summaryrefslogtreecommitdiffstats
path: root/Lib/lib2to3
Commit message (Expand)AuthorAgeFilesLines
* Issue #21408: The default __ne__() now returns NotImplemented if __eq__()Serhiy Storchaka2015-01-261-10/+0
* fix instances of consecutive articles (closes #23221)Benjamin Peterson2015-01-131-1/+1
* Issue #22823: Use set literals in lib2to3.Serhiy Storchaka2014-12-134-8/+8
* Issue #22173: Update lib2to3 tests to use unittest test discovery.Zachary Ware2014-10-295-19/+15
* Issue #22186: Fix typos in Lib/.Berker Peksag2014-10-191-1/+1
* teach 2to3 about 'yield from'Benjamin Peterson2014-04-102-1/+9
* add matrix multiplication operator support to 2to3Benjamin Peterson2014-04-105-9/+17
* Issue #19936: Added executable bits or shebang lines to Python scripts whichSerhiy Storchaka2014-01-162-0/+0
|\
| * Issue #19936: Added executable bits or shebang lines to Python scripts whichSerhiy Storchaka2014-01-162-0/+0
* | Issue #18960: Fix bugs with Python source code encoding in the second line.Serhiy Storchaka2014-01-091-0/+3
|\ \ | |/
| * Issue #18960: Fix bugs with Python source code encoding in the second line.Serhiy Storchaka2014-01-091-0/+3
* | #19943: merge with 3.3.Ezio Melotti2013-12-101-1/+1
|\ \ | |/
| * #19943: fix typo noticed by Jakub Wilk.Ezio Melotti2013-12-101-1/+1
* | #19620: merge with 3.3.Ezio Melotti2013-11-251-2/+2
|\ \ | |/
| * #19620: Fix typo in docstring (noticed by Christopher Welborn).Ezio Melotti2013-11-251-2/+2
* | #10712: 2to3 has a new "asserts" fixer that replaces deprecated names of unit...Ezio Melotti2013-11-232-0/+84
* | Issue #19592: Use specific asserts in lib2to3 tests.Serhiy Storchaka2013-11-145-17/+17
|\ \ | |/
| * Issue #19592: Use specific asserts in lib2to3 tests.Serhiy Storchaka2013-11-145-17/+17
* | Issue #18037: Do not escape '\u' and '\U' in raw strings.Serhiy Storchaka2013-10-082-3/+2
|\ \ | |/
| * Issue #18037: Do not escape '\u' and '\U' in raw strings.Serhiy Storchaka2013-10-082-3/+2
* | Issue #18037: 2to3 now escapes '\u' and '\U' in native strings.Serhiy Storchaka2013-10-032-7/+62
|\ \ | |/
| * Issue #18037: 2to3 now escapes '\u' and '\U' in native strings.Serhiy Storchaka2013-10-032-7/+62
* | merge 3.3 (#19115)Benjamin Peterson2013-09-281-5/+5
|\ \ | |/
| * fix duplicate test names (closes #19115)Benjamin Peterson2013-09-281-5/+5
* | Issue #18873: The tokenize module, IDLE, 2to3, and the findnocoding.py scriptSerhiy Storchaka2013-09-163-5/+10
|\ \ | |/
| * Issue #18873: The tokenize module, IDLE, 2to3, and the findnocoding.py scriptSerhiy Storchaka2013-09-163-5/+10
* | #18741: merge with 3.3.Ezio Melotti2013-08-173-4/+4
|\ \ | |/
| * #18741: fix more typos. Patch by Févry Thibault.Ezio Melotti2013-08-173-4/+4
* | Issue #18200: Back out usage of ModuleNotFoundError (8d28d44f3a9a)Brett Cannon2013-07-041-1/+1
* | Issue #18200: Update the stdlib (except tests) to useBrett Cannon2013-06-141-1/+1
* | Merge 3.3, issue #17047: remove doubled words found in 2.7 toTerry Jan Reedy2013-03-111-2/+2
|\ \ | |/
| * Merge 3.2, issue #17047: remove doubled words found in 2.7 toTerry Jan Reedy2013-03-111-2/+2
| |\
| | * Issue #17047: remove doubled words found in 2.7 to 3.4 Lib/*,Terry Jan Reedy2013-03-111-2/+2
* | | modernize some modules' code by using with statement around open()Giampaolo Rodola'2013-02-121-6/+4
* | | Replace IOError with OSError (#16715)Andrew Svetlov2012-12-253-4/+4
* | | Issue #16706: get rid of os.errorAndrew Svetlov2012-12-183-5/+5
* | | add fixer for reload() -> imp.reload() (closes #11797)\n\nPatch by Laurie Cla...Benjamin Peterson2012-12-084-18/+113
* | | merge 3.3 (#16573)Benjamin Peterson2012-11-292-6/+18
|\ \ \ | |/ /
| * | merge 3.2 (#16573)Benjamin Peterson2012-11-292-6/+18
| |\ \ | | |/
| | * enumerate only requires an iterable (closes #16573)Benjamin Peterson2012-11-292-6/+18
* | | Issue #16120: Use |yield from| in stdlib.Andrew Svetlov2012-10-062-10/+5
|/ /
* | merge 3.2Benjamin Peterson2012-09-252-3/+3
|\ \ | |/
| * switch assertion to an explicit ValueErrorBenjamin Peterson2012-09-252-3/+3
| * Issue #15822: Fix installation of lib2to3 grammar pickles to ensureNed Deily2012-09-091-0/+17
* | Issue #15822: Fix installation of lib2to3 grammar pickles to ensureNed Deily2012-09-091-0/+17
* | remove get_prefix and set_prefix (#13248)Benjamin Peterson2012-03-142-37/+0
* | Issue #13125: Silence spurious test_lib2to3 output when in non-verbose mode.Antoine Pitrou2012-02-271-3/+10
|\ \ | |/
| * Issue #13125: Silence spurious test_lib2to3 output when in non-verbose mode.Antoine Pitrou2012-02-271-3/+10
| * Fix use of deprecated assertRegexpMatches method.Georg Brandl2012-02-201-1/+1
| * import re for the previous commit.Gregory P. Smith2012-02-141-0/+1
th: 98.9%;'/> -rw-r--r--tcllib/modules/base64/base64c.tcl19
-rw-r--r--tcllib/modules/base64/pkgIndex.tcl5
-rw-r--r--tcllib/modules/base64/uuencode.bench46
-rw-r--r--tcllib/modules/base64/uuencode.man97
-rw-r--r--tcllib/modules/base64/uuencode.pcx74
-rw-r--r--tcllib/modules/base64/uuencode.tcl335
-rw-r--r--tcllib/modules/base64/uuencode.test193
-rw-r--r--tcllib/modules/base64/yencode.bench46
-rw-r--r--tcllib/modules/base64/yencode.man96
-rw-r--r--tcllib/modules/base64/yencode.pcx78
-rw-r--r--tcllib/modules/base64/yencode.tcl307
-rw-r--r--tcllib/modules/base64/yencode.test99
-rw-r--r--tcllib/modules/base64/yencode.test.databin0 -> 584 bytes-rw-r--r--tcllib/modules/base64/yencode.test.out17
-rw-r--r--tcllib/modules/bee/ChangeLog116
-rw-r--r--tcllib/modules/bee/bee.bench79
-rw-r--r--tcllib/modules/bee/bee.man343
-rw-r--r--tcllib/modules/bee/bee.pcx81
-rw-r--r--tcllib/modules/bee/bee.tcl990
-rw-r--r--tcllib/modules/bee/bee.test384
-rw-r--r--tcllib/modules/bee/example.torrentbin0 -> 22267 bytes-rw-r--r--tcllib/modules/bee/pkgIndex.tcl4
-rw-r--r--tcllib/modules/bench/ChangeLog541
-rw-r--r--tcllib/modules/bench/bench.man296
-rw-r--r--tcllib/modules/bench/bench.tcl553
-rw-r--r--tcllib/modules/bench/bench_intro.man91
-rw-r--r--tcllib/modules/bench/bench_lang_intro.man153
-rw-r--r--tcllib/modules/bench/bench_lang_spec.man132
-rw-r--r--tcllib/modules/bench/bench_read.man65
-rw-r--r--tcllib/modules/bench/bench_read.tcl162
-rw-r--r--tcllib/modules/bench/bench_wcsv.man54
-rw-r--r--tcllib/modules/bench/bench_wcsv.tcl101
-rw-r--r--tcllib/modules/bench/bench_wtext.man55
-rw-r--r--tcllib/modules/bench/bench_wtext.tcl165
-rw-r--r--tcllib/modules/bench/libbench.tcl561
-rw-r--r--tcllib/modules/bench/pkgIndex.tcl7
-rw-r--r--tcllib/modules/bibtex/ChangeLog98
-rw-r--r--tcllib/modules/bibtex/bibtex.man180
-rw-r--r--tcllib/modules/bibtex/bibtex.pcx85
-rw-r--r--tcllib/modules/bibtex/bibtex.tcl502
-rw-r--r--tcllib/modules/bibtex/bibtex.test236
-rw-r--r--tcllib/modules/bibtex/bytecode.bib6
-rw-r--r--tcllib/modules/bibtex/penn_sub.bib11
-rw-r--r--tcllib/modules/bibtex/pkgIndex.tcl2
-rw-r--r--tcllib/modules/blowfish/ChangeLog136
-rw-r--r--tcllib/modules/blowfish/blowfish.bench66
-rw-r--r--tcllib/modules/blowfish/blowfish.man164
-rw-r--r--tcllib/modules/blowfish/blowfish.tcl724
-rw-r--r--tcllib/modules/blowfish/blowfish.test315
-rw-r--r--tcllib/modules/blowfish/pkgIndex.tcl5
-rw-r--r--tcllib/modules/cache/ChangeLog52
-rw-r--r--tcllib/modules/cache/async.man143
-rw-r--r--tcllib/modules/cache/async.tcl185
-rw-r--r--tcllib/modules/cache/async.test230
-rw-r--r--tcllib/modules/cache/pkgIndex.tcl3
-rw-r--r--tcllib/modules/calendar/ChangeLog109
-rw-r--r--tcllib/modules/calendar/calendar.tcl18
-rw-r--r--tcllib/modules/calendar/gregorian.tcl772
-rw-r--r--tcllib/modules/calendar/gregorian.test407
-rw-r--r--tcllib/modules/calendar/pkgIndex.tcl2
-rw-r--r--tcllib/modules/calendar/tclIndex19
-rw-r--r--tcllib/modules/clock/ChangeLog16
-rw-r--r--tcllib/modules/clock/iso8601.man47
-rw-r--r--tcllib/modules/clock/iso8601.pcx43
-rw-r--r--tcllib/modules/clock/iso8601.tcl280
-rw-r--r--tcllib/modules/clock/iso8601.test220
-rw-r--r--tcllib/modules/clock/pkgIndex.tcl3
-rw-r--r--tcllib/modules/clock/rfc2822.man27
-rw-r--r--tcllib/modules/clock/rfc2822.pcx27
-rw-r--r--tcllib/modules/clock/rfc2822.tcl214
-rw-r--r--tcllib/modules/clock/rfc2822.test44
-rw-r--r--tcllib/modules/cmdline/ChangeLog340
-rw-r--r--tcllib/modules/cmdline/cmdline.man204
-rw-r--r--tcllib/modules/cmdline/cmdline.pcx78
-rw-r--r--tcllib/modules/cmdline/cmdline.tcl912
-rw-r--r--tcllib/modules/cmdline/cmdline.test553
-rw-r--r--tcllib/modules/cmdline/pkgIndex.tcl2
-rw-r--r--tcllib/modules/cmdline/typedCmdline.test470
-rw-r--r--tcllib/modules/comm/ChangeLog368
-rw-r--r--tcllib/modules/comm/comm.LICENSE48
-rw-r--r--tcllib/modules/comm/comm.man1230
-rw-r--r--tcllib/modules/comm/comm.n.html1067
-rw-r--r--tcllib/modules/comm/comm.pcx99
-rw-r--r--tcllib/modules/comm/comm.slaveboot42
-rw-r--r--tcllib/modules/comm/comm.tcl1818
-rw-r--r--tcllib/modules/comm/comm.test318
-rw-r--r--tcllib/modules/comm/comm_wire.man284
-rw-r--r--tcllib/modules/comm/pkgIndex.tcl2
-rw-r--r--tcllib/modules/common-text/tls-security-notes.inc31
-rw-r--r--tcllib/modules/control/ChangeLog252
-rw-r--r--tcllib/modules/control/ascaller.tcl72
-rw-r--r--tcllib/modules/control/assert.tcl91
-rw-r--r--tcllib/modules/control/control.man165
-rw-r--r--tcllib/modules/control/control.tcl24
-rw-r--r--tcllib/modules/control/do.tcl81
-rw-r--r--tcllib/modules/control/do.test317
-rw-r--r--tcllib/modules/control/genIndex15
-rw-r--r--tcllib/modules/control/no-op.tcl14
-rw-r--r--tcllib/modules/control/no-op.test44
-rw-r--r--tcllib/modules/control/pkgIndex.tcl2
-rw-r--r--tcllib/modules/control/tclIndex18
-rw-r--r--tcllib/modules/coroutine/ChangeLog73
-rw-r--r--tcllib/modules/coroutine/coro_auto.man46
-rw-r--r--tcllib/modules/coroutine/coro_auto.tcl316
-rw-r--r--tcllib/modules/coroutine/coroutine.pcx54
-rw-r--r--tcllib/modules/coroutine/coroutine.tcl379
-rw-r--r--tcllib/modules/coroutine/coroutine_auto.pcx23
-rw-r--r--tcllib/modules/coroutine/pkgIndex.tcl3
-rw-r--r--tcllib/modules/coroutine/tcllib_coroutine.man110
-rw-r--r--tcllib/modules/counter/ChangeLog247
-rw-r--r--tcllib/modules/counter/counter.man250
-rw-r--r--tcllib/modules/counter/counter.tcl1265
-rw-r--r--tcllib/modules/counter/counter.test235
-rw-r--r--tcllib/modules/counter/pkgIndex.tcl12
-rw-r--r--tcllib/modules/crc/ChangeLog321
-rw-r--r--tcllib/modules/crc/cksum.bench38
-rw-r--r--tcllib/modules/crc/cksum.man131
-rw-r--r--tcllib/modules/crc/cksum.pcx37
-rw-r--r--tcllib/modules/crc/cksum.tcl200
-rw-r--r--tcllib/modules/crc/cksum.test111
-rw-r--r--tcllib/modules/crc/crc16.bench38
-rw-r--r--tcllib/modules/crc/crc16.man142
-rw-r--r--tcllib/modules/crc/crc16.pcx93
-rw-r--r--tcllib/modules/crc/crc16.tcl302
-rw-r--r--tcllib/modules/crc/crc16.test233
-rw-r--r--tcllib/modules/crc/crc32.bench38
-rw-r--r--tcllib/modules/crc/crc32.man152
-rw-r--r--tcllib/modules/crc/crc32.pcx37
-rw-r--r--tcllib/modules/crc/crc32.tcl377
-rw-r--r--tcllib/modules/crc/crc32.test222
-rw-r--r--tcllib/modules/crc/crc32bugs.test104
-rw-r--r--tcllib/modules/crc/crcc.tcl22
-rw-r--r--tcllib/modules/crc/pkgIndex.tcl5
-rw-r--r--tcllib/modules/crc/sum.bench38
-rw-r--r--tcllib/modules/crc/sum.man108
-rw-r--r--tcllib/modules/crc/sum.pcx38
-rw-r--r--tcllib/modules/crc/sum.tcl285
-rw-r--r--tcllib/modules/crc/sum.test196
-rw-r--r--tcllib/modules/cron/cron.man78
-rw-r--r--tcllib/modules/cron/cron.tcl281
-rw-r--r--tcllib/modules/cron/cron.test83
-rw-r--r--tcllib/modules/cron/pkgIndex.tcl11
-rw-r--r--tcllib/modules/csv/2926387.csv4
-rw-r--r--tcllib/modules/csv/ChangeLog339
-rw-r--r--tcllib/modules/csv/csv.bench45
-rw-r--r--tcllib/modules/csv/csv.man247
-rw-r--r--tcllib/modules/csv/csv.pcx144
-rw-r--r--tcllib/modules/csv/csv.tcl789
-rw-r--r--tcllib/modules/csv/csv.test998
-rw-r--r--tcllib/modules/csv/eval.csv6
-rw-r--r--tcllib/modules/csv/mem_debug_bench.csv251
-rw-r--r--tcllib/modules/csv/mem_debug_bench_a.csv256
-rw-r--r--tcllib/modules/csv/pkgIndex.tcl2
-rw-r--r--tcllib/modules/debug/ChangeLog31
-rw-r--r--tcllib/modules/debug/caller.tcl97
-rw-r--r--tcllib/modules/debug/debug.man247
-rw-r--r--tcllib/modules/debug/debug.tcl306
-rw-r--r--tcllib/modules/debug/debug_caller.man44
-rw-r--r--tcllib/modules/debug/debug_heartbeat.man43
-rw-r--r--tcllib/modules/debug/debug_timestamp.man34
-rw-r--r--tcllib/modules/debug/heartbeat.tcl68
-rw-r--r--tcllib/modules/debug/pkgIndex.tcl5
-rw-r--r--tcllib/modules/debug/timestamp.tcl47
-rw-r--r--tcllib/modules/des/ChangeLog145
-rw-r--r--tcllib/modules/des/des.bench105
-rw-r--r--tcllib/modules/des/des.man206
-rw-r--r--tcllib/modules/des/des.tcl272
-rw-r--r--tcllib/modules/des/des.test408
-rw-r--r--tcllib/modules/des/pkgIndex.tcl7
-rw-r--r--tcllib/modules/des/tcldes.man25
-rw-r--r--tcllib/modules/des/tcldes.tcl1089
-rw-r--r--tcllib/modules/des/tcldesjr.man25
-rw-r--r--tcllib/modules/des/tcldesjr.tcl1055
-rw-r--r--tcllib/modules/devtools/ChangeLog245
-rw-r--r--tcllib/modules/devtools/README22
-rw-r--r--tcllib/modules/devtools/ca.crt17
-rw-r--r--tcllib/modules/devtools/ca.key18
-rw-r--r--tcllib/modules/devtools/ca.key.password1
-rw-r--r--tcllib/modules/devtools/coserv.tcl128
-rw-r--r--tcllib/modules/devtools/dialog.tcl346
-rw-r--r--tcllib/modules/devtools/receiver.crt18
-rw-r--r--tcllib/modules/devtools/receiver.key15
-rw-r--r--tcllib/modules/devtools/testutilities.tcl722
-rw-r--r--tcllib/modules/devtools/transmitter.crt18
-rw-r--r--tcllib/modules/devtools/transmitter.key15
-rw-r--r--tcllib/modules/dicttool/dicttool.man76
-rw-r--r--tcllib/modules/dicttool/dicttool.md62
-rw-r--r--tcllib/modules/dicttool/dicttool.tcl146
-rw-r--r--tcllib/modules/dicttool/pkgIndex.tcl11
-rw-r--r--tcllib/modules/dns/ChangeLog385
-rw-r--r--tcllib/modules/dns/dns-url.txt728
-rw-r--r--tcllib/modules/dns/dns.tcl1416
-rw-r--r--tcllib/modules/dns/dns.test73
-rw-r--r--tcllib/modules/dns/ip.tcl553
-rw-r--r--tcllib/modules/dns/ip.test271
-rw-r--r--tcllib/modules/dns/ipMore.tcl1295
-rw-r--r--tcllib/modules/dns/ipMore.test803
-rw-r--r--tcllib/modules/dns/ipMoreC.tcl242
-rw-r--r--tcllib/modules/dns/msgs/en.msg8
-rw-r--r--tcllib/modules/dns/pkgIndex.tcl9
-rw-r--r--tcllib/modules/dns/resolv.tcl249
-rw-r--r--tcllib/modules/dns/spf.tcl528
-rw-r--r--tcllib/modules/dns/spf.test244
-rw-r--r--tcllib/modules/dns/tcllib_dns.man242
-rw-r--r--tcllib/modules/dns/tcllib_ip.man451
-rw-r--r--tcllib/modules/docstrip/ChangeLog127
-rw-r--r--tcllib/modules/docstrip/docstrip.man435
-rw-r--r--tcllib/modules/docstrip/docstrip.tcl163
-rw-r--r--tcllib/modules/docstrip/docstrip.test243
-rw-r--r--tcllib/modules/docstrip/docstrip_util.man586
-rw-r--r--tcllib/modules/docstrip/docstrip_util.tcl649
-rw-r--r--tcllib/modules/docstrip/docstrip_util.test84
-rw-r--r--tcllib/modules/docstrip/pkgIndex.tcl23
-rw-r--r--tcllib/modules/docstrip/tcldocstrip.dtx4012
-rw-r--r--tcllib/modules/docstrip/tcldocstrip.ins46
-rw-r--r--tcllib/modules/docstrip/tcldocstrip.stitch25
-rw-r--r--tcllib/modules/doctools/ChangeLog1908
-rw-r--r--tcllib/modules/doctools/NOTES34
-rw-r--r--tcllib/modules/doctools/api.tcl31
-rw-r--r--tcllib/modules/doctools/api_idx.tcl26
-rw-r--r--tcllib/modules/doctools/api_toc.tcl26
-rw-r--r--tcllib/modules/doctools/changelog.man87
-rw-r--r--tcllib/modules/doctools/changelog.tcl281
-rw-r--r--tcllib/modules/doctools/checker.tcl734
-rw-r--r--tcllib/modules/doctools/checker_idx.tcl207
-rw-r--r--tcllib/modules/doctools/checker_toc.tcl214
-rw-r--r--tcllib/modules/doctools/cvs.man101
-rw-r--r--tcllib/modules/doctools/cvs.tcl136
-rw-r--r--tcllib/modules/doctools/docidx.man405
-rw-r--r--tcllib/modules/doctools/docidx.tcl962
-rw-r--r--tcllib/modules/doctools/docidx.test316
-rw-r--r--tcllib/modules/doctools/docidx_intro.man106
-rw-r--r--tcllib/modules/doctools/docidx_lang_cmdref.man116
-rw-r--r--tcllib/modules/doctools/docidx_lang_faq.man28
-rw-r--r--tcllib/modules/doctools/docidx_lang_intro.man214
-rw-r--r--tcllib/modules/doctools/docidx_lang_syntax.man120
-rw-r--r--tcllib/modules/doctools/docidx_plugin_apiref.man421
-rw-r--r--tcllib/modules/doctools/doctoc.man405
-rw-r--r--tcllib/modules/doctools/doctoc.tcl968
-rw-r--r--tcllib/modules/doctools/doctoc.test319
-rw-r--r--tcllib/modules/doctools/doctoc_intro.man105
-rw-r--r--tcllib/modules/doctools/doctoc_lang_cmdref.man127
-rw-r--r--tcllib/modules/doctools/doctoc_lang_faq.man28
-rw-r--r--tcllib/modules/doctools/doctoc_lang_intro.man297
-rw-r--r--tcllib/modules/doctools/doctoc_lang_syntax.man105
-rw-r--r--tcllib/modules/doctools/doctoc_plugin_apiref.man421
-rw-r--r--tcllib/modules/doctools/doctools.man543
-rw-r--r--tcllib/modules/doctools/doctools.tcl1361
-rw-r--r--tcllib/modules/doctools/doctools.test443
-rw-r--r--tcllib/modules/doctools/doctools_intro.man103
-rw-r--r--tcllib/modules/doctools/doctools_lang_cmdref.man470
-rw-r--r--tcllib/modules/doctools/doctools_lang_faq.man28
-rw-r--r--tcllib/modules/doctools/doctools_lang_intro.man727
-rw-r--r--tcllib/modules/doctools/doctools_lang_syntax.man142
-rw-r--r--tcllib/modules/doctools/doctools_plugin_apiref.man478
-rw-r--r--tcllib/modules/doctools/include/examples.inc30
-rw-r--r--tcllib/modules/doctools/include/placeholder.inc12
-rwxr-xr-xtcllib/modules/doctools/mpexpand153
-rwxr-xr-xtcllib/modules/doctools/mpexpand.all38
-rw-r--r--tcllib/modules/doctools/mpexpand.man107
-rw-r--r--tcllib/modules/doctools/mpformats/_common.tcl303
-rw-r--r--tcllib/modules/doctools/mpformats/_html.tcl198
-rw-r--r--tcllib/modules/doctools/mpformats/_idx_common.tcl31
-rw-r--r--tcllib/modules/doctools/mpformats/_nroff.tcl183
-rw-r--r--tcllib/modules/doctools/mpformats/_text.tcl430
-rw-r--r--tcllib/modules/doctools/mpformats/_toc_common.tcl31
-rw-r--r--tcllib/modules/doctools/mpformats/_xml.tcl236
-rw-r--r--tcllib/modules/doctools/mpformats/c.msg58
-rw-r--r--tcllib/modules/doctools/mpformats/de.msg54
-rw-r--r--tcllib/modules/doctools/mpformats/en.msg54
-rw-r--r--tcllib/modules/doctools/mpformats/fmt.desc49
-rw-r--r--tcllib/modules/doctools/mpformats/fmt.html737
-rw-r--r--tcllib/modules/doctools/mpformats/fmt.latex404
-rw-r--r--tcllib/modules/doctools/mpformats/fmt.list52
-rw-r--r--tcllib/modules/doctools/mpformats/fmt.nroff290
-rw-r--r--tcllib/modules/doctools/mpformats/fmt.null30
-rw-r--r--tcllib/modules/doctools/mpformats/fmt.text473
-rw-r--r--tcllib/modules/doctools/mpformats/fmt.tmml288
-rw-r--r--tcllib/modules/doctools/mpformats/fmt.wiki297
-rwxr-xr-xtcllib/modules/doctools/mpformats/fr.msg34
-rw-r--r--tcllib/modules/doctools/mpformats/idx.html314
-rw-r--r--tcllib/modules/doctools/mpformats/idx.nroff81
-rw-r--r--tcllib/modules/doctools/mpformats/idx.null23
-rw-r--r--tcllib/modules/doctools/mpformats/idx.text79
-rw-r--r--tcllib/modules/doctools/mpformats/idx.wiki63
-rw-r--r--tcllib/modules/doctools/mpformats/man.macros267
-rw-r--r--tcllib/modules/doctools/mpformats/toc.html129
-rw-r--r--tcllib/modules/doctools/mpformats/toc.nroff73
-rw-r--r--tcllib/modules/doctools/mpformats/toc.null23
-rw-r--r--tcllib/modules/doctools/mpformats/toc.text88
-rw-r--r--tcllib/modules/doctools/mpformats/toc.tmml37
-rw-r--r--tcllib/modules/doctools/mpformats/toc.wiki63
-rw-r--r--tcllib/modules/doctools/pkgIndex.tcl6
-rw-r--r--tcllib/modules/doctools/tests/desc/000
-rw-r--r--tcllib/modules/doctools/tests/desc/010
-rw-r--r--tcllib/modules/doctools/tests/desc/022
-rw-r--r--tcllib/modules/doctools/tests/desc/030
-rw-r--r--tcllib/modules/doctools/tests/desc/040
-rw-r--r--tcllib/modules/doctools/tests/desc/050
-rw-r--r--tcllib/modules/doctools/tests/desc/060
-rw-r--r--tcllib/modules/doctools/tests/desc/070
-rw-r--r--tcllib/modules/doctools/tests/desc/083
-rw-r--r--tcllib/modules/doctools/tests/html/00117
-rw-r--r--tcllib/modules/doctools/tests/html/01136
-rw-r--r--tcllib/modules/doctools/tests/html/02134
-rw-r--r--tcllib/modules/doctools/tests/html/03142
-rw-r--r--tcllib/modules/doctools/tests/html/04126
-rw-r--r--tcllib/modules/doctools/tests/html/05176
-rw-r--r--tcllib/modules/doctools/tests/html/06145
-rw-r--r--tcllib/modules/doctools/tests/html/07137
-rw-r--r--tcllib/modules/doctools/tests/html/08221
-rw-r--r--tcllib/modules/doctools/tests/latex/0014
-rw-r--r--tcllib/modules/doctools/tests/latex/0133
-rw-r--r--tcllib/modules/doctools/tests/latex/0223
-rw-r--r--tcllib/modules/doctools/tests/latex/0326
-rw-r--r--tcllib/modules/doctools/tests/latex/0423
-rw-r--r--tcllib/modules/doctools/tests/latex/0599
-rw-r--r--tcllib/modules/doctools/tests/latex/0654
-rw-r--r--tcllib/modules/doctools/tests/latex/0758
-rw-r--r--tcllib/modules/doctools/tests/latex/08152
-rw-r--r--tcllib/modules/doctools/tests/list/001
-rw-r--r--tcllib/modules/doctools/tests/list/011
-rw-r--r--tcllib/modules/doctools/tests/list/021
-rw-r--r--tcllib/modules/doctools/tests/list/031
-rw-r--r--tcllib/modules/doctools/tests/list/041
-rw-r--r--tcllib/modules/doctools/tests/list/051
-rw-r--r--tcllib/modules/doctools/tests/list/061
-rw-r--r--tcllib/modules/doctools/tests/list/071
-rw-r--r--tcllib/modules/doctools/tests/list/081
-rw-r--r--tcllib/modules/doctools/tests/man/003
-rw-r--r--tcllib/modules/doctools/tests/man/0123
-rw-r--r--tcllib/modules/doctools/tests/man/029
-rw-r--r--tcllib/modules/doctools/tests/man/0319
-rw-r--r--tcllib/modules/doctools/tests/man/0416
-rw-r--r--tcllib/modules/doctools/tests/man/0558
-rw-r--r--tcllib/modules/doctools/tests/man/0627
-rw-r--r--tcllib/modules/doctools/tests/man/0723
-rw-r--r--tcllib/modules/doctools/tests/man/0856
-rw-r--r--tcllib/modules/doctools/tests/nroff/0015
-rw-r--r--tcllib/modules/doctools/tests/nroff/0134
-rw-r--r--tcllib/modules/doctools/tests/nroff/0225
-rw-r--r--tcllib/modules/doctools/tests/nroff/0329
-rw-r--r--tcllib/modules/doctools/tests/nroff/0432
-rw-r--r--tcllib/modules/doctools/tests/nroff/0596
-rw-r--r--tcllib/modules/doctools/tests/nroff/0655
-rw-r--r--tcllib/modules/doctools/tests/nroff/0745
-rw-r--r--tcllib/modules/doctools/tests/nroff/08140
-rw-r--r--tcllib/modules/doctools/tests/null/000
-rw-r--r--tcllib/modules/doctools/tests/null/010
-rw-r--r--tcllib/modules/doctools/tests/null/020
-rw-r--r--tcllib/modules/doctools/tests/null/030
-rw-r--r--tcllib/modules/doctools/tests/null/040
-rw-r--r--tcllib/modules/doctools/tests/null/050
-rw-r--r--tcllib/modules/doctools/tests/null/060
-rw-r--r--tcllib/modules/doctools/tests/null/070
-rw-r--r--tcllib/modules/doctools/tests/null/080
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_arg_list6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_body4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_arg_def14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_arg_def24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_arg_def36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_call14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_call24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_call36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_cmd_def14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_cmd_def24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_cmd_def36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_def14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_def24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_def36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_enum14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_enum24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_enum36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_example14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_example24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_example36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_example_begin14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_example_begin24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_example_begin36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_item14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_item24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_item36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_list_begin14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_list_begin24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_list_begin36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_list_end14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_list_end24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_list_end36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_manpage_end5
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_opt_def14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_opt_def24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_opt_def36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_para14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_para24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_para36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_section14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_section24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_section36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_sectref14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_sectref24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_sectref36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_subsection14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_subsection24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_subsection36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_tkoption_def14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_tkoption_def24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bodycmd_tkoption_def36
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_bulletlist6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_cmd_list6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_deflist_call6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_deflist_def6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_end_open_example5
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_end_open_list5
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_end_open_mp2
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_enumlist6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_examplecmd14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_examplecmd24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_examplecmd35
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_hdrcmd_copyright14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_hdrcmd_copyright24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_hdrcmd_description14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_hdrcmd_description24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_hdrcmd_moddesc14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_hdrcmd_moddesc24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_hdrcmd_require14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_hdrcmd_require24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_hdrcmd_titledesc14
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_hdrcmd_titledesc24
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_invalidlist_list_begin5
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_listcmd_arg_def6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_listcmd_call6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_listcmd_cmd_def6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_listcmd_def6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_listcmd_enum6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_listcmd_item6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_listcmd_opt_def6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_listcmd_tkoption_def6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_mpbegin4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_arg4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_class4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_cmd4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_comment4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_const4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_emph4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_file4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_fun4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_keywords4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_method4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_namespace4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_opt4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_option4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_package4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_see_also4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_syscmd4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_term4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_type4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_uri4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_usage4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_var4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nodonecmd_widget4
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nolistcmd_section6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nolistcmd_subsection6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nolisthdr_example6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nolisthdr_example_begin6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nolisthdr_list_begin6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nolisthdr_para6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nolisthdr_sectref6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_nolisttxt7
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_opt_list6
-rw-r--r--tcllib/modules/doctools/tests/syntax/e_tkoption_list6
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_arg_list3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_body4
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_arg_def13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_arg_def23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_arg_def33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_call13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_call23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_call33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_cmd_def13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_cmd_def23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_cmd_def33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_def13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_def23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_def33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_enum13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_enum23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_enum33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_example13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_example23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_example33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_example_begin13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_example_begin23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_example_begin33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_item13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_item23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_item33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_list_begin13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_list_begin23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_list_begin33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_list_end13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_list_end23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_list_end33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_manpage_end3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_opt_def13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_opt_def23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_opt_def33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_para13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_para23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_para33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_section13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_section23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_section33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_sectref13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_sectref23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_sectref33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_subsection13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_subsection23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_subsection33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_tkoption_def13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_tkoption_def23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bodycmd_tkoption_def33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_bulletlist3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_cmd_list3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_deflist_call3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_deflist_def3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_end_open_example1
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_end_open_list1
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_end_open_mp1
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_enumlist3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_examplecmd13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_examplecmd23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_examplecmd33
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_hdrcmd_copyright13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_hdrcmd_copyright23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_hdrcmd_description13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_hdrcmd_description23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_hdrcmd_moddesc13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_hdrcmd_moddesc23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_hdrcmd_require13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_hdrcmd_require23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_hdrcmd_titledesc13
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_hdrcmd_titledesc23
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_invalidlist_list_begin3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_listcmd_arg_def3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_listcmd_call3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_listcmd_cmd_def3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_listcmd_def3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_listcmd_enum3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_listcmd_item3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_listcmd_opt_def3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_listcmd_tkoption_def3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_mpbegin3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_arg3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_class3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_cmd3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_comment3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_const3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_emph3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_file3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_fun3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_keywords3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_method3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_namespace3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_opt3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_option3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_package3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_see_also3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_syscmd3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_term3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_type3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_uri3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_usage3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_var3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nodonecmd_widget3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nolistcmd_section3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nolistcmd_subsection3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nolisthdr_example3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nolisthdr_example_begin3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nolisthdr_list_begin3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nolisthdr_para3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nolisthdr_sectref3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_nolisttxt6
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_opt_list3
-rw-r--r--tcllib/modules/doctools/tests/syntax/r_tkoption_list3
-rw-r--r--tcllib/modules/doctools/tests/text/0017
-rw-r--r--tcllib/modules/doctools/tests/text/0124
-rw-r--r--tcllib/modules/doctools/tests/text/0233
-rw-r--r--tcllib/modules/doctools/tests/text/0346
-rw-r--r--tcllib/modules/doctools/tests/text/0428
-rw-r--r--tcllib/modules/doctools/tests/text/0586
-rw-r--r--tcllib/modules/doctools/tests/text/0653
-rw-r--r--tcllib/modules/doctools/tests/text/0745
-rw-r--r--tcllib/modules/doctools/tests/text/08138
-rw-r--r--tcllib/modules/doctools/tests/tmml/0019
-rw-r--r--tcllib/modules/doctools/tests/tmml/0139
-rw-r--r--tcllib/modules/doctools/tests/tmml/0236
-rw-r--r--tcllib/modules/doctools/tests/tmml/0349
-rw-r--r--tcllib/modules/doctools/tests/tmml/0437
-rw-r--r--tcllib/modules/doctools/tests/tmml/05162
-rw-r--r--tcllib/modules/doctools/tests/tmml/0662
-rw-r--r--tcllib/modules/doctools/tests/tmml/0764
-rw-r--r--tcllib/modules/doctools/tests/tmml/08207
-rw-r--r--tcllib/modules/doctools/tests/wiki/0013
-rw-r--r--tcllib/modules/doctools/tests/wiki/0113
-rw-r--r--tcllib/modules/doctools/tests/wiki/0235
-rw-r--r--tcllib/modules/doctools/tests/wiki/0335
-rw-r--r--tcllib/modules/doctools/tests/wiki/0428
-rw-r--r--tcllib/modules/doctools/tests/wiki/0566
-rw-r--r--tcllib/modules/doctools/tests/wiki/0631
-rw-r--r--tcllib/modules/doctools/tests/wiki/0731
-rw-r--r--tcllib/modules/doctools/tests/wiki/08117
-rwxr-xr-xtcllib/modules/doctools/tocexpand136
-rw-r--r--tcllib/modules/doctools2base/ChangeLog50
-rw-r--r--tcllib/modules/doctools2base/config.tcl81
-rw-r--r--tcllib/modules/doctools2base/html.tcl209
-rw-r--r--tcllib/modules/doctools2base/html_cssdefaults.man40
-rw-r--r--tcllib/modules/doctools2base/html_cssdefaults.tcl158
-rw-r--r--tcllib/modules/doctools2base/include/feedback.inc12
-rw-r--r--tcllib/modules/doctools2base/msgcat.tcl59
-rw-r--r--tcllib/modules/doctools2base/msgcat.test51
-rw-r--r--tcllib/modules/doctools2base/nroff_manmacros.man40
-rw-r--r--tcllib/modules/doctools2base/nroff_manmacros.tcl261
-rw-r--r--tcllib/modules/doctools2base/paths.tcl76
-rw-r--r--tcllib/modules/doctools2base/pkgIndex.tcl20
-rw-r--r--tcllib/modules/doctools2base/tcl_parse.man184
-rw-r--r--tcllib/modules/doctools2base/tcl_parse.tcl800
-rw-r--r--tcllib/modules/doctools2base/tcl_parse.test80
-rw-r--r--tcllib/modules/doctools2base/tcllib_msgcat.man67
-rw-r--r--tcllib/modules/doctools2base/tests/common239
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/fail/in/1_command2
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/fail/in/2_unexpected_eof1
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/fail/in/3_unexpected_char1
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/fail/out-ec/1_command1
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/fail/out-ec/2_unexpected_eof1
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/fail/out-ec/3_unexpected_char1
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/fail/out/1_command1
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/fail/out/2_unexpected_eof1
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/fail/out/3_unexpected_char1
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/01_command11
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/02_command21
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/03_command31
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/04_command41
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/05_command51
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/06_command61
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/07_command71
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/08_command81
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/09_command_nested1
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/10_combined11
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/11_continuation12
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/12_continuation22
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/13_continuation32
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/14_emptyword11
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/15_emptyword21
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/16_text1
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/17_text_multiline2
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/in/18_command91
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/01_command14
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/02_command26
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/03_command36
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/04_command45
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/05_command55
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/06_command66
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/07_command75
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/08_command85
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/09_command_nested5
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/10_combined24
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/11_continuation16
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/12_continuation26
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/13_continuation36
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/14_emptyword15
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/15_emptyword25
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/16_text3
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/17_text_multiline4
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_data/ok/out/18_command98
-rw-r--r--tcllib/modules/doctools2base/tests/tcl_parse57
-rw-r--r--tcllib/modules/doctools2base/text.tcl216
-rw-r--r--tcllib/modules/doctools2idx/ChangeLog107
-rw-r--r--tcllib/modules/doctools2idx/container.tcl405
-rw-r--r--tcllib/modules/doctools2idx/container.test680
-rw-r--r--tcllib/modules/doctools2idx/export.tcl125
-rw-r--r--tcllib/modules/doctools2idx/export.test212
-rw-r--r--tcllib/modules/doctools2idx/export_docidx.man7
-rw-r--r--tcllib/modules/doctools2idx/export_docidx.tcl210
-rw-r--r--tcllib/modules/doctools2idx/export_docidx.test77
-rw-r--r--tcllib/modules/doctools2idx/export_html.tcl421
-rw-r--r--tcllib/modules/doctools2idx/export_html.test76
-rw-r--r--tcllib/modules/doctools2idx/export_json.tcl214
-rw-r--r--tcllib/modules/doctools2idx/export_json.test74
-rw-r--r--tcllib/modules/doctools2idx/export_nroff.tcl213
-rw-r--r--tcllib/modules/doctools2idx/export_nroff.test73
-rw-r--r--tcllib/modules/doctools2idx/export_text.tcl136
-rw-r--r--tcllib/modules/doctools2idx/export_text.test63
-rw-r--r--tcllib/modules/doctools2idx/export_wiki.tcl163
-rw-r--r--tcllib/modules/doctools2idx/export_wiki.test72
-rw-r--r--tcllib/modules/doctools2idx/idx_container.man296
-rw-r--r--tcllib/modules/doctools2idx/idx_export.man308
-rw-r--r--tcllib/modules/doctools2idx/idx_export_html.man7
-rw-r--r--tcllib/modules/doctools2idx/idx_export_json.man7
-rw-r--r--tcllib/modules/doctools2idx/idx_export_nroff.man7
-rw-r--r--tcllib/modules/doctools2idx/idx_export_text.man7
-rw-r--r--tcllib/modules/doctools2idx/idx_export_wiki.man7
-rw-r--r--tcllib/modules/doctools2idx/idx_import.man394
-rw-r--r--tcllib/modules/doctools2idx/idx_import_json.man6
-rw-r--r--tcllib/modules/doctools2idx/idx_introduction.man146
-rw-r--r--tcllib/modules/doctools2idx/idx_msgcat_c.man5
-rw-r--r--tcllib/modules/doctools2idx/idx_msgcat_de.man5
-rw-r--r--tcllib/modules/doctools2idx/idx_msgcat_en.man5
-rw-r--r--tcllib/modules/doctools2idx/idx_msgcat_fr.man5
-rw-r--r--tcllib/modules/doctools2idx/idx_parse.man175
-rw-r--r--tcllib/modules/doctools2idx/idx_structure.man129
-rw-r--r--tcllib/modules/doctools2idx/import.tcl191
-rw-r--r--tcllib/modules/doctools2idx/import.test377
-rw-r--r--tcllib/modules/doctools2idx/import_docidx.man6
-rw-r--r--tcllib/modules/doctools2idx/import_docidx.tcl91
-rw-r--r--tcllib/modules/doctools2idx/import_docidx.test92
-rw-r--r--tcllib/modules/doctools2idx/import_json.tcl78
-rw-r--r--tcllib/modules/doctools2idx/import_json.test115
-rw-r--r--tcllib/modules/doctools2idx/include/concept.inc58
-rw-r--r--tcllib/modules/doctools2idx/include/dependencies.inc44
-rw-r--r--tcllib/modules/doctools2idx/include/export/config/docidx.inc71
-rw-r--r--tcllib/modules/doctools2idx/include/export/config/html.inc203
-rw-r--r--tcllib/modules/doctools2idx/include/export/config/json.inc39
-rw-r--r--tcllib/modules/doctools2idx/include/export/config/nroff.inc40
-rw-r--r--tcllib/modules/doctools2idx/include/export/config/text.inc22
-rw-r--r--tcllib/modules/doctools2idx/include/export/config/wiki.inc42
-rw-r--r--tcllib/modules/doctools2idx/include/export/format/html.inc3
-rw-r--r--tcllib/modules/doctools2idx/include/export/format/json.inc1
-rw-r--r--tcllib/modules/doctools2idx/include/export/format/nroff.inc2
-rw-r--r--tcllib/modules/doctools2idx/include/export/format/null.inc0
-rw-r--r--tcllib/modules/doctools2idx/include/export/format/text.inc1
-rw-r--r--tcllib/modules/doctools2idx/include/export/plugin.inc55
-rw-r--r--tcllib/modules/doctools2idx/include/format/docidx.inc22
-rw-r--r--tcllib/modules/doctools2idx/include/format/json.inc54
-rw-r--r--tcllib/modules/doctools2idx/include/import/config/docidx.inc1
-rw-r--r--tcllib/modules/doctools2idx/include/import/config/json.inc1
-rw-r--r--tcllib/modules/doctools2idx/include/import/format/docidx.inc12
-rw-r--r--tcllib/modules/doctools2idx/include/import/format/json.inc2
-rw-r--r--tcllib/modules/doctools2idx/include/import/plugin.inc55
-rw-r--r--tcllib/modules/doctools2idx/include/msgcat.inc46
-rw-r--r--tcllib/modules/doctools2idx/include/serialization.inc97
-rw-r--r--tcllib/modules/doctools2idx/msgcat_c.tcl26
-rw-r--r--tcllib/modules/doctools2idx/msgcat_de.tcl26
-rw-r--r--tcllib/modules/doctools2idx/msgcat_en.tcl26
-rw-r--r--tcllib/modules/doctools2idx/msgcat_fr.tcl29
-rw-r--r--tcllib/modules/doctools2idx/parse.tcl1043
-rw-r--r--tcllib/modules/doctools2idx/parse.test153
-rw-r--r--tcllib/modules/doctools2idx/pkgIndex.tcl33
-rw-r--r--tcllib/modules/doctools2idx/structure.tcl288
-rw-r--r--tcllib/modules/doctools2idx/structure.test163
-rw-r--r--tcllib/modules/doctools2idx/tests/container358
-rw-r--r--tcllib/modules/doctools2idx/tests/data/bad_command1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/empty0
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/badtrees.tcl23
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/01_nonwhitespace11
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/02_nonwhitespace21
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/03_illegalcmd11
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/04_illegalcmd21
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/05_nestingbad11
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/06_nestingbad21
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/07_wrongargs1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/08_toomanyargs1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/09_vsetvarunknown1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/10_vsetvarerr1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/11_vsetvalueerr1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/12_incerror1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/13_incnotfound1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/14_incempty1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/15_incbadeof1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/16_incbadchar1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/17_badempty0
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/18_nobegin1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/19_manybegin5
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/20_latebegin3
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/21_noend11
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/22_noend22
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/23_manyend5
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/24_earlyend4
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/25_nobeginend2
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/26_latekey6
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/27_incbadcmd1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/28_badredef6
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/docidx/29_badredef26
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/01_nonwhitespace11
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/02_nonwhitespace21
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/03_illegalcmd11
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/04_illegalcmd21
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/05_nestingbad11
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/06_nestingbad21
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/07_wrongargs1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/08_toomanyargs1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/09_vsetvarunknown1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/10_vsetvarerr1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/11_vsetvalueerr1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/12_incerror1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/13_incnotfound1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/14_incempty1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/15_incbadeof1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/16_incbadchar1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/17_badempty1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/18_nobegin1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/19_manybegin1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/20_latebegin1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/21_noend11
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/22_noend21
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/23_manyend1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/24_earlyend1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/25_nobeginend1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/26_latekey1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/27_incbadcmd1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/28_badredef1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/ecode/29_badredef21
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/01_nonwhitespace11
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/02_nonwhitespace21
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/03_illegalcmd11
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/04_illegalcmd21
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/05_nestingbad11
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/06_nestingbad21
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/07_wrongargs1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/08_toomanyargs1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/09_vsetvarunknown1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/10_vsetvarerr1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/11_vsetvalueerr1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/12_incerror1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/13_incnotfound1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/14_incempty1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/15_incbadeof2
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/16_incbadchar2
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/17_badempty1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/18_nobegin1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/19_manybegin3
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/20_latebegin2
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/21_noend11
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/22_noend21
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/23_manyend3
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/24_earlyend1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/25_nobeginend2
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/26_latekey1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/27_incbadcmd1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/28_badredef1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/emsg/29_badredef21
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json-emsg/00_short1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json-emsg/01_tag1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json-emsg/02_cshort1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json-emsg/03_misslabel1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json-emsg/04_misstitle1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json-emsg/05_misskeywords1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json-emsg/06_missreferences1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json-emsg/10_refmismatcha1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json-emsg/11_refmismatchb1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json-emsg/12_rargs1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json-emsg/13_rtag1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json/00_short2
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json/01_tag4
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json/02_cshort4
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json/03_misslabel8
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json/04_misstitle8
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json/05_misskeywords8
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json/06_missreferences8
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json/10_refmismatcha10
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json/11_refmismatchb10
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json/12_rargs12
-rw-r--r--tcllib/modules/doctools2idx/tests/data/fail/json/13_rtag12
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx-aligned/1_nokeys2
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx-aligned/2_justkeys46
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx-aligned/3_kwic206
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx-compact/1_nokeys2
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx-compact/2_justkeys46
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx-compact/3_kwic206
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx-indalign/1_nokeys2
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx-indalign/2_justkeys46
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx-indalign/3_kwic206
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx-indented/1_nokeys2
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx-indented/2_justkeys46
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx-indented/3_kwic206
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx-ultracompact/1_nokeys1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx-ultracompact/2_justkeys1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx-ultracompact/3_kwic1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx/1_nokeys2
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx/2_justkeys51
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/docidx/3_kwic211
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/html-compact/1_nokeys20
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/html-compact/2_justkeys245
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/html-compact/3_kwic449
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/html-indented/1_nokeys20
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/html-indented/2_justkeys245
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/html-indented/3_kwic449
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/html-ultracompact/1_nokeys1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/html-ultracompact/2_justkeys1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/html-ultracompact/3_kwic1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/json-indalign/1_nokeys8
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/json-indalign/2_justkeys53
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/json-indalign/3_kwic80
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/json-indented/1_nokeys8
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/json-indented/2_justkeys53
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/json-indented/3_kwic80
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/json-ultracompact/1_nokeys1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/json-ultracompact/2_justkeys1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/json-ultracompact/3_kwic1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/json/1_nokeys8
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/json/2_justkeys53
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/json/3_kwic80
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/json/README.txt3
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/nroff-external/1_nokeys5
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/nroff-external/2_justkeys136
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/nroff-external/3_kwic660
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/nroff-inlined/1_nokeys4
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/nroff-inlined/2_justkeys135
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/nroff-inlined/3_kwic659
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/serial-print/1_nokeys1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/serial-print/2_justkeys45
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/serial-print/3_kwic205
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/serial/1_nokeys1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/serial/2_justkeys1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/serial/3_kwic1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/text/1_nokeys2
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/text/2_justkeys136
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/text/3_kwic294
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/wiki-list/1_nokeys3
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/wiki-list/2_justkeys48
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/wiki-list/3_kwic251
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/wiki-table/1_nokeys1
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/wiki-table/2_justkeys46
-rw-r--r--tcllib/modules/doctools2idx/tests/data/ok/wiki-table/3_kwic206
-rw-r--r--tcllib/modules/doctools2idx/tests/data/unexpected_char2
-rw-r--r--tcllib/modules/doctools2idx/tests/data/unexpected_eof1
-rw-r--r--tcllib/modules/doctools2idx/tests/export153
-rw-r--r--tcllib/modules/doctools2idx/tests/export_docidx5
-rw-r--r--tcllib/modules/doctools2idx/tests/export_text5
-rw-r--r--tcllib/modules/doctools2idx/tests/import174
-rw-r--r--tcllib/modules/doctools2idx/tests/import_docidx73
-rw-r--r--tcllib/modules/doctools2idx/tests/parse130
-rw-r--r--tcllib/modules/doctools2toc/ChangeLog103
-rw-r--r--tcllib/modules/doctools2toc/container.tcl545
-rw-r--r--tcllib/modules/doctools2toc/container.test53
-rw-r--r--tcllib/modules/doctools2toc/export.tcl125
-rw-r--r--tcllib/modules/doctools2toc/export.test212
-rw-r--r--tcllib/modules/doctools2toc/export_doctoc.man7
-rw-r--r--tcllib/modules/doctools2toc/export_doctoc.tcl217
-rw-r--r--tcllib/modules/doctools2toc/export_doctoc.test77
-rw-r--r--tcllib/modules/doctools2toc/export_html.tcl323
-rw-r--r--tcllib/modules/doctools2toc/export_html.test76
-rw-r--r--tcllib/modules/doctools2toc/export_json.tcl223
-rw-r--r--tcllib/modules/doctools2toc/export_json.test74
-rw-r--r--tcllib/modules/doctools2toc/export_nroff.tcl218
-rw-r--r--tcllib/modules/doctools2toc/export_nroff.test73
-rw-r--r--tcllib/modules/doctools2toc/export_text.tcl142
-rw-r--r--tcllib/modules/doctools2toc/export_text.test63
-rw-r--r--tcllib/modules/doctools2toc/export_wiki.tcl144
-rw-r--r--tcllib/modules/doctools2toc/export_wiki.test63
-rw-r--r--tcllib/modules/doctools2toc/import.tcl191
-rw-r--r--tcllib/modules/doctools2toc/import.test377
-rw-r--r--tcllib/modules/doctools2toc/import_doctoc.man6
-rw-r--r--tcllib/modules/doctools2toc/import_doctoc.tcl91
-rw-r--r--tcllib/modules/doctools2toc/import_doctoc.test92
-rw-r--r--tcllib/modules/doctools2toc/import_json.tcl77
-rw-r--r--tcllib/modules/doctools2toc/import_json.test115
-rw-r--r--tcllib/modules/doctools2toc/include/concept.inc47
-rw-r--r--tcllib/modules/doctools2toc/include/dependencies.inc44
-rw-r--r--tcllib/modules/doctools2toc/include/export/config/doctoc.inc70
-rw-r--r--tcllib/modules/doctools2toc/include/export/config/html.inc155
-rw-r--r--tcllib/modules/doctools2toc/include/export/config/json.inc39
-rw-r--r--tcllib/modules/doctools2toc/include/export/config/nroff.inc40
-rw-r--r--tcllib/modules/doctools2toc/include/export/config/text.inc21
-rw-r--r--tcllib/modules/doctools2toc/include/export/config/wiki.inc32
-rw-r--r--tcllib/modules/doctools2toc/include/export/format/html.inc3
-rw-r--r--tcllib/modules/doctools2toc/include/export/format/json.inc1
-rw-r--r--tcllib/modules/doctools2toc/include/export/format/nroff.inc2
-rw-r--r--tcllib/modules/doctools2toc/include/export/format/null.inc0
-rw-r--r--tcllib/modules/doctools2toc/include/export/format/text.inc1
-rw-r--r--tcllib/modules/doctools2toc/include/export/plugin.inc55
-rw-r--r--tcllib/modules/doctools2toc/include/format/doctoc.inc22
-rw-r--r--tcllib/modules/doctools2toc/include/format/json.inc74
-rw-r--r--tcllib/modules/doctools2toc/include/import/config/doctoc.inc1
-rw-r--r--tcllib/modules/doctools2toc/include/import/config/json.inc1
-rw-r--r--tcllib/modules/doctools2toc/include/import/format/doctoc.inc12
-rw-r--r--tcllib/modules/doctools2toc/include/import/format/json.inc2
-rw-r--r--tcllib/modules/doctools2toc/include/import/plugin.inc55
-rw-r--r--tcllib/modules/doctools2toc/include/msgcat.inc46
-rw-r--r--tcllib/modules/doctools2toc/include/serialization.inc131
-rw-r--r--tcllib/modules/doctools2toc/msgcat_c.tcl28
-rw-r--r--tcllib/modules/doctools2toc/msgcat_de.tcl28
-rw-r--r--tcllib/modules/doctools2toc/msgcat_en.tcl28
-rw-r--r--tcllib/modules/doctools2toc/msgcat_fr.tcl31
-rw-r--r--tcllib/modules/doctools2toc/parse.tcl1058
-rw-r--r--tcllib/modules/doctools2toc/parse.test153
-rw-r--r--tcllib/modules/doctools2toc/pkgIndex.tcl33
-rw-r--r--tcllib/modules/doctools2toc/structure.tcl388
-rw-r--r--tcllib/modules/doctools2toc/structure.test212
-rw-r--r--tcllib/modules/doctools2toc/tests/container379
-rw-r--r--tcllib/modules/doctools2toc/tests/container_main1003
-rw-r--r--tcllib/modules/doctools2toc/tests/data/bad_command1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/empty0
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/badtrees.tcl23
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/01_nonwhitespace11
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/02_nonwhitespace21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/03_illegalcmd11
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/04_illegalcmd21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/05_nestingbad11
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/06_nestingbad21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/07_wrongargs1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/08_toomanyargs1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/09_vsetvarunknown1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/10_vsetvarerr1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/11_vsetvalueerr1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/12_incerror1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/13_incnotfound1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/14_incempty1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/15_incbadeof1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/16_incbadchar1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/17_badempty0
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/18_nobegin1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/19_manybegin5
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/20_latebegin3
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/21_noend11
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/22_noend22
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/23_manyend5
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/24_earlyend4
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/25_nobeginend2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/26_nodivbegin3
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/27_incbadcmd1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/28_badredef4
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/29_badredef25
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/30_manydivbegin5
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/31_nodivend3
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/doctoc/32_manydivend5
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/01_nonwhitespace11
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/02_nonwhitespace21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/03_illegalcmd11
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/04_illegalcmd21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/05_nestingbad11
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/06_nestingbad21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/07_wrongargs1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/08_toomanyargs1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/09_vsetvarunknown1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/10_vsetvarerr1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/11_vsetvalueerr1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/12_incerror1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/13_incnotfound1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/14_incempty1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/15_incbadeof1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/16_incbadchar1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/17_badempty1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/18_nobegin1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/19_manybegin1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/20_latebegin1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/21_noend11
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/22_noend21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/23_manyend1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/24_earlyend1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/25_nobeginend1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/26_nodivbegin1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/27_incbadcmd1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/28_badredef1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/29_badredef21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/30_manydivbegin1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/31_nodivend1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/ecode/32_manydivend1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/01_nonwhitespace11
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/02_nonwhitespace21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/03_illegalcmd11
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/04_illegalcmd21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/05_nestingbad11
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/06_nestingbad21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/07_wrongargs1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/08_toomanyargs1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/09_vsetvarunknown1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/10_vsetvarerr1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/11_vsetvalueerr1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/12_incerror1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/13_incnotfound1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/14_incempty1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/15_incbadeof2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/16_incbadchar2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/17_badempty1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/18_nobegin1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/19_manybegin3
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/20_latebegin2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/21_noend11
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/22_noend21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/23_manyend3
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/24_earlyend1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/25_nobeginend2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/26_nodivbegin1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/27_incbadcmd1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/28_badredef1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/29_badredef21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/30_manydivbegin2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/31_nodivend2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/emsg/32_manydivend3
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/00_short1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/01_tag1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/02_cshort1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/03_misslabel1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/04_misstitle1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/05_missitems1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/07_cshort21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/08_etag1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/09_cshort32
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/10_missid1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/11_misslabel22
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/12_missdesc2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/14_dshort2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/15_misslabel33
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/16_missitems21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/19_duplabel1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/20_duplabel21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json-emsg/21_duplabel31
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/00_short2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/01_tag4
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/02_cshort4
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/03_misslabel7
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/04_misstitle7
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/05_missitems7
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/07_cshort27
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/08_etag7
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/09_cshort37
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/10_missid11
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/11_misslabel211
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/12_missdesc11
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/14_dshort7
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/15_misslabel310
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/16_missitems210
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/19_duplabel15
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/20_duplabel215
-rw-r--r--tcllib/modules/doctools2toc/tests/data/fail/json/21_duplabel315
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/1_empty2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/2_references5
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/3_toc7
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/4_toc27
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/1_empty2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/2_references5
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/3_toc7
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/4_toc27
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/1_empty2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/2_references5
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/3_toc7
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/4_toc27
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/1_empty2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/2_references5
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/3_toc7
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/4_toc27
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/1_empty1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/2_references1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/3_toc1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/4_toc21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc/1_empty2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc/2_references5
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc/3_toc7
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/doctoc/4_toc27
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/html-compact/1_empty20
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/html-compact/2_references30
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/html-compact/3_toc37
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/html-compact/4_toc237
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/html-indented/1_empty20
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/html-indented/2_references30
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/html-indented/3_toc37
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/html-indented/4_toc237
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/1_empty1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/2_references1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/3_toc1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/4_toc21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json-indalign/1_empty7
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json-indalign/2_references25
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json-indalign/3_toc31
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json-indalign/4_toc231
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json-indented/1_empty7
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json-indented/2_references25
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json-indented/3_toc31
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json-indented/4_toc231
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/1_empty1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/2_references1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/3_toc1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/4_toc21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json/1_empty7
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json/2_references25
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json/3_toc31
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/json/4_toc231
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/nroff-external/1_empty4
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/nroff-external/2_references14
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/nroff-external/3_toc19
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/nroff-external/4_toc219
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/1_empty3
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/2_references13
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/3_toc18
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/4_toc218
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/serial-print/1_empty1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/serial-print/2_references4
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/serial-print/3_toc5
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/serial-print/4_toc25
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/serial/1_empty1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/serial/2_references1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/serial/3_toc2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/serial/4_toc21
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/text/1_empty2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/text/2_references11
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/text/3_toc14
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/text/4_toc215
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/wiki/1_empty1
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/wiki/2_references5
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/wiki/3_toc6
-rw-r--r--tcllib/modules/doctools2toc/tests/data/ok/wiki/4_toc26
-rw-r--r--tcllib/modules/doctools2toc/tests/data/unexpected_char2
-rw-r--r--tcllib/modules/doctools2toc/tests/data/unexpected_eof1
-rw-r--r--tcllib/modules/doctools2toc/tests/export147
-rw-r--r--tcllib/modules/doctools2toc/tests/export_doctoc5
-rw-r--r--tcllib/modules/doctools2toc/tests/export_text5
-rw-r--r--tcllib/modules/doctools2toc/tests/import174
-rw-r--r--tcllib/modules/doctools2toc/tests/import_doctoc73
-rw-r--r--tcllib/modules/doctools2toc/tests/parse130
-rw-r--r--tcllib/modules/doctools2toc/toc_container.man370
-rw-r--r--tcllib/modules/doctools2toc/toc_export.man306
-rw-r--r--tcllib/modules/doctools2toc/toc_export_html.man7
-rw-r--r--tcllib/modules/doctools2toc/toc_export_json.man7
-rw-r--r--tcllib/modules/doctools2toc/toc_export_nroff.man7
-rw-r--r--tcllib/modules/doctools2toc/toc_export_text.man7
-rw-r--r--tcllib/modules/doctools2toc/toc_export_wiki.man7
-rw-r--r--tcllib/modules/doctools2toc/toc_import.man394
-rw-r--r--tcllib/modules/doctools2toc/toc_import_json.man6
-rw-r--r--tcllib/modules/doctools2toc/toc_introduction.man143
-rw-r--r--tcllib/modules/doctools2toc/toc_msgcat_c.man5
-rw-r--r--tcllib/modules/doctools2toc/toc_msgcat_de.man5
-rw-r--r--tcllib/modules/doctools2toc/toc_msgcat_en.man5
-rw-r--r--tcllib/modules/doctools2toc/toc_msgcat_fr.man5
-rw-r--r--tcllib/modules/doctools2toc/toc_parse.man175
-rw-r--r--tcllib/modules/doctools2toc/toc_structure.man151
-rw-r--r--tcllib/modules/dtplite/ChangeLog11
-rwxr-xr-xtcllib/modules/dtplite/dtplite.tcl1764
-rw-r--r--tcllib/modules/dtplite/pkgIndex.tcl5
-rw-r--r--tcllib/modules/dtplite/pkg_dtplite.man449
-rw-r--r--tcllib/modules/exif/ChangeLog176
-rw-r--r--tcllib/modules/exif/exif.html147
-rw-r--r--tcllib/modules/exif/exif.man80
-rw-r--r--tcllib/modules/exif/exif.pcx34
-rw-r--r--tcllib/modules/exif/exif.tcl937
-rw-r--r--tcllib/modules/exif/exif.test42
-rw-r--r--tcllib/modules/exif/exif.txt280
-rw-r--r--tcllib/modules/exif/exif.xml100
-rw-r--r--tcllib/modules/exif/noafpoint.jpgbin0 -> 1626 bytes-rw-r--r--tcllib/modules/exif/pkgIndex.tcl2
-rw-r--r--tcllib/modules/fileutil/ChangeLog1006
-rw-r--r--tcllib/modules/fileutil/cross-index-trav.inc16
-rw-r--r--tcllib/modules/fileutil/cross-index.inc12
-rw-r--r--tcllib/modules/fileutil/decode.tcl191
-rw-r--r--tcllib/modules/fileutil/filetype.test193
-rw-r--r--tcllib/modules/fileutil/fileutil.man522
-rw-r--r--tcllib/modules/fileutil/fileutil.tcl2295
-rw-r--r--tcllib/modules/fileutil/fileutil.test499
-rw-r--r--tcllib/modules/fileutil/find.setup432
-rw-r--r--tcllib/modules/fileutil/find.test367
-rw-r--r--tcllib/modules/fileutil/include/cross-index-trav.inc16
-rw-r--r--tcllib/modules/fileutil/include/cross-index.inc12
-rw-r--r--tcllib/modules/fileutil/inplace.test1129
-rw-r--r--tcllib/modules/fileutil/multi.man56
-rw-r--r--tcllib/modules/fileutil/multi.tcl28
-rw-r--r--tcllib/modules/fileutil/multi.test310
-rw-r--r--tcllib/modules/fileutil/multiop.man402
-rw-r--r--tcllib/modules/fileutil/multiop.setup49
-rw-r--r--tcllib/modules/fileutil/multiop.tcl645
-rw-r--r--tcllib/modules/fileutil/multiop.test370
-rw-r--r--tcllib/modules/fileutil/pathops.test515
-rw-r--r--tcllib/modules/fileutil/pkgIndex.tcl10
-rw-r--r--tcllib/modules/fileutil/strip.test118
-rw-r--r--tcllib/modules/fileutil/test-data/pdf4tcl_01.pdf83
-rw-r--r--tcllib/modules/fileutil/test.test665
-rw-r--r--tcllib/modules/fileutil/traverse.man165
-rw-r--r--tcllib/modules/fileutil/traverse.tcl506
-rw-r--r--tcllib/modules/fileutil/traverse.test499
-rw-r--r--tcllib/modules/ftp/ChangeLog621
-rw-r--r--tcllib/modules/ftp/README80
-rw-r--r--tcllib/modules/ftp/docs/fhelp1.html126
-rw-r--r--tcllib/modules/ftp/docs/fhelp10.html54
-rw-r--r--tcllib/modules/ftp/docs/fhelp11.html52
-rw-r--r--tcllib/modules/ftp/docs/fhelp12.html58
-rw-r--r--tcllib/modules/ftp/docs/fhelp125.html58
-rw-r--r--tcllib/modules/ftp/docs/fhelp13.html62
-rw-r--r--tcllib/modules/ftp/docs/fhelp14.html51
-rw-r--r--tcllib/modules/ftp/docs/fhelp15.html57
-rw-r--r--tcllib/modules/ftp/docs/fhelp16.html53
-rw-r--r--tcllib/modules/ftp/docs/fhelp17.html51
-rw-r--r--tcllib/modules/ftp/docs/fhelp18.html52
-rw-r--r--tcllib/modules/ftp/docs/fhelp2.html57
-rw-r--r--tcllib/modules/ftp/docs/fhelp3.html54
-rw-r--r--tcllib/modules/ftp/docs/fhelp4.html47
-rw-r--r--tcllib/modules/ftp/docs/fhelp5.html57
-rw-r--r--tcllib/modules/ftp/docs/fhelp6.html74
-rw-r--r--tcllib/modules/ftp/docs/fhelp7.html48
-rw-r--r--tcllib/modules/ftp/docs/fhelp8.html50
-rw-r--r--tcllib/modules/ftp/docs/fhelp9.html49
-rw-r--r--tcllib/modules/ftp/docs/index.html107
-rw-r--r--tcllib/modules/ftp/ftp.man440
-rw-r--r--tcllib/modules/ftp/ftp.tcl3159
-rw-r--r--tcllib/modules/ftp/ftp_geturl.man57
-rw-r--r--tcllib/modules/ftp/ftp_geturl.tcl135
-rw-r--r--tcllib/modules/ftp/pkgIndex.tcl3
-rw-r--r--tcllib/modules/ftpd/ChangeLog249
-rw-r--r--tcllib/modules/ftpd/ftpd.man279
-rw-r--r--tcllib/modules/ftpd/ftpd.tcl2064
-rw-r--r--tcllib/modules/ftpd/pkgIndex.tcl2
-rw-r--r--tcllib/modules/fumagic/ChangeLog235
-rw-r--r--tcllib/modules/fumagic/cfront.man71
-rw-r--r--tcllib/modules/fumagic/cfront.tcl396
-rw-r--r--tcllib/modules/fumagic/cgen.man63
-rw-r--r--tcllib/modules/fumagic/cgen.tcl671
-rw-r--r--tcllib/modules/fumagic/filetypes.man63
-rw-r--r--tcllib/modules/fumagic/filetypes.tcl5180
-rw-r--r--tcllib/modules/fumagic/filetypes.test186
-rw-r--r--tcllib/modules/fumagic/fileutil_magic_cfront.pcx35
-rw-r--r--tcllib/modules/fumagic/fileutil_magic_cgen.pcx35
-rw-r--r--tcllib/modules/fumagic/fileutil_magic_filetype.pcx26
-rw-r--r--tcllib/modules/fumagic/fileutil_magic_mimetype.pcx26
-rw-r--r--tcllib/modules/fumagic/fileutil_magic_rt.pcx116
-rw-r--r--tcllib/modules/fumagic/fumagic.testsupport70
-rw-r--r--tcllib/modules/fumagic/mimetypes.man60
-rw-r--r--tcllib/modules/fumagic/mimetypes.tcl583
-rw-r--r--tcllib/modules/fumagic/mimetypes.test185
-rw-r--r--tcllib/modules/fumagic/pkgIndex.tcl15
-rw-r--r--tcllib/modules/fumagic/regenerate.sh13
-rw-r--r--tcllib/modules/fumagic/rtcore.man238
-rw-r--r--tcllib/modules/fumagic/rtcore.tcl500
-rwxr-xr-xtcllib/modules/fumagic/tmc248
-rw-r--r--tcllib/modules/generator/ChangeLog11
-rw-r--r--tcllib/modules/generator/generator.man482
-rw-r--r--tcllib/modules/generator/generator.tcl378
-rw-r--r--tcllib/modules/generator/license.terms38
-rw-r--r--tcllib/modules/generator/pkgIndex.tcl3
-rw-r--r--tcllib/modules/gpx/ChangeLog44
-rw-r--r--tcllib/modules/gpx/gpx.man158
-rw-r--r--tcllib/modules/gpx/gpx.tcl294
-rw-r--r--tcllib/modules/gpx/gpx.test317
-rw-r--r--tcllib/modules/gpx/pkgIndex.tcl2
-rw-r--r--tcllib/modules/grammar_aycock/ChangeLog54
-rw-r--r--tcllib/modules/grammar_aycock/aycock-build.tcl735
-rw-r--r--tcllib/modules/grammar_aycock/aycock-debug.tcl189
-rw-r--r--tcllib/modules/grammar_aycock/aycock-runtime.tcl425
-rw-r--r--tcllib/modules/grammar_aycock/aycock.man139
-rw-r--r--tcllib/modules/grammar_aycock/aycock.test196
-rw-r--r--tcllib/modules/grammar_aycock/pkgIndex.tcl8
-rw-r--r--tcllib/modules/grammar_fa/ChangeLog368
-rw-r--r--tcllib/modules/grammar_fa/dacceptor.man102
-rw-r--r--tcllib/modules/grammar_fa/dacceptor.tcl166
-rw-r--r--tcllib/modules/grammar_fa/dacceptor.test45
-rw-r--r--tcllib/modules/grammar_fa/dexec.man183
-rw-r--r--tcllib/modules/grammar_fa/dexec.tcl188
-rw-r--r--tcllib/modules/grammar_fa/dexec.test45
-rw-r--r--tcllib/modules/grammar_fa/fa.man652
-rw-r--r--tcllib/modules/grammar_fa/fa.tcl1242
-rw-r--r--tcllib/modules/grammar_fa/fa.test44
-rw-r--r--tcllib/modules/grammar_fa/faop.man480
-rw-r--r--tcllib/modules/grammar_fa/faop.tcl1618
-rw-r--r--tcllib/modules/grammar_fa/faop.test45
-rw-r--r--tcllib/modules/grammar_fa/pkgIndex.tcl6
-rw-r--r--tcllib/modules/grammar_fa/tests/Xsupport371
-rw-r--r--tcllib/modules/grammar_fa/tests/da_accept.test84
-rw-r--r--tcllib/modules/grammar_fa/tests/da_cons.test140
-rw-r--r--tcllib/modules/grammar_fa/tests/de_cons.test157
-rw-r--r--tcllib/modules/grammar_fa/tests/de_exec.test104
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_cons.test87
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_ec.test84
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_final.test391
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_is.test59
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_is_complete.test60
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_is_deterministic.test75
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_is_epsfree.test60
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_is_useful.test715
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_next.test421
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_reach.test344
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_serial.test221
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_start.test386
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_state.test304
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_states.test76
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_symbol.test254
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_symbols.test81
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_symbols_at.test138
-rw-r--r--tcllib/modules/grammar_fa/tests/fa_useful.test344
-rw-r--r--tcllib/modules/grammar_fa/tests/faop_complete.test107
-rw-r--r--tcllib/modules/grammar_fa/tests/faop_concat.test113
-rw-r--r--tcllib/modules/grammar_fa/tests/faop_determinize.test117
-rw-r--r--tcllib/modules/grammar_fa/tests/faop_difference.test110
-rw-r--r--tcllib/modules/grammar_fa/tests/faop_intersect.test111
-rw-r--r--tcllib/modules/grammar_fa/tests/faop_kleene.test102
-rw-r--r--tcllib/modules/grammar_fa/tests/faop_minimize.test117
-rw-r--r--tcllib/modules/grammar_fa/tests/faop_optional.test102
-rw-r--r--tcllib/modules/grammar_fa/tests/faop_regex.test256
-rw-r--r--tcllib/modules/grammar_fa/tests/faop_remeps.test158
-rw-r--r--tcllib/modules/grammar_fa/tests/faop_reverse.test95
-rw-r--r--tcllib/modules/grammar_fa/tests/faop_trim.test209
-rw-r--r--tcllib/modules/grammar_fa/tests/faop_union.test113
-rw-r--r--tcllib/modules/grammar_me/ChangeLog211
-rw-r--r--tcllib/modules/grammar_me/gasm.man439
-rw-r--r--tcllib/modules/grammar_me/gasm.tcl207
-rw-r--r--tcllib/modules/grammar_me/me_ast.man134
-rw-r--r--tcllib/modules/grammar_me/me_cpu.man289
-rw-r--r--tcllib/modules/grammar_me/me_cpu.tcl103
-rw-r--r--tcllib/modules/grammar_me/me_cpu.test162
-rw-r--r--tcllib/modules/grammar_me/me_cpu.testsuite445
-rw-r--r--tcllib/modules/grammar_me/me_cpucore.man374
-rw-r--r--tcllib/modules/grammar_me/me_cpucore.tcl1156
-rw-r--r--tcllib/modules/grammar_me/me_cpucore.test163
-rw-r--r--tcllib/modules/grammar_me/me_cpucore.tests.asm-map.txt38
-rw-r--r--tcllib/modules/grammar_me/me_cpucore.tests.badasm-map.txt58
-rw-r--r--tcllib/modules/grammar_me/me_cpucore.tests.badmach-map.txt67
-rw-r--r--tcllib/modules/grammar_me/me_cpucore.tests.semantics.txt279
-rw-r--r--tcllib/modules/grammar_me/me_cpucore.testsuite419
-rw-r--r--tcllib/modules/grammar_me/me_intro.man94
-rw-r--r--tcllib/modules/grammar_me/me_tcl.man343
-rw-r--r--tcllib/modules/grammar_me/me_tcl.tcl521
-rw-r--r--tcllib/modules/grammar_me/me_tcl.test1615
-rw-r--r--tcllib/modules/grammar_me/me_util.man83
-rw-r--r--tcllib/modules/grammar_me/me_util.tcl188
-rw-r--r--tcllib/modules/grammar_me/me_util.test168
-rw-r--r--tcllib/modules/grammar_me/me_util.testsuite384
-rw-r--r--tcllib/modules/grammar_me/me_vm.man663
-rw-r--r--tcllib/modules/grammar_me/pkgIndex.tcl7
-rw-r--r--tcllib/modules/grammar_peg/ChangeLog101
-rw-r--r--tcllib/modules/grammar_peg/peg.man721
-rw-r--r--tcllib/modules/grammar_peg/peg.tcl541
-rw-r--r--tcllib/modules/grammar_peg/peg_interp.man122
-rw-r--r--tcllib/modules/grammar_peg/peg_interp.tcl350
-rw-r--r--tcllib/modules/grammar_peg/pkgIndex.tcl2
-rw-r--r--tcllib/modules/hook/ChangeLog27
-rw-r--r--tcllib/modules/hook/hook.man375
-rw-r--r--tcllib/modules/hook/hook.tcl354
-rw-r--r--tcllib/modules/hook/hook.test492
-rw-r--r--tcllib/modules/hook/license.terms38
-rw-r--r--tcllib/modules/hook/pkgIndex.tcl5
-rw-r--r--tcllib/modules/html/ChangeLog300
-rw-r--r--tcllib/modules/html/html.man476
-rw-r--r--tcllib/modules/html/html.tcl1506
-rw-r--r--tcllib/modules/html/html.test958
-rw-r--r--tcllib/modules/html/pkgIndex.tcl2
-rw-r--r--tcllib/modules/htmlparse/ChangeLog321
-rw-r--r--tcllib/modules/htmlparse/htmlparse.man266
-rw-r--r--tcllib/modules/htmlparse/htmlparse.pcx57
-rw-r--r--tcllib/modules/htmlparse/htmlparse.tcl1444
-rw-r--r--tcllib/modules/htmlparse/htmlparse.test577
-rw-r--r--tcllib/modules/htmlparse/htmlparse.tree_testsuite53
-rw-r--r--tcllib/modules/htmlparse/pkgIndex.tcl2
-rw-r--r--tcllib/modules/http/ChangeLog159
-rw-r--r--tcllib/modules/http/autoproxy.man199
-rw-r--r--tcllib/modules/http/autoproxy.pcx62
-rw-r--r--tcllib/modules/http/autoproxy.tcl539
-rw-r--r--tcllib/modules/http/pkgIndex.tcl2
-rw-r--r--tcllib/modules/httpd/content.tcl395
-rw-r--r--tcllib/modules/httpd/demos/content.file.md55
-rw-r--r--tcllib/modules/httpd/demos/content.form.md17
-rw-r--r--tcllib/modules/httpd/demos/content.md14
-rw-r--r--tcllib/modules/httpd/demos/content.proxy.md20
-rw-r--r--tcllib/modules/httpd/demos/content.scgi.md20
-rw-r--r--tcllib/modules/httpd/demos/content.server.md42
-rw-r--r--tcllib/modules/httpd/demos/docserver.tcl134
-rw-r--r--tcllib/modules/httpd/demos/index.md18
-rw-r--r--tcllib/modules/httpd/demos/operations.md30
-rw-r--r--tcllib/modules/httpd/demos/reply.md0
-rw-r--r--tcllib/modules/httpd/demos/server.md0
-rw-r--r--tcllib/modules/httpd/dispatch.tcl11
-rw-r--r--tcllib/modules/httpd/httpd.tcl665
-rw-r--r--tcllib/modules/httpd/httpd.test285
-rw-r--r--tcllib/modules/httpd/pkgIndex.tcl15
-rw-r--r--tcllib/modules/httpd/scgi-app.tcl135
-rw-r--r--tcllib/modules/httpd/scgi.test330
-rw-r--r--tcllib/modules/httpwget/pkgIndex.tcl11
-rw-r--r--tcllib/modules/httpwget/wget.tcl54
-rw-r--r--tcllib/modules/ident/ChangeLog101
-rw-r--r--tcllib/modules/ident/ident.man54
-rw-r--r--tcllib/modules/ident/ident.pcx27
-rw-r--r--tcllib/modules/ident/ident.tcl90
-rw-r--r--tcllib/modules/ident/ident.test54
-rw-r--r--tcllib/modules/ident/pkgIndex.tcl13
-rw-r--r--tcllib/modules/imap4/ChangeLog73
-rw-r--r--tcllib/modules/imap4/imap4.man367
-rw-r--r--tcllib/modules/imap4/imap4.tcl1382
-rw-r--r--tcllib/modules/imap4/pkgIndex.tcl2
-rw-r--r--tcllib/modules/inifile/ChangeLog182
-rw-r--r--tcllib/modules/inifile/ini.man100
-rw-r--r--tcllib/modules/inifile/ini.tcl403
-rw-r--r--tcllib/modules/inifile/inifile.pcx89
-rw-r--r--tcllib/modules/inifile/inifile.test218
-rw-r--r--tcllib/modules/inifile/pkgIndex.tcl2
-rw-r--r--tcllib/modules/inifile/sample.ini5
-rw-r--r--tcllib/modules/inifile/test.ini15
-rw-r--r--tcllib/modules/interp/ChangeLog108
-rw-r--r--tcllib/modules/interp/deleg_method.man49
-rw-r--r--tcllib/modules/interp/deleg_method.tcl64
-rw-r--r--tcllib/modules/interp/deleg_method.test192
-rw-r--r--tcllib/modules/interp/deleg_proc.man47
-rw-r--r--tcllib/modules/interp/deleg_proc.tcl68
-rw-r--r--tcllib/modules/interp/deleg_proc.test153
-rw-r--r--tcllib/modules/interp/interp.tcl87
-rw-r--r--tcllib/modules/interp/interp.test127
-rw-r--r--tcllib/modules/interp/pkgIndex.tcl4
-rw-r--r--tcllib/modules/interp/tcllib_interp.man74
-rw-r--r--tcllib/modules/irc/ChangeLog259
-rw-r--r--tcllib/modules/irc/irc.man239
-rw-r--r--tcllib/modules/irc/irc.tcl523
-rw-r--r--tcllib/modules/irc/picoirc.man162
-rw-r--r--tcllib/modules/irc/picoirc.tcl271
-rw-r--r--tcllib/modules/irc/pkgIndex.tcl8
-rw-r--r--tcllib/modules/javascript/ChangeLog114
-rw-r--r--tcllib/modules/javascript/javascript.man96
-rw-r--r--tcllib/modules/javascript/javascript.tcl453
-rw-r--r--tcllib/modules/javascript/pkgIndex.tcl4
-rw-r--r--tcllib/modules/jpeg/ChangeLog197
-rw-r--r--tcllib/modules/jpeg/jpeg.man196
-rw-r--r--tcllib/modules/jpeg/jpeg.pcx83
-rw-r--r--tcllib/modules/jpeg/jpeg.tcl1125
-rw-r--r--tcllib/modules/jpeg/jpeg.test503
-rw-r--r--tcllib/modules/jpeg/pkgIndex.tcl2
-rw-r--r--tcllib/modules/jpeg/testimages/1000.JPGbin0 -> 89547 bytes-rw-r--r--tcllib/modules/jpeg/testimages/1000.WxH.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/1000.exif.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/1000.info.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/1000.thumbexif.txt0
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7898.JPGbin0 -> 70940 bytes-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7898.JPG.thumbbin0 -> 6496 bytes-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7898.WxH.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7898.exif.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7898.info.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7898.thumbexif.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7917.JPGbin0 -> 48388 bytes-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7917.JPG.thumbbin0 -> 5219 bytes-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7917.WxH.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7917.exif.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7917.info.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7917.thumbexif.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7950.JPGbin0 -> 46910 bytes-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7950.JPG.thumbbin0 -> 4181 bytes-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7950.WxH.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7950.exif.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7950.info.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7950.thumbexif.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7950_none.JPGbin0 -> 37182 bytes-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7950_none.WxH.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7950_none.exif.txt0
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7950_none.info.txt1
-rw-r--r--tcllib/modules/jpeg/testimages/IMG_7950_none.thumbexif.txt0
-rw-r--r--tcllib/modules/json/ChangeLog206
-rw-r--r--tcllib/modules/json/c/json.tab.c1785
-rw-r--r--tcllib/modules/json/c/json.y551
-rw-r--r--tcllib/modules/json/c/json_y.h63
-rw-r--r--tcllib/modules/json/json.bench167
-rw-r--r--tcllib/modules/json/json.man110
-rw-r--r--tcllib/modules/json/json.pcx32
-rw-r--r--tcllib/modules/json/json.tcl282
-rw-r--r--tcllib/modules/json/json.test94
-rw-r--r--tcllib/modules/json/json.testsuite102
-rw-r--r--tcllib/modules/json/json_tcl.tcl290
-rw-r--r--tcllib/modules/json/json_write.man88
-rw-r--r--tcllib/modules/json/json_write.pcx42
-rw-r--r--tcllib/modules/json/json_write.tcl200
-rw-r--r--tcllib/modules/json/json_write.test218
-rw-r--r--tcllib/modules/json/jsonc.tcl171
-rw-r--r--tcllib/modules/json/pkgIndex.tcl7
-rw-r--r--tcllib/modules/json/tests/array.json22
-rw-r--r--tcllib/modules/json/tests/array.result1
-rw-r--r--tcllib/modules/json/tests/array.sort1
-rw-r--r--tcllib/modules/json/tests/glossary.json15
-rw-r--r--tcllib/modules/json/tests/glossary.result1
-rw-r--r--tcllib/modules/json/tests/glossary.sort1
-rw-r--r--tcllib/modules/json/tests/menu.json12
-rw-r--r--tcllib/modules/json/tests/menu.result1
-rw-r--r--tcllib/modules/json/tests/menu.sort1
-rw-r--r--tcllib/modules/json/tests/menu2.json14
-rw-r--r--tcllib/modules/json/tests/menu2.result1
-rw-r--r--tcllib/modules/json/tests/menu2.sort1
-rw-r--r--tcllib/modules/json/tests/support.tcl148
-rw-r--r--tcllib/modules/json/tests/widget.json19
-rw-r--r--tcllib/modules/json/tests/widget.result1
-rw-r--r--tcllib/modules/json/tests/widget.sort1
-rw-r--r--tcllib/modules/lambda/ChangeLog16
-rw-r--r--tcllib/modules/lambda/lambda.man89
-rw-r--r--tcllib/modules/lambda/lambda.tcl43
-rw-r--r--tcllib/modules/lambda/pkgIndex.tcl8
-rw-r--r--tcllib/modules/ldap/ChangeLog358
-rw-r--r--tcllib/modules/ldap/SASL.txt48
-rw-r--r--tcllib/modules/ldap/ldap.man525
-rw-r--r--tcllib/modules/ldap/ldap.tcl2144
-rw-r--r--tcllib/modules/ldap/ldap.test928
-rw-r--r--tcllib/modules/ldap/ldapx.man772
-rw-r--r--tcllib/modules/ldap/ldapx.tcl1794
-rw-r--r--tcllib/modules/ldap/ldapx.test375
-rw-r--r--tcllib/modules/ldap/pkgIndex.tcl7
-rw-r--r--tcllib/modules/log/ChangeLog526
-rw-r--r--tcllib/modules/log/log.man277
-rw-r--r--tcllib/modules/log/log.pcx122
-rw-r--r--tcllib/modules/log/log.tcl855
-rw-r--r--tcllib/modules/log/log.test393
-rw-r--r--tcllib/modules/log/logger.man397
-rw-r--r--tcllib/modules/log/logger.tcl1297
-rw-r--r--tcllib/modules/log/logger.test1307
-rw-r--r--tcllib/modules/log/loggerAppender.man65
-rw-r--r--tcllib/modules/log/loggerAppender.tcl449
-rw-r--r--tcllib/modules/log/loggerUtils.man149
-rw-r--r--tcllib/modules/log/loggerUtils.tcl541
-rw-r--r--tcllib/modules/log/loggerUtils.test224
-rw-r--r--tcllib/modules/log/logger_trace.test280
-rw-r--r--tcllib/modules/log/loggerperformance79
-rw-r--r--tcllib/modules/log/msgs/en.msg7
-rw-r--r--tcllib/modules/log/pkgIndex.tcl9
-rw-r--r--tcllib/modules/map/ChangeLog83
-rw-r--r--tcllib/modules/map/map_geocode_nominatim.man113
-rw-r--r--tcllib/modules/map/map_geocode_nominatim.tcl91
-rw-r--r--tcllib/modules/map/map_slippy.man189
-rw-r--r--tcllib/modules/map/map_slippy.tcl221
-rw-r--r--tcllib/modules/map/map_slippy.test144
-rw-r--r--tcllib/modules/map/map_slippy_cache.man99
-rw-r--r--tcllib/modules/map/map_slippy_cache.tcl141
-rw-r--r--tcllib/modules/map/map_slippy_fetcher.man85
-rw-r--r--tcllib/modules/map/map_slippy_fetcher.tcl183
-rw-r--r--tcllib/modules/map/pkgIndex.tcl6
-rwxr-xr-xtcllib/modules/mapproj/ChangeLog47
-rwxr-xr-xtcllib/modules/mapproj/mapproj.man308
-rwxr-xr-xtcllib/modules/mapproj/mapproj.tcl1817
-rwxr-xr-xtcllib/modules/mapproj/pkgIndex.tcl2
-rw-r--r--tcllib/modules/markdown/markdown.tcl755
-rw-r--r--tcllib/modules/markdown/pkgIndex.tcl11
-rw-r--r--tcllib/modules/math/ChangeLog1440
-rwxr-xr-xtcllib/modules/math/TODO35
-rwxr-xr-xtcllib/modules/math/bessel.tcl194
-rwxr-xr-xtcllib/modules/math/bessel.test81
-rwxr-xr-xtcllib/modules/math/bigfloat.man432
-rwxr-xr-xtcllib/modules/math/bigfloat.tcl2316
-rwxr-xr-xtcllib/modules/math/bigfloat.test683
-rw-r--r--tcllib/modules/math/bigfloat2.tcl2218
-rw-r--r--tcllib/modules/math/bigfloat2.test641
-rwxr-xr-xtcllib/modules/math/bignum.man228
-rwxr-xr-xtcllib/modules/math/bignum.tcl900
-rwxr-xr-xtcllib/modules/math/bignum.test587
-rwxr-xr-xtcllib/modules/math/calculus.CHANGES21
-rwxr-xr-xtcllib/modules/math/calculus.README21
-rwxr-xr-xtcllib/modules/math/calculus.doc311
-rwxr-xr-xtcllib/modules/math/calculus.man451
-rwxr-xr-xtcllib/modules/math/calculus.tcl1645
-rwxr-xr-xtcllib/modules/math/calculus.test680
-rwxr-xr-xtcllib/modules/math/calculus.testscript86
-rwxr-xr-xtcllib/modules/math/classic_polyns.tcl200
-rw-r--r--tcllib/modules/math/combinatorics.man108
-rw-r--r--tcllib/modules/math/combinatorics.tcl441
-rw-r--r--tcllib/modules/math/combinatorics.test323
-rwxr-xr-xtcllib/modules/math/constants.man136
-rwxr-xr-xtcllib/modules/math/constants.tcl205
-rwxr-xr-xtcllib/modules/math/constants.test56
-rwxr-xr-xtcllib/modules/math/decimal.man199
-rwxr-xr-xtcllib/modules/math/decimal.tcl1741
-rwxr-xr-xtcllib/modules/math/decimal.test45
-rwxr-xr-xtcllib/modules/math/elliptic.tcl242
-rwxr-xr-xtcllib/modules/math/elliptic.test78
-rw-r--r--tcllib/modules/math/exact.man218
-rw-r--r--tcllib/modules/math/exact.tcl4059
-rw-r--r--tcllib/modules/math/exact.test2255
-rwxr-xr-xtcllib/modules/math/exponential.tcl434
-rwxr-xr-xtcllib/modules/math/fourier.man134
-rwxr-xr-xtcllib/modules/math/fourier.tcl376
-rwxr-xr-xtcllib/modules/math/fourier.test135
-rwxr-xr-xtcllib/modules/math/fuzzy.eps.f90170
-rwxr-xr-xtcllib/modules/math/fuzzy.man133
-rwxr-xr-xtcllib/modules/math/fuzzy.tcl173
-rwxr-xr-xtcllib/modules/math/fuzzy.test387
-rwxr-xr-xtcllib/modules/math/fuzzy.testscript21
-rw-r--r--tcllib/modules/math/geometry.tcl1265
-rw-r--r--tcllib/modules/math/geometry.test520
-rwxr-xr-xtcllib/modules/math/interpolate.man299
-rwxr-xr-xtcllib/modules/math/interpolate.tcl667
-rwxr-xr-xtcllib/modules/math/interpolate.test346
-rwxr-xr-xtcllib/modules/math/kruskal.tcl154
-rwxr-xr-xtcllib/modules/math/linalg.man968
-rwxr-xr-xtcllib/modules/math/linalg.tcl2288
-rwxr-xr-xtcllib/modules/math/linalg.test855
-rwxr-xr-xtcllib/modules/math/liststat.tcl95
-rwxr-xr-xtcllib/modules/math/machineparameters.man190
-rwxr-xr-xtcllib/modules/math/machineparameters.tcl377
-rwxr-xr-xtcllib/modules/math/machineparameters.test40
-rw-r--r--tcllib/modules/math/math.man126
-rw-r--r--tcllib/modules/math/math.tcl44
-rw-r--r--tcllib/modules/math/math.test279
-rw-r--r--tcllib/modules/math/math_geometry.man456
-rw-r--r--tcllib/modules/math/misc.tcl385
-rwxr-xr-xtcllib/modules/math/mvlinreg.tcl261
-rwxr-xr-xtcllib/modules/math/numtheory.dtx952
-rw-r--r--tcllib/modules/math/numtheory.man56
-rw-r--r--tcllib/modules/math/numtheory.stitch17
-rw-r--r--tcllib/modules/math/numtheory.tcl78
-rw-r--r--tcllib/modules/math/numtheory.test208
-rwxr-xr-xtcllib/modules/math/optimize.man325
-rwxr-xr-xtcllib/modules/math/optimize.tcl1319
-rwxr-xr-xtcllib/modules/math/optimize.test634
-rwxr-xr-xtcllib/modules/math/pdf_stat.tcl2010
-rw-r--r--tcllib/modules/math/pkgIndex.tcl33
-rwxr-xr-xtcllib/modules/math/plotstat.tcl312
-rwxr-xr-xtcllib/modules/math/polynomials.man219
-rwxr-xr-xtcllib/modules/math/polynomials.tcl560
-rwxr-xr-xtcllib/modules/math/polynomials.test260
-rwxr-xr-xtcllib/modules/math/qcomplex.man302
-rwxr-xr-xtcllib/modules/math/qcomplex.tcl178
-rwxr-xr-xtcllib/modules/math/qcomplex.test250
-rwxr-xr-xtcllib/modules/math/rational_funcs.man186
-rwxr-xr-xtcllib/modules/math/rational_funcs.tcl364
-rwxr-xr-xtcllib/modules/math/roman.man51
-rwxr-xr-xtcllib/modules/math/roman.test223
-rwxr-xr-xtcllib/modules/math/romannumerals.tcl164
-rwxr-xr-xtcllib/modules/math/romberg.man340
-rwxr-xr-xtcllib/modules/math/special.man472
-rwxr-xr-xtcllib/modules/math/special.tcl301
-rwxr-xr-xtcllib/modules/math/special.test132
-rw-r--r--tcllib/modules/math/stat_kernel.tcl217
-rwxr-xr-xtcllib/modules/math/statistics.man1504
-rwxr-xr-xtcllib/modules/math/statistics.tcl1634
-rwxr-xr-xtcllib/modules/math/statistics.test1043
-rw-r--r--tcllib/modules/math/symdiff.man72
-rw-r--r--tcllib/modules/math/symdiff.tcl1229
-rw-r--r--tcllib/modules/math/symdiff.test458
-rw-r--r--tcllib/modules/math/tclIndex26
-rwxr-xr-xtcllib/modules/math/wilcoxon.tcl228
-rw-r--r--tcllib/modules/md4/ChangeLog209
-rw-r--r--tcllib/modules/md4/md4.bench46
-rw-r--r--tcllib/modules/md4/md4.c301
-rw-r--r--tcllib/modules/md4/md4.h79
-rw-r--r--tcllib/modules/md4/md4.man168
-rw-r--r--tcllib/modules/md4/md4.tcl571
-rw-r--r--tcllib/modules/md4/md4.test290
-rw-r--r--tcllib/modules/md4/md4_check.c62
-rw-r--r--tcllib/modules/md4/md4c.tcl120
-rw-r--r--tcllib/modules/md4/pkgIndex.tcl3
-rw-r--r--tcllib/modules/md5/ChangeLog308
-rw-r--r--tcllib/modules/md5/md5.c293
-rw-r--r--tcllib/modules/md5/md5.h66
-rw-r--r--tcllib/modules/md5/md5.man174
-rw-r--r--tcllib/modules/md5/md5.tcl454
-rw-r--r--tcllib/modules/md5/md5.test90
-rw-r--r--tcllib/modules/md5/md5c.tcl148
-rw-r--r--tcllib/modules/md5/md5v1.bench47
-rw-r--r--tcllib/modules/md5/md5v2.bench47
-rw-r--r--tcllib/modules/md5/md5x.tcl713
-rw-r--r--tcllib/modules/md5/md5x.test216
-rw-r--r--tcllib/modules/md5/pkgIndex.tcl3
-rw-r--r--tcllib/modules/md5crypt/ChangeLog130
-rw-r--r--tcllib/modules/md5crypt/md5crypt.bench46
-rw-r--r--tcllib/modules/md5crypt/md5crypt.man85
-rw-r--r--tcllib/modules/md5crypt/md5crypt.tcl152
-rw-r--r--tcllib/modules/md5crypt/md5crypt.test152
-rw-r--r--tcllib/modules/md5crypt/md5cryptc.tcl174
-rw-r--r--tcllib/modules/md5crypt/pkgIndex.tcl3
-rw-r--r--tcllib/modules/mime/ChangeLog796
-rw-r--r--tcllib/modules/mime/README.html880
-rw-r--r--tcllib/modules/mime/README.txt804
-rw-r--r--tcllib/modules/mime/README.xml660
-rw-r--r--tcllib/modules/mime/badmail1.txt10
-rw-r--r--tcllib/modules/mime/badmail2.txt31
-rw-r--r--tcllib/modules/mime/mime.bench59
-rw-r--r--tcllib/modules/mime/mime.man405
-rw-r--r--tcllib/modules/mime/mime.tcl4010
-rwxr-xr-xtcllib/modules/mime/mime.test609
-rw-r--r--tcllib/modules/mime/pkgIndex.tcl4
-rw-r--r--tcllib/modules/mime/rfc2629.dtd209
-rw-r--r--tcllib/modules/mime/smtp.man190
-rw-r--r--tcllib/modules/mime/smtp.tcl1508
-rw-r--r--tcllib/modules/multiplexer/ChangeLog136
-rw-r--r--tcllib/modules/multiplexer/multiplexer.man130
-rw-r--r--tcllib/modules/multiplexer/multiplexer.tcl291
-rw-r--r--tcllib/modules/multiplexer/multiplexer.test218
-rw-r--r--tcllib/modules/multiplexer/pkgIndex.tcl12
-rw-r--r--tcllib/modules/namespacex/ChangeLog34
-rw-r--r--tcllib/modules/namespacex/namespacex.man73
-rw-r--r--tcllib/modules/namespacex/namespacex.tcl254
-rw-r--r--tcllib/modules/namespacex/namespacex.test351
-rw-r--r--tcllib/modules/namespacex/pkgIndex.tcl5
-rw-r--r--tcllib/modules/ncgi/ChangeLog373
-rw-r--r--tcllib/modules/ncgi/formdata.txt24
-rw-r--r--tcllib/modules/ncgi/ncgi.man313
-rw-r--r--tcllib/modules/ncgi/ncgi.tcl1120
-rw-r--r--tcllib/modules/ncgi/ncgi.test854
-rw-r--r--tcllib/modules/ncgi/pkgIndex.tcl2
-rw-r--r--tcllib/modules/nettool/available_ports.tcl759
-rw-r--r--tcllib/modules/nettool/generic.tcl98
-rw-r--r--tcllib/modules/nettool/locateport.tcl75
-rw-r--r--tcllib/modules/nettool/nettool.man143
-rw-r--r--tcllib/modules/nettool/nettool.tcl72
-rw-r--r--tcllib/modules/nettool/nettool.test101
-rw-r--r--tcllib/modules/nettool/pkgIndex.tcl11
-rw-r--r--tcllib/modules/nettool/platform_unix.tcl23
-rw-r--r--tcllib/modules/nettool/platform_unix_linux.tcl224
-rw-r--r--tcllib/modules/nettool/platform_unix_macosx.tcl232
-rw-r--r--tcllib/modules/nettool/platform_windows.tcl135
-rw-r--r--tcllib/modules/nettool/scripts/build_services.tcl83
-rw-r--r--tcllib/modules/nettool/service-names-port-numbers.csv14396
-rw-r--r--tcllib/modules/nmea/ChangeLog101
-rw-r--r--tcllib/modules/nmea/nmea.man102
-rwxr-xr-xtcllib/modules/nmea/nmea.tcl197
-rw-r--r--tcllib/modules/nmea/pkgIndex.tcl2
-rw-r--r--tcllib/modules/nns/ChangeLog192
-rw-r--r--tcllib/modules/nns/common.tcl38
-rw-r--r--tcllib/modules/nns/common.test34
-rw-r--r--tcllib/modules/nns/nns.tcl432
-rw-r--r--tcllib/modules/nns/nns_auto.man119
-rw-r--r--tcllib/modules/nns/nns_auto.tcl443
-rw-r--r--tcllib/modules/nns/nns_client.man338
-rw-r--r--tcllib/modules/nns/nns_cluster.tcl499
-rw-r--r--tcllib/modules/nns/nns_cluster.test195
-rw-r--r--tcllib/modules/nns/nns_common.man47
-rw-r--r--tcllib/modules/nns/nns_intro.man128
-rw-r--r--tcllib/modules/nns/nns_protocol.man182
-rw-r--r--tcllib/modules/nns/nns_server.man145
-rw-r--r--tcllib/modules/nns/pkgIndex.tcl10
-rw-r--r--tcllib/modules/nns/server.tcl385
-rw-r--r--tcllib/modules/nntp/ChangeLog154
-rw-r--r--tcllib/modules/nntp/nntp.man338
-rw-r--r--tcllib/modules/nntp/nntp.tcl979
-rw-r--r--tcllib/modules/nntp/pkgIndex.tcl12
-rw-r--r--tcllib/modules/ntp/ChangeLog201
-rw-r--r--tcllib/modules/ntp/ntp_time.man131
-rw-r--r--tcllib/modules/ntp/pkgIndex.tcl2
-rw-r--r--tcllib/modules/ntp/time.tcl382
-rw-r--r--tcllib/modules/ntp/time.test162
-rw-r--r--tcllib/modules/oauth/oauth.man191
-rw-r--r--tcllib/modules/oauth/oauth.tcl291
-rw-r--r--tcllib/modules/oauth/pkgIndex.tcl2
-rw-r--r--tcllib/modules/oodialect/oodialect.demo62
-rw-r--r--tcllib/modules/oodialect/oodialect.md63
-rw-r--r--tcllib/modules/oodialect/oodialect.tcl245
-rw-r--r--tcllib/modules/oodialect/oodialect.test162
-rw-r--r--tcllib/modules/oodialect/pkgIndex.tcl11
-rw-r--r--tcllib/modules/oometa/oometa.demo27
-rw-r--r--tcllib/modules/oometa/oometa.md132
-rw-r--r--tcllib/modules/oometa/oometa.tcl377
-rw-r--r--tcllib/modules/oometa/oometa.test176
-rw-r--r--tcllib/modules/oometa/oooption.tcl168
-rw-r--r--tcllib/modules/oometa/pkgIndex.tcl8
-rw-r--r--tcllib/modules/ooutil/ChangeLog28
-rw-r--r--tcllib/modules/ooutil/ooutil.man165
-rw-r--r--tcllib/modules/ooutil/ooutil.tcl189
-rw-r--r--tcllib/modules/ooutil/ooutil.test84
-rw-r--r--tcllib/modules/ooutil/pkgIndex.tcl7
-rw-r--r--tcllib/modules/otp/ChangeLog59
-rw-r--r--tcllib/modules/otp/otp.man95
-rw-r--r--tcllib/modules/otp/otp.tcl430
-rw-r--r--tcllib/modules/otp/otp.test146
-rw-r--r--tcllib/modules/otp/pkgIndex.tcl3
-rw-r--r--tcllib/modules/page/ChangeLog419
-rw-r--r--tcllib/modules/page/NOTES.txt64
-rw-r--r--tcllib/modules/page/analysis_peg_emodes.tcl458
-rw-r--r--tcllib/modules/page/analysis_peg_minimize.tcl51
-rw-r--r--tcllib/modules/page/analysis_peg_reachable.tcl150
-rw-r--r--tcllib/modules/page/analysis_peg_realizable.tcl257
-rw-r--r--tcllib/modules/page/compiler_peg_mecpu.tcl1642
-rw-r--r--tcllib/modules/page/gen_peg_canon.tcl481
-rw-r--r--tcllib/modules/page/gen_peg_cpkg.tcl171
-rw-r--r--tcllib/modules/page/gen_peg_hb.tcl79
-rw-r--r--tcllib/modules/page/gen_peg_me.tcl888
-rw-r--r--tcllib/modules/page/gen_peg_me.template61
-rw-r--r--tcllib/modules/page/gen_peg_mecpu.tcl289
-rw-r--r--tcllib/modules/page/gen_peg_mecpu.template48
-rw-r--r--tcllib/modules/page/gen_peg_ser.tcl63
-rw-r--r--tcllib/modules/page/gen_tree_text.tcl94
-rw-r--r--tcllib/modules/page/notes/doc_emodes.txt180
-rw-r--r--tcllib/modules/page/notes/doc_emodes_alg.txt171
-rw-r--r--tcllib/modules/page/notes/doc_grammar.txt68
-rw-r--r--tcllib/modules/page/notes/doc_normalize.txt138
-rw-r--r--tcllib/modules/page/notes/doc_reachable.txt71
-rw-r--r--tcllib/modules/page/notes/doc_realizable.txt101
-rw-r--r--tcllib/modules/page/page_intro.man35
-rw-r--r--tcllib/modules/page/page_pluginmgr.man800
-rw-r--r--tcllib/modules/page/page_util_flow.man96
-rw-r--r--tcllib/modules/page/page_util_norm_lemon.man51
-rw-r--r--tcllib/modules/page/page_util_norm_peg.man105
-rw-r--r--tcllib/modules/page/page_util_peg.man108
-rw-r--r--tcllib/modules/page/page_util_quote.man62
-rw-r--r--tcllib/modules/page/parse_lemon.tcl7420
-rw-r--r--tcllib/modules/page/parse_peg.tcl4415
-rw-r--r--tcllib/modules/page/parse_peghb.tcl118
-rw-r--r--tcllib/modules/page/parse_pegser.tcl99
-rw-r--r--tcllib/modules/page/peg_grammar.peg86
-rw-r--r--tcllib/modules/page/peg_grammar.tcl117
-rw-r--r--tcllib/modules/page/pkgIndex.tcl80
-rw-r--r--tcllib/modules/page/pluginmgr.tcl581
-rw-r--r--tcllib/modules/page/plugins/config_peg.tcl14
-rw-r--r--tcllib/modules/page/plugins/pkgIndex.tcl34
-rw-r--r--tcllib/modules/page/plugins/reader_hb.tcl114
-rw-r--r--tcllib/modules/page/plugins/reader_lemon.tcl170
-rw-r--r--tcllib/modules/page/plugins/reader_peg.tcl169
-rw-r--r--tcllib/modules/page/plugins/reader_ser.tcl114
-rw-r--r--tcllib/modules/page/plugins/reader_treeser.tcl116
-rw-r--r--tcllib/modules/page/plugins/transform_mecpu.tcl107
-rw-r--r--tcllib/modules/page/plugins/transform_reachable.tcl107
-rw-r--r--tcllib/modules/page/plugins/transform_realizable.tcl106
-rw-r--r--tcllib/modules/page/plugins/writer_hb.tcl106
-rw-r--r--tcllib/modules/page/plugins/writer_identity.tcl98
-rw-r--r--tcllib/modules/page/plugins/writer_me.tcl115
-rw-r--r--tcllib/modules/page/plugins/writer_mecpu.tcl116
-rw-r--r--tcllib/modules/page/plugins/writer_null.tcl97
-rw-r--r--tcllib/modules/page/plugins/writer_peg.tcl106
-rw-r--r--tcllib/modules/page/plugins/writer_ser.tcl104
-rw-r--r--tcllib/modules/page/plugins/writer_tpc.tcl105
-rw-r--r--tcllib/modules/page/plugins/writer_tree.tcl105
-rw-r--r--tcllib/modules/page/util_flow.tcl90
-rw-r--r--tcllib/modules/page/util_norm_lemon.tcl427
-rw-r--r--tcllib/modules/page/util_norm_peg.tcl415
-rw-r--r--tcllib/modules/page/util_peg.tcl209
-rw-r--r--tcllib/modules/page/util_quote.tcl173
-rw-r--r--tcllib/modules/pki/CA.crt24
-rw-r--r--tcllib/modules/pki/CA.key30
-rw-r--r--tcllib/modules/pki/ChangeLog30
-rw-r--r--tcllib/modules/pki/pkgIndex.tcl1
-rw-r--r--tcllib/modules/pki/pki.man302
-rw-r--r--tcllib/modules/pki/pki.tcl1884
-rw-r--r--tcllib/modules/pki/pki.test403
-rw-r--r--tcllib/modules/pki/test-v1.crt20
-rw-r--r--tcllib/modules/pki/test-v3.crt20
-rw-r--r--tcllib/modules/pki/test.csr17
-rw-r--r--tcllib/modules/pki/test.key.aes30
-rw-r--r--tcllib/modules/pki/test.key.des30
-rw-r--r--tcllib/modules/pluginmgr/ChangeLog117
-rw-r--r--tcllib/modules/pluginmgr/pkgIndex.tcl2
-rw-r--r--tcllib/modules/pluginmgr/pluginmgr.man427
-rw-r--r--tcllib/modules/pluginmgr/pluginmgr.tcl421
-rw-r--r--tcllib/modules/png/ChangeLog145
-rw-r--r--tcllib/modules/png/pkgIndex.tcl2
-rw-r--r--tcllib/modules/png/png.man141
-rw-r--r--tcllib/modules/png/png.pcx61
-rw-r--r--tcllib/modules/png/png.tcl289
-rw-r--r--tcllib/modules/png/png.test306
-rw-r--r--tcllib/modules/png/testimages/basi0g01.pngbin0 -> 217 bytes-rw-r--r--tcllib/modules/png/testimages/basi0g02.pngbin0 -> 154 bytes-rw-r--r--tcllib/modules/png/testimages/basi0g04.pngbin0 -> 247 bytes-rw-r--r--tcllib/modules/png/testimages/basi0g08.pngbin0 -> 254 bytes-rw-r--r--tcllib/modules/png/testimages/basi0g16.pngbin0 -> 299 bytes-rw-r--r--tcllib/modules/png/testimages/basi2c08.pngbin0 -> 315 bytes-rw-r--r--tcllib/modules/png/testimages/basi2c16.pngbin0 -> 595 bytes-rw-r--r--tcllib/modules/png/testimages/basi3p01.pngbin0 -> 132 bytes-rw-r--r--tcllib/modules/png/testimages/basi3p02.pngbin0 -> 193 bytes-rw-r--r--tcllib/modules/png/testimages/basi3p04.pngbin0 -> 327 bytes-rw-r--r--tcllib/modules/png/testimages/basi3p08.pngbin0 -> 1527 bytes-rw-r--r--tcllib/modules/png/testimages/basi4a08.pngbin0 -> 214 bytes-rw-r--r--tcllib/modules/png/testimages/basi4a16.pngbin0 -> 2855 bytes-rw-r--r--tcllib/modules/png/testimages/basi6a08.pngbin0 -> 361 bytes-rw-r--r--tcllib/modules/png/testimages/basi6a16.pngbin0 -> 4180 bytes-rw-r--r--tcllib/modules/png/testimages/basn0g01.pngbin0 -> 164 bytes-rw-r--r--tcllib/modules/png/testimages/basn0g02.pngbin0 -> 104 bytes-rw-r--r--tcllib/modules/png/testimages/basn0g04.pngbin0 -> 145 bytes-rw-r--r--tcllib/modules/png/testimages/basn0g08.pngbin0 -> 138 bytes-rw-r--r--tcllib/modules/png/testimages/basn0g16.pngbin0 -> 167 bytes-rw-r--r--tcllib/modules/png/testimages/basn2c08.pngbin0 -> 145 bytes-rw-r--r--tcllib/modules/png/testimages/basn2c16.pngbin0 -> 302 bytes-rw-r--r--tcllib/modules/png/testimages/basn3p01.pngbin0 -> 112 bytes-rw-r--r--tcllib/modules/png/testimages/basn3p02.pngbin0 -> 146 bytes-rw-r--r--tcllib/modules/png/testimages/basn3p04.pngbin0 -> 216 bytes-rw-r--r--tcllib/modules/png/testimages/basn3p08.pngbin0 -> 1286 bytes-rw-r--r--tcllib/modules/png/testimages/basn4a08.pngbin0 -> 126 bytes-rw-r--r--tcllib/modules/png/testimages/basn4a16.pngbin0 -> 2206 bytes-rw-r--r--tcllib/modules/png/testimages/basn6a08.pngbin0 -> 184 bytes-rw-r--r--tcllib/modules/png/testimages/basn6a16.pngbin0 -> 3435 bytes-rw-r--r--tcllib/modules/png/testimages/bgai4a08.pngbin0 -> 214 bytes-rw-r--r--tcllib/modules/png/testimages/bgai4a16.pngbin0 -> 2855 bytes-rw-r--r--tcllib/modules/png/testimages/bgan6a08.pngbin0 -> 184 bytes-rw-r--r--tcllib/modules/png/testimages/bgan6a16.pngbin0 -> 3435 bytes-rw-r--r--tcllib/modules/png/testimages/bgbn4a08.pngbin0 -> 140 bytes-rw-r--r--tcllib/modules/png/testimages/bggn4a16.pngbin0 -> 2220 bytes-rw-r--r--tcllib/modules/png/testimages/bgwn6a08.pngbin0 -> 202 bytes-rw-r--r--tcllib/modules/png/testimages/bgyn6a16.pngbin0 -> 3453 bytes-rw-r--r--tcllib/modules/png/testimages/ccwn2c08.pngbin0 -> 1514 bytes-rw-r--r--tcllib/modules/png/testimages/ccwn3p08.pngbin0 -> 1554 bytes-rw-r--r--tcllib/modules/png/testimages/cdfn2c08.pngbin0 -> 404 bytes-rw-r--r--tcllib/modules/png/testimages/cdhn2c08.pngbin0 -> 344 bytes-rw-r--r--tcllib/modules/png/testimages/cdsn2c08.pngbin0 -> 232 bytes-rw-r--r--tcllib/modules/png/testimages/cdun2c08.pngbin0 -> 724 bytes-rw-r--r--tcllib/modules/png/testimages/ch1n3p04.pngbin0 -> 258 bytes-rw-r--r--tcllib/modules/png/testimages/ch2n3p08.pngbin0 -> 1810 bytes-rw-r--r--tcllib/modules/png/testimages/cm0n0g04.pngbin0 -> 292 bytes-rw-r--r--tcllib/modules/png/testimages/cm7n0g04.pngbin0 -> 292 bytes-rw-r--r--tcllib/modules/png/testimages/cm9n0g04.pngbin0 -> 292 bytes-rw-r--r--tcllib/modules/png/testimages/cs3n2c16.pngbin0 -> 214 bytes-rw-r--r--tcllib/modules/png/testimages/cs3n3p08.pngbin0 -> 259 bytes-rw-r--r--tcllib/modules/png/testimages/cs5n2c08.pngbin0 -> 186 bytes-rw-r--r--tcllib/modules/png/testimages/cs5n3p08.pngbin0 -> 271 bytes-rw-r--r--tcllib/modules/png/testimages/cs8n2c08.pngbin0 -> 149 bytes-rw-r--r--tcllib/modules/png/testimages/cs8n3p08.pngbin0 -> 256 bytes-rw-r--r--tcllib/modules/png/testimages/ct0n0g04.pngbin0 -> 273 bytes-rw-r--r--tcllib/modules/png/testimages/ct1n0g04.pngbin0 -> 792 bytes-rw-r--r--tcllib/modules/png/testimages/ctzn0g04.pngbin0 -> 753 bytes-rw-r--r--tcllib/modules/png/testimages/f00n0g08.pngbin0 -> 319 bytes-rw-r--r--tcllib/modules/png/testimages/f00n2c08.pngbin0 -> 2475 bytes-rw-r--r--tcllib/modules/png/testimages/f01n0g08.pngbin0 -> 321 bytes-rw-r--r--tcllib/modules/png/testimages/f01n2c08.pngbin0 -> 1180 bytes-rw-r--r--tcllib/modules/png/testimages/f02n0g08.pngbin0 -> 355 bytes-rw-r--r--tcllib/modules/png/testimages/f02n2c08.pngbin0 -> 1729 bytes-rw-r--r--tcllib/modules/png/testimages/f03n0g08.pngbin0 -> 389 bytes-rw-r--r--tcllib/modules/png/testimages/f03n2c08.pngbin0 -> 1291 bytes-rw-r--r--tcllib/modules/png/testimages/f04n0g08.pngbin0 -> 269 bytes-rw-r--r--tcllib/modules/png/testimages/f04n2c08.pngbin0 -> 985 bytes-rw-r--r--tcllib/modules/png/testimages/g03n0g16.pngbin0 -> 345 bytes-rw-r--r--tcllib/modules/png/testimages/g03n2c08.pngbin0 -> 370 bytes-rw-r--r--tcllib/modules/png/testimages/g03n3p04.pngbin0 -> 214 bytes-rw-r--r--tcllib/modules/png/testimages/g04n0g16.pngbin0 -> 363 bytes-rw-r--r--tcllib/modules/png/testimages/g04n2c08.pngbin0 -> 377 bytes-rw-r--r--tcllib/modules/png/testimages/g04n3p04.pngbin0 -> 219 bytes-rw-r--r--tcllib/modules/png/testimages/g05n0g16.pngbin0 -> 339 bytes-rw-r--r--tcllib/modules/png/testimages/g05n2c08.pngbin0 -> 350 bytes-rw-r--r--tcllib/modules/png/testimages/g05n3p04.pngbin0 -> 206 bytes-rw-r--r--tcllib/modules/png/testimages/g07n0g16.pngbin0 -> 321 bytes-rw-r--r--tcllib/modules/png/testimages/g07n2c08.pngbin0 -> 340 bytes-rw-r--r--tcllib/modules/png/testimages/g07n3p04.pngbin0 -> 207 bytes-rw-r--r--tcllib/modules/png/testimages/g10n0g16.pngbin0 -> 262 bytes-rw-r--r--tcllib/modules/png/testimages/g10n2c08.pngbin0 -> 285 bytes-rw-r--r--tcllib/modules/png/testimages/g10n3p04.pngbin0 -> 214 bytes-rw-r--r--tcllib/modules/png/testimages/g25n0g16.pngbin0 -> 383 bytes-rw-r--r--tcllib/modules/png/testimages/g25n2c08.pngbin0 -> 405 bytes-rw-r--r--tcllib/modules/png/testimages/g25n3p04.pngbin0 -> 215 bytes-rw-r--r--tcllib/modules/png/testimages/oi1n0g16.pngbin0 -> 167 bytes-rw-r--r--tcllib/modules/png/testimages/oi1n2c16.pngbin0 -> 302 bytes-rw-r--r--tcllib/modules/png/testimages/oi2n0g16.pngbin0 -> 179 bytes-rw-r--r--tcllib/modules/png/testimages/oi2n2c16.pngbin0 -> 314 bytes-rw-r--r--tcllib/modules/png/testimages/oi4n0g16.pngbin0 -> 203 bytes-rw-r--r--tcllib/modules/png/testimages/oi4n2c16.pngbin0 -> 338 bytes-rw-r--r--tcllib/modules/png/testimages/oi9n0g16.pngbin0 -> 1283 bytes-rw-r--r--tcllib/modules/png/testimages/oi9n2c16.pngbin0 -> 3038 bytes-rw-r--r--tcllib/modules/png/testimages/pngsuite.doc520
-rw-r--r--tcllib/modules/png/testimages/pngsuite_logo.pngbin0 -> 2262 bytes-rw-r--r--tcllib/modules/png/testimages/pp0n2c16.pngbin0 -> 962 bytes-rw-r--r--tcllib/modules/png/testimages/pp0n6a08.pngbin0 -> 818 bytes-rw-r--r--tcllib/modules/png/testimages/ps1n0g08.pngbin0 -> 1477 bytes-rw-r--r--tcllib/modules/png/testimages/ps1n2c16.pngbin0 -> 1641 bytes-rw-r--r--tcllib/modules/png/testimages/ps2n0g08.pngbin0 -> 2341 bytes-rw-r--r--tcllib/modules/png/testimages/ps2n2c16.pngbin0 -> 2505 bytes-rw-r--r--tcllib/modules/png/testimages/s01i3p01.pngbin0 -> 113 bytes-rw-r--r--tcllib/modules/png/testimages/s01n3p01.pngbin0 -> 113 bytes-rw-r--r--tcllib/modules/png/testimages/s02i3p01.pngbin0 -> 114 bytes-rw-r--r--tcllib/modules/png/testimages/s02n3p01.pngbin0 -> 115 bytes-rw-r--r--tcllib/modules/png/testimages/s03i3p01.pngbin0 -> 118 bytes-rw-r--r--tcllib/modules/png/testimages/s03n3p01.pngbin0 -> 120 bytes-rw-r--r--tcllib/modules/png/testimages/s04i3p01.pngbin0 -> 126 bytes-rw-r--r--tcllib/modules/png/testimages/s04n3p01.pngbin0 -> 121 bytes-rw-r--r--tcllib/modules/png/testimages/s05i3p02.pngbin0 -> 134 bytes-rw-r--r--tcllib/modules/png/testimages/s05n3p02.pngbin0 -> 129 bytes-rw-r--r--tcllib/modules/png/testimages/s06i3p02.pngbin0 -> 143 bytes-rw-r--r--tcllib/modules/png/testimages/s06n3p02.pngbin0 -> 131 bytes-rw-r--r--tcllib/modules/png/testimages/s07i3p02.pngbin0 -> 149 bytes-rw-r--r--tcllib/modules/png/testimages/s07n3p02.pngbin0 -> 138 bytes-rw-r--r--tcllib/modules/png/testimages/s08i3p02.pngbin0 -> 149 bytes-rw-r--r--tcllib/modules/png/testimages/s08n3p02.pngbin0 -> 139 bytes-rw-r--r--tcllib/modules/png/testimages/s09i3p02.pngbin0 -> 147 bytes-rw-r--r--tcllib/modules/png/testimages/s09n3p02.pngbin0 -> 143 bytes-rw-r--r--tcllib/modules/png/testimages/s32i3p04.pngbin0 -> 355 bytes-rw-r--r--tcllib/modules/png/testimages/s32n3p04.pngbin0 -> 263 bytes-rw-r--r--tcllib/modules/png/testimages/s33i3p04.pngbin0 -> 385 bytes-rw-r--r--tcllib/modules/png/testimages/s33n3p04.pngbin0 -> 329 bytes-rw-r--r--tcllib/modules/png/testimages/s34i3p04.pngbin0 -> 349 bytes-rw-r--r--tcllib/modules/png/testimages/s34n3p04.pngbin0 -> 248 bytes-rw-r--r--tcllib/modules/png/testimages/s35i3p04.pngbin0 -> 399 bytes-rw-r--r--tcllib/modules/png/testimages/s35n3p04.pngbin0 -> 338 bytes-rw-r--r--tcllib/modules/png/testimages/s36i3p04.pngbin0 -> 356 bytes-rw-r--r--tcllib/modules/png/testimages/s36n3p04.pngbin0 -> 258 bytes-rw-r--r--tcllib/modules/png/testimages/s37i3p04.pngbin0 -> 393 bytes-rw-r--r--tcllib/modules/png/testimages/s37n3p04.pngbin0 -> 336 bytes-rw-r--r--tcllib/modules/png/testimages/s38i3p04.pngbin0 -> 357 bytes-rw-r--r--tcllib/modules/png/testimages/s38n3p04.pngbin0 -> 245 bytes-rw-r--r--tcllib/modules/png/testimages/s39i3p04.pngbin0 -> 420 bytes-rw-r--r--tcllib/modules/png/testimages/s39n3p04.pngbin0 -> 352 bytes-rw-r--r--tcllib/modules/png/testimages/s40i3p04.pngbin0 -> 357 bytes-rw-r--r--tcllib/modules/png/testimages/s40n3p04.pngbin0 -> 256 bytes-rw-r--r--tcllib/modules/png/testimages/tbbn1g04.pngbin0 -> 419 bytes-rw-r--r--tcllib/modules/png/testimages/tbbn2c16.pngbin0 -> 1994 bytes-rw-r--r--tcllib/modules/png/testimages/tbbn3p08.pngbin0 -> 1128 bytes-rw-r--r--tcllib/modules/png/testimages/tbgn2c16.pngbin0 -> 1994 bytes-rw-r--r--tcllib/modules/png/testimages/tbgn3p08.pngbin0 -> 1128 bytes-rw-r--r--tcllib/modules/png/testimages/tbrn2c08.pngbin0 -> 1347 bytes-rw-r--r--tcllib/modules/png/testimages/tbwn1g16.pngbin0 -> 1146 bytes-rw-r--r--tcllib/modules/png/testimages/tbwn3p08.pngbin0 -> 1131 bytes-rw-r--r--tcllib/modules/png/testimages/tbyn3p08.pngbin0 -> 1131 bytes-rw-r--r--tcllib/modules/png/testimages/tp0n1g08.pngbin0 -> 689 bytes-rw-r--r--tcllib/modules/png/testimages/tp0n2c08.pngbin0 -> 1311 bytes-rw-r--r--tcllib/modules/png/testimages/tp0n3p08.pngbin0 -> 1120 bytes-rw-r--r--tcllib/modules/png/testimages/tp1n3p08.pngbin0 -> 1115 bytes-rw-r--r--tcllib/modules/png/testimages/x00n0g01.pngbin0 -> 49 bytes-rw-r--r--tcllib/modules/png/testimages/xcrn0g04.pngbin0 -> 261 bytes-rw-r--r--tcllib/modules/png/testimages/xlfn0g04.png13
-rw-r--r--tcllib/modules/png/testimages/z00n2c08.pngbin0 -> 3172 bytes-rw-r--r--tcllib/modules/png/testimages/z03n2c08.pngbin0 -> 232 bytes-rw-r--r--tcllib/modules/png/testimages/z06n2c08.pngbin0 -> 224 bytes-rw-r--r--tcllib/modules/png/testimages/z09n2c08.pngbin0 -> 224 bytes-rw-r--r--tcllib/modules/pop3/ChangeLog419
-rw-r--r--tcllib/modules/pop3/pkgIndex.tcl2
-rw-r--r--tcllib/modules/pop3/pop3.man274
-rw-r--r--tcllib/modules/pop3/pop3.tcl830
-rw-r--r--tcllib/modules/pop3/pop3.test611
-rw-r--r--tcllib/modules/pop3d/ChangeLog335
-rw-r--r--tcllib/modules/pop3d/pkgIndex.tcl16
-rw-r--r--tcllib/modules/pop3d/pop3d.man273
-rw-r--r--tcllib/modules/pop3d/pop3d.tcl1147
-rw-r--r--tcllib/modules/pop3d/pop3d.test772
-rw-r--r--tcllib/modules/pop3d/pop3d_dbox.man164
-rw-r--r--tcllib/modules/pop3d/pop3d_dbox.tcl485
-rw-r--r--tcllib/modules/pop3d/pop3d_dbox.test592
-rw-r--r--tcllib/modules/pop3d/pop3d_udb.man112
-rw-r--r--tcllib/modules/pop3d/pop3d_udb.tcl300
-rw-r--r--tcllib/modules/pop3d/pop3d_udb.test244
-rw-r--r--tcllib/modules/processman/pkgIndex.tcl12
-rw-r--r--tcllib/modules/processman/processman.man74
-rw-r--r--tcllib/modules/processman/processman.tcl270
-rw-r--r--tcllib/modules/profiler/ChangeLog258
-rw-r--r--tcllib/modules/profiler/pkgIndex.tcl2
-rw-r--r--tcllib/modules/profiler/profiler.man121
-rw-r--r--tcllib/modules/profiler/profiler.tcl638
-rw-r--r--tcllib/modules/profiler/profiler.test474
-rw-r--r--tcllib/modules/pt/ChangeLog2582
-rw-r--r--tcllib/modules/pt/char.tcl289
-rw-r--r--tcllib/modules/pt/char.test36
-rw-r--r--tcllib/modules/pt/configuration.tcl81
-rw-r--r--tcllib/modules/pt/include/arch_core.dia4
-rw-r--r--tcllib/modules/pt/include/arch_core.pngbin0 -> 18056 bytes-rw-r--r--tcllib/modules/pt/include/arch_core_container.dia4
-rw-r--r--tcllib/modules/pt/include/arch_core_container.pngbin0 -> 17960 bytes-rw-r--r--tcllib/modules/pt/include/arch_core_eplugins.dia4
-rw-r--r--tcllib/modules/pt/include/arch_core_eplugins.pngbin0 -> 18056 bytes-rw-r--r--tcllib/modules/pt/include/arch_core_export.dia4
-rw-r--r--tcllib/modules/pt/include/arch_core_export.pngbin0 -> 17961 bytes-rw-r--r--tcllib/modules/pt/include/arch_core_import.dia4
-rw-r--r--tcllib/modules/pt/include/arch_core_import.pngbin0 -> 17973 bytes-rw-r--r--tcllib/modules/pt/include/arch_core_iplugins.dia4
-rw-r--r--tcllib/modules/pt/include/arch_core_iplugins.pngbin0 -> 18038 bytes-rw-r--r--tcllib/modules/pt/include/arch_core_support.dia4
-rw-r--r--tcllib/modules/pt/include/arch_core_support.pngbin0 -> 17906 bytes-rw-r--r--tcllib/modules/pt/include/arch_core_transform.dia4
-rw-r--r--tcllib/modules/pt/include/arch_core_transform.pngbin0 -> 17922 bytes-rw-r--r--tcllib/modules/pt/include/arch_support.dia4
-rw-r--r--tcllib/modules/pt/include/arch_support.pngbin0 -> 17975 bytes-rw-r--r--tcllib/modules/pt/include/arch_user_app.dia4
-rw-r--r--tcllib/modules/pt/include/arch_user_app.pngbin0 -> 17983 bytes-rw-r--r--tcllib/modules/pt/include/arch_user_pkg.dia4
-rw-r--r--tcllib/modules/pt/include/arch_user_pkg.pngbin0 -> 18050 bytes-rw-r--r--tcllib/modules/pt/include/architecture.dia53
-rw-r--r--tcllib/modules/pt/include/architecture.pngbin0 -> 17826 bytes-rw-r--r--tcllib/modules/pt/include/channel_notes.inc14
-rw-r--r--tcllib/modules/pt/include/concept.inc22
-rw-r--r--tcllib/modules/pt/include/example/expr_ast.dia44
-rw-r--r--tcllib/modules/pt/include/example/expr_ast.inc19
-rw-r--r--tcllib/modules/pt/include/example/expr_ast.pic11
-rw-r--r--tcllib/modules/pt/include/example/expr_ast.pngbin0 -> 16291 bytes-rw-r--r--tcllib/modules/pt/include/example/expr_ast.txt9
-rw-r--r--tcllib/modules/pt/include/example/expr_container.inc33
-rw-r--r--tcllib/modules/pt/include/example/expr_json.inc41
-rw-r--r--tcllib/modules/pt/include/example/expr_param.inc758
-rw-r--r--tcllib/modules/pt/include/example/expr_pe.inc3
-rw-r--r--tcllib/modules/pt/include/example/expr_pe_serial.inc3
-rw-r--r--tcllib/modules/pt/include/example/expr_peg.inc12
-rw-r--r--tcllib/modules/pt/include/example/expr_peg_compact.inc11
-rw-r--r--tcllib/modules/pt/include/example/expr_ptgen.inc49
-rw-r--r--tcllib/modules/pt/include/example/expr_ptgenb.inc11
-rw-r--r--tcllib/modules/pt/include/example/expr_serial.inc15
-rw-r--r--tcllib/modules/pt/include/example/flow.dia5
-rw-r--r--tcllib/modules/pt/include/example/flow.pngbin0 -> 7471 bytes-rw-r--r--tcllib/modules/pt/include/example/full.inc54
-rw-r--r--tcllib/modules/pt/include/example/full_app.inc5
-rw-r--r--tcllib/modules/pt/include/example/full_pkg.inc7
-rw-r--r--tcllib/modules/pt/include/example/parser_use.inc13
-rw-r--r--tcllib/modules/pt/include/export/config/container.inc78
-rw-r--r--tcllib/modules/pt/include/export/config/cparam.inc80
-rw-r--r--tcllib/modules/pt/include/export/config/json.inc36
-rw-r--r--tcllib/modules/pt/include/export/config/param.inc49
-rw-r--r--tcllib/modules/pt/include/export/config/peg.inc49
-rw-r--r--tcllib/modules/pt/include/export/config/tclparam.inc74
-rw-r--r--tcllib/modules/pt/include/export/config/to_container.inc7
-rw-r--r--tcllib/modules/pt/include/export/config/to_cparam.inc25
-rw-r--r--tcllib/modules/pt/include/export/config/to_json.inc8
-rw-r--r--tcllib/modules/pt/include/export/config/to_param.inc51
-rw-r--r--tcllib/modules/pt/include/export/config/to_peg.inc7
-rw-r--r--tcllib/modules/pt/include/export/config/to_tclparam.inc156
-rw-r--r--tcllib/modules/pt/include/export/format/container.inc3
-rw-r--r--tcllib/modules/pt/include/export/format/cparam.inc0
-rw-r--r--tcllib/modules/pt/include/export/format/json.inc2
-rw-r--r--tcllib/modules/pt/include/export/format/null.inc0
-rw-r--r--tcllib/modules/pt/include/export/format/param.inc2
-rw-r--r--tcllib/modules/pt/include/export/format/peg.inc3
-rw-r--r--tcllib/modules/pt/include/export/format/tclparam.inc0
-rw-r--r--tcllib/modules/pt/include/export/plugin.inc71
-rw-r--r--tcllib/modules/pt/include/export/to.inc75
-rw-r--r--tcllib/modules/pt/include/feedback.inc3
-rw-r--r--tcllib/modules/pt/include/format/container.inc21
-rw-r--r--tcllib/modules/pt/include/format/cparam.inc38
-rw-r--r--tcllib/modules/pt/include/format/json.inc3
-rw-r--r--tcllib/modules/pt/include/format/json_core.inc103
-rw-r--r--tcllib/modules/pt/include/format/options_container.inc60
-rw-r--r--tcllib/modules/pt/include/format/options_cparam_critcl.inc34
-rw-r--r--tcllib/modules/pt/include/format/options_cparam_rawc.inc142
-rw-r--r--tcllib/modules/pt/include/format/options_json.inc31
-rw-r--r--tcllib/modules/pt/include/format/options_peg.inc30
-rw-r--r--tcllib/modules/pt/include/format/options_std.inc16
-rw-r--r--tcllib/modules/pt/include/format/options_tclparam_oo.inc32
-rw-r--r--tcllib/modules/pt/include/format/options_tclparam_snit.inc32
-rw-r--r--tcllib/modules/pt/include/format/param.inc21
-rw-r--r--tcllib/modules/pt/include/format/peg.inc119
-rw-r--r--tcllib/modules/pt/include/format/tclparam.inc30
-rw-r--r--tcllib/modules/pt/include/format/whatis_container.inc13
-rw-r--r--tcllib/modules/pt/include/format/whatis_cparam_critcl.inc4
-rw-r--r--tcllib/modules/pt/include/format/whatis_cparam_rawc.inc9
-rw-r--r--tcllib/modules/pt/include/format/whatis_json.inc5
-rw-r--r--tcllib/modules/pt/include/format/whatis_param.inc12
-rw-r--r--tcllib/modules/pt/include/format/whatis_peg.inc7
-rw-r--r--tcllib/modules/pt/include/format/whatis_tclparam_oo.inc4
-rw-r--r--tcllib/modules/pt/include/format/whatis_tclparam_snit.inc4
-rw-r--r--tcllib/modules/pt/include/gen.inc6
-rw-r--r--tcllib/modules/pt/include/gen_options.dia7
-rw-r--r--tcllib/modules/pt/include/gen_options.inc1
-rw-r--r--tcllib/modules/pt/include/gen_options.pic9
-rw-r--r--tcllib/modules/pt/include/gen_options.pngbin0 -> 9208 bytes-rw-r--r--tcllib/modules/pt/include/gen_options.txt7
-rw-r--r--tcllib/modules/pt/include/gen_verticals.inc22
-rw-r--r--tcllib/modules/pt/include/import/format/json.inc2
-rw-r--r--tcllib/modules/pt/include/import/format/peg.inc0
-rw-r--r--tcllib/modules/pt/include/import/from.inc49
-rw-r--r--tcllib/modules/pt/include/import/plugin.inc69
-rw-r--r--tcllib/modules/pt/include/keywords.inc17
-rw-r--r--tcllib/modules/pt/include/keywords_convert.inc5
-rw-r--r--tcllib/modules/pt/include/keywords_export.inc5
-rw-r--r--tcllib/modules/pt/include/keywords_import.inc5
-rw-r--r--tcllib/modules/pt/include/modes.inc21
-rw-r--r--tcllib/modules/pt/include/module.inc6
-rw-r--r--tcllib/modules/pt/include/param_1is.inc3
-rw-r--r--tcllib/modules/pt/include/param_2is.inc4
-rw-r--r--tcllib/modules/pt/include/param_3is.inc4
-rw-r--r--tcllib/modules/pt/include/param_okfail.inc7
-rw-r--r--tcllib/modules/pt/include/param_special.inc4
-rw-r--r--tcllib/modules/pt/include/rde_0cins.inc5
-rw-r--r--tcllib/modules/pt/include/rde_0gins.inc4
-rw-r--r--tcllib/modules/pt/include/rde_0ginsb.inc4
-rw-r--r--tcllib/modules/pt/include/rde_0ins.inc3
-rw-r--r--tcllib/modules/pt/include/rde_1ins.inc3
-rw-r--r--tcllib/modules/pt/include/rde_2ins.inc3
-rw-r--r--tcllib/modules/pt/include/ref_intro.inc12
-rw-r--r--tcllib/modules/pt/include/serial/ast.inc104
-rw-r--r--tcllib/modules/pt/include/serial/pegrammar.inc114
-rw-r--r--tcllib/modules/pt/include/serial/pexpression.inc245
-rw-r--r--tcllib/modules/pt/include/std_parser_object_api.inc71
-rw-r--r--tcllib/modules/pt/paths.tcl75
-rw-r--r--tcllib/modules/pt/pkgIndex.tcl67
-rw-r--r--tcllib/modules/pt/pt.bench186
-rw-r--r--tcllib/modules/pt/pt_astree.man171
-rw-r--r--tcllib/modules/pt/pt_astree.tcl234
-rw-r--r--tcllib/modules/pt/pt_astree.test40
-rw-r--r--tcllib/modules/pt/pt_cparam_config_critcl.man48
-rw-r--r--tcllib/modules/pt/pt_cparam_config_critcl.tcl492
-rw-r--r--tcllib/modules/pt/pt_cparam_config_critcl.test50
-rw-r--r--tcllib/modules/pt/pt_cparam_config_tea.man48
-rw-r--r--tcllib/modules/pt/pt_cparam_config_tea.tcl465
-rw-r--r--tcllib/modules/pt/pt_cparam_config_tea.test50
-rw-r--r--tcllib/modules/pt/pt_from_api.man203
-rw-r--r--tcllib/modules/pt/pt_introduction.man155
-rw-r--r--tcllib/modules/pt/pt_json_language.man13
-rw-r--r--tcllib/modules/pt/pt_param.man490
-rw-r--r--tcllib/modules/pt/pt_parse_peg.man38
-rw-r--r--tcllib/modules/pt/pt_parse_peg.tcl180
-rw-r--r--tcllib/modules/pt/pt_parse_peg.test83
-rw-r--r--tcllib/modules/pt/pt_parse_peg_c.tcl4995
-rw-r--r--tcllib/modules/pt/pt_parse_peg_tcl.tcl2431
-rw-r--r--tcllib/modules/pt/pt_parser_api.man82
-rw-r--r--tcllib/modules/pt/pt_peg_container.man385
-rw-r--r--tcllib/modules/pt/pt_peg_container.tcl530
-rw-r--r--tcllib/modules/pt/pt_peg_container.test52
-rw-r--r--tcllib/modules/pt/pt_peg_container_peg.man22
-rw-r--r--tcllib/modules/pt/pt_peg_container_peg.tcl146
-rw-r--r--tcllib/modules/pt/pt_peg_export.man195
-rw-r--r--tcllib/modules/pt/pt_peg_export.tcl119
-rw-r--r--tcllib/modules/pt/pt_peg_export.test49
-rw-r--r--tcllib/modules/pt/pt_peg_export_container.man6
-rw-r--r--tcllib/modules/pt/pt_peg_export_container.tcl51
-rw-r--r--tcllib/modules/pt/pt_peg_export_container.test50
-rw-r--r--tcllib/modules/pt/pt_peg_export_json.man6
-rw-r--r--tcllib/modules/pt/pt_peg_export_json.tcl50
-rw-r--r--tcllib/modules/pt/pt_peg_export_json.test48
-rw-r--r--tcllib/modules/pt/pt_peg_export_peg.man6
-rw-r--r--tcllib/modules/pt/pt_peg_export_peg.tcl51
-rw-r--r--tcllib/modules/pt/pt_peg_export_peg.test49
-rw-r--r--tcllib/modules/pt/pt_peg_from_container.man21
-rw-r--r--tcllib/modules/pt/pt_peg_from_json.man7
-rw-r--r--tcllib/modules/pt/pt_peg_from_json.tcl48
-rw-r--r--tcllib/modules/pt/pt_peg_from_json.test40
-rw-r--r--tcllib/modules/pt/pt_peg_from_peg.man7
-rw-r--r--tcllib/modules/pt/pt_peg_from_peg.tcl394
-rw-r--r--tcllib/modules/pt/pt_peg_from_peg.test86
-rw-r--r--tcllib/modules/pt/pt_peg_import.man218
-rw-r--r--tcllib/modules/pt/pt_peg_import.tcl190
-rw-r--r--tcllib/modules/pt/pt_peg_import.test43
-rw-r--r--tcllib/modules/pt/pt_peg_import_container.man21
-rw-r--r--tcllib/modules/pt/pt_peg_import_json.man6
-rw-r--r--tcllib/modules/pt/pt_peg_import_json.tcl40
-rw-r--r--tcllib/modules/pt/pt_peg_import_json.test45
-rw-r--r--tcllib/modules/pt/pt_peg_import_peg.man6
-rw-r--r--tcllib/modules/pt/pt_peg_import_peg.tcl41
-rw-r--r--tcllib/modules/pt/pt_peg_import_peg.test91
-rw-r--r--tcllib/modules/pt/pt_peg_interp.man80
-rw-r--r--tcllib/modules/pt/pt_peg_interp.tcl385
-rw-r--r--tcllib/modules/pt/pt_peg_interp.test66
-rw-r--r--tcllib/modules/pt/pt_peg_introduction.man208
-rw-r--r--tcllib/modules/pt/pt_peg_language.man316
-rw-r--r--tcllib/modules/pt/pt_peg_op.man179
-rw-r--r--tcllib/modules/pt/pt_peg_op.tcl377
-rw-r--r--tcllib/modules/pt/pt_peg_to_container.man7
-rw-r--r--tcllib/modules/pt/pt_peg_to_container.tcl345
-rw-r--r--tcllib/modules/pt/pt_peg_to_container.test48
-rw-r--r--tcllib/modules/pt/pt_peg_to_cparam.man7
-rw-r--r--tcllib/modules/pt/pt_peg_to_cparam.tcl1661
-rw-r--r--tcllib/modules/pt/pt_peg_to_cparam.test47
-rw-r--r--tcllib/modules/pt/pt_peg_to_json.man7
-rw-r--r--tcllib/modules/pt/pt_peg_to_json.tcl149
-rw-r--r--tcllib/modules/pt/pt_peg_to_json.test40
-rw-r--r--tcllib/modules/pt/pt_peg_to_param.man7
-rw-r--r--tcllib/modules/pt/pt_peg_to_param.tcl1029
-rw-r--r--tcllib/modules/pt/pt_peg_to_param.test41
-rw-r--r--tcllib/modules/pt/pt_peg_to_peg.man7
-rw-r--r--tcllib/modules/pt/pt_peg_to_peg.tcl413
-rw-r--r--tcllib/modules/pt/pt_peg_to_peg.test48
-rw-r--r--tcllib/modules/pt/pt_peg_to_tclparam.man7
-rw-r--r--tcllib/modules/pt/pt_peg_to_tclparam.tcl1273
-rw-r--r--tcllib/modules/pt/pt_peg_to_tclparam.test47
-rw-r--r--tcllib/modules/pt/pt_pegrammar.man144
-rw-r--r--tcllib/modules/pt/pt_pegrammar.tcl380
-rw-r--r--tcllib/modules/pt/pt_pegrammar.test42
-rw-r--r--tcllib/modules/pt/pt_pexpr_op.man89
-rw-r--r--tcllib/modules/pt/pt_pexpr_op.tcl335
-rw-r--r--tcllib/modules/pt/pt_pexpr_op.test46
-rw-r--r--tcllib/modules/pt/pt_pexpression.man275
-rw-r--r--tcllib/modules/pt/pt_pexpression.tcl321
-rw-r--r--tcllib/modules/pt/pt_pexpression.test40
-rw-r--r--tcllib/modules/pt/pt_pgen.man86
-rw-r--r--tcllib/modules/pt/pt_pgen.tcl221
-rw-r--r--tcllib/modules/pt/pt_pgen.test132
-rw-r--r--tcllib/modules/pt/pt_rdengine.man669
-rw-r--r--tcllib/modules/pt/pt_rdengine.tcl206
-rw-r--r--tcllib/modules/pt/pt_rdengine.test99
-rw-r--r--tcllib/modules/pt/pt_rdengine_c.tcl168
-rw-r--r--tcllib/modules/pt/pt_rdengine_oo.tcl2169
-rw-r--r--tcllib/modules/pt/pt_rdengine_tcl.tcl2282
-rw-r--r--tcllib/modules/pt/pt_runtime.test106
-rw-r--r--tcllib/modules/pt/pt_tclparam_config_snit.man48
-rw-r--r--tcllib/modules/pt/pt_tclparam_config_snit.tcl141
-rw-r--r--tcllib/modules/pt/pt_tclparam_config_snit.test50
-rw-r--r--tcllib/modules/pt/pt_tclparam_config_tcloo.man48
-rw-r--r--tcllib/modules/pt/pt_tclparam_config_tcloo.tcl121
-rw-r--r--tcllib/modules/pt/pt_tclparam_config_tcloo.test50
-rw-r--r--tcllib/modules/pt/pt_to_api.man217
-rw-r--r--tcllib/modules/pt/pt_util.man54
-rw-r--r--tcllib/modules/pt/pt_util.tcl160
-rw-r--r--tcllib/modules/pt/rde_critcl/m.c2746
-rw-r--r--tcllib/modules/pt/rde_critcl/m.h150
-rw-r--r--tcllib/modules/pt/rde_critcl/ms.c317
-rw-r--r--tcllib/modules/pt/rde_critcl/ms.h20
-rw-r--r--tcllib/modules/pt/rde_critcl/ot.c236
-rw-r--r--tcllib/modules/pt/rde_critcl/ot.h32
-rw-r--r--tcllib/modules/pt/rde_critcl/p.c183
-rw-r--r--tcllib/modules/pt/rde_critcl/p.h24
-rw-r--r--tcllib/modules/pt/rde_critcl/pInt.h50
-rw-r--r--tcllib/modules/pt/rde_critcl/param.c1789
-rw-r--r--tcllib/modules/pt/rde_critcl/param.h183
-rw-r--r--tcllib/modules/pt/rde_critcl/stack.c160
-rw-r--r--tcllib/modules/pt/rde_critcl/stack.h62
-rw-r--r--tcllib/modules/pt/rde_critcl/tc.c186
-rw-r--r--tcllib/modules/pt/rde_critcl/tc.h31
-rw-r--r--tcllib/modules/pt/rde_critcl/util.c145
-rw-r--r--tcllib/modules/pt/rde_critcl/util.h79
-rw-r--r--tcllib/modules/pt/tests/char.tests236
-rw-r--r--tcllib/modules/pt/tests/common412
-rw-r--r--tcllib/modules/pt/tests/data/gr/README.txt50
-rw-r--r--tcllib/modules/pt/tests/data/gr/TODO36
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/0_sequence2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/10_kleene2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/11_sym-kleene3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/12_alnum2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/13_sym-alnum3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/14_alpha2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/15_sym-alpha3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/16_ascii2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/17_sym-ascii3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/18_control2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/19_sym-control3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/1_sym-sequence3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/20_ddigit2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/21_sym-ddigit3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/22_digit2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/23_sym-digit3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/24_graph2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/25_sym-graph3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/26_lower2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/27_sym-lower3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/28_print2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/29_sym-print3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/2_choice2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/30_punct2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/31_sym-punct3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/32_space2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/33_sym-space3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/34_upper2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/35_sym-upper3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/36_wordchar2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/37_sym-wordchar3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/38_xdigit2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/39_sym-xdigit3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/3_sym-choice3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/40_dot2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/41_sym-dot3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/42_optional2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/43_sym-optional3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/44_notahead3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/45_sym-notahead4
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/46_ahead2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/47_sym-ahead3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/48_ticket-4a4e443ce95
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/4_class2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/5_sym-class3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/6_range2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/7_sym-range3
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/8_pkleene2
-rw-r--r--tcllib/modules/pt/tests/data/gr/def/9_sym-pkleene3
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-ahead-container-res/0_notmatch1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-ahead-critcl-res/0_notmatch1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-ahead-oo-res/0_notmatch1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-ahead-snit-res/0_notmatch1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-ahead/0_notmatch1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-alnum-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-alnum-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-alnum-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-alnum-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-alnum/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-alpha-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-alpha-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-alpha-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-alpha-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-alpha/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-ascii-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-ascii-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-ascii-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-ascii-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-ascii/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-container-res/0_aleph1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-container-res/1_anumber1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-container-res/2_digup1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-container-res/3_other1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/0_aleph1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/1_anumber1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/2_digup1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/3_other1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/0_aleph1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/1_anumber1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/2_digup1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/3_other1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/0_aleph1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/1_anumber1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/2_digup1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/3_other1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice/0_aleph1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice/1_anumber1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice/2_digup1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-choice/3_other1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-class-container-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-class-critcl-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-class-oo-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-class-snit-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-class/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-control-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-control-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-control-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-control-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-control/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-ddigit-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-ddigit-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-ddigit-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-ddigit-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-ddigit/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-digit-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-digit-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-digit-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-digit-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-digit/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-dot-container-res/0_none1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-dot-critcl-res/0_none1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-dot-oo-res/0_none1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-dot-snit-res/0_none1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-dot/0_none0
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-graph-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-graph-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-graph-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-graph-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-graph/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-lower-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-lower-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-lower-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-lower-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-lower/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-notahead-container-res/0_keyword1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-notahead-critcl-res/0_keyword1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-notahead-oo-res/0_keyword1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-notahead-snit-res/0_keyword1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-notahead/0_keyword1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-pkleene-container-res/0_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-pkleene-critcl-res/0_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-pkleene-oo-res/0_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-pkleene-snit-res/0_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-pkleene/0_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-print-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-print-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-print-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-print-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-print/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-punct-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-punct-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-punct-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-punct-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-punct/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-range-container-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-range-critcl-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-range-oo-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-range-snit-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-range/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sequence-container-res/0_abe1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sequence-container-res/1_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sequence-critcl-res/0_abe1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sequence-critcl-res/1_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sequence-oo-res/0_abe1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sequence-oo-res/1_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sequence-snit-res/0_abe1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sequence-snit-res/1_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sequence/0_abe1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sequence/1_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-space-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-space-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-space-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-space-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-space/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-ahead-container-res/0_notmatch1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-ahead-critcl-res/0_notmatch1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-ahead-oo-res/0_notmatch1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-ahead-snit-res/0_notmatch1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-ahead/0_notmatch1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-alnum-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-alnum-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-alnum-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-alnum-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-alnum/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-alpha-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-alpha-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-alpha-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-alpha-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-alpha/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-ascii-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-ascii-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-ascii-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-ascii-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-ascii/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/0_aleph1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/1_anumber1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/2_digup1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/3_other1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/0_aleph1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/1_anumber1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/2_digup1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/3_other1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/0_aleph1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/1_anumber1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/2_digup1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/3_other1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/0_aleph1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/1_anumber1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/2_digup1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/3_other1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice/0_aleph1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice/1_anumber1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice/2_digup1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-choice/3_other1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-class-container-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-class-critcl-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-class-oo-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-class-snit-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-class/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-control-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-control-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-control-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-control-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-control/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-ddigit/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-digit-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-digit-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-digit-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-digit-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-digit/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-dot-container-res/0_none1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-dot-critcl-res/0_none1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-dot-oo-res/0_none1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-dot-snit-res/0_none1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-dot/0_none0
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-graph-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-graph-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-graph-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-graph-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-graph/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-lower-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-lower-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-lower-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-lower-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-lower/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-notahead-container-res/0_keyword1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-notahead-critcl-res/0_keyword1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-notahead-oo-res/0_keyword1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-notahead-snit-res/0_keyword1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-notahead/0_keyword1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-container-res/0_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-critcl-res/0_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-oo-res/0_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-snit-res/0_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-pkleene/0_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-print-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-print-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-print-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-print-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-print/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-punct-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-punct-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-punct-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-punct-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-punct/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-range-container-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-range-critcl-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-range-oo-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-range-snit-res/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-range/0_beta1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-sequence-container-res/0_abe1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-sequence-container-res/1_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-sequence-critcl-res/0_abe1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-sequence-critcl-res/1_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-sequence-oo-res/0_abe1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-sequence-oo-res/1_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-sequence-snit-res/0_abe1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-sequence-snit-res/1_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-sequence/0_abe1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-sequence/1_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-space-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-space-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-space-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-space-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-space/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-upper-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-upper-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-upper-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-upper-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-upper/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-wordchar-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-wordchar-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-wordchar-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-wordchar-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-wordchar/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-xdigit-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-xdigit-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-xdigit-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-xdigit-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-sym-xdigit/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-upper-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-upper-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-upper-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-upper-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-upper/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-wordchar-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-wordchar-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-wordchar-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-wordchar-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-wordchar/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-xdigit-container-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-xdigit-critcl-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-xdigit-oo-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-xdigit-snit-res/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/fail-xdigit/0_outside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-ahead-res/0_match0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-ahead/0_match1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-alnum-res/0_inside0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-alnum/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-alpha-res/0_inside0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-alpha/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-ascii-res/0_inside0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-ascii/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-choice-res/0_alpha0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-choice-res/1_digit0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-choice-res/2_anumeric0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-choice/0_alpha1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-choice/1_digit1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-choice/2_anumeric1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-class-res/0_a0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-class-res/1_x0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-class-res/2_e0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-class/0_a1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-class/1_x1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-class/2_e1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-control-res/0_inside0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-control/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-ddigit-res/0_inside0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-ddigit/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-digit-res/0_inside0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-digit/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-dot-res/0_any0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-dot/0_any1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-graph-res/0_inside0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-graph/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-kleene-res/0_aaab0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-kleene-res/1_aab0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-kleene-res/2_ab0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-kleene-res/3_b0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-kleene/0_aaab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-kleene/1_aab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-kleene/2_ab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-kleene/3_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-lower-res/0_inside0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-lower/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-notahead-res/0_ident0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-notahead-res/1_identifierb0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-notahead/0_ident1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-notahead/1_identifierb1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-optional-res/0_have0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-optional-res/1_havenot0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-optional/0_have1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-optional/1_havenot1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-pkleene-res/0_aaab0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-pkleene-res/1_aab0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-pkleene-res/2_ab0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-pkleene/0_aaab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-pkleene/1_aab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-pkleene/2_ab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-print-res/0_inside0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-print/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-punct-res/0_inside0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-punct/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-range-res/0_a0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-range/0_a1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sequence-res/0_abc0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sequence/0_abc1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-space-res/0_inside0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-space/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-ahead-res/0_match1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-ahead/0_match1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-alnum-res/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-alnum/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-alpha-res/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-alpha/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-ascii-res/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-ascii/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-choice-res/0_alpha1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-choice-res/1_digit1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-choice-res/2_anumeric1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-choice/0_alpha1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-choice/1_digit1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-choice/2_anumeric1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-class-res/0_a1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-class-res/1_x1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-class-res/2_e1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-class/0_a1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-class/1_x1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-class/2_e1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-control-res/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-control/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-ddigit-res/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-ddigit/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-digit-res/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-digit/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-dot-res/0_any1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-dot/0_any1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-graph-res/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-graph/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-kleene-res/0_aaab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-kleene-res/1_aab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-kleene-res/2_ab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-kleene-res/3_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-kleene/0_aaab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-kleene/1_aab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-kleene/2_ab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-kleene/3_b1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-lower-res/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-lower/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-notahead-res/0_ident1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-notahead-res/1_identifierb1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-notahead/0_ident1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-notahead/1_identifierb1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-optional-res/0_have1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-optional-res/1_havenot1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-optional/0_have1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-optional/1_havenot1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-pkleene-res/0_aaab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-pkleene-res/1_aab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-pkleene-res/2_ab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-pkleene/0_aaab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-pkleene/1_aab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-pkleene/2_ab1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-print-res/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-print/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-punct-res/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-punct/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-range-res/0_a1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-range/0_a1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-sequence-res/0_abc1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-sequence/0_abc1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-space-res/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-space/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-upper-res/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-upper/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-wordchar-res/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-wordchar/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-xdigit-res/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-sym-xdigit/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-ticket-4a4e443ce9-res/0_test1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-ticket-4a4e443ce9/0_test1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-upper-res/0_inside0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-upper/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-wordchar-res/0_inside0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-wordchar/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-xdigit-res/0_inside0
-rw-r--r--tcllib/modules/pt/tests/data/gr/ok-xdigit/0_inside1
-rw-r--r--tcllib/modules/pt/tests/data/ok/ast_serial-budump/0_terminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/ast_serial-budump/1_nonterminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/ast_serial-budump/2_tree4
-rw-r--r--tcllib/modules/pt/tests/data/ok/ast_serial-print/0_terminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/ast_serial-print/1_nonterminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/ast_serial-print/2_tree4
-rw-r--r--tcllib/modules/pt/tests/data/ok/ast_serial-tddump/0_terminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/ast_serial-tddump/1_nonterminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/ast_serial-tddump/2_tree4
-rw-r--r--tcllib/modules/pt/tests/data/ok/ast_serial/0_terminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/ast_serial/1_nonterminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/ast_serial/2_tree1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/10_space1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/11_upper1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/12_wordchar1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/13_xdigit1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/14_ddigit1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/15_dot1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/16_nonterminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/17_terminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/18_range1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/19_ahead2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/1_epsilon1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/20_notahead2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/21_kleene2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/22_pkleen2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/23_optional2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/24_sequence2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/25_choice2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/26_complex11
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/2_alpha1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/3_alnum1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/4_ascii1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/5_digit1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/6_graph1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/7_lower1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/8_print1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-budump/9_punct1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/10_space1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/11_upper1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/12_wordchar1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/13_xdigit1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/14_ddigit1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/15_dot1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/16_nonterminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/17_terminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/18_range1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/19_ahead2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/1_epsilon1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/20_notahead2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/21_kleene2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/22_pkleen2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/23_optional2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/24_sequence2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/25_choice2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/26_complex11
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/2_alpha1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/3_alnum1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/4_ascii1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/5_digit1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/6_graph1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/7_lower1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/8_print1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-print/9_punct1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/10_space1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/11_upper1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/12_wordchar1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/13_xdigit1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/14_ddigit1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/15_dot1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/16_nonterminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/17_terminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/18_range1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/19_ahead2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/1_epsilon1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/20_notahead2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/21_kleene2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/22_pkleen2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/23_optional2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/24_sequence2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/25_choice2
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/26_complex11
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/2_alpha1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/3_alnum1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/4_ascii1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/5_digit1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/6_graph1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/7_lower1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/8_print1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial-tddump/9_punct1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/10_space1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/11_upper1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/12_wordchar1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/13_xdigit1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/14_ddigit1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/15_dot1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/16_nonterminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/17_terminal1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/18_range1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/19_ahead1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/1_epsilon1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/20_notahead1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/21_kleene1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/22_pkleen1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/23_optional1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/24_sequence1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/25_choice1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/26_complex1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/2_alpha1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/3_alnum1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/4_ascii1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/5_digit1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/6_graph1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/7_lower1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/8_print1
-rw-r--r--tcllib/modules/pt/tests/data/ok/pe_serial/9_punct1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-bulk/0_basic_arithmetic31
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-bulk/10_notahead17
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-bulk/11_epsilon9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-bulk/1_functions21
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-bulk/27_ticket_4a4e443ce921
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-bulk/2_fun_arithmetic35
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-bulk/3_peg_itself135
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-bulk/4_choice9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-bulk/5_sequence9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-bulk/6_optional9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-bulk/7_kleene9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-bulk/8_pkleene9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-bulk/9_ahead17
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-incremental/0_basic_arithmetic43
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-incremental/10_notahead15
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-incremental/11_epsilon9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-incremental/1_functions23
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-incremental/27_ticket_4a4e443ce923
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-incremental/2_fun_arithmetic51
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-incremental/3_peg_itself251
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-incremental/4_choice9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-incremental/5_sequence9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-incremental/6_optional9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-incremental/7_kleene9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-incremental/8_pkleene9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-incremental/9_ahead15
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-bulk/0_basic_arithmetic42
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-bulk/10_notahead28
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-bulk/11_epsilon20
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-bulk/1_functions32
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-bulk/27_ticket_4a4e443ce932
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-bulk/2_fun_arithmetic46
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-bulk/3_peg_itself146
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-bulk/4_choice20
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-bulk/5_sequence20
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-bulk/6_optional20
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-bulk/7_kleene20
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-bulk/8_pkleene20
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-bulk/9_ahead28
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-incremental/0_basic_arithmetic54
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-incremental/10_notahead26
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-incremental/11_epsilon20
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-incremental/1_functions34
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-incremental/27_ticket_4a4e443ce934
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-incremental/2_fun_arithmetic62
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-incremental/3_peg_itself262
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-incremental/4_choice20
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-incremental/5_sequence20
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-incremental/6_optional20
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-incremental/7_kleene20
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-incremental/8_pkleene20
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_container-templated-incremental/9_ahead26
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-critcl/0_basic_arithmetic2393
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-critcl/10_notahead2082
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-critcl/11_epsilon2046
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-critcl/1_functions2107
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-critcl/27_ticket_4a4e443ce92256
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-critcl/2_fun_arithmetic2456
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-critcl/3_peg_itself4995
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-critcl/4_choice2030
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-critcl/5_sequence2030
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-critcl/6_optional2043
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-critcl/7_kleene2045
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-critcl/8_pkleene2048
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-critcl/9_ahead2082
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-tea/0_basic_arithmetic2351
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-tea/10_notahead2040
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-tea/11_epsilon2004
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-tea/1_functions2065
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-tea/27_ticket_4a4e443ce92214
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-tea/2_fun_arithmetic2414
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-tea/3_peg_itself4953
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-tea/4_choice1988
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-tea/5_sequence1988
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-tea/6_optional2001
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-tea/7_kleene2003
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-tea/8_pkleene2006
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam-tea/9_ahead2040
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam/0_basic_arithmetic407
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam/10_notahead96
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam/11_epsilon60
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam/1_functions121
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam/27_ticket_4a4e443ce9270
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam/2_fun_arithmetic470
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam/3_peg_itself3009
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam/4_choice44
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam/5_sequence44
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam/6_optional57
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam/7_kleene59
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam/8_pkleene62
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_cparam/9_ahead96
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indalign/0_basic_arithmetic39
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indalign/10_notahead11
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indalign/11_epsilon6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indalign/1_functions19
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indalign/27_ticket_4a4e443ce919
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indalign/2_fun_arithmetic47
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indalign/3_peg_itself247
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indalign/4_choice6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indalign/5_sequence6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indalign/6_optional6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indalign/7_kleene6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indalign/8_pkleene6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indalign/9_ahead11
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indented/0_basic_arithmetic39
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indented/10_notahead11
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indented/11_epsilon6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indented/1_functions19
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indented/27_ticket_4a4e443ce919
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indented/2_fun_arithmetic47
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indented/3_peg_itself247
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indented/4_choice6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indented/5_sequence6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indented/6_optional6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indented/7_kleene6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indented/8_pkleene6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-indented/9_ahead11
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-ultracompact/0_basic_arithmetic1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-ultracompact/10_notahead1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-ultracompact/11_epsilon1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-ultracompact/1_functions1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-ultracompact/27_ticket_4a4e443ce91
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-ultracompact/2_fun_arithmetic1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-ultracompact/3_peg_itself1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-ultracompact/4_choice1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-ultracompact/5_sequence1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-ultracompact/6_optional1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-ultracompact/7_kleene1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-ultracompact/8_pkleene1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_json-ultracompact/9_ahead1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-compact/0_basic_arithmetic852
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-compact/10_notahead88
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-compact/11_epsilon54
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-compact/1_functions189
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-compact/27_ticket_4a4e443ce9400
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-compact/2_fun_arithmetic1037
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-compact/3_peg_itself5788
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-compact/4_choice78
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-compact/5_sequence71
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-compact/6_optional37
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-compact/7_kleene41
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-compact/8_pkleene47
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-compact/9_ahead87
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-inlined/0_basic_arithmetic790
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-inlined/10_notahead82
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-inlined/11_epsilon48
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-inlined/1_functions159
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-inlined/27_ticket_4a4e443ce9384
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-inlined/2_fun_arithmetic959
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-inlined/3_peg_itself5665
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-inlined/4_choice60
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-inlined/5_sequence53
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-inlined/6_optional31
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-inlined/7_kleene35
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-inlined/8_pkleene42
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-inlined/9_ahead81
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-unopt/0_basic_arithmetic898
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-unopt/10_notahead88
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-unopt/11_epsilon54
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-unopt/1_functions189
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-unopt/27_ticket_4a4e443ce9407
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-unopt/2_fun_arithmetic1097
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-unopt/3_peg_itself6703
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-unopt/4_choice78
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-unopt/5_sequence71
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-unopt/6_optional37
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-unopt/7_kleene41
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-unopt/8_pkleene47
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param-unopt/9_ahead87
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param/0_basic_arithmetic756
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param/10_notahead82
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param/11_epsilon48
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param/1_functions159
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param/27_ticket_4a4e443ce9384
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param/2_fun_arithmetic925
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param/3_peg_itself5580
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param/4_choice60
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param/5_sequence53
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param/6_optional31
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param/7_kleene35
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param/8_pkleene42
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_param/9_ahead81
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-fused/0_basic_arithmetic193
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-fused/10_notahead29
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-fused/11_epsilon18
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-fused/1_functions60
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-fused/27_ticket_4a4e443ce982
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-fused/2_fun_arithmetic237
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-fused/3_peg_itself1696
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-fused/4_choice20
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-fused/5_sequence17
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-fused/6_optional14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-fused/7_kleene14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-fused/8_pkleene14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-fused/9_ahead29
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated-fused/0_basic_arithmetic193
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated-fused/10_notahead29
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated-fused/11_epsilon18
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated-fused/1_functions60
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated-fused/27_ticket_4a4e443ce982
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated-fused/2_fun_arithmetic237
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated-fused/3_peg_itself1696
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated-fused/4_choice20
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated-fused/5_sequence17
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated-fused/6_optional14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated-fused/7_kleene14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated-fused/8_pkleene14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated-fused/9_ahead29
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated/0_basic_arithmetic237
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated/10_notahead29
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated/11_epsilon18
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated/1_functions72
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated/27_ticket_4a4e443ce990
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated/2_fun_arithmetic293
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated/3_peg_itself2152
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated/4_choice27
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated/5_sequence25
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated/6_optional14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated/7_kleene14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated/8_pkleene14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast-templated/9_ahead29
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast/0_basic_arithmetic237
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast/10_notahead29
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast/11_epsilon18
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast/1_functions72
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast/27_ticket_4a4e443ce990
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast/2_fun_arithmetic293
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast/3_peg_itself2152
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast/4_choice27
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast/5_sequence25
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast/6_optional14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast/7_kleene14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast/8_pkleene14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-ast/9_ahead29
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-fused/0_basic_arithmetic12
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-fused/10_notahead5
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-fused/11_epsilon2
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-fused/1_functions7
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-fused/27_ticket_4a4e443ce97
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-fused/2_fun_arithmetic14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-fused/3_peg_itself64
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-fused/4_choice2
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-fused/5_sequence2
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-fused/6_optional2
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-fused/7_kleene2
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-fused/8_pkleene2
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-fused/9_ahead5
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated-fused/0_basic_arithmetic19
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated-fused/10_notahead12
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated-fused/11_epsilon9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated-fused/1_functions14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated-fused/27_ticket_4a4e443ce914
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated-fused/2_fun_arithmetic21
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated-fused/3_peg_itself71
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated-fused/4_choice9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated-fused/5_sequence9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated-fused/6_optional9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated-fused/7_kleene9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated-fused/8_pkleene9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated-fused/9_ahead12
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated/0_basic_arithmetic19
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated/10_notahead12
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated/11_epsilon9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated/1_functions14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated/27_ticket_4a4e443ce914
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated/2_fun_arithmetic21
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated/3_peg_itself71
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated/4_choice9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated/5_sequence9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated/6_optional9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated/7_kleene9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated/8_pkleene9
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg-templated/9_ahead12
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg/0_basic_arithmetic12
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg/10_notahead5
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg/11_epsilon2
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg/1_functions7
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg/27_ticket_4a4e443ce97
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg/2_fun_arithmetic14
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg/3_peg_itself64
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg/4_choice2
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg/5_sequence2
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg/6_optional2
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg/7_kleene2
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg/8_pkleene2
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_peg/9_ahead5
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-canonical/0_basic_arithmetic1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-canonical/10_notahead1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-canonical/11_epsilon1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-canonical/1_functions1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-canonical/27_ticket_4a4e443ce91
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-canonical/2_fun_arithmetic1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-canonical/3_peg_itself2
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-canonical/4_choice1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-canonical/5_sequence1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-canonical/6_optional1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-canonical/7_kleene1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-canonical/8_pkleene1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-canonical/9_ahead1
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-print/0_basic_arithmetic54
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-print/10_notahead8
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-print/11_epsilon5
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-print/1_functions15
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-print/27_ticket_4a4e443ce924
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-print/2_fun_arithmetic66
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-print/3_peg_itself445
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-print/4_choice6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-print/5_sequence6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-print/6_optional4
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-print/7_kleene4
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-print/8_pkleene4
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial-print/9_ahead8
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial/0_basic_arithmetic13
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial/10_notahead6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial/11_epsilon4
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial/1_functions8
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial/27_ticket_4a4e443ce98
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial/2_fun_arithmetic15
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial/3_peg_itself65
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial/4_choice4
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial/5_sequence4
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial/6_optional4
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial/7_kleene4
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial/8_pkleene4
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_serial/9_ahead6
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-snit/0_basic_arithmetic365
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-snit/10_notahead119
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-snit/11_epsilon92
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-snit/1_functions137
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-snit/27_ticket_4a4e443ce9262
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-snit/2_fun_arithmetic414
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-snit/3_peg_itself2431
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-snit/4_choice79
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-snit/5_sequence79
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-snit/6_optional89
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-snit/7_kleene91
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-snit/8_pkleene94
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-snit/9_ahead119
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-tcloo/0_basic_arithmetic351
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-tcloo/10_notahead105
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-tcloo/11_epsilon78
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-tcloo/1_functions123
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-tcloo/27_ticket_4a4e443ce9248
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-tcloo/2_fun_arithmetic400
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-tcloo/3_peg_itself2417
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-tcloo/4_choice65
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-tcloo/5_sequence65
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-tcloo/6_optional75
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-tcloo/7_kleene77
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-tcloo/8_pkleene80
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam-tcloo/9_ahead105
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam/0_basic_arithmetic301
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam/10_notahead55
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam/11_epsilon28
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam/1_functions73
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam/27_ticket_4a4e443ce9198
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam/2_fun_arithmetic350
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam/3_peg_itself2367
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam/4_choice15
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam/5_sequence15
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam/6_optional25
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam/7_kleene27
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam/8_pkleene30
-rw-r--r--tcllib/modules/pt/tests/data/ok/peg_tclparam/9_ahead55
-rw-r--r--tcllib/modules/pt/tests/pt_astree.tests302
-rw-r--r--tcllib/modules/pt/tests/pt_cparam_config_critcl.tests52
-rw-r--r--tcllib/modules/pt/tests/pt_cparam_config_tea.tests52
-rw-r--r--tcllib/modules/pt/tests/pt_parse_peg.tests36
-rw-r--r--tcllib/modules/pt/tests/pt_peg_container.tests126
-rw-r--r--tcllib/modules/pt/tests/pt_peg_export.tests173
-rw-r--r--tcllib/modules/pt/tests/pt_peg_export_container.tests66
-rw-r--r--tcllib/modules/pt/tests/pt_peg_export_json.tests39
-rw-r--r--tcllib/modules/pt/tests/pt_peg_export_peg.tests62
-rw-r--r--tcllib/modules/pt/tests/pt_peg_export_plugins.tests145
-rw-r--r--tcllib/modules/pt/tests/pt_peg_from_json.tests29
-rw-r--r--tcllib/modules/pt/tests/pt_peg_from_peg.tests47
-rw-r--r--tcllib/modules/pt/tests/pt_peg_import.tests210
-rw-r--r--tcllib/modules/pt/tests/pt_peg_import_json.tests32
-rw-r--r--tcllib/modules/pt/tests/pt_peg_import_peg.tests46
-rw-r--r--tcllib/modules/pt/tests/pt_peg_import_plugins.tests168
-rw-r--r--tcllib/modules/pt/tests/pt_peg_interp.tests43
-rw-r--r--tcllib/modules/pt/tests/pt_peg_to_container.tests72
-rw-r--r--tcllib/modules/pt/tests/pt_peg_to_cparam.tests64
-rw-r--r--tcllib/modules/pt/tests/pt_peg_to_json.tests45
-rw-r--r--tcllib/modules/pt/tests/pt_peg_to_param.tests62
-rw-r--r--tcllib/modules/pt/tests/pt_peg_to_peg.tests69
-rw-r--r--tcllib/modules/pt/tests/pt_peg_to_tclparam.tests58
-rw-r--r--tcllib/modules/pt/tests/pt_pegrammar.tests195
-rw-r--r--tcllib/modules/pt/tests/pt_pexpr_op.tests110
-rw-r--r--tcllib/modules/pt/tests/pt_pexpression.tests371
-rw-r--r--tcllib/modules/pt/tests/pt_pgen.tests137
-rw-r--r--tcllib/modules/pt/tests/pt_rdengine.tests1978
-rw-r--r--tcllib/modules/pt/tests/pt_runtime.tests150
-rw-r--r--tcllib/modules/pt/tests/pt_tclparam_config_snit.tests52
-rw-r--r--tcllib/modules/pt/tests/pt_tclparam_config_tcloo.tests52
-rw-r--r--tcllib/modules/pt/text_write.tcl249
-rw-r--r--tcllib/modules/pt/tools/bench-compare.tcl126
-rw-r--r--tcllib/modules/pt/tools/regenerate_parsers.tcl86
-rw-r--r--tcllib/modules/rc4/ChangeLog134
-rw-r--r--tcllib/modules/rc4/pkgIndex.tcl13
-rw-r--r--tcllib/modules/rc4/rc4.bench64
-rw-r--r--tcllib/modules/rc4/rc4.man120
-rw-r--r--tcllib/modules/rc4/rc4.tcl422
-rw-r--r--tcllib/modules/rc4/rc4.test273
-rw-r--r--tcllib/modules/rc4/rc4c.tcl168
-rw-r--r--tcllib/modules/rcs/ChangeLog99
-rw-r--r--tcllib/modules/rcs/pkgIndex.tcl2
-rw-r--r--tcllib/modules/rcs/rcs.man330
-rw-r--r--tcllib/modules/rcs/rcs.pcx65
-rw-r--r--tcllib/modules/rcs/rcs.tcl281
-rw-r--r--tcllib/modules/rcs/rcs.test317
-rw-r--r--tcllib/modules/report/ChangeLog164
-rw-r--r--tcllib/modules/report/pkgIndex.tcl2
-rw-r--r--tcllib/modules/report/report.man476
-rw-r--r--tcllib/modules/report/report.tcl1386
-rw-r--r--tcllib/modules/report/report.test1367
-rw-r--r--tcllib/modules/rest/ChangeLog75
-rw-r--r--tcllib/modules/rest/bitly34
-rw-r--r--tcllib/modules/rest/couchdb56
-rw-r--r--tcllib/modules/rest/delicious131
-rw-r--r--tcllib/modules/rest/facebook93
-rw-r--r--tcllib/modules/rest/flickr292
-rw-r--r--tcllib/modules/rest/gcal102
-rw-r--r--tcllib/modules/rest/gdocs87
-rw-r--r--tcllib/modules/rest/pkgIndex.tcl2
-rw-r--r--tcllib/modules/rest/rest.man538
-rw-r--r--tcllib/modules/rest/rest.tcl829
-rw-r--r--tcllib/modules/rest/twitter69
-rw-r--r--tcllib/modules/rest/yboss36
-rw-r--r--tcllib/modules/rest/yweather19
-rw-r--r--tcllib/modules/ripemd/ChangeLog150
-rw-r--r--tcllib/modules/ripemd/pkgIndex.tcl11
-rw-r--r--tcllib/modules/ripemd/ripemd128.bench46
-rw-r--r--tcllib/modules/ripemd/ripemd128.man191
-rw-r--r--tcllib/modules/ripemd/ripemd128.tcl731
-rw-r--r--tcllib/modules/ripemd/ripemd128.test225
-rw-r--r--tcllib/modules/ripemd/ripemd160.bench46
-rw-r--r--tcllib/modules/ripemd/ripemd160.man175
-rw-r--r--tcllib/modules/ripemd/ripemd160.tcl866
-rw-r--r--tcllib/modules/ripemd/ripemd160.test229
-rw-r--r--tcllib/modules/ripemd/ripemd160_test.c159
-rw-r--r--tcllib/modules/sasl/ChangeLog194
-rw-r--r--tcllib/modules/sasl/gtoken.man27
-rw-r--r--tcllib/modules/sasl/gtoken.tcl92
-rw-r--r--tcllib/modules/sasl/ntlm.man36
-rw-r--r--tcllib/modules/sasl/ntlm.tcl375
-rw-r--r--tcllib/modules/sasl/ntlm.test92
-rw-r--r--tcllib/modules/sasl/pkgIndex.tcl11
-rw-r--r--tcllib/modules/sasl/sasl.man340
-rw-r--r--tcllib/modules/sasl/sasl.tcl682
-rw-r--r--tcllib/modules/sasl/sasl.test291
-rw-r--r--tcllib/modules/sasl/scram.man36
-rw-r--r--tcllib/modules/sasl/scram.tcl503
-rw-r--r--tcllib/modules/sasl/scram.test99
-rw-r--r--tcllib/modules/sha1/ChangeLog318
-rw-r--r--tcllib/modules/sha1/pkgIndex.tcl14
-rw-r--r--tcllib/modules/sha1/sha1.bench46
-rw-r--r--tcllib/modules/sha1/sha1.c267
-rw-r--r--tcllib/modules/sha1/sha1.h26
-rw-r--r--tcllib/modules/sha1/sha1.man182
-rw-r--r--tcllib/modules/sha1/sha1.tcl813
-rw-r--r--tcllib/modules/sha1/sha1.test201
-rw-r--r--tcllib/modules/sha1/sha1c.tcl125
-rw-r--r--tcllib/modules/sha1/sha1v1.tcl710
-rw-r--r--tcllib/modules/sha1/sha1v1.test227
-rw-r--r--tcllib/modules/sha1/sha256.bench52
-rw-r--r--tcllib/modules/sha1/sha256.c524
-rw-r--r--tcllib/modules/sha1/sha256.h83
-rw-r--r--tcllib/modules/sha1/sha256.man194
-rw-r--r--tcllib/modules/sha1/sha256.tcl832
-rw-r--r--tcllib/modules/sha1/sha256.test97
-rw-r--r--tcllib/modules/sha1/sha256c.tcl174
-rwxr-xr-xtcllib/modules/simulation/ChangeLog84
-rwxr-xr-xtcllib/modules/simulation/annealing.man257
-rwxr-xr-xtcllib/modules/simulation/annealing.tcl564
-rwxr-xr-xtcllib/modules/simulation/montecarlo.man219
-rwxr-xr-xtcllib/modules/simulation/montecarlo.tcl486
-rwxr-xr-xtcllib/modules/simulation/pkgIndex.tcl3
-rwxr-xr-xtcllib/modules/simulation/random.tcl577
-rwxr-xr-xtcllib/modules/simulation/random.test239
-rw-r--r--tcllib/modules/simulation/simulation_random.man216
-rw-r--r--tcllib/modules/smtpd/ChangeLog191
-rw-r--r--tcllib/modules/smtpd/clients/README13
-rw-r--r--tcllib/modules/smtpd/clients/mail-test.php21
-rw-r--r--tcllib/modules/smtpd/clients/mail-test.pl121
-rw-r--r--tcllib/modules/smtpd/clients/mail-test.py53
-rw-r--r--tcllib/modules/smtpd/clients/mail-test.rb16
-rw-r--r--tcllib/modules/smtpd/clients/mail-test.tcl15
-rw-r--r--tcllib/modules/smtpd/clients/php.ini56
-rw-r--r--tcllib/modules/smtpd/pkgIndex.tcl12
-rw-r--r--tcllib/modules/smtpd/smtpd.man294
-rw-r--r--tcllib/modules/smtpd/smtpd.tcl924
-rw-r--r--tcllib/modules/snit/ChangeLog1189
-rw-r--r--tcllib/modules/snit/README.tcl83.txt57
-rw-r--r--tcllib/modules/snit/README.txt829
-rw-r--r--tcllib/modules/snit/dictionary.txt125
-rw-r--r--tcllib/modules/snit/license.txt38
-rw-r--r--tcllib/modules/snit/main1.tcl3987
-rw-r--r--tcllib/modules/snit/main1_83.tcl4011
-rw-r--r--tcllib/modules/snit/main2.tcl3888
-rw-r--r--tcllib/modules/snit/modules.txt11
-rw-r--r--tcllib/modules/snit/pkgIndex.tcl6
-rw-r--r--tcllib/modules/snit/roadmap.txt180
-rw-r--r--tcllib/modules/snit/roadmap2.txt177
-rw-r--r--tcllib/modules/snit/snit.man2839
-rw-r--r--tcllib/modules/snit/snit.tcl41
-rw-r--r--tcllib/modules/snit/snit.test9144
-rw-r--r--tcllib/modules/snit/snit2.tcl32
-rw-r--r--tcllib/modules/snit/snit_tcl83_utils.tcl231
-rw-r--r--tcllib/modules/snit/snitfaq.man4114
-rw-r--r--tcllib/modules/snit/validate.tcl720
-rw-r--r--tcllib/modules/soundex/ChangeLog102
-rw-r--r--tcllib/modules/soundex/pkgIndex.tcl12
-rw-r--r--tcllib/modules/soundex/soundex.man45
-rw-r--r--tcllib/modules/soundex/soundex.pcx26
-rw-r--r--tcllib/modules/soundex/soundex.tcl96
-rw-r--r--tcllib/modules/soundex/soundex.test45
-rw-r--r--tcllib/modules/stooop/ChangeLog150
-rw-r--r--tcllib/modules/stooop/README79
-rwxr-xr-xtcllib/modules/stooop/mkpkgidx.tcl112
-rw-r--r--tcllib/modules/stooop/pkgIndex.tcl22
-rw-r--r--tcllib/modules/stooop/stooop.man223
-rw-r--r--tcllib/modules/stooop/stooop.tcl938
-rw-r--r--tcllib/modules/stooop/stooop.test9398
-rw-r--r--tcllib/modules/stooop/stooop_man.html1194
-rw-r--r--tcllib/modules/stooop/switched.html242
-rw-r--r--tcllib/modules/stooop/switched.man328
-rw-r--r--tcllib/modules/stooop/switched.tcl133
-rw-r--r--tcllib/modules/stooop/xifo.tcl142
-rw-r--r--tcllib/modules/string/ChangeLog16
-rw-r--r--tcllib/modules/string/pkgIndex.tcl6
-rw-r--r--tcllib/modules/string/token.man97
-rw-r--r--tcllib/modules/string/token.tcl94
-rw-r--r--tcllib/modules/string/token_shell.man141
-rw-r--r--tcllib/modules/string/token_shell.tcl172
-rw-r--r--tcllib/modules/string/token_shell.test181
-rw-r--r--tcllib/modules/stringprep/ChangeLog78
-rw-r--r--tcllib/modules/stringprep/pkgIndex.tcl5
-rw-r--r--tcllib/modules/stringprep/stringprep.man151
-rw-r--r--tcllib/modules/stringprep/stringprep.tcl278
-rw-r--r--tcllib/modules/stringprep/stringprep.test164
-rw-r--r--tcllib/modules/stringprep/stringprep_data.man21
-rw-r--r--tcllib/modules/stringprep/stringprep_data.tcl1034
-rw-r--r--tcllib/modules/stringprep/tools/gen_stringprep_data.tcl524
-rw-r--r--tcllib/modules/stringprep/tools/gen_unicode_data.tcl867
-rw-r--r--tcllib/modules/stringprep/tools/gen_unicode_test.tcl247
-rw-r--r--tcllib/modules/stringprep/unicode.man83
-rw-r--r--tcllib/modules/stringprep/unicode.tcl292
-rw-r--r--tcllib/modules/stringprep/unicode.test1732
-rw-r--r--tcllib/modules/stringprep/unicode_data.man21
-rw-r--r--tcllib/modules/stringprep/unicode_data.tcl1547
-rw-r--r--tcllib/modules/struct/ChangeLog2433
-rw-r--r--tcllib/modules/struct/disjointset.man160
-rw-r--r--tcllib/modules/struct/disjointset.tcl344
-rw-r--r--tcllib/modules/struct/disjointset.test116
-rw-r--r--tcllib/modules/struct/disjointset.testsuite223
-rw-r--r--tcllib/modules/struct/graph.man942
-rw-r--r--tcllib/modules/struct/graph.tcl180
-rw-r--r--tcllib/modules/struct/graph.test49
-rw-r--r--tcllib/modules/struct/graph/arc.c197
-rw-r--r--tcllib/modules/struct/graph/arc.h40
-rw-r--r--tcllib/modules/struct/graph/arcshimmer.c137
-rw-r--r--tcllib/modules/struct/graph/attr.c443
-rw-r--r--tcllib/modules/struct/graph/attr.h49
-rw-r--r--tcllib/modules/struct/graph/ds.h178
-rw-r--r--tcllib/modules/struct/graph/filter.c1209
-rw-r--r--tcllib/modules/struct/graph/global.c49
-rw-r--r--tcllib/modules/struct/graph/global.h20
-rw-r--r--tcllib/modules/struct/graph/graph.c706
-rw-r--r--tcllib/modules/struct/graph/graph.h40
-rw-r--r--tcllib/modules/struct/graph/methods.c2914
-rw-r--r--tcllib/modules/struct/graph/methods.h76
-rw-r--r--tcllib/modules/struct/graph/nacommon.c289
-rw-r--r--tcllib/modules/struct/graph/nacommon.h39
-rw-r--r--tcllib/modules/struct/graph/node.c136
-rw-r--r--tcllib/modules/struct/graph/node.h34
-rw-r--r--tcllib/modules/struct/graph/nodeshimmer.c137
-rw-r--r--tcllib/modules/struct/graph/objcmd.c178
-rw-r--r--tcllib/modules/struct/graph/objcmd.h20
-rw-r--r--tcllib/modules/struct/graph/tests/XOpsControl60
-rw-r--r--tcllib/modules/struct/graph/tests/XOpsSetup2750
-rw-r--r--tcllib/modules/struct/graph/tests/XOpsSupport128
-rw-r--r--tcllib/modules/struct/graph/tests/Xcontrol72
-rw-r--r--tcllib/modules/struct/graph/tests/Xsetup100
-rw-r--r--tcllib/modules/struct/graph/tests/Xsupport320
-rw-r--r--tcllib/modules/struct/graph/tests/arc/attr.test97
-rw-r--r--tcllib/modules/struct/graph/tests/arc/delete.test94
-rw-r--r--tcllib/modules/struct/graph/tests/arc/exists.test47
-rw-r--r--tcllib/modules/struct/graph/tests/arc/flip.test59
-rw-r--r--tcllib/modules/struct/graph/tests/arc/getunweighted.test74
-rw-r--r--tcllib/modules/struct/graph/tests/arc/getweight.test58
-rw-r--r--tcllib/modules/struct/graph/tests/arc/hasweight.test58
-rw-r--r--tcllib/modules/struct/graph/tests/arc/insert.test113
-rw-r--r--tcllib/modules/struct/graph/tests/arc/move-source.test76
-rw-r--r--tcllib/modules/struct/graph/tests/arc/move-target.test76
-rw-r--r--tcllib/modules/struct/graph/tests/arc/move.test111
-rw-r--r--tcllib/modules/struct/graph/tests/arc/nodes.test48
-rw-r--r--tcllib/modules/struct/graph/tests/arc/rename.test104
-rw-r--r--tcllib/modules/struct/graph/tests/arc/setunweighted.test64
-rw-r--r--tcllib/modules/struct/graph/tests/arc/setweight.test71
-rw-r--r--tcllib/modules/struct/graph/tests/arc/source.test48
-rw-r--r--tcllib/modules/struct/graph/tests/arc/target.test48
-rw-r--r--tcllib/modules/struct/graph/tests/arc/unsetweight.test62
-rw-r--r--tcllib/modules/struct/graph/tests/arc/weights.test76
-rw-r--r--tcllib/modules/struct/graph/tests/arcs.test326
-rw-r--r--tcllib/modules/struct/graph/tests/assign.test75
-rw-r--r--tcllib/modules/struct/graph/tests/attr/Xsetup78
-rw-r--r--tcllib/modules/struct/graph/tests/attr/append.test88
-rw-r--r--tcllib/modules/struct/graph/tests/attr/get.test84
-rw-r--r--tcllib/modules/struct/graph/tests/attr/getall.test79
-rw-r--r--tcllib/modules/struct/graph/tests/attr/keyexists.test84
-rw-r--r--tcllib/modules/struct/graph/tests/attr/keys.test79
-rw-r--r--tcllib/modules/struct/graph/tests/attr/lappend.test88
-rw-r--r--tcllib/modules/struct/graph/tests/attr/set.test97
-rw-r--r--tcllib/modules/struct/graph/tests/attr/unset.test115
-rw-r--r--tcllib/modules/struct/graph/tests/command.test161
-rw-r--r--tcllib/modules/struct/graph/tests/deserialize.test209
-rw-r--r--tcllib/modules/struct/graph/tests/node/attr.test97
-rw-r--r--tcllib/modules/struct/graph/tests/node/degree.test87
-rw-r--r--tcllib/modules/struct/graph/tests/node/delete.test88
-rw-r--r--tcllib/modules/struct/graph/tests/node/exists.test46
-rw-r--r--tcllib/modules/struct/graph/tests/node/insert.test67
-rw-r--r--tcllib/modules/struct/graph/tests/node/opposite.test88
-rw-r--r--tcllib/modules/struct/graph/tests/node/rename.test106
-rw-r--r--tcllib/modules/struct/graph/tests/nodes.test313
-rw-r--r--tcllib/modules/struct/graph/tests/ops/adjlist.test158
-rw-r--r--tcllib/modules/struct/graph/tests/ops/adjmatrix.test69
-rw-r--r--tcllib/modules/struct/graph/tests/ops/bellmanford.test137
-rw-r--r--tcllib/modules/struct/graph/tests/ops/bfs.test204
-rw-r--r--tcllib/modules/struct/graph/tests/ops/bipartite.test147
-rw-r--r--tcllib/modules/struct/graph/tests/ops/bridge.test75
-rw-r--r--tcllib/modules/struct/graph/tests/ops/busackergowen.test157
-rw-r--r--tcllib/modules/struct/graph/tests/ops/christofides.test58
-rw-r--r--tcllib/modules/struct/graph/tests/ops/componentof.test167
-rw-r--r--tcllib/modules/struct/graph/tests/ops/components.test131
-rw-r--r--tcllib/modules/struct/graph/tests/ops/connected.test120
-rw-r--r--tcllib/modules/struct/graph/tests/ops/cutvertex.test97
-rw-r--r--tcllib/modules/struct/graph/tests/ops/diameter.test45
-rw-r--r--tcllib/modules/struct/graph/tests/ops/dijkstra.test107
-rw-r--r--tcllib/modules/struct/graph/tests/ops/dinicblockingflow.test70
-rw-r--r--tcllib/modules/struct/graph/tests/ops/dinicmaximumflow.test137
-rw-r--r--tcllib/modules/struct/graph/tests/ops/distance.test70
-rw-r--r--tcllib/modules/struct/graph/tests/ops/eccentricity.test57
-rw-r--r--tcllib/modules/struct/graph/tests/ops/edmondskarp.test195
-rw-r--r--tcllib/modules/struct/graph/tests/ops/eulerpath.test215
-rw-r--r--tcllib/modules/struct/graph/tests/ops/eulertour.test189
-rw-r--r--tcllib/modules/struct/graph/tests/ops/floydwarshall.test124
-rw-r--r--tcllib/modules/struct/graph/tests/ops/johnsons.test130
-rw-r--r--tcllib/modules/struct/graph/tests/ops/kcenter.test179
-rw-r--r--tcllib/modules/struct/graph/tests/ops/kruskal.test59
-rw-r--r--tcllib/modules/struct/graph/tests/ops/maxcut.test138
-rw-r--r--tcllib/modules/struct/graph/tests/ops/maxmatching.test137
-rw-r--r--tcllib/modules/struct/graph/tests/ops/mdst.test131
-rw-r--r--tcllib/modules/struct/graph/tests/ops/metrictsp.test208
-rw-r--r--tcllib/modules/struct/graph/tests/ops/mkmblockingflow.test67
-rw-r--r--tcllib/modules/struct/graph/tests/ops/prim.test67
-rw-r--r--tcllib/modules/struct/graph/tests/ops/radius.test45
-rw-r--r--tcllib/modules/struct/graph/tests/ops/tarjan.test99
-rw-r--r--tcllib/modules/struct/graph/tests/ops/tspheuristics.test44
-rw-r--r--tcllib/modules/struct/graph/tests/ops/verticescover.test81
-rw-r--r--tcllib/modules/struct/graph/tests/ops/weightedkcenter.test137
-rw-r--r--tcllib/modules/struct/graph/tests/rassign.test75
-rw-r--r--tcllib/modules/struct/graph/tests/serialize.test199
-rw-r--r--tcllib/modules/struct/graph/tests/swap.test121
-rw-r--r--tcllib/modules/struct/graph/tests/walk.test207
-rw-r--r--tcllib/modules/struct/graph/util.c115
-rw-r--r--tcllib/modules/struct/graph/util.h66
-rw-r--r--tcllib/modules/struct/graph/walk.c553
-rw-r--r--tcllib/modules/struct/graph/walk.h46
-rw-r--r--tcllib/modules/struct/graph1.man375
-rw-r--r--tcllib/modules/struct/graph1.tcl2154
-rw-r--r--tcllib/modules/struct/graph1.test1905
-rw-r--r--tcllib/modules/struct/graph_c.tcl160
-rw-r--r--tcllib/modules/struct/graph_tcl.tcl3244
-rw-r--r--tcllib/modules/struct/graphops.man1318
-rw-r--r--tcllib/modules/struct/graphops.tcl3787
-rw-r--r--tcllib/modules/struct/graphops.test67
-rw-r--r--tcllib/modules/struct/list.tcl1828
-rw-r--r--tcllib/modules/struct/list.test1311
-rw-r--r--tcllib/modules/struct/matrix.man539
-rw-r--r--tcllib/modules/struct/matrix.tcl2792
-rw-r--r--tcllib/modules/struct/matrix.test2314
-rw-r--r--tcllib/modules/struct/matrix.testsupport116
-rw-r--r--tcllib/modules/struct/matrix1.man381
-rw-r--r--tcllib/modules/struct/matrix1.tcl2287
-rw-r--r--tcllib/modules/struct/matrix1.test1895
-rw-r--r--tcllib/modules/struct/pkgIndex.tcl23
-rw-r--r--tcllib/modules/struct/pool.html1151
-rw-r--r--tcllib/modules/struct/pool.man443
-rw-r--r--tcllib/modules/struct/pool.tcl715
-rw-r--r--tcllib/modules/struct/pool.test202
-rw-r--r--tcllib/modules/struct/prioqueue.man111
-rw-r--r--tcllib/modules/struct/prioqueue.tcl535
-rw-r--r--tcllib/modules/struct/prioqueue.test511
-rw-r--r--tcllib/modules/struct/queue.bench232
-rw-r--r--tcllib/modules/struct/queue.man96
-rw-r--r--tcllib/modules/struct/queue.tcl187
-rw-r--r--tcllib/modules/struct/queue.test107
-rw-r--r--tcllib/modules/struct/queue.testsuite372
-rw-r--r--tcllib/modules/struct/queue/ds.h35
-rw-r--r--tcllib/modules/struct/queue/m.c502
-rw-r--r--tcllib/modules/struct/queue/m.h26
-rw-r--r--tcllib/modules/struct/queue/ms.c76
-rw-r--r--tcllib/modules/struct/queue/ms.h20
-rw-r--r--tcllib/modules/struct/queue/q.c47
-rw-r--r--tcllib/modules/struct/queue/q.h22
-rw-r--r--tcllib/modules/struct/queue/util.h41
-rw-r--r--tcllib/modules/struct/queue_c.tcl151
-rw-r--r--tcllib/modules/struct/queue_oo.tcl228
-rw-r--r--tcllib/modules/struct/queue_tcl.tcl383
-rw-r--r--tcllib/modules/struct/record.html436
-rw-r--r--tcllib/modules/struct/record.man393
-rw-r--r--tcllib/modules/struct/record.tcl778
-rw-r--r--tcllib/modules/struct/record.test467
-rw-r--r--tcllib/modules/struct/sets.bench428
-rw-r--r--tcllib/modules/struct/sets.tcl189
-rw-r--r--tcllib/modules/struct/sets.test121
-rw-r--r--tcllib/modules/struct/sets.testsuite529
-rw-r--r--tcllib/modules/struct/sets/ds.h24
-rw-r--r--tcllib/modules/struct/sets/m.c772
-rw-r--r--tcllib/modules/struct/sets/m.h33
-rw-r--r--tcllib/modules/struct/sets/s.c458
-rw-r--r--tcllib/modules/struct/sets/s.h40
-rw-r--r--tcllib/modules/struct/sets_c.tcl93
-rw-r--r--tcllib/modules/struct/sets_tcl.tcl452
-rw-r--r--tcllib/modules/struct/skiplist.man86
-rw-r--r--tcllib/modules/struct/skiplist.tcl437
-rw-r--r--tcllib/modules/struct/skiplist.test335
-rw-r--r--tcllib/modules/struct/stack.bench244
-rw-r--r--tcllib/modules/struct/stack.man108
-rw-r--r--tcllib/modules/struct/stack.tcl187
-rw-r--r--tcllib/modules/struct/stack.test106
-rw-r--r--tcllib/modules/struct/stack.testsuite641
-rw-r--r--tcllib/modules/struct/stack/ds.h36
-rw-r--r--tcllib/modules/struct/stack/m.c382
-rw-r--r--tcllib/modules/struct/stack/m.h28
-rw-r--r--tcllib/modules/struct/stack/ms.c79
-rw-r--r--tcllib/modules/struct/stack/ms.h20
-rw-r--r--tcllib/modules/struct/stack/s.c133
-rw-r--r--tcllib/modules/struct/stack/s.h24
-rw-r--r--tcllib/modules/struct/stack/util.h41
-rw-r--r--tcllib/modules/struct/stack_c.tcl156
-rw-r--r--tcllib/modules/struct/stack_oo.tcl296
-rw-r--r--tcllib/modules/struct/stack_tcl.tcl505
-rw-r--r--tcllib/modules/struct/struct.tcl18
-rw-r--r--tcllib/modules/struct/struct1.tcl17
-rw-r--r--tcllib/modules/struct/struct_list.man830
-rw-r--r--tcllib/modules/struct/struct_set.man136
-rw-r--r--tcllib/modules/struct/struct_tree.man792
-rw-r--r--tcllib/modules/struct/struct_tree1.man292
-rw-r--r--tcllib/modules/struct/tree.bench548
-rw-r--r--tcllib/modules/struct/tree.tcl183
-rw-r--r--tcllib/modules/struct/tree.test73
-rw-r--r--tcllib/modules/struct/tree.testsuite3811
-rw-r--r--tcllib/modules/struct/tree.testsuite.4417=84tcl.txt32
-rw-r--r--tcllib/modules/struct/tree.testsuite.4417a83critcl.txt14
-rw-r--r--tcllib/modules/struct/tree.testsuite.4417a84tcl.txt27
-rw-r--r--tcllib/modules/struct/tree.testsuite.4417b84.txt27
-rw-r--r--tcllib/modules/struct/tree/ds.h111
-rw-r--r--tcllib/modules/struct/tree/m.c2908
-rw-r--r--tcllib/modules/struct/tree/m.h59
-rw-r--r--tcllib/modules/struct/tree/ms.c379
-rw-r--r--tcllib/modules/struct/tree/ms.h29
-rw-r--r--tcllib/modules/struct/tree/shimmer.c147
-rw-r--r--tcllib/modules/struct/tree/t.c440
-rw-r--r--tcllib/modules/struct/tree/t.h59
-rw-r--r--tcllib/modules/struct/tree/tests/Xsupport157
-rw-r--r--tcllib/modules/struct/tree/tn.c1147
-rw-r--r--tcllib/modules/struct/tree/tn.h63
-rw-r--r--tcllib/modules/struct/tree/util.c115
-rw-r--r--tcllib/modules/struct/tree/util.h65
-rw-r--r--tcllib/modules/struct/tree/walk.c709
-rw-r--r--tcllib/modules/struct/tree1.tcl1485
-rw-r--r--tcllib/modules/struct/tree1.test1352
-rw-r--r--tcllib/modules/struct/tree_c.tcl208
-rw-r--r--tcllib/modules/struct/tree_tcl.tcl2442
-rw-r--r--tcllib/modules/tar/ChangeLog186
-rw-r--r--tcllib/modules/tar/pkgIndex.tcl5
-rw-r--r--tcllib/modules/tar/tar.man167
-rw-r--r--tcllib/modules/tar/tar.pcx83
-rw-r--r--tcllib/modules/tar/tar.tcl540
-rw-r--r--tcllib/modules/tar/tar.test119
-rw-r--r--tcllib/modules/tar/tests/support.tcl126
-rw-r--r--tcllib/modules/tcllibc.tcl12
-rw-r--r--tcllib/modules/tepam/ChangeLog104
-rw-r--r--tcllib/modules/tepam/adbox_all.test156
-rw-r--r--tcllib/modules/tepam/adbox_widgets.test456
-rw-r--r--tcllib/modules/tepam/bug_fixes.test110
-rw-r--r--tcllib/modules/tepam/doc_gen.test150
-rw-r--r--tcllib/modules/tepam/pkgIndex.tcl3
-rw-r--r--tcllib/modules/tepam/proc_call_arg_nun.test451
-rw-r--r--tcllib/modules/tepam/proc_call_arg_type.test312
-rw-r--r--tcllib/modules/tepam/proc_call_arg_unn.test547
-rw-r--r--tcllib/modules/tepam/proc_call_arg_valid.test273
-rw-r--r--tcllib/modules/tepam/proc_interactive.test402
-rw-r--r--tcllib/modules/tepam/proc_namespaces.test229
-rw-r--r--tcllib/modules/tepam/proc_subproc.test197
-rw-r--r--tcllib/modules/tepam/tepam.tcl2762
-rw-r--r--tcllib/modules/tepam/tepam_argument_dialogbox.man570
-rw-r--r--tcllib/modules/tepam/tepam_doc_gen.man301
-rw-r--r--tcllib/modules/tepam/tepam_doc_gen.tcl747
-rw-r--r--tcllib/modules/tepam/tepam_introduction.man313
-rw-r--r--tcllib/modules/tepam/tepam_procedure.man883
-rw-r--r--tcllib/modules/term/ChangeLog164
-rw-r--r--tcllib/modules/term/ansi/code.tcl56
-rw-r--r--tcllib/modules/term/ansi/code/attr.tcl108
-rw-r--r--tcllib/modules/term/ansi/code/ctrl.tcl270
-rw-r--r--tcllib/modules/term/ansi/code/macros.tcl93
-rw-r--r--tcllib/modules/term/ansi/ctrlunix.tcl91
-rw-r--r--tcllib/modules/term/ansi/send.tcl92
-rw-r--r--tcllib/modules/term/ansi_cattr.man83
-rw-r--r--tcllib/modules/term/ansi_cctrl.man199
-rw-r--r--tcllib/modules/term/ansi_cmacros.man66
-rw-r--r--tcllib/modules/term/ansi_code.man46
-rw-r--r--tcllib/modules/term/ansi_ctrlu.man79
-rw-r--r--tcllib/modules/term/ansi_send.man266
-rw-r--r--tcllib/modules/term/bind.tcl132
-rw-r--r--tcllib/modules/term/imenu.man155
-rw-r--r--tcllib/modules/term/imenu.tcl202
-rw-r--r--tcllib/modules/term/ipager.man154
-rw-r--r--tcllib/modules/term/ipager.tcl206
-rw-r--r--tcllib/modules/term/pkgIndex.tcl13
-rw-r--r--tcllib/modules/term/receive.man77
-rw-r--r--tcllib/modules/term/receive.tcl60
-rw-r--r--tcllib/modules/term/send.tcl34
-rw-r--r--tcllib/modules/term/term.man20
-rw-r--r--tcllib/modules/term/term.tcl19
-rw-r--r--tcllib/modules/term/term_bind.man124
-rw-r--r--tcllib/modules/term/term_send.man36
-rw-r--r--tcllib/modules/textutil/ChangeLog569
-rw-r--r--tcllib/modules/textutil/adjust.man208
-rw-r--r--tcllib/modules/textutil/adjust.tcl761
-rw-r--r--tcllib/modules/textutil/adjust.test398
-rw-r--r--tcllib/modules/textutil/adjust_hyph.test132
-rw-r--r--tcllib/modules/textutil/dehypht.tex902
-rw-r--r--tcllib/modules/textutil/eshyph_vo.tex1104
-rw-r--r--tcllib/modules/textutil/expander.ehtml362
-rw-r--r--tcllib/modules/textutil/expander.html367
-rw-r--r--tcllib/modules/textutil/expander.man511
-rw-r--r--tcllib/modules/textutil/expander.tcl1122
-rw-r--r--tcllib/modules/textutil/expander.test368
-rw-r--r--tcllib/modules/textutil/expander_license.txt38
-rw-r--r--tcllib/modules/textutil/expander_notes.txt47
-rw-r--r--tcllib/modules/textutil/ithyph.tex223
-rw-r--r--tcllib/modules/textutil/pkgIndex.tcl12
-rw-r--r--tcllib/modules/textutil/repeat.man46
-rw-r--r--tcllib/modules/textutil/repeat.tcl91
-rw-r--r--tcllib/modules/textutil/repeat.test62
-rw-r--r--tcllib/modules/textutil/split.tcl167
-rw-r--r--tcllib/modules/textutil/split.test158
-rw-r--r--tcllib/modules/textutil/string.bench116
-rw-r--r--tcllib/modules/textutil/string.tcl144
-rw-r--r--tcllib/modules/textutil/tabify.man72
-rw-r--r--tcllib/modules/textutil/tabify.tcl289
-rw-r--r--tcllib/modules/textutil/tabify.test156
-rw-r--r--tcllib/modules/textutil/textutil.man388
-rw-r--r--tcllib/modules/textutil/textutil.tcl79
-rw-r--r--tcllib/modules/textutil/textutil.test166
-rw-r--r--tcllib/modules/textutil/textutil_adjust.pcx54
-rw-r--r--tcllib/modules/textutil/textutil_repeat.pcx31
-rw-r--r--tcllib/modules/textutil/textutil_split.man53
-rw-r--r--tcllib/modules/textutil/textutil_split.pcx32
-rw-r--r--tcllib/modules/textutil/textutil_string.man73
-rw-r--r--tcllib/modules/textutil/textutil_string.pcx46
-rw-r--r--tcllib/modules/textutil/textutil_tabify.pcx42
-rw-r--r--tcllib/modules/textutil/textutil_trim.pcx46
-rw-r--r--tcllib/modules/textutil/trim.man75
-rw-r--r--tcllib/modules/textutil/trim.tcl112
-rw-r--r--tcllib/modules/textutil/trim.test177
-rw-r--r--tcllib/modules/tie/ChangeLog253
-rw-r--r--tcllib/modules/tie/pkgIndex.tcl9
-rw-r--r--tcllib/modules/tie/tie.man535
-rw-r--r--tcllib/modules/tie/tie.tcl511
-rw-r--r--tcllib/modules/tie/tie.test557
-rw-r--r--tcllib/modules/tie/tie_array.tcl124
-rw-r--r--tcllib/modules/tie/tie_array.test301
-rw-r--r--tcllib/modules/tie/tie_dsource.tcl54
-rw-r--r--tcllib/modules/tie/tie_file.tcl273
-rw-r--r--tcllib/modules/tie/tie_file.test392
-rw-r--r--tcllib/modules/tie/tie_growfile.tcl147
-rw-r--r--tcllib/modules/tie/tie_growfile.test345
-rw-r--r--tcllib/modules/tie/tie_log.tcl95
-rw-r--r--tcllib/modules/tie/tie_log.test240
-rw-r--r--tcllib/modules/tie/tie_rarray.tcl118
-rw-r--r--tcllib/modules/tie/tie_rarray.test331
-rw-r--r--tcllib/modules/tie/tie_rarray_comm.test218
-rw-r--r--tcllib/modules/tie/tie_std.man35
-rw-r--r--tcllib/modules/tie/tie_template.txt100
-rw-r--r--tcllib/modules/tiff/ChangeLog103
-rw-r--r--tcllib/modules/tiff/pkgIndex.tcl2
-rw-r--r--tcllib/modules/tiff/testimages/IMG_7898.tiffbin0 -> 62561 bytes-rw-r--r--tcllib/modules/tiff/testimages/IMG_7917.tiffbin0 -> 41545 bytes-rw-r--r--tcllib/modules/tiff/testimages/IMG_7950.tiffbin0 -> 35359 bytes-rw-r--r--tcllib/modules/tiff/tiff.man174
-rw-r--r--tcllib/modules/tiff/tiff.tcl787
-rw-r--r--tcllib/modules/tiff/tiff.test556
-rw-r--r--tcllib/modules/tool/ensemble.tcl343
-rw-r--r--tcllib/modules/tool/event.tcl163
-rw-r--r--tcllib/modules/tool/index.tcl59
-rw-r--r--tcllib/modules/tool/meta.man165
-rw-r--r--tcllib/modules/tool/metaclass.tcl525
-rw-r--r--tcllib/modules/tool/module.shed8
-rw-r--r--tcllib/modules/tool/option.tcl168
-rw-r--r--tcllib/modules/tool/organ.tcl32
-rw-r--r--tcllib/modules/tool/pipeline.tcl174
-rw-r--r--tcllib/modules/tool/pkgIndex.tcl12
-rw-r--r--tcllib/modules/tool/script.tcl36
-rw-r--r--tcllib/modules/tool/tool.demo65
-rw-r--r--tcllib/modules/tool/tool.man233
-rw-r--r--tcllib/modules/tool/tool.md149
-rw-r--r--tcllib/modules/tool/tool.test339
-rw-r--r--tcllib/modules/tool/tool_dict_ensemble.man34
-rw-r--r--tcllib/modules/tool/uuid.tcl58
-rw-r--r--tcllib/modules/tool_datatype/datatype.tcl434
-rw-r--r--tcllib/modules/tool_datatype/pkgIndex.tcl2
-rw-r--r--tcllib/modules/transfer/ChangeLog193
-rw-r--r--tcllib/modules/transfer/connect.man168
-rw-r--r--tcllib/modules/transfer/connect.tcl97
-rw-r--r--tcllib/modules/transfer/copyops.man163
-rw-r--r--tcllib/modules/transfer/copyops.tcl389
-rw-r--r--tcllib/modules/transfer/ddest.man122
-rw-r--r--tcllib/modules/transfer/ddest.tcl169
-rw-r--r--tcllib/modules/transfer/dsource.man154
-rw-r--r--tcllib/modules/transfer/dsource.tcl183
-rw-r--r--tcllib/modules/transfer/include/complete.inc9
-rw-r--r--tcllib/modules/transfer/include/connect_options.inc63
-rw-r--r--tcllib/modules/transfer/include/connect_result.inc4
-rw-r--r--tcllib/modules/transfer/include/connect_result_ref.inc4
-rw-r--r--tcllib/modules/transfer/include/ddest_options.inc27
-rw-r--r--tcllib/modules/transfer/include/dsource_options.inc35
-rw-r--r--tcllib/modules/transfer/include/secure.inc18
-rw-r--r--tcllib/modules/transfer/pkgIndex.tcl8
-rw-r--r--tcllib/modules/transfer/receiver.man191
-rw-r--r--tcllib/modules/transfer/receiver.tcl188
-rw-r--r--tcllib/modules/transfer/tqueue.man174
-rw-r--r--tcllib/modules/transfer/tqueue.tcl223
-rw-r--r--tcllib/modules/transfer/transmitter.man184
-rw-r--r--tcllib/modules/transfer/transmitter.tcl176
-rw-r--r--tcllib/modules/treeql/ChangeLog192
-rw-r--r--tcllib/modules/treeql/IDEAS.txt183
-rw-r--r--tcllib/modules/treeql/docs/api+xhtml.dtd21
-rw-r--r--tcllib/modules/treeql/docs/api.css78
-rw-r--r--tcllib/modules/treeql/docs/api.dtd19
-rw-r--r--tcllib/modules/treeql/docs/index.html45
-rw-r--r--tcllib/modules/treeql/docs/treeapi.xml98
-rw-r--r--tcllib/modules/treeql/docs/treeql-int.xml74
-rw-r--r--tcllib/modules/treeql/docs/treeql-low.xml103
-rw-r--r--tcllib/modules/treeql/docs/treeql.xml376
-rw-r--r--tcllib/modules/treeql/pkgIndex.tcl5
-rw-r--r--tcllib/modules/treeql/treeql.man819
-rw-r--r--tcllib/modules/treeql/treeql.tcl24
-rw-r--r--tcllib/modules/treeql/treeql.test43
-rw-r--r--tcllib/modules/treeql/treeql.testsuite448
-rw-r--r--tcllib/modules/treeql/treeql84.tcl734
-rw-r--r--tcllib/modules/treeql/treeql85.tcl737
-rw-r--r--tcllib/modules/try/ChangeLog22
-rw-r--r--tcllib/modules/try/pkgIndex.tcl13
-rw-r--r--tcllib/modules/try/tcllib_throw.man39
-rw-r--r--tcllib/modules/try/tcllib_try.man122
-rw-r--r--tcllib/modules/try/throw.tcl18
-rw-r--r--tcllib/modules/try/try.tcl205
-rw-r--r--tcllib/modules/uev/ChangeLog103
-rw-r--r--tcllib/modules/uev/pkgIndex.tcl3
-rw-r--r--tcllib/modules/uev/uevent.man196
-rw-r--r--tcllib/modules/uev/uevent.pcx58
-rw-r--r--tcllib/modules/uev/uevent.tcl470
-rw-r--r--tcllib/modules/uev/uevent.test478
-rw-r--r--tcllib/modules/uev/uevent_onidle.man64
-rw-r--r--tcllib/modules/uev/uevent_onidle.pcx27
-rw-r--r--tcllib/modules/uev/uevent_onidle.tcl51
-rwxr-xr-xtcllib/modules/units/ChangeLog163
-rw-r--r--tcllib/modules/units/pkgIndex.tcl4
-rwxr-xr-xtcllib/modules/units/units.man392
-rw-r--r--tcllib/modules/units/units.pcx38
-rwxr-xr-xtcllib/modules/units/units.tcl690
-rwxr-xr-xtcllib/modules/units/units.test522
-rw-r--r--tcllib/modules/uri/ChangeLog413
-rw-r--r--tcllib/modules/uri/pkgIndex.tcl6
-rw-r--r--tcllib/modules/uri/uri-rfc2396.test208
-rw-r--r--tcllib/modules/uri/uri.man197
-rw-r--r--tcllib/modules/uri/uri.tcl1050
-rw-r--r--tcllib/modules/uri/uri.test526
-rw-r--r--tcllib/modules/uri/uri_urn.pcx27
-rw-r--r--tcllib/modules/uri/urn-scheme.man41
-rw-r--r--tcllib/modules/uri/urn-scheme.tcl143
-rw-r--r--tcllib/modules/uri/urn.test175
-rw-r--r--tcllib/modules/uuid/ChangeLog110
-rw-r--r--tcllib/modules/uuid/pkgIndex.tcl8
-rw-r--r--tcllib/modules/uuid/uuid.man54
-rw-r--r--tcllib/modules/uuid/uuid.tcl238
-rw-r--r--tcllib/modules/uuid/uuid.test96
-rw-r--r--tcllib/modules/valtype/ChangeLog79
-rw-r--r--tcllib/modules/valtype/cc_amex.man14
-rw-r--r--tcllib/modules/valtype/cc_amex.tcl68
-rw-r--r--tcllib/modules/valtype/cc_amex.test126
-rw-r--r--tcllib/modules/valtype/cc_discover.man14
-rw-r--r--tcllib/modules/valtype/cc_discover.tcl70
-rw-r--r--tcllib/modules/valtype/cc_discover.test126
-rw-r--r--tcllib/modules/valtype/cc_mastercard.man14
-rw-r--r--tcllib/modules/valtype/cc_mastercard.tcl68
-rw-r--r--tcllib/modules/valtype/cc_mastercard.test126
-rw-r--r--tcllib/modules/valtype/cc_visa.man14
-rw-r--r--tcllib/modules/valtype/cc_visa.tcl69
-rw-r--r--tcllib/modules/valtype/cc_visa.test130
-rw-r--r--tcllib/modules/valtype/ean13.man14
-rw-r--r--tcllib/modules/valtype/ean13.tcl99
-rw-r--r--tcllib/modules/valtype/ean13.test122
-rw-r--r--tcllib/modules/valtype/iban.man14
-rwxr-xr-xtcllib/modules/valtype/iban.tcl91
-rwxr-xr-xtcllib/modules/valtype/iban.test171
-rw-r--r--tcllib/modules/valtype/imei.man14
-rw-r--r--tcllib/modules/valtype/imei.tcl66
-rw-r--r--tcllib/modules/valtype/imei.test85
-rw-r--r--tcllib/modules/valtype/include/c_length.inc3
-rw-r--r--tcllib/modules/valtype/include/c_lenpfx.inc6
-rw-r--r--tcllib/modules/valtype/include/errorcodes.inc31
-rw-r--r--tcllib/modules/valtype/include/k_amex.inc4
-rw-r--r--tcllib/modules/valtype/include/k_discover.inc4
-rw-r--r--tcllib/modules/valtype/include/k_ean13.inc2
-rw-r--r--tcllib/modules/valtype/include/k_iban.inc2
-rw-r--r--tcllib/modules/valtype/include/k_imei.inc3
-rw-r--r--tcllib/modules/valtype/include/k_isbn.inc3
-rw-r--r--tcllib/modules/valtype/include/k_luhn.inc1
-rw-r--r--tcllib/modules/valtype/include/k_luhn5.inc1
-rw-r--r--tcllib/modules/valtype/include/k_mastercard.inc4
-rw-r--r--tcllib/modules/valtype/include/k_usnpi.inc2
-rw-r--r--tcllib/modules/valtype/include/k_verhoeff.inc1
-rw-r--r--tcllib/modules/valtype/include/k_visa.inc4
-rw-r--r--tcllib/modules/valtype/include/m_isbn.inc8
-rw-r--r--tcllib/modules/valtype/include/null.inc0
-rw-r--r--tcllib/modules/valtype/include/r_luhn.inc1
-rw-r--r--tcllib/modules/valtype/include/vtype.inc102
-rw-r--r--tcllib/modules/valtype/isbn.man14
-rw-r--r--tcllib/modules/valtype/isbn.tcl176
-rw-r--r--tcllib/modules/valtype/isbn.test127
-rw-r--r--tcllib/modules/valtype/luhn.man14
-rw-r--r--tcllib/modules/valtype/luhn.tcl128
-rw-r--r--tcllib/modules/valtype/luhn.test92
-rw-r--r--tcllib/modules/valtype/luhn5.man14
-rw-r--r--tcllib/modules/valtype/luhn5.tcl140
-rw-r--r--tcllib/modules/valtype/luhn5.test115
-rw-r--r--tcllib/modules/valtype/pkgIndex.tcl13
-rw-r--r--tcllib/modules/valtype/usnpi.man14
-rw-r--r--tcllib/modules/valtype/usnpi.tcl65
-rw-r--r--tcllib/modules/valtype/usnpi.test102
-rw-r--r--tcllib/modules/valtype/valtype.tcl77
-rw-r--r--tcllib/modules/valtype/valtype_common.man110
-rw-r--r--tcllib/modules/valtype/valtype_common.pcx44
-rw-r--r--tcllib/modules/valtype/valtype_creditcard_amex.pcx27
-rw-r--r--tcllib/modules/valtype/valtype_creditcard_discover.pcx27
-rw-r--r--tcllib/modules/valtype/valtype_creditcard_mastercard.pcx27
-rw-r--r--tcllib/modules/valtype/valtype_creditcard_visa.pcx27
-rw-r--r--tcllib/modules/valtype/valtype_gs1_ean13.pcx27
-rw-r--r--tcllib/modules/valtype/valtype_imei.pcx27
-rw-r--r--tcllib/modules/valtype/valtype_isbn.pcx30
-rw-r--r--tcllib/modules/valtype/valtype_luhn.pcx29
-rw-r--r--tcllib/modules/valtype/valtype_luhn5.pcx29
-rw-r--r--tcllib/modules/valtype/valtype_usnpi.pcx27
-rw-r--r--tcllib/modules/valtype/valtype_verhoeff.pcx29
-rw-r--r--tcllib/modules/valtype/verhoeff.man14
-rw-r--r--tcllib/modules/valtype/verhoeff.tcl128
-rw-r--r--tcllib/modules/valtype/verhoeff.test92
-rw-r--r--tcllib/modules/virtchannel_base/ChangeLog120
-rw-r--r--tcllib/modules/virtchannel_base/README.txt44
-rw-r--r--tcllib/modules/virtchannel_base/cat.man47
-rw-r--r--tcllib/modules/virtchannel_base/cat.tcl139
-rw-r--r--tcllib/modules/virtchannel_base/facade.man73
-rw-r--r--tcllib/modules/virtchannel_base/facade.tcl234
-rw-r--r--tcllib/modules/virtchannel_base/fifo.tcl138
-rw-r--r--tcllib/modules/virtchannel_base/fifo2.tcl111
-rw-r--r--tcllib/modules/virtchannel_base/halfpipe.man81
-rw-r--r--tcllib/modules/virtchannel_base/halfpipe.tcl168
-rw-r--r--tcllib/modules/virtchannel_base/memchan.tcl168
-rw-r--r--tcllib/modules/virtchannel_base/null.tcl54
-rw-r--r--tcllib/modules/virtchannel_base/nullzero.man44
-rw-r--r--tcllib/modules/virtchannel_base/nullzero.tcl62
-rw-r--r--tcllib/modules/virtchannel_base/pkgIndex.tcl17
-rw-r--r--tcllib/modules/virtchannel_base/random.tcl80
-rw-r--r--tcllib/modules/virtchannel_base/randseed.man43
-rw-r--r--tcllib/modules/virtchannel_base/randseed.tcl58
-rw-r--r--tcllib/modules/virtchannel_base/std.man43
-rw-r--r--tcllib/modules/virtchannel_base/std.tcl97
-rw-r--r--tcllib/modules/virtchannel_base/string.tcl124
-rw-r--r--tcllib/modules/virtchannel_base/tcllib_fifo.man43
-rw-r--r--tcllib/modules/virtchannel_base/tcllib_fifo2.man50
-rw-r--r--tcllib/modules/virtchannel_base/tcllib_memchan.man44
-rw-r--r--tcllib/modules/virtchannel_base/tcllib_null.man45
-rw-r--r--tcllib/modules/virtchannel_base/tcllib_random.man46
-rw-r--r--tcllib/modules/virtchannel_base/tcllib_string.man45
-rw-r--r--tcllib/modules/virtchannel_base/tcllib_variable.man46
-rw-r--r--tcllib/modules/virtchannel_base/tcllib_zero.man45
-rw-r--r--tcllib/modules/virtchannel_base/textwindow.man39
-rw-r--r--tcllib/modules/virtchannel_base/textwindow.tcl74
-rw-r--r--tcllib/modules/virtchannel_base/variable.tcl181
-rw-r--r--tcllib/modules/virtchannel_base/zero.tcl54
-rw-r--r--tcllib/modules/virtchannel_core/ChangeLog39
-rw-r--r--tcllib/modules/virtchannel_core/README.txt5
-rw-r--r--tcllib/modules/virtchannel_core/core.man72
-rw-r--r--tcllib/modules/virtchannel_core/core.tcl73
-rw-r--r--tcllib/modules/virtchannel_core/events.man79
-rw-r--r--tcllib/modules/virtchannel_core/events.tcl154
-rw-r--r--tcllib/modules/virtchannel_core/pkgIndex.tcl8
-rw-r--r--tcllib/modules/virtchannel_core/transformcore.man72
-rw-r--r--tcllib/modules/virtchannel_core/transformcore.tcl71
-rw-r--r--tcllib/modules/virtchannel_transform/ChangeLog53
-rw-r--r--tcllib/modules/virtchannel_transform/README.txt38
-rw-r--r--tcllib/modules/virtchannel_transform/adler32.man70
-rw-r--r--tcllib/modules/virtchannel_transform/adler32.tcl103
-rw-r--r--tcllib/modules/virtchannel_transform/base64.tcl111
-rw-r--r--tcllib/modules/virtchannel_transform/counter.tcl94
-rw-r--r--tcllib/modules/virtchannel_transform/crc32.tcl103
-rw-r--r--tcllib/modules/virtchannel_transform/hex.man43
-rw-r--r--tcllib/modules/virtchannel_transform/hex.tcl58
-rw-r--r--tcllib/modules/virtchannel_transform/identity.man50
-rw-r--r--tcllib/modules/virtchannel_transform/identity.tcl59
-rw-r--r--tcllib/modules/virtchannel_transform/limitsize.man46
-rw-r--r--tcllib/modules/virtchannel_transform/limitsize.tcl88
-rw-r--r--tcllib/modules/virtchannel_transform/observe.man50
-rw-r--r--tcllib/modules/virtchannel_transform/observe.tcl80
-rw-r--r--tcllib/modules/virtchannel_transform/otp.tcl98
-rw-r--r--tcllib/modules/virtchannel_transform/pkgIndex.tcl14
-rw-r--r--tcllib/modules/virtchannel_transform/rot.man57
-rw-r--r--tcllib/modules/virtchannel_transform/rot.tcl95
-rw-r--r--tcllib/modules/virtchannel_transform/spacer.man45
-rw-r--r--tcllib/modules/virtchannel_transform/spacer.tcl151
-rw-r--r--tcllib/modules/virtchannel_transform/tcllib_zlib.man46
-rw-r--r--tcllib/modules/virtchannel_transform/vt_base64.man44
-rw-r--r--tcllib/modules/virtchannel_transform/vt_counter.man68
-rw-r--r--tcllib/modules/virtchannel_transform/vt_crc32.man70
-rw-r--r--tcllib/modules/virtchannel_transform/vt_otp.man53
-rw-r--r--tcllib/modules/virtchannel_transform/zlib.tcl100
-rw-r--r--tcllib/modules/websocket/ChangeLog31
-rw-r--r--tcllib/modules/websocket/pkgIndex.tcl11
-rw-r--r--tcllib/modules/websocket/websocket.man385
-rw-r--r--tcllib/modules/websocket/websocket.tcl1754
-rw-r--r--tcllib/modules/wip/ChangeLog100
-rw-r--r--tcllib/modules/wip/pkgIndex.tcl5
-rw-r--r--tcllib/modules/wip/wip.man384
-rw-r--r--tcllib/modules/wip/wip.tcl463
-rw-r--r--tcllib/modules/wip/wip2.tcl464
-rw-r--r--tcllib/modules/yaml/06eef112da.data7
-rw-r--r--tcllib/modules/yaml/CHANGES62
-rw-r--r--tcllib/modules/yaml/ChangeLog52
-rwxr-xr-xtcllib/modules/yaml/huddle.man558
-rwxr-xr-xtcllib/modules/yaml/huddle.tcl646
-rwxr-xr-xtcllib/modules/yaml/huddle.test363
-rw-r--r--tcllib/modules/yaml/huddle_types.tcl296
-rw-r--r--tcllib/modules/yaml/json2huddle.tcl389
-rw-r--r--tcllib/modules/yaml/json2huddle.test181
-rwxr-xr-xtcllib/modules/yaml/layers.txt224
-rw-r--r--tcllib/modules/yaml/pkgIndex.tcl6
-rw-r--r--tcllib/modules/yaml/rb.test654
-rwxr-xr-xtcllib/modules/yaml/yaml.bench87
-rw-r--r--tcllib/modules/yaml/yaml.man189
-rw-r--r--tcllib/modules/yaml/yaml.tcl1283
-rw-r--r--tcllib/modules/yaml/yaml.test775
-rw-r--r--tcllib/modules/zip/ChangeLog30
-rw-r--r--tcllib/modules/zip/decode.man135
-rw-r--r--tcllib/modules/zip/decode.tcl690
-rw-r--r--tcllib/modules/zip/encode.man92
-rw-r--r--tcllib/modules/zip/encode.tcl372
-rw-r--r--tcllib/modules/zip/mkzip.man104
-rw-r--r--tcllib/modules/zip/mkzip.tcl282
-rw-r--r--tcllib/modules/zip/pkgIndex.tcl8
4149 files changed, 757823 insertions, 0 deletions
diff --git a/tcllib/modules/aes/ChangeLog b/tcllib/modules/aes/ChangeLog
new file mode 100644
index 0000000..2c7b5ee
--- /dev/null
+++ b/tcllib/modules/aes/ChangeLog
@@ -0,0 +1,146 @@
+2013-05-30 Andreas Kupries <andreask@activestate.com>
+
+ * aes.tcl (::aes::Chunk): [Bug 3612645][Allura 1366]: Fix handling
+ * aes.test: of last block read, it may be empty. In that case we
+ * aes.man: must not pad, nor try to decrypt it into garbage.
+ * pkgIndex.tcl: Extended testsuite with cases for this. Version
+ bumped to 1.1.1.
+
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2013-01-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * aes.man: [Bug 3574004]: Documented the -- option stopping
+ * aes.tcl: option processing to protect data starting with
+ * aes.test: a dash. Additionally auto-stop if only one argument
+ * pkgIndex.tcl: is left, treating it as data. Bumped to
+ version 1.1.
+
+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 ========================
+ *
+
+2010-07-06 Andreas Kupries <andreask@activestate.com>
+
+ * aes.tcl (DecryptBlock, EncryptBlock): [Bug 2993029]: More code
+ * aes.man: limiting the values to int32 range. Extended the
+ * aes.test: testsuite. Bumped version to 1.0.2. See also the
+ * pkgIndex.tcl: changelog entry of 2008-05-12.
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-01-19 Elchonon Edelson <eee@users.sourceforge.net>
+
+ * aes.man: Minor enhancement.
+
+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 ========================
+ *
+
+2008-06-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * aes.pcx: New file. Syntax definitions for the public commands of
+ the aes package.
+
+2008-05-13 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Version bump missed the index :(
+
+2008-05-12 Andreas Kupries <andreask@activestate.com>
+
+ * aes.tcl (DecryptBlock, EncryptBlock): Added code limiting the
+ * aes.man: values to int32 range, to prevent going out of range
+ * aes.test: when run by Tcl 8.5 and its bignums. Extended
+ * pkgIndex.tcl: testsuite to catch a problematic case which fails
+ without the change. Bumped version to 1.0.1.
+
+ * aes.tcl (::aes::Pop, ::aes::aes): Also, cleaned up upvar command
+ without explicit level information.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-03-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * aes.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-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * aes.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * aes.test: Hooked into the new common test support code.
+
+2005-10-18 Andreas Kupries <andreask@activestate.com>
+
+ * aes.bench: Extended with benchmarks for the keyschedule.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-09-04 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * aes.tcl: Frink warning suppression
+ * aes.man: Added a description of cipher modes of operation.
+
+2005-09-01 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * aes.tcl: Re-written to support CBC mode AES and to allow for
+ * aes.test: the tcllib-style programming API (as per blowfish, RC4 and
+ * aes.man: the hash implementations). Converted from an array based
+ * pkgIndex.tcl: implementation to a list based implementation and
+ gained a 4x speedup. Set to 1.0.0 for now the API is fixed.
+
+2005-08-30 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: **New file**. Added the missing package index
+ without which the package cannot be used.
+
+2005-08-29 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * aes.tcl: Added a number of performance improvements
+ * aes.test:
+
+2005-08-29 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * aes.tcl: Initial import of a Tcl implementation of
+ * aes.test: the Advanced Encryption Standard contributed
+ * aes.man: by Thorsten Schloermann <fattobi@users.sourceforge.net>
diff --git a/tcllib/modules/aes/aes.bench b/tcllib/modules/aes/aes.bench
new file mode 100644
index 0000000..9ab598f
--- /dev/null
+++ b/tcllib/modules/aes/aes.bench
@@ -0,0 +1,75 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'aes' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+package forget aes
+catch {namespace delete ::aes}
+source [file join [file dirname [info script]] aes.tcl]
+
+set i [binary format H* 00000000000000000000000000000000]
+set p [binary format H* 00112233445566778899aabbccddeeff]
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+foreach {len k c} [list \
+ 128 \
+ [binary format H* 000102030405060708090a0b0c0d0e0f] \
+ [binary format H* 69c4e0d86a7b0430d8cdb78070b4c55a] \
+ 192 \
+ [binary format H* 000102030405060708090a0b0c0d0e0f1011121314151617] \
+ [binary format H* dda97ca4864cdfe06eaf70a0ec0d7191] \
+ 256 \
+ [binary format H* 000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f] \
+ [binary format H* 8ea2b7ca516745bfeafc49904b496089] \
+ ] {
+
+ bench -desc "AES-${len} ECB encryption" -body {
+ aes::aes -mode ecb -dir enc -key $k -iv $i $p
+ }
+
+ bench -desc "AES-${len} ECB decryption" -body {
+ aes::aes -mode ecb -dir dec -key $k -iv $i $c
+ }
+
+ bench -desc "AES-${len} ECB encryption core" -pre {
+ set key [aes::Init ecb $k $i]
+ } -body {
+ aes::Encrypt $key $p
+ } -post {
+ aes::Final $key
+ }
+
+ bench -desc "AES-${len} ECB decryption core" -pre {
+ set key [aes::Init ecb $k $i]
+ } -body {
+ aes::Decrypt $key $c
+ } -post {
+ aes::Final $key
+ }
+
+ bench -desc "AES-${len} ECB keyschedule" -body {
+ aes::Final [aes::Init ecb $k $i]
+ }
+
+ bench -desc "AES-${len} CBC keyschedule" -body {
+ aes::Final [aes::Init cbc $k $i]
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/aes/aes.man b/tcllib/modules/aes/aes.man
new file mode 100644
index 0000000..93a73c1
--- /dev/null
+++ b/tcllib/modules/aes/aes.man
@@ -0,0 +1,168 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset AES_VERSION 1.2.1]
+[manpage_begin aes n [vset AES_VERSION]]
+[see_also blowfish(n)]
+[see_also des(n)]
+[see_also md5(n)]
+[see_also sha1(n)]
+[keywords aes]
+[keywords {block cipher}]
+[keywords {data integrity}]
+[keywords encryption]
+[keywords security]
+[copyright {2005, Pat Thoyts <patthoyts@users.sourceforge.net>}]
+[copyright {2012-2014, Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Advanced Encryption Standard (AES)}]
+[titledesc {Implementation of the AES block cipher}]
+[category {Hashes, checksums, and encryption}]
+[require Tcl 8.5]
+[require aes [opt [vset AES_VERSION]]]
+[description]
+[para]
+
+This is an implementation in Tcl of the Advanced Encryption Standard
+(AES) as published by the U.S. National Institute of Standards and
+Technology [lb]1[rb]. AES is a 128-bit block cipher with a variable
+key size of 128, 192 or 256 bits. This implementation supports ECB and
+CBC modes.
+
+[section {COMMANDS}]
+
+[list_begin definitions]
+
+[call [cmd "::aes::aes"] \
+ [opt [arg "-mode [lb]ecb|cbc[rb]"]] \
+ [opt [arg "-dir [lb]encrypt|decrypt[rb]"]] \
+ [arg "-key keydata"] \
+ [opt [arg "-iv vector"]] \
+ [opt [arg "-hex"]] \
+ [opt [arg "-out channel"]] \
+ [opt [arg "-chunksize size"]] \
+ [lb] [arg "-in channel"] | \
+ [opt [option --]] [arg "data"] [rb]]
+
+Perform the [package aes] algorithm on either the data provided
+by the argument or on the data read from the [arg "-in"] channel. If
+an [arg "-out"] channel is given then the result will be written to
+this channel.
+
+[para]
+
+The [arg -key] option must be given. This parameter takes a binary
+string of either 16, 24 or 32 bytes in length and is used to generate the
+key schedule.
+
+[para]
+
+The [arg -mode] and [arg -dir] options are optional and default to cbc
+mode and encrypt respectively. The initialization vector [arg -iv]
+takes a 16 byte binary argument which defaults to all zeros.
+See [sectref "MODES OF OPERATION"] for more about available modes and
+their uses.
+
+[para]
+
+AES is a 128-bit block cipher. This means that the data must be
+provided in units that are a multiple of 16 bytes.
+
+[list_end]
+
+[section "PROGRAMMING INTERFACE"]
+
+Internal state is maintained in an opaque structure that is returned
+from the [cmd Init] function. In ECB mode the state is not affected by
+the input but for CBC mode some input dependent state is maintained
+and may be reset by calling the [cmd Reset] function with a new
+initialization vector value.
+
+[list_begin definitions]
+
+[call [cmd "::aes::Init"] [arg "mode"] [arg "keydata"] [arg "iv"]]
+
+Construct a new AES key schedule using the specified key data and the
+given initialization vector. The initialization vector is not used
+with ECB mode but is important for CBC mode.
+See [sectref "MODES OF OPERATION"] for details about cipher modes.
+
+[call [cmd "::aes::Encrypt"] [arg "Key"] [arg "data"]]
+
+Use a prepared key acquired by calling [cmd Init] to encrypt the
+provided data. The data argument should be a binary array that is a
+multiple of the AES block size of 16 bytes. The result is a binary
+array the same size as the input of encrypted data.
+
+[call [cmd "::aes::Decrypt"] [arg "Key"] [arg "data"]]
+
+Decipher data using the key. Note that the same key may be used to
+encrypt and decrypt data provided that the initialization vector is
+reset appropriately for CBC mode.
+
+[call [cmd "::aes::Reset"] [arg "Key"] [arg "iv"]]
+
+Reset the initialization vector. This permits the programmer to re-use
+a key and avoid the cost of re-generating the key schedule where the
+same key data is being used multiple times.
+
+[call [cmd "::aes::Final"] [arg "Key"]]
+
+This should be called to clean up resources associated with [arg Key].
+Once this function has been called the key may not be used again.
+
+[list_end]
+
+[section "MODES OF OPERATION"]
+
+[list_begin definitions]
+
+[def "Electronic Code Book (ECB)"]
+ECB is the basic mode of all block ciphers. Each block is encrypted
+independently and so identical plain text will produce identical
+output when encrypted with the same key. Any encryption errors will
+only affect a single block however this is vulnerable to known
+plaintext attacks.
+
+[def "Cipher Block Chaining (CBC)"]
+
+CBC mode uses the output of the last block encryption to affect the
+current block. An initialization vector of the same size as the cipher
+block size is used to handle the first block. The initialization
+vector should be chosen randomly and transmitted as the first block of
+the output. Errors in encryption affect the current block and the next
+block after which the cipher will correct itself. CBC is the most
+commonly used mode in software encryption. This is the default mode
+of operation for this module.
+
+[list_end]
+
+[section "EXAMPLES"]
+
+[example {
+% set nil_block [string repeat \\0 16]
+% aes::aes -hex -mode cbc -dir encrypt -key $nil_block $nil_block
+66e94bd4ef8a2c3b884cfa59ca342b2e
+}]
+
+[example {
+set Key [aes::Init cbc $sixteen_bytes_key_data $sixteen_byte_iv]
+append ciphertext [aes::Encrypt $Key $plaintext]
+append ciphertext [aes::Encrypt $Key $additional_plaintext]
+aes::Final $Key
+}]
+
+[section "REFERENCES"]
+
+[list_begin enumerated]
+
+[enum]
+ "Advanced Encryption Standard",
+ Federal Information Processing Standards Publication 197, 2001
+ ([uri http://csrc.nist.gov/publications/fips/fips197/fips-197.pdf])
+
+[list_end]
+
+[section AUTHORS]
+Thorsten Schloermann, Pat Thoyts
+
+[vset CATEGORY aes]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/aes/aes.pcx b/tcllib/modules/aes/aes.pcx
new file mode 100644
index 0000000..75031f4
--- /dev/null
+++ b/tcllib/modules/aes/aes.pcx
@@ -0,0 +1,99 @@
+# -*- tcl -*- aes.pcx
+# Syntax of the commands provided by package aes.
+#
+# 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 aes
+pcx::tcldep 1.0.0 needs tcl 8.2
+
+namespace eval ::aes {}
+
+# Using the indirections below looks to be quite pointless, given that
+# they simply substitute the commands for others. I am doing this for
+# two reasons.
+
+# First, the rules coming after become self-commenting, i.e. a
+# maintainer can immediately see what an argument is supposed to be,
+# instead of having to search elsewhere (like the documentation and
+# implementation). In this manner our definitions here are a type of
+# semantic markup.
+
+# The second reason is alluded to as well in the comments to the first
+# three definitions. While we have no special checks now we cannot be
+# sure if such will (have to) be added in the future. With all
+# checking routed through our definitions we now already have the
+# basic infrastructure (i.e. hooks) in place in which we can easily
+# add any new checks by simply redefining the relevant command, and
+# all the rules update on their own. Mostly. This should cover 90% of
+# the cases. Sometimes new checks will require to create deeper
+# distinctions between different calls of the same thing. For such we
+# may have to update the rules as well, to provide the necessary
+# information to the checker.
+
+interp alias {} aes::checkAesKey {} checkWord ; # Consider redefinition to check literals
+interp alias {} aes::checkAesData {} checkWord ; # for the proper size.
+interp alias {} aes::checkAesIV {} checkWord ; #
+interp alias {} aes::checkAesMode {} checkKeyword 1 {ecb cbc}
+interp alias {} aes::checkAesAction {} checkKeyword 1 {encrypt decrypt}
+
+#pcx::message FOO {... text ...} type
+pcx::message needKey {Required -key is missing} err
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.0.0 std ::aes::Decrypt \
+ {checkSimpleArgs 2 2 {
+ aes::checkAesKey
+ aes::checkAesData
+ }}
+pcx::check 1.0.0 std ::aes::Encrypt \
+ {checkSimpleArgs 2 2 {
+ aes::checkAesKey
+ aes::checkAesData
+ }}
+pcx::check 1.0.0 std ::aes::Final \
+ {checkSimpleArgs 1 1 {
+ aes::checkAesKey
+ }}
+pcx::check 1.0.0 std ::aes::Init \
+ {checkSimpleArgs 3 3 {
+ aes::checkAesMode
+ aes::checkAesKey
+ aes::checkAesIV
+ }}
+pcx::check 1.0.0 std ::aes::Reset \
+ {checkSimpleArgs 2 2 {
+ aes::checkAesKey
+ aes::checkAesIV
+ }}
+pcx::check 1.0.0 std ::aes::aes \
+ {checkConstrained {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ {-mode aes::checkAesMode}
+ {-dir aes::checkAesAction}
+ {-key {checkSetConstraint haskey aes::checkAesKey}}
+ {-iv aes::checkAesIV}
+ {-hex}
+ {-out checkChannelID}
+ {-chunksize checkWholeNum}
+ {-in {checkSetConstraint hasin checkChannelID}}
+ } {checkConstraint {
+ {{!haskey && hasin} {warn aes::needKey {} {
+ checkAtEnd
+ }}}
+ {hasin checkAtEnd}
+ {{!haskey} {warn aes::needKey {} {checkSimpleArgs 1 1 {
+ aes::checkAesData
+ }}}}
+ } {checkSimpleArgs 1 1 {
+ aes::checkAesData
+ }}}}
+ }}}
+
+# Initialization via pcx::init.
+# Use a ::aes::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/aes/aes.tcl b/tcllib/modules/aes/aes.tcl
new file mode 100644
index 0000000..6a1849b
--- /dev/null
+++ b/tcllib/modules/aes/aes.tcl
@@ -0,0 +1,625 @@
+# aes.tcl -
+#
+# Copyright (c) 2005 Thorsten Schloermann
+# Copyright (c) 2005 Pat Thoyts <patthoyts@users.sourceforge.net>
+# Copyright (c) 2013 Andreas Kupries
+#
+# A Tcl implementation of the Advanced Encryption Standard (US FIPS PUB 197)
+#
+# AES is a block cipher with a block size of 128 bits and a variable
+# key size of 128, 192 or 256 bits.
+# The algorithm works on each block as a 4x4 state array. There are 4 steps
+# in each round:
+# SubBytes a non-linear substitution step using a predefined S-box
+# ShiftRows cyclic transposition of rows in the state matrix
+# MixColumns transformation upon columns in the state matrix
+# AddRoundKey application of round specific sub-key
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.5
+
+namespace eval ::aes {
+ variable uid
+ if {![info exists uid]} { set uid 0 }
+
+ namespace export aes
+
+ # constants
+
+ # S-box
+ variable sbox {
+ 0x63 0x7c 0x77 0x7b 0xf2 0x6b 0x6f 0xc5 0x30 0x01 0x67 0x2b 0xfe 0xd7 0xab 0x76
+ 0xca 0x82 0xc9 0x7d 0xfa 0x59 0x47 0xf0 0xad 0xd4 0xa2 0xaf 0x9c 0xa4 0x72 0xc0
+ 0xb7 0xfd 0x93 0x26 0x36 0x3f 0xf7 0xcc 0x34 0xa5 0xe5 0xf1 0x71 0xd8 0x31 0x15
+ 0x04 0xc7 0x23 0xc3 0x18 0x96 0x05 0x9a 0x07 0x12 0x80 0xe2 0xeb 0x27 0xb2 0x75
+ 0x09 0x83 0x2c 0x1a 0x1b 0x6e 0x5a 0xa0 0x52 0x3b 0xd6 0xb3 0x29 0xe3 0x2f 0x84
+ 0x53 0xd1 0x00 0xed 0x20 0xfc 0xb1 0x5b 0x6a 0xcb 0xbe 0x39 0x4a 0x4c 0x58 0xcf
+ 0xd0 0xef 0xaa 0xfb 0x43 0x4d 0x33 0x85 0x45 0xf9 0x02 0x7f 0x50 0x3c 0x9f 0xa8
+ 0x51 0xa3 0x40 0x8f 0x92 0x9d 0x38 0xf5 0xbc 0xb6 0xda 0x21 0x10 0xff 0xf3 0xd2
+ 0xcd 0x0c 0x13 0xec 0x5f 0x97 0x44 0x17 0xc4 0xa7 0x7e 0x3d 0x64 0x5d 0x19 0x73
+ 0x60 0x81 0x4f 0xdc 0x22 0x2a 0x90 0x88 0x46 0xee 0xb8 0x14 0xde 0x5e 0x0b 0xdb
+ 0xe0 0x32 0x3a 0x0a 0x49 0x06 0x24 0x5c 0xc2 0xd3 0xac 0x62 0x91 0x95 0xe4 0x79
+ 0xe7 0xc8 0x37 0x6d 0x8d 0xd5 0x4e 0xa9 0x6c 0x56 0xf4 0xea 0x65 0x7a 0xae 0x08
+ 0xba 0x78 0x25 0x2e 0x1c 0xa6 0xb4 0xc6 0xe8 0xdd 0x74 0x1f 0x4b 0xbd 0x8b 0x8a
+ 0x70 0x3e 0xb5 0x66 0x48 0x03 0xf6 0x0e 0x61 0x35 0x57 0xb9 0x86 0xc1 0x1d 0x9e
+ 0xe1 0xf8 0x98 0x11 0x69 0xd9 0x8e 0x94 0x9b 0x1e 0x87 0xe9 0xce 0x55 0x28 0xdf
+ 0x8c 0xa1 0x89 0x0d 0xbf 0xe6 0x42 0x68 0x41 0x99 0x2d 0x0f 0xb0 0x54 0xbb 0x16
+ }
+ # inverse S-box
+ variable xobs {
+ 0x52 0x09 0x6a 0xd5 0x30 0x36 0xa5 0x38 0xbf 0x40 0xa3 0x9e 0x81 0xf3 0xd7 0xfb
+ 0x7c 0xe3 0x39 0x82 0x9b 0x2f 0xff 0x87 0x34 0x8e 0x43 0x44 0xc4 0xde 0xe9 0xcb
+ 0x54 0x7b 0x94 0x32 0xa6 0xc2 0x23 0x3d 0xee 0x4c 0x95 0x0b 0x42 0xfa 0xc3 0x4e
+ 0x08 0x2e 0xa1 0x66 0x28 0xd9 0x24 0xb2 0x76 0x5b 0xa2 0x49 0x6d 0x8b 0xd1 0x25
+ 0x72 0xf8 0xf6 0x64 0x86 0x68 0x98 0x16 0xd4 0xa4 0x5c 0xcc 0x5d 0x65 0xb6 0x92
+ 0x6c 0x70 0x48 0x50 0xfd 0xed 0xb9 0xda 0x5e 0x15 0x46 0x57 0xa7 0x8d 0x9d 0x84
+ 0x90 0xd8 0xab 0x00 0x8c 0xbc 0xd3 0x0a 0xf7 0xe4 0x58 0x05 0xb8 0xb3 0x45 0x06
+ 0xd0 0x2c 0x1e 0x8f 0xca 0x3f 0x0f 0x02 0xc1 0xaf 0xbd 0x03 0x01 0x13 0x8a 0x6b
+ 0x3a 0x91 0x11 0x41 0x4f 0x67 0xdc 0xea 0x97 0xf2 0xcf 0xce 0xf0 0xb4 0xe6 0x73
+ 0x96 0xac 0x74 0x22 0xe7 0xad 0x35 0x85 0xe2 0xf9 0x37 0xe8 0x1c 0x75 0xdf 0x6e
+ 0x47 0xf1 0x1a 0x71 0x1d 0x29 0xc5 0x89 0x6f 0xb7 0x62 0x0e 0xaa 0x18 0xbe 0x1b
+ 0xfc 0x56 0x3e 0x4b 0xc6 0xd2 0x79 0x20 0x9a 0xdb 0xc0 0xfe 0x78 0xcd 0x5a 0xf4
+ 0x1f 0xdd 0xa8 0x33 0x88 0x07 0xc7 0x31 0xb1 0x12 0x10 0x59 0x27 0x80 0xec 0x5f
+ 0x60 0x51 0x7f 0xa9 0x19 0xb5 0x4a 0x0d 0x2d 0xe5 0x7a 0x9f 0x93 0xc9 0x9c 0xef
+ 0xa0 0xe0 0x3b 0x4d 0xae 0x2a 0xf5 0xb0 0xc8 0xeb 0xbb 0x3c 0x83 0x53 0x99 0x61
+ 0x17 0x2b 0x04 0x7e 0xba 0x77 0xd6 0x26 0xe1 0x69 0x14 0x63 0x55 0x21 0x0c 0x7d
+ }
+}
+
+# aes::Init --
+#
+# Initialise our AES state and calculate the key schedule. An initialization
+# vector is maintained in the state for modes that require one. The key must
+# be binary data of the correct size and the IV must be 16 bytes.
+#
+# Nk: columns of the key-array
+# Nr: number of rounds (depends on key-length)
+# Nb: columns of the text-block, is always 4 in AES
+#
+proc ::aes::Init {mode key iv} {
+ switch -exact -- $mode {
+ ecb - cbc { }
+ cfb - ofb {
+ return -code error "$mode mode not implemented"
+ }
+ default {
+ return -code error "invalid mode \"$mode\":\
+ must be one of ecb or cbc."
+ }
+ }
+
+ set size [expr {[string length $key] << 3}]
+ switch -exact -- $size {
+ 128 {set Nk 4; set Nr 10; set Nb 4}
+ 192 {set Nk 6; set Nr 12; set Nb 4}
+ 256 {set Nk 8; set Nr 14; set Nb 4}
+ default {
+ return -code error "invalid key size \"$size\":\
+ must be one of 128, 192 or 256."
+ }
+ }
+
+ variable uid
+ set Key [namespace current]::[incr uid]
+ upvar #0 $Key state
+ if {[binary scan $iv Iu4 state(I)] != 1} {
+ return -code error "invalid initialization vector: must be 16 bytes"
+ }
+ array set state [list M $mode K $key Nk $Nk Nr $Nr Nb $Nb W {}]
+ ExpandKey $Key
+ return $Key
+}
+
+# aes::Reset --
+#
+# Reset the initialization vector for the specified key. This permits the
+# key to be reused for encryption or decryption without the expense of
+# re-calculating the key schedule.
+#
+proc ::aes::Reset {Key iv} {
+ upvar #0 $Key state
+ if {[binary scan $iv Iu4 state(I)] != 1} {
+ return -code error "invalid initialization vector: must be 16 bytes"
+ }
+ return
+}
+
+# aes::Final --
+#
+# Clean up the key state
+#
+proc ::aes::Final {Key} {
+ # FRINK: nocheck
+ unset $Key
+}
+
+# -------------------------------------------------------------------------
+
+# 5.1 Cipher: Encipher a single block of 128 bits.
+proc ::aes::EncryptBlock {Key block} {
+ upvar #0 $Key state
+ if {[binary scan $block Iu4 data] != 1} {
+ return -code error "invalid block size: blocks must be 16 bytes"
+ }
+
+ if {$state(M) eq {cbc}} {
+ # Loop unrolled.
+ lassign $data d0 d1 d2 d3
+ lassign $state(I) s0 s1 s2 s3
+ set data [list \
+ [expr {$d0 ^ $s0}] \
+ [expr {$d1 ^ $s1}] \
+ [expr {$d2 ^ $s2}] \
+ [expr {$d3 ^ $s3}] ]
+ }
+
+ set data [AddRoundKey $Key 0 $data]
+ for {set n 1} {$n < $state(Nr)} {incr n} {
+ set data [AddRoundKey $Key $n [MixColumns [ShiftRows [SubBytes $data]]]]
+ }
+ set data [AddRoundKey $Key $n [ShiftRows [SubBytes $data]]]
+
+ # Bug 2993029:
+ # Force all elements of data into the 32bit range.
+ # Loop unrolled
+ set res [Clamp32 $data]
+
+ set state(I) $res
+ binary format Iu4 $res
+}
+
+# 5.3: Inverse Cipher: Decipher a single 128 bit block.
+proc ::aes::DecryptBlock {Key block} {
+ upvar #0 $Key state
+ if {[binary scan $block Iu4 data] != 1} {
+ return -code error "invalid block size: block must be 16 bytes"
+ }
+ set iv $data
+
+ set n $state(Nr)
+ set data [AddRoundKey $Key $state(Nr) $data]
+ for {incr n -1} {$n > 0} {incr n -1} {
+ set data [InvMixColumns [AddRoundKey $Key $n [InvSubBytes [InvShiftRows $data]]]]
+ }
+ set data [AddRoundKey $Key $n [InvSubBytes [InvShiftRows $data]]]
+
+ if {$state(M) eq {cbc}} {
+ lassign $data d0 d1 d2 d3
+ lassign $state(I) s0 s1 s2 s3
+ set data [list \
+ [expr {($d0 ^ $s0) & 0xffffffff}] \
+ [expr {($d1 ^ $s1) & 0xffffffff}] \
+ [expr {($d2 ^ $s2) & 0xffffffff}] \
+ [expr {($d3 ^ $s3) & 0xffffffff}] ]
+ } else {
+ # Bug 2993029:
+ # The integrated clamping we see above only happens for CBC mode.
+ set data [Clamp32 $data]
+ }
+
+ set state(I) $iv
+ binary format Iu4 $data
+}
+
+proc ::aes::Clamp32 {data} {
+ # Force all elements into 32bit range.
+ lassign $data d0 d1 d2 d3
+ list \
+ [expr {$d0 & 0xffffffff}] \
+ [expr {$d1 & 0xffffffff}] \
+ [expr {$d2 & 0xffffffff}] \
+ [expr {$d3 & 0xffffffff}]
+}
+
+# 5.2: KeyExpansion
+proc ::aes::ExpandKey {Key} {
+ upvar #0 $Key state
+ set Rcon [list 0x00000000 0x01000000 0x02000000 0x04000000 0x08000000 \
+ 0x10000000 0x20000000 0x40000000 0x80000000 0x1b000000 \
+ 0x36000000 0x6c000000 0xd8000000 0xab000000 0x4d000000]
+ # Split the key into Nk big-endian words
+ binary scan $state(K) I* W
+ set max [expr {$state(Nb) * ($state(Nr) + 1)}]
+ set i $state(Nk)
+ set h [expr {$i - 1}]
+ set j 0
+ for {} {$i < $max} {incr i; incr h; incr j} {
+ set temp [lindex $W $h]
+ if {($i % $state(Nk)) == 0} {
+ set sub [SubWord [RotWord $temp]]
+ set rc [lindex $Rcon [expr {$i/$state(Nk)}]]
+ set temp [expr {$sub ^ $rc}]
+ } elseif {$state(Nk) > 6 && ($i % $state(Nk)) == 4} {
+ set temp [SubWord $temp]
+ }
+ lappend W [expr {[lindex $W $j] ^ $temp}]
+ }
+ set state(W) $W
+}
+
+# 5.2: Key Expansion: Apply S-box to each byte in the 32 bit word
+proc ::aes::SubWord {w} {
+ variable sbox
+ set s3 [lindex $sbox [expr {($w >> 24) & 255}]]
+ set s2 [lindex $sbox [expr {($w >> 16) & 255}]]
+ set s1 [lindex $sbox [expr {($w >> 8 ) & 255}]]
+ set s0 [lindex $sbox [expr { $w & 255}]]
+ return [expr {($s3 << 24) | ($s2 << 16) | ($s1 << 8) | $s0}]
+}
+
+proc ::aes::InvSubWord {w} {
+ variable xobs
+ set s3 [lindex $xobs [expr {($w >> 24) & 255}]]
+ set s2 [lindex $xobs [expr {($w >> 16) & 255}]]
+ set s1 [lindex $xobs [expr {($w >> 8 ) & 255}]]
+ set s0 [lindex $xobs [expr { $w & 255}]]
+ return [expr {($s3 << 24) | ($s2 << 16) | ($s1 << 8) | $s0}]
+}
+
+# 5.2: Key Expansion: Rotate a 32bit word by 8 bits
+proc ::aes::RotWord {w} {
+ return [expr {(($w << 8) | (($w >> 24) & 0xff)) & 0xffffffff}]
+}
+
+# 5.1.1: SubBytes() Transformation
+proc ::aes::SubBytes {words} {
+ lassign $words w0 w1 w2 w3
+ list [SubWord $w0] [SubWord $w1] [SubWord $w2] [SubWord $w3]
+}
+
+# 5.3.2: InvSubBytes() Transformation
+proc ::aes::InvSubBytes {words} {
+ lassign $words w0 w1 w2 w3
+ list [InvSubWord $w0] [InvSubWord $w1] [InvSubWord $w2] [InvSubWord $w3]
+}
+
+# 5.1.2: ShiftRows() Transformation
+proc ::aes::ShiftRows {words} {
+ for {set n0 0} {$n0 < 4} {incr n0} {
+ set n1 [expr {($n0 + 1) % 4}]
+ set n2 [expr {($n0 + 2) % 4}]
+ set n3 [expr {($n0 + 3) % 4}]
+ lappend r [expr {( [lindex $words $n0] & 0xff000000)
+ | ([lindex $words $n1] & 0x00ff0000)
+ | ([lindex $words $n2] & 0x0000ff00)
+ | ([lindex $words $n3] & 0x000000ff)
+ }]
+ }
+ return $r
+}
+
+
+# 5.3.1: InvShiftRows() Transformation
+proc ::aes::InvShiftRows {words} {
+ for {set n0 0} {$n0 < 4} {incr n0} {
+ set n1 [expr {($n0 + 1) % 4}]
+ set n2 [expr {($n0 + 2) % 4}]
+ set n3 [expr {($n0 + 3) % 4}]
+ lappend r [expr {( [lindex $words $n0] & 0xff000000)
+ | ([lindex $words $n3] & 0x00ff0000)
+ | ([lindex $words $n2] & 0x0000ff00)
+ | ([lindex $words $n1] & 0x000000ff)
+ }]
+ }
+ return $r
+}
+
+# 5.1.3: MixColumns() Transformation
+proc ::aes::MixColumns {words} {
+ set r {}
+ foreach w $words {
+ set r0 [expr {(($w >> 24) & 255)}]
+ set r1 [expr {(($w >> 16) & 255)}]
+ set r2 [expr {(($w >> 8 ) & 255)}]
+ set r3 [expr {( $w & 255)}]
+
+ set s0 [expr {[GFMult2 $r0] ^ [GFMult3 $r1] ^ $r2 ^ $r3}]
+ set s1 [expr {$r0 ^ [GFMult2 $r1] ^ [GFMult3 $r2] ^ $r3}]
+ set s2 [expr {$r0 ^ $r1 ^ [GFMult2 $r2] ^ [GFMult3 $r3]}]
+ set s3 [expr {[GFMult3 $r0] ^ $r1 ^ $r2 ^ [GFMult2 $r3]}]
+
+ lappend r [expr {($s0 << 24) | ($s1 << 16) | ($s2 << 8) | $s3}]
+ }
+ return $r
+}
+
+# 5.3.3: InvMixColumns() Transformation
+proc ::aes::InvMixColumns {words} {
+ set r {}
+ foreach w $words {
+ set r0 [expr {(($w >> 24) & 255)}]
+ set r1 [expr {(($w >> 16) & 255)}]
+ set r2 [expr {(($w >> 8 ) & 255)}]
+ set r3 [expr {( $w & 255)}]
+
+ set s0 [expr {[GFMult0e $r0] ^ [GFMult0b $r1] ^ [GFMult0d $r2] ^ [GFMult09 $r3]}]
+ set s1 [expr {[GFMult09 $r0] ^ [GFMult0e $r1] ^ [GFMult0b $r2] ^ [GFMult0d $r3]}]
+ set s2 [expr {[GFMult0d $r0] ^ [GFMult09 $r1] ^ [GFMult0e $r2] ^ [GFMult0b $r3]}]
+ set s3 [expr {[GFMult0b $r0] ^ [GFMult0d $r1] ^ [GFMult09 $r2] ^ [GFMult0e $r3]}]
+
+ lappend r [expr {($s0 << 24) | ($s1 << 16) | ($s2 << 8) | $s3}]
+ }
+ return $r
+}
+
+# 5.1.4: AddRoundKey() Transformation
+proc ::aes::AddRoundKey {Key round words} {
+ upvar #0 $Key state
+ set r {}
+ set n [expr {$round * $state(Nb)}]
+ foreach w $words {
+ lappend r [expr {$w ^ [lindex $state(W) $n]}]
+ incr n
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# ::aes::GFMult*
+#
+# some needed functions for multiplication in a Galois-field
+#
+proc ::aes::GFMult2 {number} {
+ # this is a tabular representation of xtime (multiplication by 2)
+ # it is used instead of calculation to prevent timing attacks
+ set xtime {
+ 0x00 0x02 0x04 0x06 0x08 0x0a 0x0c 0x0e 0x10 0x12 0x14 0x16 0x18 0x1a 0x1c 0x1e
+ 0x20 0x22 0x24 0x26 0x28 0x2a 0x2c 0x2e 0x30 0x32 0x34 0x36 0x38 0x3a 0x3c 0x3e
+ 0x40 0x42 0x44 0x46 0x48 0x4a 0x4c 0x4e 0x50 0x52 0x54 0x56 0x58 0x5a 0x5c 0x5e
+ 0x60 0x62 0x64 0x66 0x68 0x6a 0x6c 0x6e 0x70 0x72 0x74 0x76 0x78 0x7a 0x7c 0x7e
+ 0x80 0x82 0x84 0x86 0x88 0x8a 0x8c 0x8e 0x90 0x92 0x94 0x96 0x98 0x9a 0x9c 0x9e
+ 0xa0 0xa2 0xa4 0xa6 0xa8 0xaa 0xac 0xae 0xb0 0xb2 0xb4 0xb6 0xb8 0xba 0xbc 0xbe
+ 0xc0 0xc2 0xc4 0xc6 0xc8 0xca 0xcc 0xce 0xd0 0xd2 0xd4 0xd6 0xd8 0xda 0xdc 0xde
+ 0xe0 0xe2 0xe4 0xe6 0xe8 0xea 0xec 0xee 0xf0 0xf2 0xf4 0xf6 0xf8 0xfa 0xfc 0xfe
+ 0x1b 0x19 0x1f 0x1d 0x13 0x11 0x17 0x15 0x0b 0x09 0x0f 0x0d 0x03 0x01 0x07 0x05
+ 0x3b 0x39 0x3f 0x3d 0x33 0x31 0x37 0x35 0x2b 0x29 0x2f 0x2d 0x23 0x21 0x27 0x25
+ 0x5b 0x59 0x5f 0x5d 0x53 0x51 0x57 0x55 0x4b 0x49 0x4f 0x4d 0x43 0x41 0x47 0x45
+ 0x7b 0x79 0x7f 0x7d 0x73 0x71 0x77 0x75 0x6b 0x69 0x6f 0x6d 0x63 0x61 0x67 0x65
+ 0x9b 0x99 0x9f 0x9d 0x93 0x91 0x97 0x95 0x8b 0x89 0x8f 0x8d 0x83 0x81 0x87 0x85
+ 0xbb 0xb9 0xbf 0xbd 0xb3 0xb1 0xb7 0xb5 0xab 0xa9 0xaf 0xad 0xa3 0xa1 0xa7 0xa5
+ 0xdb 0xd9 0xdf 0xdd 0xd3 0xd1 0xd7 0xd5 0xcb 0xc9 0xcf 0xcd 0xc3 0xc1 0xc7 0xc5
+ 0xfb 0xf9 0xff 0xfd 0xf3 0xf1 0xf7 0xf5 0xeb 0xe9 0xef 0xed 0xe3 0xe1 0xe7 0xe5
+ }
+ lindex $xtime $number
+}
+
+proc ::aes::GFMult3 {number} {
+ # multliply by 2 (via GFMult2) and add the number again on the result (via XOR)
+ expr {$number ^ [GFMult2 $number]}
+}
+
+proc ::aes::GFMult09 {number} {
+ # 09 is: (02*02*02) + 01
+ expr {[GFMult2 [GFMult2 [GFMult2 $number]]] ^ $number}
+}
+
+proc ::aes::GFMult0b {number} {
+ # 0b is: (02*02*02) + 02 + 01
+ #return [expr [GFMult2 [GFMult2 [GFMult2 $number]]] ^ [GFMult2 $number] ^ $number]
+ #set g0 [GFMult2 $number]
+ expr {[GFMult09 $number] ^ [GFMult2 $number]}
+}
+
+proc ::aes::GFMult0d {number} {
+ # 0d is: (02*02*02) + (02*02) + 01
+ set temp [GFMult2 [GFMult2 $number]]
+ expr {[GFMult2 $temp] ^ ($temp ^ $number)}
+}
+
+proc ::aes::GFMult0e {number} {
+ # 0e is: (02*02*02) + (02*02) + 02
+ set temp [GFMult2 [GFMult2 $number]]
+ expr {[GFMult2 $temp] ^ ($temp ^ [GFMult2 $number])}
+}
+
+# -------------------------------------------------------------------------
+
+# aes::Encrypt --
+#
+# Encrypt a blocks of plain text and returns blocks of cipher text.
+# The input data must be a multiple of the block size (16).
+#
+proc ::aes::Encrypt {Key data} {
+ set len [string length $data]
+ if {($len % 16) != 0} {
+ return -code error "invalid block size: AES requires 16 byte blocks"
+ }
+
+ set result {}
+ for {set i 0} {$i < $len} {incr i 1} {
+ set block [string range $data $i [incr i 15]]
+ append result [EncryptBlock $Key $block]
+ }
+ return $result
+}
+
+# aes::Decrypt --
+#
+# Decrypt blocks of cipher text and returns blocks of plain text.
+# The input data must be a multiple of the block size (16).
+#
+proc ::aes::Decrypt {Key data} {
+ set len [string length $data]
+ if {($len % 16) != 0} {
+ return -code error "invalid block size: AES requires 16 byte blocks"
+ }
+
+ set result {}
+ for {set i 0} {$i < $len} {incr i 1} {
+ set block [string range $data $i [incr i 15]]
+ append result [DecryptBlock $Key $block]
+ }
+ return $result
+}
+
+# -------------------------------------------------------------------------
+# chan event handler for chunked file reading.
+#
+proc ::aes::Chunk {Key in {out {}} {chunksize 4096}} {
+ upvar #0 $Key state
+
+ #puts ||CHUNK.X||i=$in|o=$out|c=$chunksize|eof=[eof $in]
+
+ if {[eof $in]} {
+ chan event $in readable {}
+ set state(reading) 0
+ }
+
+ set data [read $in $chunksize]
+
+ #puts ||CHUNK.R||i=$in|o=$out|c=$chunksize|eof=[eof $in]||[string length $data]||$data||
+
+ # Do nothing when data was read at all.
+ if {$data eq {}} return
+
+ if {[eof $in]} {
+ #puts CHUNK.Z
+ set data [Pad $data 16]
+ }
+
+ #puts ||CHUNK.P||i=$in|o=$out|c=$chunksize|eof=[eof $in]||[string length $data]||$data||
+
+ if {$out eq {}} {
+ append state(output) [$state(cmd) $Key $data]
+ } else {
+ puts -nonewline $out [$state(cmd) $Key $data]
+ }
+}
+
+proc ::aes::SetOneOf {lst item} {
+ set ndx [lsearch -glob $lst "${item}*"]
+ if {$ndx == -1} {
+ set err [join $lst ", "]
+ return -code error "invalid mode \"$item\": must be one of $err"
+ }
+ lindex $lst $ndx
+}
+
+proc ::aes::CheckSize {what size thing} {
+ if {[string length $thing] != $size} {
+ return -code error "invalid value for $what: must be $size bytes long"
+ }
+ return $thing
+}
+
+proc ::aes::Pad {data blocksize {fill \0}} {
+ set len [string length $data]
+ if {$len == 0} {
+ set data [string repeat $fill $blocksize]
+ } elseif {($len % $blocksize) != 0} {
+ set pad [expr {$blocksize - ($len % $blocksize)}]
+ append data [string repeat $fill $pad]
+ }
+ return $data
+}
+
+proc ::aes::Pop {varname {nth 0}} {
+ upvar 1 $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+proc ::aes::aes {args} {
+ array set opts {-dir encrypt -mode cbc -key {} -in {} -out {} -chunksize 4096 -hex 0}
+ set opts(-iv) [string repeat \0 16]
+ set modes {ecb cbc}
+ set dirs {encrypt decrypt}
+ while {([llength $args] > 1) && [string match -* [set option [lindex $args 0]]]} {
+ switch -exact -- $option {
+ -mode { set opts(-mode) [SetOneOf $modes [Pop args 1]] }
+ -dir { set opts(-dir) [SetOneOf $dirs [Pop args 1]] }
+ -iv { set opts(-iv) [CheckSize -iv 16 [Pop args 1]] }
+ -key { set opts(-key) [Pop args 1] }
+ -in { set opts(-in) [Pop args 1] }
+ -out { set opts(-out) [Pop args 1] }
+ -chunksize { set opts(-chunksize) [Pop args 1] }
+ -hex { set opts(-hex) 1 }
+ -- { Pop args ; break }
+ default {
+ set err [join [lsort [array names opts]] ", "]
+ return -code error "bad option \"$option\":\
+ must be one of $err"
+ }
+ }
+ Pop args
+ }
+
+ if {$opts(-key) eq {}} {
+ return -code error "no key provided: the -key option is required"
+ }
+
+ set r {}
+ if {$opts(-in) eq {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong \# args:\
+ should be \"aes ?options...? -key keydata plaintext\""
+ }
+
+ set data [Pad [lindex $args 0] 16]
+ set Key [Init $opts(-mode) $opts(-key) $opts(-iv)]
+ if {[string equal $opts(-dir) "encrypt"]} {
+ set r [Encrypt $Key $data]
+ } else {
+ set r [Decrypt $Key $data]
+ }
+
+ if {$opts(-out) ne {}} {
+ puts -nonewline $opts(-out) $r
+ set r {}
+ }
+ Final $Key
+
+ } else {
+
+ if {[llength $args] != 0} {
+ return -code error "wrong \# args:\
+ should be \"aes ?options...? -key keydata -in channel\""
+ }
+
+ set Key [Init $opts(-mode) $opts(-key) $opts(-iv)]
+
+ set readcmd [list [namespace origin Chunk] \
+ $Key $opts(-in) $opts(-out) \
+ $opts(-chunksize)]
+
+ upvar 1 $Key state
+ set state(reading) 1
+ if {[string equal $opts(-dir) "encrypt"]} {
+ set state(cmd) Encrypt
+ } else {
+ set state(cmd) Decrypt
+ }
+ set state(output) ""
+ chan event $opts(-in) readable $readcmd
+ if {[info commands ::tkwait] != {}} {
+ tkwait variable [subst $Key](reading)
+ } else {
+ vwait [subst $Key](reading)
+ }
+ if {$opts(-out) == {}} {
+ set r $state(output)
+ }
+ Final $Key
+ }
+
+ if {$opts(-hex)} {
+ binary scan $r H* r
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+package provide aes 1.2.1
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/aes/aes.test b/tcllib/modules/aes/aes.test
new file mode 100644
index 0000000..c7305ef
--- /dev/null
+++ b/tcllib/modules/aes/aes.test
@@ -0,0 +1,358 @@
+# aes.test - Copyright (c) 2005 Thorsten Schloermann
+#
+# the test-values are taken from:
+# http://csrc.nist.gov/CryptoToolkit/aes/rijndael/rijndael-vals.zip
+# where only the first 12 entries of Know Answer Test for variable key and
+# variable text are used
+# Unfortunately, only encryption is tested by this.
+#
+#
+# Monte Carlo Tests with 4 Million cycles through the algorithm will need too much time
+#
+# $Id: aes.test,v 1.8 2010/07/06 19:39:00 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+testing {
+ useLocal aes.tcl aes
+}
+
+# -------------------------------------------------------------------------
+
+# data for variable key KAT
+
+# Sample vectors from FIPS 197 specification document.
+#
+test aes-fips-C.1e {Test vector for AES-128 from FIPS-197 Appendix C.1} -setup {
+ set txt [binary format H* 00112233445566778899aabbccddeeff]
+ set key [binary format H* 000102030405060708090a0b0c0d0e0f]
+} -body {
+ set enc [aes::aes -mode ecb -dir enc -key $key $txt]
+ binary scan $enc H* r
+ set r
+} -cleanup {
+ unset txt key enc r
+} -result 69c4e0d86a7b0430d8cdb78070b4c55a
+
+test aes-fips-C.1d {Test vector for AES-128 from FIPS-197 Appendix C.1} -setup {
+ set txt [binary format H* 69c4e0d86a7b0430d8cdb78070b4c55a]
+ set key [binary format H* 000102030405060708090a0b0c0d0e0f]
+} -body {
+ set enc [aes::aes -mode ecb -dir dec -key $key $txt]
+ binary scan $enc H* r
+ set r
+} -cleanup {
+ unset txt key enc r
+} -result 00112233445566778899aabbccddeeff
+
+test aes-fips-C.2e {Test vector for AES-192 from FIPS-197 Appendix C.2} -setup {
+ set txt [binary format H* 00112233445566778899aabbccddeeff]
+ set key [binary format H* 000102030405060708090a0b0c0d0e0f1011121314151617]
+} -body {
+ set enc [aes::aes -mode ecb -dir enc -key $key $txt]
+ binary scan $enc H* r
+ set r
+} -cleanup {
+ unset txt key enc r
+} -result dda97ca4864cdfe06eaf70a0ec0d7191
+
+test aes-fips-C.2d {Test vector for AES-192 from FIPS-197 Appendix C.2} -setup {
+ set txt [binary format H* dda97ca4864cdfe06eaf70a0ec0d7191]
+ set key [binary format H* 000102030405060708090a0b0c0d0e0f1011121314151617]
+} -body {
+ set enc [aes::aes -mode ecb -dir dec -key $key $txt]
+ binary scan $enc H* r
+ set r
+} -cleanup {
+ unset txt key enc r
+} -result 00112233445566778899aabbccddeeff
+
+test aes-fips-C.3e {Test vector for AES-256 from FIPS-197 Appendix C.3} -setup {
+ set txt [binary format H* 00112233445566778899aabbccddeeff]
+ set key [binary format H* 000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f]
+} -body {
+ set enc [aes::aes -mode ecb -dir enc -key $key $txt]
+ binary scan $enc H* r
+ set r
+} -cleanup {
+ unset txt key enc r
+} -result 8ea2b7ca516745bfeafc49904b496089
+
+test aes-fips-C.3d {Test vector for AES-256 from FIPS-197 Appendix C.3} -setup {
+ set txt [binary format H* 8ea2b7ca516745bfeafc49904b496089]
+ set key [binary format H* 000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f]
+} -body {
+ set enc [aes::aes -mode ecb -dir dec -key $key $txt]
+ binary scan $enc H* r
+ set r
+} -cleanup {
+ unset txt key enc r
+} -result 00112233445566778899aabbccddeeff
+
+test aes-kat-ecb-128e {Known answer tests - AES-128 ECB encryption} -setup {
+ set txt [binary format H* 000102030405060708090a0b0c0d0e0f]
+ set key [binary format H* 000102030405060708090a0b0c0d0e0f]
+} -body {
+ set enc [aes::aes -mode ecb -dir enc -key $key $txt]
+ binary scan $enc H* r
+ set r
+} -cleanup {
+ unset txt key enc r
+} -result 0a940bb5416ef045f1c39458c653ea5a
+
+test aes-kat-ecb-128d {Known answer tests - AES-128 ECB decryption} -setup {
+ set txt [binary format H* 0a940bb5416ef045f1c39458c653ea5a]
+ set key [binary format H* 000102030405060708090a0b0c0d0e0f]
+} -body {
+ set enc [aes::aes -mode ecb -dir dec -key $key $txt]
+ binary scan $enc H* r
+ set r
+} -cleanup {
+ unset txt key enc r
+} -result 000102030405060708090a0b0c0d0e0f
+
+test aes-kat-ecb-192e {Known answer tests - AES-192 ECB encryption} -setup {
+ set txt [binary format H* 000102030405060708090a0b0c0d0e0f]
+ set key [binary format H* 000102030405060708090A0B0C0D0E0F1011121314151617]
+} -body {
+ set enc [aes::aes -mode ecb -dir enc -key $key $txt]
+ binary scan $enc H* r
+ set r
+} -cleanup {
+ unset txt key enc r
+} -result 0060bffe46834bb8da5cf9a61ff220ae
+
+test aes-kat-ecb-192d {Known answer tests - AES-192 ECB decryption} -setup {
+ set txt [binary format H* 0060bffe46834bb8da5cf9a61ff220ae]
+ set key [binary format H* 000102030405060708090A0B0C0D0E0F1011121314151617]
+} -body {
+ set enc [aes::aes -mode ecb -dir dec -key $key $txt]
+ binary scan $enc H* r
+ set r
+} -cleanup {
+ unset txt key enc r
+} -result 000102030405060708090a0b0c0d0e0f
+
+test aes-kat-ecb-256e {Known answer tests - AES-256 ECB encryption} -setup {
+ set txt [binary format H* 000102030405060708090a0b0c0d0e0f]
+ set key [binary format H* 000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F]
+} -body {
+ set enc [aes::aes -mode ecb -dir enc -key $key $txt]
+ binary scan $enc H* r
+ set r
+} -cleanup {
+ unset txt key enc r
+} -result 5a6e045708fb7196f02e553d02c3a692
+
+test aes-kat-ecb-256d {Known answer tests - AES-256 ECB decryption} -setup {
+ set txt [binary format H* 5a6e045708fb7196f02e553d02c3a692]
+ set key [binary format H* 000102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F]
+} -body {
+ set enc [aes::aes -mode ecb -dir dec -key $key $txt]
+ binary scan $enc H* r
+ set r
+} -cleanup {
+ unset txt key enc r
+} -result 000102030405060708090a0b0c0d0e0f
+
+
+# N key ic plain cipher
+set vectors {
+ 1 06a9214036b8a15b512e03d534120006 3dafba429d9eb430b422da802c9fac41
+ 53696e676c6520626c6f636b206d7367 e353779c1079aeb82708942dbe77181a
+ 2 c286696d887c9aa0611bbb3e2025a45a 562e17996d093d28ddb3ba695a2e6f58
+ 000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f
+ d296cd94c2cccf8a3a863028b5e1dc0a7586602d253cfff91b8266bea6d61ab1
+ 3 6c3ea0477630ce21a2ce334aa746c2cd c782dc4c098c66cbd9cd27d825682c81
+ 5468697320697320612034382d62797465206d657373616765202865786163746c7920332041455320626c6f636b7329
+ d0a02b3836451753d493665d33f0e8862dea54cdb293abc7506939276772f8d5021c19216bad525c8579695d83ba2684
+ 4 56e47a38c5598974bc46903dba290349 8ce82eefbea0da3c44699ed7db51b7d9
+ a0a1a2a3a4a5a6a7a8a9aaabacadaeafb0b1b2b3b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9cacbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedf
+ c30e32ffedc0774e6aff6af0869f71aa0f3af07a9a31a9c684db207eb0ef8e4e35907aa632c3ffdf868bb7b29d3d46ad83ce9f9a102ee99d49a53e87f4c3da55
+}
+
+foreach {n key iv pt ct} $vectors {
+ test aes-cbc-${n}e {RFC3602 AES-128 CBC mode encryption} -setup {
+ set K [binary format H* $key]
+ set I [binary format H* $iv]
+ } -body {
+ set aes [aes::aes -mode cbc -dir enc -key $K -iv $I [binary format H* $pt]]
+ binary scan $aes H* r
+ set r
+ } -cleanup {
+ unset r K I aes
+ } -result $ct
+
+ test aes-cbc-${n}d {RFC3602 AES-128 CBC mode decryption} -setup {
+ set K [binary format H* $key]
+ set I [binary format H* $iv]
+ } -body {
+ set aes [aes::aes -mode cbc -dir dec -key $K -iv $I [binary format H* $ct]]
+ binary scan $aes H* r
+ set r
+ } -cleanup {
+ unset r K I aes
+ } -result $pt
+}
+
+# Known answer tests (CBC)
+# 0 00000000000000000000000000000000 00000000000000000000000000000000
+# 00000000000000000000000000000000 8a05fc5e095af4848a08d328d3688e3d
+# 1 8a05fc5e095af4848a08d328d3688e3d 8a05fc5e095af4848a08d328d3688e3d
+# 204f17e2444381f6114ff53934c0bcd3 192d9b3aa10bb2f7846ccba0085c657a
+# 2 93286764a85146730e641888db34eb47 192d9b3aa10bb2f7846ccba0085c657a
+# 983bf6f5a6dfbcdaa19370666e83a99a 40d8daf6d1fda0a073b3bd18b7695d2e
+# 3 d3f0bd9279ace6d37dd7a5906c5db669 40d8daf6d1fda0a073b3bd18b7695d2e
+# c48cd503a21c8ad0b2483ef15f79571d 3edbe80d69a1d2248ca55fc17c4ef3c5
+
+# Bugs
+
+# N key ic plain cipher
+set vectors {
+ 1
+ 3132333435363738393031323334353637383930313233343536373839303132
+ c3f0929f353c2fc78b9c6705397f22c8
+ 005a0000003b00000000000000000000
+ 97d94ab5d6a6bf3e9a126b67b8b3bc12
+}
+
+foreach {n key iv pt ct} $vectors {
+ test aes-cbc-x${n}e {RFC3602 AES-128 CBC mode encryption} -setup {
+ set K [binary format H* $key]
+ set I [binary format H* $iv]
+ } -body {
+ set aes [aes::aes -mode cbc -dir enc -key $K -iv $I [binary format H* $pt]]
+ binary scan $aes H* r
+ set r
+ } -cleanup {
+ unset r K I aes
+ } -result $ct
+
+ test aes-cbc-x${n}d {RFC3602 AES-128 CBC mode decryption} -setup {
+ set K [binary format H* $key]
+ set I [binary format H* $iv]
+ } -body {
+ set aes [aes::aes -mode cbc -dir dec -key $K -iv $I [binary format H* $ct]]
+ binary scan $aes H* r
+ set r
+ } -cleanup {
+ unset r K I aes
+ } -result $pt
+}
+
+test aes-sf2993029 {aes decrypt, wide integer, sf bug 2993029} -body {
+ aes::aes -hex -mode ecb -dir decrypt \
+ -key [binary format H* FEDCBA98FEDCBA98FEDCBA98FEDCBA98] \
+ [binary format H* 2a666624a86d4c29de37b520781c1069]
+} -result 01000000000000003d5afbb584a29f57
+
+# -------------------------------------------------------------------------
+
+test aes-sf-3574004-a {aes use with data starting with a dash, auto-stop} -body {
+ aes::aes -hex -mode cbc -dir encrypt -key [string repeat \\0 16] -[string repeat \\0 15]
+} -result cc45117986e38ae95944f9eeaa7b700b240fdd169eacd2a20505ef4c6507c907
+
+test aes-sf-3574004-b {aes use with data starting with a dash, double-dash} -body {
+ aes::aes -hex -mode cbc -dir encrypt -key [string repeat \\0 16] -- -[string repeat \\0 15]
+} -result cc45117986e38ae95944f9eeaa7b700b240fdd169eacd2a20505ef4c6507c907
+
+# -------------------------------------------------------------------------
+## TODO: Go through the various possible options and combinations.
+
+test aes-sf-3612645-a0 {aes use of -in option, allura 1366} -setup {
+ set key [binary format a32 0123456789012345678901234567890123456789]
+ set encfile [tcltest::makeFile {} aes.encrypt]
+ set decfile [tcltest::makeFile {} aes.decrypt]
+ set outchan [open $encfile w]
+ fconfigure $outchan -translation binary
+ aes::aes -key $key -out $outchan "Hello World Tcl"
+ close $outchan
+ unset outchan
+} -body {
+ set inchan [open $encfile r]
+ fconfigure $inchan -translation binary
+ set outchan [open $decfile w+]
+ aes::aes -dir decrypt -key $key -in $inchan -out $outchan
+ close $inchan
+ close $outchan
+ viewFile $decfile
+} -cleanup {
+ file delete $encfile $decfile
+ unset key encfile decfile inchan outchan
+} -result "Hello World Tcl\000"
+
+test aes-sf-3612645-a1 {aes use of -in option, allura 1366} -setup {
+ set key [binary format a32 0123456789012345678901234567890123456789]
+ set encfile [tcltest::makeFile {} aes.encrypt]
+ set outchan [open $encfile w]
+ fconfigure $outchan -translation binary
+ aes::aes -key $key -out $outchan "Hello World Tcl"
+ close $outchan
+ unset outchan
+} -body {
+ set inchan [open $encfile r]
+ fconfigure $inchan -translation binary
+ set out [aes::aes -dir decrypt -key $key -in $inchan]
+ close $inchan
+ set out
+} -cleanup {
+ file delete $encfile
+ unset out key encfile inchan
+} -result "Hello World Tcl\000"
+
+test aes-sf-3612645-b0 {aes non-use of -in option, allura 1366} -setup {
+ set key [binary format a32 0123456789012345678901234567890123456789]
+ set encfile [tcltest::makeFile {} aes.encrypt]
+ set decfile [tcltest::makeFile {} aes.decrypt]
+ set outchan [open $encfile w]
+ fconfigure $outchan -translation binary
+ aes::aes -key $key -out $outchan "Hello World Tcl"
+ close $outchan
+ unset outchan
+} -body {
+ set inchan [open $encfile r]
+ fconfigure $inchan -translation binary
+ set outchan [open $decfile w+]
+ aes::aes -dir decrypt -key $key -out $outchan [read $inchan]
+ close $inchan
+ close $outchan
+ viewFile $decfile
+} -cleanup {
+ file delete $encfile $decfile
+ unset key encfile decfile inchan outchan
+} -result "Hello World Tcl\000"
+
+test aes-sf-3612645-b1 {aes non-use of -in option, allura 1366} -setup {
+ set key [binary format a32 0123456789012345678901234567890123456789]
+ set encfile [tcltest::makeFile {} aes.encrypt]
+ set outchan [open $encfile w]
+ fconfigure $outchan -translation binary
+ aes::aes -key $key -out $outchan "Hello World Tcl"
+ close $outchan
+ unset outchan
+} -body {
+ set inchan [open $encfile r]
+ fconfigure $inchan -translation binary
+ set out [aes::aes -dir decrypt -key $key [read $inchan]]
+ close $inchan
+ set out
+} -cleanup {
+ file delete $encfile
+ unset out key encfile inchan
+} -result "Hello World Tcl\000"
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/aes/pkgIndex.tcl b/tcllib/modules/aes/pkgIndex.tcl
new file mode 100644
index 0000000..83cc80f
--- /dev/null
+++ b/tcllib/modules/aes/pkgIndex.tcl
@@ -0,0 +1,5 @@
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ # PRAGMA: returnok
+ return
+}
+package ifneeded aes 1.2.1 [list source [file join $dir aes.tcl]]
diff --git a/tcllib/modules/amazon-s3/ChangeLog b/tcllib/modules/amazon-s3/ChangeLog
new file mode 100644
index 0000000..643246e
--- /dev/null
+++ b/tcllib/modules/amazon-s3/ChangeLog
@@ -0,0 +1,64 @@
+2013-12-17 Andreas Kupries <andreask@activestate.com>
+
+ * xsxp.man: Fixed missing requirement on the package itself.
+ * S3.man: Ditto.
+
+2013-02-08 Andreas Kupries <andreask@activestate.com>
+
+ * xsxp.man: Fixed moddesc/titledesc confusion.
+ * S3.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-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 ========================
+ *
+
+2008-09-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * S3.test: Added guards to protect testsuite against a
+ * xsxp.test: missing xml package.
+
+2008-07-08 Andreas Kupries <andreask@activestate.com>
+
+ * xsxp.man: Added boilerplate section to the documentation
+ * S3.man: directing bug reports and other feedback to the Tcllib
+ SF trackers.
+
+ * xsxp.test: Added the boilerplate necessary for integration
+ * S3.test: with tcllib's test framework.
+
+ * New module 'amazon-s3', with packages S3 and xsxp, by Darren
+ New. Physical integration of all the new files.
+ Todo: Integration with the installer, and fixes for the
+ testsuites to use Tcllib's boilerplate.
diff --git a/tcllib/modules/amazon-s3/LICENSE.txt b/tcllib/modules/amazon-s3/LICENSE.txt
new file mode 100644
index 0000000..9f43682
--- /dev/null
+++ b/tcllib/modules/amazon-s3/LICENSE.txt
@@ -0,0 +1,52 @@
+This software is copyrighted by Darren New.
+The following terms apply to all files associated with the software unless
+explicitly disclaimed in individual files.
+
+The authors hereby grant permission to use, copy, modify, distribute,
+and license this software and its documentation for any purpose, provided
+that existing copyright notices are retained in all copies and that this
+notice is included verbatim in any distributions. No written agreement,
+license, or royalty fee is required for any of the authorized uses.
+Modifications to this software may be copyrighted by their authors
+and need not follow the licensing terms described here, provided that
+the new terms are clearly indicated on the first page of each file where
+they apply.
+
+IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+MODIFICATIONS.
+
+GOVERNMENT USE: If you are acquiring this software on behalf of the
+U.S. government, the Government shall have only "Restricted Rights"
+in the software and related documentation as defined in the Federal
+Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
+are acquiring the software on behalf of the Department of Defense, the
+software shall be classified as "Commercial Computer Software" and the
+Government shall have only "Restricted Rights" as defined in Clause
+252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
+authors grant the U.S. Government and others acting in its behalf
+permission to use and distribute the software in accordance with the
+terms specified in this license.
+
+*** *** That said ... ** ***
+
+The author would appreciate feedback, bug fixes,
+and improvements in functionality. The author would
+also appreciate acknowlegement if you acknowledge
+contributors in your distribution of work. Neither
+of these are requirements for using or distributing
+the code, modifications thereof, or programs making
+use of it.
+
+The author can be reached for the forseeable future
+at dnew@san.rr.com or my SourceForge account.
+
diff --git a/tcllib/modules/amazon-s3/README.txt b/tcllib/modules/amazon-s3/README.txt
new file mode 100644
index 0000000..3aa79a8
--- /dev/null
+++ b/tcllib/modules/amazon-s3/README.txt
@@ -0,0 +1,56 @@
+This is Darren New's package to interface to amazon's S3 web service.
+This is in beta stage, but potentially useful to others already.
+
+Note that test-S3.config should have your own account identifiers
+entered, in order to run the tcltest.
+
+I'm hoping this eventually makes it into TclLib. To that end, I have
+tried to avoid using any packages that aren't widely available on
+all platforms, sticking with tcllib and ActiveState stuff as much
+as possible.
+
+Note that "xsxp.tcl" and associated packaging is necessary for this
+system. Plus, there are a few places where I used [dict] and {expand}.
+To make this work with 8.5 release, {expand} needs to be changed to {*}.
+To make this work with 8.4, you need a Tcl implementation of [dict]
+and you need to change {expand} into [eval] and [list] as appropriate.
+If you make either of these changes, please bop me back a copy of
+the changes <dnew@san.rr.com> and I'll make a new package.
+
+Manifest:
+
+README.txt - this file.
+LICENSE.txt - the license for use and redistribution. It's BSD.
+S3.man - the beginnings of a Tcl-format man page for S3.
+S3.test - The tcltest calls to the S3 package.
+ (Note that S3::REST has actually been extensively tested by
+ yours truely, but the tests were manual "call the routine,
+ print the results", and I haven't taken time to repackage them
+ in Tcltest format. But I will.
+test-S3.config - a call to S3::Configure to set your personal
+ access identifiers so you can run S3.test.
+S3.tsh - The actual source code for the S3 interface package.
+xsxp.tcl - Extremely Simple XML Parser. It uses the TclXML package
+ to build nested dictionaries, and supplies simple ways of
+ getting to the data. I use it to parse the results from
+ S3's bucket listings and such, because I couldn't get TclDOM
+ to install on my machine.
+xsxp.test - The tcltests for xsxp.
+pkgIndex.tcl - For S3 and xsxp.
+
+A few notes:
+
+I expect to break this into several "layers". S3::REST doesn't
+require any XML parsing. The routines dealing with buckets and
+listings parse the XML to return the information in a useful form.
+
+The bucket deletion test code is disabled because Amazon has
+been having trouble with bucket creation/deletion leaving
+things in an inconsistant state.
+
+FEEDBACK WELCOME! -- Please include me in email for any
+comments or bug reports about the software. Thanks!
+(I usually don't want to be cc'ed on newsgroup posts, but
+this is an exception.)
+
+THANKS!
diff --git a/tcllib/modules/amazon-s3/S3.man b/tcllib/modules/amazon-s3/S3.man
new file mode 100644
index 0000000..809116a
--- /dev/null
+++ b/tcllib/modules/amazon-s3/S3.man
@@ -0,0 +1,1450 @@
+[vset VERSION 1.0.3]
+[manpage_begin S3 n [vset VERSION]]
+[keywords amazon]
+[keywords cloud]
+[keywords s3]
+[moddesc {Amazon S3 Web Service Utilities}]
+[titledesc {Amazon S3 Web Service Interface}]
+[category Networking]
+[copyright {Copyright 2006,2008 Darren New. All Rights Reserved. See LICENSE.TXT for terms.}]
+[require Tcl 8.5]
+[require S3 [opt [vset VERSION]]]
+[require sha1 1.0]
+[require md5 2.0]
+[require base64 2.3]
+[require xsxp 1.0]
+[description]
+This package provides access to Amazon's Simple Storage Solution web service.
+
+[para]
+As a quick summary, Amazon Simple Storage Solution
+provides a for-fee web service allowing the storage of arbitrary data as
+"resources" within "buckets" online.
+See [uri http://www.amazonaws.com/] for details on that system.
+Access to the service is via HTTP (SOAP or REST). Much of this
+documentation will not make sense if you're not familiar with
+the terms and functionality of the Amazon S3 service.
+
+[para]
+This package provides services for reading and writing
+the data items via the REST interface. It also provides some
+higher-level operations. Other packages in the same distribution
+provide for even more functionality.
+
+[para]
+Copyright 2006 Darren New. All Rights Reserved.
+NO WARRANTIES OF ANY TYPE ARE PROVIDED.
+COPYING OR USE INDEMNIFIES THE AUTHOR IN ALL WAYS.
+This software is licensed under essentially the same
+terms as Tcl. See LICENSE.txt for the terms.
+
+[section "ERROR REPORTING"]
+
+The error reporting from this package makes use of $errorCode to
+provide more details on what happened than simply throwing an error.
+Any error caught by the S3 package (and we try to catch them all)
+will return with an $errorCode being a list having at least three
+elements. In all cases, the first element will be "S3". The second
+element will take on one of six values, with that element defining
+the value of the third and subsequent elements. S3::REST does not
+throw an error, but rather returns a dictionary with the keys "error",
+"errorInfo", and "errorCode" set. This allows for reliable background
+use. The possible second elements are these:
+
+[list_begin definitions]
+[def usage] The usage of the package is incorrect. For example,
+a command has been invoked which requires the library to be configured
+before the library has been configured, or an invalid combination of
+options has been specified. The third element of $errorCode supplies
+the name of the parameter that was wrong. The fourth usually provides
+the arguments that were actually supplied to the throwing proc, unless
+the usage error isn't confined to a single proc.
+
+[def local] Something happened on the local system which threw
+an error. For example, a request to upload or download a file was made
+and the file permissions denied that sort of access. The third element
+of $errorCode is the original $errorCode.
+
+[def socket] Something happened with the socket. It closed
+prematurely, or some other condition of failure-to-communicate-with-Amazon
+was detected. The third element of $errorCode is the original $errorCode,
+or sometimes the message from fcopy, or ...?
+
+[def remote] The Amazon web service returned an error code outside
+the 2xx range in the HTTP header. In other words, everything went as
+documented, except this particular case was documented not to work.
+The third element is the dictionary returned from [cmd ::S3::REST].
+Note that S3::REST itself never throws this error, but just returns
+the dictionary. Most of the higher-level commands throw for convenience,
+unless an argument indicates they should not. If something is documented
+as "not throwing an S3 remote error", it means a status return is set
+rather than throwing an error if Amazon returns a non-2XX HTTP result code.
+
+[def notyet] The user obeyed the documentation, but the author
+has not yet gotten around to implementing this feature. (Right now,
+only TLS support and sophisticated permissions fall into this category,
+as well as the S3::Acl command.)
+
+[def xml] The service has returned invalid XML, or XML whose
+schema is unexpected. For the high-level commands that accept
+service XML as input for parsing, this may also be thrown.
+
+[list_end]
+
+[section COMMANDS]
+This package provides several separate levels of complexity.
+
+[list_begin itemized]
+[item]
+The lowest level simply takes arguments to be sent to the service,
+sends them, retrieves the result, and provides it to the caller.
+[emph Note:] This layer allows both synchronous and event-driven
+processing. It depends on the MD5 and SHA1 and base64 packages
+from Tcllib (available at [uri http://core.tcl.tk/tcllib/]).
+Note that [cmd S3::Configure] is required for [cmd S3::REST] to
+work due to the authentication portion, so we put that in the "lowest level."
+
+[item]
+The next layer parses the results of calls, allowing for functionality
+such as uploading only changed files, synchronizing directories,
+and so on. This layer depends on the [package TclXML] package as well as the
+included [package xsxp] package. These packages are package required when
+these more-sophisticated routines are called, so nothing breaks if
+they are not correctly installed.
+
+[item]
+Also included is a separate program that uses the library.
+It provides code to parse $argv0 and $argv from the
+command line, allowing invocation as a tclkit, etc.
+(Not yet implmented.)
+
+[item]
+Another separate program provides a GUI interface allowing drag-and-drop
+and other such functionality. (Not yet implemented.)
+
+[item]
+Also built on this package is the OddJob program. It is
+a separate program designed to allow distribution of
+computational work units over Amazon's Elastic Compute
+Cloud web service.
+
+[list_end]
+
+[para]
+The goal is to have at least the bottom-most layers implemented in
+pure Tcl using only that which comes from widely-available sources,
+such as Tcllib.
+
+[section "LOW LEVEL COMMANDS"]
+These commands do not require any packages not listed above.
+They talk directly to the service, or they are utility or
+configuration routines. Note that the "xsxp" package was
+written to support this package, so it should be available
+wherever you got this package.
+
+[list_begin definitions]
+
+[call [cmd S3::Configure] \
+[opt "[option -reset] [arg boolean]"] \
+[opt "[option -retries] [arg integer]"] \
+[opt "[option -accesskeyid] [arg idstring]"] \
+[opt "[option -secretaccesskey] [arg idstring]"] \
+[opt "[option -service-access-point] [arg FQDN]"] \
+[opt "[option -use-tls] [arg boolean]"] \
+[opt "[option -default-compare] [arg always|never|exists|missing|newer|date|checksum|different]"] \
+[opt "[option -default-separator] [arg string]"] \
+[opt "[option -default-acl] [arg private|public-read|public-read-write|authenticated-read|keep|calc]"] \
+[opt "[option -default-bucket] [arg bucketname]"] \
+]
+
+There is one command for configuration, and that is [cmd S3::Configure].
+If called with no arguments, it returns a
+dictionary of key/value pairs listing all current settings. If called
+with one argument, it returns the value of that single argument. If
+called with two or more arguments, it must be called with pairs of
+arguments, and it applies the changes in order. There is only one set
+of configuration information per interpreter.
+[para]
+The following options are accepted:
+
+[list_begin definitions]
+
+[def "[option -reset] [arg boolean]"]
+By default, false. If true, any previous changes and any changes on the
+same call before the reset option will be returned to default values.
+
+[def "[option -retries] [arg integer]"]
+Default value is 3.
+If Amazon returns a 500 error, a retry after an exponential
+backoff delay will be tried this many times before finally
+throwing the 500 error. This applies to each call to [cmd S3::REST]
+from the higher-level commands, but not to [cmd S3::REST] itself.
+That is, [cmd S3::REST] will always return httpstatus 500 if that's
+what it receives. Functions like [cmd S3::Put] will retry the PUT call,
+and will also retry the GET and HEAD calls used to do content comparison.
+Changing this to 0 will prevent retries and their associated delays.
+In addition, socket errors (i.e., errors whose errorCode starts with
+"S3 socket") will be similarly retried after backoffs.
+
+[def "[option -accesskeyid] [arg idstring]"]
+[def "[option -secretaccesskey] [arg idstring]"]
+Each defaults to an empty string.
+These must be set before any calls are made. This is your S3 ID.
+Once you sign up for an account, go to [uri http://www.amazonaws.com/],
+sign in, go to the "Your Web Services Account" button, pick "AWS
+Access Identifiers", and your access key ID and secret access keys
+will be available. All [cmd S3::REST] calls are authenticated.
+Blame Amazon for the poor choice of names.
+
+[def "[option -service-access-point] [arg FQDN]"]
+Defaults to "s3.amazonaws.com". This is the fully-qualified domain
+name of the server to contact for [cmd S3::REST] calls. You should
+probably never need to touch this, unless someone else implements
+a compatible service, or you wish to test something by pointing
+the library at your own service.
+
+[def "[option -slop-seconds] [arg integer]"]
+When comparing dates between Amazon and the local machine,
+two dates within this many seconds of each other are considered
+the same. Useful for clock drift correction, processing overhead
+time, and so on.
+
+[def "[option -use-tls] [arg boolean]"]
+Defaults to false. This is not yet implemented. If true, [cmd S3::REST] will
+negotiate a TLS connection to Amazon. If false, unencrypted connections
+are used.
+
+[def "[option -bucket-prefix] [arg string]"]
+Defaults to "TclS3". This string is used by [cmd S3::SuggestBucketName]
+if that command is passed an empty string as an argument. It is used
+to distinguish different applications using the Amazon service.
+Your application should always set this to keep from interfering with
+the buckets of other users of Amazon S3 or with other buckets of the
+same user.
+
+[def "[option -default-compare] [arg always|never|exists|missing|newer|date|checksum|different]"]
+Defaults to "always." If no -compare is specified on
+[cmd S3::Put], [cmd S3::Get], or [cmd S3::Delete], this comparison is used.
+See those commands for a description of the meaning.
+
+[def "[option -default-separator] [arg string]"]
+Defaults to "/". This is currently unused. It might make sense to use
+this for [cmd S3::Push] and [cmd S3::Pull], but allowing resources to
+have slashes in their names that aren't marking directories would be
+problematic. Hence, this currently does nothing.
+
+[def "[option -default-acl] [arg private|public-read|public-read-write|authenticated-read|keep|calc]"]
+Defaults to an empty string. If no -acl argument is provided to [cmd S3::Put] or
+[cmd S3::Push], this string is used
+(given as the x-amz-acl header if not keep or calc). If this is also
+empty, no x-amz-acl header is generated.
+This is [emph not] used by [cmd S3::REST].
+
+[def "[option -default-bucket] [arg bucketname]"]
+If no bucket is given to [cmd S3::GetBucket], [cmd S3::PutBucket],
+[cmd S3::Get], [cmd S3::Put],
+[cmd S3::Head], [cmd S3::Acl],
+[cmd S3::Delete], [cmd S3::Push],
+[cmd S3::Pull], or [cmd S3::Toss], and if this configuration variable
+is not an empty string (and not simply "/"), then this value
+will be used for the bucket. This is useful if one program does
+a large amount of resource manipulation within a single bucket.
+
+[list_end]
+
+[para]
+
+[call [cmd S3::SuggestBucket] [opt [arg name]]]
+The [cmd S3::SuggestBucket] command accepts an optional string as
+a prefix and returns a valid bucket containing the [arg name] argument
+and the Access Key ID. This makes the name unique to the owner and
+to the application (assuming the application picks a good [arg name] argument).
+If no name is provided,
+the name from [cmd S3::Configure] [arg -bucket-prefix] is used.
+If that too is empty (which is not the default), an error is thrown.
+
+[call [cmd S3::REST] [arg dict]]
+
+The [cmd S3::REST] command takes as an argument a dictionary and
+returns a dictionary. The return dictionary has the same keys
+as the input dictionary, and includes additional keys as the result.
+The presence or absence of keys in the input dictionary can control
+the behavior of the routine. It never throws an error directly, but
+includes keys "error", "errorInfo", and "errorCode" if necessary.
+Some keys are required, some optional. The routine can run either
+in blocking or non-blocking mode, based on the presense
+of [option resultvar] in the input dictionary. This requires
+the [arg -accesskeyid] and [arg -secretaccesskey] to be configured via
+[cmd S3::Configure] before being called.
+[para]
+The possible input keys are these:
+[list_begin definitions]
+
+[def "[option verb] [arg GET|PUT|DELETE|HEAD]"]
+This required item indicates the verb to be used.
+
+[def "[option resource] [arg string]"]
+This required item indicates the resource to be accessed.
+A leading / is added if not there already. It will
+be URL-encoded for you if necessary. Do not supply a
+resource name that is already URL-encoded.
+
+[def [opt "[option rtype] [arg torrent|acl]"]]
+This indicates a torrent or acl resource is being manipulated.
+Do not include this in the [option resource] key, or the
+"?" separator will get URL-encoded.
+
+[def [opt "[option parameters] [arg dict]"]]
+This optional dictionary provides parameters added to the URL
+for the transaction. The keys must be in the correct case
+(which is confusing in the Amazon documentation) and the
+values must be valid. This can be an empty dictionary or
+omitted entirely if no parameters are desired. No other
+error checking on parameters is performed.
+
+[def [opt "[option headers] [arg dict]"]]
+This optional dictionary provides headers to be added
+to the HTTP request. The keys must be in [emph "lower case"]
+for the authentication to work. The values must not contain
+embedded newlines or carriage returns. This is primarily
+useful for adding x-amz-* headers. Since authentication
+is calculated by [cmd S3::REST], do not add that header here.
+Since content-type gets its own key, also do not add
+that header here.
+
+[def [opt "[option inbody] [arg contentstring]"]]
+This optional item, if provided, gives the content that will
+be sent. It is sent with a tranfer encoding of binary, and
+only the low bytes are used, so use [lb]encoding convertto utf-8[rb]
+if the string is a utf-8 string. This is written all in one blast,
+so if you are using non-blocking mode and the [option inbody] is
+especially large, you may wind up blocking on the write socket.
+
+[def [opt "[option infile] [arg filename]"]]
+This optional item, if provided, and if [option inbody] is not provided,
+names the file from which the body of the HTTP message will be
+constructed. The file is opened for reading and sent progressively
+by [lb]fcopy[rb], so it should not block in non-blocking mode
+even if the file is very large. The file is transfered in
+binary mode, so the bytes on your disk will match the bytes
+in your resource. Due to HTTP restrictions, it must be possible to
+use [lb]file size[rb] on this file to determine the size at the
+start of the transaction.
+
+[def [opt "[option S3chan] [arg channel]"]]
+This optional item, if provided, indicates the already-open socket
+over which the transaction should be conducted. If not provided,
+a connection is made to the service access point specified via
+[cmd S3::Configure], which is normally s3.amazonaws.com. If this
+is provided, the channel is not closed at the end of the transaction.
+
+[def [opt "[option outchan] [arg channel]"]]
+This optional item, if provided, indicates the already-open channel
+to which the body returned from S3 should be written. That is,
+to retrieve a large resource, open a file, set the translation mode,
+and pass the channel as the value of the key outchan. Output
+will be written to the channel in pieces so memory does not fill
+up unnecessarily. The channel is not closed at the end of the transaction.
+
+[def [opt "[option resultvar] [arg varname]"]]
+This optional item, if provided, indicates that [cmd S3::REST] should
+run in non-blocking mode. The [arg varname] should be fully qualified
+with respect to namespaces and cannot be local to a proc. If provided,
+the result of the [cmd S3::REST] call is assigned to this variable once
+everything has completed; use trace or vwait to know when this has happened.
+If this key is not provided, the result is simply returned from the
+call to [cmd S3::REST] and no calls to the eventloop are invoked from
+within this call.
+
+[def [opt "[option throwsocket] [arg throw|return]"]]
+This optional item, if provided, indicates that [cmd S3::REST] should
+throw an error if throwmode is throw and a socket error is encountered.
+It indicates that [cmd S3::REST] should return the error code in the
+returned dictionary if a socket error is encountered and this is
+set to return. If [option throwsocket] is set to [arg return] or
+if the call is not blocking, then a socket error (i.e., an error
+whose error code starts with "S3 socket" will be returned in the
+dictionary as [option error], [option errorInfo], and [option errorCode].
+If a foreground call is made (i.e., [option resultvar] is not provided),
+and this option is not provided or is set to [arg throw], then
+[cmd error] will be invoked instead.
+
+[list_end]
+
+[para]
+Once the call to [cmd S3::REST] completes, a new dict is returned,
+either in the [arg resultvar] or as the result of execution. This dict is
+a copy of the original dict with the results added as new keys. The possible
+new keys are these:
+[list_begin definitions]
+
+[def "[option error] [arg errorstring]"]
+[def "[option errorInfo] [arg errorstring]"]
+[def "[option errorCode] [arg errorstring]"]
+If an error is caught, these three keys will be set in the result.
+Note that [cmd S3::REST] does [emph not] consider a non-2XX HTTP
+return code as an error. The [option errorCode] value will be
+formatted according to the [sectref "ERROR REPORTING"] description.
+If these are present, other keys described here might not be.
+
+[def "[option httpstatus] [arg threedigits]"]
+The three-digit code from the HTTP transaction. 2XX for good,
+5XX for server error, etc.
+
+[def "[option httpmessage] [arg text]"]
+The textual result after the status code. "OK" or "Forbidden"
+or etc.
+
+[def "[option outbody] [arg contentstring]"]
+If [arg outchan] was not specified, this key will hold a
+reference to the (unencoded) contents of the body returned.
+If Amazon returned an error (a la the httpstatus not a 2XX value),
+the error message will be in [option outbody] or written to
+[option outchan] as appropriate.
+
+[def "[option outheaders] [arg dict]"]
+This contains a dictionary of headers returned by Amazon.
+The keys are always lower case. It's mainly useful for
+finding the x-amz-meta-* headers, if any, although things
+like last-modified and content-type are also useful.
+The keys of this dictionary are always lower case.
+Both keys and values are trimmed of extraneous whitespace.
+
+[list_end]
+[list_end]
+
+[section "HIGH LEVEL COMMANDS"]
+The routines in this section all make use of one or more calls
+to [cmd S3::REST] to do their work, then parse and manage the data
+in a convenient way. All these commands throw errors
+as described in [sectref "ERROR REPORTING"] unless otherwise noted.
+[para]
+In all these commands, all arguments are presented as name/value pairs,
+in any order. All the argument names start with a hyphen.
+[para]
+There are a few options that are common to many
+of the commands, and those common options are documented here.
+[list_begin definitions]
+[def "[option -blocking] [arg boolean]"]
+If provided and specified as false,
+then any calls to [cmd S3:REST] will be non-blocking,
+and internally these routines will call [lb]vwait[rb] to get
+the results. In other words, these routines will return the
+same value, but they'll have event loops running while waiting
+for Amazon.
+
+[def "[option -parse-xml] [arg xmlstring]"]
+If provided, the routine skips actually communicating with
+Amazon, and instead behaves as if the XML string provided
+was returned as the body of the call. Since several of
+these routines allow the return of data in various formats,
+this argument can be used to parse existing XML to extract
+the bits of information that are needed. It's also helpful
+for testing.
+
+[def "[option -bucket] [arg bucketname]"]
+Almost every high-level command needs to know what bucket
+the resources are in. This option specifies that. (Only the
+command to list available buckets does not require this parameter.)
+This does not need to be URL-encoded, even if it contains
+special or non-ASCII characters. May or may not contain leading
+or trailing spaces - commands normalize the bucket. If this is
+not supplied, the value is taken from [cmd "S3::Configure -default-bucket"]
+if that string isn't empty. Note that spaces and slashes are
+always trimmed from both ends and the rest must leave a valid bucket.
+
+[def "[option -resource] [arg resourcename]"]
+This specifies the resource of interest within the bucket.
+It may or may not start with a slash - both cases are handled.
+This does not need to be URL-encoded, even if it contains
+special or non-ASCII characters.
+
+[def "[option -compare] [arg always|never|exists|missing|newer|date|checksum|different]"]
+When commands copy resources to files or files to resources, the caller may specify that the copy should be skipped if the contents are the same. This argument specifies the conditions under which the files should be copied. If it is not passed, the result of [cmd "S3::Configure -default-compare"] is used, which in turn defaults to "always." The meanings of the various values are these:
+
+[list_begin definitions]
+[def [arg always]]
+Always copy the data. This is the default.
+
+[def [arg never]]
+Never copy the data. This is essentially a no-op, except in [cmd S3::Push] and [cmd S3::Pull] where the -delete flag might make a difference.
+
+[def [arg exists]]
+Copy the data only if the destination already exists.
+
+[def [arg missing]]
+Copy the data only if the destination does not already exist.
+
+[def [arg newer]]
+Copy the data if the destination is missing, or if the date on the source is
+newer than the date on the destination by at
+least [cmd "S3::Configure -slop-seconds"] seconds. If the source is
+Amazon, the date is taken from the Last-Modified header. If the
+source is local, it is taken as the mtime of the file. If the source data
+is specified in a string rather than a file, it is taken as right now,
+via [lb]clock seconds[rb].
+
+[def [arg date]]
+Like [arg newer], except copy if the date is newer [emph or] older.
+
+[def [arg checksum]]
+Calculate the MD5 checksum on the local file or string, ask Amazon for the eTag
+of the resource, and copy the data if they're different. Copy the data
+also if the destination is missing. Note that this can be slow with
+large local files unless the C version of the MD5 support is available.
+
+[def [arg different]]
+Copy the data if the destination does not exist.
+If the destination exists and an actual file name was specified
+(rather than a content string),
+and the date on the file differs from the date on the resource,
+copy the data.
+If the data is provided as a content string, the "date" is treated
+as "right now", so it will likely always differ unless slop-seconds is large.
+If the dates are the same, the MD5 checksums are compared, and the
+data is copied if the checksums differ.
+[list_end]
+
+[para]
+Note that "newer" and "date" don't care about the contents, and "checksum" doesn't care about the dates, but "different" checks both.
+
+[call [cmd S3::ListAllMyBuckets] \
+[opt "[option -blocking] [arg boolean]"] \
+[opt "[option -parse-xml] [arg xmlstring]"] \
+[opt "[option -result-type] [arg REST|xml|pxml|dict|names|owner]"] \
+]
+This routine performs a GET on the Amazon S3 service, which is
+defined to return a list of buckets owned by the account identified
+by the authorization header. (Blame Amazon for the dumb names.)
+
+[list_begin definitions]
+[def "[option -blocking] [arg boolean]"]
+See above for standard definition.
+
+[def "[option -parse-xml] [arg xmlstring]"]
+See above for standard definition.
+
+[def "[option -result-type] [arg REST]"]
+The dictionary returned by [cmd S3::REST] is the return value of [cmd S3::ListAllMyBuckets]. In this case, a non-2XX httpstatus will not throw an error. You may not combine this with [arg -parse-xml].
+
+[def "[option -result-type] [arg xml]"]
+The raw XML of the body is returned as the result (with no encoding applied).
+
+[def "[option -result-type] [arg pxml]"]
+The XML of the body as parsed by [cmd xsxp::parse] is returned.
+
+[def "[option -result-type] [arg dict]"]
+A dictionary of interesting portions of the XML is returned. The dictionary contains the following keys:
+
+[list_begin definitions]
+[def Owner/ID] The Amazon AWS ID (in hex) of the owner of the bucket.
+[def Owner/DisplayName] The Amazon AWS ID's Display Name.
+[def Bucket/Name] A list of names, one for each bucket.
+[def Bucket/CreationDate] A list of dates, one for each bucket,
+in the same order as Bucket/Name, in ISO format (as returned by Amazon).
+[list_end]
+
+[para]
+
+[def "[option -result-type] [arg names]"]
+A list of bucket names is returned with all other information stripped out.
+This is the default result type for this command.
+
+[def "[option -result-type] [arg owner]"]
+A list containing two elements is returned. The first element is
+the owner's ID, and the second is the owner's display name.
+
+[list_end]
+
+[para]
+
+[call [cmd S3::PutBucket] \
+[opt "[option -bucket] [arg bucketname]"] \
+[opt "[option -blocking] [arg boolean]"] \
+[opt "[option -acl] [arg {{}|private|public-read|public-read-write|authenticated-read}]"] \
+]
+This command creates a bucket if it does not already exist. Bucket names are
+globally unique, so you may get a "Forbidden" error from Amazon even if you
+cannot see the bucket in [cmd S3::ListAllMyBuckets]. See [cmd S3::SuggestBucket] for ways to minimize this risk. The x-amz-acl header comes from the [option -acl] option, or from [cmd "S3::Configure -default-acl"] if not specified.
+
+[call [cmd S3::DeleteBucket] \
+[opt "[option -bucket] [arg bucketname]"] \
+[opt "[option -blocking] [arg boolean]"] \
+]
+This command deletes a bucket if it is empty and you have such permission.
+Note that Amazon's list of buckets is a global resource, requiring
+far-flung synchronization. If you delete a bucket, it may be quite
+a few minutes (or hours) before you can recreate it, yielding "Conflict"
+errors until then.
+
+[call [cmd S3::GetBucket] \
+[opt "[option -bucket] [arg bucketname]"] \
+[opt "[option -blocking] [arg boolean]"] \
+[opt "[option -parse-xml] [arg xmlstring]"] \
+[opt "[option -max-count] [arg integer]"] \
+[opt "[option -prefix] [arg prefixstring]" ] \
+[opt "[option -delimiter] [arg delimiterstring]" ] \
+[opt "[option -result-type] [arg REST|xml|pxml|names|dict]"] \
+]
+This lists the contents of a bucket. That is, it returns a directory
+listing of resources within a bucket, rather than transfering any
+user data.
+[list_begin definitions]
+
+[def "[option -bucket] [arg bucketname]"] The standard bucket argument.
+
+[def "[option -blocking] [arg boolean]"] The standard blocking argument.
+
+[def "[option -parse-xml] [arg xmlstring]"] The standard parse-xml argument.
+
+[def "[option -max-count] [arg integer]"]
+If supplied, this is the most number of records to be returned.
+If not supplied, the code will iterate until all records have been found.
+Not compatible with -parse-xml. Note that if this is supplied, only
+one call to [cmd S3::REST] will be made. Otherwise, enough calls
+will be made to exhaust the listing, buffering results in memory,
+so take care if you may have huge buckets.
+
+[def "[option -prefix] [arg prefixstring]"]
+If present, restricts listing to resources with a particular prefix. One
+leading / is stripped if present.
+
+[def "[option -delimiter] [arg delimiterstring]"]
+If present, specifies a delimiter for the listing.
+The presence of this will summarize multiple resources
+into one entry, as if S3 supported directories. See the
+Amazon documentation for details.
+
+[def "[option -result-type] [arg REST|xml|pxml|names|dict]"]
+This indicates the format of the return result of the command.
+
+[list_begin definitions]
+[def REST]
+If [arg -max-count] is specified, the dictionary returned
+from [cmd S3::REST] is returned. If [arg -max-count] is
+not specified, a list of all the dictionaries returned from
+the one or more calls to [cmd S3::REST] is returned.
+
+[def xml]
+If [arg -max-count] is specified, the body returned
+from [cmd S3::REST] is returned. If [arg -max-count] is
+not specified, a list of all the bodies returned from
+the one or more calls to [cmd S3::REST] is returned.
+
+[def pxml]
+If [arg -max-count] is specified, the body returned
+from [cmd S3::REST] is passed throught [cmd xsxp::parse] and then returned.
+If [arg -max-count] is
+not specified, a list of all the bodies returned from
+the one or more calls to [cmd S3::REST] are each passed through
+[cmd xsxp::parse] and then returned.
+
+[def names]
+Returns a list of all names found in either the Contents/Key fields or
+the CommonPrefixes/Prefix fields. If no [arg -delimiter] is specified
+and no [arg -max-count] is specified, this returns a list of all
+resources with the specified [arg -prefix].
+
+[def dict]
+Returns a dictionary. (Returns only one dictionary even if [arg -max-count]
+wasn't specified.) The keys of the dictionary are as follows:
+
+[list_begin definitions]
+[def Name] The name of the bucket (from the final call to [cmd S3::REST]).
+
+[def Prefix] From the final call to [cmd S3::REST].
+[def Marker] From the final call to [cmd S3::REST].
+[def MaxKeys] From the final call to [cmd S3::REST].
+[def IsTruncated] From the final call to [cmd S3::REST], so
+always false if [arg -max-count] is not specified.
+[def NextMarker] Always provided if IsTruncated is true, and
+calculated of Amazon does not provide it. May be empty if IsTruncated is false.
+
+[def Key] A list of names of resources in the bucket matching the [arg -prefix] and [arg -delimiter] restrictions.
+
+[def LastModified] A list of times of resources in the bucket, in the same
+order as Key, in the format returned by Amazon. (I.e., it is not parsed into
+a seconds-from-epoch.)
+
+[def ETag] A list of entity tags (a.k.a. MD5 checksums) in the same order as Key.
+
+[def Size] A list of sizes in bytes of the resources, in the same order as Key.
+
+[def Owner/ID] A list of owners of the resources in the bucket, in the same order as Key.
+
+[def Owner/DisplayName] A list of owners of the resources in the bucket, in the same order as Key. These are the display names.
+
+[def CommonPrefixes/Prefix] A list of prefixes common to multiple entities. This is present only if [arg -delimiter] was supplied.
+
+[list_end]
+
+[list_end]
+
+[list_end]
+
+[call [cmd S3::Put] \
+[opt "[option -bucket] [arg bucketname]"] \
+[option -resource] [arg resourcename] \
+[opt "[option -blocking] [arg boolean]"] \
+[opt "[option -file] [arg filename]"] \
+[opt "[option -content] [arg contentstring]"] \
+[opt "[option -acl] [arg private|public-read|public-read-write|authenticated-read|calc|keep]"] \
+[opt "[option -content-type] [arg contenttypestring]"] \
+[opt "[option -x-amz-meta-*] [arg metadatatext]"] \
+[opt "[option -compare] [arg comparemode]"] \
+]
+
+This command sends data to a resource on Amazon's servers for storage,
+using the HTTP PUT command. It returns 0 if the [option -compare] mode
+prevented the transfer, 1 if the transfer worked, or throws an error
+if the transfer was attempted but failed.
+Server 5XX errors and S3 socket errors are retried
+according to [cmd "S3:Configure -retries"] settings before throwing an error;
+other errors throw immediately.
+
+[list_begin definitions]
+[def [option -bucket]]
+This specifies the bucket into which the resource will be written.
+Leading and/or trailing slashes are removed for you, as are spaces.
+
+[def [option -resource]]
+This is the full name of the resource within the bucket. A single
+leading slash is removed, but not a trailing slash.
+Spaces are not trimmed.
+
+[def [option -blocking]]
+The standard blocking flag.
+
+[def [option -file]]
+If this is specified, the [arg filename] must exist, must be readable,
+and must not be a special or directory file. [lb]file size[rb] must
+apply to it and must not change for the lifetime of the call. The
+default content-type is calculated based on the name and/or contents
+of the file. Specifying this is an error if [option -content] is
+also specified, but at least one of [option -file] or [option -content] must
+be specified. (The file is allowed to not exist or not be readable if
+[option -compare] [arg never] is specified.)
+
+[def [option -content]]
+If this is specified, the [arg contentstring] is sent as the body
+of the resource. The content-type defaults to "application/octet-string".
+Only the low bytes are sent, so non-ASCII should use the appropriate encoding
+(such as [lb]encoding convertto utf-8[rb]) before passing it
+to this routine, if necessary. Specifying this is an error if [option -file]
+is also specified, but at least one of [option -file] or [option -content] must
+be specified.
+
+[def [option -acl]]
+This defaults to [cmd "S3::Configure -default-acl"] if not specified.
+It sets the x-amz-acl header on the PUT operation.
+If the value provided is [arg calc], the x-amz-acl header is
+calculated based on the I/O permissions of the file to be uploaded;
+it is an error to specify [arg calc] and [option -content].
+If the value provided is [arg keep], the acl of the resource
+is read before the PUT (or the default is used if the
+resource does not exist), then set back to what it
+was after the PUT (if it existed). An error will occur if
+the resource is successfully written but the kept ACL cannot
+be then applied. This should never happen.
+[emph Note:] [arg calc] is not currently fully implemented.
+
+[def [option -x-amz-meta-*]]
+If any header starts with "-x-amz-meta-", its contents are added to the
+PUT command to be stored as metadata with the resource. Again, no
+encoding is performed, and the metadata should not contain characters
+like newlines, carriage returns, and so on. It is best to stick with
+simple ASCII strings, or to fix the library in several places.
+
+[def [option -content-type]]
+This overrides the content-type calculated by [option -file] or
+sets the content-type for [option -content].
+
+[def [option -compare]]
+This is the standard compare mode argument. [cmd S3::Put] returns
+1 if the data was copied or 0 if the data was skipped due to
+the comparison mode so indicating it should be skipped.
+
+[list_end]
+
+[para]
+
+[call [cmd S3::Get] \
+[opt "[option -bucket] [arg bucketname]"] \
+[option -resource] [arg resourcename] \
+[opt "[option -blocking] [arg boolean]"] \
+[opt "[option -compare] [arg comparemode]"] \
+[opt "[option -file] [arg filename]"] \
+[opt "[option -content] [arg contentvarname]"] \
+[opt "[option -timestamp] [arg aws|now]"] \
+[opt "[option -headers] [arg headervarname]"] \
+]
+This command retrieves data from a resource on Amazon's S3 servers,
+using the HTTP GET command. It returns 0 if the [option -compare] mode
+prevented the transfer, 1 if the transfer worked, or throws an error
+if the transfer was attempted but failed. Server 5XX errors and S3 socket
+errors are are retried
+according to [cmd S3:Configure] settings before throwing an error;
+other errors throw immediately. Note that this is always authenticated
+as the user configured in via [cmd "S3::Configure -accesskeyid"]. Use
+the Tcllib http for unauthenticated GETs.
+[list_begin definitions]
+
+[def [option -bucket]]
+This specifies the bucket from which the resource will be read.
+Leading and/or trailing slashes are removed for you, as are spaces.
+
+[def [option -resource]]
+This is the full name of the resource within the bucket. A single
+leading slash is removed, but not a trailing slash.
+Spaces are not trimmed.
+
+[def [option -blocking]]
+The standard blocking flag.
+
+[def [option -file]]
+If this is specified, the body of the resource will be read into this file,
+incrementally without pulling it entirely into memory first. The parent
+directory must already exist. If the file already exists, it must be
+writable. If an error is thrown part-way through the process and the
+file already existed, it may be clobbered. If an error is thrown part-way
+through the process and the file did not already exist, any partial
+bits will be deleted. Specifying this is an error if [option -content]
+is also specified, but at least one of [option -file] or [option -content] must
+be specified.
+
+[def [option -timestamp]]
+This is only valid in conjunction with [option -file]. It may be specified
+as [arg now] or [arg aws]. The default is [arg now]. If [arg now], the file's
+modification date is left up to the system. If [arg aws], the file's
+mtime is set to match the Last-Modified header on the resource, synchronizing
+the two appropriately for [option -compare] [arg date] or
+[option -compare] [arg newer].
+
+[def [option -content]]
+If this is specified, the [arg contentvarname] is a variable in the caller's
+scope (not necessarily global) that receives the value of the body of
+the resource. No encoding is done, so if the resource (for example) represents
+a UTF-8 byte sequence, use [lb]encoding convertfrom utf-8[rb] to get a valid
+UTF-8 string. If this is specified, the [option -compare] is ignored unless
+it is [arg never], in which case no assignment to [arg contentvarname] is
+performed. Specifying this is an error if [option -file] is also specified,
+but at least one of [option -file] or [option -content] must be specified.
+
+[def [option -compare]]
+This is the standard compare mode argument. [cmd S3::Get] returns
+1 if the data was copied or 0 if the data was skipped due to
+the comparison mode so indicating it should be skipped.
+
+[def [option -headers]]
+If this is specified, the headers resulting from the fetch are stored
+in the provided variable, as a dictionary. This will include content-type
+and x-amz-meta-* headers, as well as the usual HTTP headers, the x-amz-id
+debugging headers, and so on. If no file is fetched (due to [option -compare]
+or other errors), no assignment to this variable is performed.
+
+[list_end]
+
+[para]
+
+[call [cmd S3::Head] \
+[opt "[option -bucket] [arg bucketname]"] \
+[option -resource] [arg resourcename] \
+[opt "[option -blocking] [arg boolean]"] \
+[opt "[option -dict] [arg dictvarname]"] \
+[opt "[option -headers] [arg headersvarname]"] \
+[opt "[option -status] [arg statusvarname]"] \
+]
+This command requests HEAD from the resource.
+It returns whether a 2XX code was returned as a result
+of the request, never throwing an S3 remote error.
+That is, if this returns 1, the resource exists and is
+accessible. If this returns 0, something went wrong, and the
+[option -status] result can be consulted for details.
+
+[list_begin definitions]
+
+[def [option -bucket]]
+This specifies the bucket from which the resource will be read.
+Leading and/or trailing slashes are removed for you, as are spaces.
+
+[def [option -resource]]
+This is the full name of the resource within the bucket. A single
+leading slash is removed, but not a trailing slash.
+Spaces are not trimmed.
+
+[def [option -blocking]]
+The standard blocking flag.
+
+[def [option -dict]]
+If specified, the resulting dictionary from the [cmd S3::REST]
+call is assigned to the indicated (not necessarily global) variable
+in the caller's scope.
+
+[def [option -headers]]
+If specified, the dictionary of headers from the result are assigned
+to the indicated (not necessarily global) variable in the caller's scope.
+
+[def [option -status]]
+If specified, the indicated (not necessarily global) variable in
+the caller's scope is assigned a 2-element list. The first element is
+the 3-digit HTTP status code, while the second element is
+the HTTP message (such as "OK" or "Forbidden").
+
+[list_end]
+
+[call [cmd S3::GetAcl] \
+[opt "[option -blocking] [arg boolean]"] \
+[opt "[option -bucket] [arg bucketname]"] \
+[option -resource] [arg resourcename] \
+[opt "[option -result-type] [arg REST|xml|pxml]"] \
+]
+
+This command gets the ACL of the indicated resource or throws an
+error if it is unavailable.
+
+[list_begin definitions]
+[def "[option -blocking] [arg boolean]"]
+See above for standard definition.
+
+[def [option -bucket]]
+This specifies the bucket from which the resource will be read.
+Leading and/or trailing slashes are removed for you, as are spaces.
+
+[def [option -resource]]
+This is the full name of the resource within the bucket. A single
+leading slash is removed, but not a trailing slash.
+Spaces are not trimmed.
+
+[def "[option -parse-xml] [arg xml]"]
+The XML from a previous GetACL can be passed in to be parsed into
+dictionary form. In this case, -result-type must be pxml or dict.
+
+[def "[option -result-type] [arg REST]"]
+The dictionary returned by [cmd S3::REST] is the return value of
+[cmd S3::GetAcl]. In this case, a non-2XX httpstatus will not throw an
+error.
+
+[def "[option -result-type] [arg xml]"]
+The raw XML of the body is returned as the result (with no encoding applied).
+
+[def "[option -result-type] [arg pxml]"]
+The XML of the body as parsed by [cmd xsxp::parse] is returned.
+
+[def "[option -result-type] [arg dict]"]
+This fetches the ACL, parses it, and returns a dictionary of two elements.
+
+[para]
+
+The first element has the key "owner" whose value is the canonical ID of the owner of the resource.
+
+[para]
+
+The second element has the key "acl" whose value is a dictionary. Each
+key in the dictionary is one of Amazon's permissions, namely "READ",
+"WRITE", "READ_ACP", "WRITE_ACP", or "FULL_CONTROL". Each value of each
+key is a list of canonical IDs or group URLs that have that permission.
+Elements are not in the list in any particular order, and not all keys
+are necessarily present. Display names are not returned, as they are
+not especially useful; use pxml to obtain them if necessary.
+
+[list_end]
+
+[call [cmd S3::PutAcl] \
+[opt "[option -blocking] [arg boolean]"] \
+[opt "[option -bucket] [arg bucketname]"] \
+[option -resource] [arg resourcename] \
+[opt "[option -acl] [arg new-acl]"] \
+]
+
+This sets the ACL on the indicated resource. It returns the XML written to the ACL, or throws an error if anything went wrong.
+
+[list_begin definitions]
+[def "[option -blocking] [arg boolean]"]
+See above for standard definition.
+
+[def [option -bucket]]
+This specifies the bucket from which the resource will be read.
+Leading and/or trailing slashes are removed for you, as are spaces.
+
+[def [option -resource]]
+This is the full name of the resource within the bucket. A single
+leading slash is removed, but not a trailing slash.
+Spaces are not trimmed.
+
+[def [option -owner]]
+If this is provided, it is assumed to match the owner of the resource.
+Otherwise, a GET may need to be issued against the resource to find
+the owner. If you already have the owner (such as from a call
+to [cmd S3::GetAcl], you can pass the value of the "owner" key
+as the value of this option, and it will be used in the construction
+of the XML.
+
+[def [option -acl]]
+If this option is specified, it provides the ACL the caller wishes
+to write to the resource. If this is not supplied or is empty,
+the value is taken from [cmd "S3::Configure -default-acl"].
+The ACL is written with a PUT to the ?acl resource.
+
+[para]
+
+If the value passed to this option
+starts with "<", it is taken to be a body to be PUT to the ACL resource.
+
+[para]
+
+If the value matches one of the standard Amazon x-amz-acl headers (i.e.,
+a canned access policy), that header is translated to XML and then
+applied. The canned access policies are private, public-read,
+public-read-write, and authenticated-read (in lower case).
+
+[para]
+
+Otherwise, the value is assumed to be a dictionary formatted as the
+"acl" sub-entry within the dict returns by [cmd "S3::GetAcl -result-type dict"].
+The proper XML is generated and applied to the resource. Note that a
+value containing "//" is assumed to be a group, a value containing "@"
+is assumed to be an AmazonCustomerByEmail, and otherwise the value is
+assumed to be a canonical Amazon ID.
+
+[para]
+
+Note that you cannot change the owner, so calling GetAcl on a resource
+owned by one user and applying it via PutAcl on a resource owned by
+another user may not do exactly what you expect.
+
+[list_end]
+
+[call [cmd S3::Delete] \
+[opt "[option -bucket] [arg bucketname]"] \
+[option -resource] [arg resourcename] \
+[opt "[option -blocking] [arg boolean]"] \
+[opt "[option -status] [arg statusvar]"] \
+]
+This command deletes the specified resource from the specified bucket.
+It returns 1 if the resource was deleted successfully, 0 otherwise.
+It returns 0 rather than throwing an S3 remote error.
+
+[list_begin definitions]
+[def [option -bucket]]
+This specifies the bucket from which the resource will be deleted.
+Leading and/or trailing slashes are removed for you, as are spaces.
+
+[def [option -resource]]
+This is the full name of the resource within the bucket. A single
+leading slash is removed, but not a trailing slash.
+Spaces are not trimmed.
+
+[def [option -blocking]]
+The standard blocking flag.
+
+[def [option -status]]
+If specified, the indicated (not necessarily global) variable
+in the caller's scope is set to a two-element list. The first
+element is the 3-digit HTTP status code. The second element
+is the HTTP message (such as "OK" or "Forbidden"). Note that
+Amazon's DELETE result is 204 on success, that being the
+code indicating no content in the returned body.
+
+[list_end]
+
+[para]
+
+[call [cmd S3::Push] \
+[opt "[option -bucket] [arg bucketname]"] \
+[option -directory] [arg directoryname] \
+[opt "[option -prefix] [arg prefixstring]"] \
+[opt "[option -compare] [arg comparemode]"] \
+[opt "[option -x-amz-meta-*] [arg metastring]"] \
+[opt "[option -acl] [arg aclcode]"] \
+[opt "[option -delete] [arg boolean]"] \
+[opt "[option -error] [arg throw|break|continue]"] \
+[opt "[option -progress] [arg scriptprefix]"] \
+]
+This synchronises a local directory with a remote bucket
+by pushing the differences using [cmd S3::Put]. Note that
+if something has changed in the bucket but not locally,
+those changes could be lost. Thus, this is not a general
+two-way synchronization primitive. (See [cmd S3::Sync]
+for that.) Note too that resource names are case sensitive,
+so changing the case of a file on a Windows machine may lead
+to otherwise-unnecessary transfers.
+Note that only regular files are considered, so devices, pipes, symlinks,
+and directories are not copied.
+
+[list_begin definitions]
+
+[def [option -bucket]]
+This names the bucket into which data will be pushed.
+
+[def [option -directory]]
+This names the local directory from which files will be taken.
+It must exist, be readable via [lb]glob[rb] and so on. If only
+some of the files therein are readable, [cmd S3::Push] will PUT
+those files that are readable and return in its results the list
+of files that could not be opened.
+
+[def [option -prefix]]
+This names the prefix that will be added to all resources.
+That is, it is the remote equivalent of [option -directory].
+If it is not specified, the root of the bucket will be treated
+as the remote directory. An example may clarify.
+[example {
+S3::Push -bucket test -directory /tmp/xyz -prefix hello/world
+}]
+In this example, /tmp/xyz/pdq.html will be stored as
+http://s3.amazonaws.com/test/hello/world/pdq.html in Amazon's servers. Also,
+/tmp/xyz/abc/def/Hello will be stored as
+http://s3.amazonaws.com/test/hello/world/abc/def/Hello in Amazon's servers.
+Without the [option -prefix] option, /tmp/xyz/pdq.html would be stored
+as http://s3.amazonaws.com/test/pdq.html.
+
+[def [option -blocking]]
+This is the standard blocking option.
+
+[def [option -compare]]
+If present, this is passed to each invocation of [cmd S3::Put].
+Naturally, [cmd "S3::Configure -default-compare"] is used
+if this is not specified.
+
+[def [option -x-amz-meta-*]]
+If present, this is passed to each invocation of [cmd S3::Put]. All copied
+files will have the same metadata.
+
+[def [option -acl]]
+If present, this is passed to each invocation of [cmd S3::Put].
+
+[def [option -delete]]
+This defaults to false. If true, resources in the destination that
+are not in the source directory are deleted with [cmd S3::Delete].
+Since only regular files are considered, the existance of a symlink,
+pipe, device, or directory in the local source will [emph not]
+prevent the deletion of a remote resource with a corresponding name.
+
+[def [option -error]]
+This controls the behavior of [cmd S3::Push] in the event that
+[cmd S3::Put] throws an error. Note that
+errors encountered on the local file system or in reading the
+list of resources in the remote bucket always throw errors.
+This option allows control over "partial" errors, when some
+files were copied and some were not. [cmd S3::Delete] is always
+finished up, with errors simply recorded in the return result.
+
+[list_begin definitions]
+
+[def throw]
+The error is rethrown with the same errorCode.
+
+[def break]
+Processing stops without throwing an error, the error is recorded
+in the return value, and the command returns with a normal return.
+The calls to [cmd S3::Delete] are not started.
+
+[def continue]
+This is the default. Processing continues without throwing,
+recording the error in the return result, and resuming with the
+next file in the local directory to be copied.
+
+[list_end]
+
+[def [option -progress]]
+If this is specified and the indicated script prefix is not empty, the
+indicated script prefix will be invoked several times in the caller's
+context with additional arguments at various points in the processing.
+This allows progress reporting without backgrounding. The provided
+prefix will be invoked with additional arguments, with the first
+additional argument indicating what part of the process is being
+reported on. The prefix is initially invoked with [arg args] as the
+first additional argument and a dictionary representing the normalized
+arguments to the [cmd S3::Push] call as the second additional argument.
+Then the prefix is invoked with [arg local] as the first additional
+argument and a list of suffixes of the files to be considered as the
+second argument. Then the prefix is invoked with [arg remote] as the
+first additional argument and a list of suffixes existing in the remote
+bucket as the second additional argument. Then, for each file in the
+local list, the prefix will be invoked with [arg start] as the first
+additional argument and the common suffix as the second additional
+argument. When [cmd S3::Put] returns for that file, the prefix will be
+invoked with [arg copy] as the first additional argument, the common
+suffix as the second additional argument, and a third argument that will
+be "copied" (if [cmd S3::Put] sent the resource), "skipped" (if
+[cmd S3::Put] decided not to based on [option -compare]), or the errorCode
+that [cmd S3::Put] threw due to unexpected errors (in which case the
+third argument is a list that starts with "S3"). When all files have
+been transfered, the prefix may be invoked zero or more times with
+[arg delete] as the first additional argument and the suffix of the
+resource being deleted as the second additional argument, with a third
+argument being either an empty string (if the delete worked) or the
+errorCode from [cmd S3::Delete] if it failed. Finally, the prefix
+will be invoked with [arg finished] as the first additional argument
+and the return value as the second additional argument.
+
+[list_end]
+
+The return result from this command is a dictionary. They keys are the
+suffixes (i.e., the common portion of the path after the [option -directory]
+and [option -prefix]), while the values are either "copied", "skipped" (if
+[option -compare] indicated not to copy the file), or the errorCode
+thrown by [cmd S3::Put], as appropriate. If [option -delete] was true,
+there may also be entries for suffixes with the value "deleted" or
+"notdeleted", indicating whether the attempted [cmd S3::Delete]
+worked or not, respectively. There is one additional pair in the return
+result, whose key is the empty string and whose value is a nested dictionary.
+The keys of this nested dictionary include "filescopied" (the number of
+files successfully copied), "bytescopied" (the number of data bytes in
+the files copied, excluding headers, metadata, etc), "compareskipped" (the
+number of files not copied due to [option -compare] mode), "errorskipped"
+(the number of files not copied due to thrown errors), "filesdeleted"
+(the number of resources deleted due to not having corresponding files
+locally, or 0 if [option -delete] is false), and "filesnotdeleted"
+(the number of resources whose deletion was attempted but failed).
+[para]
+Note that this is currently implemented somewhat inefficiently.
+It fetches the bucket listing (including timestamps and eTags),
+then calls [cmd S3::Put], which uses HEAD to find the timestamps
+and eTags again. Correcting this with no API change
+is planned for a future upgrade.
+
+[para]
+
+[call [cmd S3::Pull] \
+[opt "[option -bucket] [arg bucketname]"] \
+[option -directory] [arg directoryname] \
+[opt "[option -prefix] [arg prefixstring]"] \
+[opt "[option -blocking] [arg boolean]"] \
+[opt "[option -compare] [arg comparemode]"] \
+[opt "[option -delete] [arg boolean]"] \
+[opt "[option -timestamp] [arg aws|now]"] \
+[opt "[option -error] [arg throw|break|continue]"] \
+[opt "[option -progress] [arg scriptprefix]"] \
+]
+
+This synchronises a remote bucket with a local directory by pulling the
+differences using [cmd S3::Get] If something has been changed locally but not
+in the bucket, those difference may be lost. This is not a general two-way
+synchronization mechanism. (See [cmd S3::Sync] for that.)
+This creates directories
+if needed; new directories are created with default permissions. Note that
+resource names are case sensitive, so changing the case of a file on a
+Windows machine may lead to otherwise-unnecessary transfers. Also, try not
+to store data in resources that end with a slash, or which are prefixes of
+resources that otherwise would start with a slash; i.e., don't use this if
+you store data in resources whose names have to be directories locally.
+[para]
+Note that this is currently implemented somewhat inefficiently.
+It fetches the bucket listing (including timestamps and eTags),
+then calls [cmd S3::Get], which uses HEAD to find the timestamps
+and eTags again. Correcting this with no API change
+is planned for a future upgrade.
+
+[list_begin definitions]
+
+[def [option -bucket]]
+This names the bucket from which data will be pulled.
+
+[def [option -directory]]
+This names the local directory into which files will be written
+It must exist, be readable via [lb]glob[rb], writable for file creation,
+and so on. If only some of the files therein are writable,
+[cmd S3::Pull] will GET
+those files that are writable and return in its results the list
+of files that could not be opened.
+
+[def [option -prefix]]
+The prefix of resources that will be considered for retrieval.
+See [cmd S3::Push] for more details, examples, etc. (Of course,
+[cmd S3::Pull] reads rather than writes, but the prefix is
+treated similarly.)
+
+[def [option -blocking]]
+This is the standard blocking option.
+
+[def [option -compare]]
+This is passed to each invocation of [cmd S3::Get] if provided.
+Naturally, [cmd "S3::Configure -default-compare"] is
+used if this is not provided.
+
+[def [option -timestamp]]
+This is passed to each invocation of [cmd S3::Get] if provided.
+
+[def [option -delete]]
+If this is specified and true, files that exist in the [option -directory]
+that are not in the [option -prefix] will be deleted after all resources
+have been copied. In addition, empty directories (other than the
+top-level [option -directory]) will be deleted, as
+Amazon S3 has no concept of an empty directory.
+
+[def [option -error]]
+See [cmd S3::Push] for a description of this option.
+
+[def [option -progress]]
+See [cmd S3::Push] for a description of this option.
+It differs slightly in that local directories may be included
+with a trailing slash to indicate they are directories.
+
+[list_end]
+
+The return value from this command is a dictionary. It
+is identical in form and meaning to the description of the
+return result of [cmd S3::Push]. It differs only in that
+directories may be included, with a trailing slash in their name,
+if they are empty and get deleted.
+
+[call [cmd S3::Toss] \
+[opt "[option -bucket] [arg bucketname]"] \
+[option -prefix] [arg prefixstring] \
+[opt "[option -blocking] [arg boolean]"] \
+[opt "[option -error] [arg throw|break|continue]"] \
+[opt "[option -progress] [arg scriptprefix]"] \
+]
+
+This deletes some or all resources within a bucket. It would be
+considered a "recursive delete" had Amazon implemented actual
+directories.
+
+[list_begin options]
+[opt_def -bucket]
+The bucket from which resources will be deleted.
+
+[opt_def [option -blocking]]
+The standard blocking option.
+
+[opt_def [option -prefix]]
+The prefix for resources to be deleted. Any resource that
+starts with this string will be deleted. This is required.
+To delete everything in the bucket, pass an empty string
+for the prefix.
+
+[opt_def [option -error]]
+If this is "throw", [cmd S3::Toss] rethrows any errors
+it encounters. If this is "break", [cmd S3::Toss] returns
+with a normal return after the first error, recording that
+error in the return result. If this is "continue", which is
+the default, [cmd S3::Toss] continues on and lists all
+errors in the return result.
+
+[opt_def [option -progress]]
+If this is specified and not an empty string, the script
+prefix will be invoked several times in the context of the caller
+with additional arguments appended. Initially, it will be invoked
+with the first additional argument being [arg args] and the second
+being the processed list of arguments to [cmd S3::Toss]. Then it
+is invoked with [arg remote] as the first additional argument and
+the list of suffixes in the bucket to be deleted as the second
+additional argument. Then it is invoked with the first additional
+argument being [arg delete] and the second additional argument being
+the suffix deleted and the third additional argument being "deleted"
+or "notdeleted" depending on whether [cmd S3::Delete] threw an error.
+Finally, the script prefix is invoked with a first additional argument
+of "finished" and a second additional argument of the return value.
+
+[list_end]
+
+The return value is a dictionary. The keys are the suffixes of files
+that [cmd S3::Toss] attempted to delete, and whose values are either
+the string "deleted" or "notdeleted". There is also one additional
+pair, whose key is the empty string and whose value is an embedded
+dictionary. The keys of this embedded dictionary include
+"filesdeleted" and "filesnotdeleted", each of which has integer values.
+
+[list_end]
+
+[section LIMITATIONS]
+
+[list_begin itemized]
+
+[item] The pure-Tcl MD5 checking is slow. If you are processing
+files in the megabyte range, consider ensuring binary support is available.
+
+[item] The commands [cmd S3::Pull] and [cmd S3::Push] fetch a
+directory listing which includes timestamps and MD5 hashes,
+then invoke [cmd S3::Get] and [cmd S3::Put]. If
+a complex [option -compare] mode is specified, [cmd S3::Get] and
+[cmd S3::Put] will invoke a HEAD operation for each file to fetch
+timestamps and MD5 hashes of each resource again. It is expected that
+a future release of this package will solve this without any API changes.
+
+[item] The commands [cmd S3::Pull] and [cmd S3::Push] fetch a
+directory listing without using [option -max-count]. The entire
+directory is pulled into memory at once. For very large buckets,
+this could be a performance problem. The author, at this time,
+does not plan to change this behavior. Welcome to Open Source.
+
+[item] [cmd S3::Sync] is neither designed nor implemented yet.
+The intention would be to keep changes synchronised, so changes
+could be made to both the bucket and the local directory and
+be merged by [cmd S3::Sync].
+
+[item] Nor is
+[option -compare] [arg calc] fully implemented. This is primarily due to
+Windows not providing a convenient method for distinguishing between
+local files that are "public-read" or "public-read-write". Assistance
+figuring out TWAPI for this would be appreciated. The U**X semantics
+are difficult to map directly as well. See the source for details.
+Note that there are not tests for calc, since it isn't done yet.
+
+[item] The HTTP processing is implemented within the library,
+rather than using a "real" HTTP package. Hence, multi-line headers
+are not (yet) handled correctly. Do not include carriage returns or
+linefeeds in x-amz-meta-* headers, content-type values, and so on.
+The author does not at this time expect to improve this.
+
+[item] Internally, [cmd S3::Push] and [cmd S3::Pull] and [cmd S3::Toss]
+are all very similar and should be refactored.
+
+[item] The idea of using [option -compare] [arg never]
+[option -delete] [arg true] to delete files that have been
+deleted from one place but not the other yet not copying
+changed files is untested.
+
+[list_end]
+
+[section "USAGE SUGGESTIONS"]
+
+To fetch a "directory" out of a bucket, make changes, and store it back:
+[example_begin]
+file mkdir ./tempfiles
+S3::Pull -bucket sample -prefix of/interest -directory ./tempfiles \
+ -timestamp aws
+do_my_process ./tempfiles other arguments
+S3::Push -bucket sample -prefix of/interest -directory ./tempfiles \
+ -compare newer -delete true
+[example_end]
+
+[para]
+To delete files locally that were deleted off of S3 but not otherwise
+update files:
+
+[example_begin]
+S3::Pull -bucket sample -prefix of/interest -directory ./myfiles \
+ -compare never -delete true
+[example_end]
+
+[section "FUTURE DEVELOPMENTS"]
+
+The author intends to work on several additional projects related to
+this package, in addition to finishing the unfinished features.
+
+[para]
+First, a command-line program allowing browsing of buckets and
+transfer of files from shell scripts and command prompts is useful.
+
+[para]
+Second, a GUI-based program allowing visual manipulation of
+bucket and resource trees not unlike Windows Explorer would
+be useful.
+
+[para]
+Third, a command-line (and perhaps a GUI-based) program called
+"OddJob" that will use S3 to synchronize computation amongst
+multiple servers running OddJob. An S3 bucket will be set up
+with a number of scripts to run, and the OddJob program can
+be invoked on multiple machines to run scripts on all the machines,
+each moving on to the next unstarted task as it finishes each.
+This is still being designed, and it is intended primarily
+to be run on Amazon's Elastic Compute Cloud.
+
+[include ../common-text/tls-security-notes.inc]
+
+[vset CATEGORY amazon-s3]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/amazon-s3/S3.tcl b/tcllib/modules/amazon-s3/S3.tcl
new file mode 100644
index 0000000..b82a256
--- /dev/null
+++ b/tcllib/modules/amazon-s3/S3.tcl
@@ -0,0 +1,1960 @@
+# S3.tcl
+#
+###Abstract
+# This presents an interface to Amazon's S3 service.
+# The Amazon S3 service allows for reliable storage
+# and retrieval of data via HTTP.
+#
+# Copyright (c) 2006,2008 Darren New. All Rights Reserved.
+#
+###Copyright
+# NO WARRANTIES OF ANY TYPE ARE PROVIDED.
+# COPYING OR USE INDEMNIFIES THE AUTHOR IN ALL WAYS.
+#
+# This software is licensed under essentially the same
+# terms as Tcl. See LICENSE.txt for the terms.
+#
+###Revision String
+# SCCS: %Z% %M% %I% %E% %U%
+#
+###Change history:
+# 0.7.2 - added -default-bucket.
+# 0.8.0 - fixed bug in getLocal using wrong prefix.
+# Upgraded to Tcl 8.5 release version.
+# 1.0.0 - added SetAcl, GetAcl, and -acl keep option.
+#
+
+package require Tcl 8.5
+
+# This is by Darren New too.
+# It is a SAX package to format XML for easy retrieval.
+# It should be in the same distribution as S3.
+package require xsxp
+
+# These three are required to do the auth, so always require them.
+# Note that package registry and package fileutil are required
+# by the individual routines that need them. Grep for "package".
+package require sha1
+package require md5
+package require base64
+
+package provide S3 1.0.3
+
+namespace eval S3 {
+ variable config ; # A dict holding the current configuration.
+ variable config_orig ; # Holds configuration to "reset" back to.
+ variable debug 0 ; # Turns on or off S3::debug
+ variable debuglog 0 ; # Turns on or off debugging into a file
+ variable bgvar_counter 0 ; # Makes unique names for bgvars.
+
+ set config_orig [dict create \
+ -reset false \
+ -retries 3 \
+ -accesskeyid "" -secretaccesskey "" \
+ -service-access-point "s3.amazonaws.com" \
+ -slop-seconds 3 \
+ -use-tls false \
+ -bucket-prefix "TclS3" \
+ -default-compare "always" \
+ -default-separator "/" \
+ -default-acl "" \
+ -default-bucket "" \
+ ]
+
+ set config $config_orig
+}
+
+# Internal, for development. Print a line, and maybe log it.
+proc S3::debuglogline {line} {
+ variable debuglog
+ puts $line
+ if {$debuglog} {
+ set x [open debuglog.txt a]
+ puts $x $line
+ close $x
+ }
+}
+
+# Internal, for development. Print debug info properly formatted.
+proc S3::debug {args} {
+ variable debug
+ variable debuglog
+ if {!$debug} return
+ set res ""
+ if {"-hex" == [lindex $args 0]} {
+ set str [lindex $args 1]
+ foreach ch [split $str {}] {
+ scan $ch %c val
+ append res [format %02x $val]
+ append res " "
+ }
+ debuglogline $res
+ return
+ }
+ if {"-dict" == [lindex $args 0]} {
+ set dict [lindex $args 1]
+ debuglogline "DEBUG dict:"
+ foreach {key val} $dict {
+ set val [string map [list \
+ \r \\r \n \\n \0 \\0 ] $val]
+ debuglogline "$key=$val"
+ }
+ return
+ }
+ set x [string map [list \
+ \r \\r \n \\n \0 \\0 ] $args]
+ debuglogline "DEBUG: $x"
+}
+
+# Internal. Throws an error if keys have not been initialized.
+proc S3::checkinit {} {
+ variable config
+ set error "S3 must be initialized with -accesskeyid and -secretaccesskey before use"
+ set e1 {S3 usage -accesskeyid "S3 identification not initialized"}
+ set e2 {S3 usage -secretaccesskey "S3 identification not initialized"}
+ if {[dict get $config -accesskeyid] eq ""} {
+ error $error "" $e1
+ }
+ if {[dict get $config -secretaccesskey] eq ""} {
+ error $error "" $e2
+ }
+}
+
+# Internal. Calculates the Content-Type for a given file name.
+# Naturally returns application/octet-stream if anything goes wrong.
+proc S3::contenttype {fname} {
+ if {$::tcl_platform(platform) == "windows"} {
+ set extension [file extension $fname]
+ uplevel #0 package require registry
+ set key "\\\\HKEY_CLASSES_ROOT\\"
+ set key "HKEY_CLASSES_ROOT\\"
+ if {"." != [string index $extension 0]} {append key .}
+ append key $extension
+ set ct "application/octet-stream"
+ if {$extension != ""} {
+ catch {set ct [registry get $key {Content Type}]} caught
+ }
+ } else {
+ # Assume something like Unix.
+ if {[file readable /etc/mime.types]} {
+ set extension [string trim [file extension $fname] "."]
+ set f [open /etc/mime.types r]
+ while {-1 != [gets $f line] && ![info exists c]} {
+ set line [string trim $line]
+ if {[string match "#*" $line]} continue
+ if {0 == [string length $line]} continue
+ set items [split $line]
+ for {set i 1} {$i < [llength $items]} {incr i} {
+ if {[lindex $items $i] eq $extension} {
+ set c [lindex $items 0]
+ break
+ }
+ }
+ }
+ close $f
+ if {![info exists c]} {
+ set ct "application/octet-stream"
+ } else {
+ set ct [string trim $c]
+ }
+ } else {
+ # No /etc/mime.types here.
+ if {[catch {exec file -i $fname} res]} {
+ set ct "application/octet-stream"
+ } else {
+ set ct [string range $res [expr {1+[string first : $res]}] end]
+ if {-1 != [string first ";" $ct]} {
+ set ct [string range $ct 0 [string first ";" $ct]]
+ }
+ set ct [string trim $ct "; "]
+ }
+ }
+ }
+ return $ct
+}
+
+# Change current configuration. Not object-oriented, so only one
+# configuration is tracked per interpreter.
+proc S3::Configure {args} {
+ variable config
+ variable config_orig
+ if {[llength $args] == 0} {return $config}
+ if {[llength $args] == 1 && ![dict exists $config [lindex $args 0]]} {
+ error "Bad option \"[lindex $args 0]\": must be [join [dict keys $config] ,\ ]" "" [list S3 usage [lindex $args 0] "Bad option to config"]
+ }
+ if {[llength $args] == 1} {return [dict get $config [lindex $args 0]]}
+ if {[llength $args] % 2 != 0} {
+ error "Config args must be -name val -name val" "" [list S3 usage [lindex $args end] "Odd number of config args"]
+ }
+ set new $config
+ foreach {tag val} $args {
+ if {![dict exists $new $tag]} {
+ error "Bad option \"$tag\": must be [join [dict keys $config] ,\ ]" "" [list S3 usage $tag "Bad option to config"]
+ }
+ dict set new $tag $val
+ if {$tag eq "-reset" && $val} {
+ set new $config_orig
+ }
+ }
+ if {[dict get $config -use-tls]} {
+ error "TLS for S3 not yet implemented!" "" \
+ [list S3 notyet -use-tls $config]
+ }
+ set config $new ; # Only update if all went well
+ return $config
+}
+
+# Suggest a unique bucket name based on usename and config info.
+proc S3::SuggestBucket {{usename ""}} {
+ checkinit
+ if {$usename eq ""} {set usename [::S3::Configure -bucket-prefix]}
+ if {$usename eq ""} {
+ error "S3::SuggestBucket requires name or -bucket-prefix set" \
+ "" [list S3 usage -bucket-prefix]
+ }
+ return $usename\.[::S3::Configure -accesskeyid]
+}
+
+# Calculate authorization token for REST interaction.
+# Doesn't work yet for "Expires" type headers. Hence, only for "REST".
+# We specifically don't call checkinit because it's called in all
+# callers and we don't want to throw an error inside here.
+# Caveat Emptor if you expect otherwise.
+# This is internal, but useful enough you might want to invoke it.
+proc S3::authREST {verb resource content-type headers args} {
+ if {[llength $args] != 0} {
+ set body [lindex $args 0] ; # we use [info exists] later
+ }
+ if {${content-type} != "" && [dict exists $headers content-type]} {
+ set content-type [dict get $headers content-type]
+ }
+ dict unset headers content-type
+ set verb [string toupper $verb]
+ if {[info exists body]} {
+ set content-md5 [::base64::encode [::md5::md5 $body]]
+ dict set headers content-md5 ${content-md5}
+ dict set headers content-length [string length $body]
+ } elseif {[dict exists $headers content-md5]} {
+ set content-md5 [dict get $headers content-md5]
+ } else {
+ set content-md5 ""
+ }
+ if {[dict exists $headers x-amz-date]} {
+ set date ""
+ dict unset headers date
+ } elseif {[dict exists $headers date]} {
+ set date [dict get $headers date]
+ } else {
+ set date [clock format [clock seconds] -gmt true -format \
+ "%a, %d %b %Y %T %Z"]
+ dict set headers date $date
+ }
+ if {${content-type} != ""} {
+ dict set headers content-type ${content-type}
+ }
+ dict set headers host s3.amazonaws.com
+ set xamz ""
+ foreach key [lsort [dict keys $headers x-amz-*]] {
+ # Assume each is seen only once, for now, and is canonical already.
+ append xamz \n[string trim $key]:[string trim [dict get $headers $key]]
+ }
+ set xamz [string trim $xamz]
+ # Hmmm... Amazon lies. No \n after xamz if xamz is empty.
+ if {0 != [string length $xamz]} {append xamz \n}
+ set signthis \
+ "$verb\n${content-md5}\n${content-type}\n$date\n$xamz$resource"
+ S3::debug "Sign this:" $signthis ; S3::debug -hex $signthis
+ set sig [::sha1::hmac [S3::Configure -secretaccesskey] $signthis]
+ set sig [binary format H* $sig]
+ set sig [string trim [::base64::encode $sig]]
+ dict set headers authorization "AWS [S3::Configure -accesskeyid]:$sig"
+ return $headers
+}
+
+# Internal. Takes resource and parameters, tacks them together.
+# Useful enough you might want to invoke it yourself.
+proc S3::to_url {resource parameters} {
+ if {0 == [llength $parameters]} {return $resource}
+ if {-1 == [string first "?" $resource]} {
+ set front ?
+ } else {
+ set front &
+ }
+ foreach {key value} $parameters {
+ append resource $front $key "=" $value
+ set front &
+ }
+ return $resource
+}
+
+# Internal. Encode a URL, including utf-8 versions.
+# Useful enough you might want to invoke it yourself.
+proc S3::encode_url {orig} {
+ set res ""
+ set re {[-a-zA-Z0-9/.,_]}
+ foreach ch [split $orig ""] {
+ if {[regexp $re $ch]} {
+ append res $ch
+ } else {
+ foreach uch [split [encoding convertto utf-8 $ch] ""] {
+ append res "%"
+ binary scan $uch H2 hex
+ append res $hex
+ }
+ }
+ }
+ if {$res ne $orig} {
+ S3::debug "URL Encoded:" $orig $res
+ }
+ return $res
+}
+
+# This is used internally to either queue an event-driven
+# item or to simply call the next routine, depending on
+# whether the current transaction is supposed to be running
+# in the background or not.
+proc S3::nextdo {routine thunk direction args} {
+ global errorCode
+ S3::debug "nextdo" $routine $thunk $direction $args
+ if {[dict get $thunk blocking]} {
+ return [S3::$routine $thunk]
+ } else {
+ if {[llength $args] == 2} {
+ # fcopy failed!
+ S3::fail $thunk "S3 fcopy failed: [lindex $args 1]" "" \
+ [list S3 socket $errorCode]
+ } else {
+ fileevent [dict get $thunk S3chan] $direction \
+ [list S3::$routine $thunk]
+ if {$direction == "writable"} {
+ fileevent [dict get $thunk S3chan] readable {}
+ } else {
+ fileevent [dict get $thunk S3chan] writable {}
+ }
+ }
+ }
+}
+
+# The proverbial It. Do a REST call to Amazon S3 service.
+proc S3::REST {orig} {
+ variable config
+ checkinit
+ set EndPoint [dict get $config -service-access-point]
+
+ # Save the original stuff first.
+ set thunk [dict create orig $orig]
+
+ # Now add to thunk's top-level the important things
+ if {[dict exists $thunk orig resultvar]} {
+ dict set thunk blocking 0
+ } else {
+ dict set thunk blocking 1
+ }
+ if {[dict exists $thunk orig S3chan]} {
+ dict set thunk S3chan [dict get $thunk orig S3chan]
+ } elseif {[dict get $thunk blocking]} {
+ dict set thunk S3chan [socket $EndPoint 80]
+ } else {
+ dict set thunk S3chan [socket -async $EndPoint 80]
+ }
+ fconfigure [dict get $thunk S3chan] -translation binary -encoding binary
+
+ dict set thunk verb [dict get $thunk orig verb]
+ dict set thunk resource [S3::encode_url [dict get $thunk orig resource]]
+ if {[dict exists $orig rtype]} {
+ dict set thunk resource \
+ [dict get $thunk resource]?[dict get $orig rtype]
+ }
+ if {[dict exists $orig headers]} {
+ dict set thunk headers [dict get $orig headers]
+ } else {
+ dict set thunk headers [dict create]
+ }
+ if {[dict exists $orig infile]} {
+ dict set thunk infile [dict get $orig infile]
+ }
+ if {[dict exists $orig content-type]} {
+ dict set thunk content-type [dict get $orig content-type]
+ } else {
+ if {[dict exists $thunk infile]} {
+ set zz [dict get $thunk infile]
+ } else {
+ set zz [dict get $thunk resource]
+ }
+ if {-1 != [string first "?" $zz]} {
+ set zz [string range $zz 0 [expr {[string first "?" $zz]-1}]]
+ set zz [string trim $zz]
+ }
+ if {$zz != ""} {
+ catch {dict set thunk content-type [S3::contenttype $zz]}
+ } else {
+ dict set thunk content-type application/octet-stream
+ dict set thunk content-type ""
+ }
+ }
+ set p {}
+ if {[dict exist $thunk orig parameters]} {
+ set p [dict get $thunk orig parameters]
+ }
+ dict set thunk url [S3::to_url [dict get $thunk resource] $p]
+
+ if {[dict exists $thunk orig inbody]} {
+ dict set thunk headers [S3::authREST \
+ [dict get $thunk verb] [dict get $thunk resource] \
+ [dict get $thunk content-type] [dict get $thunk headers] \
+ [dict get $thunk orig inbody] ]
+ } else {
+ dict set thunk headers [S3::authREST \
+ [dict get $thunk verb] [dict get $thunk resource] \
+ [dict get $thunk content-type] [dict get $thunk headers] ]
+ }
+ # Not the best place to put this code.
+ if {![info exists body] && [dict exists $thunk infile]} {
+ set size [file size [dict get $thunk infile]]
+ set x [dict get $thunk headers]
+ dict set x content-length $size
+ dict set thunk headers $x
+ }
+
+
+ # Ready to go!
+ return [S3::nextdo send_headers $thunk writable]
+}
+
+# Internal. Send the headers to Amazon. Might block if you have
+# really small socket buffers, but Amazon doesn't want
+# data that big anyway.
+proc S3::send_headers {thunk} {
+ S3::debug "Send-headers" $thunk
+ set s3 [dict get $thunk S3chan]
+ puts $s3 "[dict get $thunk verb] [dict get $thunk url] HTTP/1.0"
+ S3::debug ">> [dict get $thunk verb] [dict get $thunk url] HTTP/1.0"
+ foreach {key val} [dict get $thunk headers] {
+ puts $s3 "$key: $val"
+ S3::debug ">> $key: $val"
+ }
+ puts $s3 ""
+ flush $s3
+ return [S3::nextdo send_body $thunk writable]
+}
+
+# Internal. Send the body to Amazon.
+proc S3::send_body {thunk} {
+ global errorCode
+ set s3 [dict get $thunk S3chan]
+ if {[dict exists $thunk orig inbody]} {
+ # Send a string. Let's guess that even in non-blocking
+ # mode, this is small enough or Tcl's smart enough that
+ # we don't blow up the buffer.
+ puts -nonewline $s3 [dict get $thunk orig inbody]
+ flush $s3
+ return [S3::nextdo read_headers $thunk readable]
+ } elseif {![dict exists $thunk orig infile]} {
+ # No body, no file, so nothing more to do.
+ return [S3::nextdo read_headers $thunk readable]
+ } elseif {[dict get $thunk blocking]} {
+ # A blocking file copy. Still not too hard.
+ if {[catch {set inchan [open [dict get $thunk infile] r]} caught]} {
+ S3::fail $thunk "S3 could not open infile - $caught" "" \
+ [list S3 local [dict get $thunk infile] $errorCode]
+ }
+ fconfigure $inchan -translation binary -encoding binary
+ fileevent $s3 readable {}
+ fileevent $s3 writable {}
+ if {[catch {fcopy $inchan $s3 ; flush $s3 ; close $inchan} caught]} {
+ S3::fail $thunk "S3 could not copy infile - $caught" "" \
+ [list S3 local [dict get $thunk infile] $errorCode]
+ }
+ S3::nextdo read_headers $thunk readable
+ } else {
+ # The hard one. Background file copy.
+ fileevent $s3 readable {}
+ fileevent $s3 writable {}
+ if {[catch {set inchan [open [dict get $thunk infile] r]} caught]} {
+ S3::fail $thunk "S3 could not open infile - $caught" "" \
+ [list S3 local [dict get $thunk infile] $errorCode]
+ }
+ fconfigure $inchan -buffering none -translation binary -encoding binary
+ fconfigure $s3 -buffering none -translation binary \
+ -encoding binary -blocking 0 ; # Doesn't work without this?
+ dict set thunk inchan $inchan ; # So we can close it.
+ fcopy $inchan $s3 -command \
+ [list S3::nextdo read_headers $thunk readable]
+ }
+}
+
+# Internal. The first line has come back. Grab out the
+# stuff we care about.
+proc S3::parse_status {thunk line} {
+ # Got the status line
+ S3::debug "<< $line"
+ dict set thunk httpstatusline [string trim $line]
+ dict set thunk outheaders [dict create]
+ regexp {^HTTP/1.. (...) (.*)$} $line junk code message
+ dict set thunk httpstatus $code
+ dict set thunk httpmessage [string trim $message]
+ return $thunk
+}
+
+# A line of header information has come back. Grab it.
+# This probably is unhappy with multiple lines for one
+# header.
+proc S3::parse_header {thunk line} {
+ # Got a header line. For now, assume no continuations.
+ S3::debug "<< $line"
+ set line [string trim $line]
+ set left [string range $line 0 [expr {[string first ":" $line]-1}]]
+ set right [string range $line [expr {[string first ":" $line]+1}] end]
+ set left [string trim [string tolower $left]]
+ set right [string trim $right]
+ dict set thunk outheaders $left $right
+ return $thunk
+}
+
+# I don't know if HTTP requires a blank line after the headers if
+# there's no body.
+
+# Internal. Read all the headers, and throw if we get EOF before
+# we get any headers at all.
+proc S3::read_headers {thunk} {
+ set s3 [dict get $thunk S3chan]
+ flush $s3
+ fconfigure $s3 -blocking [dict get $thunk blocking]
+ if {[dict get $thunk blocking]} {
+ # Blocking. Just read to a blank line. Otherwise,
+ # if we use nextdo here, we wind up nesting horribly.
+ # If we're not blocking, of course, we're returning
+ # to the event loop each time, so that's OK.
+ set count [gets $s3 line]
+ if {[eof $s3]} {
+ S3::fail $thunk "S3 EOF during status line read" "" "S3 socket EOF"
+ }
+ set thunk [S3::parse_status $thunk $line]
+ while {[string trim $line] != ""} {
+ set count [gets $s3 line]
+ if {$count == -1 && 0 == [dict size [dict get $thunk outheaders]]} {
+ S3::fail $thunk "S3 EOF during headers read" "" "S3 socket EOF"
+ }
+ if {[string trim $line] != ""} {
+ set thunk [S3::parse_header $thunk $line]
+ }
+ }
+ return [S3::nextdo read_body $thunk readable]
+ } else {
+ # Non-blocking, so we have to reenter for each line.
+ # First, fix up the file handle, tho.
+ if {[dict exists $thunk inchan]} {
+ close [dict get $thunk inchan]
+ dict unset thunk inchan
+ }
+ # Now get one header.
+ set count [gets $s3 line]
+ if {[eof $s3]} {
+ fileevent $s3 readable {}
+ fileevent $s3 writable {}
+ if {![dict exists $thunk httpstatusline]} {
+ S3::fail $thunk "S3 EOF during status line read" "" "S3 socket EOF"
+ } elseif {0 == [dict size [dict get $thunk outheaders]]} {
+ S3::fail $thunk "S3 EOF during header read" "" "S3 socket EOF"
+ }
+ }
+ if {$count < 0} return ; # Wait for a whole line
+ set line [string trim $line]
+ if {![dict exists $thunk httpstatus]} {
+ set thunk [S3::parse_status $thunk $line]
+ S3::nextdo read_headers $thunk readable ; # New thunk here.
+ } elseif {$line != ""} {
+ set thunk [S3::parse_header $thunk $line]
+ S3::nextdo read_headers $thunk readable ; # New thunk here.
+ } else {
+ # Got an empty line. Switch to copying the body.
+ S3::nextdo read_body $thunk readable
+ }
+ }
+}
+
+# Internal. Read the body of the response.
+proc S3::read_body {thunk} {
+ set s3 [dict get $thunk S3chan]
+ if {[dict get $thunk blocking]} {
+ # Easy. Just read it.
+ if {[dict exists $thunk orig outchan]} {
+ fcopy $s3 [dict get $thunk orig outchan]
+ } else {
+ set x [read $s3]
+ dict set thunk outbody $x
+ #S3::debug "Body: $x" -- Disable unconditional wasteful conversion to string
+ #Need better debug system which does this only when active.
+ }
+ return [S3::nextdo all_done $thunk readable]
+ } else {
+ # Nonblocking mode.
+ if {[dict exists $thunk orig outchan]} {
+ fileevent $s3 readable {}
+ fileevent $s3 writable {}
+ fcopy $s3 [dict get $thunk orig outchan] -command \
+ [list S3::nextdo all_done $thunk readable]
+ } else {
+ dict append thunk outbody [read $s3]
+ if {[eof $s3]} {
+ # We're done.
+ S3::nextdo all_done $thunk readable
+ } else {
+ S3::nextdo read_body $thunk readable
+ }
+ }
+ }
+}
+
+# Internal. Convenience function.
+proc S3::fail {thunk error errorInfo errorCode} {
+ S3::all_done $thunk $error $errorInfo $errorCode
+}
+
+# Internal. We're all done the transaction. Clean up everything,
+# potentially record errors, close channels, etc etc etc.
+proc S3::all_done {thunk {error ""} {errorInfo ""} {errorCode ""}} {
+ set s3 [dict get $thunk S3chan]
+ catch {
+ fileevent $s3 readable {}
+ fileevent $s3 writable {}
+ }
+ if {![dict exists $thunk orig S3chan]} {
+ catch {close $s3}
+ }
+ set res [dict get $thunk orig]
+ catch {
+ dict set res httpstatus [dict get $thunk httpstatus]
+ dict set res httpmessage [dict get $thunk httpmessage]
+ dict set res outheaders [dict get $thunk outheaders]
+ }
+ if {![dict exists $thunk orig outchan]} {
+ if {[dict exists $thunk outbody]} {
+ dict set res outbody [dict get $thunk outbody]
+ } else {
+ # Probably HTTP failure
+ dict set rest outbody {}
+ }
+ }
+ if {$error ne ""} {
+ dict set res error $error
+ dict set res errorInfo $errorInfo
+ dict set res errorCode $errorCode
+ }
+ if {![dict get $thunk blocking]} {
+ after 0 [list uplevel #0 \
+ [list set [dict get $thunk orig resultvar] $res]]
+ }
+ if {$error eq "" || ![dict get $thunk blocking] || \
+ ([dict exists $thunk orig throwsocket] && \
+ "return" == [dict get $thunk orig throwsocket])} {
+ return $res
+ } else {
+ error $error $errorInfo $errorCode
+ }
+}
+
+# Internal. Parse the lst and make sure it has only keys from the 'valid' list.
+# Used to parse arguments going into the higher-level functions.
+proc S3::parseargs1 {lst valid} {
+ if {[llength $lst] % 2 != 0} {
+ error "Option list must be even -name val pairs" \
+ "" [list S3 usage [lindex $lst end] $lst]
+ }
+ foreach {key val} $lst {
+ # Sadly, lsearch applies -glob to the wrong thing for our needs
+ set found 0
+ foreach v $valid {
+ if {[string match $v $key]} {set found 1 ; break}
+ }
+ if {!$found} {
+ error "Option list has invalid -key" \
+ "" [list S3 usage $key $lst]
+ }
+ }
+ return $lst ; # It seems OK
+}
+
+# Internal. Create a variable for higher-level functions to vwait.
+proc S3::bgvar {} {
+ variable bgvar_counter
+ incr bgvar_counter
+ set name ::S3::bgvar$bgvar_counter
+ return $name
+}
+
+# Internal. Given a request and the arguments, run the S3::REST in
+# the foreground or the background as appropriate. Also, do retries
+# for internal errors.
+proc S3::maybebackground {req myargs} {
+ variable config
+ global errorCode errorInfo
+ set mytries [expr {1+[dict get $config -retries]}]
+ set delay 2000
+ dict set req throwsocket return
+ while {1} {
+ if {![dict exists $myargs -blocking] || [dict get $myargs -blocking]} {
+ set dict [S3::REST $req]
+ } else {
+ set res [bgvar]
+ dict set req resultvar $res
+ S3::REST $req
+ vwait $res
+ set dict [set $res]
+ unset $res ; # clean up temps
+ }
+ if {[dict exists $dict error]} {
+ set code [dict get $dict errorCode]
+ if {"S3" != [lindex $code 0] || "socket" != [lindex $code 1]} {
+ error [dict get $dict error] \
+ [dict get $dict errorInfo] \
+ [dict get $dict errorCode]
+ }
+ }
+ incr mytries -1
+ incr delay $delay ; if {20000 < $delay} {set delay 20000}
+ if {"500" ne [dict get $dict httpstatus] || $mytries <= 0} {
+ return $dict
+ }
+ if {![dict exists $myargs -blocking] || [dict get $myargs -blocking]} {
+ after $delay
+ } else {
+ set timer [bgvar]
+ after $delay [list set $timer 1]
+ vwait $timer
+ unset $timer
+ }
+ }
+}
+
+# Internal. Maybe throw an HTTP error if httpstatus not in 200 range.
+proc S3::throwhttp {dict} {
+ set hs [dict get $dict httpstatus]
+ if {![string match "2??" $hs]} {
+ error "S3 received non-OK HTTP result of $hs" "" \
+ [list S3 remote $hs $dict]
+ }
+}
+
+# Public. Returns the list of buckets for this user.
+proc S3::ListAllMyBuckets {args} {
+ checkinit ; # I know this gets done later.
+ set myargs [S3::parseargs1 $args {-blocking -parse-xml -result-type}]
+ if {![dict exists $myargs -result-type]} {
+ dict set myargs -result-type names
+ }
+ if {![dict exists $myargs -blocking]} {
+ dict set myargs -blocking true
+ }
+ set restype [dict get $myargs -result-type]
+ if {$restype eq "REST" && [dict exists $myargs -parse-xml]} {
+ error "Do not use REST with -parse-xml" "" \
+ [list S3 usage -parse-xml $args]
+ }
+ if {![dict exists $myargs -parse-xml]} {
+ # We need to fetch the results.
+ set req [dict create verb GET resource /]
+ set dict [S3::maybebackground $req $myargs]
+ if {$restype eq "REST"} {
+ return $dict ; #we're done!
+ }
+ S3::throwhttp $dict ; #make sure it worked.
+ set xml [dict get $dict outbody]
+ } else {
+ set xml [dict get $myargs -parse-xml]
+ }
+ # Here, we either already returned the dict, or the XML is in "xml".
+ if {$restype eq "xml"} {return $xml}
+ if {[catch {set pxml [::xsxp::parse $xml]}]} {
+ error "S3 invalid XML structure" "" [list S3 usage xml $xml]
+ }
+ if {$restype eq "pxml"} {return $pxml}
+ if {$restype eq "dict" || $restype eq "names"} {
+ set buckets [::xsxp::fetch $pxml "Buckets" %CHILDREN]
+ set names {} ; set dates {}
+ foreach bucket $buckets {
+ lappend names [::xsxp::fetch $bucket "Name" %PCDATA]
+ lappend dates [::xsxp::fetch $bucket "CreationDate" %PCDATA]
+ }
+ if {$restype eq "names"} {
+ return $names
+ } else {
+ return [dict create \
+ Owner/ID [::xsxp::fetch $pxml "Owner/ID" %PCDATA] \
+ Owner/DisplayName \
+ [::xsxp::fetch $pxml "Owner/DisplayName" %PCDATA] \
+ Bucket/Name $names Bucket/Date $dates \
+ ]
+ }
+ }
+ if {$restype eq "owner"} {
+ return [list [::xsxp::fetch $pxml Owner/ID %PCDATA] \
+ [::xsxp::fetch $pxml Owner/DisplayName %PCDATA] ]
+ }
+ error "ListAllMyBuckets requires -result-type to be REST, xml, pxml, dict, owner, or names" "" [list S3 usage -result-type $args]
+}
+
+# Public. Create a bucket.
+proc S3::PutBucket {args} {
+ checkinit
+ set myargs [S3::parseargs1 $args {-blocking -bucket -acl}]
+ if {![dict exists $myargs -acl]} {
+ dict set myargs -acl [S3::Configure -default-acl]
+ }
+ if {![dict exists $myargs -bucket]} {
+ dict set myargs -bucket [S3::Configure -default-bucket]
+ }
+ dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
+ if {"" eq [dict exists $myargs -bucket]} {
+ error "PutBucket requires -bucket" "" [list S3 usage -bucket $args]
+ }
+
+ set req [dict create verb PUT resource /[dict get $myargs -bucket]]
+ if {[dict exists $myargs -acl]} {
+ dict set req headers [list x-amz-acl [dict get $myargs -acl]]
+ }
+ set dict [S3::maybebackground $req $myargs]
+ S3::throwhttp $dict
+ return "" ; # until we decide what to return.
+}
+
+# Public. Delete a bucket.
+proc S3::DeleteBucket {args} {
+ checkinit
+ set myargs [S3::parseargs1 $args {-blocking -bucket}]
+ if {![dict exists $myargs -bucket]} {
+ error "DeleteBucket requires -bucket" "" [list S3 usage -bucket $args]
+ }
+ dict set myargs -bucket [string trim [dict get $args -bucket] "/ "]
+
+ set req [dict create verb DELETE resource /[dict get $myargs -bucket]]
+ set dict [S3::maybebackground $req $myargs]
+ S3::throwhttp $dict
+ return "" ; # until we decide what to return.
+}
+
+# Internal. Suck out the one and only answer from the list, if needed.
+proc S3::firstif {list myargs} {
+ if {[dict exists $myargs -max-keys]} {
+ return [lindex $list 0]
+ } else {
+ return $list
+ }
+}
+
+# Public. Get the list of resources within a bucket.
+proc S3::GetBucket {args} {
+ checkinit
+ set myargs [S3::parseargs1 $args {
+ -bucket -blocking -parse-xml -max-keys
+ -result-type -prefix -delimiter
+ -TEST
+ }]
+ if {![dict exists $myargs -bucket]} {
+ dict set myargs -bucket [S3::Configure -default-bucket]
+ }
+ dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
+ if {"" eq [dict get $myargs -bucket]} {
+ error "GetBucket requires -bucket" "" [list S3 usage -bucket $args]
+ }
+ if {[dict get $myargs -bucket] eq ""} {
+ error "GetBucket requires -bucket nonempty" "" \
+ [list S3 usage -bucket $args]
+ }
+ if {![dict exists $myargs -result-type]} {
+ dict set myargs -result-type names
+ }
+ if {[dict get $myargs -result-type] eq "REST" && \
+ [dict exists $myargs "-parse-xml"]} {
+ error "GetBucket can't have -parse-xml with REST result" "" \
+ [list S3 usage -parse-xml $args]
+ }
+ set req [dict create verb GET resource /[dict get $myargs -bucket]]
+ set parameters {}
+ # Now, just to make test cases easier...
+ if {[dict exists $myargs -TEST]} {
+ dict set parameters max-keys [dict get $myargs -TEST]
+ }
+ # Back to your regularly scheduled argument parsing
+ if {[dict exists $myargs -max-keys]} {
+ dict set parameters max-keys [dict get $myargs -max-keys]
+ }
+ if {[dict exists $myargs -prefix]} {
+ set p [dict get $myargs -prefix]
+ if {[string match "/*" $p]} {
+ set p [string range $p 1 end]
+ }
+ dict set parameters prefix $p
+ }
+ if {[dict exists $myargs -delimiter]} {
+ dict set parameters delimiter [dict get $myargs -delimiter]
+ }
+ set nextmarker0 {} ; # We use this for -result-type dict.
+ if {![dict exists $myargs -parse-xml]} {
+ # Go fetch answers.
+ # Current xaction in "0" vars, with accumulation in "L" vars.
+ # Ultimate result of this loop is $RESTL, a list of REST results.
+ set RESTL [list]
+ while {1} {
+ set req0 $req ; dict set req0 parameters $parameters
+ set REST0 [S3::maybebackground $req0 $myargs]
+ S3::throwhttp $REST0
+ lappend RESTL $REST0
+ if {[dict exists $myargs -max-keys]} {
+ # We were given a limit, so just return the answer.
+ break
+ }
+ set pxml0 [::xsxp::parse [dict get $REST0 outbody]]
+ set trunc0 [expr "true" eq \
+ [::xsxp::fetch $pxml0 IsTruncated %PCDATA]]
+ if {!$trunc0} {
+ # We've retrieved the final block, so go parse it.
+ set nextmarker0 "" ; # For later.
+ break
+ }
+ # Find the highest contents entry. (Would have been
+ # easier if Amazon always supplied NextMarker.)
+ set nextmarker0 {}
+ foreach {only tag} {Contents Key CommonPrefixes Prefix} {
+ set only0 [::xsxp::only $pxml0 $only]
+ if {0 < [llength $only0]} {
+ set k0 [::xsxp::fetch [lindex $only0 end] $tag %PCDATA]
+ if {[string compare $nextmarker0 $k0] < 0} {
+ set nextmarker0 $k0
+ }
+ }
+ }
+ if {$nextmarker0 eq ""} {error "Internal Error in S3 library"}
+ # Here we have the next marker, so fetch the next REST
+ dict set parameters marker $nextmarker0
+ # Note - $nextmarker0 is used way down below again!
+ }
+ # OK, at this point, the caller did not provide the xml via -parse-xml
+ # And now we have a list of REST results. So let's process.
+ if {[dict get $myargs -result-type] eq "REST"} {
+ return [S3::firstif $RESTL $myargs]
+ }
+ set xmlL [list]
+ foreach entry $RESTL {
+ lappend xmlL [dict get $entry outbody]
+ }
+ unset RESTL ; # just to save memory
+ } else {
+ # Well, we've parsed out the XML from the REST,
+ # so we're ready for -parse-xml
+ set xmlL [list [dict get $myargs -parse-xml]]
+ }
+ if {[dict get $myargs -result-type] eq "xml"} {
+ return [S3::firstif $xmlL $myargs]
+ }
+ set pxmlL [list]
+ foreach xml $xmlL {
+ lappend pxmlL [::xsxp::parse $xml]
+ }
+ unset xmlL
+ if {[dict get $myargs -result-type] eq "pxml"} {
+ return [S3::firstif $pxmlL $myargs]
+ }
+ # Here, for result types of "names" and "dict",
+ # we need to actually parse out all the results.
+ if {[dict get $myargs -result-type] eq "names"} {
+ # The easy one.
+ set names [list]
+ foreach pxml $pxmlL {
+ set con0 [::xsxp::only $pxml Contents]
+ set con1 [::xsxp::only $pxml CommonPrefixes]
+ lappend names {*}[concat [::xsxp::fetchall $con0 Key %PCDATA] \
+ [::xsxp::fetchall $con1 Prefix %PCDATA]]
+ }
+ return [lsort $names]
+ } elseif {[dict get $myargs -result-type] eq "dict"} {
+ # The harder one.
+ set last0 [lindex $pxmlL end]
+ set res [dict create]
+ foreach thing {Name Prefix Marker MaxKeys IsTruncated} {
+ dict set res $thing [::xsxp::fetch $last0 $thing %PCDATA?]
+ }
+ dict set res NextMarker $nextmarker0 ; # From way up above.
+ set Prefix [list]
+ set names {Key LastModified ETag Size Owner/ID Owner/DisplayName StorageClass}
+ foreach name $names {set $name [list]}
+ foreach pxml $pxmlL {
+ foreach tag [::xsxp::only $pxml CommonPrefixes] {
+ lappend Prefix [::xsxp::fetch $tag Prefix %PCDATA]
+ }
+ foreach tag [::xsxp::only $pxml Contents] {
+ foreach name $names {
+ lappend $name [::xsxp::fetch $tag $name %PCDATA]
+ }
+ }
+ }
+ dict set res CommonPrefixes/Prefix $Prefix
+ foreach name $names {dict set res $name [set $name]}
+ return $res
+ } else {
+ # The hardest one ;-)
+ error "GetBucket Invalid result type, must be REST, xml, pxml, names, or dict" "" [list S3 usage -result-type $args]
+ }
+}
+
+# Internal. Compare a resource to a file.
+# Returns 1 if they're different, 0 if they're the same.
+# Note that using If-Modified-Since and/or If-Match,If-None-Match
+# might wind up being more efficient than pulling the head
+# and checking. However, this allows for slop, checking both
+# the etag and the date, only generating local etag if the
+# date and length indicate they're the same, and so on.
+# Direction is G or P for Get or Put.
+# Assumes the source always exists. Obviously, Get and Put will throw if not,
+# but not because of this.
+proc S3::compare {myargs direction} {
+ variable config
+ global errorInfo
+ set compare [dict get $myargs -compare]
+ if {$compare ni {always never exists missing newer date checksum different}} {
+ error "-compare must be always, never, exists, missing, newer, date, checksum, or different" "" \
+ [list S3 usage -compare $myargs]
+ }
+ if {"never" eq $compare} {return 0}
+ if {"always" eq $compare} {return 1}
+ if {[dict exists $myargs -file] && [file exists [dict get $myargs -file]]} {
+ set local_exists 1
+ } else {
+ set local_exists 0
+ }
+ # Avoid hitting S3 if we don't need to.
+ if {$direction eq "G" && "exists" eq $compare} {return $local_exists}
+ if {$direction eq "G" && "missing" eq $compare} {
+ return [expr !$local_exists]
+ }
+ # We need to get the headers from the resource.
+ set req [dict create \
+ resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \
+ verb HEAD ]
+ set res [S3::maybebackground $req $myargs]
+ set httpstatus [dict get $res httpstatus]
+ if {"404" eq $httpstatus} {
+ set remote_exists 0
+ } elseif {[string match "2??" $httpstatus]} {
+ set remote_exists 1
+ } else {
+ error "S3: Neither 404 or 2xx on conditional compare" "" \
+ [list S3 remote $httpstatus $res]
+ }
+ if {$direction eq "P"} {
+ if {"exists" eq $compare} {return $remote_exists}
+ if {"missing" eq $compare} {return [expr {!$remote_exists}]}
+ if {!$remote_exists} {return 1}
+ } elseif {$direction eq "G"} {
+ # Actually already handled above, but it never hurts...
+ if {"exists" eq $compare} {return $local_exists}
+ if {"missing" eq $compare} {return [expr {!$local_exists}]}
+ }
+ set outheaders [dict get $res outheaders]
+ if {[dict exists $outheaders content-length]} {
+ set remote_length [dict get $outheaders content-length]
+ } else {
+ set remote_length -1
+ }
+ if {[dict exists $outheaders etag]} {
+ set remote_etag [string tolower \
+ [string trim [dict get $outheaders etag] \"]]
+ } else {
+ set remote_etag "YYY"
+ }
+ if {[dict exists $outheaders last-modified]} {
+ set remote_date [clock scan [dict get $outheaders last-modified]]
+ } else {
+ set remote_date -1
+ }
+ if {[dict exists $myargs -content]} {
+ # Probably should work this out better...
+ #set local_length [string length [encoding convert-to utf-8 \
+ #[dict get $myargs -content]]]
+ set local_length [string length [dict get $myargs -content]]
+ } elseif {$local_exists} {
+ if {[catch {file size [dict get $myargs -file]} local_length]} {
+ error "S3: Couldn't stat [dict get $myargs -file]" "" \
+ [list S3 local $errorInfo]
+ }
+ } else {
+ set local_length -2
+ }
+ if {[dict exists $myargs -content]} {
+ set local_date [clock seconds]
+ } elseif {$local_exists} {
+ set local_date [file mtime [dict get $myargs -file]]
+ # Shouldn't throw, since [file size] worked.
+ } else {
+ set local_date -2
+ }
+ if {$direction eq "P"} {
+ if {"newer" eq $compare} {
+ if {$remote_date < $local_date - [dict get $config -slop-seconds]} {
+ return 1 ; # Yes, local is newer
+ } else {
+ return 0 ; # Older, or the same
+ }
+ }
+ } elseif {$direction eq "G"} {
+ if {"newer" eq $compare} {
+ if {$local_date < $remote_date - [dict get $config -slop-seconds]} {
+ return 1 ; # Yes, remote is later.
+ } else {
+ return 0 ; # Local is older or same.
+ }
+ }
+ }
+ if {[dict get $config -slop-seconds] <= abs($local_date - $remote_date)} {
+ set date_diff 1 ; # Difference is greater
+ } else {
+ set date_diff 0 ; # Difference negligible
+ }
+ if {"date" eq $compare} {return $date_diff}
+ if {"different" eq $compare && [dict exists $myargs -file] && $date_diff} {
+ return 1
+ }
+ # Date's the same, but we're also interested in content, so check the rest
+ # Only others to handle are checksum and different-with-matching-dates
+ if {$local_length != $remote_length} {return 1} ; #easy quick case
+ if {[dict exists $myargs -file] && $local_exists} {
+ if {[catch {
+ # Maybe deal with making this backgroundable too?
+ set local_etag [string tolower \
+ [::md5::md5 -hex -filename [dict get $myargs -file]]]
+ } caught]} {
+ # Maybe you can stat but not read it?
+ error "S3 could not hash file" "" \
+ [list S3 local [dict get $myargs -file] $errorInfo]
+ }
+ } elseif {[dict exists $myargs -content]} {
+ set local_etag [string tolower \
+ [string tolower [::md5::md5 -hex [dict get $myargs -content]]]]
+ } else {
+ set local_etag "XXX"
+ }
+ # puts "local: $local_etag\nremote: $remote_etag"
+ if {$local_etag eq $remote_etag} {return 0} {return 1}
+}
+
+# Internal. Calculates the ACL based on file permissions.
+proc S3::calcacl {myargs} {
+ # How would one work this under Windows, then?
+ # Silly way: invoke [exec cacls $filename],
+ # parse the result looking for Everyone:F or Everyone:R
+ # Messy security if someone replaces the cacls.exe or something.
+ error "S3 Not Yet Implemented" "" [list S3 notyet calcacl $myargs]
+ set result [S3::Configure -default-acl]
+ catch {
+ set chmod [file attributes [dict get $myargs -file] -permissions]
+ set chmod [expr {$chmod & 6}]
+ if {$chmod == 0} {set result private}
+ if {$chmod == 2} {set result public-write}
+ if {$chmod == 6} {set result public-read-write}
+ }
+}
+
+# Public. Put a resource into a bucket.
+proc S3::Put {args} {
+ checkinit
+ set myargs [S3::parseargs1 $args {
+ -bucket -blocking -file -content -resource -acl
+ -content-type -x-amz-meta-* -compare
+ }]
+ if {![dict exists $myargs -bucket]} {
+ dict set myargs -bucket [S3::Configure -default-bucket]
+ }
+ dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
+ if {"" eq [dict get $myargs -bucket]} {
+ error "Put requires -bucket" "" [list S3 usage -bucket $args]
+ }
+ if {![dict exists $myargs -blocking]} {
+ dict set myargs -blocking true
+ }
+ if {![dict exists $myargs -file] && ![dict exists $myargs -content]} {
+ error "Put requires -file or -content" "" [list S3 usage -file $args]
+ }
+ if {[dict exists $myargs -file] && [dict exists $myargs -content]} {
+ error "Put says -file, -content mutually exclusive" "" [list S3 usage -file $args]
+ }
+ if {![dict exists $myargs -resource]} {
+ error "Put requires -resource" "" [list S3 usage -resource $args]
+ }
+ if {![dict exists $myargs -compare]} {
+ dict set myargs -compare [S3::Configure -default-compare]
+ }
+ if {![dict exists $myargs -acl] && "" ne [S3::Configure -default-acl]} {
+ dict set myargs -acl [S3::Configure -default-acl]
+ }
+ if {[dict exists $myargs -file] && \
+ "never" ne [dict get $myargs -compare] && \
+ ![file exists [dict get $myargs -file]]} {
+ error "Put -file doesn't exist: [dict get $myargs -file]" \
+ "" [list S3 usage -file $args]
+ }
+ # Clean up bucket, and take one leading slash (if any) off resource.
+ if {[string match "/*" [dict get $myargs -resource]]} {
+ dict set myargs -resource \
+ [string range [dict get $myargs -resource] 1 end]
+ }
+ # See if we need to copy it.
+ set comp [S3::compare $myargs P]
+ if {!$comp} {return 0} ; # skip it, then.
+
+ # Oookeydookey. At this point, we're actually going to send
+ # the file, so all we need to do is build the request array.
+ set req [dict create verb PUT \
+ resource /[dict get $myargs -bucket]/[dict get $myargs -resource]]
+ if {[dict exists $myargs -file]} {
+ dict set req infile [dict get $myargs -file]
+ } else {
+ dict set req inbody [dict get $myargs -content]
+ }
+ if {[dict exists $myargs -content-type]} {
+ dict set req content-type [dict get $myargs -content-type]
+ }
+ set headers {}
+ foreach xhead [dict keys $myargs -x-amz-meta-*] {
+ dict set headers [string range $xhead 1 end] [dict get $myargs $xhead]
+ }
+ set xmlacl "" ; # For calc and keep
+ if {[dict exists $myargs -acl]} {
+ if {[dict get $myargs -acl] eq "calc"} {
+ # We could make this more complicated by
+ # assigning it to xmlacl after building it.
+ dict set myargs -acl [S3::calcacl $myargs]
+ } elseif {[dict get $myargs -acl] eq "keep"} {
+ dict set myargs -acl [S3::Configure -default-acl]
+ catch {
+ set xmlacl [S3::GetAcl \
+ -bucket [dict get $myargs -bucket] \
+ -resource [dict get $myargs -resource] \
+ -blocking [dict get $myargs -blocking] \
+ -result-type xml]
+ }
+ }
+ dict set headers x-amz-acl [dict get $myargs -acl]
+ }
+ dict set req headers $headers
+ # That should do it.
+ set res [S3::maybebackground $req $myargs]
+ S3::throwhttp $res
+ if {"<" == [string index $xmlacl 0]} {
+ # Set the saved ACL back on the new object
+ S3::PutAcl \
+ -bucket [dict get $myargs -bucket] \
+ -resource [dict get $myargs -resource] \
+ -blocking [dict get $myargs -blocking] \
+ -acl $xmlacl
+ }
+ return 1 ; # Yep, we copied it!
+}
+
+# Public. Get a resource from a bucket.
+proc S3::Get {args} {
+ global errorCode
+ checkinit
+ set myargs [S3::parseargs1 $args {
+ -bucket -blocking -file -content -resource -timestamp
+ -headers -compare
+ }]
+ if {![dict exists $myargs -bucket]} {
+ dict set myargs -bucket [S3::Configure -default-bucket]
+ }
+ dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
+ if {"" eq [dict get $myargs -bucket]} {
+ error "Get requires -bucket" "" [list S3 usage -bucket $args]
+ }
+ if {![dict exists $myargs -file] && ![dict exists $myargs -content]} {
+ error "Get requires -file or -content" "" [list S3 usage -file $args]
+ }
+ if {[dict exists $myargs -file] && [dict exists $myargs -content]} {
+ error "Get says -file, -content mutually exclusive" "" [list S3 usage -file $args]
+ }
+ if {![dict exists $myargs -resource]} {
+ error "Get requires -resource" "" [list S3 usage -resource $args]
+ }
+ if {![dict exists $myargs -compare]} {
+ dict set myargs -compare [S3::Configure -default-compare]
+ }
+ # Clean up bucket, and take one leading slash (if any) off resource.
+ if {[string match "/*" [dict get $myargs -resource]]} {
+ dict set myargs -resource \
+ [string range [dict get $myargs -resource] 1 end]
+ }
+ # See if we need to copy it.
+ if {"never" eq [dict get $myargs -compare]} {return 0}
+ if {[dict exists $myargs -content]} {
+ set comp 1
+ } else {
+ set comp [S3::compare $myargs G]
+ }
+ if {!$comp} {return 0} ; # skip it, then.
+
+ # Oookeydookey. At this point, we're actually going to fetch
+ # the file, so all we need to do is build the request array.
+ set req [dict create verb GET \
+ resource /[dict get $myargs -bucket]/[dict get $myargs -resource]]
+ if {[dict exists $myargs -file]} {
+ set pre_exists [file exists [dict get $myargs -file]]
+ if {[catch {
+ set x [open [dict get $myargs -file] w]
+ fconfigure $x -translation binary -encoding binary
+ } caught]} {
+ error "Get could not create file [dict get $myargs -file]" "" \
+ [list S3 local -file $errorCode]
+ }
+ dict set req outchan $x
+ }
+ # That should do it.
+ set res [S3::maybebackground $req $myargs]
+ if {[dict exists $req outchan]} {
+ catch {close [dict get $req outchan]}
+ if {![string match "2??" [dict get $res httpstatus]] && !$pre_exists} {
+ catch {file delete -force -- [dict get $myargs -file]}
+ }
+ }
+ S3::throwhttp $res
+ if {[dict exists $myargs -headers]} {
+ uplevel 1 \
+ [list set [dict get $myargs -headers] [dict get $res outheaders]]
+ }
+ if {[dict exists $myargs -content]} {
+ uplevel 1 \
+ [list set [dict get $myargs -content] [dict get $res outbody]]
+ }
+ if {[dict exists $myargs -timestamp] && [dict exists $myargs -file]} {
+ if {"aws" eq [dict get $myargs -timestamp]} {
+ catch {
+ set t [dict get $res outheaders last-modified]
+ set t [clock scan $t -gmt true]
+ file mtime [dict get $myargs -file] $t
+ }
+ }
+ }
+ return 1 ; # Yep, we copied it!
+}
+
+# Public. Get information about a resource in a bucket.
+proc S3::Head {args} {
+ global errorCode
+ checkinit
+ set myargs [S3::parseargs1 $args {
+ -bucket -blocking -resource -headers -dict -status
+ }]
+ if {![dict exists $myargs -bucket]} {
+ dict set myargs -bucket [S3::Configure -default-bucket]
+ }
+ dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
+ if {"" eq [dict get $myargs -bucket]} {
+ error "Head requires -bucket" "" [list S3 usage -bucket $args]
+ }
+ if {![dict exists $myargs -resource]} {
+ error "Head requires -resource" "" [list S3 usage -resource $args]
+ }
+ # Clean up bucket, and take one leading slash (if any) off resource.
+ if {[string match "/*" [dict get $myargs -resource]]} {
+ dict set myargs -resource \
+ [string range [dict get $myargs -resource] 1 end]
+ }
+ set req [dict create verb HEAD \
+ resource /[dict get $myargs -bucket]/[dict get $myargs -resource]]
+ set res [S3::maybebackground $req $myargs]
+ if {[dict exists $myargs -dict]} {
+ uplevel 1 \
+ [list set [dict get $myargs -dict] $res]
+ }
+ if {[dict exists $myargs -headers]} {
+ uplevel 1 \
+ [list set [dict get $myargs -headers] [dict get $res outheaders]]
+ }
+ if {[dict exists $myargs -status]} {
+ set x [list [dict get $res httpstatus] [dict get $res httpmessage]]
+ uplevel 1 \
+ [list set [dict get $myargs -status] $x]
+ }
+ return [string match "2??" [dict get $res httpstatus]]
+}
+
+# Public. Get the full ACL from an object and parse it into something useful.
+proc S3::GetAcl {args} {
+ global errorCode
+ checkinit
+ set myargs [S3::parseargs1 $args {
+ -bucket -blocking -resource -result-type -parse-xml
+ }]
+ if {![dict exists $myargs -bucket]} {
+ dict set myargs -bucket [S3::Configure -default-bucket]
+ }
+ dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
+ if {![dict exists $myargs -result-type]} {
+ dict set myargs -result-type "dict"
+ }
+ set restype [dict get $myargs -result-type]
+ if {$restype eq "REST" && [dict exists $myargs -parse-xml]} {
+ error "Do not use REST with -parse-xml" "" \
+ [list S3 usage -parse-xml $args]
+ }
+ if {![dict exists $myargs -parse-xml]} {
+ # We need to fetch the results.
+ if {"" eq [dict get $myargs -bucket]} {
+ error "GetAcl requires -bucket" "" [list S3 usage -bucket $args]
+ }
+ if {![dict exists $myargs -resource]} {
+ error "GetAcl requires -resource" "" [list S3 usage -resource $args]
+ }
+ # Clean up bucket, and take one leading slash (if any) off resource.
+ if {[string match "/*" [dict get $myargs -resource]]} {
+ dict set myargs -resource \
+ [string range [dict get $myargs -resource] 1 end]
+ }
+ set req [dict create verb GET \
+ resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \
+ rtype acl]
+ set dict [S3::maybebackground $req $myargs]
+ if {$restype eq "REST"} {
+ return $dict ; #we're done!
+ }
+ S3::throwhttp $dict ; #make sure it worked.
+ set xml [dict get $dict outbody]
+ } else {
+ set xml [dict get $myargs -parse-xml]
+ }
+ if {[dict get $myargs -result-type] == "xml"} {
+ return $xml
+ }
+ set pxml [xsxp::parse $xml]
+ if {[dict get $myargs -result-type] == "pxml"} {
+ return $pxml
+ }
+ if {[dict get $myargs -result-type] == "dict"} {
+ array set resdict {}
+ set owner [xsxp::fetch $pxml Owner/ID %PCDATA]
+ set grants [xsxp::fetch $pxml AccessControlList %CHILDREN]
+ foreach grant $grants {
+ set perm [xsxp::fetch $grant Permission %PCDATA]
+ set id ""
+ catch {set id [xsxp::fetch $grant Grantee/ID %PCDATA]}
+ if {$id == ""} {
+ set id [xsxp::fetch $grant Grantee/URI %PCDATA]
+ }
+ lappend resdict($perm) $id
+ }
+ return [dict create owner $owner acl [array get resdict]]
+ }
+ error "GetAcl requires -result-type to be REST, xml, pxml or dict" "" [list S3 usage -result-type $args]
+}
+
+# Make one Grant thingie
+proc S3::engrant {who what} {
+ if {$who == "AuthenticatedUsers" || $who == "AllUsers"} {
+ set who http://acs.amazonaws.com/groups/global/$who
+ }
+ if {-1 != [string first "//" $who]} {
+ set type Group ; set tag URI
+ } elseif {-1 != [string first "@" $who]} {
+ set type AmazonCustomerByEmail ; set tag EmailAddress
+ } else {
+ set type CanonicalUser ; set tag ID
+ }
+ set who [string map {< &lt; > &gt; & &amp;} $who]
+ set what [string toupper $what]
+ set xml "<Grant><Grantee xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" xsi:type=\"$type\"><$tag>$who</$tag></Grantee>"
+ append xml "<Permission>$what</Permission></Grant>"
+ return $xml
+}
+
+# Make the owner header
+proc S3::enowner {owner} {
+ return "<AccessControlPolicy xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"><Owner><ID>$owner</ID></Owner><AccessControlList>"
+ return "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<AccessControlPolicy xmlns=\"http://s3.amazonaws.com/doc/2006-03-01/\"><Owner><ID>$owner</ID></Owner><AccessControlList>"
+}
+
+proc S3::endacl {} {
+ return "</AccessControlList></AccessControlPolicy>\n"
+}
+
+# Public. Set the ACL on an existing object.
+proc S3::PutAcl {args} {
+ global errorCode
+ checkinit
+ set myargs [S3::parseargs1 $args {
+ -bucket -blocking -resource -acl -owner
+ }]
+ if {![dict exists $myargs -bucket]} {
+ dict set myargs -bucket [S3::Configure -default-bucket]
+ }
+ dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
+ if {"" eq [dict get $myargs -bucket]} {
+ error "PutAcl requires -bucket" "" [list S3 usage -bucket $args]
+ }
+ if {![dict exists $myargs -resource]} {
+ error "PutAcl requires -resource" "" [list S3 usage -resource $args]
+ }
+ if {![dict exists $myargs -acl]} {
+ dict set myargs -acl [S3::Configure -default-acl]
+ }
+ dict set myargs -acl [string trim [dict get $myargs -acl]]
+ if {[dict get $myargs -acl] == ""} {
+ dict set myargs -acl [S3::Configure -default-acl]
+ }
+ if {[dict get $myargs -acl] == ""} {
+ error "PutAcl requires -acl" "" [list D3 usage -resource $args]
+ }
+ # Clean up bucket, and take one leading slash (if any) off resource.
+ if {[string match "/*" [dict get $myargs -resource]]} {
+ dict set myargs -resource \
+ [string range [dict get $myargs -resource] 1 end]
+ }
+ # Now, figure out the XML to send.
+ set acl [dict get $myargs -acl]
+ set owner ""
+ if {"<" != [string index $acl 0] && ![dict exists $myargs -owner]} {
+ # Grab the owner off the resource
+ set req [dict create verb GET \
+ resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \
+ rtype acl]
+ set dict [S3::maybebackground $req $myargs]
+ S3::throwhttp $dict ; #make sure it worked.
+ set xml [dict get $dict outbody]
+ set pxml [xsxp::parse $xml]
+ set owner [xsxp::fetch $pxml Owner/ID %PCDATA]
+ }
+ if {[dict exists $myargs -owner]} {
+ set owner [dict get $myargs -owner]
+ }
+ set xml [enowner $owner]
+ if {"" == $acl || "private" == $acl} {
+ append xml [engrant $owner FULL_CONTROL]
+ append xml [endacl]
+ } elseif {"public-read" == $acl} {
+ append xml [engrant $owner FULL_CONTROL]
+ append xml [engrant AllUsers READ]
+ append xml [endacl]
+ } elseif {"public-read-write" == $acl} {
+ append xml [engrant $owner FULL_CONTROL]
+ append xml [engrant AllUsers READ]
+ append xml [engrant AllUsers WRITE]
+ append xml [endacl]
+ } elseif {"authenticated-read" == $acl} {
+ append xml [engrant $owner FULL_CONTROL]
+ append xml [engrant AuthenticatedUsers READ]
+ append xml [endacl]
+ } elseif {"<" == [string index $acl 0]} {
+ set xml $acl
+ } elseif {[llength $acl] % 2 != 0} {
+ error "S3::PutAcl -acl must be xml, private, public-read, public-read-write, authenticated-read, or a dictionary" \
+ "" [list S3 usage -acl $acl]
+ } else {
+ # ACL in permission/ID-list format.
+ if {[dict exists $acl owner] && [dict exists $acl acl]} {
+ set xml [S3::enowner [dict get $acl owner]]
+ set acl [dict get $acl acl]
+ }
+ foreach perm {FULL_CONTROL READ READ_ACP WRITE WRITE_ACP} {
+ if {[dict exists $acl $perm]} {
+ foreach id [dict get $acl $perm] {
+ append xml [engrant $id $perm]
+ }
+ }
+ }
+ append xml [endacl]
+ }
+ set req [dict create verb PUT \
+ resource /[dict get $myargs -bucket]/[dict get $myargs -resource] \
+ inbody $xml \
+ rtype acl]
+ set res [S3::maybebackground $req $myargs]
+ S3::throwhttp $res ; #make sure it worked.
+ return $xml
+}
+
+# Public. Delete a resource from a bucket.
+proc S3::Delete {args} {
+ global errorCode
+ checkinit
+ set myargs [S3::parseargs1 $args {
+ -bucket -blocking -resource -status
+ }]
+ if {![dict exists $myargs -bucket]} {
+ dict set myargs -bucket [S3::Configure -default-bucket]
+ }
+ dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
+ if {"" eq [dict get $myargs -bucket]} {
+ error "Delete requires -bucket" "" [list S3 usage -bucket $args]
+ }
+ if {![dict exists $myargs -resource]} {
+ error "Delete requires -resource" "" [list S3 usage -resource $args]
+ }
+ # Clean up bucket, and take one leading slash (if any) off resource.
+ if {[string match "/*" [dict get $myargs -resource]]} {
+ dict set myargs -resource \
+ [string range [dict get $myargs -resource] 1 end]
+ }
+ set req [dict create verb DELETE \
+ resource /[dict get $myargs -bucket]/[dict get $myargs -resource]]
+ set res [S3::maybebackground $req $myargs]
+ if {[dict exists $myargs -status]} {
+ set x [list [dict get $res httpstatus] [dict get $res httpmessage]]
+ uplevel 1 \
+ [list set [dict get $myargs -status] $x]
+ }
+ return [string match "2??" [dict get $res httpstatus]]
+}
+
+# Some helper routines for Push, Pull, and Sync
+
+# Internal. Filter for fileutil::find.
+proc S3::findfilter {dirs name} {
+ # In particular, skip links, devices, etc.
+ if {$dirs} {
+ return [expr {[file isdirectory $name] || [file isfile $name]}]
+ } else {
+ return [file isfile $name]
+ }
+}
+
+# Internal. Get list of local files, appropriately trimmed.
+proc S3::getLocal {root dirs} {
+ # Thanks to Michael Cleverly for this first line...
+ set base [file normalize [file join [pwd] $root]]
+ if {![string match "*/" $base]} {
+ set base $base/
+ }
+ set files {} ; set bl [string length $base]
+ foreach file [fileutil::find $base [list S3::findfilter $dirs]] {
+ if {[file isdirectory $file]} {
+ lappend files [string range $file $bl end]/
+ } else {
+ lappend files [string range $file $bl end]
+ }
+ }
+ set files [lsort $files]
+ # At this point, $files is a sorted list of all the local files,
+ # with a trailing / on any directories included in the list.
+ return $files
+}
+
+# Internal. Get list of remote resources, appropriately trimmed.
+proc S3::getRemote {bucket prefix blocking} {
+ set prefix [string trim $prefix " /"]
+ if {0 != [string length $prefix]} {append prefix /}
+ set res [S3::GetBucket -bucket $bucket -prefix $prefix \
+ -result-type names -blocking $blocking]
+ set names {} ; set pl [string length $prefix]
+ foreach name $res {
+ lappend names [string range $name $pl end]
+ }
+ return [lsort $names]
+}
+
+# Internal. Create any directories we need to put the file in place.
+proc S3::makeDirs {directory suffix} {
+ set sofar {}
+ set nodes [split $suffix /]
+ set nodes [lrange $nodes 0 end-1]
+ foreach node $nodes {
+ lappend sofar $node
+ set tocheck [file join $directory {*}$sofar]
+ if {![file exists $tocheck]} {
+ catch {file mkdir $tocheck}
+ }
+ }
+}
+
+# Internal. Default progress monitor for push, pull, toss.
+proc S3::ignore {args} {} ; # default progress monitor
+
+# Internal. For development and testing. Progress monitor.
+proc S3::printargs {args} {puts $args} ; # For testing.
+
+# Public. Send a local directory tree to S3.
+proc S3::Push {args} {
+ uplevel #0 package require fileutil
+ global errorCode errorInfo
+ checkinit
+ set myargs [S3::parseargs1 $args {
+ -bucket -blocking -prefix -directory
+ -compare -x-amz-meta-* -acl -delete -error -progress
+ }]
+ if {![dict exists $myargs -bucket]} {
+ dict set myargs -bucket [S3::Configure -default-bucket]
+ }
+ dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
+ if {"" eq [dict get $myargs -bucket]} {
+ error "Push requires -bucket" "" [list S3 usage -bucket $args]
+ }
+ if {![dict exists $myargs -directory]} {
+ error "Push requires -directory" "" [list S3 usage -directory $args]
+ }
+ # Set default values.
+ set defaults "
+ -acl \"[S3::Configure -default-acl]\"
+ -compare [S3::Configure -default-compare]
+ -prefix {} -delete 0 -error continue -progress ::S3::ignore -blocking 1"
+ foreach {key val} $defaults {
+ if {![dict exists $myargs $key]} {dict set myargs $key $val}
+ }
+ # Pull out arguments for convenience
+ foreach i {progress prefix directory bucket blocking} {
+ set $i [dict get $myargs -$i]
+ }
+ set prefix [string trimright $prefix /]
+ set meta [dict filter $myargs key x-amz-meta-*]
+ # We're readdy to roll here.
+ uplevel 1 [list {*}$progress args $myargs]
+ if {[catch {
+ set local [S3::getLocal $directory 0]
+ } caught]} {
+ error "Push could not walk local directory - $caught" \
+ $errorInfo $errorCode
+ }
+ uplevel 1 [list {*}$progress local $local]
+ if {[catch {
+ set remote [S3::getRemote $bucket $prefix $blocking]
+ } caught]} {
+ error "Push could not walk remote directory - $caught" \
+ $errorInfo $errorCode
+ }
+ uplevel 1 [list {*}$progress remote $remote]
+ set result [dict create]
+ set result0 [dict create \
+ filescopied 0 bytescopied 0 compareskipped 0 \
+ errorskipped 0 filesdeleted 0 filesnotdeleted 0]
+ foreach suffix $local {
+ uplevel 1 [list {*}$progress copy $suffix start]
+ set err [catch {
+ S3::Put -bucket $bucket -blocking $blocking \
+ -file [file join $directory $suffix] \
+ -resource $prefix/$suffix \
+ -acl [dict get $myargs -acl] \
+ {*}$meta \
+ -compare [dict get $myargs -compare]} caught]
+ if {$err} {
+ uplevel 1 [list {*}$progress copy $suffix $errorCode]
+ dict incr result0 errorskipped
+ dict set result $suffix $errorCode
+ if {[dict get $myargs -error] eq "throw"} {
+ error "Push failed to Put - $caught" $errorInfo $errorCode
+ } elseif {[dict get $myargs -error] eq "break"} {
+ break
+ }
+ } else {
+ if {$caught} {
+ uplevel 1 [list {*}$progress copy $suffix copied]
+ dict incr result0 filescopied
+ dict incr result0 bytescopied \
+ [file size [file join $directory $suffix]]
+ dict set result $suffix copied
+ } else {
+ uplevel 1 [list {*}$progress copy $suffix skipped]
+ dict incr result0 compareskipped
+ dict set result $suffix skipped
+ }
+ }
+ }
+ # Now do deletes, if so desired
+ if {[dict get $myargs -delete]} {
+ foreach suffix $remote {
+ if {$suffix ni $local} {
+ set err [catch {
+ S3::Delete -bucket $bucket -blocking $blocking \
+ -resource $prefix/$suffix } caught]
+ if {$err} {
+ uplevel 1 [list {*}$progress delete $suffix $errorCode]
+ dict incr result0 filesnotdeleted
+ dict set result $suffix notdeleted
+ } else {
+ uplevel 1 [list {*}$progress delete $suffix {}]
+ dict incr result0 filesdeleted
+ dict set result $suffix deleted
+ }
+ }
+ }
+ }
+ dict set result {} $result0
+ uplevel 1 [list {*}$progress finished $result]
+ return $result
+}
+
+# Public. Fetch a portion of a remote bucket into a local directory tree.
+proc S3::Pull {args} {
+ # This is waaaay to similar to Push for comfort.
+ # Fold it up later.
+ uplevel #0 package require fileutil
+ global errorCode errorInfo
+ checkinit
+ set myargs [S3::parseargs1 $args {
+ -bucket -blocking -prefix -directory
+ -compare -timestamp -delete -error -progress
+ }]
+ if {![dict exists $myargs -bucket]} {
+ dict set myargs -bucket [S3::Configure -default-bucket]
+ }
+ dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
+ if {"" eq [dict get $myargs -bucket]} {
+ error "Pull requires -bucket" "" [list S3 usage -bucket $args]
+ }
+ if {![dict exists $myargs -directory]} {
+ error "Pull requires -directory" "" [list S3 usage -directory $args]
+ }
+ # Set default values.
+ set defaults "
+ -timestamp now
+ -compare [S3::Configure -default-compare]
+ -prefix {} -delete 0 -error continue -progress ::S3::ignore -blocking 1"
+ foreach {key val} $defaults {
+ if {![dict exists $myargs $key]} {dict set myargs $key $val}
+ }
+ # Pull out arguments for convenience
+ foreach i {progress prefix directory bucket blocking} {
+ set $i [dict get $myargs -$i]
+ }
+ set prefix [string trimright $prefix /]
+ # We're readdy to roll here.
+ uplevel 1 [list {*}$progress args $myargs]
+ if {[catch {
+ set local [S3::getLocal $directory 1]
+ } caught]} {
+ error "Pull could not walk local directory - $caught" \
+ $errorInfo $errorCode
+ }
+ uplevel 1 [list {*}$progress local $local]
+ if {[catch {
+ set remote [S3::getRemote $bucket $prefix $blocking]
+ } caught]} {
+ error "Pull could not walk remote directory - $caught" \
+ $errorInfo $errorCode
+ }
+ uplevel 1 [list {*}$progress remote $remote]
+ set result [dict create]
+ set result0 [dict create \
+ filescopied 0 bytescopied 0 compareskipped 0 \
+ errorskipped 0 filesdeleted 0 filesnotdeleted 0]
+ foreach suffix $remote {
+ uplevel 1 [list {*}$progress copy $suffix start]
+ set err [catch {
+ S3::makeDirs $directory $suffix
+ S3::Get -bucket $bucket -blocking $blocking \
+ -file [file join $directory $suffix] \
+ -resource $prefix/$suffix \
+ -timestamp [dict get $myargs -timestamp] \
+ -compare [dict get $myargs -compare]} caught]
+ if {$err} {
+ uplevel 1 [list {*}$progress copy $suffix $errorCode]
+ dict incr result0 errorskipped
+ dict set result $suffix $errorCode
+ if {[dict get $myargs -error] eq "throw"} {
+ error "Pull failed to Get - $caught" $errorInfo $errorCode
+ } elseif {[dict get $myargs -error] eq "break"} {
+ break
+ }
+ } else {
+ if {$caught} {
+ uplevel 1 [list {*}$progress copy $suffix copied]
+ dict incr result0 filescopied
+ dict incr result0 bytescopied \
+ [file size [file join $directory $suffix]]
+ dict set result $suffix copied
+ } else {
+ uplevel 1 [list {*}$progress copy $suffix skipped]
+ dict incr result0 compareskipped
+ dict set result $suffix skipped
+ }
+ }
+ }
+ # Now do deletes, if so desired
+ if {[dict get $myargs -delete]} {
+ foreach suffix [lsort -decreasing $local] {
+ # Note, decreasing because we delete empty dirs
+ if {[string match "*/" $suffix]} {
+ set f [file join $directory $suffix]
+ catch {file delete -- $f}
+ if {![file exists $f]} {
+ uplevel 1 [list {*}$progress delete $suffix {}]
+ dict set result $suffix deleted
+ dict incr result0 filesdeleted
+ }
+ } elseif {$suffix ni $remote} {
+ set err [catch {
+ file delete [file join $directory $suffix]
+ } caught]
+ if {$err} {
+ uplevel 1 [list {*}$progress delete $suffix $errorCode]
+ dict incr result0 filesnotdeleted
+ dict set result $suffix notdeleted
+ } else {
+ uplevel 1 [list {*}$progress delete $suffix {}]
+ dict incr result0 filesdeleted
+ dict set result $suffix deleted
+ }
+ }
+ }
+ }
+ dict set result {} $result0
+ uplevel 1 [list {*}$progress finished $result]
+ return $result
+}
+
+# Public. Delete a collection of resources with the same prefix.
+proc S3::Toss {args} {
+ # This is waaaay to similar to Push for comfort.
+ # Fold it up later.
+ global errorCode errorInfo
+ checkinit
+ set myargs [S3::parseargs1 $args {
+ -bucket -blocking -prefix
+ -error -progress
+ }]
+ if {![dict exists $myargs -bucket]} {
+ dict set myargs -bucket [S3::Configure -default-bucket]
+ }
+ dict set myargs -bucket [string trim [dict get $myargs -bucket] "/ "]
+ if {"" eq [dict get $myargs -bucket]} {
+ error "Toss requires -bucket" "" [list S3 usage -bucket $args]
+ }
+ if {![dict exists $myargs -prefix]} {
+ error "Toss requires -prefix" "" [list S3 usage -directory $args]
+ }
+ # Set default values.
+ set defaults "-error continue -progress ::S3::ignore -blocking 1"
+ foreach {key val} $defaults {
+ if {![dict exists $myargs $key]} {dict set myargs $key $val}
+ }
+ # Pull out arguments for convenience
+ foreach i {progress prefix bucket blocking} {
+ set $i [dict get $myargs -$i]
+ }
+ set prefix [string trimright $prefix /]
+ # We're readdy to roll here.
+ uplevel 1 [list {*}$progress args $myargs]
+ if {[catch {
+ set remote [S3::getRemote $bucket $prefix $blocking]
+ } caught]} {
+ error "Toss could not walk remote bucket - $caught" \
+ $errorInfo $errorCode
+ }
+ uplevel 1 [list {*}$progress remote $remote]
+ set result [dict create]
+ set result0 [dict create \
+ filescopied 0 bytescopied 0 compareskipped 0 \
+ errorskipped 0 filesdeleted 0 filesnotdeleted 0]
+ # Now do deletes
+ foreach suffix $remote {
+ set err [catch {
+ S3::Delete -bucket $bucket -blocking $blocking \
+ -resource $prefix/$suffix } caught]
+ if {$err} {
+ uplevel 1 [list {*}$progress delete $suffix $errorCode]
+ dict incr result0 filesnotdeleted
+ dict set result $suffix notdeleted
+ } else {
+ uplevel 1 [list {*}$progress delete $suffix {}]
+ dict incr result0 filesdeleted
+ dict set result $suffix deleted
+ }
+ }
+ dict set result {} $result0
+ uplevel 1 [list {*}$progress finished $result]
+ return $result
+}
diff --git a/tcllib/modules/amazon-s3/S3.test b/tcllib/modules/amazon-s3/S3.test
new file mode 100644
index 0000000..b79227a
--- /dev/null
+++ b/tcllib/modules/amazon-s3/S3.test
@@ -0,0 +1,1766 @@
+# -*- tcl -*-
+# S3.test: tests for the S3 access package.
+
+# This file contains a collection of tests for the S3
+# package. Sourcing this file into Tcl runs the tests and generates
+# output for errors. No output means no errors were found.
+
+# Copyright (c) 2006,2008 Darren New. All Rights Reserved.
+# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# (Boilerplate stuff (header, footer))
+# All rights reserved.
+#
+# RCS: @(#) $Id: S3.test,v 1.3 2008/09/04 02:11:12 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+if {[catch {package require xml}]} {
+ puts " Aborting the tests found in \"[file tail [info script]]\""
+ puts " Requiring xml package, not found."
+ return
+}
+
+support {
+ # Requires xml (TclXML)
+ useLocal xsxp.tcl xsxp
+}
+testing {
+ useLocal S3.tcl S3
+}
+
+# -------------------------------------------------------------------------
+
+# I normally leave BucketDeletion false, because Amazon gets cranky
+# if you delete a bucket and then try to recreate it any time soon.
+
+# This may clobber files starting with the characers "S3T". Don't
+# run it in a directory with such files you want.
+
+# Put your own keys in S3-test.config.
+
+tcltest::customMatch S3err S3ErrorMatch
+
+tcltest::testConstraint BucketDeletion false
+tcltest::testConstraint REST true
+tcltest::testConstraint BucketIO true
+tcltest::testConstraint ItemIO true
+tcltest::testConstraint Put true
+tcltest::testConstraint Get true
+tcltest::testConstraint Acl true
+tcltest::testConstraint Head true
+tcltest::testConstraint Directory true
+tcltest::testConstraint Delete true
+
+tcltest::configure -verbose {body error pass skip start}
+tcltest::configure -debug 1
+
+# Allow easy testing of S3-style errorCode returns.
+
+proc S3expectErr {code} {
+ global errorCode
+ set errorCode {}
+ set x [catch $code result]
+ return [concat $x $errorCode]
+}
+
+proc S3ErrorMatch {expected actual} {
+ if {$expected eq [lrange $actual 0 [expr {[llength $expected]-1}]]} {
+ return true
+ } else {
+ return false
+ }
+}
+
+# Allow easy testing of background tasks.
+
+proc S3expectBackgroundREST {req} {
+ # Might be done better, tho...
+ set ::S3::afterResult {}
+ set ::S3::afterRan 0
+ set y [after 1 {set ::S3::afterRan 1}]
+ S3::REST $req
+ vwait [dict get $req resultvar]
+ set x [set [dict get $req resultvar]]
+ after cancel $y
+ #if {$::S3::afterResult eq "AFTER-FAILURE"} {
+ #error "Background task never returned value" "" [after info $x]
+ #}
+ if {[string match "BGERROR*" $::S3::afterResult]} {
+ error "BGError triggered: $::S3::afterResult" "" $::S3::afterResult
+ }
+ if {0 == $::S3::afterRan} {
+ error "Concurrent events did not run" "" "S3 test afterRan"
+ }
+ return $x
+}
+
+proc S3expectBackground {code} {
+ # Might be done better, tho...
+ set ::S3::afterResult {}
+ set ::S3::afterRan 0
+ set y [after 1 {set ::S3::afterRan 1}]
+ set x [eval $code]
+ after cancel $y
+ #if {$::S3::afterResult eq "AFTER-FAILURE"} {
+ #error "Background task never returned value" "" [after info $x]
+ #}
+ if {[string match "BGERROR*" $::S3::afterResult]} {
+ error "BGError triggered: $::S3::afterResult" "" $::S3::afterResult
+ }
+ if {0 == $::S3::afterRan} {
+ error "Concurrent events did not run" "" "S3 test afterRan"
+ }
+ return $x
+}
+
+proc bgerror {args} {set ::S3::afterResult [list "BGERROR" $args $::errorInfo]}
+
+# Allow easy incorporation of user's AccessID and SecretKey
+
+proc S3loadKeys {} {
+ source test-S3.config
+}
+
+namespace import ::tcltest::test
+
+proc CleanUpBuckets {{buckets 0}} {
+ S3loadKeys
+ set bucket [S3::SuggestBucket TclTestS3b]
+ for {set i 0} {$i < 25} {incr i} {
+ puts "Deleting $i of 25"
+ for {set j 0} {$j < 10} {incr j} {
+ set q [format %02d $i]
+ set d [S3::REST \
+ [dict create verb DELETE resource /$bucket/thing/$q/$j]]
+ S3::throwhttp $d
+ }
+ }
+ S3::REST [dict create verb DELETE resource /$bucket/fred ]
+ S3::REST [dict create verb DELETE resource /$bucket/barney ]
+ S3::REST [dict create verb DELETE resource /$bucket/wilma ]
+ S3::REST [dict create verb DELETE resource /$bucket/betty ]
+ S3::REST [dict create verb DELETE resource /$bucket/cartman ]
+ S3::REST [dict create verb DELETE resource /$bucket/cartoon/tweety ]
+ S3::REST [dict create verb DELETE resource /$bucket/cartoon/sylvester ]
+ S3::REST [dict create verb DELETE resource "/$bucket/cartoon/road runner" ]
+ S3::REST [dict create verb DELETE \
+ resource "/$bucket/cartoon/wile e. coyote" ]
+ if {$buckets} {S3::REST [dict create verb DELETE resource /$bucket]}
+}
+
+# CleanUpBuckets 0 ; exit
+
+# Test URL encoding
+
+test S3-1.10 {URL encoding no parameters} -body {
+ S3::to_url /quotes/nelson {}
+} -result {/quotes/nelson}
+
+test S3-1.20 {URL encoding with parameters} -body {
+ S3::to_url /quotes/nelson {alpha one beta two}
+} -result {/quotes/nelson?alpha=one&beta=two}
+
+test S3-1.30 {URL encoding with parameters and query} -body {
+ S3::to_url /quotes/nelson?acl {alpha one beta two}
+} -result {/quotes/nelson?acl&alpha=one&beta=two}
+
+test S3-1.40 {URL with non-ASCII characters} -body {
+ set funky "/xyzzy/zz+fun\(\)good?junk space"
+ append funky "&and_utf-8\u2211Sigma\u5927Da"
+ S3::encode_url $funky
+} -result {/xyzzy/zz%2bfun%28%29good%3fjunk%20space%26and_utf-8%e2%88%91Sigma%e5%a4%a7Da}
+
+test S3-1.50 {Check out content types A} -setup {
+ tcltest::makeFile "This is just text" "S3junk.txt"
+} -body {
+ S3::contenttype S3junk.txt
+} -cleanup {
+ tcltest::removeFile "S3junk.txt"
+} -result "text/plain"
+
+test S3-1.60 {Check out content types A} -body {
+ # May be unhappy under UNIX?
+ S3::contenttype origT1.jpg
+} -result "image/jpeg"
+
+test S3-2.10 {Config no args} -body {
+ array set x [S3::Configure]
+ foreach key [lsort [array names x]] {
+ puts $key ; puts $x($key)
+ }
+} -cleanup {unset x} -output "-accesskeyid\n\n-bucket-prefix\nTclS3\n-default-acl\n\n-default-bucket\n\n-default-compare\nalways\n-default-separator\n/\n-reset\nfalse\n-retries\n3\n-secretaccesskey\n\n-service-access-point\ns3.amazonaws.com\n-slop-seconds\n3\n-use-tls\nfalse\n"
+
+test S3-2.20 {Config, one arg} -body {
+ S3::Configure -bucket-prefix
+} -result {TclS3}
+
+test S3-2.30 {Config, set bucket prefix} -body {
+ S3::Configure -bucket-prefix TclTestS3
+ S3::Configure -bucket-prefix
+} -result {TclTestS3}
+
+test S3-2.40 {Config, bad first argument} -body {
+ S3expectErr {S3::Configure -xyzzy}
+} -result "1 S3 usage -xyzzy" -match S3err
+
+test S3-2.50 {Config, wrong number of pairs} -body {
+ set ::errorCode {}
+ S3::Configure -bucket-prefix TclTestS3
+ set x [catch {S3::Configure -bucket-prefix 1234 -use-tls}]
+ set y [S3::Configure -bucket-prefix]
+ return [concat $x [lrange $::errorCode 0 1] $y]
+} -result {1 S3 usage TclTestS3} -cleanup {unset x ; unset y}
+
+test S3-2.60 {Config, test reset} -body {
+ S3::Configure -bucket-prefix XYZZY -reset true
+ return [S3::Configure -bucket-prefix]
+} -result TclS3
+
+test S3-2.70 {Suggest bucket name} -body {
+ S3::Configure -accesskeyid 44CF9590006BF252F707 \
+ -secretaccesskey OtxrzxIsfpFjA7SwPzILwy8Bw21TLhquhboDYROV
+ set x [S3::SuggestBucket Bloop]
+ return [concat [string match *Bloop* $x] \
+ [string match *44CF9590006BF252F707* $x] \
+ [string match *OtxrzxIsfpFjA7SwPzILwy8Bw21TLhquhboDYROV* $x]]
+} -result {1 1 0}
+
+# Now test the stuff from the manual
+
+test S3-3.10 {First documentation example of AUTH} -body {
+ S3::Configure -accesskeyid 44CF9590006BF252F707 \
+ -secretaccesskey OtxrzxIsfpFjA7SwPzILwy8Bw21TLhquhboDYROV
+ set verb put
+ set resource /quotes/nelson
+ set content-type text/html
+ set headers {
+ date "Thu, 17 Nov 2005 18:49:58 GMT"
+ content-md5 c8fdb181845a4ca6b8fec737b3581d76
+ x-amz-meta-author foo@bar.com
+ x-amz-magic abracadabra
+ }
+ set res [S3::authREST $verb $resource ${content-type} $headers]
+ dict get $res authorization
+} -result {AWS 44CF9590006BF252F707:jZNOcbfWmD/A/f3hSvVzXZjM2HU=}
+
+test S3-3.20 {Second documentation example of AUTH} -body {
+ S3::Configure -accesskeyid 44CF9590006BF252F707 \
+ -secretaccesskey OtxrzxIsfpFjA7SwPzILwy8Bw21TLhquhboDYROV
+ set verb GET
+ set resource /quotes/nelson
+ set headers {
+ date XXXXXXX
+ x-amz-magic abracadabra
+ x-amz-date "Thu, 17 Nov 2005 18:49:58 GMT"
+ }
+ set res [S3::authREST $verb $resource "" $headers]
+ dict get $res authorization
+} -result {AWS 44CF9590006BF252F707:5m+HAmc5JsrgyDelh9+a2dNrzN8=}
+
+test S3-4.10 {REST Blocking list of buckets} -constraints "BucketIO REST" \
+ -setup S3loadKeys -body {
+ set req [dict create verb GET resource /]
+ set res [S3::REST $req]
+ return [list [lsort [dict keys $res]] [dict get $res httpstatus] \
+ [expr {0<[string length [dict get $res outbody]]}]]
+} -result {{httpmessage httpstatus outbody outheaders resource verb} 200 1}
+
+test S3-4.20 {REST Nonblocking list of buckets} -constraints "BucketIO REST" \
+ -setup S3loadKeys -body {
+ set req [dict create verb GET resource / resultvar ::S3RES]
+ set res [S3expectBackgroundREST $req]
+ return [list [lsort [dict keys $res]] [dict get $res httpstatus] \
+ [expr {0<[string length [dict get $res outbody]]}]]
+} -result {{httpmessage httpstatus outbody outheaders resource resultvar verb} 200 1}
+
+test S3-4.30 {REST blocking create bucket} -constraints "BucketIO REST" \
+ -setup S3loadKeys -body {
+ set b "TclTestS3.REST.[S3::Configure -accesskeyid]"
+ set req [dict create verb PUT resource /$b headers {x-amz-acl public-read}]
+ set res [S3::REST $req]
+ return [dict get $res httpstatus]
+} -result 200
+
+test S3-4.40 {REST get bucket acl} -constraints "BucketIO REST" \
+ -setup S3loadKeys -body {
+ set b "TclTestS3.REST.[S3::Configure -accesskeyid]"
+ set req [dict create verb GET resource /$b rtype acl]
+ set res [S3::REST $req]
+ set lookfor {<URI>http://acs.amazonaws.com/groups/global/AllUsers</URI></Grantee><Permission>READ</Permission>}
+ set found [expr {-1 != [string first $lookfor $res]}]
+ return [list $found [dict get $res httpstatus]]
+} -result "1 200"
+
+test S3-4.50 {REST blocking put,get,compare contents} \
+ -constraints "ItemIO REST" \
+ -setup S3loadKeys -body {
+ set body "This is a test. This is only a test.\nHad this been a real emergency, you would be dead.\n"
+ set b "TclTestS3.REST.[S3::Configure -accesskeyid]"
+ set req [dict create verb PUT resource /$b/t1.txt inbody $body \
+ headers {x-amz-acl public-read}]
+ set res [S3::REST $req]
+ set r1 [dict get $res httpstatus]
+ set req [dict create verb GET resource /$b/t1.txt rtype acl]
+ set res [S3::REST $req]
+ set lookfor {<URI>http://acs.amazonaws.com/groups/global/AllUsers</URI></Grantee><Permission>READ</Permission>}
+ set r2 [expr {-1 != [string first $lookfor $res]}]
+ set req [dict create verb GET resource /$b/t1.txt]
+ set res [S3::REST $req]
+ set r3 [string compare $body [dict get $res outbody]]
+ return [list $r1 $r2 $r3]
+} -result "200 1 0"
+
+test S3-4.60 {REST nonblocking put,get,compare contents} \
+ -constraints "ItemIO REST" \
+ -setup S3loadKeys -body {
+ set body "This is a test. This is only a test.\nHad this been a real emergency, you would be dead.\n"
+ set b "TclTestS3.REST.[S3::Configure -accesskeyid]"
+ set req [dict create verb PUT resource /$b/t1.txt inbody $body \
+ headers {x-amz-acl public-read} resultvar ::S3REST]
+ set res [S3expectBackgroundREST $req]
+ set r1 [dict get $res httpstatus]
+ set req [dict create verb GET resource /$b/t1.txt rtype acl resultvar ::S3REST]
+ set res [S3expectBackgroundREST $req]
+ set lookfor {<URI>http://acs.amazonaws.com/groups/global/AllUsers</URI></Grantee><Permission>READ</Permission>}
+ set r2 [expr {-1 != [string first $lookfor $res]}]
+ set req [dict create verb GET resource /$b/t1.txt resultvar ::S3REST]
+ set res [S3expectBackgroundREST $req]
+ set r3 [string compare $body [dict get $res outbody]]
+ return [list $r1 $r2 $r3]
+} -result "200 1 0"
+
+test S3-4.70 {REST blocking put,delete} \
+ -constraints "ItemIO REST" \
+ -setup S3loadKeys -body {
+ set body "This is a test. This is only a test.\nHad this been a real emergency, you would be dead.\n"
+ set b "TclTestS3.REST.[S3::Configure -accesskeyid]"
+ set req [dict create verb PUT resource /$b/t1.txt inbody $body]
+ set res [S3::REST $req]
+ set r1 [dict get $res httpstatus]
+ set req [dict create verb DELETE resource /$b/t1.txt]
+ set res [S3::REST $req]
+ set r2 [dict get $res httpstatus]
+ return [list $r1 $r2]
+} -result "200 204" ; # Delete returns "no content"
+
+test S3-4.80 {REST nonblocking put,delete} \
+ -constraints "ItemIO REST" \
+ -setup S3loadKeys -body {
+ set body "This is a test. This is only a test.\nHad this been a real emergency, you would be dead.\n"
+ set b "TclTestS3.REST.[S3::Configure -accesskeyid]"
+ set req [dict create verb PUT resource /$b/t1.txt inbody $body \
+ resultvar ::S3RES]
+ set res [S3expectBackgroundREST $req]
+ set r1 [dict get $res httpstatus]
+ set req [dict create verb DELETE resource /$b/t1.txt resultvar ::S3RES]
+ set res [S3expectBackgroundREST $req]
+ set r2 [dict get $res httpstatus]
+ return [list $r1 $r2]
+} -result "200 204" ; # Delete returns "no content"
+
+test S3-4.90 {REST blocking put,head,delete} \
+ -constraints "ItemIO REST" \
+ -setup S3loadKeys -body {
+ set body "This is a test. This is only a test.\nHad this been a real emergency, you would be dead.\n"
+ set b "TclTestS3.REST.[S3::Configure -accesskeyid]"
+ set req [dict create verb PUT resource /$b/t1.txt inbody $body]
+ set res [S3::REST $req]
+ set r1 [dict get $res httpstatus]
+ set req [dict create verb HEAD resource /$b/t1.txt]
+ set res [S3::REST $req]
+ set r2 [dict get $res httpstatus]
+ set r3 [string length [dict get $res outbody]]
+ set req [dict create verb DELETE resource /$b/t1.txt]
+ set res [S3::REST $req]
+ set r4 [dict get $res httpstatus]
+ set req [dict create verb HEAD resource /$b/t1.txt]
+ set res [S3::REST $req]
+ set r5 [dict get $res httpstatus]
+ return [list $r1 $r2 $r3 $r4 $r5]
+} -result "200 200 0 204 404"
+
+test S3-4.100 {REST blocking put,head,delete from big body} \
+ -constraints "ItemIO REST" \
+ -setup S3loadKeys -body {
+ set body "0123456789"
+ set body [string repeat $body 50000] ; # Make body 500,000 bytes.
+ set b "TclTestS3.REST.[S3::Configure -accesskeyid]"
+ set req [dict create verb PUT resource /$b/t1.txt inbody $body]
+ set res [S3::REST $req]
+ set r1 [dict get $res httpstatus]
+ set req [dict create verb HEAD resource /$b/t1.txt]
+ set res [S3::REST $req]
+ set r2 [dict get $res httpstatus]
+ set r3 [string length [dict get $res outbody]]
+ set r4 [dict get $res outheaders content-length]
+ set req [dict create verb DELETE resource /$b/t1.txt]
+ set res [S3::REST $req]
+ set r5 [dict get $res httpstatus]
+ set req [dict create verb HEAD resource /$b/t1.txt]
+ set res [S3::REST $req]
+ set r6 [dict get $res httpstatus]
+ return [list $r1 $r2 $r3 $r4 $r5 $r6]
+} -result "200 200 0 500000 204 404"
+
+test S3-4.110 {REST nonblocking put,head,delete from big body} \
+ -constraints "ItemIO REST" \
+ -setup S3loadKeys -body {
+ set body "0123456789"
+ set body [string repeat $body 50000] ; # Make body 500,000 bytes.
+ set b "TclTestS3.REST.[S3::Configure -accesskeyid]"
+ set req [dict create verb PUT resource /$b/t2.txt inbody $body resultvar ::S3RES]
+ set res [S3expectBackgroundREST $req]
+ set r1 [dict get $res httpstatus]
+ set req [dict create verb HEAD resource /$b/t2.txt]
+ set res [S3::REST $req]
+ set r2 [dict get $res httpstatus]
+ set r3 [string length [dict get $res outbody]]
+ set r4 [dict get $res outheaders content-length]
+ set req [dict create verb DELETE resource /$b/t2.txt]
+ set res [S3::REST $req]
+ set r5 [dict get $res httpstatus]
+ set req [dict create verb HEAD resource /$b/t2.txt]
+ set res [S3::REST $req]
+ set r6 [dict get $res httpstatus]
+ return [list $r1 $r2 $r3 $r4 $r5 $r6]
+} -result "200 200 0 500000 204 404"
+
+test S3-4.120 {REST nonblocking put,head,delete from big file} \
+ -constraints "ItemIO REST" \
+ -setup S3loadKeys -body {
+ set body "0123456789"
+ set body [string repeat $body 50000] ; # Make body 500,000 bytes.
+ tcltest::makeFile "XXX" S3Tone.txt
+ set x [open S3Tone.txt w] ; puts -nonewline $x $body ; close $x
+ set b "TclTestS3.REST.[S3::Configure -accesskeyid]"
+ set req [dict create verb PUT resource /$b/t3.txt infile S3Tone.txt resultvar ::S3RES]
+ set res [S3expectBackgroundREST $req]
+ set r1 [dict get $res httpstatus]
+ set req [dict create verb HEAD resource /$b/t3.txt]
+ set res [S3::REST $req]
+ set r2 [dict get $res httpstatus]
+ set r3 [string length [dict get $res outbody]]
+ set r4 [dict get $res outheaders content-length]
+ set req [dict create verb DELETE resource /$b/t3.txt]
+ set res [S3::REST $req]
+ set r5 [dict get $res httpstatus]
+ set req [dict create verb HEAD resource /$b/t3.txt]
+ set res [S3::REST $req]
+ set r6 [dict get $res httpstatus]
+ tcltest::removeFile S3Tone.txt
+ return [list $r1 $r2 $r3 $r4 $r5 $r6]
+} -result "200 200 0 500000 204 404"
+
+test S3-4.130 {REST blocking put,head,delete from big file} \
+ -constraints "ItemIO REST" \
+ -setup S3loadKeys -body {
+ set body "0123456789"
+ set body [string repeat $body 50000] ; # Make body 500,000 bytes.
+ tcltest::makeFile "XXX" S3Tone.txt
+ set x [open S3Tone.txt w] ; puts -nonewline $x $body ; close $x
+ set b "TclTestS3.REST.[S3::Configure -accesskeyid]"
+ set req [dict create verb PUT resource /$b/t3.txt infile S3Tone.txt]
+ set res [S3::REST $req]
+ set r1 [dict get $res httpstatus]
+ set req [dict create verb HEAD resource /$b/t3.txt]
+ set res [S3::REST $req]
+ set r2 [dict get $res httpstatus]
+ set r3 [string length [dict get $res outbody]]
+ set r4 [dict get $res outheaders content-length]
+ set req [dict create verb DELETE resource /$b/t3.txt]
+ set res [S3::REST $req]
+ set r5 [dict get $res httpstatus]
+ set req [dict create verb HEAD resource /$b/t3.txt]
+ set res [S3::REST $req]
+ set r6 [dict get $res httpstatus]
+ tcltest::removeFile S3Tone.txt
+ return [list $r1 $r2 $r3 $r4 $r5 $r6]
+} -result "200 200 0 500000 204 404"
+
+test S3-4.140 {REST nonblocking put,get,delete into file} \
+ -constraints "ItemIO REST" \
+ -setup S3loadKeys -body {
+ set body "0123456789"
+ set body [string repeat $body 50000] ; # Make body 500,000 bytes.
+ set b "TclTestS3.REST.[S3::Configure -accesskeyid]"
+ set req [dict create verb PUT resource /$b/t5.txt inbody $body resultvar ::S3RES]
+ set res [S3expectBackgroundREST $req]
+ set r1 [dict get $res httpstatus]
+ tcltest::makeFile "blah" S3Ttwo.txt
+ set x [open S3Ttwo.txt w] ; fconfigure $x -translation binary -encoding binary
+ set req [dict create verb GET resource /$b/t5.txt outchan $x]
+ set res [S3::REST $req]
+ close $x
+ set r2 [dict get $res httpstatus]
+ set r3 [file size S3Ttwo.txt]
+ tcltest::removeFile S3Ttwo.txt
+ set req [dict create verb DELETE resource /$b/t3.txt]
+ set res [S3::REST $req]
+ set r4 [dict get $res httpstatus]
+ set req [dict create verb HEAD resource /$b/t3.txt]
+ set res [S3::REST $req]
+ set r5 [dict get $res httpstatus]
+ return [list $r1 $r2 $r3 $r4 $r5]
+} -result "200 200 500000 204 404"
+
+test S3-4.150 {REST blocking put,get,delete into file} \
+ -constraints "ItemIO REST" \
+ -setup S3loadKeys -body {
+ set body "0123456789"
+ set body [string repeat $body 50000] ; # Make body 500,000 bytes.
+ set b "TclTestS3.REST.[S3::Configure -accesskeyid]"
+ set req [dict create verb PUT resource /$b/t5.txt inbody $body]
+ set res [S3::REST $req]
+ set r1 [dict get $res httpstatus]
+ tcltest::makeFile "blah" S3Ttwo.txt
+ set x [open S3Ttwo.txt w] ; fconfigure $x -translation binary -encoding binary
+ set req [dict create verb GET resource /$b/t5.txt outchan $x]
+ set res [S3::REST $req]
+ close $x
+ set r2 [dict get $res httpstatus]
+ set r3 [file size S3Ttwo.txt]
+ tcltest::removeFile S3Ttwo.txt
+ set req [dict create verb DELETE resource /$b/t5.txt]
+ set res [S3::REST $req]
+ set r4 [dict get $res httpstatus]
+ set req [dict create verb HEAD resource /$b/t5.txt]
+ set res [S3::REST $req]
+ set r5 [dict get $res httpstatus]
+ return [list $r1 $r2 $r3 $r4 $r5]
+} -result "200 200 500000 204 404"
+
+test S3-4.160 {REST blocking put,get,delete of file with encoded name} \
+ -constraints "ItemIO REST" \
+ -setup S3loadKeys -body {
+ set body "0123456789"
+ set b "TclTestS3.REST.[S3::Configure -accesskeyid]"
+ set funky "/$b/zz+fun\(\)good?junk space"
+ append funky "&and_utf-8\u2211Sigma\u5927Da"
+ set req [dict create verb PUT resource $funky inbody $body]
+ set res [S3::REST $req]
+ set r1 [dict get $res httpstatus]
+ set req [dict create verb GET resource $funky]
+ set res [S3::REST $req]
+ set r2 [dict get $res httpstatus]
+ set req [dict create verb DELETE resource $funky]
+ set res [S3::REST $req]
+ set r3 [dict get $res httpstatus]
+ set req [dict create verb HEAD resource $funky]
+ set res [S3::REST $req]
+ set r4 [dict get $res httpstatus]
+ return [list $r1 $r2 $r3 $r4]
+} -result "200 200 204 404"
+
+test S3-4.170 {REST delete bucket} \
+ -constraints "BucketDeletion REST" \
+ -setup S3loadKeys -body {
+ # Bucket ought to be empty by now.
+ # Of course, if a delete fails for some reason...
+ set b "TclTestS3.REST.[S3::Configure -accesskeyid]"
+ set req [dict create verb PUT resource /$b headers {x-amz-acl public-read}]
+ set res [S3::REST $req]
+ set r1 [dict get $res httpstatus]
+ after 5000 ; # Give AWS a chance to remember it.
+ set req [dict create verb DELETE resource /$b]
+ set res [S3::REST $req]
+ after 5000 ; # Give AWS a chance to remember it.
+ set r2 [dict get $res httpstatus]
+ set req [dict create verb GET resource /$b]
+ set res [S3::REST $req]
+ set r3 [dict get $res httpstatus]
+ return [list $r1 $r2 $r3]
+} -result "200 204 404"
+
+test S3-10.10 {ListAllMyBuckets auth failure} -constraints BucketIO \
+ -body {
+ S3expectErr {
+ S3::Configure -accesskeyid 44CF9590006BF252F707 \
+ -secretaccesskey OtxrzxIsfpFjA7SwPzILwy8Bw21TLhquhboDYROV
+ S3::ListAllMyBuckets
+ }
+} -result "1 S3 remote 403" -match S3err
+
+test S3-10.20 {ListAllMyBuckets usage params} -body {
+ S3expectErr {
+ S3::ListAllMyBuckets -blocking false -parse-xml {} -result-type REST
+ }
+} -result "1 S3 usage -parse-xml" -match S3err
+
+test S3-10.30 {ListAllMyBuckets bad params two} -body {
+ S3expectErr {S3::ListAllMyBuckets -xyz hello}
+} -result "1 S3 usage -xyz" -match S3err
+
+test S3-10.40 {ListAllMyBuckets bad params three} -body {
+ S3expectErr {S3::ListAllMyBuckets -blocking false -parse-xml}
+} -result "1 S3 usage -parse-xml" -match S3err
+
+set testLAMB {<?xml version="1.0" encoding="UTF-8"?>
+<ListAllMyBucketsResult xmlns="http://s3.amazonaws.com/doc/2006-03-01/"><Owner><ID>9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd</ID><DisplayName>dnew@san.rr.com</DisplayName></Owner><Buckets><Bucket><Name>darren</Name><CreationDate>2006-10-29T07:04:48.000Z</CreationDate></Bucket><Bucket><Name>darren-test</Name><CreationDate>2006-10-29T07:04:48.000Z</CreationDate></Bucket><Bucket><Name>darren3</Name><CreationDate>2006-10-30T22:45:34.000Z</CreationDate></Bucket></Buckets></ListAllMyBucketsResult>}
+
+test S3-10.50 {ListAllMyBuckets result parsing RAW} -body {
+ S3::ListAllMyBuckets -parse-xml $testLAMB -result-type xml
+} -result $testLAMB
+
+test S3-10.60 {ListAllMyBuckets result parsing REST} -constraints BucketIO -body {
+ set dict [S3::ListAllMyBuckets -result-type REST]
+ dict get $dict httpstatus
+} -result "403"
+
+test S3-10.70 {ListAllMyBuckets result parsing PXML} -body {
+ set pxml [S3::ListAllMyBuckets -result-type pxml -parse-xml $testLAMB]
+ concat [lindex $pxml 0] [llength $pxml]
+} -result "ListAllMyBucketsResult 4"
+
+test S3-10.80 {ListAllMyBuckets result parsing NAMES} -body {
+ # Note these are defined to be alphabetical, so no sorting needed
+ S3::ListAllMyBuckets -result-type names -parse-xml $testLAMB
+} -result "darren darren-test darren3"
+
+test S3-10.90 {ListAllMyBuckets result parsing DICT} -body {
+ set dict [S3::ListAllMyBuckets -result-type dict -parse-xml $testLAMB]
+ puts [llength $dict]
+ puts [dict get $dict Owner/ID]
+ puts [dict get $dict Owner/DisplayName]
+ puts [dict get $dict Bucket/Name]
+ puts [dict get $dict Bucket/Date]
+} -output {8
+9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd
+dnew@san.rr.com
+darren darren-test darren3
+2006-10-29T07:04:48.000Z 2006-10-29T07:04:48.000Z 2006-10-30T22:45:34.000Z
+}
+
+test S3-10.100 {ListAllMyBuckets result parsing OWNER} -body {
+ S3::ListAllMyBuckets -result-type owner -parse-xml $testLAMB
+} -result {9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd dnew@san.rr.com}
+
+test S3-10.110 {ListAllMyBuckets result parsing error} -body {
+ S3expectErr [list S3::ListAllMyBuckets -result-type xyzzy \
+ -parse-xml $testLAMB]
+} -result "1 S3 usage -result-type" -match S3err
+
+test S3-10.120 {ListAllMyBuckets result parsing error} -body {
+ S3expectErr {S3::ListAllMyBuckets -result-type xyzzy -parse-xml "<Hello"}
+} -result "1 S3 usage xml" -match S3err
+
+test S3-10.130 {ListAllMyBuckets background good} -constraints BucketIO -body {
+ S3loadKeys
+ set x [S3expectBackground {S3::ListAllMyBuckets -result-type REST -blocking false}]
+ dict get $x httpstatus
+} -result "200"
+
+test S3-10.140 {ListAllMyBuckets background bad} -constraints BucketIO -body {
+ S3loadKeys
+ S3expectErr {
+ S3expectBackground {
+ S3::ListAllMyBuckets -result-type REST -blocking true
+ }
+ }
+} -result "1 S3 test afterRan" -match S3err
+
+test S3-20.10 {PutBucket your own bucket} -constraints BucketIO -body {
+ S3loadKeys
+ set b [S3::SuggestBucket TclTestS3]
+ S3::PutBucket -bucket $b
+}
+
+test S3-20.20 {PutBucket someone else's bucket} -constraints BucketIO -body {
+ S3loadKeys
+ S3expectErr {S3::PutBucket -bucket /test/}
+} -result "1 S3 remote 409" -match S3err
+
+test S3-20.30 {PutBucket background failure} -constraints BucketIO -body {
+ S3loadKeys
+ set b [S3::SuggestBucket TclTestS3]
+ S3expectErr [list S3expectBackground [list S3::PutBucket -bucket $b]]
+} -result "1 S3 test afterRan" -match S3err
+
+test S3-20.40 {PutBucket background success} -constraints BucketIO -body {
+ S3loadKeys
+ set b [S3::SuggestBucket TclTestS3]
+ S3expectBackground [list S3::PutBucket -bucket $b -blocking false]
+}
+
+test S3-20.50 {PutBucket test no acl} -constraints BucketIO -body {
+ S3loadKeys
+ set b [S3::SuggestBucket TclTestS3]
+ S3::PutBucket -bucket $b
+ set d1 [dict create verb GET resource /$b rtype acl]
+ set d2 [S3::REST $d1]
+ set d3 [string first "READ" $d2]
+ return [expr -1 == $d3]
+} -result 1
+
+test S3-20.60 {PutBucket test pubread acl} -constraints BucketIO -body {
+ S3loadKeys
+ set b [S3::SuggestBucket TclTestS3]
+ S3::PutBucket -bucket $b -acl public-read
+ set d1 [dict create verb GET resource /$b rtype acl]
+ set d2 [S3::REST $d1]
+ set d3 [string first "AllUsers" $d2]
+ set d4 [string first "READ" $d2]
+ return [expr 0 < $d3 && $d3 < $d4]
+} -result 1
+
+test S3-20.70 {PutBucket test given overrides default acl} \
+ -constraints BucketIO -body {
+ S3loadKeys
+ set b [S3::SuggestBucket TclTestS3]
+ S3::Configure -default-acl public-read-write
+ S3::PutBucket -bucket $b -acl public-read
+ S3::Configure -reset true
+ S3loadKeys
+ set d1 [dict create verb GET resource /$b rtype acl]
+ set d2 [S3::REST $d1]
+ set d3 [string first "AllUsers" $d2]
+ set d4 [string first "READ" $d2]
+ set d5 [string first "WRITE" $d2]
+ return [expr 0 < $d3 && $d3 < $d4 && $d5 == -1]
+} -result 1
+
+test S3-20.80 {PutBucket test default acl} -constraints BucketIO -body {
+ S3loadKeys
+ set b [S3::SuggestBucket TclTestS3]
+ S3::Configure -default-acl public-read-write
+ S3::PutBucket -bucket $b
+ S3::Configure -reset true
+ S3loadKeys
+ set d1 [dict create verb GET resource /$b rtype acl]
+ set d2 [S3::REST $d1]
+ set d3 [string first "AllUsers" $d2]
+ set d4 [string first "READ" $d2]
+ set d5 [string first "WRITE" $d2]
+ return [expr 0 < $d3 && $d3 < $d4 && $d3 < $d5]
+} -result 1
+
+test S3-30.10 {DeleteBucket error} \
+ -constraints "BucketIO BucketDeletion" -body {
+ S3loadKeys
+ set b [S3::SuggestBucket TclTestS3]
+ after 10000 ; # Wait for amazon to catch up
+ S3expectErr {S3::DeleteBucket}
+} -result "1 S3 usage -bucket" -match S3err
+
+test S3-30.20 {DeleteBucket good} \
+ -constraints "BucketIO BucketDeletion" -body {
+ S3loadKeys
+ set b [S3::SuggestBucket TclTestS3]
+ after 10000 ; # Wait for amazon to catch up
+ set x [S3::DeleteBucket -bucket $b]
+ after 10000 ; # Wait for amazon to catch up
+ return $x
+}
+
+test S3-30.30 {DeleteBucket fails on someone else's bucket} \
+ -constraints "BucketIO BucketDeletion" -body {
+ S3loadKeys
+ set b "test"
+ after 10000 ; # Wait for amazon to catch up
+ S3expectErr [list S3::DeleteBucket -bucket $b]
+} -result "1 S3 remote 403" -match S3err
+
+# Since bucket create/delete is high overhead for Amazon,
+# and it's flakey as well, don't test the background version,
+# since it uses the same code.
+
+# OK, since we need a bucket to test stuff, let's continue on.
+S3loadKeys
+set bucket [S3::SuggestBucket TclTestS3b]
+set req [dict create verb HEAD resource /$bucket]
+set res [S3::REST $req]
+set r1 [dict get $res httpstatus]
+set req [dict create verb HEAD resource /$bucket/fred]
+set res [S3::REST $req]
+set r2 [dict get $res httpstatus]
+if {200 != $r1 || 200 != $r2} {
+ S3::PutBucket -bucket $bucket
+ if {[tcltest::testConstraint Directory]} {
+ for {set i 0} {$i < 25} {incr i} {
+ puts "Creating $i of 25"
+ for {set j 0} {$j < 10} {incr j} {
+ set q [format %02d $i]
+ set d [S3::REST \
+ [dict create verb PUT resource /$bucket/thing/$q/$j \
+ inbody "This is $j inside $i"]]
+ S3::throwhttp $d
+ }
+ }
+ }
+ S3::REST [dict create verb PUT resource /$bucket/fred inbody "Fred"]
+ S3::REST [dict create verb PUT resource /$bucket/barney inbody "Barney"]
+ S3::REST [dict create verb PUT resource /$bucket/wilma inbody "Wilma"]
+ S3::REST [dict create verb PUT resource /$bucket/betty inbody "Betty"]
+ S3::REST [dict create verb PUT resource /$bucket/cartman inbody "Cartman" ]
+ S3::REST [dict create verb PUT resource /$bucket/cartoon/tweety \
+ inbody "Tweety"]
+ S3::REST [dict create verb PUT resource /$bucket/cartoon/sylvester \
+ inbody "Sylvester"]
+ S3::REST [dict create verb PUT resource "/$bucket/cartoon/road runner" \
+ inbody "RoadRunner"]
+ S3::REST [dict create verb PUT resource "/$bucket/cartoon/wile e. coyote" \
+ inbody "Coyote"]
+}
+
+# Note that -result-type REST or xml or pxml without a maxcount all
+# return lists of results of that type, since they don't really merge well.
+test S3-40.10 {GetBucket basic call} -constraints BucketIO -body {
+ set res [S3::GetBucket -bucket $bucket -result-type REST]
+ set x1 [llength $res]
+ set x2 [dict get [lindex $res 0] httpstatus]
+ return "$x1 $x2"
+} -result "1 200"
+
+test S3-40.20 {GetBucket get xml} -constraints BucketIO -body {
+ set res [S3::GetBucket -bucket $bucket -result-type xml]
+ set x1 [llength $res]
+ set x2 [lindex $res 0]
+ set x3 [lindex [::xsxp::parse $x2] 0]
+ return "$x1 $x3"
+} -result "1 ListBucketResult"
+
+test S3-40.30 {GetBucket get pxml} -constraints BucketIO -body {
+ set res [S3::GetBucket -bucket $bucket -result-type pxml]
+ set x1 [llength $res]
+ set x2 [lindex $res 0]
+ set x3 [lindex $x2 0]
+ return "$x1 $x3"
+} -result "1 ListBucketResult"
+
+test S3-40.40 {GetBucket names} -constraints BucketIO -body {
+ set r1 [S3::GetBucket -bucket $bucket -result-type names]
+ set r2 [lsort $r1]
+ set r3 [lsort -unique $r1]
+ return [list [llength $r1] [expr {$r1 eq $r2}] [expr {$r2 eq $r3}]]
+} -result "259 1 1"
+
+test S3-40.50 {GetBucket simple looping} -constraints BucketIO -body {
+ set res [S3::GetBucket -bucket $bucket -result-type REST -TEST 50]
+ return [llength $res]
+} -result "6" ; # 259, 50 at a time.
+
+test S3-40.60 {GetBucket looping, return names} -constraints BucketIO -body {
+ set r1 [S3::GetBucket -bucket $bucket -result-type names -TEST 50]
+ set r2 [lsort $r1]
+ set r3 [lsort -unique $r1]
+ return [list [llength $r1] [expr {$r1 eq $r2}] [expr {$r2 eq $r3}]]
+ return [llength $res]
+} -result "259 1 1"; # Shouldn't see the inners here.
+
+test S3-40.70 {GetBucket looping, return dict} -constraints BucketIO -body {
+ set res [S3::GetBucket -bucket $bucket -result-type dict -TEST 50]
+ set r1 [llength [dict get $res Key]]
+ set r2 [string compare [dict get $res Key] [lsort [dict get $res Key]]]
+ set r3 [llength [dict get $res LastModified]]
+ set r4 [llength [dict get $res ETag]]
+ set r5 [llength [dict get $res Size]]
+ set r6 [llength [dict get $res Owner/ID]]
+ set r7 [llength [dict get $res Owner/DisplayName]]
+ set r8 [llength [dict get $res CommonPrefixes/Prefix]]
+ return "$r1 $r2 $r3 $r4 $r5 $r6 $r7 $r8"
+} -result "259 0 259 259 259 259 259 0"
+
+test S3-40.80 {GetBucket non-looping, return dict} -constraints BucketIO -body {
+ set res [S3::GetBucket -bucket $bucket -result-type dict]
+ set r1 [llength [dict get $res Key]]
+ set r2 [string compare [dict get $res Key] [lsort [dict get $res Key]]]
+ set r3 [llength [dict get $res LastModified]]
+ set r4 [llength [dict get $res ETag]]
+ set r5 [llength [dict get $res Size]]
+ set r6 [llength [dict get $res Owner/ID]]
+ set r7 [llength [dict get $res Owner/DisplayName]]
+ set r8 [llength [dict get $res CommonPrefixes/Prefix]]
+ return "$r1 $r2 $r3 $r4 $r5 $r6 $r7 $r8"
+} -result "259 0 259 259 259 259 259 0"
+
+test S3-40.90 {GetBucket looping, prefix} -constraints BucketIO -body {
+ set r [S3::GetBucket -bucket $bucket \
+ -result-type names -TEST 50 -prefix "car"]
+ join $r \n
+} -result {cartman
+cartoon/road runner
+cartoon/sylvester
+cartoon/tweety
+cartoon/wile e. coyote}
+
+test S3-40.100 {GetBucket delimiter, prefix} -constraints BucketIO -body {
+ S3::GetBucket -bucket $bucket -result-type names -TEST 50 \
+ -prefix /thing/ -delimiter /
+} -result {thing/00/ thing/01/ thing/02/ thing/03/ thing/04/ thing/05/ thing/06/ thing/07/ thing/08/ thing/09/ thing/10/ thing/11/ thing/12/ thing/13/ thing/14/ thing/15/ thing/16/ thing/17/ thing/18/ thing/19/ thing/20/ thing/21/ thing/22/ thing/23/ thing/24/}
+
+test S3-40.110 {GetBucket delimiter, prefix again} -constraints BucketIO -body {
+ S3::GetBucket -bucket $bucket -result-type names -TEST 50 \
+ -prefix thing -delimiter /
+} -result {thing/}
+
+test S3-40.120 {GetBucket delimiter, no prefix} -constraints BucketIO -body {
+ S3::GetBucket -bucket $bucket -result-type names -TEST 50 -delimiter /
+} -result {barney betty cartman cartoon/ fred thing/ wilma}
+
+test S3-40.130 {GetBucket no default bucket} -constraints BucketIO -body {
+ S3expectErr {
+ S3::GetBucket -result-type names -TEST 50 -delimiter /
+ }
+} -result "1 S3 usage -bucket" -match S3err
+
+test S3-40.140 {GetBucket with default bucket} -constraints BucketIO -body {
+ S3::Configure -default-bucket $bucket
+ set res [S3::GetBucket -result-type names -TEST 50 -delimiter /]
+ S3::Configure -default-bucket ""
+ return $res
+} -result {barney betty cartman cartoon/ fred thing/ wilma}
+
+set bucket [S3::SuggestBucket TclTestS3] ; # Maybe delete later.
+
+proc getbody {resource} {
+ set req [dict create verb GET resource $resource]
+ set res [S3::REST $req]
+ S3::throwhttp $res
+ set body [dict get $res outbody]
+ return $body
+}
+
+proc delbody {resource} {
+ set req [dict create verb DELETE resource $resource]
+ set res [S3::REST $req]
+ S3::throwhttp $res
+}
+
+proc existsbody {resource} {
+ set req [dict create verb HEAD resource $resource]
+ set res [S3::REST $req]
+ return [expr {[dict get $res httpstatus] eq "200"}]
+}
+
+# Make a setup/cleanup pair for checking constraints on PUT and GET
+set pgsu {
+ # Create an old file, and a new file, with different contents
+ tcltest::makeFile "FILEONE" S3Tone.txt
+ tcltest::makeFile "FILETWO" S3Ttwo.txt
+ tcltest::makeFile "FILETHREE" S3Tthree.txt
+ tcltest::makeFile "This is some random content" S3Talpha.txt
+ tcltest::makeFile "This is some random content" S3Tbeta.txt
+ tcltest::makeFile "This is some random content" S3Tgamma.txt
+ tcltest::makeFile "Junk contents" S3junk.txt
+ set now [clock seconds]
+ file mtime S3Tone.txt [expr $now-300]
+ file mtime S3Ttwo.txt [expr $now+300]
+ file mtime S3Tbeta.txt [expr $now+300]
+ S3::REST [dict create verb PUT resource /$bucket/ABC inbody "ABC HERE" \
+ headers {x-amz-meta-thing stuff} content-type application/tcltest]
+ if {[file exists S3junk.txt]} {file delete S3junk.txt}
+}
+
+set pgcu {
+ tcltest::removeFile S3Tone.txt
+ tcltest::removeFile S3Ttwo.txt
+ tcltest::removeFile S3Tthree.txt
+ tcltest::removeFile S3Talpha.txt
+ tcltest::removeFile S3Tbeta.txt
+ tcltest::removeFile S3Tgamma.txt
+ if {[file exists S3junk.txt]} {file delete S3junk.txt}
+ if {[existsbody /$bucket/XYZ]} {delbody /$bucket/XYZ}
+ if {[existsbody /$bucket/PDQ]} {delbody /$bucket/PDQ}
+ if {[existsbody /$bucket/ABC]} {delbody /$bucket/ABC}
+}
+
+
+test S3-50.10 {Put, basic content} -constraints "Put ItemIO" -body {
+ set c "This is a test\n"
+ set x [S3::Put -bucket $bucket -content $c -resource "XYZ"]
+ set y [getbody /$bucket/XYZ]
+ set z [expr {$y eq $c}]
+ return "$x $z"
+} -cleanup {
+ delbody /$bucket/XYZ
+} -result "1 1"
+
+test S3-50.20 {Put, with a file} -constraints "Put ItemIO" -setup {
+ set c "This is the second test.\nIt is still a test.\n"
+ tcltest::makeFile $c "S3junk.txt"
+} -body {
+ set x [S3::Put -bucket $bucket -file "S3junk.txt" -resource "XYZ"]
+ set y [getbody /$bucket/XYZ]
+ set z [expr {$y eq $c}]
+ return "$x $z"
+} -cleanup {
+ delbody /$bucket/XYZ
+ tcltest::removeFile "S3junk.txt"
+} -result "1 1"
+
+test S3-50.30 {Put with ACL, content-type, meta} \
+ -constraints "Put ItemIO" -setup {
+ set c "This is the third test.\nIt is still a test.\n"
+ tcltest::makeFile $c "S3junk.txt"
+} -body {
+ set x [S3::Put -bucket $bucket -file "S3junk.txt" -resource "XYZ" \
+ -content-type "application/frobulate" -acl "public-read" \
+ -x-amz-meta-one ONE -x-amz-meta-two TWO]
+ set y {} ; set z {}
+ set req [dict create verb GET resource /$bucket/XYZ]
+ set res [S3::REST $req]
+ S3::throwhttp $res
+ set headers [dict get $res outheaders]
+ set y [dict get $headers content-type]
+ set w1 [dict get $headers x-amz-meta-one]
+ set w2 [dict get $headers x-amz-meta-two]
+
+ set d1 [dict create verb GET resource /$bucket/XYZ rtype acl]
+ set d2 [S3::REST $d1]
+ set d3 [string first "AllUsers" $d2]
+ set d4 [string first "READ" $d2]
+ set z [expr 0 < $d3 && $d3 < $d4]
+ return [list $x $y $z $w1 $w2]
+} -cleanup {
+ delbody /$bucket/XYZ
+ tcltest::removeFile "S3junk.txt"
+} -result "1 application/frobulate 1 ONE TWO"
+
+test S3-50.40 {Put -compare never} -constraints "Put ItemIO" -body {
+ set x [S3::Put -file S3junk.txt -bucket $bucket -resource "XYZ" \
+ -compare never]
+ set y [existsbody /$bucket/XYZ]
+ return "$x $y"
+} -cleanup {
+ if {[existsbody /$bucket/XYZ]} {delbody /$bucket/XYZ}
+} -result "0 0"
+
+test S3-50.50 {Put -compare always} \
+ -setup $pgsu -cleanup $pgcu -constraints "Put ItemIO" -body {
+ set x [S3::Put -file S3Talpha.txt -bucket $bucket -resource "XYZ" \
+ -compare always]
+ set y [existsbody /$bucket/XYZ]
+ set z [S3::Put -file S3Talpha.txt -bucket $bucket -resource "XYZ" \
+ -compare always]
+ return "$x $y $z"
+} -result "1 1 1"
+
+test S3-50.60 {Put -compare exists} \
+ -setup $pgsu -cleanup $pgcu -constraints "Put ItemIO" -body {
+ set x1 [S3::Put -file S3Tone.txt -bucket $bucket -resource "XYZ" \
+ -compare exists]
+ set x2 [existsbody /$bucket/XYZ]
+ S3::Put -file S3Tone.txt -bucket $bucket -resource "XYZ" ; # really make it
+ set y1 [S3::Put -file S3Ttwo.txt -bucket $bucket -resource "XYZ" \
+ -compare exists]
+ set y2 [existsbody /$bucket/XYZ]
+ set y3 [string trim [getbody /$bucket/XYZ]]
+ return [list $x1 $x2 $y1 $y2 $y3]
+} -result "0 0 1 1 FILETWO"
+
+test S3-50.70 {Put -compare missing} \
+ -setup $pgsu -cleanup $pgcu -constraints "Put ItemIO" -body {
+ set x1 [S3::Put -file S3Tone.txt -bucket $bucket -resource "XYZ" \
+ -compare missing]
+ set x2 [existsbody /$bucket/XYZ]
+ set y1 [S3::Put -file S3Ttwo.txt -bucket $bucket -resource "XYZ" \
+ -compare missing]
+ set y2 [existsbody /$bucket/XYZ]
+ set y3 [string trim [getbody /$bucket/XYZ]]
+ return [list $x1 $x2 $y1 $y2 $y3]
+} -result "1 1 0 1 FILEONE"
+
+test S3-50.80 {Put -compare newer} \
+ -setup $pgsu -cleanup $pgcu -constraints "Put ItemIO" -body {
+ # Create the file with the current date
+ S3::Put -file S3Tthree.txt -bucket $bucket -resource "XYZ"
+ # Make sure ONE (old) doesn't overwrite it.
+ set x1 [S3::Put -file S3Tone.txt -bucket $bucket -resource "XYZ" \
+ -compare newer]
+ set x2 [string trim [getbody /$bucket/XYZ]]
+ set y1 [S3::Put -file S3Ttwo.txt -bucket $bucket -resource "XYZ" \
+ -compare newer]
+ set y2 [string trim [getbody /$bucket/XYZ]]
+ return [list $x1 $x2 $y1 $y2]
+} -result "0 FILETHREE 1 FILETWO"
+
+test S3-50.90 {Put -compare date} \
+ -setup $pgsu -cleanup $pgcu -constraints "Put ItemIO" -body {
+ S3::Configure -slop-seconds 60
+ S3::Put -file S3Tthree.txt -bucket $bucket -resource "XYZ"
+ set x1 [S3::Put -file S3Tone.txt -bucket $bucket -resource "XYZ" \
+ -compare date]
+ set x2 [string trim [getbody /$bucket/XYZ]]
+ set y1 [S3::Put -file S3Tthree.txt -bucket $bucket -resource "XYZ" \
+ -compare date]
+ set y2 [string trim [getbody /$bucket/XYZ]]
+ set z1 [S3::Put -file S3Tthree.txt -bucket $bucket -resource "PDQ" \
+ -compare date]
+ set z2 [string trim [getbody /$bucket/PDQ]]
+ return [list $x1 $x2 $y1 $y2 $z1 $z2]
+} -result "1 FILEONE 0 FILEONE 1 FILETHREE"
+
+test S3-50.100 {Put -compare checksum} \
+ -setup $pgsu -cleanup $pgcu -constraints "Put ItemIO" -body {
+ S3::Put -file S3Talpha.txt -bucket $bucket -resource "XYZ"
+ set x1 [S3::Put -file S3Tbeta.txt -bucket $bucket -resource "XYZ" \
+ -compare checksum]
+ set x2 [S3::Put -file S3Tbeta.txt -bucket $bucket -resource "PDQ" \
+ -compare checksum]
+ set x3 [S3::Put -content "This is some random content\n" \
+ -bucket $bucket -resource "XYZ" \
+ -compare checksum]
+ set funky "One\u2211Sigma\u5927Da"
+ S3::Put -content $funky -bucket $bucket -resource "XYZ"
+ set x4 [S3::Put -content $funky -bucket $bucket -resource "XYZ" \
+ -compare checksum]
+ return [list $x1 $x2 $x3 $x4]
+} -result "0 1 0 0"
+
+test S3-50.110 {Put -compare different} \
+ -setup $pgsu -cleanup $pgcu -constraints "Put ItemIO" -body {
+ S3::Configure -slop-seconds 60
+ S3::Put -file S3Talpha.txt -bucket $bucket -resource "XYZ"
+ set x1 [S3::Put -file S3Tbeta.txt -bucket $bucket -resource "XYZ" \
+ -compare different]
+ set x2 [S3::Put -file S3Tgamma.txt -bucket $bucket -resource "XYZ" \
+ -compare different]
+ set x3 [S3::Put -file S3Tthree.txt -bucket $bucket -resource "XYZ" \
+ -compare different]
+ set x4 [string trim [getbody /$bucket/XYZ]]
+ set x5 [S3::Put -content "FILETHREE\n" -bucket $bucket -resource "XYZ" \
+ -compare different]
+ return [list $x1 $x2 $x3 $x4 $x5]
+} -result "1 0 1 FILETHREE 0"
+
+test S3-50.120 {Put -compare error} -constraints "Put ItemIO" -body {
+ S3expectErr [list S3::Put -content "STUFF" \
+ -bucket $bucket -resource "XYZ" \
+ -compare other]
+} -result "1 S3 usage -compare" -match S3err
+
+test S3-50.130 {Put -file nonexistant} -constraints "Put ItemIO" -body {
+ S3expectErr [list S3::Put -file nonexistant.txt \
+ -bucket $bucket -resource "XYZ"]
+} -result "1 S3 usage -file" -match S3err
+
+
+test S3-60.10 {Get, basic content} \
+ -setup $pgsu -cleanup $pgcu -constraints "Get ItemIO" -body {
+ set x [S3::Get -bucket $bucket -content abc -resource "ABC"]
+ set y [getbody /$bucket/ABC]
+ set z [expr {$y eq $abc}]
+ return "$x $z"
+} -result "1 1"
+
+test S3-60.20 {Get, with a file} \
+ -setup $pgsu -cleanup $pgcu -constraints "Get ItemIO" -body {
+ set x [S3::Get -bucket $bucket -file "S3junk.txt" -resource "ABC"]
+ set y [tcltest::viewFile S3junk.txt]
+ set z [expr {$y eq "ABC HERE"}]
+ return "$x $z"
+} -result "1 1"
+
+test S3-60.30 {Get with meta} \
+ -setup $pgsu -cleanup $pgcu -constraints "Get ItemIO" -body {
+ set x [S3::Get -bucket $bucket -file "S3junk.txt" -resource "ABC" \
+ -headers thishead]
+ set y [dict get $thishead content-type]
+ set z [dict get $thishead x-amz-meta-thing]
+ return [list $x $y $z]
+} -result "1 application/tcltest stuff"
+
+test S3-60.40 {Get -compare never} \
+ -setup $pgsu -cleanup $pgcu -constraints "Get ItemIO" -body {
+ set x [S3::Get -file S3junk.txt -bucket $bucket -resource "ABC" \
+ -compare never]
+ set y [file exists S3junk.txt]
+ return "$x $y"
+} -result "0 0"
+
+test S3-60.50 {Get -compare always} \
+ -setup $pgsu -cleanup $pgcu -constraints "Get ItemIO" -body {
+ set x [S3::Get -file S3junk.txt -bucket $bucket -resource "ABC" \
+ -compare always]
+ set y [file exists S3junk.txt]
+ set z [S3::Get -file S3junk.txt -bucket $bucket -resource "ABC" \
+ -compare always]
+ set q [S3::Get -content plover -bucket $bucket -resource "ABC" \
+ -compare always]
+ return "$x $y $z $q $plover"
+} -result "1 1 1 1 ABC HERE"
+
+test S3-60.60 {Get -compare exists} \
+ -setup $pgsu -cleanup $pgcu -constraints "Get ItemIO" -body {
+set x0 [file exists S3junk.txt]
+ set x1 [S3::Get -file S3junk.txt -bucket $bucket -resource "ABC" \
+ -compare exists]
+ set x2 [file exists S3junk.txt]
+ set y1 [S3::Get -file S3Tone.txt -bucket $bucket -resource "ABC" \
+ -compare exists]
+ set y2 [file exists S3Tone.txt]
+ set y3 [tcltest::viewFile S3Tone.txt]
+ return [list $x0 $x1 $x2 $y1 $y2 $y3]
+} -result "0 0 0 1 1 {ABC HERE}"
+
+test S3-60.70 {Get -compare missing} \
+ -setup $pgsu -cleanup $pgcu -constraints "Get ItemIO" -body {
+ set x1 [S3::Get -file S3Tone.txt -bucket $bucket -resource "ABC" \
+ -compare missing]
+ set x2 [file exists S3Tone.txt]
+ set y1 [S3::Get -file S3junk.txt -bucket $bucket -resource "ABC" \
+ -compare missing]
+ set y2 [file exists S3junk.txt]
+ set y3 [tcltest::viewFile S3junk.txt]
+ return [list $x1 $x2 $y1 $y2 $y3]
+} -result "0 1 1 1 {ABC HERE}"
+
+test S3-60.80 {Get -compare newer} \
+ -setup $pgsu -cleanup $pgcu -constraints "Get ItemIO" -body {
+ set x1 [S3::Get -file S3Tone.txt -bucket $bucket -resource "ABC" \
+ -compare newer]
+ set x2 [tcltest::viewFile S3Tone.txt]
+ set y1 [S3::Get -file S3Ttwo.txt -bucket $bucket -resource "ABC" \
+ -compare newer]
+ set y2 [tcltest::viewFile S3Ttwo.txt]
+ set z1 [S3::Get -file S3junk.txt -bucket $bucket -resource "ABC" \
+ -compare newer]
+ set z2 [tcltest::viewFile S3junk.txt]
+ set w1 [S3::Get -content w2 -bucket $bucket -resource "ABC" \
+ -compare newer]
+
+ return [list $x1 $x2 $y1 $y2 $z1 $z2 $w1 $w2]
+} -result "1 {ABC HERE} 0 FILETWO 1 {ABC HERE} 1 {ABC HERE}"
+
+test S3-60.90 {Get -compare date} \
+ -setup $pgsu -cleanup $pgcu -constraints "Get ItemIO" -body {
+ S3::Configure -slop-seconds 60
+ set x1 [S3::Get -file S3Tone.txt -bucket $bucket -resource "ABC" \
+ -compare date]
+ set x2 [tcltest::viewFile S3Tone.txt]
+ set y1 [S3::Get -file S3Ttwo.txt -bucket $bucket -resource "ABC" \
+ -compare date]
+ set y2 [tcltest::viewFile S3Ttwo.txt]
+ set z1 [S3::Get -file S3Tthree.txt -bucket $bucket -resource "ABC" \
+ -compare date]
+ set z2 [tcltest::viewFile S3Tthree.txt]
+ set w1 [S3::Get -content w2 -bucket $bucket -resource "ABC" \
+ -compare date]
+ return [list $x1 $x2 $y1 $y2 $z1 $z2 $w1 $w2]
+} -result "1 {ABC HERE} 1 {ABC HERE} 0 FILETHREE 1 {ABC HERE}"
+
+test S3-60.100 {Get -compare checksum} \
+ -setup $pgsu -cleanup $pgcu -constraints "Get ItemIO" -body {
+ S3::Put -file S3Talpha.txt -bucket $bucket -resource "XYZ"
+ set x1 [S3::Get -file S3Tbeta.txt -bucket $bucket -resource "XYZ" \
+ -compare checksum]
+ set x2 [S3::Get -file S3Tbeta.txt -bucket $bucket -resource "ABC" \
+ -compare checksum]
+ set x3 [tcltest::viewFile S3Tbeta.txt]
+ set x4 [S3::Get -content x5 -bucket $bucket -resource "ABC" \
+ -compare checksum]
+ return [list $x1 $x2 $x3 $x4 $x5]
+} -result "0 1 {ABC HERE} 1 {ABC HERE}"
+
+test S3-60.110 {Get -compare different} \
+ -setup $pgsu -cleanup $pgcu -constraints "Get ItemIO" -body {
+ S3::Configure -slop-seconds 60
+ S3::Put -file S3Talpha.txt -bucket $bucket -resource "XYZ"
+ set x0 [S3::Get -file S3junk.txt -bucket $bucket -resource "XYZ" \
+ -compare different] ; # Yes, file nonexistant
+ set x1 [S3::Get -file S3Talpha.txt -bucket $bucket -resource "XYZ" \
+ -compare different] ; # no, same date, same contents
+ set x2 [S3::Get -file S3Tbeta.txt -bucket $bucket -resource "XYZ" \
+ -compare different] ; # Yes, diff date, same contents.
+ set x3 [S3::Get -file S3Tbeta.txt -bucket $bucket -resource "ABC" \
+ -compare different] ; # Yes, diff contents, same date
+ set x4 [S3::Get -content x5 -bucket $bucket -resource "ABC" \
+ -compare different] ; # Yes, variable
+ set x6 [tcltest::viewFile S3Tbeta.txt]
+ return [list $x0 $x1 $x2 $x3 $x4 $x5 $x6]
+} -result "1 0 1 1 1 {ABC HERE} {ABC HERE}"
+
+test S3-60.120 {Get -compare error} -constraints "Get ItemIO" -body {
+ S3expectErr [list S3::Get -file S3Tone.txt \
+ -bucket $bucket -resource "XYZ" \
+ -compare other]
+} -result "1 S3 usage -compare" -match S3err
+
+test S3-60.130 {Get resource nonexistant, file nonexistant A} \
+ -setup $pgsu -cleanup $pgcu -constraints "Get ItemIO" -body {
+ S3expectErr [list S3::Get -file nonexistant.txt \
+ -bucket $bucket -resource "XYZ"]
+} -result "1 S3 remote 404" -match S3err
+
+test S3-60.131 {Get resource nonexistant, file nonexistant B} \
+ -setup $pgsu -cleanup $pgcu -constraints "Get ItemIO" -body {
+ catch {S3::Get -file nonexistant.txt -bucket $bucket -resource "XYZ"}
+ file exists nonexistant.txt
+} -result "0"
+
+test S3-60.132 {Get resource nonexistant, file existant B} \
+ -setup $pgsu -cleanup $pgcu -constraints "Get ItemIO" -body {
+ S3expectErr [list S3::Get -file S3Talpha.txt \
+ -bucket $bucket -resource "XYZ"]
+} -result "1 S3 remote 404" -match S3err
+
+test S3-60.133 {Get resource nonexistant, file existant A} \
+ -setup $pgsu -cleanup $pgcu -constraints "Get ItemIO" -body {
+ catch {S3::Get -file S3Talpha.txt -bucket $bucket -resource "XYZ"}
+ file exists S3Talpha.txt
+} -result "1"
+
+test S3-60.140 {Get with -timestamp options} \
+ -constraints "Get ItemIO" -body {
+ # This test assumes your clock and amazon's clock are within 10 seconds
+ tcltest::makeFile "RandomJunk" ts1.txt
+ tcltest::makeFile "RandomJunk" ts2.txt
+ after 10000
+ S3::Put -content "More random junk" -bucket $bucket -resource "TIMESTAMP"
+ after 5000
+ set tick [clock seconds]
+ after 5000
+ S3::Get -file ts1.txt -timestamp aws -bucket $bucket -resource "TIMESTAMP"
+ S3::Get -file ts2.txt -timestamp now -bucket $bucket -resource "TIMESTAMP"
+ set x1 [file mtime ts1.txt]
+ set x2 [file mtime ts2.txt]
+ return [list [expr $x1 < $tick] [expr $x2 < $tick]]
+} -cleanup {
+ tcltest::removeFile ts1.txt
+ tcltest::removeFile ts2.txt
+ if {[existsbody /$bucket/TIMESTAMP]} {delbody /$bucket/TIMESTAMP}
+} -result "1 0"
+
+test S3-70.10 {Head, resource exists} \
+ -setup $pgsu -cleanup $pgcu -constraints "Head ItemIO" -body {
+ set x1 [S3::Head -bucket $bucket -resource "ABC" -dict dict \
+ -headers headers -status status]
+ return [list $x1 [dict get $dict httpmessage] [dict exists $headers last-modified] $status]
+} -result "1 OK 1 {200 OK}"
+
+test S3-70.20 {Head, resource does not exist} \
+ -setup $pgsu -cleanup $pgcu -constraints "Head ItemIO" -body {
+ set x1 [S3::Head -bucket $bucket -resource "XYZ" -dict dict \
+ -headers headers -status status]
+ return [list $x1 $status]
+} -result "0 {404 {Not Found}}"
+
+test S3-80.10 {Delete, resource exists} \
+ -setup $pgsu -cleanup $pgcu -constraints "Delete ItemIO" -body {
+ set x1 [S3::Delete -bucket $bucket -resource "ABC" -status status]
+ return [list $x1 $status]
+} -result "1 {204 {No Content}}"
+
+test S3-80.20 {Delete, resource nonexistant} \
+ -setup $pgsu -cleanup $pgcu -constraints "Delete ItemIO" -body {
+ set x1 [S3::Delete -bucket $bucket -resource "XYZ" -status status]
+ return [list $x1 $status]
+} -result "1 {204 {No Content}}"
+
+test S3-80.30 {Delete, resource not mine} \
+ -setup $pgsu -cleanup $pgcu -constraints "Delete ItemIO" -body {
+ # Note that ami.prizecapital.net is also mine, but owned by a client.
+ set x1 [S3::Delete -bucket "ami.prizecapital.net" \
+ -resource "README.txt" -status status]
+ return [list $x1 $status]
+} -result "0 {403 Forbidden}"
+
+test S3-90.10 {GetAcl REST} \
+ -setup $pgsu -cleanup $pgcu -constraints "Acl" -body {
+#set x1 [S3::GetAcl -bucket $bucket -resource "ABC" -result-type xml]
+#puts "\n\n$x1\n\n"
+ set x2 [S3::GetAcl -bucket $bucket -resource "ABC" -result-type REST]
+ return [list [dict get $x2 httpstatus] [string index [dict get $x2 outbody] 0]]
+} -result "200 <"
+
+#test S3-90.11 {GetAcl XML} \
+ #-setup $pgsu -constraints "Zap" -body {
+ #set x2 [S3::GetAcl -bucket $bucket -resource "ABC" -result-type xml]
+ #set x3 [open xyzzy.xml w]
+ #fconfigure $x3 -translation binary -encoding binary
+ #puts $x3 $x2
+ #close $x3
+ #exit
+ #set x2 [S3::PutAcl -bucket $bucket -resource "ABC" -acl \
+ #[string trim [read [open xyzzy.xml]]]]
+ #puts $x2 ; exit
+#} -result 1
+
+test S3-90.20 {GetAcl pxml} \
+ -setup $pgsu -cleanup $pgcu -constraints "Acl" -body {
+ set x2 [S3::GetAcl -bucket $bucket -resource "ABC" -result-type pxml]
+ return [list [lindex $x2 0] [lindex $x2 2 0]]
+} -result "AccessControlPolicy Owner"
+
+test S3-90.30 {GetAcl dict} \
+ -setup $pgsu -cleanup $pgcu -constraints "Acl" -body {
+ set x2 [S3::GetAcl -bucket $bucket -resource "ABC" -result-type dict]
+ set owner [dict get $x2 owner]
+ set acl [dict get $x2 acl]
+ set z1 [dict get $acl FULL_CONTROL]
+ set z2 [expr {$owner == $z1}]
+ return $z2
+} -result "1"
+
+test S3-90.40 {GetAcl -parse-xml} \
+ -constraints "Acl" -body {
+ set xml {<?xml version="1.0" encoding="UTF-8"?>
+<AccessControlPolicy xmlns="http://s3.amazonaws.com/doc/2006-03-01/"><Owner><ID>9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd</ID><DisplayName>dnew@san.rr.com</DisplayName></Owner><AccessControlList><Grant><Grantee xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:type="Group"><URI>http://acs.amazonaws.com/groups/global/AllUsers</URI></Grantee><Permission>FULL_CONTROL</Permission></Grant><Grant><Grantee xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:type="CanonicalUser"><ID>9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd</ID><DisplayName>dnew@san.rr.com</DisplayName></Grantee><Permission>FULL_CONTROL</Permission></Grant><Grant><Grantee xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:type="CanonicalUser"><ID>a5ee16f393707820a7f2d58631351fe839972d25865f8fc423a754d77523e6d4</ID><DisplayName>darren</DisplayName></Grantee><Permission>READ</Permission></Grant><Grant><Grantee xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:type="CanonicalUser"><ID>a1bf9e3c79a243e04e31bf3d1f532aca94646ab917c188831241bf5d575fee92</ID><DisplayName>Darren</DisplayName></Grantee><Permission>WRITE</Permission></Grant></AccessControlList></AccessControlPolicy>}
+ set x2 [S3::GetAcl -parse-xml $xml -result-type dict]
+ return $x2
+} -result "owner 9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd acl {READ a5ee16f393707820a7f2d58631351fe839972d25865f8fc423a754d77523e6d4 WRITE a1bf9e3c79a243e04e31bf3d1f532aca94646ab917c188831241bf5d575fee92 FULL_CONTROL {http://acs.amazonaws.com/groups/global/AllUsers 9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd}}"
+
+test S3-90.50 {PutAcl private} \
+ -setup $pgsu -cleanup $pgcu -constraints "Acl" -body {
+ set x1 [S3::PutAcl -bucket $bucket -resource "ABC" -acl private]
+ set x2 [S3::GetAcl -bucket $bucket -resource "ABC" -result-type dict]
+ set x3 [dict get $x2 acl]
+ set x4 [llength $x3]
+ return [list [string range $x1 0 19] $x4 [lindex $x3 0]]
+} -result "<AccessControlPolicy 2 FULL_CONTROL"
+
+test S3-90.60 {PutAcl nonexistant get} \
+ -setup $pgsu -cleanup $pgcu -constraints "Acl" -body {
+ S3expectErr [list S3::PutAcl -bucket $bucket -resource XYZ -acl private]
+} -result "1 S3 remote 404" -match S3err
+
+test S3-90.70 {PutAcl nonexistant put} \
+ -setup $pgsu -cleanup $pgcu -constraints "Acl" -body {
+ set x2 [S3::GetAcl -bucket $bucket -resource "ABC" -result-type dict]
+ set owner [dict get $x2 owner]
+ S3expectErr [list S3::PutAcl -owner $owner \
+ -bucket $bucket -resource XYZ -acl private]
+} -result "1 S3 remote 404" -match S3err
+
+test S3-90.80 {PutAcl from xml} \
+ -setup $pgsu -cleanup $pgcu -constraints "Acl" -body {
+ set x0 [S3::GetAcl -bucket $bucket -resource "ABC" -result-type xml]
+ set x1 [S3::PutAcl -bucket $bucket -resource "ABC" -acl $x0]
+ set x2 [S3::GetAcl -bucket $bucket -resource "ABC" -result-type dict]
+ set x3 [dict get $x2 acl]
+ set x4 [llength $x3]
+ if {"<?xml" == [string range $x1 0 4]} {
+ set x1 [string range $x1 [expr 1+[string first "\n" $x1]] end]
+ }
+ return [list [string range $x1 0 19] $x4 [lindex $x3 0]]
+} -result "<AccessControlPolicy 2 FULL_CONTROL"
+
+test S3-90.90 {PutAcl public} \
+ -setup $pgsu -cleanup $pgcu -constraints "Acl" -body {
+ S3expectErr [list S3::PutAcl -bucket $bucket -resource "ABC" -acl public]
+} -result "1 S3 usage -acl public" -match S3err
+
+test S3-90.100 {PutAcl public-read} \
+ -setup $pgsu -cleanup $pgcu -constraints "Acl" -body {
+ set x1 [S3::PutAcl -bucket $bucket -resource "ABC" -acl public-read]
+ set x2 [S3::GetAcl -bucket $bucket -resource "ABC" -result-type dict]
+ set x3 [dict get $x2 acl]
+ set x4 [llength $x3]
+ set x5 [lsort [dict keys $x3]]
+ return [list [string range $x1 0 19] $x4 $x5]
+} -result "<AccessControlPolicy 4 {FULL_CONTROL READ}"
+
+test S3-90.110 {PutAcl public-read-write} \
+ -setup $pgsu -cleanup $pgcu -constraints "Acl" -body {
+ set x1 [S3::PutAcl -bucket $bucket -resource "ABC" -acl public-read-write]
+ set x2 [S3::GetAcl -bucket $bucket -resource "ABC" -result-type dict]
+ set x3 [dict get $x2 acl]
+ set x4 [llength $x3]
+ set x5 [lsort [dict keys $x3]]
+ return [list [string range $x1 0 19] $x4 $x5]
+} -result "<AccessControlPolicy 6 {FULL_CONTROL READ WRITE}"
+
+test S3-90.120 {PutAcl authenticated-read} \
+ -setup $pgsu -cleanup $pgcu -constraints "Acl" -body {
+ set x1 [S3::PutAcl -bucket $bucket -resource "ABC" -acl authenticated-read]
+ set x2 [S3::GetAcl -bucket $bucket -resource "ABC" -result-type dict]
+ set x3 [dict get $x2 acl]
+ set x4 [llength $x3]
+ set x5 [lsort [dict keys $x3]]
+ return [list [string range $x1 0 19] $x4 $x5]
+} -result "<AccessControlPolicy 4 {FULL_CONTROL READ}"
+
+test S3-90.130 {PutAcl complex} \
+ -setup $pgsu -cleanup $pgcu -constraints "Acl" -body {
+ set dict [dict create \
+ FULL_CONTROL {9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd AuthenticatedUsers} \
+ WRITE darren@prizecapital.net \
+ READ http://acs.amazonaws.com/groups/global/AllUsers ]
+ set x1 [S3::PutAcl -bucket $bucket -resource "ABC" -acl $dict]
+ set x2 [S3::GetAcl -bucket $bucket -resource "ABC" -result-type dict]
+ set x3 [dict get $x2 acl]
+ set x4 [llength $x3]
+ return [list [string range $x1 0 19] [lsort [dict keys $x3]]]
+} -result "<AccessControlPolicy {FULL_CONTROL READ WRITE}"
+
+test S3-90.140 {Put with keep on existing object} \
+ -setup $pgsu -cleanup $pgcu -constraints "Acl" -body {
+ set dict [dict create \
+ FULL_CONTROL {9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd AuthenticatedUsers} \
+ WRITE darren@prizecapital.net \
+ READ http://acs.amazonaws.com/groups/global/AllUsers ]
+ set x1 [S3::PutAcl -bucket $bucket -resource "ABC" -acl $dict]
+ S3::Put -bucket $bucket -resource "ABC" -file "S3Tone.txt" -acl keep
+ set x2 [S3::GetAcl -bucket $bucket -resource "ABC" -result-type dict]
+ set x3 [dict get $x2 acl]
+ set x4 [llength $x3]
+ return [list [string range $x1 0 19] [lsort [dict keys $x3]]]
+} -result "<AccessControlPolicy {FULL_CONTROL READ WRITE}"
+
+test S3-90.150 {Put with keep on new object} \
+ -setup $pgsu -cleanup $pgcu -constraints "Acl" -body {
+ S3::Put -bucket $bucket -resource "XYZ" -file "S3Tone.txt" -acl keep
+ set x2 [S3::GetAcl -bucket $bucket -resource "ABC" -result-type dict]
+ set x3 [dict get $x2 acl]
+ set x4 [llength $x3]
+ return [list [string range $x1 0 19] [lsort [dict keys $x3]]]
+} -result "<AccessControlPolicy FULL_CONTROL"
+
+
+test S3-100.10 {Pull} \
+ -setup S3loadKeys -constraints "Directory ItemIO" -body {
+ # I actually tested this manually much more extensively,
+ # but some of the tests are difficult, due to needing to
+ # set up a bunch of directories with different permissions, etc.
+ set bucket [S3::SuggestBucket TclTestS3b]
+ set dir S3Tdir
+ catch {file delete -force -- $dir}
+ file mkdir $dir
+ set res [S3::Pull -bucket $bucket -prefix thing \
+ -directory $dir -compare always -delete true]
+ set r1 [dict get $res {} filescopied]
+ set r2 [dict get $res {} errorskipped]
+ set r3 [dict get $res {} filesdeleted]
+ set r4 [file exists [file join $dir 00/6]]
+ return [list $r1 $r2 $r3 $r4]
+} -cleanup {
+ file delete -force -- $dir
+} -result {250 0 0 1}
+
+test S3-100.20 {Push} \
+ -setup S3loadKeys -constraints "Directory ItemIO" -body {
+ set bucket [S3::SuggestBucket TclTestS3b]
+ set dir S3Tdir
+ catch {file delete -force -- $dir}
+ file mkdir $dir
+ set res [S3::Pull -bucket $bucket -prefix thing \
+ -directory $dir -compare always -delete true]
+ set r1 [dict get $res {} filescopied]
+ set r2 [dict get $res {} errorskipped]
+ set r3 [dict get $res {} filesdeleted]
+ set r4 [file exists [file join $dir 00/6]]
+ # Now the rest of the test... :-)
+ set bucket [S3::SuggestBucket TclTestS3] ; # different bucket
+ set res [S3::Push -bucket $bucket -prefix hither/yon \
+ -directory $dir -compare always -delete true]
+ set r5 [dict get $res {} filescopied]
+ set r6 [dict get $res {} errorskipped]
+ set r7 [dict get $res {} filesdeleted]
+ set res [S3::REST [dict create verb HEAD resource /$bucket/hither/yon/00/6]]
+ set r8 [dict get $res httpstatus]
+ return [list $r1 $r2 $r3 $r4 $r5 $r6 $r7 $r8]
+} -cleanup {
+ file delete -force -- $dir
+ set bucket [S3::SuggestBucket TclTestS3]
+ set names [S3::GetBucket -bucket $bucket -prefix hither/yon \
+ -result-type names]
+ foreach name $names {
+ S3::Delete -bucket $bucket -resource $name
+ }
+} -result {250 0 0 1 250 0 0 200}
+
+test S3-100.30 {Push with deletes and stuff} \
+ -setup S3loadKeys -constraints "Directory ItemIO" -body {
+ set bucket [S3::SuggestBucket TclTestS3b]
+ set dir S3Tdir
+ catch {file delete -force -- $dir}
+ file mkdir $dir
+ set res [S3::Pull -bucket $bucket -prefix thing \
+ -directory $dir -compare always -delete true]
+ set r1 [dict get $res {} filescopied]
+ set r2 [dict get $res {} errorskipped]
+ set r3 [dict get $res {} filesdeleted]
+ set r4 [file exists [file join $dir 00/6]]
+ set bucket [S3::SuggestBucket TclTestS3] ; # different bucket
+ set res [S3::Push -bucket $bucket -prefix hither/yon \
+ -directory $dir -compare always -delete true]
+ set r5 [dict get $res {} filescopied]
+ set r6 [dict get $res {} errorskipped]
+ set r7 [dict get $res {} filesdeleted]
+ set res [S3::REST [dict create verb HEAD resource /$bucket/hither/yon/00/6]]
+ set r8 [dict get $res httpstatus]
+ # Now the rest of the test... :-)
+ file delete -force [file join $dir 03]
+ tcltest::makeFile "xxx" [file join $dir "j1.txt"]
+ tcltest::makeFile "xxx" [file join $dir "j2.txt"]
+ # Sadly, makefile insists on adding newlines
+ set x [open [file join $dir j1.txt] w];puts -nonewline $x "123456";close $x
+ set x [open [file join $dir j2.txt] w];puts -nonewline $x "678901";close $x
+ set res [S3::Push -bucket $bucket -prefix hither/yon \
+ -directory $dir -compare missing -delete true]
+ set r9 [dict get $res {} filescopied]
+ set r10 [dict get $res {} errorskipped]
+ set r11 [dict get $res {} filesdeleted]
+ set r12 [dict get $res {} bytescopied]
+ set res [S3::REST [dict create verb HEAD resource /$bucket/hither/yon/08/7]]
+ set r13 [dict get $res httpstatus]
+ set res [S3::REST [dict create verb HEAD resource /$bucket/hither/yon/j1.txt]]
+ set r14 [dict get $res httpstatus]
+ return [list $r1 $r2 $r3 $r4 $r5 $r6 $r7 $r8 $r9 $r10 $r11 $r12 $r13 $r14]
+} -cleanup {
+ file delete -force -- $dir
+ set bucket [S3::SuggestBucket TclTestS3]
+ set names [S3::GetBucket -bucket $bucket -prefix hither/yon \
+ -result-type names]
+ foreach name $names {
+ S3::Delete -bucket $bucket -resource $name
+ }
+} -result {250 0 0 1 250 0 0 200 2 0 10 12 200 200}
+
+test S3-100.40 {Pull with deletes and stuff} \
+ -setup S3loadKeys -constraints "Directory ItemIO" -body {
+ set bucket [S3::SuggestBucket TclTestS3b]
+ set dir S3Tdir
+ catch {file delete -force -- $dir}
+ file mkdir $dir
+ set res [S3::Pull -bucket $bucket -prefix thing \
+ -directory $dir -compare always -delete true]
+ set r1 [dict get $res {} filescopied]
+ set r2 [dict get $res {} errorskipped]
+ set r3 [dict get $res {} filesdeleted]
+ set r4 [file exists [file join $dir 00/6]]
+ set bucket [S3::SuggestBucket TclTestS3] ; # different bucket
+ set res [S3::Push -bucket $bucket -prefix hither/yon \
+ -directory $dir -compare always -delete true]
+ set r5 [dict get $res {} filescopied]
+ set r6 [dict get $res {} errorskipped]
+ set r7 [dict get $res {} filesdeleted]
+ set res [S3::REST [dict create verb HEAD resource /$bucket/hither/yon/00/6]]
+ set r8 [dict get $res httpstatus]
+ file delete -force [file join $dir 03]
+ tcltest::makeFile "xxx" [file join $dir "j1.txt"]
+ tcltest::makeFile "xxx" [file join $dir "j2.txt"]
+ # Sadly, makefile insists on adding newlines
+ set x [open [file join $dir j1.txt] w];puts -nonewline $x "123456";close $x
+ set x [open [file join $dir j2.txt] w];puts -nonewline $x "678901";close $x
+ set res [S3::Push -bucket $bucket -prefix hither/yon \
+ -directory $dir -compare missing -delete true]
+ set r9 [dict get $res {} filescopied]
+ set r10 [dict get $res {} errorskipped]
+ set r11 [dict get $res {} filesdeleted]
+ set r12 [dict get $res {} bytescopied]
+ set res [S3::REST [dict create verb HEAD resource /$bucket/hither/yon/08/7]]
+ set r13 [dict get $res httpstatus]
+ set res [S3::REST [dict create verb HEAD resource /$bucket/hither/yon/j1.txt]]
+ set r14 [dict get $res httpstatus]
+ # Now the rest of the test... :-)
+ file mkdir [file join $dir ToDelete]
+ set x [open [file join $dir ToDelete T1.txt] w];puts $x "Hello";close $x
+ set x [open [file join $dir ToDelete T2.txt] w];puts $x "World";close $x
+ set bucket [S3::SuggestBucket TclTestS3b]
+ set res [S3::Pull -bucket $bucket -prefix thing \
+ -directory $dir -compare missing -delete true]
+ set r15 [dict get $res {} filescopied] ; # The 03 directory
+ set r16 [dict get $res {} compareskipped] ; # The rest.
+ set r17 [dict get $res {} filesdeleted] ; # j1, j2, T1, T2, ToDelete
+ return [list $r1 $r2 $r3 $r4 $r5 $r6 $r7 $r8 $r9 $r10 $r11 $r12 $r13 $r14 $r15 $r16 $r17]
+} -cleanup {
+ file delete -force -- $dir
+ set bucket [S3::SuggestBucket TclTestS3]
+ set names [S3::GetBucket -bucket $bucket -prefix hither/yon \
+ -result-type names]
+ foreach name $names {
+ S3::Delete -bucket $bucket -resource $name
+ }
+} -result {250 0 0 1 250 0 0 200 2 0 10 12 200 200 10 240 5}
+
+test S3-100.50 {Push and Pull with -compare never -delete true} \
+ -setup S3loadKeys -constraints "Directory ItemIO" -body {
+ # This test creates 00 thru 09 in a bucket and a local dir.
+ # It then deletes 07 from the bucket and 03 locally.
+ # It then pushes and pulls with -compare never -delete true.
+ # It expects 0 files copied and 10/11 deleted.
+ # It then checks the deletes happened.
+ set bucket [S3::SuggestBucket TclTestS3b]
+ set dir S3Tdir
+ catch {file delete -force -- $dir}
+ file mkdir $dir
+ set res [S3::Pull -bucket $bucket -prefix thing \
+ -directory $dir -compare always -delete true]
+ set bucket [S3::SuggestBucket TclTestS3] ; # different bucket
+ set res [S3::Push -bucket $bucket -prefix hither/yon \
+ -directory $dir -compare always -delete true]
+ for {set i 0} {$i <= 9} {incr i} {
+ S3::Delete -bucket $bucket -resource hither/yon/07/$i
+ }
+ file delete -force [file join $dir 03]
+ set res [S3::Push -bucket $bucket -prefix hither/yon \
+ -directory $dir -compare never -delete true]
+ set r1 [dict get $res {} filescopied]
+ set r2 [dict get $res {} errorskipped]
+ set r3 [dict get $res {} filesdeleted]
+ set res [S3::REST [dict create verb HEAD resource /$bucket/hither/yon/03/7]]
+ set r4 [dict get $res httpstatus]
+ set res [S3::Pull -bucket $bucket -prefix hither/yon \
+ -directory $dir -compare never -delete true]
+ set r5 [dict get $res {} filescopied]
+ set r6 [dict get $res {} errorskipped]
+ set r7 [dict get $res {} filesdeleted]
+ set r8 [file exists [file join $dir 07 4]]
+ set r9 [file exists [file join $dir 07]]
+ return [list $r1 $r2 $r3 $r4 $r5 $r6 $r7 $r8 $r9]
+} -cleanup {
+ file delete -force -- $dir
+ set bucket [S3::SuggestBucket TclTestS3]
+ set names [S3::GetBucket -bucket $bucket -prefix hither/yon \
+ -result-type names]
+ foreach name $names {
+ S3::Delete -bucket $bucket -resource $name
+ }
+} -result {0 0 10 404 0 0 11 0 0}
+
+test S3-100.60 {Toss} \
+ -setup S3loadKeys -constraints "Directory ItemIO" -body {
+ set bucket [S3::SuggestBucket TclTestS3b]
+ set dir S3Tdir
+ catch {file delete -force -- $dir}
+ file mkdir $dir
+ set res [S3::Pull -bucket $bucket -prefix thing \
+ -directory $dir -compare missing -delete true]
+ set bucket [S3::SuggestBucket TclTestS3] ; # different bucket
+ set res [S3::Push -bucket $bucket -prefix hither/yon \
+ -directory $dir -compare missing -delete true]
+ set res [S3::Toss -bucket $bucket -prefix /hither]
+ set r1 [dict get $res {} filesdeleted]
+ set r2 [dict get $res {} filesnotdeleted]
+ return [list $r1 $r2]
+} -cleanup {
+ file delete -force -- $dir
+ set bucket [S3::SuggestBucket TclTestS3]
+ set names [S3::GetBucket -bucket $bucket -prefix hither/yon \
+ -result-type names]
+ foreach name $names {
+ S3::Delete -bucket $bucket -resource $name
+ }
+} -result {250 0}
+
+# set res [S3::REST {resource /darren/xyzzyplover verb HEAD}]
+# puts $res\n\n\n ; after 3000
+# set res [S3::REST [list resource /$bucket/fred verb HEAD]]
+# puts $res\n\n\n ; after 3000
+# set res [dict get $res outheaders]
+# set remote_length [dict get $res content-length]
+# set remote_etag [string trim [dict get $res etag] \"]
+# set remote_date [clock scan [dict get $res last-modified]]
+# puts "remote_length=$remote_length"
+# puts "remote_etag=$remote_etag"
+# puts "remote_date=$remote_date"
+# puts "\n\n"
+# set body "ABC\u2211S\u5927D"
+# set res [S3::REST [list resource /darren/plover verb PUT inbody $body]]
+# set res [S3::REST [list resource /darren/plover verb HEAD]]
+# puts $res\n\n\n ; after 3000
+
+CleanUpBuckets [tcltest::testConstraint BucketDeletion]
+
+#----------------------------------------------------------------------
+
+testsuiteCleanup
+puts "(If anything failed, check all test buckets got cleaned up!)"
+puts "Done!" ; after 5000
diff --git a/tcllib/modules/amazon-s3/TODO.txt b/tcllib/modules/amazon-s3/TODO.txt
new file mode 100644
index 0000000..1b4fda2
--- /dev/null
+++ b/tcllib/modules/amazon-s3/TODO.txt
@@ -0,0 +1,20 @@
+STILL TO DO: Implement S3::Acl.
+
+STILL TO DO: Optional argument to Put and Get for compares: remote
+bucket holding the contents you're comparing, so if you do a GetBucket
+you don't have to do Head.
+
+STILL TO DO: Parse headers with multiple lines per header. (Especially
+x-amz-meta-* headers.)
+
+STILL TO DO: Fix Push, Pull, Toss to not be cut-paste development.
+
+STILL TO DO: Add test to check that -compare never -delete true does
+what you would want it to do.
+
+STILL TO DO: Modify S3.tcl to remove xsxp and use TclDOM instead.
+
+STILL TO DO: Add UI, both command-line and graphical.
+
+STILL TO DO: Finish OddJob, a separate application based on S3.
+
diff --git a/tcllib/modules/amazon-s3/pkgIndex.tcl b/tcllib/modules/amazon-s3/pkgIndex.tcl
new file mode 100644
index 0000000..1d4f197
--- /dev/null
+++ b/tcllib/modules/amazon-s3/pkgIndex.tcl
@@ -0,0 +1,9 @@
+# pkgIndex.tcl --
+# Copyright (c) 2006 Darren New
+# This is for the Amazon S3 web service packages.
+
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+
+package ifneeded xsxp 1.0 [list source [file join $dir xsxp.tcl]]
+package ifneeded S3 1.0.3 [list source [file join $dir S3.tcl]]
+
diff --git a/tcllib/modules/amazon-s3/test-S3.config b/tcllib/modules/amazon-s3/test-S3.config
new file mode 100644
index 0000000..2dad351
--- /dev/null
+++ b/tcllib/modules/amazon-s3/test-S3.config
@@ -0,0 +1,2 @@
+S3::Configure -accesskeyid use-yours \
+-secretaccesskey put-yours-here
diff --git a/tcllib/modules/amazon-s3/xsxp.man b/tcllib/modules/amazon-s3/xsxp.man
new file mode 100644
index 0000000..3f66da8
--- /dev/null
+++ b/tcllib/modules/amazon-s3/xsxp.man
@@ -0,0 +1,137 @@
+[manpage_begin xsxp n 1.0]
+[keywords dom]
+[keywords parser]
+[keywords xml]
+[moddesc {Amazon S3 Web Service Utilities}]
+[titledesc {eXtremely Simple Xml Parser}]
+[copyright {Copyright 2006 Darren New. All Rights Reserved.}]
+[category {Text processing}]
+[require Tcl 8.4]
+[require xsxp 1]
+[require xml]
+[description]
+This package provides a simple interface to parse XML into a pure-value list.
+It also provides accessor routines to pull out specific subtags,
+not unlike DOM access.
+This package was written for and is used by Darren New's Amazon S3 access package.
+
+[para]
+This is pretty lame, but I needed something like this for S3,
+and at the time, TclDOM would not work with the new 8.5 Tcl
+due to version number problems.
+[para]
+In addition, this is a pure-value implementation. There is no
+garbage to clean up in the event of a thrown error, for example.
+This simplifies the code for sufficiently small XML documents,
+which is what Amazon's S3 guarantees.
+
+[para]
+Copyright 2006 Darren New. All Rights Reserved.
+NO WARRANTIES OF ANY TYPE ARE PROVIDED.
+COPYING OR USE INDEMNIFIES THE AUTHOR IN ALL WAYS.
+This software is licensed under essentially the same
+terms as Tcl. See LICENSE.txt for the terms.
+
+[section COMMANDS]
+The package implements five rather simple procedures.
+One parses, one is for debugging, and the rest pull various
+parts of the parsed document out for processing.
+
+[list_begin definitions]
+
+[call [cmd xsxp::parse] [arg xml]]
+
+This parses an XML document (using the standard xml tcllib module in a SAX sort of way) and builds a data structure which it returns if the parsing succeeded. The return value is referred to herein as a "pxml", or "parsed xml". The list consists of two or more elements:
+
+[list_begin itemized]
+[item]
+The first element is the name of the tag.
+[item]
+The second element is an array-get formatted list of key/value pairs. The keys are attribute names and the values are attribute values. This is an empty list if there are no attributes on the tag.
+[item]
+The third through end elements are the children of the node, if any. Each child is, recursively, a pxml.
+[item]
+Note that if the zero'th element, i.e. the tag name, is "%PCDATA", then
+the attributes will be empty and the third element will be the text of the element. In addition, if an element's contents consists only of PCDATA, it will have only one child, and all the PCDATA will be concatenated. In other words,
+this parser works poorly for XML with elements that contain both child tags and PCDATA. Since Amazon S3 does not do this (and for that matter most
+uses of XML where XML is a poor choice don't do this), this is probably
+not a serious limitation.
+[list_end]
+
+[para]
+
+[call [cmd xsxp::fetch] [arg pxml] [arg path] [opt [arg part]]]
+
+[arg pxml] is a parsed XML, as returned from xsxp::parse.
+[arg path] is a list of element tag names. Each element is the name
+of a child to look up, optionally followed by a
+hash ("#") and a string of digits. An empty list or an initial empty element
+selects [arg pxml]. If no hash sign is present, the behavior is as if "#0"
+had been appended to that element. (In addition to a list, slashes can separate subparts where convenient.)
+
+[para]
+
+An element of [arg path] scans the children at the indicated level
+for the n'th instance of a child whose tag matches the part of the
+element before the hash sign. If an element is simply "#" followed
+by digits, that indexed child is selected, regardless of the tags
+in the children. Hence, an element of "#3" will always select
+the fourth child of the node under consideration.
+
+[para]
+[arg part] defaults to "%ALL". It can be one of the following case-sensitive terms:
+[list_begin definitions]
+[def %ALL] returns the entire selected element.
+[def %TAGNAME] returns lindex 0 of the selected element.
+[def %ATTRIBUTES] returns index 1 of the selected element.
+
+[def %CHILDREN] returns lrange 2 through end of the selected element,
+resulting in a list of elements being returned.
+
+[def %PCDATA] returns a concatenation of all the bodies of
+direct children of this node whose tag is %PCDATA.
+It throws an error if no such children are found. That
+is, part=%PCDATA means return the textual content found
+in that node but not its children nodes.
+
+[def %PCDATA?] is like %PCDATA, but returns an empty string if
+no PCDATA is found.
+
+[list_end]
+
+[para]
+For example, to fetch the first bold text from the fifth paragraph of the body of your HTML file,
+[example {xsxp::fetch $pxml {body p#4 b} %PCDATA}]
+
+[para]
+
+[call [cmd xsxp::fetchall] [arg pxml_list] [arg path] [opt [arg part]]]
+
+This iterates over each PXML in [arg pxml_list] (which must be a list
+of pxmls) selecting the indicated path from it, building a new list
+with the selected data, and returning that new list.
+
+[para]
+
+For example, [arg pxml_list] might be
+the %CHILDREN of a particular element, and the [arg path] and [arg part]
+might select from each child a sub-element in which we're interested.
+
+[para]
+
+[call [cmd xsxp::only] [arg pxml] [arg tagname]]
+This iterates over the direct children of [arg pxml] and selects only
+those with [arg tagname] as their tag. Returns a list of matching
+elements.
+
+[para]
+
+[call [cmd xsxp::prettyprint] [arg pxml] [opt [arg chan]]]
+This outputs to [arg chan] (default stdout) a pretty-printed
+version of [arg pxml].
+
+[list_end]
+
+[vset CATEGORY amazon-s3]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/amazon-s3/xsxp.tcl b/tcllib/modules/amazon-s3/xsxp.tcl
new file mode 100644
index 0000000..1fc2042
--- /dev/null
+++ b/tcllib/modules/amazon-s3/xsxp.tcl
@@ -0,0 +1,254 @@
+# xsxp.tcl --
+#
+###Abstract
+# Extremely Simple XML Parser
+#
+# This is pretty lame, but I needed something like this for S3,
+# and at the time, TclDOM would not work with the new 8.5 Tcl
+# due to version number problems.
+#
+# In addition, this is a pure-value implementation. There is no
+# garbage to clean up in the event of a thrown error, for example.
+# This simplifies the code for sufficiently small XML documents,
+# which is what Amazon's S3 guarantees.
+#
+###Copyright
+# Copyright (c) 2006 Darren New.
+# All Rights Reserved.
+# NO WARRANTIES OF ANY TYPE ARE PROVIDED.
+# COPYING OR USE INDEMNIFIES THE AUTHOR IN ALL WAYS.
+# See the license terms in LICENSE.txt
+#
+###Revision String
+# SCCS: %Z% %M% %I% %E% %U%
+
+# xsxp::parse $xml
+# Returns a parsed XML, or PXML. A pxml is a list.
+# The first element is the name of the tag.
+# The second element is a list of name/value pairs of the
+# associated attribues, if any.
+# The third thru final values are recursively PXML values.
+# If the first element (element zero, that is) is "%PCDATA",
+# then the attributes will be emtpy and the third element
+# will be the text of the element.
+
+# xsxp::fetch $pxml $path ?$part?
+# $pxml is a parsed XML, as returned from xsxp::parse.
+# $path is a list of elements. Each element is the name of
+# a child to look up, optionally followed by a hash ("#")
+# and a string of digits. An emtpy list or an initial empty
+# element selects $pxml. If no hash sign is present, the
+# behavior is as if "#0" had been appended to that element.
+# An element of $path scans the children at the indicated
+# level for the n'th instance of a child whose tag matches
+# the part of the element before the hash sign. If an element
+# is simply "#" followed by digits, that indexed child is
+# selected, regardless of the tags in the children. So
+# an element of #3 will always select the fourth child
+# of the node under consideration.
+# $part defaults to %ALL. It can be one of the following:
+# %ALL - returns the entire selected element.
+# %TAGNAME - returns lindex 0 of the selected element.
+# %ATTRIBUTES - returns lindex 1 of the selected element.
+# %CHILDREN - returns lrange 2 through end of the selected element,
+# resulting in a list of elements being returned.
+# %PCDATA - returns a concatenation of all the bodies of
+# direct children of this node whose tag is %PCDATA.
+# Throws an error if no such children are found. That
+# is, part=%PCDATA means return the textual content found
+# in that node but not its children nodes.
+# %PCDATA? - like %PCDATA, but returns an empty string if
+# no PCDATA is found.
+
+# xsxp::fetchall $pxml_list $path ?$part?
+# Iterates over each PXML in $pxml_list, selecting the indicated
+# path from it, building a new list with the selected data, and
+# returning that new list. For example, $pxml_list might be
+# the %CHILDREN of a particular element, and the $path and $part
+# might select from each child a sub-element in which we're interested.
+
+# xsxp::only $pxml $tagname
+# Iterates over the direct children of $pxml and selects only
+# those with $tagname as their tag. Returns a list of matching
+# elements.
+
+# xsxp::prettyprint $pxml
+# Outputs to stdout a nested-list notation of the parsed XML.
+
+package require xml
+package provide xsxp 1.0
+
+namespace eval xsxp {
+
+ variable Stack
+ variable Cur
+
+ proc Characterdatacommand {characterdata} {
+ variable Cur
+ # puts "characterdatacommand $characterdata"
+ set x [list %PCDATA {} $characterdata]
+ lappend Cur $x
+ }
+
+ proc Elementstartcommand {name attlist args} {
+ # puts "elementstart $name {$attlist} $args"
+ variable Stack
+ variable Cur
+ lappend Stack $Cur
+ set Cur [list $name $attlist]
+ }
+
+ proc Elementendcommand {args} {
+ # puts "elementend $args"
+ variable Stack
+ variable Cur
+ set x [lindex $Stack end]
+ lappend x $Cur
+ set Cur $x
+ set Stack [lrange $Stack 0 end-1]
+ }
+
+ proc parse {xml} {
+ variable Cur
+ variable Stack
+ set Cur {}
+ set Stack {}
+ set parser [::xml::parser \
+ -characterdatacommand [namespace code Characterdatacommand] \
+ -elementstartcommand [namespace code Elementstartcommand] \
+ -elementendcommand [namespace code Elementendcommand] \
+ -ignorewhitespace 1 -final 1
+ ]
+ $parser parse $xml
+ $parser free
+ # The following line is needed because the close of the last element
+ # appends the outermost element to the item on the top of the stack.
+ # Since there's nothing on the top of the stack at the close of the
+ # last element, we append the current element to an empty list.
+ # In essence, since we don't really have a terminating condition
+ # on the recursion, an empty stack is still treated like an element.
+ set Cur [lindex $Cur 0]
+ set Cur [Normalize $Cur]
+ return $Cur
+ }
+
+ proc Normalize {pxml} {
+ # This iterates over pxml recursively, finding entries that
+ # start with multiple %PCDATA elements, and coalesces their
+ # content, so if an element contains only %PCDATA, it is
+ # guaranteed to have only one child.
+ # Not really necessary, given definition of part=%PCDATA
+ # However, it makes pretty-prints nicer (for AWS at least)
+ # and ends up with smaller lists. I have no idea why they
+ # would put quotes around an MD5 hash in hex, tho.
+ set dupl 1
+ while {$dupl} {
+ set first [lindex $pxml 2]
+ set second [lindex $pxml 3]
+ if {[lindex $first 0] eq "%PCDATA" && [lindex $second 0] eq "%PCDATA"} {
+ set repl [list %PCDATA {} [lindex $first 2][lindex $second 2]]
+ set pxml [lreplace $pxml 2 3 $repl]
+ } else {
+ set dupl 0
+ for {set i 2} {$i < [llength $pxml]} {incr i} {
+ set pxml [lreplace $pxml $i $i [Normalize [lindex $pxml $i]]]
+ }
+ }
+ }
+ return $pxml
+ }
+
+ proc prettyprint {pxml {chan stdout} {indent 0}} {
+ puts -nonewline $chan [string repeat " " $indent]
+ if {[lindex $pxml 0] eq "%PCDATA"} {
+ puts $chan "%PCDATA: [lindex $pxml 2]"
+ return
+ }
+ puts -nonewline $chan "[lindex $pxml 0]"
+ foreach {name val} [lindex $pxml 1] {
+ puts -nonewline $chan " $name='$val'"
+ }
+ puts $chan ""
+ foreach node [lrange $pxml 2 end] {
+ prettyprint $node $chan [expr $indent+1]
+ }
+ }
+
+ proc fetch {pxml path {part %ALL}} {
+ set path [string trim $path /]
+ if {-1 != [string first / $path]} {
+ set path [split $path /]
+ }
+ foreach element $path {
+ if {$pxml eq ""} {return ""}
+ foreach {tag count} [split $element #] {
+ if {$tag ne ""} {
+ if {$count eq ""} {set count 0}
+ set pxml [lrange $pxml 2 end]
+ while {0 <= $count && 0 != [llength $pxml]} {
+ if {$tag eq [lindex $pxml 0 0]} {
+ incr count -1
+ if {$count < 0} {
+ # We're done. Go on to next element.
+ set pxml [lindex $pxml 0]
+ } else {
+ # Not done yet. Throw this away.
+ set pxml [lrange $pxml 1 end]
+ }
+ } else {
+ # Not what we want.
+ set pxml [lrange $pxml 1 end]
+ }
+ }
+ } else { # tag eq ""
+ if {$count eq ""} {
+ # Just select whole $pxml
+ } else {
+ set pxml [lindex $pxml [expr {2+$count}]]
+ }
+ }
+ break
+ } ; # done the foreach [split] loop
+ } ; # done all the elements.
+ if {$part eq "%ALL"} {return $pxml}
+ if {$part eq "%ATTRIBUTES"} {return [lindex $pxml 1]}
+ if {$part eq "%TAGNAME"} {return [lindex $pxml 0]}
+ if {$part eq "%CHILDREN"} {return [lrange $pxml 2 end]}
+ if {$part eq "%PCDATA" || $part eq "%PCDATA?"} {
+ set res "" ; set found 0
+ foreach elem [lrange $pxml 2 end] {
+ if {"%PCDATA" eq [lindex $elem 0]} {
+ append res [lindex $elem 2]
+ set found 1
+ }
+ }
+ if {$found || $part eq "%PCDATA?"} {
+ return $res
+ } else {
+ error "xsxp::fetch did not find requested PCDATA"
+ }
+ }
+ return $pxml ; # Don't know what he's after
+ }
+
+ proc only {pxml tag} {
+ set res {}
+ foreach element [lrange $pxml 2 end] {
+ if {[lindex $element 0] eq $tag} {
+ lappend res $element
+ }
+ }
+ return $res
+ }
+
+ proc fetchall {pxml_list path {part %ALL}} {
+ set res [list]
+ foreach pxml $pxml_list {
+ lappend res [fetch $pxml $path $part]
+ }
+ return $res
+ }
+}
+
+namespace export xsxp parse prettyprint fetch
+
diff --git a/tcllib/modules/amazon-s3/xsxp.test b/tcllib/modules/amazon-s3/xsxp.test
new file mode 100644
index 0000000..97efdcb
--- /dev/null
+++ b/tcllib/modules/amazon-s3/xsxp.test
@@ -0,0 +1,166 @@
+# -*- tcl -*-
+# xsxp.test: tests for the xsxp package.
+
+# This file contains a collection of tests for the xsxp
+# package. Sourcing this file into Tcl runs the tests and generates
+# output for errors. No output means no errors were found.
+
+# Copyright (c) 2006,2008 Darren New. All Rights Reserved.
+# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# (Boilerplate stuff (header, footer))
+# All rights reserved.
+#
+# RCS: @(#) $Id: xsxp.test,v 1.3 2008/09/04 02:11:13 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+if {[catch {package require xml}]} {
+ puts " Aborting the tests found in \"[file tail [info script]]\""
+ puts " Requiring xml package, not found."
+ return
+}
+
+support {
+ # Requires xml (TclXML)
+}
+testing {
+ useLocal xsxp.tcl xsxp
+}
+
+# -------------------------------------------------------------------------
+package require -exact xsxp 1.0
+
+tcltest::configure -verbose {body error pass}
+tcltest::configure -debug 1
+
+set setup_one {
+ set xml {<?xml version="1.0" encoding="UTF-8"?>
+<AccessControlPolicy xmlns="http://s3.amazonaws.com/doc/2006-03-01/"><Owner><ID>9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd</ID><DisplayName>dnew@san.rr.com</DisplayName></Owner><AccessControlList><Grant><Grantee xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:type="CanonicalUser"><ID>9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd</ID><DisplayName>dnew@san.rr.com</DisplayName></Grantee><Permission>FULL_CONTROL</Permission></Grant></AccessControlList></AccessControlPolicy>}
+}
+
+tcltest::test xsxp-1.10 {Basic parsing} -setup $setup_one -body {
+ set pxml [::xsxp::parse $xml]
+ return [lindex $pxml 0]
+} -result {AccessControlPolicy}
+
+tcltest::test xsxp-1.20 {Precision parsing} -setup $setup_one -body {
+ return [::xsxp::parse $xml]
+} -result {AccessControlPolicy {} {Owner {} {ID {} {%PCDATA {} 9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd}} {DisplayName {} {%PCDATA {} dnew@san.rr.com}}} {AccessControlList {} {Grant {} {Grantee {xsi:type CanonicalUser} {ID {} {%PCDATA {} 9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd}} {DisplayName {} {%PCDATA {} dnew@san.rr.com}}} {Permission {} {%PCDATA {} FULL_CONTROL}}}}}
+
+tcltest::test xsxp-1.30 {Test pretty printing} -setup $setup_one -body {
+ ::xsxp::prettyprint [::xsxp::parse $xml]
+} -output {AccessControlPolicy
+ Owner
+ ID
+ %PCDATA: 9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd
+ DisplayName
+ %PCDATA: dnew@san.rr.com
+ AccessControlList
+ Grant
+ Grantee xsi:type='CanonicalUser'
+ ID
+ %PCDATA: 9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd
+ DisplayName
+ %PCDATA: dnew@san.rr.com
+ Permission
+ %PCDATA: FULL_CONTROL
+}
+
+tcltest::test xsxp-1.40 {Access via path string} -setup $setup_one -body {
+ set pxml [::xsxp::parse $xml]
+ return [::xsxp::fetch $pxml "Owner/DisplayName" %PCDATA]
+} -result {dnew@san.rr.com}
+
+tcltest::test xsxp-1.50 {Access via path list} -setup $setup_one -body {
+ set pxml [::xsxp::parse $xml]
+ return [::xsxp::fetch $pxml "Owner DisplayName" %PCDATA]
+} -result {dnew@san.rr.com}
+
+set setup_two {
+set xml {<?xml version="1.0" encoding="UTF-8"?>
+<ListBucketResult xmlns="http://s3.amazonaws.com/doc/2006-03-01/"><Name>darren</Name><Prefix></Prefix><Marker></Marker><MaxKeys>1000</MaxKeys><IsTruncated>false</IsTruncated><Contents><Key>t1.jpg</Key><LastModified>2006-10-27T23:19:07.000Z</LastModified><ETag>&quot;a251eabc2e69e9716878924b6ec291c7&quot;</ETag><Size>1512545</Size><Owner><ID>9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd</ID><DisplayName>dnew@san.rr.com</DisplayName></Owner><StorageClass>STANDARD</StorageClass></Contents><Contents><Key>t2.jpg</Key><LastModified>2006-10-27T23:19:44.000Z</LastModified><ETag>&quot;ebc9b242811239ada85f202346353f31&quot;</ETag><Size>1826062</Size><Owner><ID>9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd</ID><DisplayName>dnew@san.rr.com</DisplayName></Owner><StorageClass>STANDARD</StorageClass></Contents></ListBucketResult>}
+set pxml [::xsxp::parse $xml]
+}
+
+tcltest::test xsxp-2.10 {Fetch top-level item} -setup $setup_two -body {
+ ::xsxp::fetch $pxml MaxKeys
+} -result {MaxKeys {} {%PCDATA {} 1000}}
+
+set c0 {Contents {} {Key {} {%PCDATA {} t1.jpg}} {LastModified {} {%PCDATA {} 2006-10-27T23:19:07.000Z}} {ETag {} {%PCDATA {} {"a251eabc2e69e9716878924b6ec291c7"}}} {Size {} {%PCDATA {} 1512545}} {Owner {} {ID {} {%PCDATA {} 9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd}} {DisplayName {} {%PCDATA {} dnew@san.rr.com}}} {StorageClass {} {%PCDATA {} STANDARD}}}
+
+tcltest::test xsxp-2.20 {Fetch another top-level item} -setup $setup_two -body {
+ ::xsxp::fetch $pxml Contents
+} -result $c0
+
+tcltest::test xsxp-2.30 {Fetch #0 item} -setup $setup_two -body {
+ ::xsxp::fetch $pxml Contents
+} -result $c0
+
+set c1 {Contents {} {Key {} {%PCDATA {} t2.jpg}} {LastModified {} {%PCDATA {} 2006-10-27T23:19:44.000Z}} {ETag {} {%PCDATA {} {"ebc9b242811239ada85f202346353f31"}}} {Size {} {%PCDATA {} 1826062}} {Owner {} {ID {} {%PCDATA {} 9fb13c24488e3d7556693247d5a463c1837c3c8ede28f4094228e6c4eb5d70bd}} {DisplayName {} {%PCDATA {} dnew@san.rr.com}}} {StorageClass {} {%PCDATA {} STANDARD}}}
+
+tcltest::test xsxp-2.40 {Fetch #1 item} -setup $setup_two -body {
+ ::xsxp::fetch $pxml Contents#1
+} -result $c1
+
+tcltest::test xsxp-2.50 {Fetch item past end} -setup $setup_two -body {
+ ::xsxp::fetch $pxml Contents#2
+} -result {}
+
+tcltest::test xsxp-2.60 {Check %TAGNAME} -setup $setup_two -body {
+ ::xsxp::fetch $pxml #4 %TAGNAME
+} -result {IsTruncated}
+
+tcltest::test xsxp-2.70 {check merge of PCDATA} -setup $setup_two -body {
+ ::xsxp::fetch $pxml Contents/ETag %PCDATA
+} -result {"a251eabc2e69e9716878924b6ec291c7"}
+
+tcltest::test xsxp-2.80 {Check lack of PCDATA} -setup $setup_two -body {
+ ::xsxp::fetch $pxml Prefix %PCDATA
+} -returnCodes 1 -result "xsxp::fetch did not find requested PCDATA"
+
+tcltest::test xsxp-2.90 {Check lack of PCDATA?} -setup $setup_two -body {
+ ::xsxp::fetch $pxml Prefix %PCDATA?
+} -result ""
+
+
+tcltest::test xsxp-3.10 {only} -setup $setup_two -body {
+ set only [::xsxp::only $pxml Contents]
+ return [list [llength $only] [lindex $only 0 0] [lindex $only 1 0]]
+} -result {2 Contents Contents}
+
+tcltest::test xsxp-4.10 {fetchall basic} -setup $setup_two -body {
+ set only [::xsxp::only $pxml Contents]
+ ::xsxp::fetchall $only Key %PCDATA
+} -result {t1.jpg t2.jpg}
+
+tcltest::test xsxp-5.10 {only} -setup $setup_two -body {
+ set only [::xsxp::only $pxml Contents]
+ ::xsxp::fetch $pxml Contents#1/Key/%PCDATA %CHILDREN
+} -result {t2.jpg}
+
+
+
+if {0} {
+ foreach file [glob -directory xml *] {
+ puts $file
+ if {".xml" != [string range $file end-3 end]} continue
+ set in [open $file r]
+ set xml [read $in]
+ close $in
+ set pxml [::xsxp::parse $xml]
+ set out [open [string range $file 0 end-4].txt w] ; #lazy
+ ::xsxp::prettyprint $pxml $out
+ close $out
+ }
+}
+
+#----------------------------------------------------------------------
+testsuiteCleanup
+puts "Done!" ; after 5000
diff --git a/tcllib/modules/asn/ChangeLog b/tcllib/modules/asn/ChangeLog
new file mode 100644
index 0000000..a38aad7
--- /dev/null
+++ b/tcllib/modules/asn/ChangeLog
@@ -0,0 +1,272 @@
+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-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2011-01-05 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * asn.tcl : Fixed wrong asnGetBigInteger code
+ asn.man : Tcllib SF [3039090], added tests.
+ asn.test : Patchlevel now 0.8.4.
+ asn.bench: Thank to Roy Keene for the patch.
+ asn.pcx :
+
+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-11-22 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * asn.bench: Added a new bench for OID decoding
+
+2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11 ========================
+ *
+
+2008-06-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * asn.pcx: New file. Syntax definitions for the public commands of
+ the asn package.
+
+2008-03-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * asn.man: Added documentation for a number of public yet not
+ documented.
+
+2008-03-09 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * asn.tcl : Added (optional ) support for Tcl 8.5 unsigned binary
+ asn.man : scan to speed up byte extraction.
+ pkgIndex.tcl:
+
+2007-09-18 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * asn.tcl : Fixed missing padding in bitstring encoder
+ asn.man : Tcllib SF [1797428], added some tests for
+ asn.test : Bitstrings. Patchlevel now 0.8.2.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-04-20 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * asn.tcl : Fixed misspelt PRIVATE name in docs and code,
+ asn.man : Tcllib SF [1704626].
+ asn.test : Fixed various glitches in the new commands and
+ added more tests for asnPeekTag and asnTag.
+ Version raised to 0.8.1.
+
+2007-04-20 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * asn.tcl : Fixed documentation bug Tcllib [1703408].
+ asn.man : Fixed parts of [1558351] by adding handling
+ asn.bench : for tag numbers > 31 and some new commands
+ asn.test : for changing tags.
+ Fixed Bug [1645333]. Some new benchmarks.
+ Raised Version to 0.8 because of new commands.
+
+2007-03-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * asn.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-09-01 Michael Schlenker <mic42@users.sourceforge.net>
+ * asn.tcl : Added asnRetag, asnPeekByte and asnGetLength
+ asn.man : to the public api, because those are needed by
+ pkgIndex.tcl: the ldap package.
+
+2006-08-16 Michael Schlenker <mic42@users.sourceforge.net>
+ * asn.tcl : Fixed stupid typos in asnGetApplication.
+ Fixes bug Tcllib [1541436].
+
+2006-08-15 Michael Schlenker <mic42@users.sourceforge.net>
+ * asn.tcl : added two convenience functions,
+ asn.man : asnSequenceFromList and asnSetFromList for
+ pkgIndex.tcl: use by the ldap module. Raised version
+ to 0.6
+
+2006-08-15 Michael Schlenker <mic42@users.sourceforge.net>
+ * asn.test: Added more tests. Fixed wrong version
+ asn.man : reference in man page.
+
+2006-08-13 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * asn.tcl : Fixed Tcllib Bug [1539479]. Package version
+ asn.test: raised to 0.5.2. Added smoketest for the bug.
+ Thanks to Pierre David for finding this.
+
+2006-03-22 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * asn.tcl: Removed dependency on the log package to fix
+ Tcllib Bug [1408807]. Package version raised to 0.5.1.
+
+2006-01-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * asn.test: Fixed use of duplicate test names.
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * asn.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * asn.test: Hooked into the new common test support code.
+
+2006-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * asn.man: Reworked the documentation of the new commands a bit,
+ and fixed some typos in words and use of the doctools commands.
+
+2006-01-16 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * asn.tcl: Added new decoders for BMPString
+ asn.man: and UTF8String. New convenience
+ asn.test: function asnGetString. Added tests
+ pkgIndex.tcl: for OIDs and the new string functions.
+ Bugfix for wrong tag in asnNumericString.
+ Version increased to 0.5.
+ Big thanks to Victor Wagner <vitus@45.free.net)
+ for the patches.
+
+2006-01-05 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * asn.tcl: Fixed Tcllib Bug #1393804. Stupid typo.
+ asn.test: Added some tests for asnPeekByte,
+ asnGetByte, asnGetBytes.
+ pkgIndex.tcl: Version increased to 0.4.2
+
+2005-12-30 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * asn.tcl: Applied patch from Tcllib Bug #1391776 to
+ create better (shorter) encodings for OIDs.
+ pkgIndex.tcl: Version number increased to 0.4.1
+
+2005-10-21 Andreas Kupries <andreask@activestate.com>
+
+ * asn.test: Fixed typos, new and old.
+
+2005-10-18 Andreas Kupries <andreask@activestate.com>
+
+ * asn.test: Package requires 8.4, this was not caught
+ * pkgIndex.tcl: properly in index, nor in testsuite.
+
+ * asn.bench: New file, benchmarks, only basics for now.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-04-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * asn.man: Synchronized indexed/provided versions.
+ * pkgIndex.tcl:
+
+2005-02-09 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * asn.tcl:
+ * asn.man:
+ * asn.test: Fixed incorrect length encoding and decoding .
+ Added 64-bit support for length encoding/decoding,
+ Added 64-bit support for integers.
+ Added tests for length encoding/decoding (10.x-11.x).
+ Added tests for 64-bit integers.
+ Bumped version number to 0.4
+ The package now needs Tcl 8.4 for wide() support.
+
+2004-12-29 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * asn.tcl:
+ * asn.man:
+ * asn.test: Added more encoder functions
+ to the module.
+ * Added math::bignum support for encoding
+ and decoding large integers. Interface not
+ final, so no docs yet.
+ * Fixed bug with negative 3-byte integers in
+ asn::asnInteger, those were padded with 0x00 instead
+ of 0xff and added test for this (2.25).
+ * Added tests for null, boolean encoding and decoding
+ and for bignum integer encoding (5.x-9.x).
+ * Removed second signed-unsigned conversion for the tags
+ in error messages, asnGetByte returns unsigned tags.
+ * bumped version number to 0.3
+
+2004-10-05 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * asn.tcl: Added more decoder functions to the module.
+ * asn.man: New primitve Types supported:
+ OBJECT IDENTIFIER,BIT STRING,UTCTIME,BOOLEAN,
+ PRINTABLE STRING, IA5 STRING, NULL
+ New structure element: Context tagging
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-08-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * asn.tcl: Typo police.
+ * asn.man:
+ * ChangeLog:
+
+2004-08-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * asn.test:
+ * asn.tcl: Enhanced encoder for enumerations: fixed buglet for
+ 2-byte integers (not minimal in border case 127), added the
+ handling of 3-byte integers. Extended testsuite to cover
+ enumerations as well.
+
+2004-08-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * asn.test: New file, first test cases for asn package.
+
+ * asn.tcl: Enhanced integer encoder: fixed buglet for 2-byte
+ integers (not minimal in bordercase 127), added the handling of
+ 3-byte integers.
+
+2004-05-27 Andreas Kupries <andreask@activestate.com>
+
+ * New module: ASN.1 de- and encoding. This was provided to us
+ indirectly by Jochen Loewer <loewerj@web.de>, through the LDAP
+ module. It contains the same functionality internally.
+
+ * Added doctools documentation. Referenced the "Layman's Guide to
+ a Subset of ASN.1, BER, and DER" and added text version to the
+ sources, to guide future work.
diff --git a/tcllib/modules/asn/asn.bench b/tcllib/modules/asn/asn.bench
new file mode 100644
index 0000000..cadac67
--- /dev/null
+++ b/tcllib/modules/asn/asn.bench
@@ -0,0 +1,116 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'asn' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+package forget log
+catch {namespace delete ::log}
+source [file join [file dirname [file dirname [info script]]] log log.tcl]
+
+package forget asn
+catch {namespace delete ::asn}
+source [file join [file dirname [info script]] asn.tcl]
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+foreach n {
+ -10 -100 -1000 -10000 -100000 -1000000
+ 0
+ 10 100 1000 10000 100000 1000000
+} {
+ bench -desc "ASN Integer $n" -body {
+ asn::asnInteger $n
+ }
+
+ bench -desc "ASN Enum $n" -body {
+ asn::asnEnumeration $n
+ }
+
+ bench -desc "ASN Boolean $n" -body {
+ asn::asnBoolean $n
+ }
+}
+
+foreach n {10 100 1000 10000} {
+ bench -desc "ASN OctetString ${n}" -pre {
+ set str [string repeat X $n]
+ } -body {
+ asn::asnOctetString $str
+ } -post {
+ unset str
+ }
+}
+
+for {set n 1; set i 0} {$i < 64} { set n [expr {wide($n)*2}] ; incr i} {
+ bench -desc "ASN asnLength 2^${i}" -body {
+ asn::asnLength $n
+ }
+}
+
+for {set n 0} {$n < 10} { incr n} {
+ bench -desc "ASN encode oid with ${n}+2 components" -pre {
+ set oid [list 1 10]
+ for {set i 0} {$i < $n} {incr i} {
+ lappend oid $i
+ }
+ } -body {
+ asn::asnObjectIdentifier $oid
+ } -post {
+ unset oid
+ }
+}
+
+for {set n 0} {$n < 10} { incr n} {
+ bench -desc "ASN decode oid with ${n}+2 components" -pre {
+ set oid [list 1 10]
+ for {set i 0} {$i < $n} {incr i} {
+ lappend oid $i
+ }
+ set oidval [asn::asnObjectIdentifier $oid]
+ } -body {
+ asn::asnGetObjectIdentifier $oidval
+ } -post {
+ unset oid
+ unset oidval
+ }
+}
+
+foreach n {10 100 1000 10000 100000} {
+ bench -desc "ASN asnGetByte ${n}" -pre {
+ set bytes [binary format a* [string repeat X $n]]
+ } -body {
+ ::asn::asnGetByte bytes dummy
+ } -post {
+ unset bytes
+ unset dummy
+ }
+}
+
+
+foreach n {10 100 1000 10000 100000} {
+ bench -desc "ASN asnGetBytes ${n} len 5" -pre {
+ set bytes [binary format a* [string repeat X $n]]
+ } -body {
+ ::asn::asnGetBytes bytes 5 dummy
+ } -post {
+ unset bytes
+ unset dummy
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/asn/asn.man b/tcllib/modules/asn/asn.man
new file mode 100644
index 0000000..b5eb5c5
--- /dev/null
+++ b/tcllib/modules/asn/asn.man
@@ -0,0 +1,464 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin asn n 0.8]
+[keywords asn]
+[keywords ber]
+[keywords cer]
+[keywords der]
+[keywords internet]
+[keywords protocol]
+[keywords x.208]
+[keywords x.209]
+[copyright {2004 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[copyright {2004 Jochen Loewer <loewerj@web.de>}]
+[copyright {2004-2011 Michael Schlenker <mic42@users.sourceforge.net>}]
+[moddesc {ASN.1 processing}]
+[category Networking]
+[titledesc {ASN.1 BER encoder/decoder}]
+[require Tcl 8.4]
+[require asn [opt 0.8.4]]
+[description]
+[para]
+
+The [package asn] package provides [emph partial] de- and encoder
+commands for BER encoded ASN.1 data. It can also be used for
+decoding DER, which is a restricted subset of BER.
+
+[para]
+
+ASN.1 is a standard [term {Abstract Syntax Notation}], and BER are its
+[term {Basic Encoding Rules}].
+
+[para]
+
+See [uri http://asn1.elibel.tm.fr/en/standards/index.htm] for more
+information about the standard.
+
+[para]
+
+Also see [uri http://luca.ntop.org/Teaching/Appunti/asn1.html] for
+[emph {A Layman's Guide to a Subset of ASN.1, BER, and DER}], an RSA
+Laboratories Technical Note by Burton S. Kaliski Jr. (Revised November
+1, 1993). A text version of this note is part of the module sources
+and should be read by any implementor.
+
+[section {PUBLIC API}]
+[subsection ENCODER]
+
+[list_begin definitions]
+
+[call [cmd ::asn::asnSequence] [arg evalue]...]
+
+Takes zero or more encoded values, packs them into an ASN sequence and
+returns its encoded binary form.
+
+[call [cmd ::asn::asnSequenceFromList] [arg elist]]
+
+Takes a list of encoded values, packs them into an ASN sequence and
+returns its encoded binary form.
+
+[call [cmd ::asn::asnSet] [arg evalue]...]
+
+Takes zero or more encoded values, packs them into an ASN set and
+returns its encoded binary form.
+
+[call [cmd ::asn::asnSetFromList] [arg elist]]
+
+Takes a list of encoded values, packs them into an ASN set and
+returns its encoded binary form.
+
+[call [cmd ::asn::asnApplicationConstr] [arg appNumber] [arg evalue]...]
+
+Takes zero or more encoded values, packs them into an ASN application
+construct and returns its encoded binary form.
+
+[call [cmd ::asn::asnApplication] [arg appNumber] [arg data]]
+
+Takes a single encoded value [arg data], packs it into an ASN
+application construct and returns its encoded binary form.
+
+[call [cmd ::asn::asnChoice] [arg appNumber] [arg evalue]...]
+
+Takes zero or more encoded values, packs them into an ASN choice
+construct and returns its encoded binary form.
+
+[call [cmd ::asn::asnChoiceConstr] [arg appNumber] [arg evalue]...]
+
+Takes zero or more encoded values, packs them into an ASN choice
+construct and returns its encoded binary form.
+
+[call [cmd ::asn::asnInteger] [arg number]]
+
+Returns the encoded form of the specified integer
+[arg number].
+
+[call [cmd ::asn::asnEnumeration] [arg number]]
+
+Returns the encoded form of the specified enumeration id
+[arg number].
+
+[call [cmd ::asn::asnBoolean] [arg bool]]
+
+Returns the encoded form of the specified boolean value
+[arg bool].
+
+[call [cmd ::asn::asnContext] [arg context] [arg data]]
+
+Takes an encoded value and packs it into a constructed value with
+application tag, the [arg context] number.
+
+[call [cmd ::asn::asnContextConstr] [arg context] [arg evalue]...]
+
+Takes zero or more encoded values and packs them into a constructed
+value with application tag, the [arg context] number.
+
+[call [cmd ::asn::asnObjectIdentifier] [arg idlist]]
+
+Takes a list of at least 2 integers describing an object identifier
+(OID) value, and returns the encoded value.
+
+[call [cmd ::asn::asnUTCTime] [arg utcstring]]
+
+Returns the encoded form of the specified UTC time string.
+
+[call [cmd ::asn::asnNull]]
+
+Returns the NULL encoding.
+
+[call [cmd ::asn::asnBitString] [arg string]]
+
+Returns the encoded form of the specified [arg string].
+
+[call [cmd ::asn::asnOctetString] [arg string]]
+
+Returns the encoded form of the specified [arg string].
+
+[call [cmd ::asn::asnNumericString] [arg string]]
+
+Returns the [arg string] encoded as ASN.1 NumericString. Raises an
+error if the [arg string] contains characters other than decimal
+numbers and space.
+
+[call [cmd ::asn::asnPrintableString] [arg string]]
+
+Returns the [arg string] encoding as ASN.1 PrintableString. Raises an
+error if the [arg string] contains characters which are not allowed by
+the Printable String datatype. The allowed characters are A-Z, a-z,
+0-9, space, apostrophe, colon, parentheses, plus, minus, comma,
+period, forward slash, question mark, and the equals sign.
+
+[call [cmd ::asn::asnIA5String] [arg string]]
+
+Returns the [arg string] encoded as ASN.1 IA5String. Raises an error
+if the [arg string] contains any characters outside of the US-ASCII
+range.
+
+[call [cmd ::asn::asnBMPString] [arg string]]
+
+Returns the [arg string] encoded as ASN.1 Basic Multilingual Plane
+string (Which is essentialy big-endian UCS2).
+
+[call [cmd ::asn::asnUTF8String] [arg string]]
+
+Returns the [arg string] encoded as UTF8 String. Note that some legacy
+applications such as Windows CryptoAPI do not like UTF8 strings. Use
+BMPStrings if you are not sure.
+
+[call [cmd ::asn::asnString] [arg string]]
+
+Returns an encoded form of [arg string], choosing the most restricted
+ASN.1 string type possible. If the string contains non-ASCII
+characters, then there is more than one string type which can be
+used. See [cmd ::asn::defaultStringType].
+
+[call [cmd ::asn::defaultStringType] [opt [arg type]]]
+
+Selects the string type to use for the encoding of non-ASCII
+strings. Returns current default when called without argument. If the
+argument [arg type] is supplied, it should be either [const UTF8] or
+[const BMP] to choose UTF8String or BMPString respectively.
+
+[list_end]
+[para]
+
+[subsection DECODER]
+
+General notes:
+
+[list_begin enumerated]
+[enum]
+Nearly all decoder commands take two arguments. These arguments are variable
+names, except for [cmd ::asn::asnGetResponse]. The first variable
+contains the encoded ASN value to decode at the beginning, and more,
+and the second variable is where the value is stored to. The remainder
+of the input after the decoded value is stored back into the
+datavariable.
+
+[enum]
+After extraction the data variable is always modified first, before by
+writing the extracted value to its variable. This means that if both
+arguments refer to the same variable, it will always contain the
+extracted value after the call, and not the remainder of the input.
+
+[list_end]
+
+[para]
+[list_begin definitions]
+[call [cmd ::asn::asnPeekByte] [arg data_var] [arg byte_var]]
+
+Retrieve the first byte of the data, without modifing [arg data_var].
+This can be used to check for implicit tags.
+
+[call [cmd ::asn::asnGetLength] [arg data_var] [arg length_var]]
+
+Decode the length information for a block of BER data. The tag has already
+to be removed from the data.
+
+[call [cmd ::asn::asnGetResponse] [arg chan] [arg data_var]]
+
+Reads an encoded ASN [emph sequence] from the channel [arg chan] and
+stores it into the variable named by [arg data_var].
+
+[call [cmd ::asn::asnGetInteger] [arg data_var] [arg int_var]]
+
+Assumes that an encoded integer value is at the front of the data
+stored in the variable named [arg data_var], extracts and stores it
+into the variable named by [arg int_var]. Additionally removes all
+bytes associated with the value from the data for further processing
+by the following decoder commands.
+
+[call [cmd ::asn::asnGetEnumeration] [arg data_var] [arg enum_var]]
+
+Assumes that an enumeration id is at the front of the data stored in
+the variable named [arg data_var], and stores it into the variable
+named by [arg enum_var]. Additionally removes all bytes associated
+with the value from the data for further processing by the following
+decoder commands.
+
+[call [cmd ::asn::asnGetOctetString] [arg data_var] [arg string_var]]
+
+Assumes that a string is at the front of the data stored in the
+variable named [arg data_var], and stores it into the variable named
+by [arg string_var]. Additionally removes all bytes associated with
+the value from the data for further processing by the following
+decoder commands.
+
+[call [cmd ::asn::asnGetString] [arg data_var] [arg string_var] [opt [arg type_var]]]
+
+Decodes a user-readable string. This is a convenience function which
+is able to automatically distinguish all supported ASN.1 string types
+and convert the input value appropriately.
+
+See [cmd ::asn::asnGetPrintableString], [cmd ::asnGetIA5String], etc.
+below for the type-specific conversion commands.
+
+[para]
+
+If the optional third argument [arg type_var] is supplied, then the
+type of the incoming string is stored in the variable named by it.
+
+[para]
+
+The function throws the error
+
+"Invalid command name asnGetSome[var UnsupportedString]" if the
+unsupported string type [var Unsupported] is encountered. You can
+create the appropriate function
+
+"asn::asnGetSome[var UnsupportedString]" in your application if
+neccessary.
+
+[call [cmd ::asn::asnGetNumericString] [arg data_var] [arg string_var]]
+
+Assumes that a numeric string value is at the front of the data stored
+in the variable named [arg data_var], and stores it into the variable
+named by [arg string_var]. Additionally removes all bytes associated
+with the value from the data for further processing by the following
+decoder commands.
+
+[call [cmd ::asn::asnGetPrintableString] [arg data_var] [arg string_var]]
+
+Assumes that a printable string value is at the front of the data
+stored in the variable named [arg data_var], and stores it into the
+variable named by [arg string_var]. Additionally removes all bytes
+associated with the value from the data for further processing by the
+following decoder commands.
+
+[call [cmd ::asn::asnGetIA5String] [arg data_var] [arg string_var]]
+
+Assumes that a IA5 (ASCII) string value is at the front of the data
+stored in the variable named [arg data_var], and stores it into the
+variable named by [arg string_var]. Additionally removes all bytes
+associated with the value from the data for further processing by the
+following decoder commands.
+
+[call [cmd ::asn::asnGetBMPString] [arg data_var] [arg string_var]]
+
+Assumes that a BMP (two-byte unicode) string value is at the front of
+the data stored in the variable named [arg data_var], and stores it
+into the variable named by [arg string_var], converting it into a
+proper Tcl string. Additionally removes all bytes associated with the
+value from the data for further processing by the following decoder
+commands.
+
+[call [cmd ::asn::asnGetUTF8String] [arg data_var] [arg string_var]]
+
+Assumes that a UTF8 string value is at the front of the data stored in
+the variable named [arg data_var], and stores it into the variable
+named by [arg string_var], converting it into a proper Tcl string.
+Additionally removes all bytes associated with the value from the data
+for further processing by the following decoder commands.
+
+[call [cmd ::asn::asnGetUTCTime] [arg data_var] [arg utc_var]]
+
+Assumes that a UTC time value is at the front of the data stored in the
+variable named [arg data_var], and stores it into the variable named
+by [arg utc_var]. The UTC time value is stored as a string, which has to
+be decoded with the usual clock scan commands.
+Additionally removes all bytes associated with the
+value from the data for further processing by the following decoder
+commands.
+
+[call [cmd ::asn::asnGetBitString] [arg data_var] [arg bits_var]]
+
+Assumes that a bit string value is at the front of the data stored in the
+variable named [arg data_var], and stores it into the variable named
+by [arg bits_var] as a string containing only 0 and 1.
+Additionally removes all bytes associated with the
+value from the data for further processing by the following decoder
+commands.
+
+[call [cmd ::asn::asnGetObjectIdentifier] [arg data_var] [arg oid_var]]
+
+Assumes that a object identifier (OID) value is at the front of the data
+stored in the variable named [arg data_var], and stores it into the variable
+named by [arg oid_var] as a list of integers.
+Additionally removes all bytes associated with the
+value from the data for further processing by the following decoder
+commands.
+
+[call [cmd ::asn::asnGetBoolean] [arg data_var] [arg bool_var]]
+
+Assumes that a boolean value is at the front of the data stored in the
+variable named [arg data_var], and stores it into the variable named
+by [arg bool_var]. Additionally removes all bytes associated with the
+value from the data for further processing by the following decoder
+commands.
+
+[call [cmd ::asn::asnGetNull] [arg data_var]]
+
+Assumes that a NULL value is at the front of the data stored in the
+variable named [arg data_var] and removes the bytes used to encode it
+from the data.
+
+[call [cmd ::asn::asnGetSequence] [arg data_var] [arg sequence_var]]
+
+Assumes that an ASN sequence is at the front of the data stored in the
+variable named [arg data_var], and stores it into the variable named
+by [arg sequence_var]. Additionally removes all bytes associated with
+the value from the data for further processing by the following
+decoder commands.
+
+[para]
+
+The data in [arg sequence_var] is encoded binary and has to be
+further decoded according to the definition of the sequence, using the
+decoder commands here.
+
+[call [cmd ::asn::asnGetSet] [arg data_var] [arg set_var]]
+
+Assumes that an ASN set is at the front of the data stored in the
+variable named [arg data_var], and stores it into the variable named
+by [arg set_var]. Additionally removes all bytes associated with the
+value from the data for further processing by the following decoder
+commands.
+
+[para]
+
+The data in [arg set_var] is encoded binary and has to be further
+decoded according to the definition of the set, using the decoder
+commands here.
+
+[call [cmd ::asn::asnGetApplication] [arg data_var] [arg appNumber_var] [opt [arg content_var]] [opt [arg encodingType_var]]]
+
+Assumes that an ASN application construct is at the front of the data
+stored in the variable named [arg data_var], and stores its id into
+the variable named by [arg appNumber_var]. Additionally removes all
+bytes associated with the value from the data for further processing
+by the following decoder commands.
+
+If a [arg content_var] is specified, then the command places all data
+associated with it into the named variable, in the binary form which
+can be processed using the decoder commands of this package.
+
+If a [arg encodingType_var] is specified, then that var is set to 1 if
+the encoding is constructed and 0 if it is primitive.
+
+[para]
+
+Otherwise it is the responsibility of the caller to decode the
+remainder of the application construct based on the id retrieved by
+this command, using the decoder commands of this package.
+
+[call [cmd ::asn::asnGetContext] [arg data_var] [arg contextNumber_var] [opt [arg content_var]] [opt [arg encodingType_var]]]
+
+Assumes that an ASN context tag construct is at the front of the data
+stored in the variable named [arg data_var], and stores its id into
+the variable named by [arg contextNumber_var]. Additionally removes all
+bytes associated with the value from the data for further processing
+by the following decoder commands.
+
+If a [arg content_var] is specified, then the command places all data
+associated with it into the named variable, in the binary form which
+can be processed using the decoder commands of this package.
+
+If a [arg encodingType_var] is specified, then that var is set to 1 if
+the encoding is constructed and 0 if it is primitive.
+
+[para]
+
+Otherwise it is the responsibility of the caller to decode the
+remainder of the construct based on the id retrieved by this command,
+using the decoder commands of this package.
+
+[list_end]
+[para]
+[subsection {HANDLING TAGS}]
+
+Working with ASN.1 you often need to decode tagged values, which use a tag thats different
+from the universal tag for a type. In those cases you have to replace the tag with the universal tag
+used for the type, to decode the value.
+
+To decode a tagged value use the [cmd ::asn::asnRetag] to change the tag to the appropriate type
+to use one of the decoders for primitive values.
+
+To help with this the module contains three functions:
+
+[list_begin definitions]
+[call [cmd ::asn::asnPeekTag] [arg data_var] [arg tag_var] [arg tagtype_var] [arg constr_var]]
+
+The [cmd ::asn::asnPeekTag] command can be used to take a peek at the data and decode the tag value, without
+removing it from the data. The [arg tag_var] gets set to the tag number, while the [arg tagtype_var] gets set
+to the class of the tag. (Either UNIVERSAL, CONTEXT, APPLICATION or PRIVATE). The [arg constr_var] is set to 1 if the
+tag is for a constructed value, and to 0 for not constructed. It returns the length of the tag.
+
+[call [cmd ::asn::asnTag] [arg tagnumber] [opt [arg class]] [opt [arg tagstyle]]]
+
+The [cmd ::asn::asnTag] can be used to create a tag value. The [arg tagnumber] gives the number of the tag, while
+the [arg class] gives one of the classes (UNIVERSAL,CONTEXT,APPLICATION or PRIVATE). The class may be abbreviated to just the first letter (U,C,A,P),
+default is UNIVERSAL.
+The [arg tagstyle] is either C for Constructed encoding, or P for primitve encoding. It defaults to P. You can also use 1 instead of C and
+0 instead of P for direct use of the values returned by [cmd ::asn::asnPeekTag].
+
+[call [cmd ::asn::asnRetag] [arg data_var] [arg newTag]]
+
+Replaces the tag in front of the data in [arg data_var] with [arg newTag]. The new Tag can be created using the [cmd ::asn::asnTag] command.
+[list_end]
+
+[section EXAMPLES]
+
+Examples for the usage of this package can be found in the
+implementation of package [package ldap].
+
+[vset CATEGORY asn]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/asn/asn.pcx b/tcllib/modules/asn/asn.pcx
new file mode 100644
index 0000000..2114928
--- /dev/null
+++ b/tcllib/modules/asn/asn.pcx
@@ -0,0 +1,271 @@
+# -*- tcl -*- asn.pcx
+# Syntax of the commands provided by package asn.
+#
+# 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 asn
+pcx::tcldep 0.8.4 needs tcl 8.4
+
+namespace eval ::asn {}
+
+pcx::message outOfMinRange {The number "%1$s" is below the allowed minimum of "%2$s"} err
+pcx::message outOfMaxRange {The number "%1$s" is aboove the allowed maximum of "%2$s"} err
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 0.8.3 std ::asn::asnApplication \
+ {checkSimpleArgs 2 2 {
+ checkWholeNum
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnApplicationConstr \
+ {checkSimpleArgs 1 -1 {
+ checkWholeNum
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnBMPString \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnBitString \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnBoolean \
+ {checkSimpleArgs 1 1 {
+ checkBoolean
+ }}
+pcx::check 0.8.3 std ::asn::asnChoice \
+ {checkSimpleArgs 1 -1 {
+ checkWholeNum
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnChoiceConstr \
+ {checkSimpleArgs 1 -1 {
+ checkWholeNum
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnContext \
+ {checkSimpleArgs 2 2 {
+ checkWholeNum
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnContextConstr \
+ {checkSimpleArgs 1 -1 {
+ checkWholeNum
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnEnumeration \
+ {checkSimpleArgs 1 1 {
+ checkWholeNum
+ }}
+pcx::check 0.8.3 std ::asn::asnGetApplication \
+ {checkSimpleArgs 2 4 {
+ checkVarNameWrite
+ checkVarNameWrite
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetBMPString \
+ {checkSimpleArgs 2 2 {
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetBitString \
+ {checkSimpleArgs 2 2 {
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetBoolean \
+ {checkSimpleArgs 2 2 {
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetContext \
+ {checkSimpleArgs 2 4 {
+ checkVarNameWrite
+ checkVarNameWrite
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetEnumeration \
+ {checkSimpleArgs 2 2 {
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetIA5String \
+ {checkSimpleArgs 2 2 {
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetInteger \
+ {checkSimpleArgs 2 2 {
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetLength \
+ {checkSimpleArgs 2 2 {
+ checkVarname
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetNull \
+ {checkSimpleArgs 1 1 {
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetNumericString \
+ {checkSimpleArgs 2 2 {
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetObjectIdentifier \
+ {checkSimpleArgs 2 2 {
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetOctetString \
+ {checkSimpleArgs 2 2 {
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetPrintableString \
+ {checkSimpleArgs 2 2 {
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetResponse \
+ {checkSimpleArgs 2 2 {
+ checkChannelID
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetSequence \
+ {checkSimpleArgs 2 2 {
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetSet \
+ {checkSimpleArgs 2 2 {
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetString \
+ {checkSimpleArgs 2 3 {
+ checkVarNameWrite
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetUTCTime \
+ {checkSimpleArgs 2 2 {
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnGetUTF8String \
+ {checkSimpleArgs 2 2 {
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnIA5String \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnInteger \
+ {checkSimpleArgs 1 1 {
+ checkInt
+ }}
+pcx::check 0.8.3 std ::asn::asnNull \
+ {checkAtEnd}
+pcx::check 0.8.3 std ::asn::asnNumericString \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnObjectIdentifier \
+ {checkSimpleArgs 1 1 {
+ checkListValues 2 -1 {
+ {pcx::checkRange 0 2}
+ {pcx::checkRange 0 39}
+ checkWholeNum
+ }
+ }}
+pcx::check 0.8.3 std ::asn::asnOctetString \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnPeekByte \
+ {checkSimpleArgs 2 2 {
+ checkVarname
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnPeekTag \
+ {checkSimpleArgs 4 4 {
+ checkVarname
+ checkVarNameWrite
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.8.3 std ::asn::asnPrintableString \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnRetag \
+ {checkSimpleArgs 2 2 {
+ checkVarNameWrite
+ checkWholeNum
+ }}
+pcx::check 0.8.3 std ::asn::asnSequence \
+ {checkSimpleArgs 0 -1 {
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnSequenceFromList \
+ {checkSimpleArgs 1 1 {
+ checkList
+ }}
+pcx::check 0.8.3 std ::asn::asnSet \
+ {checkSimpleArgs 0 -1 {
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnSetFromList \
+ {checkSimpleArgs 1 1 {
+ checkList
+ }}
+pcx::check 0.8.3 std ::asn::asnString \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnTag \
+ {checkSimpleArgs 1 3 {
+ checkWholeNum
+ {checkKeyword 1 {UNIVERSAL CONTEXT APPLICATION PRIVATE U C A P}}
+ {checkKeyword 1 {C P 0 1}}
+ }}
+pcx::check 0.8.3 std ::asn::asnUTCTime \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::asnUTF8String \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 0.8.3 std ::asn::defaultStringType \
+ {checkSimpleArgs 0 1 {
+ {checkKeyword 1 {BMP UTF8}}
+ }}
+
+proc pcx::checkInitRange {min max t i} {
+ set w [lindex $t $i]
+ if {[getLiteral $w num] && ![catch {incr num 0}]} {
+ if {($min != {}) && ($num < $min)} {
+ logError pcx::outOfMinRange [getTokenRange $w] $num $min
+ }
+ if {($max != {}) && ($num > $max)} {
+ logError pcx::outOfMaxRange [getTokenRange $w] $num $min
+ }
+ }
+ return [checkInt $t $i]
+}
+
+# Initialization via pcx::init.
+# Use a ::asn::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/asn/asn.tcl b/tcllib/modules/asn/asn.tcl
new file mode 100644
index 0000000..cca460a
--- /dev/null
+++ b/tcllib/modules/asn/asn.tcl
@@ -0,0 +1,1580 @@
+#-----------------------------------------------------------------------------
+# Copyright (C) 1999-2004 Jochen C. Loewer (loewerj@web.de)
+# Copyright (C) 2004-2011 Michael Schlenker (mic42@users.sourceforge.net)
+#-----------------------------------------------------------------------------
+#
+# A partial ASN decoder/encoder implementation in plain Tcl.
+#
+# See ASN.1 (X.680) and BER (X.690).
+# See 'asn_ber_intro.txt' in this directory.
+#
+# This software is copyrighted by Jochen C. Loewer (loewerj@web.de). The
+# following terms apply to all files associated with the software unless
+# explicitly disclaimed in individual files.
+#
+# The authors hereby grant permission to use, copy, modify, distribute,
+# and license this software and its documentation for any purpose, provided
+# that existing copyright notices are retained in all copies and that this
+# notice is included verbatim in any distributions. No written agreement,
+# license, or royalty fee is required for any of the authorized uses.
+# Modifications to this software may be copyrighted by their authors
+# and need not follow the licensing terms described here, provided that
+# the new terms are clearly indicated on the first page of each file where
+# they apply.
+#
+# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+#
+# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+# MODIFICATIONS.
+#
+# written by Jochen Loewer
+# 3 June, 1999
+#
+# $Id: asn.tcl,v 1.20 2011/01/05 22:33:33 mic42 Exp $
+#
+#-----------------------------------------------------------------------------
+
+# needed for using wide()
+package require Tcl 8.4
+
+namespace eval asn {
+ # Encoder commands
+ namespace export \
+ asnSequence \
+ asnSequenceFromList \
+ asnSet \
+ asnSetFromList \
+ asnApplicationConstr \
+ asnApplication \
+ asnContext\
+ asnContextConstr\
+ asnChoice \
+ asnChoiceConstr \
+ asnInteger \
+ asnEnumeration \
+ asnBoolean \
+ asnOctetString \
+ asnNull \
+ asnUTCTime \
+ asnNumericString \
+ asnPrintableString \
+ asnIA5String\
+ asnBMPString\
+ asnUTF8String\
+ asnBitString \
+ asnObjectIdentifer
+
+ # Decoder commands
+ namespace export \
+ asnGetResponse \
+ asnGetInteger \
+ asnGetEnumeration \
+ asnGetOctetString \
+ asnGetSequence \
+ asnGetSet \
+ asnGetApplication \
+ asnGetNumericString \
+ asnGetPrintableString \
+ asnGetIA5String \
+ asnGetBMPString \
+ asnGetUTF8String \
+ asnGetObjectIdentifier \
+ asnGetBoolean \
+ asnGetUTCTime \
+ asnGetBitString \
+ asnGetContext
+
+ # general BER utility commands
+ namespace export \
+ asnPeekByte \
+ asnGetLength \
+ asnRetag \
+ asnPeekTag \
+ asnTag
+
+}
+
+#-----------------------------------------------------------------------------
+# Implementation notes:
+#
+# See the 'asn_ber_intro.txt' in this directory for an introduction
+# into BER/DER encoding of ASN.1 information. Bibliography information
+#
+# A Layman's Guide to a Subset of ASN.1, BER, and DER
+#
+# An RSA Laboratories Technical Note
+# Burton S. Kaliski Jr.
+# Revised November 1, 1993
+#
+# Supersedes June 3, 1991 version, which was also published as
+# NIST/OSI Implementors' Workshop document SEC-SIG-91-17.
+# PKCS documents are available by electronic mail to
+# <pkcs@rsa.com>.
+#
+# Copyright (C) 1991-1993 RSA Laboratories, a division of RSA
+# Data Security, Inc. License to copy this document is granted
+# provided that it is identified as "RSA Data Security, Inc.
+# Public-Key Cryptography Standards (PKCS)" in all material
+# mentioning or referencing this document.
+# 003-903015-110-000-000
+#
+#-----------------------------------------------------------------------------
+
+#-----------------------------------------------------------------------------
+# asnLength : Encode some length data. Helper command.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnLength {len} {
+
+ if {$len < 0} {
+ return -code error "Negative length octet requested"
+ }
+ if {$len < 128} {
+ # short form: ISO X.690 8.1.3.4
+ return [binary format c $len]
+ }
+ # long form: ISO X.690 8.1.3.5
+ # try to use a minimal encoding,
+ # even if not required by BER, but it is required by DER
+ # take care for signed vs. unsigned issues
+ if {$len < 256 } {
+ return [binary format H2c 81 [expr {$len - 256}]]
+ }
+ if {$len < 32769} {
+ # two octet signed value
+ return [binary format H2S 82 $len]
+ }
+ if {$len < 65536} {
+ return [binary format H2S 82 [expr {$len - 65536}]]
+ }
+ if {$len < 8388608} {
+ # three octet signed value
+ return [binary format H2cS 83 [expr {$len >> 16}] [expr {($len & 0xFFFF) - 65536}]]
+ }
+ if {$len < 16777216} {
+ # three octet signed value
+ return [binary format H2cS 83 [expr {($len >> 16) -256}] [expr {($len & 0xFFFF) -65536}]]
+ }
+ if {$len < 2147483649} {
+ # four octet signed value
+ return [binary format H2I 84 $len]
+ }
+ if {$len < 4294967296} {
+ # four octet unsigned value
+ return [binary format H2I 84 [expr {$len - 4294967296}]]
+ }
+ if {$len < 1099511627776} {
+ # five octet unsigned value
+ return [binary format H2 85][string range [binary format W $len] 3 end]
+ }
+ if {$len < 281474976710656} {
+ # six octet unsigned value
+ return [binary format H2 86][string range [binary format W $len] 2 end]
+ }
+ if {$len < 72057594037927936} {
+ # seven octet value
+ return [binary format H2 87][string range [binary format W $len] 1 end]
+ }
+
+ # must be a 64-bit wide signed value
+ return [binary format H2W 88 $len]
+}
+
+#-----------------------------------------------------------------------------
+# asnSequence : Assumes that the arguments are already ASN encoded.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnSequence {args} {
+ asnSequenceFromList $args
+}
+
+proc ::asn::asnSequenceFromList {lst} {
+ # The sequence tag is 0x30. The length is arbitrary and thus full
+ # length coding is required. The arguments have to be BER encoded
+ # already. Constructed value, definite-length encoding.
+
+ set out ""
+ foreach part $lst {
+ append out $part
+ }
+ set len [string length $out]
+ return [binary format H2a*a$len 30 [asnLength $len] $out]
+}
+
+
+#-----------------------------------------------------------------------------
+# asnSet : Assumes that the arguments are already ASN encoded.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnSet {args} {
+ asnSetFromList $args
+}
+
+proc ::asn::asnSetFromList {lst} {
+ # The set tag is 0x31. The length is arbitrary and thus full
+ # length coding is required. The arguments have to be BER encoded
+ # already.
+
+ set out ""
+ foreach part $lst {
+ append out $part
+ }
+ set len [string length $out]
+ return [binary format H2a*a$len 31 [asnLength $len] $out]
+}
+
+
+#-----------------------------------------------------------------------------
+# asnApplicationConstr
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnApplicationConstr {appNumber args} {
+ # Packs the arguments into a constructed value with application tag.
+
+ set out ""
+ foreach part $args {
+ append out $part
+ }
+ set code [expr {0x060 + $appNumber}]
+ set len [string length $out]
+ return [binary format ca*a$len $code [asnLength $len] $out]
+}
+
+#-----------------------------------------------------------------------------
+# asnApplication
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnApplication {appNumber data} {
+ # Packs the arguments into a constructed value with application tag.
+
+ set code [expr {0x040 + $appNumber}]
+ set len [string length $data]
+ return [binary format ca*a$len $code [asnLength $len] $data]
+}
+
+#-----------------------------------------------------------------------------
+# asnContextConstr
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnContextConstr {contextNumber args} {
+ # Packs the arguments into a constructed value with application tag.
+
+ set out ""
+ foreach part $args {
+ append out $part
+ }
+ set code [expr {0x0A0 + $contextNumber}]
+ set len [string length $out]
+ return [binary format ca*a$len $code [asnLength $len] $out]
+}
+
+#-----------------------------------------------------------------------------
+# asnContext
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnContext {contextNumber data} {
+ # Packs the arguments into a constructed value with application tag.
+ set code [expr {0x080 + $contextNumber}]
+ set len [string length $data]
+ return [binary format ca*a$len $code [asnLength $len] $data]
+}
+#-----------------------------------------------------------------------------
+# asnChoice
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnChoice {appNumber args} {
+ # Packs the arguments into a choice construction.
+
+ set out ""
+ foreach part $args {
+ append out $part
+ }
+ set code [expr {0x080 + $appNumber}]
+ set len [string length $out]
+ return [binary format ca*a$len $code [asnLength $len] $out]
+}
+
+#-----------------------------------------------------------------------------
+# asnChoiceConstr
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnChoiceConstr {appNumber args} {
+ # Packs the arguments into a choice construction.
+
+ set out ""
+ foreach part $args {
+ append out $part
+ }
+ set code [expr {0x0A0 + $appNumber}]
+ set len [string length $out]
+ return [binary format ca*a$len $code [asnLength $len] $out]
+}
+
+#-----------------------------------------------------------------------------
+# asnInteger : Encode integer value.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnInteger {number} {
+ asnIntegerOrEnum 02 $number
+}
+
+#-----------------------------------------------------------------------------
+# asnEnumeration : Encode enumeration value.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnEnumeration {number} {
+ asnIntegerOrEnum 0a $number
+}
+
+#-----------------------------------------------------------------------------
+# asnIntegerOrEnum : Common code for Integers and Enumerations
+# No Bignum version, as we do not expect large Enums.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnIntegerOrEnum {tag number} {
+ # The integer tag is 0x02 , the Enum Tag 0x0a otherwise identical.
+ # The length is 1, 2, 3, or 4, coded in a
+ # single byte. This can be done directly, no need to go through
+ # asnLength. The value itself is written in big-endian.
+
+ # Known bug/issue: The command cannot handle very wide integers, i.e.
+ # anything above 8 bytes length. Use asnBignumInteger for those.
+
+ # check if we really have an int
+ set num $number
+ incr num
+
+ if {($number >= -128) && ($number < 128)} {
+ return [binary format H2H2c $tag 01 $number]
+ }
+ if {($number >= -32768) && ($number < 32768)} {
+ return [binary format H2H2S $tag 02 $number]
+ }
+ if {($number >= -8388608) && ($number < 8388608)} {
+ set numberb [expr {$number & 0xFFFF}]
+ set numbera [expr {($number >> 16) & 0xFF}]
+ return [binary format H2H2cS $tag 03 $numbera $numberb]
+ }
+ if {($number >= -2147483648) && ($number < 2147483648)} {
+ return [binary format H2H2I $tag 04 $number]
+ }
+ if {($number >= -549755813888) && ($number < 549755813888)} {
+ set numberb [expr {$number & 0xFFFFFFFF}]
+ set numbera [expr {($number >> 32) & 0xFF}]
+ return [binary format H2H2cI $tag 05 $numbera $numberb]
+ }
+ if {($number >= -140737488355328) && ($number < 140737488355328)} {
+ set numberb [expr {$number & 0xFFFFFFFF}]
+ set numbera [expr {($number >> 32) & 0xFFFF}]
+ return [binary format H2H2SI $tag 06 $numbera $numberb]
+ }
+ if {($number >= -36028797018963968) && ($number < 36028797018963968)} {
+ set numberc [expr {$number & 0xFFFFFFFF}]
+ set numberb [expr {($number >> 32) & 0xFFFF}]
+ set numbera [expr {($number >> 48) & 0xFF}]
+ return [binary format H2H2cSI $tag 07 $numbera $numberb $numberc]
+ }
+ if {($number >= -9223372036854775808) && ($number <= 9223372036854775807)} {
+ return [binary format H2H2W $tag 08 $number]
+ }
+ return -code error "Integer value to large to encode, use asnBigInteger"
+}
+
+#-----------------------------------------------------------------------------
+# asnBigInteger : Encode a long integer value using math::bignum
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnBigInteger {bignum} {
+ # require math::bignum only if it is used
+ package require math::bignum
+
+ # this is a hack to check for bignum...
+ if {[llength $bignum] < 2 || ([lindex $bignum 0] ne "bignum")} {
+ return -code error "expected math::bignum value got \"$bignum\""
+ }
+ if {[math::bignum::sign $bignum]} {
+ # generate two's complement form
+ set bits [math::bignum::bits $bignum]
+ set padding [expr {$bits % 8}]
+ set len [expr {int(ceil($bits / 8.0))}]
+ if {$padding == 0} {
+ # we need a complete extra byte for the sign
+ # unless this is a base 2 multiple
+ set test [math::bignum::fromstr 0]
+ math::bignum::setbit test [expr {$bits-1}]
+ if {[math::bignum::ne [math::bignum::abs $bignum] $test]} {
+ incr len
+ }
+ }
+ set exp [math::bignum::pow \
+ [math::bignum::fromstr 256] \
+ [math::bignum::fromstr $len]]
+ set bignum [math::bignum::add $bignum $exp]
+ set hex [math::bignum::tostr $bignum 16]
+ } else {
+ set bits [math::bignum::bits $bignum]
+ if {($bits % 8) == 0 && $bits > 0} {
+ set pad "00"
+ } else {
+ set pad ""
+ }
+ set hex $pad[math::bignum::tostr $bignum 16]
+ }
+ if {[string length $hex]%2} {
+ set hex "0$hex"
+ }
+ set octets [expr {(([string length $hex]+1)/2)}]
+ return [binary format H2a*H* 02 [asnLength $octets] $hex]
+}
+
+
+#-----------------------------------------------------------------------------
+# asnBoolean : Encode a boolean value.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnBoolean {bool} {
+ # The boolean tag is 0x01. The length is always 1, coded in
+ # a single byte. This can be done directly, no need to go through
+ # asnLength. The value itself is written in big-endian.
+
+ return [binary format H2H2c 01 01 [expr {$bool ? 0x0FF : 0x0}]]
+}
+
+#-----------------------------------------------------------------------------
+# asnOctetString : Encode a string of arbitrary bytes
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnOctetString {string} {
+ # The octet tag is 0x04. The length is arbitrary, so we need
+ # 'asnLength' for full coding of the length.
+
+ set len [string length $string]
+ return [binary format H2a*a$len 04 [asnLength $len] $string]
+}
+
+#-----------------------------------------------------------------------------
+# asnNull : Encode a null value
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnNull {} {
+ # Null has only one valid encoding
+ return \x05\x00
+}
+
+#-----------------------------------------------------------------------------
+# asnBitstring : Encode a Bit String value
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnBitString {bitstring} {
+ # The bit string tag is 0x03.
+ # Bit strings can be either simple or constructed
+ # we always use simple encoding
+
+ set bitlen [string length $bitstring]
+ set padding [expr {(8 - ($bitlen % 8)) % 8}]
+ set len [expr {($bitlen / 8) + 1}]
+ if {$padding != 0} { incr len }
+
+ return [binary format H2a*cB* 03 [asnLength $len] $padding $bitstring]
+}
+
+#-----------------------------------------------------------------------------
+# asnUTCTime : Encode an UTC time string
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnUTCTime {UTCtimestring} {
+ # the utc time tag is 0x17.
+ #
+ # BUG: we do not check the string for well formedness
+
+ set ascii [encoding convertto ascii $UTCtimestring]
+ set len [string length $ascii]
+ return [binary format H2a*a* 17 [asnLength $len] $ascii]
+}
+
+#-----------------------------------------------------------------------------
+# asnPrintableString : Encode a printable string
+#-----------------------------------------------------------------------------
+namespace eval asn {
+ variable nonPrintableChars {[^ A-Za-z0-9'()+,.:/?=-]}
+}
+proc ::asn::asnPrintableString {string} {
+ # the printable string tag is 0x13
+ variable nonPrintableChars
+ # it is basically a restricted ascii string
+ if {[regexp $nonPrintableChars $string ]} {
+ return -code error "Illegal character in PrintableString."
+ }
+
+ # check characters
+ set ascii [encoding convertto ascii $string]
+ return [asnEncodeString 13 $ascii]
+}
+
+#-----------------------------------------------------------------------------
+# asnIA5String : Encode an Ascii String
+#-----------------------------------------------------------------------------
+proc ::asn::asnIA5String {string} {
+ # the IA5 string tag is 0x16
+ # check for extended charachers
+ if {[string length $string]!=[string bytelength $string]} {
+ return -code error "Illegal character in IA5String"
+ }
+ set ascii [encoding convertto ascii $string]
+ return [asnEncodeString 16 $ascii]
+}
+
+#-----------------------------------------------------------------------------
+# asnNumericString : Encode a Numeric String type
+#-----------------------------------------------------------------------------
+namespace eval asn {
+ variable nonNumericChars {[^0-9 ]}
+}
+proc ::asn::asnNumericString {string} {
+ # the Numeric String type has tag 0x12
+ variable nonNumericChars
+ if {[regexp $nonNumericChars $string]} {
+ return -code error "Illegal character in Numeric String."
+ }
+
+ return [asnEncodeString 12 $string]
+}
+#----------------------------------------------------------------------
+# asnBMPString: Encode a Tcl string as Basic Multinligval (UCS2) string
+#-----------------------------------------------------------------------
+proc asn::asnBMPString {string} {
+ if {$::tcl_platform(byteOrder) eq "littleEndian"} {
+ set bytes ""
+ foreach {lo hi} [split [encoding convertto unicode $string] ""] {
+ append bytes $hi $lo
+ }
+ } else {
+ set bytes [encoding convertto unicode $string]
+ }
+ return [asnEncodeString 1e $bytes]
+}
+#---------------------------------------------------------------------------
+# asnUTF8String: encode tcl string as UTF8 String
+#----------------------------------------------------------------------------
+proc asn::asnUTF8String {string} {
+ return [asnEncodeString 0c [encoding convertto utf-8 $string]]
+}
+#-----------------------------------------------------------------------------
+# asnEncodeString : Encode an RestrictedCharacter String
+#-----------------------------------------------------------------------------
+proc ::asn::asnEncodeString {tag string} {
+ set len [string length $string]
+ return [binary format H2a*a$len $tag [asnLength $len] $string]
+}
+
+#-----------------------------------------------------------------------------
+# asnObjectIdentifier : Encode an Object Identifier value
+#-----------------------------------------------------------------------------
+proc ::asn::asnObjectIdentifier {oid} {
+ # the object identifier tag is 0x06
+
+ if {[llength $oid] < 2} {
+ return -code error "OID must have at least two subidentifiers."
+ }
+
+ # basic check that it is valid
+ foreach identifier $oid {
+ if {$identifier < 0} {
+ return -code error \
+ "Malformed OID. Identifiers must be positive Integers."
+ }
+ }
+
+ if {[lindex $oid 0] > 2} {
+ return -code error "First subidentifier must be 0,1 or 2"
+ }
+ if {[lindex $oid 1] > 39} {
+ return -code error \
+ "Second subidentifier must be between 0 and 39"
+ }
+
+ # handle the special cases directly
+ switch [llength $oid] {
+ 2 { return [binary format H2H2c 06 01 \
+ [expr {[lindex $oid 0]*40+[lindex $oid 1]}]] }
+ default {
+ # This can probably be written much shorter.
+ # Just a first try that works...
+ #
+ set octets [binary format c \
+ [expr {[lindex $oid 0]*40+[lindex $oid 1]}]]
+ foreach identifier [lrange $oid 2 end] {
+ set d 128
+ if {$identifier < 128} {
+ set subidentifier [list $identifier]
+ } else {
+ set subidentifier [list]
+ # find the largest divisor
+
+ while {($identifier / $d) >= 128} {
+ set d [expr {$d * 128}]
+ }
+ # and construct the subidentifiers
+ set remainder $identifier
+ while {$d >= 128} {
+ set coefficient [expr {($remainder / $d) | 0x80}]
+ set remainder [expr {$remainder % $d}]
+ set d [expr {$d / 128}]
+ lappend subidentifier $coefficient
+ }
+ lappend subidentifier $remainder
+ }
+ append octets [binary format c* $subidentifier]
+ }
+ return [binary format H2a*a* 06 \
+ [asnLength [string length $octets]] $octets]
+ }
+ }
+
+}
+
+#-----------------------------------------------------------------------------
+# asnGetResponse : Read a ASN response from a channel.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetResponse {sock data_var} {
+ upvar 1 $data_var data
+
+ # We expect a sequence here (tag 0x30). The code below is an
+ # inlined replica of 'asnGetSequence', modified for reading from a
+ # channel instead of a string.
+
+ set tag [read $sock 1]
+
+ if {$tag == "\x30"} {
+ # The following code is a replica of 'asnGetLength', modified
+ # for reading the bytes from the channel instead of a string.
+
+ set len1 [read $sock 1]
+ binary scan $len1 c num
+ set length [expr {($num + 0x100) % 0x100}]
+
+ if {$length >= 0x080} {
+ # The byte the read is not the length, but a prefix, and
+ # the lower nibble tells us how many bytes follow.
+
+ set len_length [expr {$length & 0x7f}]
+
+ # BUG: We should not perform the value extraction for an
+ # BUG: improper length. It wastes cycles, and here it can
+ # BUG: cause us trouble, reading more data than there is
+ # BUG: on the channel. Depending on the channel
+ # BUG: configuration an attacker can induce us to block,
+ # BUG: causing a denial of service.
+ set lengthBytes [read $sock $len_length]
+
+ switch $len_length {
+ 1 {
+ binary scan $lengthBytes c length
+ set length [expr {($length + 0x100) % 0x100}]
+ }
+ 2 { binary scan $lengthBytes S length }
+ 3 { binary scan \x00$lengthBytes I length }
+ 4 { binary scan $lengthBytes I length }
+ default {
+ return -code error \
+ "length information too long ($len_length)"
+ }
+ }
+ }
+
+ # Now that the length is known we get the remainder,
+ # i.e. payload, and construct proper in-memory BER encoded
+ # sequence.
+
+ set rest [read $sock $length]
+ set data [binary format aa*a$length $tag [asnLength $length] $rest]
+ } else {
+ # Generate an error message if the data is not a sequence as
+ # we expected.
+
+ set tag_hex ""
+ binary scan $tag H2 tag_hex
+ return -code error "unknown start tag [string length $tag] $tag_hex"
+ }
+}
+
+if {[package vsatisfies [package present Tcl] 8.5.0]} {
+##############################################################################
+# Code for 8.5
+##############################################################################
+#-----------------------------------------------------------------------------
+# asnGetByte (8.5 version) : Retrieve a single byte from the data (unsigned)
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetByte {data_var byte_var} {
+ upvar 1 $data_var data $byte_var byte
+
+ binary scan [string index $data 0] cu byte
+ set data [string range $data 1 end]
+
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnPeekByte (8.5 version) : Retrieve a single byte from the data (unsigned)
+# without removing it.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnPeekByte {data_var byte_var {offset 0}} {
+ upvar 1 $data_var data $byte_var byte
+
+ binary scan [string index $data $offset] cu byte
+
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnGetLength (8.5 version) : Decode an ASN length value (See notes)
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetLength {data_var length_var} {
+ upvar 1 $data_var data $length_var length
+
+ asnGetByte data length
+ if {$length == 0x080} {
+ return -code error "Indefinite length BER encoding not yet supported"
+ }
+ if {$length > 0x080} {
+ # The retrieved byte is a prefix value, and the integer in the
+ # lower nibble tells us how many bytes were used to encode the
+ # length data following immediately after this prefix.
+
+ set len_length [expr {$length & 0x7f}]
+
+ if {[string length $data] < $len_length} {
+ return -code error \
+ "length information invalid, not enough octets left"
+ }
+
+ asnGetBytes data $len_length lengthBytes
+
+ switch $len_length {
+ 1 { binary scan $lengthBytes cu length }
+ 2 { binary scan $lengthBytes Su length }
+ 3 { binary scan \x00$lengthBytes Iu length }
+ 4 { binary scan $lengthBytes Iu length }
+ default {
+ binary scan $lengthBytes H* hexstr
+ scan $hexstr %llx length
+ }
+ }
+ }
+ return
+}
+
+} else {
+##############################################################################
+# Code for Tcl 8.4
+##############################################################################
+#-----------------------------------------------------------------------------
+# asnGetByte : Retrieve a single byte from the data (unsigned)
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetByte {data_var byte_var} {
+ upvar 1 $data_var data $byte_var byte
+
+ binary scan [string index $data 0] c byte
+ set byte [expr {($byte + 0x100) % 0x100}]
+ set data [string range $data 1 end]
+
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnPeekByte : Retrieve a single byte from the data (unsigned)
+# without removing it.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnPeekByte {data_var byte_var {offset 0}} {
+ upvar 1 $data_var data $byte_var byte
+
+ binary scan [string index $data $offset] c byte
+ set byte [expr {($byte + 0x100) % 0x100}]
+
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnGetLength : Decode an ASN length value (See notes)
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetLength {data_var length_var} {
+ upvar 1 $data_var data $length_var length
+
+ asnGetByte data length
+ if {$length == 0x080} {
+ return -code error "Indefinite length BER encoding not yet supported"
+ }
+ if {$length > 0x080} {
+ # The retrieved byte is a prefix value, and the integer in the
+ # lower nibble tells us how many bytes were used to encode the
+ # length data following immediately after this prefix.
+
+ set len_length [expr {$length & 0x7f}]
+
+ if {[string length $data] < $len_length} {
+ return -code error \
+ "length information invalid, not enough octets left"
+ }
+
+ asnGetBytes data $len_length lengthBytes
+
+ switch $len_length {
+ 1 {
+ # Efficiently coded data will not go through this
+ # path, as small length values can be coded directly,
+ # without a prefix.
+
+ binary scan $lengthBytes c length
+ set length [expr {($length + 0x100) % 0x100}]
+ }
+ 2 { binary scan $lengthBytes S length
+ set length [expr {($length + 0x10000) % 0x10000}]
+ }
+ 3 { binary scan \x00$lengthBytes I length
+ set length [expr {($length + 0x1000000) % 0x1000000}]
+ }
+ 4 { binary scan $lengthBytes I length
+ set length [expr {(wide($length) + 0x100000000) % 0x100000000}]
+ }
+ default {
+ binary scan $lengthBytes H* hexstr
+ # skip leading zeros which are allowed by BER
+ set hexlen [string trimleft $hexstr 0]
+ # check if it fits into a 64-bit signed integer
+ if {[string length $hexlen] > 16} {
+ return -code error -errorcode {ARITH IOVERFLOW
+ {Length value too large for normal use, try asnGetBigLength}} \
+ "Length value to large"
+ } elseif { [string length $hexlen] == 16 \
+ && ([string index $hexlen 0] & 0x8)} {
+ # check most significant bit, if set we need bignum
+ return -code error -errorcode {ARITH IOVERFLOW
+ {Length value too large for normal use, try asnGetBigLength}} \
+ "Length value to large"
+ } else {
+ scan $hexstr "%lx" length
+ }
+ }
+ }
+ }
+ return
+}
+
+}
+
+#-----------------------------------------------------------------------------
+# asnRetag: Remove an explicit tag with the real newTag
+#
+#-----------------------------------------------------------------------------
+proc ::asn::asnRetag {data_var newTag} {
+ upvar 1 $data_var data
+ set tag ""
+ set type ""
+ set len [asnPeekTag data tag type dummy]
+ asnGetBytes data $len tagbytes
+ set data [binary format c* $newTag]$data
+}
+
+#-----------------------------------------------------------------------------
+# asnGetBytes : Retrieve a block of 'length' bytes from the data.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetBytes {data_var length bytes_var} {
+ upvar 1 $data_var data $bytes_var bytes
+
+ incr length -1
+ set bytes [string range $data 0 $length]
+ incr length
+ set data [string range $data $length end]
+
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnPeekTag : Decode the tag value
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnPeekTag {data_var tag_var tagtype_var constr_var} {
+ upvar 1 $data_var data $tag_var tag $tagtype_var tagtype $constr_var constr
+
+ set type 0
+ set offset 0
+ asnPeekByte data type $offset
+ # check if we have a simple tag, < 31, which fits in one byte
+
+ set tval [expr {$type & 0x1f}]
+ if {$tval == 0x1f} {
+ # long tag, max 64-bit with Tcl 8.4, unlimited with 8.5 bignum
+ asnPeekByte data tagbyte [incr offset]
+ set tval [expr {wide($tagbyte & 0x7f)}]
+ while {($tagbyte & 0x80)} {
+ asnPeekByte data tagbyte [incr offset]
+ set tval [expr {($tval << 7) + ($tagbyte & 0x7f)}]
+ }
+ }
+
+ set tagtype [lindex {UNIVERSAL APPLICATION CONTEXT PRIVATE} \
+ [expr {($type & 0xc0) >>6}]]
+ set tag $tval
+ set constr [expr {($type & 0x20) > 0}]
+
+ return [incr offset]
+}
+
+#-----------------------------------------------------------------------------
+# asnTag : Build a tag value
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnTag {tagnumber {class UNIVERSAL} {tagstyle P}} {
+ set first 0
+ if {$tagnumber < 31} {
+ # encode everything in one byte
+ set first $tagnumber
+ set bytes [list]
+ } else {
+ # multi-byte tag
+ set first 31
+ set bytes [list [expr {$tagnumber & 0x7f}]]
+ set tagnumber [expr {$tagnumber >> 7}]
+ while {$tagnumber > 0} {
+ lappend bytes [expr {($tagnumber & 0x7f)+0x80}]
+ set tagnumber [expr {$tagnumber >>7}]
+ }
+
+ }
+
+ if {$tagstyle eq "C" || $tagstyle == 1 } {incr first 32}
+ switch -glob -- $class {
+ U* { ;# UNIVERSAL }
+ A* { incr first 64 ;# APPLICATION }
+ C* { incr first 128 ;# CONTEXT }
+ P* { incr first 192 ;# PRIVATE }
+ default {
+ return -code error "Unknown tag class \"$class\""
+ }
+ }
+ if {[llength $bytes] > 0} {
+ # long tag
+ set rbytes [list]
+ for {set i [expr {[llength $bytes]-1}]} {$i >= 0} {incr i -1} {
+ lappend rbytes [lindex $bytes $i]
+ }
+ return [binary format cc* $first $rbytes ]
+ }
+ return [binary format c $first]
+}
+
+
+
+#-----------------------------------------------------------------------------
+# asnGetBigLength : Retrieve a length that can not be represented in 63-bit
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetBigLength {data_var biglength_var} {
+
+ # Does any real world code really need this?
+ # If we encounter this, we are doomed to fail anyway,
+ # (there would be an Exabyte inside the data_var, )
+ #
+ # So i implement it just for completeness.
+ #
+ package require math::bignum
+
+ upvar 1 $data_var data $biglength_var length
+
+ asnGetByte data length
+ if {$length == 0x080} {
+ return -code error "Indefinite length BER encoding not yet supported"
+ }
+ if {$length > 0x080} {
+ # The retrieved byte is a prefix value, and the integer in the
+ # lower nibble tells us how many bytes were used to encode the
+ # length data following immediately after this prefix.
+
+ set len_length [expr {$length & 0x7f}]
+
+ if {[string length $data] < $len_length} {
+ return -code error \
+ "length information invalid, not enough octets left"
+ }
+
+ asnGetBytes data $len_length lengthBytes
+ binary scan $lengthBytes H* hexlen
+ set length [math::bignum::fromstr $hexlen 16]
+ }
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnGetInteger : Retrieve integer.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetInteger {data_var int_var} {
+ # Tag is 0x02.
+
+ upvar 1 $data_var data $int_var int
+
+ asnGetByte data tag
+
+ if {$tag != 0x02} {
+ return -code error \
+ [format "Expected Integer (0x02), but got %02x" $tag]
+ }
+
+ asnGetLength data len
+ asnGetBytes data $len integerBytes
+
+ set int ?
+
+ switch $len {
+ 1 { binary scan $integerBytes c int }
+ 2 { binary scan $integerBytes S int }
+ 3 {
+ # check for negative int and pad
+ scan [string index $integerBytes 0] %c byte
+ if {$byte & 128} {
+ binary scan \xff$integerBytes I int
+ } else {
+ binary scan \x00$integerBytes I int
+ }
+ }
+ 4 { binary scan $integerBytes I int }
+ 5 -
+ 6 -
+ 7 -
+ 8 {
+ # check for negative int and pad
+ scan [string index $integerBytes 0] %c byte
+ if {$byte & 128} {
+ set pad [string repeat \xff [expr {8-$len}]]
+ } else {
+ set pad [string repeat \x00 [expr {8-$len}]]
+ }
+ binary scan $pad$integerBytes W int
+ }
+ default {
+ # Too long, or prefix coding was used.
+ return -code error "length information too long"
+ }
+ }
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnGetBigInteger : Retrieve a big integer.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetBigInteger {data_var bignum_var} {
+ # require math::bignum only if it is used
+ package require math::bignum
+
+ # Tag is 0x02. We expect that the length of the integer is coded with
+ # maximal efficiency, i.e. without a prefix 0x81 prefix. If a prefix
+ # is used this decoder will fail.
+
+ upvar $data_var data $bignum_var bignum
+
+ asnGetByte data tag
+
+ if {$tag != 0x02} {
+ return -code error \
+ [format "Expected Integer (0x02), but got %02x" $tag]
+ }
+
+ asnGetLength data len
+ asnGetBytes data $len integerBytes
+
+ binary scan [string index $integerBytes 0] H* hex_head
+ set head [expr 0x$hex_head]
+ set replacement_head [expr {$head & 0x7f}]
+ set integerBytes [string replace $integerBytes 0 0 [format %c $replacement_head]]
+
+ binary scan $integerBytes H* hex
+
+ set bignum [math::bignum::fromstr $hex 16]
+
+ if {($head >> 7) && 1} {
+ set bigsub [math::bignum::pow [::math::bignum::fromstr 2] [::math::bignum::fromstr [expr {($len * 8) - 1}]]]
+ set bignum [math::bignum::sub $bignum $bigsub]
+ }
+
+ return $bignum
+}
+
+
+
+
+#-----------------------------------------------------------------------------
+# asnGetEnumeration : Retrieve an enumeration id
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetEnumeration {data_var enum_var} {
+ # This is like 'asnGetInteger', except for a different tag.
+
+ upvar 1 $data_var data $enum_var enum
+
+ asnGetByte data tag
+
+ if {$tag != 0x0a} {
+ return -code error \
+ [format "Expected Enumeration (0x0a), but got %02x" $tag]
+ }
+
+ asnGetLength data len
+ asnGetBytes data $len integerBytes
+ set enum ?
+
+ switch $len {
+ 1 { binary scan $integerBytes c enum }
+ 2 { binary scan $integerBytes S enum }
+ 3 { binary scan \x00$integerBytes I enum }
+ 4 { binary scan $integerBytes I enum }
+ default {
+ return -code error "length information too long"
+ }
+ }
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnGetOctetString : Retrieve arbitrary string.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetOctetString {data_var string_var} {
+ # Here we need the full decoder for length data.
+
+ upvar 1 $data_var data $string_var string
+
+ asnGetByte data tag
+ if {$tag != 0x04} {
+ return -code error \
+ [format "Expected Octet String (0x04), but got %02x" $tag]
+ }
+ asnGetLength data length
+ asnGetBytes data $length temp
+ set string $temp
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnGetSequence : Retrieve Sequence data for further decoding.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetSequence {data_var sequence_var} {
+ # Here we need the full decoder for length data.
+
+ upvar 1 $data_var data $sequence_var sequence
+
+ asnGetByte data tag
+ if {$tag != 0x030} {
+ return -code error \
+ [format "Expected Sequence (0x30), but got %02x" $tag]
+ }
+ asnGetLength data length
+ asnGetBytes data $length temp
+ set sequence $temp
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnGetSet : Retrieve Set data for further decoding.
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetSet {data_var set_var} {
+ # Here we need the full decoder for length data.
+
+ upvar 1 $data_var data $set_var set
+
+ asnGetByte data tag
+ if {$tag != 0x031} {
+ return -code error \
+ [format "Expected Set (0x31), but got %02x" $tag]
+ }
+ asnGetLength data length
+ asnGetBytes data $length temp
+ set set $temp
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnGetApplication
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetApplication {data_var appNumber_var {content_var {}} {encodingType_var {}} } {
+ upvar 1 $data_var data $appNumber_var appNumber
+
+ asnGetByte data tag
+ asnGetLength data length
+
+ if {($tag & 0xC0) != 0x40} {
+ return -code error \
+ [format "Expected Application, but got %02x" $tag]
+ }
+ if {$encodingType_var != {}} {
+ upvar 1 $encodingType_var encodingType
+ set encodingType [expr {($tag & 0x20) > 0}]
+ }
+ set appNumber [expr {$tag & 0x1F}]
+ if {[string length $content_var]} {
+ upvar 1 $content_var content
+ asnGetBytes data $length content
+ }
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnGetBoolean: decode a boolean value
+#-----------------------------------------------------------------------------
+
+proc asn::asnGetBoolean {data_var bool_var} {
+ upvar 1 $data_var data $bool_var bool
+
+ asnGetByte data tag
+ if {$tag != 0x01} {
+ return -code error \
+ [format "Expected Boolean (0x01), but got %02x" $tag]
+ }
+
+ asnGetLength data length
+ asnGetByte data byte
+ set bool [expr {$byte == 0 ? 0 : 1}]
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnGetUTCTime: Extract an UTC Time string from the data. Returns a string
+# representing an UTC Time.
+#
+#-----------------------------------------------------------------------------
+
+proc asn::asnGetUTCTime {data_var utc_var} {
+ upvar 1 $data_var data $utc_var utc
+
+ asnGetByte data tag
+ if {$tag != 0x17} {
+ return -code error \
+ [format "Expected UTCTime (0x17), but got %02x" $tag]
+ }
+
+ asnGetLength data length
+ asnGetBytes data $length bytes
+
+ # this should be ascii, make it explicit
+ set bytes [encoding convertfrom ascii $bytes]
+ binary scan $bytes a* utc
+
+ return
+}
+
+
+#-----------------------------------------------------------------------------
+# asnGetBitString: Extract a Bit String value (a string of 0/1s) from the
+# ASN.1 data.
+#
+#-----------------------------------------------------------------------------
+
+proc asn::asnGetBitString {data_var bitstring_var} {
+ upvar 1 $data_var data $bitstring_var bitstring
+
+ asnGetByte data tag
+ if {$tag != 0x03} {
+ return -code error \
+ [format "Expected Bit String (0x03), but got %02x" $tag]
+ }
+
+ asnGetLength data length
+ # get the number of padding bits used at the end
+ asnGetByte data padding
+ incr length -1
+ asnGetBytes data $length bytes
+ binary scan $bytes B* bits
+
+ # cut off the padding bits
+ set bits [string range $bits 0 end-$padding]
+ set bitstring $bits
+}
+
+#-----------------------------------------------------------------------------
+# asnGetObjectIdentifier: Decode an ASN.1 Object Identifier (OID) into
+# a Tcl list of integers.
+#-----------------------------------------------------------------------------
+
+proc asn::asnGetObjectIdentifier {data_var oid_var} {
+ upvar 1 $data_var data $oid_var oid
+
+ asnGetByte data tag
+ if {$tag != 0x06} {
+ return -code error \
+ [format "Expected Object Identifier (0x06), but got %02x" $tag]
+ }
+ asnGetLength data length
+
+ # the first byte encodes the OID parts in position 0 and 1
+ asnGetByte data val
+ set oid [expr {$val / 40}]
+ lappend oid [expr {$val % 40}]
+ incr length -1
+
+ # the next bytes encode the remaining parts of the OID
+ set bytes [list]
+ set incomplete 0
+ while {$length} {
+ asnGetByte data octet
+ incr length -1
+ if {$octet < 128} {
+ set oidval $octet
+ set mult 128
+ foreach byte $bytes {
+ if {$byte != {}} {
+ incr oidval [expr {$mult*$byte}]
+ set mult [expr {$mult*128}]
+ }
+ }
+ lappend oid $oidval
+ set bytes [list]
+ set incomplete 0
+ } else {
+ set byte [expr {$octet-128}]
+ set bytes [concat [list $byte] $bytes]
+ set incomplete 1
+ }
+ }
+ if {$incomplete} {
+ return -code error "OID Data is incomplete, not enough octets."
+ }
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnGetContext: Decode an explicit context tag
+#
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetContext {data_var contextNumber_var {content_var {}} {encodingType_var {}}} {
+ upvar 1 $data_var data $contextNumber_var contextNumber
+
+ asnGetByte data tag
+ asnGetLength data length
+
+ if {($tag & 0xC0) != 0x80} {
+ return -code error \
+ [format "Expected Context, but got %02x" $tag]
+ }
+ if {$encodingType_var != {}} {
+ upvar 1 $encodingType_var encodingType
+ set encodingType [expr {($tag & 0x20) > 0}]
+ }
+ set contextNumber [expr {$tag & 0x1F}]
+ if {[string length $content_var]} {
+ upvar 1 $content_var content
+ asnGetBytes data $length content
+ }
+ return
+}
+
+
+#-----------------------------------------------------------------------------
+# asnGetNumericString: Decode a Numeric String from the data
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetNumericString {data_var print_var} {
+ upvar 1 $data_var data $print_var print
+
+ asnGetByte data tag
+ if {$tag != 0x12} {
+ return -code error \
+ [format "Expected Numeric String (0x12), but got %02x" $tag]
+ }
+ asnGetLength data length
+ asnGetBytes data $length string
+ set print [encoding convertfrom ascii $string]
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnGetPrintableString: Decode a Printable String from the data
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetPrintableString {data_var print_var} {
+ upvar 1 $data_var data $print_var print
+
+ asnGetByte data tag
+ if {$tag != 0x13} {
+ return -code error \
+ [format "Expected Printable String (0x13), but got %02x" $tag]
+ }
+ asnGetLength data length
+ asnGetBytes data $length string
+ set print [encoding convertfrom ascii $string]
+ return
+}
+
+#-----------------------------------------------------------------------------
+# asnGetIA5String: Decode a IA5(ASCII) String from the data
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetIA5String {data_var print_var} {
+ upvar 1 $data_var data $print_var print
+
+ asnGetByte data tag
+ if {$tag != 0x16} {
+ return -code error \
+ [format "Expected IA5 String (0x16), but got %02x" $tag]
+ }
+ asnGetLength data length
+ asnGetBytes data $length string
+ set print [encoding convertfrom ascii $string]
+ return
+}
+#------------------------------------------------------------------------
+# asnGetBMPString: Decode Basic Multiningval (UCS2 string) from data
+#------------------------------------------------------------------------
+proc asn::asnGetBMPString {data_var print_var} {
+ upvar 1 $data_var data $print_var print
+ asnGetByte data tag
+ if {$tag != 0x1e} {
+ return -code error \
+ [format "Expected BMP String (0x1e), but got %02x" $tag]
+ }
+ asnGetLength data length
+ asnGetBytes data $length string
+ if {$::tcl_platform(byteOrder) eq "littleEndian"} {
+ set str2 ""
+ foreach {hi lo} [split $string ""] {
+ append str2 $lo $hi
+ }
+ } else {
+ set str2 $string
+ }
+ set print [encoding convertfrom unicode $str2]
+ return
+}
+#------------------------------------------------------------------------
+# asnGetUTF8String: Decode UTF8 string from data
+#------------------------------------------------------------------------
+proc asn::asnGetUTF8String {data_var print_var} {
+ upvar 1 $data_var data $print_var print
+ asnGetByte data tag
+ if {$tag != 0x0c} {
+ return -code error \
+ [format "Expected UTF8 String (0x0c), but got %02x" $tag]
+ }
+ asnGetLength data length
+ asnGetBytes data $length string
+ #there should be some error checking to see if input is
+ #properly-formatted utf8
+ set print [encoding convertfrom utf-8 $string]
+
+ return
+}
+#-----------------------------------------------------------------------------
+# asnGetNull: decode a NULL value
+#-----------------------------------------------------------------------------
+
+proc ::asn::asnGetNull {data_var} {
+ upvar 1 $data_var data
+
+ asnGetByte data tag
+ if {$tag != 0x05} {
+ return -code error \
+ [format "Expected NULL (0x05), but got %02x" $tag]
+ }
+
+ asnGetLength data length
+ asnGetBytes data $length bytes
+
+ # we do not check the null data, all bytes must be 0x00
+
+ return
+}
+
+#----------------------------------------------------------------------------
+# MultiType string routines
+#----------------------------------------------------------------------------
+
+namespace eval asn {
+ variable stringTypes
+ array set stringTypes {
+ 12 NumericString
+ 13 PrintableString
+ 16 IA5String
+ 1e BMPString
+ 0c UTF8String
+ 14 T61String
+ 15 VideotexString
+ 1a VisibleString
+ 1b GeneralString
+ 1c UniversalString
+ }
+ variable defaultStringType UTF8
+}
+#---------------------------------------------------------------------------
+# asnGetString - get readable string automatically detecting its type
+#---------------------------------------------------------------------------
+proc ::asn::asnGetString {data_var print_var {type_var {}}} {
+ variable stringTypes
+ upvar 1 $data_var data $print_var print
+ asnPeekByte data tag
+ set tag [format %02x $tag]
+ if {![info exists stringTypes($tag)]} {
+ return -code error "Expected one of string types, but got $tag"
+ }
+ asnGet$stringTypes($tag) data print
+ if {[string length $type_var]} {
+ upvar $type_var type
+ set type $stringTypes($tag)
+ }
+}
+#---------------------------------------------------------------------
+# defaultStringType - set or query default type for unrestricted strings
+#---------------------------------------------------------------------
+proc ::asn::defaultStringType {{type {}}} {
+ variable defaultStringType
+ if {![string length $type]} {
+ return $defaultStringType
+ }
+ if {$type ne "BMP" && $type ne "UTF8"} {
+ return -code error "Invalid default string type. Should be one of BMP, UTF8"
+ }
+ set defaultStringType $type
+ return
+}
+
+#---------------------------------------------------------------------------
+# asnString - encode readable string into most restricted type possible
+#---------------------------------------------------------------------------
+
+proc ::asn::asnString {string} {
+ variable nonPrintableChars
+ variable nonNumericChars
+ if {[string length $string]!=[string bytelength $string]} {
+ # There are non-ascii character
+ variable defaultStringType
+ return [asn${defaultStringType}String $string]
+ } elseif {![regexp $nonNumericChars $string]} {
+ return [asnNumericString $string]
+ } elseif {![regexp $nonPrintableChars $string]} {
+ return [asnPrintableString $string]
+ } else {
+ return [asnIA5String $string]
+ }
+}
+
+#-----------------------------------------------------------------------------
+package provide asn 0.8.4
+
diff --git a/tcllib/modules/asn/asn.test b/tcllib/modules/asn/asn.test
new file mode 100644
index 0000000..9ec628b
--- /dev/null
+++ b/tcllib/modules/asn/asn.test
@@ -0,0 +1,956 @@
+# -*- tcl -*-
+# asn.test: tests for the asn BER encoding/decoding module.
+#
+# Copyright (c) 2004 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Copyright (c) 2004-2007 by Michael Schlenker <mic42@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: asn.test,v 1.19 2011/01/05 22:33:33 mic42 Exp $
+
+# -------------------------------------------------------------------------
+
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+
+testsNeedTcl 8.4
+testsNeedTcltest 1.0
+
+testing {
+ useLocal asn.tcl asn
+}
+
+# Converts binary encoded structure into hexadecimal dump
+# which is more readable in test results
+# Allows cut'n'paste both encoded and parsed OID from dumpasn1.cfg
+#
+proc bytes2hex {string} {
+ foreach b [split $string ""] {
+ lappend l [format %02X [scan $b %c]]
+ }
+ return [join $l " "]
+}
+
+# -------------------------------------------------------------------------
+
+test asn-1.0 {integer} {
+ catch {asn::asnInteger} result
+ set result
+} [tcltest::wrongNumArgs {asn::asnInteger} {number} 0]
+
+test asn-1.1 {integer} {
+ catch {asn::asnInteger a b} result
+ set result
+} [tcltest::tooManyArgs {asn::asnInteger} {number}]
+
+test asn-1.2 {integer} {
+ catch {asn::asnInteger a} result
+ set result
+} {expected integer but got "a"}
+
+
+test asn-3.0 {enum} {
+ catch {asn::asnEnumeration} result
+ set result
+} [tcltest::wrongNumArgs {asn::asnEnumeration} {number} 0]
+
+test asn-3.1 {enum} {
+ catch {asn::asnEnumeration a b} result
+ set result
+} [tcltest::tooManyArgs {asn::asnEnumeration} {number}]
+
+test asn-3.2 {enum} {
+ catch {asn::asnEnumeration a} result
+ set result
+} {expected integer but got "a"}
+
+
+
+
+foreach {n i len hex} {
+ 0 0 01 00
+ 1 -1 01 FF
+ 2 1 01 01
+ 3 127 01 7F
+ 4 128 02 0080
+ 5 129 02 0081
+ 6 256 02 0100
+ 7 -127 01 81
+ 8 -128 01 80
+ 9 -129 02 FF7F
+ 10 32766 02 7FFE
+ 11 32767 02 7FFF
+ 12 32768 03 008000
+ 13 32769 03 008001
+ 14 -32767 02 8001
+ 15 -32768 02 8000
+ 16 -32769 03 FF7FFF
+ 17 65536 03 010000
+ 18 8388607 03 7FFFFF
+ 19 8388608 04 00800000
+ 20 8388609 04 00800001
+ 21 16777216 04 01000000
+ 22 -8388607 03 800001
+ 23 -8388608 03 800000
+ 24 -8388609 04 FF7FFFFF
+ 25 -65536 03 FF0000
+ 26 -2147483648 04 80000000
+ 27 2147483647 04 7FFFFFFF
+ 28 -549755813888 05 8000000000
+ 29 549755813887 05 7FFFFFFFFF
+ 30 -140737488355328 06 800000000000
+ 31 140737488355327 06 7FFFFFFFFFFF
+ 32 -36028797018963968 07 80000000000000
+ 33 36028797018963967 07 7FFFFFFFFFFFFF
+ 34 36028797018963968 08 0080000000000000
+ 35 -9223372036854775808 08 8000000000000000
+ 36 9223372036854775807 08 7FFFFFFFFFFFFFFF
+} {
+ test asn-2.$n {integer} {
+ binary scan [asn::asnInteger $i] H* result
+ list $i [string toupper $result]
+ } [list $i 02$len$hex] ; # {}
+
+ test asn-4.$n {enum} {
+ binary scan [asn::asnEnumeration $i] H* result
+ list $i [string toupper $result]
+ } [list $i 0A$len$hex] ; # {}
+}
+
+test asn-5.0 {boolean} {
+ catch {asn::asnBoolean} result
+ set result
+} [tcltest::wrongNumArgs {asn::asnBoolean} {bool} 0]
+
+test asn-5.1 {boolean} {
+ catch {asn::asnBoolean a b} result
+ set result
+} [tcltest::tooManyArgs {asn::asnBoolean} {bool}]
+
+test asn-5.2 {boolean} {
+ catch {asn::asnBoolean a} result
+ set result
+} {expected boolean value but got "a"}
+
+test asn-5.3 {boolean - true} {
+ binary scan [asn::asnBoolean 1] H* result
+ string toupper $result
+} {0101FF}
+
+test asn-5.4 {boolean - false} {
+ binary scan [asn::asnBoolean 0] H* result
+ string toupper $result
+} {010100}
+
+test asn-6.0 {parse boolean} {
+ catch {asn::asnGetBoolean} result
+ set result
+} [tcltest::wrongNumArgs {asn::asnGetBoolean} {data_var bool_var} 0]
+
+test asn-6.1 {parse boolean} {
+ catch {asn::asnGetBoolean a} result
+ set result
+} [tcltest::wrongNumArgs {asn::asnGetBoolean} {data_var bool_var} 1]
+
+test asn-6.2 {parse boolean} {
+ catch {asn::asnGetBoolean a b c} result
+ set result
+} [tcltest::tooManyArgs {asn::asnGetBoolean} {data_var bool_var}]
+
+test asn-6.3 {parse boolean} {
+ catch {asn::asnGetBoolean a b} result
+ set result
+} {can't read "data": no such variable}
+
+test asn-6.4 {parse boolean - wrong tag} {
+ set a \x02\x01\x00
+ catch {asn::asnGetBoolean a b} result
+ set result
+} {Expected Boolean (0x01), but got 02}
+
+test asn-6.5 {parse boolean - wrong length} {
+ set a \x01\x02\x00
+ catch {asn::asnGetBoolean a b} result
+ list $result $b
+} [list "" 0]
+
+test asn-6.6 {parse boolean - true} {
+ set a \x01\x01\xFF
+ asn::asnGetBoolean a b
+ set b
+} 1
+
+test asn-6.7 {parse boolean - true} {
+ set a \x01\x01\x01
+ asn::asnGetBoolean a b
+ set b
+} 1
+
+test asn-6.8 {parse boolean - false} {
+ set a \x01\x01\x00
+ asn::asnGetBoolean a b
+ set b
+} 0
+
+test asn-7.0 {null} {
+ catch {asn::asnNull foo} result
+ set result
+} [tcltest::tooManyArgs {asn::asnNull} {}]
+
+test asn-7.1 {null} {
+ binary scan [asn::asnNull] H* result
+ set result
+} {0500}
+
+test asn-8.0 {parse null} {
+ catch {asn::asnGetNull} result
+ set result
+} [tcltest::wrongNumArgs asn::asnGetNull {data_var} 0]
+
+test asn-8.1 {parse null} {
+ catch {asn::asnGetNull foo bar} result
+ set result
+} [tcltest::tooManyArgs {asn::asnGetNull} {data_var}]
+
+test asn-8.2 {parse null} {
+ set wrongtag \x01\x01
+ catch {asn::asnGetNull wrongtag} result
+ set result
+} {Expected NULL (0x05), but got 01}
+
+test asn-8.3 {parse null} {
+ set wronglength \x05\x01
+ catch {asn::asnGetNull wronglength} result
+ set result
+} {}
+
+test asn-8.4 {parse null} {
+ set null \x05\x00
+ asn::asnGetNull null
+} {}
+
+package require math::bignum
+foreach {n i len hex} {
+ 0 0 01 00
+ 1 -1 01 FF
+ 2 1 01 01
+ 3 127 01 7F
+ 4 128 02 0080
+ 5 129 02 0081
+ 6 256 02 0100
+ 7 -127 01 81
+ 8 -128 01 80
+ 9 -129 02 FF7F
+ 10 32766 02 7FFE
+ 11 32767 02 7FFF
+ 12 32768 03 008000
+ 13 32769 03 008001
+ 14 -32767 02 8001
+ 15 -32768 02 8000
+ 16 -32769 03 FF7FFF
+ 17 65536 03 010000
+ 18 8388607 03 7FFFFF
+ 19 8388608 04 00800000
+ 20 8388609 04 00800001
+ 21 16777216 04 01000000
+ 22 -8388607 03 800001
+ 23 -8388608 03 800000
+ 24 -8388609 04 FF7FFFFF
+ 25 -65536 03 FF0000
+} {
+ test asn-9.$n {big integer} {
+ binary scan [asn::asnBigInteger [math::bignum::fromstr $i]] H* result
+ list $i [string toupper $result]
+ } [list $i 02$len$hex] ; # {}
+
+}
+
+foreach {n len hex} {
+ 0 0 00
+ 1 1 01
+ 2 127 7F
+ 3 128 8180
+ 4 129 8181
+ 5 255 81FF
+ 6 256 820100
+ 7 32767 827FFF
+ 8 32768 828000
+ 9 32769 828001
+ 10 65535 82FFFF
+ 11 65536 83010000
+ 12 8388607 837FFFFF
+ 13 8388608 83800000
+ 14 8388609 83800001
+ 15 16777215 83FFFFFF
+ 16 16777216 8401000000
+ 17 4294967295 84FFFFFFFF
+ 18 4294967296 850100000000
+ 19 1099511627775 85FFFFFFFFFF
+ 20 1099511627776 86010000000000
+ 21 281474976710655 86FFFFFFFFFFFF
+ 22 281474976710656 8701000000000000
+ 23 72057594037927935 87FFFFFFFFFFFFFF
+ 24 72057594037927936 880100000000000000
+ 25 9223372036854775807 887FFFFFFFFFFFFFFF
+ } {
+ test asn-10.$n {asnLength encoding} {
+ binary scan [asn::asnLength $len] H* result
+ string toupper $result
+ } $hex
+}
+
+foreach {n len hex} {
+ 0 0 00
+ 1 1 01
+ 2 127 7F
+ 3 128 8180
+ 4 129 8181
+ 5 255 81FF
+ 6 256 820100
+ 7 32767 827FFF
+ 8 32768 828000
+ 9 32769 828001
+ 10 65535 82FFFF
+ 11 65536 83010000
+ 12 8388607 837FFFFF
+ 13 8388608 83800000
+ 14 8388609 83800001
+ 15 16777215 83FFFFFF
+ 16 16777216 8401000000
+ 17 4294967295 84FFFFFFFF
+ 18 4294967296 850100000000
+ 19 1099511627775 85FFFFFFFFFF
+ 20 1099511627776 86010000000000
+ 21 281474976710655 86FFFFFFFFFFFF
+ 22 281474976710656 8701000000000000
+ 23 72057594037927935 87FFFFFFFFFFFFFF
+ 24 72057594037927936 880100000000000000
+ 25 9223372036854775807 887FFFFFFFFFFFFFFF
+ } {
+ test asn-11.$n {asnGetLength decoding} {
+ set data [binary format H* $hex ]
+ asn::asnGetLength data length
+ set length
+ } $len
+}
+
+foreach {n i len hex} {
+ 0 0 01 00
+ 1 -1 01 FF
+ 2 1 01 01
+ 3 127 01 7F
+ 4 128 02 0080
+ 5 129 02 0081
+ 6 256 02 0100
+ 7 -127 01 81
+ 8 -128 01 80
+ 9 -129 02 FF7F
+ 10 32766 02 7FFE
+ 11 32767 02 7FFF
+ 12 32768 03 008000
+ 13 32769 03 008001
+ 14 -32767 02 8001
+ 15 -32768 02 8000
+ 16 -32769 03 FF7FFF
+ 17 65536 03 010000
+ 18 8388607 03 7FFFFF
+ 19 8388608 04 00800000
+ 20 8388609 04 00800001
+ 21 16777216 04 01000000
+ 22 -8388607 03 800001
+ 23 -8388608 03 800000
+ 24 -8388609 04 FF7FFFFF
+ 25 -65536 03 FF0000
+ 26 -2147483648 04 80000000
+ 27 2147483647 04 7FFFFFFF
+ 28 -549755813888 05 8000000000
+ 29 549755813887 05 7FFFFFFFFF
+ 30 -140737488355328 06 800000000000
+ 31 140737488355327 06 7FFFFFFFFFFF
+ 32 -36028797018963968 07 80000000000000
+ 33 36028797018963967 07 7FFFFFFFFFFFFF
+ 34 36028797018963968 08 0080000000000000
+ 35 -9223372036854775808 08 8000000000000000
+ 36 9223372036854775807 08 7FFFFFFFFFFFFFFF
+ 37 65537 03 010001
+ 38 -8323071 03 810001
+} {
+ test asn-12.$n {getInteger} {
+ set data [binary format H2H2H* 02 $len $hex]
+ asn::asnGetInteger data int
+ set int
+ } $i ; # {}
+}
+
+foreach {n i len hex} {
+ 0 0 01 00
+ 1 -1 01 FF
+ 2 1 01 01
+ 3 127 01 7F
+ 4 128 02 0080
+ 5 129 02 0081
+ 6 256 02 0100
+ 7 -127 01 81
+ 8 -128 01 80
+ 9 -129 02 FF7F
+ 10 32766 02 7FFE
+ 11 32767 02 7FFF
+ 12 32768 03 008000
+ 13 32769 03 008001
+ 14 -32767 02 8001
+ 15 -32768 02 8000
+ 16 -32769 03 FF7FFF
+ 17 65536 03 010000
+ 18 8388607 03 7FFFFF
+ 19 8388608 04 00800000
+ 20 8388609 04 00800001
+ 21 16777216 04 01000000
+ 22 -8388607 03 800001
+ 23 -8388608 03 800000
+ 24 -8388609 04 FF7FFFFF
+ 25 -65536 03 FF0000
+ 26 -2147483648 04 80000000
+ 27 2147483647 04 7FFFFFFF
+ 28 -549755813888 05 8000000000
+ 29 549755813887 05 7FFFFFFFFF
+ 30 -140737488355328 06 800000000000
+ 31 140737488355327 06 7FFFFFFFFFFF
+ 32 -36028797018963968 07 80000000000000
+ 33 36028797018963967 07 7FFFFFFFFFFFFF
+ 34 36028797018963968 08 0080000000000000
+ 35 -9223372036854775808 08 8000000000000000
+ 36 9223372036854775807 08 7FFFFFFFFFFFFFFF
+ 37 65537 03 010001
+ 38 -8323071 03 810001
+} {
+ test asn-12.[expr {$n+39}] {getBigInteger} {
+ set data [binary format H2H2H* 02 $len $hex]
+ asn::asnGetBigInteger data int
+ math::bignum::tostr $int
+ } $i ; # {}
+}
+
+test asn-13.0 {peekByte} {
+ set data \x0d\x0a
+ asn::asnPeekByte data byte
+ list $byte [string length $data]
+} {13 2}
+
+test asn-14.0 {getByte} {
+ set data \x0d\x0a
+ asn::asnGetByte data byte
+ list $byte [string length $data]
+} {13 1}
+
+test asn-15.0 {getBytes} {
+ set data \x0d\x0d\x0d\x0d\x0a
+ asn::asnGetBytes data 4 bytes
+ list [string length $data] [string length $bytes]
+} [list 1 4]
+
+test asn-15.1 {getBytes} {
+ set data \x0d\x0d\x0d\x0d\x0a
+ asn::asnGetBytes data 4 bytes
+ set expectedbytes \x0d\x0d\x0d\x0d
+ set expecteddata \x0a
+ list [expr {$data == $expecteddata}] [expr {$bytes == $expectedbytes}]
+} [list 1 1]
+
+# 16 ----------- string encoder/decoder invalid arguments
+array set stringtag {
+ NumericString 0x12
+ PrintableString 0x13
+ IA5String 0x16
+ BMPString 0x1e
+ UTF8String 0x0c
+}
+set i 0
+foreach strtype {NumericString PrintableString IA5String BMPString UTF8String} {
+ incr i
+ test asn-16.$i $strtype {
+ catch {asn::asn$strtype} result
+ set result
+ } [tcltest::wrongNumArgs asn::asn$strtype string 0]
+ incr i
+ test asn-16.$i $strtype {
+ catch "asn::asn$strtype a b" result
+ set result
+ } [tcltest::tooManyArgs "asn::asn$strtype" string]
+ incr i
+ test asn-16.$i get$strtype {
+ catch "asn::asnGet$strtype foo" result
+ set result
+ } [tcltest::wrongNumArgs "asn::asnGet$strtype" "data_var print_var" 0]
+ incr i
+ test asn-16.$i get$strtype {
+ catch "asn::asnGet$strtype foo bar baz" result
+ set result
+ } [tcltest::tooManyArgs "asn::asnGet$strtype" "data_var print_var"]
+ incr i
+ test asn-16.$i "get$strtype parse sequence" {
+ set data "\x30\x03abc"
+ catch "asn::asnGet$strtype data print" result
+ set result
+ } "Expected [regsub String $strtype " String"] ($stringtag($strtype)), but got 30"
+}
+incr i
+# 17 ------------------- invalid string values
+
+
+test asn-17.1 {numeric string with non-numbers} {
+ catch {asn::asnNumericString this-is-not-a-number} result
+ set result
+} "Illegal character in Numeric String."
+
+test asn-17.2 {numeric string with hexadecimals} {
+ catch {asn::asnNumericString 09AB} result
+ set result
+} "Illegal character in Numeric String."
+
+test asn-17.3 {numeric string with spaces - spaces are legal} {
+ catch {asn::asnNumericString " 093"}
+} 0 ;# TCL_OK
+
+test asn-17.4 {numeric string with minus sign} {
+ catch {asn::asnNumericString "-15"} result
+ set result
+} "Illegal character in Numeric String."
+
+test asn-17.5 {numeric string with tab (illegal)} {
+ catch {asn::asnNumericString "\t093"} result
+ set result
+} "Illegal character in Numeric String."
+
+#According to ITU-T X.680 37.4
+set printablechars {[-A-Za-z0-9 '()+,./=?:]}
+
+set i 6
+
+for {set j 1} {$j<128} {incr j;incr i} {
+ set data [format %c $j]
+ if {[regexp "^$printablechars+\$" $data]} {
+ test asn-17.$i "printable string valid char [format %02x $j]" {
+ catch {asn::asnPrintableString $data}
+ } 0 ; # {}
+ } else {
+ test asn-17.$i "printable string invalid char [format %02x $j]" {
+ catch {asn::asnPrintableString $data} result
+ set result
+ } "Illegal character in PrintableString." ; # {}
+ }
+}
+
+test asn-17.134 {IA5String with Latin-1 char} {
+ catch {asn::asnIA5String "\xD0"} result
+ set result
+} "Illegal character in IA5String"
+
+test asn-17.135 {IA5String with Cyrillic chars} {
+ catch {asn::asnIA5String "\u0420\u0443\u0441\u0441\u043a\u0438\u0439"} result
+ set result
+} "Illegal character in IA5String"
+
+# 18 - correct encoding of string values
+
+test asn-18.1 {encode numeric string} {
+ catch {asn::asnNumericString 123} result
+ set result
+} "\x12\003123"
+
+test asn-18.2 {encode numeric strin with space} {
+ catch {asn::asnNumericString "1 2 3"} result
+ set result
+} "\x12\0051 2 3"
+
+test asn-18.3 {encode printable string} {
+ catch {asn::asnPrintableString "printable string"} result
+ set result
+} "\x13\x10printable string"
+
+test asn-18.4 {encode IA5 string} {
+ catch {asn::asnIA5String "vitus@45.free.net"} result
+ set result
+} "\x16\x11vitus@45.free.net"
+
+test asn-18.5 {encode bmp string US-ASCII} {
+ catch {asn::asnBMPString "US-ASCII"} result
+ set result
+} "\x1e\x10\0U\0S\0-\0A\0S\0C\0I\0I"
+
+test asn-18.6 {encode UTF8 string US-ASCII} {
+ catch {asn::asnUTF8String "US-ASCII"} result
+ set result
+} "\x0c\x08US-ASCII"
+
+test asn-18.7 {encode bmp string latin-1} {
+ catch {asn::asnBMPString "gar\xC7on"} result
+ set result
+} "\x1e\x0c\0g\0a\0r\0\xc7\0o\0n"
+
+test asn-18.8 {encode utf-8 string latin-1} {
+ catch {asn::asnUTF8String "gar\xC7on"} result
+ set result
+} "\x0c\x07gar\xc3\x87on"
+
+test asn-18.9 {encode bmp string cyrillic} {
+ catch {asn::asnBMPString "\u0440\u0443\u0441\u0441\u043a\u0438\u0439"} result
+ set result
+} "\x1e\x0e\x04\x40\x04\x43\x04\x41\x04\x41\x04\x3a\x04\x38\x04\x39"
+
+test asn-18.10 {encode UTF8 string cyrillic} {
+ catch {asn::asnUTF8String "\u0440\u0443\u0441\u0441\u043a\u0438\u0439"} result
+ set result
+} "\x0c\x0e\xd1\x80\xd1\x83\xd1\x81\xd1\x81\xd0\xba\xd0\xb8\xd0\xb9"
+
+test asn-18.11 {decode numeric string} {
+ set data "\x12\003123"
+ asn::asnGetNumericString data print
+ set print
+} 123
+
+test asn-18.12 {decode printable string} {
+ set data "\x13\x10printable string"
+ asn::asnGetPrintableString data print
+ set print
+} "printable string"
+
+test asn-18.13 {decode IA5 string} {
+ set data "\x16\x11vitus@45.free.net"
+ asn::asnGetIA5String data print
+ set print
+} "vitus@45.free.net"
+
+test asn-18.14 {decode BMP string US-ASCII} {
+ set data "\x1e\x10\0U\0S\0-\0A\0S\0C\0I\0I"
+ asn::asnGetBMPString data print
+ set print
+} "US-ASCII"
+
+test asn-18.15 {decode UTF8 string US-ASCII} {
+ set data "\x0c\x08US-ASCII"
+ asn::asnGetUTF8String data print
+ set print
+} "US-ASCII"
+
+test asn-18.16 {decode BMP string latin-1} {
+ set data "\x1e\x0c\0g\0a\0r\0\xc7\0o\0n"
+ asn::asnGetBMPString data print
+ set print
+} "gar\xC7on"
+
+test asn-18.17 {decode UTF8 string latin-1} {
+ set data "\x0c\x07gar\xc3\x87on"
+ asn::asnGetUTF8String data print
+ set print
+} "gar\xC7on"
+
+test asn-18.18 {decode BMP string cyrillic} {
+ set data "\x1e\x0e\x04\x40\x04\x43\x04\x41\x04\x41\x04\x3a\x04\x38\x04\x39"
+ asn::asnGetBMPString data print
+ set print
+} "\u0440\u0443\u0441\u0441\u043a\u0438\u0439"
+
+test asn-18.19 {decode UTF8 string cyrillic} {
+ set data "\x0c\x0e\xd1\x80\xd1\x83\xd1\x81\xd1\x81\xd0\xba\xd0\xb8\xd0\xb9"
+ asn::asnGetUTF8String data print
+ set print
+} "\u0440\u0443\u0441\u0441\u043a\u0438\u0439"
+
+# 19 ------- multitype getString
+set i 0
+foreach {type encoded str} {
+
+NumericString "\x12\003123" 123
+PrintableString "\x13\x10printable string" "printable string"
+IA5String "\x16\x11vitus@45.free.net" "vitus@45.free.net"
+BMPString "\x1e\x10\0U\0S\0-\0A\0S\0C\0I\0I" US-ASCII
+UTF8String "\x0c\x08US-ASCII" US-ASCII
+BMPString "\x1e\x0c\0g\0a\0r\0\xc7\0o\0n" "gar\xc7on"
+UTF8String "\x0c\x07gar\xc3\x87on" "gar\xc7on"
+BMPString "\x1e\x0e\x04\x40\x04\x43\x04\x41\x04\x41\x04\x3a\x04\x38\x04\x39"
+"\u0440\u0443\u0441\u0441\u043a\u0438\u0439"
+UTF8String "\x0c\x0e\xd1\x80\xd1\x83\xd1\x81\xd1\x81\xd0\xba\xd0\xb8\xd0\xb9"
+"\u0440\u0443\u0441\u0441\u043a\u0438\u0439"} {
+incr i
+ test asn-19.$i "getString - decode $type" {
+ set data $encoded
+ asn::asnGetString data print
+ set print
+ } $str
+ incr i
+ test asn-19.$i "getString - decode $type and get its type" {
+ set data $encoded
+ asn::asnGetString data print gotType
+ list $data $print $gotType
+ } [list {} $str $type]
+}
+
+# 20 ----- multitype String encoding
+
+test asn-20.1 {Set default type to something wrong} {
+ catch {asn::defaultStringType foo} result
+ set result
+} "Invalid default string type. Should be one of BMP, UTF8"
+
+test asn-20.2 {Set default value to string type which cannot hold any char} {
+ catch {asn::defaultStringType IA5} result
+ set result
+} "Invalid default string type. Should be one of BMP, UTF8"
+
+
+test asn-20.3 {Set default type to UTF8} {
+ asn::defaultStringType UTF8
+} ""
+
+test asn-20.4 {Get default string type} {
+ asn::defaultStringType
+} UTF8
+
+test asn-20.5 {String - encode numeric value} {
+ asn::asnString 123
+} "\x12\003123"
+
+test asn-20.6 {String - encode printable value} {
+ asn::asnString "printable string"
+} "\x13\x10printable string"
+
+test asn-20.7 {String - encode ASCII value} {
+ asn::asnString vitus@45.free.net
+} "\x16\x11vitus@45.free.net"
+
+test asn-20.8 {String - encode Latin-1 value} {
+ asn::asnString "gar\xc7on"
+} "\x0c\x07gar\xc3\x87on"
+
+test asn-20.9 {String - encode Cyrillic value} {
+ asn::asnString "\u0440\u0443\u0441\u0441\u043a\u0438\u0439"
+} "\x0c\x0e\xd1\x80\xd1\x83\xd1\x81\xd1\x81\xd0\xba\xd0\xb8\xd0\xb9"
+
+test asn-20.10 {Set default string type to BMP} {
+ asn::defaultStringType BMP
+ asn::defaultStringType
+} BMP
+
+test asn-20.11 {String - encode numeric value} {
+ asn::asnString 123
+} "\x12\003123"
+
+test asn-20.12 {String - encode printable value} {
+ asn::asnString "printable string"
+} "\x13\x10printable string"
+
+test asn-20.13 {String - encode ASCII value} {
+ asn::asnString vitus@45.free.net
+} "\x16\x11vitus@45.free.net"
+
+
+test asn-20.14 {String - encode Latin-1 value} {
+ asn::asnString "gar\xc7on"
+} "\x1e\x0c\0g\0a\0r\0\xc7\0o\0n"
+
+test asn-20.15 {String - encode Cyrillic value} {
+ asn::asnString "\u0440\u0443\u0441\u0441\u043a\u0438\u0439"
+} "\x1e\x0e\x04\x40\x04\x43\x04\x41\x04\x41\x04\x3a\x04\x38\x04\x39"
+
+# 21 --------- Object identifier
+#
+
+test asn-21.1 {ObjectIdentifier start with 0} {
+ bytes2hex [asn::asnObjectIdentifier {0 2 262 1 10}]
+} "06 05 02 82 06 01 0A"
+
+
+test asn-21.2 {ObjectIdentifier start with 1} {
+ bytes2hex [asn::asnObjectIdentifier {1 2 840 10045 2 1}]
+} "06 07 2A 86 48 CE 3D 02 01"
+
+test asn-21.3 {ObjectIdentifer field > 65536} {
+ bytes2hex [asn::asnObjectIdentifier {1 2 840 113533 7 66 3}]
+} "06 09 2A 86 48 86 F6 7D 07 42 03"
+
+test asn-21.4 {ObjectIdentifer 2.23.42.9.37} {
+ bytes2hex [asn::asnObjectIdentifier {2 23 42 9 37}]
+} "06 04 67 2A 09 25"
+
+test asn-21.5 {GetObjectIdentifier 0.2.262.1.10} {
+ set data "\x06\x05\x02\x82\x06\x01\x0A"
+ asn::asnGetObjectIdentifier data print
+ set print
+} {0 2 262 1 10}
+
+test asn-21.6 {GetObjectIdentifier 1 2 840 10045 2 1} {
+ set data "\x06\x07\x2A\x86\x48\xCE\x3D\x02\x01"
+ asn::asnGetObjectIdentifier data print
+ set print
+} {1 2 840 10045 2 1}
+
+test asn-21.7 {GetObjectIdentifier 1 2 840 113533 7 66 3} {
+ set data "\x06\x09\x2A\x86\x48\x86\xF6\x7D\x07\x42\x03"
+ asn::asnGetObjectIdentifier data print
+ set print
+} {1 2 840 113533 7 66 3}
+
+# 22 --- Octet String
+
+# smoke tests to check that we can at least call the commands
+test asn-23.0 {asnContext smoke test} {
+ set data "\x00"
+ bytes2hex [asn::asnContext 1 $data]
+} {81 01 00}
+
+test asn-24.0 {asnSequence smoke test} {
+ set data [asn::asnNull]
+ bytes2hex [asn::asnSequence 1 $data]
+} {30 03 31 05 00}
+
+test asn-25.0 {asnSet smoke test} {
+ set data [asn::asnNull]
+ bytes2hex [asn::asnSet 1 $data]
+} {31 03 31 05 00}
+
+test asn-26.0 {asnApplicationConstr smoke test} {
+ set data [asn::asnNull]
+ bytes2hex [asn::asnApplicationConstr 1 $data]
+} {61 02 05 00}
+
+test asn-27.0 {asnApplication smoke test} {
+ set data [asn::asnNull]
+ bytes2hex [asn::asnApplication 1 $data]
+} {41 02 05 00}
+
+test asn-28.0 {asnContextConstr smoke test} {
+ set data [asn::asnNull]
+ bytes2hex [asn::asnContextConstr 1 $data]
+} {A1 02 05 00}
+
+test asn-29.0 {asnChoice smoke test} {
+ set data [asn::asnNull]
+ bytes2hex [asn::asnChoice 1 $data]
+} {81 02 05 00}
+
+test asn-30.0 {asnChoiceConstr smoke test} {
+ set data [asn::asnNull]
+ bytes2hex [asn::asnChoiceConstr 1 $data]
+} {A1 02 05 00}
+
+test asn-31.0 {asnPeekTag smoke test} {
+ set data [asn::asnNull]
+ asn::asnPeekTag data tag tagtype constr
+ list $tag $tagtype $constr
+} {5 UNIVERSAL 0}
+
+foreach {n hex tag type constr} {
+ 1 05 5 UNIVERSAL 0
+ 2 1E 30 UNIVERSAL 0
+ 3 1F1F 31 UNIVERSAL 0
+ 4 5F1F 31 APPLICATION 0
+ 5 1F818000 16384 UNIVERSAL 0
+ 6 45 5 APPLICATION 0
+ 7 65 5 APPLICATION 1
+ 8 85 5 CONTEXT 0
+ 9 a5 5 CONTEXT 1
+ 10 c5 5 PRIVATE 0
+ 11 e5 5 PRIVATE 1
+ 12 25 5 UNIVERSAL 1
+} {
+ test asn-31.$n "asnPeekTag $tag $type $constr" \
+ "set data \[binary format H* $hex\]
+ asn::asnPeekTag data tag tagtype constr
+ list \$tag \$tagtype \$constr" \
+ [list $tag $type $constr]
+}
+
+test asn-32.0 {asnTag smoke test} {
+ bytes2hex [asn::asnTag 5 UNIVERSAL P]
+} {05}
+
+test asn-32.1 {asnTag short tag} {
+ bytes2hex [asn::asnTag 30 UNIVERSAL P]
+} {1E}
+
+test asn-32.2 {asnTag long tag} {
+ bytes2hex [asn::asnTag 31 UNIVERSAL P]
+} {1F 1F}
+
+test asn-32.3 {asnTag long tag} {
+ bytes2hex [asn::asnTag 31 APPLICATION P]
+} {5F 1F}
+
+test asn-32.4 {asnTag long tag} {
+ bytes2hex [asn::asnTag 127 UNIVERSAL P]
+} {1F 7F}
+
+test asn-32.5 {asnTag long tag} {
+ bytes2hex [asn::asnTag 128 UNIVERSAL P]
+} {1F 81 00}
+
+test asn-32.6 {asnTag long tag} {
+ bytes2hex [asn::asnTag 16384 UNIVERSAL P]
+} {1F 81 80 00}
+
+test asn-32.7 {asnTag long tag} {
+ bytes2hex [asn::asnTag 16385 UNIVERSAL P]
+} {1F 81 80 01}
+
+test asn-32.8 {asnTag tag APPLICATION, PRIMITIVE} {
+ bytes2hex [asn::asnTag 5 APPLICATION P]
+} {45}
+
+test asn-32.9 {asnTag tag APPLICATION, CONSTRUCTED} {
+ bytes2hex [asn::asnTag 5 APPLICATION C]
+} {65}
+
+test asn-32.10 {asnTag tag CONTEXT, PRIMITIVE} {
+ bytes2hex [asn::asnTag 5 CONTEXT P]
+} {85}
+
+test asn-32.11 {asnTag tag CONTEXT, CONSTRUCTED} {
+ bytes2hex [asn::asnTag 5 CONTEXT C]
+} {A5}
+
+test asn-32.12 {asnTag tag PRIVATE,PRIMITIVE} {
+ bytes2hex [asn::asnTag 5 PRIVATE P]
+} {C5}
+
+test asn-32.13 {asnTag tag PRIVATE,CONSTRUCTED} {
+ bytes2hex [asn::asnTag 5 PRIVATE C]
+} {E5}
+
+test asn-32.14 {asnTag tag UNIVERSAL, CONSTRUCTED} {
+ bytes2hex [asn::asnTag 5 UNIVERSAL C]
+} {25}
+
+foreach {n hex bin} {
+ 1 03020780 1
+ 2 030206c0 11
+ 3 03020680 10
+ 4 030200ff 11111111
+ 5 03020000 00000000
+ 6 0303078000 100000000
+} {
+ test asn-33.$n "asnBitstring $bin" \
+ "binary scan \[asn::asnBitString $bin\] H* val
+ set val" \
+ $hex
+}
+
+foreach {n hex bin} {
+ 1 03020780 1
+ 2 030206c0 11
+ 3 03020680 10
+ 4 030200ff 11111111
+ 5 03020000 00000000
+ 6 0303078000 100000000
+} {
+ test asn-34.$n "asnGetBitstring $bin" \
+ "set data \[binary format H* $hex\]
+ asn::asnGetBitString data bits
+ set bits " \
+ $bin
+}
+
+
+testsuiteCleanup
+
diff --git a/tcllib/modules/asn/laymans_guide.txt b/tcllib/modules/asn/laymans_guide.txt
new file mode 100644
index 0000000..d4fbe64
--- /dev/null
+++ b/tcllib/modules/asn/laymans_guide.txt
@@ -0,0 +1,1855 @@
+A Layman's Guide to a Subset of ASN.1, BER, and DER
+
+An RSA Laboratories Technical Note
+Burton S. Kaliski Jr.
+Revised November 1, 1993
+
+
+Supersedes June 3, 1991 version, which was also published as
+NIST/OSI Implementors' Workshop document SEC-SIG-91-17.
+PKCS documents are available by electronic mail to
+<pkcs@rsa.com>.
+
+Copyright (C) 1991-1993 RSA Laboratories, a division of RSA
+Data Security, Inc. License to copy this document is granted
+provided that it is identified as "RSA Data Security, Inc.
+Public-Key Cryptography Standards (PKCS)" in all material
+mentioning or referencing this document.
+003-903015-110-000-000
+
+
+Abstract. This note gives a layman's introduction to a
+subset of OSI's Abstract Syntax Notation One (ASN.1), Basic
+Encoding Rules (BER), and Distinguished Encoding Rules
+(DER). The particular purpose of this note is to provide
+background material sufficient for understanding and
+implementing the PKCS family of standards.
+
+
+1. Introduction
+
+It is a generally accepted design principle that abstraction
+is a key to managing software development. With abstraction,
+a designer can specify a part of a system without concern
+for how the part is actually implemented or represented.
+Such a practice leaves the implementation open; it
+simplifies the specification; and it makes it possible to
+state "axioms" about the part that can be proved when the
+part is implemented, and assumed when the part is employed
+in another, higher-level part. Abstraction is the hallmark
+of most modern software specifications.
+
+One of the most complex systems today, and one that also
+involves a great deal of abstraction, is Open Systems
+Interconnection (OSI, described in X.200). OSI is an
+internationally standardized architecture that governs the
+interconnection of computers from the physical layer up to
+the user application layer. Objects at higher layers are
+defined abstractly and intended to be implemented with
+objects at lower layers. For instance, a service at one
+layer may require transfer of certain abstract objects
+between computers; a lower layer may provide transfer
+services for strings of ones and zeroes, using encoding
+rules to transform the abstract objects into such strings.
+OSI is called an open system because it supports many
+different implementations of the services at each layer.
+
+OSI's method of specifying abstract objects is called ASN.1
+(Abstract Syntax Notation One, defined in X.208), and one
+set of rules for representing such objects as strings of
+ones and zeros is called the BER (Basic Encoding Rules,
+defined in X.209). ASN.1 is a flexible notation that allows
+one to define a variety data types, from simple types such
+as integers and bit strings to structured types such as sets
+and sequences, as well as complex types defined in terms of
+others. BER describes how to represent or encode values of
+each ASN.1 type as a string of eight-bit octets. There is
+generally more than one way to BER-encode a given value.
+Another set of rules, called the Distinguished Encoding
+Rules (DER), which is a subset of BER, gives a unique
+encoding to each ASN.1 value.
+
+The purpose of this note is to describe a subset of ASN.1,
+BER and DER sufficient to understand and implement one OSI-
+based application, RSA Data Security, Inc.'s Public-Key
+Cryptography Standards. The features described include an
+overview of ASN.1, BER, and DER and an abridged list of
+ASN.1 types and their BER and DER encodings. Sections 2-4
+give an overview of ASN.1, BER, and DER, in that order.
+Section 5 lists some ASN.1 types, giving their notation,
+specific encoding rules, examples, and comments about their
+application to PKCS. Section 6 concludes with an example,
+X.500 distinguished names.
+
+Advanced features of ASN.1, such as macros, are not
+described in this note, as they are not needed to implement
+PKCS. For information on the other features, and for more
+detail generally, the reader is referred to CCITT
+Recommendations X.208 and X.209, which define ASN.1 and BER.
+
+Terminology and notation. In this note, an octet is an eight-
+bit unsigned integer. Bit 8 of the octet is the most
+significant and bit 1 is the least significant.
+
+The following meta-syntax is used for in describing ASN.1
+notation:
+
+ BIT monospace denotes literal characters in the type
+ and value notation; in examples, it generally
+ denotes an octet value in hexadecimal
+
+ n1 bold italics denotes a variable
+
+ [] bold square brackets indicate that a term is
+ optional
+
+ {} bold braces group related terms
+
+ | bold vertical bar delimits alternatives with a
+ group
+
+ ... bold ellipsis indicates repeated occurrences
+
+ = bold equals sign expresses terms as subterms
+
+
+2. Abstract Syntax Notation One
+
+Abstract Syntax Notation One, abbreviated ASN.1, is a
+notation for describing abstract types and values.
+
+In ASN.1, a type is a set of values. For some types, there
+are a finite number of values, and for other types there are
+an infinite number. A value of a given ASN.1 type is an
+element of the type's set. ASN.1 has four kinds of type:
+simple types, which are "atomic" and have no components;
+structured types, which have components; tagged types, which
+are derived from other types; and other types, which include
+the CHOICE type and the ANY type. Types and values can be
+given names with the ASN.1 assignment operator (::=) , and
+those names can be used in defining other types and values.
+
+Every ASN.1 type other than CHOICE and ANY has a tag, which
+consists of a class and a nonnegative tag number. ASN.1
+types are abstractly the same if and only if their tag
+numbers are the same. In other words, the name of an ASN.1
+type does not affect its abstract meaning, only the tag
+does. There are four classes of tag:
+
+ Universal, for types whose meaning is the same in all
+ applications; these types are only defined in
+ X.208.
+
+ Application, for types whose meaning is specific to an
+ application, such as X.500 directory services;
+ types in two different applications may have the
+ same application-specific tag and different
+ meanings.
+
+ Private, for types whose meaning is specific to a given
+ enterprise.
+
+ Context-specific, for types whose meaning is specific
+ to a given structured type; context-specific tags
+ are used to distinguish between component types
+ with the same underlying tag within the context of
+ a given structured type, and component types in
+ two different structured types may have the same
+ tag and different meanings.
+
+The types with universal tags are defined in X.208, which
+also gives the types' universal tag numbers. Types with
+other tags are defined in many places, and are always
+obtained by implicit or explicit tagging (see Section 2.3).
+Table 1 lists some ASN.1 types and their universal-class
+tags.
+
+ Type Tag number Tag number
+ (decimal) (hexadecimal)
+ INTEGER 2 02
+ BIT STRING 3 03
+ OCTET STRING 4 04
+ NULL 5 05
+ OBJECT IDENTIFIER 6 06
+ SEQUENCE and SEQUENCE OF 16 10
+ SET and SET OF 17 11
+ PrintableString 19 13
+ T61String 20 14
+ IA5String 22 16
+ UTCTime 23 17
+
+ Table 1. Some types and their universal-class tags.
+
+ASN.1 types and values are expressed in a flexible,
+programming-language-like notation, with the following
+special rules:
+
+ o Layout is not significant; multiple spaces and
+ line breaks can be considered as a single space.
+
+ o Comments are delimited by pairs of hyphens (--),
+ or a pair of hyphens and a line break.
+
+ o Identifiers (names of values and fields) and type
+ references (names of types) consist of upper- and
+ lower-case letters, digits, hyphens, and spaces;
+ identifiers begin with lower-case letters; type
+ references begin with upper-case letters.
+
+The following four subsections give an overview of simple
+types, structured types, implicitly and explicitly tagged
+types, and other types. Section 5 describes specific types
+in more detail.
+
+
+2.1 Simple types
+
+Simple types are those not consisting of components; they
+are the "atomic" types. ASN.1 defines several; the types
+that are relevant to the PKCS standards are the following:
+
+ BIT STRING, an arbitrary string of bits (ones and
+ zeroes).
+
+ IA5String, an arbitrary string of IA5 (ASCII)
+ characters.
+
+ INTEGER, an arbitrary integer.
+
+ NULL, a null value.
+
+ OBJECT IDENTIFIER, an object identifier, which is a
+ sequence of integer components that identify an
+ object such as an algorithm or attribute type.
+
+ OCTET STRING, an arbitrary string of octets (eight-bit
+ values).
+
+ PrintableString, an arbitrary string of printable
+ characters.
+
+ T61String, an arbitrary string of T.61 (eight-bit)
+ characters.
+
+ UTCTime, a "coordinated universal time" or Greenwich
+ Mean Time (GMT) value.
+
+Simple types fall into two categories: string types and non-
+string types. BIT STRING, IA5String, OCTET STRING,
+PrintableString, T61String, and UTCTime are string types.
+
+String types can be viewed, for the purposes of encoding, as
+consisting of components, where the components are
+substrings. This view allows one to encode a value whose
+length is not known in advance (e.g., an octet string value
+input from a file stream) with a constructed, indefinite-
+length encoding (see Section 3).
+
+The string types can be given size constraints limiting the
+length of values.
+
+
+2.2 Structured types
+
+Structured types are those consisting of components. ASN.1
+defines four, all of which are relevant to the PKCS
+standards:
+
+ SEQUENCE, an ordered collection of one or more types.
+
+ SEQUENCE OF, an ordered collection of zero or more
+ occurrences of a given type.
+
+ SET, an unordered collection of one or more types.
+
+ SET OF, an unordered collection of zero or more
+ occurrences of a given type.
+
+The structured types can have optional components, possibly
+with default values.
+
+
+2.3 Implicitly and explicitly tagged types
+
+Tagging is useful to distinguish types within an
+application; it is also commonly used to distinguish
+component types within a structured type. For instance,
+optional components of a SET or SEQUENCE type are typically
+given distinct context-specific tags to avoid ambiguity.
+
+There are two ways to tag a type: implicitly and explicitly.
+
+Implicitly tagged types are derived from other types by
+changing the tag of the underlying type. Implicit tagging is
+denoted by the ASN.1 keywords [class number] IMPLICIT (see
+Section 5.1).
+
+Explicitly tagged types are derived from other types by
+adding an outer tag to the underlying type. In effect,
+explicitly tagged types are structured types consisting of
+one component, the underlying type. Explicit tagging is
+denoted by the ASN.1 keywords [class number] EXPLICIT (see
+Section 5.2).
+
+The keyword [class number] alone is the same as explicit
+tagging, except when the "module" in which the ASN.1 type is
+defined has implicit tagging by default. ("Modules" are
+among the advanced features not described in this note.)
+
+For purposes of encoding, an implicitly tagged type is
+considered the same as the underlying type, except that the
+tag is different. An explicitly tagged type is considered
+like a structured type with one component, the underlying
+type. Implicit tags result in shorter encodings, but
+explicit tags may be necessary to avoid ambiguity if the tag
+of the underlying type is indeterminate (e.g., the
+underlying type is CHOICE or ANY).
+
+
+2.4 Other types
+
+Other types in ASN.1 include the CHOICE and ANY types. The
+CHOICE type denotes a union of one or more alternatives; the
+ANY type denotes an arbitrary value of an arbitrary type,
+where the arbitrary type is possibly defined in the
+registration of an object identifier or integer value.
+
+
+3. Basic Encoding Rules
+
+The Basic Encoding Rules for ASN.1, abbreviated BER, give
+one or more ways to represent any ASN.1 value as an octet
+string. (There are certainly other ways to represent ASN.1
+values, but BER is the standard for interchanging such
+values in OSI.)
+
+There are three methods to encode an ASN.1 value under BER,
+the choice of which depends on the type of value and whether
+the length of the value is known. The three methods are
+primitive, definite-length encoding; constructed, definite-
+length encoding; and constructed, indefinite-length
+encoding. Simple non-string types employ the primitive,
+definite-length method; structured types employ either of
+the constructed methods; and simple string types employ any
+of the methods, depending on whether the length of the value
+is known. Types derived by implicit tagging employ the
+method of the underlying type and types derived by explicit
+tagging employ the constructed methods.
+
+In each method, the BER encoding has three or four parts:
+
+ Identifier octets. These identify the class and tag
+ number of the ASN.1 value, and indicate whether
+ the method is primitive or constructed.
+
+ Length octets. For the definite-length methods, these
+ give the number of contents octets. For the
+ constructed, indefinite-length method, these
+ indicate that the length is indefinite.
+
+ Contents octets. For the primitive, definite-length
+ method, these give a concrete representation of
+ the value. For the constructed methods, these
+ give the concatenation of the BER encodings of the
+ components of the value.
+
+ End-of-contents octets. For the constructed, indefinite-
+ length method, these denote the end of the
+ contents. For the other methods, these are absent.
+
+The three methods of encoding are described in the following
+sections.
+
+
+3.1 Primitive, definite-length method
+
+This method applies to simple types and types derived from
+simple types by implicit tagging. It requires that the
+length of the value be known in advance. The parts of the
+BER encoding are as follows:
+
+Identifier octets. There are two forms: low tag number (for
+tag numbers between 0 and 30) and high tag number (for tag
+numbers 31 and greater).
+
+ Low-tag-number form. One octet. Bits 8 and 7 specify
+ the class (see Table 2), bit 6 has value "0,"
+ indicating that the encoding is primitive, and
+ bits 5-1 give the tag number.
+
+ Class Bit Bit
+ 8 7
+ universal 0 0
+ application 0 1
+ context-specific 1 0
+ private 1 1
+
+ Table 2. Class encoding in identifier octets.
+
+ High-tag-number form. Two or more octets. First octet
+ is as in low-tag-number form, except that bits 5-1
+ all have value "1." Second and following octets
+ give the tag number, base 128, most significant
+ digit first, with as few digits as possible, and
+ with the bit 8 of each octet except the last set
+ to "1."
+
+Length octets. There are two forms: short (for lengths
+between 0 and 127), and long definite (for lengths between 0
+and 21008-1).
+
+ Short form. One octet. Bit 8 has value "0" and bits 7-1
+ give the length.
+
+ Long form. Two to 127 octets. Bit 8 of first octet has
+ value "1" and bits 7-1 give the number of
+ additional length octets. Second and following
+ octets give the length, base 256, most significant
+ digit first.
+
+Contents octets. These give a concrete representation of the
+value (or the value of the underlying type, if the type is
+derived by implicit tagging). Details for particular types
+are given in Section 5.
+
+
+3.2 Constructed, definite-length method
+
+This method applies to simple string types, structured
+types, types derived simple string types and structured
+types by implicit tagging, and types derived from anything
+by explicit tagging. It requires that the length of the
+value be known in advance. The parts of the BER encoding are
+as follows:
+
+Identifier octets. As described in Section 3.1, except that
+bit 6 has value "1," indicating that the encoding is
+constructed.
+
+Length octets. As described in Section 3.1.
+
+Contents octets. The concatenation of the BER encodings of
+the components of the value:
+
+ o For simple string types and types derived from
+ them by implicit tagging, the concatenation of the
+ BER encodings of consecutive substrings of the
+ value (underlying value for implicit tagging).
+
+ o For structured types and types derived from them
+ by implicit tagging, the concatenation of the BER
+ encodings of components of the value (underlying
+ value for implicit tagging).
+
+ o For types derived from anything by explicit
+ tagging, the BER encoding of the underlying value.
+
+Details for particular types are given in Section 5.
+
+
+3.3 Constructed, indefinite-length method
+
+This method applies to simple string types, structured
+types, types derived simple string types and structured
+types by implicit tagging, and types derived from anything
+by explicit tagging. It does not require that the length of
+the value be known in advance. The parts of the BER encoding
+are as follows:
+
+Identifier octets. As described in Section 3.2.
+
+Length octets. One octet, 80.
+
+Contents octets. As described in Section 3.2.
+
+End-of-contents octets. Two octets, 00 00.
+
+Since the end-of-contents octets appear where an ordinary
+BER encoding might be expected (e.g., in the contents octets
+of a sequence value), the 00 and 00 appear as identifier and
+length octets, respectively. Thus the end-of-contents octets
+is really the primitive, definite-length encoding of a value
+with universal class, tag number 0, and length 0.
+
+
+4. Distinguished Encoding Rules
+
+The Distinguished Encoding Rules for ASN.1, abbreviated DER,
+are a subset of BER, and give exactly one way to represent
+any ASN.1 value as an octet string. DER is intended for
+applications in which a unique octet string encoding is
+needed, as is the case when a digital signature is computed
+on an ASN.1 value. DER is defined in Section 8.7 of X.509.
+
+DER adds the following restrictions to the rules given in
+Section 3:
+
+ 1. When the length is between 0 and 127, the short
+ form of length must be used
+
+ 2. When the length is 128 or greater, the long form
+ of length must be used, and the length must be
+ encoded in the minimum number of octets.
+
+ 3. For simple string types and implicitly tagged
+ types derived from simple string types, the
+ primitive, definite-length method must be
+ employed.
+
+ 4. For structured types, implicitly tagged types
+ derived from structured types, and explicitly
+ tagged types derived from anything, the
+ constructed, definite-length method must be
+ employed.
+
+Other restrictions are defined for particular types (such as
+BIT STRING, SEQUENCE, SET, and SET OF), and can be found in
+Section 5.
+
+
+5. Notation and encodings for some types
+
+This section gives the notation for some ASN.1 types and
+describes how to encode values of those types under both BER
+and DER.
+
+The types described are those presented in Section 2. They
+are listed alphabetically here.
+
+Each description includes ASN.1 notation, BER encoding, and
+DER encoding. The focus of the encodings is primarily on the
+contents octets; the tag and length octets follow Sections 3
+and 4. The descriptions also explain where each type is used
+in PKCS and related standards. ASN.1 notation is generally
+only for types, although for the type OBJECT IDENTIFIER,
+value notation is given as well.
+
+
+5.1 Implicitly tagged types
+
+An implicitly tagged type is a type derived from another
+type by changing the tag of the underlying type.
+
+Implicit tagging is used for optional SEQUENCE components
+with underlying type other than ANY throughout PKCS, and for
+the extendedCertificate alternative of PKCS #7's
+ExtendedCertificateOrCertificate type.
+
+ASN.1 notation:
+
+[[class] number] IMPLICIT Type
+
+class = UNIVERSAL | APPLICATION | PRIVATE
+
+where Type is a type, class is an optional class name, and
+number is the tag number within the class, a nonnegative
+integer.
+
+In ASN.1 "modules" whose default tagging method is implicit
+tagging, the notation [[class] number] Type is also
+acceptable, and the keyword IMPLICIT is implied. (See
+Section 2.3.) For definitions stated outside a module, the
+explicit inclusion of the keyword IMPLICIT is preferable to
+prevent ambiguity.
+
+If the class name is absent, then the tag is context-
+specific. Context-specific tags can only appear in a
+component of a structured or CHOICE type.
+
+Example: PKCS #8's PrivateKeyInfo type has an optional
+attributes component with an implicit, context-specific tag:
+
+PrivateKeyInfo ::= SEQUENCE {
+ version Version,
+ privateKeyAlgorithm PrivateKeyAlgorithmIdentifier,
+ privateKey PrivateKey,
+ attributes [0] IMPLICIT Attributes OPTIONAL }
+
+Here the underlying type is Attributes, the class is absent
+(i.e., context-specific), and the tag number within the
+class is 0.
+
+BER encoding. Primitive or constructed, depending on the
+underlying type. Contents octets are as for the BER encoding
+of the underlying value.
+
+Example: The BER encoding of the attributes component of a
+PrivateKeyInfo value is as follows:
+
+ o the identifier octets are 80 if the underlying
+ Attributes value has a primitive BER encoding and
+ a0 if the underlying Attributes value has a
+ constructed BER encoding
+
+ o the length and contents octets are the same as the
+ length and contents octets of the BER encoding of
+ the underlying Attributes value
+
+DER encoding. Primitive or constructed, depending on the
+underlying type. Contents octets are as for the DER encoding
+of the underlying value.
+
+
+5.2 Explicitly tagged types
+
+Explicit tagging denotes a type derived from another type by
+adding an outer tag to the underlying type.
+
+Explicit tagging is used for optional SEQUENCE components
+with underlying type ANY throughout PKCS, and for the
+version component of X.509's Certificate type.
+
+ASN.1 notation:
+
+[[class] number] EXPLICIT Type
+
+class = UNIVERSAL | APPLICATION | PRIVATE
+
+where Type is a type, class is an optional class name, and
+number is the tag number within the class, a nonnegative
+integer.
+
+If the class name is absent, then the tag is context-
+specific. Context-specific tags can only appear in a
+component of a SEQUENCE, SET or CHOICE type.
+
+In ASN.1 "modules" whose default tagging method is explicit
+tagging, the notation [[class] number] Type is also
+acceptable, and the keyword EXPLICIT is implied. (See
+Section 2.3.) For definitions stated outside a module, the
+explicit inclusion of the keyword EXPLICIT is preferable to
+prevent ambiguity.
+
+Example 1: PKCS #7's ContentInfo type has an optional
+content component with an explicit, context-specific tag:
+
+ContentInfo ::= SEQUENCE {
+ contentType ContentType,
+ content
+ [0] EXPLICIT ANY DEFINED BY contentType OPTIONAL }
+
+Here the underlying type is ANY DEFINED BY contentType, the
+class is absent (i.e., context-specific), and the tag number
+within the class is 0.
+
+Example 2: X.509's Certificate type has a version component
+with an explicit, context-specific tag, where the EXPLICIT
+keyword is omitted:
+
+Certificate ::= ...
+ version [0] Version DEFAULT v1988,
+...
+
+The tag is explicit because the default tagging method for
+the ASN.1 "module" in X.509 that defines the Certificate
+type is explicit tagging.
+
+BER encoding. Constructed. Contents octets are the BER
+encoding of the underlying value.
+
+Example: the BER encoding of the content component of a
+ContentInfo value is as follows:
+
+ o identifier octets are a0
+
+ o length octets represent the length of the BER
+ encoding of the underlying ANY DEFINED BY
+ contentType value
+
+ o contents octets are the BER encoding of the
+ underlying ANY DEFINED BY contentType value
+
+DER encoding. Constructed. Contents octets are the DER
+encoding of the underlying value.
+
+
+5.3 ANY
+
+The ANY type denotes an arbitrary value of an arbitrary
+type, where the arbitrary type is possibly defined in the
+registration of an object identifier or associated with an
+integer index.
+
+The ANY type is used for content of a particular content
+type in PKCS #7's ContentInfo type, for parameters of a
+particular algorithm in X.509's AlgorithmIdentifier type,
+and for attribute values in X.501's Attribute and
+AttributeValueAssertion types. The Attribute type is used by
+PKCS #6, #7, #8, #9 and #10, and the AttributeValueAssertion
+type is used in X.501 distinguished names.
+
+ASN.1 notation:
+
+ANY [DEFINED BY identifier]
+
+where identifier is an optional identifier.
+
+In the ANY form, the actual type is indeterminate.
+
+The ANY DEFINED BY identifier form can only appear in a
+component of a SEQUENCE or SET type for which identifier
+identifies some other component, and that other component
+has type INTEGER or OBJECT IDENTIFIER (or a type derived
+from either of those by tagging). In that form, the actual
+type is determined by the value of the other component,
+either in the registration of the object identifier value,
+or in a table of integer values.
+
+Example: X.509's AlgorithmIdentifier type has a component of
+type ANY:
+
+AlgorithmIdentifier ::= SEQUENCE {
+ algorithm OBJECT IDENTIFIER,
+ parameters ANY DEFINED BY algorithm OPTIONAL }
+
+Here the actual type of the parameter component depends on
+the value of the algorithm component. The actual type would
+be defined in the registration of object identifier values
+for the algorithm component.
+
+BER encoding. Same as the BER encoding of the actual value.
+
+Example: The BER encoding of the value of the parameter
+component is the BER encoding of the value of the actual
+type as defined in the registration of object identifier
+values for the algorithm component.
+
+DER encoding. Same as the DER encoding of the actual value.
+
+
+5.4 BIT STRING
+
+The BIT STRING type denotes an arbitrary string of bits
+(ones and zeroes). A BIT STRING value can have any length,
+including zero. This type is a string type.
+
+The BIT STRING type is used for digital signatures on
+extended certificates in PKCS #6's ExtendedCertificate type,
+for digital signatures on certificates in X.509's
+Certificate type, and for public keys in certificates in
+X.509's SubjectPublicKeyInfo type.
+
+ASN.1 notation:
+
+BIT STRING
+
+Example: X.509's SubjectPublicKeyInfo type has a component
+of type BIT STRING:
+
+SubjectPublicKeyInfo ::= SEQUENCE {
+ algorithm AlgorithmIdentifier,
+ publicKey BIT STRING }
+
+BER encoding. Primitive or constructed. In a primitive
+encoding, the first contents octet gives the number of bits
+by which the length of the bit string is less than the next
+multiple of eight (this is called the "number of unused
+bits"). The second and following contents octets give the
+value of the bit string, converted to an octet string. The
+conversion process is as follows:
+
+ 1. The bit string is padded after the last bit with
+ zero to seven bits of any value to make the length
+ of the bit string a multiple of eight. If the
+ length of the bit string is a multiple of eight
+ already, no padding is done.
+
+ 2. The padded bit string is divided into octets. The
+ first eight bits of the padded bit string become
+ the first octet, bit 8 to bit 1, and so on through
+ the last eight bits of the padded bit string.
+
+In a constructed encoding, the contents octets give the
+concatenation of the BER encodings of consecutive substrings
+of the bit string, where each substring except the last has
+a length that is a multiple of eight bits.
+
+Example: The BER encoding of the BIT STRING value
+"011011100101110111" can be any of the following, among
+others, depending on the choice of padding bits, the form of
+length octets, and whether the encoding is primitive or
+constructed:
+
+03 04 06 6e 5d c0 DER encoding
+
+03 04 06 6e 5d e0 padded with "100000"
+
+03 81 04 06 6e 5d c0 long form of length octets
+
+23 09 constructed encoding: "0110111001011101" + "11"
+ 03 03 00 6e 5d
+ 03 02 06 c0
+
+DER encoding. Primitive. The contents octects are as for a
+primitive BER encoding, except that the bit string is padded
+with zero-valued bits.
+
+Example: The DER encoding of the BIT STRING value
+"011011100101110111" is
+
+03 04 06 6e 5d c0
+
+
+5.5 CHOICE
+
+The CHOICE type denotes a union of one or more alternatives.
+
+The CHOICE type is used to represent the union of an
+extended certificate and an X.509 certificate in PKCS #7's
+ExtendedCertificateOrCertificate type.
+
+ASN.1 notation:
+
+CHOICE {
+ [identifier1] Type1,
+ ...,
+ [identifiern] Typen }
+
+where identifier1 , ..., identifiern are optional, distinct
+identifiers for the alternatives, and Type1, ..., Typen are
+the types of the alternatives. The identifiers are primarily
+for documentation; they do not affect values of the type or
+their encodings in any way.
+
+The types must have distinct tags. This requirement is
+typically satisfied with explicit or implicit tagging on
+some of the alternatives.
+
+Example: PKCS #7's ExtendedCertificateOrCertificate type is
+a CHOICE type:
+
+ExtendedCertificateOrCertificate ::= CHOICE {
+ certificate Certificate, -- X.509
+ extendedCertificate [0] IMPLICIT ExtendedCertificate
+}
+
+Here the identifiers for the alternatives are certificate
+and extendedCertificate, and the types of the alternatives
+are Certificate and [0] IMPLICIT ExtendedCertificate.
+
+BER encoding. Same as the BER encoding of the chosen
+alternative. The fact that the alternatives have distinct
+tags makes it possible to distinguish between their BER
+encodings.
+
+Example: The identifier octets for the BER encoding are 30
+if the chosen alternative is certificate, and a0 if the
+chosen alternative is extendedCertificate.
+
+DER encoding. Same as the DER encoding of the chosen
+alternative.
+
+
+5.6 IA5String
+
+The IA5String type denotes an arbtrary string of IA5
+characters. IA5 stands for International Alphabet 5, which
+is the same as ASCII. The character set includes non-
+printing control characters. An IA5String value can have any
+length, including zero. This type is a string type.
+
+The IA5String type is used in PKCS #9's electronic-mail
+address, unstructured-name, and unstructured-address
+attributes.
+
+ASN.1 notation:
+
+IA5String
+
+BER encoding. Primitive or constructed. In a primitive
+encoding, the contents octets give the characters in the IA5
+string, encoded in ASCII. In a constructed encoding, the
+contents octets give the concatenation of the BER encodings
+of consecutive substrings of the IA5 string.
+
+Example: The BER encoding of the IA5String value
+"test1@rsa.com" can be any of the following, among others,
+depending on the form of length octets and whether the
+encoding is primitive or constructed:
+
+16 0d 74 65 73 74 31 40 72 73 61 2e 63 6f 6d DER encoding
+
+16 81 0d long form of length octets
+ 74 65 73 74 31 40 72 73 61 2e 63 6f 6d
+
+36 13 constructed encoding: "test1" + "@" + "rsa.com"
+ 16 05 74 65 73 74 31
+ 16 01 40
+ 16 07 72 73 61 2e 63 6f 6d
+
+DER encoding. Primitive. Contents octets are as for a
+primitive BER encoding.
+
+Example: The DER encoding of the IA5String value
+"test1@rsa.com" is
+
+16 0d 74 65 73 74 31 40 72 73 61 2e 63 6f 6d
+
+
+5.7 INTEGER
+
+The INTEGER type denotes an arbitrary integer. INTEGER
+values can be positive, negative, or zero, and can have any
+magnitude.
+
+The INTEGER type is used for version numbers throughout
+PKCS, cryptographic values such as modulus, exponent, and
+primes in PKCS #1's RSAPublicKey and RSAPrivateKey types and
+PKCS #3's DHParameter type, a message-digest iteration count
+in PKCS #5's PBEParameter type, and version numbers and
+serial numbers in X.509's Certificate type.
+
+ASN.1 notation:
+
+INTEGER [{ identifier1(value1) ... identifiern(valuen) }]
+
+where identifier1, ..., identifiern are optional distinct
+identifiers and value1, ..., valuen are optional integer
+values. The identifiers, when present, are associated with
+values of the type.
+
+Example: X.509's Version type is an INTEGER type with
+identified values:
+
+Version ::= INTEGER { v1988(0) }
+
+The identifier v1988 is associated with the value 0. X.509's
+Certificate type uses the identifier v1988 to give a default
+value of 0 for the version component:
+
+Certificate ::= ...
+ version Version DEFAULT v1988,
+...
+
+BER encoding. Primitive. Contents octets give the value of
+the integer, base 256, in two's complement form, most
+significant digit first, with the minimum number of octets.
+The value 0 is encoded as a single 00 octet.
+
+Some example BER encodings (which also happen to be DER
+encodings) are given in Table 3.
+
+ Integer BER encoding
+ value
+ 0 02 01 00
+ 127 02 01 7F
+ 128 02 02 00 80
+ 256 02 02 01 00
+ -128 02 01 80
+ -129 02 02 FF 7F
+
+ Table 3. Example BER encodings of INTEGER values.
+
+DER encoding. Primitive. Contents octets are as for a
+primitive BER encoding.
+
+
+5.8 NULL
+
+The NULL type denotes a null value.
+
+The NULL type is used for algorithm parameters in several
+places in PKCS.
+
+ASN.1 notation:
+
+NULL
+
+BER encoding. Primitive. Contents octets are empty.
+
+Example: The BER encoding of a NULL value can be either of
+the following, as well as others, depending on the form of
+the length octets:
+
+05 00
+
+05 81 00
+
+DER encoding. Primitive. Contents octets are empty; the DER
+encoding of a NULL value is always 05 00.
+
+
+5.9 OBJECT IDENTIFIER
+
+The OBJECT IDENTIFIER type denotes an object identifier, a
+sequence of integer components that identifies an object
+such as an algorithm, an attribute type, or perhaps a
+registration authority that defines other object
+identifiers. An OBJECT IDENTIFIER value can have any number
+of components, and components can generally have any
+nonnegative value. This type is a non-string type.
+
+OBJECT IDENTIFIER values are given meanings by registration
+authorities. Each registration authority is responsible for
+all sequences of components beginning with a given sequence.
+A registration authority typically delegates responsibility
+for subsets of the sequences in its domain to other
+registration authorities, or for particular types of object.
+There are always at least two components.
+
+The OBJECT IDENTIFIER type is used to identify content in
+PKCS #7's ContentInfo type, to identify algorithms in
+X.509's AlgorithmIdentifier type, and to identify attributes
+in X.501's Attribute and AttributeValueAssertion types. The
+Attribute type is used by PKCS #6, #7, #8, #9, and #10, and
+the AttributeValueAssertion type is used in X.501
+distinguished names. OBJECT IDENTIFIER values are defined
+throughout PKCS.
+
+ASN.1 notation:
+
+OBJECT IDENTIFIER
+
+The ASN.1 notation for values of the OBJECT IDENTIFIER type
+is
+
+{ [identifier] component1 ... componentn }
+
+componenti = identifieri | identifieri (valuei) | valuei
+
+where identifier, identifier1, ..., identifiern are
+identifiers, and value1, ..., valuen are optional integer
+values.
+
+The form without identifier is the "complete" value with all
+its components; the form with identifier abbreviates the
+beginning components with another object identifier value.
+The identifiers identifier1, ..., identifiern are intended
+primarily for documentation, but they must correspond to the
+integer value when both are present. These identifiers can
+appear without integer values only if they are among a small
+set of identifiers defined in X.208.
+
+Example: The following values both refer to the object
+identifier assigned to RSA Data Security, Inc.:
+
+{ iso(1) member-body(2) 840 113549 }
+{ 1 2 840 113549 }
+
+(In this example, which gives ASN.1 value notation, the
+object identifier values are decimal, not hexadecimal.)
+Table 4 gives some other object identifier values and their
+meanings.
+
+ Object identifier value Meaning
+ { 1 2 } ISO member bodies
+ { 1 2 840 } US (ANSI)
+ { 1 2 840 113549 } RSA Data Security, Inc.
+ { 1 2 840 113549 1 } RSA Data Security, Inc. PKCS
+ { 2 5 } directory services (X.500)
+ { 2 5 8 } directory services-algorithms
+
+ Table 4. Some object identifier values and their meanings.
+
+BER encoding. Primitive. Contents octets are as follows,
+where value1, ..., valuen denote the integer values of the
+components in the complete object identifier:
+
+ 1. The first octet has value 40 * value1 + value2.
+ (This is unambiguous, since value1 is limited to
+ values 0, 1, and 2; value2 is limited to the range
+ 0 to 39 when value1 is 0 or 1; and, according to
+ X.208, n is always at least 2.)
+
+ 2. The following octets, if any, encode value3, ...,
+ valuen. Each value is encoded base 128, most
+ significant digit first, with as few digits as
+ possible, and the most significant bit of each
+ octet except the last in the value's encoding set
+ to "1."
+
+Example: The first octet of the BER encoding of RSA Data
+Security, Inc.'s object identifier is 40 * 1 + 2 = 42 =
+2a16. The encoding of 840 = 6 * 128 + 4816 is 86 48 and the
+encoding of 113549 = 6 * 1282 + 7716 * 128 + d16 is 86 f7
+0d. This leads to the following BER encoding:
+
+06 06 2a 86 48 86 f7 0d
+
+DER encoding. Primitive. Contents octets are as for a
+primitive BER encoding.
+
+
+5.10 OCTET STRING
+
+The OCTET STRING type denotes an arbitrary string of octets
+(eight-bit values). An OCTET STRING value can have any
+length, including zero. This type is a string type.
+
+The OCTET STRING type is used for salt values in PKCS #5's
+PBEParameter type, for message digests, encrypted message
+digests, and encrypted content in PKCS #7, and for private
+keys and encrypted private keys in PKCS #8.
+
+ASN.1 notation:
+
+OCTET STRING [SIZE ({size | size1..size2})]
+
+where size, size1, and size2 are optional size constraints.
+In the OCTET STRING SIZE (size) form, the octet string must
+have size octets. In the OCTET STRING SIZE (size1..size2)
+form, the octet string must have between size1 and size2
+octets. In the OCTET STRING form, the octet string can have
+any size.
+
+Example: PKCS #5's PBEParameter type has a component of type
+OCTET STRING:
+
+PBEParameter ::= SEQUENCE {
+ salt OCTET STRING SIZE(8),
+ iterationCount INTEGER }
+
+Here the size of the salt component is always eight octets.
+
+BER encoding. Primitive or constructed. In a primitive
+encoding, the contents octets give the value of the octet
+string, first octet to last octet. In a constructed
+encoding, the contents octets give the concatenation of the
+BER encodings of substrings of the OCTET STRING value.
+
+Example: The BER encoding of the OCTET STRING value 01 23 45
+67 89 ab cd ef can be any of the following, among others,
+depending on the form of length octets and whether the
+encoding is primitive or constructed:
+
+04 08 01 23 45 67 89 ab cd ef DER encoding
+
+04 81 08 01 23 45 67 89 ab cd ef long form of length octets
+
+24 0c constructed encoding: 01 ... 67 + 89 ... ef
+ 04 04 01 23 45 67
+ 04 04 89 ab cd ef
+
+DER encoding. Primitive. Contents octets are as for a
+primitive BER encoding.
+
+Example: The BER encoding of the OCTET STRING value 01 23 45
+67 89 ab cd ef is
+
+04 08 01 23 45 67 89 ab cd ef
+
+
+5.11 PrintableString
+
+The PrintableString type denotes an arbitrary string of
+printable characters from the following character set:
+
+ A, B, ..., Z
+ a, b, ..., z
+ 0, 1, ..., 9
+ (space) ' ( ) + , - . / : = ?
+
+This type is a string type.
+
+The PrintableString type is used in PKCS #9's challenge-
+password and unstructuerd-address attributes, and in several
+X.521 distinguished names attributes.
+
+ASN.1 notation:
+
+PrintableString
+
+BER encoding. Primitive or constructed. In a primitive
+encoding, the contents octets give the characters in the
+printable string, encoded in ASCII. In a constructed
+encoding, the contents octets give the concatenation of the
+BER encodings of consecutive substrings of the string.
+
+Example: The BER encoding of the PrintableString value "Test
+User 1" can be any of the following, among others, depending
+on the form of length octets and whether the encoding is
+primitive or constructed:
+
+13 0b 54 65 73 74 20 55 73 65 72 20 31 DER encoding
+
+13 81 0b long form of length octets
+ 54 65 73 74 20 55 73 65 72 20 31
+
+33 0f constructed encoding: "Test " + "User 1"
+ 13 05 54 65 73 74 20
+ 13 06 55 73 65 72 20 31
+
+DER encoding. Primitive. Contents octets are as for a
+primitive BER encoding.
+
+Example: The DER encoding of the PrintableString value "Test
+User 1" is
+
+13 0b 54 65 73 74 20 55 73 65 72 20 31
+
+
+5.12 SEQUENCE
+
+The SEQUENCE type denotes an ordered collection of one or
+more types.
+
+The SEQUENCE type is used throughout PKCS and related
+standards.
+
+ASN.1 notation:
+
+SEQUENCE {
+ [identifier1] Type1 [{OPTIONAL | DEFAULT value1}],
+ ...,
+ [identifiern] Typen [{OPTIONAL | DEFAULT valuen}]}
+
+where identifier1 , ..., identifiern are optional, distinct
+identifiers for the components, Type1, ..., Typen are the
+types of the components, and value1, ..., valuen are optional
+default values for the components. The identifiers are
+primarily for documentation; they do not affect values of
+the type or their encodings in any way.
+
+The OPTIONAL qualifier indicates that the value of a
+component is optional and need not be present in the
+sequence. The DEFAULT qualifier also indicates that the
+value of a component is optional, and assigns a default
+value to the component when the component is absent.
+
+The types of any consecutive series of components with the
+OPTIONAL or DEFAULT qualifier, as well as of any component
+immediately following that series, must have distinct tags.
+This requirement is typically satisfied with explicit or
+implicit tagging on some of the components.
+
+Example: X.509's Validity type is a SEQUENCE type with two
+components:
+
+Validity ::= SEQUENCE {
+ start UTCTime,
+ end UTCTime }
+
+Here the identifiers for the components are start and end,
+and the types of the components are both UTCTime.
+
+BER encoding. Constructed. Contents octets are the
+concatenation of the BER encodings of the values of the
+components of the sequence, in order of definition, with the
+following rules for components with the OPTIONAL and DEFAULT
+qualifiers:
+
+ o if the value of a component with the OPTIONAL or
+ DEFAULT qualifier is absent from the sequence,
+ then the encoding of that component is not
+ included in the contents octets
+
+ o if the value of a component with the DEFAULT
+ qualifier is the default value, then the encoding
+ of that component may or may not be included in
+ the contents octets
+
+DER encoding. Constructed. Contents octets are the same as
+the BER encoding, except that if the value of a component
+with the DEFAULT qualifier is the default value, the
+encoding of that component is not included in the contents
+octets.
+
+
+5.13 SEQUENCE OF
+
+The SEQUENCE OF type denotes an ordered collection of zero
+or more occurrences of a given type.
+
+The SEQUENCE OF type is used in X.501 distinguished names.
+
+ASN.1 notation:
+
+SEQUENCE OF Type
+
+where Type is a type.
+
+Example: X.501's RDNSequence type consists of zero or more
+occurences of the RelativeDistinguishedName type, most
+significant occurrence first:
+
+RDNSequence ::= SEQUENCE OF RelativeDistinguishedName
+
+BER encoding. Constructed. Contents octets are the
+concatenation of the BER encodings of the values of the
+occurrences in the collection, in order of occurence.
+
+DER encoding. Constructed. Contents octets are the
+concatenation of the DER encodings of the values of the
+occurrences in the collection, in order of occurence.
+
+
+5.14 SET
+
+The SET type denotes an unordered collection of one or more
+types.
+
+The SET type is not used in PKCS.
+
+ASN.1 notation:
+
+SET {
+ [identifier1] Type1 [{OPTIONAL | DEFAULT value1}],
+ ...,
+ [identifiern] Typen [{OPTIONAL | DEFAULT valuen}]}
+
+where identifier1, ..., identifiern are optional, distinct
+identifiers for the components, Type1, ..., Typen are the
+types of the components, and value1, ..., valuen are
+optional default values for the components. The identifiers
+are primarily for documentation; they do not affect values
+of the type or their encodings in any way.
+
+The OPTIONAL qualifier indicates that the value of a
+component is optional and need not be present in the set.
+The DEFAULT qualifier also indicates that the value of a
+component is optional, and assigns a default value to the
+component when the component is absent.
+
+The types must have distinct tags. This requirement is
+typically satisfied with explicit or implicit tagging on
+some of the components.
+
+BER encoding. Constructed. Contents octets are the
+concatenation of the BER encodings of the values of the
+components of the set, in any order, with the following
+rules for components with the OPTIONAL and DEFAULT
+qualifiers:
+
+ o if the value of a component with the OPTIONAL or
+ DEFAULT qualifier is absent from the set, then the
+ encoding of that component is not included in the
+ contents octets
+
+ o if the value of a component with the DEFAULT
+ qualifier is the default value, then the encoding
+ of that component may or may not be included in
+ the contents octets
+
+DER encoding. Constructed. Contents octets are the same as
+for the BER encoding, except that:
+
+ 1. If the value of a component with the DEFAULT
+ qualifier is the default value, the encoding of
+ that component is not included.
+
+ 2. There is an order to the components, namely
+ ascending order by tag.
+
+
+5.15 SET OF
+
+The SET OF type denotes an unordered collection of zero or
+more occurrences of a given type.
+
+The SET OF type is used for sets of attributes in PKCS #6,
+#7, #8, #9 and #10, for sets of message-digest algorithm
+identifiers, signer information, and recipient information
+in PKCS #7, and in X.501 distinguished names.
+
+ASN.1 notation:
+
+SET OF Type
+
+where Type is a type.
+
+Example: X.501's RelativeDistinguishedName type consists of
+zero or more occurrences of the AttributeValueAssertion
+type, where the order is unimportant:
+
+RelativeDistinguishedName ::=
+ SET OF AttributeValueAssertion
+
+BER encoding. Constructed. Contents octets are the
+concatenation of the BER encodings of the values of the
+occurrences in the collection, in any order.
+
+DER encoding. Constructed. Contents octets are the same as
+for the BER encoding, except that there is an order, namely
+ascending lexicographic order of BER encoding. Lexicographic
+comparison of two different BER encodings is done as
+follows: Logically pad the shorter BER encoding after the
+last octet with dummy octets that are smaller in value than
+any normal octet. Scan the BER encodings from left to right
+until a difference is found. The smaller-valued BER encoding
+is the one with the smaller-valued octet at the point of
+difference.
+
+
+5.16 T61String
+
+The T61String type denotes an arbtrary string of T.61
+characters. T.61 is an eight-bit extension to the ASCII
+character set. Special "escape" sequences specify the
+interpretation of subsequent character values as, for
+example, Japanese; the initial interpretation is Latin. The
+character set includes non-printing control characters. The
+T61String type allows only the Latin and Japanese character
+interepretations, and implementors' agreements for directory
+names exclude control characters [NIST92]. A T61String value
+can have any length, including zero. This type is a string
+type.
+
+The T61String type is used in PKCS #9's unstructured-address
+and challenge-password attributes, and in several X.521
+attributes.
+
+ASN.1 notation:
+
+T61String
+
+BER encoding. Primitive or constructed. In a primitive
+encoding, the contents octets give the characters in the
+T.61 string, encoded in ASCII. In a constructed encoding,
+the contents octets give the concatenation of the BER
+encodings of consecutive substrings of the T.61 string.
+
+Example: The BER encoding of the T61String value "cl'es
+publiques" (French for "public keys") can be any of the
+following, among others, depending on the form of length
+octets and whether the encoding is primitive or constructed:
+
+14 0f DER encoding
+ 63 6c c2 65 73 20 70 75 62 6c 69 71 75 65 73
+
+14 81 0f long form of length octets
+ 63 6c c2 65 73 20 70 75 62 6c 69 71 75 65 73
+
+34 15 constructed encoding: "cl'es" + " " + "publiques"
+ 14 05 63 6c c2 65 73
+ 14 01 20
+ 14 09 70 75 62 6c 69 71 75 65 73
+
+The eight-bit character c2 is a T.61 prefix that adds an
+acute accent (') to the next character.
+
+DER encoding. Primitive. Contents octets are as for a
+primitive BER encoding.
+
+Example: The DER encoding of the T61String value "cl'es
+publiques" is
+
+14 0f 63 6c c2 65 73 20 70 75 62 6c 69 71 75 65 73
+
+
+5.17 UTCTime
+
+The UTCTime type denotes a "coordinated universal time" or
+Greenwich Mean Time (GMT) value. A UTCTime value includes
+the local time precise to either minutes or seconds, and an
+offset from GMT in hours and minutes. It takes any of the
+following forms:
+
+YYMMDDhhmmZ
+YYMMDDhhmm+hh'mm'
+YYMMDDhhmm-hh'mm'
+YYMMDDhhmmssZ
+YYMMDDhhmmss+hh'mm'
+YYMMDDhhmmss-hh'mm'
+
+where:
+
+ YY is the least significant two digits of the year
+
+ MM is the month (01 to 12)
+
+ DD is the day (01 to 31)
+
+ hh is the hour (00 to 23)
+
+ mm are the minutes (00 to 59)
+
+ ss are the seconds (00 to 59)
+
+ Z indicates that local time is GMT, + indicates that
+ local time is later than GMT, and - indicates that
+ local time is earlier than GMT
+
+ hh' is the absolute value of the offset from GMT in
+ hours
+
+ mm' is the absolute value of the offset from GMT in
+ minutes
+
+This type is a string type.
+
+The UTCTime type is used for signing times in PKCS #9's
+signing-time attribute and for certificate validity periods
+in X.509's Validity type.
+
+ASN.1 notation:
+
+UTCTime
+
+BER encoding. Primitive or constructed. In a primitive
+encoding, the contents octets give the characters in the
+string, encoded in ASCII. In a constructed encoding, the
+contents octets give the concatenation of the BER encodings
+of consecutive substrings of the string. (The constructed
+encoding is not particularly interesting, since UTCTime
+values are so short, but the constructed encoding is
+permitted.)
+
+Example: The time this sentence was originally written was
+4:45:40 p.m. Pacific Daylight Time on May 6, 1991, which can
+be represented with either of the following UTCTime values,
+among others:
+
+"910506164540-0700"
+
+"910506234540Z"
+
+These values have the following BER encodings, among others:
+
+17 0d 39 31 30 35 30 36 32 33 34 35 34 30 5a
+
+17 11 39 31 30 35 30 36 31 36 34 35 34 30 2D 30 37 30
+ 30
+
+DER encoding. Primitive. Contents octets are as for a
+primitive BER encoding.
+
+
+6. An example
+
+This section gives an example of ASN.1 notation and DER
+encoding: the X.501 type Name.
+
+
+6.1 Abstract notation
+
+This section gives the ASN.1 notation for the X.501 type
+Name.
+
+Name ::= CHOICE {
+ RDNSequence }
+
+RDNSequence ::= SEQUENCE OF RelativeDistinguishedName
+
+RelativeDistinguishedName ::=
+ SET OF AttributeValueAssertion
+
+AttributeValueAssertion ::= SEQUENCE {
+ AttributeType,
+ AttributeValue }
+
+AttributeType ::= OBJECT IDENTIFIER
+
+AttributeValue ::= ANY
+
+The Name type identifies an object in an X.500 directory.
+Name is a CHOICE type consisting of one alternative:
+RDNSequence. (Future revisions of X.500 may have other
+alternatives.)
+
+The RDNSequence type gives a path through an X.500 directory
+tree starting at the root. RDNSequence is a SEQUENCE OF type
+consisting of zero or more occurences of
+RelativeDistinguishedName.
+
+The RelativeDistinguishedName type gives a unique name to an
+object relative to the object superior to it in the
+directory tree. RelativeDistinguishedName is a SET OF type
+consisting of zero or more occurrences of
+AttributeValueAssertion.
+
+The AttributeValueAssertion type assigns a value to some
+attribute of a relative distinguished name, such as country
+name or common name. AttributeValueAssertion is a SEQUENCE
+type consisting of two components, an AttributeType type and
+an AttributeValue type.
+
+The AttributeType type identifies an attribute by object
+identifier. The AttributeValue type gives an arbitrary
+attribute value. The actual type of the attribute value is
+determined by the attribute type.
+
+
+6.2 DER encoding
+
+This section gives an example of a DER encoding of a value
+of type Name, working from the bottom up.
+
+The name is that of the Test User 1 from the PKCS examples
+[Kal93]. The name is represented by the following path:
+
+ (root)
+ |
+ countryName = "US"
+ |
+ organizationName = "Example Organization"
+ |
+ commonName = "Test User 1"
+
+Each level corresponds to one RelativeDistinguishedName
+value, each of which happens for this name to consist of one
+AttributeValueAssertion value. The AttributeType value is
+before the equals sign, and the AttributeValue value (a
+printable string for the given attribute types) is after the
+equals sign.
+
+The countryName, organizationName, and commonUnitName are
+attribute types defined in X.520 as:
+
+attributeType OBJECT IDENTIFIER ::=
+ { joint-iso-ccitt(2) ds(5) 4 }
+
+countryName OBJECT IDENTIFIER ::= { attributeType 6 }
+organizationName OBJECT IDENTIFIER ::=
+ { attributeType 10 }
+commonUnitName OBJECT IDENTIFIER ::=
+ { attributeType 3 }
+
+
+6.2.1 AttributeType
+
+The three AttributeType values are OCTET STRING values, so
+their DER encoding follows the primitive, definite-length
+method:
+
+06 03 55 04 06 countryName
+
+06 03 55 04 0a organizationName
+
+06 03 55 04 03 commonName
+
+The identifier octets follow the low-tag form, since the tag
+is 6 for OBJECT IDENTIFIER. Bits 8 and 7 have value "0,"
+indicating universal class, and bit 6 has value "0,"
+indicating that the encoding is primitive. The length octets
+follow the short form. The contents octets are the
+concatenation of three octet strings derived from
+subidentifiers (in decimal): 40 * 2 + 5 = 85 = 5516; 4; and
+6, 10, or 3.
+
+
+6.2.2 AttributeValue
+
+The three AttributeValue values are PrintableString values,
+so their encodings follow the primitive, definite-length
+method:
+
+13 02 55 53 "US"
+
+13 14 "Example Organization"
+ 45 78 61 6d 70 6c 65 20 4f 72 67 61 6e 69 7a 61
+ 74 69 6f 6e
+
+13 0b "Test User 1"
+ 54 65 73 74 20 55 73 65 72 20 31
+
+The identifier octets follow the low-tag-number form, since
+the tag for PrintableString, 19 (decimal), is between 0 and
+30. Bits 8 and 7 have value "0" since PrintableString is in
+the universal class. Bit 6 has value "0" since the encoding
+is primitive. The length octets follow the short form, and
+the contents octets are the ASCII representation of the
+attribute value.
+
+
+6.2.3 AttributeValueAssertion
+
+The three AttributeValueAssertion values are SEQUENCE
+values, so their DER encodings follow the constructed,
+definite-length method:
+
+30 09 countryName = "US"
+ 06 03 55 04 06
+ 13 02 55 53
+
+30 1b organizationName = "Example Organizaiton"
+ 06 03 55 04 0a
+ 13 14 ... 6f 6e
+
+30 12 commonName = "Test User 1"
+ 06 03 55 04 0b
+ 13 0b ... 20 31
+
+The identifier octets follow the low-tag-number form, since
+the tag for SEQUENCE, 16 (decimal), is between 0 and 30.
+Bits 8 and 7 have value "0" since SEQUENCE is in the
+universal class. Bit 6 has value "1" since the encoding is
+constructed. The length octets follow the short form, and
+the contents octets are the concatenation of the DER
+encodings of the attributeType and attributeValue
+components.
+
+
+6.2.4 RelativeDistinguishedName
+
+The three RelativeDistinguishedName values are SET OF
+values, so their DER encodings follow the constructed,
+definite-length method:
+
+31 0b
+ 30 09 ... 55 53
+
+31 1d
+ 30 1b ... 6f 6e
+
+31 14
+ 30 12 ... 20 31
+
+The identifier octets follow the low-tag-number form, since
+the tag for SET OF, 17 (decimal), is between 0 and 30. Bits
+8 and 7 have value "0" since SET OF is in the universal
+class Bit 6 has value "1" since the encoding is constructed.
+The lengths octets follow the short form, and the contents
+octets are the DER encodings of the respective
+AttributeValueAssertion values, since there is only one
+value in each set.
+
+
+6.2.5 RDNSequence
+
+The RDNSequence value is a SEQUENCE OF value, so its DER
+encoding follows the constructed, definite-length method:
+
+30 42
+ 31 0b ... 55 53
+ 31 1d ... 6f 6e
+ 31 14 ... 20 31
+
+The identifier octets follow the low-tag-number form, since
+the tag for SEQUENCE OF, 16 (decimal), is between 0 and 30.
+Bits 8 and 7 have value "0" since SEQUENCE OF is in the
+universal class. Bit 6 has value "1" since the encoding is
+constructed. The lengths octets follow the short form, and
+the contents octets are the concatenation of the DER
+encodings of the three RelativeDistinguishedName values, in
+order of occurrence.
+
+
+6.2.6 Name
+
+The Name value is a CHOICE value, so its DER encoding is the
+same as that of the RDNSequence value:
+
+30 42
+ 31 0b
+ 30 09
+ 06 03 55 04 06 attributeType = countryName
+ 13 02 55 53 attributeValue = "US"
+ 31 1d
+ 30 1b
+ 06 03 55 04 0a attributeType = organizationName
+ 13 14 attributeValue = "Example Organization"
+ 45 78 61 6d 70 6c 65 20 4f 72 67 61 6e 69 7a 61
+ 74 69 6f 6e
+
+ 31 14
+ 30 12
+ 06 03 55 04 03 attributeType = commonName
+ 13 0b attributeValue = "Test User 1"
+ 54 65 73 74 20 55 73 65 72 20 31
+
+
+References
+
+PKCS #1 RSA Laboratories. PKCS #1: RSA Encryption
+ Standard. Version 1.5, November 1993.
+
+PKCS #3 RSA Laboratories. PKCS #3: Diffie-Hellman Key-
+ Agreement Standard. Version 1.4, November 1993.
+
+PKCS #5 RSA Laboratories. PKCS #5: Password-Based
+ Encryption Standard. Version 1.5, November 1993.
+
+PKCS #6 RSA Laboratories. PKCS #6: Extended-Certificate
+ Syntax Standard. Version 1.5, November 1993.
+
+PKCS #7 RSA Laboratories. PKCS #7: Cryptographic Message
+ Syntax Standard. Version 1.5, November 1993.
+
+PKCS #8 RSA Laboratories. PKCS #8: Private-Key Information
+ Syntax Standard. Version 1.2, November 1993.
+
+PKCS #9 RSA Laboratories. PKCS #9: Selected Attribute
+ Types. Version 1.1, November 1993.
+
+PKCS #10 RSA Laboratories. PKCS #10: Certification Request
+ Syntax Standard. Version 1.0, November 1993.
+
+X.200 CCITT. Recommendation X.200: Reference Model of
+ Open Systems Interconnection for CCITT
+ Applications. 1984.
+
+X.208 CCITT. Recommendation X.208: Specification of
+ Abstract Syntax Notation One (ASN.1). 1988.
+
+X.209 CCITT. Recommendation X.209: Specification of
+ Basic Encoding Rules for Abstract Syntax Notation
+ One (ASN.1). 1988.
+
+X.500 CCITT. Recommendation X.500: The
+ Directory--Overview of Concepts, Models and
+ Services. 1988.
+
+X.501 CCITT. Recommendation X.501: The Directory--
+ Models. 1988.
+
+X.509 CCITT. Recommendation X.509: The Directory--
+ Authentication Framework. 1988.
+
+X.520 CCITT. Recommendation X.520: The Directory--
+ Selected Attribute Types. 1988.
+
+[Kal93] Burton S. Kaliski Jr. Some Examples of the PKCS
+ Standards. RSA Laboratories, November 1993.
+
+[NIST92] NIST. Special Publication 500-202: Stable
+ Implementation Agreements for Open Systems
+ Interconnection Protocols. Part 11 (Directory
+ Services Protocols). December 1992.
+
+
+Revision history
+
+
+June 3, 1991 version
+
+The June 3, 1991 version is part of the initial public
+release of PKCS. It was published as NIST/OSI Implementors'
+Workshop document SEC-SIG-91-17.
+
+
+November 1, 1993 version
+
+The November 1, 1993 version incorporates several editorial
+changes, including the addition of a revision history. It is
+updated to be consistent with the following versions of the
+PKCS documents:
+
+ PKCS #1: RSA Encryption Standard. Version 1.5, November
+ 1993.
+
+ PKCS #3: Diffie-Hellman Key-Agreement Standard. Version
+ 1.4, November 1993.
+
+ PKCS #5: Password-Based Encryption Standard. Version
+ 1.5, November 1993.
+
+ PKCS #6: Extended-Certificate Syntax Standard. Version
+ 1.5, November 1993.
+
+ PKCS #7: Cryptographic Message Syntax Standard. Version
+ 1.5, November 1993.
+
+ PKCS #8: Private-Key Information Syntax Standard.
+ Version 1.2, November 1993.
+
+ PKCS #9: Selected Attribute Types. Version 1.1,
+ November 1993.
+
+ PKCS #10: Certification Request Syntax Standard.
+ Version 1.0, November 1993.
+
+The following substantive changes were made:
+
+ Section 5: Description of T61String type is added.
+
+ Section 6: Names are changed, consistent with other
+ PKCS examples.
+
+
+Author's address
+
+Burton S. Kaliski Jr., Ph.D.
+Chief Scientist
+RSA Laboratories (415) 595-7703
+100 Marine Parkway (415) 595-4126 (fax)
+Redwood City, CA 94065 USA burt@rsa.com
diff --git a/tcllib/modules/asn/pkgIndex.tcl b/tcllib/modules/asn/pkgIndex.tcl
new file mode 100644
index 0000000..3cbafd6
--- /dev/null
+++ b/tcllib/modules/asn/pkgIndex.tcl
@@ -0,0 +1,4 @@
+# Tcl package index file, version 1.1
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded asn 0.8.4 [list source [file join $dir asn.tcl]]
diff --git a/tcllib/modules/base32/ChangeLog b/tcllib/modules/base32/ChangeLog
new file mode 100644
index 0000000..5ebdf83
--- /dev/null
+++ b/tcllib/modules/base32/ChangeLog
@@ -0,0 +1,114 @@
+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-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 ========================
+ *
+
+2008-06-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base32.pcx: New file. Syntax definitions for the public commands
+ * base32_core.pcx: of the bibtex package.
+ * base32_hex.pcx:
+
+2008-03-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base32hex.tcl: Added missing implementation of 'Names' for use
+ by TestAccelInit.
+ * base32hex.test: Cleaned up to use the standard TestAccel*
+ commands for handling of accelerators in a testsuite. Moved
+ loading of base32::core to testing section, as that internal
+ package is implicitly tested as well.
+ * base32.test: Moved loading of base32::core to testing section,
+ as that internal package is implicitly tested as well.
+
+2008-01-28 Andreas Kupries <andreask@activestate.com>
+
+ * base32hex_c.tcl: Disabled the critcl::debug and critcl::cheaders
+ * base32_c.tcl: -g definitions
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-03-23 Andreas Kupries <andreask@activestate.com>
+
+ * base32hex.tcl: Added MD hints.
+
+2007-03-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base32.man: Fixed all warnings due to use of now deprecated
+ * base32core.man: commands. Added a section about how to give
+ * base32hex.man: feedback.
+
+2006-10-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base32.test: Rewritten to make use of the new facilities for
+ * base32.tcl: testing of multiple implementations put into the
+ test utilities.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-05-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base32_c.tcl (critcl_decode): Simplified the decoder.
+ * base32hex_c.tcl (critcl_decode): Use ByteArray, avoids
+ complex UniChar -> Utf8 conversion on our part. Also moves
+ the handling of padding out of the decoder loop.
+
+2006-05-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base32.bench: base32 standard encoding, extended hex
+ * base32.man: encoding. Tcl implementation, Critcl
+ * base32.tcl: implementation. Switch management.
+ * base32.test: Support package for Tcl implementation.
+ * base32.testsuite: Documentation. Benchmarks. Testsuites.
+ * base32_c.tcl:
+ * base32_tcl.tcl:
+ * base32core.man:
+ * base32core.tcl:
+ * base32hex.bench:
+ * base32hex.man:
+ * base32hex.tcl:
+ * base32hex.test:
+ * base32hex.testsuite:
+ * base32hex_c.tcl:
+ * base32hex_tcl.tcl:
+ * pkgIndex.tcl:
+
+ * New module 'base32'.
diff --git a/tcllib/modules/base32/base32.bench b/tcllib/modules/base32/base32.bench
new file mode 100644
index 0000000..1840148
--- /dev/null
+++ b/tcllib/modules/base32/base32.bench
@@ -0,0 +1,87 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'base32' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# Public domain
+
+# We need at least version 8.4 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.4]} return
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+package forget base32
+package forget base32::core
+catch {namespace delete ::base32}
+
+set self [file join [pwd] [file dirname [info script]]]
+set index [file join [file dirname $self] tcllibc pkgIndex.tcl]
+
+if {[file exists $index]} {
+ set ::dir [file dirname $index]
+ uplevel #0 [list source $index]
+ unset ::dir
+ package require tcllibc
+}
+
+source [file join $self base32core.tcl]
+source [file join $self base32.tcl]
+
+set bytes \000\010\020\030\001\011\021\031\002\012\022\032\003\013\023\033
+append bytes \004\014\024\034\005\015\025\035\006\016\026\036\007\017\027\037
+append bytes \040\050\060\070\041\051\061\071\042\052\062\072\043\053\063\073
+append bytes \044\054\064\074\045\055\065\075\046\056\066\076\047\057\067\077
+append bytes \100\110\120\130\101\111\121\131\102\112\122\132\103\113\123\133
+append bytes \104\114\124\134\105\115\125\135\106\116\126\136\107\117\127\137
+append bytes \140\150\160\170\141\151\161\171\142\152\162\172\143\153\163\173
+append bytes \144\154\164\174\145\155\165\175\146\156\166\176\147\157\167\177
+append bytes \200\210\220\230\201\211\221\231\202\212\222\232\203\213\223\233
+append bytes \204\214\224\234\205\215\225\235\206\216\226\236\207\217\227\237
+append bytes \240\250\260\270\241\251\261\271\242\252\262\272\243\253\263\273
+append bytes \244\254\264\274\245\255\265\275\246\256\266\276\247\257\267\277
+append bytes \300\310\320\330\301\311\321\331\302\312\322\332\303\313\323\333
+append bytes \304\314\324\334\305\315\325\335\306\316\326\336\307\317\327\337
+append bytes \340\350\360\370\341\351\361\371\342\352\362\372\343\353\363\373
+append bytes \344\354\364\374\345\355\365\375\346\356\366\376\347\357\367\377
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+base32::SwitchTo {}
+foreach e [base32::KnownImplementations] {
+ ::base32::LoadAccelerator $e
+}
+
+foreach impl [base32::Implementations] {
+ base32::SwitchTo $impl
+
+ foreach rem {0 1 2 3 4} {
+ foreach len {0 10 100 1000 10000} {
+ set blen $len
+ incr blen $rem
+
+ set blanks [string repeat { } $blen]
+ set identic [string repeat A $blen]
+ set sbytes [string range [string repeat $bytes [expr {1+$blen/256}]] 0 [expr {$blen - 1}]]
+
+ bench -desc "base32-std-${impl}-enc-$rem/${len} blanks" -body {base32::encode $blanks}
+ bench -desc "base32-std-${impl}-enc-$rem/${len} identi" -body {base32::encode $identic}
+ bench -desc "base32-std-${impl}-enc-$rem/${len} sbytes" -body {base32::encode $sbytes}
+
+ set blanks [base32::encode $blanks]
+ set identic [base32::encode $identic]
+ set sbytes [base32::encode $sbytes]
+
+ bench -desc "base32-std-${impl}-dec-$rem/${len} blanks" -body {base32::decode $blanks}
+ bench -desc "base32-std-${impl}-dec-$rem/${len} identi" -body {base32::decode $identic}
+ bench -desc "base32-std-${impl}-dec-$rem/${len} sbytes" -body {base32::decode $sbytes}
+ }
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/base32/base32.man b/tcllib/modules/base32/base32.man
new file mode 100644
index 0000000..6e19d54
--- /dev/null
+++ b/tcllib/modules/base32/base32.man
@@ -0,0 +1,75 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin base32 n 0.1]
+[keywords base32]
+[keywords rfc3548]
+[copyright {Public domain}]
+[moddesc {Base32 encoding}]
+[titledesc {base32 standard encoding}]
+[category {Text processing}]
+[require Tcl 8.4]
+[require base32::core [opt 0.1]]
+[require base32 [opt 0.1]]
+[description]
+[para]
+
+This package provides commands for encoding and decoding of strings
+into and out of the standard base32 encoding as specified in RFC 3548.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::base32::encode] [arg string]]
+
+This command encodes the given [arg string] in base32 and returns the
+encoded string as its result. The result may be padded with the
+character [const =] to signal a partial encoding at the end of the
+input string.
+
+[call [cmd ::base32::decode] [arg estring]]
+
+This commands takes the [arg estring] and decodes it under the
+assumption that it is a valid base32 encoded string. The result of the
+decoding is returned as the result of the command.
+
+[para]
+
+Note that while the encoder will generate only uppercase characters
+this decoder accepts input in lowercase as well.
+
+[para]
+
+The command will always throw an error whenever encountering
+conditions which signal some type of bogus input, namely if
+
+[list_begin enumerated]
+[enum] the input contains characters which are not valid output of a base32 encoder,
+[enum] the length of the input is not a multiple of eight,
+[enum] padding appears not at the end of input, but in the middle,
+[enum] the padding has not of length six, four, three, or one characters,
+[list_end]
+[list_end]
+
+[section {Code map}]
+
+The code map used to convert 5-bit sequences is shown below, with the
+numeric id of the bit sequences to the left and the character used to
+encode it to the right. It should be noted that the characters "0" and
+"1" are not used by the encoding. This is done as these characters can
+be easily confused with "O", "o" and "l" (L).
+
+[example {
+ 0 A 9 J 18 S 27 3
+ 1 B 10 K 19 T 28 4
+ 2 C 11 L 20 U 29 5
+ 3 D 12 M 21 V 30 6
+ 4 E 13 N 22 W 31 7
+ 5 F 14 O 23 X
+ 6 G 15 P 24 Y
+ 7 H 16 Q 25 Z
+ 8 I 17 R 26 2
+}]
+
+[vset CATEGORY base32]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/base32/base32.pcx b/tcllib/modules/base32/base32.pcx
new file mode 100644
index 0000000..0592336
--- /dev/null
+++ b/tcllib/modules/base32/base32.pcx
@@ -0,0 +1,40 @@
+# -*- tcl -*- base32.pcx
+# Syntax of the commands provided by package base32.
+#
+# 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 base32
+pcx::tcldep 0.1 needs tcl 8.4
+
+namespace eval ::base32 {}
+
+pcx::message invalidStringLength {String is not a multiple of 8 characters long} err
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 0.1 std ::base32::decode \
+ {checkSimpleArgs 1 1 {
+ base32::checkEString
+ }}
+pcx::check 0.1 std ::base32::encode \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+
+proc base32::checkEString {t i} {
+ set w [lindex $t $i]
+ if {[getLiteral $w str]} {
+ if {[string length $str] % 8 != 0} {
+ logError base32::invalidStringLength [getTokenRange $w]
+ }
+ }
+ return [checkWord $t $i]
+}
+
+# Initialization via pcx::init.
+# Use a ::base32::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/base32/base32.tcl b/tcllib/modules/base32/base32.tcl
new file mode 100644
index 0000000..dd73114
--- /dev/null
+++ b/tcllib/modules/base32/base32.tcl
@@ -0,0 +1,182 @@
+# -*- tcl -*-
+# This code is hereby put into the public domain.
+# ### ### ### ######### ######### #########
+## Overview
+# Base32 encoding and decoding of small strings.
+#
+# Management code for switching between Tcl and C accelerated
+# implementations.
+#
+# RCS: @(#) $Id: base32.tcl,v 1.2 2006/10/13 05:39:49 andreas_kupries Exp $
+
+# @mdgen EXCLUDE: base32_c.tcl
+
+package require Tcl 8.4
+
+namespace eval ::base32 {}
+
+# ### ### ### ######### ######### #########
+## Management of base32 std implementations.
+
+# ::base32::LoadAccelerator --
+#
+# Loads a named implementation, if possible.
+#
+# Arguments:
+# key Name of the implementation to load.
+#
+# Results:
+# A boolean flag. True if the implementation
+# was successfully loaded; and False otherwise.
+
+proc ::base32::LoadAccelerator {key} {
+ variable accel
+ set isok 0
+ switch -exact -- $key {
+ critcl {
+ # Critcl implementation of base32 requires Tcl 8.4.
+ if {![package vsatisfies [package provide Tcl] 8.4]} {return 0}
+ if {[catch {package require tcllibc}]} {return 0}
+ set isok [llength [info commands ::base32::critcl_encode]]
+ }
+ tcl {
+ variable selfdir
+ if {[catch {source [file join $selfdir base32_tcl.tcl]}]} {return 0}
+ set isok [llength [info commands ::base32::tcl_encode]]
+ }
+ default {
+ return -code error "invalid accelerator $key:\
+ must be one of [join [KnownImplementations] {, }]"
+ }
+ }
+ set accel($key) $isok
+ return $isok
+}
+
+# ::base32::SwitchTo --
+#
+# Activates a loaded named implementation.
+#
+# Arguments:
+# key Name of the implementation to activate.
+#
+# Results:
+# None.
+
+proc ::base32::SwitchTo {key} {
+ variable accel
+ variable loaded
+
+ if {[string equal $key $loaded]} {
+ # No change, nothing to do.
+ return
+ } elseif {![string equal $key ""]} {
+ # Validate the target implementation of the switch.
+
+ if {![info exists accel($key)]} {
+ return -code error "Unable to activate unknown implementation \"$key\""
+ } elseif {![info exists accel($key)] || !$accel($key)} {
+ return -code error "Unable to activate missing implementation \"$key\""
+ }
+ }
+
+ # Deactivate the previous implementation, if there was any.
+
+ if {![string equal $loaded ""]} {
+ foreach c {encode decode} {
+ rename ::base32::$c ::base32::${loaded}_$c
+ }
+ }
+
+ # Activate the new implementation, if there is any.
+
+ if {![string equal $key ""]} {
+ foreach c {encode decode} {
+ rename ::base32::${key}_$c ::base32::$c
+ }
+ }
+
+ # Remember the active implementation, for deactivation by future
+ # switches.
+
+ set loaded $key
+ return
+}
+
+# ::base32::Implementations --
+#
+# Determines which implementations are
+# present, i.e. loaded.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A list of implementation keys.
+
+proc ::base32::Implementations {} {
+ variable accel
+ set res {}
+ foreach n [array names accel] {
+ if {!$accel($n)} continue
+ lappend res $n
+ }
+ return $res
+}
+
+# ::base32::KnownImplementations --
+#
+# Determines which implementations are known
+# as possible implementations.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A list of implementation keys. In the order
+# of preference, most prefered first.
+
+proc ::base32::KnownImplementations {} {
+ return {critcl tcl}
+}
+
+proc ::base32::Names {} {
+ return {
+ critcl {tcllibc based}
+ tcl {pure Tcl}
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Initialization: Data structures.
+
+namespace eval ::base32 {
+ variable selfdir [file dirname [info script]]
+ variable loaded {}
+
+ variable accel
+ array set accel {tcl 0 critcl 0}
+}
+
+# ### ### ### ######### ######### #########
+## Initialization: Choose an implementation,
+## most prefered first. Loads only one of the
+## possible implementations. And activates it.
+
+namespace eval ::base32 {
+ variable e
+ foreach e [KnownImplementations] {
+ if {[LoadAccelerator $e]} {
+ SwitchTo $e
+ break
+ }
+ }
+ unset e
+
+ namespace export encode decode
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide base32 0.1
diff --git a/tcllib/modules/base32/base32.test b/tcllib/modules/base32/base32.test
new file mode 100644
index 0000000..445fdd1
--- /dev/null
+++ b/tcllib/modules/base32/base32.test
@@ -0,0 +1,38 @@
+# -*- tcl -*- Tests for "base32"
+# This testsuite is in the public domain.
+#__________________________________________
+# RCS: @(#) $Id: base32.test,v 1.4 2008/03/22 23:46:42 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.1
+
+testing {
+ useLocal base32core.tcl base32::core
+ useTcllibC
+ useLocalKeep base32.tcl base32
+ TestAccelInit base32
+}
+
+set tests [localPath base32.testsuite]
+
+# -------------------------------------------------------------------------
+
+# The global variable 'impl' is part of the public API the testsuite
+# (in base32.testsuite) does expect from the environment.
+
+TestAccelDo base32 impl {
+ source $tests
+}
+
+# -------------------------------------------------------------------------
+
+unset tests
+TestAccelExit base32
+testsuiteCleanup
+return
diff --git a/tcllib/modules/base32/base32.testsuite b/tcllib/modules/base32/base32.testsuite
new file mode 100644
index 0000000..ce816d1
--- /dev/null
+++ b/tcllib/modules/base32/base32.testsuite
@@ -0,0 +1,156 @@
+# -*- tcl -*-
+# base32.testsuite: tests for std base32.
+#
+# Public domain
+#
+# RCS: @(#) $Id: base32.testsuite,v 1.1 2006/05/27 20:44:36 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+::tcltest::testConstraint base32_critcl [string equal $impl critcl]
+
+# -------------------------------------------------------------------------
+
+test base32-${impl}-1.0 {Encode, wrong#args} -body {
+ ::base32::encode
+} -returnCodes error -result {wrong # args: should be "::base32::encode bitstring"}
+
+test base32-${impl}-1.1 {Encode, wrong#args} -body {
+ ::base32::encode a b
+} -returnCodes error -result {wrong # args: should be "::base32::encode bitstring"}
+
+# -------------------------------------------------------------------------
+
+test base32-${impl}-2.0 {Decode, wrong#args} -body {
+ ::base32::decode
+} -returnCodes error -result {wrong # args: should be "::base32::decode estring"}
+
+test base32-${impl}-2.1 {Decode, wrong#args} -body {
+ ::base32::decode a b
+} -returnCodes error -result {wrong # args: should be "::base32::decode estring"}
+
+# -------------------------------------------------------------------------
+# 0 .. 6 are the official test vectors from RFC 3548
+# 7 .. 12 are the vectors I fot previous, non-conforming,
+# implementation, updated for conformance.
+# 13 .. are new vectors to cover the whole range of bytes
+
+# 4-0 00100 000
+# 4-0-16-0 00100 00000 10000 0
+# 4-0-16-2-0 00100 00000 10000 00010 0000
+# 4-0-16-2-0-8-0 00100 00000 10000 00010 00000 01000 00
+# 4-0-16-2-0-8-1-0 00100 00000 10000 00010 00000 01000 00001 00000
+
+foreach {n text encoded} {
+ 0 {} {}
+ 1 f MY======
+ 2 fo MZXQ====
+ 3 foo MZXW6===
+ 4 foob MZXW6YQ=
+ 5 fooba MZXW6YTB
+ 6 foobar MZXW6YTBOI======
+ - - -
+ 7 { } EA======
+ 8 { } EAQA====
+ 9 { } EAQCA===
+ 10 { } EAQCAIA=
+ 11 { } EAQCAIBA
+ 12 { } EAQCAIBAEA======
+ - - - - - - - - - - - -
+ 20 \000 AA====== 28 \010 BA====== 36 \020 CA====== 44 \030 DA======
+ 21 \001 AE====== 29 \011 BE====== 37 \021 CE====== 45 \031 DE======
+ 22 \002 AI====== 30 \012 BI====== 38 \022 CI====== 46 \032 DI======
+ 23 \003 AM====== 31 \013 BM====== 39 \023 CM====== 47 \033 DM======
+ 24 \004 AQ====== 32 \014 BQ====== 40 \024 CQ====== 48 \034 DQ======
+ 25 \005 AU====== 33 \015 BU====== 41 \025 CU====== 49 \035 DU======
+ 26 \006 AY====== 34 \016 BY====== 42 \026 CY====== 50 \036 DY======
+ 27 \007 A4====== 35 \017 B4====== 43 \027 C4====== 51 \037 D4======
+ - - - - - - - - - - - -
+ 52 \040 EA====== 60 \050 FA====== 68 \060 GA====== 76 \070 HA======
+ 53 \041 EE====== 61 \051 FE====== 69 \061 GE====== 77 \071 HE======
+ 54 \042 EI====== 62 \052 FI====== 70 \062 GI====== 78 \072 HI======
+ 55 \043 EM====== 63 \053 FM====== 71 \063 GM====== 79 \073 HM======
+ 56 \044 EQ====== 64 \054 FQ====== 72 \064 GQ====== 80 \074 HQ======
+ 57 \045 EU====== 65 \055 FU====== 73 \065 GU====== 81 \075 HU======
+ 58 \046 EY====== 66 \056 FY====== 74 \066 GY====== 82 \076 HY======
+ 59 \047 E4====== 67 \057 F4====== 75 \067 G4====== 83 \077 H4======
+ - - - - - - - - - - - -
+ a0 \100 IA====== a8 \110 JA====== b6 \120 KA====== c4 \130 LA======
+ a1 \101 IE====== a9 \111 JE====== b7 \121 KE====== c5 \131 LE======
+ a2 \102 II====== b0 \112 JI====== b8 \122 KI====== c6 \132 LI======
+ a3 \103 IM====== b1 \113 JM====== b9 \123 KM====== c7 \133 LM======
+ a4 \104 IQ====== b2 \114 JQ====== c0 \124 KQ====== c8 \134 LQ======
+ a5 \105 IU====== b3 \115 JU====== c1 \125 KU====== c9 \135 LU======
+ a6 \106 IY====== b4 \116 JY====== c2 \126 KY====== d0 \136 LY======
+ a7 \107 I4====== b5 \117 J4====== c3 \127 K4====== d1 \137 L4======
+ - - - - - - - - - - - -
+ d2 \140 MA====== e0 \150 NA====== e8 \160 OA====== f6 \170 PA======
+ d3 \141 ME====== e1 \151 NE====== e9 \161 OE====== f7 \171 PE======
+ d4 \142 MI====== e2 \152 NI====== f0 \162 OI====== f8 \172 PI======
+ d5 \143 MM====== e3 \153 NM====== f1 \163 OM====== f9 \173 PM======
+ d6 \144 MQ====== e4 \154 NQ====== f2 \164 OQ====== g0 \174 PQ======
+ d7 \145 MU====== e5 \155 NU====== f3 \165 OU====== g1 \175 PU======
+ d8 \146 MY====== e6 \156 NY====== f4 \166 OY====== g2 \176 PY======
+ d9 \147 M4====== e7 \157 N4====== f5 \167 O4====== g3 \177 P4======
+ - - - - - - - - - - - -
+ h0 \200 QA====== h8 \210 RA====== i6 \220 SA====== j4 \230 TA======
+ h1 \201 QE====== h9 \211 RE====== i7 \221 SE====== j5 \231 TE======
+ h2 \202 QI====== i0 \212 RI====== i8 \222 SI====== j6 \232 TI======
+ h3 \203 QM====== i1 \213 RM====== i9 \223 SM====== j7 \233 TM======
+ h4 \204 QQ====== i2 \214 RQ====== j0 \224 SQ====== j8 \234 TQ======
+ h5 \205 QU====== i3 \215 RU====== j1 \225 SU====== j9 \235 TU======
+ h6 \206 QY====== i4 \216 RY====== j2 \226 SY====== k0 \236 TY======
+ h7 \207 Q4====== i5 \217 R4====== j3 \227 S4====== k1 \237 T4======
+ - - - - - - - - - - - -
+ k2 \240 UA====== l0 \250 VA====== l8 \260 WA====== m6 \270 XA======
+ k3 \241 UE====== l1 \251 VE====== l9 \261 WE====== m7 \271 XE======
+ k4 \242 UI====== l2 \252 VI====== m0 \262 WI====== m8 \272 XI======
+ k5 \243 UM====== l3 \253 VM====== m1 \263 WM====== m9 \273 XM======
+ k6 \244 UQ====== l4 \254 VQ====== m2 \264 WQ====== n0 \274 XQ======
+ k7 \245 UU====== l5 \255 VU====== m3 \265 WU====== n1 \275 XU======
+ k8 \246 UY====== l6 \256 VY====== m4 \266 WY====== n2 \276 XY======
+ k9 \247 U4====== l7 \257 V4====== m5 \267 W4====== n3 \277 X4======
+ - - - - - - - - - - - -
+ o0 \300 YA====== o8 \310 ZA====== p6 \320 2A====== q4 \330 3A======
+ o1 \301 YE====== o9 \311 ZE====== p7 \321 2E====== q5 \331 3E======
+ o2 \302 YI====== p0 \312 ZI====== p8 \322 2I====== q6 \332 3I======
+ o3 \303 YM====== p1 \313 ZM====== p9 \323 2M====== q7 \333 3M======
+ o4 \304 YQ====== p2 \314 ZQ====== q0 \324 2Q====== q8 \334 3Q======
+ o5 \305 YU====== p3 \315 ZU====== q1 \325 2U====== q9 \335 3U======
+ o6 \306 YY====== p4 \316 ZY====== q2 \326 2Y====== r0 \336 3Y======
+ o7 \307 Y4====== p5 \317 Z4====== q3 \327 24====== r1 \337 34======
+ - - - - - - - - - - - -
+ r2 \340 4A====== s0 \350 5A====== s8 \360 6A====== t6 \370 7A======
+ r3 \341 4E====== s1 \351 5E====== s9 \361 6E====== t7 \371 7E======
+ r4 \342 4I====== s2 \352 5I====== t0 \362 6I====== t8 \372 7I======
+ r5 \343 4M====== s3 \353 5M====== t1 \363 6M====== t9 \373 7M======
+ r6 \344 4Q====== s4 \354 5Q====== t2 \364 6Q====== u0 \374 7Q======
+ r7 \345 4U====== s5 \355 5U====== t3 \365 6U====== u1 \375 7U======
+ r8 \346 4Y====== s6 \356 5Y====== t4 \366 6Y====== u2 \376 7Y======
+ r9 \347 44====== s7 \357 54====== t5 \367 64====== u3 \377 74======
+} {
+ if {$n == "-"} continue
+ test base32-${impl}-3.$n "Encode \"$text\"" -body {
+ ::base32::encode $text
+ } -result $encoded ; # {}
+
+ test base32-${impl}-4.$n "Decode \"$encoded\"" -body {
+ ::base32::decode $encoded
+ } -result $text ; # {}
+}
+
+# -------------------------------------------------------------------------
+# Decoder stress testing bad input
+
+foreach {n input message} {
+ 0 abcde0aa {Invalid character at index 5: "0"}
+ 1 A {Length is not a multiple of 8}
+ 2 ABCDEFG {Length is not a multiple of 8}
+ 3 A======= {Invalid padding of length 7}
+ 4 ACA===== {Invalid padding of length 5}
+ 5 A=CA==== {Invalid character at index 1: "=" (padding found in the middle of the input)}
+} {
+ test base32-${impl}-5.$n "Decode, bad input \"$input\"" -body {
+ ::base32::decode $input
+ } -returnCodes error -result $message ; # {}
+}
diff --git a/tcllib/modules/base32/base32_c.tcl b/tcllib/modules/base32/base32_c.tcl
new file mode 100644
index 0000000..333d73b
--- /dev/null
+++ b/tcllib/modules/base32/base32_c.tcl
@@ -0,0 +1,253 @@
+# base32c.tcl --
+#
+# Implementation of a base32 (std) de/encoder for Tcl.
+#
+# Public domain
+#
+# RCS: @(#) $Id: base32_c.tcl,v 1.3 2008/01/28 22:58:18 andreas_kupries Exp $
+
+package require critcl
+package require Tcl 8.4
+
+namespace eval ::base32 {
+ # Supporting code for the main command.
+ catch {
+ #critcl::cheaders -g
+ #critcl::debug memory symbols
+ }
+
+ # Main commands, encoder & decoder
+
+ critcl::ccommand critcl_encode {dummy interp objc objv} {
+ /* Syntax -*- c -*-
+ * critcl_encode string
+ */
+
+ unsigned char* buf;
+ int nbuf;
+
+ unsigned char* out;
+ unsigned char* at;
+ int nout;
+
+ /*
+ * The array used for encoding
+ */ /* 123456789 123456789 123456789 12 */
+ static const char map[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567";
+
+#define USAGEE "bitstring"
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 1, objv, USAGEE);
+ return TCL_ERROR;
+ }
+
+ buf = Tcl_GetByteArrayFromObj (objv[1], &nbuf);
+ nout = ((nbuf+4)/5)*8;
+ out = (unsigned char*) Tcl_Alloc (nout*sizeof(char));
+
+ for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) {
+ *(at++) = map [ (buf[0]>>3) ];
+ *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+ *(at++) = map [ 0x1f & (buf[1]>>1) ];
+ *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
+ *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
+ *(at++) = map [ 0x1f & (buf[3]>>2) ];
+ *(at++) = map [ 0x1f & ((buf[3]<<3) | (buf[4]>>5)) ];
+ *(at++) = map [ 0x1f & (buf[4]) ];
+ }
+ if (nbuf > 0) {
+ /* Process partials at end. */
+ switch (nbuf) {
+ case 1:
+ /* |01234567| 2, padding 6
+ * xxxxx
+ * xxx 00
+ */
+
+ *(at++) = map [ (buf[0]>>3) ];
+ *(at++) = map [ 0x1f & (buf[0]<<2) ];
+ *(at++) = '=';
+ *(at++) = '=';
+ *(at++) = '=';
+ *(at++) = '=';
+ *(at++) = '=';
+ *(at++) = '=';
+ break;
+ case 2: /* x3/=4 */
+ /* |01234567|01234567| 4, padding 4
+ * xxxxx
+ * xxx xx
+ * xxxxx
+ * x 0000
+ */
+
+ *(at++) = map [ (buf[0]>>3) ];
+ *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+ *(at++) = map [ 0x1f & (buf[1]>>1) ];
+ *(at++) = map [ 0x1f & (buf[1]<<4) ];
+ *(at++) = '=';
+ *(at++) = '=';
+ *(at++) = '=';
+ *(at++) = '=';
+ break;
+ case 3:
+ /* |01234567|01234567|01234567| 5, padding 3
+ * xxxxx
+ * xxx xx
+ * xxxxx
+ * x xxxx
+ * xxxx 0
+ */
+
+ *(at++) = map [ (buf[0]>>3) ];
+ *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+ *(at++) = map [ 0x1f & (buf[1]>>1) ];
+ *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
+ *(at++) = map [ 0x1f & (buf[2]<<1) ];
+ *(at++) = '=';
+ *(at++) = '=';
+ *(at++) = '=';
+ break;
+ case 4:
+ /* |01234567|01234567|01234567|012334567| 7, padding 1
+ * xxxxx
+ * xxx xx
+ * xxxxx
+ * x xxxx
+ * xxxx
+ * xxxxx
+ * xxxx 0
+ */
+
+ *(at++) = map [ (buf[0]>>3) ];
+ *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+ *(at++) = map [ 0x1f & (buf[1]>>1) ];
+ *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
+ *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
+ *(at++) = map [ 0x1f & (buf[3]>>2) ];
+ *(at++) = map [ 0x1f & (buf[3]<<3) ];
+ *(at++) = '=';
+ break;
+ }
+ }
+
+ Tcl_SetObjResult (interp, Tcl_NewStringObj ((char*)out, nout));
+ Tcl_Free ((char*) out);
+ return TCL_OK;
+ }
+
+
+ critcl::ccommand critcl_decode {dummy interp objc objv} {
+ /* Syntax -*- c -*-
+ * critcl_decode estring
+ */
+
+ unsigned char* buf;
+ int nbuf;
+
+ unsigned char* out;
+ unsigned char* at;
+ unsigned char x [8];
+ int nout;
+
+ int i, j, a, pad, nx;
+
+ /*
+ * An array for translating single base-32 characters into a value.
+ * Disallowed input characters have a value of 64. Upper and lower
+ * case is the same. Only 128 chars, as everything above char(127)
+ * is 64.
+ */
+ static const char map [] = {
+ /* \00 */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ /* DLE */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ /* SPC */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ /* '0' */ 64, 64, 26, 27, 28, 29, 30, 31, 64, 64, 64, 64, 64, 64, 64, 64,
+ /* '@' */ 64, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
+ /* 'P' */ 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 64, 64, 64, 64, 64,
+ /* '`' */ 64, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
+ /* 'p' */ 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 64, 64, 64, 64, 64
+ };
+
+#define USAGED "estring"
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 1, objv, USAGED);
+ return TCL_ERROR;
+ }
+
+ buf = (unsigned char*) Tcl_GetStringFromObj (objv[1], &nbuf);
+
+ if (nbuf % 8) {
+ Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1));
+ return TCL_ERROR;
+ }
+
+ nout = (nbuf/8)*5 *TCL_UTF_MAX;
+ out = (unsigned char*) Tcl_Alloc (nout*sizeof(char));
+
+#define HIGH(x) (((x) & 0x80) != 0)
+#define BADC(x) ((x) == 64)
+#define BADCHAR(a,j) (HIGH ((a)) || BADC (x [(j)] = map [(a)]))
+
+ for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){
+ for (j=0; j < 8; j++){
+ a = buf [j];
+
+ if (a == '=') {
+ x[j] = 0;
+ pad++;
+ continue;
+ } else if (pad) {
+ char msg [120];
+ sprintf (msg,
+ "Invalid character at index %d: \"=\" (padding found in the middle of the input)",
+ j-1);
+ Tcl_Free ((char*) out);
+ Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
+ return TCL_ERROR;
+ }
+
+ if (BADCHAR (a,j)) {
+ char msg [100];
+ sprintf (msg,"Invalid character at index %d: \"%c\"",j,a);
+ Tcl_Free ((char*) out);
+ Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
+ return TCL_ERROR;
+ }
+ }
+
+ *(at++) = (x[0]<<3) | (x[1]>>2) ;
+ *(at++) = (x[1]<<6) | (x[2]<<1) | (x[3]>>4);
+ *(at++) = (x[3]<<4) | (x[4]>>1) ;
+ *(at++) = (x[4]<<7) | (x[5]<<2) | (x[6]>>3);
+ *(at++) = (x[6]<<5) | x[7] ;
+ }
+
+ if (pad) {
+ if (pad == 1) {
+ at -= 1;
+ } else if (pad == 3) {
+ at -= 2;
+ } else if (pad == 4) {
+ at -= 3;
+ } else if (pad == 6) {
+ at -= 4;
+ } else {
+ char msg [100];
+ sprintf (msg,"Invalid padding of length %d",pad);
+ Tcl_Free ((char*) out);
+ Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
+ return TCL_ERROR;
+ }
+ }
+
+ Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out));
+ Tcl_Free ((char*) out);
+ return TCL_OK;
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Ready
diff --git a/tcllib/modules/base32/base32_core.pcx b/tcllib/modules/base32/base32_core.pcx
new file mode 100644
index 0000000..58feb26
--- /dev/null
+++ b/tcllib/modules/base32/base32_core.pcx
@@ -0,0 +1,44 @@
+# -*- tcl -*- base32::core.pcx
+# Syntax of the commands provided by package base32::core.
+#
+# 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 base32::core
+pcx::tcldep 0.1 needs tcl 8.4
+
+namespace eval ::base32::core {}
+
+pcx::message invalidStringLength {String is not a multiple of 8 characters long} err
+
+pcx::check 0.1 std ::base32::core::define \
+ {checkSimpleArgs 4 4 {
+ checkDict
+ checkVarNameWrite
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 0.1 std ::base32::core::valid \
+ {checkSimpleArgs 3 3 {
+ base32::core::checkEString
+ checkRegexp
+ checkVarNameWrite
+ }}
+
+proc base32::core::checkEString {t i} {
+ set w [lindex $t $i]
+ if {[getLiteral $w str]} {
+ if {[string length $str] % 8 != 0} {
+ logError base32::core::invalidStringLength [getTokenRange $w]
+ }
+ }
+ return [checkWord $t $i]
+}
+
+# Initialization via pcx::init.
+# Use a ::base32::core::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/base32/base32_hex.pcx b/tcllib/modules/base32/base32_hex.pcx
new file mode 100644
index 0000000..54bb193
--- /dev/null
+++ b/tcllib/modules/base32/base32_hex.pcx
@@ -0,0 +1,40 @@
+# -*- tcl -*- base32::hex.pcx
+# Syntax of the commands provided by package base32::hex.
+#
+# 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 base32::hex
+pcx::tcldep 0.1 needs tcl 8.4
+
+namespace eval ::base32::hex {}
+
+pcx::message invalidStringLength {String is not a multiple of 8 characters long} err
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 0.1 std ::base32::hex::decode \
+ {checkSimpleArgs 0 -1 {
+ base32::hex::checkEString
+ }}
+pcx::check 0.1 std ::base32::hex::encode \
+ {checkSimpleArgs 0 -1 {
+
+ }}
+
+proc base32::hex::checkEString {t i} {
+ set w [lindex $t $i]
+ if {[getLiteral $w str]} {
+ if {[string length $str] % 8 != 0} {
+ logError base32::hex::invalidStringLength [getTokenRange $w]
+ }
+ }
+ return [checkWord $t $i]
+}
+
+# Initialization via pcx::init.
+# Use a ::base32::hex::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/base32/base32_tcl.tcl b/tcllib/modules/base32/base32_tcl.tcl
new file mode 100644
index 0000000..a8d5033
--- /dev/null
+++ b/tcllib/modules/base32/base32_tcl.tcl
@@ -0,0 +1,73 @@
+# -*- tcl -*-
+# This code is hereby put into the public domain.
+# ### ### ### ######### ######### #########
+## Overview
+# Base32 encoding and decoding of small strings.
+
+# ### ### ### ######### ######### #########
+## Notes
+
+# A binary string is split into groups of 5 bits (2^5 == 32), and each
+# group is converted into a printable character as is specified in RFC
+# 3548.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require base32::core
+namespace eval ::base32 {}
+
+# ### ### ### ######### ######### #########
+## API & Implementation
+
+proc ::base32::tcl_encode {bitstring} {
+ variable forward
+
+ binary scan $bitstring B* bits
+ set len [string length $bits]
+ set rem [expr {$len % 5}]
+ if {$rem} {append bits =/$rem}
+ #puts "($bitstring) => <$bits>"
+
+ return [string map $forward $bits]
+}
+
+proc ::base32::tcl_decode {estring} {
+ variable backward
+ variable invalid
+
+ if {![core::valid $estring $invalid msg]} {
+ return -code error $msg
+ }
+ #puts "I<$estring>"
+ #puts "M<[string map $backward $estring]>"
+
+ return [binary format B* [string map $backward [string toupper $estring]]]
+}
+
+# ### ### ### ######### ######### #########
+## Data structures
+
+namespace eval ::base32 {
+ # Initialize the maps
+ variable forward
+ variable backward
+ variable invalid
+
+ core::define {
+ 0 A 9 J 18 S 27 3
+ 1 B 10 K 19 T 28 4
+ 2 C 11 L 20 U 29 5
+ 3 D 12 M 21 V 30 6
+ 4 E 13 N 22 W 31 7
+ 5 F 14 O 23 X
+ 6 G 15 P 24 Y
+ 7 H 16 Q 25 Z
+ 8 I 17 R 26 2
+ } forward backward invalid ; # {}
+ # puts ///$forward///
+ # puts ///$backward///
+}
+
+# ### ### ### ######### ######### #########
+## Ok
diff --git a/tcllib/modules/base32/base32core.man b/tcllib/modules/base32/base32core.man
new file mode 100644
index 0000000..150b754
--- /dev/null
+++ b/tcllib/modules/base32/base32core.man
@@ -0,0 +1,66 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin base32::core n 0.1]
+[keywords base32]
+[copyright {Public domain}]
+[moddesc {Base32 encoding}]
+[titledesc {Expanding basic base32 maps}]
+[category {Text processing}]
+[require Tcl 8.4]
+[require base32::core [opt 0.1]]
+[description]
+[para]
+
+This package provides generic commands for the construction of full
+base32 mappings from a basic mapping listing just the codes and
+associated characters. The full mappings, regular and inverse, created
+here map to and from bit sequences, and also handle the partial
+mappings at the end of a string.
+
+[para]
+
+This is in essence an internal package to be used by implementors of a
+base32 en- and decoder. A regular user has no need of this package at
+all.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::base32::core::define] [arg map] [arg forwvar] [arg backwvar] [arg ivar]]
+
+This command computes full forward and backward (inverse) mappings
+from the basic [arg map] and stores them in the variables named by
+[arg forwvar] and [arg backwvar] resp. It also constructs a regexp
+pattern for the detection of invalid characters in supposedly base32
+encoded input and stores it in the variable named by [arg ivar].
+
+[call [cmd ::base32::core::valid] [arg string] [arg pattern] [arg mvar]]
+
+This command checks if the input [arg string] is a valid base32
+encoded string, based on the [arg pattern] of invalid characters as
+generated by [cmd ::base32::core::define], and some other general
+rules.
+
+[para]
+
+The result of the command is a boolean flag. Its value is [const True]
+for a valid [arg string], and [const False] otherwise. In the latter
+case an error message describing the problem with the input is stored
+into the variable named by [arg mvar]. The variable is not touched if
+the input was found to be valid.
+
+[para]
+
+The rules checked by the command, beyond rejection of bad characters,
+are:
+
+[list_begin enumerated]
+[enum] The length of the input is not a multiple of eight,
+[enum] The padding appears not at the end of input, but in the middle,
+[enum] The padding has not of length six, four, three, or one characters,
+[list_end]
+[list_end]
+
+[vset CATEGORY base32]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/base32/base32core.tcl b/tcllib/modules/base32/base32core.tcl
new file mode 100644
index 0000000..aaf7fc8
--- /dev/null
+++ b/tcllib/modules/base32/base32core.tcl
@@ -0,0 +1,134 @@
+# -*- tcl -*-
+# This code is hereby put into the public domain.
+# ### ### ### ######### ######### #########
+#= Overview
+
+# Fundamental handling of base32 conversion tables. Expansion of a
+# basic mapping into a full mapping and its inverse mapping.
+
+# ### ### ### ######### ######### #########
+#= Requisites
+
+namespace eval ::base32::core {}
+
+# ### ### ### ######### ######### #########
+#= API & Implementation
+
+proc ::base32::core::define {map fv bv iv} {
+ variable bits
+ upvar 1 $fv forward $bv backward $iv invalid
+
+ # bytes - bits - padding - tail | bits - padding - tail
+ # 0 - 0 - "" - "xxxxxxxx" | 0 - "" - ""
+ # 1 - 8 - "======" - "xx======" | 3 - "======" - "x======"
+ # 2 - 16 - "====" - "xxxx====" | 1 - "====" - "x===="
+ # 3 - 24 - "===" - "xxxxx===" | 4 - "===" - "x==="
+ # 4 - 32 - "=" - "xxxxxxx=" | 2 - "=" - "x="
+
+ array set _ $bits
+
+ set invalid "\[^="
+ set forward {}
+ set btmp {}
+
+ foreach {code char} $map {
+ set b $_($code)
+
+ append invalid [string tolower $char][string toupper $char]
+
+ # 5 bit remainder
+ lappend forward $b $char
+ lappend btmp [list $char $b]
+
+ # 4 bit remainder
+ if {$code%2} continue
+ set b [string range $b 0 end-1]
+ lappend forward ${b}=/4 ${char}===
+ lappend btmp [list ${char}=== $b]
+
+ # 3 bit remainder
+ if {$code%4} continue
+ set b [string range $b 0 end-1]
+ lappend forward ${b}=/3 ${char}======
+ lappend btmp [list ${char}====== $b]
+
+ # 2 bit remainder
+ if {$code%8} continue
+ set b [string range $b 0 end-1]
+ lappend forward ${b}=/2 ${char}=
+ lappend btmp [list ${char}= $b]
+
+ # 1 bit remainder
+ if {$code%16} continue
+ set b [string range $b 0 end-1]
+ lappend forward ${b}=/1 ${char}====
+ lappend btmp [list ${char}==== $b]
+ }
+
+ set backward {}
+ foreach item [lsort -index 0 -decreasing $btmp] {
+ foreach {c b} $item break
+ lappend backward $c $b
+ }
+
+ append invalid "\]"
+ return
+}
+
+proc ::base32::core::valid {estring pattern mv} {
+ upvar 1 $mv message
+
+ if {[string length $estring] % 8} {
+ set message "Length is not a multiple of 8"
+ return 0
+ } elseif {[regexp -indices $pattern $estring where]} {
+ foreach {s e} $where break
+ set message "Invalid character at index $s: \"[string index $estring $s]\""
+ return 0
+ } elseif {[regexp {(=+)$} $estring -> pad]} {
+ set padlen [string length $pad]
+ if {
+ ($padlen != 6) &&
+ ($padlen != 4) &&
+ ($padlen != 3) &&
+ ($padlen != 1)
+ } {
+ set message "Invalid padding of length $padlen"
+ return 0
+ }
+ }
+
+ # Remove the brackets and ^= from the pattern, to construct the
+ # class of valid characters which must not follow the padding.
+
+ set badp "=\[[string range $pattern 3 end-1]\]"
+ if {[regexp -indices $badp $estring where]} {
+ foreach {s e} $where break
+ set message "Invalid character at index $s: \"[string index $estring $s]\" (padding found in the middle of the input)"
+ return 0
+ }
+ return 1
+}
+
+# ### ### ### ######### ######### #########
+## Data structures
+
+namespace eval ::base32::core {
+ namespace export define valid
+
+ variable bits {
+ 0 00000 1 00001 2 00010 3 00011
+ 4 00100 5 00101 6 00110 7 00111
+ 8 01000 9 01001 10 01010 11 01011
+ 12 01100 13 01101 14 01110 15 01111
+ 16 10000 17 10001 18 10010 19 10011
+ 20 10100 21 10101 22 10110 23 10111
+ 24 11000 25 11001 26 11010 27 11011
+ 28 11100 29 11101 30 11110 31 11111
+ }
+}
+
+# ### ### ### ######### ######### #########
+#= Registration
+
+package provide base32::core 0.1
diff --git a/tcllib/modules/base32/base32hex.bench b/tcllib/modules/base32/base32hex.bench
new file mode 100644
index 0000000..47d5c44
--- /dev/null
+++ b/tcllib/modules/base32/base32hex.bench
@@ -0,0 +1,87 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'base32' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# Public domain
+
+# We need at least version 8.4 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.4]} return
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+package forget base32::hex
+package forget base32::core
+catch {namespace delete ::base32}
+
+set self [file join [pwd] [file dirname [info script]]]
+set index [file join [file dirname $self] tcllibc pkgIndex.tcl]
+
+if {[file exists $index]} {
+ set ::dir [file dirname $index]
+ uplevel #0 [list source $index]
+ unset ::dir
+ package require tcllibc
+}
+
+source [file join $self base32core.tcl]
+source [file join $self base32hex.tcl]
+
+set bytes \000\010\020\030\001\011\021\031\002\012\022\032\003\013\023\033
+append bytes \004\014\024\034\005\015\025\035\006\016\026\036\007\017\027\037
+append bytes \040\050\060\070\041\051\061\071\042\052\062\072\043\053\063\073
+append bytes \044\054\064\074\045\055\065\075\046\056\066\076\047\057\067\077
+append bytes \100\110\120\130\101\111\121\131\102\112\122\132\103\113\123\133
+append bytes \104\114\124\134\105\115\125\135\106\116\126\136\107\117\127\137
+append bytes \140\150\160\170\141\151\161\171\142\152\162\172\143\153\163\173
+append bytes \144\154\164\174\145\155\165\175\146\156\166\176\147\157\167\177
+append bytes \200\210\220\230\201\211\221\231\202\212\222\232\203\213\223\233
+append bytes \204\214\224\234\205\215\225\235\206\216\226\236\207\217\227\237
+append bytes \240\250\260\270\241\251\261\271\242\252\262\272\243\253\263\273
+append bytes \244\254\264\274\245\255\265\275\246\256\266\276\247\257\267\277
+append bytes \300\310\320\330\301\311\321\331\302\312\322\332\303\313\323\333
+append bytes \304\314\324\334\305\315\325\335\306\316\326\336\307\317\327\337
+append bytes \340\350\360\370\341\351\361\371\342\352\362\372\343\353\363\373
+append bytes \344\354\364\374\345\355\365\375\346\356\366\376\347\357\367\377
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+base32::hex::SwitchTo {}
+foreach e [base32::hex::KnownImplementations] {
+ ::base32::hex::LoadAccelerator $e
+}
+
+foreach impl [base32::hex::Implementations] {
+ base32::hex::SwitchTo $impl
+
+ foreach rem {0 1 2 3 4} {
+ foreach len {0 10 100 1000 10000} {
+ set blen $len
+ incr blen $rem
+
+ set blanks [string repeat { } $blen]
+ set identic [string repeat A $blen]
+ set sbytes [string range [string repeat $bytes [expr {1+$blen/256}]] 0 [expr {$blen - 1}]]
+
+ bench -desc "base32-hex-${impl}-enc-$rem/${len} blanks" -body {base32::hex::encode $blanks}
+ bench -desc "base32-hex-${impl}-enc-$rem/${len} identi" -body {base32::hex::encode $identic}
+ bench -desc "base32-hex-${impl}-enc-$rem/${len} sbytes" -body {base32::hex::encode $sbytes}
+
+ set blanks [base32::hex::encode $blanks]
+ set identic [base32::hex::encode $identic]
+ set sbytes [base32::hex::encode $sbytes]
+
+ bench -desc "base32-hex-${impl}-dec-$rem/${len} blanks" -body {base32::hex::decode $blanks}
+ bench -desc "base32-hex-${impl}-dec-$rem/${len} identi" -body {base32::hex::decode $identic}
+ bench -desc "base32-hex-${impl}-dec-$rem/${len} sbytes" -body {base32::hex::decode $sbytes}
+ }
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/base32/base32hex.man b/tcllib/modules/base32/base32hex.man
new file mode 100644
index 0000000..d38e001
--- /dev/null
+++ b/tcllib/modules/base32/base32hex.man
@@ -0,0 +1,78 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin base32::hex n 0.1]
+[keywords base32]
+[keywords hex]
+[keywords rfc3548]
+[copyright {Public domain}]
+[moddesc {Base32 encoding}]
+[titledesc {base32 extended hex encoding}]
+[category {Text processing}]
+[require Tcl 8.4]
+[require base32::core [opt 0.1]]
+[require base32::hex [opt 0.1]]
+[description]
+[para]
+
+This package provides commands for encoding and decoding of strings
+into and out of the extended hex base32 encoding as specified in the
+RFC 3548bis draft.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::base32::hex::encode] [arg string]]
+
+This command encodes the given [arg string] in extended hex base32 and
+returns the encoded string as its result. The result may be padded
+with the character [const =] to signal a partial encoding at the end
+of the input string.
+
+[call [cmd ::base32::hex::decode] [arg estring]]
+
+This commands takes the [arg estring] and decodes it under the
+assumption that it is a valid extended hex base32 encoded string. The
+result of the decoding is returned as the result of the command.
+
+[para]
+
+Note that while the encoder will generate only uppercase characters
+this decoder accepts input in lowercase as well.
+
+[para]
+
+The command will always throw an error whenever encountering
+conditions which signal some type of bogus input, namely if
+
+[list_begin enumerated]
+[enum] the input contains characters which are not valid output
+ of a extended hex base32 encoder,
+[enum] the length of the input is not a multiple of eight,
+[enum] padding appears not at the end of input, but in the middle,
+[enum] the padding has not of length six, four, three, or one characters,
+[list_end]
+[list_end]
+
+[section {Code map}]
+
+The code map used to convert 5-bit sequences is shown below, with the
+numeric id of the bit sequences to the left and the character used to
+encode it to the right. The important feature of the extended hex
+mapping is that the first 16 codes map to the digits and hex
+characters.
+
+[example {
+ 0 0 9 9 18 I 27 R
+ 1 1 10 A 19 J 28 S
+ 2 2 11 B 20 K 29 T
+ 3 3 12 C 21 L 30 U
+ 4 4 13 D 22 M 31 V
+ 5 5 14 E 23 N
+ 6 6 15 F 24 O
+ 7 7 16 G 25 P
+ 8 8 17 H 26 Q
+}]
+
+[vset CATEGORY base32]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/base32/base32hex.tcl b/tcllib/modules/base32/base32hex.tcl
new file mode 100644
index 0000000..6611c4c
--- /dev/null
+++ b/tcllib/modules/base32/base32hex.tcl
@@ -0,0 +1,182 @@
+# -*- tcl -*-
+# This code is hereby put into the public domain.
+# ### ### ### ######### ######### #########
+## Overview
+# Base32 encoding and decoding of small strings.
+#
+# Management code for switching between Tcl and C accelerated
+# implementations.
+#
+# RCS: @(#) $Id: base32hex.tcl,v 1.3 2008/03/22 23:46:42 andreas_kupries Exp $
+
+# @mdgen EXCLUDE: base32hex_c.tcl
+
+package require Tcl 8.4
+
+namespace eval ::base32::hex {}
+
+# ### ### ### ######### ######### #########
+## Management of base32 std implementations.
+
+# ::base32::hex::LoadAccelerator --
+#
+# Loads a named implementation, if possible.
+#
+# Arguments:
+# key Name of the implementation to load.
+#
+# Results:
+# A boolean flag. True if the implementation
+# was successfully loaded; and False otherwise.
+
+proc ::base32::hex::LoadAccelerator {key} {
+ variable accel
+ set isok 0
+ switch -exact -- $key {
+ critcl {
+ # Critcl implementation of base32 requires Tcl 8.4.
+ if {![package vsatisfies [package provide Tcl] 8.4]} {return 0}
+ if {[catch {package require tcllibc}]} {return 0}
+ set isok [llength [info commands ::base32::hex::critcl_encode]]
+ }
+ tcl {
+ variable selfdir
+ if {[catch {source [file join $selfdir base32hex_tcl.tcl]}]} {return 0}
+ set isok [llength [info commands ::base32::hex::tcl_encode]]
+ }
+ default {
+ return -code error "invalid accelerator $key:\
+ must be one of [join [KnownImplementations] {, }]"
+ }
+ }
+ set accel($key) $isok
+ return $isok
+}
+
+# ::base32::hex::SwitchTo --
+#
+# Activates a loaded named implementation.
+#
+# Arguments:
+# key Name of the implementation to activate.
+#
+# Results:
+# None.
+
+proc ::base32::hex::SwitchTo {key} {
+ variable accel
+ variable loaded
+
+ if {[string equal $key $loaded]} {
+ # No change, nothing to do.
+ return
+ } elseif {![string equal $key ""]} {
+ # Validate the target implementation of the switch.
+
+ if {![info exists accel($key)]} {
+ return -code error "Unable to activate unknown implementation \"$key\""
+ } elseif {![info exists accel($key)] || !$accel($key)} {
+ return -code error "Unable to activate missing implementation \"$key\""
+ }
+ }
+
+ # Deactivate the previous implementation, if there was any.
+
+ if {![string equal $loaded ""]} {
+ foreach c {encode decode} {
+ rename ::base32::hex::$c ::base32::hex::${loaded}_$c
+ }
+ }
+
+ # Activate the new implementation, if there is any.
+
+ if {![string equal $key ""]} {
+ foreach c {encode decode} {
+ rename ::base32::hex::${key}_$c ::base32::hex::$c
+ }
+ }
+
+ # Remember the active implementation, for deactivation by future
+ # switches.
+
+ set loaded $key
+ return
+}
+
+# ::base32::hex::Implementations --
+#
+# Determines which implementations are
+# present, i.e. loaded.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A list of implementation keys.
+
+proc ::base32::hex::Implementations {} {
+ variable accel
+ set res {}
+ foreach n [array names accel] {
+ if {!$accel($n)} continue
+ lappend res $n
+ }
+ return $res
+}
+
+# ::base32::hex::KnownImplementations --
+#
+# Determines which implementations are known
+# as possible implementations.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A list of implementation keys. In the order
+# of preference, most prefered first.
+
+proc ::base32::hex::KnownImplementations {} {
+ return {critcl tcl}
+}
+
+proc ::base32::hex::Names {} {
+ return {
+ critcl {tcllibc based}
+ tcl {pure Tcl}
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Initialization: Data structures.
+
+namespace eval ::base32::hex {
+ variable selfdir [file dirname [info script]]
+ variable loaded {}
+
+ variable accel
+ array set accel {tcl 0 critcl 0}
+}
+
+# ### ### ### ######### ######### #########
+## Initialization: Choose an implementation,
+## most prefered first. Loads only one of the
+## possible implementations. And activates it.
+
+namespace eval ::base32::hex {
+ variable e
+ foreach e [KnownImplementations] {
+ if {[LoadAccelerator $e]} {
+ SwitchTo $e
+ break
+ }
+ }
+ unset e
+
+ namespace export encode decode
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide base32::hex 0.1
diff --git a/tcllib/modules/base32/base32hex.test b/tcllib/modules/base32/base32hex.test
new file mode 100644
index 0000000..173c266
--- /dev/null
+++ b/tcllib/modules/base32/base32hex.test
@@ -0,0 +1,38 @@
+# -*- tcl -*- Tests for "base32"
+# This testsuite is in the public domain.
+#__________________________________________
+# RCS: @(#) $Id: base32hex.test,v 1.3 2008/03/22 23:46:42 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.1
+
+testing {
+ useLocal base32core.tcl base32::core
+ useTcllibC
+ useLocalKeep base32hex.tcl base32::hex
+ TestAccelInit base32::hex
+}
+
+set tests [localPath base32hex.testsuite]
+
+# -------------------------------------------------------------------------
+
+# The global variable 'impl' is part of the public API the testsuite
+# (in base32hex.testsuite) does expect from the environment.
+
+TestAccelDo base32::hex impl {
+ source $tests
+}
+
+# -------------------------------------------------------------------------
+
+unset tests
+TestAccelExit base32::hex
+testsuiteCleanup
+return
diff --git a/tcllib/modules/base32/base32hex.testsuite b/tcllib/modules/base32/base32hex.testsuite
new file mode 100644
index 0000000..bb7b08b
--- /dev/null
+++ b/tcllib/modules/base32/base32hex.testsuite
@@ -0,0 +1,156 @@
+# -*- tcl -*-
+# base32hex.testsuite: tests for hex extended base32.
+#
+# Public domain
+#
+# RCS: @(#) $Id: base32hex.testsuite,v 1.1 2006/05/27 20:44:36 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+::tcltest::testConstraint base32hex_critcl [string equal $impl critcl]
+
+# -------------------------------------------------------------------------
+
+test base32-hex-${impl}-1.0 {Encode, wrong#args} -body {
+ ::base32::hex::encode
+} -returnCodes error -result {wrong # args: should be "::base32::hex::encode bitstring"}
+
+test base32-hex-${impl}-1.1 {Encode, wrong#args} -body {
+ ::base32::hex::encode a b
+} -returnCodes error -result {wrong # args: should be "::base32::hex::encode bitstring"}
+
+# -------------------------------------------------------------------------
+
+test base32-hex-${impl}-2.0 {Decode, wrong#args} -body {
+ ::base32::hex::decode
+} -returnCodes error -result {wrong # args: should be "::base32::hex::decode estring"}
+
+test base32-hex-${impl}-2.1 {Decode, wrong#args} -body {
+ ::base32::hex::decode a b
+} -returnCodes error -result {wrong # args: should be "::base32::hex::decode estring"}
+
+# -------------------------------------------------------------------------
+# 0 .. 6 are the official test vectors from RFC 3548
+# 7 .. 12 are the vectors I fot previous, non-conforming,
+# implementation, updated for conformance.
+# 13 .. are new vectors to cover the whole range of bytes
+
+# 4-0 00100 000
+# 4-0-16-0 00100 00000 10000 0
+# 4-0-16-2-0 00100 00000 10000 00010 0000
+# 4-0-16-2-0-8-0 00100 00000 10000 00010 00000 01000 00
+# 4-0-16-2-0-8-1-0 00100 00000 10000 00010 00000 01000 00001 00000
+
+foreach {n text encoded} {
+ 0 {} {}
+ 1 f CO======
+ 2 fo CPNG====
+ 3 foo CPNMU===
+ 4 foob CPNMUOG=
+ 5 fooba CPNMUOJ1
+ 6 foobar CPNMUOJ1E8======
+ - - -
+ 7 { } 40======
+ 8 { } 40G0====
+ 9 { } 40G20===
+ 10 { } 40G2080=
+ 11 { } 40G20810
+ 12 { } 40G2081040======
+ - - - - - - - - - - - -
+ 20 \000 00====== 28 \010 10====== 36 \020 20====== 44 \030 30======
+ 21 \001 04====== 29 \011 14====== 37 \021 24====== 45 \031 34======
+ 22 \002 08====== 30 \012 18====== 38 \022 28====== 46 \032 38======
+ 23 \003 0C====== 31 \013 1C====== 39 \023 2C====== 47 \033 3C======
+ 24 \004 0G====== 32 \014 1G====== 40 \024 2G====== 48 \034 3G======
+ 25 \005 0K====== 33 \015 1K====== 41 \025 2K====== 49 \035 3K======
+ 26 \006 0O====== 34 \016 1O====== 42 \026 2O====== 50 \036 3O======
+ 27 \007 0S====== 35 \017 1S====== 43 \027 2S====== 51 \037 3S======
+ - - - - - - - - - - - -
+ 52 \040 40====== 60 \050 50====== 68 \060 60====== 76 \070 70======
+ 53 \041 44====== 61 \051 54====== 69 \061 64====== 77 \071 74======
+ 54 \042 48====== 62 \052 58====== 70 \062 68====== 78 \072 78======
+ 55 \043 4C====== 63 \053 5C====== 71 \063 6C====== 79 \073 7C======
+ 56 \044 4G====== 64 \054 5G====== 72 \064 6G====== 80 \074 7G======
+ 57 \045 4K====== 65 \055 5K====== 73 \065 6K====== 81 \075 7K======
+ 58 \046 4O====== 66 \056 5O====== 74 \066 6O====== 82 \076 7O======
+ 59 \047 4S====== 67 \057 5S====== 75 \067 6S====== 83 \077 7S======
+ - - - - - - - - - - - -
+ a0 \100 80====== a8 \110 90====== b6 \120 A0====== c4 \130 B0======
+ a1 \101 84====== a9 \111 94====== b7 \121 A4====== c5 \131 B4======
+ a2 \102 88====== b0 \112 98====== b8 \122 A8====== c6 \132 B8======
+ a3 \103 8C====== b1 \113 9C====== b9 \123 AC====== c7 \133 BC======
+ a4 \104 8G====== b2 \114 9G====== c0 \124 AG====== c8 \134 BG======
+ a5 \105 8K====== b3 \115 9K====== c1 \125 AK====== c9 \135 BK======
+ a6 \106 8O====== b4 \116 9O====== c2 \126 AO====== d0 \136 BO======
+ a7 \107 8S====== b5 \117 9S====== c3 \127 AS====== d1 \137 BS======
+ - - - - - - - - - - - -
+ d2 \140 C0====== e0 \150 D0====== e8 \160 E0====== f6 \170 F0======
+ d3 \141 C4====== e1 \151 D4====== e9 \161 E4====== f7 \171 F4======
+ d4 \142 C8====== e2 \152 D8====== f0 \162 E8====== f8 \172 F8======
+ d5 \143 CC====== e3 \153 DC====== f1 \163 EC====== f9 \173 FC======
+ d6 \144 CG====== e4 \154 DG====== f2 \164 EG====== g0 \174 FG======
+ d7 \145 CK====== e5 \155 DK====== f3 \165 EK====== g1 \175 FK======
+ d8 \146 CO====== e6 \156 DO====== f4 \166 EO====== g2 \176 FO======
+ d9 \147 CS====== e7 \157 DS====== f5 \167 ES====== g3 \177 FS======
+ - - - - - - - - - - - -
+ h0 \200 G0====== h8 \210 H0====== i6 \220 I0====== j4 \230 J0======
+ h1 \201 G4====== h9 \211 H4====== i7 \221 I4====== j5 \231 J4======
+ h2 \202 G8====== i0 \212 H8====== i8 \222 I8====== j6 \232 J8======
+ h3 \203 GC====== i1 \213 HC====== i9 \223 IC====== j7 \233 JC======
+ h4 \204 GG====== i2 \214 HG====== j0 \224 IG====== j8 \234 JG======
+ h5 \205 GK====== i3 \215 HK====== j1 \225 IK====== j9 \235 JK======
+ h6 \206 GO====== i4 \216 HO====== j2 \226 IO====== k0 \236 JO======
+ h7 \207 GS====== i5 \217 HS====== j3 \227 IS====== k1 \237 JS======
+ - - - - - - - - - - - -
+ k2 \240 K0====== l0 \250 L0====== l8 \260 M0====== m6 \270 N0======
+ k3 \241 K4====== l1 \251 L4====== l9 \261 M4====== m7 \271 N4======
+ k4 \242 K8====== l2 \252 L8====== m0 \262 M8====== m8 \272 N8======
+ k5 \243 KC====== l3 \253 LC====== m1 \263 MC====== m9 \273 NC======
+ k6 \244 KG====== l4 \254 LG====== m2 \264 MG====== n0 \274 NG======
+ k7 \245 KK====== l5 \255 LK====== m3 \265 MK====== n1 \275 NK======
+ k8 \246 KO====== l6 \256 LO====== m4 \266 MO====== n2 \276 NO======
+ k9 \247 KS====== l7 \257 LS====== m5 \267 MS====== n3 \277 NS======
+ - - - - - - - - - - - -
+ o0 \300 O0====== o8 \310 P0====== p6 \320 Q0====== q4 \330 R0======
+ o1 \301 O4====== o9 \311 P4====== p7 \321 Q4====== q5 \331 R4======
+ o2 \302 O8====== p0 \312 P8====== p8 \322 Q8====== q6 \332 R8======
+ o3 \303 OC====== p1 \313 PC====== p9 \323 QC====== q7 \333 RC======
+ o4 \304 OG====== p2 \314 PG====== q0 \324 QG====== q8 \334 RG======
+ o5 \305 OK====== p3 \315 PK====== q1 \325 QK====== q9 \335 RK======
+ o6 \306 OO====== p4 \316 PO====== q2 \326 QO====== r0 \336 RO======
+ o7 \307 OS====== p5 \317 PS====== q3 \327 QS====== r1 \337 RS======
+ - - - - - - - - - - - -
+ r2 \340 S0====== s0 \350 T0====== s8 \360 U0====== t6 \370 V0======
+ r3 \341 S4====== s1 \351 T4====== s9 \361 U4====== t7 \371 V4======
+ r4 \342 S8====== s2 \352 T8====== t0 \362 U8====== t8 \372 V8======
+ r5 \343 SC====== s3 \353 TC====== t1 \363 UC====== t9 \373 VC======
+ r6 \344 SG====== s4 \354 TG====== t2 \364 UG====== u0 \374 VG======
+ r7 \345 SK====== s5 \355 TK====== t3 \365 UK====== u1 \375 VK======
+ r8 \346 SO====== s6 \356 TO====== t4 \366 UO====== u2 \376 VO======
+ r9 \347 SS====== s7 \357 TS====== t5 \367 US====== u3 \377 VS======
+} {
+ if {$n == "-"} continue
+ test base32-hex-${impl}-3.$n "Encode \"$text\"" -body {
+ ::base32::hex::encode $text
+ } -result $encoded ; # {}
+
+ test base32-hex-${impl}-4.$n "Decode \"$encoded\"" -body {
+ ::base32::hex::decode $encoded
+ } -result $text ; # {}
+}
+
+# -------------------------------------------------------------------------
+# Decoder stress testing bad input
+
+foreach {n input message} {
+ 0 abcdeZaa {Invalid character at index 5: "Z"}
+ 1 A {Length is not a multiple of 8}
+ 2 ABCDEFG {Length is not a multiple of 8}
+ 3 A======= {Invalid padding of length 7}
+ 4 ACA===== {Invalid padding of length 5}
+ 5 A=CA==== {Invalid character at index 1: "=" (padding found in the middle of the input)}
+} {
+ test base32-hex-${impl}-5.$n "Decode, bad input \"$input\"" -body {
+ ::base32::hex::decode $input
+ } -returnCodes error -result $message ; # {}
+}
diff --git a/tcllib/modules/base32/base32hex_c.tcl b/tcllib/modules/base32/base32hex_c.tcl
new file mode 100644
index 0000000..5466463
--- /dev/null
+++ b/tcllib/modules/base32/base32hex_c.tcl
@@ -0,0 +1,253 @@
+# base32hexc.tcl --
+#
+# Implementation of a base32 (extended hex) de/encoder for Tcl.
+#
+# Public domain
+#
+# RCS: @(#) $Id: base32hex_c.tcl,v 1.3 2008/01/28 22:58:18 andreas_kupries Exp $
+
+package require critcl
+package require Tcl 8.4
+
+namespace eval ::base32::hex {
+ # Supporting code for the main command.
+ catch {
+ #critcl::cheaders -g
+ #critcl::debug memory symbols
+ }
+
+ # Main commands, encoder & decoder
+
+ critcl::ccommand critcl_encode {dummy interp objc objv} {
+ /* Syntax -*- c -*-
+ * critcl_encode string
+ */
+
+ unsigned char* buf;
+ int nbuf;
+
+ unsigned char* out;
+ unsigned char* at;
+ int nout;
+
+ /*
+ * The array used for encoding
+ */ /* 123456789 123456789 123456789 12 */
+ static const char map[] = "0123456789ABCDEFGHIJKLMNOPQRSTUV";
+
+#define USAGEE "bitstring"
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 1, objv, USAGEE);
+ return TCL_ERROR;
+ }
+
+ buf = Tcl_GetByteArrayFromObj (objv[1], &nbuf);
+ nout = ((nbuf+4)/5)*8;
+ out = (unsigned char*) Tcl_Alloc (nout*sizeof(char));
+
+ for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) {
+ *(at++) = map [ (buf[0]>>3) ];
+ *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+ *(at++) = map [ 0x1f & (buf[1]>>1) ];
+ *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
+ *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
+ *(at++) = map [ 0x1f & (buf[3]>>2) ];
+ *(at++) = map [ 0x1f & ((buf[3]<<3) | (buf[4]>>5)) ];
+ *(at++) = map [ 0x1f & (buf[4]) ];
+ }
+ if (nbuf > 0) {
+ /* Process partials at end. */
+ switch (nbuf) {
+ case 1:
+ /* |01234567| 2, padding 6
+ * xxxxx
+ * xxx 00
+ */
+
+ *(at++) = map [ (buf[0]>>3) ];
+ *(at++) = map [ 0x1f & (buf[0]<<2) ];
+ *(at++) = '=';
+ *(at++) = '=';
+ *(at++) = '=';
+ *(at++) = '=';
+ *(at++) = '=';
+ *(at++) = '=';
+ break;
+ case 2: /* x3/=4 */
+ /* |01234567|01234567| 4, padding 4
+ * xxxxx
+ * xxx xx
+ * xxxxx
+ * x 0000
+ */
+
+ *(at++) = map [ (buf[0]>>3) ];
+ *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+ *(at++) = map [ 0x1f & (buf[1]>>1) ];
+ *(at++) = map [ 0x1f & (buf[1]<<4) ];
+ *(at++) = '=';
+ *(at++) = '=';
+ *(at++) = '=';
+ *(at++) = '=';
+ break;
+ case 3:
+ /* |01234567|01234567|01234567| 5, padding 3
+ * xxxxx
+ * xxx xx
+ * xxxxx
+ * x xxxx
+ * xxxx 0
+ */
+
+ *(at++) = map [ (buf[0]>>3) ];
+ *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+ *(at++) = map [ 0x1f & (buf[1]>>1) ];
+ *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
+ *(at++) = map [ 0x1f & (buf[2]<<1) ];
+ *(at++) = '=';
+ *(at++) = '=';
+ *(at++) = '=';
+ break;
+ case 4:
+ /* |01234567|01234567|01234567|012334567| 7, padding 1
+ * xxxxx
+ * xxx xx
+ * xxxxx
+ * x xxxx
+ * xxxx
+ * xxxxx
+ * xxxx 0
+ */
+
+ *(at++) = map [ (buf[0]>>3) ];
+ *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+ *(at++) = map [ 0x1f & (buf[1]>>1) ];
+ *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
+ *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
+ *(at++) = map [ 0x1f & (buf[3]>>2) ];
+ *(at++) = map [ 0x1f & (buf[3]<<3) ];
+ *(at++) = '=';
+ break;
+ }
+ }
+
+ Tcl_SetObjResult (interp, Tcl_NewStringObj ((char*)out, nout));
+ Tcl_Free ((char*) out);
+ return TCL_OK;
+ }
+
+
+ critcl::ccommand critcl_decode {dummy interp objc objv} {
+ /* Syntax -*- c -*-
+ * critcl_decode estring
+ */
+
+ unsigned char* buf;
+ int nbuf;
+
+ unsigned char* out;
+ unsigned char* at;
+ unsigned char x [8];
+ int nout;
+
+ int i, j, a, pad, nx;
+
+ /*
+ * An array for translating single base-32 characters into a value.
+ * Disallowed input characters have a value of 64. Upper and lower
+ * case is the same. Only 128 chars, as everything above char(127)
+ * is 64.
+ */
+ static const char map [] = {
+ /* \00 */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ /* DLE */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ /* SPC */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ /* '0' */ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 64, 64, 64, 64, 64, 64,
+ /* '@' */ 64, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24,
+ /* 'P' */ 25, 26, 27, 28, 29, 30, 31, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ /* '`' */ 64, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24,
+ /* 'p' */ 25, 26, 27, 28, 29, 30, 31, 64, 64, 64, 64, 64, 64, 64, 64, 64
+ };
+
+#define USAGED "estring"
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 1, objv, USAGED);
+ return TCL_ERROR;
+ }
+
+ buf = (unsigned char*) Tcl_GetStringFromObj (objv[1], &nbuf);
+
+ if (nbuf % 8) {
+ Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1));
+ return TCL_ERROR;
+ }
+
+ nout = (nbuf/8)*5 *TCL_UTF_MAX;
+ out = (unsigned char*) Tcl_Alloc (nout*sizeof(char));
+
+#define HIGH(x) (((x) & 0x80) != 0)
+#define BADC(x) ((x) == 64)
+#define BADCHAR(a,j) (HIGH ((a)) || BADC (x [(j)] = map [(a)]))
+
+ for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){
+ for (j=0; j < 8; j++){
+ a = buf [j];
+
+ if (a == '=') {
+ x[j] = 0;
+ pad++;
+ continue;
+ } else if (pad) {
+ char msg [120];
+ sprintf (msg,
+ "Invalid character at index %d: \"=\" (padding found in the middle of the input)",
+ j-1);
+ Tcl_Free ((char*) out);
+ Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
+ return TCL_ERROR;
+ }
+
+ if (BADCHAR (a,j)) {
+ char msg [100];
+ sprintf (msg,"Invalid character at index %d: \"%c\"",j,a);
+ Tcl_Free ((char*) out);
+ Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
+ return TCL_ERROR;
+ }
+ }
+
+ *(at++) = (x[0]<<3) | (x[1]>>2) ;
+ *(at++) = (x[1]<<6) | (x[2]<<1) | (x[3]>>4);
+ *(at++) = (x[3]<<4) | (x[4]>>1) ;
+ *(at++) = (x[4]<<7) | (x[5]<<2) | (x[6]>>3);
+ *(at++) = (x[6]<<5) | x[7] ;
+ }
+
+ if (pad) {
+ if (pad == 1) {
+ at -= 1;
+ } else if (pad == 3) {
+ at -= 2;
+ } else if (pad == 4) {
+ at -= 3;
+ } else if (pad == 6) {
+ at -= 4;
+ } else {
+ char msg [100];
+ sprintf (msg,"Invalid padding of length %d",pad);
+ Tcl_Free ((char*) out);
+ Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1));
+ return TCL_ERROR;
+ }
+ }
+
+ Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out));
+ Tcl_Free ((char*) out);
+ return TCL_OK;
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Ready
diff --git a/tcllib/modules/base32/base32hex_tcl.tcl b/tcllib/modules/base32/base32hex_tcl.tcl
new file mode 100644
index 0000000..f406bc6
--- /dev/null
+++ b/tcllib/modules/base32/base32hex_tcl.tcl
@@ -0,0 +1,79 @@
+# -*- tcl -*-
+# This code is hereby put into the public domain.
+# ### ### ### ######### ######### #########
+## Overview
+# Base32 encoding and decoding of small strings.
+
+# ### ### ### ######### ######### #########
+## Notes
+
+# A binary string is split into groups of 5 bits (2^5 == 32), and each
+# group is converted into a printable character as is specified in RFC
+# 3548 for the extended hex encoding.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require base32::core
+namespace eval ::base32::hex {}
+
+# ### ### ### ######### ######### #########
+## API & Implementation
+
+proc ::base32::hex::tcl_encode {bitstring} {
+ variable forward
+
+ binary scan $bitstring B* bits
+ set len [string length $bits]
+ set rem [expr {$len % 5}]
+ if {$rem} {append bits =/$rem}
+ #puts "($bitstring) => <$bits>"
+
+ return [string map $forward $bits]
+}
+
+proc ::base32::hex::tcl_decode {estring} {
+ variable backward
+ variable invalid
+
+ if {![core::valid $estring $invalid msg]} {
+ return -code error $msg
+ }
+ #puts "I<$estring>"
+ #puts "M<[string map $backward $estring]>"
+
+ return [binary format B* [string map $backward [string toupper $estring]]]
+}
+
+# ### ### ### ######### ######### #########
+## Data structures
+
+namespace eval ::base32::hex {
+ namespace eval core {
+ namespace import ::base32::core::define
+ namespace import ::base32::core::valid
+ }
+
+ namespace export encode decode
+ # Initialize the maps
+ variable forward
+ variable backward
+ variable invalid
+
+ core::define {
+ 0 0 9 9 18 I 27 R
+ 1 1 10 A 19 J 28 S
+ 2 2 11 B 20 K 29 T
+ 3 3 12 C 21 L 30 U
+ 4 4 13 D 22 M 31 V
+ 5 5 14 E 23 N
+ 6 6 15 F 24 O
+ 7 7 16 G 25 P
+ 8 8 17 H 26 Q
+ } forward backward invalid ; # {}
+ # puts ///$forward///
+ # puts ///$backward///
+}
+
+# ### ### ### ######### ######### #########
+## Ok
diff --git a/tcllib/modules/base32/pkgIndex.tcl b/tcllib/modules/base32/pkgIndex.tcl
new file mode 100644
index 0000000..3bccaa7
--- /dev/null
+++ b/tcllib/modules/base32/pkgIndex.tcl
@@ -0,0 +1,4 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} return
+package ifneeded base32 0.1 [list source [file join $dir base32.tcl]]
+package ifneeded base32::hex 0.1 [list source [file join $dir base32hex.tcl]]
+package ifneeded base32::core 0.1 [list source [file join $dir base32core.tcl]]
diff --git a/tcllib/modules/base64/ChangeLog b/tcllib/modules/base64/ChangeLog
new file mode 100644
index 0000000..c182107
--- /dev/null
+++ b/tcllib/modules/base64/ChangeLog
@@ -0,0 +1,428 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2013-01-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base64.man: [Bug 3581373]: Document behaviour for -maxlen 0.
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-11-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base64.test: [Bug 2976290]: Disable new test when Trf is
+ available. It actually performs a decoding.
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-07-06 Andreas Kupries <andreask@activestate.com>
+
+ * base64.tcl (::base64::decode): [Bug 2976290]: Throw a proper
+ * base64.man: error when trying to decode padding with not enough
+ * base64.test: data in front of it. Extended testsuite. Bumped to
+ * pkgIndex.tcl: version 2.4.2.
+
+2010-05-04 Andreas Kupries <andreask@activestate.com>
+
+ * base64.man:: Fix small typo, default for -maxlen changed to 76.
+
+2010-05-03 Andreas Kupries <andreask@activestate.com>
+
+ * ascii85.man: [FR 2993200]: Added new package ascii85,
+ * ascii85.tcl: provided by Emiliano
+ * ascii85.test: <egavilan@users.sourceforge.net>
+ * pkgIndex.tcl:
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-05-07 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * uuencode.tcl: Changed poor idiom for setting interp result.
+ * yencode.tcl:
+
+2009-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base64.tcl: Define a number of transient variables in the
+ namespace, to avoid creative-writing. Fixes [Bug 2538424].
+
+ * pkgIndex.tcl: Bumped version to 2.4.1.
+ * base64.man:
+
+2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11.1 ========================
+ *
+
+2008-12-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * yencode.tcl: Fixed bug in the yencoder. Escaped characters
+ * yencode.man: have to be rotated by 64 according to the yEnc
+ * yencode.test: specification v1.3, not 42. Bumped version to
+ * pkgIndex.tcl: 1.1.2. Updated tests.
+
+ * uuencode.test: Better handling of loading 'tcllibc'.
+
+2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11 ========================
+ *
+
+2008-06-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base64.pcx: New files. Syntax definitions for the public
+ * uuencode.pcx: commands of the packages base74, uuencode,
+ * yencode.pcx: and yencode.
+
+2008-05-28 Andreas Kupries <andreask@activestate.com>
+
+ * base64.tcl: Changed the default setting for -maxlen to 76 to
+ * base64.man: coincide with MIME definitions and Trf, making
+ * base64.test: the very fast path default, with no output reflow
+ * pkgIndex.tcl: required at all. Bumped version to 2.4.
+
+ ** POTENTIAL INCOMPATIBILITY ** for all users depending on the
+ default setting to be 60.
+
+2008-05-22 Andreas Kupries <andreask@activestate.com>
+
+ * base64.test: Extended with tests using bogus values of -maxchar,
+ * base64.tcl: and non-standard values. Fixed bugs in the maxlen
+ * base64.man: handling of the pure Tcl implementation which
+ * pkgIndex.tcl: allowed the output to have more than maxlen
+ characters per line. Performance fix: Replaced Miguel's O(n^2)
+ reflow algorithm (maxlen handling after Trf) with Gustaf
+ Neumann's O(n) algorithm. Minor changes to the guarding
+ conditions by myself, and fixes for the fast cases. Bumped the
+ version to 2.3.3.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-03-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base64.man: Fixed all warnings due to use of now deprecated
+ * uuencode.man: commands. Added a section about how to give
+ * yencode.man: feedback.
+
+2006-11-04 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * base64c.tcl: Silence critcl warning.
+
+2006-10-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uuencode.test: Documentation and code (error messages) disagreed
+ * uuencode.man: about the accepted options, and tests were
+ * uuencode.tcl: missing entirely. The code additionally missed
+ some checks regarding the proper number of arguments, nor had it
+ tests checking that either. Added tests and synchronized code
+ and documentation.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * yencode.test: More boilerplate simplified via use of test support.
+ * uuencode.test:
+ * base64.test:
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * yencode.test: Hooked into the new common test support code.
+ * uuencode.test:
+ * base64.test:
+
+2005-10-18 Andreas Kupries <andreask@activestate.com>
+
+ * base64.bench: Basic benchmarks for base64, uuencode,
+ * uuencode.bench: and yencode. Encode/decode of strings
+ * yencode.bench: only.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-08-26 Andreas Kupries <andreask@activestate.com>
+
+ * uuencode.test: Deconfused the testsuite's belief of which
+ accelerators is in use. Removed superfluous output, and added a
+ flag variable for actual use of Trf, not only presence. Changed
+ definition of test 1.4 to use this flag. This is for [Tcllib SF
+ Bug 1273537].
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base64.man: Cleaned the doc up a bit. Especially highlighted the
+ recently added note recording binary by separating it from the
+ general description a bit (same location, new paragraph).
+
+2005-02-17 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * base64.man: Added some examples and attempted to point out that
+ proper string encoding may be needed for unicode strings.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-08-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base64.tcl: Typo police.
+ * uuencode.tcl:
+ * uuencode.man:
+ * yencode.man:
+
+2004-07-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uuencode.man: Polished a bit (options, keywords).
+ * yencode.man:
+
+2004-07-19 Andreas Kupries <andreask@activestate.com>
+
+ * base64.man: Added copyright notes for the early authors, as far
+ as I am aware of them.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uuencode.tcl: Updated version number to sync with 1.6.1
+ * uuencode.man: release
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uuencode.tcl: Rel. engineering. Updated version number
+ * uuencode.man: of uuencode to reflect its changes, to 1.1.1.
+ * pkgIndex.tcl:
+
+2004-03-09 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * uuencode.tcl (::uuencode::pad): don't use log package
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-10-24 Andreas Kupries <andreask@activestate.com>
+
+ * base64.test:
+ * base64.tcl: Applied patch fixing [Bug 821126]. Variable 'output'
+ is now initialized to empty to have it defined at all
+ times. Extended testsuite to cover the fixed cases.
+
+2003-10-21 Andreas Kupries <andreask@activestate.com>
+
+ * base64.tcl: Added code to the Trf supported 'decode'r to ignore
+ whitespace in hte encoded input. [Bug 736900].
+
+2003-07-24 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * base64c.tcl: Added the placeholder package.
+
+2003-05-14 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * Merged DEVELOPMENT branch from DEVELOPMENT-root to
+ DEVELOPMENT-merge-1 This brings in the critcl enhancements for
+ uuencode and yencode along with a few extra tests for yencode.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-22 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * base64c.tcl: Added file to define the base64c C coded package.
+ * uuencode.tcl: Added critcl code into the package.
+ * yencode.tcl: Added critcl code into the package.
+
+2003-04-22 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * all: Created DEVELOPMENT branch - tagged root-DEVELOPMENT.
+ This branch contains criticl-based C code to speed up some of the
+ computationally expensive functions - generates a base64c package.
+
+2003-04-21 Andreas Kupries <andreask@pliers.activestate.com>
+
+ * uuencode.test: Added code to suppress output from the log
+ package during the test.
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * uuencode.man:
+ * base64.tcl:
+ * base64.man:
+ * pkgIndex.tcl: Fixed bug #614591. Set version of the base64
+ package to to 2.2.2. uuencode is now at version 1.0.2
+ throughout.
+
+2003-03-24 Andreas Kupries <andreask@activestate.com>
+
+ * uuencode.test:
+ * uuencode.tcl: Fixed bug #700327, reported by Roger Niva
+ <rniva@users.sourceforge.net>. Added '--' before actual data
+ argument to prevent mishandling of data beginning with a dash
+ ('-'). Extended the testsuite to cover these cases.
+
+2003-02-23 David N. Welton <davidw@dedasys.com>
+
+ * base64.tcl: Bumped base64.tcl Tcl requirement to 8.2, swapped
+ out regsub for string map.
+
+2003-01-25 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * yencode.tcl:
+ * uuencode.tcl: Added Tcl 8.2 version requirement, bumped versions
+ and added copyright to man pages. Fixed uuencode to work with Tcl 8.2
+
+2002-06-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl:
+ * base64.tcl:
+ * base64.n:
+ * base64.man: Bumped base64 to version 2.2.1.
+
+ * pkgIndex.tcl:
+ * uuencode.tcl:
+ * uuencode.n:
+ * uuencode.man: Bumped uuencode to version 1.0.1.
+
+2002-05-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * yencode.test: Fixed SF Tcllib Bug #548354 so that the datafile
+ used by the test is found even if the build directory is outside
+ of the tcllib directory hierarchy. Original patch provided by Larry
+ Virden <lvirden@users.sourceforge.net>, changed by me to work in
+ my configuration too.
+
+2002-04-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * uuencode.tcl:
+ * yencode.tcl:
+ * base64.tcl: Fixed decoding of empty string in tcl
+ implementation. Fixes bug #548112.
+
+2002-04-17 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * yencode.tcl, yencode.test, yencode.man, yencode.test.data,
+ * yencode.test.out: initial import of yEnc encode/decode package
+ plus man page and test.
+
+2002-04-17 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * uuencode.tcl: fixed bug #544452 to handle DOS input files and
+ tolerate incorrect uuencoded line lengths.
+ * uuencode.test: added tests for the above bug conditions.
+
+2002-01-17 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * uuencode.tcl: added support for Trf and fixed length bug
+
+2002-01-16 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * uuencode.tcl: initial import of uuencode package
+ * pkgIndex.tcl: added uuencode package
+
+2001-09-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base64.tcl: Restricted export list to public API.
+ [456255]. Patch by Hemang Lavana
+ <hemanglavana@users.sourceforge.net>
+
+2001-07-31 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base64.n: Added manpage [446584].
+
+2001-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * base64.tcl: Frink 2.2 run, fixed dubious code.
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net
+
+ * base64.tcl: Fixed dubious code reported by frink.
+
+2001-06-02 Miguel Sofer <mig@utdt.edu>
+
+ * base64.tcl: Greatly increased speed, obtained by: using lists
+ instead of arrays, splitting the input with [binary scan],
+ taking the bytes to be encoded three at a time, and
+ reformulating the decoding algorithm to be purely
+ arithmetic. Improved backwards compatibility, now runs with
+ Tcl8.0.
+
+ Nudged version to 2.2
+
+2000-10-11 Brent Welch <welch@ajubasolutions.com>
+
+ * base64.tcl: Fixed bug in base64::decode where trailing
+ bytes were not always decoded correctly (!). This only
+ shows up with low-valued characters (less than 0x10) near
+ the end of a string that was padded with =
+
+ Nudged version to 2.1 so we can distinquish this version
+ that has bug fixes and new features.
+
+2000-10-10 Eric Melski <ericm@ajubasolutions.com>
+
+ * base64.tcl: Extending base64::encode to accept optional
+ arguments ?-maxlen maxlen? and ?-wrapchar wrapchar?, to control
+ the line wrapping and the character(s) used to cause the
+ wrapping. Based on work by Joel Saunier.
+
+2000-03-09 Eric Melski <ericm@scriptics.com>
+
+ * base64.test: Adapted tests to work in tcllib test framework.
+
+2000-03-04 Eric Melski <ericm@scriptics.com>
+
+ * base64.test: Added tests for decoding data that was padded with ='s
+
+ * base64.tcl: Fixed a bug with line wrapping in the encoder -- it
+ was not properly counting the number of characters emitted, so it
+ was not wrapping when it should. Changed the chars/line to 60, so
+ the output would be identical to that produced by GNU uuecode 4.2,
+ for easy testing purposes. Fixed a bug in the decoder with
+ newlines -- it was not ignoring them as it should according to RFC
+ 2045.
+ Fixed a bug in decoder dealing with data that was padded with ='s.
+
+
+ * base64.test: Some rudimentary tests for the encoder/decoder.
+
+2000-03-02 Eric Melski <ericm@scriptics.com>
+
+ * pkgIndex.tcl: added pkgIndex file.
diff --git a/tcllib/modules/base64/ascii85.man b/tcllib/modules/base64/ascii85.man
new file mode 100644
index 0000000..aab71a1
--- /dev/null
+++ b/tcllib/modules/base64/ascii85.man
@@ -0,0 +1,75 @@
+[manpage_begin ascii85 n 1.0]
+[keywords ascii85]
+[keywords encoding]
+[copyright "2010, Emiliano Gavil\u00e1n"]
+[moddesc {Text encoding & decoding binary data}]
+[titledesc {ascii85-encode/decode binary data}]
+[category {Text processing}]
+[require Tcl 8.4]
+[require ascii85 [opt 1.0]]
+[description]
+[para]
+
+This package provides procedures to encode binary data into ascii85 and back.
+
+[list_begin definitions]
+
+[call [cmd ::ascii85::encode] [opt "[option -maxlen] [arg maxlen]"] [opt "[option -wrapchar] [arg wrapchar]"] [arg string]]
+
+Ascii85 encodes the given binary [arg string] and returns the encoded
+result. Inserts the character [arg wrapchar] every [arg maxlen]
+characters of output. [arg wrapchar] defaults to newline. [arg maxlen]
+defaults to [const 76].
+
+[para]
+
+[emph {Note well}]: If your string is not simple ascii you should fix
+the string encoding before doing ascii85 encoding. See the examples.
+
+[para]
+
+The command will throw an error for negative values of [arg maxlen],
+or if [arg maxlen] is not an integer number.
+
+[call [cmd ::ascii85::decode] [arg "string"]]
+
+Ascii85 decodes the given [arg "string"] and returns the binary data.
+The decoder ignores whitespace in the string, as well as tabs and
+newlines.
+
+[list_end]
+
+[section {EXAMPLES}]
+
+[example {
+% ascii85::encode "Hello, world"
+87cURD_*#TDfTZ)
+}]
+
+[example {
+% ascii85::encode [string repeat xyz 24]
+G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G
+^4U[H$X^\H?a^]
+% ascii85::encode -wrapchar "" [string repeat xyz 24]
+G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]G^4U[H$X^\H?a^]
+}]
+
+[example {
+# NOTE: ascii85 encodes BINARY strings.
+% set chemical [encoding convertto utf-8 "C\u2088H\u2081\u2080N\u2084O\u2082"]
+% set encoded [ascii85::encode $chemical]
+6fN]R8E,5Pidu\UiduhZidua
+% set caffeine [encoding convertfrom utf-8 [ascii85::decode $encoded]]
+}]
+
+[section References]
+
+[list_begin enum]
+[enum] [uri http://en.wikipedia.org/wiki/Ascii85]
+[enum] Postscript Language Reference Manual, 3rd Edition, page 131.
+ [uri http://www.adobe.com/devnet/postscript/pdfs/PLRM.pdf]
+[list_end]
+
+[vset CATEGORY base64]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/base64/ascii85.pcx b/tcllib/modules/base64/ascii85.pcx
new file mode 100644
index 0000000..a300ccd
--- /dev/null
+++ b/tcllib/modules/base64/ascii85.pcx
@@ -0,0 +1,65 @@
+# -*- tcl -*- ascii85.pcx
+# Syntax of the commands provided by package ascii85.
+#
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register ascii85
+pcx::tcldep 1.0 needs tcl 8.4
+
+namespace eval ::ascii85 {}
+
+# Using the indirections below looks to be quite pointless, given that
+# they simply substitute the commands for others. I am doing this for
+# two reasons.
+
+# First, the rules coming after become self-commenting, i.e. a
+# maintainer can immediately see what an argument is supposed to be,
+# instead of having to search elsewhere (like the documentation and
+# implementation). In this manner our definitions here are a type of
+# semantic markup.
+
+# The second reason is that while we have no special checks now we
+# cannot be sure if such will (have to) be added in the future. With
+# all checking routed through our definitions we now already have the
+# basic infrastructure (i.e. hooks) in place in which we can easily
+# add any new checks by simply redefining the relevant command, and
+# all the rules update on their own. Mostly. This should cover 90% of
+# the cases. Sometimes new checks will require to create deeper
+# distinctions between different calls of the same thing. For such we
+# may have to update the rules as well, to provide the necessary
+# information to the checker.
+
+interp alias {} ascii85::checkLineLength {} checkInt ; #
+interp alias {} ascii85::checkWrapChar {} checkWord ; #
+interp alias {} ascii85::checkData {} checkWord ; #
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.0 std ::ascii85::decode \
+ {checkSimpleArgs 1 1 {
+ ascii85::checkData
+ }}
+
+# NOTE: Is '-maxlen' < 0 allowed?
+# Doc doesn't forbid it, code doesn't catch it.
+# May crash it however, i.e be a bug.
+# Check testsuite.
+pcx::check 1.0 std ::ascii85::encode \
+ {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ {-maxlen ascii85::checkLineLength}
+ {-wrapchar ascii85::checkWrapChar}
+ } {checkSimpleArgs 1 1 {
+ ascii85::checkData
+ }}}
+ }}
+
+# Initialization via pcx::init.
+# Use a ::ascii85::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/base64/ascii85.tcl b/tcllib/modules/base64/ascii85.tcl
new file mode 100644
index 0000000..9a1cd04
--- /dev/null
+++ b/tcllib/modules/base64/ascii85.tcl
@@ -0,0 +1,271 @@
+# ascii85.tcl --
+#
+# Encode/Decode ascii85 for a string
+#
+# Copyright (c) Emiliano Gavilan
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tcl 8.4
+
+namespace eval ascii85 {
+ namespace export encode encodefile decode
+ # default values for encode options
+ variable options
+ array set options [list -wrapchar \n -maxlen 76]
+}
+
+# ::ascii85::encode --
+#
+# Ascii85 encode a given string.
+#
+# Arguments:
+# args ?-maxlen maxlen? ?-wrapchar wrapchar? string
+#
+# If maxlen is 0, the output is not wrapped.
+#
+# Results:
+# A Ascii85 encoded version of $string, wrapped at $maxlen characters
+# by $wrapchar.
+
+proc ascii85::encode {args} {
+ variable options
+
+ set alen [llength $args]
+ if {$alen != 1 && $alen != 3 && $alen != 5} {
+ return -code error "wrong # args:\
+ should be \"[lindex [info level 0] 0]\
+ ?-maxlen maxlen?\
+ ?-wrapchar wrapchar? string\""
+ }
+
+ set data [lindex $args end]
+ array set opts [array get options]
+ array set opts [lrange $args 0 end-1]
+ foreach key [array names opts] {
+ if {[lsearch -exact [array names options] $key] == -1} {
+ return -code error "unknown option \"$key\":\
+ must be -maxlen or -wrapchar"
+ }
+ }
+
+ if {![string is integer -strict $opts(-maxlen)]
+ || $opts(-maxlen) < 0} {
+ return -code error "expected positive integer but got\
+ \"$opts(-maxlen)\""
+ }
+
+ # perform this check early
+ if {[string length $data] == 0} {
+ return ""
+ }
+
+ # shorten the names
+ set ml $opts(-maxlen)
+ set wc $opts(-wrapchar)
+
+ # if maxlen is zero, don't wrap the output
+ if {$ml == 0} {
+ set wc ""
+ }
+
+ set encoded {}
+
+ binary scan $data c* X
+ set len [llength $X]
+ set rest [expr {$len % 4}]
+ set lastidx [expr {$len - $rest - 1}]
+
+ foreach {b1 b2 b3 b4} [lrange $X 0 $lastidx] {
+ # calculate the 32 bit value
+ # this is an inlined version of the [encode4bytes] proc
+ # included here for performance reasons
+ set val [expr {
+ ( (($b1 & 0xff) << 24)
+ |(($b2 & 0xff) << 16)
+ |(($b3 & 0xff) << 8)
+ | ($b4 & 0xff)
+ ) & 0xffffffff }]
+
+ if {$val == 0} {
+ # four \0 bytes encodes as "z" instead of "!!!!!"
+ append current "z"
+ } else {
+ # no magic numbers here.
+ # 52200625 -> 85 ** 4
+ # 614125 -> 85 ** 3
+ # 7225 -> 85 ** 2
+ append current [binary format ccccc \
+ [expr { ( $val / 52200625) + 33 }] \
+ [expr { (($val % 52200625) / 614125) + 33 }] \
+ [expr { (($val % 614125) / 7225) + 33 }] \
+ [expr { (($val % 7225) / 85) + 33 }] \
+ [expr { ( $val % 85) + 33 }]]
+ }
+
+ if {[string length $current] >= $ml} {
+ append encoded [string range $current 0 [expr {$ml - 1}]] $wc
+ set current [string range $current $ml end]
+ }
+ }
+
+ if { $rest } {
+ # there are remaining bytes.
+ # pad with \0 and encode not using the "z" convention.
+ # finally, add ($rest + 1) chars.
+ set val 0
+ foreach {b1 b2 b3 b4} [pad [lrange $X [incr lastidx] end] 4 0] break
+ append current [string range [encode4bytes $b1 $b2 $b3 $b4] 0 $rest]
+ }
+ append encoded [regsub -all -- ".{$ml}" $current "&$wc"]
+
+ return $encoded
+}
+
+proc ascii85::encode4bytes {b1 b2 b3 b4} {
+ set val [expr {
+ ( (($b1 & 0xff) << 24)
+ |(($b2 & 0xff) << 16)
+ |(($b3 & 0xff) << 8)
+ | ($b4 & 0xff)
+ ) & 0xffffffff }]
+ return [binary format ccccc \
+ [expr { ( $val / 52200625) + 33 }] \
+ [expr { (($val % 52200625) / 614125) + 33 }] \
+ [expr { (($val % 614125) / 7225) + 33 }] \
+ [expr { (($val % 7225) / 85) + 33 }] \
+ [expr { ( $val % 85) + 33 }]]
+}
+
+# ::ascii85::encodefile --
+#
+# Ascii85 encode the contents of a file using default values
+# for maxlen and wrapchar parameters.
+#
+# Arguments:
+# fname The name of the file to encode.
+#
+# Results:
+# An Ascii85 encoded version of the contents of the file.
+# This is a convenience command
+
+proc ascii85::encodefile {fname} {
+ set fd [open $fname]
+ fconfigure $fd -encoding binary -translation binary
+ return [encode [read $fd]][close $fd]
+}
+
+# ::ascii85::decode --
+#
+# Ascii85 decode a given string.
+#
+# Arguments:
+# string The string to decode.
+# Leading spaces and tabs are removed, along with trailing newlines
+#
+# Results:
+# The decoded value.
+
+proc ascii85::decode {data} {
+ # get rid of leading spaces/tabs and trailing newlines
+ set data [string map [list \n {} \t {} { } {}] $data]
+ set len [string length $data]
+
+ # perform this ckeck early
+ if {! $len} {
+ return ""
+ }
+
+ set decoded {}
+ set count 0
+ set group [list]
+ binary scan $data c* X
+
+ foreach char $X {
+ # we must check that every char is in the allowed range
+ if {$char < 33 || $char > 117 } {
+ # "z" is an exception
+ if {$char == 122} {
+ if {$count == 0} {
+ # if a "z" char appears at the beggining of a group,
+ # it decodes as four null bytes
+ append decoded \x00\x00\x00\x00
+ continue
+ } else {
+ # if not, is an error
+ return -code error \
+ "error decoding data: \"z\" char misplaced"
+ }
+ }
+ # char is not in range and not a "z" at the beggining of a group
+ return -code error \
+ "error decoding data: chars outside the allowed range"
+ }
+
+ lappend group $char
+ incr count
+ if {$count == 5} {
+ # this is an inlined version of the [decode5chars] proc
+ # included here for performance reasons
+ set val [expr {
+ ([lindex $group 0] - 33) * wide(52200625) +
+ ([lindex $group 1] - 33) * 614125 +
+ ([lindex $group 2] - 33) * 7225 +
+ ([lindex $group 3] - 33) * 85 +
+ ([lindex $group 4] - 33) }]
+ if {$val > 0xffffffff} {
+ return -code error "error decoding data: decoded group overflow"
+ } else {
+ append decoded [binary format I $val]
+ incr count -5
+ set group [list]
+ }
+ }
+ }
+
+ set len [llength $group]
+ switch -- $len {
+ 0 {
+ # all input has been consumed
+ # do nothing
+ }
+ 1 {
+ # a single char is a condition error, there should be at least 2
+ return -code error \
+ "error decoding data: trailing char"
+ }
+ default {
+ # pad with "u"s, decode and add ($len - 1) bytes
+ append decoded [string range \
+ [decode5chars [pad $group 5 122]] \
+ 0 \
+ [expr {$len - 2}]]
+ }
+ }
+
+ return $decoded
+}
+
+proc ascii85::decode5chars {group} {
+ set val [expr {
+ ([lindex $group 0] - 33) * wide(52200625) +
+ ([lindex $group 1] - 33) * 614125 +
+ ([lindex $group 2] - 33) * 7225 +
+ ([lindex $group 3] - 33) * 85 +
+ ([lindex $group 4] - 33) }]
+ if {$val > 0xffffffff} {
+ return -code error "error decoding data: decoded group overflow"
+ }
+
+ return [binary format I $val]
+}
+
+proc ascii85::pad {chars len padchar} {
+ while {[llength $chars] < $len} {
+ lappend chars $padchar
+ }
+
+ return $chars
+}
+
+package provide ascii85 1.0
diff --git a/tcllib/modules/base64/ascii85.test b/tcllib/modules/base64/ascii85.test
new file mode 100644
index 0000000..7b249d9
--- /dev/null
+++ b/tcllib/modules/base64/ascii85.test
@@ -0,0 +1,189 @@
+# Tests for the base64 module. -*- tcl -*-
+#
+# 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) 1998-2000 by Ajuba Solutions.
+# All rights reserved.
+#
+# RCS: @(#) $Id: ascii85.test,v 1.1 2010/05/03 21:48:39 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+package require tcltest
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 1.0
+
+testing {
+ useLocal ascii85.tcl ascii85
+}
+
+# -------------------------------------------------------------------------
+# Encoding tests
+# -------------------------------------------------------------------------
+
+test ascii85-1.1 {ascii85::encode} {
+ ascii85::encode "this is a test\n"
+} {FD,B0+DGm>@3BZ'F*%`}
+
+test ascii85-1.2 {ascii85::encode wraps lines at 76 characters} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ ascii85::encode $str
+} {<+ohcF(fK4F<GU8A0>K&GT_$8DBNqABk(ppGp%3BEc6)5BHVD1AKYW+AS#a%AnbgmA0>;uA0>W0D
+/a&s+E)F7EZfI;AKZ)'Cht5'Ec6/>+C\njEXD}
+
+test ascii85-1.3 {ascii85::encode with wrap length set to 60} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ ascii85::encode -maxlen 60 $str
+} {<+ohcF(fK4F<GU8A0>K&GT_$8DBNqABk(ppGp%3BEc6)5BHVD1AKYW+AS#a%
+AnbgmA0>;uA0>W0D/a&s+E)F7EZfI;AKZ)'Cht5'Ec6/>+C\njEXD}
+
+test ascii85-1.4 {ascii85::encode with wrap length set to 0} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ ascii85::encode -maxlen 0 $str
+} {<+ohcF(fK4F<GU8A0>K&GT_$8DBNqABk(ppGp%3BEc6)5BHVD1AKYW+AS#a%AnbgmA0>;uA0>W0D/a&s+E)F7EZfI;AKZ)'Cht5'Ec6/>+C\njEXD}
+
+test ascii85-1.5 {ascii85::encode with wrap length set to 76, wrapchar to newline+space} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ ascii85::encode -maxlen 76 -wrapchar "\n " $str
+} {<+ohcF(fK4F<GU8A0>K&GT_$8DBNqABk(ppGp%3BEc6)5BHVD1AKYW+AS#a%AnbgmA0>;uA0>W0D
+ /a&s+E)F7EZfI;AKZ)'Cht5'Ec6/>+C\njEXD}
+
+test ascii85-1.6 {ascii85::encode, errors} {
+ list [catch {ascii85::encode} msg] $msg
+} [list 1 "wrong # args: should be \"ascii85::encode ?-maxlen maxlen? ?-wrapchar wrapchar? string\""]
+
+test ascii85-1.7 {ascii85::encode, errors} {
+ list [catch {ascii85::encode -maxlen foo} msg] $msg
+} [list 1 "wrong # args: should be \"ascii85::encode ?-maxlen maxlen? ?-wrapchar wrapchar? string\""]
+
+# changed form the original. ascii85 checks for correct # args before
+# checking for valid options. Now this test is duplicate of 1.12
+test ascii85-1.8 {ascii85::encode, errors} {
+ list [catch {ascii85::encode -maxlen foo bar} msg] $msg
+} [list 1 {expected positive integer but got "foo"}]
+
+test ascii85-1.9 {ascii85::encode, errors} {
+ list [catch {ascii85::encode -maxlen foo -wrapchar bar} msg] $msg
+} [list 1 "wrong # args: should be \"ascii85::encode ?-maxlen maxlen? ?-wrapchar wrapchar? string\""]
+
+test ascii85-1.10 {ascii85::encode, errors} {
+ list [catch {ascii85::encode -foo bar baz} msg] $msg
+} [list 1 "unknown option \"-foo\": must be -maxlen or -wrapchar"]
+
+test ascii85-1.11 {ascii85::encode with bogus wrap length (< 0)} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ list [catch { ascii85::encode -maxlen -3 $str } msg] $msg
+} {1 {expected positive integer but got "-3"}}
+
+# dulicate of 1.8
+test ascii85-1.12 {ascii85::encode with bogus wrap length (non-numeric)} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ list [catch { ascii85::encode -maxlen foo $str } msg] $msg
+} {1 {expected positive integer but got "foo"}}
+
+test ascii85-1.13 {ascii85::encode with bogus wrap length (non-integer)} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ list [catch { ascii85::encode -maxlen 1.5 $str } msg] $msg
+} {1 {expected positive integer but got "1.5"}}
+
+test ascii85-1.14 {ascii85::encode with wrap length set to 20} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ ascii85::encode -maxlen 20 $str
+} {<+ohcF(fK4F<GU8A0>K&
+GT_$8DBNqABk(ppGp%3B
+Ec6)5BHVD1AKYW+AS#a%
+AnbgmA0>;uA0>W0D/a&s
++E)F7EZfI;AKZ)'Cht5'
+Ec6/>+C\njEXD}
+
+test ascii85-1.15 {ascii85::encode with wrap length set to 23 (prime)} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ ascii85::encode -maxlen 23 $str
+} {<+ohcF(fK4F<GU8A0>K&GT_
+$8DBNqABk(ppGp%3BEc6)5B
+HVD1AKYW+AS#a%AnbgmA0>;
+uA0>W0D/a&s+E)F7EZfI;AK
+Z)'Cht5'Ec6/>+C\njEXD}
+
+test ascii85-1.16 {ascii85::encode string of length zero} {
+ ascii85::encode ""
+} ""
+
+# -------------------------------------------------------------------------
+# Decoding tests
+# -------------------------------------------------------------------------
+
+test ascii85-2.1 {ascii85::decode} {
+ ascii85::decode {FD,B0+DGm>@3BZ'F*%`}
+} "this is a test\n"
+
+test ascii85-2.2 {ascii85::decode ignores newlines} {
+ set str {<+ohcF(fK4F<GU8A0>K&GT_$8DBNqABk(ppGp%3BEc6)5BHVD1AKYW+AS#a%AnbgmA0>;uA0>W0D}
+ append str \n
+ append str {/a&s+E)F7EZfI;AKZ)'Cht5'Ec6/>+C\njEXD}
+ ascii85::decode $str
+} "The short red fox ran quickly through the green field and jumped over the tall brown bear\n"
+
+test ascii85-2.3 {ascii85::decode error chars not in range} {
+ list [catch {ascii85::decode "ab~cd"} msg] $msg
+} {1 {error decoding data: chars outside the allowed range}}
+
+test ascii85-2.4 {ascii85::decode error "z" char misplaced} {
+ list [catch {ascii85::decode "abczd"} msg] $msg
+} {1 {error decoding data: "z" char misplaced}}
+
+test ascii85-2.5 {ascii85::decode error trailing char} {
+ list [catch {ascii85::decode "abcde5"} msg] $msg
+} {1 {error decoding data: trailing char}}
+
+test ascii85-2.6 {ascii85::decode decoding of null chars} {
+ foreach enc [list !! !!! !!!! z z!!] {
+ lappend res [ascii85::decode $enc]
+ }
+ set res
+} [list \x00 \x00\x00 \x00\x00\x00 \x00\x00\x00\x00 \x00\x00\x00\x00\x00]
+
+test ascii85-2.7 {ascii85::decode integer range limit} {
+ ascii85::decode s8W-!
+} "\xff\xff\xff\xff"
+
+test ascii85-2.8 {ascii85::decode integer range overflow} {
+ list [catch {ascii85::decode {s8W-"}} msg] $msg
+} {1 {error decoding data: decoded group overflow}}
+
+test ascii85-2.9 {ascii85::decode of empty string} {
+ ascii85::decode ""
+} ""
+
+# -------------------------------------------------------------------------
+# Identity tests
+# -------------------------------------------------------------------------
+
+test ascii85-3.1 {ascii85 identity test} {
+ ascii85::decode [ascii85::encode "this is a test"]
+} "this is a test"
+
+test ascii85-3.2 {base64 identity test} {
+ set x \f\xee
+ set y [ascii85::decode [ascii85::encode $x]]
+ string compare $x $y
+} 0
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/base64/base64.bench b/tcllib/modules/base64/base64.bench
new file mode 100644
index 0000000..edfc2ef
--- /dev/null
+++ b/tcllib/modules/base64/base64.bench
@@ -0,0 +1,61 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'base64' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+set moddir [file dirname [file dirname [info script]]]
+lappend auto_path $moddir
+
+package forget base64
+catch {namespace delete ::base64}
+source [file join [file dirname [info script]] base64.tcl]
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+
+foreach n {10 100 1000 10000} {
+ bench -desc "BASE64 encode ${n}X" -pre {
+ set str [string repeat X $n]
+ } -body {
+ base64::encode $str
+ } -post {
+ unset str
+ }
+
+ bench -desc "BASE64 decode ${n}X" -pre {
+ set str [base64::encode [string repeat X $n]]
+ } -body {
+ base64::decode $str
+ } -post {
+ unset str
+ }
+}
+
+foreach wrap {1 10 60 100} {
+ foreach n {10 100 1000 10000} {
+ bench -desc "BASE64 encode ${n}X -wrap $wrap" -pre {
+ set str [string repeat X $n]
+ } -body {
+ base64::encode -wrap $wrap $str
+ } -post {
+ unset str
+ }
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/base64/base64.man b/tcllib/modules/base64/base64.man
new file mode 100644
index 0000000..c20274c
--- /dev/null
+++ b/tcllib/modules/base64/base64.man
@@ -0,0 +1,70 @@
+[manpage_begin base64 n 2.4.2]
+[keywords base64]
+[keywords encoding]
+[copyright {2000, Eric Melski}]
+[copyright {2001, Miguel Sofer}]
+[moddesc {Text encoding & decoding binary data}]
+[titledesc {base64-encode/decode binary data}]
+[category {Text processing}]
+[require Tcl 8]
+[require base64 [opt 2.4.2]]
+[description]
+[para]
+
+This package provides procedures to encode binary data into base64 and back.
+
+[list_begin definitions]
+
+[call [cmd ::base64::encode] [opt "[option -maxlen] [arg maxlen]"] [opt "[option -wrapchar] [arg wrapchar]"] [arg string]]
+
+Base64 encodes the given binary [arg string] and returns the encoded
+result. Inserts the character [arg wrapchar] every [arg maxlen]
+characters of output. [arg wrapchar] defaults to newline. [arg maxlen]
+defaults to [const 76].
+
+[para] [emph Note] that if [arg maxlen] is set to [const 0], the
+output will not be wrapped at all.
+
+[para]
+
+[emph {Note well}]: If your string is not simple ascii you should fix
+the string encoding before doing base64 encoding. See the examples.
+
+[para]
+
+The command will throw an error for negative values of [arg maxlen],
+or if [arg maxlen] is not an integer number.
+
+[call [cmd ::base64::decode] [arg "string"]]
+
+Base64 decodes the given [arg "string"] and returns the binary data.
+The decoder ignores whitespace in the string.
+
+[list_end]
+
+[section {EXAMPLES}]
+
+[example {
+% base64::encode "Hello, world"
+SGVsbG8sIHdvcmxk
+}]
+
+[example {
+% base64::encode [string repeat xyz 20]
+eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6
+eHl6eHl6eHl6
+% base64::encode -wrapchar "" [string repeat xyz 20]
+eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6eHl6
+}]
+
+[example {
+# NOTE: base64 encodes BINARY strings.
+% set chemical [encoding convertto utf-8 "C\u2088H\u2081\u2080N\u2084O\u2082"]
+% set encoded [base64::encode $chemical]
+Q+KCiEjigoHigoBO4oKET+KCgg==
+% set caffeine [encoding convertfrom utf-8 [base64::decode $encoded]]
+}]
+
+[vset CATEGORY base64]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/base64/base64.pcx b/tcllib/modules/base64/base64.pcx
new file mode 100644
index 0000000..f61f4c0
--- /dev/null
+++ b/tcllib/modules/base64/base64.pcx
@@ -0,0 +1,65 @@
+# -*- tcl -*- base64.pcx
+# Syntax of the commands provided by package base64.
+#
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register base64
+pcx::tcldep 2.3.2 needs tcl 8.2
+
+namespace eval ::base64 {}
+
+# Using the indirections below looks to be quite pointless, given that
+# they simply substitute the commands for others. I am doing this for
+# two reasons.
+
+# First, the rules coming after become self-commenting, i.e. a
+# maintainer can immediately see what an argument is supposed to be,
+# instead of having to search elsewhere (like the documentation and
+# implementation). In this manner our definitions here are a type of
+# semantic markup.
+
+# The second reason is that while we have no special checks now we
+# cannot be sure if such will (have to) be added in the future. With
+# all checking routed through our definitions we now already have the
+# basic infrastructure (i.e. hooks) in place in which we can easily
+# add any new checks by simply redefining the relevant command, and
+# all the rules update on their own. Mostly. This should cover 90% of
+# the cases. Sometimes new checks will require to create deeper
+# distinctions between different calls of the same thing. For such we
+# may have to update the rules as well, to provide the necessary
+# information to the checker.
+
+interp alias {} base64::checkLineLength {} checkInt ; #
+interp alias {} base64::checkWrapChar {} checkWord ; #
+interp alias {} base64::checkData {} checkWord ; #
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 2.3.2 std ::base64::decode \
+ {checkSimpleArgs 1 1 {
+ base64::checkData
+ }}
+
+# NOTE: Is '-maxlen' < 0 allowed?
+# Doc doesn't forbid it, code doesn't catch it.
+# May crash it however, i.e be a bug.
+# Check testsuite.
+pcx::check 2.3.2 std ::base64::encode \
+ {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ {-maxlen base64::checkLineLength}
+ {-wrapchar base64::checkWrapChar}
+ } {checkSimpleArgs 1 1 {
+ base64::checkData
+ }}}
+ }}
+
+# Initialization via pcx::init.
+# Use a ::base64::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/base64/base64.tcl b/tcllib/modules/base64/base64.tcl
new file mode 100644
index 0000000..5d3d538
--- /dev/null
+++ b/tcllib/modules/base64/base64.tcl
@@ -0,0 +1,387 @@
+# base64.tcl --
+#
+# Encode/Decode base64 for a string
+# Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems
+# The decoder was done for exmh by Chris Garrigues
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: base64.tcl,v 1.32 2010/07/06 19:15:40 andreas_kupries Exp $
+
+# Version 1.0 implemented Base64_Encode, Base64_Decode
+# Version 2.0 uses the base64 namespace
+# Version 2.1 fixes various decode bugs and adds options to encode
+# Version 2.2 is much faster, Tcl8.0 compatible
+# Version 2.2.1 bugfixes
+# Version 2.2.2 bugfixes
+# Version 2.3 bugfixes and extended to support Trf
+
+# @mdgen EXCLUDE: base64c.tcl
+
+package require Tcl 8.2
+namespace eval ::base64 {
+ namespace export encode decode
+}
+
+if {![catch {package require Trf 2.0}]} {
+ # Trf is available, so implement the functionality provided here
+ # in terms of calls to Trf for speed.
+
+ # ::base64::encode --
+ #
+ # Base64 encode a given string.
+ #
+ # Arguments:
+ # args ?-maxlen maxlen? ?-wrapchar wrapchar? string
+ #
+ # If maxlen is 0, the output is not wrapped.
+ #
+ # Results:
+ # A Base64 encoded version of $string, wrapped at $maxlen characters
+ # by $wrapchar.
+
+ proc ::base64::encode {args} {
+ # Set the default wrapchar and maximum line length to match
+ # the settings for MIME encoding (RFC 3548, RFC 2045). These
+ # are the settings used by Trf as well. Various RFCs allow for
+ # different wrapping characters and wraplengths, so these may
+ # be overridden by command line options.
+ set wrapchar "\n"
+ set maxlen 76
+
+ if { [llength $args] == 0 } {
+ error "wrong # args: should be \"[lindex [info level 0] 0]\
+ ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
+ }
+
+ set optionStrings [list "-maxlen" "-wrapchar"]
+ for {set i 0} {$i < [llength $args] - 1} {incr i} {
+ set arg [lindex $args $i]
+ set index [lsearch -glob $optionStrings "${arg}*"]
+ if { $index == -1 } {
+ error "unknown option \"$arg\": must be -maxlen or -wrapchar"
+ }
+ incr i
+ if { $i >= [llength $args] - 1 } {
+ error "value for \"$arg\" missing"
+ }
+ set val [lindex $args $i]
+
+ # The name of the variable to assign the value to is extracted
+ # from the list of known options, all of which have an
+ # associated variable of the same name as the option without
+ # a leading "-". The [string range] command is used to strip
+ # of the leading "-" from the name of the option.
+ #
+ # FRINK: nocheck
+ set [string range [lindex $optionStrings $index] 1 end] $val
+ }
+
+ # [string is] requires Tcl8.2; this works with 8.0 too
+ if {[catch {expr {$maxlen % 2}}]} {
+ return -code error "expected integer but got \"$maxlen\""
+ } elseif {$maxlen < 0} {
+ return -code error "expected positive integer but got \"$maxlen\""
+ }
+
+ set string [lindex $args end]
+ set result [::base64 -mode encode -- $string]
+
+ # Trf's encoder implicitly uses the settings -maxlen 76,
+ # -wrapchar \n for its output. We may have to reflow this for
+ # the settings chosen by the user. A second difference is that
+ # Trf closes the output with the wrap char sequence,
+ # always. The code here doesn't. Therefore 'trimright' is
+ # needed in the fast cases.
+
+ if {($maxlen == 76) && [string equal $wrapchar \n]} {
+ # Both maxlen and wrapchar are identical to Trf's
+ # settings. This is the super-fast case, because nearly
+ # nothing has to be done. Only thing to do is strip a
+ # terminating wrapchar.
+ set result [string trimright $result]
+ } elseif {$maxlen == 76} {
+ # wrapchar has to be different here, length is the
+ # same. We can use 'string map' to transform the wrap
+ # information.
+ set result [string map [list \n $wrapchar] \
+ [string trimright $result]]
+ } elseif {$maxlen == 0} {
+ # Have to reflow the output to no wrapping. Another fast
+ # case using only 'string map'. 'trimright' is not needed
+ # here.
+
+ set result [string map [list \n ""] $result]
+ } else {
+ # Have to reflow the output from 76 to the chosen maxlen,
+ # and possibly change the wrap sequence as well.
+
+ # Note: After getting rid of the old wrap sequence we
+ # extract the relevant segments from the string without
+ # modifying the string. Modification, i.e. removal of the
+ # processed part, means 'shifting down characters in
+ # memory', making the algorithm O(n^2). By avoiding the
+ # modification we stay in O(n).
+
+ set result [string map [list \n ""] $result]
+ set l [expr {[string length $result]-$maxlen}]
+ for {set off 0} {$off < $l} {incr off $maxlen} {
+ append res [string range $result $off [expr {$off+$maxlen-1}]] $wrapchar
+ }
+ append res [string range $result $off end]
+ set result $res
+ }
+
+ return $result
+ }
+
+ # ::base64::decode --
+ #
+ # Base64 decode a given string.
+ #
+ # Arguments:
+ # string The string to decode. Characters not in the base64
+ # alphabet are ignored (e.g., newlines)
+ #
+ # Results:
+ # The decoded value.
+
+ proc ::base64::decode {string} {
+ regsub -all {\s} $string {} string
+ ::base64 -mode decode -- $string
+ }
+
+} else {
+ # Without Trf use a pure tcl implementation
+
+ namespace eval base64 {
+ variable base64 {}
+ variable base64_en {}
+
+ # We create the auxiliary array base64_tmp, it will be unset later.
+ variable base64_tmp
+ variable i
+
+ set i 0
+ foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
+ a b c d e f g h i j k l m n o p q r s t u v w x y z \
+ 0 1 2 3 4 5 6 7 8 9 + /} {
+ set base64_tmp($char) $i
+ lappend base64_en $char
+ incr i
+ }
+
+ #
+ # Create base64 as list: to code for instance C<->3, specify
+ # that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded
+ # ascii chars get a {}. we later use the fact that lindex on a
+ # non-existing index returns {}, and that [expr {} < 0] is true
+ #
+
+ # the last ascii char is 'z'
+ variable char
+ variable len
+ variable val
+
+ scan z %c len
+ for {set i 0} {$i <= $len} {incr i} {
+ set char [format %c $i]
+ set val {}
+ if {[info exists base64_tmp($char)]} {
+ set val $base64_tmp($char)
+ } else {
+ set val {}
+ }
+ lappend base64 $val
+ }
+
+ # code the character "=" as -1; used to signal end of message
+ scan = %c i
+ set base64 [lreplace $base64 $i $i -1]
+
+ # remove unneeded variables
+ unset base64_tmp i char len val
+
+ namespace export encode decode
+ }
+
+ # ::base64::encode --
+ #
+ # Base64 encode a given string.
+ #
+ # Arguments:
+ # args ?-maxlen maxlen? ?-wrapchar wrapchar? string
+ #
+ # If maxlen is 0, the output is not wrapped.
+ #
+ # Results:
+ # A Base64 encoded version of $string, wrapped at $maxlen characters
+ # by $wrapchar.
+
+ proc ::base64::encode {args} {
+ set base64_en $::base64::base64_en
+
+ # Set the default wrapchar and maximum line length to match
+ # the settings for MIME encoding (RFC 3548, RFC 2045). These
+ # are the settings used by Trf as well. Various RFCs allow for
+ # different wrapping characters and wraplengths, so these may
+ # be overridden by command line options.
+ set wrapchar "\n"
+ set maxlen 76
+
+ if { [llength $args] == 0 } {
+ error "wrong # args: should be \"[lindex [info level 0] 0]\
+ ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
+ }
+
+ set optionStrings [list "-maxlen" "-wrapchar"]
+ for {set i 0} {$i < [llength $args] - 1} {incr i} {
+ set arg [lindex $args $i]
+ set index [lsearch -glob $optionStrings "${arg}*"]
+ if { $index == -1 } {
+ error "unknown option \"$arg\": must be -maxlen or -wrapchar"
+ }
+ incr i
+ if { $i >= [llength $args] - 1 } {
+ error "value for \"$arg\" missing"
+ }
+ set val [lindex $args $i]
+
+ # The name of the variable to assign the value to is extracted
+ # from the list of known options, all of which have an
+ # associated variable of the same name as the option without
+ # a leading "-". The [string range] command is used to strip
+ # of the leading "-" from the name of the option.
+ #
+ # FRINK: nocheck
+ set [string range [lindex $optionStrings $index] 1 end] $val
+ }
+
+ # [string is] requires Tcl8.2; this works with 8.0 too
+ if {[catch {expr {$maxlen % 2}}]} {
+ return -code error "expected integer but got \"$maxlen\""
+ } elseif {$maxlen < 0} {
+ return -code error "expected positive integer but got \"$maxlen\""
+ }
+
+ set string [lindex $args end]
+
+ set result {}
+ set state 0
+ set length 0
+
+
+ # Process the input bytes 3-by-3
+
+ binary scan $string c* X
+
+ foreach {x y z} $X {
+ ADD [lindex $base64_en [expr {($x >>2) & 0x3F}]]
+ if {$y != {}} {
+ ADD [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]]
+ if {$z != {}} {
+ ADD [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]]
+ ADD [lindex $base64_en [expr {($z & 0x3F)}]]
+ } else {
+ set state 2
+ break
+ }
+ } else {
+ set state 1
+ break
+ }
+ }
+ if {$state == 1} {
+ ADD [lindex $base64_en [expr {(($x << 4) & 0x30)}]]
+ ADD =
+ ADD =
+ } elseif {$state == 2} {
+ ADD [lindex $base64_en [expr {(($y << 2) & 0x3C)}]]
+ ADD =
+ }
+ return $result
+ }
+
+ proc ::base64::ADD {x} {
+ # The line length check is always done before appending so
+ # that we don't get an extra newline if the output is a
+ # multiple of $maxlen chars long.
+
+ upvar 1 maxlen maxlen length length result result wrapchar wrapchar
+ if {$maxlen && $length >= $maxlen} {
+ append result $wrapchar
+ set length 0
+ }
+ append result $x
+ incr length
+ return
+ }
+
+ # ::base64::decode --
+ #
+ # Base64 decode a given string.
+ #
+ # Arguments:
+ # string The string to decode. Characters not in the base64
+ # alphabet are ignored (e.g., newlines)
+ #
+ # Results:
+ # The decoded value.
+
+ proc ::base64::decode {string} {
+ if {[string length $string] == 0} {return ""}
+
+ set base64 $::base64::base64
+ set output "" ; # Fix for [Bug 821126]
+
+ binary scan $string c* X
+ foreach x $X {
+ set bits [lindex $base64 $x]
+ if {$bits >= 0} {
+ if {[llength [lappend nums $bits]] == 4} {
+ foreach {v w z y} $nums break
+ set a [expr {($v << 2) | ($w >> 4)}]
+ set b [expr {(($w & 0xF) << 4) | ($z >> 2)}]
+ set c [expr {(($z & 0x3) << 6) | $y}]
+ append output [binary format ccc $a $b $c]
+ set nums {}
+ }
+ } elseif {$bits == -1} {
+ # = indicates end of data. Output whatever chars are left.
+ # The encoding algorithm dictates that we can only have 1 or 2
+ # padding characters. If x=={}, we must (*) have 12 bits of input
+ # (enough for 1 8-bit output). If x!={}, we have 18 bits of
+ # input (enough for 2 8-bit outputs).
+ #
+ # (*) If we don't then the input is broken (bug 2976290).
+
+ foreach {v w z} $nums break
+
+ # Bug 2976290
+ if {$w == {}} {
+ return -code error "Not enough data to process padding"
+ }
+
+ set a [expr {($v << 2) | (($w & 0x30) >> 4)}]
+ if {$z == {}} {
+ append output [binary format c $a ]
+ } else {
+ set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}]
+ append output [binary format cc $a $b]
+ }
+ break
+ } else {
+ # RFC 2045 says that line breaks and other characters not part
+ # of the Base64 alphabet must be ignored, and that the decoder
+ # can optionally emit a warning or reject the message. We opt
+ # not to do so, but to just ignore the character.
+ continue
+ }
+ }
+ return $output
+ }
+}
+
+package provide base64 2.4.2
diff --git a/tcllib/modules/base64/base64.test b/tcllib/modules/base64/base64.test
new file mode 100644
index 0000000..926a16d
--- /dev/null
+++ b/tcllib/modules/base64/base64.test
@@ -0,0 +1,162 @@
+# Tests for the base64 module. -*- tcl -*-
+#
+# 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) 1998-2000 by Ajuba Solutions.
+# All rights reserved.
+#
+# RCS: @(#) $Id: base64.test,v 1.17 2011/11/09 04:31:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal base64.tcl base64
+}
+
+# -------------------------------------------------------------------------
+
+if {[catch {package present Trf}]} {
+ puts "> pure Tcl"
+ tcltest::testConstraint trf 0
+} else {
+ puts "> Trf based"
+ tcltest::testConstraint trf 1
+}
+
+# -------------------------------------------------------------------------
+
+test base64-1.1 {base64::encode} {
+ base64::encode "this is a test\n"
+} "dGhpcyBpcyBhIHRlc3QK"
+test base64-1.2 {base64::encode wraps lines at 76 characters} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ base64::encode $str
+} "VGhlIHNob3J0IHJlZCBmb3ggcmFuIHF1aWNrbHkgdGhyb3VnaCB0aGUgZ3JlZW4gZmllbGQgYW5k
+IGp1bXBlZCBvdmVyIHRoZSB0YWxsIGJyb3duIGJlYXIK"
+test base64-1.3 {base64::encode with wrap length set to 60} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ base64::encode -maxlen 60 $str
+} "VGhlIHNob3J0IHJlZCBmb3ggcmFuIHF1aWNrbHkgdGhyb3VnaCB0aGUgZ3Jl
+ZW4gZmllbGQgYW5kIGp1bXBlZCBvdmVyIHRoZSB0YWxsIGJyb3duIGJlYXIK"
+test base64-1.4 {base64::encode with wrap length set to 0} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ base64::encode -maxlen 0 $str
+} "VGhlIHNob3J0IHJlZCBmb3ggcmFuIHF1aWNrbHkgdGhyb3VnaCB0aGUgZ3JlZW4gZmllbGQgYW5kIGp1bXBlZCBvdmVyIHRoZSB0YWxsIGJyb3duIGJlYXIK"
+test base64-1.5 {base64::encode with wrap length set to 76, wrapchar to newline+space} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ base64::encode -maxlen 76 -wrapchar "\n " $str
+} "VGhlIHNob3J0IHJlZCBmb3ggcmFuIHF1aWNrbHkgdGhyb3VnaCB0aGUgZ3JlZW4gZmllbGQgYW5k
+ IGp1bXBlZCBvdmVyIHRoZSB0YWxsIGJyb3duIGJlYXIK"
+test base64-1.6 {base64::encode, errors} {
+ list [catch {base64::encode} msg] $msg
+} [list 1 "wrong # args: should be \"base64::encode ?-maxlen maxlen? ?-wrapchar wrapchar? string\""]
+test base64-1.7 {base64::encode, errors} {
+ list [catch {base64::encode -maxlen foo} msg] $msg
+} [list 1 "value for \"-maxlen\" missing"]
+test base64-1.8 {base64::encode, errors} {
+ list [catch {base64::encode -maxlen foo bar} msg] $msg
+} [list 1 "expected integer but got \"foo\""]
+test base64-1.9 {base64::encode, errors} {
+ list [catch {base64::encode -maxlen foo -wrapchar bar} msg] $msg
+} [list 1 "value for \"-wrapchar\" missing"]
+test base64-1.10 {base64::encode, errors} {
+ list [catch {base64::encode -foo bar} msg] $msg
+} [list 1 "unknown option \"-foo\": must be -maxlen or -wrapchar"]
+test base64-1.11 {base64::encode with bogus wrap length (< 0)} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ list [catch { base64::encode -maxlen -3 $str } msg] $msg
+} {1 {expected positive integer but got "-3"}}
+test base64-1.12 {base64::encode with bogus wrap length (non-numeric)} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ list [catch { base64::encode -maxlen foo $str } msg] $msg
+} {1 {expected integer but got "foo"}}
+test base64-1.13 {base64::encode with bogus wrap length (non-integer)} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ list [catch { base64::encode -maxlen 1.5 $str } msg] $msg
+} {1 {expected integer but got "1.5"}}
+test base64-1.14 {base64::encode with wrap length set to 20} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ base64::encode -maxlen 20 $str
+} "VGhlIHNob3J0IHJlZCBm
+b3ggcmFuIHF1aWNrbHkg
+dGhyb3VnaCB0aGUgZ3Jl
+ZW4gZmllbGQgYW5kIGp1
+bXBlZCBvdmVyIHRoZSB0
+YWxsIGJyb3duIGJlYXIK"
+test base64-1.15 {base64::encode with wrap length set to 23 (prime)} {
+ set str "The short red fox ran quickly through the green field "
+ append str "and jumped over the tall brown bear\n"
+ base64::encode -maxlen 23 $str
+} "VGhlIHNob3J0IHJlZCBmb3g
+gcmFuIHF1aWNrbHkgdGhyb3
+VnaCB0aGUgZ3JlZW4gZmllb
+GQgYW5kIGp1bXBlZCBvdmVy
+IHRoZSB0YWxsIGJyb3duIGJ
+lYXIK"
+
+
+test base64-2.1 {base64::decode} {
+ base64::decode "dGhpcyBpcyBhIHRlc3QK"
+} "this is a test\n"
+test base64-2.2 {base64::decode ignores newlines} {
+ set str "VGhlIHNob3J0IHJlZCBmb3ggcmFuIHF1aWNrbHkgdGhyb3VnaCB0aGUgZ3Jl\n"
+ append str "ZW4gZmllbGQgYW5kIGp1bXBlZCBvdmVyIHRoZSB0YWxsIGJyb3duIGJlYXIK"
+ base64::decode $str
+} "The short red fox ran quickly through the green field and jumped over the tall brown bear\n"
+test base64-2.3 {base64::decode handles equal sign padding} {
+ # decode the encoding of a string that will be padded in the encoding with
+ # one padding char
+ base64::decode [base64::encode "01234"]
+} "01234"
+test base64-2.4 {base64::decode handles equal sign padding} {
+ # decode the encoding of a string that will be padded in the encoding with
+ # two padding chars
+ base64::decode [base64::encode "0123"]
+} "0123"
+
+
+test base64-2.5 {base64::decode} {
+ base64::decode ""
+} ""
+test base64-2.6 {base64::decode} {
+ base64::decode " "
+} ""
+
+
+test base64-3.1 {base64 identity test} {
+ base64::decode [base64::encode "this is a test"]
+} "this is a test"
+test base64-3.2 {base64 identity test} {
+ # This test fails on version 1.5 because of the format %04x bug
+ # when handling the last characters
+ set x \f\xee
+ set y [base64::decode [base64::encode $x]]
+ string compare $x $y
+} 0
+
+# For trf a known bug.
+test base64-4.0 {base64 -- sf bug 2976290} {!trf} {
+ list [catch {
+ ::base64::decode s=GQMRAk5WXhsABh0NEx4RXBocBVgBHQMXHRgEFltMQENQXEFOExJVQ0RAQERUQ0dAEhYEExVIRRVVFENWKxMKABsPGBI6LRoYLhsEFhsXGFkXEwZXGQMIHg==
+ } msg] $msg
+} {1 {Not enough data to process padding}}
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/base64/base64c.tcl b/tcllib/modules/base64/base64c.tcl
new file mode 100644
index 0000000..29e501d
--- /dev/null
+++ b/tcllib/modules/base64/base64c.tcl
@@ -0,0 +1,19 @@
+# base64c - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# This package is a place-holder for the critcl enhanced code present in
+# the tcllib base64 module.
+#
+# Normally this code will become part of the tcllibc library.
+#
+
+# @sak notprovided base64c
+package require critcl
+package provide base64c 0.1.0
+
+namespace eval ::base64c {
+ variable base64c_rcsid {$Id: base64c.tcl,v 1.5 2008/03/25 07:15:35 andreas_kupries Exp $}
+
+ critcl::ccode {
+ /* no code required in this file */
+ }
+}
diff --git a/tcllib/modules/base64/pkgIndex.tcl b/tcllib/modules/base64/pkgIndex.tcl
new file mode 100644
index 0000000..c23b090
--- /dev/null
+++ b/tcllib/modules/base64/pkgIndex.tcl
@@ -0,0 +1,5 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded base64 2.4.2 [list source [file join $dir base64.tcl]]
+package ifneeded uuencode 1.1.5 [list source [file join $dir uuencode.tcl]]
+package ifneeded yencode 1.1.3 [list source [file join $dir yencode.tcl]]
+package ifneeded ascii85 1.0 [list source [file join $dir ascii85.tcl]]
diff --git a/tcllib/modules/base64/uuencode.bench b/tcllib/modules/base64/uuencode.bench
new file mode 100644
index 0000000..714cfe9
--- /dev/null
+++ b/tcllib/modules/base64/uuencode.bench
@@ -0,0 +1,46 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'uuencode' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+package forget uuencode
+catch {namespace delete ::uuencode}
+source [file join [file dirname [info script]] uuencode.tcl]
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+
+foreach n {10 100 1000 10000} {
+ bench -desc "UUENCODE encode ${n}X" -pre {
+ set str [string repeat X $n]
+ } -body {
+ uuencode::encode $str
+ } -post {
+ unset str
+ }
+
+ bench -desc "UUENCODE decode ${n}X" -pre {
+ set str [uuencode::encode [string repeat X $n]]
+ } -body {
+ uuencode::decode $str
+ } -post {
+ unset str
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/base64/uuencode.man b/tcllib/modules/base64/uuencode.man
new file mode 100644
index 0000000..c701a56
--- /dev/null
+++ b/tcllib/modules/base64/uuencode.man
@@ -0,0 +1,97 @@
+[manpage_begin uuencode n 1.1.4]
+[keywords encoding]
+[keywords uuencode]
+[copyright {2002, Pat Thoyts}]
+[moddesc {Text encoding & decoding binary data}]
+[titledesc {UU-encode/decode binary data}]
+[category {Text processing}]
+[require Tcl 8]
+[require uuencode [opt 1.1.4]]
+[description]
+[para]
+
+This package provides a Tcl-only implementation of the
+[syscmd uuencode(1)] and [syscmd uudecode(1)] commands. This encoding
+packs binary data into printable ASCII characters.
+
+[list_begin definitions]
+
+[call [cmd ::uuencode::encode] [arg string]]
+
+returns the uuencoded data. This will encode all the data passed in
+even if this is longer than the uuencode maximum line length. If the
+number of input bytes is not a multiple of 3 then additional 0 bytes
+are added to pad the string.
+
+[call [cmd ::uuencode::decode] [arg string]]
+
+Decodes the given encoded data. This will return any padding
+characters as well and it is the callers responsibility to deal with
+handling the actual length of the encoded data. (see uuencode).
+
+[call [cmd ::uuencode::uuencode] [opt "[option -name] [arg string]"] [opt "[option -mode] [arg octal]"] "([option -file] [arg filename] | [opt [option --]] [arg string])"]
+
+[call [cmd ::uuencode::uudecode] "([option -file] [arg filename] | [opt [option --]] [arg string])"]
+
+UUDecode a file or block of data. A file may contain more than one
+embedded file so the result is a list where each element is a three
+element list of filename, mode value and data.
+
+[list_end]
+
+[section OPTIONS]
+
+[list_begin definitions]
+
+[def "-filename name"]
+
+Cause the uuencode or uudecode commands to read their data from the
+named file rather that taking a string parameter.
+
+[def "-name string"]
+
+The uuencoded data header line contains the suggested file name to be
+used when unpacking the data. Use this option to change this from the
+default of "data.dat".
+
+[def "-mode octal"]
+
+The uuencoded data header line contains a suggested permissions bit
+pattern expressed as an octal string. To change the default of 0644
+you can set this option. For instance, 0755 would be suitable for an
+executable. See [syscmd chmod(1)].
+
+[list_end]
+
+[section EXAMPLES]
+
+[para]
+[example {
+% set d [uuencode::encode "Hello World!"]
+2&5L;&\\@5V]R;&0A
+}]
+
+[para]
+[example {
+% uuencode::uudecode $d
+Hello World!
+}]
+
+[para]
+[example {
+% set d [uuencode::uuencode -name hello.txt "Hello World"]
+begin 644 hello.txt
++2&5L;&\@5V]R;&0`
+`
+end
+}]
+
+[para]
+[example {
+% uuencode::uudecode $d
+{hello.txt 644 {Hello World}}
+}]
+
+[vset CATEGORY base64]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/base64/uuencode.pcx b/tcllib/modules/base64/uuencode.pcx
new file mode 100644
index 0000000..13e122d
--- /dev/null
+++ b/tcllib/modules/base64/uuencode.pcx
@@ -0,0 +1,74 @@
+# -*- tcl -*- uuencode.pcx
+# Syntax of the commands provided by package uuencode.
+#
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register uuencode
+pcx::tcldep 1.1.4 needs tcl 8.2
+
+namespace eval ::uuencode {}
+
+# Using the indirections below looks to be quite pointless, given that
+# they simply substitute the commands for others. I am doing this for
+# two reasons.
+
+# First, the rules coming after become self-commenting, i.e. a
+# maintainer can immediately see what an argument is supposed to be,
+# instead of having to search elsewhere (like the documentation and
+# implementation). In this manner our definitions here are a type of
+# semantic markup.
+
+# The second reason is that while we have no special checks now we
+# cannot be sure if such will (have to) be added in the future. With
+# all checking routed through our definitions we now already have the
+# basic infrastructure (i.e. hooks) in place in which we can easily
+# add any new checks by simply redefining the relevant command, and
+# all the rules update on their own. Mostly. This should cover 90% of
+# the cases. Sometimes new checks will require to create deeper
+# distinctions between different calls of the same thing. For such we
+# may have to update the rules as well, to provide the necessary
+# information to the checker.
+
+interp alias {} uuencode::checkMode {} checkWord ; #
+interp alias {} uuencode::checkDstFilename {} checkWord ; #
+interp alias {} uuencode::checkData {} checkWord ; #
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.1.4 std ::uuencode::uudecode \
+ {checkConstrained {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ {-filename {checkSetConstraint hasfilename checkFileName}}
+ --
+ } {checkConstraint {
+ {hasfilename {checkSimpleArgs 0 0 {}}}
+ {!hasfilename {checkSimpleArgs 1 1 {
+ uuencode::checkData
+ }}}
+ } {}}}
+ }}}
+# TODO: Limit -mode to a octal numbers (file permissions)
+pcx::check 1.1.4 std ::uuencode::uuencode \
+ {checkConstrained {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ {-filename {checkSetConstraint hasfilename checkFileName}}
+ {-mode uuencode::checkMode}
+ {-name uuencode::checkDstFilename}
+ --
+ } {checkConstraint {
+ {hasfilename {checkSimpleArgs 0 0 {}}}
+ {!hasfilename {checkSimpleArgs 1 1 {
+ uuencode::checkData
+ }}}
+ } {}}}
+ }}}
+
+# Initialization via pcx::init.
+# Use a ::uuencode::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/base64/uuencode.tcl b/tcllib/modules/base64/uuencode.tcl
new file mode 100644
index 0000000..e0e9862
--- /dev/null
+++ b/tcllib/modules/base64/uuencode.tcl
@@ -0,0 +1,335 @@
+# uuencode - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Provide a Tcl only implementation of uuencode and uudecode.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.2; # tcl minimum version
+
+# Try and get some compiled helper package.
+if {[catch {package require tcllibc}]} {
+ catch {package require Trf}
+}
+
+namespace eval ::uuencode {
+ namespace export encode decode uuencode uudecode
+}
+
+proc ::uuencode::Enc {c} {
+ return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]]
+}
+
+proc ::uuencode::Encode {s} {
+ set r {}
+ binary scan $s c* d
+ foreach {c1 c2 c3} $d {
+ if {$c1 == {}} {set c1 0}
+ if {$c2 == {}} {set c2 0}
+ if {$c3 == {}} {set c3 0}
+ append r [Enc [expr {$c1 >> 2}]]
+ append r [Enc [expr {(($c1 << 4) & 060) | (($c2 >> 4) & 017)}]]
+ append r [Enc [expr {(($c2 << 2) & 074) | (($c3 >> 6) & 003)}]]
+ append r [Enc [expr {($c3 & 077)}]]
+ }
+ return $r
+}
+
+
+proc ::uuencode::Decode {s} {
+ if {[string length $s] == 0} {return ""}
+ set r {}
+ binary scan [pad $s] c* d
+
+ foreach {c0 c1 c2 c3} $d {
+ append r [format %c [expr {((($c0-0x20)&0x3F) << 2) & 0xFF
+ | ((($c1-0x20)&0x3F) >> 4) & 0xFF}]]
+ append r [format %c [expr {((($c1-0x20)&0x3F) << 4) & 0xFF
+ | ((($c2-0x20)&0x3F) >> 2) & 0xFF}]]
+ append r [format %c [expr {((($c2-0x20)&0x3F) << 6) & 0xFF
+ | (($c3-0x20)&0x3F) & 0xFF}]]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# C coded version of the Encode/Decode functions for base64c package.
+# -------------------------------------------------------------------------
+if {[package provide critcl] != {}} {
+ namespace eval ::uuencode {
+ critcl::ccode {
+ #include <string.h>
+ static unsigned char Enc(unsigned char c) {
+ return (c != 0) ? ((c & 0x3f) + 0x20) : 0x60;
+ }
+ }
+ critcl::ccommand CEncode {dummy interp objc objv} {
+ Tcl_Obj *inputPtr, *resultPtr;
+ int len, rlen, xtra;
+ unsigned char *input, *p, *r;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "data");
+ return TCL_ERROR;
+ }
+
+ inputPtr = objv[1];
+ input = Tcl_GetByteArrayFromObj(inputPtr, &len);
+ if ((xtra = (3 - (len % 3))) != 3) {
+ if (Tcl_IsShared(inputPtr))
+ inputPtr = Tcl_DuplicateObj(inputPtr);
+ input = Tcl_SetByteArrayLength(inputPtr, len + xtra);
+ memset(input + len, 0, xtra);
+ len += xtra;
+ }
+
+ rlen = (len / 3) * 4;
+ resultPtr = Tcl_NewObj();
+ r = Tcl_SetByteArrayLength(resultPtr, rlen);
+ memset(r, 0, rlen);
+
+ for (p = input; p < input + len; p += 3) {
+ char a, b, c;
+ a = *p; b = *(p+1), c = *(p+2);
+ *r++ = Enc(a >> 2);
+ *r++ = Enc(((a << 4) & 060) | ((b >> 4) & 017));
+ *r++ = Enc(((b << 2) & 074) | ((c >> 6) & 003));
+ *r++ = Enc(c & 077);
+ }
+ Tcl_SetObjResult(interp, resultPtr);
+ return TCL_OK;
+ }
+
+ critcl::ccommand CDecode {dummy interp objc objv} {
+ Tcl_Obj *inputPtr, *resultPtr;
+ int len, rlen, xtra;
+ unsigned char *input, *p, *r;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "data");
+ return TCL_ERROR;
+ }
+
+ /* if input is not mod 4, extend it with nuls */
+ inputPtr = objv[1];
+ input = Tcl_GetByteArrayFromObj(inputPtr, &len);
+ if ((xtra = (4 - (len % 4))) != 4) {
+ if (Tcl_IsShared(inputPtr))
+ inputPtr = Tcl_DuplicateObj(inputPtr);
+ input = Tcl_SetByteArrayLength(inputPtr, len + xtra);
+ memset(input + len, 0, xtra);
+ len += xtra;
+ }
+
+ /* output will be 1/3 smaller than input and a multiple of 3 */
+ rlen = (len / 4) * 3;
+ resultPtr = Tcl_NewObj();
+ r = Tcl_SetByteArrayLength(resultPtr, rlen);
+ memset(r, 0, rlen);
+
+ for (p = input; p < input + len; p += 4) {
+ char a, b, c, d;
+ a = *p; b = *(p+1), c = *(p+2), d = *(p+3);
+ *r++ = (((a - 0x20) & 0x3f) << 2) | (((b - 0x20) & 0x3f) >> 4);
+ *r++ = (((b - 0x20) & 0x3f) << 4) | (((c - 0x20) & 0x3f) >> 2);
+ *r++ = (((c - 0x20) & 0x3f) << 6) | (((d - 0x20) & 0x3f) );
+ }
+ Tcl_SetObjResult(interp, resultPtr);
+ return TCL_OK;
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Permit more tolerant decoding of invalid input strings by padding to
+# a multiple of 4 bytes with nulls.
+# Result:
+# Returns the input string - possibly padded with uuencoded null chars.
+#
+proc ::uuencode::pad {s} {
+ if {[set mod [expr {[string length $s] % 4}]] != 0} {
+ append s [string repeat "`" [expr {4 - $mod}]]
+ }
+ return $s
+}
+
+# -------------------------------------------------------------------------
+
+# If the Trf package is available then we shall use this by default but the
+# Tcllib implementations are always visible if needed (ie: for testing)
+if {[info commands ::uuencode::CDecode] != {}} {
+ # tcllib critcl package
+ interp alias {} ::uuencode::encode {} ::uuencode::CEncode
+ interp alias {} ::uuencode::decode {} ::uuencode::CDecode
+} elseif {[package provide Trf] != {}} {
+ proc ::uuencode::encode {s} {
+ return [::uuencode -mode encode -- $s]
+ }
+ proc ::uuencode::decode {s} {
+ return [::uuencode -mode decode -- [pad $s]]
+ }
+} else {
+ # pure-tcl then
+ interp alias {} ::uuencode::encode {} ::uuencode::Encode
+ interp alias {} ::uuencode::decode {} ::uuencode::Decode
+}
+
+# -------------------------------------------------------------------------
+
+proc ::uuencode::uuencode {args} {
+ array set opts {mode 0644 filename {} name {}}
+ set wrongargs "wrong \# args: should be\
+ \"uuencode ?-name string? ?-mode octal?\
+ (-file filename | ?--? string)\""
+ while {[string match -* [lindex $args 0]]} {
+ switch -glob -- [lindex $args 0] {
+ -f* {
+ if {[llength $args] < 2} {
+ return -code error $wrongargs
+ }
+ set opts(filename) [lindex $args 1]
+ set args [lreplace $args 0 0]
+ }
+ -m* {
+ if {[llength $args] < 2} {
+ return -code error $wrongargs
+ }
+ set opts(mode) [lindex $args 1]
+ set args [lreplace $args 0 0]
+ }
+ -n* {
+ if {[llength $args] < 2} {
+ return -code error $wrongargs
+ }
+ set opts(name) [lindex $args 1]
+ set args [lreplace $args 0 0]
+ }
+ -- {
+ set args [lreplace $args 0 0]
+ break
+ }
+ default {
+ return -code error "bad option [lindex $args 0]:\
+ must be -file, -mode, or -name"
+ }
+ }
+ set args [lreplace $args 0 0]
+ }
+
+ if {$opts(name) == {}} {
+ set opts(name) $opts(filename)
+ }
+ if {$opts(name) == {}} {
+ set opts(name) "data.dat"
+ }
+
+ if {$opts(filename) != {}} {
+ set f [open $opts(filename) r]
+ fconfigure $f -translation binary
+ set data [read $f]
+ close $f
+ } else {
+ if {[llength $args] != 1} {
+ return -code error $wrongargs
+ }
+ set data [lindex $args 0]
+ }
+
+ set r {}
+ append r [format "begin %o %s" $opts(mode) $opts(name)] "\n"
+ for {set n 0} {$n < [string length $data]} {incr n 45} {
+ set s [string range $data $n [expr {$n + 44}]]
+ append r [Enc [string length $s]]
+ append r [encode $s] "\n"
+ }
+ append r "`\nend"
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Perform uudecoding of a file or data. A file may contain more than one
+# encoded data section so the result is a list where each element is a
+# three element list of the provided filename, the suggested mode and the
+# data itself.
+#
+proc ::uuencode::uudecode {args} {
+ array set opts {mode 0644 filename {}}
+ set wrongargs "wrong \# args: should be \"uudecode (-file filename | ?--? string)\""
+ while {[string match -* [lindex $args 0]]} {
+ switch -glob -- [lindex $args 0] {
+ -f* {
+ if {[llength $args] < 2} {
+ return -code error $wrongargs
+ }
+ set opts(filename) [lindex $args 1]
+ set args [lreplace $args 0 0]
+ }
+ -- {
+ set args [lreplace $args 0 0]
+ break
+ }
+ default {
+ return -code error "bad option [lindex $args 0]:\
+ must be -file"
+ }
+ }
+ set args [lreplace $args 0 0]
+ }
+
+ if {$opts(filename) != {}} {
+ set f [open $opts(filename) r]
+ set data [read $f]
+ close $f
+ } else {
+ if {[llength $args] != 1} {
+ return -code error $wrongargs
+ }
+ set data [lindex $args 0]
+ }
+
+ set state false
+ set result {}
+
+ foreach {line} [split $data "\n"] {
+ switch -exact -- $state {
+ false {
+ if {[regexp {^begin ([0-7]+) ([^\s]*)} $line \
+ -> opts(mode) opts(name)]} {
+ set state true
+ set r {}
+ }
+ }
+
+ true {
+ if {[string match "end" $line]} {
+ set state false
+ lappend result [list $opts(name) $opts(mode) $r]
+ } else {
+ scan $line %c c
+ set n [expr {($c - 0x21)}]
+ append r [string range \
+ [decode [string range $line 1 end]] 0 $n]
+ }
+ }
+ }
+ }
+
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+package provide uuencode 1.1.5
+
+# -------------------------------------------------------------------------
+#
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
+
diff --git a/tcllib/modules/base64/uuencode.test b/tcllib/modules/base64/uuencode.test
new file mode 100644
index 0000000..1e968da
--- /dev/null
+++ b/tcllib/modules/base64/uuencode.test
@@ -0,0 +1,193 @@
+# uuencode.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Tests for the Tcllib uuencode package
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: uuencode.test,v 1.15 2008/12/12 04:57:46 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useTcllibC
+ useLocalKeep uuencode.tcl uuencode
+}
+
+# -------------------------------------------------------------------------
+
+set trf 0
+if {[llength [info commands ::uuencode::CEncode]]} {
+ puts "> critcl based"
+} elseif {[package provide Trf] != {}} {
+ puts "> Trf based"
+ set trf 1
+} else {
+ puts "> pure tcl"
+}
+
+package require log
+log::lvSuppress notice
+
+# -------------------------------------------------------------------------
+
+test uuencode-1.0 {encode string} {
+ catch {::uuencode::encode ABC} result
+ set result
+} "04)#"
+
+test uuencode-1.1 {decode string} {
+ catch {::uuencode::decode "04)#"} result
+ set result
+} "ABC"
+
+test uuencode-1.2 {encode longer string} {
+ catch {::uuencode::encode [string repeat x 102]} result
+ set result
+} [string repeat ">'AX" 34]
+
+test uuencode-1.3 {decode longer string} {
+ catch {::uuencode::decode [string repeat ">'AX" 34]} result
+ set result
+} [string repeat x 102]
+
+# Trf uses a different padding character.
+if {!$trf} {
+ # critcl / pure tcl based
+ set testdata {begin 644 data.dat
+75&AE(&-A="!S870@;VX@=&AE(&UA="X`
+`
+end}
+} else {
+ set testdata {begin 644 data.dat
+75&AE(&-A="!S870@;VX@=&AE(&UA="X~
+`
+end}
+}
+
+test uuencode-1.4 {uuencode string} {
+ catch {::uuencode::uuencode "The cat sat on the mat."} result
+ set result
+} $testdata
+
+test uuencode-1.5 {uudecode string} {
+ catch {::uuencode::uudecode $testdata} result
+ set result
+} [list [list data.dat 644 "The cat sat on the mat."]]
+
+test uuencode-1.6 {encode dash-string} {
+ catch {::uuencode::encode -BC} result
+ set result
+} "+4)#"
+
+test uuencode-1.7 {decode dash-string} {
+ catch {::uuencode::decode "-4)#"} result
+ set result
+} "5BC"
+
+# -------------------------------------------------------------------------
+
+set testdata [list \
+ "begin 644 data.dat" \
+ "75&AE(&-A=\"!S870@;VX@=&AE(&UA=\"X" \
+ "`" \
+ "end" ]
+
+test uuencode-2.1 {uudecode unpadded lines} {
+ catch {::uuencode::uudecode [join $testdata "\n"]} result
+ set result
+} [list [list data.dat 644 "The cat sat on the mat."]]
+
+test uuencode-2.2 {uudecode DOS line endings} {
+ set f [open uuencode.test.data w]
+ fconfigure $f -translation binary
+ puts -nonewline $f [join $testdata "\r\n"]
+ close $f
+ catch {::uuencode::uudecode -file uuencode.test.data} result
+ set result
+} [list [list data.dat 644 "The cat sat on the mat."]]
+
+foreach {n in out} {
+ 0 a {80``}
+ 1 abc {86)C}
+ 2 \0 {````}
+ 3 "\r\n\t" {#0H)}
+ 4 "hello world" {:&5L;&\@=V]R;&0`}
+} {
+ test uuencode-3.$n {check the pure tcl encoder} {
+ list [catch {::uuencode::Encode $in} r] $r
+ } [list 0 $out]
+}
+
+# -------------------------------------------------------------------------
+
+test uuencode-4.0 {encode bad args} {
+ catch {::uuencode::uuencode -bogus} result
+ set result
+} {bad option -bogus: must be -file, -mode, or -name}
+
+test uuencode-4.1 {encode wrong#args} {
+ catch {::uuencode::uuencode -file} result
+ set result
+} {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"}
+
+test uuencode-4.2 {encode wrong#args} {
+ catch {::uuencode::uuencode -name} result
+ set result
+} {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"}
+
+test uuencode-4.3 {encode wrong#args} {
+ catch {::uuencode::uuencode -mode} result
+ set result
+} {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"}
+
+test uuencode-4.4 {encode wrong#args} {
+ catch {::uuencode::uuencode -mode 1} result
+ set result
+} {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"}
+
+test uuencode-4.5 {encode wrong#args} {
+ catch {::uuencode::uuencode -name foo} result
+ set result
+} {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"}
+
+test uuencode-4.6 {encode wrong#args} {
+ catch {::uuencode::uuencode --} result
+ set result
+} {wrong # args: should be "uuencode ?-name string? ?-mode octal? (-file filename | ?--? string)"}
+
+
+
+test uuencode-5.0 {decode bad args} {
+ catch {::uuencode::uudecode -bogus} result
+ set result
+} {bad option -bogus: must be -file}
+
+test uuencode-5.1 {decode wrong#args} {
+ catch {::uuencode::uudecode -file} result
+ set result
+} {wrong # args: should be "uudecode (-file filename | ?--? string)"}
+
+test uuencode-5.2 {decode wrong#args} {
+ catch {::uuencode::uudecode --} result
+ set result
+} {wrong # args: should be "uudecode (-file filename | ?--? string)"}
+
+
+# -------------------------------------------------------------------------
+
+file delete -force uuencode.test.data
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/base64/yencode.bench b/tcllib/modules/base64/yencode.bench
new file mode 100644
index 0000000..706acb5
--- /dev/null
+++ b/tcllib/modules/base64/yencode.bench
@@ -0,0 +1,46 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'yencode' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+package forget yencode
+catch {namespace delete ::yencode}
+source [file join [file dirname [info script]] yencode.tcl]
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+
+foreach n {10 100 1000 10000} {
+ bench -desc "YENCODE encode ${n}X" -pre {
+ set str [string repeat X $n]
+ } -body {
+ yencode::encode $str
+ } -post {
+ unset str
+ }
+
+ bench -desc "YENCODE decode ${n}X" -pre {
+ set str [yencode::encode [string repeat X $n]]
+ } -body {
+ yencode::decode $str
+ } -post {
+ unset str
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/base64/yencode.man b/tcllib/modules/base64/yencode.man
new file mode 100644
index 0000000..575d441
--- /dev/null
+++ b/tcllib/modules/base64/yencode.man
@@ -0,0 +1,96 @@
+[manpage_begin yencode n 1.1.2]
+[keywords encoding]
+[keywords ydecode]
+[keywords yEnc]
+[keywords yencode]
+[copyright {2002, Pat Thoyts}]
+[moddesc {Text encoding & decoding binary data}]
+[titledesc {Y-encode/decode binary data}]
+[category {Text processing}]
+[require Tcl 8.2]
+[require yencode [opt 1.1.2]]
+[description]
+[para]
+
+This package provides a Tcl-only implementation of the yEnc file
+encoding. This is a recently introduced method of encoding binary
+files for transmission through Usenet. This encoding packs binary data
+into a format that requires an 8-bit clean transmission layer but that
+escapes characters special to the [term NNTP] posting protocols. See
+[uri http://www.yenc.org/] for details concerning the algorithm.
+
+[list_begin definitions]
+
+[call [cmd ::yencode::encode] [arg string]]
+
+returns the yEnc encoded data.
+
+[call [cmd ::yencode::decode] [arg "string"]]
+
+Decodes the given yEnc encoded data.
+
+[call [cmd ::yencode::yencode] \
+ [opt "[option -name] [arg string]"] \
+ [opt "[option -line] [arg integer]"] \
+ [opt "[option -crc32] [arg boolean]"] \
+ "([option -file] [arg filename] | [opt [option --]] [arg string])"]
+
+Encode a file or block of data.
+
+[call [cmd ::yencode::ydecode] \
+ "([option -file] [arg filename] | [opt [option --]] [arg string])"]
+
+Decode a file or block of data. A file may contain more than one
+embedded file so the result is a list where each element is a three
+element list of filename, file size and data.
+
+[list_end]
+
+[section OPTIONS]
+
+[list_begin definitions]
+
+[def "-filename name"]
+
+Cause the yencode or ydecode commands to read their data from the
+named file rather that taking a string parameter.
+
+[def "-name string"]
+
+The encoded data header line contains the suggested file name to be
+used when unpacking the data. Use this option to change this from the
+default of "data.dat".
+
+[def "-line integer"]
+
+The yencoded data header line contains records the line length used
+during the encoding. Use this option to select a line length other
+that the default of 128. Note that NNTP imposes a 1000 character line
+length limit and some gateways may have trouble with more than 255
+characters per line.
+
+[def "-crc32 boolean"]
+
+The yEnc specification recommends the inclusion of a cyclic redundancy
+check value in the footer. Use this option to change the default from
+[arg true] to [arg false].
+
+[list_end]
+
+[para]
+[example {
+% set d [yencode::yencode -file testfile.txt]
+=ybegin line=128 size=584 name=testfile.txt
+ -o- data not shown -o-
+=yend size=584 crc32=ded29f4f
+}]
+
+[section References]
+
+[list_begin enum]
+[enum] [uri http://www.yenc.org/yenc-draft.1.3.txt]
+[list_end]
+
+[vset CATEGORY base64]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/base64/yencode.pcx b/tcllib/modules/base64/yencode.pcx
new file mode 100644
index 0000000..e38499f
--- /dev/null
+++ b/tcllib/modules/base64/yencode.pcx
@@ -0,0 +1,78 @@
+# -*- tcl -*- yencode.pcx
+# Syntax of the commands provided by package yencode.
+#
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register yencode
+pcx::tcldep 1.1.1 needs tcl 8.2
+
+namespace eval ::yencode {}
+
+# Using the indirections below looks to be quite pointless, given that
+# they simply substitute the commands for others. I am doing this for
+# two reasons.
+
+# First, the rules coming after become self-commenting, i.e. a
+# maintainer can immediately see what an argument is supposed to be,
+# instead of having to search elsewhere (like the documentation and
+# implementation). In this manner our definitions here are a type of
+# semantic markup.
+
+# The second reason is that while we have no special checks now we
+# cannot be sure if such will (have to) be added in the future. With
+# all checking routed through our definitions we now already have the
+# basic infrastructure (i.e. hooks) in place in which we can easily
+# add any new checks by simply redefining the relevant command, and
+# all the rules update on their own. Mostly. This should cover 90% of
+# the cases. Sometimes new checks will require to create deeper
+# distinctions between different calls of the same thing. For such we
+# may have to update the rules as well, to provide the necessary
+# information to the checker.
+
+interp alias {} yencode::checkMode {} checkWord ; #
+interp alias {} yencode::checkDstFilename {} checkWord ; #
+interp alias {} yencode::checkData {} checkWord ; #
+interp alias {} yencode::checkLineLength {} checkInt ; #
+interp alias {} yencode::checkCrc32Flag {} checkBoolean ; #
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.1.1 std ::yencode::ydecode \
+ {checkConstrained {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ {-filename {checkSetConstraint hasfilename checkFileName}}
+ --
+ } {checkConstraint {
+ {hasfilename {checkSimpleArgs 0 0 {}}}
+ {!hasfilename {checkSimpleArgs 1 1 {
+ yencode::checkData
+ }}}
+ } {}}}
+ }}}
+# TODO: Limit -mode to a octal numbers (file permissions)
+pcx::check 1.1.1 std ::yencode::yencode \
+ {checkConstrained {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ {-crc32 yencode::checkCrc32Flag}
+ {-line yencode::checkLineLength}
+ {-mode yencode::checkMode}
+ {-name yencode::checkDstFilename}
+ {-filename {checkSetConstraint hasfilename checkFileName}}
+ --
+ } {checkConstraint {
+ {hasfilename {checkSimpleArgs 0 0 {}}}
+ {!hasfilename {checkSimpleArgs 1 1 {
+ yencode::checkData
+ }}}
+ } {}}}
+ }}}
+
+# Initialization via pcx::init.
+# Use a ::yencode::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/base64/yencode.tcl b/tcllib/modules/base64/yencode.tcl
new file mode 100644
index 0000000..5d2c035
--- /dev/null
+++ b/tcllib/modules/base64/yencode.tcl
@@ -0,0 +1,307 @@
+# yencode.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Provide a Tcl only implementation of yEnc encoding algorithm
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+# FUTURE: Rework to allow switching between the tcl/critcl implementations.
+
+package require Tcl 8.2; # tcl minimum version
+catch {package require crc32}; # tcllib 1.1
+catch {package require tcllibc}; # critcl enhancements for tcllib
+
+namespace eval ::yencode {
+ namespace export encode decode yencode ydecode
+}
+
+# -------------------------------------------------------------------------
+
+proc ::yencode::Encode {s} {
+ set r {}
+ binary scan $s c* d
+ foreach {c} $d {
+ set v [expr {($c + 42) % 256}]
+ if {$v == 0x00 || $v == 0x09 || $v == 0x0A
+ || $v == 0x0D || $v == 0x3D} {
+ append r "="
+ set v [expr {($v + 64) % 256}]
+ }
+ append r [format %c $v]
+ }
+ return $r
+}
+
+proc ::yencode::Decode {s} {
+ if {[string length $s] == 0} {return ""}
+ set r {}
+ set esc 0
+ binary scan $s c* d
+ foreach c $d {
+ if {$c == 61 && $esc == 0} {
+ set esc 1
+ continue
+ }
+ set v [expr {($c - 42) % 256}]
+ if {$esc} {
+ set v [expr {($v - 64) % 256}]
+ set esc 0
+ }
+ append r [format %c $v]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# C coded versions for critcl built base64c package
+# -------------------------------------------------------------------------
+
+if {[package provide critcl] != {}} {
+ namespace eval ::yencode {
+ critcl::ccode {
+ #include <string.h>
+ }
+ critcl::ccommand CEncode {dummy interp objc objv} {
+ Tcl_Obj *inputPtr, *resultPtr;
+ int len, rlen, xtra;
+ unsigned char *input, *p, *r, v;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "data");
+ return TCL_ERROR;
+ }
+
+ /* fetch the input data */
+ inputPtr = objv[1];
+ input = Tcl_GetByteArrayFromObj(inputPtr, &len);
+
+ /* calculate the length of the encoded result */
+ rlen = len;
+ for (p = input; p < input + len; p++) {
+ v = (*p + 42) % 256;
+ if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D)
+ rlen++;
+ }
+
+ /* allocate the output buffer */
+ resultPtr = Tcl_NewObj();
+ r = Tcl_SetByteArrayLength(resultPtr, rlen);
+
+ /* encode the input */
+ for (p = input; p < input + len; p++) {
+ v = (*p + 42) % 256;
+ if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) {
+ *r++ = '=';
+ v = (v + 64) % 256;
+ }
+ *r++ = v;
+ }
+ Tcl_SetObjResult(interp, resultPtr);
+ return TCL_OK;
+ }
+
+ critcl::ccommand CDecode {dummy interp objc objv} {
+ Tcl_Obj *inputPtr, *resultPtr;
+ int len, rlen, esc;
+ unsigned char *input, *p, *r, v;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "data");
+ return TCL_ERROR;
+ }
+
+ /* fetch the input data */
+ inputPtr = objv[1];
+ input = Tcl_GetByteArrayFromObj(inputPtr, &len);
+
+ /* allocate the output buffer */
+ resultPtr = Tcl_NewObj();
+ r = Tcl_SetByteArrayLength(resultPtr, len);
+
+ /* encode the input */
+ for (p = input, esc = 0, rlen = 0; p < input + len; p++) {
+ if (*p == 61 && esc == 0) {
+ esc = 1;
+ continue;
+ }
+ v = (*p - 42) % 256;
+ if (esc) {
+ v = (v - 64) % 256;
+ esc = 0;
+ }
+ *r++ = v;
+ rlen++;
+ }
+ Tcl_SetByteArrayLength(resultPtr, rlen);
+ Tcl_SetObjResult(interp, resultPtr);
+ return TCL_OK;
+ }
+ }
+}
+
+if {[info commands ::yencode::CEncode] != {}} {
+ interp alias {} ::yencode::encode {} ::yencode::CEncode
+ interp alias {} ::yencode::decode {} ::yencode::CDecode
+} else {
+ interp alias {} ::yencode::encode {} ::yencode::Encode
+ interp alias {} ::yencode::decode {} ::yencode::Decode
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::yencode::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::yencode::yencode {args} {
+ array set opts {mode 0644 filename {} name {} line 128 crc32 1}
+ while {[string match -* [lindex $args 0]]} {
+ switch -glob -- [lindex $args 0] {
+ -f* { set opts(filename) [Pop args 1] }
+ -m* { set opts(mode) [Pop args 1] }
+ -n* { set opts(name) [Pop args 1] }
+ -l* { set opts(line) [Pop args 1] }
+ -c* { set opts(crc32) [Pop args 1] }
+ -- { Pop args ; break }
+ default {
+ set options [join [lsort [array names opts]] ", -"]
+ return -code error "bad option [lindex $args 0]:\
+ must be -$options"
+ }
+ }
+ Pop args
+ }
+
+ if {$opts(name) == {}} {
+ set opts(name) $opts(filename)
+ }
+ if {$opts(name) == {}} {
+ set opts(name) "data.dat"
+ }
+ if {! [string is boolean $opts(crc32)]} {
+ return -code error "bad option -crc32: argument must be true or false"
+ }
+
+ if {$opts(filename) != {}} {
+ set f [open $opts(filename) r]
+ fconfigure $f -translation binary
+ set data [read $f]
+ close $f
+ } else {
+ if {[llength $args] != 1} {
+ return -code error "wrong \# args: should be\
+ \"yencode ?options? -file name | data\""
+ }
+ set data [lindex $args 0]
+ }
+
+ set opts(size) [string length $data]
+
+ set r {}
+ append r [format "=ybegin line=%d size=%d name=%s" \
+ $opts(line) $opts(size) $opts(name)] "\n"
+
+ set ndx 0
+ while {$ndx < $opts(size)} {
+ set pln [string range $data $ndx [expr {$ndx + $opts(line) - 1}]]
+ set enc [encode $pln]
+ incr ndx [string length $pln]
+ append r $enc "\r\n"
+ }
+
+ append r [format "=yend size=%d" $ndx]
+ if {$opts(crc32)} {
+ append r " crc32=" [crc::crc32 -format %x $data]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Perform ydecoding of a file or data. A file may contain more than one
+# encoded data section so the result is a list where each element is a
+# three element list of the provided filename, the file size and the
+# data itself.
+#
+proc ::yencode::ydecode {args} {
+ array set opts {mode 0644 filename {} name default.bin}
+ while {[string match -* [lindex $args 0]]} {
+ switch -glob -- [lindex $args 0] {
+ -f* { set opts(filename) [Pop args 1] }
+ -- { Pop args ; break; }
+ default {
+ set options [join [lsort [array names opts]] ", -"]
+ return -code error "bad option [lindex $args 0]:\
+ must be -$opts"
+ }
+ }
+ Pop args
+ }
+
+ if {$opts(filename) != {}} {
+ set f [open $opts(filename) r]
+ set data [read $f]
+ close $f
+ } else {
+ if {[llength $args] != 1} {
+ return -code error "wrong \# args: should be\
+ \"ydecode ?options? -file name | data\""
+ }
+ set data [lindex $args 0]
+ }
+
+ set state false
+ set result {}
+
+ foreach {line} [split $data "\n"] {
+ set line [string trimright $line "\r\n"]
+ switch -exact -- $state {
+ false {
+ if {[string match "=ybegin*" $line]} {
+ regexp {line=(\d+)} $line -> opts(line)
+ regexp {size=(\d+)} $line -> opts(size)
+ regexp {name=(\d+)} $line -> opts(name)
+
+ if {$opts(name) == {}} {
+ set opts(name) default.bin
+ }
+
+ set state true
+ set r {}
+ }
+ }
+
+ true {
+ if {[string match "=yend*" $line]} {
+ set state false
+ lappend result [list $opts(name) $opts(size) $r]
+ } else {
+ append r [decode $line]
+ }
+ }
+ }
+ }
+
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+package provide yencode 1.1.3
+
+# -------------------------------------------------------------------------
+#
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
+
diff --git a/tcllib/modules/base64/yencode.test b/tcllib/modules/base64/yencode.test
new file mode 100644
index 0000000..9d1813b
--- /dev/null
+++ b/tcllib/modules/base64/yencode.test
@@ -0,0 +1,99 @@
+# yencode.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Tests for the Tcllib yencode package
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: yencode.test,v 1.11 2008/12/12 04:57:46 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ # FUTURE: Switch tcl/critcl implementations
+ useTcllibC
+ useLocalKeep yencode.tcl yencode
+}
+
+# -------------------------------------------------------------------------
+
+if {[llength [info commands ::yencode::CEncode]]} {
+ puts "> critcl based"
+} else {
+ puts "> pure tcl"
+}
+
+proc ::yencode::loaddata {filename {translation auto}} {
+ set f [open $filename r]
+ fconfigure $f -translation $translation
+ set data [read $f]
+ close $f
+ return $data
+}
+
+# -------------------------------------------------------------------------
+
+set datafile [localPath yencode.test.data]
+
+test yencode-1.0 {yencode yEnc test file} {
+ set enc [::yencode::yencode -file $datafile]
+ set dec [::yencode::ydecode $enc]
+ set chk [::yencode::loaddata $datafile]
+ string equal $dec $chk
+} {0}
+
+
+# -------------------------------------------------------------------------
+
+foreach {n in out} {
+ 0 A {k}
+ 1 ABC {klm}
+ 2 \0\1\2 {*+,}
+ 3 "\r\n\t" {743}
+ 4 "\xd6\xe0\xe3" {=@=J=M}
+} {
+ test yencode-2.$n.a {check the pure tcl encode} {
+ list [catch {::yencode::Encode $in} r] $r
+ } [list 0 $out]
+ test yencode-2.$n.b {check the pure tcl decode} {
+ list [catch {::yencode::Decode $out} r] $r
+ } [list 0 $in]
+}
+
+if {[llength [info commands ::yencode::CEncode]]} {
+ foreach {n in out} {
+ 0 A {k}
+ 1 ABC {klm}
+ 2 \0\1\2 {*+,}
+ 3 "\r\n\t" {743}
+ 4 "\xd6\xe0\xe3" {=@=J=M}
+ } {
+ test yencode-3.$n.a {check the critcl encode} {
+ list [catch {::yencode::Encode $in} r] $r
+ } [list 0 $out]
+ test yencode-3.$n.b {check the critcl decode} {
+ list [catch {::yencode::Decode $out} r] $r
+ } [list 0 $in]
+ }
+}
+
+# -------------------------------------------------------------------------
+
+catch {
+ unset datafile
+ rename ::yencode::loaddata {}
+}
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/base64/yencode.test.data b/tcllib/modules/base64/yencode.test.data
new file mode 100644
index 0000000..ebadc2c
--- /dev/null
+++ b/tcllib/modules/base64/yencode.test.data
Binary files differ
diff --git a/tcllib/modules/base64/yencode.test.out b/tcllib/modules/base64/yencode.test.out
new file mode 100644
index 0000000..f17da90
--- /dev/null
+++ b/tcllib/modules/base64/yencode.test.out
@@ -0,0 +1,17 @@
+From: develop@winews.net
+Newsgroups: yenc
+Date: 27 Oct 2001 15:07:44 +0200
+Subject: yEnc-Prefix: "testfile.txt" 584 yEnc bytes - yEnc test (1)
+Message-ID: <4407f.ra1200@liebchen.winews.net>
+Path: liebchen.winews.net!not-for-mail
+Lines: 16
+X-Newsreader: MyNews
+
+--
+=ybegin line=128 size=584 name=testfile.txt
+oJWJ~JR[S74k}mssdJ\__XXZ74)('&%$#"! =M =J=I=@
+~}|{zyxwvutsrqponmlkjihgfedcba`_^]\[ZYXWVUTSR
+QPONMLKJIHGFEDCBA@?>=}<;:9876543210/=n-,+*74k}mssdJZXX\__74*+,-=n/0123456789:;<=}>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijkl
+mnopqrstuvwxyz{|}~
+=@=I=J =M !"#$%&'()74oJJ~74
+=yend size=584 crc32=ded29f4f
diff --git a/tcllib/modules/bee/ChangeLog b/tcllib/modules/bee/ChangeLog
new file mode 100644
index 0000000..630a16c
--- /dev/null
+++ b/tcllib/modules/bee/ChangeLog
@@ -0,0 +1,116 @@
+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-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 ========================
+ *
+
+2008-06-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bee.pcx: New file. Syntax definitions for the public commands of
+ the bee package.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-03-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bee.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-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bee.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bee.test: Hooked into the new common test support code.
+
+2005-10-21 Andreas Kupries <andreask@activestate.com>
+
+ * bee.test: Fixed typo.
+
+2005-10-18 Andreas Kupries <andreask@activestate.com>
+
+ * bee.bench: New file, benchmarks, only basics for now.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-09-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bee.man: Cleared up version confusion. This package
+ * bee.test: definitely requires 8.4. Fixed in package
+ * pkgIndex.tcl: index, docs, added boilerplate abort to
+ testsuite.
+
+ * bee.test: Fixed problem with testsuite, cannot use viewFile,
+ does not do binary.
+
+2004-08-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bee.tcl: Typo police.
+ * bee.man:
+ * bee.test:
+
+2004-06-23 Andreas Kupries <andreas_kupries@users.sourceforge.bet>
+
+ * bee.man: Polished the documentation.
+
+2004-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.bet>
+
+ * bee.tcl: Completed the implementation.
+ * bee.man: Completed documentation.
+ * bee.test: Completed testsuite.
+
+2004-06-18 Andreas Kupries <andreas_kupries@users.sourceforge.bet>
+
+ * New module: BEE de- and encoding. BEE is the serialization
+ format used by BitTorrent for its data and protocol messages.
diff --git a/tcllib/modules/bee/bee.bench b/tcllib/modules/bee/bee.bench
new file mode 100644
index 0000000..2fb55fe
--- /dev/null
+++ b/tcllib/modules/bee/bee.bench
@@ -0,0 +1,79 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'bee' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+package forget bee
+catch {namespace delete ::bee}
+source [file join [file dirname [info script]] bee.tcl]
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+foreach n {
+ -10 -100 -1000 -10000 -100000 -1000000
+ 0
+ 10 100 1000 10000 100000 1000000
+} {
+ bench -desc "BEE encode Number $n" -body {
+ bee::encodeNumber $n
+ }
+
+ bench -desc "BEE decode Number $n" -pre {
+ set str [bee::encodeNumber $n]
+ } -body {
+ bee::decode $str
+ } -post {
+ unset str
+ }
+
+ bench -desc "BEE decodeIndices Number $n" -pre {
+ set str [bee::encodeNumber $n]
+ } -body {
+ bee::decodeIndices $str
+ } -post {
+ unset str
+ }
+}
+
+foreach n {10 100 1000 10000} {
+ bench -desc "BEE encode String $n" -pre {
+ set str [string repeat X $n]
+ } -body {
+ bee::encodeString $str
+ } -post {
+ unset str
+ }
+
+ bench -desc "BEE decode String $n" -pre {
+ set str [bee::encodeString [string repeat X $n]]
+ } -body {
+ bee::decode $str
+ } -post {
+ unset str
+ }
+
+ bench -desc "BEE decodeIndices String $n" -pre {
+ set str [bee::encodeString [string repeat X $n]]
+ } -body {
+ bee::decodeIndices $str
+ } -post {
+ unset str
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/bee/bee.man b/tcllib/modules/bee/bee.man
new file mode 100644
index 0000000..c6c4781
--- /dev/null
+++ b/tcllib/modules/bee/bee.man
@@ -0,0 +1,343 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin bee n 0.1]
+[keywords bee]
+[keywords BitTorrent]
+[keywords bittorrent]
+[keywords serialization]
+[keywords torrent]
+[copyright {2004 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {BitTorrent}]
+[titledesc {BitTorrent Serialization Format Encoder/Decoder}]
+[category Networking]
+[require Tcl 8.4]
+[require bee [opt 0.1]]
+[description]
+[para]
+
+The [package bee] package provides de- and encoder commands for data
+in bencoding (speak 'bee'), the serialization format for data and
+messages used by the BitTorrent application.
+
+[para]
+
+[section {PUBLIC API}]
+
+[subsection ENCODER]
+
+The package provides one encoder command for each of the basic forms,
+and two commands per container, one taking a proper tcl data structure
+to encode in the container, the other taking the same information as
+several arguments.
+
+[para]
+[list_begin definitions]
+
+[call [cmd ::bee::encodeString] [arg string]]
+
+Returns the bee-encoding of the [arg string].
+
+[call [cmd ::bee::encodeNumber] [arg integer]]
+
+Returns the bee-encoding of the [arg integer] number.
+
+[call [cmd ::bee::encodeListArgs] [arg value]...]
+
+Takes zero or more bee-encoded values and returns the bee-encoding of
+their list.
+
+[call [cmd ::bee::encodeList] [arg list]]
+
+Takes a list of bee-encoded values and returns the bee-encoding of the
+list.
+
+[call [cmd ::bee::encodeDictArgs] [arg key] [arg value]...]
+
+Takes zero or more pairs of keys and values and returns the
+bee-encoding of the dictionary they form. The values are expected to
+be already bee-encoded, but the keys must not be. Their encoding will
+be done by the command itself.
+
+[call [cmd ::bee::encodeDict] [arg dict]]
+
+Takes a dictionary list of string keys and bee-encoded values and
+returns the bee-encoding of the list. Note that the keys in the input
+must not be bee-encoded already. This will be done by the command
+itself.
+
+[list_end]
+[para]
+
+[subsection DECODER]
+
+The package provides two main decoder commands, one for decoding a
+string expected to contain a complete data structure, the other for
+the incremental decoding of bee-values arriving on a channel. The
+latter command is asynchronous and provides the completed decoded
+values to the user through a command callback.
+
+[para]
+[list_begin definitions]
+
+[call [cmd ::bee::decode] [arg string] [opt [arg endvar]] [opt [arg start]]]
+
+Takes the bee-encoding in the string and returns one decoded value. In
+the case of this being a container all contained values are decoded
+recursively as well and the result is a properly nested tcl list
+and/or dictionary.
+
+[para]
+
+If the optional [arg endvar] is set then it is the name of a variable
+to store the index of the first character [emph after] the decoded
+value into. In other words, if the string contains more than one value
+then [arg endvar] can be used to obtain the position of the bee-value
+after the bee-value currently decoded. together with [arg start], see
+below, it is possible to iterate over the string to extract all
+contained values.
+
+[para]
+
+The optional [arg start] index defaults to [const 0], i.e. the
+beginning of the string. It is the index of the first character of the
+bee-encoded value to extract.
+
+[call [cmd ::bee::decodeIndices] [arg string] [opt [arg endvar]] [opt [arg start]]]
+
+Takes the same arguments as [cmd ::bee::decode] and returns the same
+information in [arg endvar]. The result however is different. Instead
+of the tcl value contained in the [arg string] it returns a list
+describing the value with respect to type and location (indices for
+the first and last character of the bee-value). In case of a container
+the structure also contains the same information for all the embedded
+values.
+
+[para]
+
+Formally the results for the various types of bee-values are:
+
+[list_begin definitions]
+[def string]
+
+A list containing three elements:
+
+[list_begin itemized]
+[item]
+The constant string [const string], denoting the type of the value.
+
+[item]
+An integer number greater than or equal to zero. This is the index of
+the first character of the bee-value in the input [arg string].
+
+[item]
+An integer number greater than or equal to zero. This is the index of
+the last character of the bee-value in the input [arg string].
+
+[list_end]
+[para]
+
+[emph Note] that this information is present in the results for all
+four types of bee-values, with only the first element changing
+according to the type of the value.
+
+[def integer]
+
+The result is like for strings, except that the type element contains
+the constant string [const integer].
+
+[def list]
+
+The result is like before, with two exceptions: One, the type element
+contains the constant string [const list]. And two, the result
+actually contains four elements. The last element is new, and contains
+the index data as described here for all elements of the bee-list.
+
+[def dictionary]
+
+The result is like for strings, except that the type element contains
+the constant string [const dict]. A fourth element is present as well,
+with a slightly different structure than for lists. The element is a
+dictionary mapping from the strings keys of the bee-dictionary to a
+list containing two elements. The first of them is the index
+information for the key, and the second element is the index
+information for the value the key maps to. This structure is the only
+which contains not only index data, but actual values from the
+bee-string. While the index information of the keys is unique enough,
+i.e. serviceable as keys, they are not easy to navigate when trying to
+find particular element. Using the actual keys makes this much easier.
+
+[list_end]
+[para]
+
+[call [cmd ::bee::decodeChannel] [arg chan] \
+ [option -command] [arg cmdprefix] \
+ [opt [option -exact]] \
+ [opt "[option -prefix] [arg data]"] \
+]
+
+The command creates a decoder for a series of bee-values arriving on
+the channel [arg chan] and returns its handle. This handle can be used
+to remove the decoder again.
+
+Setting up another bee decoder on [arg chan] while a bee decoder is
+still active will fail with an error message.
+
+[para]
+[list_begin definitions]
+[def [option -command]]
+
+The command prefix [arg cmdprefix] specified by the [emph required]
+option [option -command] is used to report extracted values and
+exceptional situations (error, and EOF on the channel).
+
+The callback will be executed at the global level of the interpreter,
+with two or three arguments. The exact call signatures are
+
+[para]
+[list_begin definitions]
+[call [cmd cmdprefix] [method eof] [arg token]]
+
+The decoder has reached eof on the channel [arg chan]. No further
+invocations of the callback will be made after this. The channel has
+already been closed at the time of the call, and the [arg token] is
+not valid anymore as well.
+
+[call [cmd cmdprefix] [method error] [arg token] [arg message]]
+
+The decoder encountered an error, which is not eof. For example a
+malformed bee-value. The [arg message] provides details about the
+error. The decoder token is in the same state as for eof,
+i.e. invalid. The channel however is kept open.
+
+[call [cmd cmdprefix] [method value] [arg token] [arg value]]
+
+The decoder received and successfully decoded a bee-value.
+
+The format of the equivalent tcl [arg value] is the same as returned
+by [cmd ::bee::decode]. The channel is still open and the decoder
+token is valid. This means that the callback is able to remove the
+decoder.
+
+[list_end]
+[para]
+
+[def [option -exact]]
+
+By default the decoder assumes that the remainder of the data in the
+channel consists only of bee-values, and reads as much as possible per
+event, without regard for boundaries between bee-values. This means
+that if the the input contains non-bee data after a series of
+bee-value the beginning of that data may be lost because it was
+already read by the decoder, but not processed.
+
+[para]
+
+The [option -exact] was made for this situation. When specified the
+decoder will take care to not read any characters behind the currently
+processed bee-value, so that any non-bee data is kept in the channel
+for further processing after removal of the decoder.
+
+[para]
+
+[def [option -prefix]]
+
+If this option is specified its value is assumed to be the beginning
+of the bee-value and used to initialize the internal decoder
+buffer. This feature is required if the creator of the decoder used
+data from the channel to determine if it should create the decoder or
+not. Without the option this data would be lost to the decoding.
+
+[list_end]
+[para]
+
+[call [cmd ::bee::decodeCancel] [arg token]]
+
+This command cancels the decoder set up by [cmd ::bee::decodeChannel]
+and represented by the handle [arg token].
+
+[call [cmd ::bee::decodePush] [arg token] [arg string]]
+
+This command appends the [arg string] to the internal decoder
+buffer. It is the runtime equivalent of the option [option -prefix] of
+[cmd ::bee::decodeChannel]. Use it to push data back into the decoder
+when the [method value] callback used data from the channel to
+determine if it should decode another bee-value or not.
+
+[list_end]
+[para]
+
+[section {FORMAT DEFINITION}]
+
+Data in the bee serialization format is constructed from two basic
+forms, and two container forms. The basic forms are strings and
+integer numbers, and the containers are lists and dictionaries.
+
+[para]
+[list_begin definitions]
+[def "String [arg S]"]
+
+A string [arg S] of length [arg L] is encoded by the string
+
+"[arg L][const :][arg S]", where the length is written out in textual
+form.
+
+[def "Integer [arg N]"]
+
+An integer number [arg N] is encoded by the string
+
+"[const i][arg N][const e]".
+
+[def "List [arg v1] ... [arg vn]"]
+
+A list of the values [arg v1] to [arg vn] is encoded by the string
+
+"[const l][arg BV1]...[arg BVn][const e]"
+
+where "BV[var i]" is the bee-encoding of the value "v[var i]".
+
+[def "Dict [arg k1] -> [arg v1] ..."]
+
+A dictionary mapping the string key [arg k][var i] to the value
+
+[arg v][var i], for [var i] in [const 1] ... [var n]
+is encoded by the string
+
+"[const d][arg BK][var i][arg BV][ var i]...[const e]"
+
+for i in [const 1] ... [var n], where "BK[var i]" is the bee-encoding
+of the key string "k[var i]". and "BV[var i]" is the bee-encoding of
+the value "v[var i]".
+
+[para]
+
+[emph Note]: The bee-encoding does not retain the order of the keys in
+the input, but stores in a sorted order. The sorting is done for the
+"raw strings".
+
+[list_end]
+[para]
+
+Note that the type of each encoded item can be determined immediately
+from the first character of its representation:
+
+[para]
+[list_begin definitions]
+[def i]
+Integer.
+[def l]
+List.
+[def d]
+Dictionary.
+[def "[lb]0-9[rb]"]
+String.
+[list_end]
+[para]
+
+By wrapping an integer number into [const i]...[const e] the format
+makes sure that they are different from strings, which all begin with
+a digit.
+
+[section EXAMPLES]
+
+[vset CATEGORY bee]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/bee/bee.pcx b/tcllib/modules/bee/bee.pcx
new file mode 100644
index 0000000..b8cf178
--- /dev/null
+++ b/tcllib/modules/bee/bee.pcx
@@ -0,0 +1,81 @@
+# -*- tcl -*- bee.pcx
+# Syntax of the commands provided by package bee.
+#
+# 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 bee
+pcx::tcldep 0.1 needs tcl 8.4
+
+namespace eval ::bee {}
+
+pcx::message needCommand {Required -command is missing} err
+
+pcx::check 0.1 std ::bee::decode \
+ {checkSimpleArgs 1 3 {
+ checkWord
+ checkVarNameWrite
+ checkWholeNum
+ }}
+pcx::check 0.1 std ::bee::decodeCancel \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 0.1 std ::bee::decodeChannel \
+ {checkSimpleArgs 1 -1 {
+ checkChannelID
+ {checkConstrained {checkSequence {
+ {checkSwitches exact {
+ {-command {checkSetConstraint cmd {checkProcCall 3}}}
+ {-exaxt}
+ {-prefix checkWord}
+ } {checkAtEnd}}
+ {checkConstraint {
+ {!cmd {warn bee::needCommand {} checkNOP}}
+ } {checkNOP}}
+ }}}
+ }}
+pcx::check 0.1 std ::bee::decodeIndices \
+ {checkSimpleArgs 1 3 {
+ checkWord
+ checkVarNameWrite
+ checkWholeNum
+ }}
+pcx::check 0.1 std ::bee::decodePush \
+ {checkSimpleArgs 2 2 {
+ checkWord
+ checkWord
+ }}
+pcx::check 0.1 std ::bee::encodeDict \
+ {checkSimpleArgs 1 1 {
+ checkDict
+ }}
+pcx::check 0.1 std ::bee::encodeDictArgs \
+ {checkSimpleArgsModNk 0 2 {
+ checkWord
+ checkWord
+ }}
+pcx::check 0.1 std ::bee::encodeList \
+ {checkSimpleArgs 1 1 {
+ checkList
+ }}
+pcx::check 0.1 std ::bee::encodeListArgs \
+ {checkSimpleArgs 0 -1 {
+ checkWord
+ }}
+pcx::check 0.1 std ::bee::encodeNumber \
+ {checkSimpleArgs 1 1 {
+ checkInt
+ }}
+pcx::check 0.1 std ::bee::encodeString \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+
+# Initialization via pcx::init.
+# Use a ::bee::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/bee/bee.tcl b/tcllib/modules/bee/bee.tcl
new file mode 100644
index 0000000..6eb53c0
--- /dev/null
+++ b/tcllib/modules/bee/bee.tcl
@@ -0,0 +1,990 @@
+# bee.tcl --
+#
+# BitTorrent Bee de- and encoder.
+#
+# Copyright (c) 2004 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# See the file license.terms.
+
+package require Tcl 8.4
+
+namespace eval ::bee {
+ # Encoder commands
+ namespace export \
+ encodeString encodeNumber \
+ encodeListArgs encodeList \
+ encodeDictArgs encodeDict
+
+ # Decoder commands.
+ namespace export \
+ decode \
+ decodeChannel \
+ decodeCancel \
+ decodePush
+
+ # Channel decoders, reference to state information, keyed by
+ # channel handle.
+
+ variable bee
+ array set bee {}
+
+ # Counter for generation of names for the state variables.
+
+ variable count 0
+
+ # State information for the channel decoders.
+
+ # stateN, with N an integer number counting from 0 on up.
+ # ...(chan) Handle of channel the decoder is for.
+ # ...(cmd) Command prefix, completion callback
+ # ...(exact) Boolean flag, set for exact processing.
+ # ...(read) Buffer for new characters to process.
+ # ...(type) Type of current value (integer, string, list, dict)
+ # ...(value) Buffer for assembling the current value.
+ # ...(pend) Stack of pending 'value' buffers, for nested
+ # containers.
+ # ...(state) Current state of the decoding state machine.
+
+ # States of the finite automaton ...
+ # intro - One char, type of value, or 'e' as stop of container.
+ # signum - sign or digit, for integer.
+ # idigit - digit, for integer, or 'e' as stop
+ # ldigit - digit, for length of string, or :
+ # data - string data, 'get' characters.
+ # Containers via 'pend'.
+
+ #Debugging help, nesting level
+ #variable X 0
+}
+
+
+# ::bee::encodeString --
+#
+# Encode a string to bee-format.
+#
+# Arguments:
+# string The string to encode.
+#
+# Results:
+# The bee-encoded form of the string.
+
+proc ::bee::encodeString {string} {
+ return "[string length $string]:$string"
+}
+
+
+# ::bee::encodeNumber --
+#
+# Encode an integer number to bee-format.
+#
+# Arguments:
+# num The integer number to encode.
+#
+# Results:
+# The bee-encoded form of the integer number.
+
+proc ::bee::encodeNumber {num} {
+ if {![string is integer -strict $num]} {
+ return -code error "Expected integer number, got \"$num\""
+ }
+
+ # The reformatting deals with hex, octal and other tcl
+ # representation of the value. In other words we normalize the
+ # string representation of the input value.
+
+ set num [format %d $num]
+ return "i${num}e"
+}
+
+
+# ::bee::encodeList --
+#
+# Encode a list of bee-coded values to bee-format.
+#
+# Arguments:
+# list The list to encode.
+#
+# Results:
+# The bee-encoded form of the list.
+
+proc ::bee::encodeList {list} {
+ return "l[join $list ""]e"
+}
+
+
+# ::bee::encodeListArgs --
+#
+# Encode a variable list of bee-coded values to bee-format.
+#
+# Arguments:
+# args The values to encode.
+#
+# Results:
+# The bee-encoded form of the list of values.
+
+proc ::bee::encodeListArgs {args} {
+ return [encodeList $args]
+}
+
+
+# ::bee::encodeDict --
+#
+# Encode a dictionary of keys and bee-coded values to bee-format.
+#
+# Arguments:
+# dict The dictionary to encode.
+#
+# Results:
+# The bee-encoded form of the dictionary.
+
+proc ::bee::encodeDict {dict} {
+ if {([llength $dict] % 2) == 1} {
+ return -code error "Expected even number of elements, got \"[llength $dict]\""
+ }
+ set temp [list]
+ foreach {k v} $dict {
+ lappend temp [list $k $v]
+ }
+ set res "d"
+ foreach item [lsort -index 0 $temp] {
+ foreach {k v} $item break
+ append res [encodeString $k]$v
+ }
+ append res "e"
+ return $res
+}
+
+
+# ::bee::encodeDictArgs --
+#
+# Encode a variable dictionary of keys and bee-coded values to bee-format.
+#
+# Arguments:
+# args The keys and values to encode.
+#
+# Results:
+# The bee-encoded form of the dictionary.
+
+proc ::bee::encodeDictArgs {args} {
+ return [encodeDict $args]
+}
+
+
+# ::bee::decode --
+#
+# Decode a bee-encoded value and returns the embedded tcl
+# value. For containers this recurses into the contained value.
+#
+# Arguments:
+# value The string containing the bee-encoded value to decode.
+# evar Optional. If set the name of the variable to store the
+# index of the first character after the decoded value to.
+# start Optional. If set the index of the first character of the
+# value to decode. Defaults to 0, i.e. the beginning of the
+# string.
+#
+# Results:
+# The tcl value embedded in the encoded string.
+
+proc ::bee::decode {value {evar {}} {start 0}} {
+ #variable X
+ #puts -nonewline "[string repeat " " $X]decode @$start" ; flush stdout
+
+ if {$evar ne ""} {upvar 1 $evar end} else {set end _}
+
+ if {[string length $value] < ($start+2)} {
+ # This checked that the 'start' index is still in the string,
+ # and the end of the value most likely as well. Note that each
+ # encoded value consists of at least two characters (the
+ # bracketing characters for integer, list, and dict, and for
+ # string at least one digit length and the colon).
+
+ #puts \t[string length $value]\ <\ ($start+2)
+ return -code error "String not large enough for value"
+ }
+
+ set type [string index $value $start]
+
+ #puts -nonewline " $type=" ; flush stdout
+
+ if {$type eq "i"} {
+ # Extract integer
+ #puts -nonewline integer ; flush stdout
+
+ incr start ; # Skip over intro 'i'.
+ set end [string first e $value $start]
+ if {$end < 0} {
+ return -code error "End of integer number not found"
+ }
+ incr end -1 ; # Get last character before closing 'e'.
+ set num [string range $value $start $end]
+ if {
+ [regexp {^-0+$} $num] ||
+ ![string is integer -strict $num] ||
+ (([string length $num] > 1) && [string match 0* $num])
+ } {
+ return -code error "Expected integer number, got \"$num\""
+ }
+ incr end 2 ; # Step after closing 'e' to the beginning of
+ # ........ ; # the next bee-value behind the current one.
+
+ #puts " ($num) @$end"
+ return $num
+
+ } elseif {($type eq "l") || ($type eq "d")} {
+ #puts -nonewline $type\n ; flush stdout
+
+ # Extract list or dictionary, recursively each contained
+ # element. From the perspective of the decoder this is the
+ # same, the tcl representation of both is a list, and for a
+ # dictionary keys and values are also already in the correct
+ # order.
+
+ set result [list]
+ incr start ; # Step over intro 'e' to beginning of the first
+ # ........ ; # contained value, or behind the container (if
+ # ........ ; # empty).
+
+ set end $start
+ #incr X
+ while {[string index $value $start] ne "e"} {
+ lappend result [decode $value end $start]
+ set start $end
+ }
+ #incr X -1
+ incr end
+
+ #puts "[string repeat " " $X]($result) @$end"
+
+ if {$type eq "d" && ([llength $result] % 2 == 1)} {
+ return -code error "Dictionary has to be of even length"
+ }
+ return $result
+
+ } elseif {[string match {[0-9]} $type]} {
+ #puts -nonewline string ; flush stdout
+
+ # Extract string. First the length, bounded by a colon, then
+ # the appropriate number of characters.
+
+ set end [string first : $value $start]
+ if {$end < 0} {
+ return -code error "End of string length not found"
+ }
+ incr end -1
+ set length [string range $value $start $end]
+ incr end 2 ;# Skip to beginning of the string after the colon
+
+ if {![string is integer -strict $length]} {
+ return -code error "Expected integer number for string length, got \"$length\""
+ } elseif {$length < 0} {
+ # This cannot happen. To happen "-" has to be first character,
+ # and this is caught as unknown bee-type.
+ return -code error "Illegal negative string length"
+ } elseif {($end + $length) > [string length $value]} {
+ return -code error "String not large enough for value"
+ }
+
+ #puts -nonewline \[$length\] ; flush stdout
+ if {$length > 0} {
+ set start $end
+ incr end $length
+ incr end -1
+ set result [string range $value $start $end]
+ incr end
+ } else {
+ set result ""
+ }
+
+ #puts " ($result) @$end"
+ return $result
+
+ } else {
+ return -code error "Unknown bee-type \"$type\""
+ }
+}
+
+# ::bee::decodeIndices --
+#
+# Similar to 'decode', but does not return the decoded tcl values,
+# but a structure containing the start- and end-indices for all
+# values in the structure.
+#
+# Arguments:
+# value The string containing the bee-encoded value to decode.
+# evar Optional. If set the name of the variable to store the
+# index of the first character after the decoded value to.
+# start Optional. If set the index of the first character of the
+# value to decode. Defaults to 0, i.e. the beginning of the
+# string.
+#
+# Results:
+# The structure of the value, with indices and types for all
+# contained elements.
+
+proc ::bee::decodeIndices {value {evar {}} {start 0}} {
+ #variable X
+ #puts -nonewline "[string repeat " " $X]decode @$start" ; flush stdout
+
+ if {$evar ne ""} {upvar 1 $evar end} else {set end _}
+
+ if {[string length $value] < ($start+2)} {
+ # This checked that the 'start' index is still in the string,
+ # and the end of the value most likely as well. Note that each
+ # encoded value consists of at least two characters (the
+ # bracketing characters for integer, list, and dict, and for
+ # string at least one digit length and the colon).
+
+ #puts \t[string length $value]\ <\ ($start+2)
+ return -code error "String not large enough for value"
+ }
+
+ set type [string index $value $start]
+
+ #puts -nonewline " $type=" ; flush stdout
+
+ if {$type eq "i"} {
+ # Extract integer
+ #puts -nonewline integer ; flush stdout
+
+ set begin $start
+
+ incr start ; # Skip over intro 'i'.
+ set end [string first e $value $start]
+ if {$end < 0} {
+ return -code error "End of integer number not found"
+ }
+ incr end -1 ; # Get last character before closing 'e'.
+ set num [string range $value $start $end]
+ if {
+ [regexp {^-0+$} $num] ||
+ ![string is integer -strict $num] ||
+ (([string length $num] > 1) && [string match 0* $num])
+ } {
+ return -code error "Expected integer number, got \"$num\""
+ }
+ incr end
+ set stop $end
+ incr end 1 ; # Step after closing 'e' to the beginning of
+ # ........ ; # the next bee-value behind the current one.
+
+ #puts " ($num) @$end"
+ return [list integer $begin $stop]
+
+ } elseif {$type eq "l"} {
+ #puts -nonewline $type\n ; flush stdout
+
+ # Extract list, recursively each contained element.
+
+ set result [list]
+
+ lappend result list $start @
+
+ incr start ; # Step over intro 'e' to beginning of the first
+ # ........ ; # contained value, or behind the container (if
+ # ........ ; # empty).
+
+ set end $start
+ #incr X
+
+ set contained [list]
+ while {[string index $value $start] ne "e"} {
+ lappend contained [decodeIndices $value end $start]
+ set start $end
+ }
+ lappend result $contained
+ #incr X -1
+ set stop $end
+ incr end
+
+ #puts "[string repeat " " $X]($result) @$end"
+
+ return [lreplace $result 2 2 $stop]
+
+ } elseif {($type eq "l") || ($type eq "d")} {
+ #puts -nonewline $type\n ; flush stdout
+
+ # Extract dictionary, recursively each contained element.
+
+ set result [list]
+
+ lappend result dict $start @
+
+ incr start ; # Step over intro 'e' to beginning of the first
+ # ........ ; # contained value, or behind the container (if
+ # ........ ; # empty).
+
+ set end $start
+ set atkey 1
+ #incr X
+
+ set contained [list]
+ set val [list]
+ while {[string index $value $start] ne "e"} {
+ if {$atkey} {
+ lappend contained [decode $value {} $start]
+ lappend val [decodeIndices $value end $start]
+ set atkey 0
+ } else {
+ lappend val [decodeIndices $value end $start]
+ lappend contained $val
+ set val [list]
+ set atkey 1
+ }
+ set start $end
+ }
+ lappend result $contained
+ #incr X -1
+ set stop $end
+ incr end
+
+ #puts "[string repeat " " $X]($result) @$end"
+
+ if {[llength $result] % 2 == 1} {
+ return -code error "Dictionary has to be of even length"
+ }
+ return [lreplace $result 2 2 $stop]
+
+ } elseif {[string match {[0-9]} $type]} {
+ #puts -nonewline string ; flush stdout
+
+ # Extract string. First the length, bounded by a colon, then
+ # the appropriate number of characters.
+
+ set end [string first : $value $start]
+ if {$end < 0} {
+ return -code error "End of string length not found"
+ }
+ incr end -1
+ set length [string range $value $start $end]
+ incr end 2 ;# Skip to beginning of the string after the colon
+
+ if {![string is integer -strict $length]} {
+ return -code error "Expected integer number for string length, got \"$length\""
+ } elseif {$length < 0} {
+ # This cannot happen. To happen "-" has to be first character,
+ # and this is caught as unknown bee-type.
+ return -code error "Illegal negative string length"
+ } elseif {($end + $length) > [string length $value]} {
+ return -code error "String not large enough for value"
+ }
+
+ #puts -nonewline \[$length\] ; flush stdout
+ incr end -1
+ if {$length > 0} {
+ incr end $length
+ set stop $end
+ } else {
+ set stop $end
+ }
+ incr end
+
+ #puts " ($result) @$end"
+ return [list string $start $stop]
+
+ } else {
+ return -code error "Unknown bee-type \"$type\""
+ }
+}
+
+
+# ::bee::decodeChannel --
+#
+# Attach decoder for a bee-value to a channel. See the
+# documentation for details.
+#
+# Arguments:
+# chan Channel to attach to.
+# -command cmdprefix Completion callback. Required.
+# -exact Keep running after completion.
+# -prefix data Seed for decode buffer.
+#
+# Results:
+# A token to use when referring to the decoder.
+# For example when canceling it.
+
+proc ::bee::decodeChannel {chan args} {
+ variable bee
+ if {[info exists bee($chan)]} {
+ return -code error "bee-Decoder already active for channel"
+ }
+
+ # Create state and token.
+
+ variable count
+ variable [set st state$count]
+ array set $st {}
+ set bee($chan) $st
+ upvar 0 $st state
+ incr count
+
+ # Initialize the decoder state, process the options. When
+ # encountering errors here destroy the half-baked state before
+ # throwing the message.
+
+ set state(chan) $chan
+ array set state {
+ exact 0
+ type ?
+ read {}
+ value {}
+ pend {}
+ state intro
+ get 1
+ }
+
+ while {[llength $args]} {
+ set option [lindex $args 0]
+ set args [lrange $args 1 end]
+ if {$option eq "-command"} {
+ if {![llength $args]} {
+ unset bee($chan)
+ unset state
+ return -code error "Missing value for option -command."
+ }
+ set state(cmd) [lindex $args 0]
+ set args [lrange $args 1 end]
+
+ } elseif {$option eq "-prefix"} {
+ if {![llength $args]} {
+ unset bee($chan)
+ unset state
+ return -code error "Missing value for option -prefix."
+ }
+ set state(read) [lindex $args 0]
+ set args [lrange $args 1 end]
+
+ } elseif {$option eq "-exact"} {
+ set state(exact) 1
+ } else {
+ unset bee($chan)
+ unset state
+ return -code error "Illegal option \"$option\",\
+ expected \"-command\", \"-prefix\", or \"-keep\""
+ }
+ }
+
+ if {![info exists state(cmd)]} {
+ unset bee($chan)
+ unset state
+ return -code error "Missing required completion callback."
+ }
+
+ # Set up the processing of incoming data.
+
+ fileevent $chan readable [list ::bee::Process $chan $bee($chan)]
+
+ # Return the name of the state array as token.
+ return $bee($chan)
+}
+
+# ::bee::Parse --
+#
+# Internal helper. Fileevent handler for a decoder.
+# Parses input and handles both error and eof conditions.
+#
+# Arguments:
+# token The decoder to run on its input.
+#
+# Results:
+# None.
+
+proc ::bee::Process {chan token} {
+ if {[catch {Parse $token} msg]} {
+ # Something failed. Destroy and report.
+ Command $token error $msg
+ return
+ }
+
+ if {[eof $chan]} {
+ # Having data waiting, either in the input queue, or in the
+ # output stack (of nested containers) is a failure. Report
+ # this instead of the eof.
+
+ variable $token
+ upvar 0 $token state
+
+ if {
+ [string length $state(read)] ||
+ [llength $state(pend)] ||
+ [string length $state(value)] ||
+ ($state(state) ne "intro")
+ } {
+ Command $token error "Incomplete value at end of channel"
+ } else {
+ Command $token eof
+ }
+ }
+ return
+}
+
+# ::bee::Parse --
+#
+# Internal helper. Reading from the channel and parsing the input.
+# Uses a hardwired state machine.
+#
+# Arguments:
+# token The decoder to run on its input.
+#
+# Results:
+# None.
+
+proc ::bee::Parse {token} {
+ variable $token
+ upvar 0 $token state
+ upvar 0 state(state) current
+ upvar 0 state(read) input
+ upvar 0 state(type) type
+ upvar 0 state(value) value
+ upvar 0 state(pend) pend
+ upvar 0 state(exact) exact
+ upvar 0 state(get) get
+ set chan $state(chan)
+
+ #puts Parse/$current
+
+ if {!$exact} {
+ # Add all waiting characters to the buffer so that we can process as
+ # much as is possible in one go.
+ append input [read $chan]
+ } else {
+ # Exact reading. Usually one character, but when in the data
+ # section for a string value we know for how many characters
+ # we are looking for.
+
+ append input [read $chan $get]
+ }
+
+ # We got nothing, do nothing.
+ if {![string length $input]} return
+
+
+ if {$current eq "data"} {
+ # String data, this can be done faster, as we read longer
+ # sequences of characters for this.
+ set l [string length $input]
+ if {$l < $get} {
+ # Not enough, wait for more.
+ append value $input
+ incr get -$l
+ return
+ } elseif {$l == $get} {
+ # Got all, exactly. Prepare state machine for next value.
+
+ if {[Complete $token $value$input]} return
+
+ set current intro
+ set get 1
+ set value ""
+ set input ""
+
+ return
+ } else {
+ # Got more than required (only for !exact).
+
+ incr get -1
+ if {[Complete $token $value[string range $input 0 $get]]} {return}
+
+ incr get
+ set input [string range $input $get end]
+ set get 1
+ set value ""
+ set current intro
+ # This now falls into the loop below.
+ }
+ }
+
+ set where 0
+ set n [string length $input]
+
+ #puts Parse/$n
+
+ while {$where < $n} {
+ # Hardwired state machine. Get current character.
+ set ch [string index $input $where]
+
+ #puts Parse/@$where/$current/$ch/
+ if {$current eq "intro"} {
+ # First character of a value.
+
+ if {$ch eq "i"} {
+ # Begin reading integer.
+ set type integer
+ set current signum
+ } elseif {$ch eq "l"} {
+ # Begin a list.
+ set type list
+ lappend pend list {}
+ #set current intro
+
+ } elseif {$ch eq "d"} {
+ # Begin a dictionary.
+ set type dict
+ lappend pend dict {}
+ #set current intro
+
+ } elseif {$ch eq "e"} {
+ # Close a container. Throw an error if there is no
+ # container to close.
+
+ if {![llength $pend]} {
+ return -code error "End of container outside of container."
+ }
+
+ set v [lindex $pend end]
+ set t [lindex $pend end-1]
+ set pend [lrange $pend 0 end-2]
+
+ if {$t eq "dict" && ([llength $v] % 2 == 1)} {
+ return -code error "Dictionary has to be of even length"
+ }
+
+ if {[Complete $token $v]} {return}
+ set current intro
+
+ } elseif {[string match {[0-9]} $ch]} {
+ # Begin reading a string, length section first.
+ set type string
+ set current ldigit
+ set value $ch
+
+ } else {
+ # Unknown type. Throw error.
+ return -code error "Unknown bee-type \"$ch\""
+ }
+
+ # To next character.
+ incr where
+ } elseif {$current eq "signum"} {
+ # Integer number, a minus sign, or a digit.
+ if {[string match {[-0-9]} $ch]} {
+ append value $ch
+ set current idigit
+ } else {
+ return -code error "Syntax error in integer,\
+ expected sign or digit, got \"$ch\""
+ }
+ incr where
+
+ } elseif {$current eq "idigit"} {
+ # Integer number, digit or closing 'e'.
+
+ if {[string match {[-0-9]} $ch]} {
+ append value $ch
+ } elseif {$ch eq "e"} {
+ # Integer closes. Validate and report.
+ #puts validate
+ if {
+ [regexp {^-0+$} $value] ||
+ ![string is integer -strict $value] ||
+ (([string length $value] > 1) && [string match 0* $value])
+ } {
+ return -code error "Expected integer number, got \"$value\""
+ }
+
+ if {[Complete $token $value]} {return}
+ set value ""
+ set current intro
+ } else {
+ return -code error "Syntax error in integer,\
+ expected digit, or 'e', got \"$ch\""
+ }
+ incr where
+
+ } elseif {$current eq "ldigit"} {
+ # String, length section, digit, or :
+
+ if {[string match {[-0-9]} $ch]} {
+ append value $ch
+
+ } elseif {$ch eq ":"} {
+ # Length section closes, validate,
+ # then perform data processing.
+
+ set num $value
+ if {
+ [regexp {^-0+$} $num] ||
+ ![string is integer -strict $num] ||
+ (([string length $num] > 1) && [string match 0* $num])
+ } {
+ return -code error "Expected integer number as string length, got \"$num\""
+ }
+
+ set value ""
+
+ # We may have already part of the data in
+ # memory. Process that piece before looking for more.
+
+ incr where
+ set have [expr {$n - $where}]
+ if {$num < $have} {
+ # More than enough in the buffer.
+
+ set end $where
+ incr end $num
+ incr end -1
+
+ if {[Complete $token [string range $input $where $end]]} {return}
+
+ set where $end ;# Further processing behind the string.
+ set current intro
+
+ } elseif {$num == $have} {
+ # Just enough.
+
+ if {[Complete $token [string range $input $where end]]} {return}
+
+ set where $n
+ set current intro
+ } else {
+ # Not enough. Initialize value with the data we
+ # have (after the colon) and stop processing for
+ # now.
+
+ set value [string range $input $where end]
+ set current data
+ set get $num
+ set input ""
+ return
+ }
+ } else {
+ return -code error "Syntax error in string length,\
+ expected digit, or ':', got \"$ch\""
+ }
+ incr where
+ } else {
+ # unknown state = internal error
+ return -code error "Unknown decoder state \"$current\", internal error"
+ }
+ }
+
+ set input ""
+ return
+}
+
+# ::bee::Command --
+#
+# Internal helper. Runs the decoder command callback.
+#
+# Arguments:
+# token The decoder invoking its callback
+# how Which method to invoke (value, error, eof)
+# args Arguments for the method.
+#
+# Results:
+# A boolean flag. Set if further processing has to stop.
+
+proc ::bee::Command {token how args} {
+ variable $token
+ upvar 0 $token state
+
+ #puts Report/$token/$how/$args/
+
+ set cmd $state(cmd)
+ set chan $state(chan)
+
+ # We catch the fileevents because they will fail when this is
+ # called from the 'Close'. The channel will already be gone in
+ # that case.
+
+ set stop 0
+ if {($how eq "error") || ($how eq "eof")} {
+ variable bee
+
+ set stop 1
+ fileevent $chan readable {}
+ unset bee($chan)
+ unset state
+
+ if {$how eq "eof"} {
+ #puts \tclosing/$chan
+ close $chan
+ }
+ }
+
+ lappend cmd $how $token
+ foreach a $args {lappend cmd $a}
+ uplevel #0 $cmd
+
+ if {![info exists state]} {
+ # The decoder token was killed by the callback, stop
+ # processing.
+ set stop 1
+ }
+
+ #puts /$stop/[file channels]
+ return $stop
+}
+
+# ::bee::Complete --
+#
+# Internal helper. Reports a completed value.
+#
+# Arguments:
+# token The decoder reporting the value.
+# value The value to report.
+#
+# Results:
+# A boolean flag. Set if further processing has to stop.
+
+proc ::bee::Complete {token value} {
+ variable $token
+ upvar 0 $token state
+ upvar 0 state(pend) pend
+
+ if {[llength $pend]} {
+ # The value is part of a container. Add the value to its end
+ # and keep processing.
+
+ set pend [lreplace $pend end end \
+ [linsert [lindex $pend end] end \
+ $value]]
+
+ # Don't stop.
+ return 0
+ }
+
+ # The value is at the top, report it. The callback determines if
+ # we keep processing.
+
+ return [Command $token value $value]
+}
+
+# ::bee::decodeCancel --
+#
+# Destroys the decoder referenced by the token.
+#
+# Arguments:
+# token The decoder to destroy.
+#
+# Results:
+# None.
+
+proc ::bee::decodeCancel {token} {
+ variable bee
+ variable $token
+ upvar 0 $token state
+ unset bee($state(chan))
+ unset state
+ return
+}
+
+# ::bee::decodePush --
+#
+# Push data into the decoder input buffer.
+#
+# Arguments:
+# token The decoder to extend.
+# string The characters to add.
+#
+# Results:
+# None.
+
+proc ::bee::decodePush {token string} {
+ variable $token
+ upvar 0 $token state
+ append state(read) $string
+ return
+}
+
+
+package provide bee 0.1
diff --git a/tcllib/modules/bee/bee.test b/tcllib/modules/bee/bee.test
new file mode 100644
index 0000000..4ea1c7c
--- /dev/null
+++ b/tcllib/modules/bee/bee.test
@@ -0,0 +1,384 @@
+# -*- tcl -*-
+# bee.test: tests for the bee encoding.
+#
+# Copyright (c) 2004 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: bee.test,v 1.9 2006/10/09 21:41:39 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 1.0
+
+testing {
+ useLocal bee.tcl bee
+}
+
+# -------------------------------------------------------------------------
+# encoder ............................................................
+
+test bee-1.0 {encoder, string} {
+ bee::encodeString ""
+} {0:}
+
+test bee-1.1 {encoder, string} {
+ bee::encodeString spam
+} {4:spam}
+
+test bee-1.2 {encoder, string, wrong#args} {
+ catch {bee::encodeString} msg
+ set msg
+} [tcltest::wrongNumArgs {bee::encodeString} {string} 1]
+
+test bee-1.3 {encoder, string, wrong#args} {
+ catch {bee::encodeString 3 4} msg
+ set msg
+} [tcltest::tooManyArgs {bee::encodeString} {string}]
+
+
+
+test bee-2.0 {encoder, integer} {
+ bee::encodeNumber 0
+} {i0e}
+
+test bee-2.1 {encoder, integer, stupid zero} {
+ bee::encodeNumber -0
+} {i0e}
+
+test bee-2.2 {encoder, integer, good octal} {
+ bee::encodeNumber 004
+} {i4e}
+
+test bee-2.3 {encoder, integer, negatives} {
+ bee::encodeNumber -5
+} {i-5e}
+
+test bee-2.4 {encoder, integer, non-numeric} {
+ catch {bee::encodeNumber spam} msg
+ set msg
+} {Expected integer number, got "spam"}
+
+test bee-2.5 {encoder, integer, bad octal} {
+ catch {bee::encodeNumber 009} msg
+ set msg
+} {Expected integer number, got "009"}
+
+test bee-2.6 {encoder, integer, hex} {
+ bee::encodeNumber 0x45
+} {i69e}
+
+test bee-2.7 {encoder, integer, wrong#args} {
+ catch {bee::encodeNumber} msg
+ set msg
+} [tcltest::wrongNumArgs {bee::encodeNumber} {num} 1]
+
+test bee-2.8 {encoder, integer, wrong#args} {
+ catch {bee::encodeNumber 3 4} msg
+ set msg
+} [tcltest::tooManyArgs {bee::encodeNumber} {num}]
+
+
+
+test bee-3.0 {encoder, list, empty} {
+ bee::encodeListArgs
+} {le}
+
+test bee-3.1 {encoder, list, empty elements} {
+ bee::encodeListArgs [bee::encodeString {}] [bee::encodeString {}]
+} {l0:0:e}
+
+test bee-3.2 {encoder, list, regular elements} {
+ bee::encodeListArgs [bee::encodeString eggs] [bee::encodeNumber 12]
+} {l4:eggsi12ee}
+
+test bee-3.3 {encoder, list, empty} {
+ bee::encodeList {}
+} {le}
+
+test bee-3.4 {encoder, list, empty elements} {
+ bee::encodeList [list [bee::encodeString {}] [bee::encodeString {}]]
+} {l0:0:e}
+
+test bee-3.5 {encoder, list, regular elements} {
+ bee::encodeList [list [bee::encodeString eggs] [bee::encodeNumber 12]]
+} {l4:eggsi12ee}
+
+test bee-3.6 {encoder, list, empty} {
+ catch {bee::encodeList} msg
+ set msg
+} [tcltest::wrongNumArgs {bee::encodeList} {list} 1]
+
+test bee-3.7 {encoder, list, empty} {
+ catch {bee::encodeList 1 2} msg
+ set msg
+} [tcltest::tooManyArgs {bee::encodeList} {list}]
+
+
+test bee-4.0 {encoder, dict, empty} {
+ bee::encodeDictArgs
+} {de}
+
+test bee-4.1 {encoder, dict, empty elements} {
+ bee::encodeDictArgs {} [bee::encodeString {}]
+} {d0:0:e}
+
+test bee-4.2 {encoder, dict, regular elements} {
+ bee::encodeDictArgs eggs [bee::encodeNumber 12]
+} {d4:eggsi12ee}
+
+test bee-4.3 {encoder, dict, empty} {
+ bee::encodeDict {}
+} {de}
+
+test bee-4.4 {encoder, dict, empty elements} {
+ bee::encodeDict [list {} [bee::encodeString {}]]
+} {d0:0:e}
+
+test bee-4.5 {encoder, dict, regular elements} {
+ bee::encodeDict [list eggs [bee::encodeNumber 12]]
+} {d4:eggsi12ee}
+
+test bee-4.6 {encoder, dict, empty} {
+ catch {bee::encodeDict} msg
+ set msg
+} [tcltest::wrongNumArgs {bee::encodeDict} {dict} 1]
+
+test bee-4.7 {encoder, dict, empty} {
+ catch {bee::encodeDict 1 2} msg
+ set msg
+} [tcltest::tooManyArgs {bee::encodeDict} {dict}]
+
+test bee-4.8 {encoder, dict, sorted keys} {
+ bee::encodeDictArgs spam [bee::encodeNumber 2] eggs [bee::encodeNumber 12]
+} {d4:eggsi12e4:spami2ee}
+
+
+# decoder ............................................................
+
+proc tick {m tok args} {
+ global res tick
+ lappend res $m $args
+ if {$m eq "eof" || $m eq "error"} {set tick 0}
+ return
+}
+
+proc tickoff {m tok args} {
+ global res tick
+ lappend res $m $args
+ bee::decodeCancel $tok
+ set tick 0
+ return
+}
+
+proc gen {name data} {
+ set path [makeFile {} $name]
+ set f [open $path w]
+ puts -nonewline $f $data
+ close $f
+ return $path
+}
+
+foreach {n bee result} {
+ 0 i0e {0 3}
+ 1 i-5e {-5 4}
+ 2 4:spam {spam 6}
+ 3 0: {{} 2}
+ 4 le {{} 2}
+ 5 l0:e {{{}} 4}
+ 6 li5ee {5 5}
+ 7 li5e4:spame {{5 spam} 11}
+ 8 de {{} 2}
+ 9 d0:0:e {{{} {}} 6}
+ 10 d0:i5ee {{{} 5} 7}
+ 11 d1:a4:spame {{a spam} 11}
+ 12 ld1:a4:spame3:egge {{{a spam} egg} 18}
+ 13 13:eggs+spam+ham {eggs+spam+ham 16}
+ 14 d1:a1:b1:c1:de {{a b c d} 14}
+} {
+ test bee-5.$n {decoder} {
+ list [bee::decode $bee end] $end
+ } $result ; # {}
+
+ test bee-6.$n {decoder, channel} {
+ set path [gen bee6.$n $bee]
+
+ set res "" ; set tick 1
+ bee::decodeChannel [open $path r] \
+ -command tick
+ vwait tick
+ removeFile bee6.$n
+ set res
+ } [list value [list [lindex $result 0]] eof {}] ; # {}
+
+ test bee-7.$n {decoder, channel} {
+ set path [gen bee7.$n $bee]
+
+ set res "" ; set tick 1
+ bee::decodeChannel [open $path r] \
+ -command tick -exact
+ vwait tick
+ removeFile bee7.$n
+ set res
+ } [list value [list [lindex $result 0]] eof {}] ; # {}
+}
+
+foreach {n bee result resultchan} {
+ 0 i-0e {Expected integer number, got "-0"}
+ {Expected integer number, got "-0"}
+ 1 i-5 {End of integer number not found}
+ {Incomplete value at end of channel}
+ 2 ie {Expected integer number, got ""}
+ {Syntax error in integer, expected sign or digit, got "e"}
+ 3 4: {String not large enough for value}
+ {Incomplete value at end of channel}
+ 4 1: {String not large enough for value}
+ {Incomplete value at end of channel}
+ 5 0 {String not large enough for value}
+ {Incomplete value at end of channel}
+ 6 123 {End of string length not found}
+ {Incomplete value at end of channel}
+ 7 12t: {Expected integer number for string length, got "12t"}
+ {Syntax error in string length, expected digit, or ':', got "t"}
+ 8 -123 {Unknown bee-type "-"}
+ {Unknown bee-type "-"}
+ 9 d0:e {Dictionary has to be of even length}
+ {Dictionary has to be of even length}
+} {
+ test bee-8.$n {decoder errors} {
+ catch {bee::decode $bee} msg
+ set msg
+ } $result ; # {}
+
+ test bee-9.$n {decoder, channel} {
+ set path [gen bee9.$n $bee]
+
+ set res "" ; set tick 1
+ bee::decodeChannel [set f [open $path r]] \
+ -command tick
+ vwait tick
+ close $f
+ removeFile bee9.$n
+ set res
+ } [list error [list $resultchan]] ;# {}
+
+ test bee-10.$n {decoder, channel} {
+ set path [gen bee10.$n $bee]
+
+ set res "" ; set tick 1
+ bee::decodeChannel [set f [open $path r]] \
+ -command tick -exact
+ vwait tick
+ close $f
+ removeFile bee10.$n
+ set res
+ } [list error [list $resultchan]] ;# {}
+}
+
+
+foreach {n bee result} {
+ 0 i0e {{integer 0 2} 3}
+ 1 i-5e {{integer 0 3} 4}
+ 2 4:spam {{string 0 5} 6}
+ 3 0: {{string 0 1} 2}
+ 4 le {{list 0 1 {}} 2}
+ 5 l0:e {{list 0 3 {{string 1 2}}} 4}
+ 6 li5ee {{list 0 4 {{integer 1 3}}} 5}
+ 7 li5e4:spame {{list 0 10 {{integer 1 3} {string 4 9}}} 11}
+ 8 de {{dict 0 1 {}} 2}
+ 9 d0:0:e {{dict 0 5 {{} {{string 1 2} {string 3 4}}}} 6}
+ 10 d0:i5ee {{dict 0 6 {{} {{string 1 2} {integer 3 5}}}} 7}
+ 11 d1:a4:spame {{dict 0 10 {a {{string 1 3} {string 4 9}}}} 11}
+ 12 ld1:a4:spame3:egge {{list 0 17 {{dict 1 11 {a {{string 2 4} {string 5 10}}}} {string 12 16}}} 18}
+ 13 13:eggs+spam+ham {{string 0 15} 16}
+ 14 d1:a1:b1:c1:de {{dict 0 13 {a {{string 1 3} {string 4 6}} c {{string 7 9} {string 10 12}}}} 14}
+} {
+ test bee-11.$n {decoder} {
+ list [bee::decodeIndices $bee end] $end
+ } $result ; # {}
+}
+
+
+test bee-12.0 {decoder, torrent file} {
+ set end 0
+
+ # tcltest::viewFile does not do binary :(
+ set f [open [file join $::tcltest::testsDirectory example.torrent] r]
+ fconfigure $f -translation binary
+ set d [read $f]
+ close $f
+
+ set data [bee::decode $d end]
+
+ # Cut the binary stuff out of the result, to much, display problems
+ list [lreplace $data 5 5 [lreplace [lindex $data 5] end end {}]] $end
+
+} {{announce http://bt.etree.org/announce.php {creation date} 1087598771 info {files {{length 627 path ch1999-05-22.md5} {length 434 path ch1999-05-22.txt} {length 4356201 path ch1999-05-22d1t01.shn} {length 53782885 path ch1999-05-22d1t02.shn} {length 50689401 path ch1999-05-22d1t03.shn} {length 70969629 path ch1999-05-22d1t04.shn} {length 31978833 path ch1999-05-22d1t05.shn} {length 57722005 path ch1999-05-22d1t06.shn} {length 45629997 path ch1999-05-22d2t01.shn} {length 74878121 path ch1999-05-22d2t02.shn} {length 102446341 path ch1999-05-22d2t03.shn} {length 71148293 path ch1999-05-22d2t04.shn}} name ch1999-05-22.schoeps.shnf {piece length} 524288 pieces {}}} 22267}
+
+
+
+foreach {n bee result} {
+ 0 i0e4:hams {value 0 value hams eof {}}
+ 1 lede {value {{}} value {{}} eof {}}
+ 2 le3:egg {value {{}} value egg eof {}}
+ 3 3:eggle {value egg value {{}} eof {}}
+ 4 de3:egg {value {{}} value egg eof {}}
+ 5 3:eggde {value egg value {{}} eof {}}
+ 6 li6e6:plierse3:ham {value {{6 pliers}} value ham eof {}}
+ 7 7:monitorli6e6:plierse {value monitor value {{6 pliers}} eof {}}
+ 8 d6:pliersi6ee3:ham {value {{pliers 6}} value ham eof {}}
+ 9 7:monitord6:pliersi6ee {value monitor value {{pliers 6}} eof {}}
+} {
+ test bee-13.$n {decoder, channel, multiple values} {
+ set path [gen bee13.$n $bee]
+
+ set res "" ; set tick 1
+ bee::decodeChannel [open $path r] \
+ -command tick
+ vwait tick
+ removeFile bee13.$n
+ set res
+ } $result ; # {}
+
+ test bee-14.$n {decoder, channel, multiple values} {
+ set path [gen bee14.$n $bee]
+
+ set res "" ; set tick 1
+ bee::decodeChannel [open $path r] \
+ -command tick -exact
+ vwait tick
+ removeFile bee14.$n
+ set res
+ } $result ; # {}
+
+ test bee-15.$n {decoder, channel, multiple values, abort} {
+ set path [gen bee15.$n $bee]
+
+ set res "" ; set tick 1
+ bee::decodeChannel [set f [open $path r]] \
+ -command tickoff
+ vwait tick
+ close $f
+ removeFile bee15.$n
+ set res
+ } [lrange $result 0 1] ; # {}
+
+ test bee-16.$n {decoder, channel, multiple values, abort} {
+ set path [gen bee16.$n $bee]
+
+ set res "" ; set tick 1
+ bee::decodeChannel [set f [open $path r]] \
+ -command tickoff -exact
+ vwait tick
+ close $f
+ removeFile bee16.$n
+ set res
+ } [lrange $result 0 1] ; # {}
+}
+
+# ....... ............................................................
+testsuiteCleanup
diff --git a/tcllib/modules/bee/example.torrent b/tcllib/modules/bee/example.torrent
new file mode 100644
index 0000000..3421f57
--- /dev/null
+++ b/tcllib/modules/bee/example.torrent
Binary files differ
diff --git a/tcllib/modules/bee/pkgIndex.tcl b/tcllib/modules/bee/pkgIndex.tcl
new file mode 100644
index 0000000..e95dedf
--- /dev/null
+++ b/tcllib/modules/bee/pkgIndex.tcl
@@ -0,0 +1,4 @@
+# Tcl package index file, version 1.1
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded bee 0.1 [list source [file join $dir bee.tcl]]
diff --git a/tcllib/modules/bench/ChangeLog b/tcllib/modules/bench/ChangeLog
new file mode 100644
index 0000000..7693aad
--- /dev/null
+++ b/tcllib/modules/bench/ChangeLog
@@ -0,0 +1,541 @@
+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-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 ========================
+ *
+
+2008-10-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bench.tcl: Bumped to version 0.4 for 2008-06-30 commit by
+ * bench.man: myself. Was a major rewrite of the internals,
+ * pkgIndex.tcl: should have been bumped then.
+
+2008-06-30 Andreas Kupries <andreask@activestate.com>
+
+ * bench.tcl (::bench::Invoke): Reworked the protocol between
+ * libbench.tcl: manager and execution system to allow for
+ incremental returning of results and proper progress
+ feedback. This enables users to see how a benchmark progresses,
+ and to provide their own notes about conditions and decisions as
+ well.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-23 Andreas Kupries <andreask@activestate.com>
+
+ * bench.tcl: Fixed problem with the glob patterns used to query
+ * bench.man: the data array, was not matching the list quoting
+ * pkgIndex.tcl: used to generate the keys. Was fine while we had
+ no keys with spaces in the interp reference, but with -pkgdir
+ this is possible, and broke. Version bumped to 0.3.1. Reported
+ by Rolf Ade.
+
+2007-08-21 Andreas Kupries <andreask@activestate.com>
+
+ * bench.tcl (::bench::run): Extended with a new option -pkgdir
+ * bench.man: helping in the handling of multiple versions of a
+ * pkgIndex.tcl: package to benchmark, as suggested and first
+ * libbench.tcl: implemented by Rolf Ade. Moved invokation of
+ libbench to a separate helper procedure. Extended the
+ documentation. Version bumped to 0.3.
+
+2007-04-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bench_lang_intro.man: New files, documentation of the
+ * bench_lang_spec.man: benchmark declaration language, and
+ * bench_read.man: of the supporting packages.
+ * bench_wcsv.man:
+ * bench_wtext.man:
+
+2007-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * libbench.tcl: Added new benchmark options -ipre, -ipost. Per
+ * pkgIndex.tcl: iteration pre/post scripts, untimed. Version of
+ * bench.cl: package 'bench' is now 0.2.
+
+2007-01-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bench_wcsv.tcl: Fixed sorting of descriptions in text and
+ * bench_wtext.tcl: csv output. Version is now 0.1.2.
+
+2007-01-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bench.tcl (bench::norm): Removed 'split ,' from code, was left
+ * pkgIndex.tcl: in wrongly after the rewrite of the raw
+ representation. The relevant key is a list which we can and have
+ to use directly, no split required. The fixed bug caused the
+ normalization to fail and return the empty string for all
+ cells. Version number bumped to 0.1.1 for this.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-06-13 Andreas Kupries <andreask@activestate.com>
+
+ * bench_read.tcl: Rewrite the internal raw representation, use
+ * bench.tcl: lists as array keys, easier to handle, no
+ * bench_wcsv.tcl: splitting, and quoting is done automatically
+ * bench_wtext.tcl: by Tcl itself. See [Tcllib SF Bug 1414159].
+
+2006-05-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bench_read.tcl: Fixed typo "-error" --> "-code error".
+
+2006-01-25 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * bench_wcsv.tcl : Fixed bug when trying to format benchs on windows.
+ * bench_wtext.tcl: The interpreter path was truncated due to a misuse of
+ split and lindex, where string first was appropriate.
+
+2005-10-27 Andreas Kupries <andreask@activestate.com>
+
+ * bench.tcl (::bench::norm): Fixed bug leaving time data in
+ non-reference column when the reference is empty. To the unwary
+ the result looks like factors, which have ridiculous values. Now
+ the row is shown, but empty.
+
+2005-10-21 Andreas Kupries <andreask@activestate.com>
+
+ * bench.tcl (::bench::del): New command. Removal of a column from
+ benchmark data.
+
+2005-10-18 Andreas Kupries <andreask@activestate.com>
+
+ * bench_read.tcl: New file. Command and package to read benchmark
+ data in the text, csv, or raw formats.
+
+ * bench.tcl (::bench::edit): New command. Changes specified
+ interpreter path to user specified value. Needed if we wish to
+ merge data coming from the same interpreter, for different
+ revisions of the package under test.
+
+2005-10-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Package derived from the original code added to Tcllib.
+
+2004-12-29 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/parse.bench: ensure file size is consistent between interp
+ runs with formatted BOUND string.
+
+2004-12-27 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * doc/runbench.1: fix doc for -throwerrors [Bug 1091766]
+
+ * runbench.tcl (getInterps): use exec << instead of echo [Bug 1091764]
+
+2004-12-24 Miguel Sofer <msofer@users.sf.net>
+
+ * tcl/namespace.bench: new benchmark, measures the cost of calling
+ the same global command alternating different namespaces.
+
+2004-12-20 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/array.bench (new): array hash benchmarks
+
+ * tcl/file.bench: fix checkall to operate for tclsh <=8.0
+
+ * tcl/string.bench: fix string match -nocase for tclsh <=8.2
+
+ * runbench.tcl (convertVersion): add -globtclsh -globwish file
+ path glob opts (tclsh* and wish* by default).
+ Normalize soft-links.
+
+ * normbench.tcl (normalize-text): harden time norm check
+
+2003-08-06 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * normbench.tcl (normalize): correct normalization of new-style
+ stats where TclX data is present in output.
+
+2003-02-11 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/list.bench: lsearch -regexp benchmarks
+
+ * tcl/file.bench: updated with more benchmarks
+
+2003-02-08 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/startup.bench: replaced by file benchmarks
+ * tcl/file.bench: file benchmarks
+
+2002-11-13 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/regexp.bench: added anchored re tests
+
+ * tcl/klist.bench: allow method filter from command lineinvocation.
+
+ * tcl/list.bench: add lset benchmarks
+
+ * tcl/md5.bench: correct to work with pre-8.2 interps
+
+ * tcl/string.bench: add string growth, remove split benchmarks
+ * tcl/split.bench: more split benchmarks
+
+ * runbench.tcl: allow tclsh*/wish* (no version required)
+
+2002-07-24 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * tcl/base64.bench: added the current code from tcllib.
+
+2002-06-20 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * tcl/read.bench: modified to actually "use" the data being read
+ by setting a local variable.
+
+2002-06-20 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * tcl/md5.bench: added the faster implementation from tcllib
+
+2002-06-12 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/catch.bench: corrected use of string map in toplevel code
+
+ * tcl/expr.bench: corrected use of string repeat in toplevel code
+
+ * tcl/sha1.bench: correct wideint problem for 8.4 in sha1DF
+
+ * tcl/string.bench: corrected string equality checks to use
+ different variables (objects)
+
+ * tcl/gccont.bench: new benchmark that does some bioinformatics
+ manipulation on dna sequences
+
+2002-06-12 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * tcl/klist.bench:
+ * tcl/heapsort.bench: added algorithms using [lset]
+
+2002-06-11 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * tcl/regexp.bench: made the bench access the match variables, to
+ benchmark also the read access to them.
+ * tcl/vars.bench: added a "VAR ref local" benchmark, to be able to
+ compare the access times of linked variables to those of local
+ variables.
+
+2002-05-29 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/parse.bench: more complex string parsing benchmark (8.0+)
+
+ * tcl/encoding.bench: start of some encoding benchmarks (8.1+)
+
+ * tcl/expr.bench: added ==/!= expr benchmarks
+
+ * tcl/string.bench: corrected the equality benchmarks to not use
+ the same object unless specified.
+
+2002-04-25 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * runbench.tcl:
+ * libbench.tcl: added ability to set # threads to use if Thread
+ package can be loaded.
+ improved -result error checking
+
+ * tcl/base64.bench: verify result of encode/decode
+
+ * tcl/proc.bench: added empty proc benchmarks
+
+ * tcl/list.bench: added LIST concat benchmarks (hartweg)
+
+2002-03-27 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * tcl/catch.bench: modified the catch benchmarks to allow
+ comparison with catching non-error exceptions; added new
+ "CATCH except" benchmark.
+
+2002-03-15 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * tcl/catch.bench: added benchmark for catch in a body with many
+ nested exception ranges.
+
+2002-02-22 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/loops.bench: added while 1 benchmark
+
+ * tcl/conditional.bench: added if 1/0 benchmark
+
+2002-02-07 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * runbench.tcl: noted thread option.
+
+ * libbench.tcl: added ability to check result of test
+
+ * tcl/base64.bench: stripped arg stuff out of code to make it work
+ in 8.0 as well.
+
+ * tcl/list.bench: corrected list-2.11 to append to simple var.
+
+ * tcl/map.bench: added http mapReply & simple regsubs benchmarks
+
+ * tcl/read.bench: commented out new changing buffersize benchmarks
+ as they do weird things to various interp versions.
+
+ * tcl/regexp.bench: added static regexp benchmarks
+
+ * tcl/string.bench: added string first utf benchmarks
+
+ * tcl/vars.bench: corrected namespace usage for pre-8 interps.
+
+2001-09-25 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/string.bench: added exact string match benchmark and fixed
+ other string match benchmarks
+
+ * tcl/list.bench: added simple list benchmark
+
+ * tcl/vars.bench: added mset benchmarks
+
+ * libbench.tcl:
+ * runbench.tcl: added support for -threads option to try and load
+ a thread package and run separate benchmark files simultaneously.
+
+2001-08-29 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/methods.bench:
+ * tcl/vars.bench: added some more benchmarks
+
+2001-07-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tcl/read.bench: new "read" benchmarks detailing the effect of
+ the buffersize on IO performance. Created to check out the
+ performance patch associated with SF item #427196.
+
+2001-06-19 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/binary.bench: new "binary" benchmarks
+
+ * tcl/string.bench: more random split benchmarks
+
+2001-06-03 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * libbench.tcl:
+ * runbench.tcl: reduced default iterations to 1000 (still quite
+ sufficient to remove random noise).
+
+2001-05-31 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/conditional.bench: added switch/if comparison bench.
+
+ * tcl/base64.bench: new benchmark with base64 code (from tcllib).
+
+ * tcl/md5.bench: new benchmark with Libes' md5 (from tcllib).
+
+ * tcl/sha1.bench: new benchmark with a couple of pure tcl sha1
+ routines (Libes and Fellows).
+
+2001-05-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doc/libbench.n:
+ * doc/runbench.1:
+ * doc/normbench.1: Added documentation of benchmark library and
+ applications.
+
+ * doc: Added documentation directory.
+
+2001-05-22 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * runbench.tcl: corrected error for reporting errors in sourced files
+
+ * tcl/fcopy.bench: made use of bench_tmpfile for more accurate
+ data (not skewed by network).
+
+ * libbench.tcl (bench_tmpfile): correctly allow multiple calls to
+ bench_tmpfile within one file.
+
+ * normbench.tcl: new file that allows for post-process
+ normalization of the benchmark data.
+ Corrected last minute code checkin bug.
+ Added support for moving left (to higher versions) to normalize
+ when the requested version returned non-double data.
+
+ * tcl/libbench.tcl:
+ * tcl/runbench.tcl: changed -iterations to be a maximum number for
+ timings, to override any larger number the benchmark may set for
+ itself.
+ Rearranged result format of benchmarks to return data by benchmark
+ description. Benchmarks are now always returned in alphabetical
+ order of the benchmark description.
+ Changed benchmarks to rerun the interpreter per benchmark file
+ instead of sourcing all files into the same interpreter. This
+ reduces any skew related to excessive mem usage or other factors
+ that may arise for one benchmark file.
+ Changed midpoint numbers to time elapsed calculation.
+ Added -normalize option that post-processes the time information
+ to normalize against one version as a baseline.
+ Changed -errors <bool> to -throwerrors with no arg, and changed
+ the default to not throw errors in benchmark files.
+ Added version string to verbose run info.
+
+ * tcl/klist.bench: added support for <8.0 to all benchmarks except
+ shuffle0, with notably reduced default run iters due to extreme
+ slowness of <8.0 interps for these tasks.
+
+ * tcl/string.bench:
+ * tcl/regexp.bench: fixed incorrect str-repeat replacement function
+
+2001-05-18 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/string.bench: added <8.0 compatible rev-recursive benchmark,
+ fixed non-octal escape in ustring instantiation.
+
+ * tcl/wordcount.bench: added <8.1 compatible benchmarks
+
+ * tcl/methods.bench: return for interps <8.0
+
+2001-05-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tcl/conditional.bench: Changed some descriptions to make them
+ unique and matching to the code.
+
+ * tcl/fcopy.bench: New benchmarks for the [fcopy] command
+ (unsupported0 in older versions of the core).
+
+2001-05-16 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/string.bench: added static string length benchmarks
+
+ * tcl/wordcount.in:
+ * tcl/wordcount.bench: wordcount benchmarks
+
+ * tcl/heapsort.bench: new file with heapsort benchmark
+ * tcl/string.bench:
+ * tcl/matrix.bench:
+ * tcl/regexp.bench: extended benchmarks
+
+2001-05-11 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/string.bench: clarified string reverse benchmarks, added
+ more to the string compare benchmarks.
+
+ * tcl/matrix.bench: some new matrix benchmarks. Basically a seed
+ file looking for more. procs courtesy Sofer.
+
+ * tcl/list.bench: added a list-iter benchmark
+
+ * tcl/klist.bench: reduced default iters in klist.bench. Accuracy
+ seems about the same without the wait...
+
+ * libbench.tcl:
+ * runbench.tcl: added support for -rmatch option (regexp match of
+ benchmark description).
+ Added MIDPOINT verbose puts for interim time notes.
+
+2001-04-11 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tcl/klist.bench: added shuffle5* from wiki.
+
+2001-03-28 Jeff Hobbs <jeffh@activestate.com>
+
+ * tcl/string.bench: fixed str-first proc that had bogus code in it.
+ added more split benchmarks for dkf's split improvement in 8.4.
+
+ * tk/canvas.bench: expanded item draw benchmarks
+
+2001-03-23 <jeffh@activestate.com>
+
+ * tk/canvas.bench: added simple item draw benchmarks
+
+2001-03-15 <jeffh@activestate.com>
+
+ * tcl/klist.bench: improved non-tclbench data output.
+
+ * runbench.tcl: added more error capturing.
+
+ * tcl/string.bench: fixed calls to string repeat to work with
+ <8.1.1 interps.
+
+ * tcl/klist.bench: new file to benchmark various list shuffling
+ techniques (from wiki).
+ * tcl/methods.bench: new file to benchmark various method
+ invocation speeds (petasis).
+
+2000-10-19 Jeff Hobbs <hobbs@ajubasolutions.com>
+
+ * tcl/string.bench (str-append-2): added more append tests
+
+2000-08-30 Jeff Hobbs <hobbs@scriptics.com>
+
+ * tcl/string.bench: made string repeat calls compatible with
+ pre-8.1.1 interpreters.
+
+ * libbench.tcl (bench_tmpfile): add env to global list
+
+2000-08-29 Eric Melski <ericm@ajubasolutions.com>
+
+ * tcl/string.bench: Extended string append benchmarks to exploit
+ new growth algorithm for string objects in Tcl 8.4a2.
+
+2000-05-31 Jeff Hobbs <hobbs@scriptics.com>
+
+ * runbench.tcl: new options -errors (passed to libbench), -verbose
+ (by default we are now quieter on output), -output <text|list|csv>
+ (different output types - csv is char-sep-value for Excel).
+ Added start/finish times (in -verbose mode).
+ * libbench.tcl: libbench now takes -option switches for
+ flexibility, options for -errors BOOL (error suppression), -interp
+ NAME (to specify interp), -match PATTERN (glob pattern to filter
+ tests by desc), -iters NUM (default number of iters to run).
+ Reorganized how data is returned to runbench master.
+
+ * tk/entry.bench (new):
+ * tk/canvas.bench (new): new tests for widget creation, config
+
+ * tcl/array.bench (removed):
+ * tcl/vars.bench: merged array.bench tests into VAR
+
+ * tcl/map.bench: fixed for compatability with Tcl7.4-
+
+2000-05-25 Jeff Hobbs <hobbs@scriptics.com>
+
+ * runbench.tcl: added -match, -notcl, -notk options, restructured
+ startup sequence.
+
+ * libbench.tcl: added ability to return string values from bench
+ tests and support for filtering tests to run.
+
+ * tcl/string.bench: moved string mapping benchmarks and added more
+ string equality benchmarks
+ * tcl/map.bench: added extended string mapping benchmark
+
+ * tcl/read.bench:
+ * tcl/startup.bench:
+ * tk/startup.bench: updated code to reflect proc-oriented tmpfile
+ operations.
diff --git a/tcllib/modules/bench/bench.man b/tcllib/modules/bench/bench.man
new file mode 100644
index 0000000..fdee2cf
--- /dev/null
+++ b/tcllib/modules/bench/bench.man
@@ -0,0 +1,296 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin bench n 0.4]
+[see_also bench_intro]
+[see_also bench_lang_intro]
+[see_also bench_lang_spec]
+[see_also bench_read]
+[see_also bench_wcsv]
+[see_also bench_wtext]
+[keywords benchmark]
+[keywords merging]
+[keywords normalization]
+[keywords performance]
+[keywords testing]
+[copyright {2007-2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Benchmarking/Performance tools}]
+[titledesc {bench - Processing benchmark suites}]
+[category {Benchmark tools}]
+[require Tcl 8.2]
+[require bench [opt 0.4]]
+[description]
+
+This package provides commands for the execution of benchmarks written
+in the bench language, and for the processing of results generated by
+such execution.
+
+[para]
+
+A reader interested in the bench language itself should start with the
+[term {bench language introduction}] and proceed from there to the
+formal [term {bench language specification}].
+
+[para]
+
+[section {PUBLIC API}]
+[subsection {Benchmark execution}]
+
+[list_begin definitions]
+
+[call [cmd ::bench::locate] [arg pattern] [arg paths]]
+
+This command locates Tcl interpreters and returns a list containing
+their paths. It searches them in the list of [arg paths] specified by
+the caller, using the glob [arg pattern].
+
+[para]
+
+The command resolves soft links to find the actual executables
+matching the pattern. Note that only interpreters which are marked as
+executable and are actually executable on the current platform are put
+into the result.
+
+[call [cmd ::bench::run] [opt [arg "option value"]...] [arg interp_list] [arg file]...]
+
+This command executes the benchmarks declared in the set of files,
+once per Tcl interpreter specified via the [arg interp_list], and per
+the configuration specified by the options, and then returns the
+accumulated timing results. The format of this result is described in
+section [sectref {Result format}].
+
+[para]
+
+It is assumed that the contents of the files are written in the bench
+language.
+
+[para]
+
+The available options are
+
+[list_begin options]
+[opt_def -errors [arg flag]]
+
+The argument is a boolean value. If set errors in benchmarks are
+propagated to the command, aborting benchmark execution. Otherwise
+they are recorded in the timing result via a special result code. The
+default is to propagate and abort.
+
+[opt_def -threads [arg n]]
+
+The argument is a non-negative integer value declaring the number of
+threads to use while executing the benchmarks. The default value is
+[const 0], to not use threads.
+
+[opt_def -match [arg pattern]]
+
+The argument is a glob pattern. Only benchmarks whose description
+matches the pattern are executed. The default is the empty string, to
+execute all patterns.
+
+[opt_def -rmatch [arg pattern]]
+
+The argument is a regular expression pattern. Only benchmarks whose
+description matches the pattern are executed. The default is the empty
+string, to execute all patterns.
+
+[opt_def -iters [arg n]]
+
+The argument is positive integer number, the maximal number of
+iterations for any benchmark. The default is [const 1000]. Individual
+benchmarks can override this.
+
+[opt_def -pkgdir [arg path]]
+
+The argument is a path to an existing, readable directory. Multiple
+paths can be specified, simply use the option multiple times, each
+time with one of the paths to use.
+
+[para]
+
+If no paths were specified the system will behave as before.
+If one or more paths are specified, say [var N], each of the specified
+interpreters will be invoked [var N] times, with one of the specified
+paths. The chosen path is put into the interpreters' [var auto_path],
+thus allowing it to find specific versions of a package.
+
+[para]
+
+In this way the use of [option -pkgdir] allows the user to benchmark
+several different versions of a package, against one or more interpreters.
+
+[para]
+
+[emph Note:] The empty string is allowed as a path and causes the system to
+run the specified interpreters with an unmodified [var auto_path]. In case
+the package in question is available there as well.
+
+[list_end]
+[para]
+
+[call [cmd ::bench::versions] [arg interp_list]]
+
+This command takes a list of Tcl interpreters, identified by their
+path, and returns a dictionary mapping from the interpreters to their
+versions. Interpreters which are not actually executable, or fail when
+interrogated, are not put into the result. I.e the result may contain
+less interpreters than there in the input list.
+
+[para]
+
+The command uses builtin command [cmd {info patchlevel}] to determine
+the version of each interpreter.
+
+[list_end]
+
+[subsection {Result manipulation}]
+
+[list_begin definitions]
+
+[call [cmd ::bench::del] [arg bench_result] [arg column]]
+
+This command removes a column, i.e. all benchmark results for a
+specific Tcl interpreter, from the specified benchmark result and
+returns the modified result.
+
+[para]
+The benchmark results are in the format described in section
+[sectref {Result format}].
+[para]
+The column is identified by an integer number.
+
+[call [cmd ::bench::edit] [arg bench_result] [arg column] [arg newvalue]]
+
+This command renames a column in the specified benchmark result and
+returns the modified result. This means that the path of the Tcl
+interpreter in the identified column is changed to an arbitrary
+string.
+
+[para]
+The benchmark results are in the format described in section
+[sectref {Result format}].
+[para]
+The column is identified by an integer number.
+
+[call [cmd ::bench::merge] [arg bench_result]...]
+
+This commands takes one or more benchmark results, merges them into
+one big result, and returns that as its result.
+
+[para]
+All benchmark results are in the format described in section
+[sectref {Result format}].
+
+[call [cmd ::bench::norm] [arg bench_result] [arg column]]
+
+This command normalizes the timing results in the specified benchmark
+result and returns the modified result. This means that the cell
+values are not times anymore, but factors showing how much faster or
+slower the execution was relative to the baseline.
+
+[para]
+
+The baseline against which the command normalizes are the timing
+results in the chosen column. This means that after the normalization
+the values in this column are all [const 1], as these benchmarks are
+neither faster nor slower than the baseline.
+
+[para]
+
+A factor less than [const 1] indicates a benchmark which was faster
+than the baseline, whereas a factor greater than [const 1] indicates a
+slower execution.
+
+[para]
+The benchmark results are in the format described in section
+[sectref {Result format}].
+[para]
+The column is identified by an integer number.
+
+[call [cmd ::bench::out::raw] [arg bench_result]]
+
+This command formats the specified benchmark result for output to a
+file, socket, etc. This specific command does no formatting at all,
+it passes the input through unchanged.
+
+[para]
+
+For other formatting styles see the packages [package bench::out::text]
+and [package bench::out::csv] which provide commands to format
+benchmark results for human consumption, or as CSV data importable by
+spread sheets, respectively.
+
+[para]
+
+Complementary, to read benchmark results from files, sockets etc. look
+for the package [package bench::in] and the commands provided by it.
+
+[list_end]
+
+[subsection {Result format}]
+
+After the execution of a set of benchmarks the raw result returned by
+this package is a Tcl dictionary containing all the relevant
+information.
+
+The dictionary is a compact representation, i.e. serialization, of a
+2-dimensional table which has Tcl interpreters as columns and
+benchmarks as rows. The cells of the table contain the timing
+results.
+
+The Tcl interpreters / columns are identified by their paths.
+The benchmarks / rows are identified by their description.
+
+[para]
+
+The possible keys are all valid Tcl lists of two or three elements and
+have one of the following forms:
+
+[list_begin definitions]
+
+[def {{interp *}}]
+
+The set of keys matching this glob pattern capture the information
+about all the Tcl interpreters used to run the benchmarks. The second
+element of the key is the path to the interpreter.
+
+[para]
+
+The associated value is the version of the Tcl interpreter.
+
+[def {{desc *}}]
+
+The set of keys matching this glob pattern capture the information
+about all the benchmarks found in the executed benchmark suite. The
+second element of the key is the description of the benchmark, which
+has to be unique.
+
+[para]
+
+The associated value is irrelevant, and set to the empty string.
+
+[def {{usec * *}}]
+
+The set of keys matching this glob pattern capture the performance
+information, i.e. timing results. The second element of the key is the
+description of the benchmark, the third element the path of the Tcl
+interpreter which was used to run it.
+
+[para]
+
+The associated value is either one of several special result codes, or
+the time it took to execute the benchmark, in microseconds. The
+possible special result codes are
+
+[list_begin definitions]
+[def ERR]
+Benchmark could not be executed, failed with a Tcl error.
+
+[def BAD_RES]
+The benchmark could be executed, however the result from its body did
+not match the declared expectations.
+
+[list_end]
+[list_end]
+
+[vset CATEGORY bench]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/bench/bench.tcl b/tcllib/modules/bench/bench.tcl
new file mode 100644
index 0000000..461afbc
--- /dev/null
+++ b/tcllib/modules/bench/bench.tcl
@@ -0,0 +1,553 @@
+# bench.tcl --
+#
+# Management of benchmarks.
+#
+# Copyright (c) 2005-2008 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# library derived from runbench.tcl application (C) Jeff Hobbs.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: bench.tcl,v 1.14 2008/10/08 03:30:48 andreas_kupries Exp $
+
+# ### ### ### ######### ######### ######### ###########################
+## Requisites - Packages and namespace for the commands and data.
+
+package require Tcl 8.2
+package require logger
+package require csv
+package require struct::matrix
+package require report
+
+namespace eval ::bench {}
+namespace eval ::bench::out {}
+
+# @mdgen OWNER: libbench.tcl
+
+# ### ### ### ######### ######### ######### ###########################
+## Public API - Benchmark execution
+
+# ::bench::run --
+#
+# Run a series of benchmarks.
+#
+# Arguments:
+# ...
+#
+# Results:
+# Dictionary.
+
+proc ::bench::run {args} {
+ log::debug [linsert $args 0 ::bench::run]
+
+ # -errors 0|1 default 1, propagate errors in benchmarks
+ # -threads <num> default 0, no threads, #threads to use
+ # -match <pattern> only run tests matching this pattern
+ # -rmatch <pattern> only run tests matching this pattern
+ # -iters <num> default 1000, max#iterations for any benchmark
+ # -pkgdir <dir> Defaults to nothing, regular bench invokation.
+
+ # interps - dict (path -> version)
+ # files - list (of files)
+
+ # Process arguments ......................................
+ # Defaults first, then overides by the user
+
+ set errors 1 ; # Propagate errors
+ set threads 0 ; # Do not use threads
+ set match {} ; # Do not exclude benchmarks based on glob pattern
+ set rmatch {} ; # Do not exclude benchmarks based on regex pattern
+ set iters 1000 ; # Limit #iterations for any benchmark
+ set pkgdirs {} ; # List of dirs to put in front of auto_path in the
+ # bench interpreters. Default: nothing.
+
+ while {[string match "-*" [set opt [lindex $args 0]]]} {
+ set val [lindex $args 1]
+ switch -exact -- $opt {
+ -errors {
+ if {![string is boolean -strict $val]} {
+ return -code error "Expected boolean, got \"$val\""
+ }
+ set errors $val
+ }
+ -threads {
+ if {![string is int -strict $val] || ($val < 0)} {
+ return -code error "Expected int >= 0, got \"$val\""
+ }
+ set threads [lindex $args 1]
+ }
+ -match {
+ set match [lindex $args 1]
+ }
+ -rmatch {
+ set rmatch [lindex $args 1]
+ }
+ -iters {
+ if {![string is int -strict $val] || ($val <= 0)} {
+ return -code error "Expected int > 0, got \"$val\""
+ }
+ set iters [lindex $args 1]
+ }
+ -pkgdir {
+ CheckPkgDirArg $val
+ lappend pkgdirs $val
+ }
+ default {
+ return -code error "Unknown option \"$opt\", should -errors, -threads, -match, -rmatch, or -iters"
+ }
+ }
+ set args [lrange $args 2 end]
+ }
+ if {[llength $args] != 2} {
+ return -code error "wrong\#args, should be: ?options? interp files"
+ }
+ foreach {interps files} $args break
+
+ # Run the benchmarks .....................................
+
+ array set DATA {}
+
+ if {![llength $pkgdirs]} {
+ # No user specified package directories => Simple run.
+ foreach {ip ver} $interps {
+ Invoke $ip $ver {} ;# DATA etc passed via upvar.
+ }
+ } else {
+ # User specified package directories.
+ foreach {ip ver} $interps {
+ foreach pkgdir $pkgdirs {
+ Invoke $ip $ver $pkgdir ;# DATA etc passed via upvar.
+ }
+ }
+ }
+
+ # Benchmark data ... Structure, dict (key -> value)
+ #
+ # Key || Value
+ # ============ ++ =========================================
+ # interp IP -> Version. Shell IP was used to run benchmarks. IP is
+ # the path to the shell.
+ #
+ # desc DESC -> "". DESC is description of an executed benchmark.
+ #
+ # usec DESC IP -> Result. Result of benchmark DESC when run by the
+ # shell IP. Usually time in microseconds, but can be
+ # a special code as well (ERR, BAD_RES).
+ # ============ ++ =========================================
+
+ return [array get DATA]
+}
+
+# ::bench::locate --
+#
+# Locate interpreters on the pathlist, based on a pattern.
+#
+# Arguments:
+# ...
+#
+# Results:
+# List of paths.
+
+proc ::bench::locate {pattern paths} {
+ # Cache of executables already found.
+ array set var {}
+ set res {}
+
+ foreach path $paths {
+ foreach ip [glob -nocomplain [file join $path $pattern]] {
+ if {[package vsatisfies [package provide Tcl] 8.4]} {
+ set ip [file normalize $ip]
+ }
+
+ # Follow soft-links to the actual executable.
+ while {[string equal link [file type $ip]]} {
+ set link [file readlink $ip]
+ if {[string match relative [file pathtype $link]]} {
+ set ip [file join [file dirname $ip] $link]
+ } else {
+ set ip $link
+ }
+ }
+
+ if {
+ [file executable $ip] && ![info exists var($ip)]
+ } {
+ if {[catch {exec $ip << "exit"} dummy]} {
+ log::debug "$ip: $dummy"
+ continue
+ }
+ set var($ip) .
+ lappend res $ip
+ }
+ }
+ }
+
+ return $res
+}
+
+# ::bench::versions --
+#
+# Take list of interpreters, find their versions.
+# Removes all interps for which it cannot do so.
+#
+# Arguments:
+# List of interpreters (paths)
+#
+# Results:
+# dictionary: interpreter -> version.
+
+proc ::bench::versions {interps} {
+ set res {}
+ foreach ip $interps {
+ if {[catch {
+ exec $ip << {puts [info patchlevel] ; exit}
+ } patchlevel]} {
+ log::debug "$ip: $patchlevel"
+ continue
+ }
+
+ lappend res [list $patchlevel $ip]
+ }
+
+ # -uniq 8.4-ism, replaced with use of array.
+ array set tmp {}
+ set resx {}
+ foreach item [lsort -dictionary -decreasing -index 0 $res] {
+ foreach {p ip} $item break
+ if {[info exists tmp($p)]} continue
+ set tmp($p) .
+ lappend resx $ip $p
+ }
+
+ return $resx
+}
+
+# ::bench::merge --
+#
+# Take the data of several benchmark runs and merge them into
+# one data set.
+#
+# Arguments:
+# One or more data sets to merge
+#
+# Results:
+# The merged data set.
+
+proc ::bench::merge {args} {
+ if {[llength $args] == 1} {
+ return [lindex $args 0]
+ }
+
+ array set DATA {}
+ foreach data $args {
+ array set DATA $data
+ }
+ return [array get DATA]
+}
+
+# ::bench::norm --
+#
+# Normalize the time data in the dataset, using one of the
+# columns as reference.
+#
+# Arguments:
+# Data to normalize
+# Index of reference column
+#
+# Results:
+# The normalized data set.
+
+proc ::bench::norm {data col} {
+
+ if {![string is integer -strict $col]} {
+ return -code error "Ref.column: Expected integer, but got \"$col\""
+ }
+ if {$col < 1} {
+ return -code error "Ref.column out of bounds"
+ }
+
+ array set DATA $data
+ set ipkeys [array names DATA interp*]
+
+ if {$col > [llength $ipkeys]} {
+ return -code error "Ref.column out of bounds"
+ }
+ incr col -1
+ set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1]
+
+ foreach key [array names DATA] {
+ if {[string match "desc*" $key]} continue
+ if {[string match "interp*" $key]} continue
+
+ foreach {_ desc ip} $key break
+ if {[string equal $ip $refip]} continue
+
+ set v $DATA($key)
+ if {![string is double -strict $v]} continue
+
+ if {![info exists DATA([list usec $desc $refip])]} {
+ # We cannot normalize, we do not keep the time value.
+ # The row will be shown, empty.
+ set DATA($key) ""
+ continue
+ }
+ set vref $DATA([list usec $desc $refip])
+
+ if {![string is double -strict $vref]} continue
+
+ set DATA($key) [expr {$v/double($vref)}]
+ }
+
+ foreach key [array names DATA [list * $refip]] {
+ if {![string is double -strict $DATA($key)]} continue
+ set DATA($key) 1
+ }
+
+ return [array get DATA]
+}
+
+# ::bench::edit --
+#
+# Change the 'path' of an interp to a user-defined value.
+#
+# Arguments:
+# Data to edit
+# Index of column to change
+# The value replacing the current path
+#
+# Results:
+# The changed data set.
+
+proc ::bench::edit {data col new} {
+
+ if {![string is integer -strict $col]} {
+ return -code error "Ref.column: Expected integer, but got \"$col\""
+ }
+ if {$col < 1} {
+ return -code error "Ref.column out of bounds"
+ }
+
+ array set DATA $data
+ set ipkeys [array names DATA interp*]
+
+ if {$col > [llength $ipkeys]} {
+ return -code error "Ref.column out of bounds"
+ }
+ incr col -1
+ set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1]
+
+ if {[string equal $new $refip]} {
+ # No change, quick return
+ return $data
+ }
+
+ set refkey [list interp $refip]
+ set DATA([list interp $new]) $DATA($refkey)
+ unset DATA($refkey)
+
+ foreach key [array names DATA [list * $refip]] {
+ if {![string equal [lindex $key 0] "usec"]} continue
+ foreach {__ desc ip} $key break
+ set DATA([list usec $desc $new]) $DATA($key)
+ unset DATA($key)
+ }
+
+ return [array get DATA]
+}
+
+# ::bench::del --
+#
+# Remove the data for an interp.
+#
+# Arguments:
+# Data to edit
+# Index of column to remove
+#
+# Results:
+# The changed data set.
+
+proc ::bench::del {data col} {
+
+ if {![string is integer -strict $col]} {
+ return -code error "Ref.column: Expected integer, but got \"$col\""
+ }
+ if {$col < 1} {
+ return -code error "Ref.column out of bounds"
+ }
+
+ array set DATA $data
+ set ipkeys [array names DATA interp*]
+
+ if {$col > [llength $ipkeys]} {
+ return -code error "Ref.column out of bounds"
+ }
+ incr col -1
+ set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1]
+
+ unset DATA([list interp $refip])
+
+ # Do not use 'array unset'. Keep 8.2 clean.
+ foreach key [array names DATA [list * $refip]] {
+ if {![string equal [lindex $key 0] "usec"]} continue
+ unset DATA($key)
+ }
+
+ return [array get DATA]
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Public API - Result formatting.
+
+# ::bench::out::raw --
+#
+# Format the result of a benchmark run.
+# Style: Raw data.
+#
+# Arguments:
+# DATA dict
+#
+# Results:
+# String containing the formatted DATA.
+
+proc ::bench::out::raw {data} {
+ return $data
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Internal commands
+
+proc ::bench::CheckPkgDirArg {path {expected {}}} {
+ # Allow empty string, special.
+ if {![string length $path]} return
+
+ if {![file isdirectory $path]} {
+ return -code error \
+ "The path \"$path\" is not a directory."
+ }
+ if {![file readable $path]} {
+ return -code error \
+ "The path \"$path\" is not readable."
+ }
+}
+
+proc ::bench::Invoke {ip ver pkgdir} {
+ variable self
+ # Import remainder of the current configuration/settings.
+
+ upvar 1 DATA DATA match match rmatch rmatch \
+ iters iters errors errors threads threads \
+ files files
+
+ if {[string length $pkgdir]} {
+ log::info "Benchmark $ver ($pkgdir) $ip"
+ set idstr "$ip ($pkgdir)"
+ } else {
+ log::info "Benchmark $ver $ip"
+ set idstr $ip
+ }
+
+ set DATA([list interp $idstr]) $ver
+
+ set cmd [list $ip [file join $self libbench.tcl] \
+ -match $match \
+ -rmatch $rmatch \
+ -iters $iters \
+ -interp $ip \
+ -errors $errors \
+ -threads $threads \
+ -pkgdir $pkgdir \
+ ]
+
+ # Determine elapsed time per file, logged.
+ set start [clock seconds]
+
+ array set tmp {}
+
+ if {$threads} {
+ foreach f $files { lappend cmd $f }
+ if {[catch {
+ close [Process [open |$cmd r+]]
+ } output]} {
+ if {$errors} {
+ error $::errorInfo
+ }
+ }
+ } else {
+ foreach file $files {
+ log::info [file tail $file]
+ if {[catch {
+ close [Process [open |[linsert $cmd end $file] r+]]
+ } output]} {
+ if {$errors} {
+ error $::errorInfo
+ } else {
+ continue
+ }
+ }
+ }
+ }
+
+ foreach desc [array names tmp] {
+ set DATA([list desc $desc]) {}
+ set DATA([list usec $desc $idstr]) $tmp($desc)
+ }
+
+ unset tmp
+ set elapsed [expr {[clock seconds] - $start}]
+
+ set hour [expr {$elapsed / 3600}]
+ set min [expr {$elapsed / 60}]
+ set sec [expr {$elapsed % 60}]
+ log::info " [format %.2d:%.2d:%.2d $hour $min $sec] elapsed"
+ return
+}
+
+
+proc ::bench::Process {pipe} {
+ while {1} {
+ if {[eof $pipe]} break
+ if {[gets $pipe line] < 0} break
+ # AK: FUTURE: Log all lines?!
+ #puts |$line|
+ set line [string trim $line]
+ if {[string equal $line ""]} continue
+
+ Result
+ Feedback
+ # Unknown lines are printed. Future: Callback?!
+ log::info $line
+ }
+ return $pipe
+}
+
+proc ::bench::Result {} {
+ upvar 1 line line
+ if {[lindex $line 0] ne "RESULT"} return
+ upvar 2 tmp tmp
+ foreach {_ desc result} $line break
+ set tmp($desc) $result
+ return -code continue
+}
+
+proc ::bench::Feedback {} {
+ upvar 1 line line
+ if {[lindex $line 0] ne "LOG"} return
+ # AK: Future - Run through callback?!
+ log::info [lindex $line 1]
+ return -code continue
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Initialize internal data structures.
+
+namespace eval ::bench {
+ variable self [file join [pwd] [file dirname [info script]]]
+
+ logger::init bench
+ logger::import -force -all -namespace log bench
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Ready to run
+
+package provide bench 0.4
diff --git a/tcllib/modules/bench/bench_intro.man b/tcllib/modules/bench/bench_intro.man
new file mode 100644
index 0000000..8ab4e03
--- /dev/null
+++ b/tcllib/modules/bench/bench_intro.man
@@ -0,0 +1,91 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin bench_intro n 1.0]
+[see_also bench]
+[see_also bench_lang_faq]
+[see_also bench_lang_intro]
+[see_also bench_lang_spec]
+[keywords {bench language}]
+[keywords benchmark]
+[keywords performance]
+[keywords testing]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Benchmarking/Performance tools}]
+[titledesc {bench introduction}]
+[category {Benchmark tools}]
+[description]
+[para]
+
+The [term bench] (short for [emph {benchmark tools}]), is a set of
+related, yet different, entities which are working together for the
+easy creation and execution of performance test suites, also known as
+benchmarks. These are
+
+[list_begin enumerated]
+[enum]
+
+A tcl based language for the declaration of test cases. A test case is
+represented by a tcl command declaring the various parts needed to
+execute it, like setup, cleanup, the commands to test, etc.
+
+[enum]
+
+A package providing the ability to execute test cases written in that
+language.
+
+[comment {
+[enum]
+In the future we will also provide an application which wraps around the package.
+}]
+[list_end]
+
+[para]
+
+Which of the more detailed documents are relevant to the reader of
+this introduction depends on their role in the benchmarking process.
+
+[para]
+
+[list_begin enumerated]
+[enum]
+
+A [term writer] of benchmarks has to understand the bench language
+itself. A beginner to bench should read the more informally written
+[term {bench language introduction}] first. Having digested this the
+formal [term {bench language specification}] should become
+understandable. A writer experienced with bench may only need this
+last document from time to time, to refresh her memory.
+
+[comment {
+[para]
+
+While a benchmark is written the [syscmd bench] application can be
+used to validate it, and after completion it also performs the
+execution of the whole benchmark suite.
+}]
+
+[enum]
+A [term user] of benchmark suites written in the [term bench] language
+has to know which tools are available for use.
+
+[comment {
+[para]
+
+The main tool is the aforementioned [syscmd bench] application
+provided by Tcllib.
+}]
+
+At the bottom level sits the package [package bench], providing the
+basic facilities to read and execute files containing benchmarks
+written in the bench language, and to manipulate benchmark results.
+
+[list_end]
+
+[section {HISTORICAL NOTES}]
+
+This module and package have been derived from Jeff Hobbs'
+[syscmd tclbench] application for the benchmarking of the Tcl core and
+its ancestor [file runbench.tcl].
+
+[vset CATEGORY bench]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/bench/bench_lang_intro.man b/tcllib/modules/bench/bench_lang_intro.man
new file mode 100644
index 0000000..c795dec
--- /dev/null
+++ b/tcllib/modules/bench/bench_lang_intro.man
@@ -0,0 +1,153 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin bench_lang_intro n 1.0]
+[see_also bench_intro]
+[see_also bench_lang_spec]
+[keywords {bench language}]
+[keywords benchmark]
+[keywords examples]
+[keywords performance]
+[keywords testing]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Benchmarking/Performance tools}]
+[titledesc {bench language introduction}]
+[category {Benchmark tools}]
+[description]
+[para]
+
+This document is an informal introduction to version 1 of the bench
+language based on a multitude of examples. After reading this a
+benchmark writer should be ready to understand the formal
+[term {bench language specification}].
+
+[subsection Fundamentals]
+
+In the broadest terms possible the [term {bench language}] is
+essentially Tcl, plus a number of commands to support the declaration
+of benchmarks.
+
+A document written in this language is a Tcl script and has the same
+syntax.
+
+[para]
+
+[subsection {Basics}]
+
+One of the most simplest benchmarks which can be written in bench is
+
+[example_begin]
+bench -desc LABEL -body {
+ set a b
+}
+[example_end]
+
+This code declares a benchmark named [const LABEL] which measures the
+time it takes to assign a value to a variable. The Tcl code doing this
+assignment is the [option -body] of the benchmark.
+
+[subsection {Pre- and postprocessing}]
+
+Our next example demonstrates how to declare [term initialization] and
+[term cleanup] code, i.e. code computing information for the use of
+the [option -body], and for releasing such resources after the
+measurement is done.
+
+They are the [option -pre]- and the [option -post]-body, respectively.
+
+[para]
+
+In our example, directly drawn from the benchmark suite of Tcllib's
+[package aes] package, the concrete initialization code constructs the
+key schedule used by the encryption command whose speed we measure,
+and the cleanup code releases any resources bound to that schedule.
+
+[example_begin]
+bench -desc "AES-${len} ECB encryption core" [option -pre] {
+ set key [lb]aes::Init ecb $k $i[rb]
+} -body {
+ aes::Encrypt $key $p
+} [option -post] {
+ aes::Final $key
+}
+[example_end]
+
+[subsection {Advanced pre- and postprocessing}]
+
+Our last example again deals with initialization and cleanup code. To
+see the difference to the regular initialization and cleanup discussed
+in the last section it is necessary to know a bit more about how bench
+actually measures the speed of the the [option -body].
+
+[para]
+
+Instead of running the [option -body] just once the system actually
+executes the [option -body] several hundred times and then returns the
+average of the found execution times. This is done to remove
+environmental effects like machine load from the result as much as
+possible, with outliers canceling each other out in the average.
+
+[para]
+
+The drawback of doing things this way is that when we measure
+operations which are not idempotent we will most likely not measure
+the time for the operation we want, but of the state(s) the system is
+in after the first iteration, a mixture of things we have no interest
+in.
+
+[para]
+
+Should we wish, for example, to measure the time it takes to include
+an element into a set, with the element not yet in the set, and the
+set having specific properties like being a shared Tcl_Obj, then the
+first iteration will measure the time for this. [emph However] all
+subsequent iterations will measure the time to include an element
+which is already in the set, and the Tcl_Obj holding the set will not
+be shared anymore either. In the end the timings taken for the several
+hundred iterations of this state will overwhelm the time taken from
+the first iteration, the only one which actually measured what we
+wanted.
+
+[para]
+
+The advanced initialization and cleanup codes, [option -ipre]- and the
+[option -ipost]-body respectively, are present to solve this very
+problem. While the regular initialization and cleanup codes are
+executed before and after the whole series of iterations the advanced
+codes are executed before and after each iteration of the body,
+without being measured themselves. This allows them to bring the
+system into the exact state the body wishes to measure.
+
+[para]
+
+Our example, directly drawn from the benchmark suite of Tcllib's
+[package struct::set] package, is for exactly the example we used
+above to demonstrate the necessity for the advanced initialization and
+cleanup. Its concrete initialization code constructs a variable
+refering to a set with specific properties (The set has a string
+representation, which is shared) affecting the speed of the inclusion
+command, and the cleanup code releases the temporary variables created
+by this initialization.
+
+[example_begin]
+bench -desc "set include, missing <SC> x$times $n" [option -ipre] {
+ set A $sx($times,$n)
+ set B $A
+} -body {
+ struct::set include A x
+} [option -ipost] {
+ unset A B
+}
+[example_end]
+
+[section {FURTHER READING}]
+
+Now that this document has been digested the reader, assumed to be a
+[term writer] of benchmarks, he should be fortified enough to be able
+to understand the formal [term {bench language specfication}]. It will
+also serve as the detailed specification and cheat sheet for all
+available commands and their syntax.
+
+[para]
+
+[vset CATEGORY bench]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/bench/bench_lang_spec.man b/tcllib/modules/bench/bench_lang_spec.man
new file mode 100644
index 0000000..a9b0e14
--- /dev/null
+++ b/tcllib/modules/bench/bench_lang_spec.man
@@ -0,0 +1,132 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin bench_lang_spec n 1.0]
+[see_also bench_intro]
+[see_also bench_lang_intro]
+[keywords {bench language}]
+[keywords benchmark]
+[keywords performance]
+[keywords specification]
+[keywords testing]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {bench language specification}]
+[category {Benchmark tools}]
+[description]
+[para]
+
+This document specifies both names and syntax of all the commands
+which together are the bench language, version 1.
+
+As this document is intended to be a reference the commands are listed
+in alphabetical order, and the descriptions are relatively short.
+
+A beginner should read the more informally written
+[term {bench language introduction}] first.
+
+[section Commands]
+[list_begin definitions]
+
+[call [cmd bench_rm] [arg path]...]
+
+This command silently removes the files specified as its arguments and
+then returns the empty string as its result.
+
+The command is [emph trusted], there is no checking if the specified
+files are outside of whatever restricted area the benchmarks are run
+in.
+
+[call [cmd bench_tmpfile]]
+
+This command returns the path to a bench specific unique temporary
+file. The uniqueness means that multiple calls will return different
+paths. While the path may exist from previous runs, the command itself
+does [emph not] create aynthing.
+
+[para]
+
+The base location of the temporary files is platform dependent:
+
+[list_begin definitions]
+[def {Unix, and indeterminate platform}]
+[file /tmp]
+[def Windows]
+[var \$TEMP]
+[def {Anything else}]
+The current working directory.
+[list_end]
+[para]
+
+[call [cmd bench] [arg options]...]
+
+This command declares a single benchmark. Its result is the empty
+string. All parts of the benchmark are declared via options, and their
+values. The options can occur in any order. The accepted options are:
+
+[list_begin options]
+[opt_def -body script]
+
+The argument of this option declares the body of the benchmark, the
+Tcl script whose performance we wish to measure. This option, and
+[option -desc], are the two required parts of each benchmark.
+
+[opt_def -desc msg]
+
+The argument of this option declares the name of the benchmark. It has
+to be unique, or timing data from different benchmarks will be mixed
+together.
+
+[para]
+
+[emph Beware!] This requirement is not checked when benchmarks are
+executed, and the system will silently produce bogus data. This
+option, and [option -body], are the two required parts of each
+benchmark.
+
+[opt_def -ipost script]
+
+The argument of this option declares a script which is run immediately
+[emph after] each iteration of the body. Its responsibility is to
+release resources created by the body, or [option -ipre]-bodym which
+we do not wish to live into the next iteration.
+
+[opt_def -ipre script]
+
+The argument of this option declares a script which is run immediately
+[emph before] each iteration of the body. Its responsibility is to
+create the state of the system expected by the body so that we measure
+the right thing.
+
+[opt_def -iterations num]
+
+The argument of this option declares the maximum number of times to
+run the [option -body] of the benchmark. During execution this and the
+global maximum number of iterations are compared and the smaller of
+the two values is used.
+
+[para]
+
+This option should be used only for benchmarks which are expected or
+known to take a long time per run. I.e. reduce the number of times
+they are run to keep the overall time for the execution of the whole
+benchmark within manageable limits.
+
+[opt_def -post script]
+
+The argument of this option declares a script which is run
+[emph after] all iterations of the body have been run. Its
+responsibility is to release resources created by the body,
+or [option -pre]-body.
+
+[opt_def -pre script]
+
+The argument of this option declares a script which is run
+[emph before] any of the iterations of the body are run. Its
+responsibility is to create whatever resources are needed by the body
+to run without failing.
+
+[list_end]
+[list_end]
+
+[vset CATEGORY bench]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/bench/bench_read.man b/tcllib/modules/bench/bench_read.man
new file mode 100644
index 0000000..31428ae
--- /dev/null
+++ b/tcllib/modules/bench/bench_read.man
@@ -0,0 +1,65 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin bench::in n 0.1]
+[see_also bench]
+[see_also bench::out::csv]
+[see_also bench::out::text]
+[see_also bench_intro]
+[keywords benchmark]
+[keywords csv]
+[keywords formatting]
+[keywords {human readable}]
+[keywords parsing]
+[keywords performance]
+[keywords reading]
+[keywords testing]
+[keywords text]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Benchmarking/Performance tools}]
+[titledesc {bench::in - Reading benchmark results}]
+[category {Benchmark tools}]
+[require Tcl 8.2]
+[require csv]
+[require bench::in [opt 0.1]]
+[description]
+
+This package provides a command for reading benchmark results from
+files, sockets, etc.
+
+[para]
+
+A reader interested in the creation, processing or writing of such
+results should go and read
+[term {bench - Processing benchmark suites}] instead.
+
+[para]
+
+If the bench language itself is the actual interest please start with
+the [term {bench language introduction}] and then proceed from there
+to the formal [term {bench language specification}].
+
+[para]
+
+[section {PUBLIC API}]
+
+[list_begin definitions]
+
+[call [cmd ::bench::in::read] [arg file]]
+
+This command reads a benchmark result from the specified [arg file]
+and returns it as its result. The command understands the three
+formats created by the commands
+
+[list_begin commands]
+[cmd_def bench::out::raw] Provided by package [package bench].
+[cmd_def bench::out::csv] Provided by package [package bench::out::csv].
+[cmd_def bench::out::text] Provided by package [package bench::out::text].
+[list_end]
+[para]
+
+and automatically detects which format is used by the input file.
+
+[list_end]
+
+[vset CATEGORY bench]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/bench/bench_read.tcl b/tcllib/modules/bench/bench_read.tcl
new file mode 100644
index 0000000..7cebb7b
--- /dev/null
+++ b/tcllib/modules/bench/bench_read.tcl
@@ -0,0 +1,162 @@
+# bench_read.tcl --
+#
+# Management of benchmarks, reading results in various formats.
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# library derived from runbench.tcl application (C) Jeff Hobbs.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: bench_read.tcl,v 1.3 2006/06/13 23:20:30 andreas_kupries Exp $
+
+# ### ### ### ######### ######### ######### ###########################
+## Requisites - Packages and namespace for the commands and data.
+
+package require Tcl 8.2
+package require csv
+
+namespace eval ::bench::in {}
+
+# ### ### ### ######### ######### ######### ###########################
+## Public API - Result reading
+
+# ::bench::in::read --
+#
+# Read a bench result in any of the raw/csv/text formats
+#
+# Arguments:
+# path to file to read
+#
+# Results:
+# DATA dictionary, internal representation of the bench results.
+
+proc ::bench::in::read {file} {
+
+ set f [open $file r]
+ set head [gets $f]
+
+ if {![string match "# -\\*- tcl -\\*- bench/*" $head]} {
+ return -code error "Bad file format, not a benchmark file"
+ } else {
+ regexp {bench/(.*)$} $head -> format
+
+ switch -exact -- $format {
+ raw - csv - text {
+ set res [RD$format $f]
+ }
+ default {
+ return -code error "Bad format \"$val\", expected text, csv, or raw"
+ }
+ }
+ }
+ close $f
+ return $res
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Internal commands
+
+proc ::bench::in::RDraw {chan} {
+ return [string trimright [::read $chan]]
+}
+
+proc ::bench::in::RDcsv {chan} {
+ # Lines Format
+ # First line is number of interpreters #n. int
+ # Next to 1+n is interpreter data. id,ver,path
+ # Beyond is benchmark results. id,desc,res1,...,res#n
+
+ array set DATA {}
+
+ # #Interp ...
+
+ set nip [lindex [csv::split [gets $chan]] 0]
+
+ # Interp data ...
+
+ set iplist {}
+ for {set i 0} {$i < $nip} {incr i} {
+ foreach {__ ver ip} [csv::split [gets $chan]] break
+
+ set DATA([list interp $ip]) $ver
+ lappend iplist $ip
+ }
+
+ # Benchmark data ...
+
+ while {[gets $chan line] >= 0} {
+ set line [string trim $line]
+ if {$line == {}} break
+ set line [csv::split $line]
+ set desc [lindex $line 1]
+
+ set DATA([list desc $desc]) {}
+ foreach val [lrange $line 2 end] ip $iplist {
+ if {$val == {}} continue
+ set DATA([list usec $desc $ip]) $val
+ }
+ }
+
+ return [array get DATA]
+}
+
+proc ::bench::in::RDtext {chan} {
+ array set DATA {}
+
+ # Interp data ...
+
+ # Empty line - ignore
+ # "id: ver path" - interp data.
+ # Empty line - separator before benchmark data.
+
+ set n 0
+ set iplist {}
+ while {[gets $chan line] >= 0} {
+ set line [string trim $line]
+ if {$line == {}} {
+ incr n
+ if {$n == 2} break
+ continue
+ }
+
+ regexp {[^:]+: ([^ ]+) (.*)$} $line -> ver ip
+ set DATA([list interp $ip]) $ver
+ lappend iplist $ip
+ }
+
+ # Benchmark data ...
+
+ # '---' -> Ignore.
+ # '|' column separators. Remove spaces around it. Then treat line
+ # as CSV data with a particular separator.
+ # Ignore the INTERP line.
+
+ while {[gets $chan line] >= 0} {
+ set line [string trim $line]
+ if {$line == {}} continue
+ if {[string match "+---*" $line]} continue
+ if {[string match "*INTERP*" $line]} continue
+
+ regsub -all "\\| +" $line {|} line
+ regsub -all " +\\|" $line {|} line
+ set line [csv::split [string trim $line |] |]
+ set desc [lindex $line 1]
+
+ set DATA([list desc $desc]) {}
+ foreach val [lrange $line 2 end] ip $iplist {
+ if {$val == {}} continue
+ set DATA([list usec $desc $ip]) $val
+ }
+ }
+
+ return [array get DATA]
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Initialize internal data structures.
+
+# ### ### ### ######### ######### ######### ###########################
+## Ready to run
+
+package provide bench::in 0.1
diff --git a/tcllib/modules/bench/bench_wcsv.man b/tcllib/modules/bench/bench_wcsv.man
new file mode 100644
index 0000000..52554a9
--- /dev/null
+++ b/tcllib/modules/bench/bench_wcsv.man
@@ -0,0 +1,54 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin bench::out::csv n 0.1.2]
+[see_also bench]
+[see_also bench::out::text]
+[keywords benchmark]
+[keywords csv]
+[keywords formatting]
+[keywords performance]
+[keywords testing]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Benchmarking/Performance tools}]
+[titledesc {bench::out::csv - Formatting benchmark results as CSV}]
+[category {Benchmark tools}]
+[require Tcl 8.2]
+[require bench::out::csv [opt 0.1.2]]
+[description]
+
+This package provides commands for fomatting of benchmark results into
+a CSV table importable by spread sheets.
+
+[para]
+
+A reader interested in the generation or processing of such results should
+go and read [term {bench - Processing benchmark suites}] instead.
+
+[para]
+
+If the bench language itself is the actual interest please start with
+the [term {bench language introduction}] and then proceed from there
+to the formal [term {bench language specification}].
+
+[para]
+
+[section {PUBLIC API}]
+
+[list_begin definitions]
+
+[call [cmd ::bench::out::csv] [arg bench_result]]
+
+This command formats the specified benchmark result for output to a
+file, socket, etc. This specific command generates CSV data importable
+by spread sheets.
+
+[para]
+
+For other formatting styles see the packages [package bench] and
+[package bench::out::text] which provide commands to format benchmark
+results in raw form, or for human consumption, respectively.
+
+[list_end]
+
+[vset CATEGORY bench]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/bench/bench_wcsv.tcl b/tcllib/modules/bench/bench_wcsv.tcl
new file mode 100644
index 0000000..cb3d4c5
--- /dev/null
+++ b/tcllib/modules/bench/bench_wcsv.tcl
@@ -0,0 +1,101 @@
+# bench_wtext.tcl --
+#
+# Management of benchmarks, formatted text.
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# library derived from runbench.tcl application (C) Jeff Hobbs.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: bench_wcsv.tcl,v 1.4 2007/01/21 23:29:06 andreas_kupries Exp $
+
+# ### ### ### ######### ######### ######### ###########################
+## Requisites - Packages and namespace for the commands and data.
+
+package require Tcl 8.2
+package require csv
+
+namespace eval ::bench::out {}
+
+# ### ### ### ######### ######### ######### ###########################
+## Public API - Benchmark execution
+
+# ### ### ### ######### ######### ######### ###########################
+## Public API - Result formatting.
+
+# ::bench::out::csv --
+#
+# Format the result of a benchmark run.
+# Style: CSV
+#
+# Arguments:
+# DATA dict
+#
+# Results:
+# String containing the formatted DATA.
+
+proc ::bench::out::csv {data} {
+ array set DATA $data
+ set CSV {}
+
+ # 1st record: #shells
+ # 2nd record to #shells+1: Interpreter data (id, version, path)
+ # #shells+2 to end: Benchmark data (id,desc,result1,...,result#shells)
+
+ # --- --- ----
+ # #interpreters used
+
+ set ipkeys [array names DATA interp*]
+ lappend CSV [csv::join [list [llength $ipkeys]]]
+
+ # --- --- ----
+ # Table 1: Interpreter information.
+
+ set n 1
+ set iplist {}
+ foreach key [lsort -dict $ipkeys] {
+ set ip [lindex $key 1]
+ lappend CSV [csv::join [list $n $DATA($key) $ip]]
+ set DATA($key) $n
+ incr n
+ lappend iplist $ip
+ }
+
+ # --- --- ----
+ # Table 2: Benchmark information
+
+ set dlist {}
+ foreach key [lsort -dict -index 1 [array names DATA desc*]] {
+ lappend dlist [lindex $key 1]
+ }
+
+ set n 1
+ foreach desc $dlist {
+ set record {}
+ lappend record $n
+ lappend record $desc
+ foreach ip $iplist {
+ if {[catch {
+ lappend record $DATA([list usec $desc $ip])
+ }]} {
+ lappend record {}
+ }
+ }
+ lappend CSV [csv::join $record]
+ incr n
+ }
+
+ return [join $CSV \n]
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Internal commands
+
+# ### ### ### ######### ######### ######### ###########################
+## Initialize internal data structures.
+
+# ### ### ### ######### ######### ######### ###########################
+## Ready to run
+
+package provide bench::out::csv 0.1.2
diff --git a/tcllib/modules/bench/bench_wtext.man b/tcllib/modules/bench/bench_wtext.man
new file mode 100644
index 0000000..b374b51
--- /dev/null
+++ b/tcllib/modules/bench/bench_wtext.man
@@ -0,0 +1,55 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin bench::out::text n 0.1.2]
+[see_also bench]
+[see_also bench::out::csv]
+[keywords benchmark]
+[keywords formatting]
+[keywords {human readable}]
+[keywords performance]
+[keywords testing]
+[keywords text]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Benchmarking/Performance tools}]
+[titledesc {bench::out::text - Formatting benchmark results as human readable text}]
+[category {Benchmark tools}]
+[require Tcl 8.2]
+[require bench::out::text [opt 0.1.2]]
+[description]
+
+This package provides commands for fomatting of benchmark results into
+human readable text.
+
+[para]
+
+A reader interested in the generation or processing of such results should
+go and read [term {bench - Processing benchmark suites}] instead.
+
+[para]
+
+If the bench language itself is the actual interest please start with
+the [term {bench language introduction}] and then proceed from there
+to the formal [term {bench language specification}].
+
+[para]
+
+[section {PUBLIC API}]
+
+[list_begin definitions]
+
+[call [cmd ::bench::out::text] [arg bench_result]]
+
+This command formats the specified benchmark result for output to a
+file, socket, etc. This specific command generates human readable
+text.
+
+[para]
+
+For other formatting styles see the packages [package bench] and
+[package bench::out::csv] which provide commands to format benchmark
+results in raw form, or as importable CSV data, respectively.
+
+[list_end]
+
+[vset CATEGORY bench]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/bench/bench_wtext.tcl b/tcllib/modules/bench/bench_wtext.tcl
new file mode 100644
index 0000000..aaa4100
--- /dev/null
+++ b/tcllib/modules/bench/bench_wtext.tcl
@@ -0,0 +1,165 @@
+# bench_wtext.tcl --
+#
+# Management of benchmarks, formatted text.
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# library derived from runbench.tcl application (C) Jeff Hobbs.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: bench_wtext.tcl,v 1.4 2007/01/21 23:29:06 andreas_kupries Exp $
+
+# ### ### ### ######### ######### ######### ###########################
+## Requisites - Packages and namespace for the commands and data.
+
+package require Tcl 8.2
+package require struct::matrix
+package require report
+
+namespace eval ::bench::out {}
+
+# ### ### ### ######### ######### ######### ###########################
+## Public API - Result formatting.
+
+# ::bench::out::text --
+#
+# Format the result of a benchmark run.
+# Style: TEXT
+#
+# General structure like CSV, but nicely formatted and aligned
+# columns.
+#
+# Arguments:
+# DATA dict
+#
+# Results:
+# String containing the formatted DATA.
+
+proc ::bench::out::text {data} {
+ array set DATA $data
+ set LINES {}
+
+ # 1st line to #shells: Interpreter data (id, version, path)
+ # #shells+1 to end: Benchmark data (id,desc,result1,...,result#shells)
+
+ lappend LINES {}
+
+ # --- --- ----
+ # Table 1: Interpreter information.
+
+ set ipkeys [array names DATA interp*]
+ set n 1
+ set iplist {}
+ set vlen 0
+ foreach key [lsort -dict $ipkeys] {
+ lappend iplist [lindex $key 1]
+ incr n
+ set l [string length $DATA($key)]
+ if {$l > $vlen} {set vlen $l}
+ }
+ set idlen [string length $n]
+
+ set dlist {}
+ set n 1
+ foreach key [lsort -dict -index 1 [array names DATA desc*]] {
+ lappend dlist [lindex $key 1]
+ incr n
+ }
+ set didlen [string length $n]
+
+ set n 1
+ set record [list "" INTERP]
+ foreach ip $iplist {
+ set v $DATA([list interp $ip])
+ lappend LINES " [PADL $idlen $n]: [PADR $vlen $v] $ip"
+ lappend record $n
+ incr n
+ }
+
+ lappend LINES {}
+
+ # --- --- ----
+ # Table 2: Benchmark information
+
+ set m [struct::matrix m]
+ $m add columns [expr {2 + [llength $iplist]}]
+ $m add row $record
+
+ set n 1
+ foreach desc $dlist {
+ set record [list $n]
+ lappend record $desc
+
+ foreach ip $iplist {
+ if {[catch {
+ set val $DATA([list usec $desc $ip])
+ }]} {
+ set val {}
+ }
+ if {[string is double -strict $val]} {
+ lappend record [format %.2f $val]
+ } else {
+ lappend record [format %s $val]
+ }
+ }
+ $m add row $record
+ incr n
+ }
+
+ ::report::defstyle simpletable {} {
+ data set [split "[string repeat "| " [columns]]|"]
+ top set [split "[string repeat "+ - " [columns]]+"]
+ bottom set [top get]
+ top enable
+ bottom enable
+
+ set c [columns]
+ justify 0 right
+ pad 0 both
+
+ if {$c > 1} {
+ justify 1 left
+ pad 1 both
+ }
+ for {set i 2} {$i < $c} {incr i} {
+ justify $i right
+ pad $i both
+ }
+ }
+ ::report::defstyle captionedtable {{n 1}} {
+ simpletable
+ topdata set [data get]
+ topcapsep set [top get]
+ topcapsep enable
+ tcaption $n
+ }
+
+ set r [report::report r [$m columns] style captionedtable]
+ lappend LINES [$m format 2string $r]
+ $m destroy
+ $r destroy
+
+ return [join $LINES \n]
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Internal commands
+
+proc ::bench::out::PADL {max str} {
+ format "%${max}s" $str
+ #return "[PAD $max $str]$str"
+}
+
+proc ::bench::out::PADR {max str} {
+ format "%-${max}s" $str
+ #return "$str[PAD $max $str]"
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Initialize internal data structures.
+
+# ### ### ### ######### ######### ######### ###########################
+## Ready to run
+
+package provide bench::out::text 0.1.2
diff --git a/tcllib/modules/bench/libbench.tcl b/tcllib/modules/bench/libbench.tcl
new file mode 100644
index 0000000..ebf9f71
--- /dev/null
+++ b/tcllib/modules/bench/libbench.tcl
@@ -0,0 +1,561 @@
+# -*- tcl -*-
+# libbench.tcl ?(<option> <value>)...? <benchFile>...
+#
+# This file has to have code that works in any version of Tcl that
+# the user would want to benchmark.
+#
+# RCS: @(#) $Id: libbench.tcl,v 1.4 2008/07/02 23:34:06 andreas_kupries Exp $
+#
+# Copyright (c) 2000-2001 Jeffrey Hobbs.
+# Copyright (c) 2007 Andreas Kupries
+#
+
+# This code provides the supporting commands for the execution of a
+# benchmark files. It is actually an application and is exec'd by the
+# management code.
+
+# Options:
+# -help Print usage message.
+# -rmatch <regexp-pattern> Run only tests whose description matches the pattern.
+# -match <glob-pattern> Run only tests whose description matches the pattern.
+# -interp <name> Name of the interp running the benchmarks.
+# -thread <num> Invoke threaded benchmarks, number of threads to use.
+# -errors <boolean> Throw errors, or not.
+
+# Note: If both -match and -rmatch are specified then _both_
+# apply. I.e. a benchmark will be run if and only if it matches both
+# patterns.
+
+# Application activity and results are communicated to the highlevel
+# management via text written to stdout. Each line written is a list
+# and has one of the following forms:
+#
+# __THREADED <version> - Indicates threaded mode, and version
+# of package Thread in use.
+#
+# Sourcing {<desc>: <res>} - Benchmark <desc> has started.
+# <res> is the result from executing
+# it once (compilation of body.)
+#
+# Sourcing <file> - Benchmark file <file> starts execution.
+#
+# <desc> <res> - Result of a benchmark.
+#
+# The above implies that no benchmark may use the strings 'Sourcing'
+# or '__THREADED' as their description.
+
+# We will put our data into these named globals.
+
+global BENCH bench
+
+# 'BENCH' contents:
+#
+# - ERRORS : Boolean flag. If set benchmark output mismatches are
+# reported by throwing an error. Otherwise they are simply
+# listed as BAD_RES. Default true. Can be set/reset via
+# option -errors.
+#
+# - MATCH : Match pattern, see -match, default empty, aka everything
+# matches.
+#
+# - RMATCH : Match pattern, see -rmatch, default empty, aka
+# everything matches.
+#
+# - OUTFILE : Name of output file, default is special value "stdout".
+# - OUTFID : Channel for output.
+#
+# The outfile cannot be set by the caller, thus output is always
+# written to stdout.
+#
+# - FILES : List of benchmark files to run.
+#
+# - ITERS : Number of iterations to run a benchmark body, default
+# 1000. Can be overridden by the individual benchmarks.
+#
+# - THREADS : Number of threads to use. 0 signals no threading.
+# Limited to number of files if there are less files than
+# requested threads.
+#
+# - EXIT : Boolean flag. True when appplication is run by wish, for
+# special exit processing. ... Actually always true.
+#
+# - INTERP : Name of the interpreter running the benchmarks. Is the
+# executable running this code. Can be overridden via the
+# command line option -interp.
+#
+# - uniqid : Counter for 'bench_tmpfile' to generate unique names of
+# tmp files.
+#
+# - us : Thread id of main thread.
+#
+# - inuse : Number of threads active, present and relevant only in
+# threaded mode.
+#
+# - file : Currently executed benchmark file. Relevant only in
+# non-threaded mode.
+
+#
+# 'bench' contents.
+
+# Benchmark results, mapping from the benchmark descriptions to their
+# results. Usually time in microseconds, but the following special
+# values can occur:
+#
+# - BAD_RES - Result from benchmark body does not match expectations.
+# - ERR - Benchmark body aborted with an error.
+# - Any string - Forced by error code 666 to pass to management.
+
+#
+# We claim all procedures starting with bench*
+#
+
+# bench_tmpfile --
+#
+# Return a temp file name that can be modified at will
+#
+# Arguments:
+# None
+#
+# Results:
+# Returns file name
+#
+proc bench_tmpfile {} {
+ global tcl_platform env BENCH
+ if {![info exists BENCH(uniqid)]} { set BENCH(uniqid) 0 }
+ set base "tclbench[incr BENCH(uniqid)].dat"
+ if {[info exists tcl_platform(platform)]} {
+ if {$tcl_platform(platform) == "unix"} {
+ return "/tmp/$base"
+ } elseif {$tcl_platform(platform) == "windows"} {
+ return [file join $env(TEMP) $base]
+ } else {
+ return $base
+ }
+ } else {
+ # The Good Ol' Days (?) when only Unix support existed
+ return "/tmp/$base"
+ }
+}
+
+# bench_rm --
+#
+# Remove a file silently (no complaining)
+#
+# Arguments:
+# args Files to delete
+#
+# Results:
+# Returns nothing
+#
+proc bench_rm {args} {
+ foreach file $args {
+ if {[info tclversion] > 7.4} {
+ catch {file delete $file}
+ } else {
+ catch {exec /bin/rm $file}
+ }
+ }
+}
+
+proc bench_puts {args} {
+ eval [linsert $args 0 FEEDBACK]
+ return
+}
+
+# bench --
+#
+# Main bench procedure.
+# The bench test is expected to exit cleanly. If an error occurs,
+# it will be thrown all the way up. A bench proc may return the
+# special code 666, which says take the string as the bench value.
+# This is usually used for N/A feature situations.
+#
+# Arguments:
+#
+# -pre script to run before main timed body
+# -body script to run as main timed body
+# -post script to run after main timed body
+# -ipre script to run before timed body, per iteration of the body.
+# -ipost script to run after timed body, per iteration of the body.
+# -desc message text
+# -iterations <#>
+#
+# Note:
+#
+# Using -ipre and/or -ipost will cause us to compute the average
+# time ourselves, i.e. 'time body 1' n times. Required to ensure
+# that prefix/post operation are executed, yet not timed themselves.
+#
+# Results:
+#
+# Returns nothing
+#
+# Side effects:
+#
+# Sets up data in bench global array
+#
+proc bench {args} {
+ global BENCH bench errorInfo errorCode
+
+ # -pre script
+ # -body script
+ # -desc msg
+ # -post script
+ # -ipre script
+ # -ipost script
+ # -iterations <#>
+ array set opts {
+ -pre {}
+ -body {}
+ -desc {}
+ -post {}
+ -ipre {}
+ -ipost {}
+ }
+ set opts(-iter) $BENCH(ITERS)
+ while {[llength $args]} {
+ set key [lindex $args 0]
+ switch -glob -- $key {
+ -res* { set opts(-res) [lindex $args 1] }
+ -pr* { set opts(-pre) [lindex $args 1] }
+ -po* { set opts(-post) [lindex $args 1] }
+ -ipr* { set opts(-ipre) [lindex $args 1] }
+ -ipo* { set opts(-ipost) [lindex $args 1] }
+ -bo* { set opts(-body) [lindex $args 1] }
+ -de* { set opts(-desc) [lindex $args 1] }
+ -it* {
+ # Only change the iterations when it is smaller than
+ # the requested default
+ set val [lindex $args 1]
+ if {$opts(-iter) > $val} { set opts(-iter) $val }
+ }
+ default {
+ error "unknown option $key"
+ }
+ }
+ set args [lreplace $args 0 1]
+ }
+
+ FEEDBACK "Running <$opts(-desc)>"
+
+ if {($BENCH(MATCH) != "") && ![string match $BENCH(MATCH) $opts(-desc)]} {
+ return
+ }
+ if {($BENCH(RMATCH) != "") && ![regexp $BENCH(RMATCH) $opts(-desc)]} {
+ return
+ }
+ if {$opts(-pre) != ""} {
+ uplevel \#0 $opts(-pre)
+ }
+ if {$opts(-body) != ""} {
+ # always run it once to remove compile phase confusion
+ if {$opts(-ipre) != ""} {
+ uplevel \#0 $opts(-ipre)
+ }
+ set code [catch {uplevel \#0 $opts(-body)} res]
+ if {$opts(-ipost) != ""} {
+ uplevel \#0 $opts(-ipost)
+ }
+ if {!$code && [info exists opts(-res)] \
+ && [string compare $opts(-res) $res]} {
+ if {$BENCH(ERRORS)} {
+ return -code error "Result was:\n$res\nResult\
+ should have been:\n$opts(-res)"
+ } else {
+ set res "BAD_RES"
+ }
+ #set bench($opts(-desc)) $res
+ RESULT $opts(-desc) $res
+ } else {
+ if {($opts(-ipre) != "") || ($opts(-ipost) != "")} {
+ # We do the averaging on our own, to allow untimed
+ # pre/post execution per iteration. We catch and
+ # handle problems in the pre/post code as if
+ # everything was executed as one block (like it would
+ # be in the other path). We are using floating point
+ # to avoid integer overflow, easily happening when
+ # accumulating a high number (iterations) of large
+ # integers (microseconds).
+
+ set total 0.0
+ for {set i 0} {$i < $opts(-iter)} {incr i} {
+ set code 0
+ if {$opts(-ipre) != ""} {
+ set code [catch {uplevel \#0 $opts(-ipre)} res]
+ if {$code} break
+ }
+ set code [catch {uplevel \#0 [list time $opts(-body) 1]} res]
+ if {$code} break
+ set total [expr {$total + [lindex $res 0]}]
+ if {$opts(-ipost) != ""} {
+ set code [catch {uplevel \#0 $opts(-ipost)} res]
+ if {$code} break
+ }
+ }
+ if {!$code} {
+ set res [list [expr {int ($total/$opts(-iter))}] microseconds per iteration]
+ }
+ } else {
+ set code [catch {uplevel \#0 \
+ [list time $opts(-body) $opts(-iter)]} res]
+ }
+ if {!$BENCH(THREADS)} {
+ if {$code == 0} {
+ # Get just the microseconds value from the time result
+ set res [lindex $res 0]
+ } elseif {$code != 666} {
+ # A 666 result code means pass it through to the bench
+ # suite. Otherwise throw errors all the way out, unless
+ # we specified not to throw errors (option -errors 0 to
+ # libbench).
+ if {$BENCH(ERRORS)} {
+ return -code $code -errorinfo $errorInfo \
+ -errorcode $errorCode
+ } else {
+ set res "ERR"
+ }
+ }
+ #set bench($opts(-desc)) $res
+ RESULT $opts(-desc) $res
+ } else {
+ # Threaded runs report back asynchronously
+ thread::send $BENCH(us) \
+ [list thread_report $opts(-desc) $code $res]
+ }
+ }
+ }
+ if {($opts(-post) != "") && [catch {uplevel \#0 $opts(-post)} err] \
+ && $BENCH(ERRORS)} {
+ return -code error "post code threw error:\n$err"
+ }
+ return
+}
+
+proc RESULT {desc time} {
+ global BENCH
+ puts $BENCH(OUTFID) [list RESULT $desc $time]
+ return
+}
+
+proc FEEDBACK {text} {
+ global BENCH
+ puts $BENCH(OUTFID) [list LOG $text]
+ return
+}
+
+
+proc usage {} {
+ set me [file tail [info script]]
+ puts stderr "Usage: $me ?options?\
+ \n\t-help # print out this message\
+ \n\t-rmatch <regexp> # only run tests matching this pattern\
+ \n\t-match <glob> # only run tests matching this pattern\
+ \n\t-interp <name> # name of interp (tries to get it right)\
+ \n\t-thread <num> # number of threads to use\
+ \n\tfileList # files to benchmark"
+ exit 1
+}
+
+#
+# Process args
+#
+if {[catch {set BENCH(INTERP) [info nameofexec]}]} {
+ set BENCH(INTERP) $argv0
+}
+foreach {var val} {
+ ERRORS 1
+ MATCH {}
+ RMATCH {}
+ OUTFILE stdout
+ FILES {}
+ ITERS 1000
+ THREADS 0
+ PKGDIR {}
+ EXIT "[info exists tk_version]"
+} {
+ if {![info exists BENCH($var)]} {
+ set BENCH($var) [subst $val]
+ }
+}
+set BENCH(EXIT) 1
+
+if {[llength $argv]} {
+ while {[llength $argv]} {
+ set key [lindex $argv 0]
+ switch -glob -- $key {
+ -help* { usage }
+ -err* { set BENCH(ERRORS) [lindex $argv 1] }
+ -int* { set BENCH(INTERP) [lindex $argv 1] }
+ -rmat* { set BENCH(RMATCH) [lindex $argv 1] }
+ -mat* { set BENCH(MATCH) [lindex $argv 1] }
+ -iter* { set BENCH(ITERS) [lindex $argv 1] }
+ -thr* { set BENCH(THREADS) [lindex $argv 1] }
+ -pkg* { set BENCH(PKGDIR) [lindex $argv 1] }
+ default {
+ foreach arg $argv {
+ if {![file exists $arg]} { usage }
+ lappend BENCH(FILES) $arg
+ }
+ break
+ }
+ }
+ set argv [lreplace $argv 0 1]
+ }
+}
+
+if {[string length $BENCH(PKGDIR)]} {
+ set auto_path [linsert $auto_path 0 $BENCH(PKGDIR)]
+}
+
+if {$BENCH(THREADS)} {
+ # We have to be able to load threads if we want to use threads, and
+ # we don't want to create more threads than we have files.
+ if {[catch {package require Thread}]} {
+ set BENCH(THREADS) 0
+ } elseif {[llength $BENCH(FILES)] < $BENCH(THREADS)} {
+ set BENCH(THREADS) [llength $BENCH(FILES)]
+ }
+}
+
+rename exit exit.true
+proc exit args {
+ error "called \"exit $args\" in benchmark test"
+}
+
+if {[string compare $BENCH(OUTFILE) stdout]} {
+ set BENCH(OUTFID) [open $BENCH(OUTFILE) w]
+} else {
+ set BENCH(OUTFID) stdout
+}
+
+#
+# Everything that gets output must be in pairwise format, because
+# the data will be collected in via an 'array set'.
+#
+
+if {$BENCH(THREADS)} {
+ # Each file must run in it's own thread because of all the extra
+ # header stuff they have.
+ #set DEBUG 1
+ proc thread_one {{id 0}} {
+ global BENCH
+ set file [lindex $BENCH(FILES) 0]
+ set BENCH(FILES) [lrange $BENCH(FILES) 1 end]
+ if {[file exists $file]} {
+ incr BENCH(inuse)
+ FEEDBACK [list Sourcing $file]
+ if {$id} {
+ set them $id
+ } else {
+ set them [thread::create]
+ thread::send -async $them { load {} Thread }
+ thread::send -async $them \
+ [list array set BENCH [array get BENCH]]
+ thread::send -async $them \
+ [list proc bench_tmpfile {} [info body bench_tmpfile]]
+ thread::send -async $them \
+ [list proc bench_rm {args} [info body bench_rm]]
+ thread::send -async $them \
+ [list proc bench {args} [info body bench]]
+ }
+ if {[info exists ::DEBUG]} {
+ FEEDBACK "SEND [clock seconds] thread $them $file INUSE\
+ $BENCH(inuse) of $BENCH(THREADS)"
+ }
+ thread::send -async $them [list source $file]
+ thread::send -async $them \
+ [list thread::send $BENCH(us) [list thread_ready $them]]
+ #thread::send -async $them { thread::unwind }
+ }
+ }
+
+ proc thread_em {} {
+ global BENCH
+ while {[llength $BENCH(FILES)]} {
+ if {[info exists ::DEBUG]} {
+ FEEDBACK "THREAD ONE [lindex $BENCH(FILES) 0]"
+ }
+ thread_one
+ if {$BENCH(inuse) >= $BENCH(THREADS)} {
+ break
+ }
+ }
+ }
+
+ proc thread_ready {id} {
+ global BENCH
+
+ incr BENCH(inuse) -1
+ if {[llength $BENCH(FILES)]} {
+ if {[info exists ::DEBUG]} {
+ FEEDBACK "SEND ONE [clock seconds] thread $id"
+ }
+ thread_one $id
+ } else {
+ if {[info exists ::DEBUG]} {
+ FEEDBACK "UNWIND thread $id"
+ }
+ thread::send -async $id { thread::unwind }
+ }
+ }
+
+ proc thread_report {desc code res} {
+ global BENCH bench errorInfo errorCode
+
+ if {$code == 0} {
+ # Get just the microseconds value from the time result
+ set res [lindex $res 0]
+ } elseif {$code != 666} {
+ # A 666 result code means pass it through to the bench suite.
+ # Otherwise throw errors all the way out, unless we specified
+ # not to throw errors (option -errors 0 to libbench).
+ if {$BENCH(ERRORS)} {
+ return -code $code -errorinfo $errorInfo \
+ -errorcode $errorCode
+ } else {
+ set res "ERR"
+ }
+ }
+ #set bench($desc) $res
+ RESULT $desc $res
+ }
+
+ proc thread_finish {{delay 4000}} {
+ global BENCH bench
+ set val [expr {[llength [thread::names]] > 1}]
+ #set val [expr {$BENCH(inuse)}]
+ if {$val} {
+ after $delay [info level 0]
+ } else {
+ if {0} {foreach desc [array names bench] {
+ RESULT $desc $bench($desc)
+ }}
+ if {$BENCH(EXIT)} {
+ exit.true ; # needed for Tk tests
+ }
+ }
+ }
+
+ set BENCH(us) [thread::id]
+ set BENCH(inuse) 0 ; # num threads in use
+ FEEDBACK [list __THREADED [package provide Thread]]
+
+ thread_em
+ thread_finish
+ vwait forever
+} else {
+ foreach BENCH(file) $BENCH(FILES) {
+ if {[file exists $BENCH(file)]} {
+ FEEDBACK [list Sourcing $BENCH(file)]
+ source $BENCH(file)
+ }
+ }
+
+ if {0} {foreach desc [array names bench] {
+ RESULT $desc $bench($desc)
+ }}
+
+ if {$BENCH(EXIT)} {
+ exit.true ; # needed for Tk tests
+ }
+}
diff --git a/tcllib/modules/bench/pkgIndex.tcl b/tcllib/modules/bench/pkgIndex.tcl
new file mode 100644
index 0000000..e9b25f9
--- /dev/null
+++ b/tcllib/modules/bench/pkgIndex.tcl
@@ -0,0 +1,7 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+package ifneeded bench 0.4 [list source [file join $dir bench.tcl]]
+package ifneeded bench::out::text 0.1.2 [list source [file join $dir bench_wtext.tcl]]
+package ifneeded bench::out::csv 0.1.2 [list source [file join $dir bench_wcsv.tcl]]
+package ifneeded bench::in 0.1 [list source [file join $dir bench_read.tcl]]
diff --git a/tcllib/modules/bibtex/ChangeLog b/tcllib/modules/bibtex/ChangeLog
new file mode 100644
index 0000000..93764d2
--- /dev/null
+++ b/tcllib/modules/bibtex/ChangeLog
@@ -0,0 +1,98 @@
+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-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 ========================
+ *
+
+2008-06-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bibtex.pcx: New file. Syntax definitions for the public commands
+ of the bibtex package.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-03-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bibtex.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-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bibtex.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bibtex.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-04-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * example.tcl: Moved out of the module into a new directory
+ 'bibtex/' under the examples tree.
+
+2005-03-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bibtex.test: Updated testsuite to handle the more rigorous
+ * bibtex.man: option processing, fixed some buglets. Added
+ * bibtex.tcl: a new API command and extended the documentation as
+ well. Bumped to version 0.5
+
+2005-03-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bibtex.tcl: Revamped the option processing of 'parse', rewrote
+ processing to follow the documentation, and implemented true
+ background processing. ... Currently breaks the testsuite.
+
+2005-03-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bibtex.man: Added documentation.
+
+2005-03-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bibtex.tcl: New module. Parser for BibTeX bibliography
+ * pkgIndex.tcl: files, by Neil Madden.
diff --git a/tcllib/modules/bibtex/bibtex.man b/tcllib/modules/bibtex/bibtex.man
new file mode 100644
index 0000000..c82b9b0
--- /dev/null
+++ b/tcllib/modules/bibtex/bibtex.man
@@ -0,0 +1,180 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset VERSION 0.6]
+[manpage_begin bibtex n [vset VERSION]]
+[keywords bibliography]
+[keywords bibtex]
+[keywords parsing]
+[keywords {text processing}]
+[copyright {2005 for documentation, Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {bibtex}]
+[titledesc {Parse bibtex files}]
+[category {Text processing}]
+[require Tcl 8.4]
+[require bibtex [opt [vset VERSION]]]
+[description]
+[para]
+
+This package provides commands for the parsing of bibliographies in
+BibTeX format.
+
+[list_begin definitions]
+
+[call [cmd ::bibtex::parse] [opt [arg options]] [opt [arg text]]]
+
+This is the general form of the command for parsing a
+bibliography. Depending on the options used to invoke it it will
+either return a token for the parser, or the parsed entries of the
+input bibliography. Instead of performing an immediate parse returning
+a predefined format the command can also enter an event-based parsing
+style where all relevant entries in the input are reported through
+callback commands, in the style of SAX.
+
+[call [cmd ::bibtex::parse] [arg text]]
+
+In this form the command will assume that the specified [arg text] is
+a bibliography in BibTeX format, parse it, and then return a list
+containing one element per record found in the bibliography. Note that
+comments, string definitions, preambles, etc. will not show up in the
+result. Each element will be a list containing record type,
+bibliography key and record data, in this order. The record data will
+be a dictionary, its keys the keys of the record, with the associated
+values.
+
+[call [cmd ::bibtex::parse] \
+ [opt "[option -command] [arg cmd]"] \
+ [option -channel] [arg chan]]
+
+In this form the command will reads the bibliography from the
+specified Tcl channel [arg chan] and then returns the same data
+structure as described above.
+
+[para]
+
+If however the option [option -command] is specified the result will be a
+handle for the parser instead and all processing will be incremental
+and happen in the background. When the input has been exhausted the
+callback [arg cmd] will be invoked with the result of the parse. The
+exact definition for the callback is
+
+[para]
+
+[list_begin definitions]
+[def "[cmd cmd] [arg token] [arg parseresult]"]
+
+The parse result will have the structure explained above, for the
+simpler forms of the parser.
+
+[list_end]
+[para]
+
+[emph Note] that the parser will [emph not] close the channel after it
+has exhausted it. This is still the responsibility of the user of the
+parser.
+
+[call [cmd ::bibtex::parse] \
+ [opt "[option -recordcommand] [arg recordcmd]"] \
+ [opt "[option -preamblecommand] [arg preamblecmd]"] \
+ [opt "[option -stringcommand] [arg stringcmd]"] \
+ [opt "[option -commentcommand] [arg commentcmd]"] \
+ [opt "[option -progresscommand] [arg progresscmd]"] \
+ [opt "[option -casesensitivestrings] [arg bool]"] \
+ "([arg text] | [option -channel] [arg chan])"]
+
+This is the most low-level form for the parser. The returned result
+will be a handle for the parser. During processing it will invoke the
+invoke the specified callback commands for each type of data found in
+the bibliography.
+
+[para]
+
+The processing will be incremental and happen in the background if,
+and only if a Tcl channel [arg chan] is specified. For a [arg text]
+the processing will happen immediately and all callbacks will be
+invoked before the command itself returns.
+
+[para]
+
+The callbacks, i.e. [arg *cmd], are all command prefixes and will be
+invoked with additional arguments appended to them. The meaning of the
+arguments depends on the callback and is explained below. The first
+argument will however always be the handle of the parser invoking the
+callback.
+
+[list_begin definitions]
+
+[def "[option -casesensitivestrings]"]
+
+This option takes a boolean value. When set string macro processing
+becomes case-sensitive. The default is case-insensitive string macro
+processing.
+
+[def "[cmd recordcmd] [arg token] [arg type] [arg key] [arg recorddict]"]
+
+This callback is invoked whenever the parser detects a bibliography
+record in the input. Its arguments are the record type, the
+bibliography key for the record, and a dictionary containing the keys
+and values describing the record. Any string macros known to the
+parser have already been expanded.
+
+[def "[cmd preamblecmd] [arg token] [arg preambletext]"]
+
+This callback is invoked whenever the parser detects an @preamble
+block in the input. The only additional argument is the text found in
+the preamble block. By default such entries are ignored.
+
+[def "[cmd stringcmd] [arg token] [arg stringdict]"]
+
+This callback is invoked whenever the parser detects an @string-based
+macro definition in the input. The argument is a dictionary with the
+macro names as keys and their replacement strings as values. By
+default such definitions are added to the parser state for use in
+future bibliography records.
+
+[def "[cmd commentcmd] [arg token] [arg commenttext]"]
+
+This callback is invoked whenever the parser detects a comment in the
+input. The only additional argument is the comment text. By default
+such entries are ignored.
+
+[def "[cmd progresscmd] [arg token] [arg percent]"]
+
+This callback is invoked during processing to tell the user about the
+progress which has been made. Its argument is the percentage of data
+processed, as integer number between [const 0] and [const 100].
+
+In the case of incremental processing the perecentage will always be
+[const -1] as the total number of entries is not known beforehand.
+
+[list_end]
+[para]
+
+[call [cmd ::bibtex::wait] [arg token]]
+
+This command waits for the parser represented by the [arg token] to
+complete and then returns. The returned result is the empty string.
+
+[call [cmd ::bibtex::destroy] [arg token]]
+
+This command cleans up all internal state associated with the parser
+represented by the handle [arg token], effectively destroying it. This
+command can be called from within the parser callbacks to terminate
+processing.
+
+[call [cmd ::bibtex::addStrings] [arg token] [arg stringdict]]
+
+This command adds the macro definitions stored in the
+dictionary [arg stringdict] to the parser represented
+by the handle [arg token].
+
+[para]
+
+The dictionary keys are the macro names and the values their
+replacement strings. This command has the correct signature for use as
+a [option -stringcommand] callback in an invokation of the command
+[cmd ::bibtex::parse].
+
+[list_end]
+
+[vset CATEGORY bibtex]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/bibtex/bibtex.pcx b/tcllib/modules/bibtex/bibtex.pcx
new file mode 100644
index 0000000..2486dc3
--- /dev/null
+++ b/tcllib/modules/bibtex/bibtex.pcx
@@ -0,0 +1,85 @@
+# -*- tcl -*- bibtex.pcx
+# Syntax of the commands provided by package bibtex.
+#
+# 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 bibtex
+pcx::tcldep 0.5 needs tcl 8.5
+pcx::tcldep 0.6 needs tcl 8.5
+
+namespace eval ::bibtex {}
+
+pcx::message parseSaxCmdErr {Options -*command and -command exclude each other} err
+
+pcx::check 0.5 std ::bibtex::addStrings \
+ {checkSimpleArgs 2 2 {
+ checkWord
+ checkDict
+ }}
+pcx::check 0.5 std ::bibtex::destroy \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 0.5 std ::bibtex::parse \
+ {checkSimpleArgs 1 -1 {
+ {checkConstrained {
+ checkSwitches exact {
+ {-recordcommand {checkSetConstraint sax {checkProcCall 4}}}
+ {-preamblecommand {checkSetConstraint sax {checkProcCall 2}}}
+ {-stringcommand {checkSetConstraint sax {checkProcCall 2}}}
+ {-commentcommand {checkSetConstraint sax {checkProcCall 2}}}
+ {-progresscommand {checkSetConstraint sax {checkProcCall 2}}}
+ {-command {checkSetConstraint cmd {checkProcCall 2}}}
+ {-channel {checkSetConstraint chan checkChannelID}}
+ } {checkConstraint {
+ {{chan sax cmd} {warn bibtex::parseSaxCmdErr {} checkAtEnd}}
+ {{sax cmd} {warn bibtex::parseSaxCmdErr {} {
+ checkSimpleArgs 1 1 {
+ checkWord
+ }
+ }}}
+ {chan checkAtEnd}
+ } {checkSimpleArgs 1 1 {
+ checkWord
+ }}}
+ }}
+ }}
+pcx::check 0.5 std ::bibtex::wait \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+
+pcx::check 0.6 std ::bibtex::parse \
+ {checkSimpleArgs 1 -1 {
+ {checkConstrained {
+ checkSwitches exact {
+ {-casesensitivestrings checkBoolean}
+ {-recordcommand {checkSetConstraint sax {checkProcCall 4}}}
+ {-preamblecommand {checkSetConstraint sax {checkProcCall 2}}}
+ {-stringcommand {checkSetConstraint sax {checkProcCall 2}}}
+ {-commentcommand {checkSetConstraint sax {checkProcCall 2}}}
+ {-progresscommand {checkSetConstraint sax {checkProcCall 2}}}
+ {-command {checkSetConstraint cmd {checkProcCall 2}}}
+ {-channel {checkSetConstraint chan checkChannelID}}
+ } {checkConstraint {
+ {{chan sax cmd} {warn bibtex::parseSaxCmdErr {} checkAtEnd}}
+ {{sax cmd} {warn bibtex::parseSaxCmdErr {} {
+ checkSimpleArgs 1 1 {
+ checkWord
+ }
+ }}}
+ {chan checkAtEnd}
+ } {checkSimpleArgs 1 1 {
+ checkWord
+ }}}
+ }}
+ }}
+
+# Initialization via pcx::init.
+# Use a ::bibtex::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/bibtex/bibtex.tcl b/tcllib/modules/bibtex/bibtex.tcl
new file mode 100644
index 0000000..033a0dc
--- /dev/null
+++ b/tcllib/modules/bibtex/bibtex.tcl
@@ -0,0 +1,502 @@
+#####
+#
+# "BibTeX parser"
+# http://wiki.tcl.tk/13719
+#
+# Tcl code harvested on: 7 Mar 2005, 23:55 GMT
+# Wiki page last updated: ???
+#
+#####
+
+# bibtex.tcl --
+#
+# A basic parser for BibTeX bibliography databases.
+#
+# Copyright (c) 2005 Neil Madden.
+# Copyright (c) 2005 Andreas Kupries.
+# License: Tcl/BSD style.
+
+### NOTES
+###
+### Need commands to introspect parser state. Especially the string
+### map (for testing of 'addStrings', should be useful in general as
+### well).
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.4
+package require cmdline
+
+# ### ### ### ######### ######### #########
+## Implementation: Public API
+
+namespace eval ::bibtex {}
+
+# bibtex::parse --
+#
+# Parse a bibtex file.
+#
+# parse ?options? ?bibtex?
+
+proc ::bibtex::parse {args} {
+ variable data
+ variable id
+
+ # Argument processing
+ if {[llength $args] < 1} {
+ set err "[lindex [info level 0] 0] ?options? ?bibtex?"
+ return -code error "wrong # args: should be \"$err\""
+ }
+
+ array set state {}
+ GetOptions $args state
+
+ # Initialize the parser state from the options, fill in default
+ # values, and handle the input according the specified mode.
+
+ set token bibtex[incr id]
+ foreach {k v} [array get state] {
+ set data($token,$k) $v
+ }
+
+ if {$state(stream)} {
+ # Text not in memory
+ if {!$state(bg)} {
+ # Text from a channel, no async processing. We read everything
+ # into memory and the handle it as before.
+
+ set blockmode [fconfigure $state(-channel) -blocking]
+ fconfigure $state(-channel) -blocking 1
+ set data($token,buffer) [read $state(-channel)]
+ fconfigure $state(-channel) -blocking $blockmode
+
+ # Tell upcoming processing that the text is in memory.
+ set state(stream) 0
+ } else {
+ # Text from a channel, and processing is async. Create an
+ # event handler for the incoming data.
+
+ set data($token,done) 0
+ fileevent $state(-channel) readable \
+ [list ::bibtex::ReadChan $token]
+
+ # Initialize the parser internal result buffer if we use plain
+ # -command, and not the SAX api.
+ if {!$state(sax)} {
+ set data($token,result) {}
+ }
+ }
+ }
+
+ # Initialize the string mappings (none known), and the result
+ # accumulator.
+ set data($token,strings) {}
+ set data($token,result) {}
+
+ if {!$state(stream)} {
+ ParseRecords $token 1
+ if {$state(sax)} {
+ set result $token
+ } else {
+ set result $data($token,result)
+ destroy $token
+ }
+ return $result
+ }
+
+ # Assert: Processing is in background.
+ return $token
+}
+
+# Cleanup a parser, cancelling any callbacks etc.
+
+proc ::bibtex::destroy {token} {
+ variable data
+
+ if {![info exists data($token,stream)]} {
+ return -code error "Illegal bibtex parser \"$token\""
+ }
+ if {$data($token,stream)} {
+ fileevent $data($token,-channel) readable {}
+ }
+
+ array unset data $token,*
+ return
+}
+
+
+proc ::bibtex::wait {token} {
+ variable data
+
+ if {![info exists data($token,stream)]} {
+ return -code error "Illegal bibtex parser \"$token\""
+ }
+ vwait ::bibtex::data($token,done)
+ return
+}
+
+# bibtex::addStrings --
+#
+# Add strings to the map for a particular parser. All strings are
+# expanded at parse time.
+
+proc ::bibtex::addStrings {token strings} {
+ variable data
+ eval [linsert $strings 0 lappend data($token,strings)]
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Implementation: Private utility routines
+
+proc ::bibtex::AddRecord {token type key recdata} {
+ variable data
+ lappend data($token,result) [list $type $key $recdata]
+ return
+}
+
+proc ::bibtex::GetOptions {argv statevar} {
+ upvar 1 $statevar state
+
+ # Basic processing of the argument list
+ # and the options found therein.
+
+ set opts [lrange [::cmdline::GetOptionDefaults {
+ {command.arg {}}
+ {channel.arg {}}
+ {recordcommand.arg {}}
+ {preamblecommand.arg {}}
+ {stringcommand.arg {}}
+ {commentcommand.arg {}}
+ {progresscommand.arg {}}
+ {casesensitivestrings.arg {}}
+ } result] 2 end] ;# Remove ? and help.
+
+ set argc [llength $argv]
+ while {[set err [::cmdline::getopt argv $opts opt arg]]} {
+ if {$err < 0} {
+ set olist ""
+ foreach o [lsort $opts] {
+ if {[string match *.arg $o]} {
+ set o [string range $o 0 end-4]
+ }
+ lappend olist -$o
+ }
+ return -code error "bad option \"$opt\",\
+ should be one of\
+ [linsert [join $olist ", "] end-1 or]"
+ }
+ set state(-$opt) $arg
+ }
+
+ # Check the information gained so far
+ # for inconsistencies and/or missing
+ # pieces.
+
+ set sax [expr {
+ [info exists state(-recordcommand)] ||
+ [info exists state(-preamblecommand)] ||
+ [info exists state(-stringcommand)] ||
+ [info exists state(-commentcommand)] ||
+ [info exists state(-progresscommand)]
+ }] ; # {}
+
+ set bg [info exists state(-command)]
+
+ if {$sax && $bg} {
+ # Sax callbacks and channel completion callback exclude each
+ # other.
+ return -code error "The options -command and -TYPEcommand exclude each other"
+ }
+
+ set stream [info exists state(-channel)]
+
+ if {$stream} {
+ # Channel is present, a text is not allowed.
+ if {[llength $argv]} {
+ return -code error "Option -channel and text exclude each other"
+ }
+
+ # The channel has to exist as well.
+ if {[lsearch -exact [file channels] $state(-channel)] < 0} {
+ return -code error "Illegal channel handle \"$state(-channel)\""
+ }
+ } else {
+ # Channel is not present, we have to have a text, and only
+ # exactly one. And a general -command callback is not allowed.
+
+ if {![llength $argv]} {
+ return -code error "Neither -channel nor text specified"
+ } elseif {[llength $argv] > 1} {
+ return -code error "wrong # args: [lindex [info level 1] 0] ?options? ?bibtex?"
+ }
+
+ # Channel completion callback is not allowed if we are not
+ # reading from a channel.
+
+ if {$bg} {
+ return -code error "Option -command and text exclude each other"
+ }
+
+ set state(buffer) [lindex $argv 0]
+ }
+
+ set state(stream) $stream
+ set state(sax) $sax
+ set state(bg) [expr {$sax || $bg}]
+
+ if {![info exists state(-stringcommand)]} {
+ set state(-stringcommand) [list ::bibtex::addStrings]
+ }
+ if {![info exists state(-recordcommand)] && (!$sax)} {
+ set state(-recordcommand) [list ::bibtex::AddRecord]
+ }
+ if {[info exists state(-casesensitivestrings)] &&
+ $state(-casesensitivestrings)
+ } {
+ set state(casesensitivestrings) 1
+ } else {
+ set state(casesensitivestrings) 0
+ }
+ return
+}
+
+proc ::bibtex::Callback {token type args} {
+ variable data
+
+ #puts stdout "Callback ($token $type ($args))"
+
+ if {[info exists data($token,-${type}command)]} {
+ eval $data($token,-${type}command) [linsert $args 0 $token]
+ }
+ return
+}
+
+proc ::bibtex::ReadChan {token} {
+ variable data
+
+ # Read the waiting characters into our buffer and process
+ # them. The records are saved either through a user supplied
+ # record callback, or the standard callback for our non-sax
+ # processing.
+
+ set chan $data($token,-channel)
+ append data($token,buffer) [read $chan]
+
+ if {[eof $chan]} {
+ # Final processing. In non-SAX mode we have to deliver the
+ # completed result before destroying the parser.
+
+ ParseRecords $token 1
+ set data($token,done) 1
+ if {!$data($token,sax)} {
+ Callback $token {} $data($token,result)
+ }
+ return
+ }
+
+ # Processing of partial data.
+
+ ParseRecords $token 0
+ return
+}
+
+proc ::bibtex::Tidy {str} {
+ return [string tolower [string trim $str]]
+}
+
+proc ::bibtex::ParseRecords {token eof} {
+ # A rough BibTeX grammar (case-insensitive):
+ #
+ # Database ::= (Junk '@' Entry)*
+ # Junk ::= .*?
+ # Entry ::= Record
+ # | Comment
+ # | String
+ # | Preamble
+ # Comment ::= "comment" [^\n]* \n -- ignored
+ # String ::= "string" '{' Field* '}'
+ # Preamble ::= "preamble" '{' .* '}' -- (balanced)
+ # Record ::= Type '{' Key ',' Field* '}'
+ # | Type '(' Key ',' Field* ')' -- not handled
+ # Type ::= Name
+ # Key ::= Name
+ # Field ::= Name '=' Value
+ # Name ::= [^\s\"#%'(){}]*
+ # Value ::= [0-9]+
+ # | '"' ([^'"']|\\'"')* '"'
+ # | '{' .* '}' -- (balanced)
+
+ # " - Fixup emacs hilit confusion from the grammar above.
+ variable data
+ set bibtex $data($token,buffer)
+
+ # Split at each @ character which is at the beginning of a line,
+ # modulo whitespace. This is a heuristic to distinguish the @'s
+ # starting a new record from the @'s occuring inside a record, as
+ # part of email addresses. Empty pices at beginning or end are
+ # stripped before the split.
+
+ regsub -line -all {^[\n\r\f\t ]*@} $bibtex \000 bibtex
+ set db [split [string trim $bibtex \000] \000]
+
+ if {$eof} {
+ set total [llength $db]
+ set step [expr {double($total) / 100.0}]
+ set istep [expr {$step > 1 ? int($step) : 1}]
+ set count 0
+ } else {
+ if {[llength $db] < 2} {
+ # Nothing to process, or data which ay be incomplete.
+ return
+ }
+
+ set data($token,buffer) [lindex $db end]
+ set db [lrange $db 0 end-1]
+
+ # Fake progress meter.
+ set count -1
+ }
+
+ foreach block $db {
+ if {$count < 0} {
+ Callback $token progress -1
+ } elseif {([incr count] % $istep) == 0} {
+ Callback $token progress [expr {int($count / $step)}]
+ }
+ if {[regexp -nocase {\s*comment([^\n])*\n(.*)} $block \
+ -> cmnt rest]} {
+ # Are @comments blocks, or just 1 line?
+ # Does anyone care?
+ Callback $token comment $cmnt
+
+ } elseif {[regexp -nocase {^\s*string[^\{]*\{(.*)\}[^\}]*} \
+ $block -> rest]} {
+ # string macro defs
+ if {$data($token,casesensitivestrings)} {
+ Callback $token string [ParseString $rest]
+ } else {
+ Callback $token string [ParseBlock $rest]
+ }
+ } elseif {[regexp -nocase {\s*preamble[^\{]*\{(.*)\}[^\}]*} \
+ $block -> rest]} {
+ Callback $token preamble $rest
+
+ } elseif {[regexp {([^\{]+)\{([^,]*),(.*)\}[^\}]*} \
+ $block -> type key rest]} {
+ # Do any @string mappings
+ if {$data($token,casesensitivestrings)} {
+ # puts $data($token,strings)
+ set rest [string map $data($token,strings) $rest]
+ } else {
+ set rest [string map -nocase $data($token,strings) $rest]
+ }
+ Callback $token record [Tidy $type] [string trim $key] \
+ [ParseBlock $rest]
+ } else {
+ ## FUTURE: Use a logger.
+ puts stderr "Skipping: $block"
+ }
+ }
+}
+
+proc ::bibtex::ParseString {block} {
+ regexp {(\S+)[^=]*=(.*)} $block -> key rest
+ return [list $key $rest]
+}
+
+proc ::bibtex::ParseBlock {block} {
+ set ret [list]
+ set index 0
+ while {
+ [regexp -start $index -indices -- \
+ {(\S+)[^=]*=(.*)} $block -> key rest]
+ } {
+ foreach {ks ke} $key break
+ set k [Tidy [string range $block $ks $ke]]
+ foreach {rs re} $rest break
+ foreach {v index} \
+ [ParseBibString $rs [string range $block $rs $re]] \
+ break
+ lappend ret $k $v
+ }
+ return $ret
+}
+
+proc ::bibtex::ParseBibString {index str} {
+ set count 0
+ set retstr ""
+ set escape 0
+ set string 0
+ foreach char [split $str ""] {
+ incr index
+ if {$escape} {
+ set escape 0
+ } else {
+ if {$char eq "\{"} {
+ incr count
+ continue
+ } elseif {$char eq "\}"} {
+ incr count -1
+ if {$count < 0} {incr index -1; break}
+ continue
+ } elseif {$char eq ","} {
+ if {$count == 0} break
+ } elseif {$char eq "\\"} {
+ set escape 1
+ continue
+ } elseif {$char eq "\""} {
+ # Managing the count ensures that comma inside of a
+ # string is not considered as the end of the field.
+ if {!$string} {
+ incr count
+ set string 1
+ } else {
+ incr count -1
+ set string 0
+ }
+ continue
+ }
+ # else: Nothing
+ }
+ append retstr $char
+ }
+ regsub -all {\s+} $retstr { } retstr
+ return [list [string trim $retstr] $index]
+}
+
+
+# ### ### ### ######### ######### #########
+## Internal. Package configuration and state.
+
+namespace eval bibtex {
+ # Counter for the generation of parser tokens.
+ variable id 0
+
+ # State of all parsers. Keys for each parser are prefixed with the
+ # parser token.
+ variable data
+ array set data {}
+
+ # Keys and their meaning (listed without token prefix)
+ ##
+ # buffer
+ # eof
+ # channel <-\/- Difference ?
+ # strings |
+ # -async |
+ # -blocksize |
+ # -channel <-/
+ # -recordcommand -- callback for each record
+ # -preamblecommand -- callback for @preamble blocks
+ # -stringcommand -- callback for @string macros
+ # -commentcommand -- callback for @comment blocks
+ # -progresscommand -- callback to indicate progress of parse
+ ##
+}
+
+# ### ### ### ######### ######### #########
+## Ready to go
+package provide bibtex 0.6
+# EOF
diff --git a/tcllib/modules/bibtex/bibtex.test b/tcllib/modules/bibtex/bibtex.test
new file mode 100644
index 0000000..aa84594
--- /dev/null
+++ b/tcllib/modules/bibtex/bibtex.test
@@ -0,0 +1,236 @@
+# -*- tcl -*-
+# bibtex.test: tests for the bibtex parser.
+#
+# Copyright (c) 2005 by Andreas Kupries <a.kupries@westend.com>
+# All rights reserved.
+#
+# RCS: @(#) $Id: bibtex.test,v 1.7 2006/10/09 21:41:40 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 1.0
+
+testing {
+ useLocal bibtex.tcl bibtex
+}
+
+# -------------------------------------------------------------------------
+
+proc track {args} {global track ; lappend track $args ; return}
+proc addstr {token strings} {
+ track string__ $token $strings
+ bibtex::addStrings $token $strings
+}
+
+# -------------------------------------------------------------------------
+
+test bibtex-1.0 {Parse errors} {
+ set code [catch {::bibtex::parse} msg]
+ list $code $msg
+} {1 {wrong # args: should be "::bibtex::parse ?options? ?bibtex?"}}
+
+test bibtex-1.1 {Parse errors} {} {
+ set code [catch {::bibtex::parse -frob} msg]
+ list $code $msg
+} {1 {bad option "frob", should be one of -casesensitivestrings, -channel, -command, -commentcommand, -preamblecommand, -progresscommand, -recordcommand, or -stringcommand}}
+
+test bibtex-1.2 {Parse errors} {
+ set code [catch {::bibtex::parse -frob nibar} msg]
+ list $code $msg
+} {1 {bad option "frob", should be one of -casesensitivestrings, -channel, -command, -commentcommand, -preamblecommand, -progresscommand, -recordcommand, or -stringcommand}}
+
+test bibtex-1.3 {Parse errors} {} {
+ set code [catch {::bibtex::parse -frob nibar fuzz} msg]
+ list $code $msg
+} {1 {bad option "frob", should be one of -casesensitivestrings, -channel, -command, -commentcommand, -preamblecommand, -progresscommand, -recordcommand, or -stringcommand}}
+
+test bibtex-1.4 {Parse errors} {} {
+ set code [catch {::bibtex::parse -command nibar -recordcommand fuzz snarf} msg]
+ list $code $msg
+} {1 {The options -command and -TYPEcommand exclude each other}}
+
+test bibtex-1.5 {Parse errors} {} {
+ set code [catch {::bibtex::parse -channel nibar snarf} msg]
+ list $code $msg
+} {1 {Option -channel and text exclude each other}}
+
+test bibtex-1.6 {Parse errors} {} {
+ set code [catch {::bibtex::parse -channel nibar} msg]
+ list $code $msg
+} {1 {Illegal channel handle "nibar"}}
+
+test bibtex-1.7 {Parse errors} {} {
+ set code [catch {::bibtex::parse -command nibar} msg]
+ list $code $msg
+} {1 {Neither -channel nor text specified}}
+
+test bibtex-1.8 {Parse errors} {} {
+ set code [catch {::bibtex::parse -command nibar fuzz snarf} msg]
+ list $code $msg
+} {1 {wrong # args: ::bibtex::parse ?options? ?bibtex?}}
+
+test bibtex-1.9 {Parse errors} {} {
+ set code [catch {::bibtex::parse -command nibar fuzz} msg]
+ list $code $msg
+} {1 {Option -command and text exclude each other}}
+
+
+# -------------------------------------------------------------------------
+
+set bytecode [list [list \
+ book krasner83 [list \
+ title {Smalltalk-80: Bits of History, Words of Advice} \
+ publisher Addison-Wesley \
+ year 1983 \
+ editor {Glen Krasner} \
+ ]]]
+
+set penn [list [list \
+ inproceedings Carberry90 [list \
+ author {Sandra Carberry} \
+ title {Incorporating default inferences into plan recognition} \
+ booktitle aaai90 \
+ year 1990 \
+ pages 471--478 \
+ address {Boston, MA} \
+ ]]]
+
+set pennfull [list [list \
+ inproceedings Carberry90 [list \
+ author {Sandra Carberry} \
+ title {Incorporating default inferences into plan recognition} \
+ booktitle {Proc. National Conference on Artificial Intelligence, Boston} \
+ year 1990 \
+ pages 471--478 \
+ address {Boston, MA} \
+ ]]]
+
+
+test bibtex-2.0 {Parse string, direct result} {
+ set str [viewFile [file join [file dirname [info script]] bytecode.bib]]
+ bibtex::parse $str
+} $bytecode
+
+test bibtex-2.1 {Parse string, sax mode} {
+ set track {}
+ set str [viewFile [file join [file dirname [info script]] bytecode.bib]]
+ set t [bibtex::parse \
+ -progresscommand {track progress} \
+ -commentcommand {track comment_} \
+ -stringcommand {track string__} \
+ -preamblecommand {track preamble} \
+ -recordcommand {track record__} \
+ $str]
+ bibtex::destroy $t
+ list $t $track
+} [list bibtex2 [list \
+ {progress bibtex2 100} \
+ [linsert [lindex $bytecode 0] 0 record__ bibtex2]
+]]
+
+test bibtex-2.2 {Parse channel, direct result} {
+ # The contents of penn_sub.bib have been taken out of
+ # ftp://ftp.cis.upenn.edu/pub/anoop/bib/pennbib.bib
+
+ set chan [open [file join [file dirname [info script]] penn_sub.bib] r]
+ set records [bibtex::parse -channel $chan]
+ close $chan
+ set records
+} $pennfull
+
+test bibtex-2.3 {Parse channel, sax mode} {
+ set track {}
+ set chan [open [file join [file dirname [info script]] penn_sub.bib] r]
+
+ set t [bibtex::parse \
+ -progresscommand {track progress} \
+ -commentcommand {track comment_} \
+ -stringcommand {track string__} \
+ -preamblecommand {track preamble} \
+ -recordcommand {track record__} \
+ -channel $chan]
+ bibtex::wait $t
+ bibtex::destroy $t
+
+ close $chan
+ set track
+} [list \
+ {progress bibtex4 50} \
+ {string__ bibtex4 {aaai90 {Proc. National Conference on Artificial Intelligence, Boston}}} \
+ {progress bibtex4 100} \
+ [linsert [lindex $penn 0] 0 record__ bibtex4] \
+ ]
+
+test bibtex-2.4 {Parse channel, sax mode 2} {
+ set track {}
+ set chan [open [file join [file dirname [info script]] penn_sub.bib] r]
+
+ set t [bibtex::parse \
+ -progresscommand {track progress} \
+ -commentcommand {track comment_} \
+ -stringcommand addstr \
+ -preamblecommand {track preamble} \
+ -recordcommand {track record__} \
+ -channel $chan]
+ bibtex::wait $t
+ bibtex::destroy $t
+ close $chan
+ set track
+} [list \
+ {progress bibtex5 50} \
+ {string__ bibtex5 {aaai90 {Proc. National Conference on Artificial Intelligence, Boston}}} \
+ {progress bibtex5 100} \
+ [linsert [lindex $pennfull 0] 0 record__ bibtex5] \
+ ]
+
+test bibtex-2.5 {Parse channel, async} {
+ # The contents of penn_sub.bib have been taken out of
+ # ftp://ftp.cis.upenn.edu/pub/anoop/bib/pennbib.bib
+
+ set chan [open [file join [file dirname [info script]] penn_sub.bib] r]
+ proc done {args} {global done ; set done $args ; return}
+
+ set done ""
+ set t [bibtex::parse -command done -channel $chan]
+ vwait ::done
+ bibtex::destroy $t
+ close $chan
+ set done
+} [list bibtex6 $pennfull]
+
+
+test bibtex-3.0 {Destroying a parser} {
+ set code [catch {::bibtex::destroy} msg]
+ list $code $msg
+} [list 1 [tcltest::wrongNumArgs "::bibtex::destroy" "token" 0]]
+
+test bibtex-3.1 {Destroying a parser} {
+ set code [catch {::bibtex::destroy a b} msg]
+ list $code $msg
+} [list 1 [tcltest::tooManyArgs "::bibtex::destroy" "token"]]
+
+test bibtex-3.2 {Destroying a parser} {
+ set code [catch {::bibtex::destroy foo} msg]
+ list $code $msg
+} {1 {Illegal bibtex parser "foo"}}
+
+test bibtex-4.0 {Destroying a parser} {
+
+ set chan [open [file join [file dirname [info script]] bytecode.bib] r]
+ proc done {args} {global done ; set done $args ; return}
+
+ set done ""
+ set t [bibtex::parse -command done -channel $chan]
+ bibtex::destroy $t
+ close $chan
+} {}
+
+# ... Tests of addStrings ...
+# (Requires introspection of parser state)
+
+testsuiteCleanup
diff --git a/tcllib/modules/bibtex/bytecode.bib b/tcllib/modules/bibtex/bytecode.bib
new file mode 100644
index 0000000..0f7409d
--- /dev/null
+++ b/tcllib/modules/bibtex/bytecode.bib
@@ -0,0 +1,6 @@
+@Book{krasner83,
+ title = "Smalltalk-80: Bits of History, Words of Advice",
+ publisher = "Addison-Wesley",
+ year = 1983,
+ editor = "Glen Krasner"
+}
diff --git a/tcllib/modules/bibtex/penn_sub.bib b/tcllib/modules/bibtex/penn_sub.bib
new file mode 100644
index 0000000..4cd6a3f
--- /dev/null
+++ b/tcllib/modules/bibtex/penn_sub.bib
@@ -0,0 +1,11 @@
+@String{aaai90 = "Proc. National Conference on Artificial Intelligence,
+ Boston"}
+@InProceedings{Carberry90,
+ author = "Sandra Carberry",
+ title = "Incorporating default inferences into plan
+ recognition",
+ booktitle = "aaai90",
+ year = "1990",
+ pages = "471--478",
+ address = "Boston, MA",
+}
diff --git a/tcllib/modules/bibtex/pkgIndex.tcl b/tcllib/modules/bibtex/pkgIndex.tcl
new file mode 100644
index 0000000..5c2ccf1
--- /dev/null
+++ b/tcllib/modules/bibtex/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded bibtex 0.6 [list source [file join $dir bibtex.tcl]]
diff --git a/tcllib/modules/blowfish/ChangeLog b/tcllib/modules/blowfish/ChangeLog
new file mode 100644
index 0000000..92da300
--- /dev/null
+++ b/tcllib/modules/blowfish/ChangeLog
@@ -0,0 +1,136 @@
+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-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-17 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * blowfish.test: Fix default if -dir option is not specified it
+ defaults to 'enc' and this fails to match 'encrypt' and results in
+ the default operation being 'decrypt'
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-20 Andreas Kupries <andreask@activestate.com>
+
+ * blowfish.man: Version bumped to 1.0.3 due to bugfix at Mar 12.
+ * blowfish.tcl:
+ * pkgIndex.tcl:
+
+2007-03-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * blowfish.man: Fixed all warnings due to use of now deprecated
+ commands. Added a section about how to give feedback.
+
+2007-03-12 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * blowfish.tcl: Applied patch from bug #1664626 by Neil Madden to
+ the fix variable mis-naming in the Chunk command.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-10-02 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * blowfish.test: Document the padding and added -pad option
+ * blowfish.tcl: to turn off padding or change the pad char.
+ * blowfish.man: Increment the patchlevel.
+ * pkgIndex.tcl:
+
+2006-09-19 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * blowfish.tcl: Bug 1560822: hyphen handling.
+ * blowfish.test: Added test for hyphen handling.
+ * blowfish.man: Note -- for option termination.
+ * pkgIndex.tcl: Increment patchlevel.
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * blowfish.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * blowfish.test: Hooked into the new common test support code.
+
+2005-10-18 Andreas Kupries <andreask@activestate.com>
+
+ * blowfish.bench: Extended with benchmarks for the keyschedule.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-09-04 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * blowfish.tcl: Added some performance enhancements. Added some
+ * blowfish.test: documentation for the API. Fix testing to test
+ * blowfish.man: each implementation. Checked with tcl 8.2.
+ * pkgIndex.tcl:
+
+2005-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * blowfish.man: Fixed a typo.
+
+2005-06-22 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * blowfish.man: new file
+
+2004-12-21 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * blowfish.tcl: Fixed bug in search for Trfcrypt (noticed by
+ Antirez). Added a Reset command to the programming API to permit
+ reuse of a key with a new initialization vector..
+
+2004-12-07 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * blowfish.tcl: Add in support for Trfcrypt implementation.
+ * blowfish.test: Support variable key length and added tests.
+
+2004-12-06 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * blowfish.tcl: Imported Frank Pilhofer's pure-Tcl implementation
+ * blowfish.test: from the Tcler's wiki. Modified to remove the
+ Itcl code and to conform to the tcllib programming standards and
+ conventions. Test file includes standard test vectors.
+
+
diff --git a/tcllib/modules/blowfish/blowfish.bench b/tcllib/modules/blowfish/blowfish.bench
new file mode 100644
index 0000000..f3ece4e
--- /dev/null
+++ b/tcllib/modules/blowfish/blowfish.bench
@@ -0,0 +1,66 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'blowfish' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+package forget blowfish
+catch {namespace delete ::blowfish}
+source [file join [file dirname [info script]] blowfish.tcl]
+
+set i [binary format H* 000000000000000]
+set p [binary format H* 00112233445566778899aabbccddeeff]
+
+set k [binary format H* 000102030405060]
+set c [binary format H* 69c4e0d86a7b0430d8cdb78070b4c55a]
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+bench -desc "BLOWFISH ECB encryption" -body {
+ blowfish::blowfish -mode ecb -dir enc -key $k -iv $i $p
+}
+
+bench -desc "BLOWFISH ECB decryption" -body {
+ blowfish::blowfish -mode ecb -dir dec -key $k -iv $i $c
+}
+
+bench -desc "BLOWFISH ECB encryption core" -pre {
+ set key [blowfish::Init ecb $k $i]
+} -body {
+ blowfish::Encrypt $key $p
+} -post {
+ blowfish::Final $key
+}
+
+bench -desc "BLOWFISH ECB decryption core" -pre {
+ set key [blowfish::Init ecb $k $i]
+} -body {
+ blowfish::Decrypt $key $c
+} -post {
+ blowfish::Final $key
+}
+
+bench -desc "BLOWFISH ECB keyschedule" -body {
+ blowfish::Final [blowfish::Init ecb $k $i]
+}
+
+bench -desc "BLOWFISH CBC keyschedule" -body {
+ blowfish::Final [blowfish::Init cbc $k $i]
+}
+
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/blowfish/blowfish.man b/tcllib/modules/blowfish/blowfish.man
new file mode 100644
index 0000000..8ee4627
--- /dev/null
+++ b/tcllib/modules/blowfish/blowfish.man
@@ -0,0 +1,164 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin blowfish n 1.0.3]
+[see_also 3des]
+[see_also des]
+[see_also rc4]
+[keywords {block cipher}]
+[keywords blowfish]
+[keywords cryptography]
+[keywords encryption]
+[keywords security]
+[copyright {2003, Pat Thoyts <patthoyts@users.sourceforge.net>}]
+[moddesc {Blowfish Block Cipher}]
+[titledesc {Implementation of the Blowfish block cipher}]
+[category {Hashes, checksums, and encryption}]
+[require Tcl 8.4]
+[require blowfish [opt 1.0.4]]
+[description]
+[para]
+
+This package is an implementation in Tcl of the Blowfish algorithm
+developed by Bruce Schneier [lb]1[rb]. Blowfish is a 64-bit block cipher
+designed to operate quickly on 32 bit architectures and accepting a
+variable key length. This implementation supports ECB and CBC mode
+blowfish encryption.
+
+[section {COMMANDS}]
+
+[list_begin definitions]
+
+[call [cmd "::blowfish::blowfish"] \
+ [opt [arg "-mode [lb]ecb|cbc[rb]"]] \
+ [opt [arg "-dir [lb]encrypt|decrypt[rb]"]] \
+ [arg "-key keydata"] \
+ [opt [arg "-iv vector"]] \
+ [opt [arg "-out channel"]] \
+ [opt [arg "-chunksize size"]] \
+ [opt [arg "-pad padchar"]] \
+ [lb] [arg "-in channel"] | \
+ [opt [arg "--"]] [arg "data"] [rb]]
+
+Perform the [package blowfish] algorithm on either the data provided
+by the argument or on the data read from the [arg "-in"] channel. If
+an [arg "-out"] channel is given then the result will be written to
+this channel.
+
+[para]
+
+The [arg -key] option must be given. This parameter takes a binary
+string of variable length and is used to generate the [package blowfish]
+key schedule. You should be aware that creating a key
+schedule is quite an expensive operation in blowfish so it is worth
+reusing the key where possible. See [cmd Reset].
+
+[para]
+
+The [arg -mode] and [arg -dir] options are optional and default to cbc
+mode and encrypt respectively. The initialization vector [arg -iv]
+takes an 8 byte binary argument which defaults to 8 zeros.
+See [sectref "MODES OF OPERATION"] for more about available modes and
+their uses.
+
+[para]
+
+Blowfish is a 64-bit block cipher. This means that the data must be
+provided in units that are a multiple of 8 bytes. The [cmd blowfish]
+command will by default add nul characters to pad the input data to a
+multiple of 8 bytes if necessary. The programming api commands will
+never add padding and instead will raise an error if the input is not
+a multiple of the block size. The [arg -pad] option can be used to
+change the padding character or to disable padding if the empty string
+is provided as the argument.
+
+[list_end]
+
+[section "PROGRAMMING INTERFACE"]
+
+[list_begin definitions]
+
+[call [cmd "::blowfish::Init"] [arg "mode"] [arg "keydata"] [arg "iv"]]
+
+Construct a new blowfish key schedule using the specified key data and
+the given initialization vector. The initialization vector is not used
+with ECB mode but is important for CBC mode.
+See [sectref "MODES OF OPERATION"] for details about cipher modes.
+
+[call [cmd "::blowfish::Encrypt"] [arg "Key"] [arg "data"]]
+
+Use a prepared key acquired by calling [cmd Init] to encrypt the
+provided data. The data argument should be a binary array that is a
+multiple of the block size of 8 bytes. The result is a binary
+array the same size as the input of encrypted data.
+
+[call [cmd "::blowfish::Decrypt"] [arg "Key"] [arg "data"]]
+
+Decipher data using the key. Note that the same key may be used to
+encrypt and decrypt data provided that the initialization vector is
+reset appropriately for CBC mode.
+
+[call [cmd "::blowfish::Reset"] [arg "Key"] [arg "iv"]]
+
+Reset the initialization vector. This permits the programmer to re-use
+a key and avoid the cost of re-generating the key schedule where the
+same key data is being used multiple times.
+
+[call [cmd "::blowfish::Final"] [arg "Key"]]
+
+This should be called to clean up resources associated with [arg Key].
+Once this function has been called the key may not be used again.
+
+[list_end]
+
+[section "MODES OF OPERATION"]
+
+[list_begin definitions]
+
+[def "Electronic Code Book (ECB)"]
+ECB is the basic mode of all block ciphers. Each block is encrypted
+independently and so identical plain text will produce identical
+output when encrypted with the same key. Any encryption errors will
+only affect a single block however this is vulnerable to known
+plaintext attacks.
+
+[def "Cipher Block Chaining (CBC)"]
+
+CBC mode uses the output of the last block encryption to affect the
+current block. An initialization vector of the same size as the cipher
+block size is used to handle the first block. The initialization
+vector should be chosen randomly and transmitted as the first block of
+the output. Errors in encryption affect the current block and the next
+block after which the cipher will correct itself. CBC is the most
+commonly used mode in software encryption.
+
+[list_end]
+
+[section "EXAMPLES"]
+
+[example {
+% blowfish::blowfish -hex -mode ecb -dir encrypt -key secret01 "hello, world!"
+d0d8f27e7a374b9e2dbd9938dd04195a
+}]
+
+[example {
+ set Key [blowfish::Init cbc $eight_bytes_key_data $eight_byte_iv]
+ append ciphertext [blowfish::Encrypt $Key $plaintext]
+ append ciphertext [blowfish::Encrypt $Key $additional_plaintext]
+ blowfish::Final $Key
+}]
+
+[section "REFERENCES"]
+
+[list_begin enumerated]
+
+[enum]
+ Schneier, B. "Applied Cryptography, 2nd edition", 1996,
+ ISBN 0-471-11709-9, pub. John Wiley & Sons.
+
+[list_end]
+
+[section AUTHORS]
+Frank Pilhofer, Pat Thoyts
+
+[vset CATEGORY blowfish]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/blowfish/blowfish.tcl b/tcllib/modules/blowfish/blowfish.tcl
new file mode 100644
index 0000000..2610ae1
--- /dev/null
+++ b/tcllib/modules/blowfish/blowfish.tcl
@@ -0,0 +1,724 @@
+# blowfish.tcl -
+#
+# Pure-Tcl implementation of the Blowfish algorithm.
+#
+# See http://www.schneier.com/blowfish.html for information about the
+# Blowfish algorithm.
+#
+# The implementation is derived from Paul Kocher's implementation,
+# available at http://www.schneier.com/blowfish-download.html
+#
+# Copyright (C) 2004 Frank Pilhofer
+# Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+
+package require Tcl 8.2
+
+namespace eval blowfish {
+ variable uid
+ if {![info exists uid]} { set uid 0 }
+
+ variable accel
+ array set accel {trf 0}
+
+ namespace export blowfish
+
+ variable ORIG_P {
+ 0x243F6A88 0x85A308D3 0x13198A2E 0x03707344
+ 0xA4093822 0x299F31D0 0x082EFA98 0xEC4E6C89
+ 0x452821E6 0x38D01377 0xBE5466CF 0x34E90C6C
+ 0xC0AC29B7 0xC97C50DD 0x3F84D5B5 0xB5470917
+ 0x9216D5D9 0x8979FB1B
+ }
+
+ variable ORIG_S {
+ 0xD1310BA6 0x98DFB5AC 0x2FFD72DB 0xD01ADFB7
+ 0xB8E1AFED 0x6A267E96 0xBA7C9045 0xF12C7F99
+ 0x24A19947 0xB3916CF7 0x0801F2E2 0x858EFC16
+ 0x636920D8 0x71574E69 0xA458FEA3 0xF4933D7E
+ 0x0D95748F 0x728EB658 0x718BCD58 0x82154AEE
+ 0x7B54A41D 0xC25A59B5 0x9C30D539 0x2AF26013
+ 0xC5D1B023 0x286085F0 0xCA417918 0xB8DB38EF
+ 0x8E79DCB0 0x603A180E 0x6C9E0E8B 0xB01E8A3E
+ 0xD71577C1 0xBD314B27 0x78AF2FDA 0x55605C60
+ 0xE65525F3 0xAA55AB94 0x57489862 0x63E81440
+ 0x55CA396A 0x2AAB10B6 0xB4CC5C34 0x1141E8CE
+ 0xA15486AF 0x7C72E993 0xB3EE1411 0x636FBC2A
+ 0x2BA9C55D 0x741831F6 0xCE5C3E16 0x9B87931E
+ 0xAFD6BA33 0x6C24CF5C 0x7A325381 0x28958677
+ 0x3B8F4898 0x6B4BB9AF 0xC4BFE81B 0x66282193
+ 0x61D809CC 0xFB21A991 0x487CAC60 0x5DEC8032
+ 0xEF845D5D 0xE98575B1 0xDC262302 0xEB651B88
+ 0x23893E81 0xD396ACC5 0x0F6D6FF3 0x83F44239
+ 0x2E0B4482 0xA4842004 0x69C8F04A 0x9E1F9B5E
+ 0x21C66842 0xF6E96C9A 0x670C9C61 0xABD388F0
+ 0x6A51A0D2 0xD8542F68 0x960FA728 0xAB5133A3
+ 0x6EEF0B6C 0x137A3BE4 0xBA3BF050 0x7EFB2A98
+ 0xA1F1651D 0x39AF0176 0x66CA593E 0x82430E88
+ 0x8CEE8619 0x456F9FB4 0x7D84A5C3 0x3B8B5EBE
+ 0xE06F75D8 0x85C12073 0x401A449F 0x56C16AA6
+ 0x4ED3AA62 0x363F7706 0x1BFEDF72 0x429B023D
+ 0x37D0D724 0xD00A1248 0xDB0FEAD3 0x49F1C09B
+ 0x075372C9 0x80991B7B 0x25D479D8 0xF6E8DEF7
+ 0xE3FE501A 0xB6794C3B 0x976CE0BD 0x04C006BA
+ 0xC1A94FB6 0x409F60C4 0x5E5C9EC2 0x196A2463
+ 0x68FB6FAF 0x3E6C53B5 0x1339B2EB 0x3B52EC6F
+ 0x6DFC511F 0x9B30952C 0xCC814544 0xAF5EBD09
+ 0xBEE3D004 0xDE334AFD 0x660F2807 0x192E4BB3
+ 0xC0CBA857 0x45C8740F 0xD20B5F39 0xB9D3FBDB
+ 0x5579C0BD 0x1A60320A 0xD6A100C6 0x402C7279
+ 0x679F25FE 0xFB1FA3CC 0x8EA5E9F8 0xDB3222F8
+ 0x3C7516DF 0xFD616B15 0x2F501EC8 0xAD0552AB
+ 0x323DB5FA 0xFD238760 0x53317B48 0x3E00DF82
+ 0x9E5C57BB 0xCA6F8CA0 0x1A87562E 0xDF1769DB
+ 0xD542A8F6 0x287EFFC3 0xAC6732C6 0x8C4F5573
+ 0x695B27B0 0xBBCA58C8 0xE1FFA35D 0xB8F011A0
+ 0x10FA3D98 0xFD2183B8 0x4AFCB56C 0x2DD1D35B
+ 0x9A53E479 0xB6F84565 0xD28E49BC 0x4BFB9790
+ 0xE1DDF2DA 0xA4CB7E33 0x62FB1341 0xCEE4C6E8
+ 0xEF20CADA 0x36774C01 0xD07E9EFE 0x2BF11FB4
+ 0x95DBDA4D 0xAE909198 0xEAAD8E71 0x6B93D5A0
+ 0xD08ED1D0 0xAFC725E0 0x8E3C5B2F 0x8E7594B7
+ 0x8FF6E2FB 0xF2122B64 0x8888B812 0x900DF01C
+ 0x4FAD5EA0 0x688FC31C 0xD1CFF191 0xB3A8C1AD
+ 0x2F2F2218 0xBE0E1777 0xEA752DFE 0x8B021FA1
+ 0xE5A0CC0F 0xB56F74E8 0x18ACF3D6 0xCE89E299
+ 0xB4A84FE0 0xFD13E0B7 0x7CC43B81 0xD2ADA8D9
+ 0x165FA266 0x80957705 0x93CC7314 0x211A1477
+ 0xE6AD2065 0x77B5FA86 0xC75442F5 0xFB9D35CF
+ 0xEBCDAF0C 0x7B3E89A0 0xD6411BD3 0xAE1E7E49
+ 0x00250E2D 0x2071B35E 0x226800BB 0x57B8E0AF
+ 0x2464369B 0xF009B91E 0x5563911D 0x59DFA6AA
+ 0x78C14389 0xD95A537F 0x207D5BA2 0x02E5B9C5
+ 0x83260376 0x6295CFA9 0x11C81968 0x4E734A41
+ 0xB3472DCA 0x7B14A94A 0x1B510052 0x9A532915
+ 0xD60F573F 0xBC9BC6E4 0x2B60A476 0x81E67400
+ 0x08BA6FB5 0x571BE91F 0xF296EC6B 0x2A0DD915
+ 0xB6636521 0xE7B9F9B6 0xFF34052E 0xC5855664
+ 0x53B02D5D 0xA99F8FA1 0x08BA4799 0x6E85076A
+ 0x4B7A70E9 0xB5B32944 0xDB75092E 0xC4192623
+ 0xAD6EA6B0 0x49A7DF7D 0x9CEE60B8 0x8FEDB266
+ 0xECAA8C71 0x699A17FF 0x5664526C 0xC2B19EE1
+ 0x193602A5 0x75094C29 0xA0591340 0xE4183A3E
+ 0x3F54989A 0x5B429D65 0x6B8FE4D6 0x99F73FD6
+ 0xA1D29C07 0xEFE830F5 0x4D2D38E6 0xF0255DC1
+ 0x4CDD2086 0x8470EB26 0x6382E9C6 0x021ECC5E
+ 0x09686B3F 0x3EBAEFC9 0x3C971814 0x6B6A70A1
+ 0x687F3584 0x52A0E286 0xB79C5305 0xAA500737
+ 0x3E07841C 0x7FDEAE5C 0x8E7D44EC 0x5716F2B8
+ 0xB03ADA37 0xF0500C0D 0xF01C1F04 0x0200B3FF
+ 0xAE0CF51A 0x3CB574B2 0x25837A58 0xDC0921BD
+ 0xD19113F9 0x7CA92FF6 0x94324773 0x22F54701
+ 0x3AE5E581 0x37C2DADC 0xC8B57634 0x9AF3DDA7
+ 0xA9446146 0x0FD0030E 0xECC8C73E 0xA4751E41
+ 0xE238CD99 0x3BEA0E2F 0x3280BBA1 0x183EB331
+ 0x4E548B38 0x4F6DB908 0x6F420D03 0xF60A04BF
+ 0x2CB81290 0x24977C79 0x5679B072 0xBCAF89AF
+ 0xDE9A771F 0xD9930810 0xB38BAE12 0xDCCF3F2E
+ 0x5512721F 0x2E6B7124 0x501ADDE6 0x9F84CD87
+ 0x7A584718 0x7408DA17 0xBC9F9ABC 0xE94B7D8C
+ 0xEC7AEC3A 0xDB851DFA 0x63094366 0xC464C3D2
+ 0xEF1C1847 0x3215D908 0xDD433B37 0x24C2BA16
+ 0x12A14D43 0x2A65C451 0x50940002 0x133AE4DD
+ 0x71DFF89E 0x10314E55 0x81AC77D6 0x5F11199B
+ 0x043556F1 0xD7A3C76B 0x3C11183B 0x5924A509
+ 0xF28FE6ED 0x97F1FBFA 0x9EBABF2C 0x1E153C6E
+ 0x86E34570 0xEAE96FB1 0x860E5E0A 0x5A3E2AB3
+ 0x771FE71C 0x4E3D06FA 0x2965DCB9 0x99E71D0F
+ 0x803E89D6 0x5266C825 0x2E4CC978 0x9C10B36A
+ 0xC6150EBA 0x94E2EA78 0xA5FC3C53 0x1E0A2DF4
+ 0xF2F74EA7 0x361D2B3D 0x1939260F 0x19C27960
+ 0x5223A708 0xF71312B6 0xEBADFE6E 0xEAC31F66
+ 0xE3BC4595 0xA67BC883 0xB17F37D1 0x018CFF28
+ 0xC332DDEF 0xBE6C5AA5 0x65582185 0x68AB9802
+ 0xEECEA50F 0xDB2F953B 0x2AEF7DAD 0x5B6E2F84
+ 0x1521B628 0x29076170 0xECDD4775 0x619F1510
+ 0x13CCA830 0xEB61BD96 0x0334FE1E 0xAA0363CF
+ 0xB5735C90 0x4C70A239 0xD59E9E0B 0xCBAADE14
+ 0xEECC86BC 0x60622CA7 0x9CAB5CAB 0xB2F3846E
+ 0x648B1EAF 0x19BDF0CA 0xA02369B9 0x655ABB50
+ 0x40685A32 0x3C2AB4B3 0x319EE9D5 0xC021B8F7
+ 0x9B540B19 0x875FA099 0x95F7997E 0x623D7DA8
+ 0xF837889A 0x97E32D77 0x11ED935F 0x16681281
+ 0x0E358829 0xC7E61FD6 0x96DEDFA1 0x7858BA99
+ 0x57F584A5 0x1B227263 0x9B83C3FF 0x1AC24696
+ 0xCDB30AEB 0x532E3054 0x8FD948E4 0x6DBC3128
+ 0x58EBF2EF 0x34C6FFEA 0xFE28ED61 0xEE7C3C73
+ 0x5D4A14D9 0xE864B7E3 0x42105D14 0x203E13E0
+ 0x45EEE2B6 0xA3AAABEA 0xDB6C4F15 0xFACB4FD0
+ 0xC742F442 0xEF6ABBB5 0x654F3B1D 0x41CD2105
+ 0xD81E799E 0x86854DC7 0xE44B476A 0x3D816250
+ 0xCF62A1F2 0x5B8D2646 0xFC8883A0 0xC1C7B6A3
+ 0x7F1524C3 0x69CB7492 0x47848A0B 0x5692B285
+ 0x095BBF00 0xAD19489D 0x1462B174 0x23820E00
+ 0x58428D2A 0x0C55F5EA 0x1DADF43E 0x233F7061
+ 0x3372F092 0x8D937E41 0xD65FECF1 0x6C223BDB
+ 0x7CDE3759 0xCBEE7460 0x4085F2A7 0xCE77326E
+ 0xA6078084 0x19F8509E 0xE8EFD855 0x61D99735
+ 0xA969A7AA 0xC50C06C2 0x5A04ABFC 0x800BCADC
+ 0x9E447A2E 0xC3453484 0xFDD56705 0x0E1E9EC9
+ 0xDB73DBD3 0x105588CD 0x675FDA79 0xE3674340
+ 0xC5C43465 0x713E38D8 0x3D28F89E 0xF16DFF20
+ 0x153E21E7 0x8FB03D4A 0xE6E39F2B 0xDB83ADF7
+ 0xE93D5A68 0x948140F7 0xF64C261C 0x94692934
+ 0x411520F7 0x7602D4F7 0xBCF46B2E 0xD4A20068
+ 0xD4082471 0x3320F46A 0x43B7D4B7 0x500061AF
+ 0x1E39F62E 0x97244546 0x14214F74 0xBF8B8840
+ 0x4D95FC1D 0x96B591AF 0x70F4DDD3 0x66A02F45
+ 0xBFBC09EC 0x03BD9785 0x7FAC6DD0 0x31CB8504
+ 0x96EB27B3 0x55FD3941 0xDA2547E6 0xABCA0A9A
+ 0x28507825 0x530429F4 0x0A2C86DA 0xE9B66DFB
+ 0x68DC1462 0xD7486900 0x680EC0A4 0x27A18DEE
+ 0x4F3FFEA2 0xE887AD8C 0xB58CE006 0x7AF4D6B6
+ 0xAACE1E7C 0xD3375FEC 0xCE78A399 0x406B2A42
+ 0x20FE9E35 0xD9F385B9 0xEE39D7AB 0x3B124E8B
+ 0x1DC9FAF7 0x4B6D1856 0x26A36631 0xEAE397B2
+ 0x3A6EFA74 0xDD5B4332 0x6841E7F7 0xCA7820FB
+ 0xFB0AF54E 0xD8FEB397 0x454056AC 0xBA489527
+ 0x55533A3A 0x20838D87 0xFE6BA9B7 0xD096954B
+ 0x55A867BC 0xA1159A58 0xCCA92963 0x99E1DB33
+ 0xA62A4A56 0x3F3125F9 0x5EF47E1C 0x9029317C
+ 0xFDF8E802 0x04272F70 0x80BB155C 0x05282CE3
+ 0x95C11548 0xE4C66D22 0x48C1133F 0xC70F86DC
+ 0x07F9C9EE 0x41041F0F 0x404779A4 0x5D886E17
+ 0x325F51EB 0xD59BC0D1 0xF2BCC18F 0x41113564
+ 0x257B7834 0x602A9C60 0xDFF8E8A3 0x1F636C1B
+ 0x0E12B4C2 0x02E1329E 0xAF664FD1 0xCAD18115
+ 0x6B2395E0 0x333E92E1 0x3B240B62 0xEEBEB922
+ 0x85B2A20E 0xE6BA0D99 0xDE720C8C 0x2DA2F728
+ 0xD0127845 0x95B794FD 0x647D0862 0xE7CCF5F0
+ 0x5449A36F 0x877D48FA 0xC39DFD27 0xF33E8D1E
+ 0x0A476341 0x992EFF74 0x3A6F6EAB 0xF4F8FD37
+ 0xA812DC60 0xA1EBDDF8 0x991BE14C 0xDB6E6B0D
+ 0xC67B5510 0x6D672C37 0x2765D43B 0xDCD0E804
+ 0xF1290DC7 0xCC00FFA3 0xB5390F92 0x690FED0B
+ 0x667B9FFB 0xCEDB7D9C 0xA091CF0B 0xD9155EA3
+ 0xBB132F88 0x515BAD24 0x7B9479BF 0x763BD6EB
+ 0x37392EB3 0xCC115979 0x8026E297 0xF42E312D
+ 0x6842ADA7 0xC66A2B3B 0x12754CCC 0x782EF11C
+ 0x6A124237 0xB79251E7 0x06A1BBE6 0x4BFB6350
+ 0x1A6B1018 0x11CAEDFA 0x3D25BDD8 0xE2E1C3C9
+ 0x44421659 0x0A121386 0xD90CEC6E 0xD5ABEA2A
+ 0x64AF674E 0xDA86A85F 0xBEBFE988 0x64E4C3FE
+ 0x9DBC8057 0xF0F7C086 0x60787BF8 0x6003604D
+ 0xD1FD8346 0xF6381FB0 0x7745AE04 0xD736FCCC
+ 0x83426B33 0xF01EAB71 0xB0804187 0x3C005E5F
+ 0x77A057BE 0xBDE8AE24 0x55464299 0xBF582E61
+ 0x4E58F48F 0xF2DDFDA2 0xF474EF38 0x8789BDC2
+ 0x5366F9C3 0xC8B38E74 0xB475F255 0x46FCD9B9
+ 0x7AEB2661 0x8B1DDF84 0x846A0E79 0x915F95E2
+ 0x466E598E 0x20B45770 0x8CD55591 0xC902DE4C
+ 0xB90BACE1 0xBB8205D0 0x11A86248 0x7574A99E
+ 0xB77F19B6 0xE0A9DC09 0x662D09A1 0xC4324633
+ 0xE85A1F02 0x09F0BE8C 0x4A99A025 0x1D6EFE10
+ 0x1AB93D1D 0x0BA5A4DF 0xA186F20F 0x2868F169
+ 0xDCB7DA83 0x573906FE 0xA1E2CE9B 0x4FCD7F52
+ 0x50115E01 0xA70683FA 0xA002B5C4 0x0DE6D027
+ 0x9AF88C27 0x773F8641 0xC3604C06 0x61A806B5
+ 0xF0177A28 0xC0F586E0 0x006058AA 0x30DC7D62
+ 0x11E69ED7 0x2338EA63 0x53C2DD94 0xC2C21634
+ 0xBBCBEE56 0x90BCB6DE 0xEBFC7DA1 0xCE591D76
+ 0x6F05E409 0x4B7C0188 0x39720A3D 0x7C927C24
+ 0x86E3725F 0x724D9DB9 0x1AC15BB4 0xD39EB8FC
+ 0xED545578 0x08FCA5B5 0xD83D7CD3 0x4DAD0FC4
+ 0x1E50EF5E 0xB161E6F8 0xA28514D9 0x6C51133C
+ 0x6FD5C7E7 0x56E14EC4 0x362ABFCE 0xDDC6C837
+ 0xD79A3234 0x92638212 0x670EFA8E 0x406000E0
+ 0x3A39CE37 0xD3FAF5CF 0xABC27737 0x5AC52D1B
+ 0x5CB0679E 0x4FA33742 0xD3822740 0x99BC9BBE
+ 0xD5118E9D 0xBF0F7315 0xD62D1C7E 0xC700C47B
+ 0xB78C1B6B 0x21A19045 0xB26EB1BE 0x6A366EB4
+ 0x5748AB2F 0xBC946E79 0xC6A376D2 0x6549C2C8
+ 0x530FF8EE 0x468DDE7D 0xD5730A1D 0x4CD04DC6
+ 0x2939BBDB 0xA9BA4650 0xAC9526E8 0xBE5EE304
+ 0xA1FAD5F0 0x6A2D519A 0x63EF8CE2 0x9A86EE22
+ 0xC089C2B8 0x43242EF6 0xA51E03AA 0x9CF2D0A4
+ 0x83C061BA 0x9BE96A4D 0x8FE51550 0xBA645BD6
+ 0x2826A2F9 0xA73A3AE1 0x4BA99586 0xEF5562E9
+ 0xC72FEFD3 0xF752F7DA 0x3F046F69 0x77FA0A59
+ 0x80E4A915 0x87B08601 0x9B09E6AD 0x3B3EE593
+ 0xE990FD5A 0x9E34D797 0x2CF0B7D9 0x022B8B51
+ 0x96D5AC3A 0x017DA67D 0xD1CF3ED6 0x7C7D2D28
+ 0x1F9F25CF 0xADF2B89B 0x5AD6B472 0x5A88F54C
+ 0xE029AC71 0xE019A5E6 0x47B0ACFD 0xED93FA9B
+ 0xE8D3C48D 0x283B57CC 0xF8D56629 0x79132E28
+ 0x785F0191 0xED756055 0xF7960E44 0xE3D35E8C
+ 0x15056DD4 0x88F46DBA 0x03A16125 0x0564F0BD
+ 0xC3EB9E15 0x3C9057A2 0x97271AEC 0xA93A072A
+ 0x1B3F6D9B 0x1E6321F5 0xF59C66FB 0x26DCF319
+ 0x7533D928 0xB155FDF5 0x03563482 0x8ABA3CBB
+ 0x28517711 0xC20AD9F8 0xABCC5167 0xCCAD925F
+ 0x4DE81751 0x3830DC8E 0x379D5862 0x9320F991
+ 0xEA7A90C2 0xFB3E7BCE 0x5121CE64 0x774FBE32
+ 0xA8B6E37E 0xC3293D46 0x48DE5369 0x6413E680
+ 0xA2AE0810 0xDD6DB224 0x69852DFD 0x09072166
+ 0xB39A460A 0x6445C0DD 0x586CDECF 0x1C20C8AE
+ 0x5BBEF7DD 0x1B588D40 0xCCD2017F 0x6BB4E3BB
+ 0xDDA26A7E 0x3A59FF45 0x3E350A44 0xBCB4CDD5
+ 0x72EACEA8 0xFA6484BB 0x8D6612AE 0xBF3C6F47
+ 0xD29BE463 0x542F5D9E 0xAEC2771B 0xF64E6370
+ 0x740E0D8D 0xE75B1357 0xF8721671 0xAF537D5D
+ 0x4040CB08 0x4EB4E2CC 0x34D2466A 0x0115AF84
+ 0xE1B00428 0x95983A1D 0x06B89FB4 0xCE6EA048
+ 0x6F3F3B82 0x3520AB82 0x011A1D4B 0x277227F8
+ 0x611560B1 0xE7933FDC 0xBB3A792B 0x344525BD
+ 0xA08839E1 0x51CE794B 0x2F32C9B7 0xA01FBAC9
+ 0xE01CC87E 0xBCC7D1F6 0xCF0111C3 0xA1E8AAC7
+ 0x1A908749 0xD44FBD9A 0xD0DADECB 0xD50ADA38
+ 0x0339C32A 0xC6913667 0x8DF9317C 0xE0B12B4F
+ 0xF79E59B7 0x43F5BB3A 0xF2D519FF 0x27D9459C
+ 0xBF97222C 0x15E6FC2A 0x0F91FC71 0x9B941525
+ 0xFAE59361 0xCEB69CEB 0xC2A86459 0x12BAA8D1
+ 0xB6C1075E 0xE3056A0C 0x10D25065 0xCB03A442
+ 0xE0EC6E0E 0x1698DB3B 0x4C98A0BE 0x3278E964
+ 0x9F1F9532 0xE0D392DF 0xD3A0342B 0x8971F21E
+ 0x1B0A7441 0x4BA3348C 0xC5BE7120 0xC37632D8
+ 0xDF359F8D 0x9B992F2E 0xE60B6F47 0x0FE3F11D
+ 0xE54CDA54 0x1EDAD891 0xCE6279CF 0xCD3E7E6F
+ 0x1618B166 0xFD2C1D05 0x848FD2C5 0xF6FB2299
+ 0xF523F357 0xA6327623 0x93A83531 0x56CCCD02
+ 0xACF08162 0x5A75EBB5 0x6E163697 0x88D273CC
+ 0xDE966292 0x81B949D0 0x4C50901B 0x71C65614
+ 0xE6C6C7BD 0x327A140A 0x45E1D006 0xC3F27B9A
+ 0xC9AA53FD 0x62A80F00 0xBB25BFE2 0x35BDD2F6
+ 0x71126905 0xB2040222 0xB6CBCF7C 0xCD769C2B
+ 0x53113EC0 0x1640E3D3 0x38ABBD60 0x2547ADF0
+ 0xBA38209C 0xF746CE76 0x77AFA1C5 0x20756060
+ 0x85CBFE4E 0x8AE88DD8 0x7AAAF9B0 0x4CF9AA7E
+ 0x1948C25C 0x02FB8A8C 0x01C36AE4 0xD6EBE1F9
+ 0x90D4F869 0xA65CDEA0 0x3F09252D 0xC208E69F
+ 0xB74E6132 0xCE77E25B 0x578FDFE3 0x3AC372E6
+ }
+}
+
+proc ::blowfish::intEncrypt {P S xl xr} {
+ for {set i 0} {$i < 16} {incr i} {
+ set xl [expr {$xl ^ [lindex $P $i]}]
+
+ set S0a [lindex $S [expr { ($xl >> 24) & 0xff}]]
+ set S1b [lindex $S [expr {(($xl >> 16) & 0xff) + 256}]]
+ set S2c [lindex $S [expr {(($xl >> 8) & 0xff) + 512}]]
+ set S3d [lindex $S [expr { ($xl & 0xff) + 768}]]
+ set xr [expr {(((($S0a + $S1b) ^ $S2c) + $S3d) & 0xffffffff) ^ $xr}]
+
+ set temp $xl ; set xl $xr ; set xr $temp
+ }
+
+ set temp $xl ; set xl $xr ; set xr $temp
+ return [list [expr {$xl ^ [lindex $P 17]}] [expr {$xr ^ [lindex $P 16]}]]
+}
+
+proc ::blowfish::intDecrypt {P S xl xr} {
+ for {set i 17} {$i > 1} {incr i -1} {
+ set xl [expr {$xl ^ [lindex $P $i]}]
+
+ set S0a [lindex $S [expr { ($xl >> 24) & 0xff}]]
+ set S1b [lindex $S [expr {(($xl >> 16) & 0xff) + 256}]]
+ set S2c [lindex $S [expr {(($xl >> 8) & 0xff) + 512}]]
+ set S3d [lindex $S [expr { ($xl & 0xff) + 768}]]
+ set xr [expr {(((($S0a + $S1b) ^ $S2c) + $S3d) & 0xffffffff) ^ $xr}]
+
+ set temp $xl ; set xl $xr ; set xr $temp
+ }
+
+ set temp $xl ; set xl $xr ; set xr $temp
+ return [list [expr {$xl ^ [lindex $P 0]}] [expr {$xr ^ [lindex $P 1]}]]
+}
+
+proc ::blowfish::Init {mode key iv} {
+ variable ORIG_S
+ variable ORIG_P
+ variable uid
+
+ set S $ORIG_S
+ set P [list]
+
+ set kl [string length $key]
+ binary scan $key c* kc
+
+ set j 0
+ for {set i 0} {$i < 18} {incr i} {
+ set data 0
+ for {set k 0} {$k < 4} {incr k} {
+ set data [expr {(($data << 8) | ([lindex $kc $j] & 0xff)) & 0xffffffff}]
+ if {[incr j] >= $kl} {
+ set j 0
+ }
+ }
+ set OPi [lindex $ORIG_P $i]
+ lappend P [expr {$OPi ^ $data}]
+ }
+
+ set datal 0
+ set datar 0
+
+ for {set i 0} {$i < 18} {incr i} {
+ set ed [intEncrypt $P $S $datal $datar]
+ set datal [lindex $ed 0]
+ set datar [lindex $ed 1]
+ set P [lreplace $P $i [incr i] $datal $datar]
+ }
+
+ for {set i 0} {$i < 4} {incr i} {
+ for {set j 0} {$j < 256} {incr j 2} {
+ set ed [intEncrypt $P $S $datal $datar]
+ set datal [lindex $ed 0]
+ set datar [lindex $ed 1]
+ set t [expr {$i * 256 + $j}]
+ set S [lreplace $S $t [incr t] $datal $datar]
+ }
+ }
+
+ set token [namespace current]::[incr uid]
+ variable $token
+ upvar #0 $token state
+ array set state [list P $P S $S M $mode I $iv]
+ return $token
+}
+
+proc ::blowfish::Reset {token iv} {
+ upvar #0 $token state
+ set state(I) $iv
+ return
+}
+
+proc ::blowfish::Final {token} {
+ # PRAGMA: nocheck
+ variable $token
+ unset $token
+}
+
+proc ::blowfish::EncryptBlock {token block} {
+ upvar #0 $token state
+ if {[binary scan $block II xl xr] != 2} {
+ error "block must be 8 bytes"
+ }
+ set xl [expr {$xl & 0xffffffff}]
+ set xr [expr {$xr & 0xffffffff}]
+ set d [intEncrypt $state(P) $state(S) $xl $xr]
+ return [binary format I2 $d]
+}
+
+proc ::blowfish::Encrypt {Key data} {
+ upvar #0 $Key state
+ set P $state(P)
+ set S $state(S)
+ set cbc_mode [string equal "cbc" $state(M)]
+
+ if {[binary scan $state(I) II s0 s1] != 2} {
+ return -code error "invalid initialization vector: must be 8 bytes"
+ }
+
+ set len [string length $data]
+ if {($len % 8) != 0} {
+ return -code error "invalid block size: blocks must be 8 bytes"
+ }
+
+ set s0 [expr {$s0 & 0xffffffff}]
+ set s1 [expr {$s1 & 0xffffffff}]
+
+ set result ""
+ for {set i 0} {$i < $len} {incr i 8} {
+ if {[binary scan $data @[set i]II xl xr] != 2} {
+ return -code error "oops"
+ }
+ if {$cbc_mode} {
+ set xl [expr {($xl & 0xffffffff) ^ $s0}]
+ set xr [expr {($xr & 0xffffffff) ^ $s1}]
+ }
+ set d [intEncrypt $P $S $xl $xr]
+ if {$cbc_mode} {
+ set s0 [lindex $d 0]
+ set s1 [lindex $d 1]
+ }
+ append result [binary format I2 $d]
+ }
+ if {$cbc_mode} {
+ set state(I) [binary format II $s0 $s1]
+ }
+ return $result
+}
+
+proc ::blowfish::DecryptBlock {Key block} {
+ upvar #0 $Key state
+ if {[binary scan $block II xl xr] != 2} {
+ return -code error "invalid block size: block must be 8 bytes"
+ }
+ set xl [expr {$xl & 0xffffffff}]
+ set xr [expr {$xr & 0xffffffff}]
+ set d [intDecrypt $state(P) $state(S) $xl $xr]
+ return [binary format I2 $d]
+}
+
+proc ::blowfish::Decrypt {token data} {
+ upvar #0 $token state
+ set P $state(P)
+ set S $state(S)
+ set cbc_mode [string equal "cbc" $state(M)]
+
+ if {[binary scan $state(I) II s0 s1] != 2} {
+ return -code error "initialization vector must be 8 bytes"
+ }
+
+ set len [string length $data]
+ if {($len % 8) != 0} {
+ return -code error "block size invalid"
+ }
+
+ set s0 [expr {$s0 & 0xffffffff}]
+ set s1 [expr {$s1 & 0xffffffff}]
+
+ set result ""
+ for {set i 0} {$i < $len} {incr i 8} {
+ if {[binary scan $data @[set i]II xl xr] != 2} {
+ error "oops"
+ }
+ set xl [expr {$xl & 0xffffffff}]
+ set xr [expr {$xr & 0xffffffff}]
+ set d [intDecrypt $P $S $xl $xr]
+ if {$cbc_mode} {
+ set d0 [lindex $d 0]
+ set d1 [lindex $d 1]
+ set c0 [expr {$d0 ^ $s0}]
+ set c1 [expr {$d1 ^ $s1}]
+ set s0 $xl
+ set s1 $xr
+ append result [binary format II $c0 $c1]
+ } else {
+ append result [binary format I2 $d]
+ }
+ }
+ if {$cbc_mode} {
+ set state(I) [binary format II $s0 $s1]
+ }
+ return $result
+}
+
+
+# -------------------------------------------------------------------------
+# Fileevent handler for chunked file reading.
+#
+proc ::blowfish::Chunk {Key in {out {}} {chunksize 4096} {pad \0}} {
+ upvar #0 $Key state
+
+ if {[eof $in]} {
+ fileevent $in readable {}
+ set state(reading) 0
+ }
+
+ set data [read $in $chunksize]
+ # FIX ME: we should ony pad after eof
+ if {[string length $pad] > 0} {
+ set data [Pad $data 8]
+ }
+
+ if {$out == {}} {
+ append state(output) [$state(cmd) $Key $data]
+ } else {
+ puts -nonewline $out [$state(cmd) $Key $data]
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# 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 ::blowfish::LoadAccelerator {name} {
+ variable accel
+ set r 0
+ switch -exact -- $name {
+ trf {
+ if {![catch {package require Trfcrypt}]} {
+ set block [string repeat \0 8]
+ set r [expr {![catch {::blowfish -dir enc -mode ecb -key $block $block} msg]}]
+ }
+ }
+ default {
+ return -code error "invalid accelerator package:\
+ must be one of [join [array names accel] {, }]"
+ }
+ }
+ set accel($name) $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::blowfish::Hex {data} {
+ binary scan $data H* r
+ return $r
+}
+
+proc ::blowfish::SetOneOf {lst item} {
+ set ndx [lsearch -glob $lst "${item}*"]
+ if {$ndx == -1} {
+ set err [join $lst ", "]
+ return -code error "invalid mode \"$item\": must be one of $err"
+ }
+ return [lindex $lst $ndx]
+}
+
+proc ::blowfish::CheckSize {what size thing} {
+ if {[string length $thing] != $size} {
+ return -code error "invalid value for $what: must be $size bytes long"
+ }
+ return $thing
+}
+
+proc ::blowfish::CheckPad {char} {
+ if {[string length $char] > 1} {
+ return -code error "invalid value: should be a char or empty string"
+ }
+ return $char
+}
+
+proc ::blowfish::Pad {data blocksize {fill \0}} {
+ set len [string length $data]
+ if {$len == 0} {
+ set data [string repeat $fill $blocksize]
+ } elseif {($len % $blocksize) != 0} {
+ set pad [expr {$blocksize - ($len % $blocksize)}]
+ append data [string repeat $fill $pad]
+ }
+ return $data
+}
+
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::blowfish::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+proc ::blowfish::blowfish {args} {
+ variable accel
+ array set opts {-dir encrypt -mode cbc -key {} -in {} -out {} -hex 0 -pad \0}
+ set opts(-chunksize) 4096
+ set opts(-iv) [string repeat \0 8]
+ set modes {ecb cbc}
+ set dirs {encrypt decrypt}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -exact -- $option {
+ -mode { set opts(-mode) [SetOneOf $modes [Pop args 1]] }
+ -dir { set opts(-dir) [SetOneOf $dirs [Pop args 1]] }
+ -iv { set opts(-iv) [CheckSize -iv 8 [Pop args 1]] }
+ -key { set opts(-key) [Pop args 1] }
+ -in { set opts(-in) [Pop args 1] }
+ -out { set opts(-out) [Pop args 1] }
+ -chunksize { set opts(-chunksize) [Pop args 1] }
+ -hex { set opts(-hex) 1 }
+ -pad { set opts(-pad) [CheckPad [Pop args 1]] }
+ -- { Pop args; break }
+ default {
+ if {[string length $opts(-in)] == 0 && [llength $args] == 1} break
+ set err [join [lsort [array names opts]] ", "]
+ return -code error "bad option \"$option\":\
+ must be one of $err"
+ }
+ }
+ Pop args
+ }
+
+ if {$opts(-key) == {}} {
+ return -code error "no key provided: the -key option is required"
+ }
+
+ set r {}
+ if {$opts(-in) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong \# args:\
+ should be \"blowfish ?options...? -key keydata plaintext\""
+ }
+
+ set data [lindex $args 0]
+ if {[string length $opts(-pad)] > 0} {
+ set data [Pad [lindex $args 0] 8 $opts(-pad)]
+ }
+ if {$accel(trf)} {
+ set r [::blowfish -dir $opts(-dir) -mode $opts(-mode) \
+ -key $opts(-key) -iv $opts(-iv) -- $data]
+ } else {
+ set Key [Init $opts(-mode) $opts(-key) $opts(-iv)]
+ if {[string equal $opts(-dir) "encrypt"]} {
+ set r [Encrypt $Key $data]
+ } else {
+ set r [Decrypt $Key $data]
+ }
+ Final $Key
+ }
+
+ if {$opts(-out) != {}} {
+ puts -nonewline $opts(-out) $r
+ set r {}
+ }
+
+ } else {
+
+ if {[llength $args] != 0} {
+ return -code error "wrong \# args:\
+ should be \"blowfish ?options...? -key keydata -in channel\""
+ }
+
+ set Key [Init $opts(-mode) $opts(-key) $opts(-iv)]
+ upvar $Key state
+ set state(reading) 1
+ if {[string equal $opts(-dir) "encrypt"]} {
+ set state(cmd) Encrypt
+ } else {
+ set state(cmd) Decrypt
+ }
+ set state(output) ""
+ fileevent $opts(-in) readable \
+ [list [namespace origin Chunk] \
+ $Key $opts(-in) $opts(-out) $opts(-chunksize) $opts(-pad)]
+ if {[info commands ::tkwait] != {}} {
+ tkwait variable [subst $Key](reading)
+ } else {
+ vwait [subst $Key](reading)
+ }
+ if {$opts(-out) == {}} {
+ set r $state(output)
+ }
+ Final $Key
+
+ }
+
+ if {$opts(-hex)} {
+ set r [Hex $r]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::blowfish {
+ variable e {}
+ foreach e {trf} {
+ if {[LoadAccelerator $e]} break
+ }
+ unset e
+}
+
+package provide blowfish 1.0.4
+
+# -------------------------------------------------------------------------
+#
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/blowfish/blowfish.test b/tcllib/modules/blowfish/blowfish.test
new file mode 100644
index 0000000..a09e91d
--- /dev/null
+++ b/tcllib/modules/blowfish/blowfish.test
@@ -0,0 +1,315 @@
+# blowfish.test - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sf.net>
+#
+# $Id: blowfish.test,v 1.11 2007/09/17 14:19:07 patthoyts Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal blowfish.tcl blowfish
+}
+
+# -------------------------------------------------------------------------
+# Handle multiple implementation testing
+#
+array set preserve [array get ::blowfish::accel]
+
+proc implementations {} {
+ variable ::blowfish::accel
+ foreach {a v} [array get accel] {if {$v} {lappend r $a}}
+ lappend r tcl; set r
+}
+
+proc select_implementation {impl} {
+ variable ::blowfish::accel
+ foreach e [array names accel] { set accel($e) 0 }
+ if {[string compare "tcl" $impl] != 0} {
+ set accel($impl) 1
+ }
+}
+
+proc reset_implementation {} {
+ variable ::blowfish::accel
+ array set accel [array get ::preserve]
+}
+
+# -------------------------------------------------------------------------
+# Report versions
+#
+if {[::blowfish::LoadAccelerator trf]} {
+ puts "> Trf based"
+}
+puts "> pure Tcl"
+
+# -------------------------------------------------------------------------
+# Now the package specific tests....
+# -------------------------------------------------------------------------
+
+# -------------------------------------------------------------------------
+
+#test blowfish-1.0 {blowfish basic command options} {
+# list [catch {::blowfish::blowfish} msg] \
+# [string match "wrong # args*" $msg]
+#
+#} {1 1}
+
+# -------------------------------------------------------------------------
+
+# Test vectors from http://www.schneier.com/code/vectors.txt
+
+set vectors {
+ 0000000000000000 0000000000000000 4EF997456198DD78
+ FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF 51866FD5B85ECB8A
+ 3000000000000000 1000000000000001 7D856F9A613063F2
+ 1111111111111111 1111111111111111 2466DD878B963C9D
+ 0123456789ABCDEF 1111111111111111 61F9C3802281B096
+ 1111111111111111 0123456789ABCDEF 7D0CC630AFDA1EC7
+ 0000000000000000 0000000000000000 4EF997456198DD78
+ FEDCBA9876543210 0123456789ABCDEF 0ACEAB0FC6A0A28D
+ 7CA110454A1A6E57 01A1D6D039776742 59C68245EB05282B
+ 0131D9619DC1376E 5CD54CA83DEF57DA B1B8CC0B250F09A0
+ 07A1133E4A0B2686 0248D43806F67172 1730E5778BEA1DA4
+ 3849674C2602319E 51454B582DDF440A A25E7856CF2651EB
+ 04B915BA43FEB5B6 42FD443059577FA2 353882B109CE8F1A
+ 0113B970FD34F2CE 059B5E0851CF143A 48F4D0884C379918
+ 0170F175468FB5E6 0756D8E0774761D2 432193B78951FC98
+ 43297FAD38E373FE 762514B829BF486A 13F04154D69D1AE5
+ 07A7137045DA2A16 3BDD119049372802 2EEDDA93FFD39C79
+ 04689104C2FD3B2F 26955F6835AF609A D887E0393C2DA6E3
+ 37D06BB516CB7546 164D5E404F275232 5F99D04F5B163969
+ 1F08260D1AC2465E 6B056E18759F5CCA 4A057A3B24D3977B
+ 584023641ABA6176 004BD6EF09176062 452031C1E4FADA8E
+ 025816164629B007 480D39006EE762F2 7555AE39F59B87BD
+ 49793EBC79B3258F 437540C8698F3CFA 53C55F9CB49FC019
+ 4FB05E1515AB73A7 072D43A077075292 7A8E7BFA937E89A3
+ 49E95D6D4CA229BF 02FE55778117F12A CF9C5D7A4986ADB5
+ 018310DC409B26D6 1D9D5C5018F728C2 D1ABB290658BC778
+ 1C587F1C13924FEF 305532286D6F295A 55CB3774D13EF201
+ 0101010101010101 0123456789ABCDEF FA34EC4847B268B2
+ 1F1F1F1F0E0E0E0E 0123456789ABCDEF A790795108EA3CAE
+ E0FEE0FEF1FEF1FE 0123456789ABCDEF C39E072D9FAC631D
+ 0000000000000000 FFFFFFFFFFFFFFFF 014933E0CDAFF6E4
+ FFFFFFFFFFFFFFFF 0000000000000000 F21E9A77B71C49BC
+ 0123456789ABCDEF 0000000000000000 245946885754369A
+ FEDCBA9876543210 FFFFFFFFFFFFFFFF 6B5C5A9C5D9E0A5A
+}
+
+set n 0
+foreach impl [implementations] {
+ select_implementation $impl
+ foreach {key plain cipher} $vectors {
+ test blowfish-$impl-2.$n "blowfish ecb test vector $n (impl $impl)" {
+ list [catch {
+ string toupper \
+ [::blowfish::Hex \
+ [::blowfish::blowfish -mode ecb -dir enc \
+ -key [binary format H* $key] \
+ [binary format H* $plain]]]
+ } msg] $msg
+ } [list 0 $cipher]
+ incr n
+ }
+ reset_implementation
+}
+
+set vectors {
+ F9AD597C49DB005E F0
+ E91D21C1D961A6D6 F0E1
+ E9C2B70A1BC65CF3 F0E1D2
+ BE1E639408640F05 F0E1D2C3
+ B39E44481BDB1E6E F0E1D2C3B4
+ 9457AA83B1928C0D F0E1D2C3B4A5
+ 8BB77032F960629D F0E1D2C3B4A596
+ E87A244E2CC85E82 F0E1D2C3B4A59687
+ 15750E7A4F4EC577 F0E1D2C3B4A5968778
+ 122BA70B3AB64AE0 F0E1D2C3B4A596877869
+ 3A833C9AFFC537F6 F0E1D2C3B4A5968778695A
+ 9409DA87A90F6BF2 F0E1D2C3B4A5968778695A4B
+ 884F80625060B8B4 F0E1D2C3B4A5968778695A4B3C
+ 1F85031C19E11968 F0E1D2C3B4A5968778695A4B3C2D
+ 79D9373A714CA34F F0E1D2C3B4A5968778695A4B3C2D1E
+ 93142887EE3BE15C F0E1D2C3B4A5968778695A4B3C2D1E0F
+ 03429E838CE2D14B F0E1D2C3B4A5968778695A4B3C2D1E0F00
+ A4299E27469FF67B F0E1D2C3B4A5968778695A4B3C2D1E0F0011
+ AFD5AED1C1BC96A8 F0E1D2C3B4A5968778695A4B3C2D1E0F001122
+ 10851C0E3858DA9F F0E1D2C3B4A5968778695A4B3C2D1E0F00112233
+ E6F51ED79B9DB21F F0E1D2C3B4A5968778695A4B3C2D1E0F0011223344
+ 64A6E14AFD36B46F F0E1D2C3B4A5968778695A4B3C2D1E0F001122334455
+ 80C7D7D45A5479AD F0E1D2C3B4A5968778695A4B3C2D1E0F00112233445566
+ 05044B62FA52D080 F0E1D2C3B4A5968778695A4B3C2D1E0F0011223344556677
+}
+
+set plain [binary format H* FEDCBA9876543210]
+foreach impl [implementations] {
+ select_implementation $impl
+ set n 0
+ foreach {cipher key} $vectors {
+ test blowfish-$impl-4.$n "blowfish ecb test variable length key (impl $impl)" {
+ list [catch {
+ string toupper \
+ [::blowfish::Hex \
+ [::blowfish::blowfish \
+ -mode ecb \
+ -dir enc \
+ -key [binary format H* $key] \
+ $plain]]
+ } msg] $msg
+ } [list 0 $cipher]
+ incr n
+ }
+ reset_implementation
+}
+
+set key [binary format H* 0123456789ABCDEFF0E1D2C3B4A59687]
+set iv [binary format H* FEDCBA9876543210]
+set plain [binary format H* \
+ 37363534333231204E6F77206973207468652074696D6520666F722000000000]
+
+foreach impl [implementations] {
+ select_implementation $impl
+ test blowfish-$impl-6.1 "blowfish cbc mode (impl $impl)" {
+ list [catch {
+ string toupper \
+ [::blowfish::Hex \
+ [::blowfish::blowfish \
+ -dir enc \
+ -mode cbc \
+ -iv $iv \
+ -key $key \
+ $plain]]
+ } msg] $msg
+ } [list 0 \
+ 6B77B4D63006DEE605B156E27403979358DEB9E7154616D959F1652BD5FF92CC]
+ reset_implementation
+}
+
+#cfb E73214A2822139CAF26ECF6D2EB9E76E3DA3DE04D1517200519D57A6C3
+#ofb E73214A2822139CA62B343CC5B65587310DD908D0C241B2263C2CF80DA
+
+foreach impl [implementations] {
+ select_implementation $impl
+
+ test blowfish-$impl-7.1 {test reset of initialization vector on cbc mode} {
+ list [catch {
+ set iv [string repeat \x00 8]
+ set pt "01234567abcdefgh01234567"
+ set tok [blowfish::Init cbc secret $iv]
+ set ct1 [blowfish::Encrypt $tok $pt]
+ blowfish::Reset $tok $iv
+ set ct2 [blowfish::Encrypt $tok $pt]
+ blowfish::Final $tok
+ string equal $ct1 $ct2
+ } msg] $msg
+ } {0 1}
+
+ test blowfish-$impl-7.2 {test reset of initialization vector on cbc mode} {
+ list [catch {
+ set pt "01234567abcdefgh01234567"
+ set tok [blowfish::Init cbc secret [string repeat \x00 8]]
+ set ct1 [blowfish::Encrypt $tok $pt]
+ blowfish::Reset $tok [string repeat \x01 8]
+ set ct2 [blowfish::Encrypt $tok $pt]
+ blowfish::Final $tok
+ string equal $ct1 $ct2
+ } msg] $msg
+ } {0 0}
+
+ test blowfish-$impl-8.0 {check hyphen in crypt data} {
+ list [catch {
+ set key "uP/AD/oGb6q/"
+ set text "ececho cleardata"
+ set cipher [blowfish::blowfish -mode ecb -key $key -dir encrypt $text]
+ set plain [blowfish::blowfish -mode ecb -key $key -dir decrypt $cipher]
+ string compare $plain $text
+ } msg] $msg
+ } {0 0}
+
+ test blowfish-$impl-8.1 {check hyphen in plaintext} {
+ list [catch {
+ set key "uP/AD/oGb6q/"
+ set text "-cecho cleardata"
+ set cipher [blowfish::blowfish -mode ecb -key $key -dir encrypt $text]
+ set plain [blowfish::blowfish -mode ecb -key $key -dir decrypt $cipher]
+ string compare $plain $text
+ } msg] $msg
+ } {0 0}
+
+ test blowfish-$impl-8.2 {check hyphen in key} {
+ list [catch {
+ set key "-P/AD/oGb6q/"
+ set text "ececho cleardata"
+ set cipher [blowfish::blowfish -mode ecb -key $key -dir encrypt $text]
+ set plain [blowfish::blowfish -mode ecb -key $key -dir decrypt $cipher]
+ string compare $plain $text
+ } msg] $msg
+ } {0 0}
+
+ test blowfish-$impl-8.3 {check option termination} {
+ list [catch {
+ set key "uP/AD/oGb6q/"
+ set text "ececho cleardata"
+ set cipher [blowfish::blowfish -mode ecb -key $key -dir encrypt -- $text]
+ set plain [blowfish::blowfish -mode ecb -key $key -dir decrypt -- $cipher]
+ string compare $plain $text
+ } msg] $msg
+ } {0 0}
+
+ test blowfish-$impl-9.0 {check -pad option} {
+ list [catch {
+ set key "uP/AD/oGb6q/"
+ set text "01234"
+ set cipher [blowfish::blowfish -mode ecb -hex -key $key \
+ -dir encrypt -pad a -- $text]
+ } msg] $msg
+ } {0 8927243c2d7d568c}
+
+ test blowfish-$impl-9.1 {check -pad option} {
+ list [catch {
+ set key "uP/AD/oGb6q/"
+ set text "01234"
+ set cipher [blowfish::blowfish -mode ecb -hex -key $key \
+ -dir encrypt -pad { } -- $text]
+ } msg] $msg
+ } {0 3fc711286b8eca79}
+
+ test blowfish-$impl-9.2 {check -pad option} {
+ list [catch {
+ set key "uP/AD/oGb6q/"
+ set text "01234"
+ set cipher [blowfish::blowfish -mode ecb -hex -key $key \
+ -dir encrypt -pad "" -- $text]
+ } msg] \
+ [expr {
+ [string equal $msg \
+ {invalid block size: blocks must be 8 bytes}] \
+ || [string equal $msg \
+ {can not encrypt incomplete block at end of input}]}]
+ } {1 1}
+
+ test blowfish-$impl-9.3 {check -dir option default is encrypt} {
+ list [catch {
+ set key "04B915BA43FEB5B6"
+ set text "42FD443059577FA2"
+ set cipher [blowfish::blowfish -mode ecb -pad "" -hex\
+ -key [binary format H* $key]\
+ -- [binary format H* $text]]
+ } msg] $msg
+ } {0 353882b109ce8f1a}
+
+ reset_implementation
+}
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/blowfish/pkgIndex.tcl b/tcllib/modules/blowfish/pkgIndex.tcl
new file mode 100644
index 0000000..d9db123
--- /dev/null
+++ b/tcllib/modules/blowfish/pkgIndex.tcl
@@ -0,0 +1,5 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ # PRAGMA: returnok
+ return
+}
+package ifneeded blowfish 1.0.4 [list source [file join $dir blowfish.tcl]]
diff --git a/tcllib/modules/cache/ChangeLog b/tcllib/modules/cache/ChangeLog
new file mode 100644
index 0000000..d043e6a
--- /dev/null
+++ b/tcllib/modules/cache/ChangeLog
@@ -0,0 +1,52 @@
+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-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-11-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * async.tcl: Moved the cleanup of state regarding pending
+ * async.man: callbacks in the notification methods forward
+ * pkgIndex.tcl: to ensure consistent internal state in case of
+ recursive call to set method by the callbacks. Also added guard
+ in 'set' to avoid multiple sets for identical values. Bumped to
+ version 0.3.
+
+2008-11-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * async.tcl (exists): Added method querying the cache about
+ knowledge of a key. Fixed handling of provider command
+ prefix. Bumped version to 0.2.
+
+2008-11-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * async.man: New module 'cache', containing the new package
+ * async.tcl: 'cache::async'.
+ * async.test:
+ * pkgIndex.tcl:
+
diff --git a/tcllib/modules/cache/async.man b/tcllib/modules/cache/async.man
new file mode 100644
index 0000000..7672c7b
--- /dev/null
+++ b/tcllib/modules/cache/async.man
@@ -0,0 +1,143 @@
+[manpage_begin cache::async n 0.3]
+[keywords asynchronous]
+[keywords cache]
+[keywords callback]
+[keywords synchronous]
+[copyright {2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {In-memory caches}]
+[titledesc {Asynchronous in-memory cache}]
+[require Tcl 8.4]
+[require cache::async [opt 0.3]]
+[description]
+
+This package provides objects which cache data in memory, and operate
+asynchronously with regard to request and responses. The objects are
+agnostic with regard to cache keys and values, and unknown methods are
+delegated to the provider of cached data. These two properties make it
+easy to use caches as a facade for any data provider.
+
+[section API]
+
+The package exports a class, [class cache::async], as specified
+below.
+
+[list_begin definitions]
+
+[call [cmd ::cache::async] [arg objectName] [arg commandprefix] [opt [arg options]...]]
+
+The command creates a new [term cache] object with an associated
+global Tcl command whose name is [arg objectName]. This command may
+be used to invoke various operations on the object.
+
+[para]
+
+The [arg commandprefix] is the action to perform when an user asks for
+data in the cache and the cache doesn't yet know about the key. When
+run the commandprefix is given three additional arguments, the string
+[const get], the key requested, and the cache object itself, in the
+form of its object command, in this order. The execution of the action
+is done in an idle-handler, decoupling it from the original request.
+
+[para]
+
+The only supported option is
+
+[list_begin options]
+[opt_def -full-async-results]
+
+This option defines the behaviour of the cache for when requested keys
+are known to the cache at the time of [method get] request. By default
+such requeste are responded to asynchronously as well. Setting this
+option to [const false] forces the cache to respond to them
+synchronuously, although still through the specified callback.
+
+[list_end]
+[list_end]
+
+The object commands created by the class commands above have
+the form:
+
+[list_begin definitions]
+
+[call [arg objectName] [method get] [arg key] [arg donecmdprefix]]
+
+This method requests the data for the [arg key] from the cache. If the
+data is not yet known the command prefix specified during construction
+of the cache object is used to ask for this information.
+
+[para]
+
+Whenever the information is/becomes available the [arg donecmdprefix]
+will be run to transfer the result to the caller. This command prefix
+is invoked with either 2 or 3 arguments, i.e.
+
+[list_begin enum]
+[enum] The string [const set], the [arg key], and the value.
+[enum] The string [const unset], and the [arg key].
+[list_end]
+
+These two possibilities are used to either signal the value for the
+[arg key], or that the [arg key] has no value defined for it. The
+latter is distinct from the cache not knowing about the [arg key].
+
+[para]
+
+For a cache object configured to be fully asynchronous (default) the
+[arg donecmdprefix] is always run in an idle-handler, decoupling it
+from the request. Otherwise the callback will be invoked synchronously
+when the [arg key] is known to the cache at the time of the
+invokation.
+
+[para]
+
+Another important part of the cache's behaviour, as it is asynchronous
+it is possible that multiple [method get] requests are issued for the
+same [arg key] before it can respond. In that case the cache will
+issue only one data request to the provider, for the first of these,
+and suspend the others, and then notify all of them when the data
+becomes available.
+
+[call [arg objectName] [method set] [arg key] [arg value]]
+[call [arg objectName] [method unset] [arg key]]
+
+These two methods are provided to allow users of the cache to make
+keys known to the cache, as either having a [arg value], or as
+undefined.
+
+[para]
+
+It is expected that the data provider (see [arg commandprefix] of the
+constructor) uses them in response to data requests for unknown keys.
+
+[para]
+
+Note how this matches the cache's own API towards its caller, calling
+the [arg donecmd] of [method get]-requests issued to itself with
+either "set key value" or "unset key", versus issuing
+[method get]-requests to its own provider with itself in the place of
+the [arg donecmd], expecting to be called with either "set key value"
+or "unset key".
+
+[para]
+
+This also means that these methods invoke the [arg donecmd] of all
+[method get]-requests waiting for information about the modified
+[arg key].
+
+[call [arg objectName] [method exists] [arg key]]
+
+This method queries the cache for knowledge about the [arg key] and
+returns a boolean value. The result is [const true] if the key is
+known, and [const false] otherwise.
+
+[call [arg objectName] [method clear] [opt [arg key]]]
+
+This method resets the state of either the specified [arg key] or of
+all keys known to the cache, making it unkown. This forces future
+[method get]-requests to reload the information from the provider.
+
+[list_end]
+
+[vset CATEGORY cache]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/cache/async.tcl b/tcllib/modules/cache/async.tcl
new file mode 100644
index 0000000..e6c866a
--- /dev/null
+++ b/tcllib/modules/cache/async.tcl
@@ -0,0 +1,185 @@
+## -*- tcl -*-
+# ### ### ### ######### ######### #########
+
+# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# Aynchronous in-memory cache. Queries of the cache generate
+# asynchronous requests for data for unknown parts, with asynchronous
+# result return. Data found in the cache may return fully asynchronous
+# as well, or semi-synchronous. The latter meaning that the regular
+# callbacks are used, but invoked directly, and not decoupled through
+# events. The cache can be pre-filled synchronously.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.4 ; #
+package require snit ; #
+
+# ### ### ### ######### ######### #########
+##
+
+snit::type cache::async {
+
+ # ### ### ### ######### ######### #########
+ ## Unknown methods and options are forwared to the object actually
+ ## providing the cached data, making the cache a proper facade for
+ ## it.
+
+ delegate method * to myprovider
+ delegate option * to myprovider
+
+ # ### ### ### ######### ######### #########
+ ## API
+
+ option -full-async-results -default 1 -type snit::boolean
+
+ constructor {provider args} {
+ set myprovider $provider
+ $self configurelist $args
+ return
+ }
+
+ method get {key donecmd} {
+ # Register request
+ lappend mywaiting($key) $donecmd
+
+ # Check if the request can be satisfied from the cache. If yes
+ # then that is done.
+
+ if {[info exists mymiss($key)]} {
+ $self NotifyUnset 1 $key
+ return
+ } elseif {[info exists myhit($key)]} {
+ $self NotifySet 1 $key
+ return
+ }
+
+ # We have to ask our provider if there is data or
+ # not. however, if a request for this key is already in flight
+ # then we have to do nothing more. Our registration at the
+ # beginning ensures that we will get notified when the
+ # requested information comes back.
+
+ if {[llength $mywaiting($key)] > 1} return
+
+ # This is the first query for this key, ask the provider.
+
+ after idle [linsert $myprovider end get $key $self]
+ return
+ }
+
+ method clear {args} {
+ # Note: This method cannot interfere with async queries caused
+ # by 'get' invokations. If the data is present, and now
+ # removed, all 'get' invokations before this call were
+ # satisfied from the cache and only invokations coming after
+ # it can trigger async queries of the provider. If the data is
+ # not present the state will not change, and queries in flight
+ # simply refill the cache as they would do anyway without the
+ # 'clear'.
+
+ if {![llength $args]} {
+ array unset myhit *
+ array unset mymiss *
+ } elseif {[llength $arg] == 1} {
+ set key [lindex $args 0]
+ unset -nocomplain myhit($key)
+ unset -nocomplain mymiss($key)
+ } else {
+ WrongArgs ?key?
+ }
+ return
+ }
+
+ method exists {key} {
+ return [expr {[info exists myhit($key)] || [info exists mymiss($key)]}]
+ }
+
+ method set {key value} {
+ # Add data to the cache, and notify all outstanding queries.
+ # Nothing is done if the key is already known and has the same
+ # value.
+
+ # This is the method invoked by the provider in response to
+ # queries, and also the method to use to prefill the cache
+ # with data.
+
+ if {
+ [info exists myhit($key)] &&
+ ($value eq $myhit($key))
+ } return
+
+ set myhit($key) $value
+ unset -nocomplain mymiss($key)
+ $self NotifySet 0 $key
+ return
+ }
+
+ method unset {key} {
+ # Add hole to the cache, and notify all outstanding queries.
+ # This is the method invoked by the provider in response to
+ # queries, and also the method to use to prefill the cache
+ # with holes.
+ unset -nocomplain myhit($key)
+ set mymiss($key) .
+ $self NotifyUnset 0 $key
+ return
+ }
+
+ method NotifySet {found key} {
+ if {![info exists mywaiting($key)] || ![llength $mywaiting($key)]} return
+
+ set pending $mywaiting($key)
+ unset mywaiting($key)
+
+ set value $myhit($key)
+ if {$found && !$options(-full-async-results)} {
+ foreach donecmd $pending {
+ uplevel \#0 [linsert $donecmd end set $key $value]
+ }
+ } else {
+ foreach donecmd $pending {
+ after idle [linsert $donecmd end set $key $value]
+ }
+ }
+ return
+ }
+
+ method NotifyUnset {found key} {
+ if {![info exists mywaiting($key)] || ![llength $mywaiting($key)]} return
+
+ set pending $mywaiting($key)
+ unset mywaiting($key)
+
+ if {$found && !$options(-full-async-results)} {
+ foreach donecmd $pending {
+ uplevel \#0 [linsert $donecmd end unset $key]
+ }
+ } else {
+ foreach donecmd $pending {
+ after idle [linsert $donecmd end unset $key]
+ }
+ }
+ return
+ }
+
+ proc WrongArgs {expected} {
+ return -code error "wrong#args: Expected $expected"
+ }
+
+ # ### ### ### ######### ######### #########
+ ## State
+
+ variable myprovider ; # Command prefix providing the data to cache.
+ variable myhit -array {} ; # Cache array mapping keys to values.
+ variable mymiss -array {} ; # Cache array mapping keys to holes.
+ variable mywaiting -array {} ; # Map of keys pending to notifier commands.
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide cache::async 0.3
diff --git a/tcllib/modules/cache/async.test b/tcllib/modules/cache/async.test
new file mode 100644
index 0000000..f904413
--- /dev/null
+++ b/tcllib/modules/cache/async.test
@@ -0,0 +1,230 @@
+# -*- tcl -*-
+# Tests for the cache::async module.
+#
+# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: async.test,v 1.1 2008/11/19 06:04:59 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+testing {
+ useLocal async.tcl cache::async
+}
+
+# -------------------------------------------------------------------------
+# Helper commands
+
+proc DATA_NONE {method key cmd} {
+ res+ DATA_NONE $method $key $cmd
+ set ::wait .
+ return -code error "Should not be called"
+}
+
+proc DATA_VALUE {method key cmd} {
+ res+ DATA_VALUE $method $key $cmd
+ eval [linsert $cmd end set $key ALPHA]
+ return
+}
+
+proc DATA_HOLE {method key cmd} {
+ res+ DATA_HOLE $method $key $cmd
+ eval [linsert $cmd end unset $key]
+ return
+}
+
+proc DONE {args} {
+ res+ DONE $args
+ set ::wait .
+ return
+}
+
+proc WAIT {} {
+ res+ WAIT
+ vwait ::wait
+ res+ RESUME
+}
+
+# -------------------------------------------------------------------------
+
+test cache-async-1.0 {preset value} -setup {
+ cache::async ca DATA_NONE
+ ca set KEY VALUE
+ res!
+} -body {
+ res+ BEGIN
+ ca get KEY DONE
+ WAIT
+ res?lines
+} -cleanup {
+ ca destroy
+} -result {BEGIN
+WAIT
+DONE {set KEY VALUE}
+RESUME}
+
+test cache-async-1.1 {preset hole} -setup {
+ cache::async ca DATA_NONE
+ ca unset KEY
+ res!
+} -body {
+ res+ BEGIN
+ ca get KEY DONE
+ WAIT
+ res?lines
+} -cleanup {
+ ca destroy
+} -result {BEGIN
+WAIT
+DONE {unset KEY}
+RESUME}
+
+# -------------------------------------------------------------------------
+
+test cache-async-2.0 {provider value} -setup {
+ cache::async ca DATA_VALUE
+ res!
+} -body {
+ res+ BEGIN
+ ca get KEY DONE
+ WAIT
+ res?lines
+} -cleanup {
+ ca destroy
+} -result {BEGIN
+WAIT
+DATA_VALUE get KEY ::ca
+DONE {set KEY ALPHA}
+RESUME}
+
+test cache-async-2.1 {provider hole} -setup {
+ cache::async ca DATA_HOLE
+ res!
+} -body {
+ res+ BEGIN
+ ca get KEY DONE
+ WAIT
+ res?lines
+} -cleanup {
+ ca destroy
+} -result {BEGIN
+WAIT
+DATA_HOLE get KEY ::ca
+DONE {unset KEY}
+RESUME}
+
+# -------------------------------------------------------------------------
+
+test cache-async-3.0 {provider value, multi request merge} -setup {
+ cache::async ca DATA_VALUE
+ res!
+} -body {
+ res+ BEGIN
+ ca get KEY DONE
+ ca get KEY DONE
+ ca get KEY DONE
+ WAIT
+ res?lines
+} -cleanup {
+ ca destroy
+} -result {BEGIN
+WAIT
+DATA_VALUE get KEY ::ca
+DONE {set KEY ALPHA}
+DONE {set KEY ALPHA}
+DONE {set KEY ALPHA}
+RESUME}
+
+test cache-async-3.1 {provider hole, multi request merge} -setup {
+ cache::async ca DATA_HOLE
+ res!
+} -body {
+ res+ BEGIN
+ ca get KEY DONE
+ ca get KEY DONE
+ ca get KEY DONE
+ WAIT
+ res?lines
+} -cleanup {
+ ca destroy
+} -result {BEGIN
+WAIT
+DATA_HOLE get KEY ::ca
+DONE {unset KEY}
+DONE {unset KEY}
+DONE {unset KEY}
+RESUME}
+
+# -------------------------------------------------------------------------
+
+test cache-async-4.0 {preset value, sync return on hit} -setup {
+ cache::async ca DATA_NONE -full-async-results 0
+ ca set KEY VALUE
+ res!
+} -body {
+ res+ BEGIN
+ ca get KEY DONE
+ res?lines
+} -cleanup {
+ ca destroy
+} -result {BEGIN
+DONE {set KEY VALUE}}
+
+test cache-async-4.1 {preset hole, sync return on hit} -setup {
+ cache::async ca DATA_NONE -full-async-results 0
+ ca unset KEY
+ res!
+} -body {
+ res+ BEGIN
+ ca get KEY DONE
+ res?lines
+} -cleanup {
+ ca destroy
+} -result {BEGIN
+DONE {unset KEY}}
+
+# -------------------------------------------------------------------------
+
+test cache-async-5.0 {provider value, stays async} -setup {
+ cache::async ca DATA_VALUE -full-async-results 0
+ res!
+} -body {
+ res+ BEGIN
+ ca get KEY DONE
+ WAIT
+ res?lines
+} -cleanup {
+ ca destroy
+} -result {BEGIN
+WAIT
+DATA_VALUE get KEY ::ca
+DONE {set KEY ALPHA}
+RESUME}
+
+test cache-async-5.1 {provider hole, stays async} -setup {
+ cache::async ca DATA_HOLE -full-async-results 0
+ res!
+} -body {
+ res+ BEGIN
+ ca get KEY DONE
+ WAIT
+ res?lines
+} -cleanup {
+ ca destroy
+} -result {BEGIN
+WAIT
+DATA_HOLE get KEY ::ca
+DONE {unset KEY}
+RESUME}
+
+# -------------------------------------------------------------------------
+testsuiteCleanup
diff --git a/tcllib/modules/cache/pkgIndex.tcl b/tcllib/modules/cache/pkgIndex.tcl
new file mode 100644
index 0000000..0840786
--- /dev/null
+++ b/tcllib/modules/cache/pkgIndex.tcl
@@ -0,0 +1,3 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded cache::async 0.3 [list source [file join $dir async.tcl]]
+
diff --git a/tcllib/modules/calendar/ChangeLog b/tcllib/modules/calendar/ChangeLog
new file mode 100644
index 0000000..e857f56
--- /dev/null
+++ b/tcllib/modules/calendar/ChangeLog
@@ -0,0 +1,109 @@
+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-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 ========================
+ *
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-01-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * gregorian.test: Hooked into the new common test support
+ code. Also removed some gratuitous output cluttering the log,
+ see [SF Tcllib Bug 1316032].
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl:
+ * gregorian.tcl: Fixed bug #614591. Set version of the package to
+ 0.2
+
+2002-02-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * gregorian.tcl: Frink run.
+
+2002-01-14 Kevin Kenny <kennykb@users.sourceforge.net>
+
+ * gregorian.tcl, gregorian.test (EYMWDToJulianDay):
+ Added functionality for 'Nth weekday from the end of a month',
+ needed, among other things, to do DST rules in most US locales.
+
+2002-01-11 Kevin Kenny <kennykb@users.sourceforge.net>
+
+ * ChangeLog, calendar.tcl, gregorian.tcl, gregorian.test:
+ * pkgIndex.tcl, tclIndex:
+ Created an initial 'calendar' module. Functionality at this
+ point includes conversion between Julian Day and several formats:
+ year/day-of-year, year/month/day, year/week/day-of-week, and
+ year/month/day-of-week-in-month (e.g, the second Friday of
+ February).
diff --git a/tcllib/modules/calendar/calendar.tcl b/tcllib/modules/calendar/calendar.tcl
new file mode 100644
index 0000000..8f6f803
--- /dev/null
+++ b/tcllib/modules/calendar/calendar.tcl
@@ -0,0 +1,18 @@
+#----------------------------------------------------------------------
+#
+# calendar.tcl --
+#
+# This file is the main 'package provide' script for the
+# 'calendar' package. The package provides various commands for
+# manipulating dates and times.
+
+package require Tcl 8.2
+
+namespace eval ::calendar {
+ variable home [file join [pwd] [file dirname [info script]]]
+ if { [lsearch -exact $::auto_path $home] == -1 } {
+ lappend ::auto_path $home
+ }
+
+ package provide [namespace tail [namespace current]] 0.2
+}
diff --git a/tcllib/modules/calendar/gregorian.tcl b/tcllib/modules/calendar/gregorian.tcl
new file mode 100644
index 0000000..dc9bf1c
--- /dev/null
+++ b/tcllib/modules/calendar/gregorian.tcl
@@ -0,0 +1,772 @@
+#----------------------------------------------------------------------
+#
+# gregorian.tcl --
+#
+# Routines for manipulating dates on the Gregorian calendar.
+#
+# Copyright (c) 2002 by Kevin B. Kenny. All rights reserved.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: gregorian.tcl,v 1.5 2004/01/15 06:36:12 andreas_kupries Exp $
+#
+#----------------------------------------------------------------------
+
+package require Tcl 8.2; # Not tested with earlier releases
+
+#----------------------------------------------------------------------
+#
+# Many of the routines in this file accept the name of a "date array"
+# in the caller's scope. This array is used to hold the various fields
+# of a civil date. While few if any routines use or set all the fields,
+# the fields, where used or set, are always interpreted the same way.
+# The complete listing of fields used is:
+#
+# ERA -- The era in the given calendar to which a year refers.
+# In the Julian and Gregorian calendars, the ERA is one
+# of the constants, BCE or CE (Before the Common Era,
+# or Common Era). The conventional names, BC and AD
+# are also accepted. In other local calendars, the ERA
+# may be some other value, for instance, the name of
+# an emperor, AH (anno Hegirae or anno Hebraica), AM
+# (anno mundi), etc.
+#
+# YEAR - The number of the year within the given era.
+#
+# FISCAL_YEAR - The year to which 'WEEK_OF_YEAR' (see below)
+# refers. Near the beginning or end of a given
+# calendar year, the fiscal week may be the first
+# week of the following year or the last week of the
+# preceding year.
+#
+# MONTH - The number of the month within the given year. Month
+# numbers run from 1 to 12 in the common calendar; some
+# local calendars include a thirteenth month in some years.
+#
+# WEEK_OF_YEAR - The week number in the given year. On the usual
+# fiscal calendar, the week may range from 1 to 53.
+#
+# DAY_OF_WEEK_IN_MONTH - The ordinal number of a weekday within
+# the given month. Used in conjunction
+# with DAY_OF_WEEK to express constructs like,
+# 'the fourth Thursday in November'.
+# Values run from 1 to the number of weeks in
+# the month. Negative values are interpreted
+# from the end of the month; allowing
+# for 'the last Sunday of October'; 'the
+# next-to-last Sunday of October', etc.
+#
+# DAY_OF_YEAR - The day of the given year. (The first day of a year
+# is day number 1.)
+#
+# DAY_OF_MONTH - The day of the given month.
+#
+# DAY_OF_WEEK - The number of the day of the week. Sunday = 0,
+# Monday = 1, ..., Saturday = 6. In locales where
+# a day other than Sunday is the first day of the week,
+# the values of the days before it are incremented by
+# seven; thus, in an ISO locale, Monday = 1, ...,
+# Sunday == 7.
+#
+# The following fields in a date array change the behavior of FISCAL_YEAR
+# and WEEK_OF_YEAR:
+#
+# DAYS_IN_FIRST_WEEK - The minimum number of days that a week must
+# have before it is accounted the first week
+# of a year. For the ISO fiscal calendar, this
+# number is 4.
+#
+# FIRST_DAY_OF_WEEK - The day of the week (Sunday = 0, ..., Saturday = 6)
+# on which a new fiscal year begins. Days greater
+# than 6 are reduced modulo 7.
+#
+#----------------------------------------------------------------------
+
+#----------------------------------------------------------------------
+#
+# The calendar::CommonCalendar namespace contains code for handling
+# dates on the 'common calendar' -- the civil calendar in virtually
+# the entire Western world. The common calendar is the Julian
+# calendar prior to a certain date that varies with the locale, and
+# the Gregorian calendar thereafter.
+#
+#----------------------------------------------------------------------
+
+namespace eval ::calendar::CommonCalendar {
+
+ namespace export WeekdayOnOrBefore
+ namespace export CivilYearToAbsolute
+
+ # Number of days in the months in a common year and a leap year
+
+ variable daysInMonth [list 31 28 31 30 31 30 31 31 30 31 30 31]
+ variable daysInMonthInLeapYear [list 31 29 31 30 31 30 31 31 30 31 30 31]
+
+ # Number of days preceding the start of a given month in a leap year
+ # and common year. For convenience, these lists are zero based and
+ # contain a thirteenth month; [lindex $daysInPriorMonths 3], for instance
+ # gives the number of days preceding 1 March, and
+ # [lindex $daysInPriorMonths 13] gives the number of days in a common
+ # year.
+
+ variable daysInPriorMonths
+ variable daysInPriorMonthsInLeapYear
+
+ set dp 0
+ set dply 0
+ set daysInPriorMonths [list {} 0]
+ set daysInPriorMonthsInLeapYear [list {} 0]
+ foreach d $daysInMonth dly $daysInMonthInLeapYear {
+ lappend daysInPriorMonths [incr dp $d]
+ lappend daysInPriorMonthsInLeapYear [incr dply $dly]
+ }
+ unset d dly dp dply
+
+}
+
+#----------------------------------------------------------------------
+#
+# ::calendar::CommonCalendar::WeekdayOnOrBefore --
+#
+# Determine the last time that a given day of the week occurs
+# on or before a given date (e.g., Sunday on or before January 2).
+#
+# Parameters:
+# weekday -- Day of the week (Sunday = 0 .. Saturday = 6)
+# Days greater than 6 are interpreted modulo 7.
+# j -- Julian day number.
+#
+# Results:
+# Returns the Julian day number of the desired day.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc ::calendar::CommonCalendar::WeekdayOnOrBefore { weekday j } {
+ # Normalize weekday, Monday=0
+ set k [expr { ($weekday + 6) % 7 }]
+ return [expr { $j - ( $j - $k ) % 7 }]
+}
+
+#----------------------------------------------------------------------
+#
+# ::calendar::CommonCalendar::CivilYearToAbsolute --
+#
+# Calculate an "absolute" year number, that is, the count of
+# years from the common epoch, 1 B.C.E.
+#
+# Parameters:
+# dateVar -- Name of an array in caller's scope containing the
+# fields ERA (BCE or CE) and YEAR.
+#
+# Results:
+# Returns an absolute year number. The years in the common era
+# have their natural numbers; the year 1 BCE returns 0, 2 BCE returns
+# -1, and so on.
+#
+# Side effects:
+# None.
+#
+# The popular names BC and AD are accepted as synonyms for BCE and CE.
+#
+#----------------------------------------------------------------------
+
+proc ::calendar::CommonCalendar::CivilYearToAbsolute { dateVar } {
+
+ upvar 1 $dateVar date
+ switch -exact $date(ERA) {
+ BCE - BC {
+ return [expr { 1 - $date(YEAR) }]
+ }
+ CE - AD {
+ return $date(YEAR)
+ }
+ default {
+ return -code error "Unknown era \"$date(ERA)\""
+ }
+ }
+}
+
+#----------------------------------------------------------------------
+#
+# The calendar::GregorianCalendar namespace contains codes specific to the
+# Gregorian calendar. These codes deal specifically with dates after
+# the conversion from the Julian to Gregorian calendars (which are
+# various dates in various locales; 1582 in most Catholic countries,
+# 1752 in most English-speaking countries, 1917 in Russia, ...).
+# If presented with earlier dates, these codes will compute based on
+# a hypothetical proleptic calendar.
+#
+#----------------------------------------------------------------------
+
+namespace eval calendar::GregorianCalendar {
+
+ namespace import ::calendar::CommonCalendar::WeekdayOnOrBefore
+ namespace import ::calendar::CommonCalendar::CivilYearToAbsolute
+
+ namespace export IsLeapYear
+
+ namespace export EYMDToJulianDay
+ namespace export EYDToJulianDay
+ namespace export EFYWDToJulianDay
+ namespace export EYMWDToJulianDay
+
+ namespace export JulianDayToEYD
+ namespace export JulianDayToEYMD
+ namespace export JulianDayToEFYWD
+ namespace export JulianDayToEYMWD
+
+ # The Gregorian epoch -- 31 December, 1 B.C.E, Gregorian, expressed
+ # as a Julian day number. (This date is 2 January, 1 C.E., in the
+ # proleptic Julian calendar.)
+
+ variable epoch 1721425
+
+ # Common years - these years, mod 400, are the irregular common years
+ # of the Gregorian calendar
+
+ variable commonYears
+ array set commonYears { 100 {} 200 {} 300 {} }
+
+}
+
+#----------------------------------------------------------------------
+#
+# ::calendar::GregorianCalendar::IsLeapYear
+#
+# Tests whether a year is a leap year.
+#
+# Parameters:
+#
+# y - Year number of the common era. The year 0 represents
+# 1 BCE of the proleptic calendar, -1 represents 2 BCE, etc.
+#
+# Results:
+#
+# Returns 1 if the given year is a leap year, 0 otherwise.
+#
+# Side effects:
+#
+# None.
+#
+#----------------------------------------------------------------------
+
+proc ::calendar::GregorianCalendar::IsLeapYear { y } {
+
+ variable commonYears
+ return [expr { ( $y % 4 ) == 0
+ && ![info exists commonYears([expr { $y % 400 }])] }]
+
+}
+
+#----------------------------------------------------------------------
+#
+# ::calendar::GregorianCalendar::EYMDToJulianDay
+#
+# Convert a date on the Gregorian calendar expressed as
+# era (BCE or CE), year in the era, month number (January = 1)
+# and day of the month to a Julian Day Number.
+#
+# Parameters:
+#
+# dateArray -- Name of an array in caller's scope containing
+# keys ERA, YEAR, MONTH, and DAY_OF_MONTH
+#
+# Results:
+#
+# Returns the Julian Day Number of the day that starts with
+# noon of the given date.
+#
+# Side effects:
+#
+# None.
+#
+#----------------------------------------------------------------------
+
+proc ::calendar::GregorianCalendar::EYMDToJulianDay { dateArray } {
+
+ upvar 1 $dateArray date
+
+ variable epoch
+ variable ::calendar::CommonCalendar::daysInPriorMonths
+ variable ::calendar::CommonCalendar::daysInPriorMonthsInLeapYear
+
+ # Convert era and year to an absolute year number
+
+ set y [calendar::CommonCalendar::CivilYearToAbsolute date]
+ set ym1 [expr { $y - 1 }]
+
+ # Calculate the Julian day
+
+ return [expr { $epoch
+ + $date(DAY_OF_MONTH)
+ + ( [IsLeapYear $y] ?
+ [lindex $daysInPriorMonthsInLeapYear $date(MONTH)]
+ : [lindex $daysInPriorMonths $date(MONTH)] )
+ + ( 365 * $ym1 )
+ + ( $ym1 / 4 )
+ - ( $ym1 / 100 )
+ + ( $ym1 / 400 ) }]
+
+}
+
+#----------------------------------------------------------------------
+#
+# ::calendar::GregorianCalendar::EYDToJulianDay --
+#
+# Convert a date expressed in the Gregorian calendar as era (BCE or CE),
+# year, and day-of-year to a Julian Day Number.
+#
+# Parameters:
+#
+# dateArray -- Name of an array in caller's scope containing
+# keys ERA, YEAR, and DAY_OF_YEAR
+#
+# Results:
+#
+# Returns the Julian Day Number corresponding to noon of the given
+# day.
+#
+# Side effects:
+#
+# None.
+#
+#----------------------------------------------------------------------
+
+proc ::calendar::GregorianCalendar::EYDToJulianDay { dateArray } {
+
+ upvar 1 $dateArray date
+ variable epoch
+
+ set y [CivilYearToAbsolute date]
+ set ym1 [expr { $y - 1 }]
+
+ return [expr { $epoch
+ + $date(DAY_OF_YEAR)
+ + ( 365 * $ym1 )
+ + ( $ym1 / 4 )
+ - ( $ym1 / 100 )
+ + ( $ym1 / 400 ) }]
+
+}
+
+#----------------------------------------------------------------------
+#
+# ::calendar::GregorianCalendar::EFYWDToJulianDay --
+#
+# Convert a date expressed in the system of era, fiscal year,
+# week number and day number to a Julian Day Number.
+#
+# Parameters:
+#
+# dateArray -- Name of an array in caller's scope that contains
+# keys ERA, FISCAL_YEAR, WEEK_OF_YEAR, and DAY_OF_WEEK,
+# and optionally contains DAYS_IN_FIRST_WEEK
+# and FIRST_DAY_OF_WEEK.
+# daysInFirstWeek -- Minimum number of days that a week must
+# have to be considered the first week of a
+# fiscal year. Default is 4, which gives
+# ISO8601:1988 semantics. The parameter is
+# used only if the 'dateArray' does not
+# contain a DAYS_IN_FIRST_WEEK key.
+# firstDayOfWeek -- Ordinal number of the first day of the week
+# (Sunday = 0, Monday = 1, etc.) Default is
+# 1, which gives ISO8601:1988 semantics. The
+# parameter is used only if 'dateArray' does not
+# contain a DAYS_IN_FIRST_WEEK key.n
+#
+# Results:
+#
+# Returns the Julian Calendar Day corresponding to noon of the given
+# day.
+#
+# Side effects:
+#
+# None.
+#
+# The ERA element of the array is BCE or CE.
+# The FISCAL_YEAR is the year number in the given era. The year is relative
+# to the fiscal week; hence days that are early in January or late in
+# December may belong to a different year than the calendar year.
+# The WEEK_OF_YEAR is the ordinal number of the week within the year.
+# Week 1 is the week beginning on the specified FIRST_DAY_OF_WEEK
+# (Sunday = 0, Monday = 1, etc.) and containing at least DAYS_IN_FIRST_WEEK
+# days (or, equivalently, containing January DAYS_IN_FIRST_WEEK)
+# The DAY_OF_WEEK is Sunday=0, Monday=1, ..., if FIRST_DAY_OF_WEEK
+# is 0, or Monday=1, Tuesday=2, ..., Sunday=7 if FIRST_DAY_OF_WEEK
+# is 1.
+#
+#----------------------------------------------------------------------
+
+proc ::calendar::GregorianCalendar::EFYWDToJulianDay { dateArray
+ {daysInFirstWeek 4}
+ {firstDayOfWeek 1} } {
+ upvar 1 $dateArray date
+
+ # Use parameters to supply defaults if the array doesn't
+ # have conversion rules.
+
+ if { ![info exists date(DAYS_IN_FIRST_WEEK)] } {
+ set date(DAYS_IN_FIRST_WEEK) $daysInFirstWeek
+ }
+ if { ![info exists date(FIRST_DAY_OF_WEEK)] } {
+ set date(FIRST_DAY_OF_WEEK) $firstDayOfWeek
+ }
+
+ # Find the start of the fiscal year
+
+ set date2(ERA) $date(ERA)
+ set date2(YEAR) $date(FISCAL_YEAR)
+ set date2(MONTH) 1
+ set date2(DAY_OF_MONTH) $date(DAYS_IN_FIRST_WEEK)
+ set jd [WeekdayOnOrBefore \
+ $date(FIRST_DAY_OF_WEEK) \
+ [EYMDToJulianDay date2]]
+
+ # Add the weeks and days.
+
+ return [expr { $jd
+ + ( 7 * ( $date(WEEK_OF_YEAR) - 1 ) )
+ + $date(DAY_OF_WEEK) - $date(FIRST_DAY_OF_WEEK) }]
+
+}
+
+#----------------------------------------------------------------------
+#
+# ::calendar::GregorianCalendar::EYMWDToJulianDay --
+#
+# Given era, year, month, and day of week in month (e.g. "first Tuesday")
+# derive a Julian day number.
+#
+# Parameters:
+# dateVar -- Name of an array in caller's scope containing the
+# date fields.
+#
+# Results:
+# Returns the desired Julian day number.
+#
+# Side effects:
+# None.
+#
+# The 'dateVar' array is expected to contain the following keys:
+# + ERA - The constant 'BCE' or 'CE'.
+# + YEAR - The Gregorian calendar year
+# + MONTH - The month of the year (1 = January .. 12 = December)
+# + DAY_OF_WEEK - The day of the week (Sunday = 0 .. Saturday = 6)
+# If day of week is 7 or greater, it is interpreted
+# modulo 7.
+# + DAY_OF_WEEK_IN_MONTH - The day of week within the month
+# (1 = first XXXday, 2 = second XXDday, ...
+# also -1 = last XXXday, -2 = next-to-last
+# XXXday, ...)
+#
+#----------------------------------------------------------------------
+
+proc ::calendar::GregorianCalendar::EYMWDToJulianDay { dateVar } {
+
+ upvar 1 $dateVar date
+
+ variable epoch
+
+ # Are we counting from the beginning or the end of the month?
+
+ array set date2 [array get date]
+ if { $date(DAY_OF_WEEK_IN_MONTH) >= 0 } {
+
+ # When counting from the start of the month, begin by
+ # finding the 'zeroeth' - the last day of the prior month.
+ # Note that it's ok to give EYMDToJulianDay a zero day-of-month!
+
+ set date2(DAY_OF_MONTH) 0
+
+ } else {
+
+ # When counting from the end of the month, the 'zeroeth'
+ # is the seventh of the following month. Note that it's ok
+ # to give EYMDToJulianDay a thirteenth month!
+
+ incr date2(MONTH)
+ set date2(DAY_OF_MONTH) 7
+
+ }
+
+ set zeroethDayOfMonth [EYMDToJulianDay date2]
+
+ # Find the zeroeth weekday in the given month
+
+ set wd0 [WeekdayOnOrBefore $date(DAY_OF_WEEK) $zeroethDayOfMonth]
+
+ # Add the requisite number of weeks
+
+ return [expr { $wd0 + 7 * $date(DAY_OF_WEEK_IN_MONTH) }]
+
+}
+
+#----------------------------------------------------------------------
+#
+# ::calendar::GregorianCalendar::JulianDayToEYD --
+#
+# Given a Julian day number, compute era, year, and day of year.
+#
+# Parameters:
+# j - Julian day number
+# dateVar - Name of an array in caller's scope that will receive the
+# date fields.
+#
+# Results:
+# Returns an absolute year; that is, returns the year number for
+# years in the Common Era; returns 0 for 1 B.C.E., -1 for 2 B.C.E.,
+# and so on.
+#
+# Side effects:
+# The 'dateVar' array is populated with the following:
+# + ERA - The era corresponding to the given Julian Day.
+# (BCE or CE)
+# + YEAR - The year of the given era.
+# + DAY_OF_YEAR - The day within the given year (1 = 1 January,
+# etc.)
+#
+#----------------------------------------------------------------------
+
+proc ::calendar::GregorianCalendar::JulianDayToEYD { j dateVar } {
+
+ upvar 1 $dateVar date
+
+ variable epoch
+
+ # Absolute day number relative to the Gregorian epoch
+
+ set day [expr { $j - $epoch - 1}]
+
+ # Count 400-year cycles
+
+ set year 1
+ set n [expr { $day / 146097 }]
+ incr year [expr { 400 * $n }]
+ set day [expr { $day % 146097 }]
+
+ # Count centuries
+
+ set n [expr { $day / 36524 }]
+ set day [expr { $day % 36524 }]
+ if { $n > 3 } { # Last day of 1600, 2000, 2400...
+ set n 3
+ incr day 36524
+ }
+ incr year [expr { 100 * $n }]
+
+ # Count 4-year cycles
+
+ set n [expr { $day / 1461 }]
+ set day [expr { $day % 1461 }]
+ incr year [expr { 4 * $n }]
+
+ # Count years
+
+ set n [expr { $day / 365 }]
+ set day [expr { $day % 365 }]
+ if { $n > 3 } { # December 31 of a leap year
+ set n 3
+ incr day 365
+ }
+ incr year $n
+
+ # Determine the era
+
+ if { $year <= 0 } {
+ set date(YEAR) [expr { 1 - $year }]
+ set date(ERA) BCE
+ } else {
+ set date(YEAR) $year
+ set date(ERA) CE
+ }
+
+ # Determine day of year.
+
+ set date(DAY_OF_YEAR) [expr { $day + 1 }]
+ return $year
+
+}
+
+#----------------------------------------------------------------------
+#
+# ::calendar::GregorianCalendar::JulianDayToEYMD --
+#
+# Given a Julian day number, compute era, year, month, and day
+# of the Gregorian calendar.
+#
+# Parameters:
+# j - Julian day number
+# dateVar - Name of a variable in caller's scope that will be
+# filled in with the fields, ERA, YEAR, MONTH, DAY_OF_MONTH,
+# and DAY_OF_YEAR (this last comes as a side effect of how
+# the calculations are performed, but is trustworthy).
+#
+# Results:
+# None.
+#
+# Side effects:
+# Requested fields of dateVar are filled in.
+#
+#----------------------------------------------------------------------
+
+proc ::calendar::GregorianCalendar::JulianDayToEYMD { j dateVar } {
+
+ upvar 1 $dateVar date
+
+ variable ::calendar::CommonCalendar::daysInMonth
+ variable ::calendar::CommonCalendar::daysInMonthInLeapYear
+
+ set year [JulianDayToEYD $j date]
+ set day $date(DAY_OF_YEAR)
+
+ if { [IsLeapYear $year] } {
+ set hath $daysInMonthInLeapYear
+ } else {
+ set hath $daysInMonth
+ }
+ set month 1
+ foreach n $hath {
+ if { $day <= $n } {
+ break
+ }
+ incr month
+ set day [expr { $day - $n }]
+ }
+ set date(MONTH) $month
+ set date(DAY_OF_MONTH) $day
+
+ return
+
+}
+
+#----------------------------------------------------------------------
+#
+# ::calendar::GregorianCalendar::JulianDayToEFYWD --
+#
+# Given a julian day number, compute era, fiscal year, fiscal week,
+# and day of week in a fiscal calendar based on the Gregorian calendar.
+#
+# Parameters:
+# j - Julian day number
+# dateVar - Name of an array in caller's scope that is to receive the
+# fields of the date. The array may be prepared with
+# DAYS_IN_FIRST_WEEK and FIRST_DAY_OF_WEEK fields to
+# change the rule for computing the fiscal week.
+# daysInFirstWeek - (Optional) Parameter giving the minimum number
+# of days in the first week of a year. Default is 4.
+# firstDayOfWeek - (Optional) Parameter giving the day number of the
+# first day of a fiscal week (Sunday = 0 ..
+# Saturday = 6). Default is 1 (Monday).
+#
+# Results:
+# None.
+#
+# Side effects:
+# The ERA, YEAR, FISCAL_YEAR, DAY_OF_YEAR, WEEK_OF_YEAR, DAY_OF_WEEK,
+# DAYS_IN_FIRST_WEEK, and FIRST_DAY_OF_WEEK fields in the 'dateVar'
+# array are filled in.
+#
+# If DAYS_IN_FIRST_WEEK or FIRST_DAY_OF_WEEK fields are present in
+# 'dateVar' prior to the call, they override any values passed on the
+# command line.
+#
+#----------------------------------------------------------------------
+
+proc ::calendar::GregorianCalendar::JulianDayToEFYWD { j
+ dateVar
+ {daysInFirstWeek 4}
+ {firstDayOfWeek 1} } {
+ upvar 1 $dateVar date
+
+ if { ![info exists date(DAYS_IN_FIRST_WEEK)] } {
+ set date(DAYS_IN_FIRST_WEEK) $daysInFirstWeek
+ }
+ if { ![info exists date(FIRST_DAY_OF_WEEK)] } {
+ set date(FIRST_DAY_OF_WEEK) $firstDayOfWeek
+ }
+
+ # Determine the calendar year of $j - $daysInFirstWeek + 1.
+ # Guess the fiscal year
+
+ JulianDayToEYD [expr { $j - $daysInFirstWeek + 1 }] date1
+ set date1(FISCAL_YEAR) [expr { $date1(YEAR) + 1 }]
+
+ # Determine the start of the fiscal year that we guessed
+
+ set date1(WEEK_OF_YEAR) 1
+ set date1(DAY_OF_WEEK) $firstDayOfWeek
+ set startOfFiscalYear [EFYWDToJulianDay \
+ date1 \
+ $date(DAYS_IN_FIRST_WEEK) \
+ $date(FIRST_DAY_OF_WEEK)]
+
+ # If we guessed high, fix it.
+
+ if { $j < $startOfFiscalYear } {
+ incr date1(FISCAL_YEAR) -1
+ set startOfFiscalYear [EFYWDToJulianDay date1]
+ }
+
+ set date(FISCAL_YEAR) $date1(FISCAL_YEAR)
+
+ # Get the week number and the day within the week
+
+ set dayOfFiscalYear [expr { $j - $startOfFiscalYear }]
+ set date(WEEK_OF_YEAR) [expr { ( $dayOfFiscalYear / 7 ) + 1 }]
+ set date(DAY_OF_WEEK) [expr { ( $dayOfFiscalYear + 1 ) % 7 }]
+ if { $date(DAY_OF_WEEK) < $date(FIRST_DAY_OF_WEEK) } {
+ incr date(DAY_OF_WEEK) 7
+ }
+
+ return
+}
+
+#----------------------------------------------------------------------
+#
+# GregorianCalendar::JulianDayToEYMWD --
+#
+# Convert a Julian day number to year, month, day-of-week-in-month
+# (e.g., first Tuesday), and day of week.
+#
+# Parameters:
+# j - Julian day number
+# dateVar - Name of an array in caller's scope that holds the
+# fields of the date.
+#
+# Results:
+# None.
+#
+# Side effects:
+# The ERA, YEAR, MONTH, DAY_OF_MONTH, DAY_OF_WEEK, and
+# DAY_OF_WEEK_IN_MONTH fields of the given date are all filled
+# in.
+#
+# Notes:
+# DAY_OF_WEEK_IN_MONTH is always positive on return.
+#
+#----------------------------------------------------------------------
+
+proc ::calendar::GregorianCalendar::JulianDayToEYMWD { j dateVar } {
+
+ upvar 1 $dateVar date
+
+ # Compute era, year, month and day
+
+ JulianDayToEYMD $j date
+
+ # Find day of week
+
+ set date(DAY_OF_WEEK) [expr { ( $j + 1 ) % 7 }]
+
+ # Find day of week in month
+
+ set date(DAY_OF_WEEK_IN_MONTH) \
+ [expr { ( ( $date(DAY_OF_MONTH) - 1 ) / 7) + 1 }]
+
+ return
+
+}
diff --git a/tcllib/modules/calendar/gregorian.test b/tcllib/modules/calendar/gregorian.test
new file mode 100644
index 0000000..67b6177
--- /dev/null
+++ b/tcllib/modules/calendar/gregorian.test
@@ -0,0 +1,407 @@
+#----------------------------------------------------------------------
+#
+# calendar.test --
+#
+# Tests for [calendar::CommonCalendar] and
+# [calendar::GregorianCalendar]
+#
+# RCS: @(#) $Id: gregorian.test,v 1.6 2006/10/09 21:41:40 andreas_kupries Exp $
+#
+#----------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal calendar.tcl calendar
+}
+
+#----------------------------------------------------------------------
+#
+# TEST CASES
+#
+#----------------------------------------------------------------------
+# Unix epoch
+
+array set gregChange {
+ ERA CE
+ YEAR 1752
+ MONTH 9
+ DAY_OF_MONTH 14
+}
+
+array set gregUnixEpoch {
+ ERA CE
+ YEAR 1970
+ MONTH 1
+ DAY_OF_MONTH 1
+}
+
+set gregChangeJ [calendar::GregorianCalendar::EYMDToJulianDay gregChange]
+set unixEpoch [calendar::GregorianCalendar::EYMDToJulianDay gregUnixEpoch]
+
+if 0 {
+ puts "Gregorian calendar was adopted in England on Julian Day $gregChangeJ"
+ puts "Posix epoch is Julian day $unixEpoch"
+}
+
+#----------------------------------------------------------------------
+# Procedure that tests EYMDToJulianDay, EYDToJulianDay, JulianDayToEYD,
+# and JulianDayToEYMD
+
+proc testCal { month day year } {
+
+ global unixEpoch
+
+ # Convert the requested date to seconds from the Posix epoch
+
+ set seconds [clock scan $month/$day/$year -gmt true]
+
+ # Convert to days from the Posix epoch
+
+ set days [ expr { $seconds / 86400 }]
+
+ # Test EYMDToJulianDay
+
+ set dateIn(ERA) CE
+ set dateIn(YEAR) $year
+ set dateIn(MONTH) $month
+ set dateIn(DAY_OF_MONTH) $day
+ set dateIn(DAY_OF_YEAR) \
+ [string trimleft [clock format $seconds -gmt true -format %j] 0]
+ set jcdOut [calendar::GregorianCalendar::EYMDToJulianDay dateIn]
+ if { $jcdOut - $unixEpoch != $days } {
+ error "date $month/$day/$year julian day is $jcdout\
+ should be [expr $days + $unixEpoch]"
+ }
+
+ # Test JulianDayToEYMD and its internal call to JulianDayToEYD
+
+ calendar::GregorianCalendar::JulianDayToEYMD $jcdOut dateOut
+ foreach f {ERA YEAR DAY_OF_YEAR MONTH DAY_OF_MONTH} {
+ if { [string compare $dateIn($f) $dateOut($f)] } {
+ error "date $month/$day/$year field $f\
+ is $dateOut($f) should be $dateIn($f)"
+ }
+ }
+
+ # Test EYDToJulianDay (possible because JulianDayToEYMD leaves
+ # DAY_OF_YEAR
+
+ set jcdOut2 [calendar::GregorianCalendar::EYDToJulianDay dateOut]
+ if { $jcdOut2 - $unixEpoch != $days } {
+ error "date $month/$day/$year julian day is $jcdout2\
+ should be [expr $days + $unixEpoch]"
+ }
+
+
+}
+
+# Procedure that tests EFYWDToJulianDay and JulianDayToEFYWD. Inputs are
+# fiscal year, week, day, calendar year, month, and day of month. Conversion
+# in both directions is tested.
+
+proc testISO { fy w d cy m dm } {
+ set date(ERA) CE
+ set date(FISCAL_YEAR) $fy
+ set date(WEEK_OF_YEAR) $w
+ set date(DAY_OF_WEEK) $d
+ set dayNo [calendar::GregorianCalendar::EFYWDToJulianDay date]
+ calendar::GregorianCalendar::JulianDayToEYMD $dayNo date2
+ if { $date2(YEAR) != $cy
+ || $date2(MONTH) != $m
+ || $date2(DAY_OF_MONTH) != $dm } {
+ error "[info level 0]: bad date should be $cy-$m-$dm:\
+ year $date2(YEAR) month $date2(MONTH) day $date2(DAY_OF_MONTH)"
+ }
+
+ set date3(ERA) CE
+ set date3(YEAR) $cy
+ set date3(MONTH) $m
+ set date3(DAY_OF_MONTH) $dm
+ set dayNo [calendar::GregorianCalendar::EYMDToJulianDay date3]
+ calendar::GregorianCalendar::JulianDayToEFYWD $dayNo date4
+ if { $date4(FISCAL_YEAR) != $fy
+ || $date4(WEEK_OF_YEAR) != $w
+ || $date4(DAY_OF_WEEK) != $d } {
+ error "[info level 0]: bad date should be $fy-W$w-$d:
+ year $date4(FISCAL_YEAR) week $date4(WEEK_OF_YEAR) day $date4(DAY_OF_WEEK)"
+ }
+
+}
+
+# Procedure that tests day-of-week-in-month for a given year-month-day.
+# Assumes that days of month are presented in order.
+
+proc testWeekInMonth { y m d } {
+ global count lastYM
+ if { ![info exists lastYM]
+ || [string compare $lastYM [list $y $m]] } {
+ set lastYM [list $y $m]
+ for { set dw 0 } { $dw < 7 } { incr dw } {
+ set count($dw) 0
+ }
+ }
+ set date(ERA) CE
+ set date(YEAR) $y
+ set date(MONTH) $m
+ set date(DAY_OF_MONTH) $d
+ set jd [calendar::GregorianCalendar::EYMDToJulianDay date]
+ calendar::GregorianCalendar::JulianDayToEYMWD $jd date2
+ set s [clock scan "$m/$d/$y" -gmt true]
+ set dw [clock format $s -format "%w" -gmt true]
+ if { $dw != $date2(DAY_OF_WEEK) } {
+ error "JulianDayToEYMWD computed wrong day\
+ $date2(DAY_OF_WEEK) for $y-$m-$d should be $dw"
+ }
+ incr count($dw)
+ if { $count($dw) != $date2(DAY_OF_WEEK_IN_MONTH) } {
+ error "JulianDateToEYMD computed wrong week\
+ $date2(DAY_OF_WEEK_IN_MONTH) for $y-$m-$d\
+ should be $count($dw)"
+ }
+ foreach field {ERA YEAR MONTH DAY_OF_WEEK_IN_MONTH DAY_OF_WEEK} {
+ set date3($field) $date2($field)
+ }
+ set jd2 [calendar::GregorianCalendar::EYMWDToJulianDay date3]
+ unset date2 date3
+ if { $jd2 != $jd } {
+ error "EYMDToJulianDate computed wrong day $jd2\
+ for $y-$m-$d should be $jd"
+ }
+ return
+}
+
+# Procedure that tests day-of-week-from-end-ofmonth for a given year-month-day.
+# Assumes that days of month are presented in reverse order.
+
+proc testWeekFromEndOfMonth { y m d } {
+ global count lastYM
+ if { ![info exists lastYM]
+ || [string compare $lastYM [list $y $m]] } {
+ set lastYM [list $y $m]
+ for { set dw 0 } { $dw < 7 } { incr dw } {
+ set count($dw) 0
+ }
+ }
+ set date(ERA) CE
+ set date(YEAR) $y
+ set date(MONTH) $m
+ set date(DAY_OF_MONTH) $d
+ set jd [calendar::GregorianCalendar::EYMDToJulianDay date]
+
+ set s [clock scan "$m/$d/$y" -gmt true]
+ set dw [clock format $s -format "%w" -gmt true]
+ incr count($dw) -1
+
+ foreach field {ERA YEAR MONTH} {
+ set date2($field) $date($field)
+ }
+ set date2(DAY_OF_WEEK_IN_MONTH) $count($dw)
+ set date2(DAY_OF_WEEK) $dw
+ set jd2 [calendar::GregorianCalendar::EYMWDToJulianDay date2]
+ if { $jd2 != $jd } {
+ error "EYMWDToJulianDate computed wrong day $jd2\
+ for $y-$m-$d (week $count($dw), day $dw) should be $jd"
+ }
+ return
+}
+
+#----------------------------------------------------------------------
+
+test calendar-1.1 {Julian Day converting to/from Gregorian year-month-day} {
+
+ set n 0
+ for { set year 1902 } { $year < 2038 } { incr year } {
+
+ # Test the first and last day of each month. Test 28 February
+ # always, 29 February of leap years.
+
+ testCal 1 1 $year
+ testCal 1 31 $year
+ testCal 2 28 $year
+ if { $year % 4 == 0} {
+ testCal 2 29 $year
+ incr n
+ }
+ testCal 3 1 $year
+ testCal 3 31 $year
+ testCal 4 1 $year
+ testCal 4 30 $year
+ testCal 5 1 $year
+ testCal 5 31 $year
+ testCal 6 1 $year
+ testCal 6 30 $year
+ testCal 7 1 $year
+ testCal 7 31 $year
+ testCal 8 1 $year
+ testCal 8 31 $year
+ testCal 9 1 $year
+ testCal 9 30 $year
+ testCal 10 1 $year
+ testCal 10 31 $year
+ testCal 11 1 $year
+ testCal 11 30 $year
+ testCal 12 1 $year
+ testCal 12 31 $year
+ incr n 24
+ }
+
+ set n
+} 3298
+
+test calendar-2.1 {ISO date conversions} {
+
+ # Test the first and last week of a 52- and 53-week year beginning on each
+ # possible day of week
+
+ testISO 2000 52 1 2000 12 25
+ testISO 2000 52 7 2000 12 31
+ testISO 2001 1 1 2001 1 1
+ testISO 2001 1 7 2001 1 7
+ testISO 2001 2 1 2001 1 8
+
+ testISO 2001 52 1 2001 12 24
+ testISO 2001 52 7 2001 12 30
+ testISO 2002 1 1 2001 12 31
+ testISO 2002 1 2 2002 1 1
+ testISO 2002 1 7 2002 1 6
+ testISO 2002 2 1 2002 1 7
+
+ testISO 2002 52 1 2002 12 23
+ testISO 2002 52 7 2002 12 29
+ testISO 2003 1 1 2002 12 30
+ testISO 2003 1 2 2002 12 31
+ testISO 2003 1 3 2003 1 1
+ testISO 2003 1 7 2003 1 5
+ testISO 2003 2 1 2003 1 6
+
+ testISO 2003 52 1 2003 12 22
+ testISO 2003 52 7 2003 12 28
+ testISO 2004 1 1 2003 12 29
+ testISO 2004 1 3 2003 12 31
+ testISO 2004 1 4 2004 1 1
+ testISO 2004 1 7 2004 1 4
+ testISO 2004 2 1 2004 1 5
+
+ testISO 2004 52 1 2004 12 20
+ testISO 2004 52 7 2004 12 26
+ testISO 2004 53 1 2004 12 27
+ testISO 2004 53 5 2004 12 31
+ testISO 2004 53 6 2005 1 1
+ testISO 2004 53 7 2005 1 2
+ testISO 2005 1 1 2005 1 3
+ testISO 2005 1 7 2005 1 9
+ testISO 2005 2 1 2005 1 10
+
+ testISO 2005 52 1 2005 12 26
+ testISO 2005 52 6 2005 12 31
+ testISO 2005 52 7 2006 1 1
+ testISO 2006 1 1 2006 1 2
+ testISO 2006 1 7 2006 1 8
+ testISO 2006 2 1 2006 1 9
+
+ testISO 2009 52 1 2009 12 21
+ testISO 2009 52 7 2009 12 27
+ testISO 2009 53 1 2009 12 28
+ testISO 2009 53 4 2009 12 31
+ testISO 2009 53 5 2010 1 1
+ testISO 2009 53 7 2010 1 3
+ testISO 2010 1 1 2010 1 4
+ testISO 2010 1 7 2010 1 10
+ testISO 2010 2 1 2010 1 11
+
+} {}
+
+test calendar-3.1 {Day-of-week-in-month} {
+ # Test each day of month for one month of each possible length
+ # starting on each day of the week.
+
+ foreach { y m l } {
+ 2001 1 31
+ 2001 11 30
+ 2001 2 28
+ 2001 3 31
+ 2001 4 30
+ 2001 5 31
+ 2001 6 30
+ 2001 7 31
+ 2001 8 31
+ 2001 9 30
+ 2002 2 28
+ 2002 3 31
+ 2002 4 30
+ 2003 2 28
+ 2003 3 31
+ 2003 4 30
+ 2004 2 29
+ 2004 9 30
+ 2005 2 28
+ 2006 2 28
+ 2008 2 29
+ 2009 2 28
+ 2010 2 28
+ 2012 2 29
+ 2016 2 29
+ 2020 2 29
+ 2024 2 29
+ 2028 2 29
+ } {
+ for { set d 1 } { $d <= $l } { incr d } {
+ testWeekInMonth $y $m $d
+ }
+ }
+ concat
+} {}
+
+test calendar-3.2 {Day-of-week from end of month} {
+ # Test each day of month for one month of each possible length
+ # starting on each day of the week.
+
+ foreach { y m l } {
+ 2001 1 31
+ 2001 11 30
+ 2001 2 28
+ 2001 3 31
+ 2001 4 30
+ 2001 5 31
+ 2001 6 30
+ 2001 7 31
+ 2001 8 31
+ 2001 9 30
+ 2002 2 28
+ 2002 3 31
+ 2002 4 30
+ 2003 2 28
+ 2003 3 31
+ 2003 4 30
+ 2004 2 29
+ 2004 9 30
+ 2005 2 28
+ 2006 2 28
+ 2008 2 29
+ 2009 2 28
+ 2010 2 28
+ 2012 2 29
+ 2016 2 29
+ 2020 2 29
+ 2024 2 29
+ 2028 2 29
+ } {
+ for { set d $l } { $d >= 1 } { incr d -1 } {
+ testWeekFromEndOfMonth $y $m $d
+ }
+ }
+ concat
+} {}
+
+#----------------------------------------------------------------------
+testsuiteCleanup
+
+# Local Variables:
+# mode:tcl
+# End:
diff --git a/tcllib/modules/calendar/pkgIndex.tcl b/tcllib/modules/calendar/pkgIndex.tcl
new file mode 100644
index 0000000..a3d20a3
--- /dev/null
+++ b/tcllib/modules/calendar/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if { ! [package vsatisfies [package provide Tcl] 8.2] } {return}
+package ifneeded calendar 0.2 [list source [file join $dir calendar.tcl]]
diff --git a/tcllib/modules/calendar/tclIndex b/tcllib/modules/calendar/tclIndex
new file mode 100644
index 0000000..338ca68
--- /dev/null
+++ b/tcllib/modules/calendar/tclIndex
@@ -0,0 +1,19 @@
+# Tcl autoload index file, version 2.0
+# This file is generated by the "auto_mkindex" command
+# and sourced to set up indexing information for one or
+# more commands. Typically each line is a command that
+# sets an element in the auto_index array, where the
+# element name is the name of a command and the value is
+# a script that loads the command.
+
+set auto_index(::calendar::CommonCalendar::WeekdayOnOrBefore) [list source [file join $dir gregorian.tcl]]
+set auto_index(::calendar::CommonCalendar::CivilYearToAbsolute) [list source [file join $dir gregorian.tcl]]
+set auto_index(::calendar::GregorianCalendar::IsLeapYear) [list source [file join $dir gregorian.tcl]]
+set auto_index(::calendar::GregorianCalendar::EYMDToJulianDay) [list source [file join $dir gregorian.tcl]]
+set auto_index(::calendar::GregorianCalendar::EYDToJulianDay) [list source [file join $dir gregorian.tcl]]
+set auto_index(::calendar::GregorianCalendar::EFYWDToJulianDay) [list source [file join $dir gregorian.tcl]]
+set auto_index(::calendar::GregorianCalendar::EYMWDToJulianDay) [list source [file join $dir gregorian.tcl]]
+set auto_index(::calendar::GregorianCalendar::JulianDayToEYD) [list source [file join $dir gregorian.tcl]]
+set auto_index(::calendar::GregorianCalendar::JulianDayToEYMD) [list source [file join $dir gregorian.tcl]]
+set auto_index(::calendar::GregorianCalendar::JulianDayToEFYWD) [list source [file join $dir gregorian.tcl]]
+set auto_index(::calendar::GregorianCalendar::JulianDayToEYMWD) [list source [file join $dir gregorian.tcl]]
diff --git a/tcllib/modules/clock/ChangeLog b/tcllib/modules/clock/ChangeLog
new file mode 100644
index 0000000..65072da
--- /dev/null
+++ b/tcllib/modules/clock/ChangeLog
@@ -0,0 +1,16 @@
+2013-02-08 Andreas Kupries <andreask@activestate.com>
+
+ * iso8601.test: [Bug 3603702]: Fixed TZ-dependent test case.
+
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2013-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module, 2 packages.
+ * rfc2822.tcl: Parsing rfc2822 dates (mail, news)
+ * iso8601.tcl: Parsing iso8601 dates and times.
+ * pkgIndex.tcl:
diff --git a/tcllib/modules/clock/iso8601.man b/tcllib/modules/clock/iso8601.man
new file mode 100644
index 0000000..35d7e77
--- /dev/null
+++ b/tcllib/modules/clock/iso8601.man
@@ -0,0 +1,47 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin clock_iso8601 n 0.1]
+[moddesc {Date/Time Utilities}]
+[titledesc {Parsing ISO 8601 dates/times}]
+[category {Text processing}]
+[require Tcl 8.5]
+[require clock::iso8601 [opt 0.1]]
+[description]
+
+This package provides functionality to parse dates and times in
+ISO 8601 format.
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd {::clock::iso8601 parse_date}] \
+ [arg date] [arg options...]]
+
+This command parses an ISO8601 date string in an unknown variant and
+returns the given date/time in seconds since epoch.
+
+[para] The acceptable options are
+[option -base],
+[option -gmt],
+[option -locale], and
+[option -timezone]
+of the builtin command [cmd {clock scan}].
+
+[call [cmd {::clock::iso8601 parse_time}] \
+ [arg time] [arg options...]]
+
+This command parses a full ISO8601 timestamp string (date and time) in
+an unknown variant and returns the given time in seconds since epoch.
+
+[para] The acceptable options are
+[option -base],
+[option -gmt],
+[option -locale], and
+[option -timezone]
+of the builtin command [cmd {clock scan}].
+
+[list_end]
+
+[vset CATEGORY clock::iso8601]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/clock/iso8601.pcx b/tcllib/modules/clock/iso8601.pcx
new file mode 100644
index 0000000..0b48378
--- /dev/null
+++ b/tcllib/modules/clock/iso8601.pcx
@@ -0,0 +1,43 @@
+# -*- tcl -*- iso8601.pcx
+# Syntax of the commands provided by package iso8601.
+
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register clock::iso8601
+pcx::tcldep 0.1 needs tcl 8.5
+
+namespace eval ::clock::iso8601 {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+# Switches are per clock scan (Tcl 8.5), restricted subset.
+pcx::check 0.1 std ::clock::iso8601::parse_date \
+ {checkSimpleArgs 1 -1 {
+ checkWord
+ {checkSwitches 0 {
+ {-locale checkWord}
+ {-timezone checkWord}
+ {-base checkInt}
+ {-gmt checkBoolean}
+ } {}}
+ }}
+pcx::check 0.1 std ::clock::iso8601::parse_time \
+ {checkSimpleArgs 1 -1 {
+ checkWord
+ {checkSwitches 0 {
+ {-locale checkWord}
+ {-timezone checkWord}
+ {-base checkInt}
+ {-gmt checkBoolean}
+ } {}}
+ }}
+
+# Initialization via pcx::init.
+# Use a ::iso8601::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/clock/iso8601.tcl b/tcllib/modules/clock/iso8601.tcl
new file mode 100644
index 0000000..c31df61
--- /dev/null
+++ b/tcllib/modules/clock/iso8601.tcl
@@ -0,0 +1,280 @@
+## -*- tcl -*-
+# # ## ### ##### ######## ############# #####################
+## Copyright (c) 2004 Kevin Kenny
+## Origin http://wiki.tcl.tk/13094
+## Modified for Tcl 8.5 only (eval -> {*}).
+
+# # ## ### ##### ######## ############# #####################
+## Requisites
+
+package require Tcl 8.5
+package provide clock::iso8601 0.1
+namespace eval ::clock::iso8601 {}
+
+# # ## ### ##### ######## ############# #####################
+## API
+
+# iso8601::parse_date --
+#
+# Parse an ISO8601 date/time string in an unknown variant.
+#
+# Parameters:
+# string -- String to parse
+# args -- Arguments as for [clock scan]; may include any of
+# the '-base', '-gmt', '-locale' or '-timezone options.
+#
+# Results:
+# Returns the given date in seconds from the Posix epoch.
+
+proc ::clock::iso8601::parse_date { string args } {
+ variable DatePatterns
+ variable Repattern
+ foreach { regex interpretation } $DatePatterns {
+ if { [regexp "^$regex\$" $string] } {
+ #puts A|$string|\t|$regex|\t|$interpretation|
+
+ # For incomplete dates (month and/or day missing), we have
+ # to set our own default values to overcome clock scan's
+ # settings. We do this by switching to a different pattern
+ # and extending the input properly for that pattern.
+
+ if {[dict exists $Repattern $interpretation]} {
+ lassign [dict get $Repattern $interpretation] interpretation adjust modifier
+ {*}$modifier
+ # adjust irrelevant here, see parse_time for use.
+ }
+
+ #puts B|$string|\t|$regex|\t|$interpretation|
+ return [clock scan $string -format $interpretation {*}$args]
+ }
+ }
+ return -code error "not an iso8601 date string"
+}
+
+# iso8601::parse_time --
+#
+# Parse a point-in-time in ISO8601 format
+#
+# Parameters:
+# string -- String to parse
+# args -- Arguments as for [clock scan]; may include any of
+# the '-base', '-gmt', '-locale' or '-timezone options.
+#
+# Results:
+# Returns the given time in seconds from the Posix epoch.
+
+proc ::clock::iso8601::parse_time { string args } {
+ variable DatePatterns
+ variable Repattern
+ if {![MatchTime $string field]} {
+ return -code error "not an iso8601 time string"
+ }
+
+ #parray field
+ #puts A|$string|
+
+ set pattern {}
+ foreach {regex interpretation} $DatePatterns {
+ if {[Has $interpretation tstart]} {
+ append pattern $interpretation
+ }
+ }
+
+ if {[dict exists $Repattern $pattern]} {
+ lassign [dict get $Repattern $pattern] interpretation adjust modifier
+ {*}$modifier
+ incr tstart $adjust
+ }
+
+ append pattern [Get T len]
+ incr tstart $len
+
+ if {[Has %H tstart]} {
+ append pattern %H [Get Hcolon len]
+ incr tstart $len
+
+ if {[Has %M tstart]} {
+ append pattern %M [Get Mcolon len]
+ incr tstart $len
+
+ if {[Has %S tstart]} {
+ append pattern %S
+ } else {
+ # No seconds, default to start of minute.
+ append pattern %S
+ Insert string $tstart 00
+ }
+ } else {
+ # No minutes, nor seconds, default to start of hour.
+ append pattern %M%S
+ Insert string $tstart 0000
+ }
+ } else {
+ # No time information, default to midnight.
+ append pattern %H%M%S
+ Insert string $tstart 000000
+ }
+ if {[Has %Z _]} {
+ append pattern %Z
+ }
+
+ #puts B|$string|\t|$pattern|
+ return [clock scan $string -format $pattern {*}$args]
+}
+
+# # ## ### ##### ######## ############# #####################
+
+proc ::clock::iso8601::Get {x lv} {
+ upvar 1 field field string string $lv len
+ lassign $field($x) s e
+ if {($s >= 0) && ($e >= 0)} {
+ set len [expr {$e - $s + 1}]
+ return [string range $string $s $e]
+ }
+ set len 0
+ return ""
+
+}
+
+proc ::clock::iso8601::Has {x nv} {
+ upvar 1 field field string string $nv next
+ lassign $field($x) s e
+ if {($s >= 0) && ($e >= 0)} {
+ set next $e
+ incr next
+ return 1
+ }
+ return 0
+}
+
+proc ::clock::iso8601::Insert {sv index str} {
+ upvar 1 $sv string
+ append r [string range $string 0 ${index}-1]
+ append r $str
+ append r [string range $string $index end]
+ set string $r
+ return
+}
+
+# # ## ### ##### ######## ############# #####################
+## State
+
+namespace eval ::clock::iso8601 {
+
+ namespace export parse_date parse_time
+ namespace ensemble create
+
+ # Enumerate the patterns that we recognize for an ISO8601 date as both
+ # the regexp patterns that match them and the [clock] patterns that scan
+ # them.
+
+ variable DatePatterns {
+ {\d\d\d\d-\d\d-\d\d} {%Y-%m-%d}
+ {\d\d\d\d\d\d\d\d} {%Y%m%d}
+ {\d\d\d\d-\d\d\d} {%Y-%j}
+ {\d\d\d\d\d\d\d} {%Y%j}
+ {\d\d-\d\d-\d\d} {%y-%m-%d}
+ {\d\d\d\d-\d\d} {%Y-%m}
+ {\d\d\d\d\d\d} {%y%m%d}
+ {\d\d-\d\d\d} {%y-%j}
+ {\d\d\d\d\d} {%y%j}
+ {--\d\d-\d\d} {--%m-%d}
+ {--\d\d\d\d} {--%m%d}
+ {--\d\d\d} {--%j}
+ {---\d\d} {---%d}
+ {\d\d\d\d-W\d\d-\d} {%G-W%V-%u}
+ {\d\d\d\dW\d\d\d} {%GW%V%u}
+ {\d\d-W\d\d-\d} {%g-W%V-%u}
+ {\d\dW\d\d\d} {%gW%V%u}
+ {\d\d\d\d-W\d\d} {%G-W%V}
+ {\d\d\d\dW\d\d} {%GW%V}
+ {-W\d\d-\d} {-W%V-%u}
+ {-W\d\d\d} {-W%V%u}
+ {-W-\d} {%u}
+ {\d\d\d\d} {%Y}
+ }
+
+ # Dictionary of the patterns requiring modifications to the input
+ # for proper month and/or day defaults.
+ variable Repattern {
+ %Y-%m {%Y-%m-%d 3 {Insert string 7 -01}}
+ %Y {%Y-%m-%d 5 {Insert string 4 -01-01}}
+ %G-W%V {%G-W%V-%u 1 {Insert string 8 -1}}
+ %GW%V {%GW%V%u 1 {Insert string 6 1}}
+ }
+}
+
+# # ## ### ##### ######## ############# #####################
+## Initialization
+
+apply {{} {
+ # MatchTime -- (constructed procedure)
+ #
+ # Match an ISO8601 date/time string and indicate how it matched.
+ #
+ # Parameters:
+ # string -- String to match.
+ # fieldArray -- Name of an array in caller's scope that will receive
+ # parsed fields of the time.
+ #
+ # Results:
+ # Returns 1 if the time was scanned successfully, 0 otherwise.
+ #
+ # Side effects:
+ # Initializes the field array. The keys that are significant:
+ # - Any date pattern in 'DatePatterns' indicates that the
+ # corresponding value, if non-empty, contains a date string
+ # in the given format.
+ # - The patterns T, Hcolon, and Mcolon indicate a literal
+ # T preceding the time, a colon following the hour, or
+ # a colon following the minute.
+ # - %H, %M, %S, and %Z indicate the presence of the
+ # corresponding parts of the time.
+
+ variable DatePatterns
+
+ set cmd {regexp -indices -expanded -nocase -- {PATTERN} $timeString ->}
+ set re \(?:\(?:
+ set sep {}
+ foreach {regex interpretation} $DatePatterns {
+ append re $sep \( $regex \)
+ append cmd " " [list field($interpretation)]
+ set sep |
+ }
+ append re \) {(T|[[:space:]]+)} \)?
+ append cmd { field(T)}
+ append re {(\d\d)(?:(:?)(\d\d)(?:(:?)(\d\d)?))?}
+ append cmd { field(%H) field(Hcolon) } {field(%M) field(Mcolon) field(%S)}
+ append re {[[:space:]]*(Z|[-+]\d\d:?\d\d)?}
+ append cmd { field(%Z)}
+ set cmd [string map [list {{PATTERN}} [list $re]] \
+ $cmd]
+
+ proc MatchTime { timeString fieldArray } "
+ upvar 1 \$fieldArray field
+ $cmd
+ "
+
+ #puts [info body MatchTime]
+
+} ::clock::iso8601}
+
+# # ## ### ##### ######## ############# #####################
+
+return
+# Usage examples, disabled.
+
+if { [info exists ::argv0] && ( $::argv0 eq [info script] ) } {
+ puts "::clock::iso8601::parse_date"
+ puts [::clock::iso8601::parse_date 1970-01-02 -timezone :UTC]
+ puts [::clock::iso8601::parse_date 1970-W01-5 -timezone :UTC]
+ puts [time {::clock::iso8601::parse_date 1970-01-02 -timezone :UTC} 1000]
+ puts [time {::clock::iso8601::parse_date 1970-W01-5 -timezone :UTC} 1000]
+ puts "::clock::iso8601::parse_time"
+ puts [clock format [::clock::iso8601::parse_time 2004-W33-2T18:52:24Z] \
+ -format {%X %x %z} -locale system]
+ puts [clock format [::clock::iso8601::parse_time 18:52:24Z] \
+ -format {%X %x %z} -locale system]
+ puts [time {::clock::iso8601::parse_time 2004-W33-2T18:52:24Z} 1000]
+ puts [time {::clock::iso8601::parse_time 18:52:24Z} 1000]
+}
diff --git a/tcllib/modules/clock/iso8601.test b/tcllib/modules/clock/iso8601.test
new file mode 100644
index 0000000..56d256c
--- /dev/null
+++ b/tcllib/modules/clock/iso8601.test
@@ -0,0 +1,220 @@
+# -------------------------------------------------------------------------
+# iso8601.test -*- tcl -*-
+# (C) 2013 Andreas Kupries. BSD licensed.
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+testing {
+ useLocal iso8601.tcl clock::iso8601
+}
+
+# -------------------------------------------------------------------------
+
+test clock-iso8601-1.0.0 {parse_date wrong\#args} -constraints {tcl8.5plus tcl8.5minus} -body {
+ clock::iso8601 parse_date
+} -returnCodes error -result {wrong # args: should be "clock::iso8601 parse_date string ..."}
+
+test clock-iso8601-1.0.1 {parse_date wrong\#args} -constraints {tcl8.6plus} -body {
+ clock::iso8601 parse_date
+} -returnCodes error -result {wrong # args: should be "clock::iso8601 parse_date string ?arg ...?"}
+
+test clock-iso8601-1.1.0 {parse_date, bad option} -constraints {tcl8.5plus tcl8.5minus} -body {
+ clock::iso8601 parse_date 1994-11-05 -foo x
+} -returnCodes error -result {bad switch "-foo", must be -base, -format, -gmt, -locale or -timezone}
+
+test clock-iso8601-1.1.1 {parse_date, bad option} -constraints {tcl8.6plus} -body {
+ clock::iso8601 parse_date 1994-11-05 -foo x
+} -returnCodes error -result {bad option "-foo", must be -base, -format, -gmt, -locale or -timezone}
+
+# NOTE: While listed as legal, -format is NOT. This is because the
+# command simply hands off to clock scan, and we are seeing its error
+# message. Either we do our own argument check first, or we capture
+# and rewrite the error.
+
+# -------------------------------------------------------------------------
+
+test clock-iso8601-2.0 {parse_date, bad input} -body {
+ clock::iso8601 parse_date A
+} -returnCodes error -result {not an iso8601 date string}
+
+test clock-iso8601-2.1 {parse_date} -body {
+ clock format [clock::iso8601 parse_date 1994-11-05] -format %D
+} -result 11/05/1994
+
+# -------------------------------------------------------------------------
+
+test clock-iso8601-2.0.0 {parse_date, format: 19700102, reformatted with clock format -format {%D}} -body {
+ clock format [clock::iso8601 parse_date {19700102}] -format {%D}
+} -result {01/02/1970}
+
+test clock-iso8601-2.0.1 {parse_date, format: 1970-W01-5, reformatted with clock format -format {%D}} -body {
+ clock format [clock::iso8601 parse_date {1970-W01-5}] -format {%D}
+} -result {01/02/1970}
+
+test clock-iso8601-2.1.0 {parse_date, format: 19700102, using -timezone :UTC} -body {
+ clock::iso8601 parse_date {19700102} -timezone :UTC
+} -result {86400}
+
+test clock-iso8601-2.1.1 {parse_date, format: 1970-W01-5, using -timezone :UTC} -body {
+ clock::iso8601 parse_date {1970-W01-5} -timezone :UTC
+} -result {86400}
+
+test clock-iso8601-2.2.0 {parse_date, format: 970701 (yymmdd), reformatted with clock format -format {%D}} -body {
+ clock format [clock::iso8601 parse_date {970701}] -format {%D}
+} -result {07/01/1997}
+
+test clock-iso8601-2.2.1 {parse_date, format: 1997-07, reformatted with clock format -format {%D}} -body {
+ clock format [clock::iso8601 parse_date {1997-07}] -format {%D}
+} -result {07/01/1997}
+
+test clock-iso8601-2.3.0 {parse_date, format: 970701 (yymmdd), using -timezone :UTC} -body {
+ clock::iso8601 parse_date {970701} -timezone :UTC
+} -result {867715200}
+
+test clock-iso8601-2.3.1 {parse_date, format: 1997-07, using -timezone :UTC} -body {
+ clock::iso8601 parse_date {1997-07} -timezone :UTC
+} -result {867715200}
+
+test clock-iso8601-2.4.0 {parse_date, format: 1997, reformatted with clock format -format {%D}} -body {
+ clock format [clock::iso8601 parse_date {1997}] -format {%D}
+} -result {01/01/1997}
+
+test clock-iso8601-2.4.1 {parse_date, format: 1997, reformatted with clock format -format {%D}} -body {
+ clock format [clock::iso8601 parse_date {1997}] -format {%D}
+} -result {01/01/1997}
+
+test clock-iso8601-2.5.0 {parse_date, format: 1997, using -timezone :UTC} -body {
+ clock::iso8601 parse_date {1997} -timezone :UTC
+} -result {852076800}
+
+test clock-iso8601-2.5.1 {parse_date, format: 1997-, using -timezone :UTC} -body {
+ clock::iso8601 parse_date {1997} -timezone :UTC
+} -result {852076800}
+
+# -------------------------------------------------------------------------
+
+foreach {n iso week} {
+ 00 01/01/2005 2004-W53-6
+ 01 01/02/2005 2004-W53-7
+ 02 12/31/2005 2005-W52-6
+ 03 01/01/2007 2007-W01-1
+ 04 12/30/2007 2007-W52-7
+ 05 12/31/2007 2008-W01-1
+ 06 01/01/2008 2008-W01-2
+ 07 12/28/2008 2008-W52-7
+ 08 12/29/2008 2009-W01-1
+ 09 12/30/2008 2009-W01-2
+ 10 12/31/2008 2009-W01-3
+ 11 01/01/2009 2009-W01-4
+ 12 12/31/2009 2009-W53-4
+ 13 01/01/2010 2009-W53-5
+ 14 01/02/2010 2009-W53-6
+ 15 01/03/2010 2009-W53-7
+} {
+ test clock-iso8601-2.6.$n {parse_date, format: YYYY-Www-D into %D} -body {
+ clock format [clock::iso8601 parse_date $week] -format {%D}
+ } -result $iso
+
+ test clock-iso8601-2.7.$n {parse_date, format: YYYYWwwD into %D} -body {
+ clock format [clock::iso8601 parse_date [string map {- {}} $week]] -format {%D}
+ } -result $iso
+}
+
+foreach {n iso week} {
+ 00 01/01/2007 2007-W01
+ 01 12/31/2007 2008-W01
+ 02 12/29/2008 2009-W01
+} {
+ test clock-iso8601-2.8.$n {parse_date, format: YYYY-Www into %D} -body {
+ clock format [clock::iso8601 parse_date $week] -format {%D}
+ } -result $iso
+
+ test clock-iso8601-2.9.$n {parse_date, format: YYYYWww into %D} -body {
+ clock format [clock::iso8601 parse_date [string map {- {}} $week]] -format {%D}
+ } -result $iso
+}
+
+# -------------------------------------------------------------------------
+
+test clock-iso8601-5.0.0 {parse_time wrong\#args} -constraints {tcl8.5plus tcl8.5minus} -body {
+ clock::iso8601 parse_time
+} -returnCodes error -result {wrong # args: should be "clock::iso8601 parse_time string ..."}
+
+test clock-iso8601-5.0.1 {parse_time wrong\#args} -constraints {tcl8.6plus} -body {
+ clock::iso8601 parse_time
+} -returnCodes error -result {wrong # args: should be "clock::iso8601 parse_time string ?arg ...?"}
+
+test clock-iso8601-5.1 {parse_time, bad option} -body {
+ clock::iso8601 parse_time A -foo x
+} -returnCodes error -result {not an iso8601 time string}
+
+# -------------------------------------------------------------------------
+
+test clock-iso8601-6.0.0 {parse_time, full date time} -body {
+ clock::iso8601 parse_time 2004-W33-2T18:52:24Z
+} -result {1092163944}
+
+test clock-iso8601-6.0.1 {parse_time, full time} -body {
+ clock format [clock::iso8601 parse_time 18:52:24Z] -format {%X %z} -timezone :UTC
+} -result {18:52:24 +0000}
+
+test clock-iso8601-6.1.0 {parse_time, full date time to minute and offset as +/-hh:mm} -body {
+ clock::iso8601 parse_time 1997-07-16T19:20+01:00
+} -result {869077200}
+
+test clock-iso8601-6.1.1 {parse_time, full date time to minute and offset as +/-hhmm} -body {
+ clock::iso8601 parse_time 1997-07-16T19:20+0100
+} -result {869077200}
+
+test clock-iso8601-6.2.0 {parse_time, full date time to hour and offset as +/-hh:mm} -body {
+ clock::iso8601 parse_time 1997-07-16T19+01:00
+} -result {869076000}
+
+test clock-iso8601-6.2.1 {parse_time, full date time to hour and offset as +/-hhmm} -body {
+ clock::iso8601 parse_time 1997-07-16T19+0100
+} -result {869076000}
+
+test clock-iso8601-6.3.0 {parse_time, full date time to second and offset as +/-hh:mm} -body {
+ clock::iso8601 parse_time 1997-07-16T19:20:30+01:00
+} -result {869077230}
+
+test clock-iso8601-6.3.1 {parse_time, full date time to second and offset as +/-hhmm} -body {
+ clock::iso8601 parse_time 1997-07-16T19:20:30+0100
+} -result {869077230}
+
+test clock-iso8601-6.4.0 {parse_time, full date time to minute and offset as +/-hh:mm} -body {
+ clock::iso8601 parse_time 1997-07-16T19:20:30.45+01:00
+} -returnCodes error -result {input string does not match supplied format}
+
+test clock-iso8601-6.4.1 {parse_time, full date time to minute and offset as +/-hhmm} -body {
+ clock::iso8601 parse_time 1997-07-16T19:20:30.45+0100
+} -returnCodes error -result {input string does not match supplied format}
+
+# -------------------------------------------------------------------------
+
+test clock-iso8601-7.0 {parse_time, bad input} -body {
+ clock::iso8601 parse_time A
+} -returnCodes error -result {not an iso8601 time string}
+
+test clock-iso8601-7.1 {parse_time} -body {
+ # The difference to midnight is constant.
+ # The day part is not, and there is TZ.
+ expr {[clock::iso8601 parse_time 08:15:30] -
+ [clock::iso8601 parse_time 00:00:00]}
+} -result 29730
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/clock/pkgIndex.tcl b/tcllib/modules/clock/pkgIndex.tcl
new file mode 100644
index 0000000..4ba5a8c
--- /dev/null
+++ b/tcllib/modules/clock/pkgIndex.tcl
@@ -0,0 +1,3 @@
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+package ifneeded clock::rfc2822 0.1 [list source [file join $dir rfc2822.tcl]]
+package ifneeded clock::iso8601 0.1 [list source [file join $dir iso8601.tcl]]
diff --git a/tcllib/modules/clock/rfc2822.man b/tcllib/modules/clock/rfc2822.man
new file mode 100644
index 0000000..a66aaa4
--- /dev/null
+++ b/tcllib/modules/clock/rfc2822.man
@@ -0,0 +1,27 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin clock_rfc2822 n 0.1]
+[moddesc {Date/Time Utilities}]
+[titledesc {Parsing ISO 8601 dates/times}]
+[category {Text processing}]
+[require Tcl 8.5]
+[require clock::rfc2822 [opt 0.1]]
+[description]
+
+This package provides functionality to parse dates in
+RFC 2822 format.
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd {::clock::rfc2822 parse_date}] [arg date]]
+
+This command parses an RFC2822 date string and returns
+the given date in seconds since epoch. An error is thrown
+if the command is unable to parse the date.
+
+[list_end]
+
+[vset CATEGORY clock::rfc2822]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/clock/rfc2822.pcx b/tcllib/modules/clock/rfc2822.pcx
new file mode 100644
index 0000000..51e06e2
--- /dev/null
+++ b/tcllib/modules/clock/rfc2822.pcx
@@ -0,0 +1,27 @@
+# -*- tcl -*- rfc2822.pcx
+# Syntax of the commands provided by package rfc2822.
+
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register clock::rfc2822
+pcx::tcldep 0.1 needs tcl 8.5
+
+namespace eval ::clock::rfc2822 {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+# Switches are per clock scan (Tcl 8.5), restricted subset.
+pcx::check 0.1 std ::clock::rfc2822::parse_date \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+
+# Initialization via pcx::init.
+# Use a ::rfc2822::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/clock/rfc2822.tcl b/tcllib/modules/clock/rfc2822.tcl
new file mode 100644
index 0000000..ba98fcd
--- /dev/null
+++ b/tcllib/modules/clock/rfc2822.tcl
@@ -0,0 +1,214 @@
+## -*- tcl -*-
+# # ## ### ##### ######## ############# #####################
+## Copyright (c) 2004 Kevin Kenny
+## Origin http://wiki.tcl.tk/24074
+
+# # ## ### ##### ######## ############# #####################
+## Requisites
+
+package require Tcl 8.5
+package provide clock::rfc2822 0.1
+namespace eval ::clock::rfc2822 {}
+
+# # ## ### ##### ######## ############# #####################
+## API
+
+# ::clock::rfc2822::parse_date --
+#
+# Parses a date expressed in RFC2822 format
+#
+# Parameters:
+# date - The date to parse
+#
+# Results:
+# Returns the date expressed in seconds from the Epoch, or throws
+# an error if the date could not be parsed.
+
+proc ::clock::rfc2822::parse_date { date } {
+ variable datepats
+
+ # Strip comments and excess whitespace from the date field
+
+ regsub -all -expanded {
+ \( # open parenthesis
+ (:?
+ [^()[.\.]] # character other than ()\
+ |\\. # or backslash escape
+ )* # any number of times
+ \) # close paren
+ } $date {} date
+ set date [string trim $date]
+
+ # Match the patterns in order of preference, returning the first success
+
+ foreach {regexp pat} $datepats {
+ if { [regexp -nocase $regexp $date] } {
+ return [clock scan $date -format $pat]
+ }
+ }
+
+ return -code error -errorcode {CLOCK RFC2822 BADDATE} \
+ "expected an RFC2822 date, got \"$date\""
+}
+
+
+# # ## ### ##### ######## ############# #####################
+## Internals, transient, removed after initialization.
+
+# AddDatePat --
+#
+# Internal procedure that adds a date pattern to the pattern list
+#
+# Parameters:
+# wpat - Regexp pattern that matches the weekday
+# wgrp - Format group that matches the weekday
+# ypat - Regexp pattern that matches the year
+# ygrp - Format group that matches the year
+# mdpat - Regexp pattern that matches month and day
+# mdgrp - Format group that matches month and day
+# spat - Regexp pattern that matches the seconds of the minute
+# sgrp - Format group that matches the seconds of the minute
+# zpat - Regexp pattern that matches the time zone
+# zgrp - Format group that matches the time zone
+#
+# Results:
+# None
+#
+# Side effects:
+# Adds a complete regexp and a complete [clock scan] pattern to
+# 'datepats'
+
+proc ::clock::rfc2822::AddDatePat { wpat wgrp ypat ygrp mdpat mdgrp
+ spat sgrp zpat zgrp } {
+ variable datepats
+
+ set regexp {^[[:space:]]*}
+ set pat {}
+ append regexp $wpat $mdpat {[[:space:]]+} $ypat
+ append pat $wgrp $mdgrp $ygrp
+ append regexp {[[:space:]]+\d\d?:\d\d} $spat
+ append pat { %H:%M} $sgrp
+ append regexp $zpat
+ append pat $zgrp
+ append regexp {[[:space:]]*$}
+ lappend datepats $regexp $pat
+ return
+}
+
+# InitDatePats --
+#
+# Internal procedure that initializes the set of date patterns
+# allowed in an RFC2822 date
+#
+# Parameters:
+# permissible - 1 if erroneous (but common) time zones are to be
+# allowed, 0 if they are to be rejected
+#
+# Results:
+# None.
+#
+# Side effects:
+
+proc ::clock::rfc2822::InitDatePats { permissible } {
+ # Produce formats for the observed variants of ISO2822 dates.
+ # Permissible variants come first in the list; impermissible ones
+ # come later.
+
+ # The month and day may be "%b %d" or "%d %b"
+
+ foreach mdpat {{[[:alpha:]]+[[:space:]]+\d\d?}
+ {\d\d?[[:space:]]+[[:alpha:]]+}} \
+ mdgrp {{%b %d} {%d %b}} \
+ mdperm {0 1} {
+ # The year may be two digits, or four. Four digit year is
+ # done first.
+
+ foreach ypat {{\d\d\d\d} {\d\d}} ygrp {%Y %y} {
+ # The seconds of the minute may be provided, or
+ # omitted.
+
+ foreach spat {{:\d\d} {}} sgrp {:%S {}} {
+ # The weekday may be provided or omitted. It is
+ # common but impermissible to omit the comma after
+ # the weekday name.
+
+ foreach wpat {
+ {(?:Mon|T(?:ue|hu)|Wed|Fri|S(?:at|un)),[[:space:]]+}
+ {(?:Mon|T(?:ue|hu)|Wed|Fri|S(?:at|un))[[:space:]]+}
+ {}
+ } wgrp {
+ {%a, }
+ {%a }
+ {}
+ } wperm {
+ 1
+ 0
+ 1
+ } {
+ # Time zone is defined as +/- hhmm, or as a
+ # named time zone. Other common but buggy
+ # formats are GMT+-hh:mm, a time zone name in
+ # quotation marks, and complete omission of
+ # the time zone.
+
+ foreach zpat {
+ {[[:space:]]+(?:[-+]\d\d\d\d|[[:alpha:]]+)}
+ {[[:space:]]+GMT[-+]\d\d:?\d\d}
+ {[[:space:]]+"[[:alpha:]]+"}
+ {}
+ } zgrp {
+ { %Z}
+ { GMT%Z}
+ { "%Z"}
+ {}
+ } zperm {
+ 1
+ 0
+ 0
+ 0
+ } {
+ if { ($zperm && $wperm && $mdperm)
+ == $permissible } {
+ AddDatePat $wpat $wgrp $ypat $ygrp \
+ $mdpat $mdgrp \
+ $spat $sgrp $zpat $zgrp
+ }
+ }
+ }
+ }
+ }
+ }
+ return
+}
+
+# # ## ### ##### ######## ############# #####################
+## State
+
+namespace eval ::clock::rfc2822 {
+ namespace export parse_date
+ namespace ensemble create
+
+ variable datepats {}
+}
+
+# # ## ### ##### ######## ############# #####################
+# Initialize the date patterns
+
+namespace eval ::clock::rfc2822 {
+ InitDatePats 1
+ InitDatePats 0
+ rename AddDatePat {}
+ rename InitDatePats {}
+ #puts [join $datepats \n]
+}
+
+# # ## ### ##### ######## ############# #####################
+
+return
+# Usage example, disabled
+
+if {![info exists ::argv0] || [info script] ne $::argv0} return
+puts [clock format \
+ [::clock::rfc2822::parse_date {Mon(day), 23 Aug(ust) 2004 01:23:45 UT}]]
+puts [clock format \
+ [::clock::rfc2822::parse_date "Tue, Jul 21 2009 19:37:47 GMT-0400"]]
diff --git a/tcllib/modules/clock/rfc2822.test b/tcllib/modules/clock/rfc2822.test
new file mode 100644
index 0000000..0c12c08
--- /dev/null
+++ b/tcllib/modules/clock/rfc2822.test
@@ -0,0 +1,44 @@
+# -------------------------------------------------------------------------
+# rfc2822.test -*- tcl -*-
+# (C) 2013 Andreas Kupries. BSD licensed.
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+testing {
+ useLocal rfc2822.tcl clock::rfc2822
+}
+
+# -------------------------------------------------------------------------
+
+test clock-rfc2822-1.0 {parse_date wrong\#args} -body {
+ clock::rfc2822 parse_date
+} -returnCodes error -result {wrong # args: should be "clock::rfc2822 parse_date date"}
+
+test clock-rfc2822-1.1 {parse_date wrong\#args} -body {
+ clock::rfc2822 parse_date D X
+} -returnCodes error -result {wrong # args: should be "clock::rfc2822 parse_date date"}
+
+# -------------------------------------------------------------------------
+
+test clock-rfc2822-2.0 {parse_date, bad input} -body {
+ clock::rfc2822 parse_date D
+} -returnCodes error -result {expected an RFC2822 date, got "D"}
+
+test clock-rfc2822-2.1 {parse_date} -body {
+ clock::rfc2822 parse_date {Fri, 09 Sep 2005 13:51:39 -0700}
+} -result 1126299099
+
+# -------------------------------------------------------------------------
+testsuiteCleanup
+return
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/cmdline/ChangeLog b/tcllib/modules/cmdline/ChangeLog
new file mode 100644
index 0000000..949f88c
--- /dev/null
+++ b/tcllib/modules/cmdline/ChangeLog
@@ -0,0 +1,340 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2013-01-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * typedCmdline.test: Fixed test results of typed-cmdline-6.14 for
+ Tcl 8.6 and higher. Rewritten to use constraints properly
+ instead of via conditional execution.
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-02-23 Andreas Kupries <andreask@activestate.com>
+
+ * cmdline.man: [Bug 3189786]: Fixed mishandling of suffixes .arg
+ * cmdline.tcl: and .secret. The '.'s were not properly quoted,
+ * cmdline.test: allowing any character, thus mishandling options
+ * pkgIndex.tcl: like 'myarg' or 'mysecret'. Extended the testsuite.
+ Bumped version to 1.3.3.
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-09-08 Andreas Kupries <andreask@activestate.com>
+
+ * cmdline.man: [Bug 3041989]: Added the missing documentation for
+ * cmdline.tcl: the result of command 'getoptions'. Documented the
+ * cmdline.test: handling of the implicit options -?, -help, and
+ * pkgIndex.tcl: --. Added help text for option '--'. Bumped to
+ version 1.3.2.
+
+2010-05-27 Andreas Kupries <andreask@activestate.com>
+
+ * cmdline.man: [Bug 2988486]: Added a note about ::argv handling
+ to the documentation, i.e. us not keeping ::argc synchronized.
+
+2010-03-10 Elchonon Edelson <eee@activestate.com>
+
+ * cmdline.man: Fixed typo.
+
+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 ========================
+ *
+
+2008-07-09 Andreas Kupries <andreask@activestate.com>
+
+ * cmdline.tcl: Fixed problem of creative writing to variable
+ * cmdline.man: 'dummy' in package initialization code by defining
+ * pkgIndex.tcl: the variable in the namespace for the time it is
+ needed. This fixes the [Bug 2014325]. Version bumped to 1.3.1.
+
+2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cmdline.pcx: New file. Syntax definitions for the public
+ commands of the cmdline package.
+
+2008-03-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cmdline.tcl: Added pragma forcing the tclchecker to ignore an
+ intentional and caught badKey problem used to introspect the
+ runtime.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * typedCmdline.test: Updated to changes in Tcl 8.5 head.
+
+2007-03-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cmdline.man: Fixed all warnings due to use of now deprecated
+ commands. Added a section about how to give feedback.
+
+2007-01-11 Andreas Kupries <andreask@activestate.com>
+
+ * cmdline.man: Extended the list of keywords in the documentation.
+ [SF Tcllib Bug 1615252].
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cmdline.tcl: Bumped to version 1.3, due internal rewrite
+ * cmdline.man: (Folding of typedCmdline into main file).
+ * pkgIndex.tcl:
+
+2006-09-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cmdline.test: Added 'exit' to the scripts executed in
+ sub-shells, to make them usable with 'wish'-type shells as well.
+
+2006-04-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cmdline.tcl: Added the contents of typedCmdline.tcl to this file
+ (appended). It was loaded anyway, always, its procedures used
+ the same namespace, a separation does not make much sense. It
+ also makes deployment of the package as Tcl Module trivial,
+ i.e. this squashes the need to use some virtual filesystem to
+ keep everything together.
+
+ * typedCmdline.tcl: File removed. Contents appended to
+ cmdline.tcl, s.a.
+
+2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cmdline.test: Fixed use and cleanup of temp. files.
+ * typedCmdline.test: Fixed use of duplicate test names.
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cmdline.test: More boilerplate simplified via use of test support.
+ * typedCmdline.test:
+
+2006-01-21 Andreas Kupries <akupries@shaw.ca>
+
+ * typedCmdline.test: Replaced usage of the made-up command
+ 'queryConstraint' with 'testConstraint'.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * typedCmdline.test: Hooked into the new common test support
+ * cmdline.test: code.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2004-11-08 Andreas Kupries <andreask@activestate.com>
+
+ * cmdline.tcl (::cmdline::getKnownOpt): Changed generation of
+ error message for unknown option, re-added the prefix-dash to
+ the option name. See AS Bugzilla Report 32363
+ [http://bugs.activestate.com/show_bug.cgi?id=32363].
+ * cmdline.test: Updated testsuite to new error message.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-08-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * typedCmdline.test: Made test 6.14 conditional on version of Tcl,
+ needs different result for 8.5+.
+
+2004-08-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ChangeLog: Typo police.
+ * cmdline.tcl:
+ * cmdline.man:
+ * typedCmdline.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * typedCmdline.test: Fixed the problems of the testsuite with
+ * cmdline.test: Tcl 8.5. It relied on the order of data
+ returned by [array get].
+
+2003-08-19 David N. Welton <davidw@dedasys.com>
+
+ * cmdline.man: Added an example. Feel free to change/improve it,
+ but this package really needed one to show the standard usage
+ pattern.
+
+2003-08-07 Andreas Kupries <andreask@activestate.com>
+
+ * Bumped version information to 1.2.2 for the bugfix.
+
+2003-08-06 Andreas Kupries <andreask@activestate.com>
+
+ * cmdline.tcl (getfiles): Using the [string map] fix still had
+ problems, when mixing back- and forward slashes. Now using [file
+ join] on the pattern. This removed all problems with the
+ quoting. I.e. this operation pseudo-normalizes the path. Got the
+ trick from Jeff Hobbs.
+
+2003-08-06 Andreas Kupries <andreask@activestate.com>
+
+ * cmdline.test: Added a test for the backslash quoting behaviour.
+
+ * cmdline.tcl (getfiles): Corrected a bogus attempt to quote
+ backslashes in file patterns on the windows platform.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * typedCmdline.tcl: Fixed bug #614591. See also last entry, this
+ file was forgotten.
+
+2003-04-10 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl:
+ * cmdline.tcl:
+ * cmdline.man: Fixed bug #648679. Fixed bug #614591. Set version
+ of the package to to 1.2.1
+
+ * urn-scheme.tcl: Fixed bug #614591. Set version
+ of the package to to 1.2.1
+
+2003-02-23 David N. Welton <davidw@dedasys.com>
+
+ * cmdline.tcl (cmdline::getfiles): Use [string map] instead of
+ [regsub].
+
+2002-08-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * typeCmdline.tcl: Updated 'info exist' to 'info exists'.
+
+2002-04-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Applied patch #540313 on behalf of Melissa Chawla
+ <melissachawla@yahoo.com> and Don Porter
+ <dgp@users.sourceforge.net>.
+
+ * cmdline.test:
+ * cmdline.tcl: Added getKnownOpt and getKnownOptions procedures
+ to the API. The procedures offer a way for arguments that are
+ not in the optionList to be ignored. This way, you can have
+ two independent locations in your application where
+ command line arguments are parsed. I bumped the package
+ version to 1.2.
+
+ * cmdline.man: Updated documentation.
+
+2002-04-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cmdline.man: Added doctools manpage.
+
+2001-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cmdline.n:
+ * cmdline.tcl:
+ * pkgIndex.tcl: Version up to 1.1.1
+
+2001-10-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cmdline.tcl: Corrected the inline documentation to reflect what
+ is actually happening. Problem reported by Glenn Jackman
+ <glennjnn@users.sourceforge.net>, Item #46650.
+
+2001-07-31 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cmdline.n: Added manpage [446584].
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * typedCmdline.tcl:
+ * cmdline.tcl: Fixed dubious code reported by frink.
+
+2000-05-03 Brent Welch <welch@scriptics.com>
+
+ * cmdline.tcl: Changed cmdline::getopt to set boolean arguments to
+ 0 or 1 explicitly. Previously it just set the value to "" if it
+ was present, or did nothing. This fixes the -verbose command
+ line bug in connect.
+
+2000-04-07 Eric Melski <ericm@scriptics.com>
+
+ * typedCmdline.test: Changed sourcing bits at start of file to
+ work better with updated file dependencies.
+
+ * typedCmdline.tcl: Removed "package provide"; that should occur
+ only in one file per package. Reformatted function headers to
+ comply with Tcl coding standard. Renamed "cmdline::lsearch" to
+ "cmdline::prefixSearch" to avoid confusion, and removed code thus
+ made obsolete.
+
+ * cmdline.tcl: Added call to source typedCmdline.tcl
+
+2000-04-04 Ross Mohn <rpmohn@panix.com>
+
+ * typedCmdline.tcl: Added typed versions of getopt, getoptions,
+ and usage. Types supported are all character classes available
+ for the Tcl "string in" command.
+
+ * typedCmdline.test: Added tests for typed procedures.
+
+ * cmdline.tcl: Corrected some documentation errors and omissions.
+
+2000-03-09 Eric Melski <ericm@scriptics.com>
+
+ * cmdline.test: Adapted tests to work with tcllib test framework.
+
+1999-10-29 Scott Stanton <stanton@scriptics.com>
+
+ * cmdline.tcl: Fixed bug where options that contained regexp
+ special characters would cause an error. Cleaned up lots of
+ messy code. Added test suite.
+
diff --git a/tcllib/modules/cmdline/cmdline.man b/tcllib/modules/cmdline/cmdline.man
new file mode 100644
index 0000000..facbb4e
--- /dev/null
+++ b/tcllib/modules/cmdline/cmdline.man
@@ -0,0 +1,204 @@
+[manpage_begin cmdline n 1.5]
+[keywords {argument processing}]
+[keywords argv]
+[keywords argv0]
+[keywords {cmdline processing}]
+[keywords {command line processing}]
+[moddesc {Command line and option processing}]
+[titledesc {Procedures to process command lines and options.}]
+[category {Programming tools}]
+[require Tcl 8.2]
+[require cmdline [opt 1.3.3]]
+[description]
+
+This package provides commands to parse command lines and options.
+
+[section {::argv handling}]
+
+One of the most common variables this package will be used with is
+[var ::argv], which holds the command line of the current
+application. This variable has a companion [var ::argc] which is
+initialized to the number of elements in [var ::argv] at the beginning
+of the application.
+
+[para]
+
+The commands in this package will [emph not] modify the [var ::argc]
+companion when called with [var ::argv]. Keeping the value consistent,
+if such is desired or required, is the responsibility of the caller.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::cmdline::getopt] [arg argvVar] [arg optstring] [arg optVar] [arg valVar]]
+
+This command works in a fashion like the standard C based [cmd getopt]
+function. Given an option string and a pointer to an array of args
+this command will process the first argument and return info on how to
+proceed. The command returns 1 if an option was found, 0 if no more
+options were found, and -1 if an error occurred.
+
+[para]
+
+[arg argvVar] contains the name of the list of arguments to
+process. If options are found the list is modified and the processed
+arguments are removed from the start of the list.
+
+[para]
+
+[arg optstring] contains a list of command options that the
+application will accept. If the option ends in ".arg" the command
+will use the next argument as an argument to the option, or extract it
+from the current argument, if it is of the form "option=value".
+Otherwise the option is a boolean that is set to 1 if present.
+
+[para]
+
+[arg optVar] refers to the variable the command will store the found
+option into (without the leading '-' and without the .arg extension).
+
+[para]
+
+[arg valVar] refers to the variable to store either the value for the
+specified option into upon success or an error message in the case of
+failure. The stored value comes from the command line for .arg
+options, otherwise the value is 1.
+
+[call [cmd ::cmdline::getKnownOpt] [arg argvVar] [arg optstring] [arg optVar] [arg valVar]]
+
+Like [cmd ::cmdline::getopt], but ignores any unknown options in the
+input.
+
+[call [cmd ::cmdline::getoptions] [arg arglistVar] [arg optlist] [opt [arg usage]]]
+
+Processes the set of command line options found in the list variable
+named by [arg arglistVar] and fills in defaults for those not
+specified. This also generates an error message that lists the
+allowed flags if an incorrect flag is specified. The optional
+[arg usage]-argument contains a string to include in front of the
+generated message. If not present it defaults to "options:".
+
+[para]
+
+[arg optlist] contains a list of lists where each element specifies an
+option in the form: [arg flag] [arg default] [arg comment].
+
+[para]
+
+If [arg flag] ends in ".arg" then the value is taken from the command
+line. Otherwise it is a boolean and appears in the result if present
+on the command line. If [arg flag] ends in ".secret", it will not be
+displayed in the usage.
+
+[para]
+
+The options [option -?], [option -help], and [option --] are
+implicitly understood. The first two abort option processing by
+throwing an error and force the generation of the usage message,
+whereas the the last aborts option processing without an error,
+leaving all arguments coming after for regular processing, even if
+starting with a dash.
+
+[para]
+
+The result of the command is a dictionary mapping all options to their
+values, be they user-specified or defaults.
+
+[call [cmd ::cmdline::getKnownOptions] [arg arglistVar] [arg optlist] [opt [arg usage]]]
+
+Like [cmd ::cmdline::getoptions], but ignores any unknown options in the
+input.
+
+[call [cmd ::cmdline::usage] [arg optlist] [opt [arg usage]]]
+
+Generates and returns an error message that lists the allowed
+flags. [arg optlist] is defined as for
+[cmd ::cmdline::getoptions]. The optional [arg usage]-argument
+contains a string to include in front of the generated message. If not
+present it defaults to "options:".
+
+[call [cmd ::cmdline::getfiles] [arg patterns] [arg quiet]]
+
+Given a list of file [arg patterns] this command computes the set of
+valid files. On windows, file globbing is performed on each argument.
+On Unix, only file existence is tested. If a file argument produces
+no valid files, a warning is optionally generated (set [arg quiet] to
+true).
+
+[para]
+
+This code also uses the full path for each file. If not given it
+prepends the current working directory to the filename. This ensures
+that these files will never conflict with files in a wrapped zip
+file. The last sentence refers to the pro-tools.
+
+[call [cmd ::cmdline::getArgv0]]
+
+This command returns the "sanitized" version of [arg argv0]. It will
+strip off the leading path and removes the extension ".bin". The
+latter is used by the pro-apps because they must be wrapped by a shell
+script.
+
+[list_end]
+
+[subsection {Error Codes}]
+
+Starting with version 1.5 all errors thrown by the package have a
+proper [var ::errorCode] for use with Tcl's [cmd try] command. This
+code always has the word [const CMDLINE] as its first element.
+
+[section {EXAMPLES}]
+
+[example {
+ package require Tcl 8.5
+ package require try ;# Tcllib.
+ package require cmdline 1.5 ;# First version with proper error-codes.
+
+ # Notes:
+ # - Tcl 8.6+ has 'try' as a builtin command and therefore does not
+ # need the 'try' package.
+ # - Before Tcl 8.5 we cannot support 'try' and have to use 'catch'.
+ # This then requires a dedicated test (if) on the contents of
+ # ::errorCode to separate the CMDLINE USAGE signal from actual errors.
+
+ set options {
+ {a "set the atime only"}
+ {m "set the mtime only"}
+ {c "do not create non-existent files"}
+ {r.arg "" "use time from ref_file"}
+ {t.arg -1 "use specified time"}
+ }
+ set usage ": MyCommandName\
+ \[options] filename ...\noptions:"
+
+ try {
+ array set params [::cmdline::getoptions argv $options $usage]
+ } trap {CMDLINE USAGE} {msg o} {
+ # Trap the usage signal, print the message, and exit the application.
+ # Note: Other errors are not caught and passed through to higher levels!
+ puts $msg
+ exit 1
+ }
+
+ if { $params(a) } { set set_atime "true" }
+ set has_t [expr {$params(t) != -1}]
+ set has_r [expr {[string length $params(r)] > 0}]
+ if {$has_t && $has_r} {
+ return -code error "Cannot specify both -r and -t"
+ } elseif {$has_t} {
+ ...
+ }
+}]
+
+[para]
+
+This example, taken (and slightly modified) from the package
+[package fileutil], shows how to use cmdline. First, a list of
+options is created, then the 'args' list is passed to cmdline for
+processing. Subsequently, different options are checked to see if
+they have been passed to the script, and what their value is.
+
+[vset CATEGORY cmdline]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/cmdline/cmdline.pcx b/tcllib/modules/cmdline/cmdline.pcx
new file mode 100644
index 0000000..4d631d5
--- /dev/null
+++ b/tcllib/modules/cmdline/cmdline.pcx
@@ -0,0 +1,78 @@
+# -*- tcl -*- cmdline.pcx
+# Syntax of the commands provided by package cmdline.
+
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register cmdline
+pcx::tcldep 1.3 needs tcl 8.2
+
+namespace eval ::cmdline {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.3 std ::cmdline::getArgv0 \
+ {checkSimpleArgs 0 0 {}}
+pcx::check 1.3 std ::cmdline::getKnownOpt \
+ {checkSimpleArgs 4 4 {
+ checkVarName
+ checkList
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 1.3 std ::cmdline::getKnownOptions \
+ {checkSimpleArgs 2 3 {
+ checkVarName
+ checkList
+ checkWord
+ }}
+pcx::check 1.3 std ::cmdline::getfiles \
+ {checkSimpleArgs 2 2 {
+ {checkListValues 1 -1 checkPattern}
+ checkBoolean
+ }}
+pcx::check 1.3 std ::cmdline::getopt \
+ {checkSimpleArgs 4 4 {
+ checkVarName
+ checkList
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 1.3 std ::cmdline::getoptions \
+ {checkSimpleArgs 2 3 {
+ checkVarName
+ checkList
+ checkWord
+ }}
+pcx::check 1.3 std ::cmdline::typedGetopt \
+ {checkSimpleArgs 4 4 {
+ checkVarName
+ checkList
+ checkVarNameWrite
+ checkVarNameWrite
+ }}
+pcx::check 1.3 std ::cmdline::typedGetoptions \
+ {checkSimpleArgs 2 3 {
+ checkVarName
+ checkList
+ checkWord
+ }}
+pcx::check 1.3 std ::cmdline::typedUsage \
+ {checkSimpleArgs 1 2 {
+ checkList
+ checkWord
+ }}
+pcx::check 1.3 std ::cmdline::usage \
+ {checkSimpleArgs 1 2 {
+ checkList
+ checkWord
+ }}
+
+# Initialization via pcx::init.
+# Use a ::cmdline::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/cmdline/cmdline.tcl b/tcllib/modules/cmdline/cmdline.tcl
new file mode 100644
index 0000000..0df7164
--- /dev/null
+++ b/tcllib/modules/cmdline/cmdline.tcl
@@ -0,0 +1,912 @@
+# cmdline.tcl --
+#
+# This package provides a utility for parsing command line
+# arguments that are processed by our various applications.
+# It also includes a utility routine to determine the
+# application name for use in command line errors.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2001-2015 by Andreas Kupries <andreas_kupries@users.sf.net>.
+# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com>
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $
+
+package require Tcl 8.2
+package provide cmdline 1.5
+
+namespace eval ::cmdline {
+ namespace export getArgv0 getopt getKnownOpt getfiles getoptions \
+ getKnownOptions usage
+}
+
+# ::cmdline::getopt --
+#
+# The cmdline::getopt works in a fashion like the standard
+# C based getopt function. Given an option string and a
+# pointer to an array or args this command will process the
+# first argument and return info on how to proceed.
+#
+# Arguments:
+# argvVar Name of the argv list that you
+# want to process. If options are found the
+# arg list is modified and the processed arguments
+# are removed from the start of the list.
+# optstring A list of command options that the application
+# will accept. If the option ends in ".arg" the
+# getopt routine will use the next argument as
+# an argument to the option. Otherwise the option
+# is a boolean that is set to 1 if present.
+# optVar The variable pointed to by optVar
+# contains the option that was found (without the
+# leading '-' and without the .arg extension).
+# valVar Upon success, the variable pointed to by valVar
+# contains the value for the specified option.
+# This value comes from the command line for .arg
+# options, otherwise the value is 1.
+# If getopt fails, the valVar is filled with an
+# error message.
+#
+# Results:
+# The getopt function returns 1 if an option was found, 0 if no more
+# options were found, and -1 if an error occurred.
+
+proc ::cmdline::getopt {argvVar optstring optVar valVar} {
+ upvar 1 $argvVar argsList
+ upvar 1 $optVar option
+ upvar 1 $valVar value
+
+ set result [getKnownOpt argsList $optstring option value]
+
+ if {$result < 0} {
+ # Collapse unknown-option error into any-other-error result.
+ set result -1
+ }
+ return $result
+}
+
+# ::cmdline::getKnownOpt --
+#
+# The cmdline::getKnownOpt works in a fashion like the standard
+# C based getopt function. Given an option string and a
+# pointer to an array or args this command will process the
+# first argument and return info on how to proceed.
+#
+# Arguments:
+# argvVar Name of the argv list that you
+# want to process. If options are found the
+# arg list is modified and the processed arguments
+# are removed from the start of the list. Note that
+# unknown options and the args that follow them are
+# left in this list.
+# optstring A list of command options that the application
+# will accept. If the option ends in ".arg" the
+# getopt routine will use the next argument as
+# an argument to the option. Otherwise the option
+# is a boolean that is set to 1 if present.
+# optVar The variable pointed to by optVar
+# contains the option that was found (without the
+# leading '-' and without the .arg extension).
+# valVar Upon success, the variable pointed to by valVar
+# contains the value for the specified option.
+# This value comes from the command line for .arg
+# options, otherwise the value is 1.
+# If getopt fails, the valVar is filled with an
+# error message.
+#
+# Results:
+# The getKnownOpt function returns 1 if an option was found,
+# 0 if no more options were found, -1 if an unknown option was
+# encountered, and -2 if any other error occurred.
+
+proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} {
+ upvar 1 $argvVar argsList
+ upvar 1 $optVar option
+ upvar 1 $valVar value
+
+ # default settings for a normal return
+ set value ""
+ set option ""
+ set result 0
+
+ # check if we're past the end of the args list
+ if {[llength $argsList] != 0} {
+
+ # if we got -- or an option that doesn't begin with -, return (skipping
+ # the --). otherwise process the option arg.
+ switch -glob -- [set arg [lindex $argsList 0]] {
+ "--" {
+ set argsList [lrange $argsList 1 end]
+ }
+ "--*" -
+ "-*" {
+ set option [string range $arg 1 end]
+ if {[string equal [string range $option 0 0] "-"]} {
+ set option [string range $arg 2 end]
+ }
+
+ # support for format: [-]-option=value
+ set idx [string first "=" $option 1]
+ if {$idx != -1} {
+ set _val [string range $option [expr {$idx+1}] end]
+ set option [string range $option 0 [expr {$idx-1}]]
+ }
+
+ if {[lsearch -exact $optstring $option] != -1} {
+ # Booleans are set to 1 when present
+ set value 1
+ set result 1
+ set argsList [lrange $argsList 1 end]
+ } elseif {[lsearch -exact $optstring "$option.arg"] != -1} {
+ set result 1
+ set argsList [lrange $argsList 1 end]
+
+ if {[info exists _val]} {
+ set value $_val
+ } elseif {[llength $argsList]} {
+ set value [lindex $argsList 0]
+ set argsList [lrange $argsList 1 end]
+ } else {
+ set value "Option \"$option\" requires an argument"
+ set result -2
+ }
+ } else {
+ # Unknown option.
+ set value "Illegal option \"-$option\""
+ set result -1
+ }
+ }
+ default {
+ # Skip ahead
+ }
+ }
+ }
+
+ return $result
+}
+
+# ::cmdline::getoptions --
+#
+# Process a set of command line options, filling in defaults
+# for those not specified. This also generates an error message
+# that lists the allowed flags if an incorrect flag is specified.
+#
+# Arguments:
+# arglistVar The name of the argument list, typically argv.
+# We remove all known options and their args from it.
+# optlist A list-of-lists where each element specifies an option
+# in the form:
+# (where flag takes no argument)
+# flag comment
+#
+# (or where flag takes an argument)
+# flag default comment
+#
+# If flag ends in ".arg" then the value is taken from the
+# command line. Otherwise it is a boolean and appears in
+# the result if present on the command line. If flag ends
+# in ".secret", it will not be displayed in the usage.
+# usage Text to include in the usage display. Defaults to
+# "options:"
+#
+# Results
+# Name value pairs suitable for using with array set.
+
+proc ::cmdline::getoptions {arglistVar optlist {usage options:}} {
+ upvar 1 $arglistVar argv
+
+ set opts [GetOptionDefaults $optlist result]
+
+ set argc [llength $argv]
+ while {[set err [getopt argv $opts opt arg]]} {
+ if {$err < 0} {
+ set result(?) ""
+ break
+ }
+ set result($opt) $arg
+ }
+ if {[info exist result(?)] || [info exists result(help)]} {
+ Error [usage $optlist $usage] USAGE
+ }
+ return [array get result]
+}
+
+# ::cmdline::getKnownOptions --
+#
+# Process a set of command line options, filling in defaults
+# for those not specified. This ignores unknown flags, but generates
+# an error message that lists the correct usage if a known option
+# is used incorrectly.
+#
+# Arguments:
+# arglistVar The name of the argument list, typically argv. This
+# We remove all known options and their args from it.
+# optlist A list-of-lists where each element specifies an option
+# in the form:
+# flag default comment
+# If flag ends in ".arg" then the value is taken from the
+# command line. Otherwise it is a boolean and appears in
+# the result if present on the command line. If flag ends
+# in ".secret", it will not be displayed in the usage.
+# usage Text to include in the usage display. Defaults to
+# "options:"
+#
+# Results
+# Name value pairs suitable for using with array set.
+
+proc ::cmdline::getKnownOptions {arglistVar optlist {usage options:}} {
+ upvar 1 $arglistVar argv
+
+ set opts [GetOptionDefaults $optlist result]
+
+ # As we encounter them, keep the unknown options and their
+ # arguments in this list. Before we return from this procedure,
+ # we'll prepend these args to the argList so that the application
+ # doesn't lose them.
+
+ set unknownOptions [list]
+
+ set argc [llength $argv]
+ while {[set err [getKnownOpt argv $opts opt arg]]} {
+ if {$err == -1} {
+ # Unknown option.
+
+ # Skip over any non-option items that follow it.
+ # For now, add them to the list of unknownOptions.
+ lappend unknownOptions [lindex $argv 0]
+ set argv [lrange $argv 1 end]
+ while {([llength $argv] != 0) \
+ && ![string match "-*" [lindex $argv 0]]} {
+ lappend unknownOptions [lindex $argv 0]
+ set argv [lrange $argv 1 end]
+ }
+ } elseif {$err == -2} {
+ set result(?) ""
+ break
+ } else {
+ set result($opt) $arg
+ }
+ }
+
+ # Before returning, prepend the any unknown args back onto the
+ # argList so that the application doesn't lose them.
+ set argv [concat $unknownOptions $argv]
+
+ if {[info exist result(?)] || [info exists result(help)]} {
+ Error [usage $optlist $usage] USAGE
+ }
+ return [array get result]
+}
+
+# ::cmdline::GetOptionDefaults --
+#
+# This internal procedure processes the option list (that was passed to
+# the getopt or getKnownOpt procedure). The defaultArray gets an index
+# for each option in the option list, the value of which is the option's
+# default value.
+#
+# Arguments:
+# optlist A list-of-lists where each element specifies an option
+# in the form:
+# flag default comment
+# If flag ends in ".arg" then the value is taken from the
+# command line. Otherwise it is a boolean and appears in
+# the result if present on the command line. If flag ends
+# in ".secret", it will not be displayed in the usage.
+# defaultArrayVar The name of the array in which to put argument defaults.
+#
+# Results
+# Name value pairs suitable for using with array set.
+
+proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} {
+ upvar 1 $defaultArrayVar result
+
+ set opts {? help}
+ foreach opt $optlist {
+ set name [lindex $opt 0]
+ if {[regsub -- {\.secret$} $name {} name] == 1} {
+ # Need to hide this from the usage display and getopt
+ }
+ lappend opts $name
+ if {[regsub -- {\.arg$} $name {} name] == 1} {
+
+ # Set defaults for those that take values.
+
+ set default [lindex $opt 1]
+ set result($name) $default
+ } else {
+ # The default for booleans is false
+ set result($name) 0
+ }
+ }
+ return $opts
+}
+
+# ::cmdline::usage --
+#
+# Generate an error message that lists the allowed flags.
+#
+# Arguments:
+# optlist As for cmdline::getoptions
+# usage Text to include in the usage display. Defaults to
+# "options:"
+#
+# Results
+# A formatted usage message
+
+proc ::cmdline::usage {optlist {usage {options:}}} {
+ set str "[getArgv0] $usage\n"
+ foreach opt [concat $optlist \
+ {{- "Forcibly stop option processing"} {help "Print this message"} {? "Print this message"}}] {
+ set name [lindex $opt 0]
+ if {[regsub -- {\.secret$} $name {} name] == 1} {
+ # Hidden option
+ continue
+ }
+ if {[regsub -- {\.arg$} $name {} name] == 1} {
+ set default [lindex $opt 1]
+ set comment [lindex $opt 2]
+ append str [format " %-20s %s <%s>\n" "-$name value" \
+ $comment $default]
+ } else {
+ set comment [lindex $opt 1]
+ append str [format " %-20s %s\n" "-$name" $comment]
+ }
+ }
+ return $str
+}
+
+# ::cmdline::getfiles --
+#
+# Given a list of file arguments from the command line, compute
+# the set of valid files. On windows, file globbing is performed
+# on each argument. On Unix, only file existence is tested. If
+# a file argument produces no valid files, a warning is optionally
+# generated.
+#
+# This code also uses the full path for each file. If not
+# given it prepends [pwd] to the filename. This ensures that
+# these files will never conflict with files in our zip file.
+#
+# Arguments:
+# patterns The file patterns specified by the user.
+# quiet If this flag is set, no warnings will be generated.
+#
+# Results:
+# Returns the list of files that match the input patterns.
+
+proc ::cmdline::getfiles {patterns quiet} {
+ set result {}
+ if {$::tcl_platform(platform) == "windows"} {
+ foreach pattern $patterns {
+ set pat [file join $pattern]
+ set files [glob -nocomplain -- $pat]
+ if {$files == {}} {
+ if {! $quiet} {
+ puts stdout "warning: no files match \"$pattern\""
+ }
+ } else {
+ foreach file $files {
+ lappend result $file
+ }
+ }
+ }
+ } else {
+ set result $patterns
+ }
+ set files {}
+ foreach file $result {
+ # Make file an absolute path so that we will never conflict
+ # with files that might be contained in our zip file.
+ set fullPath [file join [pwd] $file]
+
+ if {[file isfile $fullPath]} {
+ lappend files $fullPath
+ } elseif {! $quiet} {
+ puts stdout "warning: no files match \"$file\""
+ }
+ }
+ return $files
+}
+
+# ::cmdline::getArgv0 --
+#
+# This command returns the "sanitized" version of argv0. It will strip
+# off the leading path and remove the ".bin" extensions that our apps
+# use because they must be wrapped by a shell script.
+#
+# Arguments:
+# None.
+#
+# Results:
+# The application name that can be used in error messages.
+
+proc ::cmdline::getArgv0 {} {
+ global argv0
+
+ set name [file tail $argv0]
+ return [file rootname $name]
+}
+
+##
+# ### ### ### ######### ######### #########
+##
+# Now the typed versions of the above commands.
+##
+# ### ### ### ######### ######### #########
+##
+
+# typedCmdline.tcl --
+#
+# This package provides a utility for parsing typed command
+# line arguments that may be processed by various applications.
+#
+# Copyright (c) 2000 by Ross Palmer Mohn.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $
+
+namespace eval ::cmdline {
+ namespace export typedGetopt typedGetoptions typedUsage
+
+ # variable cmdline::charclasses --
+ #
+ # Create regexp list of allowable character classes
+ # from "string is" error message.
+ #
+ # Results:
+ # String of character class names separated by "|" characters.
+
+ variable charclasses
+ #checker exclude badKey
+ catch {string is . .} charclasses
+ variable dummy
+ regexp -- {must be (.+)$} $charclasses dummy charclasses
+ regsub -all -- {, (or )?} $charclasses {|} charclasses
+ unset dummy
+}
+
+# ::cmdline::typedGetopt --
+#
+# The cmdline::typedGetopt works in a fashion like the standard
+# C based getopt function. Given an option string and a
+# pointer to a list of args this command will process the
+# first argument and return info on how to proceed. In addition,
+# you may specify a type for the argument to each option.
+#
+# Arguments:
+# argvVar Name of the argv list that you want to process.
+# If options are found, the arg list is modified
+# and the processed arguments are removed from the
+# start of the list.
+#
+# optstring A list of command options that the application
+# will accept. If the option ends in ".xxx", where
+# xxx is any valid character class to the tcl
+# command "string is", then typedGetopt routine will
+# use the next argument as a typed argument to the
+# option. The argument must match the specified
+# character classes (e.g. integer, double, boolean,
+# xdigit, etc.). Alternatively, you may specify
+# ".arg" for an untyped argument.
+#
+# optVar Upon success, the variable pointed to by optVar
+# contains the option that was found (without the
+# leading '-' and without the .xxx extension). If
+# typedGetopt fails the variable is set to the empty
+# string. SOMETIMES! Different for each -value!
+#
+# argVar Upon success, the variable pointed to by argVar
+# contains the argument for the specified option.
+# If typedGetopt fails, the variable is filled with
+# an error message.
+#
+# Argument type syntax:
+# Option that takes no argument.
+# foo
+#
+# Option that takes a typeless argument.
+# foo.arg
+#
+# Option that takes a typed argument. Allowable types are all
+# valid character classes to the tcl command "string is".
+# Currently must be one of alnum, alpha, ascii, control,
+# boolean, digit, double, false, graph, integer, lower, print,
+# punct, space, true, upper, wordchar, or xdigit.
+# foo.double
+#
+# Option that takes an argument from a list.
+# foo.(bar|blat)
+#
+# Argument quantifier syntax:
+# Option that takes an optional argument.
+# foo.arg?
+#
+# Option that takes a list of arguments terminated by "--".
+# foo.arg+
+#
+# Option that takes an optional list of arguments terminated by "--".
+# foo.arg*
+#
+# Argument quantifiers work on all argument types, so, for
+# example, the following is a valid option specification.
+# foo.(bar|blat|blah)?
+#
+# Argument syntax miscellany:
+# Options may be specified on the command line using a unique,
+# shortened version of the option name. Given that program foo
+# has an option list of {bar.alpha blah.arg blat.double},
+# "foo -b fob" returns an error, but "foo -ba fob"
+# successfully returns {bar fob}
+#
+# Results:
+# The typedGetopt function returns one of the following:
+# 1 a valid option was found
+# 0 no more options found to process
+# -1 invalid option
+# -2 missing argument to a valid option
+# -3 argument to a valid option does not match type
+#
+# Known Bugs:
+# When using options which include special glob characters,
+# you must use the exact option. Abbreviating it can cause
+# an error in the "cmdline::prefixSearch" procedure.
+
+proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} {
+ variable charclasses
+
+ upvar $argvVar argsList
+
+ upvar $optVar retvar
+ upvar $argVar optarg
+
+ # default settings for a normal return
+ set optarg ""
+ set retvar ""
+ set retval 0
+
+ # check if we're past the end of the args list
+ if {[llength $argsList] != 0} {
+
+ # if we got -- or an option that doesn't begin with -, return (skipping
+ # the --). otherwise process the option arg.
+ switch -glob -- [set arg [lindex $argsList 0]] {
+ "--" {
+ set argsList [lrange $argsList 1 end]
+ }
+
+ "-*" {
+ # Create list of options without their argument extensions
+
+ set optstr ""
+ foreach str $optstring {
+ lappend optstr [file rootname $str]
+ }
+
+ set _opt [string range $arg 1 end]
+
+ set i [prefixSearch $optstr [file rootname $_opt]]
+ if {$i != -1} {
+ set opt [lindex $optstring $i]
+
+ set quantifier "none"
+ if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} {
+ set opt [string range $opt 0 end-1]
+ }
+
+ if {[string first . $opt] == -1} {
+ set retval 1
+ set retvar $opt
+ set argsList [lrange $argsList 1 end]
+
+ } elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass]
+ || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
+ if {[string equal arg $charclass]} {
+ set type arg
+ } elseif {[regexp -- "^($charclasses)\$" $charclass]} {
+ set type class
+ } else {
+ set type oneof
+ }
+
+ set argsList [lrange $argsList 1 end]
+ set opt [file rootname $opt]
+
+ while {1} {
+ if {[llength $argsList] == 0
+ || [string equal "--" [lindex $argsList 0]]} {
+ if {[string equal "--" [lindex $argsList 0]]} {
+ set argsList [lrange $argsList 1 end]
+ }
+
+ set oneof ""
+ if {$type == "arg"} {
+ set charclass an
+ } elseif {$type == "oneof"} {
+ set oneof ", one of $charclass"
+ set charclass an
+ }
+
+ if {$quantifier == "?"} {
+ set retval 1
+ set retvar $opt
+ set optarg ""
+ } elseif {$quantifier == "+"} {
+ set retvar $opt
+ if {[llength $optarg] < 1} {
+ set retval -2
+ set optarg "Option requires at least one $charclass argument$oneof -- $opt"
+ } else {
+ set retval 1
+ }
+ } elseif {$quantifier == "*"} {
+ set retval 1
+ set retvar $opt
+ } else {
+ set optarg "Option requires $charclass argument$oneof -- $opt"
+ set retvar $opt
+ set retval -2
+ }
+ set quantifier ""
+ } elseif {($type == "arg")
+ || (($type == "oneof")
+ && [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1)
+ || (($type == "class")
+ && [string is $charclass [lindex $argsList 0]])} {
+ set retval 1
+ set retvar $opt
+ lappend optarg [lindex $argsList 0]
+ set argsList [lrange $argsList 1 end]
+ } else {
+ set oneof ""
+ if {$type == "arg"} {
+ set charclass an
+ } elseif {$type == "oneof"} {
+ set oneof ", one of $charclass"
+ set charclass an
+ }
+ set optarg "Option requires $charclass argument$oneof -- $opt"
+ set retvar $opt
+ set retval -3
+
+ if {$quantifier == "?"} {
+ set retval 1
+ set optarg ""
+ }
+ set quantifier ""
+ }
+ if {![regexp -- {[+*]} $quantifier]} {
+ break;
+ }
+ }
+ } else {
+ Error \
+ "Illegal option type specification: must be one of $charclasses" \
+ BAD OPTION TYPE
+ }
+ } else {
+ set optarg "Illegal option -- $_opt"
+ set retvar $_opt
+ set retval -1
+ }
+ }
+ default {
+ # Skip ahead
+ }
+ }
+ }
+
+ return $retval
+}
+
+# ::cmdline::typedGetoptions --
+#
+# Process a set of command line options, filling in defaults
+# for those not specified. This also generates an error message
+# that lists the allowed options if an incorrect option is
+# specified.
+#
+# Arguments:
+# arglistVar The name of the argument list, typically argv
+# optlist A list-of-lists where each element specifies an option
+# in the form:
+#
+# option default comment
+#
+# Options formatting is as described for the optstring
+# argument of typedGetopt. Default is for optionally
+# specifying a default value. Comment is for optionally
+# specifying a comment for the usage display. The
+# options "--", "-help", and "-?" are automatically included
+# in optlist.
+#
+# Argument syntax miscellany:
+# Options formatting and syntax is as described in typedGetopt.
+# There are two additional suffixes that may be applied when
+# passing options to typedGetoptions.
+#
+# You may add ".multi" as a suffix to any option. For options
+# that take an argument, this means that the option may be used
+# more than once on the command line and that each additional
+# argument will be appended to a list, which is then returned
+# to the application.
+# foo.double.multi
+#
+# If a non-argument option is specified as ".multi", it is
+# toggled on and off for each time it is used on the command
+# line.
+# foo.multi
+#
+# If an option specification does not contain the ".multi"
+# suffix, it is not an error to use an option more than once.
+# In this case, the behavior for options with arguments is that
+# the last argument is the one that will be returned. For
+# options that do not take arguments, using them more than once
+# has no additional effect.
+#
+# Options may also be hidden from the usage display by
+# appending the suffix ".secret" to any option specification.
+# Please note that the ".secret" suffix must be the last suffix,
+# after any argument type specification and ".multi" suffix.
+# foo.xdigit.multi.secret
+#
+# Results
+# Name value pairs suitable for using with array set.
+
+proc ::cmdline::typedGetoptions {arglistVar optlist {usage options:}} {
+ variable charclasses
+
+ upvar 1 $arglistVar argv
+
+ set opts {? help}
+ foreach opt $optlist {
+ set name [lindex $opt 0]
+ if {[regsub -- {\.secret$} $name {} name] == 1} {
+ # Remove this extension before passing to typedGetopt.
+ }
+ if {[regsub -- {\.multi$} $name {} name] == 1} {
+ # Remove this extension before passing to typedGetopt.
+
+ regsub -- {\..*$} $name {} temp
+ set multi($temp) 1
+ }
+ lappend opts $name
+ if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} {
+ # Set defaults for those that take values.
+ # Booleans are set just by being present, or not
+
+ set dflt [lindex $opt 1]
+ if {$dflt != {}} {
+ set defaults($name) $dflt
+ }
+ }
+ }
+ set argc [llength $argv]
+ while {[set err [typedGetopt argv $opts opt arg]]} {
+ if {$err == 1} {
+ if {[info exists result($opt)]
+ && [info exists multi($opt)]} {
+ # Toggle boolean options or append new arguments
+
+ if {$arg == ""} {
+ unset result($opt)
+ } else {
+ set result($opt) "$result($opt) $arg"
+ }
+ } else {
+ set result($opt) "$arg"
+ }
+ } elseif {($err == -1) || ($err == -3)} {
+ Error [typedUsage $optlist $usage] USAGE
+ } elseif {$err == -2 && ![info exists defaults($opt)]} {
+ Error [typedUsage $optlist $usage] USAGE
+ }
+ }
+ if {[info exists result(?)] || [info exists result(help)]} {
+ Error [typedUsage $optlist $usage] USAGE
+ }
+ foreach {opt dflt} [array get defaults] {
+ if {![info exists result($opt)]} {
+ set result($opt) $dflt
+ }
+ }
+ return [array get result]
+}
+
+# ::cmdline::typedUsage --
+#
+# Generate an error message that lists the allowed flags,
+# type of argument taken (if any), default value (if any),
+# and an optional description.
+#
+# Arguments:
+# optlist As for cmdline::typedGetoptions
+#
+# Results
+# A formatted usage message
+
+proc ::cmdline::typedUsage {optlist {usage {options:}}} {
+ variable charclasses
+
+ set str "[getArgv0] $usage\n"
+ foreach opt [concat $optlist \
+ {{help "Print this message"} {? "Print this message"}}] {
+ set name [lindex $opt 0]
+ if {[regsub -- {\.secret$} $name {} name] == 1} {
+ # Hidden option
+
+ } else {
+ if {[regsub -- {\.multi$} $name {} name] == 1} {
+ # Display something about multiple options
+ }
+
+ if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass]
+ || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
+ regsub -- "\\..+\$" $name {} name
+ set comment [lindex $opt 2]
+ set default "<[lindex $opt 1]>"
+ if {$default == "<>"} {
+ set default ""
+ }
+ append str [format " %-20s %s %s\n" "-$name $charclass" \
+ $comment $default]
+ } else {
+ set comment [lindex $opt 1]
+ append str [format " %-20s %s\n" "-$name" $comment]
+ }
+ }
+ }
+ return $str
+}
+
+# ::cmdline::prefixSearch --
+#
+# Search a Tcl list for a pattern; searches first for an exact match,
+# and if that fails, for a unique prefix that matches the pattern
+# (i.e, first "lsearch -exact", then "lsearch -glob $pattern*"
+#
+# Arguments:
+# list list of words
+# pattern word to search for
+#
+# Results:
+# Index of found word is returned. If no exact match or
+# unique short version is found then -1 is returned.
+
+proc ::cmdline::prefixSearch {list pattern} {
+ # Check for an exact match
+
+ if {[set pos [::lsearch -exact $list $pattern]] > -1} {
+ return $pos
+ }
+
+ # Check for a unique short version
+
+ set slist [lsort $list]
+ if {[set pos [::lsearch -glob $slist $pattern*]] > -1} {
+ # What if there is nothing for the check variable?
+
+ set check [lindex $slist [expr {$pos + 1}]]
+ if {[string first $pattern $check] != 0} {
+ return [::lsearch -exact $list [lindex $slist $pos]]
+ }
+ }
+ return -1
+}
+# ::cmdline::Error --
+#
+# Internal helper to throw errors with a proper error-code attached.
+#
+# Arguments:
+# message text of the error message to throw.
+# args additional parts of the error code to use,
+# with CMDLINE as basic prefix added by this command.
+#
+# Results:
+# An error is thrown, always.
+
+proc ::cmdline::Error {message args} {
+ return -code error -errorcode [linsert $args 0 CMDLINE] $message
+}
diff --git a/tcllib/modules/cmdline/cmdline.test b/tcllib/modules/cmdline/cmdline.test
new file mode 100644
index 0000000..1806621
--- /dev/null
+++ b/tcllib/modules/cmdline/cmdline.test
@@ -0,0 +1,553 @@
+# -*- tcl -*-
+# This file contains the tests for the cmdline.tcl file.
+#
+# 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) 1999 by Ajuba Solutions.
+# All rights reserved.
+#
+# RCS: @(#) $Id: cmdline.test,v 1.18 2011/02/23 17:41:52 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal cmdline.tcl cmdline
+}
+
+# -------------------------------------------------------------------------
+
+set cmdLineFile [localPath cmdline.tcl]
+set argv0 "argv0"
+
+# ---------------------------------------------------
+# cmdline::getopt
+
+test cmdline-1.1 {cmdline::getopt} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {}
+ list [cmdline::getopt argList {a} opt arg] $argList $opt $arg
+} {0 {} {} {}}
+test cmdline-1.2 {cmdline::getopt, multiple options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {}
+ list [cmdline::getopt argList {a b.arg c} opt arg] $argList $opt $arg
+} {0 {} {} {}}
+test cmdline-1.3 {cmdline::getopt, -- option} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-- -a}
+ list [cmdline::getopt argList {a} opt arg] $argList $opt $arg
+} {0 -a {} {}}
+test cmdline-1.4 {cmdline::getopt, non dash option} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {b -a}
+ list [cmdline::getopt argList {a} opt arg] $argList $opt $arg
+} {0 {b -a} {} {}}
+test cmdline-1.5 {cmdline::getopt, simple option} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-a b}
+ list [cmdline::getopt argList {a} opt arg] $argList $opt $arg
+} {1 b a 1}
+test cmdline-1.6 {cmdline::getopt, multiple letter option} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo b}
+ list [cmdline::getopt argList {foo} opt arg] $argList $opt $arg
+} {1 b foo 1}
+test cmdline-1.7 {cmdline::getopt, multiple letter option, no abbreviations} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-f b}
+ list [cmdline::getopt argList {foo} opt arg] $argList $opt $arg
+} {-1 {-f b} f {Illegal option "-f"}}
+test cmdline-1.8 {cmdline::getopt, option with argument} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo bar baz}
+ list [cmdline::getopt argList {foo.arg} opt arg] $argList $opt $arg
+} {1 baz foo bar}
+test cmdline-1.9 {cmdline::getopt, option with argument, missing arg} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo}
+ list [cmdline::getopt argList {foo.arg} opt arg] $argList $opt $arg
+} {-1 {} foo {Option "foo" requires an argument}}
+test cmdline-1.10 {cmdline::getopt, unknown option} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-bar}
+ list [cmdline::getopt argList {foo.arg} opt arg] $argList $opt $arg
+} {-1 -bar bar {Illegal option "-bar"}}
+test cmdline-1.11 {cmdline::getopt, multiple options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo}
+ list [cmdline::getopt argList {a.arg b foo c.arg} opt arg] $argList $opt $arg
+} {1 {} foo 1}
+
+
+test cmdline-1.12 {cmdline::getopt, option with argument, -o=v syntax} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo=bar baz}
+ list [cmdline::getopt argList {foo.arg} opt arg] $argList $opt $arg
+} {1 baz foo bar}
+
+test cmdline-1.13 {cmdline::getopt, option with argument, --o=v syntax} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {--foo=bar baz}
+ list [cmdline::getopt argList {foo.arg} opt arg] $argList $opt $arg
+} {1 baz foo bar}
+
+
+
+# cmdline::getoptions
+
+test cmdline-2.1 {cmdline::getoptions} {
+ set argList {foo}
+ list [cmdline::getoptions argList {}] $argList
+} {{} foo}
+test cmdline-2.2 {cmdline::getoptions, secret flag} {
+ set argList {-foo}
+ list [cmdline::getoptions argList {{foo.secret}}] $argList
+} {{foo 1} {}}
+test cmdline-2.3 {cmdline::getoptions, normal flag} {
+ set argList {-foo}
+ list [cmdline::getoptions argList {{foo}}] $argList
+} {{foo 1} {}}
+test cmdline-2.4 {cmdline::getoptions, flag with arg} {
+ set argList {-foo bar}
+ list [cmdline::getoptions argList {{foo.arg}}] $argList
+} {{foo bar} {}}
+test cmdline-2.5 {cmdline::getoptions, missing flag with arg, default value} {
+ set argList {}
+ list [cmdline::getoptions argList {{foo.arg blat}}] $argList
+} {{foo blat} {}}
+test cmdline-2.6 {cmdline::getoptions, flag with arg, default value} {
+ set argList {-foo bar}
+ list [cmdline::getoptions argList {{foo.arg blat}}] $argList
+} {{foo bar} {}}
+test cmdline-2.7 {cmdline::getoptions, multiple flags with arg, default value} {
+ set argList {}
+ list [dictsort [cmdline::getoptions argList {{foo.arg blat} {a.arg b}}]] $argList
+} {{a b foo blat} {}}
+test cmdline-2.8 {cmdline::getoptions, errors} {
+ set argList {-a -foo}
+ list [catch {cmdline::getoptions argList {{foo.arg blat} a}} msg] $msg $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -foo value <blat>
+ -a
+ -- Forcibly stop option processing
+ -help Print this message
+ -? Print this message
+" {}]
+test cmdline-2.9 {cmdline::getoptions, errors} {
+ set argList {-a -?}
+ list [catch {cmdline::getoptions argList {{foo.arg blat} a}} msg] $msg \
+ $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -foo value <blat>
+ -a
+ -- Forcibly stop option processing
+ -help Print this message
+ -? Print this message
+" {}]
+test cmdline-2.10 {cmdline::getoptions, errors} {
+ set argList {-help}
+ list [catch {cmdline::getoptions argList {{foo.arg blat} a}} msg] $msg \
+ $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -foo value <blat>
+ -a
+ -- Forcibly stop option processing
+ -help Print this message
+ -? Print this message
+" {}]
+test cmdline-2.11 {cmdline::getoptions, usage string in errors} {
+ set argList {-help}
+ list [catch {cmdline::getoptions argList {{foo.arg blat} a} {testing}} msg] $msg \
+ $argList
+} [list 1 "[cmdline::getArgv0] testing
+ -foo value <blat>
+ -a
+ -- Forcibly stop option processing
+ -help Print this message
+ -? Print this message
+" {}]
+
+test cmdline-2.12 {cmdline::getoptions, bug 3189786} {
+ set argList {-help}
+ list [catch {cmdline::getoptions argList {myarg a} {testing}} msg] $msg \
+ $argList
+} [list 1 "[cmdline::getArgv0] testing
+ -myarg
+ -a
+ -- Forcibly stop option processing
+ -help Print this message
+ -? Print this message
+" {}]
+
+# cmdline::usage
+
+test cmdline-3.1 {cmdline::usage,hidden options} {
+ set argList {-help}
+ list [catch {cmdline::getoptions argList {{foo.secret blat} a}} msg] $msg \
+ $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -a
+ -- Forcibly stop option processing
+ -help Print this message
+ -? Print this message
+" {}]
+test cmdline-3.2 {cmdline::usage, with & without arg} {
+ set argList {-help}
+ list [catch {cmdline::getoptions argList \
+ {{foo.arg blat testing} {a {} {line 2}}}} msg] $msg $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -foo value testing <blat>
+ -a
+ -- Forcibly stop option processing
+ -help Print this message
+ -? Print this message
+" {}]
+
+
+test cmdline-3.3 {cmdline::usage, bug 3189786} {
+ set argList {-help}
+ list [catch {cmdline::getoptions argList {{mysecret blat} a}} msg] $msg \
+ $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -mysecret blat
+ -a
+ -- Forcibly stop option processing
+ -help Print this message
+ -? Print this message
+" {}]
+
+# cmdline::getfiles
+
+# Run the script body in a slave process so we can collect stdout.
+
+proc runGetFilesTest {body} {
+ set script "source [list $::cmdLineFile]\n"
+ append script "cd [list $::tcltest::temporaryDirectory]\n"
+ append script $body
+
+ set scriptfile [makeFile $script script]
+
+ set f [open "|[list $::tcltest::tcltest $scriptfile]" r]
+ set result [read $f]
+ close $f
+ removeFile script
+ return $result
+}
+
+
+# Create a directory with some files in it
+
+makeDirectory cmdlineJunk
+set foo1 [makeFile {} cmdlineJunk/foo1]
+set foo2 [makeFile {} cmdlineJunk/foo2]
+set bar3 [makeFile {} cmdlineJunk/bar3]
+
+test cmdline-4.1 {cmdline::getfiles} {pcOnly} {
+ runGetFilesTest {
+ cmdline::getfiles {} 0
+ }
+} {}
+test cmdline-4.2 {cmdline::getfiles, one pattern} {pcOnly} {
+ runGetFilesTest {
+ cd cmdlineJunk
+ set result [cmdline::getfiles {foo*} 0]
+ puts -nonewline [lsort $result]
+ exit
+ }
+} [list $foo1 $foo2]
+test cmdline-4.3 {cmdline::getfiles, multiple patterns} {pcOnly} {
+ runGetFilesTest {
+ cd cmdlineJunk
+ set result [cmdline::getfiles {foo* bar*} 0]
+ puts -nonewline [lsort $result]
+ exit
+ }
+} [list $bar3 $foo1 $foo2]
+test cmdline-4.4 {cmdline::getfiles, no match} {pcOnly} {
+ runGetFilesTest {
+ cd cmdlineJunk
+ set result [cmdline::getfiles {blat* foo*} 0]
+ puts -nonewline [lsort $result]
+ exit
+ }
+} "warning: no files match \"blat*\"\n[list $foo1 $foo2]"
+test cmdline-4.5 {cmdline::getfiles, quiet} {pcOnly} {
+ runGetFilesTest {
+ cd cmdlineJunk
+ set result [cmdline::getfiles {blat* foo*} 1]
+ puts -nonewline [lsort $result]
+ exit
+ }
+} [list $foo1 $foo2]
+test cmdline-4.6 {cmdline::getfiles, relative paths} {
+ runGetFilesTest {
+ cd cmdlineJunk
+ set result [cmdline::getfiles {foo1 foo2} 0]
+ puts -nonewline [lsort $result]
+ exit
+ }
+} [list $foo1 $foo2]
+test cmdline-4.7 {cmdline::getfiles, absolute paths} {
+ runGetFilesTest {
+ cd cmdlineJunk
+ set result [cmdline::getfiles [list [file join [pwd] foo1]] 0]
+ puts -nonewline [lsort $result]
+ exit
+ }
+} [list $foo1]
+test cmdline-4.8 {cmdline::getfiles, no match} {
+ runGetFilesTest {
+ cd cmdlineJunk
+ set result [cmdline::getfiles {blat foo1} 0]
+ puts -nonewline [lsort $result]
+ exit
+ }
+} "warning: no files match \"blat\"\n[list $foo1]"
+test cmdline-4.9 {cmdline::getfiles, silent no match} {
+ runGetFilesTest {
+ cd cmdlineJunk
+ set result [cmdline::getfiles {blat foo1} 1]
+ puts -nonewline [lsort $result]
+ exit
+ }
+} [list $foo1]
+
+
+test cmdline-4.10 {cmdline::getfiles, backslashes on windows} {pc} {
+ runGetFilesTest {
+ set result [cmdline::getfiles {cmdlineJunk\\foo*} 1]
+ puts -nonewline [lsort $result]
+ exit
+ }
+} [list $foo1 $foo2]
+
+
+# Remove the temporary directory and files from the previous tests
+
+removeFile cmdlineJunk/foo1
+removeFile cmdlineJunk/foo2
+removeFile cmdlineJunk/bar3
+removeDirectory cmdlineJunk
+
+
+# cmdline::getArgv0
+
+test cmdline-5.1 {cmdline::getArgv0} {
+ set oldargv0 $argv0
+ set argv0 "foo"
+ set result [cmdline::getArgv0]
+ set argv0 $oldargv0
+ set result
+} foo
+test cmdline-5.2 {cmdline::getArgv0} {
+ set oldargv0 $argv0
+ set argv0 "foo.exe"
+ set result [cmdline::getArgv0]
+ set argv0 $oldargv0
+ set result
+} foo
+test cmdline-5.3 {cmdline::getArgv0} {
+ set oldargv0 $argv0
+ set argv0 "foo.bin"
+ set result [cmdline::getArgv0]
+ set argv0 $oldargv0
+ set result
+} foo
+test cmdline-5.4 {cmdline::getArgv0} {
+ set oldargv0 $argv0
+ set argv0 "foo.bar.bin"
+ set result [cmdline::getArgv0]
+ set argv0 $oldargv0
+ set result
+} foo.bar
+test cmdline-5.5 {cmdline::getArgv0} {
+ set oldargv0 $argv0
+ set argv0 "/a/b/c/foo"
+ set result [cmdline::getArgv0]
+ set argv0 $oldargv0
+ set result
+} foo
+
+# cmdline::getKnownOpt
+
+test cmdline-6.1 {cmdline::getKnownOpt} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {}
+ list [cmdline::getKnownOpt argList {a} opt arg] $argList $opt $arg
+} {0 {} {} {}}
+test cmdline-6.2 {cmdline::getKnownOpt, multiple options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {}
+ list [cmdline::getKnownOpt argList {a b.arg c} opt arg] $argList $opt $arg
+} {0 {} {} {}}
+test cmdline-6.3 {cmdline::getKnownOpt, -- option} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-- -a}
+ list [cmdline::getKnownOpt argList {a} opt arg] $argList $opt $arg
+} {0 -a {} {}}
+test cmdline-6.4 {cmdline::getKnownOpt, non dash option} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {b -a}
+ list [cmdline::getKnownOpt argList {a} opt arg] $argList $opt $arg
+} {0 {b -a} {} {}}
+test cmdline-6.5 {cmdline::getKnownOpt, simple option} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-a b}
+ list [cmdline::getKnownOpt argList {a} opt arg] $argList $opt $arg
+} {1 b a 1}
+test cmdline-6.6 {cmdline::getKnownOpt, multiple letter option} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo b}
+ list [cmdline::getKnownOpt argList {foo} opt arg] $argList $opt $arg
+} {1 b foo 1}
+test cmdline-6.7 {cmdline::getKnownOpt, multiple letter option, no abbreviations} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-f b}
+ list [cmdline::getKnownOpt argList {foo} opt arg] $argList $opt $arg
+} {-1 {-f b} f {Illegal option "-f"}}
+test cmdline-6.8 {cmdline::getKnownOpt, option with argument} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo bar baz}
+ list [cmdline::getKnownOpt argList {foo.arg} opt arg] $argList $opt $arg
+} {1 baz foo bar}
+test cmdline-6.9 {cmdline::getKnownOpt, option with argument, missing arg} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo}
+ list [cmdline::getKnownOpt argList {foo.arg} opt arg] $argList $opt $arg
+} {-2 {} foo {Option "foo" requires an argument}}
+test cmdline-6.10 {cmdline::getKnownOpt, unknown option} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-bar}
+ list [cmdline::getKnownOpt argList {foo.arg} opt arg] $argList $opt $arg
+} {-1 -bar bar {Illegal option "-bar"}}
+test cmdline-6.11 {cmdline::getKnownOpt, multiple options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo}
+ list [cmdline::getKnownOpt argList {a.arg b foo c.arg} opt arg] $argList $opt $arg
+} {1 {} foo 1}
+
+# cmdline::getKnownOptions
+
+test cmdline-7.1 {cmdline::getKnownOptions} {
+ set argList {foo}
+ list [cmdline::getKnownOptions argList {}] $argList
+} {{} foo}
+test cmdline-7.2 {cmdline::getKnownOptions, secret flag} {
+ set argList {-foo}
+ list [cmdline::getKnownOptions argList {{foo.secret}}] $argList
+} {{foo 1} {}}
+test cmdline-7.3 {cmdline::getKnownOptions, normal flag} {
+ set argList {-foo}
+ list [cmdline::getKnownOptions argList {{foo}}] $argList
+} {{foo 1} {}}
+test cmdline-7.4 {cmdline::getKnownOptions, flag with arg} {
+ set argList {-foo bar}
+ list [cmdline::getKnownOptions argList {{foo.arg}}] $argList
+} {{foo bar} {}}
+test cmdline-7.5 {cmdline::getKnownOptions, missing flag with arg, default value} {
+ set argList {}
+ list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList
+} {{foo blat} {}}
+test cmdline-7.6 {cmdline::getKnownOptions, flag with arg, default value} {
+ set argList {-foo bar}
+ list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList
+} {{foo bar} {}}
+test cmdline-7.7 {cmdline::getKnownOptions, multiple flags with arg, default value} {
+ set argList {}
+ list [dictsort [cmdline::getKnownOptions argList {{foo.arg blat} {a.arg b}}]] $argList
+} {{a b foo blat} {}}
+test cmdline-7.8 {cmdline::getKnownOptions, ignore unknown option} {
+ set argList {-unknown -foo buzz}
+ list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList
+} {{foo buzz} -unknown}
+test cmdline-7.9 {cmdline::getKnownOptions, ignore unknown option} {
+ set argList {-foo buzz -unknown}
+ list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList
+} {{foo buzz} -unknown}
+test cmdline-7.10 {cmdline::getKnownOptions, ignore unknown option with args} {
+ set argList {-unknown u1 u2 u3 -foo buzz}
+ list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList
+} {{foo buzz} {-unknown u1 u2 u3}}
+test cmdline-7.11 {cmdline::getKnownOptions, ignore unknown option with args} {
+ set argList {-foo buzz -unknown u1 u2 u3}
+ list [cmdline::getKnownOptions argList {{foo.arg blat}}] $argList
+} {{foo buzz} {-unknown u1 u2 u3}}
+test cmdline-7.12 {cmdline::getKnownOptions, errors} {
+ set argList {-a -foo}
+ list [catch {cmdline::getKnownOptions argList {{foo.arg blat} a}} msg] $msg $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -foo value <blat>
+ -a
+ -- Forcibly stop option processing
+ -help Print this message
+ -? Print this message
+" {}]
+test cmdline-7.13 {cmdline::getKnownOptions, errors} {
+ set argList {-a -?}
+ list [catch {cmdline::getKnownOptions argList {{foo.arg blat} a}} msg] $msg \
+ $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -foo value <blat>
+ -a
+ -- Forcibly stop option processing
+ -help Print this message
+ -? Print this message
+" {}]
+test cmdline-7.14 {cmdline::getKnownOptions, errors} {
+ set argList {-help}
+ list [catch {cmdline::getKnownOptions argList {{foo.arg blat} a}} msg] $msg \
+ $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -foo value <blat>
+ -a
+ -- Forcibly stop option processing
+ -help Print this message
+ -? Print this message
+" {}]
+test cmdline-7.15 {cmdline::getKnownOptions, usage string in errors} {
+ set argList {-help}
+ list [catch {cmdline::getKnownOptions argList {{foo.arg blat} a} {testing}} msg] $msg \
+ $argList
+} [list 1 "[cmdline::getArgv0] testing
+ -foo value <blat>
+ -a
+ -- Forcibly stop option processing
+ -help Print this message
+ -? Print this message
+" {}]
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/cmdline/pkgIndex.tcl b/tcllib/modules/cmdline/pkgIndex.tcl
new file mode 100644
index 0000000..71284a0
--- /dev/null
+++ b/tcllib/modules/cmdline/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded cmdline 1.5 [list source [file join $dir cmdline.tcl]]
diff --git a/tcllib/modules/cmdline/typedCmdline.test b/tcllib/modules/cmdline/typedCmdline.test
new file mode 100644
index 0000000..700659c
--- /dev/null
+++ b/tcllib/modules/cmdline/typedCmdline.test
@@ -0,0 +1,470 @@
+# -*- tcl -*-# This file contains the tests for the typedCmdline.tcl file.
+#
+# 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) 2000 by Ross Palmer Mohn.
+# All rights reserved.
+#
+# RCS: @(#) $Id: typedCmdline.test,v 1.11 2007/08/03 04:27:38 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal cmdline.tcl cmdline
+}
+
+# -------------------------------------------------------------------------
+
+set argv0 "argv0"
+
+# ---------------------------------------------------
+
+# cmdline::typedGetopt
+
+test typed-cmdline-6.1 {cmdline::typedGetopt} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {}
+ list [cmdline::typedGetopt argList {a} opt arg] $argList $opt $arg
+} {0 {} {} {}}
+test typed-cmdline-6.2 {cmdline::typedGetopt, multiple options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {}
+ list [cmdline::typedGetopt argList {a b.arg c} opt arg] $argList $opt $arg
+} {0 {} {} {}}
+test typed-cmdline-6.3 {cmdline::typedGetopt, -- option} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-- -a}
+ list [cmdline::typedGetopt argList {a} opt arg] $argList $opt $arg
+} {0 -a {} {}}
+test typed-cmdline-6.4 {cmdline::typedGetopt, non dash option} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {b -a}
+ list [cmdline::typedGetopt argList {a} opt arg] $argList $opt $arg
+} {0 {b -a} {} {}}
+test typed-cmdline-6.5 {cmdline::typedGetopt, simple option} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-a b}
+ list [cmdline::typedGetopt argList {a} opt arg] $argList $opt $arg
+} {1 b a {}}
+test typed-cmdline-6.6 {cmdline::typedGetopt, multiple letter option} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo b}
+ list [cmdline::typedGetopt argList {foo} opt arg] $argList $opt $arg
+} {1 b foo {}}
+test typed-cmdline-6.7 {cmdline::typedGetopt, multiple letter option, abbreviation} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-f -b}
+ list [cmdline::typedGetopt argList {foo b} opt arg] $argList $opt $arg
+} {1 -b foo {}}
+test typed-cmdline-6.8 {cmdline::typedGetopt, option with argument} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo bar baz}
+ list [cmdline::typedGetopt argList {foo.arg} opt arg] $argList $opt $arg
+} {1 baz foo bar}
+test typed-cmdline-6.9 {cmdline::typedGetopt, option with argument, missing arg} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo}
+ list [cmdline::typedGetopt argList {foo.arg} opt arg] $argList $opt $arg
+} {-2 {} foo {Option requires an argument -- foo}}
+test typed-cmdline-6.10 {cmdline::typedGetopt, multiple options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo}
+ list [cmdline::typedGetopt argList {a.arg b foo c.arg} opt arg] $argList $opt $arg
+} {1 {} foo {}}
+test typed-cmdline-6.11 {cmdline::typedGetopt, unusual options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-* foo}
+ list [cmdline::typedGetopt argList {a.arg b *.arg c.arg} opt arg] $argList $opt $arg
+} {1 {} * foo}
+test typed-cmdline-6.12 {cmdline::typedGetopt, integer options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo -a bar}
+ list [cmdline::typedGetopt argList {a.arg foo.integer b} opt arg] $argList $opt $arg
+} {-3 {-a bar} foo {Option requires integer argument -- foo}}
+test typed-cmdline-6.13 {cmdline::typedGetopt, integer options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo 123}
+ list [cmdline::typedGetopt argList {a.arg foo.integer b} opt arg] $argList $opt $arg
+} {1 {} foo 123}
+
+test typed-cmdline-6.14.0 {cmdline::typedGetopt, integer options} tcl8.6plus {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo 123}
+ list [catch {cmdline::typedGetopt argList {a.arg foo.bar b} opt arg} msg] $msg $argList $opt $arg
+} [list 1 {Illegal option type specification: must be one of alnum|alpha|ascii|control|boolean|digit|double|entier|false|graph|integer|list|lower|print|punct|space|true|upper|wideinteger|wordchar|xdigit} {-foo 123} {} {}]
+
+test typed-cmdline-6.14.1 {cmdline::typedGetopt, integer options} {tcl8.5plus tcl8.5minus} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo 123}
+ list [catch {cmdline::typedGetopt argList {a.arg foo.bar b} opt arg} msg] $msg $argList $opt $arg
+} [list 1 {Illegal option type specification: must be one of alnum|alpha|ascii|control|boolean|digit|double|false|graph|integer|list|lower|print|punct|space|true|upper|wideinteger|wordchar|xdigit} {-foo 123} {} {}]
+
+test typed-cmdline-6.14.2 {cmdline::typedGetopt, integer options} tcl8.4minus {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo 123}
+ list [catch {cmdline::typedGetopt argList {a.arg foo.bar b} opt arg} msg] $msg $argList $opt $arg
+} [list 1 {Illegal option type specification: must be one of alnum|alpha|ascii|control|boolean|digit|double|false|graph|integer|lower|print|punct|space|true|upper|wordchar|xdigit} {-foo 123} {} {}]
+
+test typed-cmdline-6.15 {cmdline::typedGetopt, integer options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo 123 -a 234}
+ list [cmdline::typedGetopt argList {a.arg foo.integer b} opt arg] $argList $opt $arg
+} {1 {-a 234} foo 123}
+test typed-cmdline-6.16 {cmdline::typedGetopt, unusual integer options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-* 123 -a 234}
+ list [cmdline::typedGetopt argList {a.arg *.integer b} opt arg] $argList $opt $arg
+} {1 {-a 234} * 123}
+test typed-cmdline-6.17 {cmdline::typedGetopt, integer options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo}
+ list [cmdline::typedGetopt argList {a.arg foo.integer b} opt arg] $argList $opt $arg
+} {-2 {} foo {Option requires integer argument -- foo}}
+test typed-cmdline-6.18 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo 50AC}
+ list [cmdline::typedGetopt argList {foo.xdigit} opt arg] $argList $opt $arg
+} {1 {} foo 50AC}
+test typed-cmdline-6.19 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo 50GC}
+ list [cmdline::typedGetopt argList {foo.xdigit} opt arg] $argList $opt $arg
+} {-3 50GC foo {Option requires xdigit argument -- foo}}
+test typed-cmdline-6.20 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo 50gc}
+ list [cmdline::typedGetopt argList {foo.(50GC|50gc) bar} opt arg] $argList $opt $arg
+} {1 {} foo 50gc}
+test typed-cmdline-6.21 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo 50gC}
+ list [cmdline::typedGetopt argList {foo.(50GC|50gc) bar} opt arg] $argList $opt $arg
+} {-3 50gC foo {Option requires an argument, one of 50GC|50gc -- foo}}
+test typed-cmdline-6.22 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo abc*def}
+ list [cmdline::typedGetopt argList {foo.(abc*def|ghi?jkl) bar} opt arg] $argList $opt $arg
+} {1 {} foo abc*def}
+test typed-cmdline-6.23 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo 50gc}
+ list [cmdline::typedGetopt argList {foo.(x5MP|1jxR|50gc)? bar} opt arg] $argList $opt $arg
+} {1 {} foo 50gc}
+test typed-cmdline-6.24 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo}
+ list [cmdline::typedGetopt argList {foo.(x5MP|1jxR|50gc)? bar} opt arg] $argList $opt $arg
+} {1 {} foo {}}
+test typed-cmdline-6.25 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo -bar}
+ list [cmdline::typedGetopt argList {foo.(x5MP|1jxR|50gc)? bar} opt arg] $argList $opt $arg
+} {1 -bar foo {}}
+test typed-cmdline-6.26 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo 50fc}
+ list [cmdline::typedGetopt argList {foo.xdigit? bar} opt arg] $argList $opt $arg
+} {1 {} foo 50fc}
+test typed-cmdline-6.27 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo}
+ list [cmdline::typedGetopt argList {foo.xdigit? bar} opt arg] $argList $opt $arg
+} {1 {} foo {}}
+test typed-cmdline-6.28 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo 1jxR -bar}
+ list [cmdline::typedGetopt argList {foo.xdigit? bar} opt arg] $argList $opt $arg
+} {1 {1jxR -bar} foo {}}
+test typed-cmdline-6.29 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo -bar}
+ list [cmdline::typedGetopt argList {foo.xdigit? bar} opt arg] $argList $opt $arg
+} {1 -bar foo {}}
+test typed-cmdline-6.30 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo}
+ list [cmdline::typedGetopt argList {foo.xdigit+ bar} opt arg] $argList $opt $arg
+} {-2 {} foo {Option requires at least one xdigit argument -- foo}}
+test typed-cmdline-6.31 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo AC}
+ list [cmdline::typedGetopt argList {foo.xdigit+ bar} opt arg] $argList $opt $arg
+} {1 {} foo AC}
+test typed-cmdline-6.32 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo AC 2F -bar}
+ list [cmdline::typedGetopt argList {foo.xdigit+ bar} opt arg] $argList $opt $arg
+} {-3 -bar foo {Option requires xdigit argument -- foo}}
+test typed-cmdline-6.33 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo AC 2F}
+ list [cmdline::typedGetopt argList {foo.xdigit+ bar} opt arg] $argList $opt $arg
+} {1 {} foo {AC 2F}}
+test typed-cmdline-6.34 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo AC 2F --}
+ list [cmdline::typedGetopt argList {foo.xdigit+ bar} opt arg] $argList $opt $arg
+} {1 {} foo {AC 2F}}
+test typed-cmdline-6.35 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo}
+ list [cmdline::typedGetopt argList {foo.xdigit* bar} opt arg] $argList $opt $arg
+} {1 {} foo {}}
+test typed-cmdline-6.36 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo AC}
+ list [cmdline::typedGetopt argList {foo.xdigit* bar} opt arg] $argList $opt $arg
+} {1 {} foo AC}
+test typed-cmdline-6.37 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo AC 2F -bar}
+ list [cmdline::typedGetopt argList {foo.xdigit* bar} opt arg] $argList $opt $arg
+} {-3 -bar foo {Option requires xdigit argument -- foo}}
+test typed-cmdline-6.38 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo AC 2F}
+ list [cmdline::typedGetopt argList {foo.xdigit* bar} opt arg] $argList $opt $arg
+} {1 {} foo {AC 2F}}
+test typed-cmdline-6.39 {cmdline::typedGetopt, xdigit options} {
+ catch {unset opt}
+ catch {unset arg}
+ set argList {-foo AC 2F --}
+ list [cmdline::typedGetopt argList {foo.xdigit* bar} opt arg] $argList $opt $arg
+} {1 {} foo {AC 2F}}
+
+# cmdline::typedGetoptions
+
+test typed-cmdline-7.1 {cmdline::typedGetoptions} {
+ set argList {foo}
+ list [cmdline::typedGetoptions argList {}] $argList
+} {{} foo}
+test typed-cmdline-7.2 {cmdline::typedGetoptions, secret integer flag} {
+ set argList {-foo 123}
+ list [cmdline::typedGetoptions argList {{foo.integer.secret}}] $argList
+} {{foo 123} {}}
+test typed-cmdline-7.3 {cmdline::typedGetoptions, normal integer flag} {
+ set argList {-foo 123}
+ list [cmdline::typedGetoptions argList {{foo.integer}}] $argList
+} {{foo 123} {}}
+test typed-cmdline-7.4 {cmdline::typedGetoptions, missing integer flag, no default value} {
+ set argList {}
+ list [cmdline::typedGetoptions argList {{foo.integer}}] $argList
+} {{} {}}
+test typed-cmdline-7.5 {cmdline::typedGetoptions, missing integer flag, no default value} {
+ set argList {}
+ list [cmdline::typedGetoptions argList {{foo.integer {} {option foo with integer argument}}}] $argList
+} {{} {}}
+test typed-cmdline-7.6 {cmdline::typedGetoptions, integer flag, missing arg, no default value} {
+ set argList {-foo}
+ list [catch {cmdline::typedGetoptions argList {{foo.integer {} {blah blah}}}} msg] $msg $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -foo integer blah blah
+ -help Print this message
+ -? Print this message
+" {}]
+test typed-cmdline-7.7 {cmdline::typedGetoptions, integer flag, no default value} {
+ set argList {-foo 123}
+ list [cmdline::typedGetoptions argList {{foo.integer {} {option foo with integer argument}}}] $argList
+} {{foo 123} {}}
+test typed-cmdline-7.8 {cmdline::typedGetoptions, missing integer flag with arg, default value} {
+ set argList {-* 123}
+ list [dictsort [cmdline::typedGetoptions argList {{foo.integer 234} {*.double 5.234 {Unusual}}}]] $argList
+} {{* 123 foo 234} {}}
+test typed-cmdline-7.9 {cmdline::typedGetoptions, missing integer flag with arg, default value} {
+ set argList {-f}
+ list [dictsort [cmdline::typedGetoptions argList {{foo.integer 234} {*.double 5.234 {Unusual}}}]] $argList
+} {{* 5.234 foo 234} {}}
+test typed-cmdline-7.10 {cmdline::typedGetoptions, missing integer flag with arg, default value} {
+ set argList {-f}
+ list [catch {cmdline::typedGetoptions argList {foo.integer *.double fooey}} msg] $msg $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -foo integer
+ -* double
+ -fooey
+ -help Print this message
+ -? Print this message
+" -f]
+test typed-cmdline-7.11 {cmdline::typedGetoptions, missing integer flag with arg, default value} {
+ set argList {}
+ list [cmdline::typedGetoptions argList {{foo.integer 234}}] $argList
+} {{foo 234} {}}
+test typed-cmdline-7.12 {cmdline::typedGetoptions, integer flag with arg, default value} {
+ set argList {-foo 123}
+ list [cmdline::typedGetoptions argList {{foo.integer 234}}] $argList
+} {{foo 123} {}}
+test typed-cmdline-7.13 {cmdline::typedGetoptions, multiple flags with arg, default value} {
+ set argList {}
+ list [dictsort [cmdline::typedGetoptions argList {{foo.arg blat} {a.arg b}}]] $argList
+} {{a b foo blat} {}}
+test typed-cmdline-7.14 {cmdline::typedGetoptions, errors} {
+ set argList {-a -foo}
+ list [dictsort [cmdline::typedGetoptions argList {{foo.arg blat} a}]] $argList
+} {{a {} foo blat} {}}
+test typed-cmdline-7.15 {cmdline::typedGetoptions, errors} {
+ set argList {-a -fo}
+ list [dictsort [cmdline::typedGetoptions argList {{foo.arg blat} a}]] $argList
+} {{a {} foo blat} {}}
+test typed-cmdline-7.16 {cmdline::typedGetopt, xdigit options} {
+ set argList {-foo 50gc}
+ list [cmdline::typedGetoptions argList {foo.(50GC|50gc) bar}] $argList
+} {{foo 50gc} {}}
+test typed-cmdline-7.17 {cmdline::typedGetopt, xdigit options} {
+ set argList {-foo -bar}
+ list [cmdline::typedGetoptions argList {foo.(50GC|50gc)? bar}] $argList
+} {{foo {} bar {}} {}}
+test typed-cmdline-7.18 {cmdline::typedGetopt, xdigit options} {
+ set argList {-bar -foo 123 234}
+ list [cmdline::typedGetoptions argList {foo.integer+ bar}] $argList
+} {{foo {123 234} bar {}} {}}
+test typed-cmdline-7.19 {cmdline::typedGetopt, xdigit options} {
+ set argList {-bar -foo 123 234}
+ list [cmdline::typedGetoptions argList {foo.integer* bar}] $argList
+} {{foo {123 234} bar {}} {}}
+test typed-cmdline-7.20 {cmdline::typedGetopt, xdigit options} {
+ set argList {-foo 50gC}
+ list [catch {cmdline::typedGetoptions argList {foo.(50GC|50gc) bar}} msg] $msg $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -foo 50GC|50gc
+ -bar
+ -help Print this message
+ -? Print this message
+" 50gC]
+test typed-cmdline-7.21 {cmdline::typedGetoptions, errors} {
+ set argList {-b -foo}
+ list [catch {cmdline::typedGetoptions argList {foo.arg a}} msg] $msg $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -foo arg
+ -a
+ -help Print this message
+ -? Print this message
+" {-b -foo}]
+test typed-cmdline-7.22 {cmdline::typedGetoptions, errors} {
+ set argList {-b -foo}
+ list [catch {cmdline::typedGetoptions argList {{foo.arg {} {blah blah}} a}} msg] $msg $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -foo arg blah blah
+ -a
+ -help Print this message
+ -? Print this message
+" {-b -foo}]
+test typed-cmdline-7.23 {cmdline::typedGetoptions, errors} {
+ set argList {-a -?}
+ list [catch {cmdline::typedGetoptions argList {{foo.arg blat} a}} msg] $msg \
+ $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -foo arg <blat>
+ -a
+ -help Print this message
+ -? Print this message
+" {}]
+test typed-cmdline-7.24 {cmdline::typedGetoptions, errors} {
+ set argList {-help}
+ list [catch {cmdline::typedGetoptions argList {{foo.arg blat} a}} msg] $msg \
+ $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -foo arg <blat>
+ -a
+ -help Print this message
+ -? Print this message
+" {}]
+test typed-cmdline-7.25 {cmdline::typedGetoptions, usage string in errors} {
+ set argList {-help}
+ list [catch {cmdline::typedGetoptions argList {{foo.arg blat} a} {testing:}} msg] $msg \
+ $argList
+} [list 1 "[cmdline::getArgv0] testing:
+ -foo arg <blat>
+ -a
+ -help Print this message
+ -? Print this message
+" {}]
+test typed-cmdline-7.26 {cmdline::typedGetoptions, unusual option} {
+ set argList {-x?y -a -foo}
+ list [dictsort [cmdline::typedGetoptions argList {{foo.arg blat} x?y x*y a}]] $argList
+} {{a {} foo blat x?y {}} {}}
+test typed-cmdline-7.27 {cmdline::typedGetoptions, unusual option, abbreviation error} {
+ set argList {-x -a -foo}
+ list [catch {cmdline::typedGetoptions argList {{foo.arg blat} x?y x*y a}} msg] $msg $argList
+} [list 1 "[cmdline::getArgv0] options:
+ -foo arg <blat>
+ -x?y
+ -x*y
+ -a
+ -help Print this message
+ -? Print this message
+" {-x -a -foo}]
+test typed-cmdline-7.28 {cmdline::typedGetoptions, unusual option, abbreviation} {
+ set argList {-x -a -foo}
+ list [dictsort [cmdline::typedGetoptions argList {{foo.arg blat} x?y a}]] $argList
+} {{a {} foo blat x?y {}} {}}
+test typed-cmdline-7.29 {cmdline::typedGetoptions, multiple integer flag} {
+ set argList {-foo 123 -foo 234}
+ list [cmdline::typedGetoptions argList {{foo.integer.multi}}] $argList
+} {{foo {123 234}} {}}
+test typed-cmdline-7.30 {cmdline::typedGetoptions, multiple quoted arg flag} {
+ set argList {-foo "123 234" -foo "234 345"}
+ list [cmdline::typedGetoptions argList {{foo.arg.multi}}] $argList
+} {{foo {{123 234} {234 345}}} {}}
+test typed-cmdline-7.31 {cmdline::typedGetoptions, multiple boolean flag} {
+ set argList {-foo}
+ list [cmdline::typedGetoptions argList {{foo.multi}}] $argList
+} {{foo {}} {}}
+test typed-cmdline-7.32 {cmdline::typedGetoptions, multiple boolean flag} {
+ set argList {-foo -foo}
+ list [cmdline::typedGetoptions argList {{foo.multi}}] $argList
+} {{} {}}
+test typed-cmdline-7.33 {cmdline::typedGetoptions, multiple boolean flag} {
+ set argList {-foo -foo -foo}
+ list [cmdline::typedGetoptions argList {{foo.multi}}] $argList
+} {{foo {}} {}}
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/comm/ChangeLog b/tcllib/modules/comm/ChangeLog
new file mode 100644
index 0000000..afc2cff
--- /dev/null
+++ b/tcllib/modules/comm/ChangeLog
@@ -0,0 +1,368 @@
+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-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-09-15 Andreas Kupries <andreask@activestate.com>
+
+ * comm.tcl (::comm::commIncoming): [Bug 3066872]: Replaced
+ blocking gets call to read line of offered protocols by
+ non-blocking gets and additional event handling. The procedure
+ "commIncoming" is split into two.
+
+ * comm.tcl (::comm::Word0): [Bug 2972571]: Fixed misdetection
+ * comm.man: of quoted brace due to not handling \\ on its
+ * comm.test: own. Extended testsuite. Updated docs.
+
+ * pkgIndex.tcl: Bumped to version 4.6.2.
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-11-04 Andreas Kupries <andreask@activestate.com>
+
+ * comm.tcl (::comm::commCollect): [Bug 2890743]. Replaced
+ * comm.man: lindex/lreplace with a procedure emulating lindex's
+ * pkgIndex.tcl: behaviour pre Tcl 8, i.e. it needs only the first
+ word to be a proper list element to parse it ouf the
+ buffer. Bumped package version to 4.6.1.
+
+2009-04-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.tcl: Added option -socketcmd enabling users to override how
+ * comm.man: a socket is opened. The envisioned main use is the
+ * pkgIndex.tcl: specification of tls::socket to secure the
+ * comm.pcx: communications. Version bumped to 4.6. Extended syntax
+ * comm.test: definitions for tclchecker, and extended testsuite.
+
+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 ========================
+ *
+
+2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.pcx: New file. Syntax definitions for the public commands
+ of the comm package.
+
+2008-05-16 Andreas Kupries <andreask@activestate.com>
+
+ * comm_wire.man: Fixed the sectref argument order issues.
+
+2008-05-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm_wire.man: Updated to changes in doctools (sub)section
+ reference handling.
+
+2008-03-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm_wire.man: Changed 'require' information to show that this
+ manpage belongs to the documentation for the package 'comm'.
+
+2008-02-29 Andreas Kupries <andreask@activestate.com>
+
+ * comm.tcl: Accepted Hemang's <hemanglavana@users.sourceforge.net>
+ * comm.man: patch for the [SF Tcllib Bug 1861565] he
+ * comm.test: reported. This changes the handling of 'port already
+ * pkgIndex.tcl: in use' errors to provide a clear
+ message. Testsuite was updated. Version bumped to 4.5.7.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-21 Andreas Kupries <andreask@activestate.com>
+
+ * comm_wire.man: Fixed description of messages in the basic
+ message layer, and of EOL, per [SF Tcllib Bug 1739372] (by Lars
+ Hellstroem). General cleanup (spell checking).
+
+2007-08-20 Andreas Kupries <andreask@activestate.com>
+
+ * comm.test: Updated to require Tcl 8.3 (for snit).
+
+2007-08-15 Andreas Kupries <andreask@activestate.com>
+
+ * comm.tcl (::comm::Vwait): Fixed uplevel which failed when used
+ * comm.man: with variable names containing spaces. Bumped the
+ * pkgIndex.tcl: package version to 4.5.6. Thanks to Bryan Oakley.
+
+2007-08-14 Andreas Kupries <andreask@activestate.com>
+
+ * comm.tcl (::comm::CommRunHook): Fixed typo in variable name,
+ * comm.man: should be 'res', not 'result'. Bumped the package
+ * pkgIndex.tcl: version to 4.5.5. Thanks to Bryan Oakley.
+
+2007-08-09 Andreas Kupries <andreask@activestate.com>
+
+ * comm.tcl (comm::comm_cmd_send): Replaced the 'after idle unset
+ result' with an immediate unset, saving the information into a
+ local variable. The 'after idle' can spill into a forked child
+ process if there is no event loop between its location and the
+ fork. This may bork the child if the next event loop is the
+ 'vwait' of comm's send a few lines above, and the child used the
+ same serial number for its next request. In that case the
+ parent's 'after idle unset' will delete the very array element
+ the child is waiting for, unlocking the vwait, causing it to
+ access a now missing array element, instead of the expected
+ result. Fix by JeffH, Analysis by AndreasK, bugfix actually done
+ before the analysis. This bug happened at Cisco.
+ * comm.man: Bumped the package version to 4.5.4.
+ * pkgIndex.tcl:
+
+2007-06-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.tcl: Bugfixes in the wrapper for 'update'.
+ * comm.man: Bumped the package version to 4.5.3.
+ * pkgIndex.tcl:
+
+2007-05-10 Andreas Kupries <andreask@activestate.com>
+
+ * comm.tcl: Bugfix in the wrapper for 'update'. Bumped the
+ * comm.man: package version to 4.5.2.
+ * pkgIndex.tcl:
+
+2007-05-04 Andreas Kupries <andreask@activestate.com>
+
+ * comm.tcl: Bugfixes in the handling of -interp for regular
+ * comm.man: scripts. The handling of the buffer was wrong for
+ * pkgIndex.tcl: scripts which are a single statement as
+ list. Fixed missing argument to new command commSendReply,
+ introduced by version 4.5. Affected debugging. Bumped package
+ version to 4.5.1.
+
+2007-05-01 Andreas Kupries <andreask@activestate.com>
+
+ * comm.tcl: Added ability to asynchronously generate script
+ * comm.man: results. Enables proper handling of long-running
+ * comm.test: operations (like db queries) without blocking the
+ * comm.slaveboot: server, nor requiring nested eventloops.
+ * pkgIndex.tcl: Extended documentation, and testsuite. Version
+ bumped to 4.5. Now depending on snit, and Tcl 8.3.
+
+2007-03-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.man: Fixed all warnings due to use of now deprecated
+ * comm_wire.man: commands. Added a section about how to give
+ feedback.
+
+2006-11-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.tcl (commRunHook): Fixed double execution of the hook
+ script. Thanks to Will Duquette for the report.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Bumped to version 4.4. changes were extension
+ * comm.tcl: of the existing API.
+ * comm.man:
+
+2006-09-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm_wire.man: Clarified the use of the TCP port in the initial
+ message a bit more, i.e. the meaning of the special value '0'.
+
+ * comm.tcl: The rewrite of the hook handling broken the promised
+ * comm.man: semantics. Fixed. Also extended the handling of a
+ configured -interp to deal with a variety of possibilities
+ regarding missing or hidden commands. Updated the documentation.
+
+ * pkgIndex.tcl: Bumped to version 4.3.2
+
+2006-08-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.man: Bumped to version 4.3.1
+ * comm.tcl:
+ * pkgIndex.tcl:
+
+ * comm.tcl: Implemented the new options -interp and -events,
+ * comm.test: extended the testsuite to cover them. Created
+ utility/helper command for the execution of hook scripts, and
+ rewrote all hook places to use it.
+
+2006-08-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.man: Documented an easier use of slave interpreters
+ (-interp, -events).
+
+2006-08-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.test: Moved startup and cleanup of slave process
+ * comm.slaveboot: into a separate file.
+
+2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.test: Fixed cleanup of temp. files.
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.test: Hooked into the new common test support code.
+
+2006-01-10 Andreas Kupries <andreask@activestate.com>
+
+ * comm.test: Fixed [SF Tcllib Bug 1316033]. Uncluttering test
+ output.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-10-03 Andreas Kupries <andreask@activestate.com>
+
+ * comm.tcl: Accepted [SF Tcllib Bug 1006282], which is actually an
+ * comm.man: RFE. Comm channels are extended with an option which
+ allows the user to force the server side to silently
+ ignore connection attempts where the protocol
+ negotiation with the other side failed.
+
+2005-03-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm_wire.man: Added documentation for the wire protocol run by
+ comm internally.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-08-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.tcl: Typo police.
+ * comm.man:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-10-23 Andreas Kupries <andreask@activestate.com>
+
+ * comm.man: Updated version number in documentation.
+
+2003-10-21 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * pkgIndex.tcl: updated to v4.2.
+
+ * comm.man:
+ * comm.tcl (comm_cmd_new): make 'comm::comm new ?chan?' fully
+ qualify the namespace of the new channel and return that.
+ [Bug #741653, #817351]
+
+ * comm.tcl: change default encoding to utf-8. This should still
+ work with other versions of comm because the previous one-sided
+ binary setting only allowed for limited i18n-ness. Using this
+ version of comm on both sides will ensure full i18n-happiness.
+ [Bug #806420]
+
+2003-05-09 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * pkgIndex.tcl: updated to comm 4.1
+ * comm.man:
+ * comm.tcl: rewrite of code to remove pseudo-object model.
+ Clean up code, add send -command callback to allow for
+ notification of results for asynchronous sends.
+
+2003-05-08 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * comm.tcl: update use of string functions to 8.2 cleanliness.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * comm.man:
+ * comm.tcl:
+ * pkgIndex.tcl: Set version of the package to to 4.0.1.
+
+2003-01-28 David N. Welton <davidw@dedasys.com>
+
+ * comm.tcl (::comm::commConfigure): Use 'string is integer'
+ instead of regexp's.
+ Require Tcl 8.2.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.man: More semantic markup, less visual one.
+
+2002-08-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.test: Removed writing of file ~/foo, was debugging
+ code. Changed creation and usage of file 'spawn' to allow an
+ arbitrary setting of -tmpdir. Fixes SF Bug #589225 reported by
+ Don Porter <dgp@users.sourceforge.net>.
+
+2002-03-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bumped version number to 4.0 per request by John LoVerso.
+
+ * comm.tcl: Applied patch #526499 improving the handling of errors
+ for async invoked commands.
+
+2002-02-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.tcl: Frink run.
+
+2002-01-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bumped version to 3.7.1.
+
+2001-11-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * comm.n: Updated to reflect the changes in the comm code
+ (namespaces). This fixes SF item #480227.
+
+ * comm.tcl: Fixed two places where namespacing was not handled
+ correctly.
+
+2001-08-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Integrated into tcllib.
diff --git a/tcllib/modules/comm/comm.LICENSE b/tcllib/modules/comm/comm.LICENSE
new file mode 100644
index 0000000..3e87505
--- /dev/null
+++ b/tcllib/modules/comm/comm.LICENSE
@@ -0,0 +1,48 @@
+Copyright (C) 1995-1998, The Open Group. All Rights Reserved.
+
+This software was developed by the Open Group Research Institute
+("RI"). This software, both binary and source (hereafter, Software)
+is copyrighted by The Open Group Research Institute and ownership
+remains with the RI.
+
+The RI hereby grants you (hereafter, Licensee) permission to use,
+copy, modify, distribute, and license this Software and its
+documentation for any purpose, provided that existing copyright
+notices are retained in all copies and that this notice is included
+verbatim in any distributions. No written agreement, license, or
+royalty fee is required for any of the authorized uses provided
+that the RI is publicly and prominently acknowledged as the source
+of this software.
+
+Licensee may make derivative works. However, if Licensee distributes
+any derivative work based on or derived from the Software, then
+Licensee will (1) notify the RI regarding its distribution of the
+derivative work, (2) clearly notify users that such derivative work
+is a modified version and not the original software distributed by
+the RI, and (3) the RI is publicly and prominently acknowledged as
+the source of this software.
+
+THE RI MAKES NO REPRESENTATIONS ABOUT THE SERVICEABILITY OF THIS
+SOFTWARE FOR ANY PURPOSE. IT IS PROVIDED "AS IS" WITHOUT EXPRESS
+OR IMPLIED WARRANTY. THE RI SHALL NOT BE LIABLE FOR ANY DAMAGES
+SUFFERED BY THE USERS OF THIS SOFTWARE.
+
+By using or copying this Software, Licensee agrees to abide by the
+copyright law and all other applicable laws of the U.S. including,
+but not limited to, export control laws, and the terms of this
+license. The RI shall have the right to terminate this license
+immediately by written notice upon Licensee's breach of, or
+non-compliance with, any of its terms. Licensee may be held legally
+responsible for any copyright infringement that is caused or
+encouraged by Licensee's failure to abide by the terms of this
+license.
+
+Comments and questions on this license are welcome and can be sent to:
+
+ ri-software@opengroup.org
+
+Comments and questions on this software should be sent to the author:
+
+ j.loverso@opengroup.org
+ john@loverso.southborough.ma.us
+
diff --git a/tcllib/modules/comm/comm.man b/tcllib/modules/comm/comm.man
new file mode 100644
index 0000000..be1290a
--- /dev/null
+++ b/tcllib/modules/comm/comm.man
@@ -0,0 +1,1230 @@
+[vset COMM_VERSION 4.6.3]
+[manpage_begin comm n [vset COMM_VERSION]]
+[see_also send(n)]
+[keywords comm]
+[keywords communication]
+[keywords ipc]
+[keywords message]
+[keywords {remote communication}]
+[keywords {remote execution}]
+[keywords rpc]
+[keywords secure]
+[keywords send]
+[keywords socket]
+[keywords ssl]
+[keywords tls]
+[copyright {1995-1998 The Open Group. All Rights Reserved.}]
+[copyright {2003-2004 ActiveState Corporation.}]
+[copyright {2006-2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Remote communication}]
+[titledesc {A remote communication facility for Tcl (8.3 and later)}]
+[category {Programming tools}]
+[require Tcl 8.3]
+[require comm [opt [vset COMM_VERSION]]]
+[description]
+
+[para]
+
+The [package comm] command provides an inter-interpreter remote
+execution facility much like Tk's [cmd send(n)], except that it uses
+sockets rather than the X server for the communication path. As a
+result, [package comm] works with multiple interpreters, works on
+Windows and Macintosh systems, and provides control over the remote
+execution path.
+
+[para]
+
+These commands work just like [cmd send] and [cmd {winfo interps}] :
+
+[para]
+[example {
+ ::comm::comm send ?-async? id cmd ?arg arg ...?
+ ::comm::comm interps
+}]
+[para]
+
+This is all that is really needed to know in order to use
+[package comm]
+
+[subsection Commands]
+
+The package initializes [cmd ::comm::comm] as the default [emph chan].
+
+[para]
+[package comm] names communication endpoints with an [emph id] unique
+to each machine. Before sending commands, the [emph id] of another
+interpreter is needed. Unlike Tk's send, [package comm] doesn't
+implicitly know the [emph id]'s of all the interpreters on the system.
+
+The following four methods make up the basic [package comm] interface.
+
+[list_begin definitions]
+
+[call [cmd {::comm::comm send}] [opt -async] \
+ [opt "-command [arg callback]"] \
+ [arg id] [arg cmd] [opt [arg {arg arg ...}]]]
+
+This invokes the given command in the interpreter named by [arg id]. The
+command waits for the result and remote errors are returned unless the
+[option -async] or [option -command] option is given. If [option -async]
+is given, send returns immediately and there is no further notification of
+result. If [option -command] is used, [emph callback] specifies a command
+to invoke when the result is received. These options are mutually
+exclusive. The callback will receive arguments in the form
+[emph {-option value}], suitable for [cmd {array set}].
+
+The options are: [emph -id], the comm id of the interpreter that received
+the command; [emph -serial], a unique serial for each command sent to a
+particular comm interpreter; [emph -chan], the comm channel name;
+[emph -code], the result code of the command; [emph -errorcode], the
+errorcode, if any, of the command; [emph -errorinfo], the errorinfo, if
+any, of the command; and [emph -result], the return value of the command.
+If connection is lost before a reply is received, the callback will be
+invoked with a connection lost message with -code equal to -1. When
+[option -command] is used, the command returns the unique serial for the
+command.
+
+[call [cmd {::comm::comm self}]]
+
+Returns the [emph id] for this channel.
+
+[call [cmd {::comm::comm interps}]]
+
+Returns a list of all the remote [emph id]'s to which this channel is
+connected. [package comm] learns a new remote [emph id] when a command
+is first issued it, or when a remote [emph id] first issues a command
+to this comm channel. [cmd {::comm::comm ids}] is an alias for this
+method.
+
+[call [cmd {::comm::comm connect}] [opt [arg id]]]
+
+Whereas [cmd {::comm::comm send}] will automatically connect to the
+given [arg id], this forces a connection to a remote [emph id] without
+sending a command. After this, the remote [emph id] will appear in
+[cmd {::comm::comm interps}].
+
+[list_end]
+
+[subsection {Eval Semantics}]
+[para]
+
+The evaluation semantics of [cmd {::comm::comm send}] are intended to
+match Tk's [cmd send] [emph exactly]. This means that [package comm]
+evaluates arguments on the remote side.
+
+[para]
+
+If you find that [cmd {::comm::comm send}] doesn't work for a
+particular command, try the same thing with Tk's send and see if the
+result is different. If there is a problem, please report it. For
+instance, there was had one report that this command produced an
+error. Note that the equivalent [cmd send] command also produces the
+same error.
+
+[para]
+[example {
+ % ::comm::comm send id llength {a b c}
+ wrong # args: should be "llength list"
+ % send name llength {a b c}
+ wrong # args: should be "llength list"
+}]
+[para]
+
+The [cmd eval] hook (described below) can be used to change from
+[cmd send]'s double eval semantics to single eval semantics.
+
+[subsection {Multiple Channels}]
+[para]
+
+More than one [cmd comm] channel (or [emph listener]) can be created
+in each Tcl interpreter. This allows flexibility to create full and
+restricted channels. For instance, [term hook] scripts are specific
+to the channel they are defined against.
+
+[list_begin definitions]
+
+[call [cmd {::comm::comm new}] [arg chan] [opt [arg {name value ...}]]]
+
+This creates a new channel and Tcl command with the given channel
+name. This new command controls the new channel and takes all the
+same arguments as [cmd ::comm::comm]. Any remaining arguments are
+passed to the [cmd config] method. The fully qualified channel
+name is returned.
+
+[call [cmd {::comm::comm channels}]]
+
+This lists all the channels allocated in this Tcl interpreter.
+
+[list_end]
+[para]
+
+The default configuration parameters for a new channel are:
+
+[para]
+[example {
+ "-port 0 -local 1 -listen 0 -silent 0"
+}]
+[para]
+
+The default channel [cmd ::comm::comm] is created with:
+
+[para]
+[example {
+ "::comm::comm new ::comm::comm -port 0 -local 1 -listen 1 -silent 0"
+}]
+
+[subsection {Channel Configuration}]
+[para]
+
+The [cmd config] method acts similar to [cmd fconfigure] in that it
+sets or queries configuration variables associated with a channel.
+
+[list_begin definitions]
+[call [cmd {::comm::comm config}]]
+[call [cmd {::comm::comm config}] [arg name]]
+[call [cmd {::comm::comm config}] [opt "[arg name] [arg value] [arg ...]"]]
+
+When given no arguments, [cmd config] returns a list of all variables
+and their value With one argument, [cmd config] returns the value of
+just that argument. With an even number of arguments, the given
+variables are set to the given values.
+
+[list_end]
+
+[para]
+
+These configuration variables can be changed (descriptions of them are
+elsewhere in this manual page):
+
+[list_begin definitions]
+[def "[option -listen] [opt [arg 0|1]]"]
+[def "[option -local] [opt [arg 0|1]]"]
+[def "[option -port] [opt [arg port]]"]
+[def "[option -silent] [opt [arg 0|1]]"]
+[def "[option -socketcmd] [opt [arg commandname]]"]
+
+[def "[option -interp] [opt [arg interpreter]]"]
+[def "[option -events] [opt [arg eventlist]]"]
+[list_end]
+
+[para]
+These configuration variables are read only:
+
+[list_begin definitions]
+[def "[option -chan] [arg chan]"]
+[def "[option -serial] [arg n]"]
+[def "[option -socket] sock[arg In]"]
+[list_end]
+
+[para]
+
+When [cmd config] changes the parameters of an existing channel (with
+the exception of [option -interp] and [option -events]), it closes and
+reopens the listening socket.
+
+An automatically assigned channel [emph id] will change when this
+happens.
+
+Recycling the socket is done by invoking [cmd {::comm::comm abort}],
+which causes all active sends to terminate.
+
+[subsection {Id/port Assignments}]
+[para]
+
+[package comm] uses a TCP port for endpoint [emph id]. The
+
+[method interps] (or [method ids]) method merely lists all the TCP ports
+to which the channel is connected. By default, each channel's
+
+[emph id] is randomly assigned by the operating system (but usually
+starts at a low value around 1024 and increases each time a new socket
+is opened). This behavior is accomplished by giving the
+
+[option -port] config option a value of 0. Alternately, a specific
+TCP port number may be provided for a given channel. As a special
+case, comm contains code to allocate a a high-numbered TCP port
+(>10000) by using [option {-port {}}]. Note that a channel won't be
+created and initialized unless the specific port can be allocated.
+
+[para]
+
+As a special case, if the channel is configured with
+
+[option {-listen 0}], then it will not create a listening socket and
+will use an id of [const 0] for itself. Such a channel is only good
+for outgoing connections (although once a connection is established,
+it can carry send traffic in both directions).
+
+As another special case, if the channel is configured with
+
+[option {-silent 0}], then the listening side will ignore connection
+attempts where the protocol negotiation phase failed, instead of
+throwing an error.
+
+[subsection {Execution Environment}]
+
+A communication channel in its default configuration will use the
+current interpreter for the execution of all received scripts, and of
+the event scripts associated with the various hooks.
+
+[para]
+
+This insecure setup can be changed by the user via the two options
+[option -interp], and [option -events].
+
+[para]
+
+When [option -interp] is set all received scripts are executed in the
+slave interpreter specified as the value of the option. This
+interpreter is expected to exist before configuration. I.e. it is the
+responsibility of the user to create it. However afterward the
+communication channel takes ownership of this interpreter, and will
+destroy it when the communication channel is destroyed.
+
+Note that reconfiguration of the communication channel to either a
+different interpreter or the empty string will release the ownership
+[emph without] destroying the previously configured interpreter. The
+empty string has a special meaning, it restores the default behaviour
+of executing received scripts in the current interpreter.
+
+[para]
+
+[emph {Also of note}] is that replies and callbacks (a special form of
+reply) are [emph not] considered as received scripts. They are
+trusted, part of the internal machinery of comm, and therefore always
+executed in the current interpreter.
+
+[para]
+
+Even if an interpreter has been configured as the execution
+environment for received scripts the event scripts associated with the
+various hooks will by default still be executed in the current
+interpreter. To change this use the option [option -events] to declare
+a list of the events whose scripts should be executed in the declared
+interpreter as well. The contents of this option are ignored if the
+communication channel is configured to execute received scripts in the
+current interpreter.
+
+[subsection {Remote Interpreters}]
+[para]
+
+By default, each channel is restricted to accepting connections from
+the local system. This can be overridden by using the
+
+[option {-local 0}] configuration option For such channels, the
+
+[emph id] parameter takes the form [emph "\{ id host \}"].
+
+[para]
+
+[emph WARNING]: The [emph host] must always be specified in the same
+form (e.g., as either a fully qualified domain name, plain hostname or
+an IP address).
+
+[subsection {Closing Connections}]
+[para]
+
+These methods give control over closing connections:
+
+[list_begin definitions]
+
+[call [cmd {::comm::comm shutdown}] [arg id]]
+
+This closes the connection to [arg id], aborting all outstanding
+commands in progress. Note that nothing prevents the connection from
+being immediately reopened by another incoming or outgoing command.
+
+[call [cmd {::comm::comm abort}]]
+
+This invokes shutdown on all open connections in this comm channel.
+
+[call [cmd {::comm::comm destroy}]]
+
+This aborts all connections and then destroys the this comm channel
+itself, including closing the listening socket. Special code allows
+the default [cmd ::comm::comm] channel to be closed such that the
+
+[cmd ::comm::comm] command it is not destroyed. Doing so closes the
+listening socket, preventing both incoming and outgoing commands on
+the channel. This sequence reinitializes the default channel:
+
+[para]
+[example {
+ "::comm::comm destroy; ::comm::comm new ::comm::comm"
+}]
+
+[list_end]
+
+[para]
+
+When a remote connection is lost (because the remote exited or called
+[cmd shutdown]), [package comm] can invoke an application callback.
+This can be used to cleanup or restart an ancillary process, for
+instance. See the [term lost] callback below.
+
+[subsection Callbacks]
+[para]
+This is a mechanism for setting hooks for particular events:
+
+[list_begin definitions]
+
+[call [cmd {::comm::comm hook}] [arg event] [opt [const +]] [opt [arg script]]]
+
+This uses a syntax similar to Tk's [cmd bind] command. Prefixing
+
+[arg script] with a [const +] causes the new script to be appended.
+Without this, a new [arg script] replaces any existing script. When
+invoked without a script, no change is made. In all cases, the new
+hook script is returned by the command.
+
+[para]
+
+When an [arg event] occurs, the [arg script] associated with it is
+evaluated with the listed variables in scope and available. The
+return code ([emph not] the return value) of the script is commonly
+used decide how to further process after the hook.
+
+[para]
+Common variables include:
+
+[list_begin definitions]
+
+[def [var chan]]
+the name of the comm channel (and command)
+
+[def [var id]]
+the id of the remote in question
+
+[def [var fid]]
+the file id for the socket of the connection
+
+[list_end]
+[list_end]
+
+[para]
+These are the defined [emph events]:
+
+[list_begin definitions]
+
+[def [const connecting]]
+
+Variables:
+[var chan], [var id]
+[comment {[var host], and [var port] are NOT defined when this is called}]
+[para]
+
+This hook is invoked before making a connection to the remote named in
+[arg id]. An error return (via [cmd error]) will abort the connection
+attempt with the error. Example:
+
+[para]
+[example {
+ % ::comm::comm hook connecting {
+ if {[string match {*[02468]} $id]} {
+ error "Can't connect to even ids"
+ }
+ }
+ % ::comm::comm send 10000 puts ok
+ Connect to remote failed: Can't connect to even ids
+ %
+}]
+
+[def [const connected]]
+
+Variables:
+[var chan], [var fid], [var id], [var host], and [var port].
+[para]
+
+This hook is invoked immediately after making a remote connection to
+[arg id], allowing arbitrary authentication over the socket named by
+[arg fid]. An error return (via [cmd error] ) will close the
+connection with the error. [arg host] and [arg port] are merely
+extracted from the [arg id]; changing any of these will have no effect
+on the connection, however. It is also possible to substitute and
+replace [arg fid].
+
+[def [const incoming]]
+
+Variables:
+[var chan], [var fid], [var addr], and [var remport].
+[para]
+
+Hook invoked when receiving an incoming connection, allowing arbitrary
+authentication over socket named by [arg fid]. An error return (via
+[cmd error]) will close the connection with the error. Note that the
+peer is named by [arg remport] and [arg addr] but that the remote
+[emph id] is still unknown. Example:
+
+[para]
+[example {
+ ::comm::comm hook incoming {
+ if {[string match 127.0.0.1 $addr]} {
+ error "I don't talk to myself"
+ }
+ }
+}]
+
+[def [const eval]]
+
+Variables:
+[var chan], [var id], [var cmd], and [var buffer].
+[para]
+
+This hook is invoked after collecting a complete script from a remote
+but [emph before] evaluating it. This allows complete control over
+the processing of incoming commands. [arg cmd] contains either
+[const send] or [const async]. [arg buffer] holds the script to
+evaluate. At the time the hook is called, [arg {$chan remoteid}] is
+identical in value to [arg id].
+
+[para]
+
+By changing [arg buffer], the hook can change the script to be
+evaluated. The hook can short circuit evaluation and cause a value to
+be immediately returned by using [cmd return] [arg result] (or, from
+within a procedure, [cmd {return -code return}] [arg result]). An
+error return (via [cmd error]) will return an error result, as is if
+the script caused the error. Any other return will evaluate the
+script in [arg buffer] as normal. For compatibility with 3.2,
+
+[cmd break] and [cmd {return -code break}] [arg result] is supported,
+acting similarly to [cmd {return {}}] and [cmd {return -code return}]
+[arg result].
+
+[para]
+
+Examples:
+
+[list_begin enumerated]
+
+[enum]
+augmenting a command
+[para]
+[example {
+ % ::comm::comm send [::comm::comm self] pid
+ 5013
+ % ::comm::comm hook eval {puts "going to execute $buffer"}
+ % ::comm::comm send [::comm::comm self] pid
+ going to execute pid
+ 5013
+}]
+
+[enum]
+short circuiting a command
+[para]
+[example {
+ % ::comm::comm hook eval {puts "would have executed $buffer"; return 0}
+ % ::comm::comm send [::comm::comm self] pid
+ would have executed pid
+ 0
+}]
+
+[enum]
+Replacing double eval semantics
+[para]
+[example {
+ % ::comm::comm send [::comm::comm self] llength {a b c}
+ wrong # args: should be "llength list"
+ % ::comm::comm hook eval {return [uplevel #0 $buffer]}
+ return [uplevel #0 $buffer]
+ % ::comm::comm send [::comm::comm self] llength {a b c}
+ 3
+}]
+
+[enum]
+Using a slave interpreter
+[para]
+[example {
+ % interp create foo
+ % ::comm::comm hook eval {return [foo eval $buffer]}
+ % ::comm::comm send [::comm::comm self] set myvar 123
+ 123
+ % set myvar
+ can't read "myvar": no such variable
+ % foo eval set myvar
+ 123
+}]
+
+[enum]
+Using a slave interpreter (double eval)
+[para]
+[example {
+ % ::comm::comm hook eval {return [eval foo eval $buffer]}
+}]
+
+[enum]
+Subverting the script to execute
+[para]
+[example {
+ % ::comm::comm hook eval {
+ switch -- $buffer {
+ a {return A-OK}
+ b {return B-OK}
+ default {error "$buffer is a no-no"}
+ }
+ }
+ % ::comm::comm send [::comm::comm self] pid
+ pid is a no-no
+ % ::comm::comm send [::comm::comm self] a
+ A-OK
+}]
+
+[list_end]
+
+[def [const reply]]
+
+Variables:
+[var chan], [var id], [var buffer], [var ret], and [var return()].
+[para]
+
+This hook is invoked after collecting a complete reply script from a
+remote but [emph before] evaluating it. This allows complete
+control over the processing of replies to sent commands. The reply
+[arg buffer] is in one of the following forms
+
+[list_begin itemized]
+[item]
+return result
+[item]
+return -code code result
+[item]
+return -code code -errorinfo info -errorcode ecode msg
+[list_end]
+[para]
+
+For safety reasons, this is decomposed. The return result is in
+[arg ret], and the return switches are in the return array:
+
+[list_begin itemized]
+[item]
+[emph return(-code)]
+[item]
+[emph return(-errorinfo)]
+[item]
+[emph return(-errorcode)]
+[list_end]
+[para]
+
+Any of these may be the empty string. Modifying these four variables
+can change the return value, whereas modifying [arg buffer] has no
+effect.
+
+[def [const callback]]
+
+Variables:
+[var chan], [var id], [var buffer], [var ret], and [var return()].
+[para]
+
+Similar to [emph reply], but used for callbacks.
+
+[def [const lost]]
+
+Variables:
+[var chan], [var id], and [var reason].
+[para]
+
+This hook is invoked when the connection to [var id] is lost. Return
+value (or thrown error) is ignored. [arg reason] is an explanatory
+string indicating why the connection was lost. Example:
+
+[para]
+
+[example {
+ ::comm::comm hook lost {
+ global myvar
+ if {$myvar(id) == $id} {
+ myfunc
+ return
+ }
+ }
+}]
+
+[list_end]
+
+[subsection Unsupported]
+[para]
+These interfaces may change or go away in subsequence releases.
+
+[list_begin definitions]
+[call [cmd {::comm::comm remoteid}]]
+
+Returns the [arg id] of the sender of the last remote command
+executed on this channel. If used by a proc being invoked remotely,
+it must be called before any events are processed. Otherwise, another
+command may get invoked and change the value.
+
+[call [cmd ::comm::comm_send]]
+
+Invoking this procedure will substitute the Tk [cmd send] and
+[cmd {winfo interps}] commands with these equivalents that use
+[cmd ::comm::comm].
+
+[para]
+
+[example {
+ proc send {args} {
+ eval ::comm::comm send $args
+ }
+ rename winfo tk_winfo
+ proc winfo {cmd args} {
+ if {![string match in* $cmd]} {
+ return [eval [list tk_winfo $cmd] $args]
+ }
+ return [::comm::comm interps]
+ }
+}]
+
+[list_end]
+
+[subsection Security]
+
+Starting with version 4.6 of the package an option [option -socketcmd]
+is supported, allowing the user of a comm channel to specify which
+command to use when opening a socket. Anything which is API-compatible
+with the builtin [cmd ::socket] (the default) can be used.
+
+[para]
+
+The envisioned main use is the specification of the [cmd tls::socket]
+command, see package [package tls], to secure the communication.
+
+[para]
+[example {
+ # Load and initialize tls
+ package require tls
+ tls::init -cafile /path/to/ca/cert -keyfile ...
+
+ # Create secured comm channel
+ ::comm::comm new SECURE -socketcmd tls::socket -listen 1
+ ...
+}]
+
+[para]
+
+The sections [sectref {Execution Environment}] and [sectref Callbacks]
+are also relevant to the security of the system, providing means to
+restrict the execution to a specific environment, perform additional
+authentication, and the like.
+
+[subsection {Blocking Semantics}]
+
+[para]
+
+There is one outstanding difference between [package comm] and
+
+[cmd send]. When blocking in a synchronous remote command, [cmd send]
+uses an internal C hook (Tk_RestrictEvents) to the event loop to look
+ahead for send-related events and only process those without
+processing any other events. In contrast, [package comm] uses the
+
+[cmd vwait] command as a semaphore to indicate the return message has
+arrived. The difference is that a synchronous [cmd send] will block
+the application and prevent all events (including window related ones)
+from being processed, while a synchronous [cmd {::comm::comm send}]
+will block the application but still allow other events to get
+processed. In particular, [cmd {after idle}] handlers will fire
+immediately when comm blocks.
+
+[para]
+
+What can be done about this? First, note that this behavior will come
+from any code using [cmd vwait] to block and wait for an event to
+occur. At the cost of multiple channel support, [package comm] could
+be changed to do blocking I/O on the socket, giving send-like blocking
+semantics. However, multiple channel support is a very useful feature
+of comm that it is deemed too important to lose. The remaining
+approaches involve a new loadable module written in C (which is
+somewhat against the philosophy of [cmd comm ]) One way would be to
+create a modified version of the [cmd vwait] command that allow the
+event flags passed to Tcl_DoOneEvent to be specified. For [cmd comm],
+just the TCL_FILE_EVENTS would be processed. Another way would be to
+implement a mechanism like Tk_RestrictEvents, but apply it to the Tcl
+event loop (since [package comm] doesn't require Tk). One of these
+approaches will be available in a future [package comm] release as an
+optional component.
+
+[subsection {Asynchronous Result Generation}]
+
+By default the result returned by a remotely invoked command is the
+result sent back to the invoker. This means that the result is
+generated synchronously, and the server handling the call is blocked
+for the duration of the command.
+
+[para]
+
+While this is tolerable as long as only short-running commands are
+invoked on the server long-running commands, like database queries
+make this a problem. One command can prevent the processing requests
+of all other clients for an arbitrary period of time.
+
+[para]
+
+Before version 4.5 of comm the only solution was to rewrite the server
+command to use the Tcl builtin command [cmd vwait], or one of its
+relatives like [cmd tkwait], to open a new event loop which processes
+requests while the long-running operation is executed. This however
+has its own perils, as this makes it possible to both overflow the Tcl
+stack with a large number of event loop, and to have a newer requests
+block the return of older ones, as the eventloop have to be unwound in
+the order of their creation.
+
+[para]
+
+The proper solution is to have the invoked command indicate to
+[package comm] that it cannot or will not deliver an immediate,
+synchronous result, but will do so later. At that point the framework
+can put sending the actual result on hold and continue processing
+requests using the main event loop. No blocking, no nesting of event
+loops. At some future date the long running operation delivers the
+result to comm, via the future object, which is then forwarded to the
+invoker as usual.
+
+[para]
+
+The necessary support for this solution has been added to comm since
+version 4.5, in the form of the new method [method return_async].
+
+[list_begin definitions]
+[call [cmd {::comm::comm return_async}]]
+
+This command is used by a remotely invoked script to notify the comm
+channel which invoked it that the result to send back to the invoker
+is not generated synchronously. If this command is not called the
+default/standard behaviour of comm is to send the synchronously
+generated result of the script itself to the invoker.
+
+[para]
+
+The result of [cmd return_async] is an object. This object, called a
+[term future] is where the result of the script has to be delivered to
+when it becomes ready. When that happens it will take all the
+necessary actions to deliver the result to the invoker of the script,
+and then destroy itself. Should comm have lost the connection to the
+invoker while the result is being computed the future will not try to
+deliver the result it got, but just destroy itself. The future can be
+configured with a command to call when the invoker is lost. This
+enables the user to implement an early abort of the long-running
+operation, should this be supported by it.
+
+[para]
+An example:
+
+[example {
+# Procedure invoked by remote clients to run database operations.
+proc select {sql} {
+ # Signal the async generation of the result
+
+ set future [::comm::comm return_async]
+
+ # Generate an async db operation and tell it where to deliver the result.
+
+ set query [db query -command [list $future return] $sql]
+
+ # Tell the database system which query to cancel if the connection
+ # goes away while it is running.
+
+ $future configure -command [list db cancel $query]
+
+ # Note: The above will work without problem only if the async
+ # query will nover run its completion callback immediately, but
+ # only from the eventloop. Because otherwise the future we wish to
+ # configure may already be gone. If that is possible use 'catch'
+ # to prevent the error from propagating.
+ return
+}
+}]
+[para]
+
+The API of a future object is:
+
+[list_begin definitions]
+[call [cmd \$future] [method return] [opt "[option -code] [arg code]"] [opt [arg value]]]
+
+Use this method to tell the future that long-running operation has
+completed. Arguments are an optional return value (defaults to the
+empty string), and the Tcl return code (defaults to OK).
+
+[para]
+
+The future will deliver this information to invoker, if the connection
+was not lost in the meantime, and then destroy itself. If the
+connection was lost it will do nothing but destroy itself.
+
+[call [cmd \$future] [method configure] [opt "[option -command] [opt [arg cmdprefix]]"]]
+[call [cmd \$future] [method cget] [option -command]]
+
+These methods allow the user to retrieve and set a command to be
+called if the connection the future belongs to has been lost.
+
+[list_end]
+
+[list_end]
+
+[subsection Compatibility]
+[para]
+
+[package comm] exports itself as a package. The package version number
+is in the form [emph "major . minor"], where the major version will
+only change when a non-compatible change happens to the API or
+protocol. Minor bug fixes and changes will only affect the minor
+version. To load [package comm] this command is usually used:
+
+[para]
+[example {
+ package require comm 3
+}]
+
+[para]
+Note that requiring no version (or a specific version) can also be done.
+
+[para]
+The revision history of [package comm] includes these releases:
+
+[list_begin definitions]
+
+[def 4.6.3]
+
+Fixed ticket [lb]ced0d60fc9[rb]. Added proper detection of eof on a
+socket, properly closing it.
+
+[def 4.6.2]
+
+Fixed bugs 2972571 and 3066872, the first a misdetection of quoted
+brace after double backslash, the other a blocking gets making for an
+obvious (hinsight) DoS attack on comm channels.
+
+[def 4.6.1]
+
+Changed the implementation of [cmd comm::commCollect] to emulate
+lindex's pre-Tcl 8 behaviour, i.e. it was given the ability to parse
+out the first word of a list, even if the whole buffer is not a
+well-formed list. Without this change the first word could only be
+extracted if the whole buffer was a well-formed list (ever since Tcl
+8), and in a ver-high-load situation, i.e. a server sending lots
+and/or large commands very fast, this may never happen, eventually
+crashing the receiver when it runs out of memory. With the change the
+receiver is always able to process the first word when it becomes
+well-formed, regardless of the structure of the remainder of the
+buffer.
+
+[def 4.6]
+
+Added the option [option -socketcmd] enabling users to override how a
+socket is opened. The envisioned main use is the specification of the
+[cmd tls::socket] command, see package [package tls], to secure the
+communication.
+
+[def 4.5.7]
+
+Changed handling of ports already in use to provide a proper error
+message.
+
+[def 4.5.6]
+
+Bugfix in the replacement for [cmd vwait], made robust against of
+variable names containing spaces.
+
+[def 4.5.5]
+
+Bugfix in the handling of hooks, typo in variable name.
+
+[def 4.5.4]
+
+Bugfix in the handling of the result received by the [method send]
+method. Replaced an [emph {after idle unset result}] with an immediate
+[cmd unset], with the information saved to a local variable.
+
+[para]
+
+The [cmd {after idle}] can spill into a forked child process if there
+is no event loop between its setup and the fork. This may bork the
+child if the next event loop is the [cmd vwait] of [package comm]'s
+[method send] a few lines above the [cmd {after idle}], and the child
+used the same serial number for its next request. In that case the
+parent's [cmd {after idle unset}] will delete the very array element
+the child is waiting for, unlocking the [cmd vwait], causing it to
+access a now missing array element, instead of the expected result.
+
+[def 4.5.3]
+
+Bugfixes in the wrappers for the builtin [cmd update] and [cmd vwait]
+commands.
+
+[def 4.5.2]
+
+Bugfix in the wrapper for the builtin [cmd update] command.
+
+[def 4.5.1]
+
+Bugfixes in the handling of -interp for regular scripts. The handling
+of the buffer was wrong for scripts which are a single statement as
+list. Fixed missing argument to new command [cmd commSendReply],
+introduced by version 4.5. Affected debugging.
+
+[def 4.5]
+
+New server-side feature. The command invoked on the server can now
+switch comm from the standard synchronous return of its result to an
+asynchronous (defered) return. Due to the use of snit to implement the
+[term future] objects used by this feature from this version on comm
+requires at least Tcl 8.3 to run. Please read the section
+[sectref {Asynchronous Result Generation}] for more details.
+
+[def 4.4.1]
+
+Bugfix in the execution of hooks.
+
+[def 4.4]
+
+Bugfixes in the handling of -interp for regular and hook
+scripts. Bugfixes in channel cleanup.
+
+[def 4.3.1]
+
+Introduced -interp and -events to enable easy use of a slave interp
+for execution of received scripts, and of event scripts.
+
+[def 4.3]
+
+Bugfixes, and introduces -silent to allow the user to force the
+server/listening side to silently ignore connection attempts where the
+protocol negotiation failed.
+
+[def 4.2]
+
+Bugfixes, and most important, switched to utf-8 as default encoding
+for full i18n without any problems.
+
+[def 4.1]
+
+Rewrite of internal code to remove old pseudo-object model. Addition
+of send -command asynchronous callback option.
+
+[def 4.0]
+
+Per request by John LoVerso. Improved handling of error for async
+invoked commands.
+
+[def 3.7]
+
+Moved into tcllib and placed in a proper namespace.
+
+[def 3.6]
+
+A bug in the looking up of the remoteid for a executed command could
+be triggered when the connection was closed while several asynchronous
+sends were queued to be executed.
+
+[def 3.5]
+
+Internal change to how reply messages from a [cmd send] are handled.
+Reply messages are now decoded into the [arg value] to pass to
+
+[cmd return]; a new return statement is then cons'd up to with this
+value. Previously, the return code was passed in from the remote as a
+command to evaluate. Since the wire protocol has not changed, this is
+still the case. Instead, the reply handling code decodes the
+
+[const reply] message.
+
+[def 3.4]
+
+Added more source commentary, as well as documenting config variables
+in this man page. Fixed bug were loss of connection would give error
+about a variable named [var pending] rather than the message about
+the lost connection. [cmd {comm ids}] is now an alias for
+
+[cmd {comm interps}] (previously, it an alias for [cmd {comm chans}]).
+Since the method invocation change of 3.0, break and other exceptional
+conditions were not being returned correctly from [cmd {comm send}].
+This has been fixed by removing the extra level of indirection into
+the internal procedure [cmd commSend]. Also added propagation of
+the [arg errorCode] variable. This means that these commands return
+exactly as they would with [cmd send]:
+
+[para]
+[example {
+ comm send id break
+ catch {comm send id break}
+ comm send id expr 1 / 0
+}]
+[para]
+
+Added a new hook for reply messages. Reworked method invocation to
+avoid the use of comm:* procedures; this also cut the invocation time
+down by 40%. Documented [cmd {comm config}] (as this manual page
+still listed the defunct [cmd {comm init}]!)
+
+[def 3.3]
+
+Some minor bugs were corrected and the documentation was cleaned up.
+Added some examples for hooks. The return semantics of the [cmd eval]
+hook were changed.
+
+[def 3.2]
+
+A new wire protocol, version 3, was added. This is backwards
+compatible with version 2 but adds an exchange of supported protocol
+versions to allow protocol negotiation in the future. Several bugs
+with the hook implementation were fixed. A new section of the man
+page on blocking semantics was added.
+
+[def 3.1]
+
+All the documented hooks were implemented. [cmd commLostHook] was
+removed. A bug in [cmd {comm new}] was fixed.
+
+[def 3.0]
+
+This is a new version of [package comm] with several major changes.
+There is a new way of creating the methods available under the
+
+[cmd comm] command. The [cmd {comm init}] method has been retired
+and is replaced by [cmd {comm configure}] which allows access to many
+of the well-defined internal variables. This also generalizes the
+options available to [cmd {comm new}]. Finally, there is now a
+protocol version exchanged when a connection is established. This
+will allow for future on-wire protocol changes. Currently, the
+protocol version is set to 2.
+
+[def 2.3]
+
+[cmd {comm ids}] was renamed to [cmd {comm channels}]. General
+support for [cmd {comm hook}] was fully implemented, but only the
+[term lost] hook exists, and it was changed to follow the general
+hook API. [cmd commLostHook] was unsupported (replaced by
+
+[cmd {comm hook lost}]) and [cmd commLost] was removed.
+
+[def 2.2]
+
+The [term died] hook was renamed [term lost], to be accessed by
+[cmd commLostHook] and an early implementation of
+[cmd {comm lost hook}]. As such, [cmd commDied] is now
+[cmd commLost].
+
+[def 2.1]
+Unsupported method [cmd {comm remoteid}] was added.
+
+[def 2.0]
+[package comm] has been rewritten from scratch (but is fully compatible
+with Comm 1.0, without the requirement to use obTcl).
+
+[list_end]
+
+[include ../common-text/tls-security-notes.inc]
+
+[section Author]
+
+John LoVerso, John@LoVerso.Southborough.MA.US
+
+[para]
+
+[emph http://www.opengroup.org/~loverso/tcl-tk/#comm]
+
+[section License]
+
+Please see the file [emph comm.LICENSE] that accompanied this source,
+or
+[uri http://www.opengroup.org/www/dist_client/caubweb/COPYRIGHT.free.html].
+
+[para]
+
+This license for [package comm], new as of version 3.2, allows it to be
+used for free, without any licensing fee or royalty.
+
+[section Bugs]
+[list_begin itemized]
+[item]
+
+If there is a failure initializing a channel created with
+[cmd {::comm::comm new}], then the channel should be destroyed.
+Currently, it is left in an inconsistent state.
+
+[item]
+
+There should be a way to force a channel to quiesce when changing the
+configuration.
+
+[list_end]
+
+[para]
+The following items can be implemented with the existing hooks and are
+listed here as a reminder to provide a sample hook in a future
+version.
+
+[list_begin itemized]
+[item]
+
+Allow easier use of a slave interp for actual command execution
+(especially when operating in "not local" mode).
+
+[item]
+
+Add host list (xhost-like) or "magic cookie" (xauth-like)
+authentication to initial handshake.
+
+[list_end]
+
+[para]
+The following are outstanding todo items.
+
+[list_begin itemized]
+[item]
+
+Add an interp discovery and name->port mapping. This is likely to be
+in a separate, optional nameserver. (See also the related work,
+below.)
+
+[item]
+
+Fix the [emph {{id host}}] form so as not to be dependent upon
+canonical hostnames. This requires fixes to Tcl to resolve hostnames!
+
+[list_end]
+
+[para]
+This man page is bigger than the source file.
+
+[section {On Using Old Versions Of Tcl}]
+
+[para]
+Tcl7.5 under Windows contains a bug that causes the interpreter to
+hang when EOF is reached on non-blocking sockets. This can be
+triggered with a command such as this:
+
+[para]
+[example {
+ "comm send $other exit"
+}]
+
+[para]
+Always make sure the channel is quiescent before closing/exiting or
+use at least Tcl7.6 under Windows.
+
+[para]
+Tcl7.6 on the Mac contains several bugs. It is recommended you use
+at least Tcl7.6p2.
+
+[para]
+Tcl8.0 on UNIX contains a socket bug that can crash Tcl. It is recommended
+you use Tcl8.0p1 (or Tcl7.6p2).
+
+[section {Related Work}]
+[para]
+Tcl-DP provides an RPC-based remote execution interface, but is a
+compiled Tcl extension. See
+[uri http://www.cs.cornell.edu/Info/Projects/zeno/Projects/Tcl-DP.html].
+
+[para]
+Michael Doyle <miked@eolas.com> has code that implements the Tcl-DP
+RPC interface using standard Tcl sockets, much like [package comm].
+
+[para]
+Andreas Kupries <andreas_kupries@users.sourceforge.net> uses
+[package comm] and has built a simple nameserver as part of his Pool
+library. See [uri http://www.purl.org/net/akupries/soft/pool/index.htm].
+
+[vset CATEGORY comm]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/comm/comm.n.html b/tcllib/modules/comm/comm.n.html
new file mode 100644
index 0000000..03f8a89
--- /dev/null
+++ b/tcllib/modules/comm/comm.n.html
@@ -0,0 +1,1067 @@
+<html>
+<head>
+<!-- This file has been generated by unroff 1.0, 05/30/98 15:43:05. -->
+<!-- Do not edit! -->
+<!-- $Id: comm.n.html,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $ -->
+<!-- %%_OSF_FREE_COPYRIGHT_%% -->
+<!-- Copyright (C) 1995-1998 The Open Group. All Rights Reserved. -->
+<!-- (Please see the file "comm.LICENSE" that accompanied this source) -->
+<!-- unroff -fhtml -man comm.n -->
+<!-- (then fix &lt;title&gt;) -->
+<!-- # CS - begin code excerpt -->
+<!-- # CE - end code excerpt -->
+<title>Manual page for comm(n) version 3.7.1</title>
+</head>
+<body>
+<h2>
+comm.tcl - A remote communications facility for Tcl (7.6, 8.0, and later)
+<hr></h2>
+<h2>SYNOPSIS</h2>
+<b>package require Comm 3</b>
+<p>
+<!-- define all interfaces ONCE -->
+<!-- iD taken (see i2) -->
+<!-- iE taken (see i6) -->
+<!-- iF taken (see i6) -->
+<!-- Show all interfaces -->
+<b></b><i>chan</i><b> send </b>?<i>-async</i>? <i>id cmd </i>?<i>arg arg ...</i>?<tt> </tt>
+<p>
+<b></b><i>chan</i><b> interps</b>
+<p>
+<b></b><i>chan</i><b> ids</b>
+<p>
+<b></b><i>chan</i><b> self</b>
+<p>
+<b></b><i>chan</i><b> connect </b>?<i>id</i>?<tt> </tt>
+<p>
+<b></b><i>chan</i><b> config
+<br>
+</b><b></b><i>chan</i><b> config </b><i>name</i>
+<br>
+<b></b><i>chan</i><b> config ?</b><i>name value ...</i>?<tt> </tt>
+<br>
+<dl><dt><dd>
+-<b>listen </b>?<i>0|1</i>?<tt> </tt>
+-<b>local </b>?<i>0|1</i>?<tt> </tt>
+-<b>port </b>?<i>port</i>?<tt> </tt>
+</dl>
+<p>
+<b></b><i>chan</i><b> new </b><i>chan</i> ?<i>name value ...</i>?<tt> </tt>
+<p>
+<b></b><i>chan</i><b> channels</b>
+<p>
+<b></b><i>chan</i><b> shutdown </b><i>id</i>
+<p>
+<b></b><i>chan</i><b> abort</b>
+<p>
+<b></b><i>chan</i><b> destroy</b>
+<p>
+<b></b><i>chan</i><b> remoteid</b>
+<p>
+<b></b><i>chan</i><b> hook </b><i>event</i> ?<b>+</b>??<i>script</i>?<tt> </tt>
+<p>
+The package initializes <b>comm</b> as the default <i>chan</i>.<tt> </tt>
+<h2>INTRODUCTION</h2>
+<p>
+The
+<b>comm
+</b>command provides an inter-interpreter remote execution facility
+much like Tk's
+<i>send</i>(n)<i>,
+</i>except that it uses sockets rather than
+the X server for the communication path.<tt> </tt>
+As a result,
+<b>comm
+</b>works with multiple interpreters,
+works on Windows and Macintosh systems,
+and
+provides control over the remote execution path.<tt> </tt>
+<p>
+These commands work just like
+<b>send
+</b>and
+<b>winfo interps</b>:
+<tt></tt><dl><dt><dd>
+<b></b><b>comm</b><b> send </b>?<i>-async</i>? <i>id cmd </i>?<i>arg arg ...</i>?
+<br>
+<b></b><b>comm</b><b> interps</b>
+<br>
+</dl>
+This is all that is really needed to know in order to use
+<b>comm</b>.<tt> </tt>
+<h2>DESCRIPTION</h2>
+<p>
+<b>comm
+</b>names communication endpoints with an
+<i>id
+</i>unique to each machine.<tt> </tt>
+Before sending commands, the
+<i>id
+</i>of another interpreter is needed.<tt> </tt>
+Unlike Tk's send,
+<b>comm
+</b>doesn't implicitly know the
+<i>id</i>'s
+of all the interpreters on the system.<tt> </tt>
+<dl>
+<dt><b></b><b>comm</b><b> send </b>?<i>-async</i>? <i>id cmd </i>?<i>arg arg ...</i>?<tt> </tt>
+<dd>
+This invokes the given command in the interpreter named by
+<i>id</i>.<tt> </tt>
+The command waits for the result and remote errors are returned
+unless the
+<b>-async
+</b>option is given.<tt> </tt>
+<dt><b></b><b>comm</b><b> self</b>
+<dd>
+Returns the
+<i>id
+</i>for this channel.<tt> </tt>
+<dt><b></b><b>comm</b><b> interps</b>
+<dd>
+Returns a list of all the remote
+<i>id</i>'s
+to which this channel is connected.<tt> </tt>
+<b>comm
+</b>learns a new remote
+<i>id
+</i>when a command is first issued it,
+or when a remote
+<i>id
+</i>first issues a command to this comm channel.<tt> </tt>
+<b></b><b>comm</b><b> ids</b>
+is an alias for this method.<tt> </tt>
+<dt><b></b><b>comm</b><b> connect </b>?<i>id</i>?<tt> </tt>
+<dd>
+Whereas
+<b>comm send
+</b>will automatically connect to the given
+<i>id</i>,
+this forces a connection to a remote
+<i>id
+</i>without sending a command.<tt> </tt>
+After this, the remote
+<i>id
+</i>will appear in
+<b>comm interps</b>.<tt> </tt>
+</dl>
+<p>
+These four methods make up the basic
+<b>comm
+</b>interface.<tt> </tt>
+<h2>EVAL SEMANTICS</h2>
+<p>
+The evaluation semantics of
+<b>comm send
+</b>are intended to match Tk's
+<b>send
+</b><i>exactly</i>.<tt> </tt>
+This means that
+<b>comm
+</b>evaluates arguments on the remote side.<tt> </tt>
+<p>
+If you find that
+<b>comm send
+</b>doesn't work for a particular command,
+try the same thing with Tk's send and see if the result is different.<tt> </tt>
+If there is a problem, please report it.<tt> </tt>
+For instance, there was had one report that this command produced an error.<tt> </tt>
+Note that the equivalent
+<b>send
+</b>command also produces the same error.<tt> </tt>
+<tt></tt><dl><dt><dd>
+% <b>comm send </b><i>id</i><b> llength {a b c}</b>
+<br>
+<b>wrong # args: should be "llength list"</b>
+<br>
+% <b>send </b><i>name</i><b> llength {a b c}</b>
+<br>
+<b>wrong # args: should be "llength list"</b>
+<br>
+</dl>
+<p>
+The
+<b>eval
+</b>hook (described below) can be used to change from
+<b>send</b>'s
+double eval semantics to single eval semantics.<tt> </tt>
+<h2>MULTIPLE CHANNELS</h2>
+<p>
+More than one
+<b>comm
+</b>channel (or
+<i>listener</i>)
+can be created in each Tcl interpeter.<tt> </tt>
+This allows flexibility to create full and restricted channels.<tt> </tt>
+For instance,
+<b>hook
+</b>scripts are specific to the channel they are defined against.
+<dl>
+<dt><b></b><b>comm</b><b> new </b><i>chan</i> ?<i>name value ...</i>?<tt> </tt>
+<dd>
+This creates a new channel and Tcl command with the given channel name.<tt> </tt>
+This new command controls the new channel and takes all the same
+arguments as
+<b>comm</b>.<tt> </tt>
+Any remaining arguments are passed to the
+<b>config
+</b>method.<tt> </tt>
+<dt><b></b><b>comm</b><b> channels</b>
+<dd>
+This lists all the channels allocated in this Tcl interpreter.<tt> </tt>
+</dl>
+<p>
+The default configuration parameters for a new channel are:
+<tt></tt><dl><dt><dd>
+<b>-port 0 -local 1 -listen 0
+</b></dl>
+The default channel
+<b>comm
+</b>is created with:
+<tt></tt><dl><dt><dd>
+<b>comm new comm -port 0 -local 1 -listen 1
+</b></dl>
+<h2>CHANNEL CONFIGURATION</h2>
+<p>
+The
+<b>config
+</b>method acts similar to
+<b>fconfigure
+</b>in that it sets or queries configuration variables associated with a channel.<tt> </tt>
+<dl><dt><dd>
+<b></b><b>comm</b><b> config
+<br>
+</b><b></b><b>comm</b><b> config </b><i>name</i>
+<br>
+<b></b><b>comm</b><b> config ?</b><i>name value ...</i>?<tt> </tt>
+</dl>
+When given no arguments,
+<b>config
+</b>returns a list of all variables and their value
+With one argument,
+<b>config
+</b>returns the value of just that argument.<tt> </tt>
+With an even number of arguments, the given variables are set to the
+given values.<tt> </tt>
+<p>
+These configuration variables can be changed
+(descriptions of them are elsewhere in this manual page):
+<dl><dt><dd>
+-<b>listen </b>?<i>0|1</i>?<tt> </tt>
+-<b>local </b>?<i>0|1</i>?<tt> </tt>
+-<b>port </b>?<i>port</i>?<tt> </tt>
+</dl>
+<p>
+These configuration variables are readonly:
+<dl><dt><dd>
+-<b>chan</b> <i>chan</i>
+-<b>serial</b> <i>n</i>
+-<b>socket</b> sock<i>n</i>
+</dl>
+<p>
+When
+<b>config
+</b>changes the parameters of an existing channel,
+it closes and reopens the listening socket.<tt> </tt>
+An automatically assigned channel
+<i>id
+</i>will change when this happens.<tt> </tt>
+Recycling the socket is done by invoking
+<b>comm abort</b>,
+which causes all active sends to terminate.<tt> </tt>
+<h2>ID/PORT ASSIGNMENTS</h2>
+<p>
+<b>comm
+</b>uses a TCP port for endpoint
+<i>id</i>.<tt> </tt>
+The
+<b>interps
+</b>(or
+<b>ids</b>)
+method merely lists all the TCP ports to which the channel is connected.<tt> </tt>
+By default, each channel's
+<i>id
+</i>is randomly assigned by the operating system
+(but usually starts at a low value around 1024 and increases
+each time a new socket is opened).<tt> </tt>
+This behavior is accomplished by giving the
+<b>-port
+</b>config option a value of 0.<tt> </tt>
+Alternately, a specific TCP port number may be provided for a given channel.<tt> </tt>
+As a special case, comm contains code to allocate a
+a high-numbered TCP port (&gt;10000) by using
+<b>-port {}</b>.<tt> </tt>
+Note that a channel won't be created and initialized
+unless the specific port can be allocated.<tt> </tt>
+<p>
+As a special case, if the channel is configured with
+<b>-listen 0</b>,
+then it will not create a listening socket and will use an id of
+<i>0
+</i>for itself.<tt> </tt>
+Such a channel is only good for outgoing connections
+(although once a connection is established, it can carry send traffic
+in both directions).<tt> </tt>
+<h2>REMOTE INTERPRETERS</h2>
+<p>
+By default, each channel is restricted to accepting connections from the
+local system. This can be overriden by using the
+<b>-local 0
+</b>configuration option
+For such channels, the
+<i>id
+</i>parameter takes the form
+<b>{</b><i>id host</i><b>}
+</b><b></b>.<tt> </tt>
+<p>
+<b>WARNING</b>:
+The
+<i>host
+</i>must always be specified in the same form
+(e.g., as either a fully qualified domain name,
+plain hostname or an IP address).<tt> </tt>
+<h2>CLOSING CONNECTIONS</h2>
+<p>
+These methods give control over closing connections:
+<dl>
+<dt><b></b><b>comm</b><b> shutdown </b><i>id</i>
+<dd>
+This closes the connection to
+<i>id</i>,
+aborting all outstanding commands in progress. Note that nothing
+prevents the connection from being immediately reopened by another
+incoming or outgoing command.<tt> </tt>
+<dt><b></b><b>comm</b><b> abort</b>
+<dd>
+This invokes shutdown on all open connections in this comm channel.<tt> </tt>
+<dt><b></b><b>comm</b><b> destroy</b>
+<dd>
+This aborts all connections and then destroys the this comm channel itself,
+including closing the listening socket.<tt> </tt>
+Special code allows the default
+<b>comm
+</b>channel to be closed
+such that the
+<b>comm
+</b>command it is not destroyed.<tt> </tt>
+Doing so closes the listening socket, preventing both
+incoming and outgoing commands on the channel.<tt> </tt>
+This sequence reinitializes the default channel:
+<tt></tt></dl>
+<dl><dt><dd>
+<b>comm destroy; comm new comm
+</b></dl>
+<p>
+When a remote connection is lost (because the remote exited or called
+<b>shutdown</b>),
+<b>comm
+</b>can invoke an application callback.<tt> </tt>
+This can be used to cleanup or restart an ancillary process,
+for instance.<tt> </tt>
+See the
+<b>lost
+</b>callback below.<tt> </tt>
+<h2>CALLBACKS</h2>
+<p>
+This is a mechanism for setting hooks for particular events:
+<tt></tt><dl><dt><dd>
+<b></b><b>comm</b><b> hook </b><i>event</i> ?<b>+</b>??<i>script</i>?
+<br>
+</dl>
+<p>
+This uses a syntax similar to Tk's
+<b>bind
+</b>command.<tt> </tt>
+Prefixing
+<i>script
+</i>with a + causes the new script to be appended.<tt> </tt>
+Without this, a new
+<i>script
+</i>replaces any existing script.<tt> </tt>
+When invoked without a script, no change is made.<tt> </tt>
+In all cases, the new hook script is returned by the command.<tt> </tt>
+<p>
+When an
+<i>event
+</i>occurs,
+the
+<i>script
+</i>associated with it is evaluated
+with the listed variables in scope and available.<tt> </tt>
+The return code
+(<b>not
+</b>the return value) of the script
+is commonly used decide how to further process after the hook.<tt> </tt>
+<p>
+Common variables include:
+<dl><dt><dd>
+<dl>
+<dt><b>chan</b><dd>
+the name of the comm channel (and command)
+<dt><b>id</b><dd>
+the id of the remote in question
+<dt><b>fid</b><dd>
+the file id for the socket of the connection
+</dl>
+</dl>
+
+
+These are the defined
+<i>events</i>:
+<dl>
+<dt><b>connecting
+</b><dd>
+Variables:
+<i>chan id host port
+</i><br>
+This hook is invoked before making a connection
+to the remote named in
+<i>id</i>.<tt> </tt>
+An error return (via
+<b>error</b>)
+will abort the connection attempt with the error.<tt> </tt>
+Example:
+<p>
+<tt></tt></dl>
+<dl><dt><dd>
+% comm hook connecting {
+<br>
+ if [string match {*[02468]} $id] {
+<br>
+ error "Can't connect to even ids"
+<br>
+ }
+<br>
+}
+<br>
+% comm send 10000 puts ok
+<br>
+Connect to remote failed: Can't connect to even ids
+<br>
+%
+<br>
+</dl>
+
+<dl>
+<dt><b>connected
+</b><dd>
+Variables:
+<i>chan fid id host port
+</i><br>
+This hook is invoked immediately after making a remote connection to
+<i>id</i>,
+allowing arbitrary authentication over the socket
+named by
+<i>fid</i>.<tt> </tt>
+An error return (via
+<b>error</b>)
+will close the connection with the error.<tt> </tt>
+<i>host
+</i>and
+<i>port
+</i>are merely extracted from the
+<i>id</i>;
+changing any of these will have no effect on the connection, however.<tt> </tt>
+It is also possible to substitute and replace
+<i>fid .
+</i>
+
+<dt><b>incoming
+</b><dd>
+Variables:
+<i>chan fid addr remport
+</i><br>
+Hook invoked when receiving an incoming connection,
+allowing arbitrary authentication over socket
+named by
+<i>fid</i>.<tt> </tt>
+An error return (via
+<b>error</b>)
+will close the connection with the error.<tt> </tt>
+Note that the peer is named by
+<i>remport</i> and <i>addr
+</i>but that the remote
+<i>id
+</i>is still unknown. Example:
+<p>
+<tt></tt></dl>
+<dl><dt><dd>
+comm hook incoming {
+<br>
+ if [string match 127.0.0.1 $addr] {
+<br>
+ error "I don't talk to myself"
+<br>
+ }
+<br>
+}
+<br>
+</dl>
+
+<dl>
+<dt><b>eval
+</b><dd>
+Variables:
+<i>chan id cmd buffer
+</i><br>
+This hook is invoked after collecting a complete script from a remote
+but
+<b>before
+</b>evalutating it.<tt> </tt>
+This allows complete control over the processing of incoming commands.<tt> </tt>
+<i>cmd
+</i>contains either
+<b>send</b> or <b>async</b>.<tt> </tt>
+<i>buffer
+</i>holds the script to evaluate.<tt> </tt>
+At the time the hook is called,
+<b>$chan remoteid
+</b>is identical in value to
+<b>id.
+</b><p>
+By changing
+<i>buffer</i>,
+the hook can change the script to be evaluated.<tt> </tt>
+The hook can short circuit evaluation and cause a
+value to be immediately returned by using
+<b>return
+</b><i>result
+</i>(or, from within a procedure,
+<b>return -code return
+</b><i>result</i>).<tt> </tt>
+An error return (via
+<b>error</b>)
+will return an error result, as is if the script caused the error.<tt> </tt>
+Any other return will evaluate the script in
+<i>buffer
+</i>as normal.<tt> </tt>
+For compatibility with 3.2,
+<b>break
+</b>and
+<b>return -code break
+</b><i>result
+</i>is supported, acting similarly to
+<b>return {}
+</b>and
+<b>return -code return
+</b><i>result</i>.<tt> </tt>
+<p>
+Examples:
+</dl>
+<dl><dt><dd>
+1. augmenting a command
+<tt></tt><dl><dt><dd>
+% comm send [comm self] pid
+<br>
+5013
+<br>
+% comm hook eval {puts "going to execute $buffer"}
+<br>
+% comm send [comm self] pid
+<br>
+going to execute pid
+<br>
+5013
+<br>
+</dl>
+2. short circuting a command
+<tt></tt><dl><dt><dd>
+% comm hook eval {puts "would have executed $buffer"; return 0}
+<br>
+% comm send [comm self] pid
+<br>
+would have executed pid
+<br>
+0
+<br>
+</dl>
+3. Replacing double eval semantics
+<tt></tt><dl><dt><dd>
+% comm send [comm self] llength {a b c}
+<br>
+wrong # args: should be "llength list"
+<br>
+% comm hook eval {return [uplevel #0 $buffer]}
+<br>
+return [uplevel #0 $buffer]
+<br>
+% comm send [comm self] llength {a b c}
+<br>
+3
+<br>
+</dl>
+4. Using a slave interpreter
+<tt></tt><dl><dt><dd>
+% interp create foo
+<br>
+% comm hook eval {return [foo eval $buffer]}
+<br>
+% comm send [comm self] set myvar 123
+<br>
+123
+<br>
+% set myvar
+<br>
+can't read "myvar": no such variable
+<br>
+% foo eval set myvar
+<br>
+123
+<br>
+</dl>
+5. Using a slave interpreter (double eval)
+<tt></tt><dl><dt><dd>
+% comm hook eval {return [eval foo eval $buffer]}
+<br>
+</dl>
+6. Subverting the script to execute
+<tt></tt><dl><dt><dd>
+% comm hook eval {
+<br>
+ switch -- $buffer {
+<br>
+ a {return A-OK} b {return B-OK} default {error "$buffer is a no-no"}
+<br>
+ }
+<br>
+}
+<br>
+% comm send [comm self] pid
+<br>
+pid is a no-no
+<br>
+% comm send [comm self] a
+<br>
+A-OK
+<br>
+</dl>
+</dl>
+
+<dl>
+<dt><b>reply
+</b><dd>
+Variables:
+<i>chan id buffer ret return()
+</i><br>
+This hook is invoked after collecting a complete reply script from a remote
+but
+<b>before
+</b>evalutating it.<tt> </tt>
+This allows complete control over the processing of replies to sent commands.<tt> </tt>
+The reply
+<i>buffer
+</i>is in one of the following forms
+</dl>
+<dl><dt><dd>
+<tt></tt><dl><dt><dd>
+return <i>result</i>
+<br>
+return -code <i>code</i> <i>result</i>
+<br>
+return -code <i>code</i> -errorinfo <i>info</i> -errorcode <i>ecode</i> <i>msg</i>
+<br>
+</dl>
+For safety reasons, this is decomposed. The return result
+is in
+<i>ret</i>,
+and the return switches are in the return array:
+<tt></tt><dl><dt><dd>
+<i>return(-code)
+</i><i>return(-errorinfo)
+</i><i>return(-errordcode)
+</i></dl>
+Any of these may be the empty string.<tt> </tt>
+Modifying
+these four variables can change the return value, whereas
+modifying
+<i>buffer
+</i>has no effect.<tt> </tt>
+</dl>
+
+<dl>
+<dt><b>lost
+</b><dd>
+Variables:
+<i>chan id reason
+</i><br>
+This hook is invoked when the connection to
+<i>id
+</i>is lost.<tt> </tt>
+Return value (or thrown error) is ignored.<tt> </tt>
+<i>reason
+</i>is an explanatory string indicating why the connection was lost.<tt> </tt>
+Example:
+<p>
+<tt></tt></dl>
+<dl><dt><dd>
+comm hook lost {
+<br>
+ global myvar
+<br>
+ if {$myvar(id) == $id} {
+<br>
+ myfunc
+<br>
+ return
+<br>
+ }
+<br>
+}
+<br>
+</dl>
+<h2>UNSUPPORTED</h2>
+<p>
+These interfaces may change or go away in subsequence releases.<tt> </tt>
+<dl>
+<dt><b></b><b>comm</b><b> remoteid</b>
+<dd>
+Returns the
+<i>id
+</i>of the sender of the last remote command executed on this channel.<tt> </tt>
+If used by a proc being invoked remotely, it
+must be called before any events are processed.<tt> </tt>
+Otherwise, another command may get invoked and change the value.<tt> </tt>
+<dt><b>comm_send
+</b><dd>
+Invoking this procedure will substitute the Tk
+<b>send
+</b>and
+<b>winfo interps
+</b>commands with these equivalents that use
+<b>comm</b>.<tt> </tt>
+<p>
+<tt></tt></dl>
+<dl><dt><dd>
+proc send {args} {
+<br>
+ eval comm send $args
+<br>
+}
+<br>
+rename winfo tk_winfo
+<br>
+proc winfo {cmd args} {
+<br>
+ if ![string match in* $cmd] {return [eval [list tk_winfo $cmd] $args]}
+<br>
+ return [comm interps]
+<br>
+}
+<br>
+</dl>
+<h2>SECURITY</h2>
+<p>
+Something here soon.<tt> </tt>
+<h2>BLOCKING SEMANTICS</h2>
+<p>
+There is one outstanding difference between
+<b>comm
+</b>and
+<b>send</b>.<tt> </tt>
+When blocking in a synchronous remote command,
+<b>send
+</b>uses an internal C hook (Tk_RestrictEvents)
+to the event loop to look ahead for
+send-related events and only process those without processing any other events.<tt> </tt>
+In contrast,
+<b>comm
+</b>uses the
+<b>vwait
+</b>command as a semaphore to indicate the return message has arrived.<tt> </tt>
+The difference is that a synchornous
+<b>send
+</b>will block the application and prevent all events
+(including window related ones) from being processed,
+while a synchronous
+<b>comm
+</b>will block the application but still allow
+other events will still get processed.<tt> </tt>
+In particular,
+<b>after idle
+</b>handlers will fire immediately when comm blocks.<tt> </tt>
+<p>
+What can be done about this?<tt> </tt>
+First, note that this behavior will come from any code using
+<b>vwait
+</b>to block and wait for an event to occur.<tt> </tt>
+At the cost of multiple channel support,
+<b>comm
+</b>could be changed to do blocking I/O on the socket,
+givng send-like blocking semantics.<tt> </tt>
+However, multiple channel support is a very useful feature of comm
+that it is deemed too important to lose.<tt> </tt>
+The remaining approaches involve a new loadable module written in C
+(which is somewhat against the philosophy of
+<b>comm</b>)
+One way would be to create a modified version of the
+<b>vwait
+</b>command that allow the event flags passed to Tcl_DoOneEvent to be specified.<tt> </tt>
+For
+<b>comm</b>,
+just the TCL_FILE_EVENTS would be processed.<tt> </tt>
+Another way would be to implement a mechanism like Tk_RestrictEvents, but
+apply it to the Tcl event loop (since
+<b>comm
+</b>doesn't require Tk).<tt> </tt>
+One of these approaches will be available in a future
+<b>comm
+</b>release as an optional component.<tt> </tt>
+<h2>COMPATIBILITY</h2>
+<p>
+<b>Comm
+</b>exports itself as a package.<tt> </tt>
+The package version number is in the form
+<i>major</i>.<i>minor</i>,
+where the major version will only change when
+a non-compatible change happens to the API or protocol.<tt> </tt>
+Minor bug fixes and changes will only affect the minor version.<tt> </tt>
+To load
+<b>comm
+</b>this command is usually used:
+<tt></tt><dl><dt><dd>
+<b>package require Comm 3</b>
+<br>
+</dl>
+Note that requiring no version (or a specific version) can also be done.<tt> </tt>
+<p>
+The revision history of
+<b>comm
+</b>includes these releases:
+
+<dl>
+<dt>3.6<dd>
+A bug in the looking up of the remoteid for a executed command
+could be triggered when the connection was closed while several
+asynchronous sends were queued to be executed.<tt> </tt>
+
+<dt>3.5<dd>
+Internal change to how reply messages from a
+<b>send
+</b>are handled.<tt> </tt>
+Reply messages are now decoded into the
+<i>value
+</i>to pass to
+<b>return</b>;
+a new return statement is then cons'd up to with this value.<tt> </tt>
+Previously, the return code was passed in from the remote as a
+command to evaluate. Since the wire protocol has not changed,
+this is still the case. Instead, the reply handling code decodes the
+<b>reply
+</b>message.<tt> </tt>
+
+<dt>3.4<dd>
+Added more source commentary, as well as documenting config variables
+in this man page.<tt> </tt>
+Fixed bug were loss of connection would give error about a variable
+named
+rather than the message about the lost connection.<tt> </tt>
+<b>comm ids
+</b>is now an alias for
+<b>comm interps
+</b>(previously, it an alias for
+<b>comm chans</b>).<tt> </tt>
+Since the method invocation change of 3.0, break and other exceptional
+conditions were not being returned correctly from
+<b>comm send</b>.<tt> </tt>
+This has been fixed by removing the extra level of indirection into
+the internal procedure
+<b>commSend</b>.<tt> </tt>
+Also added propogation of the
+<i>errorCode
+</i>variable.<tt> </tt>
+This means that these commands return exactly as they would with
+<b>send</b>:
+</dl>
+<dl><dt><dd>
+<tt></tt><dl><dt><dd>
+comm send <i>id</i> break
+<br>
+catch {comm send <i>id</i> break}
+<br>
+comm send <i>id</i> expr 1 / 0
+<br>
+</dl>
+Added a new hook for reply messages.<tt> </tt>
+Reworked method invocation to avoid the use of comm:* procedures;
+this also cut the invocation time down by 40%.<tt> </tt>
+Documented
+<b>comm config
+</b>(as this manual page still listed the defunct
+<b>comm init</b>!)
+</dl>
+
+<dl>
+<dt>3.3<dd>
+Some minor bugs were corrected and the documentation was cleaned up.<tt> </tt>
+Added some examples for hooks. The return semantics of the
+<b>eval
+</b>hook were changed.<tt> </tt>
+
+<dt>3.2<dd>
+A new wire protocol, version 3, was added. This is backwards compatible
+with version 2 but adds an exchange of supported protocol versions to
+allow protocol negotiation in the future.<tt> </tt>
+Several bugs with the hook implementation were fixed.<tt> </tt>
+A new section of the man page on blocking semantics was added.<tt> </tt>
+
+<dt>3.1<dd>
+All the documented hooks were implemented.<tt> </tt>
+<b>commLostHook
+</b>was removed.<tt> </tt>
+A bug in
+<b>comm new
+</b>was fixed.<tt> </tt>
+
+<dt>3.0<dd>
+This is a new version of
+<b>comm
+</b>with several major changes.<tt> </tt>
+There is a new way of creating the methods available under the
+<b>comm
+</b>command.<tt> </tt>
+The
+<b>comm init
+</b>method has been retired and is replaced by
+<b>comm configure
+</b>which allows access to many of the well-defined internal variables.<tt> </tt>
+This also generalizes the options available to
+<b>comm new</b>.<tt> </tt>
+Finally, there is now a protocol version exchanged when a connection
+is established. This will allow for future on-wire protocol changes.<tt> </tt>
+Currently, the protocol version is set to 2.<tt> </tt>
+
+<dt>2.3<dd>
+<b>comm ids
+</b>was renamed to
+<b>comm channels .
+</b>General support for
+<b>comm hook
+</b>was fully implemented, but
+only the
+<b>lost
+</b>hook exists, and it was changed to follow the general hook API.<tt> </tt>
+<b>commLostHook
+</b>was unsupported (replaced by
+<b>comm hook lost )
+</b>and
+<b>commLost
+</b>was removed.<tt> </tt>
+
+<dt>2.2<dd>
+The
+<b>died
+</b>hook was renamed
+<b>lost</b>,
+to be accessed by
+<b>commLostHook
+</b>and an early implementation of
+<b>comm lost hook</b>.<tt> </tt>
+As such,
+<b>commDied
+</b>is now
+<b>commLost</b>.<tt> </tt>
+
+<dt>2.1<dd>
+Unsupported method
+<b>comm remoteid
+</b>was added.<tt> </tt>
+
+<dt>2.0<dd>
+<b>comm
+</b>has been rewritten from scratch (but is fully compatible with Comm 1.0,
+without the requirement to use obTcl).<tt> </tt>
+</dl>
+<h2>SEE ALSO</h2>
+<i>send</i>(n)
+<h2>AUTHOR</h2>
+John LoVerso, John@LoVerso.Southborough.MA.US
+<p>
+<i>http://www.opengroup.org/~loverso/tcl-tk/#comm
+</i><h2>COPYRIGHT</h2>
+Copyright (C) 1995-1998 The Open Group. All Rights Reserved.<tt> </tt>
+Please see the file
+<i>comm.LICENSE
+</i>that accompanied this source,
+or
+<i>http://www.opengroup.org/www/dist_client/caubweb/COPYRIGHT.free.html</i>.<tt> </tt>
+<p>
+This license for
+<b>comm</b>,
+new as of version 3.2,
+allows it to be used for free,
+without any licensing fee or royalty.<tt> </tt>
+<h2>BUGS</h2>
+<ul>
+<li>
+If there is a failure initializing a channel created with
+<b>comm new</b>,
+then the channel should be destroyed.<tt> </tt>
+Currently, it is left in an inconsistent state.<tt> </tt>
+<li>
+There should be a way to force a channel to quiesce when changing the
+configuration.<tt> </tt>
+</ul>
+<p>
+The following items can be implemented with the existing hooks
+and are listed here as a reminder to provide a sample hook in a future version.<tt> </tt>
+<ul>
+<li>
+Allow easier use of a slave interp for actual command execution
+(especially when operating in "not local" mode).<tt> </tt>
+<li>
+Add host list (xhost-like) or "magic cookie" (xauth-like)
+authentication to initial handshake.<tt> </tt>
+</ul>
+<p>
+The following are outstanding todo items.<tt> </tt>
+<ul>
+<li>
+Add an interp discovery and name-&gt;port mapping.<tt> </tt>
+This is likely to be in a separate, optional nameserver.<tt> </tt>
+(See also the related work, below.)
+<li>
+Fix the
+<i>{id host}
+</i>form so as not to be dependent upon canonical hostnames.<tt> </tt>
+This requires fixes to Tcl to resolve hostnames!<tt> </tt>
+</ul>
+<p>
+<p>
+<p>
+This man page is bigger than the source file.<tt> </tt>
+<h2>ON USING OLD VERSIONS OF TCL</h2>
+<p>
+Tcl7.5 under Windows contains a bug that causes the interpreter to
+hang when EOF is reached on non-blocking sockets. This can be
+triggered with a command such as this:
+<tt></tt><dl><dt><dd>
+<b>comm send $other exit
+</b></dl>
+Always make sure the channel is quiescent before closing/exiting or
+use at least Tcl7.6 under Windows.<tt> </tt>
+<p>
+Tcl7.6 on the Mac contains several bugs. It is recommended you use
+at least Tcl7.6p2.<tt> </tt>
+<p>
+Tcl8.0 on UNIX contains a socket bug that can crash Tcl. It is recommended
+you use Tcl8.0p1 (or Tcl7.6p2).<tt> </tt>
+<h2>RELATED WORK</h2>
+<p>
+Tcl-DP provides an RPC-based remote execution interface, but is a compiled
+Tcl extension. See
+<i>http://www.cs.cornell.edu/Info/Projects/zeno/Projects/Tcl-DP.html</i>.<tt> </tt>
+<p>
+Michael Doyle &lt;miked@eolas.com&gt; has code that implements the Tcl-DP RPC
+interface using standard Tcl sockets, much like
+<b>comm</b>.<tt> </tt>
+<p>
+Andreas Kupries &lt;a.kupries@westend.com&gt; uses
+<b>comm
+</b>and has built a simple nameserver as part of his Pool library.<tt> </tt>
+See
+<i>http://www.westend.com/~kupries/doc/pool/index.htm</i>.<tt> </tt>
+<!-- eof -->
+<p><hr>
+Markup created by <em>unroff</em> 1.0,&#160;<tt> </tt>&#160;<tt> </tt>May 30, 1998.
+</body>
+</html>
diff --git a/tcllib/modules/comm/comm.pcx b/tcllib/modules/comm/comm.pcx
new file mode 100644
index 0000000..86a1dd0
--- /dev/null
+++ b/tcllib/modules/comm/comm.pcx
@@ -0,0 +1,99 @@
+# -*- tcl -*- comm.pcx
+# Syntax of the commands provided by package comm.
+
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register comm
+pcx::tcldep 4.5.7 needs tcl 8.3
+
+namespace eval ::comm {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+# TODO: new, word = name of comm channel object, register in scan mode, using this syntax.
+# TODO: hook, word = bind script, look at tk bind syntax.
+
+pcx::check 4.5.7 std ::comm::comm \
+ {checkSimpleArgs 1 -1 {
+ {checkOption {
+ {abort {checkSimpleArgs 0 0 {}}}
+ {channels {checkSimpleArgs 0 0 {}}}
+ {configure {checkSimpleArgs 0 -1 {
+ comm::checkCommSwitches
+ }}}
+ {connect {checkSimpleArgs 1 1 {
+ comm::checkCommId
+ }}}
+ {debug {checkSimpleArgs 1 1 {
+ checkBoolean
+ }}}
+ {destroy {checkSimpleArgs 0 0 {}}}
+ {hook {checkSimpleArgs 1 2 {
+ comm::checkCommHook
+ checkWord
+ }}}
+ {ids {checkSimpleArgs 0 0 {}}}
+ {interps {checkSimpleArgs 0 0 {}}}
+ {new {checkSimpleArgs 1 -1 {
+ checkWord
+ comm::checkCommSwitches
+ }}}
+ {remoteid {checkSimpleArgs 0 0 {}}}
+ {return_async {checkSimpleArgs 0 0 {}}}
+ {self {checkSimpleArgs 0 0 {}}}
+ {send {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ -async
+ {-command {checkWord}}
+ } {checkSimpleArgs 2 -1 {
+ comm::checkCommId
+ checkEvalArgs
+ }}}
+ }}}
+ {shutdown {checkSimpleArgs 1 1 {comm::checkCommId}}}
+ } {}}
+ }}
+pcx::check 4.5.7 std ::comm::comm_send \
+ {checkSimpleArgs 0 0 {}}
+
+# Initialization via pcx::init.
+# Use a ::comm::init procedure for non-standard initialization.
+
+proc comm::checkCommId {t i} {
+ return [checkListValues 1 2 {
+ checkWholeNum
+ checkWord
+ } $t $i]
+}
+
+proc comm::checkCommHook {t i} {
+ return [checkKeyword 1 {
+ connecting connected incoming eval callback reply lost
+ } $t $i]
+}
+
+proc comm::checkCommSwitches {t i} {
+ # socket, serial, encoding are read-only, hence the check that
+ # they are used only without an argument.
+ return [checkSwitches 1 {
+ {-chan {checkSimpleArgs 0 0 {}}}
+ {-encoding checkWord}
+ {-events {checkListValues 0 -1 {comm::checkCommHook}}}
+ {-interp checkWord}
+ {-listen checkBoolean}
+ {-local checkBoolean}
+ {-port checkWholeNum}
+ {-serial {checkSimpleArgs 0 0 {}}}
+ {-silent checkBoolean}
+ {-socket {checkSimpleArgs 0 0 {}}}
+ {-socketcmd checkWord}
+ } {} $t $i]
+}
+
+pcx::complete
diff --git a/tcllib/modules/comm/comm.slaveboot b/tcllib/modules/comm/comm.slaveboot
new file mode 100644
index 0000000..e70bcf9
--- /dev/null
+++ b/tcllib/modules/comm/comm.slaveboot
@@ -0,0 +1,42 @@
+# -*- tcl -*-
+# Script to boot a child running an open comm server
+
+set spawncode [makeFile {
+ catch {wm withdraw .}
+ ##puts [set fh [open ~/foo w]] $argv ; close $fh
+
+ source [lindex $argv 0] ; # load 'snit'
+ source [lindex $argv 1].tcl ; # load 'comm'
+ # and wait for commands. But first send our
+ # own server socket to the initiator
+ ::comm::comm send [lindex $argv 2] [list slaveat [::comm::comm self]]
+ vwait forever
+} spawn]
+
+proc slaveat {id} {
+ #puts "Slave @ $id"
+ proc slave {} [list return $id]
+ set ::go .
+}
+
+#puts "self @ [::comm::comm self]"
+
+exec \
+ [info nameofexecutable] $spawncode \
+ [tcllibPath snit/snit.tcl] \
+ [file rootname [info script]] \
+ [::comm::comm self] &
+
+#puts "Waiting for spawned comm system to boot"
+# Wait for the slave to initialize itself.
+vwait ::go
+
+#puts "Running tests"
+#::comm::comm debug 1
+
+proc slavestop {} {
+ ::comm::comm send -async [slave] {{exit}}
+ ::comm::comm abort
+ removeFile spawn
+ return
+}
diff --git a/tcllib/modules/comm/comm.tcl b/tcllib/modules/comm/comm.tcl
new file mode 100644
index 0000000..55eda34
--- /dev/null
+++ b/tcllib/modules/comm/comm.tcl
@@ -0,0 +1,1818 @@
+# comm.tcl --
+#
+# socket-based 'send'ing of commands between interpreters.
+#
+# %%_OSF_FREE_COPYRIGHT_%%
+# Copyright (C) 1995-1998 The Open Group. All Rights Reserved.
+# (Please see the file "comm.LICENSE" that accompanied this source,
+# or http://www.opengroup.org/www/dist_client/caubweb/COPYRIGHT.free.html)
+# Copyright (c) 2003-2007 ActiveState Corporation
+#
+# This is the 'comm' package written by Jon Robert LoVerso, placed
+# into its own namespace during integration into tcllib.
+#
+# Note that the actual code was changed in several places (Reordered,
+# eval speedup)
+#
+# comm works just like Tk's send, except that it uses sockets.
+# These commands work just like "send" and "winfo interps":
+#
+# comm send ?-async? <id> <cmd> ?<arg> ...?
+# comm interps
+#
+# See the manual page comm.n for further details on this package.
+#
+# RCS: @(#) $Id: comm.tcl,v 1.34 2010/09/15 19:48:33 andreas_kupries Exp $
+
+package require Tcl 8.3
+package require snit ; # comm::future objects.
+
+namespace eval ::comm {
+ namespace export comm comm_send
+
+ variable comm
+ array set comm {}
+
+ if {![info exists comm(chans)]} {
+ array set comm {
+ debug 0 chans {} localhost 127.0.0.1
+ connecting,hook 1
+ connected,hook 1
+ incoming,hook 1
+ eval,hook 1
+ callback,hook 1
+ reply,hook 1
+ lost,hook 1
+ offerVers {3 2}
+ acceptVers {3 2}
+ defVers 2
+ defaultEncoding "utf-8"
+ defaultSilent 0
+ }
+ set comm(lastport) [expr {[pid] % 32768 + 9999}]
+ # fast check for acceptable versions
+ foreach comm(_x) $comm(acceptVers) {
+ set comm($comm(_x),vers) 1
+ }
+ catch {unset comm(_x)}
+ }
+
+ # Class variables:
+ # lastport saves last default listening port allocated
+ # debug enable debug output
+ # chans list of allocated channels
+ # future,fid,$fid List of futures a specific peer is waiting for.
+ #
+ # Channel instance variables:
+ # comm()
+ # $ch,port listening port (our id)
+ # $ch,socket listening socket
+ # $ch,socketcmd command to use to create sockets.
+ # $ch,silent boolean to indicate whether to throw error on
+ # protocol negotiation failure
+ # $ch,local boolean to indicate if port is local
+ # $ch,interp interpreter to run received scripts in.
+ # If not empty we own it! = We destroy it
+ # with the channel
+ # $ch,events List of hoks to run in the 'interp', if defined
+ # $ch,serial next serial number for commands
+ #
+ # $ch,hook,$hook script for hook $hook
+ #
+ # $ch,peers,$id open connections to peers; ch,id=>fid
+ # $ch,fids,$fid reverse mapping for peers; ch,fid=>id
+ # $ch,vers,$id negotiated protocol version for id
+ # $ch,pending,$id list of outstanding send serial numbers for id
+ #
+ # $ch,buf,$fid buffer to collect incoming data
+ # $ch,result,$serial result value set here to wake up sender
+ # $ch,return,$serial return codes to go along with result
+
+ if {0} {
+ # Propagate result, code, and errorCode. Can't just eval
+ # otherwise TCL_BREAK gets turned into TCL_ERROR.
+ global errorInfo errorCode
+ set code [catch [concat commSend $args] res]
+ return -code $code -errorinfo $errorInfo -errorcode $errorCode $res
+ }
+}
+
+# ::comm::comm_send --
+#
+# Convenience command. Replaces Tk 'send' and 'winfo' with
+# versions using the 'comm' variants. Multiple calls are
+# allowed, only the first one will have an effect.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc ::comm::comm_send {} {
+ proc send {args} {
+ # Use pure lists to speed this up.
+ uplevel 1 [linsert $args 0 ::comm::comm send]
+ }
+ rename winfo tk_winfo
+ proc winfo {cmd args} {
+ if {![string match in* $cmd]} {
+ # Use pure lists to speed this up ...
+ return [uplevel 1 [linsert $args 0 tk_winfo $cmd]]
+ }
+ return [::comm::comm interps]
+ }
+ proc ::comm::comm_send {} {}
+}
+
+# ::comm::comm --
+#
+# See documentation for public methods of "comm".
+# This procedure is followed by the definition of
+# the public methods themselves.
+#
+# Arguments:
+# cmd Invoked method
+# args Arguments to method.
+#
+# Results:
+# As of the invoked method.
+
+proc ::comm::comm {cmd args} {
+ set method [info commands ::comm::comm_cmd_$cmd*]
+
+ if {[llength $method] == 1} {
+ set chan ::comm::comm; # passed to methods
+ return [uplevel 1 [linsert $args 0 $method $chan]]
+ } else {
+ foreach c [info commands ::comm::comm_cmd_*] {
+ # remove ::comm::comm_cmd_
+ lappend cmds [string range $c 17 end]
+ }
+ return -code error "unknown subcommand \"$cmd\":\
+ must be one of [join [lsort $cmds] {, }]"
+ }
+}
+
+proc ::comm::comm_cmd_connect {chan args} {
+ uplevel 1 [linsert $args 0 [namespace current]::commConnect $chan]
+}
+proc ::comm::comm_cmd_self {chan args} {
+ variable comm
+ return $comm($chan,port)
+}
+proc ::comm::comm_cmd_channels {chan args} {
+ variable comm
+ return $comm(chans)
+}
+proc ::comm::comm_cmd_configure {chan args} {
+ uplevel 1 [linsert $args 0 [namespace current]::commConfigure $chan 0]
+}
+proc ::comm::comm_cmd_ids {chan args} {
+ variable comm
+ set res $comm($chan,port)
+ foreach {i id} [array get comm $chan,fids,*] {lappend res $id}
+ return $res
+}
+interp alias {} ::comm::comm_cmd_interps {} ::comm::comm_cmd_ids
+proc ::comm::comm_cmd_remoteid {chan args} {
+ variable comm
+ if {[info exists comm($chan,remoteid)]} {
+ set comm($chan,remoteid)
+ } else {
+ return -code error "No remote commands processed yet"
+ }
+}
+proc ::comm::comm_cmd_debug {chan bool} {
+ variable comm
+ return [set comm(debug) [string is true -strict $bool]]
+}
+
+# ### ### ### ######### ######### #########
+## API: Setup async result generation for a remotely invoked command.
+
+# (future,fid,<fid>) -> list (future)
+# (current,async) -> bool (default 0)
+# (current,state) -> list (chan fid cmd ser)
+
+proc ::comm::comm_cmd_return_async {chan} {
+ variable comm
+
+ if {![info exists comm(current,async)]} {
+ return -code error "No remote commands processed yet"
+ }
+ if {$comm(current,async)} {
+ # Return the same future which were generated by the first
+ # call.
+ return $comm(current,state)
+ }
+
+ foreach {cmdchan cmdfid cmd ser} $comm(current,state) break
+
+ # Assert that the channel performing the request and the channel
+ # the current command came in are identical. Panic if not.
+
+ if {![string equal $chan $cmdchan]} {
+ return -code error "Internal error: Trying to activate\
+ async return for a command on a different channel"
+ }
+
+ # Establish the future for the command and return a handle for
+ # it. Remember the outstanding futures for a peer, so that we can
+ # cancel them if the peer is lost before the promise implicit in
+ # the future is redeemed.
+
+ set future [::comm::future %AUTO% $chan $cmdfid $cmd $ser]
+
+ lappend comm(future,fid,$cmdfid) $future
+ set comm(current,state) $future
+
+ # Mark the current command as using async result return. We do
+ # this last to ensure that all errors in this method are reported
+ # through the regular channels.
+
+ set comm(current,async) 1
+
+ return $future
+}
+
+# hook --
+#
+# Internal command. Implements 'comm hook'.
+#
+# Arguments:
+# hook hook to modify
+# script Script to add/remove to/from the hook
+#
+# Results:
+# None.
+#
+proc ::comm::comm_cmd_hook {chan hook {script +}} {
+ variable comm
+ if {![info exists comm($hook,hook)]} {
+ return -code error "Unknown hook invoked"
+ }
+ if {!$comm($hook,hook)} {
+ return -code error "Unimplemented hook invoked"
+ }
+ if {[string equal + $script]} {
+ if {[catch {set comm($chan,hook,$hook)} ret]} {
+ return
+ }
+ return $ret
+ }
+ if {[string match +* $script]} {
+ append comm($chan,hook,$hook) \n [string range $script 1 end]
+ } else {
+ set comm($chan,hook,$hook) $script
+ }
+ return
+}
+
+# abort --
+#
+# Close down all peer connections.
+# Implements the 'comm abort' method.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc ::comm::comm_cmd_abort {chan} {
+ variable comm
+
+ foreach pid [array names comm $chan,peers,*] {
+ commLostConn $chan $comm($pid) "Connection aborted by request"
+ }
+}
+
+# destroy --
+#
+# Destroy the channel invoking it.
+# Implements the 'comm destroy' method.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+#
+proc ::comm::comm_cmd_destroy {chan} {
+ variable comm
+ catch {close $comm($chan,socket)}
+ comm_cmd_abort $chan
+ if {$comm($chan,interp) != {}} {
+ interp delete $comm($chan,interp)
+ }
+ catch {unset comm($chan,port)}
+ catch {unset comm($chan,local)}
+ catch {unset comm($chan,silent)}
+ catch {unset comm($chan,interp)}
+ catch {unset comm($chan,events)}
+ catch {unset comm($chan,socket)}
+ catch {unset comm($chan,socketcmd)}
+ catch {unset comm($chan,remoteid)}
+ unset comm($chan,serial)
+ unset comm($chan,chan)
+ unset comm($chan,encoding)
+ unset comm($chan,listen)
+ # array unset would have been nicer, but is not available in
+ # 8.2/8.3
+ foreach pattern {hook,* interp,* vers,*} {
+ foreach k [array names comm $chan,$pattern] {unset comm($k)}
+ }
+ set pos [lsearch -exact $comm(chans) $chan]
+ set comm(chans) [lreplace $comm(chans) $pos $pos]
+ if {
+ ![string equal ::comm::comm $chan] &&
+ ![string equal [info proc $chan] ""]
+ } {
+ rename $chan {}
+ }
+ return
+}
+
+# shutdown --
+#
+# Close down a peer connection.
+# Implements the 'comm shutdown' method.
+#
+# Arguments:
+# id Reference to the remote interp
+#
+# Results:
+# None.
+#
+proc ::comm::comm_cmd_shutdown {chan id} {
+ variable comm
+
+ if {[info exists comm($chan,peers,$id)]} {
+ commLostConn $chan $comm($chan,peers,$id) \
+ "Connection shutdown by request"
+ }
+}
+
+# new --
+#
+# Create a new comm channel/instance.
+# Implements the 'comm new' method.
+#
+# Arguments:
+# ch Name of the new channel
+# args Configuration, in the form of -option value pairs.
+#
+# Results:
+# None.
+#
+proc ::comm::comm_cmd_new {chan ch args} {
+ variable comm
+
+ if {[lsearch -exact $comm(chans) $ch] >= 0} {
+ return -code error "Already existing channel: $ch"
+ }
+ if {([llength $args] % 2) != 0} {
+ return -code error "Must have an even number of config arguments"
+ }
+ # ensure that the new channel name is fully qualified
+ set ch ::[string trimleft $ch :]
+ if {[string equal ::comm::comm $ch]} {
+ # allow comm to be recreated after destroy
+ } elseif {[string equal $ch [info commands $ch]]} {
+ return -code error "Already existing command: $ch"
+ } else {
+ # Create the new channel with fully qualified proc name
+ proc $ch {cmd args} {
+ set method [info commands ::comm::comm_cmd_$cmd*]
+
+ if {[llength $method] == 1} {
+ # this should work right even if aliased
+ # it is passed to methods to identify itself
+ set chan [namespace origin [lindex [info level 0] 0]]
+ return [uplevel 1 [linsert $args 0 $method $chan]]
+ } else {
+ foreach c [info commands ::comm::comm_cmd_*] {
+ # remove ::comm::comm_cmd_
+ lappend cmds [string range $c 17 end]
+ }
+ return -code error "unknown subcommand \"$cmd\":\
+ must be one of [join [lsort $cmds] {, }]"
+ }
+ }
+ }
+ lappend comm(chans) $ch
+ set chan $ch
+ set comm($chan,serial) 0
+ set comm($chan,chan) $chan
+ set comm($chan,port) 0
+ set comm($chan,listen) 0
+ set comm($chan,socket) ""
+ set comm($chan,local) 1
+ set comm($chan,silent) $comm(defaultSilent)
+ set comm($chan,encoding) $comm(defaultEncoding)
+ set comm($chan,interp) {}
+ set comm($chan,events) {}
+ set comm($chan,socketcmd) ::socket
+
+ if {[llength $args] > 0} {
+ if {[catch [linsert $args 0 commConfigure $chan 1] err]} {
+ comm_cmd_destroy $chan
+ return -code error $err
+ }
+ }
+ return $chan
+}
+
+# send --
+#
+# Send command to a specified channel.
+# Implements the 'comm send' method.
+#
+# Arguments:
+# args see inside
+#
+# Results:
+# varies.
+#
+proc ::comm::comm_cmd_send {chan args} {
+ variable comm
+
+ set cmd send
+
+ # args = ?-async | -command command? id cmd ?arg arg ...?
+ set i 0
+ set opt [lindex $args $i]
+ if {[string equal -async $opt]} {
+ set cmd async
+ incr i
+ } elseif {[string equal -command $opt]} {
+ set cmd command
+ set callback [lindex $args [incr i]]
+ incr i
+ }
+ # args = id cmd ?arg arg ...?
+
+ set id [lindex $args $i]
+ incr i
+ set args [lrange $args $i end]
+
+ if {![info complete $args]} {
+ return -code error "Incomplete command"
+ }
+ if {![llength $args]} {
+ return -code error \
+ "wrong # args: should be \"send ?-async? id arg ?arg ...?\""
+ }
+ if {[catch {commConnect $chan $id} fid]} {
+ return -code error "Connect to remote failed: $fid"
+ }
+
+ set ser [incr comm($chan,serial)]
+ # This is unneeded - wraps from 2147483647 to -2147483648
+ ### if {$comm($chan,serial) == 0x7fffffff} {set comm($chan,serial) 0}
+
+ commDebug {puts stderr "<$chan> send <[list [list $cmd $ser $args]]>"}
+
+ # The double list assures that the command is a single list when read.
+ puts $fid [list [list $cmd $ser $args]]
+ flush $fid
+
+ commDebug {puts stderr "<$chan> sent"}
+
+ # wait for reply if so requested
+
+ if {[string equal command $cmd]} {
+ # In this case, don't wait on the command result. Set the callback
+ # in the return and that will be invoked by the result.
+ lappend comm($chan,pending,$id) [list $ser callback]
+ set comm($chan,return,$ser) $callback
+ return $ser
+ } elseif {[string equal send $cmd]} {
+ upvar 0 comm($chan,pending,$id) pending ;# shorter variable name
+
+ lappend pending $ser
+ set comm($chan,return,$ser) "" ;# we're waiting
+
+ commDebug {puts stderr "<$chan> --<<waiting $ser>>--"}
+ vwait ::comm::comm($chan,result,$ser)
+
+ # if connection was lost, pending is gone
+ if {[info exists pending]} {
+ set pos [lsearch -exact $pending $ser]
+ set pending [lreplace $pending $pos $pos]
+ }
+
+ commDebug {
+ puts stderr "<$chan> result\
+ <$comm($chan,return,$ser);$comm($chan,result,$ser)>"
+ }
+
+ array set return $comm($chan,return,$ser)
+ unset comm($chan,return,$ser)
+ set thisres $comm($chan,result,$ser)
+ unset comm($chan,result,$ser)
+ switch -- $return(-code) {
+ "" - 0 {return $thisres}
+ 1 {
+ return -code $return(-code) \
+ -errorinfo $return(-errorinfo) \
+ -errorcode $return(-errorcode) \
+ $thisres
+ }
+ default {return -code $return(-code) $thisres}
+ }
+ }
+}
+
+###############################################################################
+
+# ::comm::commDebug --
+#
+# Internal command. Conditionally executes debugging
+# statements. Currently this are only puts commands logging the
+# various interactions. These could be replaced with calls into
+# the 'log' module.
+#
+# Arguments:
+# arg Tcl script to execute.
+#
+# Results:
+# None.
+
+proc ::comm::commDebug {cmd} {
+ variable comm
+ if {$comm(debug)} {
+ uplevel 1 $cmd
+ }
+}
+
+# ::comm::commConfVars --
+#
+# Internal command. Used to declare configuration options.
+#
+# Arguments:
+# v Name of configuration option.
+# t Default value.
+#
+# Results:
+# None.
+
+proc ::comm::commConfVars {v t} {
+ variable comm
+ set comm($v,var) $t
+ set comm(vars) {}
+ foreach c [array names comm *,var] {
+ lappend comm(vars) [lindex [split $c ,] 0]
+ }
+ return
+}
+::comm::commConfVars port p
+::comm::commConfVars local b
+::comm::commConfVars listen b
+::comm::commConfVars socket ro
+::comm::commConfVars socketcmd socketcmd
+::comm::commConfVars chan ro
+::comm::commConfVars serial ro
+::comm::commConfVars encoding enc
+::comm::commConfVars silent b
+::comm::commConfVars interp interp
+::comm::commConfVars events ev
+
+# ::comm::commConfigure --
+#
+# Internal command. Implements 'comm configure'.
+#
+# Arguments:
+# force Boolean flag. If set the socket is reinitialized.
+# args New configuration, as -option value pairs.
+#
+# Results:
+# None.
+
+proc ::comm::commConfigure {chan {force 0} args} {
+ variable comm
+
+ # query
+ if {[llength $args] == 0} {
+ foreach v $comm(vars) {lappend res -$v $comm($chan,$v)}
+ return $res
+ } elseif {[llength $args] == 1} {
+ set arg [lindex $args 0]
+ set var [string range $arg 1 end]
+ if {![string match -* $arg] || ![info exists comm($var,var)]} {
+ return -code error "Unknown configuration option: $arg"
+ }
+ return $comm($chan,$var)
+ }
+
+ # set
+ set opt 0
+ foreach arg $args {
+ incr opt
+ if {[info exists skip]} {unset skip; continue}
+ set var [string range $arg 1 end]
+ if {![string match -* $arg] || ![info exists comm($var,var)]} {
+ return -code error "Unknown configuration option: $arg"
+ }
+ set optval [lindex $args $opt]
+ switch $comm($var,var) {
+ ev {
+ if {![string equal $optval ""]} {
+ set err 0
+ if {[catch {
+ foreach ev $optval {
+ if {[lsearch -exact {connecting connected incoming eval callback reply lost} $ev] < 0} {
+ set err 1
+ break
+ }
+ }
+ }]} {
+ set err 1
+ }
+ if {$err} {
+ return -code error \
+ "Non-event to configuration option: -$var"
+ }
+ }
+ # FRINK: nocheck
+ set $var $optval
+ set skip 1
+ }
+ interp {
+ if {
+ ![string equal $optval ""] &&
+ ![interp exists $optval]
+ } {
+ return -code error \
+ "Non-interpreter to configuration option: -$var"
+ }
+ # FRINK: nocheck
+ set $var $optval
+ set skip 1
+ }
+ b {
+ # FRINK: nocheck
+ set $var [string is true -strict $optval]
+ set skip 1
+ }
+ v {
+ # FRINK: nocheck
+ set $var $optval
+ set skip 1
+ }
+ p {
+ if {
+ ![string equal $optval ""] &&
+ ![string is integer $optval]
+ } {
+ return -code error \
+ "Non-port to configuration option: -$var"
+ }
+ # FRINK: nocheck
+ set $var $optval
+ set skip 1
+ }
+ i {
+ if {![string is integer $optval]} {
+ return -code error \
+ "Non-integer to configuration option: -$var"
+ }
+ # FRINK: nocheck
+ set $var $optval
+ set skip 1
+ }
+ enc {
+ # to configure encodings, we will need to extend the
+ # protocol to allow for handshaked encoding changes
+ return -code error "encoding not configurable"
+ if {[lsearch -exact [encoding names] $optval] == -1} {
+ return -code error \
+ "Unknown encoding to configuration option: -$var"
+ }
+ set $var $optval
+ set skip 1
+ }
+ ro {
+ return -code error "Readonly configuration option: -$var"
+ }
+ socketcmd {
+ if {$optval eq {}} {
+ return -code error \
+ "Non-command to configuration option: -$var"
+ }
+
+ set $var $optval
+ set skip 1
+ }
+ }
+ }
+ if {[info exists skip]} {
+ return -code error "Missing value for option: $arg"
+ }
+
+ foreach var {port listen local socketcmd} {
+ # FRINK: nocheck
+ if {[info exists $var] && [set $var] != $comm($chan,$var)} {
+ incr force
+ # FRINK: nocheck
+ set comm($chan,$var) [set $var]
+ }
+ }
+
+ foreach var {silent interp events} {
+ # FRINK: nocheck
+ if {[info exists $var] && ([set $var] != $comm($chan,$var))} {
+ # FRINK: nocheck
+ set comm($chan,$var) [set ip [set $var]]
+ if {[string equal $var "interp"] && ($ip != "")} {
+ # Interrogate the interp about its capabilities.
+ #
+ # Like: set, array set, uplevel present ?
+ # Or: The above, hidden ?
+ #
+ # This is needed to decide how to execute hook scripts
+ # and regular scripts in this interpreter.
+ set comm($chan,interp,set) [Capability $ip set]
+ set comm($chan,interp,aset) [Capability $ip array]
+ set comm($chan,interp,upl) [Capability $ip uplevel]
+ }
+ }
+ }
+
+ if {[info exists encoding] &&
+ ![string equal $encoding $comm($chan,encoding)]} {
+ # This should not be entered yet
+ set comm($chan,encoding) $encoding
+ fconfigure $comm($chan,socket) -encoding $encoding
+ foreach {i sock} [array get comm $chan,peers,*] {
+ fconfigure $sock -encoding $encoding
+ }
+ }
+
+ # do not re-init socket
+ if {!$force} {return ""}
+
+ # User is recycling object, possibly to change from local to !local
+ if {[info exists comm($chan,socket)]} {
+ comm_cmd_abort $chan
+ catch {close $comm($chan,socket)}
+ unset comm($chan,socket)
+ }
+
+ set comm($chan,socket) ""
+ if {!$comm($chan,listen)} {
+ set comm($chan,port) 0
+ return ""
+ }
+
+ if {[info exists port] && [string equal "" $comm($chan,port)]} {
+ set nport [incr comm(lastport)]
+ } else {
+ set userport 1
+ set nport $comm($chan,port)
+ }
+ while {1} {
+ set cmd [list $comm($chan,socketcmd) -server [list ::comm::commIncoming $chan]]
+ if {$comm($chan,local)} {
+ lappend cmd -myaddr $comm(localhost)
+ }
+ lappend cmd $nport
+ if {![catch $cmd ret]} {
+ break
+ }
+ if {[info exists userport] || ![string match "*already in use" $ret]} {
+ # don't eradicate the class
+ if {
+ ![string equal ::comm::comm $chan] &&
+ ![string equal [info proc $chan] ""]
+ } {
+ rename $chan {}
+ }
+ return -code error $ret
+ }
+ set nport [incr comm(lastport)]
+ }
+ set comm($chan,socket) $ret
+ fconfigure $ret -translation lf -encoding $comm($chan,encoding)
+
+ # If port was 0, system allocated it for us
+ set comm($chan,port) [lindex [fconfigure $ret -sockname] 2]
+ return ""
+}
+
+# ::comm::Capability --
+#
+# Internal command. Interogate an interp for
+# the commands needed to execute regular and
+# hook scripts.
+
+proc ::comm::Capability {interp cmd} {
+ if {[lsearch -exact [interp hidden $interp] $cmd] >= 0} {
+ # The command is present, although hidden.
+ return hidden
+ }
+
+ # The command is not a hidden command. Use info to determine if it
+ # is present as regular command. Note that the 'info' command
+ # itself might be hidden.
+
+ if {[catch {
+ set has [llength [interp eval $interp [list info commands $cmd]]]
+ }] && [catch {
+ set has [llength [interp invokehidden $interp info commands $cmd]]
+ }]} {
+ # Unable to interogate the interpreter in any way. Assume that
+ # the command is not present.
+ set has 0
+ }
+ return [expr {$has ? "ok" : "no"}]
+}
+
+# ::comm::commConnect --
+#
+# Internal command. Called to connect to a remote interp
+#
+# Arguments:
+# id Specification of the location of the remote interp.
+# A list containing either one or two elements.
+# One element = port, host is localhost.
+# Two elements = port and host, in this order.
+#
+# Results:
+# fid channel handle of the socket the connection goes through.
+
+proc ::comm::commConnect {chan id} {
+ variable comm
+
+ commDebug {puts stderr "<$chan> commConnect $id"}
+
+ # process connecting hook now
+ CommRunHook $chan connecting
+
+ if {[info exists comm($chan,peers,$id)]} {
+ return $comm($chan,peers,$id)
+ }
+ if {[lindex $id 0] == 0} {
+ return -code error "Remote comm is anonymous; cannot connect"
+ }
+
+ if {[llength $id] > 1} {
+ set host [lindex $id 1]
+ } else {
+ set host $comm(localhost)
+ }
+ set port [lindex $id 0]
+ set fid [$comm($chan,socketcmd) $host $port]
+
+ # process connected hook now
+ if {[catch {
+ CommRunHook $chan connected
+ } err]} {
+ global errorInfo
+ set ei $errorInfo
+ close $fid
+ error $err $ei
+ }
+
+ # commit new connection
+ commNewConn $chan $id $fid
+
+ # send offered protocols versions and id to identify ourselves to remote
+ puts $fid [list $comm(offerVers) $comm($chan,port)]
+ set comm($chan,vers,$id) $comm(defVers) ;# default proto vers
+ flush $fid
+ return $fid
+}
+
+# ::comm::commIncoming --
+#
+# Internal command. Called for an incoming new connection.
+# Handles connection setup and initialization.
+#
+# Arguments:
+# chan logical channel handling the connection.
+# fid channel handle of the socket running the connection.
+# addr ip address of the socket channel 'fid'
+# remport remote port for the socket channel 'fid'
+#
+# Results:
+# None.
+
+proc ::comm::commIncoming {chan fid addr remport} {
+ variable comm
+
+ commDebug {puts stderr "<$chan> commIncoming $fid $addr $remport"}
+
+ # process incoming hook now
+ if {[catch {
+ CommRunHook $chan incoming
+ } err]} {
+ global errorInfo
+ set ei $errorInfo
+ close $fid
+ error $err $ei
+ }
+
+ # Wait for offered version, without blocking the entire system.
+ # Bug 3066872. For a Tcl 8.6 implementation consider use of
+ # coroutines to hide the CSP and properly handle everything
+ # event based.
+
+ fconfigure $fid -blocking 0
+ fileevent $fid readable [list ::comm::commIncomingOffered $chan $fid $addr $remport]
+ return
+}
+
+proc ::comm::commIncomingOffered {chan fid addr remport} {
+ variable comm
+
+ # Check if we have a complete line.
+ if {[gets $fid protoline] < 0} {
+ #commDebug {puts stderr "commIncomingOffered: no data"}
+ if {[eof $fid]} {
+ commDebug {puts stderr "commIncomingOffered: eof on fid=$fid"}
+ catch {
+ close $fid
+ }
+ }
+ return
+ }
+
+ # Protocol version line has been received, disable event handling
+ # again.
+ fileevent $fid readable {}
+ fconfigure $fid -blocking 1
+
+ # a list of offered proto versions is the first word of first line
+ # remote id is the second word of first line
+ # rest of first line is ignored
+
+ set offeredvers [lindex $protoline 0]
+ set remid [lindex $protoline 1]
+
+ commDebug {puts stderr "<$chan> offered <$protoline>"}
+
+ # use the first supported version in the offered list
+ foreach v $offeredvers {
+ if {[info exists comm($v,vers)]} {
+ set vers $v
+ break
+ }
+ }
+ if {![info exists vers]} {
+ close $fid
+ if {[info exists comm($chan,silent)] &&
+ [string is true -strict $comm($chan,silent)]} then return
+ error "Unknown offered protocols \"$protoline\" from $addr/$remport"
+ }
+
+ # If the remote host addr isn't our local host addr,
+ # then add it to the remote id.
+ if {[string equal [lindex [fconfigure $fid -sockname] 0] $addr]} {
+ set id $remid
+ } else {
+ set id [list $remid $addr]
+ }
+
+ # Detect race condition of two comms connecting to each other
+ # simultaneously. It is OK when we are talking to ourselves.
+
+ if {[info exists comm($chan,peers,$id)] && $id != $comm($chan,port)} {
+
+ puts stderr "commIncoming race condition: $id"
+ puts stderr "peers=$comm($chan,peers,$id) port=$comm($chan,port)"
+
+ # To avoid the race, we really want to terminate one connection.
+ # However, both sides are committed to using it.
+ # commConnect needs to be synchronous and detect the close.
+ # close $fid
+ # return $comm($chan,peers,$id)
+ }
+
+ # Make a protocol response. Avoid any temptation to use {$vers > 2}
+ # - this forces forwards compatibility issues on protocol versions
+ # that haven't been invented yet. DON'T DO IT! Instead, test for
+ # each supported version explicitly. I.e., {$vers >2 && $vers < 5} is OK.
+
+ switch $vers {
+ 3 {
+ # Respond with the selected version number
+ puts $fid [list [list vers $vers]]
+ flush $fid
+ }
+ }
+
+ # commit new connection
+ commNewConn $chan $id $fid
+ set comm($chan,vers,$id) $vers
+}
+
+# ::comm::commNewConn --
+#
+# Internal command. Common new connection processing
+#
+# Arguments:
+# id Reference to the remote interp
+# fid channel handle of the socket running the connection.
+#
+# Results:
+# None.
+
+proc ::comm::commNewConn {chan id fid} {
+ variable comm
+
+ commDebug {puts stderr "<$chan> commNewConn $id $fid"}
+
+ # There can be a race condition two where comms connect to each other
+ # simultaneously. This code favors our outgoing connection.
+
+ if {[info exists comm($chan,peers,$id)]} {
+ # abort this connection, use the existing one
+ # close $fid
+ # return -code return $comm($chan,peers,$id)
+ } else {
+ set comm($chan,pending,$id) {}
+ set comm($chan,peers,$id) $fid
+ }
+ set comm($chan,fids,$fid) $id
+ fconfigure $fid -translation lf -encoding $comm($chan,encoding) -blocking 0
+ fileevent $fid readable [list ::comm::commCollect $chan $fid]
+}
+
+# ::comm::commLostConn --
+#
+# Internal command. Called to tidy up a lost connection,
+# including aborting ongoing sends. Each send should clean
+# themselves up in pending/result.
+#
+# Arguments:
+# fid Channel handle of the socket which got lost.
+# reason Message describing the reason of the loss.
+#
+# Results:
+# reason
+
+proc ::comm::commLostConn {chan fid reason} {
+ variable comm
+
+ commDebug {puts stderr "<$chan> commLostConn $fid $reason"}
+
+ catch {close $fid}
+
+ set id $comm($chan,fids,$fid)
+
+ # Invoke the callbacks of all commands which have such and are
+ # still waiting for a response from the lost peer. Use an
+ # appropriate error.
+
+ foreach s $comm($chan,pending,$id) {
+ if {[string equal "callback" [lindex $s end]]} {
+ set ser [lindex $s 0]
+ if {[info exists comm($chan,return,$ser)]} {
+ set args [list -id $id \
+ -serial $ser \
+ -chan $chan \
+ -code -1 \
+ -errorcode NONE \
+ -errorinfo "" \
+ -result $reason \
+ ]
+ if {[catch {uplevel \#0 $comm($chan,return,$ser) $args} err]} {
+ commBgerror $err
+ }
+ }
+ } else {
+ set comm($chan,return,$s) {-code error}
+ set comm($chan,result,$s) $reason
+ }
+ }
+ unset comm($chan,pending,$id)
+ unset comm($chan,fids,$fid)
+ catch {unset comm($chan,peers,$id)} ;# race condition
+ catch {unset comm($chan,buf,$fid)}
+
+ # Cancel all outstanding futures for requests which were made by
+ # the lost peer, if there are any. This does not destroy
+ # them. They will stay around until the long-running operations
+ # they belong too kill them.
+
+ CancelFutures $fid
+
+ # process lost hook now
+ catch {CommRunHook $chan lost}
+
+ return $reason
+}
+
+proc ::comm::commBgerror {err} {
+ # SF Tcllib Patch #526499
+ # (See http://sourceforge.net/tracker/?func=detail&aid=526499&group_id=12883&atid=312883
+ # for initial request and comments)
+ #
+ # Error in async call. Look for [bgerror] to report it. Same
+ # logic as in Tcl itself. Errors thrown by bgerror itself get
+ # reported to stderr.
+ if {[catch {bgerror $err} msg]} {
+ puts stderr "bgerror failed to handle background error."
+ puts stderr " Original error: $err"
+ puts stderr " Error in bgerror: $msg"
+ flush stderr
+ }
+}
+
+# CancelFutures: Mark futures associated with a comm channel as
+# expired, done when the connection to the peer has been lost. The
+# marked futures will not generate result anymore. They will also stay
+# around until destroyed by the script they belong to.
+
+proc ::comm::CancelFutures {fid} {
+ variable comm
+ if {![info exists comm(future,fid,$fid)]} return
+
+ commDebug {puts stderr "\tCanceling futures: [join $comm(future,fid,$fid) \
+ "\n\t : "]"}
+
+ foreach future $comm(future,fid,$fid) {
+ $future Cancel
+ }
+
+ unset comm(future,fid,$fid)
+ return
+}
+
+###############################################################################
+
+# ::comm::commCollect --
+#
+# Internal command. Called from the fileevent to read from fid
+# and append to the buffer. This continues until we get a whole
+# command, which we then invoke.
+#
+# Arguments:
+# chan logical channel collecting the data
+# fid channel handle of the socket we collect.
+#
+# Results:
+# None.
+
+proc ::comm::commCollect {chan fid} {
+ variable comm
+ upvar #0 comm($chan,buf,$fid) data
+
+ # Tcl8 may return an error on read after a close
+ if {[catch {read $fid} nbuf] || [eof $fid]} {
+ commDebug {puts stderr "<$chan> collect/lost eof $fid = [eof $fid]"}
+ commDebug {puts stderr "<$chan> collect/lost nbuf = <$nbuf>"}
+ commDebug {puts stderr "<$chan> collect/lost [fconfigure $fid]"}
+
+ fileevent $fid readable {} ;# be safe
+ commLostConn $chan $fid "target application died or connection lost"
+ return
+ }
+ append data $nbuf
+
+ commDebug {puts stderr "<$chan> collect <$data>"}
+
+ # If data contains at least one complete command, we will
+ # be able to take off the first element, which is a list holding
+ # the command. This is true even if data isn't a well-formed
+ # list overall, with unmatched open braces. This works because
+ # each command in the protocol ends with a newline, thus allowing
+ # lindex and lreplace to work.
+ #
+ # This isn't true with Tcl8.0, which will return an error until
+ # the whole buffer is a valid list. This is probably OK, although
+ # it could potentially cause a deadlock.
+
+ # [AK] Actually no. This breaks down if the sender shoves so much
+ # data at us so fast that the receiver runs into out of memory
+ # before the list is fully well-formed and thus able to be
+ # processed.
+
+ while {![catch {
+ set cmdrange [Word0 data]
+ # word0 is essentially the pre-8.0 'lindex <list> 0', getting
+ # the first word of a list, even if the remainder is not fully
+ # well-formed. Slight API change, we get the char indices the
+ # word is between, and a relative index to the remainder of
+ # the list.
+ }]} {
+ # Unpack the indices, then extract the word.
+ foreach {s e step} $cmdrange break
+ set cmd [string range $data $s $e]
+ commDebug {puts stderr "<$chan> cmd <$data>"}
+ if {[string equal "" $cmd]} break
+ if {[info complete $cmd]} {
+ # The word is a command, step to the remainder of the
+ # list, and delete the word we have processed.
+ incr e $step
+ set data [string range $data $e end]
+ after idle \
+ [list ::comm::commExec $chan $fid $comm($chan,fids,$fid) $cmd]
+ }
+ }
+}
+
+proc ::comm::Word0 {dv} {
+ upvar 1 $dv data
+
+ # data
+ #
+ # The string we expect to be either a full well-formed list, or a
+ # well-formed list until the end of the first word in the list,
+ # with non-wellformed data following after, i.e. an incomplete
+ # list with a complete first word.
+
+ if {[regexp -indices "^\\s*(\{)" $data -> bracerange]} {
+ # The word is brace-quoted, starting at index 'lindex
+ # bracerange 0'. We now have to find the closing brace,
+ # counting inner braces, ignoring quoted braces. We fail if
+ # there is no proper closing brace.
+
+ foreach {s e} $bracerange break
+ incr s ; # index of the first char after the brace.
+ incr e ; # same. but this is our running index.
+
+ set level 1
+ set max [string length $data]
+
+ while {$level} {
+ # We are looking for the first regular or backslash-quoted
+ # opening or closing brace in the string. If none is found
+ # then the word is not complete, and we abort our search.
+
+ # Bug 2972571: To avoid the bogus detection of
+ # backslash-quoted braces we look for double-backslashes
+ # as well and skip them. Without this a string like '{puts
+ # \\}' will incorrectly find a \} at the end, missing the
+ # end of the word.
+
+ if {![regexp -indices -start $e {((\\\\)|([{}])|(\\[{}]))} $data -> any dbs regular quoted]} {
+ # ^^ ^ ^
+ # |\\ regular \quoted
+ # any
+ return -code error "no complete word found/1"
+ }
+
+ foreach {ds de} $dbs break
+ foreach {qs qe} $quoted break
+ foreach {rs re} $regular break
+
+ if {$ds >= 0} {
+ # Skip double-backslashes ...
+ set e $de
+ incr e
+ continue
+ } elseif {$qs >= 0} {
+ # Skip quoted braces ...
+ set e $qe
+ incr e
+ continue
+ } elseif {$rs >= 0} {
+ # Step one nesting level in or out.
+ if {[string index $data $rs] eq "\{"} {
+ incr level
+ } else {
+ incr level -1
+ }
+ set e $re
+ incr e
+ #puts @$e
+ continue
+ } else {
+ return -code error "internal error"
+ }
+ }
+
+ incr e -2 ; # index of character just before the brace.
+ return [list $s $e 2]
+
+ } elseif {[regexp -indices {^\s*(\S+)\s} $data -> wordrange]} {
+ # The word is a simple literal which ends at the next
+ # whitespace character. Note that there has to be a whitespace
+ # for us to recognize a word, for while there is no whitespace
+ # behind it in the buffer the word itself may be incomplete.
+
+ return [linsert $wordrange end 1]
+ }
+
+ return -code error "no complete word found/2"
+}
+
+# ::comm::commExec --
+#
+# Internal command. Receives and executes a remote command,
+# returning the result and/or error. Unknown protocol commands
+# are silently discarded
+#
+# Arguments:
+# chan logical channel collecting the data
+# fid channel handle of the socket we collect.
+# remoteid id of the other side.
+# buf buffer containing the command to execute.
+#
+# Results:
+# None.
+
+proc ::comm::commExec {chan fid remoteid buf} {
+ variable comm
+
+ # buffer should contain:
+ # send # {cmd} execute cmd and send reply with serial #
+ # async # {cmd} execute cmd but send no reply
+ # reply # {cmd} execute cmd as reply to serial #
+
+ # these variables are documented in the hook interface
+ set cmd [lindex $buf 0]
+ set ser [lindex $buf 1]
+ set buf [lrange $buf 2 end]
+ set buffer [lindex $buf 0]
+
+ # Save remoteid for "comm remoteid". This will only be valid
+ # if retrieved before any additional events occur on this channel.
+ # N.B. we could have already lost the connection to remote, making
+ # this id be purely informational!
+ set comm($chan,remoteid) [set id $remoteid]
+
+ # Save state for possible async result generation
+ AsyncPrepare $chan $fid $cmd $ser
+
+ commDebug {puts stderr "<$chan> exec <$cmd,$ser,$buf>"}
+
+ switch -- $cmd {
+ send - async - command {}
+ callback {
+ if {![info exists comm($chan,return,$ser)]} {
+ commDebug {puts stderr "<$chan> No one waiting for serial \"$ser\""}
+ return
+ }
+
+ # Decompose reply command to assure it only uses "return"
+ # with no side effects.
+
+ array set return {-code "" -errorinfo "" -errorcode ""}
+ set ret [lindex $buffer end]
+ set len [llength $buffer]
+ incr len -2
+ foreach {sw val} [lrange $buffer 1 $len] {
+ if {![info exists return($sw)]} continue
+ set return($sw) $val
+ }
+
+ catch {CommRunHook $chan callback}
+
+ # this wakes up the sender
+ commDebug {puts stderr "<$chan> --<<wakeup $ser>>--"}
+
+ # the return holds the callback command
+ # string map the optional %-subs
+ set args [list -id $id \
+ -serial $ser \
+ -chan $chan \
+ -code $return(-code) \
+ -errorcode $return(-errorcode) \
+ -errorinfo $return(-errorinfo) \
+ -result $ret \
+ ]
+ set code [catch {uplevel \#0 $comm($chan,return,$ser) $args} err]
+ catch {unset comm($chan,return,$ser)}
+
+ # remove pending serial
+ upvar 0 comm($chan,pending,$id) pending
+ if {[info exists pending]} {
+ set pos [lsearch -exact $pending [list $ser callback]]
+ if {$pos != -1} {
+ set pending [lreplace $pending $pos $pos]
+ }
+ }
+ if {$code} {
+ commBgerror $err
+ }
+ return
+ }
+ reply {
+ if {![info exists comm($chan,return,$ser)]} {
+ commDebug {puts stderr "<$chan> No one waiting for serial \"$ser\""}
+ return
+ }
+
+ # Decompose reply command to assure it only uses "return"
+ # with no side effects.
+
+ array set return {-code "" -errorinfo "" -errorcode ""}
+ set ret [lindex $buffer end]
+ set len [llength $buffer]
+ incr len -2
+ foreach {sw val} [lrange $buffer 1 $len] {
+ if {![info exists return($sw)]} continue
+ set return($sw) $val
+ }
+
+ catch {CommRunHook $chan reply}
+
+ # this wakes up the sender
+ commDebug {puts stderr "<$chan> --<<wakeup $ser>>--"}
+ set comm($chan,result,$ser) $ret
+ set comm($chan,return,$ser) [array get return]
+ return
+ }
+ vers {
+ set ::comm::comm($chan,vers,$id) $ser
+ return
+ }
+ default {
+ commDebug {puts stderr "<$chan> unknown command; discard \"$cmd\""}
+ return
+ }
+ }
+
+ # process eval hook now
+ set done 0
+ set err 0
+ if {[info exists comm($chan,hook,eval)]} {
+ set err [catch {CommRunHook $chan eval} ret]
+ commDebug {puts stderr "<$chan> eval hook res <$err,$ret>"}
+ switch $err {
+ 1 {
+ # error
+ set done 1
+ }
+ 2 - 3 {
+ # return / break
+ set err 0
+ set done 1
+ }
+ }
+ }
+
+ commDebug {puts stderr "<$chan> hook(eval) done=$done, err=$err"}
+
+ # exec command
+ if {!$done} {
+ commDebug {puts stderr "<$chan> exec ($buffer)"}
+
+ # Sadly, the uplevel needs to be in the catch to access the local
+ # variables buffer and ret. These cannot simply be global because
+ # commExec is reentrant (i.e., they could be linked to an allocated
+ # serial number).
+
+ if {$comm($chan,interp) == {}} {
+ # Main interpreter
+ set thecmd [concat [list uplevel \#0] $buffer]
+ set err [catch $thecmd ret]
+ } else {
+ # Redirect execution into the configured slave
+ # interpreter. The exact command used depends on the
+ # capabilities of the interpreter. A best effort is made
+ # to execute the script in the global namespace.
+ set interp $comm($chan,interp)
+
+ if {$comm($chan,interp,upl) == "ok"} {
+ set thecmd [concat [list uplevel \#0] $buffer]
+ set err [catch {interp eval $interp $thecmd} ret]
+ } elseif {$comm($chan,interp,aset) == "hidden"} {
+ set thecmd [linsert $buffer 0 interp invokehidden $interp uplevel \#0]
+ set err [catch $thecmd ret]
+ } else {
+ set thecmd [concat [list interp eval $interp] $buffer]
+ set err [catch $thecmd ret]
+ }
+ }
+ }
+
+ # Check and handle possible async result generation.
+ if {[AsyncCheck]} return
+
+ commSendReply $chan $fid $cmd $ser $err $ret
+ return
+}
+
+# ::comm::commSendReply --
+#
+# Internal command. Executed to construct and send the reply
+# for a command.
+#
+# Arguments:
+# fid channel handle of the socket we are replying to.
+# cmd The type of request (send, command) we are replying to.
+# ser Serial number of the request the reply is for.
+# err result code to place into the reply.
+# ret result value to place into the reply.
+#
+# Results:
+# None.
+
+proc ::comm::commSendReply {chan fid cmd ser err ret} {
+ variable comm
+
+ commDebug {puts stderr "<$chan> res <$err,$ret> /$cmd"}
+
+ # The double list assures that the command is a single list when read.
+ if {[string equal send $cmd] || [string equal command $cmd]} {
+ # The catch here is just in case we lose the target. Consider:
+ # comm send $other comm send [comm self] exit
+ catch {
+ set return [list return -code $err]
+ # send error or result
+ if {$err == 1} {
+ global errorInfo errorCode
+ lappend return -errorinfo $errorInfo -errorcode $errorCode
+ }
+ lappend return $ret
+ if {[string equal send $cmd]} {
+ set reply reply
+ } else {
+ set reply callback
+ }
+ puts $fid [list [list $reply $ser $return]]
+ flush $fid
+ }
+ commDebug {puts stderr "<$chan> reply sent"}
+ }
+
+ if {$err == 1} {
+ commBgerror $ret
+ }
+ commDebug {puts stderr "<$chan> exec complete"}
+ return
+}
+
+proc ::comm::CommRunHook {chan event} {
+ variable comm
+
+ # The documentation promises the hook scripts to have access to a
+ # number of internal variables. For a regular hook we simply
+ # execute it in the calling level to fulfill this. When the hook
+ # is redirected into an interpreter however we do a best-effort
+ # copying of the variable values into the interpreter. Best-effort
+ # because the 'set' command may not be available in the
+ # interpreter, not even hidden.
+
+ if {![info exists comm($chan,hook,$event)]} return
+ set cmd $comm($chan,hook,$event)
+ set interp $comm($chan,interp)
+ commDebug {puts stderr "<$chan> hook($event) run <$cmd>"}
+
+ if {
+ ($interp != {}) &&
+ ([lsearch -exact $comm($chan,events) $event] >= 0)
+ } {
+ # Best-effort to copy the context into the interpreter for
+ # access by the hook script.
+ set vars {
+ addr buffer chan cmd fid host
+ id port reason remport ret var
+ }
+
+ if {$comm($chan,interp,set) == "ok"} {
+ foreach v $vars {
+ upvar 1 $v V
+ if {![info exists V]} continue
+ interp eval $interp [list set $v $V]
+ }
+ } elseif {$comm($chan,interp,set) == "hidden"} {
+ foreach v $vars {
+ upvar 1 $v V
+ if {![info exists V]} continue
+ interp invokehidden $interp set $v $V
+ }
+ }
+ upvar 1 return AV
+ if {[info exists AV]} {
+ if {$comm($chan,interp,aset) == "ok"} {
+ interp eval $interp [list array set return [array get AV]]
+ } elseif {$comm($chan,interp,aset) == "hidden"} {
+ interp invokehidden $interp array set return [array get AV]
+ }
+ }
+
+ commDebug {puts stderr "<$chan> /interp $interp"}
+ set code [catch {interp eval $interp $cmd} res]
+ } else {
+ commDebug {puts stderr "<$chan> /main"}
+ set code [catch {uplevel 1 $cmd} res]
+ }
+
+ # Perform the return code propagation promised
+ # to the hook scripts.
+ switch -exact -- $code {
+ 0 {}
+ 1 {
+ return -errorinfo $::errorInfo -errorcode $::errorCode -code error $res
+ }
+ 3 {return}
+ 4 {}
+ default {return -code $code $res}
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Hooks to link async return and future processing into the regular
+## system.
+
+# AsyncPrepare, AsyncCheck: Initialize state information for async
+# return upon start of a remote invokation, and checking the state for
+# async return.
+
+proc ::comm::AsyncPrepare {chan fid cmd ser} {
+ variable comm
+ set comm(current,async) 0
+ set comm(current,state) [list $chan $fid $cmd $ser]
+ return
+}
+
+proc ::comm::AsyncCheck {} {
+ # Check if the executed command notified us of an async return. If
+ # not we let the regular return processing handle the end of the
+ # script. Otherwise we stop the caller from proceeding, preventing
+ # a regular return.
+
+ variable comm
+ if {!$comm(current,async)} {return 0}
+ return 1
+}
+
+# FutureDone: Action taken by an uncanceled future to deliver the
+# generated result to the proper invoker. This also removes the future
+# from the list of pending futures for the comm channel.
+
+proc comm::FutureDone {future chan fid cmd sid rcode rvalue} {
+ variable comm
+ commSendReply $chan $fid $cmd $sid $rcode $rvalue
+
+ set pos [lsearch -exact $comm(future,fid,$fid) $future]
+ set comm(future,fid,$fid) [lreplace $comm(future,fid,$fid) $pos $pos]
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Hooks to save command state across nested eventloops a remotely
+## invoked command may run before finally activating async result
+## generation.
+
+# DANGER !! We have to refer to comm internals using fully-qualified
+# names because the wrappers will execute in the global namespace
+# after their installation.
+
+proc ::comm::Vwait {varname} {
+ variable ::comm::comm
+
+ set hasstate [info exists comm(current,async)]
+ set hasremote 0
+ if {$hasstate} {
+ set chan [lindex $comm(current,state) 0]
+ set async $comm(current,async)
+ set state $comm(current,state)
+ set hasremote [info exists comm($chan,remoteid)]
+ if {$hasremote} {
+ set remoteid $comm($chan,remoteid)
+ }
+ }
+
+ set code [catch {uplevel 1 [list ::comm::VwaitOrig $varname]} res]
+
+ if {$hasstate} {
+ set comm(current,async) $async
+ set comm(current,state) $state
+ }
+ if {$hasremote} {
+ set comm($chan,remoteid) $remoteid
+ }
+
+ return -code $code $res
+}
+
+proc ::comm::Update {args} {
+ variable ::comm::comm
+
+ set hasstate [info exists comm(current,async)]
+ set hasremote 0
+ if {$hasstate} {
+ set chan [lindex $comm(current,state) 0]
+ set async $comm(current,async)
+ set state $comm(current,state)
+
+ set hasremote [info exists comm($chan,remoteid)]
+ if {$hasremote} {
+ set remoteid $comm($chan,remoteid)
+ }
+ }
+
+ set code [catch {uplevel 1 [linsert $args 0 ::comm::UpdateOrig]} res]
+
+ if {$hasstate} {
+ set comm(current,async) $async
+ set comm(current,state) $state
+ }
+ if {$hasremote} {
+ set comm($chan,remoteid) $remoteid
+ }
+
+ return -code $code $res
+}
+
+# Install the wrappers.
+
+proc ::comm::InitWrappers {} {
+ rename ::vwait ::comm::VwaitOrig
+ rename ::comm::Vwait ::vwait
+
+ rename ::update ::comm::UpdateOrig
+ rename ::comm::Update ::update
+
+ proc ::comm::InitWrappers {} {}
+ return
+}
+
+# ### ### ### ######### ######### #########
+## API: Future objects.
+
+snit::type comm::future {
+ option -command -default {}
+
+ constructor {chan fid cmd ser} {
+ set xfid $fid
+ set xcmd $cmd
+ set xser $ser
+ set xchan $chan
+ return
+ }
+
+ destructor {
+ if {!$canceled} {
+ return -code error \
+ "Illegal attempt to destroy unresolved future \"$self\""
+ }
+ }
+
+ method return {args} {
+ # Syntax: | 0
+ # : -code x | 2
+ # : -code x val | 3
+ # : val | 4
+ # Allowing multiple -code settings, last one is taken.
+
+ set rcode 0
+ set rvalue {}
+
+ while {[lindex $args 0] == "-code"} {
+ set rcode [lindex $args 1]
+ set args [lrange $args 2 end]
+ }
+ if {[llength $args] > 1} {
+ return -code error "wrong\#args, expected \"?-code errcode? ?result?\""
+ }
+ if {[llength $args] == 1} {
+ set rvalue [lindex $args 0]
+ }
+
+ if {!$canceled} {
+ comm::FutureDone $self $xchan $xfid $xcmd $xser $rcode $rvalue
+ set canceled 1
+ }
+ # assert: canceled == 1
+ $self destroy
+ return
+ }
+
+ variable xfid {}
+ variable xcmd {}
+ variable xser {}
+ variable xchan {}
+ variable canceled 0
+
+ # Internal method for use by comm channels. Marks the future as
+ # expired, no peer to return a result back to.
+
+ method Cancel {} {
+ set canceled 1
+ if {![llength $options(-command)]} {return}
+ uplevel #0 [linsert $options(-command) end $self]
+ return
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Setup
+::comm::InitWrappers
+
+###############################################################################
+#
+# Finish creating "comm" using the default port for this interp.
+#
+
+if {![info exists ::comm::comm(comm,port)]} {
+ if {[string equal macintosh $tcl_platform(platform)]} {
+ ::comm::comm new ::comm::comm -port 0 -local 0 -listen 1
+ set ::comm::comm(localhost) \
+ [lindex [fconfigure $::comm::comm(::comm::comm,socket) -sockname] 0]
+ ::comm::comm config -local 1
+ } else {
+ ::comm::comm new ::comm::comm -port 0 -local 1 -listen 1
+ }
+}
+
+#eof
+package provide comm 4.6.3.1
diff --git a/tcllib/modules/comm/comm.test b/tcllib/modules/comm/comm.test
new file mode 100644
index 0000000..2289446
--- /dev/null
+++ b/tcllib/modules/comm/comm.test
@@ -0,0 +1,318 @@
+# -*- tcl -*-
+# Tests for the comm module.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2001 by ActiveState Tool Corp.
+# All rights reserved.
+#
+# RCS: @(#) $Id: comm.test,v 1.14 2010/09/15 19:48:33 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.3 ; # snit
+testsNeedTcltest 1.0
+
+tcltest::testConstraint hastls [expr {![catch {package require tls}]}]
+
+support {
+ # Using snit1 here, whatever the version of Tcl
+ use snit/snit.tcl snit
+}
+testing {
+ useLocal comm.tcl comm
+}
+
+# ------------------------------------------------------------------------
+# First order of things is to spawn a separate tclsh into the background
+# and have it execute comm too, with some general code to respond to our
+# requests
+
+useLocalFile comm.slaveboot
+
+# ------------------------------------------------------------------------
+
+test comm-1.0 {set remote variable} {
+ ::comm::comm send [slave] {set foo b}
+} {b}
+
+test comm-1.1 {set remote variable, async} {
+ ::comm::comm send -async [slave] {set fox a}
+} {}
+
+test comm-1.2 {get remote variables} {
+ ::comm::comm send [slave] {list $foo $fox}
+} {b a}
+
+# ------------------------------------------------------------------------
+
+set hack [interp create]
+
+test comm-2.0 {-interp configuration} {
+ ::comm::comm configure -interp $hack
+} {}
+
+test comm-2.1 {-interp configuration} {
+ ::comm::comm configure -interp
+} $hack
+
+test comm-2.2 {-interp configuration} {
+ res!
+ res+ [::comm::comm configure -interp $hack] [::comm::comm configure -interp]
+ res+ [::comm::comm configure -interp {}] [::comm::comm configure -interp]
+ res?
+} [list [list {} $hack] {{} {}}]
+
+test comm-2.3 {-interp configuration} {
+ catch {::comm::comm configure -interp bad} msg
+ set msg
+} {Non-interpreter to configuration option: -interp}
+
+test comm-2.4 {-interp configuration, destruction} {
+ res!
+ res+ [interp exists $hack]
+ res+ [info commands FOO]
+ comm::comm new FOO -interp $hack
+ FOO destroy
+ res+ [interp exists $hack]
+ res+ [info commands FOO]
+ res?
+} {1 {{}} 0 {{}}}
+
+set hack [interp create]
+set beta [interp create]
+
+test comm-2.5 {-interp configuration, destruction} {
+ res!
+ res+ [interp exists $hack]
+ res+ [interp exists $beta]
+ res+ [info commands FOO]
+ comm::comm new FOO -interp $hack
+ FOO configure -interp $beta
+ FOO destroy
+ res+ [interp exists $hack]
+ res+ [interp exists $beta]
+ res+ [info commands FOO]
+ res?
+} {1 1 {{}} 1 0 {{}}}
+
+test comm-2.6 {-interp use for received scripts} {
+ set FOO [::comm::comm send [slave] {
+ set hack [interp create]
+ interp eval $hack {set fox 0}
+ comm::comm new FOO -interp $hack -listen 1
+ FOO self
+ }] ; # {}
+
+ comm::comm send $FOO {set fox 1}
+ set res [comm::comm send [slave] {
+ interp eval $hack {set fox}
+ }] ; # {}
+ comm::comm send [slave] {FOO destroy}
+ set res
+} 1
+
+test comm-2.7 {-interp use for received scripts} {
+ set FOO [::comm::comm send [slave] {
+ set hack [interp create]
+ interp eval $hack {set fox 0}
+ comm::comm new FOO -interp $hack -listen 1
+ FOO self
+ }] ; # {}
+
+ comm::comm send $FOO set fox 2
+ set res [comm::comm send [slave] {
+ interp eval $hack {set fox}
+ }] ; # {}
+ comm::comm send [slave] {FOO destroy}
+ set res
+} 2
+
+# ------------------------------------------------------------------------
+
+test comm-3.0 {-events configuration} {
+ ::comm::comm configure -events eval
+} {}
+
+test comm-3.1 {-events configuration} {
+ ::comm::comm configure -events
+} eval
+
+test comm-3.2 {-events configuration} {
+ res!
+ res+ [::comm::comm configure -events eval] [::comm::comm configure -events]
+ res+ [::comm::comm configure -events {}] [::comm::comm configure -events]
+ res?
+} {{{} eval} {{} {}}}
+
+test comm-3.3 {-events configuration} {
+ catch {::comm::comm configure -events bad} msg
+ set msg
+} {Non-event to configuration option: -events}
+
+
+test comm-3.4 {-interp use for -events scripts, eval} {
+ set FOO [::comm::comm send [slave] {
+ set hack [interp create]
+ interp eval $hack {set fox 0 ; set wolf 0}
+ comm::comm new FOO -interp $hack -listen 1 -events eval
+ FOO hook eval {set wolf 2}
+ FOO self
+ }] ; # {}
+
+ comm::comm send $FOO {set fox 1}
+ set res [comm::comm send [slave] {
+ interp eval $hack {set wolf}
+ }] ; # {}
+ comm::comm send [slave] {FOO destroy}
+ set res
+} 2
+
+# ------------------------------------------------------------------------
+
+test comm-4.0 {async generation of result on remote side} {
+ ::comm::comm send [slave] {
+ proc future {} {
+ set f [comm::comm return_async]
+ after 3000 [list $f return "delayed $f"]
+ return ignored
+ }
+ }
+ ::comm::comm send [slave] {future}
+} {delayed ::comm::future1}
+
+test comm-4.1 {async reception of a result via callback} {
+ set res {}
+ proc foo {args} {
+ array set tmp $args
+ unset tmp(-id)
+ unset tmp(-serial)
+ global res ; lappend res [dictsort [array get tmp]]
+ }
+ ::comm::comm send -command foo [slave] {list $foo $fox}
+ vwait res
+ rename foo {}
+ set res
+} {{-chan ::comm::comm -code 0 -errorcode {} -errorinfo {} -result {b a}}}
+
+test comm-4.2 {async generation/reception of results in parallel} {
+
+ # Setup long running operations with async result generation.
+ ::comm::comm send [slave] {
+ proc future {n x} {
+ set f [comm::comm return_async]
+ after $n [list $f return "delayed $x"]
+ return ignored
+ }
+ }
+
+ # Setup async receiver callback.
+ proc receive {args} {
+ global res tick tock
+ array set tmp $args
+ unset tmp(-id)
+ unset tmp(-serial)
+ unset tmp(-chan)
+ unset tmp(-code)
+ unset tmp(-errorcode)
+ unset tmp(-errorinfo)
+ lappend res [dictsort [array get tmp]]
+ incr tock -1
+ if {!$tock} {set tick .}
+ return
+ }
+
+ # Execute two requests, the second of which is returns before the first.
+ # The main point is that the server does process it due to first doing
+ # an async return.
+
+ set tick .
+ set tock 2
+ set res {}
+
+ ::comm::comm send -command receive [slave] {future 5000 A}
+ ::comm::comm send -command receive [slave] {future 2500 B}
+ vwait tick
+ rename receive {}
+ set res
+ # B returned before A, A was sent before B
+} {{-result {delayed B}} {-result {delayed A}}}
+
+
+test comm-4.3 {bug 2972571, handling of \\ by Word0} {
+ ::comm::comm send [slave] {
+ proc foo {args} {
+ return nothing
+ }
+ }
+ ::comm::comm send [slave] {foo \\}
+} {nothing}
+
+
+# ------------------------------------------------------------------------
+
+test comm-5.0 {-port already in use} {
+ # First start a server on port 12345
+ set port 12345
+ catch {set shdl [socket -server foo $port]}
+ catch {::comm::comm new bar -port $port -listen 1 -local 0} msg
+ catch {close $shdl}
+ unset -nocomplain shdl port
+ set msg
+} {couldn't open socket: address already in use}
+
+# ------------------------------------------------------------------------
+
+test comm-6.0 {secured communication via tls package} hastls {
+ # Setup secured channel in main process.
+ tls::init \
+ -keyfile [tcllibPath devtools/receiver.key] \
+ -certfile [tcllibPath devtools/receiver.crt] \
+ -cafile [tcllibPath devtools/ca.crt] \
+ -ssl2 1 \
+ -ssl3 1 \
+ -tls1 0 \
+ -require 1
+ comm::comm new BAR -socketcmd tls::socket -listen 1
+
+ # Setup secured channel in slave process
+ ::comm::comm send [slave] {
+ package require tls
+ set fox dog
+ }
+ ::comm::comm send [slave] \
+ [list \
+ tls::init \
+ -keyfile [tcllibPath devtools/transmitter.key] \
+ -certfile [tcllibPath devtools/transmitter.crt] \
+ -cafile [tcllibPath devtools/ca.crt] \
+ -ssl2 1 \
+ -ssl3 1 \
+ -tls1 0 \
+ -require 1]
+ set FOO [::comm::comm send [slave] {
+ comm::comm new FOO -socketcmd tls::socket -listen 1
+ FOO self
+ }] ; # {}
+
+ # Run command interaction over the secured channel
+ set res [BAR send $FOO {set fox}]
+
+ # Cleanup, remove secured endpoints
+ comm::comm send [slave] {FOO destroy}
+ BAR destroy
+
+ # Return result of the secured command
+ set res
+} dog
+
+# ------------------------------------------------------------------------
+
+slavestop
+testsuiteCleanup
+return
diff --git a/tcllib/modules/comm/comm_wire.man b/tcllib/modules/comm/comm_wire.man
new file mode 100644
index 0000000..e0419f1
--- /dev/null
+++ b/tcllib/modules/comm/comm_wire.man
@@ -0,0 +1,284 @@
+[manpage_begin comm_wire n 3]
+[see_also comm]
+[keywords comm]
+[keywords communication]
+[keywords ipc]
+[keywords message]
+[keywords {remote communication}]
+[keywords {remote execution}]
+[keywords rpc]
+[keywords socket]
+[copyright {2005 Docs. Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Remote communication}]
+[titledesc {The comm wire protocol}]
+[category {Programming tools}]
+[require comm]
+[description]
+
+[para]
+
+The [package comm] command provides an inter-interpreter remote
+execution facility much like Tk's [cmd send(n)], except that it uses
+sockets rather than the X server for the communication path. As a
+result, [package comm] works with multiple interpreters, works on
+Windows and Macintosh systems, and provides control over the remote
+execution path.
+
+[para]
+
+This document contains a specification of the various versions of the
+wire protocol used by comm internally for the communication between
+its endpoints. It has no relevance to users of [package comm], only to
+developers who wish to modify the package, write a compatible facility
+in a different language, or some other facility based on the same
+protocol.
+
+[comment {
+ An example of some other facility could be a router layer which is
+ able to get messages for many different endpoints and then routes
+ them to the correct one. Why is this interesting ? Because it
+ allows mesh-routing, i.e. an application fires a command to some
+ other endpoint without having to worry if there is direct
+ connection to this endpoint or not. A secure tunnel then neatly
+ fits into this. Its endpoints are routing agents which take
+ arbitrarily commands, route them through the tunnel and then
+ dispatch them to the correct endpoint on the other side.
+
+ Note: A special case would be to have such a router facility built
+ into the core comm package, making each endpoint a router as
+ well. Like with the ability to listen to for non-local connection
+ this is something the user should be able to disable.
+}]
+
+[comment {
+ Motivation for documenting the protocol
+ ---------------------------------------
+
+ While the comm package allows the transport and execution of arbitrary
+ Tcl scripts a particular application can use the hooks to restrict the
+ scripts to single commands, and the legal commands to a specific set
+ as well.
+
+ If this is done (*) comm becomes more of a transport layer for a
+ regular RPC, and the data transported over the wire is less of a Tcl
+ script and more of a declaration of which remote procedure is wanted,
+ plus arguments.
+
+ At this point it begins to make sense to have implementations in other
+ scripting languages. Because then it becomes irrelevant in what
+ language the server is implemented. The comm protocol becomes a
+ portable RPC protocol, which can also be used for transport Tcl
+ scripts when both sides are Tcl and allowing this.
+
+ (*) And IMHO it should be done 90% of the time, just to get proper
+ security. Note that just using a safe interp is not quite enough, as
+ it still allows arbitrary scripts. The interp has to contains aliases
+ for the wanted commands, and only them for us to get a large security
+ wall.
+}]
+
+[section {Wire Protocol Version 3}]
+[subsection {Basic Layer}]
+
+The basic encoding for [emph all] data is UTF-8. Because of this
+binary data, including the NULL character, can be sent over the wire
+as is, without the need for armoring it.
+
+[subsection {Basic Message Layer}]
+
+On top of the [sectref {Basic Layer}] we have a
+
+[term {message oriented}] exchange of data.
+
+The totality of all characters written to the channel is a Tcl list,
+with each element a separate [term message], each itself a list. The
+messages in the overall list are separated by EOL. Note that EOL
+characters can occur within the list as well. They can be
+distinguished from the message-separating EOL by the fact that the
+data from the beginning up to their location is not a valid Tcl list.
+
+[para]
+
+EOL is signaled through the linefeed character, i.e [const LF], or,
+hex [const 0x0a]. This is following the unix convention for
+line-endings.
+
+[para]
+
+As a list each message is composed of [term words]. Their meaning
+depends on when the message was sent in the overall exchange. This is
+described in the upcoming sections.
+
+[subsection {Negotiation Messages - Initial Handshake} ih]
+
+The command protocol is defined like this:
+
+[list_begin itemized]
+[item]
+
+The first message send by a client to a server, when opening the
+connection, contains two words. The first word is a list as well, and
+contains the versions of the wire protocol the client is willing to
+accept, with the most preferred version first. The second word is the
+TCP port the client is listening on for connections to itself. The
+value [const 0] is used here to signal that the client will not listen
+for connections, i.e. that it is purely for sending commands, and not
+receiving them.
+
+[item]
+
+The first message sent by the server to the client, in response to the
+message above contains only one word. This word is a list, containing
+the string [const vers] as its first element, and the version of the
+wire protocol the server has selected from the offered versions as the
+second.
+
+[comment {
+ NOTE / DANGER
+
+ The terminating EOL for this first response will be the socket
+ specific default EOL (Windows/Internet convention: "\r\n").
+ However all future messages use Unix convention, i.e. "\n",
+ for their EOLs, embedded or terminating.
+
+ Reason: The internal command commNewComm does the common
+ processing for new connections, doing the
+
+ fconfigure -translation lf
+
+ However the handshake response containing the accepted
+ version is sent before commNewComm is called (in
+ commIncoming).
+
+ NOTE 2:
+
+ This inconsistency has been fixed locally already, but
+ not been committed yet.
+}]
+[list_end]
+
+[subsection {Script/Command Messages}]
+
+All messages coming after the [sectref ih {initial handshake}]
+consist of three words. These are an instruction, a transaction id,
+and the payload. The valid instructions are shown below. The
+transaction ids are used by the client to match any incoming replies
+to the command messages it sent. This means that a server has to copy
+the transaction id from a command message to the reply it sends for
+that message.
+
+[list_begin definitions]
+
+[def [const send]]
+[def [const async]]
+[def [const command]]
+
+The payload is the Tcl script to execute on the server. It is actually
+a list containing the script fragments. These fragment are
+
+[cmd concat]enated together by the server to form the full script to
+execute on the server side.
+
+This emulates the Tcl "eval" semantics.
+
+In most cases it is best to have only one word in the list, a list
+containing the exact command.
+
+[para]
+Examples:
+[para]
+[example {
+ (a) {send 1 {{array get tcl_platform}}}
+ (b) {send 1 {array get tcl_platform}}
+ (c) {send 1 {array {get tcl_platform}}}
+
+ are all valid representations of the same command. They are
+ generated via
+
+ (a') send {array get tcl_platform}
+ (b') send array get tcl_platform
+ (c') send array {get tcl_platform}
+
+ respectively
+}]
+[para]
+
+Note that (a), generated by (a'), is the usual form, if only single
+commands are sent by the client.
+
+For example constructed using [cmd list], if the command contains
+variable arguments. Like
+
+[para]
+[example {
+ send [list array get $the_variable]
+}]
+[para]
+
+These three instructions all invoke the script on the server
+side. Their difference is in the treatment of result values, and thus
+determines if a reply is expected.
+
+[list_begin definitions]
+[def [const send]]
+
+A reply is expected. The sender is waiting for the result.
+
+[def [const async]]
+
+No reply is expected, the sender has no interest in the result and is
+not waiting for any.
+
+[def [const command]]
+
+A reply is expected, but the sender is not waiting for it. It has
+arranged to get a process-internal notification when the result
+arrives.
+
+[list_end]
+
+[def [const reply]]
+
+Like the previous three command, however the tcl script in the payload
+is highly restricted.
+
+It has to be a syntactically valid Tcl [cmd return] command. This
+contains result code, value, error code, and error info.
+
+[para]
+Examples:
+[para]
+[example {
+ {reply 1 {return -code 0 {}}}
+ {reply 1 {return -code 0 {osVersion 2.4.21-99-default byteOrder littleEndian machine i686 platform unix os Linux user andreask wordSize 4}}}
+}]
+
+[list_end]
+
+[comment {
+ Socket Miscellanea
+ ------------------
+
+ It is possible to have two sockets between a client and a
+ server. This happens if both sides connected to each other at
+ the same time.
+
+ Current protocol versions
+ -------------------------
+
+ V2
+
+ V3 This is preferred version and uses UTF 8 encoding.
+
+ This is actually the only version which will work IIU
+ the code right. Because the server part of comm will
+ send the version reply if and only if version 3 was
+ negotiated.
+
+ IOW if v2 is used the client will not see a version
+ reply during the negotiation handshake.
+}]
+
+[vset CATEGORY comm]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/comm/pkgIndex.tcl b/tcllib/modules/comm/pkgIndex.tcl
new file mode 100644
index 0000000..b0372e1
--- /dev/null
+++ b/tcllib/modules/comm/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.3]} {return}
+package ifneeded comm 4.6.3.1 [list source [file join $dir comm.tcl]]
diff --git a/tcllib/modules/common-text/tls-security-notes.inc b/tcllib/modules/common-text/tls-security-notes.inc
new file mode 100644
index 0000000..09c6448
--- /dev/null
+++ b/tcllib/modules/common-text/tls-security-notes.inc
@@ -0,0 +1,31 @@
+
+[section {TLS Security Considerations}]
+
+This package uses the [package TLS] package to handle the security
+for [const https] urls and other socket connections.
+
+[para] Policy decisions like the set of protocols to support and what
+ciphers to use are not the responsibility of [package TLS], nor of
+this package itself however.
+
+Such decisions are the responsibility of whichever application is
+using the package, and are likely influenced by the set of servers
+the application will talk to as well.
+
+[para] For example, in light of the recent
+[uri http://googleonlinesecurity.blogspot.co.uk/2014/10/this-poodle-bites-exploiting-ssl-30.html \
+{POODLE attack}] discovered by Google many servers will disable support
+for the SSLv3 protocol.
+
+To handle this change the applications using [package TLS] must be
+patched, and not this package, nor [package TLS] itself.
+
+Such a patch may be as simple as generally activating [const tls1]
+support, as shown in the example below.
+
+[example {
+ package require tls
+ tls::init -tls1 1 ;# forcibly activate support for the TLS1 protocol
+
+ ... your own application code ...
+}]
diff --git a/tcllib/modules/control/ChangeLog b/tcllib/modules/control/ChangeLog
new file mode 100644
index 0000000..61702bc
--- /dev/null
+++ b/tcllib/modules/control/ChangeLog
@@ -0,0 +1,252 @@
+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-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 ========================
+ *
+
+2009-11-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * do.test: Fixed result difference between 8.5/8.6.
+
+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>
+
+ * control.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-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * do.test: More boilerplate simplified via use of test support.
+ * no-op.test:
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * no-op.test: Hooked into the new common test support code.
+ * do.test:
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-09-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * do.test (test do-2.3): Made the expected error stack conditional
+ on the version of Tcl executing the testsuite. Tcl 8.5 is now
+ generating a stack different from 8.4 or below.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-05-01 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * do.test: Skip test 1.14 if tcl < 8.3.
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * control.man:
+ * control.tcl:
+ * pkgIndex.tcl: Set version of the package to to 0.1.2.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * control.man: More semantic markup, less visual one.
+
+2002-03-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * control.man: Fixed formatting errors in the doctools manpage.
+
+2002-02-21 Don Porter <dgp@users.sourceforge.net>
+
+ * control.tcl:
+ * pkgIndex.tcl: Bumped to 0.1.1.
+ * rswitch.tcl:
+ * rswitch.test: removed files from HEAD branch that aren't yet
+ ready for release.
+ * tclIndex: ran genIndex
+
+2002-02-21 Reinhard Max <max@suse.de>
+
+ * do.test: Updated do-2.3 to reflect the change of the standard
+ "wrong # args:..." message for Tcl 8.4. (Bug #517595)
+
+2002-02-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * assert.tcl:
+ * do.tcl: Frink run
+
+2002-01-29 Reinhard Max <max@suse.de>
+
+ * do.test: Changed the performance comparison part at the end to
+ be skipped during "make test".
+
+ * RELEASE 0.1: bundled with tcllib 1.2
+
+2002-01-18 Don Porter <dgp@users.sourceforge.net>
+
+ * Bumped back to 0.1, which has never been released yet.
+
+2002-01-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bumped version to 0.2
+
+2002-01-18 Reinhard Max <max@suse.de>
+
+ * do.tcl:
+ * do.test:
+ * control.n: Extended [control::do] to allow ommitting the 2nd and
+ 3rd argument. Added tests and changed the manpage to reflect this.
+
+2001-11-30 Don Porter <dgp@users.sourceforge.net>
+
+ * control.n: Changed format to match precedent in Tcl's memory.n.
+
+2001-11-27 Don Porter <dgp@users.sourceforge.net>
+
+ * control.n: Added [control::do] to SYNOPSIS.
+
+2001-11-09 Don Porter <dgp@users.sourceforge.net>
+
+ * control.n: Some revisions to [control::do] documentation,
+ and added LIMITATIONS section where the [return -code] limitation
+ is explained. Corrections to *roff markup.
+
+2001-11-08 Don Porter <dgp@users.sourceforge.net>
+
+ * ascaller.tcl (ErrorInfoAsCaller): new utility proc that provides
+ only ::errorInfo management, leaving return code matters to the caller.
+ * do.tcl: At the prompting of Reinhard Max, replaced use of the
+ [BodyAsCaller] and [CommandAsCaller] routines with the simpler
+ [ErrorInfoAsCaller] with big performance improvement.
+ * do.test: New tests from Reinhard Max for testing ::errorInfo.
+ * tclIndex: generated
+
+2001-11-07 Don Porter <dgp@users.sourceforge.net>
+
+ * do.tcl: updated to use [BodyAsCaller] and [CommandAsCaller]
+ so that proper ::errorInfo management is achieved.
+
+ * rswitch.tcl:
+ * ascaller.tcl (new-file): factored out utility procs from
+ rswitch.tcl so they can be used by other conotrol commands.
+ * tclIndex: generated
+
+ * rswitch.test: corrected syntax error [Bug 478989]
+
+2001-11-07 Reinhard Max <max@suse.de>
+
+ * do.tcl:
+ * do.test: New files: define and test [control::do].
+ * control.tcl:
+ * control.n: Added support and documentation for [control::do].
+ * tclIndex: Generated.
+
+2001-11-03 Don Porter <dgp@users.sourceforge.net>
+
+ * rswitch.tcl: Replaced bogus copyright notice with public
+ domain boilerplate.
+ * rswitch.test: Added tests and test source material.
+
+ * pkgIndex.tcl:
+ * control.tcl: Addition of rswitch means bump 0.0 -> 0.1.
+
+ * genIndex (new file):
+ * index.tcl (deleted file): renamed index.tcl -> genIndex so
+ it won't be mistakenly installed anymore. Purpose of genIndex
+ is to regenerate the tclIndex file. [Bug 475846]
+ * tclIndex: Generated.
+
+2001-11-03 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * rswitch.tcl: checked in Don's usenet posted implementation
+ * rswitch.test: some tests for the rswitch.tcl command.
+
+RELEASE 0: bundled with tcllib 1.1
+
+2001-08-21 Don Porter <dgp@users.sourceforge.net>
+
+ * control.tcl:
+ * control.n: Added and documented new commands [control::control]
+ and [control::assert].
+ * pkgIndex.tcl: Updated to reflect Tcl 8.2 dependence.
+ * tclIndex: Generated
+
+ * assert.tcl: New file: implements [control::assert].
+
+2001-08-21 Don Porter <dgp@users.sourceforge.net>
+
+ * index.tcl: New file: Utility script for generating tclIndex.
+ * tclIndex: Generated.
+
+ * no-op.tcl:
+ * no-op.test: New files: Define and test [control::no-op].
+
+ * control.tcl:
+ * control.n:
+ * pkgIndex.tcl:
+ * ChangeLog: New files: Main provide script, documentation, and
+ hand-crafted index script of new control package.
+
diff --git a/tcllib/modules/control/ascaller.tcl b/tcllib/modules/control/ascaller.tcl
new file mode 100644
index 0000000..6c864bb
--- /dev/null
+++ b/tcllib/modules/control/ascaller.tcl
@@ -0,0 +1,72 @@
+# ascaller.tcl -
+#
+# A few utility procs that manage the evaluation of a command
+# or a script in the context of a caller, taking care of all
+# the ugly details of proper return codes, errorcodes, and
+# a good stack trace in ::errorInfo as appropriate.
+# -------------------------------------------------------------------------
+#
+# RCS: @(#) $Id: ascaller.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $
+
+namespace eval ::control {
+
+ proc CommandAsCaller {cmdVar resultVar {where {}} {codeVar code}} {
+ set x [expr {[string equal "" $where]
+ ? {} : [subst -nobackslashes {\n ($where)}]}]
+ set script [subst -nobackslashes -nocommands {
+ set $codeVar [catch {uplevel 1 $$cmdVar} $resultVar]
+ if {$$codeVar > 1} {
+ return -code $$codeVar $$resultVar
+ }
+ if {$$codeVar == 1} {
+ if {[string equal {"uplevel 1 $$cmdVar"} \
+ [lindex [split [set ::errorInfo] \n] end]]} {
+ set $codeVar [join \
+ [lrange [split [set ::errorInfo] \n] 0 \
+ end-[expr {4+[llength [split $$cmdVar \n]]}]] \n]
+ } else {
+ set $codeVar [join \
+ [lrange [split [set ::errorInfo] \n] 0 end-1] \n]
+ }
+ return -code error -errorcode [set ::errorCode] \
+ -errorinfo "$$codeVar$x" $$resultVar
+ }
+ }]
+ return $script
+ }
+
+ proc BodyAsCaller {bodyVar resultVar codeVar {where {}}} {
+ set x [expr {[string equal "" $where]
+ ? {} : [subst -nobackslashes -nocommands \
+ {\n ($where[string map {{ ("uplevel"} {}} \
+ [lindex [split [set ::errorInfo] \n] end]]}]}]
+ set script [subst -nobackslashes -nocommands {
+ set $codeVar [catch {uplevel 1 $$bodyVar} $resultVar]
+ if {$$codeVar == 1} {
+ if {[string equal {"uplevel 1 $$bodyVar"} \
+ [lindex [split [set ::errorInfo] \n] end]]} {
+ set ::errorInfo [join \
+ [lrange [split [set ::errorInfo] \n] 0 end-2] \n]
+ }
+ set $codeVar [join \
+ [lrange [split [set ::errorInfo] \n] 0 end-1] \n]
+ return -code error -errorcode [set ::errorCode] \
+ -errorinfo "$$codeVar$x" $$resultVar
+ }
+ }]
+ return $script
+ }
+
+ proc ErrorInfoAsCaller {find replace} {
+ set info $::errorInfo
+ set i [string last "\n (\"$find" $info]
+ if {$i == -1} {return $info}
+ set result [string range $info 0 [incr i 6]] ;# keep "\n (\""
+ append result $replace ;# $find -> $replace
+ incr i [string length $find]
+ set j [string first ) $info [incr i]] ;# keep rest of parenthetical
+ append result [string range $info $i $j]
+ return $result
+ }
+
+}
diff --git a/tcllib/modules/control/assert.tcl b/tcllib/modules/control/assert.tcl
new file mode 100644
index 0000000..8aac408
--- /dev/null
+++ b/tcllib/modules/control/assert.tcl
@@ -0,0 +1,91 @@
+# assert.tcl --
+#
+# The [assert] command of the package "control".
+#
+# RCS: @(#) $Id: assert.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $
+
+namespace eval ::control {
+
+ namespace eval assert {
+ namespace export EnabledAssert DisabledAssert
+ variable CallbackCmd [list return -code error]
+
+ namespace import [namespace parent]::no-op
+ rename no-op DisabledAssert
+
+ proc EnabledAssert {expr args} {
+ variable CallbackCmd
+
+ set code [catch {uplevel 1 [list expr $expr]} res]
+ if {$code} {
+ return -code $code $res
+ }
+ if {![string is boolean -strict $res]} {
+ return -code error "invalid boolean expression: $expr"
+ }
+ if {$res} {return}
+ if {[llength $args]} {
+ set msg [join $args]
+ } else {
+ set msg "assertion failed: $expr"
+ }
+ # Might want to catch this
+ namespace eval :: $CallbackCmd [list $msg]
+ }
+
+ proc enabled {args} {
+ set n [llength $args]
+ if {$n > 1} {
+ return -code error "wrong # args: should be\
+ \"[lindex [info level 0] 0] ?boolean?\""
+ }
+ if {$n} {
+ set val [lindex $args 0]
+ if {![string is boolean -strict $val]} {
+ return -code error "invalid boolean value: $val"
+ }
+ if {$val} {
+ [namespace parent]::AssertSwitch Disabled Enabled
+ } else {
+ [namespace parent]::AssertSwitch Enabled Disabled
+ }
+ } else {
+ return [string equal [namespace origin EnabledAssert] \
+ [namespace origin [namespace parent]::assert]]
+ }
+ return ""
+ }
+
+ proc callback {args} {
+ set n [llength $args]
+ if {$n > 1} {
+ return -code error "wrong # args: should be\
+ \"[lindex [info level 0] 0] ?command?\""
+ }
+ if {$n} {
+ return [variable CallbackCmd [lindex $args 0]]
+ }
+ variable CallbackCmd
+ return $CallbackCmd
+ }
+
+ }
+
+ proc AssertSwitch {old new} {
+ if {[string equal [namespace origin assert] \
+ [namespace origin assert::${new}Assert]]} {return}
+ rename assert ${old}Assert
+ rename ${new}Assert assert
+ }
+
+ namespace import assert::DisabledAssert assert::EnabledAssert
+
+ # For indexer
+ proc assert args #
+ rename assert {}
+
+ # Initial default: disabled asserts
+ rename DisabledAssert assert
+
+}
+
diff --git a/tcllib/modules/control/control.man b/tcllib/modules/control/control.man
new file mode 100644
index 0000000..102b2ff
--- /dev/null
+++ b/tcllib/modules/control/control.man
@@ -0,0 +1,165 @@
+[manpage_begin control n 0.1.3]
+[see_also break]
+[see_also continue]
+[see_also expr]
+[see_also if]
+[see_also join]
+[see_also namespace]
+[see_also return]
+[see_also string]
+[see_also while]
+[keywords assert]
+[keywords control]
+[keywords do]
+[keywords flow]
+[keywords no-op]
+[keywords structure]
+[moddesc {Tcl Control Flow Commands}]
+[titledesc {Procedures for control flow structures.}]
+[category {Programming tools}]
+[require Tcl 8.2]
+[require control [opt 0.1.3]]
+[description]
+[para]
+
+The [cmd control] package provides a variety of commands that provide
+additional flow of control structures beyond the built-in ones
+provided by Tcl. These are commands that in many programming
+languages might be considered [emph keywords], or a part of the
+language itself. In Tcl, control flow structures are just commands
+like everything else.
+
+[section COMMANDS]
+[list_begin definitions]
+
+[call [cmd control::control] [arg command] [arg option] [opt [arg "arg arg ..."]]]
+
+The [cmd control] command is used as a configuration command for
+customizing the other public commands of the control package. The
+[arg command] argument names the command to be customized. The set of
+valid [arg option] and subsequent arguments are determined by the
+command being customized, and are documented with the command.
+
+[call [cmd control::assert] [arg expr] [opt [arg "arg arg ..."]]]
+
+When disabled, the [cmd assert] command behaves exactly like the
+[cmd no-op] command.
+
+[para]
+
+When enabled, the [cmd assert] command evaluates [arg expr] as an
+expression (in the same way that [cmd expr] evaluates its argument).
+If evaluation reveals that [arg expr] is not a valid boolean
+expression (according to [lb][cmd "string is boolean -strict"][rb]),
+an error is raised. If [arg expr] evaluates to a true boolean value
+(as recognized by [cmd if]), then [cmd assert] returns an empty
+string. Otherwise, the remaining arguments to [cmd assert] are used
+to construct a message string. If there are no arguments, the message
+string is "assertion failed: $expr". If there are arguments, they are
+joined by [cmd join] to form the message string. The message string
+is then appended as an argument to a callback command, and the
+completed callback command is evaluated in the global namespace.
+
+[para]
+
+The [cmd assert] command can be customized by the [cmd control]
+command in two ways:
+
+[para]
+
+[lb][cmd "control::control assert enabled"] [opt [arg boolean]][rb]
+queries or sets whether [cmd control::assert] is enabled. When called
+without a [arg boolean] argument, a boolean value is returned
+indicating whether the [cmd control::assert] command is enabled. When
+called with a valid boolean value as the [arg boolean] argument, the
+[cmd control::assert] command is enabled or disabled to match the
+argument, and an empty string is returned.
+
+[para]
+
+[lb][cmd "control::control assert callback"] [opt [arg command]][rb]
+queries or sets the callback command that will be called by an enabled
+[cmd assert] on assertion failure. When called without a
+[arg command] argument, the current callback command is returned.
+When called with a [arg command] argument, that argument becomes the
+new assertion failure callback command. Note that an assertion
+failure callback command is always defined, even when [cmd assert]
+is disabled. The default callback command is
+
+[lb][cmd "return -code error"][rb].
+
+[para]
+
+Note that [cmd control::assert] has been written so that in
+combination with [lb][cmd "namespace import"][rb], it is possible to
+use enabled [cmd assert] commands in some namespaces and disabled
+
+[cmd assert] commands in other namespaces at the same time. This
+capability is useful so that debugging efforts can be independently
+controlled module by module.
+
+[para]
+
+[example {
+% package require control
+% control::control assert enabled 1
+% namespace eval one namespace import ::control::assert
+% control::control assert enabled 0
+% namespace eval two namespace import ::control::assert
+% one::assert {1 == 0}
+assertion failed: 1 == 0
+% two::assert {1 == 0}
+}]
+
+[call [cmd control::do] [arg body] [opt [arg "option test"]]]
+
+The [cmd do] command evaluates the script [arg body] repeatedly
+[emph until] the expression [arg test] becomes true or as long as
+([emph while]) [arg test] is true, depending on the value of
+
+[arg option] being [const until] or [const while]. If
+
+[arg option] and [arg test] are omitted the body is evaluated exactly
+once. After normal completion, [cmd do] returns an empty string.
+Exceptional return codes ([cmd break], [cmd continue], [cmd error],
+etc.) during the evaluation of [arg body] are handled in the same way
+the [cmd while] command handles them, except as noted in
+
+[sectref LIMITATIONS], below.
+
+[call [cmd control::no-op] [opt [arg "arg arg ..."]]]
+
+The [cmd no-op] command takes any number of arguments and does
+nothing. It returns an empty string.
+
+[list_end]
+
+[section LIMITATIONS]
+
+Several of the commands provided by the [cmd control] package accept
+arguments that are scripts to be evaluated. Due to fundamental
+limitations of Tcl's [cmd catch] and [cmd return] commands, it is not
+possible for these commands to properly evaluate the command
+
+[lb][cmd "return -code \$code"][rb] within one of those script
+arguments for any value of [arg \$code] other than [arg ok]. In this
+way, the commands of the [cmd control] package are limited as compared
+to Tcl's built-in control flow commands (such as [cmd if],
+
+[cmd while], etc.) and those control flow commands that can be
+provided by packages coded in C. An example of this difference:
+
+[para]
+[example {
+% package require control
+% proc a {} {while 1 {return -code error a}}
+% proc b {} {control::do {return -code error b} while 1}
+% catch a
+1
+% catch b
+0
+}]
+
+[vset CATEGORY control]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/control/control.tcl b/tcllib/modules/control/control.tcl
new file mode 100644
index 0000000..6cdf08a
--- /dev/null
+++ b/tcllib/modules/control/control.tcl
@@ -0,0 +1,24 @@
+# control.tcl --
+#
+# This is the main package provide script for the package
+# "control". It provides commands that govern the flow of
+# control of a program.
+
+package require Tcl 8.2
+
+namespace eval ::control {
+ namespace export assert control do no-op rswitch
+
+ proc control {command args} {
+ # Need to add error handling here
+ namespace eval [list $command] $args
+ }
+
+ # Set up for auto-loading the commands
+ variable home [file join [pwd] [file dirname [info script]]]
+ if {[lsearch -exact $::auto_path $home] == -1} {
+ lappend ::auto_path $home
+ }
+
+ package provide [namespace tail [namespace current]] 0.1.3
+}
diff --git a/tcllib/modules/control/do.tcl b/tcllib/modules/control/do.tcl
new file mode 100644
index 0000000..aa5c1af
--- /dev/null
+++ b/tcllib/modules/control/do.tcl
@@ -0,0 +1,81 @@
+# do.tcl --
+#
+# Tcl implementation of a "do ... while|until" loop.
+#
+# Originally written for the "Texas Tcl Shootout" programming contest
+# at the 2000 Tcl Conference in Austin/Texas.
+#
+# Copyright (c) 2001 by Reinhard Max <Reinhard.Max@gmx.de>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: do.tcl,v 1.6 2004/01/15 06:36:12 andreas_kupries Exp $
+#
+namespace eval ::control {
+
+ proc do {body args} {
+
+ #
+ # Implements a "do body while|until test" loop
+ #
+ # It is almost as fast as builtin "while" command for loops with
+ # more than just a few iterations.
+ #
+
+ set len [llength $args]
+ if {$len !=2 && $len != 0} {
+ set proc [namespace current]::[lindex [info level 0] 0]
+ return -code error "wrong # args: should be \"$proc body\" or \"$proc body \[until|while\] test\""
+ }
+ set test 0
+ foreach {whileOrUntil test} $args {
+ switch -exact -- $whileOrUntil {
+ "while" {}
+ "until" { set test !($test) }
+ default {
+ return -code error \
+ "bad option \"$whileOrUntil\": must be until, or while"
+ }
+ }
+ break
+ }
+
+ # the first invocation of the body
+ set code [catch { uplevel 1 $body } result]
+
+ # decide what to do upon the return code:
+ #
+ # 0 - the body executed successfully
+ # 1 - the body raised an error
+ # 2 - the body invoked [return]
+ # 3 - the body invoked [break]
+ # 4 - the body invoked [continue]
+ # everything else - return and pass on the results
+ #
+ switch -exact -- $code {
+ 0 {}
+ 1 {
+ return -errorinfo [ErrorInfoAsCaller uplevel do] \
+ -errorcode $::errorCode -code error $result
+ }
+ 3 {
+ # FRINK: nocheck
+ return
+ }
+ 4 {}
+ default {
+ return -code $code $result
+ }
+ }
+ # the rest of the loop
+ set code [catch {uplevel 1 [list while $test $body]} result]
+ if {$code == 1} {
+ return -errorinfo [ErrorInfoAsCaller while do] \
+ -errorcode $::errorCode -code error $result
+ }
+ return -code $code $result
+
+ }
+
+}
diff --git a/tcllib/modules/control/do.test b/tcllib/modules/control/do.test
new file mode 100644
index 0000000..d29a910
--- /dev/null
+++ b/tcllib/modules/control/do.test
@@ -0,0 +1,317 @@
+# do.test --
+#
+# Tests for [control::do]
+#
+# RCS: @(#) $Id: do.test,v 1.14 2009/11/24 04:52:49 andreas_kupries Exp $
+#
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal control.tcl control
+}
+
+# -------------------------------------------------------------------------
+
+namespace import ::control::do
+
+# ----------------------------------------
+test {do-1.0} {do ... while} {
+ set x 0
+ do {incr x} while {$x < 10}
+ set x
+} 10
+
+# ----------------------------------------
+test {do-1.1} {do ... until} {
+ set x 0
+ do {incr x} until {$x > 10}
+ set x
+} 11
+
+# ----------------------------------------
+test {do-1.2} {break} {
+ set x 0
+ do {
+ incr x
+ if {$x == 5} {break}
+ } until {$x == 10}
+ set x
+} 5
+
+# ----------------------------------------
+test {do-1.3} {continue} {
+
+ set x 0
+ set xx [list]
+ do {
+ incr x
+ if {$x == 5} {continue}
+ lappend xx $x
+ } until {$x == 10}
+ set xx
+} {1 2 3 4 6 7 8 9 10}
+
+# ----------------------------------------
+test {do-1.4} {error} {
+ catch {
+ set x 0
+ do {
+ incr x
+ if {$x == 5} {foo}
+ } while {$x < 10}
+ } result
+ list $x $result
+} {5 {invalid command name "foo"}}
+
+# ----------------------------------------
+test {do-1.5} {return} {
+ proc foo {} {
+ set x 0
+ do {
+ incr x
+ if {$x == 5} { return $x }
+ } while {$x < 10}
+ }
+ set result [foo]
+ rename foo ""
+ set result
+} 5
+
+# ----------------------------------------
+test {do-1.6} {break in the first loop} {
+ set x 0
+ do {
+ break
+ incr x
+ } while {$x < 10}
+ set x
+} 0
+
+# ----------------------------------------
+test {do-1.7} {continue in the first loop} {
+ set x 0
+ set xx [list]
+ do {
+ incr x
+ if {$x == 1} {continue}
+ lappend xx $x
+ } until {$x == 10}
+ set xx
+} {2 3 4 5 6 7 8 9 10}
+
+# ----------------------------------------
+test {do-1.8} {error in the first loop} {
+ set x 0
+ catch {
+ do {
+ foo
+ incr x
+ } until {$x == 10}
+ } result
+ list $x $result
+} {0 {invalid command name "foo"}}
+
+# ----------------------------------------
+test {do-1.9} {[do ... while] with false condition} {
+ set x 0
+ do {
+ incr x
+ } while 0
+ set x
+} 1
+
+# ----------------------------------------
+test do-1.10 {[do ... until] with true condition} {
+ set x 0
+ do {
+ incr x
+ } until 1
+ set x
+} 1
+
+# ----------------------------------------
+test do-1.11 {third arg is neither while nor until} {
+ set x 0
+ catch {
+ do {
+ incr x
+ } foo 1
+ set x
+ } result
+ list $x $result
+} {0 {bad option "foo": must be until, or while}}
+
+# ----------------------------------------
+test do-1.12 {stack traces for errors in the first iteration} {
+ proc a {} b
+ proc b {} {do c while 1}
+ proc c {} d
+ catch a
+ set ::errorInfo
+} {invalid command name "d"
+ while executing
+"d"
+ (procedure "c" line 1)
+ invoked from within
+"c"
+ ("do" body line 1)
+ invoked from within
+"do c while 1"
+ (procedure "b" line 1)
+ invoked from within
+"b"
+ (procedure "a" line 1)
+ invoked from within
+"a"}
+
+# ----------------------------------------
+test do-1.14 {stack traces for errors in subsequent iterations} tcl8.3plus {
+ proc a {} b
+ proc b {} {
+ set i 10
+ do {
+ incr i -1
+ c $i
+ } while {$i}
+ }
+ proc c {i} {if {$i==5} e}
+ catch a
+ set ::errorInfo
+} {invalid command name "e"
+ while executing
+"e"
+ (procedure "c" line 1)
+ invoked from within
+"c $i"
+ ("do" body line 3)
+ invoked from within
+"do {
+ incr i -1
+ c $i
+ } while {$i}"
+ (procedure "b" line 3)
+ invoked from within
+"b"
+ (procedure "a" line 1)
+ invoked from within
+"a"}
+
+# ----------------------------------------
+test do-2.0 {one-shot do} {
+ set x 0
+ do {incr x}
+ set x
+} 1
+
+# ----------------------------------------
+test do-2.1 {one-shot do with break} {
+ set x 0
+ do {incr x; break; incr x}
+ set x
+} 1
+
+# ----------------------------------------
+test do-2.2 {wrong no of arguments} {
+ set x 0
+ set res [catch {do {incr x} foo} ret]
+ list $x $res $errorInfo
+} {0 1 {wrong # args: should be "::control::do body" or "::control::do body [until|while] test"
+ while executing
+"do {incr x} foo"}}
+
+# ----------------------------------------
+
+if {[package vsatisfies [package provide Tcl] 8.6]} {
+ # 8.6+
+ set do23res {1 {wrong # args: should be "do body ?arg ...?"
+ while executing
+"do"}}
+} elseif {[package vsatisfies [package provide Tcl] 8.5]} {
+ # 8.5+
+ set do23res {1 {wrong # args: should be "do body ..."
+ while executing
+"do"}}
+} else {
+ # 8.4-
+ set do23res {1 {wrong # args: should be "do body args"
+ while executing
+"do"}}
+}
+
+test do-2.3 {wrong no of arguments} {} {
+ set res [catch do]
+ if {[string match \
+ {no value given for parameter "body" to "do"*} \
+ $::errorInfo]
+ } then {
+ set ::errorInfo {wrong # args: should be "do body args"
+ while executing
+"do"}
+ }
+ list $res $::errorInfo
+} $do23res
+
+# ----------------------------------------
+test do-2.4 {one-shot do with error} {
+ set x 0
+ set res [catch {do {
+ incr x
+ foo
+ incr x
+ }}]
+ list $x $res $::errorInfo
+} {1 1 {invalid command name "foo"
+ while executing
+"foo"
+ ("do" body line 3)
+ invoked from within
+"do {
+ incr x
+ foo
+ incr x
+ }"}}
+
+testsuiteCleanup
+
+if {[info exists ::argv0] && $::argv0 == [info script]} {
+ # a proc that wastes some time
+ proc something {n} {
+ for {set i 0} {$i < $n} {incr i} {}
+ }
+
+ proc main {} {
+ # run it for the first time to get it byte compiled
+ something 1
+
+ set payload {
+ something 10
+ incr x
+ }
+ puts "\nComparing performance of do-while, do-until and builtin while..."
+ set format "%-8s : %20s for %4d iteration(s)."
+ foreach c {1 10 5000} {
+ puts ""
+ foreach {descr script} {
+ {do while} {do $payload while {$x < $c}}
+ {do until} {do $payload until {$x == $c}}
+ {while} {while {$x < $c} $payload}
+ } {
+ set x 0
+ puts [format $format $descr [lrange [time $script 1] 0 1] $x]
+ }
+ }
+ }
+ main
+}
+
+# Local variables:
+# mode: tcl
+# End:
diff --git a/tcllib/modules/control/genIndex b/tcllib/modules/control/genIndex
new file mode 100644
index 0000000..1d3c47b
--- /dev/null
+++ b/tcllib/modules/control/genIndex
@@ -0,0 +1,15 @@
+# Utility program to generate tclIndex file
+
+package require Tcl 8.3
+set home [file join [pwd] [file dirname [info script]]]
+cd $home
+set files [glob -nocomplain *.tcl]
+set idx [lsearch $files control.tcl]
+set files [lreplace $files $idx $idx]
+set idx [lsearch $files index.tcl]
+set files [lreplace $files $idx $idx]
+set idx [lsearch $files pkgIndex.tcl]
+set files [lreplace $files $idx $idx]
+eval [list auto_mkindex .] $files
+#pkg_mkIndex -direct . control.tcl
+
diff --git a/tcllib/modules/control/no-op.tcl b/tcllib/modules/control/no-op.tcl
new file mode 100644
index 0000000..2400303
--- /dev/null
+++ b/tcllib/modules/control/no-op.tcl
@@ -0,0 +1,14 @@
+# no-op.tcl --
+#
+# The [no-op] command of the package "control".
+# It accepts any number of arguments and does nothing.
+# It returns an empty string.
+#
+# RCS: @(#) $Id: no-op.tcl,v 1.2 2004/01/15 06:36:12 andreas_kupries Exp $
+
+namespace eval ::control {
+
+ proc no-op args {}
+
+}
+
diff --git a/tcllib/modules/control/no-op.test b/tcllib/modules/control/no-op.test
new file mode 100644
index 0000000..f5f6248
--- /dev/null
+++ b/tcllib/modules/control/no-op.test
@@ -0,0 +1,44 @@
+# -*- tcl -*-
+# Tests for [control::no-op].
+#
+# This file contains a collection of tests for the command [control::no-op]
+# of the package control in tcllib, the Standard Tcl Library. Sourcing this
+# file into Tcl runs the tests and generates output for errors. No output
+# means no errors were found.
+#
+# RCS: @(#) $Id: no-op.test,v 1.5 2006/10/09 21:41:40 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal control.tcl control
+}
+
+# -------------------------------------------------------------------------
+
+namespace import ::control::no-op
+
+# -------------------------------------------------------------------------
+
+test no-op-0.0 {no-op return value} {
+ no-op
+} {}
+
+test no-op-1.0 {no-op argument substitution} {
+ set bcount 0
+ set b x
+ trace variable b r {incr bcount ;#}
+ set acount 0
+ proc a args {incr ::acount}
+ list [no-op a $b {a} {a $b} [a] [a $b] {[a]}] $acount $bcount
+} {{} 2 2}
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/control/pkgIndex.tcl b/tcllib/modules/control/pkgIndex.tcl
new file mode 100644
index 0000000..3b432db
--- /dev/null
+++ b/tcllib/modules/control/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded control 0.1.3 [list source [file join $dir control.tcl]]
diff --git a/tcllib/modules/control/tclIndex b/tcllib/modules/control/tclIndex
new file mode 100644
index 0000000..614d932
--- /dev/null
+++ b/tcllib/modules/control/tclIndex
@@ -0,0 +1,18 @@
+# Tcl autoload index file, version 2.0
+# This file is generated by the "auto_mkindex" command
+# and sourced to set up indexing information for one or
+# more commands. Typically each line is a command that
+# sets an element in the auto_index array, where the
+# element name is the name of a command and the value is
+# a script that loads the command.
+
+set auto_index(::control::CommandAsCaller) [list source [file join $dir ascaller.tcl]]
+set auto_index(::control::BodyAsCaller) [list source [file join $dir ascaller.tcl]]
+set auto_index(::control::ErrorInfoAsCaller) [list source [file join $dir ascaller.tcl]]
+set auto_index(::control::assert::EnabledAssert) [list source [file join $dir assert.tcl]]
+set auto_index(::control::assert::enabled) [list source [file join $dir assert.tcl]]
+set auto_index(::control::assert::callback) [list source [file join $dir assert.tcl]]
+set auto_index(::control::AssertSwitch) [list source [file join $dir assert.tcl]]
+set auto_index(::control::assert) [list source [file join $dir assert.tcl]]
+set auto_index(::control::do) [list source [file join $dir do.tcl]]
+set auto_index(::control::no-op) [list source [file join $dir no-op.tcl]]
diff --git a/tcllib/modules/coroutine/ChangeLog b/tcllib/modules/coroutine/ChangeLog
new file mode 100644
index 0000000..38948c7
--- /dev/null
+++ b/tcllib/modules/coroutine/ChangeLog
@@ -0,0 +1,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+.
+
diff --git a/tcllib/modules/coroutine/coro_auto.man b/tcllib/modules/coroutine/coro_auto.man
new file mode 100644
index 0000000..554885a
--- /dev/null
+++ b/tcllib/modules/coroutine/coro_auto.man
@@ -0,0 +1,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]
diff --git a/tcllib/modules/coroutine/coro_auto.tcl b/tcllib/modules/coroutine/coro_auto.tcl
new file mode 100644
index 0000000..e1e87f5
--- /dev/null
+++ b/tcllib/modules/coroutine/coro_auto.tcl
@@ -0,0 +1,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
diff --git a/tcllib/modules/coroutine/coroutine.pcx b/tcllib/modules/coroutine/coroutine.pcx
new file mode 100644
index 0000000..977b22e
--- /dev/null
+++ b/tcllib/modules/coroutine/coroutine.pcx
@@ -0,0 +1,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
diff --git a/tcllib/modules/coroutine/coroutine.tcl b/tcllib/modules/coroutine/coroutine.tcl
new file mode 100644
index 0000000..ef14b83
--- /dev/null
+++ b/tcllib/modules/coroutine/coroutine.tcl
@@ -0,0 +1,379 @@
+## -- Tcl Module -- -*- tcl -*-
+# # ## ### ##### ######## #############
+
+# @@ Meta Begin
+# Package coroutine 1.1.1
+# 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
+
+ while {1} {
+ set blocking [::chan configure $chan -blocking]
+ ::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::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
+
+ try {
+ set result [::chan 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 [::chan 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
+}
+
+# - -- --- ----- -------- -------------
+## 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.1.3
+return
diff --git a/tcllib/modules/coroutine/coroutine_auto.pcx b/tcllib/modules/coroutine/coroutine_auto.pcx
new file mode 100644
index 0000000..5ec93c2
--- /dev/null
+++ b/tcllib/modules/coroutine/coroutine_auto.pcx
@@ -0,0 +1,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
diff --git a/tcllib/modules/coroutine/pkgIndex.tcl b/tcllib/modules/coroutine/pkgIndex.tcl
new file mode 100644
index 0000000..78da732
--- /dev/null
+++ b/tcllib/modules/coroutine/pkgIndex.tcl
@@ -0,0 +1,3 @@
+if {![package vsatisfies [package provide Tcl] 8.6]} {return}
+package ifneeded coroutine 1.1.3 [list source [file join $dir coroutine.tcl]]
+package ifneeded coroutine::auto 1.1.3 [list source [file join $dir coro_auto.tcl]]
diff --git a/tcllib/modules/coroutine/tcllib_coroutine.man b/tcllib/modules/coroutine/tcllib_coroutine.man
new file mode 100644
index 0000000..bff26e2
--- /dev/null
+++ b/tcllib/modules/coroutine/tcllib_coroutine.man
@@ -0,0 +1,110 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset CORO_VERSION 1.1.3]
+[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 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]
diff --git a/tcllib/modules/counter/ChangeLog b/tcllib/modules/counter/ChangeLog
new file mode 100644
index 0000000..3cd1b98
--- /dev/null
+++ b/tcllib/modules/counter/ChangeLog
@@ -0,0 +1,247 @@
+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-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>
+
+ * counter.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-09-27 Andreas Kupries <andreask@activestate.com>
+
+ * counter.test: [SF Tcllib Bug 1272754]. Using 'format' to get
+ results with a deterministic precision.
+
+2006-01-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * counter.test: Fixed use of duplicate test names.
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * counter.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * counter.test: Hooked into the new common test support code.
+
+2006-01-10 Andreas Kupries <andreask@activestate.com>
+
+ * counter.test: Fixed [SF Tcllib Bug 1316036]. Uncluttering test
+ output.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-04-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * counter.tcl: Re-added the 'alt' attribute, i.e. the output now
+ contains both 'title' and 'alt', so that all browsers will be
+ satisfied, whichever attribute they use for their tooltips.
+
+2005-04-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * counter.tcl: Replace usage of the 'alt' attribute in a the <img>
+ tag with the 'title' attribute. Fixed [SF Tcllib Bug 1176744].
+ Reported by David Gravereaux <davygrvy@users.sourceforge.net>.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+Wed Sep 29 12:13:38 2004 Andreas Kupries <andreask@activestate.com>
+
+ * counter.tcl (MergeDay): Fixed [Tcllib SF Bug 943984], a typo
+ causing loss of data. Reported by David Gravereaux
+ <davygrvy@users.sourceforge.net>.
+
+2004-09-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * counter.tcl: Fixed expr'essions without braces.
+
+2004-08-18 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * counter.tcl: Error message added in counter::get if -avgn is
+ used on a non -lastn counter. Replaced fragile prefix stripping
+ with string map in counter::names with a more robust string
+ range based version.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-11-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * counter.man: Added documentation for counter::reset. This fixes
+ [SF Tcllib Bug 759959]. Also added some keywords.
+
+2003-08-13 Brent Welch <welch@panasas.com>
+
+ * counter.tcl: Fixed math in counter::start and counter::stop
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-05-02 Andreas Kupries <andreask@activestate.com>
+
+ * counter.test: Deactivated 'counter-timehist' (via constraint),
+ this test is load-dependent. I.e. it will fail if the machine
+ the test are run on is heavily loaded.
+
+2003-04-24 Andreas Kupries <andreask@activestate.com>
+
+ * counter.test: Added missing propagation of test results.
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * counter.tcl:
+ * counter.man:
+ * pkgIndex.tcl: Fixed bug #614591. Set version of the package to
+ to 2.0.1.
+
+2003-02-23 David N. Welton <davidw@dedasys.com>
+
+ * counter.tcl (counter::names): Use string map instead of regsub.
+ Require Tcl 8.2 as a consequence.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * counter.man: More semantic markup, less visual one.
+
+2002-08-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * counter.tcl: Updated 'info exist' to 'info exists'.
+
+2002-04-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * counter.man: Added doctools manpage.
+
+2001-09-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * counter.tcl: Restricted export list to public API.
+ [456255]. Patch by Hemang Lavana
+ <hemanglavana@users.sourceforge.net>
+
+2001-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * counter.tcl: Frink 2.2 run, fixed dubious code.
+
+2001-07-09 Brent Welch <welch@panasas.com>
+
+ * counter.test: Fixed histlog test
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * counter.tcl: Fixed dubious code reported by frink.
+
+2000-10-04 Brent Welch <welch@ajubasolutions.com>
+
+ * counter.tcl: Fixed bug in counter::MergeDay
+
+2000-10-03 Brent Welch <welch@ajubasolutions.com>
+
+ * counter.tcl: Fixed bug in label format for daily graph.
+
+2000-10-02 Brent Welch <welch@ajubasolutions.com>
+
+ * NAME CHANGE from "stats" to "counter"
+ * counter.tcl: Changed shading of histogram labels.
+
+2000-10-02 Brent Welch <welch@ajubasolutions.com>
+
+ * modules/stats/stats.tcl: Added stats::htmlHistDisplayRow
+ so that the calling page could define the overall table structure.
+
+2000-10-01 Brent Welch <welch@ajubasolutions.com>
+
+ * modules/stats/stats.tcl: Fixed calculation of hourBase
+ and minuteBase when secsPerMinute was not 60.
+
+2000-09-23 Brent Welch <welch@ajubasolutions.com>
+
+ * modules/stats/stats.tcl: Time-based histograms were
+ not displaying the 23rd hour nor the 59th minute.
+
+2000-09-22 Brent Welch <welch@ajubasolutions.com>
+
+ * modules/stats/stats.tcl: Fixed initialization when the
+ server starts in the 59'th minute. The first after event
+ was an hour too long, so the first hour of data didn't
+ display correctly.
+
+2000-09-21 Brent Welch <welch@ajubasolutions.com>
+
+ * modules/stats/stats.tcl: Added time labels and tick
+ marks to all the time-based histograms.
+ Fixed alignment of per-minute and per-hour histograms.
+
+2000-09-20 Brent Welch <welch@ajubasolutions.com>
+
+ * modules/stats/stats.tcl: Refined the countGet routine to return things
+ needed by the TclHttpd status module. Refined the value-based histogram display.
+ * modules/stats/stats.tests: Added more tests.
+ * modules/stats/stats.n: Completed the man page.
+
+2000-09-15 Brent Welch <welch@ajubasolutions.com>
+
+ * Created this module.
+
diff --git a/tcllib/modules/counter/counter.man b/tcllib/modules/counter/counter.man
new file mode 100644
index 0000000..5e0f234
--- /dev/null
+++ b/tcllib/modules/counter/counter.man
@@ -0,0 +1,250 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin counter n 2.0.4]
+[keywords counting]
+[keywords histogram]
+[keywords statistics]
+[keywords tallying]
+[moddesc {Counters and Histograms}]
+[titledesc {Procedures for counters and histograms}]
+[category {Data structures}]
+[require Tcl 8]
+[require counter [opt 2.0.4]]
+[description]
+[para]
+
+The [package counter] package provides a counter facility and can
+compute statistics and histograms over the collected data.
+
+[list_begin definitions]
+
+[call [cmd ::counter::init] [arg {tag args}]]
+
+This defines a counter with the name [arg tag]. The [arg args]
+determines the characteristics of the counter. The [arg args] are
+
+[list_begin definitions]
+[def "[option -group] [arg name]"]
+
+Keep a grouped counter where the name of the histogram bucket is
+passed into [cmd ::counter::count].
+
+[def "[option -hist] [arg bucketsize]"]
+
+Accumulate the counter into histogram buckets of size
+
+[arg bucketsize]. For example, if the samples are millisecond time
+values and [arg bucketsize] is 10, then each histogram bucket
+represents time values of 0 to 10 msec, 10 to 20 msec, 20 to 30 msec,
+and so on.
+
+[def "[option -hist2x] [arg bucketsize]"]
+
+Accumulate the statistic into histogram buckets. The size of the
+first bucket is [arg bucketsize], each other bucket holds values 2
+times the size of the previous bucket. For example, if
+
+[arg bucketsize] is 10, then each histogram bucket represents time
+values of 0 to 10 msec, 10 to 20 msec, 20 to 40 msec, 40 to 80 msec,
+and so on.
+
+[def "[option -hist10x] [arg bucketsize]"]
+
+Accumulate the statistic into histogram buckets. The size of the
+first bucket is [arg bucketsize], each other bucket holds values 10
+times the size of the previous bucket. For example, if
+
+[arg bucketsize] is 10, then each histogram bucket represents time
+values of 0 to 10 msec, 10 to 100 msec, 100 to 1000 msec, and so on.
+
+[def "[option -lastn] [arg N]"]
+
+Save the last [arg N] values of the counter to maintain a "running
+average" over the last [arg N] values.
+
+[def "[option -timehist] [arg secsPerMinute]"]
+
+Keep a time-based histogram. The counter is summed into a histogram
+bucket based on the current time. There are 60 per-minute buckets
+that have a size determined by [arg secsPerMinute], which is normally
+60, but for testing purposes can be less. Every "hour" (i.e., 60
+"minutes") the contents of the per-minute buckets are summed into the
+next hourly bucket. Every 24 "hours" the contents of the per-hour
+buckets are summed into the next daily bucket. The counter package
+keeps all time-based histograms in sync, so the first
+
+[arg secsPerMinute] value seen by the package is used for all
+subsequent time-based histograms.
+
+[list_end]
+
+[call [cmd ::counter::count] [arg tag] [opt [arg delta]] [opt [arg instance]]]
+
+Increment the counter identified by [arg tag]. The default increment
+is 1, although you can increment by any value, integer or real, by
+specifying [arg delta]. You must declare each counter with
+
+[cmd ::counter::init] to define the characteristics of counter before
+you start to use it. If the counter type is [option -group], then the
+counter identified by [arg instance] is incremented.
+
+[call [cmd ::counter::start] [arg {tag instance}]]
+
+Record the starting time of an interval. The [arg tag] is the name of
+the counter defined as a [option -hist] value-based histogram. The
+[arg instance] is used to distinguish this interval from any other
+intervals that might be overlapping this one.
+
+[call [cmd ::counter::stop] [arg {tag instance}]]
+
+Record the ending time of an interval. The delta time since the
+corresponding [cmd ::counter::start] call for [arg instance] is
+recorded in the histogram identified by [arg tag].
+
+[call [cmd ::counter::get] [arg {tag args}]]
+
+Return statistics about a counter identified by [arg tag]. The
+
+[arg args] determine what value to return:
+
+[list_begin definitions]
+[def [option -total]]
+
+Return the total value of the counter. This is the default if
+
+[arg args] is not specified.
+
+[def [option -totalVar]]
+
+Return the name of the total variable. Useful for specifying with
+-textvariable in a Tk widget.
+
+[def [option -N]]
+
+Return the number of samples accumulated into the counter.
+
+[def [option -avg]]
+
+Return the average of samples accumulated into the counter.
+
+[def [option -avgn]]
+
+Return the average over the last [arg N] samples taken. The [arg N]
+value is set in the [cmd ::counter::init] call.
+
+[def "[option -hist] [arg bucket]"]
+
+If [arg bucket] is specified, then the value in that bucket of the
+histogram is returned. Otherwise the complete histogram is returned
+in array get format sorted by bucket.
+
+[def [option -histVar]]
+
+Return the name of the histogram array variable.
+
+[def [option -histHour]]
+
+Return the complete hourly histogram in array get format sorted by
+bucket.
+
+[def [option -histHourVar]]
+
+Return the name of the hourly histogram array variable.
+
+[def [option -histDay]]
+
+Return the complete daily histogram in array get format sorted by
+bucket.
+
+[def [option -histDayVar]]
+
+Return the name of the daily histogram array variable.
+
+[def [option -resetDate]]
+
+Return the clock seconds value recorded when the
+counter was last reset.
+
+[def [option -all]]
+
+Return an array get of the array used to store the counter. This
+includes the total, the number of samples (N), and any type-specific
+information. This does not include the histogram array.
+
+[list_end]
+
+[call [cmd ::counter::exists] [arg tag]]
+
+Returns 1 if the counter is defined.
+
+[call [cmd ::counter::names]]
+
+Returns a list of all counters defined.
+
+[call [cmd ::counter::histHtmlDisplay] [arg {tag args}]]
+
+Generate HTML to display a histogram for a counter. The [arg args]
+control the format of the display. They are:
+
+[list_begin definitions]
+[def "[option -title] [arg string]"]
+
+Label to display above bar chart
+
+[def "[option -unit] [arg unit]"]
+
+Specify [const minutes], [const hours], or [const days] for the
+time-base histograms. For value-based histograms, the [arg unit] is
+used in the title.
+
+[def "[option -images] [arg url]"]
+
+URL of /images directory.
+
+[def "[option -gif] [arg filename]"]
+
+Image for normal histogram bars. The [arg filename] is relative to
+the [option -images] directory.
+
+[def "[option -ongif] [arg filename]"]
+
+Image for the active histogram bar. The [arg filename] is relative to
+the [option -images] directory.
+
+[def "[option -max] [arg N]"]
+
+Maximum number of value-based buckets to display.
+
+[def "[option -height] [arg N]"]
+
+Pixel height of the highest bar.
+
+[def "[option -width] [arg N]"]
+
+Pixel width of each bar.
+
+[def "[option -skip] [arg N]"]
+
+Buckets to skip when labeling value-based histograms.
+
+[def "[option -format] [arg string]"]
+
+Format used to display labels of buckets.
+
+[def "[option -text] [arg boolean]"]
+
+If 1, a text version of the histogram is dumped, otherwise a graphical
+one is generated.
+
+[list_end]
+
+[call [cmd ::counter::reset] [arg {tag args}]]
+
+Resets the counter with the name [arg tag] to an initial state. The
+[arg args] determine the new characteristics of the counter. They have
+the same meaning as described for [cmd ::counter::init].
+
+[list_end]
+
+[vset CATEGORY counter]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/counter/counter.tcl b/tcllib/modules/counter/counter.tcl
new file mode 100644
index 0000000..61aa3ff
--- /dev/null
+++ b/tcllib/modules/counter/counter.tcl
@@ -0,0 +1,1265 @@
+# counter.tcl --
+#
+# Procedures to manage simple counters and histograms.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: counter.tcl,v 1.23 2005/09/30 05:36:38 andreas_kupries Exp $
+
+package require Tcl 8.2
+
+namespace eval ::counter {
+
+ # Variables of name counter::T-$tagname
+ # are created as arrays to support each counter.
+
+ # Time-based histograms are kept in sync with each other,
+ # so these variables are shared among them.
+ # These base times record the time corresponding to the first bucket
+ # of the per-minute, per-hour, and per-day time-based histograms.
+
+ variable startTime
+ variable minuteBase
+ variable hourBase
+ variable hourEnd
+ variable dayBase
+ variable hourIndex
+ variable dayIndex
+
+ # The time-based histogram uses an after event and a list
+ # of counters to do mergeing on.
+
+ variable tagsToMerge
+ if {![info exists tagsToMerge]} {
+ set tagsToMerge {}
+ }
+ variable mergeInterval
+
+ namespace export init reset count exists get names start stop
+ namespace export histHtmlDisplay histHtmlDisplayRow histHtmlDisplayBarChart
+}
+
+# ::counter::init --
+#
+# Set up a counter.
+#
+# Arguments:
+# tag The identifier for the counter. Pass this to counter::count
+# args option values pairs that define characteristics of the counter:
+# See the man page for definitons.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Initializes state about a counter.
+
+proc ::counter::init {tag args} {
+ upvar #0 counter::T-$tag counter
+ if {[info exists counter]} {
+ unset counter
+ }
+ set counter(N) 0 ;# Number of samples
+ set counter(total) 0
+ set counter(type) {}
+
+ # With an empty type the counter is a simple accumulator
+ # for which we can compute an average. Here we loop through
+ # the args to determine what additional counter attributes
+ # we need to maintain in counter::count
+
+ foreach {option value} $args {
+ switch -- $option {
+ -timehist {
+ variable tagsToMerge
+ variable secsPerMinute
+ variable startTime
+ variable minuteBase
+ variable hourBase
+ variable dayBase
+ variable hourIndex
+ variable dayIndex
+
+ upvar #0 counter::H-$tag histogram
+ upvar #0 counter::Hour-$tag hourhist
+ upvar #0 counter::Day-$tag dayhist
+
+ # Clear the histograms.
+
+ for {set i 0} {$i < 60} {incr i} {
+ set histogram($i) 0
+ }
+ for {set i 0} {$i < 24} {incr i} {
+ set hourhist($i) 0
+ }
+ if {[info exists dayhist]} {
+ unset dayhist
+ }
+ set dayhist(0) 0
+
+ # Clear all-time high records
+
+ set counter(maxPerMinute) 0
+ set counter(maxPerHour) 0
+ set counter(maxPerDay) 0
+
+ # The value associated with -timehist is the number of seconds
+ # in each bucket. Normally this is 60, but for
+ # testing, we compress minutes. The value is limited at
+ # 60 because the per-minute buckets are accumulated into
+ # per-hour buckets later.
+
+ if {$value == "" || $value == 0 || $value > 60} {
+ set value 60
+ }
+
+ # Histogram state variables.
+ # All time-base histograms share the same bucket size
+ # and starting times to keep them all synchronized.
+ # So, we only initialize these parameters once.
+
+ if {![info exists secsPerMinute]} {
+ set secsPerMinute $value
+
+ set startTime [clock seconds]
+ set dayIndex 0
+
+ set dayStart [clock scan [clock format $startTime \
+ -format 00:00]]
+
+ # Figure out what "hour" we are
+
+ set delta [expr {$startTime - $dayStart}]
+ set hourIndex [expr {$delta / ($secsPerMinute * 60)}]
+ set day [expr {$hourIndex / 24}]
+ set hourIndex [expr {$hourIndex % 24}]
+
+ set hourBase [expr {$dayStart + $day * $secsPerMinute * 60 * 24}]
+ set minuteBase [expr {$hourBase + $hourIndex * 60 * $secsPerMinute}]
+
+ set partialHour [expr {$startTime -
+ ($hourBase + $hourIndex * 60 * $secsPerMinute)}]
+ set secs [expr {(60 * $secsPerMinute) - $partialHour}]
+ if {$secs <= 0} {
+ set secs 1
+ }
+
+ # After the first timer, the event occurs once each "hour"
+
+ set mergeInterval [expr {60 * $secsPerMinute * 1000}]
+ after [expr {$secs * 1000}] [list counter::MergeHour $mergeInterval]
+ }
+ if {[lsearch $tagsToMerge $tag] < 0} {
+ lappend tagsToMerge $tag
+ }
+
+ # This records the last used slots in order to zero-out the
+ # buckets that are skipped during idle periods.
+
+ set counter(lastMinute) -1
+
+ # The following is referenced when bugs cause histogram
+ # hits outside the expect range (overflow and underflow)
+
+ set counter(bucketsize) 0
+ }
+ -group {
+ # Cluster a set of counters with a single total
+
+ upvar #0 counter::H-$tag histogram
+ if {[info exists histogram]} {
+ unset histogram
+ }
+ set counter(group) $value
+ }
+ -lastn {
+ # The lastN samples are kept if a vector to form a running average.
+
+ upvar #0 counter::V-$tag vector
+ set counter(lastn) $value
+ set counter(index) 0
+ if {[info exists vector]} {
+ unset vector
+ }
+ for {set i 0} {$i < $value} {incr i} {
+ set vector($i) 0
+ }
+ }
+ -hist {
+ # A value-based histogram with buckets for different values.
+
+ upvar #0 counter::H-$tag histogram
+ if {[info exists histogram]} {
+ unset histogram
+ }
+ set counter(bucketsize) $value
+ set counter(mult) 1
+ }
+ -hist2x {
+ upvar #0 counter::H-$tag histogram
+ if {[info exists histogram]} {
+ unset histogram
+ }
+ set counter(bucketsize) $value
+ set counter(mult) 2
+ }
+ -hist10x {
+ upvar #0 counter::H-$tag histogram
+ if {[info exists histogram]} {
+ unset histogram
+ }
+ set counter(bucketsize) $value
+ set counter(mult) 10
+ }
+ -histlog {
+ upvar #0 counter::H-$tag histogram
+ if {[info exists histogram]} {
+ unset histogram
+ }
+ set counter(bucketsize) $value
+ }
+ -simple {
+ # Useful when disabling predefined -timehist or -group counter
+ }
+ default {
+ return -code error "Unsupported option $option.\
+ Must be -timehist, -group, -lastn, -hist, -hist2x, -hist10x, -histlog, or -simple."
+ }
+ }
+ if {[string length $option]} {
+ # In case an option doesn't change the type, but
+ # this feature of the interface isn't used, etc.
+
+ lappend counter(type) $option
+ }
+ }
+
+ # Instead of supporting a counter that could have multiple attributes,
+ # we support a single type to make counting more efficient.
+
+ if {[llength $counter(type)] > 1} {
+ return -code error "Multiple type attributes not supported. Use only one of\
+ -timehist, -group, -lastn, -hist, -hist2x, -hist10x, -histlog, -disabled."
+ }
+ return ""
+}
+
+# ::counter::reset --
+#
+# Reset a counter.
+#
+# Arguments:
+# tag The identifier for the counter.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Deletes the counter and calls counter::init again for it.
+
+proc ::counter::reset {tag args} {
+ upvar #0 counter::T-$tag counter
+
+ # Layer reset on top of init. Here we figure out what
+ # we need to pass into the init procedure to recreate it.
+
+ switch -- $counter(type) {
+ "" {
+ set args ""
+ }
+ -group {
+ upvar #0 counter::H-$tag histogram
+ if {[info exists histogram]} {
+ unset histogram
+ }
+ set args [list -group $counter(group)]
+ }
+ -lastn {
+ upvar #0 counter::V-$tag vector
+ if {[info exists vector]} {
+ unset vector
+ }
+ set args [list -lastn $counter(lastn)]
+ }
+ -hist -
+ -hist10x -
+ -histlog -
+ -hist2x {
+ upvar #0 counter::H-$tag histogram
+ if {[info exists histogram]} {
+ unset histogram
+ }
+ set args [list $counter(type) $counter(bucketsize)]
+ }
+ -timehist {
+ foreach h [list counter::H-$tag counter::Hour-$tag counter::Day-$tag] {
+ upvar #0 $h histogram
+ if {[info exists histogram]} {
+ unset histogram
+ }
+ }
+ set args [list -timehist $counter::secsPerMinute]
+ }
+ default {#ignore}
+ }
+ unset counter
+ eval {counter::init $tag} $args
+ set counter(resetDate) [clock seconds]
+ return ""
+}
+
+# ::counter::count --
+#
+# Accumulate statistics.
+#
+# Arguments:
+# tag The counter identifier.
+# delta The increment amount. Defaults to 1.
+# arg For -group types, this is the histogram index.
+#
+# Results:
+# None
+#
+# Side Effects:
+# Accumlate statistics.
+
+proc ::counter::count {tag {delta 1} args} {
+ upvar #0 counter::T-$tag counter
+ set counter(total) [expr {$counter(total) + $delta}]
+ incr counter(N)
+
+ # Instead of supporting a counter that could have multiple attributes,
+ # we support a single type to make counting a skosh more efficient.
+
+# foreach option $counter(type) {
+ switch -- $counter(type) {
+ "" {
+ # Simple counter
+ return
+ }
+ -group {
+ upvar #0 counter::H-$tag histogram
+ set subIndex [lindex $args 0]
+ if {![info exists histogram($subIndex)]} {
+ set histogram($subIndex) 0
+ }
+ set histogram($subIndex) [expr {$histogram($subIndex) + $delta}]
+ }
+ -lastn {
+ upvar #0 counter::V-$tag vector
+ set vector($counter(index)) $delta
+ set counter(index) [expr {($counter(index) +1)%$counter(lastn)}]
+ }
+ -hist {
+ upvar #0 counter::H-$tag histogram
+ set bucket [expr {int($delta / $counter(bucketsize))}]
+ if {![info exists histogram($bucket)]} {
+ set histogram($bucket) 0
+ }
+ incr histogram($bucket)
+ }
+ -hist10x -
+ -hist2x {
+ upvar #0 counter::H-$tag histogram
+ set bucket 0
+ for {set max $counter(bucketsize)} {$delta > $max} \
+ {set max [expr {$max * $counter(mult)}]} {
+ incr bucket
+ }
+ if {![info exists histogram($bucket)]} {
+ set histogram($bucket) 0
+ }
+ incr histogram($bucket)
+ }
+ -histlog {
+ upvar #0 counter::H-$tag histogram
+ set bucket [expr {int(log($delta)*$counter(bucketsize))}]
+ if {![info exists histogram($bucket)]} {
+ set histogram($bucket) 0
+ }
+ incr histogram($bucket)
+ }
+ -timehist {
+ upvar #0 counter::H-$tag histogram
+ variable minuteBase
+ variable secsPerMinute
+
+ set minute [expr {([clock seconds] - $minuteBase) / $secsPerMinute}]
+ if {$minute > 59} {
+ # this occurs while debugging if the process is
+ # stopped at a breakpoint too long.
+ set minute 59
+ }
+
+ # Initialize the current bucket and
+ # clear any buckets we've skipped since the last sample.
+
+ if {$minute != $counter(lastMinute)} {
+ set histogram($minute) 0
+ for {set i [expr {$counter(lastMinute)+1}]} \
+ {$i < $minute} \
+ {incr i} {
+ set histogram($i) 0
+ }
+ set counter(lastMinute) $minute
+ }
+ set histogram($minute) [expr {$histogram($minute) + $delta}]
+ }
+ default {#ignore}
+ }
+# }
+ return
+}
+
+# ::counter::exists --
+#
+# Return true if the counter exists.
+#
+# Arguments:
+# tag The counter identifier.
+#
+# Results:
+# 1 if it has been defined.
+#
+# Side Effects:
+# None.
+
+proc ::counter::exists {tag} {
+ upvar #0 counter::T-$tag counter
+ return [info exists counter]
+}
+
+# ::counter::get --
+#
+# Return statistics.
+#
+# Arguments:
+# tag The counter identifier.
+# option What statistic to get
+# args Needed by some options.
+#
+# Results:
+# With no args, just the counter value.
+#
+# Side Effects:
+# None.
+
+proc ::counter::get {tag {option -total} args} {
+ upvar #0 counter::T-$tag counter
+ switch -- $option {
+ -total {
+ return $counter(total)
+ }
+ -totalVar {
+ return ::counter::T-$tag\(total)
+ }
+ -N {
+ return $counter(N)
+ }
+ -avg {
+ if {$counter(N) == 0} {
+ return 0
+ } else {
+ return [expr {$counter(total) / double($counter(N))}]
+ }
+ }
+ -avgn {
+ if {$counter(type) != "-lastn"} {
+ return -code error "The -avgn option is only supported for -lastn counters."
+ }
+ upvar #0 counter::V-$tag vector
+ set sum 0
+ for {set i 0} {($i < $counter(N)) && ($i < $counter(lastn))} {incr i} {
+ set sum [expr {$sum + $vector($i)}]
+ }
+ if {$i == 0} {
+ return 0
+ } else {
+ return [expr {$sum / double($i)}]
+ }
+ }
+ -hist {
+ upvar #0 counter::H-$tag histogram
+ if {[llength $args]} {
+ # Return particular bucket
+ set bucket [lindex $args 0]
+ if {[info exists histogram($bucket)]} {
+ return $histogram($bucket)
+ } else {
+ return 0
+ }
+ } else {
+ # Dump the whole histogram
+
+ set result {}
+ if {$counter(type) == "-group"} {
+ set sort -dictionary
+ } else {
+ set sort -integer
+ }
+ foreach x [lsort $sort [array names histogram]] {
+ lappend result $x $histogram($x)
+ }
+ return $result
+ }
+ }
+ -histVar {
+ return ::counter::H-$tag
+ }
+ -histHour {
+ upvar #0 counter::Hour-$tag histogram
+ set result {}
+ foreach x [lsort -integer [array names histogram]] {
+ lappend result $x $histogram($x)
+ }
+ return $result
+ }
+ -histHourVar {
+ return ::counter::Hour-$tag
+ }
+ -histDay {
+ upvar #0 counter::Day-$tag histogram
+ set result {}
+ foreach x [lsort -integer [array names histogram]] {
+ lappend result $x $histogram($x)
+ }
+ return $result
+ }
+ -histDayVar {
+ return ::counter::Day-$tag
+ }
+ -maxPerMinute {
+ return $counter(maxPerMinute)
+ }
+ -maxPerHour {
+ return $counter(maxPerHour)
+ }
+ -maxPerDay {
+ return $counter(maxPerDay)
+ }
+ -resetDate {
+ if {[info exists counter(resetDate)]} {
+ return $counter(resetDate)
+ } else {
+ return ""
+ }
+ }
+ -all {
+ return [array get counter]
+ }
+ default {
+ return -code error "Invalid option $option.\
+ Should be -all, -total, -N, -avg, -avgn, -hist, -histHour,\
+ -histDay, -totalVar, -histVar, -histHourVar, -histDayVar -resetDate."
+ }
+ }
+}
+
+# ::counter::names --
+#
+# Return the list of defined counters.
+#
+# Arguments:
+# none
+#
+# Results:
+# A list of counter tags.
+#
+# Side Effects:
+# None.
+
+proc ::counter::names {} {
+ set result {}
+ foreach v [info vars ::counter::T-*] {
+ if {[info exists $v]} {
+ # Declared arrays might not exist, yet
+ # strip prefix from name
+ set v [string range $v [string length "::counter::T-"] end]
+ lappend result $v
+ }
+ }
+ return $result
+}
+
+# ::counter::MergeHour --
+#
+# Sum the per-minute histogram into the next hourly bucket.
+# On 24-hour boundaries, sum the hourly buckets into the next day bucket.
+# This operates on all time-based histograms.
+#
+# Arguments:
+# none
+#
+# Results:
+# none
+#
+# Side Effects:
+# See description.
+
+proc ::counter::MergeHour {interval} {
+ variable hourIndex
+ variable minuteBase
+ variable hourBase
+ variable tagsToMerge
+ variable secsPerMinute
+
+ after $interval [list counter::MergeHour $interval]
+ if {![info exists hourBase] || $hourIndex == 0} {
+ set hourBase $minuteBase
+ }
+ set minuteBase [clock seconds]
+
+ foreach tag $tagsToMerge {
+ upvar #0 counter::T-$tag counter
+ upvar #0 counter::H-$tag histogram
+ upvar #0 counter::Hour-$tag hourhist
+
+ # Clear any buckets we've skipped since the last sample.
+
+ for {set i [expr {$counter(lastMinute)+1}]} {$i < 60} {incr i} {
+ set histogram($i) 0
+ }
+ set counter(lastMinute) -1
+
+ # Accumulate into the next hour bucket.
+
+ set hourhist($hourIndex) 0
+ set max 0
+ foreach i [array names histogram] {
+ set hourhist($hourIndex) [expr {$hourhist($hourIndex) + $histogram($i)}]
+ if {$histogram($i) > $max} {
+ set max $histogram($i)
+ }
+ }
+ set perSec [expr {$max / $secsPerMinute}]
+ if {$perSec > $counter(maxPerMinute)} {
+ set counter(maxPerMinute) $perSec
+ }
+ }
+ set hourIndex [expr {($hourIndex + 1) % 24}]
+ if {$hourIndex == 0} {
+ counter::MergeDay
+ }
+
+}
+# ::counter::MergeDay --
+#
+# Sum the per-minute histogram into the next hourly bucket.
+# On 24-hour boundaries, sum the hourly buckets into the next day bucket.
+# This operates on all time-based histograms.
+#
+# Arguments:
+# none
+#
+# Results:
+# none
+#
+# Side Effects:
+# See description.
+
+proc ::counter::MergeDay {} {
+ variable dayIndex
+ variable dayBase
+ variable hourBase
+ variable tagsToMerge
+ variable secsPerMinute
+
+ # Save the hours histogram into a bucket for the last day
+ # counter(day,$day) is the starting time for that day bucket
+
+ if {![info exists dayBase]} {
+ set dayBase $hourBase
+ }
+ foreach tag $tagsToMerge {
+ upvar #0 counter::T-$tag counter
+ upvar #0 counter::Day-$tag dayhist
+ upvar #0 counter::Hour-$tag hourhist
+ set dayhist($dayIndex) 0
+ set max 0
+ for {set i 0} {$i < 24} {incr i} {
+ if {[info exists hourhist($i)]} {
+ set dayhist($dayIndex) [expr {$dayhist($dayIndex) + $hourhist($i)}]
+ if {$hourhist($i) > $max} {
+ set max $hourhist($i)
+ }
+ }
+ }
+ set perSec [expr {double($max) / ($secsPerMinute * 60)}]
+ if {$perSec > $counter(maxPerHour)} {
+ set counter(maxPerHour) $perSec
+ }
+ }
+ set perSec [expr {double($dayhist($dayIndex)) / ($secsPerMinute * 60 * 24)}]
+ if {$perSec > $counter(maxPerDay)} {
+ set counter(maxPerDay) $perSec
+ }
+ incr dayIndex
+}
+
+# ::counter::histHtmlDisplay --
+#
+# Create an html display of the histogram.
+#
+# Arguments:
+# tag The counter tag
+# args option, value pairs that affect the display:
+# -title Label to display above bar chart
+# -unit minutes, hours, or days select time-base histograms.
+# Specify anything else for value-based histograms.
+# -images URL of /images directory.
+# -gif Image for normal histogram bars
+# -ongif Image for the active histogram bar
+# -max Maximum number of value-based buckets to display
+# -height Pixel height of the highest bar
+# -width Pixel width of each bar
+# -skip Buckets to skip when labeling value-based histograms
+# -format Format used to display labels of buckets.
+# -text If 1, a text version of the histogram is dumped,
+# otherwise a graphical one is generated.
+#
+# Results:
+# HTML for the display as a complete table.
+#
+# Side Effects:
+# None.
+
+proc ::counter::histHtmlDisplay {tag args} {
+ append result "<p>\n<table border=0 cellpadding=0 cellspacing=0>\n"
+ append result [eval {counter::histHtmlDisplayRow $tag} $args]
+ append result </table>
+ return $result
+}
+
+# ::counter::histHtmlDisplayRow --
+#
+# Create an html display of the histogram.
+#
+# Arguments:
+# See counter::histHtmlDisplay
+#
+# Results:
+# HTML for the display. Ths is one row of a 2-column table,
+# the calling page must define the <table> tag.
+#
+# Side Effects:
+# None.
+
+proc ::counter::histHtmlDisplayRow {tag args} {
+ upvar #0 counter::T-$tag counter
+ variable secsPerMinute
+ variable minuteBase
+ variable hourBase
+ variable dayBase
+ variable hourIndex
+ variable dayIndex
+
+ array set options [list \
+ -title $tag \
+ -unit "" \
+ -images /images \
+ -gif Blue.gif \
+ -ongif Red.gif \
+ -max -1 \
+ -height 100 \
+ -width 4 \
+ -skip 4 \
+ -format %.2f \
+ -text 0
+ ]
+ array set options $args
+
+ # Support for self-posting pages that can clear counters.
+
+ append result "<!-- resetCounter [ncgi::value resetCounter] -->"
+ if {[ncgi::value resetCounter] == $tag} {
+ counter::reset $tag
+ return "<!-- Reset $tag counter -->"
+ }
+
+ switch -glob -- $options(-unit) {
+ min* {
+ upvar #0 counter::H-$tag histogram
+ set histname counter::H-$tag
+ if {![info exists minuteBase]} {
+ return "<!-- No time-based histograms defined -->"
+ }
+ set time $minuteBase
+ set secsForMax $secsPerMinute
+ set periodMax $counter(maxPerMinute)
+ set curIndex [expr {([clock seconds] - $minuteBase) / $secsPerMinute}]
+ set options(-max) 60
+ set options(-min) 0
+ }
+ hour* {
+ upvar #0 counter::Hour-$tag histogram
+ set histname counter::Hour-$tag
+ if {![info exists hourBase]} {
+ return "<!-- Hour merge has not occurred -->"
+ }
+ set time $hourBase
+ set secsForMax [expr {$secsPerMinute * 60}]
+ set periodMax $counter(maxPerHour)
+ set curIndex [expr {$hourIndex - 1}]
+ if {$curIndex < 0} {
+ set curIndex 23
+ }
+ set options(-max) 24
+ set options(-min) 0
+ }
+ day* {
+ upvar #0 counter::Day-$tag histogram
+ set histname counter::Day-$tag
+ if {![info exists dayBase]} {
+ return "<!-- Hour merge has not occurred -->"
+ }
+ set time $dayBase
+ set secsForMax [expr {$secsPerMinute * 60 * 24}]
+ set periodMax $counter(maxPerDay)
+ set curIndex dayIndex
+ set options(-max) $dayIndex
+ set options(-min) 0
+ }
+ default {
+ # Value-based histogram with arbitrary units.
+
+ upvar #0 counter::H-$tag histogram
+ set histname counter::H-$tag
+
+ set unit $options(-unit)
+ set curIndex ""
+ set time ""
+ }
+ }
+ if {! [info exists histogram]} {
+ return "<!-- $histname doesn't exist -->\n"
+ }
+
+ set max 0
+ set maxName 0
+ foreach {name value} [array get histogram] {
+ if {$value > $max} {
+ set max $value
+ set maxName $name
+ }
+ }
+
+ # Start 2-column HTML display. A summary table at the left, the histogram on the right.
+
+ append result "<tr><td valign=top>\n"
+
+ append result "<table bgcolor=#EEEEEE>\n"
+ append result "<tr><td colspan=2 align=center>[html::font]<b>$options(-title)</b></font></td></tr>\n"
+ append result "<tr><td>[html::font]<b>Total</b></font></td>"
+ append result "<td>[html::font][format $options(-format) $counter(total)]</font></td></tr>\n"
+
+ if {[info exists secsForMax]} {
+
+ # Time-base histogram
+
+ set string {}
+ set t $secsForMax
+ set days [expr {$t / (60 * 60 * 24)}]
+ if {$days == 1} {
+ append string "1 Day "
+ } elseif {$days > 1} {
+ append string "$days Days "
+ }
+ set t [expr {$t - $days * (60 * 60 * 24)}]
+ set hours [expr {$t / (60 * 60)}]
+ if {$hours == 1} {
+ append string "1 Hour "
+ } elseif {$hours > 1} {
+ append string "$hours Hours "
+ }
+ set t [expr {$t - $hours * (60 * 60)}]
+ set mins [expr {$t / 60}]
+ if {$mins == 1} {
+ append string "1 Minute "
+ } elseif {$mins > 1} {
+ append string "$mins Minutes "
+ }
+ set t [expr {$t - $mins * 60}]
+ if {$t == 1} {
+ append string "1 Second "
+ } elseif {$t > 1} {
+ append string "$t Seconds "
+ }
+ append result "<tr><td>[html::font]<b>Bucket Size</b></font></td>"
+ append result "<td>[html::font]$string</font></td></tr>\n"
+
+ append result "<tr><td>[html::font]<b>Max Per Sec</b></font></td>"
+ append result "<td>[html::font][format %.2f [expr {$max/double($secsForMax)}]]</font></td></tr>\n"
+
+ if {$periodMax > 0} {
+ append result "<tr><td>[html::font]<b>Best Per Sec</b></font></td>"
+ append result "<td>[html::font][format %.2f $periodMax]</font></td></tr>\n"
+ }
+ append result "<tr><td>[html::font]<b>Starting Time</b></font></td>"
+ switch -glob -- $options(-unit) {
+ min* {
+ append result "<td>[html::font][clock format $time \
+ -format %k:%M:%S]</font></td></tr>\n"
+ }
+ hour* {
+ append result "<td>[html::font][clock format $time \
+ -format %k:%M:%S]</font></td></tr>\n"
+ }
+ day* {
+ append result "<td>[html::font][clock format $time \
+ -format "%b %d %k:%M"]</font></td></tr>\n"
+ }
+ default {#ignore}
+ }
+
+ } else {
+
+ # Value-base histogram
+
+ set ix [lsort -integer [array names histogram]]
+
+ set mode [expr {$counter(bucketsize) * $maxName}]
+ set first [expr {$counter(bucketsize) * [lindex $ix 0]}]
+ set last [expr {$counter(bucketsize) * [lindex $ix end]}]
+
+ append result "<tr><td>[html::font]<b>Average</b></font></td>"
+ append result "<td>[html::font][format $options(-format) [counter::get $tag -avg]]</font></td></tr>\n"
+
+ append result "<tr><td>[html::font]<b>Mode</b></font></td>"
+ append result "<td>[html::font]$mode</font></td></tr>\n"
+
+ append result "<tr><td>[html::font]<b>Minimum</b></font></td>"
+ append result "<td>[html::font]$first</font></td></tr>\n"
+
+ append result "<tr><td>[html::font]<b>Maximum</b></font></td>"
+ append result "<td>[html::font]$last</font></td></tr>\n"
+
+ append result "<tr><td>[html::font]<b>Unit</b></font></td>"
+ append result "<td>[html::font]$unit</font></td></tr>\n"
+
+ append result "<tr><td colspan=2 align=center>[html::font]<b>"
+ append result "<a href=[ncgi::urlStub]?resetCounter=$tag>Reset</a></td></tr>\n"
+
+ if {$options(-max) < 0} {
+ set options(-max) [lindex $ix end]
+ }
+ if {![info exists options(-min)]} {
+ set options(-min) [lindex $ix 0]
+ }
+ }
+
+ # End table nested inside left-hand column
+
+ append result </table>\n
+ append result </td>\n
+ append result "<td valign=bottom>\n"
+
+
+ # Display the histogram
+
+ if {$options(-text)} {
+ } else {
+ append result [eval \
+ {counter::histHtmlDisplayBarChart $tag histogram $max $curIndex $time} \
+ [array get options]]
+ }
+
+ # Close the right hand column, but leave our caller's table open.
+
+ append result </td></tr>\n
+
+ return $result
+}
+
+# ::counter::histHtmlDisplayBarChart --
+#
+# Create an html display of the histogram.
+#
+# Arguments:
+# tag The counter tag.
+# histVar The name of the histogram array
+# max The maximum counter value in a histogram bucket.
+# curIndex The "current" histogram index, for time-base histograms.
+# time The base, or starting time, for the time-based histograms.
+# args The array get of the options passed into histHtmlDisplay
+#
+# Results:
+# HTML for the bar chart.
+#
+# Side Effects:
+# See description.
+
+proc ::counter::histHtmlDisplayBarChart {tag histVar max curIndex time args} {
+ upvar #0 counter::T-$tag counter
+ upvar 1 $histVar histogram
+ variable secsPerMinute
+ array set options $args
+
+ append result "<table cellpadding=0 cellspacing=0 bgcolor=#eeeeee><tr>\n"
+
+ set ix [lsort -integer [array names histogram]]
+
+ for {set t $options(-min)} {$t < $options(-max)} {incr t} {
+ if {![info exists histogram($t)]} {
+ set value 0
+ } else {
+ set value $histogram($t)
+ }
+ if {$max == 0 || $value == 0} {
+ set height 1
+ } else {
+ set percent [expr {round($value * 100.0 / $max)}]
+ set height [expr {$percent * $options(-height) / 100}]
+ }
+ if {$t == $curIndex} {
+ set img src=$options(-images)/$options(-ongif)
+ } else {
+ set img src=$options(-images)/$options(-gif)
+ }
+ append result "<td valign=bottom><img $img height=$height\
+ width=$options(-width) title=$value alt=$value></td>\n"
+ }
+ append result "</tr>"
+
+ # Count buckets outside the range requested
+
+ set overflow 0
+ set underflow 0
+ foreach t [lsort -integer [array names histogram]] {
+ if {($options(-max) > 0) && ($t > $options(-max))} {
+ incr overflow
+ }
+ if {($options(-min) >= 0) && ($t < $options(-min))} {
+ incr underflow
+ }
+ }
+
+ # Append a row of labels at the bottom.
+
+ set colors {black #CCCCCC}
+ set bgcolors {#CCCCCC black}
+ set colori 0
+ if {$counter(type) != "-timehist"} {
+
+ # Label each bucket with its value
+ # This is probably wrong for hist2x and hist10x
+
+ append result "<tr>"
+ set skip $options(-skip)
+ if {![info exists counter(mult)]} {
+ set counter(mult) 1
+ }
+
+ # These are tick marks
+
+ set img src=$options(-images)/$options(-gif)
+ append result "<tr>"
+ for {set i $options(-min)} {$i < $options(-max)} {incr i} {
+ if {(($i % $skip) == 0)} {
+ append result "<td valign=bottom><img $img height=3 \
+ width=1></td>\n"
+ } else {
+ append result "<td valign=bottom></td>"
+ }
+ }
+ append result </tr>
+
+ # These are the labels
+
+ append result "<tr>"
+ for {set i $options(-min)} {$i < $options(-max)} {incr i} {
+ if {$counter(type) == "-histlog"} {
+ if {[catch {expr {int(log($i) * $counter(bucketsize))}} x]} {
+ # Out-of-bounds
+ break
+ }
+ } else {
+ set x [expr {$i * $counter(bucketsize) * $counter(mult)}]
+ }
+ set label [format $options(-format) $x]
+ if {(($i % $skip) == 0)} {
+ set color [lindex $colors $colori]
+ set bg [lindex $bgcolors $colori]
+ set colori [expr {($colori+1) % 2}]
+ append result "<td colspan=$skip><font size=1 color=$color>$label</font></td>"
+ }
+ }
+ append result </tr>
+ } else {
+ switch -glob -- $options(-unit) {
+ min* {
+ if {$secsPerMinute != 60} {
+ set format %k:%M:%S
+ set skip 12
+ } else {
+ set format %k:%M
+ set skip 4
+ }
+ set deltaT $secsPerMinute
+ set wrapDeltaT [expr {$secsPerMinute * -59}]
+ }
+ hour* {
+ if {$secsPerMinute != 60} {
+ set format %k:%M
+ set skip 4
+ } else {
+ set format %k
+ set skip 2
+ }
+ set deltaT [expr {$secsPerMinute * 60}]
+ set wrapDeltaT [expr {$secsPerMinute * 60 * -23}]
+ }
+ day* {
+ if {$secsPerMinute != 60} {
+ set format "%m/%d %k:%M"
+ set skip 10
+ } else {
+ set format %k
+ set skip $options(-skip)
+ }
+ set deltaT [expr {$secsPerMinute * 60 * 24}]
+ set wrapDeltaT 0
+ }
+ default {#ignore}
+ }
+ # These are tick marks
+
+ set img src=$options(-images)/$options(-gif)
+ append result "<tr>"
+ foreach t [lsort -integer [array names histogram]] {
+ if {(($t % $skip) == 0)} {
+ append result "<td valign=bottom><img $img height=3 \
+ width=1></td>\n"
+ } else {
+ append result "<td valign=bottom></td>"
+ }
+ }
+ append result </tr>
+
+ set lastLabel ""
+ append result "<tr>"
+ foreach t [lsort -integer [array names histogram]] {
+
+ # Label each bucket with its time
+
+ set label [clock format $time -format $format]
+ if {(($t % $skip) == 0) && ($label != $lastLabel)} {
+ set color [lindex $colors $colori]
+ set bg [lindex $bgcolors $colori]
+ set colori [expr {($colori+1) % 2}]
+ append result "<td colspan=$skip><font size=1 color=$color>$label</font></td>"
+ set lastLabel $label
+ }
+ if {$t == $curIndex} {
+ incr time $wrapDeltaT
+ } else {
+ incr time $deltaT
+ }
+ }
+ append result </tr>\n
+ }
+ append result "</table>"
+ if {$underflow > 0} {
+ append result "<br>Skipped $underflow samples <\
+ [expr {$options(-min) * $counter(bucketsize)}]\n"
+ }
+ if {$overflow > 0} {
+ append result "<br>Skipped $overflow samples >\
+ [expr {$options(-max) * $counter(bucketsize)}]\n"
+ }
+ return $result
+}
+
+# ::counter::start --
+#
+# Start an interval timer. This should be pre-declared with
+# type either -hist, -hist2x, or -hist20x
+#
+# Arguments:
+# tag The counter identifier.
+# instance There may be multiple intervals outstanding
+# at any time. This serves to distinquish them.
+#
+# Results:
+# None
+#
+# Side Effects:
+# Records the starting time for the instance of this interval.
+
+proc ::counter::start {tag instance} {
+ upvar #0 counter::Time-$tag time
+ # clock clicks can return negative values if the sign bit is set
+ # Here we turn it into a 31-bit counter because we only want
+ # relative differences
+ set msec [expr {[clock clicks -milliseconds] & 0x7FFFFFFF}]
+ set time($instance) [list $msec [clock seconds]]
+}
+
+# ::counter::stop --
+#
+# Record an interval timer.
+#
+# Arguments:
+# tag The counter identifier.
+# instance There may be multiple intervals outstanding
+# at any time. This serves to distinquish them.
+# func An optional function used to massage the time
+# stamp before putting into the histogram.
+#
+# Results:
+# None
+#
+# Side Effects:
+# Computes the current interval and adds it to the histogram.
+
+proc ::counter::stop {tag instance {func ::counter::Identity}} {
+ upvar #0 counter::Time-$tag time
+
+ if {![info exists time($instance)]} {
+ # Extra call. Ignore so we can debug error cases.
+ return
+ }
+ set msec [expr {[clock clicks -milliseconds] & 0x7FFFFFFF}]
+ set now [list $msec [clock seconds]]
+ set delMicros [expr {[lindex $now 0] - [lindex $time($instance) 0]}]
+ if {$delMicros < 0} {
+ # Microsecond counter wrapped.
+ set delMicros [expr {0x7FFFFFFF - [lindex $time($instance) 0] +
+ [lindex $now 0]}]
+ }
+ set delSecond [expr {[lindex $now 1] - [lindex $time($instance) 1]}]
+ unset time($instance)
+
+ # It is quite possible that the millisecond counter is much
+ # larger than 1000, so we just use it unless our microsecond
+ # calculation is screwed up.
+
+ if {$delMicros >= 0} {
+ counter::count $tag [$func [expr {$delMicros / 1000.0}]]
+ } else {
+ counter::count $tag [$func $delSecond]
+ }
+}
+
+# ::counter::Identity --
+#
+# Return its argument. This is used as the default function
+# to apply to an interval timer.
+#
+# Arguments:
+# x Some value.
+#
+# Results:
+# $x
+#
+# Side Effects:
+# None
+
+
+proc ::counter::Identity {x} {
+ return $x
+}
+
+package provide counter 2.0.4
diff --git a/tcllib/modules/counter/counter.test b/tcllib/modules/counter/counter.test
new file mode 100644
index 0000000..0e3b26b
--- /dev/null
+++ b/tcllib/modules/counter/counter.test
@@ -0,0 +1,235 @@
+# -*- tcl -*-
+# Tests for the counter module.
+#
+# This file contains a collection of tests for a module in the
+# Standard Tcl Library. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: counter.test,v 1.13 2006/10/09 21:41:40 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal counter.tcl counter
+}
+
+# -------------------------------------------------------------------------
+
+proc Stamp {tag} {
+ puts stderr "[clock format [clock seconds]] [clock clicks -milliseconds] $tag"
+}
+
+# -------------------------------------------------------------------------
+
+test counter-1.1 {counter::init} {
+ catch {counter::init} err
+} {1}
+
+if 0 {
+ set x 0
+ puts "incr scaler [time {incr x} 100]"
+
+ set a(x) 0
+ puts "incr array [time {incr a(x)} 100]"
+
+ set a(x) 0
+ set a(n) 0
+ puts "rawcount [time {
+ set a(x) [expr {$a(x) + 2.4}]
+ incr a(n)
+} 100]"
+}
+
+test counter-simple {counter::count} {
+ counter::init simple
+ counter::count simple
+ counter::count simple
+ counter::count simple
+ counter::get simple
+} {3}
+#puts "simple [time {counter::count simple} 100]"
+
+test counter-avg-1.0 {counter::count} {
+ counter::init avg
+ counter::count avg 2.2
+ counter::count avg 3.3
+ counter::count avg 9.8
+ format %3.1f [counter::get avg -avg]
+} {5.1}
+
+test counter-avg-1.1 {counter::count} {
+ counter::init avg
+ counter::get avg -avg
+} {0}
+
+test counter-lastn-1.0 {averge over lastn} {
+ counter::init lastn -lastn 4
+ counter::count lastn 2.2
+ counter::count lastn 4.6
+ counter::get lastn -avgn
+} {3.4}
+
+test counter-lastn-1.1 {averge over lastn} {
+ counter::init lastn -lastn 4
+ counter::count lastn 2.2
+ counter::count lastn 3.3
+ counter::count lastn 8.6
+ counter::count lastn 4.1
+ counter::count lastn 6.9
+ counter::count lastn 0.4
+ counter::get lastn -avgn
+} {5.0}
+#puts "lastn [time {counter::count lastn 2.4} 100]"
+
+test counter-lastn-1.2 {lifetime average} {
+ counter::init lastn -lastn 4
+ counter::count lastn 2.2
+ counter::count lastn 3.3
+ counter::count lastn 8.6
+ counter::count lastn 4.1
+ counter::count lastn 6.9
+ counter::count lastn 0.4
+ counter::get lastn -avg
+} {4.25}
+#puts "lastn [time {counter::count lastn 2.4} 100]"
+
+test counter-hist-1.0 {basic histogram} {
+ counter::init hist -hist 10
+ counter::count hist 2.2
+ counter::count hist 18.6
+ counter::count hist 14.1
+ counter::count hist 26.9
+ counter::count hist 20.4
+ counter::count hist 23.3
+ counter::count hist 53.3
+ counter::get hist -hist
+} {0 1 1 2 2 3 5 1}
+test counter-hist-1.1 {histogram average} {
+ counter::init hist -hist 10
+ counter::count hist 2.2
+ counter::count hist 18.6
+ counter::count hist 14.1
+ counter::count hist 26.9
+ counter::count hist 20.4
+ counter::count hist 23.3
+ counter::count hist 53.3
+ format %13.10f [counter::get hist -avg]
+} {22.6857142857}
+#puts "hist [time {counter::count hist 2.4} 100]"
+
+test counter-hist2x {counter::count} {
+ counter::init hist -hist2x 10
+ counter::count hist 8
+ counter::count hist 18
+ counter::count hist 28
+ counter::count hist 38
+ counter::count hist 48
+ counter::count hist 58
+ counter::count hist 68
+ counter::count hist 78
+ counter::count hist 178
+ counter::count hist 478
+ counter::get hist -hist
+} {0 1 1 1 2 2 3 4 5 1 6 1}
+#puts "hist2x [time {counter::count hist 50} 100]"
+
+test counter-hist10x {counter::count} {
+ counter::init hist -hist10x 10
+ counter::count hist 8
+ counter::count hist 18
+ counter::count hist 28
+ counter::count hist 38
+ counter::count hist 48
+ counter::count hist 58
+ counter::count hist 68
+ counter::count hist 78
+ counter::count hist 178
+ counter::count hist 478
+ counter::count hist 1478
+ counter::count hist 1478000
+ counter::get hist -hist
+} {0 1 1 7 2 2 3 1 6 1}
+
+test counter-histlog {counter::count} {
+ counter::init histlog -histlog 1
+ counter::count histlog 0.1
+ counter::count histlog 0.5
+ counter::count histlog 0.9
+ counter::count histlog 1.0
+ counter::count histlog 2
+ counter::count histlog 3
+ counter::count histlog 5
+ counter::count histlog 10
+ counter::count histlog 30
+ counter::count histlog 50
+ counter::count histlog 100
+ counter::count histlog 300
+ counter::count histlog 500
+ counter::count histlog 1000
+ counter::get histlog -hist
+} {-2 1 0 4 1 2 2 1 3 2 4 1 5 1 6 2}
+
+test counter-timehist {counter::count} {load-dependent} {
+ counter::init hits -timehist 4
+ catch {#puts stderr "Pausing during timehist tests"}
+ counter::count hits 2
+ # We need to reach in and find out what bucket was used
+ array set info [counter::get hits -all]
+ set min0 $info(lastMinute)
+ after [expr 4000]
+ counter::count hits 4
+ after [expr 4000]
+ counter::count hits 8
+ set result [list]
+ foreach {n v} [counter::get hits -hist] {
+ if {$v > 0} {
+ lappend result [expr {$n - $min0}] $v
+ }
+ }
+
+ #puts "timehist [time {counter::count hits} 100]"
+
+ set result
+} {0 2 1 4 2 8}
+
+
+test counter-countNames {counter::names} {
+ counter::init simple
+ counter::init avg
+ counter::init lastn -lastn 4
+ counter::init hist -hist 10
+ counter::init histlog -histlog 1
+ counter::init hits -timehist 4
+ lsort [counter::names]
+} {avg hist histlog hits lastn simple}
+
+test counter-countExists {counter::exists} {
+ counter::init simple
+ counter::init lastn -lastn 4
+ unset counter::T-lastn
+ list [counter::exists simple] [counter::exists lastn]
+} {1 0}
+
+test counter-countReset {counter::reset} {
+ counter::init simple
+ counter::count simple 1
+ counter::count simple 1
+ counter::count simple 1
+ counter::reset simple
+ counter::get simple
+} {0}
+
+
+testsuiteCleanup
diff --git a/tcllib/modules/counter/pkgIndex.tcl b/tcllib/modules/counter/pkgIndex.tcl
new file mode 100644
index 0000000..7ab2eb2
--- /dev/null
+++ b/tcllib/modules/counter/pkgIndex.tcl
@@ -0,0 +1,12 @@
+# 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.2]} {return}
+package ifneeded counter 2.0.4 [list source [file join $dir counter.tcl]]
diff --git a/tcllib/modules/crc/ChangeLog b/tcllib/modules/crc/ChangeLog
new file mode 100644
index 0000000..7599b36
--- /dev/null
+++ b/tcllib/modules/crc/ChangeLog
@@ -0,0 +1,321 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2012-01-23 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc16: bug #3477684: handle data with leading hyphen.
+
+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 ========================
+ *
+
+2009-05-07 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * sum.tcl: Fixed poor idiom setting interp result.
+
+2009-05-06 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc32.tcl: Remove unecessary read-type from Trf implementation
+ and tidied the critcl code a little. Bump to 1.3.1.
+
+2009-04-21 Andreas Kupries <andreask@activestate.com>
+
+ * cksum.tcl (::crc::CksumFinal): Added the missing 'unset state'
+ * cksum.man: command which caused the memory leak reported by Phil
+ * pkgIndex.tcl: Dietz <pedietz@users.sourceforge.net> as
+ [Bug 2686560]. Bumped version to 1.1.3.
+
+2009-03-04 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc32.man: Add note on feeding crc32 values in as -seed.
+ * crc32.test: Tests to ensure -seed usage is as expected.
+
+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 ========================
+ *
+
+2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cksum.pcx: New files. Syntax definitions for the public
+ * crc16.pcx: commands of the various crc packages.
+ * crc32.pcx:
+ * sum.pcx:
+
+2008-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * crc16.man: Marked name of crc32 up as package.
+
+2008-04-08 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc16.man: document the xmodem command (bug #1895277)
+
+2008-03-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cksum.tcl (::crc::cksum): Fixed handling of options -chunksize
+ * cksum.man: and -channel. Bumped version of cksum to 1.1.2.
+ * pkgIndex.tcl
+
+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>
+
+ * sum.man: Fixed all warnings due to use of now deprecated
+ * cksum.man: commands. Added a section about how to give feedback.
+ * crc16.man:
+ * crc32.man:
+
+2006-11-04 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crcc.tcl: Silence critcl warning.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * cksum.tcl: Bumped version to 1.1.1
+ * cksum.man:
+ * pkgIndex.tcl:
+
+2006-06-29 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * cksum.tcl: fixed typo koin->join
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cksum.test: More boilerplate simplified via use of test support.
+ * crc16.test:
+ * crc32.test:
+ * crc32bugs.test:
+ * sum.test:
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cksum.test: Hooked into the new common test support code.
+ * crc16.test:
+ * crc32.test:
+ * crc32bugs.test:
+ * sum.test:
+
+2005-10-24 Andreas Kupries <andreask@activestate.com>
+
+ * cksum.bench: New files. Basic benchmark tests
+ * crc16.bench: of the crc and derived commands.
+ * crc32.bench:
+ * sum.bench:
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-08-26 Andreas Kupries <andreask@activestate.com>
+
+ * crc16.tcl: Accepted Don Porter's patch attached to [Tcllib SF
+ * crc32.tcl: Bug 1274120], fixing the creative-writing problem for
+ variable v and restricting the value to 32bit ints. Additionally
+ added an [unset v] after the initialization, as the variable is
+ not needed beyond that part of the code.
+
+2005-08-25 Andreas Kupries <andreask@activestate.com>
+
+ * crc32.tcl (::crc::Crc32Final): Restrict result of Trf to 32bit
+ range, or the [format] at the end of crc32 will blow this up
+ into a 64bit number. This is an additional fix for [Tcllib SF
+ Bug 1042420].
+
+2005-03-12 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * cksum.tcl: Refactored to use a context for better support of
+ * cksum.man: summing data in chunks. Updated man page and
+ * cksum.test: tests. Set version to 1.1.0
+
+ * crc32.tcl: Refactored the package to use a context structure
+ * crc32.man: as done for the hash modules. This makes it easier
+ * crc32.test: to work which chunks and event systems. We now
+ * crc32bugs.test: can support Trf for chunking too and have properly
+ hooked up the critcl code. Tests now test all
+ available implementations.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * crc32.tcl: Updated version number to sync with 1.6.1
+ * crc32.man: release.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * crc32.tcl: Rel. engineering. Updated version number
+ * crc32.man: of crc32 to reflect its changes, to 1.1.1.
+ * pkgIndex.tcl:
+
+2004-04-01 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc32.tcl: Cope with data begining with hyphen when using
+ Trf (SF bug #914278)
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-05-27 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc16.tcl: Added XMODEM CRC algorithm - as used in the
+ XMODEM-CRC protocol. (Simple XMODEM uses a SysV type checksum).
+ Also added a -channel option to the crc command.
+
+2003-05-09 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crcc.tcl: Added placeholder to get a module library for all the
+ critcl code segments from the crc module
+ * crc32.tcl: Added -channel option
+ * crc32.test:
+ * crc32bugs.test: Tidied up the tests
+ * sum.tcl: Refactored the code to permit chunking and reading from
+ a channel. Added critcl-dependent C code implementations.
+ * sum.test: Added new tests and generally tidied up.
+ * sum.man: Added new items to the documentation.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-02 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc32.test: Fix for bug #709375 - test failures for bigEndian
+ systems when using Trf crc-zlib.
+ * crc32bugs.test: Additional test file used to isolate byte
+ ordering problems.
+
+2003-02-11 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc32.man, cksum.man, crc16.man, crc32.man: Added the new
+ copyright markup to the doctools pages.
+ * crc32.tcl: Enforce 32 bit calculations.
+
+2003-02-02 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc16.tcl: Fixed a bug in the option handling error info.
+
+2003-01-25 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc32.tcl:
+ * cksum.tcl:
+ * crc16.tcl:
+ * sum.tcl: Added tcl package requirement for 8.2+ and hiked
+ versions to 1.0.1
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * crc32.man: More semantic markup, less visual one.
+ * cksum.man:
+ * sum.man:
+
+2003-01-07 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc32.test: Fixed another 8.3 - 8.4 wide integer problem.
+
+2003-01-06 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc16.tcl: Fix for bug #620612: the crc16 CRC calculation failed
+ for 32 bit CRC widths for tcl < 8.4. Masked off high bits after shift
+
+2003-01-03 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * cksum.tcl: Enabled processing in chunks to reduce memory
+ consumption.
+
+2002-09-26 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc32.tcl: Fix to SF bug #579026: implementing file processing
+ in small chunks to reduce memory usage.
+
+2002-01-23 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc16.tcl, crc16.test, crc16.man: Added CRC16 package
+
+2002-01-23 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc32.test, sum.test, cksum.test: Fixed SF bug #507242: failing
+ tests when running 'make test'
+
+2002-01-17 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc32.n: formatting fixes
+ * sum.n: added new manual page for package sum
+
+2002-01-16 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc32.tcl: added -seed and -implementation options.
+ * crc32.n: updated for the -seed and -impl options
+ * crc32.test: added tests for the -seed and -impl options.
+
+2002-01-15 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * sum.tcl: initial version of crc::sum command
+ * sum.test: initial version of crc::sum command tests
+ * cksum.tcl: intial version of crc::cksum command
+ * cksum.n: initial version of crc::cksum manual page
+ * cksum.test: initial version of crc::cksum command tests
+ * crc32.tcl: compatability with sum and cksum commands
+ * crc32.test: compatability with sum and cksum tests
+ * crc32.n: compatability with sum and cksum manuals
+
+2002-01-11 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc32.tcl: implemented usage of Trf crc-zlib if available.
+
+2002-01-09 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * crc32.tcl: initial version modified from the Wiki source.
+ * crc32.n: initial version of man page
+ * crc32.test: initial version of crc32 tests.
diff --git a/tcllib/modules/crc/cksum.bench b/tcllib/modules/crc/cksum.bench
new file mode 100644
index 0000000..9a4c73b
--- /dev/null
+++ b/tcllib/modules/crc/cksum.bench
@@ -0,0 +1,38 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'crc32' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+set moddir [file dirname [file dirname [info script]]]
+lappend auto_path $moddir
+
+package forget cksum
+catch {namespace delete ::crc}
+source [file join [file dirname [info script]] cksum.tcl]
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+foreach n {1 10 100 1000 10000} {
+ bench -desc "CKSUM $n" -pre {
+ set str [string repeat " " $n]
+ } -body {
+ crc::cksum $str
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/crc/cksum.man b/tcllib/modules/crc/cksum.man
new file mode 100644
index 0000000..fd55a04
--- /dev/null
+++ b/tcllib/modules/crc/cksum.man
@@ -0,0 +1,131 @@
+[vset CKSUM_VERSION 1.1.4]
+[manpage_begin cksum n [vset CKSUM_VERSION]]
+[see_also crc32(n)]
+[see_also sum(n)]
+[keywords checksum]
+[keywords cksum]
+[keywords crc]
+[keywords crc32]
+[keywords {cyclic redundancy check}]
+[keywords {data integrity}]
+[keywords security]
+[copyright {2002, Pat Thoyts}]
+[moddesc {Cyclic Redundancy Checks}]
+[titledesc {Calculate a cksum(1) compatible checksum}]
+[category {Hashes, checksums, and encryption}]
+[require Tcl 8.2]
+[require cksum [opt [vset CKSUM_VERSION]]]
+[description]
+[para]
+
+This package provides a Tcl implementation of the cksum(1) algorithm
+based upon information provided at in the GNU implementation of this
+program as part of the GNU Textutils 2.0 package.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd "::crc::cksum"] \
+ [opt [arg "-format format"]] \
+ [opt [arg "-chunksize size"]] \
+ [lb] [arg "-channel chan"] | \
+ [arg "-filename file"] | [arg "string" ] [rb]]
+
+The command takes string data or a channel or file name and returns a
+checksum value calculated using the [syscmd cksum(1)] algorithm. The
+result is formatted using the [arg format](n) specifier provided or as
+an unsigned integer (%u) by default.
+
+[list_end]
+
+[section OPTIONS]
+
+[list_begin definitions]
+
+[def "-channel [arg name]"]
+
+Return a checksum for the data read from a channel. The command will
+read data from the channel until the [cmd "eof"] is true. If you need
+to be able to process events during this calculation see the
+[sectref {PROGRAMMING INTERFACE}] section
+
+[def "-filename [arg name]"]
+
+This is a convenience option that opens the specified file, sets the
+encoding to binary and then acts as if the [arg -channel] option had
+been used. The file is closed on completion.
+
+[def "-format [arg string]"]
+
+Return the checksum using an alternative format template.
+
+[list_end]
+
+[section {PROGRAMMING INTERFACE}]
+
+The cksum package implements the checksum using a context variable to
+which additional data can be added at any time. This is expecially
+useful in an event based environment such as a Tk application or a web
+server package. Data to be checksummed may be handled incrementally
+during a [cmd fileevent] handler in discrete chunks. This can improve
+the interactive nature of a GUI application and can help to avoid
+excessive memory consumption.
+
+[list_begin definitions]
+
+[call [cmd "::crc::CksumInit"]]
+
+Begins a new cksum context. Returns a token ID that must be used for the
+remaining functions. An optional seed may be specified if required.
+
+[call [cmd "::crc::CksumUpdate"] [arg "token"] [arg "data"]]
+
+Add data to the checksum identified by token. Calling
+[emph {CksumUpdate $token "abcd"}] is equivalent to calling
+[emph {CksumUpdate $token "ab"}] followed by
+[emph {CksumUpdate $token "cb"}]. See [sectref {EXAMPLES}].
+
+[call [cmd "::crc::CksumFinal"] [arg "token"]]
+
+Returns the checksum value and releases any resources held by this
+token. Once this command completes the token will be invalid. The
+result is a 32 bit integer value.
+
+[list_end]
+
+[section EXAMPLES]
+
+[para]
+[example {
+% crc::cksum "Hello, World!"
+2609532967
+}]
+
+[para]
+[example {
+% crc::cksum -format 0x%X "Hello, World!"
+0x9B8A5027
+}]
+
+[para]
+[example {
+% crc::cksum -file cksum.tcl
+1828321145
+}]
+
+[para]
+[example {
+% set tok [crc::CksumInit]
+% crc::CksumUpdate $tok "Hello, "
+% crc::CksumUpdate $tok "World!"
+% crc::CksumFinal $tok
+2609532967
+}]
+
+[section AUTHORS]
+Pat Thoyts
+
+[vset CATEGORY crc]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/crc/cksum.pcx b/tcllib/modules/crc/cksum.pcx
new file mode 100644
index 0000000..a93f83c
--- /dev/null
+++ b/tcllib/modules/crc/cksum.pcx
@@ -0,0 +1,37 @@
+# -*- tcl -*- cksum.pcx
+# Syntax of the commands provided by package cksum.
+
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register cksum
+pcx::tcldep 1.1.1 needs tcl 8.2
+
+namespace eval ::cksum {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.1.1 std ::crc::cksum \
+ {checkConstrained {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ {-channel {checkSetConstraint fn checkChannelID}}
+ {-chunksize checkInt}
+ {-filename {checkSetConstraint fn checkFileName}}
+ {-format checkWord}
+ {-command {checkProcCall 0}}
+ {-timeout checkWholeNum}
+ --
+ } {checkConstraint {
+ {fn {checkSimpleArgs 0 0 {}}}
+ {!fn {checkSimpleArgs 1 1 checkWord}}
+ } {}}}
+ }}}
+
+# Initialization via pcx::init.
+# Use a ::cksum::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/crc/cksum.tcl b/tcllib/modules/crc/cksum.tcl
new file mode 100644
index 0000000..6ff4e51
--- /dev/null
+++ b/tcllib/modules/crc/cksum.tcl
@@ -0,0 +1,200 @@
+# cksum.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Provides a Tcl only implementation of the unix cksum(1) command. This is
+# similar to the sum(1) command but the algorithm is better defined and
+# standardized across multiple platforms by POSIX 1003.2/D11.2
+#
+# This command has been verified against the cksum command from the GNU
+# textutils package version 2.0
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.2; # tcl minimum version
+
+namespace eval ::crc {
+ namespace export cksum
+
+ variable cksum_tbl [list 0x0 \
+ 0x04C11DB7 0x09823B6E 0x0D4326D9 0x130476DC 0x17C56B6B \
+ 0x1A864DB2 0x1E475005 0x2608EDB8 0x22C9F00F 0x2F8AD6D6 \
+ 0x2B4BCB61 0x350C9B64 0x31CD86D3 0x3C8EA00A 0x384FBDBD \
+ 0x4C11DB70 0x48D0C6C7 0x4593E01E 0x4152FDA9 0x5F15ADAC \
+ 0x5BD4B01B 0x569796C2 0x52568B75 0x6A1936C8 0x6ED82B7F \
+ 0x639B0DA6 0x675A1011 0x791D4014 0x7DDC5DA3 0x709F7B7A \
+ 0x745E66CD 0x9823B6E0 0x9CE2AB57 0x91A18D8E 0x95609039 \
+ 0x8B27C03C 0x8FE6DD8B 0x82A5FB52 0x8664E6E5 0xBE2B5B58 \
+ 0xBAEA46EF 0xB7A96036 0xB3687D81 0xAD2F2D84 0xA9EE3033 \
+ 0xA4AD16EA 0xA06C0B5D 0xD4326D90 0xD0F37027 0xDDB056FE \
+ 0xD9714B49 0xC7361B4C 0xC3F706FB 0xCEB42022 0xCA753D95 \
+ 0xF23A8028 0xF6FB9D9F 0xFBB8BB46 0xFF79A6F1 0xE13EF6F4 \
+ 0xE5FFEB43 0xE8BCCD9A 0xEC7DD02D 0x34867077 0x30476DC0 \
+ 0x3D044B19 0x39C556AE 0x278206AB 0x23431B1C 0x2E003DC5 \
+ 0x2AC12072 0x128E9DCF 0x164F8078 0x1B0CA6A1 0x1FCDBB16 \
+ 0x018AEB13 0x054BF6A4 0x0808D07D 0x0CC9CDCA 0x7897AB07 \
+ 0x7C56B6B0 0x71159069 0x75D48DDE 0x6B93DDDB 0x6F52C06C \
+ 0x6211E6B5 0x66D0FB02 0x5E9F46BF 0x5A5E5B08 0x571D7DD1 \
+ 0x53DC6066 0x4D9B3063 0x495A2DD4 0x44190B0D 0x40D816BA \
+ 0xACA5C697 0xA864DB20 0xA527FDF9 0xA1E6E04E 0xBFA1B04B \
+ 0xBB60ADFC 0xB6238B25 0xB2E29692 0x8AAD2B2F 0x8E6C3698 \
+ 0x832F1041 0x87EE0DF6 0x99A95DF3 0x9D684044 0x902B669D \
+ 0x94EA7B2A 0xE0B41DE7 0xE4750050 0xE9362689 0xEDF73B3E \
+ 0xF3B06B3B 0xF771768C 0xFA325055 0xFEF34DE2 0xC6BCF05F \
+ 0xC27DEDE8 0xCF3ECB31 0xCBFFD686 0xD5B88683 0xD1799B34 \
+ 0xDC3ABDED 0xD8FBA05A 0x690CE0EE 0x6DCDFD59 0x608EDB80 \
+ 0x644FC637 0x7A089632 0x7EC98B85 0x738AAD5C 0x774BB0EB \
+ 0x4F040D56 0x4BC510E1 0x46863638 0x42472B8F 0x5C007B8A \
+ 0x58C1663D 0x558240E4 0x51435D53 0x251D3B9E 0x21DC2629 \
+ 0x2C9F00F0 0x285E1D47 0x36194D42 0x32D850F5 0x3F9B762C \
+ 0x3B5A6B9B 0x0315D626 0x07D4CB91 0x0A97ED48 0x0E56F0FF \
+ 0x1011A0FA 0x14D0BD4D 0x19939B94 0x1D528623 0xF12F560E \
+ 0xF5EE4BB9 0xF8AD6D60 0xFC6C70D7 0xE22B20D2 0xE6EA3D65 \
+ 0xEBA91BBC 0xEF68060B 0xD727BBB6 0xD3E6A601 0xDEA580D8 \
+ 0xDA649D6F 0xC423CD6A 0xC0E2D0DD 0xCDA1F604 0xC960EBB3 \
+ 0xBD3E8D7E 0xB9FF90C9 0xB4BCB610 0xB07DABA7 0xAE3AFBA2 \
+ 0xAAFBE615 0xA7B8C0CC 0xA379DD7B 0x9B3660C6 0x9FF77D71 \
+ 0x92B45BA8 0x9675461F 0x8832161A 0x8CF30BAD 0x81B02D74 \
+ 0x857130C3 0x5D8A9099 0x594B8D2E 0x5408ABF7 0x50C9B640 \
+ 0x4E8EE645 0x4A4FFBF2 0x470CDD2B 0x43CDC09C 0x7B827D21 \
+ 0x7F436096 0x7200464F 0x76C15BF8 0x68860BFD 0x6C47164A \
+ 0x61043093 0x65C52D24 0x119B4BE9 0x155A565E 0x18197087 \
+ 0x1CD86D30 0x029F3D35 0x065E2082 0x0B1D065B 0x0FDC1BEC \
+ 0x3793A651 0x3352BBE6 0x3E119D3F 0x3AD08088 0x2497D08D \
+ 0x2056CD3A 0x2D15EBE3 0x29D4F654 0xC5A92679 0xC1683BCE \
+ 0xCC2B1D17 0xC8EA00A0 0xD6AD50A5 0xD26C4D12 0xDF2F6BCB \
+ 0xDBEE767C 0xE3A1CBC1 0xE760D676 0xEA23F0AF 0xEEE2ED18 \
+ 0xF0A5BD1D 0xF464A0AA 0xF9278673 0xFDE69BC4 0x89B8FD09 \
+ 0x8D79E0BE 0x803AC667 0x84FBDBD0 0x9ABC8BD5 0x9E7D9662 \
+ 0x933EB0BB 0x97FFAD0C 0xAFB010B1 0xAB710D06 0xA6322BDF \
+ 0xA2F33668 0xBCB4666D 0xB8757BDA 0xB5365D03 0xB1F740B4 ]
+
+ variable uid
+ if {![info exists uid]} {set uid 0}
+}
+
+# crc::CksumInit --
+#
+# Create and initialize a cksum context. This is cleaned up when we
+# call CksumFinal to obtain the result.
+#
+proc ::crc::CksumInit {} {
+ variable uid
+ set token [namespace current]::[incr uid]
+ upvar #0 $token state
+ array set state {t 0 l 0}
+ return $token
+}
+
+proc ::crc::CksumUpdate {token data} {
+ variable cksum_tbl
+ upvar #0 $token state
+ set t $state(t)
+ binary scan $data c* r
+ foreach {n} $r {
+ set index [expr { (($t >> 24) ^ ($n & 0xFF)) & 0xFF }]
+ # Since the introduction of built-in bigInt support with Tcl
+ # 8.5, bit-shifting $t to the left no longer overflows,
+ # keeping it 32 bits long. The value grows bigger and bigger
+ # instead - a severe hit on performance. For this reason we
+ # do a bitwise AND against 0xFFFFFFFF at each step to keep the
+ # value within limits.
+ set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}]
+ incr state(l)
+ }
+ set state(t) $t
+ return
+}
+
+proc ::crc::CksumFinal {token} {
+ variable cksum_tbl
+ upvar #0 $token state
+ set t $state(t)
+ for {set i $state(l)} {$i > 0} {set i [expr {$i>>8}]} {
+ set index [expr {(($t >> 24) ^ $i) & 0xFF}]
+ set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}]
+ }
+ unset state
+ return [expr {~$t & 0xFFFFFFFF}]
+}
+
+# crc::Pop --
+#
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::crc::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# Description:
+# Provide a Tcl equivalent of the unix cksum(1) command.
+# Options:
+# -filename name - return a checksum for the specified file.
+# -format string - return the checksum using this format string.
+# -chunksize size - set the chunking read size
+#
+proc ::crc::cksum {args} {
+ array set opts [list -filename {} -channel {} -chunksize 4096 \
+ -format %u -command {}]
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -file* { set opts(-filename) [Pop args 1] }
+ -chan* { set opts(-channel) [Pop args 1] }
+ -chunk* { set opts(-chunksize) [Pop args 1] }
+ -for* { set opts(-format) [Pop args 1] }
+ -command { set opts(-command) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0} { Pop args ; break }
+ set err [join [lsort [array names opts -*]] ", "]
+ return -code error "bad option \"option\": must be $err"
+ }
+ }
+ Pop args
+ }
+
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be\
+ cksum ?-format string?\
+ -channel chan | -filename file | string"
+ }
+ set tok [CksumInit]
+ CksumUpdate $tok [lindex $args 0]
+ set r [CksumFinal $tok]
+
+ } else {
+
+ set tok [CksumInit]
+ while {![eof $opts(-channel)]} {
+ CksumUpdate $tok [read $opts(-channel) $opts(-chunksize)]
+ }
+ set r [CksumFinal $tok]
+
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+ }
+
+ return [format $opts(-format) $r]
+}
+
+# -------------------------------------------------------------------------
+
+package provide cksum 1.1.4
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/crc/cksum.test b/tcllib/modules/crc/cksum.test
new file mode 100644
index 0000000..a0cf03a
--- /dev/null
+++ b/tcllib/modules/crc/cksum.test
@@ -0,0 +1,111 @@
+# cksum.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Tests for the Tcllib cksum command
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: cksum.test,v 1.7 2006/10/09 21:41:40 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal cksum.tcl cksum ::crc
+}
+
+# -------------------------------------------------------------------------
+
+test cksum-1.0 {cksum with no parameters } {
+ catch {::crc::cksum} result
+ set result
+} {wrong # args: should be cksum ?-format string? -channel chan | -filename file | string}
+
+# -------------------------------------------------------------------------
+
+foreach {n msg expected} {
+ 1 ""
+ "4294967295"
+ 2 "a"
+ "1220704766"
+ 3 "abc"
+ "1219131554"
+ 4 "message digest"
+ "3644109718"
+ 5 "abcdefghijklmnopqrstuvwxyz"
+ "2713270184"
+ 6 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+ "81918263"
+ 7 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "1939911592"
+ 8 "\uFFFE\u0000\u0001\u0002"
+ "893385333"
+} {
+ test cksum-2.$n {cksum and unsigned integer} {
+ ::crc::cksum $msg
+ } $expected
+}
+
+# -------------------------------------------------------------------------
+
+foreach {n msg expected} {
+ 1 ""
+ "0xFFFFFFFF"
+ 2 "a"
+ "0x48C279FE"
+ 3 "abc"
+ "0x48AA78A2"
+ 4 "message digest"
+ "0xD934B396"
+ 5 "abcdefghijklmnopqrstuvwxyz"
+ "0xA1B937A8"
+ 6 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+ "0x4E1F937"
+ 7 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "0x73A0B3A8"
+ 8 "\uFFFE\u0000\u0001\u0002"
+ "0x353FFA75"
+} {
+ test cksum-3.$n {cksum as hexadecimal string} {
+ ::crc::cksum -format 0x%X $msg
+ } $expected
+}
+
+# -------------------------------------------------------------------------
+
+set crc::testfile [info script]
+
+proc crc::loaddata {filename} {
+ set f [open $filename r]
+ fconfigure $f -translation binary
+ set data [read $f]
+ close $f
+ return $data
+}
+
+test cksum-4.0 {cksum file option} {
+ set r1 [crc::cksum -file $crc::testfile]
+ set r2 [crc::cksum [crc::loaddata $crc::testfile]]
+ if {$r1 != $r2} {
+ set r "differing results: $r1 != $r2"
+ } else {
+ set r ok
+ }
+} {ok}
+
+# -------------------------------------------------------------------------
+
+catch {unset crc::testfile}
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/crc/crc16.bench b/tcllib/modules/crc/crc16.bench
new file mode 100644
index 0000000..8365b0f
--- /dev/null
+++ b/tcllib/modules/crc/crc16.bench
@@ -0,0 +1,38 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'crc16' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+set moddir [file dirname [file dirname [info script]]]
+lappend auto_path $moddir
+
+package forget crc16
+catch {namespace delete ::crc}
+source [file join [file dirname [info script]] crc16.tcl]
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+foreach n {1 10 100 1000 10000} {
+ bench -desc "CRC16 $n" -pre {
+ set str [string repeat " " $n]
+ } -body {
+ crc::crc16 $str
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/crc/crc16.man b/tcllib/modules/crc/crc16.man
new file mode 100644
index 0000000..b6bbce0
--- /dev/null
+++ b/tcllib/modules/crc/crc16.man
@@ -0,0 +1,142 @@
+[manpage_begin crc16 n 1.1.2]
+[see_also cksum(n)]
+[see_also crc32(n)]
+[see_also sum(n)]
+[keywords checksum]
+[keywords cksum]
+[keywords crc]
+[keywords crc16]
+[keywords crc32]
+[keywords {cyclic redundancy check}]
+[keywords {data integrity}]
+[keywords security]
+[copyright {2002, Pat Thoyts}]
+[moddesc {Cyclic Redundancy Checks}]
+[titledesc {Perform a 16bit Cyclic Redundancy Check}]
+[category {Hashes, checksums, and encryption}]
+[require Tcl 8.2]
+[require crc16 [opt 1.1.2]]
+[description]
+[para]
+
+This package provides a Tcl-only implementation of the CRC
+algorithms based upon information provided at
+http://www.microconsultants.com/tips/crc/crc.txt
+
+There are a number of permutations available for calculating CRC
+checksums and this package can handle all of them. Defaults are set up
+for the most common cases.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::crc::crc16] [opt "-format [arg format]"] \
+ [opt "-seed [arg value]"] [opt "-implementation [arg procname]"] [arg message]]
+[call [cmd ::crc::crc16] [opt "-format [arg format]"] \
+ [opt "-seed [arg value]"] [opt "-implementation [arg procname]"] "-filename [arg file]"]
+[call [cmd ::crc::crc-ccitt] [opt "-format [arg format]"] \
+ [opt "-seed [arg value]"] [opt "-implementation [arg procname]"] [arg message]]
+[call [cmd ::crc::crc-ccitt] [opt "-format [arg format]"] \
+ [opt "-seed [arg value]"] [opt "-implementation [arg procname]"] "-filename [arg file]"]
+[call [cmd ::crc::xmodem] [opt "-format [arg format]"] \
+ [opt "-seed [arg value]"] [opt "-implementation [arg procname]"] [arg message]]
+[call [cmd ::crc::xmodem] [opt "-format [arg format]"] \
+ [opt "-seed [arg value]"] [opt "-implementation [arg procname]"] "-filename [arg file]"]
+
+The command takes either string data or a file name and returns a checksum
+value calculated using the CRC algorithm. The command used sets up the
+CRC polynomial, initial value and bit ordering for the desired
+standard checksum calculation. The result is formatted
+using the [arg format](n) specifier provided or as an unsigned integer
+(%u) by default.
+
+[para]
+
+A number of common polynomials are in use with the CRC algorithm and
+the most commonly used of these are included in this package. For
+convenience each of these has a command alias in the crc namespace.
+
+[para]
+
+It is possible to implement the CRC-32 checksum using this crc16
+package as the implementation is sufficiently generic to extend to 32
+bit checksums. As an example this has been done already - however this
+is not the fastest method to implement this algorithm in Tcl and a
+separate [package crc32] package is available.
+
+[list_end]
+
+[section OPTIONS]
+
+[list_begin definitions]
+
+[def "-filename [arg name]"]
+
+Return a checksum for the file contents instead of for parameter data.
+
+[def "-format [arg string]"]
+
+Return the checksum using an alternative format template.
+
+[def "-seed [arg value]"]
+
+Select an alternative seed value for the CRC calculation. The default
+is 0 for the CRC16 calculation and 0xFFFF for the CCITT version.
+This can be useful for calculating the CRC for data
+structures without first converting the whole structure into a
+string. The CRC of the previous member can be used as the seed for
+calculating the CRC of the next member. It is also used for
+accumulating a checksum from fragments of a large message (or file)
+
+[def "-implementation [arg procname]"]
+
+This hook is provided to allow users to provide their own
+implementation (perhaps a C compiled extension). The
+procedure specfied is called with two parameters. The first is the
+data to be checksummed and the second is the seed value. An
+integer is expected as the result.
+[para]
+The package provides some implementations of standard CRC polynomials
+for the XMODEM, CCITT and the usual CRC-16 checksum. For convenience,
+additional commands have been provided that make use of these
+implementations.
+
+[def "--"]
+
+Terminate option processing.
+
+[list_end]
+
+[section EXAMPLES]
+
+[para]
+[example {
+% crc::crc16 "Hello, World!"
+64077
+}]
+
+[para]
+[example {
+% crc::crc-ccitt "Hello, World!"
+26586
+}]
+
+[para]
+[example {
+% crc::crc16 -format 0x%X "Hello, World!"
+0xFA4D
+}]
+
+[para]
+[example {
+% crc::crc16 -file crc16.tcl
+51675
+}]
+
+[section AUTHORS]
+Pat Thoyts
+
+[vset CATEGORY crc]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/crc/crc16.pcx b/tcllib/modules/crc/crc16.pcx
new file mode 100644
index 0000000..6006b39
--- /dev/null
+++ b/tcllib/modules/crc/crc16.pcx
@@ -0,0 +1,93 @@
+# -*- tcl -*- crc16.pcx
+# Syntax of the commands provided by package crc16.
+
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register crc16
+pcx::tcldep 1.1.1 needs tcl 8.2
+
+namespace eval ::crc16 {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.1.1 std ::crc::crc \
+ {checkConstrained {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ {-channel {checkSetConstraint fn checkChannelID}}
+ {-chunksize checkInt}
+ {-filename {checkSetConstraint fn checkFileName}}
+ {-format checkWord}
+ {-impl checkProcName}
+ {-seed checkWord}
+ --
+ } {checkConstraint {
+ {fn {checkSimpleArgs 0 0 {}}}
+ {!fn {checkSimpleArgs 1 1 checkWord}}
+ } {}}}
+ }}}
+pcx::check 1.1.1 std ::crc::crc-32 \
+ {checkConstrained {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ {-channel {checkSetConstraint fn checkChannelID}}
+ {-chunksize checkInt}
+ {-filename {checkSetConstraint fn checkFileName}}
+ {-format checkWord}
+ {-seed checkWord}
+ --
+ } {checkConstraint {
+ {fn {checkSimpleArgs 0 0 {}}}
+ {!fn {checkSimpleArgs 1 1 checkWord}}
+ } {}}}
+ }}}
+pcx::check 1.1.1 std ::crc::crc-ccitt \
+ {checkConstrained {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ {-channel {checkSetConstraint fn checkChannelID}}
+ {-chunksize checkInt}
+ {-filename {checkSetConstraint fn checkFileName}}
+ {-format checkWord}
+ {-seed checkWord}
+ --
+ } {checkConstraint {
+ {fn {checkSimpleArgs 0 0 {}}}
+ {!fn {checkSimpleArgs 1 1 checkWord}}
+ } {}}}
+ }}}
+pcx::check 1.1.1 std ::crc::crc16 \
+ {checkConstrained {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ {-channel {checkSetConstraint fn checkChannelID}}
+ {-chunksize checkInt}
+ {-filename {checkSetConstraint fn checkFileName}}
+ {-format checkWord}
+ {-seed checkWord}
+ --
+ } {checkConstraint {
+ {fn {checkSimpleArgs 0 0 {}}}
+ {!fn {checkSimpleArgs 1 1 checkWord}}
+ } {}}}
+ }}}
+pcx::check 1.1.1 std ::crc::xmodem \
+ {checkConstrained {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ {-channel {checkSetConstraint fn checkChannelID}}
+ {-chunksize checkInt}
+ {-filename {checkSetConstraint fn checkFileName}}
+ {-format checkWord}
+ {-seed checkWord}
+ --
+ } {checkConstraint {
+ {fn {checkSimpleArgs 0 0 {}}}
+ {!fn {checkSimpleArgs 1 1 checkWord}}
+ } {}}}
+ }}}
+
+# Initialization via pcx::init.
+# Use a ::crc16::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/crc/crc16.tcl b/tcllib/modules/crc/crc16.tcl
new file mode 100644
index 0000000..d89375e
--- /dev/null
+++ b/tcllib/modules/crc/crc16.tcl
@@ -0,0 +1,302 @@
+# crc16.tcl -- Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Cyclic Redundancy Check - this is a Tcl implementation of a general
+# table-driven CRC implementation. This code should be able to generate
+# the lookup table and implement the correct algorithm for most types
+# of CRC. CRC-16, CRC-32 and the CCITT version of CRC-16. [1][2][3]
+# Most transmission CRCs use the CCITT polynomial (including X.25, SDLC
+# and Kermit).
+#
+# [1] http://www.microconsultants.com/tips/crc/crc.txt for the reference
+# implementation
+# [2] http://www.embedded.com/internet/0001/0001connect.htm
+# for another good discussion of why things are the way they are.
+# [3] "Numerical Recipes in C", Press WH et al. Chapter 20.
+#
+# Checks: a crc for the string "123456789" should give:
+# CRC16: 0xBB3D
+# CRC-CCITT: 0x29B1
+# XMODEM: 0x31C3
+# CRC-32: 0xCBF43926
+#
+# eg: crc::crc16 "123456789"
+# crc::crc-ccitt "123456789"
+# or crc::crc16 -file tclsh.exe
+#
+# Note:
+# The CCITT CRC can very easily be checked for the accuracy of transmission
+# as the CRC of the message plus the CRC values will be 0. That is:
+# % set msg {123456789]
+# % set crc [crc::crc-ccitt $msg]
+# % crc::crc-ccitt $msg[binary format S $crc]
+# 0
+#
+# The same is true of other CRCs but some operate in reverse bit order:
+# % crc::crc16 $msg[binary format s [crc::crc16 $msg]]
+# 0
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+# @mdgen EXCLUDE: crcc.tcl
+
+package require Tcl 8.2; # tcl minimum version
+
+namespace eval ::crc {
+ namespace export crc16 crc-ccitt crc-32
+
+ # Standard CRC generator polynomials.
+ variable polynomial
+ set polynomial(crc16) [expr {(1<<16) | (1<<15) | (1<<2) | 1}]
+ set polynomial(ccitt) [expr {(1<<16) | (1<<12) | (1<<5) | 1}]
+ set polynomial(crc32) [expr {(1<<32) | (1<<26) | (1<<23) | (1<<22)
+ | (1<<16) | (1<<12) | (1<<11) | (1<<10)
+ | (1<<8) | (1<<7) | (1<<5) | (1<<4)
+ | (1<<2) | (1<<1) | 1}]
+
+ # Array to hold the generated tables
+ variable table
+ if {![info exists table]} { array set table {}}
+
+ # calculate the sign bit for the current platform.
+ variable signbit
+ if {![info exists signbit]} {
+ variable v
+ for {set v 1} {int($v) != 0} {set signbit $v; set v [expr {$v<<1}]} {}
+ unset v
+ }
+}
+
+# -------------------------------------------------------------------------
+# Generate a CRC lookup table.
+# This creates a CRC algorithm lookup table for a 'width' bits checksum
+# using the 'poly' polynomial for all values of an input byte.
+# Setting 'reflected' changes the bit order for input bytes.
+# Returns a list or 255 elements.
+#
+# CRC-32: Crc_table 32 $crc::polynomial(crc32) 1
+# CRC-16: Crc_table 16 $crc::polynomial(crc16) 1
+# CRC16/CCITT: Crc_table 16 $crc::polynomial(ccitt) 0
+#
+proc ::crc::Crc_table {width poly reflected} {
+ set tbl {}
+ if {$width < 32} {
+ set mask [expr {(1 << $width) - 1}]
+ set topbit [expr {1 << ($width - 1)}]
+ } else {
+ set mask 0xffffffff
+ set topbit 0x80000000
+ }
+
+ for {set i 0} {$i < 256} {incr i} {
+ if {$reflected} {
+ set r [reflect $i 8]
+ } else {
+ set r $i
+ }
+ set r [expr {$r << ($width - 8)}]
+ for {set k 0} {$k < 8} {incr k} {
+ if {[expr {$r & $topbit}] != 0} {
+ set r [expr {($r << 1) ^ $poly}]
+ } else {
+ set r [expr {$r << 1}]
+ }
+ }
+ if {$reflected} {
+ set r [reflect $r $width]
+ }
+ lappend tbl [expr {$r & $mask}]
+ }
+ return $tbl
+}
+
+# -------------------------------------------------------------------------
+# Calculate the CRC checksum for the data in 's' using a precalculated
+# table.
+# s the input data
+# width - the width in bits of the CRC algorithm
+# table - the name of the variable holding the calculated table
+# init - the start value (or the last CRC for sequential blocks)
+# xorout - the final value may be XORd with this value
+# reflected - a boolean indicating that the bit order is reversed.
+# For hardware optimised CRC checks, the bits are handled
+# in transmission order (ie: bit0, bit1, ..., bit7)
+proc ::crc::Crc {s width table {init 0} {xorout 0} {reflected 0}} {
+ upvar $table tbl
+ variable signbit
+ set signmask [expr {~$signbit>>7}]
+
+ if {$width < 32} {
+ set mask [expr {(1 << $width) - 1}]
+ set rot [expr {$width - 8}]
+ } else {
+ set mask 0xffffffff
+ set rot 24
+ }
+
+ set crc $init
+ binary scan $s c* data
+ foreach {datum} $data {
+ if {$reflected} {
+ set ndx [expr {($crc ^ $datum) & 0xFF}]
+ set lkp [lindex $tbl $ndx]
+ set crc [expr {($lkp ^ ($crc >> 8 & $signmask)) & $mask}]
+ } else {
+ set ndx [expr {(($crc >> $rot) ^ $datum) & 0xFF}]
+ set lkp [lindex $tbl $ndx]
+ set crc [expr {($lkp ^ ($crc << 8 & $signmask)) & $mask}]
+ }
+ }
+
+ return [expr {$crc ^ $xorout}]
+}
+
+# -------------------------------------------------------------------------
+# Reverse the bit ordering for 'b' bits of the input value 'v'
+proc ::crc::reflect {v b} {
+ set t $v
+ for {set i 0} {$i < $b} {incr i} {
+ set v [expr {($t & 1) ? ($v | (1<<(($b-1)-$i))) : ($v & ~(1<<(($b-1)-$i))) }]
+ set t [expr {$t >> 1}]
+ }
+ return $v
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::crc::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# Specialisation of the general crc procedure to perform the standard CRC16
+# checksum
+proc ::crc::CRC16 {s {seed 0}} {
+ variable table
+ if {![info exists table(crc16)]} {
+ variable polynomial
+ set table(crc16) [Crc_table 16 $polynomial(crc16) 1]
+ }
+
+ return [Crc $s 16 [namespace current]::table(crc16) $seed 0 1]
+}
+
+# -------------------------------------------------------------------------
+# Specialisation of the general crc procedure to perform the CCITT telecoms
+# flavour of the CRC16 checksum
+proc ::crc::CRC-CCITT {s {seed 0} {xor 0}} {
+ variable table
+ if {![info exists table(ccitt)]} {
+ variable polynomial
+ set table(ccitt) [Crc_table 16 $polynomial(ccitt) 0]
+ }
+
+ return [Crc $s 16 [namespace current]::table(ccitt) $seed $xor 0]
+}
+
+# -------------------------------------------------------------------------
+# Demostrates the parameters used for the 32 bit checksum CRC-32.
+# This can be used to show the algorithm is working right by comparison with
+# other crc32 implementations
+proc ::crc::CRC-32 {s {seed 0xFFFFFFFF}} {
+ variable table
+ if {![info exists table(crc32)]} {
+ variable polynomial
+ set table(crc32) [Crc_table 32 $polynomial(crc32) 1]
+ }
+
+ return [Crc $s 32 [namespace current]::table(crc32) $seed 0xFFFFFFFF 1]
+}
+
+# -------------------------------------------------------------------------
+# User level CRC command.
+proc ::crc::crc {args} {
+ array set opts [list filename {} channel {} chunksize 4096 \
+ format %u seed 0 \
+ impl [namespace origin CRC16]]
+
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -fi* { set opts(filename) [Pop args 1] }
+ -cha* { set opts(channel) [Pop args 1] }
+ -chu* { set opts(chunksize) [Pop args 1] }
+ -fo* { set opts(format) [Pop args 1] }
+ -i* { set opts(impl) [uplevel 1 namespace origin [Pop args 1]] }
+ -s* { set opts(seed) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0} { Pop args; break }
+ set options [join [lsort [array names opts]] ", -"]
+ return -code error "bad option $option:\
+ must be one of -$options"
+ }
+ }
+ Pop args
+ }
+
+ if {$opts(filename) != {}} {
+ set opts(channel) [open $opts(filename) r]
+ fconfigure $opts(channel) -translation binary
+ }
+
+ if {$opts(channel) != {}} {
+ set r $opts(seed)
+ set trans [fconfigure $opts(channel) -translation]
+ fconfigure $opts(channel) -translation binary
+ while {![eof $opts(channel)]} {
+ set chunk [read $opts(channel) $opts(chunksize)]
+ set r [$opts(impl) $chunk $r]
+ }
+ fconfigure $opts(channel) -translation $trans
+ if {$opts(filename) != {}} {
+ close $opts(channel)
+ }
+ } else {
+ if {[llength $args] != 1} {
+ return -code error "wrong \# args: should be\
+ \"crc16 ?-format string? ?-seed value? ?-impl procname?\
+ -file name | data\""
+ }
+ set r [$opts(impl) [lindex $args 0] $opts(seed)]
+ }
+ return [format $opts(format) $r]
+}
+
+# -------------------------------------------------------------------------
+# The user commands. See 'crc'
+#
+proc ::crc::crc16 {args} {
+ return [eval [list crc -impl [namespace origin CRC16]] $args]
+}
+
+proc ::crc::crc-ccitt {args} {
+ return [eval [list crc -impl [namespace origin CRC-CCITT] -seed 0xFFFF]\
+ $args]
+}
+
+proc ::crc::xmodem {args} {
+ return [eval [list crc -impl [namespace origin CRC-CCITT] -seed 0] $args]
+}
+
+proc ::crc::crc-32 {args} {
+ return [eval [list crc -impl [namespace origin CRC-32] -seed 0xFFFFFFFF]\
+ $args]
+}
+
+# -------------------------------------------------------------------------
+
+package provide crc16 1.1.2
+
+# -------------------------------------------------------------------------
+#
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/crc/crc16.test b/tcllib/modules/crc/crc16.test
new file mode 100644
index 0000000..1dc032a
--- /dev/null
+++ b/tcllib/modules/crc/crc16.test
@@ -0,0 +1,233 @@
+# crc16.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Tests for the crc16 commands
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: crc16.test,v 1.7 2012/01/23 20:28:11 patthoyts Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal crc16.tcl crc16 ::crc
+}
+
+# -------------------------------------------------------------------------
+
+test crc16-1.0 {crc16 with no parameters } {
+ catch {::crc::crc16} result
+ string match "wrong # args: *" $result
+} {1}
+
+test crc16-1.1 {crc16 with single parameter} {
+ list [catch {::crc::crc16 abc} err] $err
+} {0 38712}
+
+test crc16-1.2 {crc16 with "--" parameter} {
+ list [catch {::crc::crc16 -- abc} err] $err
+} {0 38712}
+
+test crc16-1.3 {crc16 with leading hyphen data} {
+ list [catch {::crc::crc16 -abc} err] $err
+} {0 64305}
+
+test crc16-1.4 {crc16 with leading hyphen data and option separator} {
+ list [catch {::crc::crc16 -- -abc} err] $err
+} {0 64305}
+
+test crc16-1.5 {crc16 with leading hyphen data and format option} {
+ list [catch {::crc::crc16 -format %04x -abc} err] $err
+} {0 fb31}
+
+test crc16-1.6 {crc16 with leading hyphen data, format option separator} {
+ list [catch {::crc::crc16 -format %04x -- -abc} err] $err
+} {0 fb31}
+
+test crc16-1.7 {crc-ccitt with leading hyphen data} {
+ list [catch {::crc::crc-ccitt -abc} err] $err
+} {0 6110}
+
+test crc16-1.8 {crc-ccitt with leading hyphen data and option separator} {
+ list [catch {::crc::crc-ccitt -- -abc} err] $err
+} {0 6110}
+
+
+# -------------------------------------------------------------------------
+# CRC16 tests
+# -------------------------------------------------------------------------
+
+foreach {n msg expected} {
+ 1 ""
+ "0"
+ 2 "123456789"
+ "47933"
+ 3 "abc"
+ "38712"
+ 4 "ABC"
+ "17697"
+ 5 "This is a string"
+ "19524"
+ 8 "\uFFFE\u0000\u0001\u0002"
+ "47537"
+} {
+ test crc16-2.$n {crc16 and unsigned integer} {
+ list [catch {::crc::crc16 $msg} res] $res
+ } [list 0 $expected]
+}
+
+foreach {n msg expected} {
+ 1 ""
+ "0x0"
+ 2 "123456789"
+ "0xBB3D"
+ 3 "abc"
+ "0x9738"
+ 4 "ABC"
+ "0x4521"
+ 5 "This is a string"
+ "0x4C44"
+ 6 "\uFFFE\u0000\u0001\u0002"
+ "0xB9B1"
+} {
+ test crc16-3.$n {crc16 as hexadecimal string} {
+ list [catch {::crc::crc16 -format 0x%X $msg} res] $res
+ } [list 0 $expected]
+}
+
+# -------------------------------------------------------------------------
+# Implementation tests
+# -------------------------------------------------------------------------
+
+set ::crc::testfile [info script]
+
+proc crc::loaddata {filename} {
+ set f [open $filename r]
+ fconfigure $f -translation binary
+ set data [read $f]
+ close $f
+ return $data
+}
+
+test crc16-4.0 {crc16 file option} {
+ set r1 [::crc::crc16 -file [info script]]
+ list [catch {
+ set r2 [::crc::crc16 [crc::loaddata [info script]]]
+ if {$r1 != $r2} {
+ set r "differing results: $r1 != $r2"
+ } else {
+ set r ok
+ }
+ } result] $result
+} {0 ok}
+
+test crc16-4.1 {crc16 channel option} {
+ set r1 [::crc::crc16 [crc::loaddata $crc::testfile]]
+ list [catch {
+ set f [open $crc::testfile r]
+ set r2 [::crc::crc16 -channel $f]
+ close $f
+ if {$r1 != $r2} {
+ set r "differing results: $r1 != $r2"
+ } else {
+ set r ok
+ }
+ set r
+ } result] $result
+} {0 ok}
+
+test crc16-5.0 {crc implementation option} {
+ proc crc::junk {s seed} {
+ return 0
+ }
+
+ list [catch {::crc::crc16 -impl crc::junk {Hello, World!}} res] $res
+} {0 0}
+
+# -------------------------------------------------------------------------
+# CRC-CCITT tests
+# -------------------------------------------------------------------------
+
+foreach {n msg expected} {
+ 1 ""
+ "0xFFFF"
+ 2 "123456789"
+ "0x29B1"
+ 3 "abc"
+ "0x514A"
+ 4 "ABC"
+ "0xF508"
+ 5 "This is a string"
+ "0x4BE9"
+ 8 "\uFFFE\u0000\u0001\u0002"
+ "0xAAA4"
+} {
+ test crc16-6.$n {crc-ccitt and unsigned integer} {
+ list [catch {::crc::crc-ccitt -format 0x%X $msg} res] $res
+ } [list 0 $expected]
+}
+
+# -------------------------------------------------------------------------
+# CRC32 tests
+# -------------------------------------------------------------------------
+
+foreach {n msg expected} {
+ 1 ""
+ "0x0"
+ 2 "123456789"
+ "0xCBF43926"
+ 3 "abc"
+ "0x352441C2"
+ 4 "ABC"
+ "0xA3830348"
+ 5 "This is a string"
+ "0x876633F"
+ 8 "\uFFFE\u0000\u0001\u0002"
+ "0xB0E8EEE5"
+} {
+ test crc16-7.$n {crc-32 from the crc16 algorithms} {
+ list [catch {::crc::crc-32 -format 0x%X $msg} res] $res
+ } [list 0 $expected]
+}
+
+# -------------------------------------------------------------------------
+# XMODEM CRC tests
+# -------------------------------------------------------------------------
+
+foreach {n msg expected} {
+ 1 ""
+ "0x0"
+ 2 "T"
+ "0x1A71"
+ 3 "123456789"
+ "0x31C3"
+ 4 "abc"
+ "0x9DD6"
+ 5 "ABC"
+ "0x3994"
+ 6 "This is a string"
+ "0x21E3"
+ 7 "\uFFFE\u0000\u0001\u0002"
+ "0x2E64"
+} {
+ test crc16-8.$n {XMODEM CRCs as hexadecimal string} {
+ list [catch {::crc::xmodem -format 0x%X $msg} res] $res
+ } [list 0 $expected]
+}
+# -------------------------------------------------------------------------
+
+catch {unset crc::filename}
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/crc/crc32.bench b/tcllib/modules/crc/crc32.bench
new file mode 100644
index 0000000..bf31a91
--- /dev/null
+++ b/tcllib/modules/crc/crc32.bench
@@ -0,0 +1,38 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'crc32' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+set moddir [file dirname [file dirname [info script]]]
+lappend auto_path $moddir
+
+package forget crc32
+catch {namespace delete ::crc}
+source [file join [file dirname [info script]] crc32.tcl]
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+foreach n {1 10 100 1000 10000} {
+ bench -desc "CRC32 $n" -pre {
+ set str [string repeat " " $n]
+ } -body {
+ crc::crc32 $str
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/crc/crc32.man b/tcllib/modules/crc/crc32.man
new file mode 100644
index 0000000..4de5bc5
--- /dev/null
+++ b/tcllib/modules/crc/crc32.man
@@ -0,0 +1,152 @@
+[vset VERSION 1.3.2]
+[manpage_begin crc32 n [vset VERSION]]
+[see_also cksum(n)]
+[see_also crc16(n)]
+[see_also sum(n)]
+[keywords checksum]
+[keywords cksum]
+[keywords crc]
+[keywords crc32]
+[keywords {cyclic redundancy check}]
+[keywords {data integrity}]
+[keywords security]
+[copyright {2002, Pat Thoyts}]
+[moddesc {Cyclic Redundancy Checks}]
+[titledesc {Perform a 32bit Cyclic Redundancy Check}]
+[category {Hashes, checksums, and encryption}]
+[require Tcl 8.2]
+[require crc32 [opt [vset VERSION]]]
+[description]
+[para]
+
+This package provides a Tcl implementation of the CRC-32
+algorithm based upon information provided at
+http://www.naaccr.org/standard/crc32/document.html
+
+If either the [package critcl] package or the [package Trf] package
+are available then a compiled version may be used internally to
+accelerate the checksum calculation.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd "::crc::crc32"] \
+ [opt "-format [arg format]"] \
+ [opt "-seed [arg value]"] \
+ [lb] [arg "-channel chan"] | \
+ [arg "-filename file"] | \
+ [arg message] [rb]]
+
+The command takes either string data or a channel or file name and
+returns a checksum value calculated using the CRC-32 algorithm. The
+result is formatted using the [arg format](n) specifier provided. The
+default is to return the value as an unsigned integer (format %u).
+
+[list_end]
+
+[section OPTIONS]
+
+[list_begin definitions]
+
+[def "-channel [arg name]"]
+
+Return a checksum for the data read from a channel. The command will
+read data from the channel until the [cmd "eof"] is true. If you need
+to be able to process events during this calculation see the
+[sectref {PROGRAMMING INTERFACE}] section
+
+[def "-filename [arg name]"]
+
+This is a convenience option that opens the specified file, sets the
+encoding to binary and then acts as if the [arg -channel] option had
+been used. The file is closed on completion.
+
+[def "-format [arg string]"]
+
+Return the checksum using an alternative format template.
+
+[def "-seed [arg value]"]
+
+Select an alternative seed value for the CRC calculation. The default
+is 0xffffffff. This can be useful for calculating the CRC for data
+structures without first converting the whole structure into a
+string. The CRC of the previous member can be used as the seed for
+calculating the CRC of the next member.
+
+Note that the crc32 algorithm includes a final XOR step. If
+incremental processing is desired then this must be undone before
+using the output of the algorithm as the seed for further
+processing. A simpler alternative is to use the
+[sectref {PROGRAMMING INTERFACE}] which is intended for this mode of
+operation.
+
+[list_end]
+
+[section {PROGRAMMING INTERFACE}]
+
+The CRC-32 package implements the checksum using a context variable to
+which additional data can be added at any time. This is expecially
+useful in an event based environment such as a Tk application or a web
+server package. Data to be checksummed may be handled incrementally
+during a [cmd fileevent] handler in discrete chunks. This can improve
+the interactive nature of a GUI application and can help to avoid
+excessive memory consumption.
+
+[list_begin definitions]
+
+[call [cmd "::crc::Crc32Init"] [opt [arg "seed"]]]
+
+Begins a new CRC32 context. Returns a token ID that must be used for the
+remaining functions. An optional seed may be specified if required.
+
+[call [cmd "::crc::Crc32Update"] [arg "token"] [arg "data"]]
+
+Add data to the checksum identified by token. Calling
+[emph {Crc32Update $token "abcd"}] is equivalent to calling
+[emph {Crc32Update $token "ab"}] followed by
+[emph {Crc32Update $token "cb"}]. See [sectref {EXAMPLES}].
+
+[call [cmd "::crc::Crc32Final"] [arg "token"]]
+
+Returns the checksum value and releases any resources held by this
+token. Once this command completes the token will be invalid. The
+result is a 32 bit integer value.
+
+[list_end]
+
+[section EXAMPLES]
+
+[para]
+[example {
+% crc::crc32 "Hello, World!"
+3964322768
+}]
+
+[para]
+[example {
+% crc::crc32 -format 0x%X "Hello, World!"
+0xEC4AC3D0
+}]
+
+[para]
+[example {
+% crc::crc32 -file crc32.tcl
+483919716
+}]
+
+[para]
+[example {
+% set tok [crc::Crc32Init]
+% crc::Crc32Update $tok "Hello, "
+% crc::Crc32Update $tok "World!"
+% crc::Crc32Final $tok
+3964322768
+}]
+
+[section AUTHORS]
+Pat Thoyts
+
+[vset CATEGORY crc]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/crc/crc32.pcx b/tcllib/modules/crc/crc32.pcx
new file mode 100644
index 0000000..732c766
--- /dev/null
+++ b/tcllib/modules/crc/crc32.pcx
@@ -0,0 +1,37 @@
+# -*- tcl -*- crc32.pcx
+# Syntax of the commands provided by package crc32.
+
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register crc32
+pcx::tcldep 1.3 needs tcl 8.2
+
+namespace eval ::crc32 {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.3 std ::crc::crc32 \
+ {checkConstrained {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ {-channel {checkSetConstraint fn checkChannelID}}
+ {-chunksize checkInt}
+ {-filename {checkSetConstraint fn checkFileName}}
+ {-format checkWord}
+ {-seed checkWord}
+ {-timeout checkWholeNum}
+ --
+ } {checkConstraint {
+ {fn {checkSimpleArgs 0 0 {}}}
+ {!fn {checkSimpleArgs 1 1 checkWord}}
+ } {}}}
+ }}}
+
+# Initialization via pcx::init.
+# Use a ::crc32::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/crc/crc32.tcl b/tcllib/modules/crc/crc32.tcl
new file mode 100644
index 0000000..ffc1f36
--- /dev/null
+++ b/tcllib/modules/crc/crc32.tcl
@@ -0,0 +1,377 @@
+# crc32.tcl -- Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# CRC32 Cyclic Redundancy Check.
+# (for algorithm see http://www.rad.com/networks/1994/err_con/crc.htm)
+#
+# From http://mini.net/tcl/2259.tcl
+# Written by Wayland Augur and Pat Thoyts.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.2
+
+namespace eval ::crc {
+ variable accel
+ array set accel {critcl 0 trf 0}
+
+ namespace export crc32
+
+ variable crc32_tbl [list 0x00000000 0x77073096 0xEE0E612C 0x990951BA \
+ 0x076DC419 0x706AF48F 0xE963A535 0x9E6495A3 \
+ 0x0EDB8832 0x79DCB8A4 0xE0D5E91E 0x97D2D988 \
+ 0x09B64C2B 0x7EB17CBD 0xE7B82D07 0x90BF1D91 \
+ 0x1DB71064 0x6AB020F2 0xF3B97148 0x84BE41DE \
+ 0x1ADAD47D 0x6DDDE4EB 0xF4D4B551 0x83D385C7 \
+ 0x136C9856 0x646BA8C0 0xFD62F97A 0x8A65C9EC \
+ 0x14015C4F 0x63066CD9 0xFA0F3D63 0x8D080DF5 \
+ 0x3B6E20C8 0x4C69105E 0xD56041E4 0xA2677172 \
+ 0x3C03E4D1 0x4B04D447 0xD20D85FD 0xA50AB56B \
+ 0x35B5A8FA 0x42B2986C 0xDBBBC9D6 0xACBCF940 \
+ 0x32D86CE3 0x45DF5C75 0xDCD60DCF 0xABD13D59 \
+ 0x26D930AC 0x51DE003A 0xC8D75180 0xBFD06116 \
+ 0x21B4F4B5 0x56B3C423 0xCFBA9599 0xB8BDA50F \
+ 0x2802B89E 0x5F058808 0xC60CD9B2 0xB10BE924 \
+ 0x2F6F7C87 0x58684C11 0xC1611DAB 0xB6662D3D \
+ 0x76DC4190 0x01DB7106 0x98D220BC 0xEFD5102A \
+ 0x71B18589 0x06B6B51F 0x9FBFE4A5 0xE8B8D433 \
+ 0x7807C9A2 0x0F00F934 0x9609A88E 0xE10E9818 \
+ 0x7F6A0DBB 0x086D3D2D 0x91646C97 0xE6635C01 \
+ 0x6B6B51F4 0x1C6C6162 0x856530D8 0xF262004E \
+ 0x6C0695ED 0x1B01A57B 0x8208F4C1 0xF50FC457 \
+ 0x65B0D9C6 0x12B7E950 0x8BBEB8EA 0xFCB9887C \
+ 0x62DD1DDF 0x15DA2D49 0x8CD37CF3 0xFBD44C65 \
+ 0x4DB26158 0x3AB551CE 0xA3BC0074 0xD4BB30E2 \
+ 0x4ADFA541 0x3DD895D7 0xA4D1C46D 0xD3D6F4FB \
+ 0x4369E96A 0x346ED9FC 0xAD678846 0xDA60B8D0 \
+ 0x44042D73 0x33031DE5 0xAA0A4C5F 0xDD0D7CC9 \
+ 0x5005713C 0x270241AA 0xBE0B1010 0xC90C2086 \
+ 0x5768B525 0x206F85B3 0xB966D409 0xCE61E49F \
+ 0x5EDEF90E 0x29D9C998 0xB0D09822 0xC7D7A8B4 \
+ 0x59B33D17 0x2EB40D81 0xB7BD5C3B 0xC0BA6CAD \
+ 0xEDB88320 0x9ABFB3B6 0x03B6E20C 0x74B1D29A \
+ 0xEAD54739 0x9DD277AF 0x04DB2615 0x73DC1683 \
+ 0xE3630B12 0x94643B84 0x0D6D6A3E 0x7A6A5AA8 \
+ 0xE40ECF0B 0x9309FF9D 0x0A00AE27 0x7D079EB1 \
+ 0xF00F9344 0x8708A3D2 0x1E01F268 0x6906C2FE \
+ 0xF762575D 0x806567CB 0x196C3671 0x6E6B06E7 \
+ 0xFED41B76 0x89D32BE0 0x10DA7A5A 0x67DD4ACC \
+ 0xF9B9DF6F 0x8EBEEFF9 0x17B7BE43 0x60B08ED5 \
+ 0xD6D6A3E8 0xA1D1937E 0x38D8C2C4 0x4FDFF252 \
+ 0xD1BB67F1 0xA6BC5767 0x3FB506DD 0x48B2364B \
+ 0xD80D2BDA 0xAF0A1B4C 0x36034AF6 0x41047A60 \
+ 0xDF60EFC3 0xA867DF55 0x316E8EEF 0x4669BE79 \
+ 0xCB61B38C 0xBC66831A 0x256FD2A0 0x5268E236 \
+ 0xCC0C7795 0xBB0B4703 0x220216B9 0x5505262F \
+ 0xC5BA3BBE 0xB2BD0B28 0x2BB45A92 0x5CB36A04 \
+ 0xC2D7FFA7 0xB5D0CF31 0x2CD99E8B 0x5BDEAE1D \
+ 0x9B64C2B0 0xEC63F226 0x756AA39C 0x026D930A \
+ 0x9C0906A9 0xEB0E363F 0x72076785 0x05005713 \
+ 0x95BF4A82 0xE2B87A14 0x7BB12BAE 0x0CB61B38 \
+ 0x92D28E9B 0xE5D5BE0D 0x7CDCEFB7 0x0BDBDF21 \
+ 0x86D3D2D4 0xF1D4E242 0x68DDB3F8 0x1FDA836E \
+ 0x81BE16CD 0xF6B9265B 0x6FB077E1 0x18B74777 \
+ 0x88085AE6 0xFF0F6A70 0x66063BCA 0x11010B5C \
+ 0x8F659EFF 0xF862AE69 0x616BFFD3 0x166CCF45 \
+ 0xA00AE278 0xD70DD2EE 0x4E048354 0x3903B3C2 \
+ 0xA7672661 0xD06016F7 0x4969474D 0x3E6E77DB \
+ 0xAED16A4A 0xD9D65ADC 0x40DF0B66 0x37D83BF0 \
+ 0xA9BCAE53 0xDEBB9EC5 0x47B2CF7F 0x30B5FFE9 \
+ 0xBDBDF21C 0xCABAC28A 0x53B39330 0x24B4A3A6 \
+ 0xBAD03605 0xCDD70693 0x54DE5729 0x23D967BF \
+ 0xB3667A2E 0xC4614AB8 0x5D681B02 0x2A6F2B94 \
+ 0xB40BBE37 0xC30C8EA1 0x5A05DF1B 0x2D02EF8D]
+
+ # calculate the sign bit for the current platform.
+ variable signbit
+ if {![info exists signbit]} {
+ variable v
+ for {set v 1} {int($v) != 0} {set signbit $v; set v [expr {$v<<1}]} {}
+ unset v
+ }
+
+ variable uid ; if {![info exists uid]} {set uid 0}
+}
+
+# -------------------------------------------------------------------------
+
+# crc::Crc32Init --
+#
+# Create and initialize a crc32 context. This is cleaned up
+# when we we call Crc32Final to obtain the result.
+#
+proc ::crc::Crc32Init {{seed 0xFFFFFFFF}} {
+ variable uid
+ variable accel
+ set token [namespace current]::[incr uid]
+ upvar #0 $token state
+ array set state [list sum $seed]
+ # If the initial seed is set to some other value we cannot use Trf.
+ if {$accel(trf) && $seed == 0xFFFFFFFF} {
+ set s {}
+ switch -exact -- $::tcl_platform(platform) {
+ windows { set s [open NUL w] }
+ unix { set s [open /dev/null w] }
+ }
+ if {$s != {}} {
+ fconfigure $s -translation binary -buffering none
+ ::crc-zlib -attach $s -mode write \
+ -write-type variable \
+ -write-destination ${token}(trfwrite)
+ array set state [list trfread 0 trfwrite 0 trf $s]
+ }
+ }
+ return $token
+}
+
+# crc::Crc32Update --
+#
+# This is called to add more data into the checksum. You may
+# call this as many times as you require. Note that passing in
+# "ABC" is equivalent to passing these letters in as separate
+# calls -- hence this proc permits summing of chunked data.
+#
+# If we have a C-based implementation available, then we will
+# use it here in preference to the pure-Tcl implementation.
+#
+proc ::crc::Crc32Update {token data} {
+ variable accel
+ upvar #0 $token state
+ set sum $state(sum)
+ if {$accel(critcl)} {
+ set sum [Crc32_c $data $sum]
+ } elseif {[info exists state(trf)]} {
+ puts -nonewline $state(trf) $data
+ return
+ } else {
+ set sum [Crc32_tcl $data $sum]
+ }
+ set state(sum) [expr {$sum ^ 0xFFFFFFFF}]
+ return
+}
+
+# crc::Crc32Final --
+#
+# This procedure is used to close the context and returns the
+# checksum value. Once this procedure has been called the checksum
+# context is freed and cannot be used again.
+#
+proc ::crc::Crc32Final {token} {
+ upvar #0 $token state
+ if {[info exists state(trf)]} {
+ close $state(trf)
+ binary scan $state(trfwrite) i sum
+ set sum [expr {$sum & 0xFFFFFFFF}]
+ } else {
+ set sum [expr {($state(sum) ^ 0xFFFFFFFF) & 0xFFFFFFFF}]
+ }
+ unset state
+ return $sum
+}
+
+# crc::Crc32_tcl --
+#
+# The pure-Tcl implementation of a table based CRC-32 checksum.
+# The seed should always be 0xFFFFFFFF to begin with, but for
+# successive chunks of data the seed should be set to the result
+# of the last chunk.
+#
+proc ::crc::Crc32_tcl {data {seed 0xFFFFFFFF}} {
+ variable crc32_tbl
+ variable signbit
+ set signmask [expr {~$signbit>>7}]
+ set crcval $seed
+
+ binary scan $data c* nums
+ foreach {n} $nums {
+ set ndx [expr {($crcval ^ $n) & 0xFF}]
+ set lkp [lindex $crc32_tbl $ndx]
+ set crcval [expr {($lkp ^ ($crcval >> 8 & $signmask)) & 0xFFFFFFFF}]
+ }
+
+ return [expr {$crcval ^ 0xFFFFFFFF}]
+}
+
+# crc::Crc32_c --
+#
+# A C version of the CRC-32 code using the same table. This is
+# designed to be compiled using critcl.
+#
+if {[package provide critcl] != {}} {
+ namespace eval ::crc {
+ critcl::ccommand Crc32_c {dummy interp objc objv} {
+ int r = TCL_OK;
+ unsigned long t = 0xFFFFFFFFL;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "data ?seed?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 3) {
+ r = Tcl_GetLongFromObj(interp, objv[2], (long *)&t);
+ }
+
+ if (r == TCL_OK) {
+ int cn, size, ndx;
+ unsigned char *data;
+ unsigned long lkp;
+ Tcl_Obj *tblPtr, *lkpPtr;
+
+ tblPtr = Tcl_GetVar2Ex(interp, "::crc::crc32_tbl", NULL,
+ TCL_LEAVE_ERR_MSG );
+ if (tblPtr == NULL) {
+ r = TCL_ERROR;
+ }
+ if (r == TCL_OK) {
+ data = Tcl_GetByteArrayFromObj(objv[1], &size);
+ }
+ for (cn = 0; r == TCL_OK && cn < size; cn++) {
+ ndx = (t ^ data[cn]) & 0xFF;
+ r = Tcl_ListObjIndex(interp, tblPtr, ndx, &lkpPtr);
+ if (r == TCL_OK) {
+ r = Tcl_GetLongFromObj(interp, lkpPtr, (long*) &lkp);
+ }
+ if (r == TCL_OK) {
+ t = lkp ^ (t >> 8);
+ }
+ }
+ }
+
+ if (r == TCL_OK) {
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(t ^ 0xFFFFFFFF));
+ }
+ return r;
+ }
+ }
+}
+
+# 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 ::crc::LoadAccelerator {name} {
+ variable accel
+ set r 0
+ switch -exact -- $name {
+ critcl {
+ if {![catch {package require tcllibc}]
+ || ![catch {package require crcc}]} {
+ set r [expr {[info commands ::crc::Crc32_c] != {}}]
+ }
+ }
+ trf {
+ if {![catch {package require Trf}]} {
+ set r [expr {![catch {::crc-zlib aa} msg]}]
+ }
+ }
+ default {
+ return -code error "invalid accelerator package:\
+ must be one of [join [array names accel] {, }]"
+ }
+ }
+ set accel($name) $r
+}
+
+# crc::Pop --
+#
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::crc::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# crc::crc32 --
+#
+# Provide a Tcl implementation of a crc32 checksum similar to the
+# cksum and sum unix commands.
+#
+# Options:
+# -filename name - return a checksum for the specified file.
+# -format string - return the checksum using this format string.
+# -seed value - seed the algorithm using value (default is 0xffffffff)
+#
+proc ::crc::crc32 {args} {
+ array set opts [list -filename {} -format %u -seed 0xffffffff \
+ -channel {} -chunksize 4096 -timeout 30000]
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -file* { set opts(-filename) [Pop args 1] }
+ -for* { set opts(-format) [Pop args 1] }
+ -chan* { set opts(-channel) [Pop args 1] }
+ -chunk* { set opts(-chunksize) [Pop args 1] }
+ -time* { set opts(-timeout) [Pop args 1] }
+ -seed { set opts(-seed) [Pop args 1] }
+ -impl* { set junk [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0} { Pop args; break }
+ set err [join [lsort [array names opts -*]] ", "]
+ return -code error "bad option \"$option\": must be $err"
+ }
+ }
+ Pop args
+ }
+
+ # If a file was given - open it
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \
+ \"crc32 ?-format string? ?-seed value? \
+ -channel chan | -file name | data\""
+ }
+ set tok [Crc32Init $opts(-seed)]
+ Crc32Update $tok [lindex $args 0]
+ set r [Crc32Final $tok]
+
+ } else {
+
+ set r $opts(-seed)
+ set tok [Crc32Init $opts(-seed)]
+ while {![eof $opts(-channel)]} {
+ Crc32Update $tok [read $opts(-channel) $opts(-chunksize)]
+ }
+ set r [Crc32Final $tok]
+
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+ }
+
+ return [format $opts(-format) $r]
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help (note - trf is fastest)
+namespace eval ::crc {
+ variable e {}
+ foreach e {trf critcl} {
+ if {[LoadAccelerator $e]} break
+ }
+ unset e
+}
+
+package provide crc32 1.3.2
+
+# -------------------------------------------------------------------------
+#
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/crc/crc32.test b/tcllib/modules/crc/crc32.test
new file mode 100644
index 0000000..f2366eb
--- /dev/null
+++ b/tcllib/modules/crc/crc32.test
@@ -0,0 +1,222 @@
+# crc32.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Tests for the crc32 commands
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: crc32.test,v 1.12 2009/03/04 01:01:42 patthoyts Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal crc32.tcl crc32 ::crc
+}
+
+# -------------------------------------------------------------------------
+
+if {[::crc::LoadAccelerator critcl]} {
+ puts "> critcl based"
+}
+if {[::crc::LoadAccelerator trf]} {
+ puts "> Trf based"
+}
+puts "> pure Tcl"
+
+# -------------------------------------------------------------------------
+# Handle multiple implementation testing
+#
+
+array set preserve [array get ::crc::accel]
+
+proc implementations {} {
+ variable ::crc::accel
+ foreach {a v} [array get accel] {if {$v} {lappend r $a}}
+ lappend r tcl; set r
+}
+
+proc select_implementation {impl} {
+ variable ::crc::accel
+ foreach e [array names accel] { set accel($e) 0 }
+ if {[string compare "tcl" $impl] != 0} {
+ set accel($impl) 1
+ }
+}
+
+proc reset_implementation {} {
+ variable ::crc::accel
+ array set accel [array get ::preserve]
+}
+
+# -------------------------------------------------------------------------
+
+test crc32-1.0 {crc32 with no parameters } {
+ catch {::crc::crc32} result
+ string match "wrong # args: *" $result
+} {1}
+
+# -------------------------------------------------------------------------
+
+set tests {
+ 1 ""
+ "0"
+ 2 "a"
+ "3904355907"
+ 3 "abc"
+ "891568578"
+ 4 "message digest"
+ "538287487"
+ 5 "abcdefghijklmnopqrstuvwxyz"
+ "1277644989"
+ 6 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+ "532866770"
+ 7 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "2091469426"
+ 8 "\uFFFE\u0000\u0001\u0002"
+ "2968055525"
+ 9 "-"
+ "2547889144"
+ 10 "--"
+ "606868581"
+}
+foreach impl [implementations] {
+ select_implementation $impl
+ foreach {n msg expected} $tests {
+ test crc32-$impl-2.$n "crc32 as unsigned integer ($impl)" {
+ list [catch {::crc::crc32 $msg} err] $err
+ } [list 0 $expected]
+ }
+ reset_implementation
+}
+
+# -------------------------------------------------------------------------
+
+set tests {
+ 1 ""
+ "0x0"
+ 2 "a"
+ "0xE8B7BE43"
+ 3 "abc"
+ "0x352441C2"
+ 4 "message digest"
+ "0x20159D7F"
+ 5 "abcdefghijklmnopqrstuvwxyz"
+ "0x4C2750BD"
+ 6 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+ "0x1FC2E6D2"
+ 7 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "0x7CA94A72"
+ 8 "\uFFFE\u0000\u0001\u0002"
+ "0xB0E8EEE5"
+ 9 "-"
+ "0x97DDB3F8"
+ 10 "--"
+ "0x242C1465"
+}
+
+foreach impl [implementations] {
+ select_implementation $impl
+ foreach {n msg expected} $tests {
+ test crc32-$impl-3.$n "crc32 as hexadecimal string ($impl)" {
+ list [catch {::crc::crc32 -format 0x%X $msg} err] $err
+ } [list 0 $expected]
+ }
+ reset_implementation
+}
+
+# -------------------------------------------------------------------------
+
+set crc::testfile [info script]
+
+proc crc::loaddata {filename} {
+ set f [open $filename r]
+ fconfigure $f -translation binary
+ set data [read $f]
+ close $f
+ return $data
+}
+
+foreach impl [implementations] {
+ select_implementation $impl
+ test crc32-$impl-4.0 "crc32 file option ($impl)" {
+ set r1 [::crc::crc32 -file $crc::testfile]
+ set r2 [::crc::crc32 [crc::loaddata $crc::testfile]]
+ if {$r1 != $r2} {
+ set r "differing results: $r1 != $r2"
+ } else {
+ set r ok
+ }
+ } {ok}
+ reset_implementation
+}
+
+# -------------------------------------------------------------------------
+
+set tests {
+ 1 0 ""
+ "4294967295"
+ 2 1 ""
+ "4294967294"
+ 3 0 "Hello, World!"
+ "482441901"
+ 4 1 "Hello, World!"
+ "3243746088"
+ 5 0 "-"
+ "3122701194"
+}
+foreach impl [implementations] {
+ select_implementation $impl
+ foreach {n seed msg expected} $tests {
+ test crc32-$impl-5.$n "crc32 initial seed option ($impl)" {
+ list [catch {::crc::crc32 -seed $seed $msg} err] $err
+ } [list 0 $expected]
+ }
+ reset_implementation
+}
+
+# -------------------------------------------------------------------------
+
+set tests {
+ 1 "a" "bc"
+ "891568578"
+ 2 "message" " digest"
+ "538287487"
+ 3 "abcdefghijkl" "mnopqrstuvwxyz"
+ "1277644989"
+ 4 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz012345678" "9"
+ "532866770"
+ 5 "1234567890"
+ "1234567890123456789012345678901234567890123456789012345678901234567890"
+ "2091469426"
+ 6 "\uFFFE\u0000" "\u0001\u0002"
+ "2968055525"
+}
+foreach impl [implementations] {
+ select_implementation $impl
+ foreach {n msgA msgB expected} $tests {
+ test crc32-$impl-6.$n "crc32 using -seed ($impl)" {
+ list [catch {
+ ::crc::crc32 -seed [expr {[::crc::crc32 $msgA] ^ 0xffffffff}] $msgB
+ } err] $err
+ } [list 0 $expected]
+ }
+ reset_implementation
+}
+
+# -------------------------------------------------------------------------
+
+catch {unset crc::filename}
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/crc/crc32bugs.test b/tcllib/modules/crc/crc32bugs.test
new file mode 100644
index 0000000..e750077
--- /dev/null
+++ b/tcllib/modules/crc/crc32bugs.test
@@ -0,0 +1,104 @@
+# crc32bugs.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sf.net>
+#
+# Bug finding for crc32 module.
+# In particular we are looking for byte order problems, and issues between
+# the trf code and tcl-only code.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: crc32bugs.test,v 1.8 2006/10/09 21:41:40 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+catch {namespace delete ::crc}
+support {
+ useLocal crc16.tcl crc16
+}
+testing {
+ useLocal crc32.tcl crc32
+}
+
+# -------------------------------------------------------------------------
+
+puts "> $::tcl_platform(byteOrder)"
+
+if {[::crc::LoadAccelerator critcl]} {
+ puts "> bugs, critcl based"
+}
+if {[::crc::LoadAccelerator trf]} {
+ puts "> bugs, Trf based"
+}
+puts "> bugs, pure Tcl"
+
+# -------------------------------------------------------------------------
+# Handle multiple implementation testing
+#
+
+array set preserve [array get ::crc::accel]
+
+proc implementations {} {
+ variable ::crc::accel
+ foreach {a v} [array get accel] {if {$v} {lappend r $a}}
+ lappend r tcl; set r
+}
+
+proc select_implementation {impl} {
+ variable ::crc::accel
+ foreach e [array names accel] { set accel($e) 0 }
+ if {[string compare "tcl" $impl] != 0} {
+ set accel($impl) 1
+ }
+}
+
+proc reset_implementation {} {
+ variable ::crc::accel
+ array set accel [array get ::preserve]
+}
+
+# -------------------------------------------------------------------------
+
+set tests {
+ 1 "" "0"
+ 2 "\x00" "d202ef8d"
+ 3 "\x00\x00" "41d912ff"
+ 4 "\x00\x00\x00" "ff41d912"
+ 5 "\x00\x00\x00\x00" "2144df1c"
+ 6 "\xFF" "ff000000"
+ 7 "\xFF\xFF" "ffff0000"
+ 8 "\xFF\xFF\xFF" "ffffff00"
+ 9 "\xFF\xFF\xFF\xFF" "ffffffff"
+ 10 "\x00\x00\x00\x01" "5643ef8a"
+ 11 "\x80\x00\x00\x00" "cc1d6927"
+}
+
+foreach impl [implementations] {
+ select_implementation $impl
+ foreach {n msg expected} $tests {
+ test crc32bugs-$impl-1.$n "crc32 (crc32 and crc16 comparison)" {
+ set r [catch {
+ list [::crc::crc32 -format %x $msg] \
+ [::crc::crc-32 -format %x $msg]
+ } err]
+ if {$r} {lappend err $::errorInfo}
+ list $r $err
+ } [list 0 [list $expected $expected]]
+ }
+}
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/crc/crcc.tcl b/tcllib/modules/crc/crcc.tcl
new file mode 100644
index 0000000..a1b34a0
--- /dev/null
+++ b/tcllib/modules/crc/crcc.tcl
@@ -0,0 +1,22 @@
+# crcc.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Place holder for building a critcl C module for this tcllib module.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# $Id: crcc.tcl,v 1.4 2008/03/25 07:15:35 andreas_kupries Exp $
+
+package require critcl
+
+namespace eval ::crc {
+ variable rcsid {$Id: crcc.tcl,v 1.4 2008/03/25 07:15:35 andreas_kupries Exp $}
+
+ critcl::ccode {
+ /* no code required in this file */
+ }
+}
+
+# @sak notprovided crcc
+package provide crcc 1.0.0 \ No newline at end of file
diff --git a/tcllib/modules/crc/pkgIndex.tcl b/tcllib/modules/crc/pkgIndex.tcl
new file mode 100644
index 0000000..fe33b2e
--- /dev/null
+++ b/tcllib/modules/crc/pkgIndex.tcl
@@ -0,0 +1,5 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded cksum 1.1.4 [list source [file join $dir cksum.tcl]]
+package ifneeded crc16 1.1.2 [list source [file join $dir crc16.tcl]]
+package ifneeded crc32 1.3.2 [list source [file join $dir crc32.tcl]]
+package ifneeded sum 1.1.2 [list source [file join $dir sum.tcl]]
diff --git a/tcllib/modules/crc/sum.bench b/tcllib/modules/crc/sum.bench
new file mode 100644
index 0000000..aa3f1b1
--- /dev/null
+++ b/tcllib/modules/crc/sum.bench
@@ -0,0 +1,38 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'crc32' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+set moddir [file dirname [file dirname [info script]]]
+lappend auto_path $moddir
+
+package forget sum
+catch {namespace delete ::crc}
+source [file join [file dirname [info script]] sum.tcl]
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+foreach n {1 10 100 1000 10000} {
+ bench -desc "SUM $n" -pre {
+ set str [string repeat " " $n]
+ } -body {
+ crc::sum $str
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/crc/sum.man b/tcllib/modules/crc/sum.man
new file mode 100644
index 0000000..bae7f12
--- /dev/null
+++ b/tcllib/modules/crc/sum.man
@@ -0,0 +1,108 @@
+[vset SUM_VERSION 1.1.2]
+[manpage_begin sum n [vset SUM_VERSION]]
+[see_also cksum(n)]
+[see_also crc32(n)]
+[see_also sum(1)]
+[keywords checksum]
+[keywords cksum]
+[keywords crc]
+[keywords crc32]
+[keywords {cyclic redundancy check}]
+[keywords {data integrity}]
+[keywords security]
+[keywords sum]
+[copyright {2002, Pat Thoyts <patthoyts@users.sourceforge.net>}]
+[moddesc {Cyclic Redundancy Checks}]
+[titledesc {Calculate a sum(1) compatible checksum}]
+[category {Hashes, checksums, and encryption}]
+[require Tcl 8.2]
+[require sum [opt [vset SUM_VERSION]]]
+[description]
+[para]
+
+This package provides a Tcl-only implementation of the sum(1) command
+which calculates a 16 bit checksum value from the input data. The BSD
+sum algorithm is used by default but the SysV algorithm is also
+available.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd "::crc::sum"] \
+ [opt "[arg -bsd] | [arg -sysv]"] \
+ [opt [arg "-format fmt"]] \
+ [opt [arg "-chunksize size"]] \
+ [lb] [arg "-filename file"] | \
+ [arg "-channel chan"] | [arg "string"] [rb]]
+
+The command takes string data or a file name or a channel and returns
+a checksum value calculated using the [syscmd sum(1)] algorithm. The
+result is formatted using the [arg format](n) specifier provided or as
+an unsigned integer (%u) by default.
+
+[list_end]
+
+[section OPTIONS]
+
+[list_begin definitions]
+
+[def "-sysv"]
+
+The SysV algorithm is fairly naive. The byte values are summed and any
+overflow is discarded. The lowest 16 bits are returned as the
+checksum. Input with the same content but different ordering will
+give the same result.
+
+[def "-bsd"]
+
+This algorithm is similar to the SysV version but includes a bit rotation
+step which provides a dependency on the order of the data values.
+
+[def "-filename [arg name]"]
+
+Return a checksum for the file contents instead of for parameter data.
+
+[def "-channel [arg chan]"]
+
+Return a checksum for the contents of the specified channel. The
+channel must be open for reading and should be configured for binary
+translation. The channel will no be closed on completion.
+
+[def "-chunksize [arg size]"]
+
+Set the block size used when reading data from either files or
+channels. This value defaults to 4096.
+
+[def "-format [arg string]"]
+
+Return the checksum using an alternative format template.
+
+[list_end]
+
+[section EXAMPLES]
+
+[para]
+[example {
+% crc::sum "Hello, World!"
+37287
+}]
+
+[para]
+[example {
+% crc::sum -format 0x%X "Hello, World!"
+0x91A7
+}]
+
+[para]
+[example {
+% crc::sum -file sum.tcl
+13392
+}]
+
+[section AUTHORS]
+Pat Thoyts
+
+[vset CATEGORY crc]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/crc/sum.pcx b/tcllib/modules/crc/sum.pcx
new file mode 100644
index 0000000..1168d68
--- /dev/null
+++ b/tcllib/modules/crc/sum.pcx
@@ -0,0 +1,38 @@
+# -*- tcl -*- sum.pcx
+# Syntax of the commands provided by package sum.
+
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register sum
+pcx::tcldep 1.1.0 needs tcl 8.2
+
+namespace eval ::sum {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.1.0 std ::crc::sum \
+ {checkConstrained {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ -bsd
+ -sysv
+ {-channel {checkSetConstraint fn checkChannelID}}
+ {-chunksize checkInt}
+ {-filename {checkSetConstraint fn checkFileName}}
+ {-format checkWord}
+ {-timeout checkWholeNum}
+ --
+ } {checkConstraint {
+ {fn {checkSimpleArgs 0 0 {}}}
+ {!fn {checkSimpleArgs 1 1 checkWord}}
+ } {}}}
+ }}}
+
+# Initialization via pcx::init.
+# Use a ::sum::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/crc/sum.tcl b/tcllib/modules/crc/sum.tcl
new file mode 100644
index 0000000..a35aa8f
--- /dev/null
+++ b/tcllib/modules/crc/sum.tcl
@@ -0,0 +1,285 @@
+# sum.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Provides a Tcl only implementation of the unix sum(1) command. There are
+# a number of these and they use differing algorithms to get a checksum of
+# the input data. We provide two: one using the BSD algorithm and the other
+# using the SysV algorithm. More consistent results across multiple
+# implementations can be obtained by using cksum(1).
+#
+# These commands have been checked against the GNU sum program from the GNU
+# textutils package version 2.0 to ensure the same results.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.2; # tcl minimum version
+
+catch {package require tcllibc}; # critcl enhancements to tcllib
+#catch {package require crcc}; # critcl enhanced crc module
+
+namespace eval ::crc {
+ namespace export sum
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 0
+ }
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# The SysV algorithm is fairly naive. The byte values are summed and any
+# overflow is discarded. The lowest 16 bits are returned as the checksum.
+# Notes:
+# Input with the same content but different ordering will give the same
+# result.
+#
+proc ::crc::SumSysV {s {seed 0}} {
+ set t $seed
+ binary scan $s c* r
+ foreach n $r {
+ incr t [expr {$n & 0xFF}]
+ }
+
+ set t [expr {$t & 0xffffffff}]
+ set t [expr {($t & 0xffff) + ($t >> 16)}]
+ set t [expr {($t & 0xffff) + ($t >> 16)}]
+
+ return $t
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# This algorithm is similar to the SysV version but includes a bit rotation
+# step which provides a dependency on the order of the data values.
+#
+proc ::crc::SumBsd {s {seed 0}} {
+ set t $seed
+ binary scan $s c* r
+ foreach n $r {
+ set t [expr {($t & 1) ? (($t >> 1) + 0x8000) : ($t >> 1)}]
+ set t [expr {($t + ($n & 0xFF)) & 0xFFFF}]
+ }
+ return $t
+}
+
+# -------------------------------------------------------------------------
+
+if {[package provide critcl] != {}} {
+ namespace eval ::crc {
+ critcl::ccommand SumSysV_c {dummy interp objc objv} {
+ int r = TCL_OK;
+ unsigned int t = 0;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "data ?seed?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 3)
+ r = Tcl_GetIntFromObj(interp, objv[2], (int *)&t);
+
+ if (r == TCL_OK) {
+ int cn, size;
+ unsigned char *data;
+
+ data = Tcl_GetByteArrayFromObj(objv[1], &size);
+ for (cn = 0; cn < size; cn++)
+ t += data[cn];
+ }
+
+ t = t & 0xffffffffLU;
+ t = (t & 0xffff) + (t >> 16);
+ t = (t & 0xffff) + (t >> 16);
+
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(t));
+ return r;
+ }
+
+ critcl::ccommand SumBsd_c {dummy interp objc objv} {
+ int r = TCL_OK;
+ unsigned int t = 0;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "data ?seed?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 3)
+ r = Tcl_GetIntFromObj(interp, objv[2], (int *)&t);
+
+ if (r == TCL_OK) {
+ int cn, size;
+ unsigned char *data;
+
+ data = Tcl_GetByteArrayFromObj(objv[1], &size);
+ for (cn = 0; cn < size; cn++) {
+ t = (t & 1) ? ((t >> 1) + 0x8000) : (t >> 1);
+ t = (t + data[cn]) & 0xFFFF;
+ }
+ }
+
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(t & 0xFFFF));
+ return r;
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+# Switch from pure tcl to compiled if available.
+#
+if {[info commands ::crc::SumBsd_c] == {}} {
+ interp alias {} ::crc::sum-bsd {} ::crc::SumBsd
+} else {
+ interp alias {} ::crc::sum-bsd {} ::crc::SumBsd_c
+}
+
+if {[info commands ::crc::SumSysV_c] == {}} {
+ interp alias {} ::crc::sum-sysv {} ::crc::SumSysV
+} else {
+ interp alias {} ::crc::sum-sysv {} ::crc::SumSysV_c
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::crc::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# timeout handler for the chunked file handling
+# This avoids us waiting for ever
+#
+proc ::crc::SumTimeout {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+ set state(error) "operation timed out"
+ set state(reading) 0
+}
+
+# -------------------------------------------------------------------------
+# fileevent handler for chunked file handling.
+#
+proc ::crc::SumChunk {token channel} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {[eof $channel]} {
+ fileevent $channel readable {}
+ set state(reading) 0
+ }
+
+ after cancel $state(after)
+ set state(after) [after $state(timeout) \
+ [list [namespace origin SumTimeout] $token]]
+ set state(result) [$state(algorithm) \
+ [read $channel $state(chunksize)] \
+ $state(result)]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Provide a Tcl equivalent of the unix sum(1) command. We default to the
+# BSD algorithm and return a checkum for the input string unless a filename
+# has been provided. Using sum on a file should give the same results as
+# the unix sum command with equivalent algorithm.
+# Options:
+# -bsd - use the BSD algorithm to calculate the checksum (default)
+# -sysv - use the SysV algorithm to calculate the checksum
+# -filename name - return a checksum for the specified file
+# -format string - return the checksum using this format string
+#
+proc ::crc::sum {args} {
+ array set opts [list -filename {} -channel {} -chunksize 4096 \
+ -timeout 30000 -bsd 1 -sysv 0 -format %u \
+ algorithm [namespace origin sum-bsd]]
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -bsd { set opts(-bsd) 1 ; set opts(-sysv) 0 }
+ -sysv { set opts(-bsd) 0 ; set opts(-sysv) 1 }
+ -file* { set opts(-filename) [Pop args 1] }
+ -for* { set opts(-format) [Pop args 1] }
+ -chan* { set opts(-channel) [Pop args 1] }
+ -chunk* { set opts(-chunksize) [Pop args 1] }
+ -time* { set opts(-timeout) [Pop args 1] }
+ -- { Pop args ; break }
+ default {
+ set err [join [lsort [array names opts -*]] ", "]
+ return -code error "bad option $option:\
+ must be one of $err"
+ }
+ }
+ Pop args
+ }
+
+ # Set the correct sum algorithm
+ if {$opts(-sysv)} {
+ set opts(algorithm) [namespace origin sum-sysv]
+ }
+
+ # If a file was given - open it for binary reading.
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \
+ \"sum ?-bsd|-sysv? ?-format string? ?-chunksize size? \
+ ?-timeout ms? -file name | -channel chan | data\""
+ }
+ set r [$opts(algorithm) [lindex $args 0]]
+
+ } else {
+
+ # Create a unique token for the event handling
+ variable uid
+ set token [namespace current]::[incr uid]
+ upvar #0 $token tok
+ array set tok [list reading 1 result 0 timeout $opts(-timeout) \
+ chunksize $opts(-chunksize) \
+ algorithm $opts(algorithm)]
+ set tok(after) [after $tok(timeout) \
+ [list [namespace origin SumTimeout] $token]]
+
+ fileevent $opts(-channel) readable \
+ [list [namespace origin SumChunk] $token $opts(-channel)]
+ vwait [subst $token](reading)
+
+ # If we opened the channel we must close it too.
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+
+ # Extract the result or error message if there was a problem.
+ set r $tok(result)
+ if {[info exists tok(error)]} {
+ return -code error $tok(error)
+ }
+
+ unset tok
+ }
+
+ return [format $opts(-format) $r]
+}
+
+# -------------------------------------------------------------------------
+
+package provide sum 1.1.2
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/crc/sum.test b/tcllib/modules/crc/sum.test
new file mode 100644
index 0000000..88f938d
--- /dev/null
+++ b/tcllib/modules/crc/sum.test
@@ -0,0 +1,196 @@
+# sum.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Tests for the Tcllib sum command
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: sum.test,v 1.8 2006/10/09 21:41:40 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+testing {
+ useLocal sum.tcl sum ::crc
+}
+
+# -------------------------------------------------------------------------
+
+if {[info commands ::crc::SumBsd_c] == {}} {
+ puts "> pure tcl"
+} else {
+ puts "> critcl based"
+}
+
+# -------------------------------------------------------------------------
+
+test sum-1.0 {sum with no parameters} -body {
+ ::crc::sum
+} -returnCodes error -result {wrong # args: should be "sum ?-bsd|-sysv? ?-format string? ?-chunksize size? ?-timeout ms? -file name | -channel chan | data"}
+
+test sum-1.1 {sum with incorrect parameters} -body {
+ ::crc::sum -zxcv
+} -returnCodes error -result {bad option -zxcv: must be one of -bsd, -channel, -chunksize, -filename, -format, -sysv, -timeout}
+
+# -------------------------------------------------------------------------
+
+foreach {n msg expected} {
+ 1 ""
+ "0"
+ 2 "a"
+ "97"
+ 3 "abc"
+ "16556"
+ 4 "cba"
+ "49322"
+ 5 "message digest"
+ "26423"
+ 6 "abcdefghijklmnopqrstuvwxyz"
+ "53553"
+ 7 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+ "25587"
+ 8 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "21845"
+ 9 "\uFFFE\u0000\u0001\u0002"
+ "16418"
+} {
+ test sum-2.$n {sum using BSD algorithm and unsigned integer} -body {
+ ::crc::sum -bsd $msg
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+foreach {n msg expected} {
+ 1 ""
+ "0"
+ 2 "a"
+ "97"
+ 3 "abc"
+ "294"
+ 4 "cba"
+ "294"
+ 5 "message digest"
+ "1413"
+ 6 "abcdefghijklmnopqrstuvwxyz"
+ "2847"
+ 7 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+ "5387"
+ 8 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "4200"
+ 9 "\uFFFE\u0000\u0001\u0002"
+ "257"
+} {
+ test sum-3.$n {sum using SysV algorithm and unsigned integer} -body {
+ ::crc::sum -sysv $msg
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+
+set crc::testfile [info script]
+
+proc ::crc::loaddata {filename} {
+ set f [open $filename r]
+ fconfigure $f -translation binary
+ set data [read $f]
+ close $f
+ return $data
+}
+
+test sum-4.0 {sum file option (BSD)} -body {
+ set r1 [::crc::sum -bsd -file $::crc::testfile]
+ set r2 [::crc::sum -bsd [::crc::loaddata $::crc::testfile]]
+ if {$r1 != $r2} {
+ set r "differing results: $r1 != $r2"
+ } else {
+ set r ok
+ }
+} -result ok
+
+test sum-4.1 {sum file option (SysV)} -body {
+ set r1 [::crc::sum -sysv -file $::crc::testfile]
+ set r2 [::crc::sum -sysv [::crc::loaddata $crc::testfile]]
+ if {$r1 != $r2} {
+ set r "differing results: $r1 != $r2"
+ } else {
+ set r ok
+ }
+} -result ok
+
+test sum-4.2 {sum -channel option (BSD)} -body {
+ set r1 [::crc::sum -bsd [::crc::loaddata $::crc::testfile]]
+ set f [open $::crc::testfile r]
+ fconfigure $f -translation binary
+ set r2 [::crc::sum -bsd -channel $f]
+ close $f
+ if {$r1 != $r2} {
+ set r "differing results: $r1 != $r2"
+ } else {
+ set r ok
+ }
+} -result ok
+
+test sum-4.3 {sum -channel option (SysV)} -body {
+ set r1 [::crc::sum -sysv -file $::crc::testfile]
+ set f [open $::crc::testfile r]
+ fconfigure $f -translation binary
+ set r2 [::crc::sum -sysv -channel $f]
+ close $f
+ if {$r1 != $r2} {
+ set r "differing results: $r1 != $r2"
+ } else {
+ set r ok
+ }
+} -result ok
+
+# -------------------------------------------------------------------------
+
+test sum-5.0 {sum format option (BSD)} -body {
+ ::crc::sum -bsd -format 0x%X [string repeat x 200]
+} -result 0xF8EE
+
+test sum-5.1 {sum format option (SysV)} -body {
+ ::crc::sum -sysv -format 0x%X [string repeat x 200]
+} -result 0x5DC0
+
+# -------------------------------------------------------------------------
+# ticket a80e60deb1 vectors - data over 1 KB length.
+
+foreach {n expected base count} {
+ 0 58625 a 1280
+ 1 11010 fx 640
+ 2 62980 \xfe 1280
+} {
+ test sum-6.$n {sum (sysv) over 1 K} -body {
+ crc::sum -sysv -- [string repeat $base $count]
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+# ticket 0a3d5dfe52
+
+foreach {n expected base count suffix} {
+ 0 65535 X 1489 &
+} {
+ test sum-7.$n "sum (sysv) ${base}*${count}" -body {
+ crc::sum -sysv -- [string repeat $base $count]$suffix
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+
+catch {unset ::crc::testfile}
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
+
diff --git a/tcllib/modules/cron/cron.man b/tcllib/modules/cron/cron.man
new file mode 100644
index 0000000..d3b63aa
--- /dev/null
+++ b/tcllib/modules/cron/cron.man
@@ -0,0 +1,78 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset PACKAGE_VERSION 0.1]
+[manpage_begin cron n [vset PACKAGE_VERSION]]
+[keywords {cron}]
+[keywords {odie}]
+[copyright {2015 Sean Woods <yoda@etoyoc.com>}]
+[moddesc {cron}]
+[titledesc {Tool for automating the period callback of commands}]
+[category System]
+[require Tcl 8.5]
+[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.
+
+The cron package is intended to work in time scales greater than 1 second.
+
+[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.
+
+[list_end]
+[para]
+[vset CATEGORY odie]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/cron/cron.tcl b/tcllib/modules/cron/cron.tcl
new file mode 100644
index 0000000..f799664
--- /dev/null
+++ b/tcllib/modules/cron/cron.tcl
@@ -0,0 +1,281 @@
+###
+# 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)
+
+::namespace eval ::cron {}
+
+proc ::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 $timecode
+ } else {
+ set scheduled [clock scan $timecode]
+ }
+ set now [clock seconds]
+ set info [list process $process frequency 0 command $command scheduled $scheduled lastevent $now]
+ if ![info exists processTable($process)] {
+ lappend info lastrun 0 err 0 result {}
+ }
+ foreach {field value} $info {
+ dict set processTable($process) $field $value
+ }
+ ::cron::wake
+ return $process
+}
+
+proc ::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"
+ }
+ }
+ variable processTable
+ set now [clock seconds]
+ set scheduled [expr {int(ceil($timecode+$now))}]
+ set info [list process $process frequency 0 command $command scheduled $scheduled lastevent $now]
+ if ![info exists processTable($process)] {
+ lappend info lastrun 0 err 0 result {}
+ }
+ foreach {field value} $info {
+ dict set processTable($process) $field $value
+ }
+ ::cron::wake
+ return $process
+}
+
+###
+# topic: 0776dccd7e84530fa6412e507c02487c
+###
+proc ::cron::every {process frequency command} {
+ variable processTable
+ set now [clock seconds]
+ set info [list process $process frequency $frequency command $command scheduled [expr {$now + $frequency}] lastevent $now]
+ if ![info exists processTable($process)] {
+ lappend info lastrun 0 err 0 result {}
+ }
+ foreach {field value} $info {
+ dict set processTable($process) $field $value
+ }
+ ::cron::wake
+}
+
+proc ::cron::cancel {process} {
+ variable processTable
+ unset -nocomplain processTable($process)
+}
+
+###
+# topic: 97015814408714af539f35856f85bce6
+###
+proc ::cron::run process {
+ variable processTable
+ dict set processTable($process) lastrun 0
+}
+
+proc ::cron::doOneEvent task {
+ variable lock 1
+ variable processTable
+ set now [clock seconds]
+ dict with processTable($task) {
+ set err [catch {uplevel #0 $command} result]
+ if $err {
+ puts $result
+ }
+ }
+ set lock 0
+}
+
+###
+# topic: 1f8d4726623321acc311734c1dadcd8e
+# description:
+# Run through our process table and
+# kick off overdue tasks
+###
+proc ::cron::runProcesses {} {
+ variable processTable
+ set now [clock seconds]
+ ###
+ # Determine what tasks to run this timestep
+ ###
+ set tasks {}
+ set cancellist {}
+ foreach {process} [array names processTable] {
+ dict with processTable($process) {
+ if { $scheduled <= $now } {
+ lappend tasks $process
+ if { $frequency <= 0 } {
+ lappend cancellist $process
+ } else {
+ set scheduled [expr {$frequency + $lastrun}]
+ if { $scheduled <= $now } {
+ set scheduled [expr {$frequency + $now}]
+ }
+ }
+ set lastrun $now
+ }
+ set lastevent $now
+ }
+ }
+ foreach task $tasks {
+ doOneEvent $task
+ }
+ foreach {task} $cancellist {
+ unset -nocomplain processTable($task)
+ }
+}
+
+###
+# topic: 2f5a33d28948c4514764bd2f58b750fc
+# description:
+# Called once per second, and timed to ensure
+# we run in roughly realtime
+###
+proc ::cron::runTasks {} {
+ variable lastcall
+ after cancel $lastcall
+ ###
+ # Run the processes before we kick off another task...
+ ###
+ catch {runProcesses}
+ variable processTable
+ ###
+ # Look at our schedule and book the next timeslot
+ # or 15 minutes, whichever is sooner
+ ###
+ set now [clock seconds]
+ set nexttime [expr {$now - ($now % 900) + 900}]
+ foreach {process} [array names processTable] {
+ dict with processTable($process) {
+ if {$scheduled > $now && $scheduled < $nexttime} {
+ set nexttime $scheduled
+ }
+ }
+ }
+ ###
+ # Try to get the event to fire off on the border of the
+ # nearest second
+ ###
+ if { $nexttime > $now } {
+ set ctime [clock milliseconds]
+ set next [expr {($nexttime-$now)*1000-1000+($ctime % 1000)}]
+ } else {
+ set next 0
+ }
+ set lastcall [after $next [namespace current]::runTasks]
+}
+
+
+###
+# topic: 21de7bb8db019f3a2fd5a6ae9b38fd55
+# description:
+# Called once per second, and timed to ensure
+# we run in roughly realtime
+###
+proc ::cron::runTasksCoro {} {
+ variable lastcall
+ after cancel $lastcall
+ ###
+ # Do this forever
+ ###
+ variable processTable
+ variable processing
+ while 1 {
+ set lastevent 0
+ set nextevent 0
+ set now [clock seconds]
+ ###
+ # Determine what tasks to run this timestep
+ ###
+ set tasks {}
+ set cancellist {}
+ foreach {process} [lsort -dictionary [array names processTable]] {
+ dict with processTable($process) {
+ if { $scheduled <= $now } {
+ lappend tasks $process
+ if { $frequency <= 0 } {
+ lappend cancellist $process
+ } else {
+ set scheduled [expr {$frequency + $lastrun}]
+ if { $scheduled <= $now } {
+ set scheduled [expr {$frequency + $now}]
+ }
+ }
+ set lastrun $now
+ } else {
+ if {$nextevent==0 || $scheduled < $nextevent} {
+ set $nextevent $scheduled
+ }
+ }
+ set lastevent $now
+ }
+ }
+ foreach task $tasks {
+ doOneEvent $task
+ yield 0
+ }
+
+ foreach {task} $cancellist {
+ unset -nocomplain processTable($task)
+ }
+ if {$nextevent==0} {
+ # Wake me up in 5 minutes, just out of principle
+ yield 300
+ } else {
+ yield $nextevent
+ }
+ }
+}
+
+
+
+proc ::cron::wake {} {
+ variable lock
+ ##
+ # Only triggered by cron jobs kicking off other cron jobs within
+ # the script body
+ ##
+ if {$lock} return
+ ::cron::runTasks
+}
+
+###
+# 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 lock 0
+}
+
+::cron::wake
+package provide cron 1.2.1
+
diff --git a/tcllib/modules/cron/cron.test b/tcllib/modules/cron/cron.test
new file mode 100644
index 0000000..8fd2788
--- /dev/null
+++ b/tcllib/modules/cron/cron.test
@@ -0,0 +1,83 @@
+# 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) 2014 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.5
+testsNeedTcltest 1.0
+
+testing {
+ useLocal cron.tcl cron
+}
+
+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
+
+# Test that in X seconds our timer
+# was incremented X times
+vwait pause
+test cron-1.4 {cron::every} {
+ set ::timecounter
+} [expr {[clock seconds]-$now}]
+
+test cron-1.5 {cron::at2} {
+ set ::timerevent
+} 2
+
+###
+# Confirm cancel works
+::cron::cancel timecounter
+set timecounterfinal $::timecounter
+
+after 2000 {set pause 0}
+vwait pause
+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
+
+after 6000 {set pause 0}
+vwait pause
+test cron-1.8 {cron::in} {
+ set ::inevent
+} 1
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/cron/pkgIndex.tcl b/tcllib/modules/cron/pkgIndex.tcl
new file mode 100644
index 0000000..ef73693
--- /dev/null
+++ b/tcllib/modules/cron/pkgIndex.tcl
@@ -0,0 +1,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 cron 1.2.1 [list source [file join $dir cron.tcl]]
diff --git a/tcllib/modules/csv/2926387.csv b/tcllib/modules/csv/2926387.csv
new file mode 100644
index 0000000..95d0a9c
--- /dev/null
+++ b/tcllib/modules/csv/2926387.csv
@@ -0,0 +1,4 @@
+a,b,c
+d,"e,
+e",f
+
diff --git a/tcllib/modules/csv/ChangeLog b/tcllib/modules/csv/ChangeLog
new file mode 100644
index 0000000..19fc8e1
--- /dev/null
+++ b/tcllib/modules/csv/ChangeLog
@@ -0,0 +1,339 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2013-01-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.tcl: [Bug 3575707]: Actually a feature change, the commands
+ * csv.test: join, joinlist, and joinmatrix are extended with a flag
+ * csv.pcx: argument to force use of the delimiter/quoting character,
+ * csv.man: regardless of need. Original patch by Pietro Cerutti
+ * pkgIndex.tcl: <gahr@users.sourceforge.net>. Version bumped to 0.8
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-11-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.tcl: [Bug 1724818]: Applied the patch supplied by Jeremy
+ * csv.man: Cowgar <jeremy@cowgar.com> fixing the issue. Bumped
+ * csv.test: version to 0.7.3. Extended testsuite.
+ * pkgIndex.tcl:
+
+2011-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * csv.man: [Bug 3281791]: Followup to fix for [Bug 3061815], fixed
+ forgotten change in the text after the examples. Thanks to
+ <guardus@users.sourceforge.net>.
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-09-08 Andreas Kupries <andreask@activestate.com>
+
+ * csv.man: [Bug 3061815]: Fixed a mixup in the examples which
+ matched regular output to alternate format and vice versa. Thanks
+ to Harald Oehlmann <oehhar@users.sourceforge.net>.
+
+2010-01-19 Andreas Kupries <andreask@activestate.com>
+
+ * csv.tcl (::csv::read2queue): [Bug 2926387]: Fix use of wrong
+ * csv.test: variable when handling multi-line fields reported by
+ * csv.man: Jeff Rogers <dvrsn@users.sourceforge.net>. Extended
+ * pkgIndex.tcl: testsuite. Bumped version to 0.7.2.
+ * 2926387.csv: <New file>, for the new tests.
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-09-17 Andreas Kupries <andreask@activestate.com>
+
+ * csv.man: [Bug 2860843]. Fixed two documentation typos reported
+ by Larry Virden <lvirden@users.sourceforge.net>
+
+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 ========================
+ *
+
+2008-10-02 Andreas Kupries <andreask@activestate.com>
+
+ * csv.tcl: Fixed [SF Bug 2123513]. Added protections against
+ * csv.man: malformed separator characters (empty or string) to the
+ * csv.test: read2 and split2 commands. Extended test suite to
+ * pkgIndex.tcl: cover these cases. Bumped the package version to
+ 0.7.1.
+
+2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.pcx: New file. Syntax definitions for the public commands of
+ the csv package.
+
+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>
+
+ * csv.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-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * csv.man: Bumped version to 0.7.
+ * csv.tcl:
+ * pkgIndex.tcl
+
+2006-06-15 Andreas Kupries <andreask@activestate.com>
+
+ * csv.tcl: Extended csv processing to allow different
+ * csv.test: quoting chars beyond double-quote. Patch origin at [SF
+ * csv.man: Tcllib Patch 1469593]. Needed small fix in
+ join. Extended testsuite, documentation.
+
+2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.test: Fixed use and cleanup of temp. files.
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.test: More boilerplate simplified via use of test support.
+
+2006-01-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.test: Removed some 8.4'isms out of the csv testsuite, the
+ package under test works for 8.3+.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.test: Hooked into the new common test support code.
+
+2006-01-16 Andreas Kupries <akupries@shaw.ca>
+
+ * csv.man: New command 'iscomplete' to detect partial csv
+ * csv.tcl: records. Used to enable the read2* commands to handle
+ multi-line csv records. Code provided by Jeff Hobbs, via [SF
+ Tcllib Patch 1407811]. See also the [Tcllib FR 733407].
+
+2005-10-24 Andreas Kupries <andreask@activestate.com>
+
+ * csv.bench: New file. Basic benchmarks for CSV processing.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-09-30 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Added command 'csv::joinmatrix', which converts a
+ * csv.man: matrix object into CSV records, one record per
+ * csv.tcl: row. Inspired by [SF Tcllib RFE 1204345] which
+ brought the conversion up, but went a round-about
+ way via a report object.
+
+2005-04-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.test: Testsuite package requirements fixed to ensure use of
+ local packages.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.tcl: Updated version number to sync with 1.6.1
+ * csv.man: release.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.tcl: Rel. engineering. Updated version number
+ * csv.man: of csv to reflect its changes, to 0.5.1.
+ * pkgIndex.tcl:
+
+2004-05-03 Andreas Kupries <andreask@pliers.activestate.com>
+
+ * csv.tcl (read2matrix): Fixed bogus switch case. Had case "4"
+ twice, second should have been "5". [SF Tcllib Bug 940651].
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-11-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.man: Extended the explanation for the example to cover the
+ alternate format as well [SF Tcllib RFE 737770].
+
+2003-05-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.man: Changed the phrasing for the alternate format a bit,
+ and reworded the text enclosing the example.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-24 Andreas Kupries <andreask@activestate.com>
+
+ * csv.tcl: Bumped version to 0.4. This had been
+ * csv.man: forgotten before.
+ * pkgIndex.tcl:
+
+2003-04-23 Andreas Kupries <andreask@activestate.com>
+
+ * csv.tcl (Split): Rewrote parser for alternate syntax to handle
+ the remaining known bug. Now it passes the testsuite completely.
+
+ * csv.man: Extended to handle a slightly different alternate
+ * cvs.tcl: syntax of CSV files. This takes care of bug
+ * csv.test: [606141].
+
+2003-03-31 Andreas Kupries <andreask@activestate.com>
+
+ * csv.tcl (split): Fixed bug #709123 reported by Jamie Honan
+ <jhonan@users.sourceforge.net>. The separator character is used
+ in regular epxressions, but was not protected against special
+ interpretation by the RE engine.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.man: More semantic markup, less visual one.
+
+2002-06-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.tcl (csv::split): Fixed bug #565051, found by Tod A. olson
+ <todolson@users.sourceforge.net>. The described bug is actually
+ none, given the definition of the CSV format, but the examples
+ do contain a related bug. Just swap what is seen as ok and
+ bug. Because of this the provided patched code was rejected, and
+ a new patch created. The patched code passes the extended
+ testsuite (see below).
+
+ * csv.test: Extended testsuite regarding the handling of empty
+ fields and quote characters. Part of the investigation into bug
+ #565051.
+
+2002-03-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.man: Fixed formatting errors in the doctools manpage.
+
+2002-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Version up to 0.3 to differentiate development from the
+ version in the tcllib 1.2 release.
+
+ * mem_debug_bench_a.csv: New file, contains empty lines to test
+ that part of the code. See below.
+ * csv.tcl:
+ * csv.test: Updated code and tests to cover all paths through the
+ code.
+
+2002-01-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bumped version to 0.2
+
+2001-11-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.n: Applied patch #482570 correcting a typo and adding more
+ cross-references (see also, keywords). Patch provided by Larry
+ Virden <lvirden@users.sourceforge.net>.
+
+2001-11-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.test:
+ * cvs.n:
+ * csv.tcl (split2matrix, read2matrix): Implemented FR
+ #481023. Added additional expansion behaviours, controlled via
+ an optional argument.
+
+2001-10-14 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * csv.test (csv-1.7):
+ * csv.tcl: Fixed [Bug #469855] where starting "s could not come
+ out right from csv::split.
+ Updated to 0.2
+
+2001-09-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.test: Added test to verify that the problem is fixed.
+
+ * csv.tcl (joinlist): Fixed bug [#465210] "::csv::joinlist
+ sepChar handling". The "sepChar" was not propagated to the
+ actual join operation.
+
+2001-09-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.tcl: Restricted export list to public API.
+ [456255]. Patch by Hemang Lavana
+ <hemanglavana@users.sourceforge.net>
+
+2001-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.tcl: Frink 2.2 run, fixed dubious code.
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.tcl: Fixed dubious code reported by frink and procheck.
+
+2001-06-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.n: Fixed nroff trouble.
+
+2001-05-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Committed to CVS head at SF.
+
+2001-04-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * csv.tcl: Added more code to read and write CSV formatted data
+ from and to various datastructures (queue, matrix). The basic
+ functionality is now complete.
+
+ * csv.test: Extended the testsuite to cover the new code.
+ * csv.n: Extended the documentation to cover the new code.
+
+2001-04-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module for the processing of CSV lines and files.
diff --git a/tcllib/modules/csv/csv.bench b/tcllib/modules/csv/csv.bench
new file mode 100644
index 0000000..44b21be
--- /dev/null
+++ b/tcllib/modules/csv/csv.bench
@@ -0,0 +1,45 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'csv' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.3]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+package forget csv
+catch {namespace delete ::csv}
+source [file join [file dirname [info script]] csv.tcl]
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+foreach n {1 10 100 1000 10000} {
+ bench -desc "CSV join $n" -pre {
+ set list [split [string repeat " " $n] ""]
+ } -body {
+ csv::join $list
+ } -post {
+ unset list
+ }
+
+ bench -desc "CSV split $n" -pre {
+ set str [string repeat , $n]
+ } -body {
+ csv::split $str
+ } -post {
+ unset str
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/csv/csv.man b/tcllib/modules/csv/csv.man
new file mode 100644
index 0000000..76d3259
--- /dev/null
+++ b/tcllib/modules/csv/csv.man
@@ -0,0 +1,247 @@
+[comment {-*- tcl -*-}]
+[vset VERSION 0.8.1]
+[manpage_begin csv n [vset VERSION]]
+[see_also matrix]
+[see_also queue]
+[keywords csv]
+[keywords matrix]
+[keywords package]
+[keywords queue]
+[keywords tcllib]
+[copyright {2002-2015 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {CSV processing}]
+[titledesc {Procedures to handle CSV data.}]
+[category {Text processing}]
+[require Tcl 8.4]
+[require csv [opt [vset VERSION]]]
+[description]
+
+[para]
+
+The [package csv] package provides commands to manipulate information
+in CSV [sectref FORMAT] (CSV = Comma Separated Values).
+
+[section COMMANDS]
+[para]
+
+The following commands are available:
+
+[list_begin definitions]
+
+[call [cmd ::csv::iscomplete] [arg data]]
+
+A predicate checking if the argument [arg data] is a complete csv
+record. The result is a boolean flag indicating the completeness of
+the data. The result is true if the data is complete.
+
+[call [cmd ::csv::join] [arg values] [opt [arg sepChar]] [opt [arg delChar]] [opt [arg delMode]]]
+
+Takes a list of values and returns a string in CSV format containing
+these values. The separator character can be defined by the caller,
+but this is optional. The default is ",". The quoting aka delimiting character can
+be defined by the caller, but this is optional. The default is '"'.
+
+By default the quoting mode [arg delMode] is "auto", surrounding
+values with [arg delChar] only when needed. When set to "always"
+however, values are always surrounded by the [arg delChar] instead.
+
+[call [cmd ::csv::joinlist] [arg values] [opt [arg sepChar]] [opt [arg delChar]] [opt [arg delMode]]]
+
+Takes a list of lists of values and returns a string in CSV format
+containing these values. The separator character can be defined by the
+caller, but this is optional. The default is ",". The quoting character
+can be defined by the caller, but this is optional. The default is '"'.
+
+By default the quoting mode [arg delMode] is "auto", surrounding
+values with [arg delChar] only when needed. When set to "always"
+however, values are always surrounded by the [arg delChar] instead.
+
+Each element of the outer list is considered a record, these are
+separated by newlines in the result. The elements of each record are
+formatted as usual (via [cmd ::csv::join]).
+
+[call [cmd ::csv::joinmatrix] [arg matrix] [opt [arg sepChar]] [opt [arg delChar]] [opt [arg delMode]]]
+
+Takes a [arg matrix] object following the API specified for the
+struct::matrix package and returns a string in CSV format containing
+these values. The separator character can be defined by the caller,
+but this is optional. The default is ",". The quoting character
+can be defined by the caller, but this is optional. The default is
+'"'.
+
+By default the quoting mode [arg delMode] is "auto", surrounding
+values with [arg delChar] only when needed. When set to "always"
+however, values are always surrounded by the [arg delChar] instead.
+
+Each row of the matrix is considered a record, these are
+separated by newlines in the result. The elements of each record are
+formatted as usual (via [cmd ::csv::join]).
+
+[call [cmd ::csv::read2matrix] [opt [option -alternate]] [arg "chan m"] "{[arg sepChar] ,} {[arg expand] none}"]
+
+A wrapper around [cmd ::csv::split2matrix] (see below) reading
+CSV-formatted lines from the specified channel (until EOF) and adding
+them to the given matrix. For an explanation of the [arg expand]
+argument see [cmd ::csv::split2matrix].
+
+[call [cmd ::csv::read2queue] [opt [option -alternate]] [arg "chan q"] "{[arg sepChar] ,}"]
+
+A wrapper around [cmd ::csv::split2queue] (see below) reading
+CSV-formatted lines from the specified channel (until EOF) and adding
+them to the given queue.
+
+[call [cmd ::csv::report] [arg "cmd matrix"] [opt [arg chan]]]
+
+A report command which can be used by the matrix methods
+
+[cmd "format 2string"] and [cmd "format 2chan"]. For the latter this
+command delegates the work to [cmd ::csv::writematrix]. [arg cmd] is
+expected to be either [method printmatrix] or
+
+[method printmatrix2channel]. The channel argument, [arg chan], has
+to be present for the latter and must not be present for the first.
+
+[call [cmd ::csv::split] [opt [option -alternate]] [arg line] [opt [arg sepChar]] [opt [arg delChar]]]
+
+converts a [arg line] in CSV format into a list of the values
+contained in the line. The character used to separate the values from
+each other can be defined by the caller, via [arg sepChar], but this
+is optional. The default is ",". The quoting character can be defined
+by the caller, but this is optional. The default is '"'.
+
+[para]
+
+If the option [option -alternate] is specified a slightly different
+syntax is used to parse the input. This syntax is explained below, in
+the section [sectref FORMAT].
+
+[call [cmd ::csv::split2matrix] [opt [option -alternate]] [arg "m line"] "{[arg sepChar] ,} {[arg expand] none}"]
+
+The same as [cmd ::csv::split], but appends the resulting list as a
+new row to the matrix [arg m], using the method [cmd "add row"]. The
+expansion mode specified via [arg expand] determines how the command
+handles a matrix with less columns than contained in [arg line]. The
+allowed modes are:
+
+[list_begin definitions]
+
+[def [const none]]
+
+This is the default mode. In this mode it is the responsibility of the
+caller to ensure that the matrix has enough columns to contain the
+full line. If there are not enough columns the list of values is
+silently truncated at the end to fit.
+
+[def [const empty]]
+
+In this mode the command expands an empty matrix to hold all columns
+of the specified line, but goes no further. The overall effect is that
+the first of a series of lines determines the number of columns in the
+matrix and all following lines are truncated to that size, as if mode
+[const none] was set.
+
+[def [const auto]]
+
+In this mode the command expands the matrix as needed to hold all
+columns contained in [arg line]. The overall effect is that after
+adding a series of lines the matrix will have enough columns to hold
+all columns of the longest line encountered so far.
+
+[list_end]
+
+[call [cmd ::csv::split2queue] [opt [option -alternate]] [arg "q line"] "{[arg sepChar] ,}"]
+
+The same as [cmd ::csv::split], but appending the resulting list as a
+single item to the queue [arg q], using the method [cmd put].
+
+[call [cmd ::csv::writematrix] [arg "m chan"] [opt [arg sepChar]] [opt [arg delChar]]]
+
+A wrapper around [cmd ::csv::join] taking all rows in the matrix
+[arg m] and writing them CSV formatted into the channel [arg chan].
+
+[call [cmd ::csv::writequeue] [arg "q chan"] [opt [arg sepChar]] [opt [arg delChar]]]
+
+A wrapper around [cmd ::csv::join] taking all items in the queue
+[arg q] (assumes that they are lists) and writing them CSV formatted
+into the channel [arg chan].
+
+[list_end]
+
+[section FORMAT]
+[para]
+
+The format of regular CSV files is specified as
+
+[list_begin enumerated]
+
+[enum]
+Each record of a csv file (comma-separated values, as exported e.g. by
+Excel) is a set of ASCII values separated by ",". For other languages
+it may be ";" however, although this is not important for this case as
+the functions provided here allow any separator character.
+
+[enum]
+If and only if a value contains itself the separator ",", then it (the
+value) has to be put between "". If the value does not contain the
+separator character then quoting is optional.
+
+[enum]
+If a value contains the character ", that character is represented by "".
+
+[enum]
+The output string "" represents the value ". In other words, it is
+assumed that it was created through rule 3, and only this rule,
+i.e. that the value was not quoted.
+
+[list_end]
+[para]
+
+An alternate format definition mainly used by MS products specifies
+that the output string "" is a representation of the empty
+string. In other words, it is assumed that the output was generated
+out of the empty string by quoting it (i.e. rule 2), and not through
+rule 3. This is the only difference between the regular and the
+alternate format.
+
+[para]
+
+The alternate format is activated through specification of the option
+[option -alternate] to the various split commands.
+
+[section EXAMPLE]
+
+Using the regular format the record
+
+[para]
+[example {
+123,"123,521.2","Mary says ""Hello, I am Mary""",""
+}]
+
+[para]
+is parsed into the items
+
+[para]
+[example {
+a) 123
+b) 123,521.2
+c) Mary says "Hello, I am Mary"
+d) "
+}]
+[para]
+
+Using the alternate format the result is
+
+[para]
+[example {
+a) 123
+b) 123,521.2
+c) Mary says "Hello, I am Mary"
+d) (the empty string)
+}]
+
+instead. As can be seen only item (d) is different, now the empty string
+instead of a ".
+
+[vset CATEGORY csv]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/csv/csv.pcx b/tcllib/modules/csv/csv.pcx
new file mode 100644
index 0000000..fee8344
--- /dev/null
+++ b/tcllib/modules/csv/csv.pcx
@@ -0,0 +1,144 @@
+# -*- tcl -*- csv.pcx
+# Syntax of the commands provided by package csv.
+
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register csv
+pcx::tcldep 0.7 needs tcl 8.3
+pcx::tcldep 0.8 needs tcl 8.4
+
+namespace eval ::csv {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 0.7 std ::csv::iscomplete \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 0.7 std ::csv::join \
+ {checkSimpleArgs 1 3 {
+ checkList
+ checkWord
+ checkWord
+ }}
+pcx::check 0.8 std ::csv::join \
+ {checkSimpleArgs 1 4 {
+ checkList
+ checkWord
+ checkWord
+ {checkKeyword 1 {auto always}}
+ }}
+pcx::check 0.7 std ::csv::joinlist \
+ {checkSimpleArgs 1 3 {
+ checkList
+ checkWord
+ checkWord
+ }}
+pcx::check 0.8 std ::csv::joinlist \
+ {checkSimpleArgs 1 4 {
+ checkList
+ checkWord
+ checkWord
+ {checkKeyword 1 {auto always}}
+ }}
+pcx::check 0.7 std ::csv::joinmatrix \
+ {checkSimpleArgs 1 3 {
+ checkWord
+ checkWord
+ checkWord
+ }}
+pcx::check 0.8 std ::csv::joinmatrix \
+ {checkSimpleArgs 1 4 {
+ checkWord
+ checkWord
+ checkWord
+ {checkKeyword 1 {auto always}}
+ }}
+pcx::check 0.7 std ::csv::read2matrix \
+ {checkSimpleArgs 2 -1 {
+ {checkSwitches 1 {
+ -alternate
+ } {checkSimpleArgs 1 4 {
+ checkChannelID
+ checkWord
+ checkWord
+ {checkKeyword 1 {none empty auto}}
+ }}}
+ }}
+pcx::check 0.7 std ::csv::read2queue \
+ {checkSimpleArgs 2 -1 {
+ {checkSwitches 1 {
+ -alternate
+ } {checkSimpleArgs 2 3 {
+ checkChannelID
+ checkWord
+ checkWord
+ }}}
+ }}
+pcx::check 0.7 std ::csv::report \
+ {checkSimpleArgs 2 3 {
+ {checkOption {
+ {printmatrix {checkSimpleArgs 1 1 {
+ checkWord
+ }}}
+ {printmatrix2channel {checkSimpleArgs 2 2 {
+ checkWord
+ checkChannelID
+ }}}
+ } {}}
+ }}
+pcx::check 0.7 std ::csv::split \
+ {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ -alternate
+ } {checkSimpleArgs 1 3 {
+ checkWord
+ checkWord
+ checkWord
+ }}}
+ }}
+pcx::check 0.7 std ::csv::split2matrix \
+ {checkSimpleArgs 2 -1 {
+ {checkSwitches 1 {
+ -alternate
+ } {checkSimpleArgs 1 4 {
+ checkChannelID
+ checkWord
+ checkWord
+ {checkKeyword 1 {none empty auto}}
+ }}}
+ }}
+pcx::check 0.7 std ::csv::split2queue \
+ {checkSimpleArgs 2 -1 {
+ {checkSwitches 1 {
+ -alternate
+ } {checkSimpleArgs 2 3 {
+ checkChannelID
+ checkWord
+ checkWord
+ }}}
+ }}
+pcx::check 0.7 std ::csv::writematrix \
+ {checkSimpleArgs 2 4 {
+ checkWord
+ checkChannelID
+ checkWord
+ checkWord
+ }}
+pcx::check 0.7 std ::csv::writequeue \
+ {checkSimpleArgs 2 4 {
+ checkWord
+ checkChannelID
+ checkWord
+ checkWord
+ }}
+
+# Initialization via pcx::init.
+# Use a ::csv::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/csv/csv.tcl b/tcllib/modules/csv/csv.tcl
new file mode 100644
index 0000000..a76336f
--- /dev/null
+++ b/tcllib/modules/csv/csv.tcl
@@ -0,0 +1,789 @@
+# csv.tcl --
+#
+# Tcl implementations of CSV reader and writer
+#
+# Copyright (c) 2001 by Jeffrey Hobbs
+# Copyright (c) 2001-2013 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: csv.tcl,v 1.28 2011/11/23 02:22:10 andreas_kupries Exp $
+
+package require Tcl 8.4
+package provide csv 0.8.1
+
+namespace eval ::csv {
+ namespace export join joinlist read2matrix read2queue report
+ namespace export split split2matrix split2queue writematrix writequeue
+}
+
+# ::csv::join --
+#
+# Takes a list of values and generates a string in CSV format.
+#
+# Arguments:
+# values A list of the values to join
+# sepChar The separator character, defaults to comma
+# delChar The delimiter character, defaults to quote
+# delMode If set to 'always', values are always surrounded by delChar
+#
+# Results:
+# A string containing the values in CSV format.
+
+proc ::csv::join {values {sepChar ,} {delChar \"} {delMode auto}} {
+ set out ""
+ set sep {}
+ foreach val $values {
+ if {($delMode eq "always") || [string match "*\[${delChar}$sepChar\r\n\]*" $val]} {
+ append out $sep${delChar}[string map [list $delChar ${delChar}${delChar}] $val]${delChar}
+ } else {
+ append out $sep${val}
+ }
+ set sep $sepChar
+ }
+ return $out
+}
+
+# ::csv::joinlist --
+#
+# Takes a list of lists of values and generates a string in CSV
+# format. Each item in the list is made into a single CSV
+# formatted record in the final string, the records being
+# separated by newlines.
+#
+# Arguments:
+# values A list of the lists of the values to join
+# sepChar The separator character, defaults to comma
+# delChar The delimiter character, defaults to quote
+# delMode If set to 'always', values are always surrounded by delChar
+#
+# Results:
+# A string containing the values in CSV format, the records
+# separated by newlines.
+
+proc ::csv::joinlist {values {sepChar ,} {delChar \"} {delMode auto}} {
+ set out ""
+ foreach record $values {
+ # note that this is ::csv::join
+ append out "[join $record $sepChar $delChar $delMode]\n"
+ }
+ return $out
+}
+
+# ::csv::joinmatrix --
+#
+# Takes a matrix object following the API specified for the
+# struct::matrix package. Each row of the matrix is converted
+# into a single CSV formatted record in the final string, the
+# records being separated by newlines.
+#
+# Arguments:
+# matrix Matrix object command.
+# sepChar The separator character, defaults to comma
+# delChar The delimiter character, defaults to quote
+# delMode If set to 'always', values are always surrounded by delChar
+#
+# Results:
+# A string containing the values in CSV format, the records
+# separated by newlines.
+
+proc ::csv::joinmatrix {matrix {sepChar ,} {delChar \"} {delMode auto}} {
+ return [joinlist [$matrix get rect 0 0 end end] $sepChar $delChar $delMode]
+}
+
+# ::csv::iscomplete --
+#
+# A predicate checking if the argument is a complete csv record.
+#
+# Arguments
+# data The (partial) csv record to check.
+#
+# Results:
+# A boolean flag indicating the completeness of the data. The
+# result is true if the data is complete.
+
+proc ::csv::iscomplete {data} {
+ expr {1 - [regexp -all \" $data] % 2}
+}
+
+# ::csv::read2matrix --
+#
+# A wrapper around "Split2matrix" reading CSV formatted
+# lines from the specified channel and adding it to the given
+# matrix.
+#
+# Arguments:
+# m The matrix to add the read data too.
+# chan The channel to read from.
+# sepChar The separator character, defaults to comma
+# expand The expansion mode. The default is none
+#
+# Results:
+# A list of the values in 'line'.
+
+proc ::csv::read2matrix {args} {
+ # FR #481023
+ # See 'split2matrix' for the available expansion modes.
+
+ # Argument syntax:
+ #
+ #2) chan m
+ #3) chan m sepChar
+ #3) -alternate chan m
+ #4) -alternate chan m sepChar
+ #4) chan m sepChar expand
+ #5) -alternate chan m sepChar expand
+
+ set alternate 0
+ set sepChar ,
+ set expand none
+
+ switch -exact -- [llength $args] {
+ 2 {
+ foreach {chan m} $args break
+ }
+ 3 {
+ foreach {a b c} $args break
+ if {[string equal $a "-alternate"]} {
+ set alternate 1
+ set chan $b
+ set m $c
+ } else {
+ set chan $a
+ set m $b
+ set sepChar $c
+ }
+ }
+ 4 {
+ foreach {a b c d} $args break
+ if {[string equal $a "-alternate"]} {
+ set alternate 1
+ set chan $b
+ set m $c
+ set sepChar $d
+ } else {
+ set chan $a
+ set m $b
+ set sepChar $c
+ set expand $d
+ }
+ }
+ 5 {
+ foreach {a b c d e} $args break
+ if {![string equal $a "-alternate"]} {
+ return -code error "wrong#args: Should be ?-alternate? chan m ?separator? ?expand?"
+ }
+ set alternate 1
+
+ set chan $b
+ set m $c
+ set sepChar $d
+ set expand $e
+ }
+ 0 - 1 -
+ default {
+ return -code error "wrong#args: Should be ?-alternate? chan m ?separator? ?expand?"
+ }
+ }
+
+ if {[string length $sepChar] < 1} {
+ return -code error "illegal separator character \"$sepChar\", is empty"
+ } elseif {[string length $sepChar] > 1} {
+ return -code error "illegal separator character \"$sepChar\", is a string"
+ }
+
+ set data ""
+ while {![eof $chan]} {
+ if {[gets $chan line] < 0} {continue}
+
+ # Why skip empty lines? They may be in data. Except if the
+ # buffer is empty, i.e. we are between records.
+ if {$line == {} && $data == {}} {continue}
+
+ append data $line
+ if {![iscomplete $data]} {
+ # Odd number of quotes - must have embedded newline
+ append data \n
+ continue
+ }
+
+ Split2matrix $alternate $m $data $sepChar $expand
+ set data ""
+ }
+ return
+}
+
+# ::csv::read2queue --
+#
+# A wrapper around "::csv::split2queue" reading CSV formatted
+# lines from the specified channel and adding it to the given
+# queue.
+#
+# Arguments:
+# q The queue to add the read data too.
+# chan The channel to read from.
+# sepChar The separator character, defaults to comma
+#
+# Results:
+# A list of the values in 'line'.
+
+proc ::csv::read2queue {args} {
+ # Argument syntax:
+ #
+ #2) chan q
+ #3) chan q sepChar
+ #3) -alternate chan q
+ #4) -alternate chan q sepChar
+
+ set alternate 0
+ set sepChar ,
+
+ switch -exact -- [llength $args] {
+ 2 {
+ foreach {chan q} $args break
+ }
+ 3 {
+ foreach {a b c} $args break
+ if {[string equal $a "-alternate"]} {
+ set alternate 1
+ set chan $b
+ set q $c
+ } else {
+ set chan $a
+ set q $b
+ set sepChar $c
+ }
+ }
+ 4 {
+ foreach {a b c d} $args break
+ if {![string equal $a "-alternate"]} {
+ return -code error "wrong#args: Should be ?-alternate? chan q ?separator?"
+ }
+ set alternate 1
+ set chan $b
+ set q $c
+ set sepChar $d
+ }
+ 0 - 1 -
+ default {
+ return -code error "wrong#args: Should be ?-alternate? chan q ?separator?"
+ }
+ }
+
+ if {[string length $sepChar] < 1} {
+ return -code error "illegal separator character \"$sepChar\", is empty"
+ } elseif {[string length $sepChar] > 1} {
+ return -code error "illegal separator character \"$sepChar\", is a string"
+ }
+
+ set data ""
+ while {![eof $chan]} {
+ if {[gets $chan line] < 0} {continue}
+
+ # Why skip empty lines? They may be in data. Except if the
+ # buffer is empty, i.e. we are between records.
+ if {$line == {} && $data == {}} {continue}
+
+ append data $line
+ if {![iscomplete $data]} {
+ # Odd number of quotes - must have embedded newline
+ append data \n
+ continue
+ }
+
+ $q put [Split $alternate $data $sepChar]
+ set data ""
+ }
+ return
+}
+
+# ::csv::report --
+#
+# A report command which can be used by the matrix methods
+# "format-via" and "format2chan-via". For the latter this
+# command delegates the work to "::csv::writematrix". "cmd" is
+# expected to be either "printmatrix" or
+# "printmatrix2channel". The channel argument, "chan", has to
+# be present for the latter and must not be present for the first.
+#
+# Arguments:
+# cmd Either 'printmatrix' or 'printmatrix2channel'
+# matrix The matrix to format.
+# args 0 (chan): The channel to write to
+#
+# Results:
+# None for 'printmatrix2channel', else the CSV formatted string.
+
+proc ::csv::report {cmd matrix args} {
+ switch -exact -- $cmd {
+ printmatrix {
+ if {[llength $args] > 0} {
+ return -code error "wrong # args:\
+ ::csv::report printmatrix matrix"
+ }
+ return [joinlist [$matrix get rect 0 0 end end]]
+ }
+ printmatrix2channel {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args:\
+ ::csv::report printmatrix2channel matrix chan"
+ }
+ writematrix $matrix [lindex $args 0]
+ return ""
+ }
+ default {
+ return -code error "Unknown method $cmd"
+ }
+ }
+}
+
+# ::csv::split --
+#
+# Split a string according to the rules for CSV processing.
+# This assumes that the string contains a single line of CSVs
+#
+# Arguments:
+# line The string to split
+# sepChar The separator character, defaults to comma
+#
+# Results:
+# A list of the values in 'line'.
+
+proc ::csv::split {args} {
+ # Argument syntax:
+ #
+ # (1) line
+ # (2) line sepChar
+ # (2) -alternate line
+ # (3) -alternate line sepChar
+
+ # (3) line sepChar delChar
+ # (4) -alternate line sepChar delChar
+
+ set alternate 0
+ set sepChar ,
+ set delChar \"
+
+ switch -exact -- [llength $args] {
+ 1 {
+ set line [lindex $args 0]
+ }
+ 2 {
+ foreach {a b} $args break
+ if {[string equal $a "-alternate"]} {
+ set alternate 1
+ set line $b
+ } else {
+ set line $a
+ set sepChar $b
+ }
+ }
+ 3 {
+ foreach {a b c} $args break
+ if {[string equal $a "-alternate"]} {
+ set alternate 1
+ set line $b
+ set sepChar $c
+ } else {
+ set line $a
+ set sepChar $b
+ set delChar $c
+ }
+ }
+ 4 {
+ foreach {a b c d} $args break
+ if {![string equal $a "-alternate"]} {
+ return -code error "wrong#args: Should be ?-alternate? line ?separator? ?delimiter?"
+ }
+ set alternate 1
+ set line $b
+ set sepChar $c
+ set delChar $d
+ }
+ 0 -
+ default {
+ return -code error "wrong#args: Should be ?-alternate? line ?separator? ?delimiter?"
+ }
+ }
+
+ if {[string length $sepChar] < 1} {
+ return -code error "illegal separator character ${delChar}$sepChar${delChar}, is empty"
+ } elseif {[string length $sepChar] > 1} {
+ return -code error "illegal separator character ${delChar}$sepChar${delChar}, is a string"
+ }
+
+ if {[string length $delChar] < 1} {
+ return -code error "illegal separator character \"$delChar\", is empty"
+ } elseif {[string length $delChar] > 1} {
+ return -code error "illegal separator character \"$delChar\", is a string"
+ }
+
+ return [Split $alternate $line $sepChar $delChar]
+}
+
+proc ::csv::Split {alternate line sepChar {delChar \"}} {
+ # Protect the sepchar from special interpretation by
+ # the regex calls below.
+
+ set sepRE \[\[.${sepChar}.]]
+ set delRE \[\[.${delChar}.]]
+
+ if {$alternate} {
+ # The alternate syntax requires a different parser.
+ # A variation of the string map / regsub parser for the
+ # regular syntax was tried but does not handle embedded
+ # doubled " well (testcase csv-91.3 was 'knownBug', sole
+ # one, still a bug). Now we just tokenize the input into
+ # the primary parts (sep char, "'s and the rest) and then
+ # use an explicitly coded state machine (DFA) to parse
+ # and convert token sequences.
+
+ ## puts 1->>$line<<
+ set line [string map [list \
+ $sepChar \0$sepChar\0 \
+ $delChar \0${delChar}\0 \
+ ] $line]
+
+ ## puts 2->>$line<<
+ set line [string map [list \0\0 \0] $line]
+ regsub "^\0" $line {} line
+ regsub "\0$" $line {} line
+
+ ## puts 3->>$line<<
+
+ set val ""
+ set res ""
+ set state base
+
+ ## puts 4->>[::split $line \0]
+ foreach token [::split $line \0] {
+
+ ## puts "\t*= $state\t>>$token<<"
+ switch -exact -- $state {
+ base {
+ if {[string equal $token "${delChar}"]} {
+ set state qvalue
+ continue
+ }
+ if {[string equal $token $sepChar]} {
+ lappend res $val
+ set val ""
+ continue
+ }
+ append val $token
+ }
+ qvalue {
+ if {[string equal $token "${delChar}"]} {
+ # May end value, may be a doubled "
+ set state endordouble
+ continue
+ }
+ append val $token
+ }
+ endordouble {
+ if {[string equal $token "${delChar}"]} {
+ # Doubled ", append to current value
+ append val ${delChar}
+ set state qvalue
+ continue
+ }
+ # Last " was end of quoted value. Close it.
+ # We expect current as $sepChar
+
+ lappend res $val
+ set val ""
+ set state base
+
+ if {[string equal $token $sepChar]} {continue}
+
+ # Undoubled " in middle of text. Just assume that
+ # remainder is another qvalue.
+ set state qvalue
+ }
+ default {
+ return -code error "Internal error, illegal parsing state"
+ }
+ }
+ }
+
+ ## puts "/= $state\t>>$val<<"
+
+ lappend res $val
+
+ ## puts 5->>$res<<
+ return $res
+ } else {
+ regsub -- "$sepRE${delRE}${delRE}$" $line $sepChar\0${delChar}${delChar}\0 line
+ regsub -- "^${delRE}${delRE}$sepRE" $line \0${delChar}${delChar}\0$sepChar line
+ regsub -all -- {(^${delChar}|${delChar}$)} $line \0 line
+
+ set line [string map [list \
+ $sepChar${delChar}${delChar}${delChar} $sepChar\0${delChar} \
+ ${delChar}${delChar}${delChar}$sepChar ${delChar}\0$sepChar \
+ ${delChar}${delChar} ${delChar} \
+ ${delChar} \0 \
+ ] $line]
+
+ set end 0
+ while {[regexp -indices -start $end -- {(\0)[^\0]*(\0)} $line \
+ -> start end]} {
+ set start [lindex $start 0]
+ set end [lindex $end 0]
+ set range [string range $line $start $end]
+ if {[string first $sepChar $range] >= 0} {
+ set line [string replace $line $start $end \
+ [string map [list $sepChar \1] $range]]
+ }
+ incr end
+ }
+ set line [string map [list $sepChar \0 \1 $sepChar \0 {} ] $line]
+ return [::split $line \0]
+
+ }
+}
+
+# ::csv::split2matrix --
+#
+# Split a string according to the rules for CSV processing.
+# This assumes that the string contains a single line of CSVs.
+# The resulting list of values is appended to the specified
+# matrix, as a new row. The code assumes that the matrix provides
+# the same interface as the queue provided by the 'struct'
+# module of tcllib, "add row" in particular.
+#
+# Arguments:
+# m The matrix to write the resulting list to.
+# line The string to split
+# sepChar The separator character, defaults to comma
+# expand The expansion mode. The default is none
+#
+# Results:
+# A list of the values in 'line', written to 'q'.
+
+proc ::csv::split2matrix {args} {
+ # FR #481023
+
+ # Argument syntax:
+ #
+ #2) m line
+ #3) m line sepChar
+ #3) -alternate m line
+ #4) -alternate m line sepChar
+ #4) m line sepChar expand
+ #5) -alternate m line sepChar expand
+
+ set alternate 0
+ set sepChar ,
+ set expand none
+
+ switch -exact -- [llength $args] {
+ 2 {
+ foreach {m line} $args break
+ }
+ 3 {
+ foreach {a b c} $args break
+ if {[string equal $a "-alternate"]} {
+ set alternate 1
+ set m $b
+ set line $c
+ } else {
+ set m $a
+ set line $b
+ set sepChar $c
+ }
+ }
+ 4 {
+ foreach {a b c d} $args break
+ if {[string equal $a "-alternate"]} {
+ set alternate 1
+ set m $b
+ set line $c
+ set sepChar $d
+ } else {
+ set m $a
+ set line $b
+ set sepChar $c
+ set expand $d
+ }
+ }
+ 4 {
+ foreach {a b c d e} $args break
+ if {![string equal $a "-alternate"]} {
+ return -code error "wrong#args: Should be ?-alternate? m line ?separator? ?expand?"
+ }
+ set alternate 1
+
+ set m $b
+ set line $c
+ set sepChar $d
+ set expand $e
+ }
+ 0 - 1 -
+ default {
+ return -code error "wrong#args: Should be ?-alternate? m line ?separator? ?expand?"
+ }
+ }
+
+ if {[string length $sepChar] < 1} {
+ return -code error "illegal separator character \"$sepChar\", is empty"
+ } elseif {[string length $sepChar] > 1} {
+ return -code error "illegal separator character \"$sepChar\", is a string"
+ }
+
+ Split2matrix $alternate $m $line $sepChar $expand
+ return
+}
+
+proc ::csv::Split2matrix {alternate m line sepChar expand} {
+ set csv [Split $alternate $line $sepChar]
+
+ # Expansion modes
+ # - none : default, behaviour of original implementation.
+ # no expansion is done, lines are silently truncated
+ # to the number of columns in the matrix.
+ #
+ # - empty : A matrix without columns is expanded to the number
+ # of columns in the first line added to it. All
+ # following lines are handled as if "mode == none"
+ # was set.
+ #
+ # - auto : Full auto-mode. The matrix is expanded as needed to
+ # hold all columns of all lines.
+
+ switch -exact -- $expand {
+ none {}
+ empty {
+ if {[$m columns] == 0} {
+ $m add columns [llength $csv]
+ }
+ }
+ auto {
+ if {[$m columns] < [llength $csv]} {
+ $m add columns [expr {[llength $csv] - [$m columns]}]
+ }
+ }
+ }
+ $m add row $csv
+ return
+}
+
+# ::csv::split2queue --
+#
+# Split a string according to the rules for CSV processing.
+# This assumes that the string contains a single line of CSVs.
+# The resulting list of values is appended to the specified
+# queue, as a single item. IOW each item in the queue represents
+# a single CSV record. The code assumes that the queue provides
+# the same interface as the queue provided by the 'struct'
+# module of tcllib, "put" in particular.
+#
+# Arguments:
+# q The queue to write the resulting list to.
+# line The string to split
+# sepChar The separator character, defaults to comma
+#
+# Results:
+# A list of the values in 'line', written to 'q'.
+
+proc ::csv::split2queue {args} {
+ # Argument syntax:
+ #
+ #2) q line
+ #3) q line sepChar
+ #3) -alternate q line
+ #4) -alternate q line sepChar
+
+ set alternate 0
+ set sepChar ,
+
+ switch -exact -- [llength $args] {
+ 2 {
+ foreach {q line} $args break
+ }
+ 3 {
+ foreach {a b c} $args break
+ if {[string equal $a "-alternate"]} {
+ set alternate 1
+ set q $b
+ set line $c
+ } else {
+ set q $a
+ set line $b
+ set sepChar $c
+ }
+ }
+ 4 {
+ foreach {a b c d} $args break
+ if {![string equal $a "-alternate"]} {
+ return -code error "wrong#args: Should be ?-alternate? q line ?separator?"
+ }
+ set alternate 1
+
+ set q $b
+ set line $c
+ set sepChar $d
+ }
+ 0 - 1 -
+ default {
+ return -code error "wrong#args: Should be ?-alternate? q line ?separator?"
+ }
+ }
+
+ if {[string length $sepChar] < 1} {
+ return -code error "illegal separator character \"$sepChar\", is empty"
+ } elseif {[string length $sepChar] > 1} {
+ return -code error "illegal separator character \"$sepChar\", is a string"
+ }
+
+ $q put [Split $alternate $line $sepChar]
+ return
+}
+
+# ::csv::writematrix --
+#
+# A wrapper around "::csv::join" taking the rows in a matrix and
+# writing them as CSV formatted lines into the channel.
+#
+# Arguments:
+# m The matrix to take the data to write from.
+# chan The channel to write into.
+# sepChar The separator character, defaults to comma
+#
+# Results:
+# None.
+
+proc ::csv::writematrix {m chan {sepChar ,} {delChar \"}} {
+ set n [$m rows]
+ for {set r 0} {$r < $n} {incr r} {
+ puts $chan [join [$m get row $r] $sepChar $delChar]
+ }
+
+ # Memory intensive alternative:
+ # puts $chan [joinlist [m get rect 0 0 end end] $sepChar $delChar]
+ return
+}
+
+# ::csv::writequeue --
+#
+# A wrapper around "::csv::join" taking the rows in a queue and
+# writing them as CSV formatted lines into the channel.
+#
+# Arguments:
+# q The queue to take the data to write from.
+# chan The channel to write into.
+# sepChar The separator character, defaults to comma
+#
+# Results:
+# None.
+
+proc ::csv::writequeue {q chan {sepChar ,} {delChar \"}} {
+ while {[$q size] > 0} {
+ puts $chan [join [$q get] $sepChar $delChar]
+ }
+
+ # Memory intensive alternative:
+ # puts $chan [joinlist [$q get [$q size]] $sepChar $delChar]
+ return
+}
+
diff --git a/tcllib/modules/csv/csv.test b/tcllib/modules/csv/csv.test
new file mode 100644
index 0000000..1e2ff78
--- /dev/null
+++ b/tcllib/modules/csv/csv.test
@@ -0,0 +1,998 @@
+# -*- tcl -*-
+# Tests for the find function.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2001-2011 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: csv.test,v 1.23 2011/11/23 02:22:10 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.3
+testsNeedTcltest 1.0
+
+support {
+ use struct/queue.tcl struct::queue
+ use struct/matrix.tcl struct::matrix
+}
+testing {
+ useLocal csv.tcl csv
+}
+
+# -------------------------------------------------------------------------
+
+set str1 {"123","""a""",,hello}
+set str2 {1," o, ""a"" ,b ", 3}
+set str3 {"1"," o, "","" ,b ", 3}
+set str4 {1," foo,bar,baz", 3}
+set str5 {1,"""""a""""",b}
+set str6 {123,"123,521.2","Mary says ""Hello, I am Mary"""}
+
+set str1a {123,"""a""",,hello}
+set str3a {1," o, "","" ,b ", 3}
+
+# Custom delimiter, =
+
+set str1_ {=123=,===a===,,hello}
+set str2_ {1,= o, ==a== ,b =, 3}
+set str3_ {=1=,= o, ==,== ,b =, 3}
+set str4_ {1,= foo,bar,baz=, 3}
+set str5_ {1,=====a=====,b}
+set str6_ {123,=123,521.2=,=Mary says "Hello, I am Mary"=}
+
+set str1a_ {123,===a===,,hello}
+set str3a_ {1,= o, ==,== ,b =, 3}
+
+set str7 {=1=,=====a=====,=b=}
+
+# -------------------------------------------------------------------------
+
+test csv-1.1 {split} {
+ csv::split $str1
+} {123 {"a"} {} hello}
+
+test csv-1.2 {split} {
+ csv::split $str2
+} {1 { o, "a" ,b } { 3}}
+
+test csv-1.3 {split} {
+ csv::split $str3
+} {1 { o, "," ,b } { 3}}
+
+test csv-1.4 {split} {
+ csv::split $str4
+} {1 { foo,bar,baz} { 3}}
+
+test csv-1.5 {split} {
+ csv::split $str5
+} {1 {""a""} b}
+
+test csv-1.6 {split} {
+ csv::split $str6
+} {123 123,521.2 {Mary says "Hello, I am Mary"}}
+
+test csv-1.7 {split on join} {
+ # csv 0.1 was exposed to the RE \A matching problem with regsub -all
+ set x [list "\"hello, you\"" a b c]
+ ::csv::split [::csv::join $x]
+} [list "\"hello, you\"" a b c]
+
+test csv-1.8-1 {split empty fields} {
+ csv::split {1 2 "" ""} { }
+} {1 2 {"} {"}}
+
+test csv-1.9-1 {split empty fields} {
+ csv::split {1 2 3 ""} { }
+} {1 2 3 {"}}
+
+test csv-1.10-1 {split empty fields} {
+ csv::split {"" "" 1 2} { }
+} {{"} {"} 1 2}
+
+test csv-1.11-1 {split empty fields} {
+ csv::split {"" 0 1 2} { }
+} {{"} 0 1 2}
+
+test csv-1.12-1 {split empty fields} {
+ csv::split {"" ""} { }
+} {{"} {"}}
+
+test csv-1.13-1 {split empty fields} {
+ csv::split {"" "" ""} { }
+} {{"} {"} {"}}
+
+test csv-1.14-1 {split empty fields} {
+ csv::split {"" 0 "" 2} { }
+} {{"} 0 {"} 2}
+
+test csv-1.15-1 {split empty fields} {
+ csv::split {1 "" 3 ""} { }
+} {1 {"} 3 {"}}
+
+test csv-1.8-2 {split empty fields} {
+ csv::split "1,2,,"
+} {1 2 {} {}}
+
+test csv-1.9-2 {split empty fields} {
+ csv::split "1,2,3,"
+} {1 2 3 {}}
+
+test csv-1.10-2 {split empty fields} {
+ csv::split ",,1,2"
+} {{} {} 1 2}
+
+test csv-1.11-2 {split empty fields} {
+ csv::split ",0,1,2"
+} {{} 0 1 2}
+
+test csv-1.12-2 {split empty fields} {
+ csv::split ","
+} {{} {}}
+
+test csv-1.13-2 {split empty fields} {
+ csv::split ",,"
+} {{} {} {}}
+
+test csv-1.14-2 {split empty fields} {
+ csv::split ",0,,2"
+} {{} 0 {} 2}
+
+test csv-1.15-2 {split empty fields} {
+ csv::split "1,,3,"
+} {1 {} 3 {}}
+
+test csv-1.8-3 {split empty fields} {
+ csv::split {1 2 } { }
+} {1 2 {} {}}
+
+test csv-1.9-3 {split empty fields} {
+ csv::split {1 2 3 } { }
+} {1 2 3 {}}
+
+test csv-1.10-3 {split empty fields} {
+ csv::split { 1 2} { }
+} {{} {} 1 2}
+
+test csv-1.11-3 {split empty fields} {
+ csv::split { 0 1 2} { }
+} {{} 0 1 2}
+
+test csv-1.12-3 {split empty fields} {
+ csv::split { } { }
+} {{} {}}
+
+test csv-1.13-3 {split empty fields} {
+ csv::split { } { }
+} {{} {} {}}
+
+test csv-1.14-3 {split empty fields} {
+ csv::split { 0 2} { }
+} {{} 0 {} 2}
+
+test csv-1.15-3 {split empty fields} {
+ csv::split {1 3 } { }
+} {1 {} 3 {}}
+
+
+test csv-1.8-4 {split empty fields} {
+ csv::split {1,2,"",""}
+} {1 2 {"} {"}}
+
+test csv-1.9-4 {split empty fields} {
+ csv::split {1,2,3,""}
+} {1 2 3 {"}}
+
+test csv-1.10-4 {split empty fields} {
+ csv::split {"","",1,2}
+} {{"} {"} 1 2}
+
+test csv-1.11-4 {split empty fields} {
+ csv::split {"",0,1,2}
+} {{"} 0 1 2}
+
+test csv-1.12-4 {split empty fields} {
+ csv::split {"",""}
+} {{"} {"}}
+
+test csv-1.13-4 {split empty fields} {
+ csv::split {"","",""}
+} {{"} {"} {"}}
+
+test csv-1.14-4 {split empty fields} {
+ csv::split {"",0,"",2}
+} {{"} 0 {"} 2}
+
+test csv-1.15-4 {split empty fields} {
+ csv::split {1,"",3,""}
+} {1 {"} 3 {"}}
+
+# Try various separator characters
+
+foreach {n sep} {
+ 0 | 1 + 2 *
+ 3 / 4 \ 5 [
+ 6 ] 7 ( 8 )
+ 9 ? 10 , 11 ;
+ 12 . 13 - 14 =
+ 15 : 16 x 17 9
+} {
+ test csv-1.16-$n "split on $sep" {
+ ::csv::split [join [list REC DPI AD1 AD2 AD3] $sep] $sep
+ } {REC DPI AD1 AD2 AD3}
+}
+
+test csv-2.1 {join} {
+ csv::join {123 {"a"} {} hello}
+} $str1a
+
+test csv-2.2 {join} {
+ csv::join {1 { o, "a" ,b } { 3}}
+} $str2
+
+test csv-2.3 {join} {
+ csv::join {1 { o, "," ,b } { 3}}
+} $str3a
+
+test csv-2.4 {join} {
+ csv::join {1 { foo,bar,baz} { 3}}
+} $str4
+
+test csv-2.5 {join} {
+ csv::join {1 {""a""} b}
+} $str5
+
+test csv-2.6 {join} {
+ csv::join {123 123,521.2 {Mary says "Hello, I am Mary"}}
+} $str6
+
+test csv-2.7 {join, custom delimiter} {
+ csv::join {123 =a= {} hello} , =
+} $str1a_
+
+test csv-2.8 {join, custom delimiter} {
+ csv::join {1 { o, =a= ,b } { 3}} , =
+} $str2_
+
+test csv-2.9 {join, custom delimiter} {
+ csv::join {1 { o, =,= ,b } { 3}} , =
+} $str3a_
+
+test csv-2.10 {join, custom delimiter} {
+ csv::join {1 { foo,bar,baz} { 3}} , =
+} $str4_
+
+test csv-2.11 {join, custom delimiter} {
+ csv::join {1 ==a== b} , =
+} $str5_
+
+test csv-2.12 {join, custom delimiter} {
+ csv::join {123 123,521.2 {Mary says "Hello, I am Mary"}} , =
+} $str6_
+
+test csv-2.13-sf-1724818 {join, newlines in string, sf bug 1724818} {
+ csv::join {123 {John Doe} "123 Main St.\nSmalltown, OH 44444"}
+} "123,John Doe,\"123 Main St.\nSmalltown, OH 44444\""
+
+test csv-2.14 {join, custom delimiter, always} {
+ csv::join {1 ==a== b} , = always
+} $str7
+
+# Malformed inputs
+
+test csv-3.1 {split} {
+ csv::split {abcd,abc",abc} ; # "
+} {abcd abc abc}
+
+test csv-3.2 {split} {
+ csv::split {abcd,abc"",abc}
+} {abcd abc\" abc}
+
+
+test csv-4.1 {joinlist} {
+ csv::joinlist [list \
+ {123 {"a"} {} hello} \
+ {1 { o, "a" ,b } { 3}} \
+ {1 { o, "," ,b } { 3}} \
+ {1 { foo,bar,baz} { 3}} \
+ {1 {""a""} b} \
+ {123 123,521.2 {Mary says "Hello, I am Mary"}}]
+} "$str1a\n$str2\n$str3a\n$str4\n$str5\n$str6\n"
+
+test csv-4.2 {joinlist, sepChar} {
+ csv::joinlist [list [list a b c] [list d e f]] @
+} "a@b@c\nd@e@f\n"
+
+test csv-4.3 {joinlist, custom delimiter} {
+ csv::joinlist [list \
+ {123 =a= {} hello} \
+ {1 { o, =a= ,b } { 3}} \
+ {1 { o, =,= ,b } { 3}} \
+ {1 { foo,bar,baz} { 3}} \
+ {1 ==a== b} \
+ {123 123,521.2 {Mary says "Hello, I am Mary"}}] , =
+} "$str1a_\n$str2_\n$str3a_\n$str4_\n$str5_\n$str6_\n"
+
+test csv-4.4 {joinlist, sepChar, custom delimiter} {
+ csv::joinlist [list [list a b c] [list d e f]] @ =
+} "a@b@c\nd@e@f\n"
+
+
+test csv-5.0.0 {reading csv files, bad separator, empty} {
+ ::struct::queue q
+ catch {::csv::read2queue dummy q {}} result
+ q destroy
+ set result
+} {illegal separator character "", is empty}
+
+test csv-5.0.1 {reading csv files, bad separator, string} {
+ ::struct::queue q
+ catch {::csv::read2queue dummy q foo} result
+ q destroy
+ set result
+} {illegal separator character "foo", is a string}
+
+test csv-5.0.2 {reading csv files, bad separator, empty} {
+ ::struct::matrix m
+ catch {::csv::read2matrix dummy m {}} result
+ m destroy
+ set result
+} {illegal separator character "", is empty}
+
+test csv-5.0.3 {reading csv files, bad separator, string} {
+ ::struct::matrix m
+ catch {::csv::read2matrix dummy m foo} result
+ m destroy
+ set result
+} {illegal separator character "foo", is a string}
+
+test csv-5.1 {reading csv files} {
+ set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r]
+ ::struct::queue q
+ ::csv::read2queue $f q
+ close $f
+ set result [list [q size] [q get 2]]
+ q destroy
+ set result
+} {251 {{000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} {001 {CATCH return ok} 7 13 53.85}}}
+
+test csv-5.2 {reading csv files} {
+ set f [open [file join $::tcltest::testsDirectory mem_debug_bench_a.csv] r]
+ ::struct::queue q
+ ::csv::read2queue $f q
+ close $f
+ set result [list [q size] [q get 2]]
+ q destroy
+ set result
+} {251 {{000 VERSIONS: 2:8.4a3 1:8.4a3 1:8.4a3%} {001 {CATCH return ok} 7 13 53.85}}}
+
+test csv-5.3 {reading csv files} {
+ set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r]
+ ::struct::matrix m
+ m add columns 5
+ ::csv::read2matrix $f m
+ close $f
+ set result [m get rect 0 227 end 231]
+ m destroy
+ set result
+} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}}
+
+test csv-5.4 {reading csv files} {
+ set f [open [file join $::tcltest::testsDirectory mem_debug_bench_a.csv] r]
+ ::struct::matrix m
+ m add columns 5
+ ::csv::read2matrix $f m
+ close $f
+ set result [m get rect 0 227 end 231]
+ m destroy
+ set result
+} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}}
+
+test csv-5.5 {reading csv files} {
+ set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r]
+ ::struct::matrix m
+ m add columns 5
+ ::csv::read2matrix $f m
+ close $f
+
+ set result [list]
+ foreach c {0 1 2 3 4} {
+ lappend result [m columnwidth $c]
+ }
+ m destroy
+ set result
+} {3 39 7 7 8}
+
+test csv-5.6 {reading csv files, linking} {
+ set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r]
+ ::struct::matrix m
+ m add columns 5
+ ::csv::read2matrix $f m
+ close $f
+ m link a
+ set result [array size a]
+ m destroy
+ set result
+} {1255}
+
+
+test csv-5.7 {reading csv files, empty expansion mode} {
+ set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r]
+ ::struct::matrix m
+ ::csv::read2matrix $f m , empty
+ close $f
+ set result [m get rect 0 227 end 231]
+ m destroy
+ set result
+} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}}
+
+test csv-5.8 {reading csv files, auto expansion mode} {
+ set f [open [file join $::tcltest::testsDirectory mem_debug_bench.csv] r]
+ ::struct::matrix m
+ m add columns 1
+ ::csv::read2matrix $f m , auto
+ close $f
+ set result [m get rect 0 227 end 231]
+ m destroy
+ set result
+} {{227 {STR append (1MB + 1MB * 3)} 125505 327765 38.29} {228 {STR append (1MB + 1MB * 5)} 158507 855295 18.53} {229 {STR append (1MB + (1b + 1K + 1b) * 100)} 33101 174031 19.02} {230 {STR info locals match} 946 1521 62.20} {231 {TRACE no trace set} 34 121 28.10}}
+
+# =========================================================================
+# Bug 2926387
+
+test csv-5.9.0 {reading csv files, inner field newline processing, bug 2926387} {
+ set m [struct::matrix]
+ set f [open [file join $::tcltest::testsDirectory 2926387.csv] r]
+ csv::read2matrix $f $m , auto
+ close $f
+ set result [$m serialize]
+ $m destroy
+ set result
+} {2 3 {{a b c} {d {e,
+e} f}}}
+
+test csv-5.9.1 {reading csv files, inner field newline processing, bug 2926387} {
+ set q [struct::queue]
+ set f [open [file join $::tcltest::testsDirectory 2926387.csv] r]
+ csv::read2queue $f $q
+ close $f
+ set result [$q get [$q size]]
+ $q destroy
+ set result
+} {{a b c} {d {e,
+e} f}}
+
+# =========================================================================
+
+test csv-6.1 {writing csv files} {
+ set f [open [localPath eval.csv] r]
+ ::struct::matrix m
+ m add columns 5
+ ::csv::read2matrix $f m
+ close $f
+
+ set f [open [makeFile {} eval-out1.csv] w]
+ ::csv::writematrix m $f
+ close $f
+
+ set result [viewFile eval-out1.csv]
+ m destroy
+ removeFile eval-out1.csv
+ set result
+} {023,EVAL cmd eval in list obj var,26,45,57.78
+024,EVAL cmd eval as list,23,42,54.76
+025,EVAL cmd eval as string,53,92,57.61
+026,EVAL cmd and mixed lists,3805,11276,33.74
+027,EVAL list cmd and mixed lists,3812,11325,33.66
+028,EVAL list cmd and pure lists,592,1598,37.05}
+
+test csv-6.2 {writing csv files} {
+ set f [open [localPath eval.csv] r]
+ ::struct::queue q
+ ::csv::read2queue $f q
+ close $f
+
+ set f [open [makeFile {} eval-out2.csv] w]
+ ::csv::writequeue q $f
+ close $f
+
+ set result [viewFile eval-out2.csv]
+ q destroy
+ removeFile eval-out2.csv
+ set result
+} {023,EVAL cmd eval in list obj var,26,45,57.78
+024,EVAL cmd eval as list,23,42,54.76
+025,EVAL cmd eval as string,53,92,57.61
+026,EVAL cmd and mixed lists,3805,11276,33.74
+027,EVAL list cmd and mixed lists,3812,11325,33.66
+028,EVAL list cmd and pure lists,592,1598,37.05}
+
+
+test csv-7.1 {reporting} {
+ set f [open [localPath eval.csv] r]
+ ::struct::matrix m
+ m add columns 5
+ ::csv::read2matrix $f m
+ close $f
+
+ set result [m format 2string csv::report]
+ m destroy
+ set result
+} {023,EVAL cmd eval in list obj var,26,45,57.78
+024,EVAL cmd eval as list,23,42,54.76
+025,EVAL cmd eval as string,53,92,57.61
+026,EVAL cmd and mixed lists,3805,11276,33.74
+027,EVAL list cmd and mixed lists,3812,11325,33.66
+028,EVAL list cmd and pure lists,592,1598,37.05
+}
+
+test csv-7.2 {reporting} {
+ set f [open [localPath eval.csv] r]
+ ::struct::matrix m
+ m add columns 5
+ ::csv::read2matrix $f m
+ close $f
+
+ set f [open [makeFile {} eval-out3.csv] w]
+ m format 2chan csv::report $f
+ close $f
+
+ set result [viewFile eval-out3.csv]
+ m destroy
+ removeFile eval-out3.csv
+ set result
+} {023,EVAL cmd eval in list obj var,26,45,57.78
+024,EVAL cmd eval as list,23,42,54.76
+025,EVAL cmd eval as string,53,92,57.61
+026,EVAL cmd and mixed lists,3805,11276,33.74
+027,EVAL list cmd and mixed lists,3812,11325,33.66
+028,EVAL list cmd and pure lists,592,1598,37.05}
+
+
+test csv-7.3 {report error} {
+ catch {::csv::report printmatrix foomatrix blarg} msg
+ set msg
+} {wrong # args: ::csv::report printmatrix matrix}
+
+test csv-7.4 {report error} {
+ catch {::csv::report printmatrix2channel foomatrix} msg
+ set msg
+} {wrong # args: ::csv::report printmatrix2channel matrix chan}
+
+test csv-7.5 {report error} {
+ catch {::csv::report printmatrix2channel foomatrix foo bar} msg
+ set msg
+} {wrong # args: ::csv::report printmatrix2channel matrix chan}
+
+test csv-7.6 {report error} {
+ catch {::csv::report foocmd foomatrix} msg
+ set msg
+} {Unknown method foocmd}
+
+
+## ============================================================
+## Test new restrictions on argument syntax of split.
+
+test csv-8.0 {csv argument error} {
+ catch {::csv::split} msg
+ set msg
+} {wrong#args: Should be ?-alternate? line ?separator? ?delimiter?}
+
+test csv-8.1 {csv argument error} {
+ catch {::csv::split a b c d e} msg
+ set msg
+} {wrong#args: Should be ?-alternate? line ?separator? ?delimiter?}
+
+test csv-8.2 {csv argument error} {
+ catch {::csv::split -alternate b {}} msg
+ set msg
+} {illegal separator character "", is empty}
+
+test csv-8.3 {csv argument error} {
+ catch {::csv::split -alternate b foo} msg
+ set msg
+} {illegal separator character "foo", is a string}
+
+test csv-8.4 {csv argument error} {
+ catch {::csv::split b {}} msg
+ set msg
+} {illegal separator character "", is empty}
+
+test csv-8.5 {csv argument error} {
+ catch {::csv::split b foo} msg
+ set msg
+} {illegal separator character "foo", is a string}
+
+## ============================================================
+## Tests for alternate syntax.
+
+
+test csv-91.1 {split} {
+ csv::split -alternate $str1
+} {123 {"a"} {} hello}
+
+test csv-91.2 {split} {
+ csv::split -alternate $str2
+} {1 { o, "a" ,b } { 3}}
+
+test csv-91.3 {split} {
+ csv::split -alternate $str3
+} {1 { o, "," ,b } { 3}}
+
+test csv-91.4 {split} {
+ csv::split -alternate $str4
+} {1 { foo,bar,baz} { 3}}
+
+test csv-91.5 {split} {
+ csv::split -alternate $str5
+} {1 {""a""} b}
+
+test csv-91.6 {split} {
+ csv::split -alternate $str6
+} {123 123,521.2 {Mary says "Hello, I am Mary"}}
+
+test csv-91.7 {split on join} {
+ # csv 0.1 was exposed to the RE \A matching problem with regsub -all
+ set x [list "\"hello, you\"" a b c]
+ ::csv::split -alternate [::csv::join $x]
+} [list "\"hello, you\"" a b c]
+
+test csv-91.8-1 {split empty fields} {
+ csv::split -alternate {1 2 "" ""} { }
+} {1 2 {} {}}
+
+test csv-91.9-1 {split empty fields} {
+ csv::split -alternate {1 2 3 ""} { }
+} {1 2 3 {}}
+
+test csv-91.10-1 {split empty fields} {
+ csv::split -alternate {"" "" 1 2} { }
+} {{} {} 1 2}
+
+test csv-91.11-1 {split empty fields} {
+ csv::split -alternate {"" 0 1 2} { }
+} {{} 0 1 2}
+
+test csv-91.12-1 {split empty fields} {
+ csv::split -alternate {"" ""} { }
+} {{} {}}
+
+test csv-91.13-1 {split empty fields} {
+ csv::split -alternate {"" "" ""} { }
+} {{} {} {}}
+
+test csv-91.14-1 {split empty fields} {
+ csv::split -alternate {"" 0 "" 2} { }
+} {{} 0 {} 2}
+
+test csv-91.15-1 {split empty fields} {
+ csv::split -alternate {1 "" 3 ""} { }
+} {1 {} 3 {}}
+
+test csv-91.8-2 {split empty fields} {
+ csv::split -alternate "1,2,,"
+} {1 2 {} {}}
+
+test csv-91.9-2 {split empty fields} {
+ csv::split -alternate "1,2,3,"
+} {1 2 3 {}}
+
+test csv-91.10-2 {split empty fields} {
+ csv::split -alternate ",,1,2"
+} {{} {} 1 2}
+
+test csv-91.11-2 {split empty fields} {
+ csv::split -alternate ",0,1,2"
+} {{} 0 1 2}
+
+test csv-91.12-2 {split empty fields} {
+ csv::split -alternate ","
+} {{} {}}
+
+test csv-91.13-2 {split empty fields} {
+ csv::split -alternate ",,"
+} {{} {} {}}
+
+test csv-91.14-2 {split empty fields} {
+ csv::split -alternate ",0,,2"
+} {{} 0 {} 2}
+
+test csv-91.15-2 {split empty fields} {
+ csv::split -alternate "1,,3,"
+} {1 {} 3 {}}
+
+test csv-91.8-3 {split empty fields} {
+ csv::split -alternate {1 2 } { }
+} {1 2 {} {}}
+
+test csv-91.9-3 {split empty fields} {
+ csv::split -alternate {1 2 3 } { }
+} {1 2 3 {}}
+
+test csv-91.10-3 {split empty fields} {
+ csv::split -alternate { 1 2} { }
+} {{} {} 1 2}
+
+test csv-91.11-3 {split empty fields} {
+ csv::split -alternate { 0 1 2} { }
+} {{} 0 1 2}
+
+test csv-91.12-3 {split empty fields} {
+ csv::split -alternate { } { }
+} {{} {}}
+
+test csv-91.13-3 {split empty fields} {
+ csv::split -alternate { } { }
+} {{} {} {}}
+
+test csv-91.14-3 {split empty fields} {
+ csv::split -alternate { 0 2} { }
+} {{} 0 {} 2}
+
+test csv-91.15-3 {split empty fields} {
+ csv::split -alternate {1 3 } { }
+} {1 {} 3 {}}
+
+
+test csv-91.8-4 {split empty fields} {
+ csv::split -alternate {1,2,"",""}
+} {1 2 {} {}}
+
+test csv-91.9-4 {split empty fields} {
+ csv::split -alternate {1,2,3,""}
+} {1 2 3 {}}
+
+test csv-91.10-4 {split empty fields} {
+ csv::split -alternate {"","",1,2}
+} {{} {} 1 2}
+
+test csv-91.11-4 {split empty fields} {
+ csv::split -alternate {"",0,1,2}
+} {{} 0 1 2}
+
+test csv-91.12-4 {split empty fields} {
+ csv::split -alternate {"",""}
+} {{} {}}
+
+test csv-91.13-4 {split empty fields} {
+ csv::split -alternate {"","",""}
+} {{} {} {}}
+
+test csv-91.14-4 {split empty fields} {
+ csv::split -alternate {"",0,"",2}
+} {{} 0 {} 2}
+
+test csv-91.15-4 {split empty fields} {
+ csv::split -alternate {1,"",3,""}
+} {1 {} 3 {}}
+
+
+test csv-92.0.1 {split} {
+ csv::split {"xxx",yyy}
+} {xxx yyy}
+
+test csv-92.0.2 {split} {
+ csv::split -alternate {"xxx",yyy}
+} {xxx yyy}
+
+test csv-92.1.1 {split} {
+ csv::split {"xx""x",yyy}
+} {xx\"x yyy}
+
+test csv-92.1.2 {split} {
+ csv::split -alternate {"xx""x",yyy}
+} {xx\"x yyy}
+
+# -------------------------------------------------------------------------
+
+
+test csv-100.1 {custom delimiter, split} {
+ csv::split $str1_ , =
+} {123 =a= {} hello}
+
+test csv-100.2 {custom delimiter, split} {
+ csv::split $str2_ , =
+} {1 { o, =a= ,b } { 3}}
+
+test csv-100.3 {custom delimiter, split} {
+ csv::split $str3_ , =
+} {1 { o, =,= ,b } { 3}}
+
+test csv-100.4 {custom delimiter, split} {
+ csv::split $str4_ , =
+} {1 { foo,bar,baz} { 3}}
+
+test csv-100.5 {custom delimiter, split} {
+ csv::split $str5_ , =
+} {1 ==a== b}
+
+test csv-100.6 {custom delimiter, split} {
+ csv::split $str6_ , =
+} {123 123,521.2 {Mary says "Hello, I am Mary"}}
+
+test csv-100.7 {custom delimiter, split on join} {
+ # csv 0.1 was exposed to the RE \A matching problem with regsub -all
+ set x [list "\"hello, you\"" a b c]
+ ::csv::split [::csv::join $x , =] , =
+} [list "\"hello, you\"" a b c]
+
+test csv-100.8-1 {custom delimiter, split empty fields} {
+ csv::split {1 2 == ==} { } =
+} {1 2 = =}
+
+test csv-100.9-1 {custom delimiter, split empty fields} {
+ csv::split {1 2 3 ==} { } =
+} {1 2 3 =}
+
+test csv-100.10-1 {custom delimiter, split empty fields} {
+ csv::split {== == 1 2} { } =
+} {= = 1 2}
+
+test csv-100.11-1 {custom delimiter, split empty fields} {
+ csv::split {== 0 1 2} { } =
+} {= 0 1 2}
+
+test csv-100.12-1 {custom delimiter, split empty fields} {
+ csv::split {== ==} { } =
+} {= =}
+
+test csv-100.13-1 {custom delimiter, split empty fields} {
+ csv::split {== == ==} { } =
+} {= = =}
+
+test csv-100.14-1 {custom delimiter, split empty fields} {
+ csv::split {== 0 == 2} { } =
+} {= 0 = 2}
+
+test csv-100.15-1 {custom delimiter, split empty fields} {
+ csv::split {1 == 3 ==} { } =
+} {1 = 3 =}
+
+test csv-100.8-2 {custom delimiter, split empty fields} {
+ csv::split "1,2,,"
+} {1 2 {} {}}
+
+test csv-100.9-2 {custom delimiter, split empty fields} {
+ csv::split "1,2,3,"
+} {1 2 3 {}}
+
+test csv-100.10-2 {custom delimiter, split empty fields} {
+ csv::split ",,1,2"
+} {{} {} 1 2}
+
+test csv-100.11-2 {custom delimiter, split empty fields} {
+ csv::split ",0,1,2"
+} {{} 0 1 2}
+
+test csv-100.12-2 {custom delimiter, split empty fields} {
+ csv::split ","
+} {{} {}}
+
+test csv-100.13-2 {custom delimiter, split empty fields} {
+ csv::split ",,"
+} {{} {} {}}
+
+test csv-100.14-2 {custom delimiter, split empty fields} {
+ csv::split ",0,,2"
+} {{} 0 {} 2}
+
+test csv-100.15-2 {custom delimiter, split empty fields} {
+ csv::split "1,,3,"
+} {1 {} 3 {}}
+
+test csv-100.8-3 {custom delimiter, split empty fields} {
+ csv::split {1 2 } { } =
+} {1 2 {} {}}
+
+test csv-100.9-3 {custom delimiter, split empty fields} {
+ csv::split {1 2 3 } { } =
+} {1 2 3 {}}
+
+test csv-100.10-3 {custom delimiter, split empty fields} {
+ csv::split { 1 2} { } =
+} {{} {} 1 2}
+
+test csv-100.11-3 {custom delimiter, split empty fields} {
+ csv::split { 0 1 2} { } =
+} {{} 0 1 2}
+
+test csv-100.12-3 {custom delimiter, split empty fields} {
+ csv::split { } { } =
+} {{} {}}
+
+test csv-100.13-3 {custom delimiter, split empty fields} {
+ csv::split { } { } =
+} {{} {} {}}
+
+test csv-100.14-3 {custom delimiter, split empty fields} {
+ csv::split { 0 2} { } =
+} {{} 0 {} 2}
+
+test csv-100.15-3 {custom delimiter, split empty fields} {
+ csv::split {1 3 } { } =
+} {1 {} 3 {}}
+
+test csv-100.8-4 {custom delimiter, split empty fields} {
+ csv::split {1,2,==,==} , =
+} {1 2 = =}
+
+test csv-100.9-4 {custom delimiter, split empty fields} {
+ csv::split {1,2,3,==} , =
+} {1 2 3 =}
+
+test csv-100.10-4 {custom delimiter, split empty fields} {
+ csv::split {==,==,1,2} , =
+} {= = 1 2}
+
+test csv-100.11-4 {custom delimiter, split empty fields} {
+ csv::split {==,0,1,2} , =
+} {= 0 1 2}
+
+test csv-100.12-4 {custom delimiter, split empty fields} {
+ csv::split {==,==} , =
+} {= =}
+
+test csv-100.13-4 {custom delimiter, split empty fields} {
+ csv::split {==,==,==} , =
+} {= = =}
+
+test csv-100.14-4 {custom delimiter, split empty fields} {
+ csv::split {==,0,==,2} , =
+} {= 0 = 2}
+
+test csv-100.15-4 {custom delimiter, split empty fields} {
+ csv::split {1,==,3,==} , =
+} {1 = 3 =}
+
+# Try various separator characters
+
+foreach {n sep} {
+ 0 | 1 + 2 *
+ 3 / 4 \ 5 [
+ 6 ] 7 ( 8 )
+ 9 ? 10 , 11 ;
+ 12 . 13 - 14 @
+ 15 :
+} {
+ test csv-100.16-$n "split on $sep" {
+ ::csv::split [join [list REC DPI AD1 AD2 AD3] $sep] $sep =
+ } {REC DPI AD1 AD2 AD3}
+}
+
+test csv-200.0 {splitting to queue, bad separator, empty} {
+ ::struct::queue q
+ catch {::csv::split2queue q dummy-line {}} result
+ q destroy
+ set result
+} {illegal separator character "", is empty}
+
+test csv-200.1 {splitting to queue, bad separator, string} {
+ ::struct::queue q
+ catch {::csv::split2queue q dummy-line foo} result
+ q destroy
+ set result
+} {illegal separator character "foo", is a string}
+
+test csv-200.2 {splitting to matrix, bad separator, empty} {
+ ::struct::matrix m
+ catch {::csv::split2matrix m dummy-line {}} result
+ m destroy
+ set result
+} {illegal separator character "", is empty}
+
+test csv-200.3 {splitting to matrix, bad separator, string} {
+ ::struct::matrix m
+ catch {::csv::split2matrix m dummy-line foo} result
+ m destroy
+ set result
+} {illegal separator character "foo", is a string}
+
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/csv/eval.csv b/tcllib/modules/csv/eval.csv
new file mode 100644
index 0000000..f8b8988
--- /dev/null
+++ b/tcllib/modules/csv/eval.csv
@@ -0,0 +1,6 @@
+023,EVAL cmd eval in list obj var,26,45,57.78
+024,EVAL cmd eval as list,23,42,54.76
+025,EVAL cmd eval as string,53,92,57.61
+026,EVAL cmd and mixed lists,3805,11276,33.74
+027,EVAL list cmd and mixed lists,3812,11325,33.66
+028,EVAL list cmd and pure lists,592,1598,37.05
diff --git a/tcllib/modules/csv/mem_debug_bench.csv b/tcllib/modules/csv/mem_debug_bench.csv
new file mode 100644
index 0000000..281ccaf
--- /dev/null
+++ b/tcllib/modules/csv/mem_debug_bench.csv
@@ -0,0 +1,251 @@
+000,VERSIONS:,2:8.4a3,1:8.4a3,1:8.4a3%
+001,CATCH return ok,7,13,53.85
+002,CATCH return error,68,91,74.73
+003,CATCH no catch used,7,14,50.00
+004,IF if true numeric,12,33,36.36
+005,IF elseif true numeric,15,47,31.91
+006,IF else true numeric,15,46,32.61
+007,IF if true num/num,13,32,40.62
+008,IF if false num/num,13,32,40.62
+009,IF if false al/num,28,57,49.12
+010,IF if true al/num,34,54,62.96
+011,IF if false al/num,34,58,58.62
+012,IF if true al/al,33,100,33.00
+013,IF elseif true al/al,50,87,57.47
+014,IF else true al/al,50,92,54.35
+015,SWITCH first true,50,81,61.73
+016,SWITCH second true,55,84,65.48
+017,SWITCH ninth true,56,96,58.33
+018,SWITCH default true,48,81,59.26
+019,DATA create in a list,5419,13514,40.10
+020,DATA create in an array,5861,15537,37.72
+021,DATA access in a list,4424,9967,44.39
+022,DATA access in an array,4373,9167,47.70
+023,EVAL cmd eval in list obj var,26,45,57.78
+024,EVAL cmd eval as list,23,42,54.76
+025,EVAL cmd eval as string,53,92,57.61
+026,EVAL cmd and mixed lists,3805,11276,33.74
+027,EVAL list cmd and mixed lists,3812,11325,33.66
+028,EVAL list cmd and pure lists,592,1598,37.05
+029,EXPR unbraced,174,250,69.60
+030,EXPR braced,27,60,45.00
+031,EXPR inline,28,51,54.90
+032,EXPR one operand,8,13,61.54
+033,EXPR ten operands,15,25,60.00
+034,EXPR fifty operands,46,73,63.01
+035,EXPR incr with incr,13,20,65.00
+036,EXPR incr with expr,8,14,57.14
+037,KLIST shuffle0 llength 1,154,260,59.23
+038,KLIST shuffle0 llength 10,521,950,54.84
+039,KLIST shuffle0 llength 100,4126,7781,53.03
+040,KLIST shuffle0 llength 1000,46309,85434,54.20
+041,KLIST shuffle0 llength 10000,612676,1000055,61.26
+042,KLIST shuffle1 llength 1,100,181,55.25
+043,KLIST shuffle1 llength 10,432,835,51.74
+044,KLIST shuffle1 llength 100,5872,14144,41.52
+045,KLIST shuffle1 llength 1000,1293956,1235661,104.72
+046,KLIST shuffle1a llength 1,115,200,57.50
+047,KLIST shuffle1a llength 10,442,1012,43.68
+048,KLIST shuffle1a llength 100,4212,9609,43.83
+049,KLIST shuffle1a llength 1000,42350,98262,43.10
+050,KLIST shuffle1a llength 10000,445084,1052460,42.29
+051,KLIST shuffle2 llength 1,123,205,60.00
+052,KLIST shuffle2 llength 10,484,922,52.49
+053,KLIST shuffle2 llength 100,4377,8347,52.44
+054,KLIST shuffle2 llength 1000,46002,89585,51.35
+055,KLIST shuffle2 llength 10000,525442,926369,56.72
+056,KLIST shuffle3 llength 1,116,196,59.18
+057,KLIST shuffle3 llength 10,420,911,46.10
+058,KLIST shuffle3 llength 100,3730,8465,44.06
+059,KLIST shuffle3 llength 1000,39397,87416,45.07
+060,KLIST shuffle3 llength 10000,949689,1391544,68.25
+061,KLIST shuffle4 llength 1,116,204,56.86
+062,KLIST shuffle4 llength 10,450,1000,45.00
+063,KLIST shuffle4 llength 100,4067,9326,43.61
+064,KLIST shuffle4 llength 1000,39142,92580,42.28
+065,KLIST shuffle4 llength 10000,421581,944205,44.65
+066,"STR/LIST length; obj shimmer",3268,6767,48.29
+067,"LIST length; pure list",17,21,80.95
+068,STR length of a LIST,12,25,48.00
+069,"LIST exact search; first item",18,24,75.00
+070,"LIST exact search; middle item",74,111,66.67
+071,"LIST exact search; last item",142,236,60.17
+072,"LIST exact search; non-item",344,603,57.05
+073,"LIST sorted search; first item",19,29,65.52
+074,"LIST sorted search; middle item",19,27,70.37
+075,"LIST sorted search; last item",19,27,70.37
+076,"LIST sorted search; non-item",19,27,70.37
+077,"LIST exact search; untyped item",148,230,64.35
+078,"LIST exact search; typed item",107,119,89.92
+079,"LIST sorted search; typed item",18,29,62.07
+080,LIST sort,3620,4994,72.49
+081,LIST typed sort,2923,3885,75.24
+082,LIST remove first element,310,763,40.63
+083,LIST remove middle element,308,761,40.47
+084,LIST remove last element,312,757,41.22
+085,LIST replace first element,291,740,39.32
+086,LIST replace middle element,295,741,39.81
+087,LIST replace last element,295,743,39.70
+088,LIST replace first el with multiple,315,770,40.91
+089,LIST replace middle el with multiple,314,764,41.10
+090,LIST replace last el with multiple,288,750,38.40
+091,LIST replace range,288,737,39.08
+092,LIST remove in mixed list,411,959,42.86
+093,LIST replace in mixed list,398,932,42.70
+094,LIST index first element,14,24,58.33
+095,LIST index middle element,14,28,50.00
+096,LIST index last element,14,28,50.00
+097,LIST insert an item at start,297,750,39.60
+098,LIST insert an item at middle,303,746,40.62
+099,"LIST insert an item at ""end""",299,746,40.08
+100,"LIST small; early range",26,41,63.41
+101,"LIST small; late range",23,33,69.70
+102,"LIST large; early range",42,94,44.68
+103,"LIST large; late range",41,106,38.68
+104,LIST append to list,406,426,95.31
+105,LIST join list,1147,1687,67.99
+106,"LOOP for; iterate list",6848,16393,41.77
+107,"LOOP foreach; iterate list",2169,5913,36.68
+108,LOOP for (to 1000),2756,8183,33.68
+109,LOOP while (to 1000),2753,8181,33.65
+110,"LOOP for; iterate string",8350,15966,52.30
+111,"LOOP foreach; iterate string",2684,7094,37.83
+112,MAP string 1 val,686,1097,62.53
+113,MAP string 2 val,1578,2375,66.44
+114,MAP string 3 val,1938,2674,72.48
+115,MAP string 4 val,2427,3324,73.01
+116,MAP string 1 val -nocase,3772,5524,68.28
+117,MAP string 2 val -nocase,6633,9624,68.92
+118,MAP string 3 val -nocase,8809,12682,69.46
+119,MAP string 4 val -nocase,10692,15353,69.64
+120,MAP regsub 1 val,3884,4345,89.39
+121,MAP regsub 2 val,16420,17435,94.18
+122,MAP regsub 3 val,22056,23287,94.71
+123,MAP regsub 4 val,27550,29333,93.92
+124,MAP regsub 1 val -nocase,4004,4322,92.64
+125,MAP regsub 2 val -nocase,16519,17289,95.55
+126,MAP regsub 3 val -nocase,22075,23427,94.23
+127,MAP regsub 4 val -nocase,27981,29438,95.05
+128,"MAP string; no match",1011,1734,58.30
+129,"MAP string -nocase; no match",7090,10589,66.96
+130,"MAP regsub; no match",1226,2328,52.66
+131,"MAP regsub -nocase; no match",1287,2295,56.08
+132,MAP string short,44,58,75.86
+133,MAP regsub short,188,219,85.84
+134,MTHD direct ns proc call,8,15,53.33
+135,MTHD imported ns proc call,8,16,50.00
+136,MTHD interp alias proc call,25,44,56.82
+137,MTHD indirect proc eval,36,58,62.07
+138,MTHD indirect proc eval #2,58,100,58.00
+139,MTHD array stored proc call,11,25,44.00
+140,MTHD switch method call,53,86,61.63
+141,MTHD ns lookup call,113,189,59.79
+142,MTHD inline call,3,9,33.33
+143,PROC explicit return,7,12,58.33
+144,PROC implicit return,7,17,41.18
+145,PROC explicit return (2),7,13,53.85
+146,PROC implicit return (2),7,15,46.67
+147,PROC explicit return (3),7,12,58.33
+148,PROC implicit return (3),7,12,58.33
+149,PROC heavily commented,7,12,58.33
+150,"PROC do-nothing; no args",6,11,54.55
+151,"PROC do-nothing; one arg",7,12,58.33
+152,PROC local links with global,1611,2827,56.99
+153,PROC local links with upvar,1308,2630,49.73
+154,PROC local links with variable,1309,2358,55.51
+155,"READ 595K; gets",386913,551429,70.17
+156,"READ 595K; read",85889,164758,52.13
+157,"READ 595K; read & size",86171,164854,52.27
+158,"READ 3050b; gets",2152,3481,61.82
+159,"READ 3050b; read",561,682,82.26
+160,"READ 3050b; read & size",606,738,82.11
+161,"BREAD 595K; gets",392519,568992,68.98
+162,"BREAD 595K; read",51133,110961,46.08
+163,"BREAD 595K; read & size",51194,110552,46.31
+164,"BREAD 3050b; gets",2213,3174,69.72
+165,"BREAD 3050b; read",329,472,69.70
+166,"BREAD 3050b; read & size",377,517,72.92
+167,REGEXP literal regexp,48,58,82.76
+168,REGEXP var-based regexp,51,60,85.00
+169,REGEXP count all matches,149,161,92.55
+170,REGEXP extract all matches,201,255,78.82
+171,STARTUP time to launch tclsh,26402,32329,81.67
+172,STR str [string compare],15,38,39.47
+173,STR str [string equal],15,38,39.47
+174,"STR str $a equal """"",13,32,40.62
+175,"STR str num == """"",15,38,39.47
+176,STR str $a eq $b,21,49,42.86
+177,STR str $a ne $b,21,49,42.86
+178,STR str $a eq $b (same obj),19,45,42.22
+179,STR str $a ne $b (same obj),19,46,41.30
+180,STR length (==4010),13,23,56.52
+181,STR index 0,19,30,63.33
+182,STR index 100,20,31,64.52
+183,STR index 500,19,30,63.33
+184,STR index2 0,20,32,62.50
+185,STR index2 100,21,30,70.00
+186,STR index2 500,20,31,64.52
+187,STR first (success),17,23,73.91
+188,STR first (failure),115,116,99.14
+189,STR first (total failure),106,103,102.91
+190,STR last (success),17,23,73.91
+191,STR last (failure),91,109,83.49
+192,STR last (total failure),82,86,95.35
+193,"STR match; simple (success early)",17,31,54.84
+194,"STR match; simple (success late)",18,30,60.00
+195,"STR match; simple (failure)",18,28,64.29
+196,"STR match; simple (total failure)",16,29,55.17
+197,"STR match; complex (success early)",18,34,52.94
+198,"STR match; complex (success late)",152,165,92.12
+199,"STR match; complex (failure)",121,134,90.30
+200,"STR match; complex (total failure)",95,101,94.06
+201,"STR range; index 100..200 of 4010",26,40,65.00
+202,"STR replace; no replacement",87,126,69.05
+203,"STR replace; equal replacement",93,133,69.92
+204,"STR replace; longer replacement",103,146,70.55
+205,"STR repeat; abcdefghij * 10",16,23,69.57
+206,"STR repeat; abcdefghij * 100",48,47,102.13
+207,"STR repeat; abcdefghij * 1000",231,257,89.88
+208,"STR repeat; 4010 chars * 10",282,744,37.90
+209,"STR repeat; 4010 chars * 100",6976,14673,47.54
+210,"STR reverse iter1; 100 chars",1534,2295,66.84
+211,"STR reverse iter1; 100 uchars",1457,2322,62.75
+212,"STR reverse iter2; 100 chars",1123,2042,55.00
+213,"STR reverse iter2; 100 uchars",1042,1972,52.84
+214,"STR reverse recur1; 100 chars",3458,7067,48.93
+215,"STR reverse recur1; 100 uchars",3523,6650,52.98
+216,"STR split; 4010 chars",2806,4605,60.93
+217,"STR split; 12100 uchars",7890,13813,57.12
+218,"STR split iter; 4010 chars",11129,28087,39.62
+219,"STR split iter; 12100 uchars",33318,86314,38.60
+220,STR append,99,160,61.88
+221,STR append (1KB + 1KB),95,134,70.90
+222,STR append (10KB + 1KB),209,537,38.92
+223,STR append (1MB + 2b * 1000),38681,190529,20.30
+224,STR append (1MB + 1KB),28344,173073,16.38
+225,STR append (1MB + 1KB * 20),29077,173622,16.75
+226,STR append (1MB + 1KB * 1000),66893,207868,32.18
+227,STR append (1MB + 1MB * 3),125505,327765,38.29
+228,STR append (1MB + 1MB * 5),158507,855295,18.53
+229,STR append (1MB + (1b + 1K + 1b) * 100),33101,174031,19.02
+230,STR info locals match,946,1521,62.20
+231,TRACE no trace set,34,121,28.10
+232,TRACE read,34,50,68.00
+233,TRACE write,33,50,66.00
+234,TRACE unset,33,48,68.75
+235,TRACE all set (rwu),34,52,65.38
+236,UNSET var exists,12,19,63.16
+237,UNSET catch var exists,13,23,56.52
+238,UNSET catch var !exist,77,105,73.33
+239,UNSET info check var exists,16,27,59.26
+240,UNSET info check var !exist,12,27,44.44
+241,UNSET nocomplain var exists,12,18,66.67
+242,UNSET nocomplain var !exist,12,16,75.00
+243,VAR access locally set,10,19,52.63
+244,VAR access local proc arg,10,20,50.00
+245,VAR access global,35,49,71.43
+246,VAR access upvar,40,54,74.07
+247,VAR set scalar,7,15,46.67
+248,VAR set array element,14,28,50.00
+249,VAR 100 'set's in array,161,272,59.19
+250,VAR 'array set' of 100 elems,306,467,65.52
diff --git a/tcllib/modules/csv/mem_debug_bench_a.csv b/tcllib/modules/csv/mem_debug_bench_a.csv
new file mode 100644
index 0000000..8e17485
--- /dev/null
+++ b/tcllib/modules/csv/mem_debug_bench_a.csv
@@ -0,0 +1,256 @@
+000,VERSIONS:,2:8.4a3,1:8.4a3,1:8.4a3%
+001,CATCH return ok,7,13,53.85
+002,CATCH return error,68,91,74.73
+003,CATCH no catch used,7,14,50.00
+004,IF if true numeric,12,33,36.36
+005,IF elseif true numeric,15,47,31.91
+
+006,IF else true numeric,15,46,32.61
+007,IF if true num/num,13,32,40.62
+008,IF if false num/num,13,32,40.62
+009,IF if false al/num,28,57,49.12
+010,IF if true al/num,34,54,62.96
+011,IF if false al/num,34,58,58.62
+012,IF if true al/al,33,100,33.00
+013,IF elseif true al/al,50,87,57.47
+014,IF else true al/al,50,92,54.35
+015,SWITCH first true,50,81,61.73
+016,SWITCH second true,55,84,65.48
+017,SWITCH ninth true,56,96,58.33
+018,SWITCH default true,48,81,59.26
+019,DATA create in a list,5419,13514,40.10
+020,DATA create in an array,5861,15537,37.72
+021,DATA access in a list,4424,9967,44.39
+
+022,DATA access in an array,4373,9167,47.70
+023,EVAL cmd eval in list obj var,26,45,57.78
+024,EVAL cmd eval as list,23,42,54.76
+025,EVAL cmd eval as string,53,92,57.61
+026,EVAL cmd and mixed lists,3805,11276,33.74
+027,EVAL list cmd and mixed lists,3812,11325,33.66
+028,EVAL list cmd and pure lists,592,1598,37.05
+029,EXPR unbraced,174,250,69.60
+030,EXPR braced,27,60,45.00
+031,EXPR inline,28,51,54.90
+032,EXPR one operand,8,13,61.54
+033,EXPR ten operands,15,25,60.00
+
+
+034,EXPR fifty operands,46,73,63.01
+035,EXPR incr with incr,13,20,65.00
+036,EXPR incr with expr,8,14,57.14
+037,KLIST shuffle0 llength 1,154,260,59.23
+038,KLIST shuffle0 llength 10,521,950,54.84
+039,KLIST shuffle0 llength 100,4126,7781,53.03
+040,KLIST shuffle0 llength 1000,46309,85434,54.20
+041,KLIST shuffle0 llength 10000,612676,1000055,61.26
+042,KLIST shuffle1 llength 1,100,181,55.25
+043,KLIST shuffle1 llength 10,432,835,51.74
+044,KLIST shuffle1 llength 100,5872,14144,41.52
+045,KLIST shuffle1 llength 1000,1293956,1235661,104.72
+046,KLIST shuffle1a llength 1,115,200,57.50
+047,KLIST shuffle1a llength 10,442,1012,43.68
+048,KLIST shuffle1a llength 100,4212,9609,43.83
+049,KLIST shuffle1a llength 1000,42350,98262,43.10
+050,KLIST shuffle1a llength 10000,445084,1052460,42.29
+051,KLIST shuffle2 llength 1,123,205,60.00
+052,KLIST shuffle2 llength 10,484,922,52.49
+
+053,KLIST shuffle2 llength 100,4377,8347,52.44
+054,KLIST shuffle2 llength 1000,46002,89585,51.35
+055,KLIST shuffle2 llength 10000,525442,926369,56.72
+056,KLIST shuffle3 llength 1,116,196,59.18
+057,KLIST shuffle3 llength 10,420,911,46.10
+058,KLIST shuffle3 llength 100,3730,8465,44.06
+059,KLIST shuffle3 llength 1000,39397,87416,45.07
+060,KLIST shuffle3 llength 10000,949689,1391544,68.25
+061,KLIST shuffle4 llength 1,116,204,56.86
+062,KLIST shuffle4 llength 10,450,1000,45.00
+063,KLIST shuffle4 llength 100,4067,9326,43.61
+064,KLIST shuffle4 llength 1000,39142,92580,42.28
+065,KLIST shuffle4 llength 10000,421581,944205,44.65
+066,"STR/LIST length; obj shimmer",3268,6767,48.29
+067,"LIST length; pure list",17,21,80.95
+068,STR length of a LIST,12,25,48.00
+069,"LIST exact search; first item",18,24,75.00
+070,"LIST exact search; middle item",74,111,66.67
+071,"LIST exact search; last item",142,236,60.17
+072,"LIST exact search; non-item",344,603,57.05
+073,"LIST sorted search; first item",19,29,65.52
+074,"LIST sorted search; middle item",19,27,70.37
+075,"LIST sorted search; last item",19,27,70.37
+076,"LIST sorted search; non-item",19,27,70.37
+077,"LIST exact search; untyped item",148,230,64.35
+078,"LIST exact search; typed item",107,119,89.92
+079,"LIST sorted search; typed item",18,29,62.07
+080,LIST sort,3620,4994,72.49
+081,LIST typed sort,2923,3885,75.24
+082,LIST remove first element,310,763,40.63
+083,LIST remove middle element,308,761,40.47
+084,LIST remove last element,312,757,41.22
+085,LIST replace first element,291,740,39.32
+086,LIST replace middle element,295,741,39.81
+087,LIST replace last element,295,743,39.70
+088,LIST replace first el with multiple,315,770,40.91
+089,LIST replace middle el with multiple,314,764,41.10
+090,LIST replace last el with multiple,288,750,38.40
+091,LIST replace range,288,737,39.08
+092,LIST remove in mixed list,411,959,42.86
+093,LIST replace in mixed list,398,932,42.70
+094,LIST index first element,14,24,58.33
+095,LIST index middle element,14,28,50.00
+096,LIST index last element,14,28,50.00
+097,LIST insert an item at start,297,750,39.60
+098,LIST insert an item at middle,303,746,40.62
+099,"LIST insert an item at ""end""",299,746,40.08
+100,"LIST small; early range",26,41,63.41
+101,"LIST small; late range",23,33,69.70
+102,"LIST large; early range",42,94,44.68
+103,"LIST large; late range",41,106,38.68
+104,LIST append to list,406,426,95.31
+105,LIST join list,1147,1687,67.99
+106,"LOOP for; iterate list",6848,16393,41.77
+107,"LOOP foreach; iterate list",2169,5913,36.68
+108,LOOP for (to 1000),2756,8183,33.68
+109,LOOP while (to 1000),2753,8181,33.65
+110,"LOOP for; iterate string",8350,15966,52.30
+111,"LOOP foreach; iterate string",2684,7094,37.83
+112,MAP string 1 val,686,1097,62.53
+113,MAP string 2 val,1578,2375,66.44
+114,MAP string 3 val,1938,2674,72.48
+115,MAP string 4 val,2427,3324,73.01
+116,MAP string 1 val -nocase,3772,5524,68.28
+117,MAP string 2 val -nocase,6633,9624,68.92
+118,MAP string 3 val -nocase,8809,12682,69.46
+119,MAP string 4 val -nocase,10692,15353,69.64
+120,MAP regsub 1 val,3884,4345,89.39
+121,MAP regsub 2 val,16420,17435,94.18
+122,MAP regsub 3 val,22056,23287,94.71
+123,MAP regsub 4 val,27550,29333,93.92
+124,MAP regsub 1 val -nocase,4004,4322,92.64
+125,MAP regsub 2 val -nocase,16519,17289,95.55
+126,MAP regsub 3 val -nocase,22075,23427,94.23
+127,MAP regsub 4 val -nocase,27981,29438,95.05
+128,"MAP string; no match",1011,1734,58.30
+129,"MAP string -nocase; no match",7090,10589,66.96
+130,"MAP regsub; no match",1226,2328,52.66
+131,"MAP regsub -nocase; no match",1287,2295,56.08
+132,MAP string short,44,58,75.86
+133,MAP regsub short,188,219,85.84
+134,MTHD direct ns proc call,8,15,53.33
+135,MTHD imported ns proc call,8,16,50.00
+136,MTHD interp alias proc call,25,44,56.82
+137,MTHD indirect proc eval,36,58,62.07
+138,MTHD indirect proc eval #2,58,100,58.00
+139,MTHD array stored proc call,11,25,44.00
+140,MTHD switch method call,53,86,61.63
+141,MTHD ns lookup call,113,189,59.79
+142,MTHD inline call,3,9,33.33
+143,PROC explicit return,7,12,58.33
+144,PROC implicit return,7,17,41.18
+145,PROC explicit return (2),7,13,53.85
+146,PROC implicit return (2),7,15,46.67
+147,PROC explicit return (3),7,12,58.33
+148,PROC implicit return (3),7,12,58.33
+149,PROC heavily commented,7,12,58.33
+150,"PROC do-nothing; no args",6,11,54.55
+151,"PROC do-nothing; one arg",7,12,58.33
+152,PROC local links with global,1611,2827,56.99
+153,PROC local links with upvar,1308,2630,49.73
+154,PROC local links with variable,1309,2358,55.51
+155,"READ 595K; gets",386913,551429,70.17
+156,"READ 595K; read",85889,164758,52.13
+157,"READ 595K; read & size",86171,164854,52.27
+158,"READ 3050b; gets",2152,3481,61.82
+159,"READ 3050b; read",561,682,82.26
+160,"READ 3050b; read & size",606,738,82.11
+161,"BREAD 595K; gets",392519,568992,68.98
+162,"BREAD 595K; read",51133,110961,46.08
+163,"BREAD 595K; read & size",51194,110552,46.31
+164,"BREAD 3050b; gets",2213,3174,69.72
+165,"BREAD 3050b; read",329,472,69.70
+166,"BREAD 3050b; read & size",377,517,72.92
+167,REGEXP literal regexp,48,58,82.76
+168,REGEXP var-based regexp,51,60,85.00
+169,REGEXP count all matches,149,161,92.55
+170,REGEXP extract all matches,201,255,78.82
+171,STARTUP time to launch tclsh,26402,32329,81.67
+172,STR str [string compare],15,38,39.47
+173,STR str [string equal],15,38,39.47
+174,"STR str $a equal """"",13,32,40.62
+175,"STR str num == """"",15,38,39.47
+176,STR str $a eq $b,21,49,42.86
+177,STR str $a ne $b,21,49,42.86
+178,STR str $a eq $b (same obj),19,45,42.22
+179,STR str $a ne $b (same obj),19,46,41.30
+180,STR length (==4010),13,23,56.52
+181,STR index 0,19,30,63.33
+182,STR index 100,20,31,64.52
+183,STR index 500,19,30,63.33
+184,STR index2 0,20,32,62.50
+185,STR index2 100,21,30,70.00
+186,STR index2 500,20,31,64.52
+187,STR first (success),17,23,73.91
+188,STR first (failure),115,116,99.14
+189,STR first (total failure),106,103,102.91
+190,STR last (success),17,23,73.91
+191,STR last (failure),91,109,83.49
+192,STR last (total failure),82,86,95.35
+193,"STR match; simple (success early)",17,31,54.84
+194,"STR match; simple (success late)",18,30,60.00
+195,"STR match; simple (failure)",18,28,64.29
+196,"STR match; simple (total failure)",16,29,55.17
+197,"STR match; complex (success early)",18,34,52.94
+198,"STR match; complex (success late)",152,165,92.12
+199,"STR match; complex (failure)",121,134,90.30
+200,"STR match; complex (total failure)",95,101,94.06
+201,"STR range; index 100..200 of 4010",26,40,65.00
+202,"STR replace; no replacement",87,126,69.05
+203,"STR replace; equal replacement",93,133,69.92
+204,"STR replace; longer replacement",103,146,70.55
+205,"STR repeat; abcdefghij * 10",16,23,69.57
+206,"STR repeat; abcdefghij * 100",48,47,102.13
+207,"STR repeat; abcdefghij * 1000",231,257,89.88
+208,"STR repeat; 4010 chars * 10",282,744,37.90
+209,"STR repeat; 4010 chars * 100",6976,14673,47.54
+210,"STR reverse iter1; 100 chars",1534,2295,66.84
+211,"STR reverse iter1; 100 uchars",1457,2322,62.75
+212,"STR reverse iter2; 100 chars",1123,2042,55.00
+213,"STR reverse iter2; 100 uchars",1042,1972,52.84
+214,"STR reverse recur1; 100 chars",3458,7067,48.93
+215,"STR reverse recur1; 100 uchars",3523,6650,52.98
+216,"STR split; 4010 chars",2806,4605,60.93
+217,"STR split; 12100 uchars",7890,13813,57.12
+218,"STR split iter; 4010 chars",11129,28087,39.62
+219,"STR split iter; 12100 uchars",33318,86314,38.60
+220,STR append,99,160,61.88
+221,STR append (1KB + 1KB),95,134,70.90
+222,STR append (10KB + 1KB),209,537,38.92
+223,STR append (1MB + 2b * 1000),38681,190529,20.30
+224,STR append (1MB + 1KB),28344,173073,16.38
+225,STR append (1MB + 1KB * 20),29077,173622,16.75
+226,STR append (1MB + 1KB * 1000),66893,207868,32.18
+227,STR append (1MB + 1MB * 3),125505,327765,38.29
+228,STR append (1MB + 1MB * 5),158507,855295,18.53
+229,STR append (1MB + (1b + 1K + 1b) * 100),33101,174031,19.02
+230,STR info locals match,946,1521,62.20
+231,TRACE no trace set,34,121,28.10
+232,TRACE read,34,50,68.00
+233,TRACE write,33,50,66.00
+234,TRACE unset,33,48,68.75
+235,TRACE all set (rwu),34,52,65.38
+236,UNSET var exists,12,19,63.16
+237,UNSET catch var exists,13,23,56.52
+238,UNSET catch var !exist,77,105,73.33
+239,UNSET info check var exists,16,27,59.26
+240,UNSET info check var !exist,12,27,44.44
+241,UNSET nocomplain var exists,12,18,66.67
+242,UNSET nocomplain var !exist,12,16,75.00
+243,VAR access locally set,10,19,52.63
+244,VAR access local proc arg,10,20,50.00
+245,VAR access global,35,49,71.43
+246,VAR access upvar,40,54,74.07
+247,VAR set scalar,7,15,46.67
+248,VAR set array element,14,28,50.00
+249,VAR 100 'set's in array,161,272,59.19
+250,VAR 'array set' of 100 elems,306,467,65.52
diff --git a/tcllib/modules/csv/pkgIndex.tcl b/tcllib/modules/csv/pkgIndex.tcl
new file mode 100644
index 0000000..538e735
--- /dev/null
+++ b/tcllib/modules/csv/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded csv 0.8.1 [list source [file join $dir csv.tcl]]
diff --git a/tcllib/modules/debug/ChangeLog b/tcllib/modules/debug/ChangeLog
new file mode 100644
index 0000000..d2af643
--- /dev/null
+++ b/tcllib/modules/debug/ChangeLog
@@ -0,0 +1,31 @@
+2013-12-17 Andreas Kupries <andreask@activestate.com>
+
+ * debug_heartbeat.man: Fixed missing requirement of the
+ * debug_timestamp.man: package itself.
+
+2013-08-06 Andreas Kupries <aku@hephaistos>
+
+ * debug.tcl: Fixed bug in 'pdict', access to name of the array
+ * debug.man: this is not about. Version bumped to 1.0.2
+ * pkgIndex.tcl:
+
+2013-07-31 Andreas Kupries <andreask@activestate.com>
+
+ * debug.tcl: Fixed missing export of 'pdict'. Plus better handling
+ * debug.man: of output channel definition. stderr is default only
+ * pkgIndex.tcl: if nothing is set by the user. This now allows
+ applications to override the default for all packages not having
+ their own output settings. Version bumped to 1.0.1
+
+2013-04-08 Andreas Kupries <andreask@activestate.com>
+
+ * debug.man: Added documentation.
+ * debug_caller.man:
+ * debug_heartbeat.man:
+ * debug_timestamp.man:
+
+2013-04-04 Andreas Kupries <aku@hephaistos>
+
+ * New module and packages for generating a debug
+ narrative. Adapted from the Wub utility package
+ Debug, by Colin McCormack.
diff --git a/tcllib/modules/debug/caller.tcl b/tcllib/modules/debug/caller.tcl
new file mode 100644
index 0000000..e85a9f0
--- /dev/null
+++ b/tcllib/modules/debug/caller.tcl
@@ -0,0 +1,97 @@
+## -*- tcl -*-
+# ### ### ### ######### ######### #########
+
+## Utility command for use as debug prefix command to un-mangle snit
+## and TclOO method calls.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require debug
+
+namespace eval ::debug {
+ namespace export caller
+ namespace ensemble create
+}
+
+# ### ### ### ######### ######### #########
+## API & Implementation
+
+proc ::debug::caller {args} {
+ # For snit (type)methods, rework the command line to be more
+ # legible and in line with what the user would expect. To this end
+ # we pull the primary command out of the arguments, be it type or
+ # object, massage the command to match the original (type)method
+ # name, then resort and expand the words to match the call before
+ # the snit got its claws into it.
+
+ set a [lassign [info level -1] m]
+ regsub {.*Snit_} $m {} m
+
+ if {[string match ::oo::Obj*::my $m]} {
+ # TclOO call.
+ set m [uplevel 1 self]
+ return [list $m {*}[Filter $a $args]]
+ }
+ if {$m eq "my"} {
+ # TclOO call.
+ set m [uplevel 1 self]
+ return [list $m {*}[Filter $a $args]]
+ }
+
+ switch -glob -- $m {
+ htypemethod* {
+ # primary = type, a = type
+ set a [lassign $a primary]
+ set m [string map {_ { }} [string range $m 11 end]]
+ }
+ typemethod* {
+ # primary = type, a = type
+ set a [lassign $a primary]
+ set m [string range $m 10 end]
+ }
+ hmethod* {
+ # primary = self, a = type selfns self win ...
+ set a [lassign $a _ _ primary _]
+ set m [string map {_ { }} [string range $m 7 end]]
+ }
+ method* {
+ # primary = self, a = type selfns self win ...
+ set a [lassign $a _ _ primary _]
+ set m [string range $m 6 end]
+ }
+ destructor -
+ constructor {
+ # primary = self, a = type selfns self win ...
+ set a [lassign $a _ _ primary _]
+ }
+ typeconstructor {
+ return [list {*}$a $m]
+ }
+ default {
+ # Unknown
+ return [list $m {*}[Filter $a $args]]
+ }
+ }
+ return [list $primary {*}$m {*}[Filter $a $args]]
+}
+
+proc ::debug::Filter {args droplist} {
+ if {[llength $droplist]} {
+ # Replace unwanted arguments with '*'. This is usually done
+ # for arguments which can be large Tcl values. These would
+ # screw up formatting and, to add insult to this injury, also
+ # repeat for each debug output in the same proc, method, etc.
+ foreach i [lsort -integer $droplist] {
+ set args [lreplace $args $i $i *]
+ }
+ }
+ return $args
+}
+
+# ### ######### ###########################
+## Ready for use
+
+package provide debug::caller 1.1
+return
diff --git a/tcllib/modules/debug/debug.man b/tcllib/modules/debug/debug.man
new file mode 100644
index 0000000..f7e7602
--- /dev/null
+++ b/tcllib/modules/debug/debug.man
@@ -0,0 +1,247 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset PACKAGE_VERSION 1.0.6]
+[manpage_begin debug n [vset PACKAGE_VERSION]]
+[keywords debug]
+[keywords log]
+[keywords narrative]
+[keywords trace]
+[copyright {200?, Colin McCormack, Wub Server Utilities}]
+[copyright {2012-2014, Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {debug narrative}]
+[titledesc {debug narrative - core}]
+[category {debugging, tracing, and logging}]
+[require Tcl 8.5]
+[require debug [opt [vset PACKAGE_VERSION]]]
+[description]
+
+Debugging areas of interest are represented by 'tags' which have
+independently settable levels of interest (an integer, higher is more
+detailed).
+
+[section API]
+
+[list_begin definitions]
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug.][var tag] [arg message] [opt [arg level]]]
+
+For each known tag the package creates a command with this signature
+the user can then use to provide the debug narrative of the tag.
+
+The narrative [arg message] is provided as a Tcl script whose value is
+[cmd subst]ed in the caller's scope if and only if the current level of
+interest for the [arg tag] matches or exceeds the call's [arg level]
+of detail. This is useful, as one can place arbitrarily complex
+narrative in code without unnecessarily evaluating it.
+
+[para] See methods [method level] and [method setting] for querying
+and manipulating the current level of detail for tags.
+
+[para] The actually printed text consists of not only the
+[arg message], but also global and tag-specific prefix and suffix,
+should they exist, with each line in the message having the specified
+headers and trailers.
+
+[para] All these parts are [cmd subst]ableTcl scripts, which are
+substituted once per message before assembly.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method 2array]]
+
+This method returns a dictionary mapping the names of all debug tags
+currently known to the package to their state and log level. The
+latter are encoded in a single numeric value, where a negative number
+indicates an inactive tag at the level given by the absolute value, and
+a positive number is an active tag at that level.
+
+[para] See also method [method settings] below.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method define] [arg tag]]
+
+This method registers the named [arg tag] with the package. If the
+tag was not known before it is placed in an inactive state. The state
+of an already known tag is left untouched.
+
+[para] The result of the method is the empty string.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method header] [arg text]]
+
+This method defines a global [cmd subst]able Tcl script which provides
+a text printed before each line of output.
+
+[para] Note how this is tag-independent.
+
+[para] Further note that the header substitution happens only once per
+actual printed message, i.e. all lines of the same message will have
+the same actual heading text.
+
+[para] The result of the method is the specified text.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method level] [arg tag] [opt [arg level]] [opt [arg fd]]]
+
+This method sets the detail-[arg level] for the [arg tag], and the
+channel [arg fd] to write the tags narration into.
+
+The level is an integer value >= 0 defaulting to [const 1].
+
+The channel defaults to [const stderr].
+
+[para] The result of the method is the new detail-level for the tag.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method names]]
+
+This method returns a list containing the names of all debug tags
+currently known to the package.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method off] [arg tag]]
+
+This method registers the named [arg tag] with the package and sets it
+inactive.
+
+[para] The result of the method is the empty string.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method on] [arg tag]]
+
+This method registers the named [arg tag] with the package, as active.
+
+[para] The result of the method is the empty string.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method parray] [arg arrayvarname]]
+
+This is a convenience method formatting the named array like the
+builtin command [cmd parray], except it returns the resulting string
+instead of writing it directly to [const stdout].
+
+[para] This makes it suitable for use in debug messages.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method pdict] [arg dict]]
+
+This is a convenience method formatting the dictionary similarly to
+how the builtin command [cmd parray] does for array, and returns the
+resulting string.
+
+[para] This makes it suitable for use in debug messages.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method hexl] [arg data] [opt [arg prefix]]]
+
+This is a convenience method formatting arbitrary data into a hex-dump
+and returns the resulting string.
+
+[para] This makes it suitable for use in debug messages.
+
+[para] Each line of the dump is prefixed with [arg prefix]. This prefix
+defaults to the empty string.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method nl]]
+
+This is a convenience method to insert a linefeed character (ASCII 0x0a)
+into a debug message.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method tab]]
+
+This is a convenience method to insert a TAB character (ASCII 0x09)
+into a debug message.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method prefix] [arg tag] [opt [arg text]]]
+
+This method is similar to the method [method header] above, in that it
+defines [cmd subst]able Tcl script which provides more text for debug
+messages.
+
+[para] In contrast to [method header] the generated text is added to the
+user's message before it is split into lines, making it a per-message
+extension.
+
+[para] Furthermore the script is tag-dependent.
+
+[para] In exception to that, a script for tag [const ::] is applied
+to all messages.
+
+[para] If both global and tag-dependent prefix exist, both are
+applied, with the global prefix coming before the tag-dependent
+prefix.
+
+[para] Note that the prefix substitution happens only once per
+actual printed message.
+
+[para] The result of the method is the empty string.
+
+[para] If the [arg tag] was not known at the time of the call it is
+registered, and set inactive.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method setting] ([arg tag] [arg level]) ... [opt [arg fd]]]
+
+This method is a multi-tag variant of method [method level] above,
+with the functionality of methods [method on], and [method off] also
+folded in.
+
+[para] Each named [arg tag] is set to the detail-[arg level] following
+it, with a negative level deactivating the tag, and a positive level
+activating it.
+
+[para] If the last argument is not followed by a level it is not
+treated as tag name, but as the channel all the named tags should
+print their messages to.
+
+[para] The result of the method is the empty string.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method suffix] [arg tag] [opt [arg text]]]
+
+This method is similar to the method [method trailer] below, in that
+it defines [cmd subst]able Tcl script which provides more text for
+debug messages.
+
+[para] In contrast to [method trailer] the generated text is added to
+the user's message before it is split into lines, making it a
+per-message extension.
+
+[para] Furthermore the script is tag-dependent.
+
+[para] In exception to that, a script for tag [const ::] is applied
+to all messages.
+
+[para] If both global and tag-dependent suffix exist, both are
+applied, with the global suffix coming after the tag-dependent suffix.
+
+[para] Note that the suffix substitution happens only once per actual
+printed message.
+
+[para] The result of the method is the empty string.
+
+[para] If the [arg tag] was not known at the time of the call it is
+registered, and set inactive.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd debug] [method trailer] [arg text]]
+
+This method defines a global [cmd subst]able Tcl script which provides
+a text printed after each line of output (before the EOL however).
+
+[para] Note how this is tag-independent.
+
+[para] Further note that the trailer substitution happens only once
+per actual printed message, i.e. all lines of the same message will
+have the same actual trailing text.
+
+[para] The result of the method is the specified text.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[list_end]
+
+[vset CATEGORY debug]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/debug/debug.tcl b/tcllib/modules/debug/debug.tcl
new file mode 100644
index 0000000..4ce6080
--- /dev/null
+++ b/tcllib/modules/debug/debug.tcl
@@ -0,0 +1,306 @@
+# Debug - a debug narrative logger.
+# -- Colin McCormack / originally Wub server utilities
+#
+# Debugging areas of interest are represented by 'tokens' which have
+# independantly settable levels of interest (an integer, higher is more detailed)
+#
+# Debug narrative is provided as a tcl script whose value is [subst]ed in the
+# caller's scope if and only if the current level of interest matches or exceeds
+# the Debug call's level of detail. This is useful, as one can place arbitrarily
+# complex narrative in code without unnecessarily evaluating it.
+#
+# TODO: potentially different streams for different areas of interest.
+# (currently only stderr is used. there is some complexity in efficient
+# cross-threaded streams.)
+
+# # ## ### ##### ######## ############# #####################
+## Requisites
+
+package require Tcl 8.5
+
+namespace eval ::debug {
+ namespace export -clear \
+ define on off prefix suffix header trailer \
+ names 2array level setting parray pdict \
+ nl tab hexl
+ namespace ensemble create -subcommands {}
+}
+
+# # ## ### ##### ######## ############# #####################
+## API & Implementation
+
+proc ::debug::noop {args} {}
+
+proc ::debug::debug {tag message {level 1}} {
+ variable detail
+ if {$detail($tag) < $level} {
+ #puts stderr "$tag @@@ $detail($tag) >= $level"
+ return
+ }
+
+ variable prefix
+ variable suffix
+ variable header
+ variable trailer
+ variable fds
+
+ if {[info exists fds($tag)]} {
+ set fd $fds($tag)
+ } else {
+ set fd stderr
+ }
+
+ # Assemble the shown text from the user message and the various
+ # prefixes and suffices (global + per-tag).
+
+ set themessage ""
+ if {[info exists prefix(::)]} { append themessage $prefix(::) }
+ if {[info exists prefix($tag)]} { append themessage $prefix($tag) }
+ append themessage $message
+ if {[info exists suffix($tag)]} { append themessage $suffix($tag) }
+ if {[info exists suffix(::)]} { append themessage $suffix(::) }
+
+ # Resolve variables references and command invokations embedded
+ # into the message with plain text.
+ set code [catch {
+ set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]]
+ set sheader [uplevel 1 [list ::subst -nobackslashes $header]]
+ set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]]
+ } __ eo]
+
+ # And dump an internal error if that resolution failed.
+ if {$code} {
+ if {[catch {
+ set caller [info level -1]
+ }]} { set caller GLOBAL }
+ if {[string length $caller] >= 1000} {
+ set caller "[string range $caller 0 200]...[string range $caller end-200 end]"
+ }
+ foreach line [split $caller \n] {
+ puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)"
+ }
+ return
+ }
+
+ # From here we have a good message to show. We only shorten it a
+ # bit if its a bit excessive in size.
+
+ if {[string length $smessage] > 4096} {
+ set head [string range $smessage 0 2048]
+ set tail [string range $smessage end-2048 end]
+ set smessage "${head}...(truncated)...$tail"
+ }
+
+ foreach line [split $smessage \n] {
+ puts $fd "$sheader$tag | $line$strailer"
+ }
+ return
+}
+
+# names - return names of debug tags
+proc ::debug::names {} {
+ variable detail
+ return [lsort [array names detail]]
+}
+
+proc ::debug::2array {} {
+ variable detail
+ set result {}
+ foreach n [lsort [array names detail]] {
+ if {[interp alias {} debug.$n] ne "::debug::noop"} {
+ lappend result $n $detail($n)
+ } else {
+ lappend result $n -$detail($n)
+ }
+ }
+ return $result
+}
+
+# level - set level and fd for tag
+proc ::debug::level {tag {level ""} {fd {}}} {
+ variable detail
+ # TODO: Force level >=0.
+ if {$level ne ""} {
+ set detail($tag) $level
+ }
+
+ if {![info exists detail($tag)]} {
+ set detail($tag) 1
+ }
+
+ variable fds
+ if {$fd ne {}} {
+ set fds($tag) $fd
+ }
+
+ return $detail($tag)
+}
+
+proc ::debug::header {text} { variable header $text }
+proc ::debug::trailer {text} { variable trailer $text }
+
+proc ::debug::define {tag} {
+ if {[interp alias {} debug.$tag] ne {}} return
+ off $tag
+ return
+}
+
+# Set a prefix/suffix to use for tag.
+# The global (tag-independent) prefix/suffix is adressed through tag '::'.
+# This works because colon (:) is an illegal character for user-specified tags.
+
+proc ::debug::prefix {tag {theprefix {}}} {
+ variable prefix
+ set prefix($tag) $theprefix
+
+ if {[interp alias {} debug.$tag] ne {}} return
+ off $tag
+ return
+}
+
+proc ::debug::suffix {tag {theprefix {}}} {
+ variable suffix
+ set suffix($tag) $theprefix
+
+ if {[interp alias {} debug.$tag] ne {}} return
+ off $tag
+ return
+}
+
+# turn on debugging for tag
+proc ::debug::on {tag {level ""} {fd {}}} {
+ variable active
+ set active($tag) 1
+ level $tag $level $fd
+ interp alias {} debug.$tag {} ::debug::debug $tag
+ return
+}
+
+# turn off debugging for tag
+proc ::debug::off {tag {level ""} {fd {}}} {
+ variable active
+ set active($tag) 1
+ level $tag $level $fd
+ interp alias {} debug.$tag {} ::debug::noop
+ return
+}
+
+proc ::debug::setting {args} {
+ if {[llength $args] == 1} {
+ set args [lindex $args 0]
+ }
+ set fd stderr
+ if {[llength $args] % 2} {
+ set fd [lindex $args end]
+ set args [lrange $args 0 end-1]
+ }
+ foreach {tag level} $args {
+ if {$level > 0} {
+ level $tag $level $fd
+ interp alias {} debug.$tag {} ::debug::debug $tag
+ } else {
+ level $tag [expr {-$level}] $fd
+ interp alias {} debug.$tag {} ::debug::noop
+ }
+ }
+ return
+}
+
+# # ## ### ##### ######## ############# #####################
+## Convenience commands.
+# Format arrays and dicts as multi-line message.
+# Insert newlines and tabs.
+
+proc ::debug::nl {} { return \n }
+proc ::debug::tab {} { return \t }
+
+proc ::debug::parray {a {pattern *}} {
+ upvar 1 $a array
+ if {![array exists array]} {
+ error "\"$a\" isn't an array"
+ }
+ pdict [array get array] $pattern
+}
+
+proc ::debug::pdict {dict {pattern *}} {
+ set maxl 0
+ set names [lsort -dict [dict keys $dict $pattern]]
+ foreach name $names {
+ if {[string length $name] > $maxl} {
+ set maxl [string length $name]
+ }
+ }
+ set maxl [expr {$maxl + 2}]
+ set lines {}
+ foreach name $names {
+ set nameString [format (%s) $name]
+ lappend lines [format "%-*s = %s" \
+ $maxl $nameString \
+ [dict get $dict $name]]
+ }
+ return [join $lines \n]
+}
+
+proc ::debug::hexl {data {prefix {}}} {
+ set r {}
+
+ # Convert the data to hex and to characters.
+ binary scan $data H*@0a* hexa asciia
+
+ # Replace non-printing characters in the data with dots.
+ regsub -all -- {[^[:graph:] ]} $asciia {.} asciia
+
+ # Pad with spaces to a full multiple of 32/16.
+ set n [expr {[string length $hexa] % 32}]
+ if {$n < 32} { append hexa [string repeat { } [expr {32-$n}]] }
+ #puts "pad H [expr {32-$n}]"
+
+ set n [expr {[string length $asciia] % 32}]
+ if {$n < 16} { append asciia [string repeat { } [expr {16-$n}]] }
+ #puts "pad A [expr {32-$n}]"
+
+ # Reassemble formatted, in groups of 16 bytes/characters.
+ # The hex part is handled in groups of 32 nibbles.
+ set addr 0
+ while {[string length $hexa]} {
+ # Get front group of 16 bytes each.
+ set hex [string range $hexa 0 31]
+ set ascii [string range $asciia 0 15]
+ # Prep for next iteration
+ set hexa [string range $hexa 32 end]
+ set asciia [string range $asciia 16 end]
+
+ # Convert the hex to pairs of hex digits
+ regsub -all -- {..} $hex {& } hex
+
+ # Add the hex and latin-1 data to the result buffer
+ append r $prefix [format %04x $addr] { | } $hex { |} $ascii |\n
+ incr addr 16
+ }
+
+ # And done
+ return $r
+}
+
+# # ## ### ##### ######## ############# #####################
+
+namespace eval debug {
+ variable detail ; # map: TAG -> level of interest
+ variable prefix ; # map: TAG -> message prefix to use
+ variable suffix ; # map: TAG -> message suffix to use
+ variable fds ; # map: TAG -> handle of open channel to log to.
+ variable header {} ; # per-line heading, subst'ed
+ variable trailer {} ; # per-line ending, subst'ed
+
+ # Notes:
+ # - The tag '::' is reserved. "prefix" and "suffix" use it to store
+ # the global message prefix / suffix.
+ # - prefix and suffix are applied per message.
+ # - header and trailer are per line. And should not generate multiple lines!
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide debug 1.0.6
+return
diff --git a/tcllib/modules/debug/debug_caller.man b/tcllib/modules/debug/debug_caller.man
new file mode 100644
index 0000000..65de916
--- /dev/null
+++ b/tcllib/modules/debug/debug_caller.man
@@ -0,0 +1,44 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset VERSION 1.1]
+[manpage_begin debug::caller n [vset VERSION]]
+[keywords debug]
+[keywords log]
+[keywords narrative]
+[keywords trace]
+[copyright {2012-2015, Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {debug narrative}]
+[titledesc {debug narrative - caller}]
+[category {debugging, tracing, and logging}]
+[require Tcl 8.5]
+[require debug::caller [opt [vset VERSION]]]
+[description]
+[para]
+
+[section API]
+
+[list_begin definitions]
+[call [cmd debug] [method caller] [opt [arg args]...]]
+
+This method is useful in a tag-specific prefix to automatically
+provide caller information for all uses of the tag. Or in a message,
+when only specific places need such detail.
+
+[para] Beyond that it recognizing the various internal forms of method
+calls generated by the [package snit] OO system and rewrites these to
+their original form, for better readability.
+
+Similarly for [package TclOO].
+
+[para] If [arg args] are specified then they are treated as the
+integer indices of command arguments to [emph not] show in the
+output. The referenced arguments are replaced by [const *] instead.
+
+The main anticipiated use case for this is the exclusion of arguments
+expected to contain large Tcl values, i.e. long lists, large
+dictionaries, etc. to prevent them from overwhelming the narrative.
+
+[list_end]
+
+[vset CATEGORY debug]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/debug/debug_heartbeat.man b/tcllib/modules/debug/debug_heartbeat.man
new file mode 100644
index 0000000..28a60b6
--- /dev/null
+++ b/tcllib/modules/debug/debug_heartbeat.man
@@ -0,0 +1,43 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset VERSION 1]
+[manpage_begin debug::heartbeat n [vset VERSION]]
+[keywords debug]
+[keywords heartbeat]
+[keywords log]
+[keywords narrative]
+[keywords trace]
+[copyright {200?, Colin McCormack, Wub Server Utilities}]
+[copyright {2012, Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {debug narrative}]
+[titledesc {debug narrative - heartbeat}]
+[category {debugging, tracing, and logging}]
+[require Tcl 8.5]
+[require debug::heartbeat [opt [vset VERSION]]]
+[require debug [opt 1]]
+[description]
+[para]
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd debug] [method heartbeat] [opt [arg delta]]]
+
+This method activates or disables a heartbeat with which to monitor
+the event loop of an event-based Tcl application.
+
+[para] It reserves the debug tag [const heartbeat] for its operation
+and writes a message every [arg delta] milliseconds.
+
+[para] A [arg delta]-value <= 0 disables the heartbeat.
+
+[para] The message produced by the heartbeat contains a sequence
+counter and the time in milliseconds since the last beat, thus
+providing insight into timing variationsn and deviations from the
+nominal [arg delta].
+
+[list_end]
+
+[vset CATEGORY debug]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/debug/debug_timestamp.man b/tcllib/modules/debug/debug_timestamp.man
new file mode 100644
index 0000000..3c8cb9e
--- /dev/null
+++ b/tcllib/modules/debug/debug_timestamp.man
@@ -0,0 +1,34 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin debug::timestamp n 1]
+[keywords debug]
+[keywords log]
+[keywords narrative]
+[keywords timestamps]
+[keywords trace]
+[copyright {200?, Colin McCormack, Wub Server Utilities}]
+[copyright {2012, Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {debug narrative}]
+[titledesc {debug narrative - timestamping}]
+[category {debugging, tracing, and logging}]
+[require Tcl 8.5]
+[require debug::timestamp [opt 1]]
+[require debug [opt 1]]
+[description]
+[para]
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd debug] [method timestamp]]
+
+This method returns millisecond timing information since a baseline or
+last call, making it useful in a tag-specific prefix to automatically
+provide caller information for all uses of the tag. Or in a message,
+when only specific places need such detail.
+
+[list_end]
+
+[vset CATEGORY debug]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/debug/heartbeat.tcl b/tcllib/modules/debug/heartbeat.tcl
new file mode 100644
index 0000000..00d139f
--- /dev/null
+++ b/tcllib/modules/debug/heartbeat.tcl
@@ -0,0 +1,68 @@
+# -*- tcl -*
+# Debug -- Heartbeat. Track operation of Tcl's eventloop.
+# -- Colin McCormack / originally Wub server utilities
+
+# # ## ### ##### ######## ############# #####################
+## Requisites
+
+package require Tcl 8.5
+package require debug
+
+namespace eval ::debug {
+ namespace export heartbeat
+ namespace ensemble create
+}
+
+# # ## ### ##### ######## ############# #####################
+## API & Implementation
+
+proc ::debug::heartbeat {{delta 500}} {
+ variable duration $delta
+ variable timer
+
+ if {$duration > 0} {
+ # stop a previous heartbeat before starting the next
+ catch { after cancel $timer }
+ on heartbeat
+ every $duration {
+ debug.heartbeat {[debug::pulse]}
+ }
+ } else {
+ catch { after cancel $timer }
+ off heartbeat
+ }
+}
+
+proc ::debug::every {ms body} {
+ eval $body
+ variable timer [after $ms [info level 0]]
+ return
+}
+
+proc ::debug::pulse {} {
+ variable duration
+ variable hbtimer
+ variable heartbeat
+
+ set now [::tcl::clock::milliseconds]
+ set diff [expr {$now - $hbtimer - $duration}]
+
+ set hbtimer $now
+
+ return [list [incr heartbeat] $diff]
+}
+
+# # ## ### ##### ######## ############# #####################
+
+namespace eval ::debug {
+ variable duration 0 ; # milliseconds between heart-beats
+ variable heartbeat 0 ; # beat counter
+ variable hbtimer [::tcl::clock::milliseconds]
+ variable timer
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide debug::heartbeat 1
+return
diff --git a/tcllib/modules/debug/pkgIndex.tcl b/tcllib/modules/debug/pkgIndex.tcl
new file mode 100644
index 0000000..88380bc
--- /dev/null
+++ b/tcllib/modules/debug/pkgIndex.tcl
@@ -0,0 +1,5 @@
+if {![package vsatisfies [package require Tcl] 8.5]} return
+package ifneeded debug 1.0.6 [list source [file join $dir debug.tcl]]
+package ifneeded debug::heartbeat 1 [list source [file join $dir heartbeat.tcl]]
+package ifneeded debug::timestamp 1 [list source [file join $dir timestamp.tcl]]
+package ifneeded debug::caller 1.1 [list source [file join $dir caller.tcl]]
diff --git a/tcllib/modules/debug/timestamp.tcl b/tcllib/modules/debug/timestamp.tcl
new file mode 100644
index 0000000..5fec019
--- /dev/null
+++ b/tcllib/modules/debug/timestamp.tcl
@@ -0,0 +1,47 @@
+# -*- tcl -*
+# Debug -- Timestamps.
+# -- Colin McCormack / originally Wub server utilities
+#
+# Generate timestamps for debug messages.
+# The provided commands are for use in prefixes and headers.
+
+# # ## ### ##### ######## ############# #####################
+## Requisites
+
+package require Tcl 8.5
+package require debug
+
+namespace eval ::debug {
+ namespace export timestamp
+ namespace ensemble create
+}
+
+# # ## ### ##### ######## ############# #####################
+## API & Implementation
+
+proc ::debug::timestamp {} {
+ variable timestamp::delta
+ variable timestamp::baseline
+
+ set now [::tcl::clock::milliseconds]
+ if {$delta} {
+ set time "${now}-[expr {$now - $delta}]mS "
+ } else {
+ set time "${now}mS "
+ }
+ set delta $now
+ return $time
+}
+
+# # ## ### ##### ######## ############# #####################
+
+namespace eval ::debug::timestamp {
+ variable delta 0
+ variable baseline [::tcl::clock::milliseconds]
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide debug::timestamp 1
+return
diff --git a/tcllib/modules/des/ChangeLog b/tcllib/modules/des/ChangeLog
new file mode 100644
index 0000000..fe43322
--- /dev/null
+++ b/tcllib/modules/des/ChangeLog
@@ -0,0 +1,145 @@
+2013-12-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tcldes.man: New documentation files for the helper packages,
+ * tcldesjr.man: refering back to the main package.
+
+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-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-08-20 Andreas Kupries <andreask@activestate.com>
+
+ * des.man: Bumped version to 1.1 due to API extension made by
+ * des.tcl: the last change.
+ * pkgIndex.tcl:
+
+2007-07-05 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * des.test: Previous version of DES used to pad the key to 64
+ * des.tcl: bits. If we are using the old options then add padding. The new
+ version will raise an error instead.
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * des.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-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * des.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * des.test: Hooked into the new common test support code.
+
+2005-10-18 Andreas Kupries <andreask@activestate.com>
+
+ * des.bench: Extended with benchmarks for the keyschedule.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-09-26 Andreas Kupries <andreask@activestate.com>
+
+ * des.man: Fixed syntax error introduced by the last commit.
+
+2005-09-26 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * des.tcl: Imported TclDES to provide a more complete
+ * des.test: implementation of DES and 3DES which supports
+ * des.man: ECB,CBC,OFB and CFB modes. Tcllib des is now
+ * tcldes.tcl: a compatability wrapper which continues to
+ * tcldesjr.tcl: support the previous API and a new one.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-09-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * des.tcl: Fixed expr'essions without braces.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-05-07 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * des.tcl, des.man, pkgIndex.tcl: Hiked the version to 0.8.1
+ * des.tcl (DesBlock): Change the final result from binary format
+ to some bit-shifting for tcl < 8.4 to fix for 64 bit platforms.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * des.tcl: Fixed bug #614591.
+
+2003-02-11 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * des.tcl: Imported and tcllib-ised the DES package
+ from wiki page "DES in Tcl" by Jochen Loewer. NOT added to the
+ main package list as it requires CBC/CFB/OFB modes for real use.
+ * des.test: Modified the Trfcrypt DES test suite.
+ * des.man: Simple documentation - needs more.
diff --git a/tcllib/modules/des/des.bench b/tcllib/modules/des/des.bench
new file mode 100644
index 0000000..2f769eb
--- /dev/null
+++ b/tcllib/modules/des/des.bench
@@ -0,0 +1,105 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'des' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+package forget tclDES
+catch {namespace delete ::des}
+catch {source [file join [file dirname [info script]] tcldes.tcl]}
+
+package forget des
+catch {namespace delete ::DES}
+source [file join [file dirname [info script]] des.tcl]
+
+set i [binary format H* 0000000000000000]
+set p [binary format H* 0123456789ABCDEF0123456789ABCDEF]]
+
+set k [binary format H* FEDCBA9876543210]
+set c [binary format H* ED39D950FA74BCC4ED39D950FA74BCC4]
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+bench -desc "DES 1des ECB encryption" -body {
+ DES::des -mode ecb -dir enc -key $k -iv $i $p
+}
+
+bench -desc "DES 1des ECB decryption" -body {
+ DES::des -mode ecb -dir dec -key $k -iv $i $c
+}
+
+bench -desc "DES 1des ECB encryption core" -pre {
+ set key [DES::Init ecb $k $i]
+} -body {
+ DES::Encrypt $key $p
+} -post {
+ DES::Final $key
+}
+
+bench -desc "DES 1des ECB decryption core" -pre {
+ set key [DES::Init ecb $k $i]
+} -body {
+ DES::Decrypt $key $c
+} -post {
+ DES::Final $key
+}
+
+bench -desc "DES 1des ECB keyschedule" -body {
+ DES::Final [DES::Init ecb $k $i]
+}
+
+bench -desc "DES 1des CBC keyschedule" -body {
+ DES::Final [DES::Init cbc $k $i]
+}
+
+if {[llength [package provide tclDES]] != 0} {
+ set k [binary format H* FEDCBA9876543210FEDCBA9876543210FEDCBA9876543210]
+
+ bench -desc "DES 3des ECB encryption" -body {
+ DES::des -mode ecb -dir enc -key $k -iv $i $p
+ }
+
+ bench -desc "DES 3des ECB decryption" -body {
+ DES::des -mode ecb -dir dec -key $k -iv $i $c
+ }
+
+ bench -desc "DES 3des ECB encryption core" -pre {
+ set key [DES::Init ecb $k $i]
+ } -body {
+ DES::Encrypt $key $p
+ } -post {
+ DES::Final $key
+ }
+
+ bench -desc "DES 3des ECB decryption core" -pre {
+ set key [DES::Init ecb $k $i]
+ } -body {
+ DES::Decrypt $key $c
+ } -post {
+ DES::Final $key
+ }
+
+ bench -desc "DES 3des ECB keyschedule" -body {
+ DES::Final [DES::Init ecb $k $i]
+ }
+
+ bench -desc "DES 3des CBC keyschedule" -body {
+ DES::Final [DES::Init cbc $k $i]
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/des/des.man b/tcllib/modules/des/des.man
new file mode 100644
index 0000000..60b4c19
--- /dev/null
+++ b/tcllib/modules/des/des.man
@@ -0,0 +1,206 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin des n 1.1]
+[see_also aes(n)]
+[see_also blowfish(n)]
+[see_also md5(n)]
+[see_also rc4(n)]
+[see_also sha1(n)]
+[keywords 3DES]
+[keywords {block cipher}]
+[keywords {data integrity}]
+[keywords DES]
+[keywords encryption]
+[keywords security]
+[copyright {2005, Pat Thoyts <patthoyts@users.sourceforge.net>}]
+[moddesc {Data Encryption Standard (DES)}]
+[titledesc {Implementation of the DES and triple-DES ciphers}]
+[category {Hashes, checksums, and encryption}]
+[require Tcl 8.2]
+[require des 1.1]
+[description]
+[para]
+
+This is an implementation in Tcl of the Data Encryption Standard (DES)
+as published by the U.S. National Institute of Standards and
+Technology (NIST) [lb]1[rb]. This implementation also supports triple
+DES (3DES) extension to DES. DES is a 64-bit block cipher that uses a
+56-bit key. 3DES uses a 168-bit key. DES has now officially been
+superceeded by AES but is in common use in many protocols.
+
+[para]
+
+The tcllib implementation of DES and 3DES uses an implementation by
+Mac Cody and is available as a separate download from [lb]2[rb]. For
+anyone concerned about the details of exporting this code please see
+the TclDES web pages. The tcllib specific code is a wrapper to the
+TclDES API that presents same API for the DES cipher as for other
+ciphers in the library.
+
+[section "COMMANDS"]
+
+[list_begin definitions]
+[call [cmd "::DES::des"] \
+ [opt [arg "-mode [lb]ecb|cbc|cfb|ofb[rb]"]] \
+ [opt [arg "-dir [lb]encrypt|decrypt[rb]"]] \
+ [arg "-key keydata"] \
+ [opt [arg "-iv vector"]] \
+ [opt [arg "-hex"]] \
+ [opt [arg "-weak"]] \
+ [opt [arg "-out channel"]] \
+ [opt [arg "-chunksize size"]] \
+ [lb] [arg "-in channel"] | \
+ [arg "data"] [rb]]
+
+Perform the [package DES] algorithm on either the data provided
+by the argument or on the data read from the [arg "-in"] channel. If
+an [arg "-out"] channel is given then the result will be written to
+this channel.
+
+[para]
+
+The [arg -key] option must be given. This parameter takes a binary
+string of 8 bytes in length and is used to generate the key schedule.
+In DES only 56 bits of key data are used. The highest bit from each
+byte is discarded.
+
+[para]
+
+The [arg -mode] and [arg -dir] options are optional and default to cbc
+mode and encrypt respectively. The initialization vector [arg -iv]
+takes an 8 byte binary argument. This defaults to all zeros. See
+[sectref "MODES OF OPERATION"] for more about [arg -mode] and the use
+of the initialization vector.
+
+[para]
+
+DES is a 64-bit block cipher. This means that the data must be
+provided in units that are a multiple of 8 bytes.
+
+[list_end]
+
+[section "PROGRAMMING INTERFACE"]
+
+Internal state is maintained in an opaque structure that is returned
+from the [cmd Init] function. In ECB mode the state is not affected by
+the input but for other modes some input dependent state is maintained
+and may be reset by calling the [cmd Reset] function with a new
+initialization vector value.
+
+[list_begin definitions]
+
+[call [cmd "::DES::Init"] [arg "mode"] [arg "keydata"] [arg "iv"] [opt [arg "weak"]]]
+
+Construct a new DES key schedule using the specified key data and the
+given initialization vector. The initialization vector is not used
+with ECB mode but is important for other usage modes.
+See [sectref "MODES OF OPERATION"].
+
+[para]
+
+There are a small number of keys that are known to be weak when used
+with DES. By default if such a key is passed in then an error will be
+raised. If there is a need to accept such keys then the [arg weak]
+parameter can be set true to avoid the error being thrown.
+
+[call [cmd "::DES::Encrypt"] [arg "Key"] [arg "data"]]
+
+Use a prepared key acquired by calling [cmd Init] to encrypt the
+provided data. The data argument should be a binary array that is a
+multiple of the DES block size of 8 bytes. The result is a binary
+array the same size as the input of encrypted data.
+
+[call [cmd "::DES::Decrypt"] [arg "Key"] [arg "data"]]
+
+Decipher data using the key. Note that the same key may be used to
+encrypt and decrypt data provided that the initialization vector is
+reset appropriately for CBC mode.
+
+[call [cmd "::DES::Reset"] [arg "Key"] [arg "iv"]]
+
+Reset the initialization vector. This permits the programmer to re-use
+a key and avoid the cost of re-generating the key schedule where the
+same key data is being used multiple times.
+
+[call [cmd "::DES::Final"] [arg "Key"]]
+
+This should be called to clean up resources associated with [arg Key].
+Once this function has been called the key may not be used again.
+
+[list_end]
+
+[section "MODES OF OPERATION"]
+
+[list_begin definitions]
+[def "Electronic Code Book (ECB)"]
+ECB is the basic mode of all block ciphers. Each block is encrypted
+independently and so identical plain text will produce identical
+output when encrypted with the same key. Any encryption errors will
+only affect a single block however this is vulnerable to known
+plaintext attacks.
+
+[def "Cipher Block Chaining (CBC)"]
+
+CBC mode uses the output of the last block encryption to affect the
+current block. An initialization vector of the same size as the cipher
+block size is used to handle the first block. The initialization
+vector should be chosen randomly and transmitted as the first block of
+the output. Errors in encryption affect the current block and the next
+block after which the cipher will correct itself. CBC is the most
+commonly used mode in software encryption.
+
+[def "Cipher Feedback (CFB)"]
+
+CFB mode can be used to convert block ciphers into stream ciphers. In
+CFB mode the initialization vector is encrypted and the output is then
+xor'd with the plaintext stream. The result is then used as the
+initialization vector for the next round. Errors will affect the
+current block and the next block.
+
+[def "Output Feedback (OFB)"]
+OFB is similar to CFB except that the output of the cipher is fed back
+into the next round and not the xor'd plain text. This means that
+errors only affect a single block but the cipher is more vulnerable to
+attack.
+
+[list_end]
+
+[section EXAMPLES]
+
+[example {
+% set ciphertext [DES::des -mode cbc -dir encrypt -key $secret $plaintext]
+% set plaintext [DES::des -mode cbc -dir decrypt -key $secret $ciphertext]
+}]
+
+[example {
+set iv [string repeat \\0 8]
+set Key [DES::Init cbc \\0\\1\\2\\3\\4\\5\\6\\7 $iv]
+set ciphertext [DES::Encrypt $Key "somedata"]
+append ciphertext [DES::Encrypt $Key "moredata"]
+DES::Reset $Key $iv
+set plaintext [DES::Decrypt $Key $ciphertext]
+DES::Final $Key
+}]
+
+[section "REFERENCES"]
+
+[list_begin enumerated]
+
+[enum]
+ "Data Encryption Standard",
+ Federal Information Processing Standards Publication 46-3, 1999,
+ ([uri http://csrc.nist.gov/publications/fips/fips46-3/fips46-3.pdf])
+
+[enum]
+ "TclDES: munitions-grade Tcl scripting"
+ [uri http://tcldes.sourceforge.net/]
+
+[list_end]
+
+[section "AUTHORS"]
+Jochen C Loewer,
+Mac Cody,
+Pat Thoyts
+
+[vset CATEGORY des]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/des/des.tcl b/tcllib/modules/des/des.tcl
new file mode 100644
index 0000000..a2d0bd3
--- /dev/null
+++ b/tcllib/modules/des/des.tcl
@@ -0,0 +1,272 @@
+# des.tcl - Copyright (C) 2005 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Tcllib wrapper for the DES package. This wrapper provides the same
+# programming API that tcllib uses for AES and Blowfish. We require a
+# DES implementation and use either TclDES or TclDESjr to get DES
+# and/or 3DES
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.2
+
+if {[catch {package require tclDES 1.0.0}]} {
+ package require tclDESjr 1.0.0
+}
+
+namespace eval DES {
+ variable uid
+ if {![info exists uid]} { set uid 0 }
+}
+
+proc ::DES::Init {mode key iv {weak 0}} {
+ variable uid
+ set Key [namespace current]::[incr uid]
+ upvar #0 $Key state
+ if {[string length $key] % 8 != 0} {
+ return -code error "invalid key length of\
+ [expr {[string length $key] * 8}] bits:\
+ DES requires 64 bit keys (56 bits plus parity bits)"
+ }
+ array set state [list M $mode I $iv K [des::keyset create $key $weak]]
+ return $Key
+}
+
+proc ::DES::Encrypt {Key data} {
+ upvar #0 $Key state
+ set iv $state(I)
+ set r [des::encrypt $state(K) $data $state(M) iv]
+ set state(I) $iv
+ return $r
+}
+
+proc ::DES::Decrypt {Key data} {
+ upvar #0 $Key state
+ set iv $state(I)
+ set r [des::decrypt $state(K) $data $state(M) iv]
+ set state(I) $iv
+ return $r
+}
+
+proc ::DES::Reset {Key iv} {
+ upvar #0 $Key state
+ set state(I) $iv
+ return
+}
+
+proc ::DES::Final {Key} {
+ upvar #0 $Key state
+ des::keyset destroy $state(K)
+ # FRINK: nocheck
+ unset $Key
+}
+# -------------------------------------------------------------------------
+
+# Backwards compatability - here we re-implement the DES 0.8 procs using the
+# current implementation.
+#
+# -- DO NOT USE THESE FUNCTIONS IN NEW CODE--
+#
+proc ::DES::GetKey {mode keydata keyvarname} {
+ set weak 1
+ switch -exact -- $mode {
+ -encrypt { set dir encrypt ; set vnc 0 }
+ -encryptVNC { set dir encrypt ; set vnc 1 }
+ -decrypt { set dir decrypt ; set vnc 0 }
+ -decryptVNC { set dir decrypt ; set vnc 1 }
+ default {
+ return -code error "invalid mode \"$mode\":\
+ must be one of -encrypt, -decrypt, -encryptVNC or -decryptVNC"
+ }
+ }
+ if {$vnc} { set keydata [ReverseBytes $keydata] }
+ upvar $keyvarname Key
+ set Key [Init ecb $keydata [string repeat \0 8] $weak]
+ upvar $Key state
+ array set state [list dir $dir]
+ return
+}
+
+proc ::DES::DesBlock {data keyvarname} {
+ upvar $keyvarname Key
+ upvar #0 $Key state
+ if {[string equal $state(dir) "encrypt"]} {
+ set r [Encrypt $Key $data]
+ } else {
+ set r [Decrypt $Key $data]
+ }
+ return $r
+}
+
+proc ::DES::ReverseBytes {data} {
+ binary scan $data b* bin
+ return [binary format B* $bin]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::DES::SetOneOf {lst item} {
+ set ndx [lsearch -glob $lst "${item}*"]
+ if {$ndx == -1} {
+ set err [join $lst ", "]
+ return -code error "invalid mode \"$item\": must be one of $err"
+ }
+ return [lindex $lst $ndx]
+}
+
+proc ::DES::CheckSize {what size thing} {
+ if {[string length $thing] != $size} {
+ return -code error "invalid value for $what: must be $size bytes long"
+ }
+ return $thing
+}
+
+proc ::DES::Pad {data blocksize {fill \0}} {
+ set len [string length $data]
+ if {$len == 0} {
+ set data [string repeat $fill $blocksize]
+ } elseif {($len % $blocksize) != 0} {
+ set pad [expr {$blocksize - ($len % $blocksize)}]
+ append data [string repeat $fill $pad]
+ }
+ return $data
+}
+
+proc ::DES::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+proc ::DES::Hex {data} {
+ binary scan $data H* r
+ return $r
+}
+
+proc ::DES::des {args} {
+ array set opts {
+ -dir encrypt -mode cbc -key {} -in {} -out {} -chunksize 4096 -hex 0 -weak 0 old 0
+ }
+ set blocksize 8
+ set opts(-iv) [string repeat \0 $blocksize]
+ set modes {ecb cbc cfb ofb}
+ set dirs {encrypt decrypt}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -exact -- $option {
+ -mode {
+ set M [Pop args 1]
+ if {[catch {set mode [SetOneOf $modes $M]} err]} {
+ if {[catch {SetOneOf {encode decode} $M}]} {
+ return -code error $err
+ } else {
+ # someone is using the old interface, therefore ecb
+ set mode ecb
+ set opts(-weak) 1
+ set opts(old) 1
+ set opts(-dir) [expr {[string match en* $M] ? "encrypt" : "decrypt"}]
+ }
+ }
+ set opts(-mode) $mode
+ }
+ -dir { set opts(-dir) [SetOneOf $dirs [Pop args 1]] }
+ -iv { set opts(-iv) [Pop args 1] }
+ -key { set opts(-key) [Pop args 1] }
+ -in { set opts(-in) [Pop args 1] }
+ -out { set opts(-out) [Pop args 1] }
+ -chunksize { set opts(-chunksize) [Pop args 1] }
+ -hex { set opts(-hex) 1 }
+ -weak { set opts(-weak) 1 }
+ -- { Pop args ; break }
+ default {
+ set err [join [lsort [array names opts -*]] ", "]
+ return -code error "bad option \"$option\":\
+ must be one of $err"
+ }
+ }
+ Pop args
+ }
+
+ if {$opts(-key) == {}} {
+ return -code error "no key provided: the -key option is required"
+ }
+
+ # pad the key if backwards compat required
+ if {$opts(old)} {
+ set pad [expr {8 - ([string length $opts(-key)] % 8)}]
+ if {$pad != 8} {
+ append opts(-key) [string repeat \0 $pad]
+ }
+ }
+
+ set r {}
+ if {$opts(-in) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong \# args:\
+ should be \"des ?options...? -key keydata plaintext\""
+ }
+
+ set data [Pad [lindex $args 0] $blocksize]
+ set Key [Init $opts(-mode) $opts(-key) $opts(-iv) $opts(-weak)]
+ if {[string equal $opts(-dir) "encrypt"]} {
+ set r [Encrypt $Key $data]
+ } else {
+ set r [Decrypt $Key $data]
+ }
+
+ if {$opts(-out) != {}} {
+ puts -nonewline $opts(-out) $r
+ set r {}
+ }
+ Final $Key
+
+ } else {
+
+ if {[llength $args] != 0} {
+ return -code error "wrong \# args:\
+ should be \"des ?options...? -key keydata -in channel\""
+ }
+
+ set Key [Init $opts(-mode) $opts(-key) $opts(-iv) $opts(-weak)]
+ upvar $Key state
+ set state(reading) 1
+ if {[string equal $opts(-dir) "encrypt"]} {
+ set state(cmd) Encrypt
+ } else {
+ set state(cmd) Decrypt
+ }
+ set state(output) ""
+ fileevent $opts(-in) readable \
+ [list [namespace origin Chunk] \
+ $Key $opts(-in) $opts(-out) $opts(-chunksize)]
+ if {[info commands ::tkwait] != {}} {
+ tkwait variable [subst $Key](reading)
+ } else {
+ vwait [subst $Key](reading)
+ }
+ if {$opts(-out) == {}} {
+ set r $state(output)
+ }
+ Final $Key
+
+ }
+
+ if {$opts(-hex)} {
+ set r [Hex $r]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+package provide des 1.1.0
+
+# -------------------------------------------------------------------------
+#
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/des/des.test b/tcllib/modules/des/des.test
new file mode 100644
index 0000000..a34f984
--- /dev/null
+++ b/tcllib/modules/des/des.test
@@ -0,0 +1,408 @@
+# -*- tcl -*-
+# Commands covered: DES (Data Encryption Standard)
+#
+# This file contains a collection of tests for one or more of the commands
+# the BLOB-X extension. Sourcing this file into Tcl runs the
+# tests and generates output for errors. No output means no errors were
+# found.
+#
+# Original Copyright (c) 1996 Andreas Kupries (a.kupries@westend.com)
+# Modifications Copyright (c) 2003 Patrick Thoyts <patthoyts@users.sf.net>
+#
+# Modified from TrfCrypt tests
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# $Id: des.test,v 1.7 2007/07/05 13:19:20 patthoyts Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ # Base implementation first, then the package for the public API
+ useLocal [expr {
+ [tcltest::testConstraint no3des] ?
+ "tcldesjr.tcl" :
+ "tcldes.tcl"}] tclDES ::des
+ useLocal des.tcl des ::DES
+}
+
+# -------------------------------------------------------------------------
+
+if {[llength [package provide tclDES]] != 0} {
+ puts "> pure Tcl : TclDES [package provide tclDES]"
+} elseif {[llength [package provide tclDESjr]] != 0} {
+ puts "> pure Tcl : TclDESjr [package provide tclDESjr]"
+} else {
+ puts "> unknown base implementation!"
+}
+
+# -------------------------------------------------------------------------
+# Setup any constraints
+#
+
+tcltest::testConstraint 3des \
+ [llength [package provide tclDES]]
+
+# -------------------------------------------------------------------------
+
+# These are the NBS test vectors for the S-box tests
+# See http://csrc.nist.gov/publications/nistpubs/800-20/800-20.pdf Table A.4
+#
+set vectors {
+ 1 weak 0000000000000000 0000000000000000 8CA64DE9C1B123A7
+ 2 weak FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF 7359B2163E4EDC58
+ 3 ok 3000000000000000 1000000000000001 958E6E627A05557B
+ 4 ok 1111111111111111 1111111111111111 F40379AB9E0EC533
+ 5 ok 0123456789ABCDEF 1111111111111111 17668DFC7292532D
+ 6 ok 1111111111111111 0123456789ABCDEF 8A5AE1F81AB8F2DD
+ 7 weak 0000000000000000 0000000000000000 8CA64DE9C1B123A7
+ 8 ok FEDCBA9876543210 0123456789ABCDEF ED39D950FA74BCC4
+ 9 ok 7CA110454A1A6E57 01A1D6D039776742 690F5B0D9A26939B
+ 10 ok 0131D9619DC1376E 5CD54CA83DEF57DA 7A389D10354BD271
+ 11 ok 07A1133E4A0B2686 0248D43806F67172 868EBB51CAB4599A
+ 12 ok 3849674C2602319E 51454B582DDF440A 7178876E01F19B2A
+ 13 ok 04B915BA43FEB5B6 42FD443059577FA2 AF37FB421F8C4095
+ 14 ok 0113B970FD34F2CE 059B5E0851CF143A 86A560F10EC6D85B
+ 15 ok 0170F175468FB5E6 0756D8E0774761D2 0CD3DA020021DC09
+ 16 ok 43297FAD38E373FE 762514B829BF486A EA676B2CB7DB2B7A
+ 17 ok 07A7137045DA2A16 3BDD119049372802 DFD64A815CAF1A0F
+ 18 ok 04689104C2FD3B2F 26955F6835AF609A 5C513C9C4886C088
+ 19 ok 37D06BB516CB7546 164D5E404F275232 0A2AEEAE3FF4AB77
+ 20 ok 1F08260D1AC2465E 6B056E18759F5CCA EF1BF03E5DFA575A
+ 21 ok 584023641ABA6176 004BD6EF09176062 88BF0DB6D70DEE56
+ 22 ok 025816164629B007 480D39006EE762F2 A1F9915541020B56
+ 23 ok 49793EBC79B3258F 437540C8698F3CFA 6FBF1CAFCFFD0556
+ 24 ok 4FB05E1515AB73A7 072D43A077075292 2F22E49BAB7CA1AC
+ 25 ok 49E95D6D4CA229BF 02FE55778117F12A 5A6B612CC26CCE4A
+ 26 ok 018310DC409B26D6 1D9D5C5018F728C2 5F4C038ED12B2E41
+ 27 ok 1C587F1C13924FEF 305532286D6F295A 63FAC0D034D9F793
+ 28 weak 0101010101010101 0123456789ABCDEF 617B3A0CE8F07100
+ 29 weak 1F1F1F1F0E0E0E0E 0123456789ABCDEF DB958605F8C8C606
+ 30 ok E0FEE0FEF1FEF1FE 0123456789ABCDEF EDBFD1C66C29CCC7
+ 31 weak 0000000000000000 FFFFFFFFFFFFFFFF 355550B2150E2451
+ 32 weak FFFFFFFFFFFFFFFF 0000000000000000 CAAAAF4DEAF1DBAE
+ 33 ok 0123456789ABCDEF 0000000000000000 D5D44FF720683D0D
+ 34 ok FEDCBA9876543210 FFFFFFFFFFFFFFFF 2A2BB008DF97C2F2
+}
+
+foreach {N W K I O} $vectors {
+ if {[string equal $W "weak"]} {
+ if {[llength [package provide tclDES]] != 0} {
+ set Re {1 {Key 1 is weak!}}
+ set Rd {1 {Key 1 is weak!}}
+ } else {
+ set Re {1 {The key is weak!}}
+ set Rd {1 {The key is weak!}}
+ }
+ set Ro [list 0 $O]
+ } else {
+ set Re [list 0 $O]
+ set Rd [list 0 $I]
+ set Ro [list 0 $O]
+ }
+
+ test des-1.${N}-enc {des-ecb encryption} {
+ list [catch {
+ set k [binary format H* $K]
+ set p [binary format H* $I]
+ set s [DES::des -dir encrypt -mode ecb -key $k $p]
+ binary scan $s H* h
+ string toupper $h
+ } res] $res
+ } $Re
+
+ test des-1.${N}-dec {des-ecb decryption} {
+ list [catch {
+ set k [binary format H* $K]
+ set p [binary format H* $O]
+ set s [DES::des -dir decrypt -mode ecb -key $k $p]
+ binary scan $s H* h
+ string toupper $h
+ } res] $res
+ } $Rd
+
+ test des-1.${N}-old {backwards compat check (encryption)} {
+ list [catch {
+ set s [DES::des -mode encode -key [binary format H* $K] [binary format H* $I]]
+ binary scan $s H* h; string toupper $h
+ } res] $res
+ } $Ro
+}
+
+# DESTEST - see http://theory.lcs.mit.edu/~rivest/destest.txt
+test des-2.0 {destest} {
+ list [catch {
+ set X [binary format H* 9474B8E8C73BCA7D]
+ for {set n 0} {$n < 16} {incr n} {
+ set x [lindex $X $n]
+ if {$n & 1} {
+ lappend X [DES::des -mode ecb -dir decrypt -key $x $x]
+ } else {
+ lappend X [DES::des -mode ecb -dir encrypt -key $x $x]
+ }
+ }
+ DES::Hex [lindex $X end]
+ } res] $res
+} [list 0 1b1a2ddb4c642438]
+
+set vectors {
+0 8000000000000000 95F8A5E5DD31D900
+1 4000000000000000 DD7F121CA5015619
+2 2000000000000000 2E8653104F3834EA
+3 1000000000000000 4BD388FF6CD81D4F
+4 0800000000000000 20B9E767B2FB1456
+5 0400000000000000 55579380D77138EF
+6 0200000000000000 6CC5DEFAAF04512F
+7 0100000000000000 0D9F279BA5D87260
+8 0080000000000000 D9031B0271BD5A0A
+9 0040000000000000 424250B37C3DD951
+10 0020000000000000 B8061B7ECD9A21E5
+11 0010000000000000 F15D0F286B65BD28
+12 0008000000000000 ADD0CC8D6E5DEBA1
+13 0004000000000000 E6D5F82752AD63D1
+14 0002000000000000 ECBFE3BD3F591A5E
+15 0001000000000000 F356834379D165CD
+16 0000800000000000 2B9F982F20037FA9
+17 0000400000000000 889DE068A16F0BE6
+18 0000200000000000 E19E275D846A1298
+19 0000100000000000 329A8ED523D71AEC
+20 0000080000000000 E7FCE22557D23C97
+21 0000040000000000 12A9F5817FF2D65D
+22 0000020000000000 A484C3AD38DC9C19
+23 0000010000000000 FBE00A8A1EF8AD72
+24 0000008000000000 750D079407521363
+25 0000004000000000 64FEED9C724C2FAF
+26 0000002000000000 F02B263B328E2B60
+27 0000001000000000 9D64555A9A10B852
+28 0000000800000000 D106FF0BED5255D7
+29 0000000400000000 E1652C6B138C64A5
+30 0000000200000000 E428581186EC8F46
+31 0000000100000000 AEB5F5EDE22D1A36
+32 0000000080000000 E943D7568AEC0C5C
+33 0000000040000000 DF98C8276F54B04B
+34 0000000020000000 B160E4680F6C696F
+35 0000000010000000 FA0752B07D9C4AB8
+36 0000000008000000 CA3A2B036DBC8502
+37 0000000004000000 5E0905517BB59BCF
+38 0000000002000000 814EEB3B91D90726
+39 0000000001000000 4D49DB1532919C9F
+40 0000000000800000 25EB5FC3F8CF0621
+41 0000000000400000 AB6A20C0620D1C6F
+42 0000000000200000 79E90DBC98F92CCA
+43 0000000000100000 866ECEDD8072BB0E
+44 0000000000080000 8B54536F2F3E64A8
+45 0000000000040000 EA51D3975595B86B
+46 0000000000020000 CAFFC6AC4542DE31
+47 0000000000010000 8DD45A2DDF90796C
+48 0000000000008000 1029D55E880EC2D0
+49 0000000000004000 5D86CB23639DBEA9
+50 0000000000002000 1D1CA853AE7C0C5F
+51 0000000000001000 CE332329248F3228
+52 0000000000000800 8405D1ABE24FB942
+53 0000000000000400 E643D78090CA4207
+54 0000000000000200 48221B9937748A23
+55 0000000000000100 DD7C0BBD61FAFD54
+56 0000000000000080 2FBC291A570DB5C4
+57 0000000000000040 E07C30D7E4E26E12
+58 0000000000000020 0953E2258E8E90A1
+59 0000000000000010 5B711BC4CEEBF2EE
+60 0000000000000008 CC083F1E6D9E85F6
+61 0000000000000004 D2FD8867D50D2DFE
+62 0000000000000002 06E7EA22CE92708F
+63 0000000000000001 166B40B44ABA4BD6
+}
+
+foreach {N I O} $vectors {
+ test des-3.${N}-e {FIPS 800-20 Table A.1} {
+ list [catch {
+ set k [binary format H* 0101010101010101]
+ set i [binary format H* $I]
+ string toupper [DES::des -hex -weak -mode ecb -dir encrypt -key $k $i]
+ } res] $res
+ } [list 0 $O]
+ test des-3.${N}-d {FIPS 800-20 Table A.1} {
+ list [catch {
+ set k [binary format H* 0101010101010101]
+ set o [binary format H* $O]
+ string toupper [DES::des -hex -weak -mode ecb -dir decrypt -key $k $o]
+ } res] $res
+ } [list 0 $I]
+}
+
+# NBS PUB 800 Table A.5
+#ROUND INPUTBLOCK 1 CIPHERTEXT1 INPUTBLOCK 2 CIPHERTEXT2 INPUTBLOCK 3 CIPHERTEXT3
+set vectors {
+0 8000000000000000 95f8a5e5dd31d900 d555555555555555 f7552ab6cb21e2bc 2aaaaaaaaaaaaaaa 5a48d3de869557fd
+1 4000000000000000 dd7f121ca5015619 1555555555555555 e0c2af1ebd89a262 eaaaaaaaaaaaaaaa f15ee2019a5b547c
+2 2000000000000000 2e8653104f3834ea 7555555555555555 05b865a1e49ed109 8aaaaaaaaaaaaaaa 3bee595ef860316a
+3 1000000000000000 4bd388ff6cd81d4f 4555555555555555 b447313fc704d321 baaaaaaaaaaaaaaa f6089ca9b722765c
+4 0800000000000000 20b9e767b2fb1456 5d55555555555555 c39193d42381b313 a2aaaaaaaaaaaaaa af15a8e9b2c14de5
+5 0400000000000000 55579380d77138ef 5155555555555555 6a2afdae188494b8 aeaaaaaaaaaaaaaa 45089186180bd591
+6 0200000000000000 6cc5defaaf04512f 5755555555555555 1359f4d663a3209c a8aaaaaaaaaaaaaa 280d3ae3a00cfbc9
+7 0100000000000000 0d9f279ba5d87260 5455555555555555 4a035e6a81d1314b abaaaaaaaaaaaaaa d27eb94e56c3172a
+8 0080000000000000 d9031b0271bd5a0a 55d5555555555555 4334b5fe1b7f5320 aa2aaaaaaaaaaaaa b0555ab990b7e95c
+9 0040000000000000 424250b37c3dd951 5515555555555555 f41a29e0d31107b4 aaeaaaaaaaaaaaaa f54f2bd8e2eb2bc6
+10 0020000000000000 b8061b7ecd9a21e5 5575555555555555 c8eb2e340855325b aa8aaaaaaaaaaaaa d51175259c607fb4
+11 0010000000000000 f15d0f286b65bd28 5545555555555555 b75847a2f3f2458a aabaaaaaaaaaaaaa 72ea3aadb569af43
+12 0008000000000000 add0cc8d6e5deba1 555d555555555555 be433af4c5ae0f97 aaa2aaaaaaaaaaaa 9b003151e8602b7d
+13 0004000000000000 e6d5f82752ad63d1 5551555555555555 f68101d125e2e284 aaaeaaaaaaaaaaaa fc1463bb9bba9e11
+14 0002000000000000 ecbfe3bd3f591a5e 5557555555555555 fa510732fa871094 aaa8aaaaaaaaaaaa 65f94c59c59b06e1
+15 0001000000000000 f356834379d165cd 5554555555555555 458d97a8b6ebd0d7 aaabaaaaaaaaaaaa fbcfc086f8111572
+16 0000800000000000 2b9f982f20037fa9 5555d55555555555 f4169ca3fc6799ed aaaa2aaaaaaaaaaa 68c9e70b9de8db79
+17 0000400000000000 889de068a16f0be6 5555155555555555 f47b9f01a5ee74e9 aaaaeaaaaaaaaaaa 63fc8ec1421399b8
+18 0000200000000000 e19e275d846a1298 5555755555555555 ee26a403caca387d aaaa8aaaaaaaaaaa 3f1d10e9a1a44a92
+19 0000100000000000 329a8ed523d71aec 5555455555555555 af7e5ad1d9f4ecf8 aaaabaaaaaaaaaaa e3f663de44003f9b
+20 0000080000000000 e7fce22557d23c97 55555d5555555555 bb04e854f99f6352 aaaaa2aaaaaaaaaa bc2452fd13e00dcc
+21 0000040000000000 12a9f5817ff2d65d 5555515555555555 01f57b1e69290d90 aaaaaeaaaaaaaaaa 4432a11e1c320e7a
+22 0000020000000000 a484c3ad38dc9c19 5555575555555555 8ae9dee849b46527 aaaaa8aaaaaaaaaa a1e9e67f13f932b3
+23 0000010000000000 fbe00a8a1ef8ad72 5555545555555555 cb706efba6b5110e aaaaabaaaaaaaaaa 6fd1d0793c1b7af2
+24 0000008000000000 750d079407521363 555555d555555555 b8b27d1286bdbb26 aaaaaa2aaaaaaaaa 3d2c39f9d26b589e
+25 0000004000000000 64feed9c724c2faf 5555551555555555 9862c9d770558095 aaaaaaeaaaaaaaaa e3a7abc88132ad7d
+26 0000002000000000 f02b263b328e2b60 5555557555555555 a213c5c56fdca139 aaaaaa8aaaaaaaaa 08cd945738a222c8
+27 0000001000000000 9d64555a9a10b852 5555554555555555 a3bebc0e23ab87f2 aaaaaabaaaaaaaaa 568fa34d2fc7225e
+28 0000000800000000 d106ff0bed5255d7 5555555d55555555 c32c19229d84e2b4 aaaaaaa2aaaaaaaa 3771887d7266b49d
+29 0000000400000000 e1652c6b138c64a5 5555555155555555 e628ceae5cb3bb34 aaaaaaaeaaaaaaaa edd6029a6b80a442
+30 0000000200000000 e428581186ec8f46 5555555755555555 5924454953ad5732 aaaaaaa8aaaaaaaa 0313da097aec4a43
+31 0000000100000000 aeb5f5ede22d1a36 5555555455555555 7cc987f5fb33b813 aaaaaaabaaaaaaaa 91f5b30f015b4a54
+32 0000000080000000 e943d7568aec0c5c 55555555d5555555 88e3dd1448c4e0ff aaaaaaaa2aaaaaaa 1e60759f038beec1
+33 0000000040000000 df98c8276f54b04b 5555555515555555 a49d286e5dfc6143 aaaaaaaaeaaaaaaa 97061699383bbfe0
+34 0000000020000000 b160e4680f6c696f 5555555575555555 a5206a311e9c2515 aaaaaaaa8aaaaaaa 311f3c96e071f173
+35 0000000010000000 fa0752b07d9c4ab8 5555555545555555 b6e4686a8b957cf2 aaaaaaaabaaaaaaa 1a6849edcb701b07
+36 0000000008000000 ca3a2b036dbc8502 555555555d555555 af1200418fd37fdd aaaaaaaaa2aaaaaa fa5b2fa26d03558b
+37 0000000004000000 5e0905517bb59bcf 5555555551555555 487deccf0fde5b88 aaaaaaaaaeaaaaaa bcaa0b7b7b3464c5
+38 0000000002000000 814eeb3b91d90726 5555555557555555 456a1865905ed57d aaaaaaaaa8aaaaaa 3d245b501c6abb74
+39 0000000001000000 4d49db1532919c9f 5555555554555555 3e2601fa20895e62 aaaaaaaaabaaaaaa 62133d9330e2e86b
+40 0000000000800000 25eb5fc3f8cf0621 5555555555d55555 58da89972266a7e3 aaaaaaaaaa2aaaaa 5d7d6bd225890b4d
+41 0000000000400000 ab6a20c0620d1c6f 5555555555155555 feaca17e5dd05c87 aaaaaaaaaaeaaaaa db36baba70c3b9af
+42 0000000000200000 79e90dbc98f92cca 5555555555755555 88249b73e99c5ac0 aaaaaaaaaa8aaaaa a2f5ea90c2179ab4
+43 0000000000100000 866ecedd8072bb0e 5555555555455555 5f8add8784cc3174 aaaaaaaaaabaaaaa 70470a07cb34e109
+44 0000000000080000 8b54536f2f3e64a8 55555555555d5555 cd8dc942ae2bb175 aaaaaaaaaaa2aaaa 659610094ab3824e
+45 0000000000040000 ea51d3975595b86b 5555555555515555 cf8442863e68e644 aaaaaaaaaaaeaaaa 26e6223634c857a3
+46 0000000000020000 caffc6ac4542de31 5555555555575555 16952dc89c0acd65 aaaaaaaaaaa8aaaa ddd0a647be96041f
+47 0000000000010000 8dd45a2ddf90796c 5555555555545555 8a4fca2b00c49807 aaaaaaaaaaabaaaa 363219d8cec5a9f3
+48 0000000000008000 1029d55e880ec2d0 555555555555d555 b40225aea121c8d3 aaaaaaaaaaaa2aaa bb5710f9dc8dde46
+49 0000000000004000 5d86cb23639dbea9 5555555555551555 711c066c13222f1c aaaaaaaaaaaaeaaa ae527ed311a25ea2
+50 0000000000002000 1d1ca853ae7c0c5f 5555555555557555 4fb69c832db68026 aaaaaaaaaaaa8aaa af94496800a32656
+51 0000000000001000 ce332329248f3228 5555555555554555 f24c7444edf1c394 aaaaaaaaaaaabaaa c55d7544a1eae274
+52 0000000000000800 8405d1abe24fb942 5555555555555d55 6be457abc511e87c aaaaaaaaaaaaa2aa 9ba49db251748896
+53 0000000000000400 e643d78090ca4207 5555555555555155 6136fefebb0c8118 aaaaaaaaaaaaaeaa 3d19267de9c12e7b
+54 0000000000000200 48221b9937748a23 5555555555555755 d23a8dfe39c98883 aaaaaaaaaaaaa8aa 5ce84637532650c8
+55 0000000000000100 dd7c0bbd61fafd54 5555555555555455 afe2e34f009924e2 aaaaaaaaaaaaabaa d43941ab72932bb0
+56 0000000000000080 2fbc291a570db5c4 55555555555555d5 0adcf552ec1754c6 aaaaaaaaaaaaaa2a 816c454ba7894865
+57 0000000000000040 e07c30d7e4e26e12 5555555555555515 c06e80c5238135bb aaaaaaaaaaaaaaea 74bc744f10f63889
+58 0000000000000020 0953e2258e8e90a1 5555555555555575 0912754e7c42f637 aaaaaaaaaaaaaa8a 3d2565d9bf62cdbd
+59 0000000000000010 5b711bc4ceebf2ee 5555555555555545 b4f82967c658adb8 aaaaaaaaaaaaaaba a2e13c5701a60444
+60 0000000000000008 cc083f1e6d9e85f6 555555555555555d 006fa12a796ac4d3 aaaaaaaaaaaaaaa2 cbe2873fd6f63048
+61 0000000000000004 d2fd8867d50d2dfe 5555555555555551 1a4a364616460d44 aaaaaaaaaaaaaaae cc6adcef1be975ef
+62 0000000000000002 06e7ea22ce92708f 5555555555555557 f307b5bcd44f3d8d aaaaaaaaaaaaaaa8 991d770b2bf051dc
+63 0000000000000001 166b40b44aba4bd6 5555555555555554 9cb1c3932c005c49 aaaaaaaaaaaaaaab 17d8e9c374d14494
+}
+
+foreach {N I0 O0 I1 O1 I2 O2} $vectors {
+ test des-4.$N {} {
+ list [catch {
+ set K [string repeat \x01 8]
+ set v0 [string repeat \x00 8] ; set i0 [binary format H* $I0]
+ set v1 [string repeat \x55 8] ; set i1 [binary format H* $I1]
+ set v2 [string repeat \xaa 8] ; set i2 [binary format H* $I2]
+ set r0 [DES::des -weak -mode ecb -dir enc -key $K -iv $v0 $i0]
+ set r1 [DES::des -weak -mode ecb -dir enc -key $K -iv $v1 $i1]
+ set r2 [DES::des -weak -mode ecb -dir enc -key $K -iv $v2 $i2]
+ DES::Hex $r0$r1$r2
+ } res] $res
+ } [list 0 $O0$O1$O2]
+}
+
+# Old VNC support - DES 0.8 supported VNC by using an explicit mode.
+# In fact is is only necessary to revese the key bit order - use
+# ReverseBytes for this.
+#
+set vectors {
+ 0 0000000000000000 0000000000000000 8ca64de9c1b123a7
+ 1 0001020304050607 0000000000000000 77dad0b666306c37
+ 2 0123456789abcdef 0000000000000000 acad343b2a0ac9e0
+ 3 0123456789abcdef 0123456789abcdef 6e09a37726dd560c
+}
+foreach {N K I O} $vectors {
+ test des-5.${N}-e {Check VNC DES support (encrypt)} {
+ catch {unset k}
+ list [catch {
+ DES::GetKey -encryptVNC [binary format H* $K] k
+ set r [DES::DesBlock [binary format H* $I] k]
+ unset k
+ DES::Hex $r
+ } res] $res
+ } [list 0 $O]
+
+ test des-5.${N}-d {Check VNC DES support (decrypt)} {
+ catch {unset k}
+ list [catch {
+ DES::GetKey -decryptVNC [binary format H* $K] k
+ set r [DES::DesBlock [binary format H* $O] k]
+ unset k
+ DES::Hex $r
+ } res] $res
+ } [list 0 $I]
+}
+foreach {N K I O} $vectors {
+ test des-6.${N}-e {Check reverse key} {
+ list [catch {
+ set Key [DES::Init ecb [DES::ReverseBytes [binary format H* $K]] [string repeat \0 8] 1]
+ set r [DES::Encrypt $Key [binary format H* $I]]
+ DES::Final $Key
+ DES::Hex $r
+ } res] $res
+ } [list 0 $O]
+}
+
+
+for {set N 0} {$N < 9} {incr N} {
+ if {$N == 0} {
+ set check [list 1 "invalid message size: the message may not be empty"]
+ } else {
+ set check [list 0 8ca64de9c1b123a7]
+ }
+
+ test des-7.${N} {Check block length} {
+ list [catch {
+ DES::des -hex -weak -mode ecb -dir decrypt \
+ -key [string repeat \0 8] \
+ [string repeat \0 ${N}]
+ } res] $res
+ } [list 0 8ca64de9c1b123a7]
+
+ test des-8.${N} {Check block length} {
+ list [catch {
+ set Key [DES::Init ecb [string repeat \0 8] [string repeat \0 8] 1]
+ set r [DES::Encrypt $Key [string repeat \0 ${N}]]
+ DES::Final $Key
+ DES::Hex $r
+ } res] $res
+ } $check
+}
+
+test des-9.1 {Backwards compatability - key padding} {
+ list [catch {
+ set key [DES::des -mode encode -key secret helloworld01]
+ binary scan $key H* r
+ set r
+ } res] $res
+} {0 7669422b7cce615fe4cae65c4e25eb36}
+
+# -------------------------------------------------------------------------
+
+#catch {unset in out key}
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/des/pkgIndex.tcl b/tcllib/modules/des/pkgIndex.tcl
new file mode 100644
index 0000000..a620cb7
--- /dev/null
+++ b/tcllib/modules/des/pkgIndex.tcl
@@ -0,0 +1,7 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ # PRAGMA: returnok
+ return
+}
+package ifneeded des 1.1.0 [list source [file join $dir des.tcl]]
+package ifneeded tclDES 1.0.0 [list source [file join $dir tcldes.tcl]]
+package ifneeded tclDESjr 1.0.0 [list source [file join $dir tcldesjr.tcl]]
diff --git a/tcllib/modules/des/tcldes.man b/tcllib/modules/des/tcldes.man
new file mode 100644
index 0000000..509cec2
--- /dev/null
+++ b/tcllib/modules/des/tcldes.man
@@ -0,0 +1,25 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin tcldes n 1.1]
+[see_also des(n)]
+[keywords 3DES]
+[keywords {block cipher}]
+[keywords {data integrity}]
+[keywords DES]
+[keywords encryption]
+[keywords security]
+[copyright {2005, Pat Thoyts <patthoyts@users.sourceforge.net>}]
+[moddesc {Data Encryption Standard (DES)}]
+[titledesc {Implementation of the DES and triple-DES ciphers}]
+[category {Hashes, checksums, and encryption}]
+[require Tcl 8.2]
+[require tclDES 1]
+[description]
+[para]
+
+The [package tclDES] package is a helper package for [package des].
+
+[para] Please see the documentation of [package des] for details.
+
+[vset CATEGORY des]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/des/tcldes.tcl b/tcllib/modules/des/tcldes.tcl
new file mode 100644
index 0000000..4b57d5f
--- /dev/null
+++ b/tcllib/modules/des/tcldes.tcl
@@ -0,0 +1,1089 @@
+# des.tcl
+# $Revision: 1.1 $
+# $Date: 2005/09/26 09:16:59 $
+#
+# Port of Javascript implementation to Tcl 8.4 by Mac A. Cody,
+# October, 2002 - February, 2003
+# August, 2003 - Separated key set generation from encryption/decryption.
+# Renamed "des" procedure to "block" to differentiate from the
+# "stream" procedure used for CFB and OFB modes.
+# Modified the "encrypt" and "decrypt" procedures to support
+# CFB and OFB modes. Changed the procedure arguments.
+# Added the "stream" procedure to support CFB and OFB modes.
+# June, 2004 - Corrected input vector bug in stream-mode processing. Added
+# support for feedback vector storage and management function.
+# This enables a stream of data to be processed over several calls
+# to the encryptor or decryptor.
+# September, 2004 - Added feedback vector to the CBC mode of operation to allow
+# a large data set to be processed over several calls to the
+# encryptor or decryptor.
+# October, 2004 - Added test for weak keys in the createKeys procedure.
+#
+# Paul Tero, July 2001
+# http://www.shopable.co.uk/des.html
+#
+# Optimised for performance with large blocks by Michael Hayworth,
+# November 2001, http://www.netdealing.com
+#
+# This software is copyrighted (c) 2003, 2004 by Mac A. Cody. All rights
+# reserved. The following terms apply to all files associated with
+# the software unless explicitly disclaimed in individual files or
+# directories.
+
+# The authors hereby grant permission to use, copy, modify, distribute,
+# and license this software for any purpose, provided that existing
+# copyright notices are retained in all copies and that this notice is
+# included verbatim in any distributions. No written agreement, license,
+# or royalty fee is required for any of the authorized uses.
+# Modifications to this software may be copyrighted by their authors and
+# need not follow the licensing terms described here, provided that the
+# new terms are clearly indicated on the first page of each file where
+# they apply.
+
+# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+# MODIFICATIONS.
+
+# GOVERNMENT USE: If you are acquiring this software on behalf of the
+# U.S. government, the Government shall have only "Restricted Rights"
+# in the software and related documentation as defined in the Federal
+# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
+# are acquiring the software on behalf of the Department of Defense, the
+# software shall be classified as "Commercial Computer Software" and the
+# Government shall have only "Restricted Rights" as defined in Clause
+# 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
+# authors grant the U.S. Government and others acting in its behalf
+# permission to use and distribute the software in accordance with the
+# terms specified in this license.
+namespace eval des {
+ variable keysets
+ variable WeakKeysError
+ if {![info exists WeakKeysError]} { set WeakKeysError 1 }
+ set keysets(ndx) 1
+ # Produre: keyset - Create or destroy a keyset created from a 64-bit
+ # DES key or a 192-bit 3DES key.
+ # Inputs:
+ # oper : The operation to be performed. This will be either "create"
+ # (make a new keyset) or "destroy" (delete an existing keyset).
+ # The meaning of the argument "value" depends of the operation
+ # performed. An error is generated if "oper" is not "create"
+ # or "destroy".
+ #
+ # value : If the argument "oper" is "create", then "value" is the 64-bit
+ # DES key or the 192-bit 3DES key. (Note: The lsb of each byte
+ # is ignored; odd parity is not required). If the argument
+ # "oper" is "destroy", then "value" is a handle to a keyset that
+ # was created previously.
+ #
+ # weak: If true then weak keys are allowed. The default is to raise an
+ # error when a weak key is seen.
+ # Output:
+ # If the argument "oper" is "create", then the output is a handle to the
+ # keyset stored in the des namespace. If the argument "oper" is
+ # "destroy", then nothing is returned.
+ proc keyset {oper value {weak 0}} {
+ variable keysets
+ set newset {}
+ switch -exact -- $oper {
+ create {
+ # Create a new keyset handle.
+ set newset keyset$keysets(ndx)
+ # Create key set
+ set keysets($newset) [createKeys $value $weak]
+ # Never use that keyset handle index again.
+ incr keysets(ndx)
+ }
+ destroy {
+ # Determine if the keyset handle is valid.
+ if {[array names keysets $value] != {}} {
+ # Delete the handle and corresponding keyset.
+ unset keysets($value)
+ } else {
+ error "The keyset handle \"$value\" is invalid!"
+ }
+ }
+ default {
+ error {The operator must be either "create" or "destroy".}
+ }
+ }
+ return $newset
+ }
+
+ # Procedure: encrypt - Encryption front-end for the des procedure
+ # Inputs:
+ # keyset : Handle to an existing keyset.
+ # message : String to be encrypted.
+ # mode : DES mode ecb (default), cbc, cfb, or ofb.
+ # iv : Name of the initialization vector used in CBC, CFB,
+ # and OFB modes.
+ # kbits : Number of bits in a data block (default of 64).
+ # Output:
+ # The encrypted data string.
+ proc encrypt {keyset message {mode ecb} {iv {}} {kbits 64}} {
+ switch -exact -- $mode {
+ ecb {
+ return [block $keyset $message 1 0]
+ }
+ cbc -
+ ofb -
+ cfb {
+ # Is the initialization/feedback vector variable is valid?
+ if {[string length $iv] == 0} {
+ error "An initialization variable must be specified."
+ } else {
+ upvar $iv ivec
+ if {![info exists ivec]} {
+ error "The variable $iv does not exist."
+ }
+ }
+ switch -exact -- $mode {
+ cbc {
+ return [block $keyset $message 1 1 ivec]
+ }
+ ofb {
+ return [stream $keyset $message 1 0 ivec $kbits]
+ }
+ cfb {
+ return [stream $keyset $message 1 1 ivec $kbits]
+ }
+ }
+ }
+ default {
+ error {Mode must be ecb, cbc, cfb, or ofb.}
+ }
+ }
+ }
+
+ # Procedure: decrypt - Decryption front-end for the des procedure
+ # Inputs:
+ # keyset : Handle to an existing keyset.
+ # message : String to be decrypted.
+ # mode : DES mode ecb (default), cbc, cfb, or ofb.
+ # iv : Name of the initialization vector used in CBC, CFB,
+ # and OFB modes.
+ # kbits : Number of bits in a data block (default of 64).
+ # Output:
+ # The encrypted or decrypted data string.
+ proc decrypt {keyset message {mode ecb} {iv {}} {kbits 64}} {
+ switch -exact -- $mode {
+ ecb {
+ return [block $keyset $message 0 0]
+ }
+ cbc -
+ ofb -
+ cfb {
+ # Is the initialization/feedback vector variable is valid?
+ if {[string length $iv] < 1} {
+ error "An initialization variable must be specified."
+ } else {
+ upvar $iv ivec
+ if {![info exists ivec]} {
+ error "The variable $iv does not exist."
+ }
+ }
+ switch -exact -- $mode {
+ cbc {
+ return [block $keyset $message 0 1 ivec]
+ }
+ ofb {
+ return [stream $keyset $message 0 0 ivec $kbits]
+ }
+ cfb {
+ return [stream $keyset $message 0 1 ivec $kbits]
+ }
+ }
+ }
+ default {
+ error {Mode must be ecb, cbc, cfb, or ofb.}
+ }
+ }
+ }
+
+ variable spfunction1 [list 0x1010400 0 0x10000 0x1010404 0x1010004 0x10404 0x4 0x10000 0x400 0x1010400 0x1010404 0x400 0x1000404 0x1010004 0x1000000 0x4 0x404 0x1000400 0x1000400 0x10400 0x10400 0x1010000 0x1010000 0x1000404 0x10004 0x1000004 0x1000004 0x10004 0 0x404 0x10404 0x1000000 0x10000 0x1010404 0x4 0x1010000 0x1010400 0x1000000 0x1000000 0x400 0x1010004 0x10000 0x10400 0x1000004 0x400 0x4 0x1000404 0x10404 0x1010404 0x10004 0x1010000 0x1000404 0x1000004 0x404 0x10404 0x1010400 0x404 0x1000400 0x1000400 0 0x10004 0x10400 0 0x1010004];
+ variable spfunction2 [list 0x80108020 0x80008000 0x8000 0x108020 0x100000 0x20 0x80100020 0x80008020 0x80000020 0x80108020 0x80108000 0x80000000 0x80008000 0x100000 0x20 0x80100020 0x108000 0x100020 0x80008020 0 0x80000000 0x8000 0x108020 0x80100000 0x100020 0x80000020 0 0x108000 0x8020 0x80108000 0x80100000 0x8020 0 0x108020 0x80100020 0x100000 0x80008020 0x80100000 0x80108000 0x8000 0x80100000 0x80008000 0x20 0x80108020 0x108020 0x20 0x8000 0x80000000 0x8020 0x80108000 0x100000 0x80000020 0x100020 0x80008020 0x80000020 0x100020 0x108000 0 0x80008000 0x8020 0x80000000 0x80100020 0x80108020 0x108000];
+ variable spfunction3 [list 0x208 0x8020200 0 0x8020008 0x8000200 0 0x20208 0x8000200 0x20008 0x8000008 0x8000008 0x20000 0x8020208 0x20008 0x8020000 0x208 0x8000000 0x8 0x8020200 0x200 0x20200 0x8020000 0x8020008 0x20208 0x8000208 0x20200 0x20000 0x8000208 0x8 0x8020208 0x200 0x8000000 0x8020200 0x8000000 0x20008 0x208 0x20000 0x8020200 0x8000200 0 0x200 0x20008 0x8020208 0x8000200 0x8000008 0x200 0 0x8020008 0x8000208 0x20000 0x8000000 0x8020208 0x8 0x20208 0x20200 0x8000008 0x8020000 0x8000208 0x208 0x8020000 0x20208 0x8 0x8020008 0x20200];
+ variable spfunction4 [list 0x802001 0x2081 0x2081 0x80 0x802080 0x800081 0x800001 0x2001 0 0x802000 0x802000 0x802081 0x81 0 0x800080 0x800001 0x1 0x2000 0x800000 0x802001 0x80 0x800000 0x2001 0x2080 0x800081 0x1 0x2080 0x800080 0x2000 0x802080 0x802081 0x81 0x800080 0x800001 0x802000 0x802081 0x81 0 0 0x802000 0x2080 0x800080 0x800081 0x1 0x802001 0x2081 0x2081 0x80 0x802081 0x81 0x1 0x2000 0x800001 0x2001 0x802080 0x800081 0x2001 0x2080 0x800000 0x802001 0x80 0x800000 0x2000 0x802080];
+ variable spfunction5 [list 0x100 0x2080100 0x2080000 0x42000100 0x80000 0x100 0x40000000 0x2080000 0x40080100 0x80000 0x2000100 0x40080100 0x42000100 0x42080000 0x80100 0x40000000 0x2000000 0x40080000 0x40080000 0 0x40000100 0x42080100 0x42080100 0x2000100 0x42080000 0x40000100 0 0x42000000 0x2080100 0x2000000 0x42000000 0x80100 0x80000 0x42000100 0x100 0x2000000 0x40000000 0x2080000 0x42000100 0x40080100 0x2000100 0x40000000 0x42080000 0x2080100 0x40080100 0x100 0x2000000 0x42080000 0x42080100 0x80100 0x42000000 0x42080100 0x2080000 0 0x40080000 0x42000000 0x80100 0x2000100 0x40000100 0x80000 0 0x40080000 0x2080100 0x40000100];
+ variable spfunction6 [list 0x20000010 0x20400000 0x4000 0x20404010 0x20400000 0x10 0x20404010 0x400000 0x20004000 0x404010 0x400000 0x20000010 0x400010 0x20004000 0x20000000 0x4010 0 0x400010 0x20004010 0x4000 0x404000 0x20004010 0x10 0x20400010 0x20400010 0 0x404010 0x20404000 0x4010 0x404000 0x20404000 0x20000000 0x20004000 0x10 0x20400010 0x404000 0x20404010 0x400000 0x4010 0x20000010 0x400000 0x20004000 0x20000000 0x4010 0x20000010 0x20404010 0x404000 0x20400000 0x404010 0x20404000 0 0x20400010 0x10 0x4000 0x20400000 0x404010 0x4000 0x400010 0x20004010 0 0x20404000 0x20000000 0x400010 0x20004010];
+ variable spfunction7 [list 0x200000 0x4200002 0x4000802 0 0x800 0x4000802 0x200802 0x4200800 0x4200802 0x200000 0 0x4000002 0x2 0x4000000 0x4200002 0x802 0x4000800 0x200802 0x200002 0x4000800 0x4000002 0x4200000 0x4200800 0x200002 0x4200000 0x800 0x802 0x4200802 0x200800 0x2 0x4000000 0x200800 0x4000000 0x200800 0x200000 0x4000802 0x4000802 0x4200002 0x4200002 0x2 0x200002 0x4000000 0x4000800 0x200000 0x4200800 0x802 0x200802 0x4200800 0x802 0x4000002 0x4200802 0x4200000 0x200800 0 0x2 0x4200802 0 0x200802 0x4200000 0x800 0x4000002 0x4000800 0x800 0x200002];
+ variable spfunction8 [list 0x10001040 0x1000 0x40000 0x10041040 0x10000000 0x10001040 0x40 0x10000000 0x40040 0x10040000 0x10041040 0x41000 0x10041000 0x41040 0x1000 0x40 0x10040000 0x10000040 0x10001000 0x1040 0x41000 0x40040 0x10040040 0x10041000 0x1040 0 0 0x10040040 0x10000040 0x10001000 0x41040 0x40000 0x41040 0x40000 0x10041000 0x1000 0x40 0x10040040 0x1000 0x41040 0x10001000 0x40 0x10000040 0x10040000 0x10040040 0x10000000 0x40000 0x10001040 0 0x10041040 0x40040 0x10000040 0x10040000 0x10001000 0x10001040 0 0x10041040 0x41000 0x41000 0x1040 0x1040 0x40040 0x10000000 0x10041000];
+
+ variable desEncrypt {0 32 2}
+ variable desDecrypt {30 -2 -2}
+ variable des3Encrypt {0 32 2 62 30 -2 64 96 2}
+ variable des3Decrypt {94 62 -2 32 64 2 30 -2 -2}
+
+ # Procedure: block - DES ECB and CBC mode support
+ # Inputs:
+ # keyset : Handle to an existing keyset.
+ # message : String to be encrypted or decrypted (Note: For encryption,
+ # the string is extended with null characters to an integral
+ # multiple of eight bytes. For decryption, the string length
+ # must be an integral multiple of eight bytes.
+ # encrypt : Perform encryption (1) or decryption (0)
+ # mode : DES mode 1=CBC, 0=ECB (default).
+ # iv : Name of the variable containing the initialization vector
+ # used in CBC mode. The value must be 64 bits in length.
+ # Output:
+ # The encrypted or decrypted data string.
+ proc block {keyset message encrypt {mode 0} {iv {}}} {
+ variable spfunction1
+ variable spfunction2
+ variable spfunction3
+ variable spfunction4
+ variable spfunction5
+ variable spfunction6
+ variable spfunction7
+ variable spfunction8
+ variable desEncrypt
+ variable desDecrypt
+ variable des3Encrypt
+ variable des3Decrypt
+ variable keysets
+
+ # Determine if the keyset handle is valid.
+ if {[array names keysets $keyset] != {}} {
+ # Acquire the 16 or 48 subkeys we will need
+ set keys $keysets($keyset)
+ } else {
+ error "The keyset handle \"$keyset\" is invalid!"
+ }
+ set m 0
+ set cbcleft 0x00; set cbcleft2 0x00
+ set cbcright 0x00; set cbcright2 0x00
+ set len [string length $message];
+ if {$len == 0} {
+ return -code error "invalid message size: the message may not be empty"
+ }
+ set chunk 0;
+ # Set up the loops for single and triple des
+ set iterations [expr {[llength $keys] == 32 ? 3 : 9}];
+ if {$iterations == 3} {
+ expr {$encrypt ? [set looping $desEncrypt] : \
+ [set looping $desDecrypt]}
+ } else {
+ expr {$encrypt ? [set looping $des3Encrypt] : \
+ [set looping $des3Decrypt]}
+ }
+
+ # Pad the message out with null bytes.
+ append message "\0\0\0\0\0\0\0\0"
+
+ # Store the result here
+ set result {};
+ set tempresult {};
+
+ # CBC mode
+ if {$mode == 1} {
+ # Is the initialization/feedback vector variable is valid?
+ if {[string length $iv] < 1} {
+ error "An initialization variable must be specified."
+ } else {
+ upvar $iv ivec
+ if {![info exists ivec]} {
+ error "The variable $iv does not exist."
+ }
+ if {[string length $ivec] != 8} {
+ return -code error "invalid initialization vector size:\
+ the initialization vector must be 8 bytes"
+ }
+ }
+ # Use the input vector as the intial vector.
+ binary scan $ivec H8H8 cbcleftTemp cbcrightTemp
+ set cbcleft "0x$cbcleftTemp"
+ set cbcright "0x$cbcrightTemp"
+ }
+
+ # Loop through each 64 bit chunk of the message
+ while {$m < $len} {
+ binary scan $message x${m}H8H8 lefttemp righttemp
+ set left {}
+ append left "0x" $lefttemp
+ set right {}
+ append right "0x" $righttemp
+ incr m 8
+
+ #puts "Left start: $left";
+ #puts "Right start: $right";
+ # For Cipher Block Chaining mode, xor the
+ # message with the previous result.
+ if {$mode == 1} {
+ if {$encrypt} {
+ set left [expr {$left ^ $cbcleft}]
+ set right [expr {$right ^ $cbcright}]
+ } else {
+ set cbcleft2 $cbcleft;
+ set cbcright2 $cbcright;
+ set cbcleft $left;
+ set cbcright $right;
+ }
+ }
+
+ #puts "Left mode: $left";
+ #puts "Right mode: $right";
+ #puts "cbcleft: $cbcleft";
+ #puts "cbcleft2: $cbcleft2";
+ #puts "cbcright: $cbcright";
+ #puts "cbcright2: $cbcright2";
+
+ # First each 64 but chunk of the message
+ # must be permuted according to IP.
+ set temp [expr {(($left >> 4) ^ $right) & 0x0f0f0f0f}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 4)}];
+ set temp [expr {(($left >> 16) ^ $right) & 0x0000ffff}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 16)}];
+ set temp [expr {(($right >> 2) ^ $left) & 0x33333333}];
+ set left [expr {$left ^ $temp}]
+ set right [expr {$right ^ ($temp << 2)}];
+
+ set temp [expr {(($right >> 8) ^ $left) & 0x00ff00ff}];
+ set left [expr {$left ^ $temp}];
+ set right [expr {$right ^ ($temp << 8)}];
+ set temp [expr {(($left >> 1) ^ $right) & 0x55555555}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 1)}];
+
+ set left [expr {((($left << 1) & 0xffffffff) | \
+ (($left >> 31) & 0x00000001))}];
+ set right [expr {((($right << 1) & 0xffffffff) | \
+ (($right >> 31) & 0x00000001))}];
+
+ #puts "Left IP: [format %x $left]";
+ #puts "Right IP: [format %x $right]";
+
+ # Do this either 1 or 3 times for each chunk of the message
+ for {set j 0} {$j < $iterations} {incr j 3} {
+ set endloop [lindex $looping [expr {$j + 1}]];
+ set loopinc [lindex $looping [expr {$j + 2}]];
+
+ #puts "endloop: $endloop";
+ #puts "loopinc: $loopinc";
+
+ # Now go through and perform the encryption or decryption
+ for {set i [lindex $looping $j]} \
+ {$i != $endloop} {incr i $loopinc} {
+ # For efficiency
+ set right1 [expr {$right ^ [lindex $keys $i]}];
+ set right2 [expr {((($right >> 4) & 0x0fffffff) | \
+ (($right << 28) & 0xffffffff)) ^ \
+ [lindex $keys [expr {$i + 1}]]}];
+
+ # puts "right1: [format %x $right1]";
+ # puts "right2: [format %x $right2]";
+
+ # The result is attained by passing these
+ # bytes through the S selection functions.
+ set temp $left;
+ set left $right;
+ set right [expr {$temp ^ ([lindex $spfunction2 [expr {($right1 >> 24) & 0x3f}]] | \
+ [lindex $spfunction4 [expr {($right1 >> 16) & 0x3f}]] | \
+ [lindex $spfunction6 [expr {($right1 >> 8) & 0x3f}]] | \
+ [lindex $spfunction8 [expr {$right1 & 0x3f}]] | \
+ [lindex $spfunction1 [expr {($right2 >> 24) & 0x3f}]] | \
+ [lindex $spfunction3 [expr {($right2 >> 16) & 0x3f}]] | \
+ [lindex $spfunction5 [expr {($right2 >> 8) & 0x3f}]] | \
+ [lindex $spfunction7 [expr {$right2 & 0x3f}]])}];
+
+ # puts "Left iter: [format %x $left]";
+ # puts "Right iter: [format %x $right]";
+
+ }
+ set temp $left;
+ set left $right;
+ set right $temp; # Unreverse left and right
+ }; # For either 1 or 3 iterations
+
+ #puts "Left Iterated: [format %x $left]";
+ #puts "Right Iterated: [format %x $right]";
+
+ # Move then each one bit to the right
+ set left [expr {((($left >> 1) & 0x7fffffff) \
+ | (($left << 31) & 0xffffffff))}];
+ set right [expr {((($right >> 1) & 0x7fffffff) \
+ | (($right << 31) & 0xffffffff))}];
+
+ #puts "Left shifted: [format %x $left]";
+ #puts "Right shifted: [format %x $right]";
+
+ # Now perform IP-1, which is IP in the opposite direction
+ set temp [expr {((($left >> 1) & 0x7fffffff) ^ $right) & 0x55555555}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 1)}];
+ set temp [expr {((($right >> 8) & 0x00ffffff) ^ $left) & 0x00ff00ff}];
+ set left [expr {$left ^ $temp}];
+ set right [expr {$right ^ ($temp << 8)}];
+ set temp [expr {((($right >> 2) & 0x3fffffff) ^ $left) & 0x33333333}];
+ set left [expr {$left ^ $temp}];
+ set right [expr {$right ^ ($temp << 2)}];
+ set temp [expr {((($left >> 16) & 0x0000ffff) ^ $right) & 0x0000ffff}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 16)}];
+ set temp [expr {((($left >> 4) & 0x0fffffff) ^ $right) & 0x0f0f0f0f}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 4)}];
+
+ #puts "Left IP-1: [format %x $left]";
+ #puts "Right IP-1: [format %x $right]";
+
+ # For Cipher Block Chaining mode, xor
+ # the message with the previous result.
+ if {$mode == 1} {
+ if {$encrypt} {
+ set cbcleft $left;
+ set cbcright $right;
+ } else {
+ set left [expr {$left ^ $cbcleft2}];
+ set right [expr {$right ^ $cbcright2}];
+ }
+ }
+
+ append tempresult \
+ [binary format H16 [format %08x%08x $left $right]]
+
+ #puts "Left final: [format %x $left]";
+ #puts "Right final: [format %x $right]";
+
+ incr chunk 8;
+ if {$chunk == 512} {
+ append result $tempresult
+ set tempresult {};
+ set chunk 0;
+ }
+ }; # For every 8 characters, or 64 bits in the message
+
+ if {$mode == 1} {
+ if {$encrypt} {
+ # Save the left and right registers to the feedback vector.
+ set ivec [binary format H* \
+ [format %08x $left][format %08x $right]]
+ } else {
+ set ivec [binary format H* \
+ [format %08x $cbcleft][format %08x $cbcright]]
+ }
+ }
+
+ # Return the result as an array
+ return ${result}$tempresult
+ }; # End of block
+
+ # Procedure: stream - DES CFB and OFB mode support
+ # Inputs:
+ # keyset : Handle to an existing keyset.
+ # message : String to be encrypted or decrypted (Note: The length of the
+ # string is dependent upon the value of kbits. Remember that
+ # the string is part of a stream of data, so it must be sized
+ # properly for subsequent encryptions/decryptions to be
+ # correct. See the man page for correct message lengths for
+ # values of kbits).
+ # encrypt : Perform encryption (1) or decryption (0)
+ # mode : DES mode 0=OFB, 1=CFB.
+ # iv : Name of variable containing the initialization vector. The
+ # value must be 64 bits in length with the first 64-L bits set
+ # to zero.
+ # kbits : Number of bits in a data block (default of 64).
+ # Output:
+ # The encrypted or decrypted data string.
+ proc stream {keyset message encrypt mode iv {kbits 64}} {
+ variable spfunction1
+ variable spfunction2
+ variable spfunction3
+ variable spfunction4
+ variable spfunction5
+ variable spfunction6
+ variable spfunction7
+ variable spfunction8
+ variable desEncrypt
+ variable des3Encrypt
+ variable keysets
+
+ # Determine if the keyset handle is valid.
+ if {[array names keysets $keyset] != {}} {
+ # Acquire the 16 or 48 subkeys we will need.
+ set keys $keysets($keyset)
+ } else {
+ error "The keyset handle \"$keyset\" is invalid!"
+ }
+
+ # Is the initialization/feedback vector variable is valid?
+ if {[string length $iv] < 1} {
+ error "An initialization variable must be specified."
+ } else {
+ upvar $iv ivec
+ if {![info exists ivec]} {
+ error "The variable $iv does not exist."
+ }
+ }
+
+ # Determine if message length (in bits)
+ # is not an integral number of kbits.
+ set len [string length $message];
+ #puts "len: $len, kbits: $kbits"
+ if {($kbits < 1) || ($kbits > 64)} {
+ error "The valid values of kbits are 1 through 64."
+ } elseif {($kbits % 8) != 0} {
+ set blockSize [expr {$kbits + (8 - ($kbits % 8))}]
+ set fail [expr {(($len * 8) / $blockSize) % $kbits}]
+ } else {
+ set blockSize [expr {$kbits / 8}]
+ set fail [expr {$len % $blockSize}]
+ }
+ if {$fail} {
+ error "Data length (in bits) is not an integral number of kbits."
+ }
+
+ set m 0
+ set n 0
+ set chunk 0;
+ # Set up the loops for single and triple des
+ set iterations [expr {[llength $keys] == 32 ? 3 : 9}];
+ if {$iterations == 3} {
+ set looping $desEncrypt
+ } else {
+ set looping $des3Encrypt
+ }
+
+ # Set up shifting values. Used for both CFB and OFB modes.
+ if {$kbits < 32} {
+ # Only some bits from left output are needed.
+ set kOutShift [expr {32 - $kbits}]
+ set kOutMask [expr {0x7fffffff >> (31 - $kbits)}]
+ # Determine number of message bytes needed per iteration.
+ set msgBytes [expr {int(ceil(double($kbits) / 8.0))}]
+ # Determine number of message bits needed per iteration.
+ set msgBits [expr {$msgBytes * 8}]
+ set msgBitsSub1 [expr {$msgBits - 1}]
+ # Define bit caches.
+ set bitCacheIn {}
+ set bitCacheOut {}
+ # Variable used to remove bits 0 through
+ # kbits-1 in the input bit cache.
+ set kbitsSub1 [expr {$kbits - 1}]
+ # Variable used to remove leading dummy binary bits.
+ set xbits [expr {32 - $kbits}]
+ } elseif {$kbits == 32} {
+ # Only bits of left output are used.
+ # Four messages bytes are needed per iteration.
+ set msgBytes 4
+ set xbits 32
+ } elseif {$kbits < 64} {
+ # All bits from left output are needed.
+ set kOutShiftLeft [expr {$kbits - 32}]
+ # Some bits from right output are needed.
+ set kOutShiftRight [expr {64 - $kbits}]
+ set kOutMaskRight [expr {0x7fffffff >> (63 - $kbits)}]
+ # Determine number of message bytes needed per iteration.
+ set msgBytes [expr {int(ceil(double($kbits) / 8.0))}]
+ # Determine number of message bits needed per iteration.
+ set msgBits [expr {$msgBytes * 8}]
+ set msgBitsSub1 [expr {$msgBits - 1}]
+ # Define bit caches.
+ set bitCacheIn {}
+ set bitCacheOut {}
+ # Variable used to remove bits 0 through
+ # kbits-1 in the input bit cache.
+ set kbitsSub1 [expr {$kbits - 1}]
+ # Variable used to remove leading dummy binary bits.
+ set xbits [expr {64 - $kbits}]
+ } else {
+ # All 64 bits of output are used.
+ # Eight messages bytes are needed per iteration.
+ set msgBytes 8
+ set xbits 0
+ }
+
+ # Store the result here
+ set result {}
+ set tempresult {}
+
+ # Set up the initialization vector bitstream
+ binary scan $ivec H8H8 leftTemp rightTemp
+ set left "0x$leftTemp"
+ set right "0x$rightTemp"
+ #puts "Retrieved Feedback vector: $fbvec"
+ #puts "Start: |$left| |$right|"
+
+ # Loop through each 64 bit chunk of the message
+ while {$m < $len} {
+ # puts "Left start: $left";
+ # puts "Right start: $right";
+
+ # First each 64 but chunk of the
+ # message must be permuted according to IP.
+ set temp [expr {(($left >> 4) ^ $right) & 0x0f0f0f0f}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 4)}];
+ set temp [expr {(($left >> 16) ^ $right) & 0x0000ffff}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 16)}];
+ set temp [expr {(($right >> 2) ^ $left) & 0x33333333}];
+ set left [expr {$left ^ $temp}];
+ set right [expr {$right ^ ($temp << 2)}];
+
+ set temp [expr {(($right >> 8) ^ $left) & 0x00ff00ff}];
+ set left [expr {$left ^ $temp}];
+ set right [expr {$right ^ ($temp << 8)}];
+ set temp [expr {(($left >> 1) ^ $right) & 0x55555555}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 1)}];
+
+ set left [expr {((($left << 1) & 0xffffffff) | \
+ (($left >> 31) & 0x00000001))}];
+ set right [expr {((($right << 1) & 0xffffffff) | \
+ (($right >> 31) & 0x00000001))}];
+
+ #puts "Left IP: [format %x $left]";
+ #puts "Right IP: [format %x $right]";
+
+ # Do this either 1 or 3 times for each chunk of the message
+ for {set j 0} {$j < $iterations} {incr j 3} {
+ set endloop [lindex $looping [expr {$j + 1}]];
+ set loopinc [lindex $looping [expr {$j + 2}]];
+
+ #puts "endloop: $endloop";
+ #puts "loopinc: $loopinc";
+
+ # Now go through and perform the encryption or decryption
+ for {set i [lindex $looping $j]} \
+ {$i != $endloop} {incr i $loopinc} {
+ # For efficiency
+ set right1 [expr {$right ^ [lindex $keys $i]}];
+ set right2 [expr {((($right >> 4) & 0x0fffffff) | \
+ (($right << 28) & 0xffffffff)) ^ \
+ [lindex $keys [expr {$i + 1}]]}];
+
+ # puts "right1: [format %x $right1]";
+ # puts "right2: [format %x $right2]";
+
+ # The result is attained by passing these
+ # bytes through the S selection functions.
+ set temp $left;
+ set left $right;
+ set right [expr {$temp ^ ([lindex $spfunction2 [expr {($right1 >> 24) & 0x3f}]] | \
+ [lindex $spfunction4 [expr {($right1 >> 16) & 0x3f}]] | \
+ [lindex $spfunction6 [expr {($right1 >> 8) & 0x3f}]] | \
+ [lindex $spfunction8 [expr {$right1 & 0x3f}]] | \
+ [lindex $spfunction1 [expr {($right2 >> 24) & 0x3f}]] | \
+ [lindex $spfunction3 [expr {($right2 >> 16) & 0x3f}]] | \
+ [lindex $spfunction5 [expr {($right2 >> 8) & 0x3f}]] | \
+ [lindex $spfunction7 [expr {$right2 & 0x3f}]])}];
+
+ # puts "Left iter: [format %x $left]";
+ # puts "Right iter: [format %x $right]";
+
+ }
+ set temp $left;
+ set left $right;
+ set right $temp; # Unreverse left and right
+ }; # For either 1 or 3 iterations
+
+ #puts "Left Iterated: [format %x $left]";
+ #puts "Right Iterated: [format %x $right]";
+
+ # Move then each one bit to the right
+ set left [expr {((($left >> 1) & 0x7fffffff) | \
+ (($left << 31) & 0xffffffff))}];
+ set right [expr {((($right >> 1) & 0x7fffffff) | \
+ (($right << 31) & 0xffffffff))}];
+
+ #puts "Left shifted: [format %x $left]";
+ #puts "Right shifted: [format %x $right]";
+
+ # Now perform IP-1, which is IP in the opposite direction
+ set temp [expr {((($left >> 1) & 0x7fffffff) ^ $right) & 0x55555555}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 1)}];
+ set temp [expr {((($right >> 8) & 0x00ffffff) ^ $left) & 0x00ff00ff}];
+ set left [expr {$left ^ $temp}];
+ set right [expr {$right ^ ($temp << 8)}];
+ set temp [expr {((($right >> 2) & 0x3fffffff) ^ $left) & 0x33333333}];
+ set left [expr {$left ^ $temp}];
+ set right [expr {$right ^ ($temp << 2)}];
+ set temp [expr {((($left >> 16) & 0x0000ffff) ^ $right) & 0x0000ffff}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 16)}];
+ set temp [expr {((($left >> 4) & 0x0fffffff) ^ $right) & 0x0f0f0f0f}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 4)}];
+
+ #puts "Left IP-1: [format %x $left]";
+ #puts "Right IP-1: [format %x $right]";
+
+ # Extract the "kbits" most significant bits from the output block.
+ if {$kbits < 32} {
+ # Only some bits from left output are needed.
+ set kData [expr {($left >> $kOutShift) & $kOutMask}]
+ set newBits {}
+ # If necessary, copy message bytes into input bit cache.
+ if {([string length $bitCacheIn] < $kbits) && ($n < $len)} {
+ if {$len - $n < $msgBytes} {
+ set lastBits [expr {($len - $n) * 8}]
+ ###puts -nonewline [binary scan $message x${n}B$lastBits newBits]
+ binary scan $message x${n}B$lastBits newBits
+ } else {
+ # Extract "msgBytes" whole bytes as bits
+ ###puts -nonewline [binary scan $message x${n}B$msgBits newBits]
+ binary scan $message x${n}B$msgBits newBits
+ }
+ incr n $msgBytes
+ #puts " $newBits $n [expr {$len - $n}]"
+ # Add the bits to the input bit cache.
+ append bitCacheIn $newBits
+ }
+ #puts -nonewline "In bit cache: $bitCacheIn"
+ # Set up message data from input bit cache.
+ binary scan [binary format B32 [format %032s [string range $bitCacheIn 0 $kbitsSub1]]] H8 temp
+ set msgData "0x$temp"
+ # Mix message bits with crypto bits.
+ set mixData [expr {$msgData ^ $kData}]
+ # Discard collected bits from the input bit cache.
+ set bitCacheIn [string range $bitCacheIn $kbits end]
+ #puts " After: $bitCacheIn"
+ # Convert back to a bit stream and append to the output bit cache.
+ # Only the lower kbits are wanted.
+ binary scan [binary format H8 [format %08x $mixData]] B32 msgOut
+ append bitCacheOut [string range $msgOut $xbits end]
+ #puts -nonewline "Out bit cache: $bitCacheOut"
+ # If there are sufficient bits, move bytes to the temporary holding string.
+ if {[string length $bitCacheOut] >= $msgBits} {
+ append tempresult [binary format B$msgBits [string range $bitCacheOut 0 $msgBitsSub1]]
+ set bitCacheOut [string range $bitCacheOut $msgBits end]
+ #puts -nonewline " After: $bitCacheOut"
+ incr m $msgBytes
+ ###puts "$m bytes output"
+ incr chunk $msgBytes
+ }
+ #puts ""
+ # For CFB mode
+ if {$mode == 1} {
+ if {$encrypt} {
+ set temp [expr {($right << $kbits) & 0xffffffff}]
+ set left [expr {(($left << $kbits) & 0xffffffff) | (($right >> $kOutShift) & $kOutMask)}]
+ set right [expr {$temp | $mixData}]
+ } else {
+ set temp [expr {($right << $kbits) & 0xffffffff}]
+ set left [expr {(($left << $kbits) & 0xffffffff) | (($right >> $kOutShift) & $kOutMask)}]
+ set right [expr {$temp | $msgData}]
+ }
+ }
+ } elseif {$kbits == 32} {
+ # Only bits of left output are used.
+ set kData $left
+ # Four messages bytes are needed per iteration.
+ binary scan $message x${m}H8 temp
+ incr m 4
+ incr chunk 4
+ set msgData "0x$temp"
+ # Mix message bits with crypto bits.
+ set mixData [expr {$msgData ^ $kData}]
+ # Move bytes to the temporary holding string.
+ append tempresult [binary format H8 [format %08x $mixData]]
+ # For CFB mode
+ if {$mode == 1} {
+ set left $right
+ if {$encrypt} {
+ set right $mixData
+ } else {
+ set right $msgData
+ }
+ }
+ } elseif {$kbits < 64} {
+ set kDataLeft [expr {($left >> $kOutShiftRight) & $kOutMaskRight}]
+ set temp [expr {($left << $kOutShiftLeft) & 0xffffffff}]
+ set kDataRight [expr {(($right >> $kOutShiftRight) & $kOutMaskRight) | $temp}]
+ # If necessary, copy message bytes into input bit cache.
+ if {([string length $bitCacheIn] < $kbits) && ($n < $len)} {
+ if {$len - $n < $msgBytes} {
+ set lastBits [expr {($len - $n) * 8}]
+ ###puts -nonewline [binary scan $message x${n}B$lastBits newBits]
+ binary scan $message x${n}B$lastBits newBits
+ } else {
+ # Extract "msgBytes" whole bytes as bits
+ ###puts -nonewline [binary scan $message x${n}B$msgBits newBits]
+ binary scan $message x${n}B$msgBits newBits
+ }
+ incr n $msgBytes
+ # Add the bits to the input bit cache.
+ append bitCacheIn $newBits
+ }
+ # Set up message data from input bit cache.
+ # puts "Bits from cache: [set temp [string range $bitCacheIn 0 $kbitsSub1]]"
+ # puts "Length of bit string: [string length $temp]"
+ binary scan [binary format B64 [format %064s [string range $bitCacheIn 0 $kbitsSub1]]] H8H8 leftTemp rightTemp
+ set msgDataLeft "0x$leftTemp"
+ set msgDataRight "0x$rightTemp"
+ # puts "msgDataLeft: $msgDataLeft"
+ # puts "msgDataRight: $msgDataRight"
+ # puts "kDataLeft: [format 0x%08x $kDataLeft]"
+ # puts "kDataRight: [format 0x%08x $kDataRight]"
+ # Mix message bits with crypto bits.
+ set mixDataLeft [expr {$msgDataLeft ^ $kDataLeft}]
+ set mixDataRight [expr {$msgDataRight ^ $kDataRight}]
+ # puts "mixDataLeft: $mixDataLeft"
+ # puts "mixDataRight: $mixDataRight"
+ # puts "mixDataLeft: [format 0x%08x $mixDataLeft]"
+ # puts "mixDataRight: [format 0x%08x $mixDataRight]"
+ # Discard collected bits from the input bit cache.
+ set bitCacheIn [string range $bitCacheIn $kbits end]
+ # Convert back to a bit stream and
+ # append to the output bit cache.
+ # Only the lower kbits are wanted.
+ binary scan \
+ [binary format H8H8 \
+ [format %08x $mixDataLeft] \
+ [format %08x $mixDataRight]] B64 msgOut
+ append bitCacheOut [string range $msgOut $xbits end]
+ # If there are sufficient bits, move
+ # bytes to the temporary holding string.
+ if {[string length $bitCacheOut] >= $msgBits} {
+ append tempresult \
+ [binary format B$msgBits \
+ [string range $bitCacheOut 0 $msgBitsSub1]]
+ set bitCacheOut [string range $bitCacheOut $msgBits end]
+ incr m $msgBytes
+ incr chunk $msgBytes
+ }
+ # For CFB mode
+ if {$mode == 1} {
+ if {$encrypt} {
+ set temp \
+ [expr {($right << $kOutShiftRight) & 0xffffffff}]
+ set left [expr {$temp | $mixDataLeft}]
+ set right $mixDataRight
+ } else {
+ set temp \
+ [expr {($right << $kOutShiftRight) & 0xffffffff}]
+ set left [expr {$temp | $msgDataLeft}]
+ set right $msgDataRight
+ }
+ }
+ } else {
+ # All 64 bits of output are used.
+ set kDataLeft $left
+ set kDataRight $right
+ # Eight messages bytes are needed per iteration.
+ binary scan $message x${m}H8H8 leftTemp rightTemp
+ incr m 8
+ incr chunk 8
+ set msgDataLeft "0x$leftTemp"
+ set msgDataRight "0x$rightTemp"
+ # Mix message bits with crypto bits.
+ set mixDataLeft [expr {$msgDataLeft ^ $kDataLeft}]
+ set mixDataRight [expr {$msgDataRight ^ $kDataRight}]
+ # Move bytes to the temporary holding string.
+ append tempresult \
+ [binary format H16 \
+ [format %08x%08x $mixDataLeft $mixDataRight]]
+ # For CFB mode
+ if {$mode == 1} {
+ if {$encrypt} {
+ set left $mixDataLeft
+ set right $mixDataRight
+ } else {
+ set left $msgDataLeft
+ set right $msgDataRight
+ }
+ }
+ }
+
+ #puts "Left final: [format %x $left]";
+ #puts "Right final: [format %x $right]";
+
+ if {$chunk >= 512} {
+ append result $tempresult
+ set tempresult {};
+ set chunk 0;
+ }
+ }; # For every 8 characters, or 64 bits in the message
+ #puts "End: |[format 0x%08x $left]| |[format 0x%08x $right]|"
+ # Save the left and right registers to the feedback vector.
+ set ivec [binary format H* [format %08x $left][format %08x $right]]
+ #puts "Saved Feedback vector: $fbvectors($fbvector)"
+
+ append result $tempresult
+ if {[string length $result] > $len} {
+ set result [string replace $result $len end]
+ }
+ # Return the result as an array
+ return $result
+ }; # End of stream
+
+ variable pc2bytes0 [list 0 0x4 0x20000000 0x20000004 0x10000 0x10004 0x20010000 0x20010004 0x200 0x204 0x20000200 0x20000204 0x10200 0x10204 0x20010200 0x20010204]
+ variable pc2bytes1 [list 0 0x1 0x100000 0x100001 0x4000000 0x4000001 0x4100000 0x4100001 0x100 0x101 0x100100 0x100101 0x4000100 0x4000101 0x4100100 0x4100101]
+ variable pc2bytes2 [list 0 0x8 0x800 0x808 0x1000000 0x1000008 0x1000800 0x1000808 0 0x8 0x800 0x808 0x1000000 0x1000008 0x1000800 0x1000808]
+ variable pc2bytes3 [list 0 0x200000 0x8000000 0x8200000 0x2000 0x202000 0x8002000 0x8202000 0x20000 0x220000 0x8020000 0x8220000 0x22000 0x222000 0x8022000 0x8222000]
+ variable pc2bytes4 [list 0 0x40000 0x10 0x40010 0 0x40000 0x10 0x40010 0x1000 0x41000 0x1010 0x41010 0x1000 0x41000 0x1010 0x41010]
+ variable pc2bytes5 [list 0 0x400 0x20 0x420 0 0x400 0x20 0x420 0x2000000 0x2000400 0x2000020 0x2000420 0x2000000 0x2000400 0x2000020 0x2000420]
+ variable pc2bytes6 [list 0 0x10000000 0x80000 0x10080000 0x2 0x10000002 0x80002 0x10080002 0 0x10000000 0x80000 0x10080000 0x2 0x10000002 0x80002 0x10080002]
+ variable pc2bytes7 [list 0 0x10000 0x800 0x10800 0x20000000 0x20010000 0x20000800 0x20010800 0x20000 0x30000 0x20800 0x30800 0x20020000 0x20030000 0x20020800 0x20030800]
+ variable pc2bytes8 [list 0 0x40000 0 0x40000 0x2 0x40002 0x2 0x40002 0x2000000 0x2040000 0x2000000 0x2040000 0x2000002 0x2040002 0x2000002 0x2040002]
+ variable pc2bytes9 [list 0 0x10000000 0x8 0x10000008 0 0x10000000 0x8 0x10000008 0x400 0x10000400 0x408 0x10000408 0x400 0x10000400 0x408 0x10000408]
+ variable pc2bytes10 [list 0 0x20 0 0x20 0x100000 0x100020 0x100000 0x100020 0x2000 0x2020 0x2000 0x2020 0x102000 0x102020 0x102000 0x102020]
+ variable pc2bytes11 [list 0 0x1000000 0x200 0x1000200 0x200000 0x1200000 0x200200 0x1200200 0x4000000 0x5000000 0x4000200 0x5000200 0x4200000 0x5200000 0x4200200 0x5200200]
+ variable pc2bytes12 [list 0 0x1000 0x8000000 0x8001000 0x80000 0x81000 0x8080000 0x8081000 0x10 0x1010 0x8000010 0x8001010 0x80010 0x81010 0x8080010 0x8081010]
+ variable pc2bytes13 [list 0 0x4 0x100 0x104 0 0x4 0x100 0x104 0x1 0x5 0x101 0x105 0x1 0x5 0x101 0x105]
+
+ # Now define the left shifts which need to be done
+ variable shifts {0 0 1 1 1 1 1 1 0 1 1 1 1 1 1 0};
+
+ # Procedure: createKeys
+ # Input:
+ # key : The 64-bit DES key or the 192-bit 3DES key
+ # (Note: The lsb of each byte is ignored; odd parity
+ # is not required).
+ #
+ # weak: If true then weak keys are allowed. The default is to raise an
+ # error when a weak key is seen.
+ # Output:
+ # The 16 (DES) or 48 (3DES) subkeys.
+ proc createKeys {key {weak 0}} {
+ variable pc2bytes0
+ variable pc2bytes1
+ variable pc2bytes2
+ variable pc2bytes3
+ variable pc2bytes4
+ variable pc2bytes5
+ variable pc2bytes6
+ variable pc2bytes7
+ variable pc2bytes8
+ variable pc2bytes9
+ variable pc2bytes10
+ variable pc2bytes11
+ variable pc2bytes12
+ variable pc2bytes13
+ variable shifts
+
+ # How many iterations (1 for des, 3 for triple des)
+ set iterations [expr {([string length $key] >= 24) ? 3 : 1}];
+ # Stores the return keys
+ set keys {}
+ # Other variables
+ set lefttemp {}; set righttemp {}
+ set m 0
+ # Either 1 or 3 iterations
+ for {set j 0} {$j < $iterations} {incr j} {
+ binary scan $key x${m}H8H8 lefttemp righttemp
+ set left {}
+ append left "0x" $lefttemp
+ set right {}
+ append right "0x" $righttemp
+ incr m 8
+
+ #puts "Left key: $left"
+ #puts "Right key: $right"
+
+ # Test for weak keys
+ if {! $weak} {
+ set maskedLeft [expr {$left & 0xfefefefe}]
+ set maskedRight [expr {$right & 0xfefefefe}]
+ if {($maskedLeft == 0x00000000) \
+ && ($maskedRight == 0x00000000)} {
+ error "Key [expr {$j + 1}] is weak!"
+ } elseif {($maskedLeft == 0x1e1e1e1e) \
+ && ($maskedRight == 0x0e0e0e0e)} {
+ error "Key [expr {$j + 1}] is weak!"
+ } elseif {($maskedLeft == 0xe0e0e0e0) \
+ && ($maskedRight == 0xf0f0f0f0)} {
+ error "Key [expr {$j + 1}] is weak!"
+ } elseif {($maskedLeft == 0xfefefefe) \
+ && ($maskedRight == 0xfefefefe)} {
+ error "Key [expr {$j + 1}] is weak!"
+ }
+ }
+
+ set temp [expr {(($left >> 4) ^ $right) & 0x0f0f0f0f}]
+ set right [expr {$right ^ $temp}]
+ set left [expr {$left ^ ($temp << 4)}]
+ set temp [expr {(($right >> 16) ^ $left) & 0x0000ffff}]
+ set left [expr {$left ^ $temp}]
+ set right [expr {$right ^ ($temp << 16)}]
+ set temp [expr {(($left >> 2) ^ $right) & 0x33333333}]
+ set right [expr {$right ^ $temp}]
+ set left [expr {$left ^ ($temp << 2)}]
+ set temp [expr {(($right >> 16) ^ $left) & 0x0000ffff}]
+ set left [expr {$left ^ $temp}]
+ set right [expr {$right ^ ($temp << 16)}]
+ set temp [expr {(($left >> 1) ^ $right) & 0x55555555}]
+ set right [expr {$right ^ $temp}]
+ set left [expr {$left ^ ($temp << 1)}]
+ set temp [expr {(($right >> 8) ^ $left) & 0x00ff00ff}]
+ set left [expr {$left ^ $temp}]
+ set right [expr {$right ^ ($temp << 8)}]
+ set temp [expr {(($left >> 1) ^ $right) & 0x55555555}]
+ set right [expr {$right ^ $temp}]
+ set left [expr {$left ^ ($temp << 1)}]
+
+ #puts "Left key PC1: [format %x $left]"
+ #puts "Right key PC1: [format %x $right]"
+
+ # The right side needs to be shifted and to get
+ # the last four bits of the left side
+ set temp [expr {($left << 8) | (($right >> 20) & 0x000000f0)}];
+ # Left needs to be put upside down
+ set left [expr {($right << 24) | (($right << 8) & 0x00ff0000) | \
+ (($right >> 8) & 0x0000ff00) \
+ | (($right >> 24) & 0x000000f0)}];
+ set right $temp;
+
+ #puts "Left key juggle: [format %x $left]"
+ #puts "Right key juggle: [format %x $right]"
+
+ # Now go through and perform these
+ # shifts on the left and right keys.
+ foreach i $shifts {
+ # Shift the keys either one or two bits to the left.
+ if {$i} {
+ set left [expr {($left << 2) \
+ | (($left >> 26) & 0x0000003f)}];
+ set right [expr {($right << 2) \
+ | (($right >> 26) & 0x0000003f)}];
+ } else {
+ set left [expr {($left << 1) \
+ | (($left >> 27) & 0x0000001f)}];
+ set right [expr {($right << 1) \
+ | (($right >> 27) & 0x0000001f)}];
+ }
+ set left [expr {$left & 0xfffffff0}];
+ set right [expr {$right & 0xfffffff0}];
+
+ # Now apply PC-2, in such a way that E is easier when
+ # encrypting or decrypting this conversion will look like PC-2
+ # except only the last 6 bits of each byte are used rather than
+ # 48 consecutive bits and the order of lines will be according
+ # to how the S selection functions will be applied: S2, S4, S6,
+ # S8, S1, S3, S5, S7.
+ set lefttemp [expr {[lindex $pc2bytes0 [expr {($left >> 28) & 0x0000000f}]] | \
+ [lindex $pc2bytes1 [expr {($left >> 24) & 0x0000000f}]] | \
+ [lindex $pc2bytes2 [expr {($left >> 20) & 0x0000000f}]] | \
+ [lindex $pc2bytes3 [expr {($left >> 16) & 0x0000000f}]] | \
+ [lindex $pc2bytes4 [expr {($left >> 12) & 0x0000000f}]] | \
+ [lindex $pc2bytes5 [expr {($left >> 8) & 0x0000000f}]] | \
+ [lindex $pc2bytes6 [expr {($left >> 4) & 0x0000000f}]]}];
+ set righttemp [expr {[lindex $pc2bytes7 [expr {($right >> 28) & 0x0000000f}]] | \
+ [lindex $pc2bytes8 [expr {($right >> 24) & 0x0000000f}]] | \
+ [lindex $pc2bytes9 [expr {($right >> 20) & 0x0000000f}]] | \
+ [lindex $pc2bytes10 [expr {($right >> 16) & 0x0000000f}]] | \
+ [lindex $pc2bytes11 [expr {($right >> 12) & 0x0000000f}]] | \
+ [lindex $pc2bytes12 [expr {($right >> 8) & 0x0000000f}]] | \
+ [lindex $pc2bytes13 [expr {($right >> 4) & 0x0000000f}]]}];
+ set temp [expr {(($righttemp >> 16) ^ $lefttemp) & 0x0000ffff}];
+ lappend keys [expr {$lefttemp ^ $temp}];
+ lappend keys [expr {$righttemp ^ ($temp << 16)}];
+ }
+ }; # For each iteration.
+ # Return the keys we've created.
+ return $keys;
+ }; # End of createKeys.
+}; # End of des namespace eval.
+
+package provide tclDES 1.0.0
diff --git a/tcllib/modules/des/tcldesjr.man b/tcllib/modules/des/tcldesjr.man
new file mode 100644
index 0000000..ebdb936
--- /dev/null
+++ b/tcllib/modules/des/tcldesjr.man
@@ -0,0 +1,25 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin tcldes n 1.1]
+[see_also des(n)]
+[keywords 3DES]
+[keywords {block cipher}]
+[keywords {data integrity}]
+[keywords DES]
+[keywords encryption]
+[keywords security]
+[copyright {2005, Pat Thoyts <patthoyts@users.sourceforge.net>}]
+[moddesc {Data Encryption Standard (DES)}]
+[titledesc {Implementation of the DES and triple-DES ciphers}]
+[category {Hashes, checksums, and encryption}]
+[require Tcl 8.2]
+[require tclDESjr 1]
+[description]
+[para]
+
+The [package tclDESjr] package is a helper package for [package des].
+
+[para] Please see the documentation of [package des] for details.
+
+[vset CATEGORY des]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/des/tcldesjr.tcl b/tcllib/modules/des/tcldesjr.tcl
new file mode 100644
index 0000000..a1775a7
--- /dev/null
+++ b/tcllib/modules/des/tcldesjr.tcl
@@ -0,0 +1,1055 @@
+# desjr.tcl
+# $Revision: 1.1 $
+# $Date: 2005/09/26 09:16:59 $
+#
+# Port of Javascript implementation to Tcl 8.4 by Mac A. Cody,
+# 3DES functionality removed, February, 2003
+# July, 2003 - Separated key set generation from encryption/decryption.
+# Renamed "des" procedure to "block" to differentiate from the
+# "stream" procedure used for CFB and OFB modes.
+# Modified the "encrypt" and "decrypt" procedures to support
+# CFB and OFB modes. Changed the procedure arguments.
+# August, 2003 - Added the "stream" procedure to support CFB and OFB modes.
+# June, 2004 - Corrected input vector bug in stream-mode processing. Added
+# support for feedback vector storage and management function.
+# This enables a stream of data to be processed over several calls
+# to the encryptor or decryptor.
+# September, 2004 - Added feedback vector to the CBC mode of operation to allow
+# a large data set to be processed over several calls to the
+# encryptor or decryptor.
+# October, 2004 - Added test for weak keys in the createKeys procedure.
+#
+# Paul Tero, July 2001
+# http://www.shopable.co.uk/des.html
+#
+# Optimised for performance with large blocks by Michael Hayworth,
+# November 2001, http://www.netdealing.com
+#
+# This software is copyrighted (c) 2003, 2004 by Mac A. Cody. All rights
+# reserved. The following terms apply to all files associated with
+# the software unless explicitly disclaimed in individual files or
+# directories.
+
+# The authors hereby grant permission to use, copy, modify, distribute,
+# and license this software for any purpose, provided that existing
+# copyright notices are retained in all copies and that this notice is
+# included verbatim in any distributions. No written agreement, license,
+# or royalty fee is required for any of the authorized uses.
+# Modifications to this software may be copyrighted by their authors and
+# need not follow the licensing terms described here, provided that the
+# new terms are clearly indicated on the first page of each file where
+# they apply.
+
+# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+# MODIFICATIONS.
+
+# GOVERNMENT USE: If you are acquiring this software on behalf of the
+# U.S. government, the Government shall have only "Restricted Rights"
+# in the software and related documentation as defined in the Federal
+# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
+# are acquiring the software on behalf of the Department of Defense, the
+# software shall be classified as "Commercial Computer Software" and the
+# Government shall have only "Restricted Rights" as defined in Clause
+# 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
+# authors grant the U.S. Government and others acting in its behalf
+# permission to use and distribute the software in accordance with the
+# terms specified in this license.
+namespace eval des {
+ variable keysets
+ set keysets(ndx) 1
+ # Produre: keyset - Create or destroy a keyset created
+ # from a 64-bit DES key.
+ # Inputs:
+ # oper : The operation to be performed. This will be either "create"
+ # (make a new keyset) or "destroy" (delete an existing keyset).
+ # The meaning of the argument "value" depends of the operation
+ # performed. An error is generated if "oper" is not "create"
+ # or "destroy".
+ #
+ # value : If the argument "oper" is "create", then "value" is the 64-bit
+ # DES key. (Note: The lsb of each byte is ignored; odd parity is
+ # not required). If the argument "oper" is "destroy", then
+ # "value" is a handle to a keyset that was created previously.
+ #
+ # weak: If true then weak keys are allowed. The default is to raise an
+ # error when a weak key is seen.
+ # Output:
+ # If the argument "oper" is "create", then the output is a handle to the
+ # keyset stored in the des namespace. If the argument "oper" is
+ # "destroy", then nothing is returned.
+ proc keyset {oper value {weak 0}} {
+ variable keysets
+ set newset {}
+ switch -exact -- $oper {
+ create {
+ # Create a new keyset handle.
+ set newset keyset$keysets(ndx)
+ # Create key set
+ set keysets($newset) [createKeys $value $weak]
+ # Never use that keyset handle index again.
+ incr keysets(ndx)
+ }
+ destroy {
+ # Determine if the keyset handle is valid.
+ if {[array names keysets $value] != {}} {
+ # Delete the handle and corresponding keyset.
+ unset keysets($value)
+ } else {
+ error "The keyset handle \"$value\" is invalid!"
+ }
+ }
+ default {
+ error {The operator must be either "create" or "destroy".}
+ }
+ }
+ return $newset
+ }
+
+ # Procedure: encrypt - Encryption front-end for the des procedure
+ # Inputs:
+ # keyset : Handle to an existing keyset.
+ # message : String to be encrypted.
+ # mode : DES mode ecb (default), cbc, cfb, or ofb.
+ # iv : Name of the initialization vector used in CBC, CFB,
+ # and OFB modes.
+ # kbits : Number of bits in a data block (default of 64).
+ # Output:
+ # The encrypted data string.
+ proc encrypt {keyset message {mode ecb} {iv {}} {kbits 64}} {
+ switch -exact -- $mode {
+ ecb {
+ return [block $keyset $message 1 0]
+ }
+ cbc -
+ ofb -
+ cfb {
+ # Is the initialization/feedback vector variable is valid?
+ if {[string length $iv] == 0} {
+ error "An initialization variable must be specified."
+ } else {
+ upvar $iv ivec
+ if {![info exists ivec]} {
+ error "The variable $iv does not exist."
+ }
+ }
+ switch -exact -- $mode {
+ cbc {
+ return [block $keyset $message 1 1 ivec]
+ }
+ ofb {
+ return [stream $keyset $message 1 0 ivec $kbits]
+ }
+ cfb {
+ return [stream $keyset $message 1 1 ivec $kbits]
+ }
+ }
+ }
+ default {
+ error {Mode must be ecb, cbc, cfb, or ofb.}
+ }
+ }
+ }
+
+ # Procedure: decrypt - Decryption front-end for the des procedure
+ # Inputs:
+ # keyset : Handle to an existing keyset.
+ # message : String to be decrypted.
+ # mode : DES mode ecb (default), cbc, cfb, or ofb.
+ # iv : Name of the initialization vector used in CBC, CFB,
+ # and OFB modes.
+ # kbits : Number of bits in a data block (default of 64).
+ # Output:
+ # The encrypted or decrypted data string.
+ proc decrypt {keyset message {mode ecb} {iv {}} {kbits 64}} {
+ switch -exact -- $mode {
+ ecb {
+ return [block $keyset $message 0 0]
+ }
+ cbc -
+ ofb -
+ cfb {
+ # Is the initialization/feedback vector variable is valid?
+ if {[string length $iv] < 1} {
+ error "An initialization variable must be specified."
+ } else {
+ upvar $iv ivec
+ if {![info exists ivec]} {
+ error "The variable $iv does not exist."
+ }
+ }
+ switch -exact -- $mode {
+ cbc {
+ return [block $keyset $message 0 1 ivec]
+ }
+ ofb {
+ return [stream $keyset $message 0 0 ivec $kbits]
+ }
+ cfb {
+ return [stream $keyset $message 0 1 ivec $kbits]
+ }
+ }
+ }
+ default {
+ error {Mode must be ecb, cbc, cfb, or ofb.}
+ }
+ }
+ }
+
+ variable spfunction1 [list 0x1010400 0 0x10000 0x1010404 0x1010004 0x10404 0x4 0x10000 0x400 0x1010400 0x1010404 0x400 0x1000404 0x1010004 0x1000000 0x4 0x404 0x1000400 0x1000400 0x10400 0x10400 0x1010000 0x1010000 0x1000404 0x10004 0x1000004 0x1000004 0x10004 0 0x404 0x10404 0x1000000 0x10000 0x1010404 0x4 0x1010000 0x1010400 0x1000000 0x1000000 0x400 0x1010004 0x10000 0x10400 0x1000004 0x400 0x4 0x1000404 0x10404 0x1010404 0x10004 0x1010000 0x1000404 0x1000004 0x404 0x10404 0x1010400 0x404 0x1000400 0x1000400 0 0x10004 0x10400 0 0x1010004];
+ variable spfunction2 [list 0x80108020 0x80008000 0x8000 0x108020 0x100000 0x20 0x80100020 0x80008020 0x80000020 0x80108020 0x80108000 0x80000000 0x80008000 0x100000 0x20 0x80100020 0x108000 0x100020 0x80008020 0 0x80000000 0x8000 0x108020 0x80100000 0x100020 0x80000020 0 0x108000 0x8020 0x80108000 0x80100000 0x8020 0 0x108020 0x80100020 0x100000 0x80008020 0x80100000 0x80108000 0x8000 0x80100000 0x80008000 0x20 0x80108020 0x108020 0x20 0x8000 0x80000000 0x8020 0x80108000 0x100000 0x80000020 0x100020 0x80008020 0x80000020 0x100020 0x108000 0 0x80008000 0x8020 0x80000000 0x80100020 0x80108020 0x108000];
+ variable spfunction3 [list 0x208 0x8020200 0 0x8020008 0x8000200 0 0x20208 0x8000200 0x20008 0x8000008 0x8000008 0x20000 0x8020208 0x20008 0x8020000 0x208 0x8000000 0x8 0x8020200 0x200 0x20200 0x8020000 0x8020008 0x20208 0x8000208 0x20200 0x20000 0x8000208 0x8 0x8020208 0x200 0x8000000 0x8020200 0x8000000 0x20008 0x208 0x20000 0x8020200 0x8000200 0 0x200 0x20008 0x8020208 0x8000200 0x8000008 0x200 0 0x8020008 0x8000208 0x20000 0x8000000 0x8020208 0x8 0x20208 0x20200 0x8000008 0x8020000 0x8000208 0x208 0x8020000 0x20208 0x8 0x8020008 0x20200];
+ variable spfunction4 [list 0x802001 0x2081 0x2081 0x80 0x802080 0x800081 0x800001 0x2001 0 0x802000 0x802000 0x802081 0x81 0 0x800080 0x800001 0x1 0x2000 0x800000 0x802001 0x80 0x800000 0x2001 0x2080 0x800081 0x1 0x2080 0x800080 0x2000 0x802080 0x802081 0x81 0x800080 0x800001 0x802000 0x802081 0x81 0 0 0x802000 0x2080 0x800080 0x800081 0x1 0x802001 0x2081 0x2081 0x80 0x802081 0x81 0x1 0x2000 0x800001 0x2001 0x802080 0x800081 0x2001 0x2080 0x800000 0x802001 0x80 0x800000 0x2000 0x802080];
+ variable spfunction5 [list 0x100 0x2080100 0x2080000 0x42000100 0x80000 0x100 0x40000000 0x2080000 0x40080100 0x80000 0x2000100 0x40080100 0x42000100 0x42080000 0x80100 0x40000000 0x2000000 0x40080000 0x40080000 0 0x40000100 0x42080100 0x42080100 0x2000100 0x42080000 0x40000100 0 0x42000000 0x2080100 0x2000000 0x42000000 0x80100 0x80000 0x42000100 0x100 0x2000000 0x40000000 0x2080000 0x42000100 0x40080100 0x2000100 0x40000000 0x42080000 0x2080100 0x40080100 0x100 0x2000000 0x42080000 0x42080100 0x80100 0x42000000 0x42080100 0x2080000 0 0x40080000 0x42000000 0x80100 0x2000100 0x40000100 0x80000 0 0x40080000 0x2080100 0x40000100];
+ variable spfunction6 [list 0x20000010 0x20400000 0x4000 0x20404010 0x20400000 0x10 0x20404010 0x400000 0x20004000 0x404010 0x400000 0x20000010 0x400010 0x20004000 0x20000000 0x4010 0 0x400010 0x20004010 0x4000 0x404000 0x20004010 0x10 0x20400010 0x20400010 0 0x404010 0x20404000 0x4010 0x404000 0x20404000 0x20000000 0x20004000 0x10 0x20400010 0x404000 0x20404010 0x400000 0x4010 0x20000010 0x400000 0x20004000 0x20000000 0x4010 0x20000010 0x20404010 0x404000 0x20400000 0x404010 0x20404000 0 0x20400010 0x10 0x4000 0x20400000 0x404010 0x4000 0x400010 0x20004010 0 0x20404000 0x20000000 0x400010 0x20004010];
+ variable spfunction7 [list 0x200000 0x4200002 0x4000802 0 0x800 0x4000802 0x200802 0x4200800 0x4200802 0x200000 0 0x4000002 0x2 0x4000000 0x4200002 0x802 0x4000800 0x200802 0x200002 0x4000800 0x4000002 0x4200000 0x4200800 0x200002 0x4200000 0x800 0x802 0x4200802 0x200800 0x2 0x4000000 0x200800 0x4000000 0x200800 0x200000 0x4000802 0x4000802 0x4200002 0x4200002 0x2 0x200002 0x4000000 0x4000800 0x200000 0x4200800 0x802 0x200802 0x4200800 0x802 0x4000002 0x4200802 0x4200000 0x200800 0 0x2 0x4200802 0 0x200802 0x4200000 0x800 0x4000002 0x4000800 0x800 0x200002];
+ variable spfunction8 [list 0x10001040 0x1000 0x40000 0x10041040 0x10000000 0x10001040 0x40 0x10000000 0x40040 0x10040000 0x10041040 0x41000 0x10041000 0x41040 0x1000 0x40 0x10040000 0x10000040 0x10001000 0x1040 0x41000 0x40040 0x10040040 0x10041000 0x1040 0 0 0x10040040 0x10000040 0x10001000 0x41040 0x40000 0x41040 0x40000 0x10041000 0x1000 0x40 0x10040040 0x1000 0x41040 0x10001000 0x40 0x10000040 0x10040000 0x10040040 0x10000000 0x40000 0x10001040 0 0x10041040 0x40040 0x10000040 0x10040000 0x10001000 0x10001040 0 0x10041040 0x41000 0x41000 0x1040 0x1040 0x40040 0x10000000 0x10041000];
+
+ variable desEncrypt {0 32 2}
+ variable desDecrypt {30 -2 -2}
+
+ # Procedure: block - DES ECB and CBC mode support
+ # Inputs:
+ # keyset : Handle to an existing keyset.
+ # message : String to be encrypted or decrypted (Note: For encryption,
+ # the string is extended with null characters to an integral
+ # multiple of eight bytes. For decryption, the string length
+ # must be an integral multiple of eight bytes.
+ # encrypt : Perform encryption (1) or decryption (0)
+ # mode : DES mode 1=CBC, 0=ECB (default).
+ # iv : Name of the variable containing the initialization vector
+ # used in CBC mode. The value must be 64 bits in length.
+ # Output:
+ # The encrypted or decrypted data string.
+ proc block {keyset message encrypt {mode 0} {iv {}}} {
+ variable spfunction1
+ variable spfunction2
+ variable spfunction3
+ variable spfunction4
+ variable spfunction5
+ variable spfunction6
+ variable spfunction7
+ variable spfunction8
+ variable desEncrypt
+ variable desDecrypt
+ variable keysets
+
+ # Determine if the keyset handle is valid.
+ if {[array names keysets $keyset] != {}} {
+ # Acquire the 16 or 48 subkeys we will need
+ set keys $keysets($keyset)
+ } else {
+ error "The keyset handle \"$keyset\" is invalid!"
+ }
+ set m 0
+ set cbcleft 0x00; set cbcleft2 0x00
+ set cbcright 0x00; set cbcright2 0x00
+ set len [string length $message];
+ if {$len == 0} {
+ return -code error "invalid message size: the message may not be empty"
+ }
+ set chunk 0;
+ # Set up the loops for des
+ expr {$encrypt ? [set looping $desEncrypt] : [set looping $desDecrypt]}
+
+ # Pad the message out with null bytes.
+ append message "\0\0\0\0\0\0\0\0"
+
+ # Store the result here
+ set result {};
+ set tempresult {};
+
+ # CBC mode
+ if {$mode == 1} {
+ # Is the initialization/feedback vector variable is valid?
+ if {[string length $iv] < 1} {
+ error "An initialization variable must be specified."
+ } else {
+ upvar $iv ivec
+ if {![info exists ivec]} {
+ error "The variable $iv does not exist."
+ }
+ if {[string length $ivec] != 8} {
+ return -code error "invalid initialization vector size:\
+ the initialization vector must be 8 bytes"
+ }
+ }
+ # Use the input vector as the intial vector.
+ binary scan $ivec H8H8 cbcleftTemp cbcrightTemp
+ set cbcleft "0x$cbcleftTemp"
+ set cbcright "0x$cbcrightTemp"
+ }
+
+ # Loop through each 64 bit chunk of the message
+ while {$m < $len} {
+ binary scan $message x${m}H8H8 lefttemp righttemp
+ set left {}
+ append left "0x" $lefttemp
+ set right {}
+ append right "0x" $righttemp
+ incr m 8
+
+ #puts "Left start: $left";
+ #puts "Right start: $right";
+ # For Cipher Block Chaining mode, xor the
+ # message with the previous result.
+ if {$mode == 1} {
+ if {$encrypt} {
+ set left [expr {$left ^ $cbcleft}]
+ set right [expr {$right ^ $cbcright}]
+ } else {
+ set cbcleft2 $cbcleft;
+ set cbcright2 $cbcright;
+ set cbcleft $left;
+ set cbcright $right;
+ }
+ }
+
+ #puts "Left mode: $left";
+ #puts "Right mode: $right";
+ #puts "cbcleft: $cbcleft";
+ #puts "cbcleft2: $cbcleft2";
+ #puts "cbcright: $cbcright";
+ #puts "cbcright2: $cbcright2";
+
+ # First each 64 but chunk of the message
+ # must be permuted according to IP.
+ set temp [expr {(($left >> 4) ^ $right) & 0x0f0f0f0f}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 4)}];
+ set temp [expr {(($left >> 16) ^ $right) & 0x0000ffff}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 16)}];
+ set temp [expr {(($right >> 2) ^ $left) & 0x33333333}];
+ set left [expr {$left ^ $temp}]
+ set right [expr {$right ^ ($temp << 2)}];
+
+ set temp [expr {(($right >> 8) ^ $left) & 0x00ff00ff}];
+ set left [expr {$left ^ $temp}];
+ set right [expr {$right ^ ($temp << 8)}];
+ set temp [expr {(($left >> 1) ^ $right) & 0x55555555}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 1)}];
+
+ set left [expr {((($left << 1) & 0xffffffff) | \
+ (($left >> 31) & 0x00000001))}];
+ set right [expr {((($right << 1) & 0xffffffff) | \
+ (($right >> 31) & 0x00000001))}];
+
+ #puts "Left IP: [format %x $left]";
+ #puts "Right IP: [format %x $right]";
+
+ # Do this 1 time for each chunk of the message.
+ set endloop [lindex $looping 1];
+ set loopinc [lindex $looping 2];
+
+ #puts "endloop: $endloop";
+ #puts "loopinc: $loopinc";
+
+ # Now go through and perform the encryption or decryption.
+ for {set i [lindex $looping 0]} \
+ {$i != $endloop} {incr i $loopinc} {
+ # For efficiency
+ set right1 [expr {$right ^ [lindex $keys $i]}];
+ set right2 [expr {((($right >> 4) & 0x0fffffff) | \
+ (($right << 28) & 0xffffffff)) ^ \
+ [lindex $keys [expr {$i + 1}]]}];
+
+ # puts "right1: [format %x $right1]";
+ # puts "right2: [format %x $right2]";
+
+ # The result is attained by passing these
+ # bytes through the S selection functions.
+ set temp $left;
+ set left $right;
+ set right [expr {$temp ^ ([lindex $spfunction2 [expr {($right1 >> 24) & 0x3f}]] | \
+ [lindex $spfunction4 [expr {($right1 >> 16) & 0x3f}]] | \
+ [lindex $spfunction6 [expr {($right1 >> 8) & 0x3f}]] | \
+ [lindex $spfunction8 [expr {$right1 & 0x3f}]] | \
+ [lindex $spfunction1 [expr {($right2 >> 24) & 0x3f}]] | \
+ [lindex $spfunction3 [expr {($right2 >> 16) & 0x3f}]] | \
+ [lindex $spfunction5 [expr {($right2 >> 8) & 0x3f}]] | \
+ [lindex $spfunction7 [expr {$right2 & 0x3f}]])}];
+
+ # puts "Left iter: [format %x $left]";
+ # puts "Right iter: [format %x $right]";
+
+ }
+ set temp $left;
+ set left $right;
+ set right $temp; # Unreverse left and right.
+
+ #puts "Left Iterated: [format %x $left]";
+ #puts "Right Iterated: [format %x $right]";
+
+ # Move then each one bit to the right
+ set left [expr {((($left >> 1) & 0x7fffffff) \
+ | (($left << 31) & 0xffffffff))}];
+ set right [expr {((($right >> 1) & 0x7fffffff) \
+ | (($right << 31) & 0xffffffff))}];
+
+ #puts "Left shifted: [format %x $left]";
+ #puts "Right shifted: [format %x $right]";
+
+ # Now perform IP-1, which is IP in the opposite direction
+ set temp [expr {((($left >> 1) & 0x7fffffff) ^ $right) & 0x55555555}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 1)}];
+ set temp [expr {((($right >> 8) & 0x00ffffff) ^ $left) & 0x00ff00ff}];
+ set left [expr {$left ^ $temp}];
+ set right [expr {$right ^ ($temp << 8)}];
+ set temp [expr {((($right >> 2) & 0x3fffffff) ^ $left) & 0x33333333}];
+ set left [expr {$left ^ $temp}];
+ set right [expr {$right ^ ($temp << 2)}];
+ set temp [expr {((($left >> 16) & 0x0000ffff) ^ $right) & 0x0000ffff}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 16)}];
+ set temp [expr {((($left >> 4) & 0x0fffffff) ^ $right) & 0x0f0f0f0f}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 4)}];
+
+ #puts "Left IP-1: [format %x $left]";
+ #puts "Right IP-1: [format %x $right]";
+
+ # For Cipher Block Chaining mode, xor
+ # the message with the previous result.
+ if {$mode == 1} {
+ if {$encrypt} {
+ set cbcleft $left;
+ set cbcright $right;
+ } else {
+ set left [expr {$left ^ $cbcleft2}];
+ set right [expr {$right ^ $cbcright2}];
+ }
+ }
+
+ append tempresult \
+ [binary format H16 [format %08x%08x $left $right]]
+
+ #puts "Left final: [format %x $left]";
+ #puts "Right final: [format %x $right]";
+
+ incr chunk 8;
+ if {$chunk == 512} {
+ append result $tempresult
+ set tempresult {};
+ set chunk 0;
+ }
+ }; # For every 8 characters, or 64 bits in the message
+
+ if {$mode == 1} {
+ if {$encrypt} {
+ # Save the left and right registers to the feedback vector.
+ set ivec [binary format H* \
+ [format %08x $left][format %08x $right]]
+ } else {
+ set ivec [binary format H* \
+ [format %08x $cbcleft][format %08x $cbcright]]
+ }
+ }
+
+ # Return the result as an array
+ return ${result}$tempresult
+ }; # End of block
+
+ # Procedure: stream - DES CFB and OFB mode support
+ # Inputs:
+ # keyset : Handle to an existing keyset.
+ # message : String to be encrypted or decrypted (Note: The length of the
+ # string is dependent upon the value of kbits. Remember that
+ # the string is part of a stream of data, so it must be sized
+ # properly for subsequent encryptions/decryptions to be
+ # correct. See the man page for correct message lengths for
+ # values of kbits).
+ # encrypt : Perform encryption (1) or decryption (0)
+ # mode : DES mode 0=OFB, 1=CFB.
+ # iv : Name of variable containing the initialization vector. The
+ # value must be 64 bits in length with the first 64-L bits set
+ # to zero.
+ # kbits : Number of bits in a data block (default of 64).
+ # Output:
+ # The encrypted or decrypted data string.
+ proc stream {keyset message encrypt mode iv {kbits 64}} {
+ variable spfunction1
+ variable spfunction2
+ variable spfunction3
+ variable spfunction4
+ variable spfunction5
+ variable spfunction6
+ variable spfunction7
+ variable spfunction8
+ variable desEncrypt
+ variable keysets
+
+ # Determine if the keyset handle is valid.
+ if {[array names keysets $keyset] != {}} {
+ # Acquire the 16 subkeys we will need.
+ set keys $keysets($keyset)
+ } else {
+ error "The keyset handle \"$keyset\" is invalid!"
+ }
+
+ # Is the initialization/feedback vector variable is valid?
+ if {[string length $iv] < 1} {
+ error "An initialization variable must be specified."
+ } else {
+ upvar $iv ivec
+ if {![info exists ivec]} {
+ error "The variable $iv does not exist."
+ }
+ }
+
+ # Determine if message length (in bits)
+ # is not an integral number of kbits.
+ set len [string length $message];
+ #puts "len: $len, kbits: $kbits"
+ if {($kbits < 1) || ($kbits > 64)} {
+ error "The valid values of kbits are 1 through 64."
+ } elseif {($kbits % 8) != 0} {
+ set blockSize [expr {$kbits + (8 - ($kbits % 8))}]
+ set fail [expr {(($len * 8) / $blockSize) % $kbits}]
+ } else {
+ set blockSize [expr {$kbits / 8}]
+ set fail [expr {$len % $blockSize}]
+ }
+ if {$fail} {
+ error "Data length (in bits) is not an integral number of kbits."
+ }
+
+ set m 0
+ set n 0
+ set chunk 0;
+ # Set up the loops for des
+ set looping $desEncrypt
+
+ # Set up shifting values. Used for both CFB and OFB modes.
+ if {$kbits < 32} {
+ # Only some bits from left output are needed.
+ set kOutShift [expr {32 - $kbits}]
+ set kOutMask [expr {0x7fffffff >> (31 - $kbits)}]
+ # Determine number of message bytes needed per iteration.
+ set msgBytes [expr {int(ceil(double($kbits) / 8.0))}]
+ # Determine number of message bits needed per iteration.
+ set msgBits [expr {$msgBytes * 8}]
+ set msgBitsSub1 [expr {$msgBits - 1}]
+ # Define bit caches.
+ set bitCacheIn {}
+ set bitCacheOut {}
+ # Variable used to remove bits 0 through
+ # kbits-1 in the input bit cache.
+ set kbitsSub1 [expr {$kbits - 1}]
+ # Variable used to remove leading dummy binary bits.
+ set xbits [expr {32 - $kbits}]
+ } elseif {$kbits == 32} {
+ # Only bits of left output are used.
+ # Four messages bytes are needed per iteration.
+ set msgBytes 4
+ set xbits 32
+ } elseif {$kbits < 64} {
+ # All bits from left output are needed.
+ set kOutShiftLeft [expr {$kbits - 32}]
+ # Some bits from right output are needed.
+ set kOutShiftRight [expr {64 - $kbits}]
+ set kOutMaskRight [expr {0x7fffffff >> (63 - $kbits)}]
+ # Determine number of message bytes needed per iteration.
+ set msgBytes [expr {int(ceil(double($kbits) / 8.0))}]
+ # Determine number of message bits needed per iteration.
+ set msgBits [expr {$msgBytes * 8}]
+ set msgBitsSub1 [expr {$msgBits - 1}]
+ # Define bit caches.
+ set bitCacheIn {}
+ set bitCacheOut {}
+ # Variable used to remove bits 0 through
+ # kbits-1 in the input bit cache.
+ set kbitsSub1 [expr {$kbits - 1}]
+ # Variable used to remove leading dummy binary bits.
+ set xbits [expr {64 - $kbits}]
+ } else {
+ # All 64 bits of output are used.
+ # Eight messages bytes are needed per iteration.
+ set msgBytes 8
+ set xbits 0
+ }
+
+ # Store the result here
+ set result {}
+ set tempresult {}
+
+ # Set up the initialization vector bitstream
+ binary scan $ivec H8H8 leftTemp rightTemp
+ set left "0x$leftTemp"
+ set right "0x$rightTemp"
+ #puts "Retrieved Feedback vector: $fbvec"
+ #puts "Start: |$left| |$right|"
+
+ # Loop through each 64 bit chunk of the message
+ while {$m < $len} {
+ # puts "Left start: $left";
+ # puts "Right start: $right";
+
+ # First each 64 but chunk of the
+ # message must be permuted according to IP.
+ set temp [expr {(($left >> 4) ^ $right) & 0x0f0f0f0f}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 4)}];
+ set temp [expr {(($left >> 16) ^ $right) & 0x0000ffff}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 16)}];
+ set temp [expr {(($right >> 2) ^ $left) & 0x33333333}];
+ set left [expr {$left ^ $temp}];
+ set right [expr {$right ^ ($temp << 2)}];
+
+ set temp [expr {(($right >> 8) ^ $left) & 0x00ff00ff}];
+ set left [expr {$left ^ $temp}];
+ set right [expr {$right ^ ($temp << 8)}];
+ set temp [expr {(($left >> 1) ^ $right) & 0x55555555}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 1)}];
+
+ set left [expr {((($left << 1) & 0xffffffff) | \
+ (($left >> 31) & 0x00000001))}];
+ set right [expr {((($right << 1) & 0xffffffff) | \
+ (($right >> 31) & 0x00000001))}];
+
+ #puts "Left IP: [format %x $left]";
+ #puts "Right IP: [format %x $right]";
+
+ # Do this 1 time for each chunk of the message
+ set endloop [lindex $looping 1];
+ set loopinc [lindex $looping 2];
+
+ # puts "endloop: $endloop";
+ # puts "loopinc: $loopinc";
+
+ # Now go through and perform the encryption or decryption
+ for {set i [lindex $looping 0]} \
+ {$i != $endloop} {incr i $loopinc} {
+ # For efficiency
+ set right1 [expr {$right ^ [lindex $keys $i]}];
+ set right2 [expr {((($right >> 4) & 0x0fffffff) | \
+ (($right << 28) & 0xffffffff)) ^ \
+ [lindex $keys [expr {$i + 1}]]}];
+
+ # puts "right1: [format %x $right1]";
+ # puts "right2: [format %x $right2]";
+
+ # The result is attained by passing these
+ # bytes through the S selection functions.
+ set temp $left;
+ set left $right;
+ set right [expr {$temp ^ ([lindex $spfunction2 [expr {($right1 >> 24) & 0x3f}]] | \
+ [lindex $spfunction4 [expr {($right1 >> 16) & 0x3f}]] | \
+ [lindex $spfunction6 [expr {($right1 >> 8) & 0x3f}]] | \
+ [lindex $spfunction8 [expr {$right1 & 0x3f}]] | \
+ [lindex $spfunction1 [expr {($right2 >> 24) & 0x3f}]] | \
+ [lindex $spfunction3 [expr {($right2 >> 16) & 0x3f}]] | \
+ [lindex $spfunction5 [expr {($right2 >> 8) & 0x3f}]] | \
+ [lindex $spfunction7 [expr {$right2 & 0x3f}]])}];
+
+ # puts "Left iter: [format %x $left]";
+ # puts "Right iter: [format %x $right]";
+ }
+ set temp $left;
+ set left $right;
+ set right $temp; # Unreverse left and right
+
+ #puts "Left Iterated: [format %x $left]";
+ #puts "Right Iterated: [format %x $right]";
+
+ # Move then each one bit to the right
+ set left [expr {((($left >> 1) & 0x7fffffff) | \
+ (($left << 31) & 0xffffffff))}];
+ set right [expr {((($right >> 1) & 0x7fffffff) | \
+ (($right << 31) & 0xffffffff))}];
+
+ #puts "Left shifted: [format %x $left]";
+ #puts "Right shifted: [format %x $right]";
+
+ # Now perform IP-1, which is IP in the opposite direction
+ set temp [expr {((($left >> 1) & 0x7fffffff) ^ $right) & 0x55555555}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 1)}];
+ set temp [expr {((($right >> 8) & 0x00ffffff) ^ $left) & 0x00ff00ff}];
+ set left [expr {$left ^ $temp}];
+ set right [expr {$right ^ ($temp << 8)}];
+ set temp [expr {((($right >> 2) & 0x3fffffff) ^ $left) & 0x33333333}];
+ set left [expr {$left ^ $temp}];
+ set right [expr {$right ^ ($temp << 2)}];
+ set temp [expr {((($left >> 16) & 0x0000ffff) ^ $right) & 0x0000ffff}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 16)}];
+ set temp [expr {((($left >> 4) & 0x0fffffff) ^ $right) & 0x0f0f0f0f}];
+ set right [expr {$right ^ $temp}];
+ set left [expr {$left ^ ($temp << 4)}];
+
+ #puts "Left IP-1: [format %x $left]";
+ #puts "Right IP-1: [format %x $right]";
+
+ # Extract the "kbits" most significant bits from the output block.
+ if {$kbits < 32} {
+ # Only some bits from left output are needed.
+ set kData [expr {($left >> $kOutShift) & $kOutMask}]
+ set newBits {}
+ # If necessary, copy message bytes into input bit cache.
+ if {([string length $bitCacheIn] < $kbits) && ($n < $len)} {
+ if {$len - $n < $msgBytes} {
+ set lastBits [expr {($len - $n) * 8}]
+ ###puts -nonewline [binary scan $message x${n}B$lastBits newBits]
+ binary scan $message x${n}B$lastBits newBits
+ } else {
+ # Extract "msgBytes" whole bytes as bits
+ ###puts -nonewline [binary scan $message x${n}B$msgBits newBits]
+ binary scan $message x${n}B$msgBits newBits
+ }
+ incr n $msgBytes
+ #puts " $newBits $n [expr {$len - $n}]"
+ # Add the bits to the input bit cache.
+ append bitCacheIn $newBits
+ }
+ #puts -nonewline "In bit cache: $bitCacheIn"
+ # Set up message data from input bit cache.
+ binary scan [binary format B32 [format %032s [string range $bitCacheIn 0 $kbitsSub1]]] H8 temp
+ set msgData "0x$temp"
+ # Mix message bits with crypto bits.
+ set mixData [expr {$msgData ^ $kData}]
+ # Discard collected bits from the input bit cache.
+ set bitCacheIn [string range $bitCacheIn $kbits end]
+ #puts " After: $bitCacheIn"
+ # Convert back to a bit stream and append to the output bit cache.
+ # Only the lower kbits are wanted.
+ binary scan [binary format H8 [format %08x $mixData]] B32 msgOut
+ append bitCacheOut [string range $msgOut $xbits end]
+ #puts -nonewline "Out bit cache: $bitCacheOut"
+ # If there are sufficient bits, move bytes to the temporary holding string.
+ if {[string length $bitCacheOut] >= $msgBits} {
+ append tempresult [binary format B$msgBits [string range $bitCacheOut 0 $msgBitsSub1]]
+ set bitCacheOut [string range $bitCacheOut $msgBits end]
+ #puts -nonewline " After: $bitCacheOut"
+ incr m $msgBytes
+ ###puts "$m bytes output"
+ incr chunk $msgBytes
+ }
+ #puts ""
+ # For CFB mode
+ if {$mode == 1} {
+ if {$encrypt} {
+ set temp [expr {($right << $kbits) & 0xffffffff}]
+ set left [expr {(($left << $kbits) & 0xffffffff) | (($right >> $kOutShift) & $kOutMask)}]
+ set right [expr {$temp | $mixData}]
+ } else {
+ set temp [expr {($right << $kbits) & 0xffffffff}]
+ set left [expr {(($left << $kbits) & 0xffffffff) | (($right >> $kOutShift) & $kOutMask)}]
+ set right [expr {$temp | $msgData}]
+ }
+ }
+ } elseif {$kbits == 32} {
+ # Only bits of left output are used.
+ set kData $left
+ # Four messages bytes are needed per iteration.
+ binary scan $message x${m}H8 temp
+ incr m 4
+ incr chunk 4
+ set msgData "0x$temp"
+ # Mix message bits with crypto bits.
+ set mixData [expr {$msgData ^ $kData}]
+ # Move bytes to the temporary holding string.
+ append tempresult [binary format H8 [format %08x $mixData]]
+ # For CFB mode
+ if {$mode == 1} {
+ set left $right
+ if {$encrypt} {
+ set right $mixData
+ } else {
+ set right $msgData
+ }
+ }
+ } elseif {$kbits < 64} {
+ set kDataLeft [expr {($left >> $kOutShiftRight) & $kOutMaskRight}]
+ set temp [expr {($left << $kOutShiftLeft) & 0xffffffff}]
+ set kDataRight [expr {(($right >> $kOutShiftRight) & $kOutMaskRight) | $temp}]
+ # If necessary, copy message bytes into input bit cache.
+ if {([string length $bitCacheIn] < $kbits) && ($n < $len)} {
+ if {$len - $n < $msgBytes} {
+ set lastBits [expr {($len - $n) * 8}]
+ ###puts -nonewline [binary scan $message x${n}B$lastBits newBits]
+ binary scan $message x${n}B$lastBits newBits
+ } else {
+ # Extract "msgBytes" whole bytes as bits
+ ###puts -nonewline [binary scan $message x${n}B$msgBits newBits]
+ binary scan $message x${n}B$msgBits newBits
+ }
+ incr n $msgBytes
+ # Add the bits to the input bit cache.
+ append bitCacheIn $newBits
+ }
+ # Set up message data from input bit cache.
+ # puts "Bits from cache: [set temp [string range $bitCacheIn 0 $kbitsSub1]]"
+ # puts "Length of bit string: [string length $temp]"
+ binary scan [binary format B64 [format %064s [string range $bitCacheIn 0 $kbitsSub1]]] H8H8 leftTemp rightTemp
+ set msgDataLeft "0x$leftTemp"
+ set msgDataRight "0x$rightTemp"
+ # puts "msgDataLeft: $msgDataLeft"
+ # puts "msgDataRight: $msgDataRight"
+ # puts "kDataLeft: [format 0x%08x $kDataLeft]"
+ # puts "kDataRight: [format 0x%08x $kDataRight]"
+ # Mix message bits with crypto bits.
+ set mixDataLeft [expr {$msgDataLeft ^ $kDataLeft}]
+ set mixDataRight [expr {$msgDataRight ^ $kDataRight}]
+ # puts "mixDataLeft: $mixDataLeft"
+ # puts "mixDataRight: $mixDataRight"
+ # puts "mixDataLeft: [format 0x%08x $mixDataLeft]"
+ # puts "mixDataRight: [format 0x%08x $mixDataRight]"
+ # Discard collected bits from the input bit cache.
+ set bitCacheIn [string range $bitCacheIn $kbits end]
+ # Convert back to a bit stream and
+ # append to the output bit cache.
+ # Only the lower kbits are wanted.
+ binary scan \
+ [binary format H8H8 \
+ [format %08x $mixDataLeft] \
+ [format %08x $mixDataRight]] B64 msgOut
+ append bitCacheOut [string range $msgOut $xbits end]
+ # If there are sufficient bits, move
+ # bytes to the temporary holding string.
+ if {[string length $bitCacheOut] >= $msgBits} {
+ append tempresult \
+ [binary format B$msgBits \
+ [string range $bitCacheOut 0 $msgBitsSub1]]
+ set bitCacheOut [string range $bitCacheOut $msgBits end]
+ incr m $msgBytes
+ incr chunk $msgBytes
+ }
+ # For CFB mode
+ if {$mode == 1} {
+ if {$encrypt} {
+ set temp \
+ [expr {($right << $kOutShiftRight) & 0xffffffff}]
+ set left [expr {$temp | $mixDataLeft}]
+ set right $mixDataRight
+ } else {
+ set temp \
+ [expr {($right << $kOutShiftRight) & 0xffffffff}]
+ set left [expr {$temp | $msgDataLeft}]
+ set right $msgDataRight
+ }
+ }
+ } else {
+ # All 64 bits of output are used.
+ set kDataLeft $left
+ set kDataRight $right
+ # Eight messages bytes are needed per iteration.
+ binary scan $message x${m}H8H8 leftTemp rightTemp
+ incr m 8
+ incr chunk 8
+ set msgDataLeft "0x$leftTemp"
+ set msgDataRight "0x$rightTemp"
+ # Mix message bits with crypto bits.
+ set mixDataLeft [expr {$msgDataLeft ^ $kDataLeft}]
+ set mixDataRight [expr {$msgDataRight ^ $kDataRight}]
+ # Move bytes to the temporary holding string.
+ append tempresult \
+ [binary format H16 \
+ [format %08x%08x $mixDataLeft $mixDataRight]]
+ # For CFB mode
+ if {$mode == 1} {
+ if {$encrypt} {
+ set left $mixDataLeft
+ set right $mixDataRight
+ } else {
+ set left $msgDataLeft
+ set right $msgDataRight
+ }
+ }
+ }
+
+ #puts "Left final: [format %08x $left]";
+ #puts "Right final: [format %08x $right]"
+
+ if {$chunk >= 512} {
+ append result $tempresult
+ set tempresult {};
+ set chunk 0;
+ }
+ }; # For every 8 characters, or 64 bits in the message
+ #puts "End: |[format 0x%08x $left]| |[format 0x%08x $right]|"
+ # Save the left and right registers to the feedback vector.
+ set ivec [binary format H* [format %08x $left][format %08x $right]]
+ #puts "Saved Feedback vector: $fbvectors($fbvector)"
+
+ append result $tempresult
+ if {[string length $result] > $len} {
+ set result [string replace $result $len end]
+ }
+ # Return the result as an array
+ return $result
+ }; # End of stream
+
+ variable pc2bytes0 [list 0 0x4 0x20000000 0x20000004 0x10000 0x10004 0x20010000 0x20010004 0x200 0x204 0x20000200 0x20000204 0x10200 0x10204 0x20010200 0x20010204]
+ variable pc2bytes1 [list 0 0x1 0x100000 0x100001 0x4000000 0x4000001 0x4100000 0x4100001 0x100 0x101 0x100100 0x100101 0x4000100 0x4000101 0x4100100 0x4100101]
+ variable pc2bytes2 [list 0 0x8 0x800 0x808 0x1000000 0x1000008 0x1000800 0x1000808 0 0x8 0x800 0x808 0x1000000 0x1000008 0x1000800 0x1000808]
+ variable pc2bytes3 [list 0 0x200000 0x8000000 0x8200000 0x2000 0x202000 0x8002000 0x8202000 0x20000 0x220000 0x8020000 0x8220000 0x22000 0x222000 0x8022000 0x8222000]
+ variable pc2bytes4 [list 0 0x40000 0x10 0x40010 0 0x40000 0x10 0x40010 0x1000 0x41000 0x1010 0x41010 0x1000 0x41000 0x1010 0x41010]
+ variable pc2bytes5 [list 0 0x400 0x20 0x420 0 0x400 0x20 0x420 0x2000000 0x2000400 0x2000020 0x2000420 0x2000000 0x2000400 0x2000020 0x2000420]
+ variable pc2bytes6 [list 0 0x10000000 0x80000 0x10080000 0x2 0x10000002 0x80002 0x10080002 0 0x10000000 0x80000 0x10080000 0x2 0x10000002 0x80002 0x10080002]
+ variable pc2bytes7 [list 0 0x10000 0x800 0x10800 0x20000000 0x20010000 0x20000800 0x20010800 0x20000 0x30000 0x20800 0x30800 0x20020000 0x20030000 0x20020800 0x20030800]
+ variable pc2bytes8 [list 0 0x40000 0 0x40000 0x2 0x40002 0x2 0x40002 0x2000000 0x2040000 0x2000000 0x2040000 0x2000002 0x2040002 0x2000002 0x2040002]
+ variable pc2bytes9 [list 0 0x10000000 0x8 0x10000008 0 0x10000000 0x8 0x10000008 0x400 0x10000400 0x408 0x10000408 0x400 0x10000400 0x408 0x10000408]
+ variable pc2bytes10 [list 0 0x20 0 0x20 0x100000 0x100020 0x100000 0x100020 0x2000 0x2020 0x2000 0x2020 0x102000 0x102020 0x102000 0x102020]
+ variable pc2bytes11 [list 0 0x1000000 0x200 0x1000200 0x200000 0x1200000 0x200200 0x1200200 0x4000000 0x5000000 0x4000200 0x5000200 0x4200000 0x5200000 0x4200200 0x5200200]
+ variable pc2bytes12 [list 0 0x1000 0x8000000 0x8001000 0x80000 0x81000 0x8080000 0x8081000 0x10 0x1010 0x8000010 0x8001010 0x80010 0x81010 0x8080010 0x8081010]
+ variable pc2bytes13 [list 0 0x4 0x100 0x104 0 0x4 0x100 0x104 0x1 0x5 0x101 0x105 0x1 0x5 0x101 0x105]
+
+ # Now define the left shifts which need to be done
+ variable shifts {0 0 1 1 1 1 1 1 0 1 1 1 1 1 1 0};
+
+ # Procedure: createKeys
+ # Input:
+ # key : The 64-bit DES key (Note: The lsb of each byte
+ # is ignored; odd parity is not required).
+ #
+ # weak: If true then weak keys are allowed. The default is to raise an
+ # error when a weak key is seen.
+ # Output:
+ # The 16 (DES) subkeys.
+ proc createKeys {key {weak 0}} {
+ variable pc2bytes0
+ variable pc2bytes1
+ variable pc2bytes2
+ variable pc2bytes3
+ variable pc2bytes4
+ variable pc2bytes5
+ variable pc2bytes6
+ variable pc2bytes7
+ variable pc2bytes8
+ variable pc2bytes9
+ variable pc2bytes10
+ variable pc2bytes11
+ variable pc2bytes12
+ variable pc2bytes13
+ variable shifts
+
+ # Stores the return keys
+ set keys {}
+ # Other variables
+ set lefttemp {}; set righttemp {}
+ binary scan $key H8H8 lefttemp righttemp
+ set left {}
+ append left "0x" $lefttemp
+ set right {}
+ append right "0x" $righttemp
+
+ #puts "Left key: $left"
+ #puts "Right key: $right"
+
+ # Test for weak keys
+ if {! $weak} {
+ set maskedLeft [expr {$left & 0xfefefefe}]
+ set maskedRight [expr {$right & 0xfefefefe}]
+ if {($maskedLeft == 0x00000000) \
+ && ($maskedRight == 0x00000000)} {
+ error "The key is weak!"
+ } elseif {($maskedLeft == 0x1e1e1e1e) \
+ && ($maskedRight == 0x0e0e0e0e)} {
+ error "The key is weak!"
+ } elseif {($maskedLeft == 0xe0e0e0e0) \
+ && ($maskedRight == 0xf0f0f0f0)} {
+ error "The key is weak!"
+ } elseif {($maskedLeft == 0xfefefefe) \
+ && ($maskedRight == 0xfefefefe)} {
+ error "The key is weak!"
+ }
+ }
+
+ set temp [expr {(($left >> 4) ^ $right) & 0x0f0f0f0f}]
+ set right [expr {$right ^ $temp}]
+ set left [expr {$left ^ ($temp << 4)}]
+ set temp [expr {(($right >> 16) ^ $left) & 0x0000ffff}]
+ set left [expr {$left ^ $temp}]
+ set right [expr {$right ^ ($temp << 16)}]
+ set temp [expr {(($left >> 2) ^ $right) & 0x33333333}]
+ set right [expr {$right ^ $temp}]
+ set left [expr {$left ^ ($temp << 2)}]
+ set temp [expr {(($right >> 16) ^ $left) & 0x0000ffff}]
+ set left [expr {$left ^ $temp}]
+ set right [expr {$right ^ ($temp << 16)}]
+ set temp [expr {(($left >> 1) ^ $right) & 0x55555555}]
+ set right [expr {$right ^ $temp}]
+ set left [expr {$left ^ ($temp << 1)}]
+ set temp [expr {(($right >> 8) ^ $left) & 0x00ff00ff}]
+ set left [expr {$left ^ $temp}]
+ set right [expr {$right ^ ($temp << 8)}]
+ set temp [expr {(($left >> 1) ^ $right) & 0x55555555}]
+ set right [expr $right ^ $temp]
+ set left [expr {$left ^ ($temp << 1)}]
+
+ # puts "Left key PC1: [format %x $left]"
+ # puts "Right key PC1: [format %x $right]"
+
+ # The right side needs to be shifted and to get
+ # the last four bits of the left side
+ set temp [expr {($left << 8) | (($right >> 20) & 0x000000f0)}];
+ # Left needs to be put upside down
+ set left [expr {($right << 24) | (($right << 8) & 0x00ff0000) | \
+ (($right >> 8) & 0x0000ff00) \
+ | (($right >> 24) & 0x000000f0)}];
+ set right $temp;
+
+ #puts "Left key juggle: [format %x $left]"
+ #puts "Right key juggle: [format %x $right]"
+
+ # Now go through and perform these
+ # shifts on the left and right keys.
+ foreach i $shifts {
+ # Shift the keys either one or two bits to the left.
+ if {$i} {
+ set left [expr {($left << 2) \
+ | (($left >> 26) & 0x0000003f)}];
+ set right [expr {($right << 2) \
+ | (($right >> 26) & 0x0000003f)}];
+ } else {
+ set left [expr {($left << 1) \
+ | (($left >> 27) & 0x0000001f)}];
+ set right [expr {($right << 1) \
+ | (($right >> 27) & 0x0000001f)}];
+ }
+ set left [expr {$left & 0xfffffff0}];
+ set right [expr {$right & 0xfffffff0}];
+
+ # Now apply PC-2, in such a way that E is easier when encrypting or
+ # decrypting this conversion will look like PC-2 except only the
+ # last 6 bits of each byte are used rather than 48 consecutive bits
+ # and the order of lines will be according to how the S selection
+ # functions will be applied: S2, S4, S6, S8, S1, S3, S5, S7.
+ set lefttemp [expr {[lindex $pc2bytes0 [expr {($left >> 28) & 0x0000000f}]] | \
+ [lindex $pc2bytes1 [expr {($left >> 24) & 0x0000000f}]] | \
+ [lindex $pc2bytes2 [expr {($left >> 20) & 0x0000000f}]] | \
+ [lindex $pc2bytes3 [expr {($left >> 16) & 0x0000000f}]] | \
+ [lindex $pc2bytes4 [expr {($left >> 12) & 0x0000000f}]] | \
+ [lindex $pc2bytes5 [expr {($left >> 8) & 0x0000000f}]] | \
+ [lindex $pc2bytes6 [expr {($left >> 4) & 0x0000000f}]]}];
+ set righttemp [expr {[lindex $pc2bytes7 [expr {($right >> 28) & 0x0000000f}]] | \
+ [lindex $pc2bytes8 [expr {($right >> 24) & 0x0000000f}]] | \
+ [lindex $pc2bytes9 [expr {($right >> 20) & 0x0000000f}]] | \
+ [lindex $pc2bytes10 [expr {($right >> 16) & 0x0000000f}]] | \
+ [lindex $pc2bytes11 [expr {($right >> 12) & 0x0000000f}]] | \
+ [lindex $pc2bytes12 [expr {($right >> 8) & 0x0000000f}]] | \
+ [lindex $pc2bytes13 [expr {($right >> 4) & 0x0000000f}]]}];
+ set temp [expr {(($righttemp >> 16) ^ $lefttemp) & 0x0000ffff}];
+ lappend keys [expr {$lefttemp ^ $temp}];
+ lappend keys [expr {$righttemp ^ ($temp << 16)}];
+ }
+ # Return the keys we've created.
+ return $keys;
+ }; # End of createKeys.
+}; # End of des namespace eval.
+
+package provide tclDESjr 1.0.0
diff --git a/tcllib/modules/devtools/ChangeLog b/tcllib/modules/devtools/ChangeLog
new file mode 100644
index 0000000..baff9a8
--- /dev/null
+++ b/tcllib/modules/devtools/ChangeLog
@@ -0,0 +1,245 @@
+2013-01-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * transmitter.crt: [Bug 3433470] Regenerated the certificates,
+ * transmitter.key: again. Expiry is Jan 2023 (10 years).
+ * receiver.crt: While SimpleCA doesn't seem to allow me to
+ * receiver.key: specify a longer period in the GUI it was possible
+ * ca.crt: to get, update and run the Tcl code, unwrapped.
+ * ca.key: Further changed to 4096-bit certs.
+
+2011-11-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: Fixed typos, one still breaking 'testsNeed'.
+
+2011-11-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: Fixed 'testsNeed' command to require the
+ needed package and abort properly when it is not found.
+
+ * transmitter.crt: [Bug 3433470] Regenerated the certificates.
+ * transmitter.key: Expiry is Nov 2012. SimpleCA doesn't seem
+ * receiver.crt: to allow me to specify a longer period. :(
+ * receiver.key: Updated README.
+ * ca.crt:
+ * ca.key:
+ * README:
+
+2011-11-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: Added new constraint to identify core version
+ upto Tcl 8.5, but not higher.
+
+2011-01-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl (useTcllibC): Account for the possibility of
+ the environment providing a tcllibc, instead of a Tcllib local
+ one.
+
+2011-01-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl (snitTooManyArgs): Fixed error messages for
+ snit 1.x series.
+
+2010-09-15 Andreas Kupries <andreask@activestate.com>
+
+ * testutilities.tcl: [Bug 3066026]: Moved the tcltest
+ compatibility initialization into a procedure (InitializeTcltest)
+ which is called by testNeedsTcltest and a few other places to be
+ done only after we are sure that the tcltest package is present.
+
+2010-03-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: Added constraint for 8.4-.
+
+2009-09-24 Andreas Kupries <andreask@activestate.com>
+
+ * testutilities.tcl: Added constraint for 8.6+.
+
+2009-04-13 Andreas Kupries <andreask@activestate.com>
+
+ * dialog.tcl: Extended to allow dialog over a socket secured by
+ SSL (via package tls).
+
+2009-04-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ca.crt: New files, SSL/TLS certificates for use in testsuites.
+ * ca.key: ca.* = Tcllib Certification Authority
+ * ca.key.password: Receiver, Transmitter = Certificates for two
+ * receiver.crt: sides of a communication channel.
+ * receiver.key:
+ * transmitter.crt:
+ * transmitter.key:
+
+ * README: Acknowledgement added for the SimpleCA software used to
+ create the certificates.
+
+2008-09-20 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * testutitlites.tcl: Added wrong num args error messages for
+ Tcl 8.6 alphas, to make tests pass.
+
+2007-04-30 Andreas Kupries <andreask@activestate.com>
+
+ * testutilities.tcl: Made TestFiles 8.2-ready. Added command
+ 'TestFilesGlob' to simply return files instead of immediately
+ sourcing them.
+
+2007-04-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: Added 'TestFiles', a command to run a set of
+ subordinate test files, found by globbing.
+
+ * testutilities.tcl: Added 'useAccel' to help with the setup of
+ packages which have accelerators, automatically using the proper
+ use variant.
+
+2006-10-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: Extended with three commands to make testing
+ of packages with multiple implementations (accelerators)
+ easier. A specific API for querying and manipulating
+ accelerators is assumed.
+
+2006-10-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: Changed variable definitions to shield
+ against creative writing. Added common code to save and restore
+ the environment (::env), for testsuites which have to (1) either
+ modify it as part of the tests, or (2) shield themselves against
+ manipulation from the environment.
+
+2006-09-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dialog.tcl: Bugfix in 'Input', cleaning up the waiting timer
+ when reaching eof on the socket. Could otherwise trigger
+ while executing an unrelated future dialog. Extended to manage
+ two traces, the new one a condensed form of the existing trace,
+ easier to put into the result of a testcase.
+
+ * coserv.tcl: Reworked a bit to allow the restart of a server
+ after a shutdown, by recreating the helper file executed by the
+ slave-process.
+
+2006-09-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: Modified use commands to ensure that their
+ output is a proper list.
+
+2006-09-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: Added commands constructing wrong#args
+ messages for snit methods, depending on snit version.
+
+2006-09-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: Ensure that the makeFile/Dir wrapper are
+ created only once. Also modified the code to modify the
+ originals to return the full name. The wrapper are needed only
+ as indicators.
+
+2006-04-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: Added set of commands for the easy assembly
+ of complex results. Mainly a shorthand for 'lappend', using a
+ common variable.
+
+2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: Force re-import of tcltest commands after
+ changes made by the support system. Added code forcing a useful
+ result value of makeFile/makeDirectory even for Tcltest 1.x
+ (path created instead of list of all paths). Command for the
+ creation of a binary temp. file, and a command to return the
+ path of temp files without us having to create them.
+
+ * coserv.tcl: Fixed usage of temp. files by comm server.
+
+ * coserv.tcl: Fixed output for a better fit with the other test
+ * dialog.tcl: support.
+
+2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: Added variants of the use commands which keep
+ the relevant namespace. Sometimes necessary to prevent
+ destruction of support code loaded first.
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: Added commands for the loading of files and
+ packages from the Tcllib under test. This will reduce the amount
+ of boilerplate in a .test file spent on getting the package
+ under test, its supporting packages, and other helper files.
+
+ Added helpers for dealing with loading "tcllibc" package and
+ packages using it.
+
+2006-01-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: Moved the definitions of the common
+ constraints out of the toplevel "all.tcl" into the test support
+ code.
+
+2006-01-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * testutilities.tcl: New file for boilerplate code and common
+ commands used by most to all testsuites in Tcllib.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2004-10-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dialog.tcl: More log output for better tracing of the
+ internals. Especially added trace when receiving an incomplete
+ line while waiting for data from the peer. Added code to clean
+ up old connections, prevent leakage of channel handles.
+
+2004-10-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * muserv.tcl: Removed the old facilities for sub processes
+ * musub.tcl: and programmed interactions. They have been
+ * subserv.tcl: superceded by the code below.
+
+ * coserv.tcl: New sub process mgmt based on "comm".
+ * dialog.tcl: New code for programmed dialogs based on
+ "coserv.tcl".
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-05-01 Andreas Kupries <andreask@activestate.com>
+
+ * subserv.tcl (muserv): Propagate the auto_path into the
+ subprocess so that it is able to find all packages the server
+ might require. Without that the server will need an installed
+ tcllib, for example. This fixes a hang in the pop3 testsuite
+ when tcllib is not installed.
+
+2003-04-09 Andreas Kupries <andreask@activestate.com>
+
+ * New module.
+ * First contents are support for sub-processes in testsuites.
diff --git a/tcllib/modules/devtools/README b/tcllib/modules/devtools/README
new file mode 100644
index 0000000..ba9857f
--- /dev/null
+++ b/tcllib/modules/devtools/README
@@ -0,0 +1,22 @@
+
+Right now this module only contains code to make the handling of sub
+processes from within a testsuite easier in general and of minimal
+protocol server especially. Things which are not directly within in
+the scope of the package "tcltest".
+
+The initial name for the module was 'testsupport'. This was changed to
+'devtools' to allow the collection other code here too. Like for
+example the generation of TEA 2 compatible configure scripts and
+Makefiles.
+
+For now the contents are considered internal to tcllib and are neither
+listed in the main makefile, nor do they have a package index file. So
+even if the module and its code gets installed it won't be useable
+without jumping through some hoops.
+
+The code is used in some of the tcllib testsuites.
+Currently: "comm", and "pop3".
+
+These certificates have been created with SimpleCA,
+see http://wiki.tcl.tk/11419
+and http://users.skynet.be/ballet/joris/SimpleCA/
diff --git a/tcllib/modules/devtools/ca.crt b/tcllib/modules/devtools/ca.crt
new file mode 100644
index 0000000..28a3705
--- /dev/null
+++ b/tcllib/modules/devtools/ca.crt
@@ -0,0 +1,17 @@
+-----BEGIN CERTIFICATE-----
+MIICtDCCAh2gAwIBAgIJAKWjOP4GKWjhMA0GCSqGSIb3DQEBBAUAMIGBMQswCQYD
+VQQGEwJDQTELMAkGA1UECBMCQkMxEjAQBgNVBAcTCVZhbmNvdXZlcjEMMAoGA1UE
+ChMDVENBMQ8wDQYDVQQLEwZUY2xsaWIxFzAVBgNVBAMTDlRjbGxpYiBSb290IENB
+MRkwFwYJKoZIhvcNAQkBFgp0Y2xsaWJAdGNhMB4XDTEzMDEyMTIxNDUyOFoXDTIz
+MDEyOTIxNDUyOFowgYExCzAJBgNVBAYTAkNBMQswCQYDVQQIEwJCQzESMBAGA1UE
+BxMJVmFuY291dmVyMQwwCgYDVQQKEwNUQ0ExDzANBgNVBAsTBlRjbGxpYjEXMBUG
+A1UEAxMOVGNsbGliIFJvb3QgQ0ExGTAXBgkqhkiG9w0BCQEWCnRjbGxpYkB0Y2Ew
+gZ8wDQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBALda0hrGvGLuaLICFkkwiz0AvDqK
+fFsc1nNw4A9FcQ8cpA2SMeoKLyBLANLxrn99eboSCvW+XADZ8u7uwPU2/rnLmqaZ
+mGZXA2jCKMVK6yxvbXvw2oYQGUN3xYhSQtEaYOoGrjn1HpkMpDJmx4TCCwMpwZmh
+I95MCZtwvnSEGJQvAgMBAAGjMjAwMA8GA1UdEwEB/wQFMAMBAf8wHQYDVR0OBBYE
+FCHaYPrHbeAAAjyHQIo1129sS+ElMA0GCSqGSIb3DQEBBAUAA4GBAEMba535SbVo
+wZRim/hZbH97WoWNvGA+GuEyiVvae4TQaOpFVAOxwU/l0K6qXumIs8XTCdUh9T6P
+T3TOxzVL7wHRQf8QR7buZEGooss/3Nw9lZmSJbfuxg2z0qG8r6FqhnDmNK0yimBt
+VmuLWF+l8gb0lBYCEZdP0AMGT6UdE5J8
+-----END CERTIFICATE-----
diff --git a/tcllib/modules/devtools/ca.key b/tcllib/modules/devtools/ca.key
new file mode 100644
index 0000000..99b1460
--- /dev/null
+++ b/tcllib/modules/devtools/ca.key
@@ -0,0 +1,18 @@
+-----BEGIN RSA PRIVATE KEY-----
+Proc-Type: 4,ENCRYPTED
+DEK-Info: DES-EDE3-CBC,DD33F28636691816
+
+3NQhYUEuaz6bTuf3NsjybmwqfTFPdlBsX2FAn/p7lCQdbAOtSjQbcs1aC2eohfb6
+s9o7GRMMJXOH8tMr5BueSl4fBoXalsumDU0WVt/gg2vfC4js+vbgxjV6/lqhrvE2
+E442GQIQUlcO9Zs7nGATuBGWxhgW9zCZys+lTYlU33751fGIaTlIECwuxWJ/rLdJ
+73MeRNH1Qi9pcPCuRmK/oOZsH0jAlMiLLrAzLx/VOB5e8cip14rjGyxh8M3a//Fv
+GIO4fUD6++1FQJLl39dNNVAjCsaVCyT/R82fBrhYD/JZrh/rLGD96UyIwr9AE/PW
+XySZ2YoUvwImQGdQxLSnE0x+MtxPwt5iNXr586jB2Wz1G8fjYPNDz4tUkM/8iUVi
+I/Pn8JyErul9AVZqQkSCoytrmqajMO9xZAym+R8qgvqkQuSZL2MwPgNZRJ5H01kC
+Z1xRw2jNobSOPyBEG03TOBpXHKayzpIdqEx7ZUuG2FLa1uTicmVnwyuE6jQCgMo3
+wTNrLCzeNJgNggk4XaSzMqy1zAltBx/Q3aPbrspKt1JvAboFu/+TJBwfi/Gk+MT1
+RBWUB6d/4YsnW+6mx/68TlL9TVDnvSzkW8/EW/JrCL5mAJYjN4c5/0++Qu/8g6d/
+icy7g4gz0JaEN7s0jh6lPWlYC+2cj9d3vB3uY2j+9KsUqOalr4jhSZ8sidh7T3OA
+iuQGIgrnZQgU6tZa0MeTct/zxBup4r1sfpyuYYWatkD0QTejH4rzKASWAQD81mOs
+0wzxdS10/kCjzXrh/5EDq5B1wiD506/PpRXej/l8oxHqhNE338YlSQ==
+-----END RSA PRIVATE KEY-----
diff --git a/tcllib/modules/devtools/ca.key.password b/tcllib/modules/devtools/ca.key.password
new file mode 100644
index 0000000..faddeb7
--- /dev/null
+++ b/tcllib/modules/devtools/ca.key.password
@@ -0,0 +1 @@
+tcllib-devel
diff --git a/tcllib/modules/devtools/coserv.tcl b/tcllib/modules/devtools/coserv.tcl
new file mode 100644
index 0000000..2b051e4
--- /dev/null
+++ b/tcllib/modules/devtools/coserv.tcl
@@ -0,0 +1,128 @@
+# -*- tcl -*-
+# CoServ - Comm Server
+# Copyright (c) 2004, Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# ### ### ### ######### ######### #########
+## Commands to create server processes ready to talk to their parent
+## via 'comm'. They assume that the 'tcltest' environment is present
+## without having to load it explicitly. We do load 'comm' explicitly.
+
+## Can assume that tcltest is present, and its commands imported into
+## the global namespace.
+
+# ### ### ### ######### ######### #########
+## Load "comm" into the master.
+
+namespace eval ::coserv {variable subcode {}}
+
+package forget comm
+catch {namespace delete comm}
+
+if {[package vsatisfies [package present Tcl] 8.5]} {
+ set ::coserv::snitsrc [file join [file dirname [file dirname [info script]]] snit snit2.tcl]
+} else {
+ set ::coserv::snitsrc [file join [file dirname [file dirname [info script]]] snit snit.tcl]
+}
+set ::coserv::commsrc [file join [file dirname [file dirname [info script]]] comm comm.tcl]
+
+if {[catch {source $::coserv::snitsrc} msg]} {
+ puts "Error loading \"snit\": $msg"
+ error ""
+}
+if {[catch {source $::coserv::commsrc} msg]} {
+ puts "Error loading \"comm\": $msg"
+ error ""
+}
+
+package require comm
+
+puts "- coserv (comm server)"
+#puts "Main @ [::comm::comm self]"
+
+# ### ### ### ######### ######### #########
+## Core of all sub processes.
+
+proc ::coserv::setup {} {
+ variable subcode
+ if {$subcode != {}} return
+ set subcode [::tcltest::makeFile {
+ #puts "Subshell is \"[info nameofexecutable]\""
+ catch {wm withdraw .}
+
+ # ### ### ### ######### ######### #########
+ ## Get main configuration data out of the command line, i.e.
+ ## - Id of the main process for sending information back.
+ ## - Path to the sources of comm.
+
+ foreach {snitsrc commsrc main cookie} $argv break
+
+ # ### ### ### ######### ######### #########
+ ## Load and initialize "comm" in the sub process. The latter
+ ## includes a report to main that we are ready.
+
+ source $snitsrc
+ source $commsrc
+ ::comm::comm send $main [list ::coserv::ready $cookie [::comm::comm self]]
+
+ # ### ### ### ######### ######### #########
+ ## Now wait for scripts sent by main for execution in sub.
+
+ #comm::comm debug 1
+ vwait forever
+
+ # ### ### ### ######### ######### #########
+ exit
+ } coserv.sub] ; # {}
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Command used by sub processes to signal that they are ready.
+
+proc ::coserv::ready {cookie id} {
+ #puts "Sub server @ $id\t\[$cookie\]"
+ set ::coserv::go $id
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Start a new sub server process, talk to it.
+
+proc ::coserv::start {cookie} {
+ variable subcode
+ variable snitsrc
+ variable commsrc
+ variable go
+
+ set go {}
+
+ setup
+ exec [info nameofexecutable] $subcode \
+ $snitsrc $commsrc [::comm::comm self] $cookie &
+
+ #puts "Waiting for sub server to boot"
+ vwait ::coserv::go
+
+ # We return the id of the server
+ return $::coserv::go
+}
+
+proc ::coserv::run {id script} {
+ return [comm::comm send $id $script]
+}
+
+proc ::coserv::task {id script} {
+ comm::comm send -async $id $script
+ return
+}
+
+proc ::coserv::shutdown {id} {
+ variable subcode
+ #puts "Sub server @ $id\tShutting down ..."
+ task $id exit
+ tcltest::removeFile $subcode
+ set subcode {}
+ return
+}
+
+# ### ### ### ######### ######### #########
diff --git a/tcllib/modules/devtools/dialog.tcl b/tcllib/modules/devtools/dialog.tcl
new file mode 100644
index 0000000..01fd790
--- /dev/null
+++ b/tcllib/modules/devtools/dialog.tcl
@@ -0,0 +1,346 @@
+# -*- tcl -*-
+# Dialog - Dialog Demon (Server, or Client)
+# Copyright (c) 2004, Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+puts "- dialog (coserv-based)"
+
+# ### ### ### ######### ######### #########
+## Commands on top of a plain comm server.
+## Assumes that the comm server environment
+## is present. Provides set up and execution
+## of a fixed linear dialog, done from the
+# perspective of a server application.
+
+# ### ### ### ######### ######### #########
+## Load "comm" into the master.
+
+namespace eval ::dialog {
+ variable dtrace {}
+}
+
+# ### ### ### ######### ######### #########
+## Start a new dialog server.
+
+proc ::dialog::setup {type cookie {ssl 0}} {
+ variable id
+ variable port
+
+ switch -- $type {
+ server {set server 1}
+ client {set server 0}
+ default {return -code error "Bad dialog type \"$type\", expected server, or client"}
+ }
+
+ set id [::coserv::start "$type: $cookie"]
+ ::coserv::run $id {
+ set responses {}
+ set strace {}
+ set received {}
+ set conn {}
+ set ilog {}
+
+ proc Log {text} {
+ global ilog ; lappend ilog $text
+ }
+ proc Strace {text} {
+ global strace ; lappend strace $text
+ }
+ proc Exit {sock reason} {
+ Strace $reason
+ Log [list $reason $sock]
+ close $sock
+ Done
+ }
+ proc Done {} {
+ global main strace ilog
+ comm::comm send $main [list dialog::done [list $strace $ilog]]
+ return
+ }
+ proc ClearTraces {} {
+ global strace ; set strace {}
+ global ilog ; set ilog {}
+ return
+ }
+ proc Step {sock} {
+ global responses trace
+
+ if {![llength $responses]} {
+ Exit $sock empty
+ return
+ }
+
+ set now [lindex $responses 0]
+ set responses [lrange $responses 1 end]
+
+ Log [list ** $sock $now]
+ eval [linsert $now end $sock]
+ return
+ }
+
+ # Step commands ...
+
+ proc .Crlf {sock} {
+ Strace crlf
+ Log crlf
+ fconfigure $sock -translation crlf
+ Step $sock
+ return
+ }
+ proc .Binary {sock} {
+ Strace bin
+ Log binary
+ fconfigure $sock -translation binary
+ Step $sock
+ return
+ }
+ proc .HaltKeep {sock} {
+ Log halt.keep
+ Done
+ global responses
+ set responses {}
+ # No further stepping.
+ # This keeps the socket open.
+ # Needs external reset/cleanup
+ return
+ }
+ proc .Send {line sock} {
+ Strace [list >> $line]
+ Log [list >> $line]
+
+ if {[catch {
+ puts $sock $line
+ flush $sock
+ } msg]} {
+ Exit $sock broken
+ return
+ }
+ Step $sock
+ return
+ }
+ proc .Geval {script sock} {
+ Log geval
+ uplevel #0 $script
+ Step $sock
+ return
+ }
+ proc .Eval {script sock} {
+ Log eval
+ eval $script
+ Step $sock
+ return
+ }
+ proc .SendGvar {vname sock} {
+ upvar #0 $vname line
+ .Send $line $sock
+ return
+ }
+ proc .Receive {sock} {
+ set aid [after 10000 [list Timeout $sock]]
+ fileevent $sock readable [list Input $aid $sock]
+ # No "Step" here. Comes through input.
+ Log " Waiting \[$aid\]"
+ return
+ }
+ proc Input {aid sock} {
+ global received
+ if {[eof $sock]} {
+ # Clean the timer up
+ after cancel $aid
+ Exit $sock close
+ return
+ }
+ if {[gets $sock line] < 0} {
+ Log " **|////|**"
+ return
+ }
+
+ Log "-- -v-"
+ Log " Events off \[$aid, $sock\]"
+ fileevent $sock readable {}
+ after cancel $aid
+
+ Strace [list << $line]
+ Log [list << $line]
+ lappend received $line
+
+ # Now we can step further
+ Step $sock
+ return
+ }
+ proc Timeout {sock} {
+ Exit $sock timeout
+ return
+ }
+ proc Accept {sock host port} {
+ fconfigure $sock -blocking 0
+ ClearTraces
+ Step $sock
+ return
+ }
+
+ proc Server {} {
+ global port
+ # Start listener for dialog
+ set listener [socket -server Accept 0]
+ set port [lindex [fconfigure $listener -sockname] 2]
+ # implied return of <port>
+ }
+
+ proc Client {port} {
+ global conn
+ catch {close $conn}
+
+ set conn [set sock [socket localhost $port]]
+ fconfigure $sock -blocking 0
+ ClearTraces
+ Log [list Client @ $port = $sock]
+ Log [list Channels $port = [lsort [file channels]]]
+ Step $sock
+ return
+ }
+ }
+
+ if {$ssl} {
+ # Replace various commands with tls aware variants
+ coserv::run $id [list set devtools [tcllibPath devtools]]
+ coserv::run $id {
+ package require tls
+
+ tls::init \
+ -keyfile $devtools/transmitter.key \
+ -certfile $devtools/transmitter.crt \
+ -cafile $devtools/ca.crt \
+ -ssl2 1 \
+ -ssl3 1 \
+ -tls1 0 \
+ -require 1
+
+ proc Server {} {
+ global port
+ # Start listener for dialog
+ set listener [tls::socket -server Accept 0]
+ set port [lindex [fconfigure $listener -sockname] 2]
+ # implied return of <port>
+ }
+
+ proc Client {port} {
+ global conn
+ catch {close $conn}
+
+ set conn [set sock [tls::socket localhost $port]]
+ fconfigure $sock -blocking 0
+ ClearTraces
+ Log [list Client @ $port = $sock]
+ Log [list Channels $port = [lsort [file channels]]]
+ Step $sock
+ return
+ }
+ }
+ }
+
+ if {$server} {
+ set port [coserv::run $id {Server}]
+ }
+}
+
+proc ::dialog::runclient {port} {
+ variable id
+ variable dtrace {}
+ coserv::task $id [list Client $port]
+ return
+}
+
+proc ::dialog::dialog_set {response_script} {
+ begin
+ uplevel 1 $response_script
+ end
+ return
+}
+
+proc ::dialog::begin {{cookie {}}} {
+ variable id
+ ::coserv::task $id [list set responses {}]
+ log::log debug "+============================================ $cookie \\\\"
+ return
+}
+
+proc ::dialog::cmd {command} {
+ variable id
+ ::coserv::task $id [list lappend responses $command]
+ return
+}
+
+proc ::dialog::end {} {
+ # This implicitly waits for all preceding commands (which are async) to complete.
+ variable id
+ set responses [::coserv::run $id [list set responses]]
+ ::coserv::run $id {set received {}}
+ log::log debug |\t[join $responses \n|\t]
+ log::log debug +---------------------------------------------
+ return
+}
+
+proc ::dialog::crlf. {} {cmd .Crlf}
+proc ::dialog::binary. {} {cmd .Binary}
+proc ::dialog::send. {line} {cmd [list .Send $line]}
+proc ::dialog::receive. {} {cmd .Receive}
+proc ::dialog::respond. {line} {receive. ; send. $line}
+proc ::dialog::request. {line} {send. $line ; receive.}
+proc ::dialog::halt.keep. {} {cmd .HaltKeep}
+proc ::dialog::sendgvar. {vname} {cmd [list .SendGvar $vname]}
+proc ::dialog::reqgvar. {vname} {sendgvar. $vname ; receive.}
+proc ::dialog::geval. {script} {cmd [list .Geval $script]}
+proc ::dialog::eval. {script} {cmd [list .Eval $script]}
+
+proc ::dialog::done {traces} {
+ variable dtrace $traces
+ return
+}
+
+proc ::dialog::waitdone {} {
+ variable dtrace
+
+ # Loop until we have data from the dialog subprocess.
+ # IOW writes which do not create data are ignored.
+ while {![llength $dtrace]} {
+ vwait ::dialog::dtrace
+ }
+
+ foreach {strace ilog} $dtrace break
+ set dtrace {}
+
+ log::log debug +---------------------------------------------
+ log::log debug |\t[join $strace \n|\t]
+ log::log debug +---------------------------------------------
+ log::log debug /\t[join $ilog \n/\t]
+ log::log debug "+============================================ //"
+ return $strace
+}
+
+proc ::dialog::received {} {
+ # Wait for all preceding commands to complete.
+ variable id
+ set received [::coserv::run $id [list set received]]
+ ::coserv::run $id [list set received {}]
+ return $received
+}
+
+proc ::dialog::listener {} {
+ variable port
+ return $port
+}
+
+proc ::dialog::shutdown {} {
+ variable id
+ variable port
+ variable dtrace
+
+ ::coserv::shutdown $id
+
+ set id {}
+ set port {}
+ set dtrace {}
+ return
+}
+
+# ### ### ### ######### ######### #########
diff --git a/tcllib/modules/devtools/receiver.crt b/tcllib/modules/devtools/receiver.crt
new file mode 100644
index 0000000..80c4e59
--- /dev/null
+++ b/tcllib/modules/devtools/receiver.crt
@@ -0,0 +1,18 @@
+-----BEGIN CERTIFICATE-----
+MIIC4TCCAkqgAwIBAgICEAEwDQYJKoZIhvcNAQEEBQAwgYExCzAJBgNVBAYTAkNB
+MQswCQYDVQQIEwJCQzESMBAGA1UEBxMJVmFuY291dmVyMQwwCgYDVQQKEwNUQ0Ex
+DzANBgNVBAsTBlRjbGxpYjEXMBUGA1UEAxMOVGNsbGliIFJvb3QgQ0ExGTAXBgkq
+hkiG9w0BCQEWCnRjbGxpYkB0Y2EwHhcNMTMwMTIxMjE0NzAyWhcNMjMwMTE5MjE0
+NzAyWjCBgDELMAkGA1UEBhMCQ0ExCzAJBgNVBAgTAkJDMRIwEAYDVQQHEwlWYW5j
+b3V2ZXIxDDAKBgNVBAoTA1RDQTEPMA0GA1UECxMGVGNsbGliMREwDwYDVQQDEwhS
+ZWNlaXZlcjEeMBwGCSqGSIb3DQEJARYPcmVjZWl2ZXJAdGNsbGliMIGfMA0GCSqG
+SIb3DQEBAQUAA4GNADCBiQKBgQDLjgsEvpLz8n2lumW8BrQ0mhnC5sAPSAhEUP5O
+L+ePAt7j0r3gxYMQV+LkCHQIHOIcI5COoaG1kvc0EzX085ESgX2ksOeRCZ4c9mOY
+cGbXfXlk3WGbzONPVUoI8OrrlggD4Xm5nRlg7RPsATzf4qxty5t3sH0XGzGYeyto
+grvgkQIDAQABo2cwZTAfBgNVHSMEGDAWgBQh2mD6x23gAAI8h0CKNddvbEvhJTA0
+BgNVHSUELTArBggrBgEFBQcDAQYIKwYBBQUHAwIGCisGAQQBgjcKAwMGCWCGSAGG
++EIEATAMBgNVHRMBAf8EAjAAMA0GCSqGSIb3DQEBBAUAA4GBAE8ZtGhrr36XSQvM
+e3bKS5NtiDd5EdNlbYJmx6y7mGYYev5NShXtY/Zj6B2Zs/Cb5gdxKJowHHLtjFpJ
+L/7TMkuDGmXfZJOfoDo5kuJpRy6Cl0340fwhdFftMUV36COzgttvZRBoareT5ix0
+L+C7CHTyjD7J+FM8EYS09G/v5J7/
+-----END CERTIFICATE-----
diff --git a/tcllib/modules/devtools/receiver.key b/tcllib/modules/devtools/receiver.key
new file mode 100644
index 0000000..353e69a
--- /dev/null
+++ b/tcllib/modules/devtools/receiver.key
@@ -0,0 +1,15 @@
+-----BEGIN RSA PRIVATE KEY-----
+MIICXAIBAAKBgQDLjgsEvpLz8n2lumW8BrQ0mhnC5sAPSAhEUP5OL+ePAt7j0r3g
+xYMQV+LkCHQIHOIcI5COoaG1kvc0EzX085ESgX2ksOeRCZ4c9mOYcGbXfXlk3WGb
+zONPVUoI8OrrlggD4Xm5nRlg7RPsATzf4qxty5t3sH0XGzGYeytogrvgkQIDAQAB
+AoGAS+WmjhpQyMy9tLGPhVAqmQJsYJORQSFmk7JvX8/U0yoK2X+WdNywRcO/Qa81
+NGEwnbVVDRmPJhiqO6x+DdtTV5zZBMECXbPpoRCno6rN1y66OflD0reW1EWkjDAs
+BTZJ6jkMBYb/+A9hrO6rs9vOQSOuX78bv1EG9NzSR0kdlMECQQDngjy25H0G4s04
+/WIQ6ZxiqfF1dRoyr1qdsZ4SAEw81pr5EppkxOBmCxlFuTO19flb6vHV7ufAJ7PR
+ChtFblQVAkEA4RbA66XPbfl9JC+QfGNavMKJXqTZJhvcndtc8104HHszJ3Jo0O8P
+GK3tVrmpf3QmjkkbOxxYNIuyQTU/YAiNjQJAb8vUxf1Q4yJjOEIkOUaW3o5yq+YA
+4LkNaVl8m/TI3BhGfkEdjcwFEUIK0kC9WAGQiXLLliPohkKl8yyOPtkogQJAc/vv
+iP21tyt56m1//DiOBvoPIu+63UI6GjVw3g5I3ZQ2Nbtke1TT6Jmm1KtyxbQqMeNF
+3t2qLdlWDvfLIkcF+QJBAJGyZC3Zym+BrLn8OJ6ceCt/lPp/baKzz883r2xoUCiF
+HaJXRhbT563GYTBzFPgTmJO9AnVJBMkMM+Bt2R40JHk=
+-----END RSA PRIVATE KEY-----
diff --git a/tcllib/modules/devtools/testutilities.tcl b/tcllib/modules/devtools/testutilities.tcl
new file mode 100644
index 0000000..f8f4ab1
--- /dev/null
+++ b/tcllib/modules/devtools/testutilities.tcl
@@ -0,0 +1,722 @@
+# -*- tcl -*-
+# Testsuite utilities / boilerplate
+# Copyright (c) 2006, Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+namespace eval ::tcllib::testutils {
+ variable self [file dirname [file join [pwd] [info script]]]
+ variable tcllib [file dirname $self]
+ variable tag ""
+ variable theEnv ; # Saved environment.
+}
+
+# ### ### ### ######### ######### #########
+## Commands for common functions and boilerplate actions required by
+## many testsuites of Tcllib modules and packages in a central place
+## for easier maintenance.
+
+# ### ### ### ######### ######### #########
+## Declare the minimal version of Tcl required to run the package
+## tested by this testsuite, and its dependencies.
+
+proc testsNeedTcl {version} {
+ # This command ensures that a minimum version of Tcl is used to
+ # run the tests in the calling testsuite. If the minimum is not
+ # met by the active interpreter we forcibly bail out of the
+ # testsuite calling the command. The command has to be called
+ # immediately after loading the utilities.
+
+ if {[package vsatisfies [package provide Tcl] $version]} return
+
+ puts " Aborting the tests found in \"[file tail [info script]]\""
+ puts " Requiring at least Tcl $version, have [package present Tcl]."
+
+ # This causes a 'return' in the calling scope.
+ return -code return
+}
+
+# ### ### ### ######### ######### #########
+## Declare the minimum version of Tcltest required to run the
+## testsuite.
+
+proc testsNeedTcltest {version} {
+ # This command ensure that a minimum version of the Tcltest
+ # support package is used to run the tests in the calling
+ # testsuite. If the minimum is not met by the loaded package we
+ # forcibly bail out of the testsuite calling the command. The
+ # command has to be called after loading the utilities. The only
+ # command allowed to come before it is 'testNeedTcl' above.
+
+ # Note that this command will try to load a suitable version of
+ # Tcltest if the package has not been loaded yet.
+
+ if {[lsearch [namespace children] ::tcltest] == -1} {
+ if {![catch {
+ package require tcltest $version
+ }]} {
+ namespace import -force ::tcltest::*
+ InitializeTclTest
+ return
+ }
+ } elseif {[package vcompare [package present tcltest] $version] >= 0} {
+ InitializeTclTest
+ return
+ }
+
+ puts " Aborting the tests found in [file tail [info script]]."
+ puts " Requiring at least tcltest $version, have [package present tcltest]"
+
+ # This causes a 'return' in the calling scope.
+ return -code return
+}
+
+proc testsNeed {name version} {
+ # This command ensures that a minimum version of package <name> is
+ # used to run the tests in the calling testsuite. If the minimum
+ # is not met by the active interpreter we forcibly bail out of the
+ # testsuite calling the command. The command has to be called
+ # immediately after loading the utilities.
+
+ if {[catch {
+ package require $name $version
+ }]} {
+ puts " Aborting the tests found in \"[file tail [info script]]\""
+ puts " Requiring at least $name $version, package not found."
+
+ return -code return
+ }
+
+ if {[package vsatisfies [package present $name] $version]} return
+
+ puts " Aborting the tests found in \"[file tail [info script]]\""
+ puts " Requiring at least $name $version, have [package present $name]."
+
+ # This causes a 'return' in the calling scope.
+ return -code return
+}
+
+# ### ### ### ######### ######### #########
+
+## Save/restore the environment, for testsuites which have to
+## manipulate it to (1) either achieve the effects they test
+## for/against, or (2) to shield themselves against manipulation by
+## the environment. We have examples for both in 'fileutil' (1), and
+## 'doctools' (2).
+##
+## Saving is done automatically at the beginning of a test file,
+## through this module. Restoration is done semi-automatically. We
+## __cannot__ hook into the tcltest cleanup hook It is already used by
+## all.tcl to transfer the information from the slave doing the actual
+## tests to the master. Here the hook is only an alias, and
+## unmodifiable. We create a new cleanup command which runs both our
+## environment cleanup, and the regular one. All .test files are
+## modified to use the new cleanup.
+
+proc ::tcllib::testutils::SaveEnvironment {} {
+ global env
+ variable theEnv [array get env]
+ return
+}
+
+proc ::tcllib::testutils::RestoreEnvironment {} {
+ global env
+ variable theEnv
+ foreach k [array names env] {
+ unset env($k)
+ }
+ array set env $theEnv
+ return
+}
+
+proc testsuiteCleanup {} {
+ ::tcllib::testutils::RestoreEnvironment
+ ::tcltest::cleanupTests
+ return
+}
+
+proc array_unset {a {pattern *}} {
+ upvar 1 $a array
+ foreach k [array names array $pattern] {
+ unset array($k)
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Newer versions of the Tcltest support package for testsuite provide
+## various features which make the creation and maintenance of
+## testsuites much easier. I consider it important to have these
+## features even if an older version of Tcltest is loaded. To this end
+## we now provide emulations and implementations, conditional on the
+## version of Tcltest found to be active.
+
+# ### ### ### ######### ######### #########
+## Easy definition and initialization of test constraints.
+
+proc InitializeTclTest {} {
+ global tcltestinit
+ if {[info exists tcltestinit] && $tcltestinit} return
+ set tcltestinit 1
+
+ if {![package vsatisfies [package provide tcltest] 2.0]} {
+ # Tcltest 2.0+ provides a documented public API to define and
+ # initialize a test constraint. For earlier versions of the
+ # package the user has to directly set a non-public undocumented
+ # variable in the package's namespace. We create a command doing
+ # this and emulating the public API.
+
+ proc ::tcltest::testConstraint {c args} {
+ variable testConstraints
+ if {[llength $args] < 1} {
+ if {[info exists testConstraints($c)]} {
+ return $testConstraints($c)
+ } else {
+ return {}
+ }
+ } else {
+ set testConstraints($c) [lindex $args 0]
+ }
+ return
+ }
+
+ namespace eval ::tcltest {
+ namespace export testConstraint
+ }
+ uplevel \#0 {namespace import -force ::tcltest::*}
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Define a set of standard constraints
+
+ ::tcltest::testConstraint tcl8.3only \
+ [expr {![package vsatisfies [package provide Tcl] 8.4]}]
+
+ ::tcltest::testConstraint tcl8.3plus \
+ [expr {[package vsatisfies [package provide Tcl] 8.3]}]
+
+ ::tcltest::testConstraint tcl8.4plus \
+ [expr {[package vsatisfies [package provide Tcl] 8.4]}]
+
+ ::tcltest::testConstraint tcl8.5plus \
+ [expr {[package vsatisfies [package provide Tcl] 8.5]}]
+
+ ::tcltest::testConstraint tcl8.6plus \
+ [expr {[package vsatisfies [package provide Tcl] 8.6]}]
+
+ ::tcltest::testConstraint tcl8.4minus \
+ [expr {![package vsatisfies [package provide Tcl] 8.5]}]
+
+ ::tcltest::testConstraint tcl8.5minus \
+ [expr {![package vsatisfies [package provide Tcl] 8.6]}]
+
+ # ### ### ### ######### ######### #########
+ ## Cross-version code for the generation of the error messages created
+ ## by Tcl procedures when called with the wrong number of arguments,
+ ## either too many, or not enough.
+
+ if {[package vsatisfies [package provide Tcl] 8.6]} {
+ # 8.6+
+ proc ::tcltest::wrongNumArgs {functionName argList missingIndex} {
+ if {[string match args [lindex $argList end]]} {
+ set argList [lreplace $argList end end ?arg ...?]
+ }
+ if {$argList != {}} {set argList " $argList"}
+ set msg "wrong # args: should be \"$functionName$argList\""
+ return $msg
+ }
+
+ proc ::tcltest::tooManyArgs {functionName argList} {
+ # create a different message for functions with no args
+ if {[llength $argList]} {
+ if {[string match args [lindex $argList end]]} {
+ set argList [lreplace $argList end end ?arg ...?]
+ }
+ set msg "wrong # args: should be \"$functionName $argList\""
+ } else {
+ set msg "wrong # args: should be \"$functionName\""
+ }
+ return $msg
+ }
+ } elseif {[package vsatisfies [package provide Tcl] 8.5]} {
+ # 8.5
+ proc ::tcltest::wrongNumArgs {functionName argList missingIndex} {
+ if {[string match args [lindex $argList end]]} {
+ set argList [lreplace $argList end end ...]
+ }
+ if {$argList != {}} {set argList " $argList"}
+ set msg "wrong # args: should be \"$functionName$argList\""
+ return $msg
+ }
+
+ proc ::tcltest::tooManyArgs {functionName argList} {
+ # create a different message for functions with no args
+ if {[llength $argList]} {
+ if {[string match args [lindex $argList end]]} {
+ set argList [lreplace $argList end end ...]
+ }
+ set msg "wrong # args: should be \"$functionName $argList\""
+ } else {
+ set msg "wrong # args: should be \"$functionName\""
+ }
+ return $msg
+ }
+ } elseif {[package vsatisfies [package provide Tcl] 8.4]} {
+ # 8.4+
+ proc ::tcltest::wrongNumArgs {functionName argList missingIndex} {
+ if {$argList != {}} {set argList " $argList"}
+ set msg "wrong # args: should be \"$functionName$argList\""
+ return $msg
+ }
+
+ proc ::tcltest::tooManyArgs {functionName argList} {
+ # create a different message for functions with no args
+ if {[llength $argList]} {
+ set msg "wrong # args: should be \"$functionName $argList\""
+ } else {
+ set msg "wrong # args: should be \"$functionName\""
+ }
+ return $msg
+ }
+ } else {
+ # 8.2+
+ proc ::tcltest::wrongNumArgs {functionName argList missingIndex} {
+ set msg "no value given for parameter "
+ append msg "\"[lindex $argList $missingIndex]\" to "
+ append msg "\"$functionName\""
+ return $msg
+ }
+
+ proc ::tcltest::tooManyArgs {functionName argList} {
+ set msg "called \"$functionName\" with too many arguments"
+ return $msg
+ }
+ }
+
+ # ### ### ### ######### ######### #########
+ ## tclTest::makeFile result API changed for 2.0
+
+ if {![package vsatisfies [package provide tcltest] 2.0]} {
+
+ # The 'makeFile' in Tcltest 1.0 returns a list of all the
+ # paths generated so far, whereas the 'makeFile' in 2.0+
+ # returns only the path of the newly generated file. We
+ # standardize on the more useful behaviour of 2.0+. If 1.x is
+ # present we have to create an emulation layer to get the
+ # wanted result.
+
+ # 1.0 is not fully correctly described. If the file was
+ # created before no list is returned at all. We force things
+ # by adding a line to the old procedure which makes the result
+ # unconditional (the name of the file/dir created).
+
+ # The same change applies to 'makeDirectory'
+
+ if {![llength [info commands ::tcltest::makeFile_1]]} {
+ # Marker first.
+ proc ::tcltest::makeFile_1 {args} {}
+
+ # Extend procedures with command to return the required
+ # full name.
+ proc ::tcltest::makeFile {contents name} \
+ [info body ::tcltest::makeFile]\n[list set fullName]
+
+ proc ::tcltest::makeDirectory {name} \
+ [info body ::tcltest::makeDirectory]\n[list set fullName]
+
+ # Re-export
+ namespace eval ::tcltest {
+ namespace export makeFile makeDirectory
+ }
+ uplevel \#0 {namespace import -force ::tcltest::*}
+ }
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Extended functionality, creation of binary temp. files.
+ ## Also creation of paths for temp. files
+
+ proc ::tcltest::makeBinaryFile {data f} {
+ set path [makeFile {} $f]
+ set ch [open $path w]
+ fconfigure $ch -translation binary
+ puts -nonewline $ch $data
+ close $ch
+ return $path
+ }
+
+ proc ::tcltest::tempPath {path} {
+ variable temporaryDirectory
+ return [file join $temporaryDirectory $path]
+ }
+
+ namespace eval ::tcltest {
+ namespace export wrongNumArgs tooManyArgs
+ namespace export makeBinaryFile tempPath
+ }
+ uplevel \#0 {namespace import -force ::tcltest::*}
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Command to construct wrong/args messages for Snit methods.
+
+proc snitErrors {} {
+ if {[package vsatisfies [package provide snit] 2]} {
+ # Snit 2.0+
+
+ proc snitWrongNumArgs {obj method arglist missingIndex} {
+ regsub {^.*Snit_method} $method {} method
+ tcltest::wrongNumArgs "$obj $method" $arglist $missingIndex
+ }
+
+ proc snitTooManyArgs {obj method arglist} {
+ regsub {^.*Snit_method} $method {} method
+ tcltest::tooManyArgs "$obj $method" $arglist
+ }
+
+ } else {
+ proc snitWrongNumArgs {obj method arglist missingIndex} {
+ incr missingIndex 4
+ tcltest::wrongNumArgs "$method" [linsert $arglist 0 \
+ type selfns win self] $missingIndex
+ }
+
+ proc snitTooManyArgs {obj method arglist} {
+ tcltest::tooManyArgs "$method" [linsert $arglist 0 \
+ type selfns win self]
+ }
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Commands to load files from various locations within the local
+## Tcllib, and the loading of local Tcllib packages. None of them goes
+## through the auto-loader, nor the regular package management, to
+## avoid contamination of the testsuite by packages and code outside
+## of the Tcllib under test.
+
+proc localPath {fname} {
+ return [file join $::tcltest::testsDirectory $fname]
+}
+
+proc tcllibPath {fname} {
+ return [file join $::tcllib::testutils::tcllib $fname]
+}
+
+proc useLocalFile {fname} {
+ return [uplevel 1 [list source [localPath $fname]]]
+}
+
+proc useTcllibFile {fname} {
+ return [uplevel 1 [list source [tcllibPath $fname]]]
+}
+
+proc use {fname pname args} {
+ set nsname ::$pname
+ if {[llength $args]} {set nsname [lindex $args 0]}
+
+ package forget $pname
+ catch {namespace delete $nsname}
+
+ if {[catch {
+ uplevel 1 [list useTcllibFile $fname]
+ } msg]} {
+ puts " Aborting the tests found in \"[file tail [info script]]\""
+ puts " Error in [file tail $fname]: $msg"
+ return -code error ""
+ }
+
+ puts "$::tcllib::testutils::tag [list $pname] [package present $pname]"
+ return
+}
+
+proc useKeep {fname pname args} {
+ set nsname ::$pname
+ if {[llength $args]} {set nsname [lindex $args 0]}
+
+ package forget $pname
+
+ # Keep = Keep the existing namespace of the package.
+ # = Do not delete it. This is required if the
+ # namespace contains commands created by a
+ # binary package, like 'tcllibc'. They cannot
+ # be re-created.
+ ##
+ ## catch {namespace delete $nsname}
+
+ if {[catch {
+ uplevel 1 [list useTcllibFile $fname]
+ } msg]} {
+ puts " Aborting the tests found in \"[file tail [info script]]\""
+ puts " Error in [file tail $fname]: $msg"
+ return -code error ""
+ }
+
+ puts "$::tcllib::testutils::tag [list $pname] [package present $pname]"
+ return
+}
+
+proc useLocal {fname pname args} {
+ set nsname ::$pname
+ if {[llength $args]} {set nsname [lindex $args 0]}
+
+ package forget $pname
+ catch {namespace delete $nsname}
+
+ if {[catch {
+ uplevel 1 [list useLocalFile $fname]
+ } msg]} {
+ puts " Aborting the tests found in \"[file tail [info script]]\""
+ puts " Error in [file tail $fname]: $msg"
+ return -code error ""
+ }
+
+ puts "$::tcllib::testutils::tag [list $pname] [package present $pname]"
+ return
+}
+
+proc useLocalKeep {fname pname args} {
+ set nsname ::$pname
+ if {[llength $args]} {set nsname [lindex $args 0]}
+
+ package forget $pname
+
+ # Keep = Keep the existing namespace of the package.
+ # = Do not delete it. This is required if the
+ # namespace contains commands created by a
+ # binary package, like 'tcllibc'. They cannot
+ # be re-created.
+ ##
+ ## catch {namespace delete $nsname}
+
+ if {[catch {
+ uplevel 1 [list useLocalFile $fname]
+ } msg]} {
+ puts " Aborting the tests found in \"[file tail [info script]]\""
+ puts " Error in [file tail $fname]: $msg"
+ return -code error ""
+ }
+
+ puts "$::tcllib::testutils::tag [list $pname] [package present $pname]"
+ return
+}
+
+proc useAccel {acc fname pname args} {
+ set use [expr {$acc ? "useKeep" : "use"}]
+ uplevel 1 [linsert $args 0 $use $fname $pname]
+}
+
+proc support {script} {
+ InitializeTclTest
+ set ::tcllib::testutils::tag "-"
+ if {[catch {
+ uplevel 1 $script
+ } msg]} {
+ set prefix "SETUP Error (Support): "
+ puts $prefix[join [split $::errorInfo \n] "\n$prefix"]
+
+ return -code return
+ }
+ return
+}
+
+proc testing {script} {
+ InitializeTclTest
+ set ::tcllib::testutils::tag "*"
+ if {[catch {
+ uplevel 1 $script
+ } msg]} {
+ set prefix "SETUP Error (Testing): "
+ puts $prefix[join [split $::errorInfo \n] "\n$prefix"]
+
+ return -code return
+ }
+ return
+}
+
+proc useTcllibC {} {
+ set index [tcllibPath tcllibc/pkgIndex.tcl]
+ if {![file exists $index]} {
+ # Might have an external tcllibc
+ if {![catch {
+ package require tcllibc
+ }]} {
+ puts "$::tcllib::testutils::tag tcllibc [package present tcllibc]"
+ puts "$::tcllib::testutils::tag tcllibc = [package ifneeded tcllibc [package present tcllibc]]"
+ return 1
+ }
+
+ return 0
+ }
+
+ set ::dir [file dirname $index]
+ uplevel #0 [list source $index]
+ unset ::dir
+
+ package require tcllibc
+
+ puts "$::tcllib::testutils::tag tcllibc [package present tcllibc]"
+ puts "$::tcllib::testutils::tag tcllibc = [package ifneeded tcllibc [package present tcllibc]]"
+ return 1
+}
+
+# ### ### ### ######### ######### #########
+## General utilities
+
+# - dictsort -
+#
+# Sort a dictionary by its keys. I.e. reorder the contents of the
+# dictionary so that in its list representation the keys are found in
+# ascending alphabetical order. In other words, this command creates
+# a canonical list representation of the input dictionary, suitable
+# for direct comparison.
+#
+# Arguments:
+# dict: The dictionary to sort.
+#
+# Result:
+# The canonical representation of the dictionary.
+
+proc dictsort {dict} {
+ array set a $dict
+ set out [list]
+ foreach key [lsort [array names a]] {
+ lappend out $key $a($key)
+ }
+ return $out
+}
+
+# ### ### ### ######### ######### #########
+## Putting strings together, if they cannot be expressed easily as one
+## string due to quoting problems.
+
+proc cat {args} {
+ return [join $args ""]
+}
+
+# ### ### ### ######### ######### #########
+## Mini-logging facility, can also be viewed as an accumulator for
+## complex results.
+#
+# res! : clear accumulator.
+# res+ : add arguments to accumulator.
+# res? : query contents of accumulator.
+# res?lines : query accumulator and format as
+# multiple lines, one per list element.
+
+proc res! {} {
+ variable result {}
+ return
+}
+
+proc res+ {args} {
+ variable result
+ lappend result $args
+ return
+}
+
+proc res? {} {
+ variable result
+ return $result
+}
+
+proc res?lines {} {
+ return [join [res?] \n]
+}
+
+# ### ### ### ######### ######### #########
+## Helper commands to deal with packages
+## which have multiple implementations, i.e.
+## their pure Tcl base line and one or more
+## accelerators. We are assuming a specific
+## API for accessing the data about available
+## accelerators, switching between them, etc.
+
+# == Assumed API ==
+#
+# KnownImplementations --
+# Returns list of all known implementations.
+#
+# Implementations --
+# Returns list of activated implementations.
+# A subset of 'KnownImplementations'
+#
+# Names --
+# Returns dict mapping all known implementations
+# to human-readable strings for output during a
+# test run
+#
+# LoadAccelerator accel --
+# Tries to make the implementation named
+# 'accel' available for use. Result is boolean.
+# True indicates a successful activation.
+#
+# SwitchTo accel --
+# Activate the implementation named 'accel'.
+# The empty string disables all implementations.
+
+proc TestAccelInit {namespace} {
+ # Disable all implementations ... Base state.
+ ${namespace}::SwitchTo {}
+
+ # List the implementations.
+ array set map [${namespace}::Names]
+ foreach e [${namespace}::KnownImplementations] {
+ if {[${namespace}::LoadAccelerator $e]} {
+ puts "> $map($e)"
+ }
+ }
+ return
+}
+
+proc TestAccelDo {namespace var script} {
+ upvar 1 $var impl
+ foreach impl [${namespace}::Implementations] {
+ ${namespace}::SwitchTo $impl
+ uplevel 1 $script
+ }
+ return
+}
+
+proc TestAccelExit {namespace} {
+ # Reset the system to a fully inactive state.
+ ${namespace}::SwitchTo {}
+ return
+}
+
+# ### ### ### ######### ######### #########
+##
+
+proc TestFiles {pattern} {
+ if {[package vsatisfies [package provide Tcl] 8.3]} {
+ # 8.3+ -directory ok
+ set flist [glob -nocomplain -directory $::tcltest::testsDirectory $pattern]
+ } else {
+ # 8.2 or less, no -directory
+ set flist [glob -nocomplain [file join $::tcltest::testsDirectory $pattern]]
+ }
+ foreach f [lsort -dict $flist] {
+ uplevel 1 [list source $f]
+ }
+ return
+}
+
+proc TestFilesGlob {pattern} {
+ if {[package vsatisfies [package provide Tcl] 8.3]} {
+ # 8.3+ -directory ok
+ set flist [glob -nocomplain -directory $::tcltest::testsDirectory $pattern]
+ } else {
+ # 8.2 or less, no -directory
+ set flist [glob -nocomplain [file join $::tcltest::testsDirectory $pattern]]
+ }
+ return [lsort -dict $flist]
+}
+
+# ### ### ### ######### ######### #########
+##
+
+::tcllib::testutils::SaveEnvironment
+
+# ### ### ### ######### ######### #########
+package provide tcllib::testutils 1.2
+puts "- tcllib::testutils [package present tcllib::testutils]"
+return
diff --git a/tcllib/modules/devtools/transmitter.crt b/tcllib/modules/devtools/transmitter.crt
new file mode 100644
index 0000000..69c5027
--- /dev/null
+++ b/tcllib/modules/devtools/transmitter.crt
@@ -0,0 +1,18 @@
+-----BEGIN CERTIFICATE-----
+MIIC5zCCAlCgAwIBAgICEAAwDQYJKoZIhvcNAQEEBQAwgYExCzAJBgNVBAYTAkNB
+MQswCQYDVQQIEwJCQzESMBAGA1UEBxMJVmFuY291dmVyMQwwCgYDVQQKEwNUQ0Ex
+DzANBgNVBAsTBlRjbGxpYjEXMBUGA1UEAxMOVGNsbGliIFJvb3QgQ0ExGTAXBgkq
+hkiG9w0BCQEWCnRjbGxpYkB0Y2EwHhcNMTMwMTIxMjE0NjUxWhcNMjMwMTE5MjE0
+NjUxWjCBhjELMAkGA1UEBhMCQ0ExCzAJBgNVBAgTAkJDMRIwEAYDVQQHEwlWYW5j
+b3V2ZXIxDDAKBgNVBAoTA1RDQTEPMA0GA1UECxMGVGNsbGliMRQwEgYDVQQDEwtU
+cmFuc21pdHRlcjEhMB8GCSqGSIb3DQEJARYSdHJhbnNtaXR0ZXJAdGNsbGliMIGf
+MA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQC3jpcKzCWtt5sKSHDXO34jO2G+DfbY
+OGrgPu/YaqzUxVxsFSyK56jBNa1GldVA+fOVO8KDX5UOc8KKlz+AhGq5YceGQ4Cj
+WTK3YHUeVOeBqszqphG2D5vlvFf2dqIUZ4N8a+Ah+5gwtCwBo7gPA+PxJFaTWRtG
+0nN4lWTLjeF9uwIDAQABo2cwZTAfBgNVHSMEGDAWgBQh2mD6x23gAAI8h0CKNddv
+bEvhJTA0BgNVHSUELTArBggrBgEFBQcDAQYIKwYBBQUHAwIGCisGAQQBgjcKAwMG
+CWCGSAGG+EIEATAMBgNVHRMBAf8EAjAAMA0GCSqGSIb3DQEBBAUAA4GBAA9Ec5V0
+wQCOSr2wz2qzWOQlw2KGtBCJaM/vckt5YJmpHIkp9cVP/tlHPG9qzG9VfQs4nOKa
+wUjZ8xVt6kKA8gWbBm3mFSsI2JhT/q77FCWoMC56d7cLqqU6D2fmC1ksNMljhJ5n
+UNgvspAEL5Txryh9VRYNRUZGjowquXXYUWht
+-----END CERTIFICATE-----
diff --git a/tcllib/modules/devtools/transmitter.key b/tcllib/modules/devtools/transmitter.key
new file mode 100644
index 0000000..164db5d
--- /dev/null
+++ b/tcllib/modules/devtools/transmitter.key
@@ -0,0 +1,15 @@
+-----BEGIN RSA PRIVATE KEY-----
+MIICXAIBAAKBgQC3jpcKzCWtt5sKSHDXO34jO2G+DfbYOGrgPu/YaqzUxVxsFSyK
+56jBNa1GldVA+fOVO8KDX5UOc8KKlz+AhGq5YceGQ4CjWTK3YHUeVOeBqszqphG2
+D5vlvFf2dqIUZ4N8a+Ah+5gwtCwBo7gPA+PxJFaTWRtG0nN4lWTLjeF9uwIDAQAB
+AoGAQlTp6kH5v7wg7+dbt7vNCmhUGv0q3doNbTnxLJDoIf+sNXa1YQD0L9X45xAQ
+P2nUB3LQCO+Kiu10OOcNUKEJe5WuIKGnD3BZkwyGOngJibYI8D0KXfqQRK9z2cgV
+GfsFXa5Dv1fK7vOM+zBVEJxmcsOqlHO6h8quwhRd7Kuu+/ECQQDjCTVgWgTt1Gq2
+1ph0iLns1LJbz8RPtM+7FgD1wUvixB5ItTTP5dI8j2o7dUb/ylGHnUNG4FruFGS5
+FHFgi1rDAkEAzvllogyGGsMgKLaxZHNiwQsUU8j0PI3y2EX0udLOVSvjDePbzg00
+GYx0rFM+pQUE12TQaIsykp0YCuGDB7vxqQJAKQw8K0x7Qai7Fo2cCM3Dl88o5DKf
+Uq3lNPUYfVZSaxB8TTb98myh4zMmyNM+X/brYLKNPF5J8mubfl701Li9UwJAcgo8
+k5Mu+OP2fjhbeauSCCegpaGd4RedbMju1MxwX8F0s5yO6fOgd0tKpgCgDbC8QCoO
+Iuw/i0T/kE89MS+/MQJBANIMifrdikFda4M8eGjRA/ekvZ0UD8ELgOs8eIBJZkvX
+1EAdlgtFAKvNW3dzu8uPRODQ1pKZoQSnOrMhe+sqzdo=
+-----END RSA PRIVATE KEY-----
diff --git a/tcllib/modules/dicttool/dicttool.man b/tcllib/modules/dicttool/dicttool.man
new file mode 100644
index 0000000..676d8f5
--- /dev/null
+++ b/tcllib/modules/dicttool/dicttool.man
@@ -0,0 +1,76 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin dicttool n 1.0]
+[keywords dict]
+[copyright {2015 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] \ No newline at end of file
diff --git a/tcllib/modules/dicttool/dicttool.md b/tcllib/modules/dicttool/dicttool.md
new file mode 100644
index 0000000..4b49ef4
--- /dev/null
+++ b/tcllib/modules/dicttool/dicttool.md
@@ -0,0 +1,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>
diff --git a/tcllib/modules/dicttool/dicttool.tcl b/tcllib/modules/dicttool/dicttool.tcl
new file mode 100644
index 0000000..f2caff3
--- /dev/null
+++ b/tcllib/modules/dicttool/dicttool.tcl
@@ -0,0 +1,146 @@
+###
+# 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]
+}
+
+package provide dicttool 1.0 \ No newline at end of file
diff --git a/tcllib/modules/dicttool/pkgIndex.tcl b/tcllib/modules/dicttool/pkgIndex.tcl
new file mode 100644
index 0000000..38da627
--- /dev/null
+++ b/tcllib/modules/dicttool/pkgIndex.tcl
@@ -0,0 +1,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.0 [list source [file join $dir dicttool.tcl]]
diff --git a/tcllib/modules/dns/ChangeLog b/tcllib/modules/dns/ChangeLog
new file mode 100644
index 0000000..01f57c0
--- /dev/null
+++ b/tcllib/modules/dns/ChangeLog
@@ -0,0 +1,385 @@
+2013-07-26 Andreas Kupries <andreask@activestate.com>
+
+ * ip.tcl: [AS Bug 99728]: Fixed version mismatch code vs package
+ index. Bug introduced by last change, below.
+
+2013-03-25 Andreas Kupries <andreask@activestate.com>
+
+ * ip.tcl: [Bug 3608943] Check ip::version for empty input and
+ * ip.test: react properly. Extended testsuite. Bumped version
+ * pkgIndex.tcl: to 1.2.1.
+ * tcllib_ip.man:
+
+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-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-08-16 Andreas Kupries <andreask@activestate.com>
+
+ * ip.tcl: Added new commands 'collapse' and 'subtract' for
+ * ip.test: more 'arithmetic' on network ranges. Extended
+ * pkgIndex.tcl: documentation and testsuite. Version bumped
+ * tcllib_ip.man: to 1.2. Base code by Roy Keene, with thanks.
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-04-13 Andreas Kupries <andreask@activestate.com>
+
+ * ip.tcl (::ip::IPv4?, ::ip::version): Corrected check for colons
+ * tcllib_ip.man: (wrong order of arguments), and moved this check,
+ * pkgIndex.tcl: a speed optimization from the look of it, into the
+ main IPv4 test to be used everywhere. Bumped the package version
+ to 1.1.3. Fixes [Bug 2123397].
+
+2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11.1 ========================
+ *
+
+2008-11-22 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * dns.tcl: Fixed typo in flags for errorcode decoding
+
+2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11 ========================
+ *
+
+2008-03-14 Andreas Kupries <andreask@activestate.com>
+
+ * spf.tcl (::spf::_exists): Fixed bad use of 'return', reported in
+ * pkgIndex.tcl: [SF Tcllib Bug 1826418], by Erik Leunissen. Bumped
+ to version 1.1.1.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-26 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * dns.tcl: Applied patch #1610330 from Sergei Golovan to provide
+ asynchronous connection for dns over tcp.
+
+2007-08-25 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * tcllib_dns.man: Documented the -loglevel configure option.
+
+2007-08-22 Andreas Kupries <andreask@activestate.com>
+
+ * spf.test: Added proper requisites to the testsuite.
+
+2007-08-20 Andreas Kupries <andreask@activestate.com>
+
+ * tcllib_ip.man: Bumped version to 1.1.2 due to the bugfix made
+ * ip.tcl: by the last change.
+ * pkgIndex.tcl:
+
+2007-07-05 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * ip.tcl: bug #1739359 - reject domain names that look like
+ * ip.test: ipv4 addresses
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tcllib_ip.man: Fixed all warnings due to use of now deprecated
+ * tcllib_dns.man: commands. Added a section about how to give feedback.
+
+2006-11-04 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * ipMoreC.tcl: Silence critcl warning.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * tcllib_ip.man: Bumped version to 1.1.1
+ * ip.tcl:
+ * pkgIndex.tcl:
+
+2006-05-05 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * dns.tcl: Extended the nameservers command to work on Win9x
+ systems and we now make use of this to initially configure a
+ default nameserver. Some minor additional cleanup.
+
+2006-04-21 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * dns.tcl: Fixed bug #1158037. We were using the query id to
+ locate the DNS state token but this restricts us to 65535 queries
+ as the value is packed into a short.
+
+2006-04-20 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * dns.tcl: Applied patch from #1453327 by Segei Golovan to improve
+ support for TXT records.
+
+2006-01-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * spf.test: Fixed use of duplicate test names.
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dns.test: More boilerplate simplified via use of test support.
+ * ip.test:
+ * ipMore.test:
+ * spf.test:
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dns.test: Hooked into the new common test support code.
+ * ip.test:
+ * ipMore.test:
+ * spf.test
+
+2005-10-21 Andreas Kupries <andreask@activestate.com>
+
+ * ipMore.tcl: Style cleanup. We need only one $Id expansion at
+ the top of the file, not for every command in it.
+
+2005-10-18 Andreas Kupries <andreask@activestate.com>
+
+ * ipMore.tcl (::ip::maskToInt): Fixed [SF Tcllib Bug 1323146],
+ using the patch supplied by Mikhail Teterin
+ <kot@users.sf.net>. One path through the code did not mask the
+ data down to 32bit.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-10-04 Andreas Kupries <andreask@activestate.com>
+
+ * ipMoreC.tcl: disabling the new critcl parts of ip for the
+ platforms it is known to not work for. A better solution will be
+ worked on after the release.
+
+2005-09-30 Andreas Kupries <andreask@activestate.com>
+
+ * ipMore.test: Integrated Aamer Akhter's extended
+ * ipMore.tcl: conversion and manipulation commands
+ * ipMoreC.tcl: for ip-addresses and -masks. See the
+ * msmgs/en.msg: [SF Tcllib Patch 1260196]. Extended the
+ * ip.man: documentation, testsuite, critcl setup.
+
+2005-05-21 Pat Thoyts <pat@zsplat.freeserve.co.uk>
+
+ * dns.tcl: Added support for ceptcl as well as tcludp for udp
+ support.
+
+2005-05-06 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * ip.tcl: Added some support for acceping RFC3056 6to4 addresses
+ * ip.test: of the form 2002:<ipv4 address>::/48
+
+2005-04-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dns.tcl (TcpEvent): Fixed [SF Tcllib Bug 1173444]. The cause was
+ a series of typos, the procedure argument 'token' was referenced
+ to in the code via 'tok'.
+
+2004-11-21 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * dns.tcl: Fixed bug in ReadUShort.
+
+ * dns.tcl: Incremented the version to 1.2.1 and updated the
+ * ip.tcl: manual.
+
+ * dns.tcl: Added support for RFC2782 (DNS SRV) which provides
+ for service discovery via DNS.
+ Added dns::nameservers command to return the list
+ of nameservers configured -- this is not
+ necessarily all that reliable but should be useful.
+ Implemented for Windows and Unix.
+
+ * ip.tcl: Added an error message to deal with invalid address
+ formats during normalization.
+
+2004-11-06 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * ip.tcl: Bug #1060460 - support for IPv4 in IPv6-style
+ addresses in ip::normalize.
+
+2004-10-19 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * dns.tcl: Applied fix for bug #1018934 "incorrectly
+ detecting query as a reverse lookup"
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-07-31 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * spf.test: Added lots of macro tests and fixed some bugs
+ * spf.tcl: that this revealed.
+
+2004-07-30 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * spf.tcl: Updated to draft-ietf-marid-protocol-00 document.
+ * spf.test: Fully implements section 7 macro expansion.
+
+2004-07-23 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * spf.tcl: Use ip package and implemented IPv6 type.
+
+ * dns.tcl: Added support for IPv6 lookups (type AAAA).
+
+ * ip.tcl: NEW: IP address package
+ * ip.test: tests (ipv4 and ipv6)
+ * tcllib_ip.man: Manual page
+
+2004-06-01 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * spf.tcl: NEW: Implementation of SPF using our dns package.
+ * spf.test: NEW: tests for SPF package.
+ * pkgIndex.tcl: Updated to include SPF.
+
+ * dns-url.txt: Updated the dns-url document to -09 version. This
+ implementation is still valid so no changes to the uri code.
+
+2004-05-26 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * dns.tcl: Fix issue setting the log level properly.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-01-22 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * dns.tcl: Added automatic recognition of reverse lookups (where
+ query is 1.2.3.4). These are converted to in-addr.arpa lookups.
+ Added a dns::result to return the whole decoded answer record.
+ Added SPF record type (an alias for TXT).
+ Incremented package version to 1.0.5
+
+2003-07-09 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * dns.tcl: Added decoding for SOA response records.
+
+2003-05-09 Andreas Kupries <andreask@activestate.com>
+
+ * resolv.tcl (::resolv::init): Added missing [expr] bracing.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-14 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * dns.tcl: Added error message to the timeout.
+ * resolv.tcl: incorporated some of Emmanuel's updated code.
+
+2003-04-12 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * dns.man: *Renamed* to tcllib_dns.man to avoid a name clash with
+ the dns manpage from the scotty package.
+
+2003-04-11 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * dns.tcl: Try to read the whole reply when using tcp. Added a
+ catch to avoid bgerrors within the handler.
+ * dns.tcl:
+ * dns.man:
+ * pkgIndex.tcl: hiked version to 1.0.4
+
+2003-04-11 Andreas Kupries <andreask@pliers.activestate.com>
+
+ * dns.tcl:
+ * dns.man:
+ * pkgIndex.tcl: Fixed bug #614591. Set version of the package to
+ to 1.0.3 throughout. Added package 'resolv' to index.
+
+2003-03-04 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * dns.tcl: converted from the log package to logger. Enable UDP as
+ the default if available.
+
+2003-02-27 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * resolv.tcl: Imported Emmanuel Frecon's code from the Tclers
+ Wiki. Provides a name cache and simplifies usage of the dns
+ package.
+
+2003-02-25 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * dns.tcl: Tested the UDP transmission using a fixed TclUDP.
+ * dns.tcl: Implemented inverse queries. (Pretty useless though).
+ * dns.tcl: Added errorcode procedure.
+
+2003-01-30 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * dns.tcl: Implemented UDP transmission. Currently not tested
+ because tcludp doesn't handle binary data.
+
+2003-01-24 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * pkgIndex.tcl:
+ * dns.man: Added Tcl 8.2 as minimum Tcl version to resolve bug
+ * dns.tcl: #674330. Upped version to 1.0.2
+ * dns.test: Added some tests for the dns uri handling and fixed a
+ bug in decoding the class and type section.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dns.man: More semantic markup, less visual one.
+
+2002-08-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dns.tcl: Updated 'info exist' to 'info exists'.
+
+2002-06-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dns.man:
+ * dns.tcl:
+ * pkgIndex.tcl: Version up to 1.0.1
+
+ * dns.tcl: moved var initialization code to the end, as it uses
+ the 'dns::configure' command, and thus should be called after
+ its definition. This is the reason for bug #564670, thus now
+ fixed.
+
+2002-06-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dns.man: Added note to manpage regarding DNS via TCP and
+ possible pitfalls.
diff --git a/tcllib/modules/dns/dns-url.txt b/tcllib/modules/dns/dns-url.txt
new file mode 100644
index 0000000..bed51f5
--- /dev/null
+++ b/tcllib/modules/dns/dns-url.txt
@@ -0,0 +1,728 @@
+
+
+Network Working Group S. Josefsson
+Internet-Draft October 26, 2003
+Expires: April 25, 2004
+
+
+ Domain Name System Uniform Resource Identifiers
+ draft-josefsson-dns-url-09
+
+Status of this Memo
+
+ This document is an Internet-Draft and is in full conformance with
+ all provisions of Section 10 of RFC2026.
+
+ Internet-Drafts are working documents of the Internet Engineering
+ Task Force (IETF), its areas, and its working groups. Note that other
+ groups may also distribute working documents as Internet-Drafts.
+
+ Internet-Drafts are draft documents valid for a maximum of six months
+ and may be updated, replaced, or obsoleted by other documents at any
+ time. It is inappropriate to use Internet-Drafts as reference
+ material or to cite them other than as "work in progress."
+
+ The list of current Internet-Drafts can be accessed at http://
+ www.ietf.org/ietf/1id-abstracts.txt.
+
+ The list of Internet-Draft Shadow Directories can be accessed at
+ http://www.ietf.org/shadow.html.
+
+ This Internet-Draft will expire on April 25, 2004.
+
+Copyright Notice
+
+ Copyright (C) The Internet Society (2003). All Rights Reserved.
+
+Abstract
+
+ This document define Uniform Resource Identifiers for Domain Name
+ System resources.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Josefsson Expires April 25, 2004 [Page 1]
+
+Internet-Draft DNS URI October 2003
+
+
+Table of Contents
+
+ 1. Introduction and Background . . . . . . . . . . . . . . . . . 3
+ 2. DNS URI Registration . . . . . . . . . . . . . . . . . . . . . 4
+ 3. Examples . . . . . . . . . . . . . . . . . . . . . . . . . . . 7
+ 4. Security Considerations . . . . . . . . . . . . . . . . . . . 8
+ 5. IANA Considerations . . . . . . . . . . . . . . . . . . . . . 8
+ Normative References . . . . . . . . . . . . . . . . . . . . . 9
+ Informative References . . . . . . . . . . . . . . . . . . . . 9
+ Author's Address . . . . . . . . . . . . . . . . . . . . . . . 10
+ A. Revision Changes . . . . . . . . . . . . . . . . . . . . . . . 10
+ A.1 Changes since -06 . . . . . . . . . . . . . . . . . . . . . . 10
+ A.2 Changes since -07 . . . . . . . . . . . . . . . . . . . . . . 10
+ A.3 Changes since -08 . . . . . . . . . . . . . . . . . . . . . . 10
+ Intellectual Property and Copyright Statements . . . . . . . . 12
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Josefsson Expires April 25, 2004 [Page 2]
+
+Internet-Draft DNS URI October 2003
+
+
+1. Introduction and Background
+
+ The Domain Name System (DNS) [1][2] is a widely deployed system used
+ to, among other things, translate host names into IP addresses.
+ Recent work has added support for storing certificates and
+ certificate revocation lists in the DNS [10].
+
+ The primary motivation behind defining a Uniform Resource Identifier
+ (URI) for DNS resources, instead of using another non-URI syntax that
+ embed the domain, type value and class value, is that applications
+ that stores or retrieve certificates today uses URIs for this
+ purpose. Thus, defining a URI scheme for DNS resources allows these
+ existing protocols to be used with certificates in the DNS without
+ having to add DNS specific modifications to said protocols. In order
+ to not introduce interoperability or security considerations,
+ protocols that uses these URIs naturally must have been written to
+ allow for future, as of writing yet undefined, URIs to be used.
+
+ A few examples of protocols that may utilize DNS URIs:
+
+ o The OpenPGP Message Format [8], where an end-user may indicate the
+ location of a copy of any updates to her key, using the "preferred
+ key server" field.
+
+ o The X.509 Online Certificate Status Protocol [11], where the OCSP
+ responder can indicate where a CRL is found, using the
+ id-pkix-ocsp-crl extension.
+
+ The DNS URI scheme defined here can, of course, be used to reference
+ any DNS data, and is not limited to only certificates. The purpose
+ of this specification is to define a generic DNS URI, not a specific
+ DNS solution for certificates stored in the DNS. Browsers may
+ implement support for DNS URIs by forming DNS queries and render DNS
+ responses using HTML [14], similar to what is done for the FTP [5].
+
+ The core part of this document is the URI Registration Template
+ according to [13].
+
+ The key words "MUST", "MUST NOT", "REQUIRED", "SHALL", "SHALL NOT",
+ "SHOULD", "SHOULD NOT", "RECOMMENDED", "MAY", and "OPTIONAL" in this
+ document are to be interpreted as described in RFC 2119 [6].
+
+
+
+
+
+
+
+
+
+
+Josefsson Expires April 25, 2004 [Page 3]
+
+Internet-Draft DNS URI October 2003
+
+
+2. DNS URI Registration
+
+ URL scheme name: "dns".
+
+ URL scheme syntax: A DNS URI designates a DNS resource record set
+ that can be referenced by domain name, type, class and optionally the
+ authority. The DNS URI follows the generic syntax from RFC 2396 [4],
+ and is described using ABNF [3]. Strings are not case sensitive and
+ free insertion of linear-white-space is not permitted.
+
+ dnsurl = "dns:" [ "//" dnsauthority "/" ] dnsname ["?" dnsquery]
+
+ dnsauthority = hostport
+ ; See RFC 2396 for "hostport" definition.
+
+ dnsname = *pchar
+ ; See RFC 2396 for "pchar" definition.
+ ; NB! Can be empty.
+
+ dnsquery = dnsqueryelement [";" dnsquery]
+ ; First matching element MUST be used.
+ ; E.g., dns:host.example.org?TYPE=A;TYPE=TXT
+ ; means type A.
+
+ dnsqueryelement = ( "CLASS=" dnsclassval ) / ( "TYPE=" dnstypeval ) /
+ ( 1*alphanum "=" 1*alphanum )
+
+ dnsclassval = 1*digit / "IN" / "CH" / ...
+ ; Any IANA registered DNS class expressed as
+ ; mnemonic or as decimal integer.
+
+ dnstypeval = 1*digit / "A" / "NS" / "MD" / ...
+ ; Any IANA registered DNS type expressed as
+ ; mnemonic or as decimal integer.
+
+ The digit representation of types and classes MAY be used when a
+ mnemonic for the corresponding value is not well known (e.g., for
+ newly introduced types or classes), but SHOULD NOT be used for the
+ types or classes defined in the DNS specification [2]. All
+ implementations MUST recognize the mnemonics defined in [2].
+
+ Unless specified in the URI, the authority ("dnsauthority") is
+ assumed to be locally known, "dnsclassval" to be the Internet class
+ ("IN"), and "dnstypeval" to be the Address type ("A").
+
+ To resolve a DNS URI using the DNS protocol [2] a query is formed by
+ using the dnsname, dnsclassval and dnstypeval from the URI string (or
+ the previously mentioned default values if some value missing from
+
+
+
+Josefsson Expires April 25, 2004 [Page 4]
+
+Internet-Draft DNS URI October 2003
+
+
+ the string). If authority ("dnsauthority") is given in the URI
+ string, this indicate the server that should receive the DNS query,
+ otherwise the default DNS server should receive it. (Note that DNS
+ URIs could be resolved by other protocols than the DNS protocol. DNS
+ URIs does not require the use of the DNS protocol, although it is
+ expected to be the typical usage. This paragraph only illustrate how
+ DNS URIs are resolved using the DNS protocol.)
+
+ A client MAY want to check that it understands the dnsclassval and
+ dnstypeval before sending a query, so that it is able to correctly
+ parse the answer. A typical example of a client that would not need
+ to check dnsclassval and dnstypeval would be a proxy that just treat
+ the answer as opaque data.
+
+ Character encoding considerations: The characters are encoded as per
+ the "URI Generic Syntax" RFC [4]. The DNS protocol do not consider
+ character sets, it simply transports opaque data. In particular, the
+ "dnsname" field of the DNS URI is to be considered an
+ internationalized domain name (IDN) unaware domain name slot, in the
+ terminology of [16]. (The reason for this is that making these fields
+ be IDN aware by, e.g., specifying that they are UTF-8 [7] strings,
+ would require further encoding mechanisms to be able to express all
+ valid DNS domain names. This is because the DNS allows all octet
+ sequences to be used as domain labels, so UTF-8 strings do not cover
+ all possibilities. Instead of defining further encoding mechanisms,
+ we point applications with internationalization needs at the ASCII
+ encoding described in [16] which should be satisfactory.) The
+ considerations for "hostport" are discussed in [4]
+
+ To encode a "." that is part of a DNS label the "escaped" encoding
+ MUST be used, and a label delimiter MUST be encoded as ".". That is,
+ the only way to encode a label delimiter is ".", and the only way to
+ encode a "." as part of label is "%2e". This approach was chosen to
+ minimize the modifications users will have to do when manually
+ translating a domain name string into the URI form.
+
+ This URI specification allows all possible domain names to be encoded
+ (of course following the encoding rules of [4]), however certain
+ applications may restrict the set of valid characters and care should
+ be taken so that invalid characters in these contexts does not cause
+ harm. In particular, host names in the DNS have certain
+ restrictions. It is up to these application to limit this subset,
+ this URI scheme places no restrictions.
+
+ Intended usage: Whenever DNS resources are useful to reference by
+ protocol independent identifiers, often when the data is more
+ important than the access method. Since software in general has
+ coped without this so far, it is not anticipated to be implemented
+
+
+
+Josefsson Expires April 25, 2004 [Page 5]
+
+Internet-Draft DNS URI October 2003
+
+
+ widely, nor migrated to by existing systems, but specific solutions
+ (especially security related) may find this appropriate.
+
+ Applications and/or protocols which use this scheme: Security related
+ software. It may be of interest to auxilliary DNS related software
+ too.
+
+ Interoperability considerations: The data referenced by this URI
+ scheme might be transferred by protocols that are not URI aware (such
+ as the DNS protocol). This is not anticipated to have any serious
+ interoperability impact though.
+
+ Interoperability problems may occur if one entity understands a new
+ DNS type or class mnemonic but another entity do not understand it.
+ This is an interoperability problem for DNS software in general,
+ although it is not a major practical problem as the DNS types and
+ classes are fairly static. To guarantee interoperability
+ implementations could use integers for all mnemonics not defined in
+ [2].
+
+ Interaction with Binary Labels [12], or other extended label types,
+ has not been analyzed. However, they appear to be infrequently used
+ in practice.
+
+ Security considerations: See below.
+
+ Contact: simon@josefsson.org
+
+ Author/Change Controller: simon@josefsson.org
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Josefsson Expires April 25, 2004 [Page 6]
+
+Internet-Draft DNS URI October 2003
+
+
+3. Examples
+
+ A DNS URI is of the following general form. This is intended to
+ illustrate, not define, the scheme.
+
+ dns:[//authority/]domain[?type=TYPE;class=CLASS]
+
+ The following illustrate a URI for a resource with the name
+ "www.example.org", the Internet (IN) class and the Address (A) type:
+
+ dns:www.example.org?class=IN;type=A
+
+ Since the default class is IN, and the default type is A, the same
+ resource can be identified by a shorter URI:
+
+ dns:www.example.org
+
+ The following illustrate a URI for a resource with the name
+ "simon.example.org", for the CERT type, in the Internet (IN) class:
+
+ dns:simon.example.org?type=CERT
+
+ The following illustrate a URI for a resource with the name
+ "ftp.example.org", in the Internet (IN) class and the address (A)
+ type, but from the DNS authority 192.168.1.1 instead of the default
+ authority (i.e., when DNS is used, the query is sent to that server):
+
+ dns://192.168.1.1/ftp.example.org?type=A
+
+ The following illustrate a strange, albeit valid, DNS resource. Note
+ the encoding of "." and 0x00, and the use of a named dnsauthority:
+
+ dns://internal-dns.example.org/*.%3f%20%00%2e%25+?type=TXT
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Josefsson Expires April 25, 2004 [Page 7]
+
+Internet-Draft DNS URI October 2003
+
+
+4. Security Considerations
+
+ If a DNS URI references domains in the Internet DNS environment, both
+ the URI itself and the information referenced by the URI is public
+ information. If a DNS URI is used within an "internal" DNS
+ environment, both the DNS URI and the data is referenced should be
+ handled using the same considerations that apply to DNS data in the
+ environment.
+
+ If information referenced by DNS URIs are used to make security
+ decisions (examples of such data include, but is not limited to,
+ certificates stored in the DNS), implementations may need to employ
+ security techniques such as Secure DNS [9], or even CMS [15] or
+ OpenPGP [8], to protect the data during transport. How to implement
+ this will depend on the usage scenario, and it is not up to this URI
+ scheme to define how the data referenced by DNS URIs should be
+ protected.
+
+ If applications accept unknown dnsqueryelement values (e.g., accepts
+ the URI "dns:www.example.org?secret=value" without knowing what the
+ "secret=value" dnsqueryelement means), a covert channel used to
+ "leak" information may be enabled. The implications of covert
+ channels should be understood by applications that accepts unknown
+ dnsqueryelement values.
+
+ This draft does not modify the security considerations related to the
+ DNS or URIs in general.
+
+5. IANA Considerations
+
+ The IANA is asked to register the DNS URI scheme, using the template
+ in section 2, in accordance with RFC 2717 [13].
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Josefsson Expires April 25, 2004 [Page 8]
+
+Internet-Draft DNS URI October 2003
+
+
+Acknowledgments
+
+ Thanks to Stuart Cheshire, Donald Eastlake, Pasi Eronen, Ted Hardie,
+ Peter Koch, Andrew Main, Larry Masinter, Michael Mealling, Steve
+ Mattson, and Paul Vixie for comments and suggestions. The author
+ acknowledges the RSA Laboratories for supporting the work that led to
+ this document.
+
+Normative References
+
+ [1] Mockapetris, P., "Domain names - concepts and facilities", STD
+ 13, RFC 1034, November 1987.
+
+ [2] Mockapetris, P., "Domain names - implementation and
+ specification", STD 13, RFC 1035, November 1987.
+
+ [3] Crocker, D. and P. Overell, "Augmented BNF for Syntax
+ Specifications: ABNF", RFC 2234, November 1997.
+
+ [4] Berners-Lee, T., Fielding, R. and L. Masinter, "Uniform Resource
+ Identifiers (URI): Generic Syntax", RFC 2396, August 1998.
+
+Informative References
+
+ [5] Postel, J. and J. Reynolds, "File Transfer Protocol", STD 9,
+ RFC 959, October 1985.
+
+ [6] Bradner, S., "Key words for use in RFCs to Indicate Requirement
+ Levels", BCP 14, RFC 2119, March 1997.
+
+ [7] Yergeau, F., "UTF-8, a transformation format of ISO 10646", RFC
+ 2279, January 1998.
+
+ [8] Callas, J., Donnerhacke, L., Finney, H. and R. Thayer, "OpenPGP
+ Message Format", RFC 2440, November 1998.
+
+ [9] Eastlake, D., "Domain Name System Security Extensions", RFC
+ 2535, March 1999.
+
+ [10] Eastlake, D. and O. Gudmundsson, "Storing Certificates in the
+ Domain Name System (DNS)", RFC 2538, March 1999.
+
+ [11] Myers, M., Ankney, R., Malpani, A., Galperin, S. and C. Adams,
+ "X.509 Internet Public Key Infrastructure Online Certificate
+ Status Protocol - OCSP", RFC 2560, June 1999.
+
+ [12] Crawford, M., "Binary Labels in the Domain Name System", RFC
+ 2673, August 1999.
+
+
+
+Josefsson Expires April 25, 2004 [Page 9]
+
+Internet-Draft DNS URI October 2003
+
+
+ [13] Petke, R. and I. King, "Registration Procedures for URL Scheme
+ Names", BCP 35, RFC 2717, November 1999.
+
+ [14] Connolly, D. and L. Masinter, "The 'text/html' Media Type", RFC
+ 2854, June 2000.
+
+ [15] Housley, R., "Cryptographic Message Syntax (CMS)", RFC 3369,
+ August 2002.
+
+ [16] Faltstrom, P., Hoffman, P. and A. Costello, "Internationalizing
+ Domain Names in Applications (IDNA)", RFC 3490, March 2003.
+
+
+Author's Address
+
+ Simon Josefsson
+
+ EMail: simon@josefsson.org
+
+Appendix A. Revision Changes
+
+ Note to RFC editor: This appendix is to be removed on publication.
+
+A.1 Changes since -06
+
+ The MIME registration templates for text/dns and application/dns was
+ removed, and will be defined in separate documents.
+
+ Improved discussion related to which mnemonics that must be
+ supported. The interoperability problem that provoked the
+ clarification is also mentioned.
+
+ Security consideration improvements.
+
+A.2 Changes since -07
+
+ Author/Change Controller changed to author of this document, not
+ IESG. Terminology section collapsed into introduction. The second
+ paragraph of the introduction rewritten and gives explicit examples.
+ Intended usage and applications fields fixed. Moved this revision
+ tracking information to an appendix. Mention IDN in charset section.
+ All previous thanks to suggestions by Larry Masinter.
+
+A.3 Changes since -08
+
+ Modifications derived from Last-Call comments: Made more clear that
+ DNS URIs does not imply use of the DNS protocol, but the issue is not
+ stressed because of the apparent inflamatory state of affairs. Added
+
+
+
+Josefsson Expires April 25, 2004 [Page 10]
+
+Internet-Draft DNS URI October 2003
+
+
+ informative references to HTML and FTP. Clarified that dnsname can
+ be empty. Clarified that first dnsqueryelement "win" in case of
+ ambiguity. Clarified security consideration with respect to unknown
+ dnsqueryelements. Use "authority" instead of "server". Say "IANA
+ registered" instead of "standard". Interoperability note about binary
+ DNS labels. Typos.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Josefsson Expires April 25, 2004 [Page 11]
+
+Internet-Draft DNS URI October 2003
+
+
+Intellectual Property Statement
+
+ The IETF takes no position regarding the validity or scope of any
+ intellectual property or other rights that might be claimed to
+ pertain to the implementation or use of the technology described in
+ this document or the extent to which any license under such rights
+ might or might not be available; neither does it represent that it
+ has made any effort to identify any such rights. Information on the
+ IETF's procedures with respect to rights in standards-track and
+ standards-related documentation can be found in BCP-11. Copies of
+ claims of rights made available for publication and any assurances of
+ licenses to be made available, or the result of an attempt made to
+ obtain a general license or permission for the use of such
+ proprietary rights by implementors or users of this specification can
+ be obtained from the IETF Secretariat.
+
+ The IETF invites any interested party to bring to its attention any
+ copyrights, patents or patent applications, or other proprietary
+ rights which may cover technology that may be required to practice
+ this standard. Please address the information to the IETF Executive
+ Director.
+
+
+Full Copyright Statement
+
+ Copyright (C) The Internet Society (2003). All Rights Reserved.
+
+ This document and translations of it may be copied and furnished to
+ others, and derivative works that comment on or otherwise explain it
+ or assist in its implementation may be prepared, copied, published
+ and distributed, in whole or in part, without restriction of any
+ kind, provided that the above copyright notice and this paragraph are
+ included on all such copies and derivative works. However, this
+ document itself may not be modified in any way, such as by removing
+ the copyright notice or references to the Internet Society or other
+ Internet organizations, except as needed for the purpose of
+ developing Internet standards in which case the procedures for
+ copyrights defined in the Internet Standards process must be
+ followed, or as required to translate it into languages other than
+ English.
+
+ The limited permissions granted above are perpetual and will not be
+ revoked by the Internet Society or its successors or assignees.
+
+ This document and the information contained herein is provided on an
+ "AS IS" basis and THE INTERNET SOCIETY AND THE INTERNET ENGINEERING
+ TASK FORCE DISCLAIMS ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING
+ BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE INFORMATION
+
+
+
+Josefsson Expires April 25, 2004 [Page 12]
+
+Internet-Draft DNS URI October 2003
+
+
+ HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF
+ MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+
+
+Acknowledgment
+
+ Funding for the RFC Editor function is currently provided by the
+ Internet Society.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Josefsson Expires April 25, 2004 [Page 13]
+
diff --git a/tcllib/modules/dns/dns.tcl b/tcllib/modules/dns/dns.tcl
new file mode 100644
index 0000000..305bd64
--- /dev/null
+++ b/tcllib/modules/dns/dns.tcl
@@ -0,0 +1,1416 @@
+# dns.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Provide a Tcl only Domain Name Service client. See RFC 1034 and RFC 1035
+# for information about the DNS protocol. This should insulate Tcl scripts
+# from problems with using the system library resolver for slow name servers.
+#
+# This implementation uses TCP only for DNS queries. The protocol reccommends
+# that UDP be used in these cases but Tcl does not include UDP sockets by
+# default. The package should be simple to extend to use a TclUDP extension
+# in the future.
+#
+# Support for SPF (http://spf.pobox.com/rfcs.html) will need updating
+# if or when the proposed draft becomes accepted.
+#
+# Support added for RFC1886 - DNS Extensions to support IP version 6
+# Support added for RFC2782 - DNS RR for specifying the location of services
+# Support added for RFC1995 - Incremental Zone Transfer in DNS
+#
+# TODO:
+# - When using tcp we should make better use of the open connection and
+# send multiple queries along the same connection.
+#
+# - We must switch to using TCP for truncated UDP packets.
+#
+# - Read RFC 2136 - dynamic updating of DNS
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.2; # tcl minimum version
+package require logger; # tcllib 1.3
+package require uri; # tcllib 1.1
+package require uri::urn; # tcllib 1.2
+package require ip; # tcllib 1.7
+
+namespace eval ::dns {
+ namespace export configure resolve name address cname \
+ status reset wait cleanup errorcode
+
+ variable options
+ if {![info exists options]} {
+ array set options {
+ port 53
+ timeout 30000
+ protocol tcp
+ search {}
+ nameserver {localhost}
+ loglevel warn
+ }
+ variable log [logger::init dns]
+ ${log}::setlevel $options(loglevel)
+ }
+
+ # We can use either ceptcl or tcludp for UDP support.
+ if {![catch {package require udp 1.0.4} msg]} { ;# tcludp 1.0.4+
+ # If TclUDP 1.0.4 or better is available, use it.
+ set options(protocol) udp
+ } else {
+ if {![catch {package require ceptcl} msg]} {
+ set options(protocol) udp
+ }
+ }
+
+ variable types
+ array set types {
+ A 1 NS 2 MD 3 MF 4 CNAME 5 SOA 6 MB 7 MG 8 MR 9
+ NULL 10 WKS 11 PTR 12 HINFO 13 MINFO 14 MX 15 TXT 16
+ SPF 16 AAAA 28 SRV 33 IXFR 251 AXFR 252 MAILB 253 MAILA 254
+ ANY 255 * 255
+ }
+
+ variable classes
+ array set classes { IN 1 CS 2 CH 3 HS 4 * 255}
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 0
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Configure the DNS package. In particular the local nameserver will need
+# to be set. With no options, returns a list of all current settings.
+#
+proc ::dns::configure {args} {
+ variable options
+ variable log
+
+ if {[llength $args] < 1} {
+ set r {}
+ foreach opt [lsort [array names options]] {
+ lappend r -$opt $options($opt)
+ }
+ return $r
+ }
+
+ set cget 0
+ if {[llength $args] == 1} {
+ set cget 1
+ }
+
+ while {[string match -* [lindex $args 0]]} {
+ switch -glob -- [lindex $args 0] {
+ -n* -
+ -ser* {
+ if {$cget} {
+ return $options(nameserver)
+ } else {
+ set options(nameserver) [Pop args 1]
+ }
+ }
+ -po* {
+ if {$cget} {
+ return $options(port)
+ } else {
+ set options(port) [Pop args 1]
+ }
+ }
+ -ti* {
+ if {$cget} {
+ return $options(timeout)
+ } else {
+ set options(timeout) [Pop args 1]
+ }
+ }
+ -pr* {
+ if {$cget} {
+ return $options(protocol)
+ } else {
+ set proto [string tolower [Pop args 1]]
+ if {[string compare udp $proto] == 0 \
+ && [string compare tcp $proto] == 0} {
+ return -code error "invalid protocol \"$proto\":\
+ protocol must be either \"udp\" or \"tcp\""
+ }
+ set options(protocol) $proto
+ }
+ }
+ -sea* {
+ if {$cget} {
+ return $options(search)
+ } else {
+ set options(search) [Pop args 1]
+ }
+ }
+ -log* {
+ if {$cget} {
+ return $options(loglevel)
+ } else {
+ set options(loglevel) [Pop args 1]
+ ${log}::setlevel $options(loglevel)
+ }
+ }
+ -- { Pop args ; break }
+ default {
+ set opts [join [lsort [array names options]] ", -"]
+ return -code error "bad option [lindex $args 0]:\
+ must be one of -$opts"
+ }
+ }
+ Pop args
+ }
+
+ return
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Create a DNS query and send to the specified name server. Returns a token
+# to be used to obtain any further information about this query.
+#
+proc ::dns::resolve {query args} {
+ variable uid
+ variable options
+ variable log
+
+ # get a guaranteed unique and non-present token id.
+ set id [incr uid]
+ while {[info exists [set token [namespace current]::$id]]} {
+ set id [incr uid]
+ }
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ # Setup token/state defaults.
+ set state(id) $id
+ set state(query) $query
+ set state(qdata) ""
+ set state(opcode) 0; # 0 = query, 1 = inverse query.
+ set state(-type) A; # DNS record type (A address)
+ set state(-class) IN; # IN (internet address space)
+ set state(-recurse) 1; # Recursion Desired
+ set state(-command) {}; # asynchronous handler
+ set state(-timeout) $options(timeout); # connection timeout default.
+ set state(-nameserver) $options(nameserver);# default nameserver
+ set state(-port) $options(port); # default namerservers port
+ set state(-search) $options(search); # domain search list
+ set state(-protocol) $options(protocol); # which protocol udp/tcp
+
+ # Handle DNS URL's
+ if {[string match "dns:*" $query]} {
+ array set URI [uri::split $query]
+ foreach {opt value} [uri::split $query] {
+ if {$value != {} && [info exists state(-$opt)]} {
+ set state(-$opt) $value
+ }
+ }
+ set state(query) $URI(query)
+ ${log}::debug "parsed query: $query"
+ }
+
+ while {[string match -* [lindex $args 0]]} {
+ switch -glob -- [lindex $args 0] {
+ -n* - ns -
+ -ser* { set state(-nameserver) [Pop args 1] }
+ -po* { set state(-port) [Pop args 1] }
+ -ti* { set state(-timeout) [Pop args 1] }
+ -co* { set state(-command) [Pop args 1] }
+ -cl* { set state(-class) [Pop args 1] }
+ -ty* { set state(-type) [Pop args 1] }
+ -pr* { set state(-protocol) [Pop args 1] }
+ -sea* { set state(-search) [Pop args 1] }
+ -re* { set state(-recurse) [Pop args 1] }
+ -inv* { set state(opcode) 1 }
+ -status {set state(opcode) 2}
+ -data { set state(qdata) [Pop args 1] }
+ default {
+ set opts [join [lsort [array names state -*]] ", "]
+ return -code error "bad option [lindex $args 0]: \
+ must be $opts"
+ }
+ }
+ Pop args
+ }
+
+ if {$state(-nameserver) == {}} {
+ return -code error "no nameserver specified"
+ }
+
+ if {$state(-protocol) == "udp"} {
+ if {[llength [package provide ceptcl]] == 0 \
+ && [llength [package provide udp]] == 0} {
+ return -code error "udp support is not available,\
+ get ceptcl or tcludp"
+ }
+ }
+
+ # Check for reverse lookups
+ if {[regexp {^(?:\d{0,3}\.){3}\d{0,3}$} $state(query)]} {
+ set addr [lreverse [split $state(query) .]]
+ lappend addr in-addr arpa
+ set state(query) [join $addr .]
+ set state(-type) PTR
+ }
+
+ BuildMessage $token
+
+ if {$state(-protocol) == "tcp"} {
+ TcpTransmit $token
+ } else {
+ UdpTransmit $token
+ }
+ if {$state(-command) == {}} {
+ wait $token
+ }
+ return $token
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Return a list of domain names returned as results for the last query.
+#
+proc ::dns::name {token} {
+ set r {}
+ Flags $token flags
+ array set reply [Decode $token]
+
+ switch -exact -- $flags(opcode) {
+ 0 {
+ # QUERY
+ foreach answer $reply(AN) {
+ array set AN $answer
+ if {![info exists AN(type)]} {set AN(type) {}}
+ switch -exact -- $AN(type) {
+ MX - NS - PTR {
+ if {[info exists AN(rdata)]} {lappend r $AN(rdata)}
+ }
+ default {
+ if {[info exists AN(name)]} {
+ lappend r $AN(name)
+ }
+ }
+ }
+ }
+ }
+
+ 1 {
+ # IQUERY
+ foreach answer $reply(QD) {
+ array set QD $answer
+ lappend r $QD(name)
+ }
+ }
+ default {
+ return -code error "not supported for this query type"
+ }
+ }
+ return $r
+}
+
+# Description:
+# Return a list of the IP addresses returned for this query.
+#
+proc ::dns::address {token} {
+ set r {}
+ array set reply [Decode $token]
+ foreach answer $reply(AN) {
+ array set AN $answer
+
+ if {[info exists AN(type)]} {
+ switch -exact -- $AN(type) {
+ "A" {
+ lappend r $AN(rdata)
+ }
+ "AAAA" {
+ lappend r $AN(rdata)
+ }
+ }
+ }
+ }
+ return $r
+}
+
+# Description:
+# Return a list of all CNAME results returned for this query.
+#
+proc ::dns::cname {token} {
+ set r {}
+ array set reply [Decode $token]
+ foreach answer $reply(AN) {
+ array set AN $answer
+
+ if {[info exists AN(type)]} {
+ if {$AN(type) == "CNAME"} {
+ lappend r $AN(rdata)
+ }
+ }
+ }
+ return $r
+}
+
+# Description:
+# Return the decoded answer records. This can be used for more complex
+# queries where the answer isn't supported byb cname/address/name.
+proc ::dns::result {token args} {
+ array set reply [eval [linsert $args 0 Decode $token]]
+ return $reply(AN)
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Get the status of the request.
+#
+proc ::dns::status {token} {
+ upvar #0 $token state
+ return $state(status)
+}
+
+# Description:
+# Get the error message. Empty if no error.
+#
+proc ::dns::error {token} {
+ upvar #0 $token state
+ if {[info exists state(error)]} {
+ return $state(error)
+ }
+ return ""
+}
+
+# Description
+# Get the error code. This is 0 for a successful transaction.
+#
+proc ::dns::errorcode {token} {
+ upvar #0 $token state
+ set flags [Flags $token]
+ set ndx [lsearch -exact $flags errorcode]
+ incr ndx
+ return [lindex $flags $ndx]
+}
+
+# Description:
+# Reset a connection with optional reason.
+#
+proc ::dns::reset {token {why reset} {errormsg {}}} {
+ upvar #0 $token state
+ set state(status) $why
+ if {[string length $errormsg] > 0 && ![info exists state(error)]} {
+ set state(error) $errormsg
+ }
+ catch {fileevent $state(sock) readable {}}
+ Finish $token
+}
+
+# Description:
+# Wait for a request to complete and return the status.
+#
+proc ::dns::wait {token} {
+ upvar #0 $token state
+
+ if {$state(status) == "connect"} {
+ vwait [subst $token](status)
+ }
+
+ return $state(status)
+}
+
+# Description:
+# Remove any state associated with this token.
+#
+proc ::dns::cleanup {token} {
+ upvar #0 $token state
+ if {[info exists state]} {
+ catch {close $state(sock)}
+ catch {after cancel $state(after)}
+ unset state
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Dump the raw data of the request and reply packets.
+#
+proc ::dns::dump {args} {
+ if {[llength $args] == 1} {
+ set type -reply
+ set token [lindex $args 0]
+ } elseif { [llength $args] == 2 } {
+ set type [lindex $args 0]
+ set token [lindex $args 1]
+ } else {
+ return -code error "wrong # args:\
+ should be \"dump ?option? methodName\""
+ }
+
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set result {}
+ switch -glob -- $type {
+ -qu* -
+ -req* {
+ set result [DumpMessage $state(request)]
+ }
+ -rep* {
+ set result [DumpMessage $state(reply)]
+ }
+ default {
+ error "unrecognised option: must be one of \
+ \"-query\", \"-request\" or \"-reply\""
+ }
+ }
+
+ return $result
+}
+
+# Description:
+# Perform a hex dump of binary data.
+#
+proc ::dns::DumpMessage {data} {
+ set result {}
+ binary scan $data c* r
+ foreach c $r {
+ append result [format "%02x " [expr {$c & 0xff}]]
+ }
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Contruct a DNS query packet.
+#
+proc ::dns::BuildMessage {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+ variable types
+ variable classes
+ variable options
+
+ if {! [info exists types($state(-type))] } {
+ return -code error "invalid DNS query type"
+ }
+
+ if {! [info exists classes($state(-class))] } {
+ return -code error "invalid DNS query class"
+ }
+
+ set qdcount 0
+ set qsection {}
+ set nscount 0
+ set nsdata {}
+
+ # In theory we can send multiple queries. In practice, named doesn't
+ # appear to like that much. If it did work we'd do this:
+ # foreach domain [linsert $options(search) 0 {}] ...
+
+
+ # Pack the query: QNAME QTYPE QCLASS
+ set qsection [PackName $state(query)]
+ append qsection [binary format SS \
+ $types($state(-type))\
+ $classes($state(-class))]
+ incr qdcount
+
+ if {[string length $state(qdata)] > 0} {
+ set nsdata [eval [linsert $state(qdata) 0 PackRecord]]
+ incr nscount
+ }
+
+ switch -exact -- $state(opcode) {
+ 0 {
+ # QUERY
+ set state(request) [binary format SSSSSS $state(id) \
+ [expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \
+ $qdcount 0 $nscount 0]
+ append state(request) $qsection $nsdata
+ }
+ 1 {
+ # IQUERY
+ set state(request) [binary format SSSSSS $state(id) \
+ [expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \
+ 0 $qdcount 0 0 0]
+ append state(request) \
+ [binary format cSSI 0 \
+ $types($state(-type)) $classes($state(-class)) 0]
+ switch -exact -- $state(-type) {
+ A {
+ append state(request) \
+ [binary format Sc4 4 [split $state(query) .]]
+ }
+ PTR {
+ append state(request) \
+ [binary format Sc4 4 [split $state(query) .]]
+ }
+ default {
+ return -code error "inverse query not supported for this type"
+ }
+ }
+ }
+ default {
+ return -code error "operation not supported"
+ }
+ }
+
+ return
+}
+
+# Pack a human readable dns name into a DNS resource record format.
+proc ::dns::PackName {name} {
+ set data ""
+ foreach part [split [string trim $name .] .] {
+ set len [string length $part]
+ append data [binary format ca$len $len $part]
+ }
+ append data \x00
+ return $data
+}
+
+# Pack a character string - byte length prefixed
+proc ::dns::PackString {text} {
+ set len [string length $text]
+ set data [binary format ca$len $len $text]
+ return $data
+}
+
+# Pack up a single DNS resource record. See RFC1035: 3.2 for the format
+# of each type.
+# eg: PackRecord name wiki.tcl.tk type MX class IN rdata {10 mail.example.com}
+#
+proc ::dns::PackRecord {args} {
+ variable types
+ variable classes
+ array set rr {name "" type A class IN ttl 0 rdlength 0 rdata ""}
+ array set rr $args
+ set data [PackName $rr(name)]
+
+ switch -exact -- $rr(type) {
+ CNAME - MB - MD - MF - MG - MR - NS - PTR {
+ set rr(rdata) [PackName $rr(rdata)]
+ }
+ HINFO {
+ array set r {CPU {} OS {}}
+ array set r $rr(rdata)
+ set rr(rdata) [PackString $r(CPU)]
+ append rr(rdata) [PackString $r(OS)]
+ }
+ MINFO {
+ array set r {RMAILBX {} EMAILBX {}}
+ array set r $rr(rdata)
+ set rr(rdata) [PackString $r(RMAILBX)]
+ append rr(rdata) [PackString $r(EMAILBX)]
+ }
+ MX {
+ foreach {pref exch} $rr(rdata) break
+ set rr(rdata) [binary format S $pref]
+ append rr(rdata) [PackName $exch]
+ }
+ TXT {
+ set str $rr(rdata)
+ set len [string length [set str $rr(rdata)]]
+ set rr(rdata) ""
+ for {set n 0} {$n < $len} {incr n} {
+ set s [string range $str $n [incr n 253]]
+ append rr(rdata) [PackString $s]
+ }
+ }
+ NULL {}
+ SOA {
+ array set r {MNAME {} RNAME {}
+ SERIAL 0 REFRESH 0 RETRY 0 EXPIRE 0 MINIMUM 0}
+ array set r $rr(rdata)
+ set rr(rdata) [PackName $r(MNAME)]
+ append rr(rdata) [PackName $r(RNAME)]
+ append rr(rdata) [binary format IIIII $r(SERIAL) \
+ $r(REFRESH) $r(RETRY) $r(EXPIRE) $r(MINIMUM)]
+ }
+ }
+
+ # append the root label and the type flag and query class.
+ append data [binary format SSIS $types($rr(type)) \
+ $classes($rr(class)) $rr(ttl) [string length $rr(rdata)]]
+ append data $rr(rdata)
+ return $data
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Transmit a DNS request over a tcp connection.
+#
+proc ::dns::TcpTransmit {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ # setup the timeout
+ if {$state(-timeout) > 0} {
+ set state(after) [after $state(-timeout) \
+ [list [namespace origin reset] \
+ $token timeout\
+ "operation timed out"]]
+ }
+
+ # Sometimes DNS servers drop TCP requests. So it's better to
+ # use asynchronous connect
+ set s [socket -async $state(-nameserver) $state(-port)]
+ fileevent $s writable [list [namespace origin TcpConnected] $token $s]
+ set state(sock) $s
+ set state(status) connect
+
+ return $token
+}
+
+proc ::dns::TcpConnected {token s} {
+ variable $token
+ upvar 0 $token state
+
+ fileevent $s writable {}
+ if {[catch {fconfigure $s -peername}]} {
+ # TCP connection failed
+ Finish $token "can't connect to server"
+ return
+ }
+
+ fconfigure $s -blocking 0 -translation binary -buffering none
+
+ # For TCP the message must be prefixed with a 16bit length field.
+ set req [binary format S [string length $state(request)]]
+ append req $state(request)
+
+ puts -nonewline $s $req
+
+ fileevent $s readable [list [namespace current]::TcpEvent $token]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Transmit a DNS request using UDP datagrams
+#
+# Note:
+# This requires a UDP implementation that can transmit binary data.
+# As yet I have been unable to test this myself and the tcludp package
+# cannot do this.
+#
+proc ::dns::UdpTransmit {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ # setup the timeout
+ if {$state(-timeout) > 0} {
+ set state(after) [after $state(-timeout) \
+ [list [namespace origin reset] \
+ $token timeout\
+ "operation timed out"]]
+ }
+
+ if {[llength [package provide ceptcl]] > 0} {
+ # using ceptcl
+ set state(sock) [cep -type datagram $state(-nameserver) $state(-port)]
+ fconfigure $state(sock) -blocking 0
+ } else {
+ # using tcludp
+ set state(sock) [udp_open]
+ udp_conf $state(sock) $state(-nameserver) $state(-port)
+ }
+ fconfigure $state(sock) -translation binary -buffering none
+ set state(status) connect
+ puts -nonewline $state(sock) $state(request)
+
+ fileevent $state(sock) readable [list [namespace current]::UdpEvent $token]
+
+ return $token
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Tidy up after a tcp transaction.
+#
+proc ::dns::Finish {token {errormsg ""}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+ global errorInfo errorCode
+
+ if {[string length $errormsg] != 0} {
+ set state(error) $errormsg
+ set state(status) error
+ }
+ catch {close $state(sock)}
+ catch {after cancel $state(after)}
+ if {[info exists state(-command)] && $state(-command) != {}} {
+ if {[catch {eval $state(-command) {$token}} err]} {
+ if {[string length $errormsg] == 0} {
+ set state(error) [list $err $errorInfo $errorCode]
+ set state(status) error
+ }
+ }
+ if {[info exists state(-command)]} {
+ unset state(-command)
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Handle end-of-file on a tcp connection.
+#
+proc ::dns::Eof {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+ set state(status) eof
+ Finish $token
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Process a DNS reply packet (protocol independent)
+#
+proc ::dns::Receive {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ binary scan $state(reply) SS id flags
+ set status [expr {$flags & 0x000F}]
+
+ switch -- $status {
+ 0 {
+ set state(status) ok
+ Finish $token
+ }
+ 1 { Finish $token "Format error - unable to interpret the query." }
+ 2 { Finish $token "Server failure - internal server error." }
+ 3 { Finish $token "Name Error - domain does not exist" }
+ 4 { Finish $token "Not implemented - the query type is not available." }
+ 5 { Finish $token "Refused - your request has been refused by the server." }
+ default {
+ Finish $token "unrecognised error code: $err"
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# file event handler for tcp socket. Wait for the reply data.
+#
+proc ::dns::TcpEvent {token} {
+ variable log
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+ set s $state(sock)
+
+ if {[eof $s]} {
+ Eof $token
+ return
+ }
+
+ set status [catch {read $state(sock)} result]
+ if {$status != 0} {
+ ${log}::debug "Event error: $result"
+ Finish $token "error reading data: $result"
+ } elseif { [string length $result] >= 0 } {
+ if {[catch {
+ # Handle incomplete reads - check the size and keep reading.
+ if {![info exists state(size)]} {
+ binary scan $result S state(size)
+ set result [string range $result 2 end]
+ }
+ append state(reply) $result
+
+ # check the length and flags and chop off the tcp length prefix.
+ if {[string length $state(reply)] >= $state(size)} {
+ binary scan $result S id
+ set id [expr {$id & 0xFFFF}]
+ if {$id != [expr {$state(id) & 0xFFFF}]} {
+ ${log}::error "received packed with incorrect id"
+ }
+ # bug #1158037 - doing this causes problems > 65535 requests!
+ #Receive [namespace current]::$id
+ Receive $token
+ } else {
+ ${log}::debug "Incomplete tcp read:\
+ [string length $state(reply)] should be $state(size)"
+ }
+ } err]} {
+ Finish $token "Event error: $err"
+ }
+ } elseif { [eof $state(sock)] } {
+ Eof $token
+ } elseif { [fblocked $state(sock)] } {
+ ${log}::debug "Event blocked"
+ } else {
+ ${log}::critical "Event error: this can't happen!"
+ Finish $token "Event error: this can't happen!"
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# file event handler for udp sockets.
+proc ::dns::UdpEvent {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+ set s $state(sock)
+
+ set payload [read $state(sock)]
+ append state(reply) $payload
+
+ binary scan $payload S id
+ set id [expr {$id & 0xFFFF}]
+ if {$id != [expr {$state(id) & 0xFFFF}]} {
+ ${log}::error "received packed with incorrect id"
+ }
+ # bug #1158037 - doing this causes problems > 65535 requests!
+ #Receive [namespace current]::$id
+ Receive $token
+}
+
+# -------------------------------------------------------------------------
+
+proc ::dns::Flags {token {varname {}}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {$varname != {}} {
+ upvar $varname flags
+ }
+
+ array set flags {query 0 opcode 0 authoritative 0 errorcode 0
+ truncated 0 recursion_desired 0 recursion_allowed 0}
+
+ binary scan $state(reply) SSSSSS mid hdr nQD nAN nNS nAR
+
+ set flags(response) [expr {($hdr & 0x8000) >> 15}]
+ set flags(opcode) [expr {($hdr & 0x7800) >> 11}]
+ set flags(authoritative) [expr {($hdr & 0x0400) >> 10}]
+ set flags(truncated) [expr {($hdr & 0x0200) >> 9}]
+ set flags(recursion_desired) [expr {($hdr & 0x0100) >> 8}]
+ set flags(recursion_allowed) [expr {($hdr & 0x0080) >> 7}]
+ set flags(errorcode) [expr {($hdr & 0x000F)}]
+
+ return [array get flags]
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Decode a DNS packet (either query or response).
+#
+proc ::dns::Decode {token args} {
+ variable log
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set opts {-rdata 0 -query 0}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -exact -- $option {
+ -rdata { set opts(-rdata) 1 }
+ -query { set opts(-query) 1 }
+ default {
+ return -code error "bad option \"$option\":\
+ must be -rdata"
+ }
+ }
+ Pop args
+ }
+
+ if {$opts(-query)} {
+ binary scan $state(request) SSSSSSc* mid hdr nQD nAN nNS nAR data
+ } else {
+ binary scan $state(reply) SSSSSSc* mid hdr nQD nAN nNS nAR data
+ }
+
+ set fResponse [expr {($hdr & 0x8000) >> 15}]
+ set fOpcode [expr {($hdr & 0x7800) >> 11}]
+ set fAuthoritative [expr {($hdr & 0x0400) >> 10}]
+ set fTrunc [expr {($hdr & 0x0200) >> 9}]
+ set fRecurse [expr {($hdr & 0x0100) >> 8}]
+ set fCanRecurse [expr {($hdr & 0x0080) >> 7}]
+ set fRCode [expr {($hdr & 0x000F)}]
+ set flags ""
+
+ if {$fResponse} {set flags "QR"} else {set flags "Q"}
+ set opcodes [list QUERY IQUERY STATUS]
+ lappend flags [lindex $opcodes $fOpcode]
+ if {$fAuthoritative} {lappend flags "AA"}
+ if {$fTrunc} {lappend flags "TC"}
+ if {$fRecurse} {lappend flags "RD"}
+ if {$fCanRecurse} {lappend flags "RA"}
+
+ set info "ID: $mid\
+ Fl: [format 0x%02X [expr {$hdr & 0xFFFF}]] ($flags)\
+ NQ: $nQD\
+ NA: $nAN\
+ NS: $nNS\
+ AR: $nAR"
+ ${log}::debug $info
+
+ set ndx 12
+ set r {}
+ set QD [ReadQuestion $nQD $state(reply) ndx]
+ lappend r QD $QD
+ set AN [ReadAnswer $nAN $state(reply) ndx $opts(-rdata)]
+ lappend r AN $AN
+ set NS [ReadAnswer $nNS $state(reply) ndx $opts(-rdata)]
+ lappend r NS $NS
+ set AR [ReadAnswer $nAR $state(reply) ndx $opts(-rdata)]
+ lappend r AR $AR
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::dns::Expand {data} {
+ set r {}
+ binary scan $data c* d
+ foreach c $d {
+ lappend r [expr {$c & 0xFF}]
+ }
+ return $r
+}
+
+
+# -------------------------------------------------------------------------
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::dns::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Reverse a list. Code from http://wiki.tcl.tk/tcl/43
+#
+proc ::dns::lreverse {lst} {
+ set res {}
+ set i [llength $lst]
+ while {$i} {lappend res [lindex $lst [incr i -1]]}
+ return $res
+}
+
+# -------------------------------------------------------------------------
+
+proc ::dns::KeyOf {arrayname value {default {}}} {
+ upvar $arrayname array
+ set lst [array get array]
+ set ndx [lsearch -exact $lst $value]
+ if {$ndx != -1} {
+ incr ndx -1
+ set r [lindex $lst $ndx]
+ } else {
+ set r $default
+ }
+ return $r
+}
+
+
+# -------------------------------------------------------------------------
+# Read the question section from a DNS message. This always starts at index
+# 12 of a message but may be of variable length.
+#
+proc ::dns::ReadQuestion {nitems data indexvar} {
+ variable types
+ variable classes
+ upvar $indexvar index
+ set result {}
+
+ for {set cn 0} {$cn < $nitems} {incr cn} {
+ set r {}
+ lappend r name [ReadName data $index offset]
+ incr index $offset
+
+ # Read off QTYPE and QCLASS for this query.
+ set ndx $index
+ incr index 3
+ binary scan [string range $data $ndx $index] SS qtype qclass
+ set qtype [expr {$qtype & 0xFFFF}]
+ set qclass [expr {$qclass & 0xFFFF}]
+ incr index
+ lappend r type [KeyOf types $qtype $qtype] \
+ class [KeyOf classes $qclass $qclass]
+ lappend result $r
+ }
+ return $result
+}
+
+# -------------------------------------------------------------------------
+
+# Read an answer section from a DNS message.
+#
+proc ::dns::ReadAnswer {nitems data indexvar {raw 0}} {
+ variable types
+ variable classes
+ upvar $indexvar index
+ set result {}
+
+ for {set cn 0} {$cn < $nitems} {incr cn} {
+ set r {}
+ lappend r name [ReadName data $index offset]
+ incr index $offset
+
+ # Read off TYPE, CLASS, TTL and RDLENGTH
+ binary scan [string range $data $index end] SSIS type class ttl rdlength
+
+ set type [expr {$type & 0xFFFF}]
+ set type [KeyOf types $type $type]
+
+ set class [expr {$class & 0xFFFF}]
+ set class [KeyOf classes $class $class]
+
+ set ttl [expr {$ttl & 0xFFFFFFFF}]
+ set rdlength [expr {$rdlength & 0xFFFF}]
+ incr index 10
+ set rdata [string range $data $index [expr {$index + $rdlength - 1}]]
+
+ if {! $raw} {
+ switch -- $type {
+ A {
+ set rdata [join [Expand $rdata] .]
+ }
+ AAAA {
+ set rdata [ip::contract [ip::ToString $rdata]]
+ }
+ NS - CNAME - PTR {
+ set rdata [ReadName data $index off]
+ }
+ MX {
+ binary scan $rdata S preference
+ set exchange [ReadName data [expr {$index + 2}] off]
+ set rdata [list $preference $exchange]
+ }
+ SRV {
+ set x $index
+ set rdata [list priority [ReadUShort data $x off]]
+ incr x $off
+ lappend rdata weight [ReadUShort data $x off]
+ incr x $off
+ lappend rdata port [ReadUShort data $x off]
+ incr x $off
+ lappend rdata target [ReadName data $x off]
+ incr x $off
+ }
+ TXT {
+ set rdata [ReadString data $index $rdlength]
+ }
+ SOA {
+ set x $index
+ set rdata [list MNAME [ReadName data $x off]]
+ incr x $off
+ lappend rdata RNAME [ReadName data $x off]
+ incr x $off
+ lappend rdata SERIAL [ReadULong data $x off]
+ incr x $off
+ lappend rdata REFRESH [ReadLong data $x off]
+ incr x $off
+ lappend rdata RETRY [ReadLong data $x off]
+ incr x $off
+ lappend rdata EXPIRE [ReadLong data $x off]
+ incr x $off
+ lappend rdata MINIMUM [ReadULong data $x off]
+ incr x $off
+ }
+ }
+ }
+
+ incr index $rdlength
+ lappend r type $type class $class ttl $ttl rdlength $rdlength rdata $rdata
+ lappend result $r
+ }
+ return $result
+}
+
+
+# Read a 32bit integer from a DNS packet. These are compatible with
+# the ReadName proc. Additionally - ReadULong takes measures to ensure
+# the unsignedness of the value obtained.
+#
+proc ::dns::ReadLong {datavar index usedvar} {
+ upvar $datavar data
+ upvar $usedvar used
+ set r {}
+ set used 0
+ if {[binary scan $data @${index}I r]} {
+ set used 4
+ }
+ return $r
+}
+
+proc ::dns::ReadULong {datavar index usedvar} {
+ upvar $datavar data
+ upvar $usedvar used
+ set r {}
+ set used 0
+ if {[binary scan $data @${index}cccc b1 b2 b3 b4]} {
+ set used 4
+ # This gets us an unsigned value.
+ set r [expr {($b4 & 0xFF) + (($b3 & 0xFF) << 8)
+ + (($b2 & 0xFF) << 16) + ($b1 << 24)}]
+ }
+ return $r
+}
+
+proc ::dns::ReadUShort {datavar index usedvar} {
+ upvar $datavar data
+ upvar $usedvar used
+ set r {}
+ set used 0
+ if {[binary scan [string range $data $index end] cc b1 b2]} {
+ set used 2
+ # This gets us an unsigned value.
+ set r [expr {(($b2 & 0xff) + (($b1 & 0xff) << 8)) & 0xffff}]
+ }
+ return $r
+}
+
+# Read off the NAME or QNAME element. This reads off each label in turn,
+# dereferencing pointer labels until we have finished. The length of data
+# used is passed back using the usedvar variable.
+#
+proc ::dns::ReadName {datavar index usedvar} {
+ upvar $datavar data
+ upvar $usedvar used
+ set startindex $index
+
+ set r {}
+ set len 1
+ set max [string length $data]
+
+ while {$len != 0 && $index < $max} {
+ # Read the label length (and preread the pointer offset)
+ binary scan [string range $data $index end] cc len lenb
+ set len [expr {$len & 0xFF}]
+ incr index
+
+ if {$len != 0} {
+ if {[expr {$len & 0xc0}]} {
+ binary scan [binary format cc [expr {$len & 0x3f}] [expr {$lenb & 0xff}]] S offset
+ incr index
+ lappend r [ReadName data $offset junk]
+ set len 0
+ } else {
+ lappend r [string range $data $index [expr {$index + $len - 1}]]
+ incr index $len
+ }
+ }
+ }
+ set used [expr {$index - $startindex}]
+ return [join $r .]
+}
+
+proc ::dns::ReadString {datavar index length} {
+ upvar $datavar data
+ set startindex $index
+
+ set r {}
+ set max [expr {$index + $length}]
+
+ while {$index < $max} {
+ binary scan [string range $data $index end] c len
+ set len [expr {$len & 0xFF}]
+ incr index
+
+ if {$len != 0} {
+ append r [string range $data $index [expr {$index + $len - 1}]]
+ incr index $len
+ }
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Support for finding the local nameservers
+#
+# For unix we can just parse the /etc/resolv.conf if it exists.
+# Of course, some unices use /etc/resolver and other things (NIS for instance)
+# On Windows, we can examine the Internet Explorer settings from the registry.
+#
+switch -exact $::tcl_platform(platform) {
+ windows {
+ proc ::dns::nameservers {} {
+ package require registry
+ set base {HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services}
+ set param "$base\\Tcpip\\Parameters"
+ set interfaces "$param\\Interfaces"
+ set nameservers {}
+ if {[string equal $::tcl_platform(os) "Windows NT"]} {
+ AppendRegistryValue $param NameServer nameservers
+ AppendRegistryValue $param DhcpNameServer nameservers
+ foreach i [registry keys $interfaces] {
+ AppendRegistryValue "$interfaces\\$i" NameServer nameservers
+ AppendRegistryValue "$interfaces\\$i" DhcpNameServer nameservers
+ }
+ } else {
+ set param "$base\\VxD\\MSTCP"
+ AppendRegistryValue $param NameServer nameservers
+ }
+ return $nameservers
+ }
+ proc ::dns::AppendRegistryValue {key val listName} {
+ upvar $listName lst
+ if {![catch {registry get $key $val} v]} {
+ foreach ns [split $v ", "] {
+ if {[lsearch -exact $lst $ns] == -1} {
+ lappend lst $ns
+ }
+ }
+ }
+ }
+ }
+ unix {
+ proc ::dns::nameservers {} {
+ set nameservers {}
+ if {[file readable /etc/resolv.conf]} {
+ set f [open /etc/resolv.conf r]
+ while {![eof $f]} {
+ gets $f line
+ if {[regexp {^\s*nameserver\s+(.*)$} $line -> ns]} {
+ lappend nameservers $ns
+ }
+ }
+ close $f
+ }
+ if {[llength $nameservers] < 1} {
+ lappend nameservers 127.0.0.1
+ }
+ return $nameservers
+ }
+ }
+ default {
+ proc ::dns::nameservers {} {
+ return -code error "command not supported for this platform."
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+# Possible support for the DNS URL scheme.
+# Ref: http://www.ietf.org/internet-drafts/draft-josefsson-dns-url-04.txt
+# eg: dns:target?class=IN;type=A
+# dns://nameserver/target?type=A
+#
+# URI quoting to be accounted for.
+#
+
+catch {
+ uri::register {dns} {
+ variable escape [set [namespace parent [namespace current]]::basic::escape]
+ variable host [set [namespace parent [namespace current]]::basic::host]
+ variable hostOrPort [set [namespace parent [namespace current]]::basic::hostOrPort]
+
+ variable class [string map {* \\\\*} \
+ "class=([join [array names ::dns::classes] {|}])"]
+ variable type [string map {* \\\\*} \
+ "type=([join [array names ::dns::types] {|}])"]
+ variable classOrType "(?:${class}|${type})"
+ variable classOrTypeSpec "(?:${class}|${type})(?:;(?:${class}|${type}))?"
+
+ variable query "${host}(${classOrTypeSpec})?"
+ variable schemepart "(//${hostOrPort}/)?(${query})"
+ variable url "dns:$schemepart"
+ }
+}
+
+namespace eval ::uri {} ;# needed for pkg_mkIndex.
+
+proc ::uri::SplitDns {uri} {
+ upvar \#0 [namespace current]::dns::schemepart schemepart
+ upvar \#0 [namespace current]::dns::class classOrType
+ upvar \#0 [namespace current]::dns::class classRE
+ upvar \#0 [namespace current]::dns::type typeRE
+ upvar \#0 [namespace current]::dns::classOrTypeSpec classOrTypeSpec
+
+ array set parts {nameserver {} query {} class {} type {} port {}}
+
+ # validate the uri
+ if {[regexp -- $dns::schemepart $uri r] == 1} {
+
+ # deal with the optional class and type specifiers
+ if {[regexp -indices -- "${classOrTypeSpec}$" $uri range]} {
+ set spec [string range $uri [lindex $range 0] [lindex $range 1]]
+ set uri [string range $uri 0 [expr {[lindex $range 0] - 2}]]
+
+ if {[regexp -- "$classRE" $spec -> class]} {
+ set parts(class) $class
+ }
+ if {[regexp -- "$typeRE" $spec -> type]} {
+ set parts(type) $type
+ }
+ }
+
+ # Handle the nameserver specification
+ if {[string match "//*" $uri]} {
+ set uri [string range $uri 2 end]
+ array set tmp [GetHostPort uri]
+ set parts(nameserver) $tmp(host)
+ set parts(port) $tmp(port)
+ }
+
+ # what's left is the query domain name.
+ set parts(query) [string trimleft $uri /]
+ }
+
+ return [array get parts]
+}
+
+proc ::uri::JoinDns {args} {
+ array set parts {nameserver {} port {} query {} class {} type {}}
+ array set parts $args
+ set query [::uri::urn::quote $parts(query)]
+ if {$parts(type) != {}} {
+ append query "?type=$parts(type)"
+ }
+ if {$parts(class) != {}} {
+ if {$parts(type) == {}} {
+ append query "?class=$parts(class)"
+ } else {
+ append query ";class=$parts(class)"
+ }
+ }
+ if {$parts(nameserver) != {}} {
+ set ns "$parts(nameserver)"
+ if {$parts(port) != {}} {
+ append ns ":$parts(port)"
+ }
+ set query "//${ns}/${query}"
+ }
+ return "dns:$query"
+}
+
+# -------------------------------------------------------------------------
+
+catch {dns::configure -nameserver [lindex [dns::nameservers] 0]}
+
+package provide dns 1.3.5
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/dns/dns.test b/tcllib/modules/dns/dns.test
new file mode 100644
index 0000000..1e80944
--- /dev/null
+++ b/tcllib/modules/dns/dns.test
@@ -0,0 +1,73 @@
+# dns.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Tests for the Tcllib dns package
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: dns.test,v 1.6 2006/10/09 21:41:40 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal dns.tcl dns
+}
+
+# -------------------------------------------------------------------------
+# Tests
+# -------------------------------------------------------------------------
+
+# Test the dns uri scheme split and join methods.
+
+set urls {
+ 1 dns:www.example.org
+ {class {} nameserver {} port {} query www.example.org scheme dns type {}}
+ 2 dns://nameserver/www.example.org
+ {class {} nameserver nameserver port {} query www.example.org scheme dns type {}}
+ 3 dns://nameserver:53/www.example.org
+ {class {} nameserver nameserver port 53 query www.example.org scheme dns type {}}
+ 4 dns:www.example.org?class=IN
+ {class IN nameserver {} port {} query www.example.org scheme dns type {}}
+ 5 dns:www.example.org?type=MX
+ {class {} nameserver {} port {} query www.example.org scheme dns type MX}
+ 6 dns:www.example.org?class=IN;type=A
+ {class IN nameserver {} port {} query www.example.org scheme dns type A}
+ 7 dns:www.example.org?type=A;class=IN
+ {class IN nameserver {} port {} query www.example.org scheme dns type A}
+}
+
+foreach {ndx url check} $urls {
+ test dns-1.$ndx [list uri::split $url] {
+ if {![catch {uri::split $url} result]} {
+ if {![catch {array set URL $result} result]} {
+ set result [dictsort [array get URL]]
+ }
+ }
+ set result
+ } $check
+}
+
+foreach {ndx url check} $urls {
+ if {$ndx == 6} continue; # this test is bogus for join.
+ test dns-2.$ndx [list uri::join $url] {
+ catch {eval [list uri::join] $check} result
+ set result
+ } $url
+}
+
+
+# -------------------------------------------------------------------------
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/dns/ip.tcl b/tcllib/modules/dns/ip.tcl
new file mode 100644
index 0000000..f55ab3e
--- /dev/null
+++ b/tcllib/modules/dns/ip.tcl
@@ -0,0 +1,553 @@
+# ip.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Internet address manipulation.
+#
+# RFC 3513: IPv6 addressing.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+# @mdgen EXCLUDE: ipMoreC.tcl
+
+package require Tcl 8.2; # tcl minimum version
+
+namespace eval ip {
+ namespace export is version normalize equal type contract mask collapse subtract
+ #catch {namespace ensemble create}
+
+ variable IPv4Ranges
+ if {![info exists IPv4Ranges]} {
+ array set IPv4Ranges {
+ 0/8 private
+ 10/8 private
+ 127/8 private
+ 172.16/12 private
+ 192.168/16 private
+ 223/8 reserved
+ 224/3 reserved
+ }
+ }
+
+ variable IPv6Ranges
+ if {![info exists IPv6Ranges]} {
+ # RFC 3513: 2.4
+ # RFC 3056: 2
+ array set IPv6Ranges {
+ 2002::/16 "6to4 unicast"
+ fe80::/10 "link local"
+ fec0::/10 "site local"
+ ff00::/8 "multicast"
+ ::/128 "unspecified"
+ ::1/128 "localhost"
+ }
+ }
+}
+
+proc ::ip::is {class ip} {
+ foreach {ip mask} [split $ip /] break
+ switch -exact -- $class {
+ ipv4 - IPv4 - 4 {
+ return [IPv4? $ip]
+ }
+ ipv6 - IPv6 - 6 {
+ return [IPv6? $ip]
+ }
+ default {
+ return -code error "bad class \"$class\": must be ipv4 or ipv6"
+ }
+ }
+}
+
+proc ::ip::version {ip} {
+ set version -1
+ if {[string equal $ip {}]} { return $version}
+ foreach {addr mask} [split $ip /] break
+ if {[IPv4? $addr]} {
+ set version 4
+ } elseif {[IPv6? $addr]} {
+ set version 6
+ }
+ return $version
+}
+
+proc ::ip::equal {lhs rhs} {
+ foreach {LHS LM} [SplitIp $lhs] break
+ foreach {RHS RM} [SplitIp $rhs] break
+ if {[set version [version $LHS]] != [version $RHS]} {
+ return -code error "type mismatch:\
+ cannot compare different address types"
+ }
+ if {$version == 4} {set fmt I} else {set fmt I4}
+ set LHS [Mask$version [Normalize $LHS $version] $LM]
+ set RHS [Mask$version [Normalize $RHS $version] $RM]
+ binary scan $LHS $fmt LLL
+ binary scan $RHS $fmt RRR
+ foreach L $LLL R $RRR {
+ if {$L != $R} {return 0}
+ }
+ return 1
+}
+
+proc ::ip::collapse {prefixlist} {
+ #puts **[llength $prefixlist]||$prefixlist
+
+ # Force mask parts into length notation for the following merge
+ # loop to work.
+ foreach ip $prefixlist {
+ foreach {addr mask} [SplitIp $ip] break
+ set nip $addr/[maskToLength [maskToInt $mask]]
+ #puts "prefix $ip = $nip"
+ lappend tmp $nip
+ }
+ set prefixlist $tmp
+
+ #puts @@[llength $prefixlist]||$prefixlist
+
+ set ret {}
+ set can_normalize_more 1
+ while {$can_normalize_more} {
+ set prefixlist [lsort -dict $prefixlist]
+
+ #puts ||[llength $prefixlist]||$prefixlist
+
+ set can_normalize_more 0
+
+ for {set idx 0} {$idx < [llength $prefixlist]} {incr idx} {
+ set nextidx [expr {$idx + 1}]
+
+ set item [lindex $prefixlist $idx]
+ set nextitem [lindex $prefixlist $nextidx]
+
+ if {$nextitem eq ""} {
+ lappend ret $item
+ continue
+ }
+
+ set itemmask [mask $item]
+ set nextitemmask [mask $nextitem]
+
+ set item [prefix $item]
+
+ if {$itemmask ne $nextitemmask} {
+ lappend ret $item/$itemmask
+ continue
+ }
+
+ set adjacentitem [intToString [nextNet $item $itemmask]]/$itemmask
+
+ if {$nextitem ne $adjacentitem} {
+ lappend ret $item/$itemmask
+ continue
+ }
+
+ set upmask [expr {$itemmask - 1}]
+ set upitem "$item/$upmask"
+
+ # Maybe just checking the llength of the result is enough ?
+ if {[reduceToAggregates [list $item $nextitem $upitem]] != [list $upitem]} {
+ lappend ret $item/$itemmask
+ continue
+ }
+
+ set can_normalize_more 1
+
+ incr idx
+ lappend ret $upitem
+ }
+
+ set prefixlist $ret
+ set ret {}
+ }
+
+ return $prefixlist
+}
+
+
+proc ::ip::normalize {ip {Ip4inIp6 0}} {
+ foreach {ip mask} [SplitIp $ip] break
+ set version [version $ip]
+ set s [ToString [Normalize $ip $version] $Ip4inIp6]
+ if {($version == 6 && $mask != 128) || ($version == 4 && $mask != 32)} {
+ append s /$mask
+ }
+ return $s
+}
+
+proc ::ip::contract {ip} {
+ foreach {ip mask} [SplitIp $ip] break
+ set version [version $ip]
+ set s [ToString [Normalize $ip $version]]
+ if {$version == 6} {
+ set r ""
+ foreach o [split $s :] {
+ append r [format %x: 0x$o]
+ }
+ set r [string trimright $r :]
+ regsub {(?:^|:)0(?::0)+(?::|$)} $r {::} r
+ } else {
+ set r [string trimright $s .0]
+ }
+ return $r
+}
+
+proc ::ip::subtract {hosts} {
+ set positives {}
+ set negatives {}
+
+ foreach host $hosts {
+ foreach {addr mask} [SplitIp $host] break
+ set host $addr/[maskToLength [maskToInt $mask]]
+
+ if {[string match "-*" $host]} {
+ set host [string trimleft $host "-"]
+ lappend negatives $host
+ } else {
+ lappend positives $host
+ }
+ }
+
+ # Reduce to aggregates if needed
+ if {[llength $positives] > 1} {
+ set positives [reduceToAggregates $positives]
+ }
+
+ if {![llength $positives]} {
+ return {}
+ }
+
+ if {[llength $negatives] > 1} {
+ set negatives [reduceToAggregates $negatives]
+ }
+
+ if {![llength $negatives]} {
+ return $positives
+ }
+
+ # Remove positives that are cancelled out entirely
+ set new_positives {}
+ foreach positive $positives {
+ set found 0
+ foreach negative $negatives {
+ # Do we need the exact check, i.e. ==, or 'eq', or would
+ # checking the length of result == 1 be good enough?
+ if {[reduceToAggregates [list $positive $negative]] == [list $negative]} {
+ set found 1
+ break
+ }
+ }
+
+ if {!$found} {
+ lappend new_positives $positive
+ }
+ }
+ set positives $new_positives
+
+ set retval {}
+ foreach positive $positives {
+ set negatives_found {}
+ foreach negative $negatives {
+ if {[isOverlap $positive $negative]} {
+ lappend negatives_found $negative
+ }
+ }
+
+ if {![llength $negatives_found]} {
+ lappend retval $positive
+ continue
+ }
+
+ # Convert the larger subnet
+ ## Determine smallest subnet involved
+ set maxmask 0
+ foreach subnet [linsert $negatives 0 $positive] {
+ set mask [mask $subnet]
+ if {$mask > $maxmask} {
+ set maxmask $mask
+ }
+ }
+
+ set positive_list [ExpandSubnet $positive $maxmask]
+ set negative_list {}
+ foreach negative $negatives_found {
+ foreach negative_subnet [ExpandSubnet $negative $maxmask] {
+ lappend negative_list $negative_subnet
+ }
+ }
+
+ foreach positive_sub $positive_list {
+ if {[lsearch -exact $negative_list $positive_sub] < 0} {
+ lappend retval $positive_sub
+ }
+ }
+ }
+
+ return $retval
+}
+
+proc ::ip::ExpandSubnet {subnet newmask} {
+ #set oldmask [maskToLength [maskToInt [mask $subnet]]]
+ set oldmask [mask $subnet]
+ set subnet [prefix $subnet]
+
+ set numsubnets [expr {round(pow(2, ($newmask - $oldmask)))}]
+
+ set ret {}
+ for {set idx 0} {$idx < $numsubnets} {incr idx} {
+ lappend ret "${subnet}/${newmask}"
+ set subnet [intToString [nextNet $subnet $newmask]]
+ }
+
+ return $ret
+}
+
+# Returns an IP address prefix.
+# For instance:
+# prefix 192.168.1.4/16 => 192.168.0.0
+# prefix fec0::4/16 => fec0:0:0:0:0:0:0:0
+# prefix fec0::4/ffff:: => fec0:0:0:0:0:0:0:0
+#
+proc ::ip::prefix {ip} {
+ foreach {addr mask} [SplitIp $ip] break
+ set version [version $addr]
+ set addr [Normalize $addr $version]
+ return [ToString [Mask$version $addr $mask]]
+}
+
+# Return the address type. For IPv4 this is one of private, reserved
+# or normal
+# For IPv6 it is one of site local, link local, multicast, unicast,
+# unspecified or loopback.
+proc ::ip::type {ip} {
+ set version [version $ip]
+ upvar [namespace current]::IPv${version}Ranges types
+ set ip [prefix $ip]
+ foreach prefix [array names types] {
+ set mask [mask $prefix]
+ if {[equal $ip/$mask $prefix]} {
+ return $types($prefix)
+ }
+ }
+ if {$version == 4} {
+ return "normal"
+ } else {
+ return "unicast"
+ }
+}
+
+proc ::ip::mask {ip} {
+ foreach {addr mask} [split $ip /] break
+ return $mask
+}
+
+# -------------------------------------------------------------------------
+
+# Returns true is the argument can be converted into an IPv4 address.
+#
+proc ::ip::IPv4? {ip} {
+ if {[string first : $ip] >= 0} {
+ return 0
+ }
+ if {[catch {Normalize4 $ip}]} {
+ return 0
+ }
+ return 1
+}
+
+proc ::ip::IPv6? {ip} {
+ set octets [split $ip :]
+ if {[llength $octets] < 3 || [llength $octets] > 8} {
+ return 0
+ }
+ set ndx 0
+ foreach octet $octets {
+ incr ndx
+ if {[string length $octet] < 1} continue
+ if {[regexp {^[a-fA-F\d]{1,4}$} $octet]} continue
+ if {$ndx >= [llength $octets] && [IPv4? $octet]} continue
+ if {$ndx == 2 && [lindex $octets 0] == 2002 && [IPv4? $octet]} continue
+ #"Invalid IPv6 address \"$ip\""
+ return 0
+ }
+ if {[regexp {^:[^:]} $ip]} {
+ #"Invalid ipv6 address \"$ip\" (starts with :)"
+ return 0
+ }
+ if {[regexp {[^:]:$} $ip]} {
+ # "Invalid IPv6 address \"$ip\" (ends with :)"
+ return 0
+ }
+ if {[regsub -all :: $ip "|" junk] > 1} {
+ # "Invalid IPv6 address \"$ip\" (more than one :: pattern)"
+ return 0
+ }
+ return 1
+}
+
+proc ::ip::Mask4 {ip {bits {}}} {
+ if {[string length $bits] < 1} { set bits 32 }
+ binary scan $ip I ipx
+ if {[string is integer $bits]} {
+ set mask [expr {(0xFFFFFFFF << (32 - $bits)) & 0xFFFFFFFF}]
+ } else {
+ binary scan [Normalize4 $bits] I mask
+ }
+ return [binary format I [expr {$ipx & $mask}]]
+}
+
+proc ::ip::Mask6 {ip {bits {}}} {
+ if {[string length $bits] < 1} { set bits 128 }
+ if {[string is integer $bits]} {
+ set mask [binary format B128 [string repeat 1 $bits]]
+ } else {
+ binary scan [Normalize6 $bits] I4 mask
+ }
+ binary scan $ip I4 Addr
+ binary scan $mask I4 Mask
+ foreach A $Addr M $Mask {
+ lappend r [expr {$A & $M}]
+ }
+ return [binary format I4 $r]
+}
+
+
+
+# A network address specification is an IPv4 address with an optional bitmask
+# Split an address specification into a IPv4 address and a network bitmask.
+# This doesn't validate the address portion.
+# If a spec with no mask is provided then the mask will be 32
+# (all bits significant).
+# Masks may be either integer number of significant bits or dotted-quad
+# notation.
+#
+proc ::ip::SplitIp {spec} {
+ set slash [string last / $spec]
+ if {$slash != -1} {
+ incr slash -1
+ set ip [string range $spec 0 $slash]
+ incr slash 2
+ set bits [string range $spec $slash end]
+ } else {
+ set ip $spec
+ if {[string length $ip] > 0 && [version $ip] == 6} {
+ set bits 128
+ } else {
+ set bits 32
+ }
+ }
+ return [list $ip $bits]
+}
+
+# Given an IP string from the user, convert to a normalized internal rep.
+# For IPv4 this is currently a hex string (0xHHHHHHHH).
+# For IPv6 this is a binary string or 16 chars.
+proc ::ip::Normalize {ip {version 0}} {
+ if {$version < 0} {
+ set version [version $ip]
+ if {$version < 0} {
+ return -code error "invalid address \"$ip\":\
+ value must be a valid IPv4 or IPv6 address"
+ }
+ }
+ return [Normalize$version $ip]
+}
+
+proc ::ip::Normalize4 {ip} {
+ set octets [split $ip .]
+ if {[llength $octets] > 4} {
+ return -code error "invalid ip address \"$ip\""
+ } elseif {[llength $octets] < 4} {
+ set octets [lrange [concat $octets 0 0 0] 0 3]
+ }
+ foreach oct $octets {
+ if {$oct < 0 || $oct > 255} {
+ return -code error "invalid ip address"
+ }
+ }
+ return [binary format c4 $octets]
+}
+
+proc ::ip::Normalize6 {ip} {
+ set octets [split $ip :]
+ set ip4embed [string first . $ip]
+ set len [llength $octets]
+ if {$len < 0 || $len > 8} {
+ return -code error "invalid address: this is not an IPv6 address"
+ }
+ set result ""
+ for {set n 0} {$n < $len} {incr n} {
+ set octet [lindex $octets $n]
+ if {$octet == {}} {
+ if {$n == 0 || $n == ($len - 1)} {
+ set octet \0\0
+ } else {
+ set missing [expr {9 - $len}]
+ if {$ip4embed != -1} {incr missing -1}
+ set octet [string repeat \0\0 $missing]
+ }
+ } elseif {[string first . $octet] != -1} {
+ set octet [Normalize4 $octet]
+ } else {
+ set m [expr {4 - [string length $octet]}]
+ if {$m != 0} {
+ set octet [string repeat 0 $m]$octet
+ }
+ set octet [binary format H4 $octet]
+ }
+ append result $octet
+ }
+ if {[string length $result] != 16} {
+ return -code error "invalid address: \"$ip\" is not an IPv6 address"
+ }
+ return $result
+}
+
+
+# This will convert a full ipv4/ipv6 in binary format into a normal
+# expanded string rep.
+proc ::ip::ToString {bin {Ip4inIp6 0}} {
+ set len [string length $bin]
+ set r ""
+ if {$len == 4} {
+ binary scan $bin c4 octets
+ foreach octet $octets {
+ lappend r [expr {$octet & 0xff}]
+ }
+ return [join $r .]
+ } elseif {$len == 16} {
+ if {$Ip4inIp6 == 0} {
+ binary scan $bin H32 hex
+ for {set n 0} {$n < 32} {incr n} {
+ append r [string range $hex $n [incr n 3]]:
+ }
+ return [string trimright $r :]
+ } else {
+ binary scan $bin H24c4 hex octets
+ for {set n 0} {$n < 24} {incr n} {
+ append r [string range $hex $n [incr n 3]]:
+ }
+ foreach octet $octets {
+ append r [expr {$octet & 0xff}].
+ }
+ return [string trimright $r .]
+ }
+ } else {
+ return -code error "invalid binary address:\
+ argument is neither an IPv4 nor an IPv6 address"
+ }
+}
+
+# -------------------------------------------------------------------------
+# Load extended command set.
+
+source [file join [file dirname [info script]] ipMore.tcl]
+
+# -------------------------------------------------------------------------
+
+package provide ip 1.3
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/dns/ip.test b/tcllib/modules/dns/ip.test
new file mode 100644
index 0000000..1affbc4
--- /dev/null
+++ b/tcllib/modules/dns/ip.test
@@ -0,0 +1,271 @@
+# ip.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Tests for the Tcllib ip package
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: ip.test,v 1.9 2010/08/16 17:35:18 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal ip.tcl ip
+}
+
+# -------------------------------------------------------------------------
+# Tests
+# -------------------------------------------------------------------------
+
+# version
+set Data {
+ 127.0.0.1 4
+ 0.0.0.0 4
+ 192.168.0.4 4
+ 255.255.255.255 4
+ 127/8 4
+ 192/16 4
+ :: 6
+ ::1 6
+ fec0::1 6
+ ::192.168.0.4 6
+ fec0:0:0:0:0:0:0:1 6
+ fffe:0:0::2 6
+ 2002:192.168.0.4:: 6
+ 2001:192.168.0.4:: -1
+ 2002:127.0.0.1::1 6
+ hello -1
+ -1 -1
+ 1.2.3.4.example.com -1
+ bogus.1.2.3.4.example.com -1
+ {} -1
+}
+set n 0
+foreach {addr result} $Data {
+ test ip-1.[incr n] [list ip version $addr] {
+ list [catch {ip::version $addr} msg] $addr $msg
+ } [list 0 $addr $result]
+}
+
+# is
+set n 0
+foreach {addr result} $Data {
+ if {$result != 4} {set result 0}
+ test ip-2.[incr n] [list ip::is ipv4 $addr] {
+ list [catch {expr {[ip::is ipv4 $addr] ? 4 : 0}} msg] $addr $msg
+ } [list 0 $addr $result]
+}
+
+set n 0
+foreach {addr result} $Data {
+ if {$result != 6} {set result 0}
+ test ip-3.[incr n] [list ip::is ipv6 $addr] {
+ list [catch {expr {[ip::is ipv6 $addr] ? 6 : 0}} msg] $addr $msg
+ } [list 0 $addr $result]
+}
+
+# normalize
+set Data {
+ 192.168.0.4/32 192.168.0.4
+ 192.168.0.4/24 192.168.0.4/24
+ 192.168 192.168.0.0
+ 192.168/24 192.168.0.0/24
+ 192.168/255.255.0.0 192.168.0.0/255.255.0.0
+ :: 0000:0000:0000:0000:0000:0000:0000:0000
+ ::1 0000:0000:0000:0000:0000:0000:0000:0001
+ fec0::1 fec0:0000:0000:0000:0000:0000:0000:0001
+ fec0:0:0::1 fec0:0000:0000:0000:0000:0000:0000:0001
+ fec0:0::8:0:1 fec0:0000:0000:0000:0000:0008:0000:0001
+ ::192.168.0.4 0000:0000:0000:0000:0000:0000:c0a8:0004
+ ::ffff:192.168.0.4 0000:0000:0000:0000:0000:ffff:c0a8:0004
+ fec0::1/16 fec0:0000:0000:0000:0000:0000:0000:0001/16
+ fec0::1/128 fec0:0000:0000:0000:0000:0000:0000:0001
+ 2002:127.0.0.1::1 2002:7f00:0001:0000:0000:0000:0000:0001
+}
+set n 0
+foreach {addr result} $Data {
+ test ip-4.[incr n] [list ip::normalize $addr] {
+ list [catch {ip::normalize $addr} msg] $msg
+ } [list 0 $result]
+}
+
+set Data {
+ 192.168.1.4 8 192.0.0.0
+ 192.168.1.4 1 128.0.0.0
+ 192.168.1.4 16 192.168.0.0
+ 192.169.1.4 15 192.168.0.0
+ 192.168.1.4 24 192.168.1.0
+ 192.168.1.4 32 192.168.1.4
+ fec0:fafa::1 64 fec0:fafa:0000:0000:0000:0000:0000:0000
+ fec0:fafa::1 8 fe00:0000:0000:0000:0000:0000:0000:0000
+ fec0:fafa::1 10 fec0:0000:0000:0000:0000:0000:0000:0000
+ fec0:fafa::1 128 fec0:fafa:0000:0000:0000:0000:0000:0001
+}
+
+# prefix
+set n 0
+foreach {addr mask prefix} $Data {
+ test ip-5.[incr n] [list ip::prefix $addr/$mask] {
+ list [catch {ip::prefix $addr/$mask} msg] $msg
+ } [list 0 $prefix]
+}
+
+# mask
+
+set n 0
+foreach {addr mask prefix} $Data {
+ test ip-6.[incr n] [list ip::mask $addr/$mask] {
+ list [catch {ip::mask $addr/$mask} msg] $msg
+ } [list 0 $mask]
+}
+
+# equal
+set Data {
+ 192.168.0.4 ::1 1 "type mismatch: cannot compare different address types"
+ 192.168.1.4/16 192.168.0.0/16 0 1
+ 192.169.1.4/16 192.168.0.0/16 0 0
+ 192.169.1.4/15 192.168.0.0/15 0 1
+ 192.168.1.4/24 192.168.1.0/24 0 1
+ 127/8 192/8 0 0
+ 192.168.1.4/255.255.0.0 192.168.1.4/16 0 1
+ 192.169.1.4/255.255.0.0 192.168.1.4/16 0 0
+ 192.169.1.4/255.254.0.0 192.168.1.4/16 0 1
+
+ fec0::1/10 fec0::2/10 0 1
+ ::1/64 ::2/64 0 1
+ ::1/128 ::2/128 0 0
+ ::1/127 ::2/127 0 0
+ ::1/126 ::2/126 0 1
+ fec0:ffff::1/16 fec0:aaaa::2/16 0 1
+ fec0:ffff::1/17 fec0:aaaa::2/17 0 1
+ fec0:ffff::1/18 fec0:aaaa::2/18 0 0
+}
+set n 0
+foreach {lhs rhs err result} $Data {
+ test ip-7.[incr n] [list ip::equal $lhs $rhs] {
+ list [catch {ip::equal $lhs $rhs} msg] $msg
+ } [list $err $result]
+}
+
+# contract
+set Data {
+ 127.0.0.1 127.0.0.1
+ 127.0.0.0 127
+ 0000:0000:0000:0000:0000:0000:0000:0000 ::
+ 0000:0000:0000:0000:0000:0000:0000:0001 ::1
+ fec0:0000:0000:0000:0000:0000:0000:0000 fec0::
+ fec0:0000:0000:0000:0000:0000:0000:0001 fec0::1
+ fec0:0000:0001:0000:0000:0000:0000:0001 fec0:0:1::1
+ fec0:0001:0002:0003:0004:0005:0006:0001 fec0:1:2:3:4:5:6:1
+ fec0:0001:2002:0003:0004:0005:0006:0001 fec0:1:2002:3:4:5:6:1
+}
+set n 0
+foreach {addr result} $Data {
+ test ip-8.[incr n] [list ip::contract $addr] {
+ list [catch {ip::contract $addr} msg] $msg
+ } [list 0 $result]
+}
+
+# -------------------------------------------------------------------------
+
+test ip-9.0 {collapse} {
+ ip::collapse {1.2.2.0/24 1.2.3.0/24}
+} 1.2.2.0/23
+
+test ip-9.1 {collapse revers} {
+ ip::collapse {1.2.3.0/24 1.2.2.0/24}
+} 1.2.2.0/23
+
+test ip-9.2 {collapse} {
+ set l {}
+ for {set n 0} {$n < 256} {incr n} {
+ lappend l 1.2.$n.0/24
+ }
+ ip::collapse $l
+} {1.2.0.0/16}
+
+test ip-9.3 {collapse revers} {
+ set l {}
+ for {set n 255} {$n >= 0} {incr n -1} {
+ lappend l 1.2.$n.0/24
+ }
+ ip::collapse $l
+} {1.2.0.0/16}
+
+test ip-9.4 {collapse} {
+ ip::collapse {1.2.2.0/255.255.255.0 1.2.3.0/255.255.255.0}
+} 1.2.2.0/23
+
+test ip-9.5 {collapse revers} {
+ ip::collapse {1.2.3.0/255.255.255.0 1.2.2.0/255.255.255.0}
+} 1.2.2.0/23
+
+# -------------------------------------------------------------------------
+
+test ip-10.0 {subtract} {
+ ip::collapse [ip::subtract {1.2.0.0/16 1.3.0.0/16 -1.2.4.0/24}]
+} {1.2.0.0/22 1.2.5.0/24 1.2.6.0/23 1.2.8.0/21 1.2.16.0/20 1.2.32.0/19 1.2.64.0/18 1.2.128.0/17 1.3.0.0/16}
+
+# -------------------------------------------------------------------------
+
+foreach {i m e} {
+ 0 255.255.255.255 32 5 0xffffffff 32
+ 1 255.255.255.0 24 6 0xffffff00 24
+ 2 255.255.0.0 16 7 0xffff0000 16
+ 3 255.0.0.0 8 8 0xff000000 8
+ 4 0.0.0.0 0 9 0x00000000 0
+} {
+ test ip-11.$i "maskToLength, $m" {
+ ip::maskToLength $m
+ } $e
+}
+
+# -------------------------------------------------------------------------
+
+foreach {i ip e} {
+ 0 0.0.0.0 0
+ 1 0.0.0.1 1
+ 2 0.0.1.0 256
+ 3 0.1.0.0 65536
+ 4 1.0.0.0 16777216
+ 5 0.0.0.255 255
+ 6 0.0.255.0 65280
+ 7 0.255.0.0 16711680
+ 8 255.0.0.0 4278190080
+ 9 255.255.255.255 4294967295
+} {
+ test ip-12.$i "toInteger $ip" {
+ ip::toInteger $ip
+ } $e
+}
+
+# -------------------------------------------------------------------------
+
+foreach {i pma e} {
+ 0 {1.1.1.1 24} 1.1.2.1/0
+ 1 {1.1.1.1 24 0} 1.1.1.1/0
+ 2 {1.1.1.1 24 1} 1.1.2.1/0
+ 3 {1.1.1.1 24 2} 1.1.3.1/0
+} {
+ test ip-13.$i "nextNet $pma" {
+ ip::nativeToPrefix [eval ip::nextNet $pma]
+ } $e
+}
+
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/dns/ipMore.tcl b/tcllib/modules/dns/ipMore.tcl
new file mode 100644
index 0000000..942f64c
--- /dev/null
+++ b/tcllib/modules/dns/ipMore.tcl
@@ -0,0 +1,1295 @@
+#temporary home until this gets cleaned up for export to tcllib ip module
+# $Id: ipMore.tcl,v 1.4 2006/01/22 00:27:22 andreas_kupries Exp $
+
+
+##Library Header
+#
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ipMore
+#
+# Purpose:
+# Additional commands for the tcllib ip package.
+#
+# Author:
+# Aamer Akhter / aakhter@cisco.com
+#
+# Support Alias:
+# aakhter@cisco.com
+#
+# Usage:
+# package require ip
+# (The command are loaded from the regular package).
+#
+# Description:
+# A detailed description of the functionality provided by the library.
+#
+# Requirements:
+#
+# Variables:
+# namespace ::ip
+#
+# Notes:
+# 1.
+#
+# Keywords:
+#
+#
+# Category:
+#
+#
+# End of Header
+
+package require msgcat
+
+# Try to load various C based accelerator packages for two of the
+# commands.
+
+if {[catch {package require ipMorec}]} {
+ catch {package require tcllibc}
+}
+
+if {[llength [info commands ::ip::prefixToNativec]]} {
+ # An accelerator is present, providing the C variants
+ interp alias {} ::ip::prefixToNative {} ::ip::prefixToNativec
+ interp alias {} ::ip::isOverlapNative {} ::ip::isOverlapNativec
+} else {
+ # Link API to the Tcl variants, no accelerators are available.
+ interp alias {} ::ip::prefixToNative {} ::ip::prefixToNativeTcl
+ interp alias {} ::ip::isOverlapNative {} ::ip::isOverlapNativeTcl
+}
+
+namespace eval ::ip {
+ ::msgcat::mcload [file join [file dirname [info script]] msgs]
+}
+
+if {![llength [info commands lassign]]} {
+ # Either an older tcl version, or tclx not loaded; have to use our
+ # internal lassign from http://wiki.tcl.tk/1530 by Schelte Bron
+
+ proc ::ip::lassign {values args} {
+ uplevel 1 [list foreach $args $values break]
+ lrange $values [llength $args] end
+ }
+}
+if {![llength [info commands lvarpop]]} {
+ # Define an emulation of Tclx's lvarpop if the command
+ # is not present already.
+
+ proc ::ip::lvarpop {upVar {index 0}} {
+ upvar $upVar list;
+ set top [lindex $list $index];
+ set list [concat [lrange $list 0 [expr $index - 1]] \
+ [lrange $list [expr $index +1] end]];
+ return $top;
+ }
+}
+
+# Some additional aliases for backward compatability. Not
+# documented. The old names are from previous versions while at Cisco.
+#
+# Old command name --> Documented command name
+interp alias {} ::ip::ToInteger {} ::ip::toInteger
+interp alias {} ::ip::ToHex {} ::ip::toHex
+interp alias {} ::ip::MaskToInt {} ::ip::maskToInt
+interp alias {} ::ip::MaskToLength {} ::ip::maskToLength
+interp alias {} ::ip::LengthToMask {} ::ip::lengthToMask
+interp alias {} ::ip::IpToLayer2Multicast {} ::ip::ipToLayer2Multicast
+interp alias {} ::ip::IpHostFromPrefix {} ::ip::ipHostFromPrefix
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::prefixToNative
+#
+# Purpose:
+# convert from dotted from to native (hex) form
+#
+# Synopsis:
+# prefixToNative <prefix>
+#
+# Arguments:
+# <prefix>
+# string in the <ipaddr>/<mask> format
+#
+# Return Values:
+# <prefix> in native format {<hexip> <hexmask>}
+#
+# Description:
+#
+# Examples:
+# % ip::prefixToNative 1.1.1.0/24
+# 0x01010100 0xffffff00
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+# fixed bug in C extension that modified
+# calling context variable
+# See Also:
+#
+# End of Header
+
+proc ip::prefixToNativeTcl {prefix} {
+ set plist {}
+ foreach p $prefix {
+ set newPrefix [ip::toHex [ip::prefix $p]]
+ if {[string equal [set mask [ip::mask $p]] ""]} {
+ set newMask 0xffffffff
+ } else {
+ set newMask [format "0x%08x" [ip::maskToInt $mask]]
+ }
+ lappend plist [list $newPrefix $newMask]
+ }
+ if {[llength $plist]==1} {return [lindex $plist 0]}
+ return $plist
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::nativeToPrefix
+#
+# Purpose:
+# convert from native (hex) form to dotted form
+#
+# Synopsis:
+# nativeToPrefix <nativeList>|<native> [-ipv4]
+#
+# Arguments:
+# <nativeList>
+# list of native form ip addresses native form is:
+# <native>
+# tcllist in format {<hexip> <hexmask>}
+# -ipv4
+# the provided native format addresses are in ipv4 format (default)
+#
+# Return Values:
+# if nativeToPrefix is called with <native> a single (non-listified) address
+# is returned
+# if nativeToPrefix is called with a <nativeList> address list, then
+# a list of addresses is returned
+#
+# return form is: <ipaddr>/<mask>
+#
+# Description:
+#
+# Examples:
+# % ip::nativeToPrefix {0x01010100 0xffffff00} -ipv4
+# 1.1.1.0/24
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::nativeToPrefix {nativeList args} {
+ set pList 1
+ set ipv4 1
+ while {[llength $args]} {
+ switch -- [lindex $args 0] {
+ -ipv4 {set args [lrange $args 1 end]}
+ default {
+ return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+ }
+ }
+ }
+
+ # if a single native element is passed eg {0x01010100 0xffffff00}
+ # instead of {{0x01010100 0xffffff00} {0x01010100 0xffffff00}...}
+ # then return a (non-list) single entry
+ if {[llength [lindex $nativeList 0]]==1} {set pList 0; set nativeList [list $nativeList]}
+ foreach native $nativeList {
+ lassign $native ip mask
+ if {[string equal $mask ""]} {set mask 32}
+ set pString ""
+ append pString [ip::ToString [binary format I [expr {$ip}]]]
+ append pString "/"
+ append pString [ip::maskToLength $mask]
+ lappend rList $pString
+ }
+ # a multi (listified) entry was given
+ # return the listified entry
+ if {$pList} { return $rList }
+ return $pString
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::intToString
+#
+# Purpose:
+# convert from an integer/hex to dotted form
+#
+# Synopsis:
+# intToString <integer/hex> [-ipv4]
+#
+# Arguments:
+# <integer>
+# ip address in integer form
+# -ipv4
+# the provided integer addresses is ipv4 (default)
+#
+# Return Values:
+# ip address in dotted form
+#
+# Description:
+#
+# Examples:
+# ip::intToString 4294967295
+# 255.255.255.255
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::intToString {int args} {
+ set ipv4 1
+ while {[llength $args]} {
+ switch -- [lindex $args 0] {
+ -ipv4 {set args [lrange $args 1 end]}
+ default {
+ return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+ }
+ }
+ }
+ return [ip::ToString [binary format I [expr {$int}]]]
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::toInteger
+#
+# Purpose:
+# convert dotted form ip to integer
+#
+# Synopsis:
+# toInteger <ipaddr>
+#
+# Arguments:
+# <ipaddr>
+# decimal dotted form ip address
+#
+# Return Values:
+# integer form of <ipaddr>
+#
+# Description:
+#
+# Examples:
+# % ::ip::toInteger 1.1.1.0
+# 16843008
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::toInteger {ip} {
+ binary scan [ip::Normalize4 $ip] I out
+ return [format %lu [expr {$out & 0xffffffff}]]
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::toHex
+#
+# Purpose:
+# convert dotted form ip to hex
+#
+# Synopsis:
+# toHex <ipaddr>
+#
+# Arguments:
+# <ipaddr>
+# decimal dotted from ip address
+#
+# Return Values:
+# hex form of <ipaddr>
+#
+# Description:
+#
+# Examples:
+# % ::ip::toHex 1.1.1.0
+# 0x01010100
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::toHex {ip} {
+ binary scan [ip::Normalize4 $ip] H8 out
+ return "0x$out"
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::maskToInt
+#
+# Purpose:
+# convert mask to integer
+#
+# Synopsis:
+# maskToInt <mask>
+#
+# Arguments:
+# <mask>
+# mask in either dotted form or mask length form (255.255.255.0 or 24)
+#
+# Return Values:
+# integer form of mask
+#
+# Description:
+#
+# Examples:
+# ::ip::maskToInt 24
+# 4294967040
+#
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::maskToInt {mask} {
+ if {[string is integer -strict $mask]} {
+ set maskInt [expr {(0xFFFFFFFF << (32 - $mask))}]
+ } else {
+ binary scan [Normalize4 $mask] I maskInt
+ }
+ set maskInt [expr {$maskInt & 0xFFFFFFFF}]
+ return [format %u $maskInt]
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::broadcastAddress
+#
+# Purpose:
+# return broadcast address given prefix
+#
+# Synopsis:
+# broadcastAddress <prefix> [-ipv4]
+#
+# Arguments:
+# <prefix>
+# route in the form of <ipaddr>/<mask> or native form {<hexip> <hexmask>}
+# -ipv4
+# the provided native format addresses are in ipv4 format (default)
+# note: broadcast addresses are not valid in ipv6
+#
+#
+# Return Values:
+# ipaddress of broadcast
+#
+# Description:
+#
+# Examples:
+# ::ip::broadcastAddress 1.1.1.0/24
+# 1.1.1.255
+#
+# ::ip::broadcastAddress {0x01010100 0xffffff00}
+# 0x010101ff
+#
+# Sample Input:
+#
+# Sample Output:
+
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::broadcastAddress {prefix args} {
+ set ipv4 1
+ while {[llength $args]} {
+ switch -- [lindex $args 0] {
+ -ipv4 {set args [lrange $args 1 end]}
+ default {
+ return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+ }
+ }
+ }
+ if {[llength $prefix] == 2} {
+ lassign $prefix net mask
+ } else {
+ set net [maskToInt [ip::prefix $prefix]]
+ set mask [maskToInt [ip::mask $prefix]]
+ }
+ set ba [expr {$net | ((~$mask)&0xffffffff)}]
+
+ if {[llength $prefix]==2} {
+ return [format "0x%08x" $ba]
+ }
+ return [ToString [binary format I $ba]]
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::maskToLength
+#
+# Purpose:
+# converts dotted or integer form of mask to length
+#
+# Synopsis:
+# maskToLength <dottedMask>|<integerMask>|<hexMask> [-ipv4]
+#
+# Arguments:
+# <dottedMask>
+# <integerMask>
+# <hexMask>
+# mask to convert to prefix length format (eg /24)
+# -ipv4
+# the provided integer/hex format masks are ipv4 (default)
+#
+# Return Values:
+# prefix length
+#
+# Description:
+#
+# Examples:
+# ::ip::maskToLength 0xffffff00 -ipv4
+# 24
+#
+# % ::ip::maskToLength 255.255.255.0
+# 24
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::maskToLength {mask args} {
+ set ipv4 1
+ while {[llength $args]} {
+ switch -- [lindex $args 0] {
+ -ipv4 {set args [lrange $args 1 end]}
+ default {
+ return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+ }
+ }
+ }
+ #pick the fastest method for either format
+ if {[string is integer -strict $mask]} {
+ binary scan [binary format I [expr {$mask}]] B32 maskB
+ if {[regexp -all {^1+} $maskB ones]} {
+ return [string length $ones]
+ } else {
+ return 0
+ }
+ } else {
+ regexp {\/(.+)} $mask dumb mask
+ set prefix 0
+ foreach ipByte [split $mask {.}] {
+ switch $ipByte {
+ 255 {incr prefix 8; continue}
+ 254 {incr prefix 7}
+ 252 {incr prefix 6}
+ 248 {incr prefix 5}
+ 240 {incr prefix 4}
+ 224 {incr prefix 3}
+ 192 {incr prefix 2}
+ 128 {incr prefix 1}
+ 0 {}
+ default {
+ return -code error [msgcat::mc "not an ip mask: %s" $mask]
+ }
+ }
+ break
+ }
+ return $prefix
+ }
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::lengthToMask
+#
+# Purpose:
+# converts mask length to dotted mask form
+#
+# Synopsis:
+# lengthToMask <maskLength> [-ipv4]
+#
+# Arguments:
+# <maskLength>
+# mask length
+# -ipv4
+# the provided mask length is ipv4 (default)
+#
+# Return Values:
+# mask in dotted form
+#
+# Description:
+#
+# Examples:
+# ::ip::lengthToMask 24
+# 255.255.255.0
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::lengthToMask {masklen args} {
+ while {[llength $args]} {
+ switch -- [lindex $args 0] {
+ -ipv4 {set args [lrange $args 1 end]}
+ default {
+ return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+ }
+ }
+ }
+ # the fastest method is just to look
+ # thru an array
+ return $::ip::maskLenToDotted($masklen)
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::nextNet
+#
+# Purpose:
+# returns next an ipaddress in same position in next network
+#
+# Synopsis:
+# nextNet <ipaddr> <mask> [<count>] [-ipv4]
+#
+# Arguments:
+# <ipaddress>
+# in hex/integer/dotted format
+# <mask>
+# mask in hex/integer/dotted/maskLen format
+# <count>
+# number of nets to skip over (default is 1)
+# -ipv4
+# the provided hex/integer addresses are in ipv4 format (default)
+#
+# Return Values:
+# ipaddress in same position in next network in hex
+#
+# Description:
+#
+# Examples:
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::nextNet {prefix mask args} {
+ set count 1
+ while {[llength $args]} {
+ switch -- [lindex $args 0] {
+ -ipv4 {set args [lrange $args 1 end]}
+ default {
+ set count [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ }
+ }
+ if {![string is integer -strict $prefix]} {
+ set prefix [toInteger $prefix]
+ }
+ if {![string is integer -strict $mask] || ($mask < 33 && $mask > 0)} {
+ set mask [maskToInt $mask]
+ }
+ set prefix [expr {$prefix + ((($mask ^ 0xFFffFFff) + 1) * $count) }]
+ return [format "0x%08x" $prefix]
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::isOverlap
+#
+# Purpose:
+# checks to see if prefixes overlap
+#
+# Synopsis:
+# isOverlap <prefix> <prefix1> <prefix2>...
+#
+# Arguments:
+# <prefix>
+# in form <ipaddr>/<mask> prefix to compare <prefixN> against
+# <prefixN>
+# in form <ipaddr>/<mask> prefixes to compare against
+#
+# Return Values:
+# 1 if there is an overlap
+#
+# Description:
+#
+# Examples:
+# % ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32
+# 0
+#
+# ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32 1.1.1.1/32
+# 1
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::isOverlap {ip args} {
+ lassign [SplitIp $ip] ip1 mask1
+ set ip1int [toInteger $ip1]
+ set mask1int [maskToInt $mask1]
+
+ set overLap 0
+ foreach prefix $args {
+ lassign [SplitIp $prefix] ip2 mask2
+ set ip2int [toInteger $ip2]
+ set mask2int [maskToInt $mask2]
+ set mask1mask2 [expr {$mask1int & $mask2int}]
+ if {[expr {$ip1int & $mask1mask2}] == [expr {$ip2int & $mask1mask2}]} {
+ set overLap 1
+ break
+ }
+ }
+ return $overLap
+}
+
+
+#optimized overlap, that accepts native format
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::isOverlapNative
+#
+# Purpose:
+# checks to see if prefixes overlap (optimized native form)
+#
+# Synopsis:
+# isOverlap <hexipaddr> <hexmask> {{<hexipaddr1> <hexmask1>} {<hexipaddr2> <hexmask2>...}
+#
+# Arguments:
+# -all
+# return all overlaps rather than the first one
+# -inline
+# rather than returning index values, return the actual overlap prefixes
+# <hexipaddr>
+# ipaddress in hex/integer form
+# <hexMask>
+# mask in hex/integer form
+# -ipv4
+# the provided native format addresses are in ipv4 format (default)
+#
+# Return Values:
+# non-zero if there is an overlap, value is element # in list with overlap
+#
+# Description:
+# isOverlapNative is available both as a C extension and in a native tcl form
+# if the extension is loaded (tried automatically), isOverlapNative will be
+# linked to isOverlapNativeC. If an extension is not loaded, then isOverlapNative
+# will be linked to the native tcl proc: ipOverlapNativeTcl.
+#
+# Examples:
+# % ::ip::isOverlapNative 0x01010100 0xffffff00 {{0x02010001 0xffffffff}}
+# 0
+#
+# %::ip::isOverlapNative 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}}
+# 2
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::isOverlapNativeTcl {args} {
+ set all 0
+ set inline 0
+ set notOverlap 0
+ set ipv4 1
+ foreach sw [lrange $args 0 end-3] {
+ switch -exact -- $sw {
+ -all {
+ set all 1
+ set allList [list]
+ }
+ -inline {set inline 1}
+ -ipv4 {}
+ }
+ }
+ set args [lassign [lrange $args end-2 end] ip1int mask1int prefixList]
+ if {$inline} {
+ set overLap [list]
+ } else {
+ set overLap 0
+ }
+ set count 0
+ foreach prefix $prefixList {
+ incr count
+ lassign $prefix ip2int mask2int
+ set mask1mask2 [expr {$mask1int & $mask2int}]
+ if {[expr {$ip1int & $mask1mask2}] == [expr {$ip2int & $mask1mask2}]} {
+ if {$inline} {
+ set overLap [list $prefix]
+ } else {
+ set overLap $count
+ }
+ if {$all} {
+ if {$inline} {
+ lappend allList $prefix
+ } else {
+ lappend allList $count
+ }
+ } else {
+ break
+ }
+ }
+ }
+ if {$all} {return $allList}
+ return $overLap
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::ipToLayer2Multicast
+#
+# Purpose:
+# converts ipv4 address to a layer 2 multicast address
+#
+# Synopsis:
+# ipToLayer2Multicast <ipaddr>
+#
+# Arguments:
+# <ipaddr>
+# ipaddress in dotted form
+#
+# Return Values:
+# mac address in xx.xx.xx.xx.xx.xx form
+#
+# Description:
+#
+# Examples:
+# % ::ip::ipToLayer2Multicast 224.0.0.2
+# 01.00.5e.00.00.02
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::ipToLayer2Multicast { ipaddr } {
+ regexp "\[0-9\]+\.(\[0-9\]+)\.(\[0-9\]+)\.(\[0-9\]+)" $ipaddr junk ip2 ip3 ip4
+ #remove MSB of 2nd octet of IP address for mcast L2 addr
+ set mac2 [expr {$ip2 & 127}]
+ return [format "01.00.5e.%02x.%02x.%02x" $mac2 $ip3 $ip4]
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::ipHostFromPrefix
+#
+# Purpose:
+# gives back a host address from a prefix
+#
+# Synopsis:
+# ::ip::ipHostFromPrefix <prefix> [-exclude <list of prefixes>]
+#
+# Arguments:
+# <prefix>
+# prefix is <ipaddr>/<masklen>
+# -exclude <list of prefixes>
+# list if ipprefixes that host should not be in
+# Return Values:
+# ip address
+#
+# Description:
+#
+# Examples:
+# %::ip::ipHostFromPrefix 1.1.1.5/24
+# 1.1.1.1
+#
+# %::ip::ipHostFromPrefix 1.1.1.1/32
+# 1.1.1.1
+#
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::ipHostFromPrefix { prefix args } {
+ set mask [mask $prefix]
+ set ipaddr [prefix $prefix]
+ if {[llength $args]} {
+ array set opts $args
+ } else {
+ if {$mask==32} {
+ return $ipaddr
+ } else {
+ return [intToString [expr {[toHex $ipaddr] + 1} ]]
+ }
+ }
+ set format {-ipv4}
+ # if we got here, then options were set
+ if {[info exists opts(-exclude)]} {
+ #basic algo is:
+ # 1. throw away prefixes that are less specific that $prefix
+ # 2. of remaining pfx, throw away prefixes that do not overlap
+ # 3. run reducetoAggregates on specific nets
+ # 4.
+
+ # 1. convert to hex format
+ set currHex [prefixToNative $prefix ]
+ set exclHex [prefixToNative $opts(-exclude) ]
+ # sort the prefixes by their mask, include the $prefix as a marker
+ # so we know from where to throw away prefixes
+ set sortedPfx [lsort -integer -index 1 [concat [list $currHex] $exclHex]]
+ # throw away prefixes that are less specific than $prefix
+ set specPfx [lrange $sortedPfx [expr {[lsearch -exact $sortedPfx $currHex] +1} ] end]
+
+ #2. throw away non-overlapping prefixes
+ set specPfx [isOverlapNative -all -inline \
+ [lindex $currHex 0 ] \
+ [lindex $currHex 1 ] \
+ $specPfx ]
+ #3. run reduce aggregates
+ set specPfx [reduceToAggregates $specPfx]
+
+ #4 now have to pick an address that overlaps with $currHex but not with
+ # $specPfx
+ # 4.1 find the largest prefix w/ most specific mask and go to the next net
+
+
+ # current ats tcl does not allow this in one command, so
+ # for now just going to grab the last prefix (list is already sorted)
+ set sPfx [lindex $specPfx end]
+ set startPfx $sPfx
+ # add currHex to specPfx
+ set oChkPfx [concat $specPfx [list $currHex]]
+
+
+ set notcomplete 1
+ set overflow 0
+ while {$notcomplete} {
+ #::ipMore::log::debug "doing nextnet on $sPfx"
+ set nextNet [nextNet [lindex $sPfx 0] [lindex $sPfx 1]]
+ #::ipMore::log::debug "trying $nextNet"
+ if {$overflow && ($nextNet > $startPfx)} {
+ #we've gone thru the entire net and didn't find anything.
+ return -code error [msgcat::mc "ip host could not be found in %s" $prefix]
+ break
+ }
+ set oPfx [isOverlapNative -all -inline \
+ $nextNet -1 \
+ $oChkPfx
+ ]
+ switch -exact [llength $oPfx] {
+ 0 {
+ # no overlap at all. meaning we have gone beyond the bounds of
+ # $currHex. need to overlap and try again
+ #::ipMore::log::debug {ipHostFromPrefix: overlap done}
+ set overflow 1
+ }
+ 1 {
+ #we've found what we're looking for. pick this address and exit
+ return [intToString $nextNet]
+ }
+ default {
+ # 2 or more overlaps, need to increment again
+ set sPfx [lindex $oPfx 0]
+ }
+ }
+ }
+ }
+}
+
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::reduceToAggregates
+#
+# Purpose:
+# finds nets that overlap and filters out the more specifc nets
+#
+# Synopsis:
+# ::ip::reduceToAggregates <prefixList>
+#
+# Arguments:
+# <prefixList>
+# prefixList a list in the from of
+# is <ipaddr>/<masklen> or native format
+#
+# Return Values:
+# non-overlapping ip prefixes
+#
+# Description:
+#
+# Examples:
+#
+# % ::ip::reduceToAggregates {1.1.1.0/24 1.1.0.0/8 2.1.1.0/24 1.1.1.1/32 }
+# 1.0.0.0/8 2.1.1.0/24
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::reduceToAggregates { prefixList } {
+ #find out format of $prefixeList
+ set dotConv 0
+ if {[llength [lindex $prefixList 0]]==1} {
+ #format is dotted form convert all prefixes to native form
+ set prefixList [ip::prefixToNative $prefixList]
+ set dotConv 1
+ }
+
+ set nonOverLapping $prefixList
+ while {1==1} {
+ set overlapFound 0
+ set remaining $nonOverLapping
+ set nonOverLapping {}
+ while {[llength $remaining]} {
+ set current [lvarpop remaining]
+ set overLap [ip::isOverlapNative [lindex $current 0] [lindex $current 1] $remaining]
+ if {$overLap} {
+ #there was a overlap find out which prefix has a the smaller mask, and keep that one
+ if {[lindex $current 1] > [lindex [lindex $remaining [expr {$overLap -1}]] 1]} {
+ #current has more restrictive mask, throw that prefix away
+ # keep other prefix
+ lappend nonOverLapping [lindex $remaining [expr {$overLap -1}]]
+ } else {
+ lappend nonOverLapping $current
+ }
+ lvarpop remaining [expr {$overLap -1}]
+ set overlapFound 1
+ } else {
+ #no overlap, keep all prefixes, don't touch the stuff in
+ # remaining, it is needed for other overlap checking
+ lappend nonOverLapping $current
+ }
+ }
+ if {$overlapFound==0} {break}
+ }
+ if {$dotConv} {return [nativeToPrefix $nonOverLapping]}
+ return $nonOverLapping
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::longestPrefixMatch
+#
+# Purpose:
+# given host IP finds longest prefix match from set of prefixes
+#
+# Synopsis:
+# ::ip::longestPrefixMatch <ipaddr> <prefixList> [-ipv4]
+#
+# Arguments:
+# <prefixList>
+# is list of <ipaddr> in native or dotted form
+# <ipaddr>
+# ip address in <ipprefix> format, dotted form, or integer form
+# -ipv4
+# the provided integer format addresses are in ipv4 format (default)
+#
+# Return Values:
+# <ipprefix> that is the most specific match to <ipaddr>
+#
+# Description:
+#
+# Examples:
+# % ::ip::longestPrefixMatch 1.1.1.1 {1.1.1.0/24 1.0.0.0/8 2.1.1.0/24 1.1.1.0/28 }
+# 1.1.1.0/28
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+
+proc ::ip::longestPrefixMatch { ipaddr prefixList args} {
+ set ipv4 1
+ while {[llength $args]} {
+ switch -- [lindex $args 0] {
+ -ipv4 {set args [lrange $args 1 end]}
+ default {
+ return -code error [msgcat::mc "option %s not supported" [lindex $args 0]]
+ }
+ }
+ }
+ #find out format of prefixes
+ set dotConv 0
+ if {[llength [lindex $prefixList 0]]==1} {
+ #format is dotted form convert all prefixes to native form
+ set prefixList [ip::prefixToNative $prefixList]
+ set dotConv 1
+ }
+ #sort so that most specific prefix is in the front
+ if {[llength [lindex [lindex $prefixList 0] 1]]} {
+ set prefixList [lsort -decreasing -integer -index 1 $prefixList]
+ } else {
+ set prefixList [list $prefixList]
+ }
+ if {![string is integer -strict $ipaddr]} {
+ set ipaddr [prefixToNative $ipaddr]
+ }
+ set best [ip::isOverlapNative -inline \
+ [lindex $ipaddr 0] [lindex $ipaddr 1] $prefixList]
+ if {$dotConv && [llength $best]} {
+ return [nativeToPrefix $best]
+ }
+ return $best
+}
+
+##Procedure Header
+# Copyright (c) 2004 Cisco Systems, Inc.
+#
+# Name:
+# ::ip::cmpDotIP
+#
+# Purpose:
+# helper function for dotted ip address for use in lsort
+#
+# Synopsis:
+# ::ip::cmpDotIP <ipaddr1> <ipaddr2>
+#
+# Arguments:
+# <ipaddr1> <ipaddr2>
+# prefix is in dotted ip address format
+#
+# Return Values:
+# -1 if ipaddr1 is less that ipaddr2
+# 1 if ipaddr1 is more that ipaddr2
+# 0 if ipaddr1 and ipaddr2 are equal
+#
+# Description:
+#
+# Examples:
+# % lsort -command ip::cmpDotIP {1.0.0.0 2.2.0.0 128.0.0.0 3.3.3.3}
+# 1.0.0.0 2.2.0.0 3.3.3.3 128.0.0.0
+#
+# Sample Input:
+#
+# Sample Output:
+# Notes:
+#
+# See Also:
+#
+# End of Header
+# ip address in <ipprefix> format, dotted form, or integer form
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {
+ # 8.3+
+ proc ip::cmpDotIP {ipaddr1 ipaddr2} {
+ # convert dotted to list of integers
+ set ipaddr1 [split $ipaddr1 .]
+ set ipaddr2 [split $ipaddr2 .]
+ foreach a $ipaddr1 b $ipaddr2 {
+ #ipMore::log::debug "$ipInt1 $ipInt2"
+ if { $a < $b} {
+ return -1
+ } elseif {$a >$b} {
+ return 1
+ }
+ }
+ return 0
+ }
+} else {
+ # 8.4+
+ proc ip::cmpDotIP {ipaddr1 ipaddr2} {
+ # convert dotted to decimal
+ set ipInt1 [::ip::toHex $ipaddr1]
+ set ipInt2 [::ip::toHex $ipaddr2]
+ #ipMore::log::debug "$ipInt1 $ipInt2"
+ if { $ipInt1 < $ipInt2} {
+ return -1
+ } elseif {$ipInt1 >$ipInt2 } {
+ return 1
+ } else {
+ return 0
+ }
+ }
+}
+
+# Populate the array "maskLenToDotted" for fast lookups of mask to
+# dotted form.
+
+namespace eval ::ip {
+ variable maskLenToDotted
+ variable x
+
+ for {set x 0} {$x <33} {incr x} {
+ set maskLenToDotted($x) [intToString [maskToInt $x]]
+ }
+ unset x
+}
+
+##Procedure Header
+# Copyright (c) 2015 Martin Heinrich <martin.heinrich@frequentis.com>
+#
+# Name:
+# ::ip::distance
+#
+# Purpose:
+# Calculate integer distance between two IPv4 addresses (dotted form or int)
+#
+# Synopsis:
+# distance <ipaddr1> <ipaddr2>
+#
+# Arguments:
+# <ipaddr1>
+# <ipaddr2>
+# ip address
+#
+# Return Values:
+# integer distance (addr2 - addr1)
+#
+# Description:
+#
+# Examples:
+# % ::ip::distance 1.1.1.0 1.1.1.5
+# 5
+#
+# Sample Input:
+#
+# Sample Output:
+
+proc ::ip::distance {ip1 ip2} {
+ # use package ip for normalization
+ # XXX does not support ipv6
+ expr {[toInteger $ip2]-[toInteger $ip1]}
+}
+
+##Procedure Header
+# Copyright (c) 2015 Martin Heinrich <martin.heinrich@frequentis.com>
+#
+# Name:
+# ::ip::nextIp
+#
+# Purpose:
+# Increment the given IPv4 address by an offset.
+# Complement to 'distance'.
+#
+# Synopsis:
+# nextIp <ipaddr> ?<offset>?
+#
+# Arguments:
+# <ipaddr>
+# ip address
+#
+# <offset>
+# The integer to increment the address by.
+# Default is 1.
+#
+# Return Values:
+# The increment ip address.
+#
+# Description:
+#
+# Examples:
+# % ::ip::nextIp 1.1.1.0 5
+# 1.1.1.5
+#
+# Sample Input:
+#
+# Sample Output:
+
+proc ::ip::nextIp {ip {offset 1}} {
+ set int [toInteger $ip]
+ incr int $offset
+ set prot {}
+ # TODO if ipv4 then set prot -ipv4, but
+ # XXX intToString has -ipv4, but never returns ipv6
+ intToString $int ;# 8.5-ism, avoid: {*}$prot
+}
diff --git a/tcllib/modules/dns/ipMore.test b/tcllib/modules/dns/ipMore.test
new file mode 100644
index 0000000..246be8d
--- /dev/null
+++ b/tcllib/modules/dns/ipMore.test
@@ -0,0 +1,803 @@
+# ip.test -*- tcl -*-
+#
+# Tests for the Tcllib ip package
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: ipMore.test,v 1.4 2006/10/09 21:41:40 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 2.2
+
+testing {
+ useLocal ip.tcl ip
+}
+
+# -------------------------------------------------------------------------
+
+::tcltest::testConstraint Cextension \
+ [llength [info commands ::ip::prefixToNativec]]
+
+# -------------------------------------------------------------------------
+
+logger::setlevel critical
+
+namespace eval ::ip::test {
+
+ ::tcltest::test load-1 {} -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ } -result {}
+
+ ::tcltest::test ip::prefixToNativeTcl-1 {} -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ip::prefixToNativeTcl 1.1.1.0/24
+ } -result {0x01010100 0xffffff00}
+
+ ::tcltest::test ip::prefixToNativeTcl-2 {} -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ip::prefixToNativeTcl {1.1.1.0/24 1.0.0.0/8 2.1.1.0/24 1.1.1.1/32}
+ } -result {{0x01010100 0xffffff00} {0x01000000 0xff000000} {0x02010100 0xffffff00} {0x01010101 0xffffffff}}
+
+ ::tcltest::test ip::prefixToNativeTcl-3 {} -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ip::prefixToNativeTcl ""
+ } -result {}
+
+ ::tcltest::test ip::prefixToNativec-1 {} -setup {
+ } -constraints {
+ Cextension
+ } -cleanup {
+ } -body {
+ ip::prefixToNativec 1.1.1.0/24
+ } -result {0x01010100 0xFFFFFF00}
+
+ ::tcltest::test ip::prefixToNativec-2 {} -setup {
+ } -constraints {
+ Cextension
+ } -cleanup {
+ } -body {
+ ip::prefixToNativec 1.1.1.0/255.255.255.0
+ } -result {0x01010100 0xFFFFFF00}
+
+ ::tcltest::test ip::prefixToNativec-3 {} -setup {
+ } -constraints {
+ Cextension
+ } -cleanup {
+ } -body {
+ ip::prefixToNativec 1.1.1.0
+ } -result {0x01010100 0xFFFFFFFF}
+
+ ::tcltest::test ip::prefixToNativec-4 {} -setup {
+ } -constraints {
+ Cextension
+ } -cleanup {
+ } -body {
+ ip::prefixToNativec {1.1.1.0/24 1.0.0.0/8 2.1.1.0/24 1.1.1.1/32}
+ } -result {{0x01010100 0xFFFFFF00} {0x01000000 0xFF000000} {0x02010100 0xFFFFFF00} {0x01010101 0xFFFFFFFF}}
+
+ ::tcltest::test ip::prefixToNativec-5 {} -setup {
+ } -constraints {
+ Cextension
+ } -cleanup {
+ } -body {
+ ip::prefixToNativec {1.1.1.0/24 1.0AAF0/8 2.1.1.0/24 1.1.1.1/32}
+ } -result {} -returnCodes error
+
+ ::tcltest::test ip::prefixToNativec-6 {} -setup {
+ } -constraints {
+ Cextension
+ } -cleanup {
+ unset y
+ } -body {
+ set y {1.1.1.0/24 1.0.0.0/8 2.1.1.0/24 1.1.1.1/32}
+ ip::prefixToNativec $y
+ lindex $y 0
+ } -result {1.1.1.0/24}
+
+ ::tcltest::test ip::nativeToPrefix-1 {
+ single address test
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ip::nativeToPrefix {0x01010100 0xffffff00} -ipv4
+ } -result {1.1.1.0/24}
+
+ ::tcltest::test ip::nativeToPrefix-2 {
+ multi list test
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ip::nativeToPrefix {{0x01010100 0xffffff00} {0x01000000 0xff000000} {0x02010100 0xffffff00} {0x01010101 0xffffffff}} -ipv4
+ } -result {1.1.1.0/24 1.0.0.0/8 2.1.1.0/24 1.1.1.1/32}
+
+ ::tcltest::test ip::nativeToPrefix-3 {
+ 0 test
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ip::nativeToPrefix {0x0 0x0} -ipv4
+ } -result {0.0.0.0/0}
+
+ ::tcltest::test ip::nativeToPrefix-4 {
+ 0 test, check default is ipv4
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ip::nativeToPrefix {0x0 0x0}
+ } -result {0.0.0.0/0}
+
+ ::tcltest::test ip::toInteger-1 {} -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::toInteger 1.1.1.0
+ } -result {16843008}
+
+ ::tcltest::test ::ip::toHex-1 {} -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::toHex 1.1.1.0
+ } -result {0x01010100}
+
+
+
+
+
+ ::tcltest::test ::ip:broadcastAddress-1 {
+ dotted form
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::broadcastAddress 1.1.1.0/24
+ } -result {1.1.1.255}
+
+ ::tcltest::test ::ip:broadcastAddress-2 {
+ native form
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::broadcastAddress {0x01010100 0xffffff00}
+ } -result {0x010101ff}
+
+
+ ::tcltest::test ::ip:maskToLength-1 {
+ hexform
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::maskToLength 0xffffff00 -ipv4
+ } -result {24}
+
+ ::tcltest::test ::ip:maskToLength-2 {
+ dotted form
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::maskToLength 255.255.255.0
+ } -result {24}
+
+
+ ::tcltest::test ::ip:maskToLength-3 {
+ zero form
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::maskToLength 0.0.0.0
+ } -result {0}
+
+ ::tcltest::test ::ip:maskToLength-4 {
+ zero form
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::maskToLength 0x0 -ipv4
+ } -result {0}
+
+ ::tcltest::test ::ip:maskToLength-5 {
+ zero form, defualt is ipv4
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::maskToLength 0x0
+ } -result {0}
+
+
+ ::tcltest::test ::ip::lengthToMask-1 {
+ dotted form
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::lengthToMask 24 -ipv4
+ } -result {255.255.255.0}
+
+ ::tcltest::test ::ip::lengthToMask-2 {
+ dotted form, default is ipv4
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::lengthToMask 24
+ } -result {255.255.255.0}
+
+ ::tcltest::test ::ip:maskToInt-1 {
+ integer form
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::maskToInt 32
+ } -result {4294967295}
+
+
+ ::tcltest::test ::ip:maskToInt-2 {
+ dotted form
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::maskToInt 255.255.255.255
+ } -result {4294967295}
+
+ ::tcltest::test ::ip:intToString-1 {
+ convert 255.255.255.255
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::intToString 4294967295 -ipv4
+ } -result {255.255.255.255}
+
+ ::tcltest::test ::ip:intToString-2 {
+ convert hex to string
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::intToString 0x01010101 -ipv4
+ } -result {1.1.1.1}
+
+ ::tcltest::test ::ip:intToString-3 {
+ convert hex to string, default is ipv4
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::intToString 0x01010101
+ } -result {1.1.1.1}
+
+ ::tcltest::test ::ip:nextNet-1 {
+ 255.255.255.0/32 -> 255.255.255.1
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::nextNet 0xffffff00 0xffffffff -ipv4
+ } -result {0xffffff01}
+
+ ::tcltest::test ::ip:nextNet-2 {
+ 1.0.0.0/24 -> 1.0.1.0/24
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ip::nextNet 0x01000000 0xffffff00 -ipv4
+ } -result {0x01000100}
+
+
+ ::tcltest::test ::ip:nextNet-3 {
+ 1.1.28.0/24 -> 1.1.29.0
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ip::nextNet 0x01011c00 0xffffff00 -ipv4
+ } -result {0x01011d00}
+
+ ::tcltest::test ::ip:nextNet-4 {
+ 1.1.28.0/24 -> 1.1.29.0 by 1
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ip::nextNet 0x01011c00 0xffffff00 1 -ipv4
+ } -result {0x01011d00}
+
+
+ ::tcltest::test ::ip:nextNet-5 {
+ 1.1.1.1/32 -> 1.1.29.0 by 2
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ip::nextNet 0x01010101 [ip::maskToInt 32] 2 -ipv4
+ } -result {0x01010103}
+
+ ::tcltest::test ::ip:nextNet-6 {
+ 1.1.1.1/32 -> 1.1.29.0 by 2
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ip::nextNet 1.1.1.1 32 2
+ } -result {0x01010103}
+
+ ::tcltest::test ::ip:nextNet-7 {
+ 1.1.1.1/32 -> 1.1.29.0 by 2
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ip::nextNet 1.1.1.1 255.255.255.255 2
+ } -result {0x01010103}
+
+ ::tcltest::test ::ip:nextNet-8 {
+ 1.1.1.1/32 -> 1.1.29.0 by 2, default is ipv4
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ip::nextNet 0x01010101 [ip::maskToInt 32] 2
+ } -result {0x01010103}
+
+ ::tcltest::test ::ip:isOverlap-1 {
+ no overlap test
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32
+ } -result {0}
+
+
+ ::tcltest::test ::ip:isOverlap-2 {
+ yes overlap test
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32 1.1.1.1/32
+ } -result {1}
+
+
+ ::tcltest::test ::ip:isOverlapNative-1 {
+ no overlap test
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::isOverlapNative -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff}}
+ } -result {0}
+
+
+ ::tcltest::test ::ip:isOverlapNative-2 {
+ yes overlap test
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ set a [::ip::isOverlapNative -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}} ]
+ expr $a > 0
+ } -result {1}
+
+ ::tcltest::test ::ip:isOverlapNativeTcl-1 {
+ no overlap test
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::isOverlapNativeTcl -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff}}
+ } -result {0}
+
+
+ ::tcltest::test ::ip:isOverlapNativeTcl-2 {
+ yes overlap test
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ set a [::ip::isOverlapNativeTcl -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}}]
+ expr $a > 0
+ } -result {1}
+
+ ::tcltest::test ::ip:isOverlapNativeTcl-3 {
+ yes overlap test
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ set a [::ip::isOverlapNativeTcl -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}}]
+ } -result {2}
+
+ ::tcltest::test ::ip:isOverlapNativeTcl-4 {
+ -all overlap test
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ set a [::ip::isOverlapNativeTcl -ipv4 -all 0x01010100 0xffffff00 {
+ {0x02010001 0xffffffff}
+ {0x01010101 0xffffffff}
+ {0x01010102 0xffffffff}
+ }]
+ } -result {2 3}
+
+ ::tcltest::test ::ip:isOverlapNativeTcl-5 {
+ -all overlap test with -inline
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ set a [::ip::isOverlapNativeTcl -ipv4 -all -inline 0x01010100 0xffffff00 {
+ {0x02010001 0xffffffff}
+ {0x01010101 0xffffffff}
+ {0x01010102 0xffffffff}
+ }]
+ } -result {{0x01010101 0xffffffff} {0x01010102 0xffffffff}}
+
+ ::tcltest::test ::ip:isOverlapNativeTcl-6 {
+ test with -inline
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ set a [::ip::isOverlapNativeTcl -ipv4 -inline 0x01010100 0xffffff00 {
+ {0x02010001 0xffffffff}
+ {0x01010101 0xffffffff}
+ {0x01010102 0xffffffff}
+ }]
+ } -result {{0x01010101 0xffffffff}}
+
+ ::tcltest::test ::ip:isOverlapNativeTcl-7 {
+ test with -all -inline one element return
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ set a [::ip::isOverlapNativeTcl -ipv4 -all -inline 0x01010100 0xffffff00 {
+ {0x02010001 0xffffffff}
+ {0x01010101 0xffffffff}
+ }]
+ } -result {{0x01010101 0xffffffff}}
+
+ ::tcltest::test ::ip:isOverlapNativeTcl-8 {
+ test with -inline
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ set a [::ip::isOverlapNativeTcl -ipv4 -inline 0x01010100 0xffffff00 {
+ {0x02010001 0xffffffff}
+ }]
+ } -result {}
+
+ ::tcltest::test ::ip:isOverlapNativec-1 {
+ no overlap test
+ } -setup {
+ } -constraints {
+ Cextension
+ } -cleanup {
+ } -body {
+ ::ip::isOverlapNativec -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff}}
+ } -result {0}
+
+
+ ::tcltest::test ::ip:isOverlapNativec-2 {
+ yes overlap test
+ } -setup {
+ } -constraints {
+ Cextension
+ } -cleanup {
+ } -body {
+ set a [::ip::isOverlapNativec -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}}]
+ expr $a > 0
+ } -result {1}
+
+ ::tcltest::test ::ip:isOverlapNativec-3 {
+ yes overlap test
+ } -setup {
+ } -constraints {
+ Cextension
+ } -cleanup {
+ } -body {
+ set a [::ip::isOverlapNativec -ipv4 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}}]
+ } -result {2}
+
+ ::tcltest::test ::ip:isOverlapNativec-4 {
+ -all overlap test
+ } -setup {
+ } -constraints {
+ Cextension
+ } -cleanup {
+ } -body {
+ set a [::ip::isOverlapNativec -ipv4 -all 0x01010100 0xffffff00 {
+ {0x02010001 0xffffffff}
+ {0x01010101 0xffffffff}
+ {0x01010102 0xffffffff}
+ }]
+ } -result {2 3}
+
+ ::tcltest::test ::ip:isOverlapNativec-5 {
+ -all overlap test with -inline
+ } -setup {
+ } -constraints {
+ Cextension
+ } -cleanup {
+ } -body {
+ set a [::ip::isOverlapNativec -ipv4 -all -inline 0x01010100 0xffffff00 {
+ {0x02010001 0xffffffff}
+ {0x01010101 0xffffffff}
+ {0x01010102 0xffffffff}
+ }]
+ } -result {{0x01010101 0xffffffff} {0x01010102 0xffffffff}}
+
+ ::tcltest::test ::ip:isOverlapNativec-6 {
+ test with -inline
+ } -setup {
+ } -constraints {
+ Cextension
+ } -cleanup {
+ } -body {
+ set a [::ip::isOverlapNativec -ipv4 -inline 0x01010100 0xffffff00 {
+ {0x02010001 0xffffffff}
+ {0x01010101 0xffffffff}
+ {0x01010102 0xffffffff}
+ }]
+ } -result {{0x01010101 0xffffffff}}
+
+ ::tcltest::test ::ip:isOverlapNativec-7 {
+ test with -all -inline one element return
+ } -setup {
+ } -constraints {
+ Cextension
+ } -cleanup {
+ } -body {
+ set a [::ip::isOverlapNativec -ipv4 -all -inline 0x01010100 0xffffff00 {
+ {0x02010001 0xffffffff}
+ {0x01010101 0xffffffff}
+ }]
+ } -result {{0x01010101 0xffffffff}}
+
+ ::tcltest::test ::ip:isOverlapNativec-8 {
+ test with -inline with not overlaps, returns nothing
+ } -setup {
+ } -constraints {
+ Cextension
+ } -cleanup {
+ } -body {
+ set a [::ip::isOverlapNativec -ipv4 -inline 0x01010100 0xffffff00 {
+ {0x02010001 0xffffffff}
+ }]
+ } -result {}
+
+
+
+ ::tcltest::test ::ip:ipToLayer2Multicast-1 {
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::ipToLayer2Multicast 224.0.0.2
+ } -result {01.00.5e.00.00.02}
+
+ ::tcltest::test ::ip:ipHostFromPrefix-1 {
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::ipHostFromPrefix 1.1.1.1/32
+ } -result {1.1.1.1}
+
+ ::tcltest::test ::ip:ipHostFromPrefix-2 {
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::ipHostFromPrefix 1.1.1.0/24
+ } -result {1.1.1.1}
+
+ ::tcltest::test ::ip:ipHostFromPrefix-3 {
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ unset x
+ unset exlList
+ unset testPrefix
+ } -body {
+ set testPrefix 1.1.1.0/24
+ set exlList {
+ 1.1.1.18/32
+ 1.1.1.13/32
+ 1.1.1.17/32
+ 2.1.1.0/24
+ 1.1.0.0/16
+ 1.1.1.12/30
+ 1.1.1.4/30
+ }
+ set x [::ip::ipHostFromPrefix $testPrefix -exclude $exlList ]
+ ip::longestPrefixMatch $x [concat $exlList [list $testPrefix]] -ipv4
+ } -result {1.1.1.0/24}
+
+ ::tcltest::test ::ip:reduceToAggregates {
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::reduceToAggregates {1.1.1.0/24 1.1.0.0/8 2.1.1.0/24 1.1.1.1/32 }
+ } -result {1.0.0.0/8 2.1.1.0/24}
+
+ ::tcltest::test ::ip:longestPrefixMatch-1 {
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::longestPrefixMatch 1.1.1.1/32 {1.1.1.0/24 1.1.0.0/8 2.1.1.0/24 1.1.1.1/32 } -ipv4
+ } -result {1.1.1.1/32}
+
+ ::tcltest::test ::ip:longestPrefixMatch-2 {
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::longestPrefixMatch 1.1.1.1 {1.1.1.0/24 1.0.0.0/8 2.1.1.0/24 1.1.1.0/28 } -ipv4
+ } -result {1.1.1.0/28}
+
+ ::tcltest::test ::ip:longestPrefixMatch-3 {
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::longestPrefixMatch 1.1.1.1 {2.1.1.0/24 2.0.0.0/8} -ipv4
+ } -result {}
+
+ ::tcltest::test ::ip:longestPrefixMatch-4 {
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ unset x
+ unset y
+ } -body {
+ set x 128.0.0.2
+ set y {1.0.0.0/8 2.2.0.0/16 128.0.0.0/16 3.3.3.3/32}
+ ::ip::longestPrefixMatch $x $y -ipv4
+ # there was a problem when using varibles, it looked like
+ # tcl was modifying the original variables in an
+ # upvar fashion
+ ::ip::longestPrefixMatch $x $y -ipv4
+ } -result {128.0.0.0/16}
+
+ ::tcltest::test ::ip:longestPrefixMatch-5 {
+ check where the match list is only a single prefix (non-match case)
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::longestPrefixMatch 128.0.0.2 {1.0.0.0/8} -ipv4
+ } -result {}
+
+ ::tcltest::test ::ip:longestPrefixMatch-6 {
+ check where the match list is only a single prefix (match case)
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::longestPrefixMatch 128.0.0.2 {128.0.0.0/8} -ipv4
+ } -result {128.0.0.0/8}
+
+ ::tcltest::test ::ip:cmpDotIP-1 {
+ test sorting of cmpDotIP
+ } -setup {
+ set iplist {1.0.0.0 2.2.0.0 128.0.0.0 3.3.3.3}
+ } -constraints {
+ } -cleanup {
+ unset iplist
+ } -body {
+ set a [lsort -command ip::cmpDotIP $iplist]
+ } -result {1.0.0.0 2.2.0.0 3.3.3.3 128.0.0.0}
+
+
+ ::tcltest::test ip::distance-1 {basic distance} -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::distance 1.1.1.0 1.1.1.5
+ } -result 5
+
+ ::tcltest::test ip::distance-2 {distance, not enough args} -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::distance
+ } -returnCodes error -result {wrong # args: should be "::ip::distance ip1 ip2"}
+
+ ::tcltest::test ip::distance-3 {distance, too many args} -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::distance 1.1.1.1 1.1.1.5 1.1.1.19
+ } -returnCodes error -result {wrong # args: should be "::ip::distance ip1 ip2"}
+
+
+ ::tcltest::test ip::nextIp-1 {basic nextIp} -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::nextIp 1.1.1.0 5
+ } -result 1.1.1.5
+
+ ::tcltest::test ip::nextIp-2 {nextIp, not enough args} -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::nextIp
+ } -returnCodes error -result {wrong # args: should be "::ip::nextIp ip ?offset?"}
+
+ ::tcltest::test ip::nextIp-3 {nextIp, too many args} -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::nextIp 1.1.1.1 1.1.1.5 1.1.1.19
+ } -returnCodes error -result {wrong # args: should be "::ip::nextIp ip ?offset?"}
+
+ foreach {n delta ip1 ip2} {
+ 0 4294967295 0.0.0.0 255.255.255.255
+ 1 -4294967295 255.255.255.255 0.0.0.0
+ 2 7709 10.11.12.13 10.11.42.42
+ 3 -7709 10.11.42.42 10.11.12.13
+ 4 1994195353 54.229.115.42 173.194.116.195
+ 5 -1994195353 173.194.116.195 54.229.115.42
+ } {
+ ::tcltest::test ip::distance-4.$n {basic distance} -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::distance $ip1 $ip2
+ } -result $delta
+
+ ::tcltest::test ip::nextIp-4.$n {basic nextIp} -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ ::ip::nextIp $ip1 $delta
+ } -result $ip2
+ }
+
+}
+
+namespace delete ::ip::test
+
+testsuiteCleanup
+
+#
+# ;;; Local Variables:
+# ;;; mode: tcl
+# ;;; indent-tabs-mode:nil
+# ;;; End:
diff --git a/tcllib/modules/dns/ipMoreC.tcl b/tcllib/modules/dns/ipMoreC.tcl
new file mode 100644
index 0000000..a90b4b9
--- /dev/null
+++ b/tcllib/modules/dns/ipMoreC.tcl
@@ -0,0 +1,242 @@
+# Skip this for window and a specific version of Solaris
+#
+# This could do with an explanation -- why are we avoiding these platforms
+# and perhaps using critcl's platform::platform command might be better?
+#
+if {[string equal $::tcl_platform(platform) windows] ||
+ ([string equal $::tcl_platform(os) SunOS] &&
+ [string equal $::tcl_platform(osVersion) 5.6])
+} {
+ # avoid warnings about nothing to compile
+ critcl::ccode {
+ /* nothing to do */
+ }
+ return
+}
+
+package require critcl;
+
+namespace eval ::ip {
+
+critcl::ccode {
+#include <stdlib.h>
+#include <stdio.h>
+#include <tcl.h>
+#include <inttypes.h>
+#include <arpa/inet.h>
+#include <string.h>
+#include <sys/socket.h>
+}
+
+critcl::ccommand prefixToNativec {clientData interp objc objv} {
+ int elemLen, maskLen, ipLen, mask;
+ int rval,convertListc,i;
+ Tcl_Obj **convertListv;
+ Tcl_Obj *listPtr,*returnPtr, *addrList;
+ char *stringIP, *slashPos, *stringMask;
+ char v4HEX[11];
+
+ uint32_t inaddr;
+ listPtr = NULL;
+
+ /* printf ("\n in prefixToNativeC"); */
+ /* printf ("\n objc = %d",objc); */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "<ipaddress>/<mask>");
+ return TCL_ERROR;
+ }
+
+
+ if (Tcl_ListObjGetElements (interp, objv[1],
+ &convertListc, &convertListv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ returnPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ for (i = 0; i < convertListc; i++) {
+ /* need to create a duplicate here because when we modify */
+ /* the stringIP it'll mess up the original in the calling */
+ /* context */
+ addrList = Tcl_DuplicateObj(convertListv[i]);
+ stringIP = Tcl_GetStringFromObj(addrList, &elemLen);
+ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ /* printf ("\n ### %s ### string \n", stringIP); */
+ /* split the ip address and mask */
+ slashPos = strchr(stringIP, (int) '/');
+ if (slashPos == NULL) {
+ /* straight ip address without mask */
+ mask = 0xffffffff;
+ ipLen = strlen(stringIP);
+ } else {
+ /* ipaddress has the mask, handle the mask and seperate out the */
+ /* ip address */
+ /* printf ("\n ** %d ",(uintptr_t)slashPos); */
+ stringMask = slashPos +1;
+ maskLen =strlen(stringMask);
+ /* put mask in hex form */
+ if (maskLen < 3) {
+ mask = atoi(stringMask);
+ mask = (0xFFFFFFFF << (32 - mask)) & 0xFFFFFFFF;
+ } else {
+ /* mask is in dotted form */
+ if ((rval = inet_pton(AF_INET,stringMask,&mask)) < 1 ) {
+ Tcl_AddErrorInfo(interp, "\n bad format encountered in mask conversion");
+ return TCL_ERROR;
+ }
+ mask = htonl(mask);
+ }
+ ipLen = (uintptr_t)slashPos - (uintptr_t)stringIP;
+ /* divide the string into ip and mask portion */
+ *slashPos = '\0';
+ /* printf("\n %d %d %d %d", (uintptr_t)stringMask, maskLen, (uintptr_t)stringIP, ipLen); */
+ }
+ if ( (rval = inet_pton(AF_INET,stringIP,&inaddr)) < 1) {
+ Tcl_AddErrorInfo(interp,
+ "\n bad format encountered in ip conversion");
+ return TCL_ERROR;
+ };
+ inaddr = htonl(inaddr);
+ /* apply the mask the to the ip portion, just to make sure */
+ /* what we return is cleaned up */
+ inaddr = inaddr & mask;
+ sprintf(v4HEX,"0x%08X",inaddr);
+ /* printf ("\n\n ### %s",v4HEX); */
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(v4HEX,-1));
+ sprintf(v4HEX,"0x%08X",mask);
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(v4HEX,-1));
+ Tcl_ListObjAppendElement(interp, returnPtr, listPtr);
+ Tcl_DecrRefCount(addrList);
+ }
+
+ if (convertListc==1) {
+ Tcl_SetObjResult(interp,listPtr);
+ } else {
+ Tcl_SetObjResult(interp,returnPtr);
+ }
+
+ return TCL_OK;
+}
+
+critcl::ccommand isOverlapNativec {clientData interp objc objv} {
+ int i;
+ unsigned int ipaddr,ipMask, mask1mask2;
+ unsigned int ipaddr2,ipMask2;
+ int compareListc,comparePrefixMaskc;
+ int allSet,inlineSet,index;
+ Tcl_Obj **compareListv,**comparePrefixMaskv, *listPtr;
+ Tcl_Obj *result;
+ static CONST char *options[] = {
+ "-all", "-inline", "-ipv4", NULL
+ };
+ enum options {
+ OVERLAP_ALL, OVERLAP_INLINE, OVERLAP_IPV4
+ };
+
+ allSet = 0;
+ inlineSet = 0;
+ listPtr = NULL;
+
+ /* printf ("\n objc = %d",objc); */
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?options? <hexIP> <hexMask> <hexList>");
+ return TCL_ERROR;
+ }
+ for (i = 1; i < objc-3; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (index) {
+ case OVERLAP_ALL:
+ allSet = 1;
+ /* printf ("\n all selected"); */
+ break;
+ case OVERLAP_INLINE:
+ inlineSet = 1;
+ /* printf ("\n inline selected"); */
+ break;
+ case OVERLAP_IPV4:
+ break;
+ }
+ }
+ /* options are parsed */
+
+ /* create return obj */
+ result = Tcl_GetObjResult (interp);
+
+ /* set ipaddr and ipmask */
+ Tcl_GetIntFromObj(interp,objv[objc-3],(int*)&ipaddr);
+ Tcl_GetIntFromObj(interp,objv[objc-2],(int*)&ipMask);
+
+ /* split the 3rd argument into <ipaddr> <mask> pairs */
+ if (Tcl_ListObjGetElements (interp, objv[objc-1], &compareListc, &compareListv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+/* printf("comparing %x/%x \n",ipaddr,ipMask); */
+
+ if (allSet || inlineSet) {
+ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ }
+
+ for (i = 0; i < compareListc; i++) {
+ /* split the ipaddr2 and ipmask2 */
+ if (Tcl_ListObjGetElements (interp,
+ compareListv[i],
+ &comparePrefixMaskc,
+ &comparePrefixMaskv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (comparePrefixMaskc != 2) {
+ Tcl_AddErrorInfo(interp,"need format {{<ipaddr> <mask>} {<ipad..}}");
+ return TCL_ERROR;
+ }
+ Tcl_GetIntFromObj(interp,comparePrefixMaskv[0],(int*)&ipaddr2);
+ Tcl_GetIntFromObj(interp,comparePrefixMaskv[1],(int*)&ipMask2);
+/* printf(" with %x/%x \n",ipaddr2,ipMask2); */
+ mask1mask2 = ipMask & ipMask2;
+/* printf(" mask1mask2 %x \n",mask1mask2); */
+/* printf(" ipaddr & mask1mask2 %x\n",ipaddr & mask1mask2); */
+/* printf(" ipaddr2 & mask1mask2 %x\n",ipaddr2 & mask1mask2); */
+ if ((ipaddr & mask1mask2) == (ipaddr2 & mask1mask2)) {
+ if (allSet) {
+ if (inlineSet) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ compareListv[i]);
+ } else {
+ /* printf("\n appending %d",i+1); */
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewIntObj(i+1));
+ };
+ } else {
+ if (inlineSet) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ compareListv[i]);
+ Tcl_SetObjResult(interp,listPtr);
+ } else {
+ Tcl_SetIntObj (result, i+1);
+ }
+ return TCL_OK;
+ };
+ };
+ };
+
+ if (allSet || inlineSet) {
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+ } else {
+ Tcl_SetIntObj (result, 0);
+ return TCL_OK;
+ }
+ return TCL_OK;
+
+
+
+}
+
+
+}
+
+# @sak notprovided ipMorec
+package provide ipMorec 1.0
diff --git a/tcllib/modules/dns/msgs/en.msg b/tcllib/modules/dns/msgs/en.msg
new file mode 100644
index 0000000..813cb9e
--- /dev/null
+++ b/tcllib/modules/dns/msgs/en.msg
@@ -0,0 +1,8 @@
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+mcset en "option %s not supported" "option %s not supported"
+mcset en "option %s not supported" "option %s not supported"
+mcset en "not an ip mask: %s" "not an ip mask: %s"
+mcset en "ip host could not be found in %s" "ip host could not be found in %s"
diff --git a/tcllib/modules/dns/pkgIndex.tcl b/tcllib/modules/dns/pkgIndex.tcl
new file mode 100644
index 0000000..5f03e9c
--- /dev/null
+++ b/tcllib/modules/dns/pkgIndex.tcl
@@ -0,0 +1,9 @@
+# pkgIndex.tcl -
+#
+# $Id: pkgIndex.tcl,v 1.21 2010/08/16 17:35:18 andreas_kupries Exp $
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded dns 1.3.5 [list source [file join $dir dns.tcl]]
+package ifneeded resolv 1.0.3 [list source [file join $dir resolv.tcl]]
+package ifneeded ip 1.3 [list source [file join $dir ip.tcl]]
+package ifneeded spf 1.1.1 [list source [file join $dir spf.tcl]]
diff --git a/tcllib/modules/dns/resolv.tcl b/tcllib/modules/dns/resolv.tcl
new file mode 100644
index 0000000..503be13
--- /dev/null
+++ b/tcllib/modules/dns/resolv.tcl
@@ -0,0 +1,249 @@
+# resolv.tcl - Copyright (c) 2002 Emmanuel Frecon <emmanuel@sics.se>
+#
+# Original Author -- Emmanuel Frecon - emmanuel@sics.se
+# Modified by Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# A super module on top of the dns module for host name resolution.
+# There are two services provided on top of the regular Tcl library:
+# Firstly, this module attempts to automatically discover the default
+# DNS server that is setup on the machine that it is run on. This
+# server will be used in all further host resolutions. Secondly, this
+# module offers a rudimentary cache. The cache is rudimentary since it
+# has no expiration on host name resolutions, but this is probably
+# enough for short lived applications.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require dns 1.0; # tcllib 1.3
+
+namespace eval ::resolv {
+ namespace export resolve init ignore hostname
+
+ variable R
+ if {![info exists R]} {
+ array set R {
+ initdone 0
+ dns ""
+ dnsdefault ""
+ ourhost ""
+ search {}
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+# Command Name -- ignore
+# Original Author -- Emmanuel Frecon - emmanuel@sics.se
+#
+# Remove a host name resolution from the cache, if present, so that the
+# next resolution will query the DNS server again.
+#
+# Arguments:
+# hostname - Name of host to remove from the cache.
+#
+proc ::resolv::ignore { hostname } {
+ variable Cache
+ catch {unset Cache($hostname)}
+ return
+}
+
+# -------------------------------------------------------------------------
+# Command Name -- init
+# Original Author -- Emmanuel Frecon - emmanuel@sics.se
+#
+# Initialise this module with a known host name. This host (not mandatory)
+# will become the default if the library was not able to find a DNS server.
+# This command can be called several times, its effect is double: actively
+# looking for the default DNS server setup on the running machine; and
+# emptying the host name resolution cache.
+#
+# Arguments:
+# defaultdns - Default DNS server
+#
+proc ::resolv::init { {defaultdns ""} {search {}}} {
+ variable R
+ variable Cache
+
+ # Clean the resolver cache
+ catch {unset Cache}
+
+ # Record the default DNS server and search list.
+ set R(dnsdefault) $defaultdns
+ set R(search) $search
+
+ # Now do some intelligent lookup. We do this on the current
+ # hostname to get a chance to get back some (full) information on
+ # ourselves. A previous version was using 127.0.0.1, not sure
+ # what is best.
+ set res [catch [list exec nslookup [info hostname]] lkup]
+ if { $res == 0 } {
+ set l [split $lkup]
+ set nl ""
+ foreach e $l {
+ if { [string length $e] > 0 } {
+ lappend nl $e
+ }
+ }
+
+ # Now, a lot of mixture to arrange so that hostname points at the
+ # DNS server that we should use for any further request. This
+ # code is complex, but was actually tested behind a firewall
+ # during the SITI Winter Conference 2003. There, strangly,
+ # nslookup returned an error but a DNS server was actually setup
+ # correctly...
+ set hostname ""
+ set len [llength $nl]
+ for { set i 0 } { $i < $len } { incr i } {
+ set e [lindex $nl $i]
+ if { [string match -nocase "*server*" $e] } {
+ set hostname [lindex $nl [expr {$i + 1}]]
+ if { [string match -nocase "UnKnown" $hostname] } {
+ set hostname ""
+ }
+ break
+ }
+ }
+
+ if { $hostname != "" } {
+ set R(dns) $hostname
+ } else {
+ for { set i 0 } { $i < $len } { incr i } {
+ set e [lindex $nl $i]
+ if { [string match -nocase "*address*" $e] } {
+ set hostname [lindex $nl [expr {$i + 1}]]
+ break
+ }
+ }
+ if { $hostname != "" } {
+ set R(dns) $hostname
+ }
+ }
+ }
+
+ if {$R(dns) == ""} {
+ set R(dns) $R(dnsdefault)
+ }
+
+
+ # Start again to find our full name
+ set ourhost ""
+ if {$res == 0} {
+ set dot [string first "." [info hostname]]
+ if { $dot < 0 } {
+ for { set i 0 } { $i < $len } { incr i } {
+ set e [lindex $nl $i]
+ if { [string match -nocase "*name*" $e] } {
+ set ourhost [lindex $nl [expr {$i + 1}]]
+ break
+ }
+ }
+ if { $ourhost == "" } {
+ if { ! [regexp {\d+\.\d+\.\d+\.\d+} $hostname] } {
+ set dot [string first "." $hostname]
+ set ourhost [format "%s%s" [info hostname] \
+ [string range $hostname $dot end]]
+ }
+ }
+ } else {
+ set ourhost [info hostname]
+ }
+ }
+
+ if {$ourhost == ""} {
+ set R(ourhost) [info hostname]
+ } else {
+ set R(ourhost) $ourhost
+ }
+
+
+ set R(initdone) 1
+
+ return $R(dns)
+}
+
+# -------------------------------------------------------------------------
+# Command Name -- resolve
+# Original Author -- Emmanuel Frecon - emmanuel@sics.se
+#
+# Resolve a host name to an IP address. This is a wrapping procedure around
+# the basic services of the dns library.
+#
+# Arguments:
+# hostname - Name of host
+#
+proc ::resolv::resolve { hostname } {
+ variable R
+ variable Cache
+
+ # Initialise if not already done. Auto initialisation cannot take
+ # any known DNS server (known to the caller)
+ if { ! $R(initdone) } { init }
+
+ # Check whether this is not simply a raw IP address. What about
+ # IPv6 ??
+ # - We don't have sockets in Tcl for IPv6 protocols - [PT]
+ #
+ if { [regexp {\d+\.\d+\.\d+\.\d+} $hostname] } {
+ return $hostname
+ }
+
+ # Look for hostname in the cache, if found return.
+ if { [array names ::resolv::Cache $hostname] != "" } {
+ return $::resolv::Cache($hostname)
+ }
+
+ # Scream if we don't have any DNS server setup, since we cannot do
+ # anything in that case.
+ if { $R(dns) == "" } {
+ return -code error "No dns server provided"
+ }
+
+ set R(retries) 0
+ set ip [Resolve $hostname]
+
+ # And store the result of resolution in our cache for further use.
+ set Cache($hostname) $ip
+
+ return $ip
+}
+
+# Description:
+# Attempt to resolve hostname via DNS. If the name cannot be resolved then
+# iterate through the search list appending each domain in turn until we
+# get one that succeeds.
+#
+proc ::resolv::Resolve {hostname} {
+ variable R
+ set t [::dns::resolve $hostname -server $R(dns)]
+ ::dns::wait $t; # wait with event processing
+ set status [dns::status $t]
+ if {$status == "ok"} {
+ set ip [lindex [::dns::address $t] 0]
+ ::dns::cleanup $t
+ } elseif {$status == "error"
+ && [::dns::errorcode $t] == 3
+ && $R(retries) < [llength $R(search)]} {
+ ::dns::cleanup $t
+ set suffix [lindex $R(search) $R(retries)]
+ incr R(retries)
+ set new [lindex [split $hostname .] 0].[string trim $suffix .]
+ set ip [Resolve $new]
+ } else {
+ set err [dns::error $t]
+ ::dns::cleanup $t
+ return -code error "dns error: $err"
+ }
+ return $ip
+}
+
+# -------------------------------------------------------------------------
+
+package provide resolv 1.0.3
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/dns/spf.tcl b/tcllib/modules/dns/spf.tcl
new file mode 100644
index 0000000..a752c54
--- /dev/null
+++ b/tcllib/modules/dns/spf.tcl
@@ -0,0 +1,528 @@
+# spf.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Sender Policy Framework
+#
+# http://www.ietf.org/internet-drafts/draft-ietf-marid-protocol-00.txt
+# http://spf.pobox.com/
+#
+# Some domains using SPF:
+# pobox.org - mx, a, ptr
+# oxford.ac.uk - include
+# gnu.org - ip4
+# aol.com - ip4, ptr
+# sourceforge.net - mx, a
+# altavista.com - exists, multiple TXT replies.
+# oreilly.com - mx, ptr, include
+# motleyfool.com - include (looping includes)
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.2; # tcl minimum version
+package require dns; # tcllib 1.3
+package require logger; # tcllib 1.3
+package require ip; # tcllib 1.7
+package require struct::list; # tcllib 1.7
+package require uri::urn; # tcllib 1.3
+
+namespace eval spf {
+ namespace export spf
+
+ variable uid
+ if {![info exists uid]} {set uid 0}
+
+ variable log
+ if {![info exists log]} {
+ set log [logger::init spf]
+ ${log}::setlevel warn
+ proc ${log}::stdoutcmd {level text} {
+ variable service
+ puts "\[[clock format [clock seconds] -format {%H:%M:%S}]\
+ $service $level\] $text"
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+# ip : ip address of the connecting host
+# domain : the domain to match
+# sender : full sender email address
+#
+proc ::spf::spf {ip domain sender} {
+ variable log
+
+ # 3.3: Initial processing
+ # If the sender address has no local part, set it to postmaster
+ set addr [split $sender @]
+ if {[set len [llength $addr]] == 0} {
+ return -code error -errorcode permanent "invalid sender address"
+ } elseif {$len == 1} {
+ set sender "postmaster@$sender"
+ }
+
+ # 3.4: Record lookup
+ set spf [SPF $domain]
+ if {[string equal $spf none]} {
+ return $spf
+ }
+
+ return [Spf $ip $domain $sender $spf]
+}
+
+proc ::spf::Spf {ip domain sender spf} {
+ variable log
+
+ # 3.4.1: Matching Version
+ if {![regexp {^v=spf(\d)\s+} $spf -> version]} {
+ return none
+ }
+
+ ${log}::debug "$spf"
+
+ if {$version != 1} {
+ return -code error -errorcode permanent \
+ "version mismatch: we only understand SPF 1\
+ this domain has provided version \"$version\""
+ }
+
+ set result ?
+ set seen_domains $domain
+ set explanation {denied}
+
+ set directives [lrange [split $spf { }] 1 end]
+ foreach directive $directives {
+ set prefix [string range $directive 0 0]
+ if {[string equal $prefix "+"] || [string equal $prefix "-"]
+ || [string equal $prefix "?"] || [string equal $prefix "~"]} {
+ set directive [string range $directive 1 end]
+ } else {
+ set prefix "+"
+ }
+
+ set cmd [string tolower [lindex [split $directive {:/=}] 0]]
+ set param [string range $directive [string length $cmd] end]
+
+ if {[info commands ::spf::_$cmd] == {}} {
+ # 6.1 Unrecognised directives terminate processing
+ # but unknown modifiers are ignored.
+ if {[string match "=*" $param]} {
+ continue
+ } else {
+ set result unknown
+ break
+ }
+ } else {
+ set r [catch {::spf::_$cmd $ip $domain $sender $param} res]
+ if {$r} {
+ if {$r == 2} {return $res};# deal with return -code return
+ if {[string equal $res "none"]
+ || [string equal $res "error"]
+ || [string equal $res "unknown"]} {
+ return $res
+ }
+ return -code error "error in \"$cmd\": $res"
+ }
+ if {$res} { set result $prefix }
+ }
+
+ ${log}::debug "$prefix $cmd\($param) -> $result"
+ if {[string equal $result "+"]} break
+ }
+
+ return $result
+}
+
+proc ::spf::loglevel {level} {
+ variable log
+ ${log}::setlevel $level
+}
+
+# get a guaranteed unique and non-present token id.
+proc ::spf::create_token {} {
+ variable uid
+ set id [incr uid]
+ while {[info exists [set token [namespace current]::$id]]} {
+ set id [incr uid]
+ }
+ return $token
+}
+
+# -------------------------------------------------------------------------
+#
+# SPF MECHANISM HANDLERS
+#
+# -------------------------------------------------------------------------
+
+# 4.1: The "all" mechanism is a test that always matches. It is used as the
+# rightmost mechanism in an SPF record to provide an explicit default
+#
+proc ::spf::_all {ip domain sender param} {
+ return 1
+}
+
+# 4.2: The "include" mechanism triggers a recursive SPF query.
+# The domain-spec is expanded as per section 8.
+proc ::spf::_include {ip domain sender param} {
+ variable log
+ upvar seen_domains Seen
+
+ if {![string equal [string range $param 0 0] ":"]} {
+ return -code error "dubious parameters for \"include\""
+ }
+ set r ?
+ set new_domain [Expand [string range $param 1 end] $ip $domain $sender]
+ if {[lsearch $Seen $new_domain] == -1} {
+ lappend Seen $new_domain
+ set spf [SPF $new_domain]
+ if {[string equal $spf none]} {
+ return $spf
+ }
+ set r [Spf $ip $new_domain $sender $spf]
+ }
+ return [string equal $r "+"]
+}
+
+# 4.4: This mechanism matches if <ip> is one of the target's
+# IP addresses.
+# e.g: a:smtp.example.com a:mail.%{d} a
+#
+proc ::spf::_a {ip domain sender param} {
+ variable log
+ foreach {testdomain bits} [ip::SplitIp [string trimleft $param :]] {}
+ if {[string length $testdomain] < 1} {
+ set testdomain $domain
+ } else {
+ set testdomain [Expand $testdomain $ip $domain $sender]
+ }
+ ${log}::debug " fetching A for $testdomain"
+ set dips [A $testdomain]; # get the IPs for the testdomain
+ foreach dip $dips {
+ ${log}::debug " compare: ${ip}/${bits} with ${dip}/${bits}"
+ if {[ip::equal $ip/$bits $dip/$bits]} {
+ return 1
+ }
+ }
+ return 0
+}
+
+# 4.5: This mechanism matches if the <sending-host> is one of the MX hosts
+# for a domain name.
+#
+proc ::spf::_mx {ip domain sender param} {
+ variable log
+ foreach {testdomain bits} [ip::SplitIp [string trimleft $param :]] {}
+ if {[string length $testdomain] < 1} {
+ set testdomain $domain
+ } else {
+ set testdomain [Expand $testdomain $ip $domain $sender]
+ }
+ ${log}::debug " fetching MX for $testdomain"
+ set mxs [MX $testdomain]
+
+ foreach mx $mxs {
+ set mx [lindex $mx 1]
+ set mxips [A $mx]
+ foreach mxip $mxips {
+ ${log}::debug " compare: ${ip}/${bits} with ${mxip}/${bits}"
+ if {[ip::equal $ip/$bits $mxip/$bits]} {
+ return 1
+ }
+ }
+ }
+ return 0
+}
+
+# 4.6: This mechanism tests if the <sending-host>'s name is within a
+# particular domain.
+#
+proc ::spf::_ptr {ip domain sender param} {
+ variable log
+ set validnames {}
+ if {[catch { set names [PTR $ip] } msg]} {
+ ${log}::debug " \"$ip\" $msg"
+ return 0
+ }
+ foreach name $names {
+ set addrs [A $name]
+ foreach addr $addrs {
+ if {[ip::equal $ip $addr]} {
+ lappend validnames $name
+ continue
+ }
+ }
+ }
+
+ ${log}::debug " validnames: $validnames"
+ set testdomain [Expand [string trimleft $param :] $ip $domain $sender]
+ if {$testdomain == {}} {
+ set testdomain $domain
+ }
+ foreach name $validnames {
+ if {[string match "*$testdomain" $name]} {
+ return 1
+ }
+ }
+
+ return 0
+}
+
+# 4.7: These mechanisms test if the <sending-host> falls into a given IP
+# network.
+#
+proc ::spf::_ip4 {ip domain sender param} {
+ variable log
+ foreach {network bits} [ip::SplitIp [string range $param 1 end]] {}
+ ${log}::debug " compare ${ip}/${bits} to ${network}/${bits}"
+ if {[ip::equal $ip/$bits $network/$bits]} {
+ return 1
+ }
+ return 0
+}
+
+# 4.6: These mechanisms test if the <sending-host> falls into a given IP
+# network.
+#
+proc ::spf::_ip6 {ip domain sender param} {
+ variable log
+ foreach {network bits} [ip::SplitIp [string range $param 1 end]] {}
+ ${log}::debug " compare ${ip}/${bits} to ${network}/${bits}"
+ if {[ip::equal $ip/$bits $network/$bits]} {
+ return 1
+ }
+ return 0
+}
+
+# 4.7: This mechanism is used to construct an arbitrary host name that is
+# used for a DNS A record query. It allows for complicated schemes
+# involving arbitrary parts of the mail envelope to determine what is
+# legal.
+#
+proc ::spf::_exists {ip domain sender param} {
+ variable log
+ set testdomain [Expand [string range $param 1 end] $ip $domain $sender]
+ ${log}::debug " checking existence of '$testdomain'"
+ if {[catch {A $testdomain}]} {
+ return 0
+ }
+ return 1
+}
+
+# 5.1: Redirected query
+#
+proc ::spf::_redirect {ip domain sender param} {
+ variable log
+ set new_domain [Expand [string range $param 1 end] $ip $domain $sender]
+ ${log}::debug ">> redirect to '$new_domain'"
+ set spf [SPF $new_domain]
+ if {![string equal $spf none]} {
+ set spf [Spf $ip $new_domain $sender $spf]
+ }
+ ${log}::debug "<< redirect returning '$spf'"
+ return -code return $spf
+}
+
+# 5.2: Explanation
+#
+proc ::spf::_exp {ip domain sender param} {
+ variable log
+ set new_domain [string range $param 1 end]
+ set exp [TXT $new_domain]
+ set exp [Expand $exp $ip $domain $sender]
+ ${log}::debug "exp expanded to \"$exp\""
+ # FIX ME: need to store this somehow.
+}
+
+# 5.3: Sender accreditation
+#
+proc ::spf::_accredit {ip domain sender param} {
+ variable log
+ set accredit [Expand [string range $param 1 end] $ip $domain $sender]
+ ${log}::debug " accreditation '$accredit'"
+ # We are not using this at the moment.
+ return 0
+}
+
+
+# 7: Macro expansion
+#
+proc ::spf::Expand {txt ip domain sender} {
+ variable log
+ set re {%\{[[:alpha:]](?:\d+)?r?[\+\-\.,/_=]*\}}
+ set txt [string map {\[ \\\[ \] \\\]} $txt]
+ regsub -all $re $txt {[ExpandMacro & $ip $domain $sender]} cmd
+ set cmd [string map {%% % %_ \ %- %20} $cmd]
+ return [subst -novariables $cmd]
+}
+
+proc ::spf::ExpandMacro {macro ip domain sender} {
+ variable log
+ set re {%\{([[:alpha:]])(\d+)?(r)?([\+\-\.,/_=]*)\}}
+ set C {} ; set T {} ; set R {}; set D {}
+ set r [regexp $re $macro -> C T R D]
+ if {$R == {}} {set R 0} else {set R 1}
+ set res $macro
+ if {$r} {
+ set enc [string is upper $C]
+ switch -exact -- [string tolower $C] {
+ s { set res $sender }
+ l {
+ set addr [split $sender @]
+ if {[llength $addr] < 2} {
+ set res postmaster
+ } else {
+ set res [lindex $addr 0]
+ }
+ }
+ o {
+ set addr [split $sender @]
+ if {[llength $addr] < 2} {
+ set res $sender
+ } else {
+ set res [lindex $addr 1]
+ }
+ }
+ h - d { set res $domain }
+ i {
+ set res [ip::normalize $ip]
+ if {[ip::is ipv6 $res]} {
+ # Convert 0000:0001 to 0.1
+ set t {}
+ binary scan [ip::Normalize $ip 6] c* octets
+ foreach octet $octets {
+ set hi [expr {($octet & 0xF0) >> 4}]
+ set lo [expr {$octet & 0x0F}]
+ lappend t [format %x $hi] [format %x $lo]
+ }
+ set res [join $t .]
+ }
+ }
+ v {
+ if {[ip::is ipv6 $ip]} {
+ set res ip6
+ } else {
+ set res "in-addr"
+ }
+ }
+ c {
+ set res [ip::normalize $ip]
+ if {[ip::is ipv6 $res]} {
+ set res [ip::contract $res]
+ }
+ }
+ r {
+ set s [socket -server {} -myaddr [info host] 0]
+ set res [lindex [fconfigure $s -sockname] 1]
+ close $s
+ }
+ t { set res [clock seconds] }
+ }
+ if {$T != {} || $R || $D != {}} {
+ if {$D == {}} {set D .}
+ set res [split $res $D]
+ if {$R} {
+ set res [struct::list::Lreverse $res]
+ }
+ if {$T != {}} {
+ incr T -1
+ set res [join [lrange $res end-$T end] $D]
+ }
+ set res [join $res .]
+ }
+ if {$enc} {
+ # URI encode the result.
+ set res [uri::urn::quote $res]
+ }
+ }
+ return $res
+}
+
+# -------------------------------------------------------------------------
+#
+# DNS helper procedures.
+#
+# -------------------------------------------------------------------------
+
+proc ::spf::Resolve {domain type resultproc} {
+ if {[info commands $resultproc] == {}} {
+ return -code error "invalid arg: \"$resultproc\" must be a command"
+ }
+ set tok [dns::resolve $domain -type $type]
+ dns::wait $tok
+ set errorcode NONE
+ if {[string equal [dns::status $tok] "ok"]} {
+ set result [$resultproc $tok]
+ set code ok
+ } else {
+ set result [dns::error $tok]
+ set errorcode [dns::errorcode $tok]
+ set code error
+ }
+ dns::cleanup $tok
+ return -code $code -errorcode $errorcode $result
+}
+
+# 3.4: Record lookup
+proc ::spf::SPF {domain} {
+ set txt ""
+ if {[catch {Resolve $domain SPF ::dns::result} spf]} {
+ set code $::errorCode
+ ${log}::debug "error fetching SPF record: $r"
+ switch -exact -- $code {
+ 3 { return -code return [list - "Domain Does Not Exist"] }
+ 2 { return -code error -errorcode temporary $spf }
+ }
+ set txt none
+ } else {
+ foreach res $spf {
+ set ndx [lsearch $res rdata]
+ incr ndx
+ if {$ndx != 0} {
+ append txt [string range [lindex $res $ndx] 1 end]
+ }
+ }
+ }
+ return $txt
+}
+
+proc ::spf::TXT {domain} {
+ set r [Resolve $domain TXT ::dns::result]
+ set txt ""
+ foreach res $r {
+ set ndx [lsearch $res rdata]
+ incr ndx
+ if {$ndx != 0} {
+ append txt [string range [lindex $res $ndx] 1 end]
+ }
+ }
+ return $txt
+}
+
+proc ::spf::A {name} {
+ return [Resolve $name A ::dns::address]
+}
+
+
+proc ::spf::AAAA {name} {
+ return [Resolve $name AAAA ::dns::address]
+}
+
+proc ::spf::PTR {addr} {
+ return [Resolve $addr A ::dns::name]
+}
+
+proc ::spf::MX {domain} {
+ set r [Resolve $domain MX ::dns::name]
+ return [lsort -index 0 $r]
+}
+
+
+# -------------------------------------------------------------------------
+
+package provide spf 1.1.1
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/dns/spf.test b/tcllib/modules/dns/spf.test
new file mode 100644
index 0000000..3ba3bb9
--- /dev/null
+++ b/tcllib/modules/dns/spf.test
@@ -0,0 +1,244 @@
+# spf.test - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Tests for the Tcllib SPF package
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: spf.test,v 1.8 2007/08/22 20:37:50 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+support {
+ useLocal dns.tcl dns; # tcllib 1.3
+ useLocal ip.tcl ip; # tcllib 1.7
+ use log/logger.tcl logger; # tcllib 1.3
+ use struct/list.tcl struct::list; # tcllib 1.7
+ use uri/uri.tcl uri; # - clear scheme registry
+ use uri/urn-scheme.tcl uri::urn; # tcllib 1.3
+}
+testing {
+ useLocal spf.tcl spf
+}
+
+# -------------------------------------------------------------------------
+# Helpers
+# -------------------------------------------------------------------------
+
+# These tests do not make any network calls. Instead we emulate the
+# DNS query results wiht the following functions.
+
+foreach cmd [list SPF TXT A PTR MX] {
+ catch {rename ::spf::$cmd ::spf::tmp_$cmd}
+}
+proc ::spf::A {name} { return 192.0.2.3 }
+proc ::spf::AAAA {name} { return 5f05:2000:80ad:5800::1 }
+proc ::spf::PTR {addr} { return mx.example.org }
+proc ::spf::MX {domain} { return {{10 mx1.example.org} {20 mx2.example.org}} }
+proc ::spf::TXT {domain} { return "Only mail from local hosts permitted." }
+proc ::spf::SPF {domain} { return "v=spf1 ?all" }
+set email strong-bad@email.example.com
+
+# -------------------------------------------------------------------------
+# Tests
+# -------------------------------------------------------------------------
+
+test spf-1.1 {a directive: fallthrough} {
+ list [catch {
+ spf::Spf 192.168.0.1 email.example.com $::email "v=spf1 a -all"
+ } r] $r
+} {0 -}
+
+test spf-1.2 {a directive: fallthrough} {
+ list [catch {
+ spf::Spf 192.168.0.1 email.example.com $::email "v=spf1 a ?all"
+ } r] $r
+} {0 ?}
+
+test spf-1.3 {a directive: matching subnet} {
+ list [catch {
+ spf::Spf 192.0.2.1 email.example.com $::email "v=spf1 a/24 ?all"
+ } r] $r
+} {0 +}
+
+test spf-1.4 {a directive: rejected matching subnet} {
+ list [catch {
+ spf::Spf 192.0.2.1 email.example.com $::email "v=spf1 -a/24 ?all"
+ } r] $r
+} {0 ?}
+
+test spf-1.5 {a directive: match host} {
+ list [catch {
+ spf::Spf 192.0.2.3 email.example.com $::email "v=spf1 a ?all"
+ } r] $r
+} {0 +}
+
+test spf-2.1 {mx directive: fail mx} {
+ list [catch {
+ spf::Spf 192.168.0.1 email.example.com $::email "v=spf1 mx ?all"
+ } r] $r
+} {0 ?}
+
+test spf-2.2 {mx directive: match mx subnet} {
+ list [catch {
+ spf::Spf 192.0.2.1 email.example.com $::email "v=spf1 mx/24 ?all"
+ } r] $r
+} {0 +}
+
+test spf-2.3 {mx directive: fail match explict mx} {
+ list [catch {
+ spf::Spf 192.168.0.1 email.example.com $::email \
+ "v=spf1 mx:mail.local.net ?all"
+ } r] $r
+} {0 ?}
+
+test spf-2.4 {mx directive: match explict mx} {
+ list [catch {
+ spf::Spf 192.0.2.1 email.example.com $::email \
+ "v=spf1 mx:mail.local.net/24 ?all"
+ } r] $r
+} {0 +}
+
+test spf-2.5 {mx directive: match explict mx} {
+ list [catch {
+ spf::Spf 192.0.2.3 email.example.com $::email \
+ "v=spf1 mx:mx2.example.org ?all"
+ } r] $r
+} {0 +}
+
+test spf-3.1 {ptr directive} {
+ list [catch {
+ spf::Spf 192.0.2.3 email.example.com $::email "v=spf1 ptr ?all"
+ } r] $r
+} {0 ?}
+
+test spf-3.2 {ptr directive} {
+ list [catch {
+ spf::Spf 192.0.2.3 email.example.com $::email "v=spf1 ptr ?all"
+ } r] $r
+} {0 ?}
+
+test spf-3.3 {ptr directive} {
+ list [catch {
+ spf::Spf 192.0.2.3 email.example.com $::email \
+ "v=spf1 ptr:example.org ?all"
+ } r] $r
+} {0 +}
+
+test spf-3.4 {ptr directive} {
+ list [catch {
+ spf::Spf 192.0.2.3 email.example.com $::email \
+ "v=spf1 ptr:example.com ?all"
+ } r] $r
+} {0 ?}
+
+test spf-4.1 {ip4 directive} {
+ list [catch {
+ spf::Spf 192.168.2.3 email.example.com $::email \
+ "v=spf1 ip4:192.0.2.3/32 ?all"
+ } r] $r
+} {0 ?}
+
+test spf-4.2 {ip4 directive} {
+ list [catch {
+ spf::Spf 192.0.2.3 email.example.com $::email \
+ "v=spf1 ip4:192.0.2.0/24 ?all"
+ } r] $r
+} {0 +}
+
+test spf-4.3 {ip4 directive} {
+ list [catch {
+ spf::Spf 192.0.2.3 email.example.com $::email \
+ "v=spf1 ip4:192.0.0.0/16 ?all"
+ } r] $r
+} {0 +}
+
+test spf-4.4 {ip4 directive} {
+ list [catch {
+ spf::Spf 192.255.2.3 email.example.com $::email \
+ "v=spf1 ip4:192.0.0.0/16 ?all"
+ } r] $r
+} {0 ?}
+
+test spf-4.5 {ip4 directive} {
+ list [catch {
+ spf::Spf 192.0.2.3 email.example.com $::email \
+ "v=spf1 ip4:192.0/16 ?all"
+ } r] $r
+} {0 +}
+
+# -------------------------------------------------------------------------
+# Macros language tests
+# These are all taken from the specification document.
+
+set Data {
+ %{s} strong-bad@email.example.com
+ %{o} email.example.com
+ %{d} email.example.com
+ %{d4} email.example.com
+ %{d3} email.example.com
+ %{d2} example.com
+ %{d1} com
+ %{dr} com.example.email
+ %{d2r} example.email
+ %{l} strong-bad
+ %{l-} strong.bad
+ %{lr} strong-bad
+ %{lr-} bad.strong
+ %{l1r-} strong
+ %{ir}.%{v}._spf.%{d2} 3.2.0.192.in-addr._spf.example.com
+ %{lr-}.lp._spf.%{d2} bad.strong.lp._spf.example.com
+
+ %{lr-}.lp.%{ir}.%{v}._spf.%{d2}
+ bad.strong.lp.3.2.0.192.in-addr._spf.example.com
+
+ %{ir}.%{v}.%{l1r-}.lp._spf.%{d2}
+ 3.2.0.192.in-addr.strong.lp._spf.example.com
+
+ %{d2}.trusted-domains.example.net
+ example.com.trusted-domains.example.net
+}
+set n 0
+foreach {macro check} $Data {
+ test spf-5.[incr n] [list spf macro language $macro] {
+ list [catch {
+ ::spf::Expand $macro 192.0.2.3 email.example.com $::email
+ } msg] $msg
+ } [list 0 $check]
+}
+
+set Data {
+ %{ir}.%{v}._spf.%{d2}
+ 1.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.0.8.5.d.a.0.8.0.0.0.2.5.0.f.5.ip6._spf.example.com
+}
+set n 0
+foreach {macro check} $Data {
+ test spf-6.0 [list spf macro language ipv6] {
+ list [catch {
+ ::spf::Expand $macro 5f05:2000:80ad:5800::1 \
+ email.example.com $::email
+ } msg] $msg
+ } [list 0 $check]
+}
+
+# -------------------------------------------------------------------------
+
+foreach cmd [list SPF TXT A PTR MX] {
+ catch {rename ::spf::$cmd {}}
+ catch {rename ::spf::tmp_$cmd ::spf::$cmd}
+}
+
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/dns/tcllib_dns.man b/tcllib/modules/dns/tcllib_dns.man
new file mode 100644
index 0000000..c0cae7f
--- /dev/null
+++ b/tcllib/modules/dns/tcllib_dns.man
@@ -0,0 +1,242 @@
+[vset DNS_VERSION 1.3.5]
+[manpage_begin dns n [vset DNS_VERSION]]
+[see_also resolver(5)]
+[keywords DNS]
+[keywords {domain name service}]
+[keywords resolver]
+[keywords {rfc 1034}]
+[keywords {rfc 1035}]
+[keywords {rfc 1886}]
+[copyright {2002, Pat Thoyts}]
+[moddesc {Domain Name Service}]
+[titledesc {Tcl Domain Name Service Client}]
+[category Networking]
+[require Tcl 8.2]
+[require dns [opt [vset DNS_VERSION]]]
+[description]
+[para]
+
+The dns package provides a Tcl only Domain Name Service client. You
+should refer to (1) and (2) for information about the DNS protocol or
+read resolver(3) to find out how the C library resolves domain names.
+
+The intention of this package is to insulate Tcl scripts
+from problems with using the system library resolver for slow name servers.
+It may or may not be of practical use. Internet name resolution is a
+complex business and DNS is only one part of the resolver. You may
+find you are supposed to be using hosts files, NIS or WINS to name a
+few other systems. This package is not a substitute for the C library
+resolver - it does however implement name resolution over DNS.
+
+The package also extends the package [package uri] to support DNS URIs
+(4) of the form [uri dns:what.host.com] or
+[uri dns://my.nameserver/what.host.com]. The [cmd dns::resolve]
+command can handle DNS URIs or simple domain names as a query.
+
+[para]
+
+[emph Note:] The package defaults to using DNS over TCP
+connections. If you wish to use UDP you will need to have the
+[package tcludp] package installed and have a version that
+correctly handles binary data (> 1.0.4).
+This is available at [uri http://tcludp.sourceforge.net/].
+If the [package udp] package is present then UDP will be used by default.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::dns::resolve] [arg query] [opt [arg "options"]]]
+
+Resolve a domain name using the [term DNS] protocol. [arg query] is
+the domain name to be lookup up. This should be either a fully
+qualified domain name or a DNS URI.
+
+[list_begin definitions]
+[def "[cmd -nameserver] [arg hostname] or [cmd -server] [arg hostname]"]
+ Specify an alternative name server for this request.
+[def "[cmd -protocol] [arg tcp|udp]"]
+ Specify the network protocol to use for this request. Can be one of
+ [arg tcp] or [arg udp].
+[def "[cmd -port] [arg portnum]"]
+ Specify an alternative port.
+[def "[cmd -search] [arg domainlist]"]
+[def "[cmd -timeout] [arg milliseconds]"]
+ Override the default timeout.
+[def "[cmd -type] [arg TYPE]"]
+ Specify the type of DNS record you are interested in. Valid values
+ are A, NS, MD, MF, CNAME, SOA, MB, MG, MR, NULL, WKS, PTR, HINFO,
+ MINFO, MX, TXT, SPF, SRV, AAAA, AXFR, MAILB, MAILA and *.
+ See RFC1035 for details about the return values.
+ See [uri http://spf.pobox.com/] about SPF.
+ See (3) about AAAA records and RFC2782 for details of SRV records.
+
+[def "[cmd -class] [arg CLASS]"]
+ Specify the class of domain name. This is usually IN but may be one
+ of IN for internet domain names, CS, CH, HS or * for any class.
+[def "[cmd -recurse] [arg boolean]"]
+ Set to [arg false] if you do not want the name server to recursively
+ act upon your request. Normally set to [arg true].
+[def "[cmd -command] [arg procname]"]
+ Set a procedure to be called upon request completion. The procedure
+ will be passed the token as its only argument.
+[list_end]
+
+[para]
+[call [cmd ::dns::configure] [opt [arg "options"]]]
+
+The [cmd ::dns::configure] command is used to setup the dns
+package. The server to query, the protocol and domain search path are
+all set via this command. If no arguments are provided then a list of
+all the current settings is returned. If only one argument then it
+must the the name of an option and the value for that option is
+returned.
+
+[list_begin definitions]
+[def "[cmd -nameserver] [arg hostname]"]
+ Set the default name server to be used by all queries. The default is
+ [term localhost].
+[def "[cmd -protocol] [arg tcp|udp]"]
+ Set the default network protocol to be used. Default is [arg tcp].
+[def "[cmd -port] [arg portnum]"]
+ Set the default port to use on the name server. The default is 53.
+[def "[cmd -search] [arg domainlist]"]
+ Set the domain search list. This is currently not used.
+[def "[cmd -timeout] [arg milliseconds]"]
+ Set the default timeout value for DNS lookups. Default is 30 seconds.
+[def "[cmd -loglevel] [arg level]"]
+ Set the log level used for emitting diagnostic messages from this
+ package. The default is [term warn]. See the [package log] package
+ for details of the available levels.
+[list_end]
+
+[para]
+[call [cmd ::dns::name] [arg token]]
+ Returns a list of all domain names returned as an answer to your query.
+
+[para]
+[call [cmd ::dns::address] [arg token]]
+ Returns a list of the address records that match your query.
+
+[para]
+[call [cmd ::dns::cname] [arg token]]
+ Returns a list of canonical names (usually just one) matching your query.
+
+[para]
+[call [cmd ::dns::result] [arg token]]
+ Returns a list of all the decoded answer records provided for your
+ query. This permits you to extract the result for more unusual query types.
+
+[para]
+[call [cmd ::dns::status] [arg token]]
+ Returns the status flag. For a successfully completed query this will be
+ [emph ok]. May be [emph error] or [emph timeout] or [emph eof].
+ See also [cmd ::dns::error]
+
+[para]
+[call [cmd ::dns::error] [arg token]]
+ Returns the error message provided for requests whose status is [emph error].
+ If there is no error message then an empty string is returned.
+
+[para]
+[call [cmd ::dns::reset] [arg token]]
+ Reset or cancel a DNS query.
+
+[para]
+[call [cmd ::dns::wait] [arg token]]
+ Wait for a DNS query to complete and return the status upon completion.
+
+[para]
+[call [cmd ::dns::cleanup] [arg token]]
+ Remove all state variables associated with the request.
+
+[para]
+[call [cmd ::dns::nameservers]]
+
+Attempts to return a list of the nameservers currently configured
+for the users system. On a unix machine this parses the
+/etc/resolv.conf file for nameservers (if it exists) and on Windows
+systems we examine certain parts of the registry. If no nameserver can
+be found then the loopback address (127.0.0.1) is used as a default.
+
+[list_end]
+
+[comment { ----------------------------------------------------------- }]
+
+[section EXAMPLES]
+
+[para]
+[example {
+% set tok [dns::resolve www.tcl.tk]
+::dns::1
+% dns::status $tok
+ok
+% dns::address $tok
+199.175.6.239
+% dns::name $tok
+www.tcl.tk
+% dns::cleanup $tok
+}]
+
+[para]
+Using DNS URIs as queries:
+[example {
+% set tok [dns::resolve "dns:tcl.tk;type=MX"]
+% set tok [dns::resolve "dns://l.root-servers.net/www.tcl.tk"]
+}]
+
+[para]
+Reverse address lookup:
+[example {
+% set tok [dns::resolve 127.0.0.1]
+::dns::1
+% dns::name $tok
+localhost
+% dns::cleanup $tok
+}]
+
+[comment { ----------------------------------------------------------- }]
+
+[section {REFERENCES}]
+
+[list_begin enumerated]
+
+[enum]
+ Mockapetris, P., "Domain Names - Concepts and Facilities",
+ RFC 1034, November 1987.
+ ([uri http://www.ietf.org/rfc/rfc1034.txt])
+
+[enum]
+ Mockapetris, P., "Domain Names - Implementation and Specification",
+ RFC 1035, November 1087.
+ ([uri http://www.ietf.org/rfc/rfc1035.txt])
+
+[enum]
+ Thompson, S. and Huitema, C., "DNS Extensions to support IP version 6",
+ RFC 1886, December 1995.
+ ([uri http://www.ietf.org/rfc/rfc1886.txt])
+
+[enum]
+ Josefsson, S., "Domain Name System Uniform Resource Identifiers",
+ Internet-Draft, October 2003,
+ ([uri http://www.ietf.org/internet-drafts/draft-josefsson-dns-url-09.txt])
+
+[enum]
+ Gulbrandsen, A., Vixie, P. and Esibov, L.,
+ "A DNS RR for specifying the location of services (DNS SRV)",
+ RFC 2782, February 2000,
+ ([uri http://www.ietf.org/rfc/rfc2782.txt])
+
+[enum]
+ Ohta, M. "Incremental Zone Transfer in DNS",
+ RFC 1995, August 1996,
+ ([uri http://www.ietf.org/rfc/rfc1995.txt])
+
+[list_end]
+
+[section AUTHORS]
+Pat Thoyts
+
+[vset CATEGORY dns]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/dns/tcllib_ip.man b/tcllib/modules/dns/tcllib_ip.man
new file mode 100644
index 0000000..66d0e24
--- /dev/null
+++ b/tcllib/modules/dns/tcllib_ip.man
@@ -0,0 +1,451 @@
+[vset IP_VERSION 1.3]
+[manpage_begin tcllib_ip n [vset IP_VERSION]]
+[see_also inet(3)]
+[see_also ip(7)]
+[see_also ipv6(7)]
+[keywords {internet address}]
+[keywords ip]
+[keywords ipv4]
+[keywords ipv6]
+[keywords {rfc 3513}]
+[copyright {2004, Pat Thoyts}]
+[copyright {2005 Aamer Akhter <aakhter@cisco.com>}]
+[moddesc {Domain Name Service}]
+[titledesc {IPv4 and IPv6 address manipulation}]
+[category Networking]
+[require Tcl 8.2]
+[require ip [opt [vset IP_VERSION]]]
+[description]
+[para]
+
+This package provides a set of commands to help in parsing, displaying
+and comparing internet addresses. The package can handle both IPv4 (1)
+and IPv6 (2) address types.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::ip::version] [arg address]]
+
+Returns the protocol version of the address (4 or 6) or 0 if the
+address is neither IPv4 or IPv6.
+
+[call [cmd ::ip::is] [arg class] [arg address]]
+
+Returns true if the address is a member of the given protocol
+class. The class parameter may be either [arg ipv4] or [arg ipv6]
+This is effectively a boolean equivalent of the [cmd version]
+command. The [arg class] argument may be shortened to [arg 4] or
+[arg 6].
+
+[call [cmd ::ip::equal] [arg address] [arg address]]
+
+Compare two address specifications for equivalence. The arguments are
+normalized and the address prefix determined (if a mask is
+supplied). The normalized addresses are then compared bit-by-bit and
+the procedure returns true if they match.
+
+[call [cmd ::ip::normalize] [arg address]]
+
+Convert an IPv4 or IPv6 address into a fully expanded version. There
+are various shorthand ways to write internet addresses, missing out
+redundant parts or digts.. This procedure is the opposite of
+[cmd contract].
+
+[call [cmd ::ip::contract] [arg address]]
+
+Convert a [cmd normalize]d internet address into a more compact form
+suitable for displaying to users.
+
+[call [cmd ::ip::distance] [arg ipaddr1] [arg ipaddr2]]
+
+This command computes the (integer) distance from IPv4 address
+[arg ipaddr1] to IPv4 address [arg ipaddr2], i.e. "ipaddr2 - ipaddr1"
+
+[para]
+[example {
+ % ::ip::distance 1.1.1.1 1.1.1.5
+ 4
+}]
+
+[call [cmd ::ip::nextIp] [arg ipaddr] [opt [arg offset]]]
+
+This command adds the integer [arg offset] to the IPv4 address [arg ipaddr]
+and returns the new IPv4 address.
+
+[para]
+[example {
+ % ::ip::distance 1.1.1.1 4
+ 1.1.1.5
+}]
+
+[call [cmd ::ip::prefix] [arg address]]
+
+Returns the address prefix generated by masking the address part with
+the mask if provided. If there is no mask then it is equivalent to
+calling [cmd normalize]
+
+[call [cmd ::ip::type] [arg address]]
+
+[call [cmd ::ip::mask] [arg address]]
+
+If the address supplied includes a mask then this is returned
+otherwise returns an empty string.
+
+[call [cmd ::ip::prefixToNative] [arg prefix]]
+
+This command converts the string [arg prefix] from dotted form
+(<ipaddr>/<mask> format) to native (hex) form. Returns a list
+containing two elements, ipaddress and mask, in this order, in
+hexadecimal notation.
+
+[para]
+[example {
+ % ip::prefixToNative 1.1.1.0/24
+ 0x01010100 0xffffff00
+}]
+
+[call [cmd ::ip::nativeToPrefix] [arg nativeList]|[arg native] \
+ [opt [option -ipv4]]]
+
+This command converts from native (hex) form to dotted form.
+It is the complement of [cmd ::ip::prefixToNative].
+
+[para]
+[list_begin arguments]
+[arg_def list nativeList in]
+
+List of several ip addresses in native form. The native form is a list
+as returned by [cmd ::ip::prefixToNative].
+
+[arg_def list native in]
+
+A list as returned by [cmd ::ip::prefixToNative].
+
+[list_end]
+[para]
+
+The command returns a list of addresses in dotted form if it was
+called with a list of addresses. Otherwise a single address in dotted
+form is returned.
+
+[para]
+[example {
+ % ip::nativeToPrefix {0x01010100 0xffffff00} -ipv4
+ 1.1.1.0/24
+}]
+
+[call [cmd ::ip::intToString] [arg number] [opt [option -ipv4]]]
+
+This command converts from an ip address specified as integer number
+to dotted form.
+
+[para]
+[example {
+ ip::intToString 4294967295
+ 255.255.255.255
+}]
+
+[call [cmd ::ip::toInteger] [arg ipaddr]]
+
+This command converts a dotted form ip into an integer number.
+
+[para]
+[example {
+ % ::ip::toInteger 1.1.1.0
+ 16843008
+}]
+
+[call [cmd ::ip::toHex] [arg ipaddr]]
+
+This command converts dotted form ip into a hexadecimal number.
+
+[para]
+[example {
+ % ::ip::toHex 1.1.1.0
+ 0x01010100
+}]
+
+[call [cmd ::ip::maskToInt] [arg ipmask]]
+
+This command convert an ipmask in either dotted (255.255.255.0) form
+or mask length form (24) into an integer number.
+
+[para]
+[example {
+ ::ip::maskToInt 24
+ 4294967040
+}]
+
+[call [cmd ::ip::broadcastAddress] [arg prefix] [opt [option -ipv4]]]
+
+This commands returns a broadcast address in dotted form for the given
+route [arg prefix], either in the form "addr/mask", or in native
+form. The result is in dotted form.
+
+[para]
+[example {
+ ::ip::broadcastAddress 1.1.1.0/24
+ 1.1.1.255
+
+ ::ip::broadcastAddress {0x01010100 0xffffff00}
+ 0x010101ff
+}]
+
+[call [cmd ::ip::maskToLength] \
+ [arg dottedMask]|[arg integerMask]|[arg hexMask] \
+ [opt [option -ipv4]]]
+
+This command converts the dotted or integer form of an ipmask to
+the mask length form.
+
+[para]
+[example {
+ ::ip::maskToLength 0xffffff00 -ipv4
+ 24
+
+ % ::ip::maskToLength 255.255.255.0
+ 24
+}]
+
+[call [cmd ::ip::lengthToMask] [arg maskLength] \
+ [opt [option -ipv4]]]
+
+This command converts an ipmask in mask length form to its dotted
+form.
+
+[para]
+[example {
+ ::ip::lengthToMask 24
+ 255.255.255.0
+}]
+
+[call [cmd ::ip::nextNet] [arg ipaddr] [arg ipmask] \
+ [opt [arg count]] \
+ [opt [option -ipv4]]]
+
+This command returns an ipaddress in the same position in the
+[arg count] next network. The default value for [arg count] is
+[const 1].
+
+[para]
+
+The address can be specified as either integer number or in dotted
+form. The mask can be specified as either integer number, dotted form,
+or mask length form.
+
+[para]
+
+The result is in hex form.
+
+[call [cmd ::ip::isOverlap] [arg prefix] [arg prefix]...]
+
+This command checks if the given ip prefixes overlap. All arguments
+are in dotted "addr/mask" form. All arguments after the first prefix
+are compared against the first prefix. The result is a boolean
+value. It is true if an overlap was found for any of the prefixes.
+
+[para]
+[example {
+ % ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32
+ 0
+
+ ::ip::isOverlap 1.1.1.0/24 2.1.0.1/32 1.1.1.1/32
+ 1
+}]
+
+[call [cmd ::ip::isOverlapNative] \
+ [opt [option -all]] \
+ [opt [option -inline]] \
+ [opt [option -ipv4]] \
+ [arg hexipaddr] [arg hexipmask] [arg hexiplist]]
+
+This command is similar to [cmd ::ip::isOverlap], however the
+arguments are in the native form, and the form of the result is under
+greater control of the caller.
+
+If the option [option -all] is specified it checks all addresses for
+overlap, not only until the first one is found.
+
+If the option [option -inline] is specified the command returns the
+overlapping prefix instead of index values.
+
+[para]
+
+The result of the command is, depending on the specified options,
+
+[list_begin definitions]
+[def {no options}]
+
+The index of the first overlap found, or 0 if there is none.
+
+[def -all]
+
+A list containing the indices of all overlaps found, or an empty list
+
+if there are none.
+
+[def -inline]
+
+The first overlapping prefix, or an empoty string if there is none.
+
+[def {-all -inline}]
+
+A list containing the prefixes of all overlaps found, or an empty list
+if there are none.
+
+[list_end]
+
+[para]
+[example {
+ % ::ip::isOverlapNative 0x01010100 0xffffff00 {{0x02010001 0xffffffff}}
+ 0
+
+ % ::ip::isOverlapNative 0x01010100 0xffffff00 {{0x02010001 0xffffffff} {0x01010101 0xffffffff}}
+ 2
+}]
+
+[call [cmd ::ip::ipToLayer2Multicast] [arg ipaddr]]
+
+This command an converts ipv4 address in dotted form into a layer 2
+multicast address, also in dotted form.
+
+[para]
+[example {
+ % ::ip::ipToLayer2Multicast 224.0.0.2
+ 01.00.5e.00.00.02
+}]
+
+[call [cmd ::ip::ipHostFromPrefix] [arg prefix] \
+ [opt "[option -exclude] [arg prefixExcludeList]"]]
+
+This command returns a host address from a prefix in the form
+"ipaddr/masklen", also making sure that the result is not an address
+found in the [arg prefixExcludeList].
+
+The result is an ip address in dotted form.
+
+[para]
+[example {
+ %::ip::ipHostFromPrefix 1.1.1.5/24
+ 1.1.1.1
+
+ %::ip::ipHostFromPrefix 1.1.1.1/32
+ 1.1.1.1
+}]
+
+[call [cmd ::ip::reduceToAggregates] [arg prefixlist]]
+
+This command finds nets that overlap and filters out the more specific
+nets. The prefixes are in either addr/mask form or in native format.
+
+The result is a list containing the non-overlapping ip prefixes from
+the input.
+
+[para]
+[example {
+ % ::ip::reduceToAggregates {1.1.1.0/24 1.1.0.0/8 2.1.1.0/24 1.1.1.1/32 }
+ 1.0.0.0/8 2.1.1.0/24
+}]
+
+[call [cmd ::ip::longestPrefixMatch] [arg ipaddr] [arg prefixlist] \
+ [opt [option -ipv4]]]
+
+This command finds longest prefix match from set of prefixes, given a
+specific host address. The prefixes in the list are in either native
+or dotted form, whereas the host address is in either ipprefix format,
+dotted form, or integer form.
+
+The result is the prefix which is the most specific match to the host
+address.
+
+[para]
+[example {
+ % ::ip::longestPrefixMatch 1.1.1.1 {1.1.1.0/24 1.0.0.0/8 2.1.1.0/24 1.1.1.0/28 }
+ 1.1.1.0/28
+}]
+
+[call [cmd ::ip::collapse] [arg prefixlist]]
+
+This commands takes a list of prefixes and returns a list prefixes
+with the largest possible subnet masks covering the input, in this
+manner collapsing adjacent prefixes into larger ranges.
+
+[para] This is different from [cmd ::ip::reduceToAggregates] in that
+the latter only removes specific nets from a list when they are
+covered by other elements of the input whereas this command actively
+merges nets into larger ranges when they are adjacent to each other.
+
+[para]
+[example {
+% ::ip::collapse {1.2.2.0/24 1.2.3.0/24}
+1.2.2.0/23
+}]
+
+[call [cmd ::ip::subtract] [arg prefixlist]]
+
+This command takes a list of prefixes, some of which are prefixed by a
+dash. These latter [term negative] prefixes are used to punch holes
+into the ranges described by the other, [term positive],
+prefixes. I.e. the negative prefixes are subtracted frrom the positive
+ones, resulting in a larger list of describes describing the covered
+ranges only as positives.
+
+[list_end]
+
+[comment { ----------------------------------------------------------- }]
+
+[section EXAMPLES]
+[para]
+
+[example {
+% ip::version ::1
+6
+% ip::version 127.0.0.1
+4
+}]
+
+[example {
+% ip::normalize 127/8
+127.0.0.0/8
+% ip::contract 192.168.0.0
+192.168
+%
+% ip::normalize fec0::1
+fec0:0000:0000:0000:0000:0000:0000:0001
+% ip::contract fec0:0000:0000:0000:0000:0000:0000:0001
+fec0::1
+}]
+
+[example {
+% ip::equal 192.168.0.4/16 192.168.0.0/16
+1
+% ip::equal fec0::1/10 fec0::fe01/10
+1
+}]
+
+[comment { ----------------------------------------------------------- }]
+
+[section {REFERENCES}]
+
+[list_begin enumerated]
+
+[enum]
+ Postel, J. "Internet Protocol." RFC 791, September 1981,
+ ([uri http://www.ietf.org/rfc/rfc791.txt])
+
+[enum]
+ Hinden, R. and Deering, S.,
+ "Internet Protocol Version 6 (IPv6) Addressing Architecture",
+ RFC 3513, April 2003
+ ([uri http://www.ietf.org/rfc/rfc3513.txt])
+
+[list_end]
+
+[section AUTHORS]
+Pat Thoyts
+
+[vset CATEGORY dns]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/docstrip/ChangeLog b/tcllib/modules/docstrip/ChangeLog
new file mode 100644
index 0000000..bcc9767
--- /dev/null
+++ b/tcllib/modules/docstrip/ChangeLog
@@ -0,0 +1,127 @@
+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-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-09-13 Lars Hellstr\"om <lars_h@users.sourceforge.net>
+
+ docstrip::util version is now 1.3.
+
+ * New docstrip::util feature:
+ In-file catalogue of file contents,
+ which can be used to create pkgIndex.tcl
+ entries or .tm files.
+ * Improved documentation of existing
+ docstrip::util commands.
+ * Changed docstrip::util::thefile to strip
+ away a final newline.
+ * Fixed bug #3036841.
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tcldocstrip.dtx: Moved a number of documentation cleanup changes
+ * docstrip.man: into the master DTX file, and added category
+ * docstrip_util.man: information.
+
+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-28 Andreas Kupries <andreask@activestate.com>
+
+ * apps/tcldocstrip: Added a block of meta data.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tcldocstrip.dtx: Modified the setup of the testsuite to match
+ the other modules and packages in tcllib. The testsuite
+ especially now handles execution in a too old a Tcl core
+ properly.
+ * docstrip.test: Regenerated.
+ * docstrip_util.test: Regenerated.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-10-04 Andreas Kupries <andreask@activestate.com>
+
+ * tcldocstrip.dtx: Applied changes made by Lars to fix
+ * tcldocstrip.ins: a number of bugs he found. I am doing
+ * tcldocstrip.stitch: it in his stead as he currently has
+ trouble with the SF CVS. Also fixed a syntax error in the
+ documentation.
+
+ * Regenerated the other files. One new file,
+ "docstrip_util.test". All tests pass, regular and from within
+ the test harness.
+
+2005-09-26 Andreas Kupries <andreask@activestate.com>
+
+ * tcldocstrip.dtx: Fixed the testsuite bug regarding access to
+ files in the module under test.
+
+ * docstrip.test: Regenerated.
+
+2005-08-30 Andreas Kupries <andreask@activestate.com>
+
+ * tcldocstrip.dtx:
+ * docstrip_util.man: Fixed formatting problem in manpage. (Added a
+ missing closing bracket, and removed bad splitting across lines).
+
+ * Added entry for a large commit done by Lars to the ChangeLog, on
+ behalf on Lars. See entry immediately below.
+
+2005-08-28 Lars Hellstroem
+
+ * New docstrip::util commands: guards, thefile, patch, and
+ import_unidiff. New -annotate option of docstrip::extract (used
+ by docstrip::util::patch). patch and import_unidiff still lack
+ .man documentation. The docstrip::util package still lacks
+ tests.
+
+2005-02-14 Andreas Kupries <andreask@activestate.com>
+
+ * docstrip: New module, by Lars Hellstroem, to support literate programming.
+
diff --git a/tcllib/modules/docstrip/docstrip.man b/tcllib/modules/docstrip/docstrip.man
new file mode 100644
index 0000000..95795d4
--- /dev/null
+++ b/tcllib/modules/docstrip/docstrip.man
@@ -0,0 +1,435 @@
+[manpage_begin docstrip n 1.2]
+[see_also docstrip_util]
+[keywords .dtx]
+[keywords docstrip]
+[keywords documentation]
+[keywords LaTeX]
+[keywords {literate programming}]
+[keywords source]
+[copyright "2003\u20132010 Lars Hellstr\u00F6m\
+ <Lars dot Hellstrom at residenset dot net>"]
+[moddesc {Literate programming tool}]
+[titledesc {Docstrip style source code extraction}]
+[category {Documentation tools}]
+[require Tcl 8.4]
+[require docstrip [opt 1.2]]
+[vset emdash \u2014]
+[description]
+
+[syscmd Docstrip] is a tool created to support a brand of Literate
+Programming. It is most common in the (La)TeX community, where it
+is being used for pretty much everything from the LaTeX core and up,
+but there is nothing about [syscmd docstrip] which prevents using it
+for other types of software.
+[para]
+
+In short, the basic principle of literate programming is that program
+source should primarily be written and structured to suit the
+developers (and advanced users who want to peek "under the hood"), not
+to suit the whims of a compiler or corresponding source code consumer.
+This means literate sources often need some kind of "translation" to an
+illiterate form that dumb software can understand.
+The [package docstrip] Tcl package handles this translation.
+[para]
+
+Even for those who do not whole-hartedly subscribe to the philosophy
+behind literate programming, [syscmd docstrip] can bring greater
+clarity to in particular:
+[list_begin itemized]
+ [item] programs employing non-obvious mathematics
+ [item] projects where separate pieces of code, perhaps in
+ different languages, need to be closely coordinated.
+[list_end]
+The first is by providing access to much more powerful typographical
+features for source code comments than are possible in plain text.
+The second is because all the separate pieces of code can be kept
+next to each other in the same source file.
+[para]
+
+The way it works is that the programmer edits directly only one or
+several "master" source code files, from which [syscmd docstrip]
+generates the more traditional "source" files compilers or the like
+would expect. The master sources typically contain a large amount of
+documentation of the code, sometimes even in places where the code
+consumers would not allow any comments. The etymology of "docstrip"
+is that this [emph doc]umentation was [emph strip]ped away (although
+"code extraction" might be a better description, as it has always
+been a matter of copying selected pieces of the master source rather
+than deleting text from it).
+The [package docstrip] Tcl package contains a reimplementation of
+the basic extraction functionality from the [syscmd docstrip]
+program, and thus makes it possible for a Tcl interpreter to read
+and interpret the master source files directly.
+[para]
+
+Readers who are not previously familiar with [syscmd docstrip] but
+want to know more about it may consult the following sources.
+[list_begin enumerated]
+[enum]
+ [emph {The tclldoc package and class}],
+ [uri {http://ctan.org/tex-archive/macros/latex/contrib/tclldoc/}].
+[enum]
+ [emph {The DocStrip utility}],
+ [uri {http://ctan.org/tex-archive/macros/latex/base/docstrip.dtx}].
+[enum]
+ [emph {The doc and shortvrb Packages}],
+ [uri {http://ctan.org/tex-archive/macros/latex/base/doc.dtx}].
+[enum]
+ Chapter 14 of
+ [emph {The LaTeX Companion}] (second edition),
+ Addison-Wesley, 2004; ISBN 0-201-36299-6.
+[list_end]
+
+[section {File format}]
+
+The basic unit [syscmd docstrip] operates on are the [emph lines] of
+a master source file. Extraction consists of selecting some of these
+lines to be copied from input text to output text. The basic
+distinction is that between [emph {code lines}] (which are copied and
+do not begin with a percent character) and [emph {comment lines}]
+(which begin with a percent character and are not copied).
+
+[example {
+ docstrip::extract [join {
+ {% comment}
+ {% more comment !"#$%&/(}
+ {some command}
+ { % blah $blah "Not a comment."}
+ {% abc; this is comment}
+ {# def; this is code}
+ {ghi}
+ {% jkl}
+ } \n] {}
+}]
+returns the same sequence of lines as
+[example {
+ join {
+ {some command}
+ { % blah $blah "Not a comment."}
+ {# def; this is code}
+ {ghi} ""
+ } \n
+}]
+
+It does not matter to [syscmd docstrip] what format is used for the
+documentation in the comment lines, but in order to do better than
+plain text comments, one typically uses some markup language. Most
+commonly LaTeX is used, as that is a very established standard and
+also provides the best support for mathematical formulae, but the
+[package docstrip::util] package also gives some support for
+[term doctools]-like markup.
+[para]
+
+Besides the basic code and comment lines, there are also
+[emph {guard lines}], which begin with the two characters '%<', and
+[emph {meta-comment lines}], which begin with the two characters
+'%%'. Within guard lines there is furthermore the distinction between
+[emph {verbatim guard lines}], which begin with '%<<', and ordinary
+guard lines, where the '%<' is not followed by another '<'. The last
+category is by far the most common.
+[para]
+
+Ordinary guard lines conditions extraction of the code line(s) they
+guard by the value of a boolean expression; the guarded block of
+code lines will only be included if the expression evaluates to true.
+The syntax of an ordinary guard line is one of
+[example {
+ '%' '<' STARSLASH EXPRESSION '>'
+ '%' '<' PLUSMINUS EXPRESSION '>' CODE
+}]
+where
+[example {
+ STARSLASH ::= '*' | '/'
+ PLUSMINUS ::= | '+' | '-'
+ EXPRESSION ::= SECONDARY | SECONDARY ',' EXPRESSION
+ | SECONDARY '|' EXPRESSION
+ SECONDARY ::= PRIMARY | PRIMARY '&' SECONDARY
+ PRIMARY ::= TERMINAL | '!' PRIMARY | '(' EXPRESSION ')'
+ CODE ::= { any character except end-of-line }
+}]
+Comma and vertical bar both denote 'or'. Ampersand denotes 'and'.
+Exclamation mark denotes 'not'. A TERMINAL can be any nonempty string
+of characters not containing '>', '&', '|', comma, '(', or ')',
+although the [syscmd docstrip] manual is a bit restrictive and only
+guarantees proper operation for strings of letters (although even
+the LaTeX core sources make heavy use also of digits in TERMINALs).
+The second argument of [cmd docstrip::extract] is the list of those
+TERMINALs that should count as having the value 'true'; all other
+TERMINALs count as being 'false' when guard expressions are evaluated.
+[para]
+
+In the case of a '%<*[emph EXPRESSION]>' guard, the lines guarded are
+all lines up to the next '%</[emph EXPRESSION]>' guard with the same
+[emph EXPRESSION] (compared as strings). The blocks of code delimited
+by such '*' and '/' guard lines must be properly nested.
+[example {
+ set text [join {
+ {begin}
+ {%<*foo>}
+ {1}
+ {%<*bar>}
+ {2}
+ {%</bar>}
+ {%<*!bar>}
+ {3}
+ {%</!bar>}
+ {4}
+ {%</foo>}
+ {5}
+ {%<*bar>}
+ {6}
+ {%</bar>}
+ {end}
+ } \n]
+ set res [docstrip::extract $text foo]
+ append res [docstrip::extract $text {foo bar}]
+ append res [docstrip::extract $text bar]
+}]
+sets $res to the result of
+[example {
+ join {
+ {begin}
+ {1}
+ {3}
+ {4}
+ {5}
+ {end}
+ {begin}
+ {1}
+ {2}
+ {4}
+ {5}
+ {6}
+ {end}
+ {begin}
+ {5}
+ {6}
+ {end} ""
+ } \n
+}]
+
+In guard lines without a '*', '/', '+', or '-' modifier after the
+'%<', the guard applies only to the CODE following the '>' on that
+single line. A '+' modifier is equivalent to no modifier. A '-'
+modifier is like the case with no modifier, but the expression is
+implicitly negated, i.e., the CODE of a '%<-' guard line is only
+included if the expression evaluates to false.
+[para]
+
+Metacomment lines are "comment lines which should not be stripped
+away", but be extracted like code lines; these are sometimes used for
+copyright notices and similar material. The '%%' prefix is however
+not kept, but substituted by the current [option -metaprefix], which
+is customarily set to some "comment until end of line" character (or
+character sequence) of the language of the code being extracted.
+[example {
+ set text [join {
+ {begin}
+ {%<foo> foo}
+ {%<+foo>plusfoo}
+ {%<-foo>minusfoo}
+ {middle}
+ {%% some metacomment}
+ {%<*foo>}
+ {%%another metacomment}
+ {%</foo>}
+ {end}
+ } \n]
+ set res [docstrip::extract $text foo -metaprefix {# }]
+ append res [docstrip::extract $text bar -metaprefix {#}]
+}]
+sets $res to the result of
+[example {
+ join {
+ {begin}
+ { foo}
+ {plusfoo}
+ {middle}
+ {# some metacomment}
+ {# another metacomment}
+ {end}
+ {begin}
+ {minusfoo}
+ {middle}
+ {# some metacomment}
+ {end} ""
+ } \n
+}]
+
+Verbatim guards can be used to force code line
+interpretation of a block of lines even if some of them happen to look
+like any other type of lines to docstrip. A verbatim guard has the
+form '%<<[emph END-TAG]' and the verbatim block is terminated by the
+first line that is exactly '%[emph END-TAG]'.
+[example {
+ set text [join {
+ {begin}
+ {%<*myblock>}
+ {some stupid()}
+ { #computer<program>}
+ {%<<QQQ-98765}
+ {% These three lines are copied verbatim (including percents}
+ {%% even if -metaprefix is something different than %%).}
+ {%</myblock>}
+ {%QQQ-98765}
+ { using*strange@programming<language>}
+ {%</myblock>}
+ {end}
+ } \n]
+ set res [docstrip::extract $text myblock -metaprefix {# }]
+ append res [docstrip::extract $text {}]
+}]
+sets $res to the result of
+[example {
+ join {
+ {begin}
+ {some stupid()}
+ { #computer<program>}
+ {% These three lines are copied verbatim (including percents}
+ {%% even if -metaprefix is something different than %%).}
+ {%</myblock>}
+ { using*strange@programming<language>}
+ {end}
+ {begin}
+ {end} ""
+ } \n
+}]
+The processing of verbatim guards takes place also inside blocks of
+lines which due to some outer block guard will not be copied.
+[para]
+
+The final piece of [syscmd docstrip] syntax is that extraction
+stops at a line that is exactly "\endinput"; this is often used to
+avoid copying random whitespace at the end of a file. In the unlikely
+case that one wants such a code line, one can protect it with a
+verbatim guard.
+
+[section Commands]
+
+The package defines two commands.
+
+[list_begin definitions]
+[call [cmd docstrip::extract] [arg text] [arg terminals] [
+ opt "[arg option] [arg value] ..."
+]]
+ The [cmd extract] command docstrips the [arg text] and returns the
+ extracted lines of code, as a string with each line terminated with
+ a newline. The [arg terminals] is the list of those guard
+ expression terminals which should evaluate to true.
+ The available options are:
+ [list_begin options]
+ [opt_def -annotate [arg lines]]
+ Requests the specified number of lines of annotation to follow
+ each extracted line in the result. Defaults to 0. Annotation lines
+ are mostly useful when the extracted lines are to undergo some
+ further transformation. A first annotation line is a list of three
+ elements: line type, prefix removed in extraction, and prefix
+ inserted in extraction. The line type is one of: 'V' (verbatim),
+ 'M' (metacomment), '+' (+ or no modifier guard line), '-' (-
+ modifier guard line), '.' (normal line). A second annotation line
+ is the source line number. A third annotation line is the current
+ stack of block guards. Requesting more than three lines of
+ annotation is currently not supported.
+ [opt_def -metaprefix [arg string]]
+ The string by which the '%%' prefix of a metacomment line will
+ be replaced. Defaults to '%%'. For Tcl code this would typically
+ be '#'.
+ [opt_def -onerror [arg keyword]]
+ Controls what will be done when a format error in the [arg text]
+ being processed is detected. The settings are:
+ [list_begin definitions]
+ [def [const ignore]]
+ Just ignore the error; continue as if nothing happened.
+ [def [const puts]]
+ Write an error message to [const stderr], then continue
+ processing.
+ [def [const throw]]
+ Throw an error. The [option -errorcode] is set to a list whose
+ first element is [const DOCSTRIP], second element is the
+ type of error, and third element is the line number where
+ the error is detected. This is the default.
+ [list_end]
+ [opt_def -trimlines [arg boolean]]
+ Controls whether [emph spaces] at the end of a line should be
+ trimmed away before the line is processed. Defaults to true.
+ [list_end]
+
+ It should be remarked that the [arg terminals] are often called
+ "options" in the context of the [syscmd docstrip] program, since
+ these specify which optional code fragments should be included.
+
+[call [cmd docstrip::sourcefrom] [arg filename] [arg terminals] [
+ opt "[arg option] [arg value] ..."
+]]
+ The [cmd sourcefrom] command is a docstripping emulation of
+ [cmd source]. It opens the file [arg filename], reads it, closes it,
+ docstrips the contents as specified by the [arg terminals], and
+ evaluates the result in the local context of the caller, during
+ which time the [cmd info] [method script] value will be the
+ [arg filename]. The options are passed on to [cmd fconfigure] to
+ configure the file before its contents are read. The
+ [option -metaprefix] is set to '#', all other [cmd extract]
+ options have their default values.
+[list_end]
+
+
+[section {Document structure}]
+
+The file format (as described above) determines whether a master
+source code file can be processed correctly by [syscmd docstrip],
+but the usefulness of the format is to no little part also dependent
+on that the code and comment lines together constitute a well-formed
+document.
+[para]
+
+For a document format that does not require any non-Tcl software, see
+the [cmd ddt2man] command in the [package docstrip::util] package. It
+is suggested that files employing that document format are given the
+suffix [file .ddt], to distinguish them from the more traditional
+LaTeX-based [file .dtx] files.
+[para]
+
+Master source files with [file .dtx] extension are usually set up so
+that they can be typeset directly by [syscmd latex] without any
+support from other files. This is achieved by beginning the file
+with the lines
+[example_begin]
+ % \iffalse
+ %<*driver>
+ \documentclass{tclldoc}
+ \begin{document}
+ \DocInput{[emph filename.dtx]}
+ \end{document}
+ %</driver>
+ % \fi
+[example_end]
+or some variation thereof. The trick is that the file gets read twice.
+With normal LaTeX reading rules, the first two lines are comments and
+therefore ignored. The third line is the document preamble, the fourth
+line begins the document body, and the sixth line ends the document,
+so LaTeX stops there [vset emdash] non-comments below that point in
+the file are never subjected to the normal LaTeX reading rules. Before
+that, however, the \DocInput command on the fifth line is processed,
+and that does two things: it changes the interpretation of '%' from
+"comment" to "ignored", and it inputs the file specified in the
+argument (which is normally the name of the file the command is in).
+It is this second time that the file is being read that the comments
+and code in it are typeset.
+[para]
+
+The function of the \iffalse ... \fi is to skip lines two to seven
+on this second time through; this is similar to the "if 0 { ... }"
+idiom for block comments in Tcl code, and it is needed here because
+(amongst other things) the \documentclass command may only be
+executed once. The function of the <driver> guards is to prevent this
+short piece of LaTeX code from being extracted by [syscmd docstrip].
+The total effect is that the file can function both as a LaTeX
+document and as a [syscmd docstrip] master source code file.
+[para]
+
+It is not necessary to use the tclldoc document class, but that does
+provide a number of features that are convenient for [file .dtx]
+files containing Tcl code. More information on this matter can be
+found in the references above.
+
+[manpage_end]
diff --git a/tcllib/modules/docstrip/docstrip.tcl b/tcllib/modules/docstrip/docstrip.tcl
new file mode 100644
index 0000000..fa6399b
--- /dev/null
+++ b/tcllib/modules/docstrip/docstrip.tcl
@@ -0,0 +1,163 @@
+##
+## This is the file `docstrip.tcl',
+## generated with the SAK utility
+## (sak docstrip/regen).
+##
+## The original source files were:
+##
+## tcldocstrip.dtx (with options: `pkg')
+##
+## In other words:
+## **************************************
+## * This Source is not the True Source *
+## **************************************
+## the true source is the file from which this one was generated.
+##
+package require Tcl 8.4
+package provide docstrip 1.2
+namespace eval docstrip {
+ namespace export extract sourcefrom
+}
+proc docstrip::extract {text terminals args} {
+ array set O {
+ -annotate 0
+ -metaprefix %%
+ -onerror throw
+ -trimlines 1
+ }
+ array set O $args
+ foreach t $terminals {set T($t) ""}
+ set stripped ""
+ set block_stack [list]
+ set offlevel 0
+ set verbatim 0
+ set lineno 0
+ foreach line [split $text \n] {
+ incr lineno
+ if {$O(-trimlines)} then {
+ set line [string trimright $line " "]
+ }
+ if {$verbatim} then {
+ if {$line eq $endverbline} then {
+ set verbatim 0
+ continue
+ } elseif {$offlevel} then {
+ continue
+ }
+ append stripped $line \n
+ if {$O(-annotate)>=1} then {append stripped {V "" ""} \n}
+ } else {
+ switch -glob -- $line %%* {
+ if {!$offlevel} then {
+ append stripped $O(-metaprefix)\
+ [string range $line 2 end] \n
+ if {$O(-annotate)>=1} then {
+ append stripped [list M %% $O(-metaprefix)] \n
+ }
+ }
+ } %<<* {
+ set endverbline "%[string range $line 3 end]"
+ set verbatim 1
+ continue
+ } %<* {
+ if {![
+ regexp -- {^%<([*/+-]?)([^>]*)>(.*)$} $line ""\
+ modifier expression line
+ ]} then {
+ extract,error BADGUARD\
+ "Malformed guard \"\n$line\n\""
+ "Malformed guard on line $lineno"
+ continue
+ }
+ regsub -all -- {\\|\{|\}|\$|\[|\]| |;} $expression\
+ {\\&} E
+ regsub -all -- {,} $E {|} E
+ regsub -all -- {[^()|&!]+} $E {[info exists T(&)]} E
+ if {[catch {expr $E} val]} then {
+ extract,error EXPRERR\
+ "Error in expression <$expression> ignored"\
+ "docstrip: $val"
+ set val -1
+ }
+ switch -exact -- $modifier * {
+ lappend block_stack $expression
+ if {$offlevel || !$val} then {incr offlevel}
+ continue
+ } / {
+ if {![llength $block_stack]} then {
+ extract,error SPURIOUS\
+ "Spurious end block </$expression> ignored"\
+ "Spurious end block </$expression>"
+ } else {
+ if {[string compare $expression\
+ [lindex $block_stack end]]} then {
+ extract,error MISMATCH\
+ "Found </$expression> instead of\
+ </[lindex $block_stack end]>"
+ }
+ if {$offlevel} then {incr offlevel -1}
+ set block_stack [lreplace $block_stack end end]
+ }
+ continue
+ } - {
+ if {$offlevel || $val} then {continue}
+ append stripped $line \n
+ if {$O(-annotate)>=1} then {
+ append stripped [list - %<-${expression}> ""] \n
+ }
+ } default {
+ if {$offlevel || !$val} then {continue}
+ append stripped $line \n
+ if {$O(-annotate)>=1} then {
+ append stripped\
+ [list + %<${modifier}${expression}> ""] \n
+ }
+ }
+ } %* {continue}\
+ {\\endinput} {
+ break
+ } default {
+ if {$offlevel} then {continue}
+ append stripped $line \n
+ if {$O(-annotate)>=1} then {append stripped {. "" ""} \n}
+ }
+ }
+ if {$O(-annotate)>=2} then {append stripped $lineno \n}
+ if {$O(-annotate)>=3} then {append stripped $block_stack \n}
+ }
+ return $stripped
+}
+proc docstrip::extract,error {situation message {errmessage ""}} {
+ upvar 1 O(-onerror) onerror lineno lineno
+ switch -- [string tolower $onerror] "puts" {
+ puts stderr "docstrip: $message on line $lineno."
+ } "ignore" {} default {
+ if {$errmessage ne ""} then {
+ error $errmessage "" [list DOCSTRIP $situation $lineno]
+ } else {
+ error $message "" [list DOCSTRIP $situation $lineno]
+ }
+ }
+}
+proc docstrip::sourcefrom {name terminals args} {
+ set F [open $name r]
+ if {[llength $args]} then {
+ eval [linsert $args 0 fconfigure $F]
+ }
+ set text [read $F]
+ close $F
+ set oldscr [info script]
+ info script $name
+ set code [catch {
+ uplevel 1 [extract $text $terminals -metaprefix #]
+ } res]
+ info script $oldscr
+ if {$code == 1} then {
+ error $res $::errorInfo $::errorCode
+ } else {
+ return $res
+ }
+}
+##
+##
+## End of file `docstrip.tcl'. \ No newline at end of file
diff --git a/tcllib/modules/docstrip/docstrip.test b/tcllib/modules/docstrip/docstrip.test
new file mode 100644
index 0000000..f7ffd94
--- /dev/null
+++ b/tcllib/modules/docstrip/docstrip.test
@@ -0,0 +1,243 @@
+##
+## This is the file `docstrip.test',
+## generated with the SAK utility
+## (sak docstrip/regen).
+##
+## The original source files were:
+##
+## tcldocstrip.dtx (with options: `test tcllibtest')
+##
+## In other words:
+## **************************************
+## * This Source is not the True Source *
+## **************************************
+## the true source is the file from which this one was generated.
+##
+source [file join\
+ [file dirname [file dirname [file join [pwd] [info script]]]]\
+ devtools testutilities.tcl]
+testsNeedTcl 8.4
+testsNeedTcltest 2
+testing {useLocal docstrip.tcl docstrip}
+variable docstrip_sources_dir [localPath {}]
+tcltest::testConstraint docstripSourcesAvailable [expr {[
+ file exists [file join $docstrip_sources_dir docstrip.tcl]
+] && [
+ file exists [file join $docstrip_sources_dir tcldocstrip.dtx]
+]}]
+tcltest::test docstrip-1.1 {code/comment line distinction} -body {
+ docstrip::extract [join {
+ {% comment}
+ {% more comment !"#$%&/(}
+ {some command}
+ { % blah $blah "Not a comment."}
+ {% abc; this is comment}
+ {# def; this is code}
+ {ghi}
+ {% jkl}
+ } \n] {}
+} -result [
+ join {
+ {some command}
+ { % blah $blah "Not a comment."}
+ {# def; this is code}
+ {ghi} ""
+ } \n
+]
+tcltest::test docstrip-1.2 {blocks and nesting} -body {
+ set text [join {
+ {begin}
+ {%<*foo>}
+ {1}
+ {%<*bar>}
+ {2}
+ {%</bar>}
+ {%<*!bar>}
+ {3}
+ {%</!bar>}
+ {4}
+ {%</foo>}
+ {5}
+ {%<*bar>}
+ {6}
+ {%</bar>}
+ {end}
+ } \n]
+ set res [docstrip::extract $text foo]
+ append res [docstrip::extract $text {foo bar}]
+ append res [docstrip::extract $text bar]
+} -result [
+ join {
+ {begin}
+ {1}
+ {3}
+ {4}
+ {5}
+ {end}
+ {begin}
+ {1}
+ {2}
+ {4}
+ {5}
+ {6}
+ {end}
+ {begin}
+ {5}
+ {6}
+ {end} ""
+ } \n
+]
+tcltest::test docstrip-1.3 {plusminus guards and metacomments} -body {
+ set text [join {
+ {begin}
+ {%<foo> foo}
+ {%<+foo>plusfoo}
+ {%<-foo>minusfoo}
+ {middle}
+ {%% some metacomment}
+ {%<*foo>}
+ {%%another metacomment}
+ {%</foo>}
+ {end}
+ } \n]
+ set res [docstrip::extract $text foo -metaprefix {# }]
+ append res [docstrip::extract $text bar -metaprefix {#}]
+} -result [
+ join {
+ {begin}
+ { foo}
+ {plusfoo}
+ {middle}
+ {# some metacomment}
+ {# another metacomment}
+ {end}
+ {begin}
+ {minusfoo}
+ {middle}
+ {# some metacomment}
+ {end} ""
+ } \n
+]
+tcltest::test docstrip-1.4 {verbatim mode} -body {
+ set text [join {
+ {begin}
+ {%<*myblock>}
+ {some stupid()}
+ { #computer<program>}
+ {%<<QQQ-98765}
+ {% These three lines are copied verbatim (including percents}
+ {%% even if -metaprefix is something different than %%).}
+ {%</myblock>}
+ {%QQQ-98765}
+ { using*strange@programming<language>}
+ {%</myblock>}
+ {end}
+ } \n]
+ set res [docstrip::extract $text myblock -metaprefix {# }]
+ append res [docstrip::extract $text {}]
+} -result [
+ join {
+ {begin}
+ {some stupid()}
+ { #computer<program>}
+ {% These three lines are copied verbatim (including percents}
+ {%% even if -metaprefix is something different than %%).}
+ {%</myblock>}
+ { using*strange@programming<language>}
+ {end}
+ {begin}
+ {end} ""
+ } \n
+]
+tcltest::test docstrip-1.5 {annotation} -body {
+ set text [join {
+ {begin}
+ {%<*myblock>}
+ {some stupid()}
+ {%<foo> #computer<program>}
+ {%<<QQQ-98765}
+ {% These three lines are copied verbatim (including percents}
+ {%% even if -metaprefix is something different than %%).}
+ {%</myblock>}
+ {%QQQ-98765}
+ { using*strange@programming<language>}
+ {%</myblock>}
+ {%%end}
+ } \n]
+ docstrip::extract $text {myblock foo} -metaprefix {# } -annotate 3
+} -result [
+ join {
+ {begin} {. "" ""} 1 {}
+ {some stupid()} {. "" ""} 3 myblock
+ { #computer<program>} {+ %<foo> {}} 4 myblock
+ {% These three lines are copied verbatim (including percents}
+ {V "" ""} 6 myblock
+ {%% even if -metaprefix is something different than %%).}
+ {V "" ""} 7 myblock
+ {%</myblock>} {V "" ""} 8 myblock
+ { using*strange@programming<language>} {. "" ""} 10 myblock
+ {# end} {M %% {# }} 12 {}
+ ""
+ } \n
+]
+tcltest::test docstrip-2.1 {have docstrip extract itself} -constraints {
+ docstripSourcesAvailable
+} -body {
+ # First read in the ready-stripped file, but gobble the preamble and
+ # postamble, as those are a bit messy to reproduce.
+ set F [open [file join $docstrip_sources_dir docstrip.tcl] r]
+ regsub -all -- {(^|\n)#[^\n]*} [read $F] {} stripped
+ close $F
+ # Then read the master source and strip it manually.
+ set F [open [file join $docstrip_sources_dir tcldocstrip.dtx] r]
+ set source [read $F]
+ close $F
+ set stripped2 [docstrip::extract $source pkg -metaprefix ##]
+ # Finally compare the two.
+ if {[string trim $stripped \n] ne [string trim $stripped2 \n]} then {
+ error "$strippped\n ne \n$stripped2"
+ }
+}
+tcltest::test docstrip-2.2 {soucefrom} -setup {
+ set dtxname [tcltest::makeFile [join {
+ {% Just a minor test file.}
+ {puts A}
+ {%<*bar>}
+ {puts B}
+ {%<*foo>}
+ {puts [info exists baz]}
+ {set baz 1}
+ {%</foo>}
+ {%<-foo>return}
+ {%</bar>}
+ {puts $baz}
+ {puts [file tail [info script]]}
+ {%<*!foo>}
+ {puts C}
+ "%% Tricky comment; guess what comes next\\"
+ {%</!foo>}
+ {incr baz}
+ {puts "baz=$baz"}
+ } \n] te27st01.dtx]
+} -body {
+ set baz 0
+ puts [info script]
+ docstrip::sourcefrom $dtxname {foo bar}
+ puts [info script]
+ docstrip::sourcefrom $dtxname {}
+ docstrip::sourcefrom $dtxname {bar}
+ puts $baz
+} -cleanup {
+ tcltest::removeFile $dtxname
+} -output [join [list\
+ [info script]\
+ {A} {B} {1} {1} {te27st01.dtx} {baz=2}\
+ [info script]\
+ {A} {2} {te27st01.dtx} {C} {baz=2}\
+ {A} {B}\
+ {2} ""
+] \n]
+testsuiteCleanup
+##
+##
+## End of file `docstrip.test'. \ No newline at end of file
diff --git a/tcllib/modules/docstrip/docstrip_util.man b/tcllib/modules/docstrip/docstrip_util.man
new file mode 100644
index 0000000..35e73c7
--- /dev/null
+++ b/tcllib/modules/docstrip/docstrip_util.man
@@ -0,0 +1,586 @@
+[vset VERSION 1.3.1]
+[manpage_begin docstrip_util n [vset VERSION]]
+[see_also docstrip]
+[see_also doctools]
+[see_also doctools_fmt]
+[keywords .ddt]
+[keywords .dtx]
+[keywords catalogue]
+[keywords diff]
+[keywords docstrip]
+[keywords doctools]
+[keywords documentation]
+[keywords LaTeX]
+[keywords {literate programming}]
+[keywords module]
+[keywords {package indexing}]
+[keywords patch]
+[keywords source]
+[keywords {Tcl module}]
+[copyright "2003\u20132010 Lars Hellstr\u00F6m\
+ <Lars dot Hellstrom at residenset dot net>"]
+[moddesc {Literate programming tool}]
+[titledesc {Docstrip-related utilities}]
+[category {Documentation tools}]
+[require Tcl 8.4]
+[require docstrip [opt 1.2]]
+[require docstrip::util [opt [vset VERSION]]]
+[vset emdash \u2014]
+[description]
+The [package docstrip::util] package is meant for collecting various
+utility procedures that are mainly useful at installation or
+development time. It is separate from the base package to avoid
+overhead when the latter is used to [cmd source] code.
+[para]
+[section {Package indexing commands}]
+
+Like raw [file .tcl] files, code lines in docstrip source files can
+be searched for package declarations and corresponding indices
+constructed. A complication is however that one cannot tell from the
+code blocks themselves which will fit together to make a working
+package; normally that information would be found in an accompanying
+[file .ins] file, but parsing one of those is not an easy task.
+Therefore [package docstrip::util] introduces an alternative encoding
+of such information, in the form of a declarative Tcl script: the
+[term catalogue] (of the contents in a source file).
+[para]
+
+The special commands which are available inside a catalogue are:
+[list_begin definitions]
+[call [cmd pkgProvide] [arg name] [arg version] [arg terminals]]
+ Declares that the code for a package with name [arg name] and
+ version [arg version] is made up from those modules in the source
+ file which are selected by the [arg terminals] list of guard
+ expression terminals. This code should preferably not contain a
+ [cmd {package}] [method {provide}] command for the package, as one
+ will be provided by the package loading mechanisms.
+[call [cmd pkgIndex] [opt "[arg terminal] ..."]]
+ Declares that the code for a package is made up from those modules
+ in the source file which are selected by the listed guard
+ expression [arg terminal]s. The name and version of this package is
+ determined from [cmd {package}] [method {provide}] command(s) found
+ in that code (hence there must be such a command in there).
+[call [cmd fileoptions] [opt "[arg option] [arg value] ..."]]
+ Declares the [cmd fconfigure] options that should be in force when
+ reading the source; this can usually be ignored for pure ASCII
+ files, but if the file needs to be interpreted according to some
+ other [option -encoding] then this is how to specify it. The
+ command should normally appear first in the catalogue, as it takes
+ effect only for commands following it.
+[list_end]
+Other Tcl commands are supported too [vset emdash] a catalogue is
+parsed by being evaluated in a safe interpreter [vset emdash] but they
+are rarely needed. To allow for future extensions, unknown commands
+in the catalogue are silently ignored.
+[para]
+
+To simplify distribution of catalogues together with their source
+files, the catalogue is stored [emph {in the source file itself}] as
+a module selected by the terminal '[const docstrip.tcl::catalogue]'.
+This supports both the style of collecting all catalogue lines in one
+place and the style of putting each catalogue line in close proximity
+of the code that it declares.
+[para]
+
+Putting catalogue entries next to the code they declare may look as
+follows
+[example {
+% First there's the catalogue entry
+% \begin{tcl}
+%<docstrip.tcl::catalogue>pkgProvide foo::bar 1.0 {foobar load}
+% \end{tcl}
+% second a metacomment used to include a copyright message
+% \begin{macrocode}
+%<*foobar>
+%% This file is placed in the public domain.
+% \end{macrocode}
+% third the package implementation
+% \begin{tcl}
+namespace eval foo::bar {
+ # ... some clever piece of Tcl code elided ...
+% \end{tcl}
+% which at some point may have variant code to make use of a
+% |load|able extension
+% \begin{tcl}
+%<*load>
+ load [file rootname [info script]][info sharedlibextension]
+%</load>
+%<*!load>
+ # ... even more clever scripted counterpart of the extension
+ # also elided ...
+%</!load>
+}
+%</foobar>
+% \end{tcl}
+% and that's it!
+}]
+The corresponding set-up with [cmd pkgIndex] would be
+[example {
+% First there's the catalogue entry
+% \begin{tcl}
+%<docstrip.tcl::catalogue>pkgIndex foobar load
+% \end{tcl}
+% second a metacomment used to include a copyright message
+% \begin{tcl}
+%<*foobar>
+%% This file is placed in the public domain.
+% \end{tcl}
+% third the package implementation
+% \begin{tcl}
+package provide foo::bar 1.0
+namespace eval foo::bar {
+ # ... some clever piece of Tcl code elided ...
+% \end{tcl}
+% which at some point may have variant code to make use of a
+% |load|able extension
+% \begin{tcl}
+%<*load>
+ load [file rootname [info script]][info sharedlibextension]
+%</load>
+%<*!load>
+ # ... even more clever scripted counterpart of the extension
+ # also elided ...
+%</!load>
+}
+%</foobar>
+% \end{tcl}
+% and that's it!
+}]
+[list_begin definitions]
+[call [cmd docstrip::util::index_from_catalogue] [arg dir]\
+ [arg pattern] [opt "[arg option] [arg value] ..."]]
+ This command is a sibling of the standard [cmd pkg_mkIndex]
+ command, in that it adds package entries to [file pkgIndex.tcl]
+ files. The difference is that it indexes [syscmd docstrip]-style
+ source files rather than raw [file .tcl] or loadable library files.
+ Only packages listed in the catalogue of a file are considered.
+ [para]
+
+ The [arg dir] argument is the directory in which to look for files
+ (and whose [file pkgIndex.tcl] file should be amended).
+ The [arg pattern] argument is a [cmd glob] pattern of files to look
+ into; a typical value would be [const *.dtx] or
+ [const *.{dtx,ddt}]. Remaining arguments are option-value pairs,
+ where the supported options are:
+ [list_begin options]
+ [opt_def -recursein [arg dirpattern]]
+ If this option is given, then the [cmd index_from_catalogue]
+ operation will be repeated in each subdirectory whose name
+ matches the [arg dirpattern]. [option -recursein] [const *] will
+ cause the entire subtree rooted at [arg dir] to be indexed.
+ [opt_def -sourceconf [arg dictionary]]
+ Specify [cmd fileoptions] to use when reading the catalogues of
+ files (and also for reading the packages if the catalogue does
+ not contain a [cmd fileoptions] command). Defaults to being
+ empty. Primarily useful if your system encoding is very different
+ from that of the source file (e.g., one is a two-byte encoding
+ and the other is a one-byte encoding). [const ascii] and
+ [const utf-8] are not very different in that sense.
+ [opt_def -options [arg terminals]]
+ The [arg terminals] is a list of terminals in addition to
+ [const docstrip.tcl::catalogue] that should be held as true when
+ extracting the catalogue. Defaults to being empty. This makes it
+ possible to make use of "variant sections" in the catalogue
+ itself, e.g. gaurd some entries with an extra "experimental" and
+ thus prevent them from appearing in the index unless that is
+ generated with "experimental" among the [option -options].
+ [opt_def -report [arg boolean]]
+ If the [arg boolean] is true then the return value will be a
+ textual, probably multiline, report on what was done. Defaults
+ to false, in which case there is no particular return value.
+ [opt_def -reportcmd [arg commandPrefix]]
+ Every item in the report is handed as an extra argument to the
+ command prefix. Since [cmd index_from_catalogue] would typically
+ be used at a rather high level in installation scripts and the
+ like, the [arg commandPrefix] defaults to
+ "[cmd puts] [const stdout]".
+ Use [cmd list] to effectively disable this feature. The return
+ values from the prefix are ignored.
+ [list_end]
+
+ The [cmd {package ifneeded}] scripts that are generated contain
+ one [cmd {package require docstrip}] command and one
+ [cmd docstrip::sourcefrom] command. If the catalogue entry was
+ of the [cmd pkgProvide] kind then the [cmd {package ifneeded}]
+ script also contains the [cmd {package provide}] command.
+ [para]
+
+ Note that [cmd index_from_catalogue] never removes anything from an
+ existing [file pkgIndex.tcl] file. Hence you may need to delete it
+ (or have [cmd pkg_mkIndex] recreate it from scratch) before running
+ [cmd index_from_catalogue] to update some piece of information, such
+ as a package version number.
+ [para]
+[call [cmd docstrip::util::modules_from_catalogue] [arg target]\
+ [arg source] [opt "[arg option] [arg value] ..."]]
+ This command is an alternative to [cmd index_from_catalogue] which
+ creates Tcl Module ([file .tm]) files rather than
+ [file pkgIndex.tcl] entries. Since this action is more similar to
+ what [syscmd docstrip] classically does, it has features for
+ putting pre- and postambles on the generated files.
+ [para]
+
+ The [arg source] argument is the name of the source file to
+ generate [file .tm] files from. The [arg target] argument is the
+ directory which should count as a module path, i.e., this is what
+ the relative paths derived from package names are joined to. The
+ supported options are:
+ [list_begin options]
+ [opt_def -preamble [arg message]]
+ A message to put in the preamble (initial block of comments) of
+ generated files. Defaults to a space. May be several lines, which
+ are then separated by newlines. Traditionally used for copyright
+ notices or the like, but metacomment lines provide an alternative
+ to that.
+ [opt_def -postamble [arg message]]
+ Like [option -preamble], but the message is put at the end of the
+ file instead of the beginning. Defaults to being empty.
+ [opt_def -sourceconf [arg dictionary]]
+ Specify [cmd fileoptions] to use when reading the catalogue of
+ the [arg source] (and also for reading the packages if the
+ catalogue does not contain a [cmd fileoptions] command). Defaults
+ to being empty. Primarily useful if your system encoding is very
+ different from that of the source file (e.g., one is a two-byte
+ encoding and the other is a one-byte encoding). [const ascii] and
+ [const utf-8] are not very different in that sense.
+ [opt_def -options [arg terminals]]
+ The [arg terminals] is a list of terminals in addition to
+ [const docstrip.tcl::catalogue] that should be held as true when
+ extracting the catalogue. Defaults to being empty. This makes it
+ possible to make use of "variant sections" in the catalogue
+ itself, e.g. gaurd some entries with an extra "experimental" guard
+ and thus prevent them from contributing packages unless those are
+ generated with "experimental" among the [option -options].
+ [opt_def -formatpreamble [arg commandPrefix]]
+ Command prefix used to actually format the preamble. Takes four
+ additional arguments [arg message], [arg targetFilename],
+ [arg sourceFilename], and [arg terminalList] and returns a fully
+ formatted preamble. Defaults to using [cmd classical_preamble]
+ with a [arg metaprefix] of '##'.
+ [opt_def -formatpostamble [arg commandPrefix]]
+ Command prefix used to actually format the postamble. Takes four
+ additional arguments [arg message], [arg targetFilename],
+ [arg sourceFilename], and [arg terminalList] and returns a fully
+ formatted postamble. Defaults to using [cmd classical_postamble]
+ with a [arg metaprefix] of '##'.
+ [opt_def -report [arg boolean]]
+ If the [arg boolean] is true (which is the default) then the return
+ value will be a textual, probably multiline, report on what was
+ done. If it is false then there is no particular return value.
+ [opt_def -reportcmd [arg commandPrefix]]
+ Every item in the report is handed as an extra argument to this
+ command prefix. Defaults to [cmd list], which effectively disables
+ this feature. The return values from the prefix are ignored. Use
+ for example "[cmd puts] [const stdout]" to get report items
+ written immediately to the terminal.
+ [list_end]
+ An existing file of the same name as one to be created will be
+ overwritten.
+[call [cmd docstrip::util::classical_preamble] [arg metaprefix]\
+ [arg message] [arg target] [opt "[arg source] [arg terminals] ..."]]
+ This command returns a preamble in the classical
+ [syscmd docstrip] style
+[example {
+##
+## This is `TARGET',
+## generated by the docstrip::util package.
+##
+## The original source files were:
+##
+## SOURCE (with options: `foo,bar')
+##
+## Some message line 1
+## line2
+## line3
+}]
+ if called as
+[example_begin]
+docstrip::util::classical_preamble {##}\
+ "\nSome message line 1\nline2\nline3" TARGET SOURCE {foo bar}
+[example_end]
+ The command supports preambles for files generated from multiple
+ sources, even though [cmd modules_from_catalogue] at present does
+ not need that.
+[call [cmd docstrip::util::classical_postamble] [arg metaprefix]\
+ [arg message] [arg target] [opt "[arg source] [arg terminals] ..."]]
+ This command returns a postamble in the classical
+ [syscmd docstrip] style
+[example {
+## Some message line 1
+## line2
+## line3
+##
+## End of file `TARGET'.
+}]
+ if called as
+[example_begin]
+docstrip::util::classical_postamble {##}\
+ "Some message line 1\nline2\nline3" TARGET SOURCE {foo bar}
+[example_end]
+ In other words, the [arg source] and [arg terminals] arguments are
+ ignored, but supported for symmetry with [cmd classical_preamble].
+[call [cmd docstrip::util::packages_provided] [arg text]\
+ [opt [arg setup-script]]]
+ This command returns a list where every even index element is the
+ name of a package [cmd provide]d by [arg text] when that is
+ evaluated as a Tcl script, and the following odd index element is
+ the corresponding version. It is used to do package indexing of
+ extracted pieces of code, in the manner of [cmd pkg_mkIndex].
+ [para]
+
+ One difference to [cmd pkg_mkIndex] is that the [arg text] gets
+ evaluated in a safe interpreter. [cmd {package require}] commands
+ are silently ignored, as are unknown commands (which includes
+ [cmd source] and [cmd load]). Other errors cause
+ processing of the [arg text] to stop, in which case only those
+ package declarations that had been encountered before the error
+ will be included in the return value.
+ [para]
+
+ The [arg setup-script] argument can be used to customise the
+ evaluation environment, if the code in [arg text] has some very
+ special needs. The [arg setup-script] is evaluated in the local
+ context of the [cmd packages_provided] procedure just before the
+ [arg text] is processed. At that time, the name of the slave
+ command for the safe interpreter that will do this processing is
+ kept in the local variable [var c]. To for example copy the
+ contents of the [var ::env] array to the safe interpreter, one
+ might use a [arg setup-script] of
+ [example { $c eval [list array set env [array get ::env]]}]
+[list_end]
+
+[section {Source processing commands}]
+
+Unlike the previous group of commands, which would use
+[cmd docstrip::extract] to extract some code lines and then process
+those further, the following commands operate on text consisting of
+all types of lines.
+
+[list_begin definitions]
+[call [cmd docstrip::util::ddt2man] [arg text]]
+ The [cmd ddt2man] command reformats [arg text] from the general
+ [syscmd docstrip] format to [package doctools] [file .man] format
+ (Tcl Markup Language for Manpages). The different line types are
+ treated as follows:
+ [list_begin definitions]
+ [def {comment and metacomment lines}]
+ The '%' and '%%' prefixes are removed, the rest of the text is
+ kept as it is.
+ [def {empty lines}]
+ These are kept as they are. (Effectively this means that they will
+ count as comment lines after a comment line and as code lines
+ after a code line.)
+ [def {code lines}]
+ [cmd example_begin] and [cmd example_end] commands are placed
+ at the beginning and end of every block of consecutive code
+ lines. Brackets in a code line are converted to [cmd lb] and
+ [cmd rb] commands.
+ [def {verbatim guards}]
+ These are processed as usual, so they do not show up in the
+ result but every line in a verbatim block is treated as a code
+ line.
+ [def {other guards}]
+ These are treated as code lines, except that the actual guard is
+ [cmd emph]asised.
+ [list_end]
+
+ At the time of writing, no project has employed [package doctools]
+ markup in master source files, so experience of what works well is
+ not available. A source file could however look as follows
+[example {
+% [manpage_begin gcd n 1.0]
+% [keywords divisor]
+% [keywords math]
+% [moddesc {Greatest Common Divisor}]
+% [require gcd [opt 1.0]]
+% [description]
+%
+% [list_begin definitions]
+% [call [cmd gcd] [arg a] [arg b]]
+% The [cmd gcd] procedure takes two arguments [arg a] and [arg b] which
+% must be integers and returns their greatest common divisor.
+proc gcd {a b} {
+% The first step is to take the absolute values of the arguments.
+% This relieves us of having to worry about how signs will be treated
+% by the remainder operation.
+ set a [expr {abs($a)}]
+ set b [expr {abs($b)}]
+% The next line does all of Euclid's algorithm! We can make do
+% without a temporary variable, since $a is substituted before the
+% [lb]set a $b[rb] and thus continues to hold a reference to the
+% "old" value of [var a].
+ while {$b>0} { set b [expr { $a % [set a $b] }] }
+% In Tcl 8.3 we might want to use [cmd set] instead of [cmd return]
+% to get the slight advantage of byte-compilation.
+%<tcl83> set a
+%<!tcl83> return $a
+}
+% [list_end]
+%
+% [manpage_end]
+}]
+ If the above text is fed through [cmd docstrip::util::ddt2man] then
+ the result will be a syntactically correct [package doctools]
+ manpage, even though its purpose is a bit different.
+ [para]
+
+ It is suggested that master source code files with [package doctools]
+ markup are given the suffix [file .ddt], hence the "ddt" in
+ [cmd ddt2man].
+
+[call [cmd docstrip::util::guards] [arg subcmd] [arg text]]
+ The [cmd guards] command returns information (mostly of a
+ statistical nature) about the ordinary docstrip guards that occur
+ in the [arg text]. The [arg subcmd] selects what is returned.
+
+ [list_begin definitions]
+ [def [method counts]]
+ List the guard expression terminals with counts. The format of
+ the return value is a dictionary which maps the terminal name to
+ the number of occurencies of it in the file.
+ [def [method exprcount]]
+ List the guard expressions with counts. The format of the return
+ value is a dictionary which maps the expression to the number of
+ occurencies of it in the file.
+ [def [method exprerr]]
+ List the syntactically incorrect guard expressions (e.g.
+ parentheses do not match, or a terminal is missing). The return
+ value is a list, with the elements in no particular order.
+ [def [method expressions]]
+ List the guard expressions. The return value is a list, with the
+ elements in no particular order.
+ [def [method exprmods]]
+ List the guard expressions with modifiers. The format of the return
+ value is a dictionary where each index is a guard expression and
+ each entry is a string with one character for every guard line that
+ has this expression. The characters in the entry specify what
+ modifier was used in that line: +, -, *, /, or (for guard without
+ modifier:) space. This is the most primitive form of the
+ information gathered by [cmd guards].
+ [def [method names]]
+ List the guard expression terminals. The return value is a list,
+ with the elements in no particular order.
+ [def [method rotten]]
+ List the malformed guard lines (this does not include lines where
+ only the expression is malformed, though). The format of the return
+ value is a dictionary which maps line numbers to their contents.
+ [list_end]
+[call [cmd docstrip::util::patch] [arg source-var] [arg terminals]\
+ [arg fromtext] [arg diff] [opt "[arg option] [arg value] ..."]]
+ This command tries to apply a [syscmd diff] file (for example a
+ contributed patch) that was computed for a generated file to the
+ [syscmd docstrip] source. This can be useful if someone has
+ edited a generated file, thus mistaking it for being the source.
+ This command makes no presumptions which are specific for the case
+ that the generated file is a Tcl script.
+ [para]
+
+ [cmd patch] requires that the source file to patch is kept as a
+ list of lines in a variable, and the name of that variable in the
+ calling context is what goes into the [arg source-var] argument.
+ The [arg terminals] is the list of terminals used to extract the
+ file that has been patched. The [arg diff] is the actual diff to
+ apply (in a format as explained below) and the [arg fromtext] is
+ the contents of the file which served as "from" when the diff was
+ computed. Options can be used to further control the process.
+ [para]
+
+ The process works by "lifting" the hunks in the [arg diff] from
+ generated to source file, and then applying them to the elements of
+ the [arg source-var]. In order to do this lifting, it is necessary
+ to determine how lines in the [arg fromtext] correspond to elements
+ of the [arg source-var], and that is where the [arg terminals] come
+ in; the source is first [cmd extract]ed under the given
+ [arg terminals], and the result of that is then matched against
+ the [arg fromtext]. This produces a map which translates line
+ numbers stated in the [arg diff] to element numbers in
+ [arg source-var], which is what is needed to lift the hunks.
+ [para]
+
+ The reason that both the [arg terminals] and the [arg fromtext]
+ must be given is twofold. First, it is very difficult to keep track
+ of how many lines of preamble are supplied some other way than by
+ copying lines from source files. Second, a generated file might
+ contain material from several source files. Both make it impossible
+ to predict what line number an extracted file would have in the
+ generated file, so instead the algorithm for computing the line
+ number map looks for a block of lines in the [arg fromtext] which
+ matches what can be extracted from the source. This matching is
+ affected by the following options:
+ [list_begin options]
+ [opt_def -matching [arg mode]]
+ How equal must two lines be in order to match? The supported
+ [arg mode]s are:
+ [list_begin definitions]
+ [def [const exact]]
+ Lines must be equal as strings. This is the default.
+ [def [const anyspace]]
+ All sequences of whitespace characters are converted to single
+ spaces before comparing.
+ [def [const nonspace]]
+ Only non-whitespace characters are considered when comparing.
+ [def [const none]]
+ Any two lines are considered to be equal.
+ [list_end]
+ [opt_def -metaprefix [arg string]]
+ The [option -metaprefix] value to use when extracting. Defaults
+ to "%%", but for Tcl code it is more likely that "#" or "##" had
+ been used for the generated file.
+ [opt_def -trimlines [arg boolean]]
+ The [option -trimlines] value to use when extracting. Defaults to
+ true.
+ [list_end]
+
+ The return value is in the form of a unified diff, containing only
+ those hunks which were not applied or were only partially applied;
+ a comment in the header of each hunk specifies which case is at
+ hand. It is normally necessary to manually review both the return
+ value from [cmd patch] and the patched text itself, as this command
+ cannot adjust comment lines to match new content.
+ [para]
+
+ An example use would look like
+[example_begin]
+set sourceL [lb]split [lb]docstrip::util::thefile from.dtx[rb] \n[rb]
+set terminals {foo bar baz}
+set fromtext [lb]docstrip::util::thefile from.tcl[rb]
+set difftext [lb]exec diff --unified from.tcl to.tcl[rb]
+set leftover [lb]docstrip::util::patch sourceL $terminals $fromtext\
+ [lb]docstrip::util::import_unidiff $difftext[rb] -metaprefix {#}[rb]
+set F [lb]open to.dtx w[rb]; puts $F [lb]join $sourceL \n[rb]; close $F
+return $leftover
+[example_end]
+ Here, [file from.dtx] was used as source for [file from.tcl], which
+ someone modified into [file to.tcl]. We're trying to construct a
+ [file to.dtx] which can be used as source for [file to.tcl].
+[call [cmd docstrip::util::thefile] [arg filename] [
+ opt "[arg option] [arg value] ..."
+]]
+ The [cmd thefile] command opens the file [arg filename], reads it to
+ end, closes it, and returns the contents (dropping a final newline
+ if there is one). The option-value pairs are
+ passed on to [cmd fconfigure] to configure the open file channel
+ before anything is read from it.
+[call [cmd docstrip::util::import_unidiff] [arg diff-text]\
+ [opt [arg warning-var]]]
+ This command parses a unified ([syscmd diff] flags [option -U] and
+ [option --unified]) format diff into the list-of-hunks format
+ expected by [cmd docstrip::util::patch]. The [arg diff-text]
+ argument is the text to parse and the [arg warning-var] is, if
+ specified, the name in the calling context of a variable to which
+ any warnings about parsing problems will be [cmd append]ed.
+ [para]
+
+ The return value is a list of [term hunks]. Each hunk is a list of
+ five elements "[arg start1] [arg end1] [arg start2] [arg end2]
+ [arg lines]". [arg start1] and [arg end1] are line numbers in the
+ "from" file of the first and last respectively lines of the hunk.
+ [arg start2] and [arg end2] are the corresponding line numbers in
+ the "to" file. Line numbers start at 1. The [arg lines] is a list
+ with two elements for each line in the hunk; the first specifies the
+ type of a line and the second is the actual line contents. The type
+ is [const -] for lines only in the "from" file, [const +] for lines
+ that are only in the "to" file, and [const 0] for lines that are
+ in both.
+[list_end]
+[manpage_end]
diff --git a/tcllib/modules/docstrip/docstrip_util.tcl b/tcllib/modules/docstrip/docstrip_util.tcl
new file mode 100644
index 0000000..b3a0009
--- /dev/null
+++ b/tcllib/modules/docstrip/docstrip_util.tcl
@@ -0,0 +1,649 @@
+##
+## This is the file `docstrip_util.tcl',
+## generated with the SAK utility
+## (sak docstrip/regen).
+##
+## The original source files were:
+##
+## tcldocstrip.dtx (with options: `utilpkg')
+##
+## In other words:
+## **************************************
+## * This Source is not the True Source *
+## **************************************
+## the true source is the file from which this one was generated.
+##
+package require Tcl 8.4
+package require docstrip 1.2
+package provide docstrip::util 1.3.1
+namespace eval docstrip::util {
+ namespace export ddt2man guard patch thefile\
+ packages_provided index_from_catalogue modules_from_catalogue\
+ classical_preamble classical_postamble
+}
+namespace eval docstrip::util {
+ namespace import [namespace parent]::extract
+}
+proc docstrip::util::fileoptions {args} {
+ variable filename
+ variable thefile [eval [list thefile $filename] $args]
+ variable fileoptions $args
+}
+proc docstrip::util::Report {item} {
+ variable Report_store
+ if {$Report_store} then {
+ variable Report
+ lappend Report $item
+ }
+ variable Report_cmd
+ eval [linsert $Report_cmd end $item]
+}
+proc docstrip::util::index_from_catalogue {dir pattern args} {
+ array set O {
+ -options ""
+ -sourceconf ""
+ -report 0
+ -reportcmd {puts stdout}
+ -RecursionDepth 0
+ }
+ array set O $args
+ if {$O(-RecursionDepth)==0} then {
+ variable Report {} Report_store $O(-report) \
+ Report_cmd $O(-reportcmd)
+ }
+ set targetFn [file join $dir pkgIndex.tcl]
+ Report "Entries will go to: $targetFn"
+ if {![file exists $targetFn]} then {
+ Report "Generating empty index file."
+ set F [open $targetFn w]
+ puts $F {# Tcl package index file, version 1.1}
+ puts $F {# This file is generated by the "pkg_mkIndex" command}
+ puts $F {# and sourced either when an application starts up or}
+ puts $F {# by a "package unknown" script. It invokes the}
+ puts $F {# "package ifneeded" command to set up package-related}
+ puts $F {# information so that packages will be loaded automatically}
+ puts $F {# in response to "package require" commands. When this}
+ puts $F {# script is sourced, the variable $dir must contain the}
+ puts $F {# full path name of this file's directory.}
+ close $F
+ }
+ set c [interp create -safe]
+ $c eval {
+ proc unknown args {}
+ }
+ $c alias pkgProvide [namespace which PkgProvide]
+ $c alias pkgIndex [namespace which PkgIndex]
+ $c alias fileoptions [namespace which fileoptions]
+ variable PkgIndex ""
+ foreach fn [glob -nocomplain -directory $dir -tails $pattern] {
+ Report "Processing file: $fn"
+ variable filename [file join $dir $fn]
+ variable fileoptions $O(-sourceconf)
+ variable thefile [eval [list thefile $filename] $fileoptions]
+ set catalogue [extract $thefile\
+ [linsert $O(-options) 0 docstrip.tcl::catalogue]\
+ -metaprefix {#} -onerror puts]
+ $c eval $catalogue
+ }
+ interp delete $c
+ if {$PkgIndex ne ""} then {
+ set F [open $targetFn {WRONLY APPEND}]
+ set cmd [list docstrip::util::index_from_catalogue $dir $pattern]
+ if {$O(-options) ne ""} then {
+ lappend cmd -options $O(-options)
+ }
+ if {$O(-sourceconf) ne ""} then {
+ lappend cmd -sourceconf $O(-sourceconf)
+ }
+ puts $F "\n## Appendix generated by:\n## $cmd$PkgIndex"
+ close $F
+ }
+ if {[info exists O(-recursein)]} then {
+ incr O(-RecursionDepth)
+ foreach fn [
+ glob -nocomplain -tails -types d -directory $dir\
+ $O(-recursein)
+ ] {
+ eval [list index_from_catalogue [file join $dir $fn] $pattern]\
+ [array get O]
+ }
+ }
+ if {$O(-RecursionDepth)==0 && $O(-report)} then {
+ return [join $Report \n]
+ }
+}
+proc docstrip::util::PkgProvide {pkg ver terminals} {
+ if {[catch {package vcompare 0 $ver}]} then {
+ Report "Malformed version number $ver given for package $pkg."
+ return
+ }
+ variable PkgIndex
+ variable filename
+ variable fileoptions
+ append PkgIndex \n [list package ifneeded $pkg $ver] { "}
+ append PkgIndex [string map {\\ {\\} \$ {\$} \[ {\[} \" {\"}}\
+ [list package provide $pkg $ver]] {; }
+ append PkgIndex {package require docstrip} {; }
+ append PkgIndex {[list docstrip::sourcefrom }\
+ {[file join $dir } [list [file tail $filename]] {] }\
+ [linsert $fileoptions 0 $terminals] {]"}
+}
+proc docstrip::util::PkgIndex {args} {
+ variable thefile
+ if {[catch {
+ packages_provided [extract $thefile $args -metaprefix {#}]
+ } res]} then {
+ if {[lindex $::errorCode 0] eq "DOCSTRIP"} then {
+ Report "Stripping error \"$res\"\nwhile indexing module\
+ <[join $args ,]>."
+ } else {
+ Report "Code evaluation error:\n $res\nwhile indexing\
+ module <[join $args ,]>."
+ }
+ } else {
+ variable filename
+ variable PkgIndex
+ variable fileoptions
+ foreach {pkg ver} $res {
+ append PkgIndex \n [list package ifneeded $pkg $ver] { "}
+ append PkgIndex {package require docstrip} {; }
+ append PkgIndex {[list docstrip::sourcefrom }\
+ {[file join $dir } [list [file tail $filename]] {] }\
+ [linsert $fileoptions 0 $args] {]"}
+ }
+ }
+}
+proc docstrip::util::modules_from_catalogue {target source args} {
+ array set Opt {
+ -formatpostamble {classical_postamble {##}}
+ -formatpreamble {classical_preamble {##}}
+ -options {}
+ -postamble {}
+ -preamble { }
+ -sourceconf {}
+ -report 1
+ -reportcmd list
+ }
+ array set Opt $args
+ variable filename $source
+ variable fileoptions $Opt(-sourceconf)
+ variable thefile [eval [list thefile $source] $fileoptions]
+ variable Report {} Report_store $Opt(-report) \
+ Report_cmd $Opt(-reportcmd)
+ set catalogue [extract $thefile\
+ [linsert $Opt(-options) 0 docstrip.tcl::catalogue]\
+ -metaprefix {#} -onerror puts]
+ set c [interp create -safe]
+ $c eval {
+ proc unknown args {}
+ }
+ $c alias pkgProvide\
+ [namespace which GenerateNamedPkg] $target\
+ [linsert $Opt(-formatpreamble) end $Opt(-preamble)]\
+ [linsert $Opt(-formatpostamble) end $Opt(-postamble)]
+ $c alias pkgIndex\
+ [namespace which GeneratePkg] $target\
+ [linsert $Opt(-formatpreamble) end $Opt(-preamble)]\
+ [linsert $Opt(-formatpostamble) end $Opt(-postamble)]
+ $c alias fileoptions [namespace which fileoptions]
+ $c eval $catalogue
+ interp delete $c
+ if {$Opt(-report)} then {return [join $Report \n]}
+}
+proc docstrip::util::GenerateNamedPkg\
+ {target preamblecmd postamblecmd name version terminals} {
+ variable thefile
+ if {[catch {
+ extract $thefile $terminals -metaprefix {#}
+ } text]} then {
+ Report "Stripping error \"$text\"\nwhile indexing module\
+ <[join $terminals ,]>."
+ } else {
+ variable filename
+ set module [format {%s-%s.tm}\
+ [string trim [string map {:: /} $name] /] $version]
+ set modL [file split $module]
+ file mkdir [file join $target [file dirname $module]]
+ set F [open [file join $target $module] w]
+ fconfigure $F -encoding utf-8
+ puts $F [eval $preamblecmd [list $module $filename $terminals]]
+ puts -nonewline $F $text
+ puts $F [eval $postamblecmd [list $module $filename $terminals]]
+ close $F
+ Report "Wrote $module"
+ }
+}
+proc docstrip::util::GeneratePkg {target preamblecmd postamblecmd args} {
+ variable thefile
+ if {[catch {
+ set text [extract $thefile $args -metaprefix {#}]
+ packages_provided $text
+ } res]} then {
+ if {[lindex $::errorCode 0] eq "DOCSTRIP"} then {
+ Report "Stripping error \"$res\"\nwhile indexing module\
+ <[join $args ,]>."
+ } else {
+ Report "Code evaluation error:\n $res\nwhile indexing\
+ module <[join $args ,]>."
+ }
+ } elseif {![llength $res]} then {
+ Report "Found no package in module <[join $args ,]>."
+ } else {
+ variable filename
+ set module [format {%s-%s.tm}\
+ [string trim [string map {:: /} [lindex $res 0]] /]\
+ [lindex $res 1]]
+ set modL [file split $module]
+ file mkdir [file join $target [file dirname $module]]
+ set F [open [file join $target $module] w]
+ fconfigure $F -encoding utf-8
+ puts $F [eval $preamblecmd [list $module $filename $args]]
+ puts -nonewline $F $text
+ puts $F [eval $postamblecmd [list $module $filename $args]]
+ close $F
+ Report "Wrote $module"
+ foreach {pkg ver} [lreplace $res 0 1] {
+ set mod2 [format {%s-%s.tm}\
+ [string trim [string map {:: /} $pkg] /] $ver]
+ set mod2L [file split $mod2]
+ file mkdir [file join $target [file dirname $mod2]]
+ set common 0
+ foreach d1 $modL d2 $mod2L {
+ if {$d1 eq $d2} then {incr common} else {break}
+ }
+ set tail [lrange $modL $common end]
+ set script {[::info script]}
+ foreach d2 $mod2L {
+ if {[incr common -1] < 0} then {
+ set script "\[::file dirname $script\]"
+ }
+ }
+ set F [open [file join $target $mod2] w]
+ fconfigure $F -encoding utf-8
+ puts $F "::source -encoding utf-8 \[::file join $script $tail\]"
+ close $F
+ Report "Wrote redirect $mod2"
+ }
+ }
+}
+proc docstrip::util::classical_preamble {metaprefix message target args} {
+ set res {""}
+ lappend res " This is `$target',"
+ lappend res { generated by the docstrip::util package.}
+ lappend res {} { The original source files were:} {}
+ foreach {source terminals} $args {
+ set line " [file tail $source]"
+ if {[llength $terminals]} then {
+ append line { (with options: `} [join $terminals ,] {')}
+ }
+ lappend res $line
+ }
+ foreach line [split $message \n] {lappend res " $line"}
+ return $metaprefix[join $res "\n$metaprefix"]
+}
+proc docstrip::util::classical_postamble {metaprefix message target args} {
+ set res {}
+ foreach line [split $message \n] {lappend res " $line"}
+ lappend res {} " End of file `$target'."
+ return $metaprefix[join $res "\n$metaprefix"]
+}
+proc docstrip::util::packages_provided {text {setup ""}} {
+ set c [interp create -safe]
+ $c eval {
+ proc tclPkgUnknown args {}
+ package unknown tclPkgUnknown
+ proc unknown {args} {}
+ proc auto_import {args} {}
+ }
+ $c hide package
+ $c alias package [namespace which packages_provided,package] $c
+ eval $setup
+ set package_list {}
+ catch {$c eval $text}
+ interp delete $c
+ return $package_list
+}
+proc docstrip::util::packages_provided,package {interp subcmd args} {
+ switch -- $subcmd {
+ r - re - req - requ - requi - requir - require {
+ return
+ }
+ pro - prov - provi - provid - provide {
+ if {[llength $args] == 2} then {
+ uplevel 1 [list lappend package_list] $args
+ }
+ }
+ }
+ eval [list $interp invokehidden package $subcmd] $args
+}
+proc docstrip::util::ddt2man {text} {
+ set wascode 0
+ set verbatim 0
+ set res ""
+ foreach line [split $text \n] {
+ if {$verbatim} then {
+ if {$line eq $endverbline} then {
+ set verbatim 0
+ } else {
+ append res [string map {[ [lb] ] [rb]} $line] \n
+ }
+ } else {
+ switch -glob -- $line %%* {
+ if {$wacode} then {
+ append res {[example_end]} \n
+ set wascode 0
+ }
+ append res [string range $line 2 end] \n
+ } %<<* {
+ if {!$wascode} then {
+ append res {[example_begin]} \n
+ set wascode 1
+ }
+ set endverbline "%[string range $line 3 end]"
+ set verbatim 1
+ } %<* {
+ if {!$wascode} then {
+ append res {[example_begin]} \n
+ set wascode 1
+ }
+ set guard ""
+ regexp -- {(^%<[^>]*>)(.*)$} $line "" guard line
+ append res \[ [list emph $guard] \]\
+ [string map {[ [lb] ] [rb]} $line] \n
+ } %* {
+ if {$wascode} then {
+ append res {[example_end]} \n
+ set wascode 0
+ }
+ append res [string range $line 1 end] \n
+ } {\\endinput} {
+ break
+ } "" {
+ append res \n
+ } default {
+ if {!$wascode} then {
+ append res {[example_begin]} \n
+ set wascode 1
+ }
+ append res [string map {[ [lb] ] [rb]} $line] \n
+ }
+ }
+ }
+ if {$wascode} then {append res {[example_end]} \n}
+ return $res
+}
+proc docstrip::util::guards {subcmd text} {
+ set verbatim 0
+ set lineno 1
+ set badL {}
+ foreach line [split $text \n] {
+ if {$verbatim} then {
+ if {$line eq $endverbline} then {set verbatim 0}
+ } else {
+ switch -glob -- $line %<<* {
+ set endverbline "%[string range $line 3 end]"
+ set verbatim 1
+ } %<* {
+ if {![
+ regexp -- {^%<([*/+-]?)([^>]*)>(.*)$} $line ""\
+ modifier expression line
+ ]} then {
+ lappend badL $lineno $line
+ } else {
+ if {$modifier eq ""} then {set modifier " "}
+ append E($expression) $modifier
+ }
+ }
+ }
+ incr lineno
+ }
+ if {$subcmd eq "rotten"} then {return $badL}
+ switch -- $subcmd "exprmods" {
+ return [array get E]
+ } "expressions" {
+ return [array names E]
+ } "exprerr" {
+ set res {}
+ foreach expr [array names E] {
+ regsub -all {[^()!,|&]+} $expr 0 e
+ regsub -all {,} $e {|} e
+ if {[catch {expr $e}]} then {lappend res $expr}
+ }
+ return $res
+ }
+ foreach name [array names E] {
+ set E($name) [string length $E($name)]
+ }
+ if {$subcmd eq "exprcounts"} then {return [array get E]}
+ foreach expr [array names E] {
+ foreach term [split $expr "()!,|&"] {
+ if {$term eq ""} then {continue}
+ if {![info exists T($term)]} then {set T($term) 0}
+ incr T($term) $E($expr)
+ }
+ }
+ switch -- $subcmd "counts" {
+ return [array get T]
+ } "names" {
+ return [array names T]
+ } default {
+ error "Unknown subcommand '$subcmd', must be one of:\
+ counts, exprcounts, expressions, exprmods, names, rotten"
+ }
+}
+proc docstrip::util::patch {sourcevar termL fromtext diff args} {
+ upvar 1 $sourcevar SL
+ array set O {-trimlines 1 -matching exact}
+ array set O $args
+ set cmd [list extract [join $SL \n] $termL -annotate 2]
+ foreach opt {-metaprefix -trimlines} {
+ if {[info exists O($opt)]} then {lappend cmd $opt $O($opt)}
+ }
+ set EL [split [eval $cmd] \n]
+ lset EL end \n
+ set ptr 0
+ set lineno 1
+ set FL [list {}]
+ foreach line [split $fromtext \n] {
+ lappend FL $line
+ if {$O(-trimlines)} then {set line [string trimright $line " "]}
+ if {$line eq [lindex $EL $ptr]} then {
+ set lift($lineno) [lindex $EL [incr ptr]]
+ lset lift($lineno) 0 [expr { [lindex $EL [incr ptr]] - 1 }]
+ incr ptr
+ }
+ incr lineno
+ }
+ if {![array size lift]} then {
+ return -code error "The extract did not match any part of the\
+ fromtext. Check the list of terminals and the options"
+ }
+ set RL [list]
+ set log [list]
+ foreach hunk [lsort -decreasing -integer -index 0 $diff] {
+ set replL [list]
+ set l1 [lindex $hunk 0]
+ set repl {0 -1}
+ set matches 1
+ foreach {type line} [lindex $hunk 4] {
+ switch -glob -- $type {[0-]} {
+ switch -- $O(-matching) "exact" {
+ if {[lindex $FL $l1] ne $line} then {set matches 0}
+ } "nonspace" {
+ if {[regsub -all -- {\s} $line {}] ne\
+ [regsub -all -- {\s} [lindex $FL $l1] {}]} then {
+ set matches 0
+ }
+ } "anyspace" {
+ if {[regsub -all -- {\s+} $line { }] ne\
+ [regsub -all -- {\s+} [lindex $FL $l1] { }]} then {
+ set matches 0
+ }
+ }
+ }
+ switch -- $type synch {
+ if {[llength $repl]>2 ||\
+ [lindex $repl 1]-[lindex $repl 0]>=0} then {
+ lappend replL $repl
+ }
+ set repl [list $l1 [expr {$l1-1}]]
+ } + {
+ lappend repl $line
+ } - {
+ lset repl 1 $l1
+ incr l1
+ } 0 {
+ if {[llength $repl]>2 ||\
+ [lindex $repl 1]-[lindex $repl 0]>=0} then {
+ lappend replL $repl
+ set repl {0 -1}
+ }
+ lset repl 1 $l1
+ incr l1
+ lset repl 0 $l1
+ }
+ }
+ if {[llength $repl]>2 || [lindex $repl 1]-[lindex $repl 0]>=0}\
+ then {lappend replL $repl}
+ if {$matches} then {
+ lappend hunk [lsort -decreasing -integer -index 0 $replL]
+ lappend RL $hunk
+ } else {
+ lappend hunk "(-- did not match fromtext --)"
+ lappend log $hunk
+ }
+ }
+ foreach hunk $RL {
+ set applied 0
+ set misapplied 0
+ foreach repl [lindex $hunk 5] {
+ unset -nocomplain from to
+ for {set n [lindex $repl 1]} {$n>=[lindex $repl 0]}\
+ {incr n -1} {
+ if {![info exists lift($n)]} then {
+ incr misapplied
+ continue
+ } elseif {![info exists from]} then {
+ set to [lindex $lift($n) 0]
+ set from $to
+ } elseif {[lindex $lift($n) 0] == $from-1} then {
+ set from [lindex $lift($n) 0]
+ } else {
+ set SL [lreplace $SL $from $to]
+ set to [lindex $lift($n) 0]
+ set from $to
+ }
+ incr applied
+ set n0 $n
+ }
+ if {[info exists from]} then {
+ set sprefix [lindex $lift($n0) 1]
+ set eprefix [lindex $lift($n0) 2]
+ } elseif {[info exists lift([lindex $repl 0])]} then {
+ foreach {from sprefix eprefix} $lift([lindex $repl 0])\
+ break
+ set to [expr {$from-1}]
+ } else {
+ incr misapplied [llength [lrange $repl 2 end]]
+ continue
+ }
+ set eplen [string length $eprefix]
+ set epend [expr {$eplen-1}]
+ set cmd [list lreplace $SL $from $to]
+ foreach line [lrange $repl 2 end] {
+ if {$eprefix eq [string range $line 0 $epend]} then {
+ lappend cmd "$sprefix[string range $line $eplen end]"
+ } else {
+ lappend cmd $line
+ }
+ incr applied
+ }
+ set SL [eval $cmd]
+ }
+ if {$misapplied>0} then {
+ if {$applied>0} then {
+ lset hunk 5 "(-- was partially applied --)"
+ } else {
+ lset hunk 5 "(not applied)"
+ }
+ lappend log $hunk
+ }
+ }
+ set res ""
+ foreach hunk [lsort -index 0 -integer $log] {
+ foreach {start1 end1 start2 end2 lines msg} $hunk break
+ append res [format "@@ -%d,%d +%d,%d @@ %s\n"\
+ $start1 [expr {$end1-$start1+1}]\
+ $start2 [expr {$end2-$start2+1}] $msg]
+ foreach {type line} $lines {
+ switch -- $type 0 {
+ append res " " $line \n
+ } - - + {
+ append res $type $line \n
+ }
+ }
+ }
+ return $res
+}
+proc docstrip::util::thefile {fname args} {
+ set F [open $fname r]
+ if {[llength $args]} then {
+ if {[set code [
+ catch {eval [linsert $args 0 fconfigure $F]} res
+ ]]} then {
+ close $F
+ return -code $code -errorinfo $::errorInfo -errorcode\
+ $::errorCode
+ }
+ }
+ catch {read -nonewline $F} res
+ close $F
+ return $res
+}
+proc docstrip::util::import_unidiff {text {warnvar ""}} {
+ if {$warnvar ne ""} then {upvar 1 $warnvar warning}
+ set inheader 1
+ set res [list]
+ set lines [list]
+ set end2 "not an integer"
+ foreach line [split $text \n] {
+ if {$inheader && [regexp {^(---|\+\+\+)} $line]}\
+ then {continue}
+ switch -glob -- $line { *} {
+ lappend lines 0 [string range $line 1 end]
+ } {+*} {
+ lappend lines + [string range $line 1 end]
+ } {-*} {
+ lappend lines - [string range $line 1 end]
+ } @@* {
+ if {[string is integer $end2]} then {
+ lappend res [list $start1 $end1 $start2 $end2 $lines]
+ }
+ set len2 [set len1 ,1]
+ if {[
+ regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@}\
+ $line -> start1 len1 start2 len2
+ ] && [scan "$start1 $len1,1" {%d ,%d} start1 len1]==2 &&\
+ [scan "$start2 $len2,1" {%d ,%d} start2 len2]==2
+ } then {
+ set end1 [expr {$start1+$len1-1}]
+ set end2 [expr {$start2+$len2-1}]
+ set inheader 0
+ } else {
+ set end2 "not an integer"
+ append warning "Could not parse hunk header: " $line \n
+ }
+ set lines [list]
+ } "" {
+ } default {
+ append warning "Could not parse line: " $line \n
+ }
+ }
+ if {[string is integer $end2]} then {
+ lappend res [list $start1 $end1 $start2 $end2 $lines]
+ }
+ return $res
+}
+##
+##
+## End of file `docstrip_util.tcl'. \ No newline at end of file
diff --git a/tcllib/modules/docstrip/docstrip_util.test b/tcllib/modules/docstrip/docstrip_util.test
new file mode 100644
index 0000000..5a7c1e0
--- /dev/null
+++ b/tcllib/modules/docstrip/docstrip_util.test
@@ -0,0 +1,84 @@
+##
+## This is the file `docstrip_util.test',
+## generated with the SAK utility
+## (sak docstrip/regen).
+##
+## The original source files were:
+##
+## tcldocstrip.dtx (with options: `utiltest tcllibtest')
+##
+## In other words:
+## **************************************
+## * This Source is not the True Source *
+## **************************************
+## the true source is the file from which this one was generated.
+##
+source [file join\
+ [file dirname [file dirname [file join [pwd] [info script]]]]\
+ devtools testutilities.tcl]
+testsNeedTcl 8.4
+testsNeedTcltest 2
+testing {useLocal docstrip.tcl docstrip}
+testing {useLocal docstrip_util.tcl docstrip::util}
+variable docstrip_sources_dir [localPath {}]
+tcltest::testConstraint docstripSourcesAvailable [expr {[
+ file exists [file join $docstrip_sources_dir docstrip.tcl]
+] && [
+ file exists [file join $docstrip_sources_dir tcldocstrip.dtx]
+]}]
+tcltest::test docstrip::util::thefile-1.1 {thefile without args}\
+ -setup {
+ set Fname [tcltest::makeFile [
+ join {
+ {% Just a minor test file.}
+ {puts A}
+ {%<*bar>}
+ {puts B}
+ {%<*foo>}
+ {puts [info exists baz]}
+ } \n
+ ] test.txt]
+} -body {
+ docstrip::util::thefile $Fname
+} -cleanup {
+ tcltest::removeFile $Fname
+} -result [join {
+ {% Just a minor test file.}
+ {puts A}
+ {%<*bar>}
+ {puts B}
+ {%<*foo>}
+ {puts [info exists baz]}
+} \n]
+tcltest::test docstrip::util::thefile-1.2 {thefile with wrong no. args}\
+ -setup {
+ set Fname [tcltest::makeFile [
+ join {
+ {% Just a minor test file (contents irrelevant).}
+ {puts A}
+ {%<*bar>}
+ {puts B}
+ {%<*foo>}
+ {puts [info exists baz]}
+ } \n
+ ] test.txt]
+} -body {
+ docstrip::util::thefile $Fname -translation binary -buffering
+} -cleanup {
+ tcltest::removeFile $Fname
+} -returnCodes error
+tcltest::test docstrip::util::thefile-1.3 {thefile with args} -setup {
+ set Fname [tcltest::makeFile "Dummy content to overwrite" test.xxx]
+ set F [open $Fname w]
+ fconfigure $F -translation binary
+ puts -nonewline $F [encoding convertto utf-8 \u00E5\u00E4\u00F6]
+ close $F
+} -body {
+ docstrip::util::thefile $Fname -encoding utf-8
+} -cleanup {
+ tcltest::removeFile $Fname
+} -result \u00E5\u00E4\u00F6
+testsuiteCleanup
+##
+##
+## End of file `docstrip_util.test'. \ No newline at end of file
diff --git a/tcllib/modules/docstrip/pkgIndex.tcl b/tcllib/modules/docstrip/pkgIndex.tcl
new file mode 100644
index 0000000..2835539
--- /dev/null
+++ b/tcllib/modules/docstrip/pkgIndex.tcl
@@ -0,0 +1,23 @@
+##
+## This is the file `pkgIndex.tcl',
+## generated with the SAK utility
+## (sak docstrip/regen).
+##
+## The original source files were:
+##
+## tcldocstrip.dtx (with options: `idx')
+##
+## In other words:
+## **************************************
+## * This Source is not the True Source *
+## **************************************
+## the true source is the file from which this one was generated.
+##
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded docstrip 1.2\
+ [list source [file join $dir docstrip.tcl]]
+package ifneeded docstrip::util 1.3.1\
+ [list source [file join $dir docstrip_util.tcl]]
+##
+##
+## End of file `pkgIndex.tcl'. \ No newline at end of file
diff --git a/tcllib/modules/docstrip/tcldocstrip.dtx b/tcllib/modules/docstrip/tcldocstrip.dtx
new file mode 100644
index 0000000..ceb9c4c
--- /dev/null
+++ b/tcllib/modules/docstrip/tcldocstrip.dtx
@@ -0,0 +1,4012 @@
+%
+% \iffalse
+%<*driver>
+\documentclass{tclldoc}
+\newenvironment{ttdescription}{%
+ \description
+ \def\makelabel##1{\hspace\labelsep\normalfont\ttfamily ##1}%
+}{\enddescription}
+\newcommand{\Tcllib}{\textsf{tcllib}}
+
+% The following is a hack, to get around some complications that
+% arise when one tries to use the doc package on two levels
+% simultaneously. Basically, I need to define my own macrocode
+% environment, since at one place I'm going to need it for a block
+% of code that contains the end-of-macrocode string
+% "% \end{macrocode}" (note exactly four spaces).
+\makeatletter
+\newenvironment{Macrocode}{%
+ \macro@code\frenchspacing\@vobeyspaces\xMacro@code
+}{\endmacrocode}
+% The following piece of code uses the trick of having a macro grab
+% some piece of material and thus ensure that it is tokenized under
+% the expand-time catcodes, even though a different set of catcodes
+% will be in force when that material is actually used. This saves
+% from having to introduce an extra character of \catcode 0, and
+% means only those characters which actually need it (i.e., those
+% inside the final bracket group) are tokenized with unconventional
+% catcodes.
+\@firstofone{\bgroup
+ \def\@tempa#1{\egroup\def\xMacro@code##1#1{##1\end{Macrocode}}}
+ \catcode`\[=1\catcode`\]=2%
+ \catcode`\{=12\catcode`\}=12\catcode`\%=12%
+ \catcode`\\=13\catcode`\ =13\relax
+\@tempa}[% \end{Macrocode}]
+\makeatother
+% An easier way around it would be to use a different number of
+% spaces in that particular line, since hardly anyone would notice,
+% but I want the details to be [emph correct].
+
+
+\begin{document}
+\DocInput{tcldocstrip.dtx}
+\end{document}
+%</driver>
+% \fi
+%
+% \title{The \textsf{docstrip} \Tcllogo\ package}
+% \author{Lars Hellstr\"om}
+% \date{25 August 2005}
+% \maketitle
+%
+% \begin{abstract}
+% The \textsf{docstrip} package provides a pure-\Tcllogo\
+% implementation of some of the functionality of the \LaTeX\
+% \textsc{docstrip} program. In particular, there is a command
+% using which one can |source| \Tcllogo\ code from within a
+% \texttt{.dtx} file.
+%
+% The \textsf{docstrip::util} package provides related
+% functionality, which is more of interest at installation or
+% development time than runtime. The main functionality areas are:
+% (i)~hooks into the \Tcllogo\ package mechanisms, using which one
+% can avoid depending on the \textsc{docstrip} program for
+% \Tcllogo\ scripts; (ii)~statistical introspection into source
+% files; (iii)~alternatives to \LaTeX\ as markup language;
+% (iv)~patching of source files.
+% \end{abstract}
+%
+% \changes{1.0}{2004/09/17}{Changing namespace to \texttt{docstrip} and
+% also all command names. (LH)}
+%
+% \tableofcontents
+%
+%
+% \section{Usage}
+%
+% \subsection{\textsf{docstrip} package}
+%
+% The simplest usage of the \textsf{docstrip} package is to source
+% \Tcllogo\ code from within a \texttt{.dtx} file without having to
+% generate any stripped file first. The command that does this is
+% \describestring[proc][docstrip]{sourcefrom}|docstrip::sourcefrom|,
+% which has the syntax
+% \begin{quote}
+% |docstrip::sourcefrom| \word{filename} \word{terminals}
+% \begin{regblock}[\regstar]\word{option} \word{value}\end{regblock}
+% \end{quote}
+% where \word{filename} is the source file name. The \word{terminals}
+% is the list of guard expression terminals that should be considered
+% true; the \textsc{docstrip} program calls these the ``options'' for
+% the source file. The \word{option} and \word{value} arguments are
+% passed on to |fconfigure|, to configure the file before |read|ing
+% it.
+%
+% A typical usage is
+% \begin{quote}
+% |docstrip::sourcefrom foobar.dtx {foo debug}|
+% \end{quote}
+% which corresponds to |source|ing the file \texttt{temp.tcl} that
+% would be generated by
+% \begin{quote}
+% |\generate{\file{temp.tcl}{\from{foobar.dtx}{foo,debug}}}|
+% \end{quote}
+% A more advanced usage (making use of the ability to |fconfigure| the
+% source file before reading it) is
+% \begin{quote}
+% |docstrip::sourcefrom ruslish.dtx pkg -encoding utf-8|
+% \end{quote}
+% which ensures that the file is interpreted as being
+% \texttt{utf-8} encoded.
+%
+% \iffalse
+% (Files which require an encoding specification can actually be tricky
+% to handle using the \textsc{docstrip} program, since most \TeX's will
+% by default write \TeX-style |^^|-escapes for all characters outside
+% visible ASCII, but the \textsf{docstrip} package handles such matters
+% easily.)
+% \fi
+%
+% The \textsf{docstrip} package can even be used in
+% \texttt{pkgIndex.tcl} scripts. The typical pattern is\pagebreak[2]
+%\begin{verbatim}
+% package ifneeded foo 1.0 [format {
+% package require docstrip
+% docstrip::sourcefrom [file join %s foobar.dtx] foo
+% } [list $dir]]
+% package ifneeded bar 0.2 [format {
+% package require docstrip
+% docstrip::sourcefrom [file join %s foobar.dtx] bar
+% } [list $dir]]
+%\end{verbatim}
+% where |format| is used to embed the package directory into the
+% |package ifneeded| scripts; |list| provides the right amount of
+% quoting of the directory string. Alternatively, one may use
+% |docstrip::util::index_from_catalogue| (see below) to generate such
+% scripts automatically.
+%
+% The semantics of |sourcefrom| closely follows those of |source|: The
+% code is evaluated in the local context of the caller, a |return| will
+% abort the sourcing early, and |info script| will return the
+% \word{filename} for the duration of the |sourcefrom|. A difference is
+% that |sourcefrom| does not stop at |\u001a| characters (control-Z,
+% end of file) unless told to by an explicit |-eofchar| option. Also
+% note that the entire file is ``docstripped''
+% before any of the code in it gets evaluated, so e.g. module nesting
+% errors at the end of the file cannot be hidden by an early |return|
+% in it.
+%
+% The actual ``docstripping'' is done by the
+% \describestring[proc][docstrip]{extract}|docstrip::extract| command,
+% which has the syntax
+% \begin{quote}
+% |docstrip::extract| \word{text} \word{terminals}
+% \begin{regblock}[\regstar]\word{option}
+% \word{value}\end{regblock}
+% \end{quote}
+% Unlike the \textsc{docstrip} program, which is file-oriented, this
+% command takes the \word{text} to extract code from as an argument and
+% returns the code that was extracted. The \word{terminals} is as for
+% |sourcefrom| the list of guard expression terminals that should have
+% the value true.
+%
+% The options are
+% \begin{quote}
+% |-annotate| \word{lines}\\
+% |-metaprefix| \word{string}\\
+% |-onerror| \begin{regblock}|throw|\regalt |puts|\regalt
+% |ignore|\end{regblock}\\
+% |-trimlines| \word{boolean}
+% \end{quote}
+% These control some fine details of the extraction process. See
+% Subsection~\ref{Ssec:Extract} for further information.
+%
+% The |extract| command does not as the \textsc{docstrip} program
+% wrap the extracted code up with a preamble and postamble; it just
+% handles the basic extraction, not the higher level operation of
+% complete file generation. The
+% |docstrip::util::modules_from_catalogue| command generates
+% preambles and postambles, however.
+%
+%
+% \subsection{\textsf{docstrip::util} package}
+%
+% The \textsf{docstrip::util} package is meant for collecting various
+% utility procedures that may be useful for developers who make use of
+% the \textsf{docstrip} package in some projects, either during
+% development or during installation. It is separate from
+% the main package to avoid overhead when |docstrip| is used in
+% |package ifneeded| scripts.
+%
+%
+% \subsubsection{Source file introspection}
+%
+% \describestring[proc][docstrip::util]{guards}
+% The |guards| command collects information about the docstrip guards
+% occurring in a file. It has the subcommands |names|, |counts|,
+% |expressions|, |exprcounts|, and |exprmods| which return
+% information about correct guards in various degrees of detail. The
+% |exprerr| subcommand lists syntactically incorrect guard expressions,
+% and the |rotten| subcommand lists the malformed guard lines.
+%
+% \describestring[proc][docstrip::util]{thefile}
+% The |thefile| command is a conveniency for reading the contents of
+% a file, since most other \texttt{docstrip::util} commands expect to
+% be handed the text of \texttt{.dtx} or \texttt{.ddt} files as
+% strings (or some other in-memory data structure). It takes as
+% primary argument the name of the file to read, and will like
+% |docstrip::sourcefrom| accept additional option--value pairs for
+% configuring the file channel before reading from it. A final
+% newline is dropped, so that the result can directly be |split| into
+% a list of lines.
+%
+%
+% \subsubsection{Package indexing with built-in catalogue}
+%
+% \changes{1.3}{2010/04/18}{Renamed the `directory' to `catalogue',
+% to avoid overloading this term. Should be OK since so far only
+% one project has contained a directory. (LH)}
+% The basic method of installing a \Tcllogo\ package kept in a
+% \texttt{.dtx} file is to run the corresponding \texttt{.ins} file
+% to have \textsc{docstrip} (the program) generate one or several
+% \texttt{.tcl} files, and then use the |pkg_mkIndex| to regenerate
+% the package index file. This introduces a dependency on having
+% \LaTeX\ available when installing however, so one might want to
+% have a pure-\Tcllogo\ alternative. The \textsf{docstrip::util}
+% package provides two: the |index_from_catalogue| and
+% |modules_from_catalogue| commands.
+%
+% Parsing \texttt{.ins} files using \Tcllogo\ would be difficult, so
+% the corresponding information about which docstrip modules make up
+% a package is better put somewhere else. It turns out that it can
+% easily be embedded into the \texttt{.dtx} file itself! By
+% convention, the name of this module should be
+% `|docstrip.tcl::catalogue|'---hinting both at who is expected to make
+% use of this information and what it is. The contents of this module
+% make up the \emph{catalogue} of the source file in question.
+%
+% \describestring[command]{pkgProvide}
+% The main command to use in a catalogue is
+% \begin{quote}
+% |pkgProvide| \word{name} \word{version} \word{terminal-list}
+% \end{quote}
+% which means the module in this file which is selected by the
+% terminals in \word{terminal-list} contains version \word{version}
+% of the package named \word{name}. That module should not contain a
+% |package provide| command, as one will be provided in the
+% |package ifneeded| script.
+%
+% \describestring[command]{pkgIndex}
+% An older alternative command for identifying package from within
+% a catalogue is
+% \begin{quote}
+% |pkgIndex| \word{terminal}\regstar
+% \end{quote}
+% which means there is a module in the file which should be
+% \emph{indexed} as a package; the package name and version is taken
+% from the |package provide| command(s) found. The module is as usual
+% defined by that the listed \word{terminal}s are true.
+%
+% \describestring[command]{fileoptions}
+% A configuration command is
+% \begin{quote}
+% |fileoptions| \begin{regblock}[\regstar]\word{option}
+% \word{value}\end{regblock}
+% \end{quote}
+% which sets the |fconfigure| options that will be used when reading
+% the source file. Since the whole file was read into memory just to
+% extract the catalogue, this command works by causing the file to be
+% read again using a new set of options, and it thus has effect for
+% the |pkgProvide| etc.\@ commands following it. (Even if it is
+% perfectly legal, it would be rather strange to use |fileoptions|
+% more than once in a file.)
+%
+% A catalogue for this file could be
+% \begin{tcl}
+%<*docstrip.tcl::catalogue>
+pkgIndex pkg
+pkgIndex utilpkg
+%</docstrip.tcl::catalogue>
+% \end{tcl}
+% since the two packages include |package provide| commands.
+%
+% The |pkgProvide|, |pkgIndex|, and |fileoptions| commands are only
+% available in catalogues. Unknown commands encountered in
+% catalogues are silently ignored.\footnote{
+% This allows for future extensions of the catalogue, with commands
+% that encode other kinds of entities. One application could be to
+% list the files of a virtual file system, where the contents of
+% the individual files are to be extracted from the source file.
+% Another, perhaps more likely application would be to encode
+% packages that span several source files.
+% }
+%
+% \medskip
+%
+% \describestring[proc][docstrip::util]{modules_from_catalogue}
+% The commands which look at the catalogue of a file are
+% |index_from_catalogue| and |modules_from_catalogue|. The former
+% appends |package ifneeded| commands (which make use of
+% |docstrip::sourcefrom| rather than |source|) to a traditional
+% \texttt{pkgIndex.tcl} file. The latter generates \texttt{.tm} files
+% for the packages (overwriting previous files with the target
+% names). It has the syntax
+% \begin{quote}
+% |docstrip::util::modules_from_catalogue| \word{target root}
+% \word{source file} \begin{regblock}[\regstar] \word{option}
+% \word{value} \end{regblock}
+% \end{quote}
+% where the \word{target root} is the directory used as starting
+% point for the paths builts from package names, and
+% \word{source file} is the file to process. The most common
+% \word{option}s are:
+% \begin{ttdescription}
+% \item[-preamble]
+% Message to put at the top of the generated file. Defaults to
+% a space (which ends up contributing an empty line).
+% \item[-postamble]
+% Message to put at the bottom of the generated file. Defaults to
+% being empty.
+% \item[-options]
+% \textsf{Docstrip} expressions terminals in addition to
+% the basic \texttt{docstrip.tcl::catalogue} to use when
+% extracting the catalogue. A sort of meta-configuration
+% facility.
+% \end{ttdescription}
+% Traditionally, the |-preamble| would be used for a copyright
+% message, but such messages can alternatively be embedded as
+% ``metacomment lines''.
+%
+% \describestring[proc][docstrip::util]{index_from_catalogue}
+% The syntax of |index_from_catalogue| is
+% \begin{quote}
+% |docstrip::util::index_from_catalogue| \word{directory}
+% \word{pattern} \begin{regblock}[\regstar]\word{option}
+% \word{value}\end{regblock}
+% \end{quote}
+% where \word{directory} is the directory whose \texttt{pkgIndex.tcl}
+% file should be amended and \word{pattern} is a |glob|-pattern for
+% files whose \texttt{docstrip.tcl::catalogue}s should be read. The most
+% common \word{option}s are:
+% \begin{ttdescription}
+% \item[-recursein]
+% If nonempty, then the operation will be repeated in each
+% subdirectory matching the pattern specified as \word{value}.
+% |-recursein *| causes the entire subtree rooted at |-root| to
+% be processed.
+% \item[-options]
+% \textsf{Docstrip} expression terminals in addition to
+% the basic \texttt{docstrip.tcl:\nolinebreak[1]:catalogue} to use
+% when extracting the catalogue; a sort of metaconfiguration
+% facility.
+% \end{ttdescription}
+%
+%
+% \subsubsection{Alternative markup languages}
+%
+% The |ddt2man| command provides an alternative to \LaTeX\ markup for
+% programmers who think \LaTeX\ is too heavy (e.g.\ installation-wise)
+% and prefer a pure-\Tcllogo\ documentation setup, namely to use
+% \textsf{doctools}~\cite{doctools_fmt} man page markup. This is
+% nowhere near as powerful as \LaTeX, but may well suffice in cases
+% with less sophisticated typographical requirements.
+%
+% \describestring[proc][docstrip::util]{ddt2man}
+% Since \textsf{doctools} cannot be configured to process
+% docstrip-style master sources directly, a conversion to some format
+% that can be processed is necessary, and that is precisely what the
+% |ddt2man| command does. The syntax is
+% \begin{quote}
+% |docstrip::util::ddt2man| \word{ddt-text}
+% \end{quote}
+% where \word{ddt-text} is the contents of a master source code file
+% and the result is the same text reformatted as \textsf{doctools}
+% man page source. The command name comes from the recommended file
+% suffixes: \textsf{doctools} man pages have the suffix \texttt{.man}
+% and master source files with \textsf{doctools} markup in the comments
+% should use the suffix \texttt{.ddt} to distinguish them from
+% \texttt{.dtx} files which have \LaTeX\ markup in the comments.
+%
+% A typical usage might be
+%\begin{verbatim}
+%package require docstrip::util
+%package require doctools
+%doctools::new man2html -format html
+%set ddt [docstrip::util::thefile somefile.ddt]
+%set man [docstrip::util::ddt2man $ddt]
+%set html [man2html format $man]
+%\end{verbatim}
+% after which the |html| variable contains ordinary HTML code.
+%
+%
+% \subsubsection{Patching sources}
+%
+% \describestring[proc][docstrip::util]{patch}
+% The |patch| command is a still slightly experimental utility for
+% applying patches against extracted files to the master sources
+% proper; it works by translating extracted file line numbers to
+% master source file numbers and applies differences at the translated
+% positions. Currently the text being patched is kept in memory as a
+% list of lines, but this may change if this feature is more closely
+% integrated with the \Tcllogo lib diff file utilies offered by the
+% \textsf{rcs} package. |patch| also has a companion command
+% \describestring[proc][docstrip::util]{import_unidiff}
+% |import_unidiff| that translates patches to the format understood by
+% the |patch| command.
+%
+% An example of using these commands would be
+%\begin{verbatim}
+%set sourceL [split [docstrip::util::thefile somefile.dtx] \n]
+%set generated [docstrip::util::thefile foobar.tcl]
+%set diff [docstrip::util::thefile foobar.patch]
+%set conflicts [docstrip::util::patch sourceL {foo bar} $generated\
+% [docstrip::util::import_unidiff $diff]]
+%\end{verbatim}
+% after which one in principle can overwrite \texttt{somefile.dtx}
+% with the result of |join $sourceL \n|, but more often one should
+% rather send these patched contents to a text editor for further
+% review. For one thing, there may be conflicts. For another, it is
+% often necessary to also update the comment lines around modified
+% sections.
+%
+%
+% \section{Headers}
+%
+% The guiding principle for the various file headers has been to
+% collect all occurrencies of a version number in the same place.
+% This is not entirely possible, since the |manpage_begin| and
+% |require| manpage commands both contain the package version
+% numbers, but at least it is possible to collect |require|s,
+% |package require|s, and |package provide|s together.
+% \changes{1.3}{2010/04/30}{File headers interleaved, to simplify
+% changing version numbers. (LH)}
+%
+% Since this leaves |manpage_begin| of the \textsf{doctools} manpages
+% the odd man out, we'd better begin with that.
+% \begin{tcl}
+%<*man,utilman>
+%<man>[manpage_begin docstrip n 1.2]
+%<utilman>[manpage_begin docstrip_util n 1.3]
+%<man>[see_also docstrip_util]
+%<utilman>[see_also docstrip]
+%<utilman>[see_also doctools]
+%<utilman>[see_also doctools_fmt]
+%<utilman>[keywords .ddt]
+[keywords .dtx]
+%<utilman>[keywords catalogue]
+%<utilman>[keywords diff]
+[keywords docstrip]
+%<utilman>[keywords doctools]
+[keywords documentation]
+[keywords LaTeX]
+[keywords {literate programming}]
+%<utilman>[keywords module]
+%<utilman>[keywords {package indexing}]
+%<utilman>[keywords patch]
+[keywords source]
+%<utilman>[keywords {Tcl module}]
+[copyright "2003\u20132010 Lars Hellstr\u00F6m\
+ <Lars dot Hellstrom at residenset dot net>"]
+[moddesc {Literate programming tool}]
+%<man>[titledesc {Docstrip style source code extraction}]
+%<utilman>[titledesc {Docstrip-related utilities}]
+[category {Documentation tools}]
+%</man,utilman>
+% \end{tcl}
+% The other files involved in this great interleaving are the actual
+% packages (\Module{pkg} and \Module{utilpkg}) and a hardcoded index
+% file (\Module{idx}).
+% \changes{1.1}{2005/02/26}{Added \texttt{pkgIndex.tcl} source.
+% (LH, after suggestion by AK)}
+%
+% \Tcllogo~8.4 is required because |info script| with an argument
+% is used by the |sourcefrom| command, and there are also some uses
+% of the |eq| operator in |if| expressions.
+% \begin{tcl}
+%<pkg,utilpkg>package require Tcl 8.4
+%<man,utilman>[require Tcl 8.4]
+%<idx>if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+% \end{tcl}
+% That version number check is the only part of the
+% \texttt{pkgIndex.tcl} file that would not be done the same way by
+% the standard |pkg_mkIndex| command.
+%
+% Next comes the \textsf{docstrip} package version.
+% \begin{tcl}
+%<pkg>package provide docstrip 1.2
+%<idx>package ifneeded docstrip 1.2\
+%<idx> [list source [file join $dir docstrip.tcl]]
+%<man,utilman>[require docstrip [opt 1.2]]
+%<utilpkg>package require docstrip 1.2
+% \end{tcl}
+% The \textsf{docstrip::util} package has a dependency on the
+% \textsf{docstrip} package, but not the other way around. Hence the
+% next block is slightly shorter.
+% \begin{tcl}
+%<utilpkg>package provide docstrip::util 1.3.1
+%<idx>package ifneeded docstrip::util 1.3.1\
+%<idx> [list source [file join $dir docstrip_util.tcl]]
+%<utilman>[require docstrip::util [opt 1.3]]
+% \end{tcl}
+% This ends the interleaved parts of the headers.
+%
+% The following is a trick to use non-ASCII characters in manpages
+% without having to put them as such in the source: when an emdash
+% (U+2014) is needed, just write |[vset emdash]|.
+% \begin{tcl}
+%<*man,utilman>
+%<-ASCII>[vset emdash \u2014]
+%<+ASCII>[vset emdash --]
+[description]
+%</man,utilman>
+% \end{tcl}
+% The \Module{ASCII} guard here makes it possible to fall back to
+% simpler encodings, on platforms which require it, but the default
+% is the proper emdash.
+%
+% The public commands in both packages are exported. This is
+% meaningful mostly for the \textsf{docstrip::util} package, which
+% imports |extract| from \textsf{docstrip}. The corresponding
+% |namespace import| will however occur further down, to ensure that
+% a combined file extracted with |pkg,utilpkg| works too.
+% \changes{1.2}{2005/06/20}{Added namespace export code. (LH)}
+% \begin{tcl}
+%<*pkg>
+namespace eval docstrip {
+ namespace export extract sourcefrom
+}
+%</pkg>
+%<*utilpkg>
+namespace eval docstrip::util {
+ namespace export ddt2man guard patch thefile\
+ packages_provided index_from_catalogue modules_from_catalogue\
+ classical_preamble classical_postamble
+}
+%</utilpkg>
+% \end{tcl}
+%
+% \subsection{Test headers}
+%
+% What now remains to initialise are only the tests, but that is a
+% slightly complicated affair, since it means interacting with the
+% \Tcllib\ test harness. Originally the code didn't do that,
+% so there is a \Module{tcllibtest} terminal which can be used to
+% select whether to try it or not.
+%
+% The original route was to use the \textsf{tcltest} package provided
+% by the \Tcllogo\ package mechanism, but explicitly |source| the
+% \texttt{docstrip.tcl} file in the same directory as the
+% \texttt{docstrip.test} being run. That meant you could have one
+% \textsf{docstrip} version installed and run tests on another.
+% \changes{1.2}{2005/09/18}{Introduced the
+% \texttt{docstrip\_sources\_dir} variable as the directory in
+% which to search for \texttt{docstrip.tcl},
+% \texttt{docstrip\_util.tcl}, and \texttt{tcldocstrip.dtx}.
+% Using \texttt{file normalize} to compute it. (LH)}
+% \begin{tcl}
+%<*test,utiltest>
+%<*!tcllibtest>
+package require tcltest 2
+variable docstrip_sources_dir\
+ [file dirname [file normalize [info script]]]
+source [file join $docstrip_sources_dir docstrip.tcl]
+puts "** Has Tcl docstrip package (v [package provide docstrip]) **"
+%<*utiltest>
+source [file join $docstrip_sources_dir docstrip_util.tcl]
+puts "** Has Tcl docstrip::util package\
+ (v [package provide docstrip::util]) **"
+%</utiltest>
+%</!tcllibtest>
+% \end{tcl}
+%
+% The \Tcllib\ set-up instead begins with |source|ing
+% \texttt{..\slash devtools\slash testutilities.tcl}, which
+% (in that directory structure) will be a file that causes
+% \textsf{tcltest} to be loaded. The other commands below are also
+% provided by that file.
+% \changes{1.2.1}{2006/09/13}{Modified the setup of the testsuite
+% to match the other modules and packages in \Tcllib. (AK)}
+% \begin{tcl}
+%<*tcllibtest>
+source [file join\
+ [file dirname [file dirname [file join [pwd] [info script]]]]\
+ devtools testutilities.tcl]
+testsNeedTcl 8.4
+testsNeedTcltest 2
+testing {useLocal docstrip.tcl docstrip}
+%<utiltest>testing {useLocal docstrip_util.tcl docstrip::util}
+variable docstrip_sources_dir [localPath {}]
+%</tcllibtest>
+% \end{tcl}
+% One of the tests require that \texttt{tcldocstrip.dtx} (this file) and
+% \texttt{docstrip.tcl} are both present. A \textsf{tcltest} constraint
+% is declared for this purpose.
+% \begin{tcl}
+tcltest::testConstraint docstripSourcesAvailable [expr {[
+ file exists [file join $docstrip_sources_dir docstrip.tcl]
+] && [
+ file exists [file join $docstrip_sources_dir tcldocstrip.dtx]
+]}]
+%</test,utiltest>
+% \end{tcl}
+%
+%
+% \part{The docstrip package}
+%
+% \setnamespace{docstrip}
+%
+% Here follows the source both for the actual package and its manpage,
+% the latter of which is in four sections: introduction,
+% description of the format of files to be processed by
+% \textsc{docstrip}, description of commands, and basic remarks on
+% overall document structure. Since command descriptions and
+% implementations appear in the same sections of the \texttt{.dtx}
+% file, a big batch of manpage source has to appear first.
+%
+%
+% \section{Manpage}
+%
+% The introduction is indended for \Tcllogo\ programmers who have not
+% previously encountered \textsc{docstrip}---hence it is probably a
+% bit boring for experienced \LaTeX\ programmers.
+% \begin{macrocode}
+%<*man>
+
+[syscmd Docstrip] is a tool created to support a brand of Literate
+Programming. It is most common in the (La)TeX community, where it
+is being used for pretty much everything from the LaTeX core and up,
+but there is nothing about [syscmd docstrip] which prevents using it
+for other types of software.
+[para]
+
+In short, the basic principle of literate programming is that program
+source should primarily be written and structured to suit the
+developers (and advanced users who want to peek "under the hood"), not
+to suit the whims of a compiler or corresponding source code consumer.
+This means literate sources often need some kind of "translation" to an
+illiterate form that dumb software can understand.
+The [package docstrip] Tcl package handles this translation.
+[para]
+
+Even for those who do not whole-hartedly subscribe to the philosophy
+behind literate programming, [syscmd docstrip] can bring greater
+clarity to in particular:
+[list_begin itemized]
+ [item] programs employing non-obvious mathematics
+ [item] projects where separate pieces of code, perhaps in
+ different languages, need to be closely coordinated.
+[list_end]
+The first is by providing access to much more powerful typographical
+features for source code comments than are possible in plain text.
+The second is because all the separate pieces of code can be kept
+next to each other in the same source file.
+[para]
+
+The way it works is that the programmer edits directly only one or
+several "master" source code files, from which [syscmd docstrip]
+generates the more traditional "source" files compilers or the like
+would expect. The master sources typically contain a large amount of
+documentation of the code, sometimes even in places where the code
+consumers would not allow any comments. The etymology of "docstrip"
+is that this [emph doc]umentation was [emph strip]ped away (although
+"code extraction" might be a better description, as it has always
+been a matter of copying selected pieces of the master source rather
+than deleting text from it).
+The [package docstrip] Tcl package contains a reimplementation of
+the basic extraction functionality from the [syscmd docstrip]
+program, and thus makes it possible for a Tcl interpreter to read
+and interpret the master source files directly.
+[para]
+
+Readers who are not previously familiar with [syscmd docstrip] but
+want to know more about it may consult the following sources.
+[list_begin enumerated]
+[enum]
+ [emph {The tclldoc package and class}],
+ [uri {http://ctan.org/tex-archive/macros/latex/contrib/tclldoc/}].
+[enum]
+ [emph {The DocStrip utility}],
+ [uri {http://ctan.org/tex-archive/macros/latex/base/docstrip.dtx}].
+[enum]
+ [emph {The doc and shortvrb Packages}],
+ [uri {http://ctan.org/tex-archive/macros/latex/base/doc.dtx}].
+[enum]
+ Chapter 14 of
+ [emph {The LaTeX Companion}] (second edition),
+ Addison-Wesley, 2004; ISBN 0-201-36299-6.
+[list_end]
+% \end{macrocode}
+%
+% \subsection{File format}
+%
+% In order to keep some kind of document structure in this file, it is
+% best that the manpage sections are present also in the \LaTeX\ table
+% of contents.
+%
+% \begin{macrocode}
+
+[section {File format}]
+
+The basic unit [syscmd docstrip] operates on are the [emph lines] of
+a master source file. Extraction consists of selecting some of these
+lines to be copied from input text to output text. The basic
+distinction is that between [emph {code lines}] (which are copied and
+do not begin with a percent character) and [emph {comment lines}]
+(which begin with a percent character and are not copied).
+
+[example {
+%</man>
+% \end{macrocode}
+%
+% At this point, let's do a little trick: use this example also as the
+% first test. This is just a matter of putting groups of lines in the
+% right modules.
+% \begin{tcl}
+%<*test>
+tcltest::test docstrip-1.1 {code/comment line distinction} -body {
+%</test>
+%<*test,man>
+ docstrip::extract [join {
+ {% comment}
+ {% more comment !"#$%&/(}
+ {some command}
+ { % blah $blah "Not a comment."}
+ {% abc; this is comment}
+ {# def; this is code}
+ {ghi}
+ {% jkl}
+ } \n] {}
+%<man>}]
+%<man>returns the same sequence of lines as
+%<man>[example {
+%<test>} -result [
+ join {
+ {some command}
+ { % blah $blah "Not a comment."}
+ {# def; this is code}
+ {ghi} ""
+ } \n
+%<test>]
+%</test,man>
+% \end{tcl}
+% This completes the code for the test, so let's switch back to just
+% \Module{man}.
+% \begin{macrocode}
+%<*man>
+}]
+
+It does not matter to [syscmd docstrip] what format is used for the
+documentation in the comment lines, but in order to do better than
+plain text comments, one typically uses some markup language. Most
+commonly LaTeX is used, as that is a very established standard and
+also provides the best support for mathematical formulae, but the
+[package docstrip::util] package also gives some support for
+[term doctools]-like markup.
+[para]
+
+Besides the basic code and comment lines, there are also
+[emph {guard lines}], which begin with the two characters '%<', and
+[emph {meta-comment lines}], which begin with the two characters
+'%%'. Within guard lines there is furthermore the distinction between
+[emph {verbatim guard lines}], which begin with '%<<', and ordinary
+guard lines, where the '%<' is not followed by another '<'. The last
+category is by far the most common.
+[para]
+
+Ordinary guard lines conditions extraction of the code line(s) they
+guard by the value of a boolean expression; the guarded block of
+code lines will only be included if the expression evaluates to true.
+The syntax of an ordinary guard line is one of
+[example {
+ '%' '<' STARSLASH EXPRESSION '>'
+ '%' '<' PLUSMINUS EXPRESSION '>' CODE
+}]
+where
+[example {
+ STARSLASH ::= '*' | '/'
+ PLUSMINUS ::= | '+' | '-'
+ EXPRESSION ::= SECONDARY | SECONDARY ',' EXPRESSION
+ | SECONDARY '|' EXPRESSION
+ SECONDARY ::= PRIMARY | PRIMARY '&' SECONDARY
+ PRIMARY ::= TERMINAL | '!' PRIMARY | '(' EXPRESSION ')'
+ CODE ::= { any character except end-of-line }
+}]
+Comma and vertical bar both denote 'or'. Ampersand denotes 'and'.
+Exclamation mark denotes 'not'. A TERMINAL can be any nonempty string
+of characters not containing '>', '&', '|', comma, '(', or ')',
+although the [syscmd docstrip] manual is a bit restrictive and only
+guarantees proper operation for strings of letters (although even
+the LaTeX core sources make heavy use also of digits in TERMINALs).
+The second argument of [cmd docstrip::extract] is the list of those
+TERMINALs that should count as having the value 'true'; all other
+TERMINALs count as being 'false' when guard expressions are evaluated.
+[para]
+
+In the case of a '%<*[emph EXPRESSION]>' guard, the lines guarded are
+all lines up to the next '%</[emph EXPRESSION]>' guard with the same
+[emph EXPRESSION] (compared as strings). The blocks of code delimited
+by such '*' and '/' guard lines must be properly nested.
+% \end{macrocode}
+% This looks like a good place for another example.
+% \begin{tcl}
+[example {
+%</man>
+%<*man,test>
+%<test>tcltest::test docstrip-1.2 {blocks and nesting} -body {
+ set text [join {
+ {begin}
+ {%<*foo>}
+ {1}
+ {%<*bar>}
+ {2}
+ {%</bar>}
+ {%<*!bar>}
+ {3}
+ {%</!bar>}
+ {4}
+ {%</foo>}
+ {5}
+ {%<*bar>}
+ {6}
+ {%</bar>}
+ {end}
+ } \n]
+ set res [docstrip::extract $text foo]
+ append res [docstrip::extract $text {foo bar}]
+ append res [docstrip::extract $text bar]
+%<*man>
+}]
+sets $res to the result of
+[example {
+%</man>
+%<test>} -result [
+ join {
+ {begin}
+ {1}
+ {3}
+ {4}
+ {5}
+ {end}
+ {begin}
+ {1}
+ {2}
+ {4}
+ {5}
+ {6}
+ {end}
+ {begin}
+ {5}
+ {6}
+ {end} ""
+ } \n
+%<test>]
+%</man,test>
+%<*man>
+}]
+% \end{tcl}
+% \begin{macrocode}
+
+In guard lines without a '*', '/', '+', or '-' modifier after the
+'%<', the guard applies only to the CODE following the '>' on that
+single line. A '+' modifier is equivalent to no modifier. A '-'
+modifier is like the case with no modifier, but the expression is
+implicitly negated, i.e., the CODE of a '%<-' guard line is only
+included if the expression evaluates to false.
+[para]
+
+Metacomment lines are "comment lines which should not be stripped
+away", but be extracted like code lines; these are sometimes used for
+copyright notices and similar material. The '%%' prefix is however
+not kept, but substituted by the current [option -metaprefix], which
+is customarily set to some "comment until end of line" character (or
+character sequence) of the language of the code being extracted.
+% \end{macrocode}
+% Ho hum, another example\slash test.
+% \begin{macrocode}
+[example {
+%</man>
+%<*man,test>
+%<*test>
+tcltest::test docstrip-1.3 {plusminus guards and metacomments} -body {
+%</test>
+ set text [join {
+ {begin}
+ {%<foo> foo}
+ {%<+foo>plusfoo}
+ {%<-foo>minusfoo}
+ {middle}
+ {%% some metacomment}
+ {%<*foo>}
+ {%%another metacomment}
+ {%</foo>}
+ {end}
+ } \n]
+ set res [docstrip::extract $text foo -metaprefix {# }]
+ append res [docstrip::extract $text bar -metaprefix {#}]
+%<*man>
+}]
+sets $res to the result of
+[example {
+%</man>
+%<test>} -result [
+ join {
+ {begin}
+ { foo}
+ {plusfoo}
+ {middle}
+ {# some metacomment}
+ {# another metacomment}
+ {end}
+ {begin}
+ {minusfoo}
+ {middle}
+ {# some metacomment}
+ {end} ""
+ } \n
+%<test>]
+%</man,test>
+%<*man>
+}]
+
+Verbatim guards can be used to force code line
+interpretation of a block of lines even if some of them happen to look
+like any other type of lines to docstrip. A verbatim guard has the
+form '%<<[emph END-TAG]' and the verbatim block is terminated by the
+first line that is exactly '%[emph END-TAG]'.
+[example {
+%</man>
+%<*man,test>
+%<*test>
+tcltest::test docstrip-1.4 {verbatim mode} -body {
+%</test>
+ set text [join {
+ {begin}
+ {%<*myblock>}
+ {some stupid()}
+ { #computer<program>}
+ {%<<QQQ-98765}
+ {% These three lines are copied verbatim (including percents}
+ {%% even if -metaprefix is something different than %%).}
+ {%</myblock>}
+ {%QQQ-98765}
+ { using*strange@programming<language>}
+ {%</myblock>}
+ {end}
+ } \n]
+ set res [docstrip::extract $text myblock -metaprefix {# }]
+ append res [docstrip::extract $text {}]
+%<*man>
+}]
+sets $res to the result of
+[example {
+%</man>
+%<test>} -result [
+ join {
+ {begin}
+ {some stupid()}
+ { #computer<program>}
+ {% These three lines are copied verbatim (including percents}
+ {%% even if -metaprefix is something different than %%).}
+ {%</myblock>}
+ { using*strange@programming<language>}
+ {end}
+ {begin}
+ {end} ""
+ } \n
+%<test>]
+%</man,test>
+%<*man>
+}]
+The processing of verbatim guards takes place also inside blocks of
+lines which due to some outer block guard will not be copied.
+[para]
+
+The final piece of [syscmd docstrip] syntax is that extraction
+stops at a line that is exactly "\endinput"; this is often used to
+avoid copying random whitespace at the end of a file. In the unlikely
+case that one wants such a code line, one can protect it with a
+verbatim guard.
+% \end{macrocode}
+% Thus far the general descriptions; now for the actual commands.
+% The manpage source for these are next to the actual implementations.
+% \begin{macrocode}
+
+[section Commands]
+
+The package defines two commands.
+
+[list_begin definitions]
+% \end{macrocode}
+%
+% \section{Command implementations}
+%
+% \subsection{Code extraction}
+% \label{Ssec:Extract}
+%
+% \begin{proc}{extract}
+% The |extract| procedure implements the core functionality of the
+% \textsc{docstrip} program: copying the some lines of code as
+% directed by relevant guard linnes. The main difference is that this
+% takes the input as a string and returns output as a string. Each
+% line in the return value ends with a newline.
+%
+% The syntax is
+% \begin{quote}
+% |docstrip::extract| \word{text} \word{terminal list}
+% \begin{regblock}[\regstar]\word{option}
+% \word{value}\end{regblock}
+% \end{quote}
+% where \word{text} is the string to docstrip and \word{terminal list}
+% is the list of expression terminals that should be true.
+% \changes{1.0}{2004/09/30}{Switched to option--value syntax for
+% equivalents of \textsc{docstrip} parameters. (LH)}
+% The options are
+% \begin{quote}
+% |-annotate| \word{lines}\\
+% |-metaprefix| \word{string}\\
+% |-onerror| \begin{regblock}|throw|\regalt |puts|\regalt
+% |ignore|\end{regblock}\\
+% |-trimlines| \word{boolean}
+% \end{quote}
+% \changes{1.2}{2005/06/16}{Added \texttt{-annotate} option. (LH)}
+%
+% The \describeopt[docstrip]{extract}{-metaprefix}|-metaprefix| value
+% is the string to use for the \textsc{docstrip} parameter
+% \verb|\MetaPrefix|. The default is `|%%|'.
+% The \describeopt[docstrip]{extract}{-trimlines}|-trimlines| option
+% specifies whether spaces at the end of a line should be trimmed
+% away before it is processed. For compatibility with
+% \textsc{docstrip} (which due to a quirk in the low-level input
+% routines of \TeX\ cannot help doing this), this is by default on.
+%
+% The \describeopt[docstrip]{extract}{-annotate}|-annotate| option
+% modifies the output format, so that each extracted line is followed
+% by \word{lines} lines of annotation information. These extra lines
+% have the following format
+% \begin{quote}
+% \word{type} \word{offprefix} \word{onprefix}\\
+% \meta{lineno}\\
+% \meta{current stack}
+% \end{quote}
+% If \word{lines} is |0| then none of the above lines is included. If
+% \word{lines} is |1| then only the first line is included. If
+% \word{lines} is |2| then the first two lines are included. Finally
+% if \word{lines} is |3| then all three lines are included. The
+% behaviour for other values of \word{lines} is unspecified. The
+% default value is |0|.
+%
+% A first annotation line is a list of three elements. The first
+% element is a ``line type'', the second element is the prefix string
+% that was removed from the line (an empty string if nothing was
+% removed), and the third element is the prefix that was added to the
+% line (either the |-metaprefix| value or an empty string). The line
+% type is one of: |V|~(verbatim), |M|~(metacomment), |+|~(plus or no
+% modifier guard line), |-|~(minus modifier guard line), and
+% |.|~(normal line). The second annotation line is simply the current
+% input line number. The third annotation line is the current block
+% guard stack---a list of guard expression strings.
+%
+% The \describeopt[docstrip]{extract}{-onerror}|-onerror| option
+% specifies what should happen when an error in the \word{text} being
+% processed is detected. The value |puts| causes error messages to
+% be written to |stderr|, but processing continues. |ignore| causes
+% processing to continue silently. The default |throw| causes a
+% \Tcllogo\ error to be thrown. In this last case, the |errorCode| is
+% set to a list with the format
+% \begin{quote}
+% |DOCSTRIP| \word{situation} \word{lineno}
+% \end{quote}
+% where \word{lineno} is the line number (starting at one) of the line
+% where the error was detected. The \word{situation}s are described
+% below, at the positions in the code where they are detected.
+%
+% Now, for the manpage, a quick resum\'e of the above.
+% \begin{macrocode}
+[call [cmd docstrip::extract] [arg text] [arg terminals] [
+ opt "[arg option] [arg value] ..."
+]]
+ The [cmd extract] command docstrips the [arg text] and returns the
+ extracted lines of code, as a string with each line terminated with
+ a newline. The [arg terminals] is the list of those guard
+ expression terminals which should evaluate to true.
+ The available options are:
+ [list_begin options]
+ [opt_def -annotate [arg lines]]
+ Requests the specified number of lines of annotation to follow
+ each extracted line in the result. Defaults to 0. Annotation lines
+ are mostly useful when the extracted lines are to undergo some
+ further transformation. A first annotation line is a list of three
+ elements: line type, prefix removed in extraction, and prefix
+ inserted in extraction. The line type is one of: 'V' (verbatim),
+ 'M' (metacomment), '+' (+ or no modifier guard line), '-' (-
+ modifier guard line), '.' (normal line). A second annotation line
+ is the source line number. A third annotation line is the current
+ stack of block guards. Requesting more than three lines of
+ annotation is currently not supported.
+ [opt_def -metaprefix [arg string]]
+ The string by which the '%%' prefix of a metacomment line will
+ be replaced. Defaults to '%%'. For Tcl code this would typically
+ be '#'.
+ [opt_def -onerror [arg keyword]]
+ Controls what will be done when a format error in the [arg text]
+ being processed is detected. The settings are:
+ [list_begin definitions]
+ [def [const ignore]]
+ Just ignore the error; continue as if nothing happened.
+ [def [const puts]]
+ Write an error message to [const stderr], then continue
+ processing.
+ [def [const throw]]
+ Throw an error. The [option -errorcode] is set to a list whose
+ first element is [const DOCSTRIP], second element is the
+ type of error, and third element is the line number where
+ the error is detected. This is the default.
+ [list_end]
+ [opt_def -trimlines [arg boolean]]
+ Controls whether [emph spaces] at the end of a line should be
+ trimmed away before the line is processed. Defaults to true.
+ [list_end]
+
+ It should be remarked that the [arg terminals] are often called
+ "options" in the context of the [syscmd docstrip] program, since
+ these specify which optional code fragments should be included.
+
+%</man>
+% \end{macrocode}
+% Hmm\dots\ Perhaps not so quick, after all.
+% \begin{tcl}
+%<*pkg>
+proc docstrip::extract {text terminals args} {
+ array set O {
+ -annotate 0
+ -metaprefix %%
+ -onerror throw
+ -trimlines 1
+ }
+ array set O $args
+% \end{tcl}
+% The |O| array is for options of this procedure. The |T| array is
+% for the terminals, so that the truth value of a terminal can be
+% tested using |info exists|.
+% \begin{tcl}
+ foreach t $terminals {set T($t) ""}
+% \end{tcl}
+% |stripped| is where the text that passes docstripping is collected.
+% \begin{tcl}
+ set stripped ""
+% \end{tcl}
+% |block_stack| is the list of modules inside which the current line
+% lies. |offlevel| is the number of modules that must be exited
+% before code lines should once again be included. |verbatim| is a
+% flag for whether verbatim mode is in force.
+% \begin{tcl}
+ set block_stack [list]
+ set offlevel 0
+ set verbatim 0
+% \end{tcl}
+% |lineno| is the input line number counter, for use in error
+% messages. The first line in the file has number |1|.
+% \begin{tcl}
+ set lineno 0
+% \end{tcl}
+% Here starts the main loop over lines in the \word{text}. It
+% constitutes the majority of the procedure and is split in two
+% parts. The smaller part handles lines in verbatim mode (unusual),
+% the large part handles lines in normal mode (with comment lines,
+% code lines, guard lines, and so on). |continue| is being used in
+% this loop to skip generation of annotation lines, for those branches
+% that do not contribute a line to the output in the first place.
+% \begin{tcl}
+ foreach line [split $text \n] {
+ incr lineno
+ if {$O(-trimlines)} then {
+ set line [string trimright $line " "]
+ }
+ if {$verbatim} then {
+ if {$line eq $endverbline} then {
+ set verbatim 0
+ continue
+ } elseif {$offlevel} then {
+ continue
+ }
+ append stripped $line \n
+ if {$O(-annotate)>=1} then {append stripped {V "" ""} \n}
+ } else {
+% \end{tcl}
+% Here starts the processing of lines in non-verbatim mode.
+% \begin{tcl}
+ switch -glob -- $line %%* {
+ if {!$offlevel} then {
+ append stripped $O(-metaprefix)\
+ [string range $line 2 end] \n
+ if {$O(-annotate)>=1} then {
+ append stripped [list M %% $O(-metaprefix)] \n
+ }
+ }
+ } %<<* {
+ set endverbline "%[string range $line 3 end]"
+ set verbatim 1
+ continue
+ } %<* {
+% \end{tcl}
+% This is the case of an ordinary guard line, which accounts for most
+% of the complexities in the file format. Here one can also encounter
+% a number of conditions which constitute errors in the data being
+% processed. The first of these is the
+% \describestring[error situation]{BADGUARD}|BADGUARD|
+% \word{situation}: the line looks like a guard line, but there is no
+% |>| terminating the guard expression.
+% \begin{tcl}
+ if {![
+ regexp -- {^%<([*/+-]?)([^>]*)>(.*)$} $line ""\
+ modifier expression line
+ ]} then {
+ extract,error BADGUARD\
+ "Malformed guard \"\n$line\n\""
+ "Malformed guard on line $lineno"
+ continue
+ }
+% \end{tcl}
+% At this point, an ordinary guard line has successfully been split
+% into parts. First the expression is evaluated, by converting it
+% to an |expr| expression.
+% \begin{tcl}
+ regsub -all -- {\\|\{|\}|\$|\[|\]| |;} $expression\
+ {\\&} E
+ regsub -all -- {,} $E {|} E
+ regsub -all -- {[^()|&!]+} $E {[info exists T(&)]} E
+ if {[catch {expr $E} val]} then {
+ extract,error EXPRERR\
+ "Error in expression <$expression> ignored"\
+ "docstrip: $val"
+ set val -1
+ }
+% \end{tcl}
+% If |$E| isn't a valid |expr| expression, then the original guard
+% expression must have been malformed. That is an
+% \describestring[error situation]{EXPRERR}|EXPRERR| \word{situation}.
+% \changes{1.0}{2004/09/29}{Catching errors in expressions. (LH)}
+%
+% With the expression evaluated, the processing of a guard line
+% now branches according to its type.
+% \begin{tcl}
+ switch -exact -- $modifier * {
+ lappend block_stack $expression
+ if {$offlevel || !$val} then {incr offlevel}
+ continue
+ } / {
+ if {![llength $block_stack]} then {
+% \end{tcl}
+% In this case there was no open block for this guard to end. That
+% is a \describestring[error situation]{SPURIOUS}|SPURIOUS|
+% \word{situation}.
+% \begin{tcl}
+ extract,error SPURIOUS\
+ "Spurious end block </$expression> ignored"\
+ "Spurious end block </$expression>"
+ } else {
+ if {[string compare $expression\
+ [lindex $block_stack end]]} then {
+% \end{tcl}
+% In this case the expression of the block being closed does not match
+% the expression on the block on top of the stack. That is a
+% \describestring[error situation]{MISMATCH}|MISMATCH|
+% \word{situation}. \textsc{docstrip} by default raises an error and
+% recovers by treating this situation as a typo.
+% \begin{tcl}
+ extract,error MISMATCH\
+ "Found </$expression> instead of\
+ </[lindex $block_stack end]>"
+ }
+% \end{tcl}
+% All that error processing makes it easy to lose track, but the
+% following two lines are what does the real work for an end of block
+% guard: pop a block off the stack and decrement the |offlevel|.
+% \begin{tcl}
+ if {$offlevel} then {incr offlevel -1}
+ set block_stack [lreplace $block_stack end end]
+ }
+ continue
+% \end{tcl}
+% These last cases of the |switch| handle |-|, |+|, and ``no
+% modifier'' lines.
+% \begin{tcl}
+ } - {
+ if {$offlevel || $val} then {continue}
+ append stripped $line \n
+ if {$O(-annotate)>=1} then {
+ append stripped [list - %<-${expression}> ""] \n
+ }
+ } default {
+ if {$offlevel || !$val} then {continue}
+ append stripped $line \n
+ if {$O(-annotate)>=1} then {
+ append stripped\
+ [list + %<${modifier}${expression}> ""] \n
+ }
+ }
+ } %* {continue}\
+% \end{tcl}
+% Back to the outer |switch|. With comment lines, nothing is done.
+% A line being the exact string |\endinput| terminates the stripping.
+% \begin{tcl}
+ {\\endinput} {
+ break
+ } default {
+% \end{tcl}
+% Other lines are code lines. These are included or not, depending on
+% the |offlevel|.
+% \begin{tcl}
+ if {$offlevel} then {continue}
+ append stripped $line \n
+ if {$O(-annotate)>=1} then {append stripped {. "" ""} \n}
+ }
+ }
+% \end{tcl}
+% Finally there is the code for annotation lines two and above.
+% \begin{tcl}
+ if {$O(-annotate)>=2} then {append stripped $lineno \n}
+ if {$O(-annotate)>=3} then {append stripped $block_stack \n}
+ }
+ return $stripped
+}
+% \end{tcl}
+%
+% \begin{proc}{extract,error}
+% Since the |extract| procedure can detect many different
+% errors which should all go through roughtly the same handling,
+% the common parts of that have been factored out into this
+% |extract,error| procedure. It accesses the variable |lineno| and
+% array element |O(-onerror)| in the local context of its caller
+% to determine the current line number and error reporting mode.
+% Apart from that, the call syntax is
+% \begin{quote}
+% |docstrip::extract,error| \word{situation} \word{message}
+% \word{error message}\regopt
+% \end{quote}
+% where \word{situation} is what would be used to identify the
+% error in |errorCode| (if |-onerror| is |throw|), \word{message}
+% is the message that would be written to |stderr| (if |-onerror|
+% is |puts|), and \word{error message} is the error message to use
+% (if |-onerror| is |throw|). The default for \word{error message}
+% is the \word{message}. Neither \word{message} nor \word{error
+% message} should end with a period, as such punctuation may be
+% provided by |extract,error|.
+% \changes{1.1}{2005/02/27}{Procedure factored out from
+% \texttt{extract}, as suggested by AK. (LH)}
+% \begin{tcl}
+proc docstrip::extract,error {situation message {errmessage ""}} {
+ upvar 1 O(-onerror) onerror lineno lineno
+ switch -- [string tolower $onerror] "puts" {
+ puts stderr "docstrip: $message on line $lineno."
+ } "ignore" {} default {
+ if {$errmessage ne ""} then {
+ error $errmessage "" [list DOCSTRIP $situation $lineno]
+ } else {
+ error $message "" [list DOCSTRIP $situation $lineno]
+ }
+ }
+}
+%</pkg>
+% \end{tcl}
+% \end{proc}
+% \end{proc}
+%
+% The following tests annotation. It is mostly the same code as in the
+% verbatim mode test.
+% \begin{tcl}
+%<*test>
+tcltest::test docstrip-1.5 {annotation} -body {
+ set text [join {
+ {begin}
+ {%<*myblock>}
+ {some stupid()}
+ {%<foo> #computer<program>}
+ {%<<QQQ-98765}
+ {% These three lines are copied verbatim (including percents}
+ {%% even if -metaprefix is something different than %%).}
+ {%</myblock>}
+ {%QQQ-98765}
+ { using*strange@programming<language>}
+ {%</myblock>}
+ {%%end}
+ } \n]
+ docstrip::extract $text {myblock foo} -metaprefix {# } -annotate 3
+} -result [
+ join {
+ {begin} {. "" ""} 1 {}
+ {some stupid()} {. "" ""} 3 myblock
+ { #computer<program>} {+ %<foo> {}} 4 myblock
+ {% These three lines are copied verbatim (including percents}
+ {V "" ""} 6 myblock
+ {%% even if -metaprefix is something different than %%).}
+ {V "" ""} 7 myblock
+ {%</myblock>} {V "" ""} 8 myblock
+ { using*strange@programming<language>} {. "" ""} 10 myblock
+ {# end} {M %% {# }} 12 {}
+ ""
+ } \n
+]
+% \end{tcl}
+%
+% The following is a test of the |extract| procedure, which compares its
+% output to the \textsc{docstrip} program output. If need be, and \LaTeX\
+% is not available, then this could also be modified to produce a new
+% version of \texttt{docstrip.tcl} using the |extract| command of
+% an older version.
+% \begin{tcl}
+tcltest::test docstrip-2.1 {have docstrip extract itself} -constraints {
+ docstripSourcesAvailable
+} -body {
+ # First read in the ready-stripped file, but gobble the preamble and
+ # postamble, as those are a bit messy to reproduce.
+ set F [open [file join $docstrip_sources_dir docstrip.tcl] r]
+ regsub -all -- {(^|\n)#[^\n]*} [read $F] {} stripped
+ close $F
+ # Then read the master source and strip it manually.
+ set F [open [file join $docstrip_sources_dir tcldocstrip.dtx] r]
+ set source [read $F]
+ close $F
+ set stripped2 [docstrip::extract $source pkg -metaprefix ##]
+ # Finally compare the two.
+ if {[string trim $stripped \n] ne [string trim $stripped2 \n]} then {
+ error "$strippped\n ne \n$stripped2"
+ }
+}
+%</test>
+% \end{tcl}
+%
+%
+%
+% \subsection{Code sourcing}
+%
+% \begin{proc}{sourcefrom}
+% This procedure behaves as a docstripping |source| command: it reads
+% a file, docstrips its contents in memory, and evaluates the result
+% as a \Tcllogo\ script in the context of the caller. The syntax is
+% \begin{quote}
+% |docstrip::sourcefrom| \word{filename} \word{terminals}
+% \begin{regblock}[\regstar]\word{option} \word{value}\end{regblock}
+% \end{quote}
+% where \word{filename} is the file name and \word{terminals} is the
+% list of true guard expression terminals. The \word{option} and
+% \word{value} arguments are passed on to |fconfigure|, to configure
+% the file before |read|ing it.
+% \changes{1.0}{2004/10/01}{Added \texttt{info script} management.
+% (LH)}
+% \begin{tcl}
+%<*man>
+[call [cmd docstrip::sourcefrom] [arg filename] [arg terminals] [
+ opt "[arg option] [arg value] ..."
+]]
+ The [cmd sourcefrom] command is a docstripping emulation of
+ [cmd source]. It opens the file [arg filename], reads it, closes it,
+ docstrips the contents as specified by the [arg terminals], and
+ evaluates the result in the local context of the caller, during
+ which time the [cmd info] [method script] value will be the
+ [arg filename]. The options are passed on to [cmd fconfigure] to
+ configure the file before its contents are read. The
+ [option -metaprefix] is set to '#', all other [cmd extract]
+ options have their default values.
+%</man>
+%<*pkg>
+proc docstrip::sourcefrom {name terminals args} {
+ set F [open $name r]
+ if {[llength $args]} then {
+ eval [linsert $args 0 fconfigure $F]
+ }
+ set text [read $F]
+ close $F
+ set oldscr [info script]
+ info script $name
+ set code [catch {
+ uplevel 1 [extract $text $terminals -metaprefix #]
+ } res]
+ info script $oldscr
+ if {$code == 1} then {
+ error $res $::errorInfo $::errorCode
+ } else {
+ return $res
+ }
+}
+%</pkg>
+% \end{tcl}
+% \end{proc}
+%
+% Testing the above procedure requires an external file. The business
+% with |info script| is to check that this is getting set and reset
+% correctly. The business with the |baz| variable tests that the file
+% contents are being evaluated in the context calling |sourcefrom|.
+% \changes{1.2}{2005/10/02}{Moddified test to make it work when
+% tmpdir is not the current directory. (LH)}
+% \begin{tcl}
+%<*test>
+tcltest::test docstrip-2.2 {soucefrom} -setup {
+ set dtxname [tcltest::makeFile [join {
+ {% Just a minor test file.}
+ {puts A}
+ {%<*bar>}
+ {puts B}
+ {%<*foo>}
+ {puts [info exists baz]}
+ {set baz 1}
+ {%</foo>}
+ {%<-foo>return}
+ {%</bar>}
+ {puts $baz}
+ {puts [file tail [info script]]}
+ {%<*!foo>}
+ {puts C}
+ "%% Tricky comment; guess what comes next\\"
+ {%</!foo>}
+ {incr baz}
+% \end{tcl}
+% What the above construction does depends on the truth value of |foo|.
+% When true, the \Module{!foo} block is skipped in its entirety, and
+% thus the next command after |puts [file tail [info script]]| is
+% |incr baz|. However when |foo| is false the block will be included.
+% The metacomment line gets a prefix |#| and will therefore become
+% a comment when the code is evaluated. The backslash escapes the
+% subsequent newline, and thus the |incr baz| will only be part of
+% a \Tcllogo\ comment.
+% \begin{tcl}
+ {puts "baz=$baz"}
+ } \n] te27st01.dtx]
+} -body {
+ set baz 0
+ puts [info script]
+ docstrip::sourcefrom $dtxname {foo bar}
+ puts [info script]
+ docstrip::sourcefrom $dtxname {}
+ docstrip::sourcefrom $dtxname {bar}
+ puts $baz
+} -cleanup {
+ tcltest::removeFile $dtxname
+} -output [join [list\
+ [info script]\
+ {A} {B} {1} {1} {te27st01.dtx} {baz=2}\
+ [info script]\
+ {A} {2} {te27st01.dtx} {C} {baz=2}\
+ {A} {B}\
+ {2} ""
+] \n]
+%</test>
+% \end{tcl}
+%
+%
+%
+% \section{Manpage section on document structure}
+%
+% This completes the package code, but there are more things which
+% should be said on the manpage.
+%
+%
+% \begin{macrocode}
+%<*man>
+[list_end]
+
+
+[section {Document structure}]
+
+The file format (as described above) determines whether a master
+source code file can be processed correctly by [syscmd docstrip],
+but the usefulness of the format is to no little part also dependent
+on that the code and comment lines together constitute a well-formed
+document.
+[para]
+
+For a document format that does not require any non-Tcl software, see
+the [cmd ddt2man] command in the [package docstrip::util] package. It
+is suggested that files employing that document format are given the
+suffix [file .ddt], to distinguish them from the more traditional
+LaTeX-based [file .dtx] files.
+[para]
+
+Master source files with [file .dtx] extension are usually set up so
+that they can be typeset directly by [syscmd latex] without any
+support from other files. This is achieved by beginning the file
+with the lines
+[example_begin]
+ % \iffalse
+ %<*driver>
+ \documentclass{tclldoc}
+ \begin{document}
+ \DocInput{[emph filename.dtx]}
+ \end{document}
+ %</driver>
+ % \fi
+[example_end]
+or some variation thereof. The trick is that the file gets read twice.
+With normal LaTeX reading rules, the first two lines are comments and
+therefore ignored. The third line is the document preamble, the fourth
+line begins the document body, and the sixth line ends the document,
+so LaTeX stops there [vset emdash] non-comments below that point in
+the file are never subjected to the normal LaTeX reading rules. Before
+that, however, the \DocInput command on the fifth line is processed,
+and that does two things: it changes the interpretation of '%' from
+"comment" to "ignored", and it inputs the file specified in the
+argument (which is normally the name of the file the command is in).
+It is this second time that the file is being read that the comments
+and code in it are typeset.
+[para]
+
+The function of the \iffalse ... \fi is to skip lines two to seven
+on this second time through; this is similar to the "if 0 { ... }"
+idiom for block comments in Tcl code, and it is needed here because
+(amongst other things) the \documentclass command may only be
+executed once. The function of the <driver> guards is to prevent this
+short piece of LaTeX code from being extracted by [syscmd docstrip].
+The total effect is that the file can function both as a LaTeX
+document and as a [syscmd docstrip] master source code file.
+[para]
+
+It is not necessary to use the tclldoc document class, but that does
+provide a number of features that are convenient for [file .dtx]
+files containing Tcl code. More information on this matter can be
+found in the references above.
+
+%</man>
+% \end{macrocode}
+%
+%
+% \part{The docstrip utilities package}
+%
+% The |extract| command is used by several \textsf{docstrip::util}
+% commands, so it is imported.
+% \begin{tcl}
+%<*utilpkg>
+namespace eval docstrip::util {
+ namespace import [namespace parent]::extract
+}
+%</utilpkg>
+% \end{tcl}
+% \setnamespace{docstrip::util}
+%
+% \begin{macrocode}
+%<*utilman>
+The [package docstrip::util] package is meant for collecting various
+utility procedures that are mainly useful at installation or
+development time. It is separate from the base package to avoid
+overhead when the latter is used to [cmd source] code.
+[para]
+%</utilman>
+% \end{macrocode}
+%
+% \section{Package indexing and generation}
+%
+% Manually writing \texttt{pkgIndex.tcl} files for
+% \textsf{docstrip}-encoded packages gets boring after a while
+% (especially since they will have to be updated after every version
+% increment), so one would like to automate this task. The following
+% implements a mechanism for this that parallels the standard
+% |pkg_mkIndex| command.
+%
+%
+% \subsection{The catalogue}
+%
+% The main difference between a \textsf{docstrip} file and an
+% ordinary \texttt{.tcl} file is that it is not clear to the casual
+% reader what modules in a file should be combined to make a directly
+% sourceable file. This information can however be encoded as a
+% separate module into the source file itself.
+%
+% The special module holding catalogue information will be
+% \begin{quote}
+% \Module{docstrip.tcl::catalogue}
+% \end{quote}
+% The \texttt{docstrip.tcl} prefix here is intended as a clear
+% indication of who is meant to read this information. The contents
+% of this module will be \Tcllogo\ code that causes some embedded
+% file to be stripped, sourced, and indexed.
+% The catalogue code will be evaluated in a separate safe interpreter,
+% so that a somewhat controlled set of commands can be made available.
+%
+% \begin{variable}{thefile}
+% \begin{variable}{filename}
+% The variables |thefile| and |filename| are used by
+% \textsf{docstrip} catalogue commands as sources of information
+% about the current file. |thefile| is the actual file contents,
+% whereas |filename| is the name of the file (including a path, if
+% one is needed).
+% \end{variable}\end{variable}
+%
+% \begin{variable}{fileoptions}
+% This variable holds the list of |fconfigure|-options for
+% configuring a file before reading it. This information must be
+% remembered, because it needs to be recorded in generated
+% |package ifneeded| scripts.
+% \end{variable}
+%
+% \begin{proc}{fileoptions}
+% This command may be used in \textsf{docstrip} directories to
+% change the set of options for files. The call syntax is
+% \begin{quote}
+% |fileoptions| \begin{regblock}[\regstar]\word{option}
+% \word{value}\end{regblock}
+% \end{quote}
+% and the current set of options is set to precisely those
+% specified (old options are forgotten). There is no particular
+% return value, but the |thefile| variable contents are updated to
+% reflect the new |fileoptions|.
+%
+% \begin{tcl}
+%<*utilpkg>
+proc docstrip::util::fileoptions {args} {
+ variable filename
+ variable thefile [eval [list thefile $filename] $args]
+ variable fileoptions $args
+}
+%</utilpkg>
+% \end{tcl}
+% \end{proc}
+%
+% \begin{macrocode}
+%<*utilman>
+[section {Package indexing commands}]
+
+Like raw [file .tcl] files, code lines in docstrip source files can
+be searched for package declarations and corresponding indices
+constructed. A complication is however that one cannot tell from the
+code blocks themselves which will fit together to make a working
+package; normally that information would be found in an accompanying
+[file .ins] file, but parsing one of those is not an easy task.
+Therefore [package docstrip::util] introduces an alternative encoding
+of such information, in the form of a declarative Tcl script: the
+[term catalogue] (of the contents in a source file).
+[para]
+
+The special commands which are available inside a catalogue are:
+[list_begin definitions]
+[call [cmd pkgProvide] [arg name] [arg version] [arg terminals]]
+ Declares that the code for a package with name [arg name] and
+ version [arg version] is made up from those modules in the source
+ file which are selected by the [arg terminals] list of guard
+ expression terminals. This code should preferably not contain a
+ [cmd {package}] [method {provide}] command for the package, as one
+ will be provided by the package loading mechanisms.
+[call [cmd pkgIndex] [opt "[arg terminal] ..."]]
+ Declares that the code for a package is made up from those modules
+ in the source file which are selected by the listed guard
+ expression [arg terminal]s. The name and version of this package is
+ determined from [cmd {package}] [method {provide}] command(s) found
+ in that code (hence there must be such a command in there).
+[call [cmd fileoptions] [opt "[arg option] [arg value] ..."]]
+ Declares the [cmd fconfigure] options that should be in force when
+ reading the source; this can usually be ignored for pure ASCII
+ files, but if the file needs to be interpreted according to some
+ other [option -encoding] then this is how to specify it. The
+ command should normally appear first in the catalogue, as it takes
+ effect only for commands following it.
+[list_end]
+Other Tcl commands are supported too [vset emdash] a catalogue is
+parsed by being evaluated in a safe interpreter [vset emdash] but they
+are rarely needed. To allow for future extensions, unknown commands
+in the catalogue are silently ignored.
+[para]
+
+To simplify distribution of catalogues together with their source
+files, the catalogue is stored [emph {in the source file itself}] as
+a module selected by the terminal '[const docstrip.tcl::catalogue]'.
+This supports both the style of collecting all catalogue lines in one
+place and the style of putting each catalogue line in close proximity
+of the code that it declares.
+[para]
+
+% \end{macrocode}
+% \DontCheckModules
+% \begin{Macrocode}
+Putting catalogue entries next to the code they declare may look as
+follows
+[example {
+%<<verbatim
+% First there's the catalogue entry
+% \begin{tcl}
+%<docstrip.tcl::catalogue>pkgProvide foo::bar 1.0 {foobar load}
+% \end{tcl}
+% second a metacomment used to include a copyright message
+% \begin{macrocode}
+%<*foobar>
+%% This file is placed in the public domain.
+% \end{macrocode}
+% third the package implementation
+% \begin{tcl}
+namespace eval foo::bar {
+ # ... some clever piece of Tcl code elided ...
+% \end{tcl}
+% which at some point may have variant code to make use of a
+% |load|able extension
+% \begin{tcl}
+%<*load>
+ load [file rootname [info script]][info sharedlibextension]
+%</load>
+%<*!load>
+ # ... even more clever scripted counterpart of the extension
+ # also elided ...
+%</!load>
+}
+%</foobar>
+% \end{tcl}
+% and that's it!
+%verbatim
+}]
+The corresponding set-up with [cmd pkgIndex] would be
+[example {
+%<<verbatim
+% First there's the catalogue entry
+% \begin{tcl}
+%<docstrip.tcl::catalogue>pkgIndex foobar load
+% \end{tcl}
+% second a metacomment used to include a copyright message
+% \begin{tcl}
+%<*foobar>
+%% This file is placed in the public domain.
+% \end{tcl}
+% third the package implementation
+% \begin{tcl}
+package provide foo::bar 1.0
+namespace eval foo::bar {
+ # ... some clever piece of Tcl code elided ...
+% \end{tcl}
+% which at some point may have variant code to make use of a
+% |load|able extension
+% \begin{tcl}
+%<*load>
+ load [file rootname [info script]][info sharedlibextension]
+%</load>
+%<*!load>
+ # ... even more clever scripted counterpart of the extension
+ # also elided ...
+%</!load>
+}
+%</foobar>
+% \end{tcl}
+% and that's it!
+%verbatim
+% \end{Macrocode}
+% \CheckModules
+% \begin{macrocode}
+}]
+%</utilman>
+% \end{macrocode}
+%
+% \begin{variable}{Report}
+% Since commands in the catalogue will often be implemented as
+% doing something, there is a need for giving them a way of
+% reporting back what they did, as the basic ``report in return
+% value'' idiom doesn't work for scripts. Hence there is a variable
+% |Report| where information can be gathered. The value of this
+% list is a list to which new items can be appended, although in
+% the end they will typically be |join|ed with a newline as
+% separator (thus blurring the distinction between a multiline item
+% and multiple one-line items).
+% \end{variable}
+%
+% \begin{proc}{Report}
+% Normally, items are contributed to the report using the call
+% \begin{quote}
+% |Report| \word{item}
+% \end{quote}
+% where the \word{item} is some human-readable string.
+% \begin{variable}{Report_store}
+% \begin{variable}{Report_cmd}
+% A complication is that one sometimes wants reports to be
+% returned by the top level command, but other times one wants
+% them to be written to the controlling terminal immediately
+% (e.g. to give feedback of progress). The |Report| mechanism
+% aims to support both by having the action of the |Report|
+% command controlled by one boolean variables |Report_store| and
+% one command prefix |Report_cmd|. If the former is true, then
+% the \word{item} is appended to the |Report| list. Moreover
+% the latter is evaluated with the \word{item} as an extra
+% argument. To have the latter ``do nothing'', use |list|.
+% \end{variable}\end{variable}
+% \begin{tcl}
+%<*utilpkg>
+proc docstrip::util::Report {item} {
+ variable Report_store
+ if {$Report_store} then {
+ variable Report
+ lappend Report $item
+ }
+ variable Report_cmd
+ eval [linsert $Report_cmd end $item]
+}
+%</utilpkg>
+% \end{tcl}
+% \end{proc}
+%
+%
+% \subsection{Index entry generation}
+%
+% \begin{proc}{index_from_catalogue}
+% The |index_from_catalogue| command generates package index data
+% by reading catalogue modules in master source files and appends
+% these entries to the relevant \texttt{pkgIndex.tcl} file. The
+% call syntax is
+% \changes{1.3}{2010/04/20}{Promoted the directory to being
+% a mandatory argument, for symmetry with
+% \texttt{pkg\PrintChar{95}mkIndex}. (LH)}
+% \begin{quote}
+% |docstrip::util::index_from_catalogue| \word{directory}
+% \word{pattern} \begin{regblock}[\regstar]\word{option}
+% \word{value}\end{regblock}
+% \end{quote}
+% where \word{directory} is the directory whose
+% \texttt{pkgIndex.tcl} should be updated and \word{pattern} is a
+% |glob|-pattern for files to read catalogues in. Currently the
+% following \word{option}s are implemented:
+% \begin{ttdescription}
+% \item[-recursein]
+% If nonempty, then the operation will be repeated in each
+% subdirectory matching the pattern specified as \word{value}.
+% |-recursein *| causes the entire subtree rooted at the
+% \word{directory} to be processed.
+% \item[-options]
+% \textsf{Docstrip} expressions terminals in addition to
+% the basic \texttt{docstrip.tcl::catalogue} to use when
+% extracting the catalogue; a sort of meta-configuration
+% facility.
+% \item[-sourceconf]
+% |fconfigure| options applied to the source file, before
+% reading. |fileoptions| commands in the catalogue will
+% override this setting (completely replacing the set of
+% options); this will primarily control what is used when
+% extracting the catalogue. Defaults to empty.
+% \item[-report]
+% Takes a boolean value. If true, the report will be the return
+% value of |index_from_catalogue|. Defaults to false, in which
+% case there is no particular return value.
+% \item[-reportcmd]
+% Takes a command prefix as value, which will be called as
+% \begin{quote}
+% \meta{prefix} \word{item}
+% \end{quote}
+% for every \word{item} being reported. Defaults to
+% |puts stdout|; use |list| to effectively disable this feature.
+% The return value from the prefix is ignored.
+% \item[-RecursionDepth]
+% An internal option used when making a recursive call to
+% signal the distance to the top invokation. A positive value
+% means ``don't bother about initialising the |Report| system.''
+% \end{ttdescription}
+%
+% \begin{macrocode}
+%<*utilman>
+[list_begin definitions]
+[call [cmd docstrip::util::index_from_catalogue] [arg dir]\
+ [arg pattern] [opt "[arg option] [arg value] ..."]]
+ This command is a sibling of the standard [cmd pkg_mkIndex]
+ command, in that it adds package entries to [file pkgIndex.tcl]
+ files. The difference is that it indexes [syscmd docstrip]-style
+ source files rather than raw [file .tcl] or loadable library files.
+ Only packages listed in the catalogue of a file are considered.
+ [para]
+
+ The [arg dir] argument is the directory in which to look for files
+ (and whose [file pkgIndex.tcl] file should be amended).
+ The [arg pattern] argument is a [cmd glob] pattern of files to look
+ into; a typical value would be [const *.dtx] or
+ [const *.{dtx,ddt}]. Remaining arguments are option-value pairs,
+ where the supported options are:
+ [list_begin options]
+ [opt_def -recursein [arg dirpattern]]
+ If this option is given, then the [cmd index_from_catalogue]
+ operation will be repeated in each subdirectory whose name
+ matches the [arg dirpattern]. [option -recursein] [const *] will
+ cause the entire subtree rooted at [arg dir] to be indexed.
+ [opt_def -sourceconf [arg dictionary]]
+ Specify [cmd fileoptions] to use when reading the catalogues of
+ files (and also for reading the packages if the catalogue does
+ not contain a [cmd fileoptions] command). Defaults to being
+ empty. Primarily useful if your system encoding is very different
+ from that of the source file (e.g., one is a two-byte encoding
+ and the other is a one-byte encoding). [const ascii] and
+ [const utf-8] are not very different in that sense.
+ [opt_def -options [arg terminals]]
+ The [arg terminals] is a list of terminals in addition to
+ [const docstrip.tcl::catalogue] that should be held as true when
+ extracting the catalogue. Defaults to being empty. This makes it
+ possible to make use of "variant sections" in the catalogue
+ itself, e.g. gaurd some entries with an extra "experimental" and
+ thus prevent them from appearing in the index unless that is
+ generated with "experimental" among the [option -options].
+ [opt_def -report [arg boolean]]
+ If the [arg boolean] is true then the return value will be a
+ textual, probably multiline, report on what was done. Defaults
+ to false, in which case there is no particular return value.
+ [opt_def -reportcmd [arg commandPrefix]]
+ Every item in the report is handed as an extra argument to the
+ command prefix. Since [cmd index_from_catalogue] would typically
+ be used at a rather high level in installation scripts and the
+ like, the [arg commandPrefix] defaults to
+ "[cmd puts] [const stdout]".
+ Use [cmd list] to effectively disable this feature. The return
+ values from the prefix are ignored.
+ [list_end]
+
+ The [cmd {package ifneeded}] scripts that are generated contain
+ one [cmd {package require docstrip}] command and one
+ [cmd docstrip::sourcefrom] command. If the catalogue entry was
+ of the [cmd pkgProvide] kind then the [cmd {package ifneeded}]
+ script also contains the [cmd {package provide}] command.
+ [para]
+
+ Note that [cmd index_from_catalogue] never removes anything from an
+ existing [file pkgIndex.tcl] file. Hence you may need to delete it
+ (or have [cmd pkg_mkIndex] recreate it from scratch) before running
+ [cmd index_from_catalogue] to update some piece of information, such
+ as a package version number.
+ [para]
+%</utilman>
+% \end{macrocode}
+%
+% \begin{tcl}
+%<*utilpkg>
+proc docstrip::util::index_from_catalogue {dir pattern args} {
+ array set O {
+ -options ""
+ -sourceconf ""
+ -report 0
+ -reportcmd {puts stdout}
+ -RecursionDepth 0
+ }
+ array set O $args
+ if {$O(-RecursionDepth)==0} then {
+ variable Report {} Report_store $O(-report) \
+ Report_cmd $O(-reportcmd)
+ }
+% \end{tcl}
+% The first step is to make sure that there is a
+% \texttt{pkgIndex.tcl} file to append to.
+% \begin{tcl}
+ set targetFn [file join $dir pkgIndex.tcl]
+ Report "Entries will go to: $targetFn"
+ if {![file exists $targetFn]} then {
+ Report "Generating empty index file."
+ set F [open $targetFn w]
+ puts $F {# Tcl package index file, version 1.1}
+ puts $F {# This file is generated by the "pkg_mkIndex" command}
+ puts $F {# and sourced either when an application starts up or}
+ puts $F {# by a "package unknown" script. It invokes the}
+ puts $F {# "package ifneeded" command to set up package-related}
+ puts $F {# information so that packages will be loaded automatically}
+ puts $F {# in response to "package require" commands. When this}
+ puts $F {# script is sourced, the variable $dir must contain the}
+ puts $F {# full path name of this file's directory.}
+ close $F
+ }
+% \end{tcl}
+% The second step is to gather the |package ifneeded| scripts for
+% the directory in question. This involves creating a temporary helper
+% interpreter for parsing the \Module{docstrip.tcl::catalogue}.
+% \begin{tcl}
+ set c [interp create -safe]
+ $c eval {
+ proc unknown args {}
+ }
+ $c alias pkgProvide [namespace which PkgProvide]
+ $c alias pkgIndex [namespace which PkgIndex]
+ $c alias fileoptions [namespace which fileoptions]
+ variable PkgIndex ""
+ foreach fn [glob -nocomplain -directory $dir -tails $pattern] {
+ Report "Processing file: $fn"
+ variable filename [file join $dir $fn]
+ variable fileoptions $O(-sourceconf)
+ variable thefile [eval [list thefile $filename] $fileoptions]
+ set catalogue [extract $thefile\
+ [linsert $O(-options) 0 docstrip.tcl::catalogue]\
+ -metaprefix {#} -onerror puts]
+ $c eval $catalogue
+ }
+ interp delete $c
+% \end{tcl}
+% The third step is easy: append the gathered material to the file.
+% A header is inserted that records the |-options| and
+% |-sourceconf| settings that were used.
+% \begin{tcl}
+ if {$PkgIndex ne ""} then {
+ set F [open $targetFn {WRONLY APPEND}]
+ set cmd [list docstrip::util::index_from_catalogue $dir $pattern]
+ if {$O(-options) ne ""} then {
+ lappend cmd -options $O(-options)
+ }
+ if {$O(-sourceconf) ne ""} then {
+ lappend cmd -sourceconf $O(-sourceconf)
+ }
+ puts $F "\n## Appendix generated by:\n## $cmd$PkgIndex"
+ close $F
+ }
+% \end{tcl}
+% Finally, the procedure may recurse into subdirectories and do the
+% same things there.
+% \begin{tcl}
+ if {[info exists O(-recursein)]} then {
+ incr O(-RecursionDepth)
+ foreach fn [
+ glob -nocomplain -tails -types d -directory $dir\
+ $O(-recursein)
+ ] {
+ eval [list index_from_catalogue [file join $dir $fn] $pattern]\
+ [array get O]
+ }
+ }
+ if {$O(-RecursionDepth)==0 && $O(-report)} then {
+ return [join $Report \n]
+ }
+}
+% \end{tcl}
+% \end{proc}
+%
+% \begin{variable}{PkgIndex}
+% The |PkgIndex| variable stores material that should be written
+% to the \texttt{pkgIndex.tcl} file. The |PkgIndex| procedure
+% appends suitable |package ifneeded| commands to it. Each command
+% must have a newline in front of it.
+% \end{variable}
+%
+% \begin{proc}{PkgProvide}
+% The |PkgProvide| procedure is an implementation of the |pkgProvide|
+% command in \textsf{docstrip} directories. It generates
+% |package ifneeded| commands and appends them to the |PkgIndex|
+% variable. The call syntax is
+% \begin{quote}
+% |pkgProvide| \word{pkg-name} \word{version} \word{terminal-list}
+% \end{quote}
+% where the \word{terminal}s are the true terminals in guard
+% expressions. There is no particular return value.
+%
+% The |package ifneeded| scripts generated have the form
+% \begin{quote}
+% |package provide |\word{pkg-name} \word{version}\\
+% |package require docstrip|\\
+% |docstrip::sourcefrom |\word{filename} \word{terminal-list}
+% \meta{fileoptions}
+% \end{quote}
+% (except that semicolons rather than newlines are used as command
+% separators). That the |package provide| command gets embedded in
+% the script like may seem unintuitive, but the same thing is done
+% in the |package ifneeded| scripts generated for \texttt{.tm}
+% files. Also note that the \word{filename} must be constructed
+% when the index file is |source|d; this mix of static and dynamic
+% data leads to a certain amount of Quoting Hell.
+%
+% First, better check that the \word{version} is valid.
+% \begin{tcl}
+proc docstrip::util::PkgProvide {pkg ver terminals} {
+ if {[catch {package vcompare 0 $ver}]} then {
+ Report "Malformed version number $ver given for package $pkg."
+ return
+ }
+ variable PkgIndex
+ variable filename
+ variable fileoptions
+% \end{tcl}
+% Since command substitution will have to happen inside the script
+% argument of |package ifneeded|, that word is quote-delimited. The
+% previous words are straightforwardly handled by |list|-quoting.
+% \begin{tcl}
+ append PkgIndex \n [list package ifneeded $pkg $ver] { "}
+% \end{tcl}
+% The |package provide| command is fixed and can thus be handled by
+% a |list|-quoting here and now, but since that |list|-quoted
+% string is then embedded into a quote-delimited word, any
+% characters in it that trigger substitutions or terminate the word
+% must be escaped. However, there will only be such characters
+% around for very bizarre choices of package name.
+% \begin{tcl}
+ append PkgIndex [string map {\\ {\\} \$ {\$} \[ {\[} \" {\"}}\
+ [list package provide $pkg $ver]] {; }
+% \end{tcl}
+% The |package require docstrip| command is at least harmless.
+% \begin{tcl}
+ append PkgIndex {package require docstrip} {; }
+% \end{tcl}
+% But for the |docstrip::sourcefrom| command, a different technique
+% is used. Here, there will be a quoting |list| command present in
+% the \texttt{pkgIndex.tcl} file, to be evaluated when that is
+% |source|d, and therefore the quote-delimited nature of the
+% enclosing word becomes irrelevant; a simple |list|-quoting of
+% data to be embedded as command arguments is again sufficient.
+% \begin{tcl}
+ append PkgIndex {[list docstrip::sourcefrom }\
+ {[file join $dir } [list [file tail $filename]] {] }\
+ [linsert $fileoptions 0 $terminals] {]"}
+}
+% \end{tcl}
+% \end{proc}
+%
+% \begin{proc}{PkgIndex}
+% The |PkgIndex| procedure is an implementation of the |pkgIndex|
+% command in \textsf{docstrip} directories. It generates
+% |package ifneeded| commands and appends them to the |PkgIndex|
+% variable. The call syntax is
+% \begin{quote}
+% |pkgIndex| \word{terminal}\regstar
+% \end{quote}
+% where the \word{terminal}s are the true terminals in guard
+% expressions. There is no particular return value.
+%
+% \begin{tcl}
+proc docstrip::util::PkgIndex {args} {
+ variable thefile
+ if {[catch {
+ packages_provided [extract $thefile $args -metaprefix {#}]
+ } res]} then {
+ if {[lindex $::errorCode 0] eq "DOCSTRIP"} then {
+ Report "Stripping error \"$res\"\nwhile indexing module\
+ <[join $args ,]>."
+ } else {
+ Report "Code evaluation error:\n $res\nwhile indexing\
+ module <[join $args ,]>."
+ }
+ } else {
+ variable filename
+ variable PkgIndex
+ variable fileoptions
+ foreach {pkg ver} $res {
+ append PkgIndex \n [list package ifneeded $pkg $ver] { "}
+ append PkgIndex {package require docstrip} {; }
+ append PkgIndex {[list docstrip::sourcefrom }\
+ {[file join $dir } [list [file tail $filename]] {] }\
+ [linsert $fileoptions 0 $args] {]"}
+ }
+ }
+}
+%</utilpkg>
+% \end{tcl}
+% \end{proc}
+%
+%
+%
+% \subsection{Module generation}
+%
+% An alternative to package indices is to create \Tcllogo\
+% Module~(\texttt{.tm}) files.
+%
+% \begin{proc}{modules_from_catalogue}
+% This procedure scans the \Module{docstrip.tcl::catalogue} of a
+% \texttt{.dtx} file and writes out \Tcllogo\ module files for the
+% packages it finds. The call syntax is
+% \begin{quote}
+% |modules_from_catalogue| \word{target root} \word{source file}
+% \begin{regblock}[\regstar] \word{option} \word{value}
+% \end{regblock}
+% \end{quote}
+% where the \word{target root} is the directory used as starting
+% point for the paths builts from package names are generated, and
+% \word{source file} is the file to process. The supported
+% \word{option}s are:
+% \begin{ttdescription}
+% \item[-formatpostamble]
+% Command prefix used to format postamble messages. The call
+% syntax is
+% \begin{quote}
+% \meta{prefix} \word{message} \word{target filename}
+% \word{source filename} \word{terminal-list}
+% \end{quote}
+% and the return value is the formatted message. Defaults to
+% |classical_postamble {##}|.
+% \item[-formatpreamble]
+% Command prefix used to format preamble messages. The call
+% syntax is
+% \begin{quote}
+% \meta{prefix} \word{message} \word{target filename}
+% \word{source filename} \word{terminal-list}
+% \end{quote}
+% and the return value is the formatted message. Defaults to
+% |classical_preamble {##}|.
+% \item[-options]
+% \textsf{Docstrip} expressions terminals in addition to
+% the basic \texttt{docstrip.tcl::catalogue} to use when
+% extracting the catalogue. A sort of meta-configuration
+% facility.
+% \item[-postamble]
+% Message to put at the top of the generated file. Defaults to
+% being empty. See also |-formatpostamble|.
+% \item[-preamble]
+% Message to put at the top of the generated file. Defaults to
+% a space (which ends up contributing an empty line). See also
+% |-formatpreamble|.
+% \item[-report]
+% Takes a boolean value. If true, the report will be the return
+% value of |modules_from_catalogue|. If false, there is no
+% particular return value. The default is true.
+% \item[-reportcmd]
+% Takes a command prefix as value, which will be called as
+% \begin{quote}
+% \meta{prefix} \word{item}
+% \end{quote}
+% for every \word{item} being reported. Defaults to |list|,
+% which effectively disables this feature.
+% The return value from the prefix is ignored.
+% \item[-sourceconf]
+% |fconfigure| options applied to the source file, before
+% reading.
+% \end{ttdescription}
+%
+% \begin{macrocode}
+%<*utilman>
+[call [cmd docstrip::util::modules_from_catalogue] [arg target]\
+ [arg source] [opt "[arg option] [arg value] ..."]]
+ This command is an alternative to [cmd index_from_catalogue] which
+ creates Tcl Module ([file .tm]) files rather than
+ [file pkgIndex.tcl] entries. Since this action is more similar to
+ what [syscmd docstrip] classically does, it has features for
+ putting pre- and postambles on the generated files.
+ [para]
+
+ The [arg source] argument is the name of the source file to
+ generate [file .tm] files from. The [arg target] argument is the
+ directory which should count as a module path, i.e., this is what
+ the relative paths derived from package names are joined to. The
+ supported options are:
+ [list_begin options]
+ [opt_def -preamble [arg message]]
+ A message to put in the preamble (initial block of comments) of
+ generated files. Defaults to a space. May be several lines, which
+ are then separated by newlines. Traditionally used for copyright
+ notices or the like, but metacomment lines provide an alternative
+ to that.
+ [opt_def -postamble [arg message]]
+ Like [option -preamble], but the message is put at the end of the
+ file instead of the beginning. Defaults to being empty.
+ [opt_def -sourceconf [arg dictionary]]
+ Specify [cmd fileoptions] to use when reading the catalogue of
+ the [arg source] (and also for reading the packages if the
+ catalogue does not contain a [cmd fileoptions] command). Defaults
+ to being empty. Primarily useful if your system encoding is very
+ different from that of the source file (e.g., one is a two-byte
+ encoding and the other is a one-byte encoding). [const ascii] and
+ [const utf-8] are not very different in that sense.
+ [opt_def -options [arg terminals]]
+ The [arg terminals] is a list of terminals in addition to
+ [const docstrip.tcl::catalogue] that should be held as true when
+ extracting the catalogue. Defaults to being empty. This makes it
+ possible to make use of "variant sections" in the catalogue
+ itself, e.g. gaurd some entries with an extra "experimental" guard
+ and thus prevent them from contributing packages unless those are
+ generated with "experimental" among the [option -options].
+ [opt_def -formatpreamble [arg commandPrefix]]
+ Command prefix used to actually format the preamble. Takes four
+ additional arguments [arg message], [arg targetFilename],
+ [arg sourceFilename], and [arg terminalList] and returns a fully
+ formatted preamble. Defaults to using [cmd classical_preamble]
+ with a [arg metaprefix] of '##'.
+ [opt_def -formatpostamble [arg commandPrefix]]
+ Command prefix used to actually format the postamble. Takes four
+ additional arguments [arg message], [arg targetFilename],
+ [arg sourceFilename], and [arg terminalList] and returns a fully
+ formatted postamble. Defaults to using [cmd classical_postamble]
+ with a [arg metaprefix] of '##'.
+ [opt_def -report [arg boolean]]
+ If the [arg boolean] is true (which is the default) then the return
+ value will be a textual, probably multiline, report on what was
+ done. If it is false then there is no particular return value.
+ [opt_def -reportcmd [arg commandPrefix]]
+ Every item in the report is handed as an extra argument to this
+ command prefix. Defaults to [cmd list], which effectively disables
+ this feature. The return values from the prefix are ignored. Use
+ for example "[cmd puts] [const stdout]" to get report items
+ written immediately to the terminal.
+ [list_end]
+ An existing file of the same name as one to be created will be
+ overwritten.
+%</utilman>
+% \end{macrocode}
+%
+% Most of the actual work is done by the |GenerateNamedPkg|
+% and\slash or |GeneratePkg| procedures.
+% \begin{tcl}
+%<*utilpkg>
+proc docstrip::util::modules_from_catalogue {target source args} {
+ array set Opt {
+ -formatpostamble {classical_postamble {##}}
+ -formatpreamble {classical_preamble {##}}
+ -options {}
+ -postamble {}
+ -preamble { }
+ -sourceconf {}
+ -report 1
+ -reportcmd list
+ }
+ array set Opt $args
+ variable filename $source
+ variable fileoptions $Opt(-sourceconf)
+ variable thefile [eval [list thefile $source] $fileoptions]
+ variable Report {} Report_store $Opt(-report) \
+ Report_cmd $Opt(-reportcmd)
+ set catalogue [extract $thefile\
+ [linsert $Opt(-options) 0 docstrip.tcl::catalogue]\
+ -metaprefix {#} -onerror puts]
+ set c [interp create -safe]
+ $c eval {
+ proc unknown args {}
+ }
+ $c alias pkgProvide\
+ [namespace which GenerateNamedPkg] $target\
+ [linsert $Opt(-formatpreamble) end $Opt(-preamble)]\
+ [linsert $Opt(-formatpostamble) end $Opt(-postamble)]
+ $c alias pkgIndex\
+ [namespace which GeneratePkg] $target\
+ [linsert $Opt(-formatpreamble) end $Opt(-preamble)]\
+ [linsert $Opt(-formatpostamble) end $Opt(-postamble)]
+ $c alias fileoptions [namespace which fileoptions]
+ $c eval $catalogue
+ interp delete $c
+ if {$Opt(-report)} then {return [join $Report \n]}
+}
+% \end{tcl}
+% \end{proc}
+%
+% \begin{proc}{GenerateNamedPkg}
+% This procedure is an implementation of the |pkgProvide| catalogue
+% command. The call syntax is
+% \begin{quote}
+% |GenerateNamedPkg| \word{target} \word{preamble-prefix}
+% \word{postamble-prefix} \word{pkg-name} \word{version}
+% \word{terminal-list}
+% \end{quote}
+% i.e., the alias should provide the first three arguments.
+% \word{target} is the same as the \word{target} argument of
+% |modules_from_catalogue|. The \word{preamble-prefix} and
+% \word{postamble-prefix} arguments are command prefixes with the
+% syntax
+% \begin{quote}
+% \meta{prefix} \word{target filename} \word{source filename}
+% \word{terminal-list}
+% \end{quote}
+% which will return the preamble and postamble texts respectively
+% for the generated module file.
+%
+% The first part is extracting and handling extraction errors.
+% \begin{tcl}
+proc docstrip::util::GenerateNamedPkg\
+ {target preamblecmd postamblecmd name version terminals} {
+ variable thefile
+ if {[catch {
+ extract $thefile $terminals -metaprefix {#}
+ } text]} then {
+ Report "Stripping error \"$text\"\nwhile indexing module\
+ <[join $terminals ,]>."
+ } else {
+% \end{tcl}
+% but after that it's all about generating the \texttt{.tm} file.
+% Mapping |::| directly to |/| is a bit coarse, but it is what
+% |::tcl::tm::UnknownHandler| does. Trimming away extra slashes
+% protects against someone picking a package name beginning with
+% |::|.
+% \begin{tcl}
+ variable filename
+ set module [format {%s-%s.tm}\
+ [string trim [string map {:: /} $name] /] $version]
+ set modL [file split $module]
+ file mkdir [file join $target [file dirname $module]]
+ set F [open [file join $target $module] w]
+ fconfigure $F -encoding utf-8
+ puts $F [eval $preamblecmd [list $module $filename $terminals]]
+ puts -nonewline $F $text
+ puts $F [eval $postamblecmd [list $module $filename $terminals]]
+ close $F
+ Report "Wrote $module"
+ }
+}
+% \end{tcl}
+% \end{proc}
+%
+%
+% \begin{proc}{GeneratePkg}
+% This procedure is an implementation of the |pkgIndex| catalogue
+% command. It is basically the same as |GenerateNamedPkg|, but it
+% must also (i)~index the extracted code to find out the package
+% name and version, and (ii)~handle the case that the code declares
+% several packages, by generating redirection files.
+% The call syntax is
+% \begin{quote}
+% |GeneratePkg| \word{target} \word{preamble-prefix}
+% \word{postamble-prefix} \word{terminal}\regstar
+% \end{quote}
+% i.e., the alias should provide the first three arguments.
+% \word{target} is the same as the \word{target} argument of
+% |modules_from_catalogue|. The \word{preamble-prefix} and
+% \word{postamble-prefix} arguments are command prefixes with the
+% syntax
+% \begin{quote}
+% \meta{prefix} \word{target filename} \word{source filename}
+% \word{terminal-list}
+% \end{quote}
+% which will return the preamble and postamble texts respectively
+% for the generated module file.
+%
+% The first part is extracting and looking for package
+% declarations, including the handling of errors during these
+% operations.
+% \begin{tcl}
+proc docstrip::util::GeneratePkg {target preamblecmd postamblecmd args} {
+ variable thefile
+ if {[catch {
+ set text [extract $thefile $args -metaprefix {#}]
+ packages_provided $text
+ } res]} then {
+ if {[lindex $::errorCode 0] eq "DOCSTRIP"} then {
+ Report "Stripping error \"$res\"\nwhile indexing module\
+ <[join $args ,]>."
+ } else {
+ Report "Code evaluation error:\n $res\nwhile indexing\
+ module <[join $args ,]>."
+ }
+% \end{tcl}
+% There's also the corner case of not fining any package
+% declaration,
+% \begin{tcl}
+ } elseif {![llength $res]} then {
+ Report "Found no package in module <[join $args ,]>."
+ } else {
+% \end{tcl}
+% but after that it's all about generating \texttt{.tm} files.
+% Mapping |::| directly to |/| is a bit coarse, but it is what
+% |::tcl::tm::UnknownHandler| does. Trimming away extra slashes
+% protects against someone picking a package name beginning with
+% |::|.
+% \begin{tcl}
+ variable filename
+ set module [format {%s-%s.tm}\
+ [string trim [string map {:: /} [lindex $res 0]] /]\
+ [lindex $res 1]]
+ set modL [file split $module]
+ file mkdir [file join $target [file dirname $module]]
+ set F [open [file join $target $module] w]
+ fconfigure $F -encoding utf-8
+ puts $F [eval $preamblecmd [list $module $filename $args]]
+ puts -nonewline $F $text
+ puts $F [eval $postamblecmd [list $module $filename $args]]
+ close $F
+ Report "Wrote $module"
+% \end{tcl}
+% Now, it might happen that a module provides more than package,
+% and what should then be done for the extra packages? A reasonable
+% solution seems to be to generate \texttt{.tm} files for all of
+% them, but make the extra files consist of a single |source|
+% command for the first file. Starting from the runtime
+% |info script| value it is possible to compute the expected location
+% of that file, but constructing the code to do it is a bit of work.
+% \begin{tcl}
+ foreach {pkg ver} [lreplace $res 0 1] {
+ set mod2 [format {%s-%s.tm}\
+ [string trim [string map {:: /} $pkg] /] $ver]
+ set mod2L [file split $mod2]
+ file mkdir [file join $target [file dirname $mod2]]
+ set common 0
+ foreach d1 $modL d2 $mod2L {
+ if {$d1 eq $d2} then {incr common} else {break}
+ }
+ set tail [lrange $modL $common end]
+ set script {[::info script]}
+ foreach d2 $mod2L {
+ if {[incr common -1] < 0} then {
+ set script "\[::file dirname $script\]"
+ }
+ }
+ set F [open [file join $target $mod2] w]
+ fconfigure $F -encoding utf-8
+ puts $F "::source -encoding utf-8 \[::file join $script $tail\]"
+ close $F
+ Report "Wrote redirect $mod2"
+ }
+ }
+}
+% \end{tcl}
+% \end{proc}
+%
+% \begin{proc}{classical_preamble}
+% This procedure generates preambles in the style of the \LaTeX\
+% \textsf{docstrip} utility. It has the call syntax
+% \begin{quote}
+% |docstrip::util::classical_preamble| \word{metaprefix}
+% \word{message} \word{target filename}
+% \begin{regblock}[\regstar] \word{source filename}
+% \word{terminal-list} \end{regblock}
+% \end{quote}
+% and returns the generated preamble.
+%
+% In comparison with \textsf{docstrip}, the \word{target filename}
+% is |\outFileName|, the pairs of \word{source filename} and
+% \word{terminal-list} are going to contribute to
+% |\ReferenceLines|, and \word{message} is what gets added at the
+% end.
+% \begin{tcl}
+proc docstrip::util::classical_preamble {metaprefix message target args} {
+ set res {""}
+ lappend res " This is `$target',"
+ lappend res { generated by the docstrip::util package.}
+ lappend res {} { The original source files were:} {}
+ foreach {source terminals} $args {
+ set line " [file tail $source]"
+ if {[llength $terminals]} then {
+ append line { (with options: `} [join $terminals ,] {')}
+ }
+ lappend res $line
+ }
+ foreach line [split $message \n] {lappend res " $line"}
+ return $metaprefix[join $res "\n$metaprefix"]
+}
+%</utilpkg>
+% \end{tcl}
+% \begin{macrocode}
+%<*utilman>
+[call [cmd docstrip::util::classical_preamble] [arg metaprefix]\
+ [arg message] [arg target] [opt "[arg source] [arg terminals] ..."]]
+ This command returns a preamble in the classical
+ [syscmd docstrip] style
+[example {
+##
+## This is `TARGET',
+## generated by the docstrip::util package.
+##
+## The original source files were:
+##
+## SOURCE (with options: `foo,bar')
+##
+## Some message line 1
+## line2
+## line3
+}]
+ if called as
+[example_begin]
+docstrip::util::classical_preamble {##}\
+ "\nSome message line 1\nline2\nline3" TARGET SOURCE {foo bar}
+[example_end]
+ The command supports preambles for files generated from multiple
+ sources, even though [cmd modules_from_catalogue] at present does
+ not need that.
+%</utilman>
+% \end{macrocode}
+% \end{proc}
+%
+% \begin{proc}{classical_postamble}
+% This procedure generates postambles in the style of the \LaTeX\
+% \textsf{docstrip} utility. It has the call syntax
+% \begin{quote}
+% |docstrip::util::classical_postamble| \word{metaprefix}
+% \word{message} \word{target filename}
+% \begin{regblock}[\regstar] \word{source filename}
+% \word{terminal-list} \end{regblock}
+% \end{quote}
+% and returns the generated postamble.
+%
+% \begin{tcl}
+%<*utilpkg>
+proc docstrip::util::classical_postamble {metaprefix message target args} {
+ set res {}
+ foreach line [split $message \n] {lappend res " $line"}
+ lappend res {} " End of file `$target'."
+ return $metaprefix[join $res "\n$metaprefix"]
+}
+%</utilpkg>
+% \end{tcl}
+% \begin{macrocode}
+%<*utilman>
+[call [cmd docstrip::util::classical_postamble] [arg metaprefix]\
+ [arg message] [arg target] [opt "[arg source] [arg terminals] ..."]]
+ This command returns a postamble in the classical
+ [syscmd docstrip] style
+[example {
+## Some message line 1
+## line2
+## line3
+##
+## End of file `TARGET'.
+}]
+ if called as
+[example_begin]
+docstrip::util::classical_postamble {##}\
+ "Some message line 1\nline2\nline3" TARGET SOURCE {foo bar}
+[example_end]
+ In other words, the [arg source] and [arg terminals] arguments are
+ ignored, but supported for symmetry with [cmd classical_preamble].
+%</utilman>
+% \end{macrocode}
+% \end{proc}
+%
+%
+% \subsection{Scanning for declarations}
+%
+% One task that must be performed is finding out which package(s) are
+% provided by a particular script (which will typically constitute
+% the contents of a module).
+%
+% \begin{macrocode}
+%<*utilman>
+[call [cmd docstrip::util::packages_provided] [arg text]\
+ [opt [arg setup-script]]]
+ This command returns a list where every even index element is the
+ name of a package [cmd provide]d by [arg text] when that is
+ evaluated as a Tcl script, and the following odd index element is
+ the corresponding version. It is used to do package indexing of
+ extracted pieces of code, in the manner of [cmd pkg_mkIndex].
+ [para]
+
+ One difference to [cmd pkg_mkIndex] is that the [arg text] gets
+ evaluated in a safe interpreter. [cmd {package require}] commands
+ are silently ignored, as are unknown commands (which includes
+ [cmd source] and [cmd load]). Other errors cause
+ processing of the [arg text] to stop, in which case only those
+ package declarations that had been encountered before the error
+ will be included in the return value.
+ [para]
+
+ The [arg setup-script] argument can be used to customise the
+ evaluation environment, if the code in [arg text] has some very
+ special needs. The [arg setup-script] is evaluated in the local
+ context of the [cmd packages_provided] procedure just before the
+ [arg text] is processed. At that time, the name of the slave
+ command for the safe interpreter that will do this processing is
+ kept in the local variable [var c]. To for example copy the
+ contents of the [var ::env] array to the safe interpreter, one
+ might use a [arg setup-script] of
+ [example { $c eval [list array set env [array get ::env]]}]
+%</utilman>
+% \end{macrocode}
+% \begin{proc}{packages_provided}
+% This procedure looks for package declarations inside a script. It
+% is derived from |pkg_mkIndex|, but simplified as it does not load
+% binary libraries or invoke autoloading. The call syntax is
+% \begin{quote}
+% |packages_provided| \word{text} \word{setup-script}\regopt
+% \end{quote}
+% where \word{text} is the text to scan. The result is a list
+% \begin{quote}
+% \begin{regblock}[\regstar]\word{package}
+% \word{version}\end{regblock}
+% \end{quote}
+% of packages that were declared.
+%
+% The \word{setup-script} is meant as a hook useful when indexing
+% packages that have some special need. This argument is a script
+% that gets evaluated (in the |packages_provided| procedure)
+% \emph{after} the test interpreter used for loading packages in
+% has been set up, but \emph{before} the text to index is evaluated
+% in it. The local |c| variable holds the name of the interpreter
+% command.
+% \changes{1.3}{2006/05/24}{Command added. (LH)}
+% \begin{tcl}
+%<*utilpkg>
+proc docstrip::util::packages_provided {text {setup ""}} {
+% \end{tcl}
+% First create the test interpreter and prepare it for use. Unlike
+% the case in standard package indexing, this interpreter is safe
+% (since safe interpreters are faster to create). Use the
+% \word{setup-script} if you need to expose some unsafe feature.
+% \changes{1.3}{2010/03/28}{Using safe interpreter for package
+% indexing. (LH)}
+% \begin{tcl}
+ set c [interp create -safe]
+ $c eval {
+ proc tclPkgUnknown args {}
+ package unknown tclPkgUnknown
+ proc unknown {args} {}
+ proc auto_import {args} {}
+ }
+ $c hide package
+ $c alias package [namespace which packages_provided,package] $c
+ eval $setup
+% \end{tcl}
+% Now evaluate the \word{text}. Errors are cheerfully ignored. Data
+% for the return value is collected in the \describestring[local
+% var.]{package_list}|package_list| local variable, which
+% |packages_provided,package| uses |uplevel| to access.
+% \begin{tcl}
+ set package_list {}
+ catch {$c eval $text}
+% \end{tcl}
+% Cleanup and return the result.
+% \begin{tcl}
+ interp delete $c
+ return $package_list
+}
+% \end{tcl}
+% \end{proc}
+%
+% \begin{proc}{packages_provided,package}
+% Calls to |package| in the test interpreter will be routed through
+% this procedure, so that |provide|s can be seen and |request|s can
+% be ignored. This is different from the mechanism in
+% |pkg_mkIndex|, but I think this approach is more correct. The
+% call syntax is
+% \begin{quote}
+% |packages_provided,package| \word{interp}
+% \word{subcommand} \word{argument}\regstar
+% \end{quote}
+% where \word{interp} is the slave interpreter command to use when
+% actually carrying out the command. Remaining arguments are as for
+% the core command |package|, which is assumed to be hidden in
+% \word{interp}.
+% \begin{tcl}
+proc docstrip::util::packages_provided,package {interp subcmd args} {
+ switch -- $subcmd {
+ r - re - req - requ - requi - requir - require {
+ return
+ }
+ pro - prov - provi - provid - provide {
+ if {[llength $args] == 2} then {
+ uplevel 1 [list lappend package_list] $args
+ }
+ }
+ }
+ eval [list $interp invokehidden package $subcmd] $args
+}
+%</utilpkg>
+% \end{tcl}
+% \end{proc}
+%
+% \begin{macrocode}
+%<*utilman>
+[list_end]
+%</utilman>
+% \end{macrocode}
+%
+%
+% \section{Operations on source file text}
+%
+% \begin{macrocode}
+%<*utilman>
+
+[section {Source processing commands}]
+
+Unlike the previous group of commands, which would use
+[cmd docstrip::extract] to extract some code lines and then process
+those further, the following commands operate on text consisting of
+all types of lines.
+
+[list_begin definitions]
+%</utilman>
+% \end{macrocode}
+%
+%
+%
+% \subsection{Supporting doctools as markup language}
+%
+% In the interest of making \textsf{docstrip} useful also for
+% programmers who do not want to write \LaTeX\ markup, some support is
+% offered also for files with \textsf{doctools} \texttt{.man} markup in
+% the comment lines. It is suggested that such files are given the
+% suffix \texttt{.ddt} to distinguish them from the \texttt{.dtx} files
+% that are directly \LaTeX able.
+%
+% More precisely, it is suggested that the markup on comment and
+% metacomment lines of a \texttt{.ddt} file should follow the syntax on
+% the \texttt{doctools\_fmt} manpage~\cite{doctools_fmt}, or in the
+% future perhaps some derivative thereof. Unlike the case in
+% \texttt{.dtx} files, no explicit markup is required (or wanted)
+% around blocks of code and guard lines; such markup is to be generated
+% by the procedure below, as part of adding suitable markup to the code
+% lines.
+%
+% \begin{proc}{ddt2man}
+% This procedure takes a string in the \texttt{.ddt} format sketched
+% above and returns the corresponding text with \textsf{doctools}
+% \texttt{.man} markup. The syntax is
+% \begin{quote}
+% |docstrip::util::ddt2man| \word{text}
+% \end{quote}
+%
+% \begin{macrocode}
+%<*utilman>
+[call [cmd docstrip::util::ddt2man] [arg text]]
+ The [cmd ddt2man] command reformats [arg text] from the general
+ [syscmd docstrip] format to [package doctools] [file .man] format
+ (Tcl Markup Language for Manpages). The different line types are
+ treated as follows:
+ [list_begin definitions]
+ [def {comment and metacomment lines}]
+ The '%' and '%%' prefixes are removed, the rest of the text is
+ kept as it is.
+ [def {empty lines}]
+ These are kept as they are. (Effectively this means that they will
+ count as comment lines after a comment line and as code lines
+ after a code line.)
+ [def {code lines}]
+ [cmd example_begin] and [cmd example_end] commands are placed
+ at the beginning and end of every block of consecutive code
+ lines. Brackets in a code line are converted to [cmd lb] and
+ [cmd rb] commands.
+ [def {verbatim guards}]
+ These are processed as usual, so they do not show up in the
+ result but every line in a verbatim block is treated as a code
+ line.
+ [def {other guards}]
+ These are treated as code lines, except that the actual guard is
+ [cmd emph]asised.
+ [list_end]
+
+ At the time of writing, no project has employed [package doctools]
+ markup in master source files, so experience of what works well is
+ not available. A source file could however look as follows
+[example {
+%</utilman>
+%<*utilman,gcdexample>
+%<<verbatim
+% [manpage_begin gcd n 1.0]
+% [keywords divisor]
+% [keywords math]
+% [moddesc {Greatest Common Divisor}]
+% [require gcd [opt 1.0]]
+% [description]
+%
+% [list_begin definitions]
+% [call [cmd gcd] [arg a] [arg b]]
+% The [cmd gcd] procedure takes two arguments [arg a] and [arg b] which
+% must be integers and returns their greatest common divisor.
+proc gcd {a b} {
+% The first step is to take the absolute values of the arguments.
+% This relieves us of having to worry about how signs will be treated
+% by the remainder operation.
+ set a [expr {abs($a)}]
+ set b [expr {abs($b)}]
+% The next line does all of Euclid's algorithm! We can make do
+% without a temporary variable, since $a is substituted before the
+% [lb]set a $b[rb] and thus continues to hold a reference to the
+% "old" value of [var a].
+ while {$b>0} { set b [expr { $a % [set a $b] }] }
+% In Tcl 8.3 we might want to use [cmd set] instead of [cmd return]
+% to get the slight advantage of byte-compilation.
+%<tcl83> set a
+%<!tcl83> return $a
+}
+% [list_end]
+%
+% [manpage_end]
+%verbatim
+%</utilman,gcdexample>
+%<*utilman>
+}]
+ If the above text is fed through [cmd docstrip::util::ddt2man] then
+ the result will be a syntactically correct [package doctools]
+ manpage, even though its purpose is a bit different.
+ [para]
+
+ It is suggested that master source code files with [package doctools]
+ markup are given the suffix [file .ddt], hence the "ddt" in
+ [cmd ddt2man].
+
+%</utilman>
+% \end{macrocode}
+%
+% The structure of this procedure is fairly similar to that of
+% |extract|, although of course the processing of the lines is rather
+% different. The main novelty is the variable |wascode|, which is
+% true if the previous line was a code line of some sort.
+% \begin{tcl}
+%<*utilpkg>
+proc docstrip::util::ddt2man {text} {
+ set wascode 0
+ set verbatim 0
+ set res ""
+ foreach line [split $text \n] {
+ if {$verbatim} then {
+ if {$line eq $endverbline} then {
+ set verbatim 0
+ } else {
+ append res [string map {[ [lb] ] [rb]} $line] \n
+ }
+ } else {
+ switch -glob -- $line %%* {
+ if {$wacode} then {
+ append res {[example_end]} \n
+ set wascode 0
+ }
+ append res [string range $line 2 end] \n
+ } %<<* {
+ if {!$wascode} then {
+ append res {[example_begin]} \n
+ set wascode 1
+ }
+ set endverbline "%[string range $line 3 end]"
+ set verbatim 1
+ } %<* {
+ if {!$wascode} then {
+ append res {[example_begin]} \n
+ set wascode 1
+ }
+ set guard ""
+ regexp -- {(^%<[^>]*>)(.*)$} $line "" guard line
+ append res \[ [list emph $guard] \]\
+ [string map {[ [lb] ] [rb]} $line] \n
+ } %* {
+ if {$wascode} then {
+ append res {[example_end]} \n
+ set wascode 0
+ }
+ append res [string range $line 1 end] \n
+ } {\\endinput} {
+ break
+ } "" {
+% \end{tcl}
+% Experience showed that empty lines at the beginning and end of a
+% file were hard to avoid. In order to stop those from being marked
+% up as examples, an empty line will not trigger a switch to code
+% mode.
+% \begin{tcl}
+ append res \n
+ } default {
+ if {!$wascode} then {
+ append res {[example_begin]} \n
+ set wascode 1
+ }
+ append res [string map {[ [lb] ] [rb]} $line] \n
+ }
+ }
+ }
+ if {$wascode} then {append res {[example_end]} \n}
+ return $res
+}
+%</utilpkg>
+% \end{tcl}
+% There is no test of this procedure, since it is rather
+% experimental. One could however develop the example above into a
+% test, if the need seems significant.
+% \end{proc}
+%
+%
+% \subsection{Guard information}
+%
+% \begin{proc}{guards}
+% The |guards| command looks through a piece of master source code
+% and gathers information about the guards occurring therein. The
+% syntax is
+% \begin{quote}
+% |docstrip::util::guards| \word{subcommand} \word{text}
+% \end{quote}
+% where the \word{subcommand} is one of the following:
+% \begin{ttdescription}
+% \item[names]
+% Return the list of expression terminals occuring in the
+% \word{text}, in no particular order.
+% \item[counts]
+% Return a dictionary which for each expression terminal
+% occuring in the \word{text} gives the number of times it
+% occurs.
+% \item[expressions]
+% Return the list of expressions occuring in the \word{text},
+% in no particular order.
+% \item[exprcounts]
+% Return a dictionary which for each guard expression occuring
+% in the \word{text} gives the number of times it occurs.
+% \item[exprmods]
+% Return a dictionary which for each guard expression occuring
+% in the \word{text} gives a string of the modifiers of these
+% guards (where space is used for no modifier). This is the raw
+% format of the information collected by this procedure.
+% \item[exprerr]
+% Return the list of syntactically incorrect expressions occuring
+% in the \word{text}, in no particular order.
+% \item[rotten]
+% Return a dictionary which maps line numbers with bad guards to
+% their contents.
+% \end{ttdescription}
+% \changes{1.1}{2005/03/02}{Command added. (LH, extending a
+% suggestion of AK)}
+% \changes{1.2}{2005/08/23}{Changed name of \texttt{badguards}
+% subcommand to \texttt{rotten}. (LH)}
+% \changes{1.2}{2005/08/26}{Changed name of \texttt{guard}
+% procedure to \texttt{guards}. (LH)}
+% \begin{tcl}
+%<*utilman>
+[call [cmd docstrip::util::guards] [arg subcmd] [arg text]]
+ The [cmd guards] command returns information (mostly of a
+ statistical nature) about the ordinary docstrip guards that occur
+ in the [arg text]. The [arg subcmd] selects what is returned.
+
+ [list_begin definitions]
+ [def [method counts]]
+ List the guard expression terminals with counts. The format of
+ the return value is a dictionary which maps the terminal name to
+ the number of occurencies of it in the file.
+ [def [method exprcount]]
+ List the guard expressions with counts. The format of the return
+ value is a dictionary which maps the expression to the number of
+ occurencies of it in the file.
+ [def [method exprerr]]
+ List the syntactically incorrect guard expressions (e.g.
+ parentheses do not match, or a terminal is missing). The return
+ value is a list, with the elements in no particular order.
+ [def [method expressions]]
+ List the guard expressions. The return value is a list, with the
+ elements in no particular order.
+ [def [method exprmods]]
+ List the guard expressions with modifiers. The format of the return
+ value is a dictionary where each index is a guard expression and
+ each entry is a string with one character for every guard line that
+ has this expression. The characters in the entry specify what
+ modifier was used in that line: +, -, *, /, or (for guard without
+ modifier:) space. This is the most primitive form of the
+ information gathered by [cmd guards].
+ [def [method names]]
+ List the guard expression terminals. The return value is a list,
+ with the elements in no particular order.
+ [def [method rotten]]
+ List the malformed guard lines (this does not include lines where
+ only the expression is malformed, though). The format of the return
+ value is a dictionary which maps line numbers to their contents.
+ [list_end]
+%</utilman>
+% \end{tcl}
+%
+% \begin{tcl}
+%<*utilpkg>
+proc docstrip::util::guards {subcmd text} {
+% \end{tcl}
+% The first part is a cut-down |extract|. It collects data in the |E|
+% array, which is indexed by expression. The |badL| variable is used
+% for the data returned by the |rotten| subcommand.
+% \begin{tcl}
+ set verbatim 0
+ set lineno 1
+ set badL {}
+ foreach line [split $text \n] {
+ if {$verbatim} then {
+ if {$line eq $endverbline} then {set verbatim 0}
+ } else {
+ switch -glob -- $line %<<* {
+ set endverbline "%[string range $line 3 end]"
+ set verbatim 1
+ } %<* {
+ if {![
+ regexp -- {^%<([*/+-]?)([^>]*)>(.*)$} $line ""\
+ modifier expression line
+ ]} then {
+ lappend badL $lineno $line
+ } else {
+ if {$modifier eq ""} then {set modifier " "}
+ append E($expression) $modifier
+ }
+ }
+ }
+ incr lineno
+ }
+ if {$subcmd eq "rotten"} then {return $badL}
+% \end{tcl}
+% The second part processes the |E| array contents to produce the
+% various subcommand results.
+% \begin{tcl}
+ switch -- $subcmd "exprmods" {
+ return [array get E]
+ } "expressions" {
+ return [array names E]
+ } "exprerr" {
+ set res {}
+ foreach expr [array names E] {
+ regsub -all {[^()!,|&]+} $expr 0 e
+ regsub -all {,} $e {|} e
+ if {[catch {expr $e}]} then {lappend res $expr}
+ }
+ return $res
+ }
+ foreach name [array names E] {
+ set E($name) [string length $E($name)]
+ }
+ if {$subcmd eq "exprcounts"} then {return [array get E]}
+ foreach expr [array names E] {
+ foreach term [split $expr "()!,|&"] {
+ if {$term eq ""} then {continue}
+ if {![info exists T($term)]} then {set T($term) 0}
+ incr T($term) $E($expr)
+ }
+ }
+ switch -- $subcmd "counts" {
+ return [array get T]
+ } "names" {
+ return [array names T]
+ } default {
+ error "Unknown subcommand '$subcmd', must be one of:\
+ counts, exprcounts, expressions, exprmods, names, rotten"
+ }
+}
+%</utilpkg>
+% \end{tcl}
+% \end{proc}
+%
+%
+%
+% \subsection{Backporting assistance}
+%
+% It is (sadly) not entirely uncommon that the Literate Programmer finds
+% him- or herself with generated files that have been modified, even if
+% they carry prominent notices saying ``Don't do that! Change the
+% \emph{source} instead!''. When such changes are to the worse there is
+% little problem, because erasing them is just a matter of regenerating
+% the files in question, but often enough they instead contain useful
+% improvements of the code that one would like to keep. This requires
+% porting them back into the master source file, which in theory may
+% seem like a minor copy-and-paste task, but in practice often gets
+% frustrating because of the amount of navigating between the sites of
+% different changes that one must perform.
+%
+% Ordinarily such backporting would be handled using patch files, and
+% that is what will be done also in this case, but the fact that the
+% file in which the modifications were made does not look like the
+% source file means traditional patching tools are not immediately
+% useful. The procedures defined below provides for
+% \textsc{docstrip}-aware patching.
+%
+%
+%
+% \begin{proc}{patch}
+% The |patch| procedure applies a list of diff hunks to a
+% \textsc{docstrip} style master source file.
+% \changes{1.2}{2005/06/20}{Procedure added. (LH)}
+% The syntax is
+% \begin{quote}
+% |docstrip::util::patch| \word{source var.} \word{terminals}
+% \word{fromtext} \word{diff}
+% \begin{regblock}[\regstar]\word{option} \word{value}\end{regblock}
+% \end{quote}
+% The \word{source var.} is the name in the calling context
+% of a variable which contains the list of lines in the source
+% to patch; patching thus means modifying this list. \word{diff} is
+% the difference hunks to apply, and the \word{fromtext} is the text
+% that diff is meant to modify. \word{terminals} is the list of
+% terminals one should use to |extract| \word{fromtext} (or a part
+% thereof) from the source. The return value is a sort of annotated
+% diff file, where each hunk carries a comment on how it was applied.
+% Hunks with empty comments (usually meaning ``hunk applied in full,
+% no problems were observed'') are omitted from this report.
+%
+% The \word{option} \word{value} pairs may be used to further control
+% what happens. Currently the following options are interpreted:
+% \begin{ttdescription}
+% \item[-matching]
+% How is the \word{diff} matched against the \word{fromtext}?
+% (Hunks that don't match are ignored.) The default is |exact|,
+% which means each line must match. The alternatives are |none|
+% (in which case no check is made, i.e., line numbers are silently
+% assumed to be correct), |nonspace| (only non-whitespace
+% characters are compared), and |anyspace| (any sequence of
+% whitespace characters compare as a single space).
+% \item[-metaprefix]
+% Same as for |docstrip::extract|.
+% \item[-trimlines]
+% Same as for |docstrip::extract|.
+% \end{ttdescription}
+%
+% The \word{diff} is a list of ``parsed differences'', the format of
+% which is explained in Subsection~\ref{Ssec:Tcldiff}.
+%
+% The way this procedure operates is that it first establishes a
+% correspondence between lines in the source and lines in the
+% \word{fromtext}. The first part of this correspondence is determined
+% by the source and \word{terminals}, and is complicated but univocal.
+% The second part of this correspondence is given by a matching of
+% extracted lines to \word{fromtext} lines, and this is typically
+% simple but not necessarily unique, which means the user need to be
+% aware of the heuristic used: the lines of the \word{fromtext} are
+% read in sequence, and whenever one matching the line after that in
+% the extracted text with which the most recent correspondence is
+% found, then these two are considered to correspond to each other.
+% This should work well with the generated files one typically finds,
+% which consist of long intervals of lines corresponding exactly to
+% extracted texts, surrounded by some pre- and postambles. With files
+% generated from several source files it may be necessary to add some
+% metacomment line to disambigue the pieces, but that is often not a
+% problem.
+%
+% \begin{tcl}
+%<*utilpkg>
+proc docstrip::util::patch {sourcevar termL fromtext diff args} {
+ upvar 1 $sourcevar SL
+ array set O {-trimlines 1 -matching exact}
+ array set O $args
+% \end{tcl}
+% The first step is to construct the array |lift| that maps
+% \word{fromtext} line numbers to source line numbers. This array
+% actually contains a bit more than just the line numbers; the
+% complete entry format is
+% \begin{quote}
+% \word{SL index} \word{source-prefix} \word{extract-prefix}
+% \end{quote}
+% where \word{SL index} is an index into the source \emph{list} of
+% lines (thus starting at zero rather than one), \word{source-prefix}
+% is the source line prefix (usually an empty string) that was removed
+% as part of the extraction process, and \word{extract-prefix} is the
+% prefix that was inserted as part of the extraction process (usually
+% an empty string).
+%
+% In order to gather the above information, |extract| is run in the two
+% lines of annotation format, which means the interpretation of an |EL|
+% element depends heavily on its index modulo $3$. Setting the last
+% element to a newline (it would otherwise had been an empty string,
+% since |extract| places a newline after every line) is a sneaky way
+% of preventing the |ptr| ``pointer'' into |EL| from going past the
+% end of that list.
+% \begin{tcl}
+ set cmd [list extract [join $SL \n] $termL -annotate 2]
+ foreach opt {-metaprefix -trimlines} {
+ if {[info exists O($opt)]} then {lappend cmd $opt $O($opt)}
+ }
+ set EL [split [eval $cmd] \n]
+ lset EL end \n
+ set ptr 0
+ set lineno 1
+ set FL [list {}]
+ foreach line [split $fromtext \n] {
+ lappend FL $line
+ if {$O(-trimlines)} then {set line [string trimright $line " "]}
+ if {$line eq [lindex $EL $ptr]} then {
+ set lift($lineno) [lindex $EL [incr ptr]]
+ lset lift($lineno) 0 [expr { [lindex $EL [incr ptr]] - 1 }]
+ incr ptr
+ }
+ incr lineno
+ }
+% \end{tcl}
+% The |FL| variable constructed above is a list of \word{fromtext}
+% lines, with list index equal to line number. It is used below when
+% matching the differences.
+%
+% If at this point the |lift| array is empty, then no patching can be
+% done. An error is thrown which suggests that the user checks the
+% input given.
+% \begin{tcl}
+ if {![array size lift]} then {
+ return -code error "The extract did not match any part of the\
+ fromtext. Check the list of terminals and the options"
+ }
+% \end{tcl}
+%
+% The second step consists of extending the \word{diff} to a
+% ``replace-list'', so that the hunk format becomes
+% \begin{quote}
+% \word{start1} \word{end1} \word{start2} \word{end2}
+% \word{lines} \word{replaces}
+% \end{quote}
+% where the \word{replaces} is a list of lists on the form
+% \begin{quote}
+% \word{start1} \word{end1} \word{line}\regstar
+% \end{quote}
+% i.e., the same format as for arguments two and up of |lreplace|. (In
+% particular, \(\mathit{end1} = \mathit{start1}-1\) when only
+% inserting and there are no \word{line}s when only removing.) These
+% extended hunks are placed in the variable |RL| sorted in descending
+% order after \word{start1}, and the replaces within each hunk are
+% sorted in that order too.
+%
+% This is also where the procedure begins constructing its report,
+% which is another extension of the hunk format. Here the syntax is
+% \begin{quote}
+% \word{start1} \word{end1} \word{start2} \word{end2}
+% \word{lines} \word{comment}
+% \end{quote}
+% where the \word{comment} is a description of what was done with
+% this hunk.
+% \begin{tcl}
+ set RL [list]
+ set log [list]
+ foreach hunk [lsort -decreasing -integer -index 0 $diff] {
+ set replL [list]
+ set l1 [lindex $hunk 0]
+ set repl {0 -1}
+ set matches 1
+ foreach {type line} [lindex $hunk 4] {
+ switch -glob -- $type {[0-]} {
+ switch -- $O(-matching) "exact" {
+ if {[lindex $FL $l1] ne $line} then {set matches 0}
+ } "nonspace" {
+ if {[regsub -all -- {\s} $line {}] ne\
+ [regsub -all -- {\s} [lindex $FL $l1] {}]} then {
+ set matches 0
+ }
+ } "anyspace" {
+ if {[regsub -all -- {\s+} $line { }] ne\
+ [regsub -all -- {\s+} [lindex $FL $l1] { }]} then {
+ set matches 0
+ }
+ }
+ }
+ switch -- $type synch {
+ if {[llength $repl]>2 ||\
+ [lindex $repl 1]-[lindex $repl 0]>=0} then {
+ lappend replL $repl
+ }
+ set repl [list $l1 [expr {$l1-1}]]
+ } + {
+ lappend repl $line
+ } - {
+ lset repl 1 $l1
+ incr l1
+ } 0 {
+ if {[llength $repl]>2 ||\
+ [lindex $repl 1]-[lindex $repl 0]>=0} then {
+ lappend replL $repl
+ set repl {0 -1}
+ }
+ lset repl 1 $l1
+ incr l1
+ lset repl 0 $l1
+ }
+ }
+ if {[llength $repl]>2 || [lindex $repl 1]-[lindex $repl 0]>=0}\
+ then {lappend replL $repl}
+ if {$matches} then {
+ lappend hunk [lsort -decreasing -integer -index 0 $replL]
+ lappend RL $hunk
+ } else {
+ lappend hunk "(-- did not match fromtext --)"
+ lappend log $hunk
+ }
+ }
+% \end{tcl}
+% The difference granularity is now the one that will be used in the
+% insertion of new lines. The reason for extending hunks rather than
+% using something else is to use the original data when reporting
+% problems.
+%
+% The third step is to actually apply the changes to |SL|, translating
+% line numbers as one goes along. Differences are processed
+% back-to-front, because that means first file line numbers are valid,
+% and those are the ones that can be translated to source line numbers.
+%
+% \begin{tcl}
+ foreach hunk $RL {
+ set applied 0
+ set misapplied 0
+% \end{tcl}
+% For the purpose of generating a report, count is kept of how many
+% lines of each hunk could be applied or could not be applied. That
+% a hunk could not be applied (|applied| is zero) is often normal
+% (the changed material was not generated from this source file),
+% but if both counters are positive at the same time then one should
+% take a bit more notice.
+% \begin{tcl}
+ foreach repl [lindex $hunk 5] {
+ unset -nocomplain from to
+% \end{tcl}
+% A |repl| is processed by replacing the item range |$from|--|$to|
+% of lines to remove by the lines to insert, but for that the entire
+% range of source lines must be continuous. The |for| loop below
+% sets |from| and |to| to the endpoints of the first range of lines
+% to replace because of this |repl|, and removes any subsequent
+% ranges immediately.
+% \begin{tcl}
+ for {set n [lindex $repl 1]} {$n>=[lindex $repl 0]}\
+ {incr n -1} {
+ if {![info exists lift($n)]} then {
+ incr misapplied
+ continue
+ } elseif {![info exists from]} then {
+ set to [lindex $lift($n) 0]
+ set from $to
+ } elseif {[lindex $lift($n) 0] == $from-1} then {
+ set from [lindex $lift($n) 0]
+ } else {
+ set SL [lreplace $SL $from $to]
+ set to [lindex $lift($n) 0]
+ set from $to
+ }
+ incr applied
+ set n0 $n
+ }
+% \end{tcl}
+% For the replacement with lines to insert, it is necessary to
+% figure out the source and extracted line prefixes. These are taken
+% from the |from| line of the source, which is the line \emph{after}
+% the new lines if this is a pure insertion.
+% \begin{tcl}
+ if {[info exists from]} then {
+ set sprefix [lindex $lift($n0) 1]
+ set eprefix [lindex $lift($n0) 2]
+ } elseif {[info exists lift([lindex $repl 0])]} then {
+ foreach {from sprefix eprefix} $lift([lindex $repl 0])\
+ break
+ set to [expr {$from-1}]
+ } else {
+ incr misapplied [llength [lrange $repl 2 end]]
+ continue
+ }
+ set eplen [string length $eprefix]
+ set epend [expr {$eplen-1}]
+% \end{tcl}
+% Actually replacing the lines is pretty straightforward, but the
+% |lreplace| command doing this is built dynamically.
+% \begin{tcl}
+ set cmd [list lreplace $SL $from $to]
+ foreach line [lrange $repl 2 end] {
+ if {$eprefix eq [string range $line 0 $epend]} then {
+ lappend cmd "$sprefix[string range $line $eplen end]"
+ } else {
+ lappend cmd $line
+ }
+ incr applied
+ }
+ set SL [eval $cmd]
+ }
+% \end{tcl}
+% Only hunks with misapplied lines get included in the log.
+% \begin{tcl}
+ if {$misapplied>0} then {
+ if {$applied>0} then {
+ lset hunk 5 "(-- was partially applied --)"
+ } else {
+ lset hunk 5 "(not applied)"
+ }
+ lappend log $hunk
+ }
+ }
+% \end{tcl}
+% Finally the log is formatted for return.
+% \begin{tcl}
+ set res ""
+ foreach hunk [lsort -index 0 -integer $log] {
+ foreach {start1 end1 start2 end2 lines msg} $hunk break
+ append res [format "@@ -%d,%d +%d,%d @@ %s\n"\
+ $start1 [expr {$end1-$start1+1}]\
+ $start2 [expr {$end2-$start2+1}] $msg]
+ foreach {type line} $lines {
+ switch -- $type 0 {
+ append res " " $line \n
+ } - - + {
+ append res $type $line \n
+ }
+ }
+ }
+ return $res
+}
+%</utilpkg>
+% \end{tcl}
+%
+% \begin{macrocode}
+%<*utilman>
+[call [cmd docstrip::util::patch] [arg source-var] [arg terminals]\
+ [arg fromtext] [arg diff] [opt "[arg option] [arg value] ..."]]
+ This command tries to apply a [syscmd diff] file (for example a
+ contributed patch) that was computed for a generated file to the
+ [syscmd docstrip] source. This can be useful if someone has
+ edited a generated file, thus mistaking it for being the source.
+ This command makes no presumptions which are specific for the case
+ that the generated file is a Tcl script.
+ [para]
+
+ [cmd patch] requires that the source file to patch is kept as a
+ list of lines in a variable, and the name of that variable in the
+ calling context is what goes into the [arg source-var] argument.
+ The [arg terminals] is the list of terminals used to extract the
+ file that has been patched. The [arg diff] is the actual diff to
+ apply (in a format as explained below) and the [arg fromtext] is
+ the contents of the file which served as "from" when the diff was
+ computed. Options can be used to further control the process.
+ [para]
+
+ The process works by "lifting" the hunks in the [arg diff] from
+ generated to source file, and then applying them to the elements of
+ the [arg source-var]. In order to do this lifting, it is necessary
+ to determine how lines in the [arg fromtext] correspond to elements
+ of the [arg source-var], and that is where the [arg terminals] come
+ in; the source is first [cmd extract]ed under the given
+ [arg terminals], and the result of that is then matched against
+ the [arg fromtext]. This produces a map which translates line
+ numbers stated in the [arg diff] to element numbers in
+ [arg source-var], which is what is needed to lift the hunks.
+ [para]
+
+ The reason that both the [arg terminals] and the [arg fromtext]
+ must be given is twofold. First, it is very difficult to keep track
+ of how many lines of preamble are supplied some other way than by
+ copying lines from source files. Second, a generated file might
+ contain material from several source files. Both make it impossible
+ to predict what line number an extracted file would have in the
+ generated file, so instead the algorithm for computing the line
+ number map looks for a block of lines in the [arg fromtext] which
+ matches what can be extracted from the source. This matching is
+ affected by the following options:
+ [list_begin options]
+ [opt_def -matching [arg mode]]
+ How equal must two lines be in order to match? The supported
+ [arg mode]s are:
+ [list_begin definitions]
+ [def [const exact]]
+ Lines must be equal as strings. This is the default.
+ [def [const anyspace]]
+ All sequences of whitespace characters are converted to single
+ spaces before comparing.
+ [def [const nonspace]]
+ Only non-whitespace characters are considered when comparing.
+ [def [const none]]
+ Any two lines are considered to be equal.
+ [list_end]
+ [opt_def -metaprefix [arg string]]
+ The [option -metaprefix] value to use when extracting. Defaults
+ to "%%", but for Tcl code it is more likely that "#" or "##" had
+ been used for the generated file.
+ [opt_def -trimlines [arg boolean]]
+ The [option -trimlines] value to use when extracting. Defaults to
+ true.
+ [list_end]
+
+ The return value is in the form of a unified diff, containing only
+ those hunks which were not applied or were only partially applied;
+ a comment in the header of each hunk specifies which case is at
+ hand. It is normally necessary to manually review both the return
+ value from [cmd patch] and the patched text itself, as this command
+ cannot adjust comment lines to match new content.
+ [para]
+
+ An example use would look like
+[example_begin]
+set sourceL [lb]split [lb]docstrip::util::thefile from.dtx[rb] \n[rb]
+set terminals {foo bar baz}
+set fromtext [lb]docstrip::util::thefile from.tcl[rb]
+set difftext [lb]exec diff --unified from.tcl to.tcl[rb]
+set leftover [lb]docstrip::util::patch sourceL $terminals $fromtext\
+ [lb]docstrip::util::import_unidiff $difftext[rb] -metaprefix {#}[rb]
+set F [lb]open to.dtx w[rb]; puts $F [lb]join $sourceL \n[rb]; close $F
+return $leftover
+[example_end]
+ Here, [file from.dtx] was used as source for [file from.tcl], which
+ someone modified into [file to.tcl]. We're trying to construct a
+ [file to.dtx] which can be used as source for [file to.tcl].
+%</utilman>
+% \end{macrocode}
+% \end{proc}
+%
+%
+%
+%
+% \section{Reading files}
+%
+% \subsection{Raw file contents}
+%
+% \begin{proc}{thefile}
+% When experimenting with docstripping, it is often convenient to have
+% an easy command for reading the contents of a file. The |thefile|
+% command (named vaugely in the tradition of such \LaTeX\ commands as
+% |\thepage|) returns the contents of the file whose name it is given.
+% \changes{1.2}{2005/06/19}{Procedure added. (LH)}
+% More precisely, the syntax is
+% \begin{quote}
+% |docstrip::util::thefile| \word{file name}
+% \begin{regblock}[\regstar]\word{option} \word{value}\end{regblock}
+% \end{quote}
+% where the \word{option} \word{value} pairs are handed to |fconfigure|
+% to configure the file before reading it.
+% \changes{1.2}{2005/09/07}{Added error handling. (LH)}
+% \changes{1.3}{2010/04/12}{Added \texttt{-nonewline} switch. (LH)}
+% \begin{tcl}
+%<*utilpkg>
+proc docstrip::util::thefile {fname args} {
+ set F [open $fname r]
+ if {[llength $args]} then {
+ if {[set code [
+ catch {eval [linsert $args 0 fconfigure $F]} res
+ ]]} then {
+ close $F
+ return -code $code -errorinfo $::errorInfo -errorcode\
+ $::errorCode
+ }
+ }
+ catch {read -nonewline $F} res
+ close $F
+ return $res
+}
+%</utilpkg>
+% \end{tcl}
+% The code is thus very straightforward---what remains is to make a
+% manpage entry for it.
+% \begin{tcl}
+%<*utilman>
+[call [cmd docstrip::util::thefile] [arg filename] [
+ opt "[arg option] [arg value] ..."
+]]
+ The [cmd thefile] command opens the file [arg filename], reads it to
+ end, closes it, and returns the contents (dropping a final newline
+ if there is one). The option-value pairs are
+ passed on to [cmd fconfigure] to configure the open file channel
+ before anything is read from it.
+%</utilman>
+% \end{tcl}
+% \end{proc}
+%
+% Better provide some tests too\dots
+% \begin{tcl}
+%<*utiltest>
+tcltest::test docstrip::util::thefile-1.1 {thefile without args}\
+ -setup {
+ set Fname [tcltest::makeFile [
+ join {
+ {% Just a minor test file.}
+ {puts A}
+ {%<*bar>}
+ {puts B}
+ {%<*foo>}
+ {puts [info exists baz]}
+ } \n
+ ] test.txt]
+} -body {
+ docstrip::util::thefile $Fname
+} -cleanup {
+ tcltest::removeFile $Fname
+} -result [join {
+ {% Just a minor test file.}
+ {puts A}
+ {%<*bar>}
+ {puts B}
+ {%<*foo>}
+ {puts [info exists baz]}
+} \n]
+% \end{tcl}
+% This one tests that an error in the number of arguments is caught
+% correctly.
+% \begin{tcl}
+tcltest::test docstrip::util::thefile-1.2 {thefile with wrong no. args}\
+ -setup {
+ set Fname [tcltest::makeFile [
+ join {
+ {% Just a minor test file (contents irrelevant).}
+ {puts A}
+ {%<*bar>}
+ {puts B}
+ {%<*foo>}
+ {puts [info exists baz]}
+ } \n
+ ] test.txt]
+} -body {
+ docstrip::util::thefile $Fname -translation binary -buffering
+} -cleanup {
+ tcltest::removeFile $Fname
+} -returnCodes error
+% \end{tcl}
+% This one tests configuring (of encoding).
+% \begin{tcl}
+tcltest::test docstrip::util::thefile-1.3 {thefile with args} -setup {
+ set Fname [tcltest::makeFile "Dummy content to overwrite" test.xxx]
+ set F [open $Fname w]
+ fconfigure $F -translation binary
+ puts -nonewline $F [encoding convertto utf-8 \u00E5\u00E4\u00F6]
+ close $F
+} -body {
+ docstrip::util::thefile $Fname -encoding utf-8
+} -cleanup {
+ tcltest::removeFile $Fname
+} -result \u00E5\u00E4\u00F6
+%</utiltest>
+% \end{tcl}
+%
+%
+% \subsection{The diff format}
+% \label{Ssec:Tcldiff}
+%
+% The difference format used by |docstrip::util::patch| is a
+% \Tcllogo-list format into which the common diff formats can be parsed.
+% Each hunk is a five element list
+% \begin{quote}
+% \word{start1} \word{end1} \word{start2} \word{end2} \word{lines}
+% \end{quote}
+% where the start and end elements are integers, specifying the line
+% numbers of the first and last lines in the hunk respectively. 1
+% elements pertain to the first file and 2 elements to the second file.
+% The number of the first line in a file is |1|.
+%
+% The \word{lines} is a list of the form
+% \begin{quote}
+% \begin{regblock}[\regplus]\word{type} \word{text}\end{regblock}
+% \end{quote}
+% where each \word{text} is an actual line of text (minus newline) and
+% the \word{type} specifies the type of this line. |+| means a line that
+% is in the second file but not the first, |-| means a line that is in
+% the first file but not the second, and |0| means a line that is in
+% both files. The format is thus most similar to the \texttt{--unified}
+% diff format, but the difference is not too great to the other formats
+% either. The \word{type} may also be |synch|, which is used as a
+% placeholder for any number of ``invisible'' lines (neither in the
+% first or second file, but perhaps present in the source) at that
+% point. The \word{text} of |synch| lines is ignored.
+%
+% As an example of what it looks like, a difference between the two
+% files
+%\begin{verbatim}
+%foo
+%bar baz
+%end
+%\end{verbatim}
+% and
+%\begin{verbatim}
+%foo
+%bar
+%baz
+%end
+%\end{verbatim}
+% is
+% \begin{quote}
+% |1 3 1 4 {0 foo - {bar baz} + bar + baz 0 end}|
+% \end{quote}
+% An alternative is
+% \begin{quote}
+% |2 2 2 3 {+ bar - {bar baz} + baz}|
+% \end{quote}
+% since \texttt{+} lines ``commute'' with \texttt{-} lines.
+%
+% \begin{proc}{import_unidiff}
+% The |import_unidiff| procedure imports a standard diff in unified
+% format to the format described above. The call syntax is
+% \begin{quote}
+% |docstrip::util::import_unidiff| \word{diff-text}
+% \word{warning-var}\regopt
+% \end{quote}
+% where the \word{diff-text} is the actual text of the diff file to
+% convert, and the \word{warning-var} is the name of a variable in
+% the calling context to which warnings about failings to parse the
+% input \word{diff-text} will be appended. The return format is a
+% list as described above.
+%
+% In the implementation, the hunk-to-be is kept in the five
+% variables |start1|, |end1|, |start2|, |end2|, and |lines|.
+% Whether |end2| is an integer is used as a signal for whether there
+% is a hunk to append. Malformed hunk headers will cause that hunk
+% to be ignored.
+% \begin{tcl}
+%<*utilpkg>
+proc docstrip::util::import_unidiff {text {warnvar ""}} {
+ if {$warnvar ne ""} then {upvar 1 $warnvar warning}
+ set inheader 1
+ set res [list]
+ set lines [list]
+ set end2 "not an integer"
+ foreach line [split $text \n] {
+ if {$inheader && [regexp {^(---|\+\+\+)} $line]}\
+ then {continue}
+ switch -glob -- $line { *} {
+ lappend lines 0 [string range $line 1 end]
+ } {+*} {
+ lappend lines + [string range $line 1 end]
+ } {-*} {
+ lappend lines - [string range $line 1 end]
+ } @@* {
+ if {[string is integer $end2]} then {
+ lappend res [list $start1 $end1 $start2 $end2 $lines]
+ }
+ set len2 [set len1 ,1]
+ if {[
+ regexp {^@@ -([0-9]+)(,[0-9]+)? \+([0-9]+)(,[0-9]+)? @@}\
+ $line -> start1 len1 start2 len2
+ ] && [scan "$start1 $len1,1" {%d ,%d} start1 len1]==2 &&\
+ [scan "$start2 $len2,1" {%d ,%d} start2 len2]==2
+ } then {
+ set end1 [expr {$start1+$len1-1}]
+ set end2 [expr {$start2+$len2-1}]
+ set inheader 0
+ } else {
+ set end2 "not an integer"
+ append warning "Could not parse hunk header: " $line \n
+ }
+ set lines [list]
+ } "" {
+% \end{tcl}
+% Empty lines are ignored (there will typically be one at the end of
+% the |foreach| loop).
+% \begin{tcl}
+ } default {
+ append warning "Could not parse line: " $line \n
+ }
+ }
+ if {[string is integer $end2]} then {
+ lappend res [list $start1 $end1 $start2 $end2 $lines]
+ }
+ return $res
+}
+%</utilpkg>
+% \end{tcl}
+%
+% \begin{macrocode}
+%<*utilman>
+[call [cmd docstrip::util::import_unidiff] [arg diff-text]\
+ [opt [arg warning-var]]]
+ This command parses a unified ([syscmd diff] flags [option -U] and
+ [option --unified]) format diff into the list-of-hunks format
+ expected by [cmd docstrip::util::patch]. The [arg diff-text]
+ argument is the text to parse and the [arg warning-var] is, if
+ specified, the name in the calling context of a variable to which
+ any warnings about parsing problems will be [cmd append]ed.
+ [para]
+
+ The return value is a list of [term hunks]. Each hunk is a list of
+ five elements "[arg start1] [arg end1] [arg start2] [arg end2]
+ [arg lines]". [arg start1] and [arg end1] are line numbers in the
+ "from" file of the first and last respectively lines of the hunk.
+ [arg start2] and [arg end2] are the corresponding line numbers in
+ the "to" file. Line numbers start at 1. The [arg lines] is a list
+ with two elements for each line in the hunk; the first specifies the
+ type of a line and the second is the actual line contents. The type
+ is [const -] for lines only in the "from" file, [const +] for lines
+ that are only in the "to" file, and [const 0] for lines that are
+ in both.
+[list_end]
+%</utilman>
+% \end{macrocode}
+% \end{proc}
+%
+%
+%
+% \section{Closing material}
+%
+% The packages need no particular ending, but the tests can do with an
+% explicit cleanup.
+%
+% \begin{tcl}
+%<*test,utiltest>
+%<!tcllibtest>tcltest::cleanupTests
+%<tcllibtest>testsuiteCleanup
+%</test,utiltest>
+% \end{tcl}
+%
+% The manpages require an explicit ending, and can do with some
+% keywords.
+% \begin{macrocode}
+%<*man,utilman>
+[manpage_end]
+%</man,utilman>
+% \end{macrocode}
+% There! That's it!
+%
+%
+% \section{Development tools}
+%
+% I have found the following code snippets useful for formatting
+% \texttt{docstrip.man}.
+% \begin{tcl}
+%<*devmantest>
+package require doctools
+doctools::new man2html -format html
+proc makehtml {{from docstrip.man} {to docstrip.html}} {
+ set text [string map {\r \n}\
+ [getText -w $from [minPos] [maxPos -w $from]]]
+ set html [man2html format $text]
+ replaceText -w $to [minPos] [maxPos -w $to]\
+ [string map {\n \r} $html]
+}
+proc dtx2html {terminals {to docstrip_util.html} {from tcldocstrip.dtx}} {
+ set text [string map {\r \n}\
+ [getText -w $from [minPos] [maxPos -w $from]]]
+ set html [man2html format [docstrip::extract $text $terminals]]
+ replaceText -w $to [minPos] [maxPos -w $to]\
+ [string map {\n \r} $html]
+}
+%</devmantest>
+% \end{tcl}
+% It is included here so that I know where to find it, but it is
+% normally no extracted.
+%
+% \bigskip
+%
+% The following block of code could be taken as the beginnings of a test
+% or example of the use of |ddt2man|. First extract the
+% \Module{gcdexample}.
+% \begin{tcl}
+%<*devtest2>
+package require docstrip
+set F [open tcldocstrip.dtx r]
+set text [docstrip::extract [read $F] gcdexample]
+close $F
+% \end{tcl}
+% Then unindent the lines so that they become the intended mixture of
+% code and comment lines.
+% \begin{tcl}
+regsub -all -lineanchor {^ } $text "" ddt
+% \end{tcl}
+% Now |ddt2html| can be applied:
+% \begin{tcl}
+package require docstrip::util
+set man [docstrip::util::ddt2man $ddt]
+% \end{tcl}
+% Finally, format this code as something.
+% \begin{tcl}
+package require doctools
+doctools::new man2html -format html
+set html [man2html format $man]
+%</devtest2>
+% \end{tcl}
+%
+% \begin{thebibliography}{6}
+% \bibitem{tclldoc}
+% Lars Hellstr\"om:
+% \textit{The \textsf{tclldoc} package and class},
+% \LaTeXe\ package and document class,
+% \textsc{ctan}:\discretionary{}{}{\thinspace}\texttt{macros}\slash
+% \texttt{latex}\slash \texttt{contrib}\slash \texttt{tclldoc}/.
+% \bibitem{doctools_fmt}
+% Andreas Kupries:
+% \textit{Specification of a simple \Tcllogo\ Markup Language
+% for Manpages}, manpage,
+% \texttt{tcllib} module \textsf{doctools}, 2002--;
+% \textsc{http}:/\slash \texttt{core.tcl.tk/tcllib}\slash
+% \texttt{doc}\slash \texttt{doctools\_fmt.html}.
+% \bibitem{docstrip}
+% Frank Mittelbach, Denys Duchier, Johannes Braams, Marcin
+% Woli\'nski, and Mark Wooding: \textit{The \textsf{DocStrip}
+% program}, The \LaTeX3 Project;
+% \textsc{ctan}:\discretionary{}{}{\thinspace}\texttt{macros}\slash
+% \texttt{latex}\slash \texttt{base}\slash \texttt{docstrip.dtx}.
+% \bibitem{doc}
+% Frank Mittelbach, B.~Hamilton Kelly, Andrew Mills, Dave Love, and
+% Joachim \mbox{Schrod}: \textit{The \textsf{doc} and
+% \textsf{shortvrb} Packages}, The \LaTeX3 Project;
+% \textsc{ctan}:\discretionary{}{}{\thinspace}\texttt{macros}\slash
+% \texttt{latex}\slash \texttt{base}\slash \texttt{doc.dtx}.
+% \iffalse
+% [enum]
+% Chapter 14 of
+% [emph {The LaTeX Companion}] (second edition),
+% Addison-Wesley, 2004; ISBN 0-201-36299-6.
+% \fi
+% \end{thebibliography}
+%
+%
+\endinput
+
+ \ No newline at end of file
diff --git a/tcllib/modules/docstrip/tcldocstrip.ins b/tcllib/modules/docstrip/tcldocstrip.ins
new file mode 100644
index 0000000..2eae3fd
--- /dev/null
+++ b/tcllib/modules/docstrip/tcldocstrip.ins
@@ -0,0 +1,46 @@
+% tcldocstrip.ins --- DOCSTRIP installation script for
+% the docstrip Tcl package
+\input docstrip
+
+% Redefine the \MetaPrefix; it should be something which starts a
+% until-end-of-line comment:
+\edef\MetaPrefix{\string#\string#}
+
+
+% Redefine the file preamble and postamble; this is necessary because
+% otherwise the old \metaPrefix is inserted at the beginning of these
+% lines.
+\preamble
+
+In other words:
+**************************************
+* This Source is not the True Source *
+**************************************
+the true source is the file from which this one was generated.
+
+\endpreamble
+
+\postamble
+\endpostamble
+
+\askforoverwritefalse
+
+% Actually make docstrip.tcl et al.:
+\generate{
+ \file{docstrip.tcl} {\from{tcldocstrip.dtx}{pkg}}
+ \file{docstrip_util.tcl} {\from{tcldocstrip.dtx}{utilpkg}}
+ \file{pkgIndex.tcl} {\from{tcldocstrip.dtx}{idx}}
+ \file{docstrip.test} {\from{tcldocstrip.dtx}{test}}
+ \file{docstrip_util.test}{\from{tcldocstrip.dtx}{utiltest}}
+ % The .test files are generated with an extra option tcllibtest
+ % by tcldocstrip.stitch. This causes them to make use of code
+ % that is unlikely to be present outside the tcllib test
+ % environment.
+ \usepreamble\empty
+ \usepostamble\empty
+ \file{docstrip.man} {\from{tcldocstrip.dtx}{man}}
+ \file{docstrip_util.man} {\from{tcldocstrip.dtx}{utilman}}
+}
+
+
+\end
diff --git a/tcllib/modules/docstrip/tcldocstrip.stitch b/tcllib/modules/docstrip/tcldocstrip.stitch
new file mode 100644
index 0000000..800eeae
--- /dev/null
+++ b/tcllib/modules/docstrip/tcldocstrip.stitch
@@ -0,0 +1,25 @@
+# -*- tcl -*-
+# Stitch definition for docstrip files, used by SAK.
+
+input tcldocstrip.dtx
+
+options -metaprefix \# -preamble {In other words:
+**************************************
+* This Source is not the True Source *
+**************************************
+the true source is the file from which this one was generated.
+}
+
+stitch docstrip.tcl pkg
+stitch docstrip_util.tcl utilpkg
+stitch pkgIndex.tcl idx
+stitch docstrip.test {test tcllibtest}
+stitch docstrip_util.test {utiltest tcllibtest}
+# For the .test files, the tcllibtest guard is not present in
+# the corresponding commmand in tcldocstrip.ins. The rationale
+# for this is that someone using the .ins rather than the .stitch
+# is unlikely to have a tcllib testing environment at hand.
+
+options -nopreamble -nopostamble
+stitch docstrip.man man
+stitch docstrip_util.man utilman
diff --git a/tcllib/modules/doctools/ChangeLog b/tcllib/modules/doctools/ChangeLog
new file mode 100644
index 0000000..f6df0a4
--- /dev/null
+++ b/tcllib/modules/doctools/ChangeLog
@@ -0,0 +1,1908 @@
+2013-11-07 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/man.macros: [Ticket 369f67aeee] Updated to newest from
+ Tcl/Tk.
+
+2013-11-06 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fmt.nroff: [Ticket efe207eff1]: Applied
+ * mpformats/idx.nroff: patched by Stuart Casoff to
+ * mpformats/toc.nroff: unbreak manpage rendering on
+ * modules/doctools/tests/nroff/00: various BSD variants.
+ * modules/doctools/tests/nroff/01: Must include our
+ * modules/doctools/tests/nroff/02: macros after emitting
+ * modules/doctools/tests/nroff/03: .TH to avoid clashes.
+ * modules/doctools/tests/nroff/04: Updated test results.
+ * modules/doctools/tests/nroff/05:
+ * modules/doctools/tests/nroff/06:
+ * modules/doctools/tests/nroff/07:
+ * modules/doctools/tests/nroff/08:
+
+2013-06-05 Andreas Kupries <andreask@activestate.com>
+
+ * doctools.tcl: Added dt_ibase command to the set
+ * mpformats/_common.tcl: available in formatters.
+ * pkgIndex.tcl: Extended file command emulation.
+ Used in the provenance code for shorter reference
+ to the proper input file. Bumped to 1.4.17.
+
+2013-02-26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/_nroff.tcl: Modified the formatting of dots (".").
+ * pkgIndex.tcl: Always quote them with \& (zero-width escape).
+ * doctools.tcl: Updated test results. Version bumped to 1.4.16.
+ * doctools.man:
+ * modules/doctools/tests/nroff/00:
+ * modules/doctools/tests/nroff/01:
+ * modules/doctools/tests/nroff/02:
+ * modules/doctools/tests/nroff/03:
+ * modules/doctools/tests/nroff/04:
+ * modules/doctools/tests/nroff/05:
+ * modules/doctools/tests/nroff/06:
+ * modules/doctools/tests/nroff/07:
+ * modules/doctools/tests/nroff/08:
+
+
+2013-02-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/_nroff.tcl (nroff_postprocess): Followup fixes to
+ * mpformats/fmt.nroff: bugs found in branch "bug-3601370-td",
+ * pkgIndex.tcl: Missing markup of several nroff directives as
+ * doctools.tcl: such. Version bumped to 1.4.15.
+ * doctools.man:
+
+2013-02-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * changelog.tcl: flatten method added. Extension of for 'sak
+ * changelog.man: review'. Simpler structured output. Bumped
+ version to 1.1.
+
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2013-01-29 Andreas Kupries <andreask@activestate.com>
+
+ * doctools.man: Bumped version to 1.4.14 for the
+ * doctools.tcl: last change, see below.
+ * pkgIndex.tcl:
+
+2013-01-21 Andreas Kupries <andreask@activestate.com>
+
+ * checker.tcl: Added check to manpage_begin, reject spaces in title.
+ * mpformats/c.msg: Message catalogs extended with new warning
+ * mpformats/de.msg: 'mptitle' for spaces in the manpage title.
+ * mpformats/en.msg: The french catalog contains the english
+ * mpformats/fr.msg: text, and needs a translation.
+
+2012-02-27 Andreas Kupries <aku@hephaistos>
+
+ * tests/text/04: Update the expected the result to match the new
+ actual result. See the 2011-12-13 last-second bugfix in
+ textutil::adjust::undent for the cause.
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-11-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tests/nroff/04: Updated the test outputs to match the changes
+ * tests/nroff/07: introduced by the last two commits, below.
+ * tests/nroff/08:
+
+2011-02-23 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fmt.nroff: Moved the handling of the list nesting
+ * mpformats/_nroff.tcl: level a bit around to be consistent at
+ * checker.tcl: both begin and end. Fixed the long-standing
+ indentation bug where the rendered text got unindented after a
+ nested list or example. We simply had to start indented
+ paragraphs, via .IP after them, and for each paragraph in a list
+ element. This needed the consistent nesting level to correctly
+ know when to emit the commands. And while this may generate
+ empty paragraphs, these can be removed easily in the
+ post-processing.
+ * doctools.tcl: Bumped version to 1.4.13.
+ * doctools.man:
+ * pkgIndex.tcl:
+
+2011-02-23 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/_nroff.tcl (nr_ce): [Bug 3167244]: Added \n after .CE
+ to prevent misformatting when examples are used in a sentence
+ without placement on a separate line of input.
+ * doctools.tcl: Bumped version to 1.4.12.
+ * doctools.man:
+ * pkgIndex.tcl:
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2011-01-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.test: Updated for the changes made per the entry below.
+
+2010-11-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.man: Bumped to version 1.4.11, fixing issues with
+ * doctools.tcl: resolution of relative include paths. -file had
+ * pkgIndex.tcl: overloaded semantics, used for both source paths
+ (include resolution) and destination paths (HTML relative
+ links). Added new option -ibase as primary for include
+ resolution, using -file only as fallback anymore.
+
+2010-09-15 Andreas Kupries <andreask@activestate.com>
+
+ * tests/nroff/04: [Bug 3058654] and last entry. Updated
+ * tests/nroff/08: the affected testcases.
+
+2010-09-07 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fmt.nroff: [Bug 3058654]: Changed formatting of
+ * mpformats/_nroff.tcl: examples to .CS/.CE.
+
+2010-09-07 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fmt.nroff: [Bug 3058654]: Added code compacting
+ whitespace in various strings used for nroff comments and NAME
+ section.
+
+2010-07-06 Andreas Kupries <andreask@activestate.com>
+
+ * checker.tcl: [RFE 2915921] Accepted the RFE, adding
+ * mpformats/fmt.wiki: commands to portably write em- and
+ * mpformats/fmt.text: en-dashes. Bumped version to 1.4.10.
+ * mpformats/fmt.latex:
+ * mpformats/fmt.tmml:
+ * mpformats/fmt.html:
+ * mpformats/fmt.nroff:
+ * mpformats/fmt.null:
+ * doctools.man:
+ * pkgIndex.tcl:
+ * doctools.tcl:
+
+2010-06-17 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fmt.html: Tweaked formatting of images when no
+ * mpformats/fmt.latex: data was found. Especially for HTML
+ * mpformats/fmt.text: accept http and ftp uris and format
+ * mpformats/fmt.wiki: them as links, allowing the embedding
+ * mpformats/fmt.nroff: of images without requiring a local
+ * doctools.man: file. Bumped version to 1.4.9
+ * pkgIndex.tcl:
+ * doctools.tcl:
+
+2010-06-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.tcl: Extended the plugin API to the image map to
+ * mpformats/fmt.nroff: allow querying the image data instead of
+ * mpformats/fmt.wiki: its paths. Fixed the nroff, wiki, and text
+ * mpformats/fmt.text: plugins to use this new command, as they
+ * doctools_plugin_apiref.man: are in a restricted environment
+ * doctools.man: which does not allow them to 'open' files on their
+ * pkgIndex.tcl: own. Documented the command now. nroff further
+ extended to accept .txt images as well as .pic, and do a bit of
+ formatting of their own to make them fit (.nf/.fi). Version
+ bumped to 1.4.8.
+
+ * ../../apps/dtplite: Fixes for problems with the handling of
+ relative paths. Version bumped to 1.0.2.
+
+2010-06-08 Andreas Kupries <andreask@activestate.com>
+
+ * ../../apps/dtplite: Fix the min version requirements.
+
+ * checker.tcl: Added 'image' command to doctools, and the
+ * doctools.man: various backends. Bumped to version 1.4.7.
+ * doctools_lang_cmdref.man: Images are specified through
+ * doctools.tcl: symbolic name. Tools like dtp(lite) specify
+ * pkgIndex.tcl: possible mappings, and the backends select
+ * mpformats/fmt.html: a proper variant (png, jpeg, text, ...)
+ * mpformats/fmt.latex: or fallback to a 'here should be this
+ * mpformats/fmt.nroff: image' markup, if no proper variant
+ * mpformats/fmt.null: for them was found.
+ * mpformats/fmt.wiki:
+ * mpformats/fmt.text: Future/Todo - Recognize uris as symbolic
+ * mpformats/_html.tcl: name and treat as external reference.
+ * ../../apps/dtplite:
+
+ * docidx.man: Added missing dt_package and restricted 'file'
+ * docidx.tcl: support to doctool::toc and doctools::idx. Versions
+ * doctoc.man: bumped to 1.1.3 and 1.0.4.
+ * doctoc.tcl:
+ * pkgIndex.tcl:
+
+ * mpformats/toc.text: Fixed command names using various textutil
+ * mpformats/idx.text: functionality.
+
+2010-02-05 Andreas Kupries <andreask@activestate.com>
+
+ * checker.tcl: Gave the checking layer access to dt_file,
+ * doctools.tcl: and extended it to provide the file name
+ * doctools.man: as part of the location information in
+ * doctools.test: errors and warnings. Bumped version to
+ * pkgIndex.tcl: 1.4.6.
+
+2010-02-04 Andreas Kupries <andreask@activestate.com>
+
+ * doctools.tcl: Extended with new plugin API command
+ * doctools.man: [dt_mainfile], which always returns
+ * doctools_plugin_apiref.man: the toplevel file currently
+ * pkgIndex.tcl: processed, in contrast to [dt_file] which
+ returns the currently processed file, which may be included.
+ Bumped version to 1.4.5.
+
+ * mpformats/fmt.html: Fixed bug in inter-document link generation
+ caused by computing links relative to the active (include) file,
+ instead of the toplevel.
+
+2009-12-09 Andreas Kupries <andreask@activestate.com>
+
+ * doctools.tcl: Bumped version to 1.4.4.
+ * doctools.man:
+ * pkgIndex.tcl:
+
+ * mpformats/fmt.html: Extended to support the engine variable
+ * doctools.test: 'raw' (boolean flag). The default is off, causing
+ the engine to generate the full html, as usual. If set, the
+ engine will generate only the HTML normally between the <body>
+ and </body> tags, excluding these two tags. This allows for
+ easier embedding of the result in other HTML. Thanks to Jos
+ DeCoster for the idea. Extended the testsuite to cover raw mode
+ results.
+
+ * mpformats/fmt.wiki: Thanks to Jos DeCoster for updating the Wiki
+ * tests/wiki/00: formatter to generate text making better use of
+ * tests/wiki/01: Wikit's new features, and also fixing bugs in the
+ * tests/wiki/02: use of the older features. Updated test results.
+ * tests/wiki/03:
+ * tests/wiki/04:
+ * tests/wiki/05:
+ * tests/wiki/06:
+ * tests/wiki/07:
+ * tests/wiki/08:
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-07-21 Andreas Kupries <andreask@activestate.com>
+
+ * doctools.tcl: Fixed @mdgen instructions, added forgotten
+ ownership reference to man.macros. See ActiveState Bug 83781,
+ reported by Nicolas Castagne. Bumped to version 1.4.3.
+ * docidx.tcl: See above, bumped to version 1.0.3.
+ * doctoc.tcl: See above, bumped to version 1.1.2.
+
+2009-03-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * checker.tcl (manpage): Added new markup command for document
+ references (manpage). For now formatted like a 'term'.
+
+ * doctools.tcl: Fixed handling of include files. Search relative
+ * doctools.man: to processed file, and run the command through
+ 'subst' first, to resolve embedded commands (vset uses). Bumped
+ to version 1.4.2.
+
+ * docidx.tcl: Fixed handling of include files. Search relative
+ * docidx.man: to processed file, and run the command through
+ 'subst' first, to resolve embedded commands (vset uses). Bumped
+ to version 1.0.2
+
+ * doctoc.tcl: Fixed handling of include files. Search relative
+ * doctoc.man: to processed file, and run the command through
+ 'subst' first, to resolve embedded commands (vset uses). Bumped
+ to version 1.1.1.
+
+ * docidx_lang_syntax.man: Added notes about command arguments.
+
+2009-02-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * checker_toc.tcl: TOC language extended to allow empty tocs, empty
+ * docidx.test: divisions, and the mixing of items and divisions at
+ * doctoc.tcl: every level. Extended testsuite. Updated documentation.
+ * doctoc.test: Bumped version to 1.1. Fixed bug in the documentation
+ * doctoc_lang_cmdref.man: of markup command 'item' (arguments were
+ * doctoc_lang_intro.man: missing).
+ * doctoc_lang_syntax.man:
+ * doctoc.man:
+ * pkgIndex.tcl:
+
+2009-02-10 Andreas Kupries <andreask@activestate.com>
+
+ * checker_idx.tcl (index_end): Allow empty index (no keys).
+ * docidx.tcl: Bumped package to vrsion 1.0.1. Updated the
+ * docidx.test: documentation, where not already in alignment.
+ * docidx_lang_intro.man: Extended testsuite. Fixed small typo
+ * docidx_lang_syntax.man: orthogonal to this change.
+ * pkgIndex.tcl: Fixes [SF Tcllib Bug 2557107].
+
+2009-01-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * docidx.tcl: Extended the plugin APIs for all formats with a new
+ * docidx_plugin_apiref.man: command "dt_read" to read a file's
+ * doctoc.tcl: contents into a plugin. Modified the nroff plugins
+ * doctoc_plugin_apiref.man: to inline the man.macros file into
+ * doctools.tcl: their result instead of generating a
+ * doctools.test: '.so man.macros' command. Stuart Cassoff
+ * doctools_plugin_apiref.man: <stwo@users.sourceforge.net> did the
+ * mpformats/_nroff.tcl: work and provided the patches as part of
+ * mpformats/fmt.nroff: his effort on making a Tcllib OpenBSD port.
+ * mpformats/idx.nroff:
+ * mpformats/toc.nroff:
+
+2009-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * checker.tcl: Fixed bug in handling 'category' command. Bumped
+ * doctools.tcl: version to 1.4.1
+ * doctools.man:
+ * pkgIndex.tcl:
+
+ * changelog.man: Added 'category' information to all manpages.
+ * cvs.man:
+ * docidx.man:
+ * docidx_intro.man:
+ * docidx_lang_cmdref.man:
+ * docidx_lang_faq.man:
+ * docidx_lang_intro.man:
+ * docidx_lang_syntax.man:
+ * docidx_plugin_apiref.man:
+ * doctoc.man:
+ * doctoc_intro.man:
+ * doctoc_lang_cmdref.man:
+ * doctoc_lang_faq.man:
+ * doctoc_lang_intro.man:
+ * doctoc_lang_syntax.man:
+ * doctoc_plugin_apiref.man:
+ * doctools.man:
+ * doctools_intro.man:
+ * doctools_lang_cmdref.man:
+ * doctools_lang_faq.man:
+ * doctools_lang_intro.man:
+ * doctools_lang_syntax.man:
+ * doctools_plugin_apiref.man:
+ * mpexpand.man:
+
+2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11.1 ========================
+ *
+
+2008-12-01 Andreas Kupries <andreask@activestate.com>
+
+ * doctools.tcl: New command in doctools language is extended API.
+ * doctools.man: Bumped minor version, to 1.4.
+ * pkgIndex.tcl:
+
+2008-11-26 Andreas Kupries <andreask@activestate.com>
+
+ * api.tcl: Extended doctools language with a 'category'
+ * checker.tcl: command. This allows manpages to provide
+ * doctools.tcl: a category string, like they already
+ * doctools_lang_cmdref.man: provide keywords and see-also
+ * doctools_lang_syntax.man: references. Updated all engines
+ * mpformats/_common.tcl: to handle the command in some way.
+ * mpformats/fmt.html: Bumped package version to 1.3.6.
+ * mpformats/fmt.latex: Needed: Some tests to demo the
+ * mpformats/fmt.list: handling of 'category'.
+ * mpformats/fmt.nroff:
+ * mpformats/fmt.null:
+ * mpformats/fmt.text:
+ * mpformats/fmt.tmml:
+ * mpformats/fmt.wiki:
+ * doctools.test:
+ * tests/list/00:
+ * tests/list/01:
+ * tests/list/02:
+ * tests/list/03:
+ * tests/list/04:
+ * tests/list/05:
+ * tests/list/06:
+ * tests/list/07:
+ * tests/list/08:
+
+2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11 ========================
+ *
+
+2008-07-08 Andreas Kupries <andreask@activestate.com>
+
+ * changelog.man: Bumped the packages to version 1. They have
+ * changelog.tcl: been on 0 long enough.
+ * cvs.man:
+ * cvs.tcl:
+ * docidx.man:
+ * docidx.tcl:
+ * doctoc.man:
+ * doctoc.tcl:
+
+2008-05-16 Andreas Kupries <andreask@activestate.com>
+
+ * checker.tcl (sectref): The way it was documented confused me and
+ * doctools.tcl: the last change flipped identifying and text
+ * doctools.man: argument, changing the meaning of sectref. Should
+ * pkgIndex.tcl: have seen that quicker with how comm/comm_wire.man
+ had to be updated. Fixed this now, restoring the proper
+ order. Rewrote docs as well for better understanding. Bumped to
+ version 1.3.5.
+
+ * ../comm/comm_wire.man: Fixed the sectref argument order issues.
+ * ../rcs/rcs.man: Fixed the sectref argument order issues.
+ * ../snit/snitfaq.man: Fixed the sectref argument order issues.
+ * ../tie/tie.man: Fixed the sectref argument order issues.
+
+2008-05-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.tcl: Bumped version to 1.3.4.
+ * doctools.man:
+ * pkgIndex.tcl:
+
+ * checker.tcl: Reworked the (sub)section handling, enabled the
+ * doctools_lang_cmdref.man: documentation writer to label
+ (sub)sections with logical names and use these in references.
+ Automatic logical names are improved, taking the current section
+ into account, making for a better ambiguity check. References
+ are now better as well. Backends are given unique physical
+ (sub)section ids. Added a new formatting command
+ 'sectref-external' for references to (sub)sections outside of
+ the current document, to disable checking, and documented it.
+
+ * docidx_plugin_apiref.man: Fixed the external section references
+ * doctoc_plugin_apiref.man: in the manpages to prevent false warnings.
+ * doctools_plugin_apiref.man:
+
+ * mpformats/c.msg: Message catalogs extended with new warning
+ * mpformats/de.msg: 'missingsect' for apparently dangling
+ * mpformats/en.msg: (sub)section references.
+ * mpformats/fr.msg:
+
+ * mpformats/fmt.html: Updated the backends for the changes in the
+ * mpformats/fmt.latex: frontend/backend API, and updated testsuite
+ * mpformats/fmt.nroff: results.
+ * mpformats/fmt.text:
+ * mpformats/fmt.tmml:
+ * mpformats/fmt.wiki:
+ * mpformats/_common.tcl:
+ * tests/latex/00:
+ * tests/latex/01:
+ * tests/latex/02:
+ * tests/latex/03:
+ * tests/latex/04:
+ * tests/latex/05:
+ * tests/latex/06:
+ * tests/latex/07:
+ * tests/latex/08:
+ * tests/tmml/00:
+ * tests/tmml/01:
+ * tests/tmml/02:
+ * tests/tmml/03:
+ * tests/tmml/04:
+ * tests/tmml/05:
+ * tests/tmml/06:
+ * tests/tmml/07:
+ * tests/tmml/08:
+ * tests/html/00:
+ * tests/html/01:
+ * tests/html/02:
+ * tests/html/03:
+ * tests/html/04:
+ * tests/html/05:
+ * tests/html/06:
+ * tests/html/07:
+ * tests/html/08:
+
+ * mpformats/_nroff.tcl: Modified the nroff backend to convert
+ * tests/nroff/03: (sub)section titles into uppercase in the
+ output. Updated testsuite results.
+
+ * checker.tcl: Reworked the (sub)section handling, enabled the
+ documentation writer to label (sub)sections with logical names
+ and use these in references. Automatic logical names are
+ improved, taking the current section into account, making for a
+ better ambiguity check. References are now better as well.
+ Backends are given unique physical (sub)section ids.
+
+ * mpformats/c.msg: Message catalogs extended with new warning
+ * mpformats/de.msg: 'missingsect' for apparently dangling
+ * mpformats/en.msg: (sub)section references.
+ * mpformats/fr.msg:
+
+ * mpformats/fmt.html: Updated backends for the changes in the
+ * mpformats/fmt.latex: frontend/backend API. Nroff backend
+ * mpformats/fmt.nroff: additionally modified to automatically
+ * mpformats/fmt.text: convert (sub)section titles into uppercase.
+ * mpformats/fmt.tmml:
+ * mpformats/fmt.wiki:
+ * mpformats/_common.tcl:
+ * mpformats/_nroff.tcl:
+
+ * mpformats/fmt.html (XrefLink): Now checking for and suppressing
+ * doctools.tcl: self-referential links from the current output
+ * doctools.man: file to itself exactly. Bumped version to 1.3.3.
+ * pkgIndex.tcl:
+
+2008-04-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/fmt.html: Gave title h1 tag a class. Put a div around
+ * tests/html/*: the content of the synopsis section. Removed the
+ div around examples. Their pre tag has a class, that is enough.
+ Added default CSS styling to the code. Its definitions are
+ derived from the CSS Joe English <jenglish@users.sourceforge.net>
+ uses for the HTML generated by his TMML converter. Nice and
+ simple. Thank you.
+
+ * tests/man/08: All possible list types are in testcase 5 already.
+ * tests/desc/08: Changed to demo all the commands in one file.
+ * tests/html/08: This makes trying out styles for the HTML easier too
+ * tests/latex/08: as everything can looked at in one file.
+ * tests/list/08:
+ * tests/nroff/08:
+ * tests/null/08:
+ * tests/text/08:
+ * tests/tmml/08:
+ * tests/wiki/08:
+
+ * mpformats/fmt.html: Changed example formatting, removed the nested
+ * tests/html/*: table structure. Changed toc and synopsis
+ formatting to be more sematical, using classed unordered lists.
+ Added classes to the list formatting. Removed hardwired
+ linebreaks between last list element and end of list. Replaced
+ linebreaks in list items with proper paragraph formatting. Fixed
+ initialization error causing spurious para_close at the
+ beginning. Added foundation for an internal style-sheet. No
+ definitions yet however.
+
+2008-04-26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tests/man/08: Added test demonstrating all possible list types.
+ * tests/desc/08:
+ * tests/html/08:
+ * tests/latex/08:
+ * tests/list/08:
+ * tests/nroff/08:
+ * tests/null/08:
+ * tests/text/08:
+ * tests/tmml/08:
+ * tests/wiki/08:
+
+2008-04-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tests/man/02: Added see_also and keyword references to this
+ * tests/html/02: example. Updated all changed results.
+ * tests/latex/02:
+ * tests/list/02:
+ * tests/nroff/02:
+ * tests/text/02:
+ * tests/tmml/02:
+ * tests/wiki/02:
+
+2008-04-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/fmt.html: Modified to put sections and subsections
+ * mpformats/_html.tcl: into divisions a CSS can lock onto. Changed
+ * tests/html/*: to properly close paragraphs, sections, and sub-
+ sections. Changed to remove empty paragraphs, and empty lines.
+ Put the whole body into a division. Put text marked up as
+ optional into a span. Put section references into a span. Put
+ examples into a division. Some general cleanup of the internals.
+
+2008-04-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tests/*/06: Extended for nested lists.
+ * tests/*/07: 2nd input and results for nested lists.
+ * mpformats/_nroff.tcl (nr_vspace): Added newlines to output for
+ proper formatting of text coming after it.
+
+ * tests/syntax/e_*: Additional input and result files, completing
+ * tests/syntax/r_*: the list errors. Ditto the example commands,
+ sectref, and the commands for the semantic categories.
+
+2008-04-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.test: Extended with loop to test response to the various
+ * tests/syntax/e_*: syntax errors we may find in doctools files, plus
+ * tests/syntax/r_*: first set of input files and error results.
+ * checker.tcl: Modified errors for commands which are allowed
+ everywhere in the header section since the extended syntax came
+ into effect.
+
+2008-04-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.test: Fixed [Bug 1942472], reported by Michael
+ * tests/latex/00: Schlenker, in made with the new test cases.
+ * tests/latex/01: Now mapping the name of the user running
+ * tests/latex/02: the tests around in the expected and
+ * tests/latex/03: actual results as well. Modified the
+ * tests/latex/04: expected results for the one backend
+ * tests/latex/05: affected by the change.
+ * tests/latex/06:
+
+2008-04-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.test: Added the remaining backends to the list of
+ backends checked.
+
+ * tests/tmml/00: Expected results for TMML backend.
+ * tests/tmml/01:
+ * tests/tmml/02:
+ * tests/tmml/03:
+ * tests/tmml/04:
+ * tests/tmml/05:
+ * tests/tmml/06:
+
+ * tests/text/00: Expected results for TEXT backend.
+ * tests/text/01:
+ * tests/text/02:
+ * tests/text/03:
+ * tests/text/04:
+ * tests/text/05:
+ * tests/text/06:
+
+ * tests/wiki/00: Expected results for WIKI backend.
+ * tests/wiki/01:
+ * tests/wiki/02:
+ * tests/wiki/03:
+ * tests/wiki/04:
+ * tests/wiki/05:
+ * tests/wiki/06:
+
+ * tests/latex/00: Expected results for LATEX backend.
+ * tests/latex/01:
+ * tests/latex/02:
+ * tests/latex/03:
+ * tests/latex/04:
+ * tests/latex/05:
+ * tests/latex/06:
+
+ * tests/desc/00: Expected results for DESC backend.
+ * tests/desc/01:
+ * tests/desc/02:
+ * tests/desc/03:
+ * tests/desc/04:
+ * tests/desc/05:
+ * tests/desc/06:
+
+ * tests/list/00: Expected results for LIST backend.
+ * tests/list/01:
+ * tests/list/02:
+ * tests/list/03:
+ * tests/list/04:
+ * tests/list/05:
+ * tests/list/06:
+
+ * tests/null/00: Expected results for NULL backend.
+ * tests/null/01:
+ * tests/null/02:
+ * tests/null/03:
+ * tests/null/04:
+ * tests/null/05:
+ * tests/null/06:
+
+ * tests/html/00: Replaced $ I d $ placeholder with @ID@. See
+ * tests/html/01: doctools.test.
+ * tests/html/02:
+ * tests/html/03:
+
+ * tests/man/04: Replaced placeholder text with actual input to
+ * tests/man/05: run through the formatting backends.
+ * tests/man/06:
+
+ * tests/html/04: Made results current. The handling of
+ * tests/html/05: backslashes is known to be wrong, noted
+ * tests/html/06: other ugliness.
+
+ * tests/nroff/04: Made results current, fixed some formatting
+ * tests/nroff/05: problems, see below.
+ * tests/nroff/06:
+
+ * mpformats/fmt.nroff (fmt_arg_def, fmt_opt_def): Added newlines
+ to output for proper formatting of elements in argument and
+ option lists.
+
+ * doctools.test: Fix handling of $ I d $ placeholder used in input
+ files and expected results. Extended to handle errors, to catch
+ problems other than differences between expected and actual
+ results. Ignore CVS subdirectory and handle missing files for
+ expected results.
+
+2008-03-31 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.test: Added tests to invoke the backends on a series of
+ input files and check the results against expectations.
+ * tests/man/00: First set of input files, and expected output for
+ * tests/man/01: the html and nroff backends.
+ * tests/man/02:
+ * tests/man/03:
+ * tests/man/04:
+ * tests/man/05:
+ * tests/man/06:
+ * tests/html/00:
+ * tests/html/01:
+ * tests/html/02:
+ * tests/html/03:
+ * tests/html/04:
+ * tests/html/05:
+ * tests/html/06:
+ * tests/nroff/00:
+ * tests/nroff/01:
+ * tests/nroff/02:
+ * tests/nroff/03:
+ * tests/nroff/04:
+ * tests/nroff/05:
+ * tests/nroff/06:
+
+2008-03-12 Andreas Kupries <andreask@activestate.com>
+
+ * checker.tcl (widget): Fixed bad call propagation.
+
+2008-03-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.tcl: Code cleanup, giving all upvar commands an
+ * docidx.tcl: explicit level argument. Bumped all version
+ * doctoc.tcl: numbers by one patchlevel. doctools -> 1.3.2,
+ * cvs.tcl: doctools::toc -> 0.3.1, doctools::idx -> 0.3.1,
+ * changelog.tcl: doctools::cvs -> 0.1.2,
+ * pkgIndex.tcl: doctools::changelog -> 0.1.2
+ * docidx.man:
+ * doctoc.man:
+ * doctools.man:
+ * cvs.man:
+ * changelog.man:
+
+2007-09-25 Andreas Kupries <andreask@activestate.com>
+
+ * doctools.tcl: Extended processor to pass the pass number to the
+ * checker.tcl: checker layer as well. Modified the checker layer
+ * pkgIndex.tcl: to suppress generation of warnings in all but the
+ * doctools.man: first pass, to avoid replication. Bumped version
+ to 1.3.1. This fixes [SF Tcllib Bug 1800413].
+
+ * mpformats/fmt.nroff: Fixed argument swap in fmt_arg_def, fixing
+ [SF Tcllib Bug 1800420].
+
+ * mpformats/fmt.html: Handled [SF Tcllib Bug 1800408] and [SF
+ Tcllib Bug 411], removing superfluous whitespace around link
+ text and adding more class names to semantic markup.
+
+2007-09-20 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fmt.html: Added closing of paragraphs per the request
+ in [SF Tcllib Bug 1798427]. Tis more complicated. Paragraphs
+ inside of list elements are not yet closed.
+
+ * mpformats/fmt.html: Reworking handling of list items a bit to
+ properly close the dt, dd, and li tags. Requested by [SF Tcllib
+ Bug 1798427].
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-20 Andreas Kupries <andreask@activestate.com>
+
+ * doctools.tcl: Bumped versions to 1.3 and 0.3 respectively to
+ * docidx.tcl: reflect the extended syntax and bugfixes listed
+ * doctoc.tcl: below.
+ * doctools.man:
+ * docidx.man:
+ * doctoc.man:
+ * pkgIndex.tcl:
+
+2007-08-02 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fmt.latex: Further reworking of the backend internals
+ for proper quoting of TeX special characters, prevention of
+ double-quoting, and markup of wanted special characters. Further
+ removed the use of 'quote' environments. Not needed for the
+ formatting and its use restricts the nesting of lists to three
+ levels. Without we can nest seven levels. Final fixes for
+ [Tcllib SF Bug 1766381].
+
+ * mpformats/fmt.text: Fixed handling of 'cmd_def'.
+ * mpformats/fmt.tmml: Fixed handling of nested lists.
+ * mpformats/fmt.latex: Fixed handling of list_end, was not updated
+ to the new list type codes.
+ * mpformats/fmt.latex: Fixed handling of ^ character. Has to be
+ escaped in regular text. Fixed handling of keywords and
+ references (see also). May contain special character in need of
+ escaping. Quote backslashes in paths.
+ Fixes for [Tcllib SF Bug 1766381.]
+
+2007-08-01 Andreas Kupries <andreask@activestate.com>
+
+ * doctools.test: Updated test 8.4 for changes in the formatting of
+ warnings.
+
+2007-03-20 Andreas Kupries <andreask@activestate.com>
+
+ * apps/dtplite: Added a block of meta data.
+
+2007-03-20 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fmt.wiki: Added MD pragma excluding a bogus dependency
+ from consideration.
+
+2007-03-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctoc.tcl: Extended MD pragmas declaring the ownership of
+ * docidx.tcl: various non-code files.
+ * doctools.tcl:
+
+ * support/devel/sak/doc/doc.tcl: Modified to print warnings even
+ if processed was stopped by an error.
+
+ * mpformats/c.msg: Added messages for a set of newly deprecated
+ * mpformats/de.msg: commands and list types. Added proper umlauts
+ * mpformats/en.msg: to the german messages.
+ * mpformats/fr.msg:
+
+ * doctools.tcl: Added a plugin API command (dt_where), providing
+ information about the current location, to provide location data
+ to warnings.
+
+ * checker_toc.tcl: Language change (doctoc, docidx). Comments in
+ * checker_idx.tcl: the input are now swallowed by the checker
+ layer and not propagated to the backend anymore.
+
+ * checker.tcl: Language changes.
+ -- Comments are swallowed, backends do not see them anymore.
+ -- 'require'ments an now go everywhere in the header, not only
+ after the 'desc'riptions.
+ -- Warnings now have location information.
+ -- The list types 'bullet', 'arg', 'opt', 'cmd', and 'tkoption'
+ are now deprecated. They are replaced by 'itemized',
+ 'arguments', 'options', 'commands', and 'tkoptions', and their
+ short forms 'items', 'args', 'opts', and 'cmds'.
+ -- 'para' can now be used inside of lists. Conversely 'nl' works
+ outside of lists too. The two commands are identical now, and
+ 'nl' is deprecated.
+ -- The list entry command 'lst_item' has been deprecated,
+ replaced by 'def'. Additionally the possible misspellings
+ 'list_item', 'listitem', and 'lstitem' of the old command are
+ recognized now too, albeit also considered to be deprecated.
+ -- The list entry command 'bullet' is deprecated, replaced
+ 'item'.
+ -- The commands 'see_also' and 'keywords' can now go anywhere in
+ the document, not only after the header.
+
+ Note that everything which was made deprecated is still accepted
+ as valid input, however their use does cause the generation of
+ warnings. This means that the language after the changes is a
+ proper superset of the language before it. Old documents can be
+ processed just fine with the new code.
+
+ * mpformats/fmt.html: Use the new list types for translation.
+ * mpformats/fmt.latex:
+ * mpformats/fmt.text:
+ * mpformats/fmt.tmml:
+
+ * mpformats/fmt.nroff: Add a para when closing an inner list.
+
+ * mpformats/idx.html: Rewritten to be single-pass, defering output
+ until the index is closed. Changed to ensure that keywords are
+ printed alpha-sorted (lsort -dict). Added navigation bar and
+ sectioning of the index.
+
+ * apps/dtplite: Added a format 'validate' as alias for 'null',
+ * apps/dtplite.man: both of these now do not require an output
+ specification anymore. Added the collection and printing of
+ warnings. Replaced the homegrown commands for the reading and
+ writing of files with calls to fileutil commands. Now processing
+ input files in alphabetical order. Put common code for doctoc
+ and docidx generation into a small set of commands. toc and idx
+ are now sorted by description/keyword, output is column-aligned.
+ The doc* output is saved, to serve as examples. Document titles
+ are now cross-referencable via 'term', allowing direct links
+ between documents. Comments about internals added. Documentation
+ updated for the new functionality, and fixed all warnings due to
+ use of deprecated commands and list types. Added a section on
+ how to give feedback.
+
+ * cvs.man: Fixed all warnings due to use of deprecated commands
+ * changelog.man: and list types, tweaked the titles, and added
+ sections about how to give feedback.
+
+ * docidx.man: Significant rewrites for better language, better
+ * doctoc.man: referencing of introductory documents. Tweaked the
+ * doctools.man: titles, and added sections about how to give
+ feedback.
+
+ * docidx_api.man: *** REMOVED *** old documentation about the
+ * docidx_fmt.man: languages and plugin APIs.
+ * doctoc_api.man:
+ * doctoc_fmt.man:
+ * doctools_api.man:
+ * doctools_fmt.man:
+
+ * docidx_intro.man: *** ADDED *** new documentation about the
+ * docidx_lang_cmdref.man: languages and plugin APIs, with basic
+ * docidx_lang_faq.man: introductions, cross-referencing to
+ * docidx_lang_intro.man: related documents, further readings,
+ * docidx_lang_syntax.man: introduction by example, first
+ * docidx_plugin_apiref.man: beginning of faqs.
+ * doctoc_intro.man:
+ * doctoc_lang_cmdref.man:
+ * doctoc_lang_faq.man:
+ * doctoc_lang_intro.man:
+ * doctoc_lang_syntax.man:
+ * doctoc_plugin_apiref.man:
+ * doctools_intro.man:
+ * doctools_lang_cmdref.man:
+ * doctools_lang_faq.man:
+ * doctools_lang_intro.man:
+ * doctools_lang_syntax.man:
+ * doctools_plugin_apiref.man:
+
+2006-10-25 Andreas Kupries <andreask@activestate.com>
+
+ * doctools.test: Added an explicit LANG=C setting to the tests.
+ * docidx.test: At least OS X needs the setting to behave correctly.
+ * doctoc.test: Thanks to Gustaf Neumann for the report.
+
+2006-10-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.test: Rewritten to use new features for handling the
+ * docidx.test: environment.
+ * doctoc.test:
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-10-02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.test: Made the testsuite robust against locale
+ * doctoc.test: settings in the environment. The tests
+ * docidx.test: assume the default locale (LANG=C).
+
+2006-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * doctools.man: Bumped version to 1.2.1
+ * doctools.tcl:
+ * pkgIndex.tcl:
+
+2006-08-10 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/_text.tcl: Replaced textutil with the exact packages
+ * mpformats/fmt.text: needed, and adjusted all callers to use the
+ long command names.
+
+2006-06-16 Andreas Kupries <andreask@activestate.com>
+
+ * ../../apps/dtplite: Still found a xref link bug in the -merge
+ code path. The per-module toc had the wrong links. Added code to
+ generate and set a proper file mapping for these tocs. Removed
+ MapLink and switched to the new command "fileutil::relativeUrl".
+
+2006-03-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/_nroff.tcl: Do not double-quote (sub)section titles if
+ they do not contain whitespaces.
+
+2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.test: Fixed use of duplicate test names
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * docidx.test: More boilerplate simplified via use of test support.
+ * doctoc.test:
+ * doctools.test:
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * docidx.test: Hooked into the new common test support code.
+ * doctoc.test:
+ * doctools.test:
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-10-03 Andreas Kupries <andreask@activestate.com>
+
+ * checker.tcl: Added code checking for ambiguities in section
+ * mpformats/c.msg: and subsection titles. It causes warnings.
+ * mpformats/en.msg: Extended the message catalogs with strings for
+ * mpformats/de.msg: the new warning.
+ * mpformats/fr.msg:
+
+2005-06-17 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/_common.tcl (c_sectionId): Converting quotes into
+ underscores. Fixes [SF Tcllib Bug 1220089].
+
+2005-06-06 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fr.msg: Fixed [Tcllib SF Bug 1213636], reported by
+ <sarnold75@users.sourceforge.net>, by removing the incorrect
+ english strings preceding the french ones.
+
+2005-04-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.test: Testsuite package requirements fixed to ensure
+ * docidx.test: use of local packages.
+ * doctoc.test:
+
+ * doctools.tcl: Typo police.
+ * docidx.tcl:
+ * doctoc.tcl:
+
+2005-02-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/_nroff.tcl: Fixed problem with comment
+ handling. Before the fix we could generate output where nroff
+ would misinterpret a string in apostrophes at the beginning of a
+ line as comment. Regular comments now have the special \1
+ quoting for markup.
+
+ * fmt.nroff: Fixed list processing. The commands stating list
+ items needed newlines to ensure proper separation if the input
+ has text immediately following the command, and not on the next
+ line. Superfluous newlines coming from text stating in the next
+ line is automatically excised during post-processing.
+
+2005-01-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/_nroff.tcl: Extended the post processing to regularize
+ confusing *roff formatting at the beginning of lines. This fixes
+ Tcllib SF Bug 1094294, which was reported by Rolf Ade
+ <pointsman@users.sourceforge.net>.
+
+2005-01-11 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fmt.nroff: Fixed bad nroff formatting for examples
+ * mpformats/_nroff.tcl: with explicit start/end commands.
+
+2004-11-01 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fmt.html (fmt_namespace): Added HTML backend code for
+ the namespace command.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-09-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/_text.tcl: Fixed expr'essions without braces.
+
+2004-09-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/fmt.nroff: Removed superfluous nr_rst calls inserted
+ at the end of a command, by the commands 'call', and 'usage'.
+
+2004-07-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/_common.tcl: Made section references
+ * mpformats/fmt.html: insensitive to case of
+ * mpformats/fmt.latex: the refering text. Also
+ * mpformats/fmt.nroff: now allowing an optional
+ * mpformats/fmt.text: label to the reference
+ * mpformats/fmt.tmml: a different text than
+ * mpformats/fmt.wiki: the section title. Updated
+ * doctools_fmt.man: the format and api specifi-
+ * doctools_api.man: cations.
+ * checker.tcl:
+
+2004-07-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/idx.html: Changed index table to use top alignment.
+
+ * doctools.man: Full overhaul of the documentation
+ * doctools_api.man: pertaining to doctools, format, engine
+ * doctools_fmt.man: api, and framework package.
+
+ * docidx_fmt.man: Typo fixes.
+ * doctoc_fmt.man:
+
+ * doctools.test: Updated to changes in error processing made
+ * doctoc.test: on 2004-07-22 (See below).
+ * docidx.test:
+
+2004-07-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * docidx_fmt.man: More overhaul.
+ * docidx_api.man:
+ * doctoc_fmt.man:
+ * doctoc_api.man:
+ * doctoc.man:
+ * doctools_fmt.man:
+ * doctools_api.man:
+ * doctools.man:
+ * changelog.man:
+ * cvs.man:
+
+2004-07-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * docidx_api.man: Overhaul.
+ * docidx.man:
+
+ * ../../apps/dtplite: Revamped the whole file mapping. Actually
+ ripped it out. Is not needed, the formatting engine does the
+ necessary parts for us, if we feed it the correct -file
+ options. This kills the outstanding bug with xref links.
+
+ * ../../apps/dtplite: Bugfix. Added checks to prevent duplicate
+ entries in the keyword index. Without these checks going through
+ a set of packages twice for merging will create double links for
+ each actual entry. Changed the representation of the index saved
+ between merge invokations to keep the array for the voiding of
+ duplicates around.
+
+ * docidx.man: Overhaul of documentation.
+ * cvs.man:
+ * changelog.man:
+
+2004-07-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ../../apps/dtplite: Reduced error output, show only the message,
+ not the whole stack.
+
+ * doctools.tcl: Changed processing of error messages so that
+ * doctoc.tcl: we don't loose the location information.
+ * docidx.tcl:
+
+2004-07-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools_api.man: Polished the manpages a bit,
+ * ../../apps/dtplite.man: for better cross-referencing.
+
+ * mpformats/fmt.html: Fixed initialization bug regarding
+ cross-references. Added xref matching to the formatting commands
+ 'term' and 'package'. Extended matching to allow multiple
+ prefixes, and to search for the word in lowercase.
+
+2004-07-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * apps/dtplite.man: New application for doctools processing.
+ * apps/dtplite: Supercedes 'mpexpand'. Will be installed.
+
+ * mpformats/idx.html: Added engine parameter 'kwid', allowing the
+ external definition of anchor names for keywords instead of
+ having them generated automatically. Required for persistence
+ when extending an existing index.
+
+ * mpformats/fmt.html: Added eols to the table of contents for
+ better readability of the generated HTML.
+
+ * mpformats/toc.nroff: Fixed bad markup in genration of
+ * mpformats/idx.nroff: tocs and indices. Internal markers
+ were not stripped out.
+
+ * mpformats/toc.wiki:
+ * mpformats/toc.tmml:
+ * mpformats/toc.text:
+ * mpformats/toc.nroff:
+ * mpformats/toc.html:
+ * checker_toc.tcl: Extended 'division_start' formatting command
+ * doctoc_fmt.man: with an optional second argument, a symbolic
+ file reference. Create a link to this file from the division
+ label, if supported by the format. Where not the second argument
+ will be ignored.
+
+2004-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * docidx.man: Fixed [Tcllib SF Bug 985601]. A number
+ * doctoc.man: of options (-copyright) and methods (map,
+ * doctools.man: parameters, setparam) were not documented,
+ * docidx_api.man: nor the engine parameters supported by the
+ * doctoc_api.man: predefined html formatters (header, footer,
+ * doctools_api.man: meta, xref). This is no longer the case.
+
+2004-05-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpexpand.man: Updated reference 'dtformat' to 'doctools_fmt'.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.tcl: Updated version number to distinguish from the
+ * doctools.man: 1.6.1 release.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.tcl: Rel. engineering. Updated version number
+ * doctools.man: of doctools to reflect its changes, to 1.0.2.
+ * pkgIndex.tcl:
+
+2004-05-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.tcl: Fixed a bug in the namespace implementation
+ * checker.tcl: (RFE 943145, see below). Cannot use 'namespace' in
+ checker, it uses msgcat, uses in turn the builtin, overwriting
+ is bad. Have to handle this specially (New name, rewrite to new
+ name) before handing the macro over to the expander.
+
+ * doctools.tcl: Implemented [SF Tcllib RFE 772490] for
+ * checker.tcl: doctools, the addition of 'subsections'
+ * mpformats/_common.tcl: to the language. Updated the main engine,
+ * mpformats/_nroff.tcl: the validator subsystem, and all formatting
+ * mpformats/_text.tcl: engines which are coming with the package.
+ * mpformats/fmt.html: For HTML output subsections are added to
+ * mpformats/fmt.latex: the TOC (See [SF Tcllib RFE 772491] below)
+ * mpformats/fmt.nroff: as well.
+ * mpformats/fmt.null:
+ * mpformats/fmt.text:
+ * mpformats/fmt.tmml:
+ * mpformats/fmt.wiki:
+
+2004-05-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/_text.tcl (SECT): Fixed a small problem in the text
+ generator which was present for ages. Titles of more than one
+ word would have braces around them. Not fatal but also not so
+ nice looking. It was an argument versus argument list
+ thing. Adding a lindex in the proper place gets rid of the
+ additional level of quoting.
+
+2004-05-04 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fmt.html: Implemented [SF Tcllib RFE 772491]. Added
+ the generation of a table of contents at the beginning of the
+ html output for quick jumps to the various parts of the
+ documentation.
+
+ * checker.tcl: Accepted [SF Tcllib RFE 946856], an
+ * doctools_fmt.man: extension of the uri command to allow
+ * doctools.tcl: labels. Updated documentation, added
+ * mpformats/fmt.html: added to highlevel implementation,
+ * mpformats/fmt.latex: updated all predefined formatters.
+ * mpformats/fmt.nroff:
+ * mpformats/fmt.null: Accepted [SF Tcllib RFE 943145] as
+ * mpformats/fmt.text: well, adding a namespace markup.
+ * mpformats/fmt.tmml:
+ * mpformats/fmt.wiki:
+
+ * mpformats/_nroff.tcl: Fixed [SF Tcllib Bug 943146]. Added markup
+ * mpformats/fmt.nroff: protection code like already in use for
+ HTML and XML to handle nroff's special
+ characters, i.e. the backslash properly.
+ Also fixed handling of leading dashes in
+ 'opt_def'.
+
+2004-04-22 Joe English <jenglish@users.sourceforge.net>
+
+ * mpformats/fmt.xml: BUGFIX: "puts stderr" ==> "puts_stderr".
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.test: Fixed problems with Tcl 8.5, the tests were
+ dependent on the order of keys in the result of [array get].
+
+2003-10-21 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fmt.wiki (fmt_manpage_end): Fixed usage of wrong
+ variable ('copyright' was used, should have been 'ct').
+ [Bug 826206].
+
+2003-06-06 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fr.msg: Added french message catalog. Supplied by
+ David Zolli <dzolli@users.sourceforge.net>, aka kroc. This is
+ tracker item [Bug 744149].
+
+2003-05-23 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fmt.nroff (fmt_arg_def, fmt_cmd_def): Analogous errors
+ to fmt_opt_def, see below. Fixed. Reported by David Welton.
+
+2003-05-21 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fmt.nroff (fmt_opt_def): Fixed bug. Called [option],
+ should have been [fmt_option]. Prevented the nroff conversion of
+ the multiplexer documentation. Reported by David Welton.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-01 Andreas Kupries <andreask@activestate.com>
+
+ * checker_toc.tcl: Bug fixes for handling of nested toc divisions.
+
+ * ../../examples/doctools/doctools.idx:
+ * ../../examples/doctools/doctools.toc: Updated to reflect latest
+ changes in the format definitions.
+
+ * doctoc.tcl:
+ * docidx.tcl: Added the package and file ops initially created in
+ doctools.tcl to these packages too, so that their text engines
+ can use 'textutil' too.
+
+ * mpformats/_text.tcl:
+ * mpformats/fmt.text:
+ * mpformats/toc.text:
+ * mpformats/idx.text: Bug fixes.
+
+2003-03-31 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/toc.text:
+ * mpformats/idx.text: New files, toc & index formatting in plain text.
+
+ * mpformats/_text.tcl:
+ * mpformats/fmt.text: Moved processing of plain text into the generic part.
+
+2003-03-31 Andreas Kupries <andreask@activestate.com>
+
+ * cvs.tcl (scanLog): Applied fix for Bug #712951 reported by Joe
+ English <jenglish@users.sourceforge.net>.
+
+2003-03-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.tcl (SetupFormatter): Moved error output command to the
+ front, so that the code loading the engine can use it too, and
+ not only the engine procedures. Added alias for 'file', and a
+ special command which is a shortcut for 'package require' so
+ that engines can load packages. This was required for the plain
+ text engine which makes heavy use of the formatting commands in
+ 'textutil'. Added setup of 'ctopandclear'.
+ (SetupChecker): Added setup of 'ctopandclear'.
+ (Package, Locate): New commands supporting package
+ require. Instead of trying to enable every command in the safe
+ interpreter required for package management we use the standard
+ package commands to locate the index for thr requested package
+ and evaluate just that in the safe interpreter, after
+ temporarily enabling source and load commands.
+
+ * checker.tcl: Added code for debugging, like already present in
+ the files checker_doc*.tcl.
+
+ * mpformats/_text.tcl: Core for plain text engines.
+ * mpformats/fmt.text: New engine. Generates output in plain text.
+
+2003-03-28 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: added 'doctools::cvs' and 'doctools::changelog' to
+ the package index.
+
+ * changelog.man:
+ * changelog.tcl: New. Parsing of ChangeLogs into list structures,
+ merging of multiple logs, conversion into a doctools
+ document. The code for parsing came originally out
+ Makedist_SupportAku, a private package extending my Makedist
+ tool. Documented the code.
+
+ * cvs.tcl (toChangeLog): Using the new textutil commands 'indent'
+ and 'undent' for proper alignment of the comments extracted from
+ the log.
+
+2003-03-27 Andreas Kupries <andreask@activestate.com>
+
+ * cvs.man:
+ * cvs.tcl: Added code to handle parsing and reformatting of cvs
+ log files. Origin of the code the tcl'ers wiki, page
+ http://wiki.tcl.tk/log2changelog. The actual original author is
+ unknown (not listed on the wiki).
+
+2003-03-24 Andreas Kupries <andreask@activestate.com>
+
+ * doctools_fmt.man: Fixed documentation bug #704187 reported by
+ Roy Terry <royterry@users.sourceforge.net>.
+
+2003-03-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * checker.tcl: Fixed incorrect signature of 'usage'.
+ * mpformats/fmt.null: Bugfix in naming of the procedures.
+
+2003-03-13 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/_common.tcl: Fixed initialization error for
+ cross-references causing unwanted suppression (leakage of
+ definitions between multiple pages).
+
+ * doctoc.tcl: Bug fixes in three return statemments.
+ * docidx.tcl: (return -code error string, not return -code string)
+ * doctools.tcl:
+
+2003-03-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/fmt.html: Rewrite handling of [keywords] and
+ * mpformats/fmt.latex: [see_also] to behave like for the TMML
+ * mpformats/fmt.list: formatter: Collect all keywords and
+ * mpformats/fmt.nroff: x-references during the first pass, insert
+ * mpformats/fmt.wiki: the results during the second pass, in
+ [manpage_end]. Ensures that at most one
+ see_also / keyword section is present,
+ ensures uniform order and handling of
+ multiple keyword / see_also commands is
+ now uniform too.
+
+ * examples/doctools.idx: Moved to the new examples/doctools
+ * examples/doctools.toc: directory. Thanks to Larry Virden
+ <lvirden@users.sourceforge.net> for
+ pointing out that the original location
+ in the doctools module violated the
+ principle of collecting examples in a
+ separate directory, instated by
+ myself. Stupid me.
+
+2003-03-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * A examples/doctools.idx: Fairly extensive revamping of the
+ * A examples/doctools.toc: codebase. Added a format for
+ * A mpformats/_idx_common.tcl: indices, formatting engines, a
+ * A mpformats/_toc_common.tcl: package for handling it. Extended
+ * A mpformats/idx.html: all packages to allow engine
+ * A mpformats/idx.nroff: parameters and mapping from
+ * A mpformats/idx.null: symbolic to actual filenames or
+ * A mpformats/idx.wiki: urls. Right now only the HTML
+ * A mpformats/toc.html: engines actually provide
+ * A mpformats/toc.nroff: parameters. Added testsuites for
+ * A mpformats/toc.null: doctoc and docidx. Revamped the
+ * A mpformats/toc.tmml: documentation to cross-reference
+ * A mpformats/toc.wiki: each other better, more uniform in
+ * A api_idx.tcl: structure (not complete), naming of
+ * A api_toc.tcl: the manpages for this module is now
+ * A checker_idx.tcl: uniform. Added examples for doctoc
+ * A checker_toc.tcl: and docidx formats, both in the
+ * A docidx.man: manpages, and as separate files.
+ * A docidx.tcl:
+ * A docidx.test:
+ * A docidx_api.man:
+ * A docidx_fmt.man:
+ * A doctoc.man:
+ * A doctoc.tcl:
+ * A doctoc.test:
+ * A doctoc_api.man:
+ * A doctoc_fmt.man:
+ * A doctools_api.man:
+ * A doctools_fmt.man:
+ * A tocexpand:
+ * M ChangeLog:
+ * M NOTES:
+ * M api.tcl:
+ * M checker.tcl:
+ * M doctools.man:
+ * M doctools.tcl:
+ * M doctools.test:
+ * M pkgIndex.tcl:
+ * M mpformats/_common.tcl:
+ * M mpformats/_nroff.tcl:
+ * M mpformats/c.msg:
+ * M mpformats/de.msg:
+ * M mpformats/en.msg:
+ * M mpformats/fmt.html:
+ * M mpformats/fmt.latex:
+ * M mpformats/fmt.list:
+ * R dtformat.man:
+ * R dtformatter.man:
+
+2003-02-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/fmt.list: Modified to extract all meta information out
+ of the page. Changed the output format. Argument to the
+ 'manpage' command in the output is now a key/value list
+ acceptable to 'array set' instead of a simple list with fixed
+ positions for the various data elements.
+
+2003-02-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctoc.tcl: Specified a new portable format for
+ * api_toc.tcl: writing a table of contents. Wrote a
+ * checker_toc.tcl: package to handle input that format
+ * dtocformat.man: and a number of formatting engines
+ * dtocengine.man: plugging into this package to
+ * mpformats/_toc_common.tcl: generate output in various formats.
+ * mpformats/toc.html: This required additional checker code
+ * mpformats/toc.nroff: and more messages in the message
+ * mpformats/toc.null: catalogs.
+ * mpformats/toc.tmml:
+ * mpformats/toc.wiki:
+ * pkgIndex.tcl:
+ * mpformats/c.msg:
+ * mpformats/en.msg:
+ * mpformats/de.msg:
+ * mpformats/_nroff.tcl:
+
+ * doctools.tcl: Rephrased documentation of SetupChecker a bit.
+
+2003-02-12 Andreas Kupries <andreask@activestate.com>
+
+ * dtformatter.man: Updated the documentation to include the
+ * dtformat.man: two new commands (vset, include).
+
+ * doctools.tcl (Eval): Added handling of new [include]
+ * doctools.tcl (ExpandInclude): formatting command.
+
+ * checker.tcl (vset): New command in the formatting language for
+ handling variables (setting and retrieving values). Differs from
+ the regular in that the set value is not retruned as the result
+ of the command. This is necessary to avoid unwanted insertion of
+ data into the output stream. The command is handled in the
+ checker layer (although no checking is required). The engines
+ never see this command.
+
+ * mpformats/fmt.nroff: Changed both engines to not use the
+ * mpformats/fmt.wiki: expander context stack anymore. It
+ interferes with handling of include
+ files. It was used to catch all output and
+ then perform last-miunte processing. for
+ that we have [fmt_postprocess], moved the
+ code to that.
+
+2003-01-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/fmt.html: Modified generation of section titles to
+ make the resulting HTML more conformant and less
+ troublesome. Thanks to Larry Virden
+ <lvirden@users.sourceforge.net> for the catch. Revised the
+ engine a bit. Entries in the synopsis now refer directly to the
+ location where they are defined ([call] command).
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/fmt.html: Removed 'strong' formatting. The checker
+ * mpformats/fmt.latex: warns if used and warnings requested, it
+ * mpformats/fmt.nroff: now also redirects the command to 'emph'.
+ * mpformats/fmt.wiki: The option -visualwarn (doctools, and
+ * mpformats/fmt.null: mpexpand) renamed to -deprecated. Message
+ * mpformats/fmt.list: 'visualmarkup' removed from the catalogs,
+ * mpformats/c.msg: and 'depr_strong' added instead.
+ * mpformats/en.msg:
+ * mpformats/de.msg:
+ * checker.tcl:
+ * doctools.tcl:
+ * mpexpand:
+
+ * doctools.man: Updated, converted [strong] to better
+ * dtformat.man: formatting commands. Ditto for all manpages
+ * dtformatter.man: in tcllib containing 'strong'. 'strong' is now
+ * mpexpand.man: not present anymore.
+
+ * mpformats/_common.tcl: Applied a patch by Joe English adding the
+ * mpformats/fmt.tmml: copyright information to the appropriate
+ place in the TMML output. This also fixes
+ a bug in c_get_copyright where an empty
+ string resulted in a incomplete line
+ being given to the formatter.
+
+ * mpformats/fmt.html: Removed the phrase 'All rights reserved'
+ * mpformats/fmt.latex: from the code, on recommendation by
+ * mpformats/fmt.nroff: Joe English.
+ * mpformats/fmt.wiki:
+
+ (In the way to early morrow :)
+ * mpformats/fmt.html: Changed to display copyright information in
+ * mpformats/fmt.latex: the conversion result itself and not only
+ * mpformats/fmt.nroff: embedded in comments.
+ * mpformats/fmt.wiki:
+
+2003-01-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doctools.tcl: Added a new formatting command,
+ * doctools.test: 'copyright', to declare/assign copyright
+ * doctools.man: for manpages. Updated both documentation
+ * dtformat.man: and testsuite. Extended the common code
+ * checker.tcl: base with convenience methods for storing
+ * api.tcl: and retrieving such information. The
+ * mpformats/fmt.html: retrieval operation also implements the
+ * mpformats/fmt.latex: logic giving the information in a manpage
+ * mpformats/fmt.list: precedence over information coming from the
+ * mpformats/fmt.nroff: processor. Updated all predefined engines
+ * mpformats/fmt.null: to handle the new command. TMML done only
+ * mpformats/fmt.tmml: partially, as I don't know where the copy-
+ * mpformats/fmt.wiki: right has to go.
+ * mpformats/_common.tcl:
+ * mpformats/_html.tcl:
+ * mpformats/_nroff.tcl:
+ * mpexpand:
+
+2003-01-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpexpand: Moved format help into the package itself.
+ * doctools.tcl: Changed the checker. Input syntax errors are not
+ * checker.tcl: written to stderr anymore, but reported through
+ * doctools.man: an standard tcl error. Warnings are collected and
+ * doctools.test: can be queried after a formatting run. Made the
+ generic engine more robust against failures in a
+ formatting engine. Wrote documentation for the
+ package. Extended the configuration method to be
+ more standard. Wrote a testsuite.
+
+2003-01-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpexpand: Nearly complete rewrite of the system.
+ * mpformats/fmt.html: The recognized input format was _not_
+ * mpformats/fmt.latex: changed. The main functionality was
+ * mpformats/fmt.list: placed into a package, doctools. This
+ * mpformats/fmt.nroff: package allows the creation of multiple
+ * mpformats/fmt.null: formatter objects, to be used alone or
+ * mpformats/fmt.tmml: together. The application 'mpexpand' was
+ * mpformats/fmt.wiki: rewritten to use that package and is now
+ * mpformats/_common.tcl: much simpler. The communication between
+ * mpformats/_nroff.tcl: the various stages was made simpler, and
+ * mpformats/_xml.tcl: one slave interpreter was dropped because
+ * mpformats/_html.tcl: of this. It might be added back if its
+ * api.tcl: existence proves to be beneficial. The
+ * checker.tcl: API between main systen and formatter
+ * doctools.tcl: engine was changed, consequently all
+ * dtformatter.man: existing engines had to be updated. They
+ were also made simpler, especially in the
+ area of list handling, because of the
+ validation done by the checker subsystem.
+ The version number is now 1.0.
+
+2002-12-16 David N. Welton <davidw@dedasys.com>
+
+ * mpexpand (format_find): Added 'argv0' as a global variable, in
+ order to avoid erroring out when providing a bad format.
+
+2002-12-05 Andreas Kupries <andreask@activestate.com>
+
+ * mpformats/fmt.nroff: Changed so that comments coming before
+ manpage_begin are moved after the standard header generated by
+ manpage_begin.
+
+2002-09-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpexpand: Corrected example formatting, have to run argument
+ through plain text handling.
+ * mpformats/fmt.wiki: Added Wiki formatting.
+
+2002-07-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/fmt.html: Changed bug #578465 which caused
+ mis-generation of angle-brackets and quotes.
+
+2002-06-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/fmt.html:
+ * mpformats/_html.tcl: Added the missing handling of " (&quot;) to
+ the format.
+
+2002-05-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/_xml.tcl: args -> arguments, as the argument is not
+ the last one. The code as is was not erroneous, but a possible
+ trouble spot should tcl ever be more strict with 'args'.
+
+2002-05-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/fmt.nroff: Accepted patch for bug #556509, both by Joe
+ English <jenglish@users.sourceforge.net>.
+
+2002-05-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * This completes the implementation of SF tcllib item #534334.
+
+ * mpformats/fmt.html: See last entry, completed definitions for
+ the new lists.
+
+ * format.man: Added the new commands (see last entry) to the
+ format specification and also added more explanations regarding
+ sections and paragraphs.
+
+2002-05-09 Joe English <jenglish@users.sourceforge.net>
+
+ * mpexpand:
+ * mpformats/c.msg:
+ * mpformats/de.msg:
+ * mpformats/en.msg:
+ * mpformats/fmt.nroff:
+ * mpformats/fmt.latex:
+ * mpformats/fmt.list:
+ * mpformats/fmt.nroff:
+ * mpformats/fmt.null: Added new list types for arguments, options,
+ commands, and Tk (widget) options.
+
+2002-04-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/fmt.html:
+ * mpformats/_html.tcl: Changes analogous to TMML (see below) to
+ differentiate internal markup and external special characters.
+
+2002-04-24 Joe English <jenglish@users.sourceforge.net>
+
+ * mpformats/_xml.tcl
+ * mpformats/fmt.tmml: Correctly handles XML markup characters
+ in macro arguments. Also correctly escapes apostrophes
+ in attribute values (previously-unnoticed bug).
+ * mpformats/fmt.tmml: TMML uses <url> instead of <uri>, and
+ does not have a <strong> element; changed output accordingly.
+
+2002-04-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * format.man: Added descriptions for all the commands performing
+ semantic markup. This closes bug #527025.
+
+2002-04-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpexpand: Fixed error in checker of plain text.
+
+ * mpformats/fmt.nroff: Added newlines in front of dot commands to
+ make sure that the formatting is correct. Superfluous newlines
+ are stripped in the post processor of this format, so
+ unconditionally adding them does not hurt.
+
+2002-04-02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/en.msg:
+ * mpformats/c.msg:
+ * mpformats/de.msg: Added the messages required by the new code
+ below.
+
+ * mpexpand: Added code to check that plain text is not used in
+ places where it is not allowed.
+
+2002-04-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Committed changes to list generation (better generation of
+ whitespace for HTML, allowing hints). Only the HTML formatter
+ currently acknowledges hints. This fixes SF Bug #535382.
+
+2002-03-26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpexpand: Changed the generation of error messages by the format
+ checker to use explicit error codes instead of trying to
+ construct the whole message automatically. Error codes are
+ mapped to textual messages using the message catalog facility,
+ allowing for easy i18n and l10n of mpexpand. Catalogs for the
+ locales "c", "en", and "de" are provided.
+
+ * mpformats/fmt.html: Changed uri formatting to be a link.
+
+ * mpformats/fmt.tmml:
+ * mpformats/fmt.html:
+ * mpformats/fmt.nroff:
+ * mpformats/fmt.latex:
+ * mpformats/fmt.list:
+ * mpformats/fmt.null:
+ * mpformats/_api.tcl: Added formatting commands "term" and "const"
+ to allow the structural markup of non-specific terminology and
+ of constant values.
+
+ * mpformats/fmt.nroff (bullet): Bulleting changed, use \(bu as
+ bullet instead of *.
+ (uri): Fixed error with underlining.
+
+2002-03-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpexpand: Extended with additional code checking that the
+ formatting commands are not used out of order and in the wrong
+ context. This check is independent of the format and thus
+ implemented outside of the format. Tcllib FR #530059.
+
+ * mpexpand: Implemented Tcllib FR #527029 (help options).
+
+2002-03-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/fmt.html: Removed 'center' alignment from
+ examples. Tcllib Bug #528390.
+
+2002-03-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * modules/doctools/format.man: Added documentation for [rb] and
+ [lb]. This partially fixes bug #527025.
+
+ * modules/doctools/mpformats/_html.tcl: The patch for FR #527716
+ also fixes a bug in the generation of HTML escapes. The table
+ swiped from htmlparse seems to contain some non-standard
+ escapes. Which are removed now.
+
+ * modules/doctools/format.man:
+ * modules/doctools/mpexpand:
+ * modules/doctools/mpformats/fmt.html:
+ * modules/doctools/mpformats/fmt.latex:
+ * modules/doctools/mpformats/fmt.list:
+ * modules/doctools/mpformats/fmt.nroff:
+ * modules/doctools/mpformats/fmt.null:
+ * modules/doctools/mpformats/fmt.tmml:
+ * modules/doctools/mpformats/fmt.tmml: Accepted FR #527716 by
+ Bryan Oakley <boakley@users.sourceforge.net> which adds a
+ command [usage] to the format. It allows the specification of
+ usage information for the synopsis without the need to be
+ embedded into a definition list.
+
+2002-02-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/fmt.nroff: Corrected problems with trimming lines and
+ the stripping of empty lines.
+
+ * mpformats/fmt.html: Changed the formatting of examples. Embedded
+ them into a table and additionally marked them with a black bar
+ to the left.
+
+2002-02-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/fmt.null: Null format, does not produce any output.
+
+ * mpformats/fmt.tmml:
+ * mpformats/fmt.nroff:
+ * mpformats/fmt.latex:
+ * mpformats/fmt.html:
+ * mpformats/fmt.list: Implementations of the new command.
+
+ * mpexpand: Added the commands to the processor application. Added
+ option "-visualwarn". When present the processor warn about
+ usage of visual markup. Tcllib FR #517599.
+
+ * mpformats/_api.tcl: Added a number of semantic markup commands
+ to the api as part of Tcllib FR #517599. Also added comment
+ command, see Tcllib FR #520269.
+
+2002-02-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/_common.tcl: Frink run.
+
+2002-02-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/fmt.html: Added detection of section cross-references
+ in [emph] and [strong] based on the code for TMML.
+
+2002-02-13 Joe English <jenglish@users.sourceforge.net>
+
+ * mpformats/fmt.tmml: [example_begin] inside lists was
+ not handled correctly.
+
+ * mpformats/fmt.tmml: Detect section cross-references
+ in [emph] and [strong].
+
+2002-02-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mpformats/_html.tcl: Added command to map HTML special
+ characters to their escape sequences.
+
+ * mpformats/fmt.latex: Added code to disable special processing of
+ plain text while inside of an example.
+
+ * mpformats/fmt.tmml: Added HandleText call to [example] to handle
+ special XML characters inside of the example. Not requitred for
+ [example_begin] / [example_end] as the text will go through
+ HandleText automatically for that case.
+
+ * mpformats/fmt.nroff: Added split to lsearch statement in
+ manpage_end to make the code robust against strings which are
+ not valid lists.
+
+2002-02-12 Joe English <jenglish@users.sourceforge.net>
+
+ * Added [example_begin] and [example_end] commands.
+ Also [example { code ... }] command.
+
+2001-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Added formatter for LaTeX.
+
+2001-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module. Application module providing a simple tcl-based
+ manpage markup language and a processor for converting this
+ format to TMML, nroff and HTML. Extensible, i.e. additional
+ formats can be added without to much work (Manpages for format
+ and internal interfaces are provided).
diff --git a/tcllib/modules/doctools/NOTES b/tcllib/modules/doctools/NOTES
new file mode 100644
index 0000000..05fd102
--- /dev/null
+++ b/tcllib/modules/doctools/NOTES
@@ -0,0 +1,34 @@
+======
+ TODO
+======
+
+* docidx / doctoc package documentation - sync with code
+* doctools package documentation ditto
+
+
+
+
+* Add a tk-based editor application which loads and generates
+ the format (and can invoke the processor to generate the other
+ formats).
+
+* Rewrite formatters to use generator packages for their
+ output format. Example: HTML => tcllib/html package
+ to generate the tags. Less quoting issues. Has escape
+ handlers.
+
+=======
+
+Note that running multiple formatters in parallel is possible, but
+requires that the whole chain of expander, checker and engine are
+replicated per format. The reason for this is that engine generates
+some output, but always passes it up to its caller, i.e the expander,
+for final composition. This is especially true for nested macro
+invocations where the intermediate results generated by the engine are
+passed through the expander to be sent down again into the engine. For
+multiple engines we have to combine and then separate the results for
+the various formats. The problem is to distinguish between data coming
+from the engine and text coming from the outside, for the latter has
+to be replicated instead of separated. This is possible, but I do not
+believe that it is worth the additional complexity of the
+implemementation.
diff --git a/tcllib/modules/doctools/api.tcl b/tcllib/modules/doctools/api.tcl
new file mode 100644
index 0000000..79d5572
--- /dev/null
+++ b/tcllib/modules/doctools/api.tcl
@@ -0,0 +1,31 @@
+# -*- tcl -*-
+# api.tcl -- API placeholders
+#
+# Copyright (c) 2001 Andreas Kupries <andreas_kupries@sourceforge.net>
+# Copyright (c) 2002 Andreas Kupries <andreas_kupries@sourceforge.net>
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+################################################################
+# This file defines all commands expected from a formatter by the
+# doctools library. It is loaded into the formatter interpreter before
+# the code for a particular format is loaded. All commands defined
+# here return an error. This ensures the generation of errors if a
+# format forgets to define commands in the API.
+
+################################################################
+# Here it comes
+
+foreach __cmd {
+ initialize shutdown setup numpasses listvariables varset
+
+ manpage_begin moddesc titledesc manpage_end require description
+ section para list_begin list_end lst_item call bullet enum see_also
+ keywords example example_begin example_end nl arg cmd opt emph strong
+ comment sectref syscmd method option widget fun type package class var
+ file uri term const copyright category
+} {
+ proc fmt_$__cmd {args} [list return "return -code error \"Unimplemented API command $__cmd\""]
+}
+unset __cmd
+
+################################################################
diff --git a/tcllib/modules/doctools/api_idx.tcl b/tcllib/modules/doctools/api_idx.tcl
new file mode 100644
index 0000000..3ee553d
--- /dev/null
+++ b/tcllib/modules/doctools/api_idx.tcl
@@ -0,0 +1,26 @@
+# -*- tcl -*-
+# api_idx.tcl -- API placeholders
+#
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+################################################################
+# This file defines all commands expected from a docidx formatter by the
+# doctools library. It is loaded into the formatter interpreter before
+# the code for a particular docidx format is loaded. All commands defined
+# here return an error. This ensures the generation of errors if a
+# format forgets to define commands in the API.
+
+################################################################
+# Here it comes
+
+foreach __cmd {
+ idx_initialize idx_shutdown idx_setup idx_numpasses
+ idx_listvariables idx_varset
+ fmt_index_begin fmt_index_end fmt_key fmt_manpage fmt_url
+ fmt_comment fmt_plain_text
+} {
+ proc $__cmd {args} [list return "return -code error \"Unimplemented API command $__cmd\""]
+}
+unset __cmd
+
+################################################################
diff --git a/tcllib/modules/doctools/api_toc.tcl b/tcllib/modules/doctools/api_toc.tcl
new file mode 100644
index 0000000..42398cf
--- /dev/null
+++ b/tcllib/modules/doctools/api_toc.tcl
@@ -0,0 +1,26 @@
+# -*- tcl -*-
+# api_toc.tcl -- API placeholders
+#
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+################################################################
+# This file defines all commands expected from a doctoc formatter by the
+# doctools library. It is loaded into the formatter interpreter before
+# the code for a particular doctoc format is loaded. All commands defined
+# here return an error. This ensures the generation of errors if a
+# format forgets to define commands in the API.
+
+################################################################
+# Here it comes
+
+foreach __cmd {
+ toc_initialize toc_shutdown toc_setup toc_numpasses
+ toc_listvariables toc_varset
+ fmt_toc_begin fmt_toc_end fmt_division_start fmt_division_end
+ fmt_item fmt_comment fmt_plain_text
+} {
+ proc $__cmd {args} [list return "return -code error \"Unimplemented API command $__cmd\""]
+}
+unset __cmd
+
+################################################################
diff --git a/tcllib/modules/doctools/changelog.man b/tcllib/modules/doctools/changelog.man
new file mode 100644
index 0000000..ff0e903
--- /dev/null
+++ b/tcllib/modules/doctools/changelog.man
@@ -0,0 +1,87 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::changelog n 1.1]
+[keywords changelog]
+[keywords doctools]
+[keywords emacs]
+[copyright {2003-2013 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Processing text in Emacs ChangeLog format}]
+[category {Documentation tools}]
+[require Tcl 8.2]
+[require textutil]
+[require doctools::changelog [opt 1.1]]
+[description]
+
+This package provides Tcl commands for the processing and reformatting
+of text in the [file ChangeLog] format generated by [syscmd emacs].
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::changelog::scan] [arg text]]
+
+The command takes the [arg text] and parses it under the assumption
+that it contains a ChangeLog as generated by [syscmd emacs]. It
+returns a data structure describing the contents of this ChangeLog.
+
+[para]
+
+This data structure is a list where each element describes one entry
+in the ChangeLog. Each element/entry is then a list of three elements
+describing the date of the entry, its author, and the comments made,
+in this order. The last item in each element/entry, the comments, is a
+list of sections. Each section is described by a list containing two
+elements, a list of file names, and a string containing the true
+comment associated with the files of the section.
+
+[para]
+[example {
+ {
+ {
+ date
+ author
+ {
+ {
+ {file ...}
+ commenttext
+ }
+ ...
+ }
+ }
+ {...}
+ }
+}]
+
+[call [cmd ::doctools::changelog::flatten] [arg entries]]
+
+This command converts a list of entries as generated by
+[cmd change::scan] above into a simpler list of plain
+text blocks each containing all the information of a
+single entry.
+
+[call [cmd ::doctools::changelog::toDoctools] [arg title] [arg module] [arg version] [arg entries]]
+
+This command converts the pre-parsed ChangeLog [arg entries] as
+generated by the command [cmd ::doctools::changelog::scan] into a
+document in [term doctools] format and returns it as the result of the
+command.
+
+[para]
+
+The other three arguments supply the information for the header of
+that document which is not available from the changelog itself.
+
+[call [cmd ::doctools::changelog::merge] [arg entries]...]
+
+Each argument of the command is assumed to be a pre-parsed Changelog
+as generated by the command [cmd ::doctools::changelog::scan]. This
+command merges all of them into a single structure, and collapses
+multiple entries for the same date and author into a single entry. The
+new structure is returned as the result of the command.
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/changelog.tcl b/tcllib/modules/doctools/changelog.tcl
new file mode 100644
index 0000000..d0b711b
--- /dev/null
+++ b/tcllib/modules/doctools/changelog.tcl
@@ -0,0 +1,281 @@
+# changelog.tcl --
+#
+# Handling of ChangeLog's.
+#
+# Copyright (c) 2003-2008 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: changelog.tcl,v 1.8 2008/07/08 23:03:58 andreas_kupries Exp $
+
+
+# FUTURE -- Expand pre-parsed log (nested lists) into flat structures
+# FUTURE -- => date/author/file/cref + cref/text
+# FUTURE -- I.e. relational/tabular structure, useable in table displays,
+# FUTURE -- sort by date, author, file to see aggregated changes
+# FUTURE -- => Connectivity to 'struct::matrix', Reports!
+
+
+package require Tcl 8.2
+package require textutil
+
+namespace eval ::doctools {}
+namespace eval ::doctools::changelog {
+ namespace export scan flatten merge toDoctools
+}
+
+proc ::doctools::changelog::flatten {entries} {
+ # Reformat the entries into a simpler structure.
+
+ set result {}
+ foreach entry $entries {
+ foreach {date user sections} $entry break
+ set f {}
+ set t {}
+ foreach sec $sections {
+ foreach {files text} $sec break
+ foreach file $files { lappend f $file }
+ append t \n $text
+ }
+
+ set t [textutil::adjust::indent [textutil::adjust $t] " "]
+ lappend result \
+ "$date $user\n [join $f ", "]:\n$t"
+ }
+
+ return $result
+}
+
+# ::doctools::changelog::scan --
+#
+# Scan a ChangeLog generated by 'emacs' and extract the relevant information.
+#
+# Result
+# List of entries. Each entry is a list of three elements. These
+# are date, author, and commentary. The commentary is a list of
+# sections. Each section is a list of two elements, a list of
+# files, and the associated text.
+
+proc ::doctools::changelog::scan {text} {
+ set text [split $text \n]
+ set n [llength $text]
+
+ set entries [list]
+ set clist [list]
+ set files [list]
+ set comment ""
+ set first 1
+
+ for {set i 0} {$i < $n} {incr i} {
+ set line [lindex $text $i]
+
+ if {[regexp "^\[^ \t\]" $line]} {
+ # No whitespace at the front, start a new entry
+
+ closeEntry
+
+ # For the upcoming entry. Quick extraction first, string
+ # based in case of failure.
+
+ if {[catch {
+ set date [string trim [lindex $line 0]]
+ set author [string trim [lrange $line 1 end]]
+ }]} {
+ set pos [string first " " $line]
+ set date [string trim [string range $line 0 $pos]]
+ set author [string trim [string range $line $pos end]]
+ }
+ continue
+ }
+
+ # Inside of an entry.
+
+ set line [string trim $line]
+
+ if {[string length $line] == 0} {
+ # Next comment section
+ closeSection
+ continue
+ }
+
+ # Line is not empty. Split into file and comment parts,
+ # remember the data.
+
+ if {[string first "* " $line] == 0} {
+ if {[regexp {^\* (.*):[ ]} $line full fname]} {
+ set line [string range $line [string length $full] end]
+ } elseif {[regexp {^\* (.*):$} $line full fname]} {
+ set line ""
+ } else {
+ # There is no filename
+ set fname ""
+ set line [string range $line 2 end] ; # Get rid of "* ".
+ }
+
+ set detail ""
+ while {[string first "(" $fname] >= 0} {
+ if {[regexp {\([^)]*\)} $fname detailx]} {
+ regsub {\([^)]*\)} $fname {} fnameNew
+ } elseif {[regexp {\([^)]*} $fname detailx]} {
+ regsub {\([^)]*} $fname {} fnameNew
+ } else {
+ break
+ }
+ append detail " " $detailx
+ set fname [string trim $fnameNew]
+ }
+ if {$detail != {}} {set line "$detail $line"}
+ if {$fname != {}} {lappend files $fname}
+ }
+
+ append comment $line\n
+ }
+
+ closeEntry
+ return $entries
+}
+
+
+proc ::doctools::changelog::closeSection {} {
+ upvar 1 clist clist comment comment files files
+
+ if {
+ ([string length $comment] > 0) ||
+ ([llength $files] > 0)
+ } {
+ lappend clist [list $files [string trim $comment]]
+ set files [list]
+ set comment ""
+ }
+ return
+}
+
+proc ::doctools::changelog::closeEntry {} {
+ upvar 1 clist clist comment comment files files first first \
+ date date author author entries entries
+
+ if {!$first} {
+ closeSection
+ lappend entries [list $date $author $clist]
+ }
+ set first 0
+ set clist [list]
+ set files [list]
+ set comment ""
+ return
+}
+
+# ::doctools::changelog::merge --
+#
+# Merge several preprocessed changelogs (see scan) into one structure.
+
+
+proc ::doctools::changelog::merge {args} {
+
+ if {[llength $args] == 0} {return {}}
+ if {[llength $args] == 1} {return [lindex $args 0]}
+
+ set res [list]
+ array set tmp {}
+
+ # Merge up ...
+
+ foreach entries $args {
+ foreach e $entries {
+ foreach {date author comments} $e break
+ if {![info exists tmp($date,$author)]} {
+ lappend res [list $date $author]
+ set tmp($date,$author) $comments
+ } else {
+ foreach section $comments {
+ lappend tmp($date,$author) $section
+ }
+ }
+ }
+ }
+
+ # ... And construct the final result
+
+ set args $res
+ set res [list]
+ foreach key [lsort -decreasing $args] {
+ foreach {date author} $key break
+ lappend res [list $date $author $tmp($date,$author)]
+ }
+ return $res
+}
+
+
+# ::doctools::changelog::toDoctools --
+#
+# Convert a preprocessed changelog log (see scan) into a doctools page.
+#
+# Arguments:
+# evar, cvar, fvar: Name of the variables containing the preprocessed log.
+#
+# Results:
+# A string containing a properly formatted ChangeLog.
+#
+
+proc ::doctools::changelog::q {text} {return "\[$text\]"}
+
+proc ::doctools::changelog::toDoctools {title module version entries} {
+
+ set linebuffer [list]
+ lappend linebuffer [q "manpage_begin [list ${title}-changelog n $version]"]
+ lappend linebuffer [q "titledesc [list "$title ChangeLog"]"]
+ lappend linebuffer [q "moddesc [list $module]"]
+ lappend linebuffer [q description]
+ lappend linebuffer [q "list_begin definitions compact"]
+
+ foreach entry $entries {
+ foreach {date author commentary} $entry break
+
+ lappend linebuffer [q "lst_item \"[q "emph [list $date]"] -- [string map {{"} {\"} {\"} {\\\"}} $author]\""]
+
+ if {[llength $commentary] > 0} {
+ lappend linebuffer [q nl]
+ }
+
+ foreach section $commentary {
+ foreach {files text} $section break
+ if {$text != {}} {
+ set text [string map {[ [lb] ] [rb]} [textutil::adjust $text]]
+ }
+
+ if {[llength $files] > 0} {
+ lappend linebuffer [q "list_begin definitions"]
+
+ foreach f $files {
+ lappend linebuffer [q "lst_item [q "file [list $f]"]"]
+ }
+ if {$text != {}} {
+ lappend linebuffer ""
+ lappend linebuffer $text
+ lappend linebuffer ""
+ }
+
+ lappend linebuffer [q list_end]
+ } elseif {$text != {}} {
+ # No files
+ lappend linebuffer [q "list_begin bullet"]
+ lappend linebuffer [q bullet]
+ lappend linebuffer ""
+ lappend linebuffer $text
+ lappend linebuffer ""
+ lappend linebuffer [q list_end]
+ }
+ }
+ lappend linebuffer [q nl]
+ }
+
+ lappend linebuffer [q list_end]
+ lappend linebuffer [q manpage_end]
+ return [join $linebuffer \n]
+}
+
+#------------------------------------
+# Module initialization
+
+package provide doctools::changelog 1.1
diff --git a/tcllib/modules/doctools/checker.tcl b/tcllib/modules/doctools/checker.tcl
new file mode 100644
index 0000000..d63942d
--- /dev/null
+++ b/tcllib/modules/doctools/checker.tcl
@@ -0,0 +1,734 @@
+# -*- tcl -*-
+# checker.tcl
+#
+# Code used inside of a checker interpreter to ensure correct usage of
+# doctools formatting commands.
+#
+# Copyright (c) 2003-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# L10N
+
+package require msgcat
+
+proc ::msgcat::mcunknown {locale code} {
+ return "unknown error code \"$code\" (for locale $locale)"
+}
+
+if {0} {
+ puts stderr "Locale [::msgcat::mcpreferences]"
+ foreach path [dt_search] {
+ puts stderr "Catalogs: [::msgcat::mcload $path] - $path"
+ }
+} else {
+ foreach path [dt_search] {
+ ::msgcat::mcload $path
+ }
+}
+
+# State, and checker commands.
+# -------------------------------------------------------------
+#
+# Note that the code below assumes that a command XXX provided by the
+# formatter engine is accessible under the name 'fmt_XXX'.
+#
+# -------------------------------------------------------------
+
+global state lstctx lstitem
+
+# --------------+-----------------------+----------------------
+# state | allowed commands | new state (if any)
+# --------------+-----------------------+----------------------
+# all except | arg cmd opt comment |
+# for "done" | syscmd method option |
+# | widget fun type class |
+# | package var file uri |
+# | strong emph namespace |
+# --------------+-----------------------+----------------------
+# manpage_begin | manpage_begin | header
+# --------------+-----------------------+----------------------
+# header | moddesc titledesc | header
+# | copyright keywords |
+# | require see_also category |
+# +-----------------------+-----------
+# | description | body
+# --------------+-----------------------+----------------------
+# body | section para list_end | body
+# | list_begin lst_item |
+# | call bullet usage nl |
+# | example see_also |
+# | keywords sectref enum |
+# | arg_def cmd_def |
+# | opt_def tkoption_def |
+# | subsection category |
+# +-----------------------+-----------
+# | example_begin | example
+# +-----------------------+-----------
+# | manpage_end | done
+# --------------+-----------------------+----------------------
+# example | example_end | body
+# --------------+-----------------------+----------------------
+# done | |
+# --------------+-----------------------+----------------------
+#
+# Additional checks
+# --------------------------------------+----------------------
+# list_begin/list_end | Are allowed to nest.
+# --------------------------------------+----------------------
+# section | Not allowed in list context
+#
+# arg_def | Only in 'argument list'.
+# cmd_def | Only in 'command list'.
+# nl para | Only in list item context.
+# opt_def | Only in 'option list'.
+# tkoption_def | Only in 'tkoption list'.
+# def/call | Only in 'definition list'.
+# enum | Only in 'enum list'.
+# item/bullet | Only in 'bullet list'.
+# --------------------------------------+----------------------
+
+# -------------------------------------------------------------
+# Helpers
+proc Error {code {text {}}} {
+ global state lstctx lstitem
+
+ # Problematic command with all arguments (we strip the "ck_" prefix!)
+ # -*- future -*- count lines of input, maintain history buffer, use
+ # -*- future -*- that to provide some context here.
+
+ set cmd [lindex [info level 1] 0]
+ set args [lrange [info level 1] 1 end]
+ if {$args != {}} {append cmd " [join $args]"}
+
+ # Use a message catalog to map the error code into a legible message.
+ set msg [::msgcat::mc $code]
+
+ if {$text != {}} {
+ set msg [string map [list @ $text] $msg]
+ }
+ dt_error "Manpage error ($code), \"$cmd\" : ${msg}."
+ return
+}
+proc Warn {code args} {
+ global pass
+ if {$pass > 1} return
+ # Warnings only in the first pass!
+ set msg [::msgcat::mc $code]
+ foreach {off line col} [dt_where] break
+ set msg [eval [linsert $args 0 format $msg]]
+ set msg "In macro at line $line, column $col of file [dt_file]:\n$msg"
+ set msg [split $msg \n]
+ set prefix "DocTools Warning ($code): "
+ dt_warning "$prefix[join $msg "\n$prefix"]"
+ return
+}
+proc WarnX {code args} {
+ # Warnings only in the first pass!
+ set msg [::msgcat::mc $code]
+ foreach {off line col} [dt_where] break
+ set msg [eval [linsert $args 0 format $msg]]
+ set msg "In macro at line $line, column $col of file [dt_file]:\n$msg"
+ set msg [split $msg \n]
+ set prefix "DocTools Warning ($code): "
+ dt_warning "$prefix[join $msg "\n$prefix"]"
+ return
+}
+
+proc Is {s} {global state ; return [string equal $state $s]}
+proc IsNot {s} {global state ; return [expr {![string equal $state $s]}]}
+proc Go {s} {Log " >>\[$s\]" ; global state ; set state $s; return}
+proc LPush {l} {
+ global lstctx lstitem
+ set lstctx [linsert $lstctx 0 $l $lstitem]
+ return
+}
+proc LPop {} {
+ global lstctx lstitem
+ set lstitem [lindex $lstctx 1]
+ set lstctx [lrange $lstctx 2 end]
+ return
+}
+proc LSItem {} {global lstitem ; set lstitem 1}
+proc LIs {l} {global lstctx ; string equal $l [lindex $lstctx 0]}
+proc LItem {} {global lstitem ; return $lstitem}
+proc LNest {} {
+ global lstctx
+ expr {[llength $lstctx] / 2}
+}
+proc LOpen {} {
+ global lstctx
+ expr {$lstctx != {}}
+}
+global lmap ldmap
+array set lmap {
+ bullet itemized item itemized
+ arg arguments args arguments
+ opt options opts options
+ cmd commands cmds commands
+ enum enumerated tkoption tkoptions
+}
+array set ldmap {
+ bullet . arg . cmd . tkoption . opt .
+}
+proc LMap {what} {
+ global lmap ldmap
+ if {![info exists lmap($what)]} {
+ return $what
+ }
+ if {[dt_deprecated] && [info exists ldmap($what)]} {
+ Warn depr_ltype $what $lmap($what)
+ }
+ return $lmap($what)
+}
+proc LValid {what} {
+ switch -exact -- $what {
+ arguments -
+ commands -
+ definitions -
+ enumerated -
+ itemized -
+ options -
+ tkoptions {return 1}
+ default {return 0}
+ }
+}
+
+proc State {} {global state ; return $state}
+proc Enter {cmd} {Log "\[[State]\] $cmd"}
+
+#proc Log* {text} {puts -nonewline $text}
+#proc Log {text} {puts $text}
+proc Log* {text} {}
+proc Log {text} {}
+
+
+# -------------------------------------------------------------
+# Framing
+proc ck_initialize {p} {
+ global state ; set state manpage_begin
+ global lstctx ; set lstctx [list]
+ global lstitem ; set lstitem 0
+ global sect
+ if {$p == 1} {
+ catch {unset sect} ; set sect() . ; unset sect()
+ catch {unset sectt} ; set sectt() . ; unset sectt()
+ }
+ global pass ; set pass $p
+ global countersection ; set countersection 0
+ global countersubsection ; set countersubsection 0
+ return
+}
+proc ck_complete {} {
+ if {[Is done]} {
+ if {![LOpen]} {
+ return
+ } else {
+ Error end/open/list
+ }
+ } elseif {[Is example]} {
+ Error end/open/example
+ } else {
+ Error end/open/mp
+ }
+ return
+}
+# -------------------------------------------------------------
+# Plain text
+proc plain_text {text} {
+ # Only in body, not between list_begin and first item.
+ # Ignore everything which is only whitespace ...
+
+ set redux [string map [list " " "" "\t" "" "\n" ""] $text]
+ if {$redux == {}} {return [fmt_plain_text $text]}
+ if {[IsNot body] && [IsNot example]} {Error body}
+ if {[LOpen] && ![LItem]} {Error nolisttxt}
+ return [fmt_plain_text $text]
+}
+
+# -------------------------------------------------------------
+# Variable handling ...
+
+proc vset {var args} {
+ switch -exact -- [llength $args] {
+ 0 {
+ # Retrieve contents of variable VAR
+ upvar #0 __$var data
+ if {![info exists data]} {
+ return -code error "can't read doc variable \"$var\": not set"
+ }
+ return $data
+ }
+ 1 {
+ # Set contents of variable VAR
+ global __$var
+ set __$var [lindex $args 0]
+ return "" ; # Empty string ! Nothing for output.
+ }
+ default {
+ return -code error "wrong#args: set var ?value?"
+ }
+ }
+}
+
+# -------------------------------------------------------------
+# Formatting commands
+proc manpage_begin {title section version} {
+ Enter manpage_begin
+ if {[IsNot manpage_begin]} {Error mpbegin}
+ if {[string match {* *} $title]} {Error mptitle}
+ Go header
+ fmt_manpage_begin $title $section $version
+}
+proc moddesc {desc} {
+ Enter moddesc
+ if {[IsNot header]} {Error hdrcmd}
+ fmt_moddesc $desc
+}
+proc titledesc {desc} {
+ Enter titledesc
+ if {[IsNot header]} {Error hdrcmd}
+ fmt_titledesc $desc
+}
+proc copyright {text} {
+ Enter copyright
+ if {[IsNot header]} {Error hdrcmd}
+ fmt_copyright $text
+}
+proc manpage_end {} {
+ Enter manpage_end
+ if {[IsNot body]} {Error bodycmd}
+ Go done
+ fmt_manpage_end
+}
+proc require {pkg {version {}}} {
+ Enter require
+ if {[IsNot header]} {Error hdrcmd}
+ fmt_require $pkg $version
+}
+proc description {} {
+ Enter description
+ if {[IsNot header]} {Error hdrcmd}
+ Go body
+ fmt_description [Sectdef section Description description]
+}
+
+# Storage for (sub)section ids to enable checking for ambigous
+# identificaton. The ids on this level are logical names. The backends
+# are given physical names (via counters).
+global sect ; # Map of logical -> physical ids
+global sectt ; # Map of logical -> section title
+global sectci ; # Current section (id)
+global sectct ; # Current section (title)
+global countersection
+global countersubsection
+
+proc section {title {id {}}} {
+ global sect
+
+ Enter section
+ if {[IsNot body]} {Error bodycmd}
+ if {[LOpen]} {Error nolistcmd}
+
+ fmt_section $title [Sectdef section $title $id]
+}
+proc subsection {title {id {}}} {
+ global sect
+
+ Enter subsection
+ if {[IsNot body]} {Error bodycmd}
+ if {[LOpen]} {Error nolistcmd}
+
+ fmt_subsection $title [Sectdef subsection $title $id]
+}
+
+proc Sectdef {type title id} {
+ global sect sectt sectci sectct countersection countersubsection pass
+
+ # Compute a (sub)section id from the name (= section label/title)
+ # if the user did not provide their own id.
+ if {![string length $id]} {
+ if {$type == "section"} {
+ set id [list $title]
+ } elseif {$type == "subsection"} {
+ set id [list $sectci $title]
+ } else {
+ error INTERNAL
+ }
+ }
+ # Check if the id is unambigous. Issue a warning if not. For
+ # sections we remember the now-current name and id for use by
+ # subsections.
+ if {$pass == 1} {
+ if {[info exists sect($id)]} {
+ set msg $title
+ if {$type == "subsection"} {
+ append msg " (in " $sectct ")"
+ }
+ Warn sectambig $msg
+ }
+ set sect($id) $type[incr counter$type]
+ }
+ set sectt($id) $title
+ if {$type == "section"} {
+ set sectci $id
+ set sectct $title
+ }
+ return $sect($id)
+}
+
+proc para {} {
+ Enter para
+ if {[IsNot body]} {Error bodycmd}
+ if {[LOpen]} {
+ if {![LItem]} {Error nolisthdr}
+ fmt_nl
+ } else {
+ fmt_para
+ }
+}
+proc list_begin {what {hint {}}} {
+ Enter "list_begin $what $hint"
+ if {[IsNot body]} {Error bodycmd}
+ if {[LOpen] && ![LItem]} {Error nolisthdr}
+ set what [LMap $what]
+ if {![LValid $what]} {Error invalidlist $what}
+ set res [fmt_list_begin $what $hint]
+ LPush $what
+ return $res
+}
+proc list_end {} {
+ Enter list_end
+ if {[IsNot body]} {Error bodycmd}
+ if {![LOpen]} {Error listcmd}
+ LPop
+ fmt_list_end
+}
+
+# Deprecated command, and its common misspellings. Canon is 'def'.
+proc lst_item {{text {}}} {
+ if {[dt_deprecated]} {Warn depr_lstitem "\[lst_item\]"}
+ def $text
+}
+proc list_item {{text {}}} {
+ if {[dt_deprecated]} {Warn depr_lstitem "\[list_item\]"}
+ def $text
+}
+proc listitem {{text {}}} {
+ if {[dt_deprecated]} {Warn depr_lstitem "\[listitem\]"}
+ def $text
+}
+proc lstitem {{text {}}} {
+ if {[dt_deprecated]} {Warn depr_lstitem "\[lstitem\]"}
+ def $text
+}
+proc def {{text {}}} {
+ Enter def
+ if {[IsNot body]} {Error bodycmd}
+ if {![LOpen]} {Error listcmd}
+ if {![LIs definitions]} {Error deflist}
+ LSItem
+ fmt_lst_item $text
+}
+proc arg_def {type name {mode {}}} {
+ Enter arg_def
+ if {[IsNot body]} {Error bodycmd}
+ if {![LOpen]} {Error listcmd}
+ if {![LIs arguments]} {Error arg_list}
+ LSItem
+ fmt_arg_def $type $name $mode
+}
+proc cmd_def {command} {
+ Enter cmd_def
+ if {[IsNot body]} {Error bodycmd}
+ if {![LOpen]} {Error listcmd}
+ if {![LIs commands]} {Error cmd_list}
+ LSItem
+ fmt_cmd_def $command
+}
+proc opt_def {name {arg {}}} {
+ Enter opt_def
+ if {[IsNot body]} {Error bodycmd}
+ if {![LOpen]} {Error listcmd}
+ if {![LIs options]} {Error opt_list}
+ LSItem
+ fmt_opt_def $name $arg
+}
+proc tkoption_def {name dbname dbclass} {
+ Enter tkoption_def
+ if {[IsNot body]} {Error bodycmd}
+ if {![LOpen]} {Error listcmd}
+ if {![LIs tkoptions]} {Error tkoption_list}
+ LSItem
+ fmt_tkoption_def $name $dbname $dbclass
+}
+proc call {cmd args} {
+ Enter call
+ if {[IsNot body]} {Error bodycmd}
+ if {![LOpen]} {Error listcmd}
+ if {![LIs definitions]} {Error deflist}
+ LSItem
+ eval [linsert $args 0 fmt_call $cmd]
+}
+# Deprecated. Use 'item'
+proc bullet {} {
+ if {[dt_deprecated]} {Warn depr_bullet "\[bullet\]"}
+ item
+}
+proc item {} {
+ Enter item
+ if {[IsNot body]} {Error bodycmd}
+ if {![LOpen]} {Error listcmd}
+ if {![LIs itemized]} {Error bulletlist}
+ LSItem
+ fmt_bullet
+}
+proc enum {} {
+ Enter enum
+ if {[IsNot body]} {Error bodycmd}
+ if {![LOpen]} {Error listcmd}
+ if {![LIs enumerated]} {Error enumlist}
+ LSItem
+ fmt_enum
+}
+proc example {code} {
+ Enter example
+ return [example_begin][plain_text ${code}][example_end]
+}
+proc example_begin {} {
+ Enter example_begin
+ if {[IsNot body]} {Error bodycmd}
+ if {[LOpen] && ![LItem]} {Error nolisthdr}
+ Go example
+ fmt_example_begin
+}
+proc example_end {} {
+ Enter example_end
+ if {[IsNot example]} {Error examplecmd}
+ Go body
+ fmt_example_end
+}
+proc see_also {args} {
+ Enter see_also
+ if {[Is done]} {Error nodonecmd}
+ # if {[IsNot body]} {Error bodycmd}
+ # if {[LOpen]} {Error nolistcmd}
+ eval [linsert $args 0 fmt_see_also]
+}
+proc keywords {args} {
+ Enter keywords
+ if {[Is done]} {Error nodonecmd}
+ # if {[IsNot body]} {Error bodycmd}
+ # if {[LOpen]} {Error nolistcmd}
+ eval [linsert $args 0 fmt_keywords]
+}
+proc category {text} {
+ Enter category
+ if {[Is done]} {Error nodonecmd}
+ # if {[IsNot body]} {Error bodycmd}
+ # if {[LOpen]} {Error nolistcmd}
+ fmt_category $text
+}
+# nl - Deprecated
+proc nl {} {
+ if {[dt_deprecated]} {Warn depr_nl "\[nl\]"}
+ para
+}
+proc emph {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_emph $text
+}
+# strong - Deprecated
+proc strong {text} {
+ if {[dt_deprecated]} {Warn depr_strong "\[strong\]"}
+ emph $text
+}
+proc arg {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_arg $text
+}
+proc cmd {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_cmd $text
+}
+proc opt {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_opt $text
+}
+proc comment {text} {
+ if {[Is done]} {Error nodonecmd}
+ return ; #fmt_comment $text
+}
+proc sectref-external {title} {
+ if {[IsNot body]} {Error bodycmd}
+ if {[LOpen] && ![LItem]} {Error nolisthdr}
+
+ fmt_sectref $title {}
+}
+proc sectref {id {title {}}} {
+ if {[IsNot body]} {Error bodycmd}
+ if {[LOpen] && ![LItem]} {Error nolisthdr}
+
+ # syntax: id ?title?
+ # Check existence of referenced (sub)section.
+ global sect sectt sectci pass
+
+ # Two things are done.
+ # (1) Check that the id is known and determine the full id.
+ # (2) Determine physical id, and, if needed, the title.
+
+ if {[info exists sect($id)]} {
+ # Logical id, likely user-supplied, exists.
+ set pid $sect($id)
+ set fid $id
+ } else {
+ # Doesn't exist directly. Assume that the id is derived from a
+ # (sub)section title, search various combinations.
+
+ set fid [list $id]
+ if {[info exists sect($fid)]} {
+ # Id was wrapped section title.
+ set pid $sect($fid)
+ } else {
+ # See if the id is the tail end of a subsection id.
+ set ic [array names sect [list * $id]]
+ if {![llength $ic]} {
+ # No, it is not. Give up.
+ if {$pass > 1 } { WarnX missingsect $id }
+ set pid {}
+ } elseif {[llength $ic] == 1} {
+ # Yes, and it is unique. Take it.
+ set fid [lindex $ic 0]
+ set pid $sect($fid)
+ } else {
+ # Yes, however it is ambigous. Issue warning, then
+ # select one of the possibilities. Prefer to keep the
+ # reference within the currenc section, otherwise,
+ # i.e. if we cannot do that, choose randomly.
+ if {$pass == 2} { WarnX sectambig $id }
+ set fid [list $sectci $id]
+ if {![info exists sect($fid)]} {
+ # No candidate in current section, so chose
+ # randomly.
+ set fid [lindex $ic 0]
+ }
+ set pid $sect($fid)
+ }
+ }
+ }
+
+ # If we have no text take the section title as text, if we
+ # can. Last fallback for thext is the id.
+ if {$title == {}} {
+ if {$pid != {}} {
+ set title $sectt($fid)
+ } else {
+ set title $id
+ }
+ }
+
+ # Hand both chosen title and physical id to the backend for
+ # actual formatting.
+ fmt_sectref $title $pid
+}
+proc syscmd {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_syscmd $text
+}
+proc method {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_method $text
+}
+proc option {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_option $text
+}
+proc widget {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_widget $text
+}
+proc fun {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_fun $text
+}
+proc type {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_type $text
+}
+proc package {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_package $text
+}
+proc class {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_class $text
+}
+proc var {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_var $text
+}
+proc file {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_file $text
+}
+
+# Special case: We must not overwrite the builtin namespace command,
+# as it is required by the package "msgcat".
+proc _namespace {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_namespace $text
+}
+proc uri {text {label {}}} {
+ if {[Is done]} {Error nodonecmd}
+ # The label argument is left out when undefined so that we can
+ # control old formatters as well, if the input is not using uri
+ # labels.
+
+ if {$label == {}} {
+ fmt_uri $text
+ } else {
+ fmt_uri $text $label
+ }
+}
+proc image {text {label {}}} {
+ if {[Is done]} {Error nodonecmd}
+ # The label argument is left out when undefined so that we can
+ # control old formatters as well, if the input is not using uri
+ # labels.
+
+ if {$label == {}} {
+ fmt_image $text
+ } else {
+ fmt_image $text $label
+ }
+}
+proc manpage {text} {
+ if {[Is done]} {Error nodonecmd}
+ # The label argument is left out when undefined so that we can
+ # control old formatters as well, if the input is not using uri
+ # labels.
+
+ fmt_term $text
+ #fmt_manpage $text
+}
+proc usage {args} {
+ if {[Is done]} {Error nodonecmd}
+ eval fmt_usage $args
+}
+proc const {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_const $text
+}
+proc term {text} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_term $text
+}
+
+proc mdash {} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_mdash $text
+}
+proc ndash {} {
+ if {[Is done]} {Error nodonecmd}
+ fmt_ndash $text
+}
+
+# -------------------------------------------------------------
diff --git a/tcllib/modules/doctools/checker_idx.tcl b/tcllib/modules/doctools/checker_idx.tcl
new file mode 100644
index 0000000..31b3104
--- /dev/null
+++ b/tcllib/modules/doctools/checker_idx.tcl
@@ -0,0 +1,207 @@
+# -*- tcl -*-
+# checker_idx.tcl
+#
+# Code used inside of a checker interpreter to ensure correct usage of
+# docidx formatting commands.
+#
+# Copyright (c) 2003-2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# L10N
+
+package require msgcat
+
+proc ::msgcat::mcunknown {locale code} {
+ return "unknown error code \"$code\" (for locale $locale)"
+}
+
+if {0} {
+ puts stderr "Locale [::msgcat::mcpreferences]"
+ foreach path [dt_search] {
+ puts stderr "Catalogs: [::msgcat::mcload $path] - $path"
+ }
+} else {
+ foreach path [dt_search] {
+ ::msgcat::mcload $path
+ }
+}
+
+# State, and checker commands.
+# -------------------------------------------------------------
+#
+# Note that the code below assumes that a command XXX provided by the
+# formatter engine is accessible under the name 'fmt_XXX'.
+#
+# -------------------------------------------------------------
+
+global state
+
+# State machine ... State centered
+# --------------+-----------------------+----------------------
+# state | allowed commands | new state (if any)
+# --------------+-----------------------+----------------------
+# all except | include vset |
+# ==============+=======================+======================
+# idx_begin | idx_begin | -> contents
+# --------------+-----------------------+----------------------
+# contents | key | -> ref_series
+# --------------+-----------------------+----------------------
+# ref_series | manpage | -> refkey_series
+# | url |
+# --------------+-----------------------+----------------------
+# refkey_series | manpage | -> refkey_series
+# | url |
+# +-----------------------+-----------
+# | key | -> ref_series
+# +-----------------------+-----------
+# | idx_end | -> done
+# --------------+-----------------------+----------------------
+
+# State machine, as above ... Command centered
+# --------------+-----------------------+----------------------
+# state | allowed commands | new state (if any)
+# --------------+-----------------------+----------------------
+# all except | include vset |
+# ==============+=======================+======================
+# idx_begin | idx_begin | -> contents
+# --------------+-----------------------+----------------------
+# contents | key | -> ref_series
+# refkey_series | |
+# --------------+-----------------------+----------------------
+# ref_series | manpage | -> refkey_series
+# refkey_series | |
+# --------------+-----------------------+----------------------
+# ref_series | url | -> refkey_series
+# refkey_series | |
+# --------------+-----------------------+----------------------
+# refkey_series | idx_end | -> done
+# --------------+-----------------------+----------------------
+
+# -------------------------------------------------------------
+# Helpers
+proc Error {code {text {}}} {
+ global state
+
+ # Problematic command with all arguments (we strip the "ck_" prefix!)
+ # -*- future -*- count lines of input, maintain history buffer, use
+ # -*- future -*- that to provide some context here.
+
+ set cmd [lindex [info level 1] 0]
+ set args [lrange [info level 1] 1 end]
+ if {$args != {}} {append cmd " [join $args]"}
+
+ # Use a message catalog to map the error code into a legible message.
+ set msg [::msgcat::mc $code]
+
+ if {$text != {}} {
+ set msg [string map [list @ $text] $msg]
+ }
+
+ dt_error "IDX error ($code), \"$cmd\" : ${msg}."
+ return
+}
+proc Warn {code text} {
+ set msg [::msgcat::mc $code]
+ dt_warning "IDX warning ($code): [join [split [format $msg $text] \n] "\nIDX warning ($code): "]"
+ return
+}
+
+proc Is {s} {global state ; return [string equal $state $s]}
+proc IsNot {s} {global state ; return [expr {![string equal $state $s]}]}
+proc Go {s} {Log " >>\[$s\]" ; global state ; set state $s; return}
+proc Push {s} {Log " //\[$s\]" ; global state stack ; lappend stack $state ; set state $s; return}
+proc Pop {} {Log* " pop" ; global state stack ; set state [lindex $stack end] ; set stack [lrange $stack 0 end-1] ; Log " \\\\\[$state\]" ; return}
+proc State {} {global state ; return $state}
+
+proc Enter {cmd} {Log* "\[[State]\] $cmd"}
+
+#proc Log* {text} {puts -nonewline $text}
+#proc Log {text} {puts $text}
+proc Log* {text} {}
+proc Log {text} {}
+
+# -------------------------------------------------------------
+# Framing
+proc ck_initialize {} {
+ global state ; set state idx_begin
+ global stack ; set stack [list]
+}
+proc ck_complete {} {
+ if {[Is done]} {
+ return
+ } else {
+ Error end/open/idx
+ }
+ return
+}
+# -------------------------------------------------------------
+# Plain text
+proc plain_text {text} {
+ # Ignore everything which is only whitespace ...
+ # Beyond that plain text is not allowed.
+
+ set redux [string map [list " " "" "\t" "" "\n" ""] $text]
+ if {$redux == {}} {return [fmt_plain_text $text]}
+ Error idx/plaintext
+ return ""
+}
+
+# -------------------------------------------------------------
+# Variable handling ...
+
+proc vset {var args} {
+ switch -exact -- [llength $args] {
+ 0 {
+ # Retrieve contents of variable VAR
+ upvar #0 __$var data
+ return $data
+ }
+ 1 {
+ # Set contents of variable VAR
+ global __$var
+ set __$var [lindex $args 0]
+ return "" ; # Empty string ! Nothing for output.
+ }
+ default {
+ return -code error "wrong#args: set var ?value?"
+ }
+ }
+}
+
+# -------------------------------------------------------------
+# Formatting commands
+proc index_begin {label title} {
+ Enter index_begin
+ if {[IsNot idx_begin]} {Error idx/begincmd}
+ Go contents
+ fmt_index_begin $label $title
+}
+proc index_end {} {
+ Enter index_end
+ if {[IsNot refkey_series] && [IsNot contents]} {Error idx/endcmd}
+ Go done
+ fmt_index_end
+}
+proc key {text} {
+ Enter key
+ if {[IsNot contents] && [IsNot refkey_series]} {Error idx/keycmd}
+ Go ref_series
+ fmt_key $text
+}
+proc manpage {file label} {
+ Enter manpage
+ if {[IsNot ref_series] && [IsNot refkey_series]} {Error idx/manpagecmd}
+ Go refkey_series
+ fmt_manpage $file $label
+}
+proc url {url label} {
+ Enter url
+ if {[IsNot ref_series] && [IsNot refkey_series]} {Error idx/urlcmd}
+ Go refkey_series
+ fmt_url $url $label
+}
+proc comment {text} {
+ if {[Is done]} {Error idx/nodonecmd}
+ return ; #fmt_comment $text
+}
+
+# -------------------------------------------------------------
diff --git a/tcllib/modules/doctools/checker_toc.tcl b/tcllib/modules/doctools/checker_toc.tcl
new file mode 100644
index 0000000..7f305e4
--- /dev/null
+++ b/tcllib/modules/doctools/checker_toc.tcl
@@ -0,0 +1,214 @@
+# -*- tcl -*-
+# checker_toc.tcl
+#
+# Code used inside of a checker interpreter to ensure correct usage of
+# doctoc formatting commands.
+#
+# Copyright (c) 2003-2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# L10N
+
+package require msgcat
+
+proc ::msgcat::mcunknown {locale code} {
+ return "unknown error code \"$code\" (for locale $locale)"
+}
+
+if {0} {
+ puts stderr "Locale [::msgcat::mcpreferences]"
+ foreach path [dt_search] {
+ puts stderr "Catalogs: [::msgcat::mcload $path] - $path"
+ }
+} else {
+ foreach path [dt_search] {
+ ::msgcat::mcload $path
+ }
+}
+
+# State, and checker commands.
+# -------------------------------------------------------------
+#
+# Note that the code below assumes that a command XXX provided by the
+# formatter engine is accessible under the name 'fmt_XXX'.
+#
+# -------------------------------------------------------------
+
+global state
+
+# State machine ... State centered
+# --------------+-----------------------+----------------------
+# state | allowed commands | new state (if any)
+# --------------+-----------------------+----------------------
+# all except | include vset |
+# ==============+=======================+======================
+# toc_begin | toc_begin | -> contents
+# --------------+-----------------------+----------------------
+# contents | item | -> contents //
+# +-----------------------+-----------
+# | division_start | -> end, PUSH division
+# +-----------------------+-----------
+# | toc_end | -> done
+# --------------+-----------------------+----------------------
+# division | item | -> division //
+# +-----------------------+-----------
+# | division_start | -> division, PUSH division
+# +-----------------------+-----------
+# | division_end | POP (-> division / -> end)
+# --------------+-----------------------+----------------------
+# end | toc_end | -> done
+# +-----------------------+-----------
+# | division_start | PUSH division
+# --------------+-----------------------+----------------------
+
+# State machine, as above ... Command centered
+# --------------+-----------------------+----------------------
+# state | allowed commands | new state (if any)
+# --------------+-----------------------+----------------------
+# all except | include vset |
+# ==============+=======================+======================
+# toc_begin | toc_begin | -> contents
+# --------------+-----------------------+----------------------
+# contents | item | -> contents
+# division | | -> division
+# --------------+-----------------------+----------------------
+# contents | division_start | -> end, PUSH division
+# division | | -> divison, PUSH division
+# end | | PUSH division
+# --------------+-----------------------+----------------------
+# division | division_end | POP (-> division / -> end)
+# --------------+-----------------------+----------------------
+# contents | toc_end | -> done
+# end | | -> done
+# --------------+-----------------------+----------------------
+
+# -------------------------------------------------------------
+# Helpers
+proc Error {code {text {}}} {
+ global state
+
+ # Problematic command with all arguments (we strip the "ck_" prefix!)
+ # -*- future -*- count lines of input, maintain history buffer, use
+ # -*- future -*- that to provide some context here.
+
+ set cmd [lindex [info level 1] 0]
+ set args [lrange [info level 1] 1 end]
+ if {$args != {}} {append cmd " [join $args]"}
+
+ # Use a message catalog to map the error code into a legible message.
+ set msg [::msgcat::mc $code]
+
+ if {$text != {}} {
+ set msg [string map [list @ $text] $msg]
+ }
+
+ dt_error "TOC error ($code), \"$cmd\" : ${msg}."
+ return
+}
+proc Warn {code text} {
+ set msg [::msgcat::mc $code]
+ dt_warning "TOC warning ($code): [join [split [format $msg $text] \n] "\nTOC warning ($code): "]"
+ return
+}
+
+proc Is {s} {global state ; return [string equal $state $s]}
+proc IsNot {s} {global state ; return [expr {![string equal $state $s]}]}
+proc Go {s} {Log " >>\[$s\]" ; global state ; set state $s; return}
+proc Push {s} {Log " //\[$s\]" ; global state stack ; lappend stack $state ; set state $s; return}
+proc Pop {} {Log* " pop" ; global state stack ; set state [lindex $stack end] ; set stack [lrange $stack 0 end-1] ; Log " \\\\\[$state\]" ; return}
+proc State {} {global state stack ; return "$stack || $state"}
+
+proc Enter {cmd} {Log* "\[[State]\] $cmd"}
+
+#proc Log* {text} {puts -nonewline $text}
+#proc Log {text} {puts $text}
+proc Log* {text} {}
+proc Log {text} {}
+
+# -------------------------------------------------------------
+# Framing
+proc ck_initialize {} {
+ global state ; set state toc_begin
+ global stack ; set stack [list]
+}
+proc ck_complete {} {
+ if {[Is done]} {
+ return
+ } else {
+ Error end/open/toc
+ }
+ return
+}
+# -------------------------------------------------------------
+# Plain text
+proc plain_text {text} {
+ # Ignore everything which is only whitespace ...
+ # Beyond that plain text is not allowed.
+
+ set redux [string map [list " " "" "\t" "" "\n" ""] $text]
+ if {$redux == {}} {return [fmt_plain_text $text]}
+ Error toc/plaintext
+ return ""
+}
+
+# -------------------------------------------------------------
+# Variable handling ...
+
+proc vset {var args} {
+ switch -exact -- [llength $args] {
+ 0 {
+ # Retrieve contents of variable VAR
+ upvar #0 __$var data
+ return $data
+ }
+ 1 {
+ # Set contents of variable VAR
+ global __$var
+ set __$var [lindex $args 0]
+ return "" ; # Empty string ! Nothing for output.
+ }
+ default {
+ return -code error "wrong#args: set var ?value?"
+ }
+ }
+}
+
+# -------------------------------------------------------------
+# Formatting commands
+proc toc_begin {label title} {
+ Enter toc_begin
+ if {[IsNot toc_begin]} {Error toc/begincmd}
+ Go contents
+ fmt_toc_begin $label $title
+}
+proc toc_end {} {
+ Enter toc_end
+ if {[IsNot end] && [IsNot contents]} {Error toc/endcmd}
+ Go done
+ fmt_toc_end
+}
+proc division_start {title {symfile {}}} {
+ Enter division_start
+ if {
+ [IsNot contents] && [IsNot end] && [IsNot division]
+ } {Error toc/sectcmd}
+ if {[Is contents] || [Is end]} {Go end} else {Go division}
+ Push division
+ fmt_division_start $title $symfile
+}
+proc division_end {} {
+ Enter division_end
+ if {[IsNot division]} {Error toc/sectecmd [State]}
+ Pop
+ fmt_division_end
+}
+proc item {file label desc} {
+ Enter item
+ if {[IsNot contents] && [IsNot division]} { Error toc/itemcmd }
+ fmt_item $file $label $desc
+}
+proc comment {text} {
+ if {[Is done]} {Error toc/nodonecmd}
+ return ; #fmt_comment $text
+}
+
+# -------------------------------------------------------------
diff --git a/tcllib/modules/doctools/cvs.man b/tcllib/modules/doctools/cvs.man
new file mode 100644
index 0000000..33fc733
--- /dev/null
+++ b/tcllib/modules/doctools/cvs.man
@@ -0,0 +1,101 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::cvs n 1]
+[see_also {[uri}]
+[see_also http://wiki.tcl.tk/log2changelog]
+[keywords changelog]
+[keywords cvs]
+[keywords {cvs log}]
+[keywords emacs]
+[keywords log]
+[copyright {2003-2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Processing text in 'cvs log' format}]
+[category {Documentation tools}]
+[require Tcl 8.2]
+[require textutil]
+[require doctools::cvs [opt 1]]
+[description]
+
+This package provides Tcl commands for the processing and reformatting
+text in the format generated by the [syscmd {cvs log}] command.
+
+[para]
+
+The commands [cmd ::doctools::cvs::scanLog]
+and [cmd ::doctools::cvs::toChangeLog] are derived from code found on
+the [uri http://wiki.tcl.tk {Tcl'ers Wiki}]. See the references at the
+end of the page.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::cvs::scanLog] [arg text] [arg evar] [arg cvar] [arg fvar]]
+
+The command takes the [arg text] and parses it under the assumption
+that it contains a CVS log as generated by [syscmd {cvs log}]. The
+resulting information is stored in the variables whose names were
+specified via [arg evar], [arg cvar], and [arg fvar].
+
+[para]
+
+Already existing information in the referenced variables is preserved,
+allowing the caller to merge data from multiple logs into one
+database.
+
+[list_begin arguments]
+[arg_def varname evar in]
+
+Has to refer to a scalar variable. After the call this variable will
+contain a list of all the entries found in the log file. An entry is
+identified through the combination of date and author, and can be
+split over multiple physical entries, one per touched file.
+
+[para]
+
+It should be noted that the entries are listed in the same order as
+they were found in the [arg text]. This is not necessarily sorted by
+date or author.
+
+[para]
+
+Each item in the list is a list containing two elements, the date of
+the entry, and its author, in this order. The date is formatted as
+[var year]/[var month]/[var day].
+
+[arg_def varname cvar in]
+
+Has to refer to an array variable. Keys are strings containing the
+date and author of log entries, in this order, separated by a comma.
+
+[para]
+
+The values are lists of comments made for the entry.
+
+[arg_def varname fvar in]
+
+Has to refer to an array variable. Keys are strings containing
+date, author of a log entry, and a comment for that entry, in this
+order, separated by commas.
+
+[para]
+
+The values are lists of the files the entry is touching.
+
+[list_end]
+[para]
+
+[call [cmd ::doctools::cvs::toChangeLog] [arg evar] [arg cvar] [arg fvar]]]
+
+The three arguments for this command are the same as the last three
+arguments of the command [cmd ::doctools::cvs::scanLog]. This command
+however expects them to be filled with information about one or more
+logs. It takes this information and converts it into a text in the
+format of a ChangeLog as accepted and generated by [syscmd emacs]. The
+constructed text is returned as the result of the command.
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/cvs.tcl b/tcllib/modules/doctools/cvs.tcl
new file mode 100644
index 0000000..567c20d
--- /dev/null
+++ b/tcllib/modules/doctools/cvs.tcl
@@ -0,0 +1,136 @@
+# cvs.tcl --
+#
+# Handling of various cvs output formats.
+#
+# Copyright (c) 2003-2008 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: cvs.tcl,v 1.10 2008/07/08 23:03:58 andreas_kupries Exp $
+
+package require Tcl 8.2
+package require textutil
+
+namespace eval ::doctools {}
+namespace eval ::doctools::cvs {
+ namespace export scanLog toChangeLog
+}
+
+# ::doctools::cvs::scanLog --
+#
+# Scan a log generated by 'cvs log' and extract the relevant information.
+#
+# Arguments:
+# text The text to scan
+#
+# Results:
+# None.
+#
+# Sideeffects:
+# None.
+#
+# Notes:
+# Original location of code: http://wiki.tcl.tk/3638
+# aka http://wiki.tcl.tk/log2changelog
+# Original author unknown.
+# Bugfix by TR / Torsten Reincke
+
+proc ::doctools::cvs::scanLog {text evar cvar fvar} {
+
+ set text [split $text \n]
+ set n [llength $text]
+
+ upvar 1 $evar entries ; #set entries [list]
+ upvar 1 $cvar comments ; #array set comments {}
+ upvar 1 $fvar files ; #array set files {}
+
+ for {set i 0} {$i < $n} {incr i} {
+ set line [lindex $text $i]
+ switch -glob -- $line {
+ "*Working file:*" {
+ regexp {Working file: (.*)} $line -> filename
+ }
+ "date:*" {
+ scan $line "date: %s %s author: %s" date time author
+ set author [string trim $author ";"]
+
+ # read the comment lines following date
+ set comment ""
+ incr i
+ set line [lindex $text $i]
+ # [TR]: use regexp here to see if log ends:
+ while {(![regexp "(-----*)|(=====*)" $line]) && ($i < $n)} {
+ append comment $line "\n"
+ incr i
+ set line [lindex $text $i]
+ }
+
+ # Store this date/author/comment
+ lappend entries [list $date $author]
+ lappend comments($date,$author) $comment
+ lappend files($date,$author,$comment) $filename
+ }
+ }
+ }
+
+ return
+}
+
+
+# ::doctools::cvs::toChangeLog --
+
+# Convert a preprocessed cvs log (see scanLog) into a Changelog
+# suitable for emacs.
+#
+# Arguments:
+# evar, cvar, fvar: Name of the variables containing the preprocessed log.
+#
+# Results:
+# A string containing a properly formatted ChangeLog.
+#
+# Sideeffects:
+# None.
+#
+# Notes:
+# Original location of code: http://wiki.tcl.tk/3638
+# aka http://wiki.tcl.tk/log2changelog
+# Original author unknown.
+
+proc ::doctools::cvs::toChangeLog {evar cvar fvar} {
+ upvar 1 $evar entries $cvar comments $fvar files
+
+ set linebuffer [list]
+
+ foreach e [lsort -unique -decreasing $entries] {
+
+ # print the date/author
+ foreach {date author} $e {break}
+ lappend linebuffer "$date $author"
+ lappend linebuffer ""
+
+ # Find all the comments submitted this date/author
+
+ set clist [lsort -unique $comments($date,$author)]
+
+ foreach c $clist {
+ # Print all files for a given comment
+ foreach f [lsort -unique $files($date,$author,$c)] {
+ lappend linebuffer "\t* $f:"
+ }
+
+ # Format and print the comment
+
+ lappend linebuffer [textutil::indent [textutil::undent $c] "\t "]
+ lappend linebuffer ""
+ continue
+ }
+ }
+
+ return [join $linebuffer \n]
+}
+
+#------------------------------------
+# Module initialization
+
+package provide doctools::cvs 1
diff --git a/tcllib/modules/doctools/docidx.man b/tcllib/modules/doctools/docidx.man
new file mode 100644
index 0000000..8cd5d0a
--- /dev/null
+++ b/tcllib/modules/doctools/docidx.man
@@ -0,0 +1,405 @@
+[vset PACKAGE_VERSION 1.0.5]
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::idx n [vset PACKAGE_VERSION]]
+[see_also docidx_intro]
+[see_also docidx_lang_cmdref]
+[see_also docidx_lang_intro]
+[see_also docidx_lang_syntax]
+[see_also docidx_plugin_apiref]
+[keywords conversion]
+[keywords docidx]
+[keywords documentation]
+[keywords HTML]
+[keywords index]
+[keywords {keyword index}]
+[keywords latex]
+[keywords manpage]
+[keywords markup]
+[keywords nroff]
+[keywords TMML]
+[keywords wiki]
+[copyright {2003-2014 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {docidx - Processing indices}]
+[category {Documentation tools}]
+[require Tcl 8.2]
+[require doctools::idx [opt [vset PACKAGE_VERSION]]]
+[description]
+
+This package provides a class for the creation of objects able to
+process and convert text written in the [term docidx] markup language
+into any output format X for which a [term {formatting engine}] is
+available.
+
+[para]
+
+A reader interested in the markup language itself should start with
+the [term {docidx language introduction}] and proceed from there to
+the formal specifications, i.e. the [term {docidx language syntax}]
+and the [term {docidx language command reference}].
+
+[para]
+
+If on the other hand the reader wishes to write her own formatting
+engine for some format, i.e. is a [term {plugin writer}] then reading
+and understanding the [term {docidx plugin API reference}] is an
+absolute necessity, as that document specifies the interaction between
+this package and its plugins, i.e. the formatting engines, in detail.
+
+[section {PUBLIC API}]
+[subsection {PACKAGE COMMANDS}]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::idx::new] [arg objectName] [opt "[option -option] [arg value] ..."]]
+
+This command creates a new docidx object with an associated Tcl
+command whose name is [arg objectName]. This [term object] command is
+explained in full detail in the sections [sectref {OBJECT COMMAND}]
+and [sectref {OBJECT METHODS}]. The object command will be created
+under the current namespace if the [arg objectName] is not fully
+qualified, and in the specified namespace otherwise.
+
+[para]
+
+The options and their values coming after the name of the object are
+used to set the initial configuration of the object.
+
+[call [cmd ::doctools::idx::help]]
+
+This is a convenience command for applications wishing to provide
+their user with a short description of the available formatting
+commands and their meanings. It returns a string containing a standard
+help text.
+
+[call [cmd ::doctools::idx::search] [arg path]]
+
+Whenever an object created by this the package has to map the name of
+a format to the file containing the code for its formatting engine it
+will search for the file in a number of directories stored in a
+list. See section [sectref {FORMAT MAPPING}] for more explanations.
+
+[para]
+
+This list not only contains three default directories which are
+declared by the package itself, but is also extensible user of the
+package.
+
+This command is the means to do so. When given a [arg path] to an
+existing and readable directory it will prepend that directory to the
+list of directories to search. This means that the [arg path] added
+last is later searched through first.
+
+[para]
+
+An error will be thrown if the [arg path] either does not exist, is
+not a directory, or is not readable.
+
+[list_end]
+
+[subsection {OBJECT COMMAND}]
+
+All commands created by [cmd ::doctools::idx::new] have the following
+general form and may be used to invoke various operations on their
+docidx converter object.
+
+[list_begin definitions]
+
+[call [cmd objectName] [method method] [opt [arg "arg arg ..."]]]
+
+The method [method method] and its [arg arg]'uments determine the exact
+behavior of the command. See section [sectref {OBJECT METHODS}] for
+the detailed specifications.
+
+[list_end]
+
+[subsection {OBJECT METHODS}]
+
+[list_begin definitions]
+
+[call [arg objectName] [method configure]]
+
+The method returns a list of all known options and their current
+values when called without any arguments.
+
+[call [arg objectName] [method configure] [arg option]]
+
+The method behaves like the method [method cget] when called with a
+single argument and returns the value of the option specified by said
+argument.
+
+[call [arg objectName] [method configure] [option -option] [arg value]...]
+
+The method reconfigures the specified [option option]s of the object,
+setting them to the associated [arg value]s, when called with an even
+number of arguments, at least two.
+
+[para]
+
+The legal options are described in the section
+[sectref {OBJECT CONFIGURATION}].
+
+[call [arg objectName] [method cget] [option -option]]
+
+This method expects a legal configuration option as argument and will
+return the current value of that option for the object the method was
+invoked for.
+
+[para]
+
+The legal configuration options are described in section
+[sectref {OBJECT CONFIGURATION}].
+
+[call [arg objectName] [method destroy]]
+
+This method destroys the object it is invoked for.
+
+[call [arg objectName] [method format] [arg text]]
+
+This method runs the [arg text] through the configured formatting
+engine and returns the generated string as its result. An error will
+be thrown if no [option -format] was configured for the object.
+
+[para]
+
+The method assumes that the [arg text] is in [term docidx] format as
+specified in the companion document [term docidx_fmt]. Errors will be
+thrown otherwise.
+
+[call [arg objectName] [method map] [arg symbolic] [arg actual]]
+
+This methods add one entry to the per-object mapping from
+[arg symbolic] filenames to the [arg actual] uris.
+
+The object just stores this mapping and makes it available to the
+configured formatting engine through the command [cmd dt_fmap].
+
+This command is described in more detail in the
+[term {docidx plugin API reference}] which specifies the interaction
+between the objects created by this package and index formatting
+engines.
+
+[call [arg objectName] [method parameters]]
+
+This method returns a list containing the names of all engine
+parameters provided by the configured formatting engine. It will
+return an empty list if the object is not yet configured for a
+specific format.
+
+[call [arg objectName] [method search] [arg path]]
+
+This method extends the per-object list of paths searched for index
+formatting engines. See also the command [cmd ::doctools::idx::search]
+on how to extend the per-package list of paths. Note that the path
+entered last will be searched first.
+
+For more details see section [sectref {FORMAT MAPPING}].
+
+[call [arg objectName] [method setparam] [arg name] [arg value]]
+
+This method sets the [arg name]d engine parameter to the specified
+[arg value].
+
+It will throw an error if the object is either not yet configured for
+a specific format, or if the formatting engine for the configured
+format does not provide a parameter with the given [arg name].
+
+The list of parameters provided by the configured formatting engine
+can be retrieved through the method [method parameters].
+
+[call [arg objectName] [method warnings]]
+
+This method returns a list containing all the warnings which were
+generated by the configured formatting engine during the last
+invocation of the method [method format].
+
+[list_end]
+
+[subsection {OBJECT CONFIGURATION}]
+
+All docidx objects understand the following configuration options:
+
+[list_begin options]
+
+[opt_def -file [arg file]]
+
+The argument of this option is stored in the object and made available
+to the configured formatting engine through the command [cmd dt_file].
+
+This command is described in more detail in the companion document
+[term docidx_api] which specifies the API between the object and
+formatting engines.
+
+[para]
+
+The default value of this option is the empty string.
+
+[para]
+
+The configured formatting engine should interpret the value as the
+name of the file containing the document which is currently processed.
+
+[opt_def -format [arg text]]
+
+The argument of this option specifies the format to generate and by
+implication the formatting engine to use when converting text via the
+method [method format]. Its default value is the empty string. The
+method [method format] cannot be used if this option is not set to a
+valid value at least once.
+
+[para]
+
+The package will immediately try to map the given name to a file
+containing the code for a formatting engine generating that format. An
+error will be thrown if this mapping fails. In that case a previously
+configured format is left untouched.
+
+[para]
+
+The section [sectref {FORMAT MAPPING}] explains in detail how the
+package and object will look for engine implementations.
+
+[list_end]
+
+[subsection {FORMAT MAPPING}]
+
+The package and object will perform the following algorithm when
+trying to map a format name [term foo] to a file containing an
+implementation of a formatting engine for [term foo]:
+
+[list_begin enumerated]
+[enum]
+
+If [term foo] is the name of an existing file then this file is
+directly taken as the implementation.
+
+[enum]
+
+If not, the list of per-object search paths is searched. For each
+directory in the list the package checks if that directory contains a
+file [file idx.[term foo]]. If yes, then that file is taken as the
+implementation.
+
+[para]
+
+Note that this list of paths is initially empty and can be extended
+through the object method [method search].
+
+[enum]
+
+If not, the list of package paths is searched.
+
+For each directory in the list the package checks if that directory
+contains a file [file idx.[term foo]]. If yes, then that file is taken
+as the implementation.
+
+[para]
+
+This list of paths can be extended
+through the command [cmd ::doctools::idx::search].
+
+It contains initially one path, the subdirectory [file mpformats] of
+the directory the package itself is located in. In other words, if the
+package implementation [file docidx.tcl] is installed in the directory
+[file /usr/local/lib/tcllib/doctools] then it will by default search
+the directory [file /usr/local/lib/tcllib/doctools/mpformats] for
+format implementations.
+
+[enum]
+
+The mapping fails.
+
+[list_end]
+
+[section {PREDEFINED ENGINES}]
+
+The package provides predefined formatting engines for the following
+formats. Some of the formatting engines support engine
+parameters. These will be explicitly highlighted.
+
+[list_begin definitions]
+[def html]
+
+This engine generates HTML markup, for processing by web browsers and
+the like. This engine supports three parameters:
+
+[list_begin definitions]
+[def footer]
+
+The value for this parameter has to be valid selfcontained HTML markup
+for the body section of a HTML document. The default value is the
+empty string. The value is inserted into the generated output just
+before the [const </body>] tag, closing the body of the generated
+HTML.
+
+[para]
+
+This can be used to insert boilerplate footer markup into the
+generated document.
+
+[def header]
+
+The value for this parameter has to be valid selfcontained HTML markup
+for the body section of a HTML document. The default value is the
+empty string. The value is inserted into the generated output just
+after the [const <body>] tag, starting the body of the generated HTML.
+
+[para]
+
+This can be used to insert boilerplate header markup into the
+generated document.
+
+[def meta]
+
+The value for this parameter has to be valid selfcontained HTML markup
+for the header section of a HTML document. The default value is the
+empty string. The value is inserted into the generated output just
+after the [const <head>] tag, starting the header section of the
+generated HTML.
+
+[para]
+
+This can be used to insert boilerplate meta data markup into the
+generated document, like references to a stylesheet, standard meta
+keywords, etc.
+
+[list_end]
+[para]
+
+[def latex]
+
+This engine generates output suitable for the [syscmd latex] text
+processor coming out of the TeX world.
+
+[def list]
+
+This engine retrieves version, section and title of the manpage from
+the document. As such it can be used to generate a directory listing
+for a set of manpages.
+
+[def nroff]
+
+This engine generates nroff output, for processing by [syscmd nroff],
+or [syscmd groff]. The result will be standard man pages as they are
+known in the unix world.
+
+[def null]
+
+This engine generates no outout at all. This can be used if one just
+wants to validate some input.
+
+[def tmml]
+
+This engine generates TMML markup as specified by Joe English. The Tcl
+Manpage Markup Language is a derivate of XML.
+
+[def wiki]
+
+This engine generates Wiki markup as understood by Jean Claude
+Wippler's [syscmd wikit] application.
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/docidx.tcl b/tcllib/modules/doctools/docidx.tcl
new file mode 100644
index 0000000..b8748ff
--- /dev/null
+++ b/tcllib/modules/doctools/docidx.tcl
@@ -0,0 +1,962 @@
+# docidx.tcl --
+#
+# Implementation of docidx objects for Tcl.
+#
+# Copyright (c) 2003-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: docidx.tcl,v 1.22 2010/06/08 19:13:53 andreas_kupries Exp $
+
+package require Tcl 8.2
+package require textutil::expander
+
+# @mdgen OWNER: api_idx.tcl
+# @mdgen OWNER: checker_idx.tcl
+# @mdgen OWNER: mpformats/*.tcl
+# @mdgen OWNER: mpformats/*.msg
+# @mdgen OWNER: mpformats/idx.*
+# @mdgen OWNER: mpformats/man.macros
+
+namespace eval ::doctools {}
+namespace eval ::doctools::idx {
+ # Data storage in the doctools::idx module
+ # -------------------------------
+ #
+ # One namespace per object, containing
+ # 1) A list of additional search paths for format definition files.
+ # This list extends the list of standard paths known to the module.
+ # The paths in the list are searched before the standard paths.
+ # 2) Configuration information
+ # a) string: The format to use when converting the input.
+ # 4) Name of the interpreter used to perform the syntax check of the
+ # input (= allowed order of formatting commands).
+ # 5) Name of the interpreter containing the code coming from the format
+ # definition file.
+ # 6) Name of the expander object used to interpret the input to convert.
+
+ # commands is the list of subcommands recognized by the docidx objects
+ variable commands [list \
+ "cget" \
+ "configure" \
+ "destroy" \
+ "format" \
+ "map" \
+ "search" \
+ "warnings" \
+ "parameters" \
+ "setparam" \
+ ]
+
+ # Only export the toplevel commands
+ namespace export new search help
+
+ # Global data
+
+ # 1) List of standard paths to look at when searching for a format
+ # definition. Extensible.
+ # 2) Location of this file in the filesystem
+
+ variable paths [list]
+ variable here [file dirname [info script]]
+}
+
+# ::doctools::idx::search --
+#
+# Extend the list of paths used when searching for format definition files.
+#
+# Arguments:
+# path Path to add to the list. The path has to exist, has to be a
+# directory, and has to be readable.
+#
+# Results:
+# None.
+#
+# Sideeffects:
+# The specified path is added to the front of the list of search
+# paths. This means that the new path is search before the
+# standard paths set at module initialization time.
+
+proc ::doctools::idx::search {path} {
+ variable paths
+
+ if {![file exists $path]} {return -code error "doctools::idx::search: path does not exist"}
+ if {![file isdirectory $path]} {return -code error "doctools::idx::search: path is not a directory"}
+ if {![file readable $path]} {return -code error "doctools::idx::search: path cannot be read"}
+
+ set paths [linsert $paths 0 $path]
+ return
+}
+
+# ::doctools::idx::help --
+#
+# Return a string containing short help
+# regarding the existing formatting commands.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A string.
+
+proc ::doctools::idx::help {} {
+ return "formatting commands\n\
+ * index_begin - begin of index\n\
+ * index_end - end of index\n\
+ * key - begin of references for key\n\
+ * manpage - index reference to manpage\n\
+ * url - index reference to url\n\
+ * vset - set/get variable values\n\
+ * include - insert external file\n\
+ * lb, rb - left/right brackets\n\
+ "
+}
+
+# ::doctools::idx::new --
+#
+# Create a new docidx object with a given name. May configure the object.
+#
+# Arguments:
+# name Name of the docidx object.
+# args Options configuring the new object.
+#
+# Results:
+# name Name of the doctools created
+
+proc ::doctools::idx::new {name args} {
+ if { [llength [info commands ::$name]] } {
+ return -code error "command \"$name\" already exists, unable to create docidx object"
+ }
+ if {[llength $args] % 2 == 1} {
+ return -code error "wrong # args: doctools::new name ?opt val...??"
+ }
+
+ # The arguments seem to be ok, setup the namespace for the object
+
+ namespace eval ::doctools::idx::docidx$name {
+ variable paths [list]
+ variable file ""
+ variable format ""
+ variable formatfile ""
+ variable format_ip ""
+ variable chk_ip ""
+ variable expander "[namespace current]::ex"
+ variable ex_ok 0
+ variable msg [list]
+ variable map ; array set map {}
+ variable param [list]
+ }
+
+ # Create the command to manipulate the object
+ # $name -> ::doctools::idx::DocIdxProc $name
+ interp alias {} ::$name {} ::doctools::idx::DocIdxProc $name
+
+ # If the name was followed by arguments use them to configure the
+ # object before returning its handle to the caller.
+
+ if {[llength $args] > 1} {
+ # Use linsert trick to make the command a pure list.
+ eval [linsert $args 0 _configure $name]
+ }
+ return $name
+}
+
+##########################
+# Private functions follow
+
+# ::doctools::idx::DocIdxProc --
+#
+# Command that processes all docidx object commands.
+# Dispatches any object command to the appropriate internal
+# command implementing its functionality.
+#
+# Arguments:
+# name Name of the docidx object to manipulate.
+# cmd Subcommand to invoke.
+# args Arguments for subcommand.
+#
+# Results:
+# Varies based on command to perform
+
+proc ::doctools::idx::DocIdxProc {name {cmd ""} args} {
+ # Do minimal args checks here
+ if { [llength [info level 0]] == 2 } {
+ error "wrong # args: should be \"$name option ?arg arg ...?\""
+ }
+
+ # Split the args into command and args components
+
+ if { [llength [info commands ::doctools::idx::_$cmd]] == 0 } {
+ variable commands
+ set optlist [join $commands ", "]
+ set optlist [linsert $optlist "end-1" "or"]
+ return -code error "bad option \"$cmd\": must be $optlist"
+ }
+ return [eval [list ::doctools::idx::_$cmd $name] $args]
+}
+
+##########################
+# Method implementations follow (these are also private commands)
+
+# ::doctools::idx::_cget --
+#
+# Retrieve the current value of a particular option
+#
+# Arguments:
+# name Name of the docidx object to query
+# option Name of the option whose value we are asking for.
+#
+# Results:
+# The value of the option
+
+proc ::doctools::idx::_cget {name option} {
+ _configure $name $option
+}
+
+# ::doctools::idx::_configure --
+#
+# Configure a docidx object, or query its configuration.
+#
+# Arguments:
+# name Name of the docidx object to configure
+# args Options and their values.
+#
+# Results:
+# None if configuring the object.
+# A list of all options and their values if called without arguments.
+# The value of one particular option if called with a single argument.
+
+proc ::doctools::idx::_configure {name args} {
+ if {[llength $args] == 0} {
+ # Retrieve the current configuration.
+
+ upvar #0 ::doctools::idx::docidx${name}::file file
+ upvar #0 ::doctools::idx::docidx${name}::format format
+
+ set res [list]
+ lappend res -file $file
+ lappend res -format $format
+ return $res
+
+ } elseif {[llength $args] == 1} {
+ # Query the value of one particular option.
+
+ switch -exact -- [lindex $args 0] {
+ -file {
+ upvar #0 ::doctools::idx::docidx${name}::file file
+ return $file
+ }
+ -format {
+ upvar #0 ::doctools::idx::docidx${name}::format format
+ return $format
+ }
+ default {
+ return -code error \
+ "doctools::idx::_configure: Unknown option \"[lindex $args 0]\", expected\
+ -file, or -format"
+ }
+ }
+ } else {
+ # Reconfigure the object.
+
+ if {[llength $args] % 2 == 1} {
+ return -code error "wrong # args: doctools::idx::_configure name ?opt val...??"
+ }
+
+ foreach {option value} $args {
+ switch -exact -- $option {
+ -file {
+ upvar #0 ::doctools::idx::docidx${name}::file file
+ set file $value
+ }
+ -format {
+ if {[catch {
+ set fmtfile [LookupFormat $name $value]
+ SetupFormatter $name $fmtfile
+ upvar #0 ::doctools::idx::docidx${name}::format format
+ set format $value
+ } msg]} {
+ return -code error \
+ -errorinfo $::errorInfo \
+ "doctools::idx::_configure: -format: $msg"
+ }
+ }
+ default {
+ return -code error \
+ "doctools::idx::_configure: Unknown option \"$option\", expected\
+ -file, or -format"
+ }
+ }
+ }
+ }
+ return ""
+}
+
+# ::doctools::idx::_destroy --
+#
+# Destroy a docidx object, including its associated command and data storage.
+#
+# Arguments:
+# name Name of the docidx object to destroy.
+#
+# Results:
+# None.
+
+proc ::doctools::idx::_destroy {name} {
+ # Check the object for sub objects which have to destroyed before
+ # the namespace is torn down.
+ namespace eval ::doctools::idx::docidx$name {
+ if {$format_ip != ""} {interp delete $format_ip}
+ if {$chk_ip != ""} {interp delete $chk_ip}
+
+ # Expander objects have no delete/destroy method. This would
+ # be a leak if not for the fact that an expander object is a
+ # namespace, and we have arranged to make it a sub namespace of
+ # the docidx object. Therefore tearing down our object namespace
+ # also cleans up the expander object.
+ # if {$expander != ""} {$expander destroy}
+
+ }
+ namespace delete ::doctools::idx::docidx$name
+ interp alias {} ::$name {}
+ return
+}
+
+# ::doctools::idx::_map --
+#
+# Add a mapping from symbolic to actual filename to the object.
+#
+# Arguments:
+# name Name of the docidx object to use
+# sfname Symbolic filename to map
+# afname Actual filename
+#
+# Results:
+# None.
+
+proc ::doctools::idx::_map {name sfname afname} {
+ upvar #0 ::doctools::idx::docidx${name}::map map
+ set map($sfname) $afname
+ return
+}
+
+# ::doctools::idx::_format --
+#
+# Convert some text in doctools format
+# according to the configuration in the object.
+#
+# Arguments:
+# name Name of the docidx object to use
+# text Text to convert.
+#
+# Results:
+# The conversion result.
+
+proc ::doctools::idx::_format {name text} {
+ upvar #0 ::doctools::idx::docidx${name}::format format
+ if {$format == ""} {
+ return -code error "$name: No format was specified"
+ }
+
+ upvar #0 ::doctools::idx::docidx${name}::format_ip format_ip
+ upvar #0 ::doctools::idx::docidx${name}::chk_ip chk_ip
+ upvar #0 ::doctools::idx::docidx${name}::ex_ok ex_ok
+ upvar #0 ::doctools::idx::docidx${name}::expander expander
+ upvar #0 ::doctools::idx::docidx${name}::passes passes
+ upvar #0 ::doctools::idx::docidx${name}::msg warnings
+
+ if {!$ex_ok} {SetupExpander $name}
+ if {$chk_ip == ""} {SetupChecker $name}
+ # assert (format_ip != "")
+
+ set warnings [list]
+ if {[catch {$format_ip eval idx_initialize}]} {
+ return -code error "Could not initialize engine"
+ }
+ set result ""
+
+ for {
+ set p $passes ; set n 1
+ } {
+ $p > 0
+ } {
+ incr p -1 ; incr n
+ } {
+ if {[catch {$format_ip eval [list idx_setup $n]}]} {
+ catch {$format_ip eval idx_shutdown}
+ return -code error "Could not initialize pass $n of engine"
+ }
+ $chk_ip eval ck_initialize
+
+ if {[catch {set result [$expander expand $text]} msg]} {
+ catch {$format_ip eval idx_shutdown}
+ # Filter for checker errors and reduce them to the essential message.
+
+ if {![regexp {^Error in} $msg]} {return -code error $msg}
+ #set msg [join [lrange [split $msg \n] 2 end]]
+
+ if {![regexp {^--> \(FmtError\) } $msg]} {return -code error "Docidx $msg"}
+ set msg [lindex [split $msg \n] 0]
+ regsub {^--> \(FmtError\) } $msg {} msg
+
+ return -code error $msg
+ }
+
+ $chk_ip eval ck_complete
+ }
+
+ if {[catch {set result [$format_ip eval [list idx_postprocess $result]]}]} {
+ return -code error "Unable to post process final result"
+ }
+ if {[catch {$format_ip eval idx_shutdown}]} {
+ return -code error "Could not shut engine down"
+ }
+ return $result
+
+}
+
+# ::doctools::idx::_search --
+#
+# Add a search path to the object.
+#
+# Arguments:
+# name Name of the docidx object to extend
+# path Search path to add.
+#
+# Results:
+# None.
+
+proc ::doctools::idx::_search {name path} {
+ if {![file exists $path]} {return -code error "$name search: path does not exist"}
+ if {![file isdirectory $path]} {return -code error "$name search: path is not a directory"}
+ if {![file readable $path]} {return -code error "$name search: path cannot be read"}
+
+ upvar #0 ::doctools::idx::docidx${name}::paths paths
+ set paths [linsert $paths 0 $path]
+ return
+}
+
+# ::doctools::idx::_warnings --
+#
+# Return the warning accumulated during the last invocation of 'format'.
+#
+# Arguments:
+# name Name of the docidx object to query
+#
+# Results:
+# A list of warnings.
+
+proc ::doctools::idx::_warnings {name} {
+ upvar #0 ::doctools::idx::docidx${name}::msg msg
+ return $msg
+}
+
+# ::doctools::_parameters --
+#
+# Returns a list containing the parameters provided
+# by the selected formatting engine.
+#
+# Arguments:
+# name Name of the doctools object to query
+#
+# Results:
+# A list of parameter names
+
+proc ::doctools::idx::_parameters {name} {
+ upvar #0 ::doctools::idx::docidx${name}::param param
+ return $param
+}
+
+# ::doctools::_setparam --
+#
+# Set a named engine parameter to a value.
+#
+# Arguments:
+# name Name of the doctools object to query
+# param Name of the parameter to set.
+# value Value to set the parameter to.
+#
+# Results:
+# None.
+
+proc ::doctools::idx::_setparam {name param value} {
+ upvar #0 ::doctools::idx::docidx${name}::format_ip format_ip
+
+ if {$format_ip == {}} {
+ return -code error \
+ "Unable to set parameters without a valid format"
+ }
+
+ $format_ip eval [list idx_varset $param $value]
+ return
+}
+
+##########################
+# Support commands
+
+# ::doctools::idx::LookupFormat --
+#
+# Search a format definition file based upon its name
+#
+# Arguments:
+# name Name of the docidx object to use
+# format Name of the format to look for.
+#
+# Results:
+# The file containing the format definition
+
+proc ::doctools::idx::LookupFormat {name format} {
+ # Order of searching
+ # 1) Is the name of the format an existing file ?
+ # If yes, take this file.
+ # 2) Look for the file in the directories given to the object itself..
+ # 3) Look for the file in the standard directories of this package.
+
+ if {[file exists $format] && [file isfile $format]} {
+ return $format
+ }
+
+ upvar #0 ::doctools::idx::docidx${name}::paths opaths
+ foreach path $opaths {
+ set f [file join $path idx.$format]
+ if {[file exists $f] && [file isfile $f]} {
+ return $f
+ }
+ }
+
+ variable paths
+ foreach path $paths {
+ set f [file join $path idx.$format]
+ if {[file exists $f] && [file isfile $f]} {
+ return $f
+ }
+ }
+
+ return -code error "Unknown format \"$format\""
+}
+
+# ::doctools::idx::SetupFormatter --
+#
+# Create and initializes an interpreter containing a
+# formatting engine
+#
+# Arguments:
+# name Name of the docidx object to manipulate
+# format Name of file containing the code of the engine
+#
+# Results:
+# None.
+
+proc ::doctools::idx::SetupFormatter {name format} {
+
+ # Create and initialize the interpreter first.
+ # Use a transient variable. Interrogate the
+ # engine and check its response. Bail out in
+ # case of errors. Only if we pass the checks
+ # we tear down the old engine and make the new
+ # one official.
+
+ variable here
+ set mpip [interp create -safe] ; # interpreter for the formatting engine
+ #set mpip [interp create] ; # interpreter for the formatting engine
+
+ $mpip invokehidden source [file join $here api_idx.tcl]
+ #$mpip eval [list source [file join $here api_idx.tcl]]
+ interp alias $mpip dt_source {} ::doctools::idx::Source $mpip [file dirname $format]
+ interp alias $mpip dt_read {} ::doctools::idx::Read $mpip [file dirname $format]
+ interp alias $mpip dt_package {} ::doctools::idx::Package $mpip
+ interp alias $mpip file {} ::doctools::idx::FileOp $mpip
+ interp alias $mpip puts_stderr {} ::puts stderr
+ $mpip invokehidden source $format
+ #$mpip eval [list source $format]
+
+ # Check the engine for useability in doctools.
+
+ foreach api {
+ idx_numpasses
+ idx_initialize
+ idx_setup
+ idx_postprocess
+ idx_shutdown
+ idx_listvariables
+ idx_varset
+ } {
+ if {[$mpip eval [list info commands $api]] == {}} {
+ interp delete $mpip
+ error "$format error: API incomplete, cannot use this engine"
+ }
+ }
+ if {[catch {
+ set passes [$mpip eval idx_numpasses]
+ }]} {
+ interp delete $mpip
+ error "$format error: Unable to query for number of passes"
+ }
+ if {![string is integer $passes] || ($passes < 1)} {
+ interp delete $mpip
+ error "$format error: illegal number of passes \"$passes\""
+ }
+ if {[catch {
+ set parameters [$mpip eval idx_listvariables]
+ }]} {
+ interp delete $mpip
+ error "$format error: Unable to query for list of parameters"
+ }
+
+ # Passed the tests. Tear down existing engine,
+ # and checker. The latter is destroyed because
+ # of its aliases into the formatter, which are
+ # now invalid. It will be recreated during the
+ # next call of 'format'.
+
+ upvar #0 ::doctools::idx::docidx${name}::formatfile formatfile
+ upvar #0 ::doctools::idx::docidx${name}::format_ip format_ip
+ upvar #0 ::doctools::idx::docidx${name}::chk_ip chk_ip
+ upvar #0 ::doctools::idx::docidx${name}::expander expander
+ upvar #0 ::doctools::idx::docidx${name}::passes xpasses
+ upvar #0 ::doctools::idx::docidx${name}::param xparam
+
+ if {$chk_ip != {}} {interp delete $chk_ip}
+ if {$format_ip != {}} {interp delete $format_ip}
+
+ set chk_ip ""
+ set format_ip ""
+
+ # Now link engine API into it.
+
+ interp alias $mpip dt_format {} ::doctools::idx::GetFormat $name
+ interp alias $mpip dt_user {} ::doctools::idx::GetUser $name
+ interp alias $mpip dt_fmap {} ::doctools::idx::MapFile $name
+
+ foreach cmd {cappend cget cis cname cpop cpush cset lb rb} {
+ interp alias $mpip ex_$cmd {} $expander $cmd
+ }
+
+ set format_ip $mpip
+ set formatfile $format
+ set xpasses $passes
+ set xparam $parameters
+ return
+}
+
+# ::doctools::idx::SetupChecker --
+#
+# Create and initializes an interpreter for checking the usage of
+# docidx formatting commands
+#
+# Arguments:
+# name Name of the docidx object to manipulate
+#
+# Results:
+# None.
+
+proc ::doctools::idx::SetupChecker {name} {
+ # Create an interpreter for checking the usage of docidx formatting commands
+ # and initialize it: Link it to the interpreter doing the formatting, the
+ # expander object and the configuration information. All of which
+ # is accessible through the token/handle (name of state/object array).
+
+ variable here
+
+ upvar #0 ::doctools::idx::docidx${name}::chk_ip chk_ip
+ if {$chk_ip != ""} {return}
+
+ upvar #0 ::doctools::idx::docidx${name}::expander expander
+ upvar #0 ::doctools::idx::docidx${name}::format_ip format_ip
+
+ set chk_ip [interp create] ; # interpreter hosting the formal format checker
+
+ # Make configuration available through command, then load the code base.
+
+ foreach {cmd ckcmd} {
+ dt_search SearchPaths
+ dt_error FmtError
+ dt_warning FmtWarning
+ } {
+ interp alias $chk_ip $cmd {} ::doctools::idx::$ckcmd $name
+ }
+ $chk_ip eval [list source [file join $here checker_idx.tcl]]
+
+ # Simple expander commands are directly routed back into it, no
+ # checking required.
+
+ foreach cmd {cappend cget cis cname cpop cpush cset lb rb} {
+ interp alias $chk_ip $cmd {} $expander $cmd
+ }
+
+ # Link the formatter commands into the checker. We use the prefix
+ # 'fmt_' to distinguish them from the checking commands.
+
+ foreach cmd {
+ index_begin index_end key manpage url comment plain_text
+ } {
+ interp alias $chk_ip fmt_$cmd $format_ip fmt_$cmd
+ }
+ return
+}
+
+# ::doctools::idx::SetupExpander --
+#
+# Create and initializes the expander for input
+#
+# Arguments:
+# name Name of the docidx object to manipulate
+#
+# Results:
+# None.
+
+proc ::doctools::idx::SetupExpander {name} {
+ upvar #0 ::doctools::idx::docidx${name}::ex_ok ex_ok
+ if {$ex_ok} {return}
+
+ upvar #0 ::doctools::idx::docidx${name}::expander expander
+ ::textutil::expander $expander
+ $expander evalcmd [list ::doctools::idx::Eval $name]
+ $expander textcmd plain_text
+ set ex_ok 1
+ return
+}
+
+# ::doctools::idx::SearchPaths --
+#
+# API for checker. Returns list of search paths for format
+# definitions. Used to look for message catalogs as well.
+#
+# Arguments:
+# name Name of the docidx object to query.
+#
+# Results:
+# None.
+
+proc ::doctools::idx::SearchPaths {name} {
+ upvar #0 ::doctools::idx::docidx${name}::paths opaths
+ variable paths
+
+ set p $opaths
+ foreach s $paths {lappend p $s}
+ return $p
+}
+
+# ::doctools::idx::FmtError --
+#
+# API for checker. Called when an error occurred.
+#
+# Arguments:
+# name Name of the docidx object to query.
+# text Error message
+#
+# Results:
+# None.
+
+proc ::doctools::idx::FmtError {name text} {
+ return -code error "(FmtError) $text"
+}
+
+# ::doctools::idx::FmtWarning --
+#
+# API for checker. Called when a warning was generated
+#
+# Arguments:
+# name Name of the docidx object
+# text Warning message
+#
+# Results:
+# None.
+
+proc ::doctools::idx::FmtWarning {name text} {
+ upvar #0 ::doctools::idx::docidx${name}::msg msg
+ lappend msg $text
+ return
+}
+
+# ::doctools::idx::Eval --
+#
+# API for expander. Routes the macro invocations
+# into the checker interpreter
+#
+# Arguments:
+# name Name of the docidx object to query.
+#
+# Results:
+# None.
+
+proc ::doctools::idx::Eval {name macro} {
+ upvar #0 ::doctools::idx::docidx${name}::chk_ip chk_ip
+
+ # Handle the [include] command directly
+ if {[string match include* $macro]} {
+ set macro [$chk_ip eval [list subst $macro]]
+ foreach {cmd filename} $macro break
+ return [ExpandInclude $name $filename]
+ }
+
+ return [$chk_ip eval $macro]
+}
+
+# ::doctools::idx::ExpandInclude --
+#
+# Handle inclusion of files.
+#
+# Arguments:
+# name Name of the docidx object to query.
+# path Name of file to include and expand.
+#
+# Results:
+# None.
+
+proc ::doctools::idx::ExpandInclude {name path} {
+ upvar #0 ::doctools::idx::docidx${name}::file file
+
+ set ipath [file normalize [file join [file dirname $file] $path]]
+ if {![file exists $ipath]} {
+ set ipath $path
+ if {![file exists $ipath]} {
+ return -code error "Unable to fine include file \"$path\""
+ }
+ }
+
+ set chan [open $ipath r]
+ set text [read $chan]
+ close $chan
+
+ upvar #0 ::doctools::idx::docidx${name}::expander expander
+
+ set saved $file
+ set file $ipath
+ set res [$expander expand $text]
+ set file $saved
+
+ return $res
+}
+
+# ::doctools::idx::GetUser --
+#
+# API for formatter. Returns name of current user
+#
+# Arguments:
+# name Name of the docidx object to query.
+#
+# Results:
+# String, name of current user.
+
+proc ::doctools::idx::GetUser {name} {
+ global tcl_platform
+ return $tcl_platform(user)
+}
+
+# ::doctools::idx::GetFormat --
+#
+# API for formatter. Returns format information
+#
+# Arguments:
+# name Name of the docidx object to query.
+#
+# Results:
+# Format information
+
+proc ::doctools::idx::GetFormat {name} {
+ upvar #0 ::doctools::idx::docidx${name}::format format
+ return $format
+}
+
+# ::doctools::idx::MapFile --
+#
+# API for formatter. Maps symbolic to actual filename in an
+# index element. If no mapping is found it is assumed that
+# the symbolic name is also the actual name.
+#
+# Arguments:
+# name Name of the docidx object to query.
+# fname Symbolic name of the file.
+#
+# Results:
+# Actual name of the file.
+
+proc ::doctools::idx::MapFile {name fname} {
+ upvar #0 ::doctools::idx::docidx${name}::map map
+ if {[info exists map($fname)]} {
+ return $map($fname)
+ }
+ return $fname
+}
+
+# ::doctools::idx::Source --
+#
+# API for formatter. Used by engine to ask for
+# additional script files support it.
+#
+# Arguments:
+# name Name of the docidx object to change.
+#
+# Results:
+# Boolean flag.
+
+proc ::doctools::idx::Source {ip path file} {
+ $ip invokehidden source [file join $path [file tail $file]]
+ #$ip eval [list source [file join $path [file tail $file]]]
+ return
+}
+
+proc ::doctools::idx::Read {ip path file} {
+ #puts stderr "$ip (read $path $file)"
+
+ return [read [set f [open [file join $path [file tail $file]]]]][close $f]
+}
+
+proc ::doctools::idx::FileOp {ip args} {
+ #puts stderr "$ip (file $args)"
+ # -- FUTURE -- disallow unsafe operations --
+
+ return [eval [linsert $args 0 file]]
+}
+
+proc ::doctools::idx::Package {ip pkg} {
+ #puts stderr "$ip package require $pkg"
+
+ set indexScript [Locate $pkg]
+
+ $ip expose source
+ $ip expose load
+ $ip eval $indexScript
+ $ip hide source
+ $ip hide load
+ #$ip eval [list source [file join $path [file tail $file]]]
+ return
+}
+
+proc ::doctools::idx::Locate {p} {
+ # @mdgen NODEP: doctools::__undefined__
+ catch {package require doctools::__undefined__}
+
+ #puts stderr "auto_path = [join $::auto_path \n]"
+
+ # Check if requested package is in the list of loadable packages.
+ # Then get the highest possible version, and then the index script
+
+ if {[lsearch -exact [package names] $p] < 0} {
+ return -code error "Unknown package $p"
+ }
+
+ set v [lindex [lsort -increasing [package versions $p]] end]
+
+ #puts stderr "Package $p = $v"
+
+ return [package ifneeded $p $v]
+}
+
+#------------------------------------
+# Module initialization
+
+namespace eval ::doctools::idx {
+ # Reverse order of searching. First to search is specified last.
+
+ # FOO/docidx.tcl
+ # => FOO/mpformats
+
+ #catch {search [file join $here lib doctools mpformats]}
+ #catch {search [file join [file dirname $here] lib doctools mpformats]}
+ catch {search [file join $here mpformats]}
+}
+
+package provide doctools::idx 1.0.5
diff --git a/tcllib/modules/doctools/docidx.test b/tcllib/modules/doctools/docidx.test
new file mode 100644
index 0000000..5c5d0c2
--- /dev/null
+++ b/tcllib/modules/doctools/docidx.test
@@ -0,0 +1,316 @@
+# -*- tcl -*-
+# docidx.test: tests for the doctools::idx package.
+#
+# 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) 2003-2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: docidx.test,v 1.15 2009/02/12 05:42:47 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+support {
+ use textutil/expander.tcl textutil::expander
+}
+testing {
+ useLocal docidx.tcl doctools::idx
+}
+
+# -------------------------------------------------------------------------
+
+array_unset env LANG*
+array_unset env LC_*
+set env(LANG) C ; # Usually default if nothing is set, OS X requires this.
+
+# -------------------------------------------------------------------------
+
+namespace import ::doctools::idx::new
+
+# search paths .............................................................
+
+test docidx-1.0 {default search paths} {
+ llength $::doctools::idx::paths
+} 1
+
+test docidx-1.1 {extend package search paths} {
+ ::doctools::idx::search [file dirname [info script]]
+ set res [list]
+ lappend res [llength $::doctools::idx::paths]
+ lappend res [lindex $::doctools::idx::paths 0]
+ set res
+} [list 2 [file dirname [info script]]]
+
+test docidx-1.2 {extend package search paths, error} {
+ catch {::doctools::idx::search foo} result
+ set result
+} {doctools::idx::search: path does not exist}
+
+# format help .............................................................
+
+test docidx-2.0 {format help} {
+ string length [doctools::idx::help]
+} 368
+
+# docidx .............................................................
+
+test docidx-3.0 {docidx errors} {
+ catch {new} msg
+ set msg
+} [tcltest::wrongNumArgs "new" "name args" 0]
+
+test docidx-3.1 {docidx errors} {
+ catch {new set} msg
+ set msg
+} "command \"set\" already exists, unable to create docidx object"
+
+test docidx-3.2 {docidx errors} {
+ new mydocidx
+ catch {new mydocidx} msg
+ mydocidx destroy
+ set msg
+} "command \"mydocidx\" already exists, unable to create docidx object"
+
+test docidx-3.3 {docidx errors} {
+ catch {new mydocidx -foo} msg
+ set msg
+} {wrong # args: doctools::new name ?opt val...??}
+
+# docidx methods ......................................................
+
+test docidx-4.0 {docidx method errors} {
+ new mydocidx
+ catch {mydocidx} msg
+ mydocidx destroy
+ set msg
+} "wrong # args: should be \"mydocidx option ?arg arg ...?\""
+
+test docidx-4.1 {docidx errors} {
+ new mydocidx
+ catch {mydocidx foo} msg
+ mydocidx destroy
+ set msg
+} "bad option \"foo\": must be cget, configure, destroy, format, map, search, warnings, parameters, or setparam"
+
+# cget ..................................................................
+
+test docidx-5.0 {cget errors} {
+ new mydocidx
+ catch {mydocidx cget} result
+ mydocidx destroy
+ set result
+} [tcltest::wrongNumArgs "::doctools::idx::_cget" "name option" 1]
+
+test docidx-5.1 {cget errors} {
+ new mydocidx
+ catch {mydocidx cget foo bar} result
+ mydocidx destroy
+ set result
+} [tcltest::tooManyArgs "::doctools::idx::_cget" "name option"]
+
+test docidx-5.2 {cget errors} {
+ new mydocidx
+ catch {mydocidx cget -foo} result
+ mydocidx destroy
+ set result
+} {doctools::idx::_configure: Unknown option "-foo", expected -file, or -format}
+
+foreach {na nb option default newvalue} {
+ 3 4 -file {} foo
+ 5 6 -format {} html
+} {
+ test docidx-5.$na {cget query} {
+ new mydocidx
+ set res [mydocidx cget $option]
+ mydocidx destroy
+ set res
+ } $default ; # {}
+
+ test docidx-5.$nb {cget set & query} {
+ new mydocidx
+ mydocidx configure $option $newvalue
+ set res [mydocidx cget $option]
+ mydocidx destroy
+ set res
+ } $newvalue ; # {}
+}
+
+# configure ..................................................................
+
+test docidx-6.0 {configure errors} {
+ new mydocidx
+ catch {mydocidx configure -foo bar -glub} result
+ mydocidx destroy
+ set result
+} {wrong # args: doctools::idx::_configure name ?opt val...??}
+# [tcltest::wrongNumArgs "::doctools::idx::_configure" "name ?option?|?option value...?" 1]
+
+test docidx-6.1 {configure errors} {
+ new mydocidx
+ catch {mydocidx configure -foo} result
+ mydocidx destroy
+ set result
+} {doctools::idx::_configure: Unknown option "-foo", expected -file, or -format}
+
+test docidx-6.2 {configure retrieval} {
+ new mydocidx
+ catch {mydocidx configure} result
+ mydocidx destroy
+ set result
+} {-file {} -format {}}
+
+foreach {n option illegalvalue result} {
+ 3 -format barf {doctools::idx::_configure: -format: Unknown format "barf"}
+} {
+ test docidx-6.$n {configure illegal value} {
+ new mydocidx
+ catch {mydocidx configure $option $illegalvalue} result
+ mydocidx destroy
+ set result
+ } $result
+}
+
+foreach {na nb option default newvalue} {
+ 4 5 -file {} foo
+ 6 7 -format {} html
+} {
+ test docidx-6.$na {configure query} {
+ new mydocidx
+ set res [mydocidx configure $option]
+ mydocidx destroy
+ set res
+ } $default ; # {}
+
+ test docidx-6.$nb {configure set & query} {
+ new mydocidx
+ mydocidx configure $option $newvalue
+ set res [mydocidx configure $option]
+ mydocidx destroy
+ set res
+ } $newvalue ; # {}
+}
+
+test docidx-6.8 {configure full retrieval} {
+ new mydocidx -file foo -format html
+ catch {mydocidx configure} result
+ mydocidx destroy
+ set result
+} {-file foo -format html}
+
+# search ..................................................................
+
+test docidx-7.0 {search errors} {
+ new mydocidx
+ catch {mydocidx search} result
+ mydocidx destroy
+ set result
+} [tcltest::wrongNumArgs "::doctools::idx::_search" "name path" 1]
+
+test docidx-7.1 {search errors} {
+ new mydocidx
+ catch {mydocidx search foo bar} result
+ mydocidx destroy
+ set result
+} [tcltest::tooManyArgs "::doctools::idx::_search" "name path"]
+
+test docidx-7.2 {search errors} {
+ new mydocidx
+ catch {mydocidx search foo} result
+ mydocidx destroy
+ set result
+} {mydocidx search: path does not exist}
+
+test docidx-7.3 {search, initial} {
+ new mydocidx
+ set res [llength $::doctools::idx::docidxmydocidx::paths]
+ mydocidx destroy
+ set res
+} 0
+
+test docidx-7.4 {extend object search paths} {
+ new mydocidx
+ mydocidx search [file dirname [info script]]
+ set res [list]
+ lappend res [llength $::doctools::idx::docidxmydocidx::paths]
+ lappend res [lindex $::doctools::idx::docidxmydocidx::paths 0]
+ mydocidx destroy
+ set res
+} [list 1 [file dirname [info script]]]
+
+# format & warnings .......................................................
+
+test docidx-8.0 {format errors} {
+ new mydocidx
+ catch {mydocidx format} result
+ mydocidx destroy
+ set result
+} [tcltest::wrongNumArgs "::doctools::idx::_format" "name text" 1]
+
+test docidx-8.1 {format errors} {
+ new mydocidx
+ catch {mydocidx format foo bar} result
+ mydocidx destroy
+ set result
+} [tcltest::tooManyArgs "::doctools::idx::_format" "name text"]
+
+test docidx-8.2 {format errors} {
+ new mydocidx
+ catch {mydocidx format foo} result
+ mydocidx destroy
+ set result
+} {mydocidx: No format was specified}
+
+
+test docidx-8.3 {format} {
+ new mydocidx -format wiki
+ set res [mydocidx format {[index_begin foo bar][key snafu][manpage at fubar][index_end]}]
+ lappend res [mydocidx warnings]
+ mydocidx destroy
+ set res
+} {Index '''foo''' '''bar''' '''snafu''': at {}}
+
+
+# docidx syntax .......................................................
+
+test docidx-9.0 {docidx syntax} {
+ new mydocidx -format null
+ catch {mydocidx format foo} result
+ mydocidx destroy
+ set result
+} {Docidx Error in plain text at line 1, column 0:
+[plain_text foo]
+--> (FmtError) IDX error (idx/plaintext), "plain_text foo" : Plain text beyond whitespace is not allowed..}
+
+
+test docidx-9.1 {docidx syntax, empty index, ok} {
+ new mydocidx -format null
+ set result [mydocidx format {[index_begin KWIC Test][index_end]}]
+ mydocidx destroy
+ set result
+} {}
+
+test docidx-9.2 {docidx syntax, key without references, error} {
+ new mydocidx -format null
+ catch {mydocidx format {[index_begin KWIC Test][key X][index_end]}} result
+ mydocidx destroy
+ set result
+} {Docidx Error in macro at line 1, column 30:
+[index_end]
+--> (FmtError) IDX error (idx/endcmd), "index_end" : Command not allowed here..}
+
+
+namespace forget ::doctools::idx::new
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools/docidx_intro.man b/tcllib/modules/doctools/docidx_intro.man
new file mode 100644
index 0000000..be44517
--- /dev/null
+++ b/tcllib/modules/doctools/docidx_intro.man
@@ -0,0 +1,106 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin docidx_intro n 1.0]
+[see_also docidx_lang_cmdref]
+[see_also docidx_lang_faq]
+[see_also docidx_lang_intro]
+[see_also docidx_lang_syntax]
+[see_also docidx_plugin_apiref]
+[see_also doctoc_intro]
+[see_also doctools::idx]
+[see_also doctools_intro]
+[keywords index]
+[keywords {keyword index}]
+[keywords markup]
+[keywords {semantic markup}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {docidx introduction}]
+[category {Documentation tools}]
+[description]
+[para]
+
+[term docidx] (short for [emph {documentation tables of contents}])
+stands for a set of related, yet different, entities which are working
+together for the easy creation and transformation of keyword-based
+indices for documentation. These are
+
+[list_begin enumerated]
+[enum]
+
+A tcl based language for the semantic markup of a keyword index.
+Markup is represented by Tcl commands.
+
+[enum]
+
+A package providing the ability to read and transform texts written in
+that markup language. It is important to note that the actual
+transformation of the input text is delegated to plugins.
+
+[enum]
+
+An API describing the interface between the package above and a
+plugin.
+
+[list_end]
+
+[para]
+
+Which of the more detailed documents are relevant to the reader of
+this introduction depends on their role in the documentation process.
+
+[para]
+
+[list_begin enumerated]
+[enum]
+A [term writer] of documentation has to understand the markup language
+itself. A beginner to docidx should read the more informally written
+[term {docidx language introduction}] first. Having digested this
+the formal [term {docidx language syntax}] specification should
+become understandable. A writer experienced with docidx may only
+need the [term {docidx language command reference}] from time to
+time to refresh her memory.
+
+[para]
+
+While a document is written the [syscmd dtp] application can be used
+to validate it, and after completion it also performs the conversion
+into the chosen system of visual markup, be it *roff, HTML, plain
+text, wiki, etc. The simpler [syscmd dtplite] application makes
+internal use of docidx when handling directories of documentation,
+automatically generating a proper keyword index for them.
+
+[enum]
+A [term processor] of documentation written in the [term docidx]
+markup language has to know which tools are available for use.
+
+[para]
+
+The main tool is the aforementioned [syscmd dtp] application provided
+by Tcllib. The simpler [syscmd dtplite] does not expose docidx to the
+user.
+
+At the bottom level, common to both applications, however sits the
+package [package doctoools::idx], providing the basic facilities to
+read and process files containing text in the docidx format.
+
+[enum]
+At last, but not least, [term {plugin writers}] have to understand the
+interaction between the [package doctools::idx] package and its
+plugins, as described in the [term {docidx plugin API reference}].
+
+[list_end]
+
+[section {RELATED FORMATS}]
+
+docidx does not stand alone, it has two companion formats. These are
+called [term doctoc] and [term doctools], and they are for the markup
+of [term {tables of contents}], and general documentation,
+respectively.
+
+They are described in their own sets of documents, starting at the
+[term {doctoc introduction}] and the [term {doctools introduction}],
+respectively.
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/docidx_lang_cmdref.man b/tcllib/modules/doctools/docidx_lang_cmdref.man
new file mode 100644
index 0000000..53664de
--- /dev/null
+++ b/tcllib/modules/doctools/docidx_lang_cmdref.man
@@ -0,0 +1,116 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin docidx_lang_cmdref n 1.0]
+[see_also docidx_intro]
+[see_also docidx_lang_faq]
+[see_also docidx_lang_intro]
+[see_also docidx_lang_syntax]
+[keywords {docidx commands}]
+[keywords {docidx language}]
+[keywords {docidx markup}]
+[keywords markup]
+[keywords {semantic markup}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {docidx language command reference}]
+[category {Documentation tools}]
+[description]
+[para]
+
+This document specifies both names and syntax of all the commands
+which together are the docidx markup language, version 1.
+
+As this document is intended to be a reference the commands are listed
+in alphabetical order, and the descriptions are relatively short.
+
+A beginner should read the much more informally written
+[term {docidx language introduction}] first.
+
+[section Commands]
+[list_begin definitions]
+
+[call [cmd comment] [arg plaintext]]
+
+Index markup. The argument text is marked up as a comment standing
+outside of the actual text of the document. Main use is in free-form
+text.
+
+[call [cmd include] [arg filename]]
+
+Templating. The contents of the named file are interpreted as text
+written in the docidx markup and processed in the place of the
+include command. The markup in the file has to be self-contained. It
+is not possible for a markup command to cross the file boundaries.
+
+[call [cmd index_begin] [arg text] [arg title]]
+
+Document structure. The command to start an index. The arguments are a
+label for the whole group of documents the index refers to
+([arg text]) and the overall title text for the index ([arg title]),
+without markup.
+
+[para]
+
+The label often is the name of the package (or extension) the
+documents belong to.
+
+[call [cmd index_end]]
+
+Document structure. Command to end an index. Anything in the document
+coming after this command is in error.
+
+[call [cmd key] [arg text]]
+
+Index structure. This command adds the keyword [arg text] to the
+index.
+
+[call [cmd lb]]
+
+Text. The command is replaced with a left bracket. Use in free-form
+text. Required to avoid interpretation of a left bracket as the start
+of a markup command. Its usage is restricted to the arguments of other
+markup commands.
+
+[call [cmd manpage] [arg file] [arg text]]
+
+Index structure. This command adds an element to the index which
+refers to a document. The document is specified through the symbolic
+name [arg file]. The [arg text] argument is used to label the
+reference.
+
+[para]
+
+Symbolic names are used to preserve the convertibility of this format
+to any output format. The actual name of the file will be inserted by
+the chosen formatting engine when converting the input. This will be
+based on a mapping from symbolic to actual names given to the engine.
+
+[call [cmd rb]]
+
+Text. The command is replaced with a right bracket. Use in free-form
+text. Required to avoid interpretation of a right bracket as the end
+of a markup command. Its usage is restricted to the arguments of other
+commands.
+
+[call [cmd url] [arg url] [arg label]]
+
+Index structure. This is the second command to add an element to the
+index. To refer to a document it is not using a symbolic name however,
+but a (possibly format-specific) url describing the exact location of
+the document indexed here.
+
+[call [cmd vset] [arg varname] [arg value] ]
+
+Templating. In this form the command sets the named document variable
+to the specified [arg value]. It does not generate output. I.e. the
+command is replaced by the empty string.
+
+[call [cmd vset] [arg varname]]
+
+Templating. In this form the command is replaced by the value of the
+named document variable
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/docidx_lang_faq.man b/tcllib/modules/doctools/docidx_lang_faq.man
new file mode 100644
index 0000000..786f471
--- /dev/null
+++ b/tcllib/modules/doctools/docidx_lang_faq.man
@@ -0,0 +1,28 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin docidx_lang_faq n 1.0]
+[see_also docidx_lang_cmdref]
+[see_also docidx_lang_intro]
+[see_also docidx_lang_syntax]
+[keywords {docidx commands}]
+[keywords {docidx language}]
+[keywords {docidx markup}]
+[keywords {docidx syntax}]
+[keywords examples]
+[keywords faq]
+[keywords markup]
+[keywords {semantic markup}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {docidx language faq}]
+[category {Documentation tools}]
+[description]
+[vset theformat docidx]
+
+[section OVERVIEW]
+
+[include include/placeholder.inc]
+[include include/examples.inc]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/docidx_lang_intro.man b/tcllib/modules/doctools/docidx_lang_intro.man
new file mode 100644
index 0000000..33fe521
--- /dev/null
+++ b/tcllib/modules/doctools/docidx_lang_intro.man
@@ -0,0 +1,214 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin docidx_lang_intro n 1.0]
+[see_also docidx_intro]
+[see_also docidx_lang_cmdref]
+[see_also docidx_lang_syntax]
+[keywords {docidx commands}]
+[keywords {docidx language}]
+[keywords {docidx markup}]
+[keywords {docidx syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+[copyright {2007-2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {docidx language introduction}]
+[category {Documentation tools}]
+[description]
+[para]
+
+This document is an informal introduction to version 1 of the docidx
+markup language based on a multitude of examples. After reading this a
+writer should be ready to understand the two parts of the formal
+specification, i.e. the [term {docidx language syntax}] specification
+and the [term {docidx language command reference}].
+
+[subsection Fundamentals]
+
+While the [term {docidx markup language}] is quite similar to the
+[term {doctools markup language}], in the broadest terms possible,
+there is one key difference. An index consists essentially only of
+markup commands, with no plain text interspersed between them, except
+for whitespace.
+
+[para]
+
+Each markup command is a Tcl command surrounded by a matching pair of
+[const [lb]] and [const [rb]]. Inside of these delimiters the usual
+rules for a Tcl command apply with regard to word quotation, nested
+commands, continuation lines, etc. I.e.
+
+[para]
+[example {
+ ... [key {markup language}] ...
+}]
+
+[example {
+ ... [manpage thefile \\
+ {file description}] ...
+}]
+
+[subsection {Basic structure}]
+
+The most simple document which can be written in docidx is
+
+[example {
+ [index_begin GROUPTITLE TITLE]
+ [index_end]
+}]
+
+[para]
+
+Not very useful, but valid. This also shows us that all docidx
+documents consist of only one part where we will list all keys and
+their references.
+
+[para]
+
+A more useful index will contain at least keywords, or short 'keys',
+i.e. the phrases which were indexed. So:
+
+[example_begin]
+[lb]index_begin GROUPTITLE TITLE[rb]
+[lb][cmd {key markup}][rb]
+[lb][cmd {key {semantic markup}]}][rb]
+[lb][cmd {key {docidx markup}}][rb]
+[lb][cmd {key {docidx language}}][rb]
+[lb][cmd {key {docidx commands}}][rb]
+[lb]index_end[rb]
+[example_end]
+
+[para]
+
+In the above example the command [cmd key] is used to declare the
+keyword phrases we wish to be part of the index.
+
+[para]
+
+However a truly useful index does not only list the keyword phrases,
+but will also contain references to documents associated with the
+keywords. Here is a made-up index for all the manpages in the module
+[term base64]:
+
+[example_begin]
+[lb]index_begin tcllib/base64 {De- & Encoding}[rb]
+[lb]key base64[rb]
+[lb][cmd {manpage base64}][rb]
+[lb]key encoding[rb]
+[lb][cmd {manpage base64}][rb]
+[lb][cmd {manpage uuencode}][rb]
+[lb][cmd {manpage yencode}][rb]
+[lb]key uuencode[rb]
+[lb][cmd {manpage uuencode}][rb]
+[lb]key yEnc[rb]
+[lb][cmd {manpage yencode}][rb]
+[lb]key ydecode[rb]
+[lb][cmd {manpage yencode}][rb]
+[lb]key yencode[rb]
+[lb][cmd {manpage yencode}][rb]
+[lb]index_end[rb]
+[example_end]
+
+[para]
+
+In the above example the command [cmd manpage] is used to insert
+references to documents, using symbolic file names, with each command
+belonging to the last [cmd key] command coming before it.
+
+[para]
+
+The other command to insert references is [cmd url]. In contrast to
+[cmd manpage] it uses explicit (possibly format-specific) urls to
+describe the location of the referenced document. As such this command
+is intended for the creation of references to external documents which
+could not be handled in any other way.
+
+[subsection {Advanced structure}]
+
+In all previous examples we fudged a bit regarding the markup actually
+allowed to be used before the [cmd index_begin] command opening the
+document.
+
+[para]
+
+Instead of only whitespace the two templating commands [cmd include]
+and [cmd vset] are also allowed, to enable the writer to either set
+and/or import configuration settings relevant to the table of
+contents. I.e. it is possible to write
+
+[example_begin]
+[lb][cmd {include FILE}][rb]
+[lb][cmd {vset VAR VALUE}][rb]
+[lb]index_begin GROUPTITLE TITLE[rb]
+...
+[lb]index_end[rb]
+[example_end]
+
+Even more important, these two commands are allowed anywhere where a
+markup command is allowed, without regard for any other
+structure.
+
+[example_begin]
+[lb]index_begin GROUPTITLE TITLE[rb]
+[lb][cmd {include FILE}][rb]
+[lb][cmd {vset VAR VALUE}][rb]
+...
+[lb]index_end[rb]
+[example_end]
+
+The only restriction [cmd include] has to obey is that the contents of
+the included file must be valid at the place of the inclusion. I.e. a
+file included before [cmd index_begin] may contain only the templating
+commands [cmd vset] and [cmd include], a file included after a key
+may contain only manape or url references, and other keys, etc.
+
+[subsection Escapes]
+
+Beyond the 6 commands shown so far we have two more available.
+
+However their function is not the marking up of index structure, but
+the insertion of characters, namely [const [lb]] and [const [rb]].
+
+These commands, [cmd lb] and [cmd rb] respectively, are required
+because our use of [lb] and [rb] to bracket markup commands makes it
+impossible to directly use [lb] and [rb] within the text.
+
+[para]
+
+Our example of their use are the sources of the last sentence in the
+previous paragraph, with some highlighting added.
+
+[example_begin]
+ ...
+ These commands, [lb]cmd lb[rb] and [lb]cmd lb[rb] respectively, are required
+ because our use of [lb][cmd lb][rb] and [lb][cmd rb][rb] to bracket markup commands makes it
+ impossible to directly use [lb][cmd lb][rb] and [lb][cmd rb][rb] within the text.
+ ...
+[example_end]
+
+[section {FURTHER READING}]
+
+Now that this document has been digested the reader, assumed to be a
+[term writer] of documentation should be fortified enough to be able
+to understand the formal [term {docidx language syntax}]
+specification as well. From here on out the
+[term {docidx language command reference}] will also serve as the
+detailed specification and cheat sheet for all available commands and
+their syntax.
+
+[para]
+
+To be able to validate a document while writing it, it is also
+recommended to familiarize oneself with Tclapps' ultra-configurable
+[syscmd dtp].
+
+[para]
+
+On the other hand, docidx is perfectly suited for the automatic
+generation from doctools documents, and this is the route Tcllib's
+easy and simple [syscmd dtplite] goes, creating an index for a set of
+documents behind the scenes, without the writer having to do so on
+their own.
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/docidx_lang_syntax.man b/tcllib/modules/doctools/docidx_lang_syntax.man
new file mode 100644
index 0000000..cdf7b0c
--- /dev/null
+++ b/tcllib/modules/doctools/docidx_lang_syntax.man
@@ -0,0 +1,120 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin docidx_lang_syntax n 1.0]
+[see_also docidx_intro]
+[see_also docidx_lang_cmdref]
+[see_also docidx_lang_faq]
+[see_also docidx_lang_intro]
+[keywords {docidx commands}]
+[keywords {docidx language}]
+[keywords {docidx markup}]
+[keywords {docidx syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+[copyright {2007-2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {docidx language syntax}]
+[category {Documentation tools}]
+[description]
+[para]
+
+This document contains the formal specification of the syntax of the
+docidx markup language, version 1 in Backus-Naur-Form. This document
+is intended to be a reference, complementing the
+[term {docidx language command reference}].
+
+A beginner should read the much more informally written
+[term {docidx language introduction}] first before trying to
+understand either this document or the command reference.
+
+[section Fundamentals]
+
+In the broadest terms possible the [term {docidx markup language}] is
+like SGML and similar languages. A document written in this language
+consists primarily of markup commands, with text embedded into it at
+some places.
+
+[para]
+
+Each markup command is a just Tcl command surrounded by a matching
+pair of [const [lb]] and [const [rb]]. Which commands are available,
+and their arguments, i.e. syntax is specified in the
+[term {docidx language command reference}].
+
+[para]
+
+In this document we specify first the lexeme, and then the syntax,
+i.e. how we can mix text and markup commands with each other.
+
+[section {Lexical definitions}]
+
+In the syntax rules listed in the next section
+
+[list_begin enumerated]
+[enum]
+<TEXT> stands for all text except markup commands.
+
+[enum]
+Any XXX stands for the markup command [lb]xxx[rb] including its
+arguments. Each markup command is a Tcl command surrounded by a
+matching pair of [const [lb]] and [const [rb]]. Inside of these
+delimiters the usual rules for a Tcl command apply with regard to word
+quotation, nested commands, continuation lines, etc.
+
+[enum]
+<WHITE> stands for all text consisting only of spaces, newlines,
+tabulators and the [cmd comment] markup command.
+[list_end]
+
+[section Syntax]
+
+The rules listed here specify only the syntax of docidx documents. The
+lexical level of the language was covered in the previous section.
+
+[para]
+
+Regarding the syntax of the (E)BNF itself
+
+[list_begin enumerated]
+[enum]
+The construct { X } stands for zero or more occurrences of X.
+[enum]
+The construct [lb] X [rb] stands for zero or one occurrence of X.
+[list_end]
+
+The syntax:
+
+[example {
+index = defs
+ INDEX_BEGIN
+ [ contents ]
+ INDEX_END
+ { <WHITE> }
+
+defs = { INCLUDE | VSET | <WHITE> }
+contents = keyword { keyword }
+
+keyword = defs KEY ref { ref }
+ref = MANPAGE | URL | defs
+}]
+
+At last a rule we were unable to capture in the EBNF syntax, as it is
+about the arguments of the markup commands, something which is not
+modeled here.
+
+[list_begin enumerated]
+[enum]
+
+The arguments of all markup commands have to be plain text, and/or text
+markup commands, i.e. one of
+
+[list_begin enumerated]
+[enum][cmd lb],
+[enum][cmd rb], or
+[enum][cmd vset] (1-argument form).
+[list_end]
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/docidx_plugin_apiref.man b/tcllib/modules/doctools/docidx_plugin_apiref.man
new file mode 100644
index 0000000..e375547
--- /dev/null
+++ b/tcllib/modules/doctools/docidx_plugin_apiref.man
@@ -0,0 +1,421 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin docidx_plugin_apiref n 1.0]
+[see_also docidx_intro]
+[see_also docidx_lang_cmdref]
+[see_also docidx_lang_faq]
+[see_also docidx_lang_intro]
+[see_also docidx_lang_syntax]
+[see_also doctools::idx]
+[keywords {formatting engine}]
+[keywords index]
+[keywords {index formatter}]
+[keywords keywords]
+[keywords markup]
+[keywords plugin]
+[keywords {semantic markup}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {docidx plugin API reference}]
+[category {Documentation tools}]
+[description]
+[para]
+
+This document is intended for [term {plugin writers}], i.e. developers
+wishing to write an index [term {formatting engine}] for some output
+format X.
+
+[para]
+
+It specifies the interaction between the [package doctools::idx]
+package and its plugins, i.e. the interface any index formatting
+engine has to comply with.
+
+[para]
+
+This document deals with version 1 of the interface.
+
+[para]
+
+A reader who is on the other hand more interested in the markup
+language itself should start with the
+
+[term {docidx language introduction}] and proceed from there to the
+formal specifications, i.e. the [term {docidx language syntax}] and
+the [term {docidx language command reference}].
+
+[section OVERVIEW]
+
+The API for an index formatting engine consists of two major sections.
+
+[para]
+
+On the one side we have a set of commands through which the plugin is
+able to query the frontend. These commands are provided by the
+frontend and linked into the plugin interpreter. Please see section
+[sectref {FRONTEND COMMANDS}] for their detailed specification.
+
+[para]
+
+And on the other side the plugin has to provide its own set of
+commands which will then be called by the frontend in a specific
+sequence while processing input. They, again, fall into two
+categories, management and formatting.
+
+Please see section [sectref {PLUGIN COMMANDS}] and its subsections for
+their detailed specification.
+
+[section {FRONTEND COMMANDS}]
+
+This section specifies the set of commands through which a plugin,
+also known as an index formatting engine, is able to query the
+frontend. These commands are provided by the frontend and linked into
+the plugin interpreter.
+
+[para]
+
+I.e. an index formatting engine can assume that all of the following
+commands are present when any of its own commands (as specified in
+section [sectref {PLUGIN COMMANDS}]) are executed.
+
+[para]
+
+Beyond that it can also assume that it has full access to its own safe
+interpreter and thus is not able to damage the other parts of the
+processor, nor can it damage the filesystem.
+
+It is however able to either kill or hang the whole process, by
+exiting, or running an infinite loop.
+
+[para]
+
+Coming back to the imported commands, all the commands with prefix
+[emph dt_] provide limited access to specific parts of the frontend,
+whereas the commands with prefix [emph ex_] provide access to the
+state of the [package textutil::expander] object which does the main
+parsing of the input within the frontend. These commands should not be
+except under very special circumstances.
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd dt_fmap] [arg symfname]]
+
+Query command. It returns the actual pathname to use in the output in
+place of the symbolic filename [arg symfname]. It will return the
+unchanged input if no mapping was established for [arg symfname].
+
+[para]
+
+The required mappings are established with the method [method map] of
+a frontend, as explained in section [sectref-external {OBJECT METHODS}]
+of the documentation for the package [package doctools::idx].
+
+[call [cmd dt_format]]
+
+Query command. It returns the name of the format associated with the
+index formatting engine.
+
+[call [cmd dt_read] [arg file]]
+
+Controlled filesystem access. Returns contents of [arg file] for
+whatever use desired by the plugin.
+
+Only files which are either in the same directory as the file
+containing the engine, or below it, can be loaded. Trying to load a
+file outside of this directory causes an error.
+
+[call [cmd dt_source] [arg file]]
+
+Controlled filesystem access. This command allows the index formatting
+engine to load additional Tcl code it may need.
+
+Only files which are either in the same directory as the file
+containing the engine, or below it, can be loaded. Trying to load a
+file outside of this directory causes an error.
+
+[call [cmd ex_cappend] [arg text]]
+Appends a string to the output in the current context. This command
+should rarely be used by macros or application code.
+
+[call [cmd ex_cget] [arg varname]]
+Retrieves the value of variable [arg varname], defined in the current
+context.
+
+[call [cmd ex_cis] [arg cname]]
+Determines whether or not the name of the current context is
+[arg cname].
+
+[call [cmd ex_cname]]
+Returns the name of the current context.
+
+[call [cmd ex_cpop] [arg cname]]
+Pops a context from the context stack, returning all accumulated
+output in that context. The context must be named [arg cname], or an
+error results.
+
+[call [cmd ex_cpush] [arg cname]]
+Pushes a context named [arg cname] onto the context stack. The
+context must be popped by [method cpop] before expansion ends or an
+error results.
+
+[call [cmd ex_cset] [arg varname] [arg value]]
+Sets variable [arg varname] to [arg value] in the current context.
+
+[call [cmd ex_lb] [opt [arg newbracket]]]
+Returns the current value of the left macro expansion bracket; this is
+for use as or within a macro, when the bracket needs to be included in
+the output text. If [arg newbracket] is specified, it becomes the new
+bracket, and is returned.
+
+[call [cmd ex_rb] [opt [arg newbracket]]]
+Returns the current value of the right macro expansion bracket; this
+is for use as or within a macro, when the bracket needs to be included
+in the output text. If [arg newbracket] is specified, it becomes the
+new bracket, and is returned.
+
+[list_end]
+
+[section {PLUGIN COMMANDS}]
+
+The plugin has to provide its own set of commands which will then be
+called by the frontend in a specific sequence while processing
+input. They fall into two categories, management and formatting. Their
+expected names, signatures, and responsibilities are specified in the
+following two subsections.
+
+[subsection {Management commands}]
+
+The management commands a plugin has to provide are used by the
+frontend to
+
+[list_begin enumerated]
+[enum] initialize and shutdown the plugin
+[enum] determine the number of passes it has
+ to make over the input
+[enum] initialize and shutdown each pass
+[enum] query and initialize engine parameters
+[list_end]
+[para]
+
+After the plugin has been loaded and the frontend commands are
+established the commands will be called in the following sequence:
+
+[example {
+ idx_numpasses -> n
+ idx_listvariables -> vars
+
+ idx_varset var1 value1
+ idx_varset var2 value2
+ ...
+ idx_varset varK valueK
+ idx_initialize
+ idx_setup 1
+ ...
+ idx_setup 2
+ ...
+ ...
+ idx_setup n
+ ...
+ idx_postprocess
+ idx_shutdown
+ ...
+}]
+
+I.e. first the number of passes and the set of available engine
+parameters is established, followed by calls setting the
+parameters. That second part is optional.
+
+[para]
+
+After that the plugin is initialized, the specified number of passes
+executed, the final result run through a global post processing step
+and at last the plugin is shutdown again. This can be followed by more
+conversions, restarting the sequence at [cmd idx_varset].
+
+[para]
+
+In each of the passes, i.e. after the calls of [cmd idx_setup] the
+frontend will process the input and call the formatting commands as
+markup is encountered. This means that the sequence of formatting
+commands is determined by the grammar of the docidx markup language,
+as specified in the [term {docidx language syntax}] specification.
+
+[para]
+
+A different way of looking at the sequence is:
+
+[list_begin itemized]
+[item] First some basic parameters are determined.
+
+[item] Then everything starting at the first [cmd idx_varset] to
+[cmd idx_shutdown] forms a [term run], the formatting of a
+single input. Each run can be followed by more.
+
+[item] Embedded within each run we have one or more [term passes],
+each starting with [cmd idx_setup] and going until either the next
+[cmd idx_setup] or [cmd idx_postprocess] is reached.
+
+[para]
+
+If more than one pass is required to perform the formatting only the
+output of the last pass is relevant. The output of all the previous,
+preparatory passes is ignored.
+
+[list_end]
+[para]
+
+The commands, their names, signatures, and responsibilities are, in
+detail:
+
+[list_begin definitions]
+
+[call [cmd idx_initialize]]
+[emph Initialization/Shutdown].
+
+This command is called at the beginning of every conversion run, as
+the first command of that run. Note that a run is not a pass, but may
+consist of multiple passes.
+
+It has to initialize the general state of the plugin, beyond the
+initialization done during the load. No return value is expected, and
+any returned value is ignored.
+
+[call [cmd idx_listvariables]]
+[emph Initialization/Shutdown] and [emph {Engine parameters}].
+
+Second command is called after the plugin code has been loaded,
+i.e. immediately after [cmd idx_numpasses].
+
+It has to return a list containing the names of the parameters the
+frontend can set to configure the engine. This list can be empty.
+
+[call [cmd idx_numpasses]]
+[emph Initialization/Shutdown] and [emph {Pass management}].
+
+First command called after the plugin code has been loaded. No other
+command of the engine will be called before it.
+
+It has to return the number of passes this engine requires to fully
+process the input document. This value has to be an integer number
+greater or equal to one.
+
+[call [cmd idx_postprocess] [arg text]]
+[emph Initialization/Shutdown].
+
+This command is called immediately after the last pass in a run. Its
+argument is the result of the conversion generated by that pass. It is
+provided to allow the engine to perform any global modifications of
+the generated document. If no post-processing is required for a
+specific format the command has to just return the argument.
+
+[para]
+
+Expected to return a value, the final result of formatting the input.
+
+[call [cmd idx_setup] [arg n]]
+[emph Initialization/Shutdown] and [emph {Pass management}].
+
+This command is called at the beginning of each pass over the input in
+a run. Its argument is the number of the pass which has begun. Passes
+are counted from [const 1] upward.
+
+The command has to set up the internal state of the plugin for this
+particular pass. No return value is expected, and any returned value
+is ignored.
+
+[call [cmd idx_shutdown]]
+[emph Initialization/Shutdown].
+
+This command is called at the end of every conversion run. It is the
+last command called in a run. It has to clean up of all the
+run-specific state in the plugin.
+
+After the call the engine has to be in a state which allows the
+initiation of another run without fear that information from the last
+run is leaked into this new run.
+
+No return value is expected, and any returned value is ignored.
+
+[call [cmd idx_varset] [arg varname] [arg text]]
+[emph {Engine parameters}].
+
+This command is called by the frontend to set an engine parameter to a
+particular value.
+
+The parameter to change is specified by [arg varname], the value to
+set in [arg text].
+
+[para]
+
+The command has to throw an error if an unknown [arg varname] is
+used. Only the names returned by [cmd idx_listvariables] have to be
+considered as known.
+
+[para]
+
+The values of all engine parameters have to persist between passes and
+runs.
+
+[list_end]
+
+[subsection {Formatting commands}]
+
+The formatting commands have to implement the formatting for the
+output format, for all the markup commands of the docidx markup
+language, except [cmd lb], [cmd rb], [cmd vset], [cmd include], and
+[cmd comment]. These exceptions are processed by the frontend and are
+never seen by the plugin. In return a command for the formatting of
+plain text has to be provided, something which has no markup in the
+input at all.
+
+[para]
+
+This means, that each of the five markup commands specified in the
+[term {docidx language command reference}] and outside of the set of
+exceptions listed above has an equivalent formatting command which
+takes the same arguments as the markup command and whose name is the
+name of markup command with the prefix [emph fmt_] added to it.
+
+[para]
+
+All commands are expected to format their input in some way per the
+semantics specified in the command reference and to return whatever
+part of this that they deem necessary as their result, which will be
+added to the output.
+
+[para]
+
+To avoid essentially duplicating the command reference we do not list
+any of the command here and simply refer the reader to the
+[term {docidx language command reference}] for their signature and
+description. The sole exception is the plain text formatter, which has
+no equivalent markup command.
+
+[para]
+
+The calling sequence of formatting commands is not as rigid as for the
+management commands, but determined by the grammar of the docidx
+markup language, as specified in the [term {docidx language syntax}]
+specification.
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd fmt_plain_text] [arg text]]
+[emph {No associated markup command}].
+
+[para] Called by the frontend for any plain text encountered in the
+input. It has to perform any and all special processing required for
+plain text.
+
+[para] The formatted text is expected as the result of the command,
+and added to the output. If no special processing is required it has
+to simply return its argument without change.
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/doctoc.man b/tcllib/modules/doctools/doctoc.man
new file mode 100644
index 0000000..f11f513
--- /dev/null
+++ b/tcllib/modules/doctools/doctoc.man
@@ -0,0 +1,405 @@
+[vset PACKAGE_VERSION 1.1.4]
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::toc n [vset PACKAGE_VERSION]]
+[see_also doctoc_intro]
+[see_also doctoc_lang_cmdref]
+[see_also doctoc_lang_intro]
+[see_also doctoc_lang_syntax]
+[see_also doctoc_plugin_apiref]
+[keywords conversion]
+[keywords doctoc]
+[keywords documentation]
+[keywords HTML]
+[keywords latex]
+[keywords manpage]
+[keywords markup]
+[keywords nroff]
+[keywords {table of contents}]
+[keywords TMML]
+[keywords toc]
+[keywords wiki]
+[copyright {2003-2014 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {doctoc - Processing tables of contents}]
+[category {Documentation tools}]
+[require Tcl 8.2]
+[require doctools::toc [opt [vset PACKAGE_VERSION]]]
+[description]
+
+This package provides a class for the creation of objects able to
+process and convert text written in the [term doctoc] markup language
+into any output format X for which a [term {formatting engine}] is
+available.
+
+[para]
+
+A reader interested in the markup language itself should start with
+the [term {doctoc language introduction}] and proceed from there to
+the formal specifications, i.e. the [term {doctoc language syntax}]
+and the [term {doctoc language command reference}].
+
+[para]
+
+If on the other hand the reader wishes to write her own formatting
+engine for some format, i.e. is a [term {plugin writer}] then reading
+and understanding the [term {doctoc plugin API reference}] is an
+absolute necessity, as that document specifies the interaction between
+this package and its plugins, i.e. the formatting engines, in detail.
+
+[section {PUBLIC API}]
+[subsection {PACKAGE COMMANDS}]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::toc::new] [arg objectName] [opt "[option -option] [arg value] ..."]]
+
+This command creates a new doctoc object with an associated Tcl
+command whose name is [arg objectName]. This [term object] command is
+explained in full detail in the sections [sectref {OBJECT COMMAND}]
+and [sectref {OBJECT METHODS}]. The object command will be created
+under the current namespace if the [arg objectName] is not fully
+qualified, and in the specified namespace otherwise.
+
+[para]
+
+The options and their values coming after the name of the object are
+used to set the initial configuration of the object.
+
+[call [cmd ::doctools::toc::help]]
+
+This is a convenience command for applications wishing to provide
+their user with a short description of the available formatting
+commands and their meanings. It returns a string containing a standard
+help text.
+
+[call [cmd ::doctools::toc::search] [arg path]]
+
+Whenever an object created by this the package has to map the name of
+a format to the file containing the code for its formatting engine it
+will search for the file in a number of directories stored in a
+list. See section [sectref {FORMAT MAPPING}] for more explanations.
+
+[para]
+
+This list not only contains three default directories which are
+declared by the package itself, but is also extensible user of the
+package.
+
+This command is the means to do so. When given a [arg path] to an
+existing and readable directory it will prepend that directory to the
+list of directories to search. This means that the [arg path] added
+last is later searched through first.
+
+[para]
+
+An error will be thrown if the [arg path] either does not exist, is
+not a directory, or is not readable.
+
+[list_end]
+
+[subsection {OBJECT COMMAND}]
+
+All commands created by [cmd ::doctools::toc::new] have the following
+general form and may be used to invoke various operations on their
+doctoc converter object.
+
+[list_begin definitions]
+
+[call [cmd objectName] [method method] [opt [arg "arg arg ..."]]]
+
+The method [method method] and its [arg arg]'uments determine the exact
+behavior of the command. See section [sectref {OBJECT METHODS}] for
+the detailed specifications.
+
+[list_end]
+
+[subsection {OBJECT METHODS}]
+
+[list_begin definitions]
+
+[call [arg objectName] [method configure]]
+
+The method returns a list of all known options and their current
+values when called without any arguments.
+
+[call [arg objectName] [method configure] [arg option]]
+
+The method behaves like the method [method cget] when called with a
+single argument and returns the value of the option specified by said
+argument.
+
+[call [arg objectName] [method configure] [option -option] [arg value]...]
+
+The method reconfigures the specified [option option]s of the object,
+setting them to the associated [arg value]s, when called with an even
+number of arguments, at least two.
+
+[para]
+
+The legal options are described in the section
+[sectref {OBJECT CONFIGURATION}].
+
+[call [arg objectName] [method cget] [option -option]]
+
+This method expects a legal configuration option as argument and will
+return the current value of that option for the object the method was
+invoked for.
+
+[para]
+
+The legal configuration options are described in section
+[sectref {OBJECT CONFIGURATION}].
+
+[call [arg objectName] [method destroy]]
+
+This method destroys the object it is invoked for.
+
+[call [arg objectName] [method format] [arg text]]
+
+This method runs the [arg text] through the configured formatting
+engine and returns the generated string as its result. An error will
+be thrown if no [option -format] was configured for the object.
+
+[para]
+
+The method assumes that the [arg text] is in [term doctoc] format as
+specified in the companion document [term doctoc_fmt]. Errors will be
+thrown otherwise.
+
+[call [arg objectName] [method map] [arg symbolic] [arg actual]]
+
+This methods add one entry to the per-object mapping from
+[arg symbolic] filenames to the [arg actual] uris.
+
+The object just stores this mapping and makes it available to the
+configured formatting engine through the command [cmd dt_fmap].
+
+This command is described in more detail in the
+[term {doctoc plugin API reference}] which specifies the interaction
+between the objects created by this package and toc formatting
+engines.
+
+[call [arg objectName] [method parameters]]
+
+This method returns a list containing the names of all engine
+parameters provided by the configured formatting engine. It will
+return an empty list if the object is not yet configured for a
+specific format.
+
+[call [arg objectName] [method search] [arg path]]
+
+This method extends the per-object list of paths searched for toc
+formatting engines. See also the command [cmd ::doctools::toc::search]
+on how to extend the per-package list of paths. Note that the path
+entered last will be searched first.
+
+For more details see section [sectref {FORMAT MAPPING}].
+
+[call [arg objectName] [method setparam] [arg name] [arg value]]
+
+This method sets the [arg name]d engine parameter to the specified
+[arg value].
+
+It will throw an error if the object is either not yet configured for
+a specific format, or if the formatting engine for the configured
+format does not provide a parameter with the given [arg name].
+
+The list of parameters provided by the configured formatting engine
+can be retrieved through the method [method parameters].
+
+[call [arg objectName] [method warnings]]
+
+This method returns a list containing all the warnings which were
+generated by the configured formatting engine during the last
+invocation of the method [method format].
+
+[list_end]
+
+[subsection {OBJECT CONFIGURATION}]
+
+All doctoc objects understand the following configuration options:
+
+[list_begin options]
+
+[opt_def -file [arg file]]
+
+The argument of this option is stored in the object and made available
+to the configured formatting engine through the command [cmd dt_file].
+
+This command is described in more detail in the companion document
+[term doctoc_api] which specifies the API between the object and
+formatting engines.
+
+[para]
+
+The default value of this option is the empty string.
+
+[para]
+
+The configured formatting engine should interpret the value as the
+name of the file containing the document which is currently processed.
+
+[opt_def -format [arg text]]
+
+The argument of this option specifies the format to generate and by
+implication the formatting engine to use when converting text via the
+method [method format]. Its default value is the empty string. The
+method [method format] cannot be used if this option is not set to a
+valid value at least once.
+
+[para]
+
+The package will immediately try to map the given name to a file
+containing the code for a formatting engine generating that format. An
+error will be thrown if this mapping fails. In that case a previously
+configured format is left untouched.
+
+[para]
+
+The section [sectref {FORMAT MAPPING}] explains in detail how the
+package and object will look for engine implementations.
+
+[list_end]
+
+[subsection {FORMAT MAPPING}]
+
+The package and object will perform the following algorithm when
+trying to map a format name [term foo] to a file containing an
+implementation of a formatting engine for [term foo]:
+
+[list_begin enumerated]
+[enum]
+
+If [term foo] is the name of an existing file then this file is
+directly taken as the implementation.
+
+[enum]
+
+If not, the list of per-object search paths is searched. For each
+directory in the list the package checks if that directory contains a
+file [file toc.[term foo]]. If yes, then that file is taken as the
+implementation.
+
+[para]
+
+Note that this list of paths is initially empty and can be extended
+through the object method [method search].
+
+[enum]
+
+If not, the list of package paths is searched.
+
+For each directory in the list the package checks if that directory
+contains a file [file toc.[term foo]]. If yes, then that file is taken
+as the implementation.
+
+[para]
+
+This list of paths can be extended
+through the command [cmd ::doctools::toc::search].
+
+It contains initially one path, the subdirectory [file mpformats] of
+the directory the package itself is located in. In other words, if the
+package implementation [file doctoc.tcl] is installed in the directory
+[file /usr/local/lib/tcllib/doctools] then it will by default search
+the directory [file /usr/local/lib/tcllib/doctools/mpformats] for
+format implementations.
+
+[enum]
+
+The mapping fails.
+
+[list_end]
+
+[section {PREDEFINED ENGINES}]
+
+The package provides predefined formatting engines for the following
+formats. Some of the formatting engines support engine
+parameters. These will be explicitly highlighted.
+
+[list_begin definitions]
+[def html]
+
+This engine generates HTML markup, for processing by web browsers and
+the like. This engine supports three parameters:
+
+[list_begin definitions]
+[def footer]
+
+The value for this parameter has to be valid selfcontained HTML markup
+for the body section of a HTML document. The default value is the
+empty string. The value is inserted into the generated output just
+before the [const </body>] tag, closing the body of the generated
+HTML.
+
+[para]
+
+This can be used to insert boilerplate footer markup into the
+generated document.
+
+[def header]
+
+The value for this parameter has to be valid selfcontained HTML markup
+for the body section of a HTML document. The default value is the
+empty string. The value is inserted into the generated output just
+after the [const <body>] tag, starting the body of the generated HTML.
+
+[para]
+
+This can be used to insert boilerplate header markup into the
+generated document.
+
+[def meta]
+
+The value for this parameter has to be valid selfcontained HTML markup
+for the header section of a HTML document. The default value is the
+empty string. The value is inserted into the generated output just
+after the [const <head>] tag, starting the header section of the
+generated HTML.
+
+[para]
+
+This can be used to insert boilerplate meta data markup into the
+generated document, like references to a stylesheet, standard meta
+keywords, etc.
+
+[list_end]
+[para]
+
+[def latex]
+
+This engine generates output suitable for the [syscmd latex] text
+processor coming out of the TeX world.
+
+[def list]
+
+This engine retrieves version, section and title of the manpage from
+the document. As such it can be used to generate a directory listing
+for a set of manpages.
+
+[def nroff]
+
+This engine generates nroff output, for processing by [syscmd nroff],
+or [syscmd groff]. The result will be standard man pages as they are
+known in the unix world.
+
+[def null]
+
+This engine generates no outout at all. This can be used if one just
+wants to validate some input.
+
+[def tmml]
+
+This engine generates TMML markup as specified by Joe English. The Tcl
+Manpage Markup Language is a derivate of XML.
+
+[def wiki]
+
+This engine generates Wiki markup as understood by Jean Claude
+Wippler's [syscmd wikit] application.
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/doctoc.tcl b/tcllib/modules/doctools/doctoc.tcl
new file mode 100644
index 0000000..49b21b6
--- /dev/null
+++ b/tcllib/modules/doctools/doctoc.tcl
@@ -0,0 +1,968 @@
+# doctoc.tcl --
+#
+# Implementation of doctoc objects for Tcl.
+#
+# Copyright (c) 2003-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: doctoc.tcl,v 1.22 2010/06/08 19:13:53 andreas_kupries Exp $
+
+package require Tcl 8.2
+package require textutil::expander
+
+# @mdgen OWNER: api_toc.tcl
+# @mdgen OWNER: checker_toc.tcl
+# @mdgen OWNER: mpformats/*.tcl
+# @mdgen OWNER: mpformats/*.msg
+# @mdgen OWNER: mpformats/toc.*
+# @mdgen OWNER: mpformats/man.macros
+
+namespace eval ::doctools {}
+namespace eval ::doctools::toc {
+ # Data storage in the doctools::toc module
+ # -------------------------------
+ #
+ # One namespace per object, containing
+ # 1) A list of additional search paths for format definition files.
+ # This list extends the list of standard paths known to the module.
+ # The paths in the list are searched before the standard paths.
+ # 2) Configuration information
+ # a) string: The format to use when converting the input.
+ # 4) Name of the interpreter used to perform the syntax check of the
+ # input (= allowed order of formatting commands).
+ # 5) Name of the interpreter containing the code coming from the format
+ # definition file.
+ # 6) Name of the expander object used to interpret the input to convert.
+
+ # commands is the list of subcommands recognized by the doctoc objects
+ variable commands [list \
+ "cget" \
+ "configure" \
+ "destroy" \
+ "format" \
+ "map" \
+ "search" \
+ "warnings" \
+ "parameters" \
+ "setparam" \
+ ]
+
+ # Only export the toplevel commands
+ namespace export new search help
+
+ # Global data
+
+ # 1) List of standard paths to look at when searching for a format
+ # definition. Extensible.
+ # 2) Location of this file in the filesystem
+
+ variable paths [list]
+ variable here [file dirname [info script]]
+}
+
+# ::doctools::toc::search --
+#
+# Extend the list of paths used when searching for format definition files.
+#
+# Arguments:
+# path Path to add to the list. The path has to exist, has to be a
+# directory, and has to be readable.
+#
+# Results:
+# None.
+#
+# Sideeffects:
+# The specified path is added to the front of the list of search
+# paths. This means that the new path is search before the
+# standard paths set at module initialization time.
+
+proc ::doctools::toc::search {path} {
+ variable paths
+
+ if {![file exists $path]} {return -code error "doctools::toc::search: path does not exist"}
+ if {![file isdirectory $path]} {return -code error "doctools::toc::search: path is not a directory"}
+ if {![file readable $path]} {return -code error "doctools::toc::search: path cannot be read"}
+
+ set paths [linsert $paths 0 $path]
+ return
+}
+
+# ::doctools::toc::help --
+#
+# Return a string containing short help
+# regarding the existing formatting commands.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A string.
+
+proc ::doctools::toc::help {} {
+ return "formatting commands\n\
+ * toc_begin - begin of table of contents\n\
+ * toc_end - end of toc\n\
+ * division_start - begin of toc division\n\
+ * division_end - end of toc division\n\
+ * item - toc element\n\
+ * vset - set/get variable values\n\
+ * include - insert external file\n\
+ * lb, rb - left/right brackets\n\
+ "
+}
+
+# ::doctools::toc::new --
+#
+# Create a new doctoc object with a given name. May configure the object.
+#
+# Arguments:
+# name Name of the doctoc object.
+# args Options configuring the new object.
+#
+# Results:
+# name Name of the doctools created
+
+proc ::doctools::toc::new {name args} {
+ if { [llength [info commands ::$name]] } {
+ return -code error "command \"$name\" already exists, unable to create doctoc object"
+ }
+ if {[llength $args] % 2 == 1} {
+ return -code error "wrong # args: doctools::new name ?opt val...??"
+ }
+
+ # The arguments seem to be ok, setup the namespace for the object
+
+ namespace eval ::doctools::toc::doctoc$name {
+ variable paths [list]
+ variable file ""
+ variable format ""
+ variable formatfile ""
+ variable format_ip ""
+ variable chk_ip ""
+ variable expander "[namespace current]::ex"
+ variable ex_ok 0
+ variable msg [list]
+ variable map ; array set map {}
+ variable param [list]
+ }
+
+ # Create the command to manipulate the object
+ # $name -> ::doctools::toc::DocTocProc $name
+ interp alias {} ::$name {} ::doctools::toc::DocTocProc $name
+
+ # If the name was followed by arguments use them to configure the
+ # object before returning its handle to the caller.
+
+ if {[llength $args] > 1} {
+ # Use linsert trick to make the command a pure list.
+ eval [linsert $args 0 _configure $name]
+ }
+ return $name
+}
+
+##########################
+# Private functions follow
+
+# ::doctools::toc::DocTocProc --
+#
+# Command that processes all doctoc object commands.
+# Dispatches any object command to the appropriate internal
+# command implementing its functionality.
+#
+# Arguments:
+# name Name of the doctoc object to manipulate.
+# cmd Subcommand to invoke.
+# args Arguments for subcommand.
+#
+# Results:
+# Varies based on command to perform
+
+proc ::doctools::toc::DocTocProc {name {cmd ""} args} {
+ # Do minimal args checks here
+ if { [llength [info level 0]] == 2 } {
+ error "wrong # args: should be \"$name option ?arg arg ...?\""
+ }
+
+ # Split the args into command and args components
+
+ if { [llength [info commands ::doctools::toc::_$cmd]] == 0 } {
+ variable commands
+ set optlist [join $commands ", "]
+ set optlist [linsert $optlist "end-1" "or"]
+ return -code error "bad option \"$cmd\": must be $optlist"
+ }
+ return [eval [list ::doctools::toc::_$cmd $name] $args]
+}
+
+##########################
+# Method implementations follow (these are also private commands)
+
+# ::doctools::toc::_cget --
+#
+# Retrieve the current value of a particular option
+#
+# Arguments:
+# name Name of the doctoc object to query
+# option Name of the option whose value we are asking for.
+#
+# Results:
+# The value of the option
+
+proc ::doctools::toc::_cget {name option} {
+ _configure $name $option
+}
+
+# ::doctools::toc::_configure --
+#
+# Configure a doctoc object, or query its configuration.
+#
+# Arguments:
+# name Name of the doctoc object to configure
+# args Options and their values.
+#
+# Results:
+# None if configuring the object.
+# A list of all options and their values if called without arguments.
+# The value of one particular option if called with a single argument.
+
+proc ::doctools::toc::_configure {name args} {
+ if {[llength $args] == 0} {
+ # Retrieve the current configuration.
+
+ upvar #0 ::doctools::toc::doctoc${name}::file file
+ upvar #0 ::doctools::toc::doctoc${name}::format format
+
+ set res [list]
+ lappend res -file $file
+ lappend res -format $format
+ return $res
+
+ } elseif {[llength $args] == 1} {
+ # Query the value of one particular option.
+
+ switch -exact -- [lindex $args 0] {
+ -file {
+ upvar #0 ::doctools::toc::doctoc${name}::file file
+ return $file
+ }
+ -format {
+ upvar #0 ::doctools::toc::doctoc${name}::format format
+ return $format
+ }
+ default {
+ return -code error \
+ "doctools::toc::_configure: Unknown option \"[lindex $args 0]\", expected\
+ -file, or -format"
+ }
+ }
+ } else {
+ # Reconfigure the object.
+
+ if {[llength $args] % 2 == 1} {
+ return -code error "wrong # args: doctools::toc::_configure name ?opt val...??"
+ }
+
+ foreach {option value} $args {
+ switch -exact -- $option {
+ -file {
+ upvar #0 ::doctools::toc::doctoc${name}::file file
+ set file $value
+ }
+ -format {
+ if {[catch {
+ set fmtfile [LookupFormat $name $value]
+ SetupFormatter $name $fmtfile
+ upvar #0 ::doctools::toc::doctoc${name}::format format
+ set format $value
+ } msg]} {
+ return -code error \
+ -errorinfo $::errorInfo \
+ "doctools::toc::_configure: -format: $msg"
+ }
+ }
+ default {
+ return -code error \
+ "doctools::toc::_configure: Unknown option \"$option\", expected\
+ -file, or -format"
+ }
+ }
+ }
+ }
+ return ""
+}
+
+# ::doctools::toc::_destroy --
+#
+# Destroy a doctoc object, including its associated command and data storage.
+#
+# Arguments:
+# name Name of the doctoc object to destroy.
+#
+# Results:
+# None.
+
+proc ::doctools::toc::_destroy {name} {
+ # Check the object for sub objects which have to destroyed before
+ # the namespace is torn down.
+ namespace eval ::doctools::toc::doctoc$name {
+ if {$format_ip != ""} {interp delete $format_ip}
+ if {$chk_ip != ""} {interp delete $chk_ip}
+
+ # Expander objects have no delete/destroy method. This would
+ # be a leak if not for the fact that an expander object is a
+ # namespace, and we have arranged to make it a sub namespace of
+ # the doctoc object. Therefore tearing down our object namespace
+ # also cleans up the expander object.
+ # if {$expander != ""} {$expander destroy}
+
+ }
+ namespace delete ::doctools::toc::doctoc$name
+ interp alias {} ::$name {}
+ return
+}
+
+# ::doctools::toc::_map --
+#
+# Add a mapping from symbolic to actual filename to the object.
+#
+# Arguments:
+# name Name of the doctoc object to use
+# sfname Symbolic filename to map
+# afname Actual filename
+#
+# Results:
+# None.
+
+proc ::doctools::toc::_map {name sfname afname} {
+ upvar #0 ::doctools::toc::doctoc${name}::map map
+ set map($sfname) $afname
+ return
+}
+
+# ::doctools::toc::_format --
+#
+# Convert some text in doctools format
+# according to the configuration in the object.
+#
+# Arguments:
+# name Name of the doctoc object to use
+# text Text to convert.
+#
+# Results:
+# The conversion result.
+
+proc ::doctools::toc::_format {name text} {
+ upvar #0 ::doctools::toc::doctoc${name}::format format
+ if {$format == ""} {
+ return -code error "$name: No format was specified"
+ }
+
+ upvar #0 ::doctools::toc::doctoc${name}::format_ip format_ip
+ upvar #0 ::doctools::toc::doctoc${name}::chk_ip chk_ip
+ upvar #0 ::doctools::toc::doctoc${name}::ex_ok ex_ok
+ upvar #0 ::doctools::toc::doctoc${name}::expander expander
+ upvar #0 ::doctools::toc::doctoc${name}::passes passes
+ upvar #0 ::doctools::toc::doctoc${name}::msg warnings
+
+ if {!$ex_ok} {SetupExpander $name}
+ if {$chk_ip == ""} {SetupChecker $name}
+ # assert (format_ip != "")
+
+ set warnings [list]
+ if {[catch {$format_ip eval toc_initialize}]} {
+ return -code error "Could not initialize engine"
+ }
+ set result ""
+
+ for {
+ set p $passes ; set n 1
+ } {
+ $p > 0
+ } {
+ incr p -1 ; incr n
+ } {
+ if {[catch {$format_ip eval [list toc_setup $n]}]} {
+ catch {$format_ip eval toc_shutdown}
+ return -code error "Could not initialize pass $n of engine"
+ }
+ $chk_ip eval ck_initialize
+
+ if {[catch {set result [$expander expand $text]} msg]} {
+ catch {$format_ip eval toc_shutdown}
+ # Filter for checker errors and reduce them to the essential message.
+
+ if {![regexp {^Error in} $msg]} {return -code error $msg}
+ #set msg [join [lrange [split $msg \n] 2 end]]
+
+ if {![regexp {^--> \(FmtError\) } $msg]} {return -code error "Doctoc $msg"}
+ set msg [lindex [split $msg \n] 0]
+ regsub {^--> \(FmtError\) } $msg {} msg
+
+ return -code error $msg
+ }
+
+ $chk_ip eval ck_complete
+ }
+
+ if {[catch {set result [$format_ip eval [list toc_postprocess $result]]}]} {
+ return -code error "Unable to post process final result"
+ }
+ if {[catch {$format_ip eval toc_shutdown}]} {
+ return -code error "Could not shut engine down"
+ }
+ return $result
+
+}
+
+# ::doctools::toc::_search --
+#
+# Add a search path to the object.
+#
+# Arguments:
+# name Name of the doctoc object to extend
+# path Search path to add.
+#
+# Results:
+# None.
+
+proc ::doctools::toc::_search {name path} {
+ if {![file exists $path]} {return -code error "$name search: path does not exist"}
+ if {![file isdirectory $path]} {return -code error "$name search: path is not a directory"}
+ if {![file readable $path]} {return -code error "$name search: path cannot be read"}
+
+ upvar #0 ::doctools::toc::doctoc${name}::paths paths
+ set paths [linsert $paths 0 $path]
+ return
+}
+
+# ::doctools::toc::_warnings --
+#
+# Return the warning accumulated during the last invocation of 'format'.
+#
+# Arguments:
+# name Name of the doctoc object to query
+#
+# Results:
+# A list of warnings.
+
+proc ::doctools::toc::_warnings {name} {
+ upvar #0 ::doctools::toc::doctoc${name}::msg msg
+ return $msg
+}
+
+# ::doctools::_parameters --
+#
+# Returns a list containing the parameters provided
+# by the selected formatting engine.
+#
+# Arguments:
+# name Name of the doctools object to query
+#
+# Results:
+# A list of parameter names
+
+proc ::doctools::toc::_parameters {name} {
+ upvar #0 ::doctools::toc::doctoc${name}::param param
+ return $param
+}
+
+# ::doctools::_setparam --
+#
+# Set a named engine parameter to a value.
+#
+# Arguments:
+# name Name of the doctools object to query
+# param Name of the parameter to set.
+# value Value to set the parameter to.
+#
+# Results:
+# None.
+
+proc ::doctools::toc::_setparam {name param value} {
+ upvar #0 ::doctools::toc::doctoc${name}::format_ip format_ip
+
+ if {$format_ip == {}} {
+ return -code error \
+ "Unable to set parameters without a valid format"
+ }
+
+ $format_ip eval [list toc_varset $param $value]
+ return
+}
+
+##########################
+# Support commands
+
+# ::doctools::toc::LookupFormat --
+#
+# Search a format definition file based upon its name
+#
+# Arguments:
+# name Name of the doctoc object to use
+# format Name of the format to look for.
+#
+# Results:
+# The file containing the format definition
+
+proc ::doctools::toc::LookupFormat {name format} {
+ # Order of searching
+ # 1) Is the name of the format an existing file ?
+ # If yes, take this file.
+ # 2) Look for the file in the directories given to the object itself..
+ # 3) Look for the file in the standard directories of this package.
+
+ if {[file exists $format] && [file isfile $format]} {
+ return $format
+ }
+
+ upvar #0 ::doctools::toc::doctoc${name}::paths opaths
+ foreach path $opaths {
+ set f [file join $path toc.$format]
+ if {[file exists $f] && [file isfile $f]} {
+ return $f
+ }
+ }
+
+ variable paths
+ foreach path $paths {
+ set f [file join $path toc.$format]
+ if {[file exists $f] && [file isfile $f]} {
+ return $f
+ }
+ }
+
+ return -code error "Unknown format \"$format\""
+}
+
+# ::doctools::toc::SetupFormatter --
+#
+# Create and initializes an interpreter containing a
+# formatting engine
+#
+# Arguments:
+# name Name of the doctoc object to manipulate
+# format Name of file containing the code of the engine
+#
+# Results:
+# None.
+
+proc ::doctools::toc::SetupFormatter {name format} {
+
+ # Create and initialize the interpreter first.
+ # Use a transient variable. Interrogate the
+ # engine and check its response. Bail out in
+ # case of errors. Only if we pass the checks
+ # we tear down the old engine and make the new
+ # one official.
+
+ variable here
+ set mpip [interp create -safe] ; # interpreter for the formatting engine
+ #set mpip [interp create] ; # interpreter for the formatting engine
+
+ $mpip invokehidden source [file join $here api_toc.tcl]
+ #$mpip eval [list source [file join $here api_toc.tcl]]
+ interp alias $mpip dt_source {} ::doctools::toc::Source $mpip [file dirname $format]
+ interp alias $mpip dt_read {} ::doctools::toc::Read $mpip [file dirname $format]
+ interp alias $mpip dt_package {} ::doctools::toc::Package $mpip
+ interp alias $mpip file {} ::doctools::toc::FileOp $mpip
+ interp alias $mpip puts_stderr {} ::puts stderr
+ $mpip invokehidden source $format
+ #$mpip eval [list source $format]
+
+ # Check the engine for useability in doctools.
+
+ foreach api {
+ toc_numpasses
+ toc_initialize
+ toc_setup
+ toc_postprocess
+ toc_shutdown
+ toc_listvariables
+ toc_varset
+ } {
+ if {[$mpip eval [list info commands $api]] == {}} {
+ interp delete $mpip
+ error "$format error: API incomplete, cannot use this engine"
+ }
+ }
+ if {[catch {
+ set passes [$mpip eval toc_numpasses]
+ }]} {
+ interp delete $mpip
+ error "$format error: Unable to query for number of passes"
+ }
+ if {![string is integer $passes] || ($passes < 1)} {
+ interp delete $mpip
+ error "$format error: illegal number of passes \"$passes\""
+ }
+ if {[catch {
+ set parameters [$mpip eval toc_listvariables]
+ }]} {
+ interp delete $mpip
+ error "$format error: Unable to query for list of parameters"
+ }
+
+ # Passed the tests. Tear down existing engine,
+ # and checker. The latter is destroyed because
+ # of its aliases into the formatter, which are
+ # now invalid. It will be recreated during the
+ # next call of 'format'.
+
+ upvar #0 ::doctools::toc::doctoc${name}::formatfile formatfile
+ upvar #0 ::doctools::toc::doctoc${name}::format_ip format_ip
+ upvar #0 ::doctools::toc::doctoc${name}::chk_ip chk_ip
+ upvar #0 ::doctools::toc::doctoc${name}::expander expander
+ upvar #0 ::doctools::toc::doctoc${name}::passes xpasses
+ upvar #0 ::doctools::toc::doctoc${name}::param xparam
+
+ if {$chk_ip != {}} {interp delete $chk_ip}
+ if {$format_ip != {}} {interp delete $format_ip}
+
+ set chk_ip ""
+ set format_ip ""
+
+ # Now link engine API into it.
+
+ interp alias $mpip dt_format {} ::doctools::toc::GetFormat $name
+ interp alias $mpip dt_user {} ::doctools::toc::GetUser $name
+ interp alias $mpip dt_fmap {} ::doctools::toc::MapFile $name
+
+ foreach cmd {cappend cget cis cname cpop cpush cset lb rb} {
+ interp alias $mpip ex_$cmd {} $expander $cmd
+ }
+
+ set format_ip $mpip
+ set formatfile $format
+ set xpasses $passes
+ set xparam $parameters
+ return
+}
+
+# ::doctools::toc::SetupChecker --
+#
+# Create and initializes an interpreter for checking the usage of
+# doctoc formatting commands
+#
+# Arguments:
+# name Name of the doctoc object to manipulate
+#
+# Results:
+# None.
+
+proc ::doctools::toc::SetupChecker {name} {
+ # Create an interpreter for checking the usage of doctoc formatting commands
+ # and initialize it: Link it to the interpreter doing the formatting, the
+ # expander object and the configuration information. All of which
+ # is accessible through the token/handle (name of state/object array).
+
+ variable here
+
+ upvar #0 ::doctools::toc::doctoc${name}::chk_ip chk_ip
+ if {$chk_ip != ""} {return}
+
+ upvar #0 ::doctools::toc::doctoc${name}::expander expander
+ upvar #0 ::doctools::toc::doctoc${name}::format_ip format_ip
+
+ set chk_ip [interp create] ; # interpreter hosting the formal format checker
+
+ # Make configuration available through command, then load the code base.
+
+ foreach {cmd ckcmd} {
+ dt_search SearchPaths
+ dt_error FmtError
+ dt_warning FmtWarning
+ } {
+ interp alias $chk_ip $cmd {} ::doctools::toc::$ckcmd $name
+ }
+ $chk_ip eval [list source [file join $here checker_toc.tcl]]
+
+ # Simple expander commands are directly routed back into it, no
+ # checking required.
+
+ foreach cmd {cappend cget cis cname cpop cpush cset lb rb} {
+ interp alias $chk_ip $cmd {} $expander $cmd
+ }
+
+ # Link the formatter commands into the checker. We use the prefix
+ # 'fmt_' to distinguish them from the checking commands.
+
+ foreach cmd {
+ toc_begin toc_end division_start division_end item
+ comment plain_text
+ } {
+ interp alias $chk_ip fmt_$cmd $format_ip fmt_$cmd
+ }
+ return
+}
+
+# ::doctools::toc::SetupExpander --
+#
+# Create and initializes the expander for input
+#
+# Arguments:
+# name Name of the doctoc object to manipulate
+#
+# Results:
+# None.
+
+proc ::doctools::toc::SetupExpander {name} {
+ upvar #0 ::doctools::toc::doctoc${name}::ex_ok ex_ok
+ if {$ex_ok} {return}
+
+ upvar #0 ::doctools::toc::doctoc${name}::expander expander
+ ::textutil::expander $expander
+ $expander evalcmd [list ::doctools::toc::Eval $name]
+ $expander textcmd plain_text
+ set ex_ok 1
+ return
+}
+
+# ::doctools::toc::SearchPaths --
+#
+# API for checker. Returns list of search paths for format
+# definitions. Used to look for message catalogs as well.
+#
+# Arguments:
+# name Name of the doctoc object to query.
+#
+# Results:
+# None.
+
+proc ::doctools::toc::SearchPaths {name} {
+ upvar #0 ::doctools::toc::doctoc${name}::paths opaths
+ variable paths
+
+ set p $opaths
+ foreach s $paths {lappend p $s}
+ return $p
+}
+
+# ::doctools::toc::FmtError --
+#
+# API for checker. Called when an error occurred.
+#
+# Arguments:
+# name Name of the doctoc object to query.
+# text Error message
+#
+# Results:
+# None.
+
+proc ::doctools::toc::FmtError {name text} {
+ return -code error "(FmtError) $text"
+}
+
+# ::doctools::toc::FmtWarning --
+#
+# API for checker. Called when a warning was generated
+#
+# Arguments:
+# name Name of the doctoc object
+# text Warning message
+#
+# Results:
+# None.
+
+proc ::doctools::toc::FmtWarning {name text} {
+ upvar #0 ::doctools::toc::doctoc${name}::msg msg
+ lappend msg $text
+ return
+}
+
+# ::doctools::toc::Eval --
+#
+# API for expander. Routes the macro invocations
+# into the checker interpreter
+#
+# Arguments:
+# name Name of the doctoc object to query.
+#
+# Results:
+# None.
+
+proc ::doctools::toc::Eval {name macro} {
+ upvar #0 ::doctools::toc::doctoc${name}::chk_ip chk_ip
+
+ # Handle the [include] command directly
+ if {[string match include* $macro]} {
+ set macro [$chk_ip eval [list subst $macro]]
+ foreach {cmd filename} $macro break
+ return [ExpandInclude $name $filename]
+ }
+
+ return [$chk_ip eval $macro]
+}
+
+# ::doctools::toc::ExpandInclude --
+#
+# Handle inclusion of files.
+#
+# Arguments:
+# name Name of the doctoc object to query.
+# path Name of file to include and expand.
+#
+# Results:
+# None.
+
+proc ::doctools::toc::ExpandInclude {name path} {
+ # Look for the file relative to the directory of the
+ # main file we are converting. If that fails try to
+ # use the current working directory. Throw an error
+ # if the file couldn't be found.
+
+ upvar #0 ::doctools::toc::doctoc${name}::file file
+
+ set ipath [file normalize [file join [file dirname $file] $path]]
+ if {![file exists $ipath]} {
+ set ipath $path
+ if {![file exists $ipath]} {
+ return -code error "Unable to fine include file \"$path\""
+ }
+ }
+
+ set chan [open $ipath r]
+ set text [read $chan]
+ close $chan
+
+ upvar #0 ::doctools::toc::doctoc${name}::expander expander
+
+ set saved $file
+ set file $ipath
+ set res [$expander expand $text]
+ set file $saved
+
+ return $res
+}
+
+# ::doctools::toc::GetUser --
+#
+# API for formatter. Returns name of current user
+#
+# Arguments:
+# name Name of the doctoc object to query.
+#
+# Results:
+# String, name of current user.
+
+proc ::doctools::toc::GetUser {name} {
+ global tcl_platform
+ return $tcl_platform(user)
+}
+
+# ::doctools::toc::GetFormat --
+#
+# API for formatter. Returns format information
+#
+# Arguments:
+# name Name of the doctoc object to query.
+#
+# Results:
+# Format information
+
+proc ::doctools::toc::GetFormat {name} {
+ upvar #0 ::doctools::toc::doctoc${name}::format format
+ return $format
+}
+
+# ::doctools::toc::MapFile --
+#
+# API for formatter. Maps symbolic to actual filename in a toc
+# item. If no mapping is found it is assumed that the symbolic
+# name is also the actual name.
+#
+# Arguments:
+# name Name of the doctoc object to query.
+# fname Symbolic name of the file.
+#
+# Results:
+# Actual name of the file.
+
+proc ::doctools::toc::MapFile {name fname} {
+ upvar #0 ::doctools::toc::doctoc${name}::map map
+ if {[info exists map($fname)]} {
+ return $map($fname)
+ }
+ return $fname
+}
+
+# ::doctools::toc::Source --
+#
+# API for formatter. Used by engine to ask for
+# additional script files support it.
+#
+# Arguments:
+# name Name of the doctoc object to change.
+#
+# Results:
+# Boolean flag.
+
+proc ::doctools::toc::Source {ip path file} {
+ $ip invokehidden source [file join $path [file tail $file]]
+ #$ip eval [list source [file join $path [file tail $file]]]
+ return
+}
+
+proc ::doctools::toc::Read {ip path file} {
+ #puts stderr "$ip (read $path $file)"
+
+ return [read [set f [open [file join $path [file tail $file]]]]][close $f]
+}
+
+proc ::doctools::toc::FileOp {ip args} {
+ #puts stderr "$ip (file $args)"
+ # -- FUTURE -- disallow unsafe operations --
+
+ return [eval [linsert $args 0 file]]
+}
+
+proc ::doctools::toc::Package {ip pkg} {
+ #puts stderr "$ip package require $pkg"
+
+ set indexScript [Locate $pkg]
+
+ $ip expose source
+ $ip expose load
+ $ip eval $indexScript
+ $ip hide source
+ $ip hide load
+ #$ip eval [list source [file join $path [file tail $file]]]
+ return
+}
+
+proc ::doctools::toc::Locate {p} {
+ # @mdgen NODEP: doctools::__undefined__
+ catch {package require doctools::__undefined__}
+
+ #puts stderr "auto_path = [join $::auto_path \n]"
+
+ # Check if requested package is in the list of loadable packages.
+ # Then get the highest possible version, and then the index script
+
+ if {[lsearch -exact [package names] $p] < 0} {
+ return -code error "Unknown package $p"
+ }
+
+ set v [lindex [lsort -increasing [package versions $p]] end]
+
+ #puts stderr "Package $p = $v"
+
+ return [package ifneeded $p $v]
+}
+
+#------------------------------------
+# Module initialization
+
+namespace eval ::doctools::toc {
+ # Reverse order of searching. First to search is specified last.
+
+ # FOO/doctoc.tcl
+ # => FOO/mpformats
+
+ #catch {search [file join $here lib doctools mpformats]}
+ #catch {search [file join [file dirname $here] lib doctools mpformats]}
+ catch {search [file join $here mpformats]}
+}
+
+package provide doctools::toc 1.1.4
diff --git a/tcllib/modules/doctools/doctoc.test b/tcllib/modules/doctools/doctoc.test
new file mode 100644
index 0000000..da6e752
--- /dev/null
+++ b/tcllib/modules/doctools/doctoc.test
@@ -0,0 +1,319 @@
+# -*- tcl -*-
+# doctoc.test: tests for the doctools::toc package.
+#
+# 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) 2003-2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: doctoc.test,v 1.14 2009/02/12 05:42:47 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+support {
+ use textutil/expander.tcl textutil::expander
+}
+testing {
+ useLocal doctoc.tcl doctools::toc
+}
+
+# -------------------------------------------------------------------------
+
+array_unset env LANG*
+array_unset env LC_*
+set env(LANG) C ; # Usually default if nothing is set, OS X requires this.
+
+# -------------------------------------------------------------------------
+
+namespace import ::doctools::toc::new
+
+# search paths .............................................................
+
+test doctoc-1.0 {default search paths} {
+ llength $::doctools::toc::paths
+} 1
+
+test doctoc-1.1 {extend package search paths} {
+ ::doctools::toc::search [file dirname [info script]]
+ set res [list]
+ lappend res [llength $::doctools::toc::paths]
+ lappend res [lindex $::doctools::toc::paths 0]
+ set res
+} [list 2 [file dirname [info script]]]
+
+test doctoc-1.2 {extend package search paths, error} {
+ catch {::doctools::toc::search foo} result
+ set result
+} {doctools::toc::search: path does not exist}
+
+# format help .............................................................
+
+test doctoc-2.0 {format help} {
+ string length [doctools::toc::help]
+} 338
+
+# doctoc .............................................................
+
+test doctoc-3.0 {doctoc errors} {
+ catch {new} msg
+ set msg
+} [tcltest::wrongNumArgs "new" "name args" 0]
+
+test doctoc-3.1 {doctoc errors} {
+ catch {new set} msg
+ set msg
+} "command \"set\" already exists, unable to create doctoc object"
+
+test doctoc-3.2 {doctoc errors} {
+ new mydoctoc
+ catch {new mydoctoc} msg
+ mydoctoc destroy
+ set msg
+} "command \"mydoctoc\" already exists, unable to create doctoc object"
+
+test doctoc-3.3 {doctoc errors} {
+ catch {new mydoctoc -foo} msg
+ set msg
+} {wrong # args: doctools::new name ?opt val...??}
+
+# doctoc methods ......................................................
+
+test doctoc-4.0 {doctoc method errors} {
+ new mydoctoc
+ catch {mydoctoc} msg
+ mydoctoc destroy
+ set msg
+} "wrong # args: should be \"mydoctoc option ?arg arg ...?\""
+
+test doctoc-4.1 {doctoc errors} {
+ new mydoctoc
+ catch {mydoctoc foo} msg
+ mydoctoc destroy
+ set msg
+} "bad option \"foo\": must be cget, configure, destroy, format, map, search, warnings, parameters, or setparam"
+
+# cget ..................................................................
+
+test doctoc-5.0 {cget errors} {
+ new mydoctoc
+ catch {mydoctoc cget} result
+ mydoctoc destroy
+ set result
+} [tcltest::wrongNumArgs "::doctools::toc::_cget" "name option" 1]
+
+test doctoc-5.1 {cget errors} {
+ new mydoctoc
+ catch {mydoctoc cget foo bar} result
+ mydoctoc destroy
+ set result
+} [tcltest::tooManyArgs "::doctools::toc::_cget" "name option"]
+
+test doctoc-5.2 {cget errors} {
+ new mydoctoc
+ catch {mydoctoc cget -foo} result
+ mydoctoc destroy
+ set result
+} {doctools::toc::_configure: Unknown option "-foo", expected -file, or -format}
+
+foreach {na nb option default newvalue} {
+ 3 4 -file {} foo
+ 5 6 -format {} html
+} {
+ test doctoc-5.$na {cget query} {
+ new mydoctoc
+ set res [mydoctoc cget $option]
+ mydoctoc destroy
+ set res
+ } $default ; # {}
+
+ test doctoc-5.$nb {cget set & query} {
+ new mydoctoc
+ mydoctoc configure $option $newvalue
+ set res [mydoctoc cget $option]
+ mydoctoc destroy
+ set res
+ } $newvalue ; # {}
+}
+
+# configure ..................................................................
+
+test doctoc-6.0 {configure errors} {
+ new mydoctoc
+ catch {mydoctoc configure -foo bar -glub} result
+ mydoctoc destroy
+ set result
+} {wrong # args: doctools::toc::_configure name ?opt val...??}
+# [tcltest::wrongNumArgs "::doctools::toc::_configure" "name ?option?|?option value...?" 1]
+
+test doctoc-6.1 {configure errors} {
+ new mydoctoc
+ catch {mydoctoc configure -foo} result
+ mydoctoc destroy
+ set result
+} {doctools::toc::_configure: Unknown option "-foo", expected -file, or -format}
+
+test doctoc-6.2 {configure retrieval} {
+ new mydoctoc
+ catch {mydoctoc configure} result
+ mydoctoc destroy
+ set result
+} {-file {} -format {}}
+
+foreach {n option illegalvalue result} {
+ 3 -format barf {doctools::toc::_configure: -format: Unknown format "barf"}
+} {
+ test doctoc-6.$n {configure illegal value} {
+ new mydoctoc
+ catch {mydoctoc configure $option $illegalvalue} result
+ mydoctoc destroy
+ set result
+ } $result
+}
+
+foreach {na nb option default newvalue} {
+ 4 5 -file {} foo
+ 6 7 -format {} html
+} {
+ test doctoc-6.$na {configure query} {
+ new mydoctoc
+ set res [mydoctoc configure $option]
+ mydoctoc destroy
+ set res
+ } $default ; # {}
+
+ test doctoc-6.$nb {configure set & query} {
+ new mydoctoc
+ mydoctoc configure $option $newvalue
+ set res [mydoctoc configure $option]
+ mydoctoc destroy
+ set res
+ } $newvalue ; # {}
+}
+
+test doctoc-6.8 {configure full retrieval} {
+ new mydoctoc -file foo -format html
+ catch {mydoctoc configure} result
+ mydoctoc destroy
+ set result
+} {-file foo -format html}
+
+# search ..................................................................
+
+test doctoc-7.0 {search errors} {
+ new mydoctoc
+ catch {mydoctoc search} result
+ mydoctoc destroy
+ set result
+} [tcltest::wrongNumArgs "::doctools::toc::_search" "name path" 1]
+
+test doctoc-7.1 {search errors} {
+ new mydoctoc
+ catch {mydoctoc search foo bar} result
+ mydoctoc destroy
+ set result
+} [tcltest::tooManyArgs "::doctools::toc::_search" "name path"]
+
+test doctoc-7.2 {search errors} {
+ new mydoctoc
+ catch {mydoctoc search foo} result
+ mydoctoc destroy
+ set result
+} {mydoctoc search: path does not exist}
+
+test doctoc-7.3 {search, initial} {
+ new mydoctoc
+ set res [llength $::doctools::toc::doctocmydoctoc::paths]
+ mydoctoc destroy
+ set res
+} 0
+
+test doctoc-7.4 {extend object search paths} {
+ new mydoctoc
+ mydoctoc search [file dirname [info script]]
+ set res [list]
+ lappend res [llength $::doctools::toc::doctocmydoctoc::paths]
+ lappend res [lindex $::doctools::toc::doctocmydoctoc::paths 0]
+ mydoctoc destroy
+ set res
+} [list 1 [file dirname [info script]]]
+
+# format & warnings .......................................................
+
+test doctoc-8.0 {format errors} {
+ new mydoctoc
+ catch {mydoctoc format} result
+ mydoctoc destroy
+ set result
+} [tcltest::wrongNumArgs "::doctools::toc::_format" "name text" 1]
+
+test doctoc-8.1 {format errors} {
+ new mydoctoc
+ catch {mydoctoc format foo bar} result
+ mydoctoc destroy
+ set result
+} [tcltest::tooManyArgs "::doctools::toc::_format" "name text"]
+
+test doctoc-8.2 {format errors} {
+ new mydoctoc
+ catch {mydoctoc format foo} result
+ mydoctoc destroy
+ set result
+} {mydoctoc: No format was specified}
+
+
+test doctoc-8.3 {format} {
+ new mydoctoc -format wiki
+ set res [mydoctoc format {[toc_begin foo bar][item at snafu gnarf][toc_end]}]
+ lappend res [mydoctoc warnings]
+ mydoctoc destroy
+ set res
+} {Table of Contents '''foo''' '''bar''' {[[snafu]]:} at -- gnarf {}}
+
+
+# doctoc syntax .......................................................
+
+test doctoc-9.0 {doctoc syntax} {
+ new mydoctoc -format null
+ catch {mydoctoc format foo} result
+ mydoctoc destroy
+ set result
+} {Doctoc Error in plain text at line 1, column 0:
+[plain_text foo]
+--> (FmtError) TOC error (toc/plaintext), "plain_text foo" : Plain text beyond whitespace is not allowed..}
+
+test docidx-9.1 {doctoc syntax v1.1, empty toc, ok} {
+ new mydocidx -format null
+ set result [mydocidx format {[toc_begin TOC Test][toc_end]}]
+ mydocidx destroy
+ set result
+} {}
+
+test docidx-9.2 {doctoc syntax v1.1, mixing items and divisions, ok} {
+ new mydocidx -format null
+ set result [mydocidx format {[toc_begin TOC Test][item I1f i1 i1d][division_start D Df][item I2f i2 i2d][division_end][toc_end]}]
+ mydocidx destroy
+ set result
+} {}
+
+test docidx-9.3 {doctoc syntax v1.1, empty division, ok} {
+ new mydocidx -format null
+ set result [mydocidx format {[toc_begin TOC Test][division_start D Df][division_end][toc_end]}]
+ mydocidx destroy
+ set result
+} {}
+
+namespace forget ::doctools::toc::new
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools/doctoc_intro.man b/tcllib/modules/doctools/doctoc_intro.man
new file mode 100644
index 0000000..80a3f4d
--- /dev/null
+++ b/tcllib/modules/doctools/doctoc_intro.man
@@ -0,0 +1,105 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctoc_intro n 1.0]
+[see_also docidx_intro]
+[see_also doctoc_lang_cmdref]
+[see_also doctoc_lang_faq]
+[see_also doctoc_lang_intro]
+[see_also doctoc_lang_syntax]
+[see_also doctoc_plugin_apiref]
+[see_also doctools::toc]
+[see_also doctools_intro]
+[keywords markup]
+[keywords {semantic markup}]
+[keywords {table of contents}]
+[keywords toc]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {doctoc introduction}]
+[category {Documentation tools}]
+[description]
+[para]
+
+[term doctoc] (short for [emph {documentation tables of contents}])
+stands for a set of related, yet different, entities which are working
+together for the easy creation and transformation of tables of
+contents for documentation. These are
+
+[list_begin enumerated]
+[enum]
+
+A tcl based language for the semantic markup of a table of
+contents. Markup is represented by Tcl commands.
+
+[enum]
+
+A package providing the ability to read and transform texts written in
+that markup language. It is important to note that the actual
+transformation of the input text is delegated to plugins.
+
+[enum]
+
+An API describing the interface between the package above and a
+plugin.
+
+[list_end]
+
+[para]
+
+Which of the more detailed documents are relevant to the reader of
+this introduction depends on their role in the documentation process.
+
+[para]
+
+[list_begin enumerated]
+[enum]
+A [term writer] of documentation has to understand the markup language
+itself. A beginner to doctoc should read the more informally written
+[term {doctoc language introduction}] first. Having digested this
+the formal [term {doctoc language syntax}] specification should
+become understandable. A writer experienced with doctoc may only
+need the [term {doctoc language command reference}] from time to
+time to refresh her memory.
+
+[para]
+
+While a document is written the [syscmd dtp] application can be used
+to validate it, and after completion it also performs the conversion
+into the chosen system of visual markup, be it *roff, HTML, plain
+text, wiki, etc. The simpler [syscmd dtplite] application makes
+internal use of doctoc when handling directories of documentation,
+automatically generating a proper table of contents for them.
+
+[enum]
+A [term processor] of documentation written in the [term doctoc]
+markup language has to know which tools are available for use.
+
+[para]
+
+The main tool is the aforementioned [syscmd dtp] application provided
+by Tcllib. The simpler [syscmd dtplite] does not expose doctoc to the
+user.
+
+At the bottom level, common to both applications, however sits the
+package [package doctoools::toc], providing the basic facilities to
+read and process files containing text in the doctoc format.
+
+[enum]
+At last, but not least, [term {plugin writers}] have to understand the
+interaction between the [package doctools::toc] package and its
+plugins, as described in the [term {doctoc plugin API reference}].
+
+[list_end]
+
+[section {RELATED FORMATS}]
+
+doctoc does not stand alone, it has two companion formats. These are
+called [term docidx] and [term doctools], and they are for the markup
+of [term {keyword indices}], and general documentation, respectively.
+
+They are described in their own sets of documents, starting at the
+[term {docidx introduction}] and the [term {doctools introduction}],
+respectively.
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/doctoc_lang_cmdref.man b/tcllib/modules/doctools/doctoc_lang_cmdref.man
new file mode 100644
index 0000000..eef57cf
--- /dev/null
+++ b/tcllib/modules/doctools/doctoc_lang_cmdref.man
@@ -0,0 +1,127 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctoc_lang_cmdref n 1.0]
+[see_also doctoc_intro]
+[see_also doctoc_lang_faq]
+[see_also doctoc_lang_intro]
+[see_also doctoc_lang_syntax]
+[keywords {doctoc commands}]
+[keywords {doctoc language}]
+[keywords {doctoc markup}]
+[keywords markup]
+[keywords {semantic markup}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {doctoc language command reference}]
+[category {Documentation tools}]
+[description]
+[para]
+
+This document specifies both names and syntax of all the commands
+which together are the doctoc markup language, version 1.
+
+As this document is intended to be a reference the commands are listed
+in alphabetical order, and the descriptions are relatively short.
+
+A beginner should read the much more informally written
+[term {doctoc language introduction}] first.
+
+[section Commands]
+[list_begin definitions]
+
+[call [cmd comment] [arg plaintext]]
+
+Toc markup. The argument text is marked up as a comment standing
+outside of the actual text of the document. Main use is in free-form
+text.
+
+[call [cmd division_end]]
+
+Toc structure. This command closes the division opened by the last
+[cmd division_begin] command coming before it, and not yet closed.
+
+[call [cmd division_start] [arg text] [opt [arg symfile]]]
+
+Toc structure. This command opens a division in the table of
+contents. Its counterpart is [cmd division_end]. Together they allow a
+user to give a table of contents additional structure.
+
+[para]
+
+The title of the new division is provided by the argument [arg text].
+
+[para]
+
+If the symbolic filename [arg symfile] is present then the section
+title should link to the referenced document, if links are supported
+by the output format.
+
+[call [cmd include] [arg filename]]
+
+Templating. The contents of the named file are interpreted as text
+written in the doctoc markup and processed in the place of the
+include command. The markup in the file has to be self-contained. It
+is not possible for a markup command to cross the file boundaries.
+
+[call [cmd item] [arg file] [arg text] [arg desc]]
+
+Toc structure. This command adds an individual element to the table of
+contents. Each such element refers to a document. The document is
+specified through the symbolic name [arg file]. The [arg text]
+argument is used to label the reference, whereas the [arg desc]
+provides a short descriptive text of that document.
+
+[para]
+
+The symbolic names are used to preserve the convertibility of this
+format to any output format. The actual name of the file will be
+inserted by the chosen formatting engine when converting the
+input. This will be based on a mapping from symbolic to actual names
+given to the engine.
+
+[call [cmd lb]]
+
+Text. The command is replaced with a left bracket. Use in free-form
+text. Required to avoid interpretation of a left bracket as the start
+of a markup command. Its usage is restricted to the arguments of other
+markup commands.
+
+[call [cmd rb]]
+
+Text. The command is replaced with a right bracket. Use in free-form
+text. Required to avoid interpretation of a right bracket as the end
+of a markup command. Its usage is restricted to the arguments of other
+commands.
+
+[call [cmd toc_begin] [arg text] [arg title]]
+
+Document structure. The command to start a table of contents. The
+arguments are a label for the whole group of documents the index
+refers to ([arg text]) and the overall title text for the index
+([arg title]), without markup.
+
+[para]
+
+The label often is the name of the package (or extension) the
+documents belong to.
+
+[call [cmd toc_end]]
+
+Document structure. Command to end a table of contents. Anything in
+the document coming after this command is in error.
+
+[call [cmd vset] [arg varname] [arg value] ]
+
+Templating. In this form the command sets the named document variable
+to the specified [arg value]. It does not generate output. I.e. the
+command is replaced by the empty string.
+
+[call [cmd vset] [arg varname]]
+
+Templating. In this form the command is replaced by the value of the
+named document variable
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/doctoc_lang_faq.man b/tcllib/modules/doctools/doctoc_lang_faq.man
new file mode 100644
index 0000000..1f4df69
--- /dev/null
+++ b/tcllib/modules/doctools/doctoc_lang_faq.man
@@ -0,0 +1,28 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctoc_lang_faq n 1.0]
+[see_also doctoc_lang_cmdref]
+[see_also doctoc_lang_intro]
+[see_also doctoc_lang_syntax]
+[keywords {doctoc commands}]
+[keywords {doctoc language}]
+[keywords {doctoc markup}]
+[keywords {doctoc syntax}]
+[keywords examples]
+[keywords faq]
+[keywords markup]
+[keywords {semantic markup}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {doctoc language faq}]
+[category {Documentation tools}]
+[description]
+[vset theformat doctoc]
+
+[section OVERVIEW]
+
+[include include/placeholder.inc]
+[include include/examples.inc]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/doctoc_lang_intro.man b/tcllib/modules/doctools/doctoc_lang_intro.man
new file mode 100644
index 0000000..ca7589d
--- /dev/null
+++ b/tcllib/modules/doctools/doctoc_lang_intro.man
@@ -0,0 +1,297 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctoc_lang_intro n 1.0]
+[see_also doctoc_intro]
+[see_also doctoc_lang_cmdref]
+[see_also doctoc_lang_syntax]
+[keywords {doctoc commands}]
+[keywords {doctoc language}]
+[keywords {doctoc markup}]
+[keywords {doctoc syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {doctoc language introduction}]
+[category {Documentation tools}]
+[description]
+[para]
+
+This document is an informal introduction to version 1.1 of the doctoc
+markup language based on a multitude of examples. After reading this a
+writer should be ready to understand the two parts of the formal
+specification, i.e. the [term {doctoc language syntax}] specification
+and the [term {doctoc language command reference}].
+
+[subsection Fundamentals]
+
+While the [term {doctoc markup language}] is quite similar to the
+[term {doctools markup language}], in the broadest terms possible,
+there is one key difference. A table of contents consists essentially
+only of markup commands, with no plain text interspersed between them,
+except for whitespace.
+
+[para]
+
+Each markup command is a Tcl command surrounded by a matching pair of
+[const [lb]] and [const [rb]]. Inside of these delimiters the usual
+rules for a Tcl command apply with regard to word quotation, nested
+commands, continuation lines, etc. I.e.
+
+[para]
+[example {
+ ... [division_start {Appendix 1}] ...
+}]
+
+[example {
+ ... [item thefile \\
+ label {file description}] ...
+}]
+
+[subsection {Basic structure}]
+
+The most simple document which can be written in doctoc is
+
+[example {
+ [toc_begin GROUPTITLE TITLE]
+ [toc_end]
+}]
+
+This also shows us that all doctoc documents consist of only one
+part where we will list [term items] and [term divisions].
+
+[para]
+
+The user is free to mix these as she sees fit. This is a change from
+version 1 of the language, which did not allow this mixing, but only
+the use of either a series of items or a series of divisions.
+
+[para]
+
+We will discuss the commands for each of these two possibilities in
+the next sections.
+
+[subsection Items]
+
+Use the command [cmd item] to put an [term item] into a table of
+contents. This is essentially a reference to a section, subsection,
+etc. in the document, or set of documents, the table of contents is
+for. The command takes three arguments, a symbolic name for the file
+the item is for and two text to label the item and describe the
+referenced section.
+
+[para]
+
+Symbolic names are used to preserve the convertibility of this format
+to any output format. The actual name of any file will be inserted by
+the chosen formatting engine when converting the input, based on a
+mapping from symbolic to actual names given to the engine.
+
+[para]
+
+Here a made up example for a table of contents of this document:
+
+[example_begin]
+[lb]toc_begin Doctoc {Language Introduction}[rb]
+[lb][cmd {item 1 DESCRIPTION}][rb]
+[lb][cmd {item 1.1 {Basic structure}}][rb]
+[lb][cmd {item 1.2 Items}][rb]
+[lb][cmd {item 1.3 Divisions}][rb]
+[lb][cmd {item 2 {FURTHER READING}}][rb]
+[lb]toc_end[rb]
+[example_end]
+
+[subsection Divisions]
+
+One thing of notice in the last example in the previous section is
+that the referenced sections actually had a nested structure,
+something which was expressed in the item labels, by using a common
+prefix for all the sections nested under section 1.
+
+[para]
+
+This kind of structure can be made more explicit in the doctoc
+language by using divisions. Instead of using a series of plain items
+we use a series of divisions for the major references, and then place
+the nested items inside of these.
+
+[para]
+
+Of course, instead of the nested items we can again use divisions and
+thus nest arbitrarily deep.
+
+[para]
+
+A division is marked by two commands instead of one, one to start it,
+the other to close the last opened division. They are:
+
+[list_begin commands]
+[cmd_def division_start]
+
+This command opens a new division. It takes one or two arguments, the
+title of the division, and the symbolic name of the file it refers
+to. The latter is optional.
+
+If the symbolic filename is present then the section title should link
+to the referenced document, if links are supported by the output
+format.
+
+[cmd_def division_end]
+This command closes the last opened and not yet closed division.
+
+[list_end]
+
+[para]
+
+Using this we can recast the last example like this
+
+[example_begin]
+[lb]toc_begin Doctoc {Language Introduction}[rb]
+[lb][cmd {division_start DESCRIPTION}][rb]
+[lb]item 1 {Basic structure}[rb]
+[lb]item 2 Items[rb]
+[lb]item 3 Divisions[rb]
+[lb][cmd {division_end}][rb]
+[lb][cmd {division_start {FURTHER READING}}][rb]
+[lb][cmd {division_end}][rb]
+[lb]toc_end[rb]
+[example_end]
+
+[para]
+
+Or, to demonstrate deeper nesting
+
+[example_begin]
+[lb]toc_begin Doctoc {Language Introduction}[rb]
+[lb][cmd {division_start DESCRIPTION}][rb]
+[lb][cmd {division_start {Basic structure}}][rb]
+[lb]item 1 Do[rb]
+[lb]item 2 Re[rb]
+[lb][cmd {division_end}][rb]
+[lb][cmd {division_start Items}][rb]
+[lb]item a Fi[rb]
+[lb]item b Fo[rb]
+[lb]item c Fa[rb]
+[lb][cmd {division_end}][rb]
+[lb][cmd {division_start Divisions}][rb]
+[lb]item 1 Sub[rb]
+[lb]item 1 Zero[rb]
+[lb][cmd {division_end}][rb]
+[lb][cmd {division_end}][rb]
+[lb][cmd {division_start {FURTHER READING}}][rb]
+[lb][cmd {division_end}][rb]
+[lb]toc_end[rb]
+[example_end]
+
+And do not forget, it is possible to freely mix items and divisions,
+and to have empty divisions.
+
+[example_begin]
+[lb]toc_begin Doctoc {Language Introduction}[rb]
+[lb]item 1 Do[rb]
+[lb][cmd {division_start DESCRIPTION}][rb]
+[lb][cmd {division_start {Basic structure}}][rb]
+[lb]item 2 Re[rb]
+[lb][cmd {division_end}][rb]
+[lb]item a Fi[rb]
+[lb][cmd {division_start Items}][rb]
+[lb]item b Fo[rb]
+[lb]item c Fa[rb]
+[lb][cmd {division_end}][rb]
+[lb][cmd {division_start Divisions}][rb]
+[lb][cmd {division_end}][rb]
+[lb][cmd {division_end}][rb]
+[lb][cmd {division_start {FURTHER READING}}][rb]
+[lb][cmd {division_end}][rb]
+[lb]toc_end[rb]
+[example_end]
+
+[subsection {Advanced structure}]
+
+In all previous examples we fudged a bit regarding the markup actually
+allowed to be used before the [cmd toc_begin] command opening the
+document.
+
+[para]
+
+Instead of only whitespace the two templating commands [cmd include]
+and [cmd vset] are also allowed, to enable the writer to either set
+and/or import configuration settings relevant to the table of
+contents. I.e. it is possible to write
+
+[example_begin]
+[lb][cmd {include FILE}][rb]
+[lb][cmd {vset VAR VALUE}][rb]
+[lb]toc_begin GROUPTITLE TITLE[rb]
+...
+[lb]toc_end[rb]
+[example_end]
+
+Even more important, these two commands are allowed anywhere where a
+markup command is allowed, without regard for any other
+structure.
+
+[example_begin]
+[lb]toc_begin GROUPTITLE TITLE[rb]
+[lb][cmd {include FILE}][rb]
+[lb][cmd {vset VAR VALUE}][rb]
+...
+[lb]toc_end[rb]
+[example_end]
+
+The only restriction [cmd include] has to obey is that the contents of
+the included file must be valid at the place of the inclusion. I.e. a
+file included before [cmd toc_begin] may contain only the templating
+commands [cmd vset] and [cmd include], a file included in a division
+may contain only items or divisions commands, etc.
+
+[subsection Escapes]
+
+Beyond the 6 commands shown so far we have two more available.
+
+However their function is not the marking up of toc structure, but the
+insertion of characters, namely [const [lb]] and [const [rb]].
+
+These commands, [cmd lb] and [cmd rb] respectively, are required
+because our use of [lb] and [rb] to bracket markup commands makes it
+impossible to directly use [lb] and [rb] within the text.
+
+[para]
+
+Our example of their use are the sources of the last sentence in the
+previous paragraph, with some highlighting added.
+
+[example_begin]
+ ...
+ These commands, [lb]cmd lb[rb] and [lb]cmd lb[rb] respectively, are required
+ because our use of [lb][cmd lb][rb] and [lb][cmd rb][rb] to bracket markup commands makes it
+ impossible to directly use [lb][cmd lb][rb] and [lb][cmd rb][rb] within the text.
+ ...
+[example_end]
+
+[section {FURTHER READING}]
+
+Now that this document has been digested the reader, assumed to be a
+[term writer] of documentation should be fortified enough to be able
+to understand the formal [term {doctoc language syntax}]
+specification as well. From here on out the
+[term {doctoc language command reference}] will also serve as the
+detailed specification and cheat sheet for all available commands and
+their syntax.
+
+[para]
+
+To be able to validate a document while writing it, it is also
+recommended to familiarize oneself with Tclapps' ultra-configurable
+[syscmd dtp].
+
+[para]
+
+On the other hand, doctoc is perfectly suited for the automatic
+generation from doctools documents, and this is the route Tcllib's
+easy and simple [syscmd dtplite] goes, creating a table of contents
+for a set of documents behind the scenes, without the writer having to
+do so on their own.
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/doctoc_lang_syntax.man b/tcllib/modules/doctools/doctoc_lang_syntax.man
new file mode 100644
index 0000000..d9f0a0c
--- /dev/null
+++ b/tcllib/modules/doctools/doctoc_lang_syntax.man
@@ -0,0 +1,105 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctoc_lang_syntax n 1.0]
+[see_also doctoc_intro]
+[see_also doctoc_lang_cmdref]
+[see_also doctoc_lang_faq]
+[see_also doctoc_lang_intro]
+[keywords {doctoc commands}]
+[keywords {doctoc language}]
+[keywords {doctoc markup}]
+[keywords {doctoc syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+[copyright {2007-2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {doctoc language syntax}]
+[category {Documentation tools}]
+[description]
+[para]
+
+This document contains the formal specification of the syntax of the
+doctoc markup language, version 1.1 in Backus-Naur-Form. This document
+is intended to be a reference, complementing the
+[term {doctoc language command reference}].
+
+A beginner should read the much more informally written
+[term {doctoc language introduction}] first before trying to
+understand either this document or the command reference.
+
+[section Fundamentals]
+
+In the broadest terms possible the [term {doctoc markup language}] is
+like SGML and similar languages. A document written in this language
+consists primarily of markup commands, with text embedded into it at
+some places.
+
+[para]
+
+Each markup command is a just Tcl command surrounded by a matching
+pair of [const [lb]] and [const [rb]]. Which commands are available,
+and their arguments, i.e. syntax is specified in the
+[term {doctoc language command reference}].
+
+[para]
+
+In this document we specify first the lexeme, and then the syntax,
+i.e. how we can mix text and markup commands with each other.
+
+[section {Lexical definitions}]
+
+In the syntax rules listed in the next section
+
+[list_begin enumerated]
+[enum]
+<TEXT> stands for all text except markup commands.
+
+[enum]
+Any XXX stands for the markup command [lb]xxx[rb] including its
+arguments. Each markup command is a Tcl command surrounded by a
+matching pair of [const [lb]] and [const [rb]]. Inside of these
+delimiters the usual rules for a Tcl command apply with regard to word
+quotation, nested commands, continuation lines, etc.
+
+[enum]
+<WHITE> stands for all text consisting only of spaces, newlines,
+tabulators and the [cmd comment] markup command.
+[list_end]
+
+[section Syntax]
+
+The rules listed here specify only the syntax of doctoc documents. The
+lexical level of the language was covered in the previous section.
+
+[para]
+
+Regarding the syntax of the (E)BNF itself
+
+[list_begin enumerated]
+[enum]
+The construct { X } stands for zero or more occurrences of X.
+[enum]
+The construct [lb] X [rb] stands for zero or one occurrence of X.
+[list_end]
+
+The syntax:
+
+[example {
+toc = defs
+ TOC_BEGIN
+ contents
+ TOC_END
+ { <WHITE> }
+
+defs = { INCLUDE | VSET | <WHITE> }
+contents = { defs entry } [ defs ]
+
+entry = ITEM | division
+
+division = DIVISION_START
+ contents
+ DIVISION_END
+}]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/doctoc_plugin_apiref.man b/tcllib/modules/doctools/doctoc_plugin_apiref.man
new file mode 100644
index 0000000..5e034a5
--- /dev/null
+++ b/tcllib/modules/doctools/doctoc_plugin_apiref.man
@@ -0,0 +1,421 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctoc_plugin_apiref n 1.0]
+[see_also doctoc_intro]
+[see_also doctoc_lang_cmdref]
+[see_also doctoc_lang_faq]
+[see_also doctoc_lang_intro]
+[see_also doctoc_lang_syntax]
+[see_also doctools::toc]
+[keywords {formatting engine}]
+[keywords markup]
+[keywords plugin]
+[keywords {semantic markup}]
+[keywords {table of contents}]
+[keywords toc]
+[keywords {toc formatter}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {doctoc plugin API reference}]
+[category {Documentation tools}]
+[description]
+[para]
+
+This document is intended for [term {plugin writers}], i.e. developers
+wishing to write a toc [term {formatting engine}] for some output
+format X.
+
+[para]
+
+It specifies the interaction between the [package doctools::toc]
+package and its plugins, i.e. the interface any toc formatting engine
+has to comply with.
+
+[para]
+
+This document deals with version 1 of the interface.
+
+[para]
+
+A reader who is on the other hand more interested in the markup
+language itself should start with the
+
+[term {doctoc language introduction}] and proceed from there to the
+formal specifications, i.e. the [term {doctoc language syntax}] and
+the [term {doctoc language command reference}].
+
+[section OVERVIEW]
+
+The API for a toc formatting engine consists of two major sections.
+
+[para]
+
+On the one side we have a set of commands through which the plugin is
+able to query the frontend. These commands are provided by the
+frontend and linked into the plugin interpreter. Please see section
+[sectref {FRONTEND COMMANDS}] for their detailed specification.
+
+[para]
+
+And on the other side the plugin has to provide its own set of
+commands which will then be called by the frontend in a specific
+sequence while processing input. They, again, fall into two
+categories, management and formatting.
+
+Please see section [sectref {PLUGIN COMMANDS}] and its subsections for
+their detailed specification.
+
+[section {FRONTEND COMMANDS}]
+
+This section specifies the set of commands through which a plugin,
+also known as a toc formatting engine, is able to query the
+frontend. These commands are provided by the frontend and linked into
+the plugin interpreter.
+
+[para]
+
+I.e. a toc formatting engine can assume that all of the following
+commands are present when any of its own commands (as specified in
+section [sectref {PLUGIN COMMANDS}]) are executed.
+
+[para]
+
+Beyond that it can also assume that it has full access to its own safe
+interpreter and thus is not able to damage the other parts of the
+processor, nor can it damage the filesystem.
+
+It is however able to either kill or hang the whole process, by
+exiting, or running an infinite loop.
+
+[para]
+
+Coming back to the imported commands, all the commands with prefix
+[emph dt_] provide limited access to specific parts of the frontend,
+whereas the commands with prefix [emph ex_] provide access to the
+state of the [package textutil::expander] object which does the main
+parsing of the input within the frontend. These commands should not be
+except under very special circumstances.
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd dt_fmap] [arg symfname]]
+
+Query command. It returns the actual pathname to use in the output in
+place of the symbolic filename [arg symfname]. It will return the
+unchanged input if no mapping was established for [arg symfname].
+
+[para]
+
+The required mappings are established with the method [method map] of
+a frontend, as explained in section [sectref-external {OBJECT METHODS}]
+of the documentation for the package [package doctools::toc].
+
+[call [cmd dt_format]]
+
+Query command. It returns the name of the format associated with the
+toc formatting engine.
+
+[call [cmd dt_read] [arg file]]
+
+Controlled filesystem access. Returns contents of [arg file] for
+whatever use desired by the plugin.
+
+Only files which are either in the same directory as the file
+containing the engine, or below it, can be loaded. Trying to load a
+file outside of this directory causes an error.
+
+[call [cmd dt_source] [arg file]]
+
+Controlled filesystem access. This command allows the toc formatting
+engine to load additional Tcl code it may need.
+
+Only files which are either in the same directory as the file
+containing the engine, or below it, can be loaded. Trying to load a
+file outside of this directory causes an error.
+
+[call [cmd ex_cappend] [arg text]]
+Appends a string to the output in the current context. This command
+should rarely be used by macros or application code.
+
+[call [cmd ex_cget] [arg varname]]
+Retrieves the value of variable [arg varname], defined in the current
+context.
+
+[call [cmd ex_cis] [arg cname]]
+Determines whether or not the name of the current context is
+[arg cname].
+
+[call [cmd ex_cname]]
+Returns the name of the current context.
+
+[call [cmd ex_cpop] [arg cname]]
+Pops a context from the context stack, returning all accumulated
+output in that context. The context must be named [arg cname], or an
+error results.
+
+[call [cmd ex_cpush] [arg cname]]
+Pushes a context named [arg cname] onto the context stack. The
+context must be popped by [method cpop] before expansion ends or an
+error results.
+
+[call [cmd ex_cset] [arg varname] [arg value]]
+Sets variable [arg varname] to [arg value] in the current context.
+
+[call [cmd ex_lb] [opt [arg newbracket]]]
+Returns the current value of the left macro expansion bracket; this is
+for use as or within a macro, when the bracket needs to be included in
+the output text. If [arg newbracket] is specified, it becomes the new
+bracket, and is returned.
+
+[call [cmd ex_rb] [opt [arg newbracket]]]
+Returns the current value of the right macro expansion bracket; this
+is for use as or within a macro, when the bracket needs to be included
+in the output text. If [arg newbracket] is specified, it becomes the
+new bracket, and is returned.
+
+[list_end]
+
+[section {PLUGIN COMMANDS}]
+
+The plugin has to provide its own set of commands which will then be
+called by the frontend in a specific sequence while processing
+input. They fall into two categories, management and formatting. Their
+expected names, signatures, and responsibilities are specified in the
+following two subsections.
+
+[subsection {Management commands}]
+
+The management commands a plugin has to provide are used by the
+frontend to
+
+[list_begin enumerated]
+[enum] initialize and shutdown the plugin
+[enum] determine the number of passes it has
+ to make over the input
+[enum] initialize and shutdown each pass
+[enum] query and initialize engine parameters
+[list_end]
+[para]
+
+After the plugin has been loaded and the frontend commands are
+established the commands will be called in the following sequence:
+
+[example {
+ toc_numpasses -> n
+ toc_listvariables -> vars
+
+ toc_varset var1 value1
+ toc_varset var2 value2
+ ...
+ toc_varset varK valueK
+ toc_initialize
+ toc_setup 1
+ ...
+ toc_setup 2
+ ...
+ ...
+ toc_setup n
+ ...
+ toc_postprocess
+ toc_shutdown
+ ...
+}]
+
+I.e. first the number of passes and the set of available engine
+parameters is established, followed by calls setting the
+parameters. That second part is optional.
+
+[para]
+
+After that the plugin is initialized, the specified number of passes
+executed, the final result run through a global post processing step
+and at last the plugin is shutdown again. This can be followed by more
+conversions, restarting the sequence at [cmd toc_varset].
+
+[para]
+
+In each of the passes, i.e. after the calls of [cmd toc_setup] the
+frontend will process the input and call the formatting commands as
+markup is encountered. This means that the sequence of formatting
+commands is determined by the grammar of the doctoc markup language,
+as specified in the [term {doctoc language syntax}] specification.
+
+[para]
+
+A different way of looking at the sequence is:
+
+[list_begin itemized]
+[item] First some basic parameters are determined.
+
+[item] Then everything starting at the first [cmd toc_varset] to
+[cmd toc_shutdown] forms a [term run], the formatting of a
+single input. Each run can be followed by more.
+
+[item] Embedded within each run we have one or more [term passes],
+each starting with [cmd toc_setup] and going until either the next
+[cmd toc_setup] or [cmd toc_postprocess] is reached.
+
+[para]
+
+If more than one pass is required to perform the formatting only the
+output of the last pass is relevant. The output of all the previous,
+preparatory passes is ignored.
+
+[list_end]
+[para]
+
+The commands, their names, signatures, and responsibilities are, in
+detail:
+
+[list_begin definitions]
+
+[call [cmd toc_initialize]]
+[emph Initialization/Shutdown].
+
+This command is called at the beginning of every conversion run, as
+the first command of that run. Note that a run is not a pass, but may
+consist of multiple passes.
+
+It has to initialize the general state of the plugin, beyond the
+initialization done during the load. No return value is expected, and
+any returned value is ignored.
+
+[call [cmd toc_listvariables]]
+[emph Initialization/Shutdown] and [emph {Engine parameters}].
+
+Second command is called after the plugin code has been loaded,
+i.e. immediately after [cmd toc_numpasses].
+
+It has to return a list containing the names of the parameters the
+frontend can set to configure the engine. This list can be empty.
+
+[call [cmd toc_numpasses]]
+[emph Initialization/Shutdown] and [emph {Pass management}].
+
+First command called after the plugin code has been loaded. No other
+command of the engine will be called before it.
+
+It has to return the number of passes this engine requires to fully
+process the input document. This value has to be an integer number
+greater or equal to one.
+
+[call [cmd toc_postprocess] [arg text]]
+[emph Initialization/Shutdown].
+
+This command is called immediately after the last pass in a run. Its
+argument is the result of the conversion generated by that pass. It is
+provided to allow the engine to perform any global modifications of
+the generated document. If no post-processing is required for a
+specific format the command has to just return the argument.
+
+[para]
+
+Expected to return a value, the final result of formatting the input.
+
+[call [cmd toc_setup] [arg n]]
+[emph Initialization/Shutdown] and [emph {Pass management}].
+
+This command is called at the beginning of each pass over the input in
+a run. Its argument is the number of the pass which has begun. Passes
+are counted from [const 1] upward.
+
+The command has to set up the internal state of the plugin for this
+particular pass. No return value is expected, and any returned value
+is ignored.
+
+[call [cmd toc_shutdown]]
+[emph Initialization/Shutdown].
+
+This command is called at the end of every conversion run. It is the
+last command called in a run. It has to clean up of all the
+run-specific state in the plugin.
+
+After the call the engine has to be in a state which allows the
+initiation of another run without fear that information from the last
+run is leaked into this new run.
+
+No return value is expected, and any returned value is ignored.
+
+[call [cmd toc_varset] [arg varname] [arg text]]
+[emph {Engine parameters}].
+
+This command is called by the frontend to set an engine parameter to a
+particular value.
+
+The parameter to change is specified by [arg varname], the value to
+set in [arg text].
+
+[para]
+
+The command has to throw an error if an unknown [arg varname] is
+used. Only the names returned by [cmd toc_listvariables] have to be
+considered as known.
+
+[para]
+
+The values of all engine parameters have to persist between passes and
+runs.
+
+[list_end]
+
+[subsection {Formatting commands}]
+
+The formatting commands have to implement the formatting for the
+output format, for all the markup commands of the doctoc markup
+language, except [cmd lb], [cmd rb], [cmd vset], [cmd include], and
+[cmd comment]. These exceptions are processed by the frontend and are
+never seen by the plugin. In return a command for the formatting of
+plain text has to be provided, something which has no markup in the
+input at all.
+
+[para]
+
+This means, that each of the five markup commands specified in the
+[term {doctoc language command reference}] and outside of the set of
+exceptions listed above has an equivalent formatting command which
+takes the same arguments as the markup command and whose name is the
+name of markup command with the prefix [emph fmt_] added to it.
+
+[para]
+
+All commands are expected to format their input in some way per the
+semantics specified in the command reference and to return whatever
+part of this that they deem necessary as their result, which will be
+added to the output.
+
+[para]
+
+To avoid essentially duplicating the command reference we do not list
+any of the command here and simply refer the reader to the
+[term {doctoc language command reference}] for their signature and
+description. The sole exception is the plain text formatter, which has
+no equivalent markup command.
+
+[para]
+
+The calling sequence of formatting commands is not as rigid as for the
+management commands, but determined by the grammar of the doctoc
+markup language, as specified in the [term {doctoc language syntax}]
+specification.
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd fmt_plain_text] [arg text]]
+[emph {No associated markup command}].
+
+[para] Called by the frontend for any plain text encountered in the
+input. It has to perform any and all special processing required for
+plain text.
+
+[para] The formatted text is expected as the result of the command,
+and added to the output. If no special processing is required it has
+to simply return its argument without change.
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/doctools.man b/tcllib/modules/doctools/doctools.man
new file mode 100644
index 0000000..950f7b4
--- /dev/null
+++ b/tcllib/modules/doctools/doctools.man
@@ -0,0 +1,543 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset PACKAGE_VERSION 1.4.19]
+[manpage_begin doctools n [vset PACKAGE_VERSION]]
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_intro]
+[see_also doctools_lang_syntax]
+[see_also doctools_plugin_apiref]
+[keywords conversion]
+[keywords documentation]
+[keywords HTML]
+[keywords manpage]
+[keywords markup]
+[keywords nroff]
+[keywords TMML]
+[copyright {2003-2014 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {doctools - Processing documents}]
+[category {Documentation tools}]
+[require Tcl 8.2]
+[require doctools [opt [vset PACKAGE_VERSION]]]
+[description]
+
+This package provides a class for the creation of objects able to
+process and convert text written in the [term doctools] markup
+language into any output format X for which a
+[term {formatting engine}] is available.
+
+[para]
+
+A reader interested in the markup language itself should start with
+the [term {doctools language introduction}] and proceed from there to
+the formal specifications, i.e. the [term {doctools language syntax}]
+and the [term {doctools language command reference}].
+
+[para]
+
+If on the other hand the reader wishes to write her own formatting
+engine for some format, i.e. is a [term {plugin writer}] then reading
+and understanding the [term {doctools plugin API reference}] is an
+absolute necessity, as that document specifies the interaction between
+this package and its plugins, i.e. the formatting engines, in detail.
+
+[section {PUBLIC API}]
+[subsection {PACKAGE COMMANDS}]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::new] [arg objectName] [opt [arg "option value"]...]]
+
+This command creates a new doctools object with an associated Tcl
+command whose name is [arg objectName]. This [term object] command is
+explained in full detail in the sections [sectref {OBJECT COMMAND}]
+and [sectref {OBJECT METHODS}]. The object command will be created
+under the current namespace if the [arg objectName] is not fully
+qualified, and in the specified namespace otherwise.
+
+[para]
+
+The options and their values coming after the name of the object are
+used to set the initial configuration of the object.
+
+[call [cmd ::doctools::help]]
+
+This is a convenience command for applications wishing to provide
+their user with a short description of the available formatting
+commands and their meanings. It returns a string containing a standard
+help text.
+
+[call [cmd ::doctools::search] [arg path]]
+
+Whenever an object created by this the package has to map the name of
+a format to the file containing the code for its formatting engine it
+will search for the file in a number of directories stored in a
+list. See section [sectref {FORMAT MAPPING}] for more explanations.
+
+[para]
+
+This list not only contains three default directories which are
+declared by the package itself, but is also extensible user of the
+package.
+
+This command is the means to do so. When given a [arg path] to an
+existing and readable directory it will prepend that directory to the
+list of directories to search. This means that the [arg path] added
+last is later searched through first.
+
+[para]
+
+An error will be thrown if the [arg path] either does not exist, is
+not a directory, or is not readable.
+
+[list_end]
+
+[subsection {OBJECT COMMAND}]
+
+All commands created by [cmd ::doctools::new] have the following
+general form and may be used to invoke various operations on their
+doctools converter object.
+
+[list_begin definitions]
+
+[call [cmd objectName] [method method] [opt [arg "arg arg ..."]]]
+
+The method [method method] and its [arg arg]'uments determine the exact
+behavior of the command. See section [sectref {OBJECT METHODS}] for
+the detailed specifications.
+
+[list_end]
+
+[subsection {OBJECT METHODS}]
+
+[list_begin definitions]
+
+[call [arg objectName] [method configure]]
+
+The method returns a list of all known options and their current
+values when called without any arguments.
+
+[call [arg objectName] [method configure] [arg option]]
+
+The method behaves like the method [method cget] when called with a
+single argument and returns the value of the option specified by said
+argument.
+
+[call [arg objectName] [method configure] [option -option] [arg value]...]
+
+The method reconfigures the specified [option option]s of the object,
+setting them to the associated [arg value]s, when called with an even
+number of arguments, at least two.
+
+[para]
+
+The legal options are described in the section
+[sectref {OBJECT CONFIGURATION}].
+
+[call [arg objectName] [method cget] [option -option]]
+
+This method expects a legal configuration option as argument and will
+return the current value of that option for the object the method was
+invoked for.
+
+[para]
+
+The legal configuration options are described in section
+[sectref {OBJECT CONFIGURATION}].
+
+[call [arg objectName] [method destroy]]
+
+This method destroys the object it is invoked for.
+
+[call [arg objectName] [method format] [arg text]]
+
+This method runs the [arg text] through the configured formatting
+engine and returns the generated string as its result. An error will
+be thrown if no [option -format] was configured for the object.
+
+[para]
+
+The method assumes that the [arg text] is in [term doctools] format as
+specified in the companion document [term doctools_fmt]. Errors will
+be thrown otherwise.
+
+[call [arg objectName] [method map] [arg symbolic] [arg actual]]
+
+This methods add one entry to the per-object mapping from
+[arg symbolic] filenames to the [arg actual] uris.
+
+The object just stores this mapping and makes it available to the
+configured formatting engine through the command [cmd dt_fmap].
+
+This command is described in more detail in the
+[term {doctools plugin API reference}] which specifies the interaction
+between the objects created by this package and doctools formatting
+engines.
+
+[call [arg objectName] [method parameters]]
+
+This method returns a list containing the names of all engine
+parameters provided by the configured formatting engine. It will
+return an empty list if the object is not yet configured for a
+specific format.
+
+[call [arg objectName] [method search] [arg path]]
+
+This method extends the per-object list of paths searched for doctools
+formatting engines. See also the command [cmd ::doctools::search] on
+how to extend the per-package list of paths. Note that the path
+entered last will be searched first.
+
+For more details see section [sectref {FORMAT MAPPING}].
+
+[call [arg objectName] [method setparam] [arg name] [arg value]]
+
+This method sets the [arg name]d engine parameter to the specified
+[arg value].
+
+It will throw an error if the object is either not yet configured for
+a specific format, or if the formatting engine for the configured
+format does not provide a parameter with the given [arg name].
+
+The list of parameters provided by the configured formatting engine
+can be retrieved through the method [method parameters].
+
+[call [arg objectName] [method warnings]]
+
+This method returns a list containing all the warnings which were
+generated by the configured formatting engine during the last
+invocation of the method [method format].
+
+[list_end]
+
+[subsection {OBJECT CONFIGURATION}]
+
+All doctools objects understand the following configuration options:
+
+[list_begin options]
+
+[opt_def -file [arg file]]
+
+The argument of this option is stored in the object and made available
+to the configured formatting engine through the commands [cmd dt_file]
+and [cmd dt_mainfile].
+
+These commands are described in more detail in the companion document
+[term doctools_api] which specifies the API between the object and
+formatting engines.
+
+[para]
+
+The default value of this option is the empty string.
+
+[para]
+
+The configured formatting engine should interpret the value as the
+name of the file containing the document which is currently processed.
+
+[opt_def -ibase [arg file]]
+
+The argument of this option is stored in the object and used as the
+base path for resolution of relative include paths. If this option is
+not set (empty string) the value of [option -file] is used instead.
+
+[para]
+
+Note that [option -file] and [option -ibase], while similar looking,
+are actually very different. The value of [option -file] is used by
+some engines for the generation of proper relative references between
+output documents (HTML). As such this is a [term destination]
+path. The [option -ibase] on the other hand is used to resolve
+relative include paths, and as such deals with [term source] paths.
+
+[para]
+
+The default value of this option is the empty string.
+
+[opt_def -module [arg text]]
+
+The argument of this option is stored in the object and made available
+to the configured formatting engine through the command [cmd dt_module].
+
+This command is described in more detail in the companion document
+[term doctools_api] which specifies the API between the object and
+formatting engines.
+
+[para]
+
+The default value of this option is the empty string.
+
+[para]
+
+The configured formatting engine should interpret the value as the
+name of the module the file containing the document which is currently
+processed belongs to.
+
+[opt_def -format [arg text]]
+
+The argument of this option specifies the format to generate and by
+implication the formatting engine to use when converting text via the
+method [method format]. Its default value is the empty string. The
+method [method format] cannot be used if this option is not set to a
+valid value at least once.
+
+[para]
+
+The package will immediately try to map the given name to a file
+containing the code for a formatting engine generating that format. An
+error will be thrown if this mapping fails. In that case a previously
+configured format is left untouched.
+
+[para]
+
+The section [sectref {FORMAT MAPPING}] explains in detail how the
+package and object will look for engine implementations.
+
+[opt_def -deprecated [arg boolean]]
+
+This option is a boolean flag. The object will generate warnings if
+this flag is set and the text given to method [method format] contains
+the deprecated markup command [cmd strong].
+
+Its default value is [const FALSE]. In other words, no warnings will
+be generated.
+
+[opt_def -copyright [arg text]]
+
+The argument of this option is stored in the object and made available
+to the configured formatting engine through the command [cmd dt_copyright].
+
+This command is described in more detail in the companion document
+[term doctools_api] which specifies the API between the object and
+formatting engines.
+
+[para]
+
+The default value of this option is the empty string.
+
+[para]
+
+The configured formatting engine should interpret the value as a
+copyright assignment for the document which is currently processed, or
+the package described by it.
+
+[para]
+
+This information must be used if and only if the engine is unable to
+find any copyright assignments within the document itself. Such are
+specified by the formatting command [cmd copyright]. This command is
+described in more detail in the companion document [term doctools_fmt]
+which specifies the [term doctools] format itself.
+
+[list_end]
+
+[subsection {FORMAT MAPPING}]
+
+The package and object will perform the following algorithm when
+trying to map a format name [term foo] to a file containing an
+implementation of a formatting engine for [term foo]:
+
+[list_begin enumerated]
+[enum]
+
+If [term foo] is the name of an existing file then this file is
+directly taken as the implementation.
+
+[enum]
+
+If not, the list of per-object search paths is searched. For each
+directory in the list the package checks if that directory contains a
+file [file fmt.[term foo]]. If yes, then that file is taken as the
+implementation.
+
+[para]
+
+Note that this list of paths is initially empty and can be extended
+through the object method [method search].
+
+[enum]
+
+If not, the list of package paths is searched.
+
+For each directory in the list the package checks if that directory
+contains a file [file fmt.[term foo]]. If yes, then that file is taken
+as the implementation.
+
+[para]
+
+This list of paths can be extended
+through the command [cmd ::doctools::search].
+
+It contains initially one path, the subdirectory [file mpformats] of
+the directory the package itself is located in.
+
+In other words, if the package implementation [file doctools.tcl] is
+installed in the directory [file /usr/local/lib/tcllib/doctools] then
+it will by default search the
+
+directory [file /usr/local/lib/tcllib/doctools/mpformats] for format
+implementations.
+
+[enum]
+
+The mapping fails.
+
+[list_end]
+
+[section {PREDEFINED ENGINES}]
+
+The package provides predefined engines for the following
+formats. Some of the engines support parameters. These will be
+explained below as well.
+
+[list_begin definitions]
+[def html]
+
+This engine generates HTML markup, for processing by web browsers and
+the like. This engine supports four parameters:
+
+[list_begin definitions]
+[def footer]
+
+The value for this parameter has to be valid selfcontained HTML markup
+for the body section of a HTML document. The default value is the
+empty string. The value is inserted into the generated output just
+before the [const </body>] tag, closing the body of the generated
+HTML.
+
+[para]
+
+This can be used to insert boilerplate footer markup into the
+generated document.
+
+[def header]
+
+The value for this parameter has to be valid selfcontained HTML markup
+for the body section of a HTML document. The default value is the
+empty string. The value is inserted into the generated output just
+after the [const <body>] tag, starting the body of the generated HTML.
+
+[para]
+
+This can be used to insert boilerplate header markup into the
+generated document.
+
+[def meta]
+
+The value for this parameter has to be valid selfcontained HTML markup
+for the header section of a HTML document. The default value is the
+empty string. The value is inserted into the generated output just
+after the [const <head>] tag, starting the header section of the
+generated HTML.
+
+[para]
+
+This can be used to insert boilerplate meta data markup into the
+generated document, like references to a stylesheet, standard meta
+keywords, etc.
+
+[def xref]
+
+The value for this parameter has to be a list of triples specifying
+cross-reference information. This information is used by the engine to
+create more hyperlinks. Each triple is a list containing a pattern,
+symbolic filename and fragment reference, in this order. If a pattern
+is specified multiple times the last occurence of the pattern will be
+used.
+
+[para]
+
+The engine will consult the xref database when encountering specific
+commands and will create a link if the relevant text matches one of
+the patterns. No link will be created if no match was found. The link
+will go to the uri [const {file#fragment}] listed in the relevant
+triple, after conversion of the symbolic file name to the actual uri
+via [cmd dt_fmap] (see the [term {doctools plugin API reference}]).
+
+This file-to-uri mapping was build by calls to the method [method map]
+of the doctools object (See section [sectref {OBJECT METHODS}]).
+
+[para]
+
+The following formatting commands will consult the xref database:
+
+[list_begin definitions]
+[def "[cmd cmd] [arg word]"]
+
+The command will look for the patterns [const sa,][arg word], and
+[arg word], in this order. If this fails if it will convert [arg word]
+to all lowercase and try again.
+
+[def "[cmd syscmd] [arg word]"]
+
+The command will look for the patterns [const sa,][arg word], and
+[arg word], in this order. If this fails if it will convert [arg word]
+to all lowercase and try again.
+
+[def "[cmd term] [arg word]"]
+
+The command will look for the patterns [const kw,][arg word],
+[const sa,][arg word], and [arg word], in this order. If this fails if
+it will convert [arg word] to all lowercase and try again.
+
+[def "[cmd package] [arg word]"]
+
+The command will look for the patterns [const sa,][arg word],
+[const kw,][arg word], and [arg word], in this order. If this fails if
+it will convert [arg word] to all lowercase and try again.
+
+[def "[cmd see_also] [arg word]..."]
+
+The command will look for the patterns [const sa,][arg word], and
+[arg word], in this order, for each [arg word] given to the
+command. If this fails if it will convert [arg word] to all lowercase
+and try again.
+
+[def "[cmd keywords] [arg word]..."]
+
+The command will look for the patterns [const kw,][arg word], and
+[arg word], in this order, for each [arg word] given to the
+command. If this fails if it will convert [arg word] to all lowercase
+and try again.
+
+[list_end]
+[list_end]
+[para]
+
+[def latex]
+
+This engine generates output suitable for the [syscmd latex] text
+processor coming out of the TeX world.
+
+[def list]
+
+This engine retrieves version, section and title of the manpage from
+the document. As such it can be used to generate a directory listing
+for a set of manpages.
+
+[def nroff]
+
+This engine generates nroff output, for processing by [syscmd nroff],
+or [syscmd groff]. The result will be standard man pages as they are
+known in the unix world.
+
+[def null]
+
+This engine generates no outout at all. This can be used if one just
+wants to validate some input.
+
+[def tmml]
+
+This engine generates TMML markup as specified by Joe English. The Tcl
+Manpage Markup Language is a derivate of XML.
+
+[def wiki]
+
+This engine generates Wiki markup as understood by Jean Claude
+Wippler's [syscmd wikit] application.
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/doctools.tcl b/tcllib/modules/doctools/doctools.tcl
new file mode 100644
index 0000000..8365633
--- /dev/null
+++ b/tcllib/modules/doctools/doctools.tcl
@@ -0,0 +1,1361 @@
+# doctools.tcl --
+#
+# Implementation of doctools objects for Tcl.
+#
+# Copyright (c) 2003-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tcl 8.2
+package require textutil::expander
+
+# @mdgen OWNER: api.tcl
+# @mdgen OWNER: checker.tcl
+# @mdgen OWNER: mpformats/*.tcl
+# @mdgen OWNER: mpformats/*.msg
+# @mdgen OWNER: mpformats/fmt.*
+# @mdgen OWNER: mpformats/man.macros
+
+namespace eval ::doctools {
+ # Data storage in the doctools module
+ # -------------------------------
+ #
+ # One namespace per object, containing
+ # 1) A list of additional search paths for format definition files.
+ # This list extends the list of standard paths known to the module.
+ # The paths in the list are searched before the standard paths.
+ # 2) Configuration information
+ # a) string: The format to use when converting the input.
+ # b) boolean: A flag telling us whether to warn when visual markup
+ # is used in the input, or not.
+ # c) File information associated with the input, if any.
+ # d) Module information associated with the input, if any.
+ # e) Copyright information, if any
+ # 4) Name of the interpreter used to perform the syntax check of the
+ # input (= allowed order of formatting commands).
+ # 5) Name of the interpreter containing the code coming from the format
+ # definition file.
+ # 6) Name of the expander object used to interpret the input to convert.
+
+ # commands is the list of subcommands recognized by the doctools objects
+ variable commands [list \
+ "cget" \
+ "configure" \
+ "destroy" \
+ "format" \
+ "map" \
+ "search" \
+ "warnings" \
+ "parameters" \
+ "setparam" \
+ ]
+
+ # Only export the toplevel commands
+ namespace export new search help
+
+ # Global data
+
+ # 1) List of standard paths to look at when searching for a format
+ # definition. Extensible.
+ # 2) Location of this file in the filesystem
+
+ variable paths [list]
+ variable here [file dirname [info script]]
+}
+
+# ::doctools::search --
+#
+# Extend the list of paths used when searching for format definition files.
+#
+# Arguments:
+# path Path to add to the list. The path has to exist, has to be a
+# directory, and has to be readable.
+#
+# Results:
+# None.
+#
+# Sideeffects:
+# The specified path is added to the front of the list of search
+# paths. This means that the new path is search before the
+# standard paths set at module initialization time.
+
+proc ::doctools::search {path} {
+ variable paths
+
+ if {![file exists $path]} {return -code error "doctools::search: path does not exist"}
+ if {![file isdirectory $path]} {return -code error "doctools::search: path is not a directory"}
+ if {![file readable $path]} {return -code error "doctools::search: path cannot be read"}
+
+ set paths [linsert $paths 0 $path]
+ return
+}
+
+# ::doctools::help --
+#
+# Return a string containing short help
+# regarding the existing formatting commands.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A string.
+
+proc ::doctools::help {} {
+ return "formatting commands\n\
+ * manpage_begin - begin of manpage\n\
+ * moddesc - module description\n\
+ * titledesc - manpage title\n\
+ * copyright - copyright assignment\n\
+ * manpage_end - end of manpage\n\
+ * require - package requirement\n\
+ * description - begin of manpage body\n\
+ * section - begin new section of body\n\
+ * subsection - begin new sub-section of body\n\
+ * para - begin new paragraph\n\
+ * list_begin - begin a list\n\
+ * list_end - end of a list\n\
+ * lst_item - begin item of definition list\n\
+ * call - command definition, adds to synopsis\n\
+ * usage - see above, without adding to synopsis\n\
+ * bullet - begin item in bulleted list\n\
+ * enum - begin item in enumerated list\n\
+ * arg_def - begin item in argument list\n\
+ * cmd_def - begin item in command list\n\
+ * opt_def - begin item in option list\n\
+ * tkoption_def - begin item in tkoption list\n\
+ * example - example block\n\
+ * example_begin - begin example\n\
+ * example_end - end of example\n\
+ * category - category declaration\n\
+ * see_also - cross reference declaration\n\
+ * keywords - keyword declaration\n\
+ * nl - paragraph break in list items\n\
+ * arg - semantic markup - argument\n\
+ * cmd - semantic markup - command\n\
+ * opt - semantic markup - optional data\n\
+ * comment - semantic markup - comment\n\
+ * sectref - semantic markup - section reference\n\
+ * syscmd - semantic markup - system command\n\
+ * method - semantic markup - object method\n\
+ * namespace - semantic markup - namespace name\n\
+ * option - semantic markup - option\n\
+ * widget - semantic markup - widget\n\
+ * fun - semantic markup - function\n\
+ * type - semantic markup - data type\n\
+ * package - semantic markup - package\n\
+ * class - semantic markup - class\n\
+ * var - semantic markup - variable\n\
+ * file - semantic markup - file \n\
+ * uri - semantic markup - uri (optional label)\n\
+ * term - semantic markup - unspecific terminology\n\
+ * const - semantic markup - constant value\n\
+ * emph - emphasis\n\
+ * strong - emphasis, deprecated, usage is discouraged\n\
+ "
+}
+
+# ::doctools::new --
+#
+# Create a new doctools object with a given name. May configure the object.
+#
+# Arguments:
+# name Name of the doctools object.
+# args Options configuring the new object.
+#
+# Results:
+# name Name of the doctools created
+
+proc ::doctools::new {name args} {
+
+ if { [llength [info commands ::$name]] } {
+ return -code error "command \"$name\" already exists, unable to create doctools object"
+ }
+ if {[llength $args] % 2 == 1} {
+ return -code error "wrong # args: doctools::new name ?opt val...??"
+ }
+
+ # The arguments seem to be ok, setup the namespace for the object
+
+ namespace eval ::doctools::doctools$name {
+ variable paths [list]
+ variable format ""
+ variable formatfile ""
+ variable deprecated 0
+ variable file ""
+ variable mainfile ""
+ variable ibase ""
+ variable module ""
+ variable copyright ""
+ variable format_ip ""
+ variable chk_ip ""
+ variable expander "[namespace current]::ex"
+ variable ex_ok 0
+ variable msg [list]
+ variable param [list]
+ variable map ; array set map {}
+ }
+
+ # Create the command to manipulate the object
+ # $name -> ::doctools::DoctoolsProc $name
+ interp alias {} ::$name {} ::doctools::DoctoolsProc $name
+
+ # If the name was followed by arguments use them to configure the
+ # object before returning its handle to the caller.
+
+ if {[llength $args] > 1} {
+ # Use linsert trick to make the command a pure list.
+ eval [linsert $args 0 _configure $name]
+ }
+ return $name
+}
+
+##########################
+# Private functions follow
+
+# ::doctools::DoctoolsProc --
+#
+# Command that processes all doctools object commands.
+# Dispatches any object command to the appropriate internal
+# command implementing its functionality.
+#
+# Arguments:
+# name Name of the doctools object to manipulate.
+# cmd Subcommand to invoke.
+# args Arguments for subcommand.
+#
+# Results:
+# Varies based on command to perform
+
+proc ::doctools::DoctoolsProc {name {cmd ""} args} {
+ # Do minimal args checks here
+ if { [llength [info level 0]] == 2 } {
+ error "wrong # args: should be \"$name option ?arg arg ...?\""
+ }
+
+ # Split the args into command and args components
+
+ if { [llength [info commands ::doctools::_$cmd]] == 0 } {
+ variable commands
+ set optlist [join $commands ", "]
+ set optlist [linsert $optlist "end-1" "or"]
+ return -code error "bad option \"$cmd\": must be $optlist"
+ }
+ return [eval [list ::doctools::_$cmd $name] $args]
+}
+
+##########################
+# Method implementations follow (these are also private commands)
+
+# ::doctools::_cget --
+#
+# Retrieve the current value of a particular option
+#
+# Arguments:
+# name Name of the doctools object to query
+# option Name of the option whose value we are asking for.
+#
+# Results:
+# The value of the option
+
+proc ::doctools::_cget {name option} {
+ _configure $name $option
+}
+
+# ::doctools::_configure --
+#
+# Configure a doctools object, or query its configuration.
+#
+# Arguments:
+# name Name of the doctools object to configure
+# args Options and their values.
+#
+# Results:
+# None if configuring the object.
+# A list of all options and their values if called without arguments.
+# The value of one particular option if called with a single argument.
+
+proc ::doctools::_configure {name args} {
+ upvar #0 ::doctools::doctools${name}::format_ip format_ip
+ upvar #0 ::doctools::doctools${name}::chk_ip chk_ip
+ upvar #0 ::doctools::doctools${name}::expander expander
+ upvar #0 ::doctools::doctools${name}::passes passes
+
+ if {[llength $args] == 0} {
+ # Retrieve the current configuration.
+
+ upvar #0 ::doctools::doctools${name}::file file
+ upvar #0 ::doctools::doctools${name}::ibase ibase
+ upvar #0 ::doctools::doctools${name}::module module
+ upvar #0 ::doctools::doctools${name}::format format
+ upvar #0 ::doctools::doctools${name}::copyright copyright
+ upvar #0 ::doctools::doctools${name}::deprecated deprecated
+
+ set res [list]
+ lappend res -file $file
+ lappend res -ibase $ibase
+ lappend res -module $module
+ lappend res -format $format
+ lappend res -copyright $copyright
+ lappend res -deprecated $deprecated
+ return $res
+
+ } elseif {[llength $args] == 1} {
+ # Query the value of one particular option.
+
+ switch -exact -- [lindex $args 0] {
+ -file {
+ upvar #0 ::doctools::doctools${name}::file file
+ return $file
+ }
+ -ibase {
+ upvar #0 ::doctools::doctools${name}::ibase ibase
+ return $ibase
+ }
+ -module {
+ upvar #0 ::doctools::doctools${name}::module module
+ return $module
+ }
+ -copyright {
+ upvar #0 ::doctools::doctools${name}::copyright copyright
+ return $copyright
+ }
+ -format {
+ upvar #0 ::doctools::doctools${name}::format format
+ return $format
+ }
+ -deprecated {
+ upvar #0 ::doctools::doctools${name}::deprecated deprecated
+ return $deprecated
+ }
+ default {
+ return -code error \
+ "doctools::_configure: Unknown option \"[lindex $args 0]\", expected\
+ -copyright, -file, -ibase, -module, -format, or -deprecated"
+ }
+ }
+ } else {
+ # Reconfigure the object.
+
+ if {[llength $args] % 2 == 1} {
+ return -code error "wrong # args: doctools::_configure name ?opt val...??"
+ }
+
+ foreach {option value} $args {
+ switch -exact -- $option {
+ -file {
+ upvar #0 ::doctools::doctools${name}::file file
+ upvar #0 ::doctools::doctools${name}::mainfile mfile
+ set file $value
+ set mfile $value
+ }
+ -ibase {
+ upvar #0 ::doctools::doctools${name}::ibase ibase
+ set ibase $value
+ }
+ -module {
+ upvar #0 ::doctools::doctools${name}::module module
+ set module $value
+ }
+ -copyright {
+ upvar #0 ::doctools::doctools${name}::copyright copyright
+ set copyright $value
+ }
+ -format {
+ if {[catch {
+ set fmtfile [LookupFormat $name $value]
+ SetupFormatter $name $fmtfile
+ upvar #0 ::doctools::doctools${name}::format format
+ set format $value
+ } msg]} {
+ return -code error \
+ -errorinfo $::errorInfo \
+ "doctools::_configure: -format: $msg"
+ }
+ }
+ -deprecated {
+ if {![string is boolean $value]} {
+ return -code error \
+ "doctools::_configure: -deprecated expected a boolean, got \"$value\""
+ }
+ upvar #0 ::doctools::doctools${name}::deprecated deprecated
+ set deprecated $value
+ }
+ default {
+ return -code error \
+ "doctools::_configure: Unknown option \"$option\", expected\
+ -copyright, -file, -ibase, -module, -format, or -deprecated"
+ }
+ }
+ }
+ }
+ return ""
+}
+
+# ::doctools::_destroy --
+#
+# Destroy a doctools object, including its associated command and data storage.
+#
+# Arguments:
+# name Name of the doctools object to destroy.
+#
+# Results:
+# None.
+
+proc ::doctools::_destroy {name} {
+ # Check the object for sub objects which have to destroyed before
+ # the namespace is torn down.
+ namespace eval ::doctools::doctools$name {
+ if {$format_ip != ""} {interp delete $format_ip}
+ if {$chk_ip != ""} {interp delete $chk_ip}
+
+ # Expander objects have no delete/destroy method. This would
+ # be a leak if not for the fact that an expander object is a
+ # namespace, and we have arranged to make it a sub namespace of
+ # the doctools object. Therefore tearing down our object namespace
+ # also cleans up the expander object.
+ # if {$expander != ""} {$expander destroy}
+
+ }
+ namespace delete ::doctools::doctools$name
+ interp alias {} ::$name {}
+ return
+}
+
+# ::doctools::_map --
+#
+# Add a mapping from symbolic to actual filename to the object.
+#
+# Arguments:
+# name Name of the doctools object to use
+# sfname Symbolic filename to map
+# afname Actual filename
+#
+# Results:
+# None.
+
+proc ::doctools::_map {name sfname afname} {
+ upvar #0 ::doctools::doctools${name}::map map
+ set map($sfname) $afname
+ return
+}
+
+# ::doctools::_img --
+#
+
+# Add a mapping from symbolic to the actual image filenames to
+# the object. Two actual paths! The path the image is found at
+# in the input, and the path for where image is to be placed in
+# the output.
+#
+# Arguments:
+# name Name of the doctools object to use
+# sfname Symbolic filename to map
+# afnameo Actual filename, origin
+# afnamed Actual filename, destination
+#
+# Results:
+# None.
+
+proc ::doctools::_img {name sfname afnameo afnamed} {
+ upvar #0 ::doctools::doctools${name}::imap imap
+ set imap($sfname) [list $afnameo $afnamed]
+ return
+}
+
+# ::doctools::_format --
+#
+# Convert some text in doctools format
+# according to the configuration in the object.
+#
+# Arguments:
+# name Name of the doctools object to use
+# text Text to convert.
+#
+# Results:
+# The conversion result.
+
+proc ::doctools::_format {name text} {
+ upvar #0 ::doctools::doctools${name}::format format
+ if {$format == ""} {
+ return -code error "$name: No format was specified"
+ }
+
+ upvar #0 ::doctools::doctools${name}::format_ip format_ip
+ upvar #0 ::doctools::doctools${name}::chk_ip chk_ip
+ upvar #0 ::doctools::doctools${name}::ex_ok ex_ok
+ upvar #0 ::doctools::doctools${name}::expander expander
+ upvar #0 ::doctools::doctools${name}::passes passes
+ upvar #0 ::doctools::doctools${name}::msg warnings
+
+ if {!$ex_ok} {SetupExpander $name}
+ if {$chk_ip == ""} {SetupChecker $name}
+ # assert (format_ip != "")
+
+ set warnings [list]
+ if {[catch {$format_ip eval fmt_initialize}]} {
+ return -code error -errorcode {DOCTOOLS ENGINE} \
+ "Could not initialize engine"
+ }
+ set result ""
+
+ for {
+ set p $passes ; set n 1
+ } {
+ $p > 0
+ } {
+ incr p -1 ; incr n
+ } {
+ if {[catch {$format_ip eval [list fmt_setup $n]}]} {
+ catch {$format_ip eval fmt_shutdown}
+ return -code error -errorcode {DOCTOOLS ENGINE} \
+ "Could not initialize pass $n of engine"
+ }
+ $chk_ip eval ck_initialize $n
+
+ if {[catch {set result [$expander expand $text]} msg]} {
+ catch {$format_ip eval fmt_shutdown}
+ # Filter for checker errors and reduce them to the essential message.
+
+ if {![regexp {^Error in} $msg]} {
+ return -code error -errorcode {DOCTOOLS INPUT} $msg
+ }
+ #set msg [join [lrange [split $msg \n] 2 end]]
+
+ if {![regexp {^--> \(FmtError\) } $msg]} {
+ return -code error -errorcode {DOCTOOLS INPUT} "Doctools $msg"
+ }
+ set msg [lindex [split $msg \n] 0]
+ regsub {^--> \(FmtError\) } $msg {} msg
+
+ return -code error -errorcode {DOCTOOLS INPUT} $msg
+ }
+
+ $chk_ip eval ck_complete
+ }
+
+ if {[catch {set result [$format_ip eval [list fmt_postprocess $result]]}]} {
+ return -code error -errorcode {DOCTOOLS ENGINE} \
+ "Unable to post process final result"
+ }
+ if {[catch {$format_ip eval fmt_shutdown}]} {
+ return -code error -errorcode {DOCTOOLS ENGINE} \
+ "Could not shut engine down"
+ }
+ return $result
+
+}
+
+# ::doctools::_search --
+#
+# Add a search path to the object.
+#
+# Arguments:
+# name Name of the doctools object to extend
+# path Search path to add.
+#
+# Results:
+# None.
+
+proc ::doctools::_search {name path} {
+ if {![file exists $path]} {return -code error "$name search: path does not exist"}
+ if {![file isdirectory $path]} {return -code error "$name search: path is not a directory"}
+ if {![file readable $path]} {return -code error "$name search: path cannot be read"}
+
+ upvar #0 ::doctools::doctools${name}::paths paths
+ set paths [linsert $paths 0 $path]
+ return
+}
+
+# ::doctools::_warnings --
+#
+# Return the warning accumulated during the last invocation of 'format'.
+#
+# Arguments:
+# name Name of the doctools object to query
+#
+# Results:
+# A list of warnings.
+
+proc ::doctools::_warnings {name} {
+ upvar #0 ::doctools::doctools${name}::msg msg
+ return $msg
+}
+
+# ::doctools::_parameters --
+#
+# Returns a list containing the parameters provided
+# by the selected formatting engine.
+#
+# Arguments:
+# name Name of the doctools object to query
+#
+# Results:
+# A list of parameter names
+
+proc ::doctools::_parameters {name} {
+ upvar #0 ::doctools::doctools${name}::param param
+ return $param
+}
+
+# ::doctools::_setparam --
+#
+# Set a named engine parameter to a value.
+#
+# Arguments:
+# name Name of the doctools object to query
+# param Name of the parameter to set.
+# value Value to set the parameter to.
+#
+# Results:
+# None.
+
+proc ::doctools::_setparam {name param value} {
+ upvar #0 ::doctools::doctools${name}::format_ip format_ip
+
+ if {$format_ip == {}} {
+ return -code error \
+ "Unable to set parameters without a valid format"
+ }
+
+ $format_ip eval [list fmt_varset $param $value]
+ return
+}
+
+##########################
+# Support commands
+
+# ::doctools::LookupFormat --
+#
+# Search a format definition file based upon its name
+#
+# Arguments:
+# name Name of the doctools object to use
+# format Name of the format to look for.
+#
+# Results:
+# The file containing the format definition
+
+proc ::doctools::LookupFormat {name format} {
+ # Order of searching
+ # 1) Is the name of the format an existing file ?
+ # If yes, take this file.
+ # 2) Look for the file in the directories given to the object itself..
+ # 3) Look for the file in the standard directories of this package.
+
+ if {[file exists $format] && [file isfile $format] } {
+ return $format
+ }
+
+ upvar #0 ::doctools::doctools${name}::paths opaths
+ foreach path $opaths {
+ set f [file join $path fmt.$format]
+ if {[file exists $f] && [file isfile $f]} {
+ return $f
+ }
+ }
+
+ variable paths
+ foreach path $paths {
+ set f [file join $path fmt.$format]
+ if {[file exists $f] && [file isfile $f]} {
+ return $f
+ }
+ }
+
+ return -code error "Unknown format \"$format\""
+}
+
+# ::doctools::SetupFormatter --
+#
+# Create and initializes an interpreter containing a
+# formatting engine
+#
+# Arguments:
+# name Name of the doctools object to manipulate
+# format Name of file containing the code of the engine
+#
+# Results:
+# None.
+
+proc ::doctools::SetupFormatter {name format} {
+
+ # Create and initialize the interpreter first.
+ # Use a transient variable. Interrogate the
+ # engine and check its response. Bail out in
+ # case of errors. Only if we pass the checks
+ # we tear down the old engine and make the new
+ # one official.
+
+ variable here
+ set mpip [interp create -safe] ; # interpreter for the formatting engine
+ $mpip eval [list set auto_path $::auto_path]
+ #set mpip [interp create] ; # interpreter for the formatting engine
+
+ $mpip invokehidden source [file join $here api.tcl]
+ #$mpip eval [list source [file join $here api.tcl]]
+ interp alias $mpip dt_source {} ::doctools::Source $mpip [file dirname $format]
+ interp alias $mpip dt_read {} ::doctools::Read $mpip [file dirname $format]
+ interp alias $mpip dt_package {} ::doctools::Package $mpip
+ interp alias $mpip file {} ::doctools::FileOp $mpip
+ interp alias $mpip puts_stderr {} ::puts stderr
+ interp alias $mpip puts_stdout {} ::puts stdout
+ $mpip invokehidden source $format
+ #$mpip eval [list source $format]
+
+ # Check the engine for useability in doctools.
+
+ foreach api {
+ fmt_numpasses
+ fmt_initialize
+ fmt_setup
+ fmt_postprocess
+ fmt_shutdown
+ fmt_listvariables
+ fmt_varset
+ } {
+ if {[$mpip eval [list info commands $api]] == {}} {
+ interp delete $mpip
+ error "$format error: API incomplete, cannot use this engine"
+ }
+ }
+ if {[catch {
+ set passes [$mpip eval fmt_numpasses]
+ }]} {
+ interp delete $mpip
+ error "$format error: Unable to query for number of passes"
+ }
+ if {![string is integer $passes] || ($passes < 1)} {
+ interp delete $mpip
+ error "$format error: illegal number of passes \"$passes\""
+ }
+ if {[catch {
+ set parameters [$mpip eval fmt_listvariables]
+ }]} {
+ interp delete $mpip
+ error "$format error: Unable to query for list of parameters"
+ }
+
+ # Passed the tests. Tear down existing engine,
+ # and checker. The latter is destroyed because
+ # of its aliases into the formatter, which are
+ # now invalid. It will be recreated during the
+ # next call of 'format'.
+
+ upvar #0 ::doctools::doctools${name}::formatfile formatfile
+ upvar #0 ::doctools::doctools${name}::format_ip format_ip
+ upvar #0 ::doctools::doctools${name}::chk_ip chk_ip
+ upvar #0 ::doctools::doctools${name}::expander expander
+ upvar #0 ::doctools::doctools${name}::passes xpasses
+ upvar #0 ::doctools::doctools${name}::param xparam
+
+ if {$chk_ip != {}} {interp delete $chk_ip}
+ if {$format_ip != {}} {interp delete $format_ip}
+
+ set chk_ip ""
+ set format_ip ""
+
+ # Now link engine API into it.
+
+ interp alias $mpip dt_file {} ::doctools::GetFile $name
+ interp alias $mpip dt_mainfile {} ::doctools::GetMainFile $name
+ interp alias $mpip dt_fileid {} ::doctools::GetFileId $name
+ interp alias $mpip dt_ibase {} ::doctools::GetIBase $name
+ interp alias $mpip dt_module {} ::doctools::GetModule $name
+ interp alias $mpip dt_copyright {} ::doctools::GetCopyright $name
+ interp alias $mpip dt_format {} ::doctools::GetFormat $name
+ interp alias $mpip dt_user {} ::doctools::GetUser $name
+ interp alias $mpip dt_lnesting {} ::doctools::ListLevel $name
+ interp alias $mpip dt_fmap {} ::doctools::MapFile $name
+ interp alias $mpip dt_imgsrc {} ::doctools::ImgSrc $name
+ interp alias $mpip dt_imgdst {} ::doctools::ImgDst $name
+ interp alias $mpip dt_imgdata {} ::doctools::ImgData $name
+ interp alias $mpip file {} ::doctools::FileCmd
+
+ foreach cmd {cappend cget cis cname cpop cpush ctopandclear cset lb rb} {
+ interp alias $mpip ex_$cmd {} $expander $cmd
+ }
+
+ set format_ip $mpip
+ set formatfile $format
+ set xpasses $passes
+ set xparam $parameters
+ return
+}
+
+# ::doctools::SetupChecker --
+#
+# Create and initializes an interpreter for checking the usage of
+# doctools formatting commands
+#
+# Arguments:
+# name Name of the doctools object to manipulate
+#
+# Results:
+# None.
+
+proc ::doctools::SetupChecker {name} {
+ # Create an interpreter for checking the usage of doctools formatting commands
+ # and initialize it: Link it to the interpreter doing the formatting, the
+ # expander object and the configuration information. All of which
+ # is accessible through the token/handle (name of state/object array).
+
+ variable here
+
+ upvar #0 ::doctools::doctools${name}::chk_ip chk_ip
+ if {$chk_ip != ""} {return}
+
+ upvar #0 ::doctools::doctools${name}::expander expander
+ upvar #0 ::doctools::doctools${name}::format_ip format_ip
+
+ set chk_ip [interp create] ; # interpreter hosting the formal format checker
+
+ # Make configuration available through command, then load the code base.
+
+ foreach {cmd ckcmd} {
+ dt_search SearchPaths
+ dt_deprecated Deprecated
+ dt_error FmtError
+ dt_warning FmtWarning
+ dt_where Where
+ dt_file GetFile
+ } {
+ interp alias $chk_ip $cmd {} ::doctools::$ckcmd $name
+ }
+ $chk_ip eval [list source [file join $here checker.tcl]]
+
+ # Simple expander commands are directly routed back into it, no
+ # checking required.
+
+ foreach cmd {cappend cget cis cname cpop cpush ctopandclear cset lb rb} {
+ interp alias $chk_ip $cmd {} $expander $cmd
+ }
+
+ # Link the formatter commands into the checker. We use the prefix
+ # 'fmt_' to distinguish them from the checking commands.
+
+ foreach cmd {
+ manpage_begin moddesc titledesc copyright manpage_end require
+ description section para list_begin list_end lst_item call
+ bullet enum example example_begin example_end see_also
+ keywords nl arg cmd opt comment sectref syscmd method option
+ widget fun type package class var file uri usage term const
+ arg_def cmd_def opt_def tkoption_def emph strong plain_text
+ namespace subsection category image
+ } {
+ interp alias $chk_ip fmt_$cmd $format_ip fmt_$cmd
+ }
+ return
+}
+
+# ::doctools::SetupExpander --
+#
+# Create and initializes the expander for input
+#
+# Arguments:
+# name Name of the doctools object to manipulate
+#
+# Results:
+# None.
+
+proc ::doctools::SetupExpander {name} {
+ upvar #0 ::doctools::doctools${name}::ex_ok ex_ok
+ if {$ex_ok} {return}
+
+ upvar #0 ::doctools::doctools${name}::expander expander
+ ::textutil::expander $expander
+ $expander evalcmd [list ::doctools::Eval $name]
+ $expander textcmd plain_text
+ set ex_ok 1
+ return
+}
+
+# ::doctools::SearchPaths --
+#
+# API for checker. Returns list of search paths for format
+# definitions. Used to look for message catalogs as well.
+#
+# Arguments:
+# name Name of the doctools object to query.
+#
+# Results:
+# None.
+
+proc ::doctools::SearchPaths {name} {
+ upvar #0 ::doctools::doctools${name}::paths opaths
+ variable paths
+
+ set p $opaths
+ foreach s $paths {lappend p $s}
+ return $p
+}
+
+# ::doctools::Deprecated --
+#
+# API for checker. Returns flag determining
+# whether visual markup is warned against, or not.
+#
+# Arguments:
+# name Name of the doctools object to query.
+#
+# Results:
+# None.
+
+proc ::doctools::Deprecated {name} {
+ upvar #0 ::doctools::doctools${name}::deprecated deprecated
+ return $deprecated
+}
+
+# ::doctools::FmtError --
+#
+# API for checker. Called when an error occurred.
+#
+# Arguments:
+# name Name of the doctools object to query.
+# text Error message
+#
+# Results:
+# None.
+
+proc ::doctools::FmtError {name text} {
+ return -code error "(FmtError) $text"
+}
+
+# ::doctools::FmtWarning --
+#
+# API for checker. Called when a warning was generated
+#
+# Arguments:
+# name Name of the doctools object
+# text Warning message
+#
+# Results:
+# None.
+
+proc ::doctools::FmtWarning {name text} {
+ upvar #0 ::doctools::doctools${name}::msg msg
+ lappend msg $text
+ return
+}
+
+# ::doctools::Where --
+#
+# API for checker. Called when the current location is needed
+#
+# Arguments:
+# name Name of the doctools object
+#
+# Results:
+# List containing offset, line, column
+
+proc ::doctools::Where {name} {
+ upvar #0 ::doctools::doctools${name}::expander expander
+ return [$expander where]
+}
+
+# ::doctools::Eval --
+#
+# API for expander. Routes the macro invocations
+# into the checker interpreter
+#
+# Arguments:
+# name Name of the doctools object to query.
+#
+# Results:
+# None.
+
+proc ::doctools::Eval {name macro} {
+ upvar #0 ::doctools::doctools${name}::chk_ip chk_ip
+
+ #puts stderr "\t\t$name [lindex [split $macro] 0]"
+
+ # Handle the [include] command directly
+ if {[string match include* $macro]} {
+ set macro [$chk_ip eval [list subst $macro]]
+ foreach {cmd filename} $macro break
+ return [ExpandInclude $name $filename]
+ }
+
+ # Rewrite the [namespace] command before passing it on.
+ # "namespace" is a special command. The interpreter the validator
+ # resides in uses the package "msgcat", which in turn uses the
+ # builtin namespace. So the builtin cannot be simply
+ # overwritten. We use a different name.
+
+ if {[string match namespace* $macro]} {
+ set macro _$macro
+ }
+ return [$chk_ip eval $macro]
+}
+
+# ::doctools::ExpandInclude --
+#
+# Handle inclusion of files.
+#
+# Arguments:
+# name Name of the doctools object to query.
+# path Name of file to include and expand.
+#
+# Results:
+# None.
+
+proc ::doctools::ExpandInclude {name path} {
+ upvar #0 ::doctools::doctools${name}::file file
+ upvar #0 ::doctools::doctools${name}::ibase ibase
+
+ set savedi $ibase
+ set savedf $file
+
+ set base $ibase
+ if {$base eq {}} { set base $file }
+
+ set ipath [file normalize [file join [file dirname $base] $path]]
+ if {![file exists $ipath]} {
+ set ipath $path
+ if {![file exists $ipath]} {
+ return -code error "Unable to find include file \"$path\""
+ }
+ }
+
+ set chan [open $ipath r]
+ set text [read $chan]
+ close $chan
+
+ upvar #0 ::doctools::doctools${name}::expander expander
+
+ set ibase $ipath
+ set res [$expander expand $text]
+
+ set ibase $savedi
+ set file $savedf
+
+ return $res
+}
+
+# ::doctools::GetUser --
+#
+# API for formatter. Returns name of current user
+#
+# Arguments:
+# name Name of the doctools object to query.
+#
+# Results:
+# String, name of current user.
+
+proc ::doctools::GetUser {name} {
+ global tcl_platform
+ return $tcl_platform(user)
+}
+
+# ::doctools::GetFile --
+#
+# API for formatter. Returns file information
+#
+# Arguments:
+# name Name of the doctools object to query.
+#
+# Results:
+# File information
+
+proc ::doctools::GetFile {name} {
+
+ #puts stderr "GetFile $name"
+
+ upvar #0 ::doctools::doctools${name}::file file
+
+ #puts stderr "ok $file"
+ return $file
+}
+
+proc ::doctools::GetMainFile {name} {
+
+ #puts stderr "GetMainFile $name"
+
+ upvar #0 ::doctools::doctools${name}::mainfile mfile
+
+ #puts stderr "ok $mfile"
+ return $mfile
+}
+
+# ::doctools::GetFileId --
+#
+# API for formatter. Returns file information (truncated to stem of filename)
+#
+# Arguments:
+# name Name of the doctools object to query.
+#
+# Results:
+# File information
+
+proc ::doctools::GetFileId {name} {
+ return [file rootname [file tail [GetFile $name]]]
+}
+
+proc ::doctools::GetIBase {name} {
+ upvar #0 ::doctools::doctools${name}::file file
+ upvar #0 ::doctools::doctools${name}::ibase ibase
+
+ set base $ibase
+ if {$base eq {}} { set base $file }
+ return $base
+}
+
+# ::doctools::FileCmd --
+#
+# API for formatter. Restricted implementation of file.
+#
+# Arguments:
+# name Name of the doctools object to query.
+#
+# Results:
+# Module information
+
+proc ::doctools::FileCmd {cmd args} {
+ switch -exact -- $cmd {
+ split {return [eval file split $args]}
+ join {return [eval file join $args]}
+ tail {return [eval file tail $args]}
+ rootname {return [eval file rootname $args]}
+ }
+ return -code error "Illegal subcommand: $cmd $args"
+}
+
+# ::doctools::GetModule --
+#
+# API for formatter. Returns module information
+#
+# Arguments:
+# name Name of the doctools object to query.
+#
+# Results:
+# Module information
+
+proc ::doctools::GetModule {name} {
+ upvar #0 ::doctools::doctools${name}::module module
+ return $module
+}
+
+# ::doctools::GetCopyright --
+#
+# API for formatter. Returns copyright information
+#
+# Arguments:
+# name Name of the doctools object to query.
+#
+# Results:
+# Copyright information
+
+proc ::doctools::GetCopyright {name} {
+ upvar #0 ::doctools::doctools${name}::copyright copyright
+ return $copyright
+}
+
+# ::doctools::GetFormat --
+#
+# API for formatter. Returns format information
+#
+# Arguments:
+# name Name of the doctools object to query.
+#
+# Results:
+# Format information
+
+proc ::doctools::GetFormat {name} {
+ upvar #0 ::doctools::doctools${name}::format format
+ return $format
+}
+
+# ::doctools::ListLevel --
+#
+# API for formatter. Returns number of open lists
+#
+# Arguments:
+# name Name of the doctools object to query.
+#
+# Results:
+# Boolean flag.
+
+proc ::doctools::ListLevel {name} {
+ upvar #0 ::doctools::doctools${name}::chk_ip chk_ip
+ return [$chk_ip eval LNest]
+}
+
+# ::doctools::MapFile --
+#
+# API for formatter. Maps symbolic to actual filename in a doctools
+# item. If no mapping is found it is assumed that the symbolic name
+# is also the actual name.
+#
+# Arguments:
+# name Name of the doctools object to query.
+# fname Symbolic name of the file.
+#
+# Results:
+# Actual name of the file.
+
+proc ::doctools::MapFile {name fname} {
+ upvar #0 ::doctools::doctools${name}::map map
+
+ #parray map
+
+ if {[info exists map($fname)]} {
+ return $map($fname)
+ }
+ return $fname
+}
+
+# ::doctools::Img{Src,Dst} --
+#
+# API for formatter. Maps symbolic to actual image in a doctools
+# item. Returns nothing if no mapping is found.
+#
+# Arguments:
+# name Name of the doctools object to query.
+# iname Symbolic name of the image file.
+# extensions List of acceptable file extensions.
+#
+# Results:
+# Actual name of the file.
+
+proc ::doctools::ImgData {name iname extensions} {
+
+ # The system searches for the image relative to the current input
+ # file, and the current main file
+
+ upvar #0 ::doctools::doctools${name}::imap imap
+
+ #parray imap
+
+ foreach e $extensions {
+ if {[info exists imap($iname.$e)]} {
+ foreach {origin dest} $imap($iname.$e) break
+
+ set f [open $origin r]
+ set img [read $f]
+ close $f
+
+ return $img
+ }
+ }
+ return {}
+}
+
+proc ::doctools::ImgSrc {name iname extensions} {
+
+ # The system searches for the image relative to the current input
+ # file, and the current main file
+
+ upvar #0 ::doctools::doctools${name}::imap imap
+
+ #parray imap
+
+ foreach e $extensions {
+ if {[info exists imap($iname.$e)]} {
+ foreach {origin dest} $imap($iname.$e) break
+ return $origin
+ }
+ }
+ return {}
+}
+
+proc ::doctools::ImgDst {name iname extensions} {
+ # The system searches for the image relative to the current input
+ # file, and the current main file
+
+ upvar #0 ::doctools::doctools${name}::imap imap
+
+ #parray imap
+
+ foreach e $extensions {
+ if {[info exists imap($iname.$e)]} {
+ foreach {origin dest} $imap($iname.$e) break
+ file mkdir [file dirname $dest]
+ file copy -force $origin $dest
+ return $dest
+ }
+ }
+ return {}
+}
+
+# ::doctools::Source --
+#
+# API for formatter. Used by engine to ask for
+# additional script files support it.
+#
+# Arguments:
+# name Name of the doctools object to change.
+#
+# Results:
+# Boolean flag.
+
+proc ::doctools::Source {ip path file} {
+ #puts stderr "$ip (source $path $file)"
+
+ $ip invokehidden source [file join $path [file tail $file]]
+ #$ip eval [list source [file join $path [file tail $file]]]
+ return
+}
+
+proc ::doctools::Read {ip path file} {
+ #puts stderr "$ip (read $path $file)"
+
+ return [read [set f [open [file join $path [file tail $file]]]]][close $f]
+}
+
+proc ::doctools::Locate {p} {
+ # @mdgen NODEP: doctools::__undefined__
+ catch {package require doctools::__undefined__}
+
+ #puts stderr "auto_path = [join $::auto_path \n]"
+
+ # Check if requested package is in the list of loadable packages.
+ # Then get the highest possible version, and then the index script
+
+ if {[lsearch -exact [package names] $p] < 0} {
+ return -code error "Unknown package $p"
+ }
+
+ set v [lindex [lsort -increasing [package versions $p]] end]
+
+ #puts stderr "Package $p = $v"
+
+ return [package ifneeded $p $v]
+}
+
+proc ::doctools::FileOp {ip args} {
+ #puts stderr "$ip (file $args)"
+ # -- FUTURE -- disallow unsafe operations --
+
+ return [eval [linsert $args 0 file]]
+}
+
+proc ::doctools::Package {ip pkg} {
+ #puts stderr "$ip package require $pkg"
+
+ set indexScript [Locate $pkg]
+
+ $ip expose source
+ $ip expose load
+ $ip eval $indexScript
+ $ip hide source
+ $ip hide load
+ #$ip eval [list source [file join $path [file tail $file]]]
+ return
+}
+
+#------------------------------------
+# Module initialization
+
+namespace eval ::doctools {
+ # Reverse order of searching. First to search is specified last.
+
+ # FOO/doctools.tcl
+ # => FOO/mpformats
+
+ #catch {search [file join $here lib doctools mpformats]}
+ #catch {search [file join [file dirname $here] lib doctools mpformats]}
+ catch {search [file join $here mpformats]}
+}
+
+package provide doctools 1.4.19
diff --git a/tcllib/modules/doctools/doctools.test b/tcllib/modules/doctools/doctools.test
new file mode 100644
index 0000000..9d7935c
--- /dev/null
+++ b/tcllib/modules/doctools/doctools.test
@@ -0,0 +1,443 @@
+# -*- tcl -*-
+# doctools.test: tests for the doctools package.
+#
+# 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) 2003-2010 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: doctools.test,v 1.28 2011/01/13 02:41:44 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+support {
+ use textutil/expander.tcl textutil::expander
+ use fileutil/fileutil.tcl fileutil
+}
+testing {
+ useLocal doctools.tcl doctools
+}
+
+# -------------------------------------------------------------------------
+
+array_unset env LANG*
+array_unset env LC_*
+set env(LANG) C ; # Usually default if nothing is set, OS X requires this.
+
+# -------------------------------------------------------------------------
+
+namespace import ::doctools::new
+
+# ---------------------------------------------------
+
+# search paths .............................................................
+
+test doctools-1.0 {default search paths} {
+ llength $::doctools::paths
+} 1
+
+test doctools-1.1 {extend package search paths} {
+ ::doctools::search [file dirname [info script]]
+ set res [list]
+ lappend res [llength $::doctools::paths]
+ lappend res [lindex $::doctools::paths 0]
+ set res
+} [list 2 [file dirname [info script]]]
+
+test doctools-1.2 {extend package search paths, error} {
+ catch {::doctools::search foo} result
+ set result
+} {doctools::search: path does not exist}
+
+# format help .............................................................
+
+test doctools-2.0 {format help} {
+ string length [doctools::help]
+} 2213
+
+# doctools .............................................................
+
+test doctools-3.0 {doctools errors} {
+ catch {new} msg
+ set msg
+} [tcltest::wrongNumArgs "new" "name args" 0]
+
+test doctools-3.1 {doctools errors} {
+ catch {new set} msg
+ set msg
+} "command \"set\" already exists, unable to create doctools object"
+
+test doctools-3.2 {doctools errors} {
+ new mydoctools
+ catch {new mydoctools} msg
+ mydoctools destroy
+ set msg
+} "command \"mydoctools\" already exists, unable to create doctools object"
+
+test doctools-3.3 {doctools errors} {
+ catch {new mydoctools -foo} msg
+ set msg
+} {wrong # args: doctools::new name ?opt val...??}
+
+# doctools methods ......................................................
+
+test doctools-4.0 {doctools method errors} {
+ new mydoctools
+ catch {mydoctools} msg
+ mydoctools destroy
+ set msg
+} "wrong # args: should be \"mydoctools option ?arg arg ...?\""
+
+test doctools-4.1 {doctools errors} {
+ new mydoctools
+ catch {mydoctools foo} msg
+ mydoctools destroy
+ set msg
+} "bad option \"foo\": must be cget, configure, destroy, format, map, search, warnings, parameters, or setparam"
+
+# cget ..................................................................
+
+test doctools-5.0 {cget errors} {
+ new mydoctools
+ catch {mydoctools cget} result
+ mydoctools destroy
+ set result
+} [tcltest::wrongNumArgs "::doctools::_cget" "name option" 1]
+
+test doctools-5.1 {cget errors} {
+ new mydoctools
+ catch {mydoctools cget foo bar} result
+ mydoctools destroy
+ set result
+} [tcltest::tooManyArgs "::doctools::_cget" "name option"]
+
+test doctools-5.2 {cget errors} {
+ new mydoctools
+ catch {mydoctools cget -foo} result
+ mydoctools destroy
+ set result
+} {doctools::_configure: Unknown option "-foo", expected -copyright, -file, -ibase, -module, -format, or -deprecated}
+
+foreach {na nb option default newvalue} {
+ 3 4 -deprecated 0 1
+ 5 6 -file {} foo
+ 7 8 -module {} bar
+ 9 10 -format {} latex
+ 11 12 -copyright {} {Andreas Kupries}
+} {
+ test doctools-5.$na {cget query} {
+ new mydoctools
+ set res [mydoctools cget $option]
+ mydoctools destroy
+ set res
+ } $default ; # {}
+
+ test doctools-5.$nb {cget set & query} {
+ new mydoctools
+ mydoctools configure $option $newvalue
+ set res [mydoctools cget $option]
+ mydoctools destroy
+ set res
+ } $newvalue ; # {}
+}
+
+# configure ..................................................................
+
+test doctools-6.0 {configure errors} {
+ new mydoctools
+ catch {mydoctools configure -foo bar -glub} result
+ mydoctools destroy
+ set result
+} {wrong # args: doctools::_configure name ?opt val...??}
+# [tcltest::wrongNumArgs "::doctools::_configure" "name ?option?|?option value...?" 1]
+
+test doctools-6.1 {configure errors} {
+ new mydoctools
+ catch {mydoctools configure -foo} result
+ mydoctools destroy
+ set result
+} {doctools::_configure: Unknown option "-foo", expected -copyright, -file, -ibase, -module, -format, or -deprecated}
+
+test doctools-6.2 {configure retrieval} {
+ new mydoctools
+ catch {mydoctools configure} result
+ mydoctools destroy
+ set result
+} {-file {} -ibase {} -module {} -format {} -copyright {} -deprecated 0}
+
+foreach {n option illegalvalue result} {
+ 3 -deprecated foo {doctools::_configure: -deprecated expected a boolean, got "foo"}
+ 4 -format barf {doctools::_configure: -format: Unknown format "barf"}
+} {
+ test doctools-6.$n {configure illegal value} {
+ new mydoctools
+ catch {mydoctools configure $option $illegalvalue} result
+ mydoctools destroy
+ set result
+ } $result
+}
+
+foreach {na nb option default newvalue} {
+ 5 6 -deprecated 0 1
+ 7 8 -file {} foo
+ 9 10 -module {} bar
+ 11 12 -format {} latex
+ 13 14 -copyright {} {Andreas Kupries}
+} {
+ test doctools-6.$na {configure query} {
+ new mydoctools
+ set res [mydoctools configure $option]
+ mydoctools destroy
+ set res
+ } $default ; # {}
+
+ test doctools-6.$nb {configure set & query} {
+ new mydoctools
+ mydoctools configure $option $newvalue
+ set res [mydoctools configure $option]
+ mydoctools destroy
+ set res
+ } $newvalue ; # {}
+}
+
+test doctools-6.15 {configure full retrieval} {
+ new mydoctools -file foo -module bar -format latex -deprecated 1 -copyright gnarf
+ catch {mydoctools configure} result
+ mydoctools destroy
+ set result
+} {-file foo -ibase {} -module bar -format latex -copyright gnarf -deprecated 1}
+
+# search ..................................................................
+
+test doctools-7.0 {search errors} {
+ new mydoctools
+ catch {mydoctools search} result
+ mydoctools destroy
+ set result
+} [tcltest::wrongNumArgs "::doctools::_search" "name path" 1]
+
+test doctools-7.1 {search errors} {
+ new mydoctools
+ catch {mydoctools search foo bar} result
+ mydoctools destroy
+ set result
+} [tcltest::tooManyArgs "::doctools::_search" "name path"]
+
+test doctools-7.2 {search errors} {
+ new mydoctools
+ catch {mydoctools search foo} result
+ mydoctools destroy
+ set result
+} {mydoctools search: path does not exist}
+
+test doctools-7.3 {search, initial} {
+ new mydoctools
+ set res [llength $::doctools::doctoolsmydoctools::paths]
+ mydoctools destroy
+ set res
+} 0
+
+test doctools-7.4 {extend object search paths} {
+ new mydoctools
+ mydoctools search [file dirname [info script]]
+ set res [list]
+ lappend res [llength $::doctools::doctoolsmydoctools::paths]
+ lappend res [lindex $::doctools::doctoolsmydoctools::paths 0]
+ mydoctools destroy
+ set res
+} [list 1 [file dirname [info script]]]
+
+# format & warnings .......................................................
+
+test doctools-8.0 {format errors} {
+ new mydoctools
+ catch {mydoctools format} result
+ mydoctools destroy
+ set result
+} [tcltest::wrongNumArgs "::doctools::_format" "name text" 1]
+
+test doctools-8.1 {format errors} {
+ new mydoctools
+ catch {mydoctools format foo bar} result
+ mydoctools destroy
+ set result
+} [tcltest::tooManyArgs "::doctools::_format" "name text"]
+
+test doctools-8.2 {format errors} {
+ new mydoctools
+ catch {mydoctools format foo} result
+ mydoctools destroy
+ set result
+} {mydoctools: No format was specified}
+
+
+test doctools-8.3 {format} {
+ new mydoctools -format list
+ set res [mydoctools format {[manpage_begin foo n 1.0][description][strong foo][manpage_end]}]
+ set res [list [lindex $res 0] [dictsort [lindex $res 1]]]
+ lappend res [mydoctools warnings]
+ mydoctools destroy
+ set res
+} {manpage {category {} desc {} fid {} file {} keywords {} module {} section n seealso {} shortdesc {} title foo version 1.0} {}}
+
+test doctools-8.4 {format} {
+ new mydoctools -format list -deprecated on
+ set res [mydoctools format {[manpage_begin foo n 1.0][description][strong foo][manpage_end]}]
+ set res [list [lindex $res 0] [dictsort [lindex $res 1]]]
+ lappend res [mydoctools warnings]
+ mydoctools destroy
+ set res
+} {manpage {category {} desc {} fid {} file {} keywords {} module {} section n seealso {} shortdesc {} title foo version 1.0} {{DocTools Warning (depr_strong): In macro at line 1, column 38 of file :
+DocTools Warning (depr_strong): Deprecated command "[strong]".
+DocTools Warning (depr_strong): Please consider appropriate semantic markup or [emph] instead.}}}
+
+
+
+# doctools manpage syntax .......................................................
+
+test doctools-9.0 {manpage syntax} {
+ new mydoctools -format null
+ catch {mydoctools format foo} result
+ mydoctools destroy
+ set result
+} {Doctools Error in plain text at line 1, column 0:
+[plain_text foo]
+--> (FmtError) Manpage error (body), "plain_text foo" : Plain text not allowed outside of the body of the manpage.}
+
+# -------------------------------------------------------------------------
+## Series of tests for all available backends, check their formatting.
+
+set k 11
+foreach format {
+ html tmml
+ nroff latex
+ text wiki
+ desc list null
+} {
+ set n 0
+ foreach src [TestFilesGlob tests/man/*] {
+ if {[file tail $src] == "CVS"} continue
+
+ # Get the expected result
+ set dst [localPath [file join tests $format [file tail $src]]]
+ set map @ID@ ; lappend map \$Id\$ ; lappend map @USR@ $tcl_platform(user)
+ set rem \$Id\$ ; lappend rem @ID@ ; lappend $tcl_platform(user) @USR@
+ if {$format eq "nroff"} {
+ lappend map ".so man.macros\n" [fileutil::cat [localPath mpformats/man.macros]]
+ }
+ if {[catch {
+ set expected [string map $map [fileutil::cat $dst]]
+ }]} { set expected **missing** }
+
+ test doctools-${format}-${k}.$n "doctools backends, $format/[file tail $src]" {
+ new mydoctools
+ mydoctools configure \
+ -format $format \
+ -module .MODULE. \
+ -file .FILE. \
+ -copyright .COPYRIGHT.
+ if {[catch {
+ set res [mydoctools format [fileutil::cat $src]]
+ }]} {
+ set res $::errorInfo
+ }
+ mydoctools destroy
+ #fileutil::writeFile ${dst}.actual [string map $rem $res]
+ set res
+ } $expected
+
+ #fileutil::writeFile ${dst}.expected $expected
+ incr n
+ }
+ incr k
+}
+
+
+# -------------------------------------------------------------------------
+## Test of special 'raw' mode available to the HTML backend.
+
+set n 0
+foreach src [TestFilesGlob tests/man/*] {
+ if {[file tail $src] == "CVS"} continue
+
+ # Get the expected result
+ set dst [localPath [file join tests html [file tail $src]]]
+ set map @ID@ ; lappend map \$Id\$ ; lappend map @USR@ $tcl_platform(user)
+ set rem \$Id\$ ; lappend rem @ID@ ; lappend $tcl_platform(user) @USR@
+
+ if {[catch {
+ set expected [string map $map [fileutil::cat $dst]]
+ }]} { set expected **missing** }
+
+ # Transform regular output to contents of body/, i.e. raw output.
+ regsub {</body>.*} $expected {} expected
+ regsub {.*<body>} $expected {} expected
+ append expected \n
+ if {$n == 5 || $n == 8} { set expected \n$expected }
+
+ # Run the test ...
+ test doctools-html-raw-11.$n "doctools backends, html-raw/[file tail $src]" {
+ new mydoctools
+ mydoctools configure \
+ -format html \
+ -module .MODULE. \
+ -file .FILE. \
+ -copyright .COPYRIGHT.
+ mydoctools setparam raw 1
+ if {[catch {
+ set res [mydoctools format [fileutil::cat $src]]
+ }]} {
+ set res $::errorInfo
+ }
+ mydoctools destroy
+ #fileutil::writeFile ${dst}.actual [string map $rem $res]
+ set res
+ } $expected
+
+ #fileutil::writeFile ${dst}.expected $expected
+ incr n
+}
+
+# -------------------------------------------------------------------------
+## Series of tests for the frontend, cover all possible syntax errors.
+
+set n 0
+foreach src [TestFilesGlob tests/syntax/e_*] {
+ set dst [file join [file dirname $src] r_[string range [file tail ${src}] 2 end]]
+ set expected [string trim [fileutil::cat $dst]]
+
+ test doctools-syntax-error-10.$n "doctools frontend, syntax error, [file tail $src]" {
+ new mydoctools
+ mydoctools configure \
+ -format null \
+ -module .MODULE. \
+ -file .FILE. \
+ -copyright .COPYRIGHT.
+
+ catch {
+ mydoctools format [fileutil::cat $src]
+ } res
+ mydoctools destroy
+ #fileutil::writeFile ${src}.actual $msg
+ set res
+ } $expected
+
+ #fileutil::writeFile ${dst}.expected $expected
+ incr n
+}
+
+# -------------------------------------------------------------------------
+
+namespace forget ::doctools::new
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools/doctools_intro.man b/tcllib/modules/doctools/doctools_intro.man
new file mode 100644
index 0000000..9a2229a
--- /dev/null
+++ b/tcllib/modules/doctools/doctools_intro.man
@@ -0,0 +1,103 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools_intro n 1.0]
+[see_also docidx_intro]
+[see_also doctoc_intro]
+[see_also doctools]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_intro]
+[see_also doctools_lang_syntax]
+[see_also doctools_plugin_apiref]
+[keywords markup]
+[keywords {semantic markup}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {doctools introduction}]
+[category {Documentation tools}]
+[description]
+[para]
+
+[term doctools] (short for [emph {documentation tools}]) stands for
+a set of related, yet different, entities which are working together
+for the easy creation and transformation of documentation. These are
+
+[list_begin enumerated]
+[enum]
+
+A tcl based language for the semantic markup of text. Markup is
+represented by Tcl commands interspersed with the actual text.
+
+[enum]
+
+A package providing the ability to read and transform texts written in
+that markup language. It is important to note that the actual
+transformation of the input text is delegated to plugins.
+
+[enum]
+
+An API describing the interface between the package above and a
+plugin.
+
+[list_end]
+
+[para]
+
+Which of the more detailed documents are relevant to the reader of
+this introduction depends on their role in the documentation process.
+
+[para]
+
+[list_begin enumerated]
+[enum]
+A [term writer] of documentation has to understand the markup language
+itself. A beginner to doctools should read the more informally written
+[term {doctools language introduction}] first. Having digested this
+the formal [term {doctools language syntax}] specification should
+become understandable. A writer experienced with doctools may only
+need the [term {doctools language command reference}] from time to
+time to refresh her memory.
+
+[para]
+
+While a document is written the [syscmd dtplite] application can be
+used to validate it, and after completion it also performs the
+conversion into the chosen system of visual markup, be it *roff, HTML,
+plain text, wiki, etc.
+
+[enum]
+A [term processor] of documentation written in the [term doctools]
+markup language has to know which tools are available for use.
+
+[para]
+
+The main tool is the aforementioned [syscmd dtplite] application
+provided by Tcllib. A more powerful one (in terms of options and
+ability to configure it) is the [syscmd dtp] application, provided by
+Tclapps.
+
+At the bottom level, common to both applications, however sits the
+package [package doctools], providing the basic facilities to read and
+process files containing text in the doctools format.
+
+[enum]
+
+At last, but not least, [term {plugin writers}] have to understand the
+interaction between the [package doctools] package and its plugins, as
+described in the [term {doctools plugin API reference}].
+
+[list_end]
+
+[section {RELATED FORMATS}]
+
+doctools does not stand alone, it has two companion formats. These are
+called [term docidx] and [term doctoc], and they are for the markup of
+[term {keyword indices}], and [term {tables of contents}],
+respectively.
+
+They are described in their own sets of documents, starting at the
+[term {docidx introduction}] and the [term {doctoc introduction}],
+respectively.
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/doctools_lang_cmdref.man b/tcllib/modules/doctools/doctools_lang_cmdref.man
new file mode 100644
index 0000000..7552fdf
--- /dev/null
+++ b/tcllib/modules/doctools/doctools_lang_cmdref.man
@@ -0,0 +1,470 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools_lang_cmdref n 1.0]
+[see_also doctools_intro]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_intro]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords markup]
+[keywords {semantic markup}]
+[copyright {2007-2010 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {doctools language command reference}]
+[category {Documentation tools}]
+[description]
+[para]
+
+This document specifies both names and syntax of all the commands
+which together are the doctools markup language, version 1.
+
+As this document is intended to be a reference the commands are listed
+in alphabetical order, and the descriptions are relatively short.
+
+A beginner should read the much more informally written
+[term {doctools language introduction}] first.
+
+[section Commands]
+[list_begin definitions]
+
+[call [cmd arg] [arg text]]
+
+Text markup. The argument text is marked up as the [term argument] of
+a command. Main uses are the highlighting of command arguments in
+free-form text, and for the argument parameters of the markup commands
+[cmd call] and [cmd usage].
+
+[call [cmd arg_def] [arg type] [arg name] [opt [arg mode]]]
+
+Text structure. List element. Argument list. Automatically closes the
+previous list element. Specifies the data-[arg type] of the described
+argument of a command, its [arg name] and its i/o-[arg mode]. The
+latter is optional.
+
+[call [cmd bullet]]
+
+[emph Deprecated]. Text structure. List element. Itemized list. See
+[cmd item] for the canonical command to open a list item in an
+itemized list.
+
+[call [cmd call] [arg args]]
+
+Text structure. List element. Definition list. Automatically closes
+the previous list element. Defines the term as a command and its
+arguments.
+
+The first argument is the name of the command described by the
+following free-form text, and all arguments coming after that are
+descriptions of the command's arguments.
+
+It is expected that the arguments are marked up with [cmd arg],
+[cmd method], [cmd option] etc., as is appropriate, and that the
+command itself is marked up with [cmd cmd].
+
+It is expected that the formatted term is not only printed in place,
+but also in the table of contents of the document, or synopsis,
+depending on the output format.
+
+[call [cmd category] [arg text]]
+
+Document information. Anywhere. This command registers its plain text
+arguments as the category this document belongs to. If this command is
+used multiple times the last value specified is used.
+
+[call [cmd class] [arg text]]
+
+Text markup. The argument is marked up as the name of a
+[term class]. The text may have other markup already applied to
+it. Main use is the highlighting of class names in free-form text.
+
+[call [cmd cmd] [arg text]]
+
+Text markup. The argument text is marked up as the name of a
+[term {Tcl command}]. The text may have other markup already applied
+to it. Main uses are the highlighting of commands in free-form text,
+and for the command parameters of the markup commands [cmd call] and
+[cmd usage].
+
+[call [cmd cmd_def] [arg command]]
+
+Text structure. List element. Command list. Automatically closes the
+previous list element. The argument specifies the name of the
+[term {Tcl command}] to be described by the list element. Expected to
+be marked up in the output as if it had been formatted with [cmd cmd].
+
+[call [cmd comment] [arg plaintext]]
+
+Text markup. The argument text is marked up as a comment standing
+outside of the actual text of the document. Main use is in free-form
+text.
+
+[call [cmd const] [arg text]]
+
+Text markup. The argument is marked up as a [term constant] value. The
+text may have other markup already applied to it. Main use is the
+highlighting of constants in free-form text.
+
+[call [cmd copyright] [arg text]]
+
+Document information. Anywhere. The command registers the plain text
+argument as a copyright assignment for the manpage. When invoked more
+than once the assignments are accumulated.
+
+[call [cmd def] [arg text]]
+
+Text structure. List element. Definition list. Automatically closes
+the previous list element. The argument text is the term defined by
+the new list element. Text markup can be applied to it.
+
+[call [cmd description]]
+
+Document structure. This command separates the header from the
+document body. Implicitly starts a section named "DESCRIPTION" (See
+command [cmd section]).
+
+[call [cmd enum]]
+
+Text structure. List element. Enumerated list. Automatically closes
+the previous list element.
+
+[call [cmd emph] [arg text]]
+
+Text markup. The argument text is marked up as emphasized. Main use is
+for general highlighting of pieces of free-form text without attaching
+special meaning to the pieces.
+
+[call [cmd example] [arg text]]
+
+Text structure, Text markup. This command marks its argument up as an
+[term example]. Main use is the simple embedding of examples in
+free-form text. It should be used if the example does [emph not] need
+special markup of its own. Otherwise use a sequence of
+[cmd example_begin] ... [cmd example_end].
+
+[call [cmd example_begin]]
+
+Text structure. This commands starts an example. All text until the
+next [cmd example_end] belongs to the example. Line breaks, spaces,
+and tabs have to be preserved literally. Examples cannot be nested.
+
+[call [cmd example_end]]
+
+Text structure. This command closes the example started by the last
+[cmd example_begin].
+
+[call [cmd file] [arg text]]
+
+Text markup. The argument is marked up as a [term file] or
+[term directory], i.e. in general a [term path]. The text may have
+other markup already applied to it. Main use is the highlighting of
+paths in free-form text.
+
+[call [cmd fun] [arg text]]
+
+Text markup. The argument is marked up as the name of a
+[term function]. The text may have other markup already applied to
+it. Main use is the highlighting of function names in free-form text.
+
+[call [cmd image] [arg name] [opt [arg label]]]
+
+Text markup. The argument is the symbolic name of an [term image]
+and replaced with the image itself, if a suitable variant is found
+by the backend. The second argument, should it be present, will be
+interpreted the human-readable description of the image, and put
+into the output in a suitable position, if such is supported by the
+format. The HTML format, for example, can place it into the [term alt]
+attribute of image references.
+
+[call [cmd include] [arg filename]]
+
+Templating. The contents of the named file are interpreted as text
+written in the doctools markup and processed in the place of the
+include command. The markup in the file has to be self-contained. It
+is not possible for a markup command to cross the file boundaries.
+
+[call [cmd item]]
+
+Text structure. List element. Itemized list. Automatically closes the
+previous list element.
+
+[call [cmd keywords] [arg args]]
+
+Document information. Anywhere. This command registers all its plain text
+arguments as keywords applying to this document. Each argument is a single
+keyword. If this command is used multiple times all the arguments accumulate.
+
+[call [cmd lb]]
+
+Text. The command is replaced with a left bracket. Use in free-form text.
+Required to avoid interpretation of a left bracket as the start of a markup
+command.
+
+[call [cmd list_begin] [arg what]]
+
+Text structure. This command starts a list. The exact nature of the
+list is determined by the argument [arg what] of the command. This
+further determines which commands are have to be used to start the
+list elements. Lists can be nested, i.e. it is allowed to start a new
+list within a list element.
+
+[para]
+The allowed types (and their associated item commands) are:
+
+[list_begin definitions]
+[def [const arguments]] [cmd arg_def].
+[def [const commands]] [cmd cmd_def].
+[def [const definitions]] [cmd def] and [cmd call].
+[def [const enumerated]] [cmd enum]
+[def [const itemized]] [cmd item]
+[def [const options]] [cmd opt_def]
+[def [const tkoptions]] [cmd tkoption_def]
+[list_end]
+[para]
+
+Additionally the following names are recognized as shortcuts for some
+of the regular types:
+
+[list_begin definitions]
+[def [const args]] Short for [const arguments].
+[def [const cmds]] Short for [const commands].
+[def [const enum]] Short for [const enumerated].
+[def [const item]] Short for [const itemized].
+[def [const opts]] Short for [const options].
+[list_end]
+[para]
+
+At last the following names are still recognized for backward
+compatibility, but are otherwise considered to be [emph deprecated].
+
+[list_begin definitions]
+[def [const arg]] [emph Deprecated]. See [const arguments].
+[def [const bullet]] [emph Deprecated]. See [const itemized].
+[def [const cmd]] [emph Deprecated]. See [const commands].
+[def [const opt]] [emph Deprecated]. See [const options].
+[def [const tkoption]] [emph Deprecated]. See [const tkoptions].
+[list_end]
+
+[para]
+
+[call [cmd list_end]]
+
+Text structure. This command closes the list opened by the last
+[cmd list_begin] command coming before it.
+
+[call [cmd lst_item] [arg text]]
+
+[emph Deprecated]. Text structure. List element. Definition list. See
+[cmd def] for the canonical command to open a general list item in a
+definition list.
+
+[call [cmd manpage_begin] [arg command] [arg section] [arg version]]
+[see_also doctools_intro]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_intro]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords markup]
+[keywords {semantic markup}]
+
+Document structure. The command to start a manpage. The arguments are
+the name of the [arg command] described by the manpage, the
+[arg section] of the manpages this manpage resides in, and the
+[arg version] of the module containing the command. All arguments have
+to be plain text, without markup.
+[call [cmd manpage_end]]
+
+Document structure. Command to end a manpage/document. Anything in the document
+coming after this command is in error.
+
+[call [cmd method] [arg text]]
+
+Text markup. The argument text is marked up as the name of an
+[term object] [term method], i.e. subcommand of a Tcl command. The
+text may have other markup already applied to it. Main uses are the
+highlighting of method names in free-form text, and for the command
+parameters of the markup commands [cmd call] and [cmd usage].
+
+[call [cmd moddesc] [arg text]]
+
+Document information. Header. Registers the plain text argument as a short
+description of the module the manpage resides in.
+
+[call [cmd namespace] [arg text]]
+
+Text markup. The argument text is marked up as a namespace name. The
+text may have other markup already applied to it. Main use is the
+highlighting of namespace names in free-form text.
+
+[call [cmd nl]]
+
+[emph Deprecated]. Text structure. See [cmd para] for the canonical
+command to insert paragraph breaks into the text.
+
+[call [cmd opt] [arg text]]
+
+Text markup. The argument text is marked up as [term optional]. The text may
+have other markup already applied to it. Main use is the highlighting of
+optional arguments, see the command arg [cmd arg].
+
+[call [cmd opt_def] [arg name] [opt [arg arg]]]
+
+Text structure. List element. Option list. Automatically closes the
+previous list element. Specifies [arg name] and arguments of the
+[term option] described by the list element. It is expected that the
+name is marked up using [cmd option].
+
+[call [cmd option] [arg text]]
+
+Text markup. The argument is marked up as [term option]. The text may
+have other markup already applied to it. Main use is the highlighting
+of options, also known as command-switches, in either free-form text,
+or the arguments of the [cmd call] and [cmd usage] commands.
+
+[call [cmd package] [arg text]]
+
+Text markup. The argument is marked up as the name of a
+[term package]. The text may have other markup already applied to
+it. Main use is the highlighting of package names in free-form text.
+
+[call [cmd para]]
+
+Text structure. This command breaks free-form text into
+paragraphs. Each command closes the paragraph coming before it and
+starts a new paragraph for the text coming after it. Higher-level
+forms of structure are sections and subsections.
+
+[call [cmd rb]]
+
+Text. The command is replaced with a right bracket. Use in free-form text.
+Required to avoid interpretation of a right bracket as the end of a markup
+command.
+
+[call [cmd require] [arg package] [opt [arg version]]]
+
+Document information. Header. This command registers its argument
+[arg package] as the name of a package or application required by the
+described package or application. A minimum version can be provided as
+well. This argument can be marked up. The usual markup is [cmd opt].
+
+[call [cmd section] [arg name]]
+
+Text structure. This command starts a new named document section. The
+argument has to be plain text. Implicitly closes the last paragraph
+coming before it and also implicitly opens the first paragraph of the
+new section.
+
+[call [cmd sectref] [arg id] [opt [arg text]]]
+
+Text markup. Formats a reference to the section identified by [arg id].
+If no [arg text] is specified the title of the referenced section is
+used in the output, otherwise [arg text] is used.
+
+[call [cmd sectref-external] [arg text]]
+
+Text markup. Like [cmd sectref], except that the section is assumed to
+be in a different document and therefore doesn't need to be identified,
+nor are any checks for existence made. Only the text to format is needed.
+
+[call [cmd see_also] [arg args]]
+
+Document information. Anywhere. The command defines direct cross-references
+to other documents. Each argument is a plain text label identifying the
+referenced document. If this command is used multiple times all the arguments
+accumulate.
+
+[call [cmd strong] [arg text]]
+
+[emph Deprecated]. Text markup. See [cmd emph] for the canonical
+command to emphasize text.
+
+[call [cmd subsection] [arg name]]
+
+Text structure. This command starts a new named subsection of a
+section. The argument has to be plain text. Implicitly closes the last
+paragraph coming before it and also implicitly opens the first
+paragraph of the new subsection.
+
+[call [cmd syscmd] [arg text]]
+
+Text markup. The argument text is marked up as the name of an external
+command. The text may have other markup already applied to it. Main
+use is the highlighting of external commands in free-form text.
+
+[call [cmd term] [arg text]]
+
+Text markup. The argument is marked up as unspecific terminology. The
+text may have other markup already applied to it. Main use is the
+highlighting of important terms and concepts in free-form text.
+
+[call [cmd titledesc] [arg desc]]
+
+Document information. Header. Optional. Registers the plain text
+argument as the title of the manpage. Defaults to the value registered
+by [cmd moddesc].
+
+[call [cmd tkoption_def] [arg name] [arg dbname] [arg dbclass]]
+
+Text structure. List element. Widget option list. Automatically closes
+the previous list element. Specifies the [arg name] of the option as
+used in scripts, the name used by the option database ([arg dbname]),
+and its class ([arg dbclass]), i.e. its type. It is expected that the
+name is marked up using [cmd option].
+
+[call [cmd type] [arg text]]
+
+Text markup. The argument is marked up as the name of a
+[term {data type}]. The text may have other markup already applied to
+it. Main use is the highlighting of data types in free-form text.
+
+[call [cmd uri] [arg text] [opt [arg text]]]
+
+Text markup. The argument is marked up as an [term uri] (i.e. a
+[term {uniform resource identifier}]. The text may have other markup
+already applied to it. Main use is the highlighting of uris in
+free-form text. The second argument, should it be present, will be
+interpreted the human-readable description of the uri. In other words,
+as its label. Without an explicit label the uri will be its own label.
+
+[call [cmd usage] [arg args]]
+
+Text markup. See [cmd call] for the full description, this command is
+syntactically identical, as it is in its expectations for the markup
+of its arguments.
+
+In contrast to [cmd call] it is however not allowed to generate output
+where this command occurs in the text. The command is [term silent].
+The formatted text may only appear in a different section of the
+output, for example a table of contents, or synopsis, depending on the
+output format.
+
+[call [cmd var] [arg text]]
+
+Text markup. The argument is marked up as the name of a
+[term variable]. The text may have other markup already applied to
+it. Main use is the highlighting of variables in free-form text.
+
+[call [cmd vset] [arg varname] [arg value] ]
+
+Templating. In this form the command sets the named document variable
+to the specified [arg value]. It does not generate output. I.e. the
+command is replaced by the empty string.
+
+[call [cmd vset] [arg varname]]
+
+Templating. In this form the command is replaced by the value of the
+named document variable
+
+[call [cmd widget] [arg text]]
+
+Text markup. The argument is marked up as the name of a
+[term widget]. The text may have other markup already applied to
+it. Main use is the highlighting of widget names in free-form text.
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/doctools_lang_faq.man b/tcllib/modules/doctools/doctools_lang_faq.man
new file mode 100644
index 0000000..f30a9dd
--- /dev/null
+++ b/tcllib/modules/doctools/doctools_lang_faq.man
@@ -0,0 +1,28 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools_lang_faq n 1.0]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_intro]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords {doctools syntax}]
+[keywords examples]
+[keywords faq]
+[keywords markup]
+[keywords {semantic markup}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {doctools language faq}]
+[category {Documentation tools}]
+[description]
+[vset theformat doctools]
+
+[section OVERVIEW]
+
+[include include/placeholder.inc]
+[include include/examples.inc]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/doctools_lang_intro.man b/tcllib/modules/doctools/doctools_lang_intro.man
new file mode 100644
index 0000000..9aced05
--- /dev/null
+++ b/tcllib/modules/doctools/doctools_lang_intro.man
@@ -0,0 +1,727 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools_lang_intro n 1.0]
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords {doctools syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {doctools language introduction}]
+[category {Documentation tools}]
+[description]
+[para]
+
+This document is an informal introduction to version 1 of the doctools
+markup language based on a multitude of examples. After reading this a
+writer should be ready to understand the two parts of the formal
+specification, i.e. the [term {doctools language syntax}] specification
+and the [term {doctools language command reference}].
+
+[subsection Fundamentals]
+
+In the broadest terms possible the [term {doctools markup language}]
+is LaTeX-like, instead of like SGML and similar languages. A document
+written in this language consists primarily of text, with markup
+commands embedded into it.
+
+[para]
+
+Each markup command is a Tcl command surrounded by a matching pair of
+[const [lb]] and [const [rb]]. Inside of these delimiters the usual
+rules for a Tcl command apply with regard to word quotation, nested
+commands, continuation lines, etc. I.e.
+
+[para]
+[example {
+ ... [list_begin enumerated] ...
+}]
+
+[example {
+ ... [call [cmd foo] \\
+ [arg bar]] ...
+}]
+
+[example {
+ ... [term {complex concept}] ...
+}]
+
+[example {
+ ... [opt "[arg key] [arg value]"] ...
+}]
+
+[subsection {Basic structure}]
+
+The most simple document which can be written in doctools is
+
+[example {
+ [manpage_begin NAME SECTION VERSION]
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords {doctools syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+ [description]
+ [vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
+}]
+
+This also shows us that all doctools documents are split into two
+parts, the [term header] and the [term body]. Everything coming before
+[lb][cmd description][rb] belongs to the header, and everything coming
+after belongs to the body, with the whole document bracketed by the
+two [cmd manpage_*] commands. Before and after these opening and
+closing commands we have only [term whitespace].
+
+[para]
+
+In the remainder of this section we will discuss only the contents of
+the header, the structure of the body will be discussed in the section
+[sectref {Text structure}].
+
+[para]
+
+The header section can be empty, and otherwise may contain only an
+arbitrary sequence of the four so-called [term header] commands, plus
+[term whitespace]. These commands are
+
+[list_begin commands]
+[cmd_def titledesc]
+[cmd_def moddesc]
+[cmd_def require]
+[cmd_def copyright]
+[list_end]
+
+They provide, through their arguments, additional information about
+the document, like its title, the title of the larger group the
+document belongs to (if applicable), the requirements of the
+documented packages (if applicable), and copyright assignments. All of
+them can occur multiple times, including none, and they can be used in
+any order.
+
+However for [cmd titledesc] and [cmd moddesc] only the last occurrence
+is taken. For the other two the specified information is accumulated,
+in the given order. Regular text is not allowed within the header.
+
+[para]
+
+Given the above a less minimal example of a document is
+
+[example_begin]
+[lb]manpage_begin NAME SECTION VERSION[rb]
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords {doctools syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+[lb][cmd {copyright {YEAR AUTHOR}}][rb]
+[lb][cmd {titledesc TITLE}][rb]
+[lb][cmd {moddesc MODULE_TITLE}][rb]
+[lb][cmd {require PACKAGE VERSION}][rb]
+[lb][cmd {require PACKAGE}][rb]
+[lb]description[rb]
+[lb]manpage_end[rb]
+[example_end]
+
+Remember that the whitespace is optional. The document
+
+[example {
+ [manpage_begin NAME SECTION VERSION]
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords {doctools syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+ [copyright {YEAR AUTHOR}][titledesc TITLE][moddesc MODULE_TITLE]
+ [require PACKAGE VERSION][require PACKAGE][description]
+ [vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
+}]
+
+has the same meaning as the example before.
+
+[para]
+
+On the other hand, if [term whitespace] is present it consists not
+only of any sequence of characters containing the space character,
+horizontal and vertical tabs, carriage return, and newline, but it may
+contain comment markup as well, in the form of the [cmd comment]
+command.
+
+[example_begin]
+[lb][cmd {comment { ... }}][rb]
+[lb]manpage_begin NAME SECTION VERSION[rb]
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords {doctools syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+[lb]copyright {YEAR AUTHOR}[rb]
+[lb]titledesc TITLE[rb]
+[lb]moddesc MODULE_TITLE[rb][lb][cmd {comment { ... }}][rb]
+[lb]require PACKAGE VERSION[rb]
+[lb]require PACKAGE[rb]
+[lb]description[rb]
+[lb]manpage_end[rb]
+[lb][cmd {comment { ... }}][rb]
+[example_end]
+
+[subsection {Advanced structure}]
+
+In the simple examples of the last section we fudged a bit regarding
+the markup actually allowed to be used before the [cmd manpage_begin]
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords {doctools syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+command opening the document.
+
+[para]
+
+Instead of only whitespace the two templating commands [cmd include]
+and [cmd vset] are also allowed, to enable the writer to either set
+and/or import configuration settings relevant to the document. I.e. it
+is possible to write
+
+[example_begin]
+[lb][cmd {include FILE}][rb]
+[lb][cmd {vset VAR VALUE}][rb]
+[lb]manpage_begin NAME SECTION VERSION[rb]
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords {doctools syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+[lb]description[rb]
+[lb]manpage_end[rb]
+[example_end]
+
+Even more important, these two commands are allowed anywhere where a
+markup command is allowed, without regard for any other
+structure. I.e. for example in the header as well.
+
+[example_begin]
+[lb]manpage_begin NAME SECTION VERSION[rb]
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords {doctools syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+[lb][cmd {include FILE}][rb]
+[lb][cmd {vset VAR VALUE}][rb]
+[lb]description[rb]
+[lb]manpage_end[rb]
+[example_end]
+
+The only restriction [cmd include] has to obey is that the contents of
+the included file must be valid at the place of the inclusion. I.e. a
+file included before [cmd manpage_begin] may contain only the
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords {doctools syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+templating commands [cmd vset] and [cmd include], a file included in
+the header may contain only header commands, etc.
+
+[subsection {Text structure}]
+
+The body of the document consists mainly of text, possibly split into
+sections, subsections, and paragraphs, with parts marked up to
+highlight various semantic categories of text, and additional
+structure through the use of examples and (nested) lists.
+
+[para]
+
+This section explains the high-level structural commands, with
+everything else deferred to the following sections.
+
+[para]
+
+The simplest way of structuring the body is through the introduction
+of paragraphs. The command for doing so is [cmd para]. Each occurrence
+of this command closes the previous paragraph and automatically opens
+the next. The first paragraph is automatically opened at the beginning
+of the body, by [cmd description]. In the same manner the last
+paragraph automatically ends at [cmd manpage_end].
+
+[example_begin]
+[lb]manpage_begin NAME SECTION VERSION[rb]
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords {doctools syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+[lb]description[rb]
+ ...
+[lb][cmd para][rb]
+ ...
+[lb][cmd para][rb]
+ ...
+[lb]manpage_end[rb]
+[example_end]
+
+Empty paragraphs are ignored.
+
+[para]
+
+A structure coarser than paragraphs are sections, which allow the
+writer to split a document into larger, and labeled, pieces. The
+command for doing so is [cmd section]. Each occurrence of this command
+closes the previous section and automatically opens the next,
+including its first paragraph. The first section is automatically
+opened at the beginning of the body, by [cmd description] (This
+section is labeled "DESCRIPTION"). In the same manner the last section
+automatically ends at [cmd manpage_end].
+
+[para]
+
+Empty sections are [emph not] ignored. We are free to (not) use
+paragraphs within sections.
+
+[example_begin]
+[lb]manpage_begin NAME SECTION VERSION[rb]
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords {doctools syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+[lb]description[rb]
+ ...
+[lb][cmd {section {Section A}}][rb]
+ ...
+[lb]para[rb]
+ ...
+[lb][cmd {section {Section B}}][rb]
+ ...
+[lb]manpage_end[rb]
+[example_end]
+
+Between sections and paragraphs we have subsections, to split sections.
+
+The command for doing so is [cmd subsection]. Each occurrence of this
+command closes the previous subsection and automatically opens the
+next, including its first paragraph. A subsection is automatically
+opened at the beginning of the body, by [cmd description], and at the
+beginning of each section. In the same manner the last subsection
+automatically ends at [cmd manpage_end].
+
+[para]
+
+Empty subsections are [emph not] ignored. We are free to (not) use
+paragraphs within subsections.
+
+[example_begin]
+[lb]manpage_begin NAME SECTION VERSION[rb]
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords {doctools syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+[lb]description[rb]
+ ...
+[lb]section {Section A}[rb]
+ ...
+[lb][cmd {subsection {Sub 1}}][rb]
+ ...
+[lb]para[rb]
+ ...
+[lb][cmd {subsection {Sub 2}}][rb]
+ ...
+[lb]section {Section B}[rb]
+ ...
+[lb]manpage_end[rb]
+[example_end]
+
+[subsection {Text markup}]
+
+Having handled the overall structure a writer can impose on the
+document we now take a closer at the text in a paragraph.
+
+[para]
+
+While most often this is just the unadorned content of the document we
+do have situations where we wish to highlight parts of it as some type
+of thing or other, like command arguments, command names, concepts,
+uris, etc.
+
+[para]
+
+For this we have a series of markup commands which take the text to
+highlight as their single argument. It should be noted that while
+their predominant use is the highlighting of parts of a paragraph they
+can also be used to mark up the arguments of list item commands, and
+of other markup commands.
+
+[para]
+
+The commands available to us are
+
+[list_begin commands]
+[cmd_def arg] Its argument is a the name of a command argument.
+[cmd_def class] Its argument is a class name.
+[cmd_def cmd] Its argument is a command name (Tcl command).
+[cmd_def const] Its argument is a constant.
+[cmd_def emph] General, non-semantic emphasis.
+[cmd_def file] Its argument is a filename / path.
+[cmd_def fun] Its argument is a function name.
+[cmd_def method] Its argument is a method name
+[cmd_def namespace] Its argument is namespace name.
+[cmd_def opt] Its argument is some optional syntax element.
+[cmd_def option] Its argument is a command line switch / widget option.
+[cmd_def package] Its argument is a package name.
+[cmd_def sectref] Its argument is the title of a section or subsection,
+ i.e. a section reference.
+[cmd_def syscmd] Its argument is a command name (external, system command).
+[cmd_def term] Its argument is a concept, or general terminology.
+[cmd_def type] Its argument is a type name.
+[cmd_def uri] Its argument is a uniform resource identifier, i.e an
+ external reference. A second argument can be used
+ to specify an explicit label for the reference in
+ question.
+[cmd_def usage] The arguments describe the syntax of a Tcl command.
+[cmd_def var] Its argument is a variable.
+[cmd_def widget] Its argument is a widget name.
+[list_end]
+
+The example demonstrating the use of text markup is an excerpt from
+the [term {doctools language command reference}], with some
+highlighting added.
+
+It shows their use within a block of text, as the arguments of a list
+item command ([cmd call]), and our ability to nest them.
+
+[example_begin]
+ ...
+ [lb]call [lb][cmd {cmd arg_def}][rb] [lb][cmd {arg type}][rb] [lb][cmd {arg name}][rb]] [lb][cmd opt] [lb][cmd {arg mode}][rb][rb][rb]
+
+ Text structure. List element. Argument list. Automatically closes the
+ previous list element. Specifies the data-[lb][cmd {arg type}][rb] of the described
+ argument of a command, its [lb][cmd {arg name}][rb] and its i/o-[lb][cmd {arg mode}][rb]. The
+ latter is optional.
+ ...
+[example_end]
+
+[subsection Escapes]
+
+Beyond the 20 commands for simple markup shown in the previous section
+we have two more available which are technically simple markup.
+
+However their function is not the marking up of phrases as specific
+types of things, but the insertion of characters, namely [const [lb]]
+and [const [rb]].
+
+These commands, [cmd lb] and [cmd rb] respectively, are required
+because our use of [lb] and [rb] to bracket markup commands makes it
+impossible to directly use [lb] and [rb] within the text.
+
+[para]
+
+Our example of their use are the sources of the last sentence in the
+previous paragraph, with some highlighting added.
+
+[example_begin]
+ ...
+ These commands, [lb]cmd lb[rb] and [lb]cmd lb[rb] respectively, are required
+ because our use of [lb][cmd lb][rb] and [lb][cmd rb][rb] to bracket markup commands makes it
+ impossible to directly use [lb][cmd lb][rb] and [lb][cmd rb][rb] within the text.
+ ...
+[example_end]
+
+[subsection Cross-references]
+
+The last two commands we have to discuss are for the declaration of
+cross-references between documents, explicit and implicit. They are
+[cmd keywords] and [cmd see_also]. Both take an arbitrary number of
+arguments, all of which have to be plain unmarked text. I.e. it is not
+allowed to use markup on them. Both commands can be used multiple
+times in a document. If that is done all arguments of all occurrences
+of one of them are put together into a single set.
+
+[list_begin definitions]
+[def [cmd keywords]]
+
+The arguments of this command are interpreted as keywords describing
+the document. A processor can use this information to create an index
+indirectly linking the containing document to all documents with the
+same keywords.
+
+[def [cmd see_also]]
+
+The arguments of this command are interpreted as references to other
+documents. A processor can format them as direct links to these
+documents.
+
+[list_end]
+
+[para]
+
+All the cross-reference commands can occur anywhere in the document
+between [cmd manpage_begin] and [cmd manpage_end]. As such the writer
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_syntax]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords {doctools syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+can choose whether she wants to have them at the beginning of the
+body, or at its end, maybe near the place a keyword is actually
+defined by the main content, or considers them as meta data which
+should be in the header, etc.
+
+[para]
+
+Our example shows the sources for the cross-references of this
+document, with some highlighting added. Incidentally they are found
+at the end of the body.
+
+[example_begin]
+ ...
+ [lb][cmd {see_also doctools_intro}][rb]
+ [lb][cmd {see_also doctools_lang_syntax}][rb]
+ [lb][cmd {see_also doctools_lang_cmdref}][rb]
+ [lb][cmd {keywords markup {semantic markup}}][rb]
+ [lb][cmd {keywords {doctools markup} {doctools language}}][rb]
+ [lb][cmd {keywords {doctools syntax} {doctools commands}}][rb]
+ [lb]manpage_end[rb]
+[example_end]
+
+[subsection Examples]
+
+Where ever we can write plain text we can write examples too. For
+simple examples we have the command [cmd example] which takes a single
+argument, the text of the argument. The example text must not contain
+markup. If we wish to have markup within an example we have to use the
+2-command combination [cmd example_begin] / [cmd example_end] instead.
+
+[para]
+
+The first opens an example block, the other closes it, and in between
+we can write plain text and use all the regular text markup commands.
+Note that text structure commands are not allowed. This also means
+that it is not possible to embed examples and lists within an example.
+On the other hand, we [emph can] use templating commands within
+example blocks to read their contents from a file (Remember section
+[sectref {Advanced structure}]).
+
+[para]
+
+The source for the very first example in this document (see section
+[sectref Fundamentals]), with some highlighting added, is
+
+[example_begin]
+ [lb][cmd example] {
+ ... [lb]list_begin enumerated[rb] ...
+ }[rb]
+[example_end]
+
+Using [cmd example_begin] / [cmd example_end] this would look like
+
+[example_begin]
+ [lb][cmd example_begin][rb]
+ ... [lb]list_begin enumerated[rb] ...
+ [lb][cmd example_end][rb]
+[example_end]
+
+[subsection Lists]
+
+Where ever we can write plain text we can write lists too. The main
+commands are [cmd list_begin] to start a list, and [cmd list_end] to
+close one. The opening command takes an argument specifying the type
+of list started it, and this in turn determines which of the eight
+existing list item commands are allowed within the list to start list
+items.
+
+[para]
+
+After the opening command only whitespace is allowed, until the first
+list item command opens the first item of the list. Each item is a
+regular series of paragraphs and is closed by either the next list
+item command, or the end of the list. If closed by a list item command
+this command automatically opens the next list item. A consequence of
+a list item being a series of paragraphs is that all regular text
+markup can be used within a list item, including examples and other
+lists.
+
+[para]
+
+The list types recognized by [cmd list_begin] and their associated
+list item commands are:
+
+[list_begin definitions]
+[def [const arguments]]
+
+([cmd arg_def]) This opens an [term {argument (declaration) list}]. It
+is a specialized form of a term definition list where the term is an
+argument name, with its type and i/o-mode.
+
+[def [const commands]]
+
+([cmd cmd_def]) This opens a [term {command (declaration) list}]. It
+is a specialized form of a term definition list where the term is a
+command name.
+
+[def [const definitions]]
+
+([cmd def] and [cmd call]) This opens a general
+[term {term definition list}]. The terms defined by the list items are
+specified through the argument(s) of the list item commands, either
+general terms, possibly with markup ([cmd def]), or Tcl commands with
+their syntax ([cmd call]).
+
+[def [const enumerated]]
+
+([cmd enum]) This opens a general [term {enumerated list}].
+
+[def [const itemized]]
+
+([cmd item])
+This opens a general [term {itemized list}].
+
+[def [const options]]
+
+([cmd opt_def]) This opens an [term {option (declaration) list}]. It
+is a specialized form of a term definition list where the term is an
+option name, possibly with the option's arguments.
+
+[def [const tkoptions]]
+
+([cmd tkoption_def]) This opens a
+[term {widget option (declaration) list}]. It is a specialized form of
+a term definition list where the term is the name of a configuration
+option for a widget, with its name and class in the option database.
+
+[list_end]
+
+Our example is the source of the definition list in the previous
+paragraph, with most of the content in the middle removed.
+
+[example_begin]
+ ...
+ [lb][cmd list_begin] definitions[rb]
+ [lb][cmd def] [lb]const arg[rb][rb]
+
+ ([lb]cmd arg_def[rb]) This opens an argument (declaration) list. It is a
+ specialized form of a definition list where the term is an argument
+ name, with its type and i/o-mode.
+
+ [lb][cmd def] [lb]const itemized[rb][rb]
+
+ ([lb]cmd item[rb])
+ This opens a general itemized list.
+
+ ...
+ [lb][cmd def] [lb]const tkoption[rb][rb]
+
+ ([lb]cmd tkoption_def[rb]) This opens a widget option (declaration) list. It
+ is a specialized form of a definition list where the term is the name
+ of a configuration option for a widget, with its name and class in the
+ option database.
+
+ [lb][cmd list_end][rb]
+ ...
+[example_end]
+
+Note that a list cannot begin in one (sub)section and end in
+another. Differently said, (sub)section breaks are not allowed within
+lists and list items. An example of this [emph illegal] construct is
+
+[example_begin]
+ ...
+ [lb]list_begin itemized[rb]
+ [lb]item[rb]
+ ...
+ [lb][cmd {section {ILLEGAL WITHIN THE LIST}}][rb]
+ ...
+ [lb]list_end[rb]
+ ...
+[example_end]
+
+[section {FURTHER READING}]
+
+Now that this document has been digested the reader, assumed to be a
+[term writer] of documentation should be fortified enough to be able
+to understand the formal [term {doctools language syntax}]
+specification as well. From here on out the
+[term {doctools language command reference}] will also serve as the
+detailed specification and cheat sheet for all available commands and
+their syntax.
+
+[para]
+
+To be able to validate a document while writing it, it is also
+recommended to familiarize oneself with one of the applications for
+the processing and conversion of doctools documents, i.e. either
+Tcllib's easy and simple [syscmd dtplite], or Tclapps'
+ultra-configurable [syscmd dtp].
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/doctools_lang_syntax.man b/tcllib/modules/doctools/doctools_lang_syntax.man
new file mode 100644
index 0000000..7f69405
--- /dev/null
+++ b/tcllib/modules/doctools/doctools_lang_syntax.man
@@ -0,0 +1,142 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools_lang_syntax n 1.0]
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_intro]
+[keywords {doctools commands}]
+[keywords {doctools language}]
+[keywords {doctools markup}]
+[keywords {doctools syntax}]
+[keywords markup]
+[keywords {semantic markup}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {doctools language syntax}]
+[category {Documentation tools}]
+[description]
+[para]
+
+This document contains the formal specification of the syntax of the
+doctools markup language, version 1 in Backus-Naur-Form. This document
+is intended to be a reference, complementing the
+[term {doctools language command reference}].
+
+A beginner should read the much more informally written
+[term {doctools language introduction}] first before trying to
+understand either this document or the command reference.
+
+[section Fundamentals]
+
+In the broadest terms possible the [term {doctools markup language}]
+is LaTeX-like, instead of like SGML and similar languages. A document
+written in this language consists primarily of text, with markup
+commands embedded into it.
+
+[para]
+
+Each markup command is a just Tcl command surrounded by a matching
+pair of [const [lb]] and [const [rb]]. Which commands are available,
+and their arguments, i.e. syntax is specified in the
+[term {doctools language command reference}].
+
+[para]
+
+In this document we specify first the lexeme, and then the syntax,
+i.e. how we can mix text and markup commands with each other.
+
+[section {Lexical definitions}]
+
+In the syntax rules listed in the next section
+
+[list_begin enumerated]
+[enum]
+<TEXT> stands for all text except markup commands.
+
+[enum]
+Any XXX stands for the markup command [lb]xxx[rb] including its
+arguments. Each markup command is a Tcl command surrounded by a
+matching pair of [const [lb]] and [const [rb]]. Inside of these
+delimiters the usual rules for a Tcl command apply with regard to word
+quotation, nested commands, continuation lines, etc.
+
+[enum]
+<WHITE> stands for all text consisting only of spaces, newlines,
+tabulators and the [cmd comment] markup command.
+[list_end]
+
+[section Syntax]
+
+The rules listed here specify only the syntax of doctools
+documents. The lexical level of the language was covered in the
+previous section.
+
+[para]
+
+Regarding the syntax of the (E)BNF itself
+
+[list_begin enumerated]
+[enum]
+The construct { X } stands for zero or more occurrences of X.
+[enum]
+The construct [lb] X [rb] stands for zero or one occurrence of X.
+[enum]
+The construct LIST_BEGIN<X> stands for the markup command
+[cmd list_begin] with [const X] as its type argument.
+[list_end]
+
+The syntax:
+
+[example {
+manpage = defs
+ MANPAGE_BEGIN
+ header
+ DESCRIPTION
+ body
+ MANPAGE_END
+ { <WHITE> }
+
+defs = { INCLUDE | VSET | <WHITE> }
+
+header = { TITLEDESC | MODDESC | COPYRIGHT | REQUIRE | defs | xref }
+
+xref = KEYWORDS | SEE_ALSO | CATEGORY
+
+body = paras { SECTION sbody }
+sbody = paras { SUBSECTION ssbody }
+ssbody = paras
+
+paras = tblock { (PARA | NL) tblock }
+
+tblock = { <TEXT> | defs | markup | xref | an_example | a_list }
+
+markup = ARG | CLASS | CMD | CONST | EMPH | FILE
+ | FUN | LB | METHOD | NAMESPACE | OPT | OPTION
+ | PACKAGE | RB | SECTREF | STRONG | SYSCMD | TERM
+ | TYPE | URI | USAGE | VAR | WIDGET
+
+example = EXAMPLE
+ | EXAMPLE_BEGIN extext EXAMPLE_END
+
+extext = { <TEXT> | defs | markup }
+
+a_list = LIST_BEGIN<arguments> argd_list LIST_END
+ | LIST_BEGIN<commands> cmdd_list LIST_END
+ | LIST_BEGIN<definitions> def_list LIST_END
+ | LIST_BEGIN<enumerated> enum_list LIST_END
+ | LIST_BEGIN<itemized> item_list LIST_END
+ | LIST_BEGIN<options> optd_list LIST_END
+ | LIST_BEGIN<tkoptions> tkoptd_list LIST_END
+
+argd_list = [ <WHITE> ] { ARG_DEF paras }
+cmdd_list = [ <WHITE> ] { CMD_DEF paras }
+def_list = [ <WHITE> ] { (DEF|CALL) paras }
+enum_list = [ <WHITE> ] { ENUM paras }
+item_list = [ <WHITE> ] { ITEM paras }
+optd_list = [ <WHITE> ] { OPT_DEF paras }
+tkoptd_list = [ <WHITE> ] { TKOPTION_DEF paras }
+}]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/doctools_plugin_apiref.man b/tcllib/modules/doctools/doctools_plugin_apiref.man
new file mode 100644
index 0000000..c177bcd
--- /dev/null
+++ b/tcllib/modules/doctools/doctools_plugin_apiref.man
@@ -0,0 +1,478 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools_plugin_apiref n 1.1]
+[see_also doctools]
+[see_also doctools_intro]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_intro]
+[see_also doctools_lang_syntax]
+[keywords document]
+[keywords formatter]
+[keywords {formatting engine}]
+[keywords manpage]
+[keywords markup]
+[keywords {semantic markup}]
+[copyright {2007-2010 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {doctools plugin API reference}]
+[category {Documentation tools}]
+[description]
+[para]
+
+This document is intended for [term {plugin writers}], i.e. developers
+wishing to write a doctools [term {formatting engine}] for some output
+format X.
+
+[para]
+
+It specifies the interaction between the [package doctools] package
+and its plugins, i.e. the interface any doctools formatting engine has
+to comply with.
+
+[para]
+
+This document deals with version 1 of the interface.
+
+[para]
+
+A reader who is on the other hand more interested in the markup
+language itself should start with the
+
+[term {doctools language introduction}] and proceed from there to the
+formal specifications, i.e. the [term {doctools language syntax}] and
+the [term {doctools language command reference}].
+
+[section OVERVIEW]
+
+The API for a doctools formatting engine consists of two major
+sections.
+
+[para]
+
+On the one side we have a set of commands through which the plugin is
+able to query the frontend. These commands are provided by the
+frontend and linked into the plugin interpreter. Please see section
+[sectref {FRONTEND COMMANDS}] for their detailed specification.
+
+[para]
+
+And on the other side the plugin has to provide its own set of
+commands which will then be called by the frontend in a specific
+sequence while processing input. They, again, fall into two
+categories, management and formatting.
+
+Please see section [sectref {PLUGIN COMMANDS}] and its subsections for
+their detailed specification.
+
+[section {FRONTEND COMMANDS}]
+
+This section specifies the set of commands through which a plugin,
+also known as a doctools formatting engine, is able to query the
+frontend. These commands are provided by the frontend and linked into
+the plugin interpreter.
+
+[para]
+
+I.e. a doctools formatting engine can assume that all of the following
+commands are present when any of its own commands (as specified in
+section [sectref {PLUGIN COMMANDS}]) are executed.
+
+[para]
+
+Beyond that it can also assume that it has full access to its own safe
+interpreter and thus is not able to damage the other parts of the
+processor, nor can it damage the filesystem.
+
+It is however able to either kill or hang the whole process, by
+exiting, or running an infinite loop.
+
+[para]
+
+Coming back to the imported commands, all the commands with prefix
+[emph dt_] provide limited access to specific parts of the frontend,
+whereas the commands with prefix [emph ex_] provide access to the
+state of the [package textutil::expander] object which does the main
+parsing of the input within the frontend. These commands should not be
+except under very special circumstances.
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd dt_copyright]]
+
+Query command. It returns a string containing the copyright
+information the doctools processor was configured with. The relevant
+option is [option -copyright]).
+
+[call [cmd dt_file]]
+
+Query command. It returns the full path of the file containing the
+input currently processed by the engine. This may be an included file.
+
+[call [cmd dt_mainfile]]
+
+Query command. It returns the full path of the toplevel file containing
+the input currently processed by the engine.
+
+[call [cmd dt_fileid]]
+
+Query command. It returns the name of the file containing the input
+currently processed by the engine, without path, nor extension.
+
+[call [cmd dt_fmap] [arg symfname]]
+
+Query command. It returns the actual pathname to use in the output in
+place of the symbolic filename [arg symfname]. It will return the
+unchanged input if no mapping was established for [arg symfname].
+
+[para]
+
+The required mappings are established with the method [method map] of
+a frontend, as explained in section [sectref-external {OBJECT METHODS}]
+of the documentation for the package [package doctools].
+
+[call [cmd dt_format]]
+
+Query command. It returns the name of the format associated with the
+doctools formatting engine.
+
+[call [cmd dt_imgdata] [arg key] [arg extensions]]
+
+Query command. Access to the image map. Looks for an image recorded
+under the [arg key] and having on the specified [arg extension]. If a
+matching image is found its data is returned as the result of the
+command. Otherwise an empty string is returned.
+
+[call [cmd dt_imgdst] [arg key] [arg extensions]]
+
+Query command. Access to the image map. Looks for an image recorded
+under the [arg key] and having on the specified [arg extension]. If a
+matching image is found its destination path in the output is returned
+as the result of the command. Otherwise an empty string is returned.
+
+[call [cmd dt_imgsrc] [arg key] [arg extensions]]
+
+Query command. Access to the image map. Looks for an image recorded
+under the [arg key] and having on the specified [arg extension]. If a
+matching image is found its origin path is returned as the result of
+the command. Otherwise an empty string is returned.
+
+[call [cmd dt_lnesting]]
+
+Query command. It returns the number of lists currently open.
+
+[call [cmd dt_module]]
+
+Query command. It returns the name of the module the input currently
+processed belongs to.
+
+[call [cmd dt_read] [arg file]]
+
+Controlled filesystem access. Returns contents of [arg file] for
+whatever use desired by the plugin.
+
+Only files which are either in the same directory as the file
+containing the engine, or below it, can be loaded. Trying to load a
+file outside of this directory causes an error.
+
+[call [cmd dt_source] [arg file]]
+
+Controlled filesystem access. This command allows the doctools
+formatting engine to load additional Tcl code it may need.
+
+Only files which are either in the same directory as the file
+containing the engine, or below it, can be loaded. Trying to load a
+file outside of this directory causes an error.
+
+[call [cmd dt_user]]
+
+Query command. It returns the name of the current user as known to the
+tcl interpreter the frontend controlling the formatting engine resides
+in.
+
+[call [cmd ex_cappend] [arg text]]
+Appends a string to the output in the current context. This command
+should rarely be used by macros or application code.
+
+[call [cmd ex_cget] [arg varname]]
+Retrieves the value of variable [arg varname], defined in the current
+context.
+
+[call [cmd ex_cis] [arg cname]]
+Determines whether or not the name of the current context is
+[arg cname].
+
+[call [cmd ex_cname]]
+Returns the name of the current context.
+
+[call [cmd ex_cpop] [arg cname]]
+Pops a context from the context stack, returning all accumulated
+output in that context. The context must be named [arg cname], or an
+error results.
+
+[call [cmd ex_cpush] [arg cname]]
+Pushes a context named [arg cname] onto the context stack. The
+context must be popped by [method cpop] before expansion ends or an
+error results.
+
+[call [cmd ex_cset] [arg varname] [arg value]]
+Sets variable [arg varname] to [arg value] in the current context.
+
+[call [cmd ex_lb] [opt [arg newbracket]]]
+Returns the current value of the left macro expansion bracket; this is
+for use as or within a macro, when the bracket needs to be included in
+the output text. If [arg newbracket] is specified, it becomes the new
+bracket, and is returned.
+
+[call [cmd ex_rb] [opt [arg newbracket]]]
+Returns the current value of the right macro expansion bracket; this
+is for use as or within a macro, when the bracket needs to be included
+in the output text. If [arg newbracket] is specified, it becomes the
+new bracket, and is returned.
+
+[list_end]
+
+[section {PLUGIN COMMANDS}]
+
+The plugin has to provide its own set of commands which will then be
+called by the frontend in a specific sequence while processing
+input. They fall into two categories, management and formatting. Their
+expected names, signatures, and responsibilities are specified in the
+following two subsections.
+
+[subsection {Management commands}]
+
+The management commands a plugin has to provide are used by the
+frontend to
+
+[list_begin enumerated]
+[enum] initialize and shutdown the plugin
+[enum] determine the number of passes it has
+ to make over the input
+[enum] initialize and shutdown each pass
+[enum] query and initialize engine parameters
+[list_end]
+[para]
+
+After the plugin has been loaded and the frontend commands are
+established the commands will be called in the following sequence:
+
+[example {
+ fmt_numpasses -> n
+ fmt_listvariables -> vars
+
+ fmt_varset var1 value1
+ fmt_varset var2 value2
+ ...
+ fmt_varset varK valueK
+ fmt_initialize
+ fmt_setup 1
+ ...
+ fmt_setup 2
+ ...
+ ...
+ fmt_setup n
+ ...
+ fmt_postprocess
+ fmt_shutdown
+ ...
+}]
+
+I.e. first the number of passes and the set of available engine
+parameters is established, followed by calls setting the
+parameters. That second part is optional.
+
+[para]
+
+After that the plugin is initialized, the specified number of passes
+executed, the final result run through a global post processing step
+and at last the plugin is shutdown again. This can be followed by more
+conversions, restarting the sequence at [cmd fmt_varset].
+
+[para]
+
+In each of the passes, i.e. after the calls of [cmd fmt_setup] the
+frontend will process the input and call the formatting commands as
+markup is encountered. This means that the sequence of formatting
+commands is determined by the grammar of the doctools markup language,
+as specified in the [term {doctools language syntax}] specification.
+
+[para]
+
+A different way of looking at the sequence is:
+
+[list_begin itemized]
+[item] First some basic parameters are determined.
+
+[item] Then everything starting at the first [cmd fmt_varset] to
+[cmd fmt_shutdown] forms a [term run], the formatting of a
+single input. Each run can be followed by more.
+
+[item] Embedded within each run we have one or more [term passes],
+each starting with [cmd fmt_setup] and going until either the next
+[cmd fmt_setup] or [cmd fmt_postprocess] is reached.
+
+[para]
+
+If more than one pass is required to perform the formatting only the
+output of the last pass is relevant. The output of all the previous,
+preparatory passes is ignored.
+
+[list_end]
+[para]
+
+The commands, their names, signatures, and responsibilities are, in
+detail:
+
+[list_begin definitions]
+
+[call [cmd fmt_initialize]]
+[emph Initialization/Shutdown].
+
+This command is called at the beginning of every conversion run, as
+the first command of that run. Note that a run is not a pass, but may
+consist of multiple passes.
+
+It has to initialize the general state of the plugin, beyond the
+initialization done during the load. No return value is expected, and
+any returned value is ignored.
+
+[call [cmd fmt_listvariables]]
+[emph Initialization/Shutdown] and [emph {Engine parameters}].
+
+Second command is called after the plugin code has been loaded,
+i.e. immediately after [cmd fmt_numpasses].
+
+It has to return a list containing the names of the parameters the
+frontend can set to configure the engine. This list can be empty.
+
+[call [cmd fmt_numpasses]]
+[emph Initialization/Shutdown] and [emph {Pass management}].
+
+First command called after the plugin code has been loaded. No other
+command of the engine will be called before it.
+
+It has to return the number of passes this engine requires to fully
+process the input document. This value has to be an integer number
+greater or equal to one.
+
+[call [cmd fmt_postprocess] [arg text]]
+[emph Initialization/Shutdown].
+
+This command is called immediately after the last pass in a run. Its
+argument is the result of the conversion generated by that pass. It is
+provided to allow the engine to perform any global modifications of
+the generated document. If no post-processing is required for a
+specific format the command has to just return the argument.
+
+[para]
+
+Expected to return a value, the final result of formatting the input.
+
+[call [cmd fmt_setup] [arg n]]
+[emph Initialization/Shutdown] and [emph {Pass management}].
+
+This command is called at the beginning of each pass over the input in
+a run. Its argument is the number of the pass which has begun. Passes
+are counted from [const 1] upward.
+
+The command has to set up the internal state of the plugin for this
+particular pass. No return value is expected, and any returned value
+is ignored.
+
+[call [cmd fmt_shutdown]]
+[emph Initialization/Shutdown].
+
+This command is called at the end of every conversion run. It is the
+last command called in a run. It has to clean up of all the
+run-specific state in the plugin.
+
+After the call the engine has to be in a state which allows the
+initiation of another run without fear that information from the last
+run is leaked into this new run.
+
+No return value is expected, and any returned value is ignored.
+
+[call [cmd fmt_varset] [arg varname] [arg text]]
+[emph {Engine parameters}].
+
+This command is called by the frontend to set an engine parameter to a
+particular value.
+
+The parameter to change is specified by [arg varname], the value to
+set in [arg text].
+
+[para]
+
+The command has to throw an error if an unknown [arg varname] is
+used. Only the names returned by [cmd fmt_listvariables] have to be
+considered as known.
+
+[para]
+
+The values of all engine parameters have to persist between passes and
+runs.
+
+[list_end]
+
+[subsection {Formatting commands}]
+
+The formatting commands have to implement the formatting for the
+output format, for all the markup commands of the doctools markup
+language, except [cmd lb], [cmd rb], [cmd vset], [cmd include], and
+[cmd comment]. These exceptions are processed by the frontend and are
+never seen by the plugin. In return a command for the formatting of
+plain text has to be provided, something which has no markup in the
+input at all.
+
+[para]
+
+This means, that each of the 49 markup commands specified in the
+[term {doctools language command reference}] and outside of the set of
+exceptions listed above has an equivalent formatting command which
+takes the same arguments as the markup command and whose name is the
+name of markup command with the prefix [emph fmt_] added to it.
+
+[para]
+
+All commands are expected to format their input in some way per the
+semantics specified in the command reference and to return whatever
+part of this that they deem necessary as their result, which will be
+added to the output.
+
+[para]
+
+To avoid essentially duplicating the command reference we do not list
+any of the command here and simply refer the reader to the
+[term {doctools language command reference}] for their signature and
+description. The sole exception is the plain text formatter, which has
+no equivalent markup command.
+
+[para]
+
+The calling sequence of formatting commands is not as rigid as for the
+management commands, but determined by the grammar of the doctools
+markup language, as specified in the [term {doctools language syntax}]
+specification.
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd fmt_plain_text] [arg text]]
+[emph {No associated markup command}].
+
+[para] Called by the frontend for any plain text encountered in the
+input. It has to perform any and all special processing required for
+plain text.
+
+[para] The formatted text is expected as the result of the command,
+and added to the output. If no special processing is required it has
+to simply return its argument without change.
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/include/examples.inc b/tcllib/modules/doctools/include/examples.inc
new file mode 100644
index 0000000..467e047
--- /dev/null
+++ b/tcllib/modules/doctools/include/examples.inc
@@ -0,0 +1,30 @@
+
+[section EXAMPLES]
+
+[subsection "Where do I find [vset theformat] examples?"]
+
+We have no direct examples of documents written using [vset theformat]
+markup. However the doctools processor [syscmd dtplite] does generate
+a table of contents when processing a set of documents written in
+doctools markup. The intermediate file for it uses [vset theformat]
+markup and is not deleted when generation completes. Such files can
+therefore serve as examples.
+
+[para]
+
+[syscmd dtplite] is distributed as part of Tcllib, so to get it you
+need one of
+
+[list_begin enumerated]
+
+[enum]
+A snapshot of Tcllib. How to retrieve such a snapshot and the
+tools required for this are described at
+
+[uri {/wiki?name=Development+Snapshots} {Development Snapshots}]
+
+[enum]
+A Tcllib release archive. They are available at the [uri /home home]
+page.
+
+[list_end]
diff --git a/tcllib/modules/doctools/include/placeholder.inc b/tcllib/modules/doctools/include/placeholder.inc
new file mode 100644
index 0000000..1d8a244
--- /dev/null
+++ b/tcllib/modules/doctools/include/placeholder.inc
@@ -0,0 +1,12 @@
+
+[subsection {What is this document?}]
+
+This document is currently mainly a placeholder, to be filled with
+commonly asked questions about the [vset theformat] markup language
+and companions, and their answers.
+
+[para]
+
+Please report any questions (and, if possible, answers) we should
+consider for this document as explained in the section
+[sectref {Bugs, Ideas, Feedback}] below.
diff --git a/tcllib/modules/doctools/mpexpand b/tcllib/modules/doctools/mpexpand
new file mode 100755
index 0000000..faaa80e
--- /dev/null
+++ b/tcllib/modules/doctools/mpexpand
@@ -0,0 +1,153 @@
+#! /bin/sh
+# -*- tcl -*- \
+exec tclsh "$0" ${1+"$@"}
+
+lappend auto_path [file dirname [file dirname [info script]]]
+package require doctools
+
+# ---------------------------------------------------------------------
+# 1. Handle command line options, input and output
+# 2. Initialize a doctools object.
+# 3. Run the input through the object.
+# 4. Write output.
+# ---------------------------------------------------------------------
+
+proc usage {{exitstate 1}} {
+ global argv0
+ puts "Usage: $argv0\
+ ?-h|--help|-help|-??\
+ ?-help-fmt|--help-fmt?\
+ ?-module module?\
+ ?-deprecated?\
+ ?-copyright text?\
+ format in|- ?out|-?"
+ exit $exitstate
+}
+
+# ---------------------------------------------------------------------
+
+proc fmthelp {} {
+ # Tcllib FR #527029: short reference of formatting commands.
+
+ global argv0
+ puts "$argv0 [doctools::help]"
+ exit 0
+}
+
+# ---------------------------------------------------------------------
+# 1. Handle command line options, input and output
+
+proc cmdline {} {
+ global argv0 argv format in out extmodule deprecated copyright
+
+ set copyright ""
+ set extmodule ""
+ set deprecated 0
+
+ while {[string match -* [set opt [lindex $argv 0]]]} {
+ switch -exact -- $opt {
+ -module {
+ set extmodule [lindex $argv 1]
+ set argv [lrange $argv 2 end]
+ continue
+ }
+ -copyright {
+ set copyright [lindex $argv 1]
+ set argv [lrange $argv 2 end]
+ continue
+ }
+ -deprecated {
+ set deprecated 1
+ set argv [lrange $argv 1 end]
+ }
+ -help - -h - --help - -? {
+ # Tcllib FR #527029
+ usage 0
+ }
+ -help-fmt - --help-fmt {
+ # Tcllib FR #527029
+ fmthelp
+ }
+ default {
+ # Unknown option
+ usage
+ }
+ }
+ }
+
+ if {[llength $argv] < 3} {
+ usage
+ }
+ foreach {format in out} $argv break
+
+ if {$format == {} || $in == {}} {
+ usage
+ }
+ if {$out == {}} {set out -}
+ return $format
+}
+
+# ---------------------------------------------------------------------
+# 3. Read input. Also providing the namespace with file information.
+
+proc get_input {} {
+ global in
+ if {[string equal $in -]} {
+ return [read stdin]
+ } else {
+ set if [open $in r]
+ set text [read $if]
+ close $if
+ return $text
+ }
+}
+
+# ---------------------------------------------------------------------
+# 4. Write output.
+
+proc write_out {text} {
+ global out
+ if {[string equal $out -]} {
+ puts -nonewline stdout $text
+ } else {
+ set of [open $out w]
+ puts -nonewline $of $text
+ close $of
+ }
+}
+
+
+# ---------------------------------------------------------------------
+# Get it all together
+
+proc main {} {
+ global format deprecated extmodule in copyright
+
+ #if {[catch {}
+ cmdline
+
+ ::doctools::new dt -format $format -deprecated $deprecated -file $in
+ if {$extmodule != {}} {
+ dt configure -module $extmodule
+ }
+ if {$copyright != {}} {
+ dt configure -copyright $copyright
+ }
+
+ write_out [dt format [get_input]]
+
+ set warnings [dt warnings]
+ if {[llength $warnings] > 0} {
+ puts stderr [join $warnings \n]
+ }
+
+ #{} msg]} {}
+ #puts stderr "Execution error: $msg"
+ #{}
+ return
+}
+
+
+# ---------------------------------------------------------------------
+main
+exit
diff --git a/tcllib/modules/doctools/mpexpand.all b/tcllib/modules/doctools/mpexpand.all
new file mode 100755
index 0000000..3b1878c
--- /dev/null
+++ b/tcllib/modules/doctools/mpexpand.all
@@ -0,0 +1,38 @@
+#! /bin/sh
+# -*- tcl -*- \
+exec tclsh "$0" ${1+"$@"}
+
+set here [file dirname [file join [pwd] [info script]]]
+set verbose 0
+
+set o [lindex $argv 0]
+if {[string equal $o "-verbose"]} {
+ set verbose 1
+ set argv [lrange $argv 1 end]
+} elseif {[string equal $o ""] && [llength $argv] > 1} {
+ puts stderr "Usage: $argv0 ?-verbose? ?module?"
+ exit 1
+}
+
+set module [lindex $argv 0]
+array set fmts {
+ nroff n
+ html html
+ tmml tmml
+ latex tex
+}
+
+foreach fname [glob -nocomplain *.man] {
+ foreach fmt [array names fmts] {
+ set out [file rootname $fname].$fmts($fmt)
+ if {1 || $verbose} {
+ puts " $fname -> $out"
+ }
+ if {$module != {}} {
+ exec [file join $here mpexpand] -module $module $fmt $fname $out
+ } else {
+ exec [file join $here mpexpand] $fmt $fname $out
+ }
+ }
+}
+exit
diff --git a/tcllib/modules/doctools/mpexpand.man b/tcllib/modules/doctools/mpexpand.man
new file mode 100644
index 0000000..954d3ae
--- /dev/null
+++ b/tcllib/modules/doctools/mpexpand.man
@@ -0,0 +1,107 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin mpexpand n 1.0]
+[see_also expander(n)]
+[see_also format(n)]
+[see_also formatter(n)]
+[keywords conversion]
+[keywords HTML]
+[keywords manpage]
+[keywords markup]
+[keywords nroff]
+[keywords TMML]
+[copyright {2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[copyright {2003 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation toolbox}]
+[titledesc {Markup processor}]
+[category {Documentation tools}]
+[description]
+[para]
+
+This manpage describes a processor / converter for manpages in the
+doctools format as specified in [cmd doctools_fmt]. The processor
+is based upon the package [package doctools].
+
+[list_begin definitions]
+[call [cmd mpexpand] [opt "-module [arg module]"] [arg format] [arg infile]|- [arg outfile]|-]
+
+The processor takes three arguments, namely the code describing which
+formatting to generate as the output, the file to read the markup
+from, and the file to write the generated output into. If the
+[arg infile] is "[const -]" the processor will read from
+[const stdin]. If [arg outfile] is "[const -]" the processor will
+write to [const stdout].
+
+[para]
+
+If the option [arg -module] is present its value overrides the internal
+definition of the module name.
+
+[para]
+
+The currently known output formats are
+
+[list_begin definitions]
+
+[def [const nroff]]
+
+The processor generates *roff output, the standard format for unix
+manpages.
+
+[def [const html]]
+
+The processor generates HTML output, for usage in and display by web
+browsers.
+
+[def [const tmml]]
+
+The processor generates TMML output, the Tcl Manpage Markup Language,
+a derivative of XML.
+
+[def [const latex]]
+
+The processor generates LaTeX output.
+
+[def [const wiki]]
+
+The processor generates Wiki markup as understood by [syscmd wikit].
+
+[def [const list]]
+
+The processor extracts the information provided by [cmd manpage_begin].
+[see_also expander(n)]
+[see_also format(n)]
+[see_also formatter(n)]
+[keywords conversion]
+[keywords HTML]
+[keywords manpage]
+[keywords markup]
+[keywords nroff]
+[keywords TMML]
+
+[def [const null]]
+
+The processor does not generate any output.
+
+[list_end]
+
+[call [cmd mpexpand.all] [opt [arg -verbose]] [opt [arg module]]]
+
+This command uses [syscmd mpexpand] to generate all possible output
+formats for all manpages in the current directory. The manpages are
+recognized through the extension [file .man]. If [arg -verbose] is
+specified the command will list its actions before executing them.
+
+[para]
+
+The [arg module] information is passed to [cmd mpexpand].
+
+[list_end]
+
+[section NOTES]
+[para]
+
+Possible future formats are plain text, pdf and postscript.
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools/mpformats/_common.tcl b/tcllib/modules/doctools/mpformats/_common.tcl
new file mode 100644
index 0000000..9f2288a
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/_common.tcl
@@ -0,0 +1,303 @@
+# -*- tcl -*-
+#
+# _common.tcl
+#
+# (c) 2001 Andreas Kupries <andreas_kupries@sourceforge.net>
+# (c) 2002 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+################################################################
+# The code here contains general definitions for API functions and
+# state information. They are used by several formatters to simplify
+# their own code.
+
+global state
+array set state {}
+
+proc fmt_initialize {} {
+ global state
+ unset state
+
+ set state(pass) unknown ; # Not relevant before a pass
+ set state(begun) unknown ; # is active
+ set state(mdesc) {} ; # Text, module desciption
+ #set state(tdesc) {} ; # Text, title of manpage
+ set state(copyright) {} ; # Text, copyright assignment (list)
+ return
+}
+
+proc fmt_shutdown {} {return}
+proc fmt_numpasses {} {return 2}
+proc fmt_postprocess {text} {return $text}
+proc fmt_plain_text {text} {return $text}
+proc fmt_listvariables {} {return {}}
+proc fmt_varset {varname text} {return}
+
+proc fmt_setup {n} {
+ # Called to setup a pass through the input.
+
+ global state
+ set state(pass) $n ; # We are in pass 'n' through the text.
+ set state(begun) 0 ; # No manpage_begin yet
+
+ if {$n == 1} {c_xref_init}
+
+ SetPassProcs $n
+ return
+}
+
+################################################################
+# Functions made available to the formatter to access the common
+# state managed here.
+
+proc c_inpass {} {global state ; return $state(pass)}
+
+proc c_begin {} {global state ; set state(begun) 1 ; return}
+proc c_begun {} {global state ; return $state(begun)}
+
+proc c_get_module {} {global state ; return $state(mdesc)}
+proc c_set_module {text} {global state ; set state(mdesc) $text ; return}
+
+proc c_set_title {text} {global state ; set state(tdesc) $text ; return}
+proc c_get_title {} {
+ global state
+ if {![info exists state(tdesc)]} {
+ return $state(mdesc)
+ }
+ return $state(tdesc)
+}
+
+proc c_copyrightsymbol {} {return "(c)"}
+proc c_set_copyright {text} {global state ; lappend state(copyright) $text ; return}
+proc c_get_copyright {} {
+ global state
+
+ set cc $state(copyright)
+ if {$cc == {}} {set cc [dt_copyright]}
+ if {$cc == {}} {return {}}
+
+ set stmts {}
+ set re {^Copyright +(?:\(c\)|\\\(co|&copy;)? *(.+)$}
+ foreach stmt $cc {
+ if { [string equal -nocase "public domain" [string trim $stmt]] } {
+ lappend stmts "Public domain"
+ } elseif { [regexp -nocase -- $re $stmt -> stmt] } {
+ lappend stmts $stmt
+ } else {
+ lappend stmts "Copyright [c_copyrightsymbol] $stmt"
+ }
+ }
+
+ return [join $stmts \n]
+}
+
+proc c_provenance {} {
+ return "Generated from file '[file tail [dt_ibase]]' by tcllib/doctools with format '[dt_format]'"
+}
+
+################################################################
+# Manage pass-dependent procedure definitions.
+
+global PassProcs
+
+# pass $passNo procName procArgs { body } --
+# Specifies procedure definition for pass $n.
+#
+proc c_pass {pass proc arguments body} {
+ global PassProcs
+ lappend PassProcs($pass) $proc $arguments $body
+}
+proc SetPassProcs {pass} {
+ global PassProcs
+ foreach {proc args body} $PassProcs($pass) {
+ proc $proc $args $body
+ }
+}
+
+
+################################################################
+# Manage a set of buffers to hold information between passes.
+# Each buffer holds a list of lines.
+
+global Buffers
+
+# holdBuffers buffer ? buffer ...? --
+# Declare a list of hold buffers,
+# to collect data in one pass and output it later.
+#
+proc c_holdBuffers {args} {
+ global Buffers
+ foreach arg $args {
+ set Buffers($arg) [list]
+ }
+}
+
+proc c_holdRemove {args} {
+ global Buffers
+ foreach arg $args {
+ catch {unset Buffers($arg)}
+ }
+ return
+}
+
+# hold buffer text --
+# Append text to named buffer
+#
+proc c_hold {buffer entry} {
+ global Buffers
+ lappend Buffers($buffer) $entry
+
+ #puts "$buffer -- $entry"
+ return
+}
+
+proc c_holding {buffer} {
+ global Buffers
+ set l 0
+ catch {set l [llength $Buffers($buffer)]}
+ return $l
+}
+
+# held buffer --
+# Returns current contents of named buffer and empty the buffer.
+#
+proc c_held {buffer} {
+ global Buffers
+ set content [join $Buffers($buffer) "\n"]
+ set Buffers($buffer) [list]
+ return $content
+}
+
+######################################################################
+# Nested counter
+
+global counters cnt
+set counters [list]
+set cnt 0
+
+proc c_cnext {} {global cnt ; incr cnt}
+proc c_cinit {} {
+ global counters cnt
+ set counters [linsert $counters 0 $cnt]
+ set cnt 0
+ return
+}
+proc c_creset {} {
+ global counters cnt
+ set cnt [lindex $counters 0]
+ set counters [lrange $counters 1 end]
+ return
+}
+
+
+######################################################################
+# Utilities.
+#
+
+proc NOP {args} { } ;# do nothing
+proc NYI {{message {}}} {
+ return -code error [append message " Not Yet Implemented"]
+}
+
+######################################################################
+# Cross-reference tracking (for a single file).
+#
+global SectionNames ;# array mapping 'section name' to 'reference id'
+global SectionList ;# List of sections, their ids, and levels, in
+set SectionList {} ;# order of definition.
+
+# sectionId --
+# Format section name as an XML ID.
+#
+proc c_sectionId {name} {
+ # Identical to '__sid' in checker.tcl
+ regsub -all {[ ]+} [string tolower [string trim $name]] _ id
+ regsub -all {"} $id _ id ; # "
+ return $id
+}
+
+# possibleReference text gi --
+# Check if $text is a potential cross-reference;
+# if so, format as a reference;
+# otherwise format as a $gi element.
+#
+proc c_possibleReference {text gi {label {}}} {
+ global SectionNames
+ if {![string length $label]} {set label $text}
+ set id [c_sectionId $text]
+ if {[info exists SectionNames($id)]} {
+ return "[startTag ref refid $id]$label[endTag ref]"
+ } else {
+ return [wrap $label $gi]
+ }
+}
+
+proc c_newSection {name level location {id {}}} {
+ global SectionList SectionNames
+ if {$id == {}} {
+ set id [c_sectionId $name]
+ }
+ set SectionNames($id) .
+ set SectionList [linsert $SectionList $location $name $id $level]
+ return
+}
+
+proc c_clrSections {} {
+ global SectionList SectionNames
+ set SectionList {}
+ catch {unset SectionNames}
+}
+
+######################################################################
+# Conversion specification.
+#
+# Two-pass processing. The first pass collects text for the
+# SYNOPSIS, SEE ALSO, and KEYWORDS sections, and the second pass
+# produces output.
+#
+
+c_holdBuffers synopsis see_also keywords precomments category
+
+################################################################
+# Management of see-also and keyword cross-references
+
+proc c_xref_init {} {
+ global seealso seealso__ ; set seealso [list] ; catch {unset seealso__} ; array set seealso__ {}
+ global keywords keywords__ ; set keywords [list] ; catch {unset keywords__} ; array set keywords__ {}
+ global category ; set category ""
+}
+
+proc c_xref_seealso {} {global seealso ; return $seealso}
+proc c_xref_keywords {} {global keywords ; return $keywords}
+proc c_xref_category {} {global category ; return $category}
+
+c_pass 1 fmt_category {text} {
+ global category
+ set category $text
+ return
+}
+
+c_pass 1 fmt_see_also {args} {
+ global seealso seealso__
+ foreach ref $args {
+ if {[info exists seealso__($ref)]} continue
+ lappend seealso $ref
+ set seealso__($ref) .
+ }
+ return
+}
+
+c_pass 1 fmt_keywords {args} {
+ global keywords keywords__
+ foreach ref $args {
+ if {[info exists keywords__($ref)]} continue
+ lappend keywords $ref
+ set keywords__($ref) .
+ }
+ return
+}
+
+c_pass 2 fmt_category {args} NOP
+c_pass 2 fmt_see_also {args} NOP
+c_pass 2 fmt_keywords {args} NOP
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/_html.tcl b/tcllib/modules/doctools/mpformats/_html.tcl
new file mode 100644
index 0000000..ae3ec98
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/_html.tcl
@@ -0,0 +1,198 @@
+# -*- tcl -*-
+# Copyright (c) 2001-2008 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# Helper rules for the creation of the memchan website from the .exp files.
+# General formatting instructions ...
+
+# htmlEscape text --
+# Replaces HTML markup characters in $text with the
+# appropriate entity references.
+#
+
+global textMap;
+set textMap {
+ & &amp; < &lt; > &gt;
+ \xa0 &nbsp; \xb0 &deg; \xc0 &Agrave; \xd0 &ETH; \xe0 &agrave; \xf0 &eth;
+ \xa1 &iexcl; \xb1 &plusmn; \xc1 &Aacute; \xd1 &Ntilde; \xe1 &aacute; \xf1 &ntilde;
+ \xa2 &cent; \xb2 &sup2; \xc2 &Acirc; \xd2 &Ograve; \xe2 &acirc; \xf2 &ograve;
+ \xa3 &pound; \xb3 &sup3; \xc3 &Atilde; \xd3 &Oacute; \xe3 &atilde; \xf3 &oacute;
+ \xa4 &curren; \xb4 &acute; \xc4 &Auml; \xd4 &Ocirc; \xe4 &auml; \xf4 &ocirc;
+ \xa5 &yen; \xb5 &micro; \xc5 &Aring; \xd5 &Otilde; \xe5 &aring; \xf5 &otilde;
+ \xa6 &brvbar; \xb6 &para; \xc6 &AElig; \xd6 &Ouml; \xe6 &aelig; \xf6 &ouml;
+ \xa7 &sect; \xb7 &middot; \xc7 &Ccedil; \xd7 &times; \xe7 &ccedil; \xf7 &divide;
+ \xa8 &uml; \xb8 &cedil; \xc8 &Egrave; \xd8 &Oslash; \xe8 &egrave; \xf8 &oslash;
+ \xa9 &copy; \xb9 &sup1; \xc9 &Eacute; \xd9 &Ugrave; \xe9 &eacute; \xf9 &ugrave;
+ \xaa &ordf; \xba &ordm; \xca &Ecirc; \xda &Uacute; \xea &ecirc; \xfa &uacute;
+ \xab &laquo; \xbb &raquo; \xcb &Euml; \xdb &Ucirc; \xeb &euml; \xfb &ucirc;
+ \xac &not; \xbc &frac14; \xcc &Igrave; \xdc &Uuml; \xec &igrave; \xfc &uuml;
+ \xad &shy; \xbd &frac12; \xcd &Iacute; \xdd &Yacute; \xed &iacute; \xfd &yacute;
+ \xae &reg; \xbe &frac34; \xce &Icirc; \xde &THORN; \xee &icirc; \xfe &thorn;
+ \xaf &hibar; \xbf &iquest; \xcf &Iuml; \xdf &szlig; \xef &iuml; \xff &yuml;
+ {"} &quot;
+} ; # " make the emacs highlighting code happy.
+
+# Handling of HTML delimiters in content:
+#
+# Plain text is initially passed through unescaped;
+# internally-generated markup is protected by preceding it with \1.
+# The final PostProcess step strips the escape character from
+# real markup and replaces markup characters from content
+# with entity references.
+#
+
+global markupMap
+set markupMap { {&} {\1&} {<} {\1<} {>} {\1>} {"} {\1"} }
+global finalMap
+set finalMap $textMap
+lappend finalMap {\1&} {&} {\1<} {<} {\1>} {>} {\1"} {"}
+
+
+proc htmlEscape {text} {
+ global textMap
+ return [string map $textMap $text]
+}
+
+proc fmt_postprocess {text} {
+ global finalMap
+
+ if 0 {
+ puts_stderr ____________________________________________________________
+ puts_stderr $text
+ puts_stderr ____________________________________________________________
+ }
+
+ # Put protected characters into their final form.
+ set text [string map $finalMap $text]
+ # Remove leading/trailing whitespace from paragraphs.
+ regsub -all "<p>\[\t\n \]*" $text {<p>} text
+ regsub -all "\[\t\n \]*</p>" $text {</p>} text
+ # Remove trailing linebreaks from paragraphs.
+ while {[regsub -all "<br>\[\t\n \]*</p>" $text {</p>} text]} continue
+ # Remove empty paragraphs
+ regsub -all "<p>\[\t\n \]*</p>" $text {} text
+ # Separate paragraphs
+ regsub -all "</p><p>" $text "</p>\n<p>" text
+ # Separate bigger structures
+ foreach outer {div p dl ul ol} {
+ foreach inner {div p dl ul ol} {
+ regsub -all "</${outer}><${inner}" $text "</${outer}>\n<${inner}" text
+ regsub -all "</${outer}></${inner}" $text "</${outer}>\n</${inner}" text
+ }
+ }
+ regsub -all "<li><dl" $text "<li>\n<dl" text
+ regsub -all "<li><ol" $text "<li>\n<ol" text
+ regsub -all "<li><ul" $text "<li>\n<ul" text
+ regsub -all "</dl></li" $text "</dl>\n</li" text
+ regsub -all "</ol></li" $text "</ol>\n</li" text
+ regsub -all "</ul></li" $text "</ul>\n</li" text
+ # Remove empty lines.
+ regsub -all "\n\n\n*" $text \n text
+
+ if 0 {
+ puts_stderr @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+ puts_stderr $text
+ puts_stderr @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+ }
+
+ return $text
+}
+
+# markup text --
+# Protect markup characters in $text with \1.
+# These will be stripped out in PostProcess.
+#
+proc markup {text} {
+ global markupMap
+ return [string map $markupMap $text]
+}
+
+proc use_bg {} {
+ set c [bgcolor]
+ #puts stderr "using $c"
+ if {$c == {}} {return ""}
+ return bgcolor=$c
+}
+
+
+proc nbsp {} {return [markup "&nbsp;"]}
+proc p {} {return [markup <p>]}
+proc ptop {} {return [markup "<p valign=top>"]}
+proc td {} {return [markup "<td [use_bg]>"]}
+proc trtop {} {return [markup "<tr valign=top [use_bg]>"]}
+proc tr {} {return [markup "<tr [use_bg]>"]}
+proc sect {s} {return [markup <b>]$s[markup </b><br><hr>]}
+proc link {text url} {return [markup "<a href=\"$url\">"]$text[markup </a>]}
+proc table {} {return [markup "<table [border] width=100% cellspacing=0 cellpadding=0>"]}
+proc btable {} {return [markup "<table border=1 width=100% cellspacing=0 cellpadding=0>"]}
+proc stable {} {return [markup "<table [border] cellspacing=0 cellpadding=0>"]}
+
+proc link {text url} {return [markup "<a href=\"$url\">"]$text[markup </a>]}
+
+proc tcl_cmd {cmd} {return "[markup <b>]\[$cmd][markup </b>]"}
+proc wget {url} {exec /usr/bin/wget -q -O - $url 2>/dev/null}
+
+proc url {tag text url} {
+ set body {
+ switch -exact -- $what {
+ link {return {\1<a href="%url%"\1>%text%\1</a\1>}} ; ## TODO - markup
+ text {return {%text%}}
+ url {return {%url%}}
+ }
+ }
+ proc $tag {{what link}} [string map [list %text% $text %url% $url] $body]
+}
+
+proc img {tag alt img} {
+ proc $tag {} [list return "\1<img alt=\"$alt\" src=\"$img\"\1>"]
+}
+
+proc imagelink {alt img} {
+ return [markup "<img alt=\"$alt\" src=\"$img\">"]
+}
+
+proc protect {text} {return [string map [list & "&amp;" < "&lt;" > "&gt;"] $text]}
+
+proc strong {text} {tag_ strong $text}
+proc em {text} {tag_ em $text}
+proc bold {text class} {tag_ b $text class $class}
+proc italic {text class} {tag_ i $text class $class}
+proc span {text class} {tag_ span $text class $class}
+
+proc tag {t} {return [markup <$t>]}
+proc taga {t av} {
+ # av = attribute value ...
+ set avt [list]
+ foreach {a v} $av {lappend avt "$a=\"$v\""}
+ return [markup "<$t [join $avt]>"]
+}
+proc tag/ {t} {return [markup </$t>]}
+proc tag_ {t block args} {
+ # args = key value ...
+ if {$args == {}} {return "[tag $t]$block[tag/ $t]"}
+ return "[taga $t $args]$block[tag/ $t]"
+}
+proc tag* {t args} {
+ if {[llength $args]} {
+ taga $t $args
+ } else {
+ tag $t
+ }
+}
+
+proc ht_comment {text} {
+ return "[markup <]! -- [join [split $text \n] " -- "]\n --[markup >]"
+}
+
+# wrap content gi --
+# Returns $content wrapped inside <$gi> ... </$gi> tags.
+#
+proc wrap {content gi} {
+ return "[tag $gi]${content}[tag/ $gi]"
+}
+proc startTag {x args} {if {[llength $args]} {taga $x $args} else {tag $x}}
+proc endTag {x} {tag/ $x}
+
+
+proc anchor {name text} {
+ return [taga a [list name $name]]$text[tag/ a]
+}
diff --git a/tcllib/modules/doctools/mpformats/_idx_common.tcl b/tcllib/modules/doctools/mpformats/_idx_common.tcl
new file mode 100644
index 0000000..ca0c4c0
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/_idx_common.tcl
@@ -0,0 +1,31 @@
+# -*- tcl -*-
+#
+# _idx_common.tcl
+#
+# (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+################################################################
+# The code here contains general definitions for API functions and
+# state information. They are used by several formatters to simplify
+# their own code.
+
+proc idx_initialize {} {return}
+proc idx_shutdown {} {return}
+proc idx_numpasses {} {return 1}
+proc idx_postprocess {text} {return $text}
+proc idx_setup {n} {return}
+proc idx_listvariables {} {return {}}
+proc idx_varset {varname text} {return}
+
+
+proc fmt_plain_text {text} {return $text}
+
+################################################################
+# Functions made available to the formatter to access the common
+# state managed here.
+
+proc c_provenance {} {
+ return "Generated by tcllib/doctools/idx with format '[dt_format]'"
+}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/_nroff.tcl b/tcllib/modules/doctools/mpformats/_nroff.tcl
new file mode 100644
index 0000000..c630875
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/_nroff.tcl
@@ -0,0 +1,183 @@
+# -*- tcl -*-
+#
+# -- nroff commands
+#
+# Copyright (c) 2003-2005 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+
+################################################################
+# nroff specific commands
+#
+# All dot-commands (f.e. .PP) are returned with a leading \n\1,
+# enforcing that they are on a new line and will be protected as markup.
+# Any empty line created because of this is filtered out in the
+# post-processing step.
+
+
+proc nr_lp {} {return \n\1.LP}
+proc nr_ta {{text {}}} {return "\1.ta$text"}
+proc nr_bld {} {return \1\\fB}
+proc nr_bldt {t} {return "\n\1.B $t\n"}
+proc nr_ul {} {return \1\\fI}
+proc nr_rst {} {return \1\\fR}
+proc nr_p {} {return \n\1.PP\n}
+proc nr_comment {text} {return "\1'\1\\\" [join [split $text \n] "\n\1'\1\\\" "]"} ; # "
+proc nr_enum {num} {nr_item " \[$num\]"}
+proc nr_item {{text {}}} {return "\n\1.IP$text"}
+proc nr_vspace {} {return \n\1.sp\n}
+proc nr_blt {text} {return "\n\1.TP\n$text"}
+proc nr_bltn {n text} {return "\n\1.TP $n\n$text"}
+proc nr_in {} {return \n\1.RS}
+proc nr_out {} {return \n\1.RE}
+proc nr_nofill {} {return \n\1.nf}
+proc nr_fill {} {return \n\1.fi}
+proc nr_title {text} {return "\n\1.TH $text"}
+proc nr_include {file} {return "\n\1.so $file"}
+proc nr_bolds {} {return \n\1.BS}
+proc nr_bolde {} {return \n\1.BE}
+proc nr_read {fn} {return [nroffMarkup [dt_read $fn]]}
+proc nr_cs {} {return \n\1.CS\n}
+proc nr_ce {} {return \n\1.CE\n}
+
+proc nr_section {name} {
+ if {![regexp {[ ]} $name]} {
+ return "\n\1.SH [string toupper $name]"
+ }
+ return "\n\1.SH \"[string toupper $name]\""
+}
+proc nr_subsection {name} {
+ if {![regexp {[ ]} $name]} {
+ return "\n\1.SS [string toupper $name]"
+ }
+ return "\n\1.SS \"[string toupper $name]\""
+}
+
+
+################################################################
+
+# Handling of nroff special characters in content:
+#
+# Plain text is initially passed through unescaped;
+# internally-generated markup is protected by preceding it with \1.
+# The final PostProcess step strips the escape character from
+# real markup and replaces unadorned special characters in content
+# with proper escapes.
+#
+
+global markupMap
+set markupMap [list \
+ "\\" "\1\\" \
+ "'" "\1'" \
+ "." "\1." \
+ "\\\\" "\\"]
+global finalMap
+set finalMap [list \
+ "\1\\" "\\" \
+ "\1'" "'" \
+ "\1." "." \
+ "." "\\&." \
+ "\\" "\\\\"]
+global textMap
+set textMap [list "\\" "\\\\"]
+
+
+proc nroffEscape {text} {
+ global textMap
+ return [string map $textMap $text]
+}
+
+# markup text --
+# Protect markup characters in $text.
+# These will be stripped out in PostProcess.
+#
+proc nroffMarkup {text} {
+ global markupMap
+ return [string map $markupMap $text]
+}
+
+proc nroff_postprocess {nroff} {
+ global finalMap
+
+ # Postprocessing final nroff text.
+ # - Strip empty lines out of the text
+ # - Remove leading and trailing whitespace from lines.
+ # - Exceptions to the above: Keep empty lines and leading
+ # whitespace when in verbatim sections (no-fill-mode)
+
+ set nfMode [list \1.nf \1.CS] ; # commands which start no-fill mode
+ set fiMode [list \1.fi \1.CE] ; # commands which terminate no-fill mode
+ set lines [list] ; # Result buffer
+ set verbatim 0 ; # Automaton mode/state
+
+ foreach line [split $nroff "\n"] {
+ #puts_stderr |[expr {$verbatim ? "VERB" : " "}]|$line|
+
+ if {!$verbatim} {
+ # Normal lines, not in no-fill mode.
+
+ if {[lsearch -exact $nfMode [split $line]] >= 0} {
+ # no-fill mode starts after this line.
+ set verbatim 1
+ }
+
+ # Ensure that empty lines are not added.
+ # This also removes leading and trailing whitespace.
+
+ if {![string length $line]} {continue}
+ set line [string trim $line]
+ if {![string length $line]} {continue}
+
+ if {[regexp {^\x1\\f[BI]\.} $line]} {
+ # We found confusing formatting at the beginning of
+ # the current line. We lift this line up and attach it
+ # at the end of the last line to remove this
+ # irregularity. Note that the regexp has to look for
+ # the special 0x01 character as well to be sure that
+ # the sequence in question truly is formatting.
+ # [bug-3601370] Only lift & attach if last line is not
+ # a directive
+
+ set last [lindex $lines end]
+ if { ! [string match "\1.*" $last] } {
+ #puts_stderr \tLIFT
+ set lines [lreplace $lines end end]
+ set line "$last $line"
+ }
+ } elseif {[string match {[']*} $line]} {
+ # Apostrophes at the beginning of a line have to be
+ # quoted to prevent misinterpretation as comments.
+ # The true comments and are quoted with \1 already and
+ # will therefore not detected by the code here.
+ # puts_stderr \tQUOTE
+ set line \1\\$line
+ } ; # We are not handling dots at the beginning of a line here.
+ # # We are handling them in the finalMap which will quote _all_
+ # # dots in a text with a zero-width escape (\&).
+ } else {
+ # No-fill mode. We remove trailing whitespace, but keep
+ # leading whitespace and empty lines.
+
+ if {[lsearch -exact $fiMode [split $line]] >= 0} {
+ # Normal mode resumes after this line.
+ set verbatim 0
+ }
+ set line [string trimright $line]
+ }
+ lappend lines $line
+ }
+
+ set lines [join $lines "\n"]
+
+ # Now remove all superfluous .IP commands (empty paragraphs). The
+ # first identity mapping is present to avoid smashing a man macro
+ # definition.
+
+ lappend map \n\1.IP\n\1.\1.\n \n\1.IP\n\1.\1.\n
+ lappend map \n\1.IP\n\1. \n\1.
+
+ set lines [string map $map $lines]
+
+ # Return the modified result buffer
+ return [string map $finalMap $lines]
+}
+
diff --git a/tcllib/modules/doctools/mpformats/_text.tcl b/tcllib/modules/doctools/mpformats/_text.tcl
new file mode 100644
index 0000000..6541e35
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/_text.tcl
@@ -0,0 +1,430 @@
+# -*- tcl -*-
+#
+# _text.tcl -- Core support for text engines.
+
+
+################################################################
+
+if {0} {
+ catch {rename proc proc__} msg ; puts_stderr >>$msg
+ proc__ proc {cmd argl body} {
+ puts_stderr "proc $cmd $argl ..."
+ uplevel [list proc__ $cmd $argl $body]
+ }
+}
+
+dt_package textutil::string ; # for adjust
+dt_package textutil::repeat
+dt_package textutil::adjust
+
+if {0} {
+ puts_stderr ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ rename proc {}
+ rename proc__ proc
+ puts_stderr ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+}
+
+
+################################################################
+# Formatting constants ... Might be engine variables in the future.
+
+global lmarginIncrement ; set lmarginIncrement 4
+global rmarginThreshold ; set rmarginThreshold 20
+global bulleting ; set bulleting {* - # @ ~ %}
+global enumeration ; set enumeration {[%] (%) <%>}
+
+proc Bullet {ivar} {
+ global bulleting ; upvar $ivar i
+ set res [lindex $bulleting $i]
+ set i [expr {($i + 1) % [llength $bulleting]}]
+ return $res
+}
+
+proc EnumBullet {ivar} {
+ global enumeration ; upvar $ivar i
+ set res [lindex $enumeration $i]
+ set i [expr {($i + 1) % [llength $enumeration]}]
+ return $res
+}
+
+################################################################
+
+#
+# The engine maintains several data structures per document and pass.
+# Most important is an internal representation of the text better
+# suited to perform the final layouting, the display list. Elements of
+# the display list are lists containing 2 elements, an operation, and
+# its arguments, in this order. The arguments are a list again, its
+# contents are specific to the operation.
+#
+# The operations are:
+#
+# - SECT Section. Title.
+# - SUBSECT Subsection. Title.
+# - PARA Paragraph. Environment reference and text.
+#
+# The PARA operation is the workhorse of the engine, dooing all the
+# formatting, using the information in an "environment" as the guide
+# for doing so. The environments themselves are generated during the
+# second pass through the contents. They contain the information about
+# nesting (i.e. indentation), bulleting and the like.
+#
+
+global cmds ; set cmds [list] ; # Display list
+global pEnv ; array set pEnv {} ; # Defined paragraph environments (bulleting, indentation, other).
+global para ; set para "" ; # Text buffer for paragraphs.
+
+global nextId ; set nextId 0 ; # Counter for environment generation.
+global currentId ; set currentId {} ; # Id of current environment in 'pEnv'
+global currentEnv ; array set currentEnv {} ; # Current environment, expanded form.
+global contexts ; set contexts [list] ; # Stack of saved environments.
+global off ; set off 1 ; # Supression of plain text in some places.
+
+################################################################
+# Management of the current context.
+
+proc Text {text} {global para ; append para $text ; return}
+proc Store {op args} {global cmds ; lappend cmds [list $op $args] ; return}
+proc Off {} {global off ; set off 1 ; return}
+proc On {} {global off para ; set off 0 ; set para "" ; return}
+proc IsOff {} {global off ; return [expr {$off == 1}]}
+
+# Debugging ...
+#proc Text {text} {puts_stderr "TXT \{$text\}"; global para; append para $text ; return}
+#proc Store {op args} {puts_stderr "STO $op $args"; global cmds; lappend cmds [list $op $args]; return}
+#proc Off {} {puts_stderr OFF ; global off ; set off 1 ; return}
+#proc On {} {puts_stderr ON_ ; global off para ; set off 0 ; set para "" ; return}
+
+
+proc NewEnv {name script} {
+ global currentId nextId currentEnv
+
+ #puts_stderr "NewEnv ($name)"
+
+ set parentId $currentId
+ set currentId $nextId
+ incr nextId
+
+ append currentEnv(NAME) -$parentId-$name
+ set currentEnv(parent) $parentId
+ set currentEnv(id) $currentId
+
+ # Always squash a verbatim environment inherited from the previous
+ # environment ...
+ catch {unset currentEnv(verbenv)}
+
+ uplevel $script
+ SaveEnv
+ return $currentId
+}
+
+################################################################
+
+proc TextInitialize {} {
+ global off ; set off 1
+ global cmds ; set cmds [list] ; # Display list
+ global pEnv ; array set pEnv {} ; # Defined paragraph environments (bulleting, indentation, other).
+ global para ; set para "" ; # Text buffer for paragraphs.
+
+ global nextId ; set nextId 0 ; # Counter for environment generation.
+ global currentId ; set currentId {} ; # Id of current environment in 'pEnv'
+ global currentEnv ; array set currentEnv {} ; # Current environment, expanded form.
+ global contexts ; set contexts [list] ; # Stack of saved environments.
+
+ # lmargin = location of left margin for text.
+ # prefix = prefix string to use for all lines.
+ # wspfx = whitespace prefix for all but the first line
+ # listtype = type of list, if any
+ # bullet = bullet to use for unordered, bullet template for ordered.
+ # verbatim = flag if verbatim formatting requested.
+ # next = if present the environment to use after closing the paragraph using this one.
+
+ NewEnv Base {
+ array set currentEnv {
+ lmargin 0
+ prefix {}
+ wspfx {}
+ listtype {}
+ bullet {}
+ verbatim 0
+ bulleting 0
+ enumeration 0
+ }
+ }
+ return
+}
+
+################################################################
+
+proc Section {name} {Store SECT $name ; return}
+proc Subsection {name} {Store SUBSECT $name ; return}
+
+proc CloseParagraph {{id {}}} {
+ global para currentId
+ if {$para != {}} {
+ if {$id == {}} {set id $currentId}
+ Store PARA $id $para
+ #puts_stderr "CloseParagraph $id"
+ }
+ set para ""
+ return
+}
+
+proc SaveContext {} {
+ global contexts currentId
+ lappend contexts $currentId
+
+ #global currentEnv ; puts_stderr "Save>> $currentId ($currentEnv(NAME))"
+ return
+}
+
+proc RestoreContext {} {
+ global contexts
+ SetContext [lindex $contexts end]
+ set contexts [lrange $contexts 0 end-1]
+
+ #global currentId currentEnv ; puts_stderr "<<Restored $currentId ($currentEnv(NAME))"
+ return
+}
+
+proc SetContext {id} {
+ global currentId currentEnv pEnv
+ set currentId $id
+
+ # Ensure that array is clean before setting hte new block of
+ # information.
+ unset currentEnv
+ array set currentEnv $pEnv($currentId)
+
+ #puts_stderr "--Set $currentId ($currentEnv(NAME))"
+ return
+}
+
+proc SaveEnv {} {
+ global pEnv currentId currentEnv
+ set pEnv($currentId) [array get currentEnv]
+ return
+}
+
+################################################################
+
+proc NewVerbatim {} {
+ global currentEnv
+ return [NewEnv Verbatim {set currentEnv(verbatim) 1}]
+}
+
+proc Verbatim {} {
+ global currentEnv
+ if {![info exists currentEnv(verbenv)]} {
+ SaveContext
+ set verb [NewVerbatim]
+ RestoreContext
+
+ # Remember verbatim mode in the base environment
+ set currentEnv(verbenv) $verb
+ SaveEnv
+ }
+ return $currentEnv(verbenv)
+}
+
+################################################################
+
+proc text_plain_text {text} {
+ #puts_stderr "<<text_plain_text>>"
+
+ if {[IsOff]} {return}
+
+ # Note: Whenever we get plain text it is possible that a macro for
+ # visual markup actually generated output before the expander got
+ # to the current text. This output was captured by the expander in
+ # its current context. Given the current organization of the
+ # engine we have to retrieve this formatted text from the expander
+ # or it will be lost. This is the purpose of the 'ctopandclear',
+ # which retrieves the data and also clears the capture buffer. The
+ # latter to prevent us from retrieving it again later, after the
+ # next macro added more data.
+
+ set text [ex_ctopandclear]$text
+
+ # ... TODO ... Handling of example => verbatim
+
+ if {[string length [string trim $text]] == 0} return
+
+ Text $text
+ return
+}
+
+################################################################
+
+proc text_postprocess {text} {
+
+ #puts_stderr XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+ #puts_stderr <<$text>>
+ #puts_stderr XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+
+ global cmds
+ # The argument is not relevant. Access the display list, perform
+ # the final layouting and return its result.
+
+ set linebuffer [list]
+ array set state {lmargin 0 rmargin 0}
+ foreach cmd $cmds {
+ foreach {op arguments} $cmd break
+ $op $arguments
+ }
+
+ #puts_stderr XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+
+ return [join $linebuffer \n]
+}
+
+
+proc SECT {text} {
+ upvar linebuffer linebuffer
+
+ # text is actually the list of arguments, having one element, the text.
+ set text [lindex $text 0]
+ #puts_stderr "SECT $text"
+ #puts_stderr ""
+
+ # Write section title, underline it
+
+ lappend linebuffer ""
+ lappend linebuffer $text
+ lappend linebuffer [textutil::repeat::strRepeat = [string length $text]]
+ return
+}
+
+proc SUBSECT {text} {
+ upvar linebuffer linebuffer
+
+ # text is actually the list of arguments, having one element, the text.
+ set text [lindex $text 0]
+ #puts_stderr "SUBSECT $text"
+ #puts_stderr ""
+
+ # Write subsection title, underline it (with less emphasis)
+
+ lappend linebuffer ""
+ lappend linebuffer $text
+ lappend linebuffer [textutil::repeat::strRepeat - [string length $text]]
+ return
+}
+
+proc PARA {arguments} {
+ global pEnv
+ upvar linebuffer linebuffer
+
+ foreach {env text} $arguments break
+ array set para $pEnv($env)
+
+ #puts_stderr "PARA $env"
+ #parray_stderr para
+ #puts_stderr " \{$text\}"
+ #puts_stderr ""
+
+ # Use the information in the referenced environment to format the paragraph.
+
+ if {$para(verbatim)} {
+ set text [textutil::adjust::undent $text]
+ } else {
+ # The size is determined through the set left and right margins
+ # right margin is fixed at 80, left margin is variable. Size
+ # is at least 20. I.e. when left margin > 60 right margin is
+ # shifted out to the right.
+
+ set size [expr {80 - $para(lmargin)}]
+ if {$size < 20} {set size 20}
+
+ set text [textutil::adjust::adjust $text -length $size]
+ }
+
+ # Now apply prefixes, (ws prefixes bulleting), at last indentation.
+
+ if {[string length $para(prefix)] > 0} {
+ set text [textutil::adjust::indent $text $para(prefix)]
+ }
+
+ if {$para(listtype) != {}} {
+ switch -exact $para(listtype) {
+ bullet {
+ # Indent for bullet, but not the first line. This is
+ # prefixed by the bullet itself.
+
+ set thebullet $para(bullet)
+ }
+ enum {
+ # Handling the enumeration counter. Special case: An
+ # example as first paragraph in an item has to use the
+ # counter in environment it is derived from to prevent
+ # miscounting.
+
+ if {[info exists para(example)]} {
+ set parent $para(parent)
+ array set __ $pEnv($parent)
+ if {![info exists __(counter)]} {
+ set __(counter) 1
+ } else {
+ incr __(counter)
+ }
+ set pEnv($parent) [array get __] ; # Save context change ...
+ set n $__(counter)
+ } else {
+ if {![info exists para(counter)]} {
+ set para(counter) 1
+ } else {
+ incr para(counter)
+ }
+ set pEnv($env) [array get para] ; # Save context change ...
+ set n $para(counter)
+ }
+
+ set thebullet [string map [list % $n] $para(bullet)]
+ }
+ }
+
+ set blen [string length $thebullet]
+ if {$blen >= [string length $para(wspfx)]} {
+ set text "$thebullet\n[textutil::adjust::indent $text $para(wspfx)]"
+ } else {
+ set fprefix $thebullet[string range $para(wspfx) $blen end]
+ set text "${fprefix}[textutil::adjust::indent $text $para(wspfx) 1]"
+ }
+ }
+
+ if {$para(lmargin) > 0} {
+ set text [textutil::adjust::indent $text \
+ [textutil::repeat::strRepeat " " $para(lmargin)]]
+ }
+
+ lappend linebuffer ""
+ lappend linebuffer $text
+ return
+}
+
+################################################################
+
+proc strong {text} {return *${text}*}
+proc em {text} {return _${text}_}
+
+################################################################
+
+proc parray_stderr {a {pattern *}} {
+ upvar 1 $a array
+ if {![array exists array]} {
+ error "\"$a\" isn't an array"
+ }
+ set maxl 0
+ foreach name [lsort [array names array $pattern]] {
+ if {[string length $name] > $maxl} {
+ set maxl [string length $name]
+ }
+ }
+ set maxl [expr {$maxl + [string length $a] + 2}]
+ foreach name [lsort [array names array $pattern]] {
+ set nameString [format %s(%s) $a $name]
+ puts_stderr " [format "%-*s = {%s}" $maxl $nameString $array($name)]"
+ }
+}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/_toc_common.tcl b/tcllib/modules/doctools/mpformats/_toc_common.tcl
new file mode 100644
index 0000000..a6ee81d
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/_toc_common.tcl
@@ -0,0 +1,31 @@
+# -*- tcl -*-
+#
+# _toc_common.tcl
+#
+# (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+################################################################
+# The code here contains general definitions for API functions and
+# state information. They are used by several formatters to simplify
+# their own code.
+
+proc toc_initialize {} {return}
+proc toc_shutdown {} {return}
+proc toc_numpasses {} {return 1}
+proc toc_postprocess {text} {return $text}
+proc toc_setup {n} {return}
+proc toc_listvariables {} {return {}}
+proc toc_varset {varname text} {return}
+
+
+proc fmt_plain_text {text} {return $text}
+
+################################################################
+# Functions made available to the formatter to access the common
+# state managed here.
+
+proc c_provenance {} {
+ return "Generated by tcllib/doctools/toc with format '[dt_format]'"
+}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/_xml.tcl b/tcllib/modules/doctools/mpformats/_xml.tcl
new file mode 100644
index 0000000..346a2bd
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/_xml.tcl
@@ -0,0 +1,236 @@
+# -*- tcl -*-
+#
+# $Id: _xml.tcl,v 1.9 2004/04/22 21:16:46 jenglish Exp $
+#
+# [expand] utilities for generating XML.
+#
+# Copyright (C) 2001 Joe English <jenglish@sourceforge.net>.
+# Freely redistributable.
+#
+######################################################################
+
+
+# Handling XML delimiters in content:
+#
+# Plain text is initially passed through unescaped;
+# internally-generated markup is protected by preceding it with \1.
+# The final PostProcess step strips the escape character from
+# real markup and replaces markup characters from content
+# with entity references.
+#
+
+variable attvalMap { {&} &amp; {<} &lt; {>} &gt; {"} &quot; {'} &apos; } ; # "
+variable markupMap { {&} {\1&} {<} {\1<} {>} {\1>} }
+variable finalMap { {\1&} {&} {\1<} {<} {\1>} {>}
+ {&} &amp; {<} &lt; {>} &gt; }
+
+proc fmt_postprocess {text} {
+ variable finalMap
+ return [string map $finalMap $text]
+}
+
+# markup text --
+# Protect markup characters in $text with \1.
+# These will be stripped out in PostProcess.
+#
+proc markup {text} {
+ variable markupMap
+ return [string map $markupMap $text]
+}
+
+# attlist { n1 v1 n2 v2 ... } --
+# Return XML-formatted attribute list.
+# Does *not* escape markup -- the result must be passed through
+# [markup] before returning it to the expander.
+#
+proc attlist {nvpairs} {
+ variable attvalMap
+ if {[llength $nvpairs] == 1} { set nvpairs [lindex $nvpairs 0] }
+ set attlist ""
+ foreach {name value} $nvpairs {
+ append attlist " $name='[string map $attvalMap $value]'"
+ }
+ return $attlist
+}
+
+# startTag gi ?attname attval ... ? --
+# Return start-tag for element $gi with specified attributes.
+#
+proc startTag {gi args} {
+ return [markup "<$gi[attlist $args]>"]
+}
+
+# endTag gi --
+# Return end-tag for element $gi.
+#
+proc endTag {gi} {
+ return [markup "</$gi>"]
+}
+
+# emptyElement gi ?attribute value ... ?
+# Return empty-element tag.
+#
+proc emptyElement {gi args} {
+ return [markup "<$gi[attlist $args]/>"]
+}
+
+# xmlComment text --
+# Return XML comment declaration containing $text.
+# NB: if $text includes the sequence "--", it will be mangled.
+#
+proc xmlComment {text} {
+ return [markup "<!-- [string map {-- { - - }} $text] -->"]
+}
+
+# wrap content gi --
+# Returns $content wrapped inside <$gi> ... </$gi> tags.
+#
+proc wrap {content gi} {
+ return "[startTag $gi]${content}[endTag $gi]"
+}
+
+# wrap? content gi --
+# Same as [wrap], but returns an empty string if $content is empty.
+#
+proc wrap? {content gi} {
+ if {![string length [string trim $content]]} { return "" }
+ return "[startTag $gi]${content}[endTag $gi]"
+}
+
+# wrapLines? content gi ? gi... ?
+# Same as [wrap?], but separates entries with newlines
+# and supports multiple nesting levels.
+#
+proc wrapLines? {content args} {
+ if {![string length $content]} { return "" }
+ foreach gi $args {
+ set content [join [list [startTag $gi] $content [endTag $gi]] "\n"]
+ }
+ return $content
+}
+
+# sequence args --
+# Handy combinator.
+#
+proc sequence {args} { join $args "\n" }
+
+######################################################################
+# XML context management.
+#
+
+variable elementStack [list]
+
+# start gi ?attribute value ... ? --
+# Return start-tag for element $gi
+# As a side-effect, pushes $gi onto the element stack.
+#
+proc start {gi args} {
+ if {[llength $args] == 1} { set args [lindex $args 0] }
+ variable elementStack
+ lappend elementStack $gi
+ return [startTag $gi $args]
+}
+
+# xmlContext {gi1 ... giN} ?default? --
+# Pops elements off the element stack until one of
+# the specified element types is found.
+#
+# Returns: sequence of end-tags for each element popped.
+#
+# If none of the specified elements are found, returns
+# a start-tag for $default.
+#
+proc xmlContext {gis {default {}}} {
+ variable elementStack
+ set origStack $elementStack
+ set endTags [list]
+ while {[llength $elementStack]} {
+ set current [lindex $elementStack end]
+ if {[lsearch $gis $current] >= 0} {
+ return [join $endTags \n]
+ }
+ lappend endTags [endTag $current]
+ set elementStack [lreplace $elementStack end end]
+ }
+ # Not found:
+ set elementStack $origStack
+ if {![string length $default]} {
+ set where "[join $elementStack /] - [info level 1]"
+ puts_stderr "Warning: Cannot start context $gis ($where)"
+ set default [lindex $gis 0]
+ }
+ lappend elementStack $default
+ return [startTag $default]
+}
+
+# end ? gi ? --
+# Generate markup to close element $gi, including end-tags
+# for any elements above it on the element stack.
+#
+# If element name is omitted, closes the current element.
+#
+proc end {{gi {}}} {
+ variable elementStack
+ if {![string length $gi]} {
+ set gi [lindex $elementStack end]
+ }
+ set prefix [xmlContext $gi]
+ set elementStack [lreplace $elementStack end end]
+ return [join [list $prefix [endTag $gi]] "\n"]
+}
+
+######################################################################
+# Utilities for multi-pass processing.
+#
+# Not really XML-related, but I find them handy.
+#
+
+variable PassProcs
+variable Buffers
+
+# pass $passNo procName procArgs { body } --
+# Specifies procedure definition for pass $n.
+#
+proc pass {pass proc arguments body} {
+ variable PassProcs
+ lappend PassProcs($pass) $proc $arguments $body
+}
+
+proc setPassProcs {pass} {
+ variable PassProcs
+ foreach {proc args body} $PassProcs($pass) {
+ proc $proc $args $body
+ }
+}
+
+# holdBuffers buffer ? buffer ...? --
+# Declare a list of hold buffers,
+# to collect data in one pass and output it later.
+#
+proc holdBuffers {args} {
+ variable Buffers
+ foreach arg $args {
+ set Buffers($arg) [list]
+ }
+}
+
+# hold buffer text --
+# Append text to named buffer
+#
+proc hold {buffer entry} {
+ variable Buffers
+ lappend Buffers($buffer) $entry
+ return
+}
+
+# held buffer --
+# Returns current contents of named buffer and empty the buffer.
+#
+proc held {buffer} {
+ variable Buffers
+ set content [join $Buffers($buffer) "\n"]
+ set Buffers($buffer) [list]
+ return $content
+}
+
+#*EOF*
diff --git a/tcllib/modules/doctools/mpformats/c.msg b/tcllib/modules/doctools/mpformats/c.msg
new file mode 100644
index 0000000..99c72a7
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/c.msg
@@ -0,0 +1,58 @@
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+mcset c end/open/list "End of manpage reached, \[list_end\] missing"
+mcset c end/open/example "End of manpage reached, \[example_end\] missing"
+mcset c end/open/mp "End of manpage reached, \[manpage_end\] missing"
+mcset c mpbegin "Command must be first of manpage"
+mcset c mptitle "Spaces not allowed in manpage title"
+mcset c hdrcmd "Command not allowed outside of the header section"
+mcset c bodycmd "Command not allowed outside of the body of the manpage"
+mcset c body "Plain text not allowed outside of the body of the manpage"
+mcset c reqcmd "Command not allowed outside of header or requirement section"
+mcset c invalidlist "Invalid list type \"@\""
+mcset c nolistcmd "Command not allowed inside of a list"
+mcset c nolisthdr "Command not allowed between beginning of a list and its first item"
+mcset c nolisttxt "Plain text not allowed between beginning of a list and its first item"
+mcset c listcmd "Command not allowed outside of a list"
+mcset c deflist "Command restricted to usage in definition lists"
+mcset c bulletlist "Command restricted to usage in itemized lists"
+mcset c enumlist "Command restricted to usage in enumerated lists"
+mcset c examplecmd "Command allowed only to close example section"
+mcset c listcmd "Command not allowed outside of a list"
+mcset c nodonecmd "Command not allowed after \[manpage_end\]"
+mcset c arg_list "Command restricted to usage in argument lists"
+mcset c cmd_list "Command restricted to usage in command lists"
+mcset c opt_list "Command restricted to usage in option lists"
+mcset c tkoption_list "Command restricted to usage in tkoption lists"
+mcset c depr_strong "Deprecated command \"%s\".\n\tPlease consider appropriate semantic markup or \[emph\] instead."
+mcset c depr_lstitem "Deprecated command \"%s\".\n\tPlease use \[def\] instead."
+mcset c depr_nl "Deprecated command \"%s\".\n\tPlease use \[para\] instead."
+mcset c depr_bullet "Deprecated command \"%s\".\n\tPlease use \[item\] instead."
+mcset c depr_ltype "Deprecated list type \"%s\".\n\tPlease use \"%s\" instead."
+mcset c sectambig "(Sub)Section title \"%s\" causes ambiguous section references."
+mcset c missingsect "Refered (Sub)Section \"%s\" is not known."
+
+# TOC messages
+
+mcset c end/open/toc "\[toc_end\] missing."
+mcset c toc/plaintext "Plain text beyond whitespace is not allowed."
+mcset c toc/begincmd "Command not allowed here."
+mcset c toc/endcmd "Command not allowed here."
+mcset c toc/titlecmd "Command not allowed here."
+mcset c toc/sectcmd "Command not allowed here."
+mcset c toc/sectecmd "Command not allowed here."
+mcset c toc/itemcmd "Command not allowed here."
+mcset c toc/nodonecmd "Command not allowed after \[toc_end\]"
+
+# IDX messages
+
+mcset c end/open/idx "\[index_end\] missing."
+mcset c idx/plaintext "Plain text beyond whitespace is not allowed."
+mcset c idx/begincmd "Command not allowed here."
+mcset c idx/endcmd "Command not allowed here."
+mcset c idx/keycmd "Command not allowed here."
+mcset c idx/manpagecmd "Command not allowed here."
+mcset c idx/urlcmd "Command not allowed here."
+mcset c idx/nodonecmd "Command not allowed after \[index_end\]"
diff --git a/tcllib/modules/doctools/mpformats/de.msg b/tcllib/modules/doctools/mpformats/de.msg
new file mode 100644
index 0000000..8ba908c
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/de.msg
@@ -0,0 +1,54 @@
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+mcset de end/open/list "Dokument zu Ende, nicht alle Listen wurden geschlossen"
+mcset de end/open/example "Dokument zu Ende, das letzte Beispiel wurde nicht abgeschlossen"
+mcset de end/open/mp "Dokument zu Ende, es fehlt der Abschlussbefehl \[manpage_end\]"
+mcset de mpbegin "Erwartete diesen Befehl als ersten in der Manpage"
+mcset de mptitle "Der Manpage Titel darf keine Leerzeichen enthalten"
+mcset de hdrcmd "Dieser Befehl ist ausserhalb des Headers nicht erlaubt"
+mcset de bodycmd "Dieser Befehl darf nicht ausserhalb des Hauptteils der Manpage auftreten"
+mcset de body "Text darf nicht ausserhalb des Hauptteils der Manpage auftreten"
+mcset de reqcmd "Dieser Befehl ist ausserhalb von Header/Requirements nicht erlaubt"
+mcset de invalidlist "Die Listenart \"@\" ist dem System nicht bekannt"
+mcset de nolistcmd "Dieser Befehl ist innerhalb einer Liste nicht erlaubt"
+mcset de nolisthdr "Dieser Befehl darf nicht zwischen dem Beginn einer Liste und ihrem ersten Unterpunkt benutzt werden"
+mcset de nolisttxt "Text darf nicht zwischen dem Beginn einer Liste und ihrem ersten Unterpunkt benutzt werden"
+mcset de listcmd "Dieser Befehl ist ausserhalb einer Liste nicht erlaubt"
+mcset de deflist "Dieser Befehl darf nur in Definitions-Listen benutzt werden"
+mcset de bulletlist "Dieser Befehl darf nur in ungeordneten Listen benutzt werden"
+mcset de enumlist "Dieser Befehl darf nur in Aufz\xE4hlungs-Listen benutzt werden"
+mcset de examplecmd "Dieser Befehl kann nur zum Schliessen eines Beispieles benutzt werden"
+mcset de listcmd "Dieser Befehl ist ausserhalb einer Liste nicht erlaubt"
+mcset de nodonecmd "Dieser Befehl ist nach Ausf\xFChrung von \[manpage_end\] nicht mehr erlaubt"
+mcset de arg_list "Dieser Befehl darf nur in Argument-Listen benutzt werden"
+mcset de cmd_list "Dieser Befehl darf nur in Befehls-Listen benutzt werden"
+mcset de opt_list "Dieser Befehl darf nur in Options-Listen benutzt werden"
+mcset de tkoption_list "Dieser Befehl darf nur in TkOptions-Listen benutzt werden"
+mcset de depr_strong "Misbilligter Befehl \"%s\".\n\tBitte verwenden sie \[emph\] oder eine passende semantische Auszeichnung."
+mcset de depr_lstitem "Misbilligter Befehl \"%s\".\n\tBitte verwenden sie \[def\]."
+mcset de depr_nl "Misbilligter Befehl \"%s\".\n\tBitte verwenden sie \[para\]."
+mcset de depr_bullet "Misbilligter Befehl \"%s\".\n\tBitte verwenden sie \[item\]."
+mcset de depr_ltype "Misbilligte Listen-Art \"%s\".\n\tBitte verwenden sie \"%s\"."
+mcset de sectambig "Die Kapitel\xFCberschrift \"%s\" ist nicht eindeutig, Referenzen k\xF6nnen falsch sein."
+mcset de missingsect "Die Kapitel\xFCberschrift \"%s\" ist nicht bekannt."
+
+mcset de end/open/toc "\[toc_end\] fehlt."
+mcset de toc/plaintext "Normaler Text ist (mit Ausnahme von reinem Leerraum) nicht erlaubt."
+mcset de toc/begincmd "Dieser Befehl ist hier nicht erlaubt."
+mcset de toc/endcmd "Dieser Befehl ist hier nicht erlaubt."
+mcset de toc/titlecmd "Dieser Befehl ist hier nicht erlaubt."
+mcset de toc/sectcmd "Dieser Befehl ist hier nicht erlaubt."
+mcset de toc/sectecmd "Dieser Befehl ist hier nicht erlaubt."
+mcset de toc/itemcmd "Dieser Befehl ist hier nicht erlaubt."
+mcset de toc/nodonecmd "Dieser Befehl ist nach \[toc_end\] nicht erlaubt."
+
+mcset de end/open/idx "\[index_end\] fehlt."
+mcset de idx/plaintext "Normaler Text ist (mit Ausnahme von reinem Leerraum) nicht erlaubt."
+mcset de idx/begincmd "Dieser Befehl ist hier nicht erlaubt."
+mcset de idx/endcmd "Dieser Befehl ist hier nicht erlaubt."
+mcset de idx/keycmd "Dieser Befehl ist hier nicht erlaubt."
+mcset de idx/manpagecmd "Dieser Befehl ist hier nicht erlaubt."
+mcset de idx/urlcmd "Dieser Befehl ist hier nicht erlaubt."
+mcset de idx/nodonecmd "Dieser Befehl ist nach \[index_end\] nicht erlaubt."
diff --git a/tcllib/modules/doctools/mpformats/en.msg b/tcllib/modules/doctools/mpformats/en.msg
new file mode 100644
index 0000000..d7dfffd
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/en.msg
@@ -0,0 +1,54 @@
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+mcset en end/open/list "End of manpage reached, \[list_end\] missing"
+mcset en end/open/example "End of manpage reached, \[example_end\] missing"
+mcset en end/open/mp "End of manpage reached, \[manpage_end\] missing"
+mcset en mpbegin "Command must be first of manpage"
+mcset en mptitle "Spaces not allowed in manpage title"
+mcset en hdrcmd "Command not allowed outside of the header section"
+mcset en bodycmd "Command not allowed outside of the body of the manpage"
+mcset en body "Plain text not allowed outside of the body of the manpage"
+mcset en reqcmd "Command not allowed outside of header or requirement section"
+mcset en invalidlist "Invalid list type \"@\""
+mcset en nolistcmd "Command not allowed inside of a list"
+mcset en nolisthdr "Command not allowed between beginning of a list and its first item"
+mcset en nolisttxt "Plain text not allowed between beginning of a list and its first item"
+mcset en listcmd "Command not allowed outside of a list"
+mcset en deflist "Command restricted to usage in definition lists"
+mcset en bulletlist "Command restricted to usage in itemized lists"
+mcset en enumlist "Command restricted to usage in enumerated lists"
+mcset en examplecmd "Command allowed only to close example section"
+mcset en listcmd "Command not allowed outside of a list"
+mcset en nodonecmd "Command not allowed after \[manpage_end\]"
+mcset en arg_list "Command restricted to usage in argument lists"
+mcset en cmd_list "Command restricted to usage in command lists"
+mcset en opt_list "Command restricted to usage in option lists"
+mcset en tkoption_list "Command restricted to usage in tkoption lists"
+mcset en depr_strong "Deprecated command \"%s\".\n\tPlease consider appropriate semantic markup or \[emph\] instead."
+mcset en depr_lstitem "Deprecated command \"%s\".\n\tPlease use \[def\] instead."
+mcset en depr_nl "Deprecated command \"%s\".\n\tPlease use \[para\] instead."
+mcset en depr_bullet "Deprecated command \"%s\".\n\tPlease use \[item\] instead."
+mcset en depr_ltype "Deprecated list type \"%s\".\n\tPlease use \"%s\" instead."
+mcset en sectambig "(Sub)Section title \"%s\" causes ambiguous section references."
+mcset en missingsect "Refered (Sub)Section \"%s\" is not known."
+
+mcset en end/open/toc "\[toc_end\] missing."
+mcset en toc/plaintext "Plain text beyond whitespace is not allowed."
+mcset en toc/begincmd "Command not allowed here."
+mcset en toc/endcmd "Command not allowed here."
+mcset en toc/titlecmd "Command not allowed here."
+mcset en toc/sectcmd "Command not allowed here."
+mcset en toc/sectecmd "Command not allowed here."
+mcset en toc/itemcmd "Command not allowed here."
+mcset en toc/nodonecmd "Command not allowed after \[toc_end\]"
+
+mcset en end/open/idx "\[index_end\] missing."
+mcset en idx/plaintext "Plain text beyond whitespace is not allowed."
+mcset en idx/begincmd "Command not allowed here."
+mcset en idx/endcmd "Command not allowed here."
+mcset en idx/keycmd "Command not allowed here."
+mcset en idx/manpagecmd "Command not allowed here."
+mcset en idx/urlcmd "Command not allowed here."
+mcset en idx/nodonecmd "Command not allowed after \[index_end\]"
diff --git a/tcllib/modules/doctools/mpformats/fmt.desc b/tcllib/modules/doctools/mpformats/fmt.desc
new file mode 100644
index 0000000..19afb44
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/fmt.desc
@@ -0,0 +1,49 @@
+# -*- tcl -*-
+#
+# -- Extraction of meta information from a manpage (package
+# description), and associating it with package names.
+#
+# Copyright (c) 2005 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+################################################################
+
+# Take the null format as a base and extend it a bit.
+dt_source fmt.null
+
+global data
+array set data {}
+
+proc fmt_numpasses {} {return 1}
+proc fmt_postprocess {text} {
+ global data
+
+ # Title in required packages => This is the sole package.
+ # Otherwise dump everything required.
+
+ if {[lsearch -exact $data(require) $data(title)] >= 0} {
+ return [list $data(title) $data(shortdesc) $data(desc)]
+ } else {
+ set res {}
+ foreach p $data(require) {
+ lappend res [list $p $data(shortdesc) $data(desc)]
+ }
+ return [join $res \n]
+ }
+}
+proc fmt_plain_text {text} {return ""}
+proc fmt_setup {n} {return}
+
+proc fmt_manpage_begin {title section version} {
+ global data
+ set data(title) $title
+ set data(require) {}
+ set data(desc) ""
+ set data(shortdesc) ""
+ return
+}
+
+proc fmt_moddesc {desc} {global data ; set data(shortdesc) $desc}
+proc fmt_titledesc {desc} {global data ; set data(desc) $desc}
+proc fmt_require {p {v {}}} {global data ; lappend data(require) $p ; return}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/fmt.html b/tcllib/modules/doctools/mpformats/fmt.html
new file mode 100644
index 0000000..153a52d
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/fmt.html
@@ -0,0 +1,737 @@
+# -*- tcl -*-
+#
+# fmt.html
+#
+# Copyright (c) 2001-2008 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# Definitions to convert a tcl based manpage definition into
+# a manpage based upon HTML markup.
+#
+################################################################
+################################################################
+
+dt_source _common.tcl ; # Shared code
+dt_source _html.tcl ; # HTML basic formatting
+
+proc c_copyrightsymbol {} {return "[markup "&"]copy;"}
+
+proc bgcolor {} {return ""}
+proc border {} {return 0}
+proc Year {} {clock format [clock seconds] -format %Y}
+
+c_holdBuffers require synopsis
+
+################################################################
+## Backend for HTML markup
+
+# --------------------------------------------------------------
+# Handling of lists. Simplified, the global check of nesting and
+# legality of list commands allows us to throw away most of the
+# existing checks.
+
+global liststack ; # stack of list tags to use in list_end
+set liststack {}
+
+proc lpush {t class} {
+ global liststack
+ lappend liststack [list [tag/ $t] [litc_getandclear]]
+ return [taga $t [list class $class]]
+}
+
+proc lpop {} {
+ global liststack
+ set t [lindex $liststack end]
+ set liststack [lreplace $liststack end end]
+ foreach {t l} $t break
+ litc_set $l
+ return $t
+}
+
+proc fmt_plain_text {text} {
+ return $text
+}
+
+################################################################
+# Formatting commands.
+
+c_pass 1 fmt_manpage_begin {title section version} {c_cinit ; c_clrSections ; return}
+c_pass 2 fmt_manpage_begin {title section version} {
+
+ global sec_is_open ; set sec_is_open 0
+ global subsec_is_open ; set subsec_is_open 0
+ global prev_litem_close ; set prev_litem_close {}
+ global para_is_open ; set para_is_open 0
+ global liststack ; set liststack {}
+ global defaultstyle
+
+ XrefInit
+ c_cinit
+ set module [dt_module]
+ set shortdesc [c_get_module]
+ set description [c_get_title]
+ set copyright [c_get_copyright]
+
+ set pagetitle "$title - $shortdesc"
+
+ set hdr ""
+
+ if {![Get raw]} {
+ append hdr [tag html] [tag head] \n
+ append hdr [tag_ title $pagetitle] \n
+
+ if {![Extend hdr ByParameter meta]} {
+ # Insert standard CSS definitions.
+ append hdr [tag_ style \
+ "[markup <]!--${defaultstyle}--[markup >]" \
+ type text/css] \n
+ }
+
+ append hdr [tag/ head] \n
+ append hdr [ht_comment [c_provenance]]\n
+ if {$copyright != {}} {
+ append hdr [ht_comment $copyright]\n
+ }
+ append hdr [ht_comment "$title.$section"]
+ append hdr \n\n
+ append hdr [tag body]
+ }
+
+ Extend hdr ByParameter header \
+ @TITLE@ $pagetitle
+
+ append hdr [tag* div class doctools] \n
+
+ set thetitle "[string trimleft $title :]($section) $version $module \"$shortdesc\""
+ append hdr [tag_ h1 $thetitle class doctools_title] \n
+ append hdr [fmt_section Name name] \n
+ append hdr "[para_open] $title - $description"
+ return $hdr
+}
+
+c_pass 1 fmt_moddesc {desc} {c_set_module $desc}
+c_pass 2 fmt_moddesc {desc} NOP
+
+c_pass 1 fmt_titledesc {desc} {c_set_title $desc}
+c_pass 2 fmt_titledesc {desc} NOP
+
+c_pass 1 fmt_copyright {desc} {c_set_copyright $desc}
+c_pass 2 fmt_copyright {desc} NOP
+
+c_pass 1 fmt_manpage_end {} {c_creset ; return}
+c_pass 2 fmt_manpage_end {} {
+ c_creset
+ set res ""
+
+ set sa [c_xref_seealso]
+ set kw [c_xref_keywords]
+ set ca [c_xref_category]
+ set ct [c_get_copyright]
+
+ if {[llength $sa] > 0} {
+ append res [fmt_section {See Also} see-also] \n
+ append res [join [XrefList [lsort $sa] sa] ", "] \n
+ }
+ if {[llength $kw] > 0} {
+ append res [fmt_section Keywords keywords] \n
+ append res [join [XrefList [lsort $kw] kw] ", "] \n
+ }
+ if {$ca ne ""} {
+ append res [fmt_section Category category] \n
+ append res $ca \n
+ }
+ if {$ct != {}} {
+ append res [fmt_section Copyright copyright] \n
+ append res [join [split $ct \n] [tag br]\n] [tag br]\n
+ }
+
+ # Close last paragraph, subsection, and section.
+ append res [para_close][subsec_close][sec_close]
+
+ Extend res ByParameter footer
+
+ append res [tag/ div]
+ if {![Get raw]} {
+ append res [tag/ body] [tag/ html]
+ }
+ return $res
+}
+
+c_pass 1 fmt_section {name id} {c_newSection $name 1 end $id}
+c_pass 2 fmt_section {name id} {
+ return "[sec_open $id][tag_ h2 [anchor $id $name]]\n[para_open]"
+}
+
+c_pass 1 fmt_subsection {name id} {c_newSection $name 2 end $id}
+c_pass 2 fmt_subsection {name id} {
+ return "[subsec_open $id][tag_ h3 [anchor $id $name]]\n[para_open]"
+}
+
+# Para breaks inside and outside of lists are identical
+proc fmt_nl {} {para_open}
+proc fmt_para {} {para_open}
+
+c_pass 2 fmt_require {pkg {version {}}} NOP
+c_pass 1 fmt_require {pkg {version {}}} {
+ if {$version != {}} { append pkg " " $version }
+ c_hold require [tag_ li "package require [bold $pkg pkgname]"]
+ return
+}
+
+c_pass 2 fmt_usage {cmd args} NOP
+c_pass 1 fmt_usage {cmd args} {
+ if {[llength $args]} {
+ set text "$cmd [join $args " "]"
+ } else {
+ set text $cmd
+ }
+ c_hold synopsis [tag_ li $text]
+ return
+}
+
+c_pass 1 fmt_call {cmd args} {
+ if {[llength $args]} {
+ set text "$cmd [join $args " "]"
+ } else {
+ set text $cmd
+ }
+ c_hold synopsis [tag_ li [link $text "#[c_cnext]"]]
+ return
+}
+c_pass 2 fmt_call {cmd args} {
+ if {[llength $args]} {
+ set text "$cmd [join $args " "]"
+ } else {
+ set text $cmd
+ }
+ return [fmt_lst_item [anchor [c_cnext] $text]]
+}
+
+c_pass 1 fmt_description {did} NOP
+c_pass 2 fmt_description {did} {
+ set result ""
+ set syn [c_held synopsis]
+ set req [c_held require]
+
+ # Create the TOC.
+
+ # Pass 1: We have a number of special sections which were not
+ # listed explicitly in the document sources. Add them
+ # now. Note the inverse order for the sections added
+ # at the beginning.
+
+ c_newSection Description 1 0 $did
+ if {$syn != {} || $req != {}} {c_newSection Synopsis 1 0 synopsis}
+ c_newSection {Table Of Contents} 1 0 toc
+
+ if {[llength [c_xref_seealso]] > 0} {c_newSection {See Also} 1 end see-also}
+ if {[llength [c_xref_keywords]] > 0} {c_newSection Keywords 1 end keywords}
+ if {[c_xref_category] ne ""} {c_newSection Category 1 end category}
+ if {[c_get_copyright] != {}} {c_newSection Copyright 1 end copyright}
+
+ set sections $::SectionList
+
+ # Pass 2: Generate the markup for the TOC, indenting the
+ # links according to the level of each section.
+
+ append result [fmt_section {Table Of Contents} toc] [para_close] \n
+ append result [taga ul {class doctools_toc}] \n
+
+ set lastlevel 1
+ set close 0
+ foreach {name id level} $sections {
+ # level in {1,2}, 1 = sectio n, 2 = subsection
+ if {$level == $lastlevel} {
+ # Close previous item.
+ if {$close} { append result [tag/ li] \n }
+ } elseif {$level > $lastlevel} {
+ # Start list of subsections
+ append result \n [tag ul] \n
+ } else { # level < lastlevel
+ # End list of subsections, and of previous item (two
+ # actually, the subsection, and the section item).
+ append result [tag/ li] \n [tag/ ul] \n [tag/ li] \n
+ }
+ # Start entry
+ if {$level == 1} {
+ append result [taga li {class doctools_section}]
+ } else {
+ append result [taga li {class doctools_subsection}]
+ }
+ append result [link $name "#$id"]
+ set close 1
+
+ set lastlevel $level
+ }
+ if {$lastlevel > 1 } { append result [tag/ ul] \n }
+ if {$close} { append result [tag/ li] \n }
+
+ append result [tag/ ul] \n
+
+ # Implicit sections coming after the TOC (Synopsis, then the
+ # description which starts the actual document). The other
+ # implict sections are added at the end of the document and
+ # are generated by 'fmt_manpage_end' in the second pass.
+
+ if {$syn != {} || $req != {}} {
+ append result [fmt_section Synopsis synopsis] [para_close] [taga div {class doctools_synopsis}] \n
+ if {$req != {}} {
+ append result [tag_ ul \n$req\n class doctools_requirements] \n
+ }
+ if {$syn != {}} {
+ append result [tag_ ul \n$syn\n class doctools_syntax] \n
+ }
+ append result [tag/ div] \n
+ }
+ append result [fmt_section Description $did] \n
+ return $result
+}
+
+################################################################
+
+proc fmt_list_begin {what {hint {}}} {
+ # NOTE: The hint is ignored. Use stylesheet definitions to modify
+ # item and general list spacing.
+ switch -exact -- $what {
+ enumerated {set tag ol}
+ itemized {set tag ul}
+ arguments -
+ commands -
+ options -
+ tkoptions -
+ definitions {set tag dl}
+ }
+ return [para_close][lpush $tag doctools_$what]
+}
+
+proc fmt_list_end {} {
+ set res [para_close][litc_getandclear]\n[lpop][para_open]
+ return $res
+}
+proc fmt_lst_item {text} {
+ set res [para_close][litc_getandclear]\n[tag_ dt $text]\n[tag dd][para_open]
+ litc_set [tag/ dd]
+ return $res
+}
+proc fmt_bullet {} {
+ set res [para_close][litc_getandclear]\n[tag li][para_open]
+ litc_set [tag/ li]
+ return $res
+}
+proc fmt_enum {} {
+ set res [para_close][litc_getandclear]\n[tag li][para_open]
+ litc_set [tag/ li]
+ return $res
+}
+
+proc fmt_cmd_def {command} {
+ fmt_lst_item [fmt_cmd $command]
+}
+proc fmt_arg_def {type name {mode {}}} {
+ set text ""
+ append text $type " " [fmt_arg $name]
+ if {$mode != {}} {
+ append text " (" $mode ")"
+ }
+ fmt_lst_item $text
+}
+proc fmt_opt_def {name {arg {}}} {
+ set text [fmt_option $name]
+ if {$arg != {}} {append text " " $arg}
+ fmt_lst_item $text
+}
+proc fmt_tkoption_def {name dbname dbclass} {
+ set text ""
+ append text "Command-Line Switch:\t[fmt_option $name][tag br]\n"
+ append text "Database Name:\t[bold $dbname optdbname][tag br]\n"
+ append text "Database Class:\t[bold $dbclass optdbclass][tag br]\n"
+ fmt_lst_item $text
+}
+
+################################################################
+
+proc fmt_example_begin {} {
+ return [para_close]\n[tag* pre class doctools_example]
+}
+proc fmt_example_end {} {
+ return [tag/ pre]\n[para_open]
+}
+proc fmt_example {code} {
+ return "[fmt_example_begin][fmt_plain_text $code][fmt_example_end]"
+}
+
+################################################################
+
+proc fmt_arg {text} { italic $text arg }
+proc fmt_cmd {text} { bold [XrefMatch $text sa] cmd }
+proc fmt_emph {text} { em $text }
+proc fmt_opt {text} { span "?$text?" opt }
+
+proc fmt_comment {text} {ht_comment $text}
+proc fmt_sectref {title {id {}}} {
+ global SectionNames
+ if {$id == {}} {
+ set id [c_sectionId $title]
+ }
+ if {[info exists SectionNames($id)]} {
+ return [span [link $title "#$id"] sectref]
+ } else {
+ return [bold $title sectref]
+ }
+}
+
+proc fmt_syscmd {text} {bold [XrefMatch $text sa] syscmd}
+proc fmt_method {text} {bold $text method}
+proc fmt_option {text} {bold $text option}
+proc fmt_widget {text} {bold $text widget}
+proc fmt_fun {text} {bold $text function}
+proc fmt_type {text} {bold $text type}
+proc fmt_package {text} {bold [XrefMatch $text sa kw] package}
+proc fmt_class {text} {bold $text class}
+proc fmt_var {text} {bold $text variable}
+proc fmt_file {text} {return "\"[bold $text file]\""}
+proc fmt_namespace {text} {bold $text namespace}
+proc fmt_uri {text {label {}}} {
+ if {$label == {}} {set label $text}
+ return [link $label $text]
+}
+
+proc fmt_image {text {label {}}} {
+ # text = symbolic name of the image.
+
+ set img [dt_imgdst $text {png gif jpg}]
+
+ if {$label eq {}} {
+ set label $text
+ }
+
+ if {$img ne {}} {
+ return [imagelink $label [LinkTo $img [LinkHere]]]
+ }
+
+ if {[regexp -- {^http://} $text] ||
+ [regexp -- {^ftp://} $text]} {
+ return [imagelink $label $text]
+ }
+
+ #puts_stderr here:\t[LinkHere]
+ #puts_stderr dest:\t$img
+ #puts_stderr rela:\t[LinkTo $img [LinkHere]]
+ #puts_stderr
+
+ return [strong "Image: $label"]
+}
+
+proc fmt_term {text} {italic [XrefMatch $text kw sa] term}
+proc fmt_const {text} {bold $text const}
+
+proc fmt_mdash {} { return "[markup &]mdash;" }
+proc fmt_ndash {} { return "[markup &]ndash;" }
+
+################################################################
+
+global sec_is_open
+set sec_is_open 0
+
+proc sec_open {id} {
+ global sec_is_open
+ set res [para_close][subsec_close][sec_close][tag* div id $id class doctools_section]
+ set sec_is_open 1
+ return $res
+}
+
+proc sec_close {} {
+ global sec_is_open
+ if {!$sec_is_open} {return ""}
+ set sec_is_open 0
+ return [tag/ div]\n
+}
+
+################################################################
+
+global subsec_is_open
+set subsec_is_open 0
+
+proc subsec_open {id} {
+ global subsec_is_open
+ set res [para_close][subsec_close][tag* div id $id class doctools_subsection]
+ set subsec_is_open 1
+ return $res
+}
+
+proc subsec_close {} {
+ global subsec_is_open
+ if {!$subsec_is_open} {return ""}
+ set subsec_is_open 0
+ return [tag/ div]\n
+}
+
+################################################################
+
+# Piece of html to close the previous list element, if any.
+# Saved on the list stack
+
+global prev_litem_close
+set prev_litem_close {}
+
+proc litc_getandclear {} {
+ global prev_litem_close
+ set res $prev_litem_close
+ set prev_litem_close {}
+ return $res
+}
+
+proc litc_set {value} {
+ global prev_litem_close
+ set prev_litem_close $value
+ return
+}
+
+################################################################
+
+global para_is_open
+set para_is_open 0
+
+proc para_open {} {
+ global para_is_open
+ set res [para_close][tag p]
+ set para_is_open 1
+ return $res
+}
+
+proc para_close {} {
+ global para_is_open
+ if {!$para_is_open} {return ""}
+ set para_is_open 0
+ return [tag/ p]
+}
+
+################################################################
+
+global xref ; array set xref {}
+
+global __var
+array set __var {
+ meta {}
+ header {}
+ footer {}
+ xref {}
+ raw 0
+}
+proc Get {varname} {global __var ; return $__var($varname)}
+proc fmt_listvariables {} {global __var ; return [array names __var]}
+proc fmt_varset {varname text} {
+ global __var
+ if {![info exists __var($varname)]} {return -code error "Unknown engine variable \"$varname\""}
+ set __var($varname) $text
+ return
+}
+
+# Engine parameter handling
+proc Extend {v _ by args} {
+ set html [Get $by]
+ if {$html == {}} { return 0 }
+ upvar 1 $v text
+ if {[llength $args]} {
+ set html [string map $args $html]
+ }
+ append text [markup $html] \n
+ return 1
+}
+
+global defaultstyle
+set defaultstyle {
+ HTML {
+ background: #FFFFFF;
+ color: black;
+ }
+ BODY {
+ background: #FFFFFF;
+ color: black;
+ }
+ DIV.doctools {
+ margin-left: 10%;
+ margin-right: 10%;
+ }
+ DIV.doctools H1,DIV.doctools H2 {
+ margin-left: -5%;
+ }
+ H1, H2, H3, H4 {
+ margin-top: 1em;
+ font-family: sans-serif;
+ font-size: large;
+ color: #005A9C;
+ background: transparent;
+ text-align: left;
+ }
+ H1.doctools_title {
+ text-align: center;
+ }
+ UL,OL {
+ margin-right: 0em;
+ margin-top: 3pt;
+ margin-bottom: 3pt;
+ }
+ UL LI {
+ list-style: disc;
+ }
+ OL LI {
+ list-style: decimal;
+ }
+ DT {
+ padding-top: 1ex;
+ }
+ UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL {
+ font: normal 12pt/14pt sans-serif;
+ list-style: none;
+ }
+ LI.doctools_section, LI.doctools_subsection {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ PRE {
+ display: block;
+ font-family: monospace;
+ white-space: pre;
+ margin: 0%;
+ padding-top: 0.5ex;
+ padding-bottom: 0.5ex;
+ padding-left: 1ex;
+ padding-right: 1ex;
+ width: 100%;
+ }
+ PRE.doctools_example {
+ color: black;
+ background: #f5dcb3;
+ border: 1px solid black;
+ }
+ UL.doctools_requirements LI, UL.doctools_syntax LI {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ DIV.doctools_synopsis {
+ color: black;
+ background: #80ffff;
+ border: 1px solid black;
+ font-family: serif;
+ margin-top: 1em;
+ margin-bottom: 1em;
+ }
+ UL.doctools_syntax {
+ margin-top: 1em;
+ border-top: 1px solid black;
+ }
+ UL.doctools_requirements {
+ margin-bottom: 1em;
+ border-bottom: 1px solid black;
+ }
+}
+
+################################################################
+
+proc XrefInit {} {
+ global xref __var
+ foreach item $__var(xref) {
+ foreach {pattern fname fragment} $item break
+ set fname_ref [dt_fmap $fname]
+ if {$fragment != {}} {append fname_ref #$fragment}
+ set xref($pattern) $fname_ref
+ }
+ proc XrefInit {} {}
+ return
+}
+
+proc XrefMatch {word args} {
+ global xref
+
+ foreach ext $args {
+ if {$ext != {}} {
+ if {[info exists xref($ext,$word)]} {
+ return [XrefLink $xref($ext,$word) $word]
+ }
+ }
+ }
+ if {[info exists xref($word)]} {
+ return [XrefLink $xref($word) $word]
+ }
+
+ # Convert the word to all-lower case and then try again.
+
+ set lword [string tolower $word]
+
+ foreach ext $args {
+ if {$ext != {}} {
+ if {[info exists xref($ext,$lword)]} {
+ return [XrefLink $xref($ext,$lword) $word]
+ }
+ }
+ }
+ if {[info exists xref($lword)]} {
+ return [XrefLink $xref($lword) $word]
+ }
+
+ return $word
+}
+
+proc XrefList {list {ext {}}} {
+ set res [list]
+ foreach w $list {lappend res [XrefMatch $w $ext]}
+ return $res
+}
+
+proc LinkHere {} {
+ return [dt_fmap [dt_mainfile]]
+}
+
+proc LinkTo {dest here} {
+ # Ensure that the link is properly done relative to this file!
+
+ set save $dest
+
+ #puts_stderr "XrefLink $dest $label"
+
+ set here [file split $here]
+ set dest [file split $dest]
+
+ #puts_stderr "XrefLink < $here"
+ #puts_stderr "XrefLink > $dest"
+
+ while {[string equal [lindex $dest 0] [lindex $here 0]]} {
+ set dest [lrange $dest 1 end]
+ set here [lrange $here 1 end]
+ if {[llength $dest] == 0} {break}
+ }
+ set ul [llength $dest]
+ set hl [llength $here]
+
+ if {$ul == 0} {
+ set dest [lindex [file split $save] end]
+ } else {
+ while {$hl > 1} {
+ set dest [linsert $dest 0 ..]
+ incr hl -1
+ }
+ set dest [eval file join $dest]
+ }
+
+ #puts_stderr "XrefLink --> $dest"
+ return $dest
+}
+
+proc XrefLink {dest label} {
+ # Ensure that the link is properly done relative to this file!
+
+ set here [LinkHere]
+ set dest [LinkTo $dest $here]
+
+ if {[string equal $dest [lindex [file split $here] end]]} {
+ # Suppress self-referential links, i.e. links made from the
+ # current file to itself. Note that links to specific parts of
+ # the current file are not suppressed, only exact links.
+ return $label
+ }
+ return [link $label $dest]
+}
diff --git a/tcllib/modules/doctools/mpformats/fmt.latex b/tcllib/modules/doctools/mpformats/fmt.latex
new file mode 100644
index 0000000..c0cbe68
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/fmt.latex
@@ -0,0 +1,404 @@
+# -*- tcl -*-
+#
+# fmt.latex
+#
+# (c) 2001 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# [mpexpand] definitions to convert a tcl based manpage definition into
+# a manpage based upon LaTeX markup.
+#
+################################################################
+
+##
+## This engine needs a rewrite for a better handling
+## of characters special to TeX / LaTeX.
+##
+
+dt_source _common.tcl ; # Shared code
+
+global _in_example
+set _in_example 0
+
+global _has_images
+set _has_images 0
+
+# Called to handle plain text from the input
+proc fmt_plain_text {text} {
+ global _in_example
+ if {$_in_example} {
+ return $text
+ }
+ return [texEscape $text]
+}
+
+proc Year {} {clock format [clock seconds] -format %Y}
+
+c_holdBuffers require
+
+proc fmt_postprocess {text} {
+ regsub -all -- "\n+" $text "\n" text
+ return [string map {\1\\ \\ \1$ $} $text]
+ #return $text
+}
+
+################################################################
+## Backend for LaTeX markup
+
+c_pass 1 fmt_manpage_begin {title section version} NOP
+c_pass 2 fmt_manpage_begin {title section version} {
+ global _has_images
+
+ set module [dt_module]
+ set shortdesc [c_get_module]
+ set description [c_get_title]
+ set copyright [c_get_copyright]
+
+ set hdr ""
+ append hdr [Comment [c_provenance]] \n
+ if {$copyright != {}} {
+ append hdr [Comment $copyright] \n
+ }
+ append hdr [Comment "CVS: \$Id\$ $title.$section"] \n
+ append hdr \n
+ append hdr "\1\\documentclass\{article\}" \n
+
+ if {$_has_images} {
+ append hdr "\1\\usepackage{epsfig}" \n
+ append hdr "\1\\usepackage{epstopdf}" \n
+ }
+
+ append hdr "\1\\begin\{document\}" \n
+ append hdr "\1\\author\{[dt_user]\}" \n
+
+ set titletext ""
+ append titletext "$module / $title -- "
+ append titletext "$shortdesc : $description"
+
+ append hdr "\1\\title\{[texEscape $titletext]\}" \n
+ append hdr "\1\\maketitle" \n
+ return $hdr
+}
+
+c_pass 1 fmt_moddesc {desc} {c_set_module $desc}
+c_pass 2 fmt_moddesc {desc} NOP
+
+c_pass 1 fmt_titledesc {desc} {c_set_title $desc}
+c_pass 2 fmt_titledesc {desc} NOP
+
+c_pass 1 fmt_copyright {desc} {c_set_copyright [texEscape $desc]}
+c_pass 2 fmt_copyright {desc} NOP
+
+c_pass 1 fmt_manpage_end {} NOP
+c_pass 2 fmt_manpage_end {} {
+ set res ""
+
+ set sa [c_xref_seealso]
+ set kw [c_xref_keywords]
+ set ca [c_xref_category]
+ set ct [c_get_copyright]
+
+ if {[llength $sa] > 0} {
+ set tmp {}
+ foreach x $sa {lappend tmp [texEscape $x]}
+ set sa $tmp
+
+ append res [fmt_section {See Also} see-also] \n
+ append res [join [lsort $sa] ", "] \n
+ }
+ if {[llength $kw] > 0} {
+ set tmp {}
+ foreach x $kw {lappend tmp [texEscape $x]}
+ set kw $tmp
+
+ append res [fmt_section Keywords keywords] \n
+ append res [join [lsort $kw] ", "] \n
+ }
+ if {$ca ne ""} {
+ set ca [texEscape $ca]
+
+ append res [fmt_section Category category] \n
+ append res $ca \n
+ }
+ if {$ct != {}} {
+ append res [fmt_section Copyright copyright] \n
+ append res \1\\begin\{flushleft\} \n
+ append res [join [split $ct \n] \1\\linebreak\n] \1\\linebreak\n
+ append res \1\\end\{flushleft\} \n
+ }
+ append res "\1\\end\{document\}"
+ return $res
+}
+
+proc fmt_section {name id} {return "\1\\section\{[texEscape $name]\}\1\\label\{$id\}"}
+proc fmt_subsection {name id} {return "\1\\subsection\{[texEscape $name]\}\1\\label\{$id\}"}
+proc fmt_para {} {return \n\n}
+
+c_pass 2 fmt_require {pkg {version {}}} NOP
+c_pass 1 fmt_require {pkg {version {}}} {
+ if {$version != {}} {
+ set res "package require [Bold "$pkg $version"]\n"
+ } else {
+ set res "package require [Bold $pkg]\n"
+ }
+ c_hold require $res
+ return
+}
+
+c_pass 2 fmt_usage {cmd args} NOP
+c_pass 1 fmt_usage {cmd args} {c_hold synopsis "\1\\item\[\] $cmd [join $args " "]"}
+
+c_pass 2 fmt_call {cmd args} {return "[fmt_lst_item "$cmd [join $args " "]"]"}
+c_pass 1 fmt_call {cmd args} {c_hold synopsis "\1\\item\[\] $cmd [join $args " "]"}
+
+c_pass 1 fmt_description {id} NOP
+c_pass 2 fmt_description {id} {
+ set res ""
+ set req [c_held require]
+ set syn [c_held synopsis]
+ if {$req != {} || $syn != {}} {
+ append res [fmt_section Synopsis synopsis]\n
+ if {$req != {}} {
+ append res \1\\begin\{flushleft\} \n
+ append res $req \n
+ append res \1\\end\{flushleft\} \n
+ }
+ if {$syn != {}} {
+ append res "\1\\begin\{itemize\}" \n
+ append res ${syn} \n\n
+ append res "\1\\end\{itemize\}" \n
+ }
+ }
+ append res [fmt_section Description $id]
+ return $res
+}
+
+################################################################
+
+global list_state
+array set list_state {level -1}
+
+proc fmt_list_begin {what {hint {}}} {
+ # ignoring hints
+ global list_state
+ incr list_state(level)
+ set list_state(l,$list_state(level)) $what
+ set list_state(l,$list_state(level),item) 0
+
+ switch -exact -- $what {
+ enumerated {
+ return \1\\begin\{enumerate\}
+ }
+ itemized -
+ arguments -
+ options -
+ commands -
+ tkoptions -
+ definitions {
+ return \1\\begin\{itemize\}
+ }
+ default {
+ return -code error "Must not happen"
+ }
+ }
+}
+
+proc fmt_list_end {} {
+ global list_state
+
+ set what $list_state(l,$list_state(level))
+ set item $list_state(l,$list_state(level),item)
+
+ catch {unset list_state(l,$list_state(level))}
+ catch {unset list_state(l,$list_state(level),item)}
+
+ incr list_state(level) -1
+
+ switch -exact -- $what {
+ enumerated {
+ return \1\\end\{enumerate\}
+ }
+ itemized -
+ arguments -
+ options -
+ commands -
+ tkoptions -
+ definitions {
+ return \1\\end\{itemize\}
+ }
+ default {
+ return -code error "Must not happen"
+ }
+ }
+}
+
+proc fmt_bullet {} {return "\n%\n\1\\item\n%\n"}
+proc fmt_enum {} {return "\n%\n\1\\item\n%\n"}
+
+proc fmt_lst_item {text} {
+ global list_state
+
+ set item $list_state(l,$list_state(level),item)
+ set list_state(l,$list_state(level),item) 1
+
+ set text [texEscape $text]
+ return "\n%\n\1\\item\[\] $text\n%\n"
+}
+
+proc fmt_arg_def {type name {mode {}}} {
+ global list_state
+
+ set item $list_state(l,$list_state(level),item)
+ set list_state(l,$list_state(level),item) 1
+
+ set text ""
+ append text [fmt_arg $name]
+ append text " $type"
+ if {$mode != {}} {append text " ($mode)"}
+ return "\n%\n\1\\item\[\] $text\n%\n"
+}
+
+proc fmt_cmd_def {command} {
+ global list_state
+
+ set item $list_state(l,$list_state(level),item)
+ set list_state(l,$list_state(level),item) 1
+
+ set text [fmt_cmd $command]
+ return "\n%\n\1\\item\[\] $text\n%\n"
+}
+
+proc fmt_opt_def {name {arg {}}} {
+ global list_state
+
+ set item $list_state(l,$list_state(level),item)
+ set list_state(l,$list_state(level),item) 1
+
+ set text [fmt_option $name]
+ if {$arg != {}} {append text " $arg"}
+ return "\n%\n\1\\item\[\] $text\n%\n"
+}
+
+proc fmt_tkoption_def {name dbname dbclass} {
+ global list_state
+
+ set item $list_state(l,$list_state(level),item)
+ set list_state(l,$list_state(level),item) 1
+
+ set text ""
+ append text "Command-Line Switch: [Bold $name]\\\\\n"
+ append text "Database Name: [Bold $dbname]\\\\\n"
+ append text "Database Class: [Bold $dbclass]\\\\\n"
+ return "\n%\n\1\\item\[\] $text\n%\n"
+}
+
+################################################################
+
+proc fmt_example_begin {} {
+ global _in_example
+ set _in_example 1
+ return {\begin{verbatim}}
+}
+proc fmt_example_end {} {
+ global _in_example
+ set _in_example 0
+ return {\end{verbatim}}
+}
+# No mapping of special characters
+proc fmt_example {code} { return "\1\\begin\{verbatim\}\n${code}\n\1\\end\{verbatim\}\n" }
+
+proc fmt_nl {} {return}
+proc fmt_arg {text} {Underline $text}
+proc fmt_cmd {text} {Bold $text}
+proc fmt_emph {text} {Italic $text}
+proc fmt_opt {text} {return ?$text?}
+
+proc fmt_comment {text} {
+ set res [list]
+ foreach l [split $text \n] {
+ lappend res [Comment $l]
+ }
+ return [join $res \n]
+}
+proc fmt_sectref {text {label {}}} {
+ if {![string length $label]} {set label $text}
+ Bold "$text (\1\\ref\{$label\})"
+}
+proc fmt_syscmd {text} {Bold $text}
+proc fmt_method {text} {Bold $text}
+proc fmt_option {text} {Bold $text}
+proc fmt_widget {text} {Bold $text}
+proc fmt_fun {text} {Bold $text}
+proc fmt_type {text} {Bold $text}
+proc fmt_package {text} {Bold $text}
+proc fmt_class {text} {Bold $text}
+proc fmt_var {text} {Bold $text}
+proc fmt_file {text} {return "\"[Italic $text]\""}
+proc fmt_namespace {text} {Bold $text]}
+proc fmt_uri {text {label {}}} {
+ if {$label == {}} {
+ # Without label we use the link directly as part of the text.
+ return [Underline $text]
+ } else {
+ # Label is used in the text, refered link is delegated into a
+ # footnote.
+ return "[Underline $label] \1\\footnote\{[texEscape $text]\}"
+ }
+}
+proc fmt_image {text {label {}}} {
+ global _has_images
+ # text = symbolic name of the image.
+
+ set img [dt_imgsrc $text {eps ps}]
+ if {$img eq {}} {
+ if {$label eq {}} {
+ return [Underline "IMAGE: $text"]
+ } else {
+ return [Underline "IMAGE: $text $label"]
+ }
+ }
+
+ set _has_images 1
+
+ return "\1\\begin{figure}\[htp\]\1\\includegraphics\[width=0.9\1\\textwidth\]{$img}\1\\end{figure}"
+}
+proc fmt_term {text} {Italic $text}
+proc fmt_const {text} {Bold $text}
+proc fmt_mdash {} { return " --- " }
+proc fmt_ndash {} { return " -- " }
+
+################################################################
+# latex specific commands
+
+proc Comment {text} {return "% [join [split $text \n] "\n% "]"}
+proc Bold {text} {return "\{\1\\bf [texEscape $text]\}"}
+proc Italic {text} {return "\{\1\\it [texEscape $text]\}"}
+proc Underline {text} {return "\1\\underline\{[texEscape $text]\}"}
+
+################################################################
+
+proc texEscape {text} {
+ set x 0
+ if {[string match *%* $text]} {
+ #puts_stderr '$text'
+ set x 1
+ }
+
+ # Important: \1 protected sequences are left unchanged, they are already escaped.
+ set text [string map {
+ \1$\\backslash$ \1$\\backslash$ \1$<$ \1$<$ \1$>$ \1$>$
+ \1\\_ \1\\_
+ \1\\% \1\\%
+ \1\\^ \1\\^
+ \1\\$ \1\\$
+ \1\\# \1\\#
+ \1\\& \1\\&
+ \1\\ \1\\
+ \\ \1$\\backslash$ _ \1\\_ % \1\\% ^ \1\\^ $ \1\\$ < \1$<$ > \1$>$ # \1\\# & \1\\&
+ } $text]
+ if {$x} {
+ #puts_stderr "==> '$text'"
+ }
+ return $text
+}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/fmt.list b/tcllib/modules/doctools/mpformats/fmt.list
new file mode 100644
index 0000000..15ed7f9
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/fmt.list
@@ -0,0 +1,52 @@
+# -*- tcl -*-
+#
+# -- Extraction of basic meta information (title section version) from a manpage.
+#
+# Copyright (c) 2001-2002 Andreas Kupries <andreas_kupries@sourceforge.net>
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+################################################################
+
+# Take the null format as a base and extend it a bit.
+dt_source fmt.null
+
+global data
+array set data {}
+
+proc fmt_numpasses {} {return 1}
+proc fmt_postprocess {text} {
+ global data
+ foreach key {seealso keywords} {
+ array set _ {}
+ foreach ref $data($key) {set _($ref) .}
+ set data($key) [array names _]
+ unset _
+ }
+ return [list manpage [array get data]]\n
+}
+proc fmt_plain_text {text} {return ""}
+proc fmt_setup {n} {return}
+
+proc fmt_manpage_begin {title section version} {
+ global data
+ set data(title) $title
+ set data(section) $section
+ set data(version) $version
+ set data(file) [dt_file]
+ set data(fid) [dt_fileid]
+ set data(module) [dt_module]
+ set data(desc) ""
+ set data(shortdesc) ""
+ set data(keywords) [list]
+ set data(seealso) [list]
+ set data(category) ""
+ return
+}
+
+proc fmt_moddesc {desc} {global data ; set data(shortdesc) $desc}
+proc fmt_titledesc {desc} {global data ; set data(desc) $desc}
+proc fmt_keywords {args} {global data ; foreach ref $args {lappend data(keywords) $ref} ; return}
+proc fmt_see_also {args} {global data ; foreach ref $args {lappend data(seealso) $ref} ; return}
+proc fmt_category {text} {global data ; set data(category) $text ; return}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/fmt.nroff b/tcllib/modules/doctools/mpformats/fmt.nroff
new file mode 100644
index 0000000..0988255
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/fmt.nroff
@@ -0,0 +1,290 @@
+# -*- tcl -*-
+#
+# -- doctools NROFF formatting engine.
+#
+# Copyright (c) 2001-2011 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# [expand] definitions to convert a tcl based manpage definition into
+# a manpage based upon *roff markup. Additional definition files allow
+# the conversion into HTML and TMML.
+
+
+################################################################
+# Load shared code, load nroff support.
+
+dt_source _common.tcl
+dt_source _nroff.tcl
+
+################################################################
+# Define the API commands.
+
+c_pass 1 fmt_manpage_begin {title section version} c_begin
+c_pass 2 fmt_manpage_begin {title section version} {
+ c_begin
+
+ set module [dt_module]
+ set shortdesc [c_get_module]
+ set description [c_get_title]
+ set copyright [c_get_copyright]
+
+ # compact whitespace
+ foreach v {module shortdesc description copyright} {
+ upvar 0 $v text
+ regsub -all {[ \t]+} $text { } text
+ set text [string trim $text]
+ }
+
+ c_holdBuffers hdr
+
+ c_hold hdr [nr_comment {}]
+ c_hold hdr [nr_comment [c_provenance]]
+ if {$copyright != {}} {
+ c_hold hdr [nr_comment $copyright]
+ }
+ c_hold hdr [nr_comment {}]
+
+ if {[set text [c_held precomments]] != {}} {
+ c_hold hdr $text
+ }
+
+ c_hold hdr [nr_title "\"[string trimleft $title :]\" $section $version $module \"$shortdesc\""]
+ c_hold hdr [nr_read man.macros]
+ c_hold hdr [nr_bolds]
+ c_hold hdr [fmt_section NAME]
+ c_hold hdr "$title \1\\- $description"
+
+ return [c_held hdr]
+}
+
+c_pass 1 fmt_moddesc {desc} {c_set_module $desc}
+c_pass 2 fmt_moddesc {desc} NOP
+
+c_pass 1 fmt_titledesc {desc} {c_set_title $desc}
+c_pass 2 fmt_titledesc {desc} NOP
+
+c_pass 1 fmt_copyright {desc} {c_set_copyright $desc}
+c_pass 2 fmt_copyright {desc} NOP
+
+c_pass 1 fmt_manpage_end {} NOP
+c_pass 2 fmt_manpage_end {} {
+
+ # Complete the generation with a copyright
+ # section, if such information is available.
+
+ set nroff ""
+
+ set sa [c_xref_seealso]
+ set kw [c_xref_keywords]
+ set ca [c_xref_category]
+ set ct [c_get_copyright]
+
+ if {[llength $sa] > 0} {
+ append nroff [fmt_section {SEE ALSO}] \n
+ append nroff [join [lsort $sa] ", "] \n
+ }
+ if {[llength $kw] > 0} {
+ append nroff [fmt_section KEYWORDS] \n
+ set kwline [join [lsort $kw] ", "]
+ if { [string match ".*" $kwline] } {
+ set kwline "\\$kwline"
+ }
+ append nroff $kwline \n
+ }
+ if {$ca ne ""} {
+ append nroff [fmt_section CATEGORY] \n
+ append nroff $ca \n
+ }
+ if {$ct != {}} {
+ append nroff [fmt_section COPYRIGHT] \n
+ append nroff [nr_nofill] \n
+ append nroff $ct \n
+ append nroff [nr_fill]
+ }
+ return $nroff
+}
+
+proc fmt_postprocess {nroff} {return [nroff_postprocess $nroff]}
+
+proc fmt_section {name {id {}}} {return [nr_section $name]}
+proc fmt_subsection {name {id {}}} {return [nr_subsection $name]}
+proc fmt_para {} {
+ if {[dt_lnesting]} { return [nr_item] }
+ nr_p
+}
+
+c_pass 2 fmt_require {pkg {version {}}} NOP
+c_pass 1 fmt_require {pkg {version {}}} {
+ if {$version != {}} {set version " $version"}
+ c_hold synopsis "package require [nr_bld]$pkg $version[nr_rst]\n[nr_vspace]"
+}
+
+c_pass 1 fmt_usage {cmd args} {c_hold synopsis "$cmd [join $args " "]\n[nr_vspace]"}
+c_pass 2 fmt_usage {cmd args} NOP
+
+c_pass 1 fmt_call {cmd args} {c_hold synopsis "$cmd [join $args " "]\n[nr_vspace]"}
+c_pass 2 fmt_call {cmd args} {return "[fmt_lst_item "$cmd [join $args " "]"]"}
+
+c_pass 1 fmt_description {id} NOP
+c_pass 2 fmt_description {id} {
+ set text ""
+ if {[set syn [c_held synopsis]] != {}} {
+ append text [fmt_section SYNOPSIS]\n
+ append text ${syn}\n
+ append text [nr_bolde]\n
+ }
+ append text [fmt_section DESCRIPTION]
+ return $text
+}
+
+################################################################
+
+global list_state
+array set list_state {level -1}
+
+proc fmt_list_begin {what {hint {}}} {
+ c_cinit
+ if {[dt_lnesting]} { return [nr_in] }
+ return {}
+}
+
+proc fmt_list_end {} {
+ c_creset
+ if {[dt_lnesting]} {
+ return [nr_out][nr_item]
+ } else {
+ return [nr_p]
+ }
+}
+
+proc fmt_enum {} {return [nr_item " \[[c_cnext]\]\n"]}
+proc fmt_bullet {} {return [nr_item " \1\\(bu\n"]}
+proc fmt_lst_item {text} {return [nr_blt $text]\n}
+proc fmt_cmd_def {command} {return [nr_blt [fmt_cmd $command]]\n}
+
+proc fmt_arg_def {type name {mode {}}} {
+ set text [nr_blt ""]
+ append text "$type [fmt_arg $name]"
+ if {$mode != {}} {append text " ($mode)"}
+ return $text\n
+}
+proc fmt_opt_def {name {arg {}}} {
+ #if {[string match -* $name]} {set name \1\\$name}
+ set name [fmt_option $name]
+ if {$arg != {}} {append name " $arg"}
+ return [nr_blt $name]\n
+}
+proc fmt_tkoption_def {name dbname dbclass} {
+ set text ""
+ append text "[nr_lp]\n"
+ append text "[nr_nofill]\n"
+ append text "[nr_ta " 6c"]\n"
+ append text "Command-Line Switch:\t[bold $name]\n"
+ append text "Database Name:\t[bold $dbname]\n"
+ append text "Database Class:\t[bold $dbclass]\n"
+ append text "[nr_fill]\n"
+ append text "[nr_item]\n"
+ return $text
+}
+
+################################################################
+
+proc fmt_example_begin {} {
+ return [nr_cs]\n
+}
+proc fmt_example_end {} {
+ if {[dt_lnesting]} {
+ return [nr_ce][nr_item]
+ }
+ nr_ce
+}
+proc fmt_example {code} {
+ set lines [list "" [nr_cs]]
+ foreach line [split $code "\n"] {
+ lappend lines [fmt_plain_text $line]
+ }
+ lappend lines [nr_ce] ""
+ return [join $lines "\n"]
+}
+
+proc fmt_nl {} {nr_vspace}
+proc fmt_arg {text} {underline $text}
+proc fmt_cmd {text} {bold $text}
+proc fmt_emph {text} {underline $text}
+proc fmt_opt {text} {return ?$text?}
+
+proc bold {text} {
+ # .B don't work in .TP (nr_blt)
+ if {1||[string match *\n* $text]} {
+ return [nr_bld]$text[nr_rst]
+ } else {
+ return [nr_bldt $text]
+ }
+}
+proc underline {text} {
+ return [nr_ul]$text[nr_rst]
+}
+
+proc fmt_comment {text} {
+ set res [list]
+ foreach l [split $text \n] {
+ lappend res [nr_comment $l]
+ }
+ if {[c_begun]} {
+ return [join $res \n]
+ } else {
+ if {[c_inpass] == 1} {
+ c_hold precomments [join $res \n]
+ }
+ return ""
+ }
+}
+proc fmt_sectref {text {label {}}} {
+ if {![string length $label]} {set label $text}
+ bold $text
+}
+proc fmt_syscmd {text} {bold $text}
+proc fmt_method {text} {bold $text}
+proc fmt_option {text} {bold $text}
+proc fmt_widget {text} {bold $text}
+proc fmt_fun {text} {bold $text}
+proc fmt_type {text} {bold $text}
+proc fmt_package {text} {bold $text}
+proc fmt_class {text} {bold $text}
+proc fmt_var {text} {bold $text}
+proc fmt_file {text} {return "\"[underline $text]\""}
+proc fmt_namespace {text} {bold $text}
+proc fmt_uri {text {label {}}} {
+ if {$label == {}} {
+ # Without label we use the link directly as part of the text.
+ return [underline $text]
+ } else {
+ # with label and link we use the label directly, and the
+ # link comes in parentheses after that.
+
+ return "[underline $label] \[$text\]"
+ }
+}
+proc fmt_image {text {label {}}} {
+ # text = symbolic name of the image.
+
+ set img [dt_imgdata $text {pic}]
+ if {$img ne {}} {
+ return \n\1.PS\n$img\n\1.PE\n
+ }
+ set img [dt_imgdata $text {txt}]
+ if {$img ne {}} {
+ return \n\1.PS\n\1.nf\n$img\n\1.fi\n\1.PE\n
+ }
+ if {$label eq {}} {
+ return "IMAGE: $text"
+ } else {
+ return "IMAGE: $text $label"
+ }
+}
+proc fmt_term {text} {underline $text}
+proc fmt_const {text} {bold $text}
+
+proc fmt_mdash {} { return " \1\\(em\n" }
+proc fmt_ndash {} { return " \1\\(en\n" }
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/fmt.null b/tcllib/modules/doctools/mpformats/fmt.null
new file mode 100644
index 0000000..1b2eee0
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/fmt.null
@@ -0,0 +1,30 @@
+# -*- tcl -*-
+#
+# -- Null format
+#
+# Copyright (c) 2001-2002 Andreas Kupries <andreas_kupries@sourceforge.net>
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# This is a null format which does return no output at all.
+
+################################################################
+
+proc fmt_initialize {} {return}
+proc fmt_shutdown {} {return}
+proc fmt_numpasses {} {return 1}
+proc fmt_postprocess {text} {return ""}
+proc fmt_plain_text {text} {return ""}
+proc fmt_setup {n} {return}
+
+foreach p {
+ manpage_begin moddesc titledesc manpage_end require description
+ section para list_begin list_end lst_item call usage bullet enum
+ arg_def cmd_def opt_def tkoption_def see_also keywords example
+ example_begin example_end nl arg cmd opt emph comment image mdash
+ sectref syscmd method option widget fun type package class var
+ file uri term const copyright namespace subsection category ndash
+} {
+ proc fmt_$p {args} {return ""}
+}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/fmt.text b/tcllib/modules/doctools/mpformats/fmt.text
new file mode 100644
index 0000000..27eec2e
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/fmt.text
@@ -0,0 +1,473 @@
+# -*- tcl -*-
+#
+# fmt.text -- Engine to convert a doctools document into plain text.
+#
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+################################################################
+################################################################
+
+# Load shared code and modify it to our needs.
+
+dt_source _common.tcl
+dt_source _text.tcl
+proc c_copyrightsymbol {} {return "(c)"}
+
+rename fmt_initialize BaseInitialize
+proc fmt_initialize {} {BaseInitialize ; TextInitialize ; return}
+
+################################################################
+# Special manpage environments
+
+proc NewExample {} {
+ global currentEnv
+ return [NewEnv Example {
+ set currentEnv(verbatim) 1
+ append currentEnv(prefix) "| "
+ set currentEnv(example) .
+ }] ; # {}
+}
+
+proc Example {} {
+ global currentEnv
+ if {![info exists currentEnv(exenv)]} {
+ SaveContext
+ set verb [NewExample]
+ RestoreContext
+
+ # Remember verbatim mode in the base environment
+ set currentEnv(exenv) $verb
+ SaveEnv
+ }
+ return $currentEnv(exenv)
+}
+
+proc NewList {what} {
+ # List environments
+ # Per list several environments are required.
+
+ switch -exact -- $what {
+ enumerated {NewOrderedList}
+ itemized {NewUnorderedList}
+ arguments -
+ commands -
+ options -
+ tkoptions -
+ definitions {NewDefinitionList}
+ }
+}
+
+proc NewUnorderedList {} {
+ global currentEnv lmarginIncrement
+
+ # Itemized list - unordered list - bullet
+ # 1. Base environment provides indentation.
+ # 2. First paragraph in a list item.
+ # 3. All other paragraphs.
+
+ set base [NewEnv Itemized {
+ incr currentEnv(lmargin) $lmarginIncrement
+
+ set bullet [Bullet currentEnv(bulleting)]
+ }] ; # {}
+ set first [NewEnv First {
+ set currentEnv(wspfx) [::textutil::repeat::blank $lmarginIncrement]
+ set currentEnv(listtype) bullet
+ set currentEnv(bullet) $bullet
+ }] ; SetContext $base ; # {}
+
+ set next [NewEnv Next {
+ incr currentEnv(lmargin) $lmarginIncrement
+ }] ; SetContext $base ; # {}
+
+ set currentEnv(_first) $first
+ set currentEnv(_next) $next
+ set currentEnv(pcount) 0
+ SaveEnv
+ return
+}
+
+proc NewOrderedList {} {
+ global currentEnv lmarginIncrement
+
+ # Ordered list - enumeration - enum
+ # 1. Base environment provides indentation.
+ # 2. First paragraph in a list item.
+ # 3. All other paragraphs.
+
+ set base [NewEnv Enumerated {
+ incr currentEnv(lmargin) $lmarginIncrement
+
+ set bullet [EnumBullet currentEnv(enumeration)]
+ }] ; # {}
+ set first [NewEnv First {
+ set currentEnv(wspfx) [::textutil::repeat::blank $lmarginIncrement]
+ set currentEnv(listtype) enum
+ set currentEnv(bullet) $bullet
+ }] ; SetContext $base ; # {}
+
+ set next [NewEnv Next {
+ incr currentEnv(lmargin) $lmarginIncrement
+ }] ; SetContext $base ; # {}
+
+ set currentEnv(_first) $first
+ set currentEnv(_next) $next
+ set currentEnv(pcount) 0
+ SaveEnv
+ return
+}
+
+proc NewDefinitionList {} {
+ global currentEnv lmarginIncrement
+
+ # Definition list - terms & definitions
+ # 1. Base environment provides indentation.
+ # 2. Term environment
+ # 3. Definition environment
+
+ set base [NewEnv DefL {
+ incr currentEnv(lmargin) $lmarginIncrement
+ }] ; # {}
+ set term [NewEnv Term {
+ set currentEnv(verbatim) 1
+ }] ; SetContext $base ; # {}
+
+ set def [NewEnv Def {
+ incr currentEnv(lmargin) $lmarginIncrement
+ }] ; SetContext $base ; # {}
+
+ set currentEnv(_term) $term
+ set currentEnv(_definition) $def
+ SaveEnv
+ return
+}
+
+################################################################
+# Final layouting.
+
+c_holdBuffers require
+
+proc fmt_postprocess {text} {text_postprocess $text}
+
+
+################################################################
+# Implementations of the formatting commands.
+
+c_pass 1 fmt_plain_text {text} NOP
+c_pass 2 fmt_plain_text {text} {text_plain_text $text}
+
+c_pass 1 fmt_manpage_begin {title section version} NOP
+c_pass 2 fmt_manpage_begin {title section version} {
+ Off
+ set module [dt_module]
+ set shortdesc [c_get_module]
+ set description [c_get_title]
+ set copyright [c_get_copyright]
+
+ set hdr [list]
+ lappend hdr "$title - $shortdesc"
+ lappend hdr [c_provenance]
+ lappend hdr "[string trimleft $title :]($section) $version $module \"$shortdesc\""
+ set hdr [join $hdr \n]
+
+ Text $hdr
+ CloseParagraph [Verbatim]
+ Section NAME
+ Text "$title - $description"
+ CloseParagraph
+ return
+}
+
+c_pass 1 fmt_moddesc {desc} {c_set_module $desc}
+c_pass 2 fmt_moddesc {desc} NOP
+
+c_pass 1 fmt_titledesc {desc} {c_set_title $desc}
+c_pass 2 fmt_titledesc {desc} NOP
+
+c_pass 1 fmt_copyright {desc} {c_set_copyright $desc}
+c_pass 2 fmt_copyright {desc} NOP
+
+c_pass 1 fmt_manpage_end {} NOP
+c_pass 2 fmt_manpage_end {} {
+ set sa [c_xref_seealso]
+ set kw [c_xref_keywords]
+ set ca [c_xref_category]
+ set ct [c_get_copyright]
+
+ CloseParagraph
+ if {[llength $sa] > 0} {Section {SEE ALSO} ; Text [join [lsort $sa] ", "] ; CloseParagraph}
+ if {[llength $kw] > 0} {Section KEYWORDS ; Text [join [lsort $kw] ", "] ; CloseParagraph}
+ if {$ca ne ""} {Section CATEGORY ; Text $ca ; CloseParagraph}
+ if {$ct != {}} {Section COPYRIGHT ; Text $ct ; CloseParagraph [Verbatim]}
+ return
+}
+
+c_pass 1 fmt_section {name {id {}}} NOP
+c_pass 2 fmt_section {name {id {}}} {CloseParagraph ; Section $name ; return}
+
+c_pass 1 fmt_subsection {name {id {}}} NOP
+c_pass 2 fmt_subsection {name {id {}}} {CloseParagraph ; Subsection $name ; return}
+
+c_pass 1 fmt_para {} NOP
+c_pass 2 fmt_para {} {CloseParagraph ; return}
+
+c_pass 2 fmt_require {pkg {version {}}} NOP
+c_pass 1 fmt_require {pkg {version {}}} {
+ set result "package require $pkg"
+ if {$version != {}} {append result " $version"}
+ c_hold require $result
+ return
+}
+
+c_pass 1 fmt_usage {cmd args} {c_hold synopsis "$cmd [join $args " "]"}
+c_pass 2 fmt_usage {cmd args} NOP
+
+c_pass 1 fmt_call {cmd args} {c_hold synopsis "$cmd [join $args " "]"}
+c_pass 2 fmt_call {cmd args} {fmt_lst_item "$cmd [join $args " "]"}
+
+
+c_pass 1 fmt_description {id} NOP
+c_pass 2 fmt_description {id} {
+ On
+ set syn [c_held synopsis]
+ set req [c_held require]
+
+ if {$syn != {} || $req != {}} {
+ Section SYNOPSIS
+ if {($req != {}) && ($syn != {})} {
+ Text $req\n\n$syn
+ } else {
+ if {$req != {}} {Text $req}
+ if {$syn != {}} {Text $syn}
+ }
+ CloseParagraph [Verbatim]
+ }
+
+ Section DESCRIPTION
+ return
+}
+
+################################################################
+
+c_pass 1 fmt_list_begin {what {hint {}}} NOP
+c_pass 2 fmt_list_begin {what {hint {}}} {
+ #puts_stderr "<<fmt_list_begin $what>>"
+
+ global currentEnv
+ if {[info exists currentEnv(_definition)]} {
+ CloseParagraph $currentEnv(_definition)
+ } elseif {[info exists currentEnv(pcount)]} {
+ if {$currentEnv(pcount) == 0} {CloseParagraph $currentEnv(_first)}
+ if {$currentEnv(pcount) > 0} {CloseParagraph $currentEnv(_next)}
+ incr currentEnv(pcount)
+ } else {
+ CloseParagraph
+ }
+ SaveContext
+ NewList $what
+ Off
+
+ #puts_stderr "<<fmt_list_begin _____>>"
+ return
+}
+
+c_pass 1 fmt_list_end {} NOP
+c_pass 2 fmt_list_end {} {
+ #puts_stderr "<<fmt_list_end>>"
+
+ global currentEnv
+ if {[info exists currentEnv(_definition)]} {
+ CloseParagraph $currentEnv(_definition)
+ } else {
+ if {$currentEnv(pcount) == 0} {CloseParagraph $currentEnv(_first)}
+ if {$currentEnv(pcount) > 0} {CloseParagraph $currentEnv(_next)}
+ }
+ RestoreContext
+
+ #puts_stderr "<<fmt_list_end ____>>"
+ return
+}
+
+c_pass 1 fmt_lst_item {text} NOP
+c_pass 2 fmt_lst_item {text} {
+ global currentEnv
+
+ #puts_stderr "<<fmt_lst_item \{$text\}>>"
+
+ if {[IsOff]} {
+ On
+ } else {
+ CloseParagraph $currentEnv(_definition)
+ }
+ Text $text
+ CloseParagraph $currentEnv(_term)
+
+ #puts_stderr "<<fmt_lst_item _____>>"
+ return
+}
+
+c_pass 1 fmt_bullet {} NOP
+c_pass 2 fmt_bullet {} {
+ global currentEnv
+ if {[IsOff]} {On ; return}
+ if {$currentEnv(pcount) == 0} {CloseParagraph $currentEnv(_first)}
+ if {$currentEnv(pcount) > 0} {CloseParagraph $currentEnv(_next)}
+ set currentEnv(pcount) 0
+ return
+}
+
+c_pass 1 fmt_enum {} NOP
+c_pass 2 fmt_enum {} {
+ global currentEnv
+ if {[IsOff]} {On ; return}
+ if {$currentEnv(pcount) == 0} {CloseParagraph $currentEnv(_first)}
+ if {$currentEnv(pcount) > 0} {CloseParagraph $currentEnv(_next)}
+ set currentEnv(pcount) 0
+ return
+}
+
+c_pass 1 fmt_cmd_def {command} NOP
+c_pass 2 fmt_cmd_def {command} {fmt_lst_item [fmt_cmd $command]}
+
+c_pass 1 fmt_arg_def {type name {mode {}}} NOP
+c_pass 2 fmt_arg_def {type name {mode {}}} {
+ set text "$type [fmt_arg $name]"
+ if {$mode != {}} {append text " ($mode)"}
+ fmt_lst_item $text
+ return
+}
+
+c_pass 1 fmt_opt_def {name {arg {}}} NOP
+c_pass 2 fmt_opt_def {name {arg {}}} {
+ set text [fmt_option $name]
+ if {$arg != {}} {append text " $arg"}
+ fmt_lst_item $text
+ return
+}
+
+c_pass 1 fmt_tkoption_def {name dbname dbclass} NOP
+c_pass 2 fmt_tkoption_def {name dbname dbclass} {
+ set text ""
+ append text "Command-Line Switch:\t[fmt_option $name]\n"
+ append text "Database Name:\t[strong $dbname]\n"
+ append text "Database Class:\t[strong $dbclass]\n"
+ fmt_lst_item $text
+}
+
+################################################################
+
+c_pass 1 fmt_example_begin {} NOP
+c_pass 2 fmt_example_begin {} {
+ global currentEnv para
+ if {[info exists currentEnv(_definition)]} {
+ CloseParagraph $currentEnv(_definition)
+ } elseif {[info exists currentEnv(pcount)]} {
+ if {$para != {}} {
+ if {$currentEnv(pcount) == 0} {CloseParagraph $currentEnv(_first)}
+ if {$currentEnv(pcount) > 0} {CloseParagraph $currentEnv(_next)}
+ incr currentEnv(pcount)
+ }
+ } else {
+ CloseParagraph
+ }
+ return
+}
+
+c_pass 1 fmt_example_end {} NOP
+c_pass 2 fmt_example_end {} {
+ global currentEnv para
+ set penv {}
+ if {[info exists currentEnv(_definition)]} {
+ set penv $currentEnv(_definition)
+ } elseif {[info exists currentEnv(pcount)]} {
+ if {$currentEnv(pcount) == 0} {set penv $currentEnv(_first)}
+ if {$currentEnv(pcount) > 0} {set penv $currentEnv(_next)}
+ incr currentEnv(pcount)
+ }
+ if {$penv != {}} {
+ # Save current list context, get chosen paragraph context and
+ # then create an example context form this. After closing the
+ # paragraph we get back our main list context.
+
+ SaveContext
+ SetContext $penv
+ CloseParagraph [Example]
+ RestoreContext
+ } else {
+ CloseParagraph [Example]
+ }
+ return
+}
+
+c_pass 1 fmt_example {code} NOP
+c_pass 2 fmt_example {code} {
+ fmt_example_begin
+ fmt_plain_text $code
+ fmt_example_end
+ return
+}
+
+c_pass 1 fmt_nl {} NOP
+c_pass 2 fmt_nl {} {
+ global currentEnv
+ if {[info exists currentEnv(_definition)]} {
+ CloseParagraph $currentEnv(_definition)
+ } else {
+ if {$currentEnv(pcount) == 0} {CloseParagraph $currentEnv(_first)}
+ if {$currentEnv(pcount) > 0} {CloseParagraph $currentEnv(_next)}
+ incr currentEnv(pcount)
+ }
+ return
+}
+
+################################################################
+# Visual markup of words and phrases.
+
+proc fmt_arg {text} {return $text}
+proc fmt_cmd {text} {return $text}
+proc fmt_emph {text} {em $text }
+proc fmt_opt {text} {return "?$text?" }
+proc fmt_comment {text} {return}
+proc fmt_sectref {text {label {}}} {
+ if {![string length $label]} {set label $text}
+ return "-> $text"
+}
+proc fmt_syscmd {text} {strong $text}
+proc fmt_method {text} {return $text}
+proc fmt_option {text} {return $text}
+proc fmt_widget {text} {strong $text}
+proc fmt_fun {text} {strong $text}
+proc fmt_type {text} {strong $text}
+proc fmt_package {text} {strong $text}
+proc fmt_class {text} {strong $text}
+proc fmt_var {text} {strong $text}
+proc fmt_file {text} {return "\"$text\""}
+proc fmt_namespace {text} {strong $text}
+proc fmt_uri {text {label {}}} {
+ if {$label == {}} {
+ # Without label we use the link directly as part of the text.
+ return "<URL:$text>"
+ } else {
+ return "[em $label] <URL:$text>"
+ }
+}
+proc fmt_image {text {label {}}} {
+ # text = symbolic name of the image.
+
+ set img [dt_imgdata $text {txt}]
+ if {$img eq {}} {
+ if {$label eq {}} {
+ return "IMAGE: $text"
+ } else {
+ return "IMAGE: $text $label"
+ }
+ }
+
+ return $img
+}
+proc fmt_term {text} {em $text}
+proc fmt_const {text} {strong $text}
+proc fmt_mdash {} { return " --- " }
+proc fmt_ndash {} { return " -- " }
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/fmt.tmml b/tcllib/modules/doctools/mpformats/fmt.tmml
new file mode 100644
index 0000000..522f7c3
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/fmt.tmml
@@ -0,0 +1,288 @@
+# -*- tcl -*-
+#
+# $Id: fmt.tmml,v 1.27 2010/07/06 18:49:15 andreas_kupries Exp $
+#
+# [expand] definitions to convert a tcl based manpage definition
+# into TMML.
+#
+# Copyright (C) 2001 Joe English <jenglish@sourceforge.net>.
+# Freely redistributable.
+#
+# See also <URL: http://tmml.sourceforge.net>
+#
+# BUGS:
+# + Text must be preceded by [para] or one of the
+# list item macros, or else the output will be invalid.
+#
+######################################################################
+
+dt_source _common.tcl
+dt_source _xml.tcl
+
+######################################################################
+# Conversion specification.
+#
+# Two-pass processing. The first pass collects text for the
+# SYNOPSIS, SEE ALSO, and KEYWORDS sections, and the second pass
+# produces output.
+#
+
+c_holdBuffers synopsis see_also keywords
+
+variable block {section dd li desc} ;# block context elements
+
+proc fmt_nl {} { emptyElement br }
+proc fmt_arg {text} { wrap $text m }
+proc fmt_cmd {text} { wrap $text cmd }
+proc fmt_emph {text} { wrap $text emph }
+proc fmt_opt {text} { wrap $text o }
+
+c_pass 1 fmt_example_begin {} NOP
+c_pass 1 fmt_example_end {} NOP
+c_pass 1 fmt_example {code} NOP
+c_pass 2 fmt_example_begin {} { sequence [xmlContext $::block] [start example] }
+c_pass 2 fmt_example_end {} { end example }
+c_pass 2 fmt_example {code} { sequence [xmlContext $::block] [wrap $code example] }
+
+proc fmt_comment {text} {xmlComment $text}
+proc fmt_sectref {text {id {}}} {
+ global SectionNames
+ if {$id == {}} {
+ set id [c_sectionId $text]
+ }
+ if {[info exists SectionNames($id)]} {
+ return "[startTag ref refid $id]$text[endTag ref]"
+ } else {
+ return [wrap $text emph]
+ }
+}
+proc fmt_syscmd {text} {wrap $text syscmd}
+proc fmt_method {text} {wrap $text method}
+proc fmt_option {text} {wrap $text option}
+proc fmt_widget {text} {wrap $text widget}
+proc fmt_fun {text} {wrap $text fun}
+proc fmt_type {text} {wrap $text type}
+proc fmt_package {text} {wrap $text package}
+proc fmt_class {text} {wrap $text class}
+proc fmt_var {text} {wrap $text variable}
+proc fmt_file {text} {wrap $text file}
+proc fmt_namespace {text} {wrap $text term}
+proc fmt_uri {text {label {}}} {
+ # TMML ignores the label
+ wrap $text url
+}
+proc fmt_term {text} {wrap $text term}
+proc fmt_const {text} {wrap $text l}
+
+proc fmt_mdash {} { return "[markup &]mdash;" }
+proc fmt_ndash {} { return "[markup &]ndash;" }
+
+
+c_pass 1 fmt_manpage_begin {args} NOP
+c_pass 2 fmt_manpage_begin {title section version} {
+ set headInfo [list]
+ foreach copyrightLine [split [c_get_copyright] "\n"] {
+ lappend headInfo [emptyElement info key copyright value $copyrightLine]
+ }
+ # ... other metadata here if needed ...
+
+ sequence \
+ [xmlComment [c_provenance]] \
+ [start manpage \
+ id [dt_fileid] \
+ cat cmd \
+ title $title \
+ version $version \
+ package [dt_module]] \
+ [wrapLines? [join $headInfo \n] head] \
+ [start namesection] \
+ [wrap $title name] \
+ [wrap [c_get_title] desc] \
+ [end namesection] \
+ ;
+}
+
+c_pass 1 fmt_moddesc {desc} {c_set_module $desc}
+c_pass 1 fmt_titledesc {desc} {c_set_title $desc}
+c_pass 1 fmt_copyright {desc} {c_set_copyright $desc}
+
+c_pass 2 fmt_moddesc {args} NOP
+c_pass 2 fmt_titledesc {args} NOP
+c_pass 2 fmt_copyright {desc} NOP
+
+c_pass 1 fmt_description {id} NOP
+c_pass 2 fmt_description {id} {
+ sequence \
+ [xmlContext manpage] \
+ [wrapLines? [c_held synopsis] syntax synopsis] \
+ [start section id $id] \
+ [wrap "DESCRIPTION" title] \
+ ;
+}
+
+c_pass 1 fmt_section {name {id {}}} {c_newSection $name 1 end $id}
+c_pass 2 fmt_section {name {id {}}} {
+ if {$id == {}} { set id [c_sectionId $name] }
+ sequence \
+ [xmlContext manpage] \
+ [start section id $id] \
+ [wrap [string toupper $name] title] \
+ ;
+}
+
+c_pass 1 fmt_subsection {name {id {}}} {c_newSection $name 2 end $id}
+c_pass 2 fmt_subsection {name {id {}}} {
+ if {$id == {}} { set id [c_sectionId $name] }
+ sequence \
+ [xmlContext section] \
+ [start subsection id $id] \
+ [wrap [string toupper $name] title] \
+ ;
+}
+
+c_pass 1 fmt_para {} NOP
+c_pass 2 fmt_para {} { sequence [xmlContext section] [start p] }
+
+foreach {type gi} {
+ itemized ul
+ enumerated ol
+ definitions dl
+ arguments arglist
+ commands commandlist
+ options optlist
+ tkoptions optionlist
+} {
+ set listTypes($type) $gi
+ lappend listGIs $gi
+}
+
+c_pass 1 fmt_list_begin {what {hint {}}} NOP
+c_pass 1 fmt_list_end {} NOP
+c_pass 2 fmt_list_begin {what {hint {}}} {
+ variable listTypes
+ sequence \
+ [xmlContext $::block] \
+ [start $listTypes($what)] \
+ ;
+}
+c_pass 2 fmt_list_end {} {
+ variable listGIs
+ sequence \
+ [xmlContext $listGIs] \
+ [end] \
+ ;
+}
+
+c_pass 1 fmt_bullet {} NOP
+c_pass 1 fmt_enum {} NOP
+c_pass 2 fmt_bullet {} { sequence [xmlContext {ul ol}] [start li] }
+c_pass 2 fmt_enum {} { sequence [xmlContext {ul ol}] [start li] }
+
+c_pass 1 fmt_lst_item {text} NOP
+c_pass 2 fmt_lst_item {text} {
+ sequence \
+ [xmlContext dl] \
+ [start dle] \
+ [wrap $text dt] \
+ [start dd] \
+ ;
+}
+
+c_pass 1 fmt_arg_def {type name {mode {}}} NOP
+c_pass 2 fmt_arg_def {type name {mode {}}} {
+ sequence \
+ [xmlContext arglist] \
+ [start argdef] \
+ [wrap $type argtype] \
+ [wrap $name name] \
+ [wrap? $mode argmode] \
+ [start desc] \
+ ;
+}
+
+c_pass 1 fmt_cmd_def {command} NOP
+c_pass 2 fmt_cmd_def {command} {
+ sequence \
+ [xmlContext commandlist] \
+ [start commanddef] \
+ [wrap $command command] \
+ [start desc] \
+ ;
+}
+
+c_pass 1 fmt_opt_def {name {arg {}}} NOP
+c_pass 2 fmt_opt_def {name {arg {}}} {
+ sequence \
+ [xmlContext optlist] \
+ [start optdef] \
+ [wrap $name optname] \
+ [wrap? $arg optarg] \
+ [start desc] \
+ ;
+}
+
+c_pass 1 fmt_tkoption_def {name dbname dbclass} NOP
+c_pass 2 fmt_tkoption_def {name dbname dbclass} {
+ sequence \
+ [xmlContext optionlist] \
+ [start optiondef] \
+ [wrap $name name] \
+ [wrap $dbname dbname] \
+ [wrap $dbclass dbclass] \
+ [start desc] \
+ ;
+}
+
+c_pass 1 fmt_usage {cmd args} { c_hold synopsis [formatCall $cmd $args] }
+c_pass 2 fmt_usage {cmd args} NOP
+
+c_pass 1 fmt_call {cmd args} { c_hold synopsis [formatCall $cmd $args] }
+c_pass 2 fmt_call {cmd args} {
+ sequence \
+ [xmlContext dl] \
+ [start dle] \
+ [wrap [formatCall $cmd $args] dt] \
+ [start dd] \
+ ;
+}
+proc formatCall {cmd arglist} {
+ return "$cmd [join $arglist { }]" ;# OR: wrap "..." command
+}
+
+c_pass 1 fmt_require {pkg {version {}}} {
+ c_hold synopsis [formatRequire $pkg $version]
+}
+c_pass 2 fmt_require {pkg {version {}}} NOP
+proc formatRequire {pkg version} {
+ return "package require [wrap $pkg package] $version"
+}
+
+# Note: TMML apparently has no support for category data inside of the document.
+
+c_pass 1 fmt_see_also {args} { holdWrapped see_also $args ref }
+c_pass 1 fmt_keywords {args} { holdWrapped keywords $args keyword }
+c_pass 1 fmt_category {args} NOP
+c_pass 2 fmt_see_also {args} NOP
+c_pass 2 fmt_keywords {args} NOP
+c_pass 2 fmt_category {args} NOP
+
+# holdWrapped --
+# Common factor of [see_also] and [keywords].
+#
+proc holdWrapped {buffer arglist gi} {
+ foreach arg $arglist { c_hold $buffer [wrap $arg $gi] }
+ return
+}
+
+c_pass 1 fmt_manpage_end {} NOP
+c_pass 2 fmt_manpage_end {} {
+ sequence \
+ [xmlContext manpage] \
+ [wrapLines? [c_held see_also] seealso] \
+ [wrapLines? [c_held keywords] keywords] \
+ [end manpage] \
+ ;
+}
+
+#*EOF*
+
diff --git a/tcllib/modules/doctools/mpformats/fmt.wiki b/tcllib/modules/doctools/mpformats/fmt.wiki
new file mode 100644
index 0000000..ff663fa
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/fmt.wiki
@@ -0,0 +1,297 @@
+# -*- tcl -*-
+#
+# fmt.nroff
+#
+# (c) 2002 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# [expand] definitions to convert a tcl based manpage definition into
+# Wiki markup.
+#
+################################################################
+
+dt_source _common.tcl ; # Shared code
+
+proc fmt_postprocess {wiki} {
+ # Strip empty lines out of the generated wiki source
+ # and trim leading blanks, except in code samples.
+ #
+ set lines [list]
+ set codeblock 0
+ foreach line [split $wiki \n] {
+ if {![string compare $line "======"]} {
+ set codeblock [expr {!$codeblock}]
+ lappend lines $line
+ continue
+ }
+ if {$codeblock} {
+ lappend lines $line
+ } else {
+ if {[string match " |*" $line]} {
+ # Verbatim / example
+ lappend lines [string trimright $line]
+ } elseif {[string match ". *" $line]} {
+ # Verbatim / regular
+ lappend lines [string range [string trimright $line] 1 end]
+ } elseif {[regexp {^ \* .*} $line]} {
+ # Itemized lists.
+ lappend lines [string map {[ [[ ] ]]} [string trimright $line]]
+ } elseif {[string match " 1. *" $line]} {
+ # Enumerated lists
+ lappend lines [string map {[ [[ ] ]]} [string trimright $line]]
+ } elseif {[regexp "^ .*: " $line]} {
+ # Definition list
+ lappend lines [string map {[ [[ ] ]]} $line]
+ } elseif {[string match " *" $line]} {
+ # Unwanted indentation
+ lappend lines [string map {[ [[ ] ]]} [string trim $line]]
+ } else {
+ # Everything else
+ lappend lines [string map {[ [[ ] ]]} [string trimright $line]]
+ }
+ }
+ }
+ set wiki [join $lines \n]\n
+
+ regsub {^[ ]+} $wiki {} wiki
+ return $wiki
+}
+
+
+################################################################
+## Backend for *roff markup
+
+c_pass 1 fmt_manpage_begin {title section version} NOP
+c_pass 2 fmt_manpage_begin {title section version} {
+ set module [dt_module]
+ set shortdesc [c_get_module]
+ set description [c_get_title]
+
+ set hdr ""
+ append hdr "'''$title $version'''"
+ if {[string length $module]} {
+ append hdr " '''$module'''"
+ }
+ if {[string length $shortdesc]} {
+ append hdr " ''$shortdesc''"
+ }
+ append hdr \n
+ append hdr \n
+ append hdr "$description"
+ append hdr \n
+ return $hdr
+}
+
+c_pass 1 fmt_moddesc {desc} {c_set_module $desc}
+c_pass 2 fmt_moddesc {desc} NOP
+
+c_pass 1 fmt_titledesc {desc} {c_set_title $desc}
+c_pass 2 fmt_titledesc {desc} NOP
+
+c_pass 1 fmt_copyright {desc} {c_set_copyright $desc}
+c_pass 2 fmt_copyright {desc} NOP
+
+c_pass 1 fmt_manpage_end {} NOP
+c_pass 2 fmt_manpage_end {} {
+ # Complete the generation with a copyright
+ # section, if such information is available.
+
+ set wiki ""
+
+ set sa [c_xref_seealso]
+ set kw [c_xref_keywords]
+ set ca [c_xref_category]
+ set ct [c_get_copyright]
+
+ if {[llength $sa] > 0} {
+ append wiki [fmt_section {SEE ALSO}] \n
+ append wiki [join [lsort $sa] ", "] \n
+ }
+ if {[llength $kw] > 0} {
+ append wiki [fmt_section KEYWORDS] \n
+ append wiki [join [lsort $kw] ", "] \n
+ }
+ if {$ca ne ""} {
+ append wiki [fmt_section CATEGORY] \n
+ append wiki $ca \n
+ }
+ if {$ct != {}} {
+ append wiki [fmt_section COPYRIGHT]
+ append wiki ". " [join [split $ct \n] "\n. "] \n
+ }
+ return $wiki
+}
+
+proc fmt_section {name {id {}}} {return "\n\n**$name**\n\n"}
+proc fmt_subsection {name {id {}}} {return "\n\n***$name***\n\n"}
+
+proc fmt_para {} {return \n}
+
+c_pass 2 fmt_require {pkg {version {}}} NOP
+c_pass 1 fmt_require {pkg {version {}}} {
+ if {$version != {}} {set version " $version"}
+ # @mdgen NODEP: '''
+ c_hold synopsis "package require '''$pkg$version'''\n"
+}
+
+c_pass 2 fmt_usage {cmd args} NOP
+c_pass 1 fmt_usage {cmd args} {c_hold synopsis " * $cmd [join $args " "]\n"}
+
+c_pass 2 fmt_call {cmd args} {return "[fmt_lst_item "$cmd [join $args " "]"]"}
+c_pass 1 fmt_call {cmd args} {c_hold synopsis " * $cmd [join $args " "]\n"}
+
+c_pass 1 fmt_description {id} NOP
+c_pass 2 fmt_description {id} {
+ set result ""
+ if {[set syn [c_held synopsis]] != {}} {
+ append result [fmt_section SYNOPSIS] \n
+ append result $syn \n\n
+ }
+ append result [fmt_section DESCRIPTION]
+ return $result
+}
+
+################################################################
+global arglist
+set ::arglist 0
+proc fmt_list_begin {what {hint {}}} {
+ switch -exact -- $what {
+ "arguments" {
+ set ::arglist 1
+ return "\n\n+++"
+ }
+ default {
+ return {}
+ }
+ }
+}
+proc fmt_list_end {} {
+ if {$::arglist} {
+ set ::arglist 0
+ return "\n+++\n\n"
+ }
+ return {}
+}
+
+proc fmt_bullet {} {return "\n\n * "}
+proc fmt_enum {} {return "\n\n 1. "}
+proc fmt_lst_item {text} {return "\n\n $text: "}
+proc fmt_cmd_def {command} {return "\n\n [fmt_cmd $command]: "}
+
+proc fmt_arg_def {type name {mode {}}} {
+ set text "\n"
+ append text [fmt_arg $name]
+ append text " $type"
+ if {$mode != {}} {append text " ($mode)"}
+ return "${text} "
+}
+proc fmt_opt_def {name {arg {}}} {
+# if {[string match -* $name]} {set name \\-$name}
+ set name [fmt_option $name]
+ if {$arg != {}} {append name " $arg"}
+ return "\n\n ${name}: "
+}
+proc fmt_tkoption_def {name dbname dbclass} {
+ set text "\n\n"
+ append text " Command-Line Switch:\t'''$name'''\n"
+ append text " Database Name:\t'''$dbname'''\n"
+ append text " Database Class:\t'''$dbclass'''\n"
+ append text " * "
+ return $text
+}
+
+################################################################
+
+global textmode
+set textmode ""
+
+proc fmt_example_begin {} {
+ global mode_save textmode
+ lappend mode_save $textmode
+ set textmode example
+ return "\n======\n"
+}
+proc fmt_example_end {} {
+ global mode_save textmode
+ set textmode [lindex $mode_save end]
+ set mode_save [lrange $mode_save 0 end-1]
+ return "\n======\n"
+}
+proc fmt_example {code} {
+ return "$code"
+}
+
+proc emph {text} {return ''$text''}
+proc strong {text} {return '''$text'''}
+
+proc fmt_nl {} {return ""}
+proc fmt_arg {text} {return ''$text''}
+proc fmt_cmd {text} {return '''$text'''}
+proc fmt_emph {text} {return ''$text''}
+proc fmt_opt {text} {return ?$text?}
+proc fmt_comment {text} {return {}}
+proc fmt_sectref {text {label {}}} {
+ if {![string length $label]} {set label $text}
+ strong $text
+}
+proc fmt_syscmd {text} {strong $text}
+proc fmt_method {text} {strong $text}
+proc fmt_option {text} {strong $text}
+proc fmt_widget {text} {strong $text}
+proc fmt_fun {text} {strong $text}
+proc fmt_type {text} {strong $text}
+proc fmt_package {text} {strong $text}
+proc fmt_class {text} {strong $text}
+proc fmt_var {text} {strong $text}
+proc fmt_file {text} {return "\"[emph $text]\""}
+proc fmt_namespace {text} {strong $text}
+proc fmt_uri {text {label {}}} {
+ if {$label == {}} {
+ # No label is an inlined emphasized link.
+ return $text
+ } else {
+ # Label in the text, link for it is hidden in an annotation.
+ return "$text%|%$label%|%"
+ }
+}
+proc fmt_image {text {label {}}} {
+ # text = symbolic name of the image.
+
+ # Alt: png, jpg, gif, which are then used during HTML
+ # conversion. But unclear what the link is, to use for this. So,
+ # keeping as text for the moment.
+
+ set img [dt_imgdata $text {txt}]
+ if {$img eq {}} {
+ if {$label eq {}} {
+ return "IMAGE: $text"
+ } else {
+ return "IMAGE: $text $label"
+ }
+ }
+
+ return \n======\n$img\n======\n
+}
+proc fmt_term {text} {emph $text}
+proc fmt_const {text} {strong $text}
+proc fmt_mdash {} { return " --- " }
+proc fmt_ndash {} { return " -- " }
+
+################################################################
+# wiki specific commands
+
+proc fmt_plain_text {text} {
+ # For the wiki we have to force certain text into a single line.
+ # We also have to make sure that the text is on the same line as
+ # the initiator (i.e. list bullet).
+
+ global textmode
+
+ if {"$textmode" == "example"} {
+ return "$text"
+ }
+
+ regsub -all "\[ \t\n\]+" $text { } text
+ return $text
+}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/fr.msg b/tcllib/modules/doctools/mpformats/fr.msg
new file mode 100755
index 0000000..e418e86
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/fr.msg
@@ -0,0 +1,34 @@
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+mcset fr end/open/list "Fin de la page de manuel atteinte, \[list_end\] manquant"
+mcset fr end/open/example "Fin de la page de manuel atteinte, \[example_end\] manquant"
+mcset fr end/open/mp "Fin de la page de manuel atteinte, \[manpage_end\] manquant"
+mcset fr mpbegin "Cette commande doit \xEAtre la premi\xE8re de la page de manuel"
+mcset fr mptitle "TODO: TRANSLATE: Spaces not allowed in manpage title"
+mcset fr hdrcmd "Commande interdite \xE0 l'ext\xE9rieur de l'en-t\xEAte"
+mcset fr bodycmd "Commande interdite \xE0 l'ext\xE9rieur du corps de la page de manuel"
+mcset fr body "Le texte est interdit \xE0 l'ext\xE9rieur du corps de la page de manuel"
+mcset fr reqcmd "Commande interdite \xE0 l'ext\xE9rieur de l'en-t\xEAte ou de la section de condition"
+mcset fr invalidlist "Type de liste non valide \"@\""
+mcset fr nolistcmd "Commande interdite \xE0 l'int\xE9rieur d'une liste"
+mcset fr nolisthdr "Commande interdite entre le d\xE9but d'une liste et son premier \xE9l\xE9ment"
+mcset fr nolisttxt "Le texte est interdit entre le d\xE9but d'une liste et son premier \xE9l\xE9ment"
+mcset fr listcmd "Commande interdite \xE0 l'ext\xE9rieur d'une liste"
+mcset fr deflist "Commande restreinte \xE0 l'utilisation dans les listes de d\xE9finition"
+mcset fr bulletlist "Commande restreinte \xE0 l'utilisation dans les listes d'\xE9l\xE9ments"
+mcset fr enumlist "Commande restreinte \xE0 l'utilisation dans les listes num\xE9rot\xE9es"
+mcset fr examplecmd "Commande autoris\xE9e uniquement pour fermer une section d'exemple"
+mcset fr nodonecmd "Commande interdite apr\xE8s \[manpage_end\]"
+mcset fr arg_list "Commande restreinte \xE0 l'utilisation dans les listes d'arguments"
+mcset fr cmd_list "Commande restreinte \xE0 l'utilisation dans les listes de commandes"
+mcset fr opt_list "Commande restreinte \xE0 l'utilisation dans les listes d'options"
+mcset fr tkoption_list "Commande restreinte \xE0 l'utilisation dans les listes de tkoption"
+mcset fr depr_strong "Commande obsol\xE8te \"%s\".\n\tConsultez l'aide s\xE9mantique correspondante ou \[emph\] \xE0 la place."
+mcset fr depr_lstitem "Commande obsol\xE8te \"%s\".\n\tConsultez \[def\] \xE0 la place."
+mcset fr depr_nl "Commande obsol\xE8te \"%s\".\n\tConsultez \[para\] \xE0 la place."
+mcset fr depr_bullet "Commande obsol\xE8te \"%s\".\n\tConsultez \[item\] \xE0 la place."
+mcset fr depr_ltype "<List type> obsol\xE8te \"%s\".\n\tConsultez \"%s\" \xE0 la place."
+mcset fr sectambig "@@@ Translate @@@ (Sub)Section title \"%s\" causes ambiguous section references."
+mcset fr missingsect "@@@ Translate @@@ Refered (Sub)Section \"%s\" is not known."
diff --git a/tcllib/modules/doctools/mpformats/idx.html b/tcllib/modules/doctools/mpformats/idx.html
new file mode 100644
index 0000000..1cd29e0
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/idx.html
@@ -0,0 +1,314 @@
+## -*- tcl -*-
+# ### ### ### ######### ######### #########
+##
+# $Id: idx.html,v 1.8 2007/03/20 05:06:35 andreas_kupries Exp $
+#
+# Index Formatting Engine : docidx --> HTML.
+# Single-pass
+#
+# Copyright (c) 2003-2007 Andreas Kupries <andreas_kupries@sourceforge.net>
+# Freely redistributable.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+dt_source _idx_common.tcl
+dt_source _html.tcl
+
+# ### ### ### ######### ######### #########
+## API implementation
+
+rename idx_postprocess {}
+rename fmt_postprocess idx_postprocess
+
+proc fmt_plain_text {text} {return {}}
+
+proc fmt_index_begin {l t} {
+ global la ti
+ set la $l
+ set ti $t
+ return {}
+}
+
+proc fmt_key {text} {
+ global key lk ch
+ set lk $text
+ set key($lk) {}
+ set ch([F $lk]) .
+ return {}
+}
+
+proc fmt_manpage {f l} {Ref [dt_fmap $f] $l}
+proc fmt_url {u l} {Ref $u $l}
+
+proc fmt_index_end {} {
+ LoadKwid
+ set lines {}
+ if {![Get raw]} {
+ BeginHeader ; Meta ; EndHeader
+ BeginBody
+ }
+ BodyHeader ; Title ; Navbar
+ BeginIndex ; Keys ; EndIndex
+ if {![Get raw]} {
+ EndBody
+ }
+ return [join $lines \n]
+}
+
+# ### ### ### ######### ######### #########
+## Helper commands
+
+proc Ref {r l} {
+ global key lk
+ lappend key($lk) $r $l
+ return {}
+}
+
+proc F {text} {
+ return [string toupper [string index $text 0]]
+}
+
+proc LoadKwid {} {
+ global kwid
+ # Engine parameter - load predefined keyword anchors.
+ set ki [Get kwid]
+ if {![llength $ki]} return
+ array set kwid $ki
+ return
+}
+
+proc BeginHeader {} {
+ global la ti
+ upvar 1 lines lines
+ lappend lines [markup <html>]
+ lappend lines [ht_comment [c_provenance]]
+ lappend lines [ht_comment "$la"]
+ lappend lines [markup <head>]
+ lappend lines "[markup <title>] $la [markup </title>]"
+ return
+}
+
+proc Meta {} {
+ # Engine parameter - insert 'meta'
+ set meta [Get meta]
+ if {$meta == {}} return
+ upvar 1 lines lines
+ lappend lines [markup $meta]
+ return
+}
+
+proc EndHeader {} {
+ upvar 1 lines lines
+ lappend lines [markup </head>]
+ return
+}
+
+proc BeginBody {} {
+ upvar 1 lines lines
+ lappend lines [markup <body>]
+ return
+}
+
+proc BodyHeader {} {
+ upvar 1 lines lines
+ # Engine parameter - insert 'header'
+ set header [Get header]
+ if {$header == {}} return
+ lappend map @TITLE@ [TheTitle]
+ set header [string map $map $header]
+ lappend lines [markup $header]
+ return
+}
+
+proc TheTitle {} {
+ global la ti
+ set title ???
+ if {($la != {}) && ($ti != {})} {
+ set title "$la -- $ti"
+ } elseif {$la != {}} {
+ set title $la
+ } elseif {$ti != {}} {
+ set title $ti
+ }
+ return $title
+}
+
+proc Title {} {
+ upvar 1 lines lines
+ lappend lines "[markup <h3>] [TheTitle] [markup </h3>]"
+ return
+}
+
+proc Navbar {} {
+ global ch cnt dot
+ upvar 1 lines lines
+
+ set nav {}
+ foreach c [lsort -dict [array names ch]] {
+ set ref c[incr cnt]
+ set ch($c) $ref
+ lappend nav [ALink $ref $c]
+ }
+
+ lappend lines [markup "<hr><div class=\"#doctools_idxnav\">"]
+ lappend lines [join $nav $dot]
+ lappend lines [markup </div>]
+ return
+}
+
+proc BeginIndex {} {
+ upvar 1 lines lines
+ lappend lines [markup "<hr><table class=\"#doctools_idx\" width=\"100%\">"]
+ return
+}
+
+proc Keys {} {
+ global key
+ upvar 1 lines lines
+ set lc {}
+ foreach k [lsort -dict [array names key]] {
+ set c [F $k] ; if {$lc != $c} { Section $c ; set lc $c }
+ BeginKey $k
+ References $k
+ EndKey
+ }
+ return
+}
+
+proc Section {c} {
+ global ch
+ upvar 1 lines lines
+ lappend lines [markup {<tr class="#doctools_idxheader"><th colspan="2">}]
+ lappend lines [markup "<a name=\"$ch($c)\">Keywords: $c</a>"]
+ lappend lines [markup </th></tr>]
+ return
+}
+
+proc BeginKey {k} {
+ upvar 1 lines lines
+ lappend lines [markup "<tr class=\"[Row]\" valign=top>"]
+ lappend lines [BeginColLeft][SetAnchor $k][markup </td>]
+ lappend lines [BeginColRight]
+ return
+}
+
+proc EndKey {} {
+ upvar 1 lines lines
+ lappend lines [markup </td></tr>]
+ return
+}
+
+proc References {k} {
+ global key dot
+ upvar 1 lines lines
+ set refs {}
+ foreach {ref label} $key($k) {
+ lappend refs [markup "<a href=\"$ref\"> $label </a>"]
+ }
+ lappend lines [join $refs $dot]
+ return
+}
+
+proc EndIndex {} {
+ upvar 1 lines lines
+ lappend lines [markup </table>]
+ # Engine parameter - insert 'footer'
+ set footer [Get footer]
+ if {$footer == {}} return
+ lappend lines [markup "<hr>"]
+ lappend lines [markup $footer]
+ return
+}
+
+proc EndBody {} {
+ upvar 1 lines lines
+ lappend lines [markup "</body></html>"]
+ return
+}
+
+proc ALink {dst label} {
+ markup "<a href=\"#$dst\"> $label </a>"
+}
+
+proc BeginColLeft {} {
+ return [markup {<td class="#doctools_idxleft" width="35%">}]
+}
+
+proc BeginColRight {} {
+ return [markup {<td class="#doctools_idxright" width="65%">}]
+}
+
+proc SetAnchor {text} {
+ return [markup "<a name=[Anchor $text]> $text </a>"]
+}
+
+proc Anchor {text} {
+ global kwid cnt
+ if {[info exists kwid($text)]} {
+ return "\"$kwid($text)\""
+ }
+ set anchor key$cnt
+ incr cnt
+ return "\"$anchor\""
+}
+
+proc Row {} {
+ global even
+ set res [expr {$even
+ ? "\#doctools_idxeven"
+ : "\#doctools_idxodd"}]
+ Flip
+ return $res
+}
+
+proc Flip {} {
+ global even
+ set even [expr {1-$even}]
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Engine state
+
+# key : string -> dict(ref -> label) "key formatting"
+# ch : string -> '.' "key starting characters"
+# lk : string "last key"
+# la : string "index label"
+# ti : string "index title"
+# cnt : int
+# kwid : string -> ...
+# even : bool
+
+global key ; array set key {}
+global ch ; array set ch {}
+global lk ; set lk {}
+global la ; set la {}
+global ti ; set ti {}
+global cnt ; set cnt 0
+global kwid ; array set kwid {}
+global even ; set even 1
+global dot ; set dot [markup { &#183; }]
+
+# ### ### ### ######### ######### #########
+## Engine parameters
+
+global __var
+array set __var {
+ meta {}
+ header {}
+ footer {}
+ kwid {}
+ raw 0
+}
+proc Get {varname} {global __var ; return $__var($varname)}
+proc idx_listvariables {} {global __var ; return [array names __var]}
+proc idx_varset {varname text} {
+ global __var
+ if {![info exists __var($varname)]} {return -code error "Unknown engine variable \"$varname\""}
+ set __var($varname) $text
+ return
+}
+
+##
+# ### ### ### ######### ######### #########
diff --git a/tcllib/modules/doctools/mpformats/idx.nroff b/tcllib/modules/doctools/mpformats/idx.nroff
new file mode 100644
index 0000000..5499310
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/idx.nroff
@@ -0,0 +1,81 @@
+# -*- tcl -*-
+#
+# $Id: idx.nroff,v 1.7 2009/01/30 04:56:47 andreas_kupries Exp $
+#
+# Engine to convert a docidx document into nroff.
+#
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+# Freely redistributable.
+#
+######################################################################
+
+dt_source _idx_common.tcl
+dt_source _nroff.tcl
+
+######################################################################
+# Conversion specification.
+#
+# One-pass processing.
+
+proc idx_postprocess {nroff} {
+ # Postprocessing after generation ...
+ # Strip empty lines out of the generated nroff source
+ # and trim leading blanks, except in code samples.
+
+ set lines [list]
+ foreach line [split $nroff "\n"] {
+ set line [string trim $line]
+ if {0 == [string length $line]} {
+ continue
+ }
+ lappend lines $line
+ }
+ return [nroff_postprocess [join $lines \n]]
+}
+
+#proc fmt_plain_text {text} {if {$text != {}} {return \n} else {return {}}}
+proc fmt_plain_text {text} {return {}}
+
+################################################################
+## Backend for NROFF markup
+
+global prec ok haskey
+set prec ""
+set ok 0
+set haskey 0
+
+proc fmt_index_begin {label title} {
+ global prec ok
+ set ok 1
+ set hdr [nr_comment {}]\n
+ if {$prec != {}} {
+ set hdr [nr_comment $prec]\n
+ }
+ append hdr [nr_comment [c_provenance]]\n
+ append hdr [nr_title "\"[string trimleft $label :]\" n"]\n
+ append hdr [nr_read man.macros]\n
+ append hdr [nr_bolds]\n
+ append hdr [nr_section INDEX]\n
+ append hdr $title[nr_in]\n
+ return $hdr
+}
+proc fmt_index_end {} {return [nr_out]}
+proc fmt_key {text} {
+ global haskey
+ set res ""
+ if {$haskey} {append res [nr_out]\n}
+ append res $text[nr_in]\n
+ set haskey 1
+ return $res
+}
+proc fmt_manpage {file label} {return [nr_blt [nr_bld]$file[nr_rst]]\n$label\n}
+proc fmt_url {url label} {return [nr_blt [nr_bld]$url[nr_rst]]\n$label\n}
+
+proc fmt_comment {text} {
+ global prec ok
+ if {$ok} {return [nr_comment $text]}
+ append prec $text \n
+ return {}
+}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/idx.null b/tcllib/modules/doctools/mpformats/idx.null
new file mode 100644
index 0000000..d0704a6
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/idx.null
@@ -0,0 +1,23 @@
+# -*- tcl -*-
+#
+# -- Null format (docidx)
+#
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# This is a null format which does return no output at all.
+
+################################################################
+
+proc idx_initialize {} {return}
+proc idx_shutdown {} {return}
+proc idx_numpasses {} {return 1}
+proc idx_postprocess {text} {return ""}
+proc idx_setup {n} {return}
+
+foreach p {
+ index_begin index_end key manpage url comment plain_text
+} {
+ proc fmt_$p {args} {return ""}
+}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/idx.text b/tcllib/modules/doctools/mpformats/idx.text
new file mode 100644
index 0000000..35540d8
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/idx.text
@@ -0,0 +1,79 @@
+# -*- tcl -*-
+#
+# $Id: idx.text,v 1.4 2010/06/08 19:32:36 andreas_kupries Exp $
+#
+# Engine to convert a docidx document into plain text.
+#
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+# Freely redistributable.
+#
+######################################################################
+
+dt_source _idx_common.tcl
+dt_source _text.tcl
+proc c_copyrightsymbol {} {return "(c)"}
+
+######################################################################
+# Conversion specification.
+# One-pass processing.
+
+rename idx_postprocess {}
+rename text_postprocess idx_postprocess
+proc fmt_plain_text {text} {return {}}
+
+################################################################
+## Backend for plain text markup
+
+global map ; array set map {}
+global key ; set key {}
+global max ; set max 0
+
+proc fmt_index_begin {label title} {
+ TextInitialize
+
+ global map ; unset map ; array set map {}
+ global key ; set key {}
+ global max ; set max 0
+
+ set hdr ""
+ append hdr "Index [textutil::string::uncap [c_provenance]]\n\n"
+
+ if {($label != {}) && ($title != {})} {
+ set title "$label -- $title"
+ } elseif {$label != {}} {
+ set title $label
+ } elseif {$title != {}} {
+ # title is set
+ }
+ append hdr $title \n
+ append hdr [textutil::repeat::strRepeat = [string length $title]]
+ Text $hdr
+ CloseParagraph [Verbatim]
+ return
+}
+proc fmt_index_end {} {
+ global map max
+
+ set break 0
+ set rmargin [expr {80 - $max}]
+ if {$rmargin < 20} {set rmargin 20}
+ incr max
+ set pfx [textutil::repeat::blank $max]
+
+ foreach key [lsort [array names map]] {
+ set opfx $key[string range $pfx [string length $key] end]
+ Text $opfx[textutil::adjust::indent [textutil::adjust::adjust [join $map($key) ", "] -length $rmargin] $pfx 1]
+ CloseParagraph [Verbatim]
+ }
+ return
+}
+proc fmt_key {text} {
+ global key max ; set key $text
+ if {[string length $text] > $max} {set max [string length $text]}
+ return
+}
+proc fmt_manpage {file label} {global map key ; lappend map($key) $file ; return}
+proc fmt_url {url label} {global map key ; lappend map($key) $url ; return}
+proc fmt_comment {text} {return}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/idx.wiki b/tcllib/modules/doctools/mpformats/idx.wiki
new file mode 100644
index 0000000..8eee534
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/idx.wiki
@@ -0,0 +1,63 @@
+# -*- tcl -*-
+#
+# $Id: idx.wiki,v 1.2 2004/01/15 06:36:12 andreas_kupries Exp $
+#
+# Engine to convert a docidx document into Wiki markup.
+#
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+# Freely redistributable.
+#
+######################################################################
+
+dt_source _idx_common.tcl ; # Shared code
+
+######################################################################
+
+proc idx_postprocess {wiki} {
+ # Strip empty lines out of the generated wiki source
+ # and trim leading blanks, except in code samples.
+ #
+ set lines [list]
+ foreach line [split $wiki \n] {
+ if {[string match " |*" $line]} {
+ # Verbatim / example
+ lappend lines [string trimright $line]
+ } elseif {[string match ". *" $line]} {
+ # Verbatim / regular
+ lappend lines [string range [string trimright $line] 1 end]
+ } elseif {[string match " \* *" $line]} {
+ # Itemized lists.
+ lappend lines [string map {[ [[ ] ]]} [string trimright $line]]
+ } elseif {[string match " 1. *" $line]} {
+ # Enumerated lists
+ lappend lines [string map {[ [[ ] ]]} [string trimright $line]]
+ } elseif {[regexp "^ (\[^:\]): " $line]} {
+ # Definition list
+ lappend lines [string map {[ [[ ] ]]} [string trimright $line]]
+ } elseif {[string match " *" $line]} {
+ # Unwanted indentation
+ lappend lines [string map {[ [[ ] ]]} [string trim $line]]
+ } else {
+ # Everything else
+ lappend lines [string map {[ [[ ] ]]} [string trimright $line]]
+ }
+ }
+ set wiki [join $lines \n]\n
+
+ regsub {^[ ]+} $wiki {} wiki
+ return $wiki
+}
+
+proc fmt_plain_text {text} {return {}}
+
+################################################################
+## Backend for wiki markup
+
+proc fmt_index_begin {label title} {return "Index '''$label'''\n'''[string trim $title]'''\n"}
+proc fmt_index_end {} {return {}}
+proc fmt_key {text} {return "\n '''[string trim $text]''': "}
+proc fmt_manpage {file label} {return "$file "}
+proc fmt_url {url label} {return "$url "}
+proc fmt_comment {text} {return {}}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/man.macros b/tcllib/modules/doctools/mpformats/man.macros
new file mode 100644
index 0000000..ddd073d
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/man.macros
@@ -0,0 +1,267 @@
+.\" The -*- nroff -*- definitions below are for supplemental macros used
+.\" in Tcl/Tk manual entries.
+.\"
+.\" .AP type name in/out ?indent?
+.\" Start paragraph describing an argument to a library procedure.
+.\" type is type of argument (int, etc.), in/out is either "in", "out",
+.\" or "in/out" to describe whether procedure reads or modifies arg,
+.\" and indent is equivalent to second arg of .IP (shouldn't ever be
+.\" needed; use .AS below instead)
+.\"
+.\" .AS ?type? ?name?
+.\" Give maximum sizes of arguments for setting tab stops. Type and
+.\" name are examples of largest possible arguments that will be passed
+.\" to .AP later. If args are omitted, default tab stops are used.
+.\"
+.\" .BS
+.\" Start box enclosure. From here until next .BE, everything will be
+.\" enclosed in one large box.
+.\"
+.\" .BE
+.\" End of box enclosure.
+.\"
+.\" .CS
+.\" Begin code excerpt.
+.\"
+.\" .CE
+.\" End code excerpt.
+.\"
+.\" .VS ?version? ?br?
+.\" Begin vertical sidebar, for use in marking newly-changed parts
+.\" of man pages. The first argument is ignored and used for recording
+.\" the version when the .VS was added, so that the sidebars can be
+.\" found and removed when they reach a certain age. If another argument
+.\" is present, then a line break is forced before starting the sidebar.
+.\"
+.\" .VE
+.\" End of vertical sidebar.
+.\"
+.\" .DS
+.\" Begin an indented unfilled display.
+.\"
+.\" .DE
+.\" End of indented unfilled display.
+.\"
+.\" .SO ?manpage?
+.\" Start of list of standard options for a Tk widget. The manpage
+.\" argument defines where to look up the standard options; if
+.\" omitted, defaults to "options". The options follow on successive
+.\" lines, in three columns separated by tabs.
+.\"
+.\" .SE
+.\" End of list of standard options for a Tk widget.
+.\"
+.\" .OP cmdName dbName dbClass
+.\" Start of description of a specific option. cmdName gives the
+.\" option's name as specified in the class command, dbName gives
+.\" the option's name in the option database, and dbClass gives
+.\" the option's class in the option database.
+.\"
+.\" .UL arg1 arg2
+.\" Print arg1 underlined, then print arg2 normally.
+.\"
+.\" .QW arg1 ?arg2?
+.\" Print arg1 in quotes, then arg2 normally (for trailing punctuation).
+.\"
+.\" .PQ arg1 ?arg2?
+.\" Print an open parenthesis, arg1 in quotes, then arg2 normally
+.\" (for trailing punctuation) and then a closing parenthesis.
+.\"
+.\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
+.if t .wh -1.3i ^B
+.nr ^l \n(.l
+.ad b
+.\" # Start an argument description
+.de AP
+.ie !"\\$4"" .TP \\$4
+.el \{\
+. ie !"\\$2"" .TP \\n()Cu
+. el .TP 15
+.\}
+.ta \\n()Au \\n()Bu
+.ie !"\\$3"" \{\
+\&\\$1 \\fI\\$2\\fP (\\$3)
+.\".b
+.\}
+.el \{\
+.br
+.ie !"\\$2"" \{\
+\&\\$1 \\fI\\$2\\fP
+.\}
+.el \{\
+\&\\fI\\$1\\fP
+.\}
+.\}
+..
+.\" # define tabbing values for .AP
+.de AS
+.nr )A 10n
+.if !"\\$1"" .nr )A \\w'\\$1'u+3n
+.nr )B \\n()Au+15n
+.\"
+.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
+.nr )C \\n()Bu+\\w'(in/out)'u+2n
+..
+.AS Tcl_Interp Tcl_CreateInterp in/out
+.\" # BS - start boxed text
+.\" # ^y = starting y location
+.\" # ^b = 1
+.de BS
+.br
+.mk ^y
+.nr ^b 1u
+.if n .nf
+.if n .ti 0
+.if n \l'\\n(.lu\(ul'
+.if n .fi
+..
+.\" # BE - end boxed text (draw box now)
+.de BE
+.nf
+.ti 0
+.mk ^t
+.ie n \l'\\n(^lu\(ul'
+.el \{\
+.\" Draw four-sided box normally, but don't draw top of
+.\" box if the box started on an earlier page.
+.ie !\\n(^b-1 \{\
+\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
+.\}
+.el \}\
+\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
+.\}
+.\}
+.fi
+.br
+.nr ^b 0
+..
+.\" # VS - start vertical sidebar
+.\" # ^Y = starting y location
+.\" # ^v = 1 (for troff; for nroff this doesn't matter)
+.de VS
+.if !"\\$2"" .br
+.mk ^Y
+.ie n 'mc \s12\(br\s0
+.el .nr ^v 1u
+..
+.\" # VE - end of vertical sidebar
+.de VE
+.ie n 'mc
+.el \{\
+.ev 2
+.nf
+.ti 0
+.mk ^t
+\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
+.sp -1
+.fi
+.ev
+.\}
+.nr ^v 0
+..
+.\" # Special macro to handle page bottom: finish off current
+.\" # box/sidebar if in box/sidebar mode, then invoked standard
+.\" # page bottom macro.
+.de ^B
+.ev 2
+'ti 0
+'nf
+.mk ^t
+.if \\n(^b \{\
+.\" Draw three-sided box if this is the box's first page,
+.\" draw two sides but no top otherwise.
+.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
+.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
+.\}
+.if \\n(^v \{\
+.nr ^x \\n(^tu+1v-\\n(^Yu
+\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
+.\}
+.bp
+'fi
+.ev
+.if \\n(^b \{\
+.mk ^y
+.nr ^b 2
+.\}
+.if \\n(^v \{\
+.mk ^Y
+.\}
+..
+.\" # DS - begin display
+.de DS
+.RS
+.nf
+.sp
+..
+.\" # DE - end display
+.de DE
+.fi
+.RE
+.sp
+..
+.\" # SO - start of list of standard options
+.de SO
+'ie '\\$1'' .ds So \\fBoptions\\fR
+'el .ds So \\fB\\$1\\fR
+.SH "STANDARD OPTIONS"
+.LP
+.nf
+.ta 5.5c 11c
+.ft B
+..
+.\" # SE - end of list of standard options
+.de SE
+.fi
+.ft R
+.LP
+See the \\*(So manual entry for details on the standard options.
+..
+.\" # OP - start of full description for a single option
+.de OP
+.LP
+.nf
+.ta 4c
+Command-Line Name: \\fB\\$1\\fR
+Database Name: \\fB\\$2\\fR
+Database Class: \\fB\\$3\\fR
+.fi
+.IP
+..
+.\" # CS - begin code excerpt
+.de CS
+.RS
+.nf
+.ta .25i .5i .75i 1i
+..
+.\" # CE - end code excerpt
+.de CE
+.fi
+.RE
+..
+.\" # UL - underline word
+.de UL
+\\$1\l'|0\(ul'\\$2
+..
+.\" # QW - apply quotation marks to word
+.de QW
+.ie '\\*(lq'"' ``\\$1''\\$2
+.\"" fix emacs highlighting
+.el \\*(lq\\$1\\*(rq\\$2
+..
+.\" # PQ - apply parens and quotation marks to word
+.de PQ
+.ie '\\*(lq'"' (``\\$1''\\$2)\\$3
+.\"" fix emacs highlighting
+.el (\\*(lq\\$1\\*(rq\\$2)\\$3
+..
+.\" # QR - quoted range
+.de QR
+.ie '\\*(lq'"' ``\\$1''\\-``\\$2''\\$3
+.\"" fix emacs highlighting
+.el \\*(lq\\$1\\*(rq\\-\\*(lq\\$2\\*(rq\\$3
+..
+.\" # MT - "empty" string
+.de MT
+.QW ""
+..
diff --git a/tcllib/modules/doctools/mpformats/toc.html b/tcllib/modules/doctools/mpformats/toc.html
new file mode 100644
index 0000000..a2f5dfc
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/toc.html
@@ -0,0 +1,129 @@
+# -*- tcl -*-
+#
+# $Id: toc.html,v 1.6 2005/09/28 04:51:19 andreas_kupries Exp $
+#
+# Engine to convert a doctoc document into HTML.
+#
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+# Freely redistributable.
+#
+######################################################################
+
+dt_source _toc_common.tcl
+dt_source _html.tcl
+
+######################################################################
+# Conversion specification.
+#
+# One-pass processing.
+
+rename toc_postprocess {}
+rename fmt_postprocess toc_postprocess
+
+proc fmt_plain_text {text} {return {}}
+
+################################################################
+## Backend for TMML markup
+
+global firstitem ; set firstitem 1
+global maintable ; set maintable 1
+global even ; set even 1
+
+proc fmt_toc_begin {label title} {
+ set hdr ""
+ if {![Get raw]} {
+ append hdr "[markup <html><head>]\n"
+ append hdr "[markup <title>] $label [markup </title>]\n"
+
+ # Engine parameter - insert 'meta'
+ if {[set meta [Get meta]] != {}} {append hdr [markup $meta]\n}
+
+ append hdr "[markup </head>]\n"
+ append hdr [ht_comment [c_provenance]]\n
+ append hdr [ht_comment "$label"]\n
+ append hdr \n
+ append hdr [markup <body>]\n
+ }
+
+ # Engine parameter - insert 'header'
+ if {[set header [Get header]] != {}} {
+ lappend map @TITLE@ $label
+ set header [string map $map $header]
+ append hdr [markup $header]\n
+ }
+
+ append hdr "[markup <h3>] $label [markup </h3>]\n"
+ append hdr "[markup <hr><dl><dt><h2>] $title [markup </h2><dd>]\n"
+ return $hdr
+}
+proc fmt_toc_end {} {
+ global maintable
+ set text "\n"
+ if {$maintable} {append text [tag/ table]\n}
+
+ # Engine parameter - insert 'footer'
+ set footer [Get footer]
+ if {$footer != {}} {set footer \n[markup ${footer}]\n}
+
+ append text [tag /dl][tag hr]${footer}
+
+ if {![Get raw]} {
+ append text [tag/ body][tag/ html]\n
+ }
+ return $text
+}
+proc fmt_division_start {title symfile} {
+ global maintable ; set maintable 0
+
+ if {$symfile == ""} {
+ return \n[markup <dl><dt>]$title[markup <dd>]
+ } else {
+ return \n[markup <dl><dt>][markup "<a href=\"[dt_fmap $symfile]\">"]$title[markup </a><dd>]
+ }
+}
+proc fmt_division_end {} {
+ global firstitem ; set firstitem 1
+ global even ; set even 1
+ return [markup </table></dl>]
+}
+proc fmt_item {file label desc} {
+ global firstitem even
+ set text ""
+
+ if {$firstitem} {
+ set firstitem 0
+ append text \n[markup "<table class=\"#doctools_toc\">"]\n
+ }
+
+ if {$even} {
+ append text [markup "<tr class=\"#doctools_toceven\" >"]\n
+ } else {
+ append text [markup "<tr class=\"#doctools_tocodd\" >"]\n
+ }
+ set even [expr {1-$even}]
+ append text [markup "<td class=\"#doctools_tocleft\" >"][markup "<a href=\"[dt_fmap $file]\">"]$label[tag/ a][tag/ td]\n
+ append text [markup "<td class=\"#doctools_tocright\">"]${desc}[tag /td]\n
+ append text [tag/ tr]\n
+ return $text
+}
+proc fmt_comment {text} {ht_comment $text}
+
+################################################################
+
+global __var
+array set __var {
+ meta {}
+ header {}
+ footer {}
+ raw 0
+}
+proc Get {varname} {global __var ; return $__var($varname)}
+proc toc_listvariables {} {global __var ; return [array names __var]}
+proc toc_varset {varname text} {
+ global __var
+ if {![info exists __var($varname)]} {return -code error "Unknown engine variable \"$varname\""}
+ set __var($varname) $text
+ return
+}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/toc.nroff b/tcllib/modules/doctools/mpformats/toc.nroff
new file mode 100644
index 0000000..8706e08
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/toc.nroff
@@ -0,0 +1,73 @@
+# -*- tcl -*-
+#
+# $Id: toc.nroff,v 1.7 2009/01/30 04:56:47 andreas_kupries Exp $
+#
+# Engine to convert a doctoc document into nroff.
+#
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+# Freely redistributable.
+#
+######################################################################
+
+dt_source _toc_common.tcl
+dt_source _nroff.tcl
+
+######################################################################
+# Conversion specification.
+#
+# One-pass processing.
+
+proc toc_postprocess {nroff} {
+ # Postprocessing after generation ...
+ # Strip empty lines out of the generated nroff source
+ # and trim leading blanks, except in code samples.
+
+ set lines [list]
+ foreach line [split $nroff "\n"] {
+ set line [string trim $line]
+ if {0 == [string length $line]} {
+ continue
+ }
+ lappend lines $line
+ }
+ return [nroff_postprocess [join $lines \n]]
+}
+
+#proc fmt_plain_text {text} {if {$text != {}} {return \n} else {return {}}}
+proc fmt_plain_text {text} {return {}}
+
+################################################################
+## Backend for TMML markup
+
+global prec ok
+set prec ""
+set ok 0
+
+proc fmt_toc_begin {label title} {
+ global prec ok
+ set ok 1
+ set hdr [nr_comment {}]\n
+ if {$prec != {}} {
+ set hdr [nr_comment $prec]\n
+ }
+ append hdr [nr_comment [c_provenance]]\n
+ append hdr [nr_title "\"[string trimleft $label :]\" n"]\n
+ append hdr [nr_read man.macros]\n
+ append hdr [nr_bolds]\n
+ append hdr [nr_section CONTENTS]\n
+ append hdr $title[nr_in]\n
+ return $hdr
+}
+proc fmt_toc_end {} {}
+proc fmt_division_start {title symfile} {return $title[nr_in]\n}
+proc fmt_division_end {} {return [nr_out]\n}
+proc fmt_item {file label desc} {return "[nr_blt [nr_bld]$label[nr_rst]]\n[nr_ul]$file[nr_rst]: $desc\n"}
+
+proc fmt_comment {text} {
+ global prec ok
+ if {$ok} {return [nr_comment $text]}
+ append prec $text \n
+ return {}
+}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/toc.null b/tcllib/modules/doctools/mpformats/toc.null
new file mode 100644
index 0000000..d85ada3
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/toc.null
@@ -0,0 +1,23 @@
+# -*- tcl -*-
+#
+# -- Null format (doctoc)
+#
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# This is a null format which does return no output at all.
+
+################################################################
+
+proc toc_initialize {} {return}
+proc toc_shutdown {} {return}
+proc toc_numpasses {} {return 1}
+proc toc_postprocess {text} {return ""}
+proc toc_setup {n} {return}
+
+foreach p {
+ toc_begin toc_end item division_start division_end comment plain_text
+} {
+ proc fmt_$p {args} {return ""}
+}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/toc.text b/tcllib/modules/doctools/mpformats/toc.text
new file mode 100644
index 0000000..7215550
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/toc.text
@@ -0,0 +1,88 @@
+# -*- tcl -*-
+#
+# $Id: toc.text,v 1.8 2010/06/08 19:13:53 andreas_kupries Exp $
+#
+# Engine to convert a doctoc document into plain text.
+#
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+# Freely redistributable.
+#
+######################################################################
+
+dt_source _toc_common.tcl
+dt_source _text.tcl
+
+######################################################################
+# Conversion specification.
+# One-pass processing.
+
+rename toc_postprocess {}
+rename text_postprocess toc_postprocess
+
+proc fmt_plain_text {text} {return {}}
+
+################################################################
+## Backend for TMML markup
+
+global seclist ; set seclist {}
+global max ; set max 0
+
+proc fmt_comment {text} {return}
+proc fmt_toc_end {} {return}
+proc fmt_toc_begin {label title} {
+ TextInitialize
+
+ set title "$label -- $title"
+ set hdr ""
+ append hdr "Table of contents [textutil::string::uncap [c_provenance]]\n"
+ append hdr \n
+ append hdr $title \n
+ append hdr [textutil::repeat::strRepeat = [string length $title]]
+ Text $hdr
+ CloseParagraph [Verbatim]
+}
+proc fmt_division_start {title symfile} {
+ global lmarginIncrement currentEnv
+ global seclist ; set seclist {}
+ global max ; set max 0
+
+ Text $title\n
+ Text [textutil::repeat::strRepeat - [string length $title]]
+ CloseParagraph [Verbatim]
+ SaveContext
+ NewEnv Division {
+ incr currentEnv(lmargin) $lmarginIncrement
+ }
+ return
+}
+proc fmt_division_end {} {
+ global seclist max
+
+ if {[llength $seclist] > 0} {
+ set break 0
+ incr max 2
+ set rmargin [expr {80 - $max}]
+ if {$rmargin < 20} {set rmargin 20}
+ set pfx [textutil::blank $max]
+ incr max -1
+ set fpfx "[textutil::repeat::strRepeat . $max] "
+
+ foreach {file desc} $seclist {
+ set opfx "$file [string range $fpfx [string length $file] end]"
+ Text $opfx[textutil::adjust::indent [textutil::adjust::adjust $desc -length $rmargin] $pfx 1]
+ CloseParagraph [Verbatim]
+ }
+ set seclist {}
+ }
+
+ RestoreContext
+ return
+}
+proc fmt_item {file label desc} {
+ global seclist max
+ lappend seclist $file $desc
+ if {[string length $file] > $max} {set max [string length $file]}
+ return
+}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/toc.tmml b/tcllib/modules/doctools/mpformats/toc.tmml
new file mode 100644
index 0000000..d0ec261
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/toc.tmml
@@ -0,0 +1,37 @@
+# -*- tcl -*-
+#
+# $Id: toc.tmml,v 1.6 2005/09/28 04:51:19 andreas_kupries Exp $
+#
+# Engine to convert a doctoc document into TMML.
+#
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+# Freely redistributable.
+#
+# See also <URL: http://tmml.sourceforge.net>
+#
+######################################################################
+
+dt_source _toc_common.tcl
+dt_source _xml.tcl
+
+######################################################################
+# Conversion specification.
+#
+# One-pass processing.
+
+rename toc_postprocess {}
+rename fmt_postprocess toc_postprocess
+
+proc fmt_plain_text {text} {if {$text != {}} {return \n} else {return {}}}
+
+################################################################
+## Backend for TMML markup
+
+proc fmt_toc_begin {label title} {sequence [start manual package $label] [wrap $title title]}
+proc fmt_toc_end {} {end manual}
+proc fmt_division_start {title symfile} {sequence [start division] [wrap $text title]}
+proc fmt_division_end {} {end division}
+proc fmt_item {file label desc} {emptyElement subdoc href [dt_fmap $file]}
+proc fmt_comment {text} {xmlComment $text}
+
+################################################################
diff --git a/tcllib/modules/doctools/mpformats/toc.wiki b/tcllib/modules/doctools/mpformats/toc.wiki
new file mode 100644
index 0000000..271285e
--- /dev/null
+++ b/tcllib/modules/doctools/mpformats/toc.wiki
@@ -0,0 +1,63 @@
+# -*- tcl -*-
+#
+# $Id: toc.wiki,v 1.6 2005/09/28 04:51:19 andreas_kupries Exp $
+#
+# Engine to convert a doctoc document into Wiki markup.
+#
+# Copyright (c) 2003 Andreas Kupries <andreas_kupries@sourceforge.net>
+# Freely redistributable.
+#
+######################################################################
+
+dt_source _toc_common.tcl ; # Shared code
+
+######################################################################
+
+proc toc_postprocess {wiki} {
+ # Strip empty lines out of the generated wiki source
+ # and trim leading blanks, except in code samples.
+ #
+ set lines [list]
+ foreach line [split $wiki \n] {
+ if {[string match " |*" $line]} {
+ # Verbatim / example
+ lappend lines [string trimright $line]
+ } elseif {[string match ". *" $line]} {
+ # Verbatim / regular
+ lappend lines [string range [string trimright $line] 1 end]
+ } elseif {[string match " \* *" $line]} {
+ # Itemized lists.
+ lappend lines [string map {[ [[ ] ]]} [string trimright $line]]
+ } elseif {[string match " 1. *" $line]} {
+ # Enumerated lists
+ lappend lines [string map {[ [[ ] ]]} [string trimright $line]]
+ } elseif {[regexp "^ (\[^:\]): " $line]} {
+ # Definition list
+ lappend lines [string map {[ [[ ] ]]} [string trimright $line]]
+ } elseif {[string match " *" $line]} {
+ # Unwanted indentation
+ lappend lines [string map {[ [[ ] ]]} [string trim $line]]
+ } else {
+ # Everything else
+ lappend lines [string map {[ [[ ] ]]} [string trimright $line]]
+ }
+ }
+ set wiki [join $lines \n]\n
+
+ regsub {^[ ]+} $wiki {} wiki
+ return $wiki
+}
+
+proc fmt_plain_text {text} {if {$text != {}} {return \n} else {return {}}}
+
+################################################################
+## Backend for wiki markup
+
+proc fmt_toc_begin {label title} {return "Table of Contents '''$label'''\n'''[string trim $title]'''"}
+proc fmt_toc_end {} {return {}}
+proc fmt_division_start {title symfile} {return '''[string trim $title]'''}
+proc fmt_division_end {} {return {}}
+proc fmt_item {file label desc} {return " \[$label\]: $file -- $desc"}
+proc fmt_comment {text} {return {}}
+
+################################################################
diff --git a/tcllib/modules/doctools/pkgIndex.tcl b/tcllib/modules/doctools/pkgIndex.tcl
new file mode 100644
index 0000000..eabd037
--- /dev/null
+++ b/tcllib/modules/doctools/pkgIndex.tcl
@@ -0,0 +1,6 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded doctools 1.4.19 [list source [file join $dir doctools.tcl]]
+package ifneeded doctools::toc 1.1.4 [list source [file join $dir doctoc.tcl]]
+package ifneeded doctools::idx 1.0.5 [list source [file join $dir docidx.tcl]]
+package ifneeded doctools::cvs 1 [list source [file join $dir cvs.tcl]]
+package ifneeded doctools::changelog 1.1 [list source [file join $dir changelog.tcl]]
diff --git a/tcllib/modules/doctools/tests/desc/00 b/tcllib/modules/doctools/tests/desc/00
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/desc/00
diff --git a/tcllib/modules/doctools/tests/desc/01 b/tcllib/modules/doctools/tests/desc/01
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/desc/01
diff --git a/tcllib/modules/doctools/tests/desc/02 b/tcllib/modules/doctools/tests/desc/02
new file mode 100644
index 0000000..e694867
--- /dev/null
+++ b/tcllib/modules/doctools/tests/desc/02
@@ -0,0 +1,2 @@
+AAA ..THE_MODULE.. ..THE_TITLE..
+BBB ..THE_MODULE.. ..THE_TITLE.. \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/desc/03 b/tcllib/modules/doctools/tests/desc/03
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/desc/03
diff --git a/tcllib/modules/doctools/tests/desc/04 b/tcllib/modules/doctools/tests/desc/04
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/desc/04
diff --git a/tcllib/modules/doctools/tests/desc/05 b/tcllib/modules/doctools/tests/desc/05
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/desc/05
diff --git a/tcllib/modules/doctools/tests/desc/06 b/tcllib/modules/doctools/tests/desc/06
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/desc/06
diff --git a/tcllib/modules/doctools/tests/desc/07 b/tcllib/modules/doctools/tests/desc/07
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/desc/07
diff --git a/tcllib/modules/doctools/tests/desc/08 b/tcllib/modules/doctools/tests/desc/08
new file mode 100644
index 0000000..9414a5b
--- /dev/null
+++ b/tcllib/modules/doctools/tests/desc/08
@@ -0,0 +1,3 @@
+AAA ..THE_MODULE.. ..THE_TITLE..
+BBB ..THE_MODULE.. ..THE_TITLE..
+CCC ..THE_MODULE.. ..THE_TITLE.. \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/html/00 b/tcllib/modules/doctools/tests/html/00
new file mode 100644
index 0000000..b442cba
--- /dev/null
+++ b/tcllib/modules/doctools/tests/html/00
@@ -0,0 +1,117 @@
+<html><head>
+<title>TEST - </title>
+<style type="text/css"><!--
+ HTML {
+ background: #FFFFFF;
+ color: black;
+ }
+ BODY {
+ background: #FFFFFF;
+ color: black;
+ }
+ DIV.doctools {
+ margin-left: 10%;
+ margin-right: 10%;
+ }
+ DIV.doctools H1,DIV.doctools H2 {
+ margin-left: -5%;
+ }
+ H1, H2, H3, H4 {
+ margin-top: 1em;
+ font-family: sans-serif;
+ font-size: large;
+ color: #005A9C;
+ background: transparent;
+ text-align: left;
+ }
+ H1.doctools_title {
+ text-align: center;
+ }
+ UL,OL {
+ margin-right: 0em;
+ margin-top: 3pt;
+ margin-bottom: 3pt;
+ }
+ UL LI {
+ list-style: disc;
+ }
+ OL LI {
+ list-style: decimal;
+ }
+ DT {
+ padding-top: 1ex;
+ }
+ UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL {
+ font: normal 12pt/14pt sans-serif;
+ list-style: none;
+ }
+ LI.doctools_section, LI.doctools_subsection {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ PRE {
+ display: block;
+ font-family: monospace;
+ white-space: pre;
+ margin: 0%;
+ padding-top: 0.5ex;
+ padding-bottom: 0.5ex;
+ padding-left: 1ex;
+ padding-right: 1ex;
+ width: 100%;
+ }
+ PRE.doctools_example {
+ color: black;
+ background: #f5dcb3;
+ border: 1px solid black;
+ }
+ UL.doctools_requirements LI, UL.doctools_syntax LI {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ DIV.doctools_synopsis {
+ color: black;
+ background: #80ffff;
+ border: 1px solid black;
+ font-family: serif;
+ margin-top: 1em;
+ margin-bottom: 1em;
+ }
+ UL.doctools_syntax {
+ margin-top: 1em;
+ border-top: 1px solid black;
+ }
+ UL.doctools_requirements {
+ margin-bottom: 1em;
+ border-bottom: 1px solid black;
+ }
+--></style>
+</head>
+<! -- Generated from file '.FILE.' by tcllib/doctools with format 'html'
+ -->
+<! -- Copyright &copy; .COPYRIGHT.
+ -->
+<! -- TEST.z
+ -->
+<body><div class="doctools">
+<h1 class="doctools_title">TEST(z) 3.14.15.926 .MODULE. &quot;&quot;</h1>
+<div id="name" class="doctools_section"><h2><a name="name">Name</a></h2>
+<p>TEST -</p>
+</div>
+<div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2>
+<ul class="doctools_toc">
+<li class="doctools_section"><a href="#toc">Table Of Contents</a></li>
+<li class="doctools_section"><a href="#section1">Description</a></li>
+<li class="doctools_section"><a href="#copyright">Copyright</a></li>
+</ul>
+</div>
+<div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2>
+</div>
+<div id="copyright" class="doctools_section"><h2><a name="copyright">Copyright</a></h2>
+<p>Copyright &copy; .COPYRIGHT.</p>
+</div>
+</div></body></html>
diff --git a/tcllib/modules/doctools/tests/html/01 b/tcllib/modules/doctools/tests/html/01
new file mode 100644
index 0000000..cf1b91a
--- /dev/null
+++ b/tcllib/modules/doctools/tests/html/01
@@ -0,0 +1,136 @@
+<html><head>
+<title>TEST - </title>
+<style type="text/css"><!--
+ HTML {
+ background: #FFFFFF;
+ color: black;
+ }
+ BODY {
+ background: #FFFFFF;
+ color: black;
+ }
+ DIV.doctools {
+ margin-left: 10%;
+ margin-right: 10%;
+ }
+ DIV.doctools H1,DIV.doctools H2 {
+ margin-left: -5%;
+ }
+ H1, H2, H3, H4 {
+ margin-top: 1em;
+ font-family: sans-serif;
+ font-size: large;
+ color: #005A9C;
+ background: transparent;
+ text-align: left;
+ }
+ H1.doctools_title {
+ text-align: center;
+ }
+ UL,OL {
+ margin-right: 0em;
+ margin-top: 3pt;
+ margin-bottom: 3pt;
+ }
+ UL LI {
+ list-style: disc;
+ }
+ OL LI {
+ list-style: decimal;
+ }
+ DT {
+ padding-top: 1ex;
+ }
+ UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL {
+ font: normal 12pt/14pt sans-serif;
+ list-style: none;
+ }
+ LI.doctools_section, LI.doctools_subsection {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ PRE {
+ display: block;
+ font-family: monospace;
+ white-space: pre;
+ margin: 0%;
+ padding-top: 0.5ex;
+ padding-bottom: 0.5ex;
+ padding-left: 1ex;
+ padding-right: 1ex;
+ width: 100%;
+ }
+ PRE.doctools_example {
+ color: black;
+ background: #f5dcb3;
+ border: 1px solid black;
+ }
+ UL.doctools_requirements LI, UL.doctools_syntax LI {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ DIV.doctools_synopsis {
+ color: black;
+ background: #80ffff;
+ border: 1px solid black;
+ font-family: serif;
+ margin-top: 1em;
+ margin-bottom: 1em;
+ }
+ UL.doctools_syntax {
+ margin-top: 1em;
+ border-top: 1px solid black;
+ }
+ UL.doctools_requirements {
+ margin-bottom: 1em;
+ border-bottom: 1px solid black;
+ }
+--></style>
+</head>
+<! -- Generated from file '.FILE.' by tcllib/doctools with format 'html'
+ -->
+<! -- Copyright &copy; **Copyright**
+ -->
+<! -- TEST.z
+ -->
+<body><div class="doctools">
+<h1 class="doctools_title">TEST(z) 3.14.15.926 .MODULE. &quot;&quot;</h1>
+<div id="name" class="doctools_section"><h2><a name="name">Name</a></h2>
+<p>TEST -</p>
+</div>
+<div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2>
+<ul class="doctools_toc">
+<li class="doctools_section"><a href="#toc">Table Of Contents</a></li>
+<li class="doctools_section"><a href="#section1">Description</a></li>
+<li class="doctools_section"><a href="#copyright">Copyright</a></li>
+</ul>
+</div>
+<div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2>
+<p>Argument ::<i class="arg">Argument</i>::
+Class ::<b class="class">Class</b>::
+Command ::<b class="cmd">Command</b>::
+Comment ::::
+Const ::<b class="const">Constant</b>::
+Emphasis ::<em>Emphasis</em>::
+File ::&quot;<b class="file">File/Path</b>&quot;::
+Function ::<b class="function">Function</b>::
+Method ::<b class="method">Method</b>::
+Namespace ::<b class="namespace">Namespace</b>::
+Option ::<b class="option">Option</b>::
+Optional ::<span class="opt">?Optional?</span>::
+Package ::<b class="package">Package</b>::
+Syscmd ::<b class="syscmd">SystemCommand</b>::
+Term ::<i class="term">Term</i>::
+Type ::<b class="type">Type</b>::
+Uri ::<a href="Uri">Uri</a>::
+Variable ::<b class="variable">Variable</b>::
+Widget ::<b class="widget">Widget</b>::</p>
+</div>
+<div id="copyright" class="doctools_section"><h2><a name="copyright">Copyright</a></h2>
+<p>Copyright &copy; **Copyright**</p>
+</div>
+</div></body></html>
diff --git a/tcllib/modules/doctools/tests/html/02 b/tcllib/modules/doctools/tests/html/02
new file mode 100644
index 0000000..6418e3a
--- /dev/null
+++ b/tcllib/modules/doctools/tests/html/02
@@ -0,0 +1,134 @@
+<html><head>
+<title>TEST - ..THE_MODULE..</title>
+<style type="text/css"><!--
+ HTML {
+ background: #FFFFFF;
+ color: black;
+ }
+ BODY {
+ background: #FFFFFF;
+ color: black;
+ }
+ DIV.doctools {
+ margin-left: 10%;
+ margin-right: 10%;
+ }
+ DIV.doctools H1,DIV.doctools H2 {
+ margin-left: -5%;
+ }
+ H1, H2, H3, H4 {
+ margin-top: 1em;
+ font-family: sans-serif;
+ font-size: large;
+ color: #005A9C;
+ background: transparent;
+ text-align: left;
+ }
+ H1.doctools_title {
+ text-align: center;
+ }
+ UL,OL {
+ margin-right: 0em;
+ margin-top: 3pt;
+ margin-bottom: 3pt;
+ }
+ UL LI {
+ list-style: disc;
+ }
+ OL LI {
+ list-style: decimal;
+ }
+ DT {
+ padding-top: 1ex;
+ }
+ UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL {
+ font: normal 12pt/14pt sans-serif;
+ list-style: none;
+ }
+ LI.doctools_section, LI.doctools_subsection {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ PRE {
+ display: block;
+ font-family: monospace;
+ white-space: pre;
+ margin: 0%;
+ padding-top: 0.5ex;
+ padding-bottom: 0.5ex;
+ padding-left: 1ex;
+ padding-right: 1ex;
+ width: 100%;
+ }
+ PRE.doctools_example {
+ color: black;
+ background: #f5dcb3;
+ border: 1px solid black;
+ }
+ UL.doctools_requirements LI, UL.doctools_syntax LI {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ DIV.doctools_synopsis {
+ color: black;
+ background: #80ffff;
+ border: 1px solid black;
+ font-family: serif;
+ margin-top: 1em;
+ margin-bottom: 1em;
+ }
+ UL.doctools_syntax {
+ margin-top: 1em;
+ border-top: 1px solid black;
+ }
+ UL.doctools_requirements {
+ margin-bottom: 1em;
+ border-bottom: 1px solid black;
+ }
+--></style>
+</head>
+<! -- Generated from file '.FILE.' by tcllib/doctools with format 'html'
+ -->
+<! -- Copyright &copy; .COPYRIGHT.
+ -->
+<! -- TEST.z
+ -->
+<body><div class="doctools">
+<h1 class="doctools_title">TEST(z) 3.14.15.926 .MODULE. &quot;..THE_MODULE..&quot;</h1>
+<div id="name" class="doctools_section"><h2><a name="name">Name</a></h2>
+<p>TEST - ..THE_TITLE..</p>
+</div>
+<div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2>
+<ul class="doctools_toc">
+<li class="doctools_section"><a href="#toc">Table Of Contents</a></li>
+<li class="doctools_section"><a href="#synopsis">Synopsis</a></li>
+<li class="doctools_section"><a href="#section1">Description</a></li>
+<li class="doctools_section"><a href="#see-also">See Also</a></li>
+<li class="doctools_section"><a href="#keywords">Keywords</a></li>
+<li class="doctools_section"><a href="#copyright">Copyright</a></li>
+</ul>
+</div>
+<div id="synopsis" class="doctools_section"><h2><a name="synopsis">Synopsis</a></h2>
+<div class="doctools_synopsis">
+<ul class="doctools_requirements">
+<li>package require <b class="pkgname">AAA</b></li>
+<li>package require <b class="pkgname">BBB VVV</b></li>
+</ul>
+</div>
+</div>
+<div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2>
+</div>
+<div id="see-also" class="doctools_section"><h2><a name="see-also">See Also</a></h2>
+<p>ELSE, OTHER</p>
+</div>
+<div id="keywords" class="doctools_section"><h2><a name="keywords">Keywords</a></h2>
+<p>KEYA, KEYZ</p>
+</div>
+<div id="copyright" class="doctools_section"><h2><a name="copyright">Copyright</a></h2>
+<p>Copyright &copy; .COPYRIGHT.</p>
+</div>
+</div></body></html>
diff --git a/tcllib/modules/doctools/tests/html/03 b/tcllib/modules/doctools/tests/html/03
new file mode 100644
index 0000000..65a2b0f
--- /dev/null
+++ b/tcllib/modules/doctools/tests/html/03
@@ -0,0 +1,142 @@
+<html><head>
+<title>TEST - </title>
+<style type="text/css"><!--
+ HTML {
+ background: #FFFFFF;
+ color: black;
+ }
+ BODY {
+ background: #FFFFFF;
+ color: black;
+ }
+ DIV.doctools {
+ margin-left: 10%;
+ margin-right: 10%;
+ }
+ DIV.doctools H1,DIV.doctools H2 {
+ margin-left: -5%;
+ }
+ H1, H2, H3, H4 {
+ margin-top: 1em;
+ font-family: sans-serif;
+ font-size: large;
+ color: #005A9C;
+ background: transparent;
+ text-align: left;
+ }
+ H1.doctools_title {
+ text-align: center;
+ }
+ UL,OL {
+ margin-right: 0em;
+ margin-top: 3pt;
+ margin-bottom: 3pt;
+ }
+ UL LI {
+ list-style: disc;
+ }
+ OL LI {
+ list-style: decimal;
+ }
+ DT {
+ padding-top: 1ex;
+ }
+ UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL {
+ font: normal 12pt/14pt sans-serif;
+ list-style: none;
+ }
+ LI.doctools_section, LI.doctools_subsection {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ PRE {
+ display: block;
+ font-family: monospace;
+ white-space: pre;
+ margin: 0%;
+ padding-top: 0.5ex;
+ padding-bottom: 0.5ex;
+ padding-left: 1ex;
+ padding-right: 1ex;
+ width: 100%;
+ }
+ PRE.doctools_example {
+ color: black;
+ background: #f5dcb3;
+ border: 1px solid black;
+ }
+ UL.doctools_requirements LI, UL.doctools_syntax LI {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ DIV.doctools_synopsis {
+ color: black;
+ background: #80ffff;
+ border: 1px solid black;
+ font-family: serif;
+ margin-top: 1em;
+ margin-bottom: 1em;
+ }
+ UL.doctools_syntax {
+ margin-top: 1em;
+ border-top: 1px solid black;
+ }
+ UL.doctools_requirements {
+ margin-bottom: 1em;
+ border-bottom: 1px solid black;
+ }
+--></style>
+</head>
+<! -- Generated from file '.FILE.' by tcllib/doctools with format 'html'
+ -->
+<! -- Copyright &copy; .COPYRIGHT.
+ -->
+<! -- TEST.z
+ -->
+<body><div class="doctools">
+<h1 class="doctools_title">TEST(z) 3.14.15.926 .MODULE. &quot;&quot;</h1>
+<div id="name" class="doctools_section"><h2><a name="name">Name</a></h2>
+<p>TEST -</p>
+</div>
+<div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2>
+<ul class="doctools_toc">
+<li class="doctools_section"><a href="#toc">Table Of Contents</a></li>
+<li class="doctools_section"><a href="#section1">Description</a></li>
+<li class="doctools_section"><a href="#section2">AaA</a></li>
+<li class="doctools_section"><a href="#section3">BbB</a>
+<ul>
+<li class="doctools_subsection"><a href="#subsection1">BbB.cCc</a></li>
+<li class="doctools_subsection"><a href="#subsection2">BbB.dDd</a></li>
+</ul>
+</li>
+<li class="doctools_section"><a href="#section4">EeE</a></li>
+<li class="doctools_section"><a href="#copyright">Copyright</a></li>
+</ul>
+</div>
+<div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2>
+</div>
+<div id="section2" class="doctools_section"><h2><a name="section2">AaA</a></h2>
+<p>1</p>
+</div>
+<div id="section3" class="doctools_section"><h2><a name="section3">BbB</a></h2>
+<p>22</p>
+<div id="subsection1" class="doctools_subsection"><h3><a name="subsection1">BbB.cCc</a></h3>
+<p>333</p>
+</div>
+<div id="subsection2" class="doctools_subsection"><h3><a name="subsection2">BbB.dDd</a></h3>
+<p>4444</p>
+</div>
+</div>
+<div id="section4" class="doctools_section"><h2><a name="section4">EeE</a></h2>
+<p>5555</p>
+<p>At <span class="sectref"><a href="#section2">AaA</a></span>.</p>
+<p>At <b class="sectref">__undefined__</b>.</p>
+</div>
+<div id="copyright" class="doctools_section"><h2><a name="copyright">Copyright</a></h2>
+<p>Copyright &copy; .COPYRIGHT.</p>
+</div>
+</div></body></html>
diff --git a/tcllib/modules/doctools/tests/html/04 b/tcllib/modules/doctools/tests/html/04
new file mode 100644
index 0000000..82fdcfc
--- /dev/null
+++ b/tcllib/modules/doctools/tests/html/04
@@ -0,0 +1,126 @@
+<html><head>
+<title>TEST - </title>
+<style type="text/css"><!--
+ HTML {
+ background: #FFFFFF;
+ color: black;
+ }
+ BODY {
+ background: #FFFFFF;
+ color: black;
+ }
+ DIV.doctools {
+ margin-left: 10%;
+ margin-right: 10%;
+ }
+ DIV.doctools H1,DIV.doctools H2 {
+ margin-left: -5%;
+ }
+ H1, H2, H3, H4 {
+ margin-top: 1em;
+ font-family: sans-serif;
+ font-size: large;
+ color: #005A9C;
+ background: transparent;
+ text-align: left;
+ }
+ H1.doctools_title {
+ text-align: center;
+ }
+ UL,OL {
+ margin-right: 0em;
+ margin-top: 3pt;
+ margin-bottom: 3pt;
+ }
+ UL LI {
+ list-style: disc;
+ }
+ OL LI {
+ list-style: decimal;
+ }
+ DT {
+ padding-top: 1ex;
+ }
+ UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL {
+ font: normal 12pt/14pt sans-serif;
+ list-style: none;
+ }
+ LI.doctools_section, LI.doctools_subsection {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ PRE {
+ display: block;
+ font-family: monospace;
+ white-space: pre;
+ margin: 0%;
+ padding-top: 0.5ex;
+ padding-bottom: 0.5ex;
+ padding-left: 1ex;
+ padding-right: 1ex;
+ width: 100%;
+ }
+ PRE.doctools_example {
+ color: black;
+ background: #f5dcb3;
+ border: 1px solid black;
+ }
+ UL.doctools_requirements LI, UL.doctools_syntax LI {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ DIV.doctools_synopsis {
+ color: black;
+ background: #80ffff;
+ border: 1px solid black;
+ font-family: serif;
+ margin-top: 1em;
+ margin-bottom: 1em;
+ }
+ UL.doctools_syntax {
+ margin-top: 1em;
+ border-top: 1px solid black;
+ }
+ UL.doctools_requirements {
+ margin-bottom: 1em;
+ border-bottom: 1px solid black;
+ }
+--></style>
+</head>
+<! -- Generated from file '.FILE.' by tcllib/doctools with format 'html'
+ -->
+<! -- Copyright &copy; .COPYRIGHT.
+ -->
+<! -- TEST.z
+ -->
+<body><div class="doctools">
+<h1 class="doctools_title">TEST(z) 3.14.15.926 .MODULE. &quot;&quot;</h1>
+<div id="name" class="doctools_section"><h2><a name="name">Name</a></h2>
+<p>TEST -</p>
+</div>
+<div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2>
+<ul class="doctools_toc">
+<li class="doctools_section"><a href="#toc">Table Of Contents</a></li>
+<li class="doctools_section"><a href="#section1">Description</a></li>
+<li class="doctools_section"><a href="#copyright">Copyright</a></li>
+</ul>
+</div>
+<div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2>
+<p>BEGINNE HIER</p>
+<pre class="doctools_example">
+ Example Block More Lines
+</pre>
+<pre class="doctools_example">
+Inlined Example \
+Next Line
+</pre>
+<p>FERTIG</p>
+</div>
+<div id="copyright" class="doctools_section"><h2><a name="copyright">Copyright</a></h2>
+<p>Copyright &copy; .COPYRIGHT.</p>
+</div>
+</div></body></html>
diff --git a/tcllib/modules/doctools/tests/html/05 b/tcllib/modules/doctools/tests/html/05
new file mode 100644
index 0000000..b46ba50
--- /dev/null
+++ b/tcllib/modules/doctools/tests/html/05
@@ -0,0 +1,176 @@
+
+<html><head>
+<title>BASIC - </title>
+<style type="text/css"><!--
+ HTML {
+ background: #FFFFFF;
+ color: black;
+ }
+ BODY {
+ background: #FFFFFF;
+ color: black;
+ }
+ DIV.doctools {
+ margin-left: 10%;
+ margin-right: 10%;
+ }
+ DIV.doctools H1,DIV.doctools H2 {
+ margin-left: -5%;
+ }
+ H1, H2, H3, H4 {
+ margin-top: 1em;
+ font-family: sans-serif;
+ font-size: large;
+ color: #005A9C;
+ background: transparent;
+ text-align: left;
+ }
+ H1.doctools_title {
+ text-align: center;
+ }
+ UL,OL {
+ margin-right: 0em;
+ margin-top: 3pt;
+ margin-bottom: 3pt;
+ }
+ UL LI {
+ list-style: disc;
+ }
+ OL LI {
+ list-style: decimal;
+ }
+ DT {
+ padding-top: 1ex;
+ }
+ UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL {
+ font: normal 12pt/14pt sans-serif;
+ list-style: none;
+ }
+ LI.doctools_section, LI.doctools_subsection {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ PRE {
+ display: block;
+ font-family: monospace;
+ white-space: pre;
+ margin: 0%;
+ padding-top: 0.5ex;
+ padding-bottom: 0.5ex;
+ padding-left: 1ex;
+ padding-right: 1ex;
+ width: 100%;
+ }
+ PRE.doctools_example {
+ color: black;
+ background: #f5dcb3;
+ border: 1px solid black;
+ }
+ UL.doctools_requirements LI, UL.doctools_syntax LI {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ DIV.doctools_synopsis {
+ color: black;
+ background: #80ffff;
+ border: 1px solid black;
+ font-family: serif;
+ margin-top: 1em;
+ margin-bottom: 1em;
+ }
+ UL.doctools_syntax {
+ margin-top: 1em;
+ border-top: 1px solid black;
+ }
+ UL.doctools_requirements {
+ margin-bottom: 1em;
+ border-bottom: 1px solid black;
+ }
+--></style>
+</head>
+<! -- Generated from file '.FILE.' by tcllib/doctools with format 'html'
+ -->
+<! -- Copyright &copy; .COPYRIGHT.
+ -->
+<! -- BASIC.a
+ -->
+<body><div class="doctools">
+<h1 class="doctools_title">BASIC(a) 5 .MODULE. &quot;&quot;</h1>
+<div id="name" class="doctools_section"><h2><a name="name">Name</a></h2>
+<p>BASIC -</p>
+</div>
+<div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2>
+<ul class="doctools_toc">
+<li class="doctools_section"><a href="#toc">Table Of Contents</a></li>
+<li class="doctools_section"><a href="#synopsis">Synopsis</a></li>
+<li class="doctools_section"><a href="#section1">Description</a></li>
+<li class="doctools_section"><a href="#copyright">Copyright</a></li>
+</ul>
+</div>
+<div id="synopsis" class="doctools_section"><h2><a name="synopsis">Synopsis</a></h2>
+<div class="doctools_synopsis">
+<ul class="doctools_syntax">
+<li><a href="#1">a-command</a></li>
+</ul>
+</div>
+</div>
+<div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2>
+<p>OK</p>
+<dl class="doctools_arguments">
+<dt>integer <i class="arg">argument-1</i></dt>
+<dd><p>verification</p></dd>
+<dt>string <i class="arg">argument-2</i> (out)</dt>
+<dd><p>mogrification</p></dd>
+</dl>
+<dl class="doctools_commands">
+<dt><b class="cmd">command-a</b></dt>
+<dd><p>explanation</p></dd>
+<dt><b class="cmd">command-b</b></dt>
+<dd><p>elucidation</p></dd>
+</dl>
+<dl class="doctools_definitions">
+<dt>term</dt>
+<dd><p>definition</p></dd>
+<dt><a name="1">a-command</a></dt>
+<dd><p>semantic</p></dd>
+</dl>
+<ol class="doctools_enumerated">
+<li><p>A</p></li>
+<li><p>B</p>
+<p>C</p>
+<p>D</p></li>
+</ol>
+<ul class="doctools_itemized">
+<li><p>1</p></li>
+<li><p>2</p>
+<p>2a</p>
+<p>2b</p></li>
+</ul>
+<dl class="doctools_options">
+<dt><b class="option">option-1</b></dt>
+<dd><p>meaning</p></dd>
+<dt><b class="option">option-2</b> value</dt>
+<dd><p>elaboration</p></dd>
+</dl>
+<dl class="doctools_tkoptions">
+<dt>Command-Line Switch: <b class="option">background</b><br>
+Database Name: <b class="optdbname">Background</b><br>
+Database Class: <b class="optdbclass">Color</b><br>
+</dt>
+<dd><p>candy</p></dd>
+<dt>Command-Line Switch: <b class="option">foreground</b><br>
+Database Name: <b class="optdbname">Foreground</b><br>
+Database Class: <b class="optdbclass">Color</b><br>
+</dt>
+<dd><p>caramel</p></dd>
+</dl>
+<p>KO</p>
+</div>
+<div id="copyright" class="doctools_section"><h2><a name="copyright">Copyright</a></h2>
+<p>Copyright &copy; .COPYRIGHT.</p>
+</div>
+</div></body></html>
diff --git a/tcllib/modules/doctools/tests/html/06 b/tcllib/modules/doctools/tests/html/06
new file mode 100644
index 0000000..145e6ef
--- /dev/null
+++ b/tcllib/modules/doctools/tests/html/06
@@ -0,0 +1,145 @@
+<html><head>
+<title>TEST - </title>
+<style type="text/css"><!--
+ HTML {
+ background: #FFFFFF;
+ color: black;
+ }
+ BODY {
+ background: #FFFFFF;
+ color: black;
+ }
+ DIV.doctools {
+ margin-left: 10%;
+ margin-right: 10%;
+ }
+ DIV.doctools H1,DIV.doctools H2 {
+ margin-left: -5%;
+ }
+ H1, H2, H3, H4 {
+ margin-top: 1em;
+ font-family: sans-serif;
+ font-size: large;
+ color: #005A9C;
+ background: transparent;
+ text-align: left;
+ }
+ H1.doctools_title {
+ text-align: center;
+ }
+ UL,OL {
+ margin-right: 0em;
+ margin-top: 3pt;
+ margin-bottom: 3pt;
+ }
+ UL LI {
+ list-style: disc;
+ }
+ OL LI {
+ list-style: decimal;
+ }
+ DT {
+ padding-top: 1ex;
+ }
+ UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL {
+ font: normal 12pt/14pt sans-serif;
+ list-style: none;
+ }
+ LI.doctools_section, LI.doctools_subsection {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ PRE {
+ display: block;
+ font-family: monospace;
+ white-space: pre;
+ margin: 0%;
+ padding-top: 0.5ex;
+ padding-bottom: 0.5ex;
+ padding-left: 1ex;
+ padding-right: 1ex;
+ width: 100%;
+ }
+ PRE.doctools_example {
+ color: black;
+ background: #f5dcb3;
+ border: 1px solid black;
+ }
+ UL.doctools_requirements LI, UL.doctools_syntax LI {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ DIV.doctools_synopsis {
+ color: black;
+ background: #80ffff;
+ border: 1px solid black;
+ font-family: serif;
+ margin-top: 1em;
+ margin-bottom: 1em;
+ }
+ UL.doctools_syntax {
+ margin-top: 1em;
+ border-top: 1px solid black;
+ }
+ UL.doctools_requirements {
+ margin-bottom: 1em;
+ border-bottom: 1px solid black;
+ }
+--></style>
+</head>
+<! -- Generated from file '.FILE.' by tcllib/doctools with format 'html'
+ -->
+<! -- Copyright &copy; .COPYRIGHT.
+ -->
+<! -- TEST.z
+ -->
+<body><div class="doctools">
+<h1 class="doctools_title">TEST(z) 3.14.15.926 .MODULE. &quot;&quot;</h1>
+<div id="name" class="doctools_section"><h2><a name="name">Name</a></h2>
+<p>TEST -</p>
+</div>
+<div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2>
+<ul class="doctools_toc">
+<li class="doctools_section"><a href="#toc">Table Of Contents</a></li>
+<li class="doctools_section"><a href="#section1">Description</a></li>
+<li class="doctools_section"><a href="#copyright">Copyright</a></li>
+</ul>
+</div>
+<div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2>
+<ul class="doctools_itemized">
+<li><p>1</p>
+<p>2</p>
+<p>3</p></li>
+<li>
+<ol class="doctools_enumerated">
+<li><p>a</p>
+<p>b</p>
+<p>c</p></li>
+<li>
+<dl class="doctools_definitions">
+<dt>foo</dt>
+<dd><p>snafu</p></dd>
+<dt>bar</dt>
+<dd><p>barf</p></dd>
+<dt>roo</dt>
+<dd><p>gork</p></dd>
+</dl>
+</li>
+<li><p>a</p>
+<p>b</p>
+<p>c</p></li>
+</ol>
+</li>
+<li><p>4</p>
+<p>5</p>
+<p>6</p></li>
+</ul>
+</div>
+<div id="copyright" class="doctools_section"><h2><a name="copyright">Copyright</a></h2>
+<p>Copyright &copy; .COPYRIGHT.</p>
+</div>
+</div></body></html>
diff --git a/tcllib/modules/doctools/tests/html/07 b/tcllib/modules/doctools/tests/html/07
new file mode 100644
index 0000000..721257e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/html/07
@@ -0,0 +1,137 @@
+<html><head>
+<title>TEST - </title>
+<style type="text/css"><!--
+ HTML {
+ background: #FFFFFF;
+ color: black;
+ }
+ BODY {
+ background: #FFFFFF;
+ color: black;
+ }
+ DIV.doctools {
+ margin-left: 10%;
+ margin-right: 10%;
+ }
+ DIV.doctools H1,DIV.doctools H2 {
+ margin-left: -5%;
+ }
+ H1, H2, H3, H4 {
+ margin-top: 1em;
+ font-family: sans-serif;
+ font-size: large;
+ color: #005A9C;
+ background: transparent;
+ text-align: left;
+ }
+ H1.doctools_title {
+ text-align: center;
+ }
+ UL,OL {
+ margin-right: 0em;
+ margin-top: 3pt;
+ margin-bottom: 3pt;
+ }
+ UL LI {
+ list-style: disc;
+ }
+ OL LI {
+ list-style: decimal;
+ }
+ DT {
+ padding-top: 1ex;
+ }
+ UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL {
+ font: normal 12pt/14pt sans-serif;
+ list-style: none;
+ }
+ LI.doctools_section, LI.doctools_subsection {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ PRE {
+ display: block;
+ font-family: monospace;
+ white-space: pre;
+ margin: 0%;
+ padding-top: 0.5ex;
+ padding-bottom: 0.5ex;
+ padding-left: 1ex;
+ padding-right: 1ex;
+ width: 100%;
+ }
+ PRE.doctools_example {
+ color: black;
+ background: #f5dcb3;
+ border: 1px solid black;
+ }
+ UL.doctools_requirements LI, UL.doctools_syntax LI {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ DIV.doctools_synopsis {
+ color: black;
+ background: #80ffff;
+ border: 1px solid black;
+ font-family: serif;
+ margin-top: 1em;
+ margin-bottom: 1em;
+ }
+ UL.doctools_syntax {
+ margin-top: 1em;
+ border-top: 1px solid black;
+ }
+ UL.doctools_requirements {
+ margin-bottom: 1em;
+ border-bottom: 1px solid black;
+ }
+--></style>
+</head>
+<! -- Generated from file '.FILE.' by tcllib/doctools with format 'html'
+ -->
+<! -- Copyright &copy; .COPYRIGHT.
+ -->
+<! -- TEST.z
+ -->
+<body><div class="doctools">
+<h1 class="doctools_title">TEST(z) 3.14.15.926 .MODULE. &quot;&quot;</h1>
+<div id="name" class="doctools_section"><h2><a name="name">Name</a></h2>
+<p>TEST -</p>
+</div>
+<div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2>
+<ul class="doctools_toc">
+<li class="doctools_section"><a href="#toc">Table Of Contents</a></li>
+<li class="doctools_section"><a href="#section1">Description</a></li>
+<li class="doctools_section"><a href="#copyright">Copyright</a></li>
+</ul>
+</div>
+<div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2>
+<ul class="doctools_itemized">
+<li><p>1</p></li>
+<li><p>2</p>
+<ol class="doctools_enumerated">
+<li><p>a</p></li>
+<li><p>b</p>
+<dl class="doctools_definitions">
+<dt>foo</dt>
+<dd><p>snafu</p></dd>
+<dt>bar</dt>
+<dd><p>barf</p></dd>
+<dt>roo</dt>
+<dd><p>gork</p></dd>
+</dl>
+<p>bb</p></li>
+<li><p>a</p></li>
+</ol>
+<p>22</p></li>
+<li><p>3</p></li>
+</ul>
+</div>
+<div id="copyright" class="doctools_section"><h2><a name="copyright">Copyright</a></h2>
+<p>Copyright &copy; .COPYRIGHT.</p>
+</div>
+</div></body></html>
diff --git a/tcllib/modules/doctools/tests/html/08 b/tcllib/modules/doctools/tests/html/08
new file mode 100644
index 0000000..46cfd2a
--- /dev/null
+++ b/tcllib/modules/doctools/tests/html/08
@@ -0,0 +1,221 @@
+
+<html><head>
+<title>ALL - ..THE_MODULE..</title>
+<style type="text/css"><!--
+ HTML {
+ background: #FFFFFF;
+ color: black;
+ }
+ BODY {
+ background: #FFFFFF;
+ color: black;
+ }
+ DIV.doctools {
+ margin-left: 10%;
+ margin-right: 10%;
+ }
+ DIV.doctools H1,DIV.doctools H2 {
+ margin-left: -5%;
+ }
+ H1, H2, H3, H4 {
+ margin-top: 1em;
+ font-family: sans-serif;
+ font-size: large;
+ color: #005A9C;
+ background: transparent;
+ text-align: left;
+ }
+ H1.doctools_title {
+ text-align: center;
+ }
+ UL,OL {
+ margin-right: 0em;
+ margin-top: 3pt;
+ margin-bottom: 3pt;
+ }
+ UL LI {
+ list-style: disc;
+ }
+ OL LI {
+ list-style: decimal;
+ }
+ DT {
+ padding-top: 1ex;
+ }
+ UL.doctools_toc,UL.doctools_toc UL, UL.doctools_toc UL UL {
+ font: normal 12pt/14pt sans-serif;
+ list-style: none;
+ }
+ LI.doctools_section, LI.doctools_subsection {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ PRE {
+ display: block;
+ font-family: monospace;
+ white-space: pre;
+ margin: 0%;
+ padding-top: 0.5ex;
+ padding-bottom: 0.5ex;
+ padding-left: 1ex;
+ padding-right: 1ex;
+ width: 100%;
+ }
+ PRE.doctools_example {
+ color: black;
+ background: #f5dcb3;
+ border: 1px solid black;
+ }
+ UL.doctools_requirements LI, UL.doctools_syntax LI {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+ }
+ DIV.doctools_synopsis {
+ color: black;
+ background: #80ffff;
+ border: 1px solid black;
+ font-family: serif;
+ margin-top: 1em;
+ margin-bottom: 1em;
+ }
+ UL.doctools_syntax {
+ margin-top: 1em;
+ border-top: 1px solid black;
+ }
+ UL.doctools_requirements {
+ margin-bottom: 1em;
+ border-bottom: 1px solid black;
+ }
+--></style>
+</head>
+<! -- Generated from file '.FILE.' by tcllib/doctools with format 'html'
+ -->
+<! -- Copyright &copy; **Copyright**
+ -->
+<! -- ALL.a
+ -->
+<body><div class="doctools">
+<h1 class="doctools_title">ALL(a) 5 .MODULE. &quot;..THE_MODULE..&quot;</h1>
+<div id="name" class="doctools_section"><h2><a name="name">Name</a></h2>
+<p>ALL - ..THE_TITLE..</p>
+</div>
+<div id="toc" class="doctools_section"><h2><a name="toc">Table Of Contents</a></h2>
+<ul class="doctools_toc">
+<li class="doctools_section"><a href="#toc">Table Of Contents</a></li>
+<li class="doctools_section"><a href="#synopsis">Synopsis</a></li>
+<li class="doctools_section"><a href="#section1">Description</a></li>
+<li class="doctools_section"><a href="#section2">API</a>
+<ul>
+<li class="doctools_subsection"><a href="#subsection1">NARGLE</a></li>
+</ul>
+</li>
+<li class="doctools_section"><a href="#see-also">See Also</a></li>
+<li class="doctools_section"><a href="#keywords">Keywords</a></li>
+<li class="doctools_section"><a href="#copyright">Copyright</a></li>
+</ul>
+</div>
+<div id="synopsis" class="doctools_section"><h2><a name="synopsis">Synopsis</a></h2>
+<div class="doctools_synopsis">
+<ul class="doctools_requirements">
+<li>package require <b class="pkgname">AAA</b></li>
+<li>package require <b class="pkgname">BBB VVV</b></li>
+<li>package require <b class="pkgname">CCC <span class="opt">?VVV?</span></b></li>
+</ul>
+<ul class="doctools_syntax">
+<li><a href="#1">CMDNAME ...</a></li>
+<li><a href="#2">CMDNAME ...</a></li>
+<li><a href="#3">CMDNAME ...</a></li>
+</ul>
+</div>
+</div>
+<div id="section1" class="doctools_section"><h2><a name="section1">Description</a></h2>
+<dl class="doctools_commands">
+<dt><b class="cmd">NAME</b></dt>
+<dd><p>DESCRIPTION ::<b class="cmd">Command</b>::</p></dd>
+<dt><b class="cmd">NAME</b></dt>
+<dd><p>DESCRIPTION ::::</p></dd>
+<dt><b class="cmd">NAME</b></dt>
+<dd><p>DESCRIPTION ::<b class="const">Constant</b>::</p></dd>
+</dl>
+</div>
+<div id="section2" class="doctools_section"><h2><a name="section2">API</a></h2>
+<dl class="doctools_definitions">
+<dt>TERM</dt>
+<dd><p>DESCRIPTION ::<em>Emphasis</em>::</p></dd>
+<dt>TERM</dt>
+<dd><p>DESCRIPTION ::&quot;<b class="file">File/Path</b>&quot;::</p>
+<dl class="doctools_tkoptions">
+<dt>Command-Line Switch: <b class="option">NAME</b><br>
+Database Name: <b class="optdbname">DBNAME</b><br>
+Database Class: <b class="optdbclass">CLASS</b><br>
+</dt>
+<dd><p>DESCRIPTION <span class="sectref"><a href="#subsection1">NARGLE</a></span></p></dd>
+<dt>Command-Line Switch: <b class="option">NAME</b><br>
+Database Name: <b class="optdbname">DBNAME</b><br>
+Database Class: <b class="optdbclass">CLASS</b><br>
+</dt>
+<dd><p>DESCRIPTION ::<b class="function">Function</b>::</p></dd>
+<dt>Command-Line Switch: <b class="option">NAME</b><br>
+Database Name: <b class="optdbname">DBNAME</b><br>
+Database Class: <b class="optdbclass">CLASS</b><br>
+</dt>
+<dd><p>DESCRIPTION ::<b class="method">Method</b>::</p></dd>
+</dl></dd>
+<dt>TERM</dt>
+<dd><p>DESCRIPTION</p></dd>
+<dt><a name="1">CMDNAME ...</a></dt>
+<dd><p>DESCRIPTION ::<b class="namespace">Namespace</b>::</p>
+<dl class="doctools_arguments">
+<dt>TYPE <i class="arg">NAME</i></dt>
+<dd><p>DESCRIPTION ::<i class="arg">Argument</i>::</p></dd>
+<dt>TYPE <i class="arg">NAME</i></dt>
+<dd><p>DESCRIPTION ::<b class="option">Option</b>::</p></dd>
+<dt>TYPE <i class="arg">NAME</i> (MODE)</dt>
+<dd><p>DESCRIPTION ::<span class="opt">?Optional?</span>::</p>
+<pre class="doctools_example">
+ THE ARGUMENT IS USED IN THIS
+ AND/OR THAT MANNER
+</pre>
+</dd>
+</dl></dd>
+<dt><a name="2">CMDNAME ...</a></dt>
+<dd><p>DESCRIPTION ::<b class="package">Package</b>::</p></dd>
+<dt><a name="3">CMDNAME ...</a></dt>
+<dd><p>DESCRIPTION ::<b class="syscmd">SystemCommand</b>::</p>
+<dl class="doctools_options">
+<dt><b class="option">NAME</b></dt>
+<dd><p>DESCRIPTION ::<i class="term">Term</i>::</p></dd>
+<dt><b class="option">NAME</b></dt>
+<dd><p>DESCRIPTION ::<b class="type">Type</b>::</p></dd>
+<dt><b class="option">NAME</b> ARGUMENT</dt>
+<dd><p>DESCRIPTION ::<a href="Uri">Uri</a>::</p></dd>
+</dl></dd>
+</dl>
+<div id="subsection1" class="doctools_subsection"><h3><a name="subsection1">NARGLE</a></h3>
+<ol class="doctools_enumerated">
+<li><p>PARAGRAPH ::<a href="Uri">UriLabel</a>::</p></li>
+<li><p>PARAGRAPH ::<b class="variable">Variable</b>::</p></li>
+<li><p>PARAGRAPH ::<b class="widget">Widget</b>::</p>
+<ul class="doctools_itemized">
+<li><p>PARAGRAPH ::<b class="class">Class</b>::</p></li>
+<li><p>PARAGRAPH</p></li>
+<li><p>PARAGRAPH</p></li>
+</ul>
+</li>
+</ol>
+</div>
+</div>
+<div id="see-also" class="doctools_section"><h2><a name="see-also">See Also</a></h2>
+<p>ELSE, OTHER</p>
+</div>
+<div id="keywords" class="doctools_section"><h2><a name="keywords">Keywords</a></h2>
+<p>KEYA, KEYZ</p>
+</div>
+<div id="copyright" class="doctools_section"><h2><a name="copyright">Copyright</a></h2>
+<p>Copyright &copy; **Copyright**</p>
+</div>
+</div></body></html>
diff --git a/tcllib/modules/doctools/tests/latex/00 b/tcllib/modules/doctools/tests/latex/00
new file mode 100644
index 0000000..234076f
--- /dev/null
+++ b/tcllib/modules/doctools/tests/latex/00
@@ -0,0 +1,14 @@
+% Generated from file '.FILE.' by tcllib/doctools with format 'latex'
+% Copyright (c) .COPYRIGHT.
+% CVS: @ID@ TEST.z
+\documentclass{article}
+\begin{document}
+\author{@USR@}
+\title{.MODULE. / TEST -- : }
+\maketitle
+\section{Description}\label{section1}
+\section{Copyright}\label{copyright}
+\begin{flushleft}
+Copyright (c) .COPYRIGHT.\linebreak
+\end{flushleft}
+\end{document}
diff --git a/tcllib/modules/doctools/tests/latex/01 b/tcllib/modules/doctools/tests/latex/01
new file mode 100644
index 0000000..08cf348
--- /dev/null
+++ b/tcllib/modules/doctools/tests/latex/01
@@ -0,0 +1,33 @@
+% Generated from file '.FILE.' by tcllib/doctools with format 'latex'
+% Copyright (c) **Copyright**
+% CVS: @ID@ TEST.z
+\documentclass{article}
+\begin{document}
+\author{@USR@}
+\title{.MODULE. / TEST -- : }
+\maketitle
+\section{Description}\label{section1}
+Argument ::\underline{Argument}::
+Class ::{\bf Class}::
+Command ::{\bf Command}::
+Comment ::::
+Const ::{\bf Constant}::
+Emphasis ::{\it Emphasis}::
+File ::"{\it File/Path}"::
+Function ::{\bf Function}::
+Method ::{\bf Method}::
+Namespace ::{\bf Namespace]}::
+Option ::{\bf Option}::
+Optional ::?Optional?::
+Package ::{\bf Package}::
+Syscmd ::{\bf SystemCommand}::
+Term ::{\it Term}::
+Type ::{\bf Type}::
+Uri ::\underline{Uri}::
+Variable ::{\bf Variable}::
+Widget ::{\bf Widget}::
+\section{Copyright}\label{copyright}
+\begin{flushleft}
+Copyright (c) **Copyright**\linebreak
+\end{flushleft}
+\end{document}
diff --git a/tcllib/modules/doctools/tests/latex/02 b/tcllib/modules/doctools/tests/latex/02
new file mode 100644
index 0000000..089dc1b
--- /dev/null
+++ b/tcllib/modules/doctools/tests/latex/02
@@ -0,0 +1,23 @@
+% Generated from file '.FILE.' by tcllib/doctools with format 'latex'
+% Copyright (c) .COPYRIGHT.
+% CVS: @ID@ TEST.z
+\documentclass{article}
+\begin{document}
+\author{@USR@}
+\title{.MODULE. / TEST -- ..THE\_MODULE.. : ..THE\_TITLE..}
+\maketitle
+\section{Synopsis}\label{synopsis}
+\begin{flushleft}
+package require {\bf AAA}
+package require {\bf BBB VVV}
+\end{flushleft}
+\section{Description}\label{section1}
+\section{See Also}\label{see-also}
+ELSE, OTHER
+\section{Keywords}\label{keywords}
+KEYA, KEYZ
+\section{Copyright}\label{copyright}
+\begin{flushleft}
+Copyright (c) .COPYRIGHT.\linebreak
+\end{flushleft}
+\end{document}
diff --git a/tcllib/modules/doctools/tests/latex/03 b/tcllib/modules/doctools/tests/latex/03
new file mode 100644
index 0000000..fe91842
--- /dev/null
+++ b/tcllib/modules/doctools/tests/latex/03
@@ -0,0 +1,26 @@
+% Generated from file '.FILE.' by tcllib/doctools with format 'latex'
+% Copyright (c) .COPYRIGHT.
+% CVS: @ID@ TEST.z
+\documentclass{article}
+\begin{document}
+\author{@USR@}
+\title{.MODULE. / TEST -- : }
+\maketitle
+\section{Description}\label{section1}
+\section{AaA}\label{section2}
+1
+\section{BbB}\label{section3}
+22
+\subsection{BbB.cCc}\label{subsection1}
+333
+\subsection{BbB.dDd}\label{subsection2}
+4444
+\section{EeE}\label{section4}
+5555
+At {\bf AaA (\ref{section2})}.
+At {\bf \_\_undefined\_\_ (\ref{\_\_undefined\_\_})}.
+\section{Copyright}\label{copyright}
+\begin{flushleft}
+Copyright (c) .COPYRIGHT.\linebreak
+\end{flushleft}
+\end{document}
diff --git a/tcllib/modules/doctools/tests/latex/04 b/tcllib/modules/doctools/tests/latex/04
new file mode 100644
index 0000000..1d4ee66
--- /dev/null
+++ b/tcllib/modules/doctools/tests/latex/04
@@ -0,0 +1,23 @@
+% Generated from file '.FILE.' by tcllib/doctools with format 'latex'
+% Copyright (c) .COPYRIGHT.
+% CVS: @ID@ TEST.z
+\documentclass{article}
+\begin{document}
+\author{@USR@}
+\title{.MODULE. / TEST -- : }
+\maketitle
+\section{Description}\label{section1}
+BEGINNE HIER
+\begin{verbatim}
+ Example Block More Lines
+\end{verbatim}
+\begin{verbatim}
+Inlined Example \
+Next Line
+\end{verbatim}
+FERTIG
+\section{Copyright}\label{copyright}
+\begin{flushleft}
+Copyright (c) .COPYRIGHT.\linebreak
+\end{flushleft}
+\end{document}
diff --git a/tcllib/modules/doctools/tests/latex/05 b/tcllib/modules/doctools/tests/latex/05
new file mode 100644
index 0000000..acd2f76
--- /dev/null
+++ b/tcllib/modules/doctools/tests/latex/05
@@ -0,0 +1,99 @@
+
+% Generated from file '.FILE.' by tcllib/doctools with format 'latex'
+% Copyright (c) .COPYRIGHT.
+% CVS: @ID@ BASIC.a
+\documentclass{article}
+\begin{document}
+\author{@USR@}
+\title{.MODULE. / BASIC -- : }
+\maketitle
+\section{Synopsis}\label{synopsis}
+\begin{itemize}
+\item[] a-command
+\end{itemize}
+\section{Description}\label{section1}
+OK
+\begin{itemize}
+%
+\item[] \underline{argument-1} integer
+%
+verification
+%
+\item[] \underline{argument-2} string (out)
+%
+ mogrification
+\end{itemize}
+\begin{itemize}
+%
+\item[] {\bf command-a}
+%
+ explanation
+%
+\item[] {\bf command-b}
+%
+elucidation
+\end{itemize}
+\begin{itemize}
+%
+\item[] term
+%
+ definition
+%
+\item[] a-command
+%
+semantic
+\end{itemize}
+\begin{enumerate}
+%
+\item
+%
+A
+%
+\item
+%
+ B
+C
+D
+\end{enumerate}
+\begin{itemize}
+%
+\item
+%
+1
+%
+\item
+%
+ 2
+2a
+2b
+\end{itemize}
+\begin{itemize}
+%
+\item[] {\bf option-1}
+%
+ meaning
+%
+\item[] {\bf option-2} value
+%
+elaboration
+\end{itemize}
+\begin{itemize}
+%
+\item[] Command-Line Switch: {\bf background}\\
+Database Name: {\bf Background}\\
+Database Class: {\bf Color}\\
+%
+ candy
+%
+\item[] Command-Line Switch: {\bf foreground}\\
+Database Name: {\bf Foreground}\\
+Database Class: {\bf Color}\\
+%
+caramel
+\end{itemize}
+KO
+\section{Copyright}\label{copyright}
+\begin{flushleft}
+Copyright (c) .COPYRIGHT.\linebreak
+\end{flushleft}
+\end{document}
diff --git a/tcllib/modules/doctools/tests/latex/06 b/tcllib/modules/doctools/tests/latex/06
new file mode 100644
index 0000000..5347173
--- /dev/null
+++ b/tcllib/modules/doctools/tests/latex/06
@@ -0,0 +1,54 @@
+% Generated from file '.FILE.' by tcllib/doctools with format 'latex'
+% Copyright (c) .COPYRIGHT.
+% CVS: @ID@ TEST.z
+\documentclass{article}
+\begin{document}
+\author{@USR@}
+\title{.MODULE. / TEST -- : }
+\maketitle
+\section{Description}\label{section1}
+\begin{itemize}
+%
+\item
+%
+ 1 2 3
+%
+\item
+%
+\begin{enumerate}
+%
+\item
+%
+ a b c
+%
+\item
+%
+\begin{itemize}
+%
+\item[] foo
+%
+ snafu
+%
+\item[] bar
+%
+ barf
+%
+\item[] roo
+%
+ gork
+\end{itemize}
+%
+\item
+%
+ a b c
+\end{enumerate}
+%
+\item
+%
+ 4 5 6
+\end{itemize}
+\section{Copyright}\label{copyright}
+\begin{flushleft}
+Copyright (c) .COPYRIGHT.\linebreak
+\end{flushleft}
+\end{document}
diff --git a/tcllib/modules/doctools/tests/latex/07 b/tcllib/modules/doctools/tests/latex/07
new file mode 100644
index 0000000..b9951c8
--- /dev/null
+++ b/tcllib/modules/doctools/tests/latex/07
@@ -0,0 +1,58 @@
+% Generated from file '.FILE.' by tcllib/doctools with format 'latex'
+% Copyright (c) .COPYRIGHT.
+% CVS: @ID@ TEST.z
+\documentclass{article}
+\begin{document}
+\author{@USR@}
+\title{.MODULE. / TEST -- : }
+\maketitle
+\section{Description}\label{section1}
+\begin{itemize}
+%
+\item
+%
+ 1
+%
+\item
+%
+ 2
+\begin{enumerate}
+%
+\item
+%
+ a
+%
+\item
+%
+ b
+\begin{itemize}
+%
+\item[] foo
+%
+ snafu
+%
+\item[] bar
+%
+ barf
+%
+\item[] roo
+%
+ gork
+\end{itemize}
+bb
+%
+\item
+%
+ a
+\end{enumerate}
+22
+%
+\item
+%
+ 3
+\end{itemize}
+\section{Copyright}\label{copyright}
+\begin{flushleft}
+Copyright (c) .COPYRIGHT.\linebreak
+\end{flushleft}
+\end{document}
diff --git a/tcllib/modules/doctools/tests/latex/08 b/tcllib/modules/doctools/tests/latex/08
new file mode 100644
index 0000000..793a2cd
--- /dev/null
+++ b/tcllib/modules/doctools/tests/latex/08
@@ -0,0 +1,152 @@
+
+% Generated from file '.FILE.' by tcllib/doctools with format 'latex'
+% Copyright (c) **Copyright**
+% CVS: @ID@ ALL.a
+\documentclass{article}
+\begin{document}
+\author{@USR@}
+\title{.MODULE. / ALL -- ..THE\_MODULE.. : ..THE\_TITLE..}
+\maketitle
+\section{Synopsis}\label{synopsis}
+\begin{flushleft}
+package require {\bf AAA}
+package require {\bf BBB VVV}
+package require {\bf CCC ?VVV?}
+\end{flushleft}
+\begin{itemize}
+\item[] CMDNAME ...
+\item[] CMDNAME ...
+\item[] CMDNAME ...
+\end{itemize}
+\section{Description}\label{section1}
+\begin{itemize}
+%
+\item[] {\bf NAME}
+%
+ DESCRIPTION ::{\bf Command}::
+%
+\item[] {\bf NAME}
+%
+ DESCRIPTION ::::
+%
+\item[] {\bf NAME}
+%
+ DESCRIPTION ::{\bf Constant}::
+\end{itemize}
+\section{API}\label{section2}
+\begin{itemize}
+%
+\item[] TERM
+%
+ DESCRIPTION ::{\it Emphasis}::
+%
+\item[] TERM
+%
+ DESCRIPTION ::"{\it File/Path}"::
+\begin{itemize}
+%
+\item[] Command-Line Switch: {\bf NAME}\\
+Database Name: {\bf DBNAME}\\
+Database Class: {\bf CLASS}\\
+%
+ DESCRIPTION {\bf NARGLE (\ref{subsection1})}
+%
+\item[] Command-Line Switch: {\bf NAME}\\
+Database Name: {\bf DBNAME}\\
+Database Class: {\bf CLASS}\\
+%
+ DESCRIPTION ::{\bf Function}::
+%
+\item[] Command-Line Switch: {\bf NAME}\\
+Database Name: {\bf DBNAME}\\
+Database Class: {\bf CLASS}\\
+%
+ DESCRIPTION ::{\bf Method}::
+\end{itemize}
+%
+\item[] TERM
+%
+ DESCRIPTION
+%
+\item[] CMDNAME ...
+%
+ DESCRIPTION ::{\bf Namespace]}::
+\begin{itemize}
+%
+\item[] \underline{NAME} TYPE
+%
+ DESCRIPTION ::\underline{Argument}::
+%
+\item[] \underline{NAME} TYPE
+%
+ DESCRIPTION ::{\bf Option}::
+%
+\item[] \underline{NAME} TYPE (MODE)
+%
+ DESCRIPTION ::?Optional?::
+\begin{verbatim}
+ THE ARGUMENT IS USED IN THIS
+ AND/OR THAT MANNER
+\end{verbatim}
+\end{itemize}
+%
+\item[] CMDNAME ...
+%
+ DESCRIPTION ::{\bf Package}::
+%
+\item[] CMDNAME ...
+%
+ DESCRIPTION ::{\bf SystemCommand}::
+\begin{itemize}
+%
+\item[] {\bf NAME}
+%
+ DESCRIPTION ::{\it Term}::
+%
+\item[] {\bf NAME}
+%
+ DESCRIPTION ::{\bf Type}::
+%
+\item[] {\bf NAME} ARGUMENT
+%
+ DESCRIPTION ::\underline{Uri}::
+\end{itemize}
+\end{itemize}
+\subsection{NARGLE}\label{subsection1}
+\begin{enumerate}
+%
+\item
+%
+ PARAGRAPH ::\underline{UriLabel} \footnote{Uri}::
+%
+\item
+%
+ PARAGRAPH ::{\bf Variable}::
+%
+\item
+%
+ PARAGRAPH ::{\bf Widget}::
+\begin{itemize}
+%
+\item
+%
+ PARAGRAPH ::{\bf Class}::
+%
+\item
+%
+ PARAGRAPH
+%
+\item
+%
+ PARAGRAPH
+\end{itemize}
+\end{enumerate}
+\section{See Also}\label{see-also}
+ELSE, OTHER
+\section{Keywords}\label{keywords}
+KEYA, KEYZ
+\section{Copyright}\label{copyright}
+\begin{flushleft}
+Copyright (c) **Copyright**\linebreak
+\end{flushleft}
+\end{document}
diff --git a/tcllib/modules/doctools/tests/list/00 b/tcllib/modules/doctools/tests/list/00
new file mode 100644
index 0000000..82f0dd4
--- /dev/null
+++ b/tcllib/modules/doctools/tests/list/00
@@ -0,0 +1 @@
+manpage {seealso {} keywords {} file .FILE. section z category {} module .MODULE. version 3.14.15.926 title TEST shortdesc {} desc {} fid .FILE}
diff --git a/tcllib/modules/doctools/tests/list/01 b/tcllib/modules/doctools/tests/list/01
new file mode 100644
index 0000000..82f0dd4
--- /dev/null
+++ b/tcllib/modules/doctools/tests/list/01
@@ -0,0 +1 @@
+manpage {seealso {} keywords {} file .FILE. section z category {} module .MODULE. version 3.14.15.926 title TEST shortdesc {} desc {} fid .FILE}
diff --git a/tcllib/modules/doctools/tests/list/02 b/tcllib/modules/doctools/tests/list/02
new file mode 100644
index 0000000..49e2bc7
--- /dev/null
+++ b/tcllib/modules/doctools/tests/list/02
@@ -0,0 +1 @@
+manpage {seealso {ELSE OTHER} keywords {KEYA KEYZ} file .FILE. section z category {} module .MODULE. version 3.14.15.926 title TEST shortdesc ..THE_MODULE.. desc ..THE_TITLE.. fid .FILE}
diff --git a/tcllib/modules/doctools/tests/list/03 b/tcllib/modules/doctools/tests/list/03
new file mode 100644
index 0000000..82f0dd4
--- /dev/null
+++ b/tcllib/modules/doctools/tests/list/03
@@ -0,0 +1 @@
+manpage {seealso {} keywords {} file .FILE. section z category {} module .MODULE. version 3.14.15.926 title TEST shortdesc {} desc {} fid .FILE}
diff --git a/tcllib/modules/doctools/tests/list/04 b/tcllib/modules/doctools/tests/list/04
new file mode 100644
index 0000000..82f0dd4
--- /dev/null
+++ b/tcllib/modules/doctools/tests/list/04
@@ -0,0 +1 @@
+manpage {seealso {} keywords {} file .FILE. section z category {} module .MODULE. version 3.14.15.926 title TEST shortdesc {} desc {} fid .FILE}
diff --git a/tcllib/modules/doctools/tests/list/05 b/tcllib/modules/doctools/tests/list/05
new file mode 100644
index 0000000..5fdc7fb
--- /dev/null
+++ b/tcllib/modules/doctools/tests/list/05
@@ -0,0 +1 @@
+manpage {seealso {} keywords {} file .FILE. section a category {} module .MODULE. version 5 title BASIC shortdesc {} desc {} fid .FILE}
diff --git a/tcllib/modules/doctools/tests/list/06 b/tcllib/modules/doctools/tests/list/06
new file mode 100644
index 0000000..82f0dd4
--- /dev/null
+++ b/tcllib/modules/doctools/tests/list/06
@@ -0,0 +1 @@
+manpage {seealso {} keywords {} file .FILE. section z category {} module .MODULE. version 3.14.15.926 title TEST shortdesc {} desc {} fid .FILE}
diff --git a/tcllib/modules/doctools/tests/list/07 b/tcllib/modules/doctools/tests/list/07
new file mode 100644
index 0000000..82f0dd4
--- /dev/null
+++ b/tcllib/modules/doctools/tests/list/07
@@ -0,0 +1 @@
+manpage {seealso {} keywords {} file .FILE. section z category {} module .MODULE. version 3.14.15.926 title TEST shortdesc {} desc {} fid .FILE}
diff --git a/tcllib/modules/doctools/tests/list/08 b/tcllib/modules/doctools/tests/list/08
new file mode 100644
index 0000000..e4a13e1
--- /dev/null
+++ b/tcllib/modules/doctools/tests/list/08
@@ -0,0 +1 @@
+manpage {seealso {ELSE OTHER} keywords {KEYA KEYZ} file .FILE. section a category {} module .MODULE. version 5 title ALL shortdesc ..THE_MODULE.. desc ..THE_TITLE.. fid .FILE}
diff --git a/tcllib/modules/doctools/tests/man/00 b/tcllib/modules/doctools/tests/man/00
new file mode 100644
index 0000000..cce77e7
--- /dev/null
+++ b/tcllib/modules/doctools/tests/man/00
@@ -0,0 +1,3 @@
+[manpage_begin TEST z 3.14.15.926]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/man/01 b/tcllib/modules/doctools/tests/man/01
new file mode 100644
index 0000000..0392196
--- /dev/null
+++ b/tcllib/modules/doctools/tests/man/01
@@ -0,0 +1,23 @@
+[manpage_begin TEST z 3.14.15.926]
+[copyright **Copyright**]
+[description]
+Argument ::[arg Argument]::
+Class ::[class Class]::
+Command ::[cmd Command]::
+Comment ::[comment Comment]::
+Const ::[const Constant]::
+Emphasis ::[emph Emphasis]::
+File ::[file File/Path]::
+Function ::[fun Function]::
+Method ::[method Method]::
+Namespace ::[namespace Namespace]::
+Option ::[option Option]::
+Optional ::[opt Optional]::
+Package ::[package Package]::
+Syscmd ::[syscmd SystemCommand]::
+Term ::[term Term]::
+Type ::[type Type]::
+Uri ::[uri Uri]::
+Variable ::[var Variable]::
+Widget ::[widget Widget]::
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/man/02 b/tcllib/modules/doctools/tests/man/02
new file mode 100644
index 0000000..11d01c0
--- /dev/null
+++ b/tcllib/modules/doctools/tests/man/02
@@ -0,0 +1,9 @@
+[manpage_begin TEST z 3.14.15.926]
+[moddesc ..THE_MODULE..]
+[titledesc ..THE_TITLE..]
+[require AAA]
+[require BBB VVV]
+[keywords KEYA KEYZ]
+[see_also OTHER ELSE]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/man/03 b/tcllib/modules/doctools/tests/man/03
new file mode 100644
index 0000000..f65d255
--- /dev/null
+++ b/tcllib/modules/doctools/tests/man/03
@@ -0,0 +1,19 @@
+[manpage_begin TEST z 3.14.15.926]
+[description]
+[section AaA]
+1
+[section BbB]
+22
+[subsection BbB.cCc]
+333
+[subsection BbB.dDd]
+4444
+[section EeE]
+5555
+
+[para]
+At [sectref AaA].
+[para]
+At [sectref __undefined__].
+[manpage_end]
+
diff --git a/tcllib/modules/doctools/tests/man/04 b/tcllib/modules/doctools/tests/man/04
new file mode 100644
index 0000000..82d4790
--- /dev/null
+++ b/tcllib/modules/doctools/tests/man/04
@@ -0,0 +1,16 @@
+[manpage_begin TEST z 3.14.15.926]
+[description]
+BEGINNE HIER
+[example {
+ Example Block \
+ More Lines
+}]
+[para]
+[para]
+[example_begin]
+Inlined Example \
+Next Line
+[example_end]
+FERTIG
+[manpage_end]
+
diff --git a/tcllib/modules/doctools/tests/man/05 b/tcllib/modules/doctools/tests/man/05
new file mode 100644
index 0000000..5ec6daa
--- /dev/null
+++ b/tcllib/modules/doctools/tests/man/05
@@ -0,0 +1,58 @@
+[comment {LISTS, BASIC}]
+[manpage_begin BASIC a 5]
+[description]
+OK
+[para]
+[list_begin arguments]
+[arg_def integer argument-1]
+verification
+[arg_def string argument-2 out] mogrification
+[list_end]
+[para]
+[list_begin commands]
+[cmd_def command-a] explanation
+[cmd_def command-b]
+elucidation
+[list_end]
+[para]
+[list_begin definitions]
+[def term] definition
+[call a-command]
+semantic
+[list_end]
+[para]
+[list_begin enumerated]
+[enum]
+A
+[enum] B
+[para]
+C
+[para]
+D
+[list_end]
+[para]
+[list_begin itemized]
+[item]
+1
+[item] 2
+[para]
+2a
+[para]
+2b
+[list_end]
+[para]
+[list_begin options]
+[opt_def option-1] meaning
+[opt_def option-2 value]
+elaboration
+[list_end]
+[para]
+[list_begin tkoptions]
+[tkoption_def background Background Color] candy
+[tkoption_def foreground Foreground Color]
+caramel
+[list_end]
+[para]
+KO
+[comment DONE]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/man/06 b/tcllib/modules/doctools/tests/man/06
new file mode 100644
index 0000000..c00a4c4
--- /dev/null
+++ b/tcllib/modules/doctools/tests/man/06
@@ -0,0 +1,27 @@
+[manpage_begin TEST z 3.14.15.926]
+[description]
+[comment {
+ nested lists, same and different types, examples have examples at
+ least three levels deep, for a proper inner level, i.e. not only
+ first/last level, but something truly in the middle. Also three
+ list items of the relevant on each level, see the proper handling
+ of indentations. For that we also need paragraphs in the items.
+
+ start: itemized/enumerated/definition
+}]
+[list_begin itemized]
+[item] 1 [para] 2 [para] 3
+[item]
+[list_begin enumerated]
+[enum] a [para] b [para] c
+[enum]
+[list_begin definitions]
+[def foo] snafu
+[def bar] barf
+[def roo] gork
+[list_end]
+[enum] a [para] b [para] c
+[list_end]
+[item] 4 [para] 5 [para] 6
+[list_end]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/man/07 b/tcllib/modules/doctools/tests/man/07
new file mode 100644
index 0000000..09414c5
--- /dev/null
+++ b/tcllib/modules/doctools/tests/man/07
@@ -0,0 +1,23 @@
+[manpage_begin TEST z 3.14.15.926]
+[description]
+[comment {
+ nested list 2, put text before and after the embedded list.
+}]
+[list_begin itemized]
+[item] 1
+[item] 2
+[list_begin enumerated]
+[enum] a
+[enum] b
+[list_begin definitions]
+[def foo] snafu
+[def bar] barf
+[def roo] gork
+[list_end]
+bb
+[enum] a
+[list_end]
+22
+[item] 3
+[list_end]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/man/08 b/tcllib/modules/doctools/tests/man/08
new file mode 100644
index 0000000..0526e39
--- /dev/null
+++ b/tcllib/modules/doctools/tests/man/08
@@ -0,0 +1,56 @@
+[comment {LISTS, ALL TYPES}]
+[manpage_begin ALL a 5]
+[copyright **Copyright**]
+[moddesc ..THE_MODULE..]
+[titledesc ..THE_TITLE..]
+[require AAA]
+[require BBB VVV]
+[require CCC [opt VVV]]
+[description]
+[list_begin commands]
+[cmd_def NAME] DESCRIPTION ::[cmd Command]::
+[cmd_def NAME] DESCRIPTION ::[comment Comment]::
+[cmd_def NAME] DESCRIPTION ::[const Constant]::
+[list_end]
+[section API]
+[list_begin definitions]
+[def TERM] DESCRIPTION ::[emph Emphasis]::
+[def TERM] DESCRIPTION ::[file File/Path]::
+[list_begin tkoptions]
+[tkoption_def NAME DBNAME CLASS] DESCRIPTION [sectref NARGLE]
+[tkoption_def NAME DBNAME CLASS] DESCRIPTION ::[fun Function]::
+[tkoption_def NAME DBNAME CLASS] DESCRIPTION ::[method Method]::
+[list_end]
+[def TERM] DESCRIPTION
+[call CMDNAME ...] DESCRIPTION ::[namespace Namespace]::
+[list_begin arguments]
+[arg_def TYPE NAME] DESCRIPTION ::[arg Argument]::
+[arg_def TYPE NAME] DESCRIPTION ::[option Option]::
+[arg_def TYPE NAME MODE] DESCRIPTION ::[opt Optional]::
+[example {
+ THE ARGUMENT IS USED IN THIS
+ AND/OR THAT MANNER
+}]
+[list_end]
+[call CMDNAME ...] DESCRIPTION ::[package Package]::
+[call CMDNAME ...] DESCRIPTION ::[syscmd SystemCommand]::
+[list_begin options]
+[opt_def NAME] DESCRIPTION ::[term Term]::
+[opt_def NAME] DESCRIPTION ::[type Type]::
+[opt_def NAME ARGUMENT] DESCRIPTION ::[uri Uri]::
+[list_end]
+[list_end]
+[subsection NARGLE]
+[list_begin enumerated]
+[enum] PARAGRAPH ::[uri Uri UriLabel]::
+[enum] PARAGRAPH ::[var Variable]::
+[enum] PARAGRAPH ::[widget Widget]::
+[list_begin itemized]
+[item] PARAGRAPH ::[class Class]::
+[item] PARAGRAPH
+[item] PARAGRAPH
+[list_end]
+[list_end]
+[keywords KEYA KEYZ]
+[see_also OTHER ELSE]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/nroff/00 b/tcllib/modules/doctools/tests/nroff/00
new file mode 100644
index 0000000..2cea3ca
--- /dev/null
+++ b/tcllib/modules/doctools/tests/nroff/00
@@ -0,0 +1,15 @@
+'\"
+'\" Generated from file '\&.FILE\&.' by tcllib/doctools with format 'nroff'
+'\" Copyright (c) \&.COPYRIGHT\&.
+'\"
+.TH "TEST" z 3\&.14\&.15\&.926 \&.MODULE\&. ""
+.so man.macros
+.BS
+.SH NAME
+TEST \-
+.SH DESCRIPTION
+.SH COPYRIGHT
+.nf
+Copyright (c) \&.COPYRIGHT\&.
+
+.fi \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/nroff/01 b/tcllib/modules/doctools/tests/nroff/01
new file mode 100644
index 0000000..bf0f3db
--- /dev/null
+++ b/tcllib/modules/doctools/tests/nroff/01
@@ -0,0 +1,34 @@
+'\"
+'\" Generated from file '\&.FILE\&.' by tcllib/doctools with format 'nroff'
+'\" Copyright (c) **Copyright**
+'\"
+.TH "TEST" z 3\&.14\&.15\&.926 \&.MODULE\&. ""
+.so man.macros
+.BS
+.SH NAME
+TEST \-
+.SH DESCRIPTION
+Argument ::\fIArgument\fR::
+Class ::\fBClass\fR::
+Command ::\fBCommand\fR::
+Comment ::::
+Const ::\fBConstant\fR::
+Emphasis ::\fIEmphasis\fR::
+File ::"\fIFile/Path\fR"::
+Function ::\fBFunction\fR::
+Method ::\fBMethod\fR::
+Namespace ::\fBNamespace\fR::
+Option ::\fBOption\fR::
+Optional ::?Optional?::
+Package ::\fBPackage\fR::
+Syscmd ::\fBSystemCommand\fR::
+Term ::\fITerm\fR::
+Type ::\fBType\fR::
+Uri ::\fIUri\fR::
+Variable ::\fBVariable\fR::
+Widget ::\fBWidget\fR::
+.SH COPYRIGHT
+.nf
+Copyright (c) **Copyright**
+
+.fi \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/nroff/02 b/tcllib/modules/doctools/tests/nroff/02
new file mode 100644
index 0000000..1205e3c
--- /dev/null
+++ b/tcllib/modules/doctools/tests/nroff/02
@@ -0,0 +1,25 @@
+'\"
+'\" Generated from file '\&.FILE\&.' by tcllib/doctools with format 'nroff'
+'\" Copyright (c) \&.COPYRIGHT\&.
+'\"
+.TH "TEST" z 3\&.14\&.15\&.926 \&.MODULE\&. "\&.\&.THE_MODULE\&.\&."
+.so man.macros
+.BS
+.SH NAME
+TEST \- \&.\&.THE_TITLE\&.\&.
+.SH SYNOPSIS
+package require \fBAAA \fR
+.sp
+package require \fBBBB VVV\fR
+.sp
+.BE
+.SH DESCRIPTION
+.SH "SEE ALSO"
+ELSE, OTHER
+.SH KEYWORDS
+KEYA, KEYZ
+.SH COPYRIGHT
+.nf
+Copyright (c) \&.COPYRIGHT\&.
+
+.fi \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/nroff/03 b/tcllib/modules/doctools/tests/nroff/03
new file mode 100644
index 0000000..8e7482d
--- /dev/null
+++ b/tcllib/modules/doctools/tests/nroff/03
@@ -0,0 +1,29 @@
+'\"
+'\" Generated from file '\&.FILE\&.' by tcllib/doctools with format 'nroff'
+'\" Copyright (c) \&.COPYRIGHT\&.
+'\"
+.TH "TEST" z 3\&.14\&.15\&.926 \&.MODULE\&. ""
+.so man.macros
+.BS
+.SH NAME
+TEST \-
+.SH DESCRIPTION
+.SH AAA
+1
+.SH BBB
+22
+.SS BBB\&.CCC
+333
+.SS BBB\&.DDD
+4444
+.SH EEE
+5555
+.PP
+At \fBAaA\fR\&.
+.PP
+At \fB__undefined__\fR\&.
+.SH COPYRIGHT
+.nf
+Copyright (c) \&.COPYRIGHT\&.
+
+.fi \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/nroff/04 b/tcllib/modules/doctools/tests/nroff/04
new file mode 100644
index 0000000..e132fe2
--- /dev/null
+++ b/tcllib/modules/doctools/tests/nroff/04
@@ -0,0 +1,32 @@
+'\"
+'\" Generated from file '\&.FILE\&.' by tcllib/doctools with format 'nroff'
+'\" Copyright (c) \&.COPYRIGHT\&.
+'\"
+.TH "TEST" z 3\&.14\&.15\&.926 \&.MODULE\&. ""
+.so man.macros
+.BS
+.SH NAME
+TEST \-
+.SH DESCRIPTION
+BEGINNE HIER
+.CS
+
+
+ Example Block More Lines
+
+.CE
+.PP
+.PP
+.CS
+
+
+Inlined Example \\
+Next Line
+
+.CE
+FERTIG
+.SH COPYRIGHT
+.nf
+Copyright (c) \&.COPYRIGHT\&.
+
+.fi \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/nroff/05 b/tcllib/modules/doctools/tests/nroff/05
new file mode 100644
index 0000000..fc4e5f5
--- /dev/null
+++ b/tcllib/modules/doctools/tests/nroff/05
@@ -0,0 +1,96 @@
+'\"
+'\" Generated from file '\&.FILE\&.' by tcllib/doctools with format 'nroff'
+'\" Copyright (c) \&.COPYRIGHT\&.
+'\"
+.TH "BASIC" a 5 \&.MODULE\&. ""
+.so man.macros
+.BS
+.SH NAME
+BASIC \-
+.SH SYNOPSIS
+a-command
+.sp
+.BE
+.SH DESCRIPTION
+OK
+.PP
+.TP
+integer \fIargument-1\fR
+verification
+.TP
+string \fIargument-2\fR (out)
+mogrification
+.PP
+.PP
+.TP
+\fBcommand-a\fR
+explanation
+.TP
+\fBcommand-b\fR
+elucidation
+.PP
+.PP
+.TP
+term
+definition
+.TP
+a-command
+semantic
+.PP
+.PP
+.IP [1]
+A
+.IP [2]
+B
+.sp
+C
+.sp
+D
+.PP
+.PP
+.IP \(bu
+1
+.IP \(bu
+2
+.sp
+2a
+.sp
+2b
+.PP
+.PP
+.TP
+\fBoption-1\fR
+meaning
+.TP
+\fBoption-2\fR value
+elaboration
+.PP
+.PP
+.LP
+.nf
+.ta 6c
+Command-Line Switch: \fBbackground\fR
+Database Name: \fBBackground\fR
+Database Class: \fBColor\fR
+
+.fi
+.IP
+candy
+.LP
+.nf
+.ta 6c
+Command-Line Switch: \fBforeground\fR
+Database Name: \fBForeground\fR
+Database Class: \fBColor\fR
+
+.fi
+.IP
+caramel
+.PP
+.PP
+KO
+.SH COPYRIGHT
+.nf
+Copyright (c) \&.COPYRIGHT\&.
+
+.fi \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/nroff/06 b/tcllib/modules/doctools/tests/nroff/06
new file mode 100644
index 0000000..63de9d8
--- /dev/null
+++ b/tcllib/modules/doctools/tests/nroff/06
@@ -0,0 +1,55 @@
+'\"
+'\" Generated from file '\&.FILE\&.' by tcllib/doctools with format 'nroff'
+'\" Copyright (c) \&.COPYRIGHT\&.
+'\"
+.TH "TEST" z 3\&.14\&.15\&.926 \&.MODULE\&. ""
+.so man.macros
+.BS
+.SH NAME
+TEST \-
+.SH DESCRIPTION
+.IP \(bu
+1
+.sp
+2
+.sp
+3
+.IP \(bu
+.RS
+.IP [1]
+a
+.sp
+b
+.sp
+c
+.IP [2]
+.RS
+.TP
+foo
+snafu
+.TP
+bar
+barf
+.TP
+roo
+gork
+.RE
+.IP [3]
+a
+.sp
+b
+.sp
+c
+.RE
+.IP \(bu
+4
+.sp
+5
+.sp
+6
+.PP
+.SH COPYRIGHT
+.nf
+Copyright (c) \&.COPYRIGHT\&.
+
+.fi \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/nroff/07 b/tcllib/modules/doctools/tests/nroff/07
new file mode 100644
index 0000000..b4b3647
--- /dev/null
+++ b/tcllib/modules/doctools/tests/nroff/07
@@ -0,0 +1,45 @@
+'\"
+'\" Generated from file '\&.FILE\&.' by tcllib/doctools with format 'nroff'
+'\" Copyright (c) \&.COPYRIGHT\&.
+'\"
+.TH "TEST" z 3\&.14\&.15\&.926 \&.MODULE\&. ""
+.so man.macros
+.BS
+.SH NAME
+TEST \-
+.SH DESCRIPTION
+.IP \(bu
+1
+.IP \(bu
+2
+.RS
+.IP [1]
+a
+.IP [2]
+b
+.RS
+.TP
+foo
+snafu
+.TP
+bar
+barf
+.TP
+roo
+gork
+.RE
+.IP
+bb
+.IP [3]
+a
+.RE
+.IP
+22
+.IP \(bu
+3
+.PP
+.SH COPYRIGHT
+.nf
+Copyright (c) \&.COPYRIGHT\&.
+
+.fi \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/nroff/08 b/tcllib/modules/doctools/tests/nroff/08
new file mode 100644
index 0000000..da008d4
--- /dev/null
+++ b/tcllib/modules/doctools/tests/nroff/08
@@ -0,0 +1,140 @@
+'\"
+'\" Generated from file '\&.FILE\&.' by tcllib/doctools with format 'nroff'
+'\" Copyright (c) **Copyright**
+'\"
+.TH "ALL" a 5 \&.MODULE\&. "\&.\&.THE_MODULE\&.\&."
+.so man.macros
+.BS
+.SH NAME
+ALL \- \&.\&.THE_TITLE\&.\&.
+.SH SYNOPSIS
+package require \fBAAA \fR
+.sp
+package require \fBBBB VVV\fR
+.sp
+package require \fBCCC ?VVV?\fR
+.sp
+CMDNAME \&.\&.\&.
+.sp
+CMDNAME \&.\&.\&.
+.sp
+CMDNAME \&.\&.\&.
+.sp
+.BE
+.SH DESCRIPTION
+.TP
+\fBNAME\fR
+DESCRIPTION ::\fBCommand\fR::
+.TP
+\fBNAME\fR
+DESCRIPTION ::::
+.TP
+\fBNAME\fR
+DESCRIPTION ::\fBConstant\fR::
+.PP
+.SH API
+.TP
+TERM
+DESCRIPTION ::\fIEmphasis\fR::
+.TP
+TERM
+DESCRIPTION ::"\fIFile/Path\fR"::
+.RS
+.LP
+.nf
+.ta 6c
+Command-Line Switch: \fBNAME\fR
+Database Name: \fBDBNAME\fR
+Database Class: \fBCLASS\fR
+
+.fi
+.IP
+DESCRIPTION \fBNARGLE\fR
+.LP
+.nf
+.ta 6c
+Command-Line Switch: \fBNAME\fR
+Database Name: \fBDBNAME\fR
+Database Class: \fBCLASS\fR
+
+.fi
+.IP
+DESCRIPTION ::\fBFunction\fR::
+.LP
+.nf
+.ta 6c
+Command-Line Switch: \fBNAME\fR
+Database Name: \fBDBNAME\fR
+Database Class: \fBCLASS\fR
+
+.fi
+.IP
+DESCRIPTION ::\fBMethod\fR::
+.RE
+.TP
+TERM
+DESCRIPTION
+.TP
+CMDNAME \&.\&.\&.
+DESCRIPTION ::\fBNamespace\fR::
+.RS
+.TP
+TYPE \fINAME\fR
+DESCRIPTION ::\fIArgument\fR::
+.TP
+TYPE \fINAME\fR
+DESCRIPTION ::\fBOption\fR::
+.TP
+TYPE \fINAME\fR (MODE)
+DESCRIPTION ::?Optional?::
+.CS
+
+
+ THE ARGUMENT IS USED IN THIS
+ AND/OR THAT MANNER
+
+.CE
+.RE
+.TP
+CMDNAME \&.\&.\&.
+DESCRIPTION ::\fBPackage\fR::
+.TP
+CMDNAME \&.\&.\&.
+DESCRIPTION ::\fBSystemCommand\fR::
+.RS
+.TP
+\fBNAME\fR
+DESCRIPTION ::\fITerm\fR::
+.TP
+\fBNAME\fR
+DESCRIPTION ::\fBType\fR::
+.TP
+\fBNAME\fR ARGUMENT
+DESCRIPTION ::\fIUri\fR::
+.RE
+.PP
+.SS NARGLE
+.IP [1]
+PARAGRAPH ::\fIUriLabel\fR [Uri]::
+.IP [2]
+PARAGRAPH ::\fBVariable\fR::
+.IP [3]
+PARAGRAPH ::\fBWidget\fR::
+.RS
+.IP \(bu
+PARAGRAPH ::\fBClass\fR::
+.IP \(bu
+PARAGRAPH
+.IP \(bu
+PARAGRAPH
+.RE
+.PP
+.SH "SEE ALSO"
+ELSE, OTHER
+.SH KEYWORDS
+KEYA, KEYZ
+.SH COPYRIGHT
+.nf
+Copyright (c) **Copyright**
+
+.fi \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/null/00 b/tcllib/modules/doctools/tests/null/00
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/null/00
diff --git a/tcllib/modules/doctools/tests/null/01 b/tcllib/modules/doctools/tests/null/01
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/null/01
diff --git a/tcllib/modules/doctools/tests/null/02 b/tcllib/modules/doctools/tests/null/02
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/null/02
diff --git a/tcllib/modules/doctools/tests/null/03 b/tcllib/modules/doctools/tests/null/03
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/null/03
diff --git a/tcllib/modules/doctools/tests/null/04 b/tcllib/modules/doctools/tests/null/04
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/null/04
diff --git a/tcllib/modules/doctools/tests/null/05 b/tcllib/modules/doctools/tests/null/05
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/null/05
diff --git a/tcllib/modules/doctools/tests/null/06 b/tcllib/modules/doctools/tests/null/06
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/null/06
diff --git a/tcllib/modules/doctools/tests/null/07 b/tcllib/modules/doctools/tests/null/07
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/null/07
diff --git a/tcllib/modules/doctools/tests/null/08 b/tcllib/modules/doctools/tests/null/08
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools/tests/null/08
diff --git a/tcllib/modules/doctools/tests/syntax/e_arg_list b/tcllib/modules/doctools/tests/syntax/e_arg_list
new file mode 100644
index 0000000..2cb55a5
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_arg_list
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[list_begin definitions]
+[arg_def arg-type arg-name]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_body b/tcllib/modules/doctools/tests/syntax/e_body
new file mode 100644
index 0000000..fa86a64
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_body
@@ -0,0 +1,4 @@
+Text before manpage_begin is not allowed
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_arg_def1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_arg_def1
new file mode 100644
index 0000000..9469e13
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_arg_def1
@@ -0,0 +1,4 @@
+[arg_def arg-type arg-name]
+[manpage_end ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_arg_def2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_arg_def2
new file mode 100644
index 0000000..0bcb6b5
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_arg_def2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[arg_def arg-type arg-name]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_arg_def3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_arg_def3
new file mode 100644
index 0000000..f729561
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_arg_def3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_begin]
+[arg_def arg-type arg-name]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_call1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_call1
new file mode 100644
index 0000000..3c7fff3
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_call1
@@ -0,0 +1,4 @@
+[call .command.]
+[manpage_end ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_call2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_call2
new file mode 100644
index 0000000..f1a2082
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_call2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[call .command.]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_call3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_call3
new file mode 100644
index 0000000..9ab775e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_call3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_begin]
+[call .command.]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_cmd_def1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_cmd_def1
new file mode 100644
index 0000000..db6f015
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_cmd_def1
@@ -0,0 +1,4 @@
+[cmd_def .command.]
+[manpage_end ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_cmd_def2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_cmd_def2
new file mode 100644
index 0000000..564d3c6
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_cmd_def2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[cmd_def .command.]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_cmd_def3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_cmd_def3
new file mode 100644
index 0000000..4557ab1
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_cmd_def3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_begin]
+[cmd_def .command.]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_def1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_def1
new file mode 100644
index 0000000..b1f4b25
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_def1
@@ -0,0 +1,4 @@
+[def]
+[manpage_end ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_def2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_def2
new file mode 100644
index 0000000..e1a0db4
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_def2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[def]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_def3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_def3
new file mode 100644
index 0000000..089b4bb
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_def3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_begin]
+[def]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_enum1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_enum1
new file mode 100644
index 0000000..801f2aa
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_enum1
@@ -0,0 +1,4 @@
+[enum]
+[manpage_end ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_enum2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_enum2
new file mode 100644
index 0000000..5b59ec4
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_enum2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[enum]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_enum3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_enum3
new file mode 100644
index 0000000..18f408e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_enum3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_begin]
+[enum]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_example1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_example1
new file mode 100644
index 0000000..d392d3c
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_example1
@@ -0,0 +1,4 @@
+[example {}]
+[manpage_end ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_example2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_example2
new file mode 100644
index 0000000..5d53198
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_example2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[example {}]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_example3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_example3
new file mode 100644
index 0000000..cb54076
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_example3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_begin]
+[example {}]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_example_begin1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_example_begin1
new file mode 100644
index 0000000..fe4172e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_example_begin1
@@ -0,0 +1,4 @@
+[example_begin]
+[manpage_end ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_example_begin2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_example_begin2
new file mode 100644
index 0000000..14f75b5
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_example_begin2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[example_begin]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_example_begin3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_example_begin3
new file mode 100644
index 0000000..6be2c4b
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_example_begin3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_begin]
+[example_begin]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_item1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_item1
new file mode 100644
index 0000000..dacec14
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_item1
@@ -0,0 +1,4 @@
+[item]
+[manpage_end ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_item2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_item2
new file mode 100644
index 0000000..ffe4125
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_item2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[item]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_item3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_item3
new file mode 100644
index 0000000..43bc9a7
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_item3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_begin]
+[item]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_begin1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_begin1
new file mode 100644
index 0000000..37e71ac
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_begin1
@@ -0,0 +1,4 @@
+[list_begin definitions]
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_begin2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_begin2
new file mode 100644
index 0000000..6604243
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_begin2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[list_begin definitions]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_begin3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_begin3
new file mode 100644
index 0000000..cd0ee95
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_begin3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_begin]
+[list_begin definitions]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_end1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_end1
new file mode 100644
index 0000000..a8e221f
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_end1
@@ -0,0 +1,4 @@
+[list_end]
+[manpage_end ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_end2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_end2
new file mode 100644
index 0000000..a0b5e5f
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_end2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[list_end]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_end3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_end3
new file mode 100644
index 0000000..5bff582
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_list_end3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_begin]
+[list_end]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_manpage_end b/tcllib/modules/doctools/tests/syntax/e_bodycmd_manpage_end
new file mode 100644
index 0000000..3ca4d96
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_manpage_end
@@ -0,0 +1,5 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {example not closed}]
+[example_begin]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_opt_def1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_opt_def1
new file mode 100644
index 0000000..c107610
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_opt_def1
@@ -0,0 +1,4 @@
+[opt_def .option.]
+[manpage_end ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_opt_def2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_opt_def2
new file mode 100644
index 0000000..e5c3687
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_opt_def2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[opt_def .option.]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_opt_def3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_opt_def3
new file mode 100644
index 0000000..d3758dc
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_opt_def3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_begin]
+[opt_def .option.]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_para1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_para1
new file mode 100644
index 0000000..15df4d3
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_para1
@@ -0,0 +1,4 @@
+[para]
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_para2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_para2
new file mode 100644
index 0000000..b5aceba
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_para2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[para]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_para3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_para3
new file mode 100644
index 0000000..60f8d5b
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_para3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_begin]
+[para]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_section1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_section1
new file mode 100644
index 0000000..d021414
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_section1
@@ -0,0 +1,4 @@
+[section foo]
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_section2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_section2
new file mode 100644
index 0000000..5a76f33
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_section2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[section foo]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_section3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_section3
new file mode 100644
index 0000000..fa7cf65
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_section3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_begin]
+[section foo]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_sectref1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_sectref1
new file mode 100644
index 0000000..792a4e3
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_sectref1
@@ -0,0 +1,4 @@
+[sectref S]
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_sectref2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_sectref2
new file mode 100644
index 0000000..79fa807
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_sectref2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[sectref S]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_sectref3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_sectref3
new file mode 100644
index 0000000..a4be9dc
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_sectref3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_begin]
+[sectref S]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_subsection1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_subsection1
new file mode 100644
index 0000000..1b78303
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_subsection1
@@ -0,0 +1,4 @@
+[subsection foo]
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_subsection2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_subsection2
new file mode 100644
index 0000000..55578bd
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_subsection2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[subsection foo]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_subsection3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_subsection3
new file mode 100644
index 0000000..c65910e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_subsection3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad subsection}]
+[example_begin]
+[subsection foo]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_tkoption_def1 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_tkoption_def1
new file mode 100644
index 0000000..650dca5
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_tkoption_def1
@@ -0,0 +1,4 @@
+[tkoption_def .option. .dbname. .dbclass.]
+[manpage_end ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_tkoption_def2 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_tkoption_def2
new file mode 100644
index 0000000..270948c
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_tkoption_def2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[tkoption_def .option. .dbname. .dbclass.]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bodycmd_tkoption_def3 b/tcllib/modules/doctools/tests/syntax/e_bodycmd_tkoption_def3
new file mode 100644
index 0000000..776b184
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bodycmd_tkoption_def3
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_begin]
+[tkoption_def .option. .dbname. .dbclass.]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_bulletlist b/tcllib/modules/doctools/tests/syntax/e_bulletlist
new file mode 100644
index 0000000..fda8e8e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_bulletlist
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[list_begin definitions]
+[item]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_cmd_list b/tcllib/modules/doctools/tests/syntax/e_cmd_list
new file mode 100644
index 0000000..3abf20f
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_cmd_list
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[list_begin definitions]
+[cmd_def .command.]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_deflist_call b/tcllib/modules/doctools/tests/syntax/e_deflist_call
new file mode 100644
index 0000000..2fc184f
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_deflist_call
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[list_begin arguments]
+[call .command.]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_deflist_def b/tcllib/modules/doctools/tests/syntax/e_deflist_def
new file mode 100644
index 0000000..33541ce
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_deflist_def
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[list_begin options]
+[def]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_end_open_example b/tcllib/modules/doctools/tests/syntax/e_end_open_example
new file mode 100644
index 0000000..cc77b82
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_end_open_example
@@ -0,0 +1,5 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {example not closed}]
+[example_begin]
+
diff --git a/tcllib/modules/doctools/tests/syntax/e_end_open_list b/tcllib/modules/doctools/tests/syntax/e_end_open_list
new file mode 100644
index 0000000..2f8db2f
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_end_open_list
@@ -0,0 +1,5 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[list_begin commands]
+[comment {list not closed}]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_end_open_mp b/tcllib/modules/doctools/tests/syntax/e_end_open_mp
new file mode 100644
index 0000000..4b2a040
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_end_open_mp
@@ -0,0 +1,2 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[comment {manpage not closed}]
diff --git a/tcllib/modules/doctools/tests/syntax/e_enumlist b/tcllib/modules/doctools/tests/syntax/e_enumlist
new file mode 100644
index 0000000..36713aa
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_enumlist
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[list_begin definitions]
+[enum]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_examplecmd1 b/tcllib/modules/doctools/tests/syntax/e_examplecmd1
new file mode 100644
index 0000000..c5c919e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_examplecmd1
@@ -0,0 +1,4 @@
+[example_end]
+[manpage_end ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_examplecmd2 b/tcllib/modules/doctools/tests/syntax/e_examplecmd2
new file mode 100644
index 0000000..7b08898
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_examplecmd2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[example_end]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_examplecmd3 b/tcllib/modules/doctools/tests/syntax/e_examplecmd3
new file mode 100644
index 0000000..e20804a
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_examplecmd3
@@ -0,0 +1,5 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[example_end]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_hdrcmd_copyright1 b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_copyright1
new file mode 100644
index 0000000..011d640
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_copyright1
@@ -0,0 +1,4 @@
+[copyright foo]
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_hdrcmd_copyright2 b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_copyright2
new file mode 100644
index 0000000..75aa471
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_copyright2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[copyright foo]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_hdrcmd_description1 b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_description1
new file mode 100644
index 0000000..60da8e9
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_description1
@@ -0,0 +1,4 @@
+[description]
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_hdrcmd_description2 b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_description2
new file mode 100644
index 0000000..9cd8477
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_description2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_hdrcmd_moddesc1 b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_moddesc1
new file mode 100644
index 0000000..8cb7389
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_moddesc1
@@ -0,0 +1,4 @@
+[moddesc foo]
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_hdrcmd_moddesc2 b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_moddesc2
new file mode 100644
index 0000000..c54a326
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_moddesc2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[moddesc foo]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_hdrcmd_require1 b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_require1
new file mode 100644
index 0000000..fb21304
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_require1
@@ -0,0 +1,4 @@
+[require foo]
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_hdrcmd_require2 b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_require2
new file mode 100644
index 0000000..eb7c979
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_require2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[require foo]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_hdrcmd_titledesc1 b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_titledesc1
new file mode 100644
index 0000000..bdce8a8
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_titledesc1
@@ -0,0 +1,4 @@
+[titledesc foo]
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_hdrcmd_titledesc2 b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_titledesc2
new file mode 100644
index 0000000..784efae
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_hdrcmd_titledesc2
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[titledesc foo]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_invalidlist_list_begin b/tcllib/modules/doctools/tests/syntax/e_invalidlist_list_begin
new file mode 100644
index 0000000..b701442
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_invalidlist_list_begin
@@ -0,0 +1,5 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[list_begin bogus]
+[list_end]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_listcmd_arg_def b/tcllib/modules/doctools/tests/syntax/e_listcmd_arg_def
new file mode 100644
index 0000000..753b082
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_listcmd_arg_def
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+
+[arg_def arg-type arg-name]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_listcmd_call b/tcllib/modules/doctools/tests/syntax/e_listcmd_call
new file mode 100644
index 0000000..8960db8
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_listcmd_call
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+
+[call .command.]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_listcmd_cmd_def b/tcllib/modules/doctools/tests/syntax/e_listcmd_cmd_def
new file mode 100644
index 0000000..989d5e7
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_listcmd_cmd_def
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+
+[cmd_def .command.]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_listcmd_def b/tcllib/modules/doctools/tests/syntax/e_listcmd_def
new file mode 100644
index 0000000..88101d3
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_listcmd_def
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+
+[def]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_listcmd_enum b/tcllib/modules/doctools/tests/syntax/e_listcmd_enum
new file mode 100644
index 0000000..a177d56
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_listcmd_enum
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+
+[enum]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_listcmd_item b/tcllib/modules/doctools/tests/syntax/e_listcmd_item
new file mode 100644
index 0000000..854659e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_listcmd_item
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+
+[item]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_listcmd_opt_def b/tcllib/modules/doctools/tests/syntax/e_listcmd_opt_def
new file mode 100644
index 0000000..820ea58
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_listcmd_opt_def
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+
+[opt_def .option.]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_listcmd_tkoption_def b/tcllib/modules/doctools/tests/syntax/e_listcmd_tkoption_def
new file mode 100644
index 0000000..2e05f78
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_listcmd_tkoption_def
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+
+[tkoption_def .option. .dbname. .dbclass.]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_mpbegin b/tcllib/modules/doctools/tests/syntax/e_mpbegin
new file mode 100644
index 0000000..cc86833
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_mpbegin
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[manpage_begin BOGUS e 2.71828182845904523536]
+[description]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_arg b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_arg
new file mode 100644
index 0000000..4ec427d
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_arg
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[arg .a.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_class b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_class
new file mode 100644
index 0000000..9d9b289
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_class
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[class .c.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_cmd b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_cmd
new file mode 100644
index 0000000..ebc5027
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_cmd
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[cmd .c.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_comment b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_comment
new file mode 100644
index 0000000..fd3799b
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_comment
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[comment .c]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_const b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_const
new file mode 100644
index 0000000..25e217a
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_const
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[const .c.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_emph b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_emph
new file mode 100644
index 0000000..2c2116d
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_emph
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[emph .t.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_file b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_file
new file mode 100644
index 0000000..9ef7be8
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_file
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[file .f.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_fun b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_fun
new file mode 100644
index 0000000..668ebf0
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_fun
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[fun .f.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_keywords b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_keywords
new file mode 100644
index 0000000..72707eb
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_keywords
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[keywords .kw.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_method b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_method
new file mode 100644
index 0000000..c3e33eb
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_method
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[method .m.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_namespace b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_namespace
new file mode 100644
index 0000000..22787a9
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_namespace
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[namespace .n.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_opt b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_opt
new file mode 100644
index 0000000..3ce4eb9
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_opt
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[opt .o]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_option b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_option
new file mode 100644
index 0000000..a605936
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_option
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[option .o.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_package b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_package
new file mode 100644
index 0000000..1bdab2c
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_package
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[package .p.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_see_also b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_see_also
new file mode 100644
index 0000000..c460dcc
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_see_also
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[see_also .sa.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_syscmd b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_syscmd
new file mode 100644
index 0000000..92c94ad
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_syscmd
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[syscmd .t]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_term b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_term
new file mode 100644
index 0000000..e2fca6a
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_term
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[term .t.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_type b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_type
new file mode 100644
index 0000000..86c43b7
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_type
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[type .t.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_uri b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_uri
new file mode 100644
index 0000000..b5a048e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_uri
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[uri .u.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_usage b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_usage
new file mode 100644
index 0000000..e7ca07e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_usage
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[usage .c.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_var b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_var
new file mode 100644
index 0000000..55061fc
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_var
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[var .v]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nodonecmd_widget b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_widget
new file mode 100644
index 0000000..03ca668
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nodonecmd_widget
@@ -0,0 +1,4 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[manpage_end]
+[widget .w.]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nolistcmd_section b/tcllib/modules/doctools/tests/syntax/e_nolistcmd_section
new file mode 100644
index 0000000..d7d052c
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nolistcmd_section
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[list_begin definitions]
+[section foo]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nolistcmd_subsection b/tcllib/modules/doctools/tests/syntax/e_nolistcmd_subsection
new file mode 100644
index 0000000..54083f3
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nolistcmd_subsection
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad subsection}]
+[list_begin definitions]
+[subsection foo]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nolisthdr_example b/tcllib/modules/doctools/tests/syntax/e_nolisthdr_example
new file mode 100644
index 0000000..ba31d74
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nolisthdr_example
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad example before list item}]
+[list_begin definitions]
+[example {}]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nolisthdr_example_begin b/tcllib/modules/doctools/tests/syntax/e_nolisthdr_example_begin
new file mode 100644
index 0000000..8bf39d9
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nolisthdr_example_begin
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad example_begin before list item}]
+[list_begin definitions]
+[example_begin]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nolisthdr_list_begin b/tcllib/modules/doctools/tests/syntax/e_nolisthdr_list_begin
new file mode 100644
index 0000000..640dbd2
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nolisthdr_list_begin
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad list_begin before list item}]
+[list_begin definitions]
+[list_begin definitions]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nolisthdr_para b/tcllib/modules/doctools/tests/syntax/e_nolisthdr_para
new file mode 100644
index 0000000..eaf06ca
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nolisthdr_para
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad para before list item}]
+[list_begin definitions]
+[para]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nolisthdr_sectref b/tcllib/modules/doctools/tests/syntax/e_nolisthdr_sectref
new file mode 100644
index 0000000..dcd12cc
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nolisthdr_sectref
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad sectref S before list item}]
+[list_begin definitions]
+[sectref S]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_nolisttxt b/tcllib/modules/doctools/tests/syntax/e_nolisttxt
new file mode 100644
index 0000000..25d55d8
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_nolisttxt
@@ -0,0 +1,7 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[list_begin definitions]
+Text between list_begin and first item is not allowed
+[def foo]
+[list_end]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_opt_list b/tcllib/modules/doctools/tests/syntax/e_opt_list
new file mode 100644
index 0000000..2b19792
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_opt_list
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[list_begin definitions]
+[opt_def .option.]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/e_tkoption_list b/tcllib/modules/doctools/tests/syntax/e_tkoption_list
new file mode 100644
index 0000000..cc8daa8
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/e_tkoption_list
@@ -0,0 +1,6 @@
+[manpage_begin ERROR e 2.71828182845904523536]
+[description]
+[comment {bad section}]
+[list_begin definitions]
+[tkoption_def .option. .dbname. .dbclass.]
+[manpage_end]
diff --git a/tcllib/modules/doctools/tests/syntax/r_arg_list b/tcllib/modules/doctools/tests/syntax/r_arg_list
new file mode 100644
index 0000000..606ce63
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_arg_list
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[arg_def arg-type arg-name]
+--> (FmtError) Manpage error (arg_list), "arg_def arg-type arg-name" : Command restricted to usage in argument lists.
diff --git a/tcllib/modules/doctools/tests/syntax/r_body b/tcllib/modules/doctools/tests/syntax/r_body
new file mode 100644
index 0000000..fe30a1d
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_body
@@ -0,0 +1,4 @@
+Doctools Error in plain text at line 1, column 0:
+[plain_text {Text before manpag...]
+--> (FmtError) Manpage error (body), "plain_text Text before manpage_begin is not allowed
+" : Plain text not allowed outside of the body of the manpage. \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_arg_def1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_arg_def1
new file mode 100644
index 0000000..e4c56aa
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_arg_def1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[arg_def arg-type arg-name]
+--> (FmtError) Manpage error (bodycmd), "arg_def arg-type arg-name" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_arg_def2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_arg_def2
new file mode 100644
index 0000000..39fc9e5
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_arg_def2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[arg_def arg-type arg-name]
+--> (FmtError) Manpage error (bodycmd), "arg_def arg-type arg-name" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_arg_def3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_arg_def3
new file mode 100644
index 0000000..8fad811
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_arg_def3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[arg_def arg-type arg-name]
+--> (FmtError) Manpage error (bodycmd), "arg_def arg-type arg-name" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_call1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_call1
new file mode 100644
index 0000000..7db2378
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_call1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[call .command.]
+--> (FmtError) Manpage error (bodycmd), "call .command." : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_call2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_call2
new file mode 100644
index 0000000..ab2b451
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_call2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[call .command.]
+--> (FmtError) Manpage error (bodycmd), "call .command." : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_call3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_call3
new file mode 100644
index 0000000..812f343
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_call3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[call .command.]
+--> (FmtError) Manpage error (bodycmd), "call .command." : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_cmd_def1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_cmd_def1
new file mode 100644
index 0000000..cc165d1
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_cmd_def1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[cmd_def .command.]
+--> (FmtError) Manpage error (bodycmd), "cmd_def .command." : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_cmd_def2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_cmd_def2
new file mode 100644
index 0000000..ef2562d
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_cmd_def2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[cmd_def .command.]
+--> (FmtError) Manpage error (bodycmd), "cmd_def .command." : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_cmd_def3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_cmd_def3
new file mode 100644
index 0000000..c9839a7
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_cmd_def3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[cmd_def .command.]
+--> (FmtError) Manpage error (bodycmd), "cmd_def .command." : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_def1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_def1
new file mode 100644
index 0000000..d1a6f48
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_def1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[def]
+--> (FmtError) Manpage error (bodycmd), "def" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_def2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_def2
new file mode 100644
index 0000000..2fbf5fa
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_def2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[def]
+--> (FmtError) Manpage error (bodycmd), "def" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_def3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_def3
new file mode 100644
index 0000000..70be81e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_def3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[def]
+--> (FmtError) Manpage error (bodycmd), "def" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_enum1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_enum1
new file mode 100644
index 0000000..5a7f4e3
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_enum1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[enum]
+--> (FmtError) Manpage error (bodycmd), "enum" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_enum2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_enum2
new file mode 100644
index 0000000..241255f
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_enum2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[enum]
+--> (FmtError) Manpage error (bodycmd), "enum" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_enum3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_enum3
new file mode 100644
index 0000000..a772fce
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_enum3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[enum]
+--> (FmtError) Manpage error (bodycmd), "enum" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_example1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_example1
new file mode 100644
index 0000000..9aa7d2e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_example1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[example {}]
+--> (FmtError) Manpage error (bodycmd), "example " : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_example2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_example2
new file mode 100644
index 0000000..b6b622d
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_example2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[example {}]
+--> (FmtError) Manpage error (bodycmd), "example " : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_example3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_example3
new file mode 100644
index 0000000..6fe07d4
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_example3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[example {}]
+--> (FmtError) Manpage error (bodycmd), "example " : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_example_begin1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_example_begin1
new file mode 100644
index 0000000..15e9da6
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_example_begin1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[example_begin]
+--> (FmtError) Manpage error (bodycmd), "example_begin" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_example_begin2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_example_begin2
new file mode 100644
index 0000000..78b0f04
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_example_begin2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[example_begin]
+--> (FmtError) Manpage error (bodycmd), "example_begin" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_example_begin3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_example_begin3
new file mode 100644
index 0000000..ccbc316
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_example_begin3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[example_begin]
+--> (FmtError) Manpage error (bodycmd), "example_begin" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_item1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_item1
new file mode 100644
index 0000000..d4b8d2f
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_item1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[item]
+--> (FmtError) Manpage error (bodycmd), "item" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_item2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_item2
new file mode 100644
index 0000000..0e10f63
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_item2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[item]
+--> (FmtError) Manpage error (bodycmd), "item" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_item3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_item3
new file mode 100644
index 0000000..264c774
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_item3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[item]
+--> (FmtError) Manpage error (bodycmd), "item" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_begin1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_begin1
new file mode 100644
index 0000000..662206d
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_begin1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[list_begin definitions]
+--> (FmtError) Manpage error (bodycmd), "list_begin definitions" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_begin2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_begin2
new file mode 100644
index 0000000..d14f992
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_begin2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[list_begin definitions]
+--> (FmtError) Manpage error (bodycmd), "list_begin definitions" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_begin3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_begin3
new file mode 100644
index 0000000..5d8eb05
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_begin3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[list_begin definitions]
+--> (FmtError) Manpage error (bodycmd), "list_begin definitions" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_end1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_end1
new file mode 100644
index 0000000..8ba3285
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_end1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[list_end]
+--> (FmtError) Manpage error (bodycmd), "list_end" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_end2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_end2
new file mode 100644
index 0000000..7ccc09a
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_end2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[list_end]
+--> (FmtError) Manpage error (bodycmd), "list_end" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_end3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_end3
new file mode 100644
index 0000000..e730c2b
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_list_end3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[list_end]
+--> (FmtError) Manpage error (bodycmd), "list_end" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_manpage_end b/tcllib/modules/doctools/tests/syntax/r_bodycmd_manpage_end
new file mode 100644
index 0000000..5ec9b9b
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_manpage_end
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[manpage_end]
+--> (FmtError) Manpage error (bodycmd), "manpage_end" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_opt_def1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_opt_def1
new file mode 100644
index 0000000..6f942b4
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_opt_def1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[opt_def .option.]
+--> (FmtError) Manpage error (bodycmd), "opt_def .option." : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_opt_def2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_opt_def2
new file mode 100644
index 0000000..1cffe35
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_opt_def2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[opt_def .option.]
+--> (FmtError) Manpage error (bodycmd), "opt_def .option." : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_opt_def3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_opt_def3
new file mode 100644
index 0000000..9a4fa68
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_opt_def3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[opt_def .option.]
+--> (FmtError) Manpage error (bodycmd), "opt_def .option." : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_para1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_para1
new file mode 100644
index 0000000..1f9f86f
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_para1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[para]
+--> (FmtError) Manpage error (bodycmd), "para" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_para2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_para2
new file mode 100644
index 0000000..7d01ae5
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_para2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[para]
+--> (FmtError) Manpage error (bodycmd), "para" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_para3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_para3
new file mode 100644
index 0000000..e726810
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_para3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[para]
+--> (FmtError) Manpage error (bodycmd), "para" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_section1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_section1
new file mode 100644
index 0000000..82a7d7d
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_section1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[section foo]
+--> (FmtError) Manpage error (bodycmd), "section foo" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_section2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_section2
new file mode 100644
index 0000000..e210e8a
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_section2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[section foo]
+--> (FmtError) Manpage error (bodycmd), "section foo" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_section3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_section3
new file mode 100644
index 0000000..5c7d0d1
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_section3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[section foo]
+--> (FmtError) Manpage error (bodycmd), "section foo" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_sectref1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_sectref1
new file mode 100644
index 0000000..dd0adf6
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_sectref1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[sectref S]
+--> (FmtError) Manpage error (bodycmd), "sectref S" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_sectref2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_sectref2
new file mode 100644
index 0000000..042c226
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_sectref2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[sectref S]
+--> (FmtError) Manpage error (bodycmd), "sectref S" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_sectref3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_sectref3
new file mode 100644
index 0000000..7ea9783
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_sectref3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[sectref S]
+--> (FmtError) Manpage error (bodycmd), "sectref S" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_subsection1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_subsection1
new file mode 100644
index 0000000..6816e38
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_subsection1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[subsection foo]
+--> (FmtError) Manpage error (bodycmd), "subsection foo" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_subsection2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_subsection2
new file mode 100644
index 0000000..92738e0
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_subsection2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[subsection foo]
+--> (FmtError) Manpage error (bodycmd), "subsection foo" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_subsection3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_subsection3
new file mode 100644
index 0000000..659ac48
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_subsection3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[subsection foo]
+--> (FmtError) Manpage error (bodycmd), "subsection foo" : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_tkoption_def1 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_tkoption_def1
new file mode 100644
index 0000000..76876b6
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_tkoption_def1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[tkoption_def .option. .dbname....]
+--> (FmtError) Manpage error (bodycmd), "tkoption_def .option. .dbname. .dbclass." : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_tkoption_def2 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_tkoption_def2
new file mode 100644
index 0000000..a2547e8
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_tkoption_def2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[tkoption_def .option. .dbname....]
+--> (FmtError) Manpage error (bodycmd), "tkoption_def .option. .dbname. .dbclass." : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bodycmd_tkoption_def3 b/tcllib/modules/doctools/tests/syntax/r_bodycmd_tkoption_def3
new file mode 100644
index 0000000..5599f07
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bodycmd_tkoption_def3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[tkoption_def .option. .dbname....]
+--> (FmtError) Manpage error (bodycmd), "tkoption_def .option. .dbname. .dbclass." : Command not allowed outside of the body of the manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_bulletlist b/tcllib/modules/doctools/tests/syntax/r_bulletlist
new file mode 100644
index 0000000..6a0ff5a
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_bulletlist
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[item]
+--> (FmtError) Manpage error (bulletlist), "item" : Command restricted to usage in itemized lists.
diff --git a/tcllib/modules/doctools/tests/syntax/r_cmd_list b/tcllib/modules/doctools/tests/syntax/r_cmd_list
new file mode 100644
index 0000000..4d88a92
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_cmd_list
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[cmd_def .command.]
+--> (FmtError) Manpage error (cmd_list), "cmd_def .command." : Command restricted to usage in command lists.
diff --git a/tcllib/modules/doctools/tests/syntax/r_deflist_call b/tcllib/modules/doctools/tests/syntax/r_deflist_call
new file mode 100644
index 0000000..dbc836b
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_deflist_call
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[call .command.]
+--> (FmtError) Manpage error (deflist), "call .command." : Command restricted to usage in definition lists.
diff --git a/tcllib/modules/doctools/tests/syntax/r_deflist_def b/tcllib/modules/doctools/tests/syntax/r_deflist_def
new file mode 100644
index 0000000..78ea873
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_deflist_def
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[def]
+--> (FmtError) Manpage error (deflist), "def" : Command restricted to usage in definition lists.
diff --git a/tcllib/modules/doctools/tests/syntax/r_end_open_example b/tcllib/modules/doctools/tests/syntax/r_end_open_example
new file mode 100644
index 0000000..c94311b
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_end_open_example
@@ -0,0 +1 @@
+(FmtError) Manpage error (end/open/example), "ck_complete" : End of manpage reached, [example_end] missing.
diff --git a/tcllib/modules/doctools/tests/syntax/r_end_open_list b/tcllib/modules/doctools/tests/syntax/r_end_open_list
new file mode 100644
index 0000000..175ed88
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_end_open_list
@@ -0,0 +1 @@
+(FmtError) Manpage error (end/open/list), "ck_complete" : End of manpage reached, [list_end] missing.
diff --git a/tcllib/modules/doctools/tests/syntax/r_end_open_mp b/tcllib/modules/doctools/tests/syntax/r_end_open_mp
new file mode 100644
index 0000000..0098167
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_end_open_mp
@@ -0,0 +1 @@
+(FmtError) Manpage error (end/open/mp), "ck_complete" : End of manpage reached, [manpage_end] missing.
diff --git a/tcllib/modules/doctools/tests/syntax/r_enumlist b/tcllib/modules/doctools/tests/syntax/r_enumlist
new file mode 100644
index 0000000..02dbc99
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_enumlist
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[enum]
+--> (FmtError) Manpage error (enumlist), "enum" : Command restricted to usage in enumerated lists.
diff --git a/tcllib/modules/doctools/tests/syntax/r_examplecmd1 b/tcllib/modules/doctools/tests/syntax/r_examplecmd1
new file mode 100644
index 0000000..73e8afa
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_examplecmd1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[example_end]
+--> (FmtError) Manpage error (examplecmd), "example_end" : Command allowed only to close example section.
diff --git a/tcllib/modules/doctools/tests/syntax/r_examplecmd2 b/tcllib/modules/doctools/tests/syntax/r_examplecmd2
new file mode 100644
index 0000000..cdeb0f9
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_examplecmd2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[example_end]
+--> (FmtError) Manpage error (examplecmd), "example_end" : Command allowed only to close example section.
diff --git a/tcllib/modules/doctools/tests/syntax/r_examplecmd3 b/tcllib/modules/doctools/tests/syntax/r_examplecmd3
new file mode 100644
index 0000000..fef7b3e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_examplecmd3
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[example_end]
+--> (FmtError) Manpage error (examplecmd), "example_end" : Command allowed only to close example section.
diff --git a/tcllib/modules/doctools/tests/syntax/r_hdrcmd_copyright1 b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_copyright1
new file mode 100644
index 0000000..d553b7a
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_copyright1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[copyright foo]
+--> (FmtError) Manpage error (hdrcmd), "copyright foo" : Command not allowed outside of the header section.
diff --git a/tcllib/modules/doctools/tests/syntax/r_hdrcmd_copyright2 b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_copyright2
new file mode 100644
index 0000000..c52e120
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_copyright2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 3, column 0:
+[copyright foo]
+--> (FmtError) Manpage error (hdrcmd), "copyright foo" : Command not allowed outside of the header section.
diff --git a/tcllib/modules/doctools/tests/syntax/r_hdrcmd_description1 b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_description1
new file mode 100644
index 0000000..efc4e0d
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_description1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[description]
+--> (FmtError) Manpage error (hdrcmd), "description" : Command not allowed outside of the header section.
diff --git a/tcllib/modules/doctools/tests/syntax/r_hdrcmd_description2 b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_description2
new file mode 100644
index 0000000..4513c72
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_description2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 3, column 0:
+[description]
+--> (FmtError) Manpage error (hdrcmd), "description" : Command not allowed outside of the header section.
diff --git a/tcllib/modules/doctools/tests/syntax/r_hdrcmd_moddesc1 b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_moddesc1
new file mode 100644
index 0000000..540b3eb
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_moddesc1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[moddesc foo]
+--> (FmtError) Manpage error (hdrcmd), "moddesc foo" : Command not allowed outside of the header section.
diff --git a/tcllib/modules/doctools/tests/syntax/r_hdrcmd_moddesc2 b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_moddesc2
new file mode 100644
index 0000000..6dea202
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_moddesc2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 3, column 0:
+[moddesc foo]
+--> (FmtError) Manpage error (hdrcmd), "moddesc foo" : Command not allowed outside of the header section.
diff --git a/tcllib/modules/doctools/tests/syntax/r_hdrcmd_require1 b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_require1
new file mode 100644
index 0000000..2967dda
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_require1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[require foo]
+--> (FmtError) Manpage error (hdrcmd), "require foo" : Command not allowed outside of the header section.
diff --git a/tcllib/modules/doctools/tests/syntax/r_hdrcmd_require2 b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_require2
new file mode 100644
index 0000000..cc2a0d7
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_require2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 3, column 0:
+[require foo]
+--> (FmtError) Manpage error (hdrcmd), "require foo" : Command not allowed outside of the header section.
diff --git a/tcllib/modules/doctools/tests/syntax/r_hdrcmd_titledesc1 b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_titledesc1
new file mode 100644
index 0000000..bfaea22
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_titledesc1
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 1, column 0:
+[titledesc foo]
+--> (FmtError) Manpage error (hdrcmd), "titledesc foo" : Command not allowed outside of the header section.
diff --git a/tcllib/modules/doctools/tests/syntax/r_hdrcmd_titledesc2 b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_titledesc2
new file mode 100644
index 0000000..feb3d12
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_hdrcmd_titledesc2
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 3, column 0:
+[titledesc foo]
+--> (FmtError) Manpage error (hdrcmd), "titledesc foo" : Command not allowed outside of the header section.
diff --git a/tcllib/modules/doctools/tests/syntax/r_invalidlist_list_begin b/tcllib/modules/doctools/tests/syntax/r_invalidlist_list_begin
new file mode 100644
index 0000000..08bb149
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_invalidlist_list_begin
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 3, column 0:
+[list_begin bogus]
+--> (FmtError) Manpage error (invalidlist), "list_begin bogus" : Invalid list type "bogus".
diff --git a/tcllib/modules/doctools/tests/syntax/r_listcmd_arg_def b/tcllib/modules/doctools/tests/syntax/r_listcmd_arg_def
new file mode 100644
index 0000000..5b7dead
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_listcmd_arg_def
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[arg_def arg-type arg-name]
+--> (FmtError) Manpage error (listcmd), "arg_def arg-type arg-name" : Command not allowed outside of a list.
diff --git a/tcllib/modules/doctools/tests/syntax/r_listcmd_call b/tcllib/modules/doctools/tests/syntax/r_listcmd_call
new file mode 100644
index 0000000..654d685
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_listcmd_call
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[call .command.]
+--> (FmtError) Manpage error (listcmd), "call .command." : Command not allowed outside of a list.
diff --git a/tcllib/modules/doctools/tests/syntax/r_listcmd_cmd_def b/tcllib/modules/doctools/tests/syntax/r_listcmd_cmd_def
new file mode 100644
index 0000000..08f6e63
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_listcmd_cmd_def
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[cmd_def .command.]
+--> (FmtError) Manpage error (listcmd), "cmd_def .command." : Command not allowed outside of a list.
diff --git a/tcllib/modules/doctools/tests/syntax/r_listcmd_def b/tcllib/modules/doctools/tests/syntax/r_listcmd_def
new file mode 100644
index 0000000..d37f8b6
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_listcmd_def
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[def]
+--> (FmtError) Manpage error (listcmd), "def" : Command not allowed outside of a list.
diff --git a/tcllib/modules/doctools/tests/syntax/r_listcmd_enum b/tcllib/modules/doctools/tests/syntax/r_listcmd_enum
new file mode 100644
index 0000000..3511aa0
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_listcmd_enum
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[enum]
+--> (FmtError) Manpage error (listcmd), "enum" : Command not allowed outside of a list.
diff --git a/tcllib/modules/doctools/tests/syntax/r_listcmd_item b/tcllib/modules/doctools/tests/syntax/r_listcmd_item
new file mode 100644
index 0000000..6a0ce9a
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_listcmd_item
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[item]
+--> (FmtError) Manpage error (listcmd), "item" : Command not allowed outside of a list.
diff --git a/tcllib/modules/doctools/tests/syntax/r_listcmd_opt_def b/tcllib/modules/doctools/tests/syntax/r_listcmd_opt_def
new file mode 100644
index 0000000..fe99798
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_listcmd_opt_def
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[opt_def .option.]
+--> (FmtError) Manpage error (listcmd), "opt_def .option." : Command not allowed outside of a list.
diff --git a/tcllib/modules/doctools/tests/syntax/r_listcmd_tkoption_def b/tcllib/modules/doctools/tests/syntax/r_listcmd_tkoption_def
new file mode 100644
index 0000000..868a7d2
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_listcmd_tkoption_def
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[tkoption_def .option. .dbname....]
+--> (FmtError) Manpage error (listcmd), "tkoption_def .option. .dbname. .dbclass." : Command not allowed outside of a list.
diff --git a/tcllib/modules/doctools/tests/syntax/r_mpbegin b/tcllib/modules/doctools/tests/syntax/r_mpbegin
new file mode 100644
index 0000000..c0a4637
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_mpbegin
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 2, column 0:
+[manpage_begin BOGUS e 2.718281...]
+--> (FmtError) Manpage error (mpbegin), "manpage_begin BOGUS e 2.71828182845904523536" : Command must be first of manpage.
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_arg b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_arg
new file mode 100644
index 0000000..e4215d2
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_arg
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[arg .a.]
+--> (FmtError) Manpage error (nodonecmd), "arg .a." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_class b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_class
new file mode 100644
index 0000000..82e1c96
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_class
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[class .c.]
+--> (FmtError) Manpage error (nodonecmd), "class .c." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_cmd b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_cmd
new file mode 100644
index 0000000..7932343
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_cmd
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[cmd .c.]
+--> (FmtError) Manpage error (nodonecmd), "cmd .c." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_comment b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_comment
new file mode 100644
index 0000000..00cc8d5
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_comment
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[comment .c]
+--> (FmtError) Manpage error (nodonecmd), "comment .c" : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_const b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_const
new file mode 100644
index 0000000..ae86794
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_const
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[const .c.]
+--> (FmtError) Manpage error (nodonecmd), "const .c." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_emph b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_emph
new file mode 100644
index 0000000..ca55b52
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_emph
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[emph .t.]
+--> (FmtError) Manpage error (nodonecmd), "emph .t." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_file b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_file
new file mode 100644
index 0000000..fc19a8f
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_file
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[file .f.]
+--> (FmtError) Manpage error (nodonecmd), "file .f." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_fun b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_fun
new file mode 100644
index 0000000..c446c03
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_fun
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[fun .f.]
+--> (FmtError) Manpage error (nodonecmd), "fun .f." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_keywords b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_keywords
new file mode 100644
index 0000000..71a11dd
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_keywords
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[keywords .kw.]
+--> (FmtError) Manpage error (nodonecmd), "keywords .kw." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_method b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_method
new file mode 100644
index 0000000..89763df
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_method
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[method .m.]
+--> (FmtError) Manpage error (nodonecmd), "method .m." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_namespace b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_namespace
new file mode 100644
index 0000000..98f5f6c
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_namespace
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[namespace .n.]
+--> (FmtError) Manpage error (nodonecmd), "_namespace .n." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_opt b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_opt
new file mode 100644
index 0000000..55cf23e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_opt
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[opt .o]
+--> (FmtError) Manpage error (nodonecmd), "opt .o" : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_option b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_option
new file mode 100644
index 0000000..8566066
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_option
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[option .o.]
+--> (FmtError) Manpage error (nodonecmd), "option .o." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_package b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_package
new file mode 100644
index 0000000..f4786b4
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_package
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[package .p.]
+--> (FmtError) Manpage error (nodonecmd), "package .p." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_see_also b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_see_also
new file mode 100644
index 0000000..8f86a85
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_see_also
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[see_also .sa.]
+--> (FmtError) Manpage error (nodonecmd), "see_also .sa." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_syscmd b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_syscmd
new file mode 100644
index 0000000..fea66ba
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_syscmd
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[syscmd .t]
+--> (FmtError) Manpage error (nodonecmd), "syscmd .t" : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_term b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_term
new file mode 100644
index 0000000..87b0508
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_term
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[term .t.]
+--> (FmtError) Manpage error (nodonecmd), "term .t." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_type b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_type
new file mode 100644
index 0000000..6215855
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_type
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[type .t.]
+--> (FmtError) Manpage error (nodonecmd), "type .t." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_uri b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_uri
new file mode 100644
index 0000000..ff69b3e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_uri
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[uri .u.]
+--> (FmtError) Manpage error (nodonecmd), "uri .u." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_usage b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_usage
new file mode 100644
index 0000000..e8591be
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_usage
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[usage .c.]
+--> (FmtError) Manpage error (nodonecmd), "usage .c." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_var b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_var
new file mode 100644
index 0000000..f5452aa
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_var
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[var .v]
+--> (FmtError) Manpage error (nodonecmd), "var .v" : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nodonecmd_widget b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_widget
new file mode 100644
index 0000000..534cec2
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nodonecmd_widget
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 4, column 0:
+[widget .w.]
+--> (FmtError) Manpage error (nodonecmd), "widget .w." : Command not allowed after [manpage_end].
diff --git a/tcllib/modules/doctools/tests/syntax/r_nolistcmd_section b/tcllib/modules/doctools/tests/syntax/r_nolistcmd_section
new file mode 100644
index 0000000..105d626
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nolistcmd_section
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[section foo]
+--> (FmtError) Manpage error (nolistcmd), "section foo" : Command not allowed inside of a list.
diff --git a/tcllib/modules/doctools/tests/syntax/r_nolistcmd_subsection b/tcllib/modules/doctools/tests/syntax/r_nolistcmd_subsection
new file mode 100644
index 0000000..6f6480d
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nolistcmd_subsection
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[subsection foo]
+--> (FmtError) Manpage error (nolistcmd), "subsection foo" : Command not allowed inside of a list.
diff --git a/tcllib/modules/doctools/tests/syntax/r_nolisthdr_example b/tcllib/modules/doctools/tests/syntax/r_nolisthdr_example
new file mode 100644
index 0000000..2c6c41f
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nolisthdr_example
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[example {}]
+--> (FmtError) Manpage error (nolisthdr), "example " : Command not allowed between beginning of a list and its first item.
diff --git a/tcllib/modules/doctools/tests/syntax/r_nolisthdr_example_begin b/tcllib/modules/doctools/tests/syntax/r_nolisthdr_example_begin
new file mode 100644
index 0000000..27f659d
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nolisthdr_example_begin
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[example_begin]
+--> (FmtError) Manpage error (nolisthdr), "example_begin" : Command not allowed between beginning of a list and its first item.
diff --git a/tcllib/modules/doctools/tests/syntax/r_nolisthdr_list_begin b/tcllib/modules/doctools/tests/syntax/r_nolisthdr_list_begin
new file mode 100644
index 0000000..a96686b
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nolisthdr_list_begin
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[list_begin definitions]
+--> (FmtError) Manpage error (nolisthdr), "list_begin definitions" : Command not allowed between beginning of a list and its first item.
diff --git a/tcllib/modules/doctools/tests/syntax/r_nolisthdr_para b/tcllib/modules/doctools/tests/syntax/r_nolisthdr_para
new file mode 100644
index 0000000..93ab335
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nolisthdr_para
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[para]
+--> (FmtError) Manpage error (nolisthdr), "para" : Command not allowed between beginning of a list and its first item.
diff --git a/tcllib/modules/doctools/tests/syntax/r_nolisthdr_sectref b/tcllib/modules/doctools/tests/syntax/r_nolisthdr_sectref
new file mode 100644
index 0000000..3f30687
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nolisthdr_sectref
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[sectref S]
+--> (FmtError) Manpage error (nolisthdr), "sectref S" : Command not allowed between beginning of a list and its first item.
diff --git a/tcllib/modules/doctools/tests/syntax/r_nolisttxt b/tcllib/modules/doctools/tests/syntax/r_nolisttxt
new file mode 100644
index 0000000..42f2160
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_nolisttxt
@@ -0,0 +1,6 @@
+Doctools Error in plain text at line 3, column 24:
+[plain_text {
+Text between list...]
+--> (FmtError) Manpage error (nolisttxt), "plain_text
+Text between list_begin and first item is not allowed
+" : Plain text not allowed between beginning of a list and its first item.
diff --git a/tcllib/modules/doctools/tests/syntax/r_opt_list b/tcllib/modules/doctools/tests/syntax/r_opt_list
new file mode 100644
index 0000000..3b7d384
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_opt_list
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[opt_def .option.]
+--> (FmtError) Manpage error (opt_list), "opt_def .option." : Command restricted to usage in option lists.
diff --git a/tcllib/modules/doctools/tests/syntax/r_tkoption_list b/tcllib/modules/doctools/tests/syntax/r_tkoption_list
new file mode 100644
index 0000000..a9de502
--- /dev/null
+++ b/tcllib/modules/doctools/tests/syntax/r_tkoption_list
@@ -0,0 +1,3 @@
+Doctools Error in macro at line 5, column 0:
+[tkoption_def .option. .dbname....]
+--> (FmtError) Manpage error (tkoption_list), "tkoption_def .option. .dbname. .dbclass." : Command restricted to usage in tkoption lists.
diff --git a/tcllib/modules/doctools/tests/text/00 b/tcllib/modules/doctools/tests/text/00
new file mode 100644
index 0000000..c4adc22
--- /dev/null
+++ b/tcllib/modules/doctools/tests/text/00
@@ -0,0 +1,17 @@
+
+TEST -
+Generated from file '.FILE.' by tcllib/doctools with format 'text'
+TEST(z) 3.14.15.926 .MODULE. ""
+
+NAME
+====
+
+TEST -
+
+DESCRIPTION
+===========
+
+COPYRIGHT
+=========
+
+Copyright (c) .COPYRIGHT. \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/text/01 b/tcllib/modules/doctools/tests/text/01
new file mode 100644
index 0000000..742f125
--- /dev/null
+++ b/tcllib/modules/doctools/tests/text/01
@@ -0,0 +1,24 @@
+
+TEST -
+Generated from file '.FILE.' by tcllib/doctools with format 'text'
+TEST(z) 3.14.15.926 .MODULE. ""
+
+NAME
+====
+
+TEST -
+
+DESCRIPTION
+===========
+
+Argument ::Argument:: Class ::*Class*:: Command ::Command:: Comment :::: Const
+::*Constant*:: Emphasis ::_Emphasis_:: File ::"File/Path":: Function
+::*Function*:: Method ::Method:: Namespace ::*Namespace*:: Option ::Option::
+Optional ::?Optional?:: Package ::*Package*:: Syscmd ::*SystemCommand*:: Term
+::_Term_:: Type ::*Type*:: Uri ::<URL:Uri>:: Variable ::*Variable*:: Widget
+::*Widget*::
+
+COPYRIGHT
+=========
+
+Copyright (c) **Copyright** \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/text/02 b/tcllib/modules/doctools/tests/text/02
new file mode 100644
index 0000000..8d72762
--- /dev/null
+++ b/tcllib/modules/doctools/tests/text/02
@@ -0,0 +1,33 @@
+
+TEST - ..THE_MODULE..
+Generated from file '.FILE.' by tcllib/doctools with format 'text'
+TEST(z) 3.14.15.926 .MODULE. "..THE_MODULE.."
+
+NAME
+====
+
+TEST - ..THE_TITLE..
+
+SYNOPSIS
+========
+
+package require AAA
+package require BBB VVV
+
+DESCRIPTION
+===========
+
+SEE ALSO
+========
+
+ELSE, OTHER
+
+KEYWORDS
+========
+
+KEYA, KEYZ
+
+COPYRIGHT
+=========
+
+Copyright (c) .COPYRIGHT. \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/text/03 b/tcllib/modules/doctools/tests/text/03
new file mode 100644
index 0000000..5880409
--- /dev/null
+++ b/tcllib/modules/doctools/tests/text/03
@@ -0,0 +1,46 @@
+
+TEST -
+Generated from file '.FILE.' by tcllib/doctools with format 'text'
+TEST(z) 3.14.15.926 .MODULE. ""
+
+NAME
+====
+
+TEST -
+
+DESCRIPTION
+===========
+
+AaA
+===
+
+1
+
+BbB
+===
+
+22
+
+BbB.cCc
+-------
+
+333
+
+BbB.dDd
+-------
+
+4444
+
+EeE
+===
+
+5555
+
+At -> AaA.
+
+At -> __undefined__.
+
+COPYRIGHT
+=========
+
+Copyright (c) .COPYRIGHT. \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/text/04 b/tcllib/modules/doctools/tests/text/04
new file mode 100644
index 0000000..25d3f98
--- /dev/null
+++ b/tcllib/modules/doctools/tests/text/04
@@ -0,0 +1,28 @@
+
+TEST -
+Generated from file '.FILE.' by tcllib/doctools with format 'text'
+TEST(z) 3.14.15.926 .MODULE. ""
+
+NAME
+====
+
+TEST -
+
+DESCRIPTION
+===========
+
+BEGINNE HIER
+
+
+| Example Block More Lines
+
+
+| Inlined Example \
+| Next Line
+
+FERTIG
+
+COPYRIGHT
+=========
+
+Copyright (c) .COPYRIGHT. \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/text/05 b/tcllib/modules/doctools/tests/text/05
new file mode 100644
index 0000000..7ac98f2
--- /dev/null
+++ b/tcllib/modules/doctools/tests/text/05
@@ -0,0 +1,86 @@
+
+BASIC -
+Generated from file '.FILE.' by tcllib/doctools with format 'text'
+BASIC(a) 5 .MODULE. ""
+
+NAME
+====
+
+BASIC -
+
+SYNOPSIS
+========
+
+a-command
+
+DESCRIPTION
+===========
+
+OK
+
+ integer argument-1
+
+ verification
+
+ string argument-2 (out)
+
+ mogrification
+
+ command-a
+
+ explanation
+
+ command-b
+
+ elucidation
+
+ term
+
+ definition
+
+ a-command
+
+ semantic
+
+ [1] A
+
+ [2] B
+
+ C
+
+ D
+
+ * 1
+
+ * 2
+
+ 2a
+
+ 2b
+
+ option-1
+
+ meaning
+
+ option-2 value
+
+ elaboration
+
+ Command-Line Switch: background
+ Database Name: *Background*
+ Database Class: *Color*
+
+ candy
+
+ Command-Line Switch: foreground
+ Database Name: *Foreground*
+ Database Class: *Color*
+
+ caramel
+
+KO
+
+COPYRIGHT
+=========
+
+Copyright (c) .COPYRIGHT. \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/text/06 b/tcllib/modules/doctools/tests/text/06
new file mode 100644
index 0000000..dac1bdf
--- /dev/null
+++ b/tcllib/modules/doctools/tests/text/06
@@ -0,0 +1,53 @@
+
+TEST -
+Generated from file '.FILE.' by tcllib/doctools with format 'text'
+TEST(z) 3.14.15.926 .MODULE. ""
+
+NAME
+====
+
+TEST -
+
+DESCRIPTION
+===========
+
+ * 1
+
+ 2
+
+ 3
+
+ [1] a
+
+ b
+
+ c
+
+ foo
+
+ snafu
+
+ bar
+
+ barf
+
+ roo
+
+ gork
+
+ [2] a
+
+ b
+
+ c
+
+ * 4
+
+ 5
+
+ 6
+
+COPYRIGHT
+=========
+
+Copyright (c) .COPYRIGHT. \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/text/07 b/tcllib/modules/doctools/tests/text/07
new file mode 100644
index 0000000..3d9f378
--- /dev/null
+++ b/tcllib/modules/doctools/tests/text/07
@@ -0,0 +1,45 @@
+
+TEST -
+Generated from file '.FILE.' by tcllib/doctools with format 'text'
+TEST(z) 3.14.15.926 .MODULE. ""
+
+NAME
+====
+
+TEST -
+
+DESCRIPTION
+===========
+
+ * 1
+
+ * 2
+
+ [1] a
+
+ [2] b
+
+ foo
+
+ snafu
+
+ bar
+
+ barf
+
+ roo
+
+ gork
+
+ [3] bb
+
+ [4] a
+
+ * 22
+
+ * 3
+
+COPYRIGHT
+=========
+
+Copyright (c) .COPYRIGHT. \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/text/08 b/tcllib/modules/doctools/tests/text/08
new file mode 100644
index 0000000..4e85271
--- /dev/null
+++ b/tcllib/modules/doctools/tests/text/08
@@ -0,0 +1,138 @@
+
+ALL - ..THE_MODULE..
+Generated from file '.FILE.' by tcllib/doctools with format 'text'
+ALL(a) 5 .MODULE. "..THE_MODULE.."
+
+NAME
+====
+
+ALL - ..THE_TITLE..
+
+SYNOPSIS
+========
+
+package require AAA
+package require BBB VVV
+package require CCC ?VVV?
+
+CMDNAME ...
+CMDNAME ...
+CMDNAME ...
+
+DESCRIPTION
+===========
+
+ NAME
+
+ DESCRIPTION ::Command::
+
+ NAME
+
+ DESCRIPTION ::::
+
+ NAME
+
+ DESCRIPTION ::*Constant*::
+
+API
+===
+
+ TERM
+
+ DESCRIPTION ::_Emphasis_::
+
+ TERM
+
+ DESCRIPTION ::"File/Path"::
+
+ Command-Line Switch: NAME
+ Database Name: *DBNAME*
+ Database Class: *CLASS*
+
+ DESCRIPTION -> NARGLE
+
+ Command-Line Switch: NAME
+ Database Name: *DBNAME*
+ Database Class: *CLASS*
+
+ DESCRIPTION ::*Function*::
+
+ Command-Line Switch: NAME
+ Database Name: *DBNAME*
+ Database Class: *CLASS*
+
+ DESCRIPTION ::Method::
+
+ TERM
+
+ DESCRIPTION
+
+ CMDNAME ...
+
+ DESCRIPTION ::*Namespace*::
+
+ TYPE NAME
+
+ DESCRIPTION ::Argument::
+
+ TYPE NAME
+
+ DESCRIPTION ::Option::
+
+ TYPE NAME (MODE)
+
+ DESCRIPTION ::?Optional?::
+
+
+ | THE ARGUMENT IS USED IN THIS
+ | AND/OR THAT MANNER
+
+ CMDNAME ...
+
+ DESCRIPTION ::*Package*::
+
+ CMDNAME ...
+
+ DESCRIPTION ::*SystemCommand*::
+
+ NAME
+
+ DESCRIPTION ::_Term_::
+
+ NAME
+
+ DESCRIPTION ::*Type*::
+
+ NAME ARGUMENT
+
+ DESCRIPTION ::<URL:Uri>::
+
+NARGLE
+------
+
+ [1] PARAGRAPH ::_UriLabel_ <URL:Uri>::
+
+ [2] PARAGRAPH ::*Variable*::
+
+ [3] PARAGRAPH ::*Widget*::
+
+ * PARAGRAPH ::*Class*::
+
+ * PARAGRAPH
+
+ * PARAGRAPH
+
+SEE ALSO
+========
+
+ELSE, OTHER
+
+KEYWORDS
+========
+
+KEYA, KEYZ
+
+COPYRIGHT
+=========
+
+Copyright (c) **Copyright** \ No newline at end of file
diff --git a/tcllib/modules/doctools/tests/tmml/00 b/tcllib/modules/doctools/tests/tmml/00
new file mode 100644
index 0000000..ad98243
--- /dev/null
+++ b/tcllib/modules/doctools/tests/tmml/00
@@ -0,0 +1,19 @@
+<!-- Generated from file '.FILE.' by tcllib/doctools with format 'tmml' -->
+<manpage id='.FILE' cat='cmd' title='TEST' version='3.14.15.926' package='.MODULE.'>
+<head>
+<info key='copyright' value='Copyright (c) .COPYRIGHT.'/>
+</head>
+<namesection>
+<name>TEST</name>
+<desc></desc>
+
+</namesection>
+
+
+<section id='section1'>
+<title>DESCRIPTION</title>
+</section>
+
+
+
+</manpage>
diff --git a/tcllib/modules/doctools/tests/tmml/01 b/tcllib/modules/doctools/tests/tmml/01
new file mode 100644
index 0000000..795300f
--- /dev/null
+++ b/tcllib/modules/doctools/tests/tmml/01
@@ -0,0 +1,39 @@
+<!-- Generated from file '.FILE.' by tcllib/doctools with format 'tmml' -->
+<manpage id='.FILE' cat='cmd' title='TEST' version='3.14.15.926' package='.MODULE.'>
+<head>
+<info key='copyright' value='Copyright (c) **Copyright**'/>
+</head>
+<namesection>
+<name>TEST</name>
+<desc></desc>
+
+</namesection>
+
+
+
+<section id='section1'>
+<title>DESCRIPTION</title>
+Argument ::<m>Argument</m>::
+Class ::<class>Class</class>::
+Command ::<cmd>Command</cmd>::
+Comment ::::
+Const ::<l>Constant</l>::
+Emphasis ::<emph>Emphasis</emph>::
+File ::<file>File/Path</file>::
+Function ::<fun>Function</fun>::
+Method ::<method>Method</method>::
+Namespace ::<term>Namespace</term>::
+Option ::<option>Option</option>::
+Optional ::<o>Optional</o>::
+Package ::<package>Package</package>::
+Syscmd ::<syscmd>SystemCommand</syscmd>::
+Term ::<term>Term</term>::
+Type ::<type>Type</type>::
+Uri ::<url>Uri</url>::
+Variable ::<variable>Variable</variable>::
+Widget ::<widget>Widget</widget>::
+</section>
+
+
+
+</manpage>
diff --git a/tcllib/modules/doctools/tests/tmml/02 b/tcllib/modules/doctools/tests/tmml/02
new file mode 100644
index 0000000..4a33616
--- /dev/null
+++ b/tcllib/modules/doctools/tests/tmml/02
@@ -0,0 +1,36 @@
+<!-- Generated from file '.FILE.' by tcllib/doctools with format 'tmml' -->
+<manpage id='.FILE' cat='cmd' title='TEST' version='3.14.15.926' package='.MODULE.'>
+<head>
+<info key='copyright' value='Copyright (c) .COPYRIGHT.'/>
+</head>
+<namesection>
+<name>TEST</name>
+<desc>..THE_TITLE..</desc>
+
+</namesection>
+
+
+
+
+
+
+
+<synopsis>
+<syntax>
+package require <package>AAA</package>
+package require <package>BBB</package> VVV
+</syntax>
+</synopsis>
+<section id='section1'>
+<title>DESCRIPTION</title>
+</section>
+<seealso>
+<ref>OTHER</ref>
+<ref>ELSE</ref>
+</seealso>
+<keywords>
+<keyword>KEYA</keyword>
+<keyword>KEYZ</keyword>
+</keywords>
+
+</manpage>
diff --git a/tcllib/modules/doctools/tests/tmml/03 b/tcllib/modules/doctools/tests/tmml/03
new file mode 100644
index 0000000..6b96884
--- /dev/null
+++ b/tcllib/modules/doctools/tests/tmml/03
@@ -0,0 +1,49 @@
+<!-- Generated from file '.FILE.' by tcllib/doctools with format 'tmml' -->
+<manpage id='.FILE' cat='cmd' title='TEST' version='3.14.15.926' package='.MODULE.'>
+<head>
+<info key='copyright' value='Copyright (c) .COPYRIGHT.'/>
+</head>
+<namesection>
+<name>TEST</name>
+<desc></desc>
+
+</namesection>
+
+
+<section id='section1'>
+<title>DESCRIPTION</title>
+</section>
+<section id='section2'>
+<title>AAA</title>
+1
+</section>
+<section id='section3'>
+<title>BBB</title>
+22
+
+<subsection id='subsection1'>
+<title>BBB.CCC</title>
+333
+</subsection>
+<subsection id='subsection2'>
+<title>BBB.DDD</title>
+4444
+</subsection>
+</section>
+<section id='section4'>
+<title>EEE</title>
+5555
+
+
+<p>
+At <ref refid='section2'>AaA</ref>.
+</p>
+<p>
+At <emph>__undefined__</emph>.
+</p>
+</section>
+
+
+
+</manpage>
+
diff --git a/tcllib/modules/doctools/tests/tmml/04 b/tcllib/modules/doctools/tests/tmml/04
new file mode 100644
index 0000000..c6cf13b
--- /dev/null
+++ b/tcllib/modules/doctools/tests/tmml/04
@@ -0,0 +1,37 @@
+<!-- Generated from file '.FILE.' by tcllib/doctools with format 'tmml' -->
+<manpage id='.FILE' cat='cmd' title='TEST' version='3.14.15.926' package='.MODULE.'>
+<head>
+<info key='copyright' value='Copyright (c) .COPYRIGHT.'/>
+</head>
+<namesection>
+<name>TEST</name>
+<desc></desc>
+
+</namesection>
+
+
+<section id='section1'>
+<title>DESCRIPTION</title>
+BEGINNE HIER
+
+<example>
+ Example Block More Lines
+
+</example>
+
+<p>
+</p>
+<p>
+</p>
+<example>
+Inlined Example \
+Next Line
+
+</example>
+FERTIG
+</section>
+
+
+
+</manpage>
+
diff --git a/tcllib/modules/doctools/tests/tmml/05 b/tcllib/modules/doctools/tests/tmml/05
new file mode 100644
index 0000000..250838e
--- /dev/null
+++ b/tcllib/modules/doctools/tests/tmml/05
@@ -0,0 +1,162 @@
+
+<!-- Generated from file '.FILE.' by tcllib/doctools with format 'tmml' -->
+<manpage id='.FILE' cat='cmd' title='BASIC' version='5' package='.MODULE.'>
+<head>
+<info key='copyright' value='Copyright (c) .COPYRIGHT.'/>
+</head>
+<namesection>
+<name>BASIC</name>
+<desc></desc>
+
+</namesection>
+
+<synopsis>
+<syntax>
+a-command
+</syntax>
+</synopsis>
+<section id='section1'>
+<title>DESCRIPTION</title>
+OK
+
+<p>
+</p>
+<arglist>
+
+<argdef>
+<argtype>integer</argtype>
+<name>argument-1</name>
+
+<desc>
+verification
+</desc>
+</argdef>
+<argdef>
+<argtype>string</argtype>
+<name>argument-2</name>
+<argmode>out</argmode>
+<desc> mogrification
+</desc>
+</argdef>
+
+</arglist>
+
+<p>
+</p>
+<commandlist>
+
+<commanddef>
+<command>command-a</command>
+<desc> explanation
+</desc>
+</commanddef>
+<commanddef>
+<command>command-b</command>
+<desc>
+elucidation
+</desc>
+</commanddef>
+
+</commandlist>
+
+<p>
+</p>
+<dl>
+
+<dle>
+<dt>term</dt>
+<dd> definition
+</dd>
+</dle>
+<dle>
+<dt>a-command </dt>
+<dd>
+semantic
+</dd>
+</dle>
+
+</dl>
+
+<p>
+</p>
+<ol>
+
+<li>
+A
+</li>
+<li> B
+<br/>
+C
+<br/>
+D
+</li>
+
+</ol>
+
+<p>
+</p>
+<ul>
+
+<li>
+1
+</li>
+<li> 2
+<br/>
+2a
+<br/>
+2b
+</li>
+
+</ul>
+
+<p>
+</p>
+<optlist>
+
+<optdef>
+<optname>option-1</optname>
+
+<desc> meaning
+</desc>
+</optdef>
+<optdef>
+<optname>option-2</optname>
+<optarg>value</optarg>
+<desc>
+elaboration
+</desc>
+</optdef>
+
+</optlist>
+
+<p>
+</p>
+<optionlist>
+
+<optiondef>
+<name>background</name>
+<dbname>Background</dbname>
+<dbclass>Color</dbclass>
+<desc> candy
+</desc>
+</optiondef>
+<optiondef>
+<name>foreground</name>
+<dbname>Foreground</dbname>
+<dbclass>Color</dbclass>
+<desc>
+caramel
+</desc>
+</optiondef>
+
+</optionlist>
+
+<p>
+KO
+
+</p>
+</section>
+
+
+
+</manpage>
diff --git a/tcllib/modules/doctools/tests/tmml/06 b/tcllib/modules/doctools/tests/tmml/06
new file mode 100644
index 0000000..ccad907
--- /dev/null
+++ b/tcllib/modules/doctools/tests/tmml/06
@@ -0,0 +1,62 @@
+<!-- Generated from file '.FILE.' by tcllib/doctools with format 'tmml' -->
+<manpage id='.FILE' cat='cmd' title='TEST' version='3.14.15.926' package='.MODULE.'>
+<head>
+<info key='copyright' value='Copyright (c) .COPYRIGHT.'/>
+</head>
+<namesection>
+<name>TEST</name>
+<desc></desc>
+
+</namesection>
+
+
+<section id='section1'>
+<title>DESCRIPTION</title>
+
+
+<ul>
+
+<li> 1 <br/> 2 <br/> 3
+</li>
+<li>
+
+<ol>
+
+<li> a <br/> b <br/> c
+</li>
+<li>
+
+<dl>
+
+<dle>
+<dt>foo</dt>
+<dd> snafu
+</dd>
+</dle>
+<dle>
+<dt>bar</dt>
+<dd> barf
+</dd>
+</dle>
+<dle>
+<dt>roo</dt>
+<dd> gork
+</dd>
+</dle>
+
+</dl>
+</li>
+<li> a <br/> b <br/> c
+</li>
+
+</ol>
+</li>
+<li> 4 <br/> 5 <br/> 6
+</li>
+
+</ul>
+</section>
+
+
+
+</manpage>
diff --git a/tcllib/modules/doctools/tests/tmml/07 b/tcllib/modules/doctools/tests/tmml/07
new file mode 100644
index 0000000..1b1f693
--- /dev/null
+++ b/tcllib/modules/doctools/tests/tmml/07
@@ -0,0 +1,64 @@
+<!-- Generated from file '.FILE.' by tcllib/doctools with format 'tmml' -->
+<manpage id='.FILE' cat='cmd' title='TEST' version='3.14.15.926' package='.MODULE.'>
+<head>
+<info key='copyright' value='Copyright (c) .COPYRIGHT.'/>
+</head>
+<namesection>
+<name>TEST</name>
+<desc></desc>
+
+</namesection>
+
+
+<section id='section1'>
+<title>DESCRIPTION</title>
+
+
+<ul>
+
+<li> 1
+</li>
+<li> 2
+
+<ol>
+
+<li> a
+</li>
+<li> b
+
+<dl>
+
+<dle>
+<dt>foo</dt>
+<dd> snafu
+</dd>
+</dle>
+<dle>
+<dt>bar</dt>
+<dd> barf
+</dd>
+</dle>
+<dle>
+<dt>roo</dt>
+<dd> gork
+</dd>
+</dle>
+
+</dl>
+bb
+</li>
+<li> a
+</li>
+
+</ol>
+22
+</li>
+<li> 3
+</li>
+
+</ul>
+</section>
+
+
+
+</manpage>
diff --git a/tcllib/modules/doctools/tests/tmml/08 b/tcllib/modules/doctools/tests/tmml/08
new file mode 100644
index 0000000..f2ade2d
--- /dev/null
+++ b/tcllib/modules/doctools/tests/tmml/08
@@ -0,0 +1,207 @@
+
+<!-- Generated from file '.FILE.' by tcllib/doctools with format 'tmml' -->
+<manpage id='.FILE' cat='cmd' title='ALL' version='5' package='.MODULE.'>
+<head>
+<info key='copyright' value='Copyright (c) **Copyright**'/>
+</head>
+<namesection>
+<name>ALL</name>
+<desc>..THE_TITLE..</desc>
+
+</namesection>
+
+
+
+
+
+
+
+<synopsis>
+<syntax>
+package require <package>AAA</package>
+package require <package>BBB</package> VVV
+package require <package>CCC</package> <o>VVV</o>
+CMDNAME ...
+CMDNAME ...
+CMDNAME ...
+</syntax>
+</synopsis>
+<section id='section1'>
+<title>DESCRIPTION</title>
+
+<commandlist>
+
+<commanddef>
+<command>NAME</command>
+<desc> DESCRIPTION ::<cmd>Command</cmd>::
+</desc>
+</commanddef>
+<commanddef>
+<command>NAME</command>
+<desc> DESCRIPTION ::::
+</desc>
+</commanddef>
+<commanddef>
+<command>NAME</command>
+<desc> DESCRIPTION ::<l>Constant</l>::
+</desc>
+</commanddef>
+
+</commandlist>
+</section>
+<section id='section2'>
+<title>API</title>
+
+<dl>
+
+<dle>
+<dt>TERM</dt>
+<dd> DESCRIPTION ::<emph>Emphasis</emph>::
+</dd>
+</dle>
+<dle>
+<dt>TERM</dt>
+<dd> DESCRIPTION ::<file>File/Path</file>::
+
+<optionlist>
+
+<optiondef>
+<name>NAME</name>
+<dbname>DBNAME</dbname>
+<dbclass>CLASS</dbclass>
+<desc> DESCRIPTION <ref refid='subsection1'>NARGLE</ref>
+</desc>
+</optiondef>
+<optiondef>
+<name>NAME</name>
+<dbname>DBNAME</dbname>
+<dbclass>CLASS</dbclass>
+<desc> DESCRIPTION ::<fun>Function</fun>::
+</desc>
+</optiondef>
+<optiondef>
+<name>NAME</name>
+<dbname>DBNAME</dbname>
+<dbclass>CLASS</dbclass>
+<desc> DESCRIPTION ::<method>Method</method>::
+</desc>
+</optiondef>
+
+</optionlist>
+</dd>
+</dle>
+<dle>
+<dt>TERM</dt>
+<dd> DESCRIPTION
+</dd>
+</dle>
+<dle>
+<dt>CMDNAME ...</dt>
+<dd> DESCRIPTION ::<term>Namespace</term>::
+
+<arglist>
+
+<argdef>
+<argtype>TYPE</argtype>
+<name>NAME</name>
+
+<desc> DESCRIPTION ::<m>Argument</m>::
+</desc>
+</argdef>
+<argdef>
+<argtype>TYPE</argtype>
+<name>NAME</name>
+
+<desc> DESCRIPTION ::<option>Option</option>::
+</desc>
+</argdef>
+<argdef>
+<argtype>TYPE</argtype>
+<name>NAME</name>
+<argmode>MODE</argmode>
+<desc> DESCRIPTION ::<o>Optional</o>::
+
+<example>
+ THE ARGUMENT IS USED IN THIS
+ AND/OR THAT MANNER
+
+</example>
+</desc>
+</argdef>
+
+</arglist>
+</dd>
+</dle>
+<dle>
+<dt>CMDNAME ...</dt>
+<dd> DESCRIPTION ::<package>Package</package>::
+</dd>
+</dle>
+<dle>
+<dt>CMDNAME ...</dt>
+<dd> DESCRIPTION ::<syscmd>SystemCommand</syscmd>::
+
+<optlist>
+
+<optdef>
+<optname>NAME</optname>
+
+<desc> DESCRIPTION ::<term>Term</term>::
+</desc>
+</optdef>
+<optdef>
+<optname>NAME</optname>
+
+<desc> DESCRIPTION ::<type>Type</type>::
+</desc>
+</optdef>
+<optdef>
+<optname>NAME</optname>
+<optarg>ARGUMENT</optarg>
+<desc> DESCRIPTION ::<url>Uri</url>::
+</desc>
+</optdef>
+
+</optlist>
+</dd>
+</dle>
+
+</dl>
+
+<subsection id='subsection1'>
+<title>NARGLE</title>
+</subsection>
+<ol>
+
+<li> PARAGRAPH ::<url>Uri</url>::
+</li>
+<li> PARAGRAPH ::<variable>Variable</variable>::
+</li>
+<li> PARAGRAPH ::<widget>Widget</widget>::
+
+<ul>
+
+<li> PARAGRAPH ::<class>Class</class>::
+</li>
+<li> PARAGRAPH
+</li>
+<li> PARAGRAPH
+</li>
+
+</ul>
+</li>
+
+</ol>
+
+
+</section>
+<seealso>
+<ref>OTHER</ref>
+<ref>ELSE</ref>
+</seealso>
+<keywords>
+<keyword>KEYA</keyword>
+<keyword>KEYZ</keyword>
+</keywords>
+
+</manpage>
diff --git a/tcllib/modules/doctools/tests/wiki/00 b/tcllib/modules/doctools/tests/wiki/00
new file mode 100644
index 0000000..de2d99b
--- /dev/null
+++ b/tcllib/modules/doctools/tests/wiki/00
@@ -0,0 +1,13 @@
+'''TEST 3.14.15.926''' '''.MODULE.'''
+
+
+
+
+**DESCRIPTION**
+
+
+
+**COPYRIGHT**
+
+ Copyright (c) .COPYRIGHT.
+
diff --git a/tcllib/modules/doctools/tests/wiki/01 b/tcllib/modules/doctools/tests/wiki/01
new file mode 100644
index 0000000..f26ca64
--- /dev/null
+++ b/tcllib/modules/doctools/tests/wiki/01
@@ -0,0 +1,13 @@
+'''TEST 3.14.15.926''' '''.MODULE.'''
+
+
+
+
+**DESCRIPTION**
+
+Argument ::''Argument'':: Class ::'''Class''':: Command ::'''Command''':: Comment :::: Const ::'''Constant''':: Emphasis ::''Emphasis'':: File ::"''File/Path''":: Function ::'''Function''':: Method ::'''Method''':: Namespace ::'''Namespace''':: Option ::'''Option''':: Optional ::?Optional?:: Package ::'''Package''':: Syscmd ::'''SystemCommand''':: Term ::''Term'':: Type ::'''Type''':: Uri ::Uri:: Variable ::'''Variable''':: Widget ::'''Widget'''::
+
+**COPYRIGHT**
+
+ Copyright (c) **Copyright**
+
diff --git a/tcllib/modules/doctools/tests/wiki/02 b/tcllib/modules/doctools/tests/wiki/02
new file mode 100644
index 0000000..8ef71cf
--- /dev/null
+++ b/tcllib/modules/doctools/tests/wiki/02
@@ -0,0 +1,35 @@
+'''TEST 3.14.15.926''' '''.MODULE.''' ''..THE_MODULE..''
+
+..THE_TITLE..
+
+
+**SYNOPSIS**
+
+
+package require '''AAA'''
+
+package require '''BBB VVV'''
+
+
+
+
+**DESCRIPTION**
+
+
+
+**SEE ALSO**
+
+
+ELSE, OTHER
+
+
+**KEYWORDS**
+
+
+KEYA, KEYZ
+
+
+**COPYRIGHT**
+
+ Copyright (c) .COPYRIGHT.
+
diff --git a/tcllib/modules/doctools/tests/wiki/03 b/tcllib/modules/doctools/tests/wiki/03
new file mode 100644
index 0000000..5032e2a
--- /dev/null
+++ b/tcllib/modules/doctools/tests/wiki/03
@@ -0,0 +1,35 @@
+'''TEST 3.14.15.926''' '''.MODULE.'''
+
+
+
+
+**DESCRIPTION**
+
+
+
+**AaA**
+
+1
+
+**BbB**
+
+22
+
+***BbB.cCc***
+
+333
+
+***BbB.dDd***
+
+4444
+
+**EeE**
+
+5555
+At '''AaA'''.
+At '''__undefined__'''.
+
+**COPYRIGHT**
+
+ Copyright (c) .COPYRIGHT.
+
diff --git a/tcllib/modules/doctools/tests/wiki/04 b/tcllib/modules/doctools/tests/wiki/04
new file mode 100644
index 0000000..6d2258a
--- /dev/null
+++ b/tcllib/modules/doctools/tests/wiki/04
@@ -0,0 +1,28 @@
+'''TEST 3.14.15.926''' '''.MODULE.'''
+
+
+
+
+**DESCRIPTION**
+
+BEGINNE HIER
+======
+
+ Example Block More Lines
+
+======
+
+
+
+======
+
+Inlined Example \
+Next Line
+
+======
+FERTIG
+
+**COPYRIGHT**
+
+ Copyright (c) .COPYRIGHT.
+
diff --git a/tcllib/modules/doctools/tests/wiki/05 b/tcllib/modules/doctools/tests/wiki/05
new file mode 100644
index 0000000..f4a628c
--- /dev/null
+++ b/tcllib/modules/doctools/tests/wiki/05
@@ -0,0 +1,66 @@
+'''BASIC 5''' '''.MODULE.'''
+
+
+
+
+**SYNOPSIS**
+
+
+ * a-command
+
+
+
+
+**DESCRIPTION**
+
+OK
+
+
++++
+''argument-1'' integer verification
+''argument-2'' string (out) mogrification
++++
+
+
+
+
+ '''command-a''': explanation
+
+ '''command-b''': elucidation
+
+
+ term: definition
+
+ a-command : semantic
+
+
+ 1. A
+
+ 1. B C D
+
+
+ * 1
+
+ * 2 2a 2b
+
+
+ '''option-1''': meaning
+
+ '''option-2''' value: elaboration
+
+
+Command-Line Switch: '''background'''
+Database Name: '''Background'''
+Database Class: '''Color'''
+ * candy
+
+Command-Line Switch: '''foreground'''
+Database Name: '''Foreground'''
+Database Class: '''Color'''
+ * caramel
+KO
+
+**COPYRIGHT**
+
+ Copyright (c) .COPYRIGHT.
+
diff --git a/tcllib/modules/doctools/tests/wiki/06 b/tcllib/modules/doctools/tests/wiki/06
new file mode 100644
index 0000000..7526701
--- /dev/null
+++ b/tcllib/modules/doctools/tests/wiki/06
@@ -0,0 +1,31 @@
+'''TEST 3.14.15.926''' '''.MODULE.'''
+
+
+
+
+**DESCRIPTION**
+
+
+
+ * 1 2 3
+
+ *
+
+ 1. a b c
+
+ 1.
+
+ foo: snafu
+
+ bar: barf
+
+ roo: gork
+
+ 1. a b c
+
+ * 4 5 6
+
+**COPYRIGHT**
+
+ Copyright (c) .COPYRIGHT.
+
diff --git a/tcllib/modules/doctools/tests/wiki/07 b/tcllib/modules/doctools/tests/wiki/07
new file mode 100644
index 0000000..e4541bb
--- /dev/null
+++ b/tcllib/modules/doctools/tests/wiki/07
@@ -0,0 +1,31 @@
+'''TEST 3.14.15.926''' '''.MODULE.'''
+
+
+
+
+**DESCRIPTION**
+
+
+
+ * 1
+
+ * 2
+
+ 1. a
+
+ 1. b
+
+ foo: snafu
+
+ bar: barf
+
+ roo: gork bb
+
+ 1. a 22
+
+ * 3
+
+**COPYRIGHT**
+
+ Copyright (c) .COPYRIGHT.
+
diff --git a/tcllib/modules/doctools/tests/wiki/08 b/tcllib/modules/doctools/tests/wiki/08
new file mode 100644
index 0000000..0f21169
--- /dev/null
+++ b/tcllib/modules/doctools/tests/wiki/08
@@ -0,0 +1,117 @@
+'''ALL 5''' '''.MODULE.''' ''..THE_MODULE..''
+
+..THE_TITLE..
+
+
+**SYNOPSIS**
+
+
+package require '''AAA'''
+
+package require '''BBB VVV'''
+
+package require '''CCC ?VVV?'''
+
+ * CMDNAME ...
+
+ * CMDNAME ...
+
+ * CMDNAME ...
+
+
+
+
+**DESCRIPTION**
+
+
+
+ '''NAME''': DESCRIPTION ::'''Command'''::
+
+ '''NAME''': DESCRIPTION ::::
+
+ '''NAME''': DESCRIPTION ::'''Constant'''::
+
+**API**
+
+
+
+ TERM: DESCRIPTION ::''Emphasis''::
+
+ TERM: DESCRIPTION ::"''File/Path''"::
+
+Command-Line Switch: '''NAME'''
+Database Name: '''DBNAME'''
+Database Class: '''CLASS'''
+ * DESCRIPTION '''NARGLE'''
+
+Command-Line Switch: '''NAME'''
+Database Name: '''DBNAME'''
+Database Class: '''CLASS'''
+ * DESCRIPTION ::'''Function'''::
+
+Command-Line Switch: '''NAME'''
+Database Name: '''DBNAME'''
+Database Class: '''CLASS'''
+ * DESCRIPTION ::'''Method'''::
+
+ TERM: DESCRIPTION
+
+ CMDNAME ...: DESCRIPTION ::'''Namespace'''::
+
++++
+''NAME'' TYPE DESCRIPTION ::''Argument''::
+''NAME'' TYPE DESCRIPTION ::'''Option'''::
+''NAME'' TYPE (MODE) DESCRIPTION ::?Optional?::
+======
+
+ THE ARGUMENT IS USED IN THIS
+ AND/OR THAT MANNER
+
+======
+
++++
+
+
+
+ CMDNAME ...: DESCRIPTION ::'''Package'''::
+
+ CMDNAME ...: DESCRIPTION ::'''SystemCommand'''::
+
+ '''NAME''': DESCRIPTION ::''Term''::
+
+ '''NAME''': DESCRIPTION ::'''Type'''::
+
+ '''NAME''' ARGUMENT: DESCRIPTION ::Uri::
+
+***NARGLE***
+
+
+
+ 1. PARAGRAPH ::Uri%|%UriLabel%|%::
+
+ 1. PARAGRAPH ::'''Variable'''::
+
+ 1. PARAGRAPH ::'''Widget'''::
+
+ * PARAGRAPH ::'''Class'''::
+
+ * PARAGRAPH
+
+ * PARAGRAPH
+
+**SEE ALSO**
+
+
+ELSE, OTHER
+
+
+**KEYWORDS**
+
+
+KEYA, KEYZ
+
+
+**COPYRIGHT**
+
+ Copyright (c) **Copyright**
+
diff --git a/tcllib/modules/doctools/tocexpand b/tcllib/modules/doctools/tocexpand
new file mode 100755
index 0000000..e01fc4b
--- /dev/null
+++ b/tcllib/modules/doctools/tocexpand
@@ -0,0 +1,136 @@
+#! /bin/sh
+# -*- tcl -*- \
+exec tclsh "$0" ${1+"$@"}
+
+rename source __source
+proc source {path} {
+ set f [file join [pwd] $path]
+ uplevel 1 __source $path
+}
+
+
+lappend auto_path [file dirname [file dirname [info script]]]
+package require doctools::toc
+
+# ---------------------------------------------------------------------
+# 1. Handle command line options, input and output
+# 2. Initialize a doctools object.
+# 3. Run the input through the object.
+# 4. Write output.
+# ---------------------------------------------------------------------
+
+proc usage {{exitstate 1}} {
+ global argv0
+ puts "Usage: $argv0\
+ ?-h|--help|-help|-??\
+ ?-help-fmt|--help-fmt?\
+ format in|- ?out|-?"
+ exit $exitstate
+}
+
+# ---------------------------------------------------------------------
+
+proc fmthelp {} {
+ # Tcllib FR #527029: short reference of formatting commands.
+
+ global argv0
+ puts "$argv0 [doctools::toc::help]"
+ exit 0
+}
+
+# ---------------------------------------------------------------------
+# 1. Handle command line options, input and output
+
+proc cmdline {} {
+ global argv0 argv format in out
+
+ set copyright ""
+ set extmodule ""
+ set deprecated 0
+
+ while {[string match -* [set opt [lindex $argv 0]]]} {
+ switch -exact -- $opt {
+ -help - -h - --help - -? {
+ # Tcllib FR #527029
+ usage 0
+ }
+ -help-fmt - --help-fmt {
+ # Tcllib FR #527029
+ fmthelp
+ }
+ default {
+ # Unknown option
+ usage
+ }
+ }
+ }
+
+ if {[llength $argv] < 3} {
+ usage
+ }
+ foreach {format in out} $argv break
+
+ if {$format == {} || $in == {}} {
+ usage
+ }
+ if {$out == {}} {set out -}
+ return $format
+}
+
+# ---------------------------------------------------------------------
+# 3. Read input. Also providing the namespace with file information.
+
+proc get_input {} {
+ global in
+ if {[string equal $in -]} {
+ return [read stdin]
+ } else {
+ set if [open $in r]
+ set text [read $if]
+ close $if
+ return $text
+ }
+}
+
+# ---------------------------------------------------------------------
+# 4. Write output.
+
+proc write_out {text} {
+ global out
+ if {[string equal $out -]} {
+ puts -nonewline stdout $text
+ } else {
+ set of [open $out w]
+ puts -nonewline $of $text
+ close $of
+ }
+}
+
+
+# ---------------------------------------------------------------------
+# Get it all together
+
+proc main {} {
+ global format in
+
+ #if {[catch {}
+ cmdline
+
+ ::doctools::toc::new dt -format $format
+ write_out [dt format [get_input]]
+
+ set warnings [dt warnings]
+ if {[llength $warnings] > 0} {
+ puts stderr [join $warnings \n]
+ }
+
+ #{} msg]} {}
+ #puts stderr "Execution error: $msg"
+ #{}
+ return
+}
+
+
+# ---------------------------------------------------------------------
+main
+exit
diff --git a/tcllib/modules/doctools2base/ChangeLog b/tcllib/modules/doctools2base/ChangeLog
new file mode 100644
index 0000000..3ced5c1
--- /dev/null
+++ b/tcllib/modules/doctools2base/ChangeLog
@@ -0,0 +1,50 @@
+2013-12-17 Andreas Kupries <andreask@activestate.com>
+
+ * tcl_parse.man: Fixed missing requirement of the package itself.
+
+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-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-06-08 Andreas Kupries <andreask@activestate.com>
+
+ * msgcat.man: [Bug 3012669]: Renamed this manpage, conflicted with
+ * tcllib_msgcat.man: the manpage for package msgcat in the core.
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-04-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * paths.tcl: Fixed version mismatch.
+ * nroff_manmacros.tcl: Renamed package (man.macros -> man_macros)
+ * nroff_manmacros.man: to match the set of allowed characters in
+ * tests/common: Tcl Module names. This fixes [Bug 2782256].
+ * pkgIndex.tcl:
+
+2009-04-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * html.tcl: Fix version mismatch.
+ * text.tcl: Fix version mismatch.
+ * tests/common: Fix handling of directories.
+
+2009-03-31 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Doctools version 2, base packages.
diff --git a/tcllib/modules/doctools2base/config.tcl b/tcllib/modules/doctools2base/config.tcl
new file mode 100644
index 0000000..3c4578f
--- /dev/null
+++ b/tcllib/modules/doctools2base/config.tcl
@@ -0,0 +1,81 @@
+# docidx.tcl --
+#
+# Generic configuration management, for use by import and export
+# managers.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: config.tcl,v 1.2 2011/11/17 08:00:45 andreas_kupries Exp $
+
+# Each object manages a set of configuration variables.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.4
+package require snit
+
+# ### ### ### ######### ######### #########
+## API
+
+snit::type ::doctools::config {
+
+ # ### ### ### ######### ######### #########
+ ## Options :: None
+
+ # ### ### ### ######### ######### #########
+ ## Creating, destruction
+
+ # Default constructor.
+ # Default destructor.
+
+ # ### ### ### ######### ######### #########
+ ## Public methods. Reading and writing the configuration.
+
+ method names {} {
+ return [array names myconfiguration]
+ }
+
+ method get {} {
+ return [array get myconfiguration]
+ }
+
+ method set {name {value {}}} {
+ # 7 instead of 3 in the condition below, because of the 4
+ # implicit arguments snit is providing to each method.
+ if {[llength [info level 0]] == 7} {
+ set myconfiguration($name) $value
+ } elseif {![info exists myconfiguration($name)]} {
+ return -code error "can't read \"$name\": no such variable"
+ }
+ return $myconfiguration($name)
+ }
+
+ method unset {args} {
+ if {![llength $args]} { lappend args * }
+ foreach pattern $args {
+ array unset myconfiguration $pattern
+ }
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal methods :: None.
+
+ # ### ### ### ######### ######### #########
+ ## State :: Configuration data, Tcl array
+
+ variable myconfiguration -array {}
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::config 0.1
+return
diff --git a/tcllib/modules/doctools2base/html.tcl b/tcllib/modules/doctools2base/html.tcl
new file mode 100644
index 0000000..acb7188
--- /dev/null
+++ b/tcllib/modules/doctools2base/html.tcl
@@ -0,0 +1,209 @@
+# -*- tcl -*-
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Support package. Basic html generation commands.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.4 ; # Required Core
+package require doctools::text ; # Basic generator state management.
+
+namespace eval ::doctools::html {}
+doctools::text::import ::doctools::html
+
+# # ## ### ##### ######## ############# #####################
+
+proc ::doctools::html::begin {} {
+ text::begin
+ Begin
+ return
+}
+
+proc ::doctools::html::save {} {
+ variable state
+ set current [array get state]
+ text::save
+ Begin
+ set state(stack) $current
+ return
+}
+
+proc ::doctools::html::restore {} {
+ variable state
+ set html [text::restore]
+ array set state $state(stack)
+ return $html
+}
+
+proc ::doctools::html::collect {script} {
+ save
+ uplevel 1 $script
+ return [restore]
+}
+
+# # ## ### ##### ######## ############# #####################
+
+proc ::doctools::html::tag1 {name args} {
+ text::+ <$name
+ if {[llength $args]} {
+ foreach {a v} $args { text::+ " $a=\"$v\"" }
+ }
+ text::+ >
+ return
+}
+
+proc ::doctools::html::tag {name args} {
+ tagD $name $args
+ return
+}
+
+proc ::doctools::html::tagD {name dict} {
+ variable state
+ lappend state(tstack) $name
+ text::+ <$name
+ if {[llength $dict]} {
+ foreach {a v} $dict { text::+ " $a=\"$v\"" }
+ }
+ text::+ >
+ return
+}
+
+proc ::doctools::html::/tag {} {
+ variable state
+ set tag [lindex $state(tstack) end]
+ set state(tstack) [lreplace $state(tstack) end end]
+ text::+ </$tag>
+ return
+}
+
+proc ::doctools::html::tag/ {name args} {
+ variable state
+ lappend state(tstack) $tag
+ text::+ <$tag
+ if {[llength $args]} {
+ foreach {a v} $args { text::+ " $a=\"$v\"" }
+ text::+ { }
+ }
+ text::+ />
+ return
+}
+
+proc ::doctools::html::tag* {name args} {
+ set script [lindex $args end]
+ set args [lreplace $args end end]
+ tagD $name $args
+ uplevel 1 $script
+ /tag
+ return
+}
+
+proc ::doctools::html::tag= {name args} {
+ set text [lindex $args end]
+ set args [lreplace $args end end]
+ eval [linsert $args 0 tag $name]
+ + $text
+ /tag
+ return
+}
+
+# # ## ### ##### ######## ############# #####################
+
+proc ::doctools::html::+ {text} {
+ text::+ [Quote $text]
+ return
+}
+
+proc ::doctools::html::comment {comment} {
+ text::+ "<!-- ${comment} -->"
+ return
+}
+
+proc ::doctools::html::++ {html} {
+ text::+ $html
+ return
+}
+
+# # ## ### ##### ######## ############# #####################
+
+proc ::doctools::html::import {{namespace {}}} {
+ uplevel 1 [list namespace eval ${namespace}::html {
+ namespace import ::doctools::html::*
+ }]
+ return
+}
+
+proc ::doctools::html::importhere {{namespace ::}} {
+ uplevel 1 [list namespace eval ${namespace} {
+ namespace import ::doctools::html::*
+ }]
+ return
+}
+
+# # ## ### ##### ######## ############# #####################
+
+proc ::doctools::html::Begin {} {
+ variable state
+ array unset state *
+ array set state {
+ tags {}
+ stack {}
+ }
+ return
+}
+
+proc ::doctools::html::Quote {text} {
+ variable textMap
+ return [string map $textMap $text]
+}
+
+# # ## ### ##### ######## ############# #####################
+
+namespace eval ::doctools::html {
+ variable state
+ array set state {}
+
+ # Replaces HTML markup characters in $text with the appropriate
+ # entity references.
+
+ variable textMap {
+ & &amp; < &lt; > &gt;
+ \xa0 &nbsp; \xb0 &deg; \xc0 &Agrave; \xd0 &ETH; \xe0 &agrave; \xf0 &eth;
+ \xa1 &iexcl; \xb1 &plusmn; \xc1 &Aacute; \xd1 &Ntilde; \xe1 &aacute; \xf1 &ntilde;
+ \xa2 &cent; \xb2 &sup2; \xc2 &Acirc; \xd2 &Ograve; \xe2 &acirc; \xf2 &ograve;
+ \xa3 &pound; \xb3 &sup3; \xc3 &Atilde; \xd3 &Oacute; \xe3 &atilde; \xf3 &oacute;
+ \xa4 &curren; \xb4 &acute; \xc4 &Auml; \xd4 &Ocirc; \xe4 &auml; \xf4 &ocirc;
+ \xa5 &yen; \xb5 &micro; \xc5 &Aring; \xd5 &Otilde; \xe5 &aring; \xf5 &otilde;
+ \xa6 &brvbar; \xb6 &para; \xc6 &AElig; \xd6 &Ouml; \xe6 &aelig; \xf6 &ouml;
+ \xa7 &sect; \xb7 &middot; \xc7 &Ccedil; \xd7 &times; \xe7 &ccedil; \xf7 &divide;
+ \xa8 &uml; \xb8 &cedil; \xc8 &Egrave; \xd8 &Oslash; \xe8 &egrave; \xf8 &oslash;
+ \xa9 &copy; \xb9 &sup1; \xc9 &Eacute; \xd9 &Ugrave; \xe9 &eacute; \xf9 &ugrave;
+ \xaa &ordf; \xba &ordm; \xca &Ecirc; \xda &Uacute; \xea &ecirc; \xfa &uacute;
+ \xab &laquo; \xbb &raquo; \xcb &Euml; \xdb &Ucirc; \xeb &euml; \xfb &ucirc;
+ \xac &not; \xbc &frac14; \xcc &Igrave; \xdc &Uuml; \xec &igrave; \xfc &uuml;
+ \xad &shy; \xbd &frac12; \xcd &Iacute; \xdd &Yacute; \xed &iacute; \xfd &yacute;
+ \xae &reg; \xbe &frac34; \xce &Icirc; \xde &THORN; \xee &icirc; \xfe &thorn;
+ \xaf &hibar; \xbf &iquest; \xcf &Iuml; \xdf &szlig; \xef &iuml; \xff &yuml;
+ {"} &quot;
+} ; # " make the emacs highlighting code happy.
+
+ # Text commands which are html commands, unchanged
+ namespace import \
+ ::doctools::text::done \
+ ::doctools::text::+++ \
+ ::doctools::text::newline \
+ ::doctools::text::prefix \
+ ::doctools::text::indent \
+ ::doctools::text::dedent \
+ ::doctools::text::indented \
+ ::doctools::text::indenting \
+ ::doctools::text::newlines
+
+ namespace export begin done save restore collect + +++ \
+ prefix indent dedent indented indenting newline newlines \
+ tag /tag tag/ tag* tag1 tag= comment ++
+}
+
+# # ## ### ##### ######## ############# #####################
+package provide doctools::html 0.1
+return
diff --git a/tcllib/modules/doctools2base/html_cssdefaults.man b/tcllib/modules/doctools2base/html_cssdefaults.man
new file mode 100644
index 0000000..30b638b
--- /dev/null
+++ b/tcllib/modules/doctools2base/html_cssdefaults.man
@@ -0,0 +1,40 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::html::cssdefaults n 0.1]
+[keywords CSS]
+[keywords doctools]
+[keywords export]
+[keywords HTML]
+[keywords plugin]
+[keywords style]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Default CSS style for HTML export plugins}]
+[category {Documentation tools}]
+[require Tcl 8.4]
+[require doctools::html::cssdefaults [opt 0.1]]
+[description]
+
+This package provides a single command providing access to the text of
+the default CSS style to use for HTML markup generated by the various
+HTML export plugins.
+
+[para]
+
+This is an internal package of doctools, for use by [term export] plugins,
+i.e. the packages converting doctools related documented into other
+formats, most notably [term HTML].
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::html::cssdefaults::contents]]
+
+This command returns the text of the default CSS style to use for HTML
+markup generated by the various HTML export plugins.
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2base/html_cssdefaults.tcl b/tcllib/modules/doctools2base/html_cssdefaults.tcl
new file mode 100644
index 0000000..7feab31
--- /dev/null
+++ b/tcllib/modules/doctools2base/html_cssdefaults.tcl
@@ -0,0 +1,158 @@
+# -*- tcl -*-
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Support package. Container for the default CSS style used by the
+# html export plugins when the user does not specify its own style.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.4 ; # Required Core
+
+namespace eval ::doctools::html::cssdefaults {
+ # Contents of the file we carry
+ variable c {}
+}
+
+proc ::doctools::html::cssdefaults::contents {} {
+ variable c
+ return $c
+}
+
+set ::doctools::html::cssdefaults::c {
+HTML {
+ background: #FFFFFF;
+ color: black;
+}
+BODY {
+ background: #FFFFFF;
+ color: black;
+}
+DIV.doctools {
+ margin-left: 10%;
+ margin-right: 10%;
+}
+DIV.doctools H1,DIV.doctools H2 {
+ margin-left: -5%;
+}
+H1, H2, H3, H4 {
+ margin-top: 1em;
+ font-family: sans-serif;
+ font-size: large;
+ color: #005A9C;
+ background: transparent;
+ text-align: left;
+}
+H1.title, H1.idx-title {
+ text-align: center;
+}
+UL,OL {
+ margin-right: 0em;
+ margin-top: 3pt;
+ margin-bottom: 3pt;
+}
+UL LI {
+ list-style: disc;
+}
+OL LI {
+ list-style: decimal;
+}
+DT {
+ padding-top: 1ex;
+}
+UL.toc,UL.toc UL, UL.toc UL UL {
+ font: normal 12pt/14pt sans-serif;
+ list-style: none;
+}
+LI.section, LI.subsection {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+}
+PRE {
+ display: block;
+ font-family: monospace;
+ white-space: pre;
+ margin: 0%;
+ padding-top: 0.5ex;
+ padding-bottom: 0.5ex;
+ padding-left: 1ex;
+ padding-right: 1ex;
+ width: 100%;
+}
+PRE.example {
+ color: black;
+ background: #f5dcb3;
+ border: 1px solid black;
+}
+UL.requirements LI, UL.syntax LI {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+}
+DIV.synopsis {
+ color: black;
+ background: #80ffff;
+ border: 1px solid black;
+ font-family: serif;
+ margin-top: 1em;
+ margin-bottom: 1em;
+}
+UL.syntax {
+ margin-top: 1em;
+ border-top: 1px solid black;
+}
+UL.requirements {
+ margin-bottom: 1em;
+ border-bottom: 1px solid black;
+}
+
+DIV.idx-kwnav {
+ width: 100%;
+ margin-top: 5pt;
+ margin-bottom: 5pt;
+ margin-left: 0%;
+ margin-right: 0%;
+ padding-top: 5pt;
+ padding-bottom: 5pt;
+ background: #DDDDDD;
+ color: black;
+ border: 1px solid black;
+ text-align: center;
+ font-size: small;
+ font-family: sans-serif;
+}
+
+/* TR.even/odd are used to get alternately colored table rows.
+ * Could probably choose better colors here...
+ */
+
+TR.idx-even {
+ color: black;
+ background: #efffef;
+}
+
+TR.idx-odd {
+ color: black;
+ background: #efefff;
+}
+
+DIV.idx-header, DIV.idx-footer, DIV.idx-leader {
+ width: 100%;
+ margin-left: 0%;
+ margin-right: 0%;
+}
+
+TH {
+ color: #005A9C;
+ background: #DDDDDD;
+ text-align: center;
+ font-family: sans-serif;
+ font-weight: bold;
+}
+}
+
+package provide doctools::html::cssdefaults 0.1
+return
diff --git a/tcllib/modules/doctools2base/include/feedback.inc b/tcllib/modules/doctools2base/include/feedback.inc
new file mode 100644
index 0000000..e171846
--- /dev/null
+++ b/tcllib/modules/doctools2base/include/feedback.inc
@@ -0,0 +1,12 @@
+[section {Bugs, Ideas, Feedback}]
+[vset TRACKER http://core.tcl.tk/tcllib/reportlist]
+[vset LABEL {Tcllib Trackers}]
+
+This document, and the package it describes, will undoubtedly contain
+bugs and other problems.
+
+Please report such in the category [emph [vset CATEGORY]] of the
+[uri [vset TRACKER] [vset LABEL]].
+
+Please also report any ideas for enhancements you may have for either
+package and/or documentation.
diff --git a/tcllib/modules/doctools2base/msgcat.tcl b/tcllib/modules/doctools2base/msgcat.tcl
new file mode 100644
index 0000000..9e913e4
--- /dev/null
+++ b/tcllib/modules/doctools2base/msgcat.tcl
@@ -0,0 +1,59 @@
+# -*- tcl -*-
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# L10N, I18N
+
+# Support package. Handling of message catalogs within the various
+# doctools document processing packages. Contrary to the regular
+# msgcat package here message catalogs are equated with packages. This
+# makes their use easier, as the user does not have to know the
+# location of the message catalogs. Locating a desired catalog is
+# handled through Tcl's regular package management.
+
+# To this end this package provides a command analogous to
+# 'msgcat::load', just replacing direct file access with package
+# loading. This is 'doctools::msgcat::init'.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.4 ; # Required Core
+package require msgcat ; # Fondation catalog database
+
+namespace eval ::doctools::msgcat {}
+
+# # ## ### ##### ######## ############# #####################
+## Overide catalog unknown handler to report missing strings
+## as fatal problem. DEBUG only.
+
+if 0 {
+ proc ::msgcat::mcunknown {locale code} {
+ return "unknown error code \"$code\" (for locale $locale)"
+ }
+}
+
+# # ## ### ##### ######## ############# #####################
+## Public API
+
+proc ::doctools::msgcat::init {prefix} {
+ set matches 0
+ foreach p [msgcat::mcpreferences] {
+ set pkg doctools::msgcat::${prefix}::${p}
+ if {![catch {
+ package require $pkg
+ }]} {
+ incr matches
+ }
+ }
+ return $matches
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+namespace eval ::doctools::msgcat {
+ namespace export init
+}
+
+package provide doctools::msgcat 0.1
+return
diff --git a/tcllib/modules/doctools2base/msgcat.test b/tcllib/modules/doctools2base/msgcat.test
new file mode 100644
index 0000000..71339e9
--- /dev/null
+++ b/tcllib/modules/doctools2base/msgcat.test
@@ -0,0 +1,51 @@
+# -*- tcl -*-
+# doctools::msgcat.test: tests for the doctools::msgcat package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: msgcat.test,v 1.1 2009/04/01 04:27:47 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2
+
+support {
+ # NOTE: Better use a base local file and test package ?
+ use doctools2idx/msgcat_c.tcl doctools::msgcat::idx::c ; # See 'doctools-msgcat-2.0'.
+}
+testing {
+ useLocal msgcat.tcl doctools::msgcat
+}
+
+# -------------------------------------------------------------------------
+
+array_unset env LANG*
+array_unset env LC_*
+set env(LANG) C ; # Usually default if nothing is set, OS X requires this.
+
+# -------------------------------------------------------------------------
+
+# search paths .............................................................
+
+test doctools-msgcat-1.0 {init, wrong#args, not enough} -body {
+ doctools::msgcat::init
+} -returnCodes error -result {wrong # args: should be "doctools::msgcat::init prefix"}
+
+test doctools-msgcat-1.1 {init, wrong#args, too many} -body {
+ doctools::msgcat::init fu bar
+} -returnCodes error -result {wrong # args: should be "doctools::msgcat::init prefix"}
+
+test doctools-msgcat-2.0 {init, ok args} -body {
+ doctools::msgcat::init idx
+} -result 1
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2base/nroff_manmacros.man b/tcllib/modules/doctools2base/nroff_manmacros.man
new file mode 100644
index 0000000..447e31a
--- /dev/null
+++ b/tcllib/modules/doctools2base/nroff_manmacros.man
@@ -0,0 +1,40 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::nroff::man_macros n 0.1]
+[keywords doctools]
+[keywords export]
+[keywords macros]
+[keywords man_macros]
+[keywords nroff]
+[keywords plugin]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Default CSS style for NROFF export plugins}]
+[category {Documentation tools}]
+[require Tcl 8.4]
+[require doctools::nroff::man_macros [opt 0.1]]
+[description]
+
+This package provides a single command providing access to the
+definition of the nroff [emph man] macro set to use for NROFF markup
+generated by the various NROFF export plugins.
+
+[para]
+
+This is an internal package of doctools, for use by [term export] plugins,
+i.e. the packages converting doctools related documented into other
+formats, most notably [term nroff].
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::nroff::man_macros::contents]]
+
+This command returns the text of the default CSS style to use for NROFF
+generated by the various NROFF export plugins.
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2base/nroff_manmacros.tcl b/tcllib/modules/doctools2base/nroff_manmacros.tcl
new file mode 100644
index 0000000..83522bf
--- /dev/null
+++ b/tcllib/modules/doctools2base/nroff_manmacros.tcl
@@ -0,0 +1,261 @@
+# -*- tcl -*-
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Support package. Container for the man.macros needed by the nroff
+# export plugins when instructed to inline the commands the
+# documentation is using.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.4 ; # Required Core
+
+namespace eval ::doctools::nroff::man_macros {
+ # Contents of the file we carry
+ variable c {}
+}
+
+proc ::doctools::nroff::man_macros::contents {} {
+ variable c
+ return $c
+}
+
+set ::doctools::nroff::man_macros::c {'\" The definitions below are for supplemental macros used in Tcl/Tk
+'\" manual entries.
+'\"
+'\" .AP type name in/out ?indent?
+'\" Start paragraph describing an argument to a library procedure.
+'\" type is type of argument (int, etc.), in/out is either "in", "out",
+'\" or "in/out" to describe whether procedure reads or modifies arg,
+'\" and indent is equivalent to second arg of .IP (shouldn't ever be
+'\" needed; use .AS below instead)
+'\"
+'\" .AS ?type? ?name?
+'\" Give maximum sizes of arguments for setting tab stops. Type and
+'\" name are examples of largest possible arguments that will be passed
+'\" to .AP later. If args are omitted, default tab stops are used.
+'\"
+'\" .BS
+'\" Start box enclosure. From here until next .BE, everything will be
+'\" enclosed in one large box.
+'\"
+'\" .BE
+'\" End of box enclosure.
+'\"
+'\" .CS
+'\" Begin code excerpt.
+'\"
+'\" .CE
+'\" End code excerpt.
+'\"
+'\" .VS ?version? ?br?
+'\" Begin vertical sidebar, for use in marking newly-changed parts
+'\" of man pages. The first argument is ignored and used for recording
+'\" the version when the .VS was added, so that the sidebars can be
+'\" found and removed when they reach a certain age. If another argument
+'\" is present, then a line break is forced before starting the sidebar.
+'\"
+'\" .VE
+'\" End of vertical sidebar.
+'\"
+'\" .DS
+'\" Begin an indented unfilled display.
+'\"
+'\" .DE
+'\" End of indented unfilled display.
+'\"
+'\" .SO
+'\" Start of list of standard options for a Tk widget. The
+'\" options follow on successive lines, in four columns separated
+'\" by tabs.
+'\"
+'\" .SE
+'\" End of list of standard options for a Tk widget.
+'\"
+'\" .OP cmdName dbName dbClass
+'\" Start of description of a specific option. cmdName gives the
+'\" option's name as specified in the class command, dbName gives
+'\" the option's name in the option database, and dbClass gives
+'\" the option's class in the option database.
+'\"
+'\" .UL arg1 arg2
+'\" Print arg1 underlined, then print arg2 normally.
+'\"
+'\" RCS: @(#) $Id: nroff_manmacros.tcl,v 1.2 2009/04/29 02:09:46 andreas_kupries Exp $
+'\"
+'\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
+.if t .wh -1.3i ^B
+.nr ^l \n(.l
+.ad b
+'\" # Start an argument description
+.de AP
+.ie !"\\$4"" .TP \\$4
+.el \{\
+. ie !"\\$2"" .TP \\n()Cu
+. el .TP 15
+.\}
+.ta \\n()Au \\n()Bu
+.ie !"\\$3"" \{\
+\&\\$1 \\fI\\$2\\fP (\\$3)
+.\".b
+.\}
+.el \{\
+.br
+.ie !"\\$2"" \{\
+\&\\$1 \\fI\\$2\\fP
+.\}
+.el \{\
+\&\\fI\\$1\\fP
+.\}
+.\}
+..
+'\" # define tabbing values for .AP
+.de AS
+.nr )A 10n
+.if !"\\$1"" .nr )A \\w'\\$1'u+3n
+.nr )B \\n()Au+15n
+.\"
+.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
+.nr )C \\n()Bu+\\w'(in/out)'u+2n
+..
+.AS Tcl_Interp Tcl_CreateInterp in/out
+'\" # BS - start boxed text
+'\" # ^y = starting y location
+'\" # ^b = 1
+.de BS
+.br
+.mk ^y
+.nr ^b 1u
+.if n .nf
+.if n .ti 0
+.if n \l'\\n(.lu\(ul'
+.if n .fi
+..
+'\" # BE - end boxed text (draw box now)
+.de BE
+.nf
+.ti 0
+.mk ^t
+.ie n \l'\\n(^lu\(ul'
+.el \{\
+.\" Draw four-sided box normally, but don't draw top of
+.\" box if the box started on an earlier page.
+.ie !\\n(^b-1 \{\
+\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
+.\}
+.el \}\
+\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
+.\}
+.\}
+.fi
+.br
+.nr ^b 0
+..
+'\" # VS - start vertical sidebar
+'\" # ^Y = starting y location
+'\" # ^v = 1 (for troff; for nroff this doesn't matter)
+.de VS
+.if !"\\$2"" .br
+.mk ^Y
+.ie n 'mc \s12\(br\s0
+.el .nr ^v 1u
+..
+'\" # VE - end of vertical sidebar
+.de VE
+.ie n 'mc
+.el \{\
+.ev 2
+.nf
+.ti 0
+.mk ^t
+\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
+.sp -1
+.fi
+.ev
+.\}
+.nr ^v 0
+..
+'\" # Special macro to handle page bottom: finish off current
+'\" # box/sidebar if in box/sidebar mode, then invoked standard
+'\" # page bottom macro.
+.de ^B
+.ev 2
+'ti 0
+'nf
+.mk ^t
+.if \\n(^b \{\
+.\" Draw three-sided box if this is the box's first page,
+.\" draw two sides but no top otherwise.
+.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
+.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
+.\}
+.if \\n(^v \{\
+.nr ^x \\n(^tu+1v-\\n(^Yu
+\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
+.\}
+.bp
+'fi
+.ev
+.if \\n(^b \{\
+.mk ^y
+.nr ^b 2
+.\}
+.if \\n(^v \{\
+.mk ^Y
+.\}
+..
+'\" # DS - begin display
+.de DS
+.RS
+.nf
+.sp
+..
+'\" # DE - end display
+.de DE
+.fi
+.RE
+.sp
+..
+'\" # SO - start of list of standard options
+.de SO
+.SH "STANDARD OPTIONS"
+.LP
+.nf
+.ta 4c 8c 12c
+.ft B
+..
+'\" # SE - end of list of standard options
+.de SE
+.fi
+.ft R
+.LP
+See the \\fBoptions\\fR manual entry for details on the standard options.
+..
+'\" # OP - start of full description for a single option
+.de OP
+.LP
+.nf
+.ta 4c
+Command-Line Name: \\fB\\$1\\fR
+Database Name: \\fB\\$2\\fR
+Database Class: \\fB\\$3\\fR
+.fi
+.IP
+..
+'\" # CS - begin code excerpt
+.de CS
+.RS
+.nf
+.ta .25i .5i .75i 1i
+..
+'\" # CE - end code excerpt
+.de CE
+.fi
+.RE
+..
+.de UL
+\\$1\l'|0\(ul'\\$2
+..}
+
+package provide doctools::nroff::man_macros 0.1
+return
diff --git a/tcllib/modules/doctools2base/paths.tcl b/tcllib/modules/doctools2base/paths.tcl
new file mode 100644
index 0000000..2a84c45
--- /dev/null
+++ b/tcllib/modules/doctools2base/paths.tcl
@@ -0,0 +1,76 @@
+# docidx.tcl --
+#
+# Generic path list management, for use by import management.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: paths.tcl,v 1.2 2009/04/29 02:09:46 andreas_kupries Exp $
+
+# Each object manages a list of paths.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.4
+package require snit
+
+# ### ### ### ######### ######### #########
+## API
+
+snit::type ::doctools::paths {
+
+ # ### ### ### ######### ######### #########
+ ## Options :: None
+
+ # ### ### ### ######### ######### #########
+ ## Creation, destruction
+
+ # Default constructor.
+ # Default destructor.
+
+ # ### ### ### ######### ######### #########
+ ## Methods :: Querying and manipulating the list of paths.
+
+ method paths {} {
+ return $mypaths
+ }
+
+ method add {path} {
+ set pos [lsearch $mypaths $path]
+ if {$pos >= 0 } return
+ lappend mypaths $path
+ return
+ }
+
+ method remove {path} {
+ set pos [lsearch $mypaths $path]
+ if {$pos < 0} return
+ set mypaths [lreplace $mypaths $pos $pos]
+ return
+ }
+
+ method clear {} {
+ set mypaths {}
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal methods :: None
+
+ # ### ### ### ######### ######### #########
+ ## State :: List of paths.
+
+ variable mypaths {}
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::paths 0.1
+return
diff --git a/tcllib/modules/doctools2base/pkgIndex.tcl b/tcllib/modules/doctools2base/pkgIndex.tcl
new file mode 100644
index 0000000..0a9499e
--- /dev/null
+++ b/tcllib/modules/doctools2base/pkgIndex.tcl
@@ -0,0 +1,20 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+
+# Packages for the doctools {idx,toc,doc} v2 implementation
+# (still v1.1 doc{idx,toc} languages).
+
+# Supporting packages
+# - Handling configuration variables, and include paths.
+# - Handling text generation, the nroff man.macros definitions,
+# HTML/XML generation, and the default CSS style
+# - Handling of message catalogs as packages.
+# - Recursive descent parser for Tcl strings (as expected by 'subst -novariables').
+
+package ifneeded doctools::config 0.1 [list source [file join $dir config.tcl]]
+package ifneeded doctools::paths 0.1 [list source [file join $dir paths.tcl]]
+package ifneeded doctools::text 0.1 [list source [file join $dir text.tcl]]
+package ifneeded doctools::nroff::man_macros 0.1 [list source [file join $dir nroff_manmacros.tcl]]
+package ifneeded doctools::html 0.1 [list source [file join $dir html.tcl]]
+package ifneeded doctools::html::cssdefaults 0.1 [list source [file join $dir html_cssdefaults.tcl]]
+package ifneeded doctools::msgcat 0.1 [list source [file join $dir msgcat.tcl]]
+package ifneeded doctools::tcl::parse 0.1 [list source [file join $dir tcl_parse.tcl]]
diff --git a/tcllib/modules/doctools2base/tcl_parse.man b/tcllib/modules/doctools2base/tcl_parse.man
new file mode 100644
index 0000000..bec4a1e
--- /dev/null
+++ b/tcllib/modules/doctools2base/tcl_parse.man
@@ -0,0 +1,184 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::tcl::parse n 1]
+[keywords command]
+[keywords doctools]
+[keywords parser]
+[keywords subst]
+[keywords {Tcl syntax}]
+[keywords word]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Processing text in 'subst -novariables' format}]
+[category {Documentation tools}]
+[require Tcl 8.4]
+[require snit]
+[require fileutil]
+[require logger]
+[require struct::list]
+[require struct::stack]
+[require struct::set]
+[require treeql]
+[require doctools::tcl::parse]
+[description]
+
+This package provides commands for parsing text with embedded Tcl
+commands as accepted by the Tcl builtin command
+[cmd {subst -novariables}]. The result of the parsing is an abstract
+syntax tree.
+
+[para]
+
+This is an internal package of doctools, for use by the higher level
+parsers processing the [term docidx], [term doctoc], and [term doctools]
+markup languages.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::tcl::parse] [method text] \
+ [arg tree] [arg text] [opt [arg root]]]
+
+The command takes the [arg text] and parses it under the assumption
+that it contains a string acceptable to the Tcl builtin command
+
+[cmd {subst -novariables}]. Errors are thrown otherwise during the
+parsing. The format used for these errors in described in section
+[sectref {Error format}].
+
+[para]
+
+The command returns the empty string as it result. The actual result
+of the parsing is entered into the tree structure [arg tree], under
+the node [arg root].
+
+If [arg root] is not specified the root of [arg tree] is used. The
+[arg tree] has to exist and be the command of a tree object which
+supports the same methods as trees created by the package
+
+[package struct::tree].
+
+[para]
+
+In case of errors [arg tree] will be left in an undefined state.
+
+[call [cmd ::doctools::tcl::parse] [method file] \
+ [arg tree] [arg path] [opt [arg root]]]
+
+The same as [method text], except that the text to parse is read from
+the file specified by [arg path].
+
+[list_end]
+
+[section {Error format}]
+
+When the parser encounters a problem in the input
+it will throw an error using the format described
+here.
+
+[list_begin enumerated]
+
+[enum]
+The message will contain the reason for the problem (unexpected
+character or end of input in input), the character in question, if
+any, and the line and column the problem was found at, in a human
+readable form. This part is not documented further as its format may
+change as we see fit. It is intended for human consumption, not
+machine.
+
+[enum]
+The error code however will contain a machine-readable representation
+of the problem, in the form of a 5-element list containing, in the
+order listed below
+
+[list_begin enumerated]
+[enum] the constant string [const doctools::tcl::parse]
+
+[enum] the cause of the problem, one of
+
+[list_begin definitions]
+[def [const char]] Unexpected character in input
+[def [const eof]] Unexpected end of the input
+[list_end]
+
+[enum]
+The location of the problem as offset from the beginning of the input,
+counted in characters. Note: Line markers count as one character.
+
+[enum] The line the problem was found on (counted from 1 (one)),
+
+[enum] The column the problem was found at (counted from 0 (zero))
+
+[list_end]
+[list_end]
+
+[section {Tree Structure}]
+
+After successfully parsing a string the generated tree will have the
+following structure:
+
+[list_begin enumerated]
+
+[enum]
+In the following items the word 'root' refers to the node which was
+specified as the root of the tree when invoking either [method text]
+or [method file]. This may be the actual root of the tree.
+
+[enum]
+All the following items further ignore the possibility of pre-existing
+attributes in the pre-existing nodes. If attributes exists with the
+same names as the attributes used by the parser the pre-existing
+values are written over. Attributes with names not clashing with the
+parser's attributes are not touched.
+
+[enum]
+The root node has no attributes.
+
+[enum]
+All other nodes have the attributes
+[list_begin definitions]
+[def type]
+The value is a string from the set { Command , Text , Word }
+[def range]
+The value is either empty or a 2-element list containing integer
+numbers. The numbers are the offsets of the first and last character
+in the input text, of the token described by the node,.
+[def line]
+The value is an integer, it describes the line in the input the token
+described by the node ends on. Lines are counted from 1 ([const one]).
+[def col]
+The value is an integer, it describes the column in the line in the
+input the token described by the node ends on. Columns are counted
+from 0 ([const zero]).
+[list_end]
+
+[enum]
+The children of the root, if any, are of type Command and Text, in
+semi-alternation. This means: After a Text node a Command node has to
+follow, and anything can follow a Command node, a Text or other
+Command node.
+
+[enum]
+The children of a Command node, if any, are of type Command, and Text,
+and Word, they describe the arguments of the command.
+
+[enum]
+The children of a Word node, if any, are of type Command, Text, in
+semi-alternation. This means: After a Text node a Command node has to
+follow, and anything can follow a Command node, a Text or other
+Command node.
+
+[enum]
+A Word node without children represents the empty string.
+
+[enum]
+All Text nodes are leaves of the tree.
+
+[enum]
+All leaves of the tree are either Text or Command nodes.
+Word nodes cannot be leaves.
+[list_end]
+
+[vset CATEGORY doctools]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2base/tcl_parse.tcl b/tcllib/modules/doctools2base/tcl_parse.tcl
new file mode 100644
index 0000000..59cfd00
--- /dev/null
+++ b/tcllib/modules/doctools2base/tcl_parse.tcl
@@ -0,0 +1,800 @@
+# -*- tcl -*-
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Recursive descent parser for Tcl commands embedded in a string. (=>
+# subst -novariables, without actual evaluation of the embedded
+# commands). Useful for processing templates, etc. The result is an
+# abstract syntax tree of strings and commands, which in turn have
+# strings and commands as arguments.
+
+# The tree can be processed further. The nodes of the tree are
+# annotated with line/column/offset information to allow later stages
+# the reporting of higher-level syntax and semantic errors with exact
+# locations in the input.
+
+# TODO :: Add ability to report progress through the
+# TODO :: input. Callback. Invoked in 'Initialize', 'Step', and
+# TODO :: 'Finalize'.
+
+# TODO :: Investigate possibility of using tclparser package
+# TODO :: ('parser') to handle the command pieces embedded in the
+# TODO :: text.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.4 ; # Required runtime.
+package require snit ; # OO system.
+package require fileutil ; # File utilities.
+package require logger ; # User feedback.
+package require struct::list ; # Higher-order list operations.
+package require struct::stack ; # Stacks
+package require struct::set ; # Finite sets
+package require treeql ; # Tree queries and transformation.
+
+# # ## ### ##### ######## ############# #####################
+##
+
+logger::initNamespace ::doctools::tcl::parse
+snit::type ::doctools::tcl::parse {
+ # # ## ### ##### ######## #############
+ ## Public API
+
+ typemethod file {t path {root {}}} {
+ $type text $t [fileutil::cat -translation binary -encoding binary $path] $root
+ }
+
+ typemethod text {t text {root {}}} {
+ # --- --- --- --------- --------- ---------
+ # Phase 1. Lexical processing.
+ # The resulting tree contains the raw tokens. See
+ # below for the specification of the resulting tree
+ # structure.
+ #
+ # This part is a recursive descent parser using Tcl's 12 rules
+ # for processing the input. Note: Variable references are not
+ # recognized, they are processed like regular text.
+
+ Initialize $t $text $root
+ String
+ Finalize
+
+ # Tree structure
+ # - All nodes but the root have the attributes 'type', 'range', 'line', and 'col'.
+ #
+ # * 'type' in { Command, Text, Backslash, Word, Quote, Continuation, QBrace }
+ # * 'range' is 2-element list (offset start, offset end)
+ # * 'line' is integer number > 0
+ # * 'col' is integer number >= 0
+ #
+ # 'type' specifies what sort of token the node contains.
+ #
+ # 'range' is the location of the token as offsets in
+ # characters from the beginning of the string, for
+ # first and last character in the token. EOL markers
+ # count as one character. This can be empty.
+ #
+ # 'line', 'col' are the location of the first character
+ # AFTER the token, as the line and column the character is
+ # on and at.
+ #
+ # Meaning of the various node types
+ #
+ # Command .... : A command begins here, the text in the range
+ # .............. is the opening bracket.
+ # Text ....... : A text segment in a word, anything up to the
+ # .............. beginning of a backslash sequence or of an
+ # .............. embedded command.
+ # Backslash .. : A backslash sequence. The text under the
+ # .............. range is the whole sequence.
+ # Word ....... : The beginning of an unquoted, quoted or
+ # .............. braced word. The text under the range is the
+ # .............. opening quote or brace, if any. The range is
+ # .............. empty for an unquoted word.
+ # Quote ...... : An embedded double-quote character which is
+ # .............. not the end of a quoted string (a special
+ # .............. type of backslash sequence). The range is the
+ # .............. whole sequence.
+ # Continuation : A continuation line in an unquoted, quoted,
+ # .............. or braced string. The range covers the whole
+ # .............. sequence, including the whitespace trailing
+ # .............. it.
+ # QBrace ..... : A quoted brace in a braced string. A special
+ # .............. kind of backslash sequence. The range covers
+ # .............. the whole sequence.
+
+ # --- --- --- --------- --------- ---------
+ # Phase 2. Convert the token tree into a syntax tree.
+ # This phase simplifies the tree by converting and
+ # eliminating special tokens, and further decouples
+ # it from the input by storing the relevant string
+ # ranges of the input in the tree. For the the
+ # specification of the resulting structure see method
+ # 'Verify'.
+ #
+ # The sub-phases are and do
+ #
+ # (a) Extract the string information from the input and store
+ # them in their Text tokens.
+ # (b) Convert the special tokens (QBrace, Backslash, Quote,
+ # Continuation) into equivalent 'Text' tokens, with proper
+ # string information.
+ # (c) Merge adjacent 'Text' tokens.
+ # (d) Remove irrelevant 'Word' tokens. These are tokens with a
+ # single Text token as child. Word tokens without children
+ # however represent empty strings. They are converted into
+ # an equivalent Text node instead.
+ # (e) Pull the first word of commands into the command token,
+ # and ensure that it is not dynamic, i.e not an embedded
+ # command.
+
+ ShowTree $t "Raw tree"
+
+ set q [treeql %AUTO% -tree $t]
+
+ # (a)
+ foreach n [$q query tree withatt type Text] {
+ struct::list assign [$t get $n range] a e
+ #$t unset $n range
+ $t set $n text [string range $mydata $a $e]
+ }
+ ShowTree $t "Text annotation"
+
+ # (b1)
+ foreach n [$q query tree withatt type QBrace] {
+ struct::list assign [$t get $n range] a e
+ incr a ; # Skip backslash
+ #$t unset $n range
+ $t set $n text [string range $mydata $a $e]
+ $t set $n type Text
+ }
+ ShowTree $t "Special conversion 1, quoted braces"
+
+ # (b2)
+ foreach n [$q query tree withatt type Backslash] {
+ struct::list assign [$t get $n range] a e
+ #$t unset $n range
+ $t set $n text [subst -nocommands -novariables [string range $mydata $a $e]]
+
+ #puts <'[string range $mydata $a $e]'>
+ #puts _'[subst -nocommands -novariables [string range $mydata $a $e]]'_
+
+ $t set $n type Text
+ }
+ ShowTree $t "Special conversion 2, backslash sequences"
+
+ # (b3)
+ foreach n [$q query tree withatt type Quote] {
+ #$t unset $n range
+ $t set $n text "\""
+ $t set $n type Text
+ }
+ ShowTree $t "Special conversion 3, quoted double quotes"
+
+ # (b4)
+ foreach n [$q query tree withatt type Continuation] {
+ #$t unset $n range
+ $t set $n text { }
+ $t set $n type Text
+ }
+ ShowTree $t "Special conversion 4, continuation lines"
+
+ # (c)
+ foreach n [$q query tree withatt type Text right withatt type Text] {
+ set left [$t previous $n]
+ $t append $left text [$t get $n text]
+
+ # Extend covered range. Copy location.
+ struct::list assign [$t get $left range] a _
+ struct::list assign [$t get $n range] _ e
+ $t set $left range [list $a $e]
+ $t set $left line [$t get $n line]
+ $t set $left col [$t get $n col]
+
+ $t delete $n
+ }
+ ShowTree $t "Merged adjacent texts"
+
+ # (d)
+ foreach n [$q query tree withatt type Word] {
+ if {![$t numchildren $n]} {
+ $t set $n type Text
+ $t set $n text {}
+ } elseif {[$t numchildren $n] == 1} {
+ $t cut $n
+ }
+ }
+ ShowTree $t "Dropped simple words"
+
+ # (e)
+ foreach n [$q query tree withatt type Command] {
+ set first [lindex [$t children $n] 0]
+ if {[$t get $first type] eq "Word"} {
+ error {Dynamic command name}
+ }
+ $t set $n text [$t get $first text]
+ $t set $n range [$t get $first range]
+ $t set $n line [$t get $first line]
+ $t set $n col [$t get $first col]
+ $t delete $first
+ }
+ ShowTree $t "Command lifting"
+
+ $q destroy
+
+ Verify $t
+ return
+ }
+
+ proc Verify {t} {
+ # Tree structure ...
+ # Attributes Values
+ # - type string in {'Command','Text','Word'} (phase 2)
+ # - range 2-tuple (integer, integer), can be empty. start and end offset of the word in the input string.
+ # - line integer, line the node starts on. First line is 1
+ # - col integer, column the node starts on (#char since start of line, first char is 0)
+ # Constraints
+ # .(i) The root node has no attributes at all.
+ # .(ii) The children of the root are Command and Text nodes in semi-alternation.
+ # I.e.: After a Text node a Command has to follow.
+ # After a Command node either Text or Command can follow.
+ # .(iii) The children of a Command node are Text, Word, and Command nodes, the command arguments. If any.
+ # .(iv) The children of a Word node are Command and Text nodes in semi-alternation.
+ # .(v) All Text nodes are leafs.
+ # .(vi) Any Command node can be a leaf.
+ # .(vii) Word nodes cannot be leafs.
+ # .(viii) All non-root nodes have the attributes 'type', 'range', 'col', and 'line'.
+
+ foreach n [$t nodes] {
+ if {[$t parent $n] eq ""} {
+ # (ii)
+ set last {}
+ foreach c [$t children $n] {
+ set type [$t get $c type]
+ if {![struct::set contains {Command Text} $type]} {
+ return -code error "$c :: Bad node type $type in child of root node"
+ } elseif {($type eq $last) && ($last eq "Text")} {
+ return -code error "$c :: Bad node $type, not semi-alternating"
+ }
+ set last $type
+ }
+ # (i)
+ if {[llength [$t getall $n]]} {
+ return -code error "$n :: Bad root node, has attributes, should not"
+ }
+ continue
+ } else {
+ # (viii)
+ foreach k {range line col} {
+ if {![$t keyexists $n $k]} {
+ return -code error "$n :: Bad node, attribute '$k' missing"
+ }
+ }
+ }
+ set type [$t get $n type]
+ switch -exact -- $type {
+ Command {
+ # (vi)
+ # No need to check children. May have some or not,
+ # and no specific sequence is required.
+ }
+ Word {
+ # (vii)
+ if {![llength [$t children $n]]} {
+ return -code error "$n :: Bad word node is leaf"
+ }
+ # (iv)
+ set last {}
+ foreach c [$t children $n] {
+ set type [$t get $c type]
+ if {![struct::set contains {Command Text} $type]} {
+ return -code error "$n :: Bad node type $type in word node"
+ } elseif {($type eq $last) && ($last eq "Text")} {
+ return -code error "$c :: Bad node $type, not semi-alternating"
+ }
+ set last $type
+ }
+ }
+ Text {
+ # (v)
+ if {[llength [$t children $n]]} {
+ return -code error "$n :: Bad text node is not leaf"
+ }
+ }
+ default {
+ # (iii)
+ return -code error "$n :: Bad node type $type"
+ }
+ }
+ }
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Internal methods, lexical processing
+
+ proc String {} {
+ while 1 {
+ Note @String
+ if {[EOF]} break
+ if {[Command]} continue
+ if {[TextSegment]} continue
+ if {[Backslash]} continue
+
+ Stop ;# Unexpected character
+ }
+ Note @EOF
+ return
+ }
+
+ proc Command {} {
+ # A command starts with an opening bracket.
+ Note ?Command
+ if {![Match "\\A(\\\[)" range]} {
+ Note \t%No-Command
+ return 0
+ }
+ Note !Command
+
+ PushRoot [Node Command $range]
+ while {[Word]} {
+ # Step over any whitespace after the last word
+ Whitespace
+ # Command ends at the closing bracket
+ if {[Match "\\A(\\])" range]} break
+ if {![EOF]} continue
+
+ Stop ;# Unexpected end of input
+ }
+
+ Note !CommandStop
+ PopRoot
+ return 1
+ }
+
+ proc TextSegment {} {
+ # A text segment is anything up to a command start or start of
+ # a back slash sequence.
+ Note ?TextSegment
+ if {![Match "\\A(\[^\\\[\]+)" range]} {
+ Note \t%No-TextSegment
+ return 0
+ }
+ Note !TextSegment
+ Node Text $range
+ return 1
+ }
+
+ proc TextSegmentWithoutQuote {} {
+ Note ?TextSegmentWithoutQuote
+ # A text segment without quote is anything up to a command
+ # start or start of a back slash sequence, or a double-quote
+ # character.
+ if {![Match "\\A(\[^\"\\\\\[\]+)" range]} {
+ Note \t%No-TextSegmentWithoutQuote
+ return 0
+ }
+ Note !TextSegment
+ Node Text $range
+ return 1
+ }
+
+ proc Backslash {} {
+ Note ?Backslash
+ if {
+ ![Match "\\A(\\\\x\[a-fA-F0-9\]+)" range] &&
+ ![Match "\\A(\\\\u\[a-fA-F0-9\]{1,4})" range] &&
+ ![Match "\\A(\\\\\[0-2\]\[0-7\]{2})" range] &&
+ ![Match "\\A(\\\\\[0-7\]{1,2})" range] &&
+ ![Match {\A(\\[abfnrtv])} range]
+ } {
+ Note \t%No-Backslash
+ return 0
+ }
+ Note !Backslash
+ Node Backslash $range
+ return 1
+ }
+
+ proc Word {} {
+ Note ?Word
+ if {[QuotedWord]} {return 1}
+ if {[BracedWord 0]} {return 1}
+ return [UnquotedWord]
+ }
+
+ proc Whitespace {} {
+ Note ?Whitespace
+ if {![Match {\A([ \t]|(\\\n[ \t]*))+} range]} {
+ Note \t%No-Whitespace
+ return 0
+ }
+ Note !Whitespace
+ return 1
+ }
+
+ proc QuotedWord {} {
+ # A quoted word starts with a double quote.
+ Note ?QuotedWord
+ if {![Match "\\A(\")" range]} {
+ Note \t%No-QuotedWord
+ return 0
+ }
+ Note !QuotedWord
+ PushRoot [Node Word $range]
+ QuotedString
+ PopRoot
+ return 1
+ }
+
+ proc BracedWord {keepclose} {
+ # A braced word starts with an opening brace.
+ Note ?BracedWord/$keepclose
+ if {![Match "\\A(\{)" range]} {
+ Note \t%No-BracedWord/$keepclose
+ return 0
+ }
+ Note !BracedWord/$keepclose
+ PushRoot [Node Word $range]
+ BracedString $keepclose
+ PopRoot
+ return 1
+ }
+
+ proc UnquotedWord {} {
+ Note !UnquotedWord
+ PushRoot [Node Word {}]
+ UnquotedString
+ PopRoot
+ return 1
+ }
+
+ proc QuotedString {} {
+ Note !QuotedString
+ while 1 {
+ Note !QuotedStringPart
+ # A quoted word (and thus the embedded string) ends with
+ # double quote.
+ if {[Match "\\A(\")" range]} {
+ return
+ }
+ # Now try to match possible pieces of the string. This is
+ # a repetition of the code in 'String', except for the
+ # different end condition above, and the possible embedded
+ # double quotes and continuation lines the outer string
+ # can ignore.
+ if {[Command]} continue
+ if {[Quote]} continue
+ if {[QuotedBraces]} continue
+ if {[Continuation]} continue
+ if {[Backslash]} continue
+ # Check after backslash recognition and processing
+ if {[TextSegmentWithoutQuote]} continue
+
+ Stop ;# Unexpected character or end of input
+ }
+ return
+ }
+
+ proc BracedString {keepclose} {
+ while 1 {
+ Note !BracedStringPart
+ # Closing brace encountered. keepclose is set if we are in
+ # a nested braced string. Only then do we have to put the
+ # brace as a regular text piece into the string
+ if {[Match "\\A(\})" range]} {
+ if {$keepclose} {
+ Node Text $range
+ }
+ return
+ }
+ # Special sequences.
+ if {[QuotedBraces]} continue
+ if {[Continuation]} continue
+ if {[BracedWord 1]} continue
+ # A backslash without a brace coming after is regular a
+ # character.
+ if {[Match {\A(\\)} range]} {
+ Node Text $range
+ continue
+ }
+ # Gooble sequence of regular characters. Stops at
+ # backslash and braces. Backslash stop is needed to handle
+ # the case of them starting a quoted brace.
+ if {[Match {\A([^\\\{\}]*)} range]} {
+ Node Text $range
+ continue
+ }
+ Stop ;# Unexpected character or end of input.
+ }
+ }
+
+ proc UnquotedString {} {
+ while 1 {
+ Note !UnquotedStringPart
+ # Stop conditions
+ # - end of string
+ # - whitespace
+ # - Closing bracket (end of command the word is in)
+ if {[EOF]} return
+ if {[Whitespace]} return
+ if {[Peek "\\A(\\\])" range]} return
+
+ # Match each possible type of part
+ if {[Command]} continue
+ if {[Quote]} continue
+ if {[Continuation]} continue
+ if {[Backslash]} continue
+ # Last, capture backslash sequences first.
+ if {[UnquotedTextSegment]} continue
+
+ Stop ;# Unexpected character or end of input.
+ }
+ return
+ }
+
+ proc UnquotedTextSegment {} {
+ # All chars but whitespace and brackets (start or end of
+ # command).
+ Note ?UnquotedTextSegment
+ if {![Match {\A([^\]\[\t\n ]+)} range]} {
+ Note \t%No-UnquotedTextSegment
+ return 0
+ }
+ Note !UnquotedTextSegment
+ Node Text $range
+ return 1
+ }
+
+ proc Quote {} {
+ Note ?EmdeddedQuote
+ if {![Match "\\A(\\\")" range]} {
+ Note \t%No-EmdeddedQuote
+ return 0
+ }
+ # Embedded double quote, not the end of the quoted string.
+ Note !EmdeddedQuote
+ Node Quote $range
+ return 1
+ }
+
+ proc Continuation {} {
+ Note ?ContinuationLine
+ if {![Match "\\A(\\\\\n\[ \t\]*)" range]} {
+ Note \t%No-ContinuationLine
+ return 0
+ }
+ Note !ContinuationLine
+ Node Continuation $range
+ return 1
+ }
+
+ proc QuotedBraces {} {
+ Note ?QuotedBrace
+ if {
+ ![Match "\\A(\\\\\{)" range] &&
+ ![Match "\\A(\\\\\})" range]
+ } {
+ Note \t%No-QuotedBrace
+ return 0
+ }
+ Note !QuotedBrace
+ Node QBrace $range
+ return 1
+ }
+
+ # # ## ### ##### ######## #############
+ ## Tree construction helper commands.
+
+ proc Node {what range} {
+ set n [lindex [$mytree insert $myroot end] 0]
+
+ Note "+\tNode $n @ $myroot $what"
+
+ $mytree set $n type $what
+ $mytree set $n range $range
+ $mytree set $n line $myline
+ $mytree set $n col $mycol
+
+ return $n
+ }
+
+ proc PushRoot {x} {
+ Note "Push Root = $x"
+ $myrootstack push $myroot
+ set myroot $x
+ return
+ }
+
+ proc PopRoot {} {
+ set myroot [$myrootstack pop]
+ Note "Pop Root = $myroot"
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Error reporting
+
+ proc Stop {} {
+ ::variable myerr
+ set ahead [string range $mydata $mypos [expr {$mypos + 30}]]
+ set err [expr {![string length $ahead] ? "eof" : "char"}]
+ set ahead [string map [list \n \\n \t \\t \r \\r] [string range $ahead 0 0]]
+ set caller [lindex [info level -1] 0]
+ set msg "[format $myerr($err) $ahead $caller] at line ${myline}.$mycol"
+ set err [list doctools::tcl::parse $err $mypos $myline $mycol]
+
+ return -code error -errorcode $err $msg
+ }
+
+ # # ## ### ##### ######## #############
+ ## Input processing. Match/peek lexemes, update location after
+ ## stepping over a range. Match = Peek + Step.
+
+ proc EOF {} {
+ Note "?EOF($mypos >= $mysize) = [expr {$mypos >= $mysize}]"
+ return [expr {$mypos >= $mysize}]
+ }
+
+ proc Match {pattern rv} {
+ upvar 1 $rv range
+ set ok [Peek $pattern range]
+ if {$ok} {Step $range}
+ return $ok
+ }
+
+ proc Peek {pattern rv} {
+ upvar 1 $rv range
+
+ Note Peek($pattern)----|[string map [list "\n" "\\n" "\t" "\\t"] [string range $mydata $mypos [expr {$mypos + 30}]]]|
+
+ if {[regexp -start $mypos -indices -- $pattern $mydata -> range]} {
+ Note \tOK
+ return 1
+ } else {
+ Note \tFAIL
+ return 0
+ }
+ }
+
+ proc Step {range} {
+ struct::list assign $range a e
+
+ set mylastpos $mypos
+
+ set mypos $e
+ incr mypos
+
+ set pieces [split [string range $mydata $a $e] \n]
+ set delta [string length [lindex $pieces end]]
+ set nlines [expr {[llength $pieces] - 1}]
+
+ if {$nlines} {
+ incr myline $nlines
+ set mycol $delta
+ } else {
+ incr mycol $delta
+ }
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Setup / Shutdown of parser/lexer
+
+ proc Initialize {t text root} {
+ set mytree $t
+ if {$root eq {}} {
+ set myroot [$t rootname]
+ } else {
+ set myroot $root
+ }
+
+ if {$myrootstack ne {}} Finalize
+ set myrootstack [struct::stack %AUTO%]
+ $myrootstack clear
+
+ set mydata $text
+ set mysize [string length $mydata]
+
+ set mypos 0
+ set myline 1
+ set mycol 0
+ return
+ }
+
+ proc Finalize {} {
+ $myrootstack destroy
+ set myrootstack {}
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Debugging helper commands
+ ## Add ability to disable these.
+ ## For the tree maybe add ability to dump through a callback ?
+
+ proc Note {text} {
+ upvar 1 range range
+ set m {}
+ append m "$text "
+ if {[info exists range]} {
+ append m "($range) "
+ if {$range != {}} {
+ foreach {a e} $range break
+ append m " = \"[string map [list "\n" "\\n" "\t" "\\t"] \
+ [string range $mydata $a $e]]\""
+ }
+ } else {
+ append m "@$mypos ($myline/$mycol)"
+ }
+ #log::debug $m
+ puts $m
+ return
+ }
+
+ #proc ShowTreeX {args} {}
+ proc ShowTreeX {t x} {
+ puts "=== \[ $x \] [string repeat = [expr {72 - [string length $x] - 9}]]"
+ $t walk root -order pre -type dfs n {
+ set prefix [string repeat .... [$t depth $n]]
+ puts "$prefix$n <[DictSort [$t getall $n]]>"
+ }
+ return
+ }
+
+ proc Note {args} {}
+ proc ShowTree {args} {}
+
+ # # ## ### ##### ######## #############
+
+ proc DictSort {dict} {
+ array set tmp $dict
+ set res {}
+ foreach k [lsort -dict [array names tmp]] {
+ lappend res $k $tmp($k)
+ }
+ return $res
+ }
+
+ # # ## ### ##### ######## #############
+ ## Parser state
+
+ typevariable mytree {} ; # Tree we are working on
+ typevariable myroot {} ; # Current root to add nodes to.
+ typevariable myrootstack {}
+
+ typevariable mydata {} ; # String to parse.
+ typevariable mysize 0 ; # Length of string to parse, cache
+
+ typevariable mylastpos ; # Last current position.
+ typevariable mypos 0 ; # Current parse location, offset from
+ typevariable myline 1 ; # the beginning of the string, line
+ typevariable mycol 0 ; # we are on, and the column within the
+ # line.
+
+ typevariable myerr -array {
+ char {Unexpected character '%1$s' in %2$s}
+ eof {Unexpected end of input in %2$s}
+ }
+
+
+ # # ## ### ##### ######## #############
+ ## Configuration
+
+ pragma -hasinstances no ; # singleton
+ pragma -hastypeinfo no ; # no introspection
+ pragma -hastypedestroy no ; # immortal
+
+ ##
+ # # ## ### ##### ######## #############
+}
+
+namespace eval ::doctools::tcl {
+ namespace export parse
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide doctools::tcl::parse 0.1
+return
diff --git a/tcllib/modules/doctools2base/tcl_parse.test b/tcllib/modules/doctools2base/tcl_parse.test
new file mode 100644
index 0000000..7770f26
--- /dev/null
+++ b/tcllib/modules/doctools2base/tcl_parse.test
@@ -0,0 +1,80 @@
+# -*- tcl -*-
+# docparsetcl.test: tests for the doctools::parse::tcl package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: tcl_parse.test,v 1.1 2009/04/01 04:27:47 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ useAccel [useTcllibC] struct/tree.tcl struct::tree
+ TestAccelInit struct::tree
+
+ useAccel [useTcllibC] struct/stack.tcl struct::stack
+ TestAccelInit struct::stack
+
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use struct/list.tcl struct::list
+ use snit/snit.tcl snit
+ use fileutil/fileutil.tcl fileutil
+ use log/logger.tcl logger
+ use treeql/treeql.tcl treeql
+}
+testing {
+ useLocal tcl_parse.tcl doctools::tcl::parse
+}
+
+# -------------------------------------------------------------------------
+
+test doctools-tcl-parse-1.0 {parse file, wrong#args} -body {
+ doctools::tcl::parse file
+} -returnCodes error -result {wrong # args: should be "::doctools::tcl::parse::Snit_typemethodfile type t path ?root?"}
+
+test doctools-tcl-parse-1.1 {parse file, wrong#args} -body {
+ doctools::tcl::parse file T
+} -returnCodes error -result {wrong # args: should be "::doctools::tcl::parse::Snit_typemethodfile type t path ?root?"}
+
+test doctools-tcl-parse-1.2 {parse file, wrong#args} -body {
+ doctools::tcl::parse file T P R XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::tcl::parse::Snit_typemethodfile type t path ?root?"}
+
+test doctools-tcl-parse-2.0 {parse text, wrong#args} -body {
+ doctools::tcl::parse text
+} -returnCodes error -result {wrong # args: should be "::doctools::tcl::parse::Snit_typemethodtext type t text ?root?"}
+
+test doctools-tcl-parse-2.1 {parse text, wrong#args} -body {
+ doctools::tcl::parse text T
+} -returnCodes error -result {wrong # args: should be "::doctools::tcl::parse::Snit_typemethodtext type t text ?root?"}
+
+test doctools-tcl-parse-2.2 {parse text, wrong#args} -body {
+ doctools::tcl::parse text T P R XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::tcl::parse::Snit_typemethodtext type t text ?root?"}
+
+# tcl_parse tests, numbering starts at 10
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::stack stkimpl {
+ TestAccelDo struct::set setimpl {
+ TestAccelDo struct::tree impl {
+ source [localPath tests/tcl_parse]
+ }
+ }
+}
+
+#----------------------------------------------------------------------
+TestAccelExit struct::tree
+TestAccelExit struct::set
+TestAccelExit struct::stack
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2base/tcllib_msgcat.man b/tcllib/modules/doctools2base/tcllib_msgcat.man
new file mode 100644
index 0000000..3718536
--- /dev/null
+++ b/tcllib/modules/doctools2base/tcllib_msgcat.man
@@ -0,0 +1,67 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::msgcat n 0.1]
+[keywords {catalog package}]
+[keywords docidx]
+[keywords doctoc]
+[keywords doctools]
+[keywords i18n]
+[keywords internationalization]
+[keywords l10n]
+[keywords localization]
+[keywords {message catalog}]
+[keywords {message package}]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Message catalog management for the various document parsers}]
+[category {Documentation tools}]
+[require Tcl 8.4]
+[require msgcat]
+[require doctools::msgcat [opt 0.1]]
+[description]
+
+The package [package doctools::msgcat] is a support module handling
+the selection of message catalogs for the various document processing
+packages in the doctools system version 2. As such it is an internal
+package a regular user (developer) should not be in direct contact
+with.
+
+[para]
+
+If you are such please go the documentation of either
+
+[list_begin enumerated]
+[enum] [package doctools::doc],
+[enum] [package doctools::toc], or
+[enum] [package doctools::idx]
+[list_end]
+
+[para]
+
+Within the system architecture this package resides under the various
+parser packages, and is shared by them. Underneath it, but not
+explicit dependencies, are the packages providing the message catalogs
+for the various languages.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::msgcat::init] [arg prefix]]
+
+The command locates and loads the message catalogs for all the
+languages returned by [cmd msgcat::mcpreferences], provided that they
+could be found. It returns an integer number describing how many
+packages were found and loaded.
+
+[para]
+
+The names of the packages the command will look for have the form
+"doctools::msgcat::[arg prefix]::[var langcode]", with [arg prefix]
+the argument to the command, and the [var langcode] supplied by the
+result of [cmd msgcat::mcpreferences].
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2base/tests/common b/tcllib/modules/doctools2base/tests/common
new file mode 100644
index 0000000..ee3e1d3
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/common
@@ -0,0 +1,239 @@
+# -*- tcl -*-
+# Code common to the various control files.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: common,v 1.3 2009/04/29 02:09:46 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+# Similar to TestFiles in devtools/testutilities.tcl, but not
+# identical. Here we do not expect source'able test suites, but data
+# files, organized in sections under a main directory.
+
+proc TestFilesProcess {maindir section inset outset -> nv lv iv dv ev script} {
+ upvar 1 $nv n $lv label $dv data $ev expected $iv inputfile
+
+ set pattern $maindir/$section/$inset/*
+
+ set files [TestFilesGlob $pattern]
+ if {![llength $files]} {
+ return -code error "No files matching \"$pattern\""
+ }
+ foreach src $files {
+ if {[string match *README* $src]} continue
+ if {[file isdirectory $src]} continue
+
+ set srcname [file tail $src]
+ set exp [localPath $maindir]/$section/$outset/$srcname
+ set data [fileutil::cat $src]
+ set expected [string trim [fileutil::cat $exp]]
+ set expected [string map [list @ $::tcltest::testsDirectory] $expected]
+
+ regexp -- {^([0-9]+)} $srcname -> n
+ regsub -all -- {^[0-9]+} $srcname {} label
+
+ scan $n %d n
+ set label [string trim [string map {_ { }} $label]]
+ set inputfile $src
+
+ uplevel 1 $script
+ }
+ return
+}
+
+# -------------------------------------------------------------------------
+
+proc setup_plugins {} {
+ global env
+
+ array_unset env LANG*
+ array_unset env LC_*
+ set env(LANG) C ; # Usually default if nothing is set, OS X requires this.
+
+ set paths [join [list \
+ [tcllibPath doctools2] \
+ [tcllibPath struct] \
+ [tcllibPath textutil]] \
+ [expr {$::tcl_platform(platform) eq "windows" ? ";" : ":"}]]
+
+ # Initialize the paths an import plugin manager should use when
+ # searching for an import plugin used by the code under test, and
+ # also provide the paths enabling the import plugins to find their
+ # supporting packages as well.
+
+ set env(DOCTOOLS_IDX_IMPORT_PLUGINS) $paths
+
+ # Initialize the paths an export plugin manager should use when
+ # searching for an export plugin used by the code under test, and
+ # also provide the paths enabling the export plugins to find their
+ # supporting packages as well.
+
+ set env(DOCTOOLS_IDX_EXPORT_PLUGINS) $paths
+
+ return
+}
+
+# -------------------------------------------------------------------------
+
+proc stripcomments {text} {
+ set pattern {[[:space:]]*\[comment[[:space:]][[:space:]]*\{[^\}]*\}[[:space:]]*\][[:space:]]*}
+ regsub -all -- $pattern $text {} text
+ return $text
+}
+
+proc striphtmlcomments {text {n {}}} {
+ set pattern {<!--.*?-->}
+ if {$n eq {}} {
+ regsub -all -- $pattern $text {} text
+ } else {
+ while {$n} {
+ regsub -- $pattern $text {} text
+ incr n -1
+ }
+ }
+ return $text
+}
+
+proc stripmanmacros {text} {
+ return [string map [list \n[doctools::nroff::man_macros::contents] {}] $text]
+}
+
+proc stripnroffcomments {text {n {}}} {
+# return $text
+ set pattern "'\\\\\"\[^\n\]*\n"
+ if {$n eq {}} {
+ regsub -all -- $pattern $text {} text
+ } else {
+ while {$n} {
+ regsub -- $pattern $text {} text
+ incr n -1
+ }
+ }
+ return $text
+}
+
+# -------------------------------------------------------------------------
+
+# Validate a serialization against the tree it
+# was generated from.
+
+proc validate_serial {t serial {rootname {}}} {
+ if {$rootname == {}} {
+ set rootname [$t rootname]
+ }
+
+ # List length is multiple of 3
+ if {[llength $serial] % 3} {
+ return serial/wrong#elements
+ }
+
+ # Scan through list and built a number helper
+ # structures (arrays).
+
+ array set a {}
+ array set p {}
+ array set ch {}
+ foreach {node parent attr} $serial {
+ # Node has to exist in tree
+ if {![$t exists $node]} {
+ return node/$node/unknown
+ }
+ if {![info exists ch($node)]} {set ch($node) {}}
+ # Parent reference has to be empty or
+ # integer, == 0 %3, >=0, < length serial
+ if {$parent != {}} {
+ if {![string is integer -strict $parent]} {
+ return node/$node/parent/no-integer/$parent
+ }
+ if {$parent % 3} {
+ return node/$node/parent/not-triple/$parent
+ }
+ if {$parent < 0} {
+ return node/$node/parent/out-of-bounds/$parent
+ }
+ if {$parent >= [llength $serial]} {
+ return node/$node/parent/out-of-bounds/$parent
+ }
+ # Resolve parent index into node name, has to match
+ set parentnode [lindex $serial $parent]
+ if {![$t exists $parentnode]} {
+ return node/$node/parent/unknown/$parent/$parentnode
+ }
+ if {![string equal [$t parent $node] $parentnode]} {
+ return node/$node/parent/mismatch/$parent/$parentnode/[$t parent $node]
+ }
+ lappend ch($parentnode) $node
+ } else {
+ set p($node) {}
+ }
+ # Attr list has to be of even length.
+ if {[llength $attr] % 2} {
+ return attr/$node/wrong#elements
+ }
+ # Attr have to exist and match in all respects
+ if {![string equal \
+ [dictsort $attr] \
+ [dictsort [$t getall $node]]]} {
+ return attr/$node/mismatch
+ }
+ }
+ # Second pass, check that the children information is encoded
+ # correctly. Reconstructed data has to match originals.
+
+ foreach {node parent attr} $serial {
+ if {![string equal $ch($node) [$t children $node]]} {
+ return node/$node/children/mismatch
+ }
+ }
+
+ # Reverse check
+ # - List of nodes from the 'rootname' and check
+ # that it and all its children are present
+ # in the structure.
+
+ set ::FOO {}
+ $t walk $rootname n {walker $n}
+
+ foreach n $::FOO {
+ if {![info exists ch($n)]} {
+ return node/$n/mismatch/reachable/missing
+ }
+ }
+ if {[llength $::FOO] != [llength $serial]/3} {
+ return structure/mismatch/#nodes/multiples
+ }
+ if {[llength $::FOO] != [array size ch]} {
+ return structure/mismatch/#nodes/multiples/ii
+ }
+ return ok
+}
+
+# Callbacks for tree walking.
+# Remember the node in a global variable.
+
+proc walker {node} {
+ lappend ::FOO $node
+}
+
+proc match_tree {ta tb} {
+ match_node $ta [$ta rootname] $tb [$tb rootname]
+ return
+}
+
+proc match_node {ta a tb b} {
+ if {[dictsort [$ta getall $a]] ne [dictsort [$tb getall $b]]} {
+ return -code error "$ta/$a at $tb/$b, attribute mismatch (([dictsort [$ta getall $a]]) ne ([dictsort [$tb getall $b]]))"
+ }
+ if {[llength [$ta children $a]] != [llength [$tb children $b]]} {
+ return -code error "$ta/$a at $tb/$b, children mismatch"
+ }
+ foreach ca [$ta children $a] cb [$tb children $b] {
+ match_node $ta $ca $tb $cb
+ }
+ return
+}
+
+# -------------------------------------------------------------------------
+return
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/fail/in/1_command b/tcllib/modules/doctools2base/tests/tcl_data/fail/in/1_command
new file mode 100644
index 0000000..c30242e
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/fail/in/1_command
@@ -0,0 +1,2 @@
+[foo
+x]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/fail/in/2_unexpected_eof b/tcllib/modules/doctools2base/tests/tcl_data/fail/in/2_unexpected_eof
new file mode 100644
index 0000000..394eddc
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/fail/in/2_unexpected_eof
@@ -0,0 +1 @@
+[foo \ No newline at end of file
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/fail/in/3_unexpected_char b/tcllib/modules/doctools2base/tests/tcl_data/fail/in/3_unexpected_char
new file mode 100644
index 0000000..55872e9
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/fail/in/3_unexpected_char
@@ -0,0 +1 @@
+[foo "x \ No newline at end of file
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/fail/out-ec/1_command b/tcllib/modules/doctools2base/tests/tcl_data/fail/out-ec/1_command
new file mode 100644
index 0000000..a22fd0f
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/fail/out-ec/1_command
@@ -0,0 +1 @@
+doctools::tcl::parse char 4 1 4
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/fail/out-ec/2_unexpected_eof b/tcllib/modules/doctools2base/tests/tcl_data/fail/out-ec/2_unexpected_eof
new file mode 100644
index 0000000..22b5045
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/fail/out-ec/2_unexpected_eof
@@ -0,0 +1 @@
+doctools::tcl::parse eof 4 1 4
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/fail/out-ec/3_unexpected_char b/tcllib/modules/doctools2base/tests/tcl_data/fail/out-ec/3_unexpected_char
new file mode 100644
index 0000000..d3b57de
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/fail/out-ec/3_unexpected_char
@@ -0,0 +1 @@
+doctools::tcl::parse eof 8 1 8
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/fail/out/1_command b/tcllib/modules/doctools2base/tests/tcl_data/fail/out/1_command
new file mode 100644
index 0000000..7e9d076
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/fail/out/1_command
@@ -0,0 +1 @@
+Unexpected character '\n' in UnquotedString at line 1.4
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/fail/out/2_unexpected_eof b/tcllib/modules/doctools2base/tests/tcl_data/fail/out/2_unexpected_eof
new file mode 100644
index 0000000..9c26692
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/fail/out/2_unexpected_eof
@@ -0,0 +1 @@
+Unexpected end of input in Command at line 1.4
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/fail/out/3_unexpected_char b/tcllib/modules/doctools2base/tests/tcl_data/fail/out/3_unexpected_char
new file mode 100644
index 0000000..9aa5d96
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/fail/out/3_unexpected_char
@@ -0,0 +1 @@
+Unexpected end of input in QuotedString at line 1.8
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/01_command1 b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/01_command1
new file mode 100644
index 0000000..240d9f7
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/01_command1
@@ -0,0 +1 @@
+[foo]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/02_command2 b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/02_command2
new file mode 100644
index 0000000..90ee7d5
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/02_command2
@@ -0,0 +1 @@
+[foo x y]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/03_command3 b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/03_command3
new file mode 100644
index 0000000..685c275
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/03_command3
@@ -0,0 +1 @@
+[foo x $y]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/04_command4 b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/04_command4
new file mode 100644
index 0000000..ee160cf
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/04_command4
@@ -0,0 +1 @@
+[foo {x y}]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/05_command5 b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/05_command5
new file mode 100644
index 0000000..6f2f040
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/05_command5
@@ -0,0 +1 @@
+[foo "x y"]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/06_command6 b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/06_command6
new file mode 100644
index 0000000..409b99e
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/06_command6
@@ -0,0 +1 @@
+[foo "\n y"]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/07_command7 b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/07_command7
new file mode 100644
index 0000000..85bea1e
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/07_command7
@@ -0,0 +1 @@
+[foo {x \{}]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/08_command8 b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/08_command8
new file mode 100644
index 0000000..7fa24af
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/08_command8
@@ -0,0 +1 @@
+[foo "x \{"]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/09_command_nested b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/09_command_nested
new file mode 100644
index 0000000..7234414
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/09_command_nested
@@ -0,0 +1 @@
+[foo [bar]]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/10_combined b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/10_combined
new file mode 100644
index 0000000..61e1a9b
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/10_combined
@@ -0,0 +1,11 @@
+a
+b
+c
+[foo bar {a b} \n]
+[fox [bar]]
+[dog \
+ wags "tail\t\
+ ."]
+e
+f
+g
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/11_continuation1 b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/11_continuation1
new file mode 100644
index 0000000..0ba0741
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/11_continuation1
@@ -0,0 +1,2 @@
+[foo x \
+ y]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/12_continuation2 b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/12_continuation2
new file mode 100644
index 0000000..7c5f75b
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/12_continuation2
@@ -0,0 +1,2 @@
+[foo x "y \
+ z"]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/13_continuation3 b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/13_continuation3
new file mode 100644
index 0000000..dfda6b6
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/13_continuation3
@@ -0,0 +1,2 @@
+[foo x {y \
+ z}]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/14_emptyword1 b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/14_emptyword1
new file mode 100644
index 0000000..754b33c
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/14_emptyword1
@@ -0,0 +1 @@
+[foo {}]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/15_emptyword2 b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/15_emptyword2
new file mode 100644
index 0000000..6defffd
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/15_emptyword2
@@ -0,0 +1 @@
+[foo ""]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/16_text b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/16_text
new file mode 100644
index 0000000..3774da6
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/16_text
@@ -0,0 +1 @@
+a b c
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/17_text_multiline b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/17_text_multiline
new file mode 100644
index 0000000..add38ef
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/17_text_multiline
@@ -0,0 +1,2 @@
+a b c
+d e f
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/in/18_command9 b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/18_command9
new file mode 100644
index 0000000..e7813e2
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/in/18_command9
@@ -0,0 +1 @@
+[foo][bar] [x][y]
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/01_command1 b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/01_command1
new file mode 100644
index 0000000..3c8efde
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/01_command1
@@ -0,0 +1,4 @@
+root ()
+....node1 (col 4 line 1 range {1 3} text foo type Command)
+....node4 (col 0 line 2 range {5 5} text {
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/02_command2 b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/02_command2
new file mode 100644
index 0000000..760bf40
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/02_command2
@@ -0,0 +1,6 @@
+root ()
+....node1 (col 4 line 1 range {1 3} text foo type Command)
+........node5 (col 6 line 1 range {5 5} text x type Text)
+........node7 (col 8 line 1 range {7 7} text y type Text)
+....node8 (col 0 line 2 range {9 9} text {
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/03_command3 b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/03_command3
new file mode 100644
index 0000000..44956bf
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/03_command3
@@ -0,0 +1,6 @@
+root ()
+....node1 (col 4 line 1 range {1 3} text foo type Command)
+........node5 (col 6 line 1 range {5 5} text x type Text)
+........node7 (col 9 line 1 range {7 8} text {$y} type Text)
+....node8 (col 0 line 2 range {10 10} text {
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/04_command4 b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/04_command4
new file mode 100644
index 0000000..7267983
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/04_command4
@@ -0,0 +1,5 @@
+root ()
+....node1 (col 4 line 1 range {1 3} text foo type Command)
+........node5 (col 9 line 1 range {6 8} text {x y} type Text)
+....node6 (col 0 line 2 range {11 11} text {
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/05_command5 b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/05_command5
new file mode 100644
index 0000000..7267983
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/05_command5
@@ -0,0 +1,5 @@
+root ()
+....node1 (col 4 line 1 range {1 3} text foo type Command)
+........node5 (col 9 line 1 range {6 8} text {x y} type Text)
+....node6 (col 0 line 2 range {11 11} text {
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/06_command6 b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/06_command6
new file mode 100644
index 0000000..aeaeff0
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/06_command6
@@ -0,0 +1,6 @@
+root ()
+....node1 (col 4 line 1 range {1 3} text foo type Command)
+........node5 (col 10 line 1 range {6 9} text {
+ y} type Text)
+....node7 (col 0 line 2 range {12 12} text {
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/07_command7 b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/07_command7
new file mode 100644
index 0000000..01c8dad
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/07_command7
@@ -0,0 +1,5 @@
+root ()
+....node1 (col 4 line 1 range {1 3} text foo type Command)
+........node5 (col 10 line 1 range {6 9} text x\ \{ type Text)
+....node7 (col 0 line 2 range {12 12} text {
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/08_command8 b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/08_command8
new file mode 100644
index 0000000..01c8dad
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/08_command8
@@ -0,0 +1,5 @@
+root ()
+....node1 (col 4 line 1 range {1 3} text foo type Command)
+........node5 (col 10 line 1 range {6 9} text x\ \{ type Text)
+....node7 (col 0 line 2 range {12 12} text {
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/09_command_nested b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/09_command_nested
new file mode 100644
index 0000000..b8a934a
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/09_command_nested
@@ -0,0 +1,5 @@
+root ()
+....node1 (col 4 line 1 range {1 3} text foo type Command)
+........node5 (col 9 line 1 range {6 8} text bar type Command)
+....node8 (col 0 line 2 range {11 11} text {
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/10_combined b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/10_combined
new file mode 100644
index 0000000..c78d0d9
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/10_combined
@@ -0,0 +1,24 @@
+root ()
+....node1 (col 0 line 4 range {0 5} text {a
+b
+c
+} type Text)
+....node2 (col 4 line 4 range {7 9} text foo type Command)
+........node6 (col 8 line 4 range {11 13} text bar type Text)
+........node8 (col 13 line 4 range {16 18} text {a b} type Text)
+........node10 (col 17 line 4 range {21 22} text {
+} type Text)
+....node11 (col 0 line 5 range {24 24} text {
+} type Text)
+....node12 (col 4 line 5 range {26 28} text fox type Command)
+........node16 (col 9 line 5 range {31 33} text bar type Command)
+....node19 (col 0 line 6 range {36 36} text {
+} type Text)
+....node20 (col 4 line 6 range {38 40} text dog type Command)
+........node24 (col 9 line 6 range {45 48} text wags type Text)
+........node26 (col 3 line 7 range {51 61} text {tail .} type Text)
+....node30 (col 0 line 11 range {64 70} text {
+e
+f
+g
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/11_continuation1 b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/11_continuation1
new file mode 100644
index 0000000..13cd239
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/11_continuation1
@@ -0,0 +1,6 @@
+root ()
+....node1 (col 4 line 1 range {1 3} text foo type Command)
+........node5 (col 6 line 1 range {5 5} text x type Text)
+........node7 (col 8 line 1 range {10 10} text y type Text)
+....node8 (col 0 line 2 range {12 12} text {
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/12_continuation2 b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/12_continuation2
new file mode 100644
index 0000000..74f468e
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/12_continuation2
@@ -0,0 +1,6 @@
+root ()
+....node1 (col 4 line 1 range {1 3} text foo type Command)
+........node5 (col 6 line 1 range {5 5} text x type Text)
+........node7 (col 2 line 2 range {8 13} text {y z} type Text)
+....node10 (col 0 line 3 range {16 16} text {
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/13_continuation3 b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/13_continuation3
new file mode 100644
index 0000000..74f468e
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/13_continuation3
@@ -0,0 +1,6 @@
+root ()
+....node1 (col 4 line 1 range {1 3} text foo type Command)
+........node5 (col 6 line 1 range {5 5} text x type Text)
+........node7 (col 2 line 2 range {8 13} text {y z} type Text)
+....node10 (col 0 line 3 range {16 16} text {
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/14_emptyword1 b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/14_emptyword1
new file mode 100644
index 0000000..c114ab3
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/14_emptyword1
@@ -0,0 +1,5 @@
+root ()
+....node1 (col 4 line 1 range {1 3} text foo type Command)
+........node4 (col 6 line 1 range {5 5} text {} type Text)
+....node5 (col 0 line 2 range {8 8} text {
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/15_emptyword2 b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/15_emptyword2
new file mode 100644
index 0000000..c114ab3
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/15_emptyword2
@@ -0,0 +1,5 @@
+root ()
+....node1 (col 4 line 1 range {1 3} text foo type Command)
+........node4 (col 6 line 1 range {5 5} text {} type Text)
+....node5 (col 0 line 2 range {8 8} text {
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/16_text b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/16_text
new file mode 100644
index 0000000..4b41e28
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/16_text
@@ -0,0 +1,3 @@
+root ()
+....node1 (col 0 line 2 range {0 5} text {a b c
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/17_text_multiline b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/17_text_multiline
new file mode 100644
index 0000000..58d1bc9
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/17_text_multiline
@@ -0,0 +1,4 @@
+root ()
+....node1 (col 0 line 3 range {0 11} text {a b c
+d e f
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_data/ok/out/18_command9 b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/18_command9
new file mode 100644
index 0000000..21060fa
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_data/ok/out/18_command9
@@ -0,0 +1,8 @@
+root ()
+....node1 (col 4 line 1 range {1 3} text foo type Command)
+....node4 (col 9 line 1 range {6 8} text bar type Command)
+....node7 (col 11 line 1 range {10 10} text { } type Text)
+....node8 (col 13 line 1 range {12 12} text x type Command)
+....node11 (col 16 line 1 range {15 15} text y type Command)
+....node14 (col 0 line 2 range {17 17} text {
+} type Text)
diff --git a/tcllib/modules/doctools2base/tests/tcl_parse b/tcllib/modules/doctools2base/tests/tcl_parse
new file mode 100644
index 0000000..6b9c9f2
--- /dev/null
+++ b/tcllib/modules/doctools2base/tests/tcl_parse
@@ -0,0 +1,57 @@
+# -*- tcl -*-
+# docparsetcl.testsuite: tests for the tcl parser.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: tcl_parse,v 1.1 2009/04/01 04:27:47 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/common]
+set mytestdir tests/tcl_data
+
+# -------------------------------------------------------------------------
+
+TestFilesProcess $mytestdir ok in out -> n label input data expected {
+ test doctools-tcl-parse-${stkimpl}-${setimpl}-${impl}-10.$n "doctools::tcl::parse, $label, ok" -setup {
+ struct::tree myresult
+ } -body {
+ doctools::tcl::parse text myresult $data
+ set res {}
+ myresult walk root tok {
+ lappend res "[string repeat {....} [myresult depth $tok]]$tok ([dictsort [myresult getall $tok]])"
+ }
+ join $res \n
+ } -cleanup {
+ myresult destroy
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+
+TestFilesProcess $mytestdir fail in out -> n label input data expected {
+ test doctools-tcl-parse-${stkimpl}-${setimpl}-${impl}-11.$n "doctools::tcl::parse, $label, eror message" -setup {
+ struct::tree myresult
+ } -body {
+ doctools::tcl::parse text myresult $data
+ } -cleanup {
+ myresult destroy
+ } -returnCodes error -result $expected
+}
+
+TestFilesProcess $mytestdir fail in out-ec -> n label input data expected {
+ test doctools-tcl-parse-${stkimpl}-${setimpl}-${impl}-12.$n "doctools::tcl::parse, $label, error code" -setup {
+ struct::tree myresult
+ } -body {
+ # Catch and rethrow using the error code as new message.
+ catch { doctools::tcl::parse text myresult $data }
+ set ::errorCode
+ } -cleanup {
+ myresult destroy
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+unset input data expected n label res
+return
diff --git a/tcllib/modules/doctools2base/text.tcl b/tcllib/modules/doctools2base/text.tcl
new file mode 100644
index 0000000..2d3af9b
--- /dev/null
+++ b/tcllib/modules/doctools2base/text.tcl
@@ -0,0 +1,216 @@
+# -*- tcl -*-
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Support package. Basic text generation commands.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.4 ; # Required Core
+
+namespace eval ::doctools::text {}
+
+# # ## ### ##### ######## ############# #####################
+
+proc ::doctools::text::begin {} {
+ variable state
+ array unset state *
+ array set state {
+ stack {}
+ buffer {}
+ prefix {}
+ pstack {}
+ underl {}
+ break 0
+ newlines 1
+ indenting 1
+ }
+ return
+}
+
+proc ::doctools::text::done {} {
+ variable state
+ return $state(buffer)
+}
+
+proc ::doctools::text::save {} {
+ variable state
+ set current [array get state]
+ begin
+ set state(stack) $current
+ return
+}
+
+proc ::doctools::text::restore {} {
+ variable state
+ set text [done]
+ array set state $state(stack)
+ return $text
+}
+
+proc ::doctools::text::collect {script} {
+ save
+ uplevel 1 $script
+ return [restore]
+}
+
+# # ## ### ##### ######## ############# #####################
+
+proc ::doctools::text::+ {text} {
+ variable state
+ if {$state(break)} {
+ +++ [string repeat \n $state(break)]
+ +++ $state(prefix)
+ set state(break) 0
+ }
+ +++ $text
+ set state(underl) [string length $text]
+ return
+}
+
+proc ::doctools::text::underline {char} {
+ variable state
+ newline
+ + [string repeat [string index $char 0] $state(underl)]
+ newline
+ return
+}
+
+proc ::doctools::text::+++ {text} {
+ variable state
+ append state(buffer) $text
+ return
+}
+
+# # ## ### ##### ######## ############# #####################
+
+proc ::doctools::text::newline {{increment 1}} {
+ variable state
+ if {!$state(newlines)} { return 0 }
+ incr state(break) $increment
+ return 1
+}
+
+proc ::doctools::text::newline? {} {
+ variable state
+ if {!$state(newlines)} { return 0 }
+ if {$state(break)} { return 1 }
+ if {![string length $state(buffer)]} { return 1 }
+ if {[string index $state(buffer) end] eq "\n"} { return 1 }
+ incr state(break)
+ return 1
+}
+
+# # ## ### ##### ######## ############# #####################
+
+proc ::doctools::text::prefix {text} {
+ variable state
+ if {!$state(indenting)} return
+ set state(prefix) $text
+ return
+}
+
+proc ::doctools::text::indent {{increment 2}} {
+ variable state
+ if {!$state(indenting)} return
+ lappend state(pstack) $state(prefix)
+ set state(prefix) [string repeat { } $increment]$state(prefix)
+ return
+}
+
+proc ::doctools::text::dedent {} {
+ variable state
+ if {!$state(indenting)} return
+ set state(prefix) [lindex $state(pstack) end]
+ set state(pstack) [lreplace $state(pstack) end end]
+ return
+}
+
+proc ::doctools::text::indented {increment script} {
+ indent $increment
+ uplevel 1 $script
+ dedent
+ return
+}
+
+# # ## ### ##### ######## ############# #####################
+
+proc ::doctools::text::indenting {enable} {
+ variable state
+ set state(indenting) $enable
+ return
+}
+
+proc ::doctools::text::newlines {enable} {
+ variable state
+ set state(newlines) $enable
+ return
+}
+
+# # ## ### ##### ######## ############# #####################
+
+proc ::doctools::text::field {wvar elements {index {}}} {
+ upvar 1 $wvar width
+ set width 0
+ #puts @!$width
+ if {$index ne {}} {
+ foreach e $elements {
+ #puts stdout @/$e
+ set e [lindex $e $index]
+ #puts stdout @^$e
+ set l [string length $e]
+ if {$l <= $width} continue
+ set width $l
+ }
+ } else {
+ foreach e $elements {
+ #puts stdout @/$e
+ set l [string length $e]
+ if {$l <= $width} continue
+ set width $l
+ }
+ }
+ #puts stdout @=$width
+ return
+}
+
+proc ::doctools::text::right {wvar str} {
+ upvar $wvar width
+ return [format %${width}s $str]
+}
+
+proc ::doctools::text::left {wvar str} {
+ upvar $wvar width
+ return [format %-${width}s $str]
+}
+
+# # ## ### ##### ######## ############# #####################
+
+proc ::doctools::text::import {{namespace {}}} {
+ uplevel 1 [list namespace eval ${namespace}::text {
+ namespace import ::doctools::text::*
+ }]
+ return
+}
+
+proc ::doctools::text::importhere {{namespace ::}} {
+ uplevel 1 [list namespace eval ${namespace} {
+ namespace import ::doctools::text::*
+ }]
+ return
+}
+
+# # ## ### ##### ######## ############# #####################
+
+namespace eval ::doctools::text {
+ variable state
+ array set state {}
+
+ namespace export begin done save restore collect + underline +++ \
+ prefix indent dedent indented indenting newline newlines \
+ field right left newline?
+}
+
+# # ## ### ##### ######## ############# #####################
+package provide doctools::text 0.1
+return
diff --git a/tcllib/modules/doctools2idx/ChangeLog b/tcllib/modules/doctools2idx/ChangeLog
new file mode 100644
index 0000000..b354923
--- /dev/null
+++ b/tcllib/modules/doctools2idx/ChangeLog
@@ -0,0 +1,107 @@
+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-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-11-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * export_docidx.man: Added headers to properly mark files as manpages
+ * export_html.man: even if not containing having manpage_begin, and
+ * export_json.man: vice versa, preventing recognition of subordinate
+ * export_nroff.man: include files as manpages.
+ * export_text.man:
+ * export_wiki.man:
+ * import_docidx.man:
+ * import_json.man:
+ * include/export/plugin.inc:
+ * include/import/plugin.inc:
+ * include/msgcat.inc:
+ * msgcat_c.man:
+ * msgcat_de.man:
+ * msgcat_en.man:
+ * msgcat_fr.man:
+
+ * tests/data/ok/json/1_nokeys: Fixed bad JSON.
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-11-23 Andreas Kupries <andreask@activestate.com>
+
+ * import_json.tcl: Added pragma to tell sak.tcl that the 'package
+ provide dict' is a fake.
+
+2009-08-07 Andreas Kupries <andreask@activestate.com>
+
+ * export_docidx.tcl: Added missing '@mdgen NODEP' hints for the
+ * export_html.tcl: pseudo-packages 'doctools::idx::export::plugin'
+ * export_json.tcl: and 'doctools::idx::import::plugin' to keep them
+ * export_nroff.tcl: out of the requirements listed in the meta data.
+ * export_text.tcl:
+ * export_wiki.tcl:
+ * import_docidx.tcl:
+ * import_json.tcl:
+
+2009-04-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * container.test: Updated the nroff export plugin and related files
+ * export.test: to new name of the nroff man.macros package. Bumped
+ * export_nroff.tcl: to version 0.3.
+ * export_nroff.test:
+ * export_nroff.man:
+ * pkgIndex.tcl:
+ * include/dependencies.inc:
+ * include/export/format/nroff.inc:
+
+2009-04-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * container.man: Fix version mismatch.
+ * export_docidx.tcl: Fix version mismatch.
+ * tests/container: Fix test names.
+
+2009-04-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * include/export/plugin.inc: Made version info configurable
+ * export_docidx.tcl: Version 0.1, unchanged
+ * export_json.tcl: Version 0.1, unchanged
+
+ * export_html.tcl: Bumped version to 0.2.
+ * export_nroff.tcl: Ditto.
+ * export_text.tcl: Ditto.
+ * export_wiki.tcl: Ditto.
+
+ * export_html.tcl: Fixed plugin API check.
+ * export_nroff.tcl: Ditto.
+ * export_text.tcl: Ditto.
+ * export_wiki.tcl: Ditto, plus fix in file mapping.
+ * pkgIndex.tcl: Bumped to version 0.2.
+
+ * export.man: Typo fixed.
+ * import.man: Ditto.
+ * introduction.man: Ditto.
+ * include/msgcat.inc: Ditto.
+ * include/export/config/html.inc: Ditto.
+ * include/import/plugin.inc: Ditto.
+ * import_docidx.tcl: Ditto.
+ * import_json.tcl: Ditto.
+ * tests/parse: Ditto.
+
+2009-03-31 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Doctools version 2, index processing.
diff --git a/tcllib/modules/doctools2idx/container.tcl b/tcllib/modules/doctools2idx/container.tcl
new file mode 100644
index 0000000..ae1a879
--- /dev/null
+++ b/tcllib/modules/doctools2idx/container.tcl
@@ -0,0 +1,405 @@
+# docidx.tcl --
+#
+# Implementation of docidx objects for Tcl. v2.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: container.tcl,v 1.3 2009/08/11 22:52:47 andreas_kupries Exp $
+
+# Each object manages one index, with methods to add and remove keys
+# and references, singly, or in bulk. The bulk methods accept various
+# forms of textual serializations, among them text using the docidx
+# markup language.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.4
+package require doctools::idx::structure
+package require snit
+
+# ### ### ### ######### ######### #########
+## API
+
+snit::type ::doctools::idx {
+
+ # Concepts:
+ # - An index consists of a (possibly empty) set of keys,
+ # - Each key in the set is identified by its name.
+ # - Each key has a (possibly empty) set of references.
+ # - Each reference is identified by its target, specified as
+ # either url or symbolic filename, depending on the type of
+ # reference (url, or manpage).
+ # - A reference can be in the sets of more than one key.
+ # - A reference outside of the sets of all keys is not possible
+ # however.
+ # - A reference carries not only its identifying target, but also
+ # a descriptive label (*). This label is however not unique per
+ # reference, but only per a pair of key and reference in that
+ # key.
+ # - The type of a reference (url, or manpage) is however bound to
+ # the reference itself.
+ # - (*) For keys the identifying feature is identical to its
+ # label.
+
+ # Note: url and manpage references share a namespace for their
+ # identifiers. This should be no problem with manpage identifiers
+ # being symbolic filenames and as such they should never look like
+ # urls.
+
+ # ### ### ### ######### ######### #########
+ ## Options
+
+ ## None
+
+ # ### ### ### ######### ######### #########
+ ## Methods
+
+ # Default constructor.
+ # Default destructor.
+
+ # ### ### ### ######### ######### #########
+
+ method invalidate {} {
+ array unset myidx *
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method title {{text {}}} {
+ if {[llength [info level 0]] == 6} {
+ set mytitle $text
+ }
+ return $mytitle
+ }
+
+ method label {{text {}}} {
+ if {[llength [info level 0]] == 6} {
+ set mylabel $text
+ }
+ return $mylabel
+ }
+
+ method exporter {{object {}}} {
+ # TODO :: unlink/link change notification callbacks on the
+ # config/include components so that we can invalidate our
+ # cache when the settings change.
+
+ if {[llength [info level 0]] == 6} {
+ set myexporter $object
+ }
+ return $myexporter
+ }
+
+ method importer {{object {}}} {
+ if {[llength [info level 0]] == 6} {
+ set myimporter $object
+ }
+ return $myimporter
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Direct manipulation of the index contents.
+
+ method {key add} {key} {
+ # Ignore addition of an already known key
+ if {[info exists mykey($key)]} return
+ set mykey($key) {}
+ array unset myidx *
+ return
+ }
+
+ method {key remove} {key} {
+ # Ignore removal of a key already gone
+ if {![info exists mykey($key)]} return
+ set references $mykey($key)
+ unset mykey($key)
+ foreach name $references {
+ # Remove key from the list of users for all references it
+ # contains.
+ set pos [lsearch -exact $myrefuse($name) $key]
+ set myrefuse($name) [lreplace $myrefuse($name) $pos $pos]
+ if {[llength $myrefuse($name)]} continue
+ # Last use of this reference is gone, delete it.
+ unset myrefuse($name)
+ unset myref($name)
+ }
+ array unset myidx *
+ return
+ }
+
+ method keys {} {
+ return [array names mykey]
+ }
+
+ method {key references} {key} {
+ if {![info exists mykey($key)]} {
+ return -code error "Unknown key '$key'"
+ }
+ return $mykey($key)
+ }
+
+ method {reference add} {reftype key name label} {
+ if {![info exists mykey($key)]} {
+ return -code error "Unknown key '$key'"
+ }
+ if {[info exists myref($name)] && ([lindex $myref($name) 0] ne $reftype)} {
+ return -code error "Cannot add $reftype reference '$name', is a [lindex $myref($name) 0] reference already"
+ }
+ if {($reftype ne "url") && ($reftype ne "manpage")} {
+ return -code error "Bad reference type '$reftype'"
+ }
+ set myref($name) [list $reftype $label]
+ if {![info exists myrefuse($name)]} {
+ set myrefuse($name) {}
+ }
+ if {![info exists mylink([list $name $key])]} {
+ # reference was not used by the key yet.
+ lappend mykey($key) $name
+ lappend myrefuse($name) $key
+ set mylink([list $name $key]) .
+ }
+ array unset myidx *
+ return
+ }
+
+ method {reference remove} {name} {
+ # Ignore removal of already unknown reference
+ if {![info exists myrefuse($name)]} return
+ foreach key $myrefuse($name) {
+ unset mylink([list $name $key])
+ set pos [lsearch -exact $mykey($key) $name]
+ set mykey($key) [lreplace $mykey($key) $pos $pos]
+ }
+ unset myref($name)
+ unset myrefuse($name)
+ array unset myidx *
+ return
+ }
+
+ method {reference label} {name} {
+ if {![info exists myref($name)]} {
+ return -code error "Unknown reference '$name'"
+ }
+ return [lindex $myref($name) 1]
+ }
+
+ method {reference type} {name} {
+ if {![info exists myref($name)]} {
+ return -code error "Unknown reference '$name'"
+ }
+ return [lindex $myref($name) 0]
+ }
+
+ method {reference keys} {name} {
+ if {![info exists myrefuse($name)]} {
+ return -code error "Unknown reference '$name'"
+ }
+ return $myrefuse($name)
+ }
+
+ method references {} {
+ return [array names myrefuse]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Public methods. Bulk loading and merging.
+
+ method {deserialize =} {data {format {}}} {
+ # Default format is the regular index serialization
+ if {$format eq {}} {
+ set format serial
+ }
+
+ if {$format ne "serial"} {
+ set data [$self Import $format $data]
+ # doctools::idx::structure verify-as-canonical $data
+ # ImportSerial verifies.
+ }
+
+ $self ImportSerial $data
+ return
+ }
+
+ method {deserialize +=} {data {format {}}} {
+ # Default format is the regular index serialization
+ if {$format eq {}} {
+ set format serial
+ }
+
+ if {$format ne "serial"} {
+ set data [$self Import $format $data]
+ # doctools::idx::structure verify-as-canonical $data
+ # merge or ImportSerial verify the structure.
+ }
+
+ set data [doctools::idx::structure merge [$self serialize] $data]
+ # doctools::idx::structure verify-as-canonical $data
+ # ImportSerial verifies.
+
+ $self ImportSerial $data
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method serialize {{format {}}} {
+ # Default format is the regular index serialization
+ if {$format eq {}} {
+ set format serial
+ }
+
+ # First check the cache for a remebered representation of the
+ # index for the chosen format, and return it, if such is
+ # known.
+
+ if {[info exists myidx($format)]} {
+ return $myidx($format)
+ }
+
+ # If there is no cached representation we have to generate it
+ # from it from our internal representation.
+
+ if {$format eq "serial"} {
+ return [$self GenerateSerial]
+ } else {
+ return [$self Generate $format]
+ }
+
+ return -code error "Internal error, reached unreachable location"
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal methods
+
+ method GenerateSerial {} {
+ # We can generate the list serialization easily from the
+ # internal representation.
+
+ # Scan and reorder ...
+ set keywords {}
+ foreach kw [lsort -dict [array names mykey]] {
+ # Sort the references in a keyword by their _labels_.
+ set tmp {}
+ foreach rid $mykey($kw) { lappend tmp [list $rid [lindex $myref($rid) 1]] }
+ set refs {}
+ foreach item [lsort -dict -index 1 $tmp] {
+ lappend refs [lindex $item 0]
+ }
+ lappend keywords $kw $refs
+ }
+
+ set references {}
+ foreach rid [lsort -dict [array names myrefuse]] {
+ lappend references $rid $myref($rid)
+ }
+
+ # Construct result
+ set serial [list doctools::idx \
+ [list \
+ label $mylabel \
+ keywords $keywords \
+ references $references \
+ title $mytitle]]
+
+ # This is just present to assert that the code above creates
+ # correct serializations.
+ doctools::idx::structure verify-as-canonical $serial
+
+ set myidx(serial) $serial
+ return $serial
+ }
+
+ method Generate {format} {
+ if {$myexporter eq {}} {
+ return -code error "Unable to export from \"$format\", no exporter configured"
+ }
+ set res [$myexporter export object $self $format]
+ set myidx($format) $res
+ return $res
+ }
+
+ method ImportSerial {serial} {
+ doctools::idx::structure verify $serial iscanonical
+
+ array unset myidx *
+ array unset mykey *
+ array unset myrefuse *
+ array unset myref *
+ array unset mylink *
+
+ # Unpack the serialization.
+ array set idx $serial
+ array set idx $idx(doctools::idx)
+ unset idx(doctools::idx)
+
+ # We are setting the relevant variables directly instead of
+ # going through the accessor methods.
+ # I. Label and title
+ # II. Keys and references
+ # III. Back index references -> keys.
+
+ set mytitle $idx(title)
+ set mylabel $idx(label)
+
+ array set mykey $idx(keywords)
+ array set myref $idx(references)
+
+ foreach k [array names mykey] {
+ foreach r $mykey($k) {
+ lappend myrefuse($r) $k
+ set mylink([list $r $k]) .
+ }
+ }
+
+ # Extend cache (only if canonical, as we return only canonical
+ # data).
+ if {$iscanonical} {
+ set myidx(serial) $serial
+ }
+ return
+ }
+
+ method Import {format data} {
+ if {$myimporter eq {}} {
+ return -code error "Unable to import from \"$format\", no importer configured"
+ }
+
+ return [$myimporter import text $data $format]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## State
+
+ # References to export/import managers extending the
+ # (de)serialization abilities of the index.
+ variable myexporter {}
+ variable myimporter {}
+
+ # Internal representation of the index.
+
+ variable mytitle {} ; #
+ variable mylabel {} ; #
+ variable mykey -array {} ; # key -> list of references
+ variable myref -array {} ; # reference -> (type, label)
+ variable myrefuse -array {} ; # reference -> list of keys using the reference
+ variable mylink -array {} ; # reference x key -> exists if the reference is used by key.
+
+ # Array serving as cache holding alternative representations of
+ # the index generated via 'serialize', i.e. data export.
+
+ variable myidx -array {}
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::idx 2
+return
diff --git a/tcllib/modules/doctools2idx/container.test b/tcllib/modules/doctools2idx/container.test
new file mode 100644
index 0000000..5bfeb80
--- /dev/null
+++ b/tcllib/modules/doctools2idx/container.test
@@ -0,0 +1,680 @@
+# -*- tcl -*-
+# idx.test: Tests for the doctools::idx package. Index management.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: container.test,v 1.2 2009/04/29 02:10:34 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2
+
+support {
+ use struct/list.tcl struct::list
+ use snit/snit.tcl snit
+ use fileutil/fileutil.tcl fileutil
+ use log/logger.tcl logger
+ use pluginmgr/pluginmgr.tcl pluginmgr
+
+ use doctools2base/config.tcl doctools::config
+ use doctools2base/paths.tcl doctools::paths
+ useLocal export.tcl doctools::idx::export
+ useLocal import.tcl doctools::idx::import
+ use doctools2base/nroff_manmacros.tcl doctools::nroff::man_macros
+
+ source [tcllibPath doctools2base/tests/common]
+}
+testing {
+ useLocalKeep container.tcl doctools::idx
+}
+
+# -------------------------------------------------------------------------
+
+setup_plugins
+
+# -------------------------------------------------------------------------
+
+test doctools-idx-1.0 {deserialize =, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I deserialize =
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethoddeserialize_= type selfns win self data ?format?"}
+
+test doctools-idx-1.1 {deserialize =, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I deserialize = T F XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethoddeserialize_= type selfns win self data ?format?"}
+
+test doctools-idx-2.0 {deserialize +=, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I deserialize +=
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethoddeserialize_+= type selfns win self data ?format?"}
+
+test doctools-idx-2.1 {deserialize +=, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I deserialize += T F XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethoddeserialize_+= type selfns win self data ?format?"}
+
+test doctools-idx-3.0 {serialize, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I serialize F XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_methodserialize type selfns win self ?format?"}
+
+test doctools-idx-4.0 {key add, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I key add
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodkey_add type selfns win self key"}
+
+test doctools-idx-4.1 {key add, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I key add N XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodkey_add type selfns win self key"}
+
+test doctools-idx-5.0 {key remove, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I key remove
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodkey_remove type selfns win self key"}
+
+test doctools-idx-5.1 {key remove, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I key remove N XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodkey_remove type selfns win self key"}
+
+test doctools-idx-6.0 {key references, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I key references
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodkey_references type selfns win self key"}
+
+test doctools-idx-6.1 {key references, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I key references N XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodkey_references type selfns win self key"}
+
+test doctools-idx-7.0 {keys, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I keys XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_methodkeys type selfns win self"}
+
+test doctools-idx-8.0 {reference add, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I reference add
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodreference_add type selfns win self reftype key name label"}
+
+test doctools-idx-8.1 {reference add, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I reference add T
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodreference_add type selfns win self reftype key name label"}
+
+test doctools-idx-8.2 {reference add, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I reference add T K
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodreference_add type selfns win self reftype key name label"}
+
+test doctools-idx-8.3 {reference add, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I reference add T K N
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodreference_add type selfns win self reftype key name label"}
+
+test doctools-idx-8.4 {reference add, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I reference add T K N L XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodreference_add type selfns win self reftype key name label"}
+
+test doctools-idx-9.0 {reference remove, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I reference remove
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodreference_remove type selfns win self name"}
+
+test doctools-idx-9.1 {reference remove, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I reference remove N XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodreference_remove type selfns win self name"}
+
+test doctools-idx-10.0 {reference label, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I reference label
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodreference_label type selfns win self name"}
+
+test doctools-idx-10.1 {reference label, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I reference label N XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodreference_label type selfns win self name"}
+
+test doctools-idx-11.0 {reference keys, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I reference keys
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodreference_keys type selfns win self name"}
+
+test doctools-idx-11.1 {reference keys, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I reference keys N XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodreference_keys type selfns win self name"}
+
+test doctools-idx-12.0 {reference type, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I reference type
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodreference_type type selfns win self name"}
+
+test doctools-idx-12.1 {reference type, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I reference type N XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_hmethodreference_type type selfns win self name"}
+
+test doctools-idx-13.0 {references, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I references XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_methodreferences type selfns win self"}
+
+test doctools-idx-14.0 {title, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I title T XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_methodtitle type selfns win self ?text?"}
+
+test doctools-idx-15.0 {label, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I label L XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_methodlabel type selfns win self ?text?"}
+
+test doctools-idx-16.0 {exporter, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I exporter E XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_methodexporter type selfns win self ?object?"}
+
+test doctools-idx-17.0 {importer, wrong#args} -setup {
+ doctools::idx I
+} -body {
+ I importer I XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::Snit_methodimporter type selfns win self ?object?"}
+
+# -------------------------------------------------------------------------
+
+test doctools-idx-18.0 {key add, new key} -setup {
+ doctools::idx I
+} -body {
+ I key add K
+ I keys
+} -cleanup {
+ I destroy
+} -result K
+
+test doctools-idx-18.1 {key add, known key} -setup {
+ doctools::idx I
+ I key add K
+} -body {
+ I key add K
+ I keys
+} -cleanup {
+ I destroy
+} -result K
+
+test doctools-idx-19.0 {key remove, known key} -setup {
+ doctools::idx I
+ I key add K
+} -body {
+ I key remove K
+ I keys
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-idx-19.1 {key remove, unknown key} -setup {
+ doctools::idx I
+ I key add K
+} -body {
+ I key remove K'
+ I keys
+} -cleanup {
+ I destroy
+} -result K
+
+test doctools-idx-19.2 {key remove, reference still has keys} -setup {
+ doctools::idx I
+ I key add K
+ I key add K'
+ I reference add manpage K R r
+ I reference add manpage K' R r
+} -body {
+ I key remove K
+ list [I keys] [I references]
+} -cleanup {
+ I destroy
+} -result {K' R}
+
+test doctools-idx-19.3 {key remove, last user of reference} -setup {
+ doctools::idx I
+ I key add K
+ I reference add manpage K R r
+} -body {
+ I key remove K
+ list [I keys] [I references]
+} -cleanup {
+ I destroy
+} -result {{} {}}
+
+test doctools-idx-20.0 {keys, empty} -setup {
+ doctools::idx I
+} -body {
+ I keys
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-idx-20.1 {keys, not empty} -setup {
+ doctools::idx I
+ I key add K
+} -body {
+ I keys
+} -cleanup {
+ I destroy
+} -result K
+
+test doctools-idx-20.2 {keys, not empty. multiple} -setup {
+ doctools::idx I
+ I key add K
+ I key add K'
+} -body {
+ lsort [I keys]
+} -cleanup {
+ I destroy
+} -result {K K'}
+
+test doctools-idx-21.0 {key, without references} -setup {
+ doctools::idx I
+ I key add K
+} -body {
+ I key references K
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-idx-21.1 {key, with reference, one} -setup {
+ doctools::idx I
+ I key add K
+ I reference add manpage K R r
+} -body {
+ I key references K
+} -cleanup {
+ I destroy
+} -result R
+
+test doctools-idx-21.2 {key, with reference, many} -setup {
+ doctools::idx I
+ I key add K
+ I reference add manpage K R r
+ I reference add manpage K R' r
+} -body {
+ I key references K
+} -cleanup {
+ I destroy
+} -result {R R'}
+
+test doctools-idx-22.0 {reference add, unknown key} -setup {
+ doctools::idx I
+} -body {
+ I reference add manpage K R r
+} -cleanup {
+ I destroy
+} -returnCodes error -result {Unknown key 'K'}
+
+test doctools-idx-22.1 {reference add, bad type} -setup {
+ doctools::idx I
+ I key add K
+} -body {
+ I reference add bogus K R r
+} -cleanup {
+ I destroy
+} -returnCodes error -result {Bad reference type 'bogus'}
+
+test doctools-idx-22.2 {reference add, known ref, type mismatch} -setup {
+ doctools::idx I
+ I key add K
+ I reference add manpage K R r
+} -body {
+ I reference add url K R r
+} -cleanup {
+ I destroy
+} -returnCodes error -result {Cannot add url reference 'R', is a manpage reference already}
+
+test doctools-idx-22.3 {reference add, unknown ref} -setup {
+ doctools::idx I
+ I key add K
+} -body {
+ I reference add manpage K R r
+ list [I references] [I key references K]
+} -cleanup {
+ I destroy
+} -result {R R}
+
+test doctools-idx-22.4 {reference add, known ref, type match} -setup {
+ doctools::idx I
+ I key add K
+ I reference add manpage K R r
+} -body {
+ I reference add manpage K R r'
+ list [I references] [I key references K]
+} -cleanup {
+ I destroy
+} -result {R R}
+
+test doctools-idx-23.0 {reference remove, known reference} -setup {
+ doctools::idx I
+ I key add K
+ I reference add manpage K R r
+} -body {
+ I reference remove R
+ list [I references] [I key references K]
+} -cleanup {
+ I destroy
+} -result {{} {}}
+
+test doctools-idx-23.1 {reference remove, unknown reference} -setup {
+ doctools::idx I
+ I key add K
+ I reference add manpage K R r
+} -body {
+ I reference remove R'
+ list [I references] [I key references K]
+} -cleanup {
+ I destroy
+} -result {R R}
+
+test doctools-idx-24.0 {reference type} -setup {
+ doctools::idx I
+ I key add K
+ I reference add manpage K R r
+} -body {
+ I reference type R
+} -cleanup {
+ I destroy
+} -result manpage
+
+test doctools-idx-25.0 {reference label} -setup {
+ doctools::idx I
+ I key add K
+ I reference add manpage K R r
+} -body {
+ I reference label R
+} -cleanup {
+ I destroy
+} -result r
+
+test doctools-idx-25.1 {reference label, multiple keys, overwrites} -setup {
+ doctools::idx I
+ I key add K
+ I key add K'
+ I reference add manpage K R r
+} -body {
+ lappend res [I reference label R]
+ I reference add manpage K' R r'
+ lappend res [I reference label R]
+} -cleanup {
+ I destroy
+ unset res
+} -result {r r'}
+
+test doctools-idx-25.2 {reference label, same key, overwrites} -setup {
+ doctools::idx I
+ I key add K
+ I reference add manpage K R r
+ I reference add manpage K R r'
+} -body {
+ I reference label R
+} -cleanup {
+ I destroy
+} -result r'
+
+test doctools-idx-26.0 {reference, always one key} -setup {
+ doctools::idx I
+ I key add K
+ I reference add manpage K R r
+} -body {
+ I reference keys R
+} -cleanup {
+ I destroy
+} -result K
+
+test doctools-idx-26.1 {reference, multiple keys} -setup {
+ doctools::idx I
+ I key add K
+ I key add K'
+ I reference add url K R r
+ I reference add url K' R r
+} -body {
+ lsort [I reference keys R]
+} -cleanup {
+ I destroy
+} -result {K K'}
+
+test doctools-idx-27.0 {references, empty} -setup {
+ doctools::idx I
+} -body {
+ I references
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-idx-27.1 {references, not empty} -setup {
+ doctools::idx I
+ I key add K
+ I reference add url K R r
+} -body {
+ I references
+} -cleanup {
+ I destroy
+} -result R
+
+test doctools-idx-27.2 {references, not empty. multiple} -setup {
+ doctools::idx I
+ I key add K
+ I reference add url K R r
+ I reference add url K R' r
+} -body {
+ lsort [I references]
+} -cleanup {
+ I destroy
+} -result {R R'}
+
+test doctools-idx-28.0 {title, default} -setup {
+ doctools::idx I
+} -body {
+ I title
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-idx-28.1 {title, set} -setup {
+ doctools::idx I
+} -body {
+ I title T
+} -cleanup {
+ I destroy
+} -result T
+
+test doctools-idx-28.2 {title, get} -setup {
+ doctools::idx I
+ I title T
+} -body {
+ I title
+} -cleanup {
+ I destroy
+} -result T
+
+test doctools-idx-29.0 {label, default} -setup {
+ doctools::idx I
+} -body {
+ I label
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-idx-29.1 {label, set} -setup {
+ doctools::idx I
+} -body {
+ I label T
+} -cleanup {
+ I destroy
+} -result T
+
+test doctools-idx-29.2 {label, get} -setup {
+ doctools::idx I
+ I label T
+} -body {
+ I label
+} -cleanup {
+ I destroy
+} -result T
+
+test doctools-idx-30.0 {exporter, default} -setup {
+ doctools::idx I
+} -body {
+ I exporter
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-idx-30.1 {exporter, set} -setup {
+ doctools::idx I
+} -body {
+ I exporter T
+} -cleanup {
+ I destroy
+} -result T
+
+test doctools-idx-30.2 {exporter, get} -setup {
+ doctools::idx I
+ I exporter T
+} -body {
+ I exporter
+} -cleanup {
+ I destroy
+} -result T
+
+test doctools-idx-31.0 {importer, default} -setup {
+ doctools::idx I
+} -body {
+ I importer
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-idx-31.1 {importer, set} -setup {
+ doctools::idx I
+} -body {
+ I importer T
+} -cleanup {
+ I destroy
+} -result T
+
+test doctools-idx-31.2 {importer, get} -setup {
+ doctools::idx I
+ I importer T
+} -body {
+ I importer
+} -cleanup {
+ I destroy
+} -result T
+
+# TODO :: check index merging (+=).
+
+# idx tests, numbering starts at 40
+# -------------------------------------------------------------------------
+
+source [localPath tests/container]
+
+#----------------------------------------------------------------------
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2idx/export.tcl b/tcllib/modules/doctools2idx/export.tcl
new file mode 100644
index 0000000..3b92571
--- /dev/null
+++ b/tcllib/modules/doctools2idx/export.tcl
@@ -0,0 +1,125 @@
+# docidx.tcl --
+#
+# Exporting indices into other formats.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: export.tcl,v 1.1 2009/04/01 04:28:37 andreas_kupries Exp $
+
+# Each object manages a set of plugins for the conversion of keyword
+# indices into some textual representation. I.e. this object manages
+# the conversion to specialized serializations of keyword indices.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.4
+package require doctools::config
+package require doctools::idx::structure
+package require pluginmgr
+package require snit
+
+# ### ### ### ######### ######### #########
+## API
+
+snit::type ::doctools::idx::export {
+
+ # ### ### ### ######### ######### #########
+ ## Options :: None
+
+ # ### ### ### ######### ######### #########
+ ## Creation, destruction.
+
+ constructor {} {
+ install myconfig using ::doctools::config ${selfns}::config
+ return
+ }
+
+ destructor {
+ $myconfig destroy
+ # Clear the cache of loaded export plugins.
+ foreach k [array names myplugin] {
+ $myplugin($k) destroy
+ }
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Convert from the Tcl index serialization to other formats.
+
+ method {export object} {obj {format {}}} {
+ return [$self export serial [$obj serialize] $format]
+ }
+
+ method {export serial} {serial {format {}}} {
+ doctools::idx::structure verify $serial iscanonical
+
+ set plugin [$self GetPlugin $format]
+
+ # We have a plugin, now feed it.
+
+ if {!$iscanonical} {
+ set serial [doctools::idx::structure canonicalize $serial]
+ }
+
+ set configuration [$myconfig get]
+ lappend configuration user $::tcl_platform(user)
+ lappend configuraton format [$plugin plugin]
+
+ return [$plugin do export $serial $configuration]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal methods
+
+ method GetPlugin {format} {
+ if {$format eq {}} { set format docidx }
+
+ if {![info exists myplugin($format)]} {
+ set plugin [pluginmgr ${selfns}::fmt-$format \
+ -pattern doctools::idx::export::* \
+ -api { export } \
+ -setup [mymethod PluginSetup]]
+ ::pluginmgr::paths $plugin doctools::idx::export
+ $plugin load $format
+ set myplugin($format) $plugin
+ } else {
+ set plugin $myplugin($format)
+ }
+
+ return $plugin
+ }
+
+ method PluginSetup {mgr ip} {
+ # Inject a pseudo package into the plugin interpreter the
+ # formatters can use to check that they were loaded into a
+ # proper environment.
+ $ip eval {package provide doctools::idx::export::plugin 1}
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## State
+
+ # Array serving as a cache for the various plugin managers holding
+ # a specific export plugin.
+
+ variable myplugin -array {}
+
+ # A component managing the configuration given to the export
+ # plugins when they are invoked.
+
+ component myconfig -public config
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::idx::export 0.1
+return
diff --git a/tcllib/modules/doctools2idx/export.test b/tcllib/modules/doctools2idx/export.test
new file mode 100644
index 0000000..d215828
--- /dev/null
+++ b/tcllib/modules/doctools2idx/export.test
@@ -0,0 +1,212 @@
+# -*- tcl -*-
+# idx.test: tests for the doctools::idx package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export.test,v 1.2 2009/04/29 02:10:34 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+
+ use struct/list.tcl struct::list
+ use snit/snit.tcl snit
+ use log/logger.tcl logger
+ use pluginmgr/pluginmgr.tcl pluginmgr
+
+ use doctools2base/config.tcl doctools::config
+ useLocal structure.tcl doctools::idx::structure
+ use doctools2base/nroff_manmacros.tcl doctools::nroff::man_macros
+
+ source [tcllibPath doctools2base/tests/common]
+}
+testing {
+ useLocalKeep export.tcl doctools::idx::export
+}
+
+# -------------------------------------------------------------------------
+
+setup_plugins
+
+# -------------------------------------------------------------------------
+
+test doctools-idx-export-1.0 {export object, wrong#args} -setup {
+ doctools::idx::export E
+} -body {
+ E export object
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::export::Snit_hmethodexport_object type selfns win self obj ?format?"}
+
+test doctools-idx-export-1.1 {export object, wrong#args} -setup {
+ doctools::idx::export E
+} -body {
+ E export object O F XXX
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::export::Snit_hmethodexport_object type selfns win self obj ?format?"}
+
+test doctools-idx-export-2.0 {export serial, wrong#args} -setup {
+ doctools::idx::export E
+} -body {
+ E export serial
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::export::Snit_hmethodexport_serial type selfns win self serial ?format?"}
+
+test doctools-idx-export-2.1 {export serial, wrong#args} -setup {
+ doctools::idx::export E
+} -body {
+ E export serial S F XXX
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::export::Snit_hmethodexport_serial type selfns win self serial ?format?"}
+
+test doctools-idx-export-5.0 {config names, wrong#args} -setup {
+ doctools::idx::export E
+} -body {
+ E config names X
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodnames type selfns win self"}
+
+test doctools-idx-export-6.0 {config get, wrong#args} -setup {
+ doctools::idx::export E
+} -body {
+ E config get X
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodget type selfns win self"}
+
+test doctools-idx-export-7.0 {config set, wrong#args} -setup {
+ doctools::idx::export E
+} -body {
+ E config set
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodset type selfns win self name ?value?"}
+
+test doctools-idx-export-7.1 {config set, wrong#args} -setup {
+ doctools::idx::export E
+} -body {
+ E config set N V X
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodset type selfns win self name ?value?"}
+
+# -------------------------------------------------------------------------
+
+test doctools-idx-export-12.0 {config set, define single var} -setup {
+ doctools::idx::export E
+} -body {
+ E config set N V
+ E config get
+} -cleanup {
+ E destroy
+} -result {N V}
+
+test doctools-idx-export-12.1 {config set, define multiple vars} -setup {
+ doctools::idx::export E
+} -body {
+ E config set N V
+ E config set A B
+ dictsort [E config get]
+} -cleanup {
+ E destroy
+} -result {A B N V}
+
+test doctools-idx-export-12.2 {config set, as query} -setup {
+ doctools::idx::export E
+ E config set N V
+} -body {
+ E config set N
+} -cleanup {
+ E destroy
+} -result V
+
+test doctools-idx-export-13.0 {config unset, all} -setup {
+ doctools::idx::export E
+ E config set N V
+} -body {
+ E config unset
+ E config get
+} -cleanup {
+ E destroy
+} -result {}
+
+test doctools-idx-export-13.1 {config unset, by exact name} -setup {
+ doctools::idx::export E
+ E config set N V
+ E config set A B
+} -body {
+ E config unset N
+ E config get
+} -cleanup {
+ E destroy
+} -result {A B}
+
+test doctools-idx-export-13.2 {config unset, by glob pattern} -setup {
+ doctools::idx::export E
+ E config set N V
+ E config set N' V'
+ E config set A B
+} -body {
+ E config unset N*
+ E config get
+} -cleanup {
+ E destroy
+} -result {A B}
+
+test doctools-idx-export-14.0 {config names, empty} -setup {
+ doctools::idx::export E
+} -body {
+ E config names
+} -cleanup {
+ E destroy
+} -result {}
+
+test doctools-idx-export-14.1 {config names, with variables} -setup {
+ doctools::idx::export E
+ E config set N V
+ E config set A B
+} -body {
+ lsort -dict [E config names]
+} -cleanup {
+ E destroy
+} -result {A N}
+
+test doctools-idx-export-15.0 {config get, empty} -setup {
+ doctools::idx::export E
+} -body {
+ E config get
+} -cleanup {
+ E destroy
+} -result {}
+
+test doctools-idx-export-15.1 {config get, with variables} -setup {
+ doctools::idx::export E
+ E config set N V
+ E config set A B
+} -body {
+ dictsort [E config get]
+} -cleanup {
+ E destroy
+} -result {A B N V}
+
+# idx_export tests, numbering starts at 20
+# -------------------------------------------------------------------------
+
+source [localPath tests/export]
+
+# -------------------------------------------------------------------------
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2idx/export_docidx.man b/tcllib/modules/doctools2idx/export_docidx.man
new file mode 100644
index 0000000..e5e276c
--- /dev/null
+++ b/tcllib/modules/doctools2idx/export_docidx.man
@@ -0,0 +1,7 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE docidx]
+[vset NAME docidx]
+[vset REQUIRE null]
+[vset CONFIG docidx]
+[vset VERSION 0.1]
+[include include/export/plugin.inc]
diff --git a/tcllib/modules/doctools2idx/export_docidx.tcl b/tcllib/modules/doctools2idx/export_docidx.tcl
new file mode 100644
index 0000000..4d48254
--- /dev/null
+++ b/tcllib/modules/doctools2idx/export_docidx.tcl
@@ -0,0 +1,210 @@
+# docidx.tcl --
+#
+# The docidx export plugin. Generation of docidx markup.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: export_docidx.tcl,v 1.3 2009/08/07 18:53:11 andreas_kupries Exp $
+
+# This package is a plugin for the doctools::idx v2 system. It takes
+# the list serialization of a keyword index and produces text in
+# docidx format.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: doctools::idx::export::plugin
+
+package require Tcl 8.4
+package require doctools::idx::export::plugin ; # Presence of this
+ # pseudo package
+ # indicates execution
+ # inside of a properly
+ # initialized plugin
+ # interpreter.
+package require doctools::idx::structure ; # Verification that
+ # the input is proper.
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc export {serial configuration} {
+
+ # Phase I. Check that we got a canonical index serialization. That
+ # makes the unpacking easier, as we can mix it with the
+ # generation of the output, knowing that everything is
+ # already sorted as it should be.
+
+ ::doctools::idx::structure verify-as-canonical $serial
+
+ # ### ### ### ######### ######### #########
+ # Configuration ...
+ # * Standard entries
+ # - user = person running the application doing the formatting
+ # - format = name of this format
+ # - file = name of the file the index came from. Optional.
+ # - map = maps symbolic references to actual file path. Optional.
+ # * docidx specific entries
+ # - newlines = boolean. tags separated by eol markers
+ # - indented = boolean. tags indented per the index structure.
+ # - aligned = boolean. reference information tabular aligned within keys.
+ #
+ # Notes
+ # * This format ignores 'map' even if set, as the written docidx
+ # contains the symbolic references and only them.
+ # * aligned => newlines
+ # * indented => newlines
+
+ # Combinations of the format specific entries
+ # N I A |
+ # - - - + ---------------------
+ # 0 0 0 | Ultracompact (no whitespace, single line)
+ # 1 0 0 | Compact (no whitespace, multiple lines)
+ # 1 1 0 | Indented
+ # 1 0 1 | Tabular aligned references
+ # 1 1 1 | Indented + Tabular aligned references
+ # - - - + ---------------------
+ # 0 1 0 | Not possible, per the implications above.
+ # 0 0 1 | ditto
+ # 0 1 1 | ditto
+ # - - - + ---------------------
+
+ # Import the configuration and initialize the internal state
+ array set config {
+ newlines 0
+ aligned 0
+ indented 0
+ }
+ array set config $configuration
+ array set types {
+ manpage {manpage}
+ url {url }
+ }
+
+ # Force the implications mentioned in the notes above.
+ if {
+ $config(aligned) ||
+ $config(indented)
+ } {
+ set config(newlines) 1
+ }
+
+ # ### ### ### ######### ######### #########
+
+ # Phase II. Generate the output, taking the configuration into
+ # account.
+
+ TagsBegin
+
+ # First some comments about the provenance of the output.
+ Tag+ comment [list "Generated @ [clock format [clock seconds]]"]
+ Tag+ comment [list "By $config(user)"]
+ if {[info exists config(file)] && ($config(file) ne {})} {
+ Tag+ comment [list "From file $config(file)"]
+ }
+
+ # Unpack the serialization.
+ array set idx $serial
+ array set idx $idx(doctools::idx)
+ unset idx(doctools::idx)
+ array set r $idx(references)
+
+ # Now open the markup
+
+ Tag+ index_begin [list $idx(label) $idx(title)]
+
+ # Iterate over the keys and their references
+ foreach {keyword references} $idx(keywords) {
+ # Print the key
+ if {$config(indented)} {TagPrefix { }}
+ Tag+ key [list $keyword]
+
+ # Print the references in the key
+ if {$config(aligned)} { Align $references max }
+ if {$config(indented)} {TagPrefix { }}
+
+ # Iterate over the references
+ foreach id $references {
+ foreach {type label} $r($id) break
+ if {$config(aligned)} {
+ set id [FmtR max $id]
+ set type $types($type)
+ } else {
+ set id [list $id]
+ }
+ Tag+ $type $id [list $label]
+ }
+ }
+
+ # Close the index
+ TagPrefix {}
+ Tag+ index_end
+
+ # Last formatting, joining the commands together.
+ set sep [expr {$config(newlines) ? "\n" : ""}]
+ return [join $lines $sep]
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+
+proc TagPrefix {str} {
+ upvar 1 prefix prefix
+ set prefix $str
+ return
+}
+
+proc TagsBegin {} {
+ upvar 1 prefix prefix lines lines
+ set prefix {}
+ set lines {}
+ return
+}
+
+proc Tag {n args} {
+ upvar 1 prefix prefix
+ set cmd $prefix
+ append cmd \[$n
+ if {[llength $args]} { append cmd " [join $args]" }
+ append cmd \]
+ return $cmd
+}
+
+proc Tag+ {n args} {
+ upvar 1 prefix prefix lines lines
+ lappend lines [eval [linsert $args 0 Tag $n]]
+ return
+}
+
+proc Align {references mv} {
+ upvar 1 $mv max r r
+ # Generate a list of references sortable by name, and also find the
+ # max length of all relevant names.
+ set max 0
+ foreach id $references {
+ Max max [list $id]
+ }
+ return
+}
+
+proc Max {v str} {
+ upvar 1 $v max
+ set x [string length $str]
+ if {$x <= $max} return
+ set max $x
+ return
+}
+
+proc FmtR {v str} {
+ upvar 1 $v max
+ return [list $str][string repeat { } [expr {$max - [string length [list $str]]}]]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+package provide doctools::idx::export::docidx 0.1
+return
diff --git a/tcllib/modules/doctools2idx/export_docidx.test b/tcllib/modules/doctools2idx/export_docidx.test
new file mode 100644
index 0000000..84117c3
--- /dev/null
+++ b/tcllib/modules/doctools2idx/export_docidx.test
@@ -0,0 +1,77 @@
+# -*- tcl -*-
+# idx_export_docidx.test: tests for the doctools::idx::export::docidx package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export_docidx.test,v 1.1 2009/04/01 04:28:37 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ useLocal structure.tcl doctools::idx::structure
+}
+testing {
+ package provide doctools::idx::export::plugin 1
+ # The above fakes the export plugin environment.
+
+ useLocal export_docidx.tcl doctools::idx::export::docidx
+}
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-idx-export-docidx-1.0 {export, wrong#args} -body {
+ export
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-idx-export-docidx-1.1 {export, wrong#args} -body {
+ export S
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-idx-export-docidx-1.2 {export, wrong#args} -body {
+ export S C XXX
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+# -------------------------------------------------------------------------
+
+# Testing the generation of docidx output, from index serialization,
+# for all possible plugin configurations.
+
+foreach {k nl in al name} {
+ 0 0 0 0 ultracompact
+ 1 1 0 0 compact
+ 2 1 1 0 indented
+ 3 1 0 1 aligned
+ 4 1 1 1 indalign
+ 5 0 1 0 indented
+ 6 0 0 1 aligned
+ 7 0 1 1 indalign
+} {
+ TestFilesProcess $mytestdir ok serial docidx-$name -> n label input data expected {
+ test doctools-idx-export-docidx-2.$k.$n "doctools::idx::export::docidx, ${label}-$name, ok" -setup {
+ set configuration [list newlines $nl indented $in aligned $al user _dummy_]
+ } -body {
+ stripcomments [export $data $configuration]
+ } -cleanup {
+ unset configuration
+ } -result $expected
+ }
+}
+
+#----------------------------------------------------------------------
+unset n label input data expected
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2idx/export_html.tcl b/tcllib/modules/doctools2idx/export_html.tcl
new file mode 100644
index 0000000..37e8f19
--- /dev/null
+++ b/tcllib/modules/doctools2idx/export_html.tcl
@@ -0,0 +1,421 @@
+# text.tcl --
+#
+# The HTML export plugin. Generation of HTML markup.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: export_html.tcl,v 1.3 2009/08/07 18:53:11 andreas_kupries Exp $
+
+# This package is a plugin for the doctools::idx v2 system. It takes
+# the list serialization of a keyword index and produces text in HTML
+# format.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: doctools::idx::export::plugin
+
+package require Tcl 8.4
+package require doctools::idx::export::plugin ; # Presence of this
+ # pseudo package
+ # indicates execution
+ # inside of a properly
+ # initialized plugin
+ # interpreter.
+package require doctools::idx::structure ; # Verification that the
+ # input is proper.
+package require doctools::html
+package require doctools::html::cssdefaults
+
+doctools::html::import ;# -> ::html::*
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc export {serial configuration} {
+
+ # Phase I. Check that we got a canonical index serialization. That
+ # makes the unpacking easier, as we can mix it with the
+ # generation of the output, knowing that everything is
+ # already sorted as it should be.
+
+ ::doctools::idx::structure verify-as-canonical $serial
+
+ # ### ### ### ######### ######### #########
+ # Configuration ...
+ # * Standard entries
+ # - user = person running the application doing the formatting
+ # - format = name of this format
+ # - file = name of the file the index came from. Optional.
+ # - map = maps symbolic references to actual file path. Optional.
+
+ # * HTML specific entries
+ # - newlines = boolean. tags separated by eol markers
+ # - indented = boolean. tags indented per their nesting structure.
+ # //layout = string in { list, table }.
+ #
+ # - meta = HTML fragment for use within the document <meta> section.
+ # - header = HTML fragment used immediately after <body>
+ # - footer = HTML fragment used immediately before </body>
+ #
+ # - kwid = dictionary mapping keywords to link anchor names.
+ # <=> KeyWord IDentifier
+ #
+ # Notes
+ # * indented => newlines
+
+ # Import the configuration and initialize the internal state
+ #// layout list
+ array set config {
+ newlines 0
+ indented 0
+ meta {}
+ header {}
+ footer {}
+ kwid {}
+ map {}
+ sepline ------------------------------------------------------------
+ kwidth 35
+ dot {&#183;}
+ class.main doctools
+ class.header idx-header
+ class.title idx-title
+ class.navsep idx-navsep
+ class.navbar idx-kwnav
+ class.contents idx-contents
+ class.leader idx-leader
+ class.row0 idx-even
+ class.row1 idx-odd
+ class.keyword idx-keyword
+ class.refs idx-refs
+ class.footer idx-footer
+ }
+ array set config $configuration
+ array set map $config(map)
+ array set kwid $config(kwid)
+
+ if {($config(kwidth) < 1) || ($config(kwidth) > 99)} {
+ set config(kwidth) 35
+ }
+ set config(rwidth) [expr {100 - $config(kwidth)}]
+
+
+ # Force the implications mentioned in the notes above.
+ if {$config(indented)} {
+ set config(newlines) 1
+ }
+
+ # Allow structuring comments iff structure is present.
+ set config(comments) [expr {$config(indented) || $config(newlines)}]
+
+ array set anchor {}
+ set dot {&#183;}
+
+ # ### ### ### ######### ######### #########
+
+ # Phase II. Generate the output, taking the configuration into
+ # account.
+
+ # Unpack the serialization.
+ array set idx $serial
+ array set idx $idx(doctools::idx)
+ unset idx(doctools::idx)
+ array set r $idx(references)
+ array set k $idx(keywords)
+
+ html::begin
+ # Configure the layouting
+ if {!$config(indented)} { html::indenting 0 }
+ if {!$config(newlines)} { html::newlines 0 }
+
+ html::tag* html {
+ html::newline ; html::indented 4 {
+ Header
+ Provenance
+ Body
+ }
+ }
+
+ return [html::done]
+}
+
+# ### ### ### ######### ######### #########
+
+proc Header {} {
+ upvar 1 config config idx idx
+ html::tag* head {
+ html::newline ; html::indented 4 {
+ html::tag= title [Title] ; html::newline
+ if {![Extend meta]} {
+ html::tag* style {
+ DefaultStyle
+ } ; html::newline
+ }
+ }
+ } ; html::newline
+ return
+}
+
+proc Provenance {} {
+ upvar 1 config config
+ if {!$config(comments)} return
+ html::comment [html::collect {
+ html::indented 4 {
+ html::+ "Generated @ [clock format [clock seconds]]" ; html::newline
+ html::+ "By $config(user)" ; html::newline
+ if {[info exists config(file)] && ($config(file) ne {})} {
+ html::+ "From file $config(file)" ; html::newline
+ }
+ }
+ }] ; html::newline
+ return
+}
+
+proc Body {} {
+ upvar 1 config config idx idx dot dot anchor anchor kwid kwid k k r r
+ html::tag* body {
+ html::newline ; html::indented 4 {
+ html::tag* div class $config(class.main) {
+ html::newline ; html::indented 4 {
+ html::tag* div class $config(class.header) {
+ html::newline ; html::indented 4 {
+ BodyTitle
+ UserHeader
+ html::tag1 hr class $config(class.navsep) ; html::newline
+ NavigationBar
+ }
+ } ; html::newline
+ Keywords
+ html::tag* div class $config(class.footer) {
+ html::newline ; html::indented 4 {
+ html::tag1 hr class $config(class.navsep) ; html::newline
+ UserFooter
+ }
+ } ; html::newline
+ }
+ } ; html::newline
+ }
+ } ; html::newline
+ return
+}
+
+# ### ### ### ######### ######### #########
+
+proc BodyTitle {} {
+ upvar 1 idx idx config config
+ html::tag= h1 class $config(class.title) [Title] ; html::newline
+ return
+}
+
+proc UserHeader {} {
+ upvar 1 config config
+ Extend header
+ html::newline
+ return
+}
+
+proc UserFooter {} {
+ upvar 1 config config
+ Extend footer
+ html::newline
+ return
+}
+
+# ### ### ### ######### ######### #########
+
+proc Title {} {
+ upvar 1 idx(label) label idx(title) title
+ if {($label ne {}) && ($title ne {})} {
+ return "$label -- $title"
+ } elseif {$label ne {}} {
+ return $label
+ } elseif {$title ne {}} {
+ return $title
+ }
+ return -code error {Reached the unreachable}
+}
+
+proc DefaultStyle {} {
+ html::comment \n[doctools::html::cssdefaults::contents]
+ return
+}
+
+# ### ### ### ######### ######### #########
+
+proc NavigationBar {} {
+ upvar 1 config config idx idx anchor anchor kwid kwid char char
+
+ # No navigation bar for an empty index.
+
+ if {![llength $idx(keywords)]} return
+
+ # Name each keyword, if that was not done already. And sort them
+ # into bins based on their first character (always taken as upper
+ # case, i.e. X and x are the same).
+
+ foreach {keyword references} $idx(keywords) {
+ if {![info exists kwid($keyword)]} {
+ set kwid($keyword) KW-$keyword
+ }
+ lappend char([string toupper [string index $keyword 0]]) $keyword
+ }
+
+ # Now name each character
+
+ set counter 0
+ foreach c [lsort -dict [array names char]] {
+ set anchor($c) KEYWORDS-$c
+ incr counter
+ }
+
+ # Now we have the information we can construct the nav bar from.
+
+ # NOTE: Should I do this as ul/ ? Then the CSS can select the
+ # location of the navbar, its orientation, and how the elements
+ # are joined. Right ?!
+
+ Separator {Navigation Bar}
+ html::newline
+ set sep 0
+ html::tag* div class $config(class.navbar) {
+ html::newline ; html::indented 4 {
+ foreach c [lsort -dict [array names char]] {
+ if {$sep} {
+ html::++ " $config(dot)"
+ if {![html::newline]} { html::++ " " }
+ }
+ html::tag= a href #$anchor($c) $c
+ set sep 1
+ }
+ html::newline
+ }
+ } ; html::newline
+ return
+}
+
+proc Keywords {} {
+ upvar 1 config config idx idx anchor anchor dot dot kwid kwid char char k k r r
+
+ # No content for an empty index.
+
+ if {![llength $idx(keywords)]} return
+
+ # Process the characters and associated keywords.
+
+ set rows [list $config(class.row0) $config(class.row1)]
+
+ Separator Contents
+ html::newline
+ html::tag* table class $config(class.contents) width 100% {
+ html::newline ; html::indented 4 {
+ foreach c [lsort -dict [array names char]] {
+ Separator "($c)"
+ html::newline
+ Leader $c
+ foreach kw $char($c) {
+ Keyword $kw
+ }
+ }
+ Separator
+ html::newline
+ }
+ } ; html::newline
+ return
+}
+
+proc Leader {char} {
+ upvar 1 anchor anchor config config
+
+ html::tag* tr class $config(class.leader) {
+ html::tag* th colspan 2 {
+ html::tag= a name $anchor($char) "Keywords: $char"
+ }
+ } ; html::newline
+ return
+}
+
+proc Keyword {kw} {
+ upvar 1 config config rows rows kwid kwid k k r r
+
+ html::tag* tr class [Row] {
+ html::newline ; html::indented 4 {
+ html::tag* td width $config(kwidth)% class $config(class.keyword) {
+ html::tag= a name $kwid($kw) $kw
+ } ; html::newline
+ html::tag* td width $config(rwidth)% class $config(class.refs) {
+ if {[llength $k($kw)]} {
+ html::newline ; html::indented 4 {
+ References $kw
+ }
+ }
+ } ; html::newline
+ }
+ } ; html::newline
+ return
+}
+
+proc References {kw} {
+ upvar 1 config config k k r r
+ # Iterate over the references of the key
+ set sep 0
+ foreach id $k($kw) {
+ foreach {type label} $r($id) break
+ if {$sep} {
+ html::++ " $config(dot)"
+ if {![html::newline]} { html::++ " " }
+ }
+ html::tag= a href [Map $type $id] $label
+ set sep 1
+ }
+ html::newline
+ return
+}
+
+# ### ### ### ######### ######### #########
+
+proc Separator {{text {}}} {
+ upvar config config
+ if {!$config(comments)} return
+ set str $config(sepline)
+ if {$text ne {}} {
+ set new " $text "
+ set str [string replace $str 1 [string length $new] $new]
+ }
+ html::comment $str
+ return
+}
+
+proc Row {} {
+ upvar 1 rows rows
+ foreach {a b} $rows break
+ set rows [list $b $a]
+ return $a
+}
+
+proc Map {type id} {
+ if {$type eq "url"} { return $id }
+ upvar 1 map map
+ if {![info exists map($id)]} { return $id }
+ return $map($id)
+}
+
+proc Extend {varname} {
+ upvar 1 config config
+ if {$config($varname) eq {}} {
+ if {$config(comments)} {
+ html::comment "Customization Point: $varname"
+ }
+ return 0
+ }
+ html::+++ $config($varname)
+ return 1
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::idx::export::html 0.2
+return
diff --git a/tcllib/modules/doctools2idx/export_html.test b/tcllib/modules/doctools2idx/export_html.test
new file mode 100644
index 0000000..857ba5b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/export_html.test
@@ -0,0 +1,76 @@
+# -*- tcl -*-
+# idx_export_html.test: tests for the doctools::idx::export::html package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export_html.test,v 1.1 2009/04/01 04:28:37 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ useLocal structure.tcl doctools::idx::structure
+ use doctools2base/text.tcl doctools::text
+ use doctools2base/html.tcl doctools::html
+ use doctools2base/html_cssdefaults.tcl doctools::html::cssdefaults
+}
+testing {
+ package provide doctools::idx::export::plugin 1
+ # The above fakes the export plugin environment.
+
+ useLocal export_html.tcl doctools::idx::export::html
+}
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-idx-export-html-1.0 {export, wrong#args} -body {
+ export
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-idx-export-html-1.1 {export, wrong#args} -body {
+ export S
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-idx-export-html-1.2 {export, wrong#args} -body {
+ export S C XXX
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+# -------------------------------------------------------------------------
+
+# Testing the generation of html output, from index serialization,
+# for all possible plugin configurations.
+
+foreach {k nl in section} {
+ 0 0 0 -ultracompact
+ 1 0 1 -indented
+ 2 1 0 -compact
+ 3 1 1 -indented
+} {
+ TestFilesProcess $mytestdir ok serial html$section -> n label input data expected {
+ test doctools-idx-export-html-2.$k.$n "doctools::idx::export::html, $label$section, ok" -setup {
+ set configuration [list newlines $nl indented $in user _dummy_]
+ } -body {
+ striphtmlcomments [export $data $configuration] 3
+ } -cleanup {
+ unset configuration
+ } -result $expected
+ }
+}
+
+#----------------------------------------------------------------------
+unset n label input data expected
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2idx/export_json.tcl b/tcllib/modules/doctools2idx/export_json.tcl
new file mode 100644
index 0000000..1c0bfb6
--- /dev/null
+++ b/tcllib/modules/doctools2idx/export_json.tcl
@@ -0,0 +1,214 @@
+# json.tcl --
+#
+# The JSON export plugin. Generation of Java Script Object Notation.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: export_json.tcl,v 1.2 2009/08/07 18:53:11 andreas_kupries Exp $
+
+# This package is a plugin for the doctools::idx v2 system. It takes
+# the list serialization of a keyword index and produces text in JSON
+# format.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: doctools::idx::export::plugin
+
+package require Tcl 8.4
+package require doctools::idx::export::plugin ; # Presence of this
+ # pseudo package
+ # indicates execution
+ # inside of a properly
+ # initialized plugin
+ # interpreter.
+package require doctools::idx::structure ; # Verification that
+ # the input is proper.
+package require textutil::adjust
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc export {serial configuration} {
+
+ # Phase I. Check that we got a canonical index serialization. That
+ # makes the unpacking easier, as we can mix it with the
+ # generation of the output, knowing that everything is
+ # already sorted as it should be.
+
+ ::doctools::idx::structure verify-as-canonical $serial
+
+ # ### ### ### ######### ######### #########
+ # Configuration ...
+ # * Standard entries
+ # - user = person running the application doing the formatting
+ # - format = name of this format
+ # - file = name of the file the index came from. Optional.
+ # - map = maps symbolic references to actual file path. Optional.
+ # * json/format specific entries
+ # - indented = boolean. objects indented per the index structure.
+ # - aligned = boolean. object keys tabular aligned vertically.
+ #
+ # Notes
+ # * This format ignores 'map' even if set, as the written json
+ # contains the symbolic references and only them.
+ # * aligned => indented
+
+ # Combinations of the format specific entries
+ # N I A |
+ # - - - + ---------------------
+ # 0 0 0 | Ultracompact (no whitespace, single line)
+ # 1 0 0 | Compact (no whitespace, multiple lines)
+ # 1 1 0 | Indented
+ # 1 0 1 | Tabular aligned references
+ # 1 1 1 | Indented + Tabular aligned references
+ # - - - + ---------------------
+ # 0 1 0 | Not possible, per the implications above.
+ # 0 0 1 | ditto
+ # 0 1 1 | ditto
+ # - - - + ---------------------
+
+ # Import the configuration and initialize the internal state
+ array set config {
+ indented 0
+ aligned 0
+ }
+ array set config $configuration
+
+ # Force the implications mentioned in the notes above.
+ if {$config(aligned)} {
+ set config(indented) 1
+ }
+
+ # ### ### ### ######### ######### #########
+
+ # Phase II. Generate the output, taking the configuration into
+ # account. We construct this from the inside out.
+
+ # Unpack the serialization.
+ array set idx $serial
+ array set idx $idx(doctools::idx)
+ unset idx(doctools::idx)
+
+ set keywords {}
+ foreach {kw references} $idx(keywords) {
+ set tmp {}
+ foreach id $references { lappend tmp [JsonString $id] }
+ lappend keywords $kw [JsonArrayList $tmp]
+ }
+
+ if {$config(aligned)} { set max 9 }
+
+ set references {}
+ foreach {id decl} $idx(references) {
+ foreach {type label} $decl break
+ set type [JsonString $type]
+ set label [JsonString $label]
+ if {$config(aligned)} {
+ set type [FmtR max $type]
+ }
+ lappend references $id [JsonArray $type $label]
+ }
+
+ return [JsonObject doctools::idx \
+ [JsonObject \
+ label [JsonString $idx(label)] \
+ keywords [JsonObjectDict $keywords] \
+ references [JsonObjectDict $references] \
+ title [JsonString $idx(title)]]]
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+
+proc JsonQuotes {} {
+ return [list "\"" "\\\"" / \\/ \\ \\\\ \b \\b \f \\f \n \\n \r \\r \t \\t]
+}
+
+proc JsonString {s} {
+ return "\"[string map [JsonQuotes] $s]\""
+}
+
+proc JsonArray {args} {
+ upvar 1 config config
+ return [JsonArrayList $args]
+}
+
+proc JsonArrayList {list} {
+ # compact form.
+ return "\[[join $list ,]\]"
+}
+
+proc JsonObject {args} {
+ upvar 1 config config
+ return [JsonObjectDict $args]
+}
+
+proc JsonObjectDict {dict} {
+ # The dict maps string keys to json-formatted data. I.e. we have
+ # to quote the keys, but not the values, as the latter are already
+ # in the proper format.
+ upvar 1 config config
+
+ set tmp {}
+ foreach {k v} $dict { lappend tmp [JsonString $k] $v }
+ set dict $tmp
+
+ if {$config(aligned)} { Align $dict max }
+
+ if {$config(indented)} {
+ set content {}
+ foreach {k v} $dict {
+ if {$config(aligned)} { set k [FmtR max $k] }
+ if {[string match *\n* $v]} {
+ # multi-line value
+ lappend content " $k : [textutil::adjust::indent $v { } 1]"
+ } else {
+ # single line value.
+ lappend content " $k : $v"
+ }
+ }
+ if {[llength $content]} {
+ return "\{\n[join $content ,\n]\n\}"
+ } else {
+ return "\{\}"
+ }
+ } else {
+ # ultra compact form.
+ set tmp {}
+ foreach {k v} $dict { lappend tmp "$k:$v" }
+ return "\{[join $tmp ,]\}"
+ }
+}
+
+proc Align {dict mv} {
+ upvar 1 $mv max
+ # Generate a list of references sortable by name, and also find the
+ # max length of all relevant names.
+ set max 0
+ foreach {str _} $dict { Max max $str }
+ return
+}
+
+proc Max {v str} {
+ upvar 1 $v max
+ set x [string length $str]
+ if {$x <= $max} return
+ set max $x
+ return
+}
+
+proc FmtR {v str} {
+ upvar 1 $v max
+ return $str[string repeat { } [expr {$max - [string length $str]}]]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::idx::export::json 0.1
+return
diff --git a/tcllib/modules/doctools2idx/export_json.test b/tcllib/modules/doctools2idx/export_json.test
new file mode 100644
index 0000000..73982af
--- /dev/null
+++ b/tcllib/modules/doctools2idx/export_json.test
@@ -0,0 +1,74 @@
+# -*- tcl -*-
+# idx_export_json.test: tests for the doctools::idx::export::json package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export_json.test,v 1.1 2009/04/01 04:28:37 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+ useLocal structure.tcl doctools::idx::structure
+}
+testing {
+ package provide doctools::idx::export::plugin 1
+ # The above fakes the export plugin environment.
+
+ useLocal export_json.tcl doctools::idx::export::json
+}
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-idx-export-json-1.0 {export, wrong#args} -body {
+ export
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-idx-export-json-1.1 {export, wrong#args} -body {
+ export S
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-idx-export-json-1.2 {export, wrong#args} -body {
+ export S C XXX
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+# -------------------------------------------------------------------------
+
+# Testing the generation of json output, from index serialization,
+# for all possible plugin configurations.
+
+foreach {k in al section} {
+ 0 0 0 -ultracompact
+ 1 1 0 -indented
+ 2 0 1 -indalign
+ 3 1 1 -indalign
+} {
+ TestFilesProcess $mytestdir ok serial json$section -> n label input data expected {
+ test doctools-idx-export-json-2.$k.$n "doctools::idx::export::json, $label$section, ok" -setup {
+ set configuration [list indented $in aligned $al]
+ } -body {
+ export $data $configuration
+ } -cleanup {
+ unset configuration
+ } -result $expected
+ }
+}
+
+#----------------------------------------------------------------------
+unset n label input data expected
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2idx/export_nroff.tcl b/tcllib/modules/doctools2idx/export_nroff.tcl
new file mode 100644
index 0000000..8ee559a
--- /dev/null
+++ b/tcllib/modules/doctools2idx/export_nroff.tcl
@@ -0,0 +1,213 @@
+# text.tcl --
+#
+# The NROFF export plugin. Generation of man.macros based nroff markup.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: export_nroff.tcl,v 1.4 2009/08/07 18:53:11 andreas_kupries Exp $
+
+# This package is a plugin for the doctools::idx v2 system. It takes
+# the list serialization of a keyword index and produces text in nroff
+# format, man.macros based.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: doctools::idx::export::plugin
+
+package require Tcl 8.4
+package require doctools::idx::export::plugin ; # Presence of this
+ # pseudo package
+ # indicates execution
+ # inside of a properly
+ # initialized plugin
+ # interpreter.
+package require doctools::idx::structure ; # Verification that the
+ # input is proper.
+package require doctools::text ; # Text assembly package
+package require doctools::nroff::man_macros ; # Macro definitions for result.
+
+doctools::text::import ;# -> ::text::*
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc export {serial configuration} {
+
+ # Phase I. Check that we got a canonical index serialization. That
+ # makes the unpacking easier, as we can mix it with the
+ # generation of the output, knowing that everything is
+ # already sorted as it should be.
+
+ ::doctools::idx::structure verify-as-canonical $serial
+
+ # ### ### ### ######### ######### #########
+ # Configuration ...
+ # * Standard entries
+ # - user = person running the application doing the formatting
+ # - format = name of this format
+ # - file = name of the file the index came from. Optional.
+ # - map = maps symbolic references to actual file path. Ignored
+ #
+ # Specific
+ # - inline = boolean. if set (default) man.macros is inlined in
+ # the output. other a .so reference to the file is
+ # generated.
+
+ # Import the configuration and initialize the internal state
+
+ array set config {
+ inline 1
+ }
+ array set config $configuration
+
+ # ### ### ### ######### ######### #########
+
+ # Phase II. Generate the output, taking the configuration into
+ # account.
+
+ # Unpack the serialization.
+ array set idx $serial
+ array set idx $idx(doctools::idx)
+ unset idx(doctools::idx)
+ array set r $idx(references)
+
+ text::begin
+ text::indenting 0 ; # Just in case someone tries to.
+
+ Provenance
+ if {$config(inline)} {
+ text::newline?
+ text::+ [doctools::nroff::man_macros::contents]
+ } else {
+ .so man.macros
+ }
+ .TH $idx(label)
+ .SH index
+ if {$idx(title) ne {}} {
+ text::+ $idx(title)
+ }
+ .RS
+
+ # Iterate over the keys and their references
+ foreach {keyword references} $idx(keywords) {
+ # Print the key
+ text::+ $keyword
+ text::newline
+ # Iterate over the references
+ .RS
+ foreach id $references {
+ foreach {type label} $r($id) break
+ .TP [BOLD $id]
+ text::newline
+ text::+ $label
+ text::newline
+ }
+ .RE
+ if {[llength $references]} {
+ .PP
+ }
+ }
+
+ return [text::done]
+}
+
+# ### ### ### ######### ######### #########
+
+proc Provenance {} {
+ upvar 1 config config
+ COMMENT "Generated @ [clock format [clock seconds]]"
+ COMMENT "By $config(user)"
+ if {[info exists config(file)] && ($config(file) ne {})} {
+ COMMENT "From file $config(file)"
+ }
+ return
+}
+
+proc .so {file} {
+ text::newline?
+ text::+ ".so $file"
+ text::newline
+ return
+}
+
+proc .TP {text} {
+ text::newline?
+ text::+ .TP
+ text::newline
+ text::+ $text
+ return
+}
+
+proc COMMENT {text} {
+ set pfx "'\\\" " ;#
+ text::newline?
+
+ foreach line [split $text \n] {
+ text::+ $pfx
+ text::+ $line
+ text::newline
+ }
+ #text::+ $pfx[join [split $text \n] \n$pfx]
+ return
+}
+
+proc BOLD {text} {
+ return \\fB$text\\fR
+}
+
+proc .RS {} {
+ text::newline?
+ text::+ .RS
+ text::newline
+ return
+}
+
+proc .RE {} {
+ text::newline?
+ text::+ .RE
+ text::newline
+ return
+}
+
+proc .PP {} {
+ text::newline?
+ text::+ .PP
+ text::newline
+ return
+}
+
+proc .SH {name} {
+ text::newline?
+ text::+ ".SH "
+ set hasspaces [regexp {[ ]} $name]
+ set name [string toupper $name]
+
+ if {$hasspaces} { text::+ \" }
+ text::+ $name
+ if {$hasspaces} { text::+ \" }
+ text::newline
+ return
+}
+
+proc .TH {name} {
+ text::newline?
+ text::+ ".TH "
+ set hasspaces [regexp {[ ]} $name]
+ set name [string toupper $name]
+
+ if {$hasspaces} { text::+ \" }
+ text::+ $name
+ if {$hasspaces} { text::+ \" }
+ text::newline
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::idx::export::nroff 0.3
+return
diff --git a/tcllib/modules/doctools2idx/export_nroff.test b/tcllib/modules/doctools2idx/export_nroff.test
new file mode 100644
index 0000000..63645dd
--- /dev/null
+++ b/tcllib/modules/doctools2idx/export_nroff.test
@@ -0,0 +1,73 @@
+# -*- tcl -*-
+# idx_export_nroff.test: tests for the doctools::idx::export::nroff package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export_nroff.test,v 1.2 2009/04/29 02:10:34 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ useLocal structure.tcl doctools::idx::structure
+ use doctools2base/text.tcl doctools::text
+ use doctools2base/nroff_manmacros.tcl doctools::nroff::man_macros
+}
+testing {
+ package provide doctools::idx::export::plugin 1
+ # The above fakes the export plugin environment.
+
+ useLocal export_nroff.tcl doctools::idx::export::nroff
+}
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-idx-export-nroff-1.0 {export, wrong#args} -body {
+ export
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-idx-export-nroff-1.1 {export, wrong#args} -body {
+ export S
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-idx-export-nroff-1.2 {export, wrong#args} -body {
+ export S C XXX
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+# -------------------------------------------------------------------------
+
+# Testing the generation of nroff output, from index serialization,
+# for all possible plugin configurations.
+
+foreach {k inline section} {
+ 0 0 -external
+ 1 1 -inlined
+} {
+ TestFilesProcess $mytestdir ok serial nroff$section -> n label input data expected {
+ test doctools-idx-export-nroff-2.$k.$n "doctools::idx::export::nroff, $label$section, ok" -setup {
+ set configuration [list inline $inline user _dummy_]
+ } -body {
+ stripnroffcomments [stripmanmacros [export $data $configuration]]
+ } -cleanup {
+ unset configuration
+ } -result $expected
+ }
+}
+
+#----------------------------------------------------------------------
+unset n label input data expected
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2idx/export_text.tcl b/tcllib/modules/doctools2idx/export_text.tcl
new file mode 100644
index 0000000..4880f95
--- /dev/null
+++ b/tcllib/modules/doctools2idx/export_text.tcl
@@ -0,0 +1,136 @@
+# text.tcl --
+#
+# The text export plugin. Generation of plain text (ReST -
+# re-structured text).
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: export_text.tcl,v 1.3 2009/08/07 18:53:11 andreas_kupries Exp $
+
+# This package is a plugin for the the doctools::idx v2 system. It
+# takes the list serialization of a keyword index and produces text in
+# text format.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: doctools::idx::export::plugin
+
+package require Tcl 8.4
+package require doctools::idx::export::plugin ; # Presence of this
+ # pseudo package
+ # indicates execution
+ # inside of a properly
+ # initialized plugin
+ # interpreter.
+package require doctools::idx::structure ; # Verification that the
+ # input is proper.
+package require doctools::text ; # Text assembly package
+
+doctools::text::import ;# -> ::text::*
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc export {serial configuration} {
+
+ # Phase I. Check that we got a canonical index serialization. That
+ # makes the unpacking easier, as we can mix it with the
+ # generation of the output, knowing that everything is
+ # already sorted as it should be.
+
+ ::doctools::idx::structure verify-as-canonical $serial
+
+ # ### ### ### ######### ######### #########
+ # Configuration ...
+ # * Standard entries
+ # - user = person running the application doing the formatting
+ # - format = name of this format
+ # - file = name of the file the index came from. Optional.
+ # - map = maps symbolic references to actual file path. Optional.
+
+ # //possible parameters to influence the output.
+ # //* symbolic mapping off/on
+
+ # Import the configuration and initialize the internal state
+
+ array set config $configuration
+ array set map {}
+ if {[info exists config(map)]} {
+ array set map $config(map)
+ }
+
+ # ### ### ### ######### ######### #########
+
+ # Phase II. Generate the output, taking the configuration into
+ # account.
+
+ # Unpack the serialization.
+ array set idx $serial
+ array set idx $idx(doctools::idx)
+ unset idx(doctools::idx)
+ array set r $idx(references)
+
+ text::begin
+ text::+ [Header]
+ text::underline =
+
+ # Iterate over the keys and their references
+ foreach {keyword references} $idx(keywords) {
+ # Print the key
+ text::newline
+ text::+ $keyword
+ text::underline -
+
+ # Print the references in the key
+ set tmp {}
+ foreach id $references { lappend tmp [lindex $r($id) end] }
+ text::field lwidth $tmp
+ unset tmp
+
+ # Iterate over the references
+ foreach id $references {
+ foreach {type label} $r($id) break
+ text::indented 4 {
+ # maybe special field/tabulation commands.
+ text::+ [text::left lwidth $label]
+ text::+ { }
+ text::+ ([Map $type $id])
+ text::newline
+ }
+ }
+ }
+
+ # Return final assembled text
+ return [text::done]
+}
+
+# ### ### ### ######### ######### #########
+
+proc Header {} {
+ upvar 1 idx(label) label idx(title) title
+ if {($label ne {}) && ($title ne {})} {
+ return "$label -- $title"
+ } elseif {$label ne {}} {
+ return $label
+ } elseif {$title ne {}} {
+ return $title
+ }
+ return -code error {Reached the unreachable}
+}
+
+proc Map {type id} {
+ if {$type eq "url"} { return $id }
+ upvar 1 map map
+ if {![info exists map($id)]} { return $id }
+ return $map($id)
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::idx::export::text 0.2
+return
diff --git a/tcllib/modules/doctools2idx/export_text.test b/tcllib/modules/doctools2idx/export_text.test
new file mode 100644
index 0000000..821e54b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/export_text.test
@@ -0,0 +1,63 @@
+# -*- tcl -*-
+# idx_export_text.test: tests for the doctools::idx::export::text package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export_text.test,v 1.1 2009/04/01 04:28:37 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ useLocal structure.tcl doctools::idx::structure
+ use doctools2base/text.tcl doctools::text
+}
+testing {
+ package provide doctools::idx::export::plugin 1
+ # The above fakes the export plugin environment.
+
+ useLocal export_text.tcl doctools::idx::export::text
+}
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-idx-export-text-1.0 {export, wrong#args} -body {
+ export
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-idx-export-text-1.1 {export, wrong#args} -body {
+ export S
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-idx-export-text-1.2 {export, wrong#args} -body {
+ export S C XXX
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+# -------------------------------------------------------------------------
+
+# Testing the generation of text output, from index serialization,
+# for all possible plugin configurations.
+
+TestFilesProcess $mytestdir ok serial text -> n label input data expected {
+ test doctools-idx-export-text-2.$n "doctools::idx::export::text, $label, ok" -body {
+ export $data {}
+ } -result $expected
+}
+
+#----------------------------------------------------------------------
+unset n label input data expected
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2idx/export_wiki.tcl b/tcllib/modules/doctools2idx/export_wiki.tcl
new file mode 100644
index 0000000..6334eda
--- /dev/null
+++ b/tcllib/modules/doctools2idx/export_wiki.tcl
@@ -0,0 +1,163 @@
+# text.tcl --
+#
+# The wiki export plugin. Generation of plain text, ready for
+# use by the Tcler' Wiki
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: export_wiki.tcl,v 1.3 2009/08/07 18:53:11 andreas_kupries Exp $
+
+# This package is a plugin for the the doctools::idx v2 system. It
+# takes the list serialization of a keyword index and produces text in
+# text format.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: doctools::idx::export::plugin
+
+package require Tcl 8.4
+package require doctools::idx::export::plugin ; # Presence of this
+ # pseudo package
+ # indicates execution
+ # inside of a properly
+ # initialized plugin
+ # interpreter.
+package require doctools::idx::structure ; # Verification that the
+ # input is proper.
+package require doctools::text ; # Text assembly package
+
+doctools::text::import ;# -> ::text
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc export {serial configuration} {
+
+ # Phase I. Check that we got a canonical index serialization. That
+ # makes the unpacking easier, as we can mix it with the
+ # generation of the output, knowing that everything is
+ # already sorted as it should be.
+
+ ::doctools::idx::structure verify-as-canonical $serial
+
+ # ### ### ### ######### ######### #########
+ # Configuration ...
+ # * Standard entries
+ # - user = person running the application doing the formatting
+ # - format = name of this format
+ # - file = name of the file the index came from. Optional.
+ # - map = maps symbolic references to actual file path. Optional.
+
+ # Format specific
+ # - style = string in { list, table }, list default.
+
+
+ # //possible parameters to influence the output.
+ # //* symbolic mapping off/on
+
+ # Import the configuration and initialize the internal state
+
+ array set config {
+ style list
+ }
+ array set config $configuration
+ array set map {}
+ if {[info exists config(map)]} {
+ array set map $config(map)
+ }
+
+ # ### ### ### ######### ######### #########
+
+ # Phase II. Generate the output, taking the configuration into
+ # account.
+
+ # Unpack the serialization.
+ array set idx $serial
+ array set idx $idx(doctools::idx)
+ unset idx(doctools::idx)
+ array set r $idx(references)
+
+ # FUTURE :: Create wiki package on top of the text generator,
+ # providing encapsulated wiki commands.
+
+ text::begin
+ text::+ "**[Header]**"
+ text::newline 2
+
+ switch -exact -- $config(style) {
+ list {
+ text::+ <<TOC>>
+ text::newline 2
+
+ # Iterate over the keys and their references
+ foreach {keyword references} $idx(keywords) {
+ text::+ "***$keyword***"
+ text::newline
+
+ text::indented 3 {
+ # Iterate over the references
+ foreach id $references {
+ text::+ "* [FormatReference $id]"
+ text::newline
+ }
+ }
+ if {[llength $references]} {
+ text::newline
+ }
+ }
+ }
+ table {
+ foreach {keyword references} $idx(keywords) {
+ text::+ "%|'''$keyword'''| |%"
+ text::newline
+ foreach id $references {
+ text::+ "&| | [FormatReference $id] |&"
+ text::newline
+ }
+ }
+ }
+ default {
+ return -code error "bad style \"$style\""
+ }
+ }
+
+ # Last formatting, joining the lines together.
+ return [text::done]
+}
+
+# ### ### ### ######### ######### #########
+
+proc FormatReference {id} {
+ upvar 1 r r map map
+ foreach {type label} $r($id) break
+ return "\[[Map $type $id]%|%$label\]"
+}
+
+proc Header {} {
+ upvar 1 idx(label) label idx(title) title
+ if {($label ne {}) && ($title ne {})} {
+ return "$label -- $title"
+ } elseif {$label ne {}} {
+ return $label
+ } elseif {$title ne {}} {
+ return $title
+ }
+ return -code error {Reached the unreachable}
+}
+
+proc Map {type id} {
+ if {$type eq "url"} { return $id }
+ upvar 1 map map
+ if {![info exists map($id)]} { return $id }
+ return $map($id)
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::idx::export::wiki 0.2
+return
diff --git a/tcllib/modules/doctools2idx/export_wiki.test b/tcllib/modules/doctools2idx/export_wiki.test
new file mode 100644
index 0000000..a728145
--- /dev/null
+++ b/tcllib/modules/doctools2idx/export_wiki.test
@@ -0,0 +1,72 @@
+# -*- tcl -*-
+# idx_export_wiki.test: tests for the doctools::idx::export::wiki package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export_wiki.test,v 1.1 2009/04/01 04:28:37 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ useLocal structure.tcl doctools::idx::structure
+ use doctools2base/text.tcl doctools::text
+}
+testing {
+ package provide doctools::idx::export::plugin 1
+ # The above fakes the export plugin environment.
+
+ useLocal export_wiki.tcl doctools::idx::export::wiki
+}
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-idx-export-wiki-1.0 {export, wrong#args} -body {
+ export
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-idx-export-wiki-1.1 {export, wrong#args} -body {
+ export S
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-idx-export-wiki-1.2 {export, wrong#args} -body {
+ export S C XXX
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+# -------------------------------------------------------------------------
+
+# Testing the generation of wiki output, from index serialization,
+# for all possible plugin configurations.
+
+foreach {k style section} {
+ 0 list -list
+ 1 table -table
+} {
+ TestFilesProcess $mytestdir ok serial wiki$section -> n label input data expected {
+ test doctools-idx-export-wiki-2.$k.$n "doctools::idx::export::wiki, $label$section, ok" -setup {
+ set configuration [list style $style]
+ } -body {
+ export $data $configuration
+ } -cleanup {
+ unset configuration
+ } -result $expected
+ }
+}
+
+#----------------------------------------------------------------------
+unset n label input data expected
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2idx/idx_container.man b/tcllib/modules/doctools2idx/idx_container.man
new file mode 100644
index 0000000..ff74974
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_container.man
@@ -0,0 +1,296 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::idx n 2]
+[keywords conversion]
+[keywords {docidx markup}]
+[keywords documentation]
+[keywords formatting]
+[keywords generation]
+[keywords HTML]
+[keywords index]
+[keywords json]
+[keywords {keyword index}]
+[keywords latex]
+[keywords manpage]
+[keywords markup]
+[keywords nroff]
+[keywords parsing]
+[keywords plugin]
+[keywords reference]
+[keywords {tcler's wiki}]
+[keywords text]
+[keywords TMML]
+[keywords url]
+[keywords wiki]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Holding keyword indices}]
+[category {Documentation tools}]
+[require doctools::idx [opt 2]]
+[require Tcl 8.4]
+[require doctools::idx::structure]
+[require snit]
+[description]
+
+This package provides a class to contain and programmatically
+manipulate keyword indices
+
+[para]
+
+This is one of the three public pillars the management of keyword
+indices resides on. The other two pillars are
+
+[list_begin enum]
+[enum] [manpage {Exporting keyword indices}], and
+[enum] [manpage {Importing keyword indices}]
+[list_end]
+
+[para]
+
+For information about the [sectref Concepts] of keyword indices, and
+their parts, see the same-named section.
+
+For information about the data structure which is used to encode
+keyword indices as values see the section
+[sectref {Keyword index serialization format}].
+
+This is the only format directly known to this class. Conversions from
+and to any other format are handled by export and import manager
+objects. These may be attached to a container, but do not have to be,
+it is merely a convenience.
+
+[section Concepts] [include include/concept.inc]
+
+[section API]
+[subsection {Package commands}]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::idx] [arg objectName]]
+
+This command creates a new container object with an associated Tcl
+command whose name is [arg objectName]. This [term object] command is
+explained in full detail in the sections [sectref {Object command}]
+and [sectref {Object methods}]. The object command will be created
+under the current namespace if the [arg objectName] is not fully
+qualified, and in the specified namespace otherwise.
+
+[list_end]
+
+[subsection {Object command}]
+
+All objects created by the [cmd ::doctools::idx] command have the
+following general form:
+
+[list_begin definitions]
+
+[call [cmd objectName] [method method] [opt [arg "arg arg ..."]]]
+
+The method [method method] and its [arg arg]'uments determine the
+exact behavior of the command.
+
+See section [sectref {Object methods}] for the detailed
+specifications.
+
+[list_end]
+
+[subsection {Object methods}]
+
+[list_begin definitions]
+
+[call [arg objectName] [method destroy]]
+
+This method destroys the object it is invoked for.
+
+[call [arg objectName] [method {key add}] [arg name]]
+
+This method adds the keyword [arg name] to the index. If the keyword
+is already known nothing is done. The result of the method is the
+empty string.
+
+[call [arg objectName] [method {key remove}] [arg name]]
+
+This method removes the keyword [arg name] from the index. If the
+keyword is already gone nothing is done. Any references for whom this
+keyword was the last association are removed as well. The result of
+the method is the empty string.
+
+[call [arg objectName] [method {key references}] [arg name]]
+
+This method returns a list containing the names of all references
+associated with the keyword [arg name]. An error is thrown in the
+keyword is not known to the index. The order of the references in the
+list is undefined.
+
+[call [arg objectName] [method keys]]
+
+This method returns a list containing the names of all keywords known
+to the index. The order of the keywords in the list is undefined.
+
+[call [arg objectName] [method {reference add}] [arg type] [arg key] [arg name] [arg label]]
+
+This method adds the reference [arg name] to the index and associates
+it with the keyword [arg key].
+
+The other two arguments hold the [arg type] and [arg label] of the
+reference, respectively.
+
+The type has to match the stored information, should the reference
+exist already, i.e. this information is immutable after the reference
+is known. The only way to change it is delete and recreate the
+reference.
+
+The label on the other hand is automatically updated to the value of
+the argument, overwriting any previously stored information.
+
+Should the reference exists already it is simply associated with the
+[arg key]. If that is true already as well nothing is done, but the
+[arg label] updated to the new value. The result of the method is the
+empty string.
+
+[para]
+
+The [arg type] argument has be to one of [const manpage] or [const url].
+
+[call [arg objectName] [method {reference remove}] [arg name]]
+
+The reference [arg name] is removed from the index. All associations
+with keywords are released and the relevant reference labels removed.
+The result of the method is the empty string.
+
+[call [arg objectName] [method {reference label}] [arg name]]
+
+This method returns the label associated with the reference
+[arg name]. An error is thrown if the reference is not known.
+
+[call [arg objectName] [method {reference keys}] [arg name]]
+
+This method returns a list containing the names of all keywords
+associated with the reference [arg name]. An error is thrown in the
+reference is not known to the index. The order of the keywords in the
+list is undefined.
+
+[call [arg objectName] [method {reference type}] [arg name]]
+
+This method returns the type of the reference [arg name]. An error is
+thrown in the reference is not known to the index.
+
+[call [arg objectName] [method references]]
+
+This method returns a list containing the names of all references
+known to the index. The order of the references in the list is
+undefined.
+
+[call [arg objectName] [method title]]
+
+Returns the currently defined title of the keyword index.
+
+[call [arg objectName] [method title] [arg text]]
+
+Sets the title of the keyword index to [arg text], and returns it as
+the result of the command.
+
+[call [arg objectName] [method label]]
+
+Returns the currently defined label of the keyword index.
+
+[call [arg objectName] [method label] [arg text]]
+
+Sets the label of the keyword index to [arg text], and returns it as
+the result of the command.
+
+[call [arg objectName] [method importer]]
+
+Returns the import manager object currently attached to the container,
+if any.
+
+[call [arg objectName] [method importer] [arg object]]
+
+Attaches the [arg object] as import manager to the container, and
+returns it as the result of the command.
+
+Note that the [arg object] is [emph not] put into ownership of the
+container. I.e., destruction of the container will [emph not] destroy
+the [arg object].
+
+[para]
+
+It is expected that [arg object] provides a method named
+[method {import text}] which takes a text and a format name, and
+returns the canonical serialization of the keyword index contained in
+the text, assuming the given format.
+
+[call [arg objectName] [method exporter]]
+
+Returns the export manager object currently attached to the container,
+if any.
+
+[call [arg objectName] [method exporter] [arg object]]
+
+Attaches the [arg object] as export manager to the container, and
+returns it as the result of the command.
+
+Note that the [arg object] is [emph not] put into ownership of the
+container. I.e., destruction of the container will [emph not] destroy
+the [arg object].
+
+[para]
+
+It is expected that [arg object] provides a method named
+[method {export object}] which takes the container and a format name,
+and returns a text encoding keyword index stored in the container, in
+the given format. It is further expected that the [arg object] will
+use the container's method [method serialize] to obtain the
+serialization of the keyword index from which to generate the text.
+
+[call [arg objectName] [method {deserialize =}] [arg data] [opt [arg format]]]
+
+This method replaces the contents of the index object with the index
+contained in the [arg data]. If no [arg format] was specified it is
+assumed to be the regular serialization of a keyword index.
+
+[para]
+
+Otherwise the object will use the attached import manager to convert
+the data from the specified format to a serialization it can handle.
+
+In that case an error will be thrown if the container has no import
+manager attached to it.
+
+[para]
+
+The result of the method is the empty string.
+
+[call [arg objectName] [method {deserialize +=}] [arg data] [opt [arg format]]]
+
+This method behaves like [method {deserialize =}] in its essentials,
+except that it merges the keyword index in the [arg data] to its
+contents instead of replacing it.
+
+The method will throw an error if merging is not possible, i.e. would
+produce an invalid index. The existing content is left unchanged in
+that case.
+
+[para]
+
+The result of the method is the empty string.
+
+[call [arg objectName] [method serialize] [opt [arg format]]]
+
+This method returns the keyword index contained in the object. If no
+[arg format] is not specified the returned result is the canonical
+serialization of its contents.
+
+[para]
+
+Otherwise the object will use the attached export manager to convert
+the data to the specified format.
+
+In that case an error will be thrown if the container has no export
+manager attached to it.
+
+[list_end]
+
+[include include/serialization.inc]
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2idx/idx_export.man b/tcllib/modules/doctools2idx/idx_export.man
new file mode 100644
index 0000000..f16b73e
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_export.man
@@ -0,0 +1,308 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::idx::export n 0.1]
+[keywords conversion]
+[keywords docidx]
+[keywords documentation]
+[keywords export]
+[keywords formatting]
+[keywords generation]
+[keywords HTML]
+[keywords index]
+[keywords json]
+[keywords {keyword index}]
+[keywords manpage]
+[keywords markup]
+[keywords nroff]
+[keywords plugin]
+[keywords reference]
+[keywords {tcler's wiki}]
+[keywords text]
+[keywords url]
+[keywords wiki]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Exporting keyword indices}]
+[category {Documentation tools}]
+[require doctools::idx::export [opt 0.1]]
+[require Tcl 8.4]
+[require doctools::config]
+[require doctools::idx::structure]
+[require snit]
+[require pluginmgr]
+[description]
+
+This package provides a class to manage the plugins for the export of
+keyword indices to other formats, i.e. their conversion to, for
+example [term docidx], [term HTML], etc.
+
+[para]
+
+This is one of the three public pillars the management of keyword
+indices resides on. The other two pillars are
+
+[list_begin enum]
+[enum] [manpage {Importing keyword indices}], and
+[enum] [manpage {Holding keyword indices}]
+[list_end]
+
+[para]
+
+For information about the [sectref Concepts] of keyword indices, and
+their parts, see the same-named section.
+
+For information about the data structure which is the major input to
+the manager objects provided by this package see the section
+[sectref {Keyword index serialization format}].
+
+[para]
+
+The plugin system of our class is based on the package
+[package pluginmgr], and configured to look for plugins using
+
+[list_begin enum]
+[enum] the environment variable [var DOCTOOLS_IDX_EXPORT_PLUGINS],
+[enum] the environment variable [var DOCTOOLS_IDX_PLUGINS],
+[enum] the environment variable [var DOCTOOLS_PLUGINS],
+[enum] the path [file {~/.doctools/idx/export/plugin}]
+[enum] the path [file {~/.doctools/idx/plugin}]
+[enum] the path [file {~/.doctools/plugin}]
+[enum] the path [file {~/.doctools/idx/export/plugins}]
+[enum] the path [file {~/.doctools/idx/plugins}]
+[enum] the path [file {~/.doctools/plugins}]
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\DOCTOOLS\IDX\EXPORT\PLUGINS"
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\DOCTOOLS\IDX\PLUGINS"
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\DOCTOOLS\PLUGINS"
+[list_end]
+
+The last three are used only when the package is run on a machine
+using Windows(tm) operating system.
+
+[para]
+
+The whole system is delivered with six predefined export plugins,
+namely
+
+[list_begin definitions]
+[def docidx] See [manpage {docidx export plugin}] for details.
+[def html] See [manpage {html export plugin}] for details.
+[def json] See [manpage {json export plugin}] for details.
+[def nroff] See [manpage {nroff export plugin}] for details.
+[def text] See [manpage {text export plugin}] for details.
+[def wiki] See [manpage {wiki export plugin}] for details.
+[list_end]
+
+[para]
+
+Readers wishing to write their own export plugin for some format, i.e.
+[term {plugin writer}]s reading and understanding the section
+containing the [sectref {Export plugin API v2 reference}] is an
+absolute necessity, as it specifies the interaction between this
+package and its plugins in detail.
+
+[section Concepts] [include include/concept.inc]
+
+[section API]
+[subsection {Package commands}]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::idx::export] [arg objectName]]
+
+This command creates a new export manager object with an associated
+Tcl command whose name is [arg objectName]. This [term object] command
+is explained in full detail in the sections [sectref {Object command}]
+and [sectref {Object methods}]. The object command will be created
+under the current namespace if the [arg objectName] is not fully
+qualified, and in the specified namespace otherwise.
+
+[list_end]
+
+[subsection {Object command}]
+
+All objects created by the [cmd ::doctools::idx::export] command have
+the following general form:
+
+[list_begin definitions]
+
+[call [cmd objectName] [method method] [opt [arg "arg arg ..."]]]
+
+The method [method method] and its [arg arg]'uments determine the
+exact behavior of the command.
+
+See section [sectref {Object methods}] for the detailed
+specifications.
+
+[list_end]
+
+[subsection {Object methods}]
+
+[list_begin definitions]
+
+[call [arg objectName] [method destroy]]
+
+This method destroys the object it is invoked for.
+
+[call [arg objectName] [method {export serial}] [arg serial] [opt [arg format]]]
+
+This method takes the canonical serialization of a keyword index
+stored in [arg serial] and converts it to the specified [arg format],
+using the export plugin for the format. An error is thrown if no
+plugin could be found for the format.
+
+The string generated by the conversion process is returned as
+the result of this method.
+
+[para]
+
+If no format is specified the method defaults to [const docidx].
+
+[para]
+
+The specification of what a [term canonical] serialization is can be
+found in the section [sectref {Keyword index serialization format}].
+
+[para]
+
+The plugin has to conform to the interface specified in section
+[sectref {Export plugin API v2 reference}].
+
+[call [arg objectName] [method {export object}] [arg object] [opt [arg format]]]
+
+This method is a convenient wrapper around the [method {export serial}]
+method described by the previous item.
+
+It expects that [arg object] is an object command supporting a
+[method serialize] method returning the canonical serialization of a
+keyword index. It invokes that method, feeds the result into
+[method {export serial}] and returns the resulting string as its own
+result.
+
+[call [arg objectName] [method {config names}]]
+
+This method returns a list containing the names of all configuration
+variables currently known to the object.
+
+[call [arg objectName] [method {config get}]]
+
+This method returns a dictionary containing the names and values of
+all configuration variables currently known to the object.
+
+[call [arg objectName] [method {config set}] [arg name] [opt [arg value]]]
+
+This method sets the configuration variable [arg name] to the
+specified [arg value] and returns the new value of the variable.
+
+[para]
+
+If no value is specified it simply returns the current value, without
+changing it.
+
+[para]
+
+Note that while the user can set the predefined configuration
+variables [const user] and [const format] doing so will have no
+effect, these values will be internally overriden when invoking an
+import plugin.
+
+[call [arg objectName] [method {config unset}] [arg pattern]...]
+
+This method unsets all configuration variables matching the specified
+glob [arg pattern]s. If no pattern is specified it will unset all
+currently defined configuration variables.
+
+[list_end]
+
+[section {Export plugin API v2 reference}]
+
+Plugins are what this package uses to manage the support for any
+output format beyond the
+[sectref {Keyword index serialization format}]. Here we specify the
+API the objects created by this package use to interact with their
+plugins.
+
+[para]
+
+A plugin for this package has to follow the rules listed below:
+
+[list_begin enumerated]
+
+[enum] A plugin is a package.
+
+[enum] The name of a plugin package has the form
+
+ doctools::idx::export::[var FOO],
+
+ where [var FOO] is the name of the format the plugin will
+ generate output for. This name is also the argument to provide
+ to the various [method export] methods of export manager
+ objects to get a string encoding a keyword index in that
+ format.
+
+[enum] The plugin can expect that the package
+ [package doctools::idx::export::plugin] is present, as
+ indicator that it was invoked from a genuine plugin manager.
+
+[enum] A plugin has to provide one command, with the signature shown
+ below.
+
+[list_begin definitions]
+[call [cmd export] [arg serial] [arg configuration]]
+
+Whenever an export manager of [package doctools::idx] has to generate
+output for an index it will invoke this command.
+
+[list_begin arguments]
+
+[arg_def string serial]
+
+This argument will contain the [term canonical] serialization of the
+index for which to generate the output.
+
+The specification of what a [term canonical] serialization is can be
+found in the section [sectref {Keyword index serialization format}].
+
+[arg_def dictionary configuration]
+
+This argument will contain the current configuration to apply to the
+generation, as a dictionary mapping from variable names to values.
+
+[para]
+
+The following configuration variables have a predefined meaning all
+plugins have to obey, although they can ignore this information at
+their discretion. Any other other configuration variables recognized
+by a plugin will be described in the manpage for that plugin.
+
+[list_begin definitions]
+
+[def user] This variable is expected to contain the name of the user
+ owning the process invoking the plugin.
+
+[def format] This variable is expected to contain the name of the
+ format whose plugin is invoked.
+
+[def file] This variable, if defined by the user of the index object
+ is expected to contain the name of the input file for which
+ the plugin is generating its output for.
+
+[def map] This variable, if defined by the user of the index object is
+ expected to contain a dictionary mapping from symbolic file
+ names used in the references of type [const manpage] to
+ actual paths (or urls). A plugin has to be able to handle
+ the possibility that a symbolic name is without entry in
+ this mapping.
+
+[list_end][comment {-- predefined configuration variables --}]
+[list_end][comment {-- arguments --}]
+[list_end][comment {-- api command signatures --}]
+
+[enum] A single usage cycle of a plugin consists of the invokations of
+ the command [cmd export]. This call has to leave the plugin in
+ a state where another usage cycle can be run without problems.
+
+[list_end]
+
+[include include/serialization.inc]
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2idx/idx_export_html.man b/tcllib/modules/doctools2idx/idx_export_html.man
new file mode 100644
index 0000000..66d4680
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_export_html.man
@@ -0,0 +1,7 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE html]
+[vset NAME HTML]
+[vset REQUIRE html]
+[vset CONFIG html]
+[vset VERSION 0.2]
+[include include/export/plugin.inc]
diff --git a/tcllib/modules/doctools2idx/idx_export_json.man b/tcllib/modules/doctools2idx/idx_export_json.man
new file mode 100644
index 0000000..ce9e983
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_export_json.man
@@ -0,0 +1,7 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE json]
+[vset NAME JSON]
+[vset REQUIRE json]
+[vset CONFIG json]
+[vset VERSION 0.1]
+[include include/export/plugin.inc]
diff --git a/tcllib/modules/doctools2idx/idx_export_nroff.man b/tcllib/modules/doctools2idx/idx_export_nroff.man
new file mode 100644
index 0000000..9b1692a
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_export_nroff.man
@@ -0,0 +1,7 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE nroff]
+[vset NAME nroff]
+[vset REQUIRE nroff]
+[vset CONFIG nroff]
+[vset VERSION 0.3]
+[include include/export/plugin.inc]
diff --git a/tcllib/modules/doctools2idx/idx_export_text.man b/tcllib/modules/doctools2idx/idx_export_text.man
new file mode 100644
index 0000000..29acbfc
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_export_text.man
@@ -0,0 +1,7 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE text]
+[vset NAME {plain text}]
+[vset REQUIRE text]
+[vset CONFIG text]
+[vset VERSION 0.2]
+[include include/export/plugin.inc]
diff --git a/tcllib/modules/doctools2idx/idx_export_wiki.man b/tcllib/modules/doctools2idx/idx_export_wiki.man
new file mode 100644
index 0000000..89a22f5
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_export_wiki.man
@@ -0,0 +1,7 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE wiki]
+[vset NAME wiki]
+[vset REQUIRE text]
+[vset CONFIG wiki]
+[vset VERSION 0.2]
+[include include/export/plugin.inc]
diff --git a/tcllib/modules/doctools2idx/idx_import.man b/tcllib/modules/doctools2idx/idx_import.man
new file mode 100644
index 0000000..f946348
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_import.man
@@ -0,0 +1,394 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::idx::import n 0.1]
+[keywords conversion]
+[keywords docidx]
+[keywords documentation]
+[keywords import]
+[keywords index]
+[keywords json]
+[keywords {keyword index}]
+[keywords manpage]
+[keywords markup]
+[keywords parsing]
+[keywords plugin]
+[keywords reference]
+[keywords url]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Importing keyword indices}]
+[category {Documentation tools}]
+[require doctools::idx::import [opt 0.1]]
+[require Tcl 8.4]
+[require doctools::config]
+[require doctools::idx::structure]
+[require snit]
+[require pluginmgr]
+[description]
+
+This package provides a class to manage the plugins for the import of
+keyword indices from other formats, i.e. their conversion from, for
+example [term docidx], [term json], etc.
+
+[para]
+
+This is one of the three public pillars the management of keyword
+indices resides on. The other two pillars are
+
+[list_begin enum]
+[enum] [manpage {Exporting keyword indices}], and
+[enum] [manpage {Holding keyword indices}]
+[list_end]
+
+[para]
+
+For information about the [sectref Concepts] of keyword indices, and
+their parts, see the same-named section.
+
+For information about the data structure which is the major output of
+the manager objects provided by this package see the section
+[sectref {Keyword index serialization format}].
+
+[para]
+
+The plugin system of our class is based on the package
+[package pluginmgr], and configured to look for plugins using
+
+[list_begin enum]
+[enum] the environment variable [var DOCTOOLS_IDX_IMPORT_PLUGINS],
+[enum] the environment variable [var DOCTOOLS_IDX_PLUGINS],
+[enum] the environment variable [var DOCTOOLS_PLUGINS],
+[enum] the path [file {~/.doctools/idx/import/plugin}]
+[enum] the path [file {~/.doctools/idx/plugin}]
+[enum] the path [file {~/.doctools/plugin}]
+[enum] the path [file {~/.doctools/idx/import/plugins}]
+[enum] the path [file {~/.doctools/idx/plugins}]
+[enum] the path [file {~/.doctools/plugins}]
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\DOCTOOLS\IDX\IMPORT\PLUGINS"
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\DOCTOOLS\IDX\PLUGINS"
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\DOCTOOLS\PLUGINS"
+[list_end]
+
+The last three are used only when the package is run on a machine
+using Windows(tm) operating system.
+
+[para]
+
+The whole system is delivered with two predefined import plugins,
+namely
+
+[list_begin definitions]
+[def docidx] See [manpage {docidx import plugin}] for details.
+[def json] See [manpage {json import plugin}] for details.
+[list_end]
+
+[para]
+
+Readers wishing to write their own import plugin for some format, i.e.
+[term {plugin writer}]s reading and understanding the section
+containing the [sectref {Import plugin API v2 reference}] is an
+absolute necessity, as it specifies the interaction between this
+package and its plugins in detail.
+
+[section Concepts] [include include/concept.inc]
+
+[section API]
+[subsection {Package commands}]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::idx::import] [arg objectName]]
+
+This command creates a new import manager object with an associated
+Tcl command whose name is [arg objectName]. This [term object] command
+is explained in full detail in the sections [sectref {Object command}]
+and [sectref {Object methods}]. The object command will be created
+under the current namespace if the [arg objectName] is not fully
+qualified, and in the specified namespace otherwise.
+
+[list_end]
+
+[subsection {Object command}]
+
+All objects created by the [cmd ::doctools::idx::import] command have
+the following general form:
+
+[list_begin definitions]
+
+[call [cmd objectName] [method method] [opt [arg "arg arg ..."]]]
+
+The method [method method] and its [arg arg]'uments determine the
+exact behavior of the command.
+
+See section [sectref {Object methods}] for the detailed
+specifications.
+
+[list_end]
+
+[subsection {Object methods}]
+
+[list_begin definitions]
+
+[call [arg objectName] [method destroy]]
+
+This method destroys the object it is invoked for.
+
+[call [arg objectName] [method {import text}] [arg text] [opt [arg format]]]
+
+This method takes the [arg text] and converts it from the specified
+[arg format] to the canonical serialization of a keyword index using
+the import plugin for the format. An error is thrown if no plugin
+could be found for the format.
+
+The serialization generated by the conversion process is returned as
+the result of this method.
+
+[para]
+
+If no format is specified the method defaults to [const docidx].
+
+[para]
+
+The specification of what a [term canonical] serialization is can be
+found in the section [sectref {Keyword index serialization format}].
+
+[para]
+
+The plugin has to conform to the interface specified in section
+[sectref {Import plugin API v2 reference}].
+
+[call [arg objectName] [method {import file}] [arg path] [opt [arg format]]]
+
+This method is a convenient wrapper around the [method {import text}]
+method described by the previous item.
+
+It reads the contents of the specified file into memory, feeds the
+result into [method {import text}] and returns the resulting
+serialization as its own result.
+
+[call [arg objectName] [method {import object text}] [arg object] \
+ [arg text] [opt [arg format]]]
+
+This method is a convenient wrapper around the [method {import text}]
+method described by the previous item.
+
+It expects that [arg object] is an object command supporting a
+[method deserialize] method expecting the canonical serialization of a
+keyword index.
+
+It imports the text using [method {import text}] and then feeds the
+resulting serialization into the [arg object] via [method deserialize].
+
+This method returns the empty string as it result.
+
+[call [arg objectName] [method {import object file}] [arg object] \
+ [arg path] [opt [arg format]]]
+
+This method behaves like [method {import object text}], except that it
+reads the text to convert from the specified file instead of being
+given it as argument.
+
+[call [arg objectName] [method {config names}]]
+
+This method returns a list containing the names of all configuration
+variables currently known to the object.
+
+[call [arg objectName] [method {config get}]]
+
+This method returns a dictionary containing the names and values of
+all configuration variables currently known to the object.
+
+[call [arg objectName] [method {config set}] [arg name] [opt [arg value]]]
+
+This method sets the configuration variable [arg name] to the
+specified [arg value] and returns the new value of the variable.
+
+[para]
+
+If no value is specified it simply returns the current value, without
+changing it.
+
+[para]
+
+Note that while the user can set the predefined configuration
+variables [const user] and [const format] doing so will have no
+effect, these values will be internally overriden when invoking an
+import plugin.
+
+[call [arg objectName] [method {config unset}] [arg pattern]...]
+
+This method unsets all configuration variables matching the specified
+glob [arg pattern]s. If no pattern is specified it will unset all
+currently defined configuration variables.
+
+[call [arg objectName] [method includes]]
+
+This method returns a list containing the currently specified paths to
+use to search for include files when processing input.
+
+The order of paths in the list corresponds to the order in which they
+are used, from first to last, and also corresponds to the order in
+which they were added to the object.
+
+[call [arg objectName] [method {include add}] [arg path]]
+
+This methods adds the specified [arg path] to the list of paths to use
+to search for include files when processing input. The path is added
+to the end of the list, causing it to be searched after all previously
+added paths. The result of the command is the empty string.
+
+[para]
+
+The method does nothing if the path is already known.
+
+[call [arg objectName] [method {include remove}] [arg path]]
+
+This methods removes the specified [arg path] from the list of paths
+to use to search for include files when processing input. The result
+of the command is the empty string.
+
+[para]
+
+The method does nothing if the path is not known.
+
+[call [arg objectName] [method {include clear}]]
+
+This method clears the list of paths to use to search for include
+files when processing input. The result of the command is the empty
+string.
+
+[list_end]
+
+[section {Import plugin API v2 reference}]
+
+Plugins are what this package uses to manage the support for any input
+format beyond the [sectref {Keyword index serialization format}]. Here
+we specify the API the objects created by this package use to interact
+with their plugins.
+
+[para]
+
+A plugin for this package has to follow the rules listed below:
+
+[list_begin enumerated]
+
+[enum] A plugin is a package.
+
+[enum] The name of a plugin package has the form
+
+ doctools::idx::import::[var FOO],
+
+ where [var FOO] is the name of the format the plugin will
+ generate output for. This name is also the argument to provide
+ to the various [method import] methods of import manager
+ objects to get a string encoding a keyword index in that
+ format.
+
+[enum] The plugin can expect that the package
+ [package doctools::idx::export::plugin] is present, as
+ indicator that it was invoked from a genuine plugin manager.
+
+[enum] The plugin can expect that a command named [cmd IncludeFile] is
+ present, with the signature
+
+[list_begin definitions]
+[call [cmd IncludeFile] [arg currentfile] [arg path]]
+
+This command has to be invoked by the plugin when it has to process an
+included file, if the format has the concept of such. An example of
+such a format would be [term docidx].
+
+[para]
+The plugin has to supply the following arguments
+
+[list_begin arguments]
+[arg_def string currentfile]
+The path of the file it is currently processing. This may be the empty
+string if no such is known.
+
+[arg_def string path]
+The path of the include file as specified in the include directive
+being processed.
+
+[list_end]
+
+The result of the command will be a 5-element list containing
+
+[list_begin enum]
+
+[enum] A boolean flag indicating the success ([const True]) or failure
+ ([const False]) of the operation.
+
+[enum] In case of success the contents of the included file, and the
+ empty string otherwise.
+
+[enum] The resolved, i.e. absolute path of the included file, if
+ possible, or the unchanged [arg path] argument. This is for
+ display in an error message, or as the [arg currentfile]
+ argument of another call to [cmd IncludeFile] should this file
+ contain more files.
+
+[enum] In case of success an empty string, and for failure a code
+ indicating the reason for it, one of
+
+[list_begin definitions]
+[def notfound] The specified file could not be found.
+[def notread] The specified file was found, but not be read into memory.
+[list_end][comment {-- include error codes --}]
+
+[enum] An empty string in case of success of a [const notfound]
+ failure, and an additional error message describing the reason
+ for a [const notread] error in more detail.
+
+[list_end][comment {-- result list elements --}]
+[list_end][comment {-- include-file signature --}]
+
+[enum] A plugin has to provide one command, with the signature shown
+ below.
+
+[list_begin definitions]
+[call [cmd import] [arg text] [arg configuration]]
+
+Whenever an import manager of [package doctools::idx] has to parse
+input for an index it will invoke this command.
+
+[list_begin arguments]
+
+[arg_def string text]
+
+This argument will contain the text encoding the index per the format
+the plugin is for.
+
+[arg_def dictionary configuration]
+
+This argument will contain the current configuration to apply to the
+parsing, as a dictionary mapping from variable names to values.
+
+[para]
+
+The following configuration variables have a predefined meaning all
+plugins have to obey, although they can ignore this information at
+their discretion. Any other other configuration variables recognized
+by a plugin will be described in the manpage for that plugin.
+
+[list_begin definitions]
+
+[def user] This variable is expected to contain the name of the user
+ owning the process invoking the plugin.
+
+[def format] This variable is expected to contain the name of the
+ format whose plugin is invoked.
+
+[list_end][comment {-- predefined configuration variables --}]
+[list_end][comment {-- arguments --}]
+[list_end][comment {-- api command signatures --}]
+
+[enum] A single usage cycle of a plugin consists of the invokations of
+ the command [cmd import]. This call has to leave the plugin in
+ a state where another usage cycle can be run without problems.
+
+[list_end]
+
+[include include/serialization.inc]
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2idx/idx_import_json.man b/tcllib/modules/doctools2idx/idx_import_json.man
new file mode 100644
index 0000000..c097451
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_import_json.man
@@ -0,0 +1,6 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE json]
+[vset NAME JSON]
+[vset REQUIRE json]
+[vset CONFIG json]
+[include include/import/plugin.inc]
diff --git a/tcllib/modules/doctools2idx/idx_introduction.man b/tcllib/modules/doctools2idx/idx_introduction.man
new file mode 100644
index 0000000..98edfb3
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_introduction.man
@@ -0,0 +1,146 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools2idx_introduction n 2.0]
+[see_also docidx_intro]
+[see_also doctoc_intro]
+[see_also doctools]
+[see_also doctools2doc_introduction]
+[see_also doctools2toc_introduction]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_intro]
+[see_also doctools_lang_syntax]
+[see_also doctools_plugin_apiref]
+[keywords conversion]
+[keywords formatting]
+[keywords index]
+[keywords {keyword index}]
+[keywords markup]
+[keywords parsing]
+[keywords plugin]
+[keywords {semantic markup}]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {DocTools - Keyword indices}]
+[category {Documentation tools}]
+[comment {
+}]
+[description]
+
+[term docidx] (short for [emph {documentation indices}]) stands for a
+set of related, yet different, entities which are working together for
+the easy creation and transformation of keyword indices for
+documentation.
+
+[para]
+
+These are
+
+[list_begin enumerated]
+[enum]
+A tcl based language for the semantic markup of a keyword index.
+Markup is represented by Tcl commands.
+
+Beginners should start with the
+[manpage {docidx language introduction}].
+
+The formal specification is split over two documents, one dealing with
+the [manpage {docidx language syntax}], the other a
+[manpage {docidx language command reference}].
+
+[enum]
+A set of packages for the programmatic manipulation of keyword indices
+in memory, and their conversion between various formats, reading and
+writing. The aforementioned markup language is one of the formats
+which can be both read from and written to.
+
+[enum]
+The system for the conversion of indices is based on a plugin
+mechanism, for this we have two APIs describing the interface between
+the packages above and the import/export plugins.
+
+[list_end]
+
+[para]
+Which of the more detailed documents are relevant to the reader of
+this introduction depends on their role in the documentation process.
+
+[para]
+
+[list_begin enumerated]
+[enum]
+A [manpage writer] of documentation has to understand the markup language
+itself. A beginner to docidx should read the more informally written
+[manpage {docidx language introduction}] first. Having digested this
+the formal [manpage {docidx language syntax}] specification should
+become understandable. A writer experienced with docidx may only
+need the [manpage {docidx language command reference}] from time to
+time to refresh her memory.
+
+[para]
+While a document is written the [syscmd dtp] application can be used
+to validate it, and after completion it also performs the conversion
+into the chosen system of visual markup, be it *roff, HTML, plain
+text, wiki, etc. The simpler [syscmd dtplite] application makes
+internal use of docidx when handling directories of documentation,
+automatically generating a proper keyword index for them.
+
+[enum]
+A [term processor] of documentation written in the [term docidx]
+markup language has to know which tools are available for use.
+
+[para]
+
+The main tool is the aforementioned [syscmd dtp] application provided
+by Tcllib. The simpler [syscmd dtplite] does not expose docidx to the
+user. At the bottom level, common to both applications, however we
+find the three packages providing the basic facilities to handle
+keyword indices, i.e. import from textual formats, programmatic
+manipulation in memory, and export to textual formats. These are
+
+[list_begin definitions]
+[def [package doctools::idx]]
+Programmatic manipulation of keyword indices in memory.
+
+[def [package doctools::idx::import]]
+Import of keyword indices from various textual formats. The set of
+supported formats is extensible through plugin packages.
+
+[def [package doctools::idx::export]]
+Export of keyword indices to various textual formats. The set of
+supported formats is extensible through plugin packages.
+
+[list_end]
+
+See also section [sectref {Package Overview}] for an overview of the
+dependencies between these and other, supporting packages.
+
+[enum]
+At last, but not least, [term {plugin writers}] have to understand the
+interaction between the import and export packages and their plugins.
+These APIs are described in the documentation for the two relevant
+packages, i.e.
+
+[list_begin itemized]
+[item] [package doctools::idx::import]
+[item] [package doctools::idx::export]
+[list_end]
+
+[list_end]
+
+[section {Related formats}]
+
+The docidx format does not stand alone, it has two companion formats.
+These are called [term doctoc] and [term doctools], and they are
+intended for the markup of [term {tables of contents}], and of general
+documentation, respectively.
+
+They are described in their own sets of documents, starting at
+the [manpage {DocTools - Tables Of Contents}] and
+the [manpage {DocTools - General}], respectively.
+
+[section {Package Overview}]
+[include include/dependencies.inc]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2idx/idx_msgcat_c.man b/tcllib/modules/doctools2idx/idx_msgcat_c.man
new file mode 100644
index 0000000..3bb3f54
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_msgcat_c.man
@@ -0,0 +1,5 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE c]
+[vset NAME C]
+[vset LONGNAME C]
+[include include/msgcat.inc]
diff --git a/tcllib/modules/doctools2idx/idx_msgcat_de.man b/tcllib/modules/doctools2idx/idx_msgcat_de.man
new file mode 100644
index 0000000..9c502a2
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_msgcat_de.man
@@ -0,0 +1,5 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE de]
+[vset NAME DE]
+[vset LONGNAME {DE (german)}]
+[include include/msgcat.inc]
diff --git a/tcllib/modules/doctools2idx/idx_msgcat_en.man b/tcllib/modules/doctools2idx/idx_msgcat_en.man
new file mode 100644
index 0000000..5dd9c3f
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_msgcat_en.man
@@ -0,0 +1,5 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE en]
+[vset NAME EN]
+[vset LONGNAME {EN (english)}]
+[include include/msgcat.inc]
diff --git a/tcllib/modules/doctools2idx/idx_msgcat_fr.man b/tcllib/modules/doctools2idx/idx_msgcat_fr.man
new file mode 100644
index 0000000..3e5229b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_msgcat_fr.man
@@ -0,0 +1,5 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE fr]
+[vset NAME FR]
+[vset LONGNAME {FR (french)}]
+[include include/msgcat.inc]
diff --git a/tcllib/modules/doctools2idx/idx_parse.man b/tcllib/modules/doctools2idx/idx_parse.man
new file mode 100644
index 0000000..310d59e
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_parse.man
@@ -0,0 +1,175 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::idx::parse n 1]
+[keywords docidx]
+[keywords doctools]
+[keywords lexer]
+[keywords parser]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Parsing text in docidx format}]
+[category {Documentation tools}]
+[require doctools::idx::parse [opt 0.1]]
+[require Tcl 8.4]
+[require doctools::idx::structure]
+[require doctools::msgcat]
+[require doctools::tcl::parse]
+[require fileutil]
+[require logger]
+[require snit]
+[require struct::list]
+[require struct::stack]
+
+[description]
+
+This package provides commands to parse text written in the
+[term docidx] markup language and convert it into the canonical
+serialization of the keyword index encoded in the text.
+
+See the section [sectref {Keyword index serialization format}] for
+specification of their format.
+
+[para]
+
+This is an internal package of doctools, for use by the higher level
+packages handling [term docidx] documents.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::idx::parse] [method text] [arg text]]
+
+The command takes the string contained in [arg text] and parses it
+under the assumption that it contains a document written using the
+[term docidx] markup language. An error is thrown if this assumption
+is found to be false. The format of these errors is described in
+section [sectref {Parse errors}].
+
+[para]
+
+When successful the command returns the canonical serialization of the
+keyword index which was encoded in the text.
+
+See the section [sectref {Keyword index serialization format}] for
+specification of that format.
+
+[call [cmd ::doctools::idx::parse] [method file] [arg path]]
+
+The same as [method text], except that the text to parse is read from
+the file specified by [arg path].
+
+[call [cmd ::doctools::idx::parse] [method includes]]
+
+This method returns the current list of search paths used when looking
+for include files.
+
+[call [cmd ::doctools::idx::parse] [method {include add}] [arg path]]
+
+This method adds the [arg path] to the list of paths searched when
+looking for an include file. The call is ignored if the path is
+already in the list of paths. The method returns the empty string as
+its result.
+
+[call [cmd ::doctools::idx::parse] [method {include remove}] [arg path]]
+
+This method removes the [arg path] from the list of paths searched
+when looking for an include file. The call is ignored if the path is
+not contained in the list of paths. The method returns the empty
+string as its result.
+
+[call [cmd ::doctools::idx::parse] [method {include clear}]]
+
+This method clears the list of search paths for include files.
+
+[call [cmd ::doctools::idx::parse] [method vars]]
+
+This method returns a dictionary containing the current set of
+predefined variables known to the [cmd vset] markup command during
+processing.
+
+[call [cmd ::doctools::idx::parse] [method {var set}] [arg name] [arg value]]
+
+This method adds the variable [arg name] to the set of predefined
+variables known to the [cmd vset] markup command during processing,
+and gives it the specified [arg value]. The method returns the empty
+string as its result.
+
+[call [cmd ::doctools::idx::parse] [method {var unset}] [arg name]]
+
+This method removes the variable [arg name] from the set of predefined
+variables known to the [cmd vset] markup command during
+processing. The method returns the empty string as its result.
+
+[call [cmd ::doctools::idx::parse] [method {var clear}] [opt [arg pattern]]]
+
+This method removes all variables matching the [arg pattern] from the
+set of predefined variables known to the [cmd vset] markup command
+during processing. The method returns the empty string as its result.
+
+[para]
+
+The pattern matching is done with [cmd {string match}], and the
+default pattern used when none is specified, is [const *].
+
+[list_end]
+
+[section {Parse errors}]
+
+The format of the parse error messages thrown when encountering
+violations of the [term docidx] markup syntax is human readable and
+not intended for processing by machines. As such it is not documented.
+
+[para]
+
+[emph However], the errorCode attached to the message is
+machine-readable and has the following format:
+
+[list_begin enumerated]
+[enum]
+The error code will be a list, each element describing a single error
+found in the input. The list has at least one element, possibly more.
+
+[enum]
+Each error element will be a list containing six strings describing an
+error in detail. The strings will be
+
+[list_begin enumerated]
+[enum]
+The path of the file the error occured in. This may be empty.
+
+[enum]
+The range of the token the error was found at. This range is a
+two-element list containing the offset of the first and last character
+in the range, counted from the beginning of the input (file). Offsets
+are counted from zero.
+
+[enum]
+The line the first character after the error is on.
+Lines are counted from one.
+
+[enum]
+The column the first character after the error is at.
+Columns are counted from zero.
+
+[enum]
+The message code of the error. This value can be used as argument to
+[cmd msgcat::mc] to obtain a localized error message, assuming that
+the application had a suitable call of [cmd doctools::msgcat::init] to
+initialize the necessary message catalogs (See package
+[package doctools::msgcat]).
+
+[enum]
+A list of details for the error, like the markup command involved. In
+the case of message code [const docidx/include/syntax] this value is
+the set of errors found in the included file, using the format
+described here.
+
+[list_end]
+[list_end]
+
+[include include/format/docidx.inc]
+[include include/serialization.inc]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2idx/idx_structure.man b/tcllib/modules/doctools2idx/idx_structure.man
new file mode 100644
index 0000000..0b501fd
--- /dev/null
+++ b/tcllib/modules/doctools2idx/idx_structure.man
@@ -0,0 +1,129 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::idx::structure n 0.1]
+[keywords deserialization]
+[keywords docidx]
+[keywords doctools]
+[keywords serialization]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Docidx serialization utilities}]
+[category {Documentation tools}]
+[require doctools::idx::structure [opt 0.1]]
+[require Tcl 8.4]
+[require logger]
+[require snit]
+[description]
+
+This package provides commands to work with the serializations of
+keyword indices as managed by the doctools system v2, and specified in
+section [sectref {Keyword index serialization format}].
+
+[para]
+
+This is an internal package of doctools, for use by the higher level
+packages handling keyword indices and their conversion into and out of
+various other formats, like documents written using [term docidx]
+markup.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::idx::structure] [method verify] \
+ [arg serial] [opt [arg canonvar]]]
+
+This command verifies that the content of [arg serial] is a valid
+[term regular] serialization of a keyword index and will throw an
+error if that is not the case. The result of the command is the empty
+string.
+
+[para]
+
+If the argument [arg canonvar] is specified it is interpreted as the
+name of a variable in the calling context. This variable will be
+written to if and only if [arg serial] is a valid regular
+serialization. Its value will be a boolean, with [const True]
+indicating that the serialization is not only valid, but also
+[term canonical]. [const False] will be written for a valid, but
+non-canonical serialization.
+
+[para]
+
+For the specification of regular and canonical keyword index
+serializations see the section
+[sectref {Keyword index serialization format}].
+
+[call [cmd ::doctools::idx::structure] [method verify-as-canonical] \
+ [arg serial]]
+
+This command verifies that the content of [arg serial] is a valid
+[term canonical] serialization of a keyword index and will throw an
+error if that is not the case. The result of the command is the empty
+string.
+
+[para]
+
+For the specification of canonical keyword index serializations see
+the section [sectref {Keyword index serialization format}].
+
+[call [cmd ::doctools::idx::structure] [method canonicalize] [arg serial]]
+
+This command assumes that the content of [arg serial] is a valid
+[term regular] serialization of a keyword index and will throw an
+error if that is not the case.
+
+[para]
+
+It will then convert the input into the [term canonical] serialization
+of the contained keyword index and return it as its result. If the
+input is already canonical it will be returned unchanged.
+
+[para]
+
+For the specification of regular and canonical keyword index
+serializations see the section
+[sectref {Keyword index serialization format}].
+
+[call [cmd ::doctools::idx::structure] [method print] [arg serial]]
+
+This command assumes that the argument [arg serial] contains a valid
+regular serialization of a keyword index and returns a string
+containing that index in a human readable form.
+
+[para]
+
+The exact format of this form is not specified and cannot be relied on
+for parsing or other machine-based activities.
+
+[para]
+
+For the specification of regular keyword index serializations see the
+section [sectref {Keyword index serialization format}].
+
+[call [cmd ::doctools::idx::structure] [method merge] \
+ [arg seriala] [arg serialb]]
+
+This command accepts the regular serializations of two keyword indices
+and uses them to create their union. The result of the command is the
+canonical serialization of this unified keyword index.
+
+[para]
+
+Title and label of the resulting index are taken from the index
+contained in [arg serialb]. The set of keys, references and their
+connections is the union of the set of keys and references of the two
+inputs.
+
+[para]
+
+For the specification of regular and canonical keyword index
+serializations see the section
+[sectref {Keyword index serialization format}].
+
+[list_end]
+
+[include include/serialization.inc]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2idx/import.tcl b/tcllib/modules/doctools2idx/import.tcl
new file mode 100644
index 0000000..a1d1a5a
--- /dev/null
+++ b/tcllib/modules/doctools2idx/import.tcl
@@ -0,0 +1,191 @@
+# docidx.tcl --
+#
+# Importing indices into other formats.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: import.tcl,v 1.2 2011/11/17 08:00:45 andreas_kupries Exp $
+
+# Each object manages a set of plugins for the conversion of keyword
+# indices into some textual representation. I.e. this object manages
+# the conversion to specialized serializations of keyword indices.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.4
+package require doctools::config
+package require doctools::idx::structure
+package require doctools::paths
+package require pluginmgr
+package require snit
+
+# ### ### ### ######### ######### #########
+## API
+
+snit::type ::doctools::idx::import {
+
+ # ### ### ### ######### ######### #########
+ ## Options :: None
+
+ # ### ### ### ######### ######### #########
+ ## Creation, destruction.
+
+ constructor {} {
+ install myconfig using ::doctools::config ${selfns}::config
+ install myinclude using ::doctools::paths ${selfns}::include
+ return
+ }
+
+ destructor {
+ $myconfig destroy
+ $myinclude destroy
+ # Clear the cache of loaded import plugins.
+ foreach k [array names myplugin] {
+ $myplugin($k) destroy
+ }
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Convert from other formats to the Tcl index serialization
+
+ method {import object text} {obj text {format {}}} {
+ $obj deserialize [$self import text $text $format]
+ return
+ }
+
+ method {import object file} {obj path {format {}}} {
+ $obj deserialize [$self import file $path $format]
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method {import text} {text {format {}}} {
+ set plugin [$self GetPlugin $format]
+
+ set configuration [$myconfig get]
+ lappend configuration user $::tcl_platform(user)
+ lappend configuraton format [$plugin plugin]
+
+ return [$plugin do import $text $configuration]
+ }
+
+ method {import file} {path {format {}}} {
+ # The plugin is not trusted to handle the file to convert.
+ return [$self import text [fileutil::cat $path] $format]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal methods
+
+ method GetPlugin {format} {
+ if {$format eq {}} { set format docidx }
+
+ if {![info exists myplugin($format)]} {
+ set plugin [pluginmgr ${selfns}::fmt-$format \
+ -pattern doctools::idx::import::* \
+ -api { import } \
+ -setup [mymethod PluginSetup]]
+ ::pluginmgr::paths $plugin doctools::idx::import
+ $plugin load $format
+ set myplugin($format) $plugin
+ } else {
+ set plugin $myplugin($format)
+ }
+
+ return $plugin
+ }
+
+ method PluginSetup {mgr ip} {
+ # Inject a pseudo package into the plugin interpreter the
+ # import plugins can use to check that they were loaded into a
+ # proper environment.
+ $ip eval {package provide doctools::idx::import::plugin 1}
+
+ # The import plugins may use msgcat, which requires access to
+ # tcl_platform during its initialization, and won't have it by
+ # default. We trust them enough to hand out the information.
+ # TODO :: remove user/wordSize, etc. We need only 'os'.
+ $ip eval [list array set ::tcl_platform [array get ::tcl_platform]]
+
+ # Provide an alias-command a plugin can use to ask for any
+ # file, so that it can handle the processing of include files,
+ # should its format have that concept. Like docidx. The alias
+ # will be directed to a method of ours and use the configured
+ # include paths to find the file, analogous to the GetFile
+ # procedure of doctools::idx::parse.
+
+ #8.5+: ::interp alias $ip include {} {*}[mymethod IncludeFile]
+ eval [linsert [mymethod IncludeFile] 0 ::interp alias $ip include {}]
+ return
+ }
+
+ method IncludeFile {currentfile path} {
+ # result = ok text fullpath error-code error-message
+
+ # Find the file, or not.
+ set fullpath [$self Locate $path]
+ if {$fullpath eq {}} {
+ return [list 0 {} $path notfound {}]
+ }
+
+ # Read contents, or not.
+ if {[catch {
+ set data [fileutil::cat $fullpath]
+ } msg]} {
+ set error notread
+ set emessage $msg
+ return [list 0 {} $fullpath notread $msg]
+ }
+
+ return [list 1 $data $fullpath {} {}]
+ }
+
+ method Locate {path} {
+ upvar 1 currentfile currentfile
+
+ if {$currentfile ne {}} {
+ set pathstosearch \
+ [linsert [$myinclude paths] 0 \
+ [file dirname [file normalize $currentfile]]]
+ } else {
+ set pathstosearch [$myinclude paths]
+ }
+
+ foreach base $pathstosearch {
+ set try [file join $base $path]
+ if {![file exists $try]} continue
+ return $try
+ }
+ # Nothing found
+ return {}
+ }
+
+ # ### ### ### ######### ######### #########
+ ## State
+
+ # Array serving as a cache for the various plugin managers holding
+ # a specific import plugin.
+
+ variable myplugin -array {}
+
+ # A component managing the configuration given to the import
+ # plugins when they are invoked.
+
+ component myconfig -public config
+ component myinclude -public include
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::idx::import 0.1
+return
diff --git a/tcllib/modules/doctools2idx/import.test b/tcllib/modules/doctools2idx/import.test
new file mode 100644
index 0000000..0bcfb7e
--- /dev/null
+++ b/tcllib/modules/doctools2idx/import.test
@@ -0,0 +1,377 @@
+# -*- tcl -*-
+# -- idx_import.test:
+# -- Tests for package "doctools::idx::import": Management of import plugins.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: import.test,v 1.1 2009/04/01 04:28:37 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2
+
+support {
+ use struct/list.tcl struct::list
+ use snit/snit.tcl snit
+ use fileutil/fileutil.tcl fileutil
+ use log/logger.tcl logger
+ use pluginmgr/pluginmgr.tcl pluginmgr
+
+ use doctools2base/config.tcl doctools::config
+ use doctools2base/paths.tcl doctools::paths
+
+ source [tcllibPath doctools2base/tests/common]
+}
+testing {
+ useLocalKeep import.tcl doctools::idx::import
+}
+
+# -------------------------------------------------------------------------
+
+setup_plugins
+
+# -------------------------------------------------------------------------
+
+test doctools-idx-import-1.0 {import text, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I import text
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::import::Snit_hmethodimport_text type selfns win self text ?format?"}
+
+test doctools-idx-import-1.1 {import text, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I import text T F XX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::import::Snit_hmethodimport_text type selfns win self text ?format?"}
+
+test doctools-idx-import-2.0 {import file, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I import file
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::import::Snit_hmethodimport_file type selfns win self path ?format?"}
+
+test doctools-idx-import-2.1 {import file, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I import file P F XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::import::Snit_hmethodimport_file type selfns win self path ?format?"}
+
+test doctools-idx-import-3.0 {import object text, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I import object text
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::import::Snit_hmethodimport_object_text type selfns win self obj text ?format?"}
+
+test doctools-idx-import-3.1 {import object text, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I import object text O
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::import::Snit_hmethodimport_object_text type selfns win self obj text ?format?"}
+
+test doctools-idx-import-3.2 {import object text, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I import object text O T F XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::import::Snit_hmethodimport_object_text type selfns win self obj text ?format?"}
+
+test doctools-idx-import-4.0 {import object file, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I import object file
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::import::Snit_hmethodimport_object_file type selfns win self obj path ?format?"}
+
+test doctools-idx-import-4.1 {import object file, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I import object file O
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::import::Snit_hmethodimport_object_file type selfns win self obj path ?format?"}
+
+test doctools-idx-import-4.2 {import object file, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I import object file O P F XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::import::Snit_hmethodimport_object_file type selfns win self obj path ?format?"}
+
+test doctools-idx-import-5.0 {config names, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I config names X
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodnames type selfns win self"}
+
+test doctools-idx-import-6.0 {config get, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I config get X
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodget type selfns win self"}
+
+test doctools-idx-import-7.0 {config set, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I config set
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodset type selfns win self name ?value?"}
+
+test doctools-idx-import-7.1 {config set, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I config set N V X
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodset type selfns win self name ?value?"}
+
+# config unset - accepts any number of arguments.
+
+test doctools-idx-import-8.0 {include paths, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I include paths X
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::paths::Snit_methodpaths type selfns win self"}
+
+test doctools-idx-import-9.0 {include clear, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I include clear X
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::paths::Snit_methodclear type selfns win self"}
+
+test doctools-idx-import-10.0 {include add, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I include add
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::paths::Snit_methodadd type selfns win self path"}
+
+test doctools-idx-import-10.1 {include add, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I include add P X
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::paths::Snit_methodadd type selfns win self path"}
+
+test doctools-idx-import-11.0 {include remove, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I include remove
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::paths::Snit_methodremove type selfns win self path"}
+
+test doctools-idx-import-11.1 {include remove, wrong#args} -setup {
+ doctools::idx::import I
+} -body {
+ I include remove P X
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::paths::Snit_methodremove type selfns win self path"}
+
+# -------------------------------------------------------------------------
+
+test doctools-idx-import-12.0 {config set, define single var} -setup {
+ doctools::idx::import I
+} -body {
+ I config set N V
+ I config get
+} -cleanup {
+ I destroy
+} -result {N V}
+
+test doctools-idx-import-12.1 {config set, define multiple vars} -setup {
+ doctools::idx::import I
+} -body {
+ I config set N V
+ I config set A B
+ dictsort [I config get]
+} -cleanup {
+ I destroy
+} -result {A B N V}
+
+test doctools-idx-import-12.2 {config set, as query} -setup {
+ doctools::idx::import I
+ I config set N V
+} -body {
+ I config set N
+} -cleanup {
+ I destroy
+} -result V
+
+test doctools-idx-import-13.0 {config unset, all} -setup {
+ doctools::idx::import I
+ I config set N V
+} -body {
+ I config unset
+ I config get
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-idx-import-13.1 {config unset, by exact name} -setup {
+ doctools::idx::import I
+ I config set N V
+ I config set A B
+} -body {
+ I config unset N
+ I config get
+} -cleanup {
+ I destroy
+} -result {A B}
+
+test doctools-idx-import-13.2 {config unset, by glob pattern} -setup {
+ doctools::idx::import I
+ I config set N V
+ I config set N' V'
+ I config set A B
+} -body {
+ I config unset N*
+ I config get
+} -cleanup {
+ I destroy
+} -result {A B}
+
+test doctools-idx-import-14.0 {config names, empty} -setup {
+ doctools::idx::import I
+} -body {
+ I config names
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-idx-import-14.1 {config names, with variables} -setup {
+ doctools::idx::import I
+ I config set N V
+ I config set A B
+} -body {
+ lsort -dict [I config names]
+} -cleanup {
+ I destroy
+} -result {A N}
+
+test doctools-idx-import-15.0 {config get, empty} -setup {
+ doctools::idx::import I
+} -body {
+ I config get
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-idx-import-15.1 {config get, with variables} -setup {
+ doctools::idx::import I
+ I config set N V
+ I config set A B
+} -body {
+ dictsort [I config get]
+} -cleanup {
+ I destroy
+} -result {A B N V}
+
+test doctools-idx-import-16.0 {include paths, empty} -setup {
+ doctools::idx::import I
+} -body {
+ I include paths
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-idx-import-16.1 {include paths, several paths, order} -setup {
+ doctools::idx::import I
+ I include add first
+ I include add second
+} -body {
+ I include paths
+} -cleanup {
+ I destroy
+} -result {first second}
+
+test doctools-idx-import-17.0 {include add, unknown} -setup {
+ doctools::idx::import I
+} -body {
+ I include add A
+ I include paths
+} -cleanup {
+ I destroy
+} -result A
+
+test doctools-idx-import-17.1 {include add, already known} -setup {
+ doctools::idx::import I
+} -body {
+ I include add A
+ I include add A
+ I include paths
+} -cleanup {
+ I destroy
+} -result A
+
+test doctools-idx-import-18.0 {include remove, unknown} -setup {
+ doctools::idx::import I
+} -body {
+ I include add A
+ I include remove B
+ I include paths
+} -cleanup {
+ I destroy
+} -result A
+
+test doctools-idx-import-18.1 {include remove, known} -setup {
+ doctools::idx::import I
+} -body {
+ I include add A
+ I include remove A
+ I include paths
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-idx-import-19.0 {include clear} -setup {
+ doctools::idx::import I
+} -body {
+ I include add A
+ I include add B
+ I include clear
+ I include paths
+} -cleanup {
+ I destroy
+} -result {}
+
+# idx_import tests, numbering starts at 20
+# -------------------------------------------------------------------------
+
+source [localPath tests/import]
+
+#----------------------------------------------------------------------
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2idx/import_docidx.man b/tcllib/modules/doctools2idx/import_docidx.man
new file mode 100644
index 0000000..773b108
--- /dev/null
+++ b/tcllib/modules/doctools2idx/import_docidx.man
@@ -0,0 +1,6 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE docidx]
+[vset NAME docidx]
+[vset REQUIRE docidx]
+[vset CONFIG docidx]
+[include include/import/plugin.inc]
diff --git a/tcllib/modules/doctools2idx/import_docidx.tcl b/tcllib/modules/doctools2idx/import_docidx.tcl
new file mode 100644
index 0000000..ffa4708
--- /dev/null
+++ b/tcllib/modules/doctools2idx/import_docidx.tcl
@@ -0,0 +1,91 @@
+# docidx.tcl --
+#
+# The docidx import plugin. Bridge between import management and
+# the parsing of docidx markup.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: import_docidx.tcl,v 1.3 2009/08/07 18:53:11 andreas_kupries Exp $
+
+# This package is a plugin for the the doctools::idx v2 system. It
+# takes text in docidx format and produces the list serialization of a
+# keyword index.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: doctools::idx::import::plugin
+
+package require Tcl 8.4
+package require doctools::idx::import::plugin ; # The presence of this
+ # pseudo package
+ # indicates execution
+ # of this code inside
+ # of an interpreter
+ # which was properly
+ # initialized for use
+ # by import plugins.
+package require doctools::idx::parse ; # The actual docidx
+ # parser used by the
+ # plugin.
+
+# ### ### ### ######### ######### #########
+
+## We redefine the command 'doctools::idx::parse::GetFile' to use the
+## 'include' alias provided by the plugin manager, as reguar file
+## commands are not allowed in this 'safe' environment. However this
+## is done if and only if we truly are in the plugin environment. The
+## testsuite, for example, will leave out the definition of 'include',
+## signaling in this way that the regular file operations can still be
+## used.
+
+if {[llength [info commands include]]} {
+
+ # Note: We are poking directly into the implementation of the
+ # class. Any changes to the interface here have to reviewed
+ # for their impact on doctools::idx::parse, and possibly
+ # ported over.
+
+ proc ::doctools::idx::parse::GetFile {currentfile path dv pv ev mv} {
+ upvar 1 $dv data $pv fullpath $ev error $mv emessage
+ foreach {ok data fullpath error emessage} [include $currentfile $path] break
+ return $ok
+ }
+}
+
+# ### ### ### ######### ######### #########
+## API :: Convert text to canonical index serialization.
+
+proc import {text configuration} {
+ global errorInfo errorCode
+
+ doctools::idx::parse var load $configuration
+
+ # Could be done better using a try/finally
+ set code [catch {
+ doctools::idx::parse text $text
+ } serial]
+
+ # Save error state if there was any.
+ set ei $errorInfo
+ set ec $errorCode
+
+ # Cleanup parser configuration, regardless of errors or not.
+ doctools::idx::parse var unset *
+
+ # Rethrow any error, using the captured state.
+ if {$code} {
+ return -code $code -errorinfo $ei -errorcode $ec $serial
+ }
+
+ return $serial
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::idx::import::docidx 0.1
+return
diff --git a/tcllib/modules/doctools2idx/import_docidx.test b/tcllib/modules/doctools2idx/import_docidx.test
new file mode 100644
index 0000000..fdcdc10
--- /dev/null
+++ b/tcllib/modules/doctools2idx/import_docidx.test
@@ -0,0 +1,92 @@
+# -*- tcl -*-
+# idx_import_docidx.test: tests for the doctools::idx::import::docidx package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: import_docidx.test,v 1.1 2009/04/01 04:28:37 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ useAccel [useTcllibC] struct/tree.tcl struct::tree
+ TestAccelInit struct::tree
+
+ useAccel [useTcllibC] struct/stack.tcl struct::stack
+ TestAccelInit struct::stack
+
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use struct/list.tcl struct::list
+ use snit/snit.tcl snit
+ use fileutil/fileutil.tcl fileutil
+ use log/logger.tcl logger
+ use treeql/treeql.tcl treeql
+
+ use doctools2base/tcl_parse.tcl doctools::tcl::parse
+ use doctools2base/msgcat.tcl doctools::msgcat
+
+ useLocal msgcat_c.tcl doctools::msgcat::idx::c
+ useLocal structure.tcl doctools::idx::structure
+ useLocal parse.tcl doctools::idx::parse
+
+ msgcat::mclocale C
+}
+testing {
+ package provide doctools::idx::import::plugin 1
+ # The above fakes plugin environment. Well, not completely. By
+ # leaving out a definition for the 'include' alias the plugin is
+ # signaled that there is no need to overwrite the GetFile command
+ # of doctools::idx::parse with a version calling out to the plugin
+ # manager, i.e. that it can still use the regular file operations.
+
+ useLocal import_docidx.tcl doctools::idx::import::docidx
+}
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-idx-import-docidx-1.0 {import, wrong#args} -body {
+ import
+} -returnCodes error -result {wrong # args: should be "import text configuration"}
+
+test doctools-idx-import-docidx-1.1 {import, wrong#args} -body {
+ import T
+} -returnCodes error -result {wrong # args: should be "import text configuration"}
+
+test doctools-idx-import-docidx-1.2 {import, wrong#args} -body {
+ import T C XXX
+} -returnCodes error -result {wrong # args: should be "import text configuration"}
+
+# idx_import_docidx tests, numbering starts at 2
+# -------------------------------------------------------------------------
+
+array_unset env LANG*
+array_unset env LC_*
+set env(LANG) C ; # Usually default if nothing is set, OS X requires this.
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::stack stkimpl {
+ TestAccelDo struct::set setimpl {
+ TestAccelDo struct::tree impl {
+ source [localPath tests/import_docidx]
+ }
+ }
+}
+
+#----------------------------------------------------------------------
+TestAccelExit struct::tree
+TestAccelExit struct::set
+TestAccelExit struct::stack
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2idx/import_json.tcl b/tcllib/modules/doctools2idx/import_json.tcl
new file mode 100644
index 0000000..f53db2f
--- /dev/null
+++ b/tcllib/modules/doctools2idx/import_json.tcl
@@ -0,0 +1,78 @@
+# json.tcl --
+#
+# The json import plugin. Bridge between import management and
+# the parsing of json markup.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: import_json.tcl,v 1.4 2009/11/23 23:04:25 andreas_kupries Exp $
+
+# This package is a plugin for the the doctools::idx v2 system. It
+# takes text in json format and produces the list serialization of a
+# keyword index.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @sak notprovided dict
+# @mdgen NODEP: doctools::idx::import::plugin
+
+package require Tcl 8.4
+package require doctools::idx::import::plugin ; # The presence of this
+ # pseudo package
+ # indicates execution
+ # of this code inside
+ # of an interpreter
+ # which was properly
+ # initialized for use
+ # by import plugins.
+package require doctools::idx::structure ; # Verification of the json
+ # parse result as a
+ # proper index
+ # serialization.
+
+if {[package vcompare [package present Tcl] 8.5] < 0} {
+ if {[catch {
+ package require dict
+ }]} {
+ # Create a pure Tcl implementation of the dict methods
+ # required by json, and fake the presence of the dict package.
+ proc dict {cmd args} { return [uplevel 1 [linsert $args 0 dict/$cmd]] }
+ proc dict/create {} { return {} }
+ proc dict/set {var key val} {
+ upvar 1 $var a
+ array set x $a
+ set x($key) $val
+ set a [array get x]
+ return
+ }
+ package provide dict 1
+ }
+}
+
+package require json ; # The actual json parser used by the plugin.
+# Requires 8.5, or 8.4+dict.
+
+# ### ### ### ######### ######### #########
+
+# ### ### ### ######### ######### #########
+## API :: Convert text to canonical index serialization.
+
+proc import {text configuration} {
+ # Note: We cannot fail here on duplicate keys in the input,
+ # especially for keywords and references, as we do for Tcl-based
+ # canonical index serializations, because our underlying JSON
+ # parser automatically merges them, by taking only the last found
+ # definition. I.e. of two or more definitions for a key X the last
+ # overwrites all previous occurences.
+ return [doctools::idx::structure canonicalize [json::json2dict $text]]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::idx::import::json 0.1
+return
diff --git a/tcllib/modules/doctools2idx/import_json.test b/tcllib/modules/doctools2idx/import_json.test
new file mode 100644
index 0000000..e5d4760
--- /dev/null
+++ b/tcllib/modules/doctools2idx/import_json.test
@@ -0,0 +1,115 @@
+# -*- tcl -*-
+# idx_import_json.test: tests for the doctools::idx::import::json package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: import_json.test,v 1.1 2009/04/01 04:28:37 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil
+ use struct/list.tcl struct::list
+
+ # Copy of code from idx_import_json.tcl, to define dict support
+ # even where dict is not really present on the system.
+
+ if {[package vcompare [package present Tcl] 8.5] < 0} {
+ if {[catch {
+ package require dict
+ }]} {
+ # Create a pure Tcl implementation of the dict methods
+ # required by json, and fake the presence of the dict package.
+ proc dict {cmd args} { return [uplevel 1 [linsert $args 0 dict/$cmd]] }
+ proc dict/create {} { return {} }
+ proc dict/set {var key val} {
+ upvar 1 $var a
+ array set x $a
+ set x($key) $val
+ set a [array get x]
+ return
+ }
+ package provide dict 1
+ }
+ }
+ use json/json.tcl json
+
+ useLocal structure.tcl doctools::idx::structure
+
+ #msgcat::mclocale C
+}
+testing {
+ package provide doctools::idx::import::plugin 1
+ # The above fakes plugin environment. Well, not completely. By
+ # leaving out a definition for the 'include' alias the plugin is
+ # signaled that there is no need to overwrite the GetFile command
+ # of doctools::idx::parse with a version calling out to the plugin
+ # manager, i.e. that it can still use the regular file operations.
+
+ useLocal import_json.tcl doctools::idx::import::json
+}
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-idx-import-json-1.0 {import, wrong#args} -body {
+ import
+} -returnCodes error -result {wrong # args: should be "import text configuration"}
+
+test doctools-idx-import-json-1.1 {import, wrong#args} -body {
+ import T
+} -returnCodes error -result {wrong # args: should be "import text configuration"}
+
+test doctools-idx-import-json-1.2 {import, wrong#args} -body {
+ import T C XXX
+} -returnCodes error -result {wrong # args: should be "import text configuration"}
+
+# idx_import_json tests, numbering starts at 2
+# -------------------------------------------------------------------------
+
+# We are checking that the various forms of json markup, as can be
+# generated by doctools::idx(::export(::json)) are valid input to the
+# json parser.
+#
+# section {} holds the non-canonical input we have to accept and make
+# canonical to higher layers.
+
+foreach {k section} {
+ 0 {}
+ 1 -ultracompact
+ 2 -indented
+ 3 -indalign
+} {
+ TestFilesProcess $mytestdir ok json$section serial-print -> n label input data expected {
+ test doctools-idx-import-json-2.$k.$n "doctools::idx::import::json, $label$section, ok" -body {
+ doctools::idx::structure print [import $data {}]
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# We test the error messages and codes thrown by the parser for a
+# variety of failure possibilities.
+
+TestFilesProcess $mytestdir fail json json-emsg -> n label input data expected {
+ test doctools-idx-import-json-3.$n "doctools::idx::import::json, $label, error message" -body {
+ import $data {}
+ } -returnCodes error -result $expected
+}
+
+#----------------------------------------------------------------------
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2idx/include/concept.inc b/tcllib/modules/doctools2idx/include/concept.inc
new file mode 100644
index 0000000..61b8e20
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/concept.inc
@@ -0,0 +1,58 @@
+[comment {
+ Description of the concepts used in keyword indices and how
+ their relate to each other. This is useful to understand the
+ serialization chosen for keyword indices.
+}]
+[list_begin enumerated]
+[enum]
+A [term {keyword index}] consists of a (possibly empty) set of [term keywords].
+
+[enum]
+Each keyword in the set is identified by its name.
+
+[enum]
+Each keyword has a (possibly empty) set of [term references].
+
+[enum]
+A reference can be associated with more than one keyword.
+
+[enum]
+A reference not associated with at least one keyword is not possible
+however.
+
+[enum]
+Each reference is identified by its target, specified as either an url
+or symbolic filename, depending on the type of reference ([const url],
+or [const manpage]).
+
+[enum]
+The type of a reference (url, or manpage) depends only on the
+reference itself, and not the keywords it is associated with.
+
+[enum]
+In addition to a type each reference has a descriptive label as
+well. This label depends only on the reference itself, and not the
+keywords it is associated with.
+
+[list_end]
+
+A few notes
+
+[list_begin enumerated]
+[enum]
+Manpage references are intended to be used for references to the
+documents the index is made for. Their target is a symbolic file name
+identifying the document, and export plugins may replace symbolic with
+actual file names, if specified.
+
+[enum]
+Url references are intended on the othre hand are inteded to be used
+for links to anything else, like websites. Their target is an url.
+
+[enum]
+While url and manpage references share a namespace for their
+identifiers, this should be no problem, given that manpage identifiers
+are symbolic filenames and as such they should never look like urls,
+the identifiers for url references.
+
+[list_end]
diff --git a/tcllib/modules/doctools2idx/include/dependencies.inc b/tcllib/modules/doctools2idx/include/dependencies.inc
new file mode 100644
index 0000000..92c683d
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/dependencies.inc
@@ -0,0 +1,44 @@
+[comment {
+ ASCII diagram of the dependencies between the doctools v2 idx packages
+ ======================================================================
+}][example {
+ ~~~~~~~~~~~ doctools::idx ~~~~~~~~~~~
+ ~~ | ~~
+ doctools::idx::export ~~~~~~~~~~~~~~~~~ | ~~~~~~~~~~~~~ doctools::idx::import
+ | | |
+ +---------------+-------------------------+ | +------------------+---------------+-----------------------+---------------+
+ | | | | | | | | |
+doctools::config = | | | = doctools::include doctools::config doctools::paths
+ | | | | |
+ doctools::idx::export::<*> | | | doctools::idx::import::<*>
+ docidx | | | docidx, json
+ json | | | | \\
+ html | | | doctools::idx::parse \\
+ nroff | | | | \\
+ wiki | | | +---------------+ json
+ text | | | | |
+ doctools::idx::structure |
+ |
+ +-------+---------------+
+ | |
+ doctools::html doctools::html::cssdefaults doctools::tcl::parse doctools::msgcat
+ | |
+ doctools::text doctools::nroff::man_macros =
+ |
+ doctools::msgcat::idx::<*>
+ c, en, de, fr
+ (fr == en for now)
+ ~~ Interoperable objects, without actual package dependencies
+ -- Package dependency, higher requires lower package
+ = Dynamic dependency through plugin system
+ <*> Multiple packages following the given form of naming.
+
+}][comment {
+ yaml export, import
+ tmml export, import
+ reStructured Text export
+ latex export
+
+ list, desc - old, not needed under new system, replaced by the nested-list serialization
+ null - old, not needed, deserialize docidx alone provides validation of input.
+}]
diff --git a/tcllib/modules/doctools2idx/include/export/config/docidx.inc b/tcllib/modules/doctools2idx/include/export/config/docidx.inc
new file mode 100644
index 0000000..c0b97c5
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/export/config/docidx.inc
@@ -0,0 +1,71 @@
+
+[include ../../format/docidx.inc]
+
+[section Configuration]
+
+The docidx export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+
+[arg_def string user]
+This standard configuration variable contains the name of the user
+running the process which invoked the export plugin.
+
+The plugin puts this information into the provenance comment at the
+beginning of the generated document.
+
+[arg_def string file]
+
+This standard configuration variable contains the name of the file the
+index came from. This variable may not be set or contain the empty
+string.
+
+The plugin puts this information, if defined, i.e. set and not the
+empty string, into the provenance comment at the beginning of the
+generated document.
+
+
+[arg_def boolean newlines]
+
+If this flag is set the plugin will break the generated docidx code
+across lines, with each markup command on a separate line.
+
+[para]
+
+If this flag is not set (the default), the whole document will be
+written on a single line, with minimum spacing between all elements.
+
+
+[arg_def boolean indented]
+
+If this flag is set the plugin will indent the markup commands
+according to the structure of indices. To make this work this also
+implies that [var newlines] is set. This effect is independent of the
+value for [var aligned] however.
+
+[para]
+
+If this flag is not set (the default), the output is formatted as per
+the values of [var newlines] and [var aligned], and no indenting is
+done.
+
+
+[arg_def boolean aligned]
+
+If this flag is set the generator ensures that the arguments for the
+[cmd manpage] and [cmd url] commands in a keyword section are aligned
+vertically for a nice table effect. To make this work this also
+implies that [var newlines] is set. This effect is independent of the
+value for [var indented] however.
+
+[para]
+
+If this flag is not set (the default), the output is formatted as per
+the values of [var newlines] and [var indented], and no alignment is
+done.
+
+[list_end]
+
+[emph Note] that this plugin ignores the standard configuration
+variables [var format], and [var map], and their values.
diff --git a/tcllib/modules/doctools2idx/include/export/config/html.inc b/tcllib/modules/doctools2idx/include/export/config/html.inc
new file mode 100644
index 0000000..af00470
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/export/config/html.inc
@@ -0,0 +1,203 @@
+[section Configuration]
+
+The html export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+
+[arg_def string user]
+This standard configuration variable contains the name of the user
+running the process which invoked the export plugin.
+
+The plugin puts this information into the provenance comment at the
+beginning of the generated document.
+
+[arg_def string file]
+
+This standard configuration variable contains the name of the file the
+index came from. This variable may not be set or contain the empty
+string.
+
+The plugin puts this information, if defined, i.e. set and not the
+empty string, into the provenance comment at the beginning of the
+generated document.
+
+
+[arg_def dictionary map]
+
+This standard configuration variable contains a dictionary mapping
+from the symbolic files names in manpage references to the actual
+filenames and/or urls to be used in the output.
+
+[para]
+
+Url references and symbolic file names without a mapping are used
+unchanged.
+
+
+[arg_def boolean newlines]
+
+If this flag is set the plugin will break the generated html code
+across lines, with each markup command on a separate line.
+
+[para]
+
+If this flag is not set (the default), the whole document will be
+written on a single line, with minimum spacing between all elements.
+
+
+[arg_def boolean indented]
+
+If this flag is set the plugin will indent the markup commands
+according to the structure of indices. To make this work this also
+implies that [var newlines] is set.
+
+[para]
+
+If this flag is not set (the default), the output is formatted as per
+the value of [var newlines], and no indenting is done.
+
+
+[arg_def string meta]
+
+This variable is meant to hold a fragment of HTML (default: empty).
+The fragment it contains will be inserted into the generated output in
+the <head> section of the document, just after the <title> tag.
+
+
+[arg_def string header]
+
+This variable is meant to hold a fragment of HTML (default: empty).
+The fragment it contains will be inserted into the generated output
+just after the <h1> title tag in the body of the document, in the
+class.header <div>'ision.
+
+
+
+[arg_def string footer]
+
+This variable is meant to hold a fragment of HTML (default:
+empty). The fragment it contains will be inserted into the generated
+output just before the </body> tag, in the class.footer <div>'ision.
+
+
+[arg_def dictionary kwid]
+
+The value of this variable (default: empty) maps keywords to the
+identifiers to use as their anchor names. Each keyword [var FOO] not
+found in the dictionary uses [const KW-][var FOO] as anchor,
+i.e. itself prefixed with the string [const KW-].
+
+
+[arg_def string sepline]
+
+The value of this variable is the string to use for the separator
+comments inserted into the output when the outpout is broken across
+lines and/or indented. The default string consists of 60 dashes.
+
+
+[arg_def integer kwidth]
+
+This variable holds the size of the keyword column in the main table
+generated by the plugin, in percent of the total width of the
+table. This is an integer number in the range of 1 to 99. Choosing a
+value outside of that range causes the generator to switch back to the
+defauly setting, 35 percent.
+
+
+[arg_def string dot]
+
+This variable contains a HTML fragment inserted between the entries of
+the navigation bar, and the references associated with each keyword.
+The default is the HTML entity &#183; i.e. the bullet character, also
+known as the "Greek middle dot", i.e. the unicode character 00B7.
+
+
+[arg_def string class.main]
+
+This variable contains the class name for the main <div>'ivision of
+the generated document. The default is [const doctools].
+
+
+[arg_def string class.header]
+
+This variable contains the class name for the header <div>'ision of
+the generated document. The default is [const idx-header]. This
+division contains the document title, the user specified [var header],
+if any, a visible separator line, and the navigation bar for quick
+access to each keyword section.
+
+
+[arg_def string class.title]
+
+This variable contains the class name for the <h1> tag enclosing the
+document title. The default is [const idx-title].
+
+
+[arg_def string class.navsep]
+
+This variable contains the class name for the <hr> separators in the
+header and footer sections of the generated document. The default is
+[const idx-navsep].
+
+
+[arg_def string class.navbar]
+
+This variable contains the class name for the navigation <div>'ision
+enclosing the navigation bar of the generated document. The default is
+[const idx-kwnav].
+
+
+[arg_def string class.contents]
+
+This variable contains the class name for the <table> holding the
+keywords and their references in the generated document. The default
+is [const idx-contents].
+
+
+[arg_def string class.leader]
+
+This variable contains the class name for the anchor names the plugin
+inserts into the keyword table when switching from one section to the
+next (Each section holds all keywords with a particular first
+character). The default is [const idx-leader].
+
+
+[arg_def string class.row0]
+
+This variable contains the class name used to label the even rows
+(<tr>) of the keyword table. The default is [const idx-even].
+
+
+[arg_def string class.row1]
+
+This variable contains the class name used to label the odd rows
+(<tr>) of the keyword table. The default is [const idx-odd].
+
+
+[arg_def string class.keyword]
+
+This variable contains the class name used to label the keyword
+cells/column (<td>) in the keyword table of the document. The default
+is [const idx-keyword].
+
+
+[arg_def string class.refs]
+
+This variable contains the class name used to label the reference
+cells/column (<td>) in the keyword table of the document. The default
+is [const idx-refs].
+
+
+[arg_def string class.footer]
+
+This variable contains the class name for the footer <div>'ision of
+the generated document. The default is [const idx-footer]. This
+division contains a browser-visible separator line and the user
+specified [var footer], if any.
+
+
+[list_end]
+
+[emph Note] that this plugin ignores the standard configuration
+variable [var format], and its value.
diff --git a/tcllib/modules/doctools2idx/include/export/config/json.inc b/tcllib/modules/doctools2idx/include/export/config/json.inc
new file mode 100644
index 0000000..24844b8
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/export/config/json.inc
@@ -0,0 +1,39 @@
+
+[include ../../format/json.inc]
+
+[section Configuration]
+
+The JSON export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+[arg_def boolean indented]
+
+If this flag is set the plugin will break the generated JSON code
+across lines and indent it according to its inner structure, with each
+key of a dictionary on a separate line.
+
+[para]
+
+If this flag is not set (the default), the whole JSON object will be
+written on a single line, with minimum spacing between all elements.
+
+
+[arg_def boolean aligned]
+
+If this flag is set the generator ensures that the values for the keys
+in a dictionary are vertically aligned with each other, for a nice
+table effect. To make this work this also implies that [var indented]
+is set.
+
+[para]
+
+If this flag is not set (the default), the output is formatted as per
+the value of [var indented], without trying to align the values for
+dictionary keys.
+
+[list_end]
+
+[emph Note] that this plugin ignores the standard configuration
+variables [var user], [var format], [var file], and [var map] and
+their values.
diff --git a/tcllib/modules/doctools2idx/include/export/config/nroff.inc b/tcllib/modules/doctools2idx/include/export/config/nroff.inc
new file mode 100644
index 0000000..3674055
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/export/config/nroff.inc
@@ -0,0 +1,40 @@
+[section Configuration]
+
+The nroff export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+
+[arg_def string user]
+This standard configuration variable contains the name of the user
+running the process which invoked the export plugin.
+
+The plugin puts this information into the provenance comment at the
+beginning of the generated document.
+
+[arg_def string file]
+
+This standard configuration variable contains the name of the file the
+index came from. This variable may not be set or contain the empty
+string.
+
+The plugin puts this information, if defined, i.e. set and not the
+empty string, into the provenance comment at the beginning of the
+generated document.
+
+
+[arg_def boolean inline]
+
+If this flag is set (default) the plugin will place the definitions of
+the man macro set directly into the output.
+
+[para]
+
+If this flag is not set, the plugin will place a reference to the
+definitions of the man macro set into the output, but not the macro
+definitions themselves.
+
+[list_end]
+
+[emph Note] that this plugin ignores the standard configuration
+variables [var format], and [var map], and their values.
diff --git a/tcllib/modules/doctools2idx/include/export/config/text.inc b/tcllib/modules/doctools2idx/include/export/config/text.inc
new file mode 100644
index 0000000..3d23a78
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/export/config/text.inc
@@ -0,0 +1,22 @@
+[section Configuration]
+
+The text export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+
+[arg_def dictionary map]
+
+This standard configuration variable contains a dictionary mapping
+from the symbolic files names in manpage references to the actual
+filenames and/or urls to be used in the output.
+
+[para]
+
+Url references and symbolic file names without a mapping are used
+unchanged.
+
+[list_end]
+
+[emph Note] that this plugin ignores the standard configuration
+variables [var user], [var file], and [var format], and their values.
diff --git a/tcllib/modules/doctools2idx/include/export/config/wiki.inc b/tcllib/modules/doctools2idx/include/export/config/wiki.inc
new file mode 100644
index 0000000..c74554f
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/export/config/wiki.inc
@@ -0,0 +1,42 @@
+[section {Wiki markup}]
+
+The basic syntax of the wiki markup generated by this plugin are
+described at [uri http://wiki.tcl.tk/14].
+
+[para]
+
+The plugin goes beyond the classic markup to generate proper headers
+and either a table or indented list of the keywords and their
+references.
+
+
+[section Configuration]
+
+The wiki export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+
+[arg_def dictionary map]
+
+This standard configuration variable contains a dictionary mapping
+from the symbolic files names in manpage references to the actual
+filenames and/or urls to be used in the output.
+
+[para]
+
+Url references and symbolic file names without a mapping are used
+unchanged.
+
+[arg_def enum style]
+
+This variable recognizes two values as legal, [const list] (default),
+and [const table].
+
+Depending on the value the plugin generates either a list- or
+table-based wiki page for the index.
+
+[list_end]
+
+[emph Note] that this plugin ignores the standard configuration
+variables [var user], [var file] and [var format], and their values.
diff --git a/tcllib/modules/doctools2idx/include/export/format/html.inc b/tcllib/modules/doctools2idx/include/export/format/html.inc
new file mode 100644
index 0000000..c8803f4
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/export/format/html.inc
@@ -0,0 +1,3 @@
+[require doctools::text]
+[require doctools::html]
+[require doctools::html::cssdefaults]
diff --git a/tcllib/modules/doctools2idx/include/export/format/json.inc b/tcllib/modules/doctools2idx/include/export/format/json.inc
new file mode 100644
index 0000000..9ef73f0
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/export/format/json.inc
@@ -0,0 +1 @@
+[require textutil::adjust]
diff --git a/tcllib/modules/doctools2idx/include/export/format/nroff.inc b/tcllib/modules/doctools2idx/include/export/format/nroff.inc
new file mode 100644
index 0000000..7883881
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/export/format/nroff.inc
@@ -0,0 +1,2 @@
+[require doctools::text]
+[require doctools::nroff::man_macros]
diff --git a/tcllib/modules/doctools2idx/include/export/format/null.inc b/tcllib/modules/doctools2idx/include/export/format/null.inc
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/export/format/null.inc
diff --git a/tcllib/modules/doctools2idx/include/export/format/text.inc b/tcllib/modules/doctools2idx/include/export/format/text.inc
new file mode 100644
index 0000000..be41da5
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/export/format/text.inc
@@ -0,0 +1 @@
+[require doctools::text]
diff --git a/tcllib/modules/doctools2idx/include/export/plugin.inc b/tcllib/modules/doctools2idx/include/export/plugin.inc
new file mode 100644
index 0000000..ed79cc5
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/export/plugin.inc
@@ -0,0 +1,55 @@
+[comment {-*- tcl -*- --- !doctools ---}]
+[manpage_begin doctools::idx::export::[vset PACKAGE] n [vset VERSION]]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc "[vset NAME] export plugin"]
+[category {Text formatter plugin}]
+[require Tcl 8.4]
+[require doctools::idx::export::[vset PACKAGE] [opt [vset VERSION]]]
+[include format/[vset REQUIRE].inc]
+[keywords doctools index serialization export [vset NAME]]
+[description]
+
+This package implements the doctools keyword index export plugin for
+the generation of [vset NAME] markup.
+
+[para]
+
+This is an internal package of doctools, for use by the higher level
+management packages handling keyword indices, especially [package \
+doctools::idx::export], the export manager.
+
+[para]
+
+Using it from a regular interpreter is possible, however only with
+contortions, and is not recommended.
+
+The proper way to use this functionality is through the package
+[package doctools::idx::export] and the export manager objects it
+provides.
+
+
+[section API]
+
+The API provided by this package satisfies the specification of the
+docidx export plugin API version 2.
+
+[list_begin definitions]
+
+[call [cmd export] [arg serial] [arg configuration]]
+
+This command takes the canonical serialization of a keyword index, as
+specified in section [sectref {Keyword index serialization format}],
+and contained in [arg serial], the [arg configuration], a dictionary,
+and generates [vset NAME] markup encoding the index.
+
+The created string is then returned as the result of the command.
+
+[list_end]
+
+[include config/[vset CONFIG].inc]
+[include ../serialization.inc]
+
+[vset CATEGORY doctools]
+[include ../../../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2idx/include/format/docidx.inc b/tcllib/modules/doctools2idx/include/format/docidx.inc
new file mode 100644
index 0000000..e3236fd
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/format/docidx.inc
@@ -0,0 +1,22 @@
+
+[section {[docidx] notation of keyword indices}]
+
+The docidx format for keyword indices, also called the
+[term {docidx markup language}], is too large to be covered in single
+section.
+
+The interested reader should start with the document
+
+[list_begin enum]
+[enum] [manpage {docidx language introduction}]
+[list_end]
+
+and then proceed from there to the formal specifications, i.e. the
+documents
+
+[list_begin enum]
+[enum] [manpage {docidx language syntax}] and
+[enum] [manpage {docidx language command reference}].
+[list_end]
+
+to get a thorough understanding of the language.
diff --git a/tcllib/modules/doctools2idx/include/format/json.inc b/tcllib/modules/doctools2idx/include/format/json.inc
new file mode 100644
index 0000000..6ca289a
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/format/json.inc
@@ -0,0 +1,54 @@
+
+[section {JSON notation of keyword indices}]
+
+The JSON format used for keyword indices is a direct translation of
+the [sectref {Keyword index serialization format}], mapping Tcl
+dictionaries as JSON objects and Tcl lists as JSON arrays.
+
+For example, the Tcl serialization
+
+[example {
+doctools::idx {
+ label {Keyword Index}
+ keywords {
+ changelog {changelog.man cvs.man}
+ conversion {doctools.man docidx.man doctoc.man apps/dtplite.man mpexpand.man}
+ cvs cvs.man
+ }
+ references {
+ apps/dtplite.man {manpage dtplite}
+ changelog.man {manpage doctools::changelog}
+ cvs.man {manpage doctools::cvs}
+ docidx.man {manpage doctools::idx}
+ doctoc.man {manpage doctools::toc}
+ doctools.man {manpage doctools}
+ mpexpand.man {manpage mpexpand}
+ }
+ title {}
+}
+}]
+
+is equivalent to the JSON string
+
+[example {
+{
+ "doctools::idx" : {
+ "label" : "Keyword Index",
+ "keywords" : {
+ "changelog" : ["changelog.man","cvs.man"],
+ "conversion" : ["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],
+ "cvs" : ["cvs.man"],
+ },
+ "references" : {
+ "apps\/dtplite.man" : ["manpage","dtplite"],
+ "changelog.man" : ["manpage","doctools::changelog"],
+ "cvs.man" : ["manpage","doctools::cvs"],
+ "docidx.man" : ["manpage","doctools::idx"],
+ "doctoc.man" : ["manpage","doctools::toc"],
+ "doctools.man" : ["manpage","doctools"],
+ "mpexpand.man" : ["manpage","mpexpand"]
+ },
+ "title" : ""
+ }
+}
+}]
diff --git a/tcllib/modules/doctools2idx/include/import/config/docidx.inc b/tcllib/modules/doctools2idx/include/import/config/docidx.inc
new file mode 100644
index 0000000..2df2b86
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/import/config/docidx.inc
@@ -0,0 +1 @@
+[include ../../format/docidx.inc]
diff --git a/tcllib/modules/doctools2idx/include/import/config/json.inc b/tcllib/modules/doctools2idx/include/import/config/json.inc
new file mode 100644
index 0000000..8d1e06e
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/import/config/json.inc
@@ -0,0 +1 @@
+[include ../../format/json.inc]
diff --git a/tcllib/modules/doctools2idx/include/import/format/docidx.inc b/tcllib/modules/doctools2idx/include/import/format/docidx.inc
new file mode 100644
index 0000000..5571bbd
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/import/format/docidx.inc
@@ -0,0 +1,12 @@
+[require doctools::idx::parse]
+[require doctools::idx::structure]
+[require doctools::msgcat]
+[require doctools::tcl::parse]
+[require fileutil]
+[require logger]
+[require snit]
+[require struct::list]
+[require struct::set]
+[require struct::stack]
+[require struct::tree]
+[require treeql]
diff --git a/tcllib/modules/doctools2idx/include/import/format/json.inc b/tcllib/modules/doctools2idx/include/import/format/json.inc
new file mode 100644
index 0000000..78d349a
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/import/format/json.inc
@@ -0,0 +1,2 @@
+[require doctools::idx::structure]
+[require json] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/include/import/plugin.inc b/tcllib/modules/doctools2idx/include/import/plugin.inc
new file mode 100644
index 0000000..09d0391
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/import/plugin.inc
@@ -0,0 +1,55 @@
+[comment {-*- tcl -*- --- !doctools ---}]
+[manpage_begin doctools::idx::import::[vset PACKAGE] n 0.1]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc "[vset NAME] import plugin"]
+[category {Text formatter plugin}]
+[require Tcl 8.4]
+[require doctools::idx::import::[vset PACKAGE] [opt 0.1]]
+[include format/[vset REQUIRE].inc]
+[keywords doctools index deserialization import [vset NAME]]
+[description]
+
+This package implements the doctools keyword index import plugin for
+the parsing of [vset NAME] markup.
+
+[para]
+
+This is an internal package of doctools, for use by the higher level
+management packages handling keyword indices, especially [package \
+doctools::idx::import], the import manager.
+
+[para]
+
+Using it from a regular interpreter is possible, however only with
+contortions, and is not recommended.
+
+The proper way to use this functionality is through the package
+[package doctools::idx::import] and the import manager objects it
+provides.
+
+
+[section API]
+
+The API provided by this package satisfies the specification of the
+docidx import plugin API version 2.
+
+[list_begin definitions]
+
+[call [cmd import] [arg string] [arg configuration]]
+
+This command takes the [arg string] and parses it as [vset NAME]
+markup encoding a keyword index, in the context of the specified
+[arg configuration] (a dictionary). The result of the command is the
+canonical serialization of that keyword index, in the form specified
+in section [sectref {Keyword index serialization format}].
+
+[list_end]
+
+
+[include config/[vset CONFIG].inc]
+[include ../serialization.inc]
+
+[vset CATEGORY doctools]
+[include ../../../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2idx/include/msgcat.inc b/tcllib/modules/doctools2idx/include/msgcat.inc
new file mode 100644
index 0000000..44d5407
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/msgcat.inc
@@ -0,0 +1,46 @@
+[comment {-*- tcl -*- --- !doctools ---}]
+[manpage_begin doctools::msgcat::idx::[vset PACKAGE] n 0.1]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc "Message catalog for the docidx parser ([vset NAME])"]
+[category {Documentation tools}]
+[require Tcl 8.4]
+[require msgcat]
+[require doctools::msgcat::idx::[vset PACKAGE] [opt 0.1]]
+[keywords doctools docidx {message catalog}]
+[keywords localization l10n internationalization i18n]
+[keywords {catalog package} {message package}]
+[keywords [vset NAME]]
+[description]
+
+The package [package doctools::msgcat::idx::[vset PACKAGE]] is a
+support module providing the [vset LONGNAME] language message catalog
+for the docidx parser in the doctools system version 2. As such it is
+an internal package a regular user (developer) should not be in direct
+contact with.
+
+[para]
+
+If you are such please go the documentation of either
+[list_begin enumerated]
+[enum] [package doctools::doc],
+[enum] [package doctools::toc], or
+[enum] [package doctools::idx]
+[list_end]
+[para]
+
+Within the system architecture this package resides under the package
+[package doctools::msgcat] providing the general message catalog
+management within the system. [emph Note] that there is [emph no]
+explicit dependency between the manager and catalog packages. The
+catalog is a plugin which is selected and loaded dynamically.
+
+
+[section API]
+
+This package has no exported API.
+
+
+[vset CATEGORY doctools]
+[include ../../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2idx/include/serialization.inc b/tcllib/modules/doctools2idx/include/serialization.inc
new file mode 100644
index 0000000..46b51ea
--- /dev/null
+++ b/tcllib/modules/doctools2idx/include/serialization.inc
@@ -0,0 +1,97 @@
+[section {Keyword index serialization format}]
+
+Here we specify the format used by the doctools v2 packages to
+serialize keyword indices as immutable values for transport,
+comparison, etc.
+
+[para]
+
+We distinguish between [term regular] and [term canonical]
+serializations. While a keyword index may have more than one regular
+serialization only exactly one of them will be [term canonical].
+
+[para]
+
+[list_begin definitions][comment {-- serializations --}]
+[def {regular serialization}]
+
+[list_begin enumerated][comment {-- regular points --}]
+[enum]
+An index serialization is a nested Tcl dictionary.
+
+[enum]
+This dictionary holds a single key, [const doctools::idx], and its
+value. This value holds the contents of the index.
+
+[enum]
+The contents of the index are a Tcl dictionary holding the title of
+the index, a label, and the keywords and references. The relevant keys
+and their values are
+
+[list_begin definitions][comment {-- keywords --}]
+[def [const title]]
+The value is a string containing the title of the index.
+
+[def [const label]]
+The value is a string containing a label for the index.
+
+[def [const keywords]]
+The value is a Tcl dictionary, using the keywords known to the index
+as keys. The associated values are lists containing the identifiers of
+the references associated with that particular keyword.
+
+[para]
+Any reference identifier used in these lists has to exist as a key in
+the [const references] dictionary, see the next item for its
+definition.
+
+[def [const references]]
+The value is a Tcl dictionary, using the identifiers for the
+references known to the index as keys. The associated values are
+2-element lists containing the type and label of the reference, in
+this order.
+
+[para]
+Any key here has to be associated with at least one keyword,
+i.e. occur in at least one of the reference lists which are the values
+in the [const keywords] dictionary, see previous item for its
+definition.
+
+[list_end][comment {-- keywords --}]
+
+[enum]
+The [term type] of a reference can be one of two values,
+
+[list_begin definitions][comment {-- types --}]
+[def [const manpage]]
+The identifier of the reference is interpreted as symbolic file name,
+refering to one of the documents the index was made for.
+
+[def [const url]]
+The identifier of the reference is interpreted as an url, refering to
+some external location, like a website, etc.
+
+[list_end][comment {-- types --}]
+[list_end][comment {-- regular points --}]
+
+[def {canonical serialization}]
+
+The canonical serialization of a keyword index has the format as
+specified in the previous item, and then additionally satisfies the
+constraints below, which make it unique among all the possible
+serializations of the keyword index.
+
+[list_begin enumerated][comment {-- canonical points --}]
+[enum]
+
+The keys found in all the nested Tcl dictionaries are sorted in
+ascending dictionary order, as generated by Tcl's builtin command
+[cmd {lsort -increasing -dict}].
+
+[enum]
+The references listed for each keyword of the index, if any, are
+listed in ascending dictionary order of their [emph labels], as
+generated by Tcl's builtin command [cmd {lsort -increasing -dict}].
+
+[list_end][comment {-- canonical points --}]
+[list_end][comment {-- serializations --}]
diff --git a/tcllib/modules/doctools2idx/msgcat_c.tcl b/tcllib/modules/doctools2idx/msgcat_c.tcl
new file mode 100644
index 0000000..b0f3d43
--- /dev/null
+++ b/tcllib/modules/doctools2idx/msgcat_c.tcl
@@ -0,0 +1,26 @@
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+mcset c docidx/char/syntax {Bad character in string}
+mcset c docidx/cmd/illegal {Illegal command "%1$s", not a docidx command} ; # Details: cmdname
+mcset c docidx/cmd/nested {Illegal use of "%1$s" as argument of other command} ; # Details: cmdname
+mcset c docidx/cmd/toomanyargs {Too many args for "%1$s", at most %2$d allowed} ; # Details: cmdname, max#args
+mcset c docidx/cmd/wrongargs {Wrong#args for "%1$s", need at least %2$d} ; # Details: cmdname, min#args
+mcset c docidx/eof/syntax {Bad <eof>}
+mcset c docidx/include/path/notfound {Include file "%1$s" not found} ; # Details: file name
+mcset c docidx/include/read-failed {Unable to read include file "%1$s", %2$s} ; # Details: file name and error msg
+mcset c docidx/include/syntax {Errors in include file "%1$s"}
+mcset c docidx/plaintext {Plain text beyond whitespace is not allowed}
+mcset c docidx/vset/varname/unknown {Unknown variable "%1$s"} ; # Details: variable name
+
+mcset c docidx/index_begin/missing {Expected [index_begin], not found}
+mcset c docidx/index_begin/syntax {Unexpected [index_begin], not allowed here}
+mcset c docidx/index_end/missing {Expected [index_end], not found}
+mcset c docidx/index_end/syntax {Unexpected [index_end], not allowed here}
+mcset c docidx/key/missing {Expected [key], not found}
+mcset c docidx/key/syntax {Unexpected [key], not allowed here}
+
+mcset c docidx/ref/redef {Bad redefinition of reference "%1$s", first (%2$s "%3$s"), now (%4$s "%5$s")}
+
+package provide doctools::msgcat::idx::c 0.1
diff --git a/tcllib/modules/doctools2idx/msgcat_de.tcl b/tcllib/modules/doctools2idx/msgcat_de.tcl
new file mode 100644
index 0000000..3148da3
--- /dev/null
+++ b/tcllib/modules/doctools2idx/msgcat_de.tcl
@@ -0,0 +1,26 @@
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+mcset de docidx/char/syntax {Unerwartetes Zeichen im String}
+mcset de docidx/cmd/illegal {Illegaler Befehl "%1$s", ist kein docidx Befehl} ; # Details: cmdname
+mcset de docidx/cmd/nested {Illegale Nutzung von "%1$s" als Argument eines anderen Befehles} ; # Details: cmdname
+mcset de docidx/cmd/toomanyargs {Zu viele Argumente fuer "%1$s", hoechstens %2$d moeglich} ; # Details: cmdname, max#args
+mcset de docidx/cmd/wrongargs {Zu wenig Argumente fuer "%1$s", mindestens %2$d notwendig} ; # Details: cmdname, min#args
+mcset de docidx/eof/syntax {Unerwartetes Ende der Datei}
+mcset de docidx/include/path/notfound {Include-Datei "%1$s" nicht gefunden} ; # Details: file name
+mcset de docidx/include/read-failed {Konnte Include-Datei "%1$s" nicht lesen: %2$s} ; # Details: file name and error msg
+mcset de docidx/include/syntax {Fehler in der Include-Datei "%1$s"}
+mcset de docidx/plaintext {Normaler Text ist (mit Ausnahme von reinem Leerraum) nicht erlaubt}
+mcset de docidx/vset/varname/unknown {Unbekannte Variable "%1$s"} ; # Details: variable name
+
+mcset de docidx/index_begin/missing {Erwarteter Befehl [index_begin] nicht vorhanden}
+mcset de docidx/index_begin/syntax {[index_begin] ist hier nicht erlaubt}
+mcset de docidx/index_end/missing {Erwarteter Befehl [index_end] nicht vorhanden}
+mcset de docidx/index_end/syntax {[index_end] ist hier nicht erlaubt}
+mcset de docidx/key/missing {Erwarteter Befehl [key] nicht vorhanden}
+mcset de docidx/key/syntax {[key] ist hier nicht erlaubt}
+
+mcset de docidx/ref/redef {Fehlerhafte Verwendung der Referenz "%1$s", zuerst (%2$s "%3$s"), jetzt (%4$s "%5$s")}
+
+package provide doctools::msgcat::idx::de 0.1
diff --git a/tcllib/modules/doctools2idx/msgcat_en.tcl b/tcllib/modules/doctools2idx/msgcat_en.tcl
new file mode 100644
index 0000000..97be163
--- /dev/null
+++ b/tcllib/modules/doctools2idx/msgcat_en.tcl
@@ -0,0 +1,26 @@
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+mcset en docidx/char/syntax {Bad character in string}
+mcset en docidx/cmd/illegal {Illegal command "%1$s", not a docidx command} ; # Details: cmdname
+mcset en docidx/cmd/nested {Illegal use of "%1$s" as argument of other command} ; # Details: cmdname
+mcset en docidx/cmd/toomanyargs {Too many args for "%1$s", at most %2$d allowed} ; # Details: cmdname, max#args
+mcset en docidx/cmd/wrongargs {Wrong#args for "%1$s", need at least %2$d} ; # Details: cmdname, min#args
+mcset en docidx/eof/syntax {Bad <eof>}
+mcset en docidx/include/path/notfound {Include file "%1$s" not found} ; # Details: file name
+mcset en docidx/include/read-failed {Unable to read include file "%1$s", %2$s} ; # Details: file name and error msg
+mcset en docidx/include/syntax {Errors in include file "%1$s"}
+mcset en docidx/plaintext {Plain text beyond whitespace is not allowed}
+mcset en docidx/vset/varname/unknown {Unknown variable "%1$s"} ; # Details: variable name
+
+mcset en docidx/index_begin/missing {Expected [index_begin], not found}
+mcset en docidx/index_begin/syntax {Unexpected [index_begin], not allowed here}
+mcset en docidx/index_end/missing {Expected [index_end], not found}
+mcset en docidx/index_end/syntax {Unexpected [index_end], not allowed here}
+mcset en docidx/key/missing {Expected [key], not found}
+mcset en docidx/key/syntax {Unexpected [key], not allowed here}
+
+mcset en docidx/ref/redef {Bad redefinition of reference "%1$s", first (%2$s "%3$s"), now (%4$s "%5$s")}
+
+package provide doctools::msgcat::idx::en 0.1
diff --git a/tcllib/modules/doctools2idx/msgcat_fr.tcl b/tcllib/modules/doctools2idx/msgcat_fr.tcl
new file mode 100644
index 0000000..e8a3147
--- /dev/null
+++ b/tcllib/modules/doctools2idx/msgcat_fr.tcl
@@ -0,0 +1,29 @@
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+# The texts are in english because I have do not have enough knowledge
+# of french to make the translation.
+
+mcset fr docidx/char/syntax {Bad character in string}
+mcset fr docidx/cmd/illegal {Illegal command "%1$s", not a docidx command} ; # Details: cmdname
+mcset fr docidx/cmd/nested {Illegal use of "%1$s" as argument of other command} ; # Details: cmdname
+mcset fr docidx/cmd/toomanyargs {Too many args for "%1$s", at most %2$d allowed} ; # Details: cmdname, max#args
+mcset fr docidx/cmd/wrongargs {Wrong#args for "%1$s", need at least %2$d} ; # Details: cmdname, min#args
+mcset fr docidx/eof/syntax {Bad <eof>}
+mcset fr docidx/include/path/notfound {Include file "%1$s" not found} ; # Details: file name
+mcset fr docidx/include/read-failed {Unable to read include file "%1$s", %2$s} ; # Details: file name and error msg
+mcset fr docidx/include/syntax {Errors in include file "%1$s"}
+mcset fr docidx/plaintext {Plain text beyond whitespace is not allowed}
+mcset fr docidx/vset/varname/unknown {Unknown variable "%1$s"} ; # Details: variable name
+
+mcset fr docidx/index_begin/missing {Expected [index_begin], not found}
+mcset fr docidx/index_begin/syntax {Unexpected [index_begin], not allowed here}
+mcset fr docidx/index_end/missing {Expected [index_end], not found}
+mcset fr docidx/index_end/syntax {Unexpected [index_end], not allowed here}
+mcset fr docidx/key/missing {Expected [key], not found}
+mcset fr docidx/key/syntax {Unexpected [key], not allowed here}
+
+mcset fr docidx/ref/redef {Bad redefinition of reference "%1$s", first (%2$s "%3$s"), now (%4$s "%5$s")}
+
+package provide doctools::msgcat::idx::fr 0.1
diff --git a/tcllib/modules/doctools2idx/parse.tcl b/tcllib/modules/doctools2idx/parse.tcl
new file mode 100644
index 0000000..62b9cfe
--- /dev/null
+++ b/tcllib/modules/doctools2idx/parse.tcl
@@ -0,0 +1,1043 @@
+# -*- tcl -*-
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Parser for docidx formatted input. The result is a struct::tree
+# repesenting the contents of the document in a structured form.
+
+# - root = index, attributes for title and label.
+# - children of the root = keys of the index, attribute for keyword.
+# - children of the keys = manpage and url references for the key,
+# attributes for reference and label.
+#
+# The order of the keywords under root, and of the references under
+# their keyword reflects the order of the information in the parsed
+# document.
+
+# Attributes in the nodes, except root provide location information,
+# i.e. refering from there in the input the information is coming from
+# (human-readable output: line/col for end of token, offset start/end
+# for range covered by token.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.4 ; # Required runtime.
+package require doctools::idx::structure ; # Parse Tcl script, like subst.
+package require doctools::msgcat ; # Error message L10N
+package require doctools::tcl::parse ; # Parse Tcl script, like subst.
+package require fileutil ; # Easy loading of files.
+package require logger ; # User feedback.
+package require snit ; # OO system.
+package require struct::list ; # Assign
+package require struct::tree ; # Internal syntax tree
+
+# # ## ### ##### ######## ############# #####################
+##
+
+logger::initNamespace ::doctools::idx::parse
+snit::type ::doctools::idx::parse {
+ # # ## ### ##### ######## #############
+ ## Public API
+
+ typemethod file {path} {
+ log::debug [list $type file]
+ return [$type text [fileutil::cat $path] $path]
+ }
+
+ typemethod text {text {path {}}} {
+ log::debug [list $type text]
+
+ set ourfile $path
+
+ array set vars [array get ourvars]
+ array set _file {}
+ ClearErrors
+
+ set t [struct::tree AST]
+
+ Process $t $text [$t rootname] vars _file
+ StopOnErrors
+
+ ReshapeTree $t
+ StopOnErrors
+
+ set serial [Serialize $t]
+ StopOnErrors
+
+ $t destroy
+ return $serial
+ }
+
+ # # ## ### ##### ######## #############
+ ## Manage symbol table (vset variables).
+
+ typemethod vars {} {
+ return [array get ourvars]
+ }
+
+ typemethod {var set} {name value} {
+ set ourvars($name) $value
+ return
+ }
+
+ typemethod {var load} {dict} {
+ array set ourvars $dict
+ return
+ }
+
+ typemethod {var unset} {args} {
+ if {![llength $args]} { lappend args * }
+ foreach pattern $args {
+ array unset ourvars $pattern
+ }
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Manage search paths for include files.
+
+ typemethod includes {} {
+ return $ourincpaths
+ }
+
+ typemethod {include set} {paths} {
+ set ourincpaths [lsort -uniq $paths]
+ return
+ }
+
+ typemethod {include add} {path} {
+ lappend ourincpaths $path
+ set ourincpaths [lsort -uniq $ourincpaths]
+ return
+ }
+
+ typemethod {include remove} {path} {
+ set pos [lsearch $ourincpaths $path]
+ if {$pos < 0} return
+ set ourincpaths [lreplace $ourincpaths $pos $pos]
+ return
+ }
+
+ typemethod {include clear} {} {
+ set ourincpaths {}
+ return
+ }
+
+ # # ## ### ##### ######## #############
+
+ proc Process {t text root vv fv} {
+ upvar 1 $vv vars $fv _file
+
+ DropChildren $t $root
+
+ # Phase 1. Generate the basic syntax tree
+
+ if {[catch {
+ doctools::tcl::parse text $t $text $root
+ } msg]} {
+ if {![string match {doctools::tcl::parse *} $::errorCode]} {
+ # Not a parse error, rethrow.
+ return \
+ -code error \
+ -errorcode $::errorCode \
+ -errorinfo $::errorInfo \
+ $msg
+ }
+
+ # Parse error, low-level syntax breakdown, extract the
+ # machine-info from the errorCode, and report internally.
+ # See the documentation of doctools::tcl::parse for the
+ # definition of the format.
+ struct::list assign $::errorCode _ msg pos line col
+ # msg in {eof, char}
+ ReportAt $_file($root) [list $pos $pos] $line $col docidx/$msg/syntax {}
+ return 0
+ }
+
+ #doctools::parse::tcl::ShowTreeX $t {Raw Result}
+
+ # Phase 2. Check for errors.
+
+ CheckBasicConstraints $t $root _file
+ ResolveVarsAndIncludes $t $root vars _file
+ return 1
+ }
+
+ proc CheckBasicConstraints {t root fv} {
+ ::variable ourfile
+ upvar 1 $fv _file
+
+ # Bottom-up walk through the nodes starting at the current
+ # root.
+
+ $t walk $root -type dfs -order pre n {
+ # Ignore the root node itself. Except for one thing: The
+ # path information is remembered for the root as well.
+
+ set _file($n) $ourfile
+ #puts "_file($n) = $ourfile"
+ if {$n eq $root} continue
+
+ switch -exact [$t get $n type] {
+ Text {
+ # Texts at the top level are irrelevant and
+ # removed. They have to contain only whitespace as
+ # well.
+ if {[$t depth $n] == 1} {
+ if {[regexp {[^[:blank:]\n]} [$t get $n text]]} {
+ Error $t $n docidx/plaintext
+ }
+ MarkDrop $n
+ }
+ }
+ Word {
+ # Word nodes we ignore. They are just argument
+ # aggregators. They will be gone later, when
+ # reduce arguments to their text form.
+ }
+ Command {
+ set cmdname [$t get $n text]
+ set parens [$t parent $n]
+
+ if {$parens eq $root} {
+ set parentt {}
+ } else {
+ set parentt [$t get $parens type]
+ }
+ set nested 0
+
+ if {($parentt eq "Command") || ($parentt eq "Word")} {
+ # Commands can be children/arguments of other
+ # commands only in very restricted
+ # circumstances => rb, lb, vset/1.
+ set nested 1
+ if {![Nestable $t $n $cmdname errcmdname] && [Legal $cmdname]} {
+ # Report only legal un-nestable commands.
+ # Illegal commands get their own report,
+ # see below.
+ MakeErrorMsg $t $n docidx/cmd/nested $errcmdname
+ }
+ }
+
+ if {![Legal $cmdname]} {
+ # Deletion is safe because we are walking
+ # bottom up. If nested we drop only the
+ # children and replace this node with a fake.
+ if {$nested} {
+ MakeErrorMsg $t $n docidx/cmd/illegal $cmdname
+ } else {
+ Error $t $n docidx/cmd/illegal $cmdname
+ MarkDrop $n
+ }
+
+ continue
+ }
+
+ # Check arguments of the legal commands only.
+ ArgInfo $cmdname min max
+ set argc [llength [$t children $n]]
+
+ if {$argc < $min} {
+ MakeErrorMsg $t $n docidx/cmd/wrongargs $cmdname $min
+ } elseif {$argc > $max} {
+ MakeErrorMsg $t $n docidx/cmd/toomanyargs $cmdname $max
+ }
+
+ # Convert the quoting commands for bracket into
+ # equivalent text nodes, and remove comments.
+ if {$cmdname eq "lb"} {
+ MakeText $t $n "\["
+ } elseif {$cmdname eq "rb"} {
+ MakeText $t $n "\]"
+ } elseif {$cmdname eq "comment"} {
+ # Remove comments or replace with error node (nested).
+ if {$nested} {
+ MakeError $t $n
+ } else {
+ MarkDrop $n
+ }
+ }
+ }
+ }
+ }
+
+ # Kill the nodes marked for removal now that the walker is not
+ # accessing them any longer.
+ PerformDrop $t
+
+ #doctools::parse::tcl::ShowTreeX $t {Basic Constraints}
+ return
+ }
+
+ proc ResolveVarsAndIncludes {t root vv fv} {
+ upvar 1 $vv vars $fv _file
+
+ # Now resolve include and vset uses ... This has to be done at
+ # the same time, as each include may (re)define variables.
+
+ # Bottom-up walk. Children before parent, and from the left =>
+ # Nested vset uses are resolved in the proper order.
+
+ $t walk $root -type dfs -order post n {
+ # Ignore the root node itself.
+ if {$n eq $root} continue
+
+ set ntype [$t get $n type]
+
+ switch -exact -- $ntype {
+ Text - Error {
+ # Ignore these nodes.
+ }
+ Word {
+ # Children have to be fully converted to Text, or,
+ # in case of trouble, Error. Aggregate the
+ # information.
+ CollapseWord $t $n
+ }
+ Command {
+ set cmdname [$t get $n text]
+
+ switch -exact -- $cmdname {
+ vset {
+ set argv [$t children $n]
+ switch -exact -- [llength $argv] {
+ 1 {
+ VariableUse $t $n [lindex $argv 0]
+ }
+ 2 {
+ struct::list assign $argv var val
+ VariableDefine $t $n $var $val
+ }
+ }
+ # vset commands at the structural toplevel are
+ # irrelevant and removed.
+ if {[$t depth $n] == 1} {
+ MarkDrop $n
+ }
+ }
+ include {
+ # Pulls vars, _file from this scope
+ ProcessInclude $t $n [lindex [$t children $n] 0]
+ }
+ default {
+ # For all other commands move the argument
+ # information into an attribute. Errors in
+ # the argument cause the command to conert
+ # into an error.
+ CollapseArguments $t $n
+ }
+ }
+ }
+ }
+ }
+
+ # Kill the nodes marked for removal now that the walker is
+ # not accessing them any longer.
+ PerformDrop $t
+
+ #doctools::parse::tcl::ShowTreeX $t {Vars/Includes Resolved}
+ return
+ }
+
+ proc ReshapeTree {t} {
+ upvar 1 _file _file
+
+ # We are assuming that there are no illegal commands in the
+ # tree, and further that all of lb, rb, vset, comment, and
+ # include are gone as well, per the operation of the previous
+ # phases (-> CheckBasicConstraints, ResolveVarsAndIncludes).
+ # The only commands which can occur here are
+ #
+ # index_begin, index_end, key, manpage, url
+
+ # Grammar:
+ # INDEX := index_begin KEYS index_end
+ # KEYS := { key ITEMS }
+ # ITEMS := { manpage | url }
+
+ # Hand coded LL(1) parser with explicit state machine. No
+ # stack required for this grammar.
+
+ set root [$t rootname]
+ set children [$t children $root]
+ lappend children $root
+
+ $t set $root text <EOF>
+ $t set $root range {0 0}
+ $t set $root line 1
+ $t set $root col 0
+
+ set at {}
+ set state INDEX
+
+ foreach n $children {
+ set cmdname [$t get $n text]
+ #puts <$n>|$cmdname|$state|
+
+ # We store the location of the last node in the root, for
+ # use when an unexpected eof triggers an error.
+ if {$n ne $root} {
+ $t set $root range [$t get $n range]
+ $t set $root line [$t get $n line]
+ $t set $root col [$t get $n col]
+ }
+
+ # LL(1) parser table. State/Nexttoken determine action and
+ # next state.
+ switch -exact -- [list $state $cmdname] {
+ {INDEX index_begin} {
+ # Pull arguments of the proper index_begin up into
+ # the root. Drop the expected node.
+ $t set $root argv [$t get $n argv]
+ $t delete $n
+ # Starting series of keywwords and their
+ # references. Destination is root, not that it
+ # matters, and we remember the state.
+ set at $root
+ set state KEYS
+ }
+ {KEYS key} {
+ # Starting series of references in a keyword.
+ # Destination for movement is this keyword, and we
+ # remember the state.
+ set at $n
+ set state ITEMS
+ }
+ {ITEMS index_end} -
+ {KEYS index_end} {
+ # End of the document reached, with proper closing
+ # of keys and references. Drop the node, and jump to
+ # the end state
+ set state EOF
+ $t delete $n
+ }
+ {ITEMS manpage} -
+ {ITEMS url} {
+ # Move references to their keyword.
+ $t move $at end $n
+ }
+ {ITEMS key} {
+ # Move destination of references forward.
+ set at $n
+ }
+ {EOF <EOF>} {
+ # Good, really reached the end. Nothing to be
+ # done.
+ }
+ {INDEX index_end} -
+ {INDEX key} -
+ {INDEX manpage} -
+ {INDEX url} -
+ {INDEX <EOF>} {
+ Error $t $n docidx/index_begin/missing
+ if {$n ne $root} {
+ $t delete $n
+ }
+ }
+ {KEYS index_begin} -
+ {KEYS manpage} -
+ {KEYS url} {
+ Error $t $n docidx/key/missing
+ if {$n ne $root} {
+ $t delete $n
+ }
+ }
+ {EOF index_begin} -
+ {EOF index_end} -
+ {EOF key} -
+ {EOF manpage} -
+ {EOF url} -
+ {ITEMS index_begin} {
+ # TODO ?! Split this, and add message which command was expected.
+ # Unexpected and wrong. The node is dropped.
+ Error $t $n docidx/$cmdname/syntax
+ $t delete $n
+ }
+ {KEYS <EOF>} -
+ {ITEMS <EOF>} {
+ Error $t $n docidx/index_end/missing
+ }
+ }
+ }
+
+ $t unset $root text
+ $t unset $root range
+ $t unset $root line
+ $t unset $root col
+
+ #doctools::parse::tcl::ShowTreeX $t Shaped/Structure
+ return
+ }
+
+ proc Serialize {t} {
+ upvar 1 _file _file
+ # We assume here that the tree is already in the correct
+ # shape/structure, i.e. of at most depth 2, a root, optionally
+ # a series of children for the keywords, and each keyword with
+ # an optional series of children for the items, i.e. manpage
+ # and url references.
+
+ # We now extract the basic information about the index from
+ # the tree, do some higher level checking on the references,
+ # and return the serialization of the index generated from the
+ # extracted data.
+
+ set error 0
+ set root [$t rootname]
+
+ # Root delivers index label and title.
+ struct::list assign [$t get $root argv] label title
+
+ array set k {}
+ array set r {}
+
+ # Each keyword in the tree
+ foreach key [$t children $root] {
+ set kw [lindex [$t get $key argv] 0]
+ set k($kw) {}
+
+ # Each reference in a key.
+ foreach item [$t children $key] {
+ struct::list assign [$t get $item argv] id rlabel
+ set rtype [$t get $item text]
+ set decl [list $rtype $rlabel]
+
+ lappend k($kw) $id
+
+ # Checking that all uses of a reference use the same
+ # type and label.
+ if {[info exists r($id)]} {
+ if {$r($id) ne $decl} {
+ struct::list assign $r($id) otype olabel
+ MakeErrorMsg $t $item docidx/ref/redef \
+ $id $otype $olabel $rtype $rlabel
+ set error 1
+ }
+ continue
+ }
+ set r($id) $decl
+ }
+ }
+
+ if {$error} return
+ # Caller will handle the errors.
+
+ ## ### ### ### ######### ######### #########
+ ## The part below is identical to the serialization backend of
+ ## command 'doctools::idx::structure merge'.
+
+ # Now construct the result, from the inside out, with proper
+ # sorting at all levels.
+
+ set keywords {}
+ foreach kw [lsort -dict [array names k]] {
+ # Sort references in a keyword by their _labels_.
+ set tmp {}
+ foreach rid $k($kw) { lappend tmp [list $rid [lindex $r($rid) 1]] }
+ set refs {}
+ foreach item [lsort -dict -index 1 $tmp] {
+ lappend refs [lindex $item 0]
+ }
+ lappend keywords $kw $refs
+ }
+
+ set references {}
+ foreach rid [lsort -dict [array names r]] {
+ lappend references $rid $r($rid)
+ }
+
+ set serial [list doctools::idx \
+ [list \
+ label $label \
+ keywords $keywords \
+ references $references \
+ title $title]]
+
+
+ # Caller verify, ensure contract
+ #::doctools::idx::structure verify-as-canonical $serial
+ return $serial
+ }
+
+ # # ## ### ##### ######## #############
+
+ proc CollapseArguments {t n} {
+ #puts __CA($n)
+
+ set ok 1
+ set argv {}
+ foreach ch [$t children $n] {
+ lappend argv [$t get $ch text]
+ if {[$t get $ch type] eq "Error"} {
+ set ok 0
+ break
+ }
+ }
+ if {$ok} {
+ $t set $n argv $argv
+ DropChildren $t $n
+ } else {
+ MakeError $t $n
+ }
+ return
+ }
+
+ proc CollapseWord {t n} {
+ #puts __CW($n)
+
+ set ok 1
+ set text {}
+ foreach ch [$t children $n] {
+ append text [$t get $ch text]
+ if {[$t get $ch type] eq "Error"} {
+ set ok 0
+ break
+ }
+ }
+ if {$ok} {
+ MakeText $t $n $text
+ } else {
+ MakeError $t $n
+ }
+ return
+ }
+
+ proc VariableUse {t n var} {
+ upvar 1 vars vars _file _file
+
+ # vset/1 - the command returns text information to the
+ # caller. Extract the argument data.
+
+ set vartype [$t get $var type]
+ set varname [$t get $var text]
+
+ # Remove the now superfluous argument nodes.
+ DropChildren $t $n
+
+ if {$vartype eq "Error"} {
+ # First we check if the command is in trouble because it
+ # has a bogus argument. If so we convert it into an error
+ # node to signal even higher commands, and ignore it. We
+ # do not report an error, as the actual problem was
+ # reported already.
+
+ MakeError $t $n
+ } elseif {![info exists vars($varname)]} {
+ # Secondly we check if the referenced variable is
+ # known. If not it is trouble, and we report it.
+
+ MakeErrorMsg $t $n docidx/vset/varname/unknown $varname
+ } elseif {[$t depth $n] == 1} {
+ # Commands at the structural toplevel are irrelevant and
+ # removed (see caller). They have to checked again however
+ # to see if the use introduced non-whitespace where it
+ # should not be.
+
+ if {[regexp {[^[:blank:]\n]} $vars($varname)]} {
+ Error $t $n docidx/plaintext
+ }
+ } else {
+ MakeText $t $n $vars($varname)
+ }
+ }
+
+ proc VariableDefine {t n var val} {
+ upvar 1 vars vars
+
+ # vset/2 - the command links a variable to a value. Extract
+ # the argument data.
+
+ set vartype [$t get $var type]
+ set valtype [$t get $val type]
+ set varname [$t get $var text]
+ set value [$t get $val text]
+
+ # Remove the now superfluous argument nodes.
+ DropChildren $t $n
+
+ if {($vartype eq "Error") || ($valtype eq "Error")} {
+ # First we check if the command is in trouble because it
+ # has one or more bogus arguments. If so we convert it
+ # into an error node to signal even higher commands, and
+ # ignore it. We do not report an error, as the actual
+ # problem was reported already.
+
+ MakeError $t $n
+ return
+ }
+
+ # And save the change to the symbol table we are lugging
+ # around during the processing.
+
+ set vars($varname) $value
+ return
+ }
+
+ proc ProcessInclude {t n path} {
+ upvar 1 vars vars _file _file
+ ::variable ourfile
+
+ # include - the command returns file content and inserts it in
+ # the place of the command. First extract the argument data
+
+ set pathtype [$t get $path type]
+ set pathname [$t get $path text]
+
+ # Remove the now superfluous argument nodes.
+ DropChildren $t $n
+
+ # Check for problems stemming from other trouble.
+ if {$pathtype eq "Error"} {
+ # First we check if the command is in trouble because it
+ # has a bogus argument. If so convert it into an error
+ # node to signal even higher commands, and ignore it. We
+ # do not report an error, as the actual problem was
+ # reported already.
+
+ MakeError $t $n
+ return
+ }
+
+ if {![GetFile $ourfile $pathname text fullpath error emsg]} {
+ switch -exact -- $error {
+ notfound { Error $t $n docidx/include/path/notfound $pathname }
+ notread { Error $t $n docidx/include/read-failed $fullpath $emsg }
+ }
+ MarkDrop $n
+ return
+ }
+
+ # Parse the file. This also resolves variables further.
+
+ set currenterrors [GetErrors]
+ set currentpath $ourfile
+ ClearErrors
+
+ # WIBNI :: Remember the path as relative to the current path.
+ set ourfile $fullpath
+ if {![Process $t $text $n vars _file]} {
+
+ set newerrors [GetErrors]
+ SetErrors $currenterrors
+ set ourfile $currentpath
+ Error $t $n docidx/include/syntax $fullpath $newerrors
+ MarkDrop $n
+ return
+ }
+
+ if {![$t numchildren $n]} {
+ # Inclusion did not generate additional content, we can
+ # ignore the command completely.
+ MarkDrop $n
+ return
+ }
+
+ # Create marker nodes which show the file entry/exit
+ # transitions. Disabled, makes shaping tree structure too
+ # complex. And checking the syntax as well, if we wish to have
+ # only proper complete structures in an include file. Need
+ # proper LR parser for that (is not LL(1)), or maybe even
+ # something like earley-aycock for full handling of an
+ # ambigous grammar.
+ if 0 {
+ set fstart [$t insert $n 0]
+ set fstop [$t insert $n end]
+
+ $t set $fstart type Command
+ $t set $fstop type Command
+
+ $t set $fstart text include_begin
+ $t set $fstop text include_end
+
+ $t set $fstart path $fullpath
+ $t set $fstop path $fullpath
+ }
+ # Remove the include command itself, merging its children
+ # into the place it occupied in its parent.
+ $t cut $n
+ return
+ }
+
+ # # ## ### ##### ######## #############
+
+ ## Note: The import plugin for docidx rewrites the 'GetFile'
+ ## command below to make use of an alias provided by the
+ ## plugin manager. This re-enables the ability of this class
+ ## to handle include files which would otherwise be gone due
+ ## to the necessary file operations (exists, isfile,
+ ## readable, open, read) be disallowed by the safe
+ ## environment the plugin operates in.
+ ##
+ ## Any changes to GetFile have to reviewed for their impact on
+ ## doctools::idx::import::docidx, and possibly ported over.
+
+ proc GetFile {currentfile path dv pv ev mv} {
+ upvar 1 $dv data $pv fullpath $ev error $mv emessage
+ set data {}
+ set error {}
+ set emessage {}
+
+ # Find the file, or not.
+ set fullpath [Locate $path]
+ if {$fullpath eq {}} {
+ set fullpath $path
+ set error notfound
+ return 0
+ }
+
+ # Read contents, or not.
+ if {[catch {
+ set data [fileutil::cat $fullpath]
+ } msg]} {
+ set error notread
+ set emessage $msg
+ return 0
+ }
+
+ return 1
+ }
+
+ proc Locate {path} {
+ upvar 1 currentfile currentfile
+
+ if {$currentfile ne {}} {
+ set pathstosearch \
+ [linsert $ourincpaths 0 \
+ [file dirname [file normalize $currentfile]]]
+ } else {
+ set pathstosearch $ourincpaths
+ }
+
+ foreach base $pathstosearch {
+ set try [file join $base $path]
+ if {![file exists $try]} continue
+ return $try
+ }
+ # Nothing found
+ return {}
+ }
+
+ # # ## ### ##### ######## #############
+ ## Management of nodes to kill
+
+ proc MarkDrop {n} {
+ ::variable ourtokill
+ lappend ourtokill $n
+ #puts %%mark4kill=$n|[info level -1]
+ return
+ }
+
+ proc DropChildren {t n} {
+ foreach child [$t children $n] {
+ MarkDrop $child
+ }
+ return
+ }
+
+ proc PerformDrop {t} {
+ ::variable ourtokill
+ #puts __PD($t)=<[join $ourtokill ,]>
+ foreach n $ourtokill {
+ #puts x($n/[$t exists $n])
+ if {![$t exists $n]} continue
+ #puts ^^DEL($n)
+ $t delete $n
+ }
+ set ourtokill {}
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Command predicates
+
+ proc Nestable {t n cmdname cv} {
+ upvar 1 $cv outname
+ set outname $cmdname
+ switch -exact -- $cmdname {
+ lb - rb { return 1 }
+ vset {
+ if {[$t numchildren $n] == 1} {
+ return 1
+ }
+ append outname /2
+ }
+ }
+ return 0
+ }
+
+ proc Legal {cmdname} {
+ ::variable ourcmds
+ #parray ourcmds
+ return [info exists ourcmds($cmdname)]
+ }
+
+ proc ArgInfo {cmdname minv maxv} {
+ ::variable ourcmds
+ upvar 1 $minv min $maxv max
+ foreach {min max} $ourcmds($cmdname) break
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Higher level error handling, node conversion.
+
+ proc MakeError {t n} {
+ #puts %%error=$n|[info level -1]
+ $t set $n type Error
+ DropChildren $t $n
+ return
+ }
+
+ proc MakeErrorMsg {t n msg args} {
+ upvar 1 _file _file
+ #puts %%error=$n|[info level -1]
+ Report $t $n $msg $args
+ $t set $n type Error
+ DropChildren $t $n
+ return
+ }
+
+ proc MakeText {t n text} {
+ #puts %%text=$n|[info level -1]
+ $t set $n type Text
+ $t set $n text $text
+ DropChildren $t $n
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Error reporting
+
+ proc Error {t n text args} {
+ upvar 1 _file _file
+ Report $t $n $text $args
+ }
+
+ proc Report {t n text details} {
+ upvar 1 _file _file
+ ReportAt $_file($n) [$t get $n range] [$t get $n line] [$t get $n col] $text $details
+ return
+ }
+
+ proc ReportAt {file range line col text details} {
+ ::variable ourerrors
+ #puts !![list $file $range $line $col $text $details]/[info level -1]
+ lappend ourerrors [list $file $range $line $col $text $details]
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Error Management
+
+ proc ClearErrors {} {
+ ::variable ourerrors {}
+ return
+ }
+
+ proc GetErrors {} {
+ ::variable ourerrors
+ return $ourerrors
+ }
+
+ proc SetErrors {t} {
+ ::variable ourerrors $t
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Error Response
+
+ proc StopOnErrors {} {
+ ::variable ourerrors
+ if {![llength $ourerrors]} return
+
+ upvar 1 t t
+ $t destroy
+
+ doctools::msgcat::init idx
+ set info [SortMessages $ourerrors]
+ set msg [Formatted $info {}]
+
+ return -code error -errorcode $info $msg
+ }
+
+ proc Formatted {errors prefix} {
+ set lines {}
+ foreach err $errors {
+ struct::list assign $err file range line col msg details
+ #8.5: set text [msgcat::mc $msg {*}$details]
+ set text [eval [linsert $details 0 msgcat::mc $msg]]
+ if {![string length $prefix] && [string length $file]} {
+ set prefix "\"$file\" "
+ }
+
+ lappend lines "${prefix}error on line $line.$col: $text"
+
+ if {$msg eq "docidx/include/syntax"} {
+ struct::list assign $details path moreerrors
+ lappend lines [Formatted [SortMessages $moreerrors] "\"$path\": "]
+ }
+ }
+ return [join $lines \n]
+ }
+
+ proc SortMessages {messages} {
+ return [lsort -dict -index 0 \
+ [lsort -dict -index 2 \
+ [lsort -dict -index 3 \
+ [lsort -unique $messages]]]]
+ }
+
+ # # ## ### ##### ######## #############
+ ## Parser state
+
+ # Path to the file currently processed, if known. Empty if not known
+ typevariable ourfile {}
+
+ # Array of variables for use by vset. During parsing a local copy
+ # is used so that variables set by the document cannot spill back
+ # to the parser state.
+ typevariable ourvars -array {}
+
+ # List of paths to use when searching for an include file.
+ typevariable ourincpaths {}
+
+ # Record of errors found so far. List of 5-tuples containing token
+ # range, line, column of firt character after the token, error
+ # code, and error arguments, in this order.
+ typevariable ourerrors {}
+
+ # List of nodes marked for removal.
+ typevariable ourtokill {}
+
+ # Map of legal commands to their min/max number of arguments.
+ typevariable ourcmds -array {
+ comment {1 1}
+ include {1 1}
+ lb {0 0}
+ rb {0 0}
+ vset {1 2}
+
+ index_begin {2 2}
+ index_end {0 0}
+ key {1 1}
+ manpage {2 2}
+ url {2 2}
+ }
+
+ # # ## ### ##### ######## #############
+ ## Configuration
+
+ pragma -hasinstances no ; # singleton
+ pragma -hastypeinfo no ; # no introspection
+ pragma -hastypedestroy no ; # immortal
+
+ ##
+ # # ## ### ##### ######## #############
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide doctools::idx::parse 0.1
+return
diff --git a/tcllib/modules/doctools2idx/parse.test b/tcllib/modules/doctools2idx/parse.test
new file mode 100644
index 0000000..06385c2
--- /dev/null
+++ b/tcllib/modules/doctools2idx/parse.test
@@ -0,0 +1,153 @@
+# -*- tcl -*-
+# docidx_parse.test: tests for the doctools::idx::parse package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: parse.test,v 1.1 2009/04/01 04:28:37 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ useAccel [useTcllibC] struct/tree.tcl struct::tree
+ TestAccelInit struct::tree
+
+ useAccel [useTcllibC] struct/stack.tcl struct::stack
+ TestAccelInit struct::stack
+
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use struct/list.tcl struct::list
+ use snit/snit.tcl snit
+ use fileutil/fileutil.tcl fileutil
+ use log/logger.tcl logger
+ use treeql/treeql.tcl treeql
+
+ use doctools2base/tcl_parse.tcl doctools::tcl::parse
+ use doctools2base/msgcat.tcl doctools::msgcat
+ useLocal msgcat_c.tcl doctools::msgcat::idx::c
+ useLocal structure.tcl doctools::idx::structure
+
+ msgcat::mclocale C
+}
+testing {
+ useLocal parse.tcl doctools::idx::parse
+}
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-idx-parse-1.0 {parse file, wrong#args} -body {
+ doctools::idx::parse file
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_typemethodfile type path"}
+
+test doctools-idx-parse-1.1 {parse file, wrong#args} -body {
+ doctools::idx::parse file P XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_typemethodfile type path"}
+
+test doctools-idx-parse-2.0 {parse text, wrong#args} -body {
+ doctools::idx::parse text
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_typemethodtext type text ?path?"}
+
+test doctools-idx-parse-2.1 {parse text, wrong#args} -body {
+ doctools::idx::parse text T P XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_typemethodtext type text ?path?"}
+
+test doctools-idx-parse-3.0 {vars, wrong#args} -body {
+ doctools::idx::parse vars XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_typemethodvars type"}
+
+test doctools-idx-parse-4.0 {var, bogus submethod} -body {
+ doctools::idx::parse var bogus
+} -returnCodes error -result {"::doctools::idx::parse var bogus" is not defined}
+
+test doctools-idx-parse-5.0 {var set, wrong#args} -body {
+ doctools::idx::parse var set
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_htypemethodvar_set type name value"}
+
+test doctools-idx-parse-5.1 {var set, wrong#args} -body {
+ doctools::idx::parse var set N
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_htypemethodvar_set type name value"}
+
+test doctools-idx-parse-5.2 {var set, wrong#args} -body {
+ doctools::idx::parse var set N V XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_htypemethodvar_set type name value"}
+
+test doctools-idx-parse-6.0 {var load, wrong#args} -body {
+ doctools::idx::parse var load
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_htypemethodvar_load type dict"}
+
+test doctools-idx-parse-6.1 {var load, wrong#args} -body {
+ doctools::idx::parse var load D XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_htypemethodvar_load type dict"}
+
+# var unset - 0+ arguments, no checking possible.
+
+test doctools-idx-parse-7.0 {includes, wrong#args} -body {
+ doctools::idx::parse includes XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_typemethodincludes type"}
+
+test doctools-idx-parse-8.0 {include, bogus submethod} -body {
+ doctools::idx::parse include bogus
+} -returnCodes error -result {"::doctools::idx::parse include bogus" is not defined}
+
+test doctools-idx-parse-9.0 {include set, wrong#args} -body {
+ doctools::idx::parse include set
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_htypemethodinclude_set type paths"}
+
+test doctools-idx-parse-9.1 {include set, wrong#args} -body {
+ doctools::idx::parse include set P XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_htypemethodinclude_set type paths"}
+
+test doctools-idx-parse-10.0 {include add, wrong#args} -body {
+ doctools::idx::parse include add
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_htypemethodinclude_add type path"}
+
+test doctools-idx-parse-10.1 {include add, wrong#args} -body {
+ doctools::idx::parse include add P XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_htypemethodinclude_add type path"}
+
+test doctools-idx-parse-11.0 {include remove, wrong#args} -body {
+ doctools::idx::parse include remove
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_htypemethodinclude_remove type path"}
+
+test doctools-idx-parse-11.1 {include remove, wrong#args} -body {
+ doctools::idx::parse include remove P XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_htypemethodinclude_remove type path"}
+
+test doctools-idx-parse-12.0 {include clear, wrong#args} -body {
+ doctools::idx::parse include clear XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::parse::Snit_htypemethodinclude_clear type"}
+
+# idx_parse tests, numbering starts at 20
+# -------------------------------------------------------------------------
+
+array_unset env LANG*
+array_unset env LC_*
+set env(LANG) C ; # Usually default if nothing is set, OS X requires this.
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::stack stkimpl {
+ TestAccelDo struct::set setimpl {
+ TestAccelDo struct::tree impl {
+ source [localPath tests/parse]
+ }
+ }
+}
+
+#----------------------------------------------------------------------
+TestAccelExit struct::tree
+TestAccelExit struct::set
+TestAccelExit struct::stack
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2idx/pkgIndex.tcl b/tcllib/modules/doctools2idx/pkgIndex.tcl
new file mode 100644
index 0000000..4b9a81f
--- /dev/null
+++ b/tcllib/modules/doctools2idx/pkgIndex.tcl
@@ -0,0 +1,33 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+
+# Packages for the doctools idx v2 implementation
+# (still v1.1 docidx language).
+
+# - Index container, mutable index objects
+# - Export and import management
+# - Export and import plugins
+# - Parser for docidx markup, and handling serializations
+# - Message catalogs for the parser
+
+package ifneeded doctools::idx 2 [list source [file join $dir container.tcl]]
+
+package ifneeded doctools::idx::export 0.1 [list source [file join $dir export.tcl]]
+package ifneeded doctools::idx::import 0.1 [list source [file join $dir import.tcl]]
+
+package ifneeded doctools::idx::export::docidx 0.1 [list source [file join $dir export_docidx.tcl]]
+package ifneeded doctools::idx::export::html 0.2 [list source [file join $dir export_html.tcl]]
+package ifneeded doctools::idx::export::json 0.1 [list source [file join $dir export_json.tcl]]
+package ifneeded doctools::idx::export::nroff 0.3 [list source [file join $dir export_nroff.tcl]]
+package ifneeded doctools::idx::export::text 0.2 [list source [file join $dir export_text.tcl]]
+package ifneeded doctools::idx::export::wiki 0.2 [list source [file join $dir export_wiki.tcl]]
+
+package ifneeded doctools::idx::import::docidx 0.1 [list source [file join $dir import_docidx.tcl]]
+package ifneeded doctools::idx::import::json 0.1 [list source [file join $dir import_json.tcl]]
+
+package ifneeded doctools::idx::parse 0.1 [list source [file join $dir parse.tcl]]
+package ifneeded doctools::idx::structure 0.1 [list source [file join $dir structure.tcl]]
+
+package ifneeded doctools::msgcat::idx::c 0.1 [list source [file join $dir msgcat_c.tcl]]
+package ifneeded doctools::msgcat::idx::de 0.1 [list source [file join $dir msgcat_de.tcl]]
+package ifneeded doctools::msgcat::idx::en 0.1 [list source [file join $dir msgcat_en.tcl]]
+package ifneeded doctools::msgcat::idx::fr 0.1 [list source [file join $dir msgcat_fr.tcl]]
diff --git a/tcllib/modules/doctools2idx/structure.tcl b/tcllib/modules/doctools2idx/structure.tcl
new file mode 100644
index 0000000..c7e3285
--- /dev/null
+++ b/tcllib/modules/doctools2idx/structure.tcl
@@ -0,0 +1,288 @@
+# -*- tcl -*-
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Verification of serialized indices, and conversion between
+# serialized indices and other data structures.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.4 ; # Required runtime.
+package require snit ; # OO system.
+
+# # ## ### ##### ######## ############# #####################
+##
+
+snit::type ::doctools::idx::structure {
+ # # ## ### ##### ######## #############
+ ## Public API
+
+ # Check that the proposed serialization of a keyword index is
+ # indeed such.
+
+ typemethod verify {serial {canonvar {}}} {
+ # Basic syntax: Length and outer type code
+ if {[llength $serial] != 2} {
+ return -code error $ourprefix$ourshort
+ }
+
+ foreach {tag contents} $serial break
+ #struct::list assign $serial tag contents
+
+ if {$tag ne $ourcode} {
+ return -code error $ourprefix[format $ourtag $tag]
+ }
+
+ if {[llength $contents] != 8} {
+ return -code error $ourprefix$ourcshort
+ }
+
+ # Unpack the contents, then check that all necessary keys are
+ # present. Together with the length check we can then also be
+ # sure that no other key is present either.
+ array set idx $contents
+
+ foreach k {label title keywords references} {
+ if {[info exists idx($k)]} continue
+ return -code error $ourprefix[format $ourmiss $k]
+ }
+
+ # Pull the keys and check their use (n duplicates allowed). At
+ # the same time we collect the references they are associated
+ # with.
+
+ set refs {}
+ set keys {}
+ array set kw {}
+
+ foreach {k reflist} $idx(keywords) {
+ lappend keys $k
+ set kw($k) {}
+ foreach r $reflist { lappend refs $r }
+ }
+
+ # Fail if keys are duplicated
+ if {[llength [array names kw]] != [llength $keys]} {
+ return -code error $ourprefix$ourkdup
+ }
+
+ # Pull the references and check their values, and use.
+ array set rd {}
+ set refids {}
+ foreach {id rdef} $idx(references) {
+ if {[llength $rdef] != 2} {
+ return -code error $ourprefix$ourrshort
+ }
+ set rtag [lindex $rdef 0]
+ if {($rtag ne "manpage") && ($rtag ne "url")} {
+ return -code error $ourprefix[format $ourrtag $rtag]
+ }
+ lappend refids $id
+ set rd($id) {}
+ }
+
+ # Fail if reference ids are duplicated
+ if {[llength [array names rd]] != [llength $refids]} {
+ return -code error $ourprefix$ourrdup
+ }
+
+ # Fail if we have references in keys without decl, or
+ # references not used by any key.
+ if {[lsort -dict [lsort -unique $refs]] ne [lsort -dict $refids]} {
+ return -code error $ourprefix$ourrmismatch
+ }
+
+ if {$canonvar ne {}} {
+ upvar 1 $canonvar iscanonical
+
+ # Now various checks if the keys and identifiers are
+ # properly sorted to make this a canonical serialization.
+ set iscanonical 1
+
+ foreach {a _ b _ c _ d _} $contents break
+ #struct::list assign $contents a _ b _ c _ d _
+ if {
+ ([list $a $b $c $d] ne {label keywords references title}) ||
+ ($keys ne [lsort -dict [array names kw]]) ||
+ ($refids ne [lsort -dict [array names rd]])
+ } {
+ set iscanonical 0
+ }
+ }
+
+ # Everything checked out.
+ return
+ }
+
+ typemethod verify-as-canonical {serial} {
+ $type verify $serial iscanonical
+ if {!$iscanonical} {
+ #puts <$kw>\n<[lsort -dict [lsort -unique $kw]]>
+ return -code error $ourprefix$ourdupsort
+ }
+ return
+ }
+
+ typemethod canonicalize {serial} {
+ $type verify $serial iscanonical
+ if {$iscanonical} { return $serial }
+
+ # Unpack the serialization.
+ array set idx $serial
+ array set idx $idx(doctools::idx)
+ unset idx(doctools::idx)
+ array set k $idx(keywords)
+ array set r $idx(references)
+
+ # Scan and reorder ...
+ set keywords {}
+ foreach kw [lsort -dict [array names k]] {
+ # Sort references in a keyword by their _labels_.
+ set tmp {}
+ foreach rid $k($kw) { lappend tmp [list $rid [lindex $r($rid) 1]] }
+ set refs {}
+ foreach item [lsort -dict -index 1 $tmp] {
+ lappend refs [lindex $item 0]
+ }
+ lappend keywords $kw $refs
+ }
+
+ set references {}
+ foreach rid [lsort -dict [array names r]] {
+ lappend references $rid $r($rid)
+ }
+
+ # Construct result
+ set serial [list doctools::idx \
+ [list \
+ label $idx(label) \
+ keywords $keywords \
+ references $references \
+ title $idx(title)]]
+
+ return $serial
+ }
+
+ # Merge the serialization of two indices into a new serialization.
+
+ typemethod merge {seriala serialb} {
+ $type verify $seriala
+ $type verify $serialb
+
+ # Merge using title and label of the second index, and the new
+ # key definitions come after the existing, overriding as
+ # needed.
+
+ # Unpack the definitions...
+
+ array set a $seriala ; array set a $a(doctools::idx) ; unset a(doctools::idx)
+ array set b $serialb ; array set a $b(doctools::idx) ; unset b(doctools::idx)
+
+ # Merge keywords...
+
+ array set k $a(keywords)
+ foreach {kw reflist} $b(keywords) {
+ if {![info exists k($kw)]} { set k($kw) {} }
+ foreach r $reflist { lappend k($kw) }
+ }
+
+ # Merge references... Here we may have conflicting
+ # declarations for the same id.
+
+ array set r $a(references)
+ foreach {rid rdecl} $b(references) {
+ if {[info exists r($rid)]} {
+ if {$r($rid) ne $rdecl} {
+ return -code error [format $ourmergeerr $r($rid) $rdecl $rid]
+ }
+ continue
+ }
+ set r($rid) $decl
+ }
+
+ # Now construct the result, from the inside out, with proper
+ # sorting at all levels.
+
+ set keywords {}
+ foreach kw [lsort -dict [array names k]] {
+ # Sort references in a keyword by their _labels_.
+ set tmp {}
+ foreach rid $k($kw) { lappend tmp [list $rid [lindex $r($rid) 1]] }
+ set refs {}
+ foreach item [lsort -dict -index 1 $tmp] {
+ lappend refs [lindex $item 0]
+ }
+ lappend keywords $kw $refs
+ }
+
+ set references {}
+ foreach rid [lsort -dict [array names r]] {
+ lappend references $rid $r($rid)
+ }
+
+ set serial [list doctools::idx \
+ [list \
+ label $b(label) \
+ keywords $keywords \
+ references $references \
+ title $b(title)]]
+
+ # Caller has to verify, ensure contract.
+ #$type verify-as-canonical $serial
+ return $serial
+ }
+
+ # Converts an index serialization into a human readable string for
+ # test results. It assumes that the serialization is at least
+ # structurally sound.
+
+ typemethod print {serial} {
+ array set i $serial
+ array set i $i(doctools::idx)
+ array set r $i(references)
+ set lines {}
+ lappend lines [list doctools::idx $i(label) $i(title)]
+ foreach {key reflist} $i(keywords) {
+ lappend lines ....$key
+ foreach ref $reflist {
+ lappend lines ........[linsert $r($ref) end $ref]
+ }
+ }
+ return [join $lines \n]
+ }
+
+ # # ## ### ##### ######## #############
+
+ typevariable ourcode doctools::idx
+ typevariable ourprefix {error in serialization:}
+ # # Test cases (doctools-idx-structure-)
+ typevariable ourshort { dictionary too short, expected exactly one key} ; # 6.0
+ typevariable ourtag { bad type tag "%s"} ; # 6.1
+ typevariable ourcshort { dictionary too short, expected exactly four keys} ; # 6.2
+ typevariable ourmiss { missing expected key "%s"} ; # 6.3, 6.4, 6.5, 6.6
+ typevariable ourkdup { duplicate keywords} ; # 6.8
+ typevariable ourrshort { reference list wrong, need exactly 2} ; # 6.12
+ typevariable ourrtag { bad reference tag "%s"} ; # 6.13
+ typevariable ourrdup { duplicate reference identifiers} ; # 6.14
+ typevariable ourrmismatch { use and declaration of references not matching} ; # 6.10, 6.11
+ # Message for non-canonical serialization when expecting canonical form
+ typevariable ourdupsort { duplicate and/or unsorted keywords/identifiers} ; # 6.7, 6.9, 6.15
+
+ typevariable ourmergeerr {Mismatching declarations '%s' vs. '%s' for '%s'}
+
+ # # ## ### ##### ######## #############
+ ## Configuration
+
+ pragma -hasinstances no ; # singleton
+ pragma -hastypeinfo no ; # no introspection
+ pragma -hastypedestroy no ; # immortal
+
+ ##
+ # # ## ### ##### ######## #############
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide doctools::idx::structure 0.1
+return
diff --git a/tcllib/modules/doctools2idx/structure.test b/tcllib/modules/doctools2idx/structure.test
new file mode 100644
index 0000000..7cd2df5
--- /dev/null
+++ b/tcllib/modules/doctools2idx/structure.test
@@ -0,0 +1,163 @@
+# -*- tcl -*-
+# docidx_structure.test: tests for the doctools::idx::structure package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: structure.test,v 1.1 2009/04/01 04:28:37 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ; # For tests/common
+ use snit/snit.tcl snit
+}
+testing {
+ useLocal structure.tcl doctools::idx::structure
+}
+
+# -------------------------------------------------------------------------
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+test doctools-idx-structure-1.0 {structure verify, wrong#args} -body {
+ doctools::idx::structure verify
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::structure::Snit_typemethodverify type serial ?canonvar?"}
+
+test doctools-idx-structure-1.1 {structure verify, wrong#args} -body {
+ doctools::idx::structure verify S V XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::structure::Snit_typemethodverify type serial ?canonvar?"}
+
+test doctools-idx-structure-2.0 {structure verify, wrong#args} -body {
+ doctools::idx::structure verify-as-canonical
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::structure::Snit_typemethodverify-as-canonical type serial"}
+
+test doctools-idx-structure-2.1 {structure verify, wrong#args} -body {
+ doctools::idx::structure verify-as-canonical S XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::structure::Snit_typemethodverify-as-canonical type serial"}
+
+test doctools-idx-structure-3.0 {structure print, wrong#args} -body {
+ doctools::idx::structure print
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::structure::Snit_typemethodprint type serial"}
+
+test doctools-idx-structure-3.1 {structure print, wrong#args} -body {
+ doctools::idx::structure print S XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::structure::Snit_typemethodprint type serial"}
+
+test doctools-idx-structure-4.0 {structure merge, wrong#args} -body {
+ doctools::idx::structure merge
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::structure::Snit_typemethodmerge type seriala serialb"}
+
+test doctools-idx-structure-4.1 {structure merge, wrong#args} -body {
+ doctools::idx::structure merge SA
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::structure::Snit_typemethodmerge type seriala serialb"}
+
+test doctools-idx-structure-4.2 {structure merge, wrong#args} -body {
+ doctools::idx::structure merge SA SB XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::idx::structure::Snit_typemethodmerge type seriala serialb"}
+
+# -------------------------------------------------------------------------
+
+TestFilesProcess $mytestdir ok serial text -> n label input data expected {
+ # The 'expected' data is irrelevant here, only used to satisfy
+ # TestFilesProcess' syntax.
+ test doctools-idx-structure-5.$n "doctools::idx::structure verify, $label, ok" -body {
+ doctools::idx::structure verify $data
+ } -result {}
+}
+
+# -------------------------------------------------------------------------
+
+foreach {n badserial expected} {
+ 0 {}
+ {error in serialization: dictionary too short, expected exactly one key}
+ 1 {FOO {}}
+ {error in serialization: bad type tag "FOO"}
+ 2 {doctools::idx {}}
+ {error in serialization: dictionary too short, expected exactly four keys}
+ 3 {doctools::idx {a . b . c . d .}}
+ {error in serialization: missing expected key "label"}
+ 4 {doctools::idx {label . b . c . d .}}
+ {error in serialization: missing expected key "title"}
+ 5 {doctools::idx {label . title . c . d .}}
+ {error in serialization: missing expected key "keywords"}
+ 6 {doctools::idx {label . title . keywords . d .}}
+ {error in serialization: missing expected key "references"}
+ 7 {doctools::idx {label . title . keywords {} references {}}}
+ {error in serialization: duplicate and/or unsorted keywords/identifiers}
+ 8 {doctools::idx {label . keywords {k {} k {}} references {} title .}}
+ {error in serialization: duplicate keywords}
+ 9 {doctools::idx {label . keywords {b {} a {}} references {} title .}}
+ {error in serialization: duplicate and/or unsorted keywords/identifiers}
+ 10 {doctools::idx {label . keywords {} references {a {url x}} title .}}
+ {error in serialization: use and declaration of references not matching}
+ 11 {doctools::idx {label . keywords {a {b c}} references {} title .}}
+ {error in serialization: use and declaration of references not matching}
+ 12 {doctools::idx {label . keywords {a {b}} references {b {url}} title .}}
+ {error in serialization: reference list wrong, need exactly 2}
+ 13 {doctools::idx {label . keywords {a {b}} references {b {foo B}} title .}}
+ {error in serialization: bad reference tag "foo"}
+ 14 {doctools::idx {label . keywords {a {b}} references {b {url B} b {url A}} title .}}
+ {error in serialization: duplicate reference identifiers}
+ 15 {doctools::idx {label . keywords {a {b c}} references {c {url C} b {url B}} title .}}
+ {error in serialization: duplicate and/or unsorted keywords/identifiers}
+} {
+ test doctools-idx-structure-6.$n "doctools::idx::structure verify-as-canonical, error" -body {
+ doctools::idx::structure verify-as-canonical $badserial
+ } -returnCodes error -result $expected
+}
+
+#----------------------------------------------------------------------
+
+foreach {n badserial expected} {
+ 0 {}
+ {error in serialization: dictionary too short, expected exactly one key}
+ 1 {FOO {}}
+ {error in serialization: bad type tag "FOO"}
+ 2 {doctools::idx {}}
+ {error in serialization: dictionary too short, expected exactly four keys}
+ 3 {doctools::idx {a . b . c . d .}}
+ {error in serialization: missing expected key "label"}
+ 4 {doctools::idx {label . b . c . d .}}
+ {error in serialization: missing expected key "title"}
+ 5 {doctools::idx {label . title . c . d .}}
+ {error in serialization: missing expected key "keywords"}
+ 6 {doctools::idx {label . title . keywords . d .}}
+ {error in serialization: missing expected key "references"}
+ 8 {doctools::idx {label . keywords {k {} k {}} references {} title .}}
+ {error in serialization: duplicate keywords}
+ 10 {doctools::idx {label . keywords {} references {a {url x}} title .}}
+ {error in serialization: use and declaration of references not matching}
+ 11 {doctools::idx {label . keywords {a {b c}} references {} title .}}
+ {error in serialization: use and declaration of references not matching}
+ 12 {doctools::idx {label . keywords {a {b}} references {b {url}} title .}}
+ {error in serialization: reference list wrong, need exactly 2}
+ 13 {doctools::idx {label . keywords {a {b}} references {b {foo B}} title .}}
+ {error in serialization: bad reference tag "foo"}
+ 14 {doctools::idx {label . keywords {a {b}} references {b {url B} b {url A}} title .}}
+ {error in serialization: duplicate reference identifiers}
+} {
+ test doctools-idx-structure-7.$n "doctools::idx::structure verify, error" -body {
+ doctools::idx::structure verify $badserial
+ } -returnCodes error -result $expected
+}
+
+#----------------------------------------------------------------------
+
+# TODO merge ... also test cases for doctools::idx
+
+#----------------------------------------------------------------------
+
+unset mytestdir n badserial expected label input data
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2idx/tests/container b/tcllib/modules/doctools2idx/tests/container
new file mode 100644
index 0000000..bc77c51
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/container
@@ -0,0 +1,358 @@
+# -*- tcl -*-
+# docidx.testsuite: tests for the docidx management.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: container,v 1.2 2009/04/17 05:42:07 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# I. Handling regular serialization of indices, import and export.
+# Import serialization, then re-export.
+
+TestFilesProcess $mytestdir ok serial serial-print -> n label input data expected {
+ test doctools-idx-40.$n "doctools::idx deserialize serial, $label, ok" -setup {
+ doctools::idx I
+ } -body {
+ I deserialize = $data
+ I invalidate
+ doctools::idx::structure print [I serialize]
+ } -cleanup {
+ I destroy
+ } -result $expected
+}
+
+# Testing the errors thrown for invalid serializations, at the level
+# of index objects. Underneath are the doctools::idx::structure
+# commands, so we can and are re-using the test cases which were
+# written for them.
+
+foreach {n badserial expected} {
+ 0 {}
+ {error in serialization: dictionary too short, expected exactly one key}
+ 1 {FOO {}}
+ {error in serialization: bad type tag "FOO"}
+ 2 {doctools::idx {}}
+ {error in serialization: dictionary too short, expected exactly four keys}
+ 3 {doctools::idx {a . b . c . d .}}
+ {error in serialization: missing expected key "label"}
+ 4 {doctools::idx {label . b . c . d .}}
+ {error in serialization: missing expected key "title"}
+ 5 {doctools::idx {label . title . c . d .}}
+ {error in serialization: missing expected key "keywords"}
+ 6 {doctools::idx {label . title . keywords . d .}}
+ {error in serialization: missing expected key "references"}
+ 8 {doctools::idx {label . keywords {k {} k {}} references {} title .}}
+ {error in serialization: duplicate keywords}
+ 10 {doctools::idx {label . keywords {} references {a {url x}} title .}}
+ {error in serialization: use and declaration of references not matching}
+ 11 {doctools::idx {label . keywords {a {b c}} references {} title .}}
+ {error in serialization: use and declaration of references not matching}
+ 12 {doctools::idx {label . keywords {a {b}} references {b {url}} title .}}
+ {error in serialization: reference list wrong, need exactly 2}
+ 13 {doctools::idx {label . keywords {a {b}} references {b {foo B}} title .}}
+ {error in serialization: bad reference tag "foo"}
+ 14 {doctools::idx {label . keywords {a {b}} references {b {url B} b {url A}} title .}}
+ {error in serialization: duplicate reference identifiers}
+} {
+ test doctools-idx-41.$n "doctools::idx deserialize, error" -setup {
+ doctools::idx I
+ } -body {
+ I deserialize = $badserial
+ } -cleanup {
+ I destroy
+ } -returnCodes error -result $expected
+}
+
+foreach {n noncanonserial expected} {
+ 7 {doctools::idx {label . title . keywords {} references {}}}
+ {doctools::idx {label . keywords {} references {} title .}}
+ 9 {doctools::idx {label . keywords {b {} a {}} references {} title .}}
+ {doctools::idx {label . keywords {a {} b {}} references {} title .}}
+ 15 {doctools::idx {label . keywords {a {b c}} references {c {url C} b {url B}} title .}}
+ {doctools::idx {label . keywords {a {b c}} references {b {url B} c {url C}} title .}}
+} {
+ test doctools-idx-42.$n "doctools::idx deserialize, regular to canonical" -setup {
+ doctools::idx I
+ I deserialize = $noncanonserial
+ } -body {
+ I serialize
+ } -cleanup {
+ I destroy
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# II. Handling docidx markup as serialization format, import and export.
+
+# Checking that the various forms of docidx markup as generated by the
+# export plugin doctools::idx(::export::docidx) are valid input for
+# the docidx import plugin. Actually testing that using an import
+# manager from the index is working.
+
+foreach {k section} {
+ 0 {}
+ 1 -ultracompact
+ 2 -compact
+ 3 -indented
+ 4 -aligned
+ 5 -indalign
+} {
+ TestFilesProcess $mytestdir ok docidx$section serial-print -> n label input data expected {
+ test doctools-idx-50.$k.$n "doctools::idx deserialize = docidx, $label$section, ok" -setup {
+ doctools::idx I
+ doctools::idx::import IN
+ I importer IN
+ } -body {
+ I deserialize = $data docidx
+ doctools::idx::structure print [I serialize]
+ } -cleanup {
+ I destroy
+ IN destroy
+ } -result $expected
+ }
+}
+
+# We test the error messages and codes thrown during import for a
+# variety of failure possibilities
+
+TestFilesProcess $mytestdir fail docidx emsg -> n label input data expected {
+ test doctools-idx-51.$n "doctools::idx deserialize = docidx, $label, error message" -setup {
+ # Basic variables and include search paths for use by the tests
+ doctools::idx::import IN
+ IN config set fox dog
+ IN config set lazy jump
+ IN include add [TestFilesGlob $mytestdir]
+ doctools::idx I
+ I importer IN
+ } -body {
+ I deserialize = $data docidx
+ } -cleanup {
+ I destroy
+ IN destroy
+ } -returnCodes error -result $expected
+}
+
+TestFilesProcess $mytestdir fail docidx ecode -> n label input data expected {
+ test doctools-idx-52.$n "doctools::idx deserialize = docidx, $label, error code" -setup {
+ # Basic variables and include search paths for use by the tests
+ doctools::idx::import IN
+ IN config set fox dog
+ IN config set lazy jump
+ IN include add [TestFilesGlob $mytestdir]
+ doctools::idx I
+ I importer IN
+ } -body {
+ catch { I deserialize = $data docidx }
+ set ::errorCode
+ } -cleanup {
+ I destroy
+ IN destroy
+ } -result $expected
+}
+
+# Testing the export of docidx markup through attached exporter management, for all possible configurations.
+
+foreach {k nl in al section} {
+ 0 0 0 0 -ultracompact
+ 1 1 0 0 -compact
+ 2 1 1 0 -indented
+ 3 1 0 1 -aligned
+ 4 1 1 1 -indalign
+ 5 0 1 0 -indented
+ 6 0 0 1 -aligned
+ 7 0 1 1 -indalign
+} {
+ TestFilesProcess $mytestdir ok serial docidx$section -> n label input data expected {
+ test doctools-idx-53.$k.$n "doctools::idx serialize docidx, ${label}$section, ok" -setup {
+ doctools::idx::export OUT
+ OUT config set newlines $nl
+ OUT config set indented $in
+ OUT config set aligned $al
+ doctools::idx I
+ I exporter OUT
+ } -body {
+ I deserialize = $data
+ stripcomments [I serialize docidx]
+ } -cleanup {
+ I destroy
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# III. Handling text markup as serialization format, export only
+
+TestFilesProcess $mytestdir ok serial text -> n label input data expected {
+ test doctools-idx-54.$n "doctools::idx serialize text, $label, ok" -setup {
+ doctools::idx::export OUT
+ doctools::idx I
+ I exporter OUT
+ } -body {
+ I deserialize = $data
+ I serialize text
+ } -cleanup {
+ I destroy
+ OUT destroy
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# IV. Handling json markup as serialization format, import and export.
+
+# We are checking that the various forms of json markup, as can be
+# generated by doctools::idx(::export(::json)) are valid input to the
+# json parser.
+#
+# section {} holds the non-canonical input we have to accept and make
+# canonical to higher layers.
+
+foreach {k section} {
+ 0 {}
+ 1 -ultracompact
+ 2 -indented
+ 3 -indalign
+} {
+ TestFilesProcess $mytestdir ok json$section serial-print -> n label input data expected {
+ test doctools-idx-55.$k.$n "doctools::idx deserialize = json, $label$section, ok" -setup {
+ doctools::idx::import IN
+ doctools::idx I
+ I importer IN
+ } -body {
+ I deserialize = $data json
+ doctools::idx::structure print [I serialize]
+ } -cleanup {
+ I destroy
+ IN destroy
+ } -result $expected
+ }
+}
+
+TestFilesProcess $mytestdir fail json json-emsg -> n label input data expected {
+ test doctools-idx-56.$n "doctools::idx deserialize = json, $label, error message" -setup {
+ doctools::idx::import IN
+ doctools::idx I
+ I importer IN
+ } -body {
+ I deserialize = $data json
+ } -cleanup {
+ I destroy
+ IN destroy
+ } -returnCodes error -result $expected
+}
+
+foreach {k in al section} {
+ 0 0 0 -ultracompact
+ 1 1 0 -indented
+ 2 0 1 -indalign
+ 3 1 1 -indalign
+} {
+ TestFilesProcess $mytestdir ok serial json$section -> n label input data expected {
+ test doctools-idx-57.$k.$n "doctools::idx serialize json, $label$section, ok" -setup {
+ doctools::idx::export OUT
+ OUT config set indented $in
+ OUT config set aligned $al
+ doctools::idx I
+ I exporter OUT
+ } -body {
+ I deserialize = $data
+ I serialize json
+ } -cleanup {
+ I destroy
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# V. Handling html markup as serialization format, export only
+
+foreach {k nl in section} {
+ 0 0 0 -ultracompact
+ 1 0 1 -indented
+ 2 1 0 -compact
+ 3 1 1 -indented
+} {
+ TestFilesProcess $mytestdir ok serial html$section -> n label input data expected {
+ test doctools-idx-58.$k.$n "doctools::idx serialize html, $label$section, ok" -setup {
+ doctools::idx::export OUT
+ OUT config set newlines $nl
+ OUT config set indented $in
+ OUT config set user _dummy_
+ doctools::idx I
+ I exporter OUT
+ } -body {
+ I deserialize = $data
+ striphtmlcomments [I serialize html] 3
+ } -cleanup {
+ I destroy
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# VI. Handling wiki markup as serialization format, export only
+
+foreach {k style section} {
+ 0 list -list
+ 1 table -table
+} {
+ TestFilesProcess $mytestdir ok serial wiki$section -> n label input data expected {
+ test doctools-idx-59.$k.$n "doctools::idx serialize wiki, $label$section, ok" -setup {
+ doctools::idx::export OUT
+ OUT config set style $style
+ doctools::idx I
+ I exporter OUT
+ } -body {
+ I deserialize = $data
+ I serialize wiki
+ } -cleanup {
+ I destroy
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# VII. Handling nroff markup as serialization format, export only
+
+foreach {k inline section} {
+ 0 0 -external
+ 1 1 -inlined
+} {
+ TestFilesProcess $mytestdir ok serial nroff$section -> n label input data expected {
+ test doctools-idx-60.$k.$n "doctools::idx serialize nroff, $label$section, ok" -setup {
+ doctools::idx::export OUT
+ OUT config set inline $inline
+ doctools::idx I
+ I exporter OUT
+ } -body {
+ I deserialize = $data
+ stripnroffcomments [stripmanmacros [I serialize nroff]]
+ } -cleanup {
+ I destroy
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+return
+
+# TODO :: Test the merging of indices (copy from idx_structure.test)
+
+# -------------------------------------------------------------------------
+return
diff --git a/tcllib/modules/doctools2idx/tests/data/bad_command b/tcllib/modules/doctools2idx/tests/data/bad_command
new file mode 100644
index 0000000..9bc8645
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/bad_command
@@ -0,0 +1 @@
+[key][comment {arguments missing}]
diff --git a/tcllib/modules/doctools2idx/tests/data/empty b/tcllib/modules/doctools2idx/tests/data/empty
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/empty
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/badtrees.tcl b/tcllib/modules/doctools2idx/tests/data/fail/badtrees.tcl
new file mode 100644
index 0000000..6901e4d
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/badtrees.tcl
@@ -0,0 +1,23 @@
+package require struct::tree
+package require fileutil
+
+struct::tree T
+fileutil::writeFile in-vt/0_root_label [T serialize]
+T set root label L
+fileutil::writeFile in-vt/1_root_title [T serialize]
+T set root title T
+T insert root end K
+fileutil::writeFile in-vt/2_keyword_label [T serialize]
+T set K label L
+T insert K end R
+fileutil::writeFile in-vt/3_ref_type [T serialize]
+T set R type foo
+fileutil::writeFile in-vt/4_ref_label [T serialize]
+T set R label L
+fileutil::writeFile in-vt/5_ref_ref [T serialize]
+T set R ref X
+fileutil::writeFile in-vt/6_ref_tag [T serialize]
+T set R type url
+T insert R end OVER
+fileutil::writeFile in-vt/7_depth [T serialize]
+exit
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/01_nonwhitespace1 b/tcllib/modules/doctools2idx/tests/data/fail/docidx/01_nonwhitespace1
new file mode 100644
index 0000000..463f899
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/01_nonwhitespace1
@@ -0,0 +1 @@
+regular text is not allowed in index files \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/02_nonwhitespace2 b/tcllib/modules/doctools2idx/tests/data/fail/docidx/02_nonwhitespace2
new file mode 100644
index 0000000..edd1d9e
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/02_nonwhitespace2
@@ -0,0 +1 @@
+[vset fox] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/03_illegalcmd1 b/tcllib/modules/doctools2idx/tests/data/fail/docidx/03_illegalcmd1
new file mode 100644
index 0000000..240d9f7
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/03_illegalcmd1
@@ -0,0 +1 @@
+[foo]
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/04_illegalcmd2 b/tcllib/modules/doctools2idx/tests/data/fail/docidx/04_illegalcmd2
new file mode 100644
index 0000000..893d0d8
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/04_illegalcmd2
@@ -0,0 +1 @@
+[vset [foo]] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/05_nestingbad1 b/tcllib/modules/doctools2idx/tests/data/fail/docidx/05_nestingbad1
new file mode 100644
index 0000000..6916b90
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/05_nestingbad1
@@ -0,0 +1 @@
+[index_begin a [vset b c]] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/06_nestingbad2 b/tcllib/modules/doctools2idx/tests/data/fail/docidx/06_nestingbad2
new file mode 100644
index 0000000..e9ad793
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/06_nestingbad2
@@ -0,0 +1 @@
+[index_begin I [manpage F T]] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/07_wrongargs b/tcllib/modules/doctools2idx/tests/data/fail/docidx/07_wrongargs
new file mode 100644
index 0000000..1f9514a
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/07_wrongargs
@@ -0,0 +1 @@
+[index_begin KWIC] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/08_toomanyargs b/tcllib/modules/doctools2idx/tests/data/fail/docidx/08_toomanyargs
new file mode 100644
index 0000000..54fe811
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/08_toomanyargs
@@ -0,0 +1 @@
+[index_begin KWIC INDEX _bogus_] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/09_vsetvarunknown b/tcllib/modules/doctools2idx/tests/data/fail/docidx/09_vsetvarunknown
new file mode 100644
index 0000000..da33c55
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/09_vsetvarunknown
@@ -0,0 +1 @@
+[vset a] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/10_vsetvarerr b/tcllib/modules/doctools2idx/tests/data/fail/docidx/10_vsetvarerr
new file mode 100644
index 0000000..122f82d
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/10_vsetvarerr
@@ -0,0 +1 @@
+[vset [include bogus] b] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/11_vsetvalueerr b/tcllib/modules/doctools2idx/tests/data/fail/docidx/11_vsetvalueerr
new file mode 100644
index 0000000..2b7641e
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/11_vsetvalueerr
@@ -0,0 +1 @@
+[vset a [include bogus]] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/12_incerror b/tcllib/modules/doctools2idx/tests/data/fail/docidx/12_incerror
new file mode 100644
index 0000000..8a40050
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/12_incerror
@@ -0,0 +1 @@
+[include [vset a b]] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/13_incnotfound b/tcllib/modules/doctools2idx/tests/data/fail/docidx/13_incnotfound
new file mode 100644
index 0000000..e874901
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/13_incnotfound
@@ -0,0 +1 @@
+[include bogus] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/14_incempty b/tcllib/modules/doctools2idx/tests/data/fail/docidx/14_incempty
new file mode 100644
index 0000000..de07995
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/14_incempty
@@ -0,0 +1 @@
+[include empty] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/15_incbadeof b/tcllib/modules/doctools2idx/tests/data/fail/docidx/15_incbadeof
new file mode 100644
index 0000000..a093d60
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/15_incbadeof
@@ -0,0 +1 @@
+[include unexpected_eof]
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/16_incbadchar b/tcllib/modules/doctools2idx/tests/data/fail/docidx/16_incbadchar
new file mode 100644
index 0000000..362354c
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/16_incbadchar
@@ -0,0 +1 @@
+[include unexpected_char]
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/17_badempty b/tcllib/modules/doctools2idx/tests/data/fail/docidx/17_badempty
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/17_badempty
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/18_nobegin b/tcllib/modules/doctools2idx/tests/data/fail/docidx/18_nobegin
new file mode 100644
index 0000000..5be5cec
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/18_nobegin
@@ -0,0 +1 @@
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/19_manybegin b/tcllib/modules/doctools2idx/tests/data/fail/docidx/19_manybegin
new file mode 100644
index 0000000..fbff0cc
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/19_manybegin
@@ -0,0 +1,5 @@
+[index_begin A B]
+[index_begin A B]
+[index_begin A B]
+[index_begin A B]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/20_latebegin b/tcllib/modules/doctools2idx/tests/data/fail/docidx/20_latebegin
new file mode 100644
index 0000000..e0b020a
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/20_latebegin
@@ -0,0 +1,3 @@
+[key X]
+[index_begin A B]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/21_noend1 b/tcllib/modules/doctools2idx/tests/data/fail/docidx/21_noend1
new file mode 100644
index 0000000..d744bdc
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/21_noend1
@@ -0,0 +1 @@
+[index_begin A B]
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/22_noend2 b/tcllib/modules/doctools2idx/tests/data/fail/docidx/22_noend2
new file mode 100644
index 0000000..c27858f
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/22_noend2
@@ -0,0 +1,2 @@
+[index_begin A B]
+[key A]
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/23_manyend b/tcllib/modules/doctools2idx/tests/data/fail/docidx/23_manyend
new file mode 100644
index 0000000..0613a46
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/23_manyend
@@ -0,0 +1,5 @@
+[index_begin A B]
+[index_end]
+[index_end]
+[index_end]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/24_earlyend b/tcllib/modules/doctools2idx/tests/data/fail/docidx/24_earlyend
new file mode 100644
index 0000000..c8979b5
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/24_earlyend
@@ -0,0 +1,4 @@
+[index_begin A B]
+[index_end]
+[key X]
+
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/25_nobeginend b/tcllib/modules/doctools2idx/tests/data/fail/docidx/25_nobeginend
new file mode 100644
index 0000000..56b8abb
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/25_nobeginend
@@ -0,0 +1,2 @@
+[key A]
+[key B]
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/26_latekey b/tcllib/modules/doctools2idx/tests/data/fail/docidx/26_latekey
new file mode 100644
index 0000000..923b6af
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/26_latekey
@@ -0,0 +1,6 @@
+[index_begin KWIC INDEX]
+[url A B]
+[key X]
+[url C D]
+[manpage E F]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/27_incbadcmd b/tcllib/modules/doctools2idx/tests/data/fail/docidx/27_incbadcmd
new file mode 100644
index 0000000..599e5bd
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/27_incbadcmd
@@ -0,0 +1 @@
+[include bad_command] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/28_badredef b/tcllib/modules/doctools2idx/tests/data/fail/docidx/28_badredef
new file mode 100644
index 0000000..49960d8
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/28_badredef
@@ -0,0 +1,6 @@
+[index_begin {Keyword Index} {}]
+[key TMML]
+[manpage apps/dtplite.man dtplite]
+[key conversion]
+[manpage apps/dtplite.man doc-tools-processor-lite]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/docidx/29_badredef2 b/tcllib/modules/doctools2idx/tests/data/fail/docidx/29_badredef2
new file mode 100644
index 0000000..5dccefa
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/docidx/29_badredef2
@@ -0,0 +1,6 @@
+[index_begin {Keyword Index} {}]
+[key TMML]
+[manpage apps/dtplite.man dtplite]
+[key conversion]
+[url apps/dtplite.man dtplite]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/01_nonwhitespace1 b/tcllib/modules/doctools2idx/tests/data/fail/ecode/01_nonwhitespace1
new file mode 100644
index 0000000..dbb18fa
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/01_nonwhitespace1
@@ -0,0 +1 @@
+{{} {0 41} 1 42 docidx/plaintext {}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/02_nonwhitespace2 b/tcllib/modules/doctools2idx/tests/data/fail/ecode/02_nonwhitespace2
new file mode 100644
index 0000000..eb9069e
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/02_nonwhitespace2
@@ -0,0 +1 @@
+{{} {1 4} 1 5 docidx/plaintext {}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/03_illegalcmd1 b/tcllib/modules/doctools2idx/tests/data/fail/ecode/03_illegalcmd1
new file mode 100644
index 0000000..d8d59d1
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/03_illegalcmd1
@@ -0,0 +1 @@
+{{} {1 3} 1 4 docidx/cmd/illegal foo}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/04_illegalcmd2 b/tcllib/modules/doctools2idx/tests/data/fail/ecode/04_illegalcmd2
new file mode 100644
index 0000000..811a7b3
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/04_illegalcmd2
@@ -0,0 +1 @@
+{{} {7 9} 1 10 docidx/cmd/illegal foo}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/05_nestingbad1 b/tcllib/modules/doctools2idx/tests/data/fail/ecode/05_nestingbad1
new file mode 100644
index 0000000..a59f4f8
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/05_nestingbad1
@@ -0,0 +1 @@
+{{} {16 19} 1 20 docidx/cmd/nested vset/2}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/06_nestingbad2 b/tcllib/modules/doctools2idx/tests/data/fail/ecode/06_nestingbad2
new file mode 100644
index 0000000..dee0bf3
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/06_nestingbad2
@@ -0,0 +1 @@
+{{} {16 22} 1 23 docidx/cmd/nested manpage}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/07_wrongargs b/tcllib/modules/doctools2idx/tests/data/fail/ecode/07_wrongargs
new file mode 100644
index 0000000..f744368
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/07_wrongargs
@@ -0,0 +1 @@
+{{} {1 11} 1 12 docidx/cmd/wrongargs {index_begin 2}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/08_toomanyargs b/tcllib/modules/doctools2idx/tests/data/fail/ecode/08_toomanyargs
new file mode 100644
index 0000000..1b0052d
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/08_toomanyargs
@@ -0,0 +1 @@
+{{} {1 11} 1 12 docidx/cmd/toomanyargs {index_begin 2}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/09_vsetvarunknown b/tcllib/modules/doctools2idx/tests/data/fail/ecode/09_vsetvarunknown
new file mode 100644
index 0000000..19801cb
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/09_vsetvarunknown
@@ -0,0 +1 @@
+{{} {1 4} 1 5 docidx/vset/varname/unknown a}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/10_vsetvarerr b/tcllib/modules/doctools2idx/tests/data/fail/ecode/10_vsetvarerr
new file mode 100644
index 0000000..e536365
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/10_vsetvarerr
@@ -0,0 +1 @@
+{{} {7 13} 1 14 docidx/cmd/nested include}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/11_vsetvalueerr b/tcllib/modules/doctools2idx/tests/data/fail/ecode/11_vsetvalueerr
new file mode 100644
index 0000000..80597c6
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/11_vsetvalueerr
@@ -0,0 +1 @@
+{{} {9 15} 1 16 docidx/cmd/nested include}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/12_incerror b/tcllib/modules/doctools2idx/tests/data/fail/ecode/12_incerror
new file mode 100644
index 0000000..d00bceb
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/12_incerror
@@ -0,0 +1 @@
+{{} {10 13} 1 14 docidx/cmd/nested vset/2}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/13_incnotfound b/tcllib/modules/doctools2idx/tests/data/fail/ecode/13_incnotfound
new file mode 100644
index 0000000..bba9fa4
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/13_incnotfound
@@ -0,0 +1 @@
+{{} {1 7} 1 8 docidx/include/path/notfound bogus}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/14_incempty b/tcllib/modules/doctools2idx/tests/data/fail/ecode/14_incempty
new file mode 100644
index 0000000..a64dc1e
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/14_incempty
@@ -0,0 +1 @@
+{{} {0 0} 1 0 docidx/index_begin/missing {}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/15_incbadeof b/tcllib/modules/doctools2idx/tests/data/fail/ecode/15_incbadeof
new file mode 100644
index 0000000..a99b755
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/15_incbadeof
@@ -0,0 +1 @@
+{{} {1 7} 1 8 docidx/include/syntax {@/tests/data/unexpected_eof {{{} {27 27} 1 27 docidx/eof/syntax {}}}}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/16_incbadchar b/tcllib/modules/doctools2idx/tests/data/fail/ecode/16_incbadchar
new file mode 100644
index 0000000..a75e162
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/16_incbadchar
@@ -0,0 +1 @@
+{{} {1 7} 1 8 docidx/include/syntax {@/tests/data/unexpected_char {{{} {27 27} 1 27 docidx/char/syntax {}}}}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/17_badempty b/tcllib/modules/doctools2idx/tests/data/fail/ecode/17_badempty
new file mode 100644
index 0000000..a64dc1e
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/17_badempty
@@ -0,0 +1 @@
+{{} {0 0} 1 0 docidx/index_begin/missing {}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/18_nobegin b/tcllib/modules/doctools2idx/tests/data/fail/ecode/18_nobegin
new file mode 100644
index 0000000..ec9a73b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/18_nobegin
@@ -0,0 +1 @@
+{{} {1 9} 1 10 docidx/index_begin/missing {}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/19_manybegin b/tcllib/modules/doctools2idx/tests/data/fail/ecode/19_manybegin
new file mode 100644
index 0000000..5911281
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/19_manybegin
@@ -0,0 +1 @@
+{{} {19 29} 2 12 docidx/key/missing {}} {{} {37 47} 3 12 docidx/key/missing {}} {{} {55 65} 4 12 docidx/key/missing {}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/20_latebegin b/tcllib/modules/doctools2idx/tests/data/fail/ecode/20_latebegin
new file mode 100644
index 0000000..6c36a5b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/20_latebegin
@@ -0,0 +1 @@
+{{} {1 3} 1 4 docidx/index_begin/missing {}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/21_noend1 b/tcllib/modules/doctools2idx/tests/data/fail/ecode/21_noend1
new file mode 100644
index 0000000..58371de
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/21_noend1
@@ -0,0 +1 @@
+{{} {1 11} 1 12 docidx/index_end/missing {}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/22_noend2 b/tcllib/modules/doctools2idx/tests/data/fail/ecode/22_noend2
new file mode 100644
index 0000000..b90cf9c
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/22_noend2
@@ -0,0 +1 @@
+{{} {19 21} 2 4 docidx/index_end/missing {}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/23_manyend b/tcllib/modules/doctools2idx/tests/data/fail/ecode/23_manyend
new file mode 100644
index 0000000..e234633
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/23_manyend
@@ -0,0 +1 @@
+{{} {31 39} 3 10 docidx/index_end/syntax {}} {{} {43 51} 4 10 docidx/index_end/syntax {}} {{} {55 63} 5 10 docidx/index_end/syntax {}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/24_earlyend b/tcllib/modules/doctools2idx/tests/data/fail/ecode/24_earlyend
new file mode 100644
index 0000000..4eefa17
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/24_earlyend
@@ -0,0 +1 @@
+{{} {31 33} 3 4 docidx/key/syntax {}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/25_nobeginend b/tcllib/modules/doctools2idx/tests/data/fail/ecode/25_nobeginend
new file mode 100644
index 0000000..598a015
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/25_nobeginend
@@ -0,0 +1 @@
+{{} {1 3} 1 4 docidx/index_begin/missing {}} {{} {9 11} 2 4 docidx/index_begin/missing {}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/26_latekey b/tcllib/modules/doctools2idx/tests/data/fail/ecode/26_latekey
new file mode 100644
index 0000000..a5527ed
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/26_latekey
@@ -0,0 +1 @@
+{{} {26 28} 2 4 docidx/key/missing {}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/27_incbadcmd b/tcllib/modules/doctools2idx/tests/data/fail/ecode/27_incbadcmd
new file mode 100644
index 0000000..da9c3a5
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/27_incbadcmd
@@ -0,0 +1 @@
+{@/tests/data/bad_command {1 3} 1 4 docidx/cmd/wrongargs {key 1}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/28_badredef b/tcllib/modules/doctools2idx/tests/data/fail/ecode/28_badredef
new file mode 100644
index 0000000..d030af8
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/28_badredef
@@ -0,0 +1 @@
+{{} {110 116} 5 8 docidx/ref/redef {apps/dtplite.man manpage dtplite manpage doc-tools-processor-lite}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/ecode/29_badredef2 b/tcllib/modules/doctools2idx/tests/data/fail/ecode/29_badredef2
new file mode 100644
index 0000000..dd0ab7f
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/ecode/29_badredef2
@@ -0,0 +1 @@
+{{} {110 112} 5 4 docidx/ref/redef {apps/dtplite.man manpage dtplite url dtplite}}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/01_nonwhitespace1 b/tcllib/modules/doctools2idx/tests/data/fail/emsg/01_nonwhitespace1
new file mode 100644
index 0000000..064e6a1
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/01_nonwhitespace1
@@ -0,0 +1 @@
+error on line 1.42: Plain text beyond whitespace is not allowed
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/02_nonwhitespace2 b/tcllib/modules/doctools2idx/tests/data/fail/emsg/02_nonwhitespace2
new file mode 100644
index 0000000..fe97361
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/02_nonwhitespace2
@@ -0,0 +1 @@
+error on line 1.5: Plain text beyond whitespace is not allowed
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/03_illegalcmd1 b/tcllib/modules/doctools2idx/tests/data/fail/emsg/03_illegalcmd1
new file mode 100644
index 0000000..cfee65b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/03_illegalcmd1
@@ -0,0 +1 @@
+error on line 1.4: Illegal command "foo", not a docidx command
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/04_illegalcmd2 b/tcllib/modules/doctools2idx/tests/data/fail/emsg/04_illegalcmd2
new file mode 100644
index 0000000..57554c7
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/04_illegalcmd2
@@ -0,0 +1 @@
+error on line 1.10: Illegal command "foo", not a docidx command
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/05_nestingbad1 b/tcllib/modules/doctools2idx/tests/data/fail/emsg/05_nestingbad1
new file mode 100644
index 0000000..73dd415
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/05_nestingbad1
@@ -0,0 +1 @@
+error on line 1.20: Illegal use of "vset/2" as argument of other command
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/06_nestingbad2 b/tcllib/modules/doctools2idx/tests/data/fail/emsg/06_nestingbad2
new file mode 100644
index 0000000..b0f1e3d
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/06_nestingbad2
@@ -0,0 +1 @@
+error on line 1.23: Illegal use of "manpage" as argument of other command
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/07_wrongargs b/tcllib/modules/doctools2idx/tests/data/fail/emsg/07_wrongargs
new file mode 100644
index 0000000..4799410
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/07_wrongargs
@@ -0,0 +1 @@
+error on line 1.12: Wrong#args for "index_begin", need at least 2
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/08_toomanyargs b/tcllib/modules/doctools2idx/tests/data/fail/emsg/08_toomanyargs
new file mode 100644
index 0000000..a6c39ee
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/08_toomanyargs
@@ -0,0 +1 @@
+error on line 1.12: Too many args for "index_begin", at most 2 allowed
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/09_vsetvarunknown b/tcllib/modules/doctools2idx/tests/data/fail/emsg/09_vsetvarunknown
new file mode 100644
index 0000000..f73a6bc
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/09_vsetvarunknown
@@ -0,0 +1 @@
+error on line 1.5: Unknown variable "a"
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/10_vsetvarerr b/tcllib/modules/doctools2idx/tests/data/fail/emsg/10_vsetvarerr
new file mode 100644
index 0000000..cf07b85
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/10_vsetvarerr
@@ -0,0 +1 @@
+error on line 1.14: Illegal use of "include" as argument of other command
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/11_vsetvalueerr b/tcllib/modules/doctools2idx/tests/data/fail/emsg/11_vsetvalueerr
new file mode 100644
index 0000000..13eefe5
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/11_vsetvalueerr
@@ -0,0 +1 @@
+error on line 1.16: Illegal use of "include" as argument of other command
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/12_incerror b/tcllib/modules/doctools2idx/tests/data/fail/emsg/12_incerror
new file mode 100644
index 0000000..644618d
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/12_incerror
@@ -0,0 +1 @@
+error on line 1.14: Illegal use of "vset/2" as argument of other command
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/13_incnotfound b/tcllib/modules/doctools2idx/tests/data/fail/emsg/13_incnotfound
new file mode 100644
index 0000000..3750a26
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/13_incnotfound
@@ -0,0 +1 @@
+error on line 1.8: Include file "bogus" not found
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/14_incempty b/tcllib/modules/doctools2idx/tests/data/fail/emsg/14_incempty
new file mode 100644
index 0000000..347f0e9
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/14_incempty
@@ -0,0 +1 @@
+error on line 1.0: Expected [index_begin], not found
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/15_incbadeof b/tcllib/modules/doctools2idx/tests/data/fail/emsg/15_incbadeof
new file mode 100644
index 0000000..390567b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/15_incbadeof
@@ -0,0 +1,2 @@
+error on line 1.8: Errors in include file "@/tests/data/unexpected_eof"
+"@/tests/data/unexpected_eof": error on line 1.27: Bad <eof>
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/16_incbadchar b/tcllib/modules/doctools2idx/tests/data/fail/emsg/16_incbadchar
new file mode 100644
index 0000000..7666aa2
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/16_incbadchar
@@ -0,0 +1,2 @@
+error on line 1.8: Errors in include file "@/tests/data/unexpected_char"
+"@/tests/data/unexpected_char": error on line 1.27: Bad character in string
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/17_badempty b/tcllib/modules/doctools2idx/tests/data/fail/emsg/17_badempty
new file mode 100644
index 0000000..347f0e9
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/17_badempty
@@ -0,0 +1 @@
+error on line 1.0: Expected [index_begin], not found
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/18_nobegin b/tcllib/modules/doctools2idx/tests/data/fail/emsg/18_nobegin
new file mode 100644
index 0000000..9d987bf
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/18_nobegin
@@ -0,0 +1 @@
+error on line 1.10: Expected [index_begin], not found
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/19_manybegin b/tcllib/modules/doctools2idx/tests/data/fail/emsg/19_manybegin
new file mode 100644
index 0000000..cd14ccf
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/19_manybegin
@@ -0,0 +1,3 @@
+error on line 2.12: Expected [key], not found
+error on line 3.12: Expected [key], not found
+error on line 4.12: Expected [key], not found
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/20_latebegin b/tcllib/modules/doctools2idx/tests/data/fail/emsg/20_latebegin
new file mode 100644
index 0000000..57cef7b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/20_latebegin
@@ -0,0 +1,2 @@
+error on line 1.4: Expected [index_begin], not found
+
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/21_noend1 b/tcllib/modules/doctools2idx/tests/data/fail/emsg/21_noend1
new file mode 100644
index 0000000..287ba81
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/21_noend1
@@ -0,0 +1 @@
+error on line 1.12: Expected [index_end], not found
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/22_noend2 b/tcllib/modules/doctools2idx/tests/data/fail/emsg/22_noend2
new file mode 100644
index 0000000..aca6124
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/22_noend2
@@ -0,0 +1 @@
+error on line 2.4: Expected [index_end], not found
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/23_manyend b/tcllib/modules/doctools2idx/tests/data/fail/emsg/23_manyend
new file mode 100644
index 0000000..a87a90f
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/23_manyend
@@ -0,0 +1,3 @@
+error on line 3.10: Unexpected [index_end], not allowed here
+error on line 4.10: Unexpected [index_end], not allowed here
+error on line 5.10: Unexpected [index_end], not allowed here
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/24_earlyend b/tcllib/modules/doctools2idx/tests/data/fail/emsg/24_earlyend
new file mode 100644
index 0000000..dbdc663
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/24_earlyend
@@ -0,0 +1 @@
+error on line 3.4: Unexpected [key], not allowed here
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/25_nobeginend b/tcllib/modules/doctools2idx/tests/data/fail/emsg/25_nobeginend
new file mode 100644
index 0000000..79fd2e6
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/25_nobeginend
@@ -0,0 +1,2 @@
+error on line 1.4: Expected [index_begin], not found
+error on line 2.4: Expected [index_begin], not found
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/26_latekey b/tcllib/modules/doctools2idx/tests/data/fail/emsg/26_latekey
new file mode 100644
index 0000000..b3ce79a
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/26_latekey
@@ -0,0 +1 @@
+error on line 2.4: Expected [key], not found
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/27_incbadcmd b/tcllib/modules/doctools2idx/tests/data/fail/emsg/27_incbadcmd
new file mode 100644
index 0000000..b6bf773
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/27_incbadcmd
@@ -0,0 +1 @@
+"@/tests/data/bad_command" error on line 1.4: Wrong#args for "key", need at least 1
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/28_badredef b/tcllib/modules/doctools2idx/tests/data/fail/emsg/28_badredef
new file mode 100644
index 0000000..b9ce4af
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/28_badredef
@@ -0,0 +1 @@
+error on line 5.8: Bad redefinition of reference "apps/dtplite.man", first (manpage "dtplite"), now (manpage "doc-tools-processor-lite")
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/emsg/29_badredef2 b/tcllib/modules/doctools2idx/tests/data/fail/emsg/29_badredef2
new file mode 100644
index 0000000..6be420f
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/emsg/29_badredef2
@@ -0,0 +1 @@
+error on line 5.4: Bad redefinition of reference "apps/dtplite.man", first (manpage "dtplite"), now (url "dtplite")
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/00_short b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/00_short
new file mode 100644
index 0000000..4329caa
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/00_short
@@ -0,0 +1 @@
+error in serialization: dictionary too short, expected exactly one key
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/01_tag b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/01_tag
new file mode 100644
index 0000000..369116b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/01_tag
@@ -0,0 +1 @@
+error in serialization: bad type tag "FOO"
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/02_cshort b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/02_cshort
new file mode 100644
index 0000000..3aea582
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/02_cshort
@@ -0,0 +1 @@
+error in serialization: dictionary too short, expected exactly four keys
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/03_misslabel b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/03_misslabel
new file mode 100644
index 0000000..3c3da93
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/03_misslabel
@@ -0,0 +1 @@
+error in serialization: missing expected key "label"
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/04_misstitle b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/04_misstitle
new file mode 100644
index 0000000..8401b05
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/04_misstitle
@@ -0,0 +1 @@
+error in serialization: missing expected key "title"
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/05_misskeywords b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/05_misskeywords
new file mode 100644
index 0000000..bded9c9
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/05_misskeywords
@@ -0,0 +1 @@
+error in serialization: missing expected key "keywords"
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/06_missreferences b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/06_missreferences
new file mode 100644
index 0000000..38bd10e
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/06_missreferences
@@ -0,0 +1 @@
+error in serialization: missing expected key "references"
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/10_refmismatcha b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/10_refmismatcha
new file mode 100644
index 0000000..414948b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/10_refmismatcha
@@ -0,0 +1 @@
+error in serialization: use and declaration of references not matching
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/11_refmismatchb b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/11_refmismatchb
new file mode 100644
index 0000000..414948b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/11_refmismatchb
@@ -0,0 +1 @@
+error in serialization: use and declaration of references not matching
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/12_rargs b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/12_rargs
new file mode 100644
index 0000000..4c00f65
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/12_rargs
@@ -0,0 +1 @@
+error in serialization: reference list wrong, need exactly 2
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/13_rtag b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/13_rtag
new file mode 100644
index 0000000..576cd4f
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json-emsg/13_rtag
@@ -0,0 +1 @@
+error in serialization: bad reference tag "foo"
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json/00_short b/tcllib/modules/doctools2idx/tests/data/fail/json/00_short
new file mode 100644
index 0000000..2c63c08
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json/00_short
@@ -0,0 +1,2 @@
+{
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json/01_tag b/tcllib/modules/doctools2idx/tests/data/fail/json/01_tag
new file mode 100644
index 0000000..9803dba
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json/01_tag
@@ -0,0 +1,4 @@
+{
+ "FOO" : {
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json/02_cshort b/tcllib/modules/doctools2idx/tests/data/fail/json/02_cshort
new file mode 100644
index 0000000..3d7d729
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json/02_cshort
@@ -0,0 +1,4 @@
+{
+ "doctools::idx" : {
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json/03_misslabel b/tcllib/modules/doctools2idx/tests/data/fail/json/03_misslabel
new file mode 100644
index 0000000..b13102e
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json/03_misslabel
@@ -0,0 +1,8 @@
+{
+ "doctools::idx" : {
+ "a" : ".",
+ "b" : ".",
+ "c" : ".",
+ "d" : "."
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json/04_misstitle b/tcllib/modules/doctools2idx/tests/data/fail/json/04_misstitle
new file mode 100644
index 0000000..7e2b084
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json/04_misstitle
@@ -0,0 +1,8 @@
+{
+ "doctools::idx" : {
+ "label" : ".",
+ "b" : ".",
+ "c" : ".",
+ "d" : "."
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json/05_misskeywords b/tcllib/modules/doctools2idx/tests/data/fail/json/05_misskeywords
new file mode 100644
index 0000000..3f26182
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json/05_misskeywords
@@ -0,0 +1,8 @@
+{
+ "doctools::idx" : {
+ "label" : ".",
+ "title" : ".",
+ "c" : ".",
+ "d" : "."
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json/06_missreferences b/tcllib/modules/doctools2idx/tests/data/fail/json/06_missreferences
new file mode 100644
index 0000000..0c85404
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json/06_missreferences
@@ -0,0 +1,8 @@
+{
+ "doctools::idx" : {
+ "label" : ".",
+ "title" : ".",
+ "keywords" : ".",
+ "d" : "."
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json/10_refmismatcha b/tcllib/modules/doctools2idx/tests/data/fail/json/10_refmismatcha
new file mode 100644
index 0000000..d9235b0
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json/10_refmismatcha
@@ -0,0 +1,10 @@
+{
+ "doctools::idx" : {
+ "label" : "KWIC",
+ "keywords" : {},
+ "references" : {
+ "a" : ["url", "x"]
+ },
+ "title" : "INDEX"
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json/11_refmismatchb b/tcllib/modules/doctools2idx/tests/data/fail/json/11_refmismatchb
new file mode 100644
index 0000000..cf386d2
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json/11_refmismatchb
@@ -0,0 +1,10 @@
+{
+ "doctools::idx" : {
+ "label" : "KWIC",
+ "keywords" : {
+ "a" : ["b", "c"]
+ },
+ "references" : {},
+ "title" : "INDEX"
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json/12_rargs b/tcllib/modules/doctools2idx/tests/data/fail/json/12_rargs
new file mode 100644
index 0000000..3a230f3
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json/12_rargs
@@ -0,0 +1,12 @@
+{
+ "doctools::idx" : {
+ "label" : "KWIC",
+ "keywords" : {
+ "a" : ["b"]
+ },
+ "references" : {
+ "b" : ["url"]
+ },
+ "title" : "INDEX"
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/fail/json/13_rtag b/tcllib/modules/doctools2idx/tests/data/fail/json/13_rtag
new file mode 100644
index 0000000..cbf0c19
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/fail/json/13_rtag
@@ -0,0 +1,12 @@
+{
+ "doctools::idx" : {
+ "label" : "KWIC",
+ "keywords" : {
+ "a" : ["b"]
+ },
+ "references" : {
+ "b" : ["foo", "B"]
+ },
+ "title" : "INDEX"
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx-aligned/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/docidx-aligned/1_nokeys
new file mode 100644
index 0000000..14e3342
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx-aligned/1_nokeys
@@ -0,0 +1,2 @@
+[index_begin KWIC INDEX]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx-aligned/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/docidx-aligned/2_justkeys
new file mode 100644
index 0000000..343a102
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx-aligned/2_justkeys
@@ -0,0 +1,46 @@
+[index_begin {Keyword Index} {}]
+[key changelog]
+[key conversion]
+[key cvs]
+[key {cvs log}]
+[key docidx]
+[key {docidx commands}]
+[key {docidx language}]
+[key {docidx markup}]
+[key {docidx syntax}]
+[key doctoc]
+[key {doctoc commands}]
+[key {doctoc language}]
+[key {doctoc markup}]
+[key {doctoc syntax}]
+[key doctools]
+[key {doctools commands}]
+[key {doctools language}]
+[key {doctools markup}]
+[key {doctools syntax}]
+[key document]
+[key documentation]
+[key emacs]
+[key examples]
+[key faq]
+[key formatter]
+[key {formatting engine}]
+[key HTML]
+[key index]
+[key {index formatter}]
+[key {keyword index}]
+[key keywords]
+[key latex]
+[key log]
+[key manpage]
+[key markup]
+[key nroff]
+[key plugin]
+[key {semantic markup}]
+[key {table of contents}]
+[key TMML]
+[key toc]
+[key {toc formatter}]
+[key web]
+[key wiki]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx-aligned/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/docidx-aligned/3_kwic
new file mode 100644
index 0000000..8875313
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx-aligned/3_kwic
@@ -0,0 +1,206 @@
+[index_begin {Keyword Index} {}]
+[key changelog]
+[manpage changelog.man doctools::changelog]
+[manpage cvs.man doctools::cvs]
+[key conversion]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key cvs]
+[manpage cvs.man doctools::cvs]
+[key {cvs log}]
+[manpage cvs.man doctools::cvs]
+[key docidx]
+[manpage docidx.man doctools::idx]
+[manpage apps/dtplite.man dtplite]
+[key {docidx commands}]
+[manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[key {docidx language}]
+[manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[key {docidx markup}]
+[manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[key {docidx syntax}]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[key doctoc]
+[manpage doctoc.man doctools::toc]
+[manpage apps/dtplite.man dtplite]
+[key {doctoc commands}]
+[manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[key {doctoc language}]
+[manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[key {doctoc markup}]
+[manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[key {doctoc syntax}]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[key doctools]
+[manpage changelog.man doctools::changelog]
+[manpage apps/dtplite.man dtplite]
+[key {doctools commands}]
+[manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[key {doctools language}]
+[manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[key {doctools markup}]
+[manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[key {doctools syntax}]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[key document]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[key documentation]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[key emacs]
+[manpage changelog.man doctools::changelog]
+[manpage cvs.man doctools::cvs]
+[key examples]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[key faq]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[key formatter]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[key {formatting engine}]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[key HTML]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key index]
+[manpage docidx_intro.man docidx_intro]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[manpage docidx.man doctools::idx]
+[key {index formatter}]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[key {keyword index}]
+[manpage docidx_intro.man docidx_intro]
+[manpage docidx.man doctools::idx]
+[key keywords]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[key latex]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[key log]
+[manpage cvs.man doctools::cvs]
+[key manpage]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key markup]
+[manpage docidx_intro.man docidx_intro]
+[manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[manpage doctoc_intro.man doctoc_intro]
+[manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage doctools_intro.man doctools_intro]
+[manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key nroff]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key plugin]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[key {semantic markup}]
+[manpage docidx_intro.man docidx_intro]
+[manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[manpage doctoc_intro.man doctoc_intro]
+[manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[manpage doctools_intro.man doctools_intro]
+[manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[key {table of contents}]
+[manpage doctoc_intro.man doctoc_intro]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[manpage doctoc.man doctools::toc]
+[key TMML]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key toc]
+[manpage doctoc_intro.man doctoc_intro]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[manpage doctoc.man doctools::toc]
+[key {toc formatter}]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[key web]
+[url http://tcllib.sourceforge.net/doc/docidx_lang_intro.html {docidx language introduction}]
+[key wiki]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx-compact/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/docidx-compact/1_nokeys
new file mode 100644
index 0000000..14e3342
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx-compact/1_nokeys
@@ -0,0 +1,2 @@
+[index_begin KWIC INDEX]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx-compact/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/docidx-compact/2_justkeys
new file mode 100644
index 0000000..343a102
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx-compact/2_justkeys
@@ -0,0 +1,46 @@
+[index_begin {Keyword Index} {}]
+[key changelog]
+[key conversion]
+[key cvs]
+[key {cvs log}]
+[key docidx]
+[key {docidx commands}]
+[key {docidx language}]
+[key {docidx markup}]
+[key {docidx syntax}]
+[key doctoc]
+[key {doctoc commands}]
+[key {doctoc language}]
+[key {doctoc markup}]
+[key {doctoc syntax}]
+[key doctools]
+[key {doctools commands}]
+[key {doctools language}]
+[key {doctools markup}]
+[key {doctools syntax}]
+[key document]
+[key documentation]
+[key emacs]
+[key examples]
+[key faq]
+[key formatter]
+[key {formatting engine}]
+[key HTML]
+[key index]
+[key {index formatter}]
+[key {keyword index}]
+[key keywords]
+[key latex]
+[key log]
+[key manpage]
+[key markup]
+[key nroff]
+[key plugin]
+[key {semantic markup}]
+[key {table of contents}]
+[key TMML]
+[key toc]
+[key {toc formatter}]
+[key web]
+[key wiki]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx-compact/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/docidx-compact/3_kwic
new file mode 100644
index 0000000..6a27b44
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx-compact/3_kwic
@@ -0,0 +1,206 @@
+[index_begin {Keyword Index} {}]
+[key changelog]
+[manpage changelog.man doctools::changelog]
+[manpage cvs.man doctools::cvs]
+[key conversion]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key cvs]
+[manpage cvs.man doctools::cvs]
+[key {cvs log}]
+[manpage cvs.man doctools::cvs]
+[key docidx]
+[manpage docidx.man doctools::idx]
+[manpage apps/dtplite.man dtplite]
+[key {docidx commands}]
+[manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[key {docidx language}]
+[manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[key {docidx markup}]
+[manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[key {docidx syntax}]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[key doctoc]
+[manpage doctoc.man doctools::toc]
+[manpage apps/dtplite.man dtplite]
+[key {doctoc commands}]
+[manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[key {doctoc language}]
+[manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[key {doctoc markup}]
+[manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[key {doctoc syntax}]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[key doctools]
+[manpage changelog.man doctools::changelog]
+[manpage apps/dtplite.man dtplite]
+[key {doctools commands}]
+[manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[key {doctools language}]
+[manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[key {doctools markup}]
+[manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[key {doctools syntax}]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[key document]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[key documentation]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[key emacs]
+[manpage changelog.man doctools::changelog]
+[manpage cvs.man doctools::cvs]
+[key examples]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[key faq]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[key formatter]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[key {formatting engine}]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[key HTML]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key index]
+[manpage docidx_intro.man docidx_intro]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[manpage docidx.man doctools::idx]
+[key {index formatter}]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[key {keyword index}]
+[manpage docidx_intro.man docidx_intro]
+[manpage docidx.man doctools::idx]
+[key keywords]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[key latex]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[key log]
+[manpage cvs.man doctools::cvs]
+[key manpage]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key markup]
+[manpage docidx_intro.man docidx_intro]
+[manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[manpage doctoc_intro.man doctoc_intro]
+[manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage doctools_intro.man doctools_intro]
+[manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key nroff]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key plugin]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[key {semantic markup}]
+[manpage docidx_intro.man docidx_intro]
+[manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[manpage doctoc_intro.man doctoc_intro]
+[manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[manpage doctools_intro.man doctools_intro]
+[manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[key {table of contents}]
+[manpage doctoc_intro.man doctoc_intro]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[manpage doctoc.man doctools::toc]
+[key TMML]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key toc]
+[manpage doctoc_intro.man doctoc_intro]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[manpage doctoc.man doctools::toc]
+[key {toc formatter}]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[key web]
+[url http://tcllib.sourceforge.net/doc/docidx_lang_intro.html {docidx language introduction}]
+[key wiki]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx-indalign/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/docidx-indalign/1_nokeys
new file mode 100644
index 0000000..5b2857d
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx-indalign/1_nokeys
@@ -0,0 +1,2 @@
+[index_begin KWIC INDEX]
+[index_end] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx-indalign/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/docidx-indalign/2_justkeys
new file mode 100644
index 0000000..5267b23
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx-indalign/2_justkeys
@@ -0,0 +1,46 @@
+[index_begin {Keyword Index} {}]
+ [key changelog]
+ [key conversion]
+ [key cvs]
+ [key {cvs log}]
+ [key docidx]
+ [key {docidx commands}]
+ [key {docidx language}]
+ [key {docidx markup}]
+ [key {docidx syntax}]
+ [key doctoc]
+ [key {doctoc commands}]
+ [key {doctoc language}]
+ [key {doctoc markup}]
+ [key {doctoc syntax}]
+ [key doctools]
+ [key {doctools commands}]
+ [key {doctools language}]
+ [key {doctools markup}]
+ [key {doctools syntax}]
+ [key document]
+ [key documentation]
+ [key emacs]
+ [key examples]
+ [key faq]
+ [key formatter]
+ [key {formatting engine}]
+ [key HTML]
+ [key index]
+ [key {index formatter}]
+ [key {keyword index}]
+ [key keywords]
+ [key latex]
+ [key log]
+ [key manpage]
+ [key markup]
+ [key nroff]
+ [key plugin]
+ [key {semantic markup}]
+ [key {table of contents}]
+ [key TMML]
+ [key toc]
+ [key {toc formatter}]
+ [key web]
+ [key wiki]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx-indalign/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/docidx-indalign/3_kwic
new file mode 100644
index 0000000..4882a2f
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx-indalign/3_kwic
@@ -0,0 +1,206 @@
+[index_begin {Keyword Index} {}]
+ [key changelog]
+ [manpage changelog.man doctools::changelog]
+ [manpage cvs.man doctools::cvs]
+ [key conversion]
+ [manpage doctools.man doctools]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [manpage apps/dtplite.man dtplite]
+ [manpage mpexpand.man mpexpand]
+ [key cvs]
+ [manpage cvs.man doctools::cvs]
+ [key {cvs log}]
+ [manpage cvs.man doctools::cvs]
+ [key docidx]
+ [manpage docidx.man doctools::idx]
+ [manpage apps/dtplite.man dtplite]
+ [key {docidx commands}]
+ [manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage docidx_lang_intro.man docidx_lang_intro]
+ [manpage docidx_lang_syntax.man docidx_lang_syntax]
+ [key {docidx language}]
+ [manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage docidx_lang_intro.man docidx_lang_intro]
+ [manpage docidx_lang_syntax.man docidx_lang_syntax]
+ [key {docidx markup}]
+ [manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage docidx_lang_intro.man docidx_lang_intro]
+ [manpage docidx_lang_syntax.man docidx_lang_syntax]
+ [key {docidx syntax}]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage docidx_lang_intro.man docidx_lang_intro]
+ [manpage docidx_lang_syntax.man docidx_lang_syntax]
+ [key doctoc]
+ [manpage doctoc.man doctools::toc]
+ [manpage apps/dtplite.man dtplite]
+ [key {doctoc commands}]
+ [manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctoc_lang_intro.man doctoc_lang_intro]
+ [manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+ [key {doctoc language}]
+ [manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctoc_lang_intro.man doctoc_lang_intro]
+ [manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+ [key {doctoc markup}]
+ [manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctoc_lang_intro.man doctoc_lang_intro]
+ [manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+ [key {doctoc syntax}]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctoc_lang_intro.man doctoc_lang_intro]
+ [manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+ [key doctools]
+ [manpage changelog.man doctools::changelog]
+ [manpage apps/dtplite.man dtplite]
+ [key {doctools commands}]
+ [manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [manpage doctools_lang_intro.man doctools_lang_intro]
+ [manpage doctools_lang_syntax.man doctools_lang_syntax]
+ [key {doctools language}]
+ [manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [manpage doctools_lang_intro.man doctools_lang_intro]
+ [manpage doctools_lang_syntax.man doctools_lang_syntax]
+ [key {doctools markup}]
+ [manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [manpage doctools_lang_intro.man doctools_lang_intro]
+ [manpage doctools_lang_syntax.man doctools_lang_syntax]
+ [key {doctools syntax}]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [manpage doctools_lang_intro.man doctools_lang_intro]
+ [manpage doctools_lang_syntax.man doctools_lang_syntax]
+ [key document]
+ [manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+ [key documentation]
+ [manpage doctools.man doctools]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [key emacs]
+ [manpage changelog.man doctools::changelog]
+ [manpage cvs.man doctools::cvs]
+ [key examples]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [key faq]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [key formatter]
+ [manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+ [key {formatting engine}]
+ [manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+ [manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+ [manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+ [key HTML]
+ [manpage doctools.man doctools]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [manpage apps/dtplite.man dtplite]
+ [manpage mpexpand.man mpexpand]
+ [key index]
+ [manpage docidx_intro.man docidx_intro]
+ [manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+ [manpage docidx.man doctools::idx]
+ [key {index formatter}]
+ [manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+ [key {keyword index}]
+ [manpage docidx_intro.man docidx_intro]
+ [manpage docidx.man doctools::idx]
+ [key keywords]
+ [manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+ [key latex]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [key log]
+ [manpage cvs.man doctools::cvs]
+ [key manpage]
+ [manpage doctools.man doctools]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+ [manpage apps/dtplite.man dtplite]
+ [manpage mpexpand.man mpexpand]
+ [key markup]
+ [manpage docidx_intro.man docidx_intro]
+ [manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage docidx_lang_intro.man docidx_lang_intro]
+ [manpage docidx_lang_syntax.man docidx_lang_syntax]
+ [manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+ [manpage doctoc_intro.man doctoc_intro]
+ [manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctoc_lang_intro.man doctoc_lang_intro]
+ [manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+ [manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+ [manpage doctools.man doctools]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [manpage doctools_intro.man doctools_intro]
+ [manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [manpage doctools_lang_intro.man doctools_lang_intro]
+ [manpage doctools_lang_syntax.man doctools_lang_syntax]
+ [manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+ [manpage apps/dtplite.man dtplite]
+ [manpage mpexpand.man mpexpand]
+ [key nroff]
+ [manpage doctools.man doctools]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [manpage apps/dtplite.man dtplite]
+ [manpage mpexpand.man mpexpand]
+ [key plugin]
+ [manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+ [manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+ [key {semantic markup}]
+ [manpage docidx_intro.man docidx_intro]
+ [manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage docidx_lang_intro.man docidx_lang_intro]
+ [manpage docidx_lang_syntax.man docidx_lang_syntax]
+ [manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+ [manpage doctoc_intro.man doctoc_intro]
+ [manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctoc_lang_intro.man doctoc_lang_intro]
+ [manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+ [manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+ [manpage doctools_intro.man doctools_intro]
+ [manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [manpage doctools_lang_intro.man doctools_lang_intro]
+ [manpage doctools_lang_syntax.man doctools_lang_syntax]
+ [manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+ [key {table of contents}]
+ [manpage doctoc_intro.man doctoc_intro]
+ [manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+ [manpage doctoc.man doctools::toc]
+ [key TMML]
+ [manpage doctools.man doctools]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [manpage apps/dtplite.man dtplite]
+ [manpage mpexpand.man mpexpand]
+ [key toc]
+ [manpage doctoc_intro.man doctoc_intro]
+ [manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+ [manpage doctoc.man doctools::toc]
+ [key {toc formatter}]
+ [manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+ [key web]
+ [url http://tcllib.sourceforge.net/doc/docidx_lang_intro.html {docidx language introduction}]
+ [key wiki]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx-indented/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/docidx-indented/1_nokeys
new file mode 100644
index 0000000..14e3342
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx-indented/1_nokeys
@@ -0,0 +1,2 @@
+[index_begin KWIC INDEX]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx-indented/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/docidx-indented/2_justkeys
new file mode 100644
index 0000000..5267b23
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx-indented/2_justkeys
@@ -0,0 +1,46 @@
+[index_begin {Keyword Index} {}]
+ [key changelog]
+ [key conversion]
+ [key cvs]
+ [key {cvs log}]
+ [key docidx]
+ [key {docidx commands}]
+ [key {docidx language}]
+ [key {docidx markup}]
+ [key {docidx syntax}]
+ [key doctoc]
+ [key {doctoc commands}]
+ [key {doctoc language}]
+ [key {doctoc markup}]
+ [key {doctoc syntax}]
+ [key doctools]
+ [key {doctools commands}]
+ [key {doctools language}]
+ [key {doctools markup}]
+ [key {doctools syntax}]
+ [key document]
+ [key documentation]
+ [key emacs]
+ [key examples]
+ [key faq]
+ [key formatter]
+ [key {formatting engine}]
+ [key HTML]
+ [key index]
+ [key {index formatter}]
+ [key {keyword index}]
+ [key keywords]
+ [key latex]
+ [key log]
+ [key manpage]
+ [key markup]
+ [key nroff]
+ [key plugin]
+ [key {semantic markup}]
+ [key {table of contents}]
+ [key TMML]
+ [key toc]
+ [key {toc formatter}]
+ [key web]
+ [key wiki]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx-indented/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/docidx-indented/3_kwic
new file mode 100644
index 0000000..8234537
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx-indented/3_kwic
@@ -0,0 +1,206 @@
+[index_begin {Keyword Index} {}]
+ [key changelog]
+ [manpage changelog.man doctools::changelog]
+ [manpage cvs.man doctools::cvs]
+ [key conversion]
+ [manpage doctools.man doctools]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [manpage apps/dtplite.man dtplite]
+ [manpage mpexpand.man mpexpand]
+ [key cvs]
+ [manpage cvs.man doctools::cvs]
+ [key {cvs log}]
+ [manpage cvs.man doctools::cvs]
+ [key docidx]
+ [manpage docidx.man doctools::idx]
+ [manpage apps/dtplite.man dtplite]
+ [key {docidx commands}]
+ [manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage docidx_lang_intro.man docidx_lang_intro]
+ [manpage docidx_lang_syntax.man docidx_lang_syntax]
+ [key {docidx language}]
+ [manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage docidx_lang_intro.man docidx_lang_intro]
+ [manpage docidx_lang_syntax.man docidx_lang_syntax]
+ [key {docidx markup}]
+ [manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage docidx_lang_intro.man docidx_lang_intro]
+ [manpage docidx_lang_syntax.man docidx_lang_syntax]
+ [key {docidx syntax}]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage docidx_lang_intro.man docidx_lang_intro]
+ [manpage docidx_lang_syntax.man docidx_lang_syntax]
+ [key doctoc]
+ [manpage doctoc.man doctools::toc]
+ [manpage apps/dtplite.man dtplite]
+ [key {doctoc commands}]
+ [manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctoc_lang_intro.man doctoc_lang_intro]
+ [manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+ [key {doctoc language}]
+ [manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctoc_lang_intro.man doctoc_lang_intro]
+ [manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+ [key {doctoc markup}]
+ [manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctoc_lang_intro.man doctoc_lang_intro]
+ [manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+ [key {doctoc syntax}]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctoc_lang_intro.man doctoc_lang_intro]
+ [manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+ [key doctools]
+ [manpage changelog.man doctools::changelog]
+ [manpage apps/dtplite.man dtplite]
+ [key {doctools commands}]
+ [manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [manpage doctools_lang_intro.man doctools_lang_intro]
+ [manpage doctools_lang_syntax.man doctools_lang_syntax]
+ [key {doctools language}]
+ [manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [manpage doctools_lang_intro.man doctools_lang_intro]
+ [manpage doctools_lang_syntax.man doctools_lang_syntax]
+ [key {doctools markup}]
+ [manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [manpage doctools_lang_intro.man doctools_lang_intro]
+ [manpage doctools_lang_syntax.man doctools_lang_syntax]
+ [key {doctools syntax}]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [manpage doctools_lang_intro.man doctools_lang_intro]
+ [manpage doctools_lang_syntax.man doctools_lang_syntax]
+ [key document]
+ [manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+ [key documentation]
+ [manpage doctools.man doctools]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [key emacs]
+ [manpage changelog.man doctools::changelog]
+ [manpage cvs.man doctools::cvs]
+ [key examples]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [key faq]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [key formatter]
+ [manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+ [key {formatting engine}]
+ [manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+ [manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+ [manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+ [key HTML]
+ [manpage doctools.man doctools]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [manpage apps/dtplite.man dtplite]
+ [manpage mpexpand.man mpexpand]
+ [key index]
+ [manpage docidx_intro.man docidx_intro]
+ [manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+ [manpage docidx.man doctools::idx]
+ [key {index formatter}]
+ [manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+ [key {keyword index}]
+ [manpage docidx_intro.man docidx_intro]
+ [manpage docidx.man doctools::idx]
+ [key keywords]
+ [manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+ [key latex]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [key log]
+ [manpage cvs.man doctools::cvs]
+ [key manpage]
+ [manpage doctools.man doctools]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+ [manpage apps/dtplite.man dtplite]
+ [manpage mpexpand.man mpexpand]
+ [key markup]
+ [manpage docidx_intro.man docidx_intro]
+ [manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage docidx_lang_intro.man docidx_lang_intro]
+ [manpage docidx_lang_syntax.man docidx_lang_syntax]
+ [manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+ [manpage doctoc_intro.man doctoc_intro]
+ [manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctoc_lang_intro.man doctoc_lang_intro]
+ [manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+ [manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+ [manpage doctools.man doctools]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [manpage doctools_intro.man doctools_intro]
+ [manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [manpage doctools_lang_intro.man doctools_lang_intro]
+ [manpage doctools_lang_syntax.man doctools_lang_syntax]
+ [manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+ [manpage apps/dtplite.man dtplite]
+ [manpage mpexpand.man mpexpand]
+ [key nroff]
+ [manpage doctools.man doctools]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [manpage apps/dtplite.man dtplite]
+ [manpage mpexpand.man mpexpand]
+ [key plugin]
+ [manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+ [manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+ [key {semantic markup}]
+ [manpage docidx_intro.man docidx_intro]
+ [manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+ [manpage docidx_lang_faq.man docidx_lang_faq]
+ [manpage docidx_lang_intro.man docidx_lang_intro]
+ [manpage docidx_lang_syntax.man docidx_lang_syntax]
+ [manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+ [manpage doctoc_intro.man doctoc_intro]
+ [manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+ [manpage doctoc_lang_faq.man doctoc_lang_faq]
+ [manpage doctoc_lang_intro.man doctoc_lang_intro]
+ [manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+ [manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+ [manpage doctools_intro.man doctools_intro]
+ [manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+ [manpage doctools_lang_faq.man doctools_lang_faq]
+ [manpage doctools_lang_intro.man doctools_lang_intro]
+ [manpage doctools_lang_syntax.man doctools_lang_syntax]
+ [manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+ [key {table of contents}]
+ [manpage doctoc_intro.man doctoc_intro]
+ [manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+ [manpage doctoc.man doctools::toc]
+ [key TMML]
+ [manpage doctools.man doctools]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+ [manpage apps/dtplite.man dtplite]
+ [manpage mpexpand.man mpexpand]
+ [key toc]
+ [manpage doctoc_intro.man doctoc_intro]
+ [manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+ [manpage doctoc.man doctools::toc]
+ [key {toc formatter}]
+ [manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+ [key web]
+ [url http://tcllib.sourceforge.net/doc/docidx_lang_intro.html {docidx language introduction}]
+ [key wiki]
+ [manpage docidx.man doctools::idx]
+ [manpage doctoc.man doctools::toc]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx-ultracompact/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/docidx-ultracompact/1_nokeys
new file mode 100644
index 0000000..eb66b15
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx-ultracompact/1_nokeys
@@ -0,0 +1 @@
+[index_begin KWIC INDEX][index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx-ultracompact/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/docidx-ultracompact/2_justkeys
new file mode 100644
index 0000000..267b96b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx-ultracompact/2_justkeys
@@ -0,0 +1 @@
+[index_begin {Keyword Index} {}][key changelog][key conversion][key cvs][key {cvs log}][key docidx][key {docidx commands}][key {docidx language}][key {docidx markup}][key {docidx syntax}][key doctoc][key {doctoc commands}][key {doctoc language}][key {doctoc markup}][key {doctoc syntax}][key doctools][key {doctools commands}][key {doctools language}][key {doctools markup}][key {doctools syntax}][key document][key documentation][key emacs][key examples][key faq][key formatter][key {formatting engine}][key HTML][key index][key {index formatter}][key {keyword index}][key keywords][key latex][key log][key manpage][key markup][key nroff][key plugin][key {semantic markup}][key {table of contents}][key TMML][key toc][key {toc formatter}][key web][key wiki][index_end] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx-ultracompact/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/docidx-ultracompact/3_kwic
new file mode 100644
index 0000000..784970c
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx-ultracompact/3_kwic
@@ -0,0 +1 @@
+[index_begin {Keyword Index} {}][key changelog][manpage changelog.man doctools::changelog][manpage cvs.man doctools::cvs][key conversion][manpage doctools.man doctools][manpage docidx.man doctools::idx][manpage doctoc.man doctools::toc][manpage apps/dtplite.man dtplite][manpage mpexpand.man mpexpand][key cvs][manpage cvs.man doctools::cvs][key {cvs log}][manpage cvs.man doctools::cvs][key docidx][manpage docidx.man doctools::idx][manpage apps/dtplite.man dtplite][key {docidx commands}][manpage docidx_lang_cmdref.man docidx_lang_cmdref][manpage docidx_lang_faq.man docidx_lang_faq][manpage docidx_lang_intro.man docidx_lang_intro][manpage docidx_lang_syntax.man docidx_lang_syntax][key {docidx language}][manpage docidx_lang_cmdref.man docidx_lang_cmdref][manpage docidx_lang_faq.man docidx_lang_faq][manpage docidx_lang_intro.man docidx_lang_intro][manpage docidx_lang_syntax.man docidx_lang_syntax][key {docidx markup}][manpage docidx_lang_cmdref.man docidx_lang_cmdref][manpage docidx_lang_faq.man docidx_lang_faq][manpage docidx_lang_intro.man docidx_lang_intro][manpage docidx_lang_syntax.man docidx_lang_syntax][key {docidx syntax}][manpage docidx_lang_faq.man docidx_lang_faq][manpage docidx_lang_intro.man docidx_lang_intro][manpage docidx_lang_syntax.man docidx_lang_syntax][key doctoc][manpage doctoc.man doctools::toc][manpage apps/dtplite.man dtplite][key {doctoc commands}][manpage doctoc_lang_cmdref.man doctoc_lang_cmdref][manpage doctoc_lang_faq.man doctoc_lang_faq][manpage doctoc_lang_intro.man doctoc_lang_intro][manpage doctoc_lang_syntax.man doctoc_lang_syntax][key {doctoc language}][manpage doctoc_lang_cmdref.man doctoc_lang_cmdref][manpage doctoc_lang_faq.man doctoc_lang_faq][manpage doctoc_lang_intro.man doctoc_lang_intro][manpage doctoc_lang_syntax.man doctoc_lang_syntax][key {doctoc markup}][manpage doctoc_lang_cmdref.man doctoc_lang_cmdref][manpage doctoc_lang_faq.man doctoc_lang_faq][manpage doctoc_lang_intro.man doctoc_lang_intro][manpage doctoc_lang_syntax.man doctoc_lang_syntax][key {doctoc syntax}][manpage doctoc_lang_faq.man doctoc_lang_faq][manpage doctoc_lang_intro.man doctoc_lang_intro][manpage doctoc_lang_syntax.man doctoc_lang_syntax][key doctools][manpage changelog.man doctools::changelog][manpage apps/dtplite.man dtplite][key {doctools commands}][manpage doctools_lang_cmdref.man doctools_lang_cmdref][manpage doctools_lang_faq.man doctools_lang_faq][manpage doctools_lang_intro.man doctools_lang_intro][manpage doctools_lang_syntax.man doctools_lang_syntax][key {doctools language}][manpage doctools_lang_cmdref.man doctools_lang_cmdref][manpage doctools_lang_faq.man doctools_lang_faq][manpage doctools_lang_intro.man doctools_lang_intro][manpage doctools_lang_syntax.man doctools_lang_syntax][key {doctools markup}][manpage doctools_lang_cmdref.man doctools_lang_cmdref][manpage doctools_lang_faq.man doctools_lang_faq][manpage doctools_lang_intro.man doctools_lang_intro][manpage doctools_lang_syntax.man doctools_lang_syntax][key {doctools syntax}][manpage doctools_lang_faq.man doctools_lang_faq][manpage doctools_lang_intro.man doctools_lang_intro][manpage doctools_lang_syntax.man doctools_lang_syntax][key document][manpage doctools_plugin_apiref.man doctools_plugin_apiref][key documentation][manpage doctools.man doctools][manpage docidx.man doctools::idx][manpage doctoc.man doctools::toc][key emacs][manpage changelog.man doctools::changelog][manpage cvs.man doctools::cvs][key examples][manpage docidx_lang_faq.man docidx_lang_faq][manpage doctoc_lang_faq.man doctoc_lang_faq][manpage doctools_lang_faq.man doctools_lang_faq][key faq][manpage docidx_lang_faq.man docidx_lang_faq][manpage doctoc_lang_faq.man doctoc_lang_faq][manpage doctools_lang_faq.man doctools_lang_faq][key formatter][manpage doctools_plugin_apiref.man doctools_plugin_apiref][key {formatting engine}][manpage docidx_plugin_apiref.man docidx_plugin_apiref][manpage doctoc_plugin_apiref.man doctoc_plugin_apiref][manpage doctools_plugin_apiref.man doctools_plugin_apiref][key HTML][manpage doctools.man doctools][manpage docidx.man doctools::idx][manpage doctoc.man doctools::toc][manpage apps/dtplite.man dtplite][manpage mpexpand.man mpexpand][key index][manpage docidx_intro.man docidx_intro][manpage docidx_plugin_apiref.man docidx_plugin_apiref][manpage docidx.man doctools::idx][key {index formatter}][manpage docidx_plugin_apiref.man docidx_plugin_apiref][key {keyword index}][manpage docidx_intro.man docidx_intro][manpage docidx.man doctools::idx][key keywords][manpage docidx_plugin_apiref.man docidx_plugin_apiref][key latex][manpage docidx.man doctools::idx][manpage doctoc.man doctools::toc][key log][manpage cvs.man doctools::cvs][key manpage][manpage doctools.man doctools][manpage docidx.man doctools::idx][manpage doctoc.man doctools::toc][manpage doctools_plugin_apiref.man doctools_plugin_apiref][manpage apps/dtplite.man dtplite][manpage mpexpand.man mpexpand][key markup][manpage docidx_intro.man docidx_intro][manpage docidx_lang_cmdref.man docidx_lang_cmdref][manpage docidx_lang_faq.man docidx_lang_faq][manpage docidx_lang_intro.man docidx_lang_intro][manpage docidx_lang_syntax.man docidx_lang_syntax][manpage docidx_plugin_apiref.man docidx_plugin_apiref][manpage doctoc_intro.man doctoc_intro][manpage doctoc_lang_cmdref.man doctoc_lang_cmdref][manpage doctoc_lang_faq.man doctoc_lang_faq][manpage doctoc_lang_intro.man doctoc_lang_intro][manpage doctoc_lang_syntax.man doctoc_lang_syntax][manpage doctoc_plugin_apiref.man doctoc_plugin_apiref][manpage doctools.man doctools][manpage docidx.man doctools::idx][manpage doctoc.man doctools::toc][manpage doctools_intro.man doctools_intro][manpage doctools_lang_cmdref.man doctools_lang_cmdref][manpage doctools_lang_faq.man doctools_lang_faq][manpage doctools_lang_intro.man doctools_lang_intro][manpage doctools_lang_syntax.man doctools_lang_syntax][manpage doctools_plugin_apiref.man doctools_plugin_apiref][manpage apps/dtplite.man dtplite][manpage mpexpand.man mpexpand][key nroff][manpage doctools.man doctools][manpage docidx.man doctools::idx][manpage doctoc.man doctools::toc][manpage apps/dtplite.man dtplite][manpage mpexpand.man mpexpand][key plugin][manpage docidx_plugin_apiref.man docidx_plugin_apiref][manpage doctoc_plugin_apiref.man doctoc_plugin_apiref][key {semantic markup}][manpage docidx_intro.man docidx_intro][manpage docidx_lang_cmdref.man docidx_lang_cmdref][manpage docidx_lang_faq.man docidx_lang_faq][manpage docidx_lang_intro.man docidx_lang_intro][manpage docidx_lang_syntax.man docidx_lang_syntax][manpage docidx_plugin_apiref.man docidx_plugin_apiref][manpage doctoc_intro.man doctoc_intro][manpage doctoc_lang_cmdref.man doctoc_lang_cmdref][manpage doctoc_lang_faq.man doctoc_lang_faq][manpage doctoc_lang_intro.man doctoc_lang_intro][manpage doctoc_lang_syntax.man doctoc_lang_syntax][manpage doctoc_plugin_apiref.man doctoc_plugin_apiref][manpage doctools_intro.man doctools_intro][manpage doctools_lang_cmdref.man doctools_lang_cmdref][manpage doctools_lang_faq.man doctools_lang_faq][manpage doctools_lang_intro.man doctools_lang_intro][manpage doctools_lang_syntax.man doctools_lang_syntax][manpage doctools_plugin_apiref.man doctools_plugin_apiref][key {table of contents}][manpage doctoc_intro.man doctoc_intro][manpage doctoc_plugin_apiref.man doctoc_plugin_apiref][manpage doctoc.man doctools::toc][key TMML][manpage doctools.man doctools][manpage docidx.man doctools::idx][manpage doctoc.man doctools::toc][manpage apps/dtplite.man dtplite][manpage mpexpand.man mpexpand][key toc][manpage doctoc_intro.man doctoc_intro][manpage doctoc_plugin_apiref.man doctoc_plugin_apiref][manpage doctoc.man doctools::toc][key {toc formatter}][manpage doctoc_plugin_apiref.man doctoc_plugin_apiref][key web][url http://tcllib.sourceforge.net/doc/docidx_lang_intro.html {docidx language introduction}][key wiki][manpage docidx.man doctools::idx][manpage doctoc.man doctools::toc][index_end] \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/docidx/1_nokeys
new file mode 100644
index 0000000..14e3342
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx/1_nokeys
@@ -0,0 +1,2 @@
+[index_begin KWIC INDEX]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/docidx/2_justkeys
new file mode 100644
index 0000000..7be2640
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx/2_justkeys
@@ -0,0 +1,51 @@
+[comment {
+ Note: The keys are purposefully not completely sorted
+ (alphabetically), to catch if parts of the system are not
+ generating canonical serializations.
+}]
+[index_begin {Keyword Index} {}]
+[key {semantic markup}]
+[key {table of contents}]
+[key TMML]
+[key toc]
+[key {toc formatter}]
+[key wiki]
+[key {web}]
+[key changelog]
+[key conversion]
+[key cvs]
+[key {cvs log}]
+[key docidx]
+[key {docidx commands}]
+[key {docidx language}]
+[key {docidx markup}]
+[key {docidx syntax}]
+[key doctoc]
+[key {doctoc commands}]
+[key {doctoc language}]
+[key {doctoc markup}]
+[key {doctoc syntax}]
+[key doctools]
+[key {doctools commands}]
+[key {doctools language}]
+[key {doctools markup}]
+[key {doctools syntax}]
+[key document]
+[key documentation]
+[key emacs]
+[key examples]
+[key faq]
+[key formatter]
+[key {formatting engine}]
+[key HTML]
+[key index]
+[key {index formatter}]
+[key {keyword index}]
+[key keywords]
+[key latex]
+[key log]
+[key manpage]
+[key markup]
+[key nroff]
+[key plugin]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/docidx/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/docidx/3_kwic
new file mode 100644
index 0000000..5f9bb9b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/docidx/3_kwic
@@ -0,0 +1,211 @@
+[comment {
+ Note: The keys and references are purposefully not completely
+ sorted (alphabetically), to catch if parts of the system are
+ not generating canonical serializations.
+}]
+[index_begin {Keyword Index} {}]
+[key {table of contents}]
+[manpage doctoc_intro.man doctoc_intro]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[manpage doctoc.man doctools::toc]
+[key TMML]
+[manpage apps/dtplite.man dtplite]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage mpexpand.man mpexpand]
+[key toc]
+[manpage doctoc_intro.man doctoc_intro]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[manpage doctoc.man doctools::toc]
+[key {toc formatter}]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[key wiki]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[key {web}]
+[url http://tcllib.sourceforge.net/doc/docidx_lang_intro.html {docidx language introduction}]
+[key changelog]
+[manpage changelog.man doctools::changelog]
+[manpage cvs.man doctools::cvs]
+[key conversion]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key cvs]
+[manpage cvs.man doctools::cvs]
+[key {cvs log}]
+[manpage cvs.man doctools::cvs]
+[key docidx]
+[manpage docidx.man doctools::idx]
+[manpage apps/dtplite.man dtplite]
+[key {docidx commands}]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[key {docidx language}]
+[manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[key {docidx markup}]
+[manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[key {docidx syntax}]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[key doctoc]
+[manpage doctoc.man doctools::toc]
+[manpage apps/dtplite.man dtplite]
+[key {doctoc commands}]
+[manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[key {doctoc language}]
+[manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[key {doctoc markup}]
+[manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[key {doctoc syntax}]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[key doctools]
+[manpage changelog.man doctools::changelog]
+[manpage apps/dtplite.man dtplite]
+[key {doctools commands}]
+[manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[key {doctools language}]
+[manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[key {doctools markup}]
+[manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[key {doctools syntax}]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[key document]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[key documentation]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[key emacs]
+[manpage changelog.man doctools::changelog]
+[manpage cvs.man doctools::cvs]
+[key examples]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[key faq]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[key formatter]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[key {formatting engine}]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[key HTML]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key index]
+[manpage docidx_intro.man docidx_intro]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[manpage docidx.man doctools::idx]
+[key {index formatter}]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[key {keyword index}]
+[manpage docidx_intro.man docidx_intro]
+[manpage docidx.man doctools::idx]
+[key keywords]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[key latex]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[key log]
+[manpage cvs.man doctools::cvs]
+[key manpage]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key markup]
+[manpage docidx_intro.man docidx_intro]
+[manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[manpage doctoc_intro.man doctoc_intro]
+[manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage doctools_intro.man doctools_intro]
+[manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key nroff]
+[manpage doctools.man doctools]
+[manpage docidx.man doctools::idx]
+[manpage doctoc.man doctools::toc]
+[manpage apps/dtplite.man dtplite]
+[manpage mpexpand.man mpexpand]
+[key plugin]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[key {semantic markup}]
+[manpage docidx_intro.man docidx_intro]
+[manpage docidx_lang_cmdref.man docidx_lang_cmdref]
+[manpage docidx_lang_faq.man docidx_lang_faq]
+[manpage docidx_lang_intro.man docidx_lang_intro]
+[manpage docidx_lang_syntax.man docidx_lang_syntax]
+[manpage docidx_plugin_apiref.man docidx_plugin_apiref]
+[manpage doctoc_intro.man doctoc_intro]
+[manpage doctoc_lang_cmdref.man doctoc_lang_cmdref]
+[manpage doctoc_lang_faq.man doctoc_lang_faq]
+[manpage doctoc_lang_intro.man doctoc_lang_intro]
+[manpage doctoc_lang_syntax.man doctoc_lang_syntax]
+[manpage doctoc_plugin_apiref.man doctoc_plugin_apiref]
+[manpage doctools_intro.man doctools_intro]
+[manpage doctools_lang_cmdref.man doctools_lang_cmdref]
+[manpage doctools_lang_faq.man doctools_lang_faq]
+[manpage doctools_lang_intro.man doctools_lang_intro]
+[manpage doctools_lang_syntax.man doctools_lang_syntax]
+[manpage doctools_plugin_apiref.man doctools_plugin_apiref]
+[index_end]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/html-compact/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/html-compact/1_nokeys
new file mode 100644
index 0000000..084c61f
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/html-compact/1_nokeys
@@ -0,0 +1,20 @@
+<html>
+<head>
+<title>KWIC -- INDEX</title>
+<style></style>
+</head>
+
+<body>
+<div class="doctools">
+<div class="idx-header">
+<h1 class="idx-title">KWIC -- INDEX</h1>
+<!-- Customization Point: header -->
+<hr class="idx-navsep">
+</div>
+<div class="idx-footer">
+<hr class="idx-navsep">
+<!-- Customization Point: footer -->
+</div>
+</div>
+</body>
+</html>
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/html-compact/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/html-compact/2_justkeys
new file mode 100644
index 0000000..ea92f51
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/html-compact/2_justkeys
@@ -0,0 +1,245 @@
+<html>
+<head>
+<title>Keyword Index</title>
+<style></style>
+</head>
+
+<body>
+<div class="doctools">
+<div class="idx-header">
+<h1 class="idx-title">Keyword Index</h1>
+<!-- Customization Point: header -->
+<hr class="idx-navsep">
+<!-- - Navigation Bar ------------------------------------------- -->
+<div class="idx-kwnav">
+<a href="#KEYWORDS-C">C</a> &#183;
+<a href="#KEYWORDS-D">D</a> &#183;
+<a href="#KEYWORDS-E">E</a> &#183;
+<a href="#KEYWORDS-F">F</a> &#183;
+<a href="#KEYWORDS-H">H</a> &#183;
+<a href="#KEYWORDS-I">I</a> &#183;
+<a href="#KEYWORDS-K">K</a> &#183;
+<a href="#KEYWORDS-L">L</a> &#183;
+<a href="#KEYWORDS-M">M</a> &#183;
+<a href="#KEYWORDS-N">N</a> &#183;
+<a href="#KEYWORDS-P">P</a> &#183;
+<a href="#KEYWORDS-S">S</a> &#183;
+<a href="#KEYWORDS-T">T</a> &#183;
+<a href="#KEYWORDS-W">W</a>
+</div>
+</div>
+<!-- - Contents ------------------------------------------------- -->
+<table class="idx-contents" width="100%">
+<!-- - (C) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-C">Keywords: C</a></th></tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-changelog">changelog</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-conversion">conversion</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-cvs">cvs</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-cvs log">cvs log</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<!-- - (D) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-D">Keywords: D</a></th></tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-docidx">docidx</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-docidx commands">docidx commands</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-docidx language">docidx language</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-docidx markup">docidx markup</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-docidx syntax">docidx syntax</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-doctoc">doctoc</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-doctoc commands">doctoc commands</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-doctoc language">doctoc language</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-doctoc markup">doctoc markup</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-doctoc syntax">doctoc syntax</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-doctools">doctools</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-doctools commands">doctools commands</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-doctools language">doctools language</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-doctools markup">doctools markup</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-doctools syntax">doctools syntax</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-document">document</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-documentation">documentation</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<!-- - (E) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-E">Keywords: E</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-emacs">emacs</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-examples">examples</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<!-- - (F) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-F">Keywords: F</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-faq">faq</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-formatter">formatter</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-formatting engine">formatting engine</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<!-- - (H) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-H">Keywords: H</a></th></tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-HTML">HTML</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<!-- - (I) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-I">Keywords: I</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-index">index</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-index formatter">index formatter</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<!-- - (K) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-K">Keywords: K</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-keyword index">keyword index</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-keywords">keywords</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<!-- - (L) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-L">Keywords: L</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-latex">latex</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-log">log</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<!-- - (M) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-M">Keywords: M</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-manpage">manpage</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-markup">markup</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<!-- - (N) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-N">Keywords: N</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-nroff">nroff</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<!-- - (P) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-P">Keywords: P</a></th></tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-plugin">plugin</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<!-- - (S) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-S">Keywords: S</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-semantic markup">semantic markup</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<!-- - (T) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-T">Keywords: T</a></th></tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-table of contents">table of contents</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-TMML">TMML</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-toc">toc</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-toc formatter">toc formatter</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<!-- - (W) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-W">Keywords: W</a></th></tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-web">web</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-wiki">wiki</a></td>
+<td width="65%" class="idx-refs"></td>
+</tr>
+<!-- ------------------------------------------------------------ -->
+</table>
+<div class="idx-footer">
+<hr class="idx-navsep">
+<!-- Customization Point: footer -->
+</div>
+</div>
+</body>
+</html>
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/html-compact/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/html-compact/3_kwic
new file mode 100644
index 0000000..f85bb90
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/html-compact/3_kwic
@@ -0,0 +1,449 @@
+<html>
+<head>
+<title>Keyword Index</title>
+<style></style>
+</head>
+
+<body>
+<div class="doctools">
+<div class="idx-header">
+<h1 class="idx-title">Keyword Index</h1>
+<!-- Customization Point: header -->
+<hr class="idx-navsep">
+<!-- - Navigation Bar ------------------------------------------- -->
+<div class="idx-kwnav">
+<a href="#KEYWORDS-C">C</a> &#183;
+<a href="#KEYWORDS-D">D</a> &#183;
+<a href="#KEYWORDS-E">E</a> &#183;
+<a href="#KEYWORDS-F">F</a> &#183;
+<a href="#KEYWORDS-H">H</a> &#183;
+<a href="#KEYWORDS-I">I</a> &#183;
+<a href="#KEYWORDS-K">K</a> &#183;
+<a href="#KEYWORDS-L">L</a> &#183;
+<a href="#KEYWORDS-M">M</a> &#183;
+<a href="#KEYWORDS-N">N</a> &#183;
+<a href="#KEYWORDS-P">P</a> &#183;
+<a href="#KEYWORDS-S">S</a> &#183;
+<a href="#KEYWORDS-T">T</a> &#183;
+<a href="#KEYWORDS-W">W</a>
+</div>
+</div>
+<!-- - Contents ------------------------------------------------- -->
+<table class="idx-contents" width="100%">
+<!-- - (C) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-C">Keywords: C</a></th></tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-changelog">changelog</a></td>
+<td width="65%" class="idx-refs">
+<a href="changelog.man">doctools::changelog</a> &#183;
+<a href="cvs.man">doctools::cvs</a>
+</td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-conversion">conversion</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctools.man">doctools</a> &#183;
+<a href="docidx.man">doctools::idx</a> &#183;
+<a href="doctoc.man">doctools::toc</a> &#183;
+<a href="apps/dtplite.man">dtplite</a> &#183;
+<a href="mpexpand.man">mpexpand</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-cvs">cvs</a></td>
+<td width="65%" class="idx-refs">
+<a href="cvs.man">doctools::cvs</a>
+</td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-cvs log">cvs log</a></td>
+<td width="65%" class="idx-refs">
+<a href="cvs.man">doctools::cvs</a>
+</td>
+</tr>
+<!-- - (D) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-D">Keywords: D</a></th></tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-docidx">docidx</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx.man">doctools::idx</a> &#183;
+<a href="apps/dtplite.man">dtplite</a>
+</td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-docidx commands">docidx commands</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx_lang_cmdref.man">docidx_lang_cmdref</a> &#183;
+<a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+<a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183;
+<a href="docidx_lang_syntax.man">docidx_lang_syntax</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-docidx language">docidx language</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx_lang_cmdref.man">docidx_lang_cmdref</a> &#183;
+<a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+<a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183;
+<a href="docidx_lang_syntax.man">docidx_lang_syntax</a>
+</td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-docidx markup">docidx markup</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx_lang_cmdref.man">docidx_lang_cmdref</a> &#183;
+<a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+<a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183;
+<a href="docidx_lang_syntax.man">docidx_lang_syntax</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-docidx syntax">docidx syntax</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+<a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183;
+<a href="docidx_lang_syntax.man">docidx_lang_syntax</a>
+</td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-doctoc">doctoc</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctoc.man">doctools::toc</a> &#183;
+<a href="apps/dtplite.man">dtplite</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-doctoc commands">doctoc commands</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctoc_lang_cmdref.man">doctoc_lang_cmdref</a> &#183;
+<a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+<a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183;
+<a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a>
+</td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-doctoc language">doctoc language</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctoc_lang_cmdref.man">doctoc_lang_cmdref</a> &#183;
+<a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+<a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183;
+<a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-doctoc markup">doctoc markup</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctoc_lang_cmdref.man">doctoc_lang_cmdref</a> &#183;
+<a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+<a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183;
+<a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a>
+</td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-doctoc syntax">doctoc syntax</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+<a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183;
+<a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-doctools">doctools</a></td>
+<td width="65%" class="idx-refs">
+<a href="changelog.man">doctools::changelog</a> &#183;
+<a href="apps/dtplite.man">dtplite</a>
+</td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-doctools commands">doctools commands</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctools_lang_cmdref.man">doctools_lang_cmdref</a> &#183;
+<a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183;
+<a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183;
+<a href="doctools_lang_syntax.man">doctools_lang_syntax</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-doctools language">doctools language</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctools_lang_cmdref.man">doctools_lang_cmdref</a> &#183;
+<a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183;
+<a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183;
+<a href="doctools_lang_syntax.man">doctools_lang_syntax</a>
+</td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-doctools markup">doctools markup</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctools_lang_cmdref.man">doctools_lang_cmdref</a> &#183;
+<a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183;
+<a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183;
+<a href="doctools_lang_syntax.man">doctools_lang_syntax</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-doctools syntax">doctools syntax</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183;
+<a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183;
+<a href="doctools_lang_syntax.man">doctools_lang_syntax</a>
+</td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-document">document</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-documentation">documentation</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctools.man">doctools</a> &#183;
+<a href="docidx.man">doctools::idx</a> &#183;
+<a href="doctoc.man">doctools::toc</a>
+</td>
+</tr>
+<!-- - (E) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-E">Keywords: E</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-emacs">emacs</a></td>
+<td width="65%" class="idx-refs">
+<a href="changelog.man">doctools::changelog</a> &#183;
+<a href="cvs.man">doctools::cvs</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-examples">examples</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+<a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+<a href="doctools_lang_faq.man">doctools_lang_faq</a>
+</td>
+</tr>
+<!-- - (F) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-F">Keywords: F</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-faq">faq</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+<a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+<a href="doctools_lang_faq.man">doctools_lang_faq</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-formatter">formatter</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a>
+</td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-formatting engine">formatting engine</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a> &#183;
+<a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a> &#183;
+<a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a>
+</td>
+</tr>
+<!-- - (H) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-H">Keywords: H</a></th></tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-HTML">HTML</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctools.man">doctools</a> &#183;
+<a href="docidx.man">doctools::idx</a> &#183;
+<a href="doctoc.man">doctools::toc</a> &#183;
+<a href="apps/dtplite.man">dtplite</a> &#183;
+<a href="mpexpand.man">mpexpand</a>
+</td>
+</tr>
+<!-- - (I) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-I">Keywords: I</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-index">index</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx_intro.man">docidx_intro</a> &#183;
+<a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a> &#183;
+<a href="docidx.man">doctools::idx</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-index formatter">index formatter</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a>
+</td>
+</tr>
+<!-- - (K) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-K">Keywords: K</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-keyword index">keyword index</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx_intro.man">docidx_intro</a> &#183;
+<a href="docidx.man">doctools::idx</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-keywords">keywords</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a>
+</td>
+</tr>
+<!-- - (L) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-L">Keywords: L</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-latex">latex</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx.man">doctools::idx</a> &#183;
+<a href="doctoc.man">doctools::toc</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-log">log</a></td>
+<td width="65%" class="idx-refs">
+<a href="cvs.man">doctools::cvs</a>
+</td>
+</tr>
+<!-- - (M) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-M">Keywords: M</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-manpage">manpage</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctools.man">doctools</a> &#183;
+<a href="docidx.man">doctools::idx</a> &#183;
+<a href="doctoc.man">doctools::toc</a> &#183;
+<a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a> &#183;
+<a href="apps/dtplite.man">dtplite</a> &#183;
+<a href="mpexpand.man">mpexpand</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-markup">markup</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx_intro.man">docidx_intro</a> &#183;
+<a href="docidx_lang_cmdref.man">docidx_lang_cmdref</a> &#183;
+<a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+<a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183;
+<a href="docidx_lang_syntax.man">docidx_lang_syntax</a> &#183;
+<a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a> &#183;
+<a href="doctoc_intro.man">doctoc_intro</a> &#183;
+<a href="doctoc_lang_cmdref.man">doctoc_lang_cmdref</a> &#183;
+<a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+<a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183;
+<a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a> &#183;
+<a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a> &#183;
+<a href="doctools.man">doctools</a> &#183;
+<a href="docidx.man">doctools::idx</a> &#183;
+<a href="doctoc.man">doctools::toc</a> &#183;
+<a href="doctools_intro.man">doctools_intro</a> &#183;
+<a href="doctools_lang_cmdref.man">doctools_lang_cmdref</a> &#183;
+<a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183;
+<a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183;
+<a href="doctools_lang_syntax.man">doctools_lang_syntax</a> &#183;
+<a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a> &#183;
+<a href="apps/dtplite.man">dtplite</a> &#183;
+<a href="mpexpand.man">mpexpand</a>
+</td>
+</tr>
+<!-- - (N) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-N">Keywords: N</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-nroff">nroff</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctools.man">doctools</a> &#183;
+<a href="docidx.man">doctools::idx</a> &#183;
+<a href="doctoc.man">doctools::toc</a> &#183;
+<a href="apps/dtplite.man">dtplite</a> &#183;
+<a href="mpexpand.man">mpexpand</a>
+</td>
+</tr>
+<!-- - (P) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-P">Keywords: P</a></th></tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-plugin">plugin</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a> &#183;
+<a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a>
+</td>
+</tr>
+<!-- - (S) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-S">Keywords: S</a></th></tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-semantic markup">semantic markup</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx_intro.man">docidx_intro</a> &#183;
+<a href="docidx_lang_cmdref.man">docidx_lang_cmdref</a> &#183;
+<a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+<a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183;
+<a href="docidx_lang_syntax.man">docidx_lang_syntax</a> &#183;
+<a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a> &#183;
+<a href="doctoc_intro.man">doctoc_intro</a> &#183;
+<a href="doctoc_lang_cmdref.man">doctoc_lang_cmdref</a> &#183;
+<a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+<a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183;
+<a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a> &#183;
+<a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a> &#183;
+<a href="doctools_intro.man">doctools_intro</a> &#183;
+<a href="doctools_lang_cmdref.man">doctools_lang_cmdref</a> &#183;
+<a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183;
+<a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183;
+<a href="doctools_lang_syntax.man">doctools_lang_syntax</a> &#183;
+<a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a>
+</td>
+</tr>
+<!-- - (T) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-T">Keywords: T</a></th></tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-table of contents">table of contents</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctoc_intro.man">doctoc_intro</a> &#183;
+<a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a> &#183;
+<a href="doctoc.man">doctools::toc</a>
+</td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-TMML">TMML</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctools.man">doctools</a> &#183;
+<a href="docidx.man">doctools::idx</a> &#183;
+<a href="doctoc.man">doctools::toc</a> &#183;
+<a href="apps/dtplite.man">dtplite</a> &#183;
+<a href="mpexpand.man">mpexpand</a>
+</td>
+</tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-toc">toc</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctoc_intro.man">doctoc_intro</a> &#183;
+<a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a> &#183;
+<a href="doctoc.man">doctools::toc</a>
+</td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-toc formatter">toc formatter</a></td>
+<td width="65%" class="idx-refs">
+<a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a>
+</td>
+</tr>
+<!-- - (W) ------------------------------------------------------ -->
+<tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-W">Keywords: W</a></th></tr>
+<tr class="idx-even">
+<td width="35%" class="idx-keyword"><a name="KW-web">web</a></td>
+<td width="65%" class="idx-refs">
+<a href="http://tcllib.sourceforge.net/doc/docidx_lang_intro.html">docidx language introduction</a>
+</td>
+</tr>
+<tr class="idx-odd">
+<td width="35%" class="idx-keyword"><a name="KW-wiki">wiki</a></td>
+<td width="65%" class="idx-refs">
+<a href="docidx.man">doctools::idx</a> &#183;
+<a href="doctoc.man">doctools::toc</a>
+</td>
+</tr>
+<!-- ------------------------------------------------------------ -->
+</table>
+<div class="idx-footer">
+<hr class="idx-navsep">
+<!-- Customization Point: footer -->
+</div>
+</div>
+</body>
+</html>
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/html-indented/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/html-indented/1_nokeys
new file mode 100644
index 0000000..9c5e23a
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/html-indented/1_nokeys
@@ -0,0 +1,20 @@
+<html>
+ <head>
+ <title>KWIC -- INDEX</title>
+ <style></style>
+ </head>
+
+ <body>
+ <div class="doctools">
+ <div class="idx-header">
+ <h1 class="idx-title">KWIC -- INDEX</h1>
+ <!-- Customization Point: header -->
+ <hr class="idx-navsep">
+ </div>
+ <div class="idx-footer">
+ <hr class="idx-navsep">
+ <!-- Customization Point: footer -->
+ </div>
+ </div>
+ </body>
+</html>
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/html-indented/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/html-indented/2_justkeys
new file mode 100644
index 0000000..a5de5c8
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/html-indented/2_justkeys
@@ -0,0 +1,245 @@
+<html>
+ <head>
+ <title>Keyword Index</title>
+ <style></style>
+ </head>
+
+ <body>
+ <div class="doctools">
+ <div class="idx-header">
+ <h1 class="idx-title">Keyword Index</h1>
+ <!-- Customization Point: header -->
+ <hr class="idx-navsep">
+ <!-- - Navigation Bar ------------------------------------------- -->
+ <div class="idx-kwnav">
+ <a href="#KEYWORDS-C">C</a> &#183;
+ <a href="#KEYWORDS-D">D</a> &#183;
+ <a href="#KEYWORDS-E">E</a> &#183;
+ <a href="#KEYWORDS-F">F</a> &#183;
+ <a href="#KEYWORDS-H">H</a> &#183;
+ <a href="#KEYWORDS-I">I</a> &#183;
+ <a href="#KEYWORDS-K">K</a> &#183;
+ <a href="#KEYWORDS-L">L</a> &#183;
+ <a href="#KEYWORDS-M">M</a> &#183;
+ <a href="#KEYWORDS-N">N</a> &#183;
+ <a href="#KEYWORDS-P">P</a> &#183;
+ <a href="#KEYWORDS-S">S</a> &#183;
+ <a href="#KEYWORDS-T">T</a> &#183;
+ <a href="#KEYWORDS-W">W</a>
+ </div>
+ </div>
+ <!-- - Contents ------------------------------------------------- -->
+ <table class="idx-contents" width="100%">
+ <!-- - (C) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-C">Keywords: C</a></th></tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-changelog">changelog</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-conversion">conversion</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-cvs">cvs</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-cvs log">cvs log</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <!-- - (D) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-D">Keywords: D</a></th></tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-docidx">docidx</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-docidx commands">docidx commands</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-docidx language">docidx language</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-docidx markup">docidx markup</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-docidx syntax">docidx syntax</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-doctoc">doctoc</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-doctoc commands">doctoc commands</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-doctoc language">doctoc language</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-doctoc markup">doctoc markup</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-doctoc syntax">doctoc syntax</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-doctools">doctools</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-doctools commands">doctools commands</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-doctools language">doctools language</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-doctools markup">doctools markup</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-doctools syntax">doctools syntax</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-document">document</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-documentation">documentation</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <!-- - (E) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-E">Keywords: E</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-emacs">emacs</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-examples">examples</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <!-- - (F) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-F">Keywords: F</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-faq">faq</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-formatter">formatter</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-formatting engine">formatting engine</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <!-- - (H) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-H">Keywords: H</a></th></tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-HTML">HTML</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <!-- - (I) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-I">Keywords: I</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-index">index</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-index formatter">index formatter</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <!-- - (K) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-K">Keywords: K</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-keyword index">keyword index</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-keywords">keywords</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <!-- - (L) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-L">Keywords: L</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-latex">latex</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-log">log</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <!-- - (M) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-M">Keywords: M</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-manpage">manpage</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-markup">markup</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <!-- - (N) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-N">Keywords: N</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-nroff">nroff</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <!-- - (P) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-P">Keywords: P</a></th></tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-plugin">plugin</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <!-- - (S) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-S">Keywords: S</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-semantic markup">semantic markup</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <!-- - (T) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-T">Keywords: T</a></th></tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-table of contents">table of contents</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-TMML">TMML</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-toc">toc</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-toc formatter">toc formatter</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <!-- - (W) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-W">Keywords: W</a></th></tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-web">web</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-wiki">wiki</a></td>
+ <td width="65%" class="idx-refs"></td>
+ </tr>
+ <!-- ------------------------------------------------------------ -->
+ </table>
+ <div class="idx-footer">
+ <hr class="idx-navsep">
+ <!-- Customization Point: footer -->
+ </div>
+ </div>
+ </body>
+</html>
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/html-indented/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/html-indented/3_kwic
new file mode 100644
index 0000000..4cb9b03
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/html-indented/3_kwic
@@ -0,0 +1,449 @@
+<html>
+ <head>
+ <title>Keyword Index</title>
+ <style></style>
+ </head>
+
+ <body>
+ <div class="doctools">
+ <div class="idx-header">
+ <h1 class="idx-title">Keyword Index</h1>
+ <!-- Customization Point: header -->
+ <hr class="idx-navsep">
+ <!-- - Navigation Bar ------------------------------------------- -->
+ <div class="idx-kwnav">
+ <a href="#KEYWORDS-C">C</a> &#183;
+ <a href="#KEYWORDS-D">D</a> &#183;
+ <a href="#KEYWORDS-E">E</a> &#183;
+ <a href="#KEYWORDS-F">F</a> &#183;
+ <a href="#KEYWORDS-H">H</a> &#183;
+ <a href="#KEYWORDS-I">I</a> &#183;
+ <a href="#KEYWORDS-K">K</a> &#183;
+ <a href="#KEYWORDS-L">L</a> &#183;
+ <a href="#KEYWORDS-M">M</a> &#183;
+ <a href="#KEYWORDS-N">N</a> &#183;
+ <a href="#KEYWORDS-P">P</a> &#183;
+ <a href="#KEYWORDS-S">S</a> &#183;
+ <a href="#KEYWORDS-T">T</a> &#183;
+ <a href="#KEYWORDS-W">W</a>
+ </div>
+ </div>
+ <!-- - Contents ------------------------------------------------- -->
+ <table class="idx-contents" width="100%">
+ <!-- - (C) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-C">Keywords: C</a></th></tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-changelog">changelog</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="changelog.man">doctools::changelog</a> &#183;
+ <a href="cvs.man">doctools::cvs</a>
+ </td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-conversion">conversion</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctools.man">doctools</a> &#183;
+ <a href="docidx.man">doctools::idx</a> &#183;
+ <a href="doctoc.man">doctools::toc</a> &#183;
+ <a href="apps/dtplite.man">dtplite</a> &#183;
+ <a href="mpexpand.man">mpexpand</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-cvs">cvs</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="cvs.man">doctools::cvs</a>
+ </td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-cvs log">cvs log</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="cvs.man">doctools::cvs</a>
+ </td>
+ </tr>
+ <!-- - (D) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-D">Keywords: D</a></th></tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-docidx">docidx</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx.man">doctools::idx</a> &#183;
+ <a href="apps/dtplite.man">dtplite</a>
+ </td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-docidx commands">docidx commands</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx_lang_cmdref.man">docidx_lang_cmdref</a> &#183;
+ <a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+ <a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183;
+ <a href="docidx_lang_syntax.man">docidx_lang_syntax</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-docidx language">docidx language</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx_lang_cmdref.man">docidx_lang_cmdref</a> &#183;
+ <a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+ <a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183;
+ <a href="docidx_lang_syntax.man">docidx_lang_syntax</a>
+ </td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-docidx markup">docidx markup</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx_lang_cmdref.man">docidx_lang_cmdref</a> &#183;
+ <a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+ <a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183;
+ <a href="docidx_lang_syntax.man">docidx_lang_syntax</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-docidx syntax">docidx syntax</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+ <a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183;
+ <a href="docidx_lang_syntax.man">docidx_lang_syntax</a>
+ </td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-doctoc">doctoc</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctoc.man">doctools::toc</a> &#183;
+ <a href="apps/dtplite.man">dtplite</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-doctoc commands">doctoc commands</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctoc_lang_cmdref.man">doctoc_lang_cmdref</a> &#183;
+ <a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+ <a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183;
+ <a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a>
+ </td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-doctoc language">doctoc language</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctoc_lang_cmdref.man">doctoc_lang_cmdref</a> &#183;
+ <a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+ <a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183;
+ <a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-doctoc markup">doctoc markup</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctoc_lang_cmdref.man">doctoc_lang_cmdref</a> &#183;
+ <a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+ <a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183;
+ <a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a>
+ </td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-doctoc syntax">doctoc syntax</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+ <a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183;
+ <a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-doctools">doctools</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="changelog.man">doctools::changelog</a> &#183;
+ <a href="apps/dtplite.man">dtplite</a>
+ </td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-doctools commands">doctools commands</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctools_lang_cmdref.man">doctools_lang_cmdref</a> &#183;
+ <a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183;
+ <a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183;
+ <a href="doctools_lang_syntax.man">doctools_lang_syntax</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-doctools language">doctools language</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctools_lang_cmdref.man">doctools_lang_cmdref</a> &#183;
+ <a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183;
+ <a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183;
+ <a href="doctools_lang_syntax.man">doctools_lang_syntax</a>
+ </td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-doctools markup">doctools markup</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctools_lang_cmdref.man">doctools_lang_cmdref</a> &#183;
+ <a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183;
+ <a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183;
+ <a href="doctools_lang_syntax.man">doctools_lang_syntax</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-doctools syntax">doctools syntax</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183;
+ <a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183;
+ <a href="doctools_lang_syntax.man">doctools_lang_syntax</a>
+ </td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-document">document</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-documentation">documentation</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctools.man">doctools</a> &#183;
+ <a href="docidx.man">doctools::idx</a> &#183;
+ <a href="doctoc.man">doctools::toc</a>
+ </td>
+ </tr>
+ <!-- - (E) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-E">Keywords: E</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-emacs">emacs</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="changelog.man">doctools::changelog</a> &#183;
+ <a href="cvs.man">doctools::cvs</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-examples">examples</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+ <a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+ <a href="doctools_lang_faq.man">doctools_lang_faq</a>
+ </td>
+ </tr>
+ <!-- - (F) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-F">Keywords: F</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-faq">faq</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+ <a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+ <a href="doctools_lang_faq.man">doctools_lang_faq</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-formatter">formatter</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a>
+ </td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-formatting engine">formatting engine</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a> &#183;
+ <a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a> &#183;
+ <a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a>
+ </td>
+ </tr>
+ <!-- - (H) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-H">Keywords: H</a></th></tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-HTML">HTML</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctools.man">doctools</a> &#183;
+ <a href="docidx.man">doctools::idx</a> &#183;
+ <a href="doctoc.man">doctools::toc</a> &#183;
+ <a href="apps/dtplite.man">dtplite</a> &#183;
+ <a href="mpexpand.man">mpexpand</a>
+ </td>
+ </tr>
+ <!-- - (I) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-I">Keywords: I</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-index">index</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx_intro.man">docidx_intro</a> &#183;
+ <a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a> &#183;
+ <a href="docidx.man">doctools::idx</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-index formatter">index formatter</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a>
+ </td>
+ </tr>
+ <!-- - (K) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-K">Keywords: K</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-keyword index">keyword index</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx_intro.man">docidx_intro</a> &#183;
+ <a href="docidx.man">doctools::idx</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-keywords">keywords</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a>
+ </td>
+ </tr>
+ <!-- - (L) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-L">Keywords: L</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-latex">latex</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx.man">doctools::idx</a> &#183;
+ <a href="doctoc.man">doctools::toc</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-log">log</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="cvs.man">doctools::cvs</a>
+ </td>
+ </tr>
+ <!-- - (M) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-M">Keywords: M</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-manpage">manpage</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctools.man">doctools</a> &#183;
+ <a href="docidx.man">doctools::idx</a> &#183;
+ <a href="doctoc.man">doctools::toc</a> &#183;
+ <a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a> &#183;
+ <a href="apps/dtplite.man">dtplite</a> &#183;
+ <a href="mpexpand.man">mpexpand</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-markup">markup</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx_intro.man">docidx_intro</a> &#183;
+ <a href="docidx_lang_cmdref.man">docidx_lang_cmdref</a> &#183;
+ <a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+ <a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183;
+ <a href="docidx_lang_syntax.man">docidx_lang_syntax</a> &#183;
+ <a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a> &#183;
+ <a href="doctoc_intro.man">doctoc_intro</a> &#183;
+ <a href="doctoc_lang_cmdref.man">doctoc_lang_cmdref</a> &#183;
+ <a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+ <a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183;
+ <a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a> &#183;
+ <a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a> &#183;
+ <a href="doctools.man">doctools</a> &#183;
+ <a href="docidx.man">doctools::idx</a> &#183;
+ <a href="doctoc.man">doctools::toc</a> &#183;
+ <a href="doctools_intro.man">doctools_intro</a> &#183;
+ <a href="doctools_lang_cmdref.man">doctools_lang_cmdref</a> &#183;
+ <a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183;
+ <a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183;
+ <a href="doctools_lang_syntax.man">doctools_lang_syntax</a> &#183;
+ <a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a> &#183;
+ <a href="apps/dtplite.man">dtplite</a> &#183;
+ <a href="mpexpand.man">mpexpand</a>
+ </td>
+ </tr>
+ <!-- - (N) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-N">Keywords: N</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-nroff">nroff</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctools.man">doctools</a> &#183;
+ <a href="docidx.man">doctools::idx</a> &#183;
+ <a href="doctoc.man">doctools::toc</a> &#183;
+ <a href="apps/dtplite.man">dtplite</a> &#183;
+ <a href="mpexpand.man">mpexpand</a>
+ </td>
+ </tr>
+ <!-- - (P) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-P">Keywords: P</a></th></tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-plugin">plugin</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a> &#183;
+ <a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a>
+ </td>
+ </tr>
+ <!-- - (S) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-S">Keywords: S</a></th></tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-semantic markup">semantic markup</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx_intro.man">docidx_intro</a> &#183;
+ <a href="docidx_lang_cmdref.man">docidx_lang_cmdref</a> &#183;
+ <a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183;
+ <a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183;
+ <a href="docidx_lang_syntax.man">docidx_lang_syntax</a> &#183;
+ <a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a> &#183;
+ <a href="doctoc_intro.man">doctoc_intro</a> &#183;
+ <a href="doctoc_lang_cmdref.man">doctoc_lang_cmdref</a> &#183;
+ <a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183;
+ <a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183;
+ <a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a> &#183;
+ <a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a> &#183;
+ <a href="doctools_intro.man">doctools_intro</a> &#183;
+ <a href="doctools_lang_cmdref.man">doctools_lang_cmdref</a> &#183;
+ <a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183;
+ <a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183;
+ <a href="doctools_lang_syntax.man">doctools_lang_syntax</a> &#183;
+ <a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a>
+ </td>
+ </tr>
+ <!-- - (T) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-T">Keywords: T</a></th></tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-table of contents">table of contents</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctoc_intro.man">doctoc_intro</a> &#183;
+ <a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a> &#183;
+ <a href="doctoc.man">doctools::toc</a>
+ </td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-TMML">TMML</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctools.man">doctools</a> &#183;
+ <a href="docidx.man">doctools::idx</a> &#183;
+ <a href="doctoc.man">doctools::toc</a> &#183;
+ <a href="apps/dtplite.man">dtplite</a> &#183;
+ <a href="mpexpand.man">mpexpand</a>
+ </td>
+ </tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-toc">toc</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctoc_intro.man">doctoc_intro</a> &#183;
+ <a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a> &#183;
+ <a href="doctoc.man">doctools::toc</a>
+ </td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-toc formatter">toc formatter</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a>
+ </td>
+ </tr>
+ <!-- - (W) ------------------------------------------------------ -->
+ <tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-W">Keywords: W</a></th></tr>
+ <tr class="idx-even">
+ <td width="35%" class="idx-keyword"><a name="KW-web">web</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="http://tcllib.sourceforge.net/doc/docidx_lang_intro.html">docidx language introduction</a>
+ </td>
+ </tr>
+ <tr class="idx-odd">
+ <td width="35%" class="idx-keyword"><a name="KW-wiki">wiki</a></td>
+ <td width="65%" class="idx-refs">
+ <a href="docidx.man">doctools::idx</a> &#183;
+ <a href="doctoc.man">doctools::toc</a>
+ </td>
+ </tr>
+ <!-- ------------------------------------------------------------ -->
+ </table>
+ <div class="idx-footer">
+ <hr class="idx-navsep">
+ <!-- Customization Point: footer -->
+ </div>
+ </div>
+ </body>
+</html>
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/html-ultracompact/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/html-ultracompact/1_nokeys
new file mode 100644
index 0000000..5539a6c
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/html-ultracompact/1_nokeys
@@ -0,0 +1 @@
+<html><head><title>KWIC -- INDEX</title><style></style></head><body><div class="doctools"><div class="idx-header"><h1 class="idx-title">KWIC -- INDEX</h1><hr class="idx-navsep"></div><div class="idx-footer"><hr class="idx-navsep"></div></div></body></html>
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/html-ultracompact/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/html-ultracompact/2_justkeys
new file mode 100644
index 0000000..c2dfa8c
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/html-ultracompact/2_justkeys
@@ -0,0 +1 @@
+<html><head><title>Keyword Index</title><style></style></head><body><div class="doctools"><div class="idx-header"><h1 class="idx-title">Keyword Index</h1><hr class="idx-navsep"><div class="idx-kwnav"><a href="#KEYWORDS-C">C</a> &#183; <a href="#KEYWORDS-D">D</a> &#183; <a href="#KEYWORDS-E">E</a> &#183; <a href="#KEYWORDS-F">F</a> &#183; <a href="#KEYWORDS-H">H</a> &#183; <a href="#KEYWORDS-I">I</a> &#183; <a href="#KEYWORDS-K">K</a> &#183; <a href="#KEYWORDS-L">L</a> &#183; <a href="#KEYWORDS-M">M</a> &#183; <a href="#KEYWORDS-N">N</a> &#183; <a href="#KEYWORDS-P">P</a> &#183; <a href="#KEYWORDS-S">S</a> &#183; <a href="#KEYWORDS-T">T</a> &#183; <a href="#KEYWORDS-W">W</a></div></div><table class="idx-contents" width="100%"><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-C">Keywords: C</a></th></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-changelog">changelog</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-conversion">conversion</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-cvs">cvs</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-cvs log">cvs log</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-D">Keywords: D</a></th></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-docidx">docidx</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-docidx commands">docidx commands</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-docidx language">docidx language</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-docidx markup">docidx markup</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-docidx syntax">docidx syntax</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-doctoc">doctoc</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-doctoc commands">doctoc commands</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-doctoc language">doctoc language</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-doctoc markup">doctoc markup</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-doctoc syntax">doctoc syntax</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-doctools">doctools</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-doctools commands">doctools commands</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-doctools language">doctools language</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-doctools markup">doctools markup</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-doctools syntax">doctools syntax</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-document">document</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-documentation">documentation</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-E">Keywords: E</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-emacs">emacs</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-examples">examples</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-F">Keywords: F</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-faq">faq</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-formatter">formatter</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-formatting engine">formatting engine</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-H">Keywords: H</a></th></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-HTML">HTML</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-I">Keywords: I</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-index">index</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-index formatter">index formatter</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-K">Keywords: K</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-keyword index">keyword index</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-keywords">keywords</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-L">Keywords: L</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-latex">latex</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-log">log</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-M">Keywords: M</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-manpage">manpage</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-markup">markup</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-N">Keywords: N</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-nroff">nroff</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-P">Keywords: P</a></th></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-plugin">plugin</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-S">Keywords: S</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-semantic markup">semantic markup</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-T">Keywords: T</a></th></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-table of contents">table of contents</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-TMML">TMML</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-toc">toc</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-toc formatter">toc formatter</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-W">Keywords: W</a></th></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-web">web</a></td><td width="65%" class="idx-refs"></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-wiki">wiki</a></td><td width="65%" class="idx-refs"></td></tr></table><div class="idx-footer"><hr class="idx-navsep"></div></div></body></html>
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/html-ultracompact/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/html-ultracompact/3_kwic
new file mode 100644
index 0000000..df53309
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/html-ultracompact/3_kwic
@@ -0,0 +1 @@
+<html><head><title>Keyword Index</title><style></style></head><body><div class="doctools"><div class="idx-header"><h1 class="idx-title">Keyword Index</h1><hr class="idx-navsep"><div class="idx-kwnav"><a href="#KEYWORDS-C">C</a> &#183; <a href="#KEYWORDS-D">D</a> &#183; <a href="#KEYWORDS-E">E</a> &#183; <a href="#KEYWORDS-F">F</a> &#183; <a href="#KEYWORDS-H">H</a> &#183; <a href="#KEYWORDS-I">I</a> &#183; <a href="#KEYWORDS-K">K</a> &#183; <a href="#KEYWORDS-L">L</a> &#183; <a href="#KEYWORDS-M">M</a> &#183; <a href="#KEYWORDS-N">N</a> &#183; <a href="#KEYWORDS-P">P</a> &#183; <a href="#KEYWORDS-S">S</a> &#183; <a href="#KEYWORDS-T">T</a> &#183; <a href="#KEYWORDS-W">W</a></div></div><table class="idx-contents" width="100%"><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-C">Keywords: C</a></th></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-changelog">changelog</a></td><td width="65%" class="idx-refs"><a href="changelog.man">doctools::changelog</a> &#183; <a href="cvs.man">doctools::cvs</a></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-conversion">conversion</a></td><td width="65%" class="idx-refs"><a href="doctools.man">doctools</a> &#183; <a href="docidx.man">doctools::idx</a> &#183; <a href="doctoc.man">doctools::toc</a> &#183; <a href="apps/dtplite.man">dtplite</a> &#183; <a href="mpexpand.man">mpexpand</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-cvs">cvs</a></td><td width="65%" class="idx-refs"><a href="cvs.man">doctools::cvs</a></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-cvs log">cvs log</a></td><td width="65%" class="idx-refs"><a href="cvs.man">doctools::cvs</a></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-D">Keywords: D</a></th></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-docidx">docidx</a></td><td width="65%" class="idx-refs"><a href="docidx.man">doctools::idx</a> &#183; <a href="apps/dtplite.man">dtplite</a></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-docidx commands">docidx commands</a></td><td width="65%" class="idx-refs"><a href="docidx_lang_cmdref.man">docidx_lang_cmdref</a> &#183; <a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183; <a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183; <a href="docidx_lang_syntax.man">docidx_lang_syntax</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-docidx language">docidx language</a></td><td width="65%" class="idx-refs"><a href="docidx_lang_cmdref.man">docidx_lang_cmdref</a> &#183; <a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183; <a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183; <a href="docidx_lang_syntax.man">docidx_lang_syntax</a></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-docidx markup">docidx markup</a></td><td width="65%" class="idx-refs"><a href="docidx_lang_cmdref.man">docidx_lang_cmdref</a> &#183; <a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183; <a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183; <a href="docidx_lang_syntax.man">docidx_lang_syntax</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-docidx syntax">docidx syntax</a></td><td width="65%" class="idx-refs"><a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183; <a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183; <a href="docidx_lang_syntax.man">docidx_lang_syntax</a></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-doctoc">doctoc</a></td><td width="65%" class="idx-refs"><a href="doctoc.man">doctools::toc</a> &#183; <a href="apps/dtplite.man">dtplite</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-doctoc commands">doctoc commands</a></td><td width="65%" class="idx-refs"><a href="doctoc_lang_cmdref.man">doctoc_lang_cmdref</a> &#183; <a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183; <a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183; <a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-doctoc language">doctoc language</a></td><td width="65%" class="idx-refs"><a href="doctoc_lang_cmdref.man">doctoc_lang_cmdref</a> &#183; <a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183; <a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183; <a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-doctoc markup">doctoc markup</a></td><td width="65%" class="idx-refs"><a href="doctoc_lang_cmdref.man">doctoc_lang_cmdref</a> &#183; <a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183; <a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183; <a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-doctoc syntax">doctoc syntax</a></td><td width="65%" class="idx-refs"><a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183; <a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183; <a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-doctools">doctools</a></td><td width="65%" class="idx-refs"><a href="changelog.man">doctools::changelog</a> &#183; <a href="apps/dtplite.man">dtplite</a></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-doctools commands">doctools commands</a></td><td width="65%" class="idx-refs"><a href="doctools_lang_cmdref.man">doctools_lang_cmdref</a> &#183; <a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183; <a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183; <a href="doctools_lang_syntax.man">doctools_lang_syntax</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-doctools language">doctools language</a></td><td width="65%" class="idx-refs"><a href="doctools_lang_cmdref.man">doctools_lang_cmdref</a> &#183; <a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183; <a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183; <a href="doctools_lang_syntax.man">doctools_lang_syntax</a></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-doctools markup">doctools markup</a></td><td width="65%" class="idx-refs"><a href="doctools_lang_cmdref.man">doctools_lang_cmdref</a> &#183; <a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183; <a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183; <a href="doctools_lang_syntax.man">doctools_lang_syntax</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-doctools syntax">doctools syntax</a></td><td width="65%" class="idx-refs"><a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183; <a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183; <a href="doctools_lang_syntax.man">doctools_lang_syntax</a></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-document">document</a></td><td width="65%" class="idx-refs"><a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-documentation">documentation</a></td><td width="65%" class="idx-refs"><a href="doctools.man">doctools</a> &#183; <a href="docidx.man">doctools::idx</a> &#183; <a href="doctoc.man">doctools::toc</a></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-E">Keywords: E</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-emacs">emacs</a></td><td width="65%" class="idx-refs"><a href="changelog.man">doctools::changelog</a> &#183; <a href="cvs.man">doctools::cvs</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-examples">examples</a></td><td width="65%" class="idx-refs"><a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183; <a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183; <a href="doctools_lang_faq.man">doctools_lang_faq</a></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-F">Keywords: F</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-faq">faq</a></td><td width="65%" class="idx-refs"><a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183; <a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183; <a href="doctools_lang_faq.man">doctools_lang_faq</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-formatter">formatter</a></td><td width="65%" class="idx-refs"><a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-formatting engine">formatting engine</a></td><td width="65%" class="idx-refs"><a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a> &#183; <a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a> &#183; <a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-H">Keywords: H</a></th></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-HTML">HTML</a></td><td width="65%" class="idx-refs"><a href="doctools.man">doctools</a> &#183; <a href="docidx.man">doctools::idx</a> &#183; <a href="doctoc.man">doctools::toc</a> &#183; <a href="apps/dtplite.man">dtplite</a> &#183; <a href="mpexpand.man">mpexpand</a></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-I">Keywords: I</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-index">index</a></td><td width="65%" class="idx-refs"><a href="docidx_intro.man">docidx_intro</a> &#183; <a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a> &#183; <a href="docidx.man">doctools::idx</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-index formatter">index formatter</a></td><td width="65%" class="idx-refs"><a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-K">Keywords: K</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-keyword index">keyword index</a></td><td width="65%" class="idx-refs"><a href="docidx_intro.man">docidx_intro</a> &#183; <a href="docidx.man">doctools::idx</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-keywords">keywords</a></td><td width="65%" class="idx-refs"><a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-L">Keywords: L</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-latex">latex</a></td><td width="65%" class="idx-refs"><a href="docidx.man">doctools::idx</a> &#183; <a href="doctoc.man">doctools::toc</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-log">log</a></td><td width="65%" class="idx-refs"><a href="cvs.man">doctools::cvs</a></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-M">Keywords: M</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-manpage">manpage</a></td><td width="65%" class="idx-refs"><a href="doctools.man">doctools</a> &#183; <a href="docidx.man">doctools::idx</a> &#183; <a href="doctoc.man">doctools::toc</a> &#183; <a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a> &#183; <a href="apps/dtplite.man">dtplite</a> &#183; <a href="mpexpand.man">mpexpand</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-markup">markup</a></td><td width="65%" class="idx-refs"><a href="docidx_intro.man">docidx_intro</a> &#183; <a href="docidx_lang_cmdref.man">docidx_lang_cmdref</a> &#183; <a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183; <a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183; <a href="docidx_lang_syntax.man">docidx_lang_syntax</a> &#183; <a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a> &#183; <a href="doctoc_intro.man">doctoc_intro</a> &#183; <a href="doctoc_lang_cmdref.man">doctoc_lang_cmdref</a> &#183; <a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183; <a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183; <a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a> &#183; <a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a> &#183; <a href="doctools.man">doctools</a> &#183; <a href="docidx.man">doctools::idx</a> &#183; <a href="doctoc.man">doctools::toc</a> &#183; <a href="doctools_intro.man">doctools_intro</a> &#183; <a href="doctools_lang_cmdref.man">doctools_lang_cmdref</a> &#183; <a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183; <a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183; <a href="doctools_lang_syntax.man">doctools_lang_syntax</a> &#183; <a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a> &#183; <a href="apps/dtplite.man">dtplite</a> &#183; <a href="mpexpand.man">mpexpand</a></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-N">Keywords: N</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-nroff">nroff</a></td><td width="65%" class="idx-refs"><a href="doctools.man">doctools</a> &#183; <a href="docidx.man">doctools::idx</a> &#183; <a href="doctoc.man">doctools::toc</a> &#183; <a href="apps/dtplite.man">dtplite</a> &#183; <a href="mpexpand.man">mpexpand</a></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-P">Keywords: P</a></th></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-plugin">plugin</a></td><td width="65%" class="idx-refs"><a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a> &#183; <a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-S">Keywords: S</a></th></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-semantic markup">semantic markup</a></td><td width="65%" class="idx-refs"><a href="docidx_intro.man">docidx_intro</a> &#183; <a href="docidx_lang_cmdref.man">docidx_lang_cmdref</a> &#183; <a href="docidx_lang_faq.man">docidx_lang_faq</a> &#183; <a href="docidx_lang_intro.man">docidx_lang_intro</a> &#183; <a href="docidx_lang_syntax.man">docidx_lang_syntax</a> &#183; <a href="docidx_plugin_apiref.man">docidx_plugin_apiref</a> &#183; <a href="doctoc_intro.man">doctoc_intro</a> &#183; <a href="doctoc_lang_cmdref.man">doctoc_lang_cmdref</a> &#183; <a href="doctoc_lang_faq.man">doctoc_lang_faq</a> &#183; <a href="doctoc_lang_intro.man">doctoc_lang_intro</a> &#183; <a href="doctoc_lang_syntax.man">doctoc_lang_syntax</a> &#183; <a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a> &#183; <a href="doctools_intro.man">doctools_intro</a> &#183; <a href="doctools_lang_cmdref.man">doctools_lang_cmdref</a> &#183; <a href="doctools_lang_faq.man">doctools_lang_faq</a> &#183; <a href="doctools_lang_intro.man">doctools_lang_intro</a> &#183; <a href="doctools_lang_syntax.man">doctools_lang_syntax</a> &#183; <a href="doctools_plugin_apiref.man">doctools_plugin_apiref</a></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-T">Keywords: T</a></th></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-table of contents">table of contents</a></td><td width="65%" class="idx-refs"><a href="doctoc_intro.man">doctoc_intro</a> &#183; <a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a> &#183; <a href="doctoc.man">doctools::toc</a></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-TMML">TMML</a></td><td width="65%" class="idx-refs"><a href="doctools.man">doctools</a> &#183; <a href="docidx.man">doctools::idx</a> &#183; <a href="doctoc.man">doctools::toc</a> &#183; <a href="apps/dtplite.man">dtplite</a> &#183; <a href="mpexpand.man">mpexpand</a></td></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-toc">toc</a></td><td width="65%" class="idx-refs"><a href="doctoc_intro.man">doctoc_intro</a> &#183; <a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a> &#183; <a href="doctoc.man">doctools::toc</a></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-toc formatter">toc formatter</a></td><td width="65%" class="idx-refs"><a href="doctoc_plugin_apiref.man">doctoc_plugin_apiref</a></td></tr><tr class="idx-leader"><th colspan="2"><a name="KEYWORDS-W">Keywords: W</a></th></tr><tr class="idx-even"><td width="35%" class="idx-keyword"><a name="KW-web">web</a></td><td width="65%" class="idx-refs"><a href="http://tcllib.sourceforge.net/doc/docidx_lang_intro.html">docidx language introduction</a></td></tr><tr class="idx-odd"><td width="35%" class="idx-keyword"><a name="KW-wiki">wiki</a></td><td width="65%" class="idx-refs"><a href="docidx.man">doctools::idx</a> &#183; <a href="doctoc.man">doctools::toc</a></td></tr></table><div class="idx-footer"><hr class="idx-navsep"></div></div></body></html>
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/json-indalign/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/json-indalign/1_nokeys
new file mode 100644
index 0000000..1a957dd
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/json-indalign/1_nokeys
@@ -0,0 +1,8 @@
+{
+ "doctools::idx" : {
+ "label" : "KWIC",
+ "keywords" : {},
+ "references" : {},
+ "title" : "INDEX"
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/json-indalign/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/json-indalign/2_justkeys
new file mode 100644
index 0000000..67a7e19
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/json-indalign/2_justkeys
@@ -0,0 +1,53 @@
+{
+ "doctools::idx" : {
+ "label" : "Keyword Index",
+ "keywords" : {
+ "changelog" : [],
+ "conversion" : [],
+ "cvs" : [],
+ "cvs log" : [],
+ "docidx" : [],
+ "docidx commands" : [],
+ "docidx language" : [],
+ "docidx markup" : [],
+ "docidx syntax" : [],
+ "doctoc" : [],
+ "doctoc commands" : [],
+ "doctoc language" : [],
+ "doctoc markup" : [],
+ "doctoc syntax" : [],
+ "doctools" : [],
+ "doctools commands" : [],
+ "doctools language" : [],
+ "doctools markup" : [],
+ "doctools syntax" : [],
+ "document" : [],
+ "documentation" : [],
+ "emacs" : [],
+ "examples" : [],
+ "faq" : [],
+ "formatter" : [],
+ "formatting engine" : [],
+ "HTML" : [],
+ "index" : [],
+ "index formatter" : [],
+ "keyword index" : [],
+ "keywords" : [],
+ "latex" : [],
+ "log" : [],
+ "manpage" : [],
+ "markup" : [],
+ "nroff" : [],
+ "plugin" : [],
+ "semantic markup" : [],
+ "table of contents" : [],
+ "TMML" : [],
+ "toc" : [],
+ "toc formatter" : [],
+ "web" : [],
+ "wiki" : []
+ },
+ "references" : {},
+ "title" : ""
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/json-indalign/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/json-indalign/3_kwic
new file mode 100644
index 0000000..7083936
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/json-indalign/3_kwic
@@ -0,0 +1,80 @@
+{
+ "doctools::idx" : {
+ "label" : "Keyword Index",
+ "keywords" : {
+ "changelog" : ["changelog.man","cvs.man"],
+ "conversion" : ["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],
+ "cvs" : ["cvs.man"],
+ "cvs log" : ["cvs.man"],
+ "docidx" : ["docidx.man","apps\/dtplite.man"],
+ "docidx commands" : ["docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"],
+ "docidx language" : ["docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"],
+ "docidx markup" : ["docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"],
+ "docidx syntax" : ["docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"],
+ "doctoc" : ["doctoc.man","apps\/dtplite.man"],
+ "doctoc commands" : ["doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],
+ "doctoc language" : ["doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],
+ "doctoc markup" : ["doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],
+ "doctoc syntax" : ["doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],
+ "doctools" : ["changelog.man","apps\/dtplite.man"],
+ "doctools commands" : ["doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],
+ "doctools language" : ["doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],
+ "doctools markup" : ["doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],
+ "doctools syntax" : ["doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],
+ "document" : ["doctools_plugin_apiref.man"],
+ "documentation" : ["doctools.man","docidx.man","doctoc.man"],
+ "emacs" : ["changelog.man","cvs.man"],
+ "examples" : ["docidx_lang_faq.man","doctoc_lang_faq.man","doctools_lang_faq.man"],
+ "faq" : ["docidx_lang_faq.man","doctoc_lang_faq.man","doctools_lang_faq.man"],
+ "formatter" : ["doctools_plugin_apiref.man"],
+ "formatting engine" : ["docidx_plugin_apiref.man","doctoc_plugin_apiref.man","doctools_plugin_apiref.man"],
+ "HTML" : ["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],
+ "index" : ["docidx_intro.man","docidx_plugin_apiref.man","docidx.man"],
+ "index formatter" : ["docidx_plugin_apiref.man"],
+ "keyword index" : ["docidx_intro.man","docidx.man"],
+ "keywords" : ["docidx_plugin_apiref.man"],
+ "latex" : ["docidx.man","doctoc.man"],
+ "log" : ["cvs.man"],
+ "manpage" : ["doctools.man","docidx.man","doctoc.man","doctools_plugin_apiref.man","apps\/dtplite.man","mpexpand.man"],
+ "markup" : ["docidx_intro.man","docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man","docidx_plugin_apiref.man","doctoc_intro.man","doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man","doctoc_plugin_apiref.man","doctools.man","docidx.man","doctoc.man","doctools_intro.man","doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man","doctools_plugin_apiref.man","apps\/dtplite.man","mpexpand.man"],
+ "nroff" : ["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],
+ "plugin" : ["docidx_plugin_apiref.man","doctoc_plugin_apiref.man"],
+ "semantic markup" : ["docidx_intro.man","docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man","docidx_plugin_apiref.man","doctoc_intro.man","doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man","doctoc_plugin_apiref.man","doctools_intro.man","doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man","doctools_plugin_apiref.man"],
+ "table of contents" : ["doctoc_intro.man","doctoc_plugin_apiref.man","doctoc.man"],
+ "TMML" : ["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],
+ "toc" : ["doctoc_intro.man","doctoc_plugin_apiref.man","doctoc.man"],
+ "toc formatter" : ["doctoc_plugin_apiref.man"],
+ "web" : ["http:\/\/tcllib.sourceforge.net\/doc\/docidx_lang_intro.html"],
+ "wiki" : ["docidx.man","doctoc.man"]
+ },
+ "references" : {
+ "apps\/dtplite.man" : ["manpage","dtplite"],
+ "changelog.man" : ["manpage","doctools::changelog"],
+ "cvs.man" : ["manpage","doctools::cvs"],
+ "docidx.man" : ["manpage","doctools::idx"],
+ "docidx_intro.man" : ["manpage","docidx_intro"],
+ "docidx_lang_cmdref.man" : ["manpage","docidx_lang_cmdref"],
+ "docidx_lang_faq.man" : ["manpage","docidx_lang_faq"],
+ "docidx_lang_intro.man" : ["manpage","docidx_lang_intro"],
+ "docidx_lang_syntax.man" : ["manpage","docidx_lang_syntax"],
+ "docidx_plugin_apiref.man" : ["manpage","docidx_plugin_apiref"],
+ "doctoc.man" : ["manpage","doctools::toc"],
+ "doctoc_intro.man" : ["manpage","doctoc_intro"],
+ "doctoc_lang_cmdref.man" : ["manpage","doctoc_lang_cmdref"],
+ "doctoc_lang_faq.man" : ["manpage","doctoc_lang_faq"],
+ "doctoc_lang_intro.man" : ["manpage","doctoc_lang_intro"],
+ "doctoc_lang_syntax.man" : ["manpage","doctoc_lang_syntax"],
+ "doctoc_plugin_apiref.man" : ["manpage","doctoc_plugin_apiref"],
+ "doctools.man" : ["manpage","doctools"],
+ "doctools_intro.man" : ["manpage","doctools_intro"],
+ "doctools_lang_cmdref.man" : ["manpage","doctools_lang_cmdref"],
+ "doctools_lang_faq.man" : ["manpage","doctools_lang_faq"],
+ "doctools_lang_intro.man" : ["manpage","doctools_lang_intro"],
+ "doctools_lang_syntax.man" : ["manpage","doctools_lang_syntax"],
+ "doctools_plugin_apiref.man" : ["manpage","doctools_plugin_apiref"],
+ "http:\/\/tcllib.sourceforge.net\/doc\/docidx_lang_intro.html" : ["url" ,"docidx language introduction"],
+ "mpexpand.man" : ["manpage","mpexpand"]
+ },
+ "title" : ""
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/json-indented/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/json-indented/1_nokeys
new file mode 100644
index 0000000..bffac8c
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/json-indented/1_nokeys
@@ -0,0 +1,8 @@
+{
+ "doctools::idx" : {
+ "label" : "KWIC",
+ "keywords" : {},
+ "references" : {},
+ "title" : "INDEX"
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/json-indented/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/json-indented/2_justkeys
new file mode 100644
index 0000000..f256ab0
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/json-indented/2_justkeys
@@ -0,0 +1,53 @@
+{
+ "doctools::idx" : {
+ "label" : "Keyword Index",
+ "keywords" : {
+ "changelog" : [],
+ "conversion" : [],
+ "cvs" : [],
+ "cvs log" : [],
+ "docidx" : [],
+ "docidx commands" : [],
+ "docidx language" : [],
+ "docidx markup" : [],
+ "docidx syntax" : [],
+ "doctoc" : [],
+ "doctoc commands" : [],
+ "doctoc language" : [],
+ "doctoc markup" : [],
+ "doctoc syntax" : [],
+ "doctools" : [],
+ "doctools commands" : [],
+ "doctools language" : [],
+ "doctools markup" : [],
+ "doctools syntax" : [],
+ "document" : [],
+ "documentation" : [],
+ "emacs" : [],
+ "examples" : [],
+ "faq" : [],
+ "formatter" : [],
+ "formatting engine" : [],
+ "HTML" : [],
+ "index" : [],
+ "index formatter" : [],
+ "keyword index" : [],
+ "keywords" : [],
+ "latex" : [],
+ "log" : [],
+ "manpage" : [],
+ "markup" : [],
+ "nroff" : [],
+ "plugin" : [],
+ "semantic markup" : [],
+ "table of contents" : [],
+ "TMML" : [],
+ "toc" : [],
+ "toc formatter" : [],
+ "web" : [],
+ "wiki" : []
+ },
+ "references" : {},
+ "title" : ""
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/json-indented/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/json-indented/3_kwic
new file mode 100644
index 0000000..3083fec
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/json-indented/3_kwic
@@ -0,0 +1,80 @@
+{
+ "doctools::idx" : {
+ "label" : "Keyword Index",
+ "keywords" : {
+ "changelog" : ["changelog.man","cvs.man"],
+ "conversion" : ["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],
+ "cvs" : ["cvs.man"],
+ "cvs log" : ["cvs.man"],
+ "docidx" : ["docidx.man","apps\/dtplite.man"],
+ "docidx commands" : ["docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"],
+ "docidx language" : ["docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"],
+ "docidx markup" : ["docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"],
+ "docidx syntax" : ["docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"],
+ "doctoc" : ["doctoc.man","apps\/dtplite.man"],
+ "doctoc commands" : ["doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],
+ "doctoc language" : ["doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],
+ "doctoc markup" : ["doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],
+ "doctoc syntax" : ["doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],
+ "doctools" : ["changelog.man","apps\/dtplite.man"],
+ "doctools commands" : ["doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],
+ "doctools language" : ["doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],
+ "doctools markup" : ["doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],
+ "doctools syntax" : ["doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],
+ "document" : ["doctools_plugin_apiref.man"],
+ "documentation" : ["doctools.man","docidx.man","doctoc.man"],
+ "emacs" : ["changelog.man","cvs.man"],
+ "examples" : ["docidx_lang_faq.man","doctoc_lang_faq.man","doctools_lang_faq.man"],
+ "faq" : ["docidx_lang_faq.man","doctoc_lang_faq.man","doctools_lang_faq.man"],
+ "formatter" : ["doctools_plugin_apiref.man"],
+ "formatting engine" : ["docidx_plugin_apiref.man","doctoc_plugin_apiref.man","doctools_plugin_apiref.man"],
+ "HTML" : ["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],
+ "index" : ["docidx_intro.man","docidx_plugin_apiref.man","docidx.man"],
+ "index formatter" : ["docidx_plugin_apiref.man"],
+ "keyword index" : ["docidx_intro.man","docidx.man"],
+ "keywords" : ["docidx_plugin_apiref.man"],
+ "latex" : ["docidx.man","doctoc.man"],
+ "log" : ["cvs.man"],
+ "manpage" : ["doctools.man","docidx.man","doctoc.man","doctools_plugin_apiref.man","apps\/dtplite.man","mpexpand.man"],
+ "markup" : ["docidx_intro.man","docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man","docidx_plugin_apiref.man","doctoc_intro.man","doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man","doctoc_plugin_apiref.man","doctools.man","docidx.man","doctoc.man","doctools_intro.man","doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man","doctools_plugin_apiref.man","apps\/dtplite.man","mpexpand.man"],
+ "nroff" : ["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],
+ "plugin" : ["docidx_plugin_apiref.man","doctoc_plugin_apiref.man"],
+ "semantic markup" : ["docidx_intro.man","docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man","docidx_plugin_apiref.man","doctoc_intro.man","doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man","doctoc_plugin_apiref.man","doctools_intro.man","doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man","doctools_plugin_apiref.man"],
+ "table of contents" : ["doctoc_intro.man","doctoc_plugin_apiref.man","doctoc.man"],
+ "TMML" : ["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],
+ "toc" : ["doctoc_intro.man","doctoc_plugin_apiref.man","doctoc.man"],
+ "toc formatter" : ["doctoc_plugin_apiref.man"],
+ "web" : ["http:\/\/tcllib.sourceforge.net\/doc\/docidx_lang_intro.html"],
+ "wiki" : ["docidx.man","doctoc.man"]
+ },
+ "references" : {
+ "apps\/dtplite.man" : ["manpage","dtplite"],
+ "changelog.man" : ["manpage","doctools::changelog"],
+ "cvs.man" : ["manpage","doctools::cvs"],
+ "docidx.man" : ["manpage","doctools::idx"],
+ "docidx_intro.man" : ["manpage","docidx_intro"],
+ "docidx_lang_cmdref.man" : ["manpage","docidx_lang_cmdref"],
+ "docidx_lang_faq.man" : ["manpage","docidx_lang_faq"],
+ "docidx_lang_intro.man" : ["manpage","docidx_lang_intro"],
+ "docidx_lang_syntax.man" : ["manpage","docidx_lang_syntax"],
+ "docidx_plugin_apiref.man" : ["manpage","docidx_plugin_apiref"],
+ "doctoc.man" : ["manpage","doctools::toc"],
+ "doctoc_intro.man" : ["manpage","doctoc_intro"],
+ "doctoc_lang_cmdref.man" : ["manpage","doctoc_lang_cmdref"],
+ "doctoc_lang_faq.man" : ["manpage","doctoc_lang_faq"],
+ "doctoc_lang_intro.man" : ["manpage","doctoc_lang_intro"],
+ "doctoc_lang_syntax.man" : ["manpage","doctoc_lang_syntax"],
+ "doctoc_plugin_apiref.man" : ["manpage","doctoc_plugin_apiref"],
+ "doctools.man" : ["manpage","doctools"],
+ "doctools_intro.man" : ["manpage","doctools_intro"],
+ "doctools_lang_cmdref.man" : ["manpage","doctools_lang_cmdref"],
+ "doctools_lang_faq.man" : ["manpage","doctools_lang_faq"],
+ "doctools_lang_intro.man" : ["manpage","doctools_lang_intro"],
+ "doctools_lang_syntax.man" : ["manpage","doctools_lang_syntax"],
+ "doctools_plugin_apiref.man" : ["manpage","doctools_plugin_apiref"],
+ "http:\/\/tcllib.sourceforge.net\/doc\/docidx_lang_intro.html" : ["url","docidx language introduction"],
+ "mpexpand.man" : ["manpage","mpexpand"]
+ },
+ "title" : ""
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/json-ultracompact/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/json-ultracompact/1_nokeys
new file mode 100644
index 0000000..889bc50
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/json-ultracompact/1_nokeys
@@ -0,0 +1 @@
+{"doctools::idx":{"label":"KWIC","keywords":{},"references":{},"title":"INDEX"}}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/json-ultracompact/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/json-ultracompact/2_justkeys
new file mode 100644
index 0000000..7c65c99
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/json-ultracompact/2_justkeys
@@ -0,0 +1 @@
+{"doctools::idx":{"label":"Keyword Index","keywords":{"changelog":[],"conversion":[],"cvs":[],"cvs log":[],"docidx":[],"docidx commands":[],"docidx language":[],"docidx markup":[],"docidx syntax":[],"doctoc":[],"doctoc commands":[],"doctoc language":[],"doctoc markup":[],"doctoc syntax":[],"doctools":[],"doctools commands":[],"doctools language":[],"doctools markup":[],"doctools syntax":[],"document":[],"documentation":[],"emacs":[],"examples":[],"faq":[],"formatter":[],"formatting engine":[],"HTML":[],"index":[],"index formatter":[],"keyword index":[],"keywords":[],"latex":[],"log":[],"manpage":[],"markup":[],"nroff":[],"plugin":[],"semantic markup":[],"table of contents":[],"TMML":[],"toc":[],"toc formatter":[],"web":[],"wiki":[]},"references":{},"title":""}}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/json-ultracompact/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/json-ultracompact/3_kwic
new file mode 100644
index 0000000..bb7f35b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/json-ultracompact/3_kwic
@@ -0,0 +1 @@
+{"doctools::idx":{"label":"Keyword Index","keywords":{"changelog":["changelog.man","cvs.man"],"conversion":["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],"cvs":["cvs.man"],"cvs log":["cvs.man"],"docidx":["docidx.man","apps\/dtplite.man"],"docidx commands":["docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"],"docidx language":["docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"],"docidx markup":["docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"],"docidx syntax":["docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"],"doctoc":["doctoc.man","apps\/dtplite.man"],"doctoc commands":["doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],"doctoc language":["doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],"doctoc markup":["doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],"doctoc syntax":["doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],"doctools":["changelog.man","apps\/dtplite.man"],"doctools commands":["doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],"doctools language":["doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],"doctools markup":["doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],"doctools syntax":["doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],"document":["doctools_plugin_apiref.man"],"documentation":["doctools.man","docidx.man","doctoc.man"],"emacs":["changelog.man","cvs.man"],"examples":["docidx_lang_faq.man","doctoc_lang_faq.man","doctools_lang_faq.man"],"faq":["docidx_lang_faq.man","doctoc_lang_faq.man","doctools_lang_faq.man"],"formatter":["doctools_plugin_apiref.man"],"formatting engine":["docidx_plugin_apiref.man","doctoc_plugin_apiref.man","doctools_plugin_apiref.man"],"HTML":["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],"index":["docidx_intro.man","docidx_plugin_apiref.man","docidx.man"],"index formatter":["docidx_plugin_apiref.man"],"keyword index":["docidx_intro.man","docidx.man"],"keywords":["docidx_plugin_apiref.man"],"latex":["docidx.man","doctoc.man"],"log":["cvs.man"],"manpage":["doctools.man","docidx.man","doctoc.man","doctools_plugin_apiref.man","apps\/dtplite.man","mpexpand.man"],"markup":["docidx_intro.man","docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man","docidx_plugin_apiref.man","doctoc_intro.man","doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man","doctoc_plugin_apiref.man","doctools.man","docidx.man","doctoc.man","doctools_intro.man","doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man","doctools_plugin_apiref.man","apps\/dtplite.man","mpexpand.man"],"nroff":["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],"plugin":["docidx_plugin_apiref.man","doctoc_plugin_apiref.man"],"semantic markup":["docidx_intro.man","docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man","docidx_plugin_apiref.man","doctoc_intro.man","doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man","doctoc_plugin_apiref.man","doctools_intro.man","doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man","doctools_plugin_apiref.man"],"table of contents":["doctoc_intro.man","doctoc_plugin_apiref.man","doctoc.man"],"TMML":["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],"toc":["doctoc_intro.man","doctoc_plugin_apiref.man","doctoc.man"],"toc formatter":["doctoc_plugin_apiref.man"],"web":["http:\/\/tcllib.sourceforge.net\/doc\/docidx_lang_intro.html"],"wiki":["docidx.man","doctoc.man"]},"references":{"apps\/dtplite.man":["manpage","dtplite"],"changelog.man":["manpage","doctools::changelog"],"cvs.man":["manpage","doctools::cvs"],"docidx.man":["manpage","doctools::idx"],"docidx_intro.man":["manpage","docidx_intro"],"docidx_lang_cmdref.man":["manpage","docidx_lang_cmdref"],"docidx_lang_faq.man":["manpage","docidx_lang_faq"],"docidx_lang_intro.man":["manpage","docidx_lang_intro"],"docidx_lang_syntax.man":["manpage","docidx_lang_syntax"],"docidx_plugin_apiref.man":["manpage","docidx_plugin_apiref"],"doctoc.man":["manpage","doctools::toc"],"doctoc_intro.man":["manpage","doctoc_intro"],"doctoc_lang_cmdref.man":["manpage","doctoc_lang_cmdref"],"doctoc_lang_faq.man":["manpage","doctoc_lang_faq"],"doctoc_lang_intro.man":["manpage","doctoc_lang_intro"],"doctoc_lang_syntax.man":["manpage","doctoc_lang_syntax"],"doctoc_plugin_apiref.man":["manpage","doctoc_plugin_apiref"],"doctools.man":["manpage","doctools"],"doctools_intro.man":["manpage","doctools_intro"],"doctools_lang_cmdref.man":["manpage","doctools_lang_cmdref"],"doctools_lang_faq.man":["manpage","doctools_lang_faq"],"doctools_lang_intro.man":["manpage","doctools_lang_intro"],"doctools_lang_syntax.man":["manpage","doctools_lang_syntax"],"doctools_plugin_apiref.man":["manpage","doctools_plugin_apiref"],"http:\/\/tcllib.sourceforge.net\/doc\/docidx_lang_intro.html":["url","docidx language introduction"],"mpexpand.man":["manpage","mpexpand"]},"title":""}}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/json/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/json/1_nokeys
new file mode 100644
index 0000000..754dd0d
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/json/1_nokeys
@@ -0,0 +1,8 @@
+{
+ "doctools::idx" : {
+ "keywords" : {},
+ "label" : "KWIC",
+ "title" : "INDEX",
+ "references" : {}
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/json/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/json/2_justkeys
new file mode 100644
index 0000000..2494bb0
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/json/2_justkeys
@@ -0,0 +1,53 @@
+{
+ "doctools::idx" : {
+ "keywords" : {
+ "docidx commands" : [],
+ "web" : [],
+ "doctools syntax" : [],
+ "conversion" : [],
+ "markup" : [],
+ "keywords" : [],
+ "index" : [],
+ "faq" : [],
+ "doctoc language" : [],
+ "formatting engine" : [],
+ "TMML" : [],
+ "docidx syntax" : [],
+ "table of contents" : [],
+ "doctools language" : [],
+ "doctoc syntax" : [],
+ "docidx" : [],
+ "wiki" : [],
+ "keyword index" : [],
+ "cvs log" : [],
+ "doctoc commands" : [],
+ "examples" : [],
+ "doctools" : [],
+ "changelog" : [],
+ "manpage" : [],
+ "emacs" : [],
+ "doctools commands" : [],
+ "toc formatter" : [],
+ "log" : [],
+ "documentation" : [],
+ "nroff" : [],
+ "docidx markup" : [],
+ "semantic markup" : [],
+ "index formatter" : [],
+ "formatter" : [],
+ "doctoc markup" : [],
+ "cvs" : [],
+ "doctoc" : [],
+ "HTML" : [],
+ "toc" : [],
+ "latex" : [],
+ "plugin" : [],
+ "document" : [],
+ "doctools markup" : [],
+ "docidx language" : []
+ },
+ "title" : "",
+ "label" : "Keyword Index",
+ "references" : {}
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/json/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/json/3_kwic
new file mode 100644
index 0000000..14db175
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/json/3_kwic
@@ -0,0 +1,80 @@
+{
+ "doctools::idx" : {
+ "title" : "",
+ "keywords" : {
+ "web" : ["http:\/\/tcllib.sourceforge.net\/doc\/docidx_lang_intro.html"],
+ "doctools syntax" : ["doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],
+ "conversion" : ["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],
+ "cvs log" : ["cvs.man"],
+ "doctoc commands" : ["doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],
+ "examples" : ["docidx_lang_faq.man","doctoc_lang_faq.man","doctools_lang_faq.man"],
+ "markup" : ["docidx_intro.man","docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man","docidx_plugin_apiref.man","doctoc_intro.man","doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man","doctoc_plugin_apiref.man","doctools.man","docidx.man","doctoc.man","doctools_intro.man","doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man","doctools_plugin_apiref.man","apps\/dtplite.man","mpexpand.man"],
+ "keywords" : ["docidx_plugin_apiref.man"],
+ "index" : ["docidx_intro.man","docidx_plugin_apiref.man","docidx.man"],
+ "faq" : ["docidx_lang_faq.man","doctoc_lang_faq.man","doctools_lang_faq.man"],
+ "doctoc language" : ["doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],
+ "formatting engine" : ["docidx_plugin_apiref.man","doctoc_plugin_apiref.man","doctools_plugin_apiref.man"],
+ "TMML" : ["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],
+ "docidx syntax" : ["docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"],
+ "table of contents" : ["doctoc_intro.man","doctoc_plugin_apiref.man","doctoc.man"],
+ "doctools language" : ["doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],
+ "doctoc syntax" : ["doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],
+ "docidx" : ["docidx.man","apps\/dtplite.man"],
+ "wiki" : ["docidx.man","doctoc.man"],
+ "keyword index" : ["docidx_intro.man","docidx.man"],
+ "docidx commands" : ["docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"],
+ "doctools" : ["changelog.man","apps\/dtplite.man"],
+ "changelog" : ["changelog.man","cvs.man"],
+ "manpage" : ["doctools.man","docidx.man","doctoc.man","doctools_plugin_apiref.man","apps\/dtplite.man","mpexpand.man"],
+ "emacs" : ["changelog.man","cvs.man"],
+ "doctools commands" : ["doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],
+ "toc formatter" : ["doctoc_plugin_apiref.man"],
+ "log" : ["cvs.man"],
+ "documentation" : ["docidx.man","doctools.man","doctoc.man"],
+ "nroff" : ["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],
+ "docidx markup" : ["docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"],
+ "semantic markup" : ["docidx_intro.man","docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man","docidx_plugin_apiref.man","doctoc_intro.man","doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man","doctoc_plugin_apiref.man","doctools_intro.man","doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man","doctools_plugin_apiref.man"],
+ "index formatter" : ["docidx_plugin_apiref.man"],
+ "formatter" : ["doctools_plugin_apiref.man"],
+ "doctoc markup" : ["doctoc_lang_cmdref.man","doctoc_lang_faq.man","doctoc_lang_intro.man","doctoc_lang_syntax.man"],
+ "cvs" : ["cvs.man"],
+ "doctoc" : ["doctoc.man","apps\/dtplite.man"],
+ "HTML" : ["doctools.man","docidx.man","doctoc.man","apps\/dtplite.man","mpexpand.man"],
+ "toc" : ["doctoc_intro.man","doctoc_plugin_apiref.man","doctoc.man"],
+ "latex" : ["docidx.man","doctoc.man"],
+ "plugin" : ["docidx_plugin_apiref.man","doctoc_plugin_apiref.man"],
+ "document" : ["doctools_plugin_apiref.man"],
+ "doctools markup" : ["doctools_lang_cmdref.man","doctools_lang_faq.man","doctools_lang_intro.man","doctools_lang_syntax.man"],
+ "docidx language" : ["docidx_lang_cmdref.man","docidx_lang_faq.man","docidx_lang_intro.man","docidx_lang_syntax.man"]
+ },
+ "references" : {
+ "docidx_lang_intro.man" : ["manpage","docidx_lang_intro"],
+ "docidx_plugin_apiref.man" : ["manpage","docidx_plugin_apiref"],
+ "doctoc_intro.man" : ["manpage","doctoc_intro"],
+ "doctools_lang_cmdref.man" : ["manpage","doctools_lang_cmdref"],
+ "doctoc_lang_intro.man" : ["manpage","doctoc_lang_intro"],
+ "docidx_lang_syntax.man" : ["manpage","docidx_lang_syntax"],
+ "doctools_plugin_apiref.man" : ["manpage","doctools_plugin_apiref"],
+ "doctools_lang_intro.man" : ["manpage","doctools_lang_intro"],
+ "docidx.man" : ["manpage","doctools::idx"],
+ "docidx_lang_faq.man" : ["manpage","docidx_lang_faq"],
+ "doctoc_lang_faq.man" : ["manpage","doctoc_lang_faq"],
+ "http:\/\/tcllib.sourceforge.net\/doc\/docidx_lang_intro.html" : ["url" ,"docidx language introduction"],
+ "doctoc_lang_cmdref.man" : ["manpage","doctoc_lang_cmdref"],
+ "doctools_lang_syntax.man" : ["manpage","doctools_lang_syntax"],
+ "docidx_intro.man" : ["manpage","docidx_intro"],
+ "doctools_lang_faq.man" : ["manpage","doctools_lang_faq"],
+ "doctools.man" : ["manpage","doctools"],
+ "doctoc_plugin_apiref.man" : ["manpage","doctoc_plugin_apiref"],
+ "changelog.man" : ["manpage","doctools::changelog"],
+ "apps\/dtplite.man" : ["manpage","dtplite"],
+ "doctools_intro.man" : ["manpage","doctools_intro"],
+ "doctoc_lang_syntax.man" : ["manpage","doctoc_lang_syntax"],
+ "cvs.man" : ["manpage","doctools::cvs"],
+ "docidx_lang_cmdref.man" : ["manpage","docidx_lang_cmdref"],
+ "doctoc.man" : ["manpage","doctools::toc"],
+ "mpexpand.man" : ["manpage","mpexpand"]
+ },
+ "label" : "Keyword Index"
+ }
+}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/json/README.txt b/tcllib/modules/doctools2idx/tests/data/ok/json/README.txt
new file mode 100644
index 0000000..5db289a
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/json/README.txt
@@ -0,0 +1,3 @@
+This section holds json input which is non-canonical, i.e. in the
+proper format, with the keys not alphabetically. This is acceptable as
+input, and the importer makes it canonical for the higher layers.
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/nroff-external/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/nroff-external/1_nokeys
new file mode 100644
index 0000000..9336fa2
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/nroff-external/1_nokeys
@@ -0,0 +1,5 @@
+.so man.macros
+.TH KWIC
+.SH INDEX
+INDEX
+.RS
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/nroff-external/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/nroff-external/2_justkeys
new file mode 100644
index 0000000..438077f
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/nroff-external/2_justkeys
@@ -0,0 +1,136 @@
+.so man.macros
+.TH "KEYWORD INDEX"
+.SH INDEX
+.RS
+changelog
+.RS
+.RE
+conversion
+.RS
+.RE
+cvs
+.RS
+.RE
+cvs log
+.RS
+.RE
+docidx
+.RS
+.RE
+docidx commands
+.RS
+.RE
+docidx language
+.RS
+.RE
+docidx markup
+.RS
+.RE
+docidx syntax
+.RS
+.RE
+doctoc
+.RS
+.RE
+doctoc commands
+.RS
+.RE
+doctoc language
+.RS
+.RE
+doctoc markup
+.RS
+.RE
+doctoc syntax
+.RS
+.RE
+doctools
+.RS
+.RE
+doctools commands
+.RS
+.RE
+doctools language
+.RS
+.RE
+doctools markup
+.RS
+.RE
+doctools syntax
+.RS
+.RE
+document
+.RS
+.RE
+documentation
+.RS
+.RE
+emacs
+.RS
+.RE
+examples
+.RS
+.RE
+faq
+.RS
+.RE
+formatter
+.RS
+.RE
+formatting engine
+.RS
+.RE
+HTML
+.RS
+.RE
+index
+.RS
+.RE
+index formatter
+.RS
+.RE
+keyword index
+.RS
+.RE
+keywords
+.RS
+.RE
+latex
+.RS
+.RE
+log
+.RS
+.RE
+manpage
+.RS
+.RE
+markup
+.RS
+.RE
+nroff
+.RS
+.RE
+plugin
+.RS
+.RE
+semantic markup
+.RS
+.RE
+table of contents
+.RS
+.RE
+TMML
+.RS
+.RE
+toc
+.RS
+.RE
+toc formatter
+.RS
+.RE
+web
+.RS
+.RE
+wiki
+.RS
+.RE
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/nroff-external/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/nroff-external/3_kwic
new file mode 100644
index 0000000..e5d1cf5
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/nroff-external/3_kwic
@@ -0,0 +1,660 @@
+.so man.macros
+.TH "KEYWORD INDEX"
+.SH INDEX
+.RS
+changelog
+.RS
+.TP
+\fBchangelog.man\fR
+doctools::changelog
+.TP
+\fBcvs.man\fR
+doctools::cvs
+.RE
+.PP
+conversion
+.RS
+.TP
+\fBdoctools.man\fR
+doctools
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.TP
+\fBmpexpand.man\fR
+mpexpand
+.RE
+.PP
+cvs
+.RS
+.TP
+\fBcvs.man\fR
+doctools::cvs
+.RE
+.PP
+cvs log
+.RS
+.TP
+\fBcvs.man\fR
+doctools::cvs
+.RE
+.PP
+docidx
+.RS
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.RE
+.PP
+docidx commands
+.RS
+.TP
+\fBdocidx_lang_cmdref.man\fR
+docidx_lang_cmdref
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdocidx_lang_intro.man\fR
+docidx_lang_intro
+.TP
+\fBdocidx_lang_syntax.man\fR
+docidx_lang_syntax
+.RE
+.PP
+docidx language
+.RS
+.TP
+\fBdocidx_lang_cmdref.man\fR
+docidx_lang_cmdref
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdocidx_lang_intro.man\fR
+docidx_lang_intro
+.TP
+\fBdocidx_lang_syntax.man\fR
+docidx_lang_syntax
+.RE
+.PP
+docidx markup
+.RS
+.TP
+\fBdocidx_lang_cmdref.man\fR
+docidx_lang_cmdref
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdocidx_lang_intro.man\fR
+docidx_lang_intro
+.TP
+\fBdocidx_lang_syntax.man\fR
+docidx_lang_syntax
+.RE
+.PP
+docidx syntax
+.RS
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdocidx_lang_intro.man\fR
+docidx_lang_intro
+.TP
+\fBdocidx_lang_syntax.man\fR
+docidx_lang_syntax
+.RE
+.PP
+doctoc
+.RS
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.RE
+.PP
+doctoc commands
+.RS
+.TP
+\fBdoctoc_lang_cmdref.man\fR
+doctoc_lang_cmdref
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctoc_lang_intro.man\fR
+doctoc_lang_intro
+.TP
+\fBdoctoc_lang_syntax.man\fR
+doctoc_lang_syntax
+.RE
+.PP
+doctoc language
+.RS
+.TP
+\fBdoctoc_lang_cmdref.man\fR
+doctoc_lang_cmdref
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctoc_lang_intro.man\fR
+doctoc_lang_intro
+.TP
+\fBdoctoc_lang_syntax.man\fR
+doctoc_lang_syntax
+.RE
+.PP
+doctoc markup
+.RS
+.TP
+\fBdoctoc_lang_cmdref.man\fR
+doctoc_lang_cmdref
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctoc_lang_intro.man\fR
+doctoc_lang_intro
+.TP
+\fBdoctoc_lang_syntax.man\fR
+doctoc_lang_syntax
+.RE
+.PP
+doctoc syntax
+.RS
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctoc_lang_intro.man\fR
+doctoc_lang_intro
+.TP
+\fBdoctoc_lang_syntax.man\fR
+doctoc_lang_syntax
+.RE
+.PP
+doctools
+.RS
+.TP
+\fBchangelog.man\fR
+doctools::changelog
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.RE
+.PP
+doctools commands
+.RS
+.TP
+\fBdoctools_lang_cmdref.man\fR
+doctools_lang_cmdref
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.TP
+\fBdoctools_lang_intro.man\fR
+doctools_lang_intro
+.TP
+\fBdoctools_lang_syntax.man\fR
+doctools_lang_syntax
+.RE
+.PP
+doctools language
+.RS
+.TP
+\fBdoctools_lang_cmdref.man\fR
+doctools_lang_cmdref
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.TP
+\fBdoctools_lang_intro.man\fR
+doctools_lang_intro
+.TP
+\fBdoctools_lang_syntax.man\fR
+doctools_lang_syntax
+.RE
+.PP
+doctools markup
+.RS
+.TP
+\fBdoctools_lang_cmdref.man\fR
+doctools_lang_cmdref
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.TP
+\fBdoctools_lang_intro.man\fR
+doctools_lang_intro
+.TP
+\fBdoctools_lang_syntax.man\fR
+doctools_lang_syntax
+.RE
+.PP
+doctools syntax
+.RS
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.TP
+\fBdoctools_lang_intro.man\fR
+doctools_lang_intro
+.TP
+\fBdoctools_lang_syntax.man\fR
+doctools_lang_syntax
+.RE
+.PP
+document
+.RS
+.TP
+\fBdoctools_plugin_apiref.man\fR
+doctools_plugin_apiref
+.RE
+.PP
+documentation
+.RS
+.TP
+\fBdoctools.man\fR
+doctools
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.RE
+.PP
+emacs
+.RS
+.TP
+\fBchangelog.man\fR
+doctools::changelog
+.TP
+\fBcvs.man\fR
+doctools::cvs
+.RE
+.PP
+examples
+.RS
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.RE
+.PP
+faq
+.RS
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.RE
+.PP
+formatter
+.RS
+.TP
+\fBdoctools_plugin_apiref.man\fR
+doctools_plugin_apiref
+.RE
+.PP
+formatting engine
+.RS
+.TP
+\fBdocidx_plugin_apiref.man\fR
+docidx_plugin_apiref
+.TP
+\fBdoctoc_plugin_apiref.man\fR
+doctoc_plugin_apiref
+.TP
+\fBdoctools_plugin_apiref.man\fR
+doctools_plugin_apiref
+.RE
+.PP
+HTML
+.RS
+.TP
+\fBdoctools.man\fR
+doctools
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.TP
+\fBmpexpand.man\fR
+mpexpand
+.RE
+.PP
+index
+.RS
+.TP
+\fBdocidx_intro.man\fR
+docidx_intro
+.TP
+\fBdocidx_plugin_apiref.man\fR
+docidx_plugin_apiref
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.RE
+.PP
+index formatter
+.RS
+.TP
+\fBdocidx_plugin_apiref.man\fR
+docidx_plugin_apiref
+.RE
+.PP
+keyword index
+.RS
+.TP
+\fBdocidx_intro.man\fR
+docidx_intro
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.RE
+.PP
+keywords
+.RS
+.TP
+\fBdocidx_plugin_apiref.man\fR
+docidx_plugin_apiref
+.RE
+.PP
+latex
+.RS
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.RE
+.PP
+log
+.RS
+.TP
+\fBcvs.man\fR
+doctools::cvs
+.RE
+.PP
+manpage
+.RS
+.TP
+\fBdoctools.man\fR
+doctools
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.TP
+\fBdoctools_plugin_apiref.man\fR
+doctools_plugin_apiref
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.TP
+\fBmpexpand.man\fR
+mpexpand
+.RE
+.PP
+markup
+.RS
+.TP
+\fBdocidx_intro.man\fR
+docidx_intro
+.TP
+\fBdocidx_lang_cmdref.man\fR
+docidx_lang_cmdref
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdocidx_lang_intro.man\fR
+docidx_lang_intro
+.TP
+\fBdocidx_lang_syntax.man\fR
+docidx_lang_syntax
+.TP
+\fBdocidx_plugin_apiref.man\fR
+docidx_plugin_apiref
+.TP
+\fBdoctoc_intro.man\fR
+doctoc_intro
+.TP
+\fBdoctoc_lang_cmdref.man\fR
+doctoc_lang_cmdref
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctoc_lang_intro.man\fR
+doctoc_lang_intro
+.TP
+\fBdoctoc_lang_syntax.man\fR
+doctoc_lang_syntax
+.TP
+\fBdoctoc_plugin_apiref.man\fR
+doctoc_plugin_apiref
+.TP
+\fBdoctools.man\fR
+doctools
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.TP
+\fBdoctools_intro.man\fR
+doctools_intro
+.TP
+\fBdoctools_lang_cmdref.man\fR
+doctools_lang_cmdref
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.TP
+\fBdoctools_lang_intro.man\fR
+doctools_lang_intro
+.TP
+\fBdoctools_lang_syntax.man\fR
+doctools_lang_syntax
+.TP
+\fBdoctools_plugin_apiref.man\fR
+doctools_plugin_apiref
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.TP
+\fBmpexpand.man\fR
+mpexpand
+.RE
+.PP
+nroff
+.RS
+.TP
+\fBdoctools.man\fR
+doctools
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.TP
+\fBmpexpand.man\fR
+mpexpand
+.RE
+.PP
+plugin
+.RS
+.TP
+\fBdocidx_plugin_apiref.man\fR
+docidx_plugin_apiref
+.TP
+\fBdoctoc_plugin_apiref.man\fR
+doctoc_plugin_apiref
+.RE
+.PP
+semantic markup
+.RS
+.TP
+\fBdocidx_intro.man\fR
+docidx_intro
+.TP
+\fBdocidx_lang_cmdref.man\fR
+docidx_lang_cmdref
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdocidx_lang_intro.man\fR
+docidx_lang_intro
+.TP
+\fBdocidx_lang_syntax.man\fR
+docidx_lang_syntax
+.TP
+\fBdocidx_plugin_apiref.man\fR
+docidx_plugin_apiref
+.TP
+\fBdoctoc_intro.man\fR
+doctoc_intro
+.TP
+\fBdoctoc_lang_cmdref.man\fR
+doctoc_lang_cmdref
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctoc_lang_intro.man\fR
+doctoc_lang_intro
+.TP
+\fBdoctoc_lang_syntax.man\fR
+doctoc_lang_syntax
+.TP
+\fBdoctoc_plugin_apiref.man\fR
+doctoc_plugin_apiref
+.TP
+\fBdoctools_intro.man\fR
+doctools_intro
+.TP
+\fBdoctools_lang_cmdref.man\fR
+doctools_lang_cmdref
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.TP
+\fBdoctools_lang_intro.man\fR
+doctools_lang_intro
+.TP
+\fBdoctools_lang_syntax.man\fR
+doctools_lang_syntax
+.TP
+\fBdoctools_plugin_apiref.man\fR
+doctools_plugin_apiref
+.RE
+.PP
+table of contents
+.RS
+.TP
+\fBdoctoc_intro.man\fR
+doctoc_intro
+.TP
+\fBdoctoc_plugin_apiref.man\fR
+doctoc_plugin_apiref
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.RE
+.PP
+TMML
+.RS
+.TP
+\fBdoctools.man\fR
+doctools
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.TP
+\fBmpexpand.man\fR
+mpexpand
+.RE
+.PP
+toc
+.RS
+.TP
+\fBdoctoc_intro.man\fR
+doctoc_intro
+.TP
+\fBdoctoc_plugin_apiref.man\fR
+doctoc_plugin_apiref
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.RE
+.PP
+toc formatter
+.RS
+.TP
+\fBdoctoc_plugin_apiref.man\fR
+doctoc_plugin_apiref
+.RE
+.PP
+web
+.RS
+.TP
+\fBhttp://tcllib.sourceforge.net/doc/docidx_lang_intro.html\fR
+docidx language introduction
+.RE
+.PP
+wiki
+.RS
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.RE
+.PP
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/nroff-inlined/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/nroff-inlined/1_nokeys
new file mode 100644
index 0000000..399a61e
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/nroff-inlined/1_nokeys
@@ -0,0 +1,4 @@
+.TH KWIC
+.SH INDEX
+INDEX
+.RS
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/nroff-inlined/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/nroff-inlined/2_justkeys
new file mode 100644
index 0000000..4e1899e
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/nroff-inlined/2_justkeys
@@ -0,0 +1,135 @@
+.TH "KEYWORD INDEX"
+.SH INDEX
+.RS
+changelog
+.RS
+.RE
+conversion
+.RS
+.RE
+cvs
+.RS
+.RE
+cvs log
+.RS
+.RE
+docidx
+.RS
+.RE
+docidx commands
+.RS
+.RE
+docidx language
+.RS
+.RE
+docidx markup
+.RS
+.RE
+docidx syntax
+.RS
+.RE
+doctoc
+.RS
+.RE
+doctoc commands
+.RS
+.RE
+doctoc language
+.RS
+.RE
+doctoc markup
+.RS
+.RE
+doctoc syntax
+.RS
+.RE
+doctools
+.RS
+.RE
+doctools commands
+.RS
+.RE
+doctools language
+.RS
+.RE
+doctools markup
+.RS
+.RE
+doctools syntax
+.RS
+.RE
+document
+.RS
+.RE
+documentation
+.RS
+.RE
+emacs
+.RS
+.RE
+examples
+.RS
+.RE
+faq
+.RS
+.RE
+formatter
+.RS
+.RE
+formatting engine
+.RS
+.RE
+HTML
+.RS
+.RE
+index
+.RS
+.RE
+index formatter
+.RS
+.RE
+keyword index
+.RS
+.RE
+keywords
+.RS
+.RE
+latex
+.RS
+.RE
+log
+.RS
+.RE
+manpage
+.RS
+.RE
+markup
+.RS
+.RE
+nroff
+.RS
+.RE
+plugin
+.RS
+.RE
+semantic markup
+.RS
+.RE
+table of contents
+.RS
+.RE
+TMML
+.RS
+.RE
+toc
+.RS
+.RE
+toc formatter
+.RS
+.RE
+web
+.RS
+.RE
+wiki
+.RS
+.RE
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/nroff-inlined/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/nroff-inlined/3_kwic
new file mode 100644
index 0000000..bfc5ebe
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/nroff-inlined/3_kwic
@@ -0,0 +1,659 @@
+.TH "KEYWORD INDEX"
+.SH INDEX
+.RS
+changelog
+.RS
+.TP
+\fBchangelog.man\fR
+doctools::changelog
+.TP
+\fBcvs.man\fR
+doctools::cvs
+.RE
+.PP
+conversion
+.RS
+.TP
+\fBdoctools.man\fR
+doctools
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.TP
+\fBmpexpand.man\fR
+mpexpand
+.RE
+.PP
+cvs
+.RS
+.TP
+\fBcvs.man\fR
+doctools::cvs
+.RE
+.PP
+cvs log
+.RS
+.TP
+\fBcvs.man\fR
+doctools::cvs
+.RE
+.PP
+docidx
+.RS
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.RE
+.PP
+docidx commands
+.RS
+.TP
+\fBdocidx_lang_cmdref.man\fR
+docidx_lang_cmdref
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdocidx_lang_intro.man\fR
+docidx_lang_intro
+.TP
+\fBdocidx_lang_syntax.man\fR
+docidx_lang_syntax
+.RE
+.PP
+docidx language
+.RS
+.TP
+\fBdocidx_lang_cmdref.man\fR
+docidx_lang_cmdref
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdocidx_lang_intro.man\fR
+docidx_lang_intro
+.TP
+\fBdocidx_lang_syntax.man\fR
+docidx_lang_syntax
+.RE
+.PP
+docidx markup
+.RS
+.TP
+\fBdocidx_lang_cmdref.man\fR
+docidx_lang_cmdref
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdocidx_lang_intro.man\fR
+docidx_lang_intro
+.TP
+\fBdocidx_lang_syntax.man\fR
+docidx_lang_syntax
+.RE
+.PP
+docidx syntax
+.RS
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdocidx_lang_intro.man\fR
+docidx_lang_intro
+.TP
+\fBdocidx_lang_syntax.man\fR
+docidx_lang_syntax
+.RE
+.PP
+doctoc
+.RS
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.RE
+.PP
+doctoc commands
+.RS
+.TP
+\fBdoctoc_lang_cmdref.man\fR
+doctoc_lang_cmdref
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctoc_lang_intro.man\fR
+doctoc_lang_intro
+.TP
+\fBdoctoc_lang_syntax.man\fR
+doctoc_lang_syntax
+.RE
+.PP
+doctoc language
+.RS
+.TP
+\fBdoctoc_lang_cmdref.man\fR
+doctoc_lang_cmdref
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctoc_lang_intro.man\fR
+doctoc_lang_intro
+.TP
+\fBdoctoc_lang_syntax.man\fR
+doctoc_lang_syntax
+.RE
+.PP
+doctoc markup
+.RS
+.TP
+\fBdoctoc_lang_cmdref.man\fR
+doctoc_lang_cmdref
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctoc_lang_intro.man\fR
+doctoc_lang_intro
+.TP
+\fBdoctoc_lang_syntax.man\fR
+doctoc_lang_syntax
+.RE
+.PP
+doctoc syntax
+.RS
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctoc_lang_intro.man\fR
+doctoc_lang_intro
+.TP
+\fBdoctoc_lang_syntax.man\fR
+doctoc_lang_syntax
+.RE
+.PP
+doctools
+.RS
+.TP
+\fBchangelog.man\fR
+doctools::changelog
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.RE
+.PP
+doctools commands
+.RS
+.TP
+\fBdoctools_lang_cmdref.man\fR
+doctools_lang_cmdref
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.TP
+\fBdoctools_lang_intro.man\fR
+doctools_lang_intro
+.TP
+\fBdoctools_lang_syntax.man\fR
+doctools_lang_syntax
+.RE
+.PP
+doctools language
+.RS
+.TP
+\fBdoctools_lang_cmdref.man\fR
+doctools_lang_cmdref
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.TP
+\fBdoctools_lang_intro.man\fR
+doctools_lang_intro
+.TP
+\fBdoctools_lang_syntax.man\fR
+doctools_lang_syntax
+.RE
+.PP
+doctools markup
+.RS
+.TP
+\fBdoctools_lang_cmdref.man\fR
+doctools_lang_cmdref
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.TP
+\fBdoctools_lang_intro.man\fR
+doctools_lang_intro
+.TP
+\fBdoctools_lang_syntax.man\fR
+doctools_lang_syntax
+.RE
+.PP
+doctools syntax
+.RS
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.TP
+\fBdoctools_lang_intro.man\fR
+doctools_lang_intro
+.TP
+\fBdoctools_lang_syntax.man\fR
+doctools_lang_syntax
+.RE
+.PP
+document
+.RS
+.TP
+\fBdoctools_plugin_apiref.man\fR
+doctools_plugin_apiref
+.RE
+.PP
+documentation
+.RS
+.TP
+\fBdoctools.man\fR
+doctools
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.RE
+.PP
+emacs
+.RS
+.TP
+\fBchangelog.man\fR
+doctools::changelog
+.TP
+\fBcvs.man\fR
+doctools::cvs
+.RE
+.PP
+examples
+.RS
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.RE
+.PP
+faq
+.RS
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.RE
+.PP
+formatter
+.RS
+.TP
+\fBdoctools_plugin_apiref.man\fR
+doctools_plugin_apiref
+.RE
+.PP
+formatting engine
+.RS
+.TP
+\fBdocidx_plugin_apiref.man\fR
+docidx_plugin_apiref
+.TP
+\fBdoctoc_plugin_apiref.man\fR
+doctoc_plugin_apiref
+.TP
+\fBdoctools_plugin_apiref.man\fR
+doctools_plugin_apiref
+.RE
+.PP
+HTML
+.RS
+.TP
+\fBdoctools.man\fR
+doctools
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.TP
+\fBmpexpand.man\fR
+mpexpand
+.RE
+.PP
+index
+.RS
+.TP
+\fBdocidx_intro.man\fR
+docidx_intro
+.TP
+\fBdocidx_plugin_apiref.man\fR
+docidx_plugin_apiref
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.RE
+.PP
+index formatter
+.RS
+.TP
+\fBdocidx_plugin_apiref.man\fR
+docidx_plugin_apiref
+.RE
+.PP
+keyword index
+.RS
+.TP
+\fBdocidx_intro.man\fR
+docidx_intro
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.RE
+.PP
+keywords
+.RS
+.TP
+\fBdocidx_plugin_apiref.man\fR
+docidx_plugin_apiref
+.RE
+.PP
+latex
+.RS
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.RE
+.PP
+log
+.RS
+.TP
+\fBcvs.man\fR
+doctools::cvs
+.RE
+.PP
+manpage
+.RS
+.TP
+\fBdoctools.man\fR
+doctools
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.TP
+\fBdoctools_plugin_apiref.man\fR
+doctools_plugin_apiref
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.TP
+\fBmpexpand.man\fR
+mpexpand
+.RE
+.PP
+markup
+.RS
+.TP
+\fBdocidx_intro.man\fR
+docidx_intro
+.TP
+\fBdocidx_lang_cmdref.man\fR
+docidx_lang_cmdref
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdocidx_lang_intro.man\fR
+docidx_lang_intro
+.TP
+\fBdocidx_lang_syntax.man\fR
+docidx_lang_syntax
+.TP
+\fBdocidx_plugin_apiref.man\fR
+docidx_plugin_apiref
+.TP
+\fBdoctoc_intro.man\fR
+doctoc_intro
+.TP
+\fBdoctoc_lang_cmdref.man\fR
+doctoc_lang_cmdref
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctoc_lang_intro.man\fR
+doctoc_lang_intro
+.TP
+\fBdoctoc_lang_syntax.man\fR
+doctoc_lang_syntax
+.TP
+\fBdoctoc_plugin_apiref.man\fR
+doctoc_plugin_apiref
+.TP
+\fBdoctools.man\fR
+doctools
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.TP
+\fBdoctools_intro.man\fR
+doctools_intro
+.TP
+\fBdoctools_lang_cmdref.man\fR
+doctools_lang_cmdref
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.TP
+\fBdoctools_lang_intro.man\fR
+doctools_lang_intro
+.TP
+\fBdoctools_lang_syntax.man\fR
+doctools_lang_syntax
+.TP
+\fBdoctools_plugin_apiref.man\fR
+doctools_plugin_apiref
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.TP
+\fBmpexpand.man\fR
+mpexpand
+.RE
+.PP
+nroff
+.RS
+.TP
+\fBdoctools.man\fR
+doctools
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.TP
+\fBmpexpand.man\fR
+mpexpand
+.RE
+.PP
+plugin
+.RS
+.TP
+\fBdocidx_plugin_apiref.man\fR
+docidx_plugin_apiref
+.TP
+\fBdoctoc_plugin_apiref.man\fR
+doctoc_plugin_apiref
+.RE
+.PP
+semantic markup
+.RS
+.TP
+\fBdocidx_intro.man\fR
+docidx_intro
+.TP
+\fBdocidx_lang_cmdref.man\fR
+docidx_lang_cmdref
+.TP
+\fBdocidx_lang_faq.man\fR
+docidx_lang_faq
+.TP
+\fBdocidx_lang_intro.man\fR
+docidx_lang_intro
+.TP
+\fBdocidx_lang_syntax.man\fR
+docidx_lang_syntax
+.TP
+\fBdocidx_plugin_apiref.man\fR
+docidx_plugin_apiref
+.TP
+\fBdoctoc_intro.man\fR
+doctoc_intro
+.TP
+\fBdoctoc_lang_cmdref.man\fR
+doctoc_lang_cmdref
+.TP
+\fBdoctoc_lang_faq.man\fR
+doctoc_lang_faq
+.TP
+\fBdoctoc_lang_intro.man\fR
+doctoc_lang_intro
+.TP
+\fBdoctoc_lang_syntax.man\fR
+doctoc_lang_syntax
+.TP
+\fBdoctoc_plugin_apiref.man\fR
+doctoc_plugin_apiref
+.TP
+\fBdoctools_intro.man\fR
+doctools_intro
+.TP
+\fBdoctools_lang_cmdref.man\fR
+doctools_lang_cmdref
+.TP
+\fBdoctools_lang_faq.man\fR
+doctools_lang_faq
+.TP
+\fBdoctools_lang_intro.man\fR
+doctools_lang_intro
+.TP
+\fBdoctools_lang_syntax.man\fR
+doctools_lang_syntax
+.TP
+\fBdoctools_plugin_apiref.man\fR
+doctools_plugin_apiref
+.RE
+.PP
+table of contents
+.RS
+.TP
+\fBdoctoc_intro.man\fR
+doctoc_intro
+.TP
+\fBdoctoc_plugin_apiref.man\fR
+doctoc_plugin_apiref
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.RE
+.PP
+TMML
+.RS
+.TP
+\fBdoctools.man\fR
+doctools
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.TP
+\fBapps/dtplite.man\fR
+dtplite
+.TP
+\fBmpexpand.man\fR
+mpexpand
+.RE
+.PP
+toc
+.RS
+.TP
+\fBdoctoc_intro.man\fR
+doctoc_intro
+.TP
+\fBdoctoc_plugin_apiref.man\fR
+doctoc_plugin_apiref
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.RE
+.PP
+toc formatter
+.RS
+.TP
+\fBdoctoc_plugin_apiref.man\fR
+doctoc_plugin_apiref
+.RE
+.PP
+web
+.RS
+.TP
+\fBhttp://tcllib.sourceforge.net/doc/docidx_lang_intro.html\fR
+docidx language introduction
+.RE
+.PP
+wiki
+.RS
+.TP
+\fBdocidx.man\fR
+doctools::idx
+.TP
+\fBdoctoc.man\fR
+doctools::toc
+.RE
+.PP
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/serial-print/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/serial-print/1_nokeys
new file mode 100644
index 0000000..2507117
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/serial-print/1_nokeys
@@ -0,0 +1 @@
+doctools::idx KWIC INDEX
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/serial-print/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/serial-print/2_justkeys
new file mode 100644
index 0000000..ae799f0
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/serial-print/2_justkeys
@@ -0,0 +1,45 @@
+doctools::idx {Keyword Index} {}
+....changelog
+....conversion
+....cvs
+....cvs log
+....docidx
+....docidx commands
+....docidx language
+....docidx markup
+....docidx syntax
+....doctoc
+....doctoc commands
+....doctoc language
+....doctoc markup
+....doctoc syntax
+....doctools
+....doctools commands
+....doctools language
+....doctools markup
+....doctools syntax
+....document
+....documentation
+....emacs
+....examples
+....faq
+....formatter
+....formatting engine
+....HTML
+....index
+....index formatter
+....keyword index
+....keywords
+....latex
+....log
+....manpage
+....markup
+....nroff
+....plugin
+....semantic markup
+....table of contents
+....TMML
+....toc
+....toc formatter
+....web
+....wiki
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/serial-print/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/serial-print/3_kwic
new file mode 100644
index 0000000..4000f07
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/serial-print/3_kwic
@@ -0,0 +1,205 @@
+doctools::idx {Keyword Index} {}
+....changelog
+........manpage doctools::changelog changelog.man
+........manpage doctools::cvs cvs.man
+....conversion
+........manpage doctools doctools.man
+........manpage doctools::idx docidx.man
+........manpage doctools::toc doctoc.man
+........manpage dtplite apps/dtplite.man
+........manpage mpexpand mpexpand.man
+....cvs
+........manpage doctools::cvs cvs.man
+....cvs log
+........manpage doctools::cvs cvs.man
+....docidx
+........manpage doctools::idx docidx.man
+........manpage dtplite apps/dtplite.man
+....docidx commands
+........manpage docidx_lang_cmdref docidx_lang_cmdref.man
+........manpage docidx_lang_faq docidx_lang_faq.man
+........manpage docidx_lang_intro docidx_lang_intro.man
+........manpage docidx_lang_syntax docidx_lang_syntax.man
+....docidx language
+........manpage docidx_lang_cmdref docidx_lang_cmdref.man
+........manpage docidx_lang_faq docidx_lang_faq.man
+........manpage docidx_lang_intro docidx_lang_intro.man
+........manpage docidx_lang_syntax docidx_lang_syntax.man
+....docidx markup
+........manpage docidx_lang_cmdref docidx_lang_cmdref.man
+........manpage docidx_lang_faq docidx_lang_faq.man
+........manpage docidx_lang_intro docidx_lang_intro.man
+........manpage docidx_lang_syntax docidx_lang_syntax.man
+....docidx syntax
+........manpage docidx_lang_faq docidx_lang_faq.man
+........manpage docidx_lang_intro docidx_lang_intro.man
+........manpage docidx_lang_syntax docidx_lang_syntax.man
+....doctoc
+........manpage doctools::toc doctoc.man
+........manpage dtplite apps/dtplite.man
+....doctoc commands
+........manpage doctoc_lang_cmdref doctoc_lang_cmdref.man
+........manpage doctoc_lang_faq doctoc_lang_faq.man
+........manpage doctoc_lang_intro doctoc_lang_intro.man
+........manpage doctoc_lang_syntax doctoc_lang_syntax.man
+....doctoc language
+........manpage doctoc_lang_cmdref doctoc_lang_cmdref.man
+........manpage doctoc_lang_faq doctoc_lang_faq.man
+........manpage doctoc_lang_intro doctoc_lang_intro.man
+........manpage doctoc_lang_syntax doctoc_lang_syntax.man
+....doctoc markup
+........manpage doctoc_lang_cmdref doctoc_lang_cmdref.man
+........manpage doctoc_lang_faq doctoc_lang_faq.man
+........manpage doctoc_lang_intro doctoc_lang_intro.man
+........manpage doctoc_lang_syntax doctoc_lang_syntax.man
+....doctoc syntax
+........manpage doctoc_lang_faq doctoc_lang_faq.man
+........manpage doctoc_lang_intro doctoc_lang_intro.man
+........manpage doctoc_lang_syntax doctoc_lang_syntax.man
+....doctools
+........manpage doctools::changelog changelog.man
+........manpage dtplite apps/dtplite.man
+....doctools commands
+........manpage doctools_lang_cmdref doctools_lang_cmdref.man
+........manpage doctools_lang_faq doctools_lang_faq.man
+........manpage doctools_lang_intro doctools_lang_intro.man
+........manpage doctools_lang_syntax doctools_lang_syntax.man
+....doctools language
+........manpage doctools_lang_cmdref doctools_lang_cmdref.man
+........manpage doctools_lang_faq doctools_lang_faq.man
+........manpage doctools_lang_intro doctools_lang_intro.man
+........manpage doctools_lang_syntax doctools_lang_syntax.man
+....doctools markup
+........manpage doctools_lang_cmdref doctools_lang_cmdref.man
+........manpage doctools_lang_faq doctools_lang_faq.man
+........manpage doctools_lang_intro doctools_lang_intro.man
+........manpage doctools_lang_syntax doctools_lang_syntax.man
+....doctools syntax
+........manpage doctools_lang_faq doctools_lang_faq.man
+........manpage doctools_lang_intro doctools_lang_intro.man
+........manpage doctools_lang_syntax doctools_lang_syntax.man
+....document
+........manpage doctools_plugin_apiref doctools_plugin_apiref.man
+....documentation
+........manpage doctools doctools.man
+........manpage doctools::idx docidx.man
+........manpage doctools::toc doctoc.man
+....emacs
+........manpage doctools::changelog changelog.man
+........manpage doctools::cvs cvs.man
+....examples
+........manpage docidx_lang_faq docidx_lang_faq.man
+........manpage doctoc_lang_faq doctoc_lang_faq.man
+........manpage doctools_lang_faq doctools_lang_faq.man
+....faq
+........manpage docidx_lang_faq docidx_lang_faq.man
+........manpage doctoc_lang_faq doctoc_lang_faq.man
+........manpage doctools_lang_faq doctools_lang_faq.man
+....formatter
+........manpage doctools_plugin_apiref doctools_plugin_apiref.man
+....formatting engine
+........manpage docidx_plugin_apiref docidx_plugin_apiref.man
+........manpage doctoc_plugin_apiref doctoc_plugin_apiref.man
+........manpage doctools_plugin_apiref doctools_plugin_apiref.man
+....HTML
+........manpage doctools doctools.man
+........manpage doctools::idx docidx.man
+........manpage doctools::toc doctoc.man
+........manpage dtplite apps/dtplite.man
+........manpage mpexpand mpexpand.man
+....index
+........manpage docidx_intro docidx_intro.man
+........manpage docidx_plugin_apiref docidx_plugin_apiref.man
+........manpage doctools::idx docidx.man
+....index formatter
+........manpage docidx_plugin_apiref docidx_plugin_apiref.man
+....keyword index
+........manpage docidx_intro docidx_intro.man
+........manpage doctools::idx docidx.man
+....keywords
+........manpage docidx_plugin_apiref docidx_plugin_apiref.man
+....latex
+........manpage doctools::idx docidx.man
+........manpage doctools::toc doctoc.man
+....log
+........manpage doctools::cvs cvs.man
+....manpage
+........manpage doctools doctools.man
+........manpage doctools::idx docidx.man
+........manpage doctools::toc doctoc.man
+........manpage doctools_plugin_apiref doctools_plugin_apiref.man
+........manpage dtplite apps/dtplite.man
+........manpage mpexpand mpexpand.man
+....markup
+........manpage docidx_intro docidx_intro.man
+........manpage docidx_lang_cmdref docidx_lang_cmdref.man
+........manpage docidx_lang_faq docidx_lang_faq.man
+........manpage docidx_lang_intro docidx_lang_intro.man
+........manpage docidx_lang_syntax docidx_lang_syntax.man
+........manpage docidx_plugin_apiref docidx_plugin_apiref.man
+........manpage doctoc_intro doctoc_intro.man
+........manpage doctoc_lang_cmdref doctoc_lang_cmdref.man
+........manpage doctoc_lang_faq doctoc_lang_faq.man
+........manpage doctoc_lang_intro doctoc_lang_intro.man
+........manpage doctoc_lang_syntax doctoc_lang_syntax.man
+........manpage doctoc_plugin_apiref doctoc_plugin_apiref.man
+........manpage doctools doctools.man
+........manpage doctools::idx docidx.man
+........manpage doctools::toc doctoc.man
+........manpage doctools_intro doctools_intro.man
+........manpage doctools_lang_cmdref doctools_lang_cmdref.man
+........manpage doctools_lang_faq doctools_lang_faq.man
+........manpage doctools_lang_intro doctools_lang_intro.man
+........manpage doctools_lang_syntax doctools_lang_syntax.man
+........manpage doctools_plugin_apiref doctools_plugin_apiref.man
+........manpage dtplite apps/dtplite.man
+........manpage mpexpand mpexpand.man
+....nroff
+........manpage doctools doctools.man
+........manpage doctools::idx docidx.man
+........manpage doctools::toc doctoc.man
+........manpage dtplite apps/dtplite.man
+........manpage mpexpand mpexpand.man
+....plugin
+........manpage docidx_plugin_apiref docidx_plugin_apiref.man
+........manpage doctoc_plugin_apiref doctoc_plugin_apiref.man
+....semantic markup
+........manpage docidx_intro docidx_intro.man
+........manpage docidx_lang_cmdref docidx_lang_cmdref.man
+........manpage docidx_lang_faq docidx_lang_faq.man
+........manpage docidx_lang_intro docidx_lang_intro.man
+........manpage docidx_lang_syntax docidx_lang_syntax.man
+........manpage docidx_plugin_apiref docidx_plugin_apiref.man
+........manpage doctoc_intro doctoc_intro.man
+........manpage doctoc_lang_cmdref doctoc_lang_cmdref.man
+........manpage doctoc_lang_faq doctoc_lang_faq.man
+........manpage doctoc_lang_intro doctoc_lang_intro.man
+........manpage doctoc_lang_syntax doctoc_lang_syntax.man
+........manpage doctoc_plugin_apiref doctoc_plugin_apiref.man
+........manpage doctools_intro doctools_intro.man
+........manpage doctools_lang_cmdref doctools_lang_cmdref.man
+........manpage doctools_lang_faq doctools_lang_faq.man
+........manpage doctools_lang_intro doctools_lang_intro.man
+........manpage doctools_lang_syntax doctools_lang_syntax.man
+........manpage doctools_plugin_apiref doctools_plugin_apiref.man
+....table of contents
+........manpage doctoc_intro doctoc_intro.man
+........manpage doctoc_plugin_apiref doctoc_plugin_apiref.man
+........manpage doctools::toc doctoc.man
+....TMML
+........manpage doctools doctools.man
+........manpage doctools::idx docidx.man
+........manpage doctools::toc doctoc.man
+........manpage dtplite apps/dtplite.man
+........manpage mpexpand mpexpand.man
+....toc
+........manpage doctoc_intro doctoc_intro.man
+........manpage doctoc_plugin_apiref doctoc_plugin_apiref.man
+........manpage doctools::toc doctoc.man
+....toc formatter
+........manpage doctoc_plugin_apiref doctoc_plugin_apiref.man
+....web
+........url {docidx language introduction} http://tcllib.sourceforge.net/doc/docidx_lang_intro.html
+....wiki
+........manpage doctools::idx docidx.man
+........manpage doctools::toc doctoc.man
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/serial/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/serial/1_nokeys
new file mode 100644
index 0000000..25370d0
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/serial/1_nokeys
@@ -0,0 +1 @@
+doctools::idx {label KWIC keywords {} references {} title INDEX}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/serial/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/serial/2_justkeys
new file mode 100644
index 0000000..81935e8
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/serial/2_justkeys
@@ -0,0 +1 @@
+doctools::idx {label {Keyword Index} keywords {changelog {} conversion {} cvs {} {cvs log} {} docidx {} {docidx commands} {} {docidx language} {} {docidx markup} {} {docidx syntax} {} doctoc {} {doctoc commands} {} {doctoc language} {} {doctoc markup} {} {doctoc syntax} {} doctools {} {doctools commands} {} {doctools language} {} {doctools markup} {} {doctools syntax} {} document {} documentation {} emacs {} examples {} faq {} formatter {} {formatting engine} {} HTML {} index {} {index formatter} {} {keyword index} {} keywords {} latex {} log {} manpage {} markup {} nroff {} plugin {} {semantic markup} {} {table of contents} {} TMML {} toc {} {toc formatter} {} web {} wiki {}} references {} title {}}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/serial/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/serial/3_kwic
new file mode 100644
index 0000000..110e92e
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/serial/3_kwic
@@ -0,0 +1 @@
+doctools::idx {label {Keyword Index} keywords {changelog {changelog.man cvs.man} conversion {doctools.man docidx.man doctoc.man apps/dtplite.man mpexpand.man} cvs cvs.man {cvs log} cvs.man docidx {docidx.man apps/dtplite.man} {docidx commands} {docidx_lang_cmdref.man docidx_lang_faq.man docidx_lang_intro.man docidx_lang_syntax.man} {docidx language} {docidx_lang_cmdref.man docidx_lang_faq.man docidx_lang_intro.man docidx_lang_syntax.man} {docidx markup} {docidx_lang_cmdref.man docidx_lang_faq.man docidx_lang_intro.man docidx_lang_syntax.man} {docidx syntax} {docidx_lang_faq.man docidx_lang_intro.man docidx_lang_syntax.man} doctoc {doctoc.man apps/dtplite.man} {doctoc commands} {doctoc_lang_cmdref.man doctoc_lang_faq.man doctoc_lang_intro.man doctoc_lang_syntax.man} {doctoc language} {doctoc_lang_cmdref.man doctoc_lang_faq.man doctoc_lang_intro.man doctoc_lang_syntax.man} {doctoc markup} {doctoc_lang_cmdref.man doctoc_lang_faq.man doctoc_lang_intro.man doctoc_lang_syntax.man} {doctoc syntax} {doctoc_lang_faq.man doctoc_lang_intro.man doctoc_lang_syntax.man} doctools {changelog.man apps/dtplite.man} {doctools commands} {doctools_lang_cmdref.man doctools_lang_faq.man doctools_lang_intro.man doctools_lang_syntax.man} {doctools language} {doctools_lang_cmdref.man doctools_lang_faq.man doctools_lang_intro.man doctools_lang_syntax.man} {doctools markup} {doctools_lang_cmdref.man doctools_lang_faq.man doctools_lang_intro.man doctools_lang_syntax.man} {doctools syntax} {doctools_lang_faq.man doctools_lang_intro.man doctools_lang_syntax.man} document doctools_plugin_apiref.man documentation {doctools.man docidx.man doctoc.man} emacs {changelog.man cvs.man} examples {docidx_lang_faq.man doctoc_lang_faq.man doctools_lang_faq.man} faq {docidx_lang_faq.man doctoc_lang_faq.man doctools_lang_faq.man} formatter doctools_plugin_apiref.man {formatting engine} {docidx_plugin_apiref.man doctoc_plugin_apiref.man doctools_plugin_apiref.man} HTML {doctools.man docidx.man doctoc.man apps/dtplite.man mpexpand.man} index {docidx_intro.man docidx_plugin_apiref.man docidx.man} {index formatter} docidx_plugin_apiref.man {keyword index} {docidx_intro.man docidx.man} keywords docidx_plugin_apiref.man latex {docidx.man doctoc.man} log cvs.man manpage {doctools.man docidx.man doctoc.man doctools_plugin_apiref.man apps/dtplite.man mpexpand.man} markup {docidx_intro.man docidx_lang_cmdref.man docidx_lang_faq.man docidx_lang_intro.man docidx_lang_syntax.man docidx_plugin_apiref.man doctoc_intro.man doctoc_lang_cmdref.man doctoc_lang_faq.man doctoc_lang_intro.man doctoc_lang_syntax.man doctoc_plugin_apiref.man doctools.man docidx.man doctoc.man doctools_intro.man doctools_lang_cmdref.man doctools_lang_faq.man doctools_lang_intro.man doctools_lang_syntax.man doctools_plugin_apiref.man apps/dtplite.man mpexpand.man} nroff {doctools.man docidx.man doctoc.man apps/dtplite.man mpexpand.man} plugin {docidx_plugin_apiref.man doctoc_plugin_apiref.man} {semantic markup} {docidx_intro.man docidx_lang_cmdref.man docidx_lang_faq.man docidx_lang_intro.man docidx_lang_syntax.man docidx_plugin_apiref.man doctoc_intro.man doctoc_lang_cmdref.man doctoc_lang_faq.man doctoc_lang_intro.man doctoc_lang_syntax.man doctoc_plugin_apiref.man doctools_intro.man doctools_lang_cmdref.man doctools_lang_faq.man doctools_lang_intro.man doctools_lang_syntax.man doctools_plugin_apiref.man} {table of contents} {doctoc_intro.man doctoc_plugin_apiref.man doctoc.man} TMML {doctools.man docidx.man doctoc.man apps/dtplite.man mpexpand.man} toc {doctoc_intro.man doctoc_plugin_apiref.man doctoc.man} {toc formatter} doctoc_plugin_apiref.man web http://tcllib.sourceforge.net/doc/docidx_lang_intro.html wiki {docidx.man doctoc.man}} references {apps/dtplite.man {manpage dtplite} changelog.man {manpage doctools::changelog} cvs.man {manpage doctools::cvs} docidx.man {manpage doctools::idx} docidx_intro.man {manpage docidx_intro} docidx_lang_cmdref.man {manpage docidx_lang_cmdref} docidx_lang_faq.man {manpage docidx_lang_faq} docidx_lang_intro.man {manpage docidx_lang_intro} docidx_lang_syntax.man {manpage docidx_lang_syntax} docidx_plugin_apiref.man {manpage docidx_plugin_apiref} doctoc.man {manpage doctools::toc} doctoc_intro.man {manpage doctoc_intro} doctoc_lang_cmdref.man {manpage doctoc_lang_cmdref} doctoc_lang_faq.man {manpage doctoc_lang_faq} doctoc_lang_intro.man {manpage doctoc_lang_intro} doctoc_lang_syntax.man {manpage doctoc_lang_syntax} doctoc_plugin_apiref.man {manpage doctoc_plugin_apiref} doctools.man {manpage doctools} doctools_intro.man {manpage doctools_intro} doctools_lang_cmdref.man {manpage doctools_lang_cmdref} doctools_lang_faq.man {manpage doctools_lang_faq} doctools_lang_intro.man {manpage doctools_lang_intro} doctools_lang_syntax.man {manpage doctools_lang_syntax} doctools_plugin_apiref.man {manpage doctools_plugin_apiref} http://tcllib.sourceforge.net/doc/docidx_lang_intro.html {url {docidx language introduction}} mpexpand.man {manpage mpexpand}} title {}}
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/text/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/text/1_nokeys
new file mode 100644
index 0000000..6c91911
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/text/1_nokeys
@@ -0,0 +1,2 @@
+KWIC -- INDEX
+============= \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/text/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/text/2_justkeys
new file mode 100644
index 0000000..368dd1a
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/text/2_justkeys
@@ -0,0 +1,136 @@
+Keyword Index
+=============
+
+changelog
+---------
+
+conversion
+----------
+
+cvs
+---
+
+cvs log
+-------
+
+docidx
+------
+
+docidx commands
+---------------
+
+docidx language
+---------------
+
+docidx markup
+-------------
+
+docidx syntax
+-------------
+
+doctoc
+------
+
+doctoc commands
+---------------
+
+doctoc language
+---------------
+
+doctoc markup
+-------------
+
+doctoc syntax
+-------------
+
+doctools
+--------
+
+doctools commands
+-----------------
+
+doctools language
+-----------------
+
+doctools markup
+---------------
+
+doctools syntax
+---------------
+
+document
+--------
+
+documentation
+-------------
+
+emacs
+-----
+
+examples
+--------
+
+faq
+---
+
+formatter
+---------
+
+formatting engine
+-----------------
+
+HTML
+----
+
+index
+-----
+
+index formatter
+---------------
+
+keyword index
+-------------
+
+keywords
+--------
+
+latex
+-----
+
+log
+---
+
+manpage
+-------
+
+markup
+------
+
+nroff
+-----
+
+plugin
+------
+
+semantic markup
+---------------
+
+table of contents
+-----------------
+
+TMML
+----
+
+toc
+---
+
+toc formatter
+-------------
+
+web
+---
+
+wiki
+----
+
+
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/text/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/text/3_kwic
new file mode 100644
index 0000000..e94e8a0
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/text/3_kwic
@@ -0,0 +1,294 @@
+Keyword Index
+=============
+
+changelog
+---------
+ doctools::changelog (changelog.man)
+ doctools::cvs (cvs.man)
+
+conversion
+----------
+ doctools (doctools.man)
+ doctools::idx (docidx.man)
+ doctools::toc (doctoc.man)
+ dtplite (apps/dtplite.man)
+ mpexpand (mpexpand.man)
+
+cvs
+---
+ doctools::cvs (cvs.man)
+
+cvs log
+-------
+ doctools::cvs (cvs.man)
+
+docidx
+------
+ doctools::idx (docidx.man)
+ dtplite (apps/dtplite.man)
+
+docidx commands
+---------------
+ docidx_lang_cmdref (docidx_lang_cmdref.man)
+ docidx_lang_faq (docidx_lang_faq.man)
+ docidx_lang_intro (docidx_lang_intro.man)
+ docidx_lang_syntax (docidx_lang_syntax.man)
+
+docidx language
+---------------
+ docidx_lang_cmdref (docidx_lang_cmdref.man)
+ docidx_lang_faq (docidx_lang_faq.man)
+ docidx_lang_intro (docidx_lang_intro.man)
+ docidx_lang_syntax (docidx_lang_syntax.man)
+
+docidx markup
+-------------
+ docidx_lang_cmdref (docidx_lang_cmdref.man)
+ docidx_lang_faq (docidx_lang_faq.man)
+ docidx_lang_intro (docidx_lang_intro.man)
+ docidx_lang_syntax (docidx_lang_syntax.man)
+
+docidx syntax
+-------------
+ docidx_lang_faq (docidx_lang_faq.man)
+ docidx_lang_intro (docidx_lang_intro.man)
+ docidx_lang_syntax (docidx_lang_syntax.man)
+
+doctoc
+------
+ doctools::toc (doctoc.man)
+ dtplite (apps/dtplite.man)
+
+doctoc commands
+---------------
+ doctoc_lang_cmdref (doctoc_lang_cmdref.man)
+ doctoc_lang_faq (doctoc_lang_faq.man)
+ doctoc_lang_intro (doctoc_lang_intro.man)
+ doctoc_lang_syntax (doctoc_lang_syntax.man)
+
+doctoc language
+---------------
+ doctoc_lang_cmdref (doctoc_lang_cmdref.man)
+ doctoc_lang_faq (doctoc_lang_faq.man)
+ doctoc_lang_intro (doctoc_lang_intro.man)
+ doctoc_lang_syntax (doctoc_lang_syntax.man)
+
+doctoc markup
+-------------
+ doctoc_lang_cmdref (doctoc_lang_cmdref.man)
+ doctoc_lang_faq (doctoc_lang_faq.man)
+ doctoc_lang_intro (doctoc_lang_intro.man)
+ doctoc_lang_syntax (doctoc_lang_syntax.man)
+
+doctoc syntax
+-------------
+ doctoc_lang_faq (doctoc_lang_faq.man)
+ doctoc_lang_intro (doctoc_lang_intro.man)
+ doctoc_lang_syntax (doctoc_lang_syntax.man)
+
+doctools
+--------
+ doctools::changelog (changelog.man)
+ dtplite (apps/dtplite.man)
+
+doctools commands
+-----------------
+ doctools_lang_cmdref (doctools_lang_cmdref.man)
+ doctools_lang_faq (doctools_lang_faq.man)
+ doctools_lang_intro (doctools_lang_intro.man)
+ doctools_lang_syntax (doctools_lang_syntax.man)
+
+doctools language
+-----------------
+ doctools_lang_cmdref (doctools_lang_cmdref.man)
+ doctools_lang_faq (doctools_lang_faq.man)
+ doctools_lang_intro (doctools_lang_intro.man)
+ doctools_lang_syntax (doctools_lang_syntax.man)
+
+doctools markup
+---------------
+ doctools_lang_cmdref (doctools_lang_cmdref.man)
+ doctools_lang_faq (doctools_lang_faq.man)
+ doctools_lang_intro (doctools_lang_intro.man)
+ doctools_lang_syntax (doctools_lang_syntax.man)
+
+doctools syntax
+---------------
+ doctools_lang_faq (doctools_lang_faq.man)
+ doctools_lang_intro (doctools_lang_intro.man)
+ doctools_lang_syntax (doctools_lang_syntax.man)
+
+document
+--------
+ doctools_plugin_apiref (doctools_plugin_apiref.man)
+
+documentation
+-------------
+ doctools (doctools.man)
+ doctools::idx (docidx.man)
+ doctools::toc (doctoc.man)
+
+emacs
+-----
+ doctools::changelog (changelog.man)
+ doctools::cvs (cvs.man)
+
+examples
+--------
+ docidx_lang_faq (docidx_lang_faq.man)
+ doctoc_lang_faq (doctoc_lang_faq.man)
+ doctools_lang_faq (doctools_lang_faq.man)
+
+faq
+---
+ docidx_lang_faq (docidx_lang_faq.man)
+ doctoc_lang_faq (doctoc_lang_faq.man)
+ doctools_lang_faq (doctools_lang_faq.man)
+
+formatter
+---------
+ doctools_plugin_apiref (doctools_plugin_apiref.man)
+
+formatting engine
+-----------------
+ docidx_plugin_apiref (docidx_plugin_apiref.man)
+ doctoc_plugin_apiref (doctoc_plugin_apiref.man)
+ doctools_plugin_apiref (doctools_plugin_apiref.man)
+
+HTML
+----
+ doctools (doctools.man)
+ doctools::idx (docidx.man)
+ doctools::toc (doctoc.man)
+ dtplite (apps/dtplite.man)
+ mpexpand (mpexpand.man)
+
+index
+-----
+ docidx_intro (docidx_intro.man)
+ docidx_plugin_apiref (docidx_plugin_apiref.man)
+ doctools::idx (docidx.man)
+
+index formatter
+---------------
+ docidx_plugin_apiref (docidx_plugin_apiref.man)
+
+keyword index
+-------------
+ docidx_intro (docidx_intro.man)
+ doctools::idx (docidx.man)
+
+keywords
+--------
+ docidx_plugin_apiref (docidx_plugin_apiref.man)
+
+latex
+-----
+ doctools::idx (docidx.man)
+ doctools::toc (doctoc.man)
+
+log
+---
+ doctools::cvs (cvs.man)
+
+manpage
+-------
+ doctools (doctools.man)
+ doctools::idx (docidx.man)
+ doctools::toc (doctoc.man)
+ doctools_plugin_apiref (doctools_plugin_apiref.man)
+ dtplite (apps/dtplite.man)
+ mpexpand (mpexpand.man)
+
+markup
+------
+ docidx_intro (docidx_intro.man)
+ docidx_lang_cmdref (docidx_lang_cmdref.man)
+ docidx_lang_faq (docidx_lang_faq.man)
+ docidx_lang_intro (docidx_lang_intro.man)
+ docidx_lang_syntax (docidx_lang_syntax.man)
+ docidx_plugin_apiref (docidx_plugin_apiref.man)
+ doctoc_intro (doctoc_intro.man)
+ doctoc_lang_cmdref (doctoc_lang_cmdref.man)
+ doctoc_lang_faq (doctoc_lang_faq.man)
+ doctoc_lang_intro (doctoc_lang_intro.man)
+ doctoc_lang_syntax (doctoc_lang_syntax.man)
+ doctoc_plugin_apiref (doctoc_plugin_apiref.man)
+ doctools (doctools.man)
+ doctools::idx (docidx.man)
+ doctools::toc (doctoc.man)
+ doctools_intro (doctools_intro.man)
+ doctools_lang_cmdref (doctools_lang_cmdref.man)
+ doctools_lang_faq (doctools_lang_faq.man)
+ doctools_lang_intro (doctools_lang_intro.man)
+ doctools_lang_syntax (doctools_lang_syntax.man)
+ doctools_plugin_apiref (doctools_plugin_apiref.man)
+ dtplite (apps/dtplite.man)
+ mpexpand (mpexpand.man)
+
+nroff
+-----
+ doctools (doctools.man)
+ doctools::idx (docidx.man)
+ doctools::toc (doctoc.man)
+ dtplite (apps/dtplite.man)
+ mpexpand (mpexpand.man)
+
+plugin
+------
+ docidx_plugin_apiref (docidx_plugin_apiref.man)
+ doctoc_plugin_apiref (doctoc_plugin_apiref.man)
+
+semantic markup
+---------------
+ docidx_intro (docidx_intro.man)
+ docidx_lang_cmdref (docidx_lang_cmdref.man)
+ docidx_lang_faq (docidx_lang_faq.man)
+ docidx_lang_intro (docidx_lang_intro.man)
+ docidx_lang_syntax (docidx_lang_syntax.man)
+ docidx_plugin_apiref (docidx_plugin_apiref.man)
+ doctoc_intro (doctoc_intro.man)
+ doctoc_lang_cmdref (doctoc_lang_cmdref.man)
+ doctoc_lang_faq (doctoc_lang_faq.man)
+ doctoc_lang_intro (doctoc_lang_intro.man)
+ doctoc_lang_syntax (doctoc_lang_syntax.man)
+ doctoc_plugin_apiref (doctoc_plugin_apiref.man)
+ doctools_intro (doctools_intro.man)
+ doctools_lang_cmdref (doctools_lang_cmdref.man)
+ doctools_lang_faq (doctools_lang_faq.man)
+ doctools_lang_intro (doctools_lang_intro.man)
+ doctools_lang_syntax (doctools_lang_syntax.man)
+ doctools_plugin_apiref (doctools_plugin_apiref.man)
+
+table of contents
+-----------------
+ doctoc_intro (doctoc_intro.man)
+ doctoc_plugin_apiref (doctoc_plugin_apiref.man)
+ doctools::toc (doctoc.man)
+
+TMML
+----
+ doctools (doctools.man)
+ doctools::idx (docidx.man)
+ doctools::toc (doctoc.man)
+ dtplite (apps/dtplite.man)
+ mpexpand (mpexpand.man)
+
+toc
+---
+ doctoc_intro (doctoc_intro.man)
+ doctoc_plugin_apiref (doctoc_plugin_apiref.man)
+ doctools::toc (doctoc.man)
+
+toc formatter
+-------------
+ doctoc_plugin_apiref (doctoc_plugin_apiref.man)
+
+web
+---
+ docidx language introduction (http://tcllib.sourceforge.net/doc/docidx_lang_intro.html)
+
+wiki
+----
+ doctools::idx (docidx.man)
+ doctools::toc (doctoc.man)
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/wiki-list/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/wiki-list/1_nokeys
new file mode 100644
index 0000000..a0edf96
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/wiki-list/1_nokeys
@@ -0,0 +1,3 @@
+**KWIC -- INDEX**
+
+<<TOC>>
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/wiki-list/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/wiki-list/2_justkeys
new file mode 100644
index 0000000..7791942
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/wiki-list/2_justkeys
@@ -0,0 +1,48 @@
+**Keyword Index**
+
+<<TOC>>
+
+***changelog***
+***conversion***
+***cvs***
+***cvs log***
+***docidx***
+***docidx commands***
+***docidx language***
+***docidx markup***
+***docidx syntax***
+***doctoc***
+***doctoc commands***
+***doctoc language***
+***doctoc markup***
+***doctoc syntax***
+***doctools***
+***doctools commands***
+***doctools language***
+***doctools markup***
+***doctools syntax***
+***document***
+***documentation***
+***emacs***
+***examples***
+***faq***
+***formatter***
+***formatting engine***
+***HTML***
+***index***
+***index formatter***
+***keyword index***
+***keywords***
+***latex***
+***log***
+***manpage***
+***markup***
+***nroff***
+***plugin***
+***semantic markup***
+***table of contents***
+***TMML***
+***toc***
+***toc formatter***
+***web***
+***wiki***
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/wiki-list/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/wiki-list/3_kwic
new file mode 100644
index 0000000..dac7812
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/wiki-list/3_kwic
@@ -0,0 +1,251 @@
+**Keyword Index**
+
+<<TOC>>
+
+***changelog***
+ * [changelog.man%|%doctools::changelog]
+ * [cvs.man%|%doctools::cvs]
+
+***conversion***
+ * [doctools.man%|%doctools]
+ * [docidx.man%|%doctools::idx]
+ * [doctoc.man%|%doctools::toc]
+ * [apps/dtplite.man%|%dtplite]
+ * [mpexpand.man%|%mpexpand]
+
+***cvs***
+ * [cvs.man%|%doctools::cvs]
+
+***cvs log***
+ * [cvs.man%|%doctools::cvs]
+
+***docidx***
+ * [docidx.man%|%doctools::idx]
+ * [apps/dtplite.man%|%dtplite]
+
+***docidx commands***
+ * [docidx_lang_cmdref.man%|%docidx_lang_cmdref]
+ * [docidx_lang_faq.man%|%docidx_lang_faq]
+ * [docidx_lang_intro.man%|%docidx_lang_intro]
+ * [docidx_lang_syntax.man%|%docidx_lang_syntax]
+
+***docidx language***
+ * [docidx_lang_cmdref.man%|%docidx_lang_cmdref]
+ * [docidx_lang_faq.man%|%docidx_lang_faq]
+ * [docidx_lang_intro.man%|%docidx_lang_intro]
+ * [docidx_lang_syntax.man%|%docidx_lang_syntax]
+
+***docidx markup***
+ * [docidx_lang_cmdref.man%|%docidx_lang_cmdref]
+ * [docidx_lang_faq.man%|%docidx_lang_faq]
+ * [docidx_lang_intro.man%|%docidx_lang_intro]
+ * [docidx_lang_syntax.man%|%docidx_lang_syntax]
+
+***docidx syntax***
+ * [docidx_lang_faq.man%|%docidx_lang_faq]
+ * [docidx_lang_intro.man%|%docidx_lang_intro]
+ * [docidx_lang_syntax.man%|%docidx_lang_syntax]
+
+***doctoc***
+ * [doctoc.man%|%doctools::toc]
+ * [apps/dtplite.man%|%dtplite]
+
+***doctoc commands***
+ * [doctoc_lang_cmdref.man%|%doctoc_lang_cmdref]
+ * [doctoc_lang_faq.man%|%doctoc_lang_faq]
+ * [doctoc_lang_intro.man%|%doctoc_lang_intro]
+ * [doctoc_lang_syntax.man%|%doctoc_lang_syntax]
+
+***doctoc language***
+ * [doctoc_lang_cmdref.man%|%doctoc_lang_cmdref]
+ * [doctoc_lang_faq.man%|%doctoc_lang_faq]
+ * [doctoc_lang_intro.man%|%doctoc_lang_intro]
+ * [doctoc_lang_syntax.man%|%doctoc_lang_syntax]
+
+***doctoc markup***
+ * [doctoc_lang_cmdref.man%|%doctoc_lang_cmdref]
+ * [doctoc_lang_faq.man%|%doctoc_lang_faq]
+ * [doctoc_lang_intro.man%|%doctoc_lang_intro]
+ * [doctoc_lang_syntax.man%|%doctoc_lang_syntax]
+
+***doctoc syntax***
+ * [doctoc_lang_faq.man%|%doctoc_lang_faq]
+ * [doctoc_lang_intro.man%|%doctoc_lang_intro]
+ * [doctoc_lang_syntax.man%|%doctoc_lang_syntax]
+
+***doctools***
+ * [changelog.man%|%doctools::changelog]
+ * [apps/dtplite.man%|%dtplite]
+
+***doctools commands***
+ * [doctools_lang_cmdref.man%|%doctools_lang_cmdref]
+ * [doctools_lang_faq.man%|%doctools_lang_faq]
+ * [doctools_lang_intro.man%|%doctools_lang_intro]
+ * [doctools_lang_syntax.man%|%doctools_lang_syntax]
+
+***doctools language***
+ * [doctools_lang_cmdref.man%|%doctools_lang_cmdref]
+ * [doctools_lang_faq.man%|%doctools_lang_faq]
+ * [doctools_lang_intro.man%|%doctools_lang_intro]
+ * [doctools_lang_syntax.man%|%doctools_lang_syntax]
+
+***doctools markup***
+ * [doctools_lang_cmdref.man%|%doctools_lang_cmdref]
+ * [doctools_lang_faq.man%|%doctools_lang_faq]
+ * [doctools_lang_intro.man%|%doctools_lang_intro]
+ * [doctools_lang_syntax.man%|%doctools_lang_syntax]
+
+***doctools syntax***
+ * [doctools_lang_faq.man%|%doctools_lang_faq]
+ * [doctools_lang_intro.man%|%doctools_lang_intro]
+ * [doctools_lang_syntax.man%|%doctools_lang_syntax]
+
+***document***
+ * [doctools_plugin_apiref.man%|%doctools_plugin_apiref]
+
+***documentation***
+ * [doctools.man%|%doctools]
+ * [docidx.man%|%doctools::idx]
+ * [doctoc.man%|%doctools::toc]
+
+***emacs***
+ * [changelog.man%|%doctools::changelog]
+ * [cvs.man%|%doctools::cvs]
+
+***examples***
+ * [docidx_lang_faq.man%|%docidx_lang_faq]
+ * [doctoc_lang_faq.man%|%doctoc_lang_faq]
+ * [doctools_lang_faq.man%|%doctools_lang_faq]
+
+***faq***
+ * [docidx_lang_faq.man%|%docidx_lang_faq]
+ * [doctoc_lang_faq.man%|%doctoc_lang_faq]
+ * [doctools_lang_faq.man%|%doctools_lang_faq]
+
+***formatter***
+ * [doctools_plugin_apiref.man%|%doctools_plugin_apiref]
+
+***formatting engine***
+ * [docidx_plugin_apiref.man%|%docidx_plugin_apiref]
+ * [doctoc_plugin_apiref.man%|%doctoc_plugin_apiref]
+ * [doctools_plugin_apiref.man%|%doctools_plugin_apiref]
+
+***HTML***
+ * [doctools.man%|%doctools]
+ * [docidx.man%|%doctools::idx]
+ * [doctoc.man%|%doctools::toc]
+ * [apps/dtplite.man%|%dtplite]
+ * [mpexpand.man%|%mpexpand]
+
+***index***
+ * [docidx_intro.man%|%docidx_intro]
+ * [docidx_plugin_apiref.man%|%docidx_plugin_apiref]
+ * [docidx.man%|%doctools::idx]
+
+***index formatter***
+ * [docidx_plugin_apiref.man%|%docidx_plugin_apiref]
+
+***keyword index***
+ * [docidx_intro.man%|%docidx_intro]
+ * [docidx.man%|%doctools::idx]
+
+***keywords***
+ * [docidx_plugin_apiref.man%|%docidx_plugin_apiref]
+
+***latex***
+ * [docidx.man%|%doctools::idx]
+ * [doctoc.man%|%doctools::toc]
+
+***log***
+ * [cvs.man%|%doctools::cvs]
+
+***manpage***
+ * [doctools.man%|%doctools]
+ * [docidx.man%|%doctools::idx]
+ * [doctoc.man%|%doctools::toc]
+ * [doctools_plugin_apiref.man%|%doctools_plugin_apiref]
+ * [apps/dtplite.man%|%dtplite]
+ * [mpexpand.man%|%mpexpand]
+
+***markup***
+ * [docidx_intro.man%|%docidx_intro]
+ * [docidx_lang_cmdref.man%|%docidx_lang_cmdref]
+ * [docidx_lang_faq.man%|%docidx_lang_faq]
+ * [docidx_lang_intro.man%|%docidx_lang_intro]
+ * [docidx_lang_syntax.man%|%docidx_lang_syntax]
+ * [docidx_plugin_apiref.man%|%docidx_plugin_apiref]
+ * [doctoc_intro.man%|%doctoc_intro]
+ * [doctoc_lang_cmdref.man%|%doctoc_lang_cmdref]
+ * [doctoc_lang_faq.man%|%doctoc_lang_faq]
+ * [doctoc_lang_intro.man%|%doctoc_lang_intro]
+ * [doctoc_lang_syntax.man%|%doctoc_lang_syntax]
+ * [doctoc_plugin_apiref.man%|%doctoc_plugin_apiref]
+ * [doctools.man%|%doctools]
+ * [docidx.man%|%doctools::idx]
+ * [doctoc.man%|%doctools::toc]
+ * [doctools_intro.man%|%doctools_intro]
+ * [doctools_lang_cmdref.man%|%doctools_lang_cmdref]
+ * [doctools_lang_faq.man%|%doctools_lang_faq]
+ * [doctools_lang_intro.man%|%doctools_lang_intro]
+ * [doctools_lang_syntax.man%|%doctools_lang_syntax]
+ * [doctools_plugin_apiref.man%|%doctools_plugin_apiref]
+ * [apps/dtplite.man%|%dtplite]
+ * [mpexpand.man%|%mpexpand]
+
+***nroff***
+ * [doctools.man%|%doctools]
+ * [docidx.man%|%doctools::idx]
+ * [doctoc.man%|%doctools::toc]
+ * [apps/dtplite.man%|%dtplite]
+ * [mpexpand.man%|%mpexpand]
+
+***plugin***
+ * [docidx_plugin_apiref.man%|%docidx_plugin_apiref]
+ * [doctoc_plugin_apiref.man%|%doctoc_plugin_apiref]
+
+***semantic markup***
+ * [docidx_intro.man%|%docidx_intro]
+ * [docidx_lang_cmdref.man%|%docidx_lang_cmdref]
+ * [docidx_lang_faq.man%|%docidx_lang_faq]
+ * [docidx_lang_intro.man%|%docidx_lang_intro]
+ * [docidx_lang_syntax.man%|%docidx_lang_syntax]
+ * [docidx_plugin_apiref.man%|%docidx_plugin_apiref]
+ * [doctoc_intro.man%|%doctoc_intro]
+ * [doctoc_lang_cmdref.man%|%doctoc_lang_cmdref]
+ * [doctoc_lang_faq.man%|%doctoc_lang_faq]
+ * [doctoc_lang_intro.man%|%doctoc_lang_intro]
+ * [doctoc_lang_syntax.man%|%doctoc_lang_syntax]
+ * [doctoc_plugin_apiref.man%|%doctoc_plugin_apiref]
+ * [doctools_intro.man%|%doctools_intro]
+ * [doctools_lang_cmdref.man%|%doctools_lang_cmdref]
+ * [doctools_lang_faq.man%|%doctools_lang_faq]
+ * [doctools_lang_intro.man%|%doctools_lang_intro]
+ * [doctools_lang_syntax.man%|%doctools_lang_syntax]
+ * [doctools_plugin_apiref.man%|%doctools_plugin_apiref]
+
+***table of contents***
+ * [doctoc_intro.man%|%doctoc_intro]
+ * [doctoc_plugin_apiref.man%|%doctoc_plugin_apiref]
+ * [doctoc.man%|%doctools::toc]
+
+***TMML***
+ * [doctools.man%|%doctools]
+ * [docidx.man%|%doctools::idx]
+ * [doctoc.man%|%doctools::toc]
+ * [apps/dtplite.man%|%dtplite]
+ * [mpexpand.man%|%mpexpand]
+
+***toc***
+ * [doctoc_intro.man%|%doctoc_intro]
+ * [doctoc_plugin_apiref.man%|%doctoc_plugin_apiref]
+ * [doctoc.man%|%doctools::toc]
+
+***toc formatter***
+ * [doctoc_plugin_apiref.man%|%doctoc_plugin_apiref]
+
+***web***
+ * [http://tcllib.sourceforge.net/doc/docidx_lang_intro.html%|%docidx language introduction]
+
+***wiki***
+ * [docidx.man%|%doctools::idx]
+ * [doctoc.man%|%doctools::toc]
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/wiki-table/1_nokeys b/tcllib/modules/doctools2idx/tests/data/ok/wiki-table/1_nokeys
new file mode 100644
index 0000000..48a3ea4
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/wiki-table/1_nokeys
@@ -0,0 +1 @@
+**KWIC -- INDEX**
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/wiki-table/2_justkeys b/tcllib/modules/doctools2idx/tests/data/ok/wiki-table/2_justkeys
new file mode 100644
index 0000000..b2d516f
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/wiki-table/2_justkeys
@@ -0,0 +1,46 @@
+**Keyword Index**
+
+%|'''changelog'''| |%
+%|'''conversion'''| |%
+%|'''cvs'''| |%
+%|'''cvs log'''| |%
+%|'''docidx'''| |%
+%|'''docidx commands'''| |%
+%|'''docidx language'''| |%
+%|'''docidx markup'''| |%
+%|'''docidx syntax'''| |%
+%|'''doctoc'''| |%
+%|'''doctoc commands'''| |%
+%|'''doctoc language'''| |%
+%|'''doctoc markup'''| |%
+%|'''doctoc syntax'''| |%
+%|'''doctools'''| |%
+%|'''doctools commands'''| |%
+%|'''doctools language'''| |%
+%|'''doctools markup'''| |%
+%|'''doctools syntax'''| |%
+%|'''document'''| |%
+%|'''documentation'''| |%
+%|'''emacs'''| |%
+%|'''examples'''| |%
+%|'''faq'''| |%
+%|'''formatter'''| |%
+%|'''formatting engine'''| |%
+%|'''HTML'''| |%
+%|'''index'''| |%
+%|'''index formatter'''| |%
+%|'''keyword index'''| |%
+%|'''keywords'''| |%
+%|'''latex'''| |%
+%|'''log'''| |%
+%|'''manpage'''| |%
+%|'''markup'''| |%
+%|'''nroff'''| |%
+%|'''plugin'''| |%
+%|'''semantic markup'''| |%
+%|'''table of contents'''| |%
+%|'''TMML'''| |%
+%|'''toc'''| |%
+%|'''toc formatter'''| |%
+%|'''web'''| |%
+%|'''wiki'''| |%
diff --git a/tcllib/modules/doctools2idx/tests/data/ok/wiki-table/3_kwic b/tcllib/modules/doctools2idx/tests/data/ok/wiki-table/3_kwic
new file mode 100644
index 0000000..6b600af
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/ok/wiki-table/3_kwic
@@ -0,0 +1,206 @@
+**Keyword Index**
+
+%|'''changelog'''| |%
+&| | [changelog.man%|%doctools::changelog] |&
+&| | [cvs.man%|%doctools::cvs] |&
+%|'''conversion'''| |%
+&| | [doctools.man%|%doctools] |&
+&| | [docidx.man%|%doctools::idx] |&
+&| | [doctoc.man%|%doctools::toc] |&
+&| | [apps/dtplite.man%|%dtplite] |&
+&| | [mpexpand.man%|%mpexpand] |&
+%|'''cvs'''| |%
+&| | [cvs.man%|%doctools::cvs] |&
+%|'''cvs log'''| |%
+&| | [cvs.man%|%doctools::cvs] |&
+%|'''docidx'''| |%
+&| | [docidx.man%|%doctools::idx] |&
+&| | [apps/dtplite.man%|%dtplite] |&
+%|'''docidx commands'''| |%
+&| | [docidx_lang_cmdref.man%|%docidx_lang_cmdref] |&
+&| | [docidx_lang_faq.man%|%docidx_lang_faq] |&
+&| | [docidx_lang_intro.man%|%docidx_lang_intro] |&
+&| | [docidx_lang_syntax.man%|%docidx_lang_syntax] |&
+%|'''docidx language'''| |%
+&| | [docidx_lang_cmdref.man%|%docidx_lang_cmdref] |&
+&| | [docidx_lang_faq.man%|%docidx_lang_faq] |&
+&| | [docidx_lang_intro.man%|%docidx_lang_intro] |&
+&| | [docidx_lang_syntax.man%|%docidx_lang_syntax] |&
+%|'''docidx markup'''| |%
+&| | [docidx_lang_cmdref.man%|%docidx_lang_cmdref] |&
+&| | [docidx_lang_faq.man%|%docidx_lang_faq] |&
+&| | [docidx_lang_intro.man%|%docidx_lang_intro] |&
+&| | [docidx_lang_syntax.man%|%docidx_lang_syntax] |&
+%|'''docidx syntax'''| |%
+&| | [docidx_lang_faq.man%|%docidx_lang_faq] |&
+&| | [docidx_lang_intro.man%|%docidx_lang_intro] |&
+&| | [docidx_lang_syntax.man%|%docidx_lang_syntax] |&
+%|'''doctoc'''| |%
+&| | [doctoc.man%|%doctools::toc] |&
+&| | [apps/dtplite.man%|%dtplite] |&
+%|'''doctoc commands'''| |%
+&| | [doctoc_lang_cmdref.man%|%doctoc_lang_cmdref] |&
+&| | [doctoc_lang_faq.man%|%doctoc_lang_faq] |&
+&| | [doctoc_lang_intro.man%|%doctoc_lang_intro] |&
+&| | [doctoc_lang_syntax.man%|%doctoc_lang_syntax] |&
+%|'''doctoc language'''| |%
+&| | [doctoc_lang_cmdref.man%|%doctoc_lang_cmdref] |&
+&| | [doctoc_lang_faq.man%|%doctoc_lang_faq] |&
+&| | [doctoc_lang_intro.man%|%doctoc_lang_intro] |&
+&| | [doctoc_lang_syntax.man%|%doctoc_lang_syntax] |&
+%|'''doctoc markup'''| |%
+&| | [doctoc_lang_cmdref.man%|%doctoc_lang_cmdref] |&
+&| | [doctoc_lang_faq.man%|%doctoc_lang_faq] |&
+&| | [doctoc_lang_intro.man%|%doctoc_lang_intro] |&
+&| | [doctoc_lang_syntax.man%|%doctoc_lang_syntax] |&
+%|'''doctoc syntax'''| |%
+&| | [doctoc_lang_faq.man%|%doctoc_lang_faq] |&
+&| | [doctoc_lang_intro.man%|%doctoc_lang_intro] |&
+&| | [doctoc_lang_syntax.man%|%doctoc_lang_syntax] |&
+%|'''doctools'''| |%
+&| | [changelog.man%|%doctools::changelog] |&
+&| | [apps/dtplite.man%|%dtplite] |&
+%|'''doctools commands'''| |%
+&| | [doctools_lang_cmdref.man%|%doctools_lang_cmdref] |&
+&| | [doctools_lang_faq.man%|%doctools_lang_faq] |&
+&| | [doctools_lang_intro.man%|%doctools_lang_intro] |&
+&| | [doctools_lang_syntax.man%|%doctools_lang_syntax] |&
+%|'''doctools language'''| |%
+&| | [doctools_lang_cmdref.man%|%doctools_lang_cmdref] |&
+&| | [doctools_lang_faq.man%|%doctools_lang_faq] |&
+&| | [doctools_lang_intro.man%|%doctools_lang_intro] |&
+&| | [doctools_lang_syntax.man%|%doctools_lang_syntax] |&
+%|'''doctools markup'''| |%
+&| | [doctools_lang_cmdref.man%|%doctools_lang_cmdref] |&
+&| | [doctools_lang_faq.man%|%doctools_lang_faq] |&
+&| | [doctools_lang_intro.man%|%doctools_lang_intro] |&
+&| | [doctools_lang_syntax.man%|%doctools_lang_syntax] |&
+%|'''doctools syntax'''| |%
+&| | [doctools_lang_faq.man%|%doctools_lang_faq] |&
+&| | [doctools_lang_intro.man%|%doctools_lang_intro] |&
+&| | [doctools_lang_syntax.man%|%doctools_lang_syntax] |&
+%|'''document'''| |%
+&| | [doctools_plugin_apiref.man%|%doctools_plugin_apiref] |&
+%|'''documentation'''| |%
+&| | [doctools.man%|%doctools] |&
+&| | [docidx.man%|%doctools::idx] |&
+&| | [doctoc.man%|%doctools::toc] |&
+%|'''emacs'''| |%
+&| | [changelog.man%|%doctools::changelog] |&
+&| | [cvs.man%|%doctools::cvs] |&
+%|'''examples'''| |%
+&| | [docidx_lang_faq.man%|%docidx_lang_faq] |&
+&| | [doctoc_lang_faq.man%|%doctoc_lang_faq] |&
+&| | [doctools_lang_faq.man%|%doctools_lang_faq] |&
+%|'''faq'''| |%
+&| | [docidx_lang_faq.man%|%docidx_lang_faq] |&
+&| | [doctoc_lang_faq.man%|%doctoc_lang_faq] |&
+&| | [doctools_lang_faq.man%|%doctools_lang_faq] |&
+%|'''formatter'''| |%
+&| | [doctools_plugin_apiref.man%|%doctools_plugin_apiref] |&
+%|'''formatting engine'''| |%
+&| | [docidx_plugin_apiref.man%|%docidx_plugin_apiref] |&
+&| | [doctoc_plugin_apiref.man%|%doctoc_plugin_apiref] |&
+&| | [doctools_plugin_apiref.man%|%doctools_plugin_apiref] |&
+%|'''HTML'''| |%
+&| | [doctools.man%|%doctools] |&
+&| | [docidx.man%|%doctools::idx] |&
+&| | [doctoc.man%|%doctools::toc] |&
+&| | [apps/dtplite.man%|%dtplite] |&
+&| | [mpexpand.man%|%mpexpand] |&
+%|'''index'''| |%
+&| | [docidx_intro.man%|%docidx_intro] |&
+&| | [docidx_plugin_apiref.man%|%docidx_plugin_apiref] |&
+&| | [docidx.man%|%doctools::idx] |&
+%|'''index formatter'''| |%
+&| | [docidx_plugin_apiref.man%|%docidx_plugin_apiref] |&
+%|'''keyword index'''| |%
+&| | [docidx_intro.man%|%docidx_intro] |&
+&| | [docidx.man%|%doctools::idx] |&
+%|'''keywords'''| |%
+&| | [docidx_plugin_apiref.man%|%docidx_plugin_apiref] |&
+%|'''latex'''| |%
+&| | [docidx.man%|%doctools::idx] |&
+&| | [doctoc.man%|%doctools::toc] |&
+%|'''log'''| |%
+&| | [cvs.man%|%doctools::cvs] |&
+%|'''manpage'''| |%
+&| | [doctools.man%|%doctools] |&
+&| | [docidx.man%|%doctools::idx] |&
+&| | [doctoc.man%|%doctools::toc] |&
+&| | [doctools_plugin_apiref.man%|%doctools_plugin_apiref] |&
+&| | [apps/dtplite.man%|%dtplite] |&
+&| | [mpexpand.man%|%mpexpand] |&
+%|'''markup'''| |%
+&| | [docidx_intro.man%|%docidx_intro] |&
+&| | [docidx_lang_cmdref.man%|%docidx_lang_cmdref] |&
+&| | [docidx_lang_faq.man%|%docidx_lang_faq] |&
+&| | [docidx_lang_intro.man%|%docidx_lang_intro] |&
+&| | [docidx_lang_syntax.man%|%docidx_lang_syntax] |&
+&| | [docidx_plugin_apiref.man%|%docidx_plugin_apiref] |&
+&| | [doctoc_intro.man%|%doctoc_intro] |&
+&| | [doctoc_lang_cmdref.man%|%doctoc_lang_cmdref] |&
+&| | [doctoc_lang_faq.man%|%doctoc_lang_faq] |&
+&| | [doctoc_lang_intro.man%|%doctoc_lang_intro] |&
+&| | [doctoc_lang_syntax.man%|%doctoc_lang_syntax] |&
+&| | [doctoc_plugin_apiref.man%|%doctoc_plugin_apiref] |&
+&| | [doctools.man%|%doctools] |&
+&| | [docidx.man%|%doctools::idx] |&
+&| | [doctoc.man%|%doctools::toc] |&
+&| | [doctools_intro.man%|%doctools_intro] |&
+&| | [doctools_lang_cmdref.man%|%doctools_lang_cmdref] |&
+&| | [doctools_lang_faq.man%|%doctools_lang_faq] |&
+&| | [doctools_lang_intro.man%|%doctools_lang_intro] |&
+&| | [doctools_lang_syntax.man%|%doctools_lang_syntax] |&
+&| | [doctools_plugin_apiref.man%|%doctools_plugin_apiref] |&
+&| | [apps/dtplite.man%|%dtplite] |&
+&| | [mpexpand.man%|%mpexpand] |&
+%|'''nroff'''| |%
+&| | [doctools.man%|%doctools] |&
+&| | [docidx.man%|%doctools::idx] |&
+&| | [doctoc.man%|%doctools::toc] |&
+&| | [apps/dtplite.man%|%dtplite] |&
+&| | [mpexpand.man%|%mpexpand] |&
+%|'''plugin'''| |%
+&| | [docidx_plugin_apiref.man%|%docidx_plugin_apiref] |&
+&| | [doctoc_plugin_apiref.man%|%doctoc_plugin_apiref] |&
+%|'''semantic markup'''| |%
+&| | [docidx_intro.man%|%docidx_intro] |&
+&| | [docidx_lang_cmdref.man%|%docidx_lang_cmdref] |&
+&| | [docidx_lang_faq.man%|%docidx_lang_faq] |&
+&| | [docidx_lang_intro.man%|%docidx_lang_intro] |&
+&| | [docidx_lang_syntax.man%|%docidx_lang_syntax] |&
+&| | [docidx_plugin_apiref.man%|%docidx_plugin_apiref] |&
+&| | [doctoc_intro.man%|%doctoc_intro] |&
+&| | [doctoc_lang_cmdref.man%|%doctoc_lang_cmdref] |&
+&| | [doctoc_lang_faq.man%|%doctoc_lang_faq] |&
+&| | [doctoc_lang_intro.man%|%doctoc_lang_intro] |&
+&| | [doctoc_lang_syntax.man%|%doctoc_lang_syntax] |&
+&| | [doctoc_plugin_apiref.man%|%doctoc_plugin_apiref] |&
+&| | [doctools_intro.man%|%doctools_intro] |&
+&| | [doctools_lang_cmdref.man%|%doctools_lang_cmdref] |&
+&| | [doctools_lang_faq.man%|%doctools_lang_faq] |&
+&| | [doctools_lang_intro.man%|%doctools_lang_intro] |&
+&| | [doctools_lang_syntax.man%|%doctools_lang_syntax] |&
+&| | [doctools_plugin_apiref.man%|%doctools_plugin_apiref] |&
+%|'''table of contents'''| |%
+&| | [doctoc_intro.man%|%doctoc_intro] |&
+&| | [doctoc_plugin_apiref.man%|%doctoc_plugin_apiref] |&
+&| | [doctoc.man%|%doctools::toc] |&
+%|'''TMML'''| |%
+&| | [doctools.man%|%doctools] |&
+&| | [docidx.man%|%doctools::idx] |&
+&| | [doctoc.man%|%doctools::toc] |&
+&| | [apps/dtplite.man%|%dtplite] |&
+&| | [mpexpand.man%|%mpexpand] |&
+%|'''toc'''| |%
+&| | [doctoc_intro.man%|%doctoc_intro] |&
+&| | [doctoc_plugin_apiref.man%|%doctoc_plugin_apiref] |&
+&| | [doctoc.man%|%doctools::toc] |&
+%|'''toc formatter'''| |%
+&| | [doctoc_plugin_apiref.man%|%doctoc_plugin_apiref] |&
+%|'''web'''| |%
+&| | [http://tcllib.sourceforge.net/doc/docidx_lang_intro.html%|%docidx language introduction] |&
+%|'''wiki'''| |%
+&| | [docidx.man%|%doctools::idx] |&
+&| | [doctoc.man%|%doctools::toc] |&
diff --git a/tcllib/modules/doctools2idx/tests/data/unexpected_char b/tcllib/modules/doctools2idx/tests/data/unexpected_char
new file mode 100644
index 0000000..9420cbd
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/unexpected_char
@@ -0,0 +1,2 @@
+[bad syntax in include file
+2]
diff --git a/tcllib/modules/doctools2idx/tests/data/unexpected_eof b/tcllib/modules/doctools2idx/tests/data/unexpected_eof
new file mode 100644
index 0000000..b56316c
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/data/unexpected_eof
@@ -0,0 +1 @@
+[bad syntax in include file \ No newline at end of file
diff --git a/tcllib/modules/doctools2idx/tests/export b/tcllib/modules/doctools2idx/tests/export
new file mode 100644
index 0000000..423689e
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/export
@@ -0,0 +1,153 @@
+# -*- tcl -*-
+# idx_export.testsuite: Tests for the managed of index export plugins.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export,v 1.1 2009/04/01 04:28:37 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+# Tests are run for all formats we have an export plugin for.
+
+# -------------------------------------------------------------------------
+
+set mytestdir tests/data
+set mytestconfig {fox dog lazy jump}
+set mytestincludes [TestFilesGlob $mytestdir]
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# docidx markup
+
+# Testing the export of docidx markup through an exporter manager, for
+# all possible configurations.
+
+foreach {k nl in al section} {
+ 0 0 0 0 -ultracompact
+ 1 1 0 0 -compact
+ 2 1 1 0 -indented
+ 3 1 0 1 -aligned
+ 4 1 1 1 -indalign
+ 5 0 1 0 -indented
+ 6 0 0 1 -aligned
+ 7 0 1 1 -indalign
+} {
+ TestFilesProcess $mytestdir ok serial docidx$section -> n label input data expected {
+ test doctools-idx-export-plugin-docidx-20.$k.$n "doctools::idx::export /docidx, $label$section, ok" -setup {
+ doctools::idx::export OUT
+ OUT config set newlines $nl
+ OUT config set indented $in
+ OUT config set aligned $al
+ } -body {
+ stripcomments [OUT export serial $data docidx]
+ } -cleanup {
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# text markup
+
+TestFilesProcess $mytestdir ok serial text -> n label input data expected {
+ test doctools-idx-export-plugin-text-21.$n "doctools::idx::export /text, $label, ok" -setup {
+ doctools::idx::export OUT
+ } -body {
+ OUT export serial $data text
+ } -cleanup {
+ OUT destroy
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# json markup
+
+foreach {k in al section} {
+ 0 0 0 -ultracompact
+ 1 1 0 -indented
+ 2 0 1 -indalign
+ 3 1 1 -indalign
+} {
+ TestFilesProcess $mytestdir ok serial json$section -> n label input data expected {
+ test doctools-idx-export-plugin-json-22.$k.$n "doctools::idx::export /json, $label$section, ok" -setup {
+ doctools::idx::export OUT
+ OUT config set indented $in
+ OUT config set aligned $al
+ } -body {
+ OUT export serial $data json
+ } -cleanup {
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# html markup
+
+foreach {k nl in section} {
+ 0 0 0 -ultracompact
+ 1 0 1 -indented
+ 2 1 0 -compact
+ 3 1 1 -indented
+} {
+ TestFilesProcess $mytestdir ok serial html$section -> n label input data expected {
+ test doctools-idx-export-plugin-html-23.$k.$n "doctools::idx::export /html, $label$section, ok" -setup {
+ doctools::idx::export OUT
+ OUT config set newlines $nl
+ OUT config set indented $in
+ OUT config set user _dummy_
+ } -body {
+ striphtmlcomments [OUT export serial $data html] 3
+ } -cleanup {
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# wiki markup
+
+foreach {k style section} {
+ 0 list -list
+ 1 table -table
+} {
+ TestFilesProcess $mytestdir ok serial wiki$section -> n label input data expected {
+ test doctools-idx-export-plugin-wiki-23.$k.$n "doctools::idx::export /wiki, $label$section, ok" -setup {
+ doctools::idx::export OUT
+ OUT config set style $style
+ } -body {
+ OUT export serial $data wiki
+ } -cleanup {
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# nroff markup
+
+foreach {k inline section} {
+ 0 0 -external
+ 1 1 -inlined
+} {
+ TestFilesProcess $mytestdir ok serial nroff$section -> n label input data expected {
+ test doctools-idx-export-plugin-nroff-24.$k.$n "doctools::idx::export /nroff, $label$section, ok" -setup {
+ doctools::idx::export OUT
+ OUT config set inline $inline
+ } -body {
+ stripnroffcomments [stripmanmacros [OUT export serial $data nroff]]
+ } -cleanup {
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+unset mytestdir n label input data expected
+return
diff --git a/tcllib/modules/doctools2idx/tests/export_docidx b/tcllib/modules/doctools2idx/tests/export_docidx
new file mode 100644
index 0000000..aab471b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/export_docidx
@@ -0,0 +1,5 @@
+# -*- tcl -*-
+# This file is not required as the .test file already does all the
+# tests without the need for an additional sourced control file.
+# We have it here just as a reminder.
+return
diff --git a/tcllib/modules/doctools2idx/tests/export_text b/tcllib/modules/doctools2idx/tests/export_text
new file mode 100644
index 0000000..aab471b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/export_text
@@ -0,0 +1,5 @@
+# -*- tcl -*-
+# This file is not required as the .test file already does all the
+# tests without the need for an additional sourced control file.
+# We have it here just as a reminder.
+return
diff --git a/tcllib/modules/doctools2idx/tests/import b/tcllib/modules/doctools2idx/tests/import
new file mode 100644
index 0000000..679adcf
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/import
@@ -0,0 +1,174 @@
+# -*- tcl -*-
+# idx_import.testsuite: Tests for the managed of index import plugins.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: import,v 1.1 2009/04/01 04:28:37 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+# Tests are run for all formats we have an import plugin for.
+
+# -------------------------------------------------------------------------
+
+set mytestdir tests/data
+set mytestconfig {fox dog lazy jump}
+set mytestincludes [TestFilesGlob $mytestdir]
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# docidx markup
+
+# We are checking that the various forms of docidx markup, as can be
+# generated by doctools::idx(::format::docidx) are valid input to the
+# docidx parser.
+
+foreach {k section} {
+ 0 {}
+ 1 -ultracompact
+ 2 -compact
+ 3 -indented
+ 4 -aligned
+ 5 -indalign
+} {
+ TestFilesProcess $mytestdir ok docidx$section serial-print -> n label input data expected {
+ test doctools-idx-import-plugin-docidx-20.$k.$n "doctools::idx::import text /docidx, $label$section, ok" -setup {
+ doctools::idx::import I
+ foreach {n v} $mytestconfig { I config set $n $v }
+ foreach p $mytestincludes { I include add $p }
+ } -body {
+ doctools::idx::structure print [I import text $data docidx]
+ } -cleanup {
+ I destroy
+ } -result $expected
+ }
+
+ TestFilesProcess $mytestdir ok docidx$section serial-print -> n label input data expected {
+ test doctools-idx-import-plugin-docidx-21.$k.$n "doctools::idx::import file /docidx, $label$section, ok" -setup {
+ doctools::idx::import I
+ foreach {n v} $mytestconfig { I config set $n $v }
+ foreach p $mytestincludes { I include add $p }
+ } -body {
+ doctools::idx::structure print [I import file $input docidx]
+ } -cleanup {
+ I destroy
+ } -result $expected
+ }
+}
+
+# We test the error messages and codes thrown by the parser for a
+# variety of failure possibilities.
+
+TestFilesProcess $mytestdir fail docidx emsg -> n label input data expected {
+ test doctools-idx-import-plugin-docidx-22.$n "doctools::idx::import text /docidx, $label, error message" -setup {
+ doctools::idx::import I
+ foreach {n v} $mytestconfig { I config set $n $v }
+ foreach p $mytestincludes { I include add $p }
+ } -body {
+ I import text $data docidx
+ } -cleanup {
+ I destroy
+ } -returnCodes error -result $expected
+}
+
+TestFilesProcess $mytestdir fail docidx ecode -> n label input data expected {
+ test doctools-idx-import-plugin-docidx-23.$n "doctools::idx::import text /docidx, $label, error code" -setup {
+ doctools::idx::import I
+ foreach {n v} $mytestconfig { I config set $n $v }
+ foreach p $mytestincludes { I include add $p }
+ } -body {
+ # Catch and rethrow using the error code as new message.
+ catch { I import text $data docidx }
+ set ::errorCode
+ } -cleanup {
+ I destroy
+ } -result $expected
+}
+
+TestFilesProcess $mytestdir fail docidx emsg -> n label input data expected {
+ test doctools-idx-import-plugin-docidx-24.$n "doctools::idx::import file /docidx, $label, error message" -setup {
+ doctools::idx::import I
+ foreach {n v} $mytestconfig { I config set $n $v }
+ foreach p $mytestincludes { I include add $p }
+ } -body {
+ I import file $input docidx
+ } -cleanup {
+ I destroy
+ } -returnCodes error -result $expected
+}
+
+TestFilesProcess $mytestdir fail docidx ecode -> n label input data expected {
+ test doctools-idx-import-plugin-docidx-25.$n "doctools::idx::import file /docidx, $label, error code" -setup {
+ doctools::idx::import I
+ foreach {n v} $mytestconfig { I config set $n $v }
+ foreach p $mytestincludes { I include add $p }
+ } -body {
+ # Catch and rethrow using the error code as new message.
+ catch { I import file $input docidx }
+ set ::errorCode
+ } -cleanup {
+ I destroy
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# text markup - This is not an importable format.
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# json - Java Script Object Notation
+
+# We are checking that the various forms of json markup, as can be
+# generated by doctools::idx(::export(::json)) are valid input to the
+# json parser.
+#
+# section {} holds the non-canonical input we have to accept and make
+# canonical to higher layers.
+
+foreach {k section} {
+ 0 {}
+ 1 -ultracompact
+ 2 -indented
+ 3 -indalign
+} {
+ TestFilesProcess $mytestdir ok json$section serial-print -> n label input data expected {
+ test doctools-idx-import-plugin-json-26.$k.$n "doctools::idx::import text /json, $label$section, ok" -setup {
+ doctools::idx::import I
+ } -body {
+ doctools::idx::structure print [I import text $data json]
+ } -cleanup {
+ I destroy
+ } -result $expected
+ }
+
+ TestFilesProcess $mytestdir ok json$section serial-print -> n label input data expected {
+ test doctools-idx-import-plugin-json-27.$k.$n "doctools::idx::import file /json, $label$section, ok" -setup {
+ doctools::idx::import I
+ } -body {
+ doctools::idx::structure print [I import file $input json]
+ } -cleanup {
+ I destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# We test the error messages and codes thrown by the parser for a
+# variety of failure possibilities.
+
+TestFilesProcess $mytestdir fail json json-emsg -> n label input data expected {
+ test doctools-idx-import-plugin-json-28.$n "doctools::idx::import text /json, $label, error message" -setup {
+ doctools::idx::import I
+ } -body {
+ I import text $data json
+ } -cleanup {
+ I destroy
+ } -returnCodes error -result $expected
+}
+
+# -------------------------------------------------------------------------
+unset mytestdir n label input data expected
+return
diff --git a/tcllib/modules/doctools2idx/tests/import_docidx b/tcllib/modules/doctools2idx/tests/import_docidx
new file mode 100644
index 0000000..0ccf575
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/import_docidx
@@ -0,0 +1,73 @@
+# -*- tcl -*-
+# idx_import_docidx.testsuite: tests for the docidx import plugin.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: import_docidx,v 1.1 2009/04/01 04:28:37 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+set mytestconfig {fox dog lazy jump}
+set mytestincludes [TestFilesGlob $mytestdir]
+
+# -------------------------------------------------------------------------
+
+# We are checking that the various forms of docidx markup, as can be
+# generated by doctools::idx(::export(::docidx)) are valid input to
+# the docidx parser.
+#
+# section {} holds the non-canonical input we have to accept and make
+# canonical to higher layers.
+
+foreach {k section} {
+ 0 {}
+ 1 -ultracompact
+ 2 -compact
+ 3 -indented
+ 4 -aligned
+ 5 -indalign
+} {
+ TestFilesProcess $mytestdir ok docidx$section serial-print -> n label input data expected {
+ test doctools-idx-import-docidx-${stkimpl}-${setimpl}-${impl}-2.$k.$n "doctools::idx::import::docidx, $label$section, ok" -setup {
+ doctools::idx::parse include set $mytestincludes
+ } -body {
+ doctools::idx::structure print [import $data $mytestconfig]
+ } -cleanup {
+ doctools::idx::parse include clear
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# We test the error messages and codes thrown by the parser for a
+# variety of failure possibilities.
+
+TestFilesProcess $mytestdir fail docidx emsg -> n label input data expected {
+ test doctools-idx-import-docidx-${stkimpl}-${setimpl}-${impl}-3.$n "doctools::idx::import::docidx, $label, error message" -setup {
+ doctools::idx::parse include set $mytestincludes
+ } -body {
+ import $data $mytestconfig
+ } -cleanup {
+ doctools::idx::parse include clear
+ } -returnCodes error -result $expected
+}
+
+TestFilesProcess $mytestdir fail docidx ecode -> n label input data expected {
+ test doctools-idx-import-docidx-${stkimpl}-${setimpl}-${impl}-4.$n "doctools::idx::import::docidx, $label, error code" -setup {
+ doctools::idx::parse include set $mytestincludes
+ } -body {
+ # Catch and rethrow using the error code as new message.
+ catch { import $data $mytestconfig }
+ set ::errorCode
+ } -cleanup {
+ doctools::idx::parse include clear
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+unset mytestdir n label input data expected
+return
diff --git a/tcllib/modules/doctools2idx/tests/parse b/tcllib/modules/doctools2idx/tests/parse
new file mode 100644
index 0000000..44c4d8b
--- /dev/null
+++ b/tcllib/modules/doctools2idx/tests/parse
@@ -0,0 +1,130 @@
+# -*- tcl -*-
+# docidx_parse.testsuite: tests for the docidx parser.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: parse,v 1.2 2009/04/08 04:08:58 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# We are checking that the various forms of docidx markup, as can be
+# generated by doctools::idx::export::docidx are valid input to the
+# docidx parser.
+#
+# section {} holds the non-canonical input we have to accept and make
+# canonical to higher layers.
+
+foreach {k section} {
+ 0 {}
+ 1 -ultracompact
+ 2 -compact
+ 3 -indented
+ 4 -aligned
+ 5 -indalign
+} {
+ TestFilesProcess $mytestdir ok docidx$section serial-print -> n label input data expected {
+ test doctools-idx-parse-${stkimpl}-${setimpl}-${impl}-20.$k.$n "doctools::idx::parse text, $label$section, ok" -setup {
+ # Define a few basic variables and include search paths for
+ # use by the test
+ doctools::idx::parse var load {fox dog lazy jump}
+ doctools::idx::parse include set [TestFilesGlob $mytestdir]
+ } -body {
+ doctools::idx::structure print \
+ [doctools::idx::parse text $data]
+ } -cleanup {
+ doctools::idx::parse include clear
+ doctools::idx::parse var unset *
+ } -result $expected
+ }
+
+ TestFilesProcess $mytestdir ok docidx$section serial-print -> n label input data expected {
+ test doctools-idx-parse-${stkimpl}-${setimpl}-${impl}-21.$k.$n "doctools::idx::parse file, $label$section, ok" -setup {
+ # Define a few basic variables and include search paths for
+ # use by the test
+ doctools::idx::parse var load {fox dog lazy jump}
+ doctools::idx::parse include set [TestFilesGlob $mytestdir]
+ } -body {
+ doctools::idx::structure print \
+ [doctools::idx::parse file $input]
+ } -cleanup {
+ doctools::idx::parse include clear
+ doctools::idx::parse var unset *
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# We test the error messages and codes thrown by the parser for a
+# variety of failure possibilities.
+
+TestFilesProcess $mytestdir fail docidx emsg -> n label input data expected {
+ test doctools-idx-parse-${stkimpl}-${setimpl}-${impl}-22.$n "doctools::idx::parse, $label, error message" -setup {
+ # Define a few basic variables and include search paths for
+ # use by the test
+ doctools::idx::parse var load {fox dog lazy jump}
+ doctools::idx::parse include set [TestFilesGlob $mytestdir]
+ } -body {
+ doctools::idx::parse text $data
+ } -cleanup {
+ doctools::idx::parse include clear
+ doctools::idx::parse var unset *
+ } -returnCodes error -result $expected
+}
+
+TestFilesProcess $mytestdir fail docidx ecode -> n label input data expected {
+ test doctools-idx-parse-${stkimpl}-${setimpl}-${impl}-23.$n "doctools::idx::parse, $label, error code" -setup {
+ # Define a few basic variables and include search paths for
+ # use by the test
+ doctools::idx::parse var load {fox dog lazy jump}
+ doctools::idx::parse include set [TestFilesGlob $mytestdir]
+ } -body {
+ # Catch and rethrow using the error code as new message.
+ catch { doctools::idx::parse text $data }
+ set ::errorCode
+ } -cleanup {
+ doctools::idx::parse include clear
+ doctools::idx::parse var unset *
+ } -result $expected
+}
+
+TestFilesProcess $mytestdir fail docidx emsg -> n label input data expected {
+ test doctools-idx-parse-${stkimpl}-${setimpl}-${impl}-24.$n "doctools::idx::parse file, $label, error message" -setup {
+ # Define a few basic variables and include search paths for
+ # use by the test
+ doctools::idx::parse var load {fox dog lazy jump}
+ doctools::idx::parse include set [TestFilesGlob $mytestdir]
+ } -body {
+ catch { [doctools::idx::parse file $input] } msg
+ string map [list "\"$input\" " {}] $msg
+ } -cleanup {
+ doctools::idx::parse include clear
+ doctools::idx::parse var unset *
+ } -result $expected
+}
+
+TestFilesProcess $mytestdir fail docidx ecode -> n label input data expected {
+ test doctools-idx-parse-${stkimpl}-${setimpl}-${impl}-25.$n "doctools::idx::parse file, $label, error code" -setup {
+ # Define a few basic variables and include search paths for
+ # use by the test
+ doctools::idx::parse var load {fox dog lazy jump}
+ doctools::idx::parse include set [TestFilesGlob $mytestdir]
+ } -body {
+ # Catch and rethrow using the error code as new message.
+ catch { doctools::idx::parse file $input }
+ string map [list $input {{}}] $::errorCode
+ } -cleanup {
+ doctools::idx::parse include clear
+ doctools::idx::parse var unset *
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+unset mytestdir n label input data expected
+return
diff --git a/tcllib/modules/doctools2toc/ChangeLog b/tcllib/modules/doctools2toc/ChangeLog
new file mode 100644
index 0000000..6090d9d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/ChangeLog
@@ -0,0 +1,103 @@
+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-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-11-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * export_doctoc.man: Added headers to properly mark files as manpages
+ * export_html.man: even if not containing having manpage_begin, and
+ * export_json.man: vice versa, preventing recognition of subordinate
+ * export_nroff.man: include files as manpages.
+ * export_text.man:
+ * export_wiki.man:
+ * import_doctoc.man:
+ * import_json.man:
+ * include/export/plugin.inc:
+ * include/import/plugin.inc:
+ * include/msgcat.inc:
+ * msgcat_c.man:
+ * msgcat_de.man:
+ * msgcat_en.man:
+ * msgcat_fr.man:
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-11-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * container.test: Fixed up typos in comments refering to keyword
+ * export.tcl: indices, while the packages are all about tables of
+ * export_doctoc.tcl: contents. Unchanged functionality, version
+ * export_doctoc.test: left unchanged.
+ * export_html.tcl:
+ * export_html.test:
+ * export_json.tcl:
+ * export_json.test:
+ * export_nroff.tcl:
+ * export_nroff.test:
+ * export_text.tcl:
+ * export_text.test:
+ * export_wiki.tcl:
+ * export_wiki.test:
+ * import.tcl:
+ * import_doctoc.tcl:
+ * import_json.tcl:
+ * include/export/config/doctoc.inc:
+ * include/export/config/html.inc:
+ * include/export/config/nroff.inc:
+ * include/export/plugin.inc:
+ * include/import/plugin.inc:
+ * parse.tcl:
+ * tests/container:
+ * tests/export:
+ * tests/import:
+
+2009-08-07 Andreas Kupries <andreask@activestate.com>
+
+ * export_doctoc.tcl: Added missing '@mdgen NODEP' hints for the
+ * export_html.tcl: pseudo-packages 'doctools::toc::export::plugin'
+ * export_json.tcl: and 'doctools::toc::import::plugin' to keep them
+ * export_nroff.tcl: out of the requirements listed in the meta data.
+ * export_text.tcl:
+ * export_wiki.tcl:
+ * import_doctoc.tcl:
+ * import_json.tcl:
+
+2009-04-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * container.test: Updated the nroff export plugin and related files
+ * export.test: to new name of the nroff man.macros package. Bumped
+ * export_nroff.tcl: to version 0.2.
+ * export_nroff.test:
+ * pkgIndex.tcl:
+ * include/dependencies.inc:
+ * include/export/format/nroff.inc:
+
+ * include/export/plugin.inc: Made version info configurable
+ * export_docidx.tcl: Version 0.1, unchanged
+ * export_json.tcl: Version 0.1, unchanged
+ * export_html.tcl: Version 0.1, unchanged
+ * export_text.tcl: Version 0.1, unchanged
+ * export_wiki.tcl: Version 0.1, unchanged
+ * export_nroff.tcl: Bumped version to 0.2.
+
+2009-04-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Doctools version 2, processing tables of contents.
diff --git a/tcllib/modules/doctools2toc/container.tcl b/tcllib/modules/doctools2toc/container.tcl
new file mode 100644
index 0000000..bfc66c7
--- /dev/null
+++ b/tcllib/modules/doctools2toc/container.tcl
@@ -0,0 +1,545 @@
+# doctoc.tcl --
+#
+# Implementation of doctoc objects for Tcl. v2.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: container.tcl,v 1.2 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# Each object manages one table of contents, with methods to add and
+# remove entries and divisions, singly, or in bulk. The bulk methods
+# accept various forms of textual serializations, among them text
+# using the doctoc markup language.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.4
+package require doctools::toc::structure
+package require snit
+package require struct::tree
+
+# ### ### ### ######### ######### #########
+## API
+
+snit::type ::doctools::toc {
+
+ # Concepts:
+ # - A table of contents consists of an ordered set of elements,
+ # references and divisions.
+ # - Both type of elements within the table are identified by their
+ # label.
+ # - A reference has two additional pieces of information,
+ # the id of the document it references, and a textual description.
+ # - A division may have the id of a document.
+ # - The main data of a division is an ordered set of elements,
+ # references and divisions.
+ # - Both type of elements within the division are identified by
+ # their label.
+ # - The definitions above define a tree of elements, with
+ # references as leafs, and divisions as the inner nodes.
+ # - Regarding identification, the full label of each element is
+ # the list of per-node labels on the path from the root of the
+ # tree to the element itself.
+
+ # ### ### ### ######### ######### #########
+ ## Options
+
+ ## None
+
+ # ### ### ### ######### ######### #########
+ ## Methods
+
+ constructor {} {
+ install mytree using struct::tree ${selfns}::T
+ # Root is a fake division
+ set myroot [$mytree rootname]
+ $mytree set $myroot type division
+ $mytree set $myroot label {}
+ $mytree set $myroot labelindex {}
+ return
+ }
+
+ # Default destructor.
+
+ # ### ### ### ######### ######### #########
+
+ method invalidate {} {
+ array unset mytoc *
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method title {{text {}}} {
+ if {[llength [info level 0]] == 6} {
+ set mytitle $text
+ }
+ return $mytitle
+ }
+
+ method label {{text {}}} {
+ if {[llength [info level 0]] == 6} {
+ set mylabel $text
+ $mytree set $myroot label $text
+ }
+ return $mylabel
+ }
+
+ method exporter {{object {}}} {
+ # TODO :: unlink/link change notification callbacks on the
+ # config/include components so that we can invalidate our
+ # cache when the settings change.
+
+ if {[llength [info level 0]] == 6} {
+ set myexporter $object
+ }
+ return $myexporter
+ }
+
+ method importer {{object {}}} {
+ if {[llength [info level 0]] == 6} {
+ set myimporter $object
+ }
+ return $myimporter
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Direct manipulation of the table of contents.
+
+ method {+ reference} {pid label docid desc} {
+ CheckDiv $pid
+ if {$docid eq {}} {
+ return -code error "Illegal empty document reference for reference entry"
+ }
+
+ array set l [$mytree get $pid labelindex]
+ if {[info exists l($label)]} {
+ return -code error "Redefinition of label '$label' in '[$self full-label $pid]'"
+ }
+
+ set new [$mytree insert $pid end]
+ set l($label) $new
+ $mytree set $pid labelindex [array get l]
+
+ $mytree set $new type reference
+ $mytree set $new label $label
+ $mytree set $new document $docid
+ $mytree set $new description $desc
+
+ array unset mytoc *
+ return $new
+ }
+
+ method {+ division} {pid label {docid {}}} {
+ CheckDiv $pid
+
+ array set l [$mytree get $pid labelindex]
+ if {[info exists l($label)]} {
+ return -code error "Redefinition of label '$label' in '[$self full-label $pid]'"
+ }
+
+ set new [$mytree insert $pid end]
+ set l($label) $new
+ $mytree set $pid labelindex [array get l]
+
+ $mytree set $new type division
+ $mytree set $new label $label
+ if {$docid ne {}} {
+ $mytree set $new document $docid
+ }
+ $mytree set $new labelindex {}
+
+ array unset mytoc *
+ return $new
+ }
+
+ method remove {id} {
+ Check $id
+ if {$id eq $myroot} {
+ return -code error {Unable to remove root}
+ }
+ set pid [$mytree parent $id]
+ set label [$mytree get $id label]
+
+ array set l [$mytree get $pid labelindex]
+ unset l($label)
+ $mytree set $pid labelindex [array get l]
+ $mytree delete $id
+
+ array unset mytoc *
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method up {id} {
+ Check $id
+ return [$mytree parent $id]
+ }
+
+ method next {id} {
+ Check $id
+ set n [$mytree next $id]
+ if {$n eq {}} { set n [$mytree parent $id] }
+ return $n
+ }
+
+ method prev {id} {
+ Check $id
+ set n [$mytree previous $id]
+ if {$n eq {}} { set n [$mytree parent $id] }
+ return $n
+ }
+
+ method child {id label args} {
+ CheckDiv $id
+ # Find the id of the element with the given labels, in the
+ # parent element id.
+ foreach label [linsert $args 0 $label] {
+ array set l [$mytree get $id labelindex]
+ if {![info exists l($label)]} {
+ return -code error "Bad label '$label' in '[$self full-label $id]'"
+ }
+ set id $l($label)
+ unset l
+ }
+ return $id
+ }
+
+ method element {args} {
+ if {![llength $args]} { return $myroot }
+ # 8.5: $self child $myroot {*}$args
+ return [eval [linsert $args 0 $self child $myroot]]
+ }
+
+ method children {id} {
+ CheckDiv $id
+ return [$mytree children $id]
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method type {id} {
+ Check $id
+ return [$mytree get $id type]
+ }
+
+ method full-label {id} {
+ Check $id
+ set result {}
+ foreach node [struct::list reverse [lrange [$mytree ancestors $id] 0 end-1]] {
+ lappend result [$mytree get $node label]
+ }
+ lappend result [$mytree get $id label]
+
+ return $result
+ }
+
+ method elabel {id {newlabel {}}} {
+ Check $id
+ set thelabel [$mytree get $id label]
+ if {
+ ([llength [info level 0]] == 7) &&
+ ($newlabel ne $thelabel)
+ } {
+ # Handle only calls which change the label
+
+ set parent [$mytree parent $id]
+ array set l [$mytree get $parent labelindex]
+
+ if {[info exists l($newlabel)]} {
+ return -code error "Redefinition of label '$newlabel' in '[$self full-label $parent]'"
+ }
+
+ # Copy node information and re-label.
+ set l($newlabel) $l($thelabel)
+ unset l($thelabel)
+ $mytree set $id label $newlabel
+ $mytree set $parent labelindex [array get l]
+
+ if {$id eq $myroot} {
+ set mylabel $newlabel
+ }
+
+ set thelabel $newlabel
+ }
+ return $thelabel
+ }
+
+ method description {id {newdesc {}}} {
+ Check $id
+ if {[$mytree get $id type] eq "division"} {
+ return -code error "Divisions have no description"
+ }
+ set thedescription [$mytree get $id description]
+ if {
+ ([llength [info level 0]] == 7) &&
+ ($newdesc ne $thedescription)
+ } {
+ # Handle only calls which change the description
+ $mytree set $id description $newdesc
+
+ set thedescription $newdesc
+ }
+ return $thedescription
+ }
+
+ method document {id {newdocid {}}} {
+ Check $id
+ set thedocid {}
+ catch {
+ set thedocid [$mytree get $id document]
+ }
+ if {
+ ([llength [info level 0]] == 7) &&
+ ($newdocid ne $thedocid)
+ } {
+ # Handle only calls which change the document
+ if {$newdocid eq {}} {
+ if {[$mytree get $id type] eq "division"} {
+ $mytree unset $id document
+ } else {
+ return -code error "Illegal to unset document reference in reference entry"
+ }
+ } else {
+ $mytree set $id document $newdocid
+ }
+ set thedocid $newdocid
+ }
+ return $thedocid
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Public methods. Bulk loading and merging.
+
+ method {deserialize =} {data {format {}}} {
+ # Default format is the regular toc serialization
+ if {$format eq {}} {
+ set format serial
+ }
+
+ if {$format ne "serial"} {
+ set data [$self Import $format $data]
+ # doctools::toc::structure verify-as-canonical $data
+ # ImportSerial verifies.
+ }
+
+ $self ImportSerial $data
+ return
+ }
+
+ method {deserialize +=} {data {format {}}} {
+ # Default format is the regular toc serialization
+ if {$format eq {}} {
+ set format serial
+ }
+
+ if {$format ne "serial"} {
+ set data [$self Import $format $data]
+ # doctools::toc::structure verify-as-canonical $data
+ # merge or ImportSerial verify the structure.
+ }
+
+ set data [doctools::toc::structure merge [$self serialize] $data]
+ # doctools::toc::structure verify-as-canonical $data
+ # ImportSerial verifies.
+
+ $self ImportSerial $data
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method serialize {{format {}}} {
+ # Default format is the regular toc serialization
+ if {$format eq {}} {
+ set format serial
+ }
+
+ # First check the cache for a remebered representation of the
+ # toc for the chosen format, and return it, if such is known.
+
+ if {[info exists mytoc($format)]} {
+ return $mytoc($format)
+ }
+
+ # If there is no cached representation we have to generate it
+ # from it from our internal representation.
+
+ if {$format eq "serial"} {
+ return [$self GenerateSerial]
+ } else {
+ return [$self Generate $format]
+ }
+
+ return -code error "Internal error, reached unreachable location"
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal methods
+
+ proc Check {id} {
+ upvar 1 mytree mytree
+ if {![$mytree exists $id]} {
+ return -code error "Bad toc element handle '$id'"
+ }
+ return
+ }
+
+ proc CheckDiv {id} {
+ upvar 1 mytree mytree
+ Check $id
+ if {[$mytree get $id type] ne "division"} {
+ return -code error "toc element handle '$id' does not refer to a division"
+ }
+ }
+
+ method GenerateSerial {} {
+ # We can generate the list serialization easily from the
+ # internal representation.
+
+ # Construct result
+ set serial [list doctools::toc \
+ [list \
+ items [$self GenerateDivision $myroot] \
+ label $mylabel \
+ title $mytitle]]
+
+ # This is just present to assert that the code above creates
+ # correct serializations.
+ doctools::toc::structure verify-as-canonical $serial
+
+ set mytoc(serial) $serial
+ return $serial
+ }
+
+ method GenerateDivision {root} {
+ upvar 1 mytree mytree
+ set div {}
+ foreach id [$mytree children $root] {
+ set etype [$mytree get $id type]
+ set edata {}
+ switch -exact -- $etype {
+ reference {
+ lappend edata \
+ desc [$mytree get $id description] \
+ id [$mytree get $id document] \
+ label [$mytree get $id label]
+ }
+ division {
+ if {[$mytree keyexists $id document]} {
+ lappend edata id [$mytree get $id document]
+ }
+ lappend edata \
+ items [$self GenerateDivision $id] \
+ label [$mytree get $id label]
+ }
+ }
+ lappend div [list $etype $edata]
+ }
+ return $div
+ }
+
+ method Generate {format} {
+ if {$myexporter eq {}} {
+ return -code error "Unable to export from \"$format\", no exporter configured"
+ }
+ set res [$myexporter export object $self $format]
+ set mytoc($format) $res
+ return $res
+ }
+
+ method ImportSerial {serial} {
+ doctools::toc::structure verify $serial iscanonical
+
+ # Kill existing content
+ foreach id [$mytree children $myroot] {
+ $mytree delete $id
+ }
+
+ # Unpack the serialization.
+ array set toc $serial
+ array set toc $toc(doctools::toc)
+ unset toc(doctools::toc)
+
+ # We are setting the relevant variables directly instead of
+ # going through the accessor methods.
+
+ set mytitle $toc(title)
+ set mylabel $toc(label)
+
+ $self ImportDivision $toc(items) $myroot
+
+ # Extend cache (only if canonical, as we return only canonical
+ # data).
+ if {$iscanonical} {
+ set mytoc(serial) $serial
+ }
+ return
+ }
+
+ method ImportDivision {items root} {
+ foreach element $items {
+ foreach {etype edata} $element break
+ #struct::list assign $element etype edata
+ array set toc $edata
+ switch -exact -- $etype {
+ reference {
+ $self + reference $root \
+ $toc(label) $toc(id) $toc(desc)
+ }
+ division {
+ if {[info exists toc(id)]} {
+ set div [$self + division $root $toc(label) $toc(id)]
+ } else {
+ set div [$self + division $root $toc(label)]
+ }
+ $self ImportDivision $toc(items) $div
+ }
+ }
+ unset toc
+ }
+ return
+ }
+
+ method Import {format data} {
+ if {$myimporter eq {}} {
+ return -code error "Unable to import from \"$format\", no importer configured"
+ }
+
+ return [$myimporter import text $data $format]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## State
+
+ # References to export/import managers extending the
+ # (de)serialization abilities of the table of contents.
+ variable myexporter {}
+ variable myimporter {}
+
+ # Internal representation of the table of contents.
+
+ variable mytitle {} ; #
+ variable mylabel {} ; #
+ variable mytree {} ; # Tree object holding the toc.
+ variable myroot {} ; # Name of the tree root node.
+
+ # Array serving as cache holding alternative representations of
+ # the toc generated via 'serialize', i.e. data export.
+
+ variable mytoc -array {}
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::toc 2
+return
diff --git a/tcllib/modules/doctools2toc/container.test b/tcllib/modules/doctools2toc/container.test
new file mode 100644
index 0000000..1037fb9
--- /dev/null
+++ b/tcllib/modules/doctools2toc/container.test
@@ -0,0 +1,53 @@
+# -*- tcl -*-
+# toc.test: Tests for the doctools::toc package. ToC management.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: container.test,v 1.3 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/tree.tcl struct::tree
+ TestAccelInit struct::tree
+
+ use struct/list.tcl struct::list
+ use snit/snit.tcl snit
+ use fileutil/fileutil.tcl fileutil
+ use log/logger.tcl logger
+ use pluginmgr/pluginmgr.tcl pluginmgr
+
+ use doctools2base/config.tcl doctools::config
+ use doctools2base/paths.tcl doctools::paths
+ useLocal export.tcl doctools::toc::export
+ useLocal import.tcl doctools::toc::import
+ use doctools2base/nroff_manmacros.tcl doctools::nroff::man_macros
+
+ source [tcllibPath doctools2base/tests/common]
+}
+testing {
+ useLocalKeep container.tcl doctools::toc
+}
+
+# -------------------------------------------------------------------------
+
+setup_plugins
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::tree impl {
+ source [localPath tests/container_main]
+}
+
+#----------------------------------------------------------------------
+TestAccelExit struct::tree
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2toc/export.tcl b/tcllib/modules/doctools2toc/export.tcl
new file mode 100644
index 0000000..91b7e09
--- /dev/null
+++ b/tcllib/modules/doctools2toc/export.tcl
@@ -0,0 +1,125 @@
+# doctoc.tcl --
+#
+# Exporting indices into other formats.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: export.tcl,v 1.2 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# Each object manages a set of plugins for the conversion of keyword
+# indices into some textual representation. I.e. this object manages
+# the conversion to specialized serializations of keyword indices.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.4
+package require doctools::config
+package require doctools::toc::structure
+package require pluginmgr
+package require snit
+
+# ### ### ### ######### ######### #########
+## API
+
+snit::type ::doctools::toc::export {
+
+ # ### ### ### ######### ######### #########
+ ## Options :: None
+
+ # ### ### ### ######### ######### #########
+ ## Creation, destruction.
+
+ constructor {} {
+ install myconfig using ::doctools::config ${selfns}::config
+ return
+ }
+
+ destructor {
+ $myconfig destroy
+ # Clear the cache of loaded export plugins.
+ foreach k [array names myplugin] {
+ $myplugin($k) destroy
+ }
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Convert from the Tcl toc serialization to other formats.
+
+ method {export object} {obj {format {}}} {
+ return [$self export serial [$obj serialize] $format]
+ }
+
+ method {export serial} {serial {format {}}} {
+ doctools::toc::structure verify $serial iscanonical
+
+ set plugin [$self GetPlugin $format]
+
+ # We have a plugin, now feed it.
+
+ if {!$iscanonical} {
+ set serial [doctools::toc::structure canonicalize $serial]
+ }
+
+ set configuration [$myconfig get]
+ lappend configuration user $::tcl_platform(user)
+ lappend configuraton format [$plugin plugin]
+
+ return [$plugin do export $serial $configuration]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal methods
+
+ method GetPlugin {format} {
+ if {$format eq {}} { set format doctoc }
+
+ if {![info exists myplugin($format)]} {
+ set plugin [pluginmgr ${selfns}::fmt-$format \
+ -pattern doctools::toc::export::* \
+ -api { export } \
+ -setup [mymethod PluginSetup]]
+ ::pluginmgr::paths $plugin doctools::toc::export
+ $plugin load $format
+ set myplugin($format) $plugin
+ } else {
+ set plugin $myplugin($format)
+ }
+
+ return $plugin
+ }
+
+ method PluginSetup {mgr ip} {
+ # Inject a pseudo package into the plugin interpreter the
+ # formatters can use to check that they were loaded into a
+ # proper environment.
+ $ip eval {package provide doctools::toc::export::plugin 1}
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## State
+
+ # Array serving as a cache for the various plugin managers holding
+ # a specific export plugin.
+
+ variable myplugin -array {}
+
+ # A component managing the configuration given to the export
+ # plugins when they are invoked.
+
+ component myconfig -public config
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::toc::export 0.1
+return
diff --git a/tcllib/modules/doctools2toc/export.test b/tcllib/modules/doctools2toc/export.test
new file mode 100644
index 0000000..d5e3f9d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/export.test
@@ -0,0 +1,212 @@
+# -*- tcl -*-
+# toc.test: tests for the doctools::toc package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export.test,v 1.2 2009/04/29 02:10:56 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+
+ use struct/list.tcl struct::list
+ use snit/snit.tcl snit
+ use log/logger.tcl logger
+ use pluginmgr/pluginmgr.tcl pluginmgr
+
+ use doctools2base/config.tcl doctools::config
+ useLocal structure.tcl doctools::toc::structure
+ use doctools2base/nroff_manmacros.tcl doctools::nroff::man_macros
+
+ source [tcllibPath doctools2base/tests/common]
+}
+testing {
+ useLocalKeep export.tcl doctools::toc::export
+}
+
+# -------------------------------------------------------------------------
+
+setup_plugins
+
+# -------------------------------------------------------------------------
+
+test doctools-toc-export-1.0 {export object, wrong#args} -setup {
+ doctools::toc::export E
+} -body {
+ E export object
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::export::Snit_hmethodexport_object type selfns win self obj ?format?"}
+
+test doctools-toc-export-1.1 {export object, wrong#args} -setup {
+ doctools::toc::export E
+} -body {
+ E export object O F XXX
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::export::Snit_hmethodexport_object type selfns win self obj ?format?"}
+
+test doctools-toc-export-2.0 {export serial, wrong#args} -setup {
+ doctools::toc::export E
+} -body {
+ E export serial
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::export::Snit_hmethodexport_serial type selfns win self serial ?format?"}
+
+test doctools-toc-export-2.1 {export serial, wrong#args} -setup {
+ doctools::toc::export E
+} -body {
+ E export serial S F XXX
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::export::Snit_hmethodexport_serial type selfns win self serial ?format?"}
+
+test doctools-toc-export-5.0 {config names, wrong#args} -setup {
+ doctools::toc::export E
+} -body {
+ E config names X
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodnames type selfns win self"}
+
+test doctools-toc-export-6.0 {config get, wrong#args} -setup {
+ doctools::toc::export E
+} -body {
+ E config get X
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodget type selfns win self"}
+
+test doctools-toc-export-7.0 {config set, wrong#args} -setup {
+ doctools::toc::export E
+} -body {
+ E config set
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodset type selfns win self name ?value?"}
+
+test doctools-toc-export-7.1 {config set, wrong#args} -setup {
+ doctools::toc::export E
+} -body {
+ E config set N V X
+} -cleanup {
+ E destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodset type selfns win self name ?value?"}
+
+# -------------------------------------------------------------------------
+
+test doctools-toc-export-12.0 {config set, define single var} -setup {
+ doctools::toc::export E
+} -body {
+ E config set N V
+ E config get
+} -cleanup {
+ E destroy
+} -result {N V}
+
+test doctools-toc-export-12.1 {config set, define multiple vars} -setup {
+ doctools::toc::export E
+} -body {
+ E config set N V
+ E config set A B
+ dictsort [E config get]
+} -cleanup {
+ E destroy
+} -result {A B N V}
+
+test doctools-toc-export-12.2 {config set, as query} -setup {
+ doctools::toc::export E
+ E config set N V
+} -body {
+ E config set N
+} -cleanup {
+ E destroy
+} -result V
+
+test doctools-toc-export-13.0 {config unset, all} -setup {
+ doctools::toc::export E
+ E config set N V
+} -body {
+ E config unset
+ E config get
+} -cleanup {
+ E destroy
+} -result {}
+
+test doctools-toc-export-13.1 {config unset, by exact name} -setup {
+ doctools::toc::export E
+ E config set N V
+ E config set A B
+} -body {
+ E config unset N
+ E config get
+} -cleanup {
+ E destroy
+} -result {A B}
+
+test doctools-toc-export-13.2 {config unset, by glob pattern} -setup {
+ doctools::toc::export E
+ E config set N V
+ E config set N' V'
+ E config set A B
+} -body {
+ E config unset N*
+ E config get
+} -cleanup {
+ E destroy
+} -result {A B}
+
+test doctools-toc-export-14.0 {config names, empty} -setup {
+ doctools::toc::export E
+} -body {
+ E config names
+} -cleanup {
+ E destroy
+} -result {}
+
+test doctools-toc-export-14.1 {config names, with variables} -setup {
+ doctools::toc::export E
+ E config set N V
+ E config set A B
+} -body {
+ lsort -dict [E config names]
+} -cleanup {
+ E destroy
+} -result {A N}
+
+test doctools-toc-export-15.0 {config get, empty} -setup {
+ doctools::toc::export E
+} -body {
+ E config get
+} -cleanup {
+ E destroy
+} -result {}
+
+test doctools-toc-export-15.1 {config get, with variables} -setup {
+ doctools::toc::export E
+ E config set N V
+ E config set A B
+} -body {
+ dictsort [E config get]
+} -cleanup {
+ E destroy
+} -result {A B N V}
+
+# toc_export tests, numbering starts at 20
+# -------------------------------------------------------------------------
+
+source [localPath tests/export]
+
+# -------------------------------------------------------------------------
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2toc/export_doctoc.man b/tcllib/modules/doctools2toc/export_doctoc.man
new file mode 100644
index 0000000..f7ddd4d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/export_doctoc.man
@@ -0,0 +1,7 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE doctoc]
+[vset NAME doctoc]
+[vset REQUIRE null]
+[vset CONFIG doctoc]
+[vset VERSION 0.1]
+[include include/export/plugin.inc]
diff --git a/tcllib/modules/doctools2toc/export_doctoc.tcl b/tcllib/modules/doctools2toc/export_doctoc.tcl
new file mode 100644
index 0000000..27d6aa2
--- /dev/null
+++ b/tcllib/modules/doctools2toc/export_doctoc.tcl
@@ -0,0 +1,217 @@
+# doctoc.tcl --
+#
+# The doctoc export plugin. Generation of doctoc markup.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: export_doctoc.tcl,v 1.3 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# This package is a plugin for the doctools::toc v2 system. It takes
+# the list serialization of a table of contens and produces text in
+# doctoc format.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: doctools::toc::export::plugin
+
+package require Tcl 8.4
+package require doctools::toc::export::plugin ; # Presence of this
+ # pseudo package
+ # indicates execution
+ # inside of a properly
+ # initialized plugin
+ # interpreter.
+package require doctools::toc::structure ; # Verification that
+ # the input is proper.
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc export {serial configuration} {
+
+ # Phase I. Check that we got a canonical ToC serialization. That
+ # makes the unpacking easier, as we can mix it with the
+ # generation of the output, knowing that everything is
+ # already sorted as it should be.
+
+ ::doctools::toc::structure verify-as-canonical $serial
+
+ # ### ### ### ######### ######### #########
+ # Configuration ...
+ # * Standard entries
+ # - user = person running the application doing the formatting
+ # - format = name of this format
+ # - file = name of the file the ToC came from. Optional.
+ # - map = maps symbolic document ids to actual file path or url. Optional.
+ # * doctoc specific entries
+ # - newlines = boolean. tags separated by eol markers
+ # - indented = boolean. tags indented per the toc structure.
+ # - aligned = boolean. reference information tabular aligned within keys.
+ #
+ # Notes
+ # * This format ignores 'map' even if set, as the written doctoc
+ # contains the symbolic document ids and only them.
+ # * aligned => newlines
+ # * indented => newlines
+
+ # Combinations of the format specific entries
+ # N I A |
+ # - - - + ---------------------
+ # 0 0 0 | Ultracompact (no whitespace, single line)
+ # 1 0 0 | Compact (no whitespace, multiple lines)
+ # 1 1 0 | Indented
+ # 1 0 1 | Tabular aligned references
+ # 1 1 1 | Indented + Tabular aligned references
+ # - - - + ---------------------
+ # 0 1 0 | Not possible, per the implications above.
+ # 0 0 1 | ditto
+ # 0 1 1 | ditto
+ # - - - + ---------------------
+
+ # Import the configuration and initialize the internal state
+ array set config {
+ newlines 0
+ aligned 0
+ indented 0
+ }
+ array set config $configuration
+
+ # Force the implications mentioned in the notes above.
+ if {
+ $config(aligned) ||
+ $config(indented)
+ } {
+ set config(newlines) 1
+ }
+
+ # ### ### ### ######### ######### #########
+
+ # Phase II. Generate the output, taking the configuration into
+ # account.
+
+ TagsBegin
+
+ # First some comments about the provenance of the output.
+ Tag+ comment [list "Generated @ [clock format [clock seconds]]"]
+ Tag+ comment [list "By $config(user)"]
+ if {[info exists config(file)] && ($config(file) ne {})} {
+ Tag+ comment [list "From file $config(file)"]
+ }
+
+ # Unpack the serialization.
+ array set toc $serial
+ array set toc $toc(doctools::toc)
+ unset toc(doctools::toc)
+
+ # Now open the markup
+
+ Tag+ toc_begin [list $toc(label) $toc(title)]
+ PrintItems $toc(items) { } { }
+ TagPrefix {}
+ Tag+ toc_end
+
+ # Last formatting, joining the commands together.
+ set sep [expr {$config(newlines) ? "\n" : ""}]
+ return [join $lines $sep]
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+
+proc PrintItems {items indentation increment} {
+ upvar 1 config config prefix prefix lines lines
+
+ if {$config(aligned)} {
+ set imax 0
+ set lmax 0
+ foreach element $items {
+ foreach {etype edata} $element break
+ if {$etype eq "division"} { continue }
+ array set toc $edata
+ Max imax [list $toc(id)]
+ Max lmax [list $toc(label)]
+ unset toc
+ }
+ }
+
+ foreach element $items {
+ if {$config(indented)} {TagPrefix $indentation}
+ foreach {etype edata} $element break
+ array set toc $edata
+ switch -exact -- $etype {
+ reference {
+ if {$config(aligned)} {
+ Tag+ item [FmtR imax $toc(id)] [FmtR lmax $toc(label)] [list $toc(desc)]
+ } else {
+ Tag+ item [list $toc(id) $toc(label) $toc(desc)]
+ }
+ }
+ division {
+ if {[info exists toc(id)]} {
+ Tag+ division_start [list $toc(label) $toc(id)]
+ } else {
+ Tag+ division_start [list $toc(label)]
+ }
+ PrintItems $toc(items) $indentation$increment $increment
+ if {$config(indented)} {TagPrefix $indentation}
+ Tag+ division_end
+ }
+ }
+ unset toc
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+
+proc TagPrefix {str} {
+ upvar 1 prefix prefix
+ set prefix $str
+ return
+}
+
+proc TagsBegin {} {
+ upvar 1 prefix prefix lines lines
+ set prefix {}
+ set lines {}
+ return
+}
+
+proc Tag {n args} {
+ upvar 1 prefix prefix
+ set cmd $prefix
+ append cmd \[$n
+ if {[llength $args]} { append cmd " [join $args]" }
+ append cmd \]
+ return $cmd
+}
+
+proc Tag+ {n args} {
+ upvar 1 prefix prefix lines lines
+ lappend lines [eval [linsert $args 0 Tag $n]]
+ return
+}
+
+proc Max {v str} {
+ upvar 1 $v max
+ set x [string length $str]
+ if {$x <= $max} return
+ set max $x
+ return
+}
+
+proc FmtR {v str} {
+ upvar 1 $v max
+ return [list $str][string repeat { } [expr {$max - [string length [list $str]]}]]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::toc::export::doctoc 0.1
+return
diff --git a/tcllib/modules/doctools2toc/export_doctoc.test b/tcllib/modules/doctools2toc/export_doctoc.test
new file mode 100644
index 0000000..55ad846
--- /dev/null
+++ b/tcllib/modules/doctools2toc/export_doctoc.test
@@ -0,0 +1,77 @@
+# -*- tcl -*-
+# toc_export_doctoc.test: tests for the doctools::toc::export::doctoc package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export_doctoc.test,v 1.2 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ useLocal structure.tcl doctools::toc::structure
+}
+testing {
+ package provide doctools::toc::export::plugin 1
+ # The above fakes the export plugin environment.
+
+ useLocal export_doctoc.tcl doctools::toc::export::doctoc
+}
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-toc-export-doctoc-1.0 {export, wrong#args} -body {
+ export
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-toc-export-doctoc-1.1 {export, wrong#args} -body {
+ export S
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-toc-export-doctoc-1.2 {export, wrong#args} -body {
+ export S C XXX
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+# -------------------------------------------------------------------------
+
+# Testing the generation of doctoc output, from toc serialization,
+# for all possible plugin configurations.
+
+foreach {k nl in al name} {
+ 0 0 0 0 ultracompact
+ 1 1 0 0 compact
+ 2 1 1 0 indented
+ 3 1 0 1 aligned
+ 4 1 1 1 indalign
+ 5 0 1 0 indented
+ 6 0 0 1 aligned
+ 7 0 1 1 indalign
+} {
+ TestFilesProcess $mytestdir ok serial doctoc-$name -> n label input data expected {
+ test doctools-toc-export-doctoc-2.$k.$n "doctools::toc::export::doctoc, ${label}-$name, ok" -setup {
+ set configuration [list newlines $nl indented $in aligned $al user _dummy_]
+ } -body {
+ stripcomments [export $data $configuration]
+ } -cleanup {
+ unset configuration
+ } -result $expected
+ }
+}
+
+#----------------------------------------------------------------------
+unset n label input data expected
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2toc/export_html.tcl b/tcllib/modules/doctools2toc/export_html.tcl
new file mode 100644
index 0000000..bfdbeed
--- /dev/null
+++ b/tcllib/modules/doctools2toc/export_html.tcl
@@ -0,0 +1,323 @@
+# text.tcl --
+#
+# The HTML export plugin. Generation of HTML markup.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: export_html.tcl,v 1.3 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# This package is a plugin for the doctools::toc v2 system. It takes
+# the list serialization of a table of contents and produces text in
+# HTML format.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: doctools::toc::export::plugin
+
+package require Tcl 8.4
+package require doctools::toc::export::plugin ; # Presence of this
+ # pseudo package
+ # indicates execution
+ # inside of a properly
+ # initialized plugin
+ # interpreter.
+package require doctools::toc::structure ; # Verification that the
+ # input is proper.
+package require doctools::html
+package require doctools::html::cssdefaults
+
+doctools::html::import ;# -> ::html::*
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc export {serial configuration} {
+
+ # Phase I. Check that we got a canonical toc serialization. That
+ # makes the unpacking easier, as we can mix it with the
+ # generation of the output, knowing that everything is
+ # already sorted as it should be.
+
+ ::doctools::toc::structure verify-as-canonical $serial
+
+ # ### ### ### ######### ######### #########
+ # Configuration ...
+ # * Standard entries
+ # - user = person running the application doing the formatting
+ # - format = name of this format
+ # - file = name of the file the toc came from. Optional.
+ # - map = maps symbolic references to actual file path. Optional.
+
+ # * HTML specific entries
+ # - newlines = boolean. tags separated by eol markers
+ # - indented = boolean. tags indented per their nesting structure.
+ # //layout = string in { list, table }.
+ #
+ # - meta = HTML fragment for use within the document <meta> section.
+ # - header = HTML fragment used immediately after <body>
+ # - footer = HTML fragment used immediately before </body>
+ #
+ # - rid = dictionary mapping element labels to link anchor names.
+ # <=> Reference IDentifier
+ #
+ # Notes
+ # * indented => newlines
+
+ # Import the configuration and initialize the internal state
+ #// layout list
+ array set config {
+ newlines 0
+ indented 0
+ meta {}
+ header {}
+ footer {}
+ rid {}
+ map {}
+ sepline ------------------------------------------------------------
+ class.main doctools
+ class.header toc-header
+ class.title toc-title
+ class.navsep toc-navsep
+ class.contents toc-contents
+ class.ref toc-ref
+ class.div toc-div
+ class.footer toc-footer
+ }
+ array set config $configuration
+ array set map $config(map)
+ array set rid $config(rid)
+
+ # Force the implications mentioned in the notes above.
+ if {$config(indented)} {
+ set config(newlines) 1
+ }
+
+ # Allow structuring comments iff structure is present.
+ set config(comments) [expr {$config(indented) || $config(newlines)}]
+
+ # ### ### ### ######### ######### #########
+
+ # Phase II. Generate the output, taking the configuration into
+ # account.
+
+ # Unpack the serialization.
+ array set toc $serial
+ array set toc $toc(doctools::toc)
+ unset toc(doctools::toc)
+
+ html::begin
+ # Configure the layouting
+ if {!$config(indented)} { html::indenting 0 }
+ if {!$config(newlines)} { html::newlines 0 }
+
+ html::tag* html {
+ html::newline ; html::indented 4 {
+ Header
+ Provenance
+ Body
+ }
+ }
+
+ return [html::done]
+}
+
+# ### ### ### ######### ######### #########
+
+proc Header {} {
+ upvar 1 config config toc toc
+ html::tag* head {
+ html::newline ; html::indented 4 {
+ html::tag= title [Title] ; html::newline
+ if {![Extend meta]} {
+ html::tag* style {
+ DefaultStyle
+ } ; html::newline
+ }
+ }
+ } ; html::newline
+ return
+}
+
+proc Provenance {} {
+ upvar 1 config config
+ if {!$config(comments)} return
+ html::comment [html::collect {
+ html::indented 4 {
+ html::+ "Generated @ [clock format [clock seconds]]" ; html::newline
+ html::+ "By $config(user)" ; html::newline
+ if {[info exists config(file)] && ($config(file) ne {})} {
+ html::+ "From file $config(file)" ; html::newline
+ }
+ }
+ }] ; html::newline
+ return
+}
+
+proc Body {} {
+ upvar 1 config config rid rid toc toc
+ html::tag* body {
+ html::newline ; html::indented 4 {
+ html::tag* div class $config(class.main) {
+ html::newline ; html::indented 4 {
+ html::tag* div class $config(class.header) {
+ html::newline ; html::indented 4 {
+ BodyTitle
+ UserHeader
+ html::tag1 hr class $config(class.navsep) ; html::newline
+ }
+ } ; html::newline
+ Division $toc(items) {} {Table Of Contents}
+ html::tag* div class $config(class.footer) {
+ html::newline ; html::indented 4 {
+ html::tag1 hr class $config(class.navsep) ; html::newline
+ UserFooter
+ }
+ } ; html::newline
+ }
+ } ; html::newline
+ }
+ } ; html::newline
+ return
+}
+
+# ### ### ### ######### ######### #########
+
+proc BodyTitle {} {
+ upvar 1 toc toc config config
+ html::tag= h1 class $config(class.title) [Title] ; html::newline
+ return
+}
+
+proc UserHeader {} {
+ upvar 1 config config
+ Extend header
+ html::newline
+ return
+}
+
+proc UserFooter {} {
+ upvar 1 config config
+ Extend footer
+ html::newline
+ return
+}
+
+# ### ### ### ######### ######### #########
+
+proc Title {} {
+ upvar 1 toc(label) label toc(title) title
+ if {($label ne {}) && ($title ne {})} {
+ return "$label -- $title"
+ } elseif {$label ne {}} {
+ return $label
+ } elseif {$title ne {}} {
+ return $title
+ }
+ return -code error {Reached the unreachable}
+}
+
+proc DefaultStyle {} {
+ html::comment \n[doctools::html::cssdefaults::contents]
+ return
+}
+
+# ### ### ### ######### ######### #########
+
+proc Division {items path seplabel} {
+ upvar 1 config config rid rid map map
+
+ # No content for an empty division
+ if {![llength $items]} return
+
+ # Process the elements in a division.
+
+ Separator "Start $seplabel"
+
+ html::tag* dl class $config(class.contents) {
+ html::newline ; html::indented 4 {
+ foreach element $items {
+ foreach {etype edata} $element break
+ array set e $edata
+ switch -exact -- $etype {
+ reference {
+ html::tag* dt class $config(class.ref) {
+ RMap $e(label)
+ html::tag= a href [Map $e(id)] $e(label)
+ }
+ html::newline
+ html::tag= dd class $config(class.ref) $e(desc)
+ html::newline
+ }
+ division {
+ html::tag* dt class $config(class.div) {
+ RMap $e(label)
+ if {[info exists e(id)]} {
+ html::tag= a href [Map $e(id)] $e(label)
+ } else {
+ html::+ $e(label)
+ }
+ }
+ html::newline
+ html::tag* dd class $config(class.div) {
+ html::newline ; html::indented 4 {
+ Division $e(items) [linsert $path end $e(label)] "Division ($e(label))"
+ }
+ } ; html::newline
+ }
+ }
+ unset e
+ }
+ }
+ } ; html::newline
+ Separator "Stop $seplabel"
+}
+
+# ### ### ### ######### ######### #########
+
+proc Separator {{text {}}} {
+ upvar config config
+ if {!$config(comments)} return
+ set str $config(sepline)
+ if {$text ne {}} {
+ set new " $text "
+ set str [string replace $str 1 [string length $new] $new]
+ }
+ html::comment $str
+ html::newline
+ return
+}
+
+proc Map {id} {
+ upvar 1 map map
+ if {![info exists map($id)]} { return $id }
+ return $map($id)
+}
+
+proc RMap {label} {
+ upvar 1 rid rid path path
+ set k [linsert $path end $label]
+ if {![info exists rid($k)]} return
+ html::tag/ a name $rid($k)
+}
+
+proc Extend {varname} {
+ upvar 1 config config
+ if {$config($varname) eq {}} {
+ if {$config(comments)} {
+ html::comment "Customization Point: $varname"
+ }
+ return 0
+ }
+ html::+++ $config($varname)
+ return 1
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::toc::export::html 0.1
+return
diff --git a/tcllib/modules/doctools2toc/export_html.test b/tcllib/modules/doctools2toc/export_html.test
new file mode 100644
index 0000000..d5f2f30
--- /dev/null
+++ b/tcllib/modules/doctools2toc/export_html.test
@@ -0,0 +1,76 @@
+# -*- tcl -*-
+# toc_export_html.test: tests for the doctools::toc::export::html package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export_html.test,v 1.2 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ useLocal structure.tcl doctools::toc::structure
+ use doctools2base/text.tcl doctools::text
+ use doctools2base/html.tcl doctools::html
+ use doctools2base/html_cssdefaults.tcl doctools::html::cssdefaults
+}
+testing {
+ package provide doctools::toc::export::plugin 1
+ # The above fakes the export plugin environment.
+
+ useLocal export_html.tcl doctools::toc::export::html
+}
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-toc-export-html-1.0 {export, wrong#args} -body {
+ export
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-toc-export-html-1.1 {export, wrong#args} -body {
+ export S
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-toc-export-html-1.2 {export, wrong#args} -body {
+ export S C XXX
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+# -------------------------------------------------------------------------
+
+# Testing the generation of html output, from toc serialization,
+# for all possible plugin configurations.
+
+foreach {k nl in section} {
+ 0 0 0 -ultracompact
+ 1 0 1 -indented
+ 2 1 0 -compact
+ 3 1 1 -indented
+} {
+ TestFilesProcess $mytestdir ok serial html$section -> n label input data expected {
+ test doctools-toc-export-html-2.$k.$n "doctools::toc::export::html, $label$section, ok" -setup {
+ set configuration [list newlines $nl indented $in user _dummy_]
+ } -body {
+ striphtmlcomments [export $data $configuration] 3
+ } -cleanup {
+ unset configuration
+ } -result $expected
+ }
+}
+
+#----------------------------------------------------------------------
+unset n label input data expected
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2toc/export_json.tcl b/tcllib/modules/doctools2toc/export_json.tcl
new file mode 100644
index 0000000..7051f59
--- /dev/null
+++ b/tcllib/modules/doctools2toc/export_json.tcl
@@ -0,0 +1,223 @@
+# json.tcl --
+#
+# The JSON export plugin. Generation of Java Script Object Notation.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: export_json.tcl,v 1.3 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# This package is a plugin for the doctools::toc v2 system. It takes
+# the list serialization of a table of contents and produces text in
+# JSON format.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: doctools::toc::export::plugin
+
+package require Tcl 8.4
+package require doctools::toc::export::plugin ; # Presence of this
+ # pseudo package
+ # indicates execution
+ # inside of a properly
+ # initialized plugin
+ # interpreter.
+package require doctools::toc::structure ; # Verification that
+ # the input is proper.
+package require textutil::adjust
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc export {serial configuration} {
+
+ # Phase I. Check that we got a canonical toc serialization. That
+ # makes the unpacking easier, as we can mix it with the
+ # generation of the output, knowing that everything is
+ # already sorted as it should be.
+
+ ::doctools::toc::structure verify-as-canonical $serial
+
+ # ### ### ### ######### ######### #########
+ # Configuration ...
+ # * Standard entries
+ # - user = person running the application doing the formatting
+ # - format = name of this format
+ # - file = name of the file the toc came from. Optional.
+ # - map = maps symbolic references to actual file path. Optional.
+ # * json/format specific entries
+ # - indented = boolean. objects indented per the toc structure.
+ # - aligned = boolean. object keys tabular aligned vertically.
+ #
+ # Notes
+ # * This format ignores 'map' even if set, as the written json
+ # contains the symbolic references and only them.
+ # * aligned => indented
+
+ # Combinations of the format specific entries
+ # N I A |
+ # - - - + ---------------------
+ # 0 0 0 | Ultracompact (no whitespace, single line)
+ # 1 0 0 | Compact (no whitespace, multiple lines)
+ # 1 1 0 | Indented
+ # 1 0 1 | Tabular aligned references
+ # 1 1 1 | Indented + Tabular aligned references
+ # - - - + ---------------------
+ # 0 1 0 | Not possible, per the implications above.
+ # 0 0 1 | ditto
+ # 0 1 1 | ditto
+ # - - - + ---------------------
+
+ # Import the configuration and initialize the internal state
+ array set config {
+ indented 0
+ aligned 0
+ }
+ array set config $configuration
+
+ # Force the implications mentioned in the notes above.
+ if {$config(aligned)} {
+ set config(indented) 1
+ }
+
+ # ### ### ### ######### ######### #########
+
+ # Phase II. Generate the output, taking the configuration into
+ # account. We construct this from the inside out.
+
+ # Unpack the serialization.
+ array set toc $serial
+ array set toc $toc(doctools::toc)
+ unset toc(doctools::toc)
+
+ return [JsonObject doctools::toc \
+ [JsonObject \
+ items [ProcessDivision $toc(items)] \
+ label [JsonString $toc(label)] \
+ title [JsonString $toc(title)]]]
+
+ # ### ### ### ######### ######### #########
+}
+
+proc ProcessDivision {items} {
+ upvar 1 config config
+ set result {}
+
+ foreach element $items {
+ foreach {etype edata} $element break
+ array set toc $edata
+ switch -exact -- $etype {
+ reference {
+ set edata [JsonObject \
+ desc [JsonString $toc(desc)] \
+ id [JsonString $toc(id)] \
+ label [JsonString $toc(label)]]
+ }
+ division {
+ set edata {}
+ if {[info exists toc(id)]} { lappend edata id [JsonString $toc(id)] }
+ lappend edata \
+ items [ProcessDivision $toc(items)] \
+ label [JsonString $toc(label)]
+ set edata [JsonObjectDict $edata]
+ }
+ }
+ unset toc
+ lappend result [JsonObject $etype $edata]
+ }
+
+ return [JsonArrayList $result]
+}
+
+# ### ### ### ######### ######### #########
+
+proc JsonQuotes {} {
+ return [list "\"" "\\\"" / \\/ \\ \\\\ \b \\b \f \\f \n \\n \r \\r \t \\t]
+}
+
+proc JsonString {s} {
+ return "\"[string map [JsonQuotes] $s]\""
+}
+
+proc JsonArray {args} {
+ upvar 1 config config
+ return [JsonArrayList $args]
+}
+
+proc JsonArrayList {list} {
+ # compact form.
+ return "\[[join $list ,]\]"
+}
+
+proc JsonObject {args} {
+ upvar 1 config config
+ return [JsonObjectDict $args]
+}
+
+proc JsonObjectDict {dict} {
+ # The dict maps string keys to json-formatted data. I.e. we have
+ # to quote the keys, but not the values, as the latter are already
+ # in the proper format.
+ upvar 1 config config
+
+ set tmp {}
+ foreach {k v} $dict { lappend tmp [JsonString $k] $v }
+ set dict $tmp
+
+ if {$config(aligned)} { Align $dict max }
+
+ if {$config(indented)} {
+ set content {}
+ foreach {k v} $dict {
+ if {$config(aligned)} { set k [FmtR max $k] }
+ if {[string match *\n* $v]} {
+ # multi-line value
+ lappend content " $k : [textutil::adjust::indent $v { } 1]"
+ } else {
+ # single line value.
+ lappend content " $k : $v"
+ }
+ }
+ if {[llength $content]} {
+ return "\{\n[join $content ,\n]\n\}"
+ } else {
+ return "\{\}"
+ }
+ } else {
+ # ultra compact form.
+ set tmp {}
+ foreach {k v} $dict { lappend tmp "$k:$v" }
+ return "\{[join $tmp ,]\}"
+ }
+}
+
+proc Align {dict mv} {
+ upvar 1 $mv max
+ # Generate a list of references sortable by name, and also find the
+ # max length of all relevant names.
+ set max 0
+ foreach {str _} $dict { Max max $str }
+ return
+}
+
+proc Max {v str} {
+ upvar 1 $v max
+ set x [string length $str]
+ if {$x <= $max} return
+ set max $x
+ return
+}
+
+proc FmtR {v str} {
+ upvar 1 $v max
+ return $str[string repeat { } [expr {$max - [string length $str]}]]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::toc::export::json 0.1
+return
diff --git a/tcllib/modules/doctools2toc/export_json.test b/tcllib/modules/doctools2toc/export_json.test
new file mode 100644
index 0000000..dc9c772
--- /dev/null
+++ b/tcllib/modules/doctools2toc/export_json.test
@@ -0,0 +1,74 @@
+# -*- tcl -*-
+# toc_export_json.test: tests for the doctools::toc::export::json package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export_json.test,v 1.2 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+ useLocal structure.tcl doctools::toc::structure
+}
+testing {
+ package provide doctools::toc::export::plugin 1
+ # The above fakes the export plugin environment.
+
+ useLocal export_json.tcl doctools::toc::export::json
+}
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-toc-export-json-1.0 {export, wrong#args} -body {
+ export
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-toc-export-json-1.1 {export, wrong#args} -body {
+ export S
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-toc-export-json-1.2 {export, wrong#args} -body {
+ export S C XXX
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+# -------------------------------------------------------------------------
+
+# Testing the generation of json output, from toc serialization,
+# for all possible plugin configurations.
+
+foreach {k in al section} {
+ 0 0 0 -ultracompact
+ 1 1 0 -indented
+ 2 0 1 -indalign
+ 3 1 1 -indalign
+} {
+ TestFilesProcess $mytestdir ok serial json$section -> n label input data expected {
+ test doctools-toc-export-json-2.$k.$n "doctools::toc::export::json, $label$section, ok" -setup {
+ set configuration [list indented $in aligned $al]
+ } -body {
+ export $data $configuration
+ } -cleanup {
+ unset configuration
+ } -result $expected
+ }
+}
+
+#----------------------------------------------------------------------
+unset n label input data expected
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2toc/export_nroff.tcl b/tcllib/modules/doctools2toc/export_nroff.tcl
new file mode 100644
index 0000000..28a7d66
--- /dev/null
+++ b/tcllib/modules/doctools2toc/export_nroff.tcl
@@ -0,0 +1,218 @@
+# text.tcl --
+#
+# The NROFF export plugin. Generation of man.macros based nroff markup.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: export_nroff.tcl,v 1.4 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# This package is a plugin for the doctools::toc v2 system. It takes
+# the list serialization of a table of contents and produces text in
+# nroff format, man.macros based.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: doctools::toc::export::plugin
+
+package require Tcl 8.4
+package require doctools::toc::export::plugin ; # Presence of this
+ # pseudo package
+ # indicates execution
+ # inside of a properly
+ # initialized plugin
+ # interpreter.
+package require doctools::toc::structure ; # Verification that the
+ # input is proper.
+package require doctools::text ; # Text assembly package
+package require doctools::nroff::man_macros ; # Macro definitions for result.
+
+doctools::text::import ;# -> ::text::*
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc export {serial configuration} {
+
+ # Phase I. Check that we got a canonical toc serialization. That
+ # makes the unpacking easier, as we can mix it with the
+ # generation of the output, knowing that everything is
+ # already sorted as it should be.
+
+ ::doctools::toc::structure verify-as-canonical $serial
+
+ # ### ### ### ######### ######### #########
+ # Configuration ...
+ # * Standard entries
+ # - user = person running the application doing the formatting
+ # - format = name of this format
+ # - file = name of the file the toc came from. Optional.
+ # - map = maps symbolic references to actual file path. Ignored
+ #
+ # Specific
+ # - inline = boolean. if set (default) man.macros is inlined in
+ # the output. other a .so reference to the file is
+ # generated.
+
+ # Import the configuration and initialize the internal state
+
+ array set config {
+ inline 1
+ }
+ array set config $configuration
+
+ # ### ### ### ######### ######### #########
+
+ # Phase II. Generate the output, taking the configuration into
+ # account.
+
+ # Unpack the serialization.
+ array set toc $serial
+ array set toc $toc(doctools::toc)
+ unset toc(doctools::toc)
+
+ text::begin
+ text::indenting 0 ; # Just in case someone tries to.
+
+ Provenance
+ if {$config(inline)} {
+ text::newline?
+ text::+ [doctools::nroff::man_macros::contents]
+ } else {
+ .so man.macros
+ }
+ .TH $toc(label)
+ .SH {table of contents}
+ if {$toc(title) ne {}} {
+ text::+ $toc(title)
+ }
+
+ Division $toc(items)
+ return [text::done]
+}
+
+proc Division {items} {
+ if {![llength $items]} return
+ .RS
+
+ foreach element $items {
+ foreach {etype edata} $element break
+ array set e $edata
+ switch -exact -- $etype {
+ reference {
+ .TP [BOLD $e(label)]
+ text::newline
+ text::+ $e(desc)
+ text::newline
+ }
+ division {
+ .TP [BOLD $e(label)]
+ text::newline
+ Division $e(items)
+ }
+ }
+ unset e
+ }
+ .RE
+ return
+}
+
+# ### ### ### ######### ######### #########
+
+proc Provenance {} {
+ upvar 1 config config
+ COMMENT "Generated @ [clock format [clock seconds]]"
+ COMMENT "By $config(user)"
+ if {[info exists config(file)] && ($config(file) ne {})} {
+ COMMENT "From file $config(file)"
+ }
+ return
+}
+
+proc .so {file} {
+ text::newline?
+ text::+ ".so $file"
+ text::newline
+ return
+}
+
+proc .TP {text} {
+ text::newline?
+ text::+ .TP
+ text::newline
+ text::+ $text
+ return
+}
+
+proc COMMENT {text} {
+ set pfx "'\\\" " ;#
+ text::newline?
+
+ foreach line [split $text \n] {
+ text::+ $pfx
+ text::+ $line
+ text::newline
+ }
+ #text::+ $pfx[join [split $text \n] \n$pfx]
+ return
+}
+
+proc BOLD {text} {
+ return \\fB$text\\fR
+}
+
+proc .RS {} {
+ text::newline?
+ text::+ .RS
+ text::newline
+ return
+}
+
+proc .RE {} {
+ text::newline?
+ text::+ .RE
+ text::newline
+ return
+}
+
+proc .PP {} {
+ text::newline?
+ text::+ .PP
+ text::newline
+ return
+}
+
+proc .SH {name} {
+ text::newline?
+ text::+ ".SH "
+ set hasspaces [regexp {[ ]} $name]
+ set name [string toupper $name]
+
+ if {$hasspaces} { text::+ \" }
+ text::+ $name
+ if {$hasspaces} { text::+ \" }
+ text::newline
+ return
+}
+
+proc .TH {name} {
+ text::newline?
+ text::+ ".TH "
+ set hasspaces [regexp {[ ]} $name]
+ set name [string toupper $name]
+
+ if {$hasspaces} { text::+ \" }
+ text::+ $name
+ if {$hasspaces} { text::+ \" }
+ text::newline
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::toc::export::nroff 0.2
+return
diff --git a/tcllib/modules/doctools2toc/export_nroff.test b/tcllib/modules/doctools2toc/export_nroff.test
new file mode 100644
index 0000000..bae5dd3
--- /dev/null
+++ b/tcllib/modules/doctools2toc/export_nroff.test
@@ -0,0 +1,73 @@
+# -*- tcl -*-
+# toc_export_nroff.test: tests for the doctools::toc::export::nroff package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export_nroff.test,v 1.3 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ useLocal structure.tcl doctools::toc::structure
+ use doctools2base/text.tcl doctools::text
+ use doctools2base/nroff_manmacros.tcl doctools::nroff::man_macros
+}
+testing {
+ package provide doctools::toc::export::plugin 1
+ # The above fakes the export plugin environment.
+
+ useLocal export_nroff.tcl doctools::toc::export::nroff
+}
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-toc-export-nroff-1.0 {export, wrong#args} -body {
+ export
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-toc-export-nroff-1.1 {export, wrong#args} -body {
+ export S
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-toc-export-nroff-1.2 {export, wrong#args} -body {
+ export S C XXX
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+# -------------------------------------------------------------------------
+
+# Testing the generation of nroff output, from toc serialization,
+# for all possible plugin configurations.
+
+foreach {k inline section} {
+ 0 0 -external
+ 1 1 -inlined
+} {
+ TestFilesProcess $mytestdir ok serial nroff$section -> n label input data expected {
+ test doctools-toc-export-nroff-2.$k.$n "doctools::toc::export::nroff, $label$section, ok" -setup {
+ set configuration [list inline $inline user _dummy_]
+ } -body {
+ stripnroffcomments [stripmanmacros [export $data $configuration]]
+ } -cleanup {
+ unset configuration
+ } -result $expected
+ }
+}
+
+#----------------------------------------------------------------------
+unset n label input data expected
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2toc/export_text.tcl b/tcllib/modules/doctools2toc/export_text.tcl
new file mode 100644
index 0000000..41a2864
--- /dev/null
+++ b/tcllib/modules/doctools2toc/export_text.tcl
@@ -0,0 +1,142 @@
+# text.tcl --
+#
+# The text export plugin. Generation of plain text (ReST -
+# re-structured text).
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: export_text.tcl,v 1.3 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# This package is a plugin for the the doctools::toc v2 system. It
+# takes the list serialization of a table of contents and produces
+# text in text format.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: doctools::toc::export::plugin
+
+package require Tcl 8.4
+package require doctools::toc::export::plugin ; # Presence of this
+ # pseudo package
+ # indicates execution
+ # inside of a properly
+ # initialized plugin
+ # interpreter.
+package require doctools::toc::structure ; # Verification that the
+ # input is proper.
+package require doctools::text ; # Text assembly package
+
+doctools::text::import ;# -> ::text::*
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc export {serial configuration} {
+
+ # Phase I. Check that we got a canonical toc serialization. That
+ # makes the unpacking easier, as we can mix it with the
+ # generation of the output, knowing that everything is
+ # already sorted as it should be.
+
+ ::doctools::toc::structure verify-as-canonical $serial
+
+ # ### ### ### ######### ######### #########
+ # Configuration ...
+ # * Standard entries
+ # - user = person running the application doing the formatting
+ # - format = name of this format
+ # - file = name of the file the toc came from. Optional.
+ # - map = maps symbolic references to actual file path. Optional.
+
+ # //possible parameters to influence the output.
+ # //* symbolic mapping off/on
+
+ # Import the configuration and initialize the internal state
+
+ array set config $configuration
+ array set map {}
+ if {[info exists config(map)]} {
+ array set map $config(map)
+ }
+
+ # ### ### ### ######### ######### #########
+
+ # Phase II. Generate the output, taking the configuration into
+ # account.
+
+ # Unpack the serialization.
+ array set toc $serial
+ array set toc $toc(doctools::toc)
+ unset toc(doctools::toc)
+
+ text::begin
+ text::+ [Header]
+ text::underline =
+
+ # Iterate over the keys and their references
+ PrintDivision $toc(items)
+
+ # Return final assembled text
+ return [text::done]
+}
+
+proc PrintDivision {items} {
+ foreach element $items {
+ foreach {etype edata} $element break
+ array set toc $edata
+
+ switch -exact -- $etype {
+ reference {
+ text::newline
+ text::+ "[Map $toc(id)] : $toc(label)"
+ text::newline
+ text::indented 4 { text::+ $toc(desc) }
+ text::newline
+ }
+ division {
+ text::newline
+ if {[info exists toc(id)]} {
+ text::+ "[Map $toc(id)] : $toc(label)"
+ } else {
+ text::+ "$toc(label)"
+ }
+ text::underline -
+ text::indented 4 {
+ PrintDivision $toc(items)
+ }
+ text::newline
+ }
+ }
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+
+proc Header {} {
+ upvar 1 toc(label) label toc(title) title
+ if {($label ne {}) && ($title ne {})} {
+ return "$label -- $title"
+ } elseif {$label ne {}} {
+ return $label
+ } elseif {$title ne {}} {
+ return $title
+ }
+ return -code error {Reached the unreachable}
+}
+
+proc Map {id} {
+ upvar 1 map map
+ if {![info exists map($id)]} { return $id }
+ return $map($id)
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::toc::export::text 0.1
+return
diff --git a/tcllib/modules/doctools2toc/export_text.test b/tcllib/modules/doctools2toc/export_text.test
new file mode 100644
index 0000000..dd5383f
--- /dev/null
+++ b/tcllib/modules/doctools2toc/export_text.test
@@ -0,0 +1,63 @@
+# -*- tcl -*-
+# toc_export_text.test: tests for the doctools::toc::export::text package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export_text.test,v 1.2 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ useLocal structure.tcl doctools::toc::structure
+ use doctools2base/text.tcl doctools::text
+}
+testing {
+ package provide doctools::toc::export::plugin 1
+ # The above fakes the export plugin environment.
+
+ useLocal export_text.tcl doctools::toc::export::text
+}
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-toc-export-text-1.0 {export, wrong#args} -body {
+ export
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-toc-export-text-1.1 {export, wrong#args} -body {
+ export S
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-toc-export-text-1.2 {export, wrong#args} -body {
+ export S C XXX
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+# -------------------------------------------------------------------------
+
+# Testing the generation of text output, from toc serialization,
+# for all possible plugin configurations.
+
+TestFilesProcess $mytestdir ok serial text -> n label input data expected {
+ test doctools-toc-export-text-2.$n "doctools::toc::export::text, $label, ok" -body {
+ export $data {}
+ } -result $expected
+}
+
+#----------------------------------------------------------------------
+unset n label input data expected
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2toc/export_wiki.tcl b/tcllib/modules/doctools2toc/export_wiki.tcl
new file mode 100644
index 0000000..0ced5cf
--- /dev/null
+++ b/tcllib/modules/doctools2toc/export_wiki.tcl
@@ -0,0 +1,144 @@
+# text.tcl --
+#
+# The wiki export plugin. Generation of plain text, ready for
+# use by the Tcler's Wiki
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: export_wiki.tcl,v 1.3 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# This package is a plugin for the the doctools::toc v2 system. It
+# takes the list serialization of a table of contents and produces
+# text in wiki format.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: doctools::toc::export::plugin
+
+package require Tcl 8.4
+package require doctools::toc::export::plugin ; # Presence of this
+ # pseudo package
+ # indicates execution
+ # inside of a properly
+ # initialized plugin
+ # interpreter.
+package require doctools::toc::structure ; # Verification that the
+ # input is proper.
+package require doctools::text ; # Text assembly package
+
+doctools::text::import ;# -> ::text
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc export {serial configuration} {
+
+ # Phase I. Check that we got a canonical toc serialization. That
+ # makes the unpacking easier, as we can mix it with the
+ # generation of the output, knowing that everything is
+ # already sorted as it should be.
+
+ ::doctools::toc::structure verify-as-canonical $serial
+
+ # ### ### ### ######### ######### #########
+ # Configuration ...
+ # * Standard entries
+ # - user = person running the application doing the formatting
+ # - format = name of this format
+ # - file = name of the file the toc came from. Optional.
+ # - map = maps symbolic references to actual file path. Optional.
+
+ # //possible parameters to influence the output.
+ # //* symbolic mapping off/on
+
+ # Import the configuration and initialize the internal state
+
+ array set config $configuration
+ array set map {}
+ if {[info exists config(map)]} {
+ array set map $config(map)
+ }
+
+ # ### ### ### ######### ######### #########
+
+ # Phase II. Generate the output, taking the configuration into
+ # account.
+
+ # Unpack the serialization.
+ array set toc $serial
+ array set toc $toc(doctools::toc)
+ unset toc(doctools::toc)
+
+ # FUTURE :: Create wiki package on top of the text generator,
+ # providing encapsulated wiki commands.
+
+ text::begin
+ text::+ "**[Header]**"
+ text::newline
+
+ PrintDivision $toc(items) { *} *
+
+ # Last formatting, joining the lines together.
+ return [text::done]
+}
+
+proc PrintDivision {items indent increment} {
+ upvar 1 map map
+ foreach element $items {
+ foreach {etype edata} $element break
+ array set toc $edata
+ switch -exact -- $etype {
+ reference {
+ text::newline
+ text::+ "$indent [FormatReference] : $toc(desc)"
+ }
+ division {
+ if {[info exists toc(id)]} {
+ text::newline
+ text::+ "$indent [FormatReference]"
+ } else {
+ text::newline
+ text::+ "$indent $toc(label)"
+ }
+ PrintDivision $toc(items) $indent$increment $increment
+ }
+ }
+ unset toc
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+
+proc FormatReference {} {
+ upvar 1 map map toc toc
+ return "\[[Map $toc(id)]%|%$toc(label)\]"
+}
+
+proc Header {} {
+ upvar 1 toc(label) label toc(title) title
+ if {($label ne {}) && ($title ne {})} {
+ return "$label -- $title"
+ } elseif {$label ne {}} {
+ return $label
+ } elseif {$title ne {}} {
+ return $title
+ }
+ return -code error {Reached the unreachable}
+}
+
+proc Map {id} {
+ upvar 1 map map
+ if {![info exists map($id)]} { return $id }
+ return $map($id)
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::toc::export::wiki 0.1
+return
diff --git a/tcllib/modules/doctools2toc/export_wiki.test b/tcllib/modules/doctools2toc/export_wiki.test
new file mode 100644
index 0000000..a0dfae4
--- /dev/null
+++ b/tcllib/modules/doctools2toc/export_wiki.test
@@ -0,0 +1,63 @@
+# -*- tcl -*-
+# toc_export_wiki.test: tests for the doctools::toc::export::wiki package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export_wiki.test,v 1.2 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ useLocal structure.tcl doctools::toc::structure
+ use doctools2base/text.tcl doctools::text
+}
+testing {
+ package provide doctools::toc::export::plugin 1
+ # The above fakes the export plugin environment.
+
+ useLocal export_wiki.tcl doctools::toc::export::wiki
+}
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-toc-export-wiki-1.0 {export, wrong#args} -body {
+ export
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-toc-export-wiki-1.1 {export, wrong#args} -body {
+ export S
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+test doctools-toc-export-wiki-1.2 {export, wrong#args} -body {
+ export S C XXX
+} -returnCodes error -result {wrong # args: should be "export serial configuration"}
+
+# -------------------------------------------------------------------------
+
+# Testing the generation of wiki output, from toc serialization,
+# for all possible plugin configurations.
+
+TestFilesProcess $mytestdir ok serial wiki -> n label input data expected {
+ test doctools-toc-export-wiki-2.$n "doctools::toc::export::wiki, $label, ok" -body {
+ export $data {}
+ } -result $expected
+}
+
+#----------------------------------------------------------------------
+unset n label input data expected
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2toc/import.tcl b/tcllib/modules/doctools2toc/import.tcl
new file mode 100644
index 0000000..16cc8dc
--- /dev/null
+++ b/tcllib/modules/doctools2toc/import.tcl
@@ -0,0 +1,191 @@
+# doctoc.tcl --
+#
+# Importing indices into other formats.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: import.tcl,v 1.3 2011/11/17 08:00:45 andreas_kupries Exp $
+
+# Each object manages a set of plugins for the conversion of keyword
+# indices into some textual representation. I.e. this object manages
+# the conversion to specialized serializations of keyword indices.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.4
+package require doctools::config
+package require doctools::toc::structure
+package require doctools::paths
+package require pluginmgr
+package require snit
+
+# ### ### ### ######### ######### #########
+## API
+
+snit::type ::doctools::toc::import {
+
+ # ### ### ### ######### ######### #########
+ ## Options :: None
+
+ # ### ### ### ######### ######### #########
+ ## Creation, destruction.
+
+ constructor {} {
+ install myconfig using ::doctools::config ${selfns}::config
+ install myinclude using ::doctools::paths ${selfns}::include
+ return
+ }
+
+ destructor {
+ $myconfig destroy
+ $myinclude destroy
+ # Clear the cache of loaded import plugins.
+ foreach k [array names myplugin] {
+ $myplugin($k) destroy
+ }
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Convert from other formats to the Tcl toc serialization
+
+ method {import object text} {obj text {format {}}} {
+ $obj deserialize [$self import text $text $format]
+ return
+ }
+
+ method {import object file} {obj path {format {}}} {
+ $obj deserialize [$self import file $path $format]
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method {import text} {text {format {}}} {
+ set plugin [$self GetPlugin $format]
+
+ set configuration [$myconfig get]
+ lappend configuration user $::tcl_platform(user)
+ lappend configuraton format [$plugin plugin]
+
+ return [$plugin do import $text $configuration]
+ }
+
+ method {import file} {path {format {}}} {
+ # The plugin is not trusted to handle the file to convert.
+ return [$self import text [fileutil::cat $path] $format]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal methods
+
+ method GetPlugin {format} {
+ if {$format eq {}} { set format doctoc }
+
+ if {![info exists myplugin($format)]} {
+ set plugin [pluginmgr ${selfns}::fmt-$format \
+ -pattern doctools::toc::import::* \
+ -api { import } \
+ -setup [mymethod PluginSetup]]
+ ::pluginmgr::paths $plugin doctools::toc::import
+ $plugin load $format
+ set myplugin($format) $plugin
+ } else {
+ set plugin $myplugin($format)
+ }
+
+ return $plugin
+ }
+
+ method PluginSetup {mgr ip} {
+ # Inject a pseudo package into the plugin interpreter the
+ # import plugins can use to check that they were loaded into a
+ # proper environment.
+ $ip eval {package provide doctools::toc::import::plugin 1}
+
+ # The import plugins may use msgcat, which requires access to
+ # tcl_platform during its initialization, and won't have it by
+ # default. We trust them enough to hand out the information.
+ # TODO :: remove user/wordSize, etc. We need only 'os'.
+ $ip eval [list array set ::tcl_platform [array get ::tcl_platform]]
+
+ # Provide an alias-command a plugin can use to ask for any
+ # file, so that it can handle the processing of include files,
+ # should its format have that concept. Like doctoc. The alias
+ # will be directed to a method of ours and use the configured
+ # include paths to find the file, analogous to the GetFile
+ # procedure of doctools::toc::parse.
+
+ #8.5+: ::interp alias $ip include {} {*}[mymethod IncludeFile]
+ eval [linsert [mymethod IncludeFile] 0 ::interp alias $ip include {}]
+ return
+ }
+
+ method IncludeFile {currentfile path} {
+ # result = ok text fullpath error-code error-message
+
+ # Find the file, or not.
+ set fullpath [$self Locate $path]
+ if {$fullpath eq {}} {
+ return [list 0 {} $path notfound {}]
+ }
+
+ # Read contents, or not.
+ if {[catch {
+ set data [fileutil::cat $fullpath]
+ } msg]} {
+ set error notread
+ set emessage $msg
+ return [list 0 {} $fullpath notread $msg]
+ }
+
+ return [list 1 $data $fullpath {} {}]
+ }
+
+ method Locate {path} {
+ upvar 1 currentfile currentfile
+
+ if {$currentfile ne {}} {
+ set pathstosearch \
+ [linsert [$myinclude paths] 0 \
+ [file dirname [file normalize $currentfile]]]
+ } else {
+ set pathstosearch [$myinclude paths]
+ }
+
+ foreach base $pathstosearch {
+ set try [file join $base $path]
+ if {![file exists $try]} continue
+ return $try
+ }
+ # Nothing found
+ return {}
+ }
+
+ # ### ### ### ######### ######### #########
+ ## State
+
+ # Array serving as a cache for the various plugin managers holding
+ # a specific import plugin.
+
+ variable myplugin -array {}
+
+ # A component managing the configuration given to the import
+ # plugins when they are invoked.
+
+ component myconfig -public config
+ component myinclude -public include
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::toc::import 0.1
+return
diff --git a/tcllib/modules/doctools2toc/import.test b/tcllib/modules/doctools2toc/import.test
new file mode 100644
index 0000000..e8bf0e4
--- /dev/null
+++ b/tcllib/modules/doctools2toc/import.test
@@ -0,0 +1,377 @@
+# -*- tcl -*-
+# -- toc_import.test:
+# -- Tests for package "doctools::toc::import": Management of import plugins.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: import.test,v 1.1 2009/04/18 21:14:18 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2
+
+support {
+ use struct/list.tcl struct::list
+ use snit/snit.tcl snit
+ use fileutil/fileutil.tcl fileutil
+ use log/logger.tcl logger
+ use pluginmgr/pluginmgr.tcl pluginmgr
+
+ use doctools2base/config.tcl doctools::config
+ use doctools2base/paths.tcl doctools::paths
+
+ source [tcllibPath doctools2base/tests/common]
+}
+testing {
+ useLocalKeep import.tcl doctools::toc::import
+}
+
+# -------------------------------------------------------------------------
+
+setup_plugins
+
+# -------------------------------------------------------------------------
+
+test doctools-toc-import-1.0 {import text, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I import text
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::import::Snit_hmethodimport_text type selfns win self text ?format?"}
+
+test doctools-toc-import-1.1 {import text, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I import text T F XX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::import::Snit_hmethodimport_text type selfns win self text ?format?"}
+
+test doctools-toc-import-2.0 {import file, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I import file
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::import::Snit_hmethodimport_file type selfns win self path ?format?"}
+
+test doctools-toc-import-2.1 {import file, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I import file P F XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::import::Snit_hmethodimport_file type selfns win self path ?format?"}
+
+test doctools-toc-import-3.0 {import object text, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I import object text
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::import::Snit_hmethodimport_object_text type selfns win self obj text ?format?"}
+
+test doctools-toc-import-3.1 {import object text, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I import object text O
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::import::Snit_hmethodimport_object_text type selfns win self obj text ?format?"}
+
+test doctools-toc-import-3.2 {import object text, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I import object text O T F XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::import::Snit_hmethodimport_object_text type selfns win self obj text ?format?"}
+
+test doctools-toc-import-4.0 {import object file, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I import object file
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::import::Snit_hmethodimport_object_file type selfns win self obj path ?format?"}
+
+test doctools-toc-import-4.1 {import object file, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I import object file O
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::import::Snit_hmethodimport_object_file type selfns win self obj path ?format?"}
+
+test doctools-toc-import-4.2 {import object file, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I import object file O P F XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::import::Snit_hmethodimport_object_file type selfns win self obj path ?format?"}
+
+test doctools-toc-import-5.0 {config names, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I config names X
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodnames type selfns win self"}
+
+test doctools-toc-import-6.0 {config get, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I config get X
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodget type selfns win self"}
+
+test doctools-toc-import-7.0 {config set, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I config set
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodset type selfns win self name ?value?"}
+
+test doctools-toc-import-7.1 {config set, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I config set N V X
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::config::Snit_methodset type selfns win self name ?value?"}
+
+# config unset - accepts any number of arguments.
+
+test doctools-toc-import-8.0 {include paths, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I include paths X
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::paths::Snit_methodpaths type selfns win self"}
+
+test doctools-toc-import-9.0 {include clear, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I include clear X
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::paths::Snit_methodclear type selfns win self"}
+
+test doctools-toc-import-10.0 {include add, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I include add
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::paths::Snit_methodadd type selfns win self path"}
+
+test doctools-toc-import-10.1 {include add, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I include add P X
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::paths::Snit_methodadd type selfns win self path"}
+
+test doctools-toc-import-11.0 {include remove, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I include remove
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::paths::Snit_methodremove type selfns win self path"}
+
+test doctools-toc-import-11.1 {include remove, wrong#args} -setup {
+ doctools::toc::import I
+} -body {
+ I include remove P X
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::paths::Snit_methodremove type selfns win self path"}
+
+# -------------------------------------------------------------------------
+
+test doctools-toc-import-12.0 {config set, define single var} -setup {
+ doctools::toc::import I
+} -body {
+ I config set N V
+ I config get
+} -cleanup {
+ I destroy
+} -result {N V}
+
+test doctools-toc-import-12.1 {config set, define multiple vars} -setup {
+ doctools::toc::import I
+} -body {
+ I config set N V
+ I config set A B
+ dictsort [I config get]
+} -cleanup {
+ I destroy
+} -result {A B N V}
+
+test doctools-toc-import-12.2 {config set, as query} -setup {
+ doctools::toc::import I
+ I config set N V
+} -body {
+ I config set N
+} -cleanup {
+ I destroy
+} -result V
+
+test doctools-toc-import-13.0 {config unset, all} -setup {
+ doctools::toc::import I
+ I config set N V
+} -body {
+ I config unset
+ I config get
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-toc-import-13.1 {config unset, by exact name} -setup {
+ doctools::toc::import I
+ I config set N V
+ I config set A B
+} -body {
+ I config unset N
+ I config get
+} -cleanup {
+ I destroy
+} -result {A B}
+
+test doctools-toc-import-13.2 {config unset, by glob pattern} -setup {
+ doctools::toc::import I
+ I config set N V
+ I config set N' V'
+ I config set A B
+} -body {
+ I config unset N*
+ I config get
+} -cleanup {
+ I destroy
+} -result {A B}
+
+test doctools-toc-import-14.0 {config names, empty} -setup {
+ doctools::toc::import I
+} -body {
+ I config names
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-toc-import-14.1 {config names, with variables} -setup {
+ doctools::toc::import I
+ I config set N V
+ I config set A B
+} -body {
+ lsort -dict [I config names]
+} -cleanup {
+ I destroy
+} -result {A N}
+
+test doctools-toc-import-15.0 {config get, empty} -setup {
+ doctools::toc::import I
+} -body {
+ I config get
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-toc-import-15.1 {config get, with variables} -setup {
+ doctools::toc::import I
+ I config set N V
+ I config set A B
+} -body {
+ dictsort [I config get]
+} -cleanup {
+ I destroy
+} -result {A B N V}
+
+test doctools-toc-import-16.0 {include paths, empty} -setup {
+ doctools::toc::import I
+} -body {
+ I include paths
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-toc-import-16.1 {include paths, several paths, order} -setup {
+ doctools::toc::import I
+ I include add first
+ I include add second
+} -body {
+ I include paths
+} -cleanup {
+ I destroy
+} -result {first second}
+
+test doctools-toc-import-17.0 {include add, unknown} -setup {
+ doctools::toc::import I
+} -body {
+ I include add A
+ I include paths
+} -cleanup {
+ I destroy
+} -result A
+
+test doctools-toc-import-17.1 {include add, already known} -setup {
+ doctools::toc::import I
+} -body {
+ I include add A
+ I include add A
+ I include paths
+} -cleanup {
+ I destroy
+} -result A
+
+test doctools-toc-import-18.0 {include remove, unknown} -setup {
+ doctools::toc::import I
+} -body {
+ I include add A
+ I include remove B
+ I include paths
+} -cleanup {
+ I destroy
+} -result A
+
+test doctools-toc-import-18.1 {include remove, known} -setup {
+ doctools::toc::import I
+} -body {
+ I include add A
+ I include remove A
+ I include paths
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-toc-import-19.0 {include clear} -setup {
+ doctools::toc::import I
+} -body {
+ I include add A
+ I include add B
+ I include clear
+ I include paths
+} -cleanup {
+ I destroy
+} -result {}
+
+# toc_import tests, numbering starts at 20
+# -------------------------------------------------------------------------
+
+source [localPath tests/import]
+
+#----------------------------------------------------------------------
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2toc/import_doctoc.man b/tcllib/modules/doctools2toc/import_doctoc.man
new file mode 100644
index 0000000..5c42aef
--- /dev/null
+++ b/tcllib/modules/doctools2toc/import_doctoc.man
@@ -0,0 +1,6 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE doctoc]
+[vset NAME doctoc]
+[vset REQUIRE doctoc]
+[vset CONFIG doctoc]
+[include include/import/plugin.inc]
diff --git a/tcllib/modules/doctools2toc/import_doctoc.tcl b/tcllib/modules/doctools2toc/import_doctoc.tcl
new file mode 100644
index 0000000..eff659b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/import_doctoc.tcl
@@ -0,0 +1,91 @@
+# doctoc.tcl --
+#
+# The doctoc import plugin. Bridge between import management and
+# the parsing of doctoc markup.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: import_doctoc.tcl,v 1.3 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# This package is a plugin for the the doctools::toc v2 system. It
+# takes text in docidx format and produces the list serialization of a
+# table of contents.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: doctools::toc::import::plugin
+
+package require Tcl 8.4
+package require doctools::toc::import::plugin ; # The presence of this
+ # pseudo package
+ # indicates execution
+ # of this code inside
+ # of an interpreter
+ # which was properly
+ # initialized for use
+ # by import plugins.
+package require doctools::toc::parse ; # The actual doctoc
+ # parser used by the
+ # plugin.
+
+# ### ### ### ######### ######### #########
+
+## We redefine the command 'doctools::toc::parse::GetFile' to use the
+## 'include' alias provided by the plugin manager, as reguar file
+## commands are not allowed in this 'safe' environment. However this
+## is done if and only if we truly are in the plugin environment. The
+## testsuite, for example, will leave out the definition of 'include',
+## signaling in this way that the regular file operations can still be
+## used.
+
+if {[llength [info commands include]]} {
+
+ # Note: We are poking directly into the implementation of the
+ # class. Any changes to the interface here have to reviewed
+ # for their impact on doctools::toc::parse, and possibly
+ # ported over.
+
+ proc ::doctools::toc::parse::GetFile {currentfile path dv pv ev mv} {
+ upvar 1 $dv data $pv fullpath $ev error $mv emessage
+ foreach {ok data fullpath error emessage} [include $currentfile $path] break
+ return $ok
+ }
+}
+
+# ### ### ### ######### ######### #########
+## API :: Convert text to canonical toc serialization.
+
+proc import {text configuration} {
+ global errorInfo errorCode
+
+ doctools::toc::parse var load $configuration
+
+ # Could be done better using a try/finally
+ set code [catch {
+ doctools::toc::parse text $text
+ } serial]
+
+ # Save error state if there was any.
+ set ei $errorInfo
+ set ec $errorCode
+
+ # Cleanup parser configuration, regardless of errors or not.
+ doctools::toc::parse var unset *
+
+ # Rethrow any error, using the captured state.
+ if {$code} {
+ return -code $code -errorinfo $ei -errorcode $ec $serial
+ }
+
+ return $serial
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::toc::import::doctoc 0.1
+return
diff --git a/tcllib/modules/doctools2toc/import_doctoc.test b/tcllib/modules/doctools2toc/import_doctoc.test
new file mode 100644
index 0000000..4067cac
--- /dev/null
+++ b/tcllib/modules/doctools2toc/import_doctoc.test
@@ -0,0 +1,92 @@
+# -*- tcl -*-
+# toc_import_doctoc.test: tests for the doctools::toc::import::doctoc package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: import_doctoc.test,v 1.1 2009/04/18 21:14:18 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ useAccel [useTcllibC] struct/tree.tcl struct::tree
+ TestAccelInit struct::tree
+
+ useAccel [useTcllibC] struct/stack.tcl struct::stack
+ TestAccelInit struct::stack
+
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use struct/list.tcl struct::list
+ use snit/snit.tcl snit
+ use fileutil/fileutil.tcl fileutil
+ use log/logger.tcl logger
+ use treeql/treeql.tcl treeql
+
+ use doctools2base/tcl_parse.tcl doctools::tcl::parse
+ use doctools2base/msgcat.tcl doctools::msgcat
+
+ useLocal msgcat_c.tcl doctools::msgcat::toc::c
+ useLocal structure.tcl doctools::toc::structure
+ useLocal parse.tcl doctools::toc::parse
+
+ msgcat::mclocale C
+}
+testing {
+ package provide doctools::toc::import::plugin 1
+ # The above fakes plugin environment. Well, not completely. By
+ # leaving out a definition for the 'include' alias the plugin is
+ # signaled that there is no need to overwrite the GetFile command
+ # of doctools::toc::parse with a version calling out to the plugin
+ # manager, i.e. that it can still use the regular file operations.
+
+ useLocal import_doctoc.tcl doctools::toc::import::doctoc
+}
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-toc-import-doctoc-1.0 {import, wrong#args} -body {
+ import
+} -returnCodes error -result {wrong # args: should be "import text configuration"}
+
+test doctools-toc-import-doctoc-1.1 {import, wrong#args} -body {
+ import T
+} -returnCodes error -result {wrong # args: should be "import text configuration"}
+
+test doctools-toc-import-doctoc-1.2 {import, wrong#args} -body {
+ import T C XXX
+} -returnCodes error -result {wrong # args: should be "import text configuration"}
+
+# toc_import_doctoc tests, numbering starts at 2
+# -------------------------------------------------------------------------
+
+array_unset env LANG*
+array_unset env LC_*
+set env(LANG) C ; # Usually default if nothing is set, OS X requires this.
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::stack stkimpl {
+ TestAccelDo struct::set setimpl {
+ TestAccelDo struct::tree impl {
+ source [localPath tests/import_doctoc]
+ }
+ }
+}
+
+#----------------------------------------------------------------------
+TestAccelExit struct::tree
+TestAccelExit struct::set
+TestAccelExit struct::stack
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2toc/import_json.tcl b/tcllib/modules/doctools2toc/import_json.tcl
new file mode 100644
index 0000000..2d101c8
--- /dev/null
+++ b/tcllib/modules/doctools2toc/import_json.tcl
@@ -0,0 +1,77 @@
+# json.tcl --
+#
+# The json import plugin. Bridge between import management and
+# the parsing of json markup.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: import_json.tcl,v 1.3 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# This package is a plugin for the the doctools::toc v2 system. It
+# takes text in json format and produces the list serialization of a
+# table of contents.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: doctools::toc::import::plugin
+
+package require Tcl 8.4
+package require doctools::toc::import::plugin ; # The presence of this
+ # pseudo package
+ # indicates execution
+ # of this code inside
+ # of an interpreter
+ # which was properly
+ # initialized for use
+ # by import plugins.
+package require doctools::toc::structure ; # Verification of the json
+ # parse result as a
+ # proper toc
+ # serialization.
+
+if {[package vcompare [package present Tcl] 8.5] < 0} {
+ if {[catch {
+ package require dict
+ }]} {
+ # Create a pure Tcl implementation of the dict methods
+ # required by json, and fake the presence of the dict package.
+ proc dict {cmd args} { return [uplevel 1 [linsert $args 0 dict/$cmd]] }
+ proc dict/create {} { return {} }
+ proc dict/set {var key val} {
+ upvar 1 $var a
+ array set x $a
+ set x($key) $val
+ set a [array get x]
+ return
+ }
+ package provide dict 1
+ }
+}
+
+package require json ; # The actual json parser used by the plugin.
+# Requires 8.5, or 8.4+dict.
+
+# ### ### ### ######### ######### #########
+
+# ### ### ### ######### ######### #########
+## API :: Convert text to canonical toc serialization.
+
+proc import {text configuration} {
+ # Note: We cannot fail here on duplicate keys in the input,
+ # especially for keywords and references, as we do for Tcl-based
+ # canonical toc serializations, because our underlying JSON parser
+ # automatically merges them, by taking only the last found
+ # definition. I.e. of two or more definitions for a key X the last
+ # overwrites all previous occurences.
+ return [doctools::toc::structure canonicalize [json::json2dict $text]]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide doctools::toc::import::json 0.1
+return
diff --git a/tcllib/modules/doctools2toc/import_json.test b/tcllib/modules/doctools2toc/import_json.test
new file mode 100644
index 0000000..3bf27f9
--- /dev/null
+++ b/tcllib/modules/doctools2toc/import_json.test
@@ -0,0 +1,115 @@
+# -*- tcl -*-
+# toc_import_json.test: tests for the doctools::toc::import::json package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: import_json.test,v 1.1 2009/04/18 21:14:19 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil
+ use struct/list.tcl struct::list
+
+ # Copy of code from import_json.tcl, to define dict support
+ # even where dict is not really present on the system.
+
+ if {[package vcompare [package present Tcl] 8.5] < 0} {
+ if {[catch {
+ package require dict
+ }]} {
+ # Create a pure Tcl implementation of the dict methods
+ # required by json, and fake the presence of the dict package.
+ proc dict {cmd args} { return [uplevel 1 [linsert $args 0 dict/$cmd]] }
+ proc dict/create {} { return {} }
+ proc dict/set {var key val} {
+ upvar 1 $var a
+ array set x $a
+ set x($key) $val
+ set a [array get x]
+ return
+ }
+ package provide dict 1
+ }
+ }
+ use json/json.tcl json
+
+ useLocal structure.tcl doctools::toc::structure
+
+ #msgcat::mclocale C
+}
+testing {
+ package provide doctools::toc::import::plugin 1
+ # The above fakes plugin environment. Well, not completely. By
+ # leaving out a definition for the 'include' alias the plugin is
+ # signaled that there is no need to overwrite the GetFile command
+ # of doctools::toc::parse with a version calling out to the plugin
+ # manager, i.e. that it can still use the regular file operations.
+
+ useLocal import_json.tcl doctools::toc::import::json
+}
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-toc-import-json-1.0 {import, wrong#args} -body {
+ import
+} -returnCodes error -result {wrong # args: should be "import text configuration"}
+
+test doctools-toc-import-json-1.1 {import, wrong#args} -body {
+ import T
+} -returnCodes error -result {wrong # args: should be "import text configuration"}
+
+test doctools-toc-import-json-1.2 {import, wrong#args} -body {
+ import T C XXX
+} -returnCodes error -result {wrong # args: should be "import text configuration"}
+
+# toc_import_json tests, numbering starts at 2
+# -------------------------------------------------------------------------
+
+# We are checking that the various forms of json markup, as can be
+# generated by doctools::toc(::export(::json)) are valid input to the
+# json parser.
+#
+# section {} holds the non-canonical input we have to accept and make
+# canonical to higher layers.
+
+foreach {k section} {
+ 0 {}
+ 1 -ultracompact
+ 2 -indented
+ 3 -indalign
+} {
+ TestFilesProcess $mytestdir ok json$section serial-print -> n label input data expected {
+ test doctools-toc-import-json-2.$k.$n "doctools::toc::import::json, $label$section, ok" -body {
+ doctools::toc::structure print [import $data {}]
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# We test the error messages and codes thrown by the parser for a
+# variety of failure possibilities.
+
+TestFilesProcess $mytestdir fail json json-emsg -> n label input data expected {
+ test doctools-toc-import-json-3.$n "doctools::toc::import::json, $label, error message" -body {
+ import $data {}
+ } -returnCodes error -result $expected
+}
+
+#----------------------------------------------------------------------
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2toc/include/concept.inc b/tcllib/modules/doctools2toc/include/concept.inc
new file mode 100644
index 0000000..a3f8b5c
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/concept.inc
@@ -0,0 +1,47 @@
+[comment {
+ Description of the concepts used in tables of contents and how
+ their relate to each other. This is useful to understand the
+ serialization chosen for tables of contents.
+}]
+[list_begin enumerated]
+[enum]
+
+A [term {table of contents}] consists of a (possibly empty) list of
+[term elements].
+
+[enum]
+Each element in the list is identified by its label.
+
+[enum]
+Each element is either a [term reference], or a [term division].
+
+[enum]
+Each reference has an associated document, identified by a symbolic
+id, and a textual description.
+
+[enum]
+Each division may have an associated document, identified by a
+symbolic id.
+
+[enum]
+Each division consists consists of a (possibly empty) list of
+[term elements], with each element following the rules as specified in
+item 2 and above.
+
+[list_end]
+
+A few notes
+
+[list_begin enumerated]
+[enum]
+The above rules span up a tree of elements, with references as the
+leaf nodes, and divisions as the inner nodes, and each element
+representing an entry in the whole table of contents.
+
+[enum]
+The identifying labels of any element E are unique within their
+division (or toc), and the full label of any element E is the list of
+labels for all nodes on the unique path from the root of the tree to
+E, including E.
+
+[list_end]
diff --git a/tcllib/modules/doctools2toc/include/dependencies.inc b/tcllib/modules/doctools2toc/include/dependencies.inc
new file mode 100644
index 0000000..b64d1f1
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/dependencies.inc
@@ -0,0 +1,44 @@
+[comment {
+ ASCII diagram of the dependencies between the doctools v2 toc packages
+ ======================================================================
+}][example {
+ ~~~~~~~~~~~ doctools::toc ~~~~~~~~~~~
+ ~~ | ~~
+ doctools::toc::export ~~~~~~~~~~~~~~~~~ | ~~~~~~~~~~~~~ doctools::toc::import
+ | | |
+ +---------------+-------------------------+ | +------------------+---------------+-----------------------+---------------+
+ | | | | | | | | |
+doctools::config = | | | = doctools::include doctools::config doctools::paths
+ | | | | |
+ doctools::toc::export::<*> | | | doctools::toc::import::<*>
+ doctoc | | | doctoc, json
+ json | | | | \\
+ html | | | doctools::toc::parse \\
+ nroff | | | | \\
+ wiki | | | +---------------+ json
+ text | | | | |
+ doctools::toc::structure |
+ |
+ +-------+---------------+
+ | |
+ doctools::html doctools::html::cssdefaults doctools::tcl::parse doctools::msgcat
+ | |
+ doctools::text doctools::nroff::man_macros =
+ |
+ doctools::msgcat::toc::<*>
+ c, en, de, fr
+ (fr == en for now)
+ ~~ Interoperable objects, without actual package dependencies
+ -- Package dependency, higher requires lower package
+ = Dynamic dependency through plugin system
+ <*> Multiple packages following the given form of naming.
+
+}][comment {
+ yaml export, import
+ tmml export, import
+ reStructured Text export
+ latex export
+
+ list, desc - old, not needed under new system, replaced by the nested-list serialization
+ null - old, not needed, deserialize doctoc alone provides validation of input.
+}]
diff --git a/tcllib/modules/doctools2toc/include/export/config/doctoc.inc b/tcllib/modules/doctools2toc/include/export/config/doctoc.inc
new file mode 100644
index 0000000..199b892
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/export/config/doctoc.inc
@@ -0,0 +1,70 @@
+
+[include ../../format/doctoc.inc]
+
+[section Configuration]
+
+The doctoc export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+
+[arg_def string user]
+This standard configuration variable contains the name of the user
+running the process which invoked the export plugin.
+
+The plugin puts this information into the provenance comment at the
+beginning of the generated document.
+
+[arg_def string file]
+
+This standard configuration variable contains the name of the file the
+table of contents came from. This variable may not be set or contain
+the empty string.
+
+The plugin puts this information, if defined, i.e. set and not the
+empty string, into the provenance comment at the beginning of the
+generated document.
+
+
+[arg_def boolean newlines]
+
+If this flag is set the plugin will break the generated doctoc code
+across lines, with each markup command on a separate line.
+
+[para]
+
+If this flag is not set (the default), the whole document will be
+written on a single line, with minimum spacing between all elements.
+
+
+[arg_def boolean indented]
+
+If this flag is set the plugin will indent the markup commands
+according to the structure of tables of contents. To make this work
+this also implies that [var newlines] is set. This effect is
+independent of the value for [var aligned] however.
+
+[para]
+
+If this flag is not set (the default), the output is formatted as per
+the value of [var newlines], and no indenting is done.
+
+
+[arg_def boolean aligned]
+
+If this flag is set the generator ensures that the arguments for the
+[cmd item] commands in a division are aligned vertically for a nice
+table effect. To make this work this also implies that [var newlines]
+is set. This effect is independent of the value for [var indented]
+however.
+
+[para]
+
+If this flag is not set (the default), the output is formatted as per
+the values of [var newlines] and [var indented], and no alignment is
+done.
+
+[list_end]
+
+[emph Note] that this plugin ignores the standard configuration
+variables [var format], and [var map], and their values.
diff --git a/tcllib/modules/doctools2toc/include/export/config/html.inc b/tcllib/modules/doctools2toc/include/export/config/html.inc
new file mode 100644
index 0000000..faf0b86
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/export/config/html.inc
@@ -0,0 +1,155 @@
+[section Configuration]
+
+The html export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+
+[arg_def string user]
+This standard configuration variable contains the name of the user
+running the process which invoked the export plugin.
+
+The plugin puts this information into the provenance comment at the
+beginning of the generated document.
+
+[arg_def string file]
+
+This standard configuration variable contains the name of the file the
+table of contents came from. This variable may not be set or contain
+the empty string.
+
+The plugin puts this information, if defined, i.e. set and not the
+empty string, into the provenance comment at the beginning of the
+generated document.
+
+
+[arg_def dictionary map]
+
+This standard configuration variable contains a dictionary mapping
+from the (symbolic) document ids in reference entries to the actual
+filenames and/or urls to be used in the output.
+
+[para]
+
+Document ids without a mapping are used unchanged.
+
+
+[arg_def boolean newlines]
+
+If this flag is set the plugin will break the generated html code
+across lines, with each markup command on a separate line.
+
+[para]
+
+If this flag is not set (the default), the whole document will be
+written on a single line, with minimum spacing between all elements.
+
+
+[arg_def boolean indented]
+
+If this flag is set the plugin will indent the markup commands
+according to the structure of indices. To make this work this also
+implies that [var newlines] is set.
+
+[para]
+
+If this flag is not set (the default), the output is formatted as per
+the value of [var newlines], and no indenting is done.
+
+
+[arg_def string meta]
+
+This variable is meant to hold a fragment of HTML (default: empty).
+The fragment it contains will be inserted into the generated output in
+the <head> section of the document, just after the <title> tag.
+
+
+[arg_def string header]
+
+This variable is meant to hold a fragment of HTML (default: empty).
+The fragment it contains will be inserted into the generated output
+just after the <h1> title tag in the body of the document, in the
+class.header <div>'ision.
+
+
+
+[arg_def string footer]
+
+This variable is meant to hold a fragment of HTML (default:
+empty). The fragment it contains will be inserted into the generated
+output just before the </body> tag, in the class.footer <div>'ision.
+
+
+[arg_def dictionary rid]
+
+The value of this variable (default: empty) maps references to the
+identifiers to use as their anchor names. Each reference [var FOO] not
+found in the dictionary uses [const REF-][var FOO] as anchor,
+i.e. itself prefixed with the string [const REF-].
+
+
+[arg_def string sepline]
+
+The value of this variable is the string to use for the separator
+comments inserted into the output when the outpout is broken across
+lines and/or indented. The default string consists of 60 dashes.
+
+
+[arg_def string class.main]
+
+This variable contains the class name for the main <div>'ivision of
+the generated document. The default is [const doctools].
+
+
+[arg_def string class.header]
+
+This variable contains the class name for the header <div>'ision of
+the generated document. The default is [const toc-header]. This
+division contains the document title, the user specified [var header],
+if any, and a visible separator line.
+
+
+[arg_def string class.title]
+
+This variable contains the class name for the <h1> tag enclosing the
+document title. The default is [const toc-title].
+
+
+[arg_def string class.navsep]
+
+This variable contains the class name for the <hr> separators in the
+header and footer sections of the generated document. The default is
+[const toc-navsep].
+
+
+[arg_def string class.contents]
+
+This variable contains the class name for the XXXXX holding the
+keywords and their references in the generated document. The default
+is [const toc-contents].
+
+
+[arg_def string class.ref]
+
+This variable contains the class name for the table elements which are
+references to other documents. The default is [const toc-ref].
+
+
+[arg_def string class.div]
+
+This variable contains the class name for the table elements which are
+divisions. The default is [const toc-div].
+
+
+[arg_def string class.footer]
+
+This variable contains the class name for the footer <div>'ision of
+the generated document. The default is [const toc-footer]. This
+division contains a browser-visible separator line and the user
+specified [var footer], if any.
+
+
+[list_end]
+
+[emph Note] that this plugin ignores the standard configuration
+variable [var format], and its value.
diff --git a/tcllib/modules/doctools2toc/include/export/config/json.inc b/tcllib/modules/doctools2toc/include/export/config/json.inc
new file mode 100644
index 0000000..24844b8
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/export/config/json.inc
@@ -0,0 +1,39 @@
+
+[include ../../format/json.inc]
+
+[section Configuration]
+
+The JSON export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+[arg_def boolean indented]
+
+If this flag is set the plugin will break the generated JSON code
+across lines and indent it according to its inner structure, with each
+key of a dictionary on a separate line.
+
+[para]
+
+If this flag is not set (the default), the whole JSON object will be
+written on a single line, with minimum spacing between all elements.
+
+
+[arg_def boolean aligned]
+
+If this flag is set the generator ensures that the values for the keys
+in a dictionary are vertically aligned with each other, for a nice
+table effect. To make this work this also implies that [var indented]
+is set.
+
+[para]
+
+If this flag is not set (the default), the output is formatted as per
+the value of [var indented], without trying to align the values for
+dictionary keys.
+
+[list_end]
+
+[emph Note] that this plugin ignores the standard configuration
+variables [var user], [var format], [var file], and [var map] and
+their values.
diff --git a/tcllib/modules/doctools2toc/include/export/config/nroff.inc b/tcllib/modules/doctools2toc/include/export/config/nroff.inc
new file mode 100644
index 0000000..5158ca1
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/export/config/nroff.inc
@@ -0,0 +1,40 @@
+[section Configuration]
+
+The nroff export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+
+[arg_def string user]
+This standard configuration variable contains the name of the user
+running the process which invoked the export plugin.
+
+The plugin puts this information into the provenance comment at the
+beginning of the generated document.
+
+[arg_def string file]
+
+This standard configuration variable contains the name of the file the
+table of contents came from. This variable may not be set or contain
+the empty string.
+
+The plugin puts this information, if defined, i.e. set and not the
+empty string, into the provenance comment at the beginning of the
+generated document.
+
+
+[arg_def boolean inline]
+
+If this flag is set (default) the plugin will place the definitions of
+the man macro set directly into the output.
+
+[para]
+
+If this flag is not set, the plugin will place a reference to the
+definitions of the man macro set into the output, but not the macro
+definitions themselves.
+
+[list_end]
+
+[emph Note] that this plugin ignores the standard configuration
+variables [var format], and [var map], and their values.
diff --git a/tcllib/modules/doctools2toc/include/export/config/text.inc b/tcllib/modules/doctools2toc/include/export/config/text.inc
new file mode 100644
index 0000000..5fe2a67
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/export/config/text.inc
@@ -0,0 +1,21 @@
+[section Configuration]
+
+The text export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+
+[arg_def dictionary map]
+
+This standard configuration variable contains a dictionary mapping
+from the (symbolic) document ids in reference entries to the actual
+filenames and/or urls to be used in the output.
+
+[para]
+
+Document ids without a mapping are used unchanged.
+
+[list_end]
+
+[emph Note] that this plugin ignores the standard configuration
+variables [var user], [var file], and [var format], and their values.
diff --git a/tcllib/modules/doctools2toc/include/export/config/wiki.inc b/tcllib/modules/doctools2toc/include/export/config/wiki.inc
new file mode 100644
index 0000000..fe9ba4c
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/export/config/wiki.inc
@@ -0,0 +1,32 @@
+[section {Wiki markup}]
+
+The basic syntax of the wiki markup generated by this plugin are
+described at [uri http://wiki.tcl.tk/14].
+
+[para]
+
+The plugin goes beyond the classic markup to generate proper headers
+and indenting.
+
+
+[section Configuration]
+
+The wiki export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+
+[arg_def dictionary map]
+
+This standard configuration variable contains a dictionary mapping
+from the (symbolic) document ids in reference entries to the actual
+filenames and/or urls to be used in the output.
+
+[para]
+
+Document ids without a mapping are used unchanged.
+
+[list_end]
+
+[emph Note] that this plugin ignores the standard configuration
+variables [var user], [var file] and [var format], and their values.
diff --git a/tcllib/modules/doctools2toc/include/export/format/html.inc b/tcllib/modules/doctools2toc/include/export/format/html.inc
new file mode 100644
index 0000000..c8803f4
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/export/format/html.inc
@@ -0,0 +1,3 @@
+[require doctools::text]
+[require doctools::html]
+[require doctools::html::cssdefaults]
diff --git a/tcllib/modules/doctools2toc/include/export/format/json.inc b/tcllib/modules/doctools2toc/include/export/format/json.inc
new file mode 100644
index 0000000..9ef73f0
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/export/format/json.inc
@@ -0,0 +1 @@
+[require textutil::adjust]
diff --git a/tcllib/modules/doctools2toc/include/export/format/nroff.inc b/tcllib/modules/doctools2toc/include/export/format/nroff.inc
new file mode 100644
index 0000000..7883881
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/export/format/nroff.inc
@@ -0,0 +1,2 @@
+[require doctools::text]
+[require doctools::nroff::man_macros]
diff --git a/tcllib/modules/doctools2toc/include/export/format/null.inc b/tcllib/modules/doctools2toc/include/export/format/null.inc
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/export/format/null.inc
diff --git a/tcllib/modules/doctools2toc/include/export/format/text.inc b/tcllib/modules/doctools2toc/include/export/format/text.inc
new file mode 100644
index 0000000..be41da5
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/export/format/text.inc
@@ -0,0 +1 @@
+[require doctools::text]
diff --git a/tcllib/modules/doctools2toc/include/export/plugin.inc b/tcllib/modules/doctools2toc/include/export/plugin.inc
new file mode 100644
index 0000000..cab8dd2
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/export/plugin.inc
@@ -0,0 +1,55 @@
+[comment {-*- tcl -*- --- !doctools ---}]
+[manpage_begin doctools::toc::export::[vset PACKAGE] n [vset VERSION]]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc "[vset NAME] export plugin"]
+[category {Text formatter plugin}]
+[require Tcl 8.4]
+[require doctools::toc::export::[vset PACKAGE] [opt [vset VERSION]]]
+[include format/[vset REQUIRE].inc]
+[keywords doctools toc {table of contents} serialization export [vset NAME]]
+[description]
+
+This package implements the doctools table of contents export plugin
+for the generation of [vset NAME] markup.
+
+[para]
+
+This is an internal package of doctools, for use by the higher level
+management packages handling tables of contents, especially [package \
+doctools::toc::export], the export manager.
+
+[para]
+
+Using it from a regular interpreter is possible, however only with
+contortions, and is not recommended.
+
+The proper way to use this functionality is through the package
+[package doctools::toc::export] and the export manager objects it
+provides.
+
+
+[section API]
+
+The API provided by this package satisfies the specification of the
+doctoc export plugin API version 2.
+
+[list_begin definitions]
+
+[call [cmd export] [arg serial] [arg configuration]]
+
+This command takes the canonical serialization of a table of contents,
+as specified in section [sectref {ToC serialization format}], and
+contained in [arg serial], the [arg configuration], a dictionary, and
+generates [vset NAME] markup encoding the table.
+
+The created string is then returned as the result of the command.
+
+[list_end]
+
+[include config/[vset CONFIG].inc]
+[include ../serialization.inc]
+
+[vset CATEGORY doctools]
+[include ../../../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2toc/include/format/doctoc.inc b/tcllib/modules/doctools2toc/include/format/doctoc.inc
new file mode 100644
index 0000000..6a82a7b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/format/doctoc.inc
@@ -0,0 +1,22 @@
+
+[section {[doctoc] notation of tables of contents}]
+
+The doctoc format for tables of contents, also called the
+[term {doctoc markup language}], is too large to be covered in single
+section.
+
+The interested reader should start with the document
+
+[list_begin enum]
+[enum] [manpage {doctoc language introduction}]
+[list_end]
+
+and then proceed from there to the formal specifications, i.e. the
+documents
+
+[list_begin enum]
+[enum] [manpage {doctoc language syntax}] and
+[enum] [manpage {doctoc language command reference}].
+[list_end]
+
+to get a thorough understanding of the language.
diff --git a/tcllib/modules/doctools2toc/include/format/json.inc b/tcllib/modules/doctools2toc/include/format/json.inc
new file mode 100644
index 0000000..1943241
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/format/json.inc
@@ -0,0 +1,74 @@
+
+[section {JSON notation of tables of contents}]
+
+The JSON format used for tables of contents is a direct translation of
+the [sectref {ToC serialization format}], mapping Tcl dictionaries as
+JSON objects and Tcl lists as JSON arrays.
+
+For example, the Tcl serialization
+
+[example {
+doctools::toc {
+ items {
+ {reference {
+ desc {DocTools - Tables of Contents}
+ id introduction.man
+ label doctools::toc::introduction
+ }}
+ {division {
+ id processing.man
+ items {
+ {reference {
+ desc {doctoc serialization utilities}
+ id structure.man
+ label doctools::toc::structure
+ }}
+ {reference {
+ desc {Parsing text in doctoc format}
+ id parse.man
+ label doctools::toc::parse
+ }}
+ }
+ label Processing
+ }}
+ }
+ label {Table of Contents}
+ title TOC
+}
+}]
+
+is equivalent to the JSON string
+
+[example {
+{
+ "doctools::toc" : {
+ "items" : [{
+ "reference" : {
+ "desc" : "DocTools - Tables of Contents",
+ "id" : "introduction.man",
+ "label" : "doctools::toc::introduction"
+ }
+ },{
+ "division" : {
+ "id" : "processing.man",
+ "items" : [{
+ "reference" : {
+ "desc" : "doctoc serialization utilities",
+ "id" : "structure.man",
+ "label" : "doctools::toc::structure"
+ }
+ },{
+ "reference" : {
+ "desc" : "Parsing text in doctoc format",
+ "id" : "parse.man",
+ "label" : "doctools::toc::parse"
+ }
+ }],
+ "label" : "Processing"
+ }
+ }],
+ "label" : "Table of Contents",
+ "title" : "TOC"
+ }
+}
+}]
diff --git a/tcllib/modules/doctools2toc/include/import/config/doctoc.inc b/tcllib/modules/doctools2toc/include/import/config/doctoc.inc
new file mode 100644
index 0000000..8ff41b9
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/import/config/doctoc.inc
@@ -0,0 +1 @@
+[include ../../format/doctoc.inc]
diff --git a/tcllib/modules/doctools2toc/include/import/config/json.inc b/tcllib/modules/doctools2toc/include/import/config/json.inc
new file mode 100644
index 0000000..8d1e06e
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/import/config/json.inc
@@ -0,0 +1 @@
+[include ../../format/json.inc]
diff --git a/tcllib/modules/doctools2toc/include/import/format/doctoc.inc b/tcllib/modules/doctools2toc/include/import/format/doctoc.inc
new file mode 100644
index 0000000..753fa4e
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/import/format/doctoc.inc
@@ -0,0 +1,12 @@
+[require doctools::toc::parse]
+[require doctools::toc::structure]
+[require doctools::msgcat]
+[require doctools::tcl::parse]
+[require fileutil]
+[require logger]
+[require snit]
+[require struct::list]
+[require struct::set]
+[require struct::stack]
+[require struct::tree]
+[require treeql]
diff --git a/tcllib/modules/doctools2toc/include/import/format/json.inc b/tcllib/modules/doctools2toc/include/import/format/json.inc
new file mode 100644
index 0000000..a16a34d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/import/format/json.inc
@@ -0,0 +1,2 @@
+[require doctools::toc::structure]
+[require json] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/include/import/plugin.inc b/tcllib/modules/doctools2toc/include/import/plugin.inc
new file mode 100644
index 0000000..abff582
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/import/plugin.inc
@@ -0,0 +1,55 @@
+[comment {-*- tcl -*- --- !doctools ---}]
+[manpage_begin doctools::toc::import::[vset PACKAGE] n 0.1]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc "[vset NAME] import plugin"]
+[category {Text formatter plugin}]
+[require Tcl 8.4]
+[require doctools::toc::import::[vset PACKAGE] [opt 0.1]]
+[include format/[vset REQUIRE].inc]
+[keywords doctools toc {table of contents} deserialization import [vset NAME]]
+[description]
+
+This package implements the doctools table of contents import plugin
+for the parsing of [vset NAME] markup.
+
+[para]
+
+This is an internal package of doctools, for use by the higher level
+management packages handling tables of contents, especially [package \
+doctools::toc::import], the import manager.
+
+[para]
+
+Using it from a regular interpreter is possible, however only with
+contortions, and is not recommended.
+
+The proper way to use this functionality is through the package
+[package doctools::toc::import] and the import manager objects it
+provides.
+
+
+[section API]
+
+The API provided by this package satisfies the specification of the
+doctoc import plugin API version 2.
+
+[list_begin definitions]
+
+[call [cmd import] [arg string] [arg configuration]]
+
+This command takes the [arg string] and parses it as [vset NAME]
+markup encoding a table of contents, in the context of the specified
+[arg configuration] (a dictionary). The result of the command is the
+canonical serialization of that table of contents, in the form
+specified in section [sectref {ToC serialization format}].
+
+[list_end]
+
+
+[include config/[vset CONFIG].inc]
+[include ../serialization.inc]
+
+[vset CATEGORY doctools]
+[include ../../../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2toc/include/msgcat.inc b/tcllib/modules/doctools2toc/include/msgcat.inc
new file mode 100644
index 0000000..5a32bd0
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/msgcat.inc
@@ -0,0 +1,46 @@
+[comment {-*- tcl -*- --- !doctools ---}]
+[manpage_begin doctools::msgcat::toc::[vset PACKAGE] n 0.1]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc "Message catalog for the doctoc parser ([vset NAME])"]
+[category {Documentation tools}]
+[require Tcl 8.4]
+[require msgcat]
+[require doctools::msgcat::toc::[vset PACKAGE] [opt 0.1]]
+[keywords doctools doctoc {message catalog}]
+[keywords localization l10n internationalization i18n]
+[keywords {catalog package} {message package}]
+[keywords [vset NAME]]
+[description]
+
+The package [package doctools::msgcat::toc::[vset PACKAGE]] is a
+support module providing the [vset LONGNAME] language message catalog
+for the doctoc parser in the doctools system version 2. As such it is
+an internal package a regular user (developer) should not be in direct
+contact with.
+
+[para]
+
+If you are such please go the documentation of either
+[list_begin enumerated]
+[enum] [package doctools::doc],
+[enum] [package doctools::toc], or
+[enum] [package doctools::idx]
+[list_end]
+[para]
+
+Within the system architecture this package resides under the package
+[package doctools::msgcat] providing the general message catalog
+management within the system. [emph Note] that there is [emph no]
+explicit dependency between the manager and catalog packages. The
+catalog is a plugin which is selected and loaded dynamically.
+
+
+[section API]
+
+This package has no exported API.
+
+
+[vset CATEGORY doctools]
+[include ../../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2toc/include/serialization.inc b/tcllib/modules/doctools2toc/include/serialization.inc
new file mode 100644
index 0000000..e8fc05e
--- /dev/null
+++ b/tcllib/modules/doctools2toc/include/serialization.inc
@@ -0,0 +1,131 @@
+[section {ToC serialization format}]
+
+Here we specify the format used by the doctools v2 packages to
+serialize tables of contents as immutable values for transport,
+comparison, etc.
+
+[para]
+
+We distinguish between [term regular] and [term canonical]
+serializations.
+
+While a table of contents may have more than one regular serialization
+only exactly one of them will be [term canonical].
+
+[para]
+
+[list_begin definitions][comment {-- serializations --}]
+[def {regular serialization}]
+
+[list_begin enumerated][comment {-- regular points --}]
+[enum]
+The serialization of any table of contents is a nested Tcl dictionary.
+
+[enum]
+This dictionary holds a single key, [const doctools::toc], and its
+value. This value holds the contents of the table of contents.
+
+[enum]
+
+The contents of the table of contents are a Tcl dictionary holding the
+title of the table of contents, a label, and its elements. The
+relevant keys and their values are
+
+[list_begin definitions][comment {-- keywords --}]
+[def [const title]]
+The value is a string containing the title of the table of contents.
+
+[def [const label]]
+The value is a string containing a label for the table of contents.
+
+[def [const items]]
+The value is a Tcl list holding the elements of the table, in the
+order they are to be shown.
+
+[para]
+Each element is a Tcl list holding the type of the item, and its
+description, in this order. An alternative description would be that
+it is a Tcl dictionary holding a single key, the item type, mapped to
+the item description.
+
+[para]
+The two legal item types and their descriptions are
+
+[list_begin definitions][comment {-- item types --}]
+[def [const reference]]
+This item describes a single entry in the table of contents,
+referencing a single document.
+
+To this end its value is a Tcl dictionary containing an id for the
+referenced document, a label, and a longer textual description which
+can be associated with the entry.
+
+The relevant keys and their values are
+
+[list_begin definitions][comment {-- reference keywords --}]
+[def [const id]]
+The value is a string containing the id of the document associated
+with the entry.
+
+[def [const label]]
+The value is a string containing a label for this entry. This string
+also identifies the entry, and no two entries (references and
+divisions) in the containing list are allowed to have the same label.
+
+[def [const desc]]
+The value is a string containing a longer description for this entry.
+
+[list_end][comment {-- reference keywords --}]
+
+
+[def [const division]]
+This item describes a group of entries in the table of contents,
+inducing a hierarchy of entries.
+
+To this end its value is a Tcl dictionary containing a label for the
+group, an optional id to a document for the whole group, and the list
+of entries in the group.
+
+The relevant keys and their values are
+
+[list_begin definitions][comment {-- division keywords --}]
+[def [const id]]
+The value is a string containing the id of the document associated
+with the whole group. This key is optional.
+
+[def [const label]]
+The value is a string containing a label for the group. This string
+also identifies the entry, and no two entries (references and
+divisions) in the containing list are allowed to have the same label.
+
+[def [const items]]
+The value is a Tcl list holding the elements of the group, in the
+order they are to be shown.
+
+This list has the same structure as the value for the keyword
+[const items] used to describe the whole table of contents, see
+above. This closes the recusrive definition of the structure, with
+divisions holding the same type of elements as the whole table of
+contents, including other divisions.
+
+[list_end][comment {-- division keywords --}]
+[list_end][comment {-- item types --}]
+[list_end][comment {-- keywords --}]
+[list_end][comment {-- regular points --}]
+
+[def {canonical serialization}]
+
+The canonical serialization of a table of contents has the format as
+specified in the previous item, and then additionally satisfies the
+constraints below, which make it unique among all the possible
+serializations of this table of contents.
+
+[list_begin enumerated][comment {-- canonical points --}]
+[enum]
+
+The keys found in all the nested Tcl dictionaries are sorted in
+ascending dictionary order, as generated by Tcl's builtin command
+[cmd {lsort -increasing -dict}].
+
+[list_end][comment {-- canonical points --}]
+[list_end][comment {-- serializations --}]
diff --git a/tcllib/modules/doctools2toc/msgcat_c.tcl b/tcllib/modules/doctools2toc/msgcat_c.tcl
new file mode 100644
index 0000000..31a8e54
--- /dev/null
+++ b/tcllib/modules/doctools2toc/msgcat_c.tcl
@@ -0,0 +1,28 @@
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+mcset c doctoc/char/syntax {Bad character in string}
+mcset c doctoc/cmd/illegal {Illegal command "%1$s", not a doctoc command} ; # Details: cmdname
+mcset c doctoc/cmd/nested {Illegal use of "%1$s" as argument of other command} ; # Details: cmdname
+mcset c doctoc/cmd/toomanyargs {Too many args for "%1$s", at most %2$d allowed} ; # Details: cmdname, max#args
+mcset c doctoc/cmd/wrongargs {Wrong#args for "%1$s", need at least %2$d} ; # Details: cmdname, min#args
+mcset c doctoc/eof/syntax {Bad <eof>}
+mcset c doctoc/include/path/notfound {Include file "%1$s" not found} ; # Details: file name
+mcset c doctoc/include/read-failed {Unable to read include file "%1$s", %2$s} ; # Details: file name and error msg
+mcset c doctoc/include/syntax {Errors in include file "%1$s"}
+mcset c doctoc/plaintext {Plain text beyond whitespace is not allowed}
+mcset c doctoc/vset/varname/unknown {Unknown variable "%1$s"} ; # Details: variable name
+
+mcset c doctoc/division_end/missing {Expected [division_end], not found}
+mcset c doctoc/division_end/syntax {Unexpected [division_end], not allowed here}
+mcset c doctoc/division_start/syntax {Expected [division_start], not found}
+mcset c doctoc/item/syntax {Unexpected [item], not allowed here}
+mcset c doctoc/toc_begin/missing {Expected [toc_begin], not found}
+mcset c doctoc/toc_begin/syntax {Unexpected [toc_begin], not allowed here}
+mcset c doctoc/toc_end/missing {Expected [toc_end], not found}
+mcset c doctoc/toc_end/syntax {Unexpected [toc_end], not allowed here}
+
+mcset c doctoc/redef {Bad reuse of label "%1$s"}
+
+package provide doctools::msgcat::toc::c 0.1
diff --git a/tcllib/modules/doctools2toc/msgcat_de.tcl b/tcllib/modules/doctools2toc/msgcat_de.tcl
new file mode 100644
index 0000000..23ef4a2
--- /dev/null
+++ b/tcllib/modules/doctools2toc/msgcat_de.tcl
@@ -0,0 +1,28 @@
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+mcset de doctoc/char/syntax {Unerwartetes Zeichen im String}
+mcset de doctoc/cmd/illegal {Illegaler Befehl "%1$s", ist kein doctoc Befehl} ; # Details: cmdname
+mcset de doctoc/cmd/nested {Illegale Nutzung von "%1$s" als Argument eines anderen Befehles} ; # Details: cmdname
+mcset de doctoc/cmd/toomanyargs {Zu viele Argumente fuer "%1$s", hoechstens %2$d moeglich} ; # Details: cmdname, max#args
+mcset de doctoc/cmd/wrongargs {Zu wenig Argumente fuer "%1$s", mindestens %2$d notwendig} ; # Details: cmdname, min#args
+mcset de doctoc/eof/syntax {Unerwartetes Ende der Datei}
+mcset de doctoc/include/path/notfound {Include-Datei "%1$s" nicht gefunden} ; # Details: file name
+mcset de doctoc/include/read-failed {Konnte Include-Datei "%1$s" nicht lesen: %2$s} ; # Details: file name and error msg
+mcset de doctoc/include/syntax {Fehler in der Include-Datei "%1$s"}
+mcset de doctoc/plaintext {Normaler Text ist (mit Ausnahme von reinem Leerraum) nicht erlaubt}
+mcset de doctoc/vset/varname/unknown {Unbekannte Variable "%1$s"} ; # Details: variable name
+
+mcset de doctoc/division_end/missing {Erwarteter Befehl [division_end] nicht vorhanden}
+mcset de doctoc/division_end/syntax {[division_end] ist hier nicht erlaubt}
+mcset de doctoc/division_start/syntax {Erwarteter Befehl [division_start] nicht vorhanden}
+mcset de doctoc/item/syntax {[item] ist hier nicht erlaubt}
+mcset de doctoc/toc_begin/missing {Erwarteter Befehl [toc_begin] nicht vorhanden}
+mcset de doctoc/toc_begin/syntax {[toc_begin] ist hier nicht erlaubt}
+mcset de doctoc/toc_end/missing {Erwarteter Befehl [toc_end] nicht vorhanden}
+mcset de doctoc/toc_end/syntax {[toc_end] ist hier nicht erlaubt}
+
+mcset de doctoc/redef {Fehlerhafte Wiederverwendung des Labels "%1$s"}
+
+package provide doctools::msgcat::toc::de 0.1
diff --git a/tcllib/modules/doctools2toc/msgcat_en.tcl b/tcllib/modules/doctools2toc/msgcat_en.tcl
new file mode 100644
index 0000000..f996281
--- /dev/null
+++ b/tcllib/modules/doctools2toc/msgcat_en.tcl
@@ -0,0 +1,28 @@
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+mcset en doctoc/char/syntax {Bad character in string}
+mcset en doctoc/cmd/illegal {Illegal command "%1$s", not a doctoc command} ; # Details: cmdname
+mcset en doctoc/cmd/nested {Illegal use of "%1$s" as argument of other command} ; # Details: cmdname
+mcset en doctoc/cmd/toomanyargs {Too many args for "%1$s", at most %2$d allowed} ; # Details: cmdname, max#args
+mcset en doctoc/cmd/wrongargs {Wrong#args for "%1$s", need at least %2$d} ; # Details: cmdname, min#args
+mcset en doctoc/eof/syntax {Bad <eof>}
+mcset en doctoc/include/path/notfound {Include file "%1$s" not found} ; # Details: file name
+mcset en doctoc/include/read-failed {Unable to read include file "%1$s", %2$s} ; # Details: file name and error msg
+mcset en doctoc/include/syntax {Errors in include file "%1$s"}
+mcset en doctoc/plaintext {Plain text beyond whitespace is not allowed}
+mcset en doctoc/vset/varname/unknown {Unknown variable "%1$s"} ; # Details: variable name
+
+mcset en doctoc/division_end/missing {Expected [division_end], not found}
+mcset en doctoc/division_end/syntax {Unexpected [division_end], not allowed here}
+mcset en doctoc/division_start/syntax {Expected [division_start], not found}
+mcset en doctoc/item/syntax {Unexpected [item], not allowed here}
+mcset en doctoc/toc_begin/missing {Expected [toc_begin], not found}
+mcset en doctoc/toc_begin/syntax {Unexpected [toc_begin], not allowed here}
+mcset en doctoc/toc_end/missing {Expected [toc_end], not found}
+mcset en doctoc/toc_end/syntax {Unexpected [toc_end], not allowed here}
+
+mcset en doctoc/redef {Bad reuse of label "%1$s"}
+
+package provide doctools::msgcat::toc::en 0.1
diff --git a/tcllib/modules/doctools2toc/msgcat_fr.tcl b/tcllib/modules/doctools2toc/msgcat_fr.tcl
new file mode 100644
index 0000000..7317aae
--- /dev/null
+++ b/tcllib/modules/doctools2toc/msgcat_fr.tcl
@@ -0,0 +1,31 @@
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+# The texts are in english because I have do not have enough knowledge
+# of french to make the translation.
+
+mcset fr doctoc/char/syntax {Bad character in string}
+mcset fr doctoc/cmd/illegal {Illegal command "%1$s", not a doctoc command} ; # Details: cmdname
+mcset fr doctoc/cmd/nested {Illegal use of "%1$s" as argument of other command} ; # Details: cmdname
+mcset fr doctoc/cmd/toomanyargs {Too many args for "%1$s", at most %2$d allowed} ; # Details: cmdname, max#args
+mcset fr doctoc/cmd/wrongargs {Wrong#args for "%1$s", need at least %2$d} ; # Details: cmdname, min#args
+mcset fr doctoc/eof/syntax {Bad <eof>}
+mcset fr doctoc/include/path/notfound {Include file "%1$s" not found} ; # Details: file name
+mcset fr doctoc/include/read-failed {Unable to read include file "%1$s", %2$s} ; # Details: file name and error msg
+mcset fr doctoc/include/syntax {Errors in include file "%1$s"}
+mcset fr doctoc/plaintext {Plain text beyond whitespace is not allowed}
+mcset fr doctoc/vset/varname/unknown {Unknown variable "%1$s"} ; # Details: variable name
+
+mcset fr doctoc/division_end/missing {Expected [division_end], not found}
+mcset fr doctoc/division_end/syntax {Unexpected [division_end], not allowed here}
+mcset fr doctoc/division_start/syntax {Expected [division_start], not found}
+mcset fr doctoc/item/syntax {Unexpected [item], not allowed here}
+mcset fr doctoc/toc_begin/missing {Expected [toc_begin], not found}
+mcset fr doctoc/toc_begin/syntax {Unexpected [toc_begin], not allowed here}
+mcset fr doctoc/toc_end/missing {Expected [toc_end], not found}
+mcset fr doctoc/toc_end/syntax {Unexpected [toc_end], not allowed here}
+
+mcset fr doctoc/redef {Bad reuse of label "%1$s"}
+
+package provide doctools::msgcat::toc::fr 0.1
diff --git a/tcllib/modules/doctools2toc/parse.tcl b/tcllib/modules/doctools2toc/parse.tcl
new file mode 100644
index 0000000..0bb5e69
--- /dev/null
+++ b/tcllib/modules/doctools2toc/parse.tcl
@@ -0,0 +1,1058 @@
+# -*- tcl -*-
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Parser for doctoc formatted input. The result is a struct::tree
+# repesenting the contents of the document in a structured form.
+
+# - root = table, attributes for title and label.
+# - children of the root = if any, elements of the table, references and divisions.
+# - children of divisions = if any, elements of the division, references and divisions.
+#
+# The order of the elements under root, and of the elements under
+# their division reflects the order of the information in the parsed
+# document.
+
+# Attributes in the nodes, except root provide location information,
+# i.e. refering from there in the input the information is coming from
+# (human-readable output: line/col for end of token, offset start/end
+# for range covered by token.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.4 ; # Required runtime.
+package require doctools::toc::structure ; # Parse Tcl script, like subst.
+package require doctools::msgcat ; # Error message L10N
+package require doctools::tcl::parse ; # Parse Tcl script, like subst.
+package require fileutil ; # Easy loading of files.
+package require logger ; # User feedback.
+package require snit ; # OO system.
+package require struct::list ; # Assign
+package require struct::tree ; # Internal syntax tree
+
+# # ## ### ##### ######## ############# #####################
+##
+
+logger::initNamespace ::doctools::toc::parse
+snit::type ::doctools::toc::parse {
+ # # ## ### ##### ######## #############
+ ## Public API
+
+ typemethod file {path} {
+ log::debug [list $type file]
+ return [$type text [fileutil::cat $path] $path]
+ }
+
+ typemethod text {text {path {}}} {
+ log::debug [list $type text]
+
+ set ourfile $path
+
+ array set vars [array get ourvars]
+ array set _file {}
+ ClearErrors
+
+ set t [struct::tree AST]
+
+ Process $t $text [$t rootname] vars _file
+ StopOnErrors
+
+ ReshapeTree $t
+ StopOnErrors
+
+ set serial [Serialize $t]
+ StopOnErrors
+
+ $t destroy
+ return $serial
+ }
+
+ # # ## ### ##### ######## #############
+ ## Manage symbol table (vset variables).
+
+ typemethod vars {} {
+ return [array get ourvars]
+ }
+
+ typemethod {var set} {name value} {
+ set ourvars($name) $value
+ return
+ }
+
+ typemethod {var load} {dict} {
+ array set ourvars $dict
+ return
+ }
+
+ typemethod {var unset} {args} {
+ if {![llength $args]} { lappend args * }
+ foreach pattern $args {
+ array unset ourvars $pattern
+ }
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Manage search paths for include files.
+
+ typemethod includes {} {
+ return $ourincpaths
+ }
+
+ typemethod {include set} {paths} {
+ set ourincpaths [lsort -uniq $paths]
+ return
+ }
+
+ typemethod {include add} {path} {
+ lappend ourincpaths $path
+ set ourincpaths [lsort -uniq $ourincpaths]
+ return
+ }
+
+ typemethod {include remove} {path} {
+ set pos [lsearch $ourincpaths $path]
+ if {$pos < 0} return
+ set ourincpaths [lreplace $ourincpaths $pos $pos]
+ return
+ }
+
+ typemethod {include clear} {} {
+ set ourincpaths {}
+ return
+ }
+
+ # # ## ### ##### ######## #############
+
+ proc Process {t text root vv fv} {
+ upvar 1 $vv vars $fv _file
+
+ DropChildren $t $root
+
+ # Phase 1. Generate the basic syntax tree
+
+ if {[catch {
+ doctools::tcl::parse text $t $text $root
+ } msg]} {
+ if {![string match {doctools::tcl::parse *} $::errorCode]} {
+ # Not a parse error, rethrow.
+ return \
+ -code error \
+ -errorcode $::errorCode \
+ -errorinfo $::errorInfo \
+ $msg
+ }
+
+ # Parse error, low-level syntax breakdown, extract the
+ # machine-info from the errorCode, and report internally.
+ # See the documentation of doctools::tcl::parse for the
+ # definition of the format.
+ struct::list assign $::errorCode _ msg pos line col
+ # msg in {eof, char}
+ ReportAt $_file($root) [list $pos $pos] $line $col doctoc/$msg/syntax {}
+ return 0
+ }
+
+ #doctools::parse::tcl::ShowTreeX $t {Raw Result}
+
+ # Phase 2. Check for errors.
+
+ CheckBasicConstraints $t $root _file
+ ResolveVarsAndIncludes $t $root vars _file
+ return 1
+ }
+
+ proc CheckBasicConstraints {t root fv} {
+ ::variable ourfile
+ upvar 1 $fv _file
+
+ # Bottom-up walk through the nodes starting at the current
+ # root.
+
+ $t walk $root -type dfs -order pre n {
+ # Ignore the root node itself. Except for one thing: The
+ # path information is remembered for the root as well.
+
+ set _file($n) $ourfile
+ #puts "_file($n) = $ourfile"
+ if {$n eq $root} continue
+
+ switch -exact [$t get $n type] {
+ Text {
+ # Texts at the top level are irrelevant and
+ # removed. They have to contain only whitespace as
+ # well.
+ if {[$t depth $n] == 1} {
+ if {[regexp {[^[:blank:]\n]} [$t get $n text]]} {
+ Error $t $n doctoc/plaintext
+ }
+ MarkDrop $n
+ }
+ }
+ Word {
+ # Word nodes we ignore. They are just argument
+ # aggregators. They will be gone later, when
+ # reduce arguments to their text form.
+ }
+ Command {
+ set cmdname [$t get $n text]
+ set parens [$t parent $n]
+
+ if {$parens eq $root} {
+ set parentt {}
+ } else {
+ set parentt [$t get $parens type]
+ }
+ set nested 0
+
+ if {($parentt eq "Command") || ($parentt eq "Word")} {
+ # Commands can be children/arguments of other
+ # commands only in very restricted
+ # circumstances => rb, lb, vset/1.
+ set nested 1
+ if {![Nestable $t $n $cmdname errcmdname] && [Legal $cmdname]} {
+ # Report only legal un-nestable commands.
+ # Illegal commands get their own report,
+ # see below.
+ MakeErrorMsg $t $n doctoc/cmd/nested $errcmdname
+ }
+ }
+
+ if {![Legal $cmdname]} {
+ # Deletion is safe because we are walking
+ # bottom up. If nested we drop only the
+ # children and replace this node with a fake.
+ if {$nested} {
+ MakeErrorMsg $t $n doctoc/cmd/illegal $cmdname
+ } else {
+ Error $t $n doctoc/cmd/illegal $cmdname
+ MarkDrop $n
+ }
+
+ continue
+ }
+
+ # Check arguments of the legal commands only.
+ ArgInfo $cmdname min max
+ set argc [llength [$t children $n]]
+
+ if {$argc < $min} {
+ MakeErrorMsg $t $n doctoc/cmd/wrongargs $cmdname $min
+ } elseif {$argc > $max} {
+ MakeErrorMsg $t $n doctoc/cmd/toomanyargs $cmdname $max
+ }
+
+ # Convert the quoting commands for bracket into
+ # equivalent text nodes, and remove comments.
+ if {$cmdname eq "lb"} {
+ MakeText $t $n "\["
+ } elseif {$cmdname eq "rb"} {
+ MakeText $t $n "\]"
+ } elseif {$cmdname eq "comment"} {
+ # Remove comments or replace with error node (nested).
+ if {$nested} {
+ MakeError $t $n
+ } else {
+ MarkDrop $n
+ }
+ }
+ }
+ }
+ }
+
+ # Kill the nodes marked for removal now that the walker is not
+ # accessing them any longer.
+ PerformDrop $t
+
+ #doctools::parse::tcl::ShowTreeX $t {Basic Constraints}
+ return
+ }
+
+ proc ResolveVarsAndIncludes {t root vv fv} {
+ upvar 1 $vv vars $fv _file
+
+ # Now resolve include and vset uses ... This has to be done at
+ # the same time, as each include may (re)define variables.
+
+ # Bottom-up walk. Children before parent, and from the left =>
+ # Nested vset uses are resolved in the proper order.
+
+ $t walk $root -type dfs -order post n {
+ # Ignore the root node itself.
+ if {$n eq $root} continue
+
+ set ntype [$t get $n type]
+
+ switch -exact -- $ntype {
+ Text - Error {
+ # Ignore these nodes.
+ }
+ Word {
+ # Children have to be fully converted to Text, or,
+ # in case of trouble, Error. Aggregate the
+ # information.
+ CollapseWord $t $n
+ }
+ Command {
+ set cmdname [$t get $n text]
+
+ switch -exact -- $cmdname {
+ vset {
+ set argv [$t children $n]
+ switch -exact -- [llength $argv] {
+ 1 {
+ VariableUse $t $n [lindex $argv 0]
+ }
+ 2 {
+ struct::list assign $argv var val
+ VariableDefine $t $n $var $val
+ }
+ }
+ # vset commands at the structural toplevel are
+ # irrelevant and removed.
+ if {[$t depth $n] == 1} {
+ MarkDrop $n
+ }
+ }
+ include {
+ # Pulls vars, _file from this scope
+ ProcessInclude $t $n [lindex [$t children $n] 0]
+ }
+ default {
+ # For all other commands move the argument
+ # information into an attribute. Errors in
+ # the argument cause the command to conert
+ # into an error.
+ CollapseArguments $t $n
+ }
+ }
+ }
+ }
+ }
+
+ # Kill the nodes marked for removal now that the walker is
+ # not accessing them any longer.
+ PerformDrop $t
+
+ #doctools::parse::tcl::ShowTreeX $t {Vars/Includes Resolved}
+ return
+ }
+
+ proc ReshapeTree {t} {
+ upvar 1 _file _file
+
+ # We are assuming that there are no illegal commands in the
+ # tree, and further that all of lb, rb, vset, comment, and
+ # include are gone as well, per the operation of the previous
+ # phases (-> CheckBasicConstraints, ResolveVarsAndIncludes).
+ # The only commands which can occur here are
+ #
+ # toc_begin, toc_end, division_start, division_end, item
+
+ # Grammar:
+ # TOC := toc_begin ITEMS toc_end
+ # ITEMS := { item | DIV }
+ # DIV := division_start ITEMS division_end
+
+ # Hand coded LL(1) parser with explicit stack and state
+ # machine.
+
+ set root [$t rootname]
+ set children [$t children $root]
+ lappend children $root
+
+ $t set $root text <EOF>
+ $t set $root range {0 0}
+ $t set $root line 1
+ $t set $root col 0
+
+ set st [struct::stack %AUTO%]
+ set at {}
+ set state TOC
+
+ foreach n $children {
+ #puts ____[$t get $n text]($n)
+
+ set cmdname [$t get $n text]
+ #puts <$n>|$cmdname|$state|
+
+ # We store the location of the last node in the root, for
+ # use when an unexpected eof triggers an error.
+ if {$n ne $root} {
+ $t set $root range [$t get $n range]
+ $t set $root line [$t get $n line]
+ $t set $root col [$t get $n col]
+ }
+
+ # LL(1) parser table. State/Nexttoken determine action and
+ # next state.
+ switch -exact -- [list $state $cmdname] {
+ {TOC toc_begin} {
+ # Pull arguments of the proper toc_begin up into
+ # the root. Drop the expected node.
+ $t set $root argv [$t get $n argv]
+ $t delete $n
+ #puts \t/drop/$n
+ # Starting series of toplevel items and divisions.
+ # Destination for movement is root, and we remember
+ # the state.
+ $st push $at
+ $st push $state
+ set at $root
+ #puts \t/p=$at
+ set state ITEMS
+ }
+ {ITEMS item} {
+ # Move item to proper parent. Nothing needed to be
+ # done for the toplevel items.
+ }
+ {ITEMS division_start} -
+ {DIV division_start} {
+ # Sub division begins, toplevel or deeper. Mark it
+ # as new movement destination, and remember the
+ # state. Also, do not forget to move it as well.
+ if {$at ne $root} {
+ $t move $at end $n
+ #puts \t/moveto/$at
+ }
+ $st push $at
+ $st push $state
+ set at $n
+ #puts \t/p=$at
+ set state DIV
+ }
+ {ITEMS toc_end} {
+ # End of the document reached, with proper closing
+ # of sub divisions and all. Drop the node, and go
+ # to end state
+ set state EOF
+ $t delete $n
+ #puts \t/drop/$n
+ }
+ {DIV item} {
+ # Move item to proper parent.
+ $t move $at end $n
+ #puts \t/moveto/$at
+ }
+ {DIV division_end} {
+ # Drop the node, pop the state and restore the
+ # previous state/destination.
+ $t delete $n
+ #puts \t/drop/$n
+ set state [$st pop]
+ set at [$st pop]
+ #puts \t/p=$at
+ }
+ {EOF <EOF>} {
+ # Good, really reached the end. Nothing to be
+ # done.
+ }
+ {TOC division_end} -
+ {TOC division_start} -
+ {TOC item} -
+ {TOC toc_end} {
+ Error $t $n doctoc/toc_begin/missing
+ $t delete $n
+ #puts \t/drop/$n
+ }
+ {EOF division_start} -
+ {ITEMS division_end} -
+ {EOF division_end} -
+ {EOF item} -
+ {ITEMS toc_begin} -
+ {EOF toc_begin} -
+ {DIV toc_begin} -
+ {EOF toc_end} -
+ {DIV toc_end} {
+ # TODO ?! Split this, and add message which command was expected.
+ # Unexpected and wrong. The node is dropped.
+ Error $t $n doctoc/$cmdname/syntax
+ $t delete $n
+ #puts \t/drop/$n
+ }
+ {TOC <EOF>} {
+ Error $t $n doctoc/toc_begin/missing
+ }
+ {ITEMS <EOF>} {
+ Error $t $n doctoc/toc_end/missing
+ }
+ {DIV <EOF>} {
+ Error $t $n doctoc/division_end/missing
+ }
+ }
+ }
+
+ $st destroy
+
+ $t unset $root text
+ $t unset $root range
+ $t unset $root line
+ $t unset $root col
+
+ #doctools::parse::tcl::ShowTreeX $t Shaped/Structure
+ return
+ }
+
+ proc Serialize {t} {
+ upvar 1 _file _file
+ # We assume here that the tree is already in the correct
+ # shape/structure, i.e. root, children for references and
+ # divisions, with divisions possibly having children and well.
+
+ # We now extract the basic information about the table from
+ # the tree, do some higher level checking on the elements and
+ # return the serialization of the table generated from the
+ # extracted data.
+
+ set error 0
+ set root [$t rootname]
+
+ # Root delivers toc label and title.
+ struct::list assign [$t get $root argv] label title
+
+ set prefix ....
+ set items [GetDivision $t $root error]
+
+ if {$error} return
+ # Caller will handle the errors.
+
+ ## ### ### ### ######### ######### #########
+ ## The part below is identical to the serialization backend of
+ ## command 'doctools::toc::structure merge'.
+
+ # Now construct the result, from the inside out, with proper
+ # sorting at all levels.
+
+ set serial [list doctools::toc \
+ [list \
+ items $items \
+ label $label \
+ title $title]]
+
+ # Caller verify, ensure contract
+ #::doctools::toc::structure verify-as-canonical $serial
+ return $serial
+ }
+
+ proc GetDivision {t root ev} {
+ upvar 1 $ev error _file _file
+ array set l {} ; # Label counters
+ set items {}
+
+ # Each element in the tree
+ foreach element [$t children $root] {
+ switch -exact -- [$t get $element text] {
+ item {
+ struct::list assign [$t get $element argv] file label desc
+ lappend items [list reference [list \
+ desc $desc \
+ id $file \
+ label $label]]
+ lappend l($label) .
+ }
+ division_start {
+ struct::list assign [$t get $element argv] label file
+ set subitems [GetDivision $t $element error]
+ if {$error} return
+ set res {}
+ if {$file ne {}} {
+ lappend res id $file
+ }
+ lappend res \
+ items $subitems \
+ label $label
+ lappend items [list division $res]
+ lappend l($label) .
+ }
+ }
+ if {[llength $l($label)] > 1} {
+ MakeErrorMsg $t $element doctoc/redef $label
+ set error 1
+ return
+ }
+ }
+ return $items
+ }
+
+ # # ## ### ##### ######## #############
+
+ proc CollapseArguments {t n} {
+ #puts __CA($n)
+
+ set ok 1
+ set argv {}
+ foreach ch [$t children $n] {
+ lappend argv [$t get $ch text]
+ if {[$t get $ch type] eq "Error"} {
+ set ok 0
+ break
+ }
+ }
+ if {$ok} {
+ $t set $n argv $argv
+ DropChildren $t $n
+ } else {
+ MakeError $t $n
+ }
+ return
+ }
+
+ proc CollapseWord {t n} {
+ #puts __CW($n)
+
+ set ok 1
+ set text {}
+ foreach ch [$t children $n] {
+ append text [$t get $ch text]
+ if {[$t get $ch type] eq "Error"} {
+ set ok 0
+ break
+ }
+ }
+ if {$ok} {
+ MakeText $t $n $text
+ } else {
+ MakeError $t $n
+ }
+ return
+ }
+
+ proc VariableUse {t n var} {
+ upvar 1 vars vars _file _file
+
+ # vset/1 - the command returns text information to the
+ # caller. Extract the argument data.
+
+ set vartype [$t get $var type]
+ set varname [$t get $var text]
+
+ # Remove the now superfluous argument nodes.
+ DropChildren $t $n
+
+ if {$vartype eq "Error"} {
+ # First we check if the command is in trouble because it
+ # has a bogus argument. If so we convert it into an error
+ # node to signal even higher commands, and ignore it. We
+ # do not report an error, as the actual problem was
+ # reported already.
+
+ MakeError $t $n
+ } elseif {![info exists vars($varname)]} {
+ # Secondly we check if the referenced variable is
+ # known. If not it is trouble, and we report it.
+
+ MakeErrorMsg $t $n doctoc/vset/varname/unknown $varname
+ } elseif {[$t depth $n] == 1} {
+ # Commands at the structural toplevel are irrelevant and
+ # removed (see caller). They have to checked again however
+ # to see if the use introduced non-whitespace where it
+ # should not be.
+
+ if {[regexp {[^[:blank:]\n]} $vars($varname)]} {
+ Error $t $n doctoc/plaintext
+ }
+ } else {
+ MakeText $t $n $vars($varname)
+ }
+ }
+
+ proc VariableDefine {t n var val} {
+ upvar 1 vars vars
+
+ # vset/2 - the command links a variable to a value. Extract
+ # the argument data.
+
+ set vartype [$t get $var type]
+ set valtype [$t get $val type]
+ set varname [$t get $var text]
+ set value [$t get $val text]
+
+ # Remove the now superfluous argument nodes.
+ DropChildren $t $n
+
+ if {($vartype eq "Error") || ($valtype eq "Error")} {
+ # First we check if the command is in trouble because it
+ # has one or more bogus arguments. If so we convert it
+ # into an error node to signal even higher commands, and
+ # ignore it. We do not report an error, as the actual
+ # problem was reported already.
+
+ MakeError $t $n
+ return
+ }
+
+ # And save the change to the symbol table we are lugging
+ # around during the processing.
+
+ set vars($varname) $value
+ return
+ }
+
+ proc ProcessInclude {t n path} {
+ upvar 1 vars vars _file _file
+ ::variable ourfile
+
+ # include - the command returns file content and inserts it in
+ # the place of the command. First extract the argument data
+
+ set pathtype [$t get $path type]
+ set pathname [$t get $path text]
+
+ # Remove the now superfluous argument nodes.
+ DropChildren $t $n
+
+ # Check for problems stemming from other trouble.
+ if {$pathtype eq "Error"} {
+ # First we check if the command is in trouble because it
+ # has a bogus argument. If so convert it into an error
+ # node to signal even higher commands, and ignore it. We
+ # do not report an error, as the actual problem was
+ # reported already.
+
+ MakeError $t $n
+ return
+ }
+
+ if {![GetFile $ourfile $pathname text fullpath error emsg]} {
+ switch -exact -- $error {
+ notfound { Error $t $n doctoc/include/path/notfound $pathname }
+ notread { Error $t $n doctoc/include/read-failed $fullpath $emsg }
+ }
+ MarkDrop $n
+ return
+ }
+
+ # Parse the file. This also resolves variables further.
+
+ set currenterrors [GetErrors]
+ set currentpath $ourfile
+ ClearErrors
+
+ # WIBNI :: Remember the path as relative to the current path.
+ set ourfile $fullpath
+ if {![Process $t $text $n vars _file]} {
+
+ set newerrors [GetErrors]
+ SetErrors $currenterrors
+ set ourfile $currentpath
+ Error $t $n doctoc/include/syntax $fullpath $newerrors
+ MarkDrop $n
+ return
+ }
+
+ if {![$t numchildren $n]} {
+ # Inclusion did not generate additional content, we can
+ # ignore the command completely.
+ MarkDrop $n
+ return
+ }
+
+ # Create marker nodes which show the file entry/exit
+ # transitions. Disabled, makes shaping tree structure too
+ # complex. And checking the syntax as well, if we wish to have
+ # only proper complete structures in an include file. Need
+ # proper LR parser for that (is not LL(1)), or maybe even
+ # something like earley-aycock for full handling of an
+ # ambigous grammar.
+ if 0 {
+ set fstart [$t insert $n 0]
+ set fstop [$t insert $n end]
+
+ $t set $fstart type Command
+ $t set $fstop type Command
+
+ $t set $fstart text include_begin
+ $t set $fstop text include_end
+
+ $t set $fstart path $fullpath
+ $t set $fstop path $fullpath
+ }
+ # Remove the include command itself, merging its children
+ # into the place it occupied in its parent.
+ $t cut $n
+ return
+ }
+
+ # # ## ### ##### ######## #############
+
+ ## Note: The import plugin for doctoc rewrites the 'GetFile'
+ ## command below to make use of an alias provided by the
+ ## plugin manager. This re-enables the ability of this class
+ ## to handle include files which would otherwise be gone due
+ ## to the necessary file operations (exists, isfile,
+ ## readable, open, read) be disallowed by the safe
+ ## environment the plugin operates in.
+ ##
+ ## Any changes to GetFile have to reviewed for their impact on
+ ## doctools::toc::import::doctoc, and possibly ported over.
+
+ proc GetFile {currentfile path dv pv ev mv} {
+ upvar 1 $dv data $pv fullpath $ev error $mv emessage
+ set data {}
+ set error {}
+ set emessage {}
+
+ # Find the file, or not.
+ set fullpath [Locate $path]
+ if {$fullpath eq {}} {
+ set fullpath $path
+ set error notfound
+ return 0
+ }
+
+ # Read contents, or not.
+ if {[catch {
+ set data [fileutil::cat $fullpath]
+ } msg]} {
+ set error notread
+ set emessage $msg
+ return 0
+ }
+
+ return 1
+ }
+
+ proc Locate {path} {
+ upvar 1 currentfile currentfile
+
+ if {$currentfile ne {}} {
+ set pathstosearch \
+ [linsert $ourincpaths 0 \
+ [file dirname [file normalize $currentfile]]]
+ } else {
+ set pathstosearch $ourincpaths
+ }
+
+ foreach base $pathstosearch {
+ set try [file join $base $path]
+ if {![file exists $try]} continue
+ return $try
+ }
+ # Nothing found
+ return {}
+ }
+
+ # # ## ### ##### ######## #############
+ ## Management of nodes to kill
+
+ proc MarkDrop {n} {
+ ::variable ourtokill
+ lappend ourtokill $n
+ #puts %%mark4kill=$n|[info level -1]
+ return
+ }
+
+ proc DropChildren {t n} {
+ foreach child [$t children $n] {
+ MarkDrop $child
+ }
+ return
+ }
+
+ proc PerformDrop {t} {
+ ::variable ourtokill
+ #puts __PD($t)=<[join $ourtokill ,]>
+ foreach n $ourtokill {
+ #puts x($n/[$t exists $n])
+ if {![$t exists $n]} continue
+ #puts ^^DEL($n)
+ $t delete $n
+ }
+ set ourtokill {}
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Command predicates
+
+ proc Nestable {t n cmdname cv} {
+ upvar 1 $cv outname
+ set outname $cmdname
+ switch -exact -- $cmdname {
+ lb - rb { return 1 }
+ vset {
+ if {[$t numchildren $n] == 1} {
+ return 1
+ }
+ append outname /2
+ }
+ }
+ return 0
+ }
+
+ proc Legal {cmdname} {
+ ::variable ourcmds
+ #parray ourcmds
+ return [info exists ourcmds($cmdname)]
+ }
+
+ proc ArgInfo {cmdname minv maxv} {
+ ::variable ourcmds
+ upvar 1 $minv min $maxv max
+ foreach {min max} $ourcmds($cmdname) break
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Higher level error handling, node conversion.
+
+ proc MakeError {t n} {
+ #puts %%error=$n|[info level -1]
+ $t set $n type Error
+ DropChildren $t $n
+ return
+ }
+
+ proc MakeErrorMsg {t n msg args} {
+ upvar 1 _file _file
+ #puts %%error=$n|[info level -1]
+ Report $t $n $msg $args
+ $t set $n type Error
+ DropChildren $t $n
+ return
+ }
+
+ proc MakeText {t n text} {
+ #puts %%text=$n|[info level -1]
+ $t set $n type Text
+ $t set $n text $text
+ DropChildren $t $n
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Error reporting
+
+ proc Error {t n text args} {
+ upvar 1 _file _file
+ Report $t $n $text $args
+ }
+
+ proc Report {t n text details} {
+ upvar 1 _file _file
+ ReportAt $_file($n) [$t get $n range] [$t get $n line] [$t get $n col] $text $details
+ return
+ }
+
+ proc ReportAt {file range line col text details} {
+ ::variable ourerrors
+ #puts !![list $file $range $line $col $text $details]/[info level -1]
+ lappend ourerrors [list $file $range $line $col $text $details]
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Error Management
+
+ proc ClearErrors {} {
+ ::variable ourerrors {}
+ return
+ }
+
+ proc GetErrors {} {
+ ::variable ourerrors
+ return $ourerrors
+ }
+
+ proc SetErrors {t} {
+ ::variable ourerrors $t
+ return
+ }
+
+ # # ## ### ##### ######## #############
+ ## Error Response
+
+ proc StopOnErrors {} {
+ ::variable ourerrors
+ if {![llength $ourerrors]} return
+
+ upvar 1 t t
+ $t destroy
+
+ doctools::msgcat::init toc
+ set info [SortMessages $ourerrors]
+ set msg [Formatted $info {}]
+
+ return -code error -errorcode $info $msg
+ }
+
+ proc Formatted {errors prefix} {
+ set lines {}
+ foreach err $errors {
+ struct::list assign $err file range line col msg details
+ #8.5: set text [msgcat::mc $msg {*}$details]
+ set text [eval [linsert $details 0 msgcat::mc $msg]]
+ if {![string length $prefix] && [string length $file]} {
+ set prefix "\"$file\" "
+ }
+
+ lappend lines "${prefix}error on line $line.$col: $text"
+
+ if {$msg eq "doctoc/include/syntax"} {
+ struct::list assign $details path moreerrors
+ lappend lines [Formatted [SortMessages $moreerrors] "\"$path\": "]
+ }
+ }
+ return [join $lines \n]
+ }
+
+ proc SortMessages {messages} {
+ return [lsort -dict -index 0 \
+ [lsort -dict -index 2 \
+ [lsort -dict -index 3 \
+ [lsort -unique $messages]]]]
+ }
+
+ # # ## ### ##### ######## #############
+ ## Parser state
+
+ # Path to the file currently processed, if known. Empty if not known
+ typevariable ourfile {}
+
+ # Array of variables for use by vset. During parsing a local copy
+ # is used so that variables set by the document cannot spill back
+ # to the parser state.
+ typevariable ourvars -array {}
+
+ # List of paths to use when searching for an include file.
+ typevariable ourincpaths {}
+
+ # Record of errors found so far. List of 5-tuples containing token
+ # range, line, column of firt character after the token, error
+ # code, and error arguments, in this order.
+ typevariable ourerrors {}
+
+ # List of nodes marked for removal.
+ typevariable ourtokill {}
+
+ # Map of legal commands to their min/max number of arguments.
+ typevariable ourcmds -array {
+ comment {1 1}
+ include {1 1}
+ lb {0 0}
+ rb {0 0}
+ vset {1 2}
+
+ division_end {0 0}
+ division_start {1 2}
+ item {3 3}
+ toc_begin {2 2}
+ toc_end {0 0}
+ }
+
+ # # ## ### ##### ######## #############
+ ## Configuration
+
+ pragma -hasinstances no ; # singleton
+ pragma -hastypeinfo no ; # no introspection
+ pragma -hastypedestroy no ; # immortal
+
+ ##
+ # # ## ### ##### ######## #############
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide doctools::toc::parse 0.1
+return
diff --git a/tcllib/modules/doctools2toc/parse.test b/tcllib/modules/doctools2toc/parse.test
new file mode 100644
index 0000000..2cf22f9
--- /dev/null
+++ b/tcllib/modules/doctools2toc/parse.test
@@ -0,0 +1,153 @@
+# -*- tcl -*-
+# doctoc_parse.test: tests for the doctools::toc::parse package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: parse.test,v 1.1 2009/04/18 21:14:19 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ useAccel [useTcllibC] struct/tree.tcl struct::tree
+ TestAccelInit struct::tree
+
+ useAccel [useTcllibC] struct/stack.tcl struct::stack
+ TestAccelInit struct::stack
+
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use struct/list.tcl struct::list
+ use snit/snit.tcl snit
+ use fileutil/fileutil.tcl fileutil
+ use log/logger.tcl logger
+ use treeql/treeql.tcl treeql
+
+ use doctools2base/tcl_parse.tcl doctools::tcl::parse
+ use doctools2base/msgcat.tcl doctools::msgcat
+ useLocal msgcat_c.tcl doctools::msgcat::toc::c
+ useLocal structure.tcl doctools::toc::structure
+
+ msgcat::mclocale C
+}
+testing {
+ useLocal parse.tcl doctools::toc::parse
+}
+
+# -------------------------------------------------------------------------
+
+# General set of error cases regarding the number of arguments.
+
+test doctools-toc-parse-1.0 {parse file, wrong#args} -body {
+ doctools::toc::parse file
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_typemethodfile type path"}
+
+test doctools-toc-parse-1.1 {parse file, wrong#args} -body {
+ doctools::toc::parse file P XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_typemethodfile type path"}
+
+test doctools-toc-parse-2.0 {parse text, wrong#args} -body {
+ doctools::toc::parse text
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_typemethodtext type text ?path?"}
+
+test doctools-toc-parse-2.1 {parse text, wrong#args} -body {
+ doctools::toc::parse text T P XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_typemethodtext type text ?path?"}
+
+test doctools-toc-parse-3.0 {vars, wrong#args} -body {
+ doctools::toc::parse vars XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_typemethodvars type"}
+
+test doctools-toc-parse-4.0 {var, bogus submethod} -body {
+ doctools::toc::parse var bogus
+} -returnCodes error -result {"::doctools::toc::parse var bogus" is not defined}
+
+test doctools-toc-parse-5.0 {var set, wrong#args} -body {
+ doctools::toc::parse var set
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_htypemethodvar_set type name value"}
+
+test doctools-toc-parse-5.1 {var set, wrong#args} -body {
+ doctools::toc::parse var set N
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_htypemethodvar_set type name value"}
+
+test doctools-toc-parse-5.2 {var set, wrong#args} -body {
+ doctools::toc::parse var set N V XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_htypemethodvar_set type name value"}
+
+test doctools-toc-parse-6.0 {var load, wrong#args} -body {
+ doctools::toc::parse var load
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_htypemethodvar_load type dict"}
+
+test doctools-toc-parse-6.1 {var load, wrong#args} -body {
+ doctools::toc::parse var load D XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_htypemethodvar_load type dict"}
+
+# var unset - 0+ arguments, no checking possible.
+
+test doctools-toc-parse-7.0 {includes, wrong#args} -body {
+ doctools::toc::parse includes XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_typemethodincludes type"}
+
+test doctools-toc-parse-8.0 {include, bogus submethod} -body {
+ doctools::toc::parse include bogus
+} -returnCodes error -result {"::doctools::toc::parse include bogus" is not defined}
+
+test doctools-toc-parse-9.0 {include set, wrong#args} -body {
+ doctools::toc::parse include set
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_htypemethodinclude_set type paths"}
+
+test doctools-toc-parse-9.1 {include set, wrong#args} -body {
+ doctools::toc::parse include set P XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_htypemethodinclude_set type paths"}
+
+test doctools-toc-parse-10.0 {include add, wrong#args} -body {
+ doctools::toc::parse include add
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_htypemethodinclude_add type path"}
+
+test doctools-toc-parse-10.1 {include add, wrong#args} -body {
+ doctools::toc::parse include add P XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_htypemethodinclude_add type path"}
+
+test doctools-toc-parse-11.0 {include remove, wrong#args} -body {
+ doctools::toc::parse include remove
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_htypemethodinclude_remove type path"}
+
+test doctools-toc-parse-11.1 {include remove, wrong#args} -body {
+ doctools::toc::parse include remove P XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_htypemethodinclude_remove type path"}
+
+test doctools-toc-parse-12.0 {include clear, wrong#args} -body {
+ doctools::toc::parse include clear XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::parse::Snit_htypemethodinclude_clear type"}
+
+# toc_parse tests, numbering starts at 20
+# -------------------------------------------------------------------------
+
+array_unset env LANG*
+array_unset env LC_*
+set env(LANG) C ; # Usually default if nothing is set, OS X requires this.
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::stack stkimpl {
+ TestAccelDo struct::set setimpl {
+ TestAccelDo struct::tree impl {
+ source [localPath tests/parse]
+ }
+ }
+}
+
+#----------------------------------------------------------------------
+TestAccelExit struct::tree
+TestAccelExit struct::set
+TestAccelExit struct::stack
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2toc/pkgIndex.tcl b/tcllib/modules/doctools2toc/pkgIndex.tcl
new file mode 100644
index 0000000..03759e8
--- /dev/null
+++ b/tcllib/modules/doctools2toc/pkgIndex.tcl
@@ -0,0 +1,33 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+
+# Packages for the doctools toc v2 implementation
+# (still v1.1 doctoc language).
+
+# - Index container, mutable toc objects
+# - Export and import management
+# - Export and import plugins
+# - Parser for doctoc markup, and handling serializations
+# - Message catalogs for the parser
+
+package ifneeded doctools::toc 2 [list source [file join $dir container.tcl]]
+
+package ifneeded doctools::toc::export 0.1 [list source [file join $dir export.tcl]]
+package ifneeded doctools::toc::import 0.1 [list source [file join $dir import.tcl]]
+
+package ifneeded doctools::toc::export::doctoc 0.1 [list source [file join $dir export_doctoc.tcl]]
+package ifneeded doctools::toc::export::html 0.1 [list source [file join $dir export_html.tcl]]
+package ifneeded doctools::toc::export::json 0.1 [list source [file join $dir export_json.tcl]]
+package ifneeded doctools::toc::export::nroff 0.2 [list source [file join $dir export_nroff.tcl]]
+package ifneeded doctools::toc::export::text 0.1 [list source [file join $dir export_text.tcl]]
+package ifneeded doctools::toc::export::wiki 0.1 [list source [file join $dir export_wiki.tcl]]
+
+package ifneeded doctools::toc::import::doctoc 0.1 [list source [file join $dir import_doctoc.tcl]]
+package ifneeded doctools::toc::import::json 0.1 [list source [file join $dir import_json.tcl]]
+
+package ifneeded doctools::toc::parse 0.1 [list source [file join $dir parse.tcl]]
+package ifneeded doctools::toc::structure 0.1 [list source [file join $dir structure.tcl]]
+
+package ifneeded doctools::msgcat::toc::c 0.1 [list source [file join $dir msgcat_c.tcl]]
+package ifneeded doctools::msgcat::toc::de 0.1 [list source [file join $dir msgcat_de.tcl]]
+package ifneeded doctools::msgcat::toc::en 0.1 [list source [file join $dir msgcat_en.tcl]]
+package ifneeded doctools::msgcat::toc::fr 0.1 [list source [file join $dir msgcat_fr.tcl]]
diff --git a/tcllib/modules/doctools2toc/structure.tcl b/tcllib/modules/doctools2toc/structure.tcl
new file mode 100644
index 0000000..edbaff6
--- /dev/null
+++ b/tcllib/modules/doctools2toc/structure.tcl
@@ -0,0 +1,388 @@
+# -*- tcl -*-
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Verification of serialized tables of contents, and conversion
+# between serialized tables of contents and other data structures.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.4 ; # Required runtime.
+package require snit ; # OO system.
+
+# # ## ### ##### ######## ############# #####################
+##
+
+snit::type ::doctools::toc::structure {
+ # # ## ### ##### ######## #############
+ ## Public API
+
+ # Check that the proposed serialization of a table of contents is
+ # indeed such.
+
+ typemethod verify {serial {canonvar {}}} {
+ # Basic syntax: Length and outer type code
+ if {[llength $serial] != 2} {
+ return -code error $ourprefix$ourshort
+ }
+
+ foreach {tag contents} $serial break
+ #struct::list assign $serial tag contents
+
+ if {$tag ne $ourcode} {
+ return -code error $ourprefix[format $ourtag $tag]
+ }
+
+ if {[llength $contents] != 6} {
+ return -code error $ourprefix$ourcshort
+ }
+
+ # Unpack the contents, then check that all necessary keys are
+ # present. Together with the length check we can then also be
+ # sure that no other key is present either.
+ array set toc $contents
+
+ foreach k {label title items} {
+ if {[info exists toc($k)]} continue
+ return -code error $ourprefix[format $ourmiss $k]
+ }
+
+ if {$canonvar eq {}} {
+ VerifyDivision $toc(items)
+ } else {
+ upvar 1 $canonvar iscanonical
+
+ set iscanonical 1
+ VerifyDivision $toc(items) iscanonical
+
+ # Quick exit if the inner structure was already
+ # non-canonical.
+ if {!$iscanonical} return
+
+ # Now various checks if the keys and identifiers are
+ # properly sorted to make this a canonical serialization.
+
+ foreach {a _ b _ c _} $contents break
+ #struct::list assign $contents a _ b _ c _
+ if {[list $a $b $c] ne {items label title}} {
+ set iscanonical 0
+ }
+ }
+
+ # Everything checked out.
+ return
+ }
+
+ typemethod verify-as-canonical {serial} {
+ $type verify $serial iscanonical
+ if {!$iscanonical} {
+ return -code error $ourprefix$ourdupsort
+ }
+ return
+ }
+
+ typemethod canonicalize {serial} {
+ $type verify $serial iscanonical
+ if {$iscanonical} { return $serial }
+
+ # Unpack the serialization.
+ array set toc $serial
+ array set toc $toc(doctools::toc)
+ unset toc(doctools::toc)
+
+ # Construct result
+ set serial [list doctools::toc \
+ [list \
+ items [CanonicalizeDivision $toc(items)] \
+ label $toc(label) \
+ title $toc(title)]]
+ return $serial
+ }
+
+ # Merge the serialization of two indices into a new serialization.
+
+ typemethod merge {seriala serialb} {
+ $type verify $seriala
+ $type verify $serialb
+
+ # Merge using title and label of the second toc, and the new
+ # elements come after the existing.
+
+ # Unpack the definitions...
+ array set a $seriala ; array set a $a(doctools::toc) ; unset a(doctools::toc)
+ array set b $serialb ; array set a $b(doctools::toc) ; unset b(doctools::toc)
+
+ # Construct result
+ set serial [list doctools::toc \
+ [list \
+ items [MergeDivisions $a(items) $b(items)] \
+ label $b(label) \
+ title $b(title)]]
+
+ # Caller has to verify, ensure contract.
+ #$type verify-as-canonical $serial
+ return $serial
+ }
+
+ # Converts a toc serialization into a human readable string for
+ # test results. It assumes that the serialization is at least
+ # structurally sound.
+
+ typemethod print {serial} {
+ # Unpack the serialization.
+ array set toc $serial
+ array set toc $toc(doctools::toc)
+ unset toc(doctools::toc)
+ # Print
+ set lines {}
+ lappend lines [list doctools::toc $toc(label) $toc(title)]
+ PrintDivision lines $toc(items) .... ....
+ return [join $lines \n]
+ }
+
+ # # ## ### ##### ######## #############
+
+ proc VerifyDivision {items {canonvar {}}} {
+ if {$canonvar ne {}} {
+ upvar 1 $canonvar iscanonical
+ }
+
+ array set label {}
+
+ foreach element $items {
+ if {[llength $element] != 2} {
+ return -code error $ourprefix$oureshort
+ }
+ foreach {etype edata} $element break
+ #struct::list assign $element etype edata
+
+ switch -exact -- $etype {
+ reference {
+ # edata = dict (id, label, desc)
+ if {[llength $edata] != 6} {
+ return -code error $ourprefix$ourcshort
+ }
+ array set toc $edata
+ foreach k {id label desc} {
+ if {[info exists toc($k)]} continue
+ return -code error $ourprefix[format $ourmiss $k]
+ }
+ lappend label($toc(label)) .
+ if {$canonvar ne {}} {
+ foreach {a _ b _ c _} $edata break
+ #struct::list assign $edata a _ b _ c _
+ if {[list $a $b $c] ne {desc id label}} {
+ set iscanonical 0
+ }
+ }
+ }
+ division {
+ # edata = dict (id?, label, items)
+ if {([llength $edata] != 4) && ([llength $edata] != 6)} {
+ return -code error $ourprefix$ourdshort
+ }
+ array set toc $edata
+ foreach k {label items} {
+ if {[info exists toc($k)]} continue
+ return -code error $ourprefix[format $ourmiss $k]
+ }
+ lappend label($toc(label)) .
+ if {$canonvar eq {}} {
+ VerifyDivision $toc(items)
+ } else {
+ VerifyDivision $toc(items) iscanonical
+ if {$iscanonical} {
+ if {[info exists toc(id)]} {
+ foreach {a _ b _ c _} $edata break
+ #struct::list assign $edata a _ b _ c _
+ if {[list $a $b $c] ne {id items label}} {
+ set iscanonical 0
+ }
+ } else {
+ foreach {a _ b _} $edata break
+ #struct::list assign $edata a _ b _
+ if {[list $a $b] ne {items label}} {
+ set iscanonical 0
+ }
+ }
+ }
+ }
+ }
+ default {
+ return -code error $ourprefix[format $ouretag $etype]
+ }
+ }
+ unset toc
+ }
+
+ # Fail if labels are duplicated.
+ foreach k [array names label] {
+ if {[llength $label($k)] > 1} {
+ return -code error $ourprefix$ourldup
+ }
+ }
+
+ return
+ }
+
+ proc CanonicalizeDivision {items} {
+ set result {}
+ foreach element $items {
+ foreach {etype edata} $element break
+ #struct::list assign $element etype edata
+
+ array set toc $edata
+ switch -exact -- $etype {
+ reference {
+ set element \
+ [list \
+ desc $toc(desc) \
+ id $toc(id) \
+ label $toc(label)]
+ }
+ division {
+ set element {}
+ if {[info exists toc(id)]} {
+ lappend element id $toc(id)
+ }
+ lappend element \
+ items [CanonicalizeDivision $toc(items)] \
+ label $toc(label)
+ }
+ }
+ unset toc
+ lappend result [list $etype $element]
+ }
+ return $result
+ }
+
+ proc PrintDivision {lv items prefix increment} {
+ upvar 1 $lv lines
+
+ foreach element $items {
+ foreach {etype edata} $element break
+ #struct::list assign $element etype edata
+ array set toc $edata
+ switch -exact -- $etype {
+ reference {
+ lappend lines $prefix[list $toc(id) $toc(label) $toc(desc)]
+ }
+ division {
+ set buf {}
+ if {[info exists toc(id)]} {
+ lappend buf $toc(id)
+ }
+ lappend buf $toc(label)
+ lappend lines $prefix$buf
+ PrintDivision lines $toc(items) $prefix$increment $increment
+ }
+ }
+ unset toc
+ }
+ return
+ }
+
+ proc MergeDivisions {aitems bitems} {
+
+ # Unpack the b-items for easy access when looping over a.
+ array set b
+ foreach element $bitems {
+ foreach {etype edata} $element break
+ array set toc $edata
+ set b($toc(label)) [list $etype $edata]
+ unset toc
+ }
+
+ set items {}
+
+ # Unification loop...
+ foreach element $aitems {
+ foreach {etype edata} $element break
+ array set toc $edata
+ set label $toc(label)
+ if {![info exists b($label)]} {
+ # Nothing in b, keep entry as is.
+ lappend items $element
+ } else {
+ # Unify. Type dependent. And throw an if the types do
+ # not match.
+ foreach {btype bdata} $b($label) break
+ if {$etype ne $btype} {
+ # TODO :: More details in error message to show
+ # where the mismatch is.
+ return -code error "Merge error"
+ }
+ switch -exact -- $etype {
+ reference {
+ # Unification by taking the b-information.
+ lappend items $b($label)
+ }
+ division {
+ # Unification by taking the b-information
+ # where possible, and merging the sub-ordinate
+ # items.
+ array set btoc $bdata
+ set element {}
+ if {[info exists btoc(id)]} {
+ lappend element id $btoc(id)
+ } elseif {[info exists toc(id)]} {
+ lappend element id $toc(id)
+ }
+ lappend element \
+ items [MergeDivisions $toc(items) $btoc(items)] \
+ label $btoc(label)
+ unset btoc
+ lappend items [list $etype $element]
+ }
+ }
+ unset b($label)
+ }
+ unset toc
+ }
+
+ # Appending loop. Now we add everything from b which was not
+ # unified with data in a.
+ foreach element $bitems {
+ foreach {etype edata} $element break
+ array set toc $edata
+ set label $toc(label)
+ if {![info exists b($label)]} continue
+ lappend items $element
+ }
+
+ return $items
+ }
+
+ # # ## ### ##### ######## #############
+
+ typevariable ourcode doctools::toc
+ typevariable ourprefix {error in serialization:}
+ # # Test cases (doctools-toc-structure-)
+ typevariable ourshort { dictionary too short, expected exactly one key} ; # 6.0
+ typevariable ourtag { bad type tag "%s"} ; # 6.1
+ typevariable ourcshort { dictionary too short, expected exactly three keys} ; # 6.2, 6.9
+ typevariable ourdshort { dictionary too short, expected two or three keys} ; # 6.14
+ typevariable ourmiss { missing expected key "%s"} ; # 6.3, 6.4, 6.5, 6.10, 6.11, 6.12, 6.15, 6.16 (XXX + inner: div)
+ typevariable ourldup { duplicate labels} ; # 6.19, 6.20, 6.21
+ typevariable oureshort { element list wrong, need exactly 2} ; # 6.7
+ typevariable ouretag { bad element tag "%s"} ; # 6.8
+ # Message for non-canonical serialization when expecting canonical form
+ typevariable ourdupsort { duplicate and/or unsorted keywords} ; # 6.6, 6.13, 6.17, 6.18
+ typevariable ourmergeerr {Mismatching declarations '%s' vs. '%s' for '%s'}
+
+ # # ## ### ##### ######## #############
+ ## Configuration
+
+ pragma -hasinstances no ; # singleton
+ pragma -hastypeinfo no ; # no introspection
+ pragma -hastypedestroy no ; # immortal
+
+ ##
+ # # ## ### ##### ######## #############
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide doctools::toc::structure 0.1
+return
diff --git a/tcllib/modules/doctools2toc/structure.test b/tcllib/modules/doctools2toc/structure.test
new file mode 100644
index 0000000..58dffb6
--- /dev/null
+++ b/tcllib/modules/doctools2toc/structure.test
@@ -0,0 +1,212 @@
+# -*- tcl -*-
+# doctoc_structure.test: tests for the doctools::toc::structure package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: structure.test,v 1.1 2009/04/18 21:14:19 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ; # For tests/common
+ use snit/snit.tcl snit
+}
+testing {
+ useLocal structure.tcl doctools::toc::structure
+}
+
+# -------------------------------------------------------------------------
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+test doctools-toc-structure-1.0 {structure verify, wrong#args} -body {
+ doctools::toc::structure verify
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::structure::Snit_typemethodverify type serial ?canonvar?"}
+
+test doctools-toc-structure-1.1 {structure verify, wrong#args} -body {
+ doctools::toc::structure verify S V XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::structure::Snit_typemethodverify type serial ?canonvar?"}
+
+test doctools-toc-structure-2.0 {structure verify, wrong#args} -body {
+ doctools::toc::structure verify-as-canonical
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::structure::Snit_typemethodverify-as-canonical type serial"}
+
+test doctools-toc-structure-2.1 {structure verify, wrong#args} -body {
+ doctools::toc::structure verify-as-canonical S XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::structure::Snit_typemethodverify-as-canonical type serial"}
+
+test doctools-toc-structure-3.0 {structure print, wrong#args} -body {
+ doctools::toc::structure print
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::structure::Snit_typemethodprint type serial"}
+
+test doctools-toc-structure-3.1 {structure print, wrong#args} -body {
+ doctools::toc::structure print S XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::structure::Snit_typemethodprint type serial"}
+
+test doctools-toc-structure-4.0 {structure merge, wrong#args} -body {
+ doctools::toc::structure merge
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::structure::Snit_typemethodmerge type seriala serialb"}
+
+test doctools-toc-structure-4.1 {structure merge, wrong#args} -body {
+ doctools::toc::structure merge SA
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::structure::Snit_typemethodmerge type seriala serialb"}
+
+test doctools-toc-structure-4.2 {structure merge, wrong#args} -body {
+ doctools::toc::structure merge SA SB XXX
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::structure::Snit_typemethodmerge type seriala serialb"}
+
+# -------------------------------------------------------------------------
+
+TestFilesProcess $mytestdir ok serial text -> n label input data expected {
+ # The 'expected' data is irrelevant here, only used to satisfy
+ # TestFilesProcess' syntax.
+ test doctools-toc-structure-5.$n "doctools::toc::structure verify, $label, ok" -body {
+ doctools::toc::structure verify $data
+ } -result {}
+}
+
+# -------------------------------------------------------------------------
+
+foreach {n badserial expected} {
+ 0 {}
+ {error in serialization: dictionary too short, expected exactly one key}
+ 1 {FOO {}}
+ {error in serialization: bad type tag "FOO"}
+ 2 {doctools::toc {}}
+ {error in serialization: dictionary too short, expected exactly three keys}
+ 3 {doctools::toc {a . b . c .}}
+ {error in serialization: missing expected key "label"}
+ 4 {doctools::toc {label . b . c .}}
+ {error in serialization: missing expected key "title"}
+ 5 {doctools::toc {label . title . c .}}
+ {error in serialization: missing expected key "items"}
+ 6 {doctools::toc {label . title . items {}}}
+ {error in serialization: duplicate and/or unsorted keywords}
+ 7 {doctools::toc {items {{}} label . title .}}
+ {error in serialization: element list wrong, need exactly 2}
+ 8 {doctools::toc {items {{FOO {}}} label . title .}}
+ {error in serialization: bad element tag "FOO"}
+ 9 {doctools::toc {items {{reference {}}} label . title .}}
+ {error in serialization: dictionary too short, expected exactly three keys}
+ 10 {doctools::toc {items {
+ {reference {a . b . c .}}} label . title .}}
+ {error in serialization: missing expected key "id"}
+ 11 {doctools::toc {items {
+ {reference {id . b . c .}}} label . title .}}
+ {error in serialization: missing expected key "label"}
+ 12 {doctools::toc {items {
+ {reference {id . label . c .}}} label . title .}}
+ {error in serialization: missing expected key "desc"}
+ 13 {doctools::toc {items {
+ {reference {id . label . desc .}}} label . title .}}
+ {error in serialization: duplicate and/or unsorted keywords}
+ 14 {doctools::toc {items {
+ {division {}}} label . title .}}
+ {error in serialization: dictionary too short, expected two or three keys}
+ 15 {doctools::toc {items {
+ {division {a . b .}}} label . title .}}
+ {error in serialization: missing expected key "label"}
+ 16 {doctools::toc {items {
+ {division {label . b .}}} label . title .}}
+ {error in serialization: missing expected key "items"}
+ 17 {doctools::toc {items {
+ {division {label . items {}}}} label . title .}}
+ {error in serialization: duplicate and/or unsorted keywords}
+ 18 {doctools::toc {items {
+ {division {items {} label . id .}}} label . title .}}
+ {error in serialization: duplicate and/or unsorted keywords}
+ 19 {doctools::toc {items {
+ {reference {desc . id . label .}}
+ {reference {desc . id . label .}}} label . title .}}
+ {error in serialization: duplicate labels}
+ 20 {doctools::toc {items {
+ {division {id . items {} label .}}
+ {division {id . items {} label .}}} label . title .}}
+ {error in serialization: duplicate labels}
+ 21 {doctools::toc {items {
+ {division {id . items {} label .}}
+ {reference {desc . id . label .}}} label . title .}}
+ {error in serialization: duplicate labels}
+} {
+ test doctools-toc-structure-6.$n "doctools::toc::structure verify-as-canonical, error" -body {
+ doctools::toc::structure verify-as-canonical $badserial
+ } -returnCodes error -result $expected
+}
+
+#----------------------------------------------------------------------
+
+foreach {n badserial expected} {
+ 0 {}
+ {error in serialization: dictionary too short, expected exactly one key}
+ 1 {FOO {}}
+ {error in serialization: bad type tag "FOO"}
+ 2 {doctools::toc {}}
+ {error in serialization: dictionary too short, expected exactly three keys}
+ 3 {doctools::toc {a . b . c .}}
+ {error in serialization: missing expected key "label"}
+ 4 {doctools::toc {label . b . c .}}
+ {error in serialization: missing expected key "title"}
+ 5 {doctools::toc {label . title . c .}}
+ {error in serialization: missing expected key "items"}
+ 7 {doctools::toc {items {{}} label . title .}}
+ {error in serialization: element list wrong, need exactly 2}
+ 8 {doctools::toc {items {{FOO {}}} label . title .}}
+ {error in serialization: bad element tag "FOO"}
+ 9 {doctools::toc {items {{reference {}}} label . title .}}
+ {error in serialization: dictionary too short, expected exactly three keys}
+ 10 {doctools::toc {items {
+ {reference {a . b . c .}}} label . title .}}
+ {error in serialization: missing expected key "id"}
+ 11 {doctools::toc {items {
+ {reference {id . b . c .}}} label . title .}}
+ {error in serialization: missing expected key "label"}
+ 12 {doctools::toc {items {
+ {reference {id . label . c .}}} label . title .}}
+ {error in serialization: missing expected key "desc"}
+ 14 {doctools::toc {items {
+ {division {}}} label . title .}}
+ {error in serialization: dictionary too short, expected two or three keys}
+ 15 {doctools::toc {items {
+ {division {a . b .}}} label . title .}}
+ {error in serialization: missing expected key "label"}
+ 16 {doctools::toc {items {
+ {division {label . b .}}} label . title .}}
+ {error in serialization: missing expected key "items"}
+ 19 {doctools::toc {items {
+ {reference {desc . id . label .}}
+ {reference {desc . id . label .}}} label . title .}}
+ {error in serialization: duplicate labels}
+ 20 {doctools::toc {items {
+ {division {id . items {} label .}}
+ {division {id . items {} label .}}} label . title .}}
+ {error in serialization: duplicate labels}
+ 21 {doctools::toc {items {
+ {division {id . items {} label .}}
+ {reference {desc . id . label .}}} label . title .}}
+ {error in serialization: duplicate labels}
+} {
+ test doctools-toc-structure-7.$n "doctools::toc::structure verify, error" -body {
+ doctools::toc::structure verify $badserial
+ } -returnCodes error -result $expected
+}
+
+#----------------------------------------------------------------------
+
+# TODO merge ... also test cases for doctools::toc
+
+#----------------------------------------------------------------------
+
+unset mytestdir n badserial expected label input data
+testsuiteCleanup
+return
diff --git a/tcllib/modules/doctools2toc/tests/container b/tcllib/modules/doctools2toc/tests/container
new file mode 100644
index 0000000..ef393d5
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/container
@@ -0,0 +1,379 @@
+# -*- tcl -*-
+# doctoc.testsuite: tests for the doctoc management.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: container,v 1.2 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# I. Handling regular serialization of indices, import and export.
+# Import serialization, then re-export.
+
+TestFilesProcess $mytestdir ok serial serial-print -> n label input data expected {
+ test doctools-toc-${impl}-40.$n "doctools::toc deserialize serial, $label, ok" -setup {
+ doctools::toc I
+ } -body {
+ I deserialize = $data
+ I invalidate
+ doctools::toc::structure print [I serialize]
+ } -cleanup {
+ I destroy
+ } -result $expected
+}
+
+# Testing the errors thrown for invalid serializations, at the level
+# of toc objects. Underneath are the doctools::toc::structure
+# commands, so we can and are re-using the test cases which were
+# written for them.
+
+foreach {n badserial expected} {
+ 0 {}
+ {error in serialization: dictionary too short, expected exactly one key}
+ 1 {FOO {}}
+ {error in serialization: bad type tag "FOO"}
+ 2 {doctools::toc {}}
+ {error in serialization: dictionary too short, expected exactly three keys}
+ 3 {doctools::toc {a . b . c .}}
+ {error in serialization: missing expected key "label"}
+ 4 {doctools::toc {label . b . c .}}
+ {error in serialization: missing expected key "title"}
+ 5 {doctools::toc {label . title . c .}}
+ {error in serialization: missing expected key "items"}
+ 7 {doctools::toc {items {{}} label . title .}}
+ {error in serialization: element list wrong, need exactly 2}
+ 8 {doctools::toc {items {{FOO {}}} label . title .}}
+ {error in serialization: bad element tag "FOO"}
+ 9 {doctools::toc {items {{reference {}}} label . title .}}
+ {error in serialization: dictionary too short, expected exactly three keys}
+ 10 {doctools::toc {items {
+ {reference {a . b . c .}}} label . title .}}
+ {error in serialization: missing expected key "id"}
+ 11 {doctools::toc {items {
+ {reference {id . b . c .}}} label . title .}}
+ {error in serialization: missing expected key "label"}
+ 12 {doctools::toc {items {
+ {reference {id . label . c .}}} label . title .}}
+ {error in serialization: missing expected key "desc"}
+ 14 {doctools::toc {items {
+ {division {}}} label . title .}}
+ {error in serialization: dictionary too short, expected two or three keys}
+ 15 {doctools::toc {items {
+ {division {a . b .}}} label . title .}}
+ {error in serialization: missing expected key "label"}
+ 16 {doctools::toc {items {
+ {division {label . b .}}} label . title .}}
+ {error in serialization: missing expected key "items"}
+ 19 {doctools::toc {items {
+ {reference {desc . id . label .}}
+ {reference {desc . id . label .}}} label . title .}}
+ {error in serialization: duplicate labels}
+ 20 {doctools::toc {items {
+ {division {id . items {} label .}}
+ {division {id . items {} label .}}} label . title .}}
+ {error in serialization: duplicate labels}
+ 21 {doctools::toc {items {
+ {division {id . items {} label .}}
+ {reference {desc . id . label .}}} label . title .}}
+ {error in serialization: duplicate labels}
+} {
+ test doctools-toc-${impl}-41.$n "doctools::toc deserialize, error" -setup {
+ doctools::toc I
+ } -body {
+ I deserialize = $badserial
+ } -cleanup {
+ I destroy
+ } -returnCodes error -result $expected
+}
+
+foreach {n noncanonserial expected} {
+ 6 {doctools::toc {label . title . items {}}}
+ {doctools::toc {items {} label . title .}}
+ 13 {doctools::toc {items {
+ {reference {id . label . desc .}}} label . title .}}
+ {doctools::toc {items {{reference {desc . id . label .}}} label . title .}}
+ 17 {doctools::toc {items {
+ {division {label . items {}}}} label . title .}}
+ {doctools::toc {items {{division {items {} label .}}} label . title .}}
+ 18 {doctools::toc {items {
+ {division {items {} label . id .}}} label . title .}}
+ {doctools::toc {items {{division {id . items {} label .}}} label . title .}}
+} {
+ test doctools-toc-${impl}-42.$n "doctools::toc deserialize, regular to canonical" -setup {
+ doctools::toc I
+ I deserialize = $noncanonserial
+ } -body {
+ I serialize
+ } -cleanup {
+ I destroy
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# II. Handling doctoc markup as serialization format, import and export.
+
+# Checking that the various forms of doctoc markup as generated by the
+# export plugin doctools::toc(::export::doctoc) are valid input for
+# the doctoc import plugin. Actually testing that using an import
+# manager from the toc is working.
+
+foreach {k section} {
+ 0 {}
+ 1 -ultracompact
+ 2 -compact
+ 3 -indented
+ 4 -aligned
+ 5 -indalign
+} {
+ TestFilesProcess $mytestdir ok doctoc$section serial-print -> n label input data expected {
+ test doctools-toc-${impl}-50.$k.$n "doctools::toc deserialize = doctoc, $label$section, ok" -setup {
+ doctools::toc I
+ doctools::toc::import IN
+ I importer IN
+ } -body {
+ I deserialize = $data doctoc
+ doctools::toc::structure print [I serialize]
+ } -cleanup {
+ I destroy
+ IN destroy
+ } -result $expected
+ }
+}
+
+# We test the error messages and codes thrown during import for a
+# variety of failure possibilities
+
+TestFilesProcess $mytestdir fail doctoc emsg -> n label input data expected {
+ test doctools-toc-${impl}-51.$n "doctools::toc deserialize = doctoc, $label, error message" -setup {
+ # Basic variables and include search paths for use by the tests
+ doctools::toc::import IN
+ IN config set fox dog
+ IN config set lazy jump
+ IN include add [TestFilesGlob $mytestdir]
+ doctools::toc I
+ I importer IN
+ } -body {
+ I deserialize = $data doctoc
+ } -cleanup {
+ I destroy
+ IN destroy
+ } -returnCodes error -result $expected
+}
+
+TestFilesProcess $mytestdir fail doctoc ecode -> n label input data expected {
+ test doctools-toc-${impl}-52.$n "doctools::toc deserialize = doctoc, $label, error code" -setup {
+ # Basic variables and include search paths for use by the tests
+ doctools::toc::import IN
+ IN config set fox dog
+ IN config set lazy jump
+ IN include add [TestFilesGlob $mytestdir]
+ doctools::toc I
+ I importer IN
+ } -body {
+ catch { I deserialize = $data doctoc }
+ set ::errorCode
+ } -cleanup {
+ I destroy
+ IN destroy
+ } -result $expected
+}
+
+# Testing the export of doctoc markup through attached exporter management, for all possible configurations.
+
+foreach {k nl in al section} {
+ 0 0 0 0 -ultracompact
+ 1 1 0 0 -compact
+ 2 1 1 0 -indented
+ 3 1 0 1 -aligned
+ 4 1 1 1 -indalign
+ 5 0 1 0 -indented
+ 6 0 0 1 -aligned
+ 7 0 1 1 -indalign
+} {
+ TestFilesProcess $mytestdir ok serial doctoc$section -> n label input data expected {
+ test doctools-toc-${impl}-53.$k.$n "doctools::toc serialize doctoc, ${label}$section, ok" -setup {
+ doctools::toc::export OUT
+ OUT config set newlines $nl
+ OUT config set indented $in
+ OUT config set aligned $al
+ doctools::toc I
+ I exporter OUT
+ } -body {
+ I deserialize = $data
+ stripcomments [I serialize doctoc]
+ } -cleanup {
+ I destroy
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# III. Handling text markup as serialization format, export only
+
+TestFilesProcess $mytestdir ok serial text -> n label input data expected {
+ test doctools-toc-${impl}-54.$n "doctools::toc serialize text, $label, ok" -setup {
+ doctools::toc::export OUT
+ doctools::toc I
+ I exporter OUT
+ } -body {
+ I deserialize = $data
+ I serialize text
+ } -cleanup {
+ I destroy
+ OUT destroy
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# IV. Handling json markup as serialization format, import and export.
+
+# We are checking that the various forms of json markup, as can be
+# generated by doctools::toc(::export(::json)) are valid input to the
+# json parser.
+#
+# section {} holds the non-canonical input we have to accept and make
+# canonical to higher layers.
+
+foreach {k section} {
+ 0 {}
+ 1 -ultracompact
+ 2 -indented
+ 3 -indalign
+} {
+ TestFilesProcess $mytestdir ok json$section serial-print -> n label input data expected {
+ test doctools-toc-${impl}-55.$k.$n "doctools::toc deserialize = json, $label$section, ok" -setup {
+ doctools::toc::import IN
+ doctools::toc I
+ I importer IN
+ } -body {
+ I deserialize = $data json
+ doctools::toc::structure print [I serialize]
+ } -cleanup {
+ I destroy
+ IN destroy
+ } -result $expected
+ }
+}
+
+TestFilesProcess $mytestdir fail json json-emsg -> n label input data expected {
+ test doctools-toc-${impl}-56.$n "doctools::toc deserialize = json, $label, error message" -setup {
+ doctools::toc::import IN
+ doctools::toc I
+ I importer IN
+ } -body {
+ I deserialize = $data json
+ } -cleanup {
+ I destroy
+ IN destroy
+ } -returnCodes error -result $expected
+}
+
+foreach {k in al section} {
+ 0 0 0 -ultracompact
+ 1 1 0 -indented
+ 2 0 1 -indalign
+ 3 1 1 -indalign
+} {
+ TestFilesProcess $mytestdir ok serial json$section -> n label input data expected {
+ test doctools-toc-${impl}-57.$k.$n "doctools::toc serialize json, $label$section, ok" -setup {
+ doctools::toc::export OUT
+ OUT config set indented $in
+ OUT config set aligned $al
+ doctools::toc I
+ I exporter OUT
+ } -body {
+ I deserialize = $data
+ I serialize json
+ } -cleanup {
+ I destroy
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# V. Handling html markup as serialization format, export only
+
+foreach {k nl in section} {
+ 0 0 0 -ultracompact
+ 1 0 1 -indented
+ 2 1 0 -compact
+ 3 1 1 -indented
+} {
+ TestFilesProcess $mytestdir ok serial html$section -> n label input data expected {
+ test doctools-toc-${impl}-58.$k.$n "doctools::toc serialize html, $label$section, ok" -setup {
+ doctools::toc::export OUT
+ OUT config set newlines $nl
+ OUT config set indented $in
+ OUT config set user _dummy_
+ doctools::toc I
+ I exporter OUT
+ } -body {
+ I deserialize = $data
+ striphtmlcomments [I serialize html] 3
+ } -cleanup {
+ I destroy
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# VI. Handling wiki markup as serialization format, export only
+
+TestFilesProcess $mytestdir ok serial wiki -> n label input data expected {
+ test doctools-toc-${impl}-59.$n "doctools::toc serialize wiki, $label, ok" -setup {
+ doctools::toc::export OUT
+ doctools::toc I
+ I exporter OUT
+ } -body {
+ I deserialize = $data
+ I serialize wiki
+ } -cleanup {
+ I destroy
+ OUT destroy
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# VII. Handling nroff markup as serialization format, export only
+
+foreach {k inline section} {
+ 0 0 -external
+ 1 1 -inlined
+} {
+ TestFilesProcess $mytestdir ok serial nroff$section -> n label input data expected {
+ test doctools-toc-${impl}-60.$k.$n "doctools::toc serialize nroff, $label$section, ok" -setup {
+ doctools::toc::export OUT
+ OUT config set inline $inline
+ doctools::toc I
+ I exporter OUT
+ } -body {
+ I deserialize = $data
+ stripnroffcomments [stripmanmacros [I serialize nroff]]
+ } -cleanup {
+ I destroy
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+return
+
+# TODO :: Test the merging of indices (copy from toc_structure.test)
+
+# -------------------------------------------------------------------------
+return
diff --git a/tcllib/modules/doctools2toc/tests/container_main b/tcllib/modules/doctools2toc/tests/container_main
new file mode 100644
index 0000000..ce1cc20
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/container_main
@@ -0,0 +1,1003 @@
+
+# -------------------------------------------------------------------------
+
+test doctools-toc-${impl}-1.0 {deserialize =, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I deserialize =
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_hmethoddeserialize_= type selfns win self data ?format?"}
+
+test doctools-toc-${impl}-1.1 {deserialize =, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I deserialize = T F XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_hmethoddeserialize_= type selfns win self data ?format?"}
+
+test doctools-toc-${impl}-2.0 {deserialize +=, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I deserialize +=
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_hmethoddeserialize_+= type selfns win self data ?format?"}
+
+test doctools-toc-${impl}-2.1 {deserialize +=, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I deserialize += T F XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_hmethoddeserialize_+= type selfns win self data ?format?"}
+
+test doctools-toc-${impl}-3.0 {serialize, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I serialize F XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodserialize type selfns win self ?format?"}
+
+test doctools-toc-${impl}-4.0 {+ reference, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I + reference
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_hmethod+_reference type selfns win self pid label docid desc"}
+
+test doctools-toc-${impl}-4.1 {+ reference, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I + reference P
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_hmethod+_reference type selfns win self pid label docid desc"}
+
+test doctools-toc-${impl}-4.2 {+ reference, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I + reference P L
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_hmethod+_reference type selfns win self pid label docid desc"}
+
+test doctools-toc-${impl}-4.3 {+ reference, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I + reference P L D
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_hmethod+_reference type selfns win self pid label docid desc"}
+
+test doctools-toc-${impl}-4.4 {+ reference, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I + reference P L D D XXXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_hmethod+_reference type selfns win self pid label docid desc"}
+
+test doctools-toc-${impl}-5.0 {+ division, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I + division
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_hmethod+_division type selfns win self pid label ?docid?"}
+
+test doctools-toc-${impl}-5.1 {+ division, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I + division P
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_hmethod+_division type selfns win self pid label ?docid?"}
+
+test doctools-toc-${impl}-5.2 {+ division, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I + division P L D XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_hmethod+_division type selfns win self pid label ?docid?"}
+
+test doctools-toc-${impl}-6.0 {remove, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I remove
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodremove type selfns win self id"}
+
+test doctools-toc-${impl}-6.1 {remove, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I remove I XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodremove type selfns win self id"}
+
+test doctools-toc-${impl}-7.0 {up, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I up
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodup type selfns win self id"}
+
+test doctools-toc-${impl}-7.1 {up, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I up I XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodup type selfns win self id"}
+
+test doctools-toc-${impl}-8.0 {next, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I next
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodnext type selfns win self id"}
+
+test doctools-toc-${impl}-8.1 {next, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I next I XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodnext type selfns win self id"}
+
+test doctools-toc-${impl}-9.0 {prev, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I prev
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodprev type selfns win self id"}
+
+test doctools-toc-${impl}-9.1 {prev, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I prev I XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodprev type selfns win self id"}
+
+test doctools-toc-${impl}-10.0 {child, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I child
+} -cleanup {
+ I destroy
+} -returnCodes error -result [tcltest::wrongNumArgs ::doctools::toc::Snit_methodchild {type selfns win self id label args} 0]
+
+test doctools-toc-${impl}-10.1 {child, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I child I
+} -cleanup {
+ I destroy
+} -returnCodes error -result [tcltest::wrongNumArgs ::doctools::toc::Snit_methodchild {type selfns win self id label args} 0]
+
+test doctools-toc-${impl}-11.0 {children, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I children
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodchildren type selfns win self id"}
+
+test doctools-toc-${impl}-11.1 {children, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I children I XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodchildren type selfns win self id"}
+
+test doctools-toc-${impl}-12.0 {type, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I type
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodtype type selfns win self id"}
+
+test doctools-toc-${impl}-12.1 {type, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I type I XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodtype type selfns win self id"}
+
+test doctools-toc-${impl}-13.0 {full-label, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I full-label
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodfull-label type selfns win self id"}
+
+test doctools-toc-${impl}-13.1 {full-label, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I full-label I XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodfull-label type selfns win self id"}
+
+test doctools-toc-${impl}-13.0 {elabel, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I elabel
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodelabel type selfns win self id ?newlabel?"}
+
+test doctools-toc-${impl}-14.1 {elabel, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I elabel I V XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodelabel type selfns win self id ?newlabel?"}
+
+test doctools-toc-${impl}-15.0 {description, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I description
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methoddescription type selfns win self id ?newdesc?"}
+
+test doctools-toc-${impl}-15.1 {description, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I description I V XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methoddescription type selfns win self id ?newdesc?"}
+
+test doctools-toc-${impl}-16.0 {document, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I document
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methoddocument type selfns win self id ?newdocid?"}
+
+test doctools-toc-${impl}-16.1 {document, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I document I V XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methoddocument type selfns win self id ?newdocid?"}
+
+test doctools-toc-${impl}-17.0 {title, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I title T XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodtitle type selfns win self ?text?"}
+
+test doctools-toc-${impl}-18.0 {label, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I label L XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodlabel type selfns win self ?text?"}
+
+test doctools-toc-${impl}-19.0 {exporter, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I exporter E XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodexporter type selfns win self ?object?"}
+
+test doctools-toc-${impl}-20.0 {importer, wrong#args} -setup {
+ doctools::toc I
+} -body {
+ I importer I XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {wrong # args: should be "::doctools::toc::Snit_methodimporter type selfns win self ?object?"}
+
+# -------------------------------------------------------------------------
+
+test doctools-toc-${impl}-21.0 {+ reference, new label} -setup {
+ doctools::toc I
+ set R [I element]
+} -body {
+ I + reference $R L D DESC
+ I children $R
+} -cleanup {
+ I destroy
+ unset R
+} -result node1
+
+test doctools-toc-${impl}-21.1 {+ reference, known key} -setup {
+ doctools::toc I
+ set R [I element]
+ I + reference $R L D DESC
+} -body {
+ I + reference $R L D' DESC'
+} -cleanup {
+ I destroy
+ unset R
+} -returnCodes error -result {Redefinition of label 'L' in '{}'}
+
+test doctools-toc-${impl}-21.2 {+ reference, not in div} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + reference $R L D DESC]
+} -body {
+ I + reference $R L' D' DESC'
+} -cleanup {
+ I destroy
+ unset R
+} -returnCodes error -result {toc element handle 'node1' does not refer to a division}
+
+test doctools-toc-${impl}-21.3 {+ reference, bogus handle} -setup {
+ doctools::toc I
+} -body {
+ I + reference XXX L D DESC
+} -cleanup {
+ I destroy
+} -returnCodes error -result {Bad toc element handle 'XXX'}
+
+test doctools-toc-${impl}-21.4 {+ reference, bogus document id} -setup {
+ doctools::toc I
+ set R [I element]
+} -body {
+ I + reference $R L {} DESC
+} -cleanup {
+ I destroy
+ unset R
+} -returnCodes error -result {Illegal empty document reference for reference entry}
+
+test doctools-toc-${impl}-22.0 {+ division, new label} -setup {
+ doctools::toc I
+ set R [I element]
+} -body {
+ I + division $R L D
+ I children $R
+} -cleanup {
+ I destroy
+ unset R
+} -result node1
+
+test doctools-toc-${impl}-22.1 {+ division, known key} -setup {
+ doctools::toc I
+ set R [I element]
+ I + division $R L D
+} -body {
+ I + division $R L D'
+} -cleanup {
+ I destroy
+ unset R
+} -returnCodes error -result {Redefinition of label 'L' in '{}'}
+
+test doctools-toc-${impl}-22.2 {+ division, not in div} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + reference $R L D DESC]
+} -body {
+ I + division $R L' D'
+} -cleanup {
+ I destroy
+ unset R
+} -returnCodes error -result {toc element handle 'node1' does not refer to a division}
+
+test doctools-toc-${impl}-22.3 {+ division, bogus handle} -setup {
+ doctools::toc I
+} -body {
+ I + division XXX L D
+} -cleanup {
+ I destroy
+} -returnCodes error -result {Bad toc element handle 'XXX'}
+
+test doctools-toc-${impl}-23.0 {remove, known key, reference} -setup {
+ doctools::toc I
+ set R [I + reference [I element] L D DESC]
+} -body {
+ I remove $R
+ I children [I element]
+} -cleanup {
+ I destroy
+ unset R
+} -result {}
+
+test doctools-toc-${impl}-23.1 {remove, known key, division} -setup {
+ doctools::toc I
+ set R [I + division [I element] L D]
+} -body {
+ I remove $R
+ I children [I element]
+} -cleanup {
+ I destroy
+ unset R
+} -result {}
+
+test doctools-toc-${impl}-23.2 {remove, unknown key} -setup {
+ doctools::toc I
+} -body {
+ I remove XXX
+} -cleanup {
+ I destroy
+} -returnCodes error -result {Bad toc element handle 'XXX'}
+
+test doctools-toc-${impl}-23.3 {remove, root} -setup {
+ doctools::toc I
+} -body {
+ I remove [I element]
+} -cleanup {
+ I destroy
+} -returnCodes error -result {Unable to remove root}
+
+test doctools-toc-${impl}-23.4 {remove, division, children as well} -setup {
+ doctools::toc I
+ set R [I element]
+ set A [I + division $R L D]
+ set B [I + reference $A L D DESC]
+} -body {
+ I remove $A
+ I type $B
+} -cleanup {
+ I destroy
+ unset R A B
+} -returnCodes error -result {Bad toc element handle 'node2'}
+
+test doctools-toc-${impl}-24.0 {children, nothing} -setup {
+ doctools::toc I
+} -body {
+ I children [I element]
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-toc-${impl}-24.1 {children, something} -setup {
+ doctools::toc I
+ set R [I element]
+ set A [I + division $R L D]
+} -body {
+ list [llength [I children $R]] \
+ [string equal $A [lindex [I children $R] 0]]
+} -cleanup {
+ I destroy
+ unset R A
+} -result {1 1}
+
+test doctools-toc-${impl}-24.2 {children, multiple, order} -setup {
+ doctools::toc I
+ set R [I element]
+ set A [I + division $R L D]
+ set B [I + division $R L' D]
+} -body {
+ list [llength [I children $R]] \
+ [string equal $A [lindex [I children $R] 0]] \
+ [string equal $B [lindex [I children $R] 1]]
+} -cleanup {
+ I destroy
+ unset R A B
+} -result {2 1 1}
+
+test doctools-toc-${impl}-25.0 {type, reference} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + reference $R L D DESC]
+} -body {
+ I type $R
+} -cleanup {
+ I destroy
+ unset R
+} -result reference
+
+test doctools-toc-${impl}-25.1 {type, division} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + division $R L D]
+} -body {
+ I type $R
+} -cleanup {
+ I destroy
+ unset R
+} -result division
+
+test doctools-toc-${impl}-26.0 {full-label, reference} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + division $R L D]
+ set R [I + reference $R L' D DESC]
+} -body {
+ I full-label $R
+} -cleanup {
+ I destroy
+ unset R
+} -result {L L'}
+
+test doctools-toc-${impl}-26.1 {full-label, division} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + division $R L D]
+ set R [I + division $R L' D]
+} -body {
+ I full-label $R
+} -cleanup {
+ I destroy
+ unset R
+} -result {L L'}
+
+test doctools-toc-${impl}-27.0 {elabel, reference, query} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + reference $R L D DESC]
+} -body {
+ I elabel $R
+} -cleanup {
+ I destroy
+ unset R
+} -result L
+
+test doctools-toc-${impl}-27.1 {elabel, reference, set, unchanged} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + reference $R L D DESC]
+} -body {
+ I elabel $R L
+} -cleanup {
+ I destroy
+ unset R
+} -result L
+
+test doctools-toc-${impl}-27.2 {elabel, reference, set, changed} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + reference $R L D DESC]
+} -body {
+ I elabel $R L'
+} -cleanup {
+ I destroy
+ unset R
+} -result L'
+
+test doctools-toc-${impl}-27.3 {elabel, reference, set, collision} -setup {
+ doctools::toc I
+ set R [I element]
+ I + reference $R L' D DESC
+ set R [I + reference $R L D DESC]
+} -body {
+ I elabel $R L'
+} -cleanup {
+ I destroy
+ unset R
+} -returnCodes error -result {Redefinition of label 'L'' in '{}'}
+
+test doctools-toc-${impl}-27.4 {elabel, division, query} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + division $R L D]
+} -body {
+ I elabel $R
+} -cleanup {
+ I destroy
+ unset R
+} -result L
+
+test doctools-toc-${impl}-27.5 {elabel, division, set, unchanged} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + division $R L D]
+} -body {
+ I elabel $R L
+} -cleanup {
+ I destroy
+ unset R
+} -result L
+
+test doctools-toc-${impl}-27.6 {elabel, division, set, changed} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + division $R L D]
+} -body {
+ I elabel $R L'
+} -cleanup {
+ I destroy
+ unset R
+} -result L'
+
+test doctools-toc-${impl}-27.7 {elabel, division, set, collision} -setup {
+ doctools::toc I
+ set R [I element]
+ I + division $R L' D
+ set R [I + division $R L D]
+} -body {
+ I elabel $R L'
+} -cleanup {
+ I destroy
+ unset R
+} -returnCodes error -result {Redefinition of label 'L'' in '{}'}
+
+test doctools-toc-${impl}-28.0 {description, reference, query} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + reference $R L D DESC]
+} -body {
+ I description $R
+} -cleanup {
+ I destroy
+ unset R
+} -result DESC
+
+test doctools-toc-${impl}-28.1 {description, reference, set, unchanged} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + reference $R L D DESC]
+} -body {
+ I description $R DESC
+} -cleanup {
+ I destroy
+ unset R
+} -result DESC
+
+test doctools-toc-${impl}-28.2 {description, reference, set, changed} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + reference $R L D DESC]
+} -body {
+ I description $R DESC'
+} -cleanup {
+ I destroy
+ unset R
+} -result DESC'
+
+test doctools-toc-${impl}-28.3 {description, division, query} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + division $R L D]
+} -body {
+ I description $R
+} -cleanup {
+ I destroy
+ unset R
+} -returnCodes error -result {Divisions have no description}
+
+test doctools-toc-${impl}-28.4 {description, division, set} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + division $R L D]
+} -body {
+ I description $R DESC
+} -cleanup {
+ I destroy
+ unset R
+} -returnCodes error -result {Divisions have no description}
+
+test doctools-toc-${impl}-29.0 {document, reference, query} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + reference $R L D DESC]
+} -body {
+ I document $R
+} -cleanup {
+ I destroy
+ unset R
+} -result D
+
+test doctools-toc-${impl}-29.1 {document, reference, set, unchanged} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + reference $R L D DESC]
+} -body {
+ I document $R D
+} -cleanup {
+ I destroy
+ unset R
+} -result D
+
+test doctools-toc-${impl}-29.2 {document, reference, set, changed} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + reference $R L D DESC]
+} -body {
+ I document $R D'
+} -cleanup {
+ I destroy
+ unset R
+} -result D'
+
+test doctools-toc-${impl}-29.3 {document, reference, set, empty} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + reference $R L D DESC]
+} -body {
+ I document $R {}
+} -cleanup {
+ I destroy
+ unset R
+} -returnCodes error -result {Illegal to unset document reference in reference entry}
+
+test doctools-toc-${impl}-29.4 {document, division, query} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + division $R L D]
+} -body {
+ I document $R
+} -cleanup {
+ I destroy
+ unset R
+} -result D
+
+test doctools-toc-${impl}-29.5 {document, division, set, unchanged} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + division $R L D]
+} -body {
+ I document $R D
+} -cleanup {
+ I destroy
+ unset R
+} -result D
+
+test doctools-toc-${impl}-29.6 {document, division, set, changed} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + division $R L D]
+} -body {
+ I document $R D'
+} -cleanup {
+ I destroy
+ unset R
+} -result D'
+
+test doctools-toc-${impl}-29.7 {document, division, unset} -setup {
+ doctools::toc I
+ set R [I element]
+ set R [I + division $R L D]
+} -body {
+ I document $R {}
+} -cleanup {
+ I destroy
+ unset R
+} -result {}
+
+# -------------------------------------------------------------------------
+
+test doctools-toc-${impl}-30.0 {title, default} -setup {
+ doctools::toc I
+} -body {
+ I title
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-toc-${impl}-30.1 {title, set} -setup {
+ doctools::toc I
+} -body {
+ I title T
+} -cleanup {
+ I destroy
+} -result T
+
+test doctools-toc-${impl}-30.2 {title, get} -setup {
+ doctools::toc I
+ I title T
+} -body {
+ I title
+} -cleanup {
+ I destroy
+} -result T
+
+test doctools-toc-${impl}-31.0 {label, default} -setup {
+ doctools::toc I
+} -body {
+ I label
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-toc-${impl}-31.1 {label, set} -setup {
+ doctools::toc I
+} -body {
+ I label T
+} -cleanup {
+ I destroy
+} -result T
+
+test doctools-toc-${impl}-31.2 {label, get} -setup {
+ doctools::toc I
+ I label T
+} -body {
+ I label
+} -cleanup {
+ I destroy
+} -result T
+
+test doctools-toc-${impl}-32.0 {exporter, default} -setup {
+ doctools::toc I
+} -body {
+ I exporter
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-toc-${impl}-32.1 {exporter, set} -setup {
+ doctools::toc I
+} -body {
+ I exporter T
+} -cleanup {
+ I destroy
+} -result T
+
+test doctools-toc-${impl}-32.2 {exporter, get} -setup {
+ doctools::toc I
+ I exporter T
+} -body {
+ I exporter
+} -cleanup {
+ I destroy
+} -result T
+
+test doctools-toc-${impl}-33.0 {importer, default} -setup {
+ doctools::toc I
+} -body {
+ I importer
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-toc-${impl}-33.1 {importer, set} -setup {
+ doctools::toc I
+} -body {
+ I importer T
+} -cleanup {
+ I destroy
+} -result T
+
+test doctools-toc-${impl}-33.2 {importer, get} -setup {
+ doctools::toc I
+ I importer T
+} -body {
+ I importer
+} -cleanup {
+ I destroy
+} -result T
+
+# -------------------------------------------------------------------------
+
+test doctools-toc-${impl}-34.0 {up, at root} -setup {
+ doctools::toc I
+} -body {
+ I up [I element]
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-toc-${impl}-34.1 {up, at root} -setup {
+ doctools::toc I
+ set R [I element]
+ set A [I + reference $R L D DESC]
+} -body {
+ string equal $R [I up $A]
+} -cleanup {
+ I destroy
+ unset R A
+} -result 1
+
+test doctools-toc-${impl}-35.0 {next, at root} -setup {
+ doctools::toc I
+} -body {
+ I next [I element]
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-toc-${impl}-35.1 {next, right} -setup {
+ doctools::toc I
+ set R [I element]
+ set A [I + reference $R L D DESC]
+ set B [I + reference $R L' D' DESC']
+} -body {
+ string equal $B [I next $A]
+} -cleanup {
+ I destroy
+ unset R A B
+} -result 1
+
+test doctools-toc-${impl}-35.2 {next, right up} -setup {
+ doctools::toc I
+ set R [I element]
+ set A [I + reference $R L D DESC]
+ set B [I + reference $R L' D' DESC']
+} -body {
+ string equal $R [I next $B]
+} -cleanup {
+ I destroy
+ unset R A B
+} -result 1
+
+test doctools-toc-${impl}-36.0 {prev, at root} -setup {
+ doctools::toc I
+} -body {
+ I prev [I element]
+} -cleanup {
+ I destroy
+} -result {}
+
+test doctools-toc-${impl}-36.1 {prev, left} -setup {
+ doctools::toc I
+ set R [I element]
+ set A [I + reference $R L D DESC]
+ set B [I + reference $R L' D' DESC']
+} -body {
+ string equal $A [I prev $B]
+} -cleanup {
+ I destroy
+ unset R A B
+} -result 1
+
+test doctools-toc-${impl}-36.2 {prev, left up} -setup {
+ doctools::toc I
+ set R [I element]
+ set A [I + reference $R L D DESC]
+ set B [I + reference $R L' D' DESC']
+} -body {
+ string equal $R [I prev $A]
+} -cleanup {
+ I destroy
+ unset R A B
+} -result 1
+
+test doctools-toc-${impl}-37.0 {child, ok} -setup {
+ doctools::toc I
+ set R [I element]
+ set A [I + reference $R L D DESC]
+} -body {
+ string equal $A [I child $R L]
+} -cleanup {
+ I destroy
+ unset R A
+} -result 1
+
+test doctools-toc-${impl}-37.1 {child, unknown} -setup {
+ doctools::toc I
+ set R [I element]
+ set A [I + reference $R L D DESC]
+} -body {
+ I child $R bogus
+} -cleanup {
+ I destroy
+ unset R A
+} -returnCodes error -result {Bad label 'bogus' in '{}'}
+
+test doctools-toc-${impl}-37.2 {child, nested} -setup {
+ doctools::toc I
+ set R [I element]
+ set A [I + division $R L D]
+ set B [I + reference $A L' D' DESC']
+} -body {
+ string equal $B [I child $R L L']
+} -cleanup {
+ I destroy
+ unset R A B
+} -result 1
+
+
+
+# TODO :: check toc merging (+=).
+
+# toc tests, numbering starts at 40
+# -------------------------------------------------------------------------
+
+source [localPath tests/container]
+return
diff --git a/tcllib/modules/doctools2toc/tests/data/bad_command b/tcllib/modules/doctools2toc/tests/data/bad_command
new file mode 100644
index 0000000..8e23fdd
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/bad_command
@@ -0,0 +1 @@
+[item][comment {arguments missing}]
diff --git a/tcllib/modules/doctools2toc/tests/data/empty b/tcllib/modules/doctools2toc/tests/data/empty
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/empty
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/badtrees.tcl b/tcllib/modules/doctools2toc/tests/data/fail/badtrees.tcl
new file mode 100644
index 0000000..6901e4d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/badtrees.tcl
@@ -0,0 +1,23 @@
+package require struct::tree
+package require fileutil
+
+struct::tree T
+fileutil::writeFile in-vt/0_root_label [T serialize]
+T set root label L
+fileutil::writeFile in-vt/1_root_title [T serialize]
+T set root title T
+T insert root end K
+fileutil::writeFile in-vt/2_keyword_label [T serialize]
+T set K label L
+T insert K end R
+fileutil::writeFile in-vt/3_ref_type [T serialize]
+T set R type foo
+fileutil::writeFile in-vt/4_ref_label [T serialize]
+T set R label L
+fileutil::writeFile in-vt/5_ref_ref [T serialize]
+T set R ref X
+fileutil::writeFile in-vt/6_ref_tag [T serialize]
+T set R type url
+T insert R end OVER
+fileutil::writeFile in-vt/7_depth [T serialize]
+exit
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/01_nonwhitespace1 b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/01_nonwhitespace1
new file mode 100644
index 0000000..5668d0a
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/01_nonwhitespace1
@@ -0,0 +1 @@
+regular text is not allowed in toc files \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/02_nonwhitespace2 b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/02_nonwhitespace2
new file mode 100644
index 0000000..edd1d9e
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/02_nonwhitespace2
@@ -0,0 +1 @@
+[vset fox] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/03_illegalcmd1 b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/03_illegalcmd1
new file mode 100644
index 0000000..240d9f7
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/03_illegalcmd1
@@ -0,0 +1 @@
+[foo]
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/04_illegalcmd2 b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/04_illegalcmd2
new file mode 100644
index 0000000..893d0d8
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/04_illegalcmd2
@@ -0,0 +1 @@
+[vset [foo]] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/05_nestingbad1 b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/05_nestingbad1
new file mode 100644
index 0000000..4682abc
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/05_nestingbad1
@@ -0,0 +1 @@
+[toc_begin a [vset b c]] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/06_nestingbad2 b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/06_nestingbad2
new file mode 100644
index 0000000..bc810a5
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/06_nestingbad2
@@ -0,0 +1 @@
+[toc_begin I [item F L D]] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/07_wrongargs b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/07_wrongargs
new file mode 100644
index 0000000..298f04a
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/07_wrongargs
@@ -0,0 +1 @@
+[toc_begin KWIC] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/08_toomanyargs b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/08_toomanyargs
new file mode 100644
index 0000000..ab6569d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/08_toomanyargs
@@ -0,0 +1 @@
+[toc_begin TOC {Table Of Contents} _bogus_] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/09_vsetvarunknown b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/09_vsetvarunknown
new file mode 100644
index 0000000..da33c55
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/09_vsetvarunknown
@@ -0,0 +1 @@
+[vset a] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/10_vsetvarerr b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/10_vsetvarerr
new file mode 100644
index 0000000..122f82d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/10_vsetvarerr
@@ -0,0 +1 @@
+[vset [include bogus] b] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/11_vsetvalueerr b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/11_vsetvalueerr
new file mode 100644
index 0000000..2b7641e
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/11_vsetvalueerr
@@ -0,0 +1 @@
+[vset a [include bogus]] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/12_incerror b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/12_incerror
new file mode 100644
index 0000000..8a40050
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/12_incerror
@@ -0,0 +1 @@
+[include [vset a b]] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/13_incnotfound b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/13_incnotfound
new file mode 100644
index 0000000..e874901
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/13_incnotfound
@@ -0,0 +1 @@
+[include bogus] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/14_incempty b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/14_incempty
new file mode 100644
index 0000000..de07995
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/14_incempty
@@ -0,0 +1 @@
+[include empty] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/15_incbadeof b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/15_incbadeof
new file mode 100644
index 0000000..a093d60
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/15_incbadeof
@@ -0,0 +1 @@
+[include unexpected_eof]
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/16_incbadchar b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/16_incbadchar
new file mode 100644
index 0000000..362354c
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/16_incbadchar
@@ -0,0 +1 @@
+[include unexpected_char]
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/17_badempty b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/17_badempty
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/17_badempty
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/18_nobegin b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/18_nobegin
new file mode 100644
index 0000000..db9b03e
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/18_nobegin
@@ -0,0 +1 @@
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/19_manybegin b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/19_manybegin
new file mode 100644
index 0000000..b6a92d2
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/19_manybegin
@@ -0,0 +1,5 @@
+[toc_begin A B]
+[toc_begin A B]
+[toc_begin A B]
+[toc_begin A B]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/20_latebegin b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/20_latebegin
new file mode 100644
index 0000000..ea9de89
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/20_latebegin
@@ -0,0 +1,3 @@
+[item F L D]
+[toc_begin A B]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/21_noend1 b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/21_noend1
new file mode 100644
index 0000000..4ebfa77
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/21_noend1
@@ -0,0 +1 @@
+[toc_begin A B]
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/22_noend2 b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/22_noend2
new file mode 100644
index 0000000..bafc0eb
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/22_noend2
@@ -0,0 +1,2 @@
+[toc_begin A B]
+[item F L D]
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/23_manyend b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/23_manyend
new file mode 100644
index 0000000..93dbd05
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/23_manyend
@@ -0,0 +1,5 @@
+[toc_begin A B]
+[toc_end]
+[toc_end]
+[toc_end]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/24_earlyend b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/24_earlyend
new file mode 100644
index 0000000..528c811
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/24_earlyend
@@ -0,0 +1,4 @@
+[toc_begin A B]
+[toc_end]
+[item F L D]
+
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/25_nobeginend b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/25_nobeginend
new file mode 100644
index 0000000..eb9a7d7
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/25_nobeginend
@@ -0,0 +1,2 @@
+[item F L D]
+[item F L' D']
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/26_nodivbegin b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/26_nodivbegin
new file mode 100644
index 0000000..65e18a2
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/26_nodivbegin
@@ -0,0 +1,3 @@
+[toc_begin TOC TOC]
+[division_end]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/27_incbadcmd b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/27_incbadcmd
new file mode 100644
index 0000000..599e5bd
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/27_incbadcmd
@@ -0,0 +1 @@
+[include bad_command] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/28_badredef b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/28_badredef
new file mode 100644
index 0000000..c0d00f8
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/28_badredef
@@ -0,0 +1,4 @@
+[toc_begin {Keyword Index} {}]
+[item ID LABEL DESC]
+[item ID LABEL DESC]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/29_badredef2 b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/29_badredef2
new file mode 100644
index 0000000..babe8bd
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/29_badredef2
@@ -0,0 +1,5 @@
+[toc_begin {Keyword Index} {}]
+[item ID LABEL DESC]
+[division_start LABEL]
+[division_end]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/30_manydivbegin b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/30_manydivbegin
new file mode 100644
index 0000000..70d2059
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/30_manydivbegin
@@ -0,0 +1,5 @@
+[toc_begin TOC TOC]
+[division_start L F]
+[division_start L F]
+[division_start L F]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/31_nodivend b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/31_nodivend
new file mode 100644
index 0000000..bef23d3
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/31_nodivend
@@ -0,0 +1,3 @@
+[toc_begin TOC TOC]
+[division_start L F]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/doctoc/32_manydivend b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/32_manydivend
new file mode 100644
index 0000000..b1e3ff6
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/doctoc/32_manydivend
@@ -0,0 +1,5 @@
+[toc_begin TOC TOC]
+[division_end]
+[division_end]
+[division_end]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/01_nonwhitespace1 b/tcllib/modules/doctools2toc/tests/data/fail/ecode/01_nonwhitespace1
new file mode 100644
index 0000000..b52db63
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/01_nonwhitespace1
@@ -0,0 +1 @@
+{{} {0 39} 1 40 doctoc/plaintext {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/02_nonwhitespace2 b/tcllib/modules/doctools2toc/tests/data/fail/ecode/02_nonwhitespace2
new file mode 100644
index 0000000..a810f91
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/02_nonwhitespace2
@@ -0,0 +1 @@
+{{} {1 4} 1 5 doctoc/plaintext {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/03_illegalcmd1 b/tcllib/modules/doctools2toc/tests/data/fail/ecode/03_illegalcmd1
new file mode 100644
index 0000000..23676aa
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/03_illegalcmd1
@@ -0,0 +1 @@
+{{} {1 3} 1 4 doctoc/cmd/illegal foo}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/04_illegalcmd2 b/tcllib/modules/doctools2toc/tests/data/fail/ecode/04_illegalcmd2
new file mode 100644
index 0000000..76a957a
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/04_illegalcmd2
@@ -0,0 +1 @@
+{{} {7 9} 1 10 doctoc/cmd/illegal foo}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/05_nestingbad1 b/tcllib/modules/doctools2toc/tests/data/fail/ecode/05_nestingbad1
new file mode 100644
index 0000000..e4728c5
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/05_nestingbad1
@@ -0,0 +1 @@
+{{} {14 17} 1 18 doctoc/cmd/nested vset/2}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/06_nestingbad2 b/tcllib/modules/doctools2toc/tests/data/fail/ecode/06_nestingbad2
new file mode 100644
index 0000000..80fa726
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/06_nestingbad2
@@ -0,0 +1 @@
+{{} {14 17} 1 18 doctoc/cmd/nested item}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/07_wrongargs b/tcllib/modules/doctools2toc/tests/data/fail/ecode/07_wrongargs
new file mode 100644
index 0000000..53f47c0
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/07_wrongargs
@@ -0,0 +1 @@
+{{} {1 9} 1 10 doctoc/cmd/wrongargs {toc_begin 2}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/08_toomanyargs b/tcllib/modules/doctools2toc/tests/data/fail/ecode/08_toomanyargs
new file mode 100644
index 0000000..b9ade4d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/08_toomanyargs
@@ -0,0 +1 @@
+{{} {1 9} 1 10 doctoc/cmd/toomanyargs {toc_begin 2}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/09_vsetvarunknown b/tcllib/modules/doctools2toc/tests/data/fail/ecode/09_vsetvarunknown
new file mode 100644
index 0000000..c95a1c0
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/09_vsetvarunknown
@@ -0,0 +1 @@
+{{} {1 4} 1 5 doctoc/vset/varname/unknown a}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/10_vsetvarerr b/tcllib/modules/doctools2toc/tests/data/fail/ecode/10_vsetvarerr
new file mode 100644
index 0000000..e133089
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/10_vsetvarerr
@@ -0,0 +1 @@
+{{} {7 13} 1 14 doctoc/cmd/nested include}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/11_vsetvalueerr b/tcllib/modules/doctools2toc/tests/data/fail/ecode/11_vsetvalueerr
new file mode 100644
index 0000000..e21599c
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/11_vsetvalueerr
@@ -0,0 +1 @@
+{{} {9 15} 1 16 doctoc/cmd/nested include}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/12_incerror b/tcllib/modules/doctools2toc/tests/data/fail/ecode/12_incerror
new file mode 100644
index 0000000..03610bb
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/12_incerror
@@ -0,0 +1 @@
+{{} {10 13} 1 14 doctoc/cmd/nested vset/2}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/13_incnotfound b/tcllib/modules/doctools2toc/tests/data/fail/ecode/13_incnotfound
new file mode 100644
index 0000000..4b9fe3a
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/13_incnotfound
@@ -0,0 +1 @@
+{{} {1 7} 1 8 doctoc/include/path/notfound bogus}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/14_incempty b/tcllib/modules/doctools2toc/tests/data/fail/ecode/14_incempty
new file mode 100644
index 0000000..dcf238b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/14_incempty
@@ -0,0 +1 @@
+{{} {0 0} 1 0 doctoc/toc_begin/missing {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/15_incbadeof b/tcllib/modules/doctools2toc/tests/data/fail/ecode/15_incbadeof
new file mode 100644
index 0000000..328f512
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/15_incbadeof
@@ -0,0 +1 @@
+{{} {1 7} 1 8 doctoc/include/syntax {@/tests/data/unexpected_eof {{{} {27 27} 1 27 doctoc/eof/syntax {}}}}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/16_incbadchar b/tcllib/modules/doctools2toc/tests/data/fail/ecode/16_incbadchar
new file mode 100644
index 0000000..44f268b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/16_incbadchar
@@ -0,0 +1 @@
+{{} {1 7} 1 8 doctoc/include/syntax {@/tests/data/unexpected_char {{{} {27 27} 1 27 doctoc/char/syntax {}}}}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/17_badempty b/tcllib/modules/doctools2toc/tests/data/fail/ecode/17_badempty
new file mode 100644
index 0000000..dcf238b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/17_badempty
@@ -0,0 +1 @@
+{{} {0 0} 1 0 doctoc/toc_begin/missing {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/18_nobegin b/tcllib/modules/doctools2toc/tests/data/fail/ecode/18_nobegin
new file mode 100644
index 0000000..d9ca877
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/18_nobegin
@@ -0,0 +1 @@
+{{} {1 7} 1 8 doctoc/toc_begin/missing {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/19_manybegin b/tcllib/modules/doctools2toc/tests/data/fail/ecode/19_manybegin
new file mode 100644
index 0000000..058a824
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/19_manybegin
@@ -0,0 +1 @@
+{{} {17 25} 2 10 doctoc/toc_begin/syntax {}} {{} {33 41} 3 10 doctoc/toc_begin/syntax {}} {{} {49 57} 4 10 doctoc/toc_begin/syntax {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/20_latebegin b/tcllib/modules/doctools2toc/tests/data/fail/ecode/20_latebegin
new file mode 100644
index 0000000..70cfffe
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/20_latebegin
@@ -0,0 +1 @@
+{{} {1 4} 1 5 doctoc/toc_begin/missing {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/21_noend1 b/tcllib/modules/doctools2toc/tests/data/fail/ecode/21_noend1
new file mode 100644
index 0000000..08f3435
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/21_noend1
@@ -0,0 +1 @@
+{{} {1 9} 1 10 doctoc/toc_end/missing {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/22_noend2 b/tcllib/modules/doctools2toc/tests/data/fail/ecode/22_noend2
new file mode 100644
index 0000000..47da638
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/22_noend2
@@ -0,0 +1 @@
+{{} {17 20} 2 5 doctoc/toc_end/missing {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/23_manyend b/tcllib/modules/doctools2toc/tests/data/fail/ecode/23_manyend
new file mode 100644
index 0000000..aa37c55
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/23_manyend
@@ -0,0 +1 @@
+{{} {27 33} 3 8 doctoc/toc_end/syntax {}} {{} {37 43} 4 8 doctoc/toc_end/syntax {}} {{} {47 53} 5 8 doctoc/toc_end/syntax {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/24_earlyend b/tcllib/modules/doctools2toc/tests/data/fail/ecode/24_earlyend
new file mode 100644
index 0000000..9d05b9d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/24_earlyend
@@ -0,0 +1 @@
+{{} {27 30} 3 5 doctoc/item/syntax {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/25_nobeginend b/tcllib/modules/doctools2toc/tests/data/fail/ecode/25_nobeginend
new file mode 100644
index 0000000..8d3d1b9
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/25_nobeginend
@@ -0,0 +1 @@
+{{} {1 4} 1 5 doctoc/toc_begin/missing {}} {{} {14 17} 2 5 doctoc/toc_begin/missing {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/26_nodivbegin b/tcllib/modules/doctools2toc/tests/data/fail/ecode/26_nodivbegin
new file mode 100644
index 0000000..cc7ea87
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/26_nodivbegin
@@ -0,0 +1 @@
+{{} {21 32} 2 13 doctoc/division_end/syntax {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/27_incbadcmd b/tcllib/modules/doctools2toc/tests/data/fail/ecode/27_incbadcmd
new file mode 100644
index 0000000..08048d2
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/27_incbadcmd
@@ -0,0 +1 @@
+{@/tests/data/bad_command {1 4} 1 5 doctoc/cmd/wrongargs {item 3}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/28_badredef b/tcllib/modules/doctools2toc/tests/data/fail/ecode/28_badredef
new file mode 100644
index 0000000..7b81c93
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/28_badredef
@@ -0,0 +1 @@
+{{} {53 56} 3 5 doctoc/redef LABEL}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/29_badredef2 b/tcllib/modules/doctools2toc/tests/data/fail/ecode/29_badredef2
new file mode 100644
index 0000000..4b3cc09
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/29_badredef2
@@ -0,0 +1 @@
+{{} {53 66} 3 15 doctoc/redef LABEL} \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/30_manydivbegin b/tcllib/modules/doctools2toc/tests/data/fail/ecode/30_manydivbegin
new file mode 100644
index 0000000..c085d4b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/30_manydivbegin
@@ -0,0 +1 @@
+{{} {84 90} 5 8 doctoc/division_end/missing {}} {{} {84 90} 5 8 doctoc/toc_end/syntax {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/31_nodivend b/tcllib/modules/doctools2toc/tests/data/fail/ecode/31_nodivend
new file mode 100644
index 0000000..26012a6
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/31_nodivend
@@ -0,0 +1 @@
+{{} {42 48} 3 8 doctoc/division_end/missing {}} {{} {42 48} 3 8 doctoc/toc_end/syntax {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/ecode/32_manydivend b/tcllib/modules/doctools2toc/tests/data/fail/ecode/32_manydivend
new file mode 100644
index 0000000..dfc74d9
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/ecode/32_manydivend
@@ -0,0 +1 @@
+{{} {21 32} 2 13 doctoc/division_end/syntax {}} {{} {36 47} 3 13 doctoc/division_end/syntax {}} {{} {51 62} 4 13 doctoc/division_end/syntax {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/01_nonwhitespace1 b/tcllib/modules/doctools2toc/tests/data/fail/emsg/01_nonwhitespace1
new file mode 100644
index 0000000..a026582
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/01_nonwhitespace1
@@ -0,0 +1 @@
+error on line 1.40: Plain text beyond whitespace is not allowed
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/02_nonwhitespace2 b/tcllib/modules/doctools2toc/tests/data/fail/emsg/02_nonwhitespace2
new file mode 100644
index 0000000..fe97361
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/02_nonwhitespace2
@@ -0,0 +1 @@
+error on line 1.5: Plain text beyond whitespace is not allowed
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/03_illegalcmd1 b/tcllib/modules/doctools2toc/tests/data/fail/emsg/03_illegalcmd1
new file mode 100644
index 0000000..20bc922
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/03_illegalcmd1
@@ -0,0 +1 @@
+error on line 1.4: Illegal command "foo", not a doctoc command
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/04_illegalcmd2 b/tcllib/modules/doctools2toc/tests/data/fail/emsg/04_illegalcmd2
new file mode 100644
index 0000000..3ad9935
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/04_illegalcmd2
@@ -0,0 +1 @@
+error on line 1.10: Illegal command "foo", not a doctoc command
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/05_nestingbad1 b/tcllib/modules/doctools2toc/tests/data/fail/emsg/05_nestingbad1
new file mode 100644
index 0000000..e65e334
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/05_nestingbad1
@@ -0,0 +1 @@
+error on line 1.18: Illegal use of "vset/2" as argument of other command
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/06_nestingbad2 b/tcllib/modules/doctools2toc/tests/data/fail/emsg/06_nestingbad2
new file mode 100644
index 0000000..fcf4cdc
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/06_nestingbad2
@@ -0,0 +1 @@
+error on line 1.18: Illegal use of "item" as argument of other command
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/07_wrongargs b/tcllib/modules/doctools2toc/tests/data/fail/emsg/07_wrongargs
new file mode 100644
index 0000000..3326719
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/07_wrongargs
@@ -0,0 +1 @@
+error on line 1.10: Wrong#args for "toc_begin", need at least 2
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/08_toomanyargs b/tcllib/modules/doctools2toc/tests/data/fail/emsg/08_toomanyargs
new file mode 100644
index 0000000..efe705a
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/08_toomanyargs
@@ -0,0 +1 @@
+error on line 1.10: Too many args for "toc_begin", at most 2 allowed
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/09_vsetvarunknown b/tcllib/modules/doctools2toc/tests/data/fail/emsg/09_vsetvarunknown
new file mode 100644
index 0000000..f73a6bc
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/09_vsetvarunknown
@@ -0,0 +1 @@
+error on line 1.5: Unknown variable "a"
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/10_vsetvarerr b/tcllib/modules/doctools2toc/tests/data/fail/emsg/10_vsetvarerr
new file mode 100644
index 0000000..cf07b85
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/10_vsetvarerr
@@ -0,0 +1 @@
+error on line 1.14: Illegal use of "include" as argument of other command
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/11_vsetvalueerr b/tcllib/modules/doctools2toc/tests/data/fail/emsg/11_vsetvalueerr
new file mode 100644
index 0000000..13eefe5
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/11_vsetvalueerr
@@ -0,0 +1 @@
+error on line 1.16: Illegal use of "include" as argument of other command
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/12_incerror b/tcllib/modules/doctools2toc/tests/data/fail/emsg/12_incerror
new file mode 100644
index 0000000..644618d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/12_incerror
@@ -0,0 +1 @@
+error on line 1.14: Illegal use of "vset/2" as argument of other command
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/13_incnotfound b/tcllib/modules/doctools2toc/tests/data/fail/emsg/13_incnotfound
new file mode 100644
index 0000000..3750a26
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/13_incnotfound
@@ -0,0 +1 @@
+error on line 1.8: Include file "bogus" not found
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/14_incempty b/tcllib/modules/doctools2toc/tests/data/fail/emsg/14_incempty
new file mode 100644
index 0000000..3b1db20
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/14_incempty
@@ -0,0 +1 @@
+error on line 1.0: Expected [toc_begin], not found
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/15_incbadeof b/tcllib/modules/doctools2toc/tests/data/fail/emsg/15_incbadeof
new file mode 100644
index 0000000..390567b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/15_incbadeof
@@ -0,0 +1,2 @@
+error on line 1.8: Errors in include file "@/tests/data/unexpected_eof"
+"@/tests/data/unexpected_eof": error on line 1.27: Bad <eof>
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/16_incbadchar b/tcllib/modules/doctools2toc/tests/data/fail/emsg/16_incbadchar
new file mode 100644
index 0000000..7666aa2
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/16_incbadchar
@@ -0,0 +1,2 @@
+error on line 1.8: Errors in include file "@/tests/data/unexpected_char"
+"@/tests/data/unexpected_char": error on line 1.27: Bad character in string
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/17_badempty b/tcllib/modules/doctools2toc/tests/data/fail/emsg/17_badempty
new file mode 100644
index 0000000..3b1db20
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/17_badempty
@@ -0,0 +1 @@
+error on line 1.0: Expected [toc_begin], not found
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/18_nobegin b/tcllib/modules/doctools2toc/tests/data/fail/emsg/18_nobegin
new file mode 100644
index 0000000..31511ea
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/18_nobegin
@@ -0,0 +1 @@
+error on line 1.8: Expected [toc_begin], not found
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/19_manybegin b/tcllib/modules/doctools2toc/tests/data/fail/emsg/19_manybegin
new file mode 100644
index 0000000..ea6385a
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/19_manybegin
@@ -0,0 +1,3 @@
+error on line 2.10: Unexpected [toc_begin], not allowed here
+error on line 3.10: Unexpected [toc_begin], not allowed here
+error on line 4.10: Unexpected [toc_begin], not allowed here
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/20_latebegin b/tcllib/modules/doctools2toc/tests/data/fail/emsg/20_latebegin
new file mode 100644
index 0000000..b4db5b7
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/20_latebegin
@@ -0,0 +1,2 @@
+error on line 1.5: Expected [toc_begin], not found
+
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/21_noend1 b/tcllib/modules/doctools2toc/tests/data/fail/emsg/21_noend1
new file mode 100644
index 0000000..b981fc1
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/21_noend1
@@ -0,0 +1 @@
+error on line 1.10: Expected [toc_end], not found
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/22_noend2 b/tcllib/modules/doctools2toc/tests/data/fail/emsg/22_noend2
new file mode 100644
index 0000000..385ca45
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/22_noend2
@@ -0,0 +1 @@
+error on line 2.5: Expected [toc_end], not found
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/23_manyend b/tcllib/modules/doctools2toc/tests/data/fail/emsg/23_manyend
new file mode 100644
index 0000000..1fa20b7
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/23_manyend
@@ -0,0 +1,3 @@
+error on line 3.8: Unexpected [toc_end], not allowed here
+error on line 4.8: Unexpected [toc_end], not allowed here
+error on line 5.8: Unexpected [toc_end], not allowed here
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/24_earlyend b/tcllib/modules/doctools2toc/tests/data/fail/emsg/24_earlyend
new file mode 100644
index 0000000..12d3db9
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/24_earlyend
@@ -0,0 +1 @@
+error on line 3.5: Unexpected [item], not allowed here
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/25_nobeginend b/tcllib/modules/doctools2toc/tests/data/fail/emsg/25_nobeginend
new file mode 100644
index 0000000..9cf6486
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/25_nobeginend
@@ -0,0 +1,2 @@
+error on line 1.5: Expected [toc_begin], not found
+error on line 2.5: Expected [toc_begin], not found
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/26_nodivbegin b/tcllib/modules/doctools2toc/tests/data/fail/emsg/26_nodivbegin
new file mode 100644
index 0000000..5a174f8
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/26_nodivbegin
@@ -0,0 +1 @@
+error on line 2.13: Unexpected [division_end], not allowed here
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/27_incbadcmd b/tcllib/modules/doctools2toc/tests/data/fail/emsg/27_incbadcmd
new file mode 100644
index 0000000..23dea3b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/27_incbadcmd
@@ -0,0 +1 @@
+"@/tests/data/bad_command" error on line 1.5: Wrong#args for "item", need at least 3
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/28_badredef b/tcllib/modules/doctools2toc/tests/data/fail/emsg/28_badredef
new file mode 100644
index 0000000..d26a6f2
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/28_badredef
@@ -0,0 +1 @@
+error on line 3.5: Bad reuse of label "LABEL"
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/29_badredef2 b/tcllib/modules/doctools2toc/tests/data/fail/emsg/29_badredef2
new file mode 100644
index 0000000..fe10c28
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/29_badredef2
@@ -0,0 +1 @@
+error on line 3.15: Bad reuse of label "LABEL"
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/30_manydivbegin b/tcllib/modules/doctools2toc/tests/data/fail/emsg/30_manydivbegin
new file mode 100644
index 0000000..3e3a123
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/30_manydivbegin
@@ -0,0 +1,2 @@
+error on line 5.8: Expected [division_end], not found
+error on line 5.8: Unexpected [toc_end], not allowed here
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/31_nodivend b/tcllib/modules/doctools2toc/tests/data/fail/emsg/31_nodivend
new file mode 100644
index 0000000..424cd8f
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/31_nodivend
@@ -0,0 +1,2 @@
+error on line 3.8: Expected [division_end], not found
+error on line 3.8: Unexpected [toc_end], not allowed here
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/emsg/32_manydivend b/tcllib/modules/doctools2toc/tests/data/fail/emsg/32_manydivend
new file mode 100644
index 0000000..0cecb94
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/emsg/32_manydivend
@@ -0,0 +1,3 @@
+error on line 2.13: Unexpected [division_end], not allowed here
+error on line 3.13: Unexpected [division_end], not allowed here
+error on line 4.13: Unexpected [division_end], not allowed here
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/00_short b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/00_short
new file mode 100644
index 0000000..4329caa
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/00_short
@@ -0,0 +1 @@
+error in serialization: dictionary too short, expected exactly one key
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/01_tag b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/01_tag
new file mode 100644
index 0000000..369116b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/01_tag
@@ -0,0 +1 @@
+error in serialization: bad type tag "FOO"
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/02_cshort b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/02_cshort
new file mode 100644
index 0000000..2dbe5b7
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/02_cshort
@@ -0,0 +1 @@
+error in serialization: dictionary too short, expected exactly three keys
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/03_misslabel b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/03_misslabel
new file mode 100644
index 0000000..3c3da93
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/03_misslabel
@@ -0,0 +1 @@
+error in serialization: missing expected key "label"
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/04_misstitle b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/04_misstitle
new file mode 100644
index 0000000..8401b05
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/04_misstitle
@@ -0,0 +1 @@
+error in serialization: missing expected key "title"
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/05_missitems b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/05_missitems
new file mode 100644
index 0000000..50331bd
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/05_missitems
@@ -0,0 +1 @@
+error in serialization: missing expected key "items"
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/07_cshort2 b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/07_cshort2
new file mode 100644
index 0000000..29f072a
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/07_cshort2
@@ -0,0 +1 @@
+error in serialization: element list wrong, need exactly 2 \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/08_etag b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/08_etag
new file mode 100644
index 0000000..21a0f0a
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/08_etag
@@ -0,0 +1 @@
+error in serialization: bad element tag "FOO"
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/09_cshort3 b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/09_cshort3
new file mode 100644
index 0000000..e753b96
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/09_cshort3
@@ -0,0 +1,2 @@
+error in serialization: dictionary too short, expected exactly three keys
+
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/10_missid b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/10_missid
new file mode 100644
index 0000000..deac041
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/10_missid
@@ -0,0 +1 @@
+error in serialization: missing expected key "id"
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/11_misslabel2 b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/11_misslabel2
new file mode 100644
index 0000000..55d919d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/11_misslabel2
@@ -0,0 +1,2 @@
+error in serialization: missing expected key "label"
+
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/12_missdesc b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/12_missdesc
new file mode 100644
index 0000000..7a8c4c3
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/12_missdesc
@@ -0,0 +1,2 @@
+error in serialization: missing expected key "desc"
+
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/14_dshort b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/14_dshort
new file mode 100644
index 0000000..e1abdb2
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/14_dshort
@@ -0,0 +1,2 @@
+error in serialization: dictionary too short, expected two or three keys
+
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/15_misslabel3 b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/15_misslabel3
new file mode 100644
index 0000000..c5f7daa
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/15_misslabel3
@@ -0,0 +1,3 @@
+error in serialization: missing expected key "label"
+
+
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/16_missitems2 b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/16_missitems2
new file mode 100644
index 0000000..50331bd
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/16_missitems2
@@ -0,0 +1 @@
+error in serialization: missing expected key "items"
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/19_duplabel b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/19_duplabel
new file mode 100644
index 0000000..9a9863a
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/19_duplabel
@@ -0,0 +1 @@
+error in serialization: duplicate labels \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/20_duplabel2 b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/20_duplabel2
new file mode 100644
index 0000000..9a9863a
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/20_duplabel2
@@ -0,0 +1 @@
+error in serialization: duplicate labels \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/21_duplabel3 b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/21_duplabel3
new file mode 100644
index 0000000..9a9863a
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json-emsg/21_duplabel3
@@ -0,0 +1 @@
+error in serialization: duplicate labels \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/00_short b/tcllib/modules/doctools2toc/tests/data/fail/json/00_short
new file mode 100644
index 0000000..2c63c08
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/00_short
@@ -0,0 +1,2 @@
+{
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/01_tag b/tcllib/modules/doctools2toc/tests/data/fail/json/01_tag
new file mode 100644
index 0000000..9803dba
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/01_tag
@@ -0,0 +1,4 @@
+{
+ "FOO" : {
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/02_cshort b/tcllib/modules/doctools2toc/tests/data/fail/json/02_cshort
new file mode 100644
index 0000000..325b934
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/02_cshort
@@ -0,0 +1,4 @@
+{
+ "doctools::toc" : {
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/03_misslabel b/tcllib/modules/doctools2toc/tests/data/fail/json/03_misslabel
new file mode 100644
index 0000000..e08662c
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/03_misslabel
@@ -0,0 +1,7 @@
+{
+ "doctools::toc" : {
+ "a" : ".",
+ "b" : ".",
+ "c" : "."
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/04_misstitle b/tcllib/modules/doctools2toc/tests/data/fail/json/04_misstitle
new file mode 100644
index 0000000..ec1eaa8
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/04_misstitle
@@ -0,0 +1,7 @@
+{
+ "doctools::toc" : {
+ "label" : ".",
+ "b" : ".",
+ "c" : "."
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/05_missitems b/tcllib/modules/doctools2toc/tests/data/fail/json/05_missitems
new file mode 100644
index 0000000..4c4e391
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/05_missitems
@@ -0,0 +1,7 @@
+{
+ "doctools::toc" : {
+ "label" : ".",
+ "title" : ".",
+ "c" : "."
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/07_cshort2 b/tcllib/modules/doctools2toc/tests/data/fail/json/07_cshort2
new file mode 100644
index 0000000..f99a165
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/07_cshort2
@@ -0,0 +1,7 @@
+{
+ "doctools::toc" : {
+ "label" : ".",
+ "title" : ".",
+ "items" : [{}]
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/08_etag b/tcllib/modules/doctools2toc/tests/data/fail/json/08_etag
new file mode 100644
index 0000000..b43a43b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/08_etag
@@ -0,0 +1,7 @@
+{
+ "doctools::toc" : {
+ "label" : ".",
+ "title" : ".",
+ "items" : [{ "FOO" : ""}]
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/09_cshort3 b/tcllib/modules/doctools2toc/tests/data/fail/json/09_cshort3
new file mode 100644
index 0000000..c7ac012
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/09_cshort3
@@ -0,0 +1,7 @@
+{
+ "doctools::toc" : {
+ "label" : ".",
+ "title" : ".",
+ "items" : [{ "reference" : ""}]
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/10_missid b/tcllib/modules/doctools2toc/tests/data/fail/json/10_missid
new file mode 100644
index 0000000..c249aec
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/10_missid
@@ -0,0 +1,11 @@
+{
+ "doctools::toc" : {
+ "label" : ".",
+ "title" : ".",
+ "items" : [{ "reference" : {
+ "a" : ".",
+ "b" : ".",
+ "c" : "."
+ }}]
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/11_misslabel2 b/tcllib/modules/doctools2toc/tests/data/fail/json/11_misslabel2
new file mode 100644
index 0000000..401f608
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/11_misslabel2
@@ -0,0 +1,11 @@
+{
+ "doctools::toc" : {
+ "label" : ".",
+ "title" : ".",
+ "items" : [{ "reference" : {
+ "id" : ".",
+ "b" : ".",
+ "c" : "."
+ }}]
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/12_missdesc b/tcllib/modules/doctools2toc/tests/data/fail/json/12_missdesc
new file mode 100644
index 0000000..a0824f2
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/12_missdesc
@@ -0,0 +1,11 @@
+{
+ "doctools::toc" : {
+ "label" : ".",
+ "title" : ".",
+ "items" : [{ "reference" : {
+ "id" : ".",
+ "label" : ".",
+ "c" : "."
+ }}]
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/14_dshort b/tcllib/modules/doctools2toc/tests/data/fail/json/14_dshort
new file mode 100644
index 0000000..a71bba0
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/14_dshort
@@ -0,0 +1,7 @@
+{
+ "doctools::toc" : {
+ "label" : ".",
+ "title" : ".",
+ "items" : [{ "division" : ""}]
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/15_misslabel3 b/tcllib/modules/doctools2toc/tests/data/fail/json/15_misslabel3
new file mode 100644
index 0000000..1c70099
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/15_misslabel3
@@ -0,0 +1,10 @@
+{
+ "doctools::toc" : {
+ "label" : ".",
+ "title" : ".",
+ "items" : [{ "division" : {
+ "a" : ".",
+ "b" : "."
+ }}]
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/16_missitems2 b/tcllib/modules/doctools2toc/tests/data/fail/json/16_missitems2
new file mode 100644
index 0000000..d4437de
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/16_missitems2
@@ -0,0 +1,10 @@
+{
+ "doctools::toc" : {
+ "label" : ".",
+ "title" : ".",
+ "items" : [{ "division" : {
+ "label" : ".",
+ "b" : "."
+ }}]
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/19_duplabel b/tcllib/modules/doctools2toc/tests/data/fail/json/19_duplabel
new file mode 100644
index 0000000..1b7d921
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/19_duplabel
@@ -0,0 +1,15 @@
+{
+ "doctools::toc" : {
+ "label" : ".",
+ "title" : ".",
+ "items" : [{ "reference" : {
+ "id" : ".",
+ "label" : ".",
+ "desc" : "."
+ }},{ "reference" : {
+ "id" : ".",
+ "label" : ".",
+ "desc" : "."
+ }}]
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/20_duplabel2 b/tcllib/modules/doctools2toc/tests/data/fail/json/20_duplabel2
new file mode 100644
index 0000000..9335518
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/20_duplabel2
@@ -0,0 +1,15 @@
+{
+ "doctools::toc" : {
+ "label" : ".",
+ "title" : ".",
+ "items" : [{ "division" : {
+ "id" : ".",
+ "label" : ".",
+ "items" : ""
+ }},{ "division" : {
+ "id" : ".",
+ "label" : ".",
+ "items" : ""
+ }}]
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/fail/json/21_duplabel3 b/tcllib/modules/doctools2toc/tests/data/fail/json/21_duplabel3
new file mode 100644
index 0000000..b802d3f
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/fail/json/21_duplabel3
@@ -0,0 +1,15 @@
+{
+ "doctools::toc" : {
+ "label" : ".",
+ "title" : ".",
+ "items" : [{ "reference" : {
+ "id" : ".",
+ "label" : ".",
+ "desc" : "."
+ }},{ "division" : {
+ "id" : ".",
+ "label" : ".",
+ "items" : ""
+ }}]
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/1_empty
new file mode 100644
index 0000000..6f5db06
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/1_empty
@@ -0,0 +1,2 @@
+[toc_begin TOC TOC]
+[toc_end] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/2_references b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/2_references
new file mode 100644
index 0000000..3e5ab89
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/2_references
@@ -0,0 +1,5 @@
+[toc_begin {Table of Contents} {}]
+[item structure.man doctools::toc::structure {doctoc serialization utilities}]
+[item parse.man doctools::toc::parse {Parsing text in doctoc format}]
+[item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/3_toc
new file mode 100644
index 0000000..63f1b1c
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/3_toc
@@ -0,0 +1,7 @@
+[toc_begin {Table of Contents} TOC]
+[item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}]
+[division_start Processing processing.man]
+[item structure.man doctools::toc::structure {doctoc serialization utilities}]
+[item parse.man doctools::toc::parse {Parsing text in doctoc format}]
+[division_end]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/4_toc2
new file mode 100644
index 0000000..398718c
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-aligned/4_toc2
@@ -0,0 +1,7 @@
+[toc_begin {Table of Contents} TOC]
+[item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}]
+[division_start Processing processing.man]
+[item parse.man doctools::toc::parse {Parsing text in doctoc format}]
+[division_end]
+[item structure.man doctools::toc::structure {doctoc serialization utilities}]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/1_empty
new file mode 100644
index 0000000..6f5db06
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/1_empty
@@ -0,0 +1,2 @@
+[toc_begin TOC TOC]
+[toc_end] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/2_references b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/2_references
new file mode 100644
index 0000000..9432e62
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/2_references
@@ -0,0 +1,5 @@
+[toc_begin {Table of Contents} {}]
+[item structure.man doctools::toc::structure {doctoc serialization utilities}]
+[item parse.man doctools::toc::parse {Parsing text in doctoc format}]
+[item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/3_toc
new file mode 100644
index 0000000..28896ac
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/3_toc
@@ -0,0 +1,7 @@
+[toc_begin {Table of Contents} TOC]
+[item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}]
+[division_start Processing processing.man]
+[item structure.man doctools::toc::structure {doctoc serialization utilities}]
+[item parse.man doctools::toc::parse {Parsing text in doctoc format}]
+[division_end]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/4_toc2
new file mode 100644
index 0000000..8ca535b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-compact/4_toc2
@@ -0,0 +1,7 @@
+[toc_begin {Table of Contents} TOC]
+[item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}]
+[division_start Processing processing.man]
+[item parse.man doctools::toc::parse {Parsing text in doctoc format}]
+[division_end]
+[item structure.man doctools::toc::structure {doctoc serialization utilities}]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/1_empty
new file mode 100644
index 0000000..6f5db06
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/1_empty
@@ -0,0 +1,2 @@
+[toc_begin TOC TOC]
+[toc_end] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/2_references b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/2_references
new file mode 100644
index 0000000..978be38
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/2_references
@@ -0,0 +1,5 @@
+[toc_begin {Table of Contents} {}]
+ [item structure.man doctools::toc::structure {doctoc serialization utilities}]
+ [item parse.man doctools::toc::parse {Parsing text in doctoc format}]
+ [item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/3_toc
new file mode 100644
index 0000000..49a43d6
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/3_toc
@@ -0,0 +1,7 @@
+[toc_begin {Table of Contents} TOC]
+ [item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}]
+ [division_start Processing processing.man]
+ [item structure.man doctools::toc::structure {doctoc serialization utilities}]
+ [item parse.man doctools::toc::parse {Parsing text in doctoc format}]
+ [division_end]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/4_toc2
new file mode 100644
index 0000000..596bf3e
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indalign/4_toc2
@@ -0,0 +1,7 @@
+[toc_begin {Table of Contents} TOC]
+ [item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}]
+ [division_start Processing processing.man]
+ [item parse.man doctools::toc::parse {Parsing text in doctoc format}]
+ [division_end]
+ [item structure.man doctools::toc::structure {doctoc serialization utilities}]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/1_empty
new file mode 100644
index 0000000..a4f2ffd
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/1_empty
@@ -0,0 +1,2 @@
+[toc_begin TOC TOC]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/2_references b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/2_references
new file mode 100644
index 0000000..7d72fd5
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/2_references
@@ -0,0 +1,5 @@
+[toc_begin {Table of Contents} {}]
+ [item structure.man doctools::toc::structure {doctoc serialization utilities}]
+ [item parse.man doctools::toc::parse {Parsing text in doctoc format}]
+ [item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/3_toc
new file mode 100644
index 0000000..e048067
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/3_toc
@@ -0,0 +1,7 @@
+[toc_begin {Table of Contents} TOC]
+ [item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}]
+ [division_start Processing processing.man]
+ [item structure.man doctools::toc::structure {doctoc serialization utilities}]
+ [item parse.man doctools::toc::parse {Parsing text in doctoc format}]
+ [division_end]
+[toc_end] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/4_toc2
new file mode 100644
index 0000000..000d2b6
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-indented/4_toc2
@@ -0,0 +1,7 @@
+[toc_begin {Table of Contents} TOC]
+ [item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}]
+ [division_start Processing processing.man]
+ [item parse.man doctools::toc::parse {Parsing text in doctoc format}]
+ [division_end]
+ [item structure.man doctools::toc::structure {doctoc serialization utilities}]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/1_empty
new file mode 100644
index 0000000..24f98d4
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/1_empty
@@ -0,0 +1 @@
+[toc_begin TOC TOC][toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/2_references b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/2_references
new file mode 100644
index 0000000..69183d2
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/2_references
@@ -0,0 +1 @@
+[toc_begin {Table of Contents} {}][item structure.man doctools::toc::structure {doctoc serialization utilities}][item parse.man doctools::toc::parse {Parsing text in doctoc format}][item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}][toc_end] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/3_toc
new file mode 100644
index 0000000..9a679ed
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/3_toc
@@ -0,0 +1 @@
+[toc_begin {Table of Contents} TOC][item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}][division_start Processing processing.man][item structure.man doctools::toc::structure {doctoc serialization utilities}][item parse.man doctools::toc::parse {Parsing text in doctoc format}][division_end][toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/4_toc2
new file mode 100644
index 0000000..a42ba63
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc-ultracompact/4_toc2
@@ -0,0 +1 @@
+[toc_begin {Table of Contents} TOC][item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}][division_start Processing processing.man][item parse.man doctools::toc::parse {Parsing text in doctoc format}][division_end][item structure.man doctools::toc::structure {doctoc serialization utilities}][toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/doctoc/1_empty
new file mode 100644
index 0000000..6f5db06
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc/1_empty
@@ -0,0 +1,2 @@
+[toc_begin TOC TOC]
+[toc_end] \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc/2_references b/tcllib/modules/doctools2toc/tests/data/ok/doctoc/2_references
new file mode 100644
index 0000000..9432e62
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc/2_references
@@ -0,0 +1,5 @@
+[toc_begin {Table of Contents} {}]
+[item structure.man doctools::toc::structure {doctoc serialization utilities}]
+[item parse.man doctools::toc::parse {Parsing text in doctoc format}]
+[item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/doctoc/3_toc
new file mode 100644
index 0000000..63f1b1c
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc/3_toc
@@ -0,0 +1,7 @@
+[toc_begin {Table of Contents} TOC]
+[item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}]
+[division_start Processing processing.man]
+[item structure.man doctools::toc::structure {doctoc serialization utilities}]
+[item parse.man doctools::toc::parse {Parsing text in doctoc format}]
+[division_end]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/doctoc/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/doctoc/4_toc2
new file mode 100644
index 0000000..217342d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/doctoc/4_toc2
@@ -0,0 +1,7 @@
+[toc_begin {Table of Contents} TOC]
+[item introduction.man doctools::toc::introduction {DocTools - Tables of Contents}]
+[division_start Processing processing.man]
+[item parse.man doctools::toc::parse {Parsing text in doctoc format}]
+[division_end]
+[item structure.man doctools::toc::structure {doctoc serialization utilities}]
+[toc_end]
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/html-compact/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/html-compact/1_empty
new file mode 100644
index 0000000..e886a56
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/html-compact/1_empty
@@ -0,0 +1,20 @@
+<html>
+<head>
+<title>TOC -- TOC</title>
+<style></style>
+</head>
+
+<body>
+<div class="doctools">
+<div class="toc-header">
+<h1 class="toc-title">TOC -- TOC</h1>
+<!-- Customization Point: header -->
+<hr class="toc-navsep">
+</div>
+<div class="toc-footer">
+<hr class="toc-navsep">
+<!-- Customization Point: footer -->
+</div>
+</div>
+</body>
+</html>
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/html-compact/2_references b/tcllib/modules/doctools2toc/tests/data/ok/html-compact/2_references
new file mode 100644
index 0000000..f366e63
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/html-compact/2_references
@@ -0,0 +1,30 @@
+<html>
+<head>
+<title>Table of Contents</title>
+<style></style>
+</head>
+
+<body>
+<div class="doctools">
+<div class="toc-header">
+<h1 class="toc-title">Table of Contents</h1>
+<!-- Customization Point: header -->
+<hr class="toc-navsep">
+</div>
+<!-- - Start Table Of Contents ---------------------------------- -->
+<dl class="toc-contents">
+<dt class="toc-ref"><a href="structure.man">doctools::toc::structure</a></dt>
+<dd class="toc-ref">doctoc serialization utilities</dd>
+<dt class="toc-ref"><a href="parse.man">doctools::toc::parse</a></dt>
+<dd class="toc-ref">Parsing text in doctoc format</dd>
+<dt class="toc-ref"><a href="introduction.man">doctools::toc::introduction</a></dt>
+<dd class="toc-ref">DocTools - Tables of Contents</dd>
+</dl>
+<!-- - Stop Table Of Contents ---------------------------------- -->
+<div class="toc-footer">
+<hr class="toc-navsep">
+<!-- Customization Point: footer -->
+</div>
+</div>
+</body>
+</html>
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/html-compact/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/html-compact/3_toc
new file mode 100644
index 0000000..d765d38
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/html-compact/3_toc
@@ -0,0 +1,37 @@
+<html>
+<head>
+<title>Table of Contents -- TOC</title>
+<style></style>
+</head>
+
+<body>
+<div class="doctools">
+<div class="toc-header">
+<h1 class="toc-title">Table of Contents -- TOC</h1>
+<!-- Customization Point: header -->
+<hr class="toc-navsep">
+</div>
+<!-- - Start Table Of Contents ---------------------------------- -->
+<dl class="toc-contents">
+<dt class="toc-ref"><a href="introduction.man">doctools::toc::introduction</a></dt>
+<dd class="toc-ref">DocTools - Tables of Contents</dd>
+<dt class="toc-div"><a href="processing.man">Processing</a></dt>
+<dd class="toc-div">
+<!-- - Start Division (Processing) ------------------------------ -->
+<dl class="toc-contents">
+<dt class="toc-ref"><a href="structure.man">doctools::toc::structure</a></dt>
+<dd class="toc-ref">doctoc serialization utilities</dd>
+<dt class="toc-ref"><a href="parse.man">doctools::toc::parse</a></dt>
+<dd class="toc-ref">Parsing text in doctoc format</dd>
+</dl>
+<!-- - Stop Division (Processing) ------------------------------ -->
+</dd>
+</dl>
+<!-- - Stop Table Of Contents ---------------------------------- -->
+<div class="toc-footer">
+<hr class="toc-navsep">
+<!-- Customization Point: footer -->
+</div>
+</div>
+</body>
+</html>
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/html-compact/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/html-compact/4_toc2
new file mode 100644
index 0000000..11b2cd0
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/html-compact/4_toc2
@@ -0,0 +1,37 @@
+<html>
+<head>
+<title>Table of Contents -- TOC</title>
+<style></style>
+</head>
+
+<body>
+<div class="doctools">
+<div class="toc-header">
+<h1 class="toc-title">Table of Contents -- TOC</h1>
+<!-- Customization Point: header -->
+<hr class="toc-navsep">
+</div>
+<!-- - Start Table Of Contents ---------------------------------- -->
+<dl class="toc-contents">
+<dt class="toc-ref"><a href="introduction.man">doctools::toc::introduction</a></dt>
+<dd class="toc-ref">DocTools - Tables of Contents</dd>
+<dt class="toc-div"><a href="processing.man">Processing</a></dt>
+<dd class="toc-div">
+<!-- - Start Division (Processing) ------------------------------ -->
+<dl class="toc-contents">
+<dt class="toc-ref"><a href="parse.man">doctools::toc::parse</a></dt>
+<dd class="toc-ref">Parsing text in doctoc format</dd>
+</dl>
+<!-- - Stop Division (Processing) ------------------------------ -->
+</dd>
+<dt class="toc-ref"><a href="structure.man">doctools::toc::structure</a></dt>
+<dd class="toc-ref">doctoc serialization utilities</dd>
+</dl>
+<!-- - Stop Table Of Contents ---------------------------------- -->
+<div class="toc-footer">
+<hr class="toc-navsep">
+<!-- Customization Point: footer -->
+</div>
+</div>
+</body>
+</html>
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/html-indented/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/html-indented/1_empty
new file mode 100644
index 0000000..08be800
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/html-indented/1_empty
@@ -0,0 +1,20 @@
+<html>
+ <head>
+ <title>TOC -- TOC</title>
+ <style></style>
+ </head>
+
+ <body>
+ <div class="doctools">
+ <div class="toc-header">
+ <h1 class="toc-title">TOC -- TOC</h1>
+ <!-- Customization Point: header -->
+ <hr class="toc-navsep">
+ </div>
+ <div class="toc-footer">
+ <hr class="toc-navsep">
+ <!-- Customization Point: footer -->
+ </div>
+ </div>
+ </body>
+</html>
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/html-indented/2_references b/tcllib/modules/doctools2toc/tests/data/ok/html-indented/2_references
new file mode 100644
index 0000000..ac834d9
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/html-indented/2_references
@@ -0,0 +1,30 @@
+<html>
+ <head>
+ <title>Table of Contents</title>
+ <style></style>
+ </head>
+
+ <body>
+ <div class="doctools">
+ <div class="toc-header">
+ <h1 class="toc-title">Table of Contents</h1>
+ <!-- Customization Point: header -->
+ <hr class="toc-navsep">
+ </div>
+ <!-- - Start Table Of Contents ---------------------------------- -->
+ <dl class="toc-contents">
+ <dt class="toc-ref"><a href="structure.man">doctools::toc::structure</a></dt>
+ <dd class="toc-ref">doctoc serialization utilities</dd>
+ <dt class="toc-ref"><a href="parse.man">doctools::toc::parse</a></dt>
+ <dd class="toc-ref">Parsing text in doctoc format</dd>
+ <dt class="toc-ref"><a href="introduction.man">doctools::toc::introduction</a></dt>
+ <dd class="toc-ref">DocTools - Tables of Contents</dd>
+ </dl>
+ <!-- - Stop Table Of Contents ---------------------------------- -->
+ <div class="toc-footer">
+ <hr class="toc-navsep">
+ <!-- Customization Point: footer -->
+ </div>
+ </div>
+ </body>
+</html>
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/html-indented/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/html-indented/3_toc
new file mode 100644
index 0000000..1fb5f5a
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/html-indented/3_toc
@@ -0,0 +1,37 @@
+<html>
+ <head>
+ <title>Table of Contents -- TOC</title>
+ <style></style>
+ </head>
+
+ <body>
+ <div class="doctools">
+ <div class="toc-header">
+ <h1 class="toc-title">Table of Contents -- TOC</h1>
+ <!-- Customization Point: header -->
+ <hr class="toc-navsep">
+ </div>
+ <!-- - Start Table Of Contents ---------------------------------- -->
+ <dl class="toc-contents">
+ <dt class="toc-ref"><a href="introduction.man">doctools::toc::introduction</a></dt>
+ <dd class="toc-ref">DocTools - Tables of Contents</dd>
+ <dt class="toc-div"><a href="processing.man">Processing</a></dt>
+ <dd class="toc-div">
+ <!-- - Start Division (Processing) ------------------------------ -->
+ <dl class="toc-contents">
+ <dt class="toc-ref"><a href="structure.man">doctools::toc::structure</a></dt>
+ <dd class="toc-ref">doctoc serialization utilities</dd>
+ <dt class="toc-ref"><a href="parse.man">doctools::toc::parse</a></dt>
+ <dd class="toc-ref">Parsing text in doctoc format</dd>
+ </dl>
+ <!-- - Stop Division (Processing) ------------------------------ -->
+ </dd>
+ </dl>
+ <!-- - Stop Table Of Contents ---------------------------------- -->
+ <div class="toc-footer">
+ <hr class="toc-navsep">
+ <!-- Customization Point: footer -->
+ </div>
+ </div>
+ </body>
+</html>
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/html-indented/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/html-indented/4_toc2
new file mode 100644
index 0000000..85f664d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/html-indented/4_toc2
@@ -0,0 +1,37 @@
+<html>
+ <head>
+ <title>Table of Contents -- TOC</title>
+ <style></style>
+ </head>
+
+ <body>
+ <div class="doctools">
+ <div class="toc-header">
+ <h1 class="toc-title">Table of Contents -- TOC</h1>
+ <!-- Customization Point: header -->
+ <hr class="toc-navsep">
+ </div>
+ <!-- - Start Table Of Contents ---------------------------------- -->
+ <dl class="toc-contents">
+ <dt class="toc-ref"><a href="introduction.man">doctools::toc::introduction</a></dt>
+ <dd class="toc-ref">DocTools - Tables of Contents</dd>
+ <dt class="toc-div"><a href="processing.man">Processing</a></dt>
+ <dd class="toc-div">
+ <!-- - Start Division (Processing) ------------------------------ -->
+ <dl class="toc-contents">
+ <dt class="toc-ref"><a href="parse.man">doctools::toc::parse</a></dt>
+ <dd class="toc-ref">Parsing text in doctoc format</dd>
+ </dl>
+ <!-- - Stop Division (Processing) ------------------------------ -->
+ </dd>
+ <dt class="toc-ref"><a href="structure.man">doctools::toc::structure</a></dt>
+ <dd class="toc-ref">doctoc serialization utilities</dd>
+ </dl>
+ <!-- - Stop Table Of Contents ---------------------------------- -->
+ <div class="toc-footer">
+ <hr class="toc-navsep">
+ <!-- Customization Point: footer -->
+ </div>
+ </div>
+ </body>
+</html>
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/1_empty
new file mode 100644
index 0000000..14aa774
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/1_empty
@@ -0,0 +1 @@
+<html><head><title>TOC -- TOC</title><style></style></head><body><div class="doctools"><div class="toc-header"><h1 class="toc-title">TOC -- TOC</h1><hr class="toc-navsep"></div><div class="toc-footer"><hr class="toc-navsep"></div></div></body></html>
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/2_references b/tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/2_references
new file mode 100644
index 0000000..f6d5312
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/2_references
@@ -0,0 +1 @@
+<html><head><title>Table of Contents</title><style></style></head><body><div class="doctools"><div class="toc-header"><h1 class="toc-title">Table of Contents</h1><hr class="toc-navsep"></div><dl class="toc-contents"><dt class="toc-ref"><a href="structure.man">doctools::toc::structure</a></dt><dd class="toc-ref">doctoc serialization utilities</dd><dt class="toc-ref"><a href="parse.man">doctools::toc::parse</a></dt><dd class="toc-ref">Parsing text in doctoc format</dd><dt class="toc-ref"><a href="introduction.man">doctools::toc::introduction</a></dt><dd class="toc-ref">DocTools - Tables of Contents</dd></dl><div class="toc-footer"><hr class="toc-navsep"></div></div></body></html>
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/3_toc
new file mode 100644
index 0000000..3e9828d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/3_toc
@@ -0,0 +1 @@
+<html><head><title>Table of Contents -- TOC</title><style></style></head><body><div class="doctools"><div class="toc-header"><h1 class="toc-title">Table of Contents -- TOC</h1><hr class="toc-navsep"></div><dl class="toc-contents"><dt class="toc-ref"><a href="introduction.man">doctools::toc::introduction</a></dt><dd class="toc-ref">DocTools - Tables of Contents</dd><dt class="toc-div"><a href="processing.man">Processing</a></dt><dd class="toc-div"><dl class="toc-contents"><dt class="toc-ref"><a href="structure.man">doctools::toc::structure</a></dt><dd class="toc-ref">doctoc serialization utilities</dd><dt class="toc-ref"><a href="parse.man">doctools::toc::parse</a></dt><dd class="toc-ref">Parsing text in doctoc format</dd></dl></dd></dl><div class="toc-footer"><hr class="toc-navsep"></div></div></body></html>
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/4_toc2
new file mode 100644
index 0000000..04f4c39
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/html-ultracompact/4_toc2
@@ -0,0 +1 @@
+<html><head><title>Table of Contents -- TOC</title><style></style></head><body><div class="doctools"><div class="toc-header"><h1 class="toc-title">Table of Contents -- TOC</h1><hr class="toc-navsep"></div><dl class="toc-contents"><dt class="toc-ref"><a href="introduction.man">doctools::toc::introduction</a></dt><dd class="toc-ref">DocTools - Tables of Contents</dd><dt class="toc-div"><a href="processing.man">Processing</a></dt><dd class="toc-div"><dl class="toc-contents"><dt class="toc-ref"><a href="parse.man">doctools::toc::parse</a></dt><dd class="toc-ref">Parsing text in doctoc format</dd></dl></dd><dt class="toc-ref"><a href="structure.man">doctools::toc::structure</a></dt><dd class="toc-ref">doctoc serialization utilities</dd></dl><div class="toc-footer"><hr class="toc-navsep"></div></div></body></html> \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json-indalign/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/json-indalign/1_empty
new file mode 100644
index 0000000..766b40c
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json-indalign/1_empty
@@ -0,0 +1,7 @@
+{
+ "doctools::toc" : {
+ "items" : [],
+ "label" : "TOC",
+ "title" : "TOC"
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json-indalign/2_references b/tcllib/modules/doctools2toc/tests/data/ok/json-indalign/2_references
new file mode 100644
index 0000000..19ab697
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json-indalign/2_references
@@ -0,0 +1,25 @@
+{
+ "doctools::toc" : {
+ "items" : [{
+ "reference" : {
+ "desc" : "doctoc serialization utilities",
+ "id" : "structure.man",
+ "label" : "doctools::toc::structure"
+ }
+ },{
+ "reference" : {
+ "desc" : "Parsing text in doctoc format",
+ "id" : "parse.man",
+ "label" : "doctools::toc::parse"
+ }
+ },{
+ "reference" : {
+ "desc" : "DocTools - Tables of Contents",
+ "id" : "introduction.man",
+ "label" : "doctools::toc::introduction"
+ }
+ }],
+ "label" : "Table of Contents",
+ "title" : ""
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json-indalign/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/json-indalign/3_toc
new file mode 100644
index 0000000..3ad6339
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json-indalign/3_toc
@@ -0,0 +1,31 @@
+{
+ "doctools::toc" : {
+ "items" : [{
+ "reference" : {
+ "desc" : "DocTools - Tables of Contents",
+ "id" : "introduction.man",
+ "label" : "doctools::toc::introduction"
+ }
+ },{
+ "division" : {
+ "id" : "processing.man",
+ "items" : [{
+ "reference" : {
+ "desc" : "doctoc serialization utilities",
+ "id" : "structure.man",
+ "label" : "doctools::toc::structure"
+ }
+ },{
+ "reference" : {
+ "desc" : "Parsing text in doctoc format",
+ "id" : "parse.man",
+ "label" : "doctools::toc::parse"
+ }
+ }],
+ "label" : "Processing"
+ }
+ }],
+ "label" : "Table of Contents",
+ "title" : "TOC"
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json-indalign/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/json-indalign/4_toc2
new file mode 100644
index 0000000..8779d95
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json-indalign/4_toc2
@@ -0,0 +1,31 @@
+{
+ "doctools::toc" : {
+ "items" : [{
+ "reference" : {
+ "desc" : "DocTools - Tables of Contents",
+ "id" : "introduction.man",
+ "label" : "doctools::toc::introduction"
+ }
+ },{
+ "division" : {
+ "id" : "processing.man",
+ "items" : [{
+ "reference" : {
+ "desc" : "Parsing text in doctoc format",
+ "id" : "parse.man",
+ "label" : "doctools::toc::parse"
+ }
+ }],
+ "label" : "Processing"
+ }
+ },{
+ "reference" : {
+ "desc" : "doctoc serialization utilities",
+ "id" : "structure.man",
+ "label" : "doctools::toc::structure"
+ }
+ }],
+ "label" : "Table of Contents",
+ "title" : "TOC"
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json-indented/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/json-indented/1_empty
new file mode 100644
index 0000000..766b40c
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json-indented/1_empty
@@ -0,0 +1,7 @@
+{
+ "doctools::toc" : {
+ "items" : [],
+ "label" : "TOC",
+ "title" : "TOC"
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json-indented/2_references b/tcllib/modules/doctools2toc/tests/data/ok/json-indented/2_references
new file mode 100644
index 0000000..c3adb97
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json-indented/2_references
@@ -0,0 +1,25 @@
+{
+ "doctools::toc" : {
+ "items" : [{
+ "reference" : {
+ "desc" : "doctoc serialization utilities",
+ "id" : "structure.man",
+ "label" : "doctools::toc::structure"
+ }
+ },{
+ "reference" : {
+ "desc" : "Parsing text in doctoc format",
+ "id" : "parse.man",
+ "label" : "doctools::toc::parse"
+ }
+ },{
+ "reference" : {
+ "desc" : "DocTools - Tables of Contents",
+ "id" : "introduction.man",
+ "label" : "doctools::toc::introduction"
+ }
+ }],
+ "label" : "Table of Contents",
+ "title" : ""
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json-indented/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/json-indented/3_toc
new file mode 100644
index 0000000..2364953
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json-indented/3_toc
@@ -0,0 +1,31 @@
+{
+ "doctools::toc" : {
+ "items" : [{
+ "reference" : {
+ "desc" : "DocTools - Tables of Contents",
+ "id" : "introduction.man",
+ "label" : "doctools::toc::introduction"
+ }
+ },{
+ "division" : {
+ "id" : "processing.man",
+ "items" : [{
+ "reference" : {
+ "desc" : "doctoc serialization utilities",
+ "id" : "structure.man",
+ "label" : "doctools::toc::structure"
+ }
+ },{
+ "reference" : {
+ "desc" : "Parsing text in doctoc format",
+ "id" : "parse.man",
+ "label" : "doctools::toc::parse"
+ }
+ }],
+ "label" : "Processing"
+ }
+ }],
+ "label" : "Table of Contents",
+ "title" : "TOC"
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json-indented/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/json-indented/4_toc2
new file mode 100644
index 0000000..958bf12
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json-indented/4_toc2
@@ -0,0 +1,31 @@
+{
+ "doctools::toc" : {
+ "items" : [{
+ "reference" : {
+ "desc" : "DocTools - Tables of Contents",
+ "id" : "introduction.man",
+ "label" : "doctools::toc::introduction"
+ }
+ },{
+ "division" : {
+ "id" : "processing.man",
+ "items" : [{
+ "reference" : {
+ "desc" : "Parsing text in doctoc format",
+ "id" : "parse.man",
+ "label" : "doctools::toc::parse"
+ }
+ }],
+ "label" : "Processing"
+ }
+ },{
+ "reference" : {
+ "desc" : "doctoc serialization utilities",
+ "id" : "structure.man",
+ "label" : "doctools::toc::structure"
+ }
+ }],
+ "label" : "Table of Contents",
+ "title" : "TOC"
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/1_empty
new file mode 100644
index 0000000..3b4e072
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/1_empty
@@ -0,0 +1 @@
+{"doctools::toc":{"items":[],"label":"TOC","title":"TOC"}}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/2_references b/tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/2_references
new file mode 100644
index 0000000..304256f
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/2_references
@@ -0,0 +1 @@
+{"doctools::toc":{"items":[{"reference":{"desc":"doctoc serialization utilities","id":"structure.man","label":"doctools::toc::structure"}},{"reference":{"desc":"Parsing text in doctoc format","id":"parse.man","label":"doctools::toc::parse"}},{"reference":{"desc":"DocTools - Tables of Contents","id":"introduction.man","label":"doctools::toc::introduction"}}],"label":"Table of Contents","title":""}}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/3_toc
new file mode 100644
index 0000000..d40b45d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/3_toc
@@ -0,0 +1 @@
+{"doctools::toc":{"items":[{"reference":{"desc":"DocTools - Tables of Contents","id":"introduction.man","label":"doctools::toc::introduction"}},{"division":{"id":"processing.man","items":[{"reference":{"desc":"doctoc serialization utilities","id":"structure.man","label":"doctools::toc::structure"}},{"reference":{"desc":"Parsing text in doctoc format","id":"parse.man","label":"doctools::toc::parse"}}],"label":"Processing"}}],"label":"Table of Contents","title":"TOC"}}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/4_toc2
new file mode 100644
index 0000000..d130f98
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json-ultracompact/4_toc2
@@ -0,0 +1 @@
+{"doctools::toc":{"items":[{"reference":{"desc":"DocTools - Tables of Contents","id":"introduction.man","label":"doctools::toc::introduction"}},{"division":{"id":"processing.man","items":[{"reference":{"desc":"Parsing text in doctoc format","id":"parse.man","label":"doctools::toc::parse"}}],"label":"Processing"}},{"reference":{"desc":"doctoc serialization utilities","id":"structure.man","label":"doctools::toc::structure"}}],"label":"Table of Contents","title":"TOC"}} \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/json/1_empty
new file mode 100644
index 0000000..5f852ac
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json/1_empty
@@ -0,0 +1,7 @@
+{
+ "doctools::toc" : {
+ "label" : "TOC",
+ "title" : "TOC",
+ "items" : []
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json/2_references b/tcllib/modules/doctools2toc/tests/data/ok/json/2_references
new file mode 100644
index 0000000..8e7510e
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json/2_references
@@ -0,0 +1,25 @@
+{
+ "doctools::toc" : {
+ "title" : "",
+ "items" : [{
+ "reference" : {
+ "id" : "structure.man",
+ "desc" : "doctoc serialization utilities",
+ "label" : "doctools::toc::structure"
+ }
+ },{
+ "reference" : {
+ "id" : "parse.man",
+ "desc" : "Parsing text in doctoc format",
+ "label" : "doctools::toc::parse"
+ }
+ },{
+ "reference" : {
+ "label" : "doctools::toc::introduction",
+ "desc" : "DocTools - Tables of Contents",
+ "id" : "introduction.man"
+ }
+ }],
+ "label" : "Table of Contents"
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/json/3_toc
new file mode 100644
index 0000000..925a932
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json/3_toc
@@ -0,0 +1,31 @@
+{
+ "doctools::toc" : {
+ "label" : "Table of Contents",
+ "items" : [{
+ "reference" : {
+ "label" : "doctools::toc::introduction",
+ "desc" : "DocTools - Tables of Contents",
+ "id" : "introduction.man"
+ }
+ },{
+ "division" : {
+ "items" : [{
+ "reference" : {
+ "id" : "structure.man",
+ "desc" : "doctoc serialization utilities",
+ "label" : "doctools::toc::structure"
+ }
+ },{
+ "reference" : {
+ "label" : "doctools::toc::parse",
+ "desc" : "Parsing text in doctoc format",
+ "id" : "parse.man"
+ }
+ }],
+ "label" : "Processing",
+ "id" : "processing.man"
+ }
+ }],
+ "title" : "TOC"
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/json/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/json/4_toc2
new file mode 100644
index 0000000..55ff761
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/json/4_toc2
@@ -0,0 +1,31 @@
+{
+ "doctools::toc" : {
+ "label" : "Table of Contents",
+ "items" : [{
+ "reference" : {
+ "label" : "doctools::toc::introduction",
+ "desc" : "DocTools - Tables of Contents",
+ "id" : "introduction.man"
+ }
+ },{
+ "division" : {
+ "items" : [{
+ "reference" : {
+ "label" : "doctools::toc::parse",
+ "desc" : "Parsing text in doctoc format",
+ "id" : "parse.man"
+ }
+ }],
+ "label" : "Processing",
+ "id" : "processing.man"
+ }
+ },{
+ "reference" : {
+ "id" : "structure.man",
+ "desc" : "doctoc serialization utilities",
+ "label" : "doctools::toc::structure"
+ }
+ }],
+ "title" : "TOC"
+ }
+}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/nroff-external/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/nroff-external/1_empty
new file mode 100644
index 0000000..1c01c52
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/nroff-external/1_empty
@@ -0,0 +1,4 @@
+.so man.macros
+.TH TOC
+.SH "TABLE OF CONTENTS"
+TOC
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/nroff-external/2_references b/tcllib/modules/doctools2toc/tests/data/ok/nroff-external/2_references
new file mode 100644
index 0000000..23285cf
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/nroff-external/2_references
@@ -0,0 +1,14 @@
+.so man.macros
+.TH "TABLE OF CONTENTS"
+.SH "TABLE OF CONTENTS"
+.RS
+.TP
+\fBdoctools::toc::structure\fR
+doctoc serialization utilities
+.TP
+\fBdoctools::toc::parse\fR
+Parsing text in doctoc format
+.TP
+\fBdoctools::toc::introduction\fR
+DocTools - Tables of Contents
+.RE
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/nroff-external/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/nroff-external/3_toc
new file mode 100644
index 0000000..b738407
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/nroff-external/3_toc
@@ -0,0 +1,19 @@
+.so man.macros
+.TH "TABLE OF CONTENTS"
+.SH "TABLE OF CONTENTS"
+TOC
+.RS
+.TP
+\fBdoctools::toc::introduction\fR
+DocTools - Tables of Contents
+.TP
+\fBProcessing\fR
+.RS
+.TP
+\fBdoctools::toc::structure\fR
+doctoc serialization utilities
+.TP
+\fBdoctools::toc::parse\fR
+Parsing text in doctoc format
+.RE
+.RE
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/nroff-external/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/nroff-external/4_toc2
new file mode 100644
index 0000000..4df0548
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/nroff-external/4_toc2
@@ -0,0 +1,19 @@
+.so man.macros
+.TH "TABLE OF CONTENTS"
+.SH "TABLE OF CONTENTS"
+TOC
+.RS
+.TP
+\fBdoctools::toc::introduction\fR
+DocTools - Tables of Contents
+.TP
+\fBProcessing\fR
+.RS
+.TP
+\fBdoctools::toc::parse\fR
+Parsing text in doctoc format
+.RE
+.TP
+\fBdoctools::toc::structure\fR
+doctoc serialization utilities
+.RE
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/1_empty
new file mode 100644
index 0000000..668c866
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/1_empty
@@ -0,0 +1,3 @@
+.TH TOC
+.SH "TABLE OF CONTENTS"
+TOC
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/2_references b/tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/2_references
new file mode 100644
index 0000000..7a55c89
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/2_references
@@ -0,0 +1,13 @@
+.TH "TABLE OF CONTENTS"
+.SH "TABLE OF CONTENTS"
+.RS
+.TP
+\fBdoctools::toc::structure\fR
+doctoc serialization utilities
+.TP
+\fBdoctools::toc::parse\fR
+Parsing text in doctoc format
+.TP
+\fBdoctools::toc::introduction\fR
+DocTools - Tables of Contents
+.RE
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/3_toc
new file mode 100644
index 0000000..b4cc5f8
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/3_toc
@@ -0,0 +1,18 @@
+.TH "TABLE OF CONTENTS"
+.SH "TABLE OF CONTENTS"
+TOC
+.RS
+.TP
+\fBdoctools::toc::introduction\fR
+DocTools - Tables of Contents
+.TP
+\fBProcessing\fR
+.RS
+.TP
+\fBdoctools::toc::structure\fR
+doctoc serialization utilities
+.TP
+\fBdoctools::toc::parse\fR
+Parsing text in doctoc format
+.RE
+.RE
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/4_toc2
new file mode 100644
index 0000000..6a470f7
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/nroff-inlined/4_toc2
@@ -0,0 +1,18 @@
+.TH "TABLE OF CONTENTS"
+.SH "TABLE OF CONTENTS"
+TOC
+.RS
+.TP
+\fBdoctools::toc::introduction\fR
+DocTools - Tables of Contents
+.TP
+\fBProcessing\fR
+.RS
+.TP
+\fBdoctools::toc::parse\fR
+Parsing text in doctoc format
+.RE
+.TP
+\fBdoctools::toc::structure\fR
+doctoc serialization utilities
+.RE
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/serial-print/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/serial-print/1_empty
new file mode 100644
index 0000000..31ec2ff
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/serial-print/1_empty
@@ -0,0 +1 @@
+doctools::toc TOC TOC
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/serial-print/2_references b/tcllib/modules/doctools2toc/tests/data/ok/serial-print/2_references
new file mode 100644
index 0000000..f80e088
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/serial-print/2_references
@@ -0,0 +1,4 @@
+doctools::toc {Table of Contents} {}
+....structure.man doctools::toc::structure {doctoc serialization utilities}
+....parse.man doctools::toc::parse {Parsing text in doctoc format}
+....introduction.man doctools::toc::introduction {DocTools - Tables of Contents}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/serial-print/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/serial-print/3_toc
new file mode 100644
index 0000000..032b764
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/serial-print/3_toc
@@ -0,0 +1,5 @@
+doctools::toc {Table of Contents} TOC
+....introduction.man doctools::toc::introduction {DocTools - Tables of Contents}
+....processing.man Processing
+........structure.man doctools::toc::structure {doctoc serialization utilities}
+........parse.man doctools::toc::parse {Parsing text in doctoc format}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/serial-print/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/serial-print/4_toc2
new file mode 100644
index 0000000..b493406
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/serial-print/4_toc2
@@ -0,0 +1,5 @@
+doctools::toc {Table of Contents} TOC
+....introduction.man doctools::toc::introduction {DocTools - Tables of Contents}
+....processing.man Processing
+........parse.man doctools::toc::parse {Parsing text in doctoc format}
+....structure.man doctools::toc::structure {doctoc serialization utilities}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/serial/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/serial/1_empty
new file mode 100644
index 0000000..0b06b3d
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/serial/1_empty
@@ -0,0 +1 @@
+doctools::toc {items {} label TOC title TOC}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/serial/2_references b/tcllib/modules/doctools2toc/tests/data/ok/serial/2_references
new file mode 100644
index 0000000..3ef0355
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/serial/2_references
@@ -0,0 +1 @@
+doctools::toc {items {{reference {desc {doctoc serialization utilities} id structure.man label doctools::toc::structure}} {reference {desc {Parsing text in doctoc format} id parse.man label doctools::toc::parse}} {reference {desc {DocTools - Tables of Contents} id introduction.man label doctools::toc::introduction}}} label {Table of Contents} title {}}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/serial/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/serial/3_toc
new file mode 100644
index 0000000..796d1c2
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/serial/3_toc
@@ -0,0 +1,2 @@
+doctools::toc {items {{reference {desc {DocTools - Tables of Contents} id introduction.man label doctools::toc::introduction}} {division {id processing.man items {{reference {desc {doctoc serialization utilities} id structure.man label doctools::toc::structure}} {reference {desc {Parsing text in doctoc format} id parse.man label doctools::toc::parse}}} label Processing}}} label {Table of Contents} title TOC}
+
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/serial/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/serial/4_toc2
new file mode 100644
index 0000000..1d9c2d1
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/serial/4_toc2
@@ -0,0 +1 @@
+doctools::toc {items {{reference {desc {DocTools - Tables of Contents} id introduction.man label doctools::toc::introduction}} {division {id processing.man items {{reference {desc {Parsing text in doctoc format} id parse.man label doctools::toc::parse}}} label Processing}} {reference {desc {doctoc serialization utilities} id structure.man label doctools::toc::structure}}} label {Table of Contents} title TOC}
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/text/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/text/1_empty
new file mode 100644
index 0000000..954d944
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/text/1_empty
@@ -0,0 +1,2 @@
+TOC -- TOC
+==========
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/text/2_references b/tcllib/modules/doctools2toc/tests/data/ok/text/2_references
new file mode 100644
index 0000000..539c8e8
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/text/2_references
@@ -0,0 +1,11 @@
+Table of Contents
+=================
+
+structure.man : doctools::toc::structure
+ doctoc serialization utilities
+
+parse.man : doctools::toc::parse
+ Parsing text in doctoc format
+
+introduction.man : doctools::toc::introduction
+ DocTools - Tables of Contents
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/text/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/text/3_toc
new file mode 100644
index 0000000..452f02f
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/text/3_toc
@@ -0,0 +1,14 @@
+Table of Contents -- TOC
+========================
+
+introduction.man : doctools::toc::introduction
+ DocTools - Tables of Contents
+
+processing.man : Processing
+---------------------------
+
+ structure.man : doctools::toc::structure
+ doctoc serialization utilities
+
+ parse.man : doctools::toc::parse
+ Parsing text in doctoc format
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/text/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/text/4_toc2
new file mode 100644
index 0000000..dbcd94b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/text/4_toc2
@@ -0,0 +1,15 @@
+Table of Contents -- TOC
+========================
+
+introduction.man : doctools::toc::introduction
+ DocTools - Tables of Contents
+
+processing.man : Processing
+---------------------------
+
+ parse.man : doctools::toc::parse
+ Parsing text in doctoc format
+
+
+structure.man : doctools::toc::structure
+ doctoc serialization utilities
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/wiki/1_empty b/tcllib/modules/doctools2toc/tests/data/ok/wiki/1_empty
new file mode 100644
index 0000000..7de7984
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/wiki/1_empty
@@ -0,0 +1 @@
+**TOC -- TOC**
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/wiki/2_references b/tcllib/modules/doctools2toc/tests/data/ok/wiki/2_references
new file mode 100644
index 0000000..867aec8
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/wiki/2_references
@@ -0,0 +1,5 @@
+**Table of Contents**
+
+ * [structure.man%|%doctools::toc::structure] : doctoc serialization utilities
+ * [parse.man%|%doctools::toc::parse] : Parsing text in doctoc format
+ * [introduction.man%|%doctools::toc::introduction] : DocTools - Tables of Contents
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/wiki/3_toc b/tcllib/modules/doctools2toc/tests/data/ok/wiki/3_toc
new file mode 100644
index 0000000..6cde073
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/wiki/3_toc
@@ -0,0 +1,6 @@
+**Table of Contents -- TOC**
+
+ * [introduction.man%|%doctools::toc::introduction] : DocTools - Tables of Contents
+ * [processing.man%|%Processing]
+ ** [structure.man%|%doctools::toc::structure] : doctoc serialization utilities
+ ** [parse.man%|%doctools::toc::parse] : Parsing text in doctoc format
diff --git a/tcllib/modules/doctools2toc/tests/data/ok/wiki/4_toc2 b/tcllib/modules/doctools2toc/tests/data/ok/wiki/4_toc2
new file mode 100644
index 0000000..95976c6
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/ok/wiki/4_toc2
@@ -0,0 +1,6 @@
+**Table of Contents -- TOC**
+
+ * [introduction.man%|%doctools::toc::introduction] : DocTools - Tables of Contents
+ * [processing.man%|%Processing]
+ ** [parse.man%|%doctools::toc::parse] : Parsing text in doctoc format
+ * [structure.man%|%doctools::toc::structure] : doctoc serialization utilities
diff --git a/tcllib/modules/doctools2toc/tests/data/unexpected_char b/tcllib/modules/doctools2toc/tests/data/unexpected_char
new file mode 100644
index 0000000..9420cbd
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/unexpected_char
@@ -0,0 +1,2 @@
+[bad syntax in include file
+2]
diff --git a/tcllib/modules/doctools2toc/tests/data/unexpected_eof b/tcllib/modules/doctools2toc/tests/data/unexpected_eof
new file mode 100644
index 0000000..b56316c
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/data/unexpected_eof
@@ -0,0 +1 @@
+[bad syntax in include file \ No newline at end of file
diff --git a/tcllib/modules/doctools2toc/tests/export b/tcllib/modules/doctools2toc/tests/export
new file mode 100644
index 0000000..fee8c83
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/export
@@ -0,0 +1,147 @@
+# -*- tcl -*-
+# toc_export.testsuite: Tests for the management of toc export plugins.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: export,v 1.2 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+# Tests are run for all formats we have an export plugin for.
+
+# -------------------------------------------------------------------------
+
+set mytestdir tests/data
+set mytestconfig {fox dog lazy jump}
+set mytestincludes [TestFilesGlob $mytestdir]
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# doctoc markup
+
+# Testing the export of doctoc markup through an exporter manager, for
+# all possible configurations.
+
+foreach {k nl in al section} {
+ 0 0 0 0 -ultracompact
+ 1 1 0 0 -compact
+ 2 1 1 0 -indented
+ 3 1 0 1 -aligned
+ 4 1 1 1 -indalign
+ 5 0 1 0 -indented
+ 6 0 0 1 -aligned
+ 7 0 1 1 -indalign
+} {
+ TestFilesProcess $mytestdir ok serial doctoc$section -> n label input data expected {
+ test doctools-toc-export-plugin-doctoc-20.$k.$n "doctools::toc::export /doctoc, $label$section, ok" -setup {
+ doctools::toc::export OUT
+ OUT config set newlines $nl
+ OUT config set indented $in
+ OUT config set aligned $al
+ } -body {
+ stripcomments [OUT export serial $data doctoc]
+ } -cleanup {
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# text markup
+
+TestFilesProcess $mytestdir ok serial text -> n label input data expected {
+ test doctools-toc-export-plugin-text-21.$n "doctools::toc::export /text, $label, ok" -setup {
+ doctools::toc::export OUT
+ } -body {
+ OUT export serial $data text
+ } -cleanup {
+ OUT destroy
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# json markup
+
+foreach {k in al section} {
+ 0 0 0 -ultracompact
+ 1 1 0 -indented
+ 2 0 1 -indalign
+ 3 1 1 -indalign
+} {
+ TestFilesProcess $mytestdir ok serial json$section -> n label input data expected {
+ test doctools-toc-export-plugin-json-22.$k.$n "doctools::toc::export /json, $label$section, ok" -setup {
+ doctools::toc::export OUT
+ OUT config set indented $in
+ OUT config set aligned $al
+ } -body {
+ OUT export serial $data json
+ } -cleanup {
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# html markup
+
+foreach {k nl in section} {
+ 0 0 0 -ultracompact
+ 1 0 1 -indented
+ 2 1 0 -compact
+ 3 1 1 -indented
+} {
+ TestFilesProcess $mytestdir ok serial html$section -> n label input data expected {
+ test doctools-toc-export-plugin-html-23.$k.$n "doctools::toc::export /html, $label$section, ok" -setup {
+ doctools::toc::export OUT
+ OUT config set newlines $nl
+ OUT config set indented $in
+ OUT config set user _dummy_
+ } -body {
+ striphtmlcomments [OUT export serial $data html] 3
+ } -cleanup {
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# wiki markup
+
+TestFilesProcess $mytestdir ok serial wiki -> n label input data expected {
+ test doctools-toc-export-plugin-wiki-23.$n "doctools::toc::export /wiki, $label, ok" -setup {
+ doctools::toc::export OUT
+ } -body {
+ OUT export serial $data wiki
+ } -cleanup {
+ OUT destroy
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# nroff markup
+
+foreach {k inline section} {
+ 0 0 -external
+ 1 1 -inlined
+} {
+ TestFilesProcess $mytestdir ok serial nroff$section -> n label input data expected {
+ test doctools-toc-export-plugin-nroff-24.$k.$n "doctools::toc::export /nroff, $label$section, ok" -setup {
+ doctools::toc::export OUT
+ OUT config set inline $inline
+ } -body {
+ stripnroffcomments [stripmanmacros [OUT export serial $data nroff]]
+ } -cleanup {
+ OUT destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+unset mytestdir n label input data expected
+return
diff --git a/tcllib/modules/doctools2toc/tests/export_doctoc b/tcllib/modules/doctools2toc/tests/export_doctoc
new file mode 100644
index 0000000..aab471b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/export_doctoc
@@ -0,0 +1,5 @@
+# -*- tcl -*-
+# This file is not required as the .test file already does all the
+# tests without the need for an additional sourced control file.
+# We have it here just as a reminder.
+return
diff --git a/tcllib/modules/doctools2toc/tests/export_text b/tcllib/modules/doctools2toc/tests/export_text
new file mode 100644
index 0000000..aab471b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/export_text
@@ -0,0 +1,5 @@
+# -*- tcl -*-
+# This file is not required as the .test file already does all the
+# tests without the need for an additional sourced control file.
+# We have it here just as a reminder.
+return
diff --git a/tcllib/modules/doctools2toc/tests/import b/tcllib/modules/doctools2toc/tests/import
new file mode 100644
index 0000000..feacfac
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/import
@@ -0,0 +1,174 @@
+# -*- tcl -*-
+# toc_import.testsuite: Tests for the management of toc import plugins.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: import,v 1.2 2009/11/15 05:50:03 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+# Tests are run for all formats we have an import plugin for.
+
+# -------------------------------------------------------------------------
+
+set mytestdir tests/data
+set mytestconfig {fox dog lazy jump}
+set mytestincludes [TestFilesGlob $mytestdir]
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# doctoc markup
+
+# We are checking that the various forms of doctoc markup, as can be
+# generated by doctools::toc(::format::doctoc) are valid input to the
+# doctoc parser.
+
+foreach {k section} {
+ 0 {}
+ 1 -ultracompact
+ 2 -compact
+ 3 -indented
+ 4 -aligned
+ 5 -indalign
+} {
+ TestFilesProcess $mytestdir ok doctoc$section serial-print -> n label input data expected {
+ test doctools-toc-import-plugin-doctoc-20.$k.$n "doctools::toc::import text /doctoc, $label$section, ok" -setup {
+ doctools::toc::import I
+ foreach {n v} $mytestconfig { I config set $n $v }
+ foreach p $mytestincludes { I include add $p }
+ } -body {
+ doctools::toc::structure print [I import text $data doctoc]
+ } -cleanup {
+ I destroy
+ } -result $expected
+ }
+
+ TestFilesProcess $mytestdir ok doctoc$section serial-print -> n label input data expected {
+ test doctools-toc-import-plugin-doctoc-21.$k.$n "doctools::toc::import file /doctoc, $label$section, ok" -setup {
+ doctools::toc::import I
+ foreach {n v} $mytestconfig { I config set $n $v }
+ foreach p $mytestincludes { I include add $p }
+ } -body {
+ doctools::toc::structure print [I import file $input doctoc]
+ } -cleanup {
+ I destroy
+ } -result $expected
+ }
+}
+
+# We test the error messages and codes thrown by the parser for a
+# variety of failure possibilities.
+
+TestFilesProcess $mytestdir fail doctoc emsg -> n label input data expected {
+ test doctools-toc-import-plugin-doctoc-22.$n "doctools::toc::import text /doctoc, $label, error message" -setup {
+ doctools::toc::import I
+ foreach {n v} $mytestconfig { I config set $n $v }
+ foreach p $mytestincludes { I include add $p }
+ } -body {
+ I import text $data doctoc
+ } -cleanup {
+ I destroy
+ } -returnCodes error -result $expected
+}
+
+TestFilesProcess $mytestdir fail doctoc ecode -> n label input data expected {
+ test doctools-toc-import-plugin-doctoc-23.$n "doctools::toc::import text /doctoc, $label, error code" -setup {
+ doctools::toc::import I
+ foreach {n v} $mytestconfig { I config set $n $v }
+ foreach p $mytestincludes { I include add $p }
+ } -body {
+ # Catch and rethrow using the error code as new message.
+ catch { I import text $data doctoc }
+ set ::errorCode
+ } -cleanup {
+ I destroy
+ } -result $expected
+}
+
+TestFilesProcess $mytestdir fail doctoc emsg -> n label input data expected {
+ test doctools-toc-import-plugin-doctoc-24.$n "doctools::toc::import file /doctoc, $label, error message" -setup {
+ doctools::toc::import I
+ foreach {n v} $mytestconfig { I config set $n $v }
+ foreach p $mytestincludes { I include add $p }
+ } -body {
+ I import file $input doctoc
+ } -cleanup {
+ I destroy
+ } -returnCodes error -result $expected
+}
+
+TestFilesProcess $mytestdir fail doctoc ecode -> n label input data expected {
+ test doctools-toc-import-plugin-doctoc-25.$n "doctools::toc::import file /doctoc, $label, error code" -setup {
+ doctools::toc::import I
+ foreach {n v} $mytestconfig { I config set $n $v }
+ foreach p $mytestincludes { I include add $p }
+ } -body {
+ # Catch and rethrow using the error code as new message.
+ catch { I import file $input doctoc }
+ set ::errorCode
+ } -cleanup {
+ I destroy
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# text markup - This is not an importable format.
+
+# -------------------------------------------------------------------------
+# -------------------------------------------------------------------------
+# json - Java Script Object Notation
+
+# We are checking that the various forms of json markup, as can be
+# generated by doctools::toc(::export(::json)) are valid input to the
+# json parser.
+#
+# section {} holds the non-canonical input we have to accept and make
+# canonical to higher layers.
+
+foreach {k section} {
+ 0 {}
+ 1 -ultracompact
+ 2 -indented
+ 3 -indalign
+} {
+ TestFilesProcess $mytestdir ok json$section serial-print -> n label input data expected {
+ test doctools-toc-import-plugin-json-26.$k.$n "doctools::toc::import text /json, $label$section, ok" -setup {
+ doctools::toc::import I
+ } -body {
+ doctools::toc::structure print [I import text $data json]
+ } -cleanup {
+ I destroy
+ } -result $expected
+ }
+
+ TestFilesProcess $mytestdir ok json$section serial-print -> n label input data expected {
+ test doctools-toc-import-plugin-json-27.$k.$n "doctools::toc::import file /json, $label$section, ok" -setup {
+ doctools::toc::import I
+ } -body {
+ doctools::toc::structure print [I import file $input json]
+ } -cleanup {
+ I destroy
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# We test the error messages and codes thrown by the parser for a
+# variety of failure possibilities.
+
+TestFilesProcess $mytestdir fail json json-emsg -> n label input data expected {
+ test doctools-toc-import-plugin-json-28.$n "doctools::toc::import text /json, $label, error message" -setup {
+ doctools::toc::import I
+ } -body {
+ I import text $data json
+ } -cleanup {
+ I destroy
+ } -returnCodes error -result $expected
+}
+
+# -------------------------------------------------------------------------
+unset mytestdir n label input data expected
+return
diff --git a/tcllib/modules/doctools2toc/tests/import_doctoc b/tcllib/modules/doctools2toc/tests/import_doctoc
new file mode 100644
index 0000000..056ca67
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/import_doctoc
@@ -0,0 +1,73 @@
+# -*- tcl -*-
+# toc_import_doctoc.testsuite: tests for the doctoc import plugin.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: import_doctoc,v 1.1 2009/04/18 21:14:21 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+set mytestconfig {fox dog lazy jump}
+set mytestincludes [TestFilesGlob $mytestdir]
+
+# -------------------------------------------------------------------------
+
+# We are checking that the various forms of doctoc markup, as can be
+# generated by doctools::toc(::export(::doctoc)) are valid input to
+# the doctoc parser.
+#
+# section {} holds the non-canonical input we have to accept and make
+# canonical to higher layers.
+
+foreach {k section} {
+ 0 {}
+ 1 -ultracompact
+ 2 -compact
+ 3 -indented
+ 4 -aligned
+ 5 -indalign
+} {
+ TestFilesProcess $mytestdir ok doctoc$section serial-print -> n label input data expected {
+ test doctools-toc-import-doctoc-${stkimpl}-${setimpl}-${impl}-2.$k.$n "doctools::toc::import::doctoc, $label$section, ok" -setup {
+ doctools::toc::parse include set $mytestincludes
+ } -body {
+ doctools::toc::structure print [import $data $mytestconfig]
+ } -cleanup {
+ doctools::toc::parse include clear
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# We test the error messages and codes thrown by the parser for a
+# variety of failure possibilities.
+
+TestFilesProcess $mytestdir fail doctoc emsg -> n label input data expected {
+ test doctools-toc-import-doctoc-${stkimpl}-${setimpl}-${impl}-3.$n "doctools::toc::import::doctoc, $label, error message" -setup {
+ doctools::toc::parse include set $mytestincludes
+ } -body {
+ import $data $mytestconfig
+ } -cleanup {
+ doctools::toc::parse include clear
+ } -returnCodes error -result $expected
+}
+
+TestFilesProcess $mytestdir fail doctoc ecode -> n label input data expected {
+ test doctools-toc-import-doctoc-${stkimpl}-${setimpl}-${impl}-4.$n "doctools::toc::import::doctoc, $label, error code" -setup {
+ doctools::toc::parse include set $mytestincludes
+ } -body {
+ # Catch and rethrow using the error code as new message.
+ catch { import $data $mytestconfig }
+ set ::errorCode
+ } -cleanup {
+ doctools::toc::parse include clear
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+unset mytestdir n label input data expected
+return
diff --git a/tcllib/modules/doctools2toc/tests/parse b/tcllib/modules/doctools2toc/tests/parse
new file mode 100644
index 0000000..70f4007
--- /dev/null
+++ b/tcllib/modules/doctools2toc/tests/parse
@@ -0,0 +1,130 @@
+# -*- tcl -*-
+# doctoc_parse.testsuite: tests for the doctoc parser.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: parse,v 1.1 2009/04/18 21:14:21 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [tcllibPath doctools2base/tests/common]
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+# We are checking that the various forms of doctoc markup, as can be
+# generated by doctools::toc::export::doctoc are valid input to the
+# doctoc parser.
+#
+# section {} holds the non-canonical input we have to accept and make
+# canonical to higher layers.
+
+foreach {k section} {
+ 0 {}
+ 1 -ultracompact
+ 2 -compact
+ 3 -indented
+ 4 -aligned
+ 5 -indalign
+} {
+ TestFilesProcess $mytestdir ok doctoc$section serial-print -> n label input data expected {
+ test doctools-toc-parse-${stkimpl}-${setimpl}-${impl}-20.$k.$n "doctools::toc::parse text, $label$section, ok" -setup {
+ # Define a few basic variables and include search paths for
+ # use by the test
+ doctools::toc::parse var load {fox dog lazy jump}
+ doctools::toc::parse include set [TestFilesGlob $mytestdir]
+ } -body {
+ doctools::toc::structure print \
+ [doctools::toc::parse text $data]
+ } -cleanup {
+ doctools::toc::parse include clear
+ doctools::toc::parse var unset *
+ } -result $expected
+ }
+
+ TestFilesProcess $mytestdir ok doctoc$section serial-print -> n label input data expected {
+ test doctools-toc-parse-${stkimpl}-${setimpl}-${impl}-21.$k.$n "doctools::toc::parse file, $label$section, ok" -setup {
+ # Define a few basic variables and include search paths for
+ # use by the test
+ doctools::toc::parse var load {fox dog lazy jump}
+ doctools::toc::parse include set [TestFilesGlob $mytestdir]
+ } -body {
+ doctools::toc::structure print \
+ [doctools::toc::parse file $input]
+ } -cleanup {
+ doctools::toc::parse include clear
+ doctools::toc::parse var unset *
+ } -result $expected
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# We test the error messages and codes thrown by the parser for a
+# variety of failure possibilities.
+
+TestFilesProcess $mytestdir fail doctoc emsg -> n label input data expected {
+ test doctools-toc-parse-${stkimpl}-${setimpl}-${impl}-22.$n "doctools::toc::parse, $label, error message" -setup {
+ # Define a few basic variables and include search paths for
+ # use by the test
+ doctools::toc::parse var load {fox dog lazy jump}
+ doctools::toc::parse include set [TestFilesGlob $mytestdir]
+ } -body {
+ doctools::toc::parse text $data
+ } -cleanup {
+ doctools::toc::parse include clear
+ doctools::toc::parse var unset *
+ } -returnCodes error -result $expected
+}
+
+TestFilesProcess $mytestdir fail doctoc ecode -> n label input data expected {
+ test doctools-toc-parse-${stkimpl}-${setimpl}-${impl}-23.$n "doctools::toc::parse, $label, error code" -setup {
+ # Define a few basic variables and include search paths for
+ # use by the test
+ doctools::toc::parse var load {fox dog lazy jump}
+ doctools::toc::parse include set [TestFilesGlob $mytestdir]
+ } -body {
+ # Catch and rethrow using the error code as new message.
+ catch { doctools::toc::parse text $data }
+ set ::errorCode
+ } -cleanup {
+ doctools::toc::parse include clear
+ doctools::toc::parse var unset *
+ } -result $expected
+}
+
+TestFilesProcess $mytestdir fail doctoc emsg -> n label input data expected {
+ test doctools-toc-parse-${stkimpl}-${setimpl}-${impl}-24.$n "doctools::toc::parse file, $label, error message" -setup {
+ # Define a few basic variables and include search paths for
+ # use by the test
+ doctools::toc::parse var load {fox dog lazy jump}
+ doctools::toc::parse include set [TestFilesGlob $mytestdir]
+ } -body {
+ catch { [doctools::toc::parse file $input] } msg
+ string map [list "\"$input\" " {}] $msg
+ } -cleanup {
+ doctools::toc::parse include clear
+ doctools::toc::parse var unset *
+ } -result $expected
+}
+
+TestFilesProcess $mytestdir fail doctoc ecode -> n label input data expected {
+ test doctools-toc-parse-${stkimpl}-${setimpl}-${impl}-25.$n "doctools::toc::parse file, $label, error code" -setup {
+ # Define a few basic variables and include search paths for
+ # use by the test
+ doctools::toc::parse var load {fox dog lazy jump}
+ doctools::toc::parse include set [TestFilesGlob $mytestdir]
+ } -body {
+ # Catch and rethrow using the error code as new message.
+ catch { doctools::toc::parse file $input }
+ string map [list $input {{}}] $::errorCode
+ } -cleanup {
+ doctools::toc::parse include clear
+ doctools::toc::parse var unset *
+ } -result $expected
+}
+
+# -------------------------------------------------------------------------
+unset mytestdir n label input data expected
+return
diff --git a/tcllib/modules/doctools2toc/toc_container.man b/tcllib/modules/doctools2toc/toc_container.man
new file mode 100644
index 0000000..1cfe961
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_container.man
@@ -0,0 +1,370 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::toc n 2]
+[keywords conversion]
+[keywords {doctoc markup}]
+[keywords documentation]
+[keywords formatting]
+[keywords generation]
+[keywords HTML]
+[keywords json]
+[keywords latex]
+[keywords markup]
+[keywords nroff]
+[keywords parsing]
+[keywords plugin]
+[keywords reference]
+[keywords table]
+[keywords {table of contents}]
+[keywords {tcler's wiki}]
+[keywords text]
+[keywords TMML]
+[keywords wiki]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Holding tables of contents}]
+[category {Documentation tools}]
+[require doctools::toc [opt 2]]
+[require Tcl 8.4]
+[require doctools::toc::structure]
+[require struct::tree]
+[require snit]
+[description]
+
+This package provides a class to contain and programmatically
+manipulate tables of contents.
+
+[para]
+
+This is one of the three public pillars the management of tables of
+contents resides on. The other two pillars are
+
+[list_begin enum]
+[enum] [manpage {Exporting tables of contents}], and
+[enum] [manpage {Importing tables of contents}]
+[list_end]
+
+[para]
+
+For information about the [sectref Concepts] of tables of contents, and
+their parts, see the same-named section.
+
+For information about the data structure which is used to encode
+tables of contents as values see the section
+[sectref {ToC serialization format}].
+
+This is the only format directly known to this class. Conversions from
+and to any other format are handled by export and import manager
+objects. These may be attached to a container, but do not have to be,
+it is merely a convenience.
+
+[section Concepts] [include include/concept.inc]
+
+[section API]
+[subsection {Package commands}]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::toc] [arg objectName]]
+
+This command creates a new container object with an associated Tcl
+command whose name is [arg objectName]. This [term object] command is
+explained in full detail in the sections [sectref {Object command}]
+and [sectref {Object methods}]. The object command will be created
+under the current namespace if the [arg objectName] is not fully
+qualified, and in the specified namespace otherwise.
+
+[list_end]
+
+[subsection {Object command}]
+
+All objects created by the [cmd ::doctools::toc] command have the
+following general form:
+
+[list_begin definitions]
+
+[call [cmd objectName] [method method] [opt [arg "arg arg ..."]]]
+
+The method [method method] and its [arg arg]'uments determine the
+exact behavior of the command.
+
+See section [sectref {Object methods}] for the detailed
+specifications.
+
+[list_end]
+
+[subsection {Object methods}]
+
+[list_begin definitions]
+
+[call [arg objectName] [method destroy]]
+
+This method destroys the object it is invoked for.
+
+[call [arg objectName] [method {+ reference}] [arg id] [arg label] [arg docid] [arg desc]]
+
+This method adds a new reference element to the table of contents,
+under the element specified via its handle [arg id]. This parent
+element has to be a division element, or the root. An error is thrown
+otherwise.
+
+The new element will be externally identified by its [arg label],
+which has to be be unique within the parent element. An error is
+thrown otherwise.
+
+[para]
+
+As a reference element it will refer to a document identified by the
+symbolic [arg docid]. This reference must not be the empty string, an
+error is thrown otherwise.
+
+Beyond the label the element also has a longer descriptive string,
+supplied via [arg desc].
+
+[para]
+
+The result of the method is the handle (id) of the new element.
+
+[call [arg objectName] [method {+ division}] [arg id] [arg label] [opt [arg docid]]]
+
+This method adds a new division element to the table of contents,
+under the element specified via its handle [arg id]. This parent
+element has to be a division element, or the root. An error is thrown
+otherwise.
+
+The new element will be externally identified by its [arg label],
+which has to be be unique within the parent element. An error is
+thrown otherwise.
+
+[para]
+
+As a division element it is can refer to a document, identified by the
+symbolic [arg docid], but may choose not to.
+
+[para]
+
+The result of the method is the handle (id) of the new element.
+
+[call [arg objectName] [method remove] [arg id]]
+
+This method removes the element identified by the handle [arg id] from
+the table of contents.
+
+If the element is a division all of its children, if any, are removed
+as well. The root element/division of the table of contents cannot be
+removed however, only its children.
+
+[para]
+
+The result of the method is the empty string.
+
+[call [arg objectName] [method up] [arg id]]
+
+This method returns the handle of the parent for the element
+identified by its handle [arg id], or the empty string if [arg id]
+refered to the root element.
+
+[call [arg objectName] [method next] [arg id]]
+
+This method returns the handle of the right sibling for the element
+identified by its handle [arg id], or the handle of the parent if the
+element has no right sibling, or the empty string if [arg id] refered
+to the root element.
+
+[call [arg objectName] [method prev] [arg id]]
+
+This method returns the handle of the left sibling for the element
+identified by its handle [arg id], or the handle of the parent if the
+element has no left sibling, or the empty string if [arg id] refered
+to the root element.
+
+[call [arg objectName] [method child] [arg id] [arg label] [opt [arg ...]]]
+
+This method returns the handle of a child of the element identified by
+its handle [arg id]. The child itself is identified by a series of
+labels.
+
+[call [arg objectName] [method element] [opt [arg ...]]]
+
+This method returns the handle of the element identified by a series
+of labels, starting from the root of the table of contents. The series
+of labels is allowed to be empty, in which case the handle of the root
+element is returned.
+
+[call [arg objectName] [method children] [arg id]]
+
+This method returns a list containing the handles of all children of
+the element identified by the handle [arg id], from first to last, in
+that order.
+
+[call [arg objectName] [method type] [arg id]]
+
+This method returns the type of the element, either [const reference],
+or [const division].
+
+[call [arg objectName] [method full-label] [arg id]]
+
+This method is the complement of the method [method element],
+converting the handle [arg id] of an element into a list of labels
+full identifying the element within the whole table of contents.
+
+[call [arg objectName] [method elabel] [arg id] [opt [arg newlabel]]]
+
+This method queries and/or changes the label of the element identified
+by the handle [arg id]. If the argument [arg newlabel] is present then
+the label is changed to that value. Regardless of this, the result of
+the method is the current value of the label.
+
+[para]
+
+If the label is changed the new label has to be unique within the
+containing division, or an error is thrown.
+
+[para]
+
+Further, of the [arg id] refers to the root element of the table of
+contents, then using this method is equivalent to using the method
+[arg label], i.e. it is accessing the global label for the whole
+table.
+
+[call [arg objectName] [method description] [arg id] [opt [arg newdesc]]]
+
+This method queries and/or changes the description of the element
+identified by the handle [arg id]. If the argument [arg newdesc] is
+present then the description is changed to that value. Regardless of
+this, the result of the method is the current value of the description.
+
+[para]
+
+The element this method operates on has to be a reference element, or
+an error will be thrown.
+
+[call [arg objectName] [method document] [arg id] [opt [arg newdocid]]]
+
+This method queries and/or changes the document reference of the
+element identified by the handle [arg id].
+
+If the argument [arg newdocid] is present then the description is
+changed to that value. Regardless of this, the result of the method is
+the current value of the document reference.
+
+[para]
+
+Setting the reference to the empty string means unsetting it, and is
+allowed only for division elements. Conversely, if the result is the
+empty string then the element has no document reference, and this can
+happen only for division elements.
+
+[call [arg objectName] [method title]]
+
+Returns the currently defined title of the table of contents.
+
+[call [arg objectName] [method title] [arg text]]
+
+Sets the title of the table of contents to [arg text], and returns it as
+the result of the command.
+
+[call [arg objectName] [method label]]
+
+Returns the currently defined label of the table of contents.
+
+[call [arg objectName] [method label] [arg text]]
+
+Sets the label of the table of contents to [arg text], and returns it as
+the result of the command.
+
+[call [arg objectName] [method importer]]
+
+Returns the import manager object currently attached to the container,
+if any.
+
+[call [arg objectName] [method importer] [arg object]]
+
+Attaches the [arg object] as import manager to the container, and
+returns it as the result of the command.
+
+Note that the [arg object] is [emph not] put into ownership of the
+container. I.e., destruction of the container will [emph not] destroy
+the [arg object].
+
+[para]
+
+It is expected that [arg object] provides a method named
+[method {import text}] which takes a text and a format name, and
+returns the canonical serialization of the table of contents contained in
+the text, assuming the given format.
+
+[call [arg objectName] [method exporter]]
+
+Returns the export manager object currently attached to the container,
+if any.
+
+[call [arg objectName] [method exporter] [arg object]]
+
+Attaches the [arg object] as export manager to the container, and
+returns it as the result of the command.
+
+Note that the [arg object] is [emph not] put into ownership of the
+container. I.e., destruction of the container will [emph not] destroy
+the [arg object].
+
+[para]
+
+It is expected that [arg object] provides a method named
+[method {export object}] which takes the container and a format name,
+and returns a text encoding table of contents stored in the container, in
+the given format. It is further expected that the [arg object] will
+use the container's method [method serialize] to obtain the
+serialization of the table of contents from which to generate the text.
+
+[call [arg objectName] [method {deserialize =}] [arg data] [opt [arg format]]]
+
+This method replaces the contents of the table object with the table
+contained in the [arg data]. If no [arg format] was specified it is
+assumed to be the regular serialization of a table of contents.
+
+[para]
+
+Otherwise the object will use the attached import manager to convert
+the data from the specified format to a serialization it can handle.
+
+In that case an error will be thrown if the container has no import
+manager attached to it.
+
+[para]
+
+The result of the method is the empty string.
+
+[call [arg objectName] [method {deserialize +=}] [arg data] [opt [arg format]]]
+
+This method behaves like [method {deserialize =}] in its essentials,
+except that it merges the table of contents in the [arg data] to its
+contents instead of replacing it.
+
+The method will throw an error if merging is not possible, i.e. would
+produce an invalid table. The existing content is left unchanged in
+that case.
+
+[para]
+
+The result of the method is the empty string.
+
+[call [arg objectName] [method serialize] [opt [arg format]]]
+
+This method returns the table of contents contained in the object. If no
+[arg format] is not specified the returned result is the canonical
+serialization of its contents.
+
+[para]
+
+Otherwise the object will use the attached export manager to convert
+the data to the specified format.
+
+In that case an error will be thrown if the container has no export
+manager attached to it.
+
+[list_end]
+
+[include include/serialization.inc]
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2toc/toc_export.man b/tcllib/modules/doctools2toc/toc_export.man
new file mode 100644
index 0000000..91a87e7
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_export.man
@@ -0,0 +1,306 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::toc::export n 0.1]
+[keywords conversion]
+[keywords doctoc]
+[keywords documentation]
+[keywords export]
+[keywords formatting]
+[keywords generation]
+[keywords HTML]
+[keywords json]
+[keywords manpage]
+[keywords markup]
+[keywords nroff]
+[keywords plugin]
+[keywords reference]
+[keywords table]
+[keywords {table of contents}]
+[keywords {tcler's wiki}]
+[keywords text]
+[keywords url]
+[keywords wiki]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Exporting tables of contents}]
+[category {Documentation tools}]
+[require doctools::toc::export [opt 0.1]]
+[require Tcl 8.4]
+[require doctools::config]
+[require doctools::toc::structure]
+[require snit]
+[require pluginmgr]
+[description]
+
+This package provides a class to manage the plugins for the export of
+tables of contents to other formats, i.e. their conversion to, for
+example [term doctoc], [term HTML], etc.
+
+[para]
+
+This is one of the three public pillars the management of tables of
+contents resides on. The other two pillars are
+
+[list_begin enum]
+[enum] [manpage {Importing tables of contents}], and
+[enum] [manpage {Holding tables of contents}]
+[list_end]
+
+[para]
+
+For information about the [sectref Concepts] of tables of contents,
+and their parts, see the same-named section.
+
+For information about the data structure which is the major input to
+the manager objects provided by this package see the section
+[sectref {ToC serialization format}].
+
+[para]
+
+The plugin system of our class is based on the package
+[package pluginmgr], and configured to look for plugins using
+
+[list_begin enum]
+[enum] the environment variable [var DOCTOOLS_TOC_EXPORT_PLUGINS],
+[enum] the environment variable [var DOCTOOLS_TOC_PLUGINS],
+[enum] the environment variable [var DOCTOOLS_PLUGINS],
+[enum] the path [file {~/.doctools/toc/export/plugin}]
+[enum] the path [file {~/.doctools/toc/plugin}]
+[enum] the path [file {~/.doctools/plugin}]
+[enum] the path [file {~/.doctools/toc/export/plugins}]
+[enum] the path [file {~/.doctools/toc/plugins}]
+[enum] the path [file {~/.doctools/plugins}]
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\DOCTOOLS\TOC\EXPORT\PLUGINS"
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\DOCTOOLS\TOC\PLUGINS"
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\DOCTOOLS\PLUGINS"
+[list_end]
+
+The last three are used only when the package is run on a machine
+using Windows(tm) operating system.
+
+[para]
+
+The whole system is delivered with six predefined export plugins,
+namely
+
+[list_begin definitions]
+[def doctoc] See [manpage {doctoc export plugin}] for details.
+[def html] See [manpage {html export plugin}] for details.
+[def json] See [manpage {json export plugin}] for details.
+[def nroff] See [manpage {nroff export plugin}] for details.
+[def text] See [manpage {text export plugin}] for details.
+[def wiki] See [manpage {wiki export plugin}] for details.
+[list_end]
+
+[para]
+
+Readers wishing to write their own export plugin for some format, i.e.
+[term {plugin writer}]s reading and understanding the section
+containing the [sectref {Export plugin API v2 reference}] is an
+absolute necessity, as it specifies the interaction between this
+package and its plugins in detail.
+
+[section Concepts] [include include/concept.inc]
+
+[section API]
+[subsection {Package commands}]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::toc::export] [arg objectName]]
+
+This command creates a new export manager object with an associated
+Tcl command whose name is [arg objectName]. This [term object] command
+is explained in full detail in the sections [sectref {Object command}]
+and [sectref {Object methods}]. The object command will be created
+under the current namespace if the [arg objectName] is not fully
+qualified, and in the specified namespace otherwise.
+
+[list_end]
+
+[subsection {Object command}]
+
+All objects created by the [cmd ::doctools::toc::export] command have
+the following general form:
+
+[list_begin definitions]
+
+[call [cmd objectName] [method method] [opt [arg "arg arg ..."]]]
+
+The method [method method] and its [arg arg]'uments determine the
+exact behavior of the command.
+
+See section [sectref {Object methods}] for the detailed
+specifications.
+
+[list_end]
+
+[subsection {Object methods}]
+
+[list_begin definitions]
+
+[call [arg objectName] [method destroy]]
+
+This method destroys the object it is invoked for.
+
+[call [arg objectName] [method {export serial}] [arg serial] [opt [arg format]]]
+
+This method takes the canonical serialization of a table of contents
+stored in [arg serial] and converts it to the specified [arg format],
+using the export plugin for the format. An error is thrown if no
+plugin could be found for the format.
+
+The string generated by the conversion process is returned as
+the result of this method.
+
+[para]
+
+If no format is specified the method defaults to [const doctoc].
+
+[para]
+
+The specification of what a [term canonical] serialization is can be
+found in the section [sectref {ToC serialization format}].
+
+[para]
+
+The plugin has to conform to the interface specified in section
+[sectref {Export plugin API v2 reference}].
+
+[call [arg objectName] [method {export object}] [arg object] [opt [arg format]]]
+
+This method is a convenient wrapper around the [method {export serial}]
+method described by the previous item.
+
+It expects that [arg object] is an object command supporting a
+[method serialize] method returning the canonical serialization of a
+table of contents. It invokes that method, feeds the result into
+[method {export serial}] and returns the resulting string as its own
+result.
+
+[call [arg objectName] [method {config names}]]
+
+This method returns a list containing the names of all configuration
+variables currently known to the object.
+
+[call [arg objectName] [method {config get}]]
+
+This method returns a dictionary containing the names and values of
+all configuration variables currently known to the object.
+
+[call [arg objectName] [method {config set}] [arg name] [opt [arg value]]]
+
+This method sets the configuration variable [arg name] to the
+specified [arg value] and returns the new value of the variable.
+
+[para]
+
+If no value is specified it simply returns the current value, without
+changing it.
+
+[para]
+
+Note that while the user can set the predefined configuration
+variables [const user] and [const format] doing so will have no
+effect, these values will be internally overriden when invoking an
+import plugin.
+
+[call [arg objectName] [method {config unset}] [arg pattern]...]
+
+This method unsets all configuration variables matching the specified
+glob [arg pattern]s. If no pattern is specified it will unset all
+currently defined configuration variables.
+
+[list_end]
+
+[section {Export plugin API v2 reference}]
+
+Plugins are what this package uses to manage the support for any
+output format beyond the [sectref {ToC serialization format}]. Here we
+specify the API the objects created by this package use to interact
+with their plugins.
+
+[para]
+
+A plugin for this package has to follow the rules listed below:
+
+[list_begin enumerated]
+
+[enum] A plugin is a package.
+
+[enum] The name of a plugin package has the form
+
+ doctools::toc::export::[var FOO],
+
+ where [var FOO] is the name of the format the plugin will
+ generate output for. This name is also the argument to provide
+ to the various [method export] methods of export manager
+ objects to get a string encoding a table of contents in that
+ format.
+
+[enum] The plugin can expect that the package
+ [package doctools::toc::export::plugin] is present, as
+ indicator that it was invoked from a genuine plugin manager.
+
+[enum] A plugin has to provide one command, with the signature shown
+ below.
+
+[list_begin definitions]
+[call [cmd export] [arg serial] [arg configuration]]
+
+Whenever an export manager of [package doctools::toc] has to generate
+output for a table of contents it will invoke this command.
+
+[list_begin arguments]
+
+[arg_def string serial]
+
+This argument will contain the [term canonical] serialization of the
+table of contents for which to generate the output.
+
+The specification of what a [term canonical] serialization is can be
+found in the section [sectref {ToC serialization format}].
+
+[arg_def dictionary configuration]
+
+This argument will contain the current configuration to apply to the
+generation, as a dictionary mapping from variable names to values.
+
+[para]
+
+The following configuration variables have a predefined meaning all
+plugins have to obey, although they can ignore this information at
+their discretion. Any other other configuration variables recognized
+by a plugin will be described in the manpage for that plugin.
+
+[list_begin definitions]
+
+[def user] This variable is expected to contain the name of the user
+ owning the process invoking the plugin.
+
+[def format] This variable is expected to contain the name of the
+ format whose plugin is invoked.
+
+[def file] This variable, if defined by the user of the table object
+ is expected to contain the name of the input file for which
+ the plugin is generating its output for.
+
+[def map] This variable, if defined by the user of the table object is
+ expected to contain a dictionary mapping from symbolic
+ document ids used in the table entries to actual paths (or
+ urls). A plugin has to be able to handle the possibility
+ that a document id is without entry in this mapping.
+
+[list_end][comment {-- predefined configuration variables --}]
+[list_end][comment {-- arguments --}]
+[list_end][comment {-- api command signatures --}]
+
+[enum] A single usage cycle of a plugin consists of the invokations of
+ the command [cmd export]. This call has to leave the plugin in
+ a state where another usage cycle can be run without problems.
+
+[list_end]
+
+[include include/serialization.inc]
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2toc/toc_export_html.man b/tcllib/modules/doctools2toc/toc_export_html.man
new file mode 100644
index 0000000..6124f48
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_export_html.man
@@ -0,0 +1,7 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE html]
+[vset NAME HTML]
+[vset REQUIRE html]
+[vset CONFIG html]
+[vset VERSION 0.1]
+[include include/export/plugin.inc]
diff --git a/tcllib/modules/doctools2toc/toc_export_json.man b/tcllib/modules/doctools2toc/toc_export_json.man
new file mode 100644
index 0000000..ce9e983
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_export_json.man
@@ -0,0 +1,7 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE json]
+[vset NAME JSON]
+[vset REQUIRE json]
+[vset CONFIG json]
+[vset VERSION 0.1]
+[include include/export/plugin.inc]
diff --git a/tcllib/modules/doctools2toc/toc_export_nroff.man b/tcllib/modules/doctools2toc/toc_export_nroff.man
new file mode 100644
index 0000000..cc17540
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_export_nroff.man
@@ -0,0 +1,7 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE nroff]
+[vset NAME nroff]
+[vset REQUIRE nroff]
+[vset CONFIG nroff]
+[vset VERSION 0.2]
+[include include/export/plugin.inc]
diff --git a/tcllib/modules/doctools2toc/toc_export_text.man b/tcllib/modules/doctools2toc/toc_export_text.man
new file mode 100644
index 0000000..6d718f8
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_export_text.man
@@ -0,0 +1,7 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE text]
+[vset NAME {plain text}]
+[vset REQUIRE text]
+[vset CONFIG text]
+[vset VERSION 0.1]
+[include include/export/plugin.inc]
diff --git a/tcllib/modules/doctools2toc/toc_export_wiki.man b/tcllib/modules/doctools2toc/toc_export_wiki.man
new file mode 100644
index 0000000..5a5eb1a
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_export_wiki.man
@@ -0,0 +1,7 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE wiki]
+[vset NAME wiki]
+[vset REQUIRE text]
+[vset CONFIG wiki]
+[vset VERSION 0.1]
+[include include/export/plugin.inc]
diff --git a/tcllib/modules/doctools2toc/toc_import.man b/tcllib/modules/doctools2toc/toc_import.man
new file mode 100644
index 0000000..e0edab0
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_import.man
@@ -0,0 +1,394 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::toc::import n 0.1]
+[keywords conversion]
+[keywords doctoc]
+[keywords documentation]
+[keywords import]
+[keywords json]
+[keywords manpage]
+[keywords markup]
+[keywords parsing]
+[keywords plugin]
+[keywords reference]
+[keywords table]
+[keywords {table of contents}]
+[keywords url]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Importing keyword indices}]
+[category {Documentation tools}]
+[require doctools::toc::import [opt 0.1]]
+[require Tcl 8.4]
+[require doctools::config]
+[require doctools::toc::structure]
+[require snit]
+[require pluginmgr]
+[description]
+
+This package provides a class to manage the plugins for the import of
+tables of contents from other formats, i.e. their conversion from, for
+example [term doctoc], [term json], etc.
+
+[para]
+
+This is one of the three public pillars the management of tables of
+contents resides on. The other two pillars are
+
+[list_begin enum]
+[enum] [manpage {Exporting tables of contents}], and
+[enum] [manpage {Holding tables of contents}]
+[list_end]
+
+[para]
+
+For information about the [sectref Concepts] of tables of contents,
+and their parts, see the same-named section.
+
+For information about the data structure which is the major output of
+the manager objects provided by this package see the section
+[sectref {ToC serialization format}].
+
+[para]
+
+The plugin system of our class is based on the package
+[package pluginmgr], and configured to look for plugins using
+
+[list_begin enum]
+[enum] the environment variable [var DOCTOOLS_TOC_IMPORT_PLUGINS],
+[enum] the environment variable [var DOCTOOLS_TOC_PLUGINS],
+[enum] the environment variable [var DOCTOOLS_PLUGINS],
+[enum] the path [file {~/.doctools/toc/import/plugin}]
+[enum] the path [file {~/.doctools/toc/plugin}]
+[enum] the path [file {~/.doctools/plugin}]
+[enum] the path [file {~/.doctools/toc/import/plugins}]
+[enum] the path [file {~/.doctools/toc/plugins}]
+[enum] the path [file {~/.doctools/plugins}]
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\DOCTOOLS\TOC\IMPORT\PLUGINS"
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\DOCTOOLS\TOC\PLUGINS"
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\DOCTOOLS\PLUGINS"
+[list_end]
+
+The last three are used only when the package is run on a machine
+using Windows(tm) operating system.
+
+[para]
+
+The whole system is delivered with two predefined import plugins,
+namely
+
+[list_begin definitions]
+[def doctoc] See [manpage {doctoc import plugin}] for details.
+[def json] See [manpage {json import plugin}] for details.
+[list_end]
+
+[para]
+
+Readers wishing to write their own import plugin for some format, i.e.
+[term {plugin writer}]s reading and understanding the section
+containing the [sectref {Import plugin API v2 reference}] is an
+absolute necessity, as it specifies the interaction between this
+package and its plugins in detail.
+
+[section Concepts] [include include/concept.inc]
+
+[section API]
+[subsection {Package commands}]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::toc::import] [arg objectName]]
+
+This command creates a new import manager object with an associated
+Tcl command whose name is [arg objectName]. This [term object] command
+is explained in full detail in the sections [sectref {Object command}]
+and [sectref {Object methods}]. The object command will be created
+under the current namespace if the [arg objectName] is not fully
+qualified, and in the specified namespace otherwise.
+
+[list_end]
+
+[subsection {Object command}]
+
+All objects created by the [cmd ::doctools::toc::import] command have
+the following general form:
+
+[list_begin definitions]
+
+[call [cmd objectName] [method method] [opt [arg "arg arg ..."]]]
+
+The method [method method] and its [arg arg]'uments determine the
+exact behavior of the command.
+
+See section [sectref {Object methods}] for the detailed
+specifications.
+
+[list_end]
+
+[subsection {Object methods}]
+
+[list_begin definitions]
+
+[call [arg objectName] [method destroy]]
+
+This method destroys the object it is invoked for.
+
+[call [arg objectName] [method {import text}] [arg text] [opt [arg format]]]
+
+This method takes the [arg text] and converts it from the specified
+[arg format] to the canonical serialization of a table of contents using
+the import plugin for the format. An error is thrown if no plugin
+could be found for the format.
+
+The serialization generated by the conversion process is returned as
+the result of this method.
+
+[para]
+
+If no format is specified the method defaults to [const doctoc].
+
+[para]
+
+The specification of what a [term canonical] serialization is can be
+found in the section [sectref {ToC serialization format}].
+
+[para]
+
+The plugin has to conform to the interface specified in section
+[sectref {Import plugin API v2 reference}].
+
+[call [arg objectName] [method {import file}] [arg path] [opt [arg format]]]
+
+This method is a convenient wrapper around the [method {import text}]
+method described by the previous item.
+
+It reads the contents of the specified file into memory, feeds the
+result into [method {import text}] and returns the resulting
+serialization as its own result.
+
+[call [arg objectName] [method {import object text}] [arg object] \
+ [arg text] [opt [arg format]]]
+
+This method is a convenient wrapper around the [method {import text}]
+method described by the previous item.
+
+It expects that [arg object] is an object command supporting a
+[method deserialize] method expecting the canonical serialization of a
+table of contents.
+
+It imports the text using [method {import text}] and then feeds the
+resulting serialization into the [arg object] via [method deserialize].
+
+This method returns the empty string as it result.
+
+[call [arg objectName] [method {import object file}] [arg object] \
+ [arg path] [opt [arg format]]]
+
+This method behaves like [method {import object text}], except that it
+reads the text to convert from the specified file instead of being
+given it as argument.
+
+[call [arg objectName] [method {config names}]]
+
+This method returns a list containing the names of all configuration
+variables currently known to the object.
+
+[call [arg objectName] [method {config get}]]
+
+This method returns a dictionary containing the names and values of
+all configuration variables currently known to the object.
+
+[call [arg objectName] [method {config set}] [arg name] [opt [arg value]]]
+
+This method sets the configuration variable [arg name] to the
+specified [arg value] and returns the new value of the variable.
+
+[para]
+
+If no value is specified it simply returns the current value, without
+changing it.
+
+[para]
+
+Note that while the user can set the predefined configuration
+variables [const user] and [const format] doing so will have no
+effect, these values will be internally overriden when invoking an
+import plugin.
+
+[call [arg objectName] [method {config unset}] [arg pattern]...]
+
+This method unsets all configuration variables matching the specified
+glob [arg pattern]s. If no pattern is specified it will unset all
+currently defined configuration variables.
+
+[call [arg objectName] [method includes]]
+
+This method returns a list containing the currently specified paths to
+use to search for include files when processing input.
+
+The order of paths in the list corresponds to the order in which they
+are used, from first to last, and also corresponds to the order in
+which they were added to the object.
+
+[call [arg objectName] [method {include add}] [arg path]]
+
+This methods adds the specified [arg path] to the list of paths to use
+to search for include files when processing input. The path is added
+to the end of the list, causing it to be searched after all previously
+added paths. The result of the command is the empty string.
+
+[para]
+
+The method does nothing if the path is already known.
+
+[call [arg objectName] [method {include remove}] [arg path]]
+
+This methods removes the specified [arg path] from the list of paths
+to use to search for include files when processing input. The result
+of the command is the empty string.
+
+[para]
+
+The method does nothing if the path is not known.
+
+[call [arg objectName] [method {include clear}]]
+
+This method clears the list of paths to use to search for include
+files when processing input. The result of the command is the empty
+string.
+
+[list_end]
+
+[section {Import plugin API v2 reference}]
+
+Plugins are what this package uses to manage the support for any input
+format beyond the [sectref {ToC serialization format}]. Here we
+specify the API the objects created by this package use to interact
+with their plugins.
+
+[para]
+
+A plugin for this package has to follow the rules listed below:
+
+[list_begin enumerated]
+
+[enum] A plugin is a package.
+
+[enum] The name of a plugin package has the form
+
+ doctools::toc::import::[var FOO],
+
+ where [var FOO] is the name of the format the plugin will
+ generate output for. This name is also the argument to provide
+ to the various [method import] methods of import manager
+ objects to get a string encoding a table of contents in that
+ format.
+
+[enum] The plugin can expect that the package
+ [package doctools::toc::export::plugin] is present, as
+ indicator that it was invoked from a genuine plugin manager.
+
+[enum] The plugin can expect that a command named [cmd IncludeFile] is
+ present, with the signature
+
+[list_begin definitions]
+[call [cmd IncludeFile] [arg currentfile] [arg path]]
+
+This command has to be invoked by the plugin when it has to process an
+included file, if the format has the concept of such. An example of
+such a format would be [term doctoc].
+
+[para]
+The plugin has to supply the following arguments
+
+[list_begin arguments]
+[arg_def string currentfile]
+The path of the file it is currently processing. This may be the empty
+string if no such is known.
+
+[arg_def string path]
+The path of the include file as specified in the include directive
+being processed.
+
+[list_end]
+
+The result of the command will be a 5-element list containing
+
+[list_begin enum]
+
+[enum] A boolean flag indicating the success ([const True]) or failure
+ ([const False]) of the operation.
+
+[enum] In case of success the contents of the included file, and the
+ empty string otherwise.
+
+[enum] The resolved, i.e. absolute path of the included file, if
+ possible, or the unchanged [arg path] argument. This is for
+ display in an error message, or as the [arg currentfile]
+ argument of another call to [cmd IncludeFile] should this file
+ contain more files.
+
+[enum] In case of success an empty string, and for failure a code
+ indicating the reason for it, one of
+
+[list_begin definitions]
+[def notfound] The specified file could not be found.
+[def notread] The specified file was found, but not be read into memory.
+[list_end][comment {-- include error codes --}]
+
+[enum] An empty string in case of success of a [const notfound]
+ failure, and an additional error message describing the reason
+ for a [const notread] error in more detail.
+
+[list_end][comment {-- result list elements --}]
+[list_end][comment {-- include-file signature --}]
+
+[enum] A plugin has to provide one command, with the signature shown
+ below.
+
+[list_begin definitions]
+[call [cmd import] [arg text] [arg configuration]]
+
+Whenever an import manager of [package doctools::toc] has to parse
+input for a table of contents it will invoke this command.
+
+[list_begin arguments]
+
+[arg_def string text]
+
+This argument will contain the text encoding the table of contents per
+the format the plugin is for.
+
+[arg_def dictionary configuration]
+
+This argument will contain the current configuration to apply to the
+parsing, as a dictionary mapping from variable names to values.
+
+[para]
+
+The following configuration variables have a predefined meaning all
+plugins have to obey, although they can ignore this information at
+their discretion. Any other other configuration variables recognized
+by a plugin will be described in the manpage for that plugin.
+
+[list_begin definitions]
+
+[def user] This variable is expected to contain the name of the user
+ owning the process invoking the plugin.
+
+[def format] This variable is expected to contain the name of the
+ format whose plugin is invoked.
+
+[list_end][comment {-- predefined configuration variables --}]
+[list_end][comment {-- arguments --}]
+[list_end][comment {-- api command signatures --}]
+
+[enum] A single usage cycle of a plugin consists of the invokations of
+ the command [cmd import]. This call has to leave the plugin in
+ a state where another usage cycle can be run without problems.
+
+[list_end]
+
+[include include/serialization.inc]
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2toc/toc_import_json.man b/tcllib/modules/doctools2toc/toc_import_json.man
new file mode 100644
index 0000000..c097451
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_import_json.man
@@ -0,0 +1,6 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE json]
+[vset NAME JSON]
+[vset REQUIRE json]
+[vset CONFIG json]
+[include include/import/plugin.inc]
diff --git a/tcllib/modules/doctools2toc/toc_introduction.man b/tcllib/modules/doctools2toc/toc_introduction.man
new file mode 100644
index 0000000..78527db
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_introduction.man
@@ -0,0 +1,143 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools2toc_introduction n 2.0]
+[see_also doctoc_intro]
+[see_also doctools]
+[see_also doctools2doc_introduction]
+[see_also doctools2idx_introduction]
+[see_also doctools_lang_cmdref]
+[see_also doctools_lang_faq]
+[see_also doctools_lang_intro]
+[see_also doctools_lang_syntax]
+[see_also doctools_plugin_apiref]
+[keywords contents]
+[keywords conversion]
+[keywords formatting]
+[keywords markup]
+[keywords parsing]
+[keywords plugin]
+[keywords {semantic markup}]
+[keywords {table of contents}]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {DocTools - Tables of Contents}]
+[category {Documentation tools}]
+[comment {
+}]
+[description]
+
+[term doctoc] (short for [emph {documentation tables of contents}])
+stands for a set of related, yet different, entities which are working
+together for the easy creation and transformation of tables and
+contents for documentation.
+
+[para]
+
+These are
+
+[list_begin enumerated]
+[enum]
+A tcl based language for the semantic markup of a table of contents.
+Markup is represented by Tcl commands.
+
+Beginners should start with the
+[manpage {doctoc language introduction}].
+
+The formal specification is split over two documents, one dealing with
+the [manpage {doctoc language syntax}], the other a
+[manpage {doctoc language command reference}].
+
+[enum]
+A set of packages for the programmatic manipulation of tables of
+contents in memory, and their conversion between various formats,
+reading and writing. The aforementioned markup language is one of the
+formats which can be both read from and written to.
+
+[enum]
+The system for the conversion of tables of contents is based on a
+plugin mechanism, for this we have two APIs describing the interface
+between the packages above and the import/export plugins.
+
+[list_end]
+
+[para]
+Which of the more detailed documents are relevant to the reader of
+this introduction depends on their role in the documentation process.
+
+[para]
+
+[list_begin enumerated]
+[enum]
+A [manpage writer] of documentation has to understand the markup language
+itself. A beginner to doctoc should read the more informally written
+[manpage {doctoc language introduction}] first. Having digested this
+the formal [manpage {doctoc language syntax}] specification should
+become understandable. A writer experienced with doctoc may only
+need the [manpage {doctoc language command reference}] from time to
+time to refresh her memory.
+
+[para]
+While a document is written the [syscmd dtp] application can be used
+to validate it, and after completion it also performs the conversion
+into the chosen system of visual markup, be it *roff, HTML, plain
+text, wiki, etc. The simpler [syscmd dtplite] application makes
+internal use of doctoc when handling directories of documentation,
+automatically generating a proper table of contents for them.
+
+[enum]
+A [term processor] of documentation written in the [term doctoc]
+markup language has to know which tools are available for use.
+
+[para]
+The main tool is the aforementioned [syscmd dtp] application provided
+by Tcllib. The simpler [syscmd dtplite] does not expose doctoc to the
+user. At the bottom level, common to both applications, however we
+find the three packages providing the basic facilities to handle
+tables of contents, i.e. import from textual formats, programmatic
+manipulation in memory, and export to textual formats. These are
+
+[list_begin definitions]
+[def [package doctoools::toc]]
+Programmatic manipulation of tables of contents in memory.
+
+[def [package doctoools::toc::import]]
+Import of tables of contents from various textual formats. The set of
+supported formats is extensible through plugin packages.
+
+[def [package doctoools::toc::export]]
+Export of tables of contents to various textual formats. The set of
+supported formats is extensible through plugin packages.
+
+[list_end]
+See also section [sectref {Package Overview}] for an overview of the
+dependencies between these and other, supporting packages.
+
+[enum]
+At last, but not least, [term {plugin writers}] have to understand the
+interaction between the import and export packages and their plugins.
+These APIs are described in the documentation for the two relevant
+packages, i.e.
+
+[list_begin itemized]
+[item] [package doctoools::toc::import]
+[item] [package doctoools::toc::export]
+[list_end]
+
+[list_end]
+
+[section {Related formats}]
+
+The doctoc format does not stand alone, it has two companion formats.
+These are called [term docidx] and [term doctools], and they are
+intended for the markup of [term {keyword indices}], and of general
+documentation, respectively.
+
+They are described in their own sets of documents, starting at
+the [manpage {DocTools - Keyword Indices}] and
+the [manpage {DocTools - General}], respectively.
+
+[section {Package Overview}]
+[include include/dependencies.inc]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2toc/toc_msgcat_c.man b/tcllib/modules/doctools2toc/toc_msgcat_c.man
new file mode 100644
index 0000000..3bb3f54
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_msgcat_c.man
@@ -0,0 +1,5 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE c]
+[vset NAME C]
+[vset LONGNAME C]
+[include include/msgcat.inc]
diff --git a/tcllib/modules/doctools2toc/toc_msgcat_de.man b/tcllib/modules/doctools2toc/toc_msgcat_de.man
new file mode 100644
index 0000000..9c502a2
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_msgcat_de.man
@@ -0,0 +1,5 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE de]
+[vset NAME DE]
+[vset LONGNAME {DE (german)}]
+[include include/msgcat.inc]
diff --git a/tcllib/modules/doctools2toc/toc_msgcat_en.man b/tcllib/modules/doctools2toc/toc_msgcat_en.man
new file mode 100644
index 0000000..5dd9c3f
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_msgcat_en.man
@@ -0,0 +1,5 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE en]
+[vset NAME EN]
+[vset LONGNAME {EN (english)}]
+[include include/msgcat.inc]
diff --git a/tcllib/modules/doctools2toc/toc_msgcat_fr.man b/tcllib/modules/doctools2toc/toc_msgcat_fr.man
new file mode 100644
index 0000000..3e5229b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_msgcat_fr.man
@@ -0,0 +1,5 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[vset PACKAGE fr]
+[vset NAME FR]
+[vset LONGNAME {FR (french)}]
+[include include/msgcat.inc]
diff --git a/tcllib/modules/doctools2toc/toc_parse.man b/tcllib/modules/doctools2toc/toc_parse.man
new file mode 100644
index 0000000..073581b
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_parse.man
@@ -0,0 +1,175 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::toc::parse n 1]
+[keywords doctoc]
+[keywords doctools]
+[keywords lexer]
+[keywords parser]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Parsing text in doctoc format}]
+[category {Documentation tools}]
+[require doctools::toc::parse [opt 0.1]]
+[require Tcl 8.4]
+[require doctools::toc::structure]
+[require doctools::msgcat]
+[require doctools::tcl::parse]
+[require fileutil]
+[require logger]
+[require snit]
+[require struct::list]
+[require struct::stack]
+
+[description]
+
+This package provides commands to parse text written in the
+[term doctoc] markup language and convert it into the canonical
+serialization of the table of contents encoded in the text.
+
+See the section [sectref {ToC serialization format}] for specification
+of their format.
+
+[para]
+
+This is an internal package of doctools, for use by the higher level
+packages handling [term doctoc] documents.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::toc::parse] [method text] [arg text]]
+
+The command takes the string contained in [arg text] and parses it
+under the assumption that it contains a document written using the
+[term doctoc] markup language. An error is thrown if this assumption
+is found to be false. The format of these errors is described in
+section [sectref {Parse errors}].
+
+[para]
+
+When successful the command returns the canonical serialization of the
+table of contents which was encoded in the text.
+
+See the section [sectref {ToC serialization format}] for specification
+of that format.
+
+[call [cmd ::doctools::toc::parse] [method file] [arg path]]
+
+The same as [method text], except that the text to parse is read from
+the file specified by [arg path].
+
+[call [cmd ::doctools::toc::parse] [method includes]]
+
+This method returns the current list of search paths used when looking
+for include files.
+
+[call [cmd ::doctools::toc::parse] [method {include add}] [arg path]]
+
+This method adds the [arg path] to the list of paths searched when
+looking for an include file. The call is ignored if the path is
+already in the list of paths. The method returns the empty string as
+its result.
+
+[call [cmd ::doctools::toc::parse] [method {include remove}] [arg path]]
+
+This method removes the [arg path] from the list of paths searched
+when looking for an include file. The call is ignored if the path is
+not contained in the list of paths. The method returns the empty
+string as its result.
+
+[call [cmd ::doctools::toc::parse] [method {include clear}]]
+
+This method clears the list of search paths for include files.
+
+[call [cmd ::doctools::toc::parse] [method vars]]
+
+This method returns a dictionary containing the current set of
+predefined variables known to the [cmd vset] markup command during
+processing.
+
+[call [cmd ::doctools::toc::parse] [method {var set}] [arg name] [arg value]]
+
+This method adds the variable [arg name] to the set of predefined
+variables known to the [cmd vset] markup command during processing,
+and gives it the specified [arg value]. The method returns the empty
+string as its result.
+
+[call [cmd ::doctools::toc::parse] [method {var unset}] [arg name]]
+
+This method removes the variable [arg name] from the set of predefined
+variables known to the [cmd vset] markup command during
+processing. The method returns the empty string as its result.
+
+[call [cmd ::doctools::toc::parse] [method {var clear}] [opt [arg pattern]]]
+
+This method removes all variables matching the [arg pattern] from the
+set of predefined variables known to the [cmd vset] markup command
+during processing. The method returns the empty string as its result.
+
+[para]
+
+The pattern matching is done with [cmd {string match}], and the
+default pattern used when none is specified, is [const *].
+
+[list_end]
+
+[section {Parse errors}]
+
+The format of the parse error messages thrown when encountering
+violations of the [term doctoc] markup syntax is human readable and
+not intended for processing by machines. As such it is not documented.
+
+[para]
+
+[emph However], the errorCode attached to the message is
+machine-readable and has the following format:
+
+[list_begin enumerated]
+[enum]
+The error code will be a list, each element describing a single error
+found in the input. The list has at least one element, possibly more.
+
+[enum]
+Each error element will be a list containing six strings describing an
+error in detail. The strings will be
+
+[list_begin enumerated]
+[enum]
+The path of the file the error occured in. This may be empty.
+
+[enum]
+The range of the token the error was found at. This range is a
+two-element list containing the offset of the first and last character
+in the range, counted from the beginning of the input (file). Offsets
+are counted from zero.
+
+[enum]
+The line the first character after the error is on.
+Lines are counted from one.
+
+[enum]
+The column the first character after the error is at.
+Columns are counted from zero.
+
+[enum]
+The message code of the error. This value can be used as argument to
+[cmd msgcat::mc] to obtain a localized error message, assuming that
+the application had a suitable call of [cmd doctools::msgcat::init] to
+initialize the necessary message catalogs (See package
+[package doctools::msgcat]).
+
+[enum]
+A list of details for the error, like the markup command involved. In
+the case of message code [const doctoc/include/syntax] this value is
+the set of errors found in the included file, using the format
+described here.
+
+[list_end]
+[list_end]
+
+[include include/format/doctoc.inc]
+[include include/serialization.inc]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/doctools2toc/toc_structure.man b/tcllib/modules/doctools2toc/toc_structure.man
new file mode 100644
index 0000000..2e22128
--- /dev/null
+++ b/tcllib/modules/doctools2toc/toc_structure.man
@@ -0,0 +1,151 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin doctools::toc::structure n 0.1]
+[keywords deserialization]
+[keywords doctoc]
+[keywords doctools]
+[keywords serialization]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Documentation tools}]
+[titledesc {Doctoc serialization utilities}]
+[category {Documentation tools}]
+[require doctools::toc::structure [opt 0.1]]
+[require Tcl 8.4]
+[require logger]
+[require snit]
+[description]
+
+This package provides commands to work with the serializations of
+tables of contents as managed by the doctools system v2, and specified
+in section [sectref {ToC serialization format}].
+
+[para]
+
+This is an internal package of doctools, for use by the higher level
+packages handling tables of contents and their conversion into and out
+of various other formats, like documents written using [term doctoc]
+markup.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::doctools::toc::structure] [method verify] \
+ [arg serial] [opt [arg canonvar]]]
+
+This command verifies that the content of [arg serial] is a valid
+[term regular] serialization of a table of contents and will throw an
+error if that is not the case. The result of the command is the empty
+string.
+
+[para]
+
+If the argument [arg canonvar] is specified it is interpreted as the
+name of a variable in the calling context. This variable will be
+written to if and only if [arg serial] is a valid regular
+serialization. Its value will be a boolean, with [const True]
+indicating that the serialization is not only valid, but also
+[term canonical]. [const False] will be written for a valid, but
+non-canonical serialization.
+
+[para]
+
+For the specification of regular and canonical serializations see the
+section [sectref {ToC serialization format}].
+
+[call [cmd ::doctools::toc::structure] [method verify-as-canonical] \
+ [arg serial]]
+
+This command verifies that the content of [arg serial] is a valid
+[term canonical] serialization of a table of contents and will throw
+an error if that is not the case. The result of the command is the
+empty string.
+
+[para]
+
+For the specification of canonical serializations see the section
+[sectref {ToC serialization format}].
+
+[call [cmd ::doctools::toc::structure] [method canonicalize] [arg serial]]
+
+This command assumes that the content of [arg serial] is a valid
+[term regular] serialization of a table of contents and will throw an
+error if that is not the case.
+
+[para]
+
+It will then convert the input into the [term canonical] serialization
+of the contained table of contents and return it as its result. If the
+input is already canonical it will be returned unchanged.
+
+[para]
+
+For the specification of regular and canonical serializations see the
+section [sectref {ToC serialization format}].
+
+[call [cmd ::doctools::toc::structure] [method print] [arg serial]]
+
+This command assumes that the argument [arg serial] contains a valid
+regular serialization of a table of contents and returns a string
+containing that table in a human readable form.
+
+[para]
+
+The exact format of this form is not specified and cannot be relied on
+for parsing or other machine-based activities.
+
+[para]
+
+For the specification of regular serializations see the section
+[sectref {ToC serialization format}].
+
+[call [cmd ::doctools::toc::structure] [method merge] \
+ [arg seriala] [arg serialb]]
+
+This command accepts the regular serializations of two tables of
+contents and uses them to create their union. The result of the
+command is the canonical serialization of this unified table of
+contents.
+
+[para]
+Title and label of the resulting table are taken from the table
+contained in [arg serialb].
+
+[para]
+The whole table and its divisions are merged recursively in the same
+manner:
+
+[list_begin enumerated]
+
+[enum]
+All reference elements which occur in both divisions (identified by
+their label) are unified with document id's and descriptions taken
+from the second table.
+
+[enum]
+All division elements which occur in both divisions (identified by
+their label) are unified with the optional document id taken from the
+second table, if any, or from the first if none is in the second. The
+elements in the division are merged recursively using the same
+algorithm as described in this list.
+
+[enum]
+Type conflicts between elements, i.e. finding two elements with the
+same label but different types result in a merge error.
+
+[enum]
+All elements found in the second division but not in the first are
+added to the end of the list of elements in the merge result.
+[list_end]
+
+[para]
+
+For the specification of regular and canonical serializations see the
+section [sectref {ToC serialization format}].
+
+[list_end]
+
+[include include/serialization.inc]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/dtplite/ChangeLog b/tcllib/modules/dtplite/ChangeLog
new file mode 100644
index 0000000..0c64576
--- /dev/null
+++ b/tcllib/modules/dtplite/ChangeLog
@@ -0,0 +1,11 @@
+2013-04-04 Andreas Kupries <andreask@activestate.com>
+
+ * dtplite.man: [Feature 3609342]: Applied Ashok's patch to disable
+ * dtplite.tcl: the keyword index page when the processed
+ * pkgIndex.tcl: documentation does not contain keywords, with
+ modifications. Version bumped to 1.1.
+
+2013-02-22 Andreas Kupries <andreask@activestate.com>
+
+ * New module 'dtplite'. dtplite application-as-package.
+
diff --git a/tcllib/modules/dtplite/dtplite.tcl b/tcllib/modules/dtplite/dtplite.tcl
new file mode 100755
index 0000000..f3a4c3a
--- /dev/null
+++ b/tcllib/modules/dtplite/dtplite.tcl
@@ -0,0 +1,1764 @@
+# -*- tcl -*- \
+# @@ Meta Begin
+# Application dtplite 1.2
+# Meta platform tcl
+# Meta summary Lightweight DocTools Processor
+# Meta description This application is a simple processor
+# Meta description for documents written in the doctools
+# Meta description markup language. It covers the most
+# Meta description common use cases, but is not as
+# Meta description configurable as its big brother dtp.
+# Meta category Processing doctools documents
+# Meta subject doctools doctoc docidx
+# Meta require {doctools 1}
+# Meta require {doctools::idx 1}
+# Meta require {doctools::toc 1}
+# Meta require fileutil
+# Meta require textutil::repeat
+# Meta author Andreas Kupries
+# Meta license BSD
+# @@ Meta End
+
+package provide dtplite 1.3
+
+# dtp lite - Lightweight DocTools Processor
+# ======== = ==============================
+#
+# Use cases
+# ---------
+#
+# (1) Validation of a single manpage, i.e. checking that it is valid
+# doctools format.
+#
+# (1a) Getting a preliminary version of the formatted output, for
+# display in a browser, nroff, etc., proofreading the
+# formatting.
+#
+# (2) Generate documentation for a single package, i.e. all the
+# manpages, plus index and table of contents.
+#
+# (3) Generation of unified documentation for several
+# packages. Especially unified keyword index and table of
+# contents. This may additionally generate per-package TOCs
+# as well (Per-package indices don't make sense IMHO).
+#
+# Command syntax
+# --------------
+#
+# Ad 1) dtplite -o output format file
+#
+# The option -o specifies where to write the output to. Using
+# the string "-" as name of the output file causes the tool to
+# write the generated data to stdout. If $output is a directory
+# then a file named [[file rootname $file].$format] is written
+# to the directory.
+
+# Ad 1a) dtplite validate file
+#
+# The "validate" format does not generate output at all, only
+# syntax checking is performed.
+#
+# Ad 2) dtplite -o output format directory
+#
+# I.e. we distinguish (2) from (1) by the type of the input,
+# file, or directory. In this situation output has to be a
+# directory. Use the path "." to place the results into the
+# current directory.
+#
+# We locate _all_ files under directory, i.e. all subdirectories
+# are scanned as well. We replicate the found directory
+# structure in the output (See example below). The index and
+# table of contents are written to the toplevel directory in the
+# output. The names are hardwired to "toc.$format" and
+# "index.$format".
+#
+# Ad 3) dtplite -merge -o output format directory
+#
+# This can be treated as special case of (2). The -merge option
+# tells it that the output is nested one level deeper, to keep a
+# global toc and index in the toplevel and to merge the package
+# toc and index into them.
+#
+# This way the global documents are built up incrementally. This
+# can help us in a future extended installer as well!, extending
+# a global documentation tree of all installed packages.
+#
+# Additional features.
+#
+# * As described above the format name is used as the extension
+# for the generated files. Does it make sense to introduce an
+# option with which we can overide this, or should we simply
+# extect that a calling script does a proper renaming of all the
+# files ? ... The option is better. In HTML output we have
+# links between the files, and renaming from the outside just
+# breaks the links. This option is '-ext'. It is ignored if the
+# output is a single file (fully specified via -o), or stdout.
+#
+# -ext extension
+#
+# * Most of the formats don't need much/none of customizability.
+# I.e. text, nroff, wiki, tmml, ... For HTML however some
+# degree of customizability is required for good output. What
+# should we given to the user ?
+#
+# - Allow setting of a stylesheet.
+# - Allow integration of custom body header and footer html.
+# - Allow additional links for the navigation bar.
+# - Force module name, for when the directory name is wrong.
+# - Allow raw output, aka "embedded HTML", no head/body, just the body itself
+#
+# Note: The tool generates standard navigation bars to link the
+# all tocs, indices, and pages together.
+#
+# -style file
+# -header file
+# -footer file
+# -module name
+# -nav label url
+# -prenav label url
+# -postnav label url
+# -raw
+#
+# * The application may mis-detect files as doctools input.
+# And we cannot always mark them as non-doctools because
+# they may be such. Test cases, for example. To exclude
+# these we have the option '-exclude' taking a glob pattern.
+# Multiple uses of the option accumulate.
+#
+# -exclude glob
+#
+# * For tcllib itself we have external tools generating a nicer
+# TOC. Use option -toc to specify the doctoc file to use
+# _instead_ of generating our own. And using option -post+toc
+# and -pre+toc to _add_ more special toc's to the main
+# navbar. These latter mix with the -pre- and -postnav options.
+#
+# -toc path|text
+# -post+toc label path|text
+# -pre+toc label path|text
+#
+# That should be enough to allow the creation of good looking formatted
+# documentation without getting overly complex in both implementation
+# and use.
+
+package require doctools 1.4.11 ; # 'image' support, -ibase support
+package require doctools::idx 1.0.4 ;
+package require doctools::toc 1.1.3 ;
+package require fileutil
+package require textutil::repeat
+
+# ### ### ### ######### ######### #########
+## Internal data and status
+
+namespace eval ::dtplite {
+ variable print ::puts
+
+ # Path to where the output goes to. This is a file in case of mode
+ # 'file', irrelevant for mode 'file.stdout', and the directory for
+ # all the generated files for the two directory modes. Specified
+ # through the mandatory option '-o'.
+
+ variable output ""
+
+ # Path to where the documents to convert come from. This is a
+ # single file in the case of the two file modes, and a directory
+ # for the directory modes. In the later case all files under that
+ # directory are significant, including links, if identifiable as
+ # in doctools format (fileutil::fileType). Specified through the
+ # last argument on the command line. The relative path of a file
+ # under 'input' also becomes its relative path under 'output'.
+
+ variable input ""
+
+ # The extension to use for the generated files. Ignored by the
+ # file modes, as for them they either don't generate a file, or
+ # know its full name already, i.e. including any wanted
+ # extension. Set via option '-ext'. Defaults to the format name if
+ # '-ext' was not used.
+
+ variable ext ""
+
+ # Optional. HTML specific, requires engine parameter 'meta'. Path
+ # to a stylesheet file to use in the output. The file modes link
+ # to it using the original location, but the directory modes copy
+ # the file into the 'output' and link it there (to make the
+ # 'output' more selfcontained). Initially set via option '-style'.
+
+ variable style ""
+
+ # Optional. Path to a file. Contents of the file are assigned to
+ # engine parameter 'header', if present. If navigation buttons
+ # were defined their HTML will be appended to the file contents
+ # before doing the assignment. A specification is ignored if the
+ # engine does not support the parameter 'header'. Set via option
+ # '-header'.
+
+ variable header ""
+
+ # Like header, but for the document footer, and no navigation bar
+ # insert. Set via option '-footer', requires engine parameter
+ # 'footer'.
+
+ variable footer ""
+
+ # raw flag. When set "embedded HTML" is generated. Or whatever
+ # fits the definition for the active format.
+
+ variable raw off
+
+ # List of buttons/links for a navigation bar. No navigation bar is
+ # created if this is empty. HTML specific, requires engine
+ # parameter 'header' (The navigation bar is merged with the
+ # 'header' data, see above). Each element of the list is a
+ # 2-element list, containing the button label and url, in this
+ # order. Initial data comes from the command line, via options
+ # '-nav', '-prenav', and '-postnav'. The commands 'Navbutton(Push|Pop)'
+ # then allow the programmatic addition and removal of buttons at
+ # the left (stack like, top at end index). This is used for the
+ # insertion of links to TOC and Index into each document, if
+ # applicable.
+
+ variable nav {}
+ variable prenav {}
+ variable postnav {}
+
+ # The name of the format to convert the doctools documents
+ # into. Set via the next-to-last argument on the command
+ # line. Used as extension for the generated files as well by the
+ # directory modes, and if not overridden via '-ext'. See 'ext'
+ # above.
+
+ variable format ""
+
+ # Boolean flag. Set by the option '-merge'. Ignored when a file
+ # mode is detected, but for a directory it determines the
+ # difference between the two directory modes, i.e. plain
+ # generation, or incremental merging of many inputs into one
+ # output.
+
+ variable merge 0
+
+ # Boolean flag. Automatically set by code distinguishing between
+ # file and directory modes. Set for a the file modes, unset for
+ # the directory modes.
+
+ variable single 1
+
+ # Boolean flag. Automatically set by the code processing the '-o'
+ # option. Set if output is '-', unset otherwise. Ignored for the
+ # directory modes. Distinguished between the two file modes, i.e.
+ # writing to a file (unset), or stdout (set).
+
+ variable stdout 0
+
+ # Name of the found processing mode. Derived from the values of
+ # the three boolean flags (merge, single, stdout). This value is
+ # used during the dispatch to the command implementing the mode,
+ # after processing the command line.
+ #
+ # Possible/Legal values: Meaning
+ # --------------------- -------
+ # File File mode. Write result to a file.
+ # File.Stdout File mode. Write result to stdout.
+ # Directory Directory mode. Plain processing of one set.
+ # Directory.Merge Directory mode. Merging of multiple sets into
+ # one output.
+ # --------------------- -------
+
+ variable mode ""
+
+ # Name of the module currently processed. Derived from the 'input'
+ # (last element of this path, without extension).
+
+ variable module ""
+
+ # Crossreference data. Extracted from the processed documents, a
+ # rearrangement and filtration of the full meta data (See 'meta'
+ # below). Relevant only to the directory modes. I.e. the file
+ # modes don't bother with its extraction and use.
+
+ variable xref
+ array set xref {}
+
+ # Index data. Mapping from keyword (label) to the name of its
+ # anchor in the index output. Requires support for the engine
+ # parameter 'kwid' in the index engine.
+
+ variable kwid
+ array set kwid {}
+
+ # Cache. This array maps from the path of an input file/document
+ # (relative to 'input'), to the paths of the file to generate
+ # (relative to 'output', including extension and such). In other
+ # words we derive the output paths from the inputs only once and
+ # then simply get them here.
+
+ variable out
+ array set out {}
+
+ # Meta data cache. Stores the meta data extracted from the input
+ # files/documents, per input. The meta data is a dictionary and
+ # processed several ways to get: Crossreferences (See 'xref'
+ # above), Table Of Contents, and Keyword Index. The last two are
+ # not cached, but ephemeral.
+
+ variable meta
+ array set meta {}
+
+ # Cache of input documents. When we read an input file we store
+ # its contents here, keyed by path (relative to 'input') so that
+ # we don't have to go to the disk when we we need the file again.
+ # The directory modes need each input twice, for metadata
+ # extraction, and the actual conversion.
+
+ variable data
+ array set data {}
+
+ # Database of image files for use by dt_imap.
+
+ variable imap
+ array set imap {}
+
+ # Database of exclusion patterns. Files matching these are not
+ # manpages. For example, test files for doctools itself may fall
+ # under this.
+
+ variable excl {}
+
+ # Path of a user specified table of contents (doctoc format).
+
+ variable utoc {}
+
+ # List of path|text of additional TOCs to put into the navigation
+ # bar. Label and ordering information is found in the pre- and
+ # postnav lists. See above.
+
+ variable mtoc {}
+}
+
+# ### ### ### ######### ######### #########
+## External data and status
+#
+## Only the directory merge mode uses external data, saving the
+## internal representations of current toc, index. and xref
+## information for use by future mergers. It uses three files,
+## described below. The files are created if they don't exist.
+## Remove them when the merging is complete.
+#
+## .toc
+## Contains the current full toc in form of a dictionary.
+# Keys are division labels, values the lists of toc items.
+#
+## .idx
+## Contains the current full index, plus keyword id map. Is a list of
+# three elements, index, start id for new kwid entries, and the
+# keyword id map (kwid). Index and Kwid are both dictionaries, keyed
+# by keywords. Index value is a list of 2-tuples containing symbolic
+# file plus label, in this order. Kwid value is the id of the anchor
+# for that keyword in the index.
+#
+## .xrf
+## Contains the current cross reference database, a dictionary. Keys
+# are tags the formatter can search for (keywords, keywords with
+# prefixes, keywords with suffices), values a list containing either
+# the file to refer to to, or both file and an anchor in that
+# file. The latter is for references into the index.
+
+proc ::dtplite::Init {} {
+ variable data
+ variable excl {}
+ variable ext ""
+ variable footer ""
+ variable format ""
+ variable header ""
+ variable imap
+ variable input ""
+ variable kwid
+ variable merge 0
+ variable meta
+ variable mode ""
+ variable module ""
+ variable mtoc {}
+ variable nav {}
+ variable out
+ variable output ""
+ variable postnav {}
+ variable prenav {}
+ variable single 1
+ variable stdout 0
+ variable style ""
+ variable utoc {}
+ variable xref
+ variable xrefl
+
+ array unset data *
+ array unset imap *
+ array unset kwid *
+ array unset meta *
+ array unset out *
+ array unset xref *
+ catch { unset xrefl }
+
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Option processing.
+## Validate command line.
+## Full command line syntax.
+##
+# dtplite -o outputpath \
+# ?-merge? \
+# ?-raw? \
+# ?-ext ext? \
+# ?-style file? \
+# ?-header file? \
+# ?-footer file? \
+# ?-module name? \
+# ?-nav label url?... \
+# ?-prenav label url?... \
+# ?-postnav label url?... \
+# ?-exclude glob?... \
+# ?-toc path|text? \
+# ?-post+toc label path|text? \
+# ?-pre+toc label path|text? \
+# format inputpath
+##
+
+proc ::dtplite::ProcessCmdline {argv} {
+ variable output ; variable style ; variable stdout
+ variable format ; variable header ; variable single
+ variable input ; variable footer ; variable mode
+ variable ext ; variable nav ; variable merge
+ variable module ; variable excl ; variable utoc
+ variable prenav ; variable postnav ; variable mtoc
+ variable raw
+
+ # Process the options, perform basic validation.
+
+ set fixup {}
+ set muser false
+
+ while {[llength $argv]} {
+ set opt [lindex $argv 0]
+ if {![string match "-*" $opt]} break
+
+ if {[string equal $opt "-o"]} {
+ if {[llength $argv] < 2} Usage
+ set output [lindex $argv 1]
+ set argv [lrange $argv 2 end]
+ } elseif {[string equal $opt "-merge"]} {
+ set merge 1
+ set argv [lrange $argv 1 end]
+ } elseif {[string equal $opt "-raw"]} {
+ set raw on
+ set argv [lrange $argv 1 end]
+ } elseif {[string equal $opt "-ext"]} {
+ if {[llength $argv] < 2} Usage
+ set ext [lindex $argv 1]
+ set argv [lrange $argv 2 end]
+ } elseif {[string equal $opt "-toc"]} {
+ if {[llength $argv] < 2} Usage
+ set utoc [lindex $argv 1]
+ set argv [lrange $argv 2 end]
+ } elseif {[string equal $opt "-post+toc"]} {
+ if {[llength $argv] < 3} Usage
+ # Place toc data separate from the nav data, and identify
+ # by counter (list length). The nav data gets the file
+ # name (see Do.Directory* commands, marker (+TOC)). As
+ # relative paths they will be transformed during navbar
+ # generation to link properly.
+ set n [llength $mtoc]
+ set fname toc$n.$ext
+ if {$ext == {}} {
+ lappend fixup postnav [llength $postnav]
+ }
+ lappend postnav [list [lindex $argv 1] $fname]
+ lappend mtoc [lindex $argv 2]
+ set argv [lrange $argv 3 end]
+ } elseif {[string equal $opt "-pre+toc"]} {
+ if {[llength $argv] < 3} Usage
+ # Place toc data separate from the nav data, and identify
+ # by counter (list length). The nav data gets the file
+ # name (see Do.Directory* commands, marker (+TOC)). As
+ # relative paths they will be transformed during navbar
+ # generation to link properly.
+ set n [llength $mtoc]
+ set fname toc$n.$ext
+ if {$ext == {}} {
+ lappend fixup prenav [llength $prenav]
+ }
+ lappend prenav [list [lindex $argv 1] $fname]
+ lappend mtoc [lindex $argv 2]
+ set argv [lrange $argv 3 end]
+ } elseif {[string equal $opt "-exclude"]} {
+ if {[llength $argv] < 2} Usage
+ lappend excl [lindex $argv 1]
+ set argv [lrange $argv 2 end]
+ } elseif {[string equal $opt "-style"]} {
+ if {[llength $argv] < 2} Usage
+ set style [lindex $argv 1]
+ set argv [lrange $argv 2 end]
+ } elseif {[string equal $opt "-header"]} {
+ if {[llength $argv] < 2} Usage
+ set header [lindex $argv 1]
+ set argv [lrange $argv 2 end]
+ } elseif {[string equal $opt "-footer"]} {
+ if {[llength $argv] < 2} Usage
+ set footer [lindex $argv 1]
+ set argv [lrange $argv 2 end]
+ } elseif {[string equal $opt "-module"]} {
+ if {[llength $argv] < 2} Usage
+ set module [lindex $argv 1]
+ set argv [lrange $argv 2 end]
+ set muser true
+ } elseif {[string equal $opt "-nav"]} {
+ if {[llength $argv] < 3} Usage
+ lappend prenav [lrange $argv 1 2]
+ set argv [lrange $argv 3 end]
+ } elseif {[string equal $opt "-postnav"]} {
+ if {[llength $argv] < 3} Usage
+ lappend postnav [lrange $argv 1 2]
+ set argv [lrange $argv 3 end]
+ } elseif {[string equal $opt "-prenav"]} {
+ if {[llength $argv] < 3} Usage
+ lappend prenav [lrange $argv 1 2]
+ set argv [lrange $argv 3 end]
+ } else {
+ Usage
+ }
+ }
+
+ # Additional validation, and extraction of the non-option
+ # arguments.
+
+ if {[llength $argv] != 2} Usage
+
+ set format [lindex $argv 0]
+ set input [lindex $argv 1]
+
+ if {[string equal $format validate]} {
+ set format null
+ }
+
+ # Final validation across the whole configuration.
+
+ if {[string equal $format ""]} {
+ ArgError "Illegal empty format specification"
+
+ } else {
+ # Early check: Is the chosen format ok ? For this we have
+ # create and configure a doctools object.
+
+ doctools::new dt
+ if {[catch {dt configure -format $format}]} {
+ ArgError "Unknown format \"$format\""
+ }
+ dt configure -deprecated 1
+
+ # Check style, header, and footer options, if present.
+
+ CheckInsert header {Header file}
+ CheckInsert footer {Footer file}
+ CheckPresence raw {Raw flag}
+
+ if {[llength $nav] && ![in [dt parameters] header]} {
+ ArgError "-nav not supported by format \"$format\""
+ }
+ if {![string equal $style ""]} {
+ if {![in [dt parameters] meta]} {
+ ArgError "-style not supported by format \"$format\""
+ } elseif {![file exists $style]} {
+ ArgError "Unable to find style file \"$style\""
+ }
+ }
+ }
+
+ # Set up an extension based on the format, if no extension was
+ # specified. Also compute the name of the module, based on the
+ # input. [SF Tcllib Bug 1111364]. Has to come before the line
+ # marked with a [*], or a filename without extension is created.
+
+ if {[string equal $ext ""]} {
+ set ext $format
+ foreach {v i} $fixup {
+ upvar 0 $v navlist
+ set item [lindex $navlist $i]
+ set item [lreplace $item 1 1 [lindex $item 1]$ext]
+ set navlist [lreplace $navlist $i $i $item]
+ }
+ }
+
+ CheckInput $input {Input path}
+ if {[file isfile $input]} {
+ # Input file. Merge mode is not possible. Output can be file
+ # or directory, or "-" for stdout. The output may exist, but
+ # does not have to. The directory it is in however does have
+ # to exist, and has to be writable (if the output does not
+ # exist yet). An existing output has to be writable.
+
+ if {$merge} {
+ ArgError "-merge illegal when processing a single input file."
+ }
+ if {![string equal $output "-"]} {
+ CheckTheOutput
+
+ # If the output is an existing directory then we have to
+ # ensure that the actual output is a file in that
+ # directory, and we derive its name from the name of the
+ # input file (and -ext, if present).
+
+ if {[file isdirectory $output]} {
+ # [*] [SF Tcllib Bug 1111364]
+ set output [file join $output [file tail [Output $input]]]
+ }
+ } else {
+ set stdout 1
+ }
+ } else {
+ # Input directory. Merge mode is possible. Output has to be a
+ # directory. The output may exist, but does not have to. The
+ # directory it is in however does have to exist. An existing
+ # output has to be writable.
+
+ set single 0
+ CheckTheOutput 1
+ }
+
+ # Determine the operation mode from the flags
+
+ if {$single} {
+ if {$stdout} {
+ set mode File.Stdout
+ } else {
+ set mode File
+ }
+ } elseif {$merge} {
+ set mode Directory.Merge
+ } else {
+ set mode Directory
+ }
+
+ # Derive a module name iff user has not chosen any.
+ if {!$muser} {
+ set module [file rootname [file tail [file normalize $input]]]
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Option processing.
+## Helpers: Generation of error messages.
+## I. General usage/help message.
+## II. Specific messages.
+#
+# Both write their messages to stderr and then
+# exit the application with status 1.
+##
+
+proc ::dtplite::Usage {} {
+ global argv0
+ Print stderr "$argv0 wrong#args, expected:\
+ -o outputpath ?-merge? ?-raw? ?-ext ext?\
+ ?-style file? ?-header file?\
+ ?-footer file? ?-module string? ?-nav label url?...\
+ format inputpath"
+ return -code error -errorcode {DTPLITE STOP} {}
+}
+
+proc ::dtplite::ArgError {text} {
+ global argv0
+ Print stderr "$argv0: $text"
+ return -code error -errorcode {DTPLITE STOP} {}
+}
+
+proc ::dtplite::Print {args} {
+ variable print
+ set cmd [concat $print $args]
+ return [uplevel 1 $cmd]
+}
+
+proc in {list item} {
+ expr {([lsearch -exact $list $item] >= 0)}
+}
+
+# ### ### ### ######### ######### #########
+## Helper commands. File paths.
+## Conversion of relative paths
+## to absolute ones for input
+## and output. Derivation of
+## output file name from input.
+
+proc ::dtplite::Pick {f} {
+ variable input
+ return [file join $input $f]
+}
+
+proc ::dtplite::Output {f} {
+ variable ext
+ return [file rootname $f].$ext
+}
+
+proc ::dtplite::At {f} {
+ variable output
+ set of [file normalize [file join $output $f]]
+ file mkdir [file dirname $of]
+ return $of
+}
+
+# ### ### ### ######### ######### #########
+## Check existence and permissions of an input/output file or
+## directory.
+
+proc ::dtplite::CheckInput {f label} {
+ if {![file exists $f]} {
+ ArgError "Unable to find $label \"$f\""
+ } elseif {![file readable $f]} {
+ ArgError "$label \"$f\" not readable (permission denied)"
+ }
+ return
+}
+
+proc ::dtplite::CheckTheOutput {{needdir 0}} {
+ variable output
+ variable format
+
+ if {[string equal $format null]} {
+ # The format does not generate output, so not specifying an
+ # output file is ok for that case.
+ return
+ }
+
+ if {[string equal $output ""]} {
+ ArgError "No output path specified"
+ }
+
+ set base [file dirname $output]
+ if {[string equal $base ""]} {set base [pwd]}
+
+ if {![file exists $output]} {
+ if {![file exists $base]} {
+ ArgError "Output base path \"$base\" not found"
+ }
+ if {![file writable $base]} {
+ ArgError "Output base path \"$base\" not writable (permission denied)"
+ }
+ } else {
+ if {![file writable $output]} {
+ ArgError "Output path \"$output\" not writable (permission denied)"
+ }
+ if {$needdir && ![file isdirectory $output]} {
+ ArgError "Output path \"$output\" not a directory"
+ }
+ }
+ return
+}
+
+proc ::dtplite::CheckInsert {option label} {
+ variable format
+ variable $option
+ upvar 0 $option opt
+
+ if {![string equal $opt ""]} {
+ if {![in [dt parameters] $option]} {
+ ArgError "-$option not supported by format \"$format\""
+ }
+ CheckInput $opt $label
+ set opt [Get $opt]
+ }
+ return
+}
+
+proc ::dtplite::CheckPresence {option label} {
+ variable format
+ variable $option
+ upvar 0 $option opt
+
+ if {$opt} {
+ if {![in [dt parameters] $option]} {
+ ArgError "-$option not supported by format \"$format\""
+ }
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Helper commands. File reading and writing.
+
+proc ::dtplite::Get {f} {
+ variable data
+ if {[info exists data($f)]} {return $data($f)}
+ return [set data($f) [fileutil::cat $f]]
+}
+
+proc ::dtplite::Write {f data} {
+ # An empty filename is acceptable, the format will be 'null'
+ if {[string equal $f ""]} return
+ fileutil::writeFile $f $data
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Dump accumulated warnings.
+
+proc ::dtplite::Warnings {} {
+ set warnings [dt warnings]
+ if {[llength $warnings] > 0} {
+ Print stderr [join $warnings \n]
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Configuation phase, validate command line.
+
+# ### ### ### ######### ######### #########
+## We can assume that we have from here on a command 'dt', which is a
+## doctools object command, and already configured for the format to
+## generate.
+# ### ### ### ######### ######### #########
+
+# ### ### ### ######### ######### #########
+## Commands implementing the main functionality.
+
+proc ::dtplite::Do.File {} {
+ # Process a single input file, write the result to a single outut file.
+
+ variable input
+ variable output
+
+ SinglePrep
+ Write $output [dt format [Get $input]]
+ Warnings
+ return
+}
+
+proc ::dtplite::Do.File.Stdout {} {
+ # Process a single input file, write the result to stdout.
+
+ variable input
+
+ SinglePrep
+ puts stdout [dt format [Get $input]]
+ close stdout
+ Warnings
+ return
+}
+
+proc ::dtplite::Do.Directory {} {
+ # Process a directory of input files, through all subdirectories.
+ # Generate index and toc, but no merging with an existing index
+ # and toc. I.e. any existing index and toc files are overwritten.
+
+ variable input
+ variable out
+ variable module
+ variable meta
+ variable format
+ variable utoc
+ variable mtoc
+
+ # Phase 0. Find the documents to convert.
+ # Phase I. Collect meta data, and compute the map from input to
+ # ........ output files. This is also the map for the symbolic
+ # ........ references. We extend an existing map (required for use
+ # ........ in merge op.
+ # Phase II. Build index and toc information from the meta data.
+ # Phase III. Convert each file, using index, toc and meta
+ # .......... information.
+
+ MapImages
+ set files [LocateManpages $input]
+ if {![llength $files]} {
+ ArgError "Module \"$module\" has no files to process."
+ }
+
+ MetadataGet $files
+ StyleMakeLocal
+
+ # Attention, ordering! Ensure that 'kwid' is initialized before
+ # testing it with 'HaveKeywords' everywhere we configure the links
+ # showns in the navigation bar.
+
+ set idx [IdxGenerate $module [IdxGet]]
+
+ if {$utoc ne {}} {
+ if {[file exists $utoc]} { set utoc [Get $utoc] }
+ TocWrite toc index $utoc
+ } else {
+ TocWrite toc index [TocGenerate [TocGet $module toc]]
+ }
+ # (+TOC)
+ set n 0
+ foreach item $mtoc {
+ if {[file exists $item]} { set item [Get $item] }
+ TocWrite toc$n index $item
+ incr n
+ }
+ IdxWrite index toc $idx
+
+ dt configure -module $module
+ XrefGet
+ XrefSetup dt
+ FooterSetup dt
+ MapSetup dt
+
+ foreach f [lsort -dict $files] {
+ Print stdout \t$f
+
+ set o $out($f)
+ dt configure -file [At $o] -ibase $input/$f
+
+ if {[HaveKeywords]} {
+ NavbuttonPush {Keyword Index} [Output index] $o
+ }
+ NavbuttonPush {Table Of Contents} [Output toc] $o
+ HeaderSetup dt $o
+ NavbuttonPop
+ if {[HaveKeywords]} {
+ NavbuttonPop
+ }
+ StyleSetup dt $o
+
+ if {[string equal $format null]} {
+ dt format [Get [Pick $f]]
+ } else {
+ Write [At $o] [dt format [Get [Pick $f]]]
+ }
+ Warnings
+ }
+ return
+}
+
+proc ::dtplite::Do.Directory.Merge {} {
+ # See Do.Directory, but merge the TOC/Index information from this
+ # set of input files into an existing TOC/Index.
+
+ variable input
+ variable out
+ variable module
+ variable meta
+ variable output
+ variable format
+ variable utoc
+ variable mtoc
+
+ # Phase 0. Find the documents to process.
+ # Phase I. Collect meta data, and compute the map from input to
+ # ........ output files. This is also the map for the symbolic
+ # ........ references. We extend an existing map (required for use
+ # ........ in merge op.
+ # Phase II. Build module local toc from the meta data, insert it
+ # ......... into the main toc as well, and generate a global
+ # ......... index.
+ # Phase III. Process each file, using cross references, and links
+ # .......... to boths tocs and the index.
+
+ MapImages
+ set files [LocateManpages $input]
+ if {![llength $files]} {
+ ArgError "Module \"$module\" has no files to process."
+ }
+
+ MetadataGet $files $module
+ StyleMakeLocal $module
+
+ # Attention, ordering! Ensure that 'kwid' is initialized before
+ # testing it with 'HaveKeywords' everywhere we configure the links
+ # showns in the navigation bar.
+
+ set idx [IdxGenerate {} [IdxGetSaved index]]
+
+ set localtoc [TocGet $module $module/toc]
+ TocWrite $module/toc index [TocGenerate $localtoc] [TocMap $localtoc]
+ if {$utoc ne {}} {
+ if {[file exists $utoc]} { set utoc [Get $utoc] }
+ TocWrite toc index $utoc
+ } else {
+ TocWrite toc index [TocGenerate [TocMergeSaved $localtoc]]
+ }
+ # (+TOC)
+ set n 0
+ foreach item $mtoc {
+ if {[file exists $item]} { set item [Get $item] }
+ TocWrite toc$n index $item
+ incr n
+ }
+ IdxWrite index toc $idx
+
+ dt configure -module $module
+ XrefGetSaved
+ XrefSetup dt
+ FooterSetup dt
+ MapSetup dt
+
+ foreach f [lsort -dict $files] {
+ Print stdout \t$f
+
+ set o $out($f)
+ dt configure -file [At $o] -ibase $input/$f
+ if {[HaveKeywords]} {
+ NavbuttonPush {Keyword Index} [Output index] $o
+ }
+ NavbuttonPush {Table Of Contents} [Output $module/toc] $o
+ NavbuttonPush {Main Table Of Contents} [Output toc] $o
+ HeaderSetup dt $o
+ NavbuttonPop
+ NavbuttonPop
+ if {[HaveKeywords]} {
+ NavbuttonPop
+ }
+ StyleSetup dt $o
+
+ if {[string equal $format null]} {
+ dt format [Get [Pick $f]]
+ } else {
+ Write [At $o] [dt format [Get [Pick $f]]]
+ }
+ Warnings
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Helper commands. Preparations shared between the two file modes.
+
+proc ::dtplite::SinglePrep {} {
+ variable input
+ variable module
+
+ MapImages
+ StyleSetup dt
+ HeaderSetup dt {}
+ FooterSetup dt
+ MapSetup dt
+
+ dt configure -module $module -file $input
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Get the base meta data out of the listed documents.
+
+proc ::dtplite::MetadataGet {files {floc {}}} {
+ # meta :: map (symbolicfile -> metadata)
+ # metadata = dict (key -> value)
+ # key = set { desc, fid, file, keywords,
+ # module, section, see_also,
+ # shortdesc, title, version }
+ # desc :: string 'document title'
+ # fid :: string 'file name, without path/extension'
+ # file :: string 'file name, without path'
+ # keywords :: list (string...) 'key phrases'
+ # module :: string 'module the file is in'
+ # section :: string 'manpage section'
+ # see_also :: list (string...) 'related files'
+ # shortdesc :: string 'module description'
+ # title :: string 'manpage file name intended'
+ # version :: string 'file/package version'
+ variable meta
+ variable input
+ variable out
+
+ doctools::new meta -format list -deprecated 1
+ foreach f $files {
+ meta configure -file $input/$f
+ set o [Output [file join $floc files $f]]
+ set out($f) $o
+ set meta($o) [lindex [string trim [meta format [Get [Pick $f]]]] 1]
+ }
+ meta destroy
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Handling Tables of Contents:
+## - Get them out of the base meta data.
+## - As above, and merging them with global toc.
+## - Conversion of internals into doctoc.
+## - Processing doctoc into final formatting.
+
+proc ::dtplite::TocGet {desc {f toc}} {
+ # Generate the intermediate form of a TOC for the current document
+ # set. This generates a single division.
+
+ # Get toc out of the meta data.
+ variable meta
+ set res {}
+ foreach {k item} [array get meta] {
+ lappend res [TocItem $k $item]
+ }
+ return [list $desc [list $f $res]]
+}
+
+proc ::dtplite::TocMap {toc {base {}}} {
+ if {$base == {}} {
+ set base [lindex [lindex $toc 1] 0]
+ }
+ set items [lindex [lindex $toc 1] 1]
+
+ set res {}
+ foreach i $items {
+ foreach {f label desc} $i break
+ lappend res $f [fileutil::relativeUrl $base $f]
+ }
+ return $res
+}
+
+proc ::dtplite::TocItem {f meta} {
+ array set md $meta
+ set desc $md(desc)
+ set label $md(title)
+ return [list $f $label $desc]
+}
+
+proc ::dtplite::TocMergeSaved {sub} {
+ # sub is the TOC of the current doc set (local toc). Merge this
+ # into the main toc (as read from the saved global state), and
+ # return the resulting internal rep for further processing.
+
+ set fqn [At .toc]
+ if {[file exists $fqn]} {
+ array set _ [Get $fqn]
+ }
+ array set _ $sub
+ set thetoc [array get _]
+
+ # Save extended toc for next merge.
+ Write $fqn $thetoc
+
+ return $thetoc
+}
+
+proc ::dtplite::TocGenerate {data} {
+ # Handling single and multiple divisions.
+ # single div => div is full toc
+ # multi div => place divs into the toc in alpha order.
+ #
+ # Sort toc (each division) by label (index 1).
+ # Write as doctoc.
+
+ array set toc $data
+
+ TagsBegin
+ if {[array size toc] < 2} {
+ # Empty, or single division. The division is the TOC, toplevel.
+
+ unset toc
+ set desc [lindex $data 0]
+ set data [lindex [lindex $data 1] 1]
+ TocAlign mxf mxl $data
+
+ Tag+ toc_begin [list {Table Of Contents} $desc]
+ foreach item [lsort -dict -index 1 $data] {
+ foreach {symfile label desc} $item break
+ Tag+ item \
+ [FmtR mxf $symfile] \
+ [FmtR mxl $label] \
+ [list $desc]
+ }
+ } else {
+ Tag+ toc_begin [list {Table Of Contents} Modules]
+ foreach desc [lsort -dict [array names toc]] {
+ foreach {ref div} $toc($desc) break
+ TocAlign mxf mxl $div
+
+ Tag+ division_start [list $desc [Output $ref]]
+ foreach item [lsort -dict -index 1 $div] {
+ foreach {symfile label desc} $item break
+ Tag+ item \
+ [FmtR mxf $symfile] \
+ [FmtR mxl $label] \
+ [list $desc]
+ }
+ Tag+ division_end
+ }
+ }
+
+ Tag+ toc_end
+
+ #puts ____________________\n[join $lines \n]\n_________________________
+ return [join $lines \n]\n
+}
+
+proc ::dtplite::TocWrite {ftoc findex text {map {}}} {
+ variable format
+
+ if {[string equal $format null]} return
+ Write [At .tocdoc] $text
+
+ set ft [Output $ftoc]
+
+ doctools::toc::new toc -format $format -file $ft
+ if {[HaveKeywords]} {
+ NavbuttonPush {Keyword Index} [Output $findex] $ftoc
+ }
+ HeaderSetup toc $ft
+ if {[HaveKeywords]} {
+ NavbuttonPop
+ }
+ FooterSetup toc
+ StyleSetup toc $ftoc
+
+ foreach {k v} $map {toc map $k $v}
+
+ Write [At $ft] [toc format $text]
+ toc destroy
+ return
+}
+
+proc ::dtplite::TocAlign {fv lv div} {
+ upvar 1 $fv mxf $lv mxl
+ set mxf 0
+ set mxl 0
+ foreach item $div {
+ foreach {symfile label desc} $item break
+ Max mxf $symfile
+ Max mxl $label
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Handling Keyword Indices:
+## - Get them out of the base meta data.
+## - As above, and merging them with global index.
+## - Conversion of internals into docidx.
+## - Processing docidx into final formatting.
+
+proc ::dtplite::IdxGet {{f index}} {
+ # Get index out of the meta data.
+ array set keys {}
+ array set kdup {}
+ return [lindex [IdxExtractMeta] 1]
+}
+
+proc ::dtplite::IdxGetSaved {{f index}} {
+ # Get index out of the meta data, merge into global state.
+ variable meta
+ variable kwid
+
+ array set keys {}
+ array set kwid {}
+ array set kdup {}
+ set start 0
+
+ set fqn [At .idx]
+ if {[file exists $fqn]} {
+ foreach {kw kd start ki} [Get $fqn] break
+ array set keys $kw
+ array set kwid $ki
+ array set kdup $kd
+ }
+
+ foreach {start theindex} [IdxExtractMeta $start] break
+
+ # Save extended index for next merge.
+ Write $fqn [list $theindex [array get kdup] $start [array get kwid]]
+
+ return $theindex
+}
+
+proc ::dtplite::IdxExtractMeta {{start 0}} {
+ # Get index out of the meta data.
+ variable meta
+ variable kwid
+
+ upvar keys keys kdup kdup
+ foreach {k item} [array get meta] {
+ foreach {symfile keywords label} [IdxItem $k $item] break
+ # Store inverted file - keyword relationship
+ # Kdup is used to prevent entering of duplicates.
+ # Checks full (keyword file label).
+ foreach k $keywords {
+ set kx [list $k $symfile $label]
+ if {![info exists kdup($kx)]} {
+ lappend keys($k) [list $symfile $label]
+ set kdup($kx) .
+ }
+ if {[info exist kwid($k)]} continue
+ set kwid($k) key$start
+ incr start
+ }
+ }
+ return [list $start [array get keys]]
+}
+
+proc ::dtplite::IdxItem {f meta} {
+ array set md $meta
+ set keywords $md(keywords)
+ set title $md(title)
+ return [list $f $keywords $title]
+}
+
+proc ::dtplite::IdxGenerate {desc data} {
+ # Sort by keyword label.
+ # Write as docidx.
+
+ array set keys $data
+
+ TagsBegin
+ Tag+ index_begin [list {Keyword Index} $desc]
+
+ foreach k [lsort -dict [array names keys]] {
+ IdxAlign mxf $keys($k)
+
+ Tag+ key [list $k]
+ foreach v [lsort -dict -index 1 $keys($k)] {
+ foreach {file label} $v break
+ Tag+ manpage [FmtR mxf $file] [list $label]
+ }
+ }
+
+ Tag+ index_end
+ #puts ____________________\n[join $lines \n]\n_________________________
+ return [join $lines \n]\n
+}
+
+proc ::dtplite::IdxWrite {findex ftoc text} {
+ variable format
+
+ if {[string equal $format null]} return
+ if {![HaveKeywords]} return
+
+ Write [At .idxdoc] $text
+
+ set fi [Output $findex]
+
+ doctools::idx::new idx -format $format -file $fi
+
+ NavbuttonPush {Table Of Contents} [Output $ftoc] $findex
+ HeaderSetup idx $findex
+ NavbuttonPop
+ FooterSetup idx
+ StyleSetup idx $findex
+ XrefSetupKwid idx
+
+ Write [At $fi] [idx format $text]
+ idx destroy
+ return
+}
+
+proc ::dtplite::IdxAlign {v keys} {
+ upvar 1 $v mxf
+ set mxf 0
+ foreach item $keys {
+ foreach {symfile label} $item break
+ Max mxf $symfile
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Detect presence of keywords.
+
+proc ::dtplite::HaveKeywords {} {
+ variable kwid
+ array size kwid
+}
+
+# ### ### ### ######### ######### #########
+## Column sizing
+
+proc ::dtplite::Max {v str} {
+ upvar 1 $v max
+ set l [string length [list $str]]
+ if {$max < $l} {set max $l}
+ return
+}
+
+proc ::dtplite::FmtR {v str} {
+ upvar 1 $v max
+ return [list $str][textutil::repeat::blank \
+ [expr {$max - [string length [list $str]]}]]
+}
+
+# ### ### ### ######### ######### #########
+## Code generation.
+
+proc ::dtplite::Tag {n args} {
+ if {[llength $args]} {
+ return "\[$n [join $args]\]"
+ } else {
+ return "\[$n\]"
+ }
+ #return \[[linsert $args 0 $n]\]
+}
+
+proc ::dtplite::Tag+ {n args} {
+ upvar 1 lines lines
+ lappend lines [eval [linsert $args 0 ::dtplite::Tag $n]]
+ return
+}
+
+proc ::dtplite::TagsBegin {} {
+ upvar 1 lines lines
+ set lines {}
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Collect all files for possible use as image
+
+proc ::dtplite::MapImages {} {
+ variable input
+ variable output
+ variable single
+ variable stdout
+
+ # Ignore images when writing results to a pipe.
+ if {$stdout} return
+
+ set out [file normalize $output]
+ set path [file normalize $input]
+ set res {}
+
+ if {$single} {
+ # output is file, image directory is sibling to it.
+ set imgbase [file join [file dirname $output] image]
+ # input to search is director the input file is in, and below
+ set path [file dirname $path]
+ } else {
+ # output is directory, image directory is inside.
+ set imgbase [file join $out image]
+ }
+
+ set n [llength [file split $path]]
+
+ foreach f [::fileutil::find $path] {
+ MapImage \
+ [::fileutil::stripN $f $n] \
+ $f [file join $imgbase [file tail $f]]
+ }
+ return
+}
+
+proc ::dtplite::MapImage {path orig dest} {
+ # A file a/b/x.y is stored under
+ # a/b/x.y, b/x.y, and x.y
+
+ variable imap
+ set plist [file split $path]
+ while {[llength $plist]} {
+ set imap([join $plist /]) [list $orig $dest]
+ set plist [lrange $plist 1 end]
+ }
+ return
+}
+
+proc ::dtplite::MapSetup {dt} {
+ # imap :: map (symbolicfile -> list (originpath,destpath)))
+ variable imap
+ # Skip if no data available
+
+ #puts MIS|[array size imap]|
+ if {![array size imap]} return
+
+ foreach sf [array names imap] {
+ foreach {origin destination} $imap($sf) break
+ $dt img $sf $origin $destination
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Find the documents to process.
+
+proc ::dtplite::LocateManpages {path} {
+ set path [file normalize $path]
+ set n [llength [file split $path]]
+ set res {}
+ foreach f [::fileutil::find $path ::dtplite::IsDoctools] {
+ lappend res [::fileutil::stripN $f $n]
+ }
+ return $res
+}
+
+proc ::dtplite::IsDoctools {f} {
+ set res [expr {[in [::fileutil::fileType $f] doctools] && ![Excluded [file normalize $f]]}]
+ #puts ...$f\t$res\t|[fileutil::fileType $f]|\texcluded=[Excluded [file normalize $f]]\tin.[pwd]
+ return $res
+}
+
+proc ::dtplite::Excluded {f} {
+ variable excl
+ foreach p $excl {
+ if {[string match $p $f]} {return 1}
+ }
+ return 0
+}
+
+# ### ### ### ######### ######### #########
+## Handling a style sheet
+## - Decoupling output from input location.
+## - Generate HTML to insert into a generated document.
+
+proc ::dtplite::StyleMakeLocal {{pfx {}}} {
+ variable style
+ if {[string equal $style ""]} return
+ set base [file join $pfx [file tail $style]]
+
+ # TODO input == output does what here ?
+
+ file copy -force $style [At $base]
+ set style $base
+ return
+}
+
+proc ::dtplite::StyleSetup {o {f {}}} {
+ variable style
+ if {[string equal $style ""]} return
+ if {![in [$o parameters] meta]} return
+
+ if {![string equal $f ""]} {
+ set dst [fileutil::relativeUrl $f $style]
+ } else {
+ set dst $style
+ }
+ set value "<link\
+ rel=\"stylesheet\"\
+ href=\"$dst\"\
+ type=\"text/css\">"
+
+ $o setparam meta $value
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Handling the cross references
+## - Getting them out of the base meta data.
+## - ditto, plus merging with saved xref information.
+## - Insertion into processor, cached list.
+## - Setting up the keyword-2-anchor map.
+
+proc ::dtplite::XrefGet {} {
+ variable meta
+ variable xref
+ variable kwid
+
+ array set keys {}
+ foreach {symfile item} [array get meta] {
+ array set md $item
+ # Cross-references ... File based, see-also
+
+ set t $md(title)
+ set ts ${t}($md(section))
+ set td $md(desc)
+
+ set xref(sa,$t) [set _ [list $symfile]]
+ set xref(sa,$ts) $_
+ set xref($t) $_ ; # index on manpage file name
+ set xref($ts) $_ ; # ditto, with section added
+ set xref($td) $_ ; # index on document title
+
+ # Store an inverted file - keyword relationship, for the index
+ foreach kw $md(keywords) {
+ lappend keys($kw) $symfile
+ }
+ }
+
+ set if [Output index]
+ foreach k [array names keys] {
+ if {[info exists xref(kw,$k)]} continue
+
+ set frag $kwid($k)
+ set xref(kw,$k) [set _ [list $if $frag]]
+ set xref($k) $_
+ }
+ return
+}
+
+proc ::dtplite::XrefGetSaved {} {
+ # xref :: map (xrefid -> list (symbolicfile))
+ variable xref
+ array set xref {}
+
+ # Load old cross references, from a previous run
+ set fqn [At .xrf]
+ if {[file exists $fqn]} {
+ array set xref [set s [Get $fqn]]
+ }
+
+ # Add any new cross references ...
+ XrefGet
+ Write $fqn [array get xref]
+ return
+}
+
+proc ::dtplite::XrefSetup {o} {
+ # xref :: map (xrefid -> list (symbolicfile))
+ variable xref
+ # Skip if no data available
+ if {![array size xref]} return
+ # Skip if backend doesn't support an index
+ if {![in [$o parameters] xref]} return
+
+ # Transfer index data to the backend. The data we keep has to be
+ # re-formatted from a dict into a list of tuples with leading
+ # xrefid.
+
+ # xrefl :: list (list (xrefid symbolicfile...)...)
+ variable xrefl
+ if {![info exist xrefl]} {
+ set xrefl {}
+ foreach k [array names xref] {
+ lappend xrefl [linsert $xref($k) 0 $k]
+ set f [lindex $xref($k) 0]
+ dt map $f [At $f]
+ }
+ }
+ $o setparam xref $xrefl
+ return
+}
+
+proc ::dtplite::XrefSetupKwid {o} {
+ # kwid :: map (label -> anchorname)
+ variable kwid
+ # Skip if no data available
+ if {![array size kwid]} return
+ # Skip if backend doesn't support an index
+ if {![in [$o parameters] kwid]} return
+ # Transfer index data to the backend
+ $o setparam kwid [array get kwid]
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Extending and shrinking the navigation bar.
+
+proc ::dtplite::NavbuttonPush {label file ref} {
+ # nav = list (list (label reference) ...)
+ variable nav
+ #set file [fileutil::relativeUrl $ref $file]]]
+ set nav [linsert $nav 0 [list $label $file]]
+ return
+}
+
+proc ::dtplite::NavbuttonPop {} {
+ # nav = list (list (label reference) ...)
+ variable nav
+ set nav [lrange $nav 1 end]
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Header/Footer mgmt
+## Header is merged from regular header, plus nav bar.
+## Caching the merge result for quicker future access.
+
+proc ::dtplite::HeaderSetup {o ref} {
+ variable header
+ variable nav
+ variable prenav
+ variable postnav
+ variable raw
+
+ # Activate raw mode, if supported and requested.
+ if {[in [$o parameters] raw] && $raw} {
+ $o setparam raw 1
+ }
+
+ # We cannot generate a navigation bar if the output format does
+ # not support a "header".
+ if {![in [$o parameters] header]} return
+
+ # Do not generate a navigation bar if no content was specified for
+ # it, at all.
+ if {![llength $prenav] &&
+ ![llength $postnav] &&
+ ![llength $nav] &&
+ [string equal $header ""]} return
+
+ $o setparam header [Navbar $nav $ref]
+ return
+}
+
+proc ::dtplite::Navbar {nav ref} {
+ variable header
+ variable prenav
+ variable postnav
+
+ set sep 0
+ set first 1
+ set hdr ""
+
+ append hdr [NavbarSegment sep first $prenav $ref]
+ append hdr [NavbarSegment sep first $nav $ref]
+ append hdr [NavbarSegment sep first $postnav $ref]
+
+ if {[string length $hdr]} {
+ set hdr "<hr> \[\n $hdr \] <hr>\n"
+ }
+ if {![string equal $header ""]} {
+ set hdr "$header $hdr"
+ }
+ return $hdr
+}
+
+proc ::dtplite::NavbarSegment {sepv firstv nav ref} {
+ if {![llength $nav]} { return {} }
+ upvar 1 $sepv sep $firstv first
+
+ if {$sep} {append hdr <br>\n}
+ set sep 0
+
+ foreach item $nav {
+ if {!$first} {append hdr "| "} else {append hdr " "}
+ set first 0
+ foreach {label url} $item break
+
+ if {[string length $ref] &&
+ ![string match *://* $url] &&
+ ![string match /* $url]} {
+ # The specified url is a plain relative path and we have a
+ # proper referent. We assume that this path is relative
+ # to the toplevel toc and index files we are generating,
+ # and transform it here to be relative to the referent
+ # instead.
+ set url [fileutil::relativeUrl $ref $url]
+ }
+ append hdr "<a href=\"" $url "\">" $label "</a>\n"
+ }
+ return $hdr
+}
+
+proc ::dtplite::FooterSetup {o} {
+ variable footer
+ if {[string equal $footer ""]} return
+ if {![in [$o parameters] footer]} return
+ $o setparam footer $footer
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Invoking the functionality.
+
+proc ::dtplite::print-via {cmd} {
+ variable print $cmd
+ return
+}
+
+proc ::dtplite::do {arguments} {
+ Init
+
+ if {[catch {
+ ProcessCmdline $arguments
+ }]} {
+ return 1
+ }
+ if {[catch {
+ set mode $::dtplite::mode
+ Do.$mode
+ } msg]} {
+ ## puts $::errorInfo
+ dt destroy
+ ArgError $msg
+ return 1
+ }
+ dt destroy
+ return 0
+}
+
+# ### ### ### ######### ######### #########
+return
+
diff --git a/tcllib/modules/dtplite/pkgIndex.tcl b/tcllib/modules/dtplite/pkgIndex.tcl
new file mode 100644
index 0000000..6683b1d
--- /dev/null
+++ b/tcllib/modules/dtplite/pkgIndex.tcl
@@ -0,0 +1,5 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ # PRAGMA: returnok
+ return
+}
+package ifneeded dtplite 1.3 [list source [file join $dir dtplite.tcl]]
diff --git a/tcllib/modules/dtplite/pkg_dtplite.man b/tcllib/modules/dtplite/pkg_dtplite.man
new file mode 100644
index 0000000..877b8e5
--- /dev/null
+++ b/tcllib/modules/dtplite/pkg_dtplite.man
@@ -0,0 +1,449 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset PACKAGE_VERSION 1.3]
+[manpage_begin dtplite n [vset PACKAGE_VERSION]]
+[see_also {docidx introduction}]
+[see_also {doctoc introduction}]
+[see_also {doctools introduction}]
+[keywords conversion]
+[keywords docidx]
+[keywords doctoc]
+[keywords doctools]
+[keywords HTML]
+[keywords manpage]
+[keywords markup]
+[keywords nroff]
+[keywords TMML]
+[copyright {2004-2013 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[titledesc {Lightweight DocTools Markup Processor}]
+[moddesc {Documentation toolbox}]
+[category {Documentation tools}]
+[require dtplite [opt [vset PACKAGE_VERSION]]]
+[description]
+[para]
+
+The application described by this document, [syscmd dtplite], is the
+successor to the extremely simple [syscmd mpexpand]. Influenced in its
+functionality by the [syscmd dtp] doctools processor it is much more
+powerful than [syscmd mpexpand], yet still as easy to use; definitely
+easier than [syscmd dtp] with its myriad of subcommands and options.
+
+[para]
+
+[syscmd dtplite] is based upon the package [package doctools], like
+the other two processors.
+
+[subsection {USE CASES}]
+
+[syscmd dtplite] was written with the following three use cases in
+mind.
+
+[para]
+[list_begin enumerated]
+[enum]
+Validation of a single document, i.e. checking that it was written in
+valid doctools format. This mode can also be used to get a preliminary
+version of the formatted output for a single document, for display in
+a browser, nroff, etc., allowing proofreading of the formatting.
+
+[enum]
+Generation of the formatted documentation for a single package,
+i.e. all the manpages, plus a table of contents and an index of
+keywords.
+
+[enum]
+An extension of the previous mode of operation, a method for the easy
+generation of one documentation tree for several packages, and
+especially of a unified table of contents and keyword index.
+
+[list_end]
+
+[para]
+
+Beyond the above we also want to make use of the customization
+features provided by the HTML formatter. It is not the only format the
+application should be able to generate, but we anticipiate it to be
+the most commonly used, and it is one of the few which do provide
+customization hooks.
+
+[para]
+
+We allow the caller to specify a header string, footer string, a
+stylesheet, and data for a bar of navigation links at the top of the
+generated document.
+
+While all can be set as long as the formatting engine provides an
+appropriate engine parameter (See section [sectref OPTIONS]) the last
+two have internal processing which make them specific to HTML.
+
+[subsection {COMMAND LINE}]
+
+[list_begin definitions]
+
+[call [cmd dtplite] [option -o] [arg output] [opt options] [arg format] [arg inputfile]]
+
+This is the form for use case [lb]1[rb]. The [arg options] will be
+explained later, in section [sectref OPTIONS].
+
+[list_begin arguments]
+
+[arg_def path output in]
+
+This argument specifies where to write the generated document. It can
+be the path to a file or directory, or [const -].
+
+The last value causes the application to write the generated
+documented to [const stdout].
+
+[para]
+
+If the [arg output] does not exist then [lb]file dirname $output[rb]
+has to exist and must be a writable directory.
+
+The generated document will be written to a file in that directory,
+and the name of that file will be derived from the [arg inputfile],
+the [arg format], and the value given to option [option -ext] (if
+present).
+
+[arg_def (path|handle) format in]
+
+This argument specifies the formatting engine to use when processing
+the input, and thus the format of the generated document. See section
+[sectref FORMATS] for the possibilities recognized by the application.
+
+[arg_def path inputfile in]
+
+This argument specifies the path to the file to process. It has to
+exist, must be readable, and written in [term doctools] format.
+
+[list_end]
+[para]
+
+[call [cmd dtplite] [const validate] [arg inputfile]]
+
+This is a simpler form for use case [lb]1[rb]. The "validate" format
+generates no output at all, only syntax checks are performed. As such
+the specification of an output file or other options is not necessary
+and left out.
+
+[call [cmd dtplite] [option -o] [arg output] [opt options] [arg format] [arg inputdirectory]]
+
+This is the form for use case [lb]2[rb]. It differs from the form for
+use case [lb]1[rb] by having the input documents specified through a
+directory instead of a file. The other arguments are identical, except
+for [arg output], which now has to be the path to an existing and
+writable directory.
+
+[para]
+
+The input documents are all files in [arg inputdirectory] or any of
+its subdirectories which were recognized by [cmd fileutil::fileType]
+as containing text in [term doctools] format.
+
+[call [cmd dtplite] [option -merge] [option -o] [arg output] [opt options] [arg format] [arg inputdirectory]]
+
+This is the form for use case [lb]3[rb]. The only difference to the
+form for use case [lb]2[rb] is the additional option [option -merge].
+
+[para]
+
+Each such call will merge the generated documents coming from
+processing the input documents under [arg inputdirectory] or any of
+its subdirectories to the files under [arg output]. In this manner it
+is possible to incrementally build the unified documentation for any
+number of packages. Note that it is necessary to run through all the
+packages twice to get fully correct cross-references (for formats
+supporting them).
+
+[list_end]
+
+[subsection OPTIONS]
+
+This section describes all the options available to the user of the
+application, with
+
+the exception of the options [option -o] and [option -merge]. These
+two were described already, in section [sectref {COMMAND LINE}].
+
+[para]
+[list_begin options]
+[opt_def -exclude string]
+
+This option specifies an exclude (glob) pattern. Any files identified
+as manpages to process which match the exclude pattern are
+ignored. The option can be provided multiple times, each usage adding
+an additional pattern to the list of exclusions.
+
+[opt_def -ext string]
+
+If the name of an output file has to be derived from the name of an
+input file it will use the name of the [arg format] as the extension
+by default. This option here will override this however, forcing it to
+use [arg string] as the file extension. This option is ignored if the
+name of the output file is fully specified through option [option -o].
+
+[para]
+
+When used multiple times only the last definition is relevant.
+
+[opt_def -header file]
+
+This option can be used if and only if the selected [arg format]
+provides an engine parameter named "header". It takes the contents of
+the specified file and assign them to that parameter, for whatever use
+by the engine. The HTML engine will insert the text just after the tag
+[const <body>].
+
+If navigation buttons are present (see option [option -nav] below),
+then the HTML generated for them is appended to the header data
+originating here before the final assignment to the parameter.
+
+[para]
+
+When used multiple times only the last definition is relevant.
+
+[opt_def -footer file]
+
+Like [option -header], except that: Any navigation buttons are ignored,
+the corresponding required engine parameter is named "footer", and the
+data is inserted just before the tag [const </body>].
+
+[para]
+
+When used multiple times only the last definition is relevant.
+
+[opt_def -style file]
+
+This option can be used if and only if the selected [arg format]
+provides an engine parameter named "meta". When specified it will
+generate a piece of HTML code declaring the [arg file] as the
+stylesheet for the generated document and assign that to the
+parameter. The HTML engine will insert this inot the document, just
+after the tag [const <head>].
+
+[para]
+
+When processing an input directory the stylesheet file is copied into
+the output directory and the generated HTML will refer to the copy, to
+make the result more self-contained. When processing an input file we
+have no location to copy the stylesheet to and so just reference it as
+specified.
+
+[para]
+
+When used multiple times only the last definition is relevant.
+
+[opt_def -toc path|text]
+
+This option specifies a doctoc file (or text) to use for the table of contents
+instead of generating our own.
+
+[para]
+
+When used multiple times only the last definition is relevant.
+
+[opt_def -pre+toc "label path|text"]
+[opt_def -post+toc "label path|text"]
+
+This option specifies additional doctoc files (or texts) to use in
+the navigation bar.
+
+[para] Positioning and handling of multiple uses is like for options
+[option -prenav] and [option -postnav], see below.
+
+[opt_def -nav "label url"]
+[opt_def -prenav "label url"]
+
+Use this option to specify a navigation button with [arg label] to
+display and the [arg url] to link to. This option can be used if and
+only if the selected [arg format] provides an engine parameter named
+"header". The HTML generated for this is appended to whatever data we
+got from option [option -header] before it is inserted into the
+generated documents.
+
+[para]
+
+When used multiple times all definitions are collected and a
+navigation bar is created, with the first definition shown at the left
+edge and the last definition to the right.
+
+[para] The url can be relative. In that case it is assumed to be relative
+to the main files (TOC and Keyword index), and will be transformed for
+all others to still link properly.
+
+[opt_def -postnav "label url"]
+
+Use this option to specify a navigation button with [arg label] to
+display and the [arg url] to link to. This option can be used if and
+only if the selected [arg format] provides an engine parameter named
+"header". The HTML generated for this is appended to whatever data we
+got from option [option -header] before it is inserted into the
+generated documents.
+
+[para]
+
+When used multiple times all definitions are collected and a
+navigation bar is created, with the last definition shown at the right
+edge and the first definition to the left.
+
+[para] The url can be relative. In that case it is assumed to be relative
+to the main files (TOC and Keyword index), and will be transformed for
+all others to still link properly.
+
+[list_end]
+
+[subsection FORMATS]
+
+At first the [arg format] argument will be treated as a path to a tcl
+file containing the code for the requested formatting engine. The
+argument will be treated as the name of one of the predefined formats
+listed below if and only if the path does not exist.
+
+[para]
+
+[emph {Note a limitation}]: If treating the format as path to the tcl
+script implementing the engine was sucessful, then this script has to
+implement not only the engine API for doctools, i.e.
+
+[term doctools_api], but for [term doctoc_api] and [term docidx_api]
+as well. Otherwise the generation of a table of contents and of a
+keyword index will fail.
+
+[para]
+
+List of predefined formats, i.e. as provided by the
+package [package doctools]:
+
+[para]
+[list_begin definitions]
+
+[def [const nroff]]
+
+The processor generates *roff output, the standard format for unix
+manpages.
+
+[def [const html]]
+
+The processor generates HTML output, for usage in and display by web
+browsers. This engine is currently the only one providing the various
+engine parameters required for the additional customaization of the
+output.
+
+[def [const tmml]]
+
+The processor generates TMML output, the Tcl Manpage Markup Language,
+a derivative of XML.
+
+[def [const latex]]
+
+The processor generates LaTeX output.
+
+[def [const wiki]]
+
+The processor generates Wiki markup as understood by [syscmd wikit].
+
+[def [const list]]
+
+The processor extracts the information provided by [cmd manpage_begin].
+[see_also {docidx introduction}]
+[see_also {doctoc introduction}]
+[see_also {doctools introduction}]
+[keywords conversion]
+[keywords docidx]
+[keywords doctoc]
+[keywords doctools]
+[keywords HTML]
+[keywords manpage]
+[keywords markup]
+[keywords nroff]
+[keywords TMML]
+
+This format is used internally to extract the meta data from which
+both table of contents and keyword index are derived from.
+
+[def [const null]]
+
+The processor does not generate any output. This is equivalent to
+[const validate].
+
+[list_end]
+
+[subsection {DIRECTORY STRUCTURES}]
+
+In this section we describe the directory structures generated by the
+application under [arg output] when processing all documents in an
+[arg inputdirectory]. In other words, this is only relevant to the use
+cases [lb]2[rb] and [lb]3[rb].
+
+[list_begin definitions]
+
+[def "[lb]2[rb]"]
+
+The following directory structure is created when processing a single
+set of input documents. The file extension used is for output in
+HTML, but that is not relevant to the structure and was just used to
+have proper file names.
+
+[example {
+ output/
+ toc.html
+ index.html
+ files/
+ path/to/FOO.html
+}]
+
+The last line in the example shows the document
+generated for a file FOO located at
+
+[example {
+ inputdirectory/path/to/FOO
+}]
+
+[def "[lb]3[rb]"]
+
+When merging many packages into a unified set of documents the
+generated directory structure is a bit deeper:
+
+[example {
+ output
+ .toc
+ .idx
+ .tocdoc
+ .idxdoc
+ .xrf
+ toc.html
+ index.html
+ FOO1/
+ ...
+ FOO2/
+ toc.html
+ files/
+ path/to/BAR.html
+}]
+
+Each of the directories FOO1, ... contains the documents generated for
+the package FOO1, ... and follows the structure shown for use case
+[lb]2[rb]. The only exception is that there is no per-package index.
+
+[para]
+
+The files [file .toc], [file .idx], and [file .xrf] contain the
+internal status of the whole output and will be read and updated by
+the next invokation. Their contents will not be documented. Remove
+these files when all packages wanted for the output have been
+processed, i.e. when the output is complete.
+
+[para]
+
+The files [file .tocdoc], and [file .idxdoc], are intermediate files
+in doctoc and docidx markup, respectively, containing the main table
+of contents and keyword index for the set of documents before their
+conversion to the chosen output format.
+
+They are left in place, i.e. not deleted, to serve as demonstrations
+of doctoc and docidx markup.
+
+[list_end]
+
+[vset CATEGORY doctools]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/exif/ChangeLog b/tcllib/modules/exif/ChangeLog
new file mode 100644
index 0000000..e305b89
--- /dev/null
+++ b/tcllib/modules/exif/ChangeLog
@@ -0,0 +1,176 @@
+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-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 ========================
+ *
+
+2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * exif.pcx: New file. Syntax definitions for the public commands
+ of the exif package.
+
+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>
+
+ * exif.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-09-27 Andreas Kupries <andreask@activestate.com>
+
+ * exif.test: [SF Tcllib Bug 1272798]. Using 'format' to get
+ results with a deterministic precision.
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * exif.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * exif.test: Hooked into the new common test support code.
+
+2005-10-21 Andreas Kupries <andreask@activestate.com>
+
+ * exif.test: Fixed typo.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+Wed Sep 29 15:11:35 2004 Andreas Kupries <andreask@activestate.com>
+
+ * exif.tcl (makerNote): Fixed [Tcllib SF Bug 1028668]. There are
+ * exif.test: images in the wild which do not provide
+ AFPoint information in the makerNote Exif
+ data. Test suite is new.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-05-09 Andreas Kupries <andreask@activestate.com>
+
+ * exif.tcl (::exif::makerNote): Added missing logical operator to
+ if condition for field 34. Procheck report.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * exif.tcl:
+ * exif.man:
+ * pkgIndex.tcl: Fixed bug #614591. Set version of the package to
+ to 1.1.
+
+2003-04-01 Andreas Kupries <andreask@activestate.com>
+
+ * exif.man:
+ * exif.tcl: Applied patch for SF tcllib bug #665737 provided by
+ Tim J. Edwards <timje@users.sourceforge.net>. This not only
+ fixes the bug mentioned above, but also corrects some spelling
+ mistakes, adds support for a number of additional EXIF tags, and
+ provides functionality to dump a thumbnail image contained in
+ the data to a file.
+
+ The change in the interface of 'analyze' (stream -> file) was
+ reverted and an additional file based command provided
+ instead. This command is a wrapper around the stream interface.
+
+ Updated the documentation.
+
+2003-02-06 David N. Welton <davidw@dedasys.com>
+
+ * exif.tcl (exif::makerNote): Use string match instead of regexp.
+
+2002-08-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * exif.tcl: Applied patch for bug report SF #530907 partially.
+
+ Parts of the patch are accepted and applied
+ * FlashPixVersion
+ * Construction of FlashMode
+
+ Not applied parts:
+ * SubjectDistance. Patch assumes that unit is millimeter and
+ converts to meter. Spec says that unit _is_ meter. (*). Is it
+ possible that the specific camera of the submitter implements
+ the standard incorrectly ?
+
+ * ShutterSpeedValue. Instead of logical inversion (1/value
+ seconds) I added the proper unit for frequency (Hz).
+
+ (*) http://www.media.mit.edu/pia/Research/deepview/exif.html
+ 0x9206 SubjectDistance signed rational 1 Distance to focus point, unit is meter
+
+ * exif.tcl: Applied patch SF #582828 provided by Anselm Lingnau
+ <lingnau@users.sourceforge.net> to make the module work with
+ Digital IXUS.
+
+2002-03-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * exif.man: Fixed formatting errors in the doctools manpage.
+
+2002-02-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Added module on behalf of Darren New.
+
diff --git a/tcllib/modules/exif/exif.html b/tcllib/modules/exif/exif.html
new file mode 100644
index 0000000..a98d4e5
--- /dev/null
+++ b/tcllib/modules/exif/exif.html
@@ -0,0 +1,147 @@
+<html><head><title>The EXIF documentation file: The EXIF Package</title>
+<meta http-equiv="Expires" content="Tue, 12 Feb 2002 23:41:06 +0000">
+<STYLE type='text/css'>
+ .title { color: #990000; font-size: 22px; line-height: 22px; font-weight: bold; text-align: right;
+ font-family: helvetica, arial, sans-serif }
+ .filename { color: #666666; font-size: 18px; line-height: 28px; font-weight: bold; text-align: right;
+ font-family: helvetica, arial, sans-serif }
+ p.copyright { color: #000000; font-size: 10px;
+ font-family: verdana, charcoal, helvetica, arial, sans-serif }
+ p { margin-left: 2em; margin-right: 2em; }
+ li { margin-left: 3em; }
+ ol { margin-left: 2em; margin-right: 2em; }
+ ul.text { margin-left: 2em; margin-right: 2em; }
+ pre { margin-left: 3em; color: #333333 }
+ ul.toc { color: #000000; line-height: 16px;
+ font-family: verdana, charcoal, helvetica, arial, sans-serif }
+ H3 { color: #333333; font-size: 16px; line-height: 16px; font-family: helvetica, arial, sans-serif }
+ H4 { color: #000000; font-size: 14px; font-family: helvetica, arial, sans-serif }
+ TD.header { color: #ffffff; font-size: 10px; font-family: arial, helvetica, san-serif; valign: top }
+ TD.author-text { color: #000000; font-size: 10px;
+ font-family: verdana, charcoal, helvetica, arial, sans-serif }
+ TD.author { color: #000000; font-weight: bold; margin-left: 4em; font-size: 10px; font-family: verdana, charcoal, helvetica, arial, sans-serif }
+ A:link { color: #990000; font-size: 10px; text-transform: uppercase; font-weight: bold;
+ font-family: MS Sans Serif, verdana, charcoal, helvetica, arial, sans-serif }
+ A:visited { color: #333333; font-weight: bold; font-size: 10px; text-transform: uppercase;
+ font-family: MS Sans Serif, verdana, charcoal, helvetica, arial, sans-serif }
+ A:name { color: #333333; font-weight: bold; font-size: 10px; text-transform: uppercase;
+ font-family: MS Sans Serif, verdana, charcoal, helvetica, arial, sans-serif }
+ .link2 { color:#ffffff; font-weight: bold; text-decoration: none;
+ font-family: monaco, charcoal, geneva, MS Sans Serif, helvetica, monotype, verdana, sans-serif;
+ font-size: 9px }
+ .RFC { color:#666666; font-weight: bold; text-decoration: none;
+ font-family: monaco, charcoal, geneva, MS Sans Serif, helvetica, monotype, verdana, sans-serif;
+ font-size: 9px }
+ .hotText { color:#ffffff; font-weight: normal; text-decoration: none;
+ font-family: charcoal, monaco, geneva, MS Sans Serif, helvetica, monotype, verdana, sans-serif;
+ font-size: 9px }
+</style>
+</head>
+<body bgcolor="#ffffff" text="#000000" alink="#000000" vlink="#666666" link="#990000">
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<table width="66%" border="0" cellpadding="0" cellspacing="0"><tr><td><table width="100%" border="0" cellpadding="2" cellspacing="1">
+<tr valign="top"><td width="33%" bgcolor="#666666" class="header">The EXIF documentation file</td><td width="33%" bgcolor="#666666" class="header">D. New</td></tr>
+<tr valign="top"><td width="33%" bgcolor="#666666" class="header">&nbsp;</td><td width="33%" bgcolor="#666666" class="header">February 12, 2002</td></tr>
+</table></td></tr></table>
+<div align="right"><font face="monaco, MS Sans Serif" color="#990000" size="+3"><b><br><span class="title">The EXIF Package</span></b></font></div>
+<font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<h3>Abstract</h3>
+
+<p>
+
+ Tcl EXIF extracts and parses EXIF fields from digital images.
+
+</p>
+<a name="toc"><br><hr size="1" shade="0"></a>
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<h3>Table of Contents</h3>
+<ul compact class="toc">
+<b><a href="#anchor1">1.</a>&nbsp;
+Synopsis<br></b>
+<b><a href="#anchor2">2.</a>&nbsp;
+Details<br></b>
+<b><a href="#anchor3">3.</a>&nbsp;
+Copyrights<br></b>
+<b><a href="#anchor4">4.</a>&nbsp;
+Acknowledgements<br></b>
+</ul>
+<br clear="all">
+
+<a name="anchor1"><br><hr size="1" shade="0"></a>
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<h3>1.&nbsp;Synopsis</h3>
+</font><pre>
+ package provide exif 1.0
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+The EXIF package is a recoding of Chris Breeze's Perl package to do the same
+ thing. This version accepts a channel as input and returns a serialized
+ array with all the recognised fields parsed out.
+</p>
+
+<p>
+ There is also a function to obtain a list of all possible field names that
+ might be present, which is useful in building GUIs that present such
+ information.
+</p>
+
+<a name="anchor2"><br><hr size="1" shade="0"></a>
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<h3>2.&nbsp;Details</h3>
+</font><pre>
+ array set answer [exif::analyze $channel]
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+ $channel should be an open file handle rewound
+ to the start. It does not need to be seekable.
+ $channel will be set to binary mode and is left
+ wherever it happens to stop being parsed, usually
+ at the end of the file or the start of the image
+ data. You must open and close the stream yourself.
+ If no error is thrown, the return value is a
+ serialized array with informative English text
+ about what was found in the EXIF block. Failure
+ during parsing or I/O throw errors.
+</p>
+</font><pre>
+ set names [exif::fieldnames]
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+ This returns a list of all possible field names.
+ That is, the array returned by exif::analyze will
+ not contain keys that are not listed in the return
+ from exif::fieldnames. Of course, if information is
+ missing in the image file, exif::analyze may not
+ return all the fields listed in the return from
+ exif::fieldnames. This function is expected to be
+ primarily useful for building GUIs to display results.
+ N.B.: Read the implementation of exif::fieldnames
+ before modifying the implementation of exif::analyze.
+
+</p>
+
+<a name="anchor3"><br><hr size="1" shade="0"></a>
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<h3>3.&nbsp;Copyrights</h3>
+
+<p>
+(c) 2002 Darren New
+</p>
+
+<p>
+Hold harmless the author, and any lawful use is allowed.
+</p>
+
+<a name="anchor4"><br><hr size="1" shade="0"></a>
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<h3>4.&nbsp;Acknowledgements</h3>
+
+<p>
+ This code is a direct translation of version 1.3 of exif.pl by Chris
+ Breeze. See the source for full headers, references, etc.
+</p>
+</font></body></html>
diff --git a/tcllib/modules/exif/exif.man b/tcllib/modules/exif/exif.man
new file mode 100644
index 0000000..62c6682
--- /dev/null
+++ b/tcllib/modules/exif/exif.man
@@ -0,0 +1,80 @@
+[manpage_begin exif n 1.1.2]
+[keywords exif]
+[keywords jpeg]
+[keywords {maker note}]
+[keywords tiff]
+[moddesc {EXIF parsing}]
+[titledesc {Tcl EXIF extracts and parses EXIF fields from digital images}]
+[category {File formats}]
+[require Tcl 8.2]
+[require exif [opt 1.1.2]]
+[description]
+[para]
+
+The EXIF package is a recoding of Chris Breeze's Perl package to do
+the same thing. This version accepts a channel as input and returns a
+serialized array with all the recognised fields parsed out.
+
+[para]
+
+There is also a function to obtain a list of all possible field names
+that might be present, which is useful in building GUIs that present
+such information.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd exif::analyze] [arg channel] [opt [arg thumbnail]]]
+
+[arg channel] should be an open file handle rewound to the start. It
+does not need to be seekable. [arg channel] will be set to binary
+mode and is left wherever it happens to stop being parsed, usually at
+the end of the file or the start of the image data. You must open and
+close the stream yourself. If no error is thrown, the return value is
+a serialized array with informative English text about what was found
+in the EXIF block. Failure during parsing or I/O throw errors.
+
+[para]
+
+If [arg thumbnail] is present and not the empty string it will be
+interpreted as the name of a file, and the thumbnail image contained
+in the exif data will be written into it.
+
+[call [cmd exif::analyzeFile] [arg filename] [opt [arg thumbnail]]]
+
+This is a file-based wrapper around [cmd exif::analyze]. Instead of
+taking a stream it takes a [arg filename] and analyzes the contents of
+the specified file.
+
+[call [cmd exif::fieldnames]]
+
+This returns a list of all possible field names. That is, the array
+returned by [cmd exif::analyze] will not contain keys that are not
+listed in the return from [cmd exif::fieldnames]. Of course, if
+information is missing in the image file, [cmd exif::analyze] may not
+return all the fields listed in the return from exif::fieldnames.
+This function is expected to be primarily useful for building GUIs to
+display results.
+
+[para]
+
+N.B.: Read the implementation of [cmd exif::fieldnames] before
+modifying the implementation of [cmd exif::analyze].
+
+[list_end]
+
+[section COPYRIGHTS]
+
+(c) 2002 Darren New
+
+Hold harmless the author, and any lawful use is allowed.
+
+[section ACKNOWLEDGEMENTS]
+
+This code is a direct translation of version 1.3 of exif.pl by Chris
+Breeze. See the source for full headers, references, etc.
+
+[vset CATEGORY exif]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/exif/exif.pcx b/tcllib/modules/exif/exif.pcx
new file mode 100644
index 0000000..cd69941
--- /dev/null
+++ b/tcllib/modules/exif/exif.pcx
@@ -0,0 +1,34 @@
+# -*- tcl -*- exif.pcx
+# Syntax of the commands provided by package exif.
+#
+# 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 exif
+pcx::tcldep 1.1.2 needs tcl 8.3
+
+namespace eval ::exif {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.1.2 std ::exif::analyze \
+ {checkSimpleArgs 1 2 {
+ checkChannelID
+ checkFileName
+ }}
+pcx::check 1.1.2 std ::exif::analyzeFile \
+ {checkSimpleArgs 1 2 {
+ checkFileName
+ checkFileName
+ }}
+pcx::check 1.1.2 std ::exif::fieldnames \
+ {checkAtEnd}
+
+# Initialization via pcx::init.
+# Use a ::exif::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/exif/exif.tcl b/tcllib/modules/exif/exif.tcl
new file mode 100644
index 0000000..adb5709
--- /dev/null
+++ b/tcllib/modules/exif/exif.tcl
@@ -0,0 +1,937 @@
+# EXIF parser in Tcl
+# Author: Darren New <dnew@san.rr.com>
+# Translated directly from the Perl version
+# by Chris Breeze <chris@breezesys.com>
+# http://www.breezesys.com
+# See the original comment block, reproduced
+# at the bottom.
+# Most of the inline comments about the meanings of fields
+# are copied verbatim and without understanding from the
+# original, unless "DNew" is there.
+# Much of the structure is preserved, except in
+# makerNote, where I got tired of typing as verbosely
+# as the original Perl. But thanks for making it so
+# readable that even someone who doesn't know Perl
+# could translate it, Chris! ;-)
+# PLEASE read and understand exif::fieldnames
+# BEFORE making any changes here! Thanks!
+
+# Usage of this version:
+# exif::analyze $stream ?$thumbnail?
+# Stream should be an open file handle
+# rewound to the start. It gets set to
+# binary mode and is left at EOF or
+# possibly pointing at image data.
+# You have to open and close the
+# stream yourself.
+# The return is a serialized array
+# (a la [array get]) with informative
+# english text about what was found.
+# Errors in parsing or I/O or whatever
+# throw errors.
+# exif::allfields
+# returns a list of all possible field names.
+# Added by DNew. Funky implementation.
+#
+# New
+# exif::analyzeFile $filename ?$thumbnail?
+#
+# If you find any mistakes here, feel free to correct them
+# and/or send them to me. I just cribbed this - I don't even
+# have a camera that puts this kind of info into the file.
+
+# LICENSE: Standard BSD License.
+
+# There's probably something here I'm using without knowing it.
+package require Tcl 8.3
+
+package provide exif 1.1.2 ; # first release
+
+namespace eval ::exif {
+ namespace export analyze analyzeFile fieldnames
+ variable debug 0 ; # set to 1 for puts of debug trace
+ variable cameraModel ; # used internally to understand options
+ variable jpeg_markers ; # so we only have to do it once
+ variable intel ; # byte order - so we don't have to pass to every read
+ variable cached_fieldnames ; # just what it says
+ array set jpeg_markers {
+ SOF0 \xC0
+ DHT \xC4
+ SOI \xD8
+ EOI \xD9
+ SOS \xDA
+ DQT \xDB
+ DRI \xDD
+ APP1 \xE1
+ }
+}
+
+proc ::exif::debug {str} {
+ variable debug
+ if {$debug} {puts $str}
+}
+
+proc ::exif::streq {s1 s2} {
+ return [string equal $s1 $s2]
+}
+
+proc ::exif::analyzeFile {file {thumbnail {}}} {
+ set stream [open $file]
+ set res [analyze $stream $thumbnail]
+ close $stream
+ return $res
+}
+
+proc ::exif::analyze {stream {thumbnail {}}} {
+ variable jpeg_markers
+ array set result {}
+ fconfigure $stream -translation binary -encoding binary
+ while {![eof $stream]} {
+ set ch [read $stream 1]
+ if {1 != [string length $ch]} {error "End of file reached @1"}
+ if {![streq "\xFF" $ch]} {break} ; # skip image data
+ set marker [read $stream 1]
+ if {1 != [string length $marker]} {error "End of file reached @2"}
+ if {[streq $marker $jpeg_markers(SOI)]} {
+ debug "SOI"
+ } elseif {[streq $marker $jpeg_markers(EOI)]} {
+ debug "EOI"
+ } else {
+ set msb [read $stream 1]
+ set lsb [read $stream 1]
+ if {1 != [string length $msb] || 1 != [string length $lsb]} {
+ error "File truncated @1"
+ }
+ scan $msb %c msb ; scan $lsb %c lsb
+ set size [expr {256 * $msb + $lsb}]
+ set data [read $stream [expr {$size-2}]]
+ debug "read [expr {$size - 2}] bytes of data"
+ if {[expr {$size-2}] != [string length $data]} {
+ error "File truncated @2"
+ }
+ if {[streq $marker $jpeg_markers(APP1)]} {
+ debug "APP1\t$size"
+ array set result [app1 $data $thumbnail]
+ } elseif {[streq $marker $jpeg_markers(DQT)]} {
+ debug "DQT\t$size"
+ } elseif {[streq $marker $jpeg_markers(SOF0)]} {
+ debug "SOF0\t$size"
+ } elseif {[streq $marker $jpeg_markers(DHT)]} {
+ debug "DHT\t$size"
+ } elseif {[streq $marker $jpeg_markers(SOS)]} {
+ debug "SOS\t$size"
+ } else {
+ binary scan $marker H* x
+ debug "UNKNOWN MARKER $x"
+ }
+ }
+ }
+ return [array get result]
+}
+
+proc ::exif::app1 {data thumbnail} {
+ variable intel
+ variable cameraModel
+ array set result {}
+ if {![string equal [string range $data 0 5] "Exif\0\0"]} {
+ error "APP1 does not contain EXIF"
+ }
+ debug "Reading EXIF data"
+ set data [string range $data 6 end]
+ set t [string range $data 0 1]
+ if {[streq $t "II"]} {
+ set intel 1
+ debug "Intel byte alignment"
+ } elseif {[streq $t "MM"]} {
+ set intel 0
+ debug "Motorola byte alignment"
+ } else {
+ error "Invalid byte alignment: $t"
+ }
+ if {[readShort $data 2]!=0x002A} {error "Invalid tag mark"}
+ set curoffset [readLong $data 4] ; # just called "offset" in the Perl - DNew
+ debug "Offset to first IFD: $curoffset"
+ set numEntries [readShort $data $curoffset]
+ incr curoffset 2
+ debug "Number of directory entries: $numEntries"
+ for {set i 0} {$i < $numEntries} {incr i} {
+ set head [expr {$curoffset + 12 * $i}]
+ set entry [string range $data $head [expr {$head+11}]]
+ set tag [readShort $entry 0]
+ set format [readShort $entry 2]
+ set components [readLong $entry 4]
+ set offset [readLong $entry 8]
+ set value [readIFDEntry $data $format $components $offset]
+ if {$tag==0x010e} {
+ set result(ImageDescription) $value
+ } elseif {$tag==0x010f} {
+ set result(CameraMake) $value
+ } elseif {$tag==0x0110} {
+ set result(CameraModel) $value
+ set cameraModel $value
+ } elseif {$tag==0x0112} {
+ set result(Orientation) $value
+ } elseif {$tag == 0x011A} {
+ set result(XResolution) $value
+ } elseif {$tag == 0x011B} {
+ set result(YResolution) $value
+ } elseif {$tag == 0x0128} {
+ set result(ResolutionUnit) "unknown"
+ if {$value==2} {set result(ResolutionUnit) "inch"}
+ if {$value==3} {set result(ResolutionUnit) "centimeter"}
+ } elseif {$tag==0x0131} {
+ set result(Software) $value
+ } elseif {$tag==0x0132} {
+ set result(DateTime) $value
+ } elseif {$tag==0x0213} {
+ set result(YCbCrPositioning) "unknown"
+ if {$value==1} {set result(YCbCrPositioning) "Center of pixel array"}
+ if {$value==2} {set result(YCbCrPositioning) "Datum point"}
+ } elseif {$tag==0x8769} {
+ # EXIF sub IFD
+ debug "==CALLING exifSubIFD=="
+ array set result [exifSubIFD $data $offset]
+ } else {
+ debug "Unrecognized entry: Tag=$tag, value=$value"
+ }
+ }
+ set offset [readLong $data [expr {$curoffset + 12 * $numEntries}]]
+ debug "Offset to next IFD: $offset"
+ array set thumb_result [exifSubIFD $data $offset]
+
+ if {$thumbnail != {}} {
+ set jpg [string range $data \
+ $thumb_result(JpegIFOffset) \
+ [expr {$thumb_result(JpegIFOffset) + $thumb_result(JpegIFByteCount) - 1}]]
+
+ set to [open $thumbnail w]
+ fconfigure $to -translation binary -encoding binary
+ puts $to $jpg
+ close $to
+
+ #can be used (with a JPG-aware TK) to add the image to the result array
+ #set result(THUMB) [image create photo -file $thumbnail]
+ }
+
+ return [array get result]
+}
+
+# Extract EXIF sub IFD info
+proc ::exif::exifSubIFD {data curoffset} {
+ debug "EXIF: offset=$curoffset"
+ set numEntries [readShort $data $curoffset]
+ incr curoffset 2
+ debug "Number of directory entries: $numEntries"
+ for {set i 0} {$i < $numEntries} {incr i} {
+ set head [expr {$curoffset + 12 * $i}]
+ set entry [string range $data $head [expr {$head+11}]]
+ set tag [readShort $entry 0]
+ set format [readShort $entry 2]
+ set components [readLong $entry 4]
+ set offset [readLong $entry 8]
+ if {$tag==0x9000} {
+ set result(ExifVersion) [string range $entry 8 11]
+ } elseif {$tag==0x9101} {
+ set result(ComponentsConfigured) [format 0x%08x $offset]
+ } elseif {$tag == 0x927C} {
+ array set result [makerNote $data $offset]
+ } elseif {$tag == 0x9286} {
+ # Apparently, this doesn't usually work.
+ set result(UserComment) "$offset - [string range $data $offset [expr {$offset+8}]]"
+ set result(UserComment) [string trim $result(UserComment) "\0"]
+ } elseif {$tag==0xA000} {
+ set result(FlashPixVersion) [string range $entry 8 11]
+ } elseif {$tag==0xA300} {
+ # 3 means digital camera
+ if {$offset == 3} {
+ set result(FileSource) "3 - Digital camera"
+ } else {
+ set result(FileSource) $offset
+ }
+ } else {
+ set value [readIFDEntry $data $format $components $offset]
+ if {$tag==0x829A} {
+ if {0.3 <= $value} {
+ # In seconds...
+ set result(ExposureTime) "$value seconds"
+ } else {
+ set result(ExposureTime) "1/[expr {1.0/$value}] seconds"
+ }
+ } elseif {$tag == 0x829D} {
+ set result(FNumber) $value
+ } elseif {$tag == 0x8827} {
+ # D30 stores ISO here, G1 uses MakerNote Tag 1 field 16
+ set result(ISOSpeedRatings) $value
+ } elseif {$tag == 0x9003} {
+ set result(DateTimeOriginal) $value
+ } elseif {$tag == 0x9004} {
+ set result(DateTimeDigitized) $value
+ } elseif {$tag == 0x9102} {
+ if {$value == 5} {
+ set result(ImageQuality) "super fine"
+ } elseif {$value == 3} {
+ set result(ImageQuality) "fine"
+ } elseif {$value == 2} {
+ set result(ImageQuality) "normal"
+ } else {
+ set result(CompressedBitsPerPixel) $value
+ }
+ } elseif {$tag == 0x9201} {
+ # Not very accurate, use Exposure time instead.
+ # (That's Chris' comment. I don't know what it means.)
+ set value [expr {pow(2,$value)}]
+ if {$value < 4} {
+ set value [expr {1.0 / $value}]
+ set value [expr {int($value * 10 + 0.5) / 10.0}]
+ } else {
+ set value [expr {int($value + 0.49)}]
+ }
+ set result(ShutterSpeedValue) "$value Hz"
+ } elseif {$tag == 0x9202} {
+ set value [expr {int(pow(sqrt(2.0), $value) * 10 + 0.5) / 10.0}]
+ set result(AperatureValue) $value
+ } elseif {$tag == 0x9204} {
+ set value [compensationFraction $value]
+ set result(ExposureBiasValue) $value
+ } elseif {$tag == 0x9205} {
+ set value [expr {int(pow(sqrt(2.0), $value) * 10 + 0.5) / 10.0}]
+ } elseif {$tag == 0x9206} {
+ # May need calibration
+ set result(SubjectDistance) "$value m"
+ } elseif {$tag == 0x9207} {
+ set result(MeteringMode) "other"
+ if {$value == 0} {set result(MeteringMode) "unknown"}
+ if {$value == 1} {set result(MeteringMode) "average"}
+ if {$value == 2} {set result(MeteringMode) "center weighted average"}
+ if {$value == 3} {set result(MeteringMode) "spot"}
+ if {$value == 4} {set result(MeteringMode) "multi-spot"}
+ if {$value == 5} {set result(MeteringMode) "multi-segment"}
+ if {$value == 6} {set result(MeteringMode) "partial"}
+ } elseif {$tag == 0x9209} {
+ if {$value == 0} {
+ set result(Flash) no
+ } elseif {$value == 1} {
+ set result(Flash) yes
+ } else {
+ set result(Flash) "unknown: $value"
+ }
+ } elseif {$tag == 0x920a} {
+ set result(FocalLength) "$value mm"
+ } elseif {$tag == 0xA001} {
+ set result(ColorSpace) $value
+ } elseif {$tag == 0xA002} {
+ set result(ExifImageWidth) $value
+ } elseif {$tag == 0xA003} {
+ set result(ExifImageHeight) $value
+ } elseif {$tag == 0xA005} {
+ set result(ExifInteroperabilityOffset) $value
+ } elseif {$tag == 0xA20E} {
+ set result(FocalPlaneXResolution) $value
+ } elseif {$tag == 0xA20F} {
+ set result(FocalPlaneYResolution) $value
+ } elseif {$tag == 0xA210} {
+ set result(FocalPlaneResolutionUnit) "none"
+ if {$value == 2} {set result(FocalPlaneResolutionUnit) "inch"}
+ if {$value == 3} {set result(FocalPlaneResolutionUnit) "centimeter"}
+ } elseif {$tag == 0xA217} {
+ # 2 = 1 chip color area sensor
+ set result(SensingMethod) $value
+ } elseif {$tag == 0xA401} {
+ #TJE
+ set result(SensingMethod) "normal"
+ if {$value == 1} {set result(SensingMethod) "custom"}
+ } elseif {$tag == 0xA402} {
+ #TJE
+ set result(ExposureMode) "auto"
+ if {$value == 1} {set result(ExposureMode) "manual"}
+ if {$value == 2} {set result(ExposureMode) "auto bracket"}
+ } elseif {$tag == 0xA403} {
+ #TJE
+ set result(WhiteBalance) "auto"
+ if {$value == 1} {set result(WhiteBalance) "manual"}
+ } elseif {$tag == 0xA404} {
+ # digital zoom not used if number is zero
+ set result(DigitalZoomRatio) "not used"
+ if {$value != 0} {set result(DigitalZoomRatio) $value}
+ } elseif {$tag == 0xA405} {
+ set result(FocalLengthIn35mmFilm) "unknown"
+ if {$value != 0} {set result(FocalLengthIn35mmFilm) $value}
+ } elseif {$tag == 0xA406} {
+ set result(SceneCaptureType) "Standard"
+ if {$value == 1} {set result(SceneCaptureType) "Landscape"}
+ if {$value == 2} {set result(SceneCaptureType) "Portrait"}
+ if {$value == 3} {set result(SceneCaptureType) "Night scene"}
+ } elseif {$tag == 0xA407} {
+ set result(GainControl) "none"
+ if {$value == 1} {set result(GainControl) "Low gain up"}
+ if {$value == 2} {set result(GainControl) "High gain up"}
+ if {$value == 3} {set result(GainControl) "Low gain down"}
+ if {$value == 4} {set result(GainControl) "High gain down"}
+ } elseif {$tag == 0x0103} {
+ #TJE
+ set result(Compression) "unknown"
+ if {$value == 1} {set result(Compression) "none"}
+ if {$value == 6} {set result(Compression) "JPEG"}
+ } elseif {$tag == 0x011A} {
+ #TJE
+ set result(XResolution) $value
+ } elseif {$tag == 0x011B} {
+ #TJE
+ set result(YResolution) $value
+ } elseif {$tag == 0x0128} {
+ #TJE
+ set result(ResolutionUnit) "unknown"
+ if {$value == 1} {set result(ResolutionUnit) "inch"}
+ if {$value == 6} {set result(ResolutionUnit) "cm"}
+ } elseif {$tag == 0x0201} {
+ #TJE
+ set result(JpegIFOffset) $value
+ debug "offset = $value"
+ } elseif {$tag == 0x0202} {
+ #TJE
+ set result(JpegIFByteCount) $value
+ debug "bytecount = $value"
+ } else {
+ error "Unrecognized EXIF Tag: $tag (0x[string toupper [format %x $tag]])"
+ }
+ }
+ }
+ return [array get result]
+}
+
+# Canon proprietary data that I didn't feel like translating to Tcl yet.
+proc ::exif::makerNote {data curoffset} {
+ variable cameraModel
+ debug "MakerNote: offset=$curoffset"
+
+ array set result {}
+ set numEntries [readShort $data $curoffset]
+ incr curoffset 2
+ debug "Number of directory entries: $numEntries"
+ for {set i 0} {$i < $numEntries} {incr i} {
+ set head [expr {$curoffset + 12 * $i}]
+ set entry [string range $data $head [expr {$head+11}]]
+ set tag [readShort $entry 0]
+ set format [readShort $entry 2]
+ set components [readLong $entry 4]
+ set offset [readLong $entry 8]
+ debug "$i)\tTag: $tag, format: $format, components: $components"
+
+ if {$tag==6} {
+ set value [readIFDEntry $data $format $components $offset]
+ set result(ImageFormat) $value
+ } elseif {$tag==7} {
+ set value [readIFDEntry $data $format $components $offset]
+ set result(FirmwareVersion) $value
+ } elseif {$tag==8} {
+ set value [string range $offset 0 2]-[string range $offset 3 end]
+ set result(ImageNumber) $value
+ } elseif {$tag==9} {
+ set value [readIFDEntry $data $format $components $offset]
+ set result(Owner) $value
+ } elseif {$tag==0x0C} {
+ # camera serial number
+ set msw [expr {($offset >> 16) & 0xFFFF}]
+ set lsw [expr {$offset & 0xFFFF}]
+ set result(CameraSerialNumber) [format %04X%05d $msw $lsw]
+ } elseif {$tag==0x10} {
+ set result(UnknownTag-0x10) $offset
+ } else {
+ if {$format == 3 && 1 < $components} {
+ debug "MakerNote $i: TAG=$tag"
+ catch {unset field}
+ array set field {}
+ for {set j 0} {$j < $components} {incr j} {
+ set field($j) [readShort $data [expr {$offset+2*$j}]]
+ debug "$j : $field($j)"
+ }
+ if {$tag == 1} {
+ if {![string match -nocase "*Pro90*" $cameraModel]} {
+ if {$field(1)==1} {
+ set result(MacroMode) macro
+ } else {
+ set result(MacroMode) normal
+ }
+ }
+ if {0 < $field(2)} {
+ set result(SelfTimer) "[expr {$field(2)/10.0}] seconds"
+ }
+ set result(ImageQuality) [switch $field(3) {
+ 2 {format Normal}
+ 3 {format Fine}
+ 4 {format "CCD Raw"}
+ 5 {format "Super fine"}
+ default {format ""}
+ }]
+ set result(FlashMode) [switch $field(4) {
+ 0 {format off}
+ 1 {format auto}
+ 2 {format on}
+ 3 {format "red eye reduction"}
+ 4 {format "slow synchro"}
+ 5 {format "auto + red eye reduction"}
+ 6 {format "on + red eye reduction"}
+ default {format ""}
+ }]
+ if {$field(5)} {
+ set result(ShootingMode) "Continuous"
+ } else {
+ set result(ShootingMode) "Single frame"
+ }
+ # Field 6 - don't know what it is.
+ set result(AutoFocusMode) [switch $field(7) {
+ 0 {format "One-shot"}
+ 1 {format "AI servo"}
+ 2 {format "AI focus"}
+ 3 - 6 {format "MF"}
+ 5 {format "Continuous"}
+ 4 {
+ # G1: uses field 32 to store single/continuous,
+ # and always sets 7 to 4.
+ if {[info exists field(32)] && $field(32)} {
+ format "Continuous"
+ } else {
+ format "Single"
+ }
+ }
+ default {format unknown}
+ }]
+ # Field 8 and 9 are unknown
+ set result(ImageSize) [switch $field(10) {
+ 0 {format "large"}
+ 1 {format "medium"}
+ 2 {format "small"}
+ default {format "unknown"}
+ }]
+ # Field 11 - easy shooting - see field 20
+ # Field 12 - unknown
+ set NHL {
+ 0 {format "Normal"}
+ 1 {format "High"}
+ 65536 {format "Low"}
+ default {format "Unknown"}
+ }
+ set result(Contrast) [switch $field(13) $NHL]
+ set result(Saturation) [switch $field(14) $NHL]
+ set result(Sharpness) [switch $field(15) $NHL]
+ set result(ISO) [switch $field(16) {
+ 15 {format Auto}
+ 16 {format 50}
+ 17 {format 100}
+ 18 {format 200}
+ 19 {format 400}
+ default {format "unknown"}
+ }]
+ set result(MeteringMode) [switch $field(17) {
+ 3 {format evaluative}
+ 4 {format partial}
+ 5 {format center-weighted}
+ default {format unknown}
+ }]
+ # Field 18 - unknown
+ if {[info exists field(19)]} {
+ set result(AFPoint) [switch -- [expr {$field(19)-0x3000}] {
+ 0 {format none}
+ 1 {format auto-selected}
+ 2 {format right}
+ 3 {format center}
+ 4 {format left}
+ default {format unknown}
+ }] ; # {}
+ }
+ if {[info exists field(20)]} {
+ if {$field(20) == 0} {
+ set result(ExposureMode) [switch $field(11) {
+ 0 {format auto}
+ 1 {format manual}
+ 2 {format landscape}
+ 3 {format "fast shutter"}
+ 4 {format "slow shutter"}
+ 5 {format "night scene"}
+ 6 {format "black and white"}
+ 7 {format sepia}
+ 8 {format portrait}
+ 9 {format sports}
+ 10 {format close-up}
+ 11 {format "pan focus"}
+ default {format unknown}
+ }] ; # {}
+ } elseif {$field(20) == 1} {
+ set result(ExposureMode) program
+ } elseif {$field(20) == 2} {
+ set result(ExposureMode) Tv
+ } elseif {$field(20) == 3} {
+ set result(ExposureMode) Av
+ } elseif {$field(20) == 4} {
+ set result(ExposureMode) manual
+ } elseif {$field(20) == 5} {
+ set result(ExposureMode) A-DEP
+ } else {
+ set result(ExposureMode) unknown
+ }
+ }
+ # Field 21 and 22 are unknown
+ # Field 23: max focal len, 24 min focal len, 25 units per mm
+ if {[info exists field(23)] && [info exists field(25)]} {
+ set result(MaxFocalLength) \
+ "[expr {1.0 * $field(23) / $field(25)}] mm"
+ }
+ if {[info exists field(24)] && [info exists field(25)]} {
+ set result(MinFocalLength) \
+ "[expr {1.0 * $field(24) / $field(25)}] mm"
+ }
+ # Field 26-28 are unknown.
+ if {[info exists field(29)]} {
+ if {$field(29) & 0x0010} {
+ lappend result(FlashMode) "FP_sync_enabled"
+ }
+ if {$field(29) & 0x0800} {
+ lappend result(FlashMode) "FP_sync_used"
+ }
+ if {$field(29) & 0x2000} {
+ lappend result(FlashMode) "internal_flash"
+ }
+ if {$field(29) & 0x4000} {
+ lappend result(FlashMode) "external_E-TTL"
+ }
+ }
+ if {[info exists field(34)] && \
+ [string match -nocase "*pro90*" $cameraModel]} {
+ if {$field(34)} {
+ set result(ImageStabilisation) on
+ } else {
+ set result(ImageStabilisation) off
+ }
+ }
+ } elseif {$tag == 4} {
+ set result(WhiteBalance) [switch $field(7) {
+ 0 {format Auto}
+ 1 {format Daylight}
+ 2 {format Cloudy}
+ 3 {format Tungsten}
+ 4 {format Fluorescent}
+ 5 {format Flash}
+ 6 {format Custom}
+ default {format Unknown}
+ }]
+ if {$field(14) & 0x07} {
+ set result(AFPointsUsed) \
+ [expr {($field(14)>>12) & 0x0F}]
+ if {$field(14)&0x04} {
+ append result(AFPointsUsed) " left"
+ }
+ if {$field(14)&0x02} {
+ append result(AFPointsUsed) " center"
+ }
+ if {$field(14)&0x01} {
+ append result(AFPointsUsed) " right"
+ }
+ }
+ if {[info exists field(15)]} {
+ set v $field(15)
+ if {32768 < $v} {incr v -65536}
+ set v [compensationFraction [expr {$v / 32.0}]]
+ set result(FlashExposureCompensation) $v
+ }
+ if {[info exists field(19)]} {
+ set result(SubjectDistance) "$field(19) m"
+ }
+ } elseif {$tag == 15} {
+ foreach k [array names field] {
+ set func [expr {($field($k) >> 8) & 0xFF}]
+ set v [expr {$field($k) & 0xFF}]
+ if {$func==1 && $v} {
+ set result(LongExposureNoiseReduction) on
+ } elseif {$func==1 && !$v} {
+ set result(LongExposureNoiseReduction) off
+ } elseif {$func==2} {
+ set result(Shutter/AE-Lock) [switch $v {
+ 0 {format "AF/AE lock"}
+ 1 {format "AE lock/AF"}
+ 2 {format "AF/AF lock"}
+ 3 {format "AE+release/AE+AF"}
+ default {format "Unknown"}
+ }]
+ } elseif {$func==3} {
+ if {$v} {
+ set result(MirrorLockup) enable
+ } else {
+ set result(MirrorLockup) disable
+ }
+ } elseif {$func==4} {
+ if {$v} {
+ set result(Tv/AvExposureLevel) "1/3 stop"
+ } else {
+ set result(Tv/AvExposureLevel) "1/2 stop"
+ }
+ } elseif {$func==5} {
+ if {$v} {
+ set result(AFAssistLight) off
+ } else {
+ set result(AFAssistLight) on
+ }
+ } elseif {$func==6} {
+ if {$v} {
+ set result(ShutterSpeedInAVMode) "Fixed 1/200"
+ } else {
+ set result(ShutterSpeedInAVMode) "Auto"
+ }
+ } elseif {$func==7} {
+ set result(AEBSeq/AutoCancel) [switch $v {
+ 0 {format "0, -, + enabled"}
+ 1 {format "0, -, + disabled"}
+ 2 {format "-, 0, + enabled"}
+ 3 {format "-, 0, + disabled"}
+ default {format unknown}
+ }]
+ } elseif {$func==8} {
+ if {$v} {
+ set result(ShutterCurtainSync) "2nd curtain sync"
+ } else {
+ set result(ShutterCurtainSync) "1st curtain sync"
+ }
+ } elseif {$func==9} {
+ set result(LensAFStopButtonFnSwitch) [switch $v {
+ 0 {format "AF stop"}
+ 1 {format "operate AF"}
+ 2 {format "lock AE and start timer"}
+ default {format unknown}
+ }]
+ } elseif {$func==10} {
+ if {$v} {
+ set result(AutoReductionOfFillFlash) disable
+ } else {
+ set result(AutoReductionOfFillFlash) enable
+ }
+ } elseif {$func==11} {
+ if {$v} {
+ set result(MenuButtonReturnPosition) previous
+ } else {
+ set result(MenuButtonReturnPosition) top
+ }
+ } elseif {$func==12} {
+ set result(SetButtonFuncWhenShooting) [switch $v {
+ 0 {format "not assigned"}
+ 1 {format "change quality"}
+ 2 {format "change ISO speed"}
+ 3 {format "select parameters"}
+ default {format unknown}
+ }]
+ } elseif {$func==13} {
+ if {$v} {
+ set result(SensorCleaning) enable
+ } else {
+ set result(SensorCleaning) disable
+ }
+ } elseif {$func==0} {
+ # Discovered by DNew?
+ set result(CameraOwner) $v
+ } else {
+ append result(UnknownCustomFunc) "$func=$v "
+ }
+ }
+ }
+ } else {
+ debug [format "makerNote: Unrecognized TAG: 0x%x" $tag]
+ }
+ }
+ }
+ return [array get result]
+}
+
+proc ::exif::readShort {data offset} {
+ variable intel
+ if {[string length $data] < [expr {$offset+2}]} {
+ error "readShort: end of string reached"
+ }
+ set ch1 [string index $data $offset]
+ set ch2 [string index $data [expr {$offset+1}]]
+ scan $ch1 %c ch1 ; scan $ch2 %c ch2
+ if {$intel} {
+ return [expr {$ch1 + 256 * $ch2}]
+ } else {
+ return [expr {$ch2 + 256 * $ch1}]
+ }
+}
+
+proc ::exif::readLong {data offset} {
+ variable intel
+ if {[string length $data] < [expr {$offset+4}]} {
+ error "readLong: end of string reached"
+ }
+ set ch1 [string index $data $offset]
+ set ch2 [string index $data [expr {$offset+1}]]
+ set ch3 [string index $data [expr {$offset+2}]]
+ set ch4 [string index $data [expr {$offset+3}]]
+ scan $ch1 %c ch1 ; scan $ch2 %c ch2
+ scan $ch3 %c ch3 ; scan $ch4 %c ch4
+ if {$intel} {
+ return [expr {(((($ch4 * 256) + $ch3) * 256) + $ch2) * 256 + $ch1}]
+ } else {
+ return [expr {(((($ch1 * 256) + $ch2) * 256) + $ch3) * 256 + $ch4}]
+ }
+}
+
+proc ::exif::readIFDEntry {data format components offset} {
+ variable intel
+ if {$format == 2} {
+ # ASCII string
+ set value [string range $data $offset [expr {$offset+$components-1}]]
+ return [string trimright $value "\0"]
+ } elseif {$format == 3} {
+ # unsigned short
+ if {!$intel} {
+ set offset [expr {0xFFFF & ($offset >> 16)}]
+ }
+ return $offset
+ } elseif {$format == 4} {
+ # unsigned long
+ return $offset
+ } elseif {$format == 5} {
+ # unsigned rational
+ # This could be messy, if either is >2**31
+ set numerator [readLong $data $offset]
+ set denominator [readLong $data [expr {$offset + 4}]]
+ return [expr {(1.0*$numerator)/$denominator}]
+ } elseif {$format == 10} {
+ # signed rational
+ # Should work normally, since everything in Tcl is signed
+ set numerator [readLong $data $offset]
+ set denominator [readLong $data [expr {$offset + 4}]]
+ return [expr {(1.0*$numerator)/$denominator}]
+ } else {
+ set x [format %08x $format]
+ error "Invalid IFD entry format: $x"
+ }
+}
+
+proc ::exif::compensationFraction {value} {
+ if {$value==0} {return 0}
+ if {$value < 0} {
+ set result "-"
+ set value [expr {0-$value}]
+ } else {
+ set result "+"
+ }
+ set value [expr {int(0.5 + $value * 6)}]
+ set integer [expr {int($value / 6)}]
+ set sixths [expr {$value % 6}]
+ if {$integer != 0} {
+ append result $integer
+ if {$sixths != 0} {
+ append result " "
+ }
+ }
+ if {$sixths == 2} {
+ append result "1/3"
+ } elseif {$sixths == 3} {
+ append result "1/2"
+ } elseif {$sixths == 4} {
+ append result "2/3"
+ } else {
+ # Added by DNew
+ append result "$sixths/6"
+ }
+ return $result
+}
+
+# This returns the list of all possible fieldnames
+# that analyze might return.
+proc ::exif::fieldnames {} {
+ variable cached_fieldnames
+ if {[info exists cached_fieldnames]} {
+ return $cached_fieldnames
+ }
+ # Otherwise, parse the source to find the fieldnames.
+ # Cool, huh? Don'tcha just love Tcl?
+ # Because of this, "result(...)" should only appear
+ # in these functions when "..." is the literal name
+ # of a field to be returned.
+ array set namelist {}
+ foreach proc {analyze app1 exifSubIFD makerNote} {
+ set body [info body ::exif::$proc]
+ foreach line [split $body \n] {
+ if {[regexp {result\(([^)]+)\)} $line junk name]} {
+ set namelist($name) {}
+ }
+ }
+ }
+ set cached_fieldnames [lsort -dictionary [array names namelist]]
+ return $cached_fieldnames
+}
+
+
+
+# # # # # # # # # # # # # #
+# What follows is the original header comments
+# from the Perl code from which this is
+# translated. Any changes I made directly
+# are marked by "DNew".
+
+# PERL script to extract EXIF information from JPEGs generated by Canon
+# digital cameras.
+# This software is free and you may do anything like with it except sell it.
+#
+# Current version: 1.3
+# Author: Chris Breeze
+# email: chris@breezesys.com
+# Web: http://www.breezesys.com
+#
+# Based on experimenting with my G1 and information from:
+# http://www.ba.wakwak.com/~tsuruzoh/Computer/Digicams/exif-e.html
+#
+# Also Canon MakerNote from David Burren's page:
+# http://www.burren.cx/david/canon.html
+#
+# More EXIF info and specs:
+# http://exif.org
+#
+# Warnings:
+# 1) The Subject distance is unreliable. It seems reasonably accurate
+# for the G1 but on the D30 it is highly dependent on the lens fitted.
+#
+# Perl for Windows is available for free from:
+# http://www.activestate.com
+#
+# History
+# 11 Jan 2001
+# v0.1: Initial version
+#
+# 14 Jan 2001
+# v0.2: Updated with data from David Burren's page
+#
+# 15 Jan 2001
+# v0.3: Added more info for D30 (supplied by David Burren)
+# 1) D30 stores ISO in EXIF tag 0x8827, G1 uses MakerNote 0x1/16
+# 2) MakerNote 0x1/10, ImageSize appears to be large, medium, small
+# 3) D30 allows 1/2 or 1/3 stop exposure compensation
+# 4) Added D30 custom function details, but can't test them
+#
+# 17 Jan 2001
+# v1.0 Tidied up AutoFocusMode for G1 vs D30 + added manual auto focus point (D30)
+#
+# 18 Jan 2001
+# v1.1 Removed some debug code left in by mistake
+#
+# 29 Jan 2001
+# v1.2 Added flash mode (MakerNote Tag 1, field 4)
+#
+# 7 Mar 2001
+# v1.3 Added ImageQuality (MakerNote Tag 1, field 3)
+#
+# 21 Apr 2001
+# v1.4 added ImageStabilisation for Pro90 IS
+#
+# 17 Sep 2001
+# v1.5 Incorporated D30 improvements from Jim Leonard
+
+if {0} {
+ # Trivial usage example
+ set x [exif::fieldnames]
+ puts "fieldnames = $x"
+ set f [open [lindex $argv 0]]
+ array set v [exif::analyze $f]
+ close $f
+ parray v
+}
+
diff --git a/tcllib/modules/exif/exif.test b/tcllib/modules/exif/exif.test
new file mode 100644
index 0000000..05e72fa
--- /dev/null
+++ b/tcllib/modules/exif/exif.test
@@ -0,0 +1,42 @@
+# -*- tcl -*-
+# exif.test: tests for the exif structure.
+#
+# 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) 2001-2006 by Andreas Kupries <a.kupries@westend.com>
+# All rights reserved.
+#
+# RCS: @(#) $Id: exif.test,v 1.6 2006/10/09 21:41:40 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.3
+testsNeedTcltest 1.0
+
+testing {
+ useLocal exif.tcl exif
+}
+
+# -------------------------------------------------------------------------
+
+test exif-makernote-19.0 {makernote field 19 (afpoint) is optional} {
+ # AFPoint == AutoFocus Point
+
+ set f [open [file join $::tcltest::testsDirectory noafpoint.jpg] r]
+ fconfigure $f -translation binary
+ array set resa [exif::analyze $f]
+ close $f
+ set resa(FocalPlaneXResolution) [format %13.8f $resa(FocalPlaneXResolution)]
+ set resa(FocalPlaneYResolution) [format %13.8f $resa(FocalPlaneYResolution)]
+ set res [dictsort [array get resa]]
+ unset resa
+ set res
+} {AFPointsUsed {3 right} AperatureValue 7.1 AutoFocusMode {AI servo} CameraMake Canon CameraModel {Canon PowerShot S100} ColorSpace 1 ComponentsConfigured 0x00030201 Contrast Normal DateTime {2004:09:06 05:22:56} DateTimeDigitized {2004:09:06 05:22:56} DateTimeOriginal {2004:09:06 05:22:56} ExifImageHeight 1200 ExifImageWidth 1600 ExifInteroperabilityOffset 1088 ExifVersion 0210 ExposureBiasValue 0 ExposureTime {1/250.0 seconds} FNumber 7.1 FileSource {3 - Digital camera} FirmwareVersion {Firmware Version 1.0} Flash no FlashMode auto FlashPixVersion 0100 FocalLength {5.40625 mm} FocalPlaneResolutionUnit inch FocalPlaneXResolution 7766.99029126 FocalPlaneYResolution 7741.93548387 ISO unknown ImageFormat {IMG:JPEG file} ImageNumber 140-4060 ImageQuality Fine ImageSize large MacroMode normal MeteringMode unknown Orientation 1 Owner Irochka ResolutionUnit inch Saturation Normal SensingMethod 2 Sharpness Normal ShootingMode {Single frame} ShutterSpeedValue {250 Hz} SubjectDistance {3.358 m} UnknownTag-0x10 100925440 UserComment {554 - } WhiteBalance Auto XResolution 180.0 YCbCrPositioning {Center of pixel array} YResolution 180.0}
+
+testsuiteCleanup
diff --git a/tcllib/modules/exif/exif.txt b/tcllib/modules/exif/exif.txt
new file mode 100644
index 0000000..33b8961
--- /dev/null
+++ b/tcllib/modules/exif/exif.txt
@@ -0,0 +1,280 @@
+
+
+The EXIF documentation file D. New
+ February 12, 2002
+
+
+ The EXIF Package
+
+
+Abstract
+
+ Tcl EXIF extracts and parses EXIF fields from digital images.
+
+Table of Contents
+
+ 1. Synopsis . . . . . . . . . . . . . . . . . . . . . . . . . . . . 2
+ 2. Details . . . . . . . . . . . . . . . . . . . . . . . . . . . . 3
+ 3. Copyrights . . . . . . . . . . . . . . . . . . . . . . . . . . . 4
+ 4. Acknowledgements . . . . . . . . . . . . . . . . . . . . . . . . 5
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+New [Page 1]
+
+EXIF The EXIF Package February 2002
+
+
+1. Synopsis
+
+ package provide exif 1.0
+
+ The EXIF package is a recoding of Chris Breeze's Perl package to do
+ the same thing. This version accepts a channel as input and returns
+ a serialized array with all the recognised fields parsed out.
+
+ There is also a function to obtain a list of all possible field names
+ that might be present, which is useful in building GUIs that present
+ such information.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+New [Page 2]
+
+EXIF The EXIF Package February 2002
+
+
+2. Details
+
+ array set answer [exif::analyze $channel]
+
+ $channel should be an open file handle rewound to the start. It does
+ not need to be seekable. $channel will be set to binary mode and is
+ left wherever it happens to stop being parsed, usually at the end of
+ the file or the start of the image data. You must open and close the
+ stream yourself. If no error is thrown, the return value is a
+ serialized array with informative English text about what was found
+ in the EXIF block. Failure during parsing or I/O throw errors.
+
+ set names [exif::fieldnames]
+
+ This returns a list of all possible field names. That is, the array
+ returned by exif::analyze will not contain keys that are not listed
+ in the return from exif::fieldnames. Of course, if information is
+ missing in the image file, exif::analyze may not return all the
+ fields listed in the return from exif::fieldnames. This function is
+ expected to be primarily useful for building GUIs to display results.
+ N.B.: Read the implementation of exif::fieldnames before modifying
+ the implementation of exif::analyze.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+New [Page 3]
+
+EXIF The EXIF Package February 2002
+
+
+3. Copyrights
+
+ (c) 2002 Darren New
+
+ Hold harmless the author, and any lawful use is allowed.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+New [Page 4]
+
+EXIF The EXIF Package February 2002
+
+
+4. Acknowledgements
+
+ This code is a direct translation of version 1.3 of exif.pl by Chris
+ Breeze. See the source for full headers, references, etc.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+New [Page 5]
+
diff --git a/tcllib/modules/exif/exif.xml b/tcllib/modules/exif/exif.xml
new file mode 100644
index 0000000..5d960ac
--- /dev/null
+++ b/tcllib/modules/exif/exif.xml
@@ -0,0 +1,100 @@
+<?xml version="1.0"?>
+<!DOCTYPE rfc SYSTEM "rfc2629.dtd">
+
+<?rfc compact="no"?>
+<?rfc toc="yes"?>
+<?rfc private="The EXIF documentation file"?>
+<?rfc header="EXIF"?>
+
+<rfc>
+<front>
+<title>The EXIF Package</title>
+
+<author initials="D." surname="New" fullname="Darren New">
+<organization/>
+<address>
+<postal>
+<street>5390 Caminito Exquisito</street>
+<city>San Diego</city> <region>CA</region> <code>92130</code>
+<country>US</country>
+</postal>
+<email>dnew@san.rr.com</email>
+</address>
+</author>
+
+<date month="February" year="2002" />
+
+<abstract><t>
+ Tcl EXIF extracts and parses EXIF fields from digital images.
+</t></abstract>
+</front>
+
+<middle>
+
+<section title="Synopsis">
+<figure><artwork><![CDATA[
+ package provide exif 1.0
+]]></artwork></figure>
+
+<t>The EXIF package is a recoding of Chris Breeze's Perl package to do the same
+ thing. This version accepts a channel as input and returns a serialized
+ array with all the recognised fields parsed out. </t>
+
+<t> There is also a function to obtain a list of all possible field names that
+ might be present, which is useful in building GUIs that present such
+ information. </t>
+
+</section>
+
+<section title="Details">
+
+<figure><artwork><![CDATA[
+ array set answer [exif::analyze $channel]
+]]></artwork></figure>
+
+<t> $channel should be an open file handle rewound
+ to the start. It does not need to be seekable.
+ $channel will be set to binary mode and is left
+ wherever it happens to stop being parsed, usually
+ at the end of the file or the start of the image
+ data. You must open and close the stream yourself.
+ If no error is thrown, the return value is a
+ serialized array with informative English text
+ about what was found in the EXIF block. Failure
+ during parsing or I/O throw errors. </t>
+
+<figure><artwork><![CDATA[
+ set names [exif::fieldnames]
+]]></artwork></figure>
+
+<t> This returns a list of all possible field names.
+ That is, the array returned by exif::analyze will
+ not contain keys that are not listed in the return
+ from exif::fieldnames. Of course, if information is
+ missing in the image file, exif::analyze may not
+ return all the fields listed in the return from
+ exif::fieldnames. This function is expected to be
+ primarily useful for building GUIs to display results.
+ N.B.: Read the implementation of exif::fieldnames
+ before modifying the implementation of exif::analyze.
+</t>
+
+</section>
+
+<section title="Copyrights">
+<t>(c) 2002 Darren New</t>
+
+<t>Hold harmless the author, and any lawful use is allowed.</t>
+</section>
+
+<section title="Acknowledgements">
+
+<t> This code is a direct translation of version 1.3 of exif.pl by Chris
+ Breeze. See the source for full headers, references, etc. </t>
+
+</section>
+
+</middle>
+
+</rfc>
+
diff --git a/tcllib/modules/exif/noafpoint.jpg b/tcllib/modules/exif/noafpoint.jpg
new file mode 100644
index 0000000..106c73c
--- /dev/null
+++ b/tcllib/modules/exif/noafpoint.jpg
Binary files differ
diff --git a/tcllib/modules/exif/pkgIndex.tcl b/tcllib/modules/exif/pkgIndex.tcl
new file mode 100644
index 0000000..dc87584
--- /dev/null
+++ b/tcllib/modules/exif/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.3]} {return}
+package ifneeded exif 1.1.2 [list source [file join $dir exif.tcl]]
diff --git a/tcllib/modules/fileutil/ChangeLog b/tcllib/modules/fileutil/ChangeLog
new file mode 100644
index 0000000..6525c50
--- /dev/null
+++ b/tcllib/modules/fileutil/ChangeLog
@@ -0,0 +1,1006 @@
+2013-07-11 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.man: Ticket [8b317b4a63]: Added code to the 8.4+
+ * fileutil.tcl: implementations of GLOBF and GLOBD to guard
+ * fileutil.test: ourselves against VFS packages mishandling the
+ * pkgIndex.tcl: -types option of [glob]. vfs::zip is an example.
+ This mishandling causes glob to return the same data for the two
+ calls with "-types x" and "-types {hidden x}", generating lists
+ with duplicate entries. We now generally de-duplicate the result
+ ourselves. Bumped the package version to 1.14.6. Thanks to
+ <eugene.mindrov@gmail.com> for the investigation identifying
+ this problem.
+
+2013-02-14 Andreas Kupries <andreask@activestate.com>
+
+ * decode.tcl: Bumped fileutil::decode to 0.2 to distinguish
+ * pkgIndex.tcl: properly from the 0.1.xxx version which existed in
+ AS/perforce before it moved to tcllib/fossil. That should have
+ been done as part of the move, and was forgotten.
+
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2013-01-28 Andreas Kupries <andreask@activestate.com>
+
+ * decode.tcl: New. Simple package to support writing decoders
+ * pkgIndex.tcl: for binary files.
+
+2013-01-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.man: [Bug 3147481], [Bug 3141568]. Fixed issues with
+ * fileutil.tcl: changes to [glob]'s behaviour in 8.5+, reported
+ * find.setup: by guardus@users.sourceforge.net. Plus [Bug 3599839]
+ * find.test: reminding us of these, and Win 7. Bumped version to
+ * pkgIndex.tcl: 1.14.5. Extended testsuite, can be repro'd under
+ Unix also.
+
+2012-08-29 Andreas Kupries <andreask@activestate.com>
+
+ * traverse.tcl (Init): Fixed a bug where a symlink to the
+ * traverse.man: base directory was not handled correctly.
+ * traverse.test: It got expanded and should not have been.
+ * pkgIndex.tcl: Cause was missing initialization of the _known set
+ * find.setup: with the normalized base path. Added test for this.
+ Bumped version to 0.4.3.
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-12-02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * traverse.tcl: Mark directories as 'known' only if we decided
+ * traverse.man: to recurse into them. Otherwise a link to a
+ * pkgIndex.tcl: directory we choose to not follow may non-
+ deterministically prevent us from recursing into the original
+ directory, depending on the order we encounter them in. Bumped
+ package version to 0.4.2.
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-06-16 Andreas Kupries <akupries@shaw.ca>
+
+ * fileutil.tcl (::fileutil::fileType): Fumbled the extension of
+ * fileutil.man: the doctools/toc/idx detector in the last change.
+ * pkgIndex.tcl: Fixed the bogosity, merging the separate checks.
+ Bumped to version 1.14.4.
+
+2010-06-09 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl (::fileutil::fileType): Extended to recognize tklib
+ * fileutil.man: diagram files, and extended the doctools/toc/idx
+ * pkgIndex.tcl: detector to accept markers in the same style as
+ for tklib diagrams. Bumped to version 1.14.3.
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-11-24 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl: Extended the doctools/toc/idx detector with
+ * fileutil.man: checks for inclusion and exclusion markers
+ * pkgIndex.tcl: allowing the user to force acceptance or rejection
+ of files for complex situations (like an include file looking like
+ a doctools main file but not bein so, and the converse, a main
+ file lacking the regular marker, which is hidden in an included
+ file). Bumped to version 1.14.2.
+
+2009-10-27 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl (::fileutil::stripPath): [Bug 2872536]. Fixed both
+ * fileutil.man: issues. Compare the canonical list representations
+ * pkgIndex.tcl: for the \\bar problem, and separate $prefix from
+ * strip.test: '*' by a space to prevent matching on a partial path
+ segment. Thanks to Ashok P. Nadkarni
+ <apnadkarni@users.sourceforge.net> for the report. Bumped the
+ version to 1.14.1. Extended the testsuite.
+
+ * pathops.test: Cleaned up some win vs unix issues in the tests.
+
+2009-10-06 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.test: Added fixes to test cleanups, to prevents errors
+ * inplace.test: when the testsuite is only run partially.
+ * test.test:
+
+2009-09-14 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl: Renamed the internal command 'LexNormalize' to
+ * fileutil.man: 'lexnormalize' and documented it, making it
+ * pkgIndex.tcl: public. Bumped version to 1.14. This closes and
+ accepts the feature request [SF Tcllib Bug 2855302]. Tests are
+ currently only indirect, through testing of commands 'jail' and
+ 'relativeUrl'.
+
+2009-04-01 Andreas Kupries <andreask@activestate.com>
+
+ * multiop.tcl (Copy): Fix special case with copying directories
+ * multiop.man: where the source is one level to deep, or copy fails.
+ * pkgIndex.tcl: Bumped version to 0.5.3.
+
+2009-02-10 Andreas Kupries <andreask@activestate.com>
+
+ * traverse.man: Fixed bug in the requirements, this package
+ * traverse.tcl: needs fileutil (-> fullnormalize). Bumped
+ * pkgIndex.tcl: version to 0.4.1.
+
+2009-02-05 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl (::fileutil::stripPath): Fixed handling
+ * fileutil.man: of letter-case on windows, comparisons
+ * strip.test: have to be case-insensitive. Bumped version
+ * pkgIndex.tcl: to 1.13.6. See [SF Tcllib Bug 2499641].
+
+2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11.1 ========================
+ *
+
+2008-12-02 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.man: Fixed [Bug 2376321] (fileutil::TempDir, use
+ * fileutil.tcl: of env(TRASHFOLDER) for OSX). Bumped version
+ * pkgIndex.tcl: to 1.13.5.
+
+2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11 ========================
+ *
+
+2008-10-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * multiop.test: Canonicalized sorting of two test results.
+ * multi.test:
+
+2008-09-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * multiop.tcl: Sync'd to 2008 Sep 3 change in wip-core, using
+ * multiop.man: the new name of the wip processor component.
+ * pkgIndex.tcl: Bumped version to 0.5.2.
+
+2008-06-20 Andreas Kupries <andreask@activestate.com>
+
+ * multiop.tcl: Fixed usage of struct::stack. Now using the
+ * multiop.man: official construction command instead of an
+ * pkgIndex.tcl: internal command recently removed from the
+ struct::stack package. Bumped version to 0.5.1.
+
+2008-05-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * multi.man: Updated to changes in doctools (sub)section reference
+ handling.
+
+2008-02-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * traverse.tcl: Made snit dependency more strict, requesting 1.3+.
+
+2007-10-22 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl: Changed handling of broken symbolic links
+ * fileutil.man: by fileutil::find and fileutil::traverse.
+ * traverse.tcl: They are now recognized and returned.
+ * traverse.man: Extended the testsuite. Bumped fileutil
+ * pkgIndex.tcl: to v1.13.4 and fileutil::traverse to v0.4.
+ * find.setup:
+ * find.test:
+ * traverse.text:
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * multiop.setup: Moved the common setup code for the testing of
+ * multiop.test: the multi-file operations into a separate file.
+ * multi.test: Added commands to query the state of objects.
+ * multiop.tcl: Updated both testsuite and documentation. Version
+ * multiop.man: bumped to 0.5.
+ * pkgIndex.tcl:
+
+2007-08-15 Andreas Kupries <andreask@activestate.com>
+
+ * multiop.tcl (ChDir, ChUp): Fixed the method calls in change dir
+ * multiop.man: operations, forget the $self. Version bumped to 0.4.
+ * pkgIndex.tcl:
+
+2007-08-13 Andreas Kupries <andreask@activestate.com>
+
+ * multiop.tcl (Expand): Fixed bug in recursive expansion, pattern
+ applies to the last segment of the path.
+
+ * multiop.tcl: New features coming out of dog-fooding: Removed
+ * multiop.man: hardwired fixation on files, accept all paths by
+ * multiop.test: default, and added commands to allow the user to
+ * multi.test: limit the expansion to files, firectories, or links.
+ * pkgIndex.tcl: New command to allow the user to specify how
+ strict checking of the 'in(to)' argument is, and if empty
+ expansions are acceptable. Documentation updated. Testsuite
+ updated and extended. Version bumped to 0.3
+
+2007-08-10 Andreas Kupries <andreask@activestate.com>
+
+ * multiop.tcl: New features - Recursive processing.
+ * multiop.test: Expand only mode. Save/restore set of files
+ * pkgIndex.tcl: to/from a variable. Platform checking
+ * multi.test: semi-conditional commands. Invoke a user command for
+ * multiop.man: the file set. Test suite extended, documentation
+ updated. Version bumped to 0.2
+
+ * fileutil.tcl: The rewrite of find changed how it invoked the
+ * fileutil.man: filter command. As that however is documented this
+ * pkgIndex.tcl: change is a bug. Restored the old way of invoking
+ * find.test: the filter command. Version bumped to 1.13.3.
+ Extended the testsuite to verify the API.
+
+2007-08-08 Andreas Kupries <andreask@activestate.com>
+
+ * inplace.test: Fixed failures of some tests on Windows.
+
+ * fileutil.tcl: Working around a possible bug in the handling of
+ path intreps by the core, on Windows. See commentary in
+ 'fullnormalize', and 'find.setup' (f_setupcircle).
+
+ * find.test: Moved the support code into a separate file, the new
+ * find.setup: 'find.setup'. Added a testsuite for the package
+ * traverse.test: 'fileutil::traverse', using the same support
+ * traverse.tcl: code. Rewrote the internals of traverse.tcl based
+ * traverse.man: on the experience gained by the rewrite of 'find',
+ * pkgIndex.tcl: using similar re-focatorization of the platform
+ and core dependencies, and made the traversal state variables
+ easier to understand (separated the processing and result
+ stack). Bumped version of traverse to 0.3.
+
+2007-08-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * find.test: Reworked the setup/cleanup code, made the tests more
+ independent from each other.
+
+ * traverse.man: New file, first documentation for
+ fileutil::traverse.
+
+2007-08-07 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl (::fileutil::find): Command rewritten to use a
+ * pkgIndex.tcl: portable iterative traversal core. Platform and
+ * fileutil.man: Tcl version dependencies have been re-factored
+ into separate small commands. Should be more readable and
+ maintainable. Handling of circular symbolic links is now
+ portable (via a portable 'file normalize'). Order of paths in
+ the output changed, this however was never documented. Version
+ bumped to 1.13.2.
+
+2007-08-03 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.test: Cleaned the setup/cleanup code up a bit.
+
+ * filetype.test: Split the overly large file fileutil.test
+ * fileutil.test: into a series of smaller test files for
+ * find.test: specific commands.
+ * inplace.test:
+ * pathops.test:
+ * strip.test:
+ * test.test:
+
+2007-08-01 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.test: Fixed problems with the tests for
+ fileutil::writeFile and companions. The regsub did not like
+ paths containing special characters like '+'. Replaced with a
+ 'string map' construction.
+
+ * multiop.tcl: Language tweak. Allow 'from', and 'into' (and aliases)
+ * multiop.man: as qualifiers to 'the', i.e. allow specification after
+ * multiop.test: 'the'. Updates documentation and examples too.
+
+ * multi.tcl: Added documentation and testsuite for the multiop
+ * multi.man: package built on top of the multiop objects. Bug
+ * multi.test: fixes.
+ * multiop.tcl:
+ * multiop.man:
+ * multiop.test:
+
+2007-07-31 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * multiop.man: Wrote the actual documentation for the core
+ * multiop.tcl: multi-file objects. Tweaked the syntax a bit.
+
+2007-07-31 Andreas Kupries <andreask@activestate.com>
+
+ * multiop.tcl: New packages in module. Scatter/gather
+ * multiop.test: operations, multi-file operations.
+ * multiop.man: First user of 'wip' code.
+ * multi.tcl:
+ * pkgIndex.tcl:
+
+2007-07-27 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl: Fixed problems of 'relative' and 'relativeUrl'
+ * fileutil.man: with paths containing . and .., i.e. like
+ * fileutil.test: '/foo/bar/../common'. Done by making the paths
+ * pkgIndex.man: absolute and then using LexNormalize to remove
+ them. Added a fast path to LexNormalize to quickly return for
+ paths not containing . nor .. Also fixed bug in handling .. with
+ short relative paths. Extended the testsuite. Package bumped to
+ version 1.13.1 (patchlevel, bugfixes only).
+
+2007-06-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl (::fileutil::fullnormalize): Simplified the
+ implementation by recognizing that the complex
+ file split/lrange/eval/join combo is just 'file dirname'.
+
+2007-06-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * traverse.tcl: Fixed invokation of -filter callback when used for
+ * pkgIndex.tcl: directories. Wrongly used only the short path. Now
+ correctly uses the full name. Bumped package version to 0.2.
+
+2007-05-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl: Added command 'tempdirReset' to allow users to
+ * fileutil.man: clear the information set via 'tempdir path'.
+ * pkgIndex.tcl: Bumped package to version 1.13. Additionally
+ extended relative-url computation to make the result of an
+ edge-case nicer looking (result was ok, but not
+ optimal). Extended testsuite for this. Extended error output
+ when computation of relative path fails.
+
+2007-03-28 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl (::fileutil::fileType): Added definitions to
+ * pkgIndex.tcl: recognize Apple .icns files.
+ * fileutil.man: Bumped version up to 1.12.
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.man: Fixed all warnings due to use of now deprecated
+ commands. Added a section about how to give feedback.
+
+2007-03-12 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl (::fileutil::TempDir): Added code to collect all
+ * pkgIndex.tcl: problems encountered, to be reported if no temp
+ * fileutil.man: directory could be found, to aid in the
+ debugging of the situation. Bumped version up to 1.11.
+
+2007-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl: Added a command [fileutil::fullnormalize].
+ * fileutil.man: Documented it, extended the testsuite. Bumped
+ * filetuil.test: version up to 1.10. Removed nonsensical
+ * pkgIndex.tcl: [file join one_element] calls from the testsuite.
+
+2006-10-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Marked all 20 permission dependent tests as
+ 'notRoot' as they cannot fail when the superuser executes the
+ testsuite.
+
+2006-10-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Rewritten to use new features for handling the
+ environment.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl: Bumped version to 1.9
+ * fileutil.man:
+ * pkgIndex.tcl:
+
+2006-09-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Fixed 8.3isms in the testsuite. Symbolic
+ permissions for 'file attributes' are not available in 8.2 yet
+ :(. Also fixed the tests using hardcoded wrong#args messages to
+ use the compatibility commands instead.
+
+2006-09-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Fixed 8.4ism in the testsuite of a 8.2+ package.
+
+2006-07-19 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl (fileutil::jail): Fixed [Tcllib SF Bug 1525172], by
+ * fileutil.test: Ramon Ribo. Accepted the provided
+ solution. Extended the testsuite.
+
+2006-06-16 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl: Added commands to compute paths relative to some
+ * fileutil.man: base. Extended testsuite, documentation.
+ * fileutil.test:
+ * pkgIndex.tcl:
+
+2006-04-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.man: Extended documentation.
+ * fileutil.test: Extended testsuite for x/exec.
+ * fileutil.tcl: Added x/exec'utable flag to the 'test' command.
+
+2006-03-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * traverse.tcl: Bug fixes. Added the missing declaration of the
+ dev/inode cache, and moved the restoration of the old working
+ directory in the 8.3 glob -directory emulation to their proper
+ place.
+
+ * traverse.tcl: New file. Object based directory traversal,
+ * pkgIndex.tcl: incremental at the core, i.e. can be event-
+ driven. Iterative algorithm, no trouble with deep directory
+ structures anymore. Not documented yet, no testsuite yet.
+
+2006-03-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Removed some hardcoded paths into my
+ system. Thanks to Michael Schlenker for catching this.
+
+2006-03-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl: Extended the tempdir command to allow the user
+ * fileutil.man: to set a directory to use, exclusively. Updated
+ * fileutil.test: both documentation and testsuite.
+
+ * fileutil.tcl: Added a 'test' command for the quick testing of
+ * fileutil.man: several properties of a given path. Extended
+ * fileutil.test: both documentation and testsuite.
+
+2006-02-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.man: Updated the documentation to cover all the new
+ commands.
+
+ * fileutil.test: Extended testsuite to cover the command
+ 'updateInPlace'.
+
+ * fileutil.tcl: Fixed bug in implementation of 'updateInPlace', we
+ wrote the unchanged input back instead of the transformation
+ result.
+
+2006-02-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Extended the testsuite to cover the commands
+ 'appendToFile', 'insertIntoFile', 'removeFromFile', and
+ 'replaceInFile'.
+
+ * fileutil.tcl: Added argument validation to the commands
+ 'appendToFile', 'insertIntoFile', 'removeFromFile', and
+ 'replaceInFile'. Modified their implementation to use shorter
+ implementations for the degenerate cases.
+
+2006-02-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Extended testsuite to cover the command
+ 'writeFile'.
+
+ * fileutil.tcl: Fixed problems in common option processor and
+ supporting commands.
+
+2006-02-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl: Added commands 'writeFile', 'appendToFile',
+ 'insertIntoFile', 'removeFromFile', 'replaceInFile', and
+ 'updateInPlace'. Extended 'cat' with option processing for
+ -encoding, ...
+
+ * fileutil.test: Extended testsuite of 'cat', and made
+ this part self-contained with regard to temp files.
+
+2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Fixed use and cleanup of temp.files.
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Hooked into the new common test support code.
+
+2006-01-18 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.man: Fixed a typo, clarified usage of the filtercmd for
+ find (Boolean result), added an example for that as well. This
+ fixes the [SF Tcllib Bug 1409083] submitted by Glenn Jackman
+ <glennjnn@users.sourceforge.net>.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-09-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test (tempdir-1.2): Added code to remove the env
+ variable TEMP as well. It is set on my host and can thus
+ interfere with the test.
+
+2005-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Fixed a bug in find, where it excluded symbolic
+ * fileutil.tcl: links if the destination was circular. This is
+ wrong. The link itself can be listed in the result, it just must
+ not be followed. Otherwise even non-circular links are not listed.
+
+2005-02-14 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.man (find): Documented the implicit arguments to the
+ filter command (current working directory). This fixes [SF
+ Tcllib Bug 1048995].
+
+2005-02-10 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl (fileutil::jail): Fixed a problem reported by Pat
+ Thoyts. Test jail-2.1 failed on windows. The reason was improper
+ handling of volume-relative paths. They have to be handled like
+ absolute paths, but were not. Changed the initial if condition a
+ bit to fix this.
+
+2005-02-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl: Made glob patterns platform-dependent. This fixes
+ [SF Tcllib Bug 1098039].
+
+2005-02-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Added test case for the handling of dot-files by
+ [find]. This is for [SF Tcllib Bug 1098039].
+
+2005-02-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl: Completed implementation and testing of the 'jail'
+ command which ensures that a path is inside a specific
+ directory. Implemented a 'LexNormalize' helper
+ command.
+
+ * fileutil.test: Added additional test for 'jail' beyond our
+ current suite.
+
+2005-02-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl: Implemented command 'stripPath'. Like 'stripPwd'
+ for a general prefix path [SF Tcllib RFE 1040372].
+
+ * fileutil.test: Added tests for 'stripPath.
+ * fileutil.man: Documented 'stripPath'.
+
+2005-02-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Added tests for the 'Normalize' forward
+ compatibility wrapper. Got them from the Tcl testsuite for 'file
+ normalize'. Added tests for the new 'jail' command.
+
+ * fileutil.tcl: Wrote a forward compatibility implementation of
+ 'file normalize', for use with a Tcl core < 8.4. Updated the
+ (non)use of 'file normalize' by 'tempdir' and 'tempfile'.
+ Updated the namespace export clause. Implemented the 'jail'
+ command [SF Tcllib RFE 111076].
+
+2005-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Extended tests for the case of inacessible
+ directories.
+
+ * fileutil.tcl (find): Fixed SF [Tcllib Bug 1111153]. This is the
+ same as [Tcllib SF Bug 862491]. Catching problems now when
+ cd'ing into the chosen base directory, and ignoring all
+ directories for which the [cd] fails (permissions).
+
+2005-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.man: Fixed the doctools syntax error in the new text
+ from the last entry.
+
+2005-01-26 David N. Welton <davidw@dedasys.com>
+
+ * fileutil.man: Added a small note on the measure used to count
+ elements in fileutil::stripN.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-09-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Introduced a "makeBinaryFile" command to ensure
+ the correct generation of the example files which contain
+ binary. Thanks to Greg Baker <gregb@ifost.org.au> for noticing
+ the problem on his Mac OS X box and helping in debugging it.
+
+2004-09-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Fixed platform problems in testsuite, bad
+ characters in filenames for Windows.
+
+2004-06-16 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl (fileType): Added code to recognize files written
+ in the doctools, doctoc, and docidx documentation formats.
+
+2004-05-30 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * fileutil.tcl: added tests for dos executables, tar, zip, bmp, wav, and mp3 to fileType
+ * fileutil.man: updated to reflect new types for fileType
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl: Updated version number to sync with 1.6.1
+ * fileutil.man: release.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl: Rel. engineering. Updated version number
+ * fileutil.man: of fileutil to reflect its changes, to 1.6.1.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Cleaning up after Aaron. Updated the test
+ filetype-1.12 to look for the extended return value of fileType
+ when applied to jpeg images. The last checkin changed this, but
+ the test was not updated as well, most likely not even
+ run. Found and corrected during release preparation and testing.
+
+2004-05-11 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * fileutil.tcl: updated the jpeg test to recognize exif format
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: The tempdir tests used advanced test syntax not
+ available before 8.4 (IIRC). Not useable for 8.2. Ditto the lot of
+ the install tests also used 8.3 and 8.4 features. Straightened
+ the bad syntax out (killed the tests), and added proper
+ constraints to the tests.
+
+ * fileutil.tcl: Ooops. fileutil is certified for usage with Tcl
+ 8.2, there is no [file normalize] before 8.4. Made the usage
+ (See 2004-02-03) conditional.
+
+2004-02-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Modified the tests a bit to use glob characters
+ in file names to check that the code is robust against that too.
+
+ See http://bugs.activestate.com/show_bug.cgi?id=29491
+
+2004-02-03 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl (tempdir, tempfile): Now [file normalize]'ing the
+ results of these two commands. More windows friendly.
+
+2004-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl (fileutil::find): Fixed bug in handling a single
+ file as base directory: The initial list was not set up as a
+ list, and the test results (see below) were not listified either
+ for these cases. That broke down for paths containing
+ spaces. Also fixed: Neither the windows nor the pre-8.4 version
+ of the command had been modified to deal with a single file.
+ Oversight from the change @ 2003-10-22 by David N. Welton
+ <davidw@dedasys.com>.
+
+ Regularized a number of error returns.
+
+ * fileutil.test: Changed testsuite to use files and directories
+ containing spaces in their names. A number of tests
+ failed. Modified the tempdir tests to better exclude and
+ manipulate the environment to enforce the wanted result.
+
+2004-01-23 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl (fileType): The check for an attached metakit
+ database left a channel on the tested file open. This causes the
+ application to leak channels, and on windows the file is also
+ locked against deletion. Fixed.
+
+2003-11-15 David N. Welton <davidw@dedasys.com>
+
+ * fileutil.man: Added new test and docs for change below.
+
+ * fileutil.tcl (::fileutil::cat): Make cat accept multiple files
+ (bug [830075]).
+
+2003-10-27 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.man: Better formatting of the new docs.
+
+2003-10-25 David N. Welton <davidw@dedasys.com>
+
+ * fileutil.man: Documented 'fileutil::tempdir' algorithm.
+
+2003-10-23 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.man: Updated documentation, added description of
+ 'fileutil::tempdir'.
+
+2003-10-23 David N. Welton <davidw@dedasys.com>
+
+ * fileutil.test (tempdir): Added a few very simple tests for
+ tempdir under Unix.
+
+ * fileutil.tcl (::fileutil::tempdir): Added tempdir
+ implementation.
+ (::fileutil::tempfile): Use new tempdir command.
+
+2003-10-22 David N. Welton <davidw@dedasys.com>
+
+ * fileutil.tcl (::fileutil::find): Change Unix version of find
+ command to accept a file (as opposed to a directory) as an
+ argument. This reflects the behavior of the Unix find
+ command. This change also needs to be added to the windows
+ version, but should probably be done by someone who can test it
+ on that platform.
+ (::fileutil::install): -m option only works on Unix, as far as I
+ know.
+ (::fileutil::install): Make sure correct thing is chmod'ed.
+
+ * fileutil.test: Added tests for find to check that it works ok
+ with a single file as an argument. Also, error out if initial
+ file does not correspond to 'isfile' or 'isdirectory'.
+
+2003-09-03 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl (fileutil::fileType): Fixed the SourceForge Tcllib
+ bug [795585]. We are now allowing whitespace between the #! and
+ path of the script interpreter. Extended to identify metakit
+ databases, also when attached to another file.
+
+ (tempfile): Added 'global env', access to 'env' was bad, causing
+ malfunction on windows.
+
+2003-08-12 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.man: Fixed a bad call of [cmd] in the documentation of
+ the new install command. Always use 'sak validate moldule' to
+ validate the whole module, or 'sak text module' when wishing to
+ validate only the documentation.
+
+2003-08-06 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl (find): The fix for SF tcllib bug [647974]
+ introduced a tcl command new to tcl 8.4. This command is
+ [file system]. Changing the code to exclude dev/inode checking
+ only for 8.4 and above. For versions of Tcl below 8.4. the fix
+ is not required as they do not have virtual filesystem
+ support. This fixes SF tcllib bug [784157].
+
+2003-08-06 David N. Welton <davidw@dedasys.com>
+
+ * fileutil.man: Added documentation for the new 'install' command.
+
+ * fileutil.tcl (::fileutil::install): Added 'install' command,
+ which is similar in functionality to the Unix install command - it
+ is basically file copy with some additional features.
+
+ * fileutil.test: Added tests for 'install' fileutil command.
+
+2003-07-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bumped version to 1.5.1 as this is a bug fix. Any bug fixes and
+ more minor changes coming in the future do not have to bump the
+ version number anymore until the next release. Only a major
+ change warrants another bump before the release.
+
+ * fileutil.tcl: Fixed SF tcllib bug [647974]. We now ignore
+ device/inode information if the current path is in a virtual
+ filesystem. We also assume now that VFS's do not support links,
+ thus also obviating the need for the data, circles cannot occur.
+
+2003-05-09 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.tcl (::fileutil::tempfile): Braced [expr].
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-05-01 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * fileutil.tcl: The touch command cannot be implemented in Tcl
+ * fileutil.test: versions < 8.3 so do not define the command.
+ * fileutil.man: Noted in documentation and skipped tests.
+
+2003-04-23 Andreas Kupries <andreask@pliers.activestate.com>
+
+ * fileutil.man:
+ * fileutil.tcl: Added command [tempfile]. Was part of tcllib patch
+ 611595, but has a better place here.
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.man:
+ * fileutil.tcl:
+ * pkgIndex.tcl: Set version of the package to to 1.5.
+
+2003-04-02 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.test (fileutil): Fixed tcllib SF bug #714214 reported
+ by Pat Thoyts, by working around the 'makeFile' command provided
+ with tcltest. It seems to have issues when doing binary data.
+
+2003-03-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl (fileutil::touch): Applied patch #688965 provided
+ by Glenn Jackman <glennjnn@users.sourceforge.net>. This patch
+ provides a better message when asking the [fileutil::touch]
+ command for help.
+
+2003-03-24 Andreas Kupries <andreask@activestate.com>
+
+ * fileutil.test:
+ * fileutil.man:
+ * fileutil.tcl: Fixed bug #707009, reported by Helmut Giese
+ <hgiese@users.sourceforge.net>, also updated the documentation
+ and the testsuite.
+
+2003-01-28 David N. Welton <davidw@dedasys.com>
+
+ * fileutil.tcl (::fileutil::fileType): Use 'string match' instead
+ of regexp. Require Tcl 8.2.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.man: More semantic markup, less visual one.
+
+2002-10-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl:
+ * fileutil.man:
+ * fileutil.test: Accepted enhanced format detection by Philip
+ Ehrens <pehrens@ligo.caltech.edu>.
+
+2002-05-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl (cat): Fixed bug #556504, reported by Michael
+ A. Cleverly <cleverly@users.sourceforge.net>. The fix was
+ provided by Michael too. The problem was reading files which are
+ reported as size 0, but actually have content, just dynamically
+ generated (Linux /proc is an example of an fs containing such
+ files).
+
+2002-05-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.man: Documented the two new commands (stripN,
+ stripPwd).
+
+ * fileutil.tcl: Made up my mind about SF Bug #462015. The proposed
+ interface change to [find] is rejected to keep the interface of
+ the library procedure simple and without hidden surprises =
+ KISS. Added a command [stripPwd] instead which can be used by
+ the caller of [find] to make the returned paths relative to the
+ current working directory. Also added [stripN] to strip a fixed
+ number of elements from the beginning of a path.
+
+2002-04-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.man: Added doctools manpage.
+ * fileutils.n: Updated to reflect change of version.
+
+2002-03-20 Eric Melski <ericm@ajubasolutions.com>
+
+ * Bumped version to 1.4
+
+ * fileutil.n:
+ * fileutil.test:
+ * fileutil.tcl: Added fileType command posted to comp.lang.tcl by
+ Phil Ehrens, with some minor modifications.
+
+2002-01-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bumped version to 1.3
+
+2001-12-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test: Restricted tests 2.2 and 2.3 to the directory
+ structure created for the test and not the whole directory the
+ test is run in. Bugfix for item #486572.
+
+2001-11-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.test:
+ * fileutil.n:
+ * fileutil.tcl: Applied patch #477805 by Glenn Jackman
+ <glennjnn@users.sourceforge.net> implementing the unix 'touch'
+ command. Contains documentation and testsuite for the new
+ command too.
+
+2001-09-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl: Restricted export list to public API.
+ [456255]. Patch by Hemang Lavana
+ <hemanglavana@users.sourceforge.net>
+
+2001-08-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * All of the changes below are related to tcllib Patch [449531] by
+ Anselm Lingnau <lingnau@users.sourceforge.net>. Instead of
+ taking in the proposed highlevel 'fileinput' I added some of the
+ more low-level commands from Tclx which can be used to
+ create/compose 'fileinput'.
+
+ * pkgIndex.tcl: Moved version of fileutil to 1.2.
+
+ * fileutil.test: Added tests for the new commands. Moved version
+ of fileutil to 1.2.
+
+ * fileutil.n: Added documentation of the new commands. Moved
+ version of fileutil to 1.2.
+
+ * fileutil.tcl (findByPattern, foreachLine): New commands, modeled
+ after TclX's 'recursive_glob' and 'for_file'. Moved version of
+ fileutil to 1.2.
+
+2001-07-31 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.n: Added manpage documenting the commands. tcllib Bug
+ [446584].
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl: Fixed dubious code reported by frink.
+
+2001-03-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil.tcl: [Bug #410104, Patch #410106]
+ New implementation of ::fileutil::find for unixoid OSs using
+ stat and device/inode configuration to detect and break circular
+ softlink structures. This implementation also skips un'stat'able
+ files and directories.
+
+ * fileutil.test: Added fileutil-1.4 testing the circle breaker
+ (only under unix).
+
+2000-03-10 Eric Melski <ericm@scriptics.com>
+
+ * fileutil.test:
+ * fileutil.tcl: Added cat function, duplicates standard UNIX "cat"
+ utility.
+
+2000-03-09 Eric Melski <ericm@scriptics.com>
+
+ * fileutil.test: Collected tests into one file; adapted tests for
+ use in/out of tcllib test framework.
+
diff --git a/tcllib/modules/fileutil/cross-index-trav.inc b/tcllib/modules/fileutil/cross-index-trav.inc
new file mode 100644
index 0000000..a51b823
--- /dev/null
+++ b/tcllib/modules/fileutil/cross-index-trav.inc
@@ -0,0 +1,16 @@
+[example {
+ package require fileutil::traverse
+
+ proc NoLinks {fileName} {
+ if {[string equal [file type $fileName] link]} {
+ return 0
+ }
+ return 1
+ }
+
+ fileutil::traverse T /sys/devices -prefilter NoLinks
+ T foreach p {
+ puts $p
+ }
+ T destroy
+}]
diff --git a/tcllib/modules/fileutil/cross-index.inc b/tcllib/modules/fileutil/cross-index.inc
new file mode 100644
index 0000000..5abce12
--- /dev/null
+++ b/tcllib/modules/fileutil/cross-index.inc
@@ -0,0 +1,12 @@
+[example {
+ /sys/class/tty/tty0 --> ../../dev/tty0
+ /sys/class/tty/tty1 --> ../../dev/tty1
+ /sys/class/tty/tty2 --> ../../dev/tty1
+
+ /sys/dev/tty0/bus
+ /sys/dev/tty0/subsystem --> ../../class/tty
+ /sys/dev/tty1/bus
+ /sys/dev/tty1/subsystem --> ../../class/tty
+ /sys/dev/tty2/bus
+ /sys/dev/tty2/subsystem --> ../../class/tty
+}]
diff --git a/tcllib/modules/fileutil/decode.tcl b/tcllib/modules/fileutil/decode.tcl
new file mode 100644
index 0000000..a9d205a
--- /dev/null
+++ b/tcllib/modules/fileutil/decode.tcl
@@ -0,0 +1,191 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Copyright (c) 2008-2009 ActiveState Software Inc.
+## Andreas Kupries
+## BSD License
+##
+# Package to help the writing of file decoders. Provides generic
+# low-level support commands.
+
+package require Tcl 8.4
+
+namespace eval ::fileutil::decode {
+ namespace export mark go rewind at
+ namespace export byte short-le long-le nbytes skip
+ namespace export unsigned match recode getval
+ namespace export clear get put putloc setbuf
+}
+
+# ### ### ### ######### ######### #########
+##
+
+proc ::fileutil::decode::open {fname} {
+ variable chan
+ set chan [::open $fname r]
+ fconfigure $chan \
+ -translation binary \
+ -encoding binary \
+ -eofchar {}
+ return
+}
+
+proc ::fileutil::decode::close {} {
+ variable chan
+ ::close $chan
+}
+
+# ### ### ### ######### ######### #########
+##
+
+proc ::fileutil::decode::mark {} {
+ variable chan
+ variable mark
+ set mark [tell $chan]
+ return
+}
+
+proc ::fileutil::decode::go {to} {
+ variable chan
+ seek $chan $to start
+ return
+}
+
+proc ::fileutil::decode::rewind {} {
+ variable chan
+ variable mark
+ if {$mark == {}} {
+ return -code error "No mark to rewind to"
+ }
+ seek $chan $mark start
+ set mark {}
+ return
+}
+
+proc ::fileutil::decode::at {} {
+ variable chan
+ return [tell $chan]
+}
+
+# ### ### ### ######### ######### #########
+##
+
+proc ::fileutil::decode::byte {} {
+ variable chan
+ variable val [read $chan 1]
+ binary scan $val c val
+ return
+}
+
+proc ::fileutil::decode::short-le {} {
+ variable chan
+ variable val [read $chan 2]
+ binary scan $val s val
+ return
+}
+
+proc ::fileutil::decode::long-le {} {
+ variable chan
+ variable val [read $chan 4]
+ binary scan $val i val
+ return
+}
+
+proc ::fileutil::decode::nbytes {n} {
+ variable chan
+ variable val [read $chan $n]
+ return
+}
+
+proc ::fileutil::decode::skip {n} {
+ variable chan
+ #read $chan $n
+ seek $chan $n current
+ return
+}
+
+# ### ### ### ######### ######### #########
+##
+
+proc ::fileutil::decode::unsigned {} {
+ variable val
+ if {$val >= 0} return
+ set val [format %u [expr {$val & 0xffffffff}]]
+ return
+}
+
+proc ::fileutil::decode::match {eval} {
+ variable val
+
+ #puts "Match: Expected $eval, Got: [format 0x%08x $val]"
+
+ if {$val == $eval} {return 1}
+ rewind
+ return 0
+}
+
+proc ::fileutil::decode::recode {cmdpfx} {
+ variable val
+ lappend cmdpfx $val
+ set val [uplevel 1 $cmdpfx]
+ return
+}
+
+proc ::fileutil::decode::getval {} {
+ variable val
+ return $val
+}
+
+# ### ### ### ######### ######### #########
+##
+
+proc ::fileutil::decode::clear {} {
+ variable buf {}
+ return
+}
+
+proc ::fileutil::decode::get {} {
+ variable buf
+ return $buf
+}
+
+proc ::fileutil::decode::setbuf {list} {
+ variable buf $list
+ return
+}
+
+proc ::fileutil::decode::put {name} {
+ variable buf
+ variable val
+ lappend buf $name $val
+ return
+}
+
+proc ::fileutil::decode::putloc {name} {
+ variable buf
+ variable chan
+ lappend buf $name [tell $chan]
+ return
+}
+
+# ### ### ### ######### ######### #########
+##
+
+namespace eval ::fileutil::decode {
+ # Stream to read from
+ variable chan {}
+
+ # Last value read from the stream, or modified through decoder
+ # operations.
+ variable val {}
+
+ # Remembered location in the stream
+ variable mark {}
+
+ # Buffer for accumulating structured results
+ variable buf {}
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+package provide fileutil::decode 0.2
+return
diff --git a/tcllib/modules/fileutil/filetype.test b/tcllib/modules/fileutil/filetype.test
new file mode 100644
index 0000000..55123cf
--- /dev/null
+++ b/tcllib/modules/fileutil/filetype.test
@@ -0,0 +1,193 @@
+# -*- tcl -*-
+# Tests for the find function.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2001 by ActiveState Tool Corp.
+# Copyright (c) 2005-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: filetype.test,v 1.1 2007/08/03 23:07:25 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+support {
+ useTcllibFile fumagic/fumagic.testsupport ; # Filetype helpers.
+ use cmdline/cmdline.tcl cmdline
+}
+testing {
+ useLocal fileutil.tcl fileutil
+}
+
+# -------------------------------------------------------------------------
+
+set path [makeFile {} bogus]
+removeFile bogus
+
+# -------------------------------------------------------------------------
+
+test fileType-1.1 {test file non-existance} {
+ set res [catch {fileutil::fileType $path} msg]
+ list $res $msg
+} [list 1 "file not found: '$path'"]
+
+test fileType-1.2 {test file directory} {
+ set f [makeDirectory fileTypeTest]
+ set res [catch {fileutil::fileType $f} msg]
+ removeDirectory fileTypeTest
+ list $res $msg
+} [list 0 [list directory]]
+
+test fileType-1.3 {test file empty} {
+ set f [makeEmptyFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removeEmptyFile
+ list $res $msg
+} [list 0 [list empty]]
+
+test fileType-1.4 {test simple binary} {
+ set f [makeBinFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removeBinFile
+ list $res $msg
+} [list 0 [list binary]]
+
+test fileType-1.5 {test elf executable} {
+ set f [makeElfFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removeElfFile
+ list $res $msg
+} [list 0 [list binary executable elf]]
+
+test fileType-1.6 {test simple text} {
+ set f [makeTextFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removeTextFile
+ list $res $msg
+} [list 0 [list text]]
+
+test fileType-1.7 {test script file} {
+ set f [makeScriptFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removeScriptFile
+ list $res $msg
+} [list 0 [list text script /bin/tclsh]]
+
+test fileType-1.8 {test html text} {
+ set f [makeHtmlFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removeHtmlFile
+ list $res $msg
+} [list 0 [list text html]]
+
+test fileType-1.9 {test xml text} {
+ set f [makeXmlFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removeXmlFile
+ list $res $msg
+} [list 0 [list text xml]]
+
+test fileType-1.10 {test xml with dtd text} {
+ set f [makeXmlDTDFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removeXmlDTDFile
+ list $res $msg
+} [list 0 [list text xml foobar]]
+
+test fileType-1.11 {test PGP message} {
+ set f [makePGPFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removePGPFile
+ list $res $msg
+} [list 0 [list text message pgp]]
+
+test fileType-1.12 {test binary graphic jpeg} {
+ set f [makeJpegFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removeJpegFile
+ list $res $msg
+} [list 0 [list binary graphic jpeg jfif]]
+
+test fileType-1.13 {test binary graphic gif} {
+ set f [makeGifFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removeGifFile
+ list $res $msg
+} [list 0 [list binary graphic gif]]
+
+test fileType-1.14 {test binary graphic png} {
+ set f [makePngFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removePngFile
+ list $res $msg
+} [list 0 [list binary graphic png]]
+
+test fileType-1.15 {test binary graphic tiff} {
+ set f [makeTiffFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removeTiffFile
+ list $res $msg
+} [list 0 [list binary graphic tiff]]
+
+test fileType-1.16 {test binary pdf} {
+ set f [makePdfFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removePdfFile
+ list $res $msg
+} [list 0 [list binary pdf]]
+
+test fileType-1.17 {test text ps} {
+ set f [makePSFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removePSFile
+ list $res $msg
+} [list 0 [list text ps eps]]
+
+test fileType-1.18 {test text eps} {
+ set f [makeEPSFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removeEPSFile
+ list $res $msg
+} [list 0 [list text ps eps]]
+
+test fileType-1.19 {test binary gravity_wave_data_frame} {
+ set f [makeIgwdFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removeIgwdFile
+ list $res $msg
+} [list 0 [list binary gravity_wave_data_frame]]
+
+test fileType-1.20 {test binary compressed bzip} {
+ set f [makeBzipFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removeBzipFile
+ list $res $msg
+} [list 0 [list binary compressed bzip]]
+
+test fileType-1.21 {test binary compressed gzip} {
+ set f [makeGzipFile]
+ set res [catch {fileutil::fileType $f} msg]
+ removeGzipFile
+ list $res $msg
+} [list 0 [list binary compressed gzip]]
+
+test fileType-1.22 {text pdf} {
+ set f [localPath test-data/pdf4tcl_01.pdf]
+ set res [catch {fileutil::fileType $f} msg]
+ list $res $msg
+} [list 0 [list text pdf]]
+
+# -------------------------------------------------------------------------
+
+unset path
+testsuiteCleanup
+return
diff --git a/tcllib/modules/fileutil/fileutil.man b/tcllib/modules/fileutil/fileutil.man
new file mode 100644
index 0000000..370c47d
--- /dev/null
+++ b/tcllib/modules/fileutil/fileutil.man
@@ -0,0 +1,522 @@
+[vset PACKAGE_VERSION 1.15]
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin fileutil n [vset PACKAGE_VERSION]]
+[keywords cat]
+[keywords {file utilities}]
+[keywords grep]
+[keywords {temp file}]
+[keywords test]
+[keywords touch]
+[keywords type]
+[moddesc {file utilities}]
+[titledesc {Procedures implementing some file utilities}]
+[category {Programming tools}]
+[require Tcl 8]
+[require fileutil [opt [vset PACKAGE_VERSION]]]
+[description]
+[para]
+
+This package provides implementations of standard unix utilities.
+
+[list_begin definitions]
+
+[call [cmd ::fileutil::lexnormalize] [arg path]]
+
+This command performs purely lexical normalization on the [arg path] and returns
+the changed path as its result. Symbolic links in the path are [emph not] resolved.
+
+[para]
+Examples:
+[example {
+ fileutil::lexnormalize /foo/./bar
+ => /foo/bar
+
+ fileutil::lexnormalize /foo/../bar
+ => /bar
+}]
+
+[call [cmd ::fileutil::fullnormalize] [arg path]]
+
+This command resolves all symbolic links in the [arg path] and returns
+the changed path as its result.
+
+In contrast to the builtin [cmd {file normalize}] this command
+resolves a symbolic link in the last element of the path as well.
+
+[call [cmd ::fileutil::test] [arg path] [arg codes] [opt [arg msgvar]] [opt [arg label]]]
+
+A command for the testing of several properties of a [arg path]. The
+properties to test for are specified in [arg codes], either as a list
+of keywords describing the properties, or as a string where each
+letter is a shorthand for a property to test. The recognized keywords,
+shorthands, and associated properties are shown in the list below. The
+tests are executed in the order given to the command.
+
+[para]
+
+The result of the command is a boolean value. It will be true if and
+only if the [arg path] passes all the specified tests.
+
+In the case of the [arg path] not passing one or more test the first
+failing test will leave a message in the variable referenced by
+
+[arg msgvar], if such is specified. The message will be prefixed with
+[arg label], if it is specified.
+
+[emph Note] that the variabled referenced by [arg msgvar] is not touched at
+all if all the tests pass.
+
+[para]
+[list_begin definitions]
+[def "[emph r]ead"]
+[cmd {file readable}]
+[def "[emph w]rite"]
+[cmd {file writable}]
+[def "[emph e]xists"]
+[cmd {file exists}]
+[def "e[emph x]ec"]
+[cmd {file executable}]
+[def "[emph f]ile"]
+[cmd {file isfile}]
+[def "[emph d]ir"]
+[cmd {file isdirectory}]
+[list_end]
+
+[call [cmd ::fileutil::cat] ([opt [arg options]] [arg file])...]
+
+A tcl implementation of the UNIX [syscmd cat] command. Returns the
+contents of the specified file(s). The arguments are files to read,
+with interspersed options configuring the process. If there are
+problems reading any of the files, an error will occur, and no data
+will be returned.
+
+[para]
+
+The options accepted are [option -encoding], [option -translation],
+[option -eofchar], and [option --]. With the exception of the last all
+options take a single value as argument, as specified by the tcl
+builtin command [cmd fconfigure]. The [option --] has to be used to
+terminate option processing before a file if that file's name begins
+with a dash.
+
+[para]
+
+Each file can have its own set of options coming before it, and for
+anything not specified directly the defaults are inherited from the
+options of the previous file. The first file inherits the system
+default for unspecified options.
+
+[call [cmd ::fileutil::writeFile] [opt [arg options]] [arg file] [arg data]]
+
+The command replaces the current contents of the specified [arg file]
+with [arg data], with the process configured by the options. The
+command accepts the same options as [cmd ::fileutil::cat]. The
+specification of a non-existent file is legal and causes the command
+to create the file (and all required but missing directories).
+
+[call [cmd ::fileutil::appendToFile] [opt [arg options]] [arg file] [arg data]]
+
+This command is like [cmd ::fileutil::writeFile], except that the
+previous contents of [arg file] are not replaced, but appended to. The
+command accepts the same options as [cmd ::fileutil::cat]
+
+[call [cmd ::fileutil::insertIntoFile] [opt [arg options]] [arg file] [arg at] [arg data]]
+
+This comment is similar to [cmd ::fileutil::appendToFile], except that
+the new data is not appended at the end, but inserted at a specified
+location within the file. In further contrast this command has to be
+given the path to an existing file. It will not create a missing file,
+but throw an error instead.
+
+[para]
+
+The specified location [arg at] has to be an integer number in the
+range [const 0] ... [lb]file size [arg file][rb]. [const 0] will cause
+insertion of the new data before the first character of the existing
+content, whereas [lb]file size [arg file][rb] causes insertion after
+the last character of the existing content, i.e. appending.
+
+[para]
+
+The command accepts the same options as [cmd ::fileutil::cat].
+
+[call [cmd ::fileutil::removeFromFile] [opt [arg options]] [arg file] [arg at] [arg n]]
+
+This command is the complement to [cmd ::fileutil::insertIntoFile], removing [arg n] characters from the [arg file], starting at location [arg at].
+
+The specified location [arg at] has to be an integer number in the
+range [const 0] ... [lb]file size [arg file][rb] - [arg n]. [const 0]
+will cause the removal of the new data to start with the first
+character of the existing content,
+
+whereas [lb]file size [arg file][rb] - [arg n] causes the removal of
+the tail of the existing content, i.e. the truncation of the file.
+
+[para]
+
+The command accepts the same options as [cmd ::fileutil::cat].
+
+[call [cmd ::fileutil::replaceInFile] [opt [arg options]] [arg file] [arg at] [arg n] [arg data]]
+
+This command is a combination of [cmd ::fileutil::removeFromFile] and
+[cmd ::fileutil::insertIntoFile]. It first removes the part of the
+contents specified by the arguments [arg at] and [arg n], and then
+inserts [arg data] at the given location, effectively replacing the
+removed by content with [arg data].
+
+All constraints imposed on [arg at] and [arg n] by
+[cmd ::fileutil::removeFromFile] and [cmd ::fileutil::insertIntoFile]
+are obeyed.
+
+[para]
+
+The command accepts the same options as [cmd ::fileutil::cat].
+
+[call [cmd ::fileutil::updateInPlace] [opt [arg options]] [arg file] [arg cmd]]
+
+This command can be seen as the generic core functionality of
+[cmd ::fileutil::replaceInFile].
+
+It first reads the contents of the specified [arg file], then runs the
+command prefix [arg cmd] with that data appended to it, and at last
+writes the result of that invokation back as the new contents of the
+file.
+
+[para]
+
+If the executed command throws an error the [arg file] is not changed.
+
+[para]
+
+The command accepts the same options as [cmd ::fileutil::cat].
+
+[call [cmd ::fileutil::fileType] [arg filename]]
+
+An implementation of the UNIX [syscmd file] command, which uses
+various heuristics to guess the type of a file. Returns a list
+specifying as much type information as can be determined about the
+file, from most general (eg, "binary" or "text") to most specific (eg,
+"gif"). For example, the return value for a GIF file would be "binary
+graphic gif". The command will detect the following types of files:
+directory, empty, binary, text, script (with interpreter), executable
+elf, executable dos, executable ne, executable pe, graphic gif, graphic
+jpeg, graphic png, graphic tiff, graphic bitmap, html, xml (with doctype
+if available), message pgp, binary pdf, text ps, text eps, binary
+gravity_wave_data_frame, compressed bzip, compressed gzip, compressed
+zip, compressed tar, audio wave, audio mpeg, and link. It further
+detects doctools, doctoc, and docidx documentation files, and
+tklib diagrams.
+
+[call [cmd ::fileutil::find] [opt "[arg basedir] [opt [arg filtercmd]]"]]
+
+An implementation of the unix command [syscmd find]. Adapted from the
+Tcler's Wiki. Takes at most two arguments, the path to the directory
+to start searching from and a command to use to evaluate interest in
+each file. The path defaults to [file .], i.e. the current
+directory. The command defaults to the empty string, which means that
+all files are of interest. The command takes care [emph not] to
+lose itself in infinite loops upon encountering circular link
+structures. The result of the command is a list containing the paths
+to the interesting files.
+
+[para]
+
+The [arg filtercmd], if specified, is interpreted as a command prefix
+and one argument is added to it, the name of the file or directory
+find is currently looking at. Note that this name is [emph not] fully
+qualified. It has to be joined it with the result of [cmd pwd] to get
+an absolute filename.
+
+[para]
+
+The result of [arg filtercmd] is a boolean value that indicates if the
+current file should be included in the list of interesting files.
+
+[para]
+Example:
+[para]
+[example {
+ # find .tcl files
+ package require fileutil
+ proc is_tcl {name} {return [string match *.tcl $name]}
+ set tcl_files [fileutil::find . is_tcl]
+}]
+
+[call [cmd ::fileutil::findByPattern] [arg basedir] \
+ [opt [option -regexp]|[option -glob]] [opt [option --]] \
+ [arg patterns]]
+
+This command is based upon the [package TclX] command
+
+[cmd recursive_glob], except that it doesn't allow recursion over more
+than one directory at a time. It uses [cmd ::fileutil::find]
+internally and is thus able to and does follow symbolic links,
+something the [package TclX] command does not do. First argument is
+the directory to start the search in, second argument is a list of
+[arg patterns]. The command returns a list of all files reachable
+through [arg basedir] whose names match at least one of the
+patterns. The options before the pattern-list determine the style of
+matching, either regexp or glob. glob-style matching is the default if
+no options are given. Usage of the option [option --] stops option
+processing. This allows the use of a leading '-' in the patterns.
+
+[call [cmd ::fileutil::foreachLine] [arg {var filename cmd}]]
+
+The command reads the file [arg filename] and executes the script
+
+[arg cmd] for every line in the file. During the execution of the
+script the variable [arg var] is set to the contents of the current
+line. The return value of this command is the result of the last
+invocation of the script [arg cmd] or the empty string if the file was
+empty.
+
+[call [cmd ::fileutil::grep] [arg pattern] [opt [arg files]]]
+
+Implementation of [syscmd grep]. Adapted from the Tcler's Wiki. The
+first argument defines the [arg pattern] to search for. This is
+followed by a list of [arg files] to search through. The list is
+optional and [const stdin] will be used if it is missing. The result
+of the procedures is a list containing the matches. Each match is a
+single element of the list and contains filename, number and contents
+of the matching line, separated by a colons.
+
+[call [cmd ::fileutil::install] [opt "[option -m] [arg "mode"]"] [arg source] [arg destination]]
+
+The [cmd install] command is similar in functionality to the [syscmd install]
+command found on many unix systems, or the shell script
+distributed with many source distributions (unix/install-sh in the Tcl
+sources, for example). It copies [arg source], which can be either a
+file or directory to [arg destination], which should be a directory,
+unless [arg source] is also a single file. The [opt -m] option lets
+the user specify a unix-style mode (either octal or symbolic - see
+[cmd {file attributes}].
+
+[call [cmd ::fileutil::stripN] [arg path] [arg n]]
+
+Removes the first [arg n] elements from the specified [arg path] and
+returns the modified path. If [arg n] is greater than the number of
+components in [arg path] an empty string is returned. The number of
+components in a given path may be determined by performing
+[cmd llength] on the list returned by [cmd {file split}].
+
+[call [cmd ::fileutil::stripPwd] [arg path]]
+
+If, and only if the [arg path] is inside of the directory returned by
+[lb][cmd pwd][rb] (or the current working directory itself) it is made
+relative to that directory. In other words, the current working
+directory is stripped from the [arg path]. The possibly modified path
+is returned as the result of the command. If the current working
+directory itself was specified for [arg path] the result is the string
+"[const .]".
+
+[call [cmd ::fileutil::stripPath] [arg prefix] [arg path]]
+
+If, and only of the [arg path] is inside of the directory
+
+[file prefix] (or the prefix directory itself) it is made relative to
+that directory. In other words, the prefix directory is stripped from
+the [arg path]. The possibly modified path is returned as the result
+of the command.
+
+If the prefix directory itself was specified for [arg path] the result
+is the string "[const .]".
+
+[call [cmd ::fileutil::jail] [arg jail] [arg path]]
+
+This command ensures that the [arg path] is not escaping the directory
+[arg jail]. It always returns an absolute path derived from [arg path]
+which is within [arg jail].
+
+[para]
+
+If [arg path] is an absolute path and already within [arg jail] it is
+returned unmodified.
+
+[para]
+
+An absolute path outside of [arg jail] is stripped of its root element
+and then put into the [arg jail] by prefixing it with it. The same
+happens if [arg path] is relative, except that nothing is stripped of
+it. Before adding the [arg jail] prefix the [arg path] is lexically
+normalized to prevent the caller from using [const ..] segments in
+[arg path] to escape the jail.
+
+[call [cmd ::fileutil::touch] [opt [option -a]] [opt [option -c]] [opt [option -m]] [opt "[option -r] [arg ref_file]"] [opt "[option -t] [arg time]"] [arg filename] [opt [arg ...]]]
+
+Implementation of [syscmd touch]. Alter the atime and mtime of the
+specified files. If [option -c], do not create files if they do not
+already exist. If [option -r], use the atime and mtime from
+
+[arg ref_file]. If [option -t], use the integer clock value
+
+[arg time]. It is illegal to specify both [option -r] and
+
+[option -t]. If [option -a], only change the atime. If [option -m],
+only change the mtime.
+
+[para]
+[emph {This command is not available for Tcl versions less than 8.3.}]
+
+[call [cmd ::fileutil::tempdir]]
+
+The command returns the path of a directory where the caller can
+place temporary files, such as [file /tmp] on Unix systems. The
+algorithm we use to find the correct directory is as follows:
+
+[list_begin enumerated]
+
+[enum]
+The directory set by an invokation of [cmd ::fileutil::tempdir] with
+an argument. If this is present it is tried exclusively and none of
+the following item are tried.
+
+[enum]
+The directory named in the TMPDIR environment variable.
+
+[enum]
+The directory named in the TEMP environment variable.
+
+[enum]
+The directory named in the TMP environment variable.
+
+[enum]
+A platform specific location:
+
+[list_begin definitions]
+[def {Windows}]
+
+[file "C:\\TEMP"], [file "C:\\TMP"], [file "\\TEMP"],
+and [file "\\TMP"] are tried in that order.
+
+[def {(classic) Macintosh}]
+
+The TRASH_FOLDER environment variable is used. This is most likely
+not correct.
+
+[def {Unix}]
+
+The directories [file /tmp], [file /var/tmp], and [file /usr/tmp] are
+tried in that order.
+
+[list_end]
+[list_end]
+[para]
+
+The algorithm utilized is mainly that used in the Python standard
+library. The exception is the first item, the ability to have the
+search overridden by a user-specified directory.
+
+[call [cmd ::fileutil::tempdir] [arg path]]
+
+In this mode the command sets the [arg path] as the first and only
+directory to try as a temp. directory. See the previous item for the
+use of the set directory. The command returns the empty string.
+
+[call [cmd ::fileutil::tempdirReset]]
+
+Invoking this command clears the information set by the
+last call of [lb][cmd ::fileutil::tempdir] [arg path][rb].
+See the last item too.
+
+[call [cmd ::fileutil::tempfile] [opt [arg prefix]]]
+
+The command generates a temporary file name suitable for writing to,
+and the associated file. The file name will be unique, and the file
+will be writable and contained in the appropriate system specific temp
+directory. The name of the file will be returned as the result of the
+command.
+
+[para]
+
+The code was taken from [uri http://wiki.tcl.tk/772], attributed to
+Igor Volobouev and anon.
+
+[call [cmd ::fileutil::maketempdir] \
+ [opt "[option -prefix] [arg str]"] \
+ [opt "[option -suffix] [arg str]"] \
+ [opt "[option -dir] [arg str]"]]
+
+The command generates a temporary directory suitable for writing to.
+The directory name will be unique, and the directory will be writable
+and contained in the appropriate system specific temp directory. The
+name of the directory will be returned as the result of the command.
+
+[para] The three options can used to tweak the behaviour of the command:
+
+[list_begin options]
+[opt_def -prefix str] The initial, fixed part of the directory name. Defaults to [const tmp] if not specified.
+[opt_def -suffix str] The fixed tail of the directory. Defaults to the empty string if not specified.
+[opt_def -dir str] The directory to place the new directory into. Defaults to the result of [cmd fileutil::tempdir] if not specified.
+[list_end]
+
+[para]The initial code for this was supplied by [uri mailto:aplicacionamedida@gmail.com {Miguel Martinez Lopez}].
+
+[call [cmd ::fileutil::relative] [arg base] [arg dst]]
+
+This command takes two directory paths, both either absolute or relative
+and computes the path of [arg dst] relative to [arg base]. This relative
+path is returned as the result of the command. As implied in the previous
+sentence, the command is not able to compute this relationship between the
+arguments if one of the paths is absolute and the other relative.
+
+[para]
+
+[emph Note:] The processing done by this command is purely lexical.
+Symbolic links are [emph not] taken into account.
+
+[call [cmd ::fileutil::relativeUrl] [arg base] [arg dst]]
+
+This command takes two file paths, both either absolute or relative
+and computes the path of [arg dst] relative to [arg base], as seen
+from inside of the [arg base]. This is the algorithm how a browser
+resolves a relative link found in the currently shown file.
+
+[para]
+
+The computed relative path is returned as the result of the command.
+As implied in the previous sentence, the command is not able to compute
+this relationship between the arguments if one of the paths is absolute
+and the other relative.
+
+[para]
+
+[emph Note:] The processing done by this command is purely lexical.
+Symbolic links are [emph not] taken into account.
+
+[list_end]
+
+[section {Warnings and Incompatibilities}]
+
+[list_begin definitions]
+
+[def [const 1.14.9]]
+In this version [cmd fileutil::find]'s broken system for handling
+symlinks was replaced with one working correctly and properly
+enumerating all the legal non-cyclic paths under a base directory.
+
+[para] While correct this means that certain pathological directory
+hierarchies with cross-linked sym-links will now take about O(n**2)
+time to enumerate whereas the original broken code managed O(n) due to
+its brokenness.
+
+[para] A concrete example and extreme case is the [file /sys]
+hierarchy under Linux where some hundred devices exist under both
+[file /sys/devices] and [file /sys/class] with the two sub-hierarchies
+linking to the other, generating millions of legal paths to enumerate.
+The structure, reduced to three devices, roughly looks like
+
+[include include/cross-index.inc]
+
+[para] The command [cmd fileutil::find] currently has no way to escape
+this. When having to handle such a pathological hierarchy It is
+recommended to switch to package [package fileutil::traverse] and the
+same-named command it provides, and then use the [option -prefilter]
+option to prevent the traverser from following symbolic links, like so:
+
+[include include/cross-index-trav.inc]
+
+[list_end]
+
+[vset CATEGORY fileutil]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/fileutil/fileutil.tcl b/tcllib/modules/fileutil/fileutil.tcl
new file mode 100644
index 0000000..b72864d
--- /dev/null
+++ b/tcllib/modules/fileutil/fileutil.tcl
@@ -0,0 +1,2295 @@
+# fileutil.tcl --
+#
+# Tcl implementations of standard UNIX utilities.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2002 by Phil Ehrens <phil@slug.org> (fileType)
+# Copyright (c) 2005-2013 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: fileutil.tcl,v 1.78 2010/06/17 04:46:19 andreas_kupries Exp $
+
+package require Tcl 8.2
+package require cmdline
+package provide fileutil 1.15
+
+namespace eval ::fileutil {
+ namespace export \
+ grep find findByPattern cat touch foreachLine \
+ jail stripPwd stripN stripPath tempdir tempfile \
+ install fileType writeFile appendToFile \
+ insertIntoFile removeFromFile replaceInFile \
+ updateInPlace test tempdirReset maketempdir
+}
+
+# ::fileutil::grep --
+#
+# Implementation of grep. Adapted from the Tcler's Wiki.
+#
+# Arguments:
+# pattern pattern to search for.
+# files list of files to search; if NULL, uses stdin.
+#
+# Results:
+# results list of matches
+
+proc ::fileutil::grep {pattern {files {}}} {
+ set result [list]
+ if {[llength $files] == 0} {
+ # read from stdin
+ set lnum 0
+ while {[gets stdin line] >= 0} {
+ incr lnum
+ if {[regexp -- $pattern $line]} {
+ lappend result "${lnum}:${line}"
+ }
+ }
+ } else {
+ foreach filename $files {
+ set file [open $filename r]
+ set lnum 0
+ while {[gets $file line] >= 0} {
+ incr lnum
+ if {[regexp -- $pattern $line]} {
+ lappend result "${filename}:${lnum}:${line}"
+ }
+ }
+ close $file
+ }
+ }
+ return $result
+}
+
+# ::fileutil::find ==
+
+# Below is the core command, which is portable across Tcl versions and
+# platforms. Functionality which is common or platform and/or Tcl
+# version dependent, has been factored out/ encapsulated into separate
+# (small) commands. Only these commands may have multiple variant
+# implementations per the available features of the Tcl core /
+# platform.
+#
+# These commands are
+#
+# FADD - Add path result, performs filtering. Portable!
+# GLOBF - Return files in a directory. Tcl version/platform dependent.
+# GLOBD - Return dirs in a directory. Tcl version/platform dependent.
+# ACCESS - Check directory for accessibility. Tcl version/platform dependent.
+
+proc ::fileutil::find {{basedir .} {filtercmd {}}} {
+ set result {}
+ set filt [string length $filtercmd]
+
+ if {[file isfile $basedir]} {
+ # The base is a file, and therefore only possible result,
+ # modulo filtering.
+
+ FADD $basedir
+
+ } elseif {[file isdirectory $basedir]} {
+ # For a directory as base we do an iterative recursion through
+ # the directory hierarchy starting at the base. We use a queue
+ # (Tcl list) of directories we have to check. We access it by
+ # index, and stop when we have reached beyond the end of the
+ # list. This is faster than removing elements from the be-
+ # ginning of the list, as that entails copying down a possibly
+ # large list of directories, making it O(n*n). The index is
+ # faster, O(n), at the expense of memory. Nothing is deleted
+ # from the list until we have processed all directories in the
+ # hierarchy.
+ #
+ # We scan each directory at least twice. First for files, then
+ # for directories. The scans may internally make several
+ # passes (normal vs hidden files).
+ #
+ # Looped directory structures due to symbolic links are
+ # handled by _fully_ normalizing directory paths and checking
+ # if we encountered the normalized form before. The array
+ # 'known' is our cache where we record the known normalized
+ # paths.
+
+ set pending [list $basedir]
+ set at 0
+ array set parent {}
+ array set norm {}
+ Enter {} $basedir
+
+ while {$at < [llength $pending]} {
+ # Get next directory not yet processed.
+ set current [lindex $pending $at]
+ incr at
+
+ # Is the directory accessible? Continue if not.
+ ACCESS $current
+
+ # Files first, then the sub-directories ...
+
+ foreach f [GLOBF $current] { FADD $f }
+
+ foreach f [GLOBD $current] {
+ # Ignore current and parent directory, this needs
+ # explicit filtering outside of the filter command.
+ if {
+ [string equal [file tail $f] "."] ||
+ [string equal [file tail $f] ".."]
+ } continue
+
+ # Extend result, modulo filtering.
+ FADD $f
+
+ # Detection of symlink loops via a portable path
+ # normalization computing a canonical form of the path
+ # followed by a check if that canonical form was
+ # encountered before. If ok, record directory for
+ # expansion in future iterations.
+
+ Enter $current $f
+ if {[Cycle $f]} continue
+
+ lappend pending $f
+ }
+ }
+ } else {
+ return -code error "$basedir does not exist"
+ }
+
+ return $result
+}
+
+proc ::fileutil::Enter {parent path} {
+ upvar 1 parent _parent norm _norm
+ set _parent($path) $parent
+ set _norm($path) [fullnormalize $path]
+ return
+}
+
+proc ::fileutil::Cycle {path} {
+ upvar 1 parent _parent norm _norm
+ set nform $_norm($path)
+ set paren $_parent($path)
+ while {$paren ne {}} {
+ if {$_norm($paren) eq $nform} { return yes }
+ set paren $_parent($paren)
+ }
+ return no
+}
+
+# Helper command for fileutil::find. Performs the filtering of the
+# result per a filter command for the candidates found by the
+# traversal core, see above. This is portable.
+
+proc ::fileutil::FADD {filename} {
+ upvar 1 result result filt filt filtercmd filtercmd
+ if {!$filt} {
+ lappend result $filename
+ return
+ }
+
+ set here [pwd]
+ cd [file dirname $filename]
+
+ if {[uplevel 2 [linsert $filtercmd end [file tail $filename]]]} {
+ lappend result $filename
+ }
+
+ cd $here
+ return
+}
+
+# The next three helper commands for fileutil::find depend strongly on
+# the version of Tcl, and partially on the platform.
+
+# 1. The -directory and -types switches were added to glob in Tcl
+# 8.3. This means that we have to emulate them for Tcl 8.2.
+#
+# 2. In Tcl 8.3 using -types f will return only true files, but not
+# links to files. This changed in 8.4+ where links to files are
+# returned as well. So for 8.3 we have to handle the links
+# separately (-types l) and also filter on our own.
+# Note that Windows file links are hard links which are reported by
+# -types f, but not -types l, so we can optimize that for the two
+# platforms.
+#
+# Note further that we have to handle broken links on our own. They
+# are not returned by glob yet we want them in the output.
+#
+# 3. In Tcl 8.3 we also have a crashing bug in glob (SIGABRT, "stat on
+# a known file") when trying to perform 'glob -types {hidden f}' on
+# a directory without e'x'ecute permissions. We code around by
+# testing if we can cd into the directory (stat might return enough
+# information too (mode), but possibly also not portable).
+#
+# For Tcl 8.2 and 8.4+ glob simply delivers an empty result
+# (-nocomplain), without crashing. For them this command is defined
+# so that the bytecode compiler removes it from the bytecode.
+#
+# This bug made the ACCESS helper necessary.
+# We code around the problem by testing if we can cd into the
+# directory (stat might return enough information too (mode), but
+# possibly also not portable).
+
+if {[package vsatisfies [package present Tcl] 8.5]} {
+ # Tcl 8.5+.
+ # We have to check readability of "current" on our own, glob
+ # changed to error out instead of returning nothing.
+
+ proc ::fileutil::ACCESS {args} {}
+
+ proc ::fileutil::GLOBF {current} {
+ if {![file readable $current] ||
+ [BadLink $current]} {
+ return {}
+ }
+
+ set res [lsort -unique [concat \
+ [glob -nocomplain -directory $current -types f -- *] \
+ [glob -nocomplain -directory $current -types {hidden f} -- *]]]
+
+ # Look for broken links (They are reported as neither file nor directory).
+ foreach l [lsort -unique [concat \
+ [glob -nocomplain -directory $current -types l -- *] \
+ [glob -nocomplain -directory $current -types {hidden l} -- *]]] {
+ if {[file isfile $l]} continue
+ if {[file isdirectory $l]} continue
+ lappend res $l
+ }
+ return [lsort -unique $res]
+ }
+
+ proc ::fileutil::GLOBD {current} {
+ if {![file readable $current] ||
+ [BadLink $current]} {
+ return {}
+ }
+
+ lsort -unique [concat \
+ [glob -nocomplain -directory $current -types d -- *] \
+ [glob -nocomplain -directory $current -types {hidden d} -- *]]
+ }
+
+ proc ::fileutil::BadLink {current} {
+ if {[file type $current] ne "link"} { return no }
+
+ set dst [file join [file dirname $current] [file readlink $current]]
+
+ if {![file exists $dst] ||
+ ![file readable $dst]} {
+ return yes
+ }
+
+ return no
+ }
+} elseif {[package vsatisfies [package present Tcl] 8.4]} {
+ # Tcl 8.4+.
+ # (Ad 1) We have -directory, and -types,
+ # (Ad 2) Links are returned for -types f/d if they refer to files/dirs.
+ # (Ad 3) No bug to code around
+
+ proc ::fileutil::ACCESS {args} {}
+
+ proc ::fileutil::GLOBF {current} {
+ set res [lsort -unique [concat \
+ [glob -nocomplain -directory $current -types f -- *] \
+ [glob -nocomplain -directory $current -types {hidden f} -- *]]]
+
+ # Look for broken links (They are reported as neither file nor directory).
+ foreach l [lsort -unique [concat \
+ [glob -nocomplain -directory $current -types l -- *] \
+ [glob -nocomplain -directory $current -types {hidden l} -- *]]] {
+ if {[file isfile $l]} continue
+ if {[file isdirectory $l]} continue
+ lappend res $l
+ }
+ return [lsort -unique $res]
+ }
+
+ proc ::fileutil::GLOBD {current} {
+ lsort -unique [concat \
+ [glob -nocomplain -directory $current -types d -- *] \
+ [glob -nocomplain -directory $current -types {hidden d} -- *]]
+ }
+
+} elseif {[package vsatisfies [package present Tcl] 8.3]} {
+ # 8.3.
+ # (Ad 1) We have -directory, and -types,
+ # (Ad 2) Links are NOT returned for -types f/d, collect separately.
+ # No symbolic file links on Windows.
+ # (Ad 3) Bug to code around.
+
+ proc ::fileutil::ACCESS {current} {
+ if {[catch {
+ set h [pwd] ; cd $current ; cd $h
+ }]} {return -code continue}
+ return
+ }
+
+ if {[string equal $::tcl_platform(platform) windows]} {
+ proc ::fileutil::GLOBF {current} {
+ concat \
+ [glob -nocomplain -directory $current -types f -- *] \
+ [glob -nocomplain -directory $current -types {hidden f} -- *]]
+ }
+ } else {
+ proc ::fileutil::GLOBF {current} {
+ set l [concat \
+ [glob -nocomplain -directory $current -types f -- *] \
+ [glob -nocomplain -directory $current -types {hidden f} -- *]]
+
+ foreach x [concat \
+ [glob -nocomplain -directory $current -types l -- *] \
+ [glob -nocomplain -directory $current -types {hidden l} -- *]] {
+ if {[file isdirectory $x]} continue
+ # We have now accepted files, links to files, and broken links.
+ lappend l $x
+ }
+
+ return $l
+ }
+ }
+
+ proc ::fileutil::GLOBD {current} {
+ set l [concat \
+ [glob -nocomplain -directory $current -types d -- *] \
+ [glob -nocomplain -directory $current -types {hidden d} -- *]]
+
+ foreach x [concat \
+ [glob -nocomplain -directory $current -types l -- *] \
+ [glob -nocomplain -directory $current -types {hidden l} -- *]] {
+ if {![file isdirectory $x]} continue
+ lappend l $x
+ }
+
+ return $l
+ }
+} else {
+ # 8.2.
+ # (Ad 1,2,3) We do not have -directory, nor -types. Full emulation required.
+
+ proc ::fileutil::ACCESS {args} {}
+
+ if {[string equal $::tcl_platform(platform) windows]} {
+ # Hidden files cannot be handled by Tcl 8.2 in glob. We have
+ # to punt.
+
+ proc ::fileutil::GLOBF {current} {
+ set current \\[join [split $current {}] \\]
+ set res {}
+ foreach x [glob -nocomplain -- [file join $current *]] {
+ if {[file isdirectory $x]} continue
+ if {[catch {file type $x}]} continue
+ # We have now accepted files, links to files, and
+ # broken links. We may also have accepted a directory
+ # as well, if the current path was inaccessible. This
+ # however will cause 'file type' to throw an error,
+ # hence the second check.
+ lappend res $x
+ }
+ return $res
+ }
+
+ proc ::fileutil::GLOBD {current} {
+ set current \\[join [split $current {}] \\]
+ set res {}
+ foreach x [glob -nocomplain -- [file join $current *]] {
+ if {![file isdirectory $x]} continue
+ lappend res $x
+ }
+ return $res
+ }
+ } else {
+ # Hidden files on Unix are dot-files. We emulate the switch
+ # '-types hidden' by using an explicit pattern.
+
+ proc ::fileutil::GLOBF {current} {
+ set current \\[join [split $current {}] \\]
+ set res {}
+ foreach x [glob -nocomplain -- [file join $current *] [file join $current .*]] {
+ if {[file isdirectory $x]} continue
+ if {[catch {file type $x}]} continue
+ # We have now accepted files, links to files, and
+ # broken links. We may also have accepted a directory
+ # as well, if the current path was inaccessible. This
+ # however will cause 'file type' to throw an error,
+ # hence the second check.
+
+ lappend res $x
+ }
+ return $res
+ }
+
+ proc ::fileutil::GLOBD {current} {
+ set current \\[join [split $current {}] \\]
+ set res {}
+ foreach x [glob -nocomplain -- $current/* [file join $current .*]] {
+ if {![file isdirectory $x]} continue
+ lappend res $x
+ }
+ return $res
+ }
+ }
+}
+
+# ::fileutil::findByPattern --
+#
+# Specialization of find. Finds files based on their names,
+# which have to match the specified patterns. Options are used
+# to specify which type of patterns (regexp-, glob-style) is
+# used.
+#
+# Arguments:
+# basedir Directory to start searching from.
+# args Options (-glob, -regexp, --) followed by a
+# list of patterns to search for.
+#
+# Results:
+# files a list of interesting files.
+
+proc ::fileutil::findByPattern {basedir args} {
+ set pos 0
+ set cmd ::fileutil::FindGlob
+ foreach a $args {
+ incr pos
+ switch -glob -- $a {
+ -- {break}
+ -regexp {set cmd ::fileutil::FindRegexp}
+ -glob {set cmd ::fileutil::FindGlob}
+ -* {return -code error "Unknown option $a"}
+ default {incr pos -1 ; break}
+ }
+ }
+
+ set args [lrange $args $pos end]
+
+ if {[llength $args] != 1} {
+ set pname [lindex [info level 0] 0]
+ return -code error \
+ "wrong#args for \"$pname\", should be\
+ \"$pname basedir ?-regexp|-glob? ?--? patterns\""
+ }
+
+ set patterns [lindex $args 0]
+ return [find $basedir [list $cmd $patterns]]
+}
+
+
+# ::fileutil::FindRegexp --
+#
+# Internal helper. Filter command used by 'findByPattern'
+# to match files based on regular expressions.
+#
+# Arguments:
+# patterns List of regular expressions to match against.
+# filename Name of the file to match against the patterns.
+# Results:
+# interesting A boolean flag. Set to true if the file
+# matches at least one of the patterns.
+
+proc ::fileutil::FindRegexp {patterns filename} {
+ foreach p $patterns {
+ if {[regexp -- $p $filename]} {
+ return 1
+ }
+ }
+ return 0
+}
+
+# ::fileutil::FindGlob --
+#
+# Internal helper. Filter command used by 'findByPattern'
+# to match files based on glob expressions.
+#
+# Arguments:
+# patterns List of glob expressions to match against.
+# filename Name of the file to match against the patterns.
+# Results:
+# interesting A boolean flag. Set to true if the file
+# matches at least one of the patterns.
+
+proc ::fileutil::FindGlob {patterns filename} {
+ foreach p $patterns {
+ if {[string match $p $filename]} {
+ return 1
+ }
+ }
+ return 0
+}
+
+# ::fileutil::stripPwd --
+#
+# If the specified path references is a path in [pwd] (or [pwd] itself) it
+# is made relative to [pwd]. Otherwise it is left unchanged.
+# In the case of [pwd] itself the result is the string '.'.
+#
+# Arguments:
+# path path to modify
+#
+# Results:
+# path The (possibly) modified path.
+
+proc ::fileutil::stripPwd {path} {
+
+ # [file split] is used to generate a canonical form for both
+ # paths, for easy comparison, and also one which is easy to modify
+ # using list commands.
+
+ set pwd [pwd]
+ if {[string equal $pwd $path]} {
+ return "."
+ }
+
+ set pwd [file split $pwd]
+ set npath [file split $path]
+
+ if {[string match ${pwd}* $npath]} {
+ set path [eval [linsert [lrange $npath [llength $pwd] end] 0 file join ]]
+ }
+ return $path
+}
+
+# ::fileutil::stripN --
+#
+# Removes N elements from the beginning of the path.
+#
+# Arguments:
+# path path to modify
+# n number of elements to strip
+#
+# Results:
+# path The modified path
+
+proc ::fileutil::stripN {path n} {
+ set path [file split $path]
+ if {$n >= [llength $path]} {
+ return {}
+ } else {
+ return [eval [linsert [lrange $path $n end] 0 file join]]
+ }
+}
+
+# ::fileutil::stripPath --
+#
+# If the specified path references/is a path in prefix (or prefix itself) it
+# is made relative to prefix. Otherwise it is left unchanged.
+# In the case of it being prefix itself the result is the string '.'.
+#
+# Arguments:
+# prefix prefix to strip from the path.
+# path path to modify
+#
+# Results:
+# path The (possibly) modified path.
+
+if {[string equal $tcl_platform(platform) windows]} {
+
+ # Windows. While paths are stored with letter-case preserved al
+ # comparisons have to be done case-insensitive. For reference see
+ # SF Tcllib Bug 2499641.
+
+ proc ::fileutil::stripPath {prefix path} {
+ # [file split] is used to generate a canonical form for both
+ # paths, for easy comparison, and also one which is easy to modify
+ # using list commands.
+
+ set prefix [file split $prefix]
+ set npath [file split $path]
+
+ if {[string equal -nocase $prefix $npath]} {
+ return "."
+ }
+
+ if {[string match -nocase "${prefix} *" $npath]} {
+ set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]]
+ }
+ return $path
+ }
+} else {
+ proc ::fileutil::stripPath {prefix path} {
+ # [file split] is used to generate a canonical form for both
+ # paths, for easy comparison, and also one which is easy to modify
+ # using list commands.
+
+ set prefix [file split $prefix]
+ set npath [file split $path]
+
+ if {[string equal $prefix $npath]} {
+ return "."
+ }
+
+ if {[string match "${prefix} *" $npath]} {
+ set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]]
+ }
+ return $path
+ }
+}
+
+# ::fileutil::jail --
+#
+# Ensures that the input path 'filename' stays within the the
+# directory 'jail'. In this way it preventsuser-supplied paths
+# from escaping the jail.
+#
+# Arguments:
+# jail The path to the directory the other must
+# not escape from.
+# filename The path to prevent from escaping.
+#
+# Results:
+# path The (possibly) modified path surely within
+# the confines of the jail.
+
+proc fileutil::jail {jail filename} {
+ if {![string equal [file pathtype $filename] "relative"]} {
+ # Although the path to check is absolute (or volumerelative on
+ # windows) we cannot perform a simple prefix check to see if
+ # the path is inside the jail or not. We have to normalize
+ # both path and jail and then we can check. If the path is
+ # outside we make the original path relative and prefix it
+ # with the original jail. We do make the jail pseudo-absolute
+ # by prefixing it with the current working directory for that.
+
+ # Normalized jail. Fully resolved sym links, if any. Our main
+ # complication is that normalize does not resolve symlinks in the
+ # last component of the path given to it, so we add a bogus
+ # component, resolve, and then strip it off again. That is why the
+ # code is so large and long.
+
+ set njail [eval [list file join] [lrange [file split \
+ [Normalize [file join $jail __dummy__]]] 0 end-1]]
+
+ # Normalize filename. Fully resolved sym links, if
+ # any. S.a. for an explanation of the complication.
+
+ set nfile [eval [list file join] [lrange [file split \
+ [Normalize [file join $filename __dummy__]]] 0 end-1]]
+
+ if {[string match ${njail}* $nfile]} {
+ return $filename
+ }
+
+ # Outside the jail, put it inside. ... We normalize the input
+ # path lexically for this, to prevent escapes still lurking in
+ # the original path. (We cannot use the normalized path,
+ # symlinks may have bent it out of shape in unrecognizable ways.
+
+ return [eval [linsert [lrange [file split \
+ [lexnormalize $filename]] 1 end] 0 file join [pwd] $jail]]
+ } else {
+ # The path is relative, consider it as outside
+ # implicitly. Normalize it lexically! to prevent escapes, then
+ # put the jail in front, use PWD to ensure absoluteness.
+
+ return [eval [linsert [file split [lexnormalize $filename]] 0 \
+ file join [pwd] $jail]]
+ }
+}
+
+
+# ::fileutil::test --
+#
+# Simple API to testing various properties of
+# a path (read, write, file/dir, existence)
+#
+# Arguments:
+# path path to test
+# codes names of the properties to test
+# msgvar Name of variable to leave an error
+# message in. Optional.
+# label Label for error message, optional
+#
+# Results:
+# ok boolean flag, set if the path passes
+# all tests.
+
+namespace eval ::fileutil {
+ variable test
+ array set test {
+ read {readable {Read access is denied}}
+ write {writable {Write access is denied}}
+ exec {executable {Is not executable}}
+ exists {exists {Does not exist}}
+ file {isfile {Is not a file}}
+ dir {isdirectory {Is not a directory}}
+ }
+}
+
+proc ::fileutil::test {path codes {msgvar {}} {label {}}} {
+ variable test
+
+ if {[string equal $msgvar ""]} {
+ set msg ""
+ } else {
+ upvar 1 $msgvar msg
+ }
+
+ if {![string equal $label ""]} {append label { }}
+
+ if {![regexp {^(read|write|exec|exists|file|dir)} $codes]} {
+ # Translate single characters into proper codes
+ set codes [string map {
+ r read w write e exists x exec f file d dir
+ } [split $codes {}]]
+ }
+
+ foreach c $codes {
+ foreach {cmd text} $test($c) break
+ if {![file $cmd $path]} {
+ set msg "$label\"$path\": $text"
+ return 0
+ }
+ }
+
+ return 1
+}
+
+# ::fileutil::cat --
+#
+# Tcl implementation of the UNIX "cat" command. Returns the contents
+# of the specified files.
+#
+# Arguments:
+# args names of the files to read, interspersed with options
+# to set encodings, translations, or eofchar.
+#
+# Results:
+# data data read from the file.
+
+proc ::fileutil::cat {args} {
+ # Syntax: (?options? file)+
+ # options = -encoding ENC
+ # | -translation TRA
+ # | -eofchar ECH
+ # | --
+
+ if {![llength $args]} {
+ # Argument processing stopped with arguments missing.
+ return -code error \
+ "wrong#args: should be\
+ [lindex [info level 0] 0] ?-eofchar|-translation|-encoding arg?+ file ..."
+ }
+
+ # We go through the arguments using foreach and keeping track of
+ # the index we are at. We do not shift the arguments out to the
+ # left. That is inherently quadratic, copying everything down.
+
+ set opts {}
+ set mode maybeopt
+ set channels {}
+
+ foreach a $args {
+ if {[string equal $mode optarg]} {
+ lappend opts $a
+ set mode maybeopt
+ continue
+ } elseif {[string equal $mode maybeopt]} {
+ if {[string match -* $a]} {
+ switch -exact -- $a {
+ -encoding -
+ -translation -
+ -eofchar {
+ lappend opts $a
+ set mode optarg
+ continue
+ }
+ -- {
+ set mode file
+ continue
+ }
+ default {
+ return -code error \
+ "Bad option \"$a\",\
+ expected one of\
+ -encoding, -eofchar,\
+ or -translation"
+ }
+ }
+ }
+ # Not an option, but a file. Change mode and fall through.
+ set mode file
+ }
+ # Process file arguments
+
+ if {[string equal $a -]} {
+ # Stdin reference is special.
+
+ # Test that the current options are all ok.
+ # For stdin we have to avoid closing it.
+
+ set old [fconfigure stdin]
+ set fail [catch {
+ SetOptions stdin $opts
+ } msg] ; # {}
+ SetOptions stdin $old
+
+ if {$fail} {
+ return -code error $msg
+ }
+
+ lappend channels [list $a $opts 0]
+ } else {
+ if {![file exists $a]} {
+ return -code error "Cannot read file \"$a\", does not exist"
+ } elseif {![file isfile $a]} {
+ return -code error "Cannot read file \"$a\", is not a file"
+ } elseif {![file readable $a]} {
+ return -code error "Cannot read file \"$a\", read access is denied"
+ }
+
+ # Test that the current options are all ok.
+ set c [open $a r]
+ set fail [catch {
+ SetOptions $c $opts
+ } msg] ; # {}
+ close $c
+ if {$fail} {
+ return -code error $msg
+ }
+
+ lappend channels [list $a $opts [file size $a]]
+ }
+
+ # We may have more options and files coming after.
+ set mode maybeopt
+ }
+
+ if {![string equal $mode maybeopt]} {
+ # Argument processing stopped with arguments missing.
+ return -code error \
+ "wrong#args: should be\
+ [lindex [info level 0] 0] ?-eofchar|-translation|-encoding arg?+ file ..."
+ }
+
+ set data ""
+ foreach c $channels {
+ foreach {fname opts size} $c break
+
+ if {[string equal $fname -]} {
+ set old [fconfigure stdin]
+ SetOptions stdin $opts
+ append data [read stdin]
+ SetOptions stdin $old
+ continue
+ }
+
+ set c [open $fname r]
+ SetOptions $c $opts
+
+ if {$size > 0} {
+ # Used the [file size] command to get the size, which
+ # preallocates memory, rather than trying to grow it as
+ # the read progresses.
+ append data [read $c $size]
+ } else {
+ # if the file has zero bytes it is either empty, or
+ # something where [file size] reports 0 but the file
+ # actually has data (like the files in the /proc
+ # filesystem on Linux).
+ append data [read $c]
+ }
+ close $c
+ }
+
+ return $data
+}
+
+# ::fileutil::writeFile --
+#
+# Write the specified data into the named file,
+# creating it if necessary.
+#
+# Arguments:
+# options... Options and arguments.
+# filename Path to the file to write.
+# data The data to write into the file
+#
+# Results:
+# None.
+
+proc ::fileutil::writeFile {args} {
+ # Syntax: ?options? file data
+ # options = -encoding ENC
+ # | -translation TRA
+ # | -eofchar ECH
+ # | --
+
+ Spec Writable $args opts fname data
+
+ # Now perform the requested operation.
+
+ file mkdir [file dirname $fname]
+ set c [open $fname w]
+ SetOptions $c $opts
+ puts -nonewline $c $data
+ close $c
+ return
+}
+
+# ::fileutil::appendToFile --
+#
+# Append the specified data at the end of the named file,
+# creating it if necessary.
+#
+# Arguments:
+# options... Options and arguments.
+# filename Path to the file to extend.
+# data The data to extend the file with.
+#
+# Results:
+# None.
+
+proc ::fileutil::appendToFile {args} {
+ # Syntax: ?options? file data
+ # options = -encoding ENC
+ # | -translation TRA
+ # | -eofchar ECH
+ # | --
+
+ Spec Writable $args opts fname data
+
+ # Now perform the requested operation.
+
+ file mkdir [file dirname $fname]
+ set c [open $fname a]
+ SetOptions $c $opts
+ set at [tell $c]
+ puts -nonewline $c $data
+ close $c
+ return $at
+}
+
+# ::fileutil::insertIntoFile --
+#
+# Insert the specified data into the named file,
+# creating it if necessary, at the given locaton.
+#
+# Arguments:
+# options... Options and arguments.
+# filename Path to the file to extend.
+# data The data to extend the file with.
+#
+# Results:
+# None.
+
+proc ::fileutil::insertIntoFile {args} {
+
+ # Syntax: ?options? file at data
+ # options = -encoding ENC
+ # | -translation TRA
+ # | -eofchar ECH
+ # | --
+
+ Spec ReadWritable $args opts fname at data
+
+ set max [file size $fname]
+ CheckLocation $at $max insertion
+
+ if {[string length $data] == 0} {
+ # Another degenerate case, inserting nothing.
+ # Leave the file well enough alone.
+ return
+ }
+
+ foreach {c o t} [Open2 $fname $opts] break
+
+ # The degenerate cases of both appending and insertion at the
+ # beginning of the file allow more optimized implementations of
+ # the operation.
+
+ if {$at == 0} {
+ puts -nonewline $o $data
+ fcopy $c $o
+ } elseif {$at == $max} {
+ fcopy $c $o
+ puts -nonewline $o $data
+ } else {
+ fcopy $c $o -size $at
+ puts -nonewline $o $data
+ fcopy $c $o
+ }
+
+ Close2 $fname $t $c $o
+ return
+}
+
+# ::fileutil::removeFromFile --
+#
+# Remove n characters from the named file,
+# starting at the given locaton.
+#
+# Arguments:
+# options... Options and arguments.
+# filename Path to the file to extend.
+# at Location to start the removal from.
+# n Number of characters to remove.
+#
+# Results:
+# None.
+
+proc ::fileutil::removeFromFile {args} {
+
+ # Syntax: ?options? file at n
+ # options = -encoding ENC
+ # | -translation TRA
+ # | -eofchar ECH
+ # | --
+
+ Spec ReadWritable $args opts fname at n
+
+ set max [file size $fname]
+ CheckLocation $at $max removal
+ CheckLength $n $at $max removal
+
+ if {$n == 0} {
+ # Another degenerate case, removing nothing.
+ # Leave the file well enough alone.
+ return
+ }
+
+ foreach {c o t} [Open2 $fname $opts] break
+
+ # The degenerate cases of both removal from the beginning or end
+ # of the file allow more optimized implementations of the
+ # operation.
+
+ if {$at == 0} {
+ seek $c $n current
+ fcopy $c $o
+ } elseif {($at + $n) == $max} {
+ fcopy $c $o -size $at
+ # Nothing further to copy.
+ } else {
+ fcopy $c $o -size $at
+ seek $c $n current
+ fcopy $c $o
+ }
+
+ Close2 $fname $t $c $o
+ return
+}
+
+# ::fileutil::replaceInFile --
+#
+# Remove n characters from the named file,
+# starting at the given locaton, and replace
+# it with the given data.
+#
+# Arguments:
+# options... Options and arguments.
+# filename Path to the file to extend.
+# at Location to start the removal from.
+# n Number of characters to remove.
+# data The replacement data.
+#
+# Results:
+# None.
+
+proc ::fileutil::replaceInFile {args} {
+
+ # Syntax: ?options? file at n data
+ # options = -encoding ENC
+ # | -translation TRA
+ # | -eofchar ECH
+ # | --
+
+ Spec ReadWritable $args opts fname at n data
+
+ set max [file size $fname]
+ CheckLocation $at $max replacement
+ CheckLength $n $at $max replacement
+
+ if {
+ ($n == 0) &&
+ ([string length $data] == 0)
+ } {
+ # Another degenerate case, replacing nothing with
+ # nothing. Leave the file well enough alone.
+ return
+ }
+
+ foreach {c o t} [Open2 $fname $opts] break
+
+ # Check for degenerate cases and handle them separately,
+ # i.e. strip the no-op parts out of the general implementation.
+
+ if {$at == 0} {
+ if {$n == 0} {
+ # Insertion instead of replacement.
+
+ puts -nonewline $o $data
+ fcopy $c $o
+
+ } elseif {[string length $data] == 0} {
+ # Removal instead of replacement.
+
+ seek $c $n current
+ fcopy $c $o
+
+ } else {
+ # General replacement at front.
+
+ seek $c $n current
+ puts -nonewline $o $data
+ fcopy $c $o
+ }
+ } elseif {($at + $n) == $max} {
+ if {$n == 0} {
+ # Appending instead of replacement
+
+ fcopy $c $o
+ puts -nonewline $o $data
+
+ } elseif {[string length $data] == 0} {
+ # Truncating instead of replacement
+
+ fcopy $c $o -size $at
+ # Nothing further to copy.
+
+ } else {
+ # General replacement at end
+
+ fcopy $c $o -size $at
+ puts -nonewline $o $data
+ }
+ } else {
+ if {$n == 0} {
+ # General insertion.
+
+ fcopy $c $o -size $at
+ puts -nonewline $o $data
+ fcopy $c $o
+
+ } elseif {[string length $data] == 0} {
+ # General removal.
+
+ fcopy $c $o -size $at
+ seek $c $n current
+ fcopy $c $o
+
+ } else {
+ # General replacement.
+
+ fcopy $c $o -size $at
+ seek $c $n current
+ puts -nonewline $o $data
+ fcopy $c $o
+ }
+ }
+
+ Close2 $fname $t $c $o
+ return
+}
+
+# ::fileutil::updateInPlace --
+#
+# Run command prefix on the contents of the
+# file and replace them with the result of
+# the command.
+#
+# Arguments:
+# options... Options and arguments.
+# filename Path to the file to extend.
+# cmd Command prefix to run.
+#
+# Results:
+# None.
+
+proc ::fileutil::updateInPlace {args} {
+ # Syntax: ?options? file cmd
+ # options = -encoding ENC
+ # | -translation TRA
+ # | -eofchar ECH
+ # | --
+
+ Spec ReadWritable $args opts fname cmd
+
+ # readFile/cat inlined ...
+
+ set c [open $fname r]
+ SetOptions $c $opts
+ set data [read $c]
+ close $c
+
+ # Transformation. Abort and do not modify the target file if an
+ # error was raised during this step.
+
+ lappend cmd $data
+ set code [catch {uplevel 1 $cmd} res]
+ if {$code} {
+ return -code $code $res
+ }
+
+ # writeFile inlined, with careful preservation of old contents
+ # until we are sure that the write was ok.
+
+ if {[catch {
+ file rename -force $fname ${fname}.bak
+
+ set o [open $fname w]
+ SetOptions $o $opts
+ puts -nonewline $o $res
+ close $o
+
+ file delete -force ${fname}.bak
+ } msg]} {
+ if {[file exists ${fname}.bak]} {
+ catch {
+ file rename -force ${fname}.bak $fname
+ }
+ return -code error $msg
+ }
+ }
+ return
+}
+
+proc ::fileutil::Writable {fname mv} {
+ upvar 1 $mv msg
+ if {[file exists $fname]} {
+ if {![file isfile $fname]} {
+ set msg "Cannot use file \"$fname\", is not a file"
+ return 0
+ } elseif {![file writable $fname]} {
+ set msg "Cannot use file \"$fname\", write access is denied"
+ return 0
+ }
+ }
+ return 1
+}
+
+proc ::fileutil::ReadWritable {fname mv} {
+ upvar 1 $mv msg
+ if {![file exists $fname]} {
+ set msg "Cannot use file \"$fname\", does not exist"
+ return 0
+ } elseif {![file isfile $fname]} {
+ set msg "Cannot use file \"$fname\", is not a file"
+ return 0
+ } elseif {![file writable $fname]} {
+ set msg "Cannot use file \"$fname\", write access is denied"
+ return 0
+ } elseif {![file readable $fname]} {
+ set msg "Cannot use file \"$fname\", read access is denied"
+ return 0
+ }
+ return 1
+}
+
+proc ::fileutil::Spec {check alist ov fv args} {
+ upvar 1 $ov opts $fv fname
+
+ set n [llength $args] ; # Num more args
+ incr n ; # Count path as well
+
+ set opts {}
+ set mode maybeopt
+
+ set at 0
+ foreach a $alist {
+ if {[string equal $mode optarg]} {
+ lappend opts $a
+ set mode maybeopt
+ incr at
+ continue
+ } elseif {[string equal $mode maybeopt]} {
+ if {[string match -* $a]} {
+ switch -exact -- $a {
+ -encoding -
+ -translation -
+ -eofchar {
+ lappend opts $a
+ set mode optarg
+ incr at
+ continue
+ }
+ -- {
+ # Stop processing.
+ incr at
+ break
+ }
+ default {
+ return -code error \
+ "Bad option \"$a\",\
+ expected one of\
+ -encoding, -eofchar,\
+ or -translation"
+ }
+ }
+ }
+ # Not an option, but a file.
+ # Stop processing.
+ break
+ }
+ }
+
+ if {([llength $alist] - $at) != $n} {
+ # Argument processing stopped with arguments missing, or too
+ # many
+ return -code error \
+ "wrong#args: should be\
+ [lindex [info level 1] 0] ?-eofchar|-translation|-encoding arg? file $args"
+ }
+
+ set fname [lindex $alist $at]
+ incr at
+ foreach \
+ var $args \
+ val [lrange $alist $at end] {
+ upvar 1 $var A
+ set A $val
+ }
+
+ # Check given path ...
+
+ if {![eval [linsert $check end $a msg]]} {
+ return -code error $msg
+ }
+
+ return
+}
+
+proc ::fileutil::Open2 {fname opts} {
+ set c [open $fname r]
+ set t [tempfile]
+ set o [open $t w]
+
+ SetOptions $c $opts
+ SetOptions $o $opts
+
+ return [list $c $o $t]
+}
+
+proc ::fileutil::Close2 {f temp in out} {
+ close $in
+ close $out
+
+ file copy -force $f ${f}.bak
+ file rename -force $temp $f
+ file delete -force ${f}.bak
+ return
+}
+
+proc ::fileutil::SetOptions {c opts} {
+ if {![llength $opts]} return
+ eval [linsert $opts 0 fconfigure $c]
+ return
+}
+
+proc ::fileutil::CheckLocation {at max label} {
+ if {![string is integer -strict $at]} {
+ return -code error \
+ "Expected integer but got \"$at\""
+ } elseif {$at < 0} {
+ return -code error \
+ "Bad $label point $at, before start of data"
+ } elseif {$at > $max} {
+ return -code error \
+ "Bad $label point $at, behind end of data"
+ }
+}
+
+proc ::fileutil::CheckLength {n at max label} {
+ if {![string is integer -strict $n]} {
+ return -code error \
+ "Expected integer but got \"$n\""
+ } elseif {$n < 0} {
+ return -code error \
+ "Bad $label size $n"
+ } elseif {($at + $n) > $max} {
+ return -code error \
+ "Bad $label size $n, going behind end of data"
+ }
+}
+
+# ::fileutil::foreachLine --
+#
+# Executes a script for every line in a file.
+#
+# Arguments:
+# var name of the variable to contain the lines
+# filename name of the file to read.
+# cmd The script to execute.
+#
+# Results:
+# None.
+
+proc ::fileutil::foreachLine {var filename cmd} {
+ upvar 1 $var line
+ set fp [open $filename r]
+
+ # -future- Use try/eval from tcllib/control
+ catch {
+ set code 0
+ set result {}
+ while {[gets $fp line] >= 0} {
+ set code [catch {uplevel 1 $cmd} result]
+ if {($code != 0) && ($code != 4)} {break}
+ }
+ }
+ close $fp
+
+ if {($code == 0) || ($code == 3) || ($code == 4)} {
+ return $result
+ }
+ if {$code == 1} {
+ global errorCode errorInfo
+ return \
+ -code $code \
+ -errorcode $errorCode \
+ -errorinfo $errorInfo \
+ $result
+ }
+ return -code $code $result
+}
+
+# ::fileutil::touch --
+#
+# Tcl implementation of the UNIX "touch" command.
+#
+# touch [-a] [-m] [-c] [-r ref_file] [-t time] filename ...
+#
+# Arguments:
+# -a change the access time only, unless -m also specified
+# -m change the modification time only, unless -a also specified
+# -c silently prevent creating a file if it did not previously exist
+# -r ref_file use the ref_file's time instead of the current time
+# -t time use the specified time instead of the current time
+# ("time" is an integer clock value, like [clock seconds])
+# filename ... the files to modify
+#
+# Results
+# None.
+#
+# Errors:
+# Both of "-r" and "-t" cannot be specified.
+
+if {[package vsatisfies [package provide Tcl] 8.3]} {
+ namespace eval ::fileutil {
+ namespace export touch
+ }
+
+ proc ::fileutil::touch {args} {
+ # Don't bother catching errors, just let them propagate up
+
+ set options {
+ {a "set the atime only"}
+ {m "set the mtime only"}
+ {c "do not create non-existant files"}
+ {r.arg "" "use time from ref_file"}
+ {t.arg -1 "use specified time"}
+ }
+ set usage ": [lindex [info level 0] 0]\
+ \[options] filename ...\noptions:"
+ array set params [::cmdline::getoptions args $options $usage]
+
+ # process -a and -m options
+ set set_atime [set set_mtime "true"]
+ if { $params(a) && ! $params(m)} {set set_mtime "false"}
+ if {! $params(a) && $params(m)} {set set_atime "false"}
+
+ # process -r and -t
+ set has_t [expr {$params(t) != -1}]
+ set has_r [expr {[string length $params(r)] > 0}]
+ if {$has_t && $has_r} {
+ return -code error "Cannot specify both -r and -t"
+ } elseif {$has_t} {
+ set atime [set mtime $params(t)]
+ } elseif {$has_r} {
+ file stat $params(r) stat
+ set atime $stat(atime)
+ set mtime $stat(mtime)
+ } else {
+ set atime [set mtime [clock seconds]]
+ }
+
+ # do it
+ foreach filename $args {
+ if {! [file exists $filename]} {
+ if {$params(c)} {continue}
+ close [open $filename w]
+ }
+ if {$set_atime} {file atime $filename $atime}
+ if {$set_mtime} {file mtime $filename $mtime}
+ }
+ return
+ }
+}
+
+# ::fileutil::fileType --
+#
+# Do some simple heuristics to determine file type.
+#
+#
+# Arguments:
+# filename Name of the file to test.
+#
+# Results
+# type Type of the file. May be a list if multiple tests
+# are positive (eg, a file could be both a directory
+# and a link). In general, the list proceeds from most
+# general (eg, binary) to most specific (eg, gif), so
+# the full type for a GIF file would be
+# "binary graphic gif"
+#
+# At present, the following types can be detected:
+#
+# directory
+# empty
+# binary
+# text
+# script <interpreter>
+# executable [elf, dos, ne, pe]
+# binary graphic [gif, jpeg, png, tiff, bitmap, icns]
+# ps, eps, pdf
+# html
+# xml <doctype>
+# message pgp
+# compressed [bzip, gzip, zip, tar]
+# audio [mpeg, wave]
+# gravity_wave_data_frame
+# link
+# doctools, doctoc, and docidx documentation files.
+#
+
+proc ::fileutil::fileType {filename} {
+ ;## existence test
+ if { ! [ file exists $filename ] } {
+ set err "file not found: '$filename'"
+ return -code error $err
+ }
+ ;## directory test
+ if { [ file isdirectory $filename ] } {
+ set type directory
+ if { ! [ catch {file readlink $filename} ] } {
+ lappend type link
+ }
+ return $type
+ }
+ ;## empty file test
+ if { ! [ file size $filename ] } {
+ set type empty
+ if { ! [ catch {file readlink $filename} ] } {
+ lappend type link
+ }
+ return $type
+ }
+ set bin_rx {[\x00-\x08\x0b\x0e-\x1f]}
+
+ if { [ catch {
+ set fid [ open $filename r ]
+ fconfigure $fid -translation binary
+ fconfigure $fid -buffersize 1024
+ fconfigure $fid -buffering full
+ set test [ read $fid 1024 ]
+ ::close $fid
+ } err ] } {
+ catch { ::close $fid }
+ return -code error "::fileutil::fileType: $err"
+ }
+
+ if { [ regexp $bin_rx $test ] } {
+ set type binary
+ set binary 1
+ } else {
+ set type text
+ set binary 0
+ }
+
+ # SF Tcllib bug [795585]. Allowing whitespace between #!
+ # and path of script interpreter
+
+ set metakit 0
+
+ if { [ regexp {^\#\!\s*(\S+)} $test -> terp ] } {
+ lappend type script $terp
+ } elseif {([regexp "\\\[manpage_begin " $test] &&
+ !([regexp -- {--- !doctools ---} $test] || [regexp -- "!tcl\.tk//DSL doctools//EN//" $test])) ||
+ ([regexp -- {--- doctools ---} $test] || [regexp -- "tcl\.tk//DSL doctools//EN//" $test])} {
+ lappend type doctools
+ } elseif {([regexp "\\\[toc_begin " $test] &&
+ !([regexp -- {--- !doctoc ---} $test] || [regexp -- "!tcl\.tk//DSL doctoc//EN//" $test])) ||
+ ([regexp -- {--- doctoc ---} $test] || [regexp -- "tcl\.tk//DSL doctoc//EN//" $test])} {
+ lappend type doctoc
+ } elseif {([regexp "\\\[index_begin " $test] &&
+ !([regexp -- {--- !docidx ---} $test] || [regexp -- "!tcl\.tk//DSL docidx//EN//" $test])) ||
+ ([regexp -- {--- docidx ---} $test] || [regexp -- "tcl\.tk//DSL docidx//EN//" $test])} {
+ lappend type docidx
+ } elseif {[regexp -- "tcl\\.tk//DSL diagram//EN//" $test]} {
+ lappend type tkdiagram
+ } elseif { $binary && [ regexp {^[\x7F]ELF} $test ] } {
+ lappend type executable elf
+ } elseif { $binary && [string match "MZ*" $test] } {
+ if { [scan [string index $test 24] %c] < 64 } {
+ lappend type executable dos
+ } else {
+ binary scan [string range $test 60 61] s next
+ set sig [string range $test $next [expr {$next + 1}]]
+ if { $sig == "NE" || $sig == "PE" } {
+ lappend type executable [string tolower $sig]
+ } else {
+ lappend type executable dos
+ }
+ }
+ } elseif { $binary && [string match "BZh91AY\&SY*" $test] } {
+ lappend type compressed bzip
+ } elseif { $binary && [string match "\x1f\x8b*" $test] } {
+ lappend type compressed gzip
+ } elseif { $binary && [string range $test 257 262] == "ustar\x00" } {
+ lappend type compressed tar
+ } elseif { $binary && [string match "\x50\x4b\x03\x04*" $test] } {
+ lappend type compressed zip
+ } elseif { $binary && [string match "GIF*" $test] } {
+ lappend type graphic gif
+ } elseif { $binary && [string match "icns*" $test] } {
+ lappend type graphic icns bigendian
+ } elseif { $binary && [string match "snci*" $test] } {
+ lappend type graphic icns smallendian
+ } elseif { $binary && [string match "\x89PNG*" $test] } {
+ lappend type graphic png
+ } elseif { $binary && [string match "\xFF\xD8\xFF*" $test] } {
+ binary scan $test x3H2x2a5 marker txt
+ if { $marker == "e0" && $txt == "JFIF\x00" } {
+ lappend type graphic jpeg jfif
+ } elseif { $marker == "e1" && $txt == "Exif\x00" } {
+ lappend type graphic jpeg exif
+ }
+ } elseif { $binary && [string match "MM\x00\**" $test] } {
+ lappend type graphic tiff
+ } elseif { $binary && [string match "BM*" $test] && [string range $test 6 9] == "\x00\x00\x00\x00" } {
+ lappend type graphic bitmap
+ } elseif { ! $binary && [string match -nocase "*\<html\>*" $test] } {
+ lappend type html
+ } elseif {[string match "\%PDF\-*" $test] } {
+ lappend type pdf
+ } elseif { [string match "\%\!PS\-*" $test] } {
+ lappend type ps
+ if { [string match "* EPSF\-*" $test] } {
+ lappend type eps
+ }
+ } elseif { [string match -nocase "*\<\?xml*" $test] } {
+ lappend type xml
+ if { [ regexp -nocase {\<\!DOCTYPE\s+(\S+)} $test -> doctype ] } {
+ lappend type $doctype
+ }
+ } elseif { [string match {*BEGIN PGP MESSAGE*} $test] } {
+ lappend type message pgp
+ } elseif { $binary && [string match {IGWD*} $test] } {
+ lappend type gravity_wave_data_frame
+ } elseif {[string match "JL\x1a\x00*" $test] && ([file size $filename] >= 27)} {
+ lappend type metakit smallendian
+ set metakit 1
+ } elseif {[string match "LJ\x1a\x00*" $test] && ([file size $filename] >= 27)} {
+ lappend type metakit bigendian
+ set metakit 1
+ } elseif { $binary && [string match "RIFF*" $test] && [string range $test 8 11] == "WAVE" } {
+ lappend type audio wave
+ } elseif { $binary && [string match "ID3*" $test] } {
+ lappend type audio mpeg
+ } elseif { $binary && [binary scan $test S tmp] && [expr {$tmp & 0xFFE0}] == 65504 } {
+ lappend type audio mpeg
+ }
+
+ # Additional checks of file contents at the end of the file,
+ # possibly pointing into the middle too (attached metakit,
+ # attached zip).
+
+ ## Metakit File format: http://www.equi4.com/metakit/metakit-ff.html
+ ## Metakit database attached ? ##
+
+ if {!$metakit && ([file size $filename] >= 27)} {
+ # The offsets in the footer are in always bigendian format
+
+ if { [ catch {
+ set fid [ open $filename r ]
+ fconfigure $fid -translation binary
+ fconfigure $fid -buffersize 1024
+ fconfigure $fid -buffering full
+ seek $fid -16 end
+ set test [ read $fid 16 ]
+ ::close $fid
+ } err ] } {
+ catch { ::close $fid }
+ return -code error "::fileutil::fileType: $err"
+ }
+
+ binary scan $test IIII __ hdroffset __ __
+ set hdroffset [expr {[file size $filename] - 16 - $hdroffset}]
+
+ # Further checks iff the offset is actually inside the file.
+
+ if {($hdroffset >= 0) && ($hdroffset < [file size $filename])} {
+ # Seek to the specified location and try to match a metakit header
+ # at this location.
+
+ if { [ catch {
+ set fid [ open $filename r ]
+ fconfigure $fid -translation binary
+ fconfigure $fid -buffersize 1024
+ fconfigure $fid -buffering full
+ seek $fid $hdroffset start
+ set test [ read $fid 16 ]
+ ::close $fid
+ } err ] } {
+ catch { ::close $fid }
+ return -code error "::fileutil::fileType: $err"
+ }
+
+ if {[string match "JL\x1a\x00*" $test]} {
+ lappend type attached metakit smallendian
+ set metakit 1
+ } elseif {[string match "LJ\x1a\x00*" $test]} {
+ lappend type attached metakit bigendian
+ set metakit 1
+ }
+ }
+ }
+
+ ## Zip File Format: http://zziplib.sourceforge.net/zzip-parse.html
+ ## http://www.pkware.com/products/enterprise/white_papers/appnote.html
+
+
+ ;## lastly, is it a link?
+ if { ! [ catch {file readlink $filename} ] } {
+ lappend type link
+ }
+ return $type
+}
+
+# ::fileutil::tempdir --
+#
+# Return the correct directory to use for temporary files.
+# Python attempts this sequence, which seems logical:
+#
+# 1. The directory named by the `TMPDIR' environment variable.
+#
+# 2. The directory named by the `TEMP' environment variable.
+#
+# 3. The directory named by the `TMP' environment variable.
+#
+# 4. A platform-specific location:
+# * On Macintosh, the `Temporary Items' folder.
+#
+# * On Windows, the directories `C:\\TEMP', `C:\\TMP',
+# `\\TEMP', and `\\TMP', in that order.
+#
+# * On all other platforms, the directories `/tmp',
+# `/var/tmp', and `/usr/tmp', in that order.
+#
+# 5. As a last resort, the current working directory.
+#
+# The code here also does
+#
+# 0. The directory set by invoking tempdir with an argument.
+# If this is present it is used exclusively.
+#
+# Arguments:
+# None.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# The directory for temporary files.
+
+proc ::fileutil::tempdir {args} {
+ if {[llength $args] > 1} {
+ return -code error {wrong#args: should be "::fileutil::tempdir ?path?"}
+ } elseif {[llength $args] == 1} {
+ variable tempdir [lindex $args 0]
+ variable tempdirSet 1
+ return
+ }
+ return [Normalize [TempDir]]
+}
+
+proc ::fileutil::tempdirReset {} {
+ variable tempdir {}
+ variable tempdirSet 0
+ return
+}
+
+proc ::fileutil::TempDir {} {
+ global tcl_platform env
+ variable tempdir
+ variable tempdirSet
+
+ set attempdirs [list]
+ set problems {}
+
+ if {$tempdirSet} {
+ lappend attempdirs $tempdir
+ lappend problems {User/Application specified tempdir}
+ } else {
+ foreach tmp {TMPDIR TEMP TMP} {
+ if { [info exists env($tmp)] } {
+ lappend attempdirs $env($tmp)
+ } else {
+ lappend problems "No environment variable $tmp"
+ }
+ }
+
+ switch $tcl_platform(platform) {
+ windows {
+ lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP"
+ }
+ macintosh {
+ lappend attempdirs $env(TRASH_FOLDER) ;# a better place?
+ }
+ default {
+ lappend attempdirs \
+ [file join / tmp] \
+ [file join / var tmp] \
+ [file join / usr tmp]
+ }
+ }
+
+ lappend attempdirs [pwd]
+ }
+
+ foreach tmp $attempdirs {
+ if { [file isdirectory $tmp] && [file writable $tmp] } {
+ return $tmp
+ } elseif { ![file isdirectory $tmp] } {
+ lappend problems "Not a directory: $tmp"
+ } else {
+ lappend problems "Not writable: $tmp"
+ }
+ }
+
+ # Fail if nothing worked.
+ return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]"
+}
+
+namespace eval ::fileutil {
+ variable tempdir {}
+ variable tempdirSet 0
+}
+
+# ::fileutil::maketempdir --
+
+proc ::fileutil::maketempdir {args} {
+ return [Normalize [MakeTempDir $args]]
+}
+
+proc ::fileutil::MakeTempDir {config} {
+ # Setup of default configuration.
+ array set options {}
+ set options(-suffix) ""
+ set options(-prefix) "tmp"
+ set options(-dir) [tempdir]
+
+ # TODO: Check for and reject options not in -suffix, -prefix, -dir
+ # Merge user configuration, overwrite defaults.
+ array set options $config
+
+ # See also "tempfile" below. Could be shareable internal configuration.
+ set chars abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789
+ set nrand_chars 10
+ set maxtries 10
+
+ for {set i 0} {$i < $maxtries} {incr i} {
+ # Build up the candidate name. See also "tempfile".
+ set directory_name $options(-prefix)
+ for {set j 0} {$j < $nrand_chars} {incr j} {
+ append directory_name \
+ [string index $chars [expr {int(rand() * 62)}]]
+ }
+ append directory_name $options(-suffix)
+ set path [file join $options(-dir) $directory_name]
+
+ # Try to create. Try again if already exists, or trouble
+ # with creation and setting of perms.
+ #
+ # Note: The last looks as if it is able to leave partial
+ # directories behind (created, trouble with perms). But
+ # deleting ... Might pull the rug out from somebody else.
+
+ if {[file exists $path]} continue
+ if {[catch {
+ file mkdir $path
+ file attributes $path -permissions 0700
+ }]} continue
+
+ return $path
+ }
+ return -code error "Failed to find an unused temporary directory name"
+}
+
+# ::fileutil::tempfile --
+#
+# generate a temporary file name suitable for writing to
+# the file name will be unique, writable and will be in the
+# appropriate system specific temp directory
+# Code taken from http://mini.net/tcl/772 attributed to
+# Igor Volobouev and anon.
+#
+# Arguments:
+# prefix - a prefix for the filename, p
+# Results:
+# returns a file name
+#
+
+proc ::fileutil::tempfile {{prefix {}}} {
+ return [Normalize [TempFile $prefix]]
+}
+
+proc ::fileutil::TempFile {prefix} {
+ set tmpdir [tempdir]
+
+ set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
+ set nrand_chars 10
+ set maxtries 10
+ set access [list RDWR CREAT EXCL]
+ set permission 0600
+ set channel ""
+ set checked_dir_writable 0
+
+ for {set i 0} {$i < $maxtries} {incr i} {
+ set newname $prefix
+ for {set j 0} {$j < $nrand_chars} {incr j} {
+ append newname [string index $chars \
+ [expr {int(rand()*62)}]]
+ }
+ set newname [file join $tmpdir $newname]
+
+ if {[catch {open $newname $access $permission} channel]} {
+ if {!$checked_dir_writable} {
+ set dirname [file dirname $newname]
+ if {![file writable $dirname]} {
+ return -code error "Directory $dirname is not writable"
+ }
+ set checked_dir_writable 1
+ }
+ } else {
+ # Success
+ close $channel
+ return $newname
+ }
+
+ }
+ if {[string compare $channel ""]} {
+ return -code error "Failed to open a temporary file: $channel"
+ } else {
+ return -code error "Failed to find an unused temporary file name"
+ }
+}
+
+# ::fileutil::install --
+#
+# Tcl version of the 'install' command, which copies files from
+# one places to another and also optionally sets some attributes
+# such as group, owner, and permissions.
+#
+# Arguments:
+# -m Change the file permissions to the specified
+# value. Valid arguments are those accepted by
+# file attributes -permissions
+#
+# Results:
+# None.
+
+# TODO - add options for group/owner manipulation.
+
+proc ::fileutil::install {args} {
+ set options {
+ {m.arg "" "Set permission mode"}
+ }
+ set usage ": [lindex [info level 0] 0]\
+\[options] source destination \noptions:"
+ array set params [::cmdline::getoptions args $options $usage]
+ # Args should now just be the source and destination.
+ if { [llength $args] < 2 } {
+ return -code error $usage
+ }
+ set src [lindex $args 0]
+ set dst [lindex $args 1]
+ file copy -force $src $dst
+ if { $params(m) != "" } {
+ set targets [::fileutil::find $dst]
+ foreach fl $targets {
+ file attributes $fl -permissions $params(m)
+ }
+ }
+}
+
+# ### ### ### ######### ######### #########
+
+proc ::fileutil::lexnormalize {sp} {
+ set spx [file split $sp]
+
+ # Resolution of embedded relative modifiers (., and ..).
+
+ if {
+ ([lsearch -exact $spx . ] < 0) &&
+ ([lsearch -exact $spx ..] < 0)
+ } {
+ # Quick path out if there are no relative modifiers
+ return $sp
+ }
+
+ set absolute [expr {![string equal [file pathtype $sp] relative]}]
+ # A volumerelative path counts as absolute for our purposes.
+
+ set sp $spx
+ set np {}
+ set noskip 1
+
+ while {[llength $sp]} {
+ set ele [lindex $sp 0]
+ set sp [lrange $sp 1 end]
+ set islast [expr {[llength $sp] == 0}]
+
+ if {[string equal $ele ".."]} {
+ if {
+ ($absolute && ([llength $np] > 1)) ||
+ (!$absolute && ([llength $np] >= 1))
+ } {
+ # .. : Remove the previous element added to the
+ # new path, if there actually is enough to remove.
+ set np [lrange $np 0 end-1]
+ }
+ } elseif {[string equal $ele "."]} {
+ # Ignore .'s, they stay at the current location
+ continue
+ } else {
+ # A regular element.
+ lappend np $ele
+ }
+ }
+ if {[llength $np] > 0} {
+ return [eval [linsert $np 0 file join]]
+ # 8.5: return [file join {*}$np]
+ }
+ return {}
+}
+
+# ### ### ### ######### ######### #########
+## Forward compatibility. Some routines require path normalization,
+## something we have supported by the builtin 'file' only since Tcl
+## 8.4. For versions of Tcl before that, to be supported by the
+## module, we implement a normalizer in Tcl itself. Slow, but working.
+
+if {[package vcompare [package provide Tcl] 8.4] < 0} {
+ # Pre 8.4. We do not have 'file normalize'. We create an
+ # approximation for it based on earlier commands.
+
+ # ... Hm. This is lexical normalization. It does not resolve
+ # symlinks in the path to their origin.
+
+ proc ::fileutil::Normalize {sp} {
+ set sp [file split $sp]
+
+ # Conversion of the incoming path to absolute.
+ if {[string equal [file pathtype [lindex $sp 0]] "relative"]} {
+ set sp [file split [eval [list file join [pwd]] $sp]]
+ }
+
+ # Resolution of symlink components, and embedded relative
+ # modifiers (., and ..).
+
+ set np {}
+ set noskip 1
+ while {[llength $sp]} {
+ set ele [lindex $sp 0]
+ set sp [lrange $sp 1 end]
+ set islast [expr {[llength $sp] == 0}]
+
+ if {[string equal $ele ".."]} {
+ if {[llength $np] > 1} {
+ # .. : Remove the previous element added to the
+ # new path, if there actually is enough to remove.
+ set np [lrange $np 0 end-1]
+ }
+ } elseif {[string equal $ele "."]} {
+ # Ignore .'s, they stay at the current location
+ continue
+ } else {
+ # A regular element. If it is not the last component
+ # then check if the combination is a symlink, and if
+ # yes, resolve it.
+
+ lappend np $ele
+
+ if {!$islast && $noskip} {
+ # The flag 'noskip' is technically not required,
+ # just 'file exists'. However if a path P does not
+ # exist, then all longer paths starting with P can
+ # not exist either, and using the flag to store
+ # this knowledge then saves us a number of
+ # unnecessary stat calls. IOW this a performance
+ # optimization.
+
+ set p [eval file join $np]
+ set noskip [file exists $p]
+ if {$noskip} {
+ if {[string equal link [file type $p]]} {
+ set dst [file readlink $p]
+
+ # We always push the destination in front of
+ # the source path (in expanded form). So that
+ # we handle .., .'s, and symlinks inside of
+ # this path as well. An absolute path clears
+ # the result, a relative one just removes the
+ # last, now resolved component.
+
+ set sp [eval [linsert [file split $dst] 0 linsert $sp 0]]
+
+ if {![string equal relative [file pathtype $dst]]} {
+ # Absolute|volrelative destination, clear
+ # result, we have to start over.
+ set np {}
+ } else {
+ # Relative link, just remove the resolved
+ # component again.
+ set np [lrange $np 0 end-1]
+ }
+ }
+ }
+ }
+ }
+ }
+ if {[llength $np] > 0} {
+ return [eval file join $np]
+ }
+ return {}
+ }
+} else {
+ proc ::fileutil::Normalize {sp} {
+ file normalize $sp
+ }
+}
+
+# ::fileutil::relative --
+#
+# Taking two _directory_ paths, a base and a destination, computes the path
+# of the destination relative to the base.
+#
+# Arguments:
+# base The path to make the destination relative to.
+# dst The destination path
+#
+# Results:
+# The path of the destination, relative to the base.
+
+proc ::fileutil::relative {base dst} {
+ # Ensure that the link to directory 'dst' is properly done relative to
+ # the directory 'base'.
+
+ if {![string equal [file pathtype $base] [file pathtype $dst]]} {
+ return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)"
+ }
+
+ set base [lexnormalize [file join [pwd] $base]]
+ set dst [lexnormalize [file join [pwd] $dst]]
+
+ set save $dst
+ set base [file split $base]
+ set dst [file split $dst]
+
+ while {[string equal [lindex $dst 0] [lindex $base 0]]} {
+ set dst [lrange $dst 1 end]
+ set base [lrange $base 1 end]
+ if {![llength $dst]} {break}
+ }
+
+ set dstlen [llength $dst]
+ set baselen [llength $base]
+
+ if {($dstlen == 0) && ($baselen == 0)} {
+ # Cases:
+ # (a) base == dst
+
+ set dst .
+ } else {
+ # Cases:
+ # (b) base is: base/sub = sub
+ # dst is: base = {}
+
+ # (c) base is: base = {}
+ # dst is: base/sub = sub
+
+ while {$baselen > 0} {
+ set dst [linsert $dst 0 ..]
+ incr baselen -1
+ }
+ # 8.5: set dst [file join {*}$dst]
+ set dst [eval [linsert $dst 0 file join]]
+ }
+
+ return $dst
+}
+
+# ::fileutil::relativeUrl --
+#
+# Taking two _file_ paths, a base and a destination, computes the path
+# of the destination relative to the base, from the inside of the base.
+#
+# This is how a browser resolves relative links in a file, hence the
+# url in the command name.
+#
+# Arguments:
+# base The file path to make the destination relative to.
+# dst The destination file path
+#
+# Results:
+# The path of the destination file, relative to the base file.
+
+proc ::fileutil::relativeUrl {base dst} {
+ # Like 'relative', but for links from _inside_ a file to a
+ # different file.
+
+ if {![string equal [file pathtype $base] [file pathtype $dst]]} {
+ return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $base] vs. [file pathtype $dst], ($base vs. $dst)"
+ }
+
+ set base [lexnormalize [file join [pwd] $base]]
+ set dst [lexnormalize [file join [pwd] $dst]]
+
+ set basedir [file dirname $base]
+ set dstdir [file dirname $dst]
+
+ set dstdir [relative $basedir $dstdir]
+
+ # dstdir == '.' on input => dstdir output has trailing './'. Strip
+ # this superfluous segment off.
+
+ if {[string equal $dstdir "."]} {
+ return [file tail $dst]
+ } elseif {[string equal [file tail $dstdir] "."]} {
+ return [file join [file dirname $dstdir] [file tail $dst]]
+ } else {
+ return [file join $dstdir [file tail $dst]]
+ }
+}
+
+# ::fileutil::fullnormalize --
+#
+# Normalizes a path completely. I.e. a symlink in the last
+# element is resolved as well, not only symlinks in the higher
+# elements.
+#
+# Arguments:
+# path The path to normalize
+#
+# Results:
+# The input path with all symlinks resolved.
+
+proc ::fileutil::fullnormalize {path} {
+ # When encountering symlinks in a file copy operation Tcl copies
+ # the link, not the contents of the file it references. There are
+ # situations there this is not acceptable. For these this command
+ # resolves all symbolic links in the path, including in the last
+ # element of the path. A "file copy" using the return value of
+ # this command copies an actual file, it will not encounter
+ # symlinks.
+
+ # BUG / WORKAROUND. Using the / instead of the join seems to work
+ # around a bug in the path handling on windows which can break the
+ # core 'file normalize' for symbolic links. This was exposed by
+ # the find testsuite which could not reproduced outside. I believe
+ # that there is some deep path bug in the core triggered under
+ # special circumstances. Use of / likely forces a refresh through
+ # the string rep and so avoids the problem with the path intrep.
+
+ return [file dirname [Normalize $path/__dummy__]]
+ #return [file dirname [Normalize [file join $path __dummy__]]]
+}
diff --git a/tcllib/modules/fileutil/fileutil.test b/tcllib/modules/fileutil/fileutil.test
new file mode 100644
index 0000000..48f1e01
--- /dev/null
+++ b/tcllib/modules/fileutil/fileutil.test
@@ -0,0 +1,499 @@
+# -*- tcl -*-
+# Tests for the find function.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2001 by ActiveState Tool Corp.
+# Copyright (c) 2005-2013 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: fileutil.test,v 1.56 2009/10/06 20:07:18 andreas_kupries Exp $
+
+# TODO: Bug [8b317b4a63]: Create test cases for this bug. This
+# requires the use of a custom VFS as the native filesystem does not
+# contain the bug we are guarding ourselves against.
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+support {
+ useTcllibFile fumagic/fumagic.testsupport
+ use cmdline/cmdline.tcl cmdline
+}
+testing {
+ useLocal fileutil.tcl fileutil
+}
+
+# -------------------------------------------------------------------------
+
+proc gt_setup {} {
+ global tcl_platform gt gtfa gtfb
+
+ set gt [makeDirectory grepTest]
+ set gtfa [makeFile "zoop" [file join $gt {file [1]}]]
+ set gtfb {}
+
+ if {[string equal $::tcl_platform(platform) windows]} return
+
+ set gtfb [makeFile "zoo\nbart" [file join $gt {file* 2}]]
+ return
+}
+
+proc gt_cleanup {} {
+ removeDirectory grepTest
+
+
+ rename gt_setup {}
+ rename gt_cleanup {}
+ unset ::gt ::gtfa ::gtfb
+ return
+}
+
+# -------------------------------------------------------------------------
+
+gt_setup
+
+test grep-1.1 {normal grep} {macOrUnix} {
+ lsort [fileutil::grep "zoo" [glob [file join $gt *]]]
+} [list "$gtfa:1:zoop" "$gtfb:1:zoo"]
+
+test grep-1.2 {more restrictive grep} {
+ lsort [fileutil::grep "zoo." [glob [file join $gt *]]]
+} [list "$gtfa:1:zoop"]
+
+test grep-1.3 {more restrictive grep} {macOrUnix} {
+ lsort [fileutil::grep "bar" [glob [file join $gt *]]]
+} [list "$gtfb:2:bart"]
+
+gt_cleanup
+
+# -------------------------------------------------------------------------
+
+test foreachline-1.0 {foreachLine} {
+ set path [makeFile "foo\nbar\nbaz\n" {cat [1]}]
+
+ set res ""
+ ::fileutil::foreachLine line $path {
+ append res /$line
+ }
+
+ removeFile {cat [1]}
+ set res
+} {/foo/bar/baz}
+
+# -------------------------------------------------------------------------
+
+proc t_setup {} {
+ global tt
+
+ set tt [makeDirectory touchTest]
+ makeFile "blah" [file join touchTest {file [1]}]
+}
+
+proc t_cleanup {} {
+ removeDirectory touchTest
+ rename t_setup {}
+ rename t_cleanup {}
+ unset ::tt
+ catch { unset ::a1 }
+ catch { unset ::m1}
+ catch { unset ::a2}
+ catch { unset ::m2}
+ catch { unset ::f}
+ catch { unset ::r}
+ return
+}
+
+# -------------------------------------------------------------------------
+
+t_setup
+
+test touch-1.1 {create file} tcl8.3plus {
+ set f [file join $tt here]
+ fileutil::touch $f
+ file exists $f
+} 1
+
+test touch-1.2 {'-c' prevents file creation} tcl8.3plus {
+ set f [file join $tt nothere]
+ fileutil::touch -c $f
+ file exists $f
+} 0
+
+test touch-1.3 {'-c' has no effect on existing files} tcl8.3plus {
+ set f [file join $tt {file [1]}]
+ fileutil::touch -c $f
+ file exists $f
+} 1
+
+test touch-1.4 {test relative times} tcl8.3plus {
+ set f [file join $tt {file [1]}]
+ fileutil::touch $f
+ set a1 [file atime $f]
+ set m1 [file mtime $f]
+ after 1001
+ fileutil::touch $f
+ set a2 [file atime $f]
+ set m2 [file mtime $f]
+ list [expr {$a1 == $m1}] [expr {$a2 == $m2}] [expr {$a1 < $a2}] [expr {$m1 < $m2}]
+} {1 1 1 1}
+
+test touch-1.5 {test relative times using -a} tcl8.3plus {
+ set f [file join $tt {file [1]}]
+ fileutil::touch $f
+ set a1 [file atime $f]
+ set m1 [file mtime $f]
+ after 1001
+ fileutil::touch -a $f
+ set a2 [file atime $f]
+ set m2 [file mtime $f]
+ list [expr {$a1 == $m1}] [expr {$a2 == $m2}] [expr {$a1 < $a2}] [expr {$m1 < $m2}]
+} {1 0 1 0}
+
+test touch-1.6 {test relative times using -m} tcl8.3plus {
+ set f [file join $tt {file [1]}]
+ fileutil::touch $f
+ set a1 [file atime $f]
+ set m1 [file mtime $f]
+ after 1001
+ fileutil::touch -m $f
+ set a2 [file atime $f]
+ set m2 [file mtime $f]
+ list [expr {$a1 == $m1}] [expr {$a2 == $m2}] [expr {$a1 < $a2}] [expr {$m1 < $m2}]
+} {1 0 0 1}
+
+test touch-1.7 {test relative times using -a and -m} tcl8.3plus {
+ set f [file join $tt {file [1]}]
+ fileutil::touch $f
+ set a1 [file atime $f]
+ set m1 [file mtime $f]
+ after 1001
+ fileutil::touch -a -m $f
+ set a2 [file atime $f]
+ set m2 [file mtime $f]
+ list [expr {$a1 == $m1}] [expr {$a2 == $m2}] [expr {$a1 < $a2}] [expr {$m1 < $m2}]
+} {1 1 1 1}
+
+test touch-1.8 {test -t} tcl8.3plus {
+ set f [file join $tt {file [1]}]
+ fileutil::touch $f
+ after 1001
+ fileutil::touch -t 42 $f
+ set a1 [file atime $f]
+ set m1 [file mtime $f]
+ list [expr {$a1 == 42}] [expr {$m1 == 42}]
+} {1 1}
+
+test touch-1.9 {test -t with -a} tcl8.3plus {
+ set f [file join $tt {file [1]}]
+ fileutil::touch $f
+ after 1001
+ fileutil::touch -t 42 -a $f
+ set a1 [file atime $f]
+ set m1 [file mtime $f]
+ list [expr {$a1 == 42}] [expr {$m1 == 42}]
+} [list 1 0]
+
+test touch-1.10 {test -t with -m} tcl8.3plus {
+ set f [file join $tt {file [1]}]
+ fileutil::touch $f
+ after 1001
+ fileutil::touch -t 42 -m $f
+ set a1 [file atime $f]
+ set m1 [file mtime $f]
+ list [expr {$a1 == 42}] [expr {$m1 == 42}]
+} [list 0 1]
+
+test touch-1.11 {test -t with -a and -m} tcl8.3plus {
+ set f [file join $tt {file [1]}]
+ fileutil::touch $f
+ after 1001
+ fileutil::touch -t 42 -a -m $f
+ set a1 [file atime $f]
+ set m1 [file mtime $f]
+ list [expr {$a1 == 42}] [expr {$m1 == 42}]
+} {1 1}
+
+test touch-1.12 {test -r} tcl8.3plus {
+ set r [info script]
+ set f [file join $tt {file [1]}]
+ fileutil::touch $f
+ after 1001
+ fileutil::touch -r $r $f
+ set a1 [file atime $f]
+ set m1 [file mtime $f]
+ list [expr {$a1 == [file atime $r]}] [expr {$m1 == [file mtime $r]}]
+} {1 1}
+
+test touch-1.13 {test -r with -a} tcl8.3plus {
+ set r [info script]
+ set f [file join $tt {file [1]}]
+ fileutil::touch $f
+ after 1001
+ fileutil::touch -r $r -a $f
+ set a1 [file atime $f]
+ set m1 [file mtime $f]
+ list [expr {$a1 == [file atime $r]}] [expr {$m1 == [file mtime $r]}]
+} {1 0}
+
+test touch-1.14 {test -r with -m} tcl8.3plus {
+ set r [info script]
+ set f [file join $tt {file [1]}]
+ fileutil::touch $f
+ after 1001
+ fileutil::touch -r $r -m $f
+ set a1 [file atime $f]
+ set m1 [file mtime $f]
+ list [expr {$a1 == [file atime $r]}] [expr {$m1 == [file mtime $r]}]
+} {0 1}
+
+test touch-1.15 {test -r with -a and -m} tcl8.3plus {
+ set r [info script]
+ set f [file join $tt {file [1]}]
+ fileutil::touch $f
+ after 1001
+ fileutil::touch -r $r -m -a $f
+ set a1 [file atime $f]
+ set m1 [file mtime $f]
+ list [expr {$a1 == [file atime $r]}] [expr {$m1 == [file mtime $r]}]
+} {1 1}
+
+t_cleanup
+
+# ----------------------------------------------------------------
+
+proc i_setup {} {
+ global tcl_platform
+ makeDirectory installDst
+ makeDirectory installSrc
+
+ makeDirectory [file join installSrc subdir]
+ makeFile "blah" [file join installSrc {file [1]}]
+
+ # Make a second subdirectory to install, unix-only
+ if {$tcl_platform(platform) != "unix" } return
+
+ makeDirectory [file join installSrc subdir2]
+ makeFile "blah" [file join installSrc subdir subfile1]
+ makeFile "blah" [file join installSrc subdir subfile2]
+ makeFile "blah" [file join installSrc subdir subfile3]
+
+ foreach fl {1 2 3} {
+ set fn [file join installSrc subdir2 subfile$fl]
+ makeFile "blah" $fn
+
+ # Give it some "bad" permissions.
+ file attributes $fn -permissions 0600
+ }
+ return
+}
+
+proc i_cleanup {} {
+ removeDirectory installDst
+ removeDirectory installSrc
+
+ rename i_setup {}
+ rename i_cleanup {}
+ return
+}
+
+# ----------------------------------------------------------------
+
+i_setup
+
+test install-1.1 {install a file} {
+ fileutil::install [file join installSrc {file [1]}] installDst
+ file exists [file join installDst {file [1]}]
+} {1}
+
+makeDirectory installDst
+
+test install-2.1 {install a directory} {tcl8.4plus} {
+ list [catch {
+ fileutil::install [file join installSrc subdir] installDst
+ set result [lsort [glob -tails -directory [file join installDst subdir] [file join . / *]]]
+ file delete -force installDst
+ set result
+ } err] $err
+} {0 {subfile1 subfile2 subfile3}}
+
+makeDirectory installDst
+
+test install-2.2 {install a directory} {tcl8.3plus} {
+ list [catch {
+ fileutil::install [file join installSrc subdir] installDst
+ set result [lsort [glob -directory [file join installDst subdir] [file join . / *]]]
+ file delete -force installDst
+ set result
+ } err] $err
+} {0 {installDst/subdir/subfile1 installDst/subdir/subfile2 installDst/subdir/subfile3}}
+
+makeDirectory installDst
+
+test install-3.1 {install a directory, set permissions} {unix tcl8.3plus} {
+ set res {}
+ fileutil::install -m go+rw [file join installSrc subdir2] installDst
+ foreach fl [glob [file join installDst subdir2 *]] {
+ append res [file attributes $fl -permissions]
+ }
+ set res
+} {006660066600666}
+
+i_cleanup
+
+# -------------------------------------------------------------------------
+
+proc tmp_setup {} {
+ global xpath res
+
+ # Set up an exclusive directory to search. This cannot be unset,
+ # hence the location of these tests after the regular
+ # tempdir/tempfile tests.
+
+ removeDirectory x
+ set xpath [makeDirectory x]
+ set res {}
+ removeDirectory x
+ return
+}
+
+proc tmp_cleanup {} {
+ rename tmp_setup {}
+ rename tmp_cleanup {}
+ removeDirectory x
+ unset ::xpath
+ unset ::res
+ return
+}
+
+# -------------------------------------------------------------------------
+
+tmp_setup
+
+test tempdir-1.1 {return the correct directorary for temporary files} {unix} {
+ set ::env(TMPDIR) [pwd] ;# Most high-priority source, and existing directory!
+ set res [::fileutil::tempdir]
+ unset ::env(TMPDIR)
+ set res
+} [pwd]
+
+test tempdir-1.2 {return the correct directorary for temporary files} {unix} {
+ catch {unset ::env(TMPDIR)}
+ catch {unset ::env(TEMPDIR)}
+ catch {unset ::env(TMP)}
+ catch {unset ::env(TEMP)}
+ ::fileutil::tempdir
+} {/tmp}
+
+test tempfile-1.1 {generate temporary file name and file} {
+ set filename [::fileutil::tempfile]
+ set res [file exists $filename]
+ file delete $filename
+ unset filename
+ set res
+} {1}
+
+test tempfile-1.2 {generate writable temporary file name} {
+ set filename [::fileutil::tempfile]
+ set res [file writable $filename]
+ file delete $filename
+ unset filename
+ set res
+} {1}
+
+test tempfile-1.3 {generate 100 unique temporary filenames} {
+ set filenames [list]
+ for {set i 0} {$i<100} {incr i} {
+ lappend filenames [::fileutil::tempfile]
+ }
+ foreach f $filenames {
+ file delete $f
+ }
+ set i
+} {100}
+
+test tempdir-1.3 {tempdir, user-specified, bad} {
+ catch {::fileutil::tempdir x y} msg
+ set msg
+} {wrong#args: should be "::fileutil::tempdir ?path?"}
+
+test tempdir-1.4 {tempdir, user-specified, bad} {
+ ::fileutil::tempdir [makeDirectory x]
+ removeDirectory x
+
+ catch {::fileutil::tempdir} msg
+ removeDirectory x
+
+ lindex [split $msg \n] 0 ; # First line only.
+} {Unable to determine a proper directory for temporary files}
+
+test tempdir-1.5 {tempdir, user-specified, ok} {
+ ::fileutil::tempdir [makeDirectory x]
+
+ set res [::fileutil::tempdir]
+ removeDirectory x
+ set res
+} $xpath
+
+test tempfile-1.4 {temp file in user specified directory} {
+ ::fileutil::tempdir [makeDirectory x]
+
+ set filename [::fileutil::tempfile TEST]
+ file delete $filename
+ ::fileutil::tempdirReset
+
+ removeDirectory x
+ string match $xpath/TEST* $filename
+} 1
+
+# -------------------------------------------------------------------------
+
+test maketempdir-1.1 {generate temporary directory} {
+ set filename [::fileutil::maketempdir]
+ set res [file exists $filename]
+ file delete $filename
+ unset filename
+ set res
+} {1}
+
+test maketempdir-1.2 {generate writable temporary directory} {
+ set filename [::fileutil::maketempdir]
+ set res [file writable $filename]
+ file delete $filename
+ unset filename
+ set res
+} {1}
+
+test maketempdir-1.3 {generate 100 unique temporary directories} {
+ set filenames [list]
+ for {set i 0} {$i<100} {incr i} {
+ lappend filenames [::fileutil::maketempdir]
+ }
+ foreach f $filenames {
+ file delete $f
+ }
+ set i
+} {100}
+
+test maketempdir-1.4 {temp directory in user specified directory} {
+ set filename [::fileutil::maketempdir -dir $xpath -prefix TEST]
+ file delete $filename
+ string match $xpath/TEST* $filename
+} 1
+
+# -------------------------------------------------------------------------
+
+tmp_cleanup
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/fileutil/find.setup b/tcllib/modules/fileutil/find.setup
new file mode 100644
index 0000000..e64f45f
--- /dev/null
+++ b/tcllib/modules/fileutil/find.setup
@@ -0,0 +1,432 @@
+# -*- tcl -*-
+# Support code for the tests of the find command (and incremental find).
+#
+# Copyright (c) 2007-2015 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: find.setup,v 1.3 2012/08/29 20:42:19 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+# Build a sample tree to search
+# Structure
+#
+# dir
+# +--{find 1}
+# +--{find 2}
+# | +--{file* 2} (This file is unix only)
+# +--{file 1}
+#
+# dir2
+# +-- dotfiles
+# +-- .foo
+# +-- foo
+
+proc f_setup {} {
+ makeDirectory {find 1}
+ makeDirectory [file join {find 1} {find 2}]
+ makeFile "" [file join {find 1} {file [1]}]
+
+ if {[string equal $::tcl_platform(platform) windows]} return
+
+ makeFile "test" [file join {find 1} {find 2} {file* 2}]
+ return
+}
+
+proc f_cleanup {} {
+ # Remove sym link first. Not doing this causes the file delete for
+ # the directory to fail (on Windows, Unix would have been fine).
+ catch {removeFile [file join {find 1} {find 2} {file 3}]}
+ removeDirectory {find 1}
+ return
+}
+
+# Extend the previous sample tree with circular symbolic
+# links. Unix-only.
+#
+# dir
+# +--{find 1}
+# +--{find 2} <----------+
+# | +--{file* 2} |
+# | +--{file 3} --> ../{find 2} -+
+# +--{file [1]}
+
+proc f_setupcircle {} {
+ f_setup
+
+ set fthree [file join {find 1} {find 2} {file 3}]
+ set path [makeFile "" $fthree]
+ removeFile $fthree
+
+ # Added use of 'file link' for Tcl 8.4+, on windows, to have a
+ # modicum of x-platform testing regarding the handling of symbolic
+ # links.
+
+ set target [file join .. {find 2}]
+
+ if {
+ [string equal $::tcl_platform(platform) windows] &&
+ [package vsatisfies [package require Tcl] 8.4]
+ } {
+ if {[string equal $::tcl_platform(platform) windows]} {
+ # Windows doesn't like the .. in the target, it needs an
+ # absolute path.
+
+ # NOTE/BUG Even so the 'fullnormalize' in the traverser
+ # returns bogus results for the link, whereas use of file
+ # normalize and fullnormalize in a simple tclsh,
+ # i.e. outside of the testing is ok.
+
+ # It seems if the 'file join' in fullnormalize is replaced
+ # by a plain / then the results are ok again => The
+ # handling of paths on Windows by the Tcl core is bogus in
+ # some way which breaks the core 'normalize'.
+
+ set here [pwd]
+ cd [file dirname [tempPath $fthree]]
+ file link [file tail $fthree] [file normalize $target]
+ cd $here
+ } else {
+ file link [tempPath $fthree] $target
+ }
+ return
+ }
+
+ exec ln -s $target [tempPath $fthree]
+ return
+}
+
+# Change previous sample tree so that its circular symbolic
+# link points to the base directory. Unix-only.
+#
+# dir
+# +--{find 1} <----------+
+# +--{find 2} |
+# | +--{file* 2} |
+# | +--{file 3} --> ../../find 1 +
+# +--{file [1]}
+
+proc f_setupcircle2 {} {
+ f_setup
+
+ set fthree [file join {find 1} {find 2} {file 3}]
+ set path [makeFile "" $fthree]
+ removeFile $fthree
+
+ # Added use of 'file link' for Tcl 8.4+, on windows, to have a
+ # modicum of x-platform testing regarding the handling of symbolic
+ # links.
+
+ set target [file join .. .. {find 1}]
+
+ if {
+ [string equal $::tcl_platform(platform) windows] &&
+ [package vsatisfies [package require Tcl] 8.4]
+ } {
+ if {[string equal $::tcl_platform(platform) windows]} {
+ # Windows doesn't like the .. in the target, it needs an
+ # absolute path.
+
+ # NOTE/BUG Even so the 'fullnormalize' in the traverser
+ # returns bogus results for the link, whereas use of file
+ # normalize and fullnormalize in a simple tclsh,
+ # i.e. outside of the testing is ok.
+
+ # It seems if the 'file join' in fullnormalize is replaced
+ # by a plain / then the results are ok again => The
+ # handling of paths on Windows by the Tcl core is bogus in
+ # some way which breaks the core 'normalize'.
+
+ set here [pwd]
+ cd [file dirname [tempPath $fthree]]
+ file link [file tail $fthree] [file normalize $target]
+ cd $here
+ } else {
+ file link [tempPath $fthree] $target
+ }
+ return
+ }
+
+ exec ln -s $target [tempPath $fthree]
+ return
+}
+
+# Extend the regular sample tree with a broken symbolic link. Unix-only.
+#
+# dir
+# +--{find 1}
+# +--{find 2}
+# | +--{file* 2}
+# | +--{file 3} --> BROKEN
+# +--{file [1]}
+
+
+proc f_setupbroken {} {
+ f_setup
+
+ set fthree [file join {find 1} {find 2} {file 3}]
+ set path [makeFile "" $fthree]
+ removeFile $fthree
+
+ # Added use of 'file link' for Tcl 8.4+, on windows, to have a
+ # modicum of x-platform testing regarding the handling of symbolic
+ # links.
+
+ set target BROKEN
+
+ if {
+ [string equal $::tcl_platform(platform) windows] &&
+ [package vsatisfies [package require Tcl] 8.4]
+ } {
+ makeFile {} [file dirname $fthree]/BROKEN
+
+ if {[string equal $::tcl_platform(platform) windows]} {
+ # Windows doesn't like the .. in the target, it needs an
+ # absolute path.
+
+ # NOTE/BUG Even so the 'fullnormalize' in the traverser
+ # returns bogus results for the link, whereas use of file
+ # normalize and fullnormalize in a simple tclsh,
+ # i.e. outside of the testing is ok.
+
+ # It seems if the 'file join' in fullnormalize is replaced
+ # by a plain / then the results are ok again => The
+ # handling of paths on Windows by the Tcl core is bogus in
+ # some way which breaks the core 'normalize'.
+
+ set here [pwd]
+ cd [file dirname [tempPath $fthree]]
+ file link [file tail $fthree] [file normalize $target]
+ cd $here
+ } else {
+ file link [tempPath $fthree] $target
+ }
+ removeFile [file dirname $fthree]/BROKEN
+ return
+ }
+
+ exec ln -s $target [tempPath $fthree]
+ return
+}
+
+proc f_setupdot {} {
+ makeDirectory dotfiles
+ makeFile "" [file join dotfiles foo]
+ makeFile "" [file join dotfiles .foo]
+ return
+}
+
+
+
+# Complex directory tree with DAG-links and circular links. We want to
+# break the latter, but not the former. I.e. DAG-links allow us to
+# find a file by multiple paths, and we wish to see these all.
+#
+# Paths Links Seen Broken Why
+# dir/a | a
+# dir/b | a/c
+# dir/a/c | a/c/g == a
+# dir/a/d | a/c/h
+# dir/a/c/g --> .. | a/c/h/e == c
+# dir/a/c/h --> ../../b | a/c/h/f
+# dir/a/c/i | a/c/i
+# dir/b/e --> ../a/c | a/d
+# dir/b/f | b
+# | b/e
+# | b/e/g
+# | b/e/g/c
+# | b/e/g/c/g == b/e/g
+# | b/e/g/c/h == b
+# | b/e/g/d
+# | b/e/h == b
+# | b/e/i
+# | b/f
+
+proc pathmap {args} {
+ set res {}
+ foreach p $args {
+ lappend res [tempPath $p]
+ }
+ return $res
+}
+
+proc f_setupcircle3 {} {
+
+ makeDirectory z/a
+ makeDirectory z/a/c
+ makeDirectory z/b
+ makeFile "" z/a/d
+ makeFile "" z/a/c/i
+ makeFile "" z/b/f
+
+ f_link z/a/c/g ../../a
+ f_link z/a/c/h ../../b
+ f_link z/b/e ../a/c
+ return
+}
+
+proc f_cleanup3 {} {
+ # Remove sym links first. Not doing this causes the file delete for
+ # the directory to fail (on Windows, Unix would have been fine).
+ catch { removeFile z/a/c/g }
+ catch { removeFile z/a/c/h }
+ catch { removeFile z/b/e }
+ removeDirectory z
+ return
+}
+
+proc f_link {src target} {
+ # Added use of 'file link' for Tcl 8.4+, on windows, to have a
+ # modicum of x-platform testing regarding the handling of symbolic
+ # links.
+
+ if {
+ [string equal $::tcl_platform(platform) windows] &&
+ [package vsatisfies [package require Tcl] 8.4]
+ } {
+ if {[string equal $::tcl_platform(platform) windows]} {
+ # Windows doesn't like the .. in the target, it needs an
+ # absolute path.
+
+ # NOTE/BUG Even so the 'fullnormalize' in the traverser
+ # returns bogus results for the link, whereas use of file
+ # normalize and fullnormalize in a simple tclsh,
+ # i.e. outside of the testing is ok.
+
+ # It seems if the 'file join' in fullnormalize is replaced
+ # by a plain / then the results are ok again => The
+ # handling of paths on Windows by the Tcl core is bogus in
+ # some way which breaks the core 'normalize'.
+
+ set here [pwd]
+ cd [file dirname [tempPath $src]]
+ file link [file tail $src] [file normalize $target]
+ cd $here
+ } else {
+ file link [tempPath $src] $target
+ }
+ return
+ }
+
+ exec ln -s $target [tempPath $src]
+ return
+}
+
+
+proc f_cleanupdot {} {
+ removeDirectory dotfiles
+ return
+}
+
+proc f_setupnostat {} {
+ # Finding inaccessible directories. Unix only, as I do not know
+ # how to make the directory inaccessible on Windows, and then
+ # reaccessible again.
+
+ makeDirectory find3
+ makeDirectory find3/find4
+ makeFile {} find3/find4/file5
+
+ if {[string equal $::tcl_platform(platform) windows]} return
+ exec chmod -x [tempPath find3/find4]
+ return
+}
+
+proc f_cleanupnostat {} {
+ if {![string equal $::tcl_platform(platform) windows]} {
+ exec chmod +x [tempPath find3/find4]
+ }
+ removeDirectory find3
+ return
+}
+
+proc f_setupnoread {} {
+ # Finding unreadable directories.
+
+ makeDirectory find3
+ makeDirectory find3/find4
+ makeFile {} find3/find4/file5
+
+ if {[string equal $::tcl_platform(platform) windows]} {
+ file attributes -readonly 1 [tempPath find3/find4]
+ } else {
+ exec chmod -r [tempPath find3/find4]
+ }
+ return
+}
+
+proc f_cleanupnoread {} {
+ if {[string equal $::tcl_platform(platform) windows]} {
+ file attributes -readonly 0 [tempPath find3/find4]
+ } else {
+ exec chmod +r [tempPath find3/find4]
+ }
+ removeDirectory find3
+ return
+}
+
+
+proc f_setup_crossindex {} {
+ makeDirectory s
+ makeDirectory s/c
+ makeDirectory s/c/t
+
+ makeDirectory s/d
+ makeDirectory s/d/t0
+ makeDirectory s/d/t1
+ makeDirectory s/d/t2
+
+ makeFile "" s/d/t0/b
+ makeFile "" s/d/t1/b
+ makeFile "" s/d/t2/b
+
+ f_link s/c/t/t0 ../../d/t0
+ f_link s/c/t/t1 ../../d/t1
+ f_link s/c/t/t2 ../../d/t2
+
+ f_link s/d/t0/s ../../c/t
+ f_link s/d/t1/s ../../c/t
+ f_link s/d/t2/s ../../c/t
+ return
+}
+
+proc f_cleanup_crossindex {} {
+ removeFile s/d/t0/b
+ removeFile s/d/t1/b
+ removeFile s/d/t2/b
+ removeDirectory s
+ return
+}
+
+proc f_cleanall {} {
+ rename f_link {}
+ rename f_setup {}
+ rename f_cleanup {}
+ rename f_cleanup3 {}
+ rename f_setupcircle {}
+ rename f_setupcircle2 {}
+ rename f_setupcircle3 {}
+ rename f_setupdot {}
+ rename f_cleanupdot {}
+ rename f_setupnostat {}
+ rename f_cleanupnostat {}
+ rename f_setupnoread {}
+ rename f_cleanupnoread {}
+ rename f_setup_crossindex {}
+ rename f_cleanup_crossindex {}
+ rename f_cleanall {}
+ rename fileIsBiggerThan {}
+ catch {unset ::res}
+ return
+}
+
+# -------------------------------------------------------------------------
+
+proc fileIsBiggerThan {s f} {
+ expr {
+ ![file isdirectory $f] &&
+ ([file size $f] > $s)
+ }
+}
+
+# -------------------------------------------------------------------------
diff --git a/tcllib/modules/fileutil/find.test b/tcllib/modules/fileutil/find.test
new file mode 100644
index 0000000..e35b48f
--- /dev/null
+++ b/tcllib/modules/fileutil/find.test
@@ -0,0 +1,367 @@
+# -*- tcl -*-
+# Tests for the find function.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2001 by ActiveState Tool Corp.
+# Copyright (c) 2005-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: find.test,v 1.7 2007/10/24 19:28:36 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+support {
+ useLocalFile find.setup
+}
+testing {
+ useLocal fileutil.tcl fileutil
+}
+
+# -------------------------------------------------------------------------
+
+test find-1.1 {standard recursive find} {macOrUnix} {
+ f_setup
+ set res [lsort [fileutil::find [tempPath {find 1}]]]
+ f_cleanup
+ set res
+} [list [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}] \
+ [tempPath {find 1/find 2/file* 2}]]
+
+test find-1.2 {standard recursive find} {win} {
+ f_setup
+ set res [lsort [fileutil::find [tempPath {find 1}]]]
+ f_cleanup
+ set res
+} [list [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}]]
+
+test find-1.3 {find directories} {
+ f_setup
+ set res [fileutil::find [tempPath {find 1}] {file isdirectory}]
+ f_cleanup
+ set res
+} [list [tempPath {find 1/find 2}]]
+
+test find-1.4 {find files bigger than a given size} {macOrUnix} {
+ f_setup
+ set res [fileutil::find [tempPath {find 1}] {fileIsBiggerThan 1}]
+ f_cleanup
+ set res
+} [list [tempPath {find 1/find 2/file* 2}]]
+
+# Find has to skip '{file 3}', in the sense that the path should be in
+# the output, but it must not be expanded further. Two tests, one for
+# all versions of Tcl (8.2+), but only unix, and one for windows,
+# restricted to Tcl 8.4+.
+
+test find-1.5.0 {handling of circular links} {unix} {
+ f_setupcircle
+ set res [lsort [fileutil::find [tempPath {find 1}]]]
+ f_cleanup
+ set res
+} [list [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}] \
+ [tempPath {find 1/find 2/file 3}] \
+ [tempPath {find 1/find 2/file* 2}]]
+
+test find-1.5.1 {handling of circular links} {win tcl8.4plus} {
+ f_setupcircle
+ set res [lsort [fileutil::find [tempPath {find 1}]]]
+ f_cleanup
+ set res
+} [list [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}] \
+ [tempPath {find 1/find 2/file 3}]]
+
+test find-1.6 {find file} {
+ f_setup
+ set res [::fileutil::find [tempPath {find 1/file [1]}]]
+ f_cleanup
+ set res
+} [list [tempPath {find 1/file [1]}]]
+
+test find-1.7 {find file with filter} {
+ f_setup
+ set res [::fileutil::find [tempPath {find 1/file [1]}] {file isfile}]
+ f_cleanup
+ set res
+} [list [tempPath {find 1/file [1]}]]
+
+test find-1.8 {find file with filter - negative} {
+ f_setup
+ set res [::fileutil::find [tempPath {find 1/file [1]}] {file isdirectory}]
+ f_cleanup
+ set res
+} {}
+
+# Behaviour of find with regard to dot-files.
+
+test find-1.9 {find file dot-files} {
+ f_setupdot
+ set res [lsort [::fileutil::find [tempPath dotfiles]]]
+ f_cleanupdot
+ set res
+} [list [tempPath dotfiles/.foo] \
+ [tempPath dotfiles/foo]]
+
+
+# Find has to skip '{file 3}', in the sense that the path should be in
+# the output, but it cannot be expanded further, being a broken
+# link. Two tests, one for all versions of Tcl (8.2+), but only unix,
+# and one for windows, restricted to Tcl 8.4+.
+
+test find-1.10.0 {handling of broken links} {unix} {
+ f_setupbroken
+ set res [lsort [fileutil::find [tempPath {find 1}]]]
+ f_cleanup
+ set res
+} [list [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}] \
+ [tempPath {find 1/find 2/file 3}] \
+ [tempPath {find 1/find 2/file* 2}]]
+
+test find-1.10.1 {handling of broken links} {win tcl8.4plus} {
+ f_setupbroken
+ set res [lsort [fileutil::find [tempPath {find 1}]]]
+ f_cleanup
+ set res
+} [list [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}] \
+ [tempPath {find 1/find 2/file 3}]]
+
+
+test find-1.11.0 {find result, circular links, unix} -setup {
+ f_setupcircle3
+} -constraints unix -body {
+ join [lsort [fileutil::find [tempPath z]]] \n
+} -cleanup {
+ f_cleanup3
+} -result [join [pathmap \
+ z/a z/a/c z/a/c/g z/a/c/h z/a/c/h/e z/a/c/h/f \
+ z/a/c/i z/a/d z/b z/b/e z/b/e/g z/b/e/g/c z/b/e/g/d \
+ z/b/e/h z/b/e/i z/b/f] \n]
+
+test find-1.11.1 {find result, circular links, windows, 8.4+} -setup {
+ f_setupcircle3
+} -constraints {win tcl8.4plus} -body {
+ join [lsort [fileutil::find [tempPath z]]] \n
+} -cleanup {
+ f_cleanup3
+} -result [join [pathmap \
+ z/a z/a/c z/a/c/g z/a/c/h z/a/c/h/e z/a/c/h/f \
+ z/a/c/i z/a/d z/b z/b/e z/b/e/g z/b/e/g/c z/b/e/g/d \
+ z/b/e/h z/b/e/i z/b/f] \n]
+
+# -------------------------------------------------------------------------
+
+test find-1.12.0 {Traverse pathological circularity, unix} -setup {
+ f_setup_crossindex
+} -constraints unix -body {
+ join [lsort [fileutil::find [tempPath s]]] \n
+} -cleanup {
+ f_cleanup_crossindex
+} -result [join [pathmap \
+ s/c \
+ s/c/t \
+ s/c/t/t0 \
+ s/c/t/t0/b \
+ s/c/t/t0/s \
+ s/c/t/t1 \
+ s/c/t/t1/b \
+ s/c/t/t1/s \
+ s/c/t/t2 \
+ s/c/t/t2/b \
+ s/c/t/t2/s \
+ s/d \
+ s/d/t0 \
+ s/d/t0/b \
+ s/d/t0/s \
+ s/d/t0/s/t0 \
+ s/d/t0/s/t1 \
+ s/d/t0/s/t1/b \
+ s/d/t0/s/t1/s \
+ s/d/t0/s/t2 \
+ s/d/t0/s/t2/b \
+ s/d/t0/s/t2/s \
+ s/d/t1 \
+ s/d/t1/b \
+ s/d/t1/s \
+ s/d/t1/s/t0 \
+ s/d/t1/s/t0/b \
+ s/d/t1/s/t0/s \
+ s/d/t1/s/t1 \
+ s/d/t1/s/t2 \
+ s/d/t1/s/t2/b \
+ s/d/t1/s/t2/s \
+ s/d/t2 \
+ s/d/t2/b \
+ s/d/t2/s \
+ s/d/t2/s/t0 \
+ s/d/t2/s/t0/b \
+ s/d/t2/s/t0/s \
+ s/d/t2/s/t1 \
+ s/d/t2/s/t1/b \
+ s/d/t2/s/t1/s \
+ s/d/t2/s/t2 \
+ ] \n]
+
+test find-1.12.1 {Traverse pathological circularity, windows, 8.4+} -setup {
+ f_setup_crossindex
+} -constraints {win tcl8.4plus} -body {
+ join [lsort [fileutil::find [tempPath s]]] \n
+} -cleanup {
+ f_cleanup_crossindex
+} -result [join [pathmap \
+ s/c \
+ s/c/t \
+ s/c/t/t0 \
+ s/c/t/t0/b \
+ s/c/t/t0/s \
+ s/c/t/t1 \
+ s/c/t/t1/b \
+ s/c/t/t1/s \
+ s/c/t/t2 \
+ s/c/t/t2/b \
+ s/c/t/t2/s \
+ s/d \
+ s/d/t0 \
+ s/d/t0/b \
+ s/d/t0/s \
+ s/d/t0/s/t0 \
+ s/d/t0/s/t1 \
+ s/d/t0/s/t1/b \
+ s/d/t0/s/t1/s \
+ s/d/t0/s/t2 \
+ s/d/t0/s/t2/b \
+ s/d/t0/s/t2/s \
+ s/d/t1 \
+ s/d/t1/b \
+ s/d/t1/s \
+ s/d/t1/s/t0 \
+ s/d/t1/s/t0/b \
+ s/d/t1/s/t0/s \
+ s/d/t1/s/t1 \
+ s/d/t1/s/t2 \
+ s/d/t1/s/t2/b \
+ s/d/t1/s/t2/s \
+ s/d/t2 \
+ s/d/t2/b \
+ s/d/t2/s \
+ s/d/t2/s/t0 \
+ s/d/t2/s/t0/b \
+ s/d/t2/s/t0/s \
+ s/d/t2/s/t1 \
+ s/d/t2/s/t1/b \
+ s/d/t2/s/t1/s \
+ s/d/t2/s/t2 \
+ ] \n]
+
+# -------------------------------------------------------------------------
+
+test find-2.0 {find by pattern} {
+ list [catch {
+ ::fileutil::findByPattern [tempPath {}] -glob {fil*} foo
+ } err] $err
+} {1 {wrong#args for "::fileutil::findByPattern", should be "::fileutil::findByPattern basedir ?-regexp|-glob? ?--? patterns"}}
+
+test find-2.1 {find by pattern} {
+ list [catch {
+ ::fileutil::findByPattern [tempPath {}] -glob
+ } err] $err
+} {1 {wrong#args for "::fileutil::findByPattern", should be "::fileutil::findByPattern basedir ?-regexp|-glob? ?--? patterns"}}
+
+test find-2.2 {find by pattern} {macOrUnix} {
+ f_setupcircle
+ set res [lsort [::fileutil::findByPattern [tempPath {find 1}] -glob {fil*}]]
+ f_cleanup
+ set res
+} [list [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2/file 3}] \
+ [tempPath {find 1/find 2/file* 2}]]
+
+test find-2.3 {find by pattern} {win} {
+ f_setup
+ set res [lsort [::fileutil::findByPattern [tempPath {find 1}] -glob {fil*}]]
+ f_cleanup
+ set res
+} [list [tempPath {find 1/file [1]}]]
+
+test find-2.4 {find by pattern} {
+ f_setup
+ set res [lsort [::fileutil::findByPattern [tempPath {find 1}] -regexp {.*\\[1\\]$}]]
+ f_cleanup
+ set res
+} [list [tempPath {find 1/file [1]}]]
+
+# -------------------------------------------------------------------------
+
+test find-3.0 {inaccessible directory} {unix notRoot} {
+ f_setupnostat
+ set res [lsort [fileutil::find [tempPath find3]]]
+ f_cleanupnostat
+ set res
+} [list [tempPath find3/find4]]
+
+test find-3.1 {inaccessible directory} {unix notRoot} {
+ f_setupnostat
+ set res [lsort [fileutil::find [tempPath find3/find4]]]
+ f_cleanupnostat
+ set res
+} {}
+
+# -------------------------------------------------------------------------
+
+test find-sf-3147481-0 {unreadable directory} {notRoot} {
+ f_setupnoread
+ set res [lsort [fileutil::find [tempPath find3]]]
+ f_cleanupnoread
+ set res
+} [list [tempPath find3/find4]]
+
+test find-sf-3147481-1 {unreadable directory} {notRoot} {
+ f_setupnoread
+ set res [lsort [fileutil::find [tempPath find3/find4]]]
+ f_cleanupnoread
+ set res
+} {}
+
+# -------------------------------------------------------------------------
+
+proc rec {f} {
+ # Documented filter API:
+ # f = unqualified filename,
+ # pwd = directory the file is in.
+ global res
+ lappend res [list [pwd] $f]
+ return 1
+}
+
+test find-4.0 {find file with filter, filter API} {
+ f_setup
+ set res {}
+ ::fileutil::find [tempPath {find 1}] rec
+ f_cleanup
+ lsort $res
+} [list \
+ [list [tempPath {find 1/find 2}] {file* 2}] \
+ [list [tempPath {find 1}] {file [1]}] \
+ [list [tempPath {find 1}] {find 2}] \
+ ]
+# pwd fname
+
+# -------------------------------------------------------------------------
+
+f_cleanall
+testsuiteCleanup
+return
diff --git a/tcllib/modules/fileutil/include/cross-index-trav.inc b/tcllib/modules/fileutil/include/cross-index-trav.inc
new file mode 100644
index 0000000..a51b823
--- /dev/null
+++ b/tcllib/modules/fileutil/include/cross-index-trav.inc
@@ -0,0 +1,16 @@
+[example {
+ package require fileutil::traverse
+
+ proc NoLinks {fileName} {
+ if {[string equal [file type $fileName] link]} {
+ return 0
+ }
+ return 1
+ }
+
+ fileutil::traverse T /sys/devices -prefilter NoLinks
+ T foreach p {
+ puts $p
+ }
+ T destroy
+}]
diff --git a/tcllib/modules/fileutil/include/cross-index.inc b/tcllib/modules/fileutil/include/cross-index.inc
new file mode 100644
index 0000000..5abce12
--- /dev/null
+++ b/tcllib/modules/fileutil/include/cross-index.inc
@@ -0,0 +1,12 @@
+[example {
+ /sys/class/tty/tty0 --> ../../dev/tty0
+ /sys/class/tty/tty1 --> ../../dev/tty1
+ /sys/class/tty/tty2 --> ../../dev/tty1
+
+ /sys/dev/tty0/bus
+ /sys/dev/tty0/subsystem --> ../../class/tty
+ /sys/dev/tty1/bus
+ /sys/dev/tty1/subsystem --> ../../class/tty
+ /sys/dev/tty2/bus
+ /sys/dev/tty2/subsystem --> ../../class/tty
+}]
diff --git a/tcllib/modules/fileutil/inplace.test b/tcllib/modules/fileutil/inplace.test
new file mode 100644
index 0000000..b30a593
--- /dev/null
+++ b/tcllib/modules/fileutil/inplace.test
@@ -0,0 +1,1129 @@
+# -*- tcl -*-
+# Tests for the find function.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2001 by ActiveState Tool Corp.
+# Copyright (c) 2005-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: inplace.test,v 1.3 2009/10/06 20:07:18 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal fileutil.tcl fileutil
+}
+
+# -------------------------------------------------------------------------
+
+test cat-1.1 {cat} {
+ set path [makeFile "foo\nbar\nbaz\n" {cat [1]}]
+
+ set data [fileutil::cat $path]
+
+ removeFile {cat [1]}
+ set data
+} "foo\nbar\nbaz\n"
+
+test cat-1.2 {cat multiple files} {macOrUnix} {
+ set pathA [makeFile "foo\nbar\nbaz\n" {cat [1]}]
+ set pathB [makeFile "bebop" {cat* 2}]
+
+ set data [fileutil::cat $pathA $pathB]
+
+ removeFile {cat [1]}
+ removeFile {cat* 2}
+ set data
+} "foo\nbar\nbaz\nbebop\n"
+
+
+test cat-1.3.0 {cat, option processing} {
+ set path [makeFile "foo\r\nbar\r\nbaz\r\n" {cat [1]}]
+
+ set data [fileutil::cat -translation binary $path]
+
+ removeFile {cat [1]}
+ set data
+} "foo\r\nbar\r\nbaz\r\n"
+
+test cat-1.3.1 {cat, option processing} {
+ set path [makeFile "foo\r\nbar\r\nbaz\r\n" {cat [1]}]
+
+ set data [fileutil::cat $path]
+
+ removeFile {cat [1]}
+ set data
+} "foo\nbar\nbaz\n"
+
+test cat-1.4 {cat multiple files} {macOrUnix} {
+ set pathA [makeFile "foo\r\nbar\r\nbaz\r\n" {cat [1]}]
+ set pathB [makeFile "bebop\r\nsnoof" {cat* 2}]
+
+ set data [fileutil::cat $pathA -translation binary $pathB]
+
+ removeFile {cat [1]}
+ removeFile {cat* 2}
+ set data
+} "foo\nbar\nbaz\nbebop\r\nsnoof\n"
+
+test cat-1.5.0 {cat, bad arguments} {
+ catch {fileutil::cat} msg
+ set msg
+} {wrong#args: should be fileutil::cat ?-eofchar|-translation|-encoding arg?+ file ...}
+
+test cat-1.5.1 {cat, bad arguments} {
+ catch {fileutil::cat -translation} msg
+ set msg
+} {wrong#args: should be fileutil::cat ?-eofchar|-translation|-encoding arg?+ file ...}
+
+test cat-1.5.2 {cat, bad arguments} {
+ catch {fileutil::cat -bogus foo} msg
+ set msg
+} {Bad option "-bogus", expected one of -encoding, -eofchar, or -translation}
+
+set xpath [makeFile {} {cat [2]}]
+removeFile {cat [2]}
+
+test cat-1.5.3 {cat, bad arguments, unreadable file} {unixOnly notRoot} {
+ set path [makeFile {} {cat [2]}]
+ file attributes $path -permissions 0000
+
+ catch {fileutil::cat $path} msg
+
+ file attributes $path -permissions 0600
+ removeFile {cat [2]}
+ set msg
+} "Cannot read file \"$xpath\", read access is denied"
+
+test cat-1.5.4 {cat, bad arguments, non-existing file} {unixOnly} {
+ set path [makeFile {} {cat [2]}]
+ removeFile {cat [2]}
+
+ catch {fileutil::cat $path} msg
+
+ set msg
+} "Cannot read file \"$xpath\", does not exist"
+
+test cat-1.5.5 {cat, bad arguments, directory} {unixOnly} {
+ set path [makeDirectory {cat [2]}]
+
+ catch {fileutil::cat $path} msg
+
+ removeDirectory {cat [2]}
+ set msg
+} "Cannot read file \"$xpath\", is not a file"
+
+
+test writefile-1.0 {writeFile, unwriteable file} {unixOnly notRoot} {
+ set path [makeFile {} unwritable]
+ file attributes $path -permissions 0000
+
+ catch {fileutil::writeFile $path {}} msg
+
+ file attributes $path -permissions 0600
+ removeFile unwritable
+
+ string map [list $path @] $msg
+} {Cannot use file "@", write access is denied}
+
+test writefile-1.1 {writeFile, not a file} {unixOnly} {
+ set path [makeDirectory notafile]
+
+ catch {fileutil::writeFile $path {}} msg
+
+ removeDirectory notafile
+ string map [list $path @] $msg
+} {Cannot use file "@", is not a file}
+
+test writefile-1.2 {writeFile, wrong#args} {
+ catch {fileutil::writeFile irrelevant} msg
+ set msg
+} {wrong#args: should be fileutil::writeFile ?-eofchar|-translation|-encoding arg? file data}
+
+test writefile-1.3 {writeFile, wrong#args} {
+ catch {fileutil::writeFile} msg
+ set msg
+} {wrong#args: should be fileutil::writeFile ?-eofchar|-translation|-encoding arg? file data}
+
+test writefile-1.4 {writeFile, wrong#args} {
+ catch {fileutil::writeFile a b c} msg
+ set msg
+} {wrong#args: should be fileutil::writeFile ?-eofchar|-translation|-encoding arg? file data}
+
+test writefile-1.5 {writeFile, bad option} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::writeFile -bogus $path {}} msg
+
+ removeFile dummy
+ set msg
+} {Bad option "-bogus", expected one of -encoding, -eofchar, or -translation}
+
+
+test writefile-2.0 {writeFile, create file} {
+ set path [makeFile {} out]
+ removeFile out
+
+ set res {}
+ lappend res [file exists $path]
+
+ fileutil::writeFile $path dummy
+
+ lappend res [file exists $path]
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {0 1 dummy}
+
+test writefile-2.1 {writeFile, replace file} {
+ set path [makeFile {} out]
+
+ set res {}
+ lappend res [file exists $path]
+ lappend res [fileutil::cat $path]
+
+ fileutil::writeFile $path dummy
+
+ lappend res [file exists $path]
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {1 {
+} 1 dummy}
+
+test writefile-2.2 {writeFile, translation 1} {
+ set path [makeFile {} out]
+
+ fileutil::writeFile -translation binary $path "dummy\nfoo"
+ set res [fileutil::cat -translation binary $path]
+
+ removeFile out
+ set res
+} "dummy\nfoo"
+
+test writefile-2.3 {writeFile, translation 2} {
+ set path [makeFile {} out]
+
+ fileutil::writeFile -translation crlf $path "dummy\nfoo"
+ set res [fileutil::cat -translation binary $path]
+
+ removeFile out
+ set res
+} "dummy\r\nfoo"
+
+test appendtofile-1.0 {appendToFile, unwriteable file} {unixOnly notRoot} {
+ set path [makeFile {} unwritable]
+ file attributes $path -permissions 0000
+
+ catch {fileutil::appendToFile $path {}} msg
+
+ file attributes $path -permissions 0600
+ removeFile unwritable
+
+ string map [list $path @] $msg
+} {Cannot use file "@", write access is denied}
+
+test appendtofile-1.1 {appendToFile, not a file} {unixOnly} {
+ set path [makeDirectory notafile]
+
+ catch {fileutil::appendToFile $path {}} msg
+
+ removeDirectory notafile
+ string map [list $path @] $msg
+} {Cannot use file "@", is not a file}
+
+test appendtofile-1.2 {appendToFile, wrong#args} {
+ catch {fileutil::appendToFile irrelevant} msg
+ set msg
+} {wrong#args: should be fileutil::appendToFile ?-eofchar|-translation|-encoding arg? file data}
+
+test appendtofile-1.3 {appendToFile, wrong#args} {
+ catch {fileutil::appendToFile} msg
+ set msg
+} {wrong#args: should be fileutil::appendToFile ?-eofchar|-translation|-encoding arg? file data}
+
+test appendtofile-1.4 {appendToFile, wrong#args} {
+ catch {fileutil::appendToFile a b c} msg
+ set msg
+} {wrong#args: should be fileutil::appendToFile ?-eofchar|-translation|-encoding arg? file data}
+
+test appendtofile-1.5 {appendToFile, bad option} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::appendToFile -bogus $path {}} msg
+
+ removeFile dummy
+ set msg
+} {Bad option "-bogus", expected one of -encoding, -eofchar, or -translation}
+
+
+test appendtofile-2.0 {appendToFile, create file} {
+ set path [makeFile {} out]
+ removeFile out
+
+ set res {}
+ lappend res [file exists $path]
+
+ fileutil::appendToFile $path dummy
+
+ lappend res [file exists $path]
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {0 1 dummy}
+
+test appendtofile-2.1 {appendToFile, true append} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn|
+
+ set res {}
+ lappend res [file exists $path]
+ lappend res [fileutil::cat $path]
+
+ fileutil::appendToFile $path dummy
+
+ lappend res [file exists $path]
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {1 aragorn| 1 aragorn|dummy}
+
+test appendtofile-2.2 {appendToFile, translation 1} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path {}
+
+ fileutil::appendToFile -translation binary $path "dummy\nfoo"
+ set res [fileutil::cat -translation binary $path]
+
+ removeFile out
+ set res
+} "dummy\nfoo"
+
+test appendtofile-2.3 {appendToFile, translation 2} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path {}
+
+ fileutil::appendToFile -translation crlf $path "dummy\nfoo"
+ set res [fileutil::cat -translation binary $path]
+
+ removeFile out
+ set res
+} "dummy\r\nfoo"
+
+
+test insertintofile-1.0 {insertIntoFile, unwriteable file} {unixOnly notRoot} {
+ set path [makeFile {} unwritable]
+ file attributes $path -permissions 0000
+
+ catch {fileutil::insertIntoFile $path 0 {}} msg
+
+ file attributes $path -permissions 0600
+ removeFile unwritable
+
+ string map [list $path @] $msg
+} {Cannot use file "@", write access is denied}
+
+test insertintofile-1.1 {insertIntoFile, not a file} {unixOnly} {
+ set path [makeDirectory notafile]
+
+ catch {fileutil::insertIntoFile $path 0 {}} msg
+
+ removeDirectory notafile
+ string map [list $path @] $msg
+} {Cannot use file "@", is not a file}
+
+test insertintofile-1.2 {insertIntoFile, missing file} {
+ set path [makeFile {} missing]
+ removeFile missing
+
+ catch {fileutil::insertIntoFile $path 0 {}} msg
+
+ string map [list $path @] $msg
+} {Cannot use file "@", does not exist}
+
+test insertintofile-1.3 {insertIntoFile, wrong#args} {
+ catch {fileutil::insertIntoFile irrelevant} msg
+ set msg
+} {wrong#args: should be fileutil::insertIntoFile ?-eofchar|-translation|-encoding arg? file at data}
+
+test insertintofile-1.4 {insertIntoFile, wrong#args} {
+ catch {fileutil::insertIntoFile} msg
+ set msg
+} {wrong#args: should be fileutil::insertIntoFile ?-eofchar|-translation|-encoding arg? file at data}
+
+test insertintofile-1.5 {insertIntoFile, wrong#args} {
+ catch {fileutil::insertIntoFile a b c d} msg
+ set msg
+} {wrong#args: should be fileutil::insertIntoFile ?-eofchar|-translation|-encoding arg? file at data}
+
+test insertintofile-1.6 {insertIntoFile, bad option} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::insertIntoFile -bogus $path {}} msg
+
+ removeFile dummy
+ set msg
+} {Bad option "-bogus", expected one of -encoding, -eofchar, or -translation}
+
+test insertintofile-1.7 {insertIntoFile, non-integer insertion point} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::insertIntoFile $path foo {}} msg
+
+ removeFile dummy
+ set msg
+} {Expected integer but got "foo"}
+
+test insertintofile-1.8 {insertIntoFile, negative insertion point} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::insertIntoFile $path -1 {}} msg
+
+ removeFile dummy
+ set msg
+} {Bad insertion point -1, before start of data}
+
+test insertintofile-1.9 {insertIntoFile, insertion point beyond end-of-file} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::insertIntoFile $path 4 {}} msg
+
+ removeFile dummy
+ set msg
+} {Bad insertion point 4, behind end of data}
+
+# Needed for 1.10
+set path [makeFile {} dummy]
+set beyond [file size $path]
+incr beyond
+removeFile dummy
+
+test insertintofile-1.10 {insertIntoFile, insertion point beyond end-of-file} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::insertIntoFile $path $beyond {}} msg
+
+ removeFile dummy
+ set msg
+} "Bad insertion point $beyond, behind end of data"
+
+
+test insertintofile-2.0 {insertIntoFile, insert at front} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::insertIntoFile $path 0 dummy|
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn dummy|aragorn}
+
+test insertintofile-2.1 {insertIntoFile, insert degenerated to append} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::insertIntoFile $path \
+ [file size $path] dummy|
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn aragorndummy|}
+
+test insertintofile-2.2 {insertIntoFile, insert in the middle} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::insertIntoFile $path 3 dummy|
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn aradummy|gorn}
+
+test insertintofile-2.3 {insertIntoFile, insert nothing} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::insertIntoFile $path 3 {}
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn aragorn}
+
+test insertintofile-2.4 {insertIntoFile, translation 1} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path {}
+
+ fileutil::insertIntoFile -translation binary $path 0 "dummy\nfoo"
+ set res [fileutil::cat -translation binary $path]
+
+ removeFile out
+ set res
+} "dummy\nfoo"
+
+test insertintofile-2.5 {insertIntoFile, translation 2} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path {}
+
+ fileutil::insertIntoFile -translation crlf $path 0 "dummy\nfoo"
+ set res [fileutil::cat -translation binary $path]
+
+ removeFile out
+ set res
+} "dummy\r\nfoo"
+
+
+test removefromfile-1.0 {removeFromFile, unwriteable file} {unixOnly notRoot} {
+ set path [makeFile {} unwritable]
+ file attributes $path -permissions 0000
+
+ catch {fileutil::removeFromFile $path 0 {}} msg
+
+ file attributes $path -permissions 0600
+ removeFile unwritable
+
+ string map [list $path @] $msg
+} {Cannot use file "@", write access is denied}
+
+test removefromfile-1.1 {removeFromFile, not a file} {unixOnly} {
+ set path [makeDirectory notafile]
+
+ catch {fileutil::removeFromFile $path 0 {}} msg
+
+ removeDirectory notafile
+ string map [list $path @] $msg
+} {Cannot use file "@", is not a file}
+
+test removefromfile-1.2 {removeFromFile, missing file} {
+ set path [makeFile {} missing]
+ removeFile missing
+
+ catch {fileutil::removeFromFile $path 0 {}} msg
+
+ string map [list $path @] $msg
+} {Cannot use file "@", does not exist}
+
+test removefromfile-1.3 {removeFromFile, wrong#args} {
+ catch {fileutil::removeFromFile irrelevant} msg
+ set msg
+} {wrong#args: should be fileutil::removeFromFile ?-eofchar|-translation|-encoding arg? file at n}
+
+test removefromfile-1.4 {removeFromFile, wrong#args} {
+ catch {fileutil::removeFromFile} msg
+ set msg
+} {wrong#args: should be fileutil::removeFromFile ?-eofchar|-translation|-encoding arg? file at n}
+
+test removefromfile-1.5 {removeFromFile, wrong#args} {
+ catch {fileutil::removeFromFile a b c d} msg
+ set msg
+} {wrong#args: should be fileutil::removeFromFile ?-eofchar|-translation|-encoding arg? file at n}
+
+test removefromfile-1.6 {removeFromFile, bad option} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::removeFromFile -bogus $path {}} msg
+
+ removeFile dummy
+ set msg
+} {Bad option "-bogus", expected one of -encoding, -eofchar, or -translation}
+
+test removefromfile-1.7 {removeFromFile, non-integer removal point} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::removeFromFile $path foo 0} msg
+
+ removeFile dummy
+ set msg
+} {Expected integer but got "foo"}
+
+test removefromfile-1.8 {removeFromFile, negative removal point} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::removeFromFile $path -1 0} msg
+
+ removeFile dummy
+ set msg
+} {Bad removal point -1, before start of data}
+
+test removefromfile-1.9 {removeFromFile, removal point beyond end-of-file} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::removeFromFile $path 4 0} msg
+
+ removeFile dummy
+ set msg
+} {Bad removal point 4, behind end of data}
+
+set path [makeFile {} dummy]
+set beyond [file size $path]
+incr beyond
+removeFile dummy
+
+test removefromfile-1.10 {removeFromFile, removal point beyond end-of-file} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::removeFromFile $path $beyond 0} msg
+
+ removeFile dummy
+ set msg
+} "Bad removal point $beyond, behind end of data"
+
+test removefromfile-1.11 {removeFromFile, non-integer removal size} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::removeFromFile $path 0 foo} msg
+
+ removeFile dummy
+ set msg
+} {Expected integer but got "foo"}
+
+test removefromfile-1.12 {removeFromFile, negative removal size} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::removeFromFile $path 0 -1} msg
+
+ removeFile dummy
+ set msg
+} {Bad removal size -1}
+
+test removefromfile-1.13 {removeFromFile, removal size beyond end-of-file} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::removeFromFile $path 0 4} msg
+
+ removeFile dummy
+ set msg
+} {Bad removal size 4, going behind end of data}
+
+set path [makeFile {} dummy]
+set beyond [file size $path]
+incr beyond
+removeFile dummy
+
+test removefromfile-1.14 {removeFromFile, removal point beyond end-of-file} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::removeFromFile $path 0 $beyond} msg
+
+ removeFile dummy
+ set msg
+} "Bad removal size $beyond, going behind end of data"
+
+
+test removefromfile-2.0 {removeFromFile, remove at front} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::removeFromFile $path 0 3
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn gorn}
+
+test removefromfile-2.1 {removeFromFile, removal at end} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::removeFromFile $path 3 4
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn ara}
+
+test removefromfile-2.2 {removeFromFile, removal in the middle} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::removeFromFile $path 3 1
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn araorn}
+
+test removefromfile-2.3 {removeFromFile, remove nothing} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::removeFromFile $path 3 0
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn aragorn}
+
+
+test replaceinfile-1.0 {replaceInFile, unwriteable file} {unixOnly notRoot} {
+ set path [makeFile {} unwritable]
+ file attributes $path -permissions 0000
+
+ catch {fileutil::replaceInFile $path 0 0 {}} msg
+
+ file attributes $path -permissions 0600
+ removeFile unwritable
+
+ string map [list $path @] $msg
+} {Cannot use file "@", write access is denied}
+
+test replaceinfile-1.1 {replaceInFile, not a file} {unixOnly} {
+ set path [makeDirectory notafile]
+
+ catch {fileutil::replaceInFile $path 0 0 {}} msg
+
+ removeDirectory notafile
+ string map [list $path @] $msg
+} {Cannot use file "@", is not a file}
+
+test replaceinfile-1.2 {replaceInFile, missing file} {
+ set path [makeFile {} missing]
+ removeFile missing
+
+ catch {fileutil::replaceInFile $path 0 0 {}} msg
+
+ string map [list $path @] $msg
+} {Cannot use file "@", does not exist}
+
+test replaceinfile-1.3 {replaceInFile, wrong#args} {
+ catch {fileutil::replaceInFile irrelevant} msg
+ set msg
+} {wrong#args: should be fileutil::replaceInFile ?-eofchar|-translation|-encoding arg? file at n data}
+
+test replaceinfile-1.4 {replaceInFile, wrong#args} {
+ catch {fileutil::replaceInFile} msg
+ set msg
+} {wrong#args: should be fileutil::replaceInFile ?-eofchar|-translation|-encoding arg? file at n data}
+
+test replaceinfile-1.5 {replaceInFile, wrong#args} {
+ catch {fileutil::replaceInFile a b c d e} msg
+ set msg
+} {wrong#args: should be fileutil::replaceInFile ?-eofchar|-translation|-encoding arg? file at n data}
+
+test replaceinfile-1.6 {replaceInFile, bad option} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::replaceInFile -bogus $path {}} msg
+
+ removeFile dummy
+ set msg
+} {Bad option "-bogus", expected one of -encoding, -eofchar, or -translation}
+
+test replaceinfile-1.7 {replaceInFile, non-integer replacement point} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::replaceInFile $path foo 0 x} msg
+
+ removeFile dummy
+ set msg
+} {Expected integer but got "foo"}
+
+test replaceinfile-1.8 {replaceInFile, negative replacement point} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::replaceInFile $path -1 0 x} msg
+
+ removeFile dummy
+ set msg
+} {Bad replacement point -1, before start of data}
+
+test replaceinfile-1.9 {replaceInFile, replacement point beyond end-of-file} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::replaceInFile $path 4 0 x} msg
+
+ removeFile dummy
+ set msg
+} {Bad replacement point 4, behind end of data}
+
+set path [makeFile {} dummy]
+set beyond [file size $path]
+incr beyond
+removeFile dummy
+
+test replaceinfile-1.10 {replaceInFile, replacement point beyond end-of-file} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::replaceInFile $path $beyond 0 x} msg
+
+ removeFile dummy
+ set msg
+} "Bad replacement point $beyond, behind end of data"
+
+test replaceinfile-1.11 {replaceInFile, non-integer replacement size} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::replaceInFile $path 0 foo x} msg
+
+ removeFile dummy
+ set msg
+} {Expected integer but got "foo"}
+
+test replaceinfile-1.12 {replaceInFile, negative replacement size} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::replaceInFile $path 0 -1 x} msg
+
+ removeFile dummy
+ set msg
+} {Bad replacement size -1}
+
+test replaceinfile-1.13 {replaceInFile, replacement size beyond end-of-file} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::replaceInFile $path 0 4 x} msg
+
+ removeFile dummy
+ set msg
+} {Bad replacement size 4, going behind end of data}
+
+set path [makeFile {} dummy]
+set beyond [file size $path]
+incr beyond
+removeFile dummy
+
+test replaceinfile-1.14 {replaceInFile, replacement size beyond end-of-file} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::replaceInFile $path 0 $beyond x} msg
+
+ removeFile dummy
+ set msg
+} "Bad replacement size $beyond, going behind end of data"
+
+
+test replaceinfile-2.0 {replaceInFile, replace at front, remove} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::replaceInFile $path 0 3 {}
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn gorn}
+
+test replaceinfile-2.1 {replaceInFile, replacement at end, remove} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::replaceInFile $path 3 4 {}
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn ara}
+
+test replaceinfile-2.2 {replaceInFile, replacement in the middle, remove} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::replaceInFile $path 3 1 {}
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn araorn}
+
+test replaceinfile-2.3 {replaceInFile, replace nothing} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::replaceInFile $path 3 0 {}
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn aragorn}
+
+test replaceinfile-2.4 {replaceInFile, replace at front, insert} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::replaceInFile $path 0 0 dummy|
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn dummy|aragorn}
+
+test replaceinfile-2.5 {replaceInFile, replacement at end, append} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::replaceInFile $path 7 0 |dummy
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn aragorn|dummy}
+
+test replaceinfile-2.6 {replaceInFile, replacement in the middle, insert} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::replaceInFile $path 3 0 |dummy|
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn ara|dummy|gorn}
+
+test replaceinfile-2.7 {replaceInFile, replace at front, expand} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::replaceInFile $path 0 3 dummy|
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn dummy|gorn}
+
+test replaceinfile-2.8 {replaceInFile, replacement at end, expand} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::replaceInFile $path 3 4 |dummy
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn ara|dummy}
+
+test replaceinfile-2.9 {replaceInFile, replacement in the middle, expand} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::replaceInFile $path 3 1 |dummy|
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn ara|dummy|orn}
+
+test replaceinfile-2.10 {replaceInFile, replace at front, shrink} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::replaceInFile $path 0 3 |
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn |gorn}
+
+test replaceinfile-2.11 {replaceInFile, replacement at end, shrink} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::replaceInFile $path 3 4 |
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn ara|}
+
+test replaceinfile-2.12 {replaceInFile, replacement in the middle, shrink} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::replaceInFile $path 3 3 |
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn ara|n}
+
+
+test updateinplace-1.0 {updateInPlace, unwriteable file} {unixOnly notRoot} {
+ set path [makeFile {} unwritable]
+ file attributes $path -permissions 0000
+
+ catch {fileutil::updateInPlace $path {string map {}}} msg
+
+ file attributes $path -permissions 0600
+ removeFile unwritable
+
+ string map [list $path @] $msg
+} {Cannot use file "@", write access is denied}
+
+test updateinplace-1.1 {updateInPlace, not a file} {unixOnly} {
+ set path [makeDirectory notafile]
+
+ catch {fileutil::updateInPlace $path {string map {}}} msg
+
+ removeDirectory notafile
+ string map [list $path @] $msg
+} {Cannot use file "@", is not a file}
+
+test updateinplace-1.2 {updateInPlace, missing file} {
+ set path [makeFile {} missing]
+ removeFile missing
+
+ catch {fileutil::updateInPlace $path {string map {}}} msg
+
+ string map [list $path @] $msg
+} {Cannot use file "@", does not exist}
+
+test updateinplace-1.3 {updateInPlace, wrong#args} {
+ catch {fileutil::updateInPlace irrelevant} msg
+ set msg
+} {wrong#args: should be fileutil::updateInPlace ?-eofchar|-translation|-encoding arg? file cmd}
+
+test updateinplace-1.4 {updateInPlace, wrong#args} {
+ catch {fileutil::updateInPlace} msg
+ set msg
+} {wrong#args: should be fileutil::updateInPlace ?-eofchar|-translation|-encoding arg? file cmd}
+
+test updateinplace-1.5 {updateInPlace, wrong#args} {
+ catch {fileutil::updateInPlace a b c} msg
+ set msg
+} {wrong#args: should be fileutil::updateInPlace ?-eofchar|-translation|-encoding arg? file cmd}
+
+test updateinplace-1.6 {updateInPlace, bad option} {
+ set path [makeFile {} dummy]
+
+ catch {fileutil::updateInPlace -bogus $path {string map {}}} msg
+
+ removeFile dummy
+ set msg
+} {Bad option "-bogus", expected one of -encoding, -eofchar, or -translation}
+
+test updateinplace-1.7 {updateInPlace, bogus cmd} {
+ # Error leaves input file unchanged.
+ set path [makeFile {} dummy]
+ fileutil::writeFile $path aragorn
+
+ catch {fileutil::updateInPlace $path bogus} msg
+
+ set msg [list $msg [fileutil::cat $path]]
+ removeFile dummy
+ set msg
+} {{invalid command name "bogus"} aragorn}
+
+
+test updateinplace-2.0 {updateInPlace, string map} {
+ set path [makeFile {} out]
+ fileutil::writeFile $path aragorn
+
+ set res {}
+ lappend res [fileutil::cat $path]
+
+ fileutil::updateInPlace $path {string map {a | r =}}
+
+ lappend res [fileutil::cat $path]
+
+ removeFile out
+ set res
+} {aragorn |=|go=n}
+
+# -------------------------------------------------------------------------
+
+catch {unset path}
+catch {unset res}
+catch {unset msg}
+catch {unset data}
+testsuiteCleanup
+return
diff --git a/tcllib/modules/fileutil/multi.man b/tcllib/modules/fileutil/multi.man
new file mode 100644
index 0000000..42703ce
--- /dev/null
+++ b/tcllib/modules/fileutil/multi.man
@@ -0,0 +1,56 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin fileutil::multi n 0.1]
+[keywords copy]
+[keywords {file utilities}]
+[keywords move]
+[keywords multi-file]
+[keywords remove]
+[moddesc {file utilities}]
+[titledesc {Multi-file operation, scatter/gather, standard object}]
+[category {Programming tools}]
+[require Tcl 8.4]
+[require fileutil::multi [opt 0.1]]
+[require fileutil::multi::op [opt 0.1]]
+[require wip [opt 1.0]]
+[description]
+[para]
+
+This package provides a single command to perform actions on multiple
+files selected by glob patterns. It is a thin layer over the package
+[package fileutil::multi::op] which provides objects for the
+same. This package simply creates a single such object and directs all
+file commands to it.
+
+[para]
+
+At the core is a domain specific language allowing the easy
+specification of multi-file copy and/or move and/or deletion
+operations. Alternate names would be scatter/gather processor, or
+maybe even assembler.
+
+For the detailed specification of this language, and examples, please
+see the documention for the package [package fileutil::multi::op].
+
+[section {PUBLIC API}]
+
+The main command of the package is:
+
+[list_begin definitions]
+
+[call [cmd ::fileutil::multi] [opt [arg word]...]]
+
+This command interprets the specified words as file commands to
+execute. See the section [sectref-external {FILE API}] of the
+documentation for the package [package fileutil::multi::op] for
+the set of acceptable commands, their syntax, and semantics.
+
+[para]
+
+The result of the command is the result generated by the last file
+command it executed.
+
+[list_end]
+
+[vset CATEGORY fileutil]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/fileutil/multi.tcl b/tcllib/modules/fileutil/multi.tcl
new file mode 100644
index 0000000..b95a728
--- /dev/null
+++ b/tcllib/modules/fileutil/multi.tcl
@@ -0,0 +1,28 @@
+# ### ### ### ######### ######### #########
+##
+# (c) 2007 Andreas Kupries.
+
+# Multi file operations. Singleton based on the multiop processor.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require fileutil::multi::op
+
+# ### ### ### ######### ######### #########
+## API & Implementation
+
+namespace eval ::fileutil {}
+
+# Create the multiop processor object and make its do method the main
+# command of this package.
+::fileutil::multi::op ::fileutil::multi::obj
+
+proc ::fileutil::multi {args} {
+ return [uplevel 1 [linsert $args 0 ::fileutil::multi::obj do]]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide fileutil::multi 0.1
diff --git a/tcllib/modules/fileutil/multi.test b/tcllib/modules/fileutil/multi.test
new file mode 100644
index 0000000..01c4273
--- /dev/null
+++ b/tcllib/modules/fileutil/multi.test
@@ -0,0 +1,310 @@
+# -*- tcl -*-
+# Tests for the multi-op system.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: multi.test,v 1.5 2008/10/11 05:42:37 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.1
+
+support {
+ use snit/snit.tcl snit
+ use struct/list.tcl struct::list
+ use wip/wip.tcl wip
+ useLocal fileutil.tcl fileutil
+ useLocal multiop.tcl fileutil::multi::op
+
+ useLocalFile multiop.setup
+}
+testing {
+ useLocalKeep multi.tcl fileutil::multi
+}
+
+# -------------------------------------------------------------------------
+
+test multi-1.0 {multi-file operation, copying} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset copy from $src to $dst the *e* except for *n*
+ list [mo_scan origin] [mo_scan destination]
+} -cleanup {
+ mo_cleanup
+} -result {{anneliese bertram connie detlev egon egon/bettina egon/suse} {bertram detlev}}
+
+test multi-1.1 {multi-file operation, moving} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset move from $src into $dst the *e* except for *n*
+ list [mo_scan origin] [mo_scan destination]
+} -cleanup {
+ mo_cleanup
+} -result {{anneliese connie egon egon/bettina egon/suse} {bertram detlev}}
+
+test multi-1.1 {multi-file operation, deletion} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset copy from $src into $dst the *e* except for *n*
+ fileutil::multi reset remove in $dst the *a*
+ mo_scan destination
+} -cleanup {
+ mo_cleanup
+} -result {detlev}
+
+test multi-1.2 {multi-file operation, recursive copying} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset recursively copy the * from $src to $dst
+ list [mo_scan origin] [mo_scan destination]
+} -cleanup {
+ mo_cleanup
+} -result {{anneliese bertram connie detlev egon egon/bettina egon/suse} {anneliese bertram connie detlev egon egon/bettina egon/suse}}
+
+test multi-1.3 {multi-file operation, recursive move} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset recursively move the * files from $src to $dst
+ list [mo_scan origin] [mo_scan destination]
+} -cleanup {
+ mo_cleanup
+} -result {egon {anneliese bertram connie detlev egon egon/bettina egon/suse}}
+
+test multi-1.4 {multi-file operation, expand and save} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset expand the *a* in $src -> v
+ lsort $v
+} -cleanup {
+ mo_cleanup ; unset v
+} -result {anneliese bertram}
+
+test multi-1.5 {multi-file operation, expand and save} -setup {
+ mo_setup
+} -body {
+ set v {bertram egon}
+ fileutil::multi reset copy the-set v from $src to $dst
+ mo_scan destination
+} -cleanup {
+ mo_cleanup ; unset v
+} -result {bertram egon egon/bettina egon/suse}
+
+# -------------------------------------------------------------------------
+
+test multi-2.0 {multi-file operation, platform conditionals, not matching, win on unix} -setup {
+ mo_setup
+} -constraints unix -body {
+ set v {bertram egon}
+ fileutil::multi reset for-win copy the-set v from $src to $dst
+ mo_scan destination
+} -cleanup {
+ mo_cleanup ; unset v
+} -result {}
+
+test multi-2.1 {multi-file operation, platform conditionals, not matching, unix on win} -setup {
+ mo_setup
+} -constraints win -body {
+ set v {bertram egon}
+ fileutil::multi reset for-unix copy the-set v from $src to $dst
+ mo_scan destination
+} -cleanup {
+ mo_cleanup ; unset v
+} -result {}
+
+test multi-2.2 {multi-file operation, platform conditionals, matching, unix} -setup {
+ mo_setup
+} -constraints unix -body {
+ set v {bertram}
+ fileutil::multi reset for-unix copy the-set v from $src to $dst
+ mo_scan destination
+} -cleanup {
+ mo_cleanup ; unset v
+} -result {bertram}
+
+test multi-2.3 {multi-file operation, platform conditionals, matching, windows} -setup {
+ mo_setup
+} -constraints win -body {
+ set v {bertram}
+ fileutil::multi reset for-win copy the-set v from $src to $dst
+ mo_scan destination
+} -cleanup {
+ mo_cleanup ; unset v
+} -result {bertram}
+
+# -------------------------------------------------------------------------
+
+proc rec {args} {
+ global res
+ lappend res $args
+ return
+}
+
+test multi-3.0 {multi-file operation, invoke user operation} -setup {
+ mo_setup
+} -constraints unix -body {
+ set v {bertram egon}
+ set res {}
+ fileutil::multi reset invoke rec the-set v from $src to $dst as X
+ set res
+} -cleanup {
+ mo_cleanup ; unset v res
+} -result [list [list $src $dst {bertram X egon egon}]]
+
+# -------------------------------------------------------------------------
+
+test multi-4.0 {multi-file operation, moving, files} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset move the * files from $src into $dst
+ list [mo_scan origin] [mo_scan destination]
+} -cleanup {
+ mo_cleanup
+} -result {{egon egon/bettina egon/suse} {anneliese bertram connie detlev}}
+
+test multi-4.1 {multi-file operation, moving, directories} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset move the * directories from $src into $dst
+ list [mo_scan origin] [mo_scan destination]
+} -cleanup {
+ mo_cleanup
+} -result {{anneliese bertram connie detlev} {egon egon/bettina egon/suse}}
+
+test multi-4.2 {multi-file operation, moving, links} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset move the * links from $src into $dst
+ list [mo_scan origin] [mo_scan destination]
+} -cleanup {
+ mo_cleanup
+} -result {{anneliese bertram connie detlev egon egon/bettina egon/suse} {}}
+
+# -------------------------------------------------------------------------
+
+test multi-5.0 {multi-file operation, strict destination} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset strict into ${dst}x
+} -cleanup {
+ mo_cleanup
+} -returnCodes error -result "Destination directory \"${dst}x\": Does not exist"
+
+test multi-5.1 {multi-file operation, non-strict destination} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset !strict into ${dst}x
+} -cleanup {
+ mo_cleanup
+} -result {}
+
+test multi-5.2 {multi-file operation, strict expansion} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset strict expand the A* in $src
+} -cleanup {
+ mo_cleanup
+} -returnCodes error -result "No files matching pattern \"A*\" in directory \"$src\""
+
+test multi-5.3 {multi-file operation, non-strict expansion} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset !strict expand the A* in $src
+} -cleanup {
+ mo_cleanup
+} -result {}
+
+# -------------------------------------------------------------------------
+
+test multi-6.0 {multi-file operation, query state, defaults} -setup {
+ mo_setup
+ fileutil::multi reset
+} -body {
+ list \
+ [dictsort [fileutil::multi state?]] \
+ [fileutil::multi as?] \
+ [fileutil::multi excluded?] \
+ [fileutil::multi from?] \
+ [fileutil::multi into?] \
+ [fileutil::multi operation?] \
+ [fileutil::multi recursive?] \
+ [fileutil::multi strict?] \
+ [fileutil::multi type?]
+
+} -cleanup {
+ mo_cleanup
+} -result {{as {} excluded {} from {} into {} op {} recursive 0 strict 0 type {}} {} {} {} {} {} 0 0 {}}
+
+test multi-6.1 {multi-file operation, query state, settings} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset from $src to B not C* as D links recursive strict move
+ string map [list $src @] [list \
+ [dictsort [fileutil::multi state?]] \
+ [fileutil::multi as?] \
+ [fileutil::multi excluded?] \
+ [fileutil::multi from?] \
+ [fileutil::multi into?] \
+ [fileutil::multi operation?] \
+ [fileutil::multi recursive?] \
+ [fileutil::multi strict?] \
+ [fileutil::multi type?]]
+} -cleanup {
+ mo_cleanup
+} -result {{as D excluded C* from @ into B op move recursive 1 strict 1 type links} D C* @ B move 1 1 links}
+
+# -------------------------------------------------------------------------
+
+test multi-7.0 {multi-file operation, change destination dir, subdir} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset in A cd B into?
+} -cleanup {
+ mo_cleanup
+} -result A/B
+
+test multi-7.1 {multi-file operation, change destination dir, up} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset in A cd B up into?
+} -cleanup {
+ mo_cleanup
+} -result A
+
+# -------------------------------------------------------------------------
+
+test multi-8.0 {multi-file operation, stack handling} -setup {
+ mo_setup
+} -body {
+ list \
+ [dictsort [fileutil::multi reset state?]] \
+ [dictsort [fileutil::multi \( into B as A not C* state?]] \
+ [dictsort [fileutil::multi \) state?]]
+} -cleanup {
+ mo_cleanup
+} -result [list \
+ {as {} excluded {} from {} into {} op {} recursive 0 strict 0 type {}} \
+ {as A excluded C* from {} into B op {} recursive 0 strict 0 type {}} \
+ {as {} excluded {} from {} into {} op {} recursive 0 strict 0 type {}} \
+ ]
+
+test multi-8.1 {multi-file operation, stack handling, underflow} -setup {
+ mo_setup
+} -body {
+ fileutil::multi reset \)
+} -cleanup {
+ mo_cleanup
+} -returnCodes error -result {Stack underflow}
+
+# -------------------------------------------------------------------------
+mo_cleanup_all
+testsuiteCleanup
+return
diff --git a/tcllib/modules/fileutil/multiop.man b/tcllib/modules/fileutil/multiop.man
new file mode 100644
index 0000000..9227be4
--- /dev/null
+++ b/tcllib/modules/fileutil/multiop.man
@@ -0,0 +1,402 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin fileutil::multi::op n 0.5.3]
+[keywords copy]
+[keywords {file utilities}]
+[keywords move]
+[keywords multi-file]
+[keywords remove]
+[moddesc {file utilities}]
+[titledesc {Multi-file operation, scatter/gather}]
+[category {Programming tools}]
+[require Tcl 8.4]
+[require fileutil::multi::op [opt 0.5.3]]
+[require wip [opt 1.0]]
+[description]
+[para]
+
+This package provides objects which are able to perform actions on
+multiple files selected by glob patterns.
+
+[para]
+
+At the core is a domain specific language allowing the easy
+specification of multi-file copy and/or move and/or deletion
+operations. Alternate names would be scatter/gather processor, or
+maybe even assembler.
+
+[section {CLASS API}]
+
+The main command of the package is:
+
+[list_begin definitions]
+
+[call [cmd ::fileutil::multi::op] [opt [arg opName]] [opt [arg word]...]]
+
+The command creates a new multi-file operation object with an
+associated global Tcl command whose name is [arg opName]. This
+command can be used to invoke the various possible file operations.
+It has the following general form:
+
+[list_begin definitions]
+[call [cmd opName] [arg option] [opt [arg "arg arg ..."]]]
+
+[arg Option] and the [arg arg]s determine the exact behavior of the
+command.
+
+[list_end]
+[para]
+
+If the string [const %AUTO%] is used as the [arg opName] then the
+package will generate a unique name on its own.
+
+[para]
+
+If one or more [arg word]s are specified they are interpreted as an
+initial set of file commands to execute. I.e. the method [method do]
+of the newly constructed object is implicitly invoked using the words
+as its arguments.
+
+[list_end]
+
+[para]
+
+[section {OBJECT API}]
+
+The following methods are possible for multi-file operation objects:
+
+[list_begin definitions]
+
+[call [cmd \$opName] [method do] [opt [arg word]...]]
+
+This method interprets the specified words as file commands to
+execute. See the section [sectref {FILE API}] for the set of
+acceptable commands, their syntax, and semantics.
+
+[para]
+
+The result of the method is the result generated by the last file
+command it executed.
+
+[list_end]
+
+[section {FILE API}]
+
+Both object constructor and method [method do] take a list of words
+and interpret them as file commands to execute. The names were chosen
+to allow the construction of operations as sentences in near-natural
+language. Most of the commands influence just the state of the object,
+i.e. are simply providing the configuration used by the command
+triggering the actual action.
+
+[list_begin definitions]
+[call [cmd into] [arg directory]]
+
+Specifies the destination directory for operations.
+
+[call [cmd in] [arg directory]]
+
+Alias for [cmd into].
+
+[call [cmd to] [arg directory]]
+
+Alias for [cmd into].
+
+[call [cmd from] [arg directory]]
+
+Specifies the source directory for operations.
+
+[call [cmd not] [arg pattern]]
+
+Specifies a glob pattern for paths to be excluded from the operation.
+
+[call [cmd for] [arg pattern]]
+
+Alias for [cmd not].
+
+[call [cmd exclude] [arg pattern]]
+
+Alias for [cmd not].
+
+[call [cmd but]]
+
+Has no arguments of its own, but looks ahead in the list of words and
+executes all [cmd not] commands immediately following it. This allows the
+construction of "but not" and "but exclude" clauses for a more natural
+sounding specification of excluded paths.
+
+[call [cmd except]]
+
+A semi-alias for [cmd but]. Has no arguments of its own, but looks
+ahead in the list of words and executes all [cmd for] commands
+immediately following it. This allows the construction of "except for"
+clauses for a more natural sounding specification of excluded paths.
+
+[call [cmd as] [arg name]]
+
+Specifies a new name for the first file handled by the current
+operation. I.e. for the renaming of a single file during the
+operation.
+
+[call [cmd recursive]]
+
+Signals that file expansion should happen in the whole directory
+hierarchy and not just the directory itself.
+
+[call [cmd recursively]]
+
+An alias for [cmd recursive].
+
+[call [cmd copy]]
+
+Signals that the operation is the copying of files from source to
+destination directory per the specified inclusion and exclusion
+patterns.
+
+[call [cmd move]]
+
+Signals that the operation is the moving of files from source to
+destination directory per the specified inclusion and exclusion
+patterns.
+
+[call [cmd remove]]
+
+Signals that the operation is the removal of files in the destination
+directory per the specified inclusion and exclusion patterns.
+
+[call [cmd expand]]
+
+Signals that there is no operation but the calculation of the set of
+files from the include and exclude patterns. This operation is not
+available if [cmd the-set] is used.
+
+[call [cmd invoke] [arg cmdprefix]]
+
+Signals that the user-specified command prefix [arg cmdprefix] is the
+operation to perform. The command prefix is executed at the global
+level and given the source directory, destination directory, and set
+of files (as dictionary mapping from source to destination files), in
+this order.
+
+[call [cmd reset]]
+
+Forces the object into the ground state where all parts of the
+configuration have default values.
+
+[call [cmd "("]]
+
+Saves a copy of the current object state on a stack.
+
+[call [cmd ")"]]
+
+Takes the state at the top of the state stack and restores it,
+i.e. makes it the new current object state.
+
+[call [cmd cd] [arg directory]]
+
+Changes the destination directory to the sub-directory [arg directory]
+of the current destination.
+
+[call [cmd up]]
+
+Changes the destination directory to the parent directory of the
+current destination.
+
+[call [cmd for-windows]]
+
+Checks that Windows is the current platform. Aborts processing if not.
+
+[call [cmd for-win]]
+
+An alias for [cmd for-windows].
+
+[call [cmd for-unix]]
+
+Checks that Unix is the current platform. Aborts processing if not.
+
+[call [cmd the] [arg pattern]]
+
+This command specifies the files to operate on per a glob pattern, and
+is also the active element, i.e. the command which actually performs
+the specified operation. All the other commands only modified the
+object state to set the operation up, but di nothing else.
+
+[para]
+
+To allow for a more natural sounding syntax this command also looks
+ahead in the list of words looks and executes several commands
+immediately following it before performing its own actions.
+
+These commands are [cmd as], [cmd but], [cmd exclude], [cmd except],
+[cmd from], and [cmd into] (and aliases). That way these commands act
+like qualifiers, and still take effect as if they had been written
+before this command.
+
+[para]
+
+After the operation has been performed the object state the exclude
+patterns and the alias name, if specified, are reset to their default
+values (i.e. empty), but nothing else.
+
+[call [cmd the-set] [arg varname]]
+
+Like [cmd the], however the set of files to use is not specified
+implicitly per a glob pattern, but contained and loaded from the
+specified variable. The operation [cmd expand] is not available
+if this command is used.
+
+[call [cmd ->] [arg varname]]
+
+Saves the set of files from the last expansion into the specified
+variable.
+
+[call [cmd strict]]
+
+Make file expansion and definition of destination directory ([cmd in]
+and aliases) strict, i.e. report errors for missing directories, and
+empty expansion.
+
+[call [cmd !strict]]
+
+Complement of [cmd strict]. A missing destination directory or empty
+expansion are not reported as errors.
+
+[call [cmd files]]
+
+Limit the search to files. Default is to accept every type of path.
+
+[call [cmd links]]
+
+Limit the search to symbolic links. Default is to accept every type of path.
+
+[call [cmd directories]]
+
+Limit the search to directories. Default is to accept every type of path.
+
+[call [cmd dirs]]
+
+An alias for [cmd directories].
+
+[call [cmd all]]
+
+Accept all types of paths (default).
+
+[call [cmd state?]]
+
+Returns the current state of the object as dictionary. The dictionary keys and their meanings are:
+
+[list_begin definitions]
+[def [const as]]
+Last setting made by [cmd as].
+[def [const excluded]]
+List of currently known exclusion patterns.
+[def [const from]]
+Current source directory, set by [cmd from].
+[def [const into]]
+Current destination directory, set by [cmd into] (and aliases).
+[def [const operation]]
+Current operation to perform, set by [cmd copy], [cmd move], [cmd remove], [cmd expand], or [cmd invoke].
+[def [const recursive]]
+Current recursion status. Set/unset by [cmd recursive] and [cmd !recursive].
+[def [const strict]]
+Current strictness. Set/unset by [cmd strict] and [cmd !strict].
+[def [const type]]
+Current path type limiter. Set by either [cmd files], [cmd directories], [cmd links], or [cmd all].
+[list_end]
+
+[call [cmd as?]]
+Returns the current alias name.
+[call [cmd excluded?]]
+Returns the current set of exclusion patterns.
+[call [cmd from?]]
+Returns the current source directory.
+[call [cmd into?]]
+Returns the current destination directory.
+[call [cmd operation?]]
+Returns the current operation to perform.
+[call [cmd recursive?]]
+Returns the current recursion status.
+[call [cmd strict?]]
+Returns the current strictness.
+[call [cmd type?]]
+Returns the current path type limiter.
+[list_end]
+
+[section EXAMPLES]
+
+The following examples assume that the variable [var F] contains a
+reference to a multi-file operation object.
+
+[example {
+ $F do copy \\
+ the *.dll \\
+ from c:/TDK/PrivateOpenSSL/bin \\
+ to [installdir_of tls]
+}]
+
+[example {
+ $F do move \\
+ the * \\
+ from /sources \\
+ into /scratch \\
+ but not *.html
+
+ # Alternatively use 'except for *.html'.
+}]
+
+[example {
+ $F do \\
+ move \\
+ the index \\
+ from /sources \\
+ into /scratch \\
+ as pkgIndex.tcl
+}]
+
+[example {
+ $F do \\
+ remove \\
+ the *.txt \\
+ in /scratch
+}]
+
+Note that the fact that most commands just modify the object state
+allows us to use more off forms as specifications instead of just
+nearly-natural language sentences.
+
+For example the second example in this section can re-arranged into:
+
+[example {
+ $F do \\
+ from /sources \\
+ into /scratch \\
+ but not *.html \\
+ move \\
+ the *
+}]
+
+and the result is not only still a valid specification, but even stays
+relatively readable.
+
+[para]
+
+Further note that the information collected by the commands [cmd but],
+[cmd except], and [cmd as] is automatically reset after the associated
+[cmd the] was executed. However no other state is reset in that
+manner, allowing the user to avoid repetitions of unchanging
+information. For example the second and third examples of this section
+can be merged and rewritten into the equivalent:
+
+[example {
+$F do \\
+ move \\
+ the * \\
+ from /sources \\
+ into /scratch \\
+ but not *.html not index \\
+ the index \\
+ as pkgIndex.tcl
+}]
+
+[vset CATEGORY fileutil]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/fileutil/multiop.setup b/tcllib/modules/fileutil/multiop.setup
new file mode 100644
index 0000000..1e31c8b
--- /dev/null
+++ b/tcllib/modules/fileutil/multiop.setup
@@ -0,0 +1,49 @@
+# -*- tcl -*-
+# Support code for the tests of the find command (and incremental find).
+#
+# Copyright (c) 2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: multiop.setup,v 1.1 2007/08/16 04:11:49 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+proc mo_setup {} {
+ makeDirectory origin
+ makeFile {} origin/anneliese
+ makeFile {} origin/bertram
+ makeFile {} origin/connie
+ makeFile {} origin/detlev
+ makeDirectory origin/egon
+ makeFile {} origin/egon/suse
+ makeFile {} origin/egon/bettina
+ makeDirectory destination
+ return
+}
+
+proc mo_cleanup {} {
+ removeDirectory origin
+ removeDirectory destination
+ return
+}
+
+proc mo_scan {d} {
+ set base [tempPath $d]
+ return [lsort -dict \
+ [struct::list map [fileutil::find $base] \
+ [list fileutil::stripPath $base]]]
+}
+
+proc mo_cleanup_all {} {
+ rename mo_setup {}
+ rename mo_cleanup {}
+ rename mo_scan {}
+ rename mo_cleanup_all {}
+ unset ::src ::dst
+ return
+}
+
+set src [tempPath origin]
+set dst [tempPath destination]
+
+# -------------------------------------------------------------------------
diff --git a/tcllib/modules/fileutil/multiop.tcl b/tcllib/modules/fileutil/multiop.tcl
new file mode 100644
index 0000000..4725daf
--- /dev/null
+++ b/tcllib/modules/fileutil/multiop.tcl
@@ -0,0 +1,645 @@
+# ### ### ### ######### ######### #########
+##
+# (c) 2007-2008 Andreas Kupries.
+
+# DSL allowing the easy specification of multi-file copy and/or move
+# and/or deletion operations. Alternate names would be scatter/gather
+# processor, or maybe even assembler.
+
+# Examples:
+# (1) copy
+# into [installdir_of tls]
+# from c:/TDK/PrivateOpenSSL/bin
+# the *.dll
+#
+# (2) move
+# from /sources
+# into /scratch
+# the *
+# but not *.html
+# (Alternatively: except for *.html)
+#
+# (3) into /scratch
+# from /sources
+# move
+# as pkgIndex.tcl
+# the index
+#
+# (4) in /scratch
+# remove
+# the *.txt
+
+# The language is derived from the parts of TclApp's option language
+# dealing with files and their locations, yet not identical. In parts
+# simplified, in parts more capable, keyword names were changed
+# throughout.
+
+# Language commands
+
+# From the examples
+#
+# into DIR : Specify destination directory.
+# in DIR : See 'into'.
+# from DIR : Specify source directory.
+# the PATTERN (...) : Specify files to operate on.
+# but not PATTERN : Specify exceptions to 'the'.
+# but exclude PATTERN : Specify exceptions to 'the'.
+# except for PATTERN : See 'but not'.
+# as NAME : New name for file.
+# move : Move files.
+# copy : Copy files.
+# remove : Delete files.
+#
+# Furthermore
+#
+# reset : Force to defaults.
+# cd DIR : Change destination to subdirectory.
+# up : Change destination to parent directory.
+# ( : Save a copy of the current state.
+# ) : Restore last saved state and make it current.
+
+# The main active element is the command 'the'. In other words, this
+# command not only specifies the files to operate on, but also
+# executes the operation as defined in the current state. All other
+# commands modify the state to set the operation up, and nothing
+# else. To allow for a more natural syntax the active command also
+# looks ahead for the commands 'as', 'but', and 'except', and executes
+# them, like qualifiers, so that they take effect as if they had been
+# written before. The command 'but' and 'except use identical
+# constructions to handle their qualifiers, i.e. 'not' and 'for'.
+
+# Note that the fact that most commands just modify the state allows
+# us to use more off forms as specifications instead of just natural
+# language sentences For example the example 2 can re-arranged into:
+#
+# (5) from /sources
+# into /scratch
+# but not *.html
+# move
+# the *
+#
+# and the result is still a valid specification.
+
+# Further note that the information collected by 'but', 'except', and
+# 'as' is automatically reset after the associated 'the' was
+# executed. However no other state is reset in that manner, allowing
+# the user to avoid repetitions of unchanging information. Lets us for
+# example merge the examples 2 and 3. The trivial merge is:
+
+# (6) move
+# into /scratch
+# from /sources
+# the *
+# but not *.html not index
+# move
+# into /scratch
+# from /sources
+# the index
+# as pkgIndex.tcl
+#
+# With less repetitions
+#
+# (7) move
+# into /scratch
+# from /sources
+# the *
+# but not *.html not index
+# the index
+# as pkgIndex.tcl
+
+# I have not yet managed to find a suitable syntax to specify when to
+# add a new extension to the moved/copied files, or have to strip all
+# extensions, a specific extension, or even replace extensions.
+
+# Other possibilities to muse about: Load the patterns for 'not'/'for'
+# from a file ... Actually, load the whole exceptions from a file,
+# with its contents a proper interpretable word list. Which makes it
+# general processing of include files.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# This processor uses the 'wip' word list interpreter as its
+# foundation.
+
+package require fileutil ; # File testing
+package require snit ; # OO support
+package require struct::stack ; # Context stack
+package require wip ; # DSL execution core
+
+# ### ### ### ######### ######### #########
+## API & Implementation
+
+snit::type ::fileutil::multi::op {
+ # ### ### ### ######### ######### #########
+ ## API
+
+ constructor {args} {} ; # create processor
+
+ # ### ### ### ######### ######### #########
+ ## API - Implementation.
+
+ constructor {args} {
+ install stack using struct::stack ${selfns}::stack
+ $self wip_setup
+
+ # Mapping dsl commands to methods.
+ defdva \
+ reset Reset ( Push ) Pop \
+ into Into in Into from From \
+ cd ChDir up ChUp as As \
+ move Move copy Copy remove Remove \
+ but But not Exclude the The \
+ except Except for Exclude exclude Exclude \
+ to Into -> Save the-set TheSet \
+ recursive Recursive recursively Recursive \
+ for-win ForWindows for-unix ForUnix \
+ for-windows ForWindows expand Expand \
+ invoke Invoke strict Strict !strict NotStrict \
+ files Files links Links all Everything \
+ dirs Directories directories Directories \
+ state? QueryState from? QueryFrom into? QueryInto \
+ excluded? QueryExcluded as? QueryAs type? QueryType \
+ recursive? QueryRecursive operation? QueryOperation \
+ strict? QueryStrict !recursive NotRecursive
+
+ $self Reset
+ runl $args
+ return
+ }
+
+ destructor {
+ $mywip destroy
+ return
+ }
+
+ method do {args} {
+ return [runl $args]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## DSL Implementation
+ wip::dsl
+
+ # General reset of processor state
+ method Reset {} {
+ $stack clear
+ set base ""
+ set alias ""
+ set op ""
+ set recursive 0
+ set src ""
+ set excl ""
+ set types {}
+ set strict 0
+ return
+ }
+
+ # Stack manipulation
+ method Push {} {
+ $stack push [list $base $alias $op $opcmd $recursive $src $excl $types $strict]
+ return
+ }
+
+ method Pop {} {
+ if {![$stack size]} {
+ return -code error {Stack underflow}
+ }
+ foreach {base alias op opcmd recursive src excl types strict} [$stack pop] break
+ return
+ }
+
+ # Destination directory
+ method Into {dir} {
+ if {$dir eq ""} {set dir [pwd]}
+ if {$strict && ![fileutil::test $dir edr msg {Destination directory}]} {
+ return -code error $msg
+ }
+ set base $dir
+ return
+ }
+
+ method ChDir {dir} { $self Into [file join $base $dir] ; return }
+ method ChUp {} { $self Into [file dirname $base] ; return }
+
+ # Detail
+ method As {fname} {
+ set alias [ForceRelative $fname]
+ return
+ }
+
+ # Operations
+ method Move {} { set op move ; return }
+ method Copy {} { set op copy ; return }
+ method Remove {} { set op remove ; return }
+ method Expand {} { set op expand ; return }
+
+ method Invoke {cmdprefix} {
+ set op invoke
+ set opcmd $cmdprefix
+ return
+ }
+
+ # Operation qualifier
+ method Recursive {} { set recursive 1 ; return }
+ method NotRecursive {} { set recursive 0 ; return }
+
+ # Source directory
+ method From {dir} {
+ if {$dir eq ""} {set dir [pwd]}
+ if {![fileutil::test $dir edr msg {Source directory}]} {
+ return -code error $msg
+ }
+ set src $dir
+ return
+ }
+
+ # Exceptions
+ method But {} { run_next_while {not exclude} ; return }
+ method Except {} { run_next_while {for} ; return }
+
+ method Exclude {pattern} {
+ lappend excl $pattern
+ return
+ }
+
+ # Define the files to operate on, and perform the operation.
+ method The {pattern} {
+ run_next_while {as but except exclude from into in to files dirs directories links all}
+
+ switch -exact -- $op {
+ invoke {Invoke [Resolve [Remember [Exclude [Expand $src $pattern]]]]}
+ move {Move [Resolve [Remember [Exclude [Expand $src $pattern]]]]}
+ copy {Copy [Resolve [Remember [Exclude [Expand $src $pattern]]]]}
+ remove {Remove [Remember [Exclude [Expand $base $pattern]]] }
+ expand { Remember [Exclude [Expand $base $pattern]] }
+ }
+
+ # Reset the per-pattern flags of the resolution context back
+ # to their defaults, for the next pattern.
+
+ set alias {}
+ set excl {}
+ set recursive 0
+ return
+ }
+
+ # Like 'The' above, except that the fileset is taken from the
+ # specified variable. Semi-complementary to 'Save' below.
+ # Exclusion data and recursion info do not apply for this, this is
+ # already implicitly covered by the set, when it was generated.
+
+ method TheSet {varname} {
+ # See 'Save' for the levels we jump here.
+ upvar 5 $varname var
+
+ run_next_while {as from into in to}
+
+ switch -exact -- $op {
+ invoke {Invoke [Resolve $var]}
+ move {Move [Resolve $var]}
+ copy {Copy [Resolve $var]}
+ remove {Remove $var }
+ expand {
+ return -code error "Expansion does not make sense\
+ when we already have a set of files."
+ }
+ }
+
+ # Reset the per-pattern flags of the resolution context back
+ # to their defaults, for the next pattern.
+
+ set alias {}
+ return
+ }
+
+ # Save the last expansion result to a variable for use by future commands.
+
+ method Save {varname} {
+ # Levels to jump. Brittle.
+ # 5: Caller
+ # 4: object do ...
+ # 3: runl
+ # 2: wip::runl
+ # 1: run_next
+ # 0: Here
+ upvar 5 $varname v
+ set v $lastexpansion
+ return
+ }
+
+ # Platform conditionals ...
+
+ method ForUnix {} {
+ global tcl_platform
+ if {$tcl_platform(platform) eq "unix"} return
+ # Kill the remaining code. This effectively aborts processing.
+ replacel {}
+ return
+ }
+
+ method ForWindows {} {
+ global tcl_platform
+ if {$tcl_platform(platform) eq "windows"} return
+ # Kill the remaining code. This effectively aborts processing.
+ replacel {}
+ return
+ }
+
+ # Strictness
+
+ method Strict {} {
+ set strict 1
+ return
+ }
+
+ method NotStrict {} {
+ set strict 0
+ return
+ }
+
+ # Type qualifiers
+
+ method Files {} {
+ set types files
+ return
+ }
+
+ method Links {} {
+ set types links
+ return
+ }
+
+ method Directories {} {
+ set types dirs
+ return
+ }
+
+ method Everything {} {
+ set types {}
+ return
+ }
+
+ # State interogation
+
+ method QueryState {} {
+ return [list \
+ from $src \
+ into $base \
+ as $alias \
+ op $op \
+ excluded $excl \
+ recursive $recursive \
+ type $types \
+ strict $strict \
+ ]
+ }
+ method QueryExcluded {} {
+ return $excl
+ }
+ method QueryFrom {} {
+ return $src
+ }
+ method QueryInto {} {
+ return $base
+ }
+ method QueryAs {} {
+ return $alias
+ }
+ method QueryOperation {} {
+ return $op
+ }
+ method QueryRecursive {} {
+ return $recursive
+ }
+ method QueryType {} {
+ return $types
+ }
+ method QueryStrict {} {
+ return $strict
+ }
+
+ # ### ### ### ######### ######### #########
+ ## DSL State
+
+ component stack ; # State stack - ( )
+ variable base "" ; # Destination dir - into, in, cd, up
+ variable alias "" ; # Detail - as
+ variable op "" ; # Operation - move, copy, remove, expand, invoke
+ variable opcmd "" ; # Command prefix for invoke.
+ variable recursive 0 ; # Op. qualifier: recursive expansion?
+ variable src "" ; # Source dir - from
+ variable excl "" ; # Excluded files - but not|exclude, except for
+ # incl ; # Included files - the (immediate use)
+ variable types {} ; # Limit glob/find to specific types (f, l, d).
+ variable strict 0 ; # Strictness of into/Expand
+
+ variable lastexpansion "" ; # Area for last expansion result, for 'Save' to take from.
+
+ # ### ### ### ######### ######### #########
+ ## Internal -- Path manipulation helpers.
+
+ proc ForceRelative {path} {
+ set pathtype [file pathtype $path]
+ switch -exact -- $pathtype {
+ relative {
+ return $path
+ }
+ absolute {
+ # Chop off the first element in the path, which is the
+ # root, either '/' or 'x:/'. If this was the only
+ # element assume an empty path.
+
+ set path [lrange [file split $path] 1 end]
+ if {![llength $path]} {return {}}
+ return [eval [linsert $path 0 file join]]
+ }
+ volumerelative {
+ return -code error {Unable to handle volumerelative path, yet}
+ }
+ }
+
+ return -code error \
+ "file pathtype returned unknown type \"$pathtype\""
+ }
+
+ proc ForceAbsolute {path} {
+ return [file join [pwd] $path]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal - Operation execution helpers
+
+ proc Invoke {files} {
+ upvar 1 base base src src opcmd opcmd
+ uplevel #0 [linsert $opcmd end $src $base $files]
+ return
+ }
+
+ proc Move {files} {
+ upvar 1 base base src src
+
+ foreach {s d} $files {
+ set s [file join $src $s]
+ set d [file join $base $d]
+
+ file mkdir [file dirname $d]
+ file rename -force $s $d
+ }
+ return
+ }
+
+ proc Copy {files} {
+ upvar 1 base base src src
+
+ foreach {s d} $files {
+ set s [file join $src $s]
+ set d [file join $base $d]
+
+ file mkdir [file dirname $d]
+ if {
+ [file isdirectory $s] &&
+ [file exists $d] &&
+ [file isdirectory $d]
+ } {
+ # Special case: source and destination are
+ # directories, and the latter exists. This puts the
+ # source under the destination, and may even prevent
+ # copying at all. The semantics of the operation is
+ # that the source is the destination. We avoid the
+ # trouble by copying the contents of the source,
+ # instead of the directory itself.
+ foreach path [glob -directory $s *] {
+ file copy -force $path $d
+ }
+ } else {
+ file copy -force $s $d
+ }
+ }
+ return
+ }
+
+ proc Remove {files} {
+ upvar 1 base base
+
+ foreach f $files {
+ file delete -force [file join $base $f]
+ }
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal -- Resolution helper commands
+
+ typevariable tmap -array {
+ files {f TFile}
+ links {l TLink}
+ dirs {d TDir}
+ {} {{} {}}
+ }
+
+ proc Expand {dir pattern} {
+ upvar 1 recursive recursive strict strict types types tmap tmap
+ # FUTURE: struct::list filter ...
+
+ set files {}
+ if {$recursive} {
+ # Recursion through the entire directory hierarchy, save
+ # all matching paths.
+
+ set filter [lindex $tmap($types) 1]
+ if {$filter ne ""} {
+ set filter [myproc $filter]
+ }
+
+ foreach f [fileutil::find $dir $filter] {
+ if {![string match $pattern [file tail $f]]} continue
+ lappend files [fileutil::stripPath $dir $f]
+ }
+ } else {
+ # No recursion, just scan the whole directory for matching paths.
+ # check for specific types integrated.
+
+ set filter [lindex $tmap($types) 0]
+ if {$filter ne ""} {
+ foreach f [glob -nocomplain -directory $dir -types $filter -- $pattern] {
+ lappend files [fileutil::stripPath $dir $f]
+ }
+ } else {
+ foreach f [glob -nocomplain -directory $dir -- $pattern] {
+ lappend files [fileutil::stripPath $dir $f]
+ }
+ }
+ }
+
+ if {[llength $files]} {return $files}
+ if {!$strict} {return {}}
+
+ return -code error \
+ "No files matching pattern \"$pattern\" in directory \"$dir\""
+ }
+
+ proc TFile {f} {file isfile $f}
+ proc TDir {f} {file isdirectory $f}
+ proc TLink {f} {expr {[file type $f] eq "link"}}
+
+ proc Exclude {files} {
+ upvar 1 excl excl
+
+ # FUTURE: struct::list filter ...
+ set res {}
+ foreach f $files {
+ if {[IsExcluded $f $excl]} continue
+ lappend res $f
+ }
+ return $res
+ }
+
+ proc IsExcluded {f patterns} {
+ foreach p $patterns {
+ if {[string match $p $f]} {return 1}
+ }
+ return 0
+ }
+
+ proc Resolve {files} {
+ upvar 1 alias alias
+ set res {}
+ foreach f $files {
+
+ # Remember alias for processing and auto-invalidate to
+ # prevent contamination of the next file.
+
+ set thealias $alias
+ set alias ""
+
+ if {$thealias eq ""} {
+ set d $f
+ } else {
+ set d [file dirname $f]
+ if {$d eq "."} {
+ set d $thealias
+ } else {
+ set d [file join $d $thealias]
+ }
+ }
+
+ lappend res $f $d
+ }
+ return $res
+ }
+
+ proc Remember {files} {
+ upvar 1 lastexpansion lastexpansion
+ set lastexpansion $files
+ return $files
+ }
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide fileutil::multi::op 0.5.3
diff --git a/tcllib/modules/fileutil/multiop.test b/tcllib/modules/fileutil/multiop.test
new file mode 100644
index 0000000..a94e1c6
--- /dev/null
+++ b/tcllib/modules/fileutil/multiop.test
@@ -0,0 +1,370 @@
+# -*- tcl -*-
+# Tests for the multi-op system.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: multiop.test,v 1.7 2008/10/11 05:42:37 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.1
+
+support {
+ use snit/snit.tcl snit
+ use struct/list.tcl struct::list
+
+ # Note: Order is important for the next two. First ::fileutil is
+ # wiped out, and through this all previously created multi::op
+ # objects, like from the 'multi.test'. This also kills the
+ # embedded wip objects, and wiping out ::wip after is ok.
+
+ # However, if we were to wipe out ::wip before ::fileutil kills
+ # the wip objects, and leaves the multi::op objects with dangling
+ # references. Wiping them then out then causes snit to write error
+ # messages to stdout (RT.InstanceTrace) due to the already deleted
+ # namespaces for the wip objects.
+
+ useLocal fileutil.tcl fileutil
+ use wip/wip.tcl wip
+
+ useLocalFile multiop.setup
+}
+testing {
+ useLocal multiop.tcl fileutil::multi::op
+}
+
+# -------------------------------------------------------------------------
+
+test multiop-1.0 {multi-file operation, copying} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do copy the *e* from $src to $dst except for *n*
+ list [mo_scan origin] [mo_scan destination]
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -result {{anneliese bertram connie detlev egon egon/bettina egon/suse} {bertram detlev}}
+
+test multiop-1.1 {multi-file operation, moving} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do move the *e* from $src into $dst except for *n*
+ list [mo_scan origin] [mo_scan destination]
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -result {{anneliese connie egon egon/bettina egon/suse} {bertram detlev}}
+
+test multiop-1.1 {multi-file operation, deletion} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do copy the *e* from $src into $dst except for *n*
+ X do remove the *a* in $dst
+ mo_scan destination
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -result {detlev}
+
+test multiop-1.2 {multi-file operation, recursive copying} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do recursively copy the * from $src to $dst
+ list [mo_scan origin] [mo_scan destination]
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -result {{anneliese bertram connie detlev egon egon/bettina egon/suse} {anneliese bertram connie detlev egon egon/bettina egon/suse}}
+
+test multiop-1.3 {multi-file operation, recursive move} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do recursively move the * files from $src to $dst
+ list [mo_scan origin] [mo_scan destination]
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -result {egon {anneliese bertram connie detlev egon egon/bettina egon/suse}}
+
+test multiop-1.4 {multi-file operation, expand and save} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do expand the *a* in $src -> v
+ lsort $v
+} -cleanup {
+ mo_cleanup ; unset v
+ X destroy
+} -result {anneliese bertram}
+
+test multiop-1.5 {multi-file operation, expand and save} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ set v {bertram egon}
+ X do copy the-set v from $src to $dst
+ mo_scan destination
+} -cleanup {
+ mo_cleanup ; unset v
+ X destroy
+} -result {bertram egon egon/bettina egon/suse}
+
+# -------------------------------------------------------------------------
+
+test multiop-2.0 {multi-file operation, platform conditionals, not matching, win on unix} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -constraints unix -body {
+ set v {bertram egon}
+ X do for-win copy the-set v from $src to $dst
+ mo_scan destination
+} -cleanup {
+ mo_cleanup ; unset v
+ X destroy
+} -result {}
+
+test multiop-2.1 {multi-file operation, platform conditionals, not matching, unix on win} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -constraints win -body {
+ set v {bertram egon}
+ X do for-unix copy the-set v from $src to $dst
+ mo_scan destination
+} -cleanup {
+ mo_cleanup ; unset v
+ X destroy
+} -result {}
+
+test multiop-2.2 {multi-file operation, platform conditionals, matching, unix} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -constraints unix -body {
+ set v {bertram}
+ X do for-unix copy the-set v from $src to $dst
+ mo_scan destination
+} -cleanup {
+ mo_cleanup ; unset v
+ X destroy
+} -result {bertram}
+
+test multiop-2.3 {multi-file operation, platform conditionals, matching, windows} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -constraints win -body {
+ set v {bertram}
+ X do for-win copy the-set v from $src to $dst
+ mo_scan destination
+} -cleanup {
+ mo_cleanup ; unset v
+ X destroy
+} -result {bertram}
+
+# -------------------------------------------------------------------------
+
+proc rec {args} {
+ global res
+ lappend res $args
+ return
+}
+
+test multiop-3.0 {multi-file operation, invoke user operation} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -constraints unix -body {
+ set v {bertram egon}
+ set res {}
+ X do invoke rec the-set v from $src to $dst as X
+ set res
+} -cleanup {
+ mo_cleanup ; unset v res
+ X destroy
+} -result [list [list $src $dst {bertram X egon egon}]]
+
+# -------------------------------------------------------------------------
+
+test multiop-4.0 {multi-file operation, moving, files} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do move the * files from $src into $dst
+ list [mo_scan origin] [mo_scan destination]
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -result {{egon egon/bettina egon/suse} {anneliese bertram connie detlev}}
+
+test multiop-4.1 {multi-file operation, moving, directories} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do move the * directories from $src into $dst
+ list [mo_scan origin] [mo_scan destination]
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -result {{anneliese bertram connie detlev} {egon egon/bettina egon/suse}}
+
+test multiop-4.2 {multi-file operation, moving, links} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do move the * links from $src into $dst
+ list [mo_scan origin] [mo_scan destination]
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -result {{anneliese bertram connie detlev egon egon/bettina egon/suse} {}}
+
+# -------------------------------------------------------------------------
+
+test multiop-5.0 {multi-file operation, strict destination} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do strict into ${dst}x
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -returnCodes error -result "Destination directory \"${dst}x\": Does not exist"
+
+test multiop-5.1 {multi-file operation, non-strict destination} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do !strict into ${dst}x
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -result {}
+
+test multiop-5.2 {multi-file operation, strict expansion} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do strict expand the A* in $src
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -returnCodes error -result "No files matching pattern \"A*\" in directory \"$src\""
+
+test multiop-5.3 {multi-file operation, non-strict expansion} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do !strict expand the A* in $src
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -result {}
+
+# -------------------------------------------------------------------------
+
+test multiop-6.0 {multi-file operation, query state, defaults} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ list \
+ [dictsort [X do state?]] \
+ [X do as?] \
+ [X do excluded?] \
+ [X do from?] \
+ [X do into?] \
+ [X do operation?] \
+ [X do recursive?] \
+ [X do strict?] \
+ [X do type?]
+
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -result {{as {} excluded {} from {} into {} op {} recursive 0 strict 0 type {}} {} {} {} {} {} 0 0 {}}
+
+test multiop-6.1 {multi-file operation, query state, settings} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do from $src to B not C* as D links recursive strict move
+ string map [list $src @] [list \
+ [dictsort [X do state?]] \
+ [X do as?] \
+ [X do excluded?] \
+ [X do from?] \
+ [X do into?] \
+ [X do operation?] \
+ [X do recursive?] \
+ [X do strict?] \
+ [X do type?]]
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -result {{as D excluded C* from @ into B op move recursive 1 strict 1 type links} D C* @ B move 1 1 links}
+
+# -------------------------------------------------------------------------
+
+test multiop-7.0 {multi-file operation, change destination dir, subdir} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do in A cd B into?
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -result A/B
+
+test multiop-7.1 {multi-file operation, change destination dir, up} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do in A cd B up into?
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -result A
+
+# -------------------------------------------------------------------------
+
+test multiop-8.0 {multi-file operation, stack handling} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ list \
+ [dictsort [X do state?]] \
+ [dictsort [X do \( into B as A not C* state?]] \
+ [dictsort [X do \) state?]]
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -result [list \
+ {as {} excluded {} from {} into {} op {} recursive 0 strict 0 type {}} \
+ {as A excluded C* from {} into B op {} recursive 0 strict 0 type {}} \
+ {as {} excluded {} from {} into {} op {} recursive 0 strict 0 type {}} \
+ ]
+
+test multiop-8.1 {multi-file operation, stack handling, underflow} -setup {
+ mo_setup
+ fileutil::multi::op X
+} -body {
+ X do \)
+} -cleanup {
+ mo_cleanup
+ X destroy
+} -returnCodes error -result {Stack underflow}
+
+# -------------------------------------------------------------------------
+mo_cleanup_all
+testsuiteCleanup
+return
diff --git a/tcllib/modules/fileutil/pathops.test b/tcllib/modules/fileutil/pathops.test
new file mode 100644
index 0000000..0ff6866
--- /dev/null
+++ b/tcllib/modules/fileutil/pathops.test
@@ -0,0 +1,515 @@
+# -*- tcl -*-
+# Tests for the find function.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2001 by ActiveState Tool Corp.
+# Copyright (c) 2005-2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pathops.test,v 1.2 2009/10/27 19:16:34 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal fileutil.tcl fileutil
+}
+
+# -------------------------------------------------------------------------
+
+set dir $::tcltest::temporaryDirectory
+
+# -------------------------------------------------------------------------
+
+test jail-1.0 {jail error} {
+ catch {::fileutil::jail} res
+ set res
+} [tcltest::wrongNumArgs {::fileutil::jail} {jail filename} 0]
+
+test jail-1.2 {jail error} {
+ catch {::fileutil::jail a} res
+ set res
+} [tcltest::wrongNumArgs {::fileutil::jail} {jail filename} 1]
+
+test jail-1.3 {jail error} {
+ catch {::fileutil::jail a b c} res
+ set res
+} [tcltest::tooManyArgs {::fileutil::jail} {jail filename}]
+
+test jail-2.0 {jail relative} {
+ ::fileutil::jail /var/www a/b/c
+} /var/www/a/b/c
+
+test jail-2.1 {jail absolute outside} {
+ ::fileutil::jail /var/www /a/b/c
+} /var/www/a/b/c
+
+test jail-2.1.1 {jail absolute outside, spaces} {
+ ::fileutil::jail /var/www {/a/b/c d}
+} {/var/www/a/b/c d}
+
+test jail-2.2 {jail absolute inside} {
+ ::fileutil::jail /var/www /var/www/a/b/c
+} /var/www/a/b/c
+
+test jail-2.2.1 {jail absolute inside} {
+ ::fileutil::jail /var/www {/var/www/a/b/c d}
+} {/var/www/a/b/c d}
+
+test jail-2.3 {try to escape from jail} {
+ ::fileutil::jail /var/www ../../etc/passwd
+} /var/www/etc/passwd
+
+test jail-2.4 {jail is relative itself} {
+ ::fileutil::jail a b
+} [file join $dir a b]
+
+test jail-2.4.1 {jail is relative itself, spaces in path} {
+ ::fileutil::jail a {b c}
+} [file join $dir a {b c}]
+
+test jail-2.4.2 {jail is relative itself, spaces in path} {
+ ::fileutil::jail {a b} {c d}
+} [file join $dir {a b} {c d}]
+
+
+# Need tests using non-existing paths for sure. Similar tests for
+# 'normalize' as well.
+
+# Tests for the internal 'Normalize' command. This is our forward
+# compatibility wrapper and it should behave identical to the
+# 8.4. builtin 'file normalize'. We pilfered the test cases from the
+# test suite for 'file normalize' in the Tcl core.
+
+if {![string equal $::tcl_platform(platform) windows]} {
+
+ set dirfile [makeDirectory dir.file]
+ set dirbfile [makeDirectory dir2.file]
+ set insidefile [makeFile "test file in directory" dir.file/inside.file]
+ set gorpfile [makeFile "test file" gorp.file]
+
+ # Paths for the links.
+
+ set linkfile [tempPath link.file]
+ set dirlink [tempPath dir.link]
+ set dirblink [tempPath dir2.link]
+ set linkinsidefile [tempPath $dirfile/linkinside.file]
+ set dirbblink [tempPath $dirbfile/dir2.link]]
+
+ # Create the links. Unix specific.
+
+ exec ln -s gorp.file $linkfile
+ exec ln -s inside.file $linkinsidefile
+ exec ln -s dir.file $dirlink
+ exec ln -s dir.link $dirblink
+ exec ln -s ../dir2.link $dirbblink
+
+ # File/Directory structure created by the above.
+ #
+ # /FOO/dir2.link -> dir.link
+ # /FOO/dir.link -> dir.file
+ # /FOO/dir.file/
+ # /FOO/dir.file/linkinside.file -> inside.file
+ # /FOO/dir.file/inside.file
+ #
+ # /FOO/link.file -> gorp.file
+ # /FOO/gorp.file
+ #
+ # /FOO/dir2.file/
+ # /FOO/dir2.file/dir2.link -> ../dir2.link
+}
+
+
+test fu-normalize-1.0 {link normalisation} {unixOnly} {
+ # Symlink of last path element is not resolved.
+ string equal \
+ [::fileutil::Normalize $gorpfile] \
+ [::fileutil::Normalize $linkfile]
+} {0}
+
+test fu-normalize-1.1 {link normalisation} {unixOnly} {
+ # Symlink of last path element is not resolved.
+ string equal \
+ [::fileutil::Normalize $dirfile] \
+ [::fileutil::Normalize $dirlink]
+} {0}
+
+test fu-normalize-1.2 {link normalisation} {unixOnly} {
+ # Link higher in path is resolved (File!, non-existing last component).
+ string equal \
+ [::fileutil::Normalize [file join $gorpfile foo]] \
+ [::fileutil::Normalize [file join $linkfile foo]]
+} {1}
+
+test fu-normalize-1.3 {link normalisation} {unixOnly} {
+ # Link higher in path is resolved (Directory, non-existing last component).
+ string equal \
+ [::fileutil::Normalize [file join $dirfile foo]] \
+ [::fileutil::Normalize [file join $dirlink foo]]
+} {1}
+
+test fu-normalize-1.4 {link normalisation} {unixOnly} {
+ # Link higher in path is resolved (Directory, existing last component).
+ string equal \
+ [::fileutil::Normalize $insidefile] \
+ [::fileutil::Normalize [file join $dirlink inside.file]]
+} {1}
+
+test fu-normalize-1.5 {link normalisation} {unixOnly} {
+ # Identical paths.
+ string equal \
+ [::fileutil::Normalize $linkinsidefile] \
+ [::fileutil::Normalize $linkinsidefile]
+} {1}
+
+test fu-normalize-1.6 {link normalisation} {unixOnly} {
+ # Double link, one in last component, that one not resolved.
+ string equal \
+ [::fileutil::Normalize $linkinsidefile] \
+ [::fileutil::Normalize [file join $dirlink inside.file]]
+} {0}
+
+test fu-normalize-1.7 {link normalisation} {unixOnly} {
+ # Double link, both higher up, second is file!, both resolved
+ string equal \
+ [::fileutil::Normalize [file join $dirlink linkinside.file foo]] \
+ [::fileutil::Normalize [file join $insidefile foo]]
+} {1}
+
+test fu-normalize-1.8 {link normalisation} {unixOnly} {
+ # Directory link, and bad last component
+ string equal \
+ [::fileutil::Normalize ${linkinsidefile}foo] \
+ [::fileutil::Normalize [file join $dirlink inside.filefoo]]
+} {0}
+
+if 0 {
+ test fu-normalize-1.9 {link normalisation} {unixOnly} {
+ file delete -force $dirlink
+ file link $dirlink [file nativename $dirfile]
+ string equal \
+ [::fileutil::Normalize [file join $linkinsidefile foo]] \
+ [::fileutil::Normalize [file join $dirlink inside.file foo]]
+ } {1}
+}
+
+test fu-normalize-1.10 {link normalisation: double link} {unixOnly} {
+ # Double symlink in one component.
+ string equal \
+ [::fileutil::Normalize [file join $linkinsidefile foo]] \
+ [::fileutil::Normalize [file join $dirblink inside.file foo]]
+} {1}
+
+
+test fu-normalize-1.11 {link normalisation: double link, back in tree} {unixOnly} {
+ # Double link and back up in the tree.
+
+ string equal \
+ [::fileutil::Normalize [file join $linkinsidefile foo]] \
+ [::fileutil::Normalize [file join $dirbblink inside.file foo]]
+} {1}
+
+
+test fu-normalize-2.0 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::Normalize /a/b/c
+} /a/b/c
+
+test fu-normalize-2.1 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::Normalize /a/../b/c
+} /b/c
+
+test fu-normalize-2.2 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::Normalize /a/./b/c
+} /a/b/c
+
+test fu-normalize-2.3 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::Normalize /../b/c
+} /b/c
+
+test fu-normalize-2.4 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::Normalize /a/../../b/c
+} /b/c
+
+
+
+# Based on the internal Normalize, a fullnormalize (which resolves a
+# link in the last element as well.
+
+test fu-fullnormalize-1.0 {link normalisation} {unixOnly} {
+ # Symlink of last path element _is_ resolved.
+ string equal \
+ [::fileutil::fullnormalize $gorpfile] \
+ [::fileutil::fullnormalize $linkfile]
+} {1}
+
+test fu-fullnormalize-1.1 {link normalisation} {unixOnly} {
+ # Symlink of last path element _is_ resolved.
+ string equal \
+ [::fileutil::fullnormalize $dirfile] \
+ [::fileutil::fullnormalize $dirlink]
+} {1}
+
+test fu-fullnormalize-1.2 {link normalisation} {unixOnly} {
+ # Link higher in path is resolved (File!, non-existing last component).
+ string equal \
+ [::fileutil::fullnormalize [file join $gorpfile foo]] \
+ [::fileutil::fullnormalize [file join $linkfile foo]]
+} {1}
+
+test fu-fullnormalize-1.3 {link normalisation} {unixOnly} {
+ # Link higher in path is resolved (Directory, non-existing last component).
+ string equal \
+ [::fileutil::fullnormalize [file join $dirfile foo]] \
+ [::fileutil::fullnormalize [file join $dirlink foo]]
+} {1}
+
+test fu-fullnormalize-1.4 {link normalisation} {unixOnly} {
+ # Link higher in path is resolved (Directory, existing last component).
+ string equal \
+ [::fileutil::fullnormalize $insidefile] \
+ [::fileutil::fullnormalize [file join $dirlink inside.file]]
+} {1}
+
+test fu-fullnormalize-1.5 {link normalisation} {unixOnly} {
+ # Identical paths.
+ string equal \
+ [::fileutil::fullnormalize $linkinsidefile] \
+ [::fileutil::fullnormalize $linkinsidefile]
+} {1}
+
+test fu-fullnormalize-1.6 {link normalisation} {unixOnly} {
+ # Double link, one in last component, this one is resolved.
+ string equal \
+ [::fileutil::fullnormalize $linkinsidefile] \
+ [::fileutil::fullnormalize [file join $dirlink inside.file]]
+} {1}
+
+test fu-fullnormalize-1.7 {link normalisation} {unixOnly} {
+ # Double link, both higher up, second is file!, both resolved
+ string equal \
+ [::fileutil::fullnormalize [file join $dirlink linkinside.file foo]] \
+ [::fileutil::fullnormalize [file join $insidefile foo]]
+} {1}
+
+test fu-fullnormalize-1.8 {link normalisation} {unixOnly} {
+ # Directory link, and bad last component
+ string equal \
+ [::fileutil::fullnormalize ${linkinsidefile}foo] \
+ [::fileutil::fullnormalize [file join $dirlink inside.filefoo]]
+} {0}
+
+test fu-fullnormalize-1.10 {link normalisation: double link} {unixOnly} {
+ # Double symlink in one component.
+ string equal \
+ [::fileutil::fullnormalize [file join $linkinsidefile foo]] \
+ [::fileutil::fullnormalize [file join $dirblink inside.file foo]]
+} {1}
+
+
+test fu-fullnormalize-2.0 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::fullnormalize /a/b/c
+} /a/b/c
+
+test fu-fullnormalize-2.1 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::fullnormalize /a/../b/c
+} /b/c
+
+test fu-fullnormalize-2.2 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::fullnormalize /a/./b/c
+} /a/b/c
+
+test fu-fullnormalize-2.3 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::fullnormalize /../b/c
+} /b/c
+
+test fu-fullnormalize-2.4 {normalisation, non-existing paths} {unixOnly} {
+ ::fileutil::fullnormalize /a/../../b/c
+} /b/c
+
+# Cleaning up after.
+
+removeFile find3/find4/file5
+removeDirectory find3/find4
+removeDirectory find3
+removeDirectory touchTest
+removeDirectory installDst
+removeDirectory installSrc
+removeDirectory {find 1}
+removeDirectory dotfiles
+removeDirectory grepTest
+
+if {![string equal $::tcl_platform(platform) windows]} {
+ file delete -force $linkfile
+ file delete -force $dirlink
+ file delete -force $dirblink
+ file delete -force $linkinsidefile
+ file delete -force $dirbblink
+
+ removeFile dir.file/inside.file
+ removeFile gorp.file
+ removeDirectory dir.file
+ removeDirectory dir2.file
+}
+
+# -------------------------------------------------------------------------
+# Computation of paths relative to a base.
+
+test fu-relative-1.0 {fileutil::relative, wrong#args} {
+ catch {fileutil::relative} msg
+ set msg
+} [tcltest::wrongNumArgs fileutil::relative {base dst} 0]
+
+test fu-relative-1.1 {fileutil::relative, wrong#args} {
+ catch {fileutil::relative a} msg
+ set msg
+} [tcltest::wrongNumArgs fileutil::relative {base dst} 1]
+
+test fu-relative-1.2 {fileutil::relative, wrong#args} {
+ catch {fileutil::relative a b c} msg
+ set msg
+} [tcltest::tooManyArgs fileutil::relative {base dst}]
+
+foreach {n base dst result} {
+ 0 /base /base/destination destination
+ 1 /base /destination ../destination
+ 2 base base/destination destination
+ 3 base destination ../destination
+ 4 /sub/base /sub/sub/destination ../sub/destination
+ 5 /sub/sub/base /sub/destination ../../destination
+ 6 sub/base sub/sub/destination ../sub/destination
+ 7 sub/sub/base sub/destination ../../destination
+ 8 /base /base .
+ 9 base base .
+ 10 /base/sub /base/sub .
+ 11 base/sub base/sub .
+ 12 /base/sub /base ..
+ 13 base/sub base ..
+ 14 base/sub destination ../../destination
+ 15 base/tcl base/common ../common
+ 16 base/tcl/x base/common ../../common
+ 17 /base/tcl /base/common ../common
+ 18 /base/tcl/x /base/common ../../common
+} {
+ test fu-relative-2.$n {fileutil::relative} {
+ fileutil::relative $base $dst
+ } $result
+}
+
+foreach {n base dst ra rb} {
+ 0 /base base/destination absolute relative
+ 1 base /destination relative absolute
+} {
+ test fu-relative-3.$n {fileutil::relative, bad mix} unixOnly {
+ catch {fileutil::relative $base $dst} msg
+ set msg
+ } "Unable to compute relation for paths of different pathtypes: $ra vs. $rb, ($base vs. $dst)"
+}
+
+foreach {n base dst ra rb} {
+ 0 /base base/destination volumerelative relative
+ 1 base /destination relative volumerelative
+} {
+ test fu-relative-4.$n {fileutil::relative, bad mix} winOnly {
+ catch {fileutil::relative $base $dst} msg
+ set msg
+ } "Unable to compute relation for paths of different pathtypes: $ra vs. $rb, ($base vs. $dst)"
+}
+
+test fu-relativeurl-1.0 {fileutil::relativeUrl, wrong#args} {
+ catch {fileutil::relativeUrl} msg
+ set msg
+} [tcltest::wrongNumArgs fileutil::relativeUrl {base dst} 0]
+
+test fu-relativeurl-1.1 {fileutil::relativeUrl, wrong#args} {
+ catch {fileutil::relativeUrl a} msg
+ set msg
+} [tcltest::wrongNumArgs fileutil::relativeUrl {base dst} 1]
+
+test fu-relativeurl-1.2 {fileutil::relativeUrl, wrong#args} {
+ catch {fileutil::relativeUrl a b c} msg
+ set msg
+} [tcltest::tooManyArgs fileutil::relativeUrl {base dst}]
+
+foreach {n base dst result} {
+ 0 /base/file.html /base/destination/xx.html destination/xx.html
+ 1 /base/file.html /destination/xx.html ../destination/xx.html
+ 2 base/file.html base/destination/xx.html destination/xx.html
+ 3 base/file.html destination/xx.html ../destination/xx.html
+ 4 /sub/base/file.html /sub/sub/destination/xx.html ../sub/destination/xx.html
+ 5 /sub/sub/base/file.html /sub/destination/xx.html ../../destination/xx.html
+ 6 sub/base/file.html sub/sub/destination/xx.html ../sub/destination/xx.html
+ 7 sub/sub/base/file.html sub/destination/xx.html ../../destination/xx.html
+ 8 /base/file.html /base/xx.html xx.html
+ 9 base/file.html base/xx.html xx.html
+ 10 /base/sub/file.html /base/sub/xx.html xx.html
+ 11 base/sub/file.html base/sub/xx.html xx.html
+ 12 /base/sub/file.html /base/xx.html ../xx.html
+ 13 base/sub/file.html base/xx.html ../xx.html
+ 14 base/sub/file.html xx.html ../../xx.html
+ 15 base/tcl/a.html base/common/../common/./style.css ../common/style.css
+ 16 base/tcl/x/a.html base/common/../common/./style.css ../../common/style.css
+ 17 /base/tcl/a.html /base/common/../common/./style.css ../common/style.css
+ 18 /base/tcl/x/a.html /base/common/../common/./style.css ../../common/style.css
+} {
+ test fu-relativeurl-2.$n {fileutil::relativeUrl} {
+ fileutil::relativeUrl $base $dst
+ } $result
+}
+
+foreach {n base dst ra rb} {
+ 0 /base/file.html base/destination/xx.html absolute relative
+ 1 base/file.html /destination/xx.html relative absolute
+} {
+ test fu-relativeurl-3.$n {fileutil::relativeUrl, bad mix} unixOnly {
+ catch {fileutil::relativeUrl $base $dst} msg
+ set msg
+ } "Unable to compute relation for paths of different pathtypes: $ra vs. $rb, ($base vs. $dst)"
+}
+
+foreach {n base dst ra rb} {
+ 0 /base/file.html base/destination/xx.html volumerelative relative
+ 1 base/file.html /destination/xx.html relative volumerelative
+} {
+ test fu-relativeurl-4.$n {fileutil::relativeUrl, bad mix} winOnly {
+ catch {fileutil::relativeUrl $base $dst} msg
+ set msg
+ } "Unable to compute relation for paths of different pathtypes: $ra vs. $rb, ($base vs. $dst)"
+}
+
+if {[llength [info commands ::fileutil::LexNormalize]]} {
+
+ # Check an internal command. May not exist (i.e. an accelerator
+ # may not define it).
+
+ foreach {n base dst} {
+ 0 a/../b b
+ 1 a/./b a/b
+ 2 a a
+ 3 a/b a/b
+ 4 ./a a
+ 5 ../a a
+ 6 /../a /a
+ 7 /./a /a
+ 8 /a/../b /b
+ 9 /foo/bar/../snafu/../gobble /foo/gobble
+ } {
+ test fu-lexnormalize-1.$n "fileutil::LexNormalize $base" {
+ fileutil::LexNormalize $base
+ } $dst
+ }
+}
+
+# -------------------------------------------------------------------------
+
+unset dir
+testsuiteCleanup
+return
diff --git a/tcllib/modules/fileutil/pkgIndex.tcl b/tcllib/modules/fileutil/pkgIndex.tcl
new file mode 100644
index 0000000..8f6c392
--- /dev/null
+++ b/tcllib/modules/fileutil/pkgIndex.tcl
@@ -0,0 +1,10 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded fileutil 1.15 [list source [file join $dir fileutil.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.3]} {return}
+package ifneeded fileutil::traverse 0.6 [list source [file join $dir traverse.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded fileutil::multi 0.1 [list source [file join $dir multi.tcl]]
+package ifneeded fileutil::multi::op 0.5.3 [list source [file join $dir multiop.tcl]]
+package ifneeded fileutil::decode 0.2 [list source [file join $dir decode.tcl]]
diff --git a/tcllib/modules/fileutil/strip.test b/tcllib/modules/fileutil/strip.test
new file mode 100644
index 0000000..756d304
--- /dev/null
+++ b/tcllib/modules/fileutil/strip.test
@@ -0,0 +1,118 @@
+# -*- tcl -*-
+# Tests for the find function.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2001 by ActiveState Tool Corp.
+# Copyright (c) 2005-2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: strip.test,v 1.3 2009/10/27 19:16:34 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal fileutil.tcl fileutil
+}
+
+# -------------------------------------------------------------------------
+
+set dir $::tcltest::temporaryDirectory
+
+# -------------------------------------------------------------------------
+
+# stripPwd/N/Prefix -----------------------------------------------------
+# dir = $::tcltest::temporaryDirectory = current working directory
+
+test stripPwd-1.0 {unrelated path} {
+ fileutil::stripPwd {find 1}
+} {find 1}
+
+test stripPwd-1.1 {pwd-relative path} {
+ fileutil::stripPwd [file join [pwd] $dir {find 1}]
+} {find 1}
+
+test stripPwd-1.2 {pwd-relative path} {
+ fileutil::stripPwd [file join [pwd] $dir {find 1} {find 2}]
+} [file join {find 1} {find 2}]
+
+test stripPwd-1.3 {pwd itself} {
+ fileutil::stripPwd [pwd]
+} .
+
+
+test stripPath-1.0 {unrelated path} {
+ fileutil::stripPath [pwd] {find 1}
+} {find 1}
+
+test stripPath-1.1 {prefix-relative path} {
+ fileutil::stripPath [pwd] [file join [pwd] $dir {find 1}]
+} {find 1}
+
+test stripPath-1.2 {prefix-relative path} {
+ fileutil::stripPath [pwd] [file join [pwd] $dir {find 1} {find 2}]
+} [file join {find 1} {find 2}]
+
+test stripPath-1.3 {prefix itself} {
+ fileutil::stripPath [pwd] [pwd]
+} .
+
+
+test stripPath-2.0 {SF Tcllib Bug 2499641, handle mixed case properly on windows} win {
+ fileutil::stripPath C:/temp C:/Temp/foo
+} foo
+
+test stripPath-2.1.0 {SF Tcllib Bug 2872536, partial paths} unix {
+ fileutil::stripPath /temp /tempx/foo
+} /tempx/foo
+
+test stripPath-2.1.1 {SF Tcllib Bug 2872536, partial paths} win {
+ fileutil::stripPath C:/temp C:/Tempx/foo
+} C:/Tempx/foo
+
+test stripPath-2.2 {SF Tcllib Bug 2872536, different separators} win {
+ fileutil::stripPath c:/temp/foo/bar c:/temp/foo\\bar
+} .
+
+
+test stripN-1.0 {remove nothing} {
+ fileutil::stripN {find 1} 0
+} {find 1}
+
+test stripN-1.1 {remove all} {
+ fileutil::stripN {find 1} 1
+} {}
+
+test stripN-1.2 {remove more than existing} {
+ fileutil::stripN {find 1} 2
+} {}
+
+test stripN-2.0 {remove nothing} {
+ fileutil::stripN [file join {find 1} {find 2}] 0
+} [file join {find 1} {find 2}]
+
+test stripN-2.1 {remove part} {
+ fileutil::stripN [file join {find 1} {find 2}] 1
+} {find 2}
+
+test stripN-2.2 {remove all} {
+ fileutil::stripN [file join {find 1} {find 2}] 2
+} {}
+
+test stripN-2.3 {remove more than existing} {
+ fileutil::stripN [file join {find 1} {find 2}] 3
+} {}
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/fileutil/test-data/pdf4tcl_01.pdf b/tcllib/modules/fileutil/test-data/pdf4tcl_01.pdf
new file mode 100644
index 0000000..8289779
--- /dev/null
+++ b/tcllib/modules/fileutil/test-data/pdf4tcl_01.pdf
@@ -0,0 +1,83 @@
+%PDF-1.4
+%
+5 0 obj
+<<
+/Length 6 0 R
+>>
+stream
+/Courier 12 Tf
+0 Tr
+12 TL
+BT
+(Hello) Tj
+
+ET
+
+endstream
+endobj
+
+6 0 obj
+45
+endobj
+
+4 0 obj
+<</Type /Page
+/Parent 2 0 R
+/Resources 3 0 R
+/MediaBox [0 0 595 842]
+/Contents [5 0 R]
+>>
+endobj
+
+7 0 obj
+<<
+/Type /Font
+/Subtype /Type1
+/Encoding /WinAnsiEncoding
+/Name /Courier
+/BaseFont /Courier
+>>
+endobj
+1 0 obj
+<<
+/Type /Catalog
+/Pages 2 0 R
+>>
+endobj
+
+2 0 obj
+<<
+/Type /Pages
+/Count 1
+/Kids [4 0 R ]
+>>
+endobj
+
+3 0 obj
+<<
+/ProcSet[/PDF /Text /ImageC]
+/Font <<
+/Courier 7 0 R
+>>
+>>
+endobj
+
+xref
+0 8
+0000000000 65535 f
+0000000347 00000 n
+0000000397 00000 n
+0000000456 00000 n
+0000000131 00000 n
+0000000014 00000 n
+0000000112 00000 n
+0000000237 00000 n
+trailer
+<<
+/Size 8
+/Root 1 0 R
+>>
+
+startxref
+534
+%%EOF
diff --git a/tcllib/modules/fileutil/test.test b/tcllib/modules/fileutil/test.test
new file mode 100644
index 0000000..9807dbe
--- /dev/null
+++ b/tcllib/modules/fileutil/test.test
@@ -0,0 +1,665 @@
+# -*- tcl -*-
+# Tests for fileutil commands. 'test'.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2001 by ActiveState Tool Corp.
+# Copyright (c) 2005-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: test.test,v 1.2 2009/10/06 20:07:18 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal fileutil.tcl fileutil
+}
+
+# -------------------------------------------------------------------------
+# In 8.3+ we can use symbolic permissions, i.e. strings like u+r, or
+# ugo-r when invoking 'file attributes'. This feature is however not
+# available in Tcl 8.2, the lowest revision supported by the
+# package. So we make do without them and use absolute permissions
+# instead.
+
+# 644 = -rw-r--r--
+# 700 = -rwx------
+# 600 = -rw-------
+# 500 = -r-x------
+# 300 = --wx------
+
+# -------------------------------------------------------------------------
+
+set xpath [makeFile {} x] ; removeFile x
+
+# -------------------------------------------------------------------------
+
+proc makewritable {path enable} {
+ global tcl_platform
+ if {[string equal $tcl_platform(platform) windows]} {
+ set ro [expr {!$enable}]
+ file attributes $path -readonly $ro
+ } else {
+ set mode [expr {$enable ? "700" : "500"}]
+ file attributes $path -permissions 00$mode
+ }
+ return
+}
+
+proc makereadable {path enable} {
+ global tcl_platform
+ if {[string equal $tcl_platform(platform) windows]} {
+ return -code error "Can't do that on Windows"
+ } else {
+ set mode [expr {$enable ? "700" : "300"}]
+ file attributes $path -permissions 00$mode
+ }
+ return
+}
+
+proc makeexecutable {path enable} {
+ global tcl_platform
+ if {[string equal $tcl_platform(platform) windows]} {
+ return -code error "Can't do that on Windows"
+ } else {
+ set mode [expr {$enable ? "700" : "600"}]
+ file attributes $path -permissions 00$mode
+ }
+ return
+}
+
+# -------------------------------------------------------------------------
+
+test test-1.0.0 {test read} {unixOnly} {
+ set path [makeFile {} x]
+ makereadable $path 1
+
+ set x PRE
+ set res [list [fileutil::test $path read x TEST] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-1.0.1 {test read, no variable} {unixOnly} {
+ set path [makeFile {} x]
+ makereadable $path 1
+
+ set x PRE
+ set res [list [fileutil::test $path read] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-1.0.2 {test !read} {unixOnly notRoot} {
+ set path [makeFile {} x]
+ makereadable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path read x TEST] $x]
+ removeFile x
+ set res
+} [list 0 "TEST \"$xpath\": Read access is denied"]
+
+test test-1.0.3 {test !read, no variable} {unixOnly notRoot} {
+ set path [makeFile {} x]
+ makereadable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path read] $x]
+ removeFile x
+ set res
+} {0 PRE}
+
+test test-1.0.4 {test !read, no label} {unixOnly notRead} {
+ set path [makeFile {} x]
+ makereadable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path read x] $x]
+ removeFile x
+ set res
+} [list 0 "\"$xpath\": Read access is denied"]
+
+test test-2.0.0 {test write} {
+ set path [makeFile {} x]
+ makewritable $path 1
+
+ set x PRE
+ set res [list [fileutil::test $path write x TEST] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-2.0.1 {test write, no variable} {
+ set path [makeFile {} x]
+ makewritable $path 1
+
+ set x PRE
+ set res [list [fileutil::test $path write] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-2.0.2 {test !write} notRoot {
+ set path [makeFile {} x]
+ makewritable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path write x TEST] $x]
+ removeFile x
+ set res
+} [list 0 "TEST \"$xpath\": Write access is denied"]
+
+test test-2.0.3 {test !write, no variable} notRoot {
+ set path [makeFile {} x]
+ makewritable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path write] $x]
+ removeFile x
+ set res
+} {0 PRE}
+
+test test-2.0.4 {test !write, no label} notRoot {
+ set path [makeFile {} x]
+ makewritable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path write x] $x]
+ removeFile x
+ set res
+} [list 0 "\"$xpath\": Write access is denied"]
+
+test test-3.0.0 {test exists} {
+ set path [makeFile {} x]
+
+ set x PRE
+ set res [list [fileutil::test $path exists x TEST] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-3.0.1 {test exists, no variable} {
+ set path [makeFile {} x]
+
+ set x PRE
+ set res [list [fileutil::test $path exists] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-3.0.2 {test !exists} {
+ set path [makeFile {} x]
+ removeFile x
+
+ set x PRE
+ set res [list [fileutil::test $path exists x TEST] $x]
+ set res
+} [list 0 "TEST \"$xpath\": Does not exist"]
+
+test test-3.0.3 {test !exists, no variable} {
+ set path [makeFile {} x]
+ removeFile x
+
+ set x PRE
+ set res [list [fileutil::test $path exists] $x]
+ set res
+} {0 PRE}
+
+test test-3.0.4 {test !exists, no label} {
+ set path [makeFile {} x]
+ removeFile x
+
+ set x PRE
+ set res [list [fileutil::test $path exists x] $x]
+ set res
+} [list 0 "\"$xpath\": Does not exist"]
+
+test test-4.0.0 {test file} {
+ set path [makeFile {} x]
+
+ set x PRE
+ set res [list [fileutil::test $path file x TEST] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-4.0.1 {test file, no variable} {
+ set path [makeFile {} x]
+
+ set x PRE
+ set res [list [fileutil::test $path file] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-4.0.2 {test !file} {
+ set path [makeDirectory x]
+
+ set x PRE
+ set res [list [fileutil::test $path file x TEST] $x]
+ removeDirectory x
+ set res
+} [list 0 "TEST \"$xpath\": Is not a file"]
+
+test test-4.0.3 {test !file, no variable} {
+ set path [makeDirectory x]
+
+ set x PRE
+ set res [list [fileutil::test $path file] $x]
+ removeDirectory x
+ set res
+} {0 PRE}
+
+test test-4.0.4 {test !file, no label} {
+ set path [makeDirectory x]
+
+ set x PRE
+ set res [list [fileutil::test $path file x] $x]
+ removeDirectory x
+ set res
+} [list 0 "\"$xpath\": Is not a file"]
+
+test test-5.0.0 {test dir} {
+ set path [makeDirectory x]
+
+ set x PRE
+ set res [list [fileutil::test $path dir x TEST] $x]
+ removeDirectory x
+ set res
+} {1 PRE}
+
+test test-5.0.1 {test dir, no variable} {
+ set path [makeDirectory x]
+
+ set x PRE
+ set res [list [fileutil::test $path dir] $x]
+ removeDirectory x
+ set res
+} {1 PRE}
+
+test test-5.0.2 {test !dir} {
+ set path [makeFile {} x]
+
+ set x PRE
+ set res [list [fileutil::test $path dir x TEST] $x]
+ removeFile x
+ set res
+} [list 0 "TEST \"$xpath\": Is not a directory"]
+
+test test-5.0.3 {test !dir, no variable} {
+ set path [makeFile {} x]
+
+ set x PRE
+ set res [list [fileutil::test $path dir] $x]
+ removeFile x
+ set res
+} {0 PRE}
+
+test test-5.0.4 {test !dir, no label} {
+ set path [makeFile {} x]
+
+ set x PRE
+ set res [list [fileutil::test $path dir x] $x]
+ removeFile x
+ set res
+} [list 0 "\"$xpath\": Is not a directory"]
+
+test test-6.0.0 {test exec} {unixOnly} {
+ set path [makeFile {} x]
+ makeexecutable $path 1
+
+ set x PRE
+ set res [list [fileutil::test $path exec x TEST] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-6.0.1 {test exec, no variable} {unixOnly} {
+ set path [makeFile {} x]
+ makeexecutable $path 1
+
+ set x PRE
+ set res [list [fileutil::test $path exec] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-6.0.2 {test !exec} {unixOnly} {
+ set path [makeFile {} x]
+ makeexecutable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path exec x TEST] $x]
+ removeFile x
+ set res
+} [list 0 "TEST \"$xpath\": Is not executable"]
+
+test test-6.0.3 {test !exec, no variable} {unixOnly} {
+ set path [makeFile {} x]
+ makeexecutable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path exec] $x]
+ removeFile x
+ set res
+} {0 PRE}
+
+test test-6.0.4 {test !exec, no label} {unixOnly} {
+ set path [makeFile {} x]
+ makeexecutable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path exec x] $x]
+ removeFile x
+ set res
+} [list 0 "\"$xpath\": Is not executable"]
+
+
+
+test test-1.1.0 {test read} {unixOnly} {
+ set path [makeFile {} x]
+ makereadable $path 1
+
+ set x PRE
+ set res [list [fileutil::test $path r x TEST] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-1.1.1 {test read, no variable} {unixOnly} {
+ set path [makeFile {} x]
+ makereadable $path 1
+
+ set x PRE
+ set res [list [fileutil::test $path r] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-1.1.2 {test !read} {unixOnly notRoot} {
+ set path [makeFile {} x]
+ makereadable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path r x TEST] $x]
+ removeFile x
+ set res
+} [list 0 "TEST \"$xpath\": Read access is denied"]
+
+test test-1.1.3 {test !read, no variable} {unixOnly notRoot} {
+ set path [makeFile {} x]
+ makereadable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path r] $x]
+ removeFile x
+ set res
+} {0 PRE}
+
+test test-1.1.4 {test !read, no label} {unixOnly notRoot} {
+ set path [makeFile {} x]
+ makereadable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path r x] $x]
+ removeFile x
+ set res
+} [list 0 "\"$xpath\": Read access is denied"]
+
+test test-2.1.0 {test write} {
+ set path [makeFile {} x]
+ makewritable $path 1
+
+ set x PRE
+ set res [list [fileutil::test $path w x TEST] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-2.1.1 {test write, no variable} {
+ set path [makeFile {} x]
+ makewritable $path 1
+
+ set x PRE
+ set res [list [fileutil::test $path w] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-2.1.2 {test !write} notRoot {
+ set path [makeFile {} x]
+ makewritable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path w x TEST] $x]
+ removeFile x
+ set res
+} [list 0 "TEST \"$xpath\": Write access is denied"]
+
+test test-2.1.3 {test !write, no variable} notRoot {
+ set path [makeFile {} x]
+ makewritable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path w] $x]
+ removeFile x
+ set res
+} {0 PRE}
+
+test test-2.1.4 {test !write, no label} notRoot {
+ set path [makeFile {} x]
+ makewritable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path w x] $x]
+ removeFile x
+ set res
+} [list 0 "\"$xpath\": Write access is denied"]
+
+test test-3.1.0 {test exists} {
+ set path [makeFile {} x]
+
+ set x PRE
+ set res [list [fileutil::test $path e x TEST] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-3.1.1 {test exists, no variable} {
+ set path [makeFile {} x]
+
+ set x PRE
+ set res [list [fileutil::test $path e] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-3.1.2 {test !exists} {
+ set path [makeFile {} x]
+ removeFile x
+
+ set x PRE
+ set res [list [fileutil::test $path e x TEST] $x]
+ set res
+} [list 0 "TEST \"$xpath\": Does not exist"]
+
+test test-3.1.3 {test !exists, no variable} {
+ set path [makeFile {} x]
+ removeFile x
+
+ set x PRE
+ set res [list [fileutil::test $path e] $x]
+ set res
+} {0 PRE}
+
+test test-3.1.4 {test !exists, no label} {
+ set path [makeFile {} x]
+ removeFile x
+
+ set x PRE
+ set res [list [fileutil::test $path e x] $x]
+ set res
+} [list 0 "\"$xpath\": Does not exist"]
+
+test test-4.1.0 {test file} {
+ set path [makeFile {} x]
+
+ set x PRE
+ set res [list [fileutil::test $path f x TEST] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-4.1.1 {test file, no variable} {
+ set path [makeFile {} x]
+
+ set x PRE
+ set res [list [fileutil::test $path f] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-4.1.2 {test !file} {
+ set path [makeDirectory x]
+
+ set x PRE
+ set res [list [fileutil::test $path f x TEST] $x]
+ removeDirectory x
+ set res
+} [list 0 "TEST \"$xpath\": Is not a file"]
+
+test test-4.1.3 {test !file, no variable} {
+ set path [makeDirectory x]
+
+ set x PRE
+ set res [list [fileutil::test $path f] $x]
+ removeDirectory x
+ set res
+} {0 PRE}
+
+test test-4.1.4 {test !file, no label} {
+ set path [makeDirectory x]
+
+ set x PRE
+ set res [list [fileutil::test $path f x] $x]
+ removeDirectory x
+ set res
+} [list 0 "\"$xpath\": Is not a file"]
+
+test test-5.1.0 {test dir} {
+ set path [makeDirectory x]
+
+ set x PRE
+ set res [list [fileutil::test $path d x TEST] $x]
+ removeDirectory x
+ set res
+} {1 PRE}
+
+test test-5.1.1 {test dir, no variable} {
+ set path [makeDirectory x]
+
+ set x PRE
+ set res [list [fileutil::test $path d] $x]
+ removeDirectory x
+ set res
+} {1 PRE}
+
+test test-5.1.2 {test !dir} {
+ set path [makeFile {} x]
+
+ set x PRE
+ set res [list [fileutil::test $path d x TEST] $x]
+ removeFile x
+ set res
+} [list 0 "TEST \"$xpath\": Is not a directory"]
+
+test test-5.1.3 {test !dir, no variable} {
+ set path [makeFile {} x]
+
+ set x PRE
+ set res [list [fileutil::test $path d] $x]
+ removeFile x
+ set res
+} {0 PRE}
+
+test test-5.1.4 {test !dir, no label} {
+ set path [makeFile {} x]
+
+ set x PRE
+ set res [list [fileutil::test $path d x] $x]
+ removeFile x
+ set res
+} [list 0 "\"$xpath\": Is not a directory"]
+
+test test-6.1.0 {test exec} {unixOnly} {
+ set path [makeFile {} x]
+ makeexecutable $path 1
+
+ set x PRE
+ set res [list [fileutil::test $path x x TEST] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-6.1.1 {test exec, no variable} {unixOnly} {
+ set path [makeFile {} x]
+ makeexecutable $path 1
+
+ set x PRE
+ set res [list [fileutil::test $path x] $x]
+ removeFile x
+ set res
+} {1 PRE}
+
+test test-6.1.2 {test !exec} {unixOnly} {
+ set path [makeFile {} x]
+ makeexecutable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path x x TEST] $x]
+ removeFile x
+ set res
+} [list 0 "TEST \"$xpath\": Is not executable"]
+
+test test-6.1.3 {test !exec, no variable} {unixOnly} {
+ set path [makeFile {} x]
+ makeexecutable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path x] $x]
+ removeFile x
+ set res
+} {0 PRE}
+
+test test-6.1.4 {test !exec, no label} {unixOnly} {
+ set path [makeFile {} x]
+ makeexecutable $path 0
+
+ set x PRE
+ set res [list [fileutil::test $path x x] $x]
+ removeFile x
+ set res
+} [list 0 "\"$xpath\": Is not executable"]
+
+# -------------------------------------------------------------------------
+
+rename makewritable {}
+rename makereadable {}
+rename makeexecutable {}
+catch {unset xpath}
+catch {unset path}
+catch {unset res}
+catch {unset x}
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/fileutil/traverse.man b/tcllib/modules/fileutil/traverse.man
new file mode 100644
index 0000000..971b635
--- /dev/null
+++ b/tcllib/modules/fileutil/traverse.man
@@ -0,0 +1,165 @@
+[comment {-*- text -*- doctools manpage}]
+[vset VERSION 0.6]
+[manpage_begin fileutil_traverse n [vset VERSION]]
+[keywords {directory traversal}]
+[keywords traversal]
+[moddesc {file utilities}]
+[titledesc {Iterative directory traversal}]
+[category {Programming tools}]
+[require Tcl 8.3]
+[require fileutil::traverse [opt [vset VERSION]]]
+[require fileutil]
+[require control]
+[description]
+[para]
+
+This package provides objects for the programmable traversal of
+directory hierarchies.
+
+The main command exported by the package is:
+
+[list_begin definitions]
+
+[call [cmd ::fileutil::traverse] [opt [arg objectName]] \
+ [arg path] [opt "[arg option] [arg value]..."]]
+
+The command creates a new traversal object with an associated global
+Tcl command whose name is [arg objectName]. This command may be used
+to invoke various operations on the traverser.
+
+If the string [const %AUTO%] is used as the [arg objectName] then a
+unique name will be generated by the package itself.
+
+[para]
+
+Regarding the recognized options see section [sectref OPTIONS]. Note
+that all these options can be set only during the creation of the
+traversal object. Changing them later is not possible and causes
+errors to be thrown if attempted.
+
+[para]
+
+The object command has the following general form:
+
+[list_begin definitions]
+[call [cmd \$traverser] [method command] [opt [arg "arg arg ..."]]]
+
+[arg Command] and its [arg arg]uments determine the exact behavior of
+the object.
+
+[list_end]
+[list_end]
+
+The following commands are possible for traversal objects:
+
+[list_begin definitions]
+
+[call [cmd \$traverser] [method files]]
+
+This method is the most highlevel one provided by traversal
+objects. When invoked it returns a list containing the names of all
+files and directories matching the current configuration of the
+traverser.
+
+[call [cmd \$traverser] [method foreach] [arg filevar] [arg script]]
+
+The highlevel [method files] method (see above) is based on this
+mid-level method. When invoked it finds all files and directories
+matching per the current configuration and executes the [arg script]
+for each path. The current path under consideration is stored in the
+variable named by [arg filevar]. Both variable and script live / are
+executed in the context of the caller of the method. In the method
+[method files] the script simply saves the found paths into the list
+to return.
+
+[call [cmd \$traverser] [method next] [arg filevar]]
+
+This is the lowest possible interface to the traverser, the core all
+higher methods are built on. When invoked it returns a boolean value
+indicating whether it found a path matching the current configuration
+([const True]), or not ([const False]). If a path was found it is
+stored into the variable named by [arg filevar], in the context of the
+caller.
+
+[para] The [method foreach] method simply calls this method in a loop
+until it returned [const False]. This method is exposed so that we are
+also able to incrementally traverse a directory hierarchy in an
+event-based manner.
+
+[para] Note that the traverser does follow symbolic links, except when
+doing so would cause it to enter a link-cycle. In other words, the
+command takes care to [emph not] lose itself in infinite loops upon
+encountering circular link structures. Note that even links which are
+not followed will still appear in the result.
+
+[list_end]
+
+[section OPTIONS]
+
+[list_begin options]
+[opt_def -prefilter command_prefix]
+
+This callback is executed for directories. Its result determines if
+the traverser recurses into the directory or not. The default is to
+always recurse into all directories. The callback is invoked with a
+single argument, the [emph absolute] path of the directory, and has to
+return a boolean value, [const True] when the directory passes the
+filter, and [const False] if not.
+
+[opt_def -filter command_prefix]
+
+This callback is executed for all paths. Its result determines if the
+current path is a valid result, and returned by [method next]. The
+default is to accept all paths as valid. The callback is invoked with
+a single argument, the [emph absolute] path to check, and has to
+return a boolean value, [const True] when the path passes the filter,
+and [const False] if not.
+
+[opt_def -errorcmd command_prefix]
+
+This callback is executed for all paths the traverser has trouble
+with. Like being unable to change into them, get their status,
+etc. The default is to ignore any such problems. The callback is
+invoked with a two arguments, the [emph absolute] path for which the
+error occured, and the error message. Errors thrown by the filter
+callbacks are handled through this callback too. Errors thrown by the
+error callback itself are not caught and ignored, but allowed to pass
+to the caller, i.e. however invoked the [method next]. Any other
+results from the callback are ignored.
+
+[list_end]
+
+
+[section {Warnings and Incompatibilities}]
+
+[list_begin definitions]
+
+[def [const 0.4.4]]
+In this version the traverser's broken system for handling symlinks
+was replaced with one working correctly and properly enumerating all
+the legal non-cyclic paths under a base directory.
+
+[para] While correct this means that certain pathological directory
+hierarchies with cross-linked sym-links will now take about O(n**2)
+time to enumerate whereas the original broken code managed O(n) due to
+its brokenness.
+
+[para] A concrete example and extreme case is the [file /sys]
+hierarchy under Linux where some hundred devices exist under both
+[file /sys/devices] and [file /sys/class] with the two sub-hierarchies
+linking to the other, generating millions of legal paths to enumerate.
+The structure, reduced to three devices, roughly looks like
+
+[include include/cross-index.inc]
+
+[para] When having to handle such a pathological hierarchy it is
+recommended to use the [option -prefilter] option to prevent the
+traverser from following symbolic links, like so:
+
+[include include/cross-index-trav.inc]
+
+[list_end]
+
+[vset CATEGORY fileutil]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/fileutil/traverse.tcl b/tcllib/modules/fileutil/traverse.tcl
new file mode 100644
index 0000000..c8d981f
--- /dev/null
+++ b/tcllib/modules/fileutil/traverse.tcl
@@ -0,0 +1,506 @@
+# traverse.tcl --
+#
+# Directory traversal.
+#
+# Copyright (c) 2006-2015 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: traverse.tcl,v 1.9 2012/08/29 20:42:19 andreas_kupries Exp $
+
+package require Tcl 8.3
+
+# OO core
+if {[package vsatisfies [package present Tcl] 8.5]} {
+ # Use new Tcl 8.5a6+ features to specify the allowed packages.
+ # We can use anything above 1.3. This means v2 as well.
+ package require snit 1.3-
+} else {
+ # For Tcl 8.{3,4} only snit1 of a suitable patchlevel is possible.
+ package require snit 1.3
+}
+package require control ; # Helpers for control structures
+package require fileutil ; # -> fullnormalize
+
+snit::type ::fileutil::traverse {
+
+ # Incremental directory traversal.
+
+ # API
+ # create %AUTO% basedirectory options... -> object
+ # next filevar -> boolean
+ # foreach filevar script
+ # files -> list (path ...)
+
+ # Options
+ # -prefilter command-prefix
+ # -filter command-prefix
+ # -errorcmd command-prefix
+
+ # Use cases
+ #
+ # (a) Basic incremental
+ # - Create and configure a traversal object.
+ # - Execute 'next' to retrieve one path at a time,
+ # until the command returns False, signaling that
+ # the iterator has exhausted the supply of paths.
+ # (The path is stored in the named variable).
+ #
+ # The execution of 'next' can be done in a loop, or via event
+ # processing.
+
+ # (b) Basic loop
+ # - Create and configure a traversal object.
+ # - Run a script for each path, using 'foreach'.
+ # This is a convenient standard wrapper around 'next'.
+ #
+ # The loop properly handles all possible Tcl result codes.
+
+ # (c) Non-incremental, non-looping.
+ # - Create and configure a traversal object.
+ # - Retrieve a list of all paths via 'files'.
+
+ # The -prefilter callback is executed for directories. Its result
+ # determines if the traverser recurses into the directory or not.
+ # The default is to always recurse into all directories. The call-
+ # back is invoked with a single argument, the path of the
+ # directory.
+ #
+ # The -filter callback is executed for all paths. Its result
+ # determines if the current path is a valid result, and returned
+ # by 'next'. The default is to accept all paths as valid. The
+ # callback is invoked with a single argument, the path to check.
+
+ # The -errorcmd callback is executed for all paths the traverser
+ # has trouble with. Like being unable to cd into them, get their
+ # status, etc. The default is to ignore any such problems. The
+ # callback is invoked with a two arguments, the path for which the
+ # error occured, and the error message. Errors thrown by the
+ # filter callbacks are handled through this callback too. Errors
+ # thrown by the error callback itself are not caught and ignored,
+ # but allowed to pass to the caller, usually of 'next'.
+
+ # Note: Low-level functionality, version and platform dependent is
+ # implemented in procedures, and conditioally defined for optimal
+ # use of features, etc. ...
+
+ # Note: Traversal is done in depth-first pre-order.
+
+ # Note: The options are handled only during
+ # construction. Afterward they are read-only and attempts to
+ # modify them will cause the system to throw errors.
+
+ # ### ### ### ######### ######### #########
+ ## Implementation
+
+ option -filter -default {} -readonly 1
+ option -prefilter -default {} -readonly 1
+ option -errorcmd -default {} -readonly 1
+
+ constructor {basedir args} {
+ set _base $basedir
+ $self configurelist $args
+ return
+ }
+
+ method files {} {
+ set files {}
+ $self foreach f {lappend files $f}
+ return $files
+ }
+
+ method foreach {fvar body} {
+ upvar 1 $fvar currentfile
+
+ # (Re-)initialize the traversal state on every call.
+ $self Init
+
+ while {[$self next currentfile]} {
+ set code [catch {uplevel 1 $body} result]
+
+ # decide what to do upon the return code:
+ #
+ # 0 - the body executed successfully
+ # 1 - the body raised an error
+ # 2 - the body invoked [return]
+ # 3 - the body invoked [break]
+ # 4 - the body invoked [continue]
+ # everything else - return and pass on the results
+ #
+ switch -exact -- $code {
+ 0 {}
+ 1 {
+ return -errorinfo [::control::ErrorInfoAsCaller uplevel foreach] \
+ -errorcode $::errorCode -code error $result
+ }
+ 3 {
+ # FRINK: nocheck
+ return
+ }
+ 4 {}
+ default {
+ return -code $code $result
+ }
+ }
+ }
+ return
+ }
+
+ method next {fvar} {
+ upvar 1 $fvar currentfile
+
+ # Initialize on first call.
+ if {!$_init} {
+ $self Init
+ }
+
+ # We (still) have valid paths in the result stack, return the
+ # next one.
+
+ if {[llength $_results]} {
+ set top [lindex $_results end]
+ set _results [lreplace $_results end end]
+ set currentfile $top
+ return 1
+ }
+
+ # Take the next directory waiting in the processing stack and
+ # fill the result stack with all valid files and sub-
+ # directories contained in it. Extend the processing queue
+ # with all sub-directories not yet seen already (!circular
+ # symlinks) and accepted by the prefilter. We stop iterating
+ # when we either have no directories to process anymore, or
+ # the result stack contains at least one path we can return.
+
+ while {[llength $_pending]} {
+ set top [lindex $_pending end]
+ set _pending [lreplace $_pending end end]
+
+ # Directory accessible? Skip if not.
+ if {![ACCESS $top]} {
+ Error $top "Inacessible directory"
+ continue
+ }
+
+ # Expand the result stack with all files in the directory,
+ # modulo filtering.
+
+ foreach f [GLOBF $top] {
+ if {![Valid $f]} continue
+ lappend _results $f
+ }
+
+ # Expand the result stack with all sub-directories in the
+ # directory, modulo filtering. Further expand the
+ # processing stack with the same directories, if not seen
+ # yet and modulo pre-filtering.
+
+ foreach f [GLOBD $top] {
+ if {
+ [string equal [file tail $f] "."] ||
+ [string equal [file tail $f] ".."]
+ } continue
+
+ if {[Valid $f]} {
+ lappend _results $f
+ }
+
+ Enter $top $f
+ if {[Cycle $f]} continue
+
+ if {[Recurse $f]} {
+ lappend _pending $f
+ }
+ }
+
+ # Stop expanding if we have paths to return.
+
+ if {[llength $_results]} {
+ set top [lindex $_results end]
+ set _results [lreplace $_results end end]
+ set currentfile $top
+ return 1
+ }
+ }
+
+ # Allow re-initialization with next call.
+
+ set _init 0
+ return 0
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Traversal state
+
+ # * Initialization flag. Checked in 'next', reset by next when no
+ # more files are available. Set in 'Init'.
+ # * Base directory (or file) to start the traversal from.
+ # * Stack of prefiltered unknown directories waiting for
+ # processing, i.e. expansion (TOP at end).
+ # * Stack of valid paths waiting to be returned as results.
+ # * Set of directories already visited (normalized paths), for
+ # detection of circular symbolic links.
+
+ variable _init 0 ; # Initialization flag.
+ variable _base {} ; # Base directory.
+ variable _pending {} ; # Processing stack.
+ variable _results {} ; # Result stack.
+
+ # sym link handling (to break cycles, while allowing the following of non-cycle links).
+ # Notes
+ # - path parent tracking is lexical.
+ # - path identity tracking is based on the normalized path, i.e. the path with all
+ # symlinks resolved.
+ # Maps
+ # - path -> parent (easier to follow the list than doing dirname's)
+ # - path -> normalized (cache to avoid redundant calls of fullnormalize)
+ # cycle <=> A parent's normalized form (NF) is identical to the current path's NF
+
+ variable _parent -array {}
+ variable _norm -array {}
+
+ # ### ### ### ######### ######### #########
+ ## Internal helpers.
+
+ proc Enter {parent path} {
+ #puts ___E|$path
+ upvar 1 _parent _parent _norm _norm
+ set _parent($path) $parent
+ set _norm($path) [fileutil::fullnormalize $path]
+ }
+
+ proc Cycle {path} {
+ upvar 1 _parent _parent _norm _norm
+ set nform $_norm($path)
+ set paren $_parent($path)
+ while {$paren ne {}} {
+ if {$_norm($paren) eq $nform} { return yes }
+ set paren $_parent($paren)
+ }
+ return no
+ }
+
+ method Init {} {
+ array unset _parent *
+ array unset _norm *
+
+ # Path ok as result?
+ if {[Valid $_base]} {
+ lappend _results $_base
+ }
+
+ # Expansion allowed by prefilter?
+ if {[file isdirectory $_base] && [Recurse $_base]} {
+ Enter {} $_base
+ lappend _pending $_base
+ }
+
+ # System is set up now.
+ set _init 1
+ return
+ }
+
+ proc Valid {path} {
+ #puts ___V|$path
+ upvar 1 options options
+ if {![llength $options(-filter)]} {return 1}
+ set path [file normalize $path]
+ set code [catch {uplevel \#0 [linsert $options(-filter) end $path]} valid]
+ if {!$code} {return $valid}
+ Error $path $valid
+ return 0
+ }
+
+ proc Recurse {path} {
+ #puts ___X|$path
+ upvar 1 options options _norm _norm
+ if {![llength $options(-prefilter)]} {return 1}
+ set path [file normalize $path]
+ set code [catch {uplevel \#0 [linsert $options(-prefilter) end $path]} valid]
+ if {!$code} {return $valid}
+ Error $path $valid
+ return 0
+ }
+
+ proc Error {path msg} {
+ upvar 1 options options
+ if {![llength $options(-errorcmd)]} return
+ set path [file normalize $path]
+ uplevel \#0 [linsert $options(-errorcmd) end $path $msg]
+ return
+ }
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+##
+
+# The next three helper commands for the traverser depend strongly on
+# the version of Tcl, and partially on the platform.
+
+# 1. In Tcl 8.3 using -types f will return only true files, but not
+# links to files. This changed in 8.4+ where links to files are
+# returned as well. So for 8.3 we have to handle the links
+# separately (-types l) and also filter on our own.
+# Note that Windows file links are hard links which are reported by
+# -types f, but not -types l, so we can optimize that for the two
+# platforms.
+#
+# 2. In Tcl 8.3 we also have a crashing bug in glob (SIGABRT, "stat on
+# a known file") when trying to perform 'glob -types {hidden f}' on
+# a directory without e'x'ecute permissions. We code around by
+# testing if we can cd into the directory (stat might return enough
+# information too (mode), but possibly also not portable).
+#
+# For Tcl 8.2 and 8.4+ glob simply delivers an empty result
+# (-nocomplain), without crashing. For them this command is defined
+# so that the bytecode compiler removes it from the bytecode.
+#
+# This bug made the ACCESS helper necessary.
+# We code around the problem by testing if we can cd into the
+# directory (stat might return enough information too (mode), but
+# possibly also not portable).
+
+if {[package vsatisfies [package present Tcl] 8.5]} {
+ # Tcl 8.5+.
+ # We have to check readability of "current" on our own, glob
+ # changed to error out instead of returning nothing.
+
+ proc ::fileutil::traverse::ACCESS {args} {return 1}
+
+ proc ::fileutil::traverse::GLOBF {current} {
+ if {![file readable $current] ||
+ [BadLink $current]} {
+ return {}
+ }
+
+ set res [lsort -unique [concat \
+ [glob -nocomplain -directory $current -types f -- *] \
+ [glob -nocomplain -directory $current -types {hidden f} -- *]]]
+
+ # Look for broken links (They are reported as neither file nor directory).
+ foreach l [lsort -unique [concat \
+ [glob -nocomplain -directory $current -types l -- *] \
+ [glob -nocomplain -directory $current -types {hidden l} -- *]]] {
+ if {[file isfile $l]} continue
+ if {[file isdirectory $l]} continue
+ lappend res $l
+ }
+ return [lsort -unique $res]
+ }
+
+ proc ::fileutil::traverse::GLOBD {current} {
+ if {![file readable $current] ||
+ [BadLink $current]} {
+ return {}
+ }
+
+ lsort -unique [concat \
+ [glob -nocomplain -directory $current -types d -- *] \
+ [glob -nocomplain -directory $current -types {hidden d} -- *]]
+ }
+
+ proc ::fileutil::traverse::BadLink {current} {
+ if {[file type $current] ne "link"} { return no }
+
+ set dst [file join [file dirname $current] [file readlink $current]]
+
+ if {![file exists $dst] ||
+ ![file readable $dst]} {
+ return yes
+ }
+
+ return no
+ }
+
+} elseif {[package vsatisfies [package present Tcl] 8.4]} {
+ # Tcl 8.4+.
+ # (Ad 1) We have -directory, and -types,
+ # (Ad 2) Links are returned for -types f/d if they refer to files/dirs.
+ # (Ad 3) No bug to code around
+
+ proc ::fileutil::traverse::ACCESS {args} {return 1}
+
+ proc ::fileutil::traverse::GLOBF {current} {
+ set res [concat \
+ [glob -nocomplain -directory $current -types f -- *] \
+ [glob -nocomplain -directory $current -types {hidden f} -- *]]
+
+ # Look for broken links (They are reported as neither file nor directory).
+ foreach l [concat \
+ [glob -nocomplain -directory $current -types l -- *] \
+ [glob -nocomplain -directory $current -types {hidden l} -- *] ] {
+ if {[file isfile $l]} continue
+ if {[file isdirectory $l]} continue
+ lappend res $l
+ }
+ return $res
+ }
+
+ proc ::fileutil::traverse::GLOBD {current} {
+ concat \
+ [glob -nocomplain -directory $current -types d -- *] \
+ [glob -nocomplain -directory $current -types {hidden d} -- *]
+ }
+
+} else {
+ # 8.3.
+ # (Ad 1) We have -directory, and -types,
+ # (Ad 2) Links are NOT returned for -types f/d, collect separately.
+ # No symbolic file links on Windows.
+ # (Ad 3) Bug to code around.
+
+ proc ::fileutil::traverse::ACCESS {current} {
+ if {[catch {
+ set h [pwd] ; cd $current ; cd $h
+ }]} {return 0}
+ return 1
+ }
+
+ if {[string equal $::tcl_platform(platform) windows]} {
+ proc ::fileutil::traverse::GLOBF {current} {
+ concat \
+ [glob -nocomplain -directory $current -types f -- *] \
+ [glob -nocomplain -directory $current -types {hidden f} -- *]]
+ }
+ } else {
+ proc ::fileutil::traverse::GLOBF {current} {
+ set l [concat \
+ [glob -nocomplain -directory $current -types f -- *] \
+ [glob -nocomplain -directory $current -types {hidden f} -- *]]
+
+ foreach x [concat \
+ [glob -nocomplain -directory $current -types l -- *] \
+ [glob -nocomplain -directory $current -types {hidden l} -- *]] {
+ if {[file isdirectory $x]} continue
+ # We have now accepted files, links to files, and broken links.
+ lappend l $x
+ }
+
+ return $l
+ }
+ }
+
+ proc ::fileutil::traverse::GLOBD {current} {
+ set l [concat \
+ [glob -nocomplain -directory $current -types d -- *] \
+ [glob -nocomplain -directory $current -types {hidden d} -- *]]
+
+ foreach x [concat \
+ [glob -nocomplain -directory $current -types l -- *] \
+ [glob -nocomplain -directory $current -types {hidden l} -- *]] {
+ if {![file isdirectory $x]} continue
+ lappend l $x
+ }
+
+ return $l
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide fileutil::traverse 0.6
diff --git a/tcllib/modules/fileutil/traverse.test b/tcllib/modules/fileutil/traverse.test
new file mode 100644
index 0000000..c7e5694
--- /dev/null
+++ b/tcllib/modules/fileutil/traverse.test
@@ -0,0 +1,499 @@
+# -*- tcl -*-
+# Tests for the find function.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2007-2015 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: traverse.test,v 1.3 2012/08/29 20:42:19 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.3
+testsNeedTcltest 2.1
+
+support {
+ use control/control.tcl control
+ use snit/snit.tcl snit
+
+ useLocalFile find.setup
+}
+testing {
+ useLocal traverse.tcl fileutil::traverse
+}
+
+# -------------------------------------------------------------------------
+# Filters commands to record which callbacks were run.
+
+proc rec {x} {
+ lappend ::rec $x
+ return 1
+}
+
+proc recx {args} {
+ lappend ::rec $args
+ return 1
+}
+
+# -------------------------------------------------------------------------
+
+test traverse-1.0.0 {Traverse result, circular links, unix} -setup {
+ f_setupcircle
+ set t [fileutil::traverse %AUTO% [tempPath {find 1}]]
+} -constraints unix -body {
+ lsort [$t files]
+} -cleanup {
+ $t destroy
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}] \
+ [tempPath {find 1/find 2/file 3}] \
+ [tempPath {find 1/find 2/file* 2}]]
+
+test traverse-1.0.1 {Traverse result, circular links, windows, 8.4+} -setup {
+ f_setupcircle
+ set t [fileutil::traverse %AUTO% [tempPath {find 1}]]
+} -constraints {win tcl8.4plus} -body {
+ lsort [$t files]
+} -cleanup {
+ $t destroy
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}] \
+ [tempPath {find 1/find 2/file 3}]]
+
+test traverse-1.0.2 {Traverse result, unix} -setup {
+ f_setup
+ set t [fileutil::traverse %AUTO% [tempPath {find 1}]]
+} -constraints unix -body {
+ lsort [$t files]
+} -cleanup {
+ $t destroy
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}] \
+ [tempPath {find 1/find 2/file* 2}]]
+
+test traverse-1.0.3 {Traverse result, windows} -setup {
+ f_setup
+ set t [fileutil::traverse %AUTO% [tempPath {find 1}]]
+} -constraints win -body {
+ lsort [$t files]
+} -cleanup {
+ $t destroy
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}]]
+
+# Find has to skip '{file 3}', in the sense that the path should be in
+# the output, but it cannot be expanded further, being a broken
+# link. Two tests, one for all versions of Tcl (8.2+), but only unix,
+# and one for windows, restricted to Tcl 8.4+.
+
+test traverse-1.0.4 {Traverse result, broken links, unix} -setup {
+ f_setupbroken
+ set t [fileutil::traverse %AUTO% [tempPath {find 1}]]
+} -constraints unix -body {
+ lsort [$t files]
+} -cleanup {
+ $t destroy
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}] \
+ [tempPath {find 1/find 2/file 3}] \
+ [tempPath {find 1/find 2/file* 2}]]
+
+test traverse-1.0.5 {Traverse result, broken links, windows, 8.4+} -setup {
+ f_setupbroken
+ set t [fileutil::traverse %AUTO% [tempPath {find 1}]]
+} -constraints {win tcl8.4plus} -body {
+ lsort [$t files]
+} -cleanup {
+ $t destroy
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}] \
+ [tempPath {find 1/find 2/file 3}]]
+
+
+test traverse-1.0.6 {Traverse result, circular links to base, unix} -setup {
+ f_setupcircle2
+ set t [fileutil::traverse %AUTO% [tempPath {find 1}]]
+} -constraints unix -body {
+ lsort [$t files]
+} -cleanup {
+ $t destroy
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}] \
+ [tempPath {find 1/find 2/file 3}] \
+ [tempPath {find 1/find 2/file* 2}]]
+
+# -------------------------------------------------------------------------
+
+test traverse-1.1.0 {Traverse filter execution, circular links, unix} -setup {
+ f_setupcircle
+ set rec {}
+ set t [fileutil::traverse %AUTO% [tempPath {find 1}] -filter ::rec]
+} -constraints unix -body {
+ $t files
+ lsort $rec
+} -cleanup {
+ $t destroy
+ unset rec
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}] \
+ [tempPath {find 1/find 2/file 3}] \
+ [tempPath {find 1/find 2/file* 2}]]
+
+test traverse-1.1.1 {Traverse filter execution, circular links, windows, 8.4+} -setup {
+ f_setupcircle
+ set rec {}
+ set t [fileutil::traverse %AUTO% [tempPath {find 1}] -filter ::rec]
+} -constraints {win tcl8.4plus} -body {
+ $t files
+ lsort $rec
+} -cleanup {
+ $t destroy
+ unset rec
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}] \
+ [tempPath {find 1/find 2/file 3}]]
+
+test traverse-1.1.2 {Traverse filter execution, unix} -setup {
+ f_setup
+ set rec {}
+ set t [fileutil::traverse %AUTO% [tempPath {find 1}] -filter ::rec]
+} -constraints unix -body {
+ $t files
+ lsort $rec
+} -cleanup {
+ $t destroy
+ unset rec
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}] \
+ [tempPath {find 1/find 2/file* 2}]]
+
+test traverse-1.1.3 {Traverse filter execution, windows} -setup {
+ f_setup
+ set rec {}
+ set t [fileutil::traverse %AUTO% [tempPath {find 1}] -filter ::rec]
+} -constraints win -body {
+ $t files
+ lsort $rec
+} -cleanup {
+ $t destroy
+ unset rec
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}]]
+
+# -------------------------------------------------------------------------
+
+test traverse-1.2.0 {Traverse prefilter execution, unix} -setup {
+ f_setupcircle
+ set rec {}
+ set t [fileutil::traverse %AUTO% [tempPath {find 1}] -prefilter ::rec]
+} -constraints unix -body {
+ $t files
+ lsort $rec
+ # Note: The link 'file 3' is _not_ run through the pre-filter,
+ # because it is filtered out as already seen before it comes to
+ # the pre-filter stage.
+} -cleanup {
+ $t destroy
+ unset rec
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/find 2}]]
+
+test traverse-1.2.1 {Traverse prefilter execution, windows, 8.4+} -setup {
+ f_setupcircle
+ set rec {}
+ set t [fileutil::traverse %AUTO% [tempPath {find 1}] -prefilter ::rec]
+} -constraints {win tcl8.4plus} -body {
+ $t files
+ lsort $rec
+ # Note: The link 'file 3' is _not_ run through the pre-filter,
+ # because it is filtered out as already seen before it comes to
+ # the pre-filter stage.
+} -cleanup {
+ $t destroy
+ unset rec
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/find 2}]]
+
+test traverse-1.2.2 {Traverse prefilter execution, all platforms} -setup {
+ f_setup
+ set rec {}
+ set t [fileutil::traverse %AUTO% [tempPath {find 1}] -prefilter ::rec]
+} -body {
+ $t files
+ lsort $rec
+} -cleanup {
+ $t destroy
+ unset rec
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/find 2}]]
+
+# -------------------------------------------------------------------------
+
+test traverse-1.3.0 {Traverse error execution, unix, 8.4+} -setup {
+ f_setupnostat
+ set rec {}
+ set t [fileutil::traverse %AUTO% [tempPath find3] -errorcmd ::recx]
+} -constraints {unix tcl8.4plus} -body {
+ $t files
+ lsort $rec
+} -cleanup {
+ $t destroy
+ unset rec
+ f_cleanupnostat
+} -result {}
+
+test traverse-1.3.1 {Traverse error execution, unix, 8.3} -setup {
+ f_setupnostat
+ set rec {}
+ set t [fileutil::traverse %AUTO% [tempPath find3] -errorcmd ::recx]
+} -constraints {unix tcl8.3only} -body {
+ $t files
+ lsort $rec
+} -cleanup {
+ $t destroy
+ unset rec
+ f_cleanupnostat
+} -result [list [list [tempPath find3/find4] {Inacessible directory}]]
+
+# traverse 1.3.x - error callback, all platforms - Not possible. We have
+# no win32 setup code for non-readable/non-accessible directories.
+
+# -------------------------------------------------------------------------
+
+test traverse-1.4.0 {Traverse result, circular links, unix} -setup {
+ f_setupcircle3
+ set t [fileutil::traverse %AUTO% [tempPath z]]
+} -constraints unix -body {
+ join [lsort [$t files]] \n
+} -cleanup {
+ $t destroy
+ f_cleanup3
+} -result [join [pathmap \
+ z z/a z/a/c z/a/c/g z/a/c/h z/a/c/h/e z/a/c/h/f \
+ z/a/c/i z/a/d z/b z/b/e z/b/e/g z/b/e/g/c z/b/e/g/d \
+ z/b/e/h z/b/e/i z/b/f] \n]
+
+test traverse-1.4.1 {Traverse result, circular links, windows, 8.4+} -setup {
+ f_setupcircle3
+ set t [fileutil::traverse %AUTO% [tempPath z]]
+} -constraints {win tcl8.4plus} -body {
+ join [lsort [$t files]] \n
+} -cleanup {
+ $t destroy
+ f_cleanup3
+} -result [join [pathmap \
+ z z/a z/a/c z/a/c/g z/a/c/h z/a/c/h/e z/a/c/h/f \
+ z/a/c/i z/a/d z/b z/b/e z/b/e/g z/b/e/g/c z/b/e/g/d \
+ z/b/e/h z/b/e/i z/b/f] \n]
+
+# -------------------------------------------------------------------------
+
+test traverse-1.5 {Traverse, relative base path, callback API} -setup {
+ f_setupcircle
+ set rec {}
+
+ set base [tempPath {find 1}]
+ set bdir [file dirname $base]
+ set base [file tail $base]
+ set here [pwd]
+ cd $bdir
+ set t [fileutil::traverse %AUTO% $base -filter ::rec]
+} -constraints unix -body {
+ $t files
+ lsort $rec
+} -cleanup {
+ $t destroy
+ cd $here
+ unset rec bdir base here
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/file [1]}] \
+ [tempPath {find 1/find 2}] \
+ [tempPath {find 1/find 2/file 3}] \
+ [tempPath {find 1/find 2/file* 2}]]
+
+test traverse-1.6 {Traverse, relative base path, callback API} -setup {
+ f_setupcircle
+ set rec {}
+
+ set base [tempPath {find 1}]
+ set bdir [file dirname $base]
+ set base [file tail $base]
+ set here [pwd]
+ cd $bdir
+ set t [fileutil::traverse %AUTO% $base -prefilter ::rec]
+} -constraints unix -body {
+ $t files
+ lsort $rec
+} -cleanup {
+ $t destroy
+ cd $here
+ unset rec bdir base here
+ f_cleanup
+} -result [list \
+ [tempPath {find 1}] \
+ [tempPath {find 1/find 2}]]
+
+# TODO: checking -error callback with ingoing relative basepath.
+
+# -------------------------------------------------------------------------
+
+test traverse-2.0 {Traverse pathological circularity, unix} -setup {
+ f_setup_crossindex
+ set t [fileutil::traverse %AUTO% [tempPath s]]
+} -constraints unix -body {
+ join [lsort -dict [$t files]] \n
+} -cleanup {
+ $t destroy
+ f_cleanup_crossindex
+} -result [join [pathmap \
+ s \
+ s/c \
+ s/c/t \
+ s/c/t/t0 \
+ s/c/t/t0/b \
+ s/c/t/t0/s \
+ s/c/t/t1 \
+ s/c/t/t1/b \
+ s/c/t/t1/s \
+ s/c/t/t2 \
+ s/c/t/t2/b \
+ s/c/t/t2/s \
+ s/d \
+ s/d/t0 \
+ s/d/t0/b \
+ s/d/t0/s \
+ s/d/t0/s/t0 \
+ s/d/t0/s/t1 \
+ s/d/t0/s/t1/b \
+ s/d/t0/s/t1/s \
+ s/d/t0/s/t2 \
+ s/d/t0/s/t2/b \
+ s/d/t0/s/t2/s \
+ s/d/t1 \
+ s/d/t1/b \
+ s/d/t1/s \
+ s/d/t1/s/t0 \
+ s/d/t1/s/t0/b \
+ s/d/t1/s/t0/s \
+ s/d/t1/s/t1 \
+ s/d/t1/s/t2 \
+ s/d/t1/s/t2/b \
+ s/d/t1/s/t2/s \
+ s/d/t2 \
+ s/d/t2/b \
+ s/d/t2/s \
+ s/d/t2/s/t0 \
+ s/d/t2/s/t0/b \
+ s/d/t2/s/t0/s \
+ s/d/t2/s/t1 \
+ s/d/t2/s/t1/b \
+ s/d/t2/s/t1/s \
+ s/d/t2/s/t2 \
+ ] \n]
+
+test traverse-2.1 {Traverse pathological circularity, windows, 8.4+} -setup {
+ f_setup_crossindex
+ set t [fileutil::traverse %AUTO% [tempPath s]]
+} -constraints {win tcl8.4plus} -body {
+ join [lsort -dict [$t files]] \n
+} -cleanup {
+ $t destroy
+ f_cleanup_crossindex
+} -result [join [pathmap \
+ s \
+ s/c \
+ s/c/t \
+ s/c/t/t0 \
+ s/c/t/t0/b \
+ s/c/t/t0/s \
+ s/c/t/t1 \
+ s/c/t/t1/b \
+ s/c/t/t1/s \
+ s/c/t/t2 \
+ s/c/t/t2/b \
+ s/c/t/t2/s \
+ s/d \
+ s/d/t0 \
+ s/d/t0/b \
+ s/d/t0/s \
+ s/d/t0/s/t0 \
+ s/d/t0/s/t1 \
+ s/d/t0/s/t1/b \
+ s/d/t0/s/t1/s \
+ s/d/t0/s/t2 \
+ s/d/t0/s/t2/b \
+ s/d/t0/s/t2/s \
+ s/d/t1 \
+ s/d/t1/b \
+ s/d/t1/s \
+ s/d/t1/s/t0 \
+ s/d/t1/s/t0/b \
+ s/d/t1/s/t0/s \
+ s/d/t1/s/t1 \
+ s/d/t1/s/t2 \
+ s/d/t1/s/t2/b \
+ s/d/t1/s/t2/s \
+ s/d/t2 \
+ s/d/t2/b \
+ s/d/t2/s \
+ s/d/t2/s/t0 \
+ s/d/t2/s/t0/b \
+ s/d/t2/s/t0/s \
+ s/d/t2/s/t1 \
+ s/d/t2/s/t1/b \
+ s/d/t2/s/t1/s \
+ s/d/t2/s/t2 \
+ ] \n]
+
+# -------------------------------------------------------------------------
+
+f_cleanall
+testsuiteCleanup
+return
diff --git a/tcllib/modules/ftp/ChangeLog b/tcllib/modules/ftp/ChangeLog
new file mode 100644
index 0000000..ff11511
--- /dev/null
+++ b/tcllib/modules/ftp/ChangeLog
@@ -0,0 +1,621 @@
+2013-03-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * rfc959.txt: Removed copies of RFC documents. Keep only links.
+ * std9.txt:
+
+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-08-09 Andreas Kupries <andreask@activestate.com>
+
+ * ftp.man: Bumped version to 2.4.11.
+ * ftp.tcl:
+ * pkgIndex.tcl:
+
+ * ftp.tcl (::ftp::OpenActiveConn, ::ftp::OpenControlConn):
+ [Bug 3325112]: Accepted patch by Alexandre Ferrieux
+ <ferrieux@users.sourceforge.net> reducing the number of reverse
+ DNS lookups.
+
+2011-04-18 Andreas Kupries <andreask@activestate.com>
+
+ * ftp.tcl (::ftp::__ftp_ls): [Bug 3288793]: Fixed ftp::List
+ variant used by Tkcon, to not only print the result, but
+ continue returning it as well, for non-interactive use. Thanks
+ to Pedro <proteco@users.sourceforge.net>
+
+ * ftp.tcl (::ftp::StateHandler): [Bug 3288977]: Fixed handling of
+ multi-line replies which are not strictly RFC 959. Thanks to
+ Shaun Zinck <szinck@users.sourceforge.net>. This partially fixes
+ [Bug 2813069].
+
+ * pkgIndex.tcl: Bumped version to 2.4.10.
+ * ftp.man:
+
+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 ========================
+ *
+
+2008-08-05 Andreas Kupries <andreask@activestate.com>
+
+ * ftp.tcl: Fixed [Bug 2038279], a creative-writing problem.
+ * ftp.man: Bumped package version to 2.4.9.
+ * pkgIndex.tcl:
+
+2008-03-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftp_geturl.man: Separated the documentation of the ftp and
+ * ftp.man: ftp::geturl packages into two files.
+
+2007-09-13 Andreas Kupries <andreask@activestate.com>
+
+ * ftp_geturl.tcl (::ftp::geturl): Fixed the handling of urls which
+ * pkgIndex.tcl: are directories instead of files, per the patch
+ * ftp.man: coming with [SF Tcllib Bug 1793855], suggested by
+ Gerald Lester. Bumped version of ftp::geturl to 0.2.1.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-05-07 Andreas Kupries <andreask@activestate.com>
+
+ * ftp.tcl (::ftp::Get): SF Bug 1708350. Do not unset get:channel
+ * pkgIndex.tcl: state information to prevent async get from
+ * ftp.man: blowing in HandleData. More comments in the
+ code. Version bumped to 2.4.8.
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftp.man: Fixed all warnings due to use of now deprecated
+ commands. Added a section about how to give feedback.
+
+2006-11-09 Andreas Kupries <andreask@activestate.com>
+
+ * ftp.tcl (::ftp::StateHandler): Fixed [Bug 1191607] using the
+ * ftp.man: minimum possible change. Exporting information
+ * pkgIndex.tcl: accumulated in buffer to msgtext. Version is
+ now 2.4.7.
+
+2006-10-23 Andreas Kupries <andreask@activestate.com>
+
+ * ftp.tcl (::ftp::StateHandler): Applied patch by Guy Hofkens
+ * ftp.man: <hofkensg@users.sourceforge.net>, with small
+ * pkgIndex.tcl: modification by myself (removing a no-op), for
+ [SF Tcllib Bug 15822535], reported by same person, fixing an
+ infinite recursion through vwait because the ctrl socket at eof
+ is not closed and immediately waited upon again for more
+ events. Version now 2.4.6.
+
+2006-10-20 Andreas Kupries <andreask@activestate.com>
+
+ * ftp.tcl: Wrapped several 'unset ftp(state.data)' into 'catch'
+ * ftp.man: as the state-logic apparently is able to run several
+ * pkgIndex.tcl: of them multiple times in exceptional situations
+ (i.e. ftp errors). This should fix both [SF Tcllib Bug 1234831]
+ and [SF Tcllib Bug 1581453]. Version now 2.4.5. Thanks to
+ <goodegod@users.sourceforge.net> who tracked this down.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-22 Andreas Kupries <andreask@activestate.com>
+
+ * ftp.tcl (::ftp::NList): Fixed [SF Tcllib Bug 1563137] using the
+ * ftp.man: patch submitted by Keith Vetter
+ * pkgIndex.tcl: <keithv@users.sourceforge.net> as part of his
+ report. Bumped version to 2.4.4 See also the duplicate entry
+ [SF Tcllib Bug 1553919]. And also [SF Tcllib Bug 748758].
+
+2006-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * ftp.man: Bumped version to 2.4.3
+ * ftp.tcl:
+ * pkgIndex.tcl:
+
+2006-06-13 Andreas Kupries <andreask@activestate.com>
+
+ * ftp.tcl (::ftp::StateHandler): Replaced use of 8.4ism (expr 'ne'
+ operator) with appropriate invokation of 'string equal'. This
+ fixes [SF Tcllib Bug 1429377], reported by John Mercogliano III.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-02-14 Andreas Kupries <andreask@activestate.com>
+
+ * ftp.tcl (::ftp::StateHandler): Accepted patch by Keith Vetter
+ <keithv@users.sourceforge.net> for [SF Tcllib Bug 1076923], also
+ reported by him. This fixes a race condition where the client
+ has sent QUIT and is waiting for response, but gets the socket
+ closed without any.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-12-01 Andreas Kupries <andreask@activestate.com>
+
+ * ftp.tcl (ftp::StateHandler): See last entry. The condition to
+ invoke a report for a failure of the regex was wrong, and
+ missing a negation. Fixed this. Also cleaned up the regexp, it
+ had a caret to much in it. Thanks to <nafis@crd.ge.com> for
+ reporting this. The bug report is at -->
+ http://bugs.activestate.com/show_bug.cgi?id=28433, and not on
+ SourceForge.
+
+2003-10-21 Andreas Kupries <andreask@activestate.com>
+
+ * ftp.tcl (ftp::StateHandler): Accepted change to the regexp
+ pattern to handle irregular input better. [Bug 739393]. Also
+ added code to handle future regex failures better.
+
+2003-07-28 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * ftp.tcl: fixed bug #753770, added verbose flag check in
+ ElapsedTime.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * ftp.tcl:
+ * ftp.man:
+ * ftp_geturl.tcl:
+ * pkgIndex.tcl: Fixed bug #614591. Set version of the package to
+ to 2.4. Set version of geturl package to 0.2.
+
+2003-03-31 Andreas Kupries <andreask@activestate.com>
+
+ * ftp.tcl (ModTime): Applied patch #659238 supplied by Dan Rogahn
+ <ddrogahn@users.sourceforge.net> to allow setting the
+ modification time of a file, assuming the server allows this as
+ well.
+
+2003-03-18 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * ftp.tcl (ftp::InitDataConn): revert -regexp to fix bug 701288.
+
+2003-02-24 David N. Welton <davidw@dedasys.com>
+
+ * ftp.tcl (ftp::OpenControlConn): Use string map instead of
+ regsub.
+
+2003-01-28 David N. Welton <davidw@dedasys.com>
+
+ * ftp.tcl (ftp::InitDataConn): Use 'string match' instead of
+ regexp.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftp.man: More semantic markup, less visual one.
+
+2002-08-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * examples (hpupdate.tcl): Updated 'info exist' to 'info exists'.
+
+2002-08-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpdemo.tcl (Examples): Changed ftp.tcl to ftpdemo.tcl in
+ [test_40afile] and [test_70append]. Problem found and reported
+ by Jussi Kuosa <Jussi.Kuosa@tellabs.com>.
+
+2002-08-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftp.tcl: Fixed SF Bug #582668, reported by Frank Richter
+ <frari@users.sourceforge.net>.
+
+2002-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftp.man: New, doctools manpage.
+
+2002-02-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftp.tcl: Frink run.
+
+ * ftp: Version is now 2.3.1 to distinguish this from the code in
+ tcllib release 1.2
+
+2002-01-26 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * ftp_geturl.tcl: Re-opened FR #476804 to add support for
+ username and password and for non-unix based FTP servers.
+
+2002-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bumped version to 2.3
+
+2002-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftp.tcl: Fix for bug #503471. The commands Get, Reget, and Newer
+ now check if the directory the local file is to be placed in
+ does exist. They now immediately throw an error if the directory
+ does not exist instead of starting the download and getting
+ confused.
+
+ * ftp.n: Typo fix. Updates in the descriptions of Get, Reget, and
+ Newer explaining the new behaviour, s.a.
+
+2001-11-20 Joe English <jenglish@users.sourceforge.net>
+
+ * ftp.n: (r1.6 -> r1.8) Update for bug report #474999
+ "ftp man page description typo" -- attempt to clarify
+ description of "ftp::List" command. Also fixed minor
+ markup errors.
+
+2001-11-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftp.tcl: Tested implementation of FR #481161. Fixed the errors
+ found that way (incomplete cleanup by 'Get', interfered with the
+ following 'Put' command).
+
+2001-11-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftp.tcl, ftp.n: Implemented and documented FR #481161.
+
+ * ftp.tcl: Applied patch #428053 provided by Sreangsu Acharyya
+ <srean_list@myrealbox.com>. The patch extends 'Reget' to allow
+ download of an exactly specified slice of the the source
+ file. This enables the implementation of a 'resume' after a
+ partial download and also the parallel download of
+ non-overlaping parts of the same file from different servers.
+
+ * ftp.n: updated documentation to cover the new code above and
+ below.
+
+ * ftp_geturl.tcl: New file, provides a geturl command for use by
+ uri. Declared in a separate package to avoid a cyclic dependency
+ between the ftp and uri packages. The uri package is changed to
+ try for a scheme::geturl package first and then for a scheme
+ package to get the desired functionality. Implements FR #476804.
+
+2001-11-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftp.tcl: Applied patch in #478478 to handle non-standard date
+ information from servers with a buggy y2k patch. 2001 is
+ rendered as 19101 (19*100 + 101 = 2001).
+
+2001-11-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftp.n: Updated description of DisplayMsg to the changed
+ behaviour and added a discussion of what happens should it throw
+ errors. Also added a description of option -output to the
+ description of ftp::Open.
+
+ * ftp.tcl: Fixed bug #476729. Instead of describing the behaviour
+ of the default 'DisplayMsg' the procedure is changed instead to
+ throw no errors, and to use the log module of tcllib. Thanks to
+ Larry Virden <lvirden@users.sourceforge.net> for pointing out
+ the deficiencies in the documentation.
+
+2001-10-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftp.tcl: Fixed bug #466746. Reporter of bug unknown, provided
+ fix too. Problem was incomplete handling of [gets] return
+ values. Value -1 signaling an incomplete line was not handled.
+
+2001-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftp.n:
+ * ftp.tcl:
+ * pkgIndex.tcl: Version up to 2.2.1.
+
+2001-09-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * example/hpupdate.tcl: Some cleanups in the example code,
+ provided by Larry Virden <lvirden@users.sourceforge.net>. This
+ fixes [440064].
+
+2001-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Added manpages for ftp package.
+
+2001-08-01 Don Porter <dgp@users.sourceforge.net>
+
+ * example/hpupdate.tcl: Workaround for moving Tk internal
+ command [tkButtonInvoke]. [Bug 450914]
+
+2001-08-01 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * ftp.tcl: added eval in ftp::List wrapper when used in tkcon.
+ [Bug: #439779] (loring)
+
+2001-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftp.tcl: Frink 2.2 run, fixed dubious code.
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpdemo.tcl:
+ * ftp.tcl: Fixed dubious code reported by frink.
+
+2000-10-01 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * ftp.tcl: Moved the call to 'DisplayMsg' from inside of the
+ fileevent loop (in ftp::StateHandler) to WaitorTimeout. Now
+ errors that occur in StateHandler won't be thrown until after the
+ the asynchronous (fileevent) portion of the code has completed.
+ ftp::OpenActiveConn and ftp::OpenPassiveConn can both still generate
+ errors in the event loop, which will cause a bgerror to be thrown.
+ Added some (untested) code to support Tenex mode ftp transfers. So
+ far tenex mode sends across 'TYPE L', and then does the transfer with
+ a binary encoded channel. Since I don't have a tenex system to test
+ it with, this feature is very alpha at this point.
+
+2000-09-28 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * ftp.tcl: Fixed a line of code in the "list_close" state of StateHandler,
+ switching a ![info exists... to [info exists...
+
+2000-09-25 Sandeep Tamhankar <sandeep@ajubasolutions.com>
+
+ * ftp.tcl: Fixed a line of code in the "connect" state of StateHandler,
+ switching a ![info exists... to [info exists... It was originally
+ stack tracing when opening a connection.
+
+2000-08-29 Steve Ball <Steve.Ball@zveno.com>
+
+ * README
+ * ftp.tcl
+ * pkgIndex.tcl
+ * docs/Open.html: Added '-command' configuration to the Open
+ command. This option indicates that all operations performed
+ on this connection are to be made asynchronously. The value
+ given to the option is a script which is invoked when operations
+ have finished. Updated documentation and bumped the version
+ number from 2.1 to 2.2 because a new feature was added.
+
+2000-08-16 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * README
+ * ftp.tcl
+ * pkgIndex.tcl
+ * docs/*.html: Added new optional arguments to the Get, Put, and
+ Append commands. The Append and Put commands have a new optional
+ argument '-data "data"' that can be used to specify data to transfer
+ instead of transferring data from a local file. The Get command has
+ a new optional argument '-variable varname' that specifies a variable
+ to store the retrieved data into, that can be used instead of
+ specifying a local filename. Updated the documentation to reflect
+ the changes and bumped the version number from 2.0 to 2.1 because
+ new features were added.
+
+
+2000-08-10 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * ftp.tcl
+ * pkgIndex.tcl: Fixed the ftp package to allow for
+ the destination location of the ftp::Get command to
+ be a directory as well as a file.
+
+2000-07-08 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * README
+ * ftp.tcl
+ * ftpdemo.tcl
+ * pkgIndex.tcl
+ * example/README
+ * example/hpupdate.tcl
+ * example/mirror.tcl
+ * example/newer.tcl
+ * docs/*.html: Updated for the change of ftp_lib.tcl -> ftp.tcl, for
+ the change of ftp_demo.tcl to ftpdemo.tcl, and for the FTP namespace
+ change. Made lots of fixes to complete the partially done work to
+ make ftp handle multiple concurrent ftps at the same time. Updated the
+ version in the docs, examples, source, and pkgIndex to be version 2.0
+
+2000-06-02 Eric Melski <ericm@scriptics.com>
+
+ * ftp.tcl: Changed namespace to ftp (from FTP). Updated license
+ information. Renamed ftp_lib.tcl to ftp.tcl in preparation for
+ inclusion in tcllib.
+
+1999-12-31 Peter MacDonald <peter@pdqi.com>
+ * ftp_lib.tcl: Modified to allow multiple concurrent ftps at the same
+ time. Unfortunately this is incompatible with the old procs.
+ Rewrite proc headers to be declared outside namespace eval.
+ Incremented version to 2.0.
+
+-------------------------- Released 1.2 -----------------------------
+
+1999-04-30 Steffen Traeger <Steffen.Traeger@t-online.de>
+
+ * ftp_lib.tcl: added new FTP command FTP::Append to append local
+ files to remote files.
+
+ * ftp_lib.tcl: Added TkCon support to make FTP::List inside TkCon
+ more readable.
+
+ * ftp_lib.tcl: In some strange cases ftp_lib overlaps the state
+ machine, to prevent this the state handler disables fileevents on
+ control socket a the beginning and enables it again at the end
+ (this failure comes with an earlier release of tkcon, it is only a
+ debugging feature now and commented).
+
+ * examples/*.tcl: Store the example files in a separate directory.
+
+-------------------------- Released 1.12 ----------------------------
+
+1999-02-28 Steffen Traeger <Steffen.Traeger@t-online.de>
+
+ * ftp_lib.tcl: Disabled remote Abort command, it doesn't work.
+ Insert an internal CloseDataConn command instaed of Abort.
+ Get/Reget: create local file only if the remote file really
+ exist. Fix major bug for passive mode that ftp_lib blocks in
+ every cases if file or directory doesn't exist at the remote
+ machine, THANKS to Brian Lalo <blalor@hcirisc.cs.binghamton.edu>
+ for his investigation. Added current namespace prefix to
+ InitDataConn procedure.
+
+1999-01-31 Steffen Traeger <Steffen.Traeger@t-online.de>
+
+ * ftp_lib.tcl: Changed return values of the FTP::Quote command,
+ sent back the string it received instead of any parsing THANKS
+ Keith Vetter <kvetter@us.oracle.com> for his patch. Improved
+ buffer mechanism in StateHandler, buffer represents the whole
+ received data. VERBOSE variable controlled output now will be
+ handled by the package not by the application. New online HTML
+ help files are available under the directory docs.
+
+1998-11-30 Steffen Traeger <Steffen.Traeger@t-online.de>
+
+ * ftp_lib.tcl: Can now also operate in the passive data transfer
+ mode, added "PASV" ability for every command that uses data
+ connection. Improved procedure return codes for a better error
+ handling. Restore correct type after switching to ascii mode in
+ FTP::List and FTP::NList. Insert a hook for using a graphical
+ progress bar that shows the elapsed time. Added new command
+ FTP::FileSize which gets the file size of the file on the remote
+ machine. FTP::Newer now is able to compare the modification date
+ of a remote file with the date of any local file. Enabled DEBUG
+ variable displays in additional the real FTP commands (old VERBOSE
+ feature). Signification of the VERBOSE variable is changed, if
+ enabled it shows the responses from the remote server. Allows to
+ call FTP::Cd without any parameter. Include some examples in
+ ftp_lib distribution.
+
+1998-05-31 Steffen Traeger <Steffen.Traeger@t-online.de>
+
+ * ftp_lib.tcl: Fixed a little bug in FTP::Open that makes it not
+ possible to use this procedure in a proc (upvar #0 ..)
+
+1998-03-31 Steffen Traeger <Steffen.Traeger@t-online.de>
+
+ * ftp_lib.tcl: Non-Blocking I/O of the control channel doesn't
+ work on Windows, changed to block the I/O channel
+
+-------------------------- Released 1.0 -----------------------------
+
+1998-03-30 Steffen Traeger <Steffen.Traeger@t-online.de>
+
+ * ftp_lib.tcl: Complete redesign to handle timeouts after
+ specified amount of time. Added new FTP command FTP::Quote for
+ sending verbatim commands to the FTP server THANKS to Ron Zajac
+ <Ron.Zajac.zajac@nt.com> for inspiration
+
+-------------------------- Released 0.9 -----------------------------
+
+1998-02-28 Steffen Traeger <Steffen.Traeger@t-online.de>
+
+ * ftp_lib.tcl: Uses only the highest-order digit of the 3-digit
+ reply code for switching in procedure StateHandler. Added new FTP
+ command FTP::ModTime to show the last modification time of a file
+ on the remote machine. THANKS to Bill Thorson
+ <thorson@typhoon.atmos.colostate.edu> for the patch. Added new
+ FTP command FTP::Newer to get remote file only if it is newer than
+ local file. DEBUG flag. VERBOSE flag. Added two options for
+ FTP::Open command: -timeout seconds, sets up timeout; -blocksize
+ size, writes "size" bytes at once. Procedure DisplayMsg now is
+ provided to display in different colors.
+
+0.84 (02/98)
+-----------
+- FTP commands now runs only if control connection is available
+- changed ls-output, removed "total"-line and blank lines from
+ the list
+
+0.83 (02/98)
+-----------
+- changed the FTP::NList command to query data of empty directories
+- added new FTP command FTP::Reget to skip over big files after
+ broken file transfer
+ THANKS to Paulo da Silva <pdasilva@mail2.esoterica.pt> for help
+- specially interpretation of the 421 reply code ("Service
+ not available, closing control connection"), it is necessary
+ for reget
+
+0.82 (12/97)
+-----------
+- added current namespace prefix to CopyNext procedure,
+ because of ftp_lib doesn't work correctly with tlc/tk8.0p2
+
+0.81 (08/97)
+-----------
+- replaced tkwait with vwait, this allows only to use
+ tcl shell for FTP library
+
+0.8 (07/97)
+-----------
+- redesigned to support namespace
+- added simple installation program
+- modified to support the tcl package specification
+
+0.7 (06/97)
+-----------
+- changed to tcl/tk version 8.0
+- used the new fcopy command to transfer binary data
+
+0.6 (02/97)
+-----------
+- bugfix: close data socket after every data transfer
+- added the rename command
+
+0.5 (02/97)
+-----------
+- bugfixes
+- added directory manipulation commands
+
+0.4 (02/97)
+-----------
+- changed to tcl7.6/tk4.2
+- added put/get commands
+
+0.1 - 0.3 (01/97)
+-----------------
+- ???
+
diff --git a/tcllib/modules/ftp/README b/tcllib/modules/ftp/README
new file mode 100644
index 0000000..2591c7a
--- /dev/null
+++ b/tcllib/modules/ftp/README
@@ -0,0 +1,80 @@
+=========================
+ftp 2.3 (08/16/2000)
+=========================
+
+files:
+
+ README - this file
+ ChangeLog - change log
+
+ ftp.tcl - ftp library package
+ ftpdemo.tcl - ftp test program
+ pkgIndex.tcl - package index file for ftp package
+
+ example/README - Overview of the example scripts
+ example/hpupdate.tcl - ftp example "homepage update"
+ example/mirror.tcl - ftp example "directoy mirror"
+ example/newer.tcl - ftp example "software update"
+
+ docs/*html - HTML manual pages
+
+1. Introduction
+===============
+
+In order to speed up the update of homepage files on the ftp server of
+my ISP, in spring of 1996 I looked for a useful solution. In those days
+I worked with Linux and used the Linux inside ftp tool.
+As fan of Tcl/Tk 'expect' was my next choice. It is excelently
+suitabled to control interactive processes like ftp sessions.
+A little bit more Tcl/Tk source and hpupdate 0.1 was ready, a script
+for the automatical update of homepage files without subdirectories.
+
+In the beginning of 1997 I was intense employed with RFC 959.
+Simultaneous I played with the Tcl socket command. Thus the
+FTP library for Tcl was developed...
+
+
+2. Overview
+===============
+
+The FTP Library Package extends tcl/tk with commands to support the
+FTP protocol. The library package is 100% tcl code, no extensions, no
+C stuff. It is easily to include in programs with
+
+ package require ftp 2.2
+
+Now everybody can write an own ftp program with an own GUI. It works
+with Windows, UNIX, and also, but not tested on Mac. The ftp package
+makes it comfortable and quick to create small tcl scripts for downloading
+files or directory trees. The ftp::Open command creates a session handle for
+each connection, and that handle is then used as the first argument to the
+rest of the commands.
+
+ Supports the following commands:
+
+ ftp::Open <server> <user> <passwd>
+ ftp::Close <handle>
+ ftp::Cd <handle> <directory>
+ ftp::Pwd <handle>
+ ftp::Type <handle> <?ascii|binary|tenex?>
+ ftp::List <handle> <?directory?>
+ ftp::NList <handle> <?directory?>
+ ftp::FileSize <handle> <file>
+ ftp::ModTime <handle> <file>
+ ftp::Delete <handle> <file>
+ ftp::Rename <handle> <from> <to>
+ ftp::Put <handle> <(local | -data "data")> <?remote?>
+ ftp::Append <handle> <(local | -data "data")> <?remote?>
+ ftp::Get <handle> <remote> <?(local | -variable varname)?>
+ ftp::Reget <handle> <remote> <?local?>
+ ftp::Newer <handle> <remote> <?local?>
+ ftp::MkDir <handle> <directory>
+ ftp::RmDir <handle> <directory>
+ ftp::Quote <handle> <arg1> <arg2> ...
+
+This new Releases use the new "fcopy" command to transfer binary data
+between two channels. There is also a version 0.4 of ftp for
+tcl7.6/tk4.2, which works stable using the undocumented command
+"unsupported0" for binary data transfer.
+
+
diff --git a/tcllib/modules/ftp/docs/fhelp1.html b/tcllib/modules/ftp/docs/fhelp1.html
new file mode 100644
index 0000000..1bc01d9
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp1.html
@@ -0,0 +1,126 @@
+<html>
+<head>
+<title>ftp Library Package 2.2 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::Open</b>&nbsp; <em>server&nbsp; user&nbsp; passwd&nbsp; ?options?</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+ The <b>ftp::Open</b> command is used to start the FTP session by
+ establishing a control connection to the FTP server. If no
+ options are specified, then the defaults are used.
+
+ <p>The <b>ftp::Open</b> command takes a host name <em>server</em>, a user name
+ <em>user</em> and a password <em>password</em> as its parameters and returns
+ a session handle that is an integer greater than or equal to 0 if the
+ connection is successfully established, otherwise it returns "-1".<br>
+ The <em>server</em> parameter must be the name or internet address (in dotted decimal
+ notation) of the ftp server. The <em>user</em> and <em>passwd</em> parameters must contain a
+ valid user name and password to complete the login process.</p>
+
+ The options overwrite some default values or set special
+ abilities:
+
+ <p><b>-blocksize size</b><dl><dd>
+ The blocksize is used during data transfer. At most <em>size</em>
+ bytes are transfered at once. After each block, a call to the "-progress callback" is made.
+ The default value for this option is 4096.</dd></dl></p>
+
+ <p><b>-timeout seconds</b><dl><dd>
+ If <em>seconds</em> is non-zero, then <b>ftp::Open</b> sets up a timeout
+ to occur after the specified number of seconds. The default value is 600.</dd></dl></p>
+
+ <p><b>-port number</b><dl><dd>
+ The <em>port number</em> specifies an alternative remote port on
+ the ftp server on which the ftp service resides. Most
+ ftp services listen for connection requests on default
+ port 21. Sometimes, usually for security reasons, port
+ numbers other than 21 are used for ftp connections.</dd></dl></p>
+
+ <p><b>-mode mode</b><dl><dd>
+ The <em>transfer mode</em> option determines if a file transfer
+ occurs in an active or passive way. In passive mode the
+ client session may want to request the ftp Server to
+ listen for a data port and wait for the connection
+ rather than initiate the process when a data transfer
+ request comes in. Passive mode is normally a requirement
+ when accessing sites via a firewall. The default mode is active.</dd></dl></p>
+
+ <p><b>-progress callback</b><dl><dd>
+ The <em>callback</em> is made after each transfer of a data
+ block specified in blocksize. The callback gets as
+ additional argument the current number of bytes transferred so far.
+ Here is a template for the progress callback:<br>
+
+ <pre>proc Progress {total} {
+ puts "$total bytes transfered!"
+}</pre></dd></dl></p>
+
+ <p><b>-command callback</b><dl><dd>
+ Specifying this option puts the connection in asynchronous mode.
+ The <em>callback</em> is made after each operation has been
+ completed. The callback gets as an additional argument
+ a keyword of the operation that has completed plus
+ additional arguments specific to the operation.
+ If an error occurs the callback is made with the keyword
+ "error". When an operation, such as "Cd", "Get", and so on,
+ has been started no further operations should be started
+ until a callback has been received for the current
+ operation.
+ A template for the callback is:<br>
+
+ <pre>proc Callback {what args} {
+ puts "Operation $what $args completed"
+}</pre></dd></dl></p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre>set server "ftp.server.com"
+set user "anonymous"
+set passwd "mist@foo.com"
+
+# define callback
+proc Progress {total} {
+ puts "$total bytes transfered!"
+}
+
+# open a new connection
+if {[set conn [ftp::Open $server $user $passwd -progress Progress -blocksize 1024 -mode passive]] == -1} {
+ puts "Connection refused!"
+ exit 1
+}
+
+# get a file
+ftp::Get $conn index.html
+
+# close connection
+ftp::Close $conn
+ </pre>
+
+ </dd>
+ </dl></dd>
+
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp2.html">ftp::Close</a>]
+</p>
+
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp10.html b/tcllib/modules/ftp/docs/fhelp10.html
new file mode 100644
index 0000000..f1425a8
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp10.html
@@ -0,0 +1,54 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::Delete</b><em>&nbsp; handle&nbsp; file</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::Delete</b> command deletes the specified file on the ftp
+ server. The command returns 1 if the specified file can be
+ successfully deleted or 0 if it fails.
+
+ <p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># delete file
+if {![ftp::Delete $conn index.htm]} {
+ puts "File couldn't be deleted!"
+}
+
+# delete all like "rm *"
+foreach file [ftp::NList $conn] {
+ ftp::Delete $conn $file
+}
+ </pre>
+
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp9.html">ftp::ModTime</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp11.html">ftp::Rename</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp11.html b/tcllib/modules/ftp/docs/fhelp11.html
new file mode 100644
index 0000000..adc9440
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp11.html
@@ -0,0 +1,52 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::Rename</b><em>&nbsp; handle&nbsp; from &nbsp;to</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::Rename</b> command renames the file in the current
+ directory of the ftp server with the specified file name <em>from</em>
+ to the specified new file name <em>to</em>. This new file name cannot
+ be the same as any existing subdirectory or file name.
+
+ <p>The command returns 1 if the specified file can be successfully
+ renamed or 0 if it fails.</p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># rename file
+ftp::Rename $conn index.htm index.htm.org
+
+# with fully qualified path name
+ftp::Rename $conn /usr/htdocs/index.htm /usr/htdocs/index.htm.org
+ </pre>
+
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp10.html">ftp::Delete</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp12.html">ftp::Put</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp12.html b/tcllib/modules/ftp/docs/fhelp12.html
new file mode 100644
index 0000000..f517e65
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp12.html
@@ -0,0 +1,58 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::Put</b><em>&nbsp; handle&nbsp; (local | -data "data") &nbsp;?remote?</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::Put</b> command stores a local file <em>local</em> to a remote
+ file <em>remote</em> on the ftp server. The file parameters passed must
+ contain a fully qualified path name, otherwise the command uses
+ the current directory. If '-data "data"' is specified, then rather than
+ transferring a file, the data passed in is used as the data to transfer.
+ If remote file name is unspecified, the local file name is assigned to
+ the remote file name.
+
+ <p>If the file was successfully transferred, then the command
+ returns 1, if it fails 0. </p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># store unique file name
+ftp::Put $conn index.htm
+
+# store different file names
+ftp::Put $conn test.htm index.htm
+
+# with different fully qualified path name
+ftp::Put $conn /usr/local/src/my.tar.gz /incoming/foo.tar.gz
+ </pre>
+
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp11.html">ftp::Rename</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp125.html">ftp::Append</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp125.html b/tcllib/modules/ftp/docs/fhelp125.html
new file mode 100644
index 0000000..9ce6132
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp125.html
@@ -0,0 +1,58 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::Append</b><em>&nbsp; handle&nbsp; (local | -data "data") &nbsp;?remote?</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::Append</b> command appends a local file <em>local</em> to an
+ existing remote file <em>remote</em> on the ftp server. If the file
+ not exists at the server site, the file shall be created at the server
+ site. If '-data "data"' is specified, then rather than
+ transferring a file, the data passed in is used as the data to transfer.
+<br>
+ The file parameters passed must
+ contain a fully qualified path name, otherwise the command uses
+ the current directory. If remote file name is unspecified, the
+ local file name is assigned to the remote file name.
+
+ <p>If the file was successfully transferred, then the command
+ returns 1, if it fails 0. </p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># store data
+ftp::Put $conn data.log
+
+# append new data
+ftp::Append $conn logfile data.log
+ </pre>
+
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp12.html">ftp::Put</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp13.html">ftp::Get</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp13.html b/tcllib/modules/ftp/docs/fhelp13.html
new file mode 100644
index 0000000..a6813ea
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp13.html
@@ -0,0 +1,62 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::Get</b><em>&nbsp; handle&nbsp; remote &nbsp;?(local | -variable varname)?</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::Get</b> command retrieves a remote file <em>remote</em> on the
+ ftp server to a local file <em>local</em>. If '-variable varname' is
+ specified, then the variable 'varname' will get the retreived data
+ stored in it, rather than storing the data in a file. The file
+ parameters passed must contain a fully qualified path name, otherwise
+ the command uses the current directory. If local file name is
+ unspecified, the remote file name is assigned to the remote file name.
+
+ <p>If the file was successfully transferred, then the command
+ returns 1, if it fails 0. </p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># retrieve unique file name
+ftp::Get $conn index.htm
+
+# retrieve different file names
+ftp::Get $conn index.htm new.htm
+
+# with different fully qualified path name
+if [ftp::Get $conn /incoming/foo.tar.gz /usr/local/src] {
+ cd /usr/local/src
+ exec gunzip foo.tar.gz
+ exec tar xf foo.tar
+}
+ </pre>
+
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp125.html">ftp::Append</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp14.html">ftp::Reget</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp14.html b/tcllib/modules/ftp/docs/fhelp14.html
new file mode 100644
index 0000000..2cc83ca
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp14.html
@@ -0,0 +1,51 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::Newer</b><em>&nbsp; handle&nbsp; remote &nbsp;?local?</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::Newer</b> command has the same behavior as <b>ftp::Get</b>, except
+ that it gets the remote file only if the modification time of
+ the remote file is more recent that the file on the local
+ system. If the file does not exist on the current system, the
+ remote file is considered newer.
+
+ <p>If the file was successfully transferred, then the command
+ returns 1, if it fails 0. </p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># package update
+if {[ftp::Newer $conn /pub/tcl/httpd/tclhttpd.tar.gz /usr/local/src/tclhttpd.tgz]} {
+ exec echo "New httpd arrived!" | mailx -s ANNOUNCE root
+}
+ </pre>
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp13.html">ftp::Get</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp15.html">ftp::Newer</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp15.html b/tcllib/modules/ftp/docs/fhelp15.html
new file mode 100644
index 0000000..c03bbbd
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp15.html
@@ -0,0 +1,57 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::Reget</b><em>&nbsp; handle&nbsp; remote &nbsp;?local?</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::Reget</b> command has the same behavior as <b>ftp::Get</b>, except
+ that if local file <em>local</em> exists and is smaller than remote
+ file <em>remote</em>, the local file is presumed to be a partially
+ transferred copy of the remote file and the transfer is
+ continued from the apparent point of failure. This command is
+ useful when transferring very large files over networks that
+ tend to drop connections.
+
+ <p>If the file was successfully transferred, then the command
+ returns 1, if it fails 0. </p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># retrieve a large file name (12 MByte)
+ftp::Get $conn foo.tar
+
+.... after 1 hour and 11.9 transfered MBytes the connection is broken :-(
+
+# restart file transfer at the broken position and
+# retrieve only the remaining 0.1 MByte
+ftp::Reget $conn foo.tar
+ </pre>
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp14.html">ftp::Reget</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp16.html">ftp::MkDir</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp16.html b/tcllib/modules/ftp/docs/fhelp16.html
new file mode 100644
index 0000000..f893d10
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp16.html
@@ -0,0 +1,53 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>FTP Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::MkDir</b><em>&nbsp; handle&nbsp; directory</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::MkDir</b> causes the directory specified in directory to
+ be created as a directory (if the directory is absolute) or as
+ a subdirectory of the current working directory (if directory
+ is relative).
+
+ <p>If the directory was successfully created, then the command
+ returns 1, if it fails 0. </p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># create directory
+ftp::MkDir $conn /incoming/newdir
+
+# or
+ftp::Cd $conn /incoming
+ftp::MkDir $conn newdir
+ </pre>
+
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp15.html">ftp::Newer</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp17.html">ftp::RmDir</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp17.html b/tcllib/modules/ftp/docs/fhelp17.html
new file mode 100644
index 0000000..38b5c8a
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp17.html
@@ -0,0 +1,51 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::RmDir</b><em>&nbsp; handle&nbsp; directory</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::RmDir</b> command removes the specified directory on the
+ ftp server. The remote directory must be empty.
+
+ <p>The command returns 1 if the specified directory can be successfully
+ removed or 0 if it fails. </p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># remove directory
+ftp::RmDir $conn /incoming/newdir
+
+# or
+ftp::Cd $conn /incoming
+ftp::RmDir $conn newdir
+ </pre>
+
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp16.html">ftp::MkDir</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp18.html">ftp::Quote</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp18.html b/tcllib/modules/ftp/docs/fhelp18.html
new file mode 100644
index 0000000..3ede807
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp18.html
@@ -0,0 +1,52 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::Quote</b><em>&nbsp; handle&nbsp; arg1&nbsp; arg2&nbsp; ...</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::Quote</b> command is used to send the specified arguments
+ verbatim, as is, to the remote ftp server. This command cannot
+ be used to obtain a directory listing or for transferring files,
+ but it can be used for any other ftp commands. It is typically
+ used to execute commands on the server that are not directly
+ available from the ftp_lib itself.
+
+ <p>The command sent back the string it received instead of any parsing</p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># change the mode settings on UNIX systems
+ftp::Quote $conn site chmod 644 index.htm
+
+# request supported ftp server commands
+puts [ftp::Quote $conn help]
+ </pre>
+
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp17.html">ftp::RmDir</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp2.html b/tcllib/modules/ftp/docs/fhelp2.html
new file mode 100644
index 0000000..5f5895b
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp2.html
@@ -0,0 +1,57 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::Close</b> <em>handle</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+ The <b>ftp::Close</b> command terminates the ftp session and if file
+ transfer is not in progress, the server closes the control
+ connection. If file transfer is in progress, the connection
+ will remain open for result response and the server will then
+ close it.
+ </dd>
+ <dd>&nbsp;</dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># open a new connection
+if {[set conn [ftp::Open ...]] == -1} {
+ puts "Connection refused!"
+ exit 1
+}
+
+# get file
+ftp::Get $conn index.html
+
+# close connection
+ftp::Close $conn
+ </pre>
+
+ </dd>
+ </dl></dd>
+
+</dl>
+</p>
+
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp1.html">ftp::Open</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp3.html">ftp::Cd</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp3.html b/tcllib/modules/ftp/docs/fhelp3.html
new file mode 100644
index 0000000..15ec010
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp3.html
@@ -0,0 +1,54 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::CD</b>&nbsp; <em>handle</em> <em>directory</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::Cd</b> command changes the current working directory on
+ the ftp server to a specified target directory. This target
+ directory can be a subdirectory of the current directory, ".."
+ (for the parent directory) or a fully qualified path to a new
+ working directory.
+
+ <p>The command returns 1 if the current working directory can be
+ successfully changed to the specified directory or 0 if it fails.</p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># change directory
+ftp::Cd $conn pub/tcl
+ftp::Cd $conn ..
+
+ </pre>
+
+ </dd>
+ </dl></dd>
+
+</dl>
+</p>
+
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp2.html">ftp::Close</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp4.html">ftp::Pwd</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp4.html b/tcllib/modules/ftp/docs/fhelp4.html
new file mode 100644
index 0000000..9131d54
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp4.html
@@ -0,0 +1,47 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::Pwd</b> <em>handle</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::Pwd</b> command gets the complete path of the current
+ working directory on the ftp server or an empty string if an
+ error occurs.
+
+ <p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># get directory path
+set current_path [ftp::Pwd $conn]
+ </pre>
+
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp3.html">ftp::Cd</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp5.html">ftp::Type</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp5.html b/tcllib/modules/ftp/docs/fhelp5.html
new file mode 100644
index 0000000..581dfa3
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp5.html
@@ -0,0 +1,57 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::Type</b><em>&nbsp; handle&nbsp; ?ascii|binary?</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::Type</b> command sets the ftp file transfer type either
+ to <em>ascii</em>, <em>binary</em>, or to <em>tenex</em>. In every
+ case, also if the type name is unspecified, it returns the current type.
+
+ <p>Only <b>ascii</b> and <b>binary</b> types are currently supported.
+ There is some early (alhpa) support for Tenex mode. The ascii
+ type is normally used to convert text files to a format suitable
+ for text editors on the platform depended destination machine.
+ The binary type allows undisturbed transfers of non-text files,
+ such as compressed files, images and executables. </p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># get file transfer type
+set current_type [ftp::Type $conn]
+
+# set file transfer type
+ftp::Type $conn ascii
+
+
+ </pre>
+
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp4.html">ftp::Pwd</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp6.html">ftp::List</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp6.html b/tcllib/modules/ftp/docs/fhelp6.html
new file mode 100644
index 0000000..dc8b19d
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp6.html
@@ -0,0 +1,74 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::List</b><em>&nbsp; handle&nbsp; ?directory?</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::List</b> command lists the contents of the current remote
+ directory or if the directory parameter is specified a directory
+ or other group of files. Also wildcard expression, such as
+ "*.tcl", can be specified. The directory or file name must be
+ fully qualified, otherwise the it takes entries in the current
+ remote directory.
+
+ <p>The listing includes any system-dependent information that the
+ server chooses to include; for example, most UNIX systems
+ produce output from the command "ls -l". <b>ftp::List</b> returns
+ these information as a <b>tcl list</b> with one line for every entry.
+ Empty lines and UNIX's "total" lines are ignored. So it should
+ offer only usable informations.</p>
+
+ <p>If the command fails an empty list is returned.</p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># list current directory
+foreach line [ftp::List $conn]
+ puts $line
+}
+
+# list only tcl files
+foreach line [ftp::List $conn *.tcl]
+ puts $line
+}
+
+# list specified directory
+set dir_list [ftp::List $conn /pub/usr/lib]
+
+# list if directory exist
+if {[ftp::Cd $conn /pub/usr/lib]} {
+ set dir_list [ftp::List $conn]
+} else {
+ puts "Directory doesn't exist!"
+}
+ </pre>
+
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp5.html">ftp::Type</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp7.html">ftp::NList</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp7.html b/tcllib/modules/ftp/docs/fhelp7.html
new file mode 100644
index 0000000..548b20f
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp7.html
@@ -0,0 +1,48 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::NList</b><em>&nbsp; handle&nbsp; ?directory?</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ This command has the same behavior as previous <b>ftp::List</b> command, except that it
+ only gets a abbreviated listing. This means only file names are
+ returned in a sorted list.
+
+ <p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># list current directory
+set file_names [ftp::NList $conn]
+
+ </pre>
+
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp6.html">ftp::List</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp8.html">ftp::FileSize</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp8.html b/tcllib/modules/ftp/docs/fhelp8.html
new file mode 100644
index 0000000..185dec3
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp8.html
@@ -0,0 +1,50 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::FileSize</b><em>&nbsp; handle&nbsp; file</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::FileSize</b> command gets the file size of the specified
+ file on the ftp server.<br> <b><font color="#ff0000">ATTENTION!</font></b> It doesn't work properly in
+ ascci mode and isn't supported by all ftp server implementations.
+
+ <p>If the command fails an empty string is returned.</p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># get file size
+set old_type [ftp::Type $conn]
+ftp::Type $conn binary
+set size [ftp::FileSize $conn index.htm]
+ftp::Type $conn $old_type
+ </pre>
+
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp7.html">ftp::NList</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp9.html">ftp::ModTime</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/fhelp9.html b/tcllib/modules/ftp/docs/fhelp9.html
new file mode 100644
index 0000000..2952bab
--- /dev/null
+++ b/tcllib/modules/ftp/docs/fhelp9.html
@@ -0,0 +1,49 @@
+<html>
+<head>
+<title>ftp Library Package 2.1 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>COMMAND</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp::ModTime</b><em>&nbsp; handle&nbsp; file</em></dd>
+ <dd>&nbsp;</dd>
+ <dd>
+
+ The <b>ftp::ModTime</b> command gets the last modification time of the
+ file on the ftp server as a system dependent integer value in
+ seconds (see tcl's clock command) or an empty string in error cases.
+
+ <p>
+
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>EXAMPLE</b></font></dd>
+ <dd><dl>
+ <dd>
+ <pre># get modification time
+puts [clock format [ftp::ModTime $conn index.htm]]
+
+set year [clock format [ftp::ModTime $conn index.htm] -format %y]
+ </pre>
+
+ </dd>
+ </dl></dd>
+</dl>
+</p>
+<p>
+[<a href="index.html">Contents</a>]&nbsp;
+[<b>Previous:</b> <a href="fhelp8.html">ftp::FileSize</a>]&nbsp;
+[<b>Next:</b> <a href="fhelp10.html">ftp::Delete</a>]
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
diff --git a/tcllib/modules/ftp/docs/index.html b/tcllib/modules/ftp/docs/index.html
new file mode 100644
index 0000000..012727c
--- /dev/null
+++ b/tcllib/modules/ftp/docs/index.html
@@ -0,0 +1,107 @@
+<html>
+<head>
+<title>ftp Library Package 2.2 for Tcl/Tk help file</title>
+</head>
+<body bgcolor="#ffffff" text="#000000">
+<body>
+
+<p>
+<dl>
+ <dd>
+ <p><font face="Arial,Helvetica" color="#526e9c" size="+2"><b>ftp Library Package 2.1 for Tcl/Tk Manual Pages</b></font></p>
+ </dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>NAME</b></font></dd>
+ <dd><dl>
+ <dd><b>ftp - Client-side tcl implementation of the ftp protocol</b></dd>
+ </dl></dd>
+ <dd>&nbsp;</dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>SYNOPSIS</b></font></dd>
+ <dd><dl>
+ <dd><b>package require ftp ?2.2?</b></dd>
+ <dd>&nbsp;</dd>
+ <dd><b>ftp::<a href="fhelp1.html">Open</b><em>&nbsp; server&nbsp; user&nbsp; passwd&nbsp; ?options?</em></a></dd>
+ <dd><b>ftp::<a href="fhelp2.html">Close</b><em>&nbsp; handle</em></a></dd>
+ <dd><b>ftp::<a href="fhelp3.html">Cd</b><em>&nbsp; handle&nbsp; directory</em></a></dd>
+ <dd><b>ftp::<a href="fhelp4.html">Pwd</b><em>&nbsp; handle</em></a></dd>
+ <dd><b>ftp::<a href="fhelp5.html">Type</b><em>&nbsp; handle&nbsp; ?ascii|binary|tenex?</em></a></dd>
+ <dd><b>ftp::<a href="fhelp6.html">List</b><em>&nbsp; handle&nbsp; ?directory?</em></a></dd>
+ <dd><b>ftp::<a href="fhelp7.html">NList</b><em>&nbsp; handle&nbsp; ?directory?</em></a></dd>
+ <dd><b>ftp::<a href="fhelp8.html">FileSize</b><em>&nbsp; handle&nbsp; file</em></a></dd>
+ <dd><b>ftp::<a href="fhelp9.html">ModTime</b><em>&nbsp; handle&nbsp; from&nbsp; to</em></a></dd>
+ <dd><b>ftp::<a href="fhelp10.html">Delete</b><em>&nbsp; handle&nbsp; file</em></a></dd>
+ <dd><b>ftp::<a href="fhelp11.html">Rename</b><em>&nbsp; handle&nbsp; from&nbsp; to</em></a></dd>
+ <dd><b>ftp::<a href="fhelp12.html">Put</b><em>&nbsp; handle&nbsp; (local | -data "data")&nbsp; ?remote?</em></a></dd>
+ <dd><b>ftp::<a href="fhelp125.html">Append</b><em>&nbsp; handle&nbsp; (local | -data "data")&nbsp; ?remote?</em></a></dd>
+ <dd><b>ftp::<a href="fhelp13.html">Get</b><em>&nbsp; handle&nbsp; remote&nbsp; ?(local | -variable varname)?</em></a></dd>
+ <dd><b>ftp::<a href="fhelp14.html">Reget</b><em>&nbsp; handle&nbsp; remote&nbsp; ?local?</em></a></dd>
+ <dd><b>ftp::<a href="fhelp15.html">Newer</b><em>&nbsp; handle&nbsp; remote&nbsp; ?local?</em></a></dd>
+ <dd><b>ftp::<a href="fhelp16.html">MkDir</b><em>&nbsp; handle&nbsp; directory</em></a></dd>
+ <dd><b>ftp::<a href="fhelp17.html">RmDir</b><em>&nbsp; handle&nbsp; directory</em></a></dd>
+ <dd><b>ftp::<a href="fhelp18.html">Quote</b><em>&nbsp; handle&nbsp; arg1&nbsp; arg2&nbsp; ...</em></a></dd>
+ <dd><b>ftp::DisplayMsg</b><em>&nbsp; handle&nbsp; msg&nbsp; ?state? </em></dd>
+ <dd>&nbsp;</dd>
+ <dd>variable <b>ftp::VERBOSE</b></dd>
+ <dd>variable <b>ftp::DEBUG</b></dd>
+ </dl></dd>
+ <dd>&nbsp;</dd>
+
+ <dd><font face="Arial,Helvetica" size="+1"><b>DESCRIPTION</b></font></dd>
+ <dd><dl>
+ <dd>
+ The ftp library package provides the client side of the ftp protocol.
+ The package implements active (default) and passive ftp sessions.
+
+ <p>A new ftp session is started with the Open</b> command. Quitting an
+ existing ftp session is done by Close</b>. All other commands can
+ only be used in an opened ftp session else an error will occured.
+ The ftp package includes file and directory manipulating commands for
+ remote sites. To do the same stuff to the local site the built-in tcl
+ commands like "cd" or "file <em>command</em>" are the best choice.</p>
+
+ Two state variables controls the output of ftp. Setting VERBOSE</b>
+ to "1" forces to show all responses from the remote server. The default value is "0".
+ Setting DEBUG</b> to "1" enables debugging to show all the return code, states
+ and "real" ftp commands. The default value is "0".
+
+ <p>The procedure <b>DisplayMsg</b> is used to show the different messages from
+ the ftp session. It is simple declared in ftp and must be overwritten
+ by the programmer to make it more comfortable. A state variable for different
+ states assigned to different colors is recommended by the author. For
+ example:</p>
+
+ <pre>.msg.text tag configure error -foreground red
+.msg.text tag configure data -foreground brown
+.msg.text tag configure control -foreground blue
+
+namespace ftp {
+ proc DisplayMsg {s msg {state ""}} {
+ switch $state {
+ data {.msg.text insert end "$msg\n" data}
+ control {.msg.text insert end "$msg\n" control}
+ error {.msg.f.text insert end "$msg\n" error}
+ }
+ }
+}</pre>
+ </dd>
+ </dl></dd>
+
+ <dd><font face="Arial,Helvetica" size="+1" color="##ff0000"><b>BUGS</b></font></dd>
+ <dd><dl>
+ <dd>
+ Correct execution of many commands depends upon proper behavior by the remote server, network
+ and router configuration.<p>
+
+ An update command placed in the procedure DisplayMsg run into persistent errors or infinite loops.
+ The solution to this problem is to use "update idletasks", rather than a single update.
+ </dd>
+ </dl></dd>
+
+</dl>
+</p>
+<p align="left"><hr noshade size="1"><font face="Arial,Helvetica" size="-1">&copy; 1999 <a href="mailto:Steffen.Traeger@t-online.de">Steffen Traeger</a></font></p>
+</body>
+</html>
+
+
diff --git a/tcllib/modules/ftp/ftp.man b/tcllib/modules/ftp/ftp.man
new file mode 100644
index 0000000..72118ec
--- /dev/null
+++ b/tcllib/modules/ftp/ftp.man
@@ -0,0 +1,440 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset PACKAGE_VERSION 2.4.13]
+[manpage_begin ftp n [vset PACKAGE_VERSION]]
+[see_also ftpd]
+[see_also mime]
+[see_also pop3]
+[see_also smtp]
+[keywords ftp]
+[keywords internet]
+[keywords net]
+[keywords {rfc 959}]
+[moddesc {ftp client}]
+[titledesc {Client-side tcl implementation of the ftp protocol}]
+[category Networking]
+[require Tcl 8.2]
+[require ftp [opt [vset PACKAGE_VERSION]]]
+[description]
+
+[para]
+
+The ftp package provides the client side of the ftp protocol as
+specified in RFC 959 ([uri http://www.rfc-editor.org/rfc/rfc959.txt]).
+The package implements both active (default) and passive ftp sessions.
+
+[para]
+
+A new ftp session is started with the [cmd ::ftp::Open] command. To
+shutdown an existing ftp session use [cmd ::ftp::Close]. All other
+commands are restricted to usage in an an open ftp session. They will
+generate errors if they are used out of context. The ftp package
+includes file and directory manipulating commands for remote sites. To
+perform the same operations on the local site use commands built into
+the core, like [cmd cd] or [cmd file].
+
+[para]
+
+The output of the package is controlled by two state variables,
+
+[var ::ftp::VERBOSE] and [var ::ftp::DEBUG]. Setting
+
+[var ::ftp::VERBOSE] to "1" forces the package to show all responses
+from a remote server. The default value is "0". Setting
+
+[var ::ftp::DEBUG] to "1" enables debugging and forces the package to
+show all return codes, states, state changes and "real" ftp
+commands. The default value is "0".
+
+[para]
+
+The command [cmd ::ftp::DisplayMsg] is used to show the different
+messages from the ftp session. The setting of [var ::ftp::VERBOSE]
+determines if this command is called or not. The current
+implementation of the command uses the [package log] package of tcllib
+to write the messages to their final destination. This means that the
+behaviour of [cmd ::ftp::DisplayMsg] can be customized without
+changing its implementation. For more radical changes overwriting its
+implementation by the application is of course still possible. Note
+that the default implementation honors the option [option -output] to
+
+[cmd ::ftp::Open] for a session specific log command.
+
+[para]
+
+[emph Caution]: The default implementation logs error messages like
+all other messages. If this behaviour is changed to throwing an error
+instead all commands in the API will change their behaviour too. In
+such a case they will not return a failure code as described below but
+pass the thrown error to their caller.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::ftp::Open] [arg server] [arg user] [arg passwd] [opt [arg options]]]
+
+This command is used to start a FTP session by establishing a control
+connection to the FTP server. The defaults are used for any option not
+specified by the caller.
+
+[para]
+
+The command takes a host name [arg server], a user name [arg user] and
+a password [arg password] as its parameters and returns a session
+handle that is an integer number greater than or equal to "0", if the
+connection is successfully established. Otherwise it returns "-1".
+The [arg server] parameter must be the name or internet address (in
+dotted decimal notation) of the ftp server to connect to. The
+
+[arg user] and [arg passwd] parameters must contain a valid user name
+and password to complete the login process.
+
+[para]
+
+The options overwrite some default values or set special abilities:
+
+[list_begin definitions]
+
+[def "[option -blocksize] [arg size]"]
+
+The blocksize is used during data transfer. At most [arg size] bytes
+are transfered at once. The default value for this option is 4096.
+The package will evaluate the [cmd {-progress callback}] for the
+session after the transfer of each block.
+
+[def "[option -timeout] [arg seconds]"]
+
+If [arg seconds] is non-zero, then [cmd ::ftp::Open] sets up a timeout
+which will occur after the specified number of seconds. The default
+value is 600.
+
+[def "[option -port] [arg number]"]
+
+The port [arg number] specifies an alternative remote port on the ftp
+server on which the ftp service resides. Most ftp services listen for
+connection requests on the default port 21. Sometimes, usually for
+security reasons, port numbers other than 21 are used for ftp
+connections.
+
+[def "[option -mode] [arg mode]"]
+
+The transfer [arg mode] option determines if a file transfer occurs in
+[const active] or [const passive] mode. In passive mode the client
+will ask the ftp server to listen on a data port and wait for the
+connection rather than to initiate the process by itself when a data
+transfer request comes in. Passive mode is normally a requirement when
+accessing sites via a firewall. The default mode is [const active].
+
+[def "[option -progress] [arg callback]"]
+
+This [arg callback] is evaluated whenever a block of data was
+transfered. See the option [option -blocksize] for how to specify the
+size of the transfered blocks.
+
+[para]
+
+When evaluating the [arg callback] one argument is appended to the
+callback script, the current accumulated number of bytes transferred
+so far.
+
+[def "[option -command] [arg callback]"]
+
+Specifying this option places the connection into asynchronous
+mode. The [arg callback] is evaluated after the completion of any
+operation. When an operation is running no further operations must be
+started until a callback has been received for the currently executing
+operation.
+
+[para]
+
+When evaluating the [arg callback] several arguments are appended to
+the callback script, namely the keyword of the operation that has
+completed and any additional arguments specific to the operation. If
+an error occurred during the execution of the operation the callback is
+given the keyword [const error].
+
+[def "[option -output] [arg callback]"]
+
+This option has no default. If it is set the default implementation of
+[cmd ::ftp::DisplayMsg] will use its value as command prefix to log
+all internal messages. The callback will have three arguments appended
+to it before evaluation, the id of the session, the message itself,
+and the connection state, in this order.
+
+[list_end]
+
+[call [cmd ::ftp::Close] [arg handle]]
+
+This command terminates the specified ftp session. If no file transfer
+is in progress, the server will close the control connection
+immediately. If a file transfer is in progress however, the control
+connection will remain open until the transfers completes. When that
+happens the server will write the result response for the transfer to
+it and close the connection afterward.
+
+[call [cmd ::ftp::Cd] [arg handle] [arg directory]]
+
+This command changes the current working directory on the ftp server
+to a specified target [arg directory]. The command returns 1 if the
+current working directory was successfully changed to the specified
+directory or 0 if it fails. The target directory can be
+
+[list_begin itemized]
+[item]
+
+a subdirectory of the current directory,
+
+[item]
+
+Two dots, [const ..] (as an indicator for the parent directory of
+the current directory)
+
+[item]
+
+or a fully qualified path to a new working directory.
+
+[list_end]
+
+[call [cmd ::ftp::Pwd] [arg handle]]
+
+This command returns the complete path of the current working
+directory on the ftp server, or an empty string in case of an error.
+
+[call [cmd ::ftp::Type] [arg handle] [opt [const ascii|binary|tenex]]]
+
+This command sets the ftp file transfer type to either [const ascii],
+[const binary], or [const tenex]. The command always returns the
+currently set type. If called without type no change is made.
+
+[para]
+
+Currently only [const ascii] and [const binary] types are
+supported. There is some early (alpha) support for Tenex mode. The
+type [const ascii] is normally used to convert text files into a
+format suitable for text editors on the platform of the destination
+machine. This mainly affects end-of-line markers. The type
+
+[const binary] on the other hand allows the undisturbed transfer of
+non-text files, such as compressed files, images and executables.
+
+[call [cmd ::ftp::List] [arg handle] [opt [arg pattern]]]
+
+This command returns a human-readable list of files. Wildcard
+expressions such as [file *.tcl] are allowed. If [arg pattern]
+refers to a specific directory, then the contents of that directory
+are returned. If the [arg pattern] is not a fully-qualified path
+name, the command lists entries relative to the current remote
+directory. If no [arg pattern] is specified, the contents of the
+current remote directory is returned.
+
+[para]
+
+The listing includes any system-dependent information that the server
+chooses to include. For example most UNIX systems produce output from
+the command [syscmd {ls -l}]. The command returns the retrieved
+information as a tcl list with one item per entry. Empty lines and
+UNIX's "total" lines are ignored and not included in the result as
+reported by this command.
+
+[para]
+
+If the command fails an empty list is returned.
+
+[call [cmd ::ftp::NList] [arg handle] [opt [arg directory]]]
+
+This command has the same behavior as the [cmd ::ftp::List] command,
+except that it only retrieves an abbreviated listing. This means only
+file names are returned in a sorted list.
+
+[call [cmd ::ftp::FileSize] [arg handle] [arg file]]
+
+This command returns the size of the specified [arg file] on the ftp
+server. If the command fails an empty string is returned.
+
+[para]
+
+[emph ATTENTION!] It will not work properly when in ascii mode and
+is not supported by all ftp server implementations.
+
+[call [cmd ::ftp::ModTime] [arg handle] [arg file]]
+
+This command retrieves the time of the last modification of the
+
+[arg file] on the ftp server as a system dependent integer value in
+seconds or an empty string if an error occurred. Use the built-in
+command [cmd clock] to convert the retrieves value into other formats.
+
+[call [cmd ::ftp::Delete] [arg handle] [arg file]]
+
+This command deletes the specified [arg file] on the ftp server. The
+command returns 1 if the specified file was successfully deleted or 0
+if it failed.
+
+[call [cmd ::ftp::Rename] [arg handle] [arg from] [arg to]]
+
+This command renames the file [arg from] in the current directory of
+the ftp server to the specified new file name [arg to]. This new file
+name must not be the same as any existing subdirectory or file name.
+The command returns 1 if the specified file was successfully renamed
+or 0 if it failed.
+
+[call [cmd ::ftp::Put] [arg handle] ([arg local] | -data [arg data] | -channel [arg chan]) [opt [arg remote]]]
+
+This command transfers a local file [arg local] to a remote file
+
+[arg remote] on the ftp server. If the file parameters passed to the
+command do not fully qualified path names the command will use the
+current directory on local and remote host. If the remote file name is
+unspecified, the server will use the name of the local file as the
+name of the remote file. The command returns 1 to indicate a successful
+transfer and 0 in the case of a failure.
+
+[para]
+
+If [option -data] [arg data] is specified instead of a local file, the
+system will not transfer a file, but the [arg data] passed into it. In
+this case the name of the remote file has to be specified.
+
+[para]
+
+If [option -channel] [arg chan] is specified instead of a local file,
+the system will not transfer a file, but read the contents of the
+channel [arg chan] and write this to the remote file. In this case the
+name of the remote file has to be specified. After the transfer
+
+[arg chan] will be closed.
+
+[call [cmd ::ftp::Append] [arg handle] ([arg local] | -data [arg data] | -channel [arg chan]) [opt [arg remote]]]
+
+This command behaves like [cmd ::ftp::Puts], but appends the
+transfered information to the remote file. If the file did not exist
+on the server it will be created.
+
+[call [cmd ::ftp::Get] [arg handle] [arg remote] [opt "([arg local] | -variable [arg varname] | -channel [arg chan])"]]
+
+This command retrieves a remote file [arg remote] on the ftp server
+and stores its contents into the local file [arg local]. If the file
+parameters passed to the command are not fully qualified path names
+the command will use the current directory on local and remote
+host. If the local file name is unspecified, the server will use the
+name of the remote file as the name of the local file. The command
+returns 1 to indicate a successful transfer and 0 in the case of a
+failure. The command will throw an error if the directory the file
+[arg local] is to be placed in does not exist.
+
+[para]
+
+If [option -variable] [arg varname] is specified, the system will
+store the retrieved data into the variable [arg varname] instead of a
+file.
+
+[para]
+
+If [option -channel] [arg chan] is specified, the system will write
+the retrieved data into the channel [arg chan] instead of a file. The
+system will [emph not] close [arg chan] after the transfer, this is
+the responsibility of the caller to [cmd ::ftp::Get].
+
+[call [cmd ::ftp::Reget] [arg handle] [arg remote] [opt [arg local]] [opt [arg from]] [opt [arg to]]]
+
+This command behaves like [cmd ::ftp::Get], except that if local file
+[arg local] exists and is smaller than remote file [arg remote], the
+local file is presumed to be a partially transferred copy of the
+remote file and the transfer is continued from the apparent point of
+failure. The command will throw an error if the directory the file
+[arg local] is to be placed in does not exist. This command is useful
+when transferring very large files over networks that tend to drop
+connections.
+
+[para]
+
+Specifying the additional byte offsets [arg from] and [arg to] will
+cause the command to change its behaviour and to download exactly the
+specified slice of the remote file. This mode is possible only if a
+local destination is explicitly provided. Omission of [arg to] leads
+to downloading till the end of the file.
+
+[call [cmd ::ftp::Newer] [arg handle] [arg remote] [opt [arg local]]]
+
+This command behaves like [cmd ::ftp::Get], except that it retrieves
+the remote file only if the modification time of the remote file is
+more recent than the file on the local system. If the file does not
+exist on the local system, the remote file is considered newer. The
+command will throw an error if the directory the file [arg local] is
+to be placed in does not exist.
+
+[call [cmd ::ftp::MkDir] [arg handle] [arg directory]]
+
+This command creates the specified [arg directory] on the ftp
+server. If the specified path is relative the new directory will be
+created as a subdirectory of the current working directory. Else the
+created directory will have the specified path name. The command
+returns 1 to indicate a successful creation of the directory and 0 in
+the case of a failure.
+
+[call [cmd ::ftp::RmDir] [arg handle] [arg directory]]
+
+This command removes the specified directory on the ftp server. The
+remote directory has to be empty or the command will fail. The command
+returns 1 to indicate a successful removal of the directory and 0 in
+the case of a failure.
+
+[call [cmd ::ftp::Quote] [arg handle] [arg arg1] [arg arg2] [arg ...]]
+
+This command is used to send an arbitrary ftp command to the
+server. It cannot be used to obtain a directory listing or for
+transferring files. It is included to allow an application to execute
+commands on the ftp server which are not provided by this package.
+The arguments are sent verbatim, i.e. as is, with no changes.
+
+[para]
+
+In contrast to the other commands in this package this command will
+not parse the response it got from the ftp server but return it
+verbatim to the caller.
+
+[call [cmd ::ftp::DisplayMsg] [arg handle] [arg msg] [opt [arg state]]]
+
+This command is used by the package itself to show the different
+messages from the ftp sessions. The package itself declares this
+command very simple, writing the messages to [const stdout] (if
+
+[var ::ftp::VERBOSE] was set, see below) and throwing tcl errors for
+error messages. It is the responsibility of the application to
+overwrite it as needed. A state variable for different states assigned
+to different colors is recommended by the author. The package
+
+[package log] is useful for this.
+
+[def [var ::ftp::VERBOSE]]
+
+A state variable controlling the output of the package. Setting
+
+[var ::ftp::VERBOSE] to "1" forces the package to show all responses
+from a remote server. The default value is "0".
+
+[def [var ::ftp::DEBUG]]
+
+A state variable controlling the output of ftp. Setting
+
+[var ::ftp::DEBUG] to "1" enables debugging and forces the package to
+show all return codes, states, state changes and "real" ftp
+commands. The default value is "0".
+
+[list_end]
+
+[section BUGS]
+[para]
+
+The correct execution of many commands depends upon the proper
+behavior by the remote server, network and router configuration.
+
+[para]
+
+An update command placed in the procedure [cmd ::ftp::DisplayMsg] may
+run into persistent errors or infinite loops. The solution to this
+problem is to use [cmd {update idletasks}] instead of [cmd update].
+
+[vset CATEGORY ftp]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/ftp/ftp.tcl b/tcllib/modules/ftp/ftp.tcl
new file mode 100644
index 0000000..f5f13c7
--- /dev/null
+++ b/tcllib/modules/ftp/ftp.tcl
@@ -0,0 +1,3159 @@
+# ftp.tcl --
+#
+# FTP library package for Tcl 8.2+. Originally written by Steffen
+# Traeger (Steffen.Traeger@t-online.de); modified by Peter MacDonald
+# (peter@pdqi.com) to support multiple simultaneous FTP sessions;
+# Modified by Steve Ball (Steve.Ball@zveno.com) to support
+# asynchronous operation.
+#
+# Copyright (c) 1996-1999 by Steffen Traeger <Steffen.Traeger@t-online.de>
+# Copyright (c) 2000 by Ajuba Solutions
+# Copyright (c) 2000 by Zveno Pty Ltd
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: ftp.tcl,v 1.50 2011/08/09 20:57:01 andreas_kupries Exp $
+#
+# core ftp support: ftp::Open <server> <user> <passwd> <?options?>
+# ftp::Close <s>
+# ftp::Cd <s> <directory>
+# ftp::Pwd <s>
+# ftp::Type <s> <?ascii|binary|tenex?>
+# ftp::List <s> <?directory?>
+# ftp::NList <s> <?directory?>
+# ftp::FileSize <s> <file>
+# ftp::ModTime <s> <file> <?newtime?>
+# ftp::Delete <s> <file>
+# ftp::Rename <s> <from> <to>
+# ftp::Put <s> <(local | -data "data" -channel chan)> <?remote?>
+# ftp::Append <s> <(local | -data "data" | -channel chan)> <?remote?>
+# ftp::Get <s> <remote> <?(local | -variable varname | -channel chan)?>
+# ftp::Reget <s> <remote> <?local?>
+# ftp::Newer <s> <remote> <?local?>
+# ftp::MkDir <s> <directory>
+# ftp::RmDir <s> <directory>
+# ftp::Quote <s> <arg1> <arg2> ...
+#
+# Internal documentation. Contents of a session state array.
+#
+# ---------------------------------------------
+# key value
+# ---------------------------------------------
+# State Current state of the session and the currently executing command.
+# RemoteFileName Name of the remote file, for put/get
+# LocalFileName Name of local file, for put/get
+# inline 1 - Put/Get is inline (from data, to variable)
+# filebuffer
+# PutData Data to move when inline
+# SourceCI Channel to read from, "Put"
+# ---------------------------------------------
+#
+
+package require Tcl 8.2
+package require log ; # tcllib/log, general logging facility.
+
+namespace eval ::ftp {
+ namespace export DisplayMsg Open Close Cd Pwd Type List NList \
+ FileSize ModTime Delete Rename Put Append Get Reget \
+ Newer Quote MkDir RmDir
+
+ variable serial 0
+ variable VERBOSE 0
+ variable DEBUG 0
+}
+
+#############################################################################
+#
+# DisplayMsg --
+#
+# This is a simple procedure to display any messages on screen.
+# Can be intercepted by the -output option to Open
+#
+# namespace ftp {
+# proc DisplayMsg {msg} {
+# ......
+# }
+# }
+#
+# Arguments:
+# msg - message string
+# state - different states {normal, data, control, error}
+#
+proc ::ftp::DisplayMsg {s msg {state ""}} {
+
+ upvar ::ftp::ftp$s ftp
+
+ if { ([info exists ftp(Output)]) && ($ftp(Output) != "") } {
+ eval [concat $ftp(Output) {$s $msg $state}]
+ return
+ }
+
+ # FIX #476729. Instead of changing the documentation this
+ # procedure is changed to enforce the documented
+ # behaviour. IOW, this procedure will not throw
+ # errors anymore. At the same time printing to stdout
+ # is exchanged against calls into the 'log' module
+ # tcllib, which is much easier to customize for the
+ # needs of any application using the ftp module. The
+ # variable VERBOSE is still relevant as it controls
+ # whether this procedure is called or not.
+
+ global errorInfo
+ switch -exact -- $state {
+ error {log::log error "$state | $msg"}
+ default {log::log debug "$state | $msg"}
+ }
+ return
+}
+
+#############################################################################
+#
+# Timeout --
+#
+# Handle timeouts
+#
+# Arguments:
+# -
+#
+proc ::ftp::Timeout {s} {
+ upvar ::ftp::ftp$s ftp
+ variable VERBOSE
+
+ if {$VERBOSE} { DisplayMsg $s Waiting|Timeout! }
+
+ after cancel $ftp(Wait)
+ set ftp(state.control) 1
+
+ DisplayMsg "" "Timeout of control connection after $ftp(Timeout) sec.!" error
+ Command $ftp(Command) timeout
+ return
+}
+
+#############################################################################
+#
+# WaitOrTimeout --
+#
+# Blocks the running procedure and waits for a variable of the transaction
+# to complete. It continues processing procedure until a procedure or
+# StateHandler sets the value of variable "finished".
+# If a connection hangs the variable is setting instead of by this procedure after
+# specified seconds in $ftp(Timeout).
+#
+#
+# Arguments:
+# -
+#
+
+proc ::ftp::WaitOrTimeout {s} {
+ upvar ::ftp::ftp$s ftp
+ variable VERBOSE
+
+ set retvar 1
+
+ if { ![string length $ftp(Command)] && [info exists ftp(state.control)] } {
+
+ if {$VERBOSE} { DisplayMsg $s Waiting|$ftp(Timeout)|\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\# }
+
+ set ftp(Wait) [after [expr {$ftp(Timeout) * 1000}] [list [namespace current]::Timeout $s]]
+
+ vwait ::ftp::ftp${s}(state.control)
+ set retvar $ftp(state.control)
+
+ if {$VERBOSE} { DisplayMsg $s Waiting|Done|\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\# }
+ }
+
+ if {$ftp(Error) != ""} {
+ set errmsg $ftp(Error)
+ set ftp(Error) ""
+ DisplayMsg $s $errmsg error
+ }
+
+ if {$VERBOSE} { DisplayMsg $s Waiting|OK|$retvar }
+ return $retvar
+}
+
+#############################################################################
+#
+# WaitComplete --
+#
+# Transaction completed.
+# Cancel execution of the delayed command declared in procedure WaitOrTimeout.
+#
+# Arguments:
+# value - result of the transaction
+# 0 ... Error
+# 1 ... OK
+#
+
+proc ::ftp::WaitComplete {s value} {
+ variable VERBOSE
+ upvar ::ftp::ftp$s ftp
+
+ if {$VERBOSE} { DisplayMsg $s Waiting|Complete|$s|$value|\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\# }
+
+ if {![info exists ftp(Command)]} {
+ set ftp(state.control) $value
+
+ if {$VERBOSE} { DisplayMsg $s Waiting|Complete|Done/Command|$value|\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\# }
+ return $value
+ }
+ if { ![string length $ftp(Command)] && [info exists ftp(state.data)] } {
+
+ if {$VERBOSE} { DisplayMsg $s Waiting|State|\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\# }
+
+ vwait ::ftp::ftp${s}(state.data)
+
+ if {$VERBOSE} { DisplayMsg $s Waiting|State|Done|\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\# }
+ }
+
+ catch {after cancel $ftp(Wait)}
+ set ftp(state.control) $value
+
+ if {$VERBOSE} { DisplayMsg $s Waiting|OK|$ftp(state.control)|\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\#\# }
+
+ return $ftp(state.control)
+}
+
+#############################################################################
+#
+# PutsCtrlSocket --
+#
+# Puts then specified command to control socket,
+# if DEBUG is set than it logs via DisplayMsg
+#
+# Arguments:
+# command - ftp command
+#
+
+proc ::ftp::PutsCtrlSock {s {command ""}} {
+ upvar ::ftp::ftp$s ftp
+ variable DEBUG
+
+ if { $DEBUG } {
+ DisplayMsg $s "---> $command"
+ }
+
+ puts $ftp(CtrlSock) $command
+ flush $ftp(CtrlSock)
+ return
+}
+
+#############################################################################
+#
+# StateHandler --
+#
+# Implements a finite state handler and a fileevent handler
+# for the control channel
+#
+# Arguments:
+# sock - socket name
+# If called from a procedure than this argument is empty.
+# If called from a fileevent than this argument contains
+# the socket channel identifier.
+
+proc ::ftp::StateHandler {s {sock ""}} {
+ upvar ::ftp::ftp$s ftp
+ variable DEBUG
+ variable VERBOSE
+
+ if {$VERBOSE} { DisplayMsg $s StateHandler/$s/$sock/================================================ }
+
+ # disable fileevent on control socket, enable it at the and of the state machine
+ # fileevent $ftp(CtrlSock) readable {}
+
+ # there is no socket (and no channel to get) if called from a procedure
+
+ set rc " "
+ set msgtext {}
+
+ if { $sock != "" } {
+
+ set number 0 ;# Error condition
+ catch {set number [gets $sock bufline]}
+
+ if { $number > 0 } {
+
+ # get return code, check for multi-line text
+
+ if {![regexp -- "^-?(\[0-9\]+)( |-)?(.*)$" $bufline all rc multi_line msgtext]} {
+ set errmsg "C: Internal Error @ line 255.\
+ Regex pattern not matching the input \"$bufline\""
+ if {$VERBOSE} {
+ DisplayMsg $s $errmsg control
+ }
+ } else {
+ # multi-line format detected ("-"), get all the lines
+ # until the real return code
+
+ set buffer $bufline
+
+ while { [string equal $multi_line "-"] } {
+ set number [gets $sock bufline]
+ if { $number > 0 } {
+ append buffer \n "$bufline"
+ regexp -- "(^\[0-9\]+)( |-)?(.*)$" $bufline all rc multi_line
+ # multi_line is not set if the bufline does not match the regexp,
+ # I.e. this keeps the '-' which started this around until the
+ # closing line does match and sets it to space.
+ } elseif {$number == -1 && [eof $sock]} {
+ # The reply indicated a multi-line reply, but the
+ # socket was closed and there were no more lines.
+ # In that case, keep the current return values.
+
+ # This means the server isn't speaking strict rfc959.
+ # see section on multi-line replies
+ break
+ }
+ }
+
+ # Export the accumulated response. [Bug 1191607].
+ set msgtext $buffer
+ }
+ } elseif { [eof $ftp(CtrlSock)] } {
+ # remote server has closed control connection. kill
+ # control socket, unset State to disable all following
+ # commands. Killing the socket is done before
+ # 'WaitComplete' to prevent it from recursively entering
+ # this code, overflowing the stack (socket still existing,
+ # still readable, still eof). [SF Tcllib Bug 15822535].
+
+ set rc 421
+ catch {close $ftp(CtrlSock)}
+ catch {unset ftp(CtrlSock)}
+ catch {unset ftp(state.data)}
+ if { $VERBOSE } {
+ DisplayMsg $s "C: 421 Service not available, closing control connection." control
+ }
+ if {![string equal $ftp(State) "quit_sent"]} {
+ set ftp(Error) "Service not available!"
+ }
+ CloseDataConn $s
+ WaitComplete $s 0
+ Command $ftp(Command) terminated
+ catch {unset ftp(State)}
+
+ if {$VERBOSE} { DisplayMsg $s EOF/Control }
+ return
+ } else {
+ # Fix SF bug #466746: Incomplete line, do nothing.
+ if {$VERBOSE} { DisplayMsg $s Incomplete/Line }
+ return
+ }
+ }
+
+ if { $DEBUG } {
+ DisplayMsg $s "-> rc=\"$rc\" -> msgtext=\"$msgtext\" -> state=\"$ftp(State)\""
+ }
+
+ # In asynchronous mode, should we move on to the next state?
+ set nextState 0
+
+ # system status replay
+ if { [string equal $rc "211"] } {
+ if {$VERBOSE} { DisplayMsg $s Ignore/211 }
+ return
+ }
+
+ # use only the first digit
+ regexp -- "^\[0-9\]?" $rc rc
+
+ if {$VERBOSE} { DisplayMsg $s StateBegin////////($ftp(State)) }
+
+ switch -exact -- $ftp(State) {
+ user {
+ switch -exact -- $rc {
+ 2 {
+ PutsCtrlSock $s "USER $ftp(User)"
+ set ftp(State) passwd
+ Command $ftp(Command) user
+ }
+ default {
+ set errmsg "Error connecting! $msgtext"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ passwd {
+ switch -exact -- $rc {
+ 2 {
+ set complete_with 1
+ Command $ftp(Command) password
+ }
+ 3 {
+ PutsCtrlSock $s "PASS $ftp(Passwd)"
+ set ftp(State) connect
+ Command $ftp(Command) password
+ }
+ default {
+ set errmsg "Error connecting! $msgtext"
+ set complete_with 0
+ Command $ftp(Command) error $msgtext
+ }
+ }
+ }
+ connect {
+ switch -exact -- $rc {
+ 2 {
+ # The type is set after this, and we want to report
+ # that the connection is complete once the type is done
+ set nextState 1
+ if {[info exists ftp(NextState)] && ![llength $ftp(NextState)]} {
+ Command $ftp(Command) connect $s
+ } else {
+ set complete_with 1
+ }
+ }
+ default {
+ set errmsg "Error connecting! $msgtext"
+ set complete_with 0
+ Command $ftp(Command) error $msgtext
+ }
+ }
+ }
+ connect_last {
+ Command $ftp(Command) connect $s
+ set complete_with 1
+ }
+ quit {
+ PutsCtrlSock $s "QUIT"
+ set ftp(State) quit_sent
+ }
+ quit_sent {
+ switch -exact -- $rc {
+ 2 {
+ set complete_with 1
+ set nextState 1
+ Command $ftp(Command) quit
+ }
+ default {
+ set errmsg "Error disconnecting! $msgtext"
+ set complete_with 0
+ Command $ftp(Command) error $msgtext
+ }
+ }
+ }
+ quote {
+ PutsCtrlSock $s $ftp(Cmd)
+ set ftp(State) quote_sent
+ }
+ quote_sent {
+ set complete_with 1
+ set ftp(Quote) $buffer
+ set nextState 1
+ Command $ftp(Command) quote $buffer
+ }
+ type {
+ if { [string equal $ftp(Type) "ascii"] } {
+ PutsCtrlSock $s "TYPE A"
+ } elseif { [string equal $ftp(Type) "binary"] } {
+ PutsCtrlSock $s "TYPE I"
+ } else {
+ PutsCtrlSock $s "TYPE L"
+ }
+ set ftp(State) type_sent
+ }
+ type_sent {
+ switch -exact -- $rc {
+ 2 {
+ set complete_with 1
+ set nextState 1
+ Command $ftp(Command) type $ftp(Type)
+ }
+ default {
+ set errmsg "Error setting type \"$ftp(Type)\"!"
+ set complete_with 0
+ Command $ftp(Command) error "error setting type \"$ftp(Type)\""
+ }
+ }
+ }
+ type_change {
+ set ftp(Type) $ftp(type:changeto)
+ set ftp(State) type
+ StateHandler $s
+ }
+ nlist_active {
+ if { [OpenActiveConn $s] } {
+ PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)"
+ set ftp(State) nlist_open
+ } else {
+ set errmsg "Error setting port!"
+ }
+ }
+ nlist_passive {
+ PutsCtrlSock $s "PASV"
+ set ftp(State) nlist_open
+ }
+ nlist_open {
+ switch -exact -- $rc {
+ 1 {}
+ 2 {
+ if { [string equal $ftp(Mode) "passive"] } {
+ if { ![OpenPassiveConn $s $buffer] } {
+ set errmsg "Error setting PASSIVE mode!"
+ set complete_with 0
+ Command $ftp(Command) error "error setting passive mode"
+ }
+ }
+ PutsCtrlSock $s "NLST$ftp(Dir)"
+ set ftp(State) list_sent
+ }
+ default {
+ if { [string equal $ftp(Mode) "passive"] } {
+ set errmsg "Error setting PASSIVE mode!"
+ } else {
+ set errmsg "Error setting port!"
+ }
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ list_active {
+ if { [OpenActiveConn $s] } {
+ PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)"
+ set ftp(State) list_open
+ } else {
+ set errmsg "Error setting port!"
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ list_passive {
+ PutsCtrlSock $s "PASV"
+ set ftp(State) list_open
+ }
+ list_open {
+ switch -exact -- $rc {
+ 1 {}
+ 2 {
+ if { [string equal $ftp(Mode) "passive"] } {
+ if { ![OpenPassiveConn $s $buffer] } {
+ set errmsg "Error setting PASSIVE mode!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ PutsCtrlSock $s "LIST$ftp(Dir)"
+ set ftp(State) list_sent
+ }
+ default {
+ if { [string equal $ftp(Mode) "passive"] } {
+ set errmsg "Error setting PASSIVE mode!"
+ } else {
+ set errmsg "Error setting port!"
+ }
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ list_sent {
+ switch -exact -- $rc {
+ 1 -
+ 2 {
+ set ftp(State) list_close
+ }
+ default {
+ if { [string equal $ftp(Mode) "passive"] } {
+ catch {unset ftp(state.data)}
+ }
+ set errmsg "Error getting directory listing!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ list_close {
+ switch -exact -- $rc {
+ 1 {}
+ 2 {
+ # Sync control sequencer to active data connection
+ # before stepping out
+ WaitDataConn $s
+
+ set nextState 1
+ if {[info exists ftp(NextState)] && ![llength $ftp(NextState)]} {
+ Command $ftp(Command) list [ListPostProcess $ftp(List)]
+ } else {
+ set complete_with 1
+ }
+ }
+ default {
+ set errmsg "Error receiving list!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ list_last {
+ Command $ftp(Command) list [ListPostProcess $ftp(List)]
+ set complete_with 1
+ }
+ size {
+ PutsCtrlSock $s "SIZE $ftp(File)"
+ set ftp(State) size_sent
+ }
+ size_sent {
+ switch -exact -- $rc {
+ 2 {
+ regexp -- "^\[0-9\]+ (.*)$" $buffer all ftp(FileSize)
+ set complete_with 1
+ set nextState 1
+ Command $ftp(Command) size $ftp(File) $ftp(FileSize)
+ }
+ default {
+ set errmsg "Error getting file size!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ modtime {
+ if {$ftp(DateTime) != ""} {
+ PutsCtrlSock $s "MDTM $ftp(DateTime) $ftp(File)"
+ } else { ;# No DateTime Specified
+ PutsCtrlSock $s "MDTM $ftp(File)"
+ }
+ set ftp(State) modtime_sent
+ }
+ modtime_sent {
+ switch -exact -- $rc {
+ 2 {
+ regexp -- "^\[0-9\]+ (.*)$" $buffer all ftp(DateTime)
+ set complete_with 1
+ set nextState 1
+ Command $ftp(Command) modtime $ftp(File) [ModTimePostProcess $ftp(DateTime)]
+ }
+ default {
+ if {$ftp(DateTime) != ""} {
+ set errmsg "Error setting modification time! No server MDTM support?"
+ } else {
+ set errmsg "Error getting modification time!"
+ }
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ pwd {
+ PutsCtrlSock $s "PWD"
+ set ftp(State) pwd_sent
+ }
+ pwd_sent {
+ switch -exact -- $rc {
+ 2 {
+ regexp -- "^.*\"(.*)\"" $buffer temp ftp(Dir)
+ set complete_with 1
+ set nextState 1
+ Command $ftp(Command) pwd $ftp(Dir)
+ }
+ default {
+ set errmsg "Error getting working dir!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ cd {
+ PutsCtrlSock $s "CWD$ftp(Dir)"
+ set ftp(State) cd_sent
+ }
+ cd_sent {
+ switch -exact -- $rc {
+ 1 {}
+ 2 {
+ set complete_with 1
+ set nextState 1
+ Command $ftp(Command) cd $ftp(Dir)
+ }
+ default {
+ set errmsg "Error changing directory to \"$ftp(Dir)\""
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ mkdir {
+ PutsCtrlSock $s "MKD $ftp(Dir)"
+ set ftp(State) mkdir_sent
+ }
+ mkdir_sent {
+ switch -exact -- $rc {
+ 2 {
+ set complete_with 1
+ set nextState 1
+ Command $ftp(Command) mkdir $ftp(Dir)
+ }
+ default {
+ set errmsg "Error making dir \"$ftp(Dir)\"!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ rmdir {
+ PutsCtrlSock $s "RMD $ftp(Dir)"
+ set ftp(State) rmdir_sent
+ }
+ rmdir_sent {
+ switch -exact -- $rc {
+ 2 {
+ set complete_with 1
+ set nextState 1
+ Command $ftp(Command) rmdir $ftp(Dir)
+ }
+ default {
+ set errmsg "Error removing directory!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ delete {
+ PutsCtrlSock $s "DELE $ftp(File)"
+ set ftp(State) delete_sent
+ }
+ delete_sent {
+ switch -exact -- $rc {
+ 2 {
+ set complete_with 1
+ set nextState 1
+ Command $ftp(Command) delete $ftp(File)
+ }
+ default {
+ set errmsg "Error deleting file \"$ftp(File)\"!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ rename {
+ PutsCtrlSock $s "RNFR $ftp(RenameFrom)"
+ set ftp(State) rename_to
+ }
+ rename_to {
+ switch -exact -- $rc {
+ 3 {
+ PutsCtrlSock $s "RNTO $ftp(RenameTo)"
+ set ftp(State) rename_sent
+ }
+ default {
+ set errmsg "Error renaming file \"$ftp(RenameFrom)\"!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ rename_sent {
+ switch -exact -- $rc {
+ 2 {
+ set complete_with 1
+ set nextState 1
+ Command $ftp(Command) rename $ftp(RenameFrom) $ftp(RenameTo)
+ }
+ default {
+ set errmsg "Error renaming file \"$ftp(RenameFrom)\"!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ put_active {
+ if { [OpenActiveConn $s] } {
+ PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)"
+ set ftp(State) put_open
+ } else {
+ set errmsg "Error setting port!"
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ put_passive {
+ PutsCtrlSock $s "PASV"
+ set ftp(State) put_open
+ }
+ put_open {
+ switch -exact -- $rc {
+ 1 -
+ 2 {
+ if { [string equal $ftp(Mode) "passive"] } {
+ if { ![OpenPassiveConn $s $buffer] } {
+ set errmsg "Error setting PASSIVE mode!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ PutsCtrlSock $s "STOR $ftp(RemoteFilename)"
+ set ftp(State) put_sent
+ }
+ default {
+ if { [string equal $ftp(Mode) "passive"] } {
+ set errmsg "Error setting PASSIVE mode!"
+ } else {
+ set errmsg "Error setting port!"
+ }
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ put_sent {
+ switch -exact -- $rc {
+ 1 -
+ 2 {
+ set ftp(State) put_close
+ }
+ default {
+ if { [string equal $ftp(Mode) "passive"] } {
+ # close already opened DataConnection
+ catch {unset ftp(state.data)}
+ }
+ set errmsg "Error opening connection!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ put_close {
+ switch -exact -- $rc {
+ 1 {
+ # Keep going
+ if {$VERBOSE} { DisplayMsg $s put_close/1--continue }
+ return
+ }
+ 2 {
+ # Sync control sequencer to active data connection
+ # before stepping out
+ WaitDataConn $s
+
+ set complete_with 1
+ set nextState 1
+ Command $ftp(Command) put $ftp(RemoteFilename)
+ }
+ default {
+ DisplayMsg $s "rc = $rc msgtext = \"$msgtext\""
+ set errmsg "Error storing file \"$ftp(RemoteFilename)\" due to \"$msgtext\""
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ append_active {
+ if { [OpenActiveConn $s] } {
+ PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)"
+ set ftp(State) append_open
+ } else {
+ set errmsg "Error setting port!"
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ append_passive {
+ PutsCtrlSock $s "PASV"
+ set ftp(State) append_open
+ }
+ append_open {
+ switch -exact -- $rc {
+ 1 -
+ 2 {
+ if { [string equal $ftp(Mode) "passive"] } {
+ if { ![OpenPassiveConn $s $buffer] } {
+ set errmsg "Error setting PASSIVE mode!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ PutsCtrlSock $s "APPE $ftp(RemoteFilename)"
+ set ftp(State) append_sent
+ }
+ default {
+ if { [string equal $ftp(Mode) "passive"] } {
+ set errmsg "Error setting PASSIVE mode!"
+ } else {
+ set errmsg "Error setting port!"
+ }
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ append_sent {
+ switch -exact -- $rc {
+ 1 {
+ set ftp(State) append_close
+ }
+ default {
+ if { [string equal $ftp(Mode) "passive"] } {
+ # close already opened DataConnection
+ catch {unset ftp(state.data)}
+ }
+ set errmsg "Error opening connection!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ append_close {
+ switch -exact -- $rc {
+ 2 {
+ # Sync control sequencer to active data connection
+ # before stepping out
+ WaitDataConn $s
+
+ set complete_with 1
+ set nextState 1
+ Command $ftp(Command) append $ftp(RemoteFilename)
+ }
+ default {
+ set errmsg "Error storing file \"$ftp(RemoteFilename)\"!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ reget_active {
+ if { [OpenActiveConn $s] } {
+ PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)"
+ set ftp(State) reget_restart
+ } else {
+ set errmsg "Error setting port!"
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ reget_passive {
+ PutsCtrlSock $s "PASV"
+ set ftp(State) reget_restart
+ }
+ reget_restart {
+ switch -exact -- $rc {
+ 2 {
+ if { [string equal $ftp(Mode) "passive"] } {
+ if { ![OpenPassiveConn $s $buffer] } {
+ set errmsg "Error setting PASSIVE mode!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ if { $ftp(FileSize) != 0 } {
+ PutsCtrlSock $s "REST $ftp(FileSize)"
+ set ftp(State) reget_open
+ } else {
+ PutsCtrlSock $s "RETR $ftp(RemoteFilename)"
+ set ftp(State) reget_sent
+ }
+ }
+ default {
+ set errmsg "Error restarting filetransfer of \"$ftp(RemoteFilename)\"!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ reget_open {
+ switch -exact -- $rc {
+ 2 -
+ 3 {
+ PutsCtrlSock $s "RETR $ftp(RemoteFilename)"
+ set ftp(State) reget_sent
+ }
+ default {
+ if { [string equal $ftp(Mode) "passive"] } {
+ set errmsg "Error setting PASSIVE mode!"
+ } else {
+ set errmsg "Error setting port!"
+ }
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ reget_sent {
+ switch -exact -- $rc {
+ 1 {
+ set ftp(State) reget_close
+ }
+ default {
+ if { [string equal $ftp(Mode) "passive"] } {
+ # close already opened DataConnection
+ catch {unset ftp(state.data)}
+ }
+ set errmsg "Error retrieving file \"$ftp(RemoteFilename)\"!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ reget_close {
+ switch -exact -- $rc {
+ 2 {
+ # Sync control sequencer to active data connection
+ # before stepping out
+ WaitDataConn $s
+
+ set complete_with 1
+ set nextState 1
+ Command $ftp(Command) get $ftp(RemoteFilename):$ftp(From):$ftp(To)
+ unset ftp(From) ftp(To)
+ }
+ default {
+ set errmsg "Error retrieving file \"$ftp(RemoteFilename)\"!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ get_active {
+ if { [OpenActiveConn $s] } {
+ PutsCtrlSock $s "PORT $ftp(LocalAddr),$ftp(DataPort)"
+ set ftp(State) get_open
+ } else {
+ set errmsg "Error setting port!"
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ get_passive {
+ PutsCtrlSock $s "PASV"
+ set ftp(State) get_open
+ }
+ get_open {
+ switch -exact -- $rc {
+ 1 -
+ 2 -
+ 3 {
+ if { [string equal $ftp(Mode) "passive"] } {
+ if { ![OpenPassiveConn $s $buffer] } {
+ set errmsg "Error setting PASSIVE mode!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ PutsCtrlSock $s "RETR $ftp(RemoteFilename)"
+ set ftp(State) get_sent
+ }
+ default {
+ if { [string equal $ftp(Mode) "passive"] } {
+ set errmsg "Error setting PASSIVE mode!"
+ } else {
+ set errmsg "Error setting port!"
+ }
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ get_sent {
+ switch -exact -- $rc {
+ 1 {
+ set ftp(State) get_close
+ }
+ default {
+ if { [string equal $ftp(Mode) "passive"] } {
+ # close already opened DataConnection
+ catch {unset ftp(state.data)}
+ }
+ set errmsg "Error retrieving file \"$ftp(RemoteFilename)\"!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ get_close {
+ switch -exact -- $rc {
+ 2 {
+ # Sync control sequencer to active data connection
+ # before stepping out
+ WaitDataConn $s
+
+ set complete_with 1
+ set nextState 1
+ if {$ftp(inline)} {
+ upvar #0 $ftp(get:varname) returnData
+ set returnData $ftp(GetData)
+ Command $ftp(Command) get $ftp(GetData)
+ } else {
+ Command $ftp(Command) get $ftp(RemoteFilename)
+ }
+ }
+ default {
+ set errmsg "Error retrieving file \"$ftp(RemoteFilename)\"!"
+ set complete_with 0
+ Command $ftp(Command) error $errmsg
+ }
+ }
+ }
+ default {
+ error "Unknown state \"$ftp(State)\""
+ }
+ }
+
+ if {$VERBOSE} { DisplayMsg $s ////////StateDone==>$ftp(State) }
+
+ # finish waiting
+ if { [info exists complete_with] } {
+ if {$VERBOSE} { DisplayMsg $s WaitBegin////////($complete_with) }
+
+ WaitComplete $s $complete_with
+
+ if {$VERBOSE} { DisplayMsg $s ////////WaitDone }
+ }
+
+ # display control channel message
+ if { [info exists buffer] } {
+ if { $VERBOSE } {
+ foreach line [split $buffer \n] {
+ DisplayMsg $s "C: $line" control
+ }
+ }
+ }
+
+ # Rather than throwing an error in the event loop, set the ftp(Error)
+ # variable to hold the message so that it can later be thrown after the
+ # the StateHandler has completed.
+
+ if { [info exists errmsg] } {
+ set ftp(Error) $errmsg
+ }
+
+ # If operating asynchronously, commence next state
+ if {$VERBOSE} {
+ DisplayMsg $s "ns=$nextState, NS=[info exists ftp(NextState)], NSlen=[expr {[info exists ftp(NextState)] && [llength $ftp(NextState)]}]"
+ }
+ if {$nextState && [info exists ftp(NextState)] && [llength $ftp(NextState)]} {
+ # Pop the head of the NextState queue
+ if {$VERBOSE} { DisplayMsg $s Sequence=($ftp(NextState)) }
+
+ set ftp(State) [lindex $ftp(NextState) 0]
+ set ftp(NextState) [lreplace $ftp(NextState) 0 0]
+
+ if {$VERBOSE} { DisplayMsg $s Recurse/StateHandler }
+ StateHandler $s
+ }
+
+ # enable fileevent on control socket again
+ #fileevent $ftp(CtrlSock) readable [list ::ftp::StateHandler $ftp(CtrlSock)]
+
+ if {$VERBOSE} { DisplayMsg $s ======/HandlerDone }
+ return
+}
+
+#############################################################################
+#
+# Type --
+#
+# REPRESENTATION TYPE - Sets the file transfer type to ascii or binary.
+# (exported)
+#
+# Arguments:
+# type - specifies the representation type (ascii|binary)
+#
+# Returns:
+# type - returns the current type or {} if an error occurs
+
+proc ::ftp::Type {s {type ""}} {
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ if { ![string is digit -strict $s] } {
+ DisplayMsg $s "Bad connection name \"$s\"" error
+ } else {
+ DisplayMsg $s "Not connected!" error
+ }
+ return {}
+ }
+
+ # return current type
+ if { $type == "" } {
+ return $ftp(Type)
+ }
+
+ # save current type
+ set old_type $ftp(Type)
+
+ set ftp(Type) $type
+ set ftp(State) type
+ StateHandler $s
+
+ # wait for synchronization
+ set rc [WaitOrTimeout $s]
+ if { $rc } {
+ return $ftp(Type)
+ } else {
+ # restore old type
+ set ftp(Type) $old_type
+ return {}
+ }
+}
+
+#############################################################################
+#
+# NList --
+#
+# NAME LIST - This command causes a directory listing to be sent from
+# server to user site.
+# (exported)
+#
+# Arguments:
+# dir - The $dir should specify a directory or other system
+# specific file group descriptor; a null argument
+# implies the current directory.
+#
+# Arguments:
+# dir - directory to list
+#
+# Returns:
+# sorted list of files or {} if listing fails
+
+proc ::ftp::NList {s { dir ""}} {
+ variable VERBOSE
+ upvar ::ftp::ftp$s ftp
+
+ if {$VERBOSE} { DisplayMsg $s NList($s)($dir)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }
+
+ if { ![info exists ftp(State)] } {
+ if { ![string is digit -strict $s] } {
+ DisplayMsg $s "Bad connection name \"$s\"" error
+ } else {
+ DisplayMsg $s "Not connected!" error
+ }
+ return {}
+ }
+
+ set ftp(List) {}
+ if { $dir == "" } {
+ set ftp(Dir) ""
+ } else {
+ set ftp(Dir) " $dir"
+ }
+
+ # save current type and force ascii mode
+ set old_type $ftp(Type)
+ if { $ftp(Type) != "ascii" } {
+ if {$VERBOSE} { DisplayMsg $s NList/ForceAscii }
+
+ if {[string length $ftp(Command)]} {
+ set ftp(NextState) [list nlist_$ftp(Mode) type_change list_last]
+ set ftp(type:changeto) $old_type
+ Type $s ascii
+ return {}
+ }
+ Type $s ascii
+ }
+
+ set ftp(State) nlist_$ftp(Mode)
+
+ if {$VERBOSE} { DisplayMsg $s NList/Process~~~~~~~~~~~~~~~~~~~ }
+ StateHandler $s
+
+ if {$VERBOSE} { DisplayMsg $s NList/Processed~~~~~~~~~~~~~~~~~ }
+
+ # wait for synchronization
+ set rc [WaitOrTimeout $s]
+
+ # restore old type
+ if {$VERBOSE} { DisplayMsg $s NList/RestoreType~~~~~~~~~~~~~~~~~~~~~ }
+ if { [Type $s] != $old_type } {
+ Type $s $old_type
+ }
+
+ unset ftp(Dir)
+ if { $rc } {
+ if {$VERBOSE} { DisplayMsg $s NList/ReturnData~~~~~~~~~~~~~~~~~~~~~~~ }
+
+ return [lsort [split [string trim $ftp(List) \n] \n]]
+ } else {
+ if {$VERBOSE} { DisplayMsg $s NList/CDC~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ }
+
+ CloseDataConn $s
+ return {}
+ }
+
+ if {$VERBOSE} { DisplayMsg $s ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~NList/Done }
+}
+
+#############################################################################
+#
+# List --
+#
+# LIST - This command causes a list to be sent from the server
+# to user site.
+# (exported)
+#
+# Arguments:
+# dir - If the $dir specifies a directory or other group of
+# files, the server should transfer a list of files in
+# the specified directory. If the $dir specifies a file
+# then the server should send current information on the
+# file. A null argument implies the user's current
+# working or default directory.
+#
+# Returns:
+# list of files or {} if listing fails
+
+proc ::ftp::List {s {dir ""}} {
+
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ if { ![string is digit -strict $s] } {
+ DisplayMsg $s "Bad connection name \"$s\"" error
+ } else {
+ DisplayMsg $s "Not connected!" error
+ }
+ return {}
+ }
+
+ set ftp(List) {}
+ if { $dir == "" } {
+ set ftp(Dir) ""
+ } else {
+ set ftp(Dir) " $dir"
+ }
+
+ # save current type and force ascii mode
+
+ set old_type $ftp(Type)
+ if { ![string equal "$ftp(Type)" "ascii"] } {
+ if {[string length $ftp(Command)]} {
+ set ftp(NextState) [list list_$ftp(Mode) type_change list_last]
+ set ftp(type:changeto) $old_type
+ Type $s ascii
+ return {}
+ }
+ Type $s ascii
+ }
+
+ set ftp(State) list_$ftp(Mode)
+ StateHandler $s
+
+ # wait for synchronization
+
+ set rc [WaitOrTimeout $s]
+
+ # restore old type
+
+ if { ![string equal "[Type $s]" "$old_type"] } {
+ Type $s $old_type
+ }
+
+ unset ftp(Dir)
+ if { $rc } {
+ return [ListPostProcess $ftp(List)]
+ } else {
+ CloseDataConn $s
+ return {}
+ }
+}
+
+proc ::ftp::ListPostProcess l {
+
+ # clear "total"-line
+
+ set l [split $l "\n"]
+ set index [lsearch -regexp $l "^total"]
+ if { $index != "-1" } {
+ set l [lreplace $l $index $index]
+ }
+
+ # clear blank line
+
+ set index [lsearch -regexp $l "^$"]
+ if { $index != "-1" } {
+ set l [lreplace $l $index $index]
+ }
+
+ return $l
+}
+
+#############################################################################
+#
+# FileSize --
+#
+# REMOTE FILE SIZE - This command gets the file size of the
+# file on the remote machine.
+# ATTENTION! Doesn't work properly in ascii mode!
+# (exported)
+#
+# Arguments:
+# filename - specifies the remote file name
+#
+# Returns:
+# size - files size in bytes or {} in error cases
+
+proc ::ftp::FileSize {s {filename ""}} {
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ if { ![string is digit -strict $s] } {
+ DisplayMsg $s "Bad connection name \"$s\"" error
+ } else {
+ DisplayMsg $s "Not connected!" error
+ }
+ return {}
+ }
+
+ if { $filename == "" } {
+ return {}
+ }
+
+ set ftp(File) $filename
+ set ftp(FileSize) 0
+
+ set ftp(State) size
+ StateHandler $s
+
+ # wait for synchronization
+ set rc [WaitOrTimeout $s]
+
+ if {![string length $ftp(Command)]} {
+ unset ftp(File)
+ }
+
+ if { $rc } {
+ return $ftp(FileSize)
+ } else {
+ return {}
+ }
+}
+
+
+#############################################################################
+#
+# ModTime --
+#
+# MODIFICATION TIME - This command gets the last modification time of the
+# file on the remote machine.
+# (exported)
+#
+# Arguments:
+# filename - specifies the remote file name
+# datetime - optional new timestamp for file
+#
+# Returns:
+# clock - files date and time as a system-depentend integer
+# value in seconds (see tcls clock command) or {} in
+# error cases
+# if MDTM not supported on server, returns original timestamp
+
+proc ::ftp::ModTime {s {filename ""} {datetime ""}} {
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ if { ![string is digit -strict $s] } {
+ DisplayMsg $s "Bad connection name \"$s\"" error
+ } else {
+ DisplayMsg $s "Not connected!" error
+ }
+ return {}
+ }
+
+ if { $filename == "" } {
+ return {}
+ }
+
+ set ftp(File) $filename
+
+ if {$datetime != ""} {
+ set datetime [clock format $datetime -format "%Y%m%d%H%M%S"]
+ }
+ set ftp(DateTime) $datetime
+
+ set ftp(State) modtime
+ StateHandler $s
+
+ # wait for synchronization
+ set rc [WaitOrTimeout $s]
+
+ if {![string length $ftp(Command)]} {
+ unset ftp(File)
+ }
+ if { ![string length $ftp(Command)] && $rc } {
+ return [ModTimePostProcess $ftp(DateTime)]
+ } else {
+ return {}
+ }
+}
+
+proc ::ftp::ModTimePostProcess {clock} {
+ foreach {year month day hour min sec} {1 1 1 1 1 1} break
+
+ # Bug #478478. Special code to detect ftp servers with a Y2K patch
+ # gone bad and delivering, hmmm, non-standard date information.
+
+ if {[string length $clock] == 15} {
+ scan $clock "%2s%3s%2s%2s%2s%2s%2s" cent year month day hour min sec
+ set year [expr {($cent * 100) + $year}]
+ log::log warning "data | W: server with non-standard time, bad Y2K patch."
+ } else {
+ scan $clock "%4s%2s%2s%2s%2s%2s" year month day hour min sec
+ }
+
+ set clock [clock scan "$month/$day/$year $hour:$min:$sec" -gmt 1]
+ return $clock
+}
+
+#############################################################################
+#
+# Pwd --
+#
+# PRINT WORKING DIRECTORY - Causes the name of the current working directory.
+# (exported)
+#
+# Arguments:
+# None.
+#
+# Returns:
+# current directory name
+
+proc ::ftp::Pwd {s } {
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ if { ![string is digit -strict $s] } {
+ DisplayMsg $s "Bad connection name \"$s\"" error
+ } else {
+ DisplayMsg $s "Not connected!" error
+ }
+ return {}
+ }
+
+ set ftp(Dir) {}
+
+ set ftp(State) pwd
+ StateHandler $s
+
+ # wait for synchronization
+ set rc [WaitOrTimeout $s]
+
+ if { $rc } {
+ return $ftp(Dir)
+ } else {
+ return {}
+ }
+}
+
+#############################################################################
+#
+# Cd --
+#
+# CHANGE DIRECTORY - Sets the working directory on the server host.
+# (exported)
+#
+# Arguments:
+# dir - pathname specifying a directory
+#
+# Returns:
+# 0 - ERROR
+# 1 - OK
+
+proc ::ftp::Cd {s {dir ""}} {
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ if { ![string is digit -strict $s] } {
+ DisplayMsg $s "Bad connection name \"$s\"" error
+ } else {
+ DisplayMsg $s "Not connected!" error
+ }
+ return 0
+ }
+
+ if { $dir == "" } {
+ set ftp(Dir) ""
+ } else {
+ set ftp(Dir) " $dir"
+ }
+
+ set ftp(State) cd
+ StateHandler $s
+
+ # wait for synchronization
+ set rc [WaitOrTimeout $s]
+
+ if {![string length $ftp(Command)]} {
+ unset ftp(Dir)
+ }
+
+ if { $rc } {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+#############################################################################
+#
+# MkDir --
+#
+# MAKE DIRECTORY - This command causes the directory specified in the $dir
+# to be created as a directory (if the $dir is absolute) or as a subdirectory
+# of the current working directory (if the $dir is relative).
+# (exported)
+#
+# Arguments:
+# dir - new directory name
+#
+# Returns:
+# 0 - ERROR
+# 1 - OK
+
+proc ::ftp::MkDir {s dir} {
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ DisplayMsg $s "Not connected!" error
+ return 0
+ }
+
+ set ftp(Dir) $dir
+
+ set ftp(State) mkdir
+ StateHandler $s
+
+ # wait for synchronization
+ set rc [WaitOrTimeout $s]
+
+ if {![string length $ftp(Command)]} {
+ unset ftp(Dir)
+ }
+
+ if { $rc } {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+#############################################################################
+#
+# RmDir --
+#
+# REMOVE DIRECTORY - This command causes the directory specified in $dir to
+# be removed as a directory (if the $dir is absolute) or as a
+# subdirectory of the current working directory (if the $dir is relative).
+# (exported)
+#
+# Arguments:
+# dir - directory name
+#
+# Returns:
+# 0 - ERROR
+# 1 - OK
+
+proc ::ftp::RmDir {s dir} {
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ DisplayMsg $s "Not connected!" error
+ return 0
+ }
+
+ set ftp(Dir) $dir
+
+ set ftp(State) rmdir
+ StateHandler $s
+
+ # wait for synchronization
+ set rc [WaitOrTimeout $s]
+
+ if {![string length $ftp(Command)]} {
+ unset ftp(Dir)
+ }
+
+ if { $rc } {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+#############################################################################
+#
+# Delete --
+#
+# DELETE - This command causes the file specified in $file to be deleted at
+# the server site.
+# (exported)
+#
+# Arguments:
+# file - file name
+#
+# Returns:
+# 0 - ERROR
+# 1 - OK
+
+proc ::ftp::Delete {s file} {
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ DisplayMsg $s "Not connected!" error
+ return 0
+ }
+
+ set ftp(File) $file
+
+ set ftp(State) delete
+ StateHandler $s
+
+ # wait for synchronization
+ set rc [WaitOrTimeout $s]
+
+ if {![string length $ftp(Command)]} {
+ unset ftp(File)
+ }
+
+ if { $rc } {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+#############################################################################
+#
+# Rename --
+#
+# RENAME FROM TO - This command causes the file specified in $from to be
+# renamed at the server site.
+# (exported)
+#
+# Arguments:
+# from - specifies the old file name of the file which
+# is to be renamed
+# to - specifies the new file name of the file
+# specified in the $from agument
+# Returns:
+# 0 - ERROR
+# 1 - OK
+
+proc ::ftp::Rename {s from to} {
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ DisplayMsg $s "Not connected!" error
+ return 0
+ }
+
+ set ftp(RenameFrom) $from
+ set ftp(RenameTo) $to
+
+ set ftp(State) rename
+
+ StateHandler $s
+
+ # wait for synchronization
+ set rc [WaitOrTimeout $s]
+
+ if {![string length $ftp(Command)]} {
+ unset ftp(RenameFrom)
+ unset ftp(RenameTo)
+ }
+
+ if { $rc } {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+#############################################################################
+#
+# ElapsedTime --
+#
+# Gets the elapsed time for file transfer
+#
+# Arguments:
+# stop_time - ending time
+
+proc ::ftp::ElapsedTime {s stop_time} {
+ variable VERBOSE
+ upvar ::ftp::ftp$s ftp
+
+ set elapsed [expr {$stop_time - $ftp(Start_Time)}]
+ if { $elapsed == 0 } {
+ set elapsed 1
+ }
+ set persec [expr {$ftp(Total) / $elapsed}]
+ if { $VERBOSE } {
+ DisplayMsg $s "$ftp(Total) bytes sent in $elapsed seconds ($persec Bytes/s)"
+ }
+ return
+}
+
+#############################################################################
+#
+# PUT --
+#
+# STORE DATA - Causes the server to accept the data transferred via the data
+# connection and to store the data as a file at the server site. If the file
+# exists at the server site, then its contents shall be replaced by the data
+# being transferred. A new file is created at the server site if the file
+# does not already exist.
+# (exported)
+#
+# Arguments:
+# source - local file name
+# dest - remote file name, if unspecified, ftp assigns
+# the local file name.
+# Returns:
+# 0 - file not stored
+# 1 - OK
+
+proc ::ftp::Put {s args} {
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ DisplayMsg $s "Not connected!" error
+ return 0
+ }
+ if {([llength $args] < 1) || ([llength $args] > 4)} {
+ DisplayMsg $s \
+ "wrong # args: should be \"ftp::Put handle (-data \"data\" | -channel chan | localFilename) remoteFilename\"" error
+ return 0
+ }
+
+ set ftp(inline) 0
+ set flags 1
+ set source ""
+ set dest ""
+ foreach arg $args {
+ if {[string equal $arg "--"]} {
+ set flags 0
+ } elseif {($flags) && ([string equal $arg "-data"])} {
+ set ftp(inline) 1
+ set ftp(filebuffer) ""
+ } elseif {($flags) && ([string equal $arg "-channel"])} {
+ set ftp(inline) 2
+ } elseif {$source == ""} {
+ set source $arg
+ } elseif {$dest == ""} {
+ set dest $arg
+ } else {
+ DisplayMsg $s "wrong # args: should be \"ftp::Put handle (-data \"data\" | -channel chan | localFilename) remoteFilename\"" error
+ return 0
+ }
+ }
+
+ if {($source == "")} {
+ DisplayMsg $s "Must specify a valid data source to Put" error
+ return 0
+ }
+
+ set ftp(RemoteFilename) $dest
+
+ if {$ftp(inline) == 1} {
+ set ftp(PutData) $source
+ if { $dest == "" } {
+ set dest ftp.tmp
+ }
+ set ftp(RemoteFilename) $dest
+ } else {
+ if {$ftp(inline) == 0} {
+ # File transfer
+
+ set ftp(PutData) ""
+ if { ![file exists $source] } {
+ DisplayMsg $s "File \"$source\" not exist" error
+ return 0
+ }
+ if { $dest == "" } {
+ set dest [file tail $source]
+ }
+ set ftp(LocalFilename) $source
+ set ftp(SourceCI) [open $ftp(LocalFilename) r]
+ } else {
+ # Channel transfer. We fake the rest of the system into
+ # believing that a file transfer is happening. This makes
+ # the handling easier.
+
+ set ftp(SourceCI) $source
+ set ftp(inline) 0
+ }
+ set ftp(RemoteFilename) $dest
+
+ # TODO: read from source file asynchronously
+ if { [string equal $ftp(Type) "ascii"] } {
+ fconfigure $ftp(SourceCI) -buffering line -blocking 1
+ } else {
+ fconfigure $ftp(SourceCI) -buffering line -translation binary -blocking 1
+ }
+ }
+
+ set ftp(State) put_$ftp(Mode)
+ StateHandler $s
+
+ # wait for synchronization
+ set rc [WaitOrTimeout $s]
+ if { $rc } {
+ if {![string length $ftp(Command)]} {
+ ElapsedTime $s [clock seconds]
+ }
+ return 1
+ } else {
+ CloseDataConn $s
+ return 0
+ }
+}
+
+#############################################################################
+#
+# APPEND --
+#
+# APPEND DATA - Causes the server to accept the data transferred via the data
+# connection and to store the data as a file at the server site. If the file
+# exists at the server site, then the data shall be appended to that file;
+# otherwise the file specified in the pathname shall be created at the
+# server site.
+# (exported)
+#
+# Arguments:
+# source - local file name
+# dest - remote file name, if unspecified, ftp assigns
+# the local file name.
+# Returns:
+# 0 - file not stored
+# 1 - OK
+
+proc ::ftp::Append {s args} {
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ DisplayMsg $s "Not connected!" error
+ return 0
+ }
+
+ if {([llength $args] < 1) || ([llength $args] > 4)} {
+ DisplayMsg $s "wrong # args: should be \"ftp::Append handle (-data \"data\" | -channel chan | localFilename) remoteFilename\"" error
+ return 0
+ }
+
+ set ftp(inline) 0
+ set flags 1
+ set source ""
+ set dest ""
+ foreach arg $args {
+ if {[string equal $arg "--"]} {
+ set flags 0
+ } elseif {($flags) && ([string equal $arg "-data"])} {
+ set ftp(inline) 1
+ set ftp(filebuffer) ""
+ } elseif {($flags) && ([string equal $arg "-channel"])} {
+ set ftp(inline) 2
+ } elseif {$source == ""} {
+ set source $arg
+ } elseif {$dest == ""} {
+ set dest $arg
+ } else {
+ DisplayMsg $s "wrong # args: should be \"ftp::Append handle (-data \"data\" | -channel chan | localFilename) remoteFilename\"" error
+ return 0
+ }
+ }
+
+ if {($source == "")} {
+ DisplayMsg $s "Must specify a valid data source to Append" error
+ return 0
+ }
+
+ set ftp(RemoteFilename) $dest
+
+ if {$ftp(inline) == 1} {
+ set ftp(PutData) $source
+ if { $dest == "" } {
+ set dest ftp.tmp
+ }
+ set ftp(RemoteFilename) $dest
+ } else {
+ if {$ftp(inline) == 0} {
+ # File transfer
+
+ set ftp(PutData) ""
+ if { ![file exists $source] } {
+ DisplayMsg $s "File \"$source\" not exist" error
+ return 0
+ }
+
+ if { $dest == "" } {
+ set dest [file tail $source]
+ }
+
+ set ftp(LocalFilename) $source
+ set ftp(SourceCI) [open $ftp(LocalFilename) r]
+ } else {
+ # Channel transfer. We fake the rest of the system into
+ # believing that a file transfer is happening. This makes
+ # the handling easier.
+
+ set ftp(SourceCI) $source
+ set ftp(inline) 0
+ }
+ set ftp(RemoteFilename) $dest
+
+ if { [string equal $ftp(Type) "ascii"] } {
+ fconfigure $ftp(SourceCI) -buffering line -blocking 1
+ } else {
+ fconfigure $ftp(SourceCI) -buffering line -translation binary \
+ -blocking 1
+ }
+ }
+
+ set ftp(State) append_$ftp(Mode)
+ StateHandler $s
+
+ # wait for synchronization
+ set rc [WaitOrTimeout $s]
+ if { $rc } {
+ if {![string length $ftp(Command)]} {
+ ElapsedTime $s [clock seconds]
+ }
+ return 1
+ } else {
+ CloseDataConn $s
+ return 0
+ }
+}
+
+
+#############################################################################
+#
+# Get --
+#
+# RETRIEVE DATA - Causes the server to transfer a copy of the specified file
+# to the local site at the other end of the data connection.
+# (exported)
+#
+# Arguments:
+# source - remote file name
+# dest - local file name, if unspecified, ftp assigns
+# the remote file name.
+# Returns:
+# 0 - file not retrieved
+# 1 - OK
+
+proc ::ftp::Get {s args} {
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ DisplayMsg $s "Not connected!" error
+ return 0
+ }
+
+ if {([llength $args] < 1) || ([llength $args] > 4)} {
+ DisplayMsg $s "wrong # args: should be \"ftp::Get handle remoteFile ?(-variable varName | -channel chan | localFilename)?\"" error
+ return 0
+ }
+
+ set ftp(inline) 0
+ set flags 1
+ set source ""
+ set dest ""
+ set varname "**NONE**"
+ foreach arg $args {
+ if {[string equal $arg "--"]} {
+ set flags 0
+ } elseif {($flags) && ([string equal $arg "-variable"])} {
+ set ftp(inline) 1
+ set ftp(filebuffer) ""
+ } elseif {($flags) && ([string equal $arg "-channel"])} {
+ set ftp(inline) 2
+ } elseif {($ftp(inline) == 1) && ([string equal $varname "**NONE**"])} {
+ set varname $arg
+ set ftp(get:varname) $varname
+ } elseif {($ftp(inline) == 2) && ([string equal $varname "**NONE**"])} {
+ set ftp(get:channel) $arg
+ } elseif {$source == ""} {
+ set source $arg
+ } elseif {$dest == ""} {
+ set dest $arg
+ } else {
+ DisplayMsg $s "wrong # args: should be \"ftp::Get handle remoteFile
+?(-variable varName | -channel chan | localFilename)?\"" error
+ return 0
+ }
+ }
+
+ if {($ftp(inline) != 0) && ($dest != "")} {
+ DisplayMsg $s "Cannot return data in a variable or channel, and place it in destination file." error
+ return 0
+ }
+
+ if {$source == ""} {
+ DisplayMsg $s "Must specify a valid data source to Get" error
+ return 0
+ }
+
+ if {$ftp(inline) == 0} {
+ if { $dest == "" } {
+ set dest $source
+ } else {
+ if {[file isdirectory $dest]} {
+ set dest [file join $dest [file tail $source]]
+ }
+ }
+ if {![file exists [file dirname $dest]]} {
+ return -code error "ftp::Get, directory \"[file dirname $dest]\" for destination \"$dest\" does not exist"
+ }
+ set ftp(LocalFilename) $dest
+ }
+
+ set ftp(RemoteFilename) $source
+
+ if {$ftp(inline) == 2} {
+ set ftp(inline) 0
+ }
+ set ftp(State) get_$ftp(Mode)
+ StateHandler $s
+
+ # wait for synchronization
+ set rc [WaitOrTimeout $s]
+
+ # It is important to unset 'get:channel' in all cases or it will
+ # interfere with any following ftp command (as its existence
+ # suppresses the closing of the destination channel identifier
+ # (DestCI). We cannot do it earlier than just before the 'return'
+ # or code depending on it for the current command may not execute
+ # correctly.
+
+ if { $rc } {
+ if {![string length $ftp(Command)]} {
+ ElapsedTime $s [clock seconds]
+ if {$ftp(inline)} {
+ catch {unset ftp(get:channel)}
+ upvar $varname returnData
+ set returnData $ftp(GetData)
+ }
+ }
+ # catch {unset ftp(get:channel)}
+ # SF Bug 1708350. DISABLED. In async mode (Open -command) the
+ # unset here causes HandleData to blow up, see marker <@>. In
+ # essence in async mode HandleData can be entered multiple
+ # times, and unsetting get:channel here causes it to think
+ # that the data goes into a local file, not a channel, but the
+ # state does not contain local file information, so an error
+ # is thrown. Removing the catch here seems to fix it without
+ # adverse effects elsewhere. Maybe. We hope.
+ return 1
+ } else {
+ if {$ftp(inline)} {
+ catch {unset ftp(get:channel)}
+ return ""
+ }
+ CloseDataConn $s
+ catch {unset ftp(get:channel)}
+ return 0
+ }
+}
+
+#############################################################################
+#
+# Reget --
+#
+# RESTART RETRIEVING DATA - Causes the server to transfer a copy of the specified file
+# to the local site at the other end of the data connection like get but skips over
+# the file to the specified data checkpoint.
+# (exported)
+#
+# Arguments:
+# source - remote file name
+# dest - local file name, if unspecified, ftp assigns
+# the remote file name.
+# Returns:
+# 0 - file not retrieved
+# 1 - OK
+
+proc ::ftp::Reget {s source {dest ""} {from_bytes 0} {till_bytes -1}} {
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ DisplayMsg $s "Not connected!" error
+ return 0
+ }
+
+ if { $dest == "" } {
+ set dest $source
+ }
+ if {![file exists [file dirname $dest]]} {
+ return -code error \
+ "ftp::Reget, directory \"[file dirname $dest]\" for destination \"$dest\" does not exist"
+ }
+
+ set ftp(RemoteFilename) $source
+ set ftp(LocalFilename) $dest
+ set ftp(From) $from_bytes
+
+
+ # Assumes that the local file has a starting offset of $from_bytes
+ # The following calculation ensures that the download starts from the
+ # correct offset
+
+ if { [file exists $ftp(LocalFilename)] } {
+ set ftp(FileSize) [ expr {[file size $ftp(LocalFilename)] + $from_bytes }]
+
+ if { $till_bytes != -1 } {
+ set ftp(To) $till_bytes
+ set ftp(Bytes_to_go) [ expr {$till_bytes - $ftp(FileSize)} ]
+
+ if { $ftp(Bytes_to_go) <= 0 } {return 0}
+
+ } else {
+ # till_bytes not set
+ set ftp(To) end
+ }
+
+ } else {
+ # local file does not exist
+ set ftp(FileSize) $from_bytes
+
+ if { $till_bytes != -1 } {
+ set ftp(Bytes_to_go) [ expr {$till_bytes - $from_bytes }]
+ set ftp(To) $till_bytes
+ } else {
+ #till_bytes not set
+ set ftp(To) end
+ }
+ }
+
+ set ftp(State) reget_$ftp(Mode)
+ StateHandler $s
+
+ # wait for synchronization
+ set rc [WaitOrTimeout $s]
+ if { $rc } {
+ if {![string length $ftp(Command)]} {
+ ElapsedTime $s [clock seconds]
+ }
+ return 1
+ } else {
+ CloseDataConn $s
+ return 0
+ }
+}
+
+#############################################################################
+#
+# Newer --
+#
+# GET NEWER DATA - Get the file only if the modification time of the remote
+# file is more recent that the file on the current system. If the file does
+# not exist on the current system, the remote file is considered newer.
+# Otherwise, this command is identical to get.
+# (exported)
+#
+# Arguments:
+# source - remote file name
+# dest - local file name, if unspecified, ftp assigns
+# the remote file name.
+#
+# Returns:
+# 0 - file not retrieved
+# 1 - OK
+
+proc ::ftp::Newer {s source {dest ""}} {
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ DisplayMsg $s "Not connected!" error
+ return 0
+ }
+
+ if {[string length $ftp(Command)]} {
+ return -code error "unable to retrieve file asynchronously (not implemented yet)"
+ }
+
+ if { $dest == "" } {
+ set dest $source
+ }
+ if {![file exists [file dirname $dest]]} {
+ return -code error "ftp::Newer, directory \"[file dirname $dest]\" for destination \"$dest\" does not exist"
+ }
+
+ set ftp(RemoteFilename) $source
+ set ftp(LocalFilename) $dest
+
+ # get remote modification time
+ set rmt [ModTime $s $ftp(RemoteFilename)]
+ if { $rmt == "-1" } {
+ return 0
+ }
+
+ # get local modification time
+ if { [file exists $ftp(LocalFilename)] } {
+ set lmt [file mtime $ftp(LocalFilename)]
+ } else {
+ set lmt 0
+ }
+
+ # remote file is older than local file
+ if { $rmt < $lmt } {
+ return 0
+ }
+
+ # remote file is newer than local file or local file doesn't exist
+ # get it
+ set rc [Get $s $ftp(RemoteFilename) $ftp(LocalFilename)]
+ return $rc
+
+}
+
+#############################################################################
+#
+# Quote --
+#
+# The arguments specified are sent, verbatim, to the remote ftp server.
+#
+# Arguments:
+# arg1 arg2 ...
+#
+# Returns:
+# string sent back by the remote ftp server or null string if any error
+#
+
+proc ::ftp::Quote {s args} {
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ DisplayMsg $s "Not connected!" error
+ return 0
+ }
+
+ set ftp(Cmd) $args
+ set ftp(Quote) {}
+
+ set ftp(State) quote
+ StateHandler $s
+
+ # wait for synchronization
+ set rc [WaitOrTimeout $s]
+
+ unset ftp(Cmd)
+
+ if { $rc } {
+ return $ftp(Quote)
+ } else {
+ return {}
+ }
+}
+
+
+#############################################################################
+#
+# Abort --
+#
+# ABORT - Tells the server to abort the previous ftp service command and
+# any associated transfer of data. The control connection is not to be
+# closed by the server, but the data connection must be closed.
+#
+# NOTE: This procedure doesn't work properly. Thus the ftp::Abort command
+# is no longer available!
+#
+# Arguments:
+# None.
+#
+# Returns:
+# 0 - ERROR
+# 1 - OK
+#
+# proc Abort {} {
+#
+# }
+
+#############################################################################
+#
+# Close --
+#
+# Terminates a ftp session and if file transfer is not in progress, the server
+# closes the control connection. If file transfer is in progress, the
+# connection will remain open for result response and the server will then
+# close it.
+# (exported)
+#
+# Arguments:
+# None.
+#
+# Returns:
+# 0 - ERROR
+# 1 - OK
+
+proc ::ftp::Close {s } {
+ variable connections
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ DisplayMsg $s "Not connected!" error
+ return 0
+ }
+
+ if {[info exists \
+ connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid)]} {
+ unset connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid)
+ unset connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost))
+ }
+
+ set ftp(State) quit
+ StateHandler $s
+
+ # wait for synchronization
+ WaitOrTimeout $s
+
+ catch {close $ftp(CtrlSock)}
+ catch {unset ftp}
+ return 1
+}
+
+proc ::ftp::LazyClose {s } {
+ variable connections
+ upvar ::ftp::ftp$s ftp
+
+ if { ![info exists ftp(State)] } {
+ DisplayMsg $s "Not connected!" error
+ return 0
+ }
+
+ if {[info exists connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost))]} {
+ set connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid) \
+ [after 5000 [list ftp::Close $s]]
+ }
+ return 1
+}
+
+#############################################################################
+#
+# Open --
+#
+# Starts the ftp session and sets up a ftp control connection.
+# (exported)
+#
+# Arguments:
+# server - The ftp server hostname.
+# user - A string identifying the user. The user identification
+# is that which is required by the server for access to
+# its file system.
+# passwd - A string specifying the user's password.
+# options - -blocksize size writes "size" bytes at once
+# (default 4096)
+# -timeout seconds if non-zero, sets up timeout to
+# occur after specified number of
+# seconds (default 120)
+# -progress proc procedure name that handles callbacks
+# (no default)
+# -output proc procedure name that handles output
+# (no default)
+# -mode mode switch active or passive file transfer
+# (default active)
+# -port number alternative port (default 21)
+# -command proc callback for completion notification
+# (no default)
+#
+# Returns:
+# 0 - Not logged in
+# 1 - User logged in
+
+proc ::ftp::Open {server user passwd args} {
+ variable DEBUG
+ variable VERBOSE
+ variable serial
+ variable connections
+
+ set s $serial
+ incr serial
+ upvar ::ftp::ftp$s ftp
+# if { [info exists ftp(State)] } {
+# DisplayMsg $s "Mmh, another attempt to open a new connection? There is already a hot wire!" error
+# return 0
+# }
+
+ # default NO DEBUG
+ if { ![info exists DEBUG] } {
+ set DEBUG 0
+ }
+
+ # default NO VERBOSE
+ if { ![info exists VERBOSE] } {
+ set VERBOSE 0
+ }
+
+ if { $DEBUG } {
+ DisplayMsg $s "Starting new connection with: "
+ }
+
+ set ftp(inline) 0
+ set ftp(User) $user
+ set ftp(Passwd) $passwd
+ set ftp(RemoteHost) $server
+ set ftp(LocalHost) [info hostname]
+ set ftp(DataPort) 0
+ set ftp(Type) {}
+ set ftp(Error) ""
+ set ftp(Progress) {}
+ set ftp(Command) {}
+ set ftp(Output) {}
+ set ftp(Blocksize) 4096
+ set ftp(Timeout) 600
+ set ftp(Mode) active
+ set ftp(Port) 21
+
+ set ftp(State) user
+
+ # set state var
+ set ftp(state.control) ""
+
+ # Get and set possible options
+ set options {-blocksize -timeout -mode -port -progress -output -command}
+ foreach {option value} $args {
+ if { [lsearch -exact $options $option] != "-1" } {
+ if { $DEBUG } {
+ DisplayMsg $s " $option = $value"
+ }
+ regexp -- {^-(.?)(.*)$} $option all first rest
+ set option "[string toupper $first]$rest"
+ set ftp($option) $value
+ }
+ }
+ if { $DEBUG && ([llength $args] == 0) } {
+ DisplayMsg $s " no option"
+ }
+
+ if {[info exists \
+ connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid)]} {
+ after cancel $connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid)
+ Command $ftp(Command) connect $connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost))
+ return $connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost))
+ }
+
+
+ # No call of StateHandler is required at this time.
+ # StateHandler at first time is called automatically
+ # by a fileevent for the control channel.
+
+ # Try to open a control connection
+ if { ![OpenControlConn $s [expr {[string length $ftp(Command)] > 0}]] } {
+ return -1
+ }
+
+ # waits for synchronization
+ # 0 ... Not logged in
+ # 1 ... User logged in
+ if {[string length $ftp(Command)]} {
+ # Don't wait - asynchronous operation
+ set ftp(NextState) {type connect_last}
+ set connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost)) $s
+ return $s
+ } elseif { [WaitOrTimeout $s] } {
+ # default type is binary
+ Type $s binary
+ set connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost)) $s
+ Command $ftp(Command) connect $s
+ return $s
+ } else {
+ # close connection if not logged in
+ Close $s
+ return -1
+ }
+}
+
+#############################################################################
+#
+# CopyNext --
+#
+# recursive background copy procedure for ascii/binary file I/O
+#
+# Arguments:
+# bytes - indicates how many bytes were written on $ftp(DestCI)
+
+proc ::ftp::CopyNext {s bytes {error {}}} {
+ upvar ::ftp::ftp$s ftp
+ variable DEBUG
+ variable VERBOSE
+
+ # summary bytes
+
+ incr ftp(Total) $bytes
+
+ # update bytes_to_go and blocksize
+
+ if { [info exists ftp(Bytes_to_go)] } {
+ set ftp(Bytes_to_go) [expr {$ftp(Bytes_to_go) - $bytes}]
+
+ if { $ftp(Blocksize) <= $ftp(Bytes_to_go) } {
+ set blocksize $ftp(Blocksize)
+ } else {
+ set blocksize $ftp(Bytes_to_go)
+ }
+ } else {
+ set blocksize $ftp(Blocksize)
+ }
+
+ # callback for progress bar procedure
+
+ if { ([info exists ftp(Progress)]) && \
+ [string length $ftp(Progress)] && \
+ ([info commands [lindex $ftp(Progress) 0]] != "") } {
+ eval $ftp(Progress) $ftp(Total)
+ }
+
+ # setup new timeout handler
+
+ catch {after cancel $ftp(Wait)}
+ set ftp(Wait) [after [expr {$ftp(Timeout) * 1000}] [namespace current]::Timeout $s]
+
+ if { $DEBUG } {
+ DisplayMsg $s "-> $ftp(Total) bytes $ftp(SourceCI) -> $ftp(DestCI)"
+ }
+
+ if { $error != "" } {
+ # Protect the destination channel from destruction if it came
+ # from the caller. Closing it is not our responsibility in that case.
+
+ if {![info exists ftp(get:channel)]} {
+ catch {close $ftp(DestCI)}
+ }
+ catch {close $ftp(SourceCI)}
+ catch {unset ftp(state.data)}
+ DisplayMsg $s $error error
+
+ } elseif { ([eof $ftp(SourceCI)] || ($blocksize <= 0)) } {
+ # Protect the destination channel from destruction if it came
+ # from the caller. Closing it is not our responsibility in that case.
+
+ if {![info exists ftp(get:channel)]} {
+ close $ftp(DestCI)
+ }
+ close $ftp(SourceCI)
+ catch {unset ftp(state.data)}
+ if { $VERBOSE } {
+ DisplayMsg $s "D: Port closed" data
+ }
+
+ } else {
+ fcopy $ftp(SourceCI) $ftp(DestCI) \
+ -command [list [namespace current]::CopyNext $s] \
+ -size $blocksize
+ }
+ return
+}
+
+#############################################################################
+#
+# HandleData --
+#
+# Handles ascii/binary data transfer for Put and Get
+#
+# Arguments:
+# sock - socket name (data channel)
+
+proc ::ftp::HandleData {s sock} {
+ upvar ::ftp::ftp$s ftp
+
+ # Turn off any fileevent handlers
+
+ fileevent $sock writable {}
+ fileevent $sock readable {}
+
+ # create local file for ftp::Get
+
+ if { [string match "get*" $ftp(State)] && (!$ftp(inline))} {
+
+ # A channel was specified by the caller. Use that instead of a
+ # file.
+
+ # SF Bug 1708350 <@>
+ if {[info exists ftp(get:channel)]} {
+ set ftp(DestCI) $ftp(get:channel)
+ set rc 0
+ } else {
+ set rc [catch {set ftp(DestCI) [open $ftp(LocalFilename) w]} msg]
+ }
+ if { $rc != 0 } {
+ DisplayMsg $s "$msg" error
+ return 0
+ }
+ # TODO: Use non-blocking I/O
+ if { [string equal $ftp(Type) "ascii"] } {
+ fconfigure $ftp(DestCI) -buffering line -blocking 1
+ } else {
+ fconfigure $ftp(DestCI) -buffering line -translation binary -blocking 1
+ }
+ }
+
+ # append local file for ftp::Reget
+
+ if { [string match "reget*" $ftp(State)] } {
+ set rc [catch {set ftp(DestCI) [open $ftp(LocalFilename) a]} msg]
+ if { $rc != 0 } {
+ DisplayMsg $s "$msg" error
+ return 0
+ }
+ # TODO: Use non-blocking I/O
+ if { [string equal $ftp(Type) "ascii"] } {
+ fconfigure $ftp(DestCI) -buffering line -blocking 1
+ } else {
+ fconfigure $ftp(DestCI) -buffering line -translation binary -blocking 1
+ }
+ }
+
+
+ set ftp(Total) 0
+ set ftp(Start_Time) [clock seconds]
+
+ # calculate blocksize
+
+ if { [ info exists ftp(Bytes_to_go) ] } {
+
+ if { $ftp(Blocksize) <= $ftp(Bytes_to_go) } {
+ set Blocksize $ftp(Blocksize)
+ } else {
+ set Blocksize $ftp(Bytes_to_go)
+ }
+
+ } else {
+ set Blocksize $ftp(Blocksize)
+ }
+
+ # perform fcopy
+ fcopy $ftp(SourceCI) $ftp(DestCI) \
+ -command [list [namespace current]::CopyNext $s ] \
+ -size $Blocksize
+ return 1
+}
+
+#############################################################################
+#
+# HandleList --
+#
+# Handles ascii data transfer for list commands
+#
+# Arguments:
+# sock - socket name (data channel)
+
+proc ::ftp::HandleList {s sock} {
+ upvar ::ftp::ftp$s ftp
+ variable VERBOSE
+
+ if { ![eof $sock] } {
+ set buffer [read $sock]
+ if { $buffer != "" } {
+ set ftp(List) [append ftp(List) $buffer]
+ }
+ } else {
+ close $sock
+ catch {unset ftp(state.data)}
+ if { $VERBOSE } {
+ DisplayMsg $s "D: Port closed" data
+ }
+ }
+ return
+}
+
+#############################################################################
+#
+# HandleVar --
+#
+# Handles data transfer for get/put commands that use buffers instead
+# of files.
+#
+# Arguments:
+# sock - socket name (data channel)
+
+proc ::ftp::HandleVar {s sock} {
+ upvar ::ftp::ftp$s ftp
+ variable VERBOSE
+
+ if {$ftp(Start_Time) == -1} {
+ set ftp(Start_Time) [clock seconds]
+ }
+
+ if { ![eof $sock] } {
+ set buffer [read $sock]
+ if { $buffer != "" } {
+ append ftp(GetData) $buffer
+ incr ftp(Total) [string length $buffer]
+ }
+ } else {
+ close $sock
+ catch {unset ftp(state.data)}
+ if { $VERBOSE } {
+ DisplayMsg $s "D: Port closed" data
+ }
+ }
+ return
+}
+
+#############################################################################
+#
+# HandleOutput --
+#
+# Handles data transfer for get/put commands that use buffers instead
+# of files.
+#
+# Arguments:
+# sock - socket name (data channel)
+
+proc ::ftp::HandleOutput {s sock} {
+ upvar ::ftp::ftp$s ftp
+ variable VERBOSE
+
+ if {$ftp(Start_Time) == -1} {
+ set ftp(Start_Time) [clock seconds]
+ }
+
+ if { $ftp(Total) < [string length $ftp(PutData)] } {
+ set substr [string range $ftp(PutData) $ftp(Total) \
+ [expr {$ftp(Total) + $ftp(Blocksize)}]]
+ if {[catch {puts -nonewline $sock "$substr"} result]} {
+ close $sock
+ catch {unset ftp(state.data)}
+ if { $VERBOSE } {
+ DisplayMsg $s "D: Port closed" data
+ }
+ } else {
+ incr ftp(Total) [string length $substr]
+ }
+ } else {
+ fileevent $sock writable {}
+ close $sock
+ catch {unset ftp(state.data)}
+ if { $VERBOSE } {
+ DisplayMsg $s "D: Port closed" data
+ }
+ }
+ return
+}
+
+############################################################################
+#
+# CloseDataConn --
+#
+# Closes all sockets and files used by the data conection
+#
+# Arguments:
+# None.
+#
+# Returns:
+# None.
+#
+proc ::ftp::CloseDataConn {s } {
+ upvar ::ftp::ftp$s ftp
+
+ # Protect the destination channel from destruction if it came
+ # from the caller. Closing it is not our responsibility.
+
+ if {[info exists ftp(get:channel)]} {
+ catch {unset ftp(get:channel)}
+ catch {unset ftp(DestCI)}
+ }
+
+ catch { unset ftp(AC) }
+ catch {after cancel $ftp(Wait)}
+ catch {fileevent $ftp(DataSock) readable {}}
+ catch {close $ftp(DataSock); unset ftp(DataSock)}
+ catch {close $ftp(DestCI); unset ftp(DestCI)}
+ catch {close $ftp(SourceCI); unset ftp(SourceCI)}
+ catch {close $ftp(DummySock); unset ftp(DummySock)}
+ return
+}
+
+#############################################################################
+#
+# InitDataConn --
+#
+# Configures new data channel for connection to ftp server
+# ATTENTION! The new data channel "sock" is not the same as the
+# server channel, it's a dummy.
+#
+# Arguments:
+# sock - the name of the new channel
+# addr - the address, in network address notation,
+# of the client's host,
+# port - the client's port number
+
+proc ::ftp::InitDataConn {s sock addr port} {
+ upvar ::ftp::ftp$s ftp
+ variable VERBOSE
+
+ if { $VERBOSE } {
+ DisplayMsg $s "D: New Connection from $addr:$port" data
+ DisplayMsg $s "D: Sequencer state $ftp(State)" data
+ }
+
+ # If the new channel is accepted, the dummy channel will be closed
+
+ catch {close $ftp(DummySock); unset ftp(DummySock)}
+
+ set ftp(state.data) 0
+
+ # Configure translation and blocking modes
+
+ set blocking 1
+ if {[string length $ftp(Command)]} {
+ set blocking 0
+ }
+
+ if { [string equal $ftp(Type) "ascii"] } {
+ fconfigure $sock -buffering line -blocking $blocking
+ } else {
+ fconfigure $sock -buffering line -translation binary -blocking $blocking
+ }
+
+ # assign fileevent handlers, source and destination CI (Channel Identifier)
+
+ # NB: this really does need to be -regexp [PT] 18Mar03
+ switch -regexp -- $ftp(State) {
+ list {
+ fileevent $sock readable [list [namespace current]::HandleList $s $sock]
+ set ftp(SourceCI) $sock
+ }
+ get {
+ if {$ftp(inline)} {
+ set ftp(GetData) ""
+ set ftp(Start_Time) -1
+ set ftp(Total) 0
+ fileevent $sock readable [list [namespace current]::HandleVar $s $sock]
+ } else {
+ fileevent $sock readable [list [namespace current]::HandleData $s $sock]
+ set ftp(SourceCI) $sock
+ }
+ }
+ append -
+ put {
+ if {$ftp(inline)} {
+ set ftp(Start_Time) -1
+ set ftp(Total) 0
+ fileevent $sock writable [list [namespace current]::HandleOutput $s $sock]
+ } else {
+ fileevent $sock writable [list [namespace current]::HandleData $s $sock]
+ set ftp(DestCI) $sock
+ }
+ }
+ default {
+ error "Unknown state \"$ftp(State)\""
+ }
+ }
+
+ if { $VERBOSE } {
+ DisplayMsg $s "D: ... Connection from $addr:$port ... initialized" data
+ }
+
+ # Marker for WaitDataConn
+ set ftp(AC) 1
+ return
+}
+
+#############################################################################
+#
+# WaitDataConn --
+# Arguments: The ftp connection handle
+# Returns: None
+#
+# Synchronizes the control sequencer to the data connection (active
+# mode). This must be placed at the end of all state sequences,
+# i.e. the last state of each sequence, dealing with a data
+# connection. Without the sync the control sequencer may step to the
+# next command causing a very late-coming data connection to encounter
+# an unknown state, and failing to establish what to do.
+#
+# Sync is achieved through the state field AC, in cooperation with the
+# procedures OpenActiveConn and InitDataConn.
+#
+# Missing field => Not an active connection - Ignore
+# AC == 0 => OAC has run, IDC not - Wait for IDC, then cleanup
+# AC == 1 => OAC has run, IDC as well - No waiting, just cleanup.
+
+proc ::ftp::WaitDataConn {s} {
+ variable VERBOSE
+ upvar ::ftp::ftp$s ftp
+
+ if {$VERBOSE} { DisplayMsg $s WDC|$s|Begin|@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ }
+
+ # Passive connection, nothing to do
+ if {![info exists ftp(AC)]} {
+ if {$VERBOSE} { DisplayMsg $s WDC|$s|Passive|@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ }
+ return
+ }
+
+ # InitDataConn has not run yet. Wait!
+ if {!$ftp(AC)} {
+ if {$VERBOSE} { DisplayMsg $s WDC|$s|Sync|@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ }
+ vwait ::ftp::ftp${s}(AC)
+ # assert ftp(AC) == 1
+ if {$VERBOSE} { DisplayMsg $s WDC|$s|Synced|@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ }
+ } ; # else: Was run already
+
+ if {$VERBOSE} { DisplayMsg $s WDC|$s|Cleanup|@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ }
+ # InitDataConn has run, clean up and continue
+ unset ftp(AC)
+ return
+}
+
+#############################################################################
+#
+# OpenActiveConn --
+#
+# Opens a ftp data connection
+#
+# Arguments:
+# None.
+#
+# Returns:
+# 0 - no connection
+# 1 - connection established
+
+proc ::ftp::OpenActiveConn {s } {
+ upvar ::ftp::ftp$s ftp
+ variable VERBOSE
+
+ # Port address 0 is a dummy used to give the server the responsibility
+ # of getting free new port addresses for every data transfer.
+
+ set rc [catch {set ftp(DummySock) [socket -server [list [namespace current]::InitDataConn $s] 0]} msg]
+ if { $rc != 0 } {
+ DisplayMsg $s "$msg" error
+ return 0
+ }
+
+ # prepare local ip address for PORT command (convert pointed format
+ # to comma format)
+
+ set ftp(LocalAddr) [lindex [fconfigure $ftp(CtrlSock) -sockname] 0]
+ set ftp(LocalAddr) [string map {. ,} $ftp(LocalAddr)]
+
+ # get a new local port address for data transfer and convert it to a format
+ # which is useable by the PORT command
+
+ set p [lindex [fconfigure $ftp(DummySock) -sockname] 2]
+ if { $VERBOSE } {
+ DisplayMsg $s "D: Port is $p" data
+ }
+ set ftp(DataPort) "[expr {$p / 256}],[expr {$p % 256}]"
+
+ # Marker for WaitDataConn
+ set ftp(AC) 0
+ return 1
+}
+
+#############################################################################
+#
+# OpenPassiveConn --
+#
+# Opens a ftp data connection
+#
+# Arguments:
+# buffer - returned line from server control connection
+#
+# Returns:
+# 0 - no connection
+# 1 - connection established
+
+proc ::ftp::OpenPassiveConn {s buffer} {
+ upvar ::ftp::ftp$s ftp
+
+ if { [regexp -- {([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)} $buffer all a1 a2 a3 a4 p1 p2] } {
+ set ftp(LocalAddr) "$a1.$a2.$a3.$a4"
+ set ftp(DataPort) "[expr {$p1 * 256 + $p2}]"
+
+ # establish data connection for passive mode
+
+ set rc [catch {set ftp(DataSock) [socket $ftp(LocalAddr) $ftp(DataPort)]} msg]
+ if { $rc != 0 } {
+ DisplayMsg $s "$msg" error
+ return 0
+ }
+
+ InitDataConn $s $ftp(DataSock) $ftp(LocalAddr) $ftp(DataPort)
+ return 1
+ } else {
+ return 0
+ }
+}
+
+#############################################################################
+#
+# OpenControlConn --
+#
+# Opens a ftp control connection
+#
+# Arguments:
+# s connection id
+# block blocking or non-blocking mode
+#
+# Returns:
+# 0 - no connection
+# 1 - connection established
+
+proc ::ftp::OpenControlConn {s {block 1}} {
+ upvar ::ftp::ftp$s ftp
+ variable DEBUG
+ variable VERBOSE
+
+ # open a control channel
+
+ set rc [catch {set ftp(CtrlSock) [socket $ftp(RemoteHost) $ftp(Port)]} msg]
+ if { $rc != 0 } {
+ if { $VERBOSE } {
+ DisplayMsg $s "C: No connection to server!" error
+ }
+ if { $DEBUG } {
+ DisplayMsg $s "[list $msg]" error
+ }
+ unset ftp(State)
+ return 0
+ }
+
+ # configure control channel
+
+ fconfigure $ftp(CtrlSock) -buffering line -blocking $block -translation {auto crlf}
+ fileevent $ftp(CtrlSock) readable [list [namespace current]::StateHandler $s $ftp(CtrlSock)]
+
+ # report ready message
+
+ if { $VERBOSE } {
+ DisplayMsg $s "C: Connection to $ftp(RemoteHost):$ftp(Port)" control
+ }
+
+ return 1
+}
+
+# ::ftp::Command --
+#
+# Wrapper for evaluated user-supplied command callback
+#
+# Arguments:
+# cb callback script
+# msg what happened
+# args additional info
+#
+# Results:
+# Depends on callback script
+
+proc ::ftp::Command {cb msg args} {
+ if {[string length $cb]} {
+ uplevel #0 $cb [list $msg] $args
+ }
+}
+
+# ==================================================================
+# ?????? Hmm, how to do multithreaded for tkcon?
+# added TkCon support
+# TkCon is (c) 1995-2001 Jeffrey Hobbs, http://tkcon.sourceforge.net/
+# started with: tkcon -load ftp
+if { [string equal [uplevel "#0" {info commands tkcon}] "tkcon"] } {
+
+ # new ftp::List proc makes the output more readable
+ proc ::ftp::__ftp_ls {args} {
+ set rc [eval [linsert $args 0 ::ftp::List_org]]
+ foreach i $rc {
+ puts $i
+ }
+ return $rc
+ }
+
+ # rename the original ftp::List procedure
+ rename ::ftp::List ::ftp::List_org
+
+ alias ::ftp::List ::ftp::__ftp_ls
+ alias bye catch {::ftp::Close; exit}
+
+ set ::ftp::VERBOSE 1
+ set ::ftp::DEBUG 0
+}
+
+# ==================================================================
+# At last, everything is fine, we can provide the package.
+
+package provide ftp [lindex {Revision: 2.4.13} 1]
diff --git a/tcllib/modules/ftp/ftp_geturl.man b/tcllib/modules/ftp/ftp_geturl.man
new file mode 100644
index 0000000..f3cbc06
--- /dev/null
+++ b/tcllib/modules/ftp/ftp_geturl.man
@@ -0,0 +1,57 @@
+[vset VERSION 0.2.2]
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin ftp::geturl n [vset VERSION]]
+[see_also ftpd]
+[see_also mime]
+[see_also pop3]
+[see_also smtp]
+[keywords ftp]
+[keywords internet]
+[keywords net]
+[keywords {rfc 959}]
+[moddesc {ftp client}]
+[titledesc {Uri handler for ftp urls}]
+[category Networking]
+[require Tcl 8.2]
+[require ftp::geturl [opt [vset VERSION]]]
+[description]
+
+This package provides a command which wraps around the client side of
+the [term ftp] protocol provided by package [package ftp] to allow the
+retrieval of urls using the [term ftp] schema.
+
+[section API]
+
+[list_begin definitions]
+[call [cmd ::ftp::geturl] [arg url]]
+
+This command can be used by the generic command [cmd ::uri::geturl]
+(See package [package uri]) to retrieve the contents of ftp
+urls. Internally it uses the commands of the package [package ftp] to
+fulfill the request.
+
+[para]
+
+The contents of a [term ftp] url are defined as follows:
+
+[list_begin definitions]
+
+[def [term file]]
+
+The contents of the specified file itself.
+
+[def [term directory]]
+
+A listing of the contents of the directory in key value notation where
+the file name is the key and its attributes the associated value.
+
+[def [term link]]
+
+The attributes of the link, including the path it refers to.
+
+[list_end]
+[list_end]
+
+[vset CATEGORY ftp]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/ftp/ftp_geturl.tcl b/tcllib/modules/ftp/ftp_geturl.tcl
new file mode 100644
index 0000000..d909d4b
--- /dev/null
+++ b/tcllib/modules/ftp/ftp_geturl.tcl
@@ -0,0 +1,135 @@
+# ftp_geturl.tcl --
+#
+# Copyright (c) 2001 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# ftp::geturl url
+
+package require ftp
+package require uri
+
+namespace eval ::ftp {
+ namespace export geturl
+}
+
+# ::ftp::geturl
+#
+# Command useable by uri to retrieve the contents of an ftp url.
+# Returns the contents of the requested url.
+
+proc ::ftp::geturl {url} {
+ # FUTURE: -validate to validate existence of url, but no download
+ # of contents.
+
+ array set urlparts [uri::split $url]
+
+ if {$urlparts(user) == {}} {
+ set urlparts(user) "anonymous"
+ }
+ if {$urlparts(pwd) == {}} {
+ set urlparts(pwd) "user@localhost.localdomain"
+ }
+ if {$urlparts(port) == {}} {
+ set urlparts(port) 21
+ }
+
+ set fdc [ftp::Open $urlparts(host) $urlparts(user) $urlparts(pwd) \
+ -port $urlparts(port)]
+ if {$fdc < 0} {
+ return -code error "Cannot reach host for url \"$url\""
+ }
+
+ # We have reached the host, now get on to retrieve the item.
+ # We are very careful in accessing the item because we don't know
+ # if it is a file, directory or link. So we change into the
+ # directory containing the item, get a list of all entries and
+ # then determine if the item actually exists and what type it is,
+ # and what actions to perform.
+
+ set ftp_dir [file dirname $urlparts(path)]
+ set ftp_file [file tail $urlparts(path)]
+
+ set result [ftp::Cd $fdc $ftp_dir]
+ if { $result == 0 } {
+ ftp::Close $fdc
+ return -code error "Cannot reach directory of url \"$url\""
+ }
+
+ # Fix for the tkcon List enhancements in ftp.tcl
+ set List ::ftp::List_org
+ if {[info commands $List] == {}} {
+ set List ::ftp::List
+ }
+
+ # The result of List is a list of entries in the given directory.
+ # Note that it is in 'ls -l format. We parse that into a more
+ # readable array.
+
+ #array set flist [ftp::ParseList [$List $fdc ""]]
+ #if {![info exists flist($ftp_file)]} {}
+ set flist [$List $fdc $ftp_file]
+ if {$flist == {}} {
+ ftp::Close $fdc
+ return -code error "Cannot reach item of url \"$url\""
+ }
+
+ # The item exists, what is it ?
+ # File : Download the contents.
+ # Directory: Download a listing, this is its contents.
+ # Link : For now we do not follow the link but return the
+ # meta information, i.e. the path it is pointing to.
+
+ #switch -exact -- [lindex $flist($ftp_file) 0] {}
+ switch -exact -- [string index [lindex $flist 0] 0] {
+ - {
+ if {[string equal $ftp_file {}]} {
+ set contents [ftp::NList $fdc $ftp_file]
+ } else {
+ ftp::Get $fdc $ftp_file -variable contents
+ }
+ }
+ d {
+ set contents [ftp::NList $fdc $ftp_file]
+ }
+ l {
+ set contents $flist
+ }
+ default {
+ ftp::Close $fdc
+ return -code error "File information \"$flist\" not recognised"
+ }
+ }
+
+ ftp::Close $fdc
+ return $contents
+}
+
+# Internal helper to parse a directory listing into something which
+# can be better handled by tcl than raw ls -l format.
+
+proc ::ftp::ParseList {flist} {
+ array set data {}
+ foreach item $flist {
+ foreach {mode dummy owner group size month day yrtime name} $item break
+
+ if {[string first : $yrtime] >=0} {
+ set date "$month/$day/[clock format [clock seconds] -format %Y] $yrtime"
+ } else {
+ set date "$month/$day/$yrtime 00:00"
+ }
+ set info [list owner $owner group $group size $size date $date]
+
+ switch -exact -- [string index $mode 0] {
+ - {set type file}
+ d {set type dir}
+ l {set type link ; lappend info link [lindex $item end]}
+ }
+
+ set data($name) [list $type $info]
+ }
+ array get data
+}
+
+# ==================================================================
+# At last, everything is fine, we can provide the package.
+
+package provide ftp::geturl [lindex {Revision: 0.2.2} 1]
diff --git a/tcllib/modules/ftp/pkgIndex.tcl b/tcllib/modules/ftp/pkgIndex.tcl
new file mode 100644
index 0000000..0155103
--- /dev/null
+++ b/tcllib/modules/ftp/pkgIndex.tcl
@@ -0,0 +1,3 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded ftp 2.4.13 [list source [file join $dir ftp.tcl]]
+package ifneeded ftp::geturl 0.2.2 [list source [file join $dir ftp_geturl.tcl]]
diff --git a/tcllib/modules/ftpd/ChangeLog b/tcllib/modules/ftpd/ChangeLog
new file mode 100644
index 0000000..a95e00f
--- /dev/null
+++ b/tcllib/modules/ftpd/ChangeLog
@@ -0,0 +1,249 @@
+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-08-09 Andreas Kupries <andreask@activestate.com>
+
+ * ftpd.man: Bumped version to 1.2.6.
+ * ftpd.tcl:
+ * pkgIndex.tcl:
+
+ * ftpd.tcl (::ftpd::command::CWD): [Bug 3312900]: Accepted patch
+ by Roy Keene, adding basic checks to the CWD command.
+
+ * ftpd.tcl (::ftpd::command::RNTO, ::ftpd::command::RNFR):
+ [Bug 3312880, 3325229]: Fixed issues with the rename command
+ found by Roy Keene.
+
+ * ftpd.tcl: [Bug 3357765]: Accepted patch by Roy Keene
+ <rkeene@users.sourceforge.net> fixing issues with the handling
+ of passive connections by the server, with modifications (Moved
+ the replicated checking code into a procedure shared by the
+ modified commands).
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-01-20 Andreas Kupries <andreask@activestate.com>
+
+ * ftpd.tcl (::ftpd::command::RNTO): [Bug 2928355]: Fixed the
+ missing import of the server's state array, reported by Martin
+ <martinao@users.sourceforge.net>.
+
+ * ftpd.tcl (::ftpd::config): [Bug 2935339] [Patch 2935347]:
+ * ftpd.man: Applied the patch by Keith Vetter
+ * pkgIndex.tcl: <keithv@users.sourceforge.net>, fixing the
+ non-idempotency of the config command. Bumped the package
+ version to 1.2.5.
+
+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 ========================
+ *
+
+2008-02-29 Andreas Kupries <andreask@activestate.com>
+
+ * ftpd.tcl: Renamed ::ftpd::read -> ftp::Read to prevent clash
+ * ftpd.man: with Tcl's builtin command. Version bumped to 1.2.4.
+ * pkgIndex.tcl:
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-20 Andreas Kupries <andreask@activestate.com>
+
+ * ftpd.tcl: Fix for [SF Tcllib Bug 1720144]. Version
+ * ftpd.man: of the package bumped to 1.2.3.
+ * pkgIndex.tcl:
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.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 ========================
+ *
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-10-05 Andreas Kupries <andreask@activestate.com>
+
+ * ftpd.tcl: Fixed [Tcllib SF Bug 1006157] reported by Stephen
+ Huntley <blacksqr@users.sourceforge.net>. Using fake user/group
+ information when on Windows.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.tcl: Updated version number to sync with 1.6.1
+ * ftpd.man: release.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.tcl: Rel. engineering. Updated version number
+ * ftpd.man: of ftpd to reflect its changes, to 1.2.1.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bugfixes by Gerald Lester. No details available. Gerald is asked
+ to replace this entry with one describing his changes.
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.man: Updated documentation to explain the new features (Two
+ additional callbacks, and the variable 'CurrentSocket').
+ * ftpd.tcl (Finish): Replaced string compare with canonical
+ 'hasCallback'.
+ (GetDone): Ditto for 'xferDoneCmd'.
+ (command::REIN): Closing passive data server port,
+ reinitializing to empty as well.
+ (read): Reverted call of Finish to relative addressing of the
+ command.
+
+2004-02-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl
+ * ftpd.tcl: Imported changes made by "Gerald W. Lester"
+ <Gerald.Lester@ShowMaster.com>. Bugfixes, more callbacks (close,
+ transfer done), and implementation of passive mode data
+ connection. Version up to 1.2.
+
+2003-07-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.tcl (Fs): Fixed SF tcllib bug [766112]. Copied code from
+ style 'nslt' to exclude . and .. from the list.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * ftpd.tcl:
+ * ftpd.man:
+ * pkgIndex.tcl: Fixed bug #614591. Set version of the package to
+ to 1.1.3.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.man: More semantic markup, less visual one.
+
+2002-08-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.tcl: Updated 'info exist' to 'info exists'.
+
+2002-06-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl:
+ * ftpd.tcl:
+ * ftpd.n:
+ * ftpd.man: Bumped to version 1.1.2.
+
+2002-03-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.man: New, doctools manpage.
+
+2002-03-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl:
+ * ftpd.n: Changed to require tcl version 8.3. Code uses -unique
+ option of [lsort], introduced in that version. This fixes SF bug
+ #531799.
+
+2001-09-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.tcl: Applied patch [459197] from Hemang to fix more
+ 'namespace export *'. Patch modified before application as some
+ export command are actually private (Implementations of the ftp
+ commands).
+
+2001-09-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.tcl: Restricted export list to public API.
+ [456255]. Patch by Hemang Lavana
+ <hemanglavana@users.sourceforge.net>
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ftpd.tcl: Fixed dubious code reported by frink.
+
+2000-11-22 Eric Melski <ericm@interwoven.com>
+
+ * Integrated patch from Mark O'Conner. Patch fixed file translation
+ mode bug (ie, binary vs. ascii) that prevented proper retrieval
+ of binary files. [SFBUG: 122664]
+
+2000-11-01 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * Integrated patch from Keith Vetter <keith@softbook.com>
+ Patch fixed several bugs. Allowed users to log in as
+ both 'anonymous' and 'ftp' by default instead of just anonymous.
+ Fixed syntax error with the 'socket -server' line in ftpd::server when
+ 'myaddr' is specified. Fixed the argument specifications for
+ cmdline:getoptions in ftpd::config so that arguments are required for
+ the -logCmd and the -fsCmd.
+
+2000-10-30 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * Made some fixes to better support windows.
+
+2000-10-27 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * Initial revision of tcllib ftpd. Based off of the ftpd in
+ the stdtcl distribution.
+
diff --git a/tcllib/modules/ftpd/ftpd.man b/tcllib/modules/ftpd/ftpd.man
new file mode 100644
index 0000000..e50b24c
--- /dev/null
+++ b/tcllib/modules/ftpd/ftpd.man
@@ -0,0 +1,279 @@
+[vset VERSION 1.3]
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin ftpd n [vset VERSION]]
+[keywords ftp]
+[keywords ftpd]
+[keywords ftpserver]
+[keywords {rfc 959}]
+[keywords services]
+[moddesc {Tcl FTP Server Package}]
+[titledesc {Tcl FTP server implementation}]
+[category Networking]
+[require Tcl 8.3]
+[require ftpd [opt [vset VERSION]]]
+[description]
+
+The [package ftpd] package provides a simple Tcl-only server library
+for the FTP protocol as specified in
+RFC 959 ([uri http://www.rfc-editor.org/rfc/rfc959.txt]).
+It works by listening on the standard FTP socket. Most server errors
+are returned as error messages with the appropriate code attached to
+them. Since the server code for the ftp daemon is executed in the
+event loop, it is possible that a
+
+[cmd bgerror] will be thrown on the server if there are problems with
+the code in the module.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::ftpd::server] [opt [arg myaddr]]]
+
+Open a listening socket to listen to and accept ftp connections.
+myaddr is an optional argument. [arg myaddr] is the domain-style name
+or numerical IP address of the client-side network interface to use
+for the connection.
+
+[call [cmd ::ftpd::config] [opt [arg {option value}]] [opt [arg {option value ...}]]]
+
+The value is always the name of the command to call as the
+callback. The option specifies which callback should be configured.
+See section [sectref CALLBACKS] for descriptions of the arguments and
+return values for each of the callbacks.
+
+[list_begin definitions]
+
+[def "-authIpCmd [arg proc]"]
+
+Callback to authenticate new connections based on the ip-address of
+the peer.
+
+[def "-authUsrCmd [arg proc]"]
+
+Callback to authenticate new connections based on the user logging in
+(and the users password).
+
+[def "-authFileCmd [arg proc]"]
+
+Callback to accept or deny a users access to read and write to a
+specific path or file.
+
+[def "-logCmd [arg proc]"]
+
+Callback for log information generated by the FTP engine.
+
+[def "-fsCmd [arg proc]"]
+
+Callback to connect the engine to the filesystem it operates on.
+
+[def "-closeCmd [arg proc]"]
+
+Callback to be called when a connection is closed. This allows the
+embedding application to perform its own cleanup operations.
+
+[def "-xferDoneCmd [arg proc]"]
+
+Callback for transfer completion notification. In other words, it is
+called whenever a transfer of data to or from the client has
+completed.
+
+[list_end]
+[list_end]
+
+[section CALLBACKS]
+
+[list_begin definitions]
+
+[def "[cmd authIpCmd] callback"]
+
+The authIpCmd receives the ip-address of the peer attempting to
+connect to the ftp server as its argument. It returns a 1 to allow
+users from the specified IP to attempt to login and a 0 to reject the
+login attempt from the specified IP.
+
+[def "[cmd authUsrCmd] callback"]
+
+The authUsrCmd receives the username and password as its two
+arguments. It returns a 1 to accept the attempted login to the ftpd
+and a 0 to reject the attempted login.
+
+[def "[cmd authFileCmd] callback"]
+
+The authFileCmd receives the user (that is currently logged in), the
+path or filename that is about to be read or written, and
+
+[const read] or [const write] as its three arguments. It returns a
+1 to allow the path or filename to be read or written, and a 0 to
+reject the attempted read or write with a permissions error code.
+
+[def "[cmd logCmd] callback"]
+
+The logCmd receives a severity and a message as its two arguments.
+The severities used within the ftpd package are [const note],
+
+[const debug], and [const error]. The logCmd doesn't return
+anything.
+
+[def "[cmd fsCmd] callback"]
+
+The fsCmd receives a subcommand, a filename or path, and optional
+additional arguments (depending on the subcommand).
+
+[para]
+The subcommands supported by the fsCmd are:
+
+[list_begin definitions]
+
+[call [arg fsCmd] [method append] [arg path]]
+
+The append subcommand receives the filename to append to as its
+argument. It returns a writable tcl channel as its return value.
+
+[call [arg fsCmd] [method delete] [arg path] [arg channel]]
+
+The delete subcommand receives the filename to delete, and a channel
+to write to as its two arguments. The file specified is deleted and
+the appropriate ftp message is written to the channel that is passed
+as the second argument. The delete subcommand returns nothing.
+
+[call [arg fsCmd] [method dlist] [arg path] [arg style] [arg channel]]
+
+The dlist subcommand receives the path that it should list the files
+that are in, the style in which the files should be listed which is
+either [const nlst] or [const list], and a channel to write to as
+its three arguments. The files in the specified path are printed to
+the specified channel one per line. If the style is [const nlst]
+only the name of the file is printed to the channel. If the style is
+[const list] then the file permissions, number of links to the file,
+the name of the user that owns the file, the name of the group that
+owns the file, the size (in bytes) of the file, the modify time of the
+file, and the filename are printed out to the channel in a formatted
+space separated format. The [method dlist] subcommand returns
+nothing.
+
+[call [arg fsCmd] [method exists] [arg path]]
+
+The exists subcommand receives the name of a file to check the
+existence of as its only argument. The exists subcommand returns a 1
+if the path specified exists and the path is not a directory.
+
+[call [arg fsCmd] [method mkdir] [arg path] [arg channel]]
+
+The mkdir subcommand receives the path of a directory to create and a
+channel to write to as its two arguments. The mkdir subcommand
+creates the specified directory if necessary and possible. The mkdir
+subcommand then prints the appropriate success or failure message to
+the channel. The mkdir subcommand returns nothing.
+
+[call [arg fsCmd] [method mtime] [arg path] [arg channel]]
+
+The mtime subcommand receives the path of a file to check the modify
+time on and a channel as its two arguments. If the file exists the
+mtime is printed to the channel in the proper FTP format, otherwise an
+appropriate error message and code are printed to the channel. The
+mtime subcommand returns nothing.
+
+[call [arg fsCmd] [method permissions] [arg path]]
+
+The permissions subcommand receives the path of a file to retrieve the
+permissions of. The permissions subcommand returns the octal file
+permissions of the specified file. The file is expected to exist.
+
+[call [arg fsCmd] [method rename] [arg path] [arg newpath] [arg channel]]
+
+The rename subcommand receives the path of the current file, the new
+file path, and a channel to write to as its three arguments. The
+rename subcommand renames the current file to the new file path if the
+path to the new file exists, and then prints out the appropriate
+message to the channel. If the new file path doesn't exist the
+appropriate error message is printed to the channel. The rename
+subcommand returns nothing.
+
+[call [arg fsCmd] [method retr] [arg path]]
+
+The retr subcommand receives the path of a file to read as its only
+argument. The retr subcommand returns a readable channel that the
+specified file can be read from.
+
+[call [arg fsCmd] [method rmdir] [arg path] [arg channel]]
+
+The rmdir subcommand receives the path of a directory to remove and a
+channel to write to as its two arguments. The rmdir subcommand
+removes the specified directory (if possible) and prints the
+appropriate message to the channel (which may be an error if the
+specified directory does not exist or is not empty). The rmdir
+subcommand returns nothing.
+
+[call [arg fsCmd] [method size] [arg path] [arg channel]]
+
+The size subcommand receives the path of a file to get the size (in
+bytes) of and a channel to write to as its two arguments. The size
+subcommand prints the appropriate code and the size of the file if the
+specified path is a file, otherwise an appropriate error code and
+message are printed to the channel. The size subcommand returns
+nothing.
+
+[call [arg fsCmd] [method store] [arg path]]
+
+The store subcommand receives the path of a file to write as its only
+argument. The store subcommand returns a writable channel.
+
+[list_end]
+
+[def "[cmd closeCmd]"]
+
+The [cmd closeCmd] receives no arguments when it is invoked, and any
+return value it may generate is discarded.
+
+[def "[cmd xferDoneCmd] sock sock2 file bytes filename err"]
+
+The [cmd xferDoneCmd] receives six arguments when invoked. These are,
+in this order, the channel handle of the control socket for the
+connection, the channel handle of the data socket used for the
+transfer (already closed), the handle of the channel containing the
+transfered file, the number of bytes transfered, the path of the file
+which was transfered, and a (possibly empty) error message.
+
+Any return value it may generate is discarded.
+
+[list_end]
+
+[section VARIABLES]
+
+[list_begin definitions]
+
+[def [var ::ftpd::cwd]]
+
+The current working directory for a session when someone first
+connects to the FTPD or when the [cmd REIN] ftp command is received.
+
+[def [var ::ftpd::contact]]
+
+The e-mail address of the person that is the contact for the ftp
+server. This address is printed out as part of the response to the
+[cmd {FTP HELP}] command.
+
+[def [var ::ftpd::port]]
+
+The port that the ftp server should listen on.
+If port is specified as zero, the operating system will allocate an
+unused port for use as a server socket; afterwards, the variable will
+contain the port number that was allocated.
+
+[def [var ::ftpd::welcome]]
+
+The message that is printed out when the user first connects to the
+ftp server.
+
+[def [var ::ftpd::CurrentSocket]]
+
+Accessible to all callbacks and all filesystem commands (which are a
+special form of callback) and contains the handle of the socket
+channel which was active when the callback was invoked.
+
+[list_end]
+
+[vset CATEGORY ftpd]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/ftpd/ftpd.tcl b/tcllib/modules/ftpd/ftpd.tcl
new file mode 100644
index 0000000..7e93f8e
--- /dev/null
+++ b/tcllib/modules/ftpd/ftpd.tcl
@@ -0,0 +1,2064 @@
+# ftpd.tcl --
+#
+# This file contains Tcl/Tk package to create a ftp daemon.
+# I believe it was originally written by Matt Newman (matt@sensus.org).
+# Modified by Dan Kuchler (kuchler@ajubasolutions.com) to handle
+# more ftp commands and to fix some bugs in the original implementation
+# that was found in the stdtcl module.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: ftpd.tcl,v 1.34 2011/08/09 20:55:38 andreas_kupries Exp $
+#
+
+# Define the ftpd package version 1.2.5
+
+package require Tcl 8.2
+namespace eval ::ftpd {
+
+ # The listening port.
+
+ variable port 21
+
+ variable contact
+ if {![info exists contact]} {
+ global tcl_platform
+ set contact "$tcl_platform(user)@[info hostname]"
+ }
+
+ variable cwd
+ if {![info exists cwd]} {
+ set cwd ""
+ }
+
+ variable welcome
+ if {![info exists welcome]} {
+ set welcome "[info hostname] FTP server ready."
+ }
+
+ # Global configuration.
+
+ variable cfg
+ if {![info exists cfg]} {
+ array set cfg [list \
+ closeCmd {} \
+ authIpCmd {} \
+ authUsrCmd {::ftpd::anonAuth} \
+ authFileCmd {::ftpd::fileAuth} \
+ logCmd {::ftpd::logStderr} \
+ fsCmd {::ftpd::fsFile::fs} \
+ xferDoneCmd {}]
+ }
+
+ variable commands
+ if {![info exists commands]} {
+ array set commands [list \
+ ABOR {ABOR (abort operation)} \
+ ACCT {(specify account); unimplemented.} \
+ ALLO {(allocate storage - vacuously); unimplemented.} \
+ APPE {APPE <sp> file-name} \
+ CDUP {CDUP (change to parent directory)} \
+ CWD {CWD [ <sp> directory-name ]} \
+ DELE {DELE <sp> file-name} \
+ HELP {HELP [ <sp> <string> ]} \
+ LIST {LIST [ <sp> path-name ]} \
+ NLST {NLST [ <sp> path-name ]} \
+ MAIL {(mail to user); unimplemented.} \
+ MDTM {MDTM <sp> path-name} \
+ MKD {MKD <sp> path-name} \
+ MLFL {(mail file); unimplemented.} \
+ MODE {(specify transfer mode); unimplemented.} \
+ MRCP {(mail recipient); unimplemented.} \
+ MRSQ {(mail recipient scheme question); unimplemented.} \
+ MSAM {(mail send to terminal and mailbox); unimplemented.} \
+ MSND {(mail send to terminal); unimplemented.} \
+ MSOM {(mail send to terminal or mailbox); unimplemented.} \
+ NOOP {NOOP} \
+ PASS {PASS <sp> password} \
+ PASV {(set server in passive mode); unimplemented.} \
+ PORT {PORT <sp> b0, b1, b2, b3, b4, b5} \
+ PWD {PWD (return current directory)} \
+ QUIT {QUIT (terminate service)} \
+ REIN {REIN (reinitialize server state)} \
+ REST {(restart command); unimplemented.} \
+ RETR {RETR <sp> file-name} \
+ RMD {RMD <sp> path-name} \
+ RNFR {RNFR <sp> file-name} \
+ RNTO {RNTO <sp> file-name} \
+ SIZE {SIZE <sp> path-name} \
+ SMNT {(structure mount); unimplemented.} \
+ STOR {STOR <sp> file-name} \
+ STOU {STOU <sp> file-name} \
+ STRU {(specify file structure); unimplemented.} \
+ SYST {SYST (get type of operating system)} \
+ TYPE {TYPE <sp> [ A | E | I | L ]} \
+ USER {USER <sp> username} \
+ XCUP {XCUP (change to parent directory)} \
+ XCWD {XCWD [ <sp> directory-name ]} \
+ XMKD {XMKD <sp> path-name} \
+ XPWD {XPWD (return current directory)} \
+ XRMD {XRMD <sp> path-name}]
+ }
+
+ variable passwords [list ]
+
+ # Exported procedures
+
+ namespace export config hasCallback logStderr
+ namespace export fileAuth anonAuth unixAuth server accept read
+}
+
+
+# ::ftpd::config --
+#
+# Configure the configurable parameters of the ftp daemon.
+#
+# Arguments:
+# options - -authIpCmd proc procedure that accepts or rejects an
+# incoming connection. A value of 0 or
+# an error causes the connection to be
+# rejected. There is no default.
+# -authUsrCmd proc procedure that accepts or rejects a
+# login. Defaults to ::ftpd::anonAuth
+# -authFileCmd proc procedure that accepts or rejects
+# access to read or write a certain
+# file or path. Defaults to
+# ::ftpd::userAuth
+# -logCmd proc procedure that logs information from
+# the ftp engine. Default is
+# ::ftpd::logStderr
+# -fsCmd proc procedure to connect the ftp engine
+# to the file system it operates on.
+# Default is ::ftpd::fsFile::fs
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Changes the value of the specified configurables.
+
+proc ::ftpd::config {args} {
+
+ # Processing of global configuration changes.
+
+ package require cmdline
+
+ variable cfg
+
+ # Make default value be the current value so we can call this
+ # command multiple times without resetting already set values
+
+ array set cfg [cmdline::getoptions args [list \
+ [list closeCmd.arg $cfg(closeCmd) {Callback when a connection is closed.}] \
+ [list authIpCmd.arg $cfg(authIpCmd) {Callback to authenticate new connections based on the ip-address of the peer. Optional}] \
+ [list authUsrCmd.arg $cfg(authUsrCmd) {Callback to authenticate new connections based on the user logging in.}] \
+ [list authFileCmd.arg $cfg(authFileCmd) {Callback to accept or deny a users access to read and write to a specific path or file.}] \
+ [list logCmd.arg $cfg(logCmd) {Callback for log information generated by the FTP engine.}] \
+ [list xferDoneCmd.arg $cfg(xferDoneCmd) {Callback for transfer completion notification. Optional}] \
+ [list fsCmd.arg $cfg(fsCmd) {Callback to connect the engine to the filesystem it operates on.}]]]
+ return
+}
+
+
+# ::ftpd::hasCallback --
+#
+# Determines whether or not a non-NULL callback has been defined for one
+# of the callback types.
+#
+# Arguments:
+# callbackType - One of authIpCmd, authUsrCmd, logCmd, or fsCmd
+#
+# Results:
+# Returns 1 if a non-NULL callback has been specified for the
+# callbackType that is passed in.
+#
+# Side Effects:
+# None.
+
+proc ::ftpd::hasCallback {callbackType} {
+ variable cfg
+
+ return [expr {[info exists cfg($callbackType)] && [string length $cfg($callbackType)]}]
+}
+
+
+# ::ftpd::logStderr --
+#
+# Outputs a message with the specified severity to stderr. The default
+# logCmd callback.
+#
+# Arguments:
+# severity - The severity of the error. One of debug, error,
+# or note.
+# text - The error message.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# A message is written to the stderr channel.
+
+proc ::ftpd::logStderr {severity text} {
+
+ # Standard log handler. Prints to stderr.
+
+ puts stderr "\[$severity\] $text"
+ return
+}
+
+
+# ::ftpd::Log --
+#
+# Used for all ftpd logging.
+#
+# Arguments:
+# severity - The severity of the error. One of debug, error,
+# or note.
+# text - The error message.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The ftpd logCmd callback is called with the specified severity and
+# text if there is a non-NULL ftpCmd.
+
+proc ::ftpd::Log {severity text} {
+
+ # Central call out to log handlers.
+
+ variable cfg
+
+ if {[hasCallback logCmd]} {
+ set cmd $cfg(logCmd)
+ lappend cmd $severity $text
+ eval $cmd
+ }
+ return
+}
+
+
+# ::ftpd::fileAuth --
+#
+# Given a username, path, and operation- decides whether or not to accept
+# the attempted read or write operation.
+#
+# Arguments:
+# user - The name of the user that is attempting to
+# connect to the ftpd.
+# path - The path or filename that the user is attempting
+# to read or write.
+# operation - read or write.
+#
+# Results:
+# Returns 0 if it rejects access and 1 if it accepts access.
+#
+# Side Effects:
+# None.
+
+proc ::ftpd::fileAuth {user path operation} {
+ # Standard authentication handler
+
+ if {(![Fs exists $path]) && ([string equal $operation "write"])} {
+ if {[Fs exists [file dirname $path]]} {
+ set path [file dirname $path]
+ }
+ } elseif {(![Fs exists $path]) && ([string equal $operation "read"])} {
+ return 0
+ }
+
+ if {[Fs exists $path]} {
+ set mode [Fs permissions $path]
+ if {([string equal $operation "read"] && (($mode & 00004) > 0)) || \
+ ([string equal $operation "write"] && (($mode & 00002) > 0))} {
+ return 1
+ }
+ }
+ return 0
+}
+
+# ::ftpd::anonAuth --
+#
+# Given a username and password, decides whether or not to accept the
+# attempted login. This is the default ftpd authUsrCmd callback. By
+# default it accepts the annonymous user and does some basic checking
+# checking on the form of the password to see if it has the form of an
+# email address.
+#
+# Arguments:
+# user - The name of the user that is attempting to
+# connect to the ftpd.
+# pass - The password of the user that is attempting to
+# connect to the ftpd.
+#
+# Results:
+# Returns 0 if it rejects the login and 1 if it accepts the login.
+#
+# Side Effects:
+# None.
+
+proc ::ftpd::anonAuth {user pass} {
+ # Standard authentication handler
+ #
+ # Accept user 'anonymous' if a password was
+ # provided which is at least similar to an
+ # fully qualified email address.
+
+ if {(![string equal $user anonymous]) && (![string equal $user ftp])} {
+ return 0
+ }
+
+ set pass [split $pass @]
+ if {[llength $pass] != 2} {
+ return 0
+ }
+
+ set domain [split [lindex $pass 1] .]
+ if {[llength $domain] < 2} {
+ return 0
+ }
+
+ return 1
+}
+
+# ::ftpd::unixAuth --
+#
+# Given a username and password, decides whether or not to accept the
+# attempted login. This is an alternative to the default ftpd
+# authUsrCmd callback. By default it accepts the annonymous user and does
+# some basic checking checking on the form of the password to see if it
+# has the form of an email address.
+#
+# Arguments:
+# user - The name of the user that is attempting to
+# connect to the ftpd.
+# pass - The password of the user that is attempting to
+# connect to the ftpd.
+#
+# Results:
+# Returns 0 if it rejects the login and 1 if it accepts the login.
+#
+# Side Effects:
+# None.
+
+proc ::ftpd::unixAuth {user pass} {
+
+ variable passwords
+ array set password $passwords
+
+ # Standard authentication handler
+ #
+ # Accept user 'anonymous' if a password was
+ # provided which is at least similar to an
+ # fully qualified email address.
+
+ if {([llength $passwords] == 0) && (![catch {package require crypt}])} {
+ foreach file [list /etc/passwd /etc/shadow] {
+ if {([file exists $file]) && ([file readable $file])} {
+ set fh [open $file r]
+ set data [read $fh [file size $file]]
+ foreach line [split $data \n] {
+ foreach {username passwd uid gid dir sh} [split $line :] {
+ if {[string length $passwd] > 2} {
+ set password($username) $passwd
+ } elseif {$passwd == ""} {
+ set password($username) ""
+ }
+ break
+ }
+ }
+ }
+ }
+ set passwords [array get password]
+ }
+
+ ::ftpd::Log debug $passwords
+
+ if {[string equal $user anonymous] || [string equal $user ftp]} {
+
+ set pass [split $pass @]
+ if {[llength $pass] != 2} {
+ return 0
+ }
+
+ set domain [split [lindex $pass 1] .]
+ if {[llength $domain] < 2} {
+ return 0
+ }
+
+ return 1
+ }
+
+ if {[info exists password($user)]} {
+ if {$password($user) == ""} {
+ return 1
+ }
+ if {[string equal $password($user) [::crypt $pass $password($user)]]} {
+ return 1
+ }
+ }
+
+ return 0
+}
+
+# ::ftpd::server --
+#
+# Creates a server socket at the specified port.
+#
+# Arguments:
+# myaddr - The domain-style name or numerical IP address of
+# the client-side network interface to use for the
+# connection. The name of the user that is
+# attempting to connect to the ftpd.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# A listener is setup on the specified port which will call
+# ::ftpd::accept when it is connected to.
+
+proc ::ftpd::server {{myaddr {}}} {
+ variable port
+ variable serviceSock
+ if {[string length $myaddr]} {
+ set serviceSock [socket -server ::ftpd::accept -myaddr $myaddr $port]
+ } else {
+ set serviceSock [socket -server ::ftpd::accept $port]
+ }
+ set port [lindex [fconfigure $serviceSock -sockname] 2]
+ return
+}
+
+
+# ::ftpd::accept --
+#
+# Checks if the connecting IP is authorized to connect or not. If not
+# the socket is closed and failure is logged. Otherwise, a welcome is
+# printed out, and a ftpd::Read filevent is placed on the socket.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# ipaddr - The client's IP address.
+# client_port - The client's port number.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Sets up a ftpd::Read fileevent to trigger whenever the channel is
+# readable. Logs an error and closes the connection if the IP is
+# not authorized to connect.
+
+proc ::ftpd::accept {sock ipaddr client_port} {
+ upvar #0 ::ftpd::$sock data
+ variable welcome
+ variable cfg
+ variable cwd
+ variable CurrentSocket
+
+ set CurrentSocket $sock
+ if {[info exists data]} {
+ unset data
+ }
+
+ if {[hasCallback authIpCmd]} {
+ # Call out to authenticate the peer. A return value of 0 or an
+ # error causes the system to reject the connection. Everything
+ # else (with 1 prefered) leads to acceptance.
+
+ set cmd $cfg(authIpCmd)
+ lappend cmd $ipaddr
+
+ set fail [catch {eval $cmd} res]
+
+ if {$fail} {
+ Log error "AuthIp error: $res"
+ }
+ if {$fail || ($res == 0)} {
+ Log note "AuthIp: Access denied to $ipaddr"
+
+ # Now: Close the connection. (Is there a standard response
+ # before closing down to signal the peer that we don't want
+ # to talk to it ? -> read RFC).
+
+ close $sock
+ return
+ }
+
+ # Accept the connection (for now, 'authUsrCmd' may revoke this
+ # decision).
+ }
+
+ array set data [list \
+ access 0 \
+ ip $ipaddr \
+ state command \
+ buffering line \
+ cwd "$cwd" \
+ mode binary \
+ sock2a "" \
+ sock2 ""]
+
+ fconfigure $sock -buffering line
+ fileevent $sock readable [list ::ftpd::Read $sock]
+ puts $sock "220 $welcome"
+
+ Log debug "Accept $ipaddr"
+ return
+}
+
+# ::ftpd::Read --
+#
+# Checks the state of a channel and then reads a command from the
+# channel if it is not at end of file yet. If there is a command named
+# ftpd::command::* where '*' is the all upper case name of the command,
+# then that proc is called to handle the command with the remaining parts
+# of the command that was read from the channel as arguments.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Runs the appropriate command depending on the state in the state
+# machine, and the command that is specified.
+
+proc ::ftpd::Read {sock} {
+ upvar #0 ::ftpd::$sock data
+ variable CurrentSocket
+
+ set CurrentSocket $sock
+ if {[eof $sock]} {
+ Finish $sock
+ return
+ }
+ switch -exact -- $data(state) {
+ command {
+ gets $sock command
+ set argument ""
+ if {![regexp {^([^ ]+) (.*)$} $command -> cmd argument]} {
+ if {![regexp {^([^ ]+)$} $command -> cmd]} {
+ # Very bad command syntax.
+ puts $sock "500 Command not understood."
+ return
+ }
+ }
+ set cmd [string toupper $cmd]
+ auto_load ::ftpd::command::$cmd
+ if {($data(access) == 0) && ((![info exists data(user)]) || \
+ ($data(user) == "")) && (![string equal $cmd "USER"])} {
+ if {[string equal $cmd "PASS"]} {
+ puts $sock "503 Login with USER first."
+ } else {
+ puts $sock "530 Please login with USER and PASS."
+ }
+ } elseif {($data(access) == 0) && (![string equal $cmd "PASS"]) \
+ && (![string equal $cmd "USER"]) \
+ && (![string equal $cmd "QUIT"])} {
+ puts $sock "530 Please login with USER and PASS."
+ } elseif {[info commands ::ftpd::command::$cmd] != ""} {
+ Log debug $command
+ ::ftpd::command::$cmd $sock $argument
+ catch {flush $sock}
+ } else {
+ Log error "Unknown command: $cmd"
+ puts $sock "500 Unknown command $cmd"
+ }
+ }
+ default {
+ error "Unknown state \"$data(state)\""
+ }
+ }
+ return
+}
+
+# ::ftpd::Finish --
+#
+# Closes the socket connection between the ftpd and client.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The channel is closed.
+
+proc ::ftpd::Finish {sock} {
+ upvar #0 ::ftpd::$sock data
+ variable cfg
+
+ if {[hasCallback closeCmd]} then {
+ ##
+ ## User specified a close command so invoke it
+ ##
+ uplevel #0 $cfg(closeCmd)
+ }
+ close $sock
+ if {[info exists data]} {
+ unset data
+ }
+ return
+}
+
+# ::ftpd::FinishData --
+#
+# Closes the data socket connection that is created when the 'PORT'
+# command is recieved.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The data channel is closed.
+
+proc ::ftpd::FinishData {sock} {
+ upvar #0 ::ftpd::$sock data
+ catch {close $data(sock2)}
+ set data(sock2) {}
+ return
+}
+
+# ::ftpd::Fs --
+#
+# The general filesystem command. Used as an intermediary for filesystem
+# access to allow alternate (virtual, etc.) filesystems to be used. The
+# ::ftpd::Fs command will call out to the fsCmd callback with the
+# subcommand and arguments that are passed to it.
+#
+# The fsCmd callback is called in the following ways:
+#
+# <cmd> append <path>
+# <cmd> delete <path> <channel-to-write-to>
+# <cmd> dlist <path> <style> <channel-to-write-dir-list-to>
+# <cmd> exists <path>
+# <cmd> mkdir <path> <channel-to-write-to>
+# <cmd> mtime <path> <channel-to-write-mtime-to>
+# <cmd> permissions <path>
+# <cmd> rename <path> <newpath> <channel-to-write-to>
+# <cmd> retr <path>
+# <cmd> rmdir <path> <channel-to-write-to>
+# <cmd> size <path> <channel-to-write-size-to>
+# <cmd> store <path>
+#
+# Arguments:
+# command - The filesystem command (one of dlist, retr, or
+# store). 'dlist' will list files in a
+# directory, 'retr' will get a channel to
+# to read the specified file from, 'store'
+# will return the channel to write to, and
+# 'mtime' will print the modification time.
+# path - The file name or directory to read, write, or
+# list.
+# args - Additional arguments for filesystem commands.
+# Currently this is used by 'dlist' which
+# has two additional arguments 'style' and
+# 'channel-to-write-dir-list-to'. It is also
+# used by 'size' and 'mtime' which have one
+# additional argument 'channel-to-write-to'.
+#
+# Results:
+# For a 'appe', 'retr', or 'stor' a channel is returned. For 'exists'
+# a 1 is returned if the path exists, and is not a directory. Otherwise
+# a 0 is returned. For 'permissions' the octal file permissions (i.e.
+# the 'file stat' mode) are returned.
+#
+# Side Effects:
+# For 'dlist' a directory listing for the specified path is written to
+# the specified channel. For 'mtime' the modification time is written
+# or an error is thrown. An error is thrown if there is no fsCmd
+# callback configured for the ftpd.
+
+proc ::ftpd::Fs {command path args} {
+ variable cfg
+
+ if {![hasCallback fsCmd]} {
+ error "-fsCmd must not be empty, need a way to access files."
+ }
+
+ return [eval [list $cfg(fsCmd) $command $path] $args]
+}
+
+# Create a namespace to hold one proc for each ftp command (in upper case
+# letters) that is supported by the ftp daemon. The existance of a proc
+# in this namespace is the way that the list of supported commands is
+# determined, and the procs in this namespace are invoked to handle the
+# ftp commands with the same name as the procs.
+
+namespace eval ::ftpd::command {
+ # All commands in this namespace are private, no export.
+}
+
+# ::ftpd::command::ABOR --
+#
+# Handle the ABOR ftp command. Closes the data socket if it
+# is open, and then prints the appropriate success message.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the APPE command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The data is copied to from the socket data(sock2) to the
+# writable channel to create a file.
+
+proc ::ftpd::command::ABOR {sock list} {
+
+ ::ftpd::FinishData $sock
+ puts $sock "225 ABOR command successful."
+
+ return
+}
+
+# ::ftpd::command::APPE --
+#
+# Handle the APPE ftp command. Gets a writable channel for the file
+# specified from ::ftpd::Fs and copies the data from data(sock2) to
+# the writable channel. If the filename already exists the data is
+# appended, otherwise the file is created and then written.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the APPE command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The data is copied to from the socket data(sock2) to the
+# writable channel to create a file.
+
+proc ::ftpd::command::APPE {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+ #
+ # Patched Mark O'Connor
+ #
+ if {![catch {::ftpd::Fs append $path $data(mode)} f]} {
+ puts $sock "150 Copy Started ($data(mode))"
+ ::ftpd::PasvCheckAndWait $sock
+ fcopy $data(sock2) $f -command [list ::ftpd::GetDone $sock $data(sock2) $f ""]
+ } else {
+ puts $sock "500 Copy Failed: $path $f"
+ ::ftpd::FinishData $sock
+ }
+ return
+}
+
+# ::ftpd::command::CDUP --
+#
+# Handle the CDUP ftp command. Change the current working directory to
+# the directory above the current working directory.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the CDUP command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Changes the data(cwd) to the appropriate directory.
+
+proc ::ftpd::command::CDUP {sock list} {
+ upvar #0 ::ftpd::$sock data
+
+ set data(cwd) [file dirname $data(cwd)]
+ puts $sock "200 CDUP command successful."
+ return
+}
+
+# ::ftpd::command::CWD --
+#
+# Handle the CWD ftp command. Change the current working directory.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the CWD command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Changes the data(cwd) to the appropriate directory.
+
+proc ::ftpd::command::CWD {sock relativepath} {
+ upvar #0 ::ftpd::$sock data
+
+ if {[string equal $relativepath .]} {
+ puts $sock "250 CWD command successful."
+ return
+ }
+
+ if {[string equal $relativepath ..]} {
+ set data(cwd) [file dirname $data(cwd)]
+ puts $sock "250 CWD command successful."
+ return
+ }
+
+ set path [file join $data(cwd) $relativepath]
+
+ if {[::ftpd::Fs exists $path]} {
+ puts $sock "550 not a directory"
+ return
+ }
+
+ set data(cwd) $path
+ puts $sock "250 CWD command successful."
+ return
+}
+
+# ::ftpd::command::DELE --
+#
+# Handle the DELE ftp command. Delete the specified file.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the DELE command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The specified file is deleted.
+
+proc ::ftpd::command::DELE {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+ if {[catch {::ftpd::Fs delete $path $sock} msg]} {
+ puts $sock "500 DELE Failed: $path $msg"
+ }
+ return
+}
+
+# ::ftpd::command::HELP --
+#
+# Handle the HELP ftp command. Display a list of commands
+# or syntax information about the supported commands.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the HELP command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Displays a helpful message.
+
+proc ::ftpd::command::HELP {sock command} {
+ upvar #0 ::ftpd::$sock data
+
+ if {$command != ""} {
+ set command [string toupper $command]
+ if {![info exists ::ftpd::commands($command)]} {
+ puts $sock "502 Unknown command '$command'."
+ } elseif {[info commands ::ftpd::command::$command] == ""} {
+ puts $sock "214 $command\t$::ftpd::commands($command)"
+ } else {
+ puts $sock "214 Syntax: $::ftpd::commands($command)"
+ }
+ } else {
+ set commandList [lsort [array names ::ftpd::commands]]
+ puts $sock "214-The following commands are recognized (* =>'s unimplemented)."
+ set i 1
+ foreach commandName $commandList {
+ if {[info commands ::ftpd::command::$commandName] == ""} {
+ puts -nonewline $sock [format " %-7s" "${commandName}*"]
+ } else {
+ puts -nonewline $sock [format " %-7s" $commandName]
+ }
+ if {($i % 8) == 0} {
+ puts $sock ""
+ }
+ incr i
+ }
+ incr i -1
+ if {($i % 8) != 0} {
+ puts $sock ""
+ }
+ puts $sock "214 Direct comments to $::ftpd::contact."
+ }
+
+ return
+}
+
+# ::ftpd::command::LIST --
+#
+# Handle the LIST ftp command. Lists the names of the files in the
+# specified path.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the LIST command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# A listing of files is written to the socket.
+
+proc ::ftpd::command::LIST {sock filename} {
+ ::ftpd::List $sock $filename list
+ return
+}
+
+# ::ftpd::command::MDTM --
+#
+# Handle the MDTM ftp command. Prints the modification time of the
+# specified file to the socket.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the MDTM command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Prints the modification time of the specified file to the socket.
+
+proc ::ftpd::command::MDTM {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+ if {[catch {::ftpd::Fs mtime $path $sock} msg]} {
+ puts $sock "500 MDTM Failed: $path $msg"
+ ::ftpd::FinishData $sock
+ }
+ return
+}
+
+# ::ftpd::command::MKD --
+#
+# Handle the MKD ftp command. Create the specified directory.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the MKD command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The directory specified by $path (if it exists) is deleted.
+
+proc ::ftpd::command::MKD {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+ if {[catch {::ftpd::Fs mkdir $path $sock} f]} {
+ puts $sock "500 MKD Failed: $path $f"
+ }
+ return
+}
+
+# ::ftpd::command::NOOP --
+#
+# Handle the NOOP ftp command. Do nothing.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the NOOP command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Prints the proper NOOP response.
+
+proc ::ftpd::command::NOOP {sock list} {
+
+ puts $sock "200 NOOP command successful."
+ return
+}
+
+# ::ftpd::command::NLST --
+#
+# Handle the NLST ftp command. Lists the full file stat of all of the
+# files that are in the specified path.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the NLST command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# A listing of file stats is written to the socket.
+
+proc ::ftpd::command::NLST {sock filename} {
+ ::ftpd::List $sock $filename nlst
+ return
+}
+
+# ::ftpd::command::PASS --
+#
+# Handle the PASS ftp command. Check whether the specified user
+# and password are allowed to log in (using the authUsrCmd). If
+# they are allowed to log in, they are allowed to continue. If
+# not ::ftpd::Log is used to log and error, and an "Access Denied"
+# error is sent back.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the PASS command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The user is accepted, or an error is logged and the user/password is
+# denied..
+
+proc ::ftpd::command::PASS {sock password} {
+ upvar #0 ::ftpd::$sock data
+
+ if {$password == ""} {
+ puts $sock "530 Please login with USER and PASS."
+ return
+ }
+ set data(pass) $password
+
+ ::ftpd::Log debug "pass <$data(pass)>"
+
+ if {![::ftpd::hasCallback authUsrCmd]} {
+ error "-authUsrCmd must not be empty, need a way to authenticate the user."
+ }
+
+ # Call out to authenticate the user. A return value of 0 or an
+ # error causes the system to reject the connection. Everything
+ # else (with 1 prefered) leads to acceptance.
+
+ set cmd $::ftpd::cfg(authUsrCmd)
+ lappend cmd $data(user) $data(pass)
+
+ set fail [catch {eval $cmd} res]
+
+ if {$fail} {
+ ::ftpd::Log error "AuthUsr error: $res"
+ }
+ if {$fail || ($res == 0)} {
+ ::ftpd::Log note "AuthUsr: Access denied to <$data(user)> <$data(pass)>."
+ unset data(user)
+ unset data(pass)
+ puts $sock "551 Access Denied"
+ } else {
+ puts $sock "230 OK"
+ set data(access) 1
+ }
+ return
+}
+
+# ::ftpd::command::PORT --
+#
+# Handle the PORT ftp command. Create a new socket with the specified
+# paramaters.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the PORT command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# A new socket, data(sock2), is opened.
+
+proc ::ftpd::command::PORT {sock numbers} {
+ upvar #0 ::ftpd::$sock data
+ set x [split $numbers ,]
+
+ ::ftpd::FinishData $sock
+
+ set data(sock2) [socket [join [lrange $x 0 3] .] \
+ [expr {([lindex $x 4] << 8) | [lindex $x 5]}]]
+ fconfigure $data(sock2) -translation $data(mode)
+ puts $sock "200 PORT OK"
+ return
+}
+
+# ::ftpd::command::PWD --
+#
+# Handle the PWD ftp command. Prints the current working directory to
+# the socket.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the PWD command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Prints the current working directory to the socket.
+
+proc ::ftpd::command::PWD {sock list} {
+ upvar #0 ::ftpd::$sock data
+ ::ftpd::Log debug $data(cwd)
+ puts $sock "257 \"$data(cwd)\" is current directory."
+ return
+}
+
+# ::ftpd::command::QUIT --
+#
+# Handle the QUIT ftp command. Closes the socket.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the PWD command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Closes the connection.
+
+proc ::ftpd::command::QUIT {sock list} {
+ ::ftpd::Log note "Closed $sock"
+ puts $sock "221 Goodbye."
+ ::ftpd::Finish $sock
+ # FRINK: nocheck
+ #unset ::ftpd::$sock
+ return
+}
+
+# ::ftpd::command::REIN --
+#
+# Handle the REIN ftp command. This command terminates a USER, flushing
+# all I/O and account information, except to allow any transfer in
+# progress to be completed. All parameters are reset to the default
+# settings and the control connection is left open.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the REIN command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The file specified by $path (if it exists) is copied to the socket
+# data(sock2) otherwise a 'Copy Failed' message is output.
+
+proc ::ftpd::command::REIN {sock list} {
+ upvar #0 ::ftpd::$sock data
+
+ ::ftpd::FinishData $sock
+ catch {close $data(sock2a)}
+
+ # Reinitialize the user and connection data.
+
+ array set data [list \
+ access 0 \
+ state command \
+ buffering line \
+ cwd "$::ftpd::cwd" \
+ mode binary \
+ sock2a "" \
+ sock2 ""]
+
+ return
+}
+
+# ::ftpd::command::RETR --
+#
+# Handle the RETR ftp command. Gets a readable channel for the file
+# specified from ::ftpd::Fs and copies the file to second socket
+# data(sock2).
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the RETR command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The file specified by $path (if it exists) is copied to the socket
+# data(sock2) otherwise a 'Copy Failed' message is output.
+
+proc ::ftpd::command::RETR {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path read
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+ #
+ # Patched Mark O'Connor
+ #
+ if {![catch {::ftpd::Fs retr $path $data(mode)} f]} {
+ puts $sock "150 Copy Started ($data(mode))"
+ ::ftpd::PasvCheckAndWait $sock
+ fcopy $f $data(sock2) -command [list ::ftpd::GetDone $sock $data(sock2) $f ""]
+ } else {
+ puts $sock "500 Copy Failed: $path $f"
+ ::ftpd::FinishData $sock
+ }
+ return
+}
+
+# ::ftpd::command::RMD --
+#
+# Handle the RMD ftp command. Remove the specified directory.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the RMD command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The directory specified by $path (if it exists) is deleted.
+
+proc ::ftpd::command::RMD {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+ if {[catch {::ftpd::Fs rmdir $path $sock} f]} {
+ puts $sock "500 RMD Failed: $path $f"
+ }
+ return
+}
+
+# ::ftpd::command::RNFR --
+#
+# Handle the RNFR ftp command. Stores the name of the file to rename
+# from.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the RNFR command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# If the file specified by $path exists, then store the name and request
+# the next name.
+
+proc ::ftpd::command::RNFR {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+
+ if {[::ftpd::Fs exists $path]} {
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+ puts $sock "350 File exists, ready for destination name"
+ set data(renameFrom) $path
+ } else {
+ puts $sock "550 $path: No such file or directory."
+ }
+ return
+}
+
+# ::ftpd::command::RNTO --
+#
+# Handle the RNTO ftp command. Renames the file specified by 'RNFR' if
+# one was specified.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the RNTO command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The specified file is renamed.
+
+proc ::ftpd::command::RNTO {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ if {$filename == ""} {
+ puts $sock "500 'RNTO': command not understood."
+ return
+ }
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+
+ if {![info exists data(renameFrom)]} {
+ puts $sock "503 Bad sequence of commands."
+ return
+ }
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+
+ if {![catch {::ftpd::Fs rename $data(renameFrom) $path $sock} msg]} {
+ unset data(renameFrom)
+ } else {
+ unset data(renameFrom)
+ puts $sock "500 'RNTO': command not understood."
+ }
+ return
+}
+
+# ::ftpd::command::SIZE --
+#
+# Handle the SIZE ftp command. Prints the modification time of the
+# specified file to the socket.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the MDTM command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Prints the size of the specified file to the socket.
+
+proc ::ftpd::command::SIZE {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+ if {[catch {::ftpd::Fs size $path $sock} msg]} {
+ puts $sock "500 SIZE Failed: $path $msg"
+ ::ftpd::FinishData $sock
+ }
+ return
+}
+
+# ::ftpd::command::STOR --
+#
+# Handle the STOR ftp command. Gets a writable channel for the file
+# specified from ::ftpd::Fs and copies the data from data(sock2) to
+# the writable channel.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the STOR command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The data is copied to from the socket data(sock2) to the
+# writable channel to create a file.
+
+proc ::ftpd::command::STOR {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+ #
+ # Patched Mark O'Connor
+ #
+ if {![catch {::ftpd::Fs store $path $data(mode)} f]} {
+ puts $sock "150 Copy Started ($data(mode))"
+ ::ftpd::PasvCheckAndWait $sock
+ fcopy $data(sock2) $f -command [list ::ftpd::GetDone $sock $data(sock2) $f ""]
+ } else {
+ puts $sock "500 Copy Failed: $path $f"
+ ::ftpd::FinishData $sock
+ }
+ return
+}
+
+# ::ftpd::command::STOU --
+#
+# Handle the STOR ftp command. Gets a writable channel for the file
+# specified from ::ftpd::Fs and copies the data from data(sock2) to
+# the writable channel.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the STOU command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The data is copied to from the socket data(sock2) to the
+# writable channel to create a file.
+
+proc ::ftpd::command::STOU {sock filename} {
+ upvar #0 ::ftpd::$sock data
+
+ set path [file join $data(cwd) [string trimleft $filename /]]
+ if {[::ftpd::hasCallback authFileCmd]} {
+ set cmd $::ftpd::cfg(authFileCmd)
+ lappend cmd $data(user) $path write
+ if {[eval $cmd] == 0} {
+ puts $sock "550 $filename: Permission denied"
+ return
+ }
+ }
+
+ set file $path
+ set i 0
+ while {[::ftpd::Fs exists $file]} {
+ set file "$path.$i"
+ incr i
+ }
+
+ #
+ # Patched Mark O'Connor
+ #
+ if {![catch {::ftpd::Fs store $file $data(mode)} f]} {
+ puts $sock "150 Copy Started ($data(mode))"
+ ::ftpd::PasvCheckAndWait $sock
+ fcopy $data(sock2) $f -command [list ::ftpd::GetDone $sock $data(sock2) $f $file]
+ } else {
+ puts $sock "500 Copy Failed: $path $f"
+ ::ftpd::FinishData $sock
+ }
+ return
+}
+
+# ::ftpd::command::SYST --
+#
+# Handle the SYST ftp command. Print the system information.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the SYST command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Prints the system information.
+
+proc ::ftpd::command::SYST {sock list} {
+ upvar #0 ::ftpd::$sock data
+
+ global tcl_platform
+
+ if {[string equal $tcl_platform(platform) "unix"]} {
+ set platform UNIX
+ } elseif {[string equal $tcl_platform(platform) "windows"]} {
+ set platform WIN32
+ } elseif {[string equal $tcl_platform(platform) "macintosh"]} {
+ set platform MACOS
+ } else {
+ set platform UNKNOWN
+ }
+ set version [string toupper $tcl_platform(os)]
+ puts $sock "215 $platform Type: L8 Version: $version"
+
+ return
+}
+
+# ::ftpd::command::TYPE --
+#
+# Handle the TYPE ftp command. Sets up the proper translation mode on
+# the data socket data(sock2)
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the TYPE command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The translation mode of the data channel is changed to the appropriate
+# mode.
+
+proc ::ftpd::command::TYPE {sock type} {
+ upvar #0 ::ftpd::$sock data
+
+ if {[string compare i [string tolower $type]] == 0} {
+ set data(mode) binary
+ } else {
+ set data(mode) auto
+ }
+
+ if {$data(sock2) != {}} {
+ fconfigure $data(sock2) -translation $data(mode)
+ }
+ puts $sock "200 Type set to $type."
+ return
+}
+
+# ::ftpd::command::USER --
+#
+# Handle the USER ftp command. Store the username, and request a
+# password.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# list - The arguments to the USER command.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# A message is printed asking for the password.
+
+proc ::ftpd::command::USER {sock username} {
+ upvar #0 ::ftpd::$sock data
+
+ if {$username == ""} {
+ puts $sock "530 Please login with USER and PASS."
+ return
+ }
+ set data(user) $username
+ puts $sock "331 Password Required"
+
+ ::ftpd::Log debug "user <$data(user)>"
+ return
+}
+
+# ::ftpd::GetDone --
+#
+# The fcopy command callback for both the RETR and STOR calls. Called
+# after the fcopy completes.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# sock2 - The data socket data(sock2).
+# f - The file channel.
+# filename - The name of the unique file (if a unique
+# transfer was requested), and the empty string
+# otherwise
+# bytes - The number of bytes that were copied.
+# err - Passed if an error occurred during the fcopy.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# The open file channel is closed and a 'complete' message is printed to
+# the socket.
+
+proc ::ftpd::GetDone {sock sock2 f filename bytes {err {}}} {
+ upvar #0 ::ftpd::$sock data
+ variable cfg
+
+ close $f
+ FinishData $sock
+
+ if {[string length $err]} {
+ puts $sock "226- $err"
+ } elseif {$filename == ""} {
+ puts $sock "226 Transfer complete ($bytes bytes)"
+ } else {
+ puts $sock "226 Transfer complete (unique file name: $filename)."
+ }
+ if {[hasCallback xferDoneCmd]} then {
+ catch {$cfg(xferDoneCmd) $sock $sock2 $f $bytes $filename $err}
+ }
+ Log debug "GetDone $f $sock2 $bytes bytes filename: $filename"
+ return
+}
+
+# ::ftpd::List --
+#
+# Handle the NLST and LIST ftp commands. Shared command to do the
+# actual listing of files.
+#
+# Arguments:
+# sock - The channel for this connection to the ftpd.
+# filename - The path/filename to list.
+# style - The type of listing -- nlst or list.
+#
+# Results:
+# None.
+#
+# Side Effects:
+# A listing of file stats is written to the socket.
+
+proc ::ftpd::List {sock filename style} {
+ upvar #0 ::ftpd::$sock data
+ puts $sock "150 Opening data channel"
+
+ set path [file join $data(cwd) $filename]
+
+ PasvCheckAndWait $sock
+ Fs dlist $path $style $data(sock2)
+
+ FinishData $sock
+ puts $sock "226 Listing complete"
+ return
+}
+
+# Standard filesystem - Assume the files are held on a standard disk. This
+# namespace contains the commands to act as the default fsCmd callback for the
+# ftpd.
+
+namespace eval ::ftpd::fsFile {
+ # Our document root directory
+
+ variable docRoot
+ if {![info exists docRoot]} {
+ set docRoot /
+ }
+
+ namespace export docRoot fs
+}
+
+# ::ftpd::fsFile::docRoot --
+#
+# Set or query the root of the ftpd file system. If no 'dir' argument
+# is passed, or if the 'dir' argument is the null string, then the
+# current docroot is returned. If a non-NULL 'dir' argument is passed
+# in it is set as the docRoot.
+#
+# Arguments:
+# dir - The directory to set as the ftp docRoot.
+# (optional. If unspecified, the current docRoot
+# is returned).
+#
+# Results:
+# None.
+#
+# Side Effects:
+# Sets the docRoot to the specified directory if a directory is
+# specified.
+
+proc ::ftpd::fsFile::docRoot {{dir {}}} {
+ variable docRoot
+ if {[string length $dir] == 0} {
+ return $docRoot
+ } else {
+ set docRoot $dir
+ }
+ return ""
+}
+
+# ::ftpd::fsFile::fs --
+#
+# Handles the a standard file systems file system requests and is the
+# default fsCmd callback.
+#
+# Arguments:
+# command - The filesystem command (one of dlist, retr, or
+# store). 'dlist' will list files in a
+# directory, 'retr' will get a channel to
+# to read the specified file from, and 'store'
+# will return the channel to write to.
+# path - The file name or directory to read, write or
+# list.
+# args - Additional arguments for filesystem commands.
+# Currently this is used by 'dlist' which
+# has two additional arguments 'style' and
+# 'channel-to-write-dir-list-to'. It is also
+# used by 'size' and 'mtime' which have one
+# additional argument 'channel-to-write-to'.
+#
+# Results:
+# For a 'appe', 'retr', or 'stor' a channel is returned. For 'exists' a 1
+# is returned if the path exists, and is not a directory. Otherwise a
+# 0 is returned. For 'permissions' the octal file permissions (i.e.
+# the 'file stat' mode) are returned.
+#
+# Side Effects:
+# For 'dlist' a directory listing for the specified path is written to
+# the specified channel. For 'mtime' the modification time is written
+# or an error is thrown. An error is thrown if there is no fsCmd
+# callback configured for the ftpd.
+
+proc ::ftpd::fsFile::fs {command path args} {
+ # append <path>
+ # delete <path> <channel-to-write-to>
+ # dlist <path> <style> <channel-to-write-dir-list-to>
+ # exists <path>
+ # mkdir <path> <channel-to-write-to>
+ # mtime <path> <channel-to-write-mtime-to>
+ # permissions <path>
+ # rename <path> <newpath> <channel-to-write-to>
+ # retr <path>
+ # rmdir <path> <channel-to-write-to>
+ # size <path> <channel-to-write-size-to>
+ # store <path>
+
+ global tcl_platform
+
+ variable docRoot
+
+ set path [file join $docRoot $path]
+
+ switch -exact -- $command {
+ append {
+ #
+ # Patched Mark O'Connor
+ #
+ set fhandle [open $path a]
+ if {[lindex $args 0] == "binary"} {
+ fconfigure $fhandle -translation binary -encoding binary
+ }
+ return $fhandle
+ }
+ retr {
+ #
+ # Patched Mark O'Connor
+ #
+ set fhandle [open $path r]
+ if {[lindex $args 0] == "binary"} {
+ fconfigure $fhandle -translation binary -encoding binary
+ }
+ return $fhandle
+ }
+ store {
+ #
+ # Patched Mark O'Connor
+ #
+ set fhandle [open $path w]
+ if {[lindex $args 0] == "binary"} {
+ fconfigure $fhandle -translation binary -encoding binary
+ }
+ return $fhandle
+ }
+ dlist {
+ foreach {style outchan} $args break
+ ::ftpd::Log debug "at dlist {$style} {$outchan} {$path}"
+ #set path [glob -nocomplain $path]
+ #::ftpd::Log debug "at dlist2 {$style} {$outchan} {$path}"
+
+ # Attempt to get a list of all files (even ones that start with .)
+
+ if {[file isdirectory $path]} {
+ set path1 [file join $path *]
+ set path2 [file join $path .*]
+ } else {
+ set path1 $path
+ set path2 $path
+ }
+
+ # Get a list of all files that match the glob pattern
+
+ set fileList [lsort -unique [concat [glob -nocomplain $path1] \
+ [glob -nocomplain $path2]]]
+
+ ::ftpd::Log debug "File list is {$fileList}"
+
+ switch -- $style {
+ nlst {
+ ::ftpd::Log debug "In nlist"
+ foreach f [lsort $fileList] {
+ if {[string equal [file tail $f] "."] || \
+ [string equal [file tail $f] ".."]} {
+ continue
+ }
+ if {[string equal {} $f]} then continue
+ ::ftpd::Log debug [file tail $f]
+ puts $outchan [file tail $f]
+ }
+ }
+ list {
+ # [ 766112 ] report . and .. directories (linux)
+ # Copied the code from 'nlst' above to handle this.
+
+ foreach f [lsort $fileList] {
+ if {[string equal [file tail $f] "."] || \
+ [string equal [file tail $f] ".."]} {
+ continue
+ }
+ file stat $f stat
+ if {[string equal $tcl_platform(platform) "unix"]} {
+ set user [file attributes $f -owner]
+ set group [file attributes $f -group]
+ } else {
+ set user owner
+ set group group
+ }
+ puts $outchan [format "%s %3d %s %8s %11s %s %s" \
+ [PermBits $f $stat(mode)] $stat(nlink) \
+ $user $group $stat(size) \
+ [FormDate $stat(mtime)] [file tail $f]]
+ }
+ }
+ default {
+ error "Unknown list style <$style>"
+ }
+ }
+ }
+ delete {
+ foreach {outchan} $args break
+
+ if {![file exists $path]} {
+ puts $outchan "550 $path: No such file or directory."
+ } elseif {![file isfile $path]} {
+ puts $outchan "550 $path: File exists."
+ } else {
+ file delete $path
+ puts $outchan "250 DELE command successful."
+ }
+ }
+ exists {
+ if {[file isdirectory $path]} {
+ return 0
+ } else {
+ return [file exists $path]
+ }
+ }
+ mkdir {
+ foreach {outchan} $args break
+
+ set path [string trimright $path /]
+ if {[file exists $path]} {
+ if {[file isdirectory $path]} {
+ puts $outchan "521 \"$path\" directory exists"
+ } else {
+ puts $outchan "521 \"$path\" already exists"
+ }
+ } elseif {[file exists [file dirname $path]]} {
+ file mkdir $path
+ puts $outchan "257 \"$path\" new directory created."
+ } else {
+ puts $outchan "550 $path: No such file or directory."
+ }
+ }
+ mtime {
+ foreach {outchan} $args break
+
+ if {![file exists $path]} {
+ puts $outchan "550 $path: No such file or directory"
+ } elseif {![file isfile $path]} {
+ puts $outchan "550 $path: not a plain file."
+ } else {
+ set time [file mtime $path]
+ puts $outchan [clock format $time -format "213 %Y%m%d%H%M%S"]
+ }
+ }
+ permissions {
+ file stat $path stat
+ return $stat(mode)
+ }
+ rename {
+ foreach {newname outchan} $args break
+
+ if {![file isdirectory [file dirname $newname]]} {
+ puts $outchan "550 rename: No such file or directory."
+ }
+ file rename $path $newname
+ puts $outchan "250 RNTO command successful."
+ }
+ rmdir {
+ foreach {outchan} $args break
+
+ if {![file isdirectory $path]} {
+ puts $outchan "550 $path: Not a directory."
+ } elseif {[llength [glob -nocomplain [file join $path *]]] != 0} {
+ puts $outchan "550 $path: Directory not empty."
+ } else {
+ file delete $path
+ puts $outchan "250 RMD command successful."
+ }
+ }
+ size {
+ foreach {outchan} $args break
+
+ if {![file exists $path]} {
+ puts $outchan "550 $path: No such file or directory"
+ } elseif {![file isfile $path]} {
+ puts $outchan "550 $path: not a plain file."
+ } else {
+ puts $outchan "213 [file size $path]"
+ }
+ }
+ default {
+ error "Unknown command \"$command\""
+ }
+ }
+ return ""
+}
+
+# ::ftpd::fsFile::PermBits --
+#
+# Returns the file permissions for the specified file.
+#
+# Arguments:
+# file - The file to return the permissions of.
+#
+# Results:
+# The permissions for the specified file are returned.
+#
+# Side Effects:
+# None.
+
+proc ::ftpd::fsFile::PermBits {file mode} {
+
+ array set s {
+ 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx
+ }
+
+ set type [file type $file]
+ if {[string equal $type "file"]} {
+ set permissions "-"
+ } else {
+ set permissions [string index $type 0]
+ }
+ foreach j [split [format %03o [expr {$mode&0777}]] {}] {
+ append permissions $s($j)
+ }
+
+ return $permissions
+}
+
+# ::ftpd::fsFile::FormDate --
+#
+# Returns the file permissions for the specified file.
+#
+# Arguments:
+# seconds - The number of seconds returned by 'file mtime'.
+#
+# Results:
+# A formatted date is returned.
+#
+# Side Effects:
+# None.
+
+proc ::ftpd::fsFile::FormDate {seconds} {
+
+ set currentTime [clock seconds]
+ set oldTime [clock scan "6 months ago" -base $currentTime]
+ if {$seconds <= $oldTime} {
+ set time [clock format $seconds -format "%Y"]
+ } else {
+ set time [clock format $seconds -format "%H:%M"]
+ }
+ set day [string trimleft [clock format $seconds -format "%d"] 0]
+ set month [clock format $seconds -format "%b"]
+ return [format "%3s %2s %5s" $month $day $time]
+}
+
+# Only provide the package if it has been successfully
+# sourced into the interpreter.
+
+#
+# Patched Mark O'Connor
+#
+package provide ftpd 1.3
+
+
+##
+## Implementation of passive command
+##
+proc ::ftpd::command::PASV {sock argument} {
+ upvar #0 ::ftpd::$sock data
+
+ set data(sock2a) [socket -server [list ::ftpd::PasvAccept $sock] 0]
+ set list1 [fconfigure $sock -sockname]
+ set ip [lindex $list1 0]
+ set list2 [fconfigure $data(sock2a) -sockname]
+ set port [lindex $list2 2]
+ ::ftpd::Log debug "PASV on {$list1} {$list2} $ip $port"
+ set ans [split $ip {.}]
+ lappend ans [expr {($port >> 8) & 0xff}] [expr {$port & 0xff}]
+ set ans [join $ans {,}]
+ puts $sock "227 Entering Passive Mode ($ans)."
+ set data(sock2) ""
+ return
+}
+
+
+proc ::ftpd::PasvAccept {sock sock2 ip port} {
+ upvar #0 ::ftpd::$sock data
+
+ ::ftpd::Log debug "In Pasv Accept with {$sock} {$sock2} {$ip} {$port}"
+ ##
+ ## Verify this is from who it should be
+ ##
+ if {![string equal $ip $data(ip)]} then {
+ ##
+ ## Nope, so close it and wait some more
+ ##
+ close $sock2
+ return
+ }
+ ::ftpd::FinishData $sock
+
+ set data(sock2) $sock2 ; # (*), see ::ftpd::PasvCheckAndWait
+ fconfigure $data(sock2) -translation $data(mode)
+ close $data(sock2a)
+ set data(sock2a) ""
+ return
+}
+
+proc ::ftpd::PasvCheckAndWait {sock} {
+ upvar #0 ::ftpd::$sock data
+
+ # Check if we are in passive mode, with the data connection not
+ # yet established. If so, wait for the data connection to be
+ # made. This vwait is unlocked by (*) in ::ftpd::PasvAccept above.
+
+ if {$data(sock2) != ""} return
+ vwait ::ftpd::${sock}(sock2)
+ return
+}
diff --git a/tcllib/modules/ftpd/pkgIndex.tcl b/tcllib/modules/ftpd/pkgIndex.tcl
new file mode 100644
index 0000000..68aa204
--- /dev/null
+++ b/tcllib/modules/ftpd/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.3]} {return}
+package ifneeded ftpd 1.3 [list source [file join $dir ftpd.tcl]]
diff --git a/tcllib/modules/fumagic/ChangeLog b/tcllib/modules/fumagic/ChangeLog
new file mode 100644
index 0000000..64aecb9
--- /dev/null
+++ b/tcllib/modules/fumagic/ChangeLog
@@ -0,0 +1,235 @@
+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-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 ========================
+ *
+
+2008-06-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * fileutil_magic_cfront.pcx: New file. Syntax definitions for the
+ * fileutil_magic_cgen.pcx: public commands of the fileutil::magic
+ * fileutil_magic_filetype.pcx: packages.
+ * fileutil_magic_mimetype.pcx:
+ * fileutil_magic_rt.pcx:
+
+2008-03-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cfront.man: Fixed typo in the new documentation.
+
+2008-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * rtcore.man: Added documentation for the runtime package
+ * cgen.man: 'fileutil::magic::rt', and the two compiler packages
+ * cfront.man: 'fileutil::magic::cgen' and 'fileutil::magic::cfront'.
+
+ * cfront.tcl: Fixed a typo in the export clause.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-09-12 Andreas Kupries <andreask@activestate.com>
+
+ * filetypes.man: Fixed typos in the documentation, incomplete
+ * mimetypes.man: command names. Fixes [SF Bug 1791379].
+
+2007-06-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cfront.tcl: Replaced deprecated {expand} syntax in comments with
+ * cgen.tcl: {*}.
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mimetypes.man: Fixed all warnings due to use of now deprecated
+ * filetypes.man: 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-09-27 Andreas Kupries <andreask@activestate.com>
+
+ * filetypes.tcl: [SF Tcllib Bug 1329207]. Extended commands with
+ * mimetypes.tcl: hardwired check for directory as that cannot be
+ * filetypes.man: done by the generated code. Bumped version to
+ * mimetypes.man: 1.0.2.
+ * filetypes.test:
+ * mimetypes.test:
+ * pkgIndex.tcl:
+
+2006-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * mimetypes.man: Bumped versions to 1.0.1
+ * mimetypes.tcl:
+ * filetypes.man:
+ * filetypes.tcl:
+ * pkgIndex.tcl:
+
+2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * filetypes.test: Fixed usage of temp. files by the testsuites.
+ * mimetypes.test:
+
+ * fumagic.testsupport: New file, common definitions for the testsuite.
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * filestypes.test: More boilerplate simplified via use of test support.
+ * mimetypes.test:
+
+ * filetypes.tcl: Added proper set up of the package namespace,
+ * mimetypes.tcl: paranoid code, 'rtcore' should have done it already.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * filetypes.test: Hooked into the new common test support code.
+ * mimetypes.test:
+
+2005-12-09 Andreas Kupries <andreask@activestate.com>
+
+ * mimetypes.man: Corrected package names used in the
+ * filetypes.man: manpage headings.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-09-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * filetypes.test (fumagic.filetype-1.2): Modified test result to
+ * mimetypes.test (fumagic.mimetype-1.2): make it independent of
+ the exact channel handle listed in the error message. Has
+ changed with Tcl 8.5.
+
+2005-03-16 Andreas Kupries <andreask@activestate.com>
+
+ * Fixed typos in the manpage headers.
+
+2005-02-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tmc: Added basic magic compiler, and script to
+ * regenerate.sh: regenerate the recognizers.
+
+ * filetypes.tcl: Added general recognizer for file types,
+ * filetypes.man: tests, and documentation for it.
+ * filetypes.test: WARNING. This recognizer is LARGE.
+
+2005-02-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * rtcore.tcl: Added the Nvx, Nx, and Sx commands to handle the
+ generation of location data for use by the R command for the
+ handling of relative addressing.
+
+ * cgen.tcl:
+ * rtcore.tcl: Rewritten the intialization of the typemap, fixing
+ bugs in the definition of the types using native byteorder
+ instead of explicitly specified big/little endian.
+
+ * mimetypes,man: Added REFERENCES section, and olisted url where
+ Colin found the sources of file(1) and of the magic files used.
+
+2005-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * rtcore.tcl: Added commands I, R, and L to support indirect and
+ relative adressing.
+
+ * cgen.tcl: Rewrote the whole offset handling in the generator, to
+ support all types of offsets, i.e relative, indirect and
+ indirect relative ones. A new stage now parses all offsets into
+ standard components. The treegen stage then assembles proper
+ base handling using new rtcore commands (I, R). Also now saving
+ indicators about which branches actually need saving of field
+ locations for relative adressing, this is used to optimize usage
+ of check commands with saving (Nx, Sx, Nvx), and when to
+ regenerate the level information (L). The latter is an implicit
+ variable in the generated recognizer procedure, accessed via
+ 'upvar 1' from the runtime commands.
+
+2005-02-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cfront.tcl: More fixes and 8.5 feature removal for the
+ * cgen.tcl: compiler packages.
+
+2005-02-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * cgen.tcl: Removed usage of catch 8.5 feature.
+ * cfront.tcl: Fixed bad reference to file/scope local
+ command. Repaced usage 0f 8.5 feature 'lrepeat' with forward
+ compatibility command provided by 'struct::list'.
+
+ * cgen.tcl: Moved the 'provide' definition to the front, so that
+ * cfront.tcl: sak recognizes it and registers the provision of a
+ * mimetypes.tcl: package when validating the module.
+
+ * mimetypes.man: Basic documentation for the main recognizer
+ command.
+
+ * mimetypes.test: Copied the filetype tests from fileutil over for
+ use by the mimetype command, and adapted the results. Only four
+ places where the result can be said to be bogus
+ * mimetypes.tcl: Added code to remove duplicates from the output
+ of the low-level recognizer.
+ * rtcore.tcl: Added 'resultv' command which does not stop
+ processing in the caller as well. Needed by our wrapper.
+
+ * mimetypes.tcl: Moved code in 'magic.tcl' to
+ * magic.tcl: 'mimetypes.tcl'. There is no need for a highlevel
+ package loading all the different recognizers. Each recognizer
+ is fully in its own package now. That makes the addition of more
+ recognizers easier, without causing the wrapper to load more and
+ more unneeded code. Things are large as they are, no need to
+ make them larger. Deleted "magic.tcl".
+
+2005-02-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module 'fumagic'. file(1) magic(5) based file type
+ recognition, in pure Tcl. Basic packages: runtime core,
+ mime-type engine, and a command wrapping the functionality for
+ easy access. The mime-type engine is not exactly so, it is
+ possible for to produce non-mime strings. We keep it for now
+ until the compiler has been put into this module as well.
+
+ * rtcore.tcl: Runtime core.
+ * magic-mime.tcl: Mime engine
+ * magic.tcl: Wrapper.
+
+ * Compiler packages now present as well
+
+ * cgen.tcl: Backend, tree-based code generator
+ * cfront.tcl: Frontend, parsing of magic(5) files.
diff --git a/tcllib/modules/fumagic/cfront.man b/tcllib/modules/fumagic/cfront.man
new file mode 100644
index 0000000..6715f38
--- /dev/null
+++ b/tcllib/modules/fumagic/cfront.man
@@ -0,0 +1,71 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin fileutil::magic::cfront n 1.0]
+[see_also file(1)]
+[see_also fileutil]
+[see_also magic(5)]
+[keywords {file recognition}]
+[keywords {file type}]
+[keywords {file utilities}]
+[keywords mime]
+[keywords type]
+[moddesc {file utilities}]
+[titledesc {Generator core for compiler of magic(5) files}]
+[category {Programming tools}]
+[require Tcl 8.4]
+[require fileutil::magic::cfront [opt 1.0]]
+[require fileutil::magic::cgen [opt 1.0]]
+[require fileutil::magic::rt [opt 1.0]]
+[require struct::list]
+[require fileutil]
+[description]
+[para]
+
+This package provides the frontend of a compiler of magic(5) files
+into recognizers based on the [package fileutil::magic::rt] recognizer
+runtime package. For the generator backed used by this compiler see
+the package [package fileutil::magic::cgen].
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::fileutil::magic::cfront::compile] [arg path]...]
+
+This command takes the paths of one or more files and directories and
+compiles all the files, and the files in all the directories into a
+single recognizer for all the file types specified in these files.
+
+[para]
+
+All the files have to be in the format specified by magic(5).
+
+[para]
+
+The result of the command is a Tcl script containing the generated
+recognizer.
+
+[call [cmd ::fileutil::magic::cfront::procdef] [arg procname] [arg path]...]
+
+This command behaves like [cmd ::fileutil::magic::cfront::compile]
+with regard to the specified path arguments, then wraps the resulting
+recognizer script into a procedure named [arg procname], puts code
+setting up the namespace of [arg procname] in front, and returns the
+resulting script.
+
+[call [cmd ::fileutil::magic::cfront::install] [arg path]...]
+
+This command uses [cmd ::fileutil::magic::cfront::procdef] to compile
+each of the paths into a recognizer procedure and installs the result
+in the current interpreter.
+
+[para]
+
+The name of each new procedure is derived from the name of the
+file/directory used in its creation, with file/directory [file FOO]
+causing the creation of procedure [const ::fileutil::magic::/FOO::run].
+
+[list_end]
+
+[vset CATEGORY {fileutil :: magic}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/fumagic/cfront.tcl b/tcllib/modules/fumagic/cfront.tcl
new file mode 100644
index 0000000..7d991b4
--- /dev/null
+++ b/tcllib/modules/fumagic/cfront.tcl
@@ -0,0 +1,396 @@
+# cfront.tcl --
+#
+# Generator frontend for compiler of magic(5) files into recognizers
+# based on the 'rtcore'. Parses magic(5) into a basic 'script'.
+#
+# Copyright (c) 2004-2005 Colin McCormack <coldstore@users.sourceforge.net>
+# Copyright (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: cfront.tcl,v 1.7 2008/03/22 01:10:32 andreas_kupries Exp $
+
+#####
+#
+# "mime type recognition in pure tcl"
+# http://wiki.tcl.tk/12526
+#
+# Tcl code harvested on: 10 Feb 2005, 04:06 GMT
+# Wiki page last updated: ???
+#
+#####
+
+# ### ### ### ######### ######### #########
+## Requirements
+
+package require Tcl 8.4
+
+# file to compile the magic file from magic(5) into a tcl program
+package require fileutil ; # File processing (input)
+package require fileutil::magic::cgen ; # Code generator.
+package require fileutil::magic::rt ; # Runtime (typemap)
+package require struct::list ; # lrepeat.
+
+package provide fileutil::magic::cfront 1.0
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+namespace eval ::fileutil::magic::cfront {
+ # Configuration flag. (De)activate debugging output.
+ # This is done during initialization.
+ # Changes at runtime have no effect.
+
+ variable debug 0
+
+ # Constants
+
+ variable hashprotection [list "\#" "\\#" \" \\\" \{ \\\{ \} \\\}] ;#"
+ variable hashprotectionB [list "\#" "\\\#" \" \\\" \} \\\} ( \\( ) \\)] ;#"
+
+ # Make backend functionality accessible
+ namespace import ::fileutil::magic::cgen::*
+
+ namespace export compile procdef install
+}
+
+# parse an individual line
+proc ::fileutil::magic::cfront::parseline {line {maxlevel 10000}} {
+ # calculate the line's level
+ set unlevel [string trimleft $line >]
+ set level [expr {[string length $line] - [string length $unlevel]}]
+ if {$level > $maxlevel} {
+ return -code continue "Skip - too high a level"
+ }
+
+ # regexp parse line into (offset, type, value, command)
+ set parse [regexp -expanded -inline {^(\S+)\s+(\S+)\s*((\S|(\B\s))*)\s*(.*)$} $unlevel]
+ if {$parse == {}} {
+ error "Can't parse: '$unlevel'"
+ }
+
+ # unpack parsed line
+ set value ""
+ set command ""
+ foreach {junk offset type value junk1 junk2 command} $parse break
+
+ # handle trailing spaces
+ if {[string index $value end] eq "\\"} {
+ append value " "
+ }
+ if {[string index $command end] eq "\\"} {
+ append command " "
+ }
+
+ if {$value eq ""} {
+ # badly formatted line
+ return -code error "no value"
+ }
+
+ ::fileutil::magic::cfront::Debug {
+ puts "level:$level offset:$offset type:$type value:'$value' command:'$command'"
+ }
+
+ # return the line's fields
+ return [list $level $offset $type $value $command]
+}
+
+# process a magic file
+proc ::fileutil::magic::cfront::process {file {maxlevel 10000}} {
+ variable hashprotection
+ variable hashprotectionB
+ variable level ;# level of line
+ variable linenum ;# line number
+
+ set level 0
+ set script {}
+
+ set linenum 0
+ ::fileutil::foreachLine line $file {
+ incr linenum
+ set line [string trim $line " "]
+ if {[string index $line 0] eq "#"} {
+ continue ;# skip comments
+ } elseif {$line == ""} {
+ continue ;# skip blank lines
+ } else {
+ # parse line
+ if {[catch {parseline $line $maxlevel} parsed]} {
+ continue ;# skip erroring lines
+ }
+
+ # got a valid line
+ foreach {level offset type value message} $parsed break
+
+ # strip comparator out of value field,
+ # (they are combined)
+ set compare [string index $value 0]
+ switch -glob -- $value {
+ [<>]=* {
+ set compare [string range $value 0 1]
+ set value [string range $value 2 end]
+ }
+
+ <* - >* - &* - ^* {
+ set value [string range $value 1 end]
+ }
+
+ =* {
+ set compare "=="
+ set value [string range $value 1 end]
+ }
+
+ !* {
+ set compare "!="
+ set value [string range $value 1 end]
+ }
+
+ x {
+ # this is the 'don't care' match
+ # used for collecting values
+ set value ""
+ }
+
+ default {
+ # the default comparator is equals
+ set compare "=="
+ if {[string match {\\[<!>=]*} $value]} {
+ set value [string range $value 1 end]
+ }
+ }
+ }
+
+ # process type field
+ set qual ""
+ switch -glob -- $type {
+ pstring* - string* {
+ # String or Pascal string type
+
+ # extract string match qualifiers
+ foreach {type qual} [split $type /] break
+
+ # convert pstring to string + qualifier
+ if {$type eq "pstring"} {
+ append qual "p"
+ set type "string"
+ }
+
+ # protect hashes in output script value
+ set value [string map $hashprotection $value]
+
+ if {($value eq "\\0") && ($compare eq ">")} {
+ # record 'any string' match
+ set value ""
+ set compare x
+ } elseif {$compare eq "!="} {
+ # string doesn't allow !match
+ set value !$value
+ set compare "=="
+ }
+
+ if {$type ne "string"} {
+ # don't let any odd string types sneak in
+ puts stderr "Reject String: ${file}:$linenum $type - $line"
+ continue
+ }
+ }
+
+ regex {
+ # I am *not* going to handle regex
+ puts stderr "Reject Regex: ${file}:$linenum $type - $line"
+ continue
+ }
+
+ *byte* - *short* - *long* - *date* {
+ # Numeric types
+
+ # extract numeric match &qualifiers
+ set type [split $type &]
+ set qual [lindex $type 1]
+
+ if {$qual ne ""} {
+ # this is an &-qualifier
+ set qual &$qual
+ } else {
+ # extract -qualifier from type
+ set type [split $type -]
+ set qual [lindex $type 1]
+ if {$qual ne ""} {
+ set qual -$qual
+ }
+ }
+ set type [lindex $type 0]
+
+ # perform value adjustments
+ if {$compare ne "x"} {
+ # trim redundant Long value qualifier
+ set value [string trimright $value L]
+
+ if {[catch {set value [expr $value]} x]} {
+ upvar #0 errorInfo eo
+ # check that value is representable in tcl
+ puts stderr "Reject Value Error: ${file}:$linenum '$value' '$line' - $eo"
+ continue;
+ }
+
+ # coerce numeric value into hex
+ set value [format "0x%x" $value]
+ }
+ }
+
+ default {
+ # this is not a type we can handle
+ puts stderr "Reject Unknown Type: ${file}:$linenum $type - $line"
+ continue
+ }
+ }
+ }
+
+ # collect some summaries
+ ::fileutil::magic::cfront::Debug {
+ variable types
+ set types($type) $type
+ variable quals
+ set quals($qual) $qual
+ }
+
+ #puts $linenum level:$level offset:$offset type:$type
+ #puts qual:$qual compare:$compare value:'$value' message:'$message'
+
+ # protect hashes in output script message
+ set message [string map $hashprotectionB $message]
+
+ if {![string match "(*)" $offset]} {
+ catch {set offset [expr $offset]}
+ }
+
+ # record is the complete match command,
+ # encoded for tcl code generation
+ set record [list $linenum $type $qual $compare $offset $value $message]
+ if {$script == {}} {
+ # the original script has level 0,
+ # regardless of what the script says
+ set level 0
+ }
+
+ if {$level == 0} {
+ # add a new 0-level record
+ lappend script $record
+ } else {
+ # find the growing edge of the script
+ set depth [::struct::list repeat [expr $level] end]
+ while {[catch {
+ # get the insertion point
+ set insertion [eval [linsert $depth 0 lindex $script]]
+ # 8.5 # set insertion [lindex $script {*}$depth]
+ }]} {
+ # handle scripts which jump levels,
+ # reduce depth to current-depth+1
+ set depth [lreplace $depth end end]
+ }
+
+ # add the record at the insertion point
+ lappend insertion $record
+
+ # re-insert the record into its correct position
+ eval [linsert [linsert $depth 0 lset script] end $insertion]
+ # 8.5 # lset script {*}$depth $insertion
+ }
+ }
+ #puts "Script: $script"
+ return $script
+}
+
+# compile up magic files or directories of magic files into a single recognizer.
+proc ::fileutil::magic::cfront::compile {args} {
+ set tcl ""
+ set script {}
+ foreach arg $args {
+ if {[file type $arg] == "directory"} {
+ foreach file [glob [file join $arg *]] {
+ set script1 [process $file]
+ eval [linsert $script1 0 lappend script [list file $file]]
+ # 8.5 # lappend script [list file $file] {*}$script1
+
+ #append tcl "magic::file_start $file" \n
+ #append tcl [run $script1] \n
+ }
+ } else {
+ set file $arg
+ set script1 [process $file]
+ eval [linsert $script1 0 lappend script [list file $file]]
+ # 8.5 # lappend script [list file $file] {*}$script1
+
+ #append tcl "magic::file_start $file" \n
+ #append tcl [run $script1] \n
+ }
+ }
+
+ #puts stderr $script
+ ::fileutil::magic::cfront::Debug {puts "\# $args"}
+
+ set t [2tree $script]
+ set tcl [treegen $t root]
+ append tcl "\nreturn \{\}"
+
+ ::fileutil::magic::cfront::Debug {puts [treedump $t]}
+ #set tcl [run $script]
+
+ return $tcl
+}
+
+proc ::fileutil::magic::cfront::procdef {procname args} {
+
+ set pspace [namespace qualifiers $procname]
+
+ if {$pspace eq ""} {
+ return -code error "Cannot generate recognizer in the global namespace"
+ }
+
+ set script {}
+ lappend script "package require fileutil::magic::rt"
+ lappend script "namespace eval [list ${pspace}] \{"
+ lappend script " namespace import ::fileutil::magic::rt::*"
+ lappend script "\}"
+ lappend script ""
+ lappend script [list proc ${procname} {} \n[eval [linsert $args 0 compile]]\n]
+ return [join $script \n]
+}
+
+proc ::fileutil::magic::cfront::install {args} {
+ foreach arg $args {
+ set path [file tail $arg]
+ eval [procdef ::fileutil::magic::/${path}::run $arg]
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal, debugging.
+
+if {!$::fileutil::magic::cfront::debug} {
+ # This procedure definition is optimized out of using code by the
+ # core bcc. It knows that neither argument checks are required,
+ # nor is anything done. So neither results, nor errors are
+ # possible, a true no-operation.
+ proc ::fileutil::magic::cfront::Debug {args} {}
+
+} else {
+ proc ::fileutil::magic::cfront::Debug {script} {
+ # Run the commands in the debug script. This usually generates
+ # some output. The uplevel is required to ensure the proper
+ # resolution of all variables found in the script.
+ uplevel 1 $script
+ return
+ }
+}
+
+#set script [magic::compile {} /usr/share/misc/file/magic]
+#puts "\# types:[array names magic::types]"
+#puts "\# quals:[array names magic::quals]"
+#puts "Script: $script"
+
+# ### ### ### ######### ######### #########
+## Ready for use.
+# EOF
diff --git a/tcllib/modules/fumagic/cgen.man b/tcllib/modules/fumagic/cgen.man
new file mode 100644
index 0000000..bca630d
--- /dev/null
+++ b/tcllib/modules/fumagic/cgen.man
@@ -0,0 +1,63 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin fileutil::magic::cgen n 1.0]
+[see_also file(1)]
+[see_also fileutil]
+[see_also magic(5)]
+[keywords {file recognition}]
+[keywords {file type}]
+[keywords {file utilities}]
+[keywords mime]
+[keywords type]
+[moddesc {file utilities}]
+[titledesc {Generator core for compiler of magic(5) files}]
+[category {Programming tools}]
+[require Tcl 8.4]
+[require fileutil::magic::cgen [opt 1.0]]
+[require fileutil::magic::rt [opt 1.0]]
+
+[require struct::tree]
+[require struct::list]
+[description]
+[para]
+
+This package provides the generator backend for a compiler of magic(5)
+files into recognizers based on the [package fileutil::magic::rt]
+recognizer runtime package. For the compiler frontend using this
+generator see the package [package fileutil::magic::cfront].
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::fileutil::magic::cgen::2tree] [arg script]]
+
+This command converts the recognizer specified by the [arg script]
+into a tree and returns the object command of that tree as its
+result. It uses the package [package struct::tree] for the tree.
+
+[para]
+
+The [arg script] is in the format specified by magic(5).
+
+[call [cmd ::fileutil::magic::cgen::treedump] [arg tree]]
+
+This command takes a [arg tree] as generated by
+[cmd ::fileutil::magic::cgen::2tree] and returns a string encoding the
+tree for human consumption, to aid in debugging.
+
+[call [cmd ::fileutil::magic::cgen::treegen] [arg tree] [arg node]]
+
+This command takes a [arg tree] as generated by
+[cmd ::fileutil::magic::cgen::2tree] and returns a Tcl script, the
+recognizer for the file types represented by the sub-tree rooted at
+the [arg node].
+
+The generated script makes extensive use of the commands provided by
+the recognizer runtime package [package fileutil::magic::rt] to
+perform its duties.
+
+[list_end]
+
+[vset CATEGORY {fileutil :: magic}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/fumagic/cgen.tcl b/tcllib/modules/fumagic/cgen.tcl
new file mode 100644
index 0000000..f8048f2
--- /dev/null
+++ b/tcllib/modules/fumagic/cgen.tcl
@@ -0,0 +1,671 @@
+# cgen.tcl --
+#
+# Generator core for compiler of magic(5) files into recognizers
+# based on the 'rtcore'.
+#
+# Copyright (c) 2004-2005 Colin McCormack <coldstore@users.sourceforge.net>
+# Copyright (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: cgen.tcl,v 1.7 2007/06/23 03:39:34 andreas_kupries Exp $
+
+#####
+#
+# "mime type recognition in pure tcl"
+# http://wiki.tcl.tk/12526
+#
+# Tcl code harvested on: 10 Feb 2005, 04:06 GMT
+# Wiki page last updated: ???
+#
+#####
+
+# ### ### ### ######### ######### #########
+## Requirements
+
+package require Tcl 8.4
+package require fileutil::magic::rt ; # Runtime core, for Access to the typemap
+package require struct::list ; # Our data structures.
+package require struct::tree ; #
+
+package provide fileutil::magic::cgen 1.0
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+namespace eval ::fileutil::magic::cgen {
+ # Import the runtime typemap into our scope.
+ variable ::fileutil::magic::rt::typemap
+
+ # The tree most operations use for their work.
+ variable tree {}
+
+ # Generator data structure.
+ variable regions
+
+ # Type mapping for indirect offsets.
+ # empty -> long/Q, because this uses native byteorder.
+
+ array set otmap {
+ .b c .B c
+ .s s .S S
+ .l i .L I
+ {} Q
+ }
+
+ # Export the API
+ namespace export 2tree treedump treegen
+}
+
+
+# Optimisations:
+
+# reorder tests according to expected or observed frequency this
+# conflicts with reduction in strength optimisations.
+
+# Rewriting within a level will require pulling apart the list of
+# tests at that level and reordering them. There is an inconsistency
+# between handling at 0-level and deeper level - this has to be
+# removed or justified.
+
+# Hypothetically, every test at the same level should be mutually
+# exclusive, but this is not given, and should be detected. If true,
+# this allows reduction in strength to switch on Numeric tests
+
+# reduce Numeric tests at the same level to switches
+#
+# - first pass through clauses at same level to categorise as
+# variant values over same test (type and offset).
+
+# work out some way to cache String comparisons
+
+# Reduce seek/reads for String comparisons at same level:
+#
+# - first pass through clauses at same level to determine string ranges.
+#
+# - String tests at same level over overlapping ranges can be
+# written as sub-string comparisons over the maximum range
+# this saves re-reading the same string from file.
+#
+# - common prefix strings will have to be guarded against, by
+# sorting string values, then sorting the tests in reverse length order.
+
+
+proc ::fileutil::magic::cgen::path {tree} {
+ # Annotates the tree. In each node we store the path from the root
+ # to this node, as list of nodes, with the current node the last
+ # element. The root node is never stored in the path.
+
+ $tree set root path {}
+ foreach child [$tree children root] {
+ $tree walk $child -type dfs node {
+ set path [$tree get [$tree parent $node] path]
+ lappend path [$tree index $node]
+ $tree set $node path $path
+ }
+ }
+ return
+}
+
+proc ::fileutil::magic::cgen::tree_el {tree parent file line type qual comp offset val message args} {
+
+ # Recursively creates and annotates a node for the specified
+ # tests, and its sub-tests (args).
+
+ set node [$tree insert $parent end]
+ set path [$tree get $parent path]
+ lappend path [$tree index $node]
+ $tree set $node path $path
+
+ # generate a proc call type for the type, Numeric or String
+ variable ::fileutil::magic::rt::typemap
+
+ switch -glob -- $type {
+ *byte* -
+ *short* -
+ *long* -
+ *date* {
+ set otype N
+ set type [lindex $typemap($type) 1]
+ }
+ *string {
+ set otype S
+ }
+ default {
+ puts stderr "Unknown type: '$type'"
+ }
+ }
+
+ # Stores the type determined above, and the arguments into
+ # attributes of the new node.
+
+ foreach key {line type qual comp offset val message file otype} {
+ if {[catch {
+ $tree set $node $key [set $key]
+ } result]} {
+ upvar ::errorInfo eo
+ puts "Tree: $eo - $file $line $type"
+ }
+ }
+
+ # now add children
+ foreach el $args {
+ eval [linsert $el 0 tree_el $tree $node $file]
+ # 8.5 # tree_el $tree $node $file {*}$el
+ }
+ return $node
+}
+
+proc ::fileutil::magic::cgen::2tree {script} {
+
+ # Converts a recognizer which is in a simple script form into a
+ # tree.
+
+ variable tree
+ set tree [::struct::tree]
+
+ $tree set root path ""
+ $tree set root otype Root
+ $tree set root type root
+ $tree set root message "unknown"
+
+ # generate a test for each match
+ set file "unknown"
+ foreach el $script {
+ #puts "EL: $el"
+ if {[lindex $el 0] eq "file"} {
+ set file [lindex $el 1]
+ } else {
+ set node [eval [linsert $el 0 tree_el $tree root $file]]
+ # 8.5 # set more [tree_el $tree root $file {*}$el]
+ append result $node
+ }
+ }
+ optNum $tree root
+ #optStr $tree root
+ puts stderr "Script contains [llength [$tree children root]] discriminators"
+ path $tree
+
+ # Decoding the offsets, determination if we have to handle
+ # relative offsets, and where. The less, the better.
+ Offsets $tree
+
+ return $tree
+}
+
+proc ::fileutil::magic::cgen::isStr {tree node} {
+ return [expr {"S" eq [$tree get $node otype]}]
+}
+
+proc ::fileutil::magic::cgen::sortRegion {r1 r2} {
+ set cmp 0
+ if {[catch {
+ if {[string match (*) $r1] || [string match (*) $r2]} {
+ set cmp [string compare $r1 $r2]
+ } else {
+ set cmp [expr {[lindex $r1 0] - [lindex $r2 0]}]
+ if {!$cmp} {
+ set cmp 0
+ set cmp [expr {[lindex $r1 1] - [lindex $r2 1]}]
+ }
+ }
+ } result]} {
+ set cmp [string compare $r1 $r2]
+ }
+ return $cmp
+}
+
+proc ::fileutil::magic::cgen::optStr {tree node} {
+ variable regions
+ catch {unset regions}
+ array set regions {}
+
+ optStr1 $tree $node
+
+ puts stderr "Regions [array statistics regions]"
+ foreach region [lsort \
+ -index 0 \
+ -command ::fileutil::magic::cgen::sortRegion \
+ [array name regions]] {
+ puts "$region - $regions($region)"
+ }
+}
+
+proc ::fileutil::magic::cgen::optStr1 {tree node} {
+ variable regions
+
+ # traverse each numeric element of this node's children,
+ # categorising them
+
+ set kids [$tree children $node]
+ foreach child $kids {
+ optStr1 $tree $child
+ }
+
+ set strings [$tree children $node filter ::fileutil::magic::cgen::isStr]
+ #puts stderr "optstr: $node: $strings"
+
+ foreach el $strings {
+ #if {[$tree get $el otype] eq "String"} {puts "[$tree getall $el] - [string length [$tree get $el val]]"}
+ if {[$tree get $el comp] eq "x"} {
+ continue
+ }
+
+ set offset [$tree get $el offset]
+ set len [string length [$tree get $el val]]
+ lappend regions([list $offset $len]) $el
+ }
+}
+
+proc ::fileutil::magic::cgen::isNum {tree node} {
+ return [expr {"N" eq [$tree get $node otype]}]
+}
+
+proc ::fileutil::magic::cgen::switchNSort {tree n1 n2} {
+ return [expr {[$tree get $n1 val] - [$tree get $n1 val]}]
+}
+
+proc ::fileutil::magic::cgen::optNum {tree node} {
+ array set offsets {}
+
+ # traverse each numeric element of this node's children,
+ # categorising them
+
+ set kids [$tree children $node]
+ foreach child $kids {
+ optNum $tree $child
+ }
+
+ set numerics [$tree children $node filter ::fileutil::magic::cgen::isNum]
+ #puts stderr "optNum: $node: $numerics"
+ if {[llength $numerics] < 2} {
+ return
+ }
+
+ foreach el $numerics {
+ if {[$tree get $el comp] ne "=="} {
+ continue
+ }
+ lappend offsets([$tree get $el type],[$tree get $el offset],[$tree get $el qual]) $el
+ }
+
+ #puts "Offset: stderr [array get offsets]"
+ foreach {match nodes} [array get offsets] {
+ if {[llength $nodes] < 2} {
+ continue
+ }
+
+ catch {unset matcher}
+ foreach n $nodes {
+ set nv [expr [$tree get $n val]]
+ if {[info exists matcher($nv)]} {
+ puts stderr "*====================================="
+ puts stderr "* Node <[$tree getall $n]>"
+ puts stderr "* clashes with <[$tree getall $matcher($nv)]>"
+ puts stderr "*====================================="
+ } else {
+ set matcher($nv) $n
+ }
+ }
+
+ foreach {type offset qual} [split $match ,] break
+ set switch [$tree insert $node [$tree index [lindex $nodes 0]]]
+ $tree set $switch otype Switch
+ $tree set $switch message $match
+ $tree set $switch offset $offset
+ $tree set $switch type $type
+ $tree set $switch qual $qual
+
+ set nodes [lsort -command [list ::fileutil::magic::cgen::switchNSort $tree] $nodes]
+
+ eval [linsert $nodes 0 $tree move $switch end]
+ # 8.5 # $tree move $switch end {*}$nodes
+ set path [$tree get [$tree parent $switch] path]
+ lappend path [$tree index $switch]
+ $tree set $switch path $path
+ }
+}
+
+proc ::fileutil::magic::cgen::Offsets {tree} {
+
+ # Indicator if a node has to save field location information for
+ # relative addressing. The 'kill' attribute is an accumulated
+ # 'save' over the whole subtree. It will be used to determine when
+ # level information was destroyed by subnodes and has to be
+ # regenerated at the current level.
+
+ $tree walk root -type dfs node {
+ $tree set $node save 0
+ $tree set $node kill 0
+ }
+
+ # We walk from the leafs up to the root, synthesizing the data
+ # needed, as we go.
+ $tree walk root -type dfs -order post node {
+ if {$node eq "root"} continue
+ DecodeOffset $tree $node [$tree get $node offset]
+
+ # If the current node's parent is a switch, and the node has
+ # to save, then the switch has to save. Because the current
+ # node is not relevant during code generation anymore, the
+ # switch is.
+
+ if {[$tree get $node save]} {
+ # We save, therefore we kill.
+ $tree set $node kill 1
+ if {[$tree get [$tree parent $node] otype] eq "Switch"} {
+ $tree set [$tree parent $node] save 1
+ }
+ } else {
+ # We don't save i.e. kill, but we may inherit it from
+ # children which kill.
+
+ foreach c [$tree children $node] {
+ if {[$tree get $c kill]} {
+ $tree set $node kill 1
+ break
+ }
+ }
+ }
+ }
+}
+
+proc ::fileutil::magic::cgen::DecodeOffset {tree node offset} {
+ if {[string match "(*)" $offset]} {
+ # Indirection offset. (Decoding is non-trivial, therefore
+ # packed into a proc).
+
+ set ind 1 ; # Indirect location
+ foreach {rel base itype idelta} [DecodeIndirectOffset $offset] break
+
+ } elseif {[string match "&*" $offset]} {
+ # Direct relative offset. (Decoding is trivial)
+
+ set ind 0 ; # Direct location
+ set rel 1 ; # Relative
+ set base [string range $offset 1 end] ; # Base Delta
+ set itype {} ; # No data for indirect
+ set idelta {} ; # s.a.
+
+ } else {
+ set ind 0 ; # Direct location
+ set rel 0 ; # Absolute
+ set base $offset ; # Here!
+ set itype {} ; # No data for indirect
+ set idelta {} ; # s.a.
+ }
+
+ # Store the expanded data back into the tree.
+
+ foreach v {ind rel base itype idelta} {
+ $tree set $node $v [set $v]
+ }
+
+ # For nodes with adressing relative to last field above the latter
+ # has to save this information.
+
+ if {$rel} {
+ $tree set [$tree parent $node] save 1
+ }
+ return
+}
+
+proc ::fileutil::magic::cgen::DecodeIndirectOffset {offset} {
+ variable otmap ; # Offset typemap.
+
+ # Offset parser.
+ # Syntax:
+ # ( ?&? number ?.[bslBSL]? ?[+-]? ?number? )
+
+ set n {(([0-9]+)|(0x[0-9A-Fa-f]+))}
+ set o "\\((&?)(${n})((\\.\[bslBSL])?)(\[+-]?)(${n}?)\\)"
+ # | | ||| || | | |||
+ # 1 2 345 67 8 9 012
+ # ^ ^ ^ ^ ^
+ # rel base type sign index
+ #
+ # 1 2 3 4 5 6 7 8 9 0 1 2
+ set ok [regexp $o $offset -> rel base _ _ _ type _ sign idx _ _ _]
+
+ if {!$ok} {
+ return -code error "Bad offset \"$offset\""
+ }
+
+ # rel is in {"", &}, map to 0|1
+ if {$rel eq ""} {set rel 0} else {set rel 1}
+
+ # base is a number, enforce decimal. Not optional.
+ set base [expr $base]
+
+ # Type is in .b .s .l .B .S .L, and "". Map to a regular magic
+ # type code.
+ set type $otmap($type)
+
+ # sign is in {+,-,""}. Map to -|"" (Becomes sign of index)
+ if {$sign eq "+"} {set sign ""}
+
+ # Index is optional number. Enforce decimal, empty is zero. Add in
+ # the sign as well for a proper signed index.
+
+ if {$idx eq ""} {set idx 0}
+ set idx $sign[expr $idx]
+
+ return [list $rel $base $type $idx]
+}
+
+proc ::fileutil::magic::cgen::treedump {tree} {
+ set result ""
+ $tree walk root -type dfs node {
+ set path [$tree get $node path]
+ set depth [llength $path]
+
+ append result [string repeat " " $depth] [list $path] ": " [$tree get $node type]:
+
+ if {[$tree keyexists $node offset]} {
+ append result " ,O|[$tree get $node offset]|"
+
+ set x {}
+ foreach v {ind rel base itype idelta} {lappend x [$tree get $node $v]}
+ append result "=<[join $x !]>"
+ }
+ if {[$tree keyexists $node qual]} {
+ set q [$tree get $node qual]
+ if {$q ne ""} {
+ append result " ,q/$q/"
+ }
+ }
+
+ if {[$tree keyexists $node comp]} {
+ append result " " C([$tree get $node comp])
+ }
+ if {[$tree keyexists $node val]} {
+ append result " " V([$tree get $node val])
+ }
+
+ if {[$tree keyexists $node otype]} {
+ append result " " [$tree get $node otype]/[$tree get $node save]
+ }
+
+ if {$depth == 1} {
+ set msg [$tree get $node message]
+ set n $node
+ while {($n != {}) && ($msg == "")} {
+ set n [lindex [$tree children $n] 0]
+ if {$n != {}} {
+ set msg [$tree get $n message]
+ }
+ }
+ append result " " ( $msg )
+ if {[$tree keyexists $node file]} {
+ append result " - " [$tree get $node file]
+ }
+ }
+
+ #append result " <" [$tree getall $node] >
+ append result \n
+ }
+ return $result
+}
+
+proc ::fileutil::magic::cgen::treegen {tree node} {
+ return "[treegen1 $tree $node]\nresult\n"
+}
+
+proc ::fileutil::magic::cgen::treegen1 {tree node} {
+ variable ::fileutil::magic::rt::typemap
+
+ set result ""
+ foreach k {otype type offset comp val qual message save path} {
+ if {[$tree keyexists $node $k]} {
+ set $k [$tree get $node $k]
+ }
+ }
+
+ set level [llength $path]
+
+ # Generate code for each node per its type.
+
+ switch $otype {
+ N -
+ S {
+ if {$save} {
+ # We have to save field data for relative adressing under this
+ # leaf.
+ if {$otype eq "N"} {
+ set type [list Nx $level $type]
+ } elseif {$otype eq "S"} {
+ set type [list Sx $level]
+ }
+ } else {
+ # Regular fetching of information.
+ if {$otype eq "N"} {
+ set type [list N $type]
+ } elseif {$otype eq "S"} {
+ set type S
+ }
+ }
+
+ set offset [GenerateOffset $tree $node]
+
+ if {$qual eq ""} {
+ append result "if \{\[$type $offset $comp [list $val]\]\} \{"
+ } else {
+ append result "if \{\[$type $offset $comp [list $val] $qual\]\} \{"
+ }
+
+ if {[$tree isleaf $node]} {
+ if {$message ne ""} {
+ append result "emit [list $message]"
+ } else {
+ append result "emit [$tree get $node path]"
+ }
+ } else {
+ # If we saved data the child branches may destroy
+ # level information. We regenerate it if needed.
+
+ if {$message ne ""} {
+ append result "emit [list $message]\n"
+ }
+
+ set killed 0
+ foreach child [$tree children $node] {
+ if {$save && $killed && [$tree get $child rel]} {
+ # This location already does not regenerate if
+ # the killing subnode was last. We also do not
+ # need to regenerate if the current subnode
+ # does not use relative adressing.
+ append result "L $level;"
+ set killed 0
+ }
+ append result [treegen1 $tree $child]
+ set killed [expr {$killed || [$tree get $child kill]}]
+ }
+ #append result "\nreturn \$result"
+ }
+
+ append result "\}\n"
+ }
+ Root {
+ foreach child [$tree children $node] {
+ append result [treegen1 $tree $child]
+ }
+ }
+ Switch {
+ set offset [GenerateOffset $tree $node]
+
+ if {$save} {
+ set fetch "Nvx $level"
+ } else {
+ set fetch Nv
+ }
+
+ append fetch " " $type " " $offset
+ if {$qual ne ""} {
+ append fetch " " $qual
+ }
+ append result "switch -- \[$fetch\] "
+
+ set scan [lindex $typemap($type) 1]
+
+ set ckilled 0
+ foreach child [$tree children $node] {
+ binary scan [binary format $scan [$tree get $child val]] $scan val
+ append result "$val \{"
+
+ if {$save && $ckilled} {
+ # This location already does not regenerate if
+ # the killing subnode was last. We also do not
+ # need to regenerate if the current subnode
+ # does not use relative adressing.
+ append result "L $level;"
+ set ckilled 0
+ }
+
+ if {[$tree isleaf $child]} {
+ append result "emit [list [$tree get $child message]]"
+ } else {
+ set killed 0
+ append result "emit [list [$tree get $child message]]\n"
+ foreach grandchild [$tree children $child] {
+ if {$save && $killed && [$tree get $grandchild rel]} {
+ # This location already does not regenerate if
+ # the killing subnode was last. We also do not
+ # need to regenerate if the current subnode
+ # does not use relative adressing.
+ append result "L $level;"
+ set killed 0
+ }
+ append result [treegen1 $tree $grandchild]
+ set killed [expr {$killed || [$tree get $grandchild kill]}]
+ }
+ }
+
+ set ckilled [expr {$ckilled || [$tree get $child kill]}]
+ append result "\} "
+ }
+ append result "\n"
+ }
+ }
+ return $result
+}
+
+proc ::fileutil::magic::cgen::GenerateOffset {tree node} {
+ # Examples:
+ # direct absolute: 45 -> 45
+ # direct relative: &45 -> [R 45]
+ # indirect absolute: (45.s+1) -> [I 45 s 1]
+ # indirect relative: (&45.s+1) -> [I [R 45] s 1]
+
+ foreach v {ind rel base itype idelta} {
+ set $v [$tree get $node $v]
+ }
+
+ if {$rel} {set base "\[R $base\]"}
+ if {$ind} {set base "\[I $base $itype $idelta\]"}
+ return $base
+}
+
+# ### ### ### ######### ######### #########
+## Ready for use.
+# EOF
diff --git a/tcllib/modules/fumagic/filetypes.man b/tcllib/modules/fumagic/filetypes.man
new file mode 100644
index 0000000..977d074
--- /dev/null
+++ b/tcllib/modules/fumagic/filetypes.man
@@ -0,0 +1,63 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin fileutil::magic::filetype n 1.0.2]
+[see_also file(1)]
+[see_also fileutil]
+[see_also magic(5)]
+[keywords {file recognition}]
+[keywords {file type}]
+[keywords {file utilities}]
+[keywords type]
+[moddesc {file utilities}]
+[titledesc {Procedures implementing file-type recognition}]
+[category {Programming tools}]
+[require Tcl 8.4]
+[require fileutil::magic::filetype [opt 1.0.2]]
+[description]
+[para]
+
+This package provides a command for the recognition of file types in
+pure Tcl.
+
+[para]
+
+The core part of the recognizer was generated from a "magic(5)" file
+containing the checks to perform to recognize files, and associated
+file-types.
+
+[para]
+
+[emph Beware!] This recognizer is large, about 276 Kilobyte of
+generated Tcl code.
+
+[list_begin definitions]
+
+[call [cmd ::fileutil::magic::filetype] [arg filename]]
+
+This command is similar to the command [cmd fileutil::fileType].
+
+[para]
+
+The output of the command for the specified file is a string
+describing the type of the file.
+
+[para]
+
+This list will be empty if the type of the file is not recognized.
+
+[list_end]
+
+[section REFERENCES]
+
+[list_begin enumerated]
+[enum]
+[uri ftp://ftp.astron.com/pub/file/ {File(1) sources}]
+
+This site contains the current sources for the file command, including
+the magic definitions used by it. The latter were used by us to
+generate this recognizer.
+
+[list_end]
+
+[vset CATEGORY {fileutil :: magic}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/fumagic/filetypes.tcl b/tcllib/modules/fumagic/filetypes.tcl
new file mode 100644
index 0000000..8872af3
--- /dev/null
+++ b/tcllib/modules/fumagic/filetypes.tcl
@@ -0,0 +1,5180 @@
+# filetypes.tcl --
+#
+# Tcl based file type recognizer using the runtime core and
+# generated from /usr/share/misc/magic.mime. Limited output,
+# but only mime-types, i.e. standardized.
+#
+# Copyright (c) 2004-2005 Colin McCormack <coldstore@users.sourceforge.net>
+# Copyright (c) 2005-2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: filetypes.tcl,v 1.6 2006/09/27 21:19:35 andreas_kupries Exp $
+
+#####
+#
+# "mime type discriminator"
+# http://wiki.tcl.tk/12537
+#
+# Tcl code harvested on: 10 Feb 2005, 04:16 GMT
+# Wiki page last updated: ???
+#
+#####
+
+# ### ### ### ######### ######### #########
+## Requirements.
+
+package require Tcl 8.4
+package require fileutil::magic::rt ; # We need the runtime core.
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+namespace eval ::fileutil::magic {}
+
+proc ::fileutil::magic::filetype {file} {
+ if {![file exists $file]} {
+ return -code error "file not found: \"$file\""
+ }
+ if {[file isdirectory $file]} {
+ return directory
+ }
+
+ rt::open $file
+ filetype::run
+ rt::close
+ set types [rt::resultv]
+
+ if {[llength $types]} {
+ # We postprocess the data if needed, as the low-level
+ # recognizer can return duplicate information.
+
+ array set _ {}
+ set utypes {}
+ foreach t $types {
+ if {[info exists _($t)]} continue
+ lappend utypes $t
+ set _($t) .
+ set types $utypes
+ }
+ }
+ return [join $types]
+}
+
+package provide fileutil::magic::filetype 1.0.2
+# The actual recognizer is the command below.
+
+##
+## -- Do not edit after this line !
+## -- ** BEGIN GENERATED CODE ** --
+
+package require fileutil::magic::rt
+namespace eval ::fileutil::magic::filetype {
+ namespace import ::fileutil::magic::rt::*
+}
+
+proc ::fileutil::magic::filetype::run {} {
+switch -- [Nv S 0] 518 {emit {ALAN game data}
+if {[N c 2 < 0xa]} {emit {version 2.6%d}}
+} -7408 {emit {Amiga Workbench}
+if {[N S 2 == 0x1]} {switch -- [Nv c 48] 1 {emit {disk icon}} 2 {emit {drawer icon}} 3 {emit {tool icon}} 4 {emit {project icon}} 5 {emit {garbage icon}} 6 {emit {device icon}} 7 {emit {kickstart icon}} 8 {emit {workbench application icon}}
+}
+if {[N S 2 > 0x1]} {emit {icon, vers. %d}}
+} 3840 {emit {AmigaOS bitmap font}} 3843 {emit {AmigaOS outline font}} 19937 {emit {MPEG-4 LO-EP audio stream}} 3599 {emit {Atari MSA archive data}
+if {[N S 2 x {}]} {emit {\b, %d sectors per track}}
+switch -- [Nv S 4] 0 {emit {\b, 1 sided}} 1 {emit {\b, 2 sided}}
+if {[N S 6 x {}]} {emit {\b, starting track: %d}}
+if {[N S 8 x {}]} {emit {\b, ending track: %d}}
+} 368 {emit {WE32000 COFF}
+if {[N S 18 ^ 0x10]} {emit object}
+if {[N S 18 & 0x10]} {emit executable}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+if {[N S 18 ^ 0x1000]} {emit {N/A on 3b2/300 w/paging}}
+if {[N S 18 & 0x2000]} {emit {32100 required}}
+if {[N S 18 & 0x4000]} {emit {and MAU hardware required}}
+switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(pure\)}} 267 {emit {\(demand paged\)}} 291 {emit {\(target shared library\)}}
+if {[N S 22 > 0x0]} {emit {- version %ld}}
+} 369 {emit {WE32000 COFF executable \(TV\)}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+} 14541 {emit {C64 PCLink Image}} 30463 {emit {squeezed data,}
+if {[S 4 x {}]} {emit {original name %s}}
+} 30462 {emit {crunched data,}
+if {[S 2 x {}]} {emit {original name %s}}
+} 30461 {emit {LZH compressed data,}
+if {[S 2 x {}]} {emit {original name %s}}
+} -32760 {emit {Lynx cartridge,}
+if {[N S 2 x {}]} {emit {RAM start $%04x}}
+if {[S 6 == BS93]} {emit 0 12 1}
+if {[N I 16 == 0x3030 &0xfe00f0f0]} {emit {Infocom game data}}
+if {[N c 0 == 0x0]} {emit {\(false match\)}}
+if {[N c 0 > 0x0]} {emit {\(Z-machine %d,}
+if {[N S 2 x {}]} {emit {Release %d /}}
+if {[S 18 x {}]} {emit {Serial %.6s\)}}
+}
+} 2935 {emit {ATSC A/52 aka AC-3 aka Dolby Digital stream,}
+switch -- [Nv c 4 &0xc0] 0 {emit {48 kHz,}} 64 {emit {44.1 kHz,}} -128 {emit {32 kHz,}} -64 {emit {reserved frequency,}}
+switch -- [Nv c 6 &0xe0] 0 {emit {1+1 front,}} 32 {emit {1 front/0 rear,}} 64 {emit {2 front/0 rear,}} 96 {emit {3 front/0 rear,}} -128 {emit {2 front/1 rear,}} -96 {emit {3 front/1 rear,}} -64 {emit {2 front/2 rear,}} -32 {emit {3 front/2 rear,}}
+switch -- [Nv c 7 &0x40] 0 {emit {LFE off,}} 64 {emit {LFE on,}}
+switch -- [Nv S 6 &0x0180] 0 {emit {Dolby Surround not indicated}} 128 {emit {not Dolby Surround encoded}} 256 {emit {Dolby Surround encoded}} 384 {emit {reserved Dolby Surround mode}}
+} 5493 {emit {fsav \(linux\) macro virus}
+if {[N s 8 > 0x0]} {emit {\(%d-}}
+if {[N c 11 > 0x0]} {emit {\b%02d-}}
+if {[N c 10 > 0x0]} {emit {\b%02d\)}}
+} -26367 {emit {GPG key public ring}} 1280 {emit {Hitachi SH big-endian COFF}
+switch -- [Nv S 18 &0x0002] 0 {emit object} 2 {emit executable}
+switch -- [Nv S 18 &0x0008] 8 {emit {\b, stripped}} 0 {emit {\b, not stripped}}
+} 351 {emit {370 XA sysV executable}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+if {[N S 22 > 0x0]} {emit {- version %d}}
+if {[N I 30 > 0x0]} {emit {- 5.2 format}}
+} 346 {emit {370 XA sysV pure executable}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+if {[N S 22 > 0x0]} {emit {- version %d}}
+if {[N I 30 > 0x0]} {emit {- 5.2 format}}
+} 22529 {emit {370 sysV pure executable}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+} 23041 {emit {370 XA sysV pure executable}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+} 23809 {emit {370 sysV executable}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+} 24321 {emit {370 XA sysV executable}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+} 345 {emit {SVR2 executable \(Amdahl-UTS\)}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+if {[N I 24 > 0x0]} {emit {- version %ld}}
+} 348 {emit {SVR2 pure executable \(Amdahl-UTS\)}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+if {[N I 24 > 0x0]} {emit {- version %ld}}
+} 344 {emit {SVR2 pure executable \(USS/370\)}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+if {[N I 24 > 0x0]} {emit {- version %ld}}
+} 349 {emit {SVR2 executable \(USS/370\)}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+if {[N I 24 > 0x0]} {emit {- version %ld}}
+} 407 {emit {Apollo m68k COFF executable}
+if {[N S 18 ^ 0x4000]} {emit {not stripped}}
+if {[N S 22 > 0x0]} {emit {- version %ld}}
+} 404 {emit {apollo a88k COFF executable}
+if {[N S 18 ^ 0x4000]} {emit {not stripped}}
+if {[N S 22 > 0x0]} {emit {- version %ld}}
+} 200 {emit {hp200 \(68010\) BSD}
+switch -- [Nv S 2] 263 {emit {impure binary}} 264 {emit {read-only binary}} 267 {emit {demand paged binary}}
+} 300 {emit {hp300 \(68020+68881\) BSD}
+switch -- [Nv S 2] 263 {emit {impure binary}} 264 {emit {read-only binary}} 267 {emit {demand paged binary}}
+} 479 {emit {executable \(RISC System/6000 V3.1\) or obj module}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+} 260 {emit {shared library}} 261 {emit {ctab data}} -508 {emit {structured file}} 12320 {emit {character Computer Graphics Metafile}} 474 {emit {SGI image data}
+if {[N c 2 == 0x1]} {emit {\b, RLE}}
+if {[N c 3 == 0x2]} {emit {\b, high precision}}
+if {[N S 4 x {}]} {emit {\b, %d-D}}
+if {[N S 6 x {}]} {emit {\b, %d x}}
+if {[N S 8 x {}]} {emit %d}
+if {[N S 10 x {}]} {emit {\b, %d channel}}
+if {[N S 10 != 0x1]} {emit {\bs}}
+if {[S 80 > 0]} {emit {\b, \"%s\"}}
+} 4112 {emit {PEX Binary Archive}} 2560 {emit {PCX ver. 2.5 image data}} 2562 {emit {PCX ver. 2.8 image data, with palette}} 2563 {emit {PCX ver. 2.8 image data, without palette}} 2564 {emit {PCX for Windows image data}} 2565 {emit {PCX ver. 3.0 image data}
+if {[N s 4 x {}]} {emit {bounding box [%hd,}}
+if {[N s 6 x {}]} {emit {%hd] -}}
+if {[N s 8 x {}]} {emit {[%hd,}}
+if {[N s 10 x {}]} {emit %hd\],}
+if {[N c 65 > 0x1]} {emit {%d planes each of}}
+if {[N c 3 x {}]} {emit %hhd-bit}
+switch -- [Nv c 68] 0 {emit image,} 1 {emit colour,} 2 {emit grayscale,}
+if {[N c 68 > 0x2]} {emit image,}
+if {[N c 68 < 0x0]} {emit image,}
+if {[N s 12 > 0x0]} {emit {%hd x}
+if {[N s 14 x {}]} {emit {%hd dpi,}}
+}
+switch -- [Nv c 2] 0 {emit uncompressed} 1 {emit {RLE compressed}}
+} 12320 {emit {character Computer Graphics Metafile}} 21930 {emit {BIOS \(ia32\) ROM Ext.}
+if {[S 5 == USB]} {emit USB}
+if {[S 7 == LDR]} {emit {UNDI image}}
+if {[S 30 == IBM]} {emit {IBM comp. Video}}
+if {[S 26 == Adaptec]} {emit Adaptec}
+if {[S 28 == Adaptec]} {emit Adaptec}
+if {[S 42 == PROMISE]} {emit Promise}
+if {[N c 2 x {}]} {emit {\(%d*512\)}}
+} -21267 {emit {Java serialization data}
+if {[N S 2 > 0x4]} {emit {\b, version %d}}
+} -40 {emit {JPEG image data}
+if {[S 6 == JFIF]} {emit {\b, JFIF standard}
+if {[N c 11 x {}]} {emit {\b %d.}}
+if {[N c 12 x {}]} {emit {\b%02d}}
+if {[N c 18 != 0x0]} {emit {\b, thumbnail %dx}
+if {[N c 19 x {}]} {emit {\b%d}}
+}
+}
+if {[S 6 == Exif]} {emit {\b, EXIF standard}
+if {[S 12 == II]} {if {[N s 70 == 0x8769]} {if {[N s [I 78 i 14] == 0x9000]} {if {[N c [I 78 i 23] x {}]} {emit %c}
+if {[N c [I 78 i 24] x {}]} {emit {\b.%c}}
+if {[N c [I 78 i 25] != 0x30]} {emit {\b%c}}
+}
+}
+if {[N s 118 == 0x8769]} {if {[N s [I 126 i 38] == 0x9000]} {if {[N c [I 126 i 47] x {}]} {emit %c}
+if {[N c [I 126 i 48] x {}]} {emit {\b.%c}}
+if {[N c [I 126 i 49] != 0x30]} {emit {\b%c}}
+}
+}
+if {[N s 130 == 0x8769]} {if {[N s [I 138 i 38] == 0x9000]} {if {[N c [I 138 i 47] x {}]} {emit %c}
+if {[N c [I 138 i 48] x {}]} {emit {\b.%c}}
+if {[N c [I 138 i 49] != 0x30]} {emit {\b%c}}
+}
+if {[N s [I 138 i 50] == 0x9000]} {if {[N c [I 138 i 59] x {}]} {emit %c}
+if {[N c [I 138 i 60] x {}]} {emit {\b.%c}}
+if {[N c [I 138 i 61] != 0x30]} {emit {\b%c}}
+}
+if {[N s [I 138 i 62] == 0x9000]} {if {[N c [I 138 i 71] x {}]} {emit %c}
+if {[N c [I 138 i 72] x {}]} {emit {\b.%c}}
+if {[N c [I 138 i 73] != 0x30]} {emit {\b%c}}
+}
+}
+if {[N s 142 == 0x8769]} {if {[N s [I 150 i 38] == 0x9000]} {if {[N c [I 150 i 47] x {}]} {emit %c}
+if {[N c [I 150 i 48] x {}]} {emit {\b.%c}}
+if {[N c [I 150 i 49] != 0x30]} {emit {\b%c}}
+}
+if {[N s [I 150 i 50] == 0x9000]} {if {[N c [I 150 i 59] x {}]} {emit %c}
+if {[N c [I 150 i 60] x {}]} {emit {\b.%c}}
+if {[N c [I 150 i 61] != 0x30]} {emit {\b%c}}
+}
+if {[N s [I 150 i 62] == 0x9000]} {if {[N c [I 150 i 71] x {}]} {emit %c}
+if {[N c [I 150 i 72] x {}]} {emit {\b.%c}}
+if {[N c [I 150 i 73] != 0x30]} {emit {\b%c}}
+}
+}
+}
+if {[S 12 == MM]} {if {[N S 118 == 0x8769]} {if {[N S [I 126 I 14] == 0x9000]} {if {[N c [I 126 I 23] x {}]} {emit %c}
+if {[N c [I 126 I 24] x {}]} {emit {\b.%c}}
+if {[N c [I 126 I 25] != 0x30]} {emit {\b%c}}
+}
+if {[N S [I 126 I 38] == 0x9000]} {if {[N c [I 126 I 47] x {}]} {emit %c}
+if {[N c [I 126 I 48] x {}]} {emit {\b.%c}}
+if {[N c [I 126 I 49] != 0x30]} {emit {\b%c}}
+}
+}
+if {[N S 130 == 0x8769]} {if {[N S [I 138 I 38] == 0x9000]} {if {[N c [I 138 I 47] x {}]} {emit %c}
+if {[N c [I 138 I 48] x {}]} {emit {\b.%c}}
+if {[N c [I 138 I 49] != 0x30]} {emit {\b%c}}
+}
+if {[N S [I 138 I 62] == 0x9000]} {if {[N c [I 138 I 71] x {}]} {emit %c}
+if {[N c [I 138 I 72] x {}]} {emit {\b.%c}}
+if {[N c [I 138 I 73] != 0x30]} {emit {\b%c}}
+}
+}
+if {[N S 142 == 0x8769]} {if {[N S [I 150 I 50] == 0x9000]} {if {[N c [I 150 I 59] x {}]} {emit %c}
+if {[N c [I 150 I 60] x {}]} {emit {\b.%c}}
+if {[N c [I 150 I 61] != 0x30]} {emit {\b%c}}
+}
+}
+}
+}
+switch -- [Nv c [I 4 S 5]] -2 {emit {}
+if {[S [I 4 S 8] x {}]} {emit {\b, comment: \"%s\"}}
+} -64 {emit {\b, baseline}
+if {[N c [I 4 S 6] x {}]} {emit {\b, precision %d}}
+if {[N S [I 4 S 7] x {}]} {emit {\b, %dx}}
+if {[N S [I 4 S 9] x {}]} {emit {\b%d}}
+} -63 {emit {\b, extended sequential}
+if {[N c [I 4 S 6] x {}]} {emit {\b, precision %d}}
+if {[N S [I 4 S 7] x {}]} {emit {\b, %dx}}
+if {[N S [I 4 S 9] x {}]} {emit {\b%d}}
+} -62 {emit {\b, progressive}
+if {[N c [I 4 S 6] x {}]} {emit {\b, precision %d}}
+if {[N S [I 4 S 7] x {}]} {emit {\b, %dx}}
+if {[N S [I 4 S 9] x {}]} {emit {\b%d}}
+}
+} -32768 {emit {lif file}} -30875 {emit {disk quotas file}} 1286 {emit {IRIS Showcase file}
+if {[N c 2 == 0x49]} {emit -}
+if {[N c 3 x {}]} {emit {- version %ld}}
+} 550 {emit {IRIS Showcase template}
+if {[N c 2 == 0x63]} {emit -}
+if {[N c 3 x {}]} {emit {- version %ld}}
+} 352 {emit {MIPSEB ECOFF executable}
+switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(swapped\)}} 267 {emit {\(paged\)}}
+if {[N I 8 > 0x0]} {emit {not stripped}}
+if {[N I 8 == 0x0]} {emit stripped}
+if {[N c 22 x {}]} {emit {- version %ld}}
+if {[N c 23 x {}]} {emit .%ld}
+} 354 {emit {MIPSEL-BE ECOFF executable}
+switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(swapped\)}} 267 {emit {\(paged\)}}
+if {[N I 8 > 0x0]} {emit {not stripped}}
+if {[N I 8 == 0x0]} {emit stripped}
+if {[N c 23 x {}]} {emit {- version %d}}
+if {[N c 22 x {}]} {emit .%ld}
+} 24577 {emit {MIPSEB-LE ECOFF executable}
+switch -- [Nv S 20] 1793 {emit {\(impure\)}} 2049 {emit {\(swapped\)}} 2817 {emit {\(paged\)}}
+if {[N I 8 > 0x0]} {emit {not stripped}}
+if {[N I 8 == 0x0]} {emit stripped}
+if {[N c 23 x {}]} {emit {- version %d}}
+if {[N c 22 x {}]} {emit .%ld}
+} 25089 {emit {MIPSEL ECOFF executable}
+switch -- [Nv S 20] 1793 {emit {\(impure\)}} 2049 {emit {\(swapped\)}} 2817 {emit {\(paged\)}}
+if {[N I 8 > 0x0]} {emit {not stripped}}
+if {[N I 8 == 0x0]} {emit stripped}
+if {[N c 23 x {}]} {emit {- version %ld}}
+if {[N c 22 x {}]} {emit .%ld}
+} 355 {emit {MIPSEB MIPS-II ECOFF executable}
+switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(swapped\)}} 267 {emit {\(paged\)}}
+if {[N I 8 > 0x0]} {emit {not stripped}}
+if {[N I 8 == 0x0]} {emit stripped}
+if {[N c 22 x {}]} {emit {- version %ld}}
+if {[N c 23 x {}]} {emit .%ld}
+} 358 {emit {MIPSEL-BE MIPS-II ECOFF executable}
+switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(swapped\)}} 267 {emit {\(paged\)}}
+if {[N I 8 > 0x0]} {emit {not stripped}}
+if {[N I 8 == 0x0]} {emit stripped}
+if {[N c 22 x {}]} {emit {- version %ld}}
+if {[N c 23 x {}]} {emit .%ld}
+} 25345 {emit {MIPSEB-LE MIPS-II ECOFF executable}
+switch -- [Nv S 20] 1793 {emit {\(impure\)}} 2049 {emit {\(swapped\)}} 2817 {emit {\(paged\)}}
+if {[N I 8 > 0x0]} {emit {not stripped}}
+if {[N I 8 == 0x0]} {emit stripped}
+if {[N c 23 x {}]} {emit {- version %ld}}
+if {[N c 22 x {}]} {emit .%ld}
+} 26113 {emit {MIPSEL MIPS-II ECOFF executable}
+switch -- [Nv S 20] 1793 {emit {\(impure\)}} 2049 {emit {\(swapped\)}} 2817 {emit {\(paged\)}}
+if {[N I 8 > 0x0]} {emit {not stripped}}
+if {[N I 8 == 0x0]} {emit stripped}
+if {[N c 23 x {}]} {emit {- version %ld}}
+if {[N c 22 x {}]} {emit .%ld}
+} 320 {emit {MIPSEB MIPS-III ECOFF executable}
+switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(swapped\)}} 267 {emit {\(paged\)}}
+if {[N I 8 > 0x0]} {emit {not stripped}}
+if {[N I 8 == 0x0]} {emit stripped}
+if {[N c 22 x {}]} {emit {- version %ld}}
+if {[N c 23 x {}]} {emit .%ld}
+} 322 {emit {MIPSEL-BE MIPS-III ECOFF executable}
+switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(swapped\)}} 267 {emit {\(paged\)}}
+if {[N I 8 > 0x0]} {emit {not stripped}}
+if {[N I 8 == 0x0]} {emit stripped}
+if {[N c 22 x {}]} {emit {- version %ld}}
+if {[N c 23 x {}]} {emit .%ld}
+} 16385 {emit {MIPSEB-LE MIPS-III ECOFF executable}
+switch -- [Nv S 20] 1793 {emit {\(impure\)}} 2049 {emit {\(swapped\)}} 2817 {emit {\(paged\)}}
+if {[N I 8 > 0x0]} {emit {not stripped}}
+if {[N I 8 == 0x0]} {emit stripped}
+if {[N c 23 x {}]} {emit {- version %ld}}
+if {[N c 22 x {}]} {emit .%ld}
+} 16897 {emit {MIPSEL MIPS-III ECOFF executable}
+switch -- [Nv S 20] 1793 {emit {\(impure\)}} 2049 {emit {\(swapped\)}} 2817 {emit {\(paged\)}}
+if {[N I 8 > 0x0]} {emit {not stripped}}
+if {[N I 8 == 0x0]} {emit stripped}
+if {[N c 23 x {}]} {emit {- version %ld}}
+if {[N c 22 x {}]} {emit .%ld}
+} 384 {emit {MIPSEB Ucode}} 386 {emit {MIPSEL-BE Ucode}} 336 {emit {mc68k COFF}
+if {[N S 18 ^ 0x10]} {emit object}
+if {[N S 18 & 0x10]} {emit executable}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+if {[S 168 == .lowmem]} {emit {Apple toolbox}}
+switch -- [Nv S 20] 263 {emit {\(impure\)}} 264 {emit {\(pure\)}} 267 {emit {\(demand paged\)}} 273 {emit {\(standalone\)}}
+} 337 {emit {mc68k executable \(shared\)}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+} 338 {emit {mc68k executable \(shared demand paged\)}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+} 364 {emit {68K BCS executable}} 365 {emit {88K BCS executable}} 24602 {emit {Atari 68xxx executable,}
+if {[N I 2 x {}]} {emit {text len %lu,}}
+if {[N I 6 x {}]} {emit {data len %lu,}}
+if {[N I 10 x {}]} {emit {BSS len %lu,}}
+if {[N I 14 x {}]} {emit {symboltab len %lu,}}
+if {[N I 18 == 0x0]} {emit 0 70 4}
+if {[N I 22 & 0x1]} {emit {fastload flag,}}
+if {[N I 22 & 0x2]} {emit {may be loaded to alternate RAM,}}
+if {[N I 22 & 0x4]} {emit {malloc may be from alternate RAM,}}
+if {[N I 22 x {}]} {emit {flags: 0x%lX,}}
+if {[N S 26 == 0x0]} {emit {no relocation tab}}
+if {[N S 26 != 0x0]} {emit {+ relocation tab}}
+if {[S 30 == SFX]} {emit {[Self-Extracting LZH SFX archive]}}
+if {[S 38 == SFX]} {emit {[Self-Extracting LZH SFX archive]}}
+if {[S 44 == ZIP!]} {emit {[Self-Extracting ZIP SFX archive]}}
+} 100 {emit {Atari 68xxx CPX file}
+if {[N S 8 x {}]} {emit {\(version %04lx\)}}
+} 392 {emit {Tower/XP rel 2 object}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+switch -- [Nv S 20] 263 {emit executable} 264 {emit {pure executable}}
+if {[N S 22 > 0x0]} {emit {- version %ld}}
+} 397 {emit {Tower/XP rel 2 object}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+switch -- [Nv S 20] 263 {emit executable} 264 {emit {pure executable}}
+if {[N S 22 > 0x0]} {emit {- version %ld}}
+} 400 {emit {Tower/XP rel 3 object}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+switch -- [Nv S 20] 263 {emit executable} 264 {emit {pure executable}}
+if {[N S 22 > 0x0]} {emit {- version %ld}}
+} 405 {emit {Tower/XP rel 3 object}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+switch -- [Nv S 20] 263 {emit executable} 264 {emit {pure executable}}
+if {[N S 22 > 0x0]} {emit {- version %ld}}
+} 408 {emit {Tower32/600/400 68020 object}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+switch -- [Nv S 20] 263 {emit executable} 264 {emit {pure executable}}
+if {[N S 22 > 0x0]} {emit {- version %ld}}
+} 416 {emit {Tower32/800 68020}
+if {[N S 18 & 0x2000]} {emit {w/68881 object}}
+if {[N S 18 & 0x4000]} {emit {compatible object}}
+if {[N S 18 & 0xffff9fff]} {emit object}
+switch -- [Nv S 20] 263 {emit executable} 267 {emit {pure executable}}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+if {[N S 22 > 0x0]} {emit {- version %ld}}
+} 421 {emit {Tower32/800 68010}
+if {[N S 18 & 0x4000]} {emit {compatible object}}
+if {[N S 18 & 0xffff9fff]} {emit object}
+switch -- [Nv S 20] 263 {emit executable} 267 {emit {pure executable}}
+if {[N I 12 > 0x0]} {emit {not stripped}}
+if {[N S 22 > 0x0]} {emit {- version %ld}}
+} -30771 {emit {OS9/6809 module:}
+switch -- [Nv c 6 &0x0f] 0 {emit non-executable} 1 {emit {machine language}} 2 {emit {BASIC I-code}} 3 {emit {Pascal P-code}} 4 {emit {C I-code}} 5 {emit {COBOL I-code}} 6 {emit {Fortran I-code}}
+switch -- [Nv c 6 &0xf0] 16 {emit {program executable}} 32 {emit subroutine} 48 {emit multi-module} 64 {emit {data module}} -64 {emit {system module}} -48 {emit {file manager}} -32 {emit {device driver}} -16 {emit {device descriptor}}
+} 19196 {emit {OS9/68K module:}
+if {[N c 20 == 0x80 &0x80]} {emit re-entrant}
+if {[N c 20 == 0x40 &0x40]} {emit ghost}
+if {[N c 20 == 0x20 &0x20]} {emit system-state}
+switch -- [Nv c 19] 1 {emit {machine language}} 2 {emit {BASIC I-code}} 3 {emit {Pascal P-code}} 4 {emit {C I-code}} 5 {emit {COBOL I-code}} 6 {emit {Fortran I-code}}
+switch -- [Nv c 18] 1 {emit {program executable}} 2 {emit subroutine} 3 {emit multi-module} 4 {emit {data module}} 11 {emit {trap library}} 12 {emit {system module}} 13 {emit {file manager}} 14 {emit {device driver}} 15 {emit {device descriptor}}
+} -26368 {emit {PGP key public ring}} -27391 {emit {PGP key security ring}} -27392 {emit {PGP key security ring}} -23040 {emit {PGP encrypted data}} -4693 {emit {}
+if {[N S 2 == 0xeedb]} {emit RPM
+if {[N c 4 x {}]} {emit v%d}
+switch -- [Nv S 6] 0 {emit bin} 1 {emit src}
+switch -- [Nv S 8] 1 {emit i386} 2 {emit Alpha} 3 {emit Sparc} 4 {emit MIPS} 5 {emit PowerPC} 6 {emit 68000} 7 {emit SGI} 8 {emit RS6000} 9 {emit IA64} 10 {emit Sparc64} 11 {emit MIPSel} 12 {emit ARM}
+if {[S 10 x {}]} {emit %s}
+}
+} -1279 {emit {QDOS object}
+if {[S 2 x {} p]} {emit '%s'}
+} -511 {emit {MySQL table definition file}
+if {[N c 2 x {}]} {emit {Version %d}}
+} 378 {emit {amd 29k coff noprebar executable}} 890 {emit {amd 29k coff prebar executable}} -8185 {emit {amd 29k coff archive}}
+if {[S 0 == {TADS2\ bin}]} {emit TADS
+if {[N I 9 != 0xa0d1a00]} {emit {game data, CORRUPTED}}
+if {[N I 9 == 0xa0d1a00]} {if {[S 13 x {}]} {emit {%s game data}}
+}
+}
+if {[S 0 == {TADS2\ rsc}]} {emit TADS
+if {[N I 9 != 0xa0d1a00]} {emit {resource data, CORRUPTED}}
+if {[N I 9 == 0xa0d1a00]} {if {[S 13 x {}]} {emit {%s resource data}}
+}
+}
+if {[S 0 == {TADS2\ save/g}]} {emit TADS
+if {[N I 12 != 0xa0d1a00]} {emit {saved game data, CORRUPTED}}
+if {[N I 12 == 0xa0d1a00]} {if {[S [I 16 s 32] x {}]} {emit {%s saved game data}}
+}
+}
+if {[S 0 == {TADS2\ save}]} {emit TADS
+if {[N I 10 != 0xa0d1a00]} {emit {saved game data, CORRUPTED}}
+if {[N I 10 == 0xa0d1a00]} {if {[S 14 x {}]} {emit {%s saved game data}}
+}
+}
+switch -- [Nv i 0] -1010055483 {emit {RISC OS Chunk data}
+if {[S 12 == OBJ_]} {emit {\b, AOF object}}
+if {[S 12 == LIB_]} {emit {\b, ALF library}}
+} 65389 {emit {very old VAX archive}} 65381 {emit {old VAX archive}
+if {[S 8 == __.SYMDEF]} {emit {random library}}
+} 236525 {emit {PDP-11 old archive}} 236526 {emit {PDP-11 4.0 archive}} 6583086 {emit {DEC audio data:}
+switch -- [Nv i 12] 1 {emit {8-bit ISDN mu-law,}} 2 {emit {8-bit linear PCM [REF-PCM],}} 3 {emit {16-bit linear PCM,}} 4 {emit {24-bit linear PCM,}} 5 {emit {32-bit linear PCM,}} 6 {emit {32-bit IEEE floating point,}} 7 {emit {64-bit IEEE floating point,}} 23 {emit {8-bit ISDN mu-law compressed \(CCITT G.721 ADPCM voice data encoding\),}}
+switch -- [Nv I 12] 8 {emit {Fragmented sample data,}} 10 {emit {DSP program,}} 11 {emit {8-bit fixed point,}} 12 {emit {16-bit fixed point,}} 13 {emit {24-bit fixed point,}} 14 {emit {32-bit fixed point,}} 18 {emit {16-bit linear with emphasis,}} 19 {emit {16-bit linear compressed,}} 20 {emit {16-bit linear with emphasis and compression,}} 21 {emit {Music kit DSP commands,}} 24 {emit {compressed \(8-bit CCITT G.722 ADPCM\)}} 25 {emit {compressed \(3-bit CCITT G.723.3 ADPCM\),}} 26 {emit {compressed \(5-bit CCITT G.723.5 ADPCM\),}} 27 {emit {8-bit A-law \(CCITT G.711\),}}
+switch -- [Nv i 20] 1 {emit mono,} 2 {emit stereo,} 4 {emit quad,}
+if {[N i 16 > 0x0]} {emit {%d Hz}}
+} 204 {emit {386 compact demand paged pure executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+if {[N c 32 == 0x6a]} {emit {\(uses shared libs\)}}
+} 263 {emit {386 executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+if {[N c 32 == 0x6a]} {emit {\(uses shared libs\)}}
+} 264 {emit {386 pure executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+if {[N c 32 == 0x6a]} {emit {\(uses shared libs\)}}
+} 267 {emit {386 demand paged pure executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+if {[N c 32 == 0x6a]} {emit {\(uses shared libs\)}}
+} 324508366 {emit {GNU dbm 1.x or ndbm database, little endian}} 340322 {emit {Berkeley DB 1.85/1.86}
+if {[N i 4 > 0x0]} {emit {\(Btree, version %d, little-endian\)}}
+} -109248628 {emit {SE Linux policy}
+if {[N i 16 x {}]} {emit v%d}
+if {[N i 20 == 0x1]} {emit MLS}
+if {[N i 24 x {}]} {emit {%d symbols}}
+if {[N i 28 x {}]} {emit {%d ocons}}
+} 453186358 {emit {Netboot image,}
+if {[N i 4 == 0x0 &0xFFFFFF00]} {switch -- [Nv i 4 &0x100] 0 {emit {mode 2}} 256 {emit {mode 3}}
+}
+if {[N i 4 != 0x0 &0xFFFFFF00]} {emit {unknown mode}}
+} 684539205 {emit {Linux Compressed ROM File System data, little endian}
+if {[N i 4 x {}]} {emit {size %d}}
+if {[N i 8 & 0x1]} {emit {version \#2}}
+if {[N i 8 & 0x2]} {emit sorted_dirs}
+if {[N i 8 & 0x4]} {emit hole_support}
+if {[N i 32 x {}]} {emit {CRC 0x%x,}}
+if {[N i 36 x {}]} {emit {edition %d,}}
+if {[N i 40 x {}]} {emit {%d blocks,}}
+if {[N i 44 x {}]} {emit {%d files}}
+} 876099889 {emit {Linux Journalled Flash File system, little endian}} -536798843 {emit {Linux jffs2 filesystem data little endian}} 4 {emit {X11 SNF font data, LSB first}} 1279543401 {emit {ld.so hints file \(Little Endian}
+if {[N i 4 > 0x0]} {emit {\b, version %d\)}}
+if {[N I 4 <= 0x0]} {emit {\b\)}}
+} 1638399 {emit {GEM Metafile data}
+if {[N s 4 x {}]} {emit {version %d}}
+} 987654321 {emit {DCX multi-page PCX image data}} -681629056 {emit {Cineon image data}
+if {[N I 200 > 0x0]} {emit {\b, %ld x}}
+if {[N I 204 > 0x0]} {emit %ld}
+} 20000630 {emit {OpenEXR image data}} 6553863 {emit {Linux/i386 impure executable \(OMAGIC\)}
+if {[N i 16 == 0x0]} {emit {\b, stripped}}
+} 6553864 {emit {Linux/i386 pure executable \(NMAGIC\)}
+if {[N i 16 == 0x0]} {emit {\b, stripped}}
+} 6553867 {emit {Linux/i386 demand-paged executable \(ZMAGIC\)}
+if {[N i 16 == 0x0]} {emit {\b, stripped}}
+} 6553804 {emit {Linux/i386 demand-paged executable \(QMAGIC\)}
+if {[N i 16 == 0x0]} {emit {\b, stripped}}
+} 336851773 {emit {SYSLINUX' LSS16 image data}
+if {[N s 4 x {}]} {emit {\b, width %d}}
+if {[N s 6 x {}]} {emit {\b, height %d}}
+} -249691108 {emit {magic binary file for file\(1\) cmd}
+if {[N i 4 x {}]} {emit {\(version %d\) \(little endian\)}}
+} 574529400 {emit {Transport Neutral Encapsulation Format}} -21555 {emit {MLSSA datafile,}
+if {[N s 4 x {}]} {emit {algorithm %d,}}
+if {[N i 10 x {}]} {emit {%d samples}}
+} 134769520 {emit {TurboC BGI file}} 134761296 {emit {TurboC Font file}} 76 {emit {}
+if {[N i 4 == 0x21401]} {emit {Windows shortcut file}}
+} 1313096225 {emit {Microsoft Outlook binary email folder}} 220991 {emit {Windows 3.x help file}} 263 {emit {a.out NetBSD little-endian object file}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 459141 {emit {ECOFF NetBSD/alpha binary}
+switch -- [Nv s 10] 1 {emit {not stripped}} 0 {emit stripped}
+} 33645 {emit {PDP-11 single precision APL workspace}} 33644 {emit {PDP-11 double precision APL workspace}} 268435511 {emit {Psion Series 5}
+switch -- [Nv i 4] 268435513 {emit {font file}} 268435514 {emit {printer driver}} 268435515 {emit clipboard} 268435522 {emit {multi-bitmap image}} 268435562 {emit {application infomation file}} 268435565 {emit {}
+switch -- [Nv i 8] 268435581 {emit {sketch image}} 268435582 {emit {voice note}} 268435583 {emit {word file}} 268435589 {emit {OPL program}} 268435592 {emit {sheet file}} 268435908 {emit {EasyFax initialisation file}}
+} 268435571 {emit {OPO module}} 268435572 {emit {OPL application}} 268435594 {emit {exported multi-bitmap image}}
+} 268435521 {emit {Psion Series 5 ROM multi-bitmap image}} 268435536 {emit {Psion Series 5}
+switch -- [Nv i 4] 268435565 {emit database} 268435684 {emit {ini file}}
+} 268435577 {emit {Psion Series 5 binary:}
+switch -- [Nv i 4] 0 {emit DLL} 268435529 {emit {comms hardware library}} 268435530 {emit {comms protocol library}} 268435549 {emit OPX} 268435564 {emit application} 268435597 {emit DLL} 268435628 {emit {logical device driver}} 268435629 {emit {physical device driver}} 268435685 {emit {file transfer protocol}} 268435685 {emit {file transfer protocol}} 268435776 {emit {printer defintion}} 268435777 {emit {printer defintion}}
+} 268435578 {emit {Psion Series 5 executable}} 234 {emit {BALANCE NS32000 .o}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+if {[N i 124 > 0x0]} {emit {version %ld}}
+} 4330 {emit {BALANCE NS32000 executable \(0 @ 0\)}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+if {[N i 124 > 0x0]} {emit {version %ld}}
+} 8426 {emit {BALANCE NS32000 executable \(invalid @ 0\)}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+if {[N i 124 > 0x0]} {emit {version %ld}}
+} 12522 {emit {BALANCE NS32000 standalone executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+if {[N i 124 > 0x0]} {emit {version %ld}}
+} 320013059 {emit {SpeedShop data file}} 16922978 {emit {mdbm file, version 0 \(obsolete\)}} -1582119980 {emit {tcpdump capture file \(little-endian\)}
+if {[N s 4 x {}]} {emit {- version %d}}
+if {[N s 6 x {}]} {emit {\b.%d}}
+switch -- [Nv i 20] 0 {emit {\(No link-layer encapsulation}} 1 {emit {\(Ethernet}} 2 {emit {\(3Mb Ethernet}} 3 {emit {\(AX.25}} 4 {emit {\(ProNET}} 5 {emit {\(CHAOS}} 6 {emit {\(Token Ring}} 7 {emit {\(ARCNET}} 8 {emit {\(SLIP}} 9 {emit {\(PPP}} 10 {emit {\(FDDI}} 11 {emit {\(RFC 1483 ATM}} 12 {emit {\(raw IP}} 13 {emit {\(BSD/OS SLIP}} 14 {emit {\(BSD/OS PPP}} 19 {emit {\(Linux ATM Classical IP}} 50 {emit {\(PPP or Cisco HDLC}} 51 {emit {\(PPP-over-Ethernet}} 99 {emit {\(Symantec Enterprise Firewall}} 100 {emit {\(RFC 1483 ATM}} 101 {emit {\(raw IP}} 102 {emit {\(BSD/OS SLIP}} 103 {emit {\(BSD/OS PPP}} 104 {emit {\(BSD/OS Cisco HDLC}} 105 {emit {\(802.11}} 106 {emit {\(Linux Classical IP over ATM}} 107 {emit {\(Frame Relay}} 108 {emit {\(OpenBSD loopback}} 109 {emit {\(OpenBSD IPsec encrypted}} 112 {emit {\(Cisco HDLC}} 113 {emit {\(Linux \"cooked\"}} 114 {emit {\(LocalTalk}} 117 {emit {\(OpenBSD PFLOG}} 119 {emit {\(802.11 with Prism header}} 122 {emit {\(RFC 2625 IP over Fibre Channel}} 123 {emit {\(SunATM}} 127 {emit {\(802.11 with radiotap header}} 129 {emit {\(Linux ARCNET}} 138 {emit {\(Apple IP over IEEE 1394}} 140 {emit {\(MTP2}} 141 {emit {\(MTP3}} 143 {emit {\(DOCSIS}} 144 {emit {\(IrDA}} 147 {emit {\(Private use 0}} 148 {emit {\(Private use 1}} 149 {emit {\(Private use 2}} 150 {emit {\(Private use 3}} 151 {emit {\(Private use 4}} 152 {emit {\(Private use 5}} 153 {emit {\(Private use 6}} 154 {emit {\(Private use 7}} 155 {emit {\(Private use 8}} 156 {emit {\(Private use 9}} 157 {emit {\(Private use 10}} 158 {emit {\(Private use 11}} 159 {emit {\(Private use 12}} 160 {emit {\(Private use 13}} 161 {emit {\(Private use 14}} 162 {emit {\(Private use 15}} 163 {emit {\(802.11 with AVS header}}
+if {[N i 16 x {}]} {emit {\b, capture length %d\)}}
+} -1582117580 {emit {extended tcpdump capture file \(little-endian\)}
+if {[N s 4 x {}]} {emit {- version %d}}
+if {[N s 6 x {}]} {emit {\b.%d}}
+switch -- [Nv i 20] 0 {emit {\(No link-layer encapsulation}} 1 {emit {\(Ethernet}} 2 {emit {\(3Mb Ethernet}} 3 {emit {\(AX.25}} 4 {emit {\(ProNET}} 5 {emit {\(CHAOS}} 6 {emit {\(Token Ring}} 7 {emit {\(ARCNET}} 8 {emit {\(SLIP}} 9 {emit {\(PPP}} 10 {emit {\(FDDI}} 11 {emit {\(RFC 1483 ATM}} 12 {emit {\(raw IP}} 13 {emit {\(BSD/OS SLIP}} 14 {emit {\(BSD/OS PPP}}
+if {[N i 16 x {}]} {emit {\b, capture length %d\)}}
+} 33647 {emit {VAX single precision APL workspace}} 33646 {emit {VAX double precision APL workspace}} 263 {emit {VAX executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 264 {emit {VAX pure executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 267 {emit {VAX demand paged pure executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 272 {emit {VAX demand paged \(first page unmapped\) pure executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 518 {emit b.out
+if {[N s 30 & 0x10]} {emit overlay}
+if {[N s 30 & 0x2]} {emit separate}
+if {[N s 30 & 0x4]} {emit pure}
+if {[N s 30 & 0x800]} {emit segmented}
+if {[N s 30 & 0x400]} {emit standalone}
+if {[N s 30 & 0x1]} {emit executable}
+if {[N s 30 ^ 0x1]} {emit {object file}}
+if {[N s 30 & 0x4000]} {emit V2.3}
+if {[N s 30 & 0x8000]} {emit V3.0}
+if {[N c 28 & 0x4]} {emit 86}
+if {[N c 28 & 0xb]} {emit 186}
+if {[N c 28 & 0x9]} {emit 286}
+if {[N c 28 & 0x29]} {emit 286}
+if {[N c 28 & 0xa]} {emit 386}
+if {[N s 30 & 0x4]} {emit {Large Text}}
+if {[N s 30 & 0x2]} {emit {Large Data}}
+if {[N s 30 & 0x102]} {emit {Huge Objects Enabled}}
+}
+if {[N i 16 == 0xef000011]} {emit {RISC OS AIF executable}}
+if {[S 0 == Draw]} {emit {RISC OS Draw file data}}
+if {[S 0 == {FONT\0}]} {emit {RISC OS outline font data,}
+if {[N c 5 x {}]} {emit {version %d}}
+}
+if {[S 0 == {FONT\1}]} {emit {RISC OS 1bpp font data,}
+if {[N c 5 x {}]} {emit {version %d}}
+}
+if {[S 0 == {FONT\4}]} {emit {RISC OS 4bpp font data}
+if {[N c 5 x {}]} {emit {version %d}}
+}
+if {[S 0 == {Maestro\r}]} {emit {RISC OS music file}
+if {[N c 8 x {}]} {emit {version %d}}
+}
+switch -- [Nv s 0] 21020 {emit {COFF DSP21k}
+if {[N i 18 & 0x2]} {emit executable,}
+if {[N i 18 ^ 0x2]} {if {[N i 18 & 0x1]} {emit {static object,}}
+if {[N i 18 ^ 0x1]} {emit {relocatable object,}}
+}
+if {[N i 18 & 0x8]} {emit stripped}
+if {[N i 18 ^ 0x8]} {emit {not stripped}}
+} 387 {emit {COFF format alpha}
+if {[N s 22 != 0x2000 &030000]} {emit executable}
+switch -- [Nv s 24] 264 {emit pure} 267 {emit paged} 263 {emit object}
+if {[N s 22 != 0x0 &020000]} {emit {dynamically linked}}
+if {[N i 16 != 0x0]} {emit {not stripped}}
+if {[N i 16 == 0x0]} {emit stripped}
+if {[N s 22 == 0x2000 &030000]} {emit {shared library}}
+if {[N c 27 x {}]} {emit {- version %d}}
+if {[N c 26 x {}]} {emit .%d}
+if {[N c 28 x {}]} {emit -%d}
+} -147 {emit {very old PDP-11 archive}} -155 {emit {old PDP-11 archive}
+if {[S 8 == __.SYMDEF]} {emit {random library}}
+} -5536 {emit {ARJ archive data}
+if {[N c 5 x {}]} {emit {\b, v%d,}}
+if {[N c 8 & 0x4]} {emit multi-volume,}
+if {[N c 8 & 0x10]} {emit slash-switched,}
+if {[N c 8 & 0x20]} {emit backup,}
+if {[S 34 x {}]} {emit {original name: %s,}}
+switch -- [Nv c 7] 0 {emit {os: MS-DOS}} 1 {emit {os: PRIMOS}} 2 {emit {os: Unix}} 3 {emit {os: Amiga}} 4 {emit {os: Macintosh}} 5 {emit {os: OS/2}} 6 {emit {os: Apple ][ GS}} 7 {emit {os: Atari ST}} 8 {emit {os: NeXT}} 9 {emit {os: VAX/VMS}}
+if {[N c 3 > 0x0]} {emit %d\]}
+} -5247 {emit {PRCS packaged project}} 387 {emit {COFF format alpha}
+if {[N s 22 & 0x1000 &020000]} {emit {sharable library,}}
+if {[N s 22 ^ 0x1000 &020000]} {emit {dynamically linked,}}
+switch -- [Nv s 24] 264 {emit pure} 267 {emit {demand paged}}
+if {[N i 8 > 0x0]} {emit {executable or object module, not stripped}}
+if {[N i 8 == 0x0]} {if {[N i 12 == 0x0]} {emit {executable or object module, stripped}}
+if {[N i 12 > 0x0]} {emit {executable or object module, not stripped}}
+}
+if {[N c 27 > 0x0]} {emit {- version %d.}}
+if {[N c 26 > 0x0]} {emit %d-}
+if {[N s 28 > 0x0]} {emit %d}
+} 392 {emit {Alpha compressed COFF}} 399 {emit {Alpha u-code object}} 6532 {emit {Linux old jffs2 filesystem data little endian}} 1360 {emit {Hitachi SH little-endian COFF}
+switch -- [Nv s 18 &0x0002] 0 {emit object} 2 {emit executable}
+switch -- [Nv s 18 &0x0008] 8 {emit {\b, stripped}} 0 {emit {\b, not stripped}}
+} -13230 {emit {RLE image data,}
+if {[N s 6 x {}]} {emit {%d x}}
+if {[N s 8 x {}]} {emit %d}
+if {[N s 2 > 0x0]} {emit {\b, lower left corner: %d}}
+if {[N s 4 > 0x0]} {emit {\b, lower right corner: %d}}
+if {[N c 10 == 0x1 &0x1]} {emit {\b, clear first}}
+if {[N c 10 == 0x2 &0x2]} {emit {\b, no background}}
+if {[N c 10 == 0x4 &0x4]} {emit {\b, alpha channel}}
+if {[N c 10 == 0x8 &0x8]} {emit {\b, comment}}
+if {[N c 11 > 0x0]} {emit {\b, %d color channels}}
+if {[N c 12 > 0x0]} {emit {\b, %d bits per pixel}}
+if {[N c 13 > 0x0]} {emit {\b, %d color map channels}}
+} 322 {emit {basic-16 executable}
+if {[N i 12 > 0x0]} {emit {not stripped}}
+} 323 {emit {basic-16 executable \(TV\)}
+if {[N i 12 > 0x0]} {emit {not stripped}}
+} 328 {emit {x86 executable}
+if {[N i 12 > 0x0]} {emit {not stripped}}
+} 329 {emit {x86 executable \(TV\)}
+if {[N i 12 > 0x0]} {emit {not stripped}}
+} 330 {emit {iAPX 286 executable small model \(COFF\)}
+if {[N i 12 > 0x0]} {emit {not stripped}}
+} 338 {emit {iAPX 286 executable large model \(COFF\)}
+if {[N i 12 > 0x0]} {emit {not stripped}}
+} 332 {emit {80386 COFF executable}
+if {[N i 12 > 0x0]} {emit {not stripped}}
+if {[N s 22 > 0x0]} {emit {- version %ld}}
+} 1078 {emit {Linux/i386 PC Screen Font data,}
+switch -- [Nv c 2] 0 {emit {256 characters, no directory,}} 1 {emit {512 characters, no directory,}} 2 {emit {256 characters, Unicode directory,}} 3 {emit {512 characters, Unicode directory,}}
+if {[N c 3 > 0x0]} {emit 8x%d}
+} 387 {emit {ECOFF alpha}
+switch -- [Nv s 24] 263 {emit executable} 264 {emit pure} 267 {emit {demand paged}}
+if {[N Q 8 > 0x0]} {emit {not stripped}}
+if {[N Q 8 == 0x0]} {emit stripped}
+if {[N s 23 > 0x0]} {emit {- version %ld.}}
+} 332 {emit {MS Windows COFF Intel 80386 object file}} 358 {emit {MS Windows COFF MIPS R4000 object file}} 388 {emit {MS Windows COFF Alpha object file}} 616 {emit {MS Windows COFF Motorola 68000 object file}} 496 {emit {MS Windows COFF PowerPC object file}} 656 {emit {MS Windows COFF PA-RISC object file}} 6 {emit {DBase 3 index file}} -24712 {emit TNEF} 263 {emit {PDP-11 executable}
+if {[N s 8 > 0x0]} {emit {not stripped}}
+if {[N c 15 > 0x0]} {emit {- version %ld}}
+} 257 {emit {PDP-11 UNIX/RT ldp}} 261 {emit {PDP-11 old overlay}} 264 {emit {PDP-11 pure executable}
+if {[N s 8 > 0x0]} {emit {not stripped}}
+if {[N c 15 > 0x0]} {emit {- version %ld}}
+} 265 {emit {PDP-11 separate I&D executable}
+if {[N s 8 > 0x0]} {emit {not stripped}}
+if {[N c 15 > 0x0]} {emit {- version %ld}}
+} 287 {emit {PDP-11 kernel overlay}} 267 {emit {PDP-11 demand-paged pure executable}
+if {[N s 8 > 0x0]} {emit {not stripped}}
+} 280 {emit {PDP-11 overlaid pure executable}
+if {[N s 8 > 0x0]} {emit {not stripped}}
+} 281 {emit {PDP-11 overlaid separate executable}
+if {[N s 8 > 0x0]} {emit {not stripped}}
+} 4843 {emit {SYMMETRY i386 .o}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+if {[N i 124 > 0x0]} {emit {version %ld}}
+} 8939 {emit {SYMMETRY i386 executable \(0 @ 0\)}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+if {[N i 124 > 0x0]} {emit {version %ld}}
+} 13035 {emit {SYMMETRY i386 executable \(invalid @ 0\)}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+if {[N i 124 > 0x0]} {emit {version %ld}}
+} 17131 {emit {SYMMETRY i386 standalone executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+if {[N i 124 > 0x0]} {emit {version %ld}}
+} 21020 {emit {SHARC COFF binary}
+if {[N s 2 > 0x1]} {emit {, %hd sections}
+if {[N i 12 > 0x0]} {emit {, not stripped}}
+}
+} 4097 {emit {LANalyzer capture file}} 4103 {emit {LANalyzer capture file}} 376 {emit {VAX COFF executable}
+if {[N i 12 > 0x0]} {emit {not stripped}}
+if {[N s 22 > 0x0]} {emit {- version %ld}}
+} 381 {emit {VAX COFF pure executable}
+if {[N i 12 > 0x0]} {emit {not stripped}}
+if {[N s 22 > 0x0]} {emit {- version %ld}}
+} -155 {emit x.out
+if {[S 2 == __.SYMDEF]} {emit randomized}
+if {[N c 0 x {}]} {emit archive}
+} 518 {emit {Microsoft a.out}
+if {[N s 8 == 0x1]} {emit {Middle model}}
+if {[N s 30 & 0x10]} {emit overlay}
+if {[N s 30 & 0x2]} {emit separate}
+if {[N s 30 & 0x4]} {emit pure}
+if {[N s 30 & 0x800]} {emit segmented}
+if {[N s 30 & 0x400]} {emit standalone}
+if {[N s 30 & 0x8]} {emit fixed-stack}
+if {[N c 28 & 0x80]} {emit byte-swapped}
+if {[N c 28 & 0x40]} {emit word-swapped}
+if {[N i 16 > 0x0]} {emit not-stripped}
+if {[N s 30 ^ 0xc000]} {emit pre-SysV}
+if {[N s 30 & 0x4000]} {emit V2.3}
+if {[N s 30 & 0x8000]} {emit V3.0}
+if {[N c 28 & 0x4]} {emit 86}
+if {[N c 28 & 0xb]} {emit 186}
+if {[N c 28 & 0x9]} {emit 286}
+if {[N c 28 & 0xa]} {emit 386}
+if {[N c 31 < 0x40]} {emit {small model}}
+switch -- [Nv c 31] 72 {emit {large model }} 73 {emit {huge model}}
+if {[N s 30 & 0x1]} {emit executable}
+if {[N s 30 ^ 0x1]} {emit {object file}}
+if {[N s 30 & 0x40]} {emit {Large Text}}
+if {[N s 30 & 0x20]} {emit {Large Data}}
+if {[N s 30 & 0x120]} {emit {Huge Objects Enabled}}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 320 {emit {old Microsoft 8086 x.out}
+if {[N c 3 & 0x4]} {emit separate}
+if {[N c 3 & 0x2]} {emit pure}
+if {[N c 0 & 0x1]} {emit executable}
+if {[N c 0 ^ 0x1]} {emit relocatable}
+if {[N i 20 > 0x0]} {emit {not stripped}}
+} 1408 {emit {XENIX 8086 relocatable or 80286 small model}}
+switch -- [Nv Y 0] 381 {emit {CLIPPER COFF executable \(VAX \#\)}
+switch -- [Nv Y 20] 263 {emit {\(impure\)}} 264 {emit {\(5.2 compatible\)}} 265 {emit {\(pure\)}} 267 {emit {\(demand paged\)}} 291 {emit {\(target shared library\)}}
+if {[N Q 12 > 0x0]} {emit {not stripped}}
+if {[N Y 22 > 0x0]} {emit {- version %ld}}
+} 383 {emit {CLIPPER COFF executable}
+switch -- [Nv Y 18 &074000] 0 {emit {C1 R1}} 2048 {emit {C2 R1}} 4096 {emit {C3 R1}} 30720 {emit TEST}
+switch -- [Nv Y 20] 263 {emit {\(impure\)}} 264 {emit {\(pure\)}} 265 {emit {\(separate I&D\)}} 267 {emit {\(paged\)}} 291 {emit {\(target shared library\)}}
+if {[N Q 12 > 0x0]} {emit {not stripped}}
+if {[N Y 22 > 0x0]} {emit {- version %ld}}
+if {[N Q 48 == 0x1 &01]} {emit {alignment trap enabled}}
+switch -- [Nv c 52] 1 {emit -Ctnc} 2 {emit -Ctsw} 3 {emit -Ctpw} 4 {emit -Ctcb}
+switch -- [Nv c 53] 1 {emit -Cdnc} 2 {emit -Cdsw} 3 {emit -Cdpw} 4 {emit -Cdcb}
+switch -- [Nv c 54] 1 {emit -Csnc} 2 {emit -Cssw} 3 {emit -Cspw} 4 {emit -Cscb}
+} 272 {emit {0420 Alliant virtual executable}
+if {[N Y 2 & 0x20]} {emit {common library}}
+if {[N Q 16 > 0x0]} {emit {not stripped}}
+} 273 {emit {0421 Alliant compact executable}
+if {[N Y 2 & 0x20]} {emit {common library}}
+if {[N Q 16 > 0x0]} {emit {not stripped}}
+} 29127 {emit {cpio archive}} -14479 {emit {byte-swapped cpio archive}} -147 {emit {very old PDP-11 archive}} -155 {emit {old PDP-11 archive}} 1793 {emit {VAX-order 68K Blit \(standalone\) executable}} 262 {emit {VAX-order2 68k Blit mpx/mux executable}} 1537 {emit {VAX-order 68k Blit mpx/mux executable}} 7967 {emit {old packed data}} 8191 {emit {compacted data}} -13563 {emit {huf output}} 1281 {emit {locale data table}
+switch -- [Nv Y 6] 36 {emit {for MIPS}} 64 {emit {for Alpha}}
+} 340 {emit Encore
+switch -- [Nv Y 20] 263 {emit executable} 264 {emit {pure executable}} 267 {emit {demand-paged executable}} 271 {emit {unsupported executable}}
+if {[N Q 12 > 0x0]} {emit {not stripped}}
+if {[N Y 22 > 0x0]} {emit {- version %ld}}
+if {[N Y 22 == 0x0]} {emit -}
+} 341 {emit {Encore unsupported executable}
+if {[N Q 12 > 0x0]} {emit {not stripped}}
+if {[N Y 22 > 0x0]} {emit {- version %ld}}
+if {[N Y 22 == 0x0]} {emit -}
+} 286 {emit {Berkeley vfont data}} 7681 {emit {byte-swapped Berkeley vfont data}} 256 {emit {raw G3 data, byte-padded}} 5120 {emit {raw G3 data}} 373 {emit {i386 COFF object}} 10775 {emit {\"compact bitmap\" format \(Poskanzer\)}} 601 {emit {mumps avl global}
+if {[N c 2 > 0x0]} {emit {\(V%d\)}}
+if {[N c 6 > 0x0]} {emit {with %d byte name}}
+if {[N c 7 > 0x0]} {emit {and %d byte data cells}}
+} 602 {emit {mumps blt global}
+if {[N c 2 > 0x0]} {emit {\(V%d\)}}
+if {[N Y 8 > 0x0]} {emit {- %d byte blocks}}
+switch -- [Nv c 15] 0 {emit {- P/D format}} 1 {emit {- P/K/D format}} 2 {emit {- K/D format}}
+if {[N c 15 > 0x2]} {emit {- Bad Flags}}
+} 10012 {emit {Sendmail frozen configuration}
+if {[S 16 x {}]} {emit {- version %s}}
+} -16162 {emit {Compiled PSI \(v1\) data}} -16166 {emit {Compiled PSI \(v2\) data}
+if {[S 3 x {}]} {emit {\(%s\)}}
+} -21846 {emit {SoftQuad DESC or font file binary}
+if {[N Y 2 > 0x0]} {emit {- version %d}}
+} 283 {emit {Curses screen image}} 284 {emit {Curses screen image}} 263 {emit {unknown machine executable}
+if {[N Y 8 > 0x0]} {emit {not stripped}}
+if {[N c 15 > 0x0]} {emit {- version %ld}}
+} 264 {emit {unknown pure executable}
+if {[N Y 8 > 0x0]} {emit {not stripped}}
+if {[N c 15 > 0x0]} {emit {- version %ld}}
+} 265 {emit {PDP-11 separate I&D}
+if {[N Y 8 > 0x0]} {emit {not stripped}}
+if {[N c 15 > 0x0]} {emit {- version %ld}}
+} 267 {emit {unknown pure executable}
+if {[N Y 8 > 0x0]} {emit {not stripped}}
+if {[N c 15 > 0x0]} {emit {- version %ld}}
+} 392 {emit {Perkin-Elmer executable}} 21845 {emit {VISX image file}
+switch -- [Nv c 2] 0 {emit {\(zero\)}} 1 {emit {\(unsigned char\)}} 2 {emit {\(short integer\)}} 3 {emit {\(float 32\)}} 4 {emit {\(float 64\)}} 5 {emit {\(signed char\)}} 6 {emit {\(bit-plane\)}} 7 {emit {\(classes\)}} 8 {emit {\(statistics\)}} 10 {emit {\(ascii text\)}} 15 {emit {\(image segments\)}} 100 {emit {\(image set\)}} 101 {emit {\(unsigned char vector\)}} 102 {emit {\(short integer vector\)}} 103 {emit {\(float 32 vector\)}} 104 {emit {\(float 64 vector\)}} 105 {emit {\(signed char vector\)}} 106 {emit {\(bit plane vector\)}} 121 {emit {\(feature vector\)}} 122 {emit {\(feature vector library\)}} 124 {emit {\(chain code\)}} 126 {emit {\(bit vector\)}} -126 {emit {\(graph\)}} -125 {emit {\(adjacency graph\)}} -124 {emit {\(adjacency graph library\)}}
+if {[S 2 == .VISIX]} {emit {\(ascii text\)}}
+}
+if {[S 4 == pipe]} {emit {CLIPPER instruction trace}}
+if {[S 4 == prof]} {emit {CLIPPER instruction profile}}
+switch -- [Nv I 0] 1936484385 {emit {Allegro datafile \(packed\)}} 1936484398 {emit {Allegro datafile \(not packed/autodetect\)}} 1936484395 {emit {Allegro datafile \(appended exe data\)}} 1018 {emit {AmigaOS shared library}} 1011 {emit {AmigaOS loadseg\(\)ble executable/binary}} 999 {emit {AmigaOS object/library data}} -2147479551 {emit {AmigaOS outline tag}} 1 {emit {JVT NAL sequence}
+if {[N c 4 == 0x7 &0x1F]} {emit {\b, H.264 video}
+switch -- [Nv c 5] 66 {emit {\b, baseline}} 77 {emit {\b, main}} 88 {emit {\b, extended}}
+if {[N c 7 x {}]} {emit {\b @ L %u}}
+}
+} 807842421 {emit {Microsoft ASF}} 333312 {emit {AppleSingle encoded Macintosh file}} 333319 {emit {AppleDouble encoded Macintosh file}} 1711210496 {emit {VAX 3.0 archive}} 1013019198 {emit {VAX 5.0 archive}} 1314148939 {emit {MultiTrack sound data}
+if {[N I 4 x {}]} {emit {- version %ld}}
+} 779248125 {emit {RealAudio sound file}} 1688404224 {emit {IRCAM file \(VAX\)}} 1688404480 {emit {IRCAM file \(Sun\)}} 1688404736 {emit {IRCAM file \(MIPS little-endian\)}} 1688404992 {emit {IRCAM file \(NeXT\)}} 1125466468 {emit {X64 Image}} -12432129 {emit {WRAptor packer \(c64\)}} 554074152 {emit {Sega Dreamcast VMU game image}} 931151890 {emit {V64 Nintendo 64 ROM dump}} 327 {emit {Convex old-style object}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 331 {emit {Convex old-style demand paged executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 333 {emit {Convex old-style pre-paged executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 335 {emit {Convex old-style pre-paged, non-swapped executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 70231 {emit {Core file}} 385 {emit {Convex SOFF}
+if {[N I 88 == 0x0 &0x000f0000]} {emit c1}
+if {[N I 88 & 0x10000]} {emit c2}
+if {[N I 88 & 0x20000]} {emit c2mp}
+if {[N I 88 & 0x40000]} {emit parallel}
+if {[N I 88 & 0x80000]} {emit intrinsic}
+if {[N I 88 & 0x1]} {emit {demand paged}}
+if {[N I 88 & 0x2]} {emit pre-paged}
+if {[N I 88 & 0x4]} {emit non-swapped}
+if {[N I 88 & 0x8]} {emit POSIX}
+if {[N I 84 & 0x80000000]} {emit executable}
+if {[N I 84 & 0x40000000]} {emit object}
+if {[N I 84 == 0x0 &0x20000000]} {emit {not stripped}}
+switch -- [Nv I 84 &0x18000000] 0 {emit {native fpmode}} 268435456 {emit {ieee fpmode}} 402653184 {emit {undefined fpmode}}
+} 389 {emit {Convex SOFF core}} 391 {emit {Convex SOFF checkpoint}
+if {[N I 88 == 0x0 &0x000f0000]} {emit c1}
+if {[N I 88 & 0x10000]} {emit c2}
+if {[N I 88 & 0x20000]} {emit c2mp}
+if {[N I 88 & 0x40000]} {emit parallel}
+if {[N I 88 & 0x80000]} {emit intrinsic}
+if {[N I 88 & 0x8]} {emit POSIX}
+switch -- [Nv I 84 &0x18000000] 0 {emit {native fpmode}} 268435456 {emit {ieee fpmode}} 402653184 {emit {undefined fpmode}}
+} 324508366 {emit {GNU dbm 1.x or ndbm database, big endian}} 398689 {emit {Berkeley DB}
+switch -- [Nv I 8] 4321 {emit {}
+if {[N I 4 > 0x2]} {emit 1.86}
+if {[N I 4 < 0x3]} {emit 1.85}
+if {[N I 4 > 0x0]} {emit {\(Hash, version %d, big-endian\)}}
+} 1234 {emit {}
+if {[N I 4 > 0x2]} {emit 1.86}
+if {[N I 4 < 0x3]} {emit 1.85}
+if {[N I 4 > 0x0]} {emit {\(Hash, version %d, native byte-order\)}}
+}
+} 340322 {emit {Berkeley DB 1.85/1.86}
+if {[N I 4 > 0x0]} {emit {\(Btree, version %d, big-endian\)}}
+} 9994 {emit {ESRI Shapefile}
+if {[N I 4 == 0x0]} {emit 16 34 0}
+if {[N I 8 == 0x0]} {emit 16 34 1}
+if {[N I 12 == 0x0]} {emit 16 34 2}
+if {[N I 16 == 0x0]} {emit 16 34 3}
+if {[N I 20 == 0x0]} {emit 16 34 4}
+if {[N i 28 x {}]} {emit {version %d}}
+if {[N I 24 x {}]} {emit {length %d}}
+switch -- [Nv i 32] 0 {emit {type Null Shape}} 1 {emit {type Point}} 3 {emit {type PolyLine}} 5 {emit {type Polygon}} 8 {emit {type MultiPoint}} 11 {emit {type PointZ}} 13 {emit {type PolyLineZ}} 15 {emit {type PolygonZ}} 18 {emit {type MultiPointZ}} 21 {emit {type PointM}} 23 {emit {type PolyLineM}} 25 {emit {type PolygonM}} 28 {emit {type MultiPointM}} 31 {emit {type MultiPatch}}
+} 199600449 {emit {SGI disk label \(volume header\)}} 1481003842 {emit {SGI XFS filesystem data}
+if {[N I 4 x {}]} {emit {\(blksz %d,}}
+if {[N S 104 x {}]} {emit {inosz %d,}}
+if {[N S 100 ^ 0x2004]} {emit {v1 dirs\)}}
+if {[N S 100 & 0x2004]} {emit {v2 dirs\)}}
+} 684539205 {emit {Linux Compressed ROM File System data, big endian}
+if {[N I 4 x {}]} {emit {size %d}}
+if {[N I 8 & 0x1]} {emit {version \#2}}
+if {[N I 8 & 0x2]} {emit sorted_dirs}
+if {[N I 8 & 0x4]} {emit hole_support}
+if {[N I 32 x {}]} {emit {CRC 0x%x,}}
+if {[N I 36 x {}]} {emit {edition %d,}}
+if {[N I 40 x {}]} {emit {%d blocks,}}
+if {[N I 44 x {}]} {emit {%d files}}
+} 876099889 {emit {Linux Journalled Flash File system, big endian}} 654645590 {emit {PPCBoot image}
+if {[S 4 == PPCBoot]} {if {[S 12 x {}]} {emit {version %s}}
+}
+} 4 {emit {X11 SNF font data, MSB first}} 335698201 {emit {libGrx font data,}
+if {[N s 8 x {}]} {emit %dx}
+if {[N s 10 x {}]} {emit {\b%d}}
+if {[S 40 x {}]} {emit %s}
+} -12169394 {emit {DOS code page font data collection}} 1279543401 {emit {ld.so hints file \(Big Endian}
+if {[N I 4 > 0x0]} {emit {\b, version %d\)}}
+if {[N I 4 <= 0x0]} {emit {\b\)}}
+} -951729837 {emit GEOS
+switch -- [Nv c 40] 1 {emit executable} 2 {emit VMFile} 3 {emit binary} 4 {emit {directory label}}
+if {[N c 40 < 0x1]} {emit unknown}
+if {[N c 40 > 0x4]} {emit unknown}
+if {[S 4 x {}]} {emit {\b, name \"%s\"}}
+} 235082497 {emit {Hierarchical Data Format \(version 4\) data}} 34603270 {emit {PA-RISC1.1 relocatable object}} 34603271 {emit {PA-RISC1.1 executable}
+if {[N I 168 & 0x4]} {emit {dynamically linked}}
+if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}}
+if {[N I 96 > 0x0]} {emit {- not stripped}}
+} 34603272 {emit {PA-RISC1.1 shared executable}
+if {[N I 168 == 0x4 &0x4]} {emit {dynamically linked}}
+if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}}
+if {[N I 96 > 0x0]} {emit {- not stripped}}
+} 34603275 {emit {PA-RISC1.1 demand-load executable}
+if {[N I 168 == 0x4 &0x4]} {emit {dynamically linked}}
+if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}}
+if {[N I 96 > 0x0]} {emit {- not stripped}}
+} 34603278 {emit {PA-RISC1.1 shared library}
+if {[N I 96 > 0x0]} {emit {- not stripped}}
+} 34603277 {emit {PA-RISC1.1 dynamic load library}
+if {[N I 96 > 0x0]} {emit {- not stripped}}
+} 34865414 {emit {PA-RISC2.0 relocatable object}} 34865415 {emit {PA-RISC2.0 executable}
+if {[N I 168 & 0x4]} {emit {dynamically linked}}
+if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}}
+if {[N I 96 > 0x0]} {emit {- not stripped}}
+} 34865416 {emit {PA-RISC2.0 shared executable}
+if {[N I 168 & 0x4]} {emit {dynamically linked}}
+if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}}
+if {[N I 96 > 0x0]} {emit {- not stripped}}
+} 34865419 {emit {PA-RISC2.0 demand-load executable}
+if {[N I 168 & 0x4]} {emit {dynamically linked}}
+if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}}
+if {[N I 96 > 0x0]} {emit {- not stripped}}
+} 34865422 {emit {PA-RISC2.0 shared library}
+if {[N I 96 > 0x0]} {emit {- not stripped}}
+} 34865421 {emit {PA-RISC2.0 dynamic load library}
+if {[N I 96 > 0x0]} {emit {- not stripped}}
+} 34275590 {emit {PA-RISC1.0 relocatable object}} 34275591 {emit {PA-RISC1.0 executable}
+if {[N I 168 == 0x4 &0x4]} {emit {dynamically linked}}
+if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}}
+if {[N I 96 > 0x0]} {emit {- not stripped}}
+} 34275592 {emit {PA-RISC1.0 shared executable}
+if {[N I 168 == 0x4 &0x4]} {emit {dynamically linked}}
+if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}}
+if {[N I 96 > 0x0]} {emit {- not stripped}}
+} 34275595 {emit {PA-RISC1.0 demand-load executable}
+if {[N I 168 == 0x4 &0x4]} {emit {dynamically linked}}
+if {[N I [I 144 Q 0] == 0x54ef630]} {emit {dynamically linked}}
+if {[N I 96 > 0x0]} {emit {- not stripped}}
+} 34275598 {emit {PA-RISC1.0 shared library}
+if {[N I 96 > 0x0]} {emit {- not stripped}}
+} 34275597 {emit {PA-RISC1.0 dynamic load library}
+if {[N I 96 > 0x0]} {emit {- not stripped}}
+} 557605234 {emit {archive file}
+switch -- [Nv I 68] 34276889 {emit {- PA-RISC1.0 relocatable library}} 34604569 {emit {- PA-RISC1.1 relocatable library}} 34670105 {emit {- PA-RISC1.2 relocatable library}} 34866713 {emit {- PA-RISC2.0 relocatable library}}
+} 34341128 {emit {HP s200 pure executable}
+if {[N S 4 > 0x0]} {emit {- version %ld}}
+if {[N I 8 & 0x80000000]} {emit {save fp regs}}
+if {[N I 8 & 0x40000000]} {emit {dynamically linked}}
+if {[N I 8 & 0x20000000]} {emit debuggable}
+if {[N I 36 > 0x0]} {emit {not stripped}}
+} 34341127 {emit {HP s200 executable}
+if {[N S 4 > 0x0]} {emit {- version %ld}}
+if {[N I 8 & 0x80000000]} {emit {save fp regs}}
+if {[N I 8 & 0x40000000]} {emit {dynamically linked}}
+if {[N I 8 & 0x20000000]} {emit debuggable}
+if {[N I 36 > 0x0]} {emit {not stripped}}
+} 34341131 {emit {HP s200 demand-load executable}
+if {[N S 4 > 0x0]} {emit {- version %ld}}
+if {[N I 8 & 0x80000000]} {emit {save fp regs}}
+if {[N I 8 & 0x40000000]} {emit {dynamically linked}}
+if {[N I 8 & 0x20000000]} {emit debuggable}
+if {[N I 36 > 0x0]} {emit {not stripped}}
+} 34341126 {emit {HP s200 relocatable executable}
+if {[N S 4 > 0x0]} {emit {- version %ld}}
+if {[N S 6 > 0x0]} {emit {- highwater %d}}
+if {[N I 8 & 0x80000000]} {emit {save fp regs}}
+if {[N I 8 & 0x20000000]} {emit debuggable}
+if {[N I 8 & 0x10000000]} {emit PIC}
+} 34210056 {emit {HP s200 \(2.x release\) pure executable}
+if {[N S 4 > 0x0]} {emit {- version %ld}}
+if {[N I 36 > 0x0]} {emit {not stripped}}
+} 34210055 {emit {HP s200 \(2.x release\) executable}
+if {[N S 4 > 0x0]} {emit {- version %ld}}
+if {[N I 36 > 0x0]} {emit {not stripped}}
+} 34341134 {emit {HP s200 shared library}
+if {[N S 4 > 0x0]} {emit {- version %ld}}
+if {[N S 6 > 0x0]} {emit {- highwater %d}}
+if {[N I 36 > 0x0]} {emit {not stripped}}
+} 34341133 {emit {HP s200 dynamic load library}
+if {[N S 4 > 0x0]} {emit {- version %ld}}
+if {[N S 6 > 0x0]} {emit {- highwater %d}}
+if {[N I 36 > 0x0]} {emit {not stripped}}
+} 505 {emit {AIX compiled message catalog}} 1504078485 {emit {Sun raster image data}
+if {[N I 4 > 0x0]} {emit {\b, %d x}}
+if {[N I 8 > 0x0]} {emit %d,}
+if {[N I 12 > 0x0]} {emit %d-bit,}
+switch -- [Nv I 20] 0 {emit {old format,}} 2 {emit compressed,} 3 {emit RGB,} 4 {emit TIFF,} 5 {emit IFF,} 65535 {emit {reserved for testing,}}
+switch -- [Nv I 24] 0 {emit {no colormap}} 1 {emit {RGB colormap}} 2 {emit {raw colormap}}
+} 65544 {emit {GEM Image data}
+if {[N S 12 x {}]} {emit {%d x}}
+if {[N S 14 x {}]} {emit %d,}
+if {[N S 4 x {}]} {emit {%d planes,}}
+if {[N S 8 x {}]} {emit {%d x}}
+if {[N S 10 x {}]} {emit {%d pixelsize}}
+} 235082497 {emit {Hierarchical Data Format \(version 4\) data}} -889275714 {emit {compiled Java class data,}
+if {[N S 6 x {}]} {emit {version %d.}}
+if {[N S 4 x {}]} {emit {\b%d}}
+} -1195374706 {emit {Linux kernel}
+if {[S 483 == Loading]} {emit {version 1.3.79 or older}}
+if {[S 489 == Loading]} {emit {from prehistoric times}}
+} 1330597709 {emit {User-mode Linux COW file}
+if {[N I 4 x {}]} {emit {\b, version %d}}
+if {[S 8 x {}]} {emit {\b, backing file %s}}
+} -1195374706 {emit Linux
+if {[N I 486 == 0x454c4b53]} {emit {ELKS Kernel}}
+if {[N I 486 != 0x454c4b53]} {emit {style boot sector}}
+} -889275714 {emit {Mach-O fat file}
+if {[N I 4 == 0x1]} {emit {with 1 architecture}}
+if {[N I 4 > 0x1]} {if {[N I 4 x {}]} {emit {with %ld architectures }}
+}
+} -17958194 {emit Mach-O
+switch -- [Nv I 12] 1 {emit object} 2 {emit executable} 3 {emit {shared library}} 4 {emit core} 5 {emit {preload executable}} 6 {emit {dynamically linked shared library}} 7 {emit {dynamic linker}} 8 {emit bundle}
+if {[N I 12 > 0x8]} {if {[N I 12 x {}]} {emit filetype=%ld}
+}
+if {[N I 4 < 0x0]} {if {[N I 4 x {}]} {emit architecture=%ld}
+}
+switch -- [Nv I 4] 1 {emit vax} 2 {emit romp} 3 {emit architecture=3} 4 {emit ns32032} 5 {emit ns32332} 6 {emit {for m68k architecture}
+switch -- [Nv I 8] 2 {emit {\(mc68040\)}} 3 {emit {\(mc68030 only\)}}
+} 7 {emit i386} 8 {emit mips} 9 {emit ns32532} 10 {emit architecture=10} 11 {emit {hp pa-risc}} 12 {emit acorn} 13 {emit m88k} 14 {emit sparc} 15 {emit i860-big} 16 {emit i860} 17 {emit rs6000} 18 {emit ppc}
+if {[N I 4 > 0x12]} {if {[N I 4 x {}]} {emit architecture=%ld}
+}
+} -249691108 {emit {magic binary file for file\(1\) cmd}
+if {[N I 4 x {}]} {emit {\(version %d\) \(big endian\)}}
+} 440786851 {emit {}
+if {[N S 5 == 0x4282]} {if {[S 8 == matroska]} {emit {Matroska data}}
+}
+} 263 {emit {old SGI 68020 executable}} 264 {emit {old SGI 68020 pure executable}} 1396917837 {emit {IRIS Showcase file}
+if {[N c 4 x {}]} {emit {- version %ld}}
+} 1413695053 {emit {IRIS Showcase template}
+if {[N c 4 x {}]} {emit {- version %ld}}
+} -559039810 {emit {IRIX Parallel Arena}
+if {[N I 8 > 0x0]} {emit {- version %ld}}
+} -559043152 {emit {IRIX core dump}
+if {[N I 4 == 0x1]} {emit of}
+if {[S 16 x {}]} {emit '%s'}
+} -559043264 {emit {IRIX 64-bit core dump}
+if {[N I 4 == 0x1]} {emit of}
+if {[S 16 x {}]} {emit '%s'}
+} -1161903941 {emit {IRIX N32 core dump}
+if {[N I 4 == 0x1]} {emit of}
+if {[S 16 x {}]} {emit '%s'}
+} 834535424 {emit {Microsoft Word Document}} 6656 {emit {Lotus 1-2-3}
+switch -- [Nv I 4] 1049600 {emit {wk3 document data}} 34604032 {emit {wk4 document data}} 125829376 {emit {fm3 or fmb document data}} 125829120 {emit {fm3 or fmb document data}}
+} 512 {emit {Lotus 1-2-3}
+switch -- [Nv I 4] 100926976 {emit {wk1 document data}} 109052416 {emit {fmt document data}}
+} -976170042 {emit {DOS EPS Binary File}
+if {[N Q 4 > 0x0]} {emit {Postscript starts at byte %d}
+if {[N Q 8 > 0x0]} {emit {length %d}
+if {[N Q 12 > 0x0]} {emit {Metafile starts at byte %d}
+if {[N Q 16 > 0x0]} {emit {length %d}}
+}
+if {[N Q 20 > 0x0]} {emit {TIFF starts at byte %d}
+if {[N Q 24 > 0x0]} {emit {length %d}}
+}
+}
+}
+} 263 {emit {a.out NetBSD big-endian object file}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 326773060 {emit {NeWS bitmap font}} 326773063 {emit {NeWS font family}} 326773072 {emit {scalable OpenFont binary}} 326773073 {emit {encrypted scalable OpenFont binary}} 263 {emit {Plan 9 executable, Motorola 68k}} 491 {emit {Plan 9 executable, Intel 386}} 583 {emit {Plan 9 executable, Intel 960}} 683 {emit {Plan 9 executable, SPARC}} 1031 {emit {Plan 9 executable, MIPS R3000}} 1163 {emit {Plan 9 executable, AT&T DSP 3210}} 1303 {emit {Plan 9 executable, MIPS R4000 BE}} 1451 {emit {Plan 9 executable, AMD 29000}} 1607 {emit {Plan 9 executable, ARM 7-something}} 1771 {emit {Plan 9 executable, PowerPC}} 1943 {emit {Plan 9 executable, MIPS R4000 LE}} 2123 {emit {Plan 9 executable, DEC Alpha}} -976170042 {emit {DOS EPS Binary File}
+if {[N Q 4 > 0x0]} {emit {Postscript starts at byte %d}
+if {[N Q 8 > 0x0]} {emit {length %d}
+if {[N Q 12 > 0x0]} {emit {Metafile starts at byte %d}
+if {[N Q 16 > 0x0]} {emit {length %d}}
+}
+if {[N Q 20 > 0x0]} {emit {TIFF starts at byte %d}
+if {[N Q 24 > 0x0]} {emit {length %d}}
+}
+}
+}
+} 518517022 {emit {Pulsar POP3 daemon mailbox cache file.}
+if {[N I 4 x {}]} {emit {Version: %d.}}
+if {[N I 8 x {}]} {emit {\b%d}}
+} -1722938102 {emit {python 1.5/1.6 byte-compiled}} -2017063670 {emit {python 2.0 byte-compiled}} 720047370 {emit {python 2.1 byte-compiled}} 770510090 {emit {python 2.2 byte-compiled}} 1005718794 {emit {python 2.3 byte-compiled}} 1257963521 {emit {QL plugin-ROM data,}
+if {[S 9 == {\0} p]} {emit un-named}
+if {[S 9 x {} p]} {emit {named: %s}}
+} -1582119980 {emit {tcpdump capture file \(big-endian\)}
+if {[N S 4 x {}]} {emit {- version %d}}
+if {[N S 6 x {}]} {emit {\b.%d}}
+switch -- [Nv I 20] 0 {emit {\(No link-layer encapsulation}} 1 {emit {\(Ethernet}} 2 {emit {\(3Mb Ethernet}} 3 {emit {\(AX.25}} 4 {emit {\(ProNET}} 5 {emit {\(CHAOS}} 6 {emit {\(Token Ring}} 7 {emit {\(BSD ARCNET}} 8 {emit {\(SLIP}} 9 {emit {\(PPP}} 10 {emit {\(FDDI}} 11 {emit {\(RFC 1483 ATM}} 12 {emit {\(raw IP}} 13 {emit {\(BSD/OS SLIP}} 14 {emit {\(BSD/OS PPP}} 19 {emit {\(Linux ATM Classical IP}} 50 {emit {\(PPP or Cisco HDLC}} 51 {emit {\(PPP-over-Ethernet}} 99 {emit {\(Symantec Enterprise Firewall}} 100 {emit {\(RFC 1483 ATM}} 101 {emit {\(raw IP}} 102 {emit {\(BSD/OS SLIP}} 103 {emit {\(BSD/OS PPP}} 104 {emit {\(BSD/OS Cisco HDLC}} 105 {emit {\(802.11}} 106 {emit {\(Linux Classical IP over ATM}} 107 {emit {\(Frame Relay}} 108 {emit {\(OpenBSD loopback}} 109 {emit {\(OpenBSD IPsec encrypted}} 112 {emit {\(Cisco HDLC}} 113 {emit {\(Linux \"cooked\"}} 114 {emit {\(LocalTalk}} 117 {emit {\(OpenBSD PFLOG}} 119 {emit {\(802.11 with Prism header}} 122 {emit {\(RFC 2625 IP over Fibre Channel}} 123 {emit {\(SunATM}} 127 {emit {\(802.11 with radiotap header}} 129 {emit {\(Linux ARCNET}} 138 {emit {\(Apple IP over IEEE 1394}} 140 {emit {\(MTP2}} 141 {emit {\(MTP3}} 143 {emit {\(DOCSIS}} 144 {emit {\(IrDA}} 147 {emit {\(Private use 0}} 148 {emit {\(Private use 1}} 149 {emit {\(Private use 2}} 150 {emit {\(Private use 3}} 151 {emit {\(Private use 4}} 152 {emit {\(Private use 5}} 153 {emit {\(Private use 6}} 154 {emit {\(Private use 7}} 155 {emit {\(Private use 8}} 156 {emit {\(Private use 9}} 157 {emit {\(Private use 10}} 158 {emit {\(Private use 11}} 159 {emit {\(Private use 12}} 160 {emit {\(Private use 13}} 161 {emit {\(Private use 14}} 162 {emit {\(Private use 15}} 163 {emit {\(802.11 with AVS header}}
+if {[N I 16 x {}]} {emit {\b, capture length %d\)}}
+} -1582117580 {emit {extended tcpdump capture file \(big-endian\)}
+if {[N S 4 x {}]} {emit {- version %d}}
+if {[N S 6 x {}]} {emit {\b.%d}}
+switch -- [Nv I 20] 0 {emit {\(No link-layer encapsulation}} 1 {emit {\(Ethernet}} 2 {emit {\(3Mb Ethernet}} 3 {emit {\(AX.25}} 4 {emit {\(ProNET}} 5 {emit {\(CHAOS}} 6 {emit {\(Token Ring}} 7 {emit {\(ARCNET}} 8 {emit {\(SLIP}} 9 {emit {\(PPP}} 10 {emit {\(FDDI}} 11 {emit {\(RFC 1483 ATM}} 12 {emit {\(raw IP}} 13 {emit {\(BSD/OS SLIP}} 14 {emit {\(BSD/OS PPP}}
+if {[N I 16 x {}]} {emit {\b, capture length %d\)}}
+} 263 {emit {old sun-2 executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 264 {emit {old sun-2 pure executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 267 {emit {old sun-2 demand paged executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 525398 {emit {SunOS core file}
+switch -- [Nv I 4] 432 {emit {\(SPARC\)}
+if {[S 132 x {}]} {emit {from '%s'}}
+switch -- [Nv I 116] 3 {emit {\(quit\)}} 4 {emit {\(illegal instruction\)}} 5 {emit {\(trace trap\)}} 6 {emit {\(abort\)}} 7 {emit {\(emulator trap\)}} 8 {emit {\(arithmetic exception\)}} 9 {emit {\(kill\)}} 10 {emit {\(bus error\)}} 11 {emit {\(segmentation violation\)}} 12 {emit {\(bad argument to system call\)}} 29 {emit {\(resource lost\)}}
+if {[N I 120 x {}]} {emit {\(T=%dK,}}
+if {[N I 124 x {}]} {emit D=%dK,}
+if {[N I 128 x {}]} {emit {S=%dK\)}}
+} 826 {emit {\(68K\)}
+if {[S 128 x {}]} {emit {from '%s'}}
+} 456 {emit {\(SPARC 4.x BCP\)}
+if {[S 152 x {}]} {emit {from '%s'}}
+}
+} 50331648 {emit {VMS Alpha executable}
+if {[S 75264 == {PK\003\004}]} {emit {\b, Info-ZIP SFX archive v5.12 w/decryption}}
+} 1297241678 {emit {VMware nvram}} 1129273156 {emit VMware
+switch -- [Nv c 4] 3 {emit {virtual disk}
+if {[N i 32 x {}]} {emit {\(%d/}}
+if {[N i 36 x {}]} {emit {\b%d/}}
+if {[N i 40 x {}]} {emit {\b%d\)}}
+} 2 {emit {undoable disk}
+if {[S 32 x {}]} {emit {\(%s\)}}
+}
+}
+if {[S 0 == {Core\001}]} {emit {Alpha COFF format core dump \(Digital UNIX\)}
+if {[S 24 x {}]} {emit {\b, from '%s'}}
+}
+if {[S 0 == {Core\002}]} {emit {Alpha COFF format core dump \(Digital UNIX\)}
+if {[S 24 x {}]} {emit {\b, from '%s'}}
+}
+if {[S 0 == {AMANDA:\ }]} {emit AMANDA
+if {[S 8 == {TAPESTART\ DATE}]} {emit {tape header file,}
+if {[S 23 == X]} {if {[S 25 > {\ }]} {emit {Unused %s}}
+}
+if {[S 23 > {\ }]} {emit {DATE %s}}
+}
+if {[S 8 == {FILE\ }]} {emit {dump file,}
+if {[S 13 > {\ }]} {emit {DATE %s}}
+}
+}
+if {[S 0 == FC14]} {emit {Future Composer 1.4 Module sound file}}
+if {[S 0 == SMOD]} {emit {Future Composer 1.3 Module sound file}}
+if {[S 0 == AON4artofnoise]} {emit {Art Of Noise Module sound file}}
+if {[S 1 == MUGICIAN/SOFTEYES]} {emit {Mugician Module sound file}}
+if {[S 58 == {SIDMON\ II\ -\ THE}]} {emit {Sidmon 2.0 Module sound file}}
+if {[S 0 == Synth4.0]} {emit {Synthesis Module sound file}}
+if {[S 0 == ARP.]} {emit {The Holy Noise Module sound file}}
+if {[S 0 == {BeEp\0}]} {emit {JamCracker Module sound file}}
+if {[S 0 == {COSO\0}]} {emit {Hippel-COSO Module sound file}}
+if {[S 0 == {\#\#\ version}]} {emit {catalog translation}}
+if {[S 0 == RDSK]} {emit {Rigid Disk Block}
+if {[S 160 x {}]} {emit {on %.24s}}
+}
+if {[S 0 == {DOS\0}]} {emit {Amiga DOS disk}}
+if {[S 0 == {DOS\1}]} {emit {Amiga FFS disk}}
+if {[S 0 == {DOS\2}]} {emit {Amiga Inter DOS disk}}
+if {[S 0 == {DOS\3}]} {emit {Amiga Inter FFS disk}}
+if {[S 0 == {DOS\4}]} {emit {Amiga Fastdir DOS disk}}
+if {[S 0 == {DOS\5}]} {emit {Amiga Fastdir FFS disk}}
+if {[S 0 == KICK]} {emit {Kickstart disk}}
+if {[S 0 == MOVI]} {emit {Silicon Graphics movie file}}
+if {[S 4 == moov]} {emit {Apple QuickTime}
+if {[S 12 == mvhd]} {emit {\b movie \(fast start\)}}
+if {[S 12 == mdra]} {emit {\b URL}}
+if {[S 12 == cmov]} {emit {\b movie \(fast start, compressed header\)}}
+if {[S 12 == rmra]} {emit {\b multiple URLs}}
+}
+if {[S 4 == mdat]} {emit {Apple QuickTime movie \(unoptimized\)}}
+if {[S 4 == wide]} {emit {Apple QuickTime movie \(unoptimized\)}}
+if {[S 4 == skip]} {emit {Apple QuickTime movie \(modified\)}}
+if {[S 4 == free]} {emit {Apple QuickTime movie \(modified\)}}
+if {[S 4 == idsc]} {emit {Apple QuickTime image \(fast start\)}}
+if {[S 4 == idat]} {emit {Apple QuickTime image \(unoptimized\)}}
+if {[S 4 == pckg]} {emit {Apple QuickTime compressed archive}}
+if {[S 4 == jP B]} {emit {JPEG 2000 image}}
+if {[S 4 == ftyp]} {emit {ISO Media}
+if {[S 8 == isom]} {emit {\b, MPEG v4 system, version 1}}
+if {[S 8 == iso2]} {emit {\b, MPEG v4 system, part 12 revision}}
+if {[S 8 == mp41]} {emit {\b, MPEG v4 system, version 1}}
+if {[S 8 == mp42]} {emit {\b, MPEG v4 system, version 2}}
+if {[S 8 == mp7t]} {emit {\b, MPEG v4 system, MPEG v7 XML}}
+if {[S 8 == mp7b]} {emit {\b, MPEG v4 system, MPEG v7 binary XML}}
+if {[S 8 == jp2 B]} {emit {\b, JPEG 2000}}
+if {[S 8 == 3gp]} {emit {\b, MPEG v4 system, 3GPP}
+switch -- [Nv c 11] 4 {emit {\b v4 \(H.263/AMR GSM 6.10\)}} 5 {emit {\b v5 \(H.263/AMR GSM 6.10\)}} 6 {emit {\b v6 \(ITU H.264/AMR GSM 6.10\)}}
+}
+if {[S 8 == mmp4]} {emit {\b, MPEG v4 system, 3GPP Mobile}}
+if {[S 8 == avc1]} {emit {\b, MPEG v4 system, 3GPP JVT AVC}}
+if {[S 8 == M4A B]} {emit {\b, MPEG v4 system, iTunes AAC-LC}}
+if {[S 8 == M4P B]} {emit {\b, MPEG v4 system, iTunes AES encrypted}}
+if {[S 8 == M4B B]} {emit {\b, MPEG v4 system, iTunes bookmarked}}
+if {[S 8 == qt B]} {emit {\b, Apple QuickTime movie}}
+}
+if {[N I 0 == 0x100 &0xFFFFFF00]} {emit {MPEG sequence}
+switch -- [Nv c 3] -70 {emit {}
+if {[N c 4 & 0x40]} {emit {\b, v2, program multiplex}}
+if {[N c 4 ^ 0x40]} {emit {\b, v1, system multiplex}}
+} -69 {emit {\b, v1/2, multiplex \(missing pack header\)}} -80 {emit {\b, v4}
+if {[N I 5 == 0x1b5]} {if {[N c 9 & 0x80]} {switch -- [Nv c 10 &0xF0] 16 {emit {\b, video}} 32 {emit {\b, still texture}} 48 {emit {\b, mesh}} 64 {emit {\b, face}}
+}
+switch -- [Nv c 9 &0xF8] 8 {emit {\b, video}} 16 {emit {\b, still texture}} 24 {emit {\b, mesh}} 32 {emit {\b, face}}
+}
+switch -- [Nv c 4] 1 {emit {\b, simple @ L1}} 2 {emit {\b, simple @ L2}} 3 {emit {\b, simple @ L3}} 4 {emit {\b, simple @ L0}} 17 {emit {\b, simple scalable @ L1}} 18 {emit {\b, simple scalable @ L2}} 33 {emit {\b, core @ L1}} 34 {emit {\b, core @ L2}} 50 {emit {\b, main @ L2}} 51 {emit {\b, main @ L3}} 53 {emit {\b, main @ L4}} 66 {emit {\b, n-bit @ L2}} 81 {emit {\b, scalable texture @ L1}} 97 {emit {\b, simple face animation @ L1}} 98 {emit {\b, simple face animation @ L2}} 99 {emit {\b, simple face basic animation @ L1}} 100 {emit {\b, simple face basic animation @ L2}} 113 {emit {\b, basic animation text @ L1}} 114 {emit {\b, basic animation text @ L2}} -127 {emit {\b, hybrid @ L1}} -126 {emit {\b, hybrid @ L2}} -111 {emit {\b, advanced RT simple @ L!}} -110 {emit {\b, advanced RT simple @ L2}} -109 {emit {\b, advanced RT simple @ L3}} -108 {emit {\b, advanced RT simple @ L4}} -95 {emit {\b, core scalable @ L1}} -94 {emit {\b, core scalable @ L2}} -93 {emit {\b, core scalable @ L3}} -79 {emit {\b, advanced coding efficiency @ L1}} -78 {emit {\b, advanced coding efficiency @ L2}} -77 {emit {\b, advanced coding efficiency @ L3}} -76 {emit {\b, advanced coding efficiency @ L4}} -63 {emit {\b, advanced core @ L1}} -62 {emit {\b, advanced core @ L2}} -47 {emit {\b, advanced scalable texture @ L1}} -46 {emit {\b, advanced scalable texture @ L2}} -45 {emit {\b, advanced scalable texture @ L3}} -31 {emit {\b, simple studio @ L1}} -30 {emit {\b, simple studio @ L2}} -29 {emit {\b, simple studio @ L3}} -28 {emit {\b, simple studio @ L4}} -27 {emit {\b, core studio @ L1}} -26 {emit {\b, core studio @ L2}} -25 {emit {\b, core studio @ L3}} -24 {emit {\b, core studio @ L4}} -16 {emit {\b, advanced simple @ L0}} -15 {emit {\b, advanced simple @ L1}} -14 {emit {\b, advanced simple @ L2}} -13 {emit {\b, advanced simple @ L3}} -12 {emit {\b, advanced simple @ L4}} -11 {emit {\b, advanced simple @ L5}} -9 {emit {\b, advanced simple @ L3b}} -8 {emit {\b, FGS @ L0}} -7 {emit {\b, FGS @ L1}} -6 {emit {\b, FGS @ L2}} -5 {emit {\b, FGS @ L3}} -4 {emit {\b, FGS @ L4}} -3 {emit {\b, FGS @ L5}}
+} -75 {emit {\b, v4}
+if {[N c 4 & 0x80]} {switch -- [Nv c 5 &0xF0] 16 {emit {\b, video \(missing profile header\)}} 32 {emit {\b, still texture \(missing profile header\)}} 48 {emit {\b, mesh \(missing profile header\)}} 64 {emit {\b, face \(missing profile header\)}}
+}
+switch -- [Nv c 4 &0xF8] 8 {emit {\b, video \(missing profile header\)}} 16 {emit {\b, still texture \(missing profile header\)}} 24 {emit {\b, mesh \(missing profile header\)}} 32 {emit {\b, face \(missing profile header\)}}
+} -77 {emit {}
+switch -- [Nv I 12] 440 {emit {\b, v1, progressive Y'CbCr 4:2:0 video}} 434 {emit {\b, v1, progressive Y'CbCr 4:2:0 video}} 437 {emit {\b, v2,}
+switch -- [Nv c 16 &0x0F] 1 {emit {\b HP}} 2 {emit {\b Spt}} 3 {emit {\b SNR}} 4 {emit {\b MP}} 5 {emit {\b SP}}
+switch -- [Nv c 17 &0xF0] 64 {emit {\b@HL}} 96 {emit {\b@H-14}} -128 {emit {\b@ML}} -96 {emit {\b@LL}}
+if {[N c 17 & 0x8]} {emit {\b progressive}}
+if {[N c 17 ^ 0x8]} {emit {\b interlaced}}
+switch -- [Nv c 17 &0x06] 2 {emit {\b Y'CbCr 4:2:0 video}} 4 {emit {\b Y'CbCr 4:2:2 video}} 6 {emit {\b Y'CbCr 4:4:4 video}}
+}
+if {[N c 11 & 0x2]} {if {[N c 75 & 0x1]} {switch -- [Nv I 140] 440 {emit {\b, v1, progressive Y'CbCr 4:2:0 video}} 434 {emit {\b, v1, progressive Y'CbCr 4:2:0 video}} 437 {emit {\b, v2,}
+switch -- [Nv c 144 &0x0F] 1 {emit {\b HP}} 2 {emit {\b Spt}} 3 {emit {\b SNR}} 4 {emit {\b MP}} 5 {emit {\b SP}}
+switch -- [Nv c 145 &0xF0] 64 {emit {\b@HL}} 96 {emit {\b@H-14}} -128 {emit {\b@ML}} -96 {emit {\b@LL}}
+if {[N c 145 & 0x8]} {emit {\b progressive}}
+if {[N c 145 ^ 0x8]} {emit {\b interlaced}}
+switch -- [Nv c 145 &0x06] 2 {emit {\b Y'CbCr 4:2:0 video}} 4 {emit {\b Y'CbCr 4:2:2 video}} 6 {emit {\b Y'CbCr 4:4:4 video}}
+}
+}
+}
+switch -- [Nv I 76] 440 {emit {\b, v1, progressive Y'CbCr 4:2:0 video}} 434 {emit {\b, v1, progressive Y'CbCr 4:2:0 video}} 437 {emit {\b, v2,}
+switch -- [Nv c 80 &0x0F] 1 {emit {\b HP}} 2 {emit {\b Spt}} 3 {emit {\b SNR}} 4 {emit {\b MP}} 5 {emit {\b SP}}
+switch -- [Nv c 81 &0xF0] 64 {emit {\b@HL}} 96 {emit {\b@H-14}} -128 {emit {\b@ML}} -96 {emit {\b@LL}}
+if {[N c 81 & 0x8]} {emit {\b progressive}}
+if {[N c 81 ^ 0x8]} {emit {\b interlaced}}
+switch -- [Nv c 81 &0x06] 2 {emit {\b Y'CbCr 4:2:0 video}} 4 {emit {\b Y'CbCr 4:2:2 video}} 6 {emit {\b Y'CbCr 4:4:4 video}}
+}
+switch -- [Nv I 4 &0xFFFFFF00] 2013542400 {emit {\b, HD-TV 1920P}
+if {[N c 7 == 0x10 &0xF0]} {emit {\b, 16:9}}
+} 1342188800 {emit {\b, SD-TV 1280I}
+if {[N c 7 == 0x10 &0xF0]} {emit {\b, 16:9}}
+} 805453824 {emit {\b, PAL Capture}
+if {[N c 7 == 0x10 &0xF0]} {emit {\b, 4:3}}
+} 671211520 {emit {\b, LD-TV 640P}
+if {[N c 7 == 0x10 &0xF0]} {emit {\b, 4:3}}
+} 335605760 {emit {\b, 320x240}
+if {[N c 7 == 0x10 &0xF0]} {emit {\b, 4:3}}
+} 251699200 {emit {\b, 240x160}
+if {[N c 7 == 0x10 &0xF0]} {emit {\b, 4:3}}
+} 167802880 {emit {\b, 160x120}
+if {[N c 7 == 0x10 &0xF0]} {emit {\b, 4:3}}
+}
+switch -- [Nv S 4 &0xFFF0] 11264 {emit {\b, 4CIF}
+switch -- [Nv S 5 &0x0FFF] 480 {emit {\b NTSC}} 576 {emit {\b PAL}}
+switch -- [Nv c 7 &0xF0] 32 {emit {\b, 4:3}} 48 {emit {\b, 16:9}} 64 {emit {\b, 11:5}} -128 {emit {\b, PAL 4:3}} -64 {emit {\b, NTSC 4:3}}
+} 5632 {emit {\b, CIF}
+switch -- [Nv S 5 &0x0FFF] 240 {emit {\b NTSC}} 288 {emit {\b PAL}} 576 {emit {\b PAL 625}
+switch -- [Nv c 7 &0xF0] 32 {emit {\b, 4:3}} 48 {emit {\b, 16:9}} 64 {emit {\b, 11:5}}
+}
+switch -- [Nv c 7 &0xF0] 32 {emit {\b, 4:3}} 48 {emit {\b, 16:9}} 64 {emit {\b, 11:5}} -128 {emit {\b, PAL 4:3}} -64 {emit {\b, NTSC 4:3}}
+} 11520 {emit {\b, CCIR/ITU}
+switch -- [Nv S 5 &0x0FFF] 480 {emit {\b NTSC 525}} 576 {emit {\b PAL 625}}
+switch -- [Nv c 7 &0xF0] 32 {emit {\b, 4:3}} 48 {emit {\b, 16:9}} 64 {emit {\b, 11:5}}
+} 7680 {emit {\b, SVCD}
+switch -- [Nv S 5 &0x0FFF] 480 {emit {\b NTSC 525}} 576 {emit {\b PAL 625}}
+switch -- [Nv c 7 &0xF0] 32 {emit {\b, 4:3}} 48 {emit {\b, 16:9}} 64 {emit {\b, 11:5}}
+}
+switch -- [Nv c 7 &0x0F] 1 {emit {\b, 23.976 fps}} 2 {emit {\b, 24 fps}} 3 {emit {\b, 25 fps}} 4 {emit {\b, 29.97 fps}} 5 {emit {\b, 30 fps}} 6 {emit {\b, 50 fps}} 7 {emit {\b, 59.94 fps}} 8 {emit {\b, 60 fps}}
+if {[N c 11 & 0x4]} {emit {\b, Constrained}}
+}
+if {[N c 3 == 0x7 &0x1F]} {emit {\b, H.264 video}
+switch -- [Nv c 4] 66 {emit {\b, baseline}} 77 {emit {\b, main}} 88 {emit {\b, extended}}
+if {[N c 6 x {}]} {emit {\b @ L %u}}
+}
+}
+switch -- [Nv S 0 &0xFFFE] -6 {emit {MPEG ADTS, layer III, v1}
+switch -- [Nv c 2 &0xF0] 16 {emit {\b, 32 kBits}} 32 {emit {\b, 40 kBits}} 48 {emit {\b, 48 kBits}} 64 {emit {\b, 56 kBits}} 80 {emit {\b, 64 kBits}} 96 {emit {\b, 80 kBits}} 112 {emit {\b, 96 kBits}} -128 {emit {\b, 112 kBits}} -112 {emit {\b, 128 kBits}} -96 {emit {\b, 160 kBits}} -80 {emit {\b, 192 kBits}} -64 {emit {\b, 224 kBits}} -48 {emit {\b, 256 kBits}} -32 {emit {\b, 320 kBits}}
+switch -- [Nv c 2 &0x0C] 0 {emit {\b, 44.1 kHz}} 4 {emit {\b, 48 kHz}} 8 {emit {\b, 32 kHz}}
+switch -- [Nv c 3 &0xC0] 0 {emit {\b, Stereo}} 64 {emit {\b, JntStereo}} -128 {emit {\b, 2x Monaural}} -64 {emit {\b, Monaural}}
+} -4 {emit {MPEG ADTS, layer II, v1}
+switch -- [Nv c 2 &0xF0] 16 {emit {\b, 32 kBits}} 32 {emit {\b, 48 kBits}} 48 {emit {\b, 56 kBits}} 64 {emit {\b, 64 kBits}} 80 {emit {\b, 80 kBits}} 96 {emit {\b, 96 kBits}} 112 {emit {\b, 112 kBits}} -128 {emit {\b, 128 kBits}} -112 {emit {\b, 160 kBits}} -96 {emit {\b, 192 kBits}} -80 {emit {\b, 224 kBits}} -64 {emit {\b, 256 kBits}} -48 {emit {\b, 320 kBits}} -32 {emit {\b, 384 kBits}}
+switch -- [Nv c 2 &0x0C] 0 {emit {\b, 44.1 kHz}} 4 {emit {\b, 48 kHz}} 8 {emit {\b, 32 kHz}}
+switch -- [Nv c 3 &0xC0] 0 {emit {\b, Stereo}} 64 {emit {\b, JntStereo}} -128 {emit {\b, 2x Monaural}} -64 {emit {\b, Monaural}}
+} -2 {emit {MPEG ADTS, layer I, v1}
+switch -- [Nv c 2 &0xF0] 16 {emit {\b, 32 kBits}} 32 {emit {\b, 64 kBits}} 48 {emit {\b, 96 kBits}} 64 {emit {\b, 128 kBits}} 80 {emit {\b, 160 kBits}} 96 {emit {\b, 192 kBits}} 112 {emit {\b, 224 kBits}} -128 {emit {\b, 256 kBits}} -112 {emit {\b, 288 kBits}} -96 {emit {\b, 320 kBits}} -80 {emit {\b, 352 kBits}} -64 {emit {\b, 384 kBits}} -48 {emit {\b, 416 kBits}} -32 {emit {\b, 448 kBits}}
+switch -- [Nv c 2 &0x0C] 0 {emit {\b, 44.1 kHz}} 4 {emit {\b, 48 kHz}} 8 {emit {\b, 32 kHz}}
+switch -- [Nv c 3 &0xC0] 0 {emit {\b, Stereo}} 64 {emit {\b, JntStereo}} -128 {emit {\b, 2x Monaural}} -64 {emit {\b, Monaural}}
+} -14 {emit {MPEG ADTS, layer III, v2}
+switch -- [Nv c 2 &0xF0] 16 {emit {\b, 8 kBits}} 32 {emit {\b, 16 kBits}} 48 {emit {\b, 24 kBits}} 64 {emit {\b, 32 kBits}} 80 {emit {\b, 40 kBits}} 96 {emit {\b, 48 kBits}} 112 {emit {\b, 56 kBits}} -128 {emit {\b, 64 kBits}} -112 {emit {\b, 80 kBits}} -96 {emit {\b, 96 kBits}} -80 {emit {\b, 112 kBits}} -64 {emit {\b, 128 kBits}} -48 {emit {\b, 144 kBits}} -32 {emit {\b, 160 kBits}}
+switch -- [Nv c 2 &0x0C] 0 {emit {\b, 22.05 kHz}} 4 {emit {\b, 24 kHz}} 8 {emit {\b, 16 kHz}}
+switch -- [Nv c 3 &0xC0] 0 {emit {\b, Stereo}} 64 {emit {\b, JntStereo}} -128 {emit {\b, 2x Monaural}} -64 {emit {\b, Monaural}}
+} -12 {emit {MPEG ADTS, layer II, v2}
+switch -- [Nv c 2 &0xF0] 16 {emit {\b, 8 kBits}} 32 {emit {\b, 16 kBits}} 48 {emit {\b, 24 kBits}} 64 {emit {\b, 32 kBits}} 80 {emit {\b, 40 kBits}} 96 {emit {\b, 48 kBits}} 112 {emit {\b, 56 kBits}} -128 {emit {\b, 64 kBits}} -112 {emit {\b, 80 kBits}} -96 {emit {\b, 96 kBits}} -80 {emit {\b, 112 kBits}} -64 {emit {\b, 128 kBits}} -48 {emit {\b, 144 kBits}} -32 {emit {\b, 160 kBits}}
+switch -- [Nv c 2 &0x0C] 0 {emit {\b, 22.05 kHz}} 4 {emit {\b, 24 kHz}} 8 {emit {\b, 16 kHz}}
+switch -- [Nv c 3 &0xC0] 0 {emit {\b, Stereo}} 64 {emit {\b, JntStereo}} -128 {emit {\b, 2x Monaural}} -64 {emit {\b, Monaural}}
+} -10 {emit {MPEG ADTS, layer I, v2}
+switch -- [Nv c 2 &0xF0] 16 {emit {\b, 32 kBits}} 32 {emit {\b, 48 kBits}} 48 {emit {\b, 56 kBits}} 64 {emit {\b, 64 kBits}} 80 {emit {\b, 80 kBits}} 96 {emit {\b, 96 kBits}} 112 {emit {\b, 112 kBits}} -128 {emit {\b, 128 kBits}} -112 {emit {\b, 144 kBits}} -96 {emit {\b, 160 kBits}} -80 {emit {\b, 176 kBits}} -64 {emit {\b, 192 kBits}} -48 {emit {\b, 224 kBits}} -32 {emit {\b, 256 kBits}}
+switch -- [Nv c 2 &0x0C] 0 {emit {\b, 22.05 kHz}} 4 {emit {\b, 24 kHz}} 8 {emit {\b, 16 kHz}}
+switch -- [Nv c 3 &0xC0] 0 {emit {\b, Stereo}} 64 {emit {\b, JntStereo}} -128 {emit {\b, 2x Monaural}} -64 {emit {\b, Monaural}}
+} -30 {emit {MPEG ADTS, layer III, v2.5}
+switch -- [Nv c 2 &0xF0] 16 {emit {\b, 8 kBits}} 32 {emit {\b, 16 kBits}} 48 {emit {\b, 24 kBits}} 64 {emit {\b, 32 kBits}} 80 {emit {\b, 40 kBits}} 96 {emit {\b, 48 kBits}} 112 {emit {\b, 56 kBits}} -128 {emit {\b, 64 kBits}} -112 {emit {\b, 80 kBits}} -96 {emit {\b, 96 kBits}} -80 {emit {\b, 112 kBits}} -64 {emit {\b, 128 kBits}} -48 {emit {\b, 144 kBits}} -32 {emit {\b, 160 kBits}}
+switch -- [Nv c 2 &0x0C] 0 {emit {\b, 11.025 kHz}} 4 {emit {\b, 12 kHz}} 8 {emit {\b, 8 kHz}}
+switch -- [Nv c 3 &0xC0] 0 {emit {\b, Stereo}} 64 {emit {\b, JntStereo}} -128 {emit {\b, 2x Monaural}} -64 {emit {\b, Monaural}}
+}
+if {[S 0 == ADIF]} {emit {MPEG ADIF, AAC}
+if {[N c 4 & 0x80]} {if {[N c 13 & 0x10]} {emit {\b, VBR}}
+if {[N c 13 ^ 0x10]} {emit {\b, CBR}}
+switch -- [Nv c 16 &0x1E] 2 {emit {\b, single stream}} 4 {emit {\b, 2 streams}} 6 {emit {\b, 3 streams}}
+if {[N c 16 & 0x8]} {emit {\b, 4 or more streams}}
+if {[N c 16 & 0x10]} {emit {\b, 8 or more streams}}
+if {[N c 4 & 0x80]} {emit {\b, Copyrighted}}
+if {[N c 13 & 0x40]} {emit {\b, Original Source}}
+if {[N c 13 & 0x20]} {emit {\b, Home Flag}}
+}
+if {[N c 4 ^ 0x80]} {if {[N c 4 & 0x10]} {emit {\b, VBR}}
+if {[N c 4 ^ 0x10]} {emit {\b, CBR}}
+switch -- [Nv c 7 &0x1E] 2 {emit {\b, single stream}} 4 {emit {\b, 2 streams}} 6 {emit {\b, 3 streams}}
+if {[N c 7 & 0x8]} {emit {\b, 4 or more streams}}
+if {[N c 7 & 0x10]} {emit {\b, 8 or more streams}}
+if {[N c 4 & 0x40]} {emit {\b, Original Stream\(s\)}}
+if {[N c 4 & 0x20]} {emit {\b, Home Source}}
+}
+}
+if {[N S 0 == 0xfff0 &0xFFF6]} {emit {MPEG ADTS, AAC}
+if {[N c 1 & 0x8]} {emit {\b, v2}}
+if {[N c 1 ^ 0x8]} {emit {\b, v4}
+if {[N c 2 & 0xc0]} {emit {\b LTP}}
+}
+switch -- [Nv c 2 &0xc0] 0 {emit {\b Main}} 64 {emit {\b LC}} -128 {emit {\b SSR}}
+switch -- [Nv c 2 &0x3c] 0 {emit {\b, 96 kHz}} 4 {emit {\b, 88.2 kHz}} 8 {emit {\b, 64 kHz}} 12 {emit {\b, 48 kHz}} 16 {emit {\b, 44.1 kHz}} 20 {emit {\b, 32 kHz}} 24 {emit {\b, 24 kHz}} 28 {emit {\b, 22.05 kHz}} 32 {emit {\b, 16 kHz}} 36 {emit {\b, 12 kHz}} 40 {emit {\b, 11.025 kHz}} 44 {emit {\b, 8 kHz}}
+switch -- [Nv S 2 &0x01c0] 64 {emit {\b, monaural}} 128 {emit {\b, stereo}} 192 {emit {\b, stereo + center}} 256 {emit {\b, stereo+center+LFE}} 320 {emit {\b, surround}} 384 {emit {\b, surround + LFE}}
+if {[N S 2 & 0x1c0]} {emit {\b, surround + side}}
+}
+if {[N S 0 == 0x56e0 &0xFFE0]} {emit {MPEG-4 LOAS}
+if {[N c 3 == 0x40 &0xE0]} {switch -- [Nv c 4 &0x3C] 4 {emit {\b, single stream}} 8 {emit {\b, 2 streams}} 12 {emit {\b, 3 streams}}
+if {[N c 4 & 0x8]} {emit {\b, 4 or more streams}}
+if {[N c 4 & 0x20]} {emit {\b, 8 or more streams}}
+}
+if {[N c 3 == 0x0 &0xC0]} {switch -- [Nv c 4 &0x78] 8 {emit {\b, single stream}} 16 {emit {\b, 2 streams}} 24 {emit {\b, 3 streams}}
+if {[N c 4 & 0x20]} {emit {\b, 4 or more streams}}
+if {[N c 4 & 0x40]} {emit {\b, 8 or more streams}}
+}
+}
+switch -- [Nv s 4] -20719 {emit {FLI file}
+if {[N s 6 x {}]} {emit {- %d frames,}}
+if {[N s 8 x {}]} {emit {width=%d pixels,}}
+if {[N s 10 x {}]} {emit {height=%d pixels,}}
+if {[N s 12 x {}]} {emit depth=%d,}
+if {[N s 16 x {}]} {emit ticks/frame=%d}
+} -20718 {emit {FLC file}
+if {[N s 6 x {}]} {emit {- %d frames}}
+if {[N s 8 x {}]} {emit {width=%d pixels,}}
+if {[N s 10 x {}]} {emit {height=%d pixels,}}
+if {[N s 12 x {}]} {emit depth=%d,}
+if {[N s 16 x {}]} {emit ticks/frame=%d}
+}
+if {[N I 0 == 0x47400010 &0xFF5FFF1F]} {emit {MPEG transport stream data}
+if {[N c 188 != 0x47]} {emit CORRUPTED}
+}
+switch -- [Nv I 0 &0xffffff00] 520552448 {emit DIF
+if {[N c 4 & 0x1]} {emit {\(DVCPRO\) movie file}}
+if {[N c 4 ^ 0x1]} {emit {\(DV\) movie file}}
+if {[N c 3 & 0x80]} {emit {\(PAL\)}}
+if {[N c 3 ^ 0x80]} {emit {\(NTSC\)}}
+} -2063526912 {emit {cisco IOS microcode}
+if {[S 7 x {}]} {emit {for '%s'}}
+} -2063480064 {emit {cisco IOS experimental microcode}
+if {[S 7 x {}]} {emit {for '%s'}}
+} -16907520 {emit {MySQL MISAM index file}
+if {[N c 3 x {}]} {emit {Version %d}}
+} -16906496 {emit {MySQL MISAM compressed data file}
+if {[N c 3 x {}]} {emit {Version %d}}
+} -16907008 {emit {MySQL ISAM index file}
+if {[N c 3 x {}]} {emit {Version %d}}
+} -16906752 {emit {MySQL ISAM compressed data file}
+if {[N c 3 x {}]} {emit {Version %d}}
+}
+if {[S 0 == {\x8aMNG}]} {emit {MNG video data,}
+if {[N I 4 != 0xd0a1a0a]} {emit CORRUPTED,}
+if {[N I 4 == 0xd0a1a0a]} {if {[N I 16 x {}]} {emit {%ld x}}
+if {[N I 20 x {}]} {emit %ld}
+}
+}
+if {[S 0 == {\x8bJNG}]} {emit {JNG video data,}
+if {[N I 4 != 0xd0a1a0a]} {emit CORRUPTED,}
+if {[N I 4 == 0xd0a1a0a]} {if {[N I 16 x {}]} {emit {%ld x}}
+if {[N I 20 x {}]} {emit %ld}
+}
+}
+if {[S 3 == {\x0D\x0AVersion:Vivo}]} {emit {Vivo video data}}
+if {[S 0 == {\#VRML\ V1.0\ ascii} b]} {emit {VRML 1 file}}
+if {[S 0 == {\#VRML\ V2.0\ utf8} b]} {emit {ISO/IEC 14772 VRML 97 file}}
+if {[S 0 == HVQM4]} {emit %s
+if {[S 6 x {}]} {emit v%s}
+if {[N c 0 x {}]} {emit {GameCube movie,}}
+if {[N S 52 x {}]} {emit {%d x}}
+if {[N S 54 x {}]} {emit %d,}
+if {[N S 38 x {}]} {emit %dµs,}
+if {[N S 66 == 0x0]} {emit {no audio}}
+if {[N S 66 > 0x0]} {emit {%dHz audio}}
+}
+if {[S 0 == DVDVIDEO-VTS]} {emit {Video title set,}
+if {[N c 33 x {}]} {emit v%x}
+}
+if {[S 0 == DVDVIDEO-VMG]} {emit {Video manager,}
+if {[N c 33 x {}]} {emit v%x}
+}
+switch -- [Nv Q 0] 33132 {emit {APL workspace \(Ken's original?\)}} 65389 {emit {very old archive}} 65381 {emit {old archive}} 33132 {emit {apl workspace}} 557605234 {emit {archive file}} 262 {emit {68k Blit mpx/mux executable}} 269 {emit {i960 b.out relocatable object}
+if {[N Q 16 > 0x0]} {emit {not stripped}}
+} 1145263299 {emit {DACT compressed data}
+if {[N c 4 > 0xffffffff]} {emit {\(version %i.}}
+if {[N c 5 > 0xffffffff]} {emit {$BS%i.}}
+if {[N c 6 > 0xffffffff]} {emit {$BS%i\)}}
+if {[N Q 7 > 0x0]} {emit {$BS, original size: %i bytes}}
+if {[N Q 15 > 0x1e]} {emit {$BS, block size: %i bytes}}
+} 398689 {emit {Berkeley DB}
+switch -- [Nv I 8] 4321 {emit {}
+if {[N I 4 > 0x2]} {emit 1.86}
+if {[N I 4 < 0x3]} {emit 1.85}
+if {[N I 4 > 0x0]} {emit {\(Hash, version %d, native byte-order\)}}
+} 1234 {emit {}
+if {[N I 4 > 0x2]} {emit 1.86}
+if {[N I 4 < 0x3]} {emit 1.85}
+if {[N I 4 > 0x0]} {emit {\(Hash, version %d, little-endian\)}}
+}
+} 340322 {emit {Berkeley DB 1.85/1.86}
+if {[N Q 4 > 0x0]} {emit {\(Btree, version %d, native byte-order\)}}
+} 1234567 {emit {X image}} 168757262 {emit {TML 0123 byte-order format}} 252317192 {emit {TML 1032 byte-order format}} 135137807 {emit {TML 2301 byte-order format}} 235409162 {emit {TML 3210 byte-order format}} 34078982 {emit {HP s500 relocatable executable}
+if {[N Q 16 > 0x0]} {emit {- version %ld}}
+} 34078983 {emit {HP s500 executable}
+if {[N Q 16 > 0x0]} {emit {- version %ld}}
+} 34078984 {emit {HP s500 pure executable}
+if {[N Q 16 > 0x0]} {emit {- version %ld}}
+} 65381 {emit {HP old archive}} 34275173 {emit {HP s200 old archive}} 34406245 {emit {HP s200 old archive}} 34144101 {emit {HP s500 old archive}} 22552998 {emit {HP core file}} 1302851304 {emit {HP-WINDOWS font}
+if {[N c 8 > 0x0]} {emit {- version %ld}}
+} 34341132 {emit {compiled Lisp}} 1123028772 {emit {Artisan image data}
+switch -- [Nv Q 4] 1 {emit {\b, rectangular 24-bit}} 2 {emit {\b, rectangular 8-bit with colormap}} 3 {emit {\b, rectangular 32-bit \(24-bit with matte\)}}
+} 1886817234 {emit {CLISP memory image data}} -762612112 {emit {CLISP memory image data, other endian}} -569244523 {emit {GNU-format message catalog data}} -1794895138 {emit {GNU-format message catalog data}} -1042103351 {emit {SPSS Portable File}
+if {[S 40 x {}]} {emit %s}
+} 31415 {emit {Mirage Assembler m.out executable}} 61374 {emit {OSF/Rose object}} 1351614727 {emit {Pyramid 90x family executable}} 1351614728 {emit {Pyramid 90x family pure executable}
+if {[N Q 16 > 0x0]} {emit {not stripped}}
+} 1351614731 {emit {Pyramid 90x family demand paged pure executable}
+if {[N Q 16 > 0x0]} {emit {not stripped}}
+} -97271666 {emit {SunPC 4.0 Hard Disk}} 268 {emit {unknown demand paged pure executable}
+if {[N Q 16 > 0x0]} {emit {not stripped}}
+} 270 {emit {unknown readable demand paged pure executable}} 395726 {emit {Jaleo XFS file}
+if {[N Q 4 x {}]} {emit {- version %ld}}
+if {[N Q 8 x {}]} {emit {- [%ld -}}
+if {[N Q 20 x {}]} {emit %ldx}
+if {[N Q 24 x {}]} {emit %ldx}
+switch -- [Nv Q 28] 1008 {emit YUV422\]} 1000 {emit RGB24\]}
+} 59399 {emit {object file \(z8000 a.out\)}} 59400 {emit {pure object file \(z8000 a.out\)}} 59401 {emit {separate object file \(z8000 a.out\)}} 59397 {emit {overlay object file \(z8000 a.out\)}}
+if {[S 0 == FiLeStArTfIlEsTaRt]} {emit {binscii \(apple ][\) text}}
+if {[S 0 == {\x0aGL}]} {emit {Binary II \(apple ][\) data}}
+if {[S 0 == {\x76\xff}]} {emit {Squeezed \(apple ][\) data}}
+if {[S 0 == NuFile]} {emit {NuFile archive \(apple ][\) data}}
+if {[S 0 == {N\xf5F\xe9l\xe5}]} {emit {NuFile archive \(apple ][\) data}}
+if {[S 0 == package0]} {emit {Newton package, NOS 1.x,}
+if {[N I 12 & 0x80000000]} {emit AutoRemove,}
+if {[N I 12 & 0x40000000]} {emit CopyProtect,}
+if {[N I 12 & 0x10000000]} {emit NoCompression,}
+if {[N I 12 & 0x4000000]} {emit Relocation,}
+if {[N I 12 & 0x2000000]} {emit UseFasterCompression,}
+if {[N I 16 x {}]} {emit {version %d}}
+}
+if {[S 0 == package1]} {emit {Newton package, NOS 2.x,}
+if {[N I 12 & 0x80000000]} {emit AutoRemove,}
+if {[N I 12 & 0x40000000]} {emit CopyProtect,}
+if {[N I 12 & 0x10000000]} {emit NoCompression,}
+if {[N I 12 & 0x4000000]} {emit Relocation,}
+if {[N I 12 & 0x2000000]} {emit UseFasterCompression,}
+if {[N I 16 x {}]} {emit {version %d}}
+}
+if {[S 0 == package4]} {emit {Newton package,}
+switch -- [Nv c 8] 8 {emit {NOS 1.x,}} 9 {emit {NOS 2.x,}}
+if {[N I 12 & 0x80000000]} {emit AutoRemove,}
+if {[N I 12 & 0x40000000]} {emit CopyProtect,}
+if {[N I 12 & 0x10000000]} {emit NoCompression,}
+}
+if {[S 4 == O====]} {emit {AppleWorks word processor data}
+if {[N c 85 > 0x0 &0x01]} {emit {\b, zoomed}}
+if {[N c 90 > 0x0 &0x01]} {emit {\b, paginated}}
+if {[N c 92 > 0x0 &0x01]} {emit {\b, with mail merge}}
+}
+if {[N I 0 == 0x80000 &0xff00ff]} {emit {Applesoft BASIC program data}}
+if {[S 8144 == {\x7F\x7F\x7F\x7F\x7F\x7F\x7F\x7F}]} {emit {Apple II image with white background}}
+if {[S 8144 == {\x55\x2A\x55\x2A\x55\x2A\x55\x2A}]} {emit {Apple II image with purple background}}
+if {[S 8144 == {\x2A\x55\x2A\x55\x2A\x55\x2A\x55}]} {emit {Apple II image with green background}}
+if {[S 8144 == {\xD5\xAA\xD5\xAA\xD5\xAA\xD5\xAA}]} {emit {Apple II image with blue background}}
+if {[S 8144 == {\xAA\xD5\xAA\xD5\xAA\xD5\xAA\xD5}]} {emit {Apple II image with orange background}}
+if {[N I 0 == 0x6400d000 &0xFF00FFFF]} {emit {Apple Mechanic font}}
+if {[S 0 == *BEGIN]} {emit Applixware
+if {[S 7 == WORDS]} {emit {Words Document}}
+if {[S 7 == GRAPHICS]} {emit Graphic}
+if {[S 7 == RASTER]} {emit Bitmap}
+if {[S 7 == SPREADSHEETS]} {emit Spreadsheet}
+if {[S 7 == MACRO]} {emit Macro}
+if {[S 7 == BUILDER]} {emit {Builder Object}}
+}
+if {[S 257 == {ustar\0}]} {emit {POSIX tar archive}}
+if {[S 257 == {ustar\040\040\0}]} {emit {GNU tar archive}}
+if {[S 0 == 070707]} {emit {ASCII cpio archive \(pre-SVR4 or odc\)}}
+if {[S 0 == 070701]} {emit {ASCII cpio archive \(SVR4 with no CRC\)}}
+if {[S 0 == 070702]} {emit {ASCII cpio archive \(SVR4 with CRC\)}}
+if {[S 0 == {!<arch>\ndebian}]} {if {[S 8 == debian-split]} {emit {part of multipart Debian package}}
+if {[S 8 == debian-binary]} {emit {Debian binary package}}
+if {[S 68 x {}]} {emit {\(format %s\)}}
+if {[S 81 == bz2]} {emit {\b, uses bzip2 compression}}
+if {[S 84 == gz]} {emit {\b, uses gzip compression}}
+}
+if {[S 0 == <ar>]} {emit archive}
+if {[S 0 == {!<arch>\n__________E}]} {emit {MIPS archive}
+if {[S 20 == U]} {emit {with MIPS Ucode members}}
+if {[S 21 == L]} {emit {with MIPSEL members}}
+if {[S 21 == B]} {emit {with MIPSEB members}}
+if {[S 19 == L]} {emit {and an EL hash table}}
+if {[S 19 == B]} {emit {and an EB hash table}}
+if {[S 22 == X]} {emit {-- out of date}}
+}
+if {[S 0 == -h-]} {emit {Software Tools format archive text}}
+if {[S 0 == !<arch>]} {emit {current ar archive}
+if {[S 8 == __.SYMDEF]} {emit {random library}}
+switch -- [Nv I 0] 65538 {emit {- pre SR9.5}} 65539 {emit {- post SR9.5}}
+switch -- [Nv S 0] 2 {emit {- object archive}} 3 {emit {- shared library module}} 4 {emit {- debug break-pointed module}} 5 {emit {- absolute code program module}}
+}
+if {[S 0 == <ar>]} {emit {System V Release 1 ar archive}}
+if {[S 0 == <ar>]} {emit archive}
+switch -- [Nv i 0 &0x8080ffff] 2074 {emit {ARC archive data, dynamic LZW}} 2330 {emit {ARC archive data, squashed}} 538 {emit {ARC archive data, uncompressed}} 794 {emit {ARC archive data, packed}} 1050 {emit {ARC archive data, squeezed}} 1562 {emit {ARC archive data, crunched}}
+if {[S 0 == {\032}]} {emit {RISC OS archive \(spark format\)}}
+if {[S 0 == {Archive\000}]} {emit {RISC OS archive \(ArcFS format\)}}
+if {[S 0 == HPAK]} {emit {HPACK archive data}}
+if {[S 0 == {\351,\001JAM\ }]} {emit {JAM archive,}
+if {[S 7 x {}]} {emit {version %.4s}}
+if {[N c 38 == 0x27]} {emit -
+if {[S 43 x {}]} {emit {label %.11s,}}
+if {[N i 39 x {}]} {emit {serial %08x,}}
+if {[S 54 x {}]} {emit {fstype %.8s}}
+}
+}
+if {[S 2 == -lh0-]} {emit {LHarc 1.x archive data [lh0]}}
+if {[S 2 == -lh1-]} {emit {LHarc 1.x archive data [lh1]}}
+if {[S 2 == -lz4-]} {emit {LHarc 1.x archive data [lz4]}}
+if {[S 2 == -lz5-]} {emit {LHarc 1.x archive data [lz5]}}
+if {[S 2 == -lzs-]} {emit {LHa 2.x? archive data [lzs]}}
+if {[S 2 == {-lh\40-}]} {emit {LHa 2.x? archive data [lh ]}}
+if {[S 2 == -lhd-]} {emit {LHa 2.x? archive data [lhd]}}
+if {[S 2 == -lh2-]} {emit {LHa 2.x? archive data [lh2]}}
+if {[S 2 == -lh3-]} {emit {LHa 2.x? archive data [lh3]}}
+if {[S 2 == -lh4-]} {emit {LHa \(2.x\) archive data [lh4]}}
+if {[S 2 == -lh5-]} {emit {LHa \(2.x\) archive data [lh5]}}
+if {[S 2 == -lh6-]} {emit {LHa \(2.x\) archive data [lh6]}}
+if {[S 2 == -lh7-]} {emit {LHa \(2.x\) archive data [lh7]}
+if {[N c 20 x {}]} {emit {- header level %d}}
+}
+if {[S 0 == Rar!]} {emit {RAR archive data,}
+if {[N c 44 x {}]} {emit v%0x,}
+switch -- [Nv c 35] 0 {emit {os: MS-DOS}} 1 {emit {os: OS/2}} 2 {emit {os: Win32}} 3 {emit {os: Unix}}
+}
+if {[S 0 == SQSH]} {emit {squished archive data \(Acorn RISCOS\)}}
+if {[S 0 == {UC2\x1a}]} {emit {UC2 archive data}}
+if {[S 0 == {PK\003\004}]} {emit {Zip archive data}
+switch -- [Nv c 4] 9 {emit {\b, at least v0.9 to extract}} 10 {emit {\b, at least v1.0 to extract}} 11 {emit {\b, at least v1.1 to extract}} 20 {emit {\b, at least v2.0 to extract}}
+}
+if {[N i 20 == 0xfdc4a7dc]} {emit {Zoo archive data}
+if {[N c 4 > 0x30]} {emit {\b, v%c.}
+if {[N c 6 > 0x2f]} {emit {\b%c}
+if {[N c 7 > 0x2f]} {emit {\b%c}}
+}
+}
+if {[N c 32 > 0x0]} {emit {\b, modify: v%d}
+if {[N c 33 x {}]} {emit {\b.%d+}}
+}
+if {[N i 42 == 0xfdc4a7dc]} {emit {\b,}
+if {[N c 70 > 0x0]} {emit {extract: v%d}
+if {[N c 71 x {}]} {emit {\b.%d+}}
+}
+}
+}
+if {[S 10 == {\#\ This\ is\ a\ shell\ archive}]} {emit {shell archive text}}
+if {[S 0 == {\0\ \ \ \ \ \ \ \ \ \ \ \0\0}]} {emit {LBR archive data}}
+if {[S 2 == -pm0-]} {emit {PMarc archive data [pm0]}}
+if {[S 2 == -pm1-]} {emit {PMarc archive data [pm1]}}
+if {[S 2 == -pm2-]} {emit {PMarc archive data [pm2]}}
+if {[S 2 == -pms-]} {emit {PMarc SFX archive \(CP/M, DOS\)}}
+if {[S 5 == -pc1-]} {emit {PopCom compressed executable \(CP/M\)}}
+if {[S 4 == {gtktalog\ }]} {emit {GTKtalog catalog data,}
+if {[S 13 == 3]} {emit {version 3}
+if {[N S 14 == 0x677a]} {emit {\(gzipped\)}}
+if {[N S 14 != 0x677a]} {emit {\(not gzipped\)}}
+}
+if {[S 13 > 3]} {emit {version %s}}
+}
+if {[S 0 == {PAR\0}]} {emit {PARity archive data}
+if {[N s 48 == 0x0]} {emit {- Index file}}
+if {[N s 48 > 0x0]} {emit {- file number %d}}
+}
+if {[S 0 == d8:announce]} {emit {BitTorrent file}}
+if {[S 0 == {PK00PK\003\004}]} {emit {Zip archive data}}
+if {[S 7 == **ACE**]} {emit {ACE compressed archive}
+if {[N c 15 > 0x0]} {emit {version %d}}
+switch -- [Nv c 16] 0 {emit {\b, from MS-DOS}} 1 {emit {\b, from OS/2}} 2 {emit {\b, from Win/32}} 3 {emit {\b, from Unix}} 4 {emit {\b, from MacOS}} 5 {emit {\b, from WinNT}} 6 {emit {\b, from Primos}} 7 {emit {\b, from AppleGS}} 8 {emit {\b, from Atari}} 9 {emit {\b, from Vax/VMS}} 10 {emit {\b, from Amiga}} 11 {emit {\b, from Next}}
+if {[N c 14 x {}]} {emit {\b, version %d to extract}}
+if {[N s 5 & 0x80]} {emit {\b, multiple volumes,}
+if {[N c 17 x {}]} {emit {\b \(part %d\),}}
+}
+if {[N s 5 & 0x2]} {emit {\b, contains comment}}
+if {[N s 5 & 0x200]} {emit {\b, sfx}}
+if {[N s 5 & 0x400]} {emit {\b, small dictionary}}
+if {[N s 5 & 0x800]} {emit {\b, multi-volume}}
+if {[N s 5 & 0x1000]} {emit {\b, contains AV-String}}
+if {[N s 5 & 0x2000]} {emit {\b, with recovery record}}
+if {[N s 5 & 0x4000]} {emit {\b, locked}}
+if {[N s 5 & 0x8000]} {emit {\b, solid}}
+}
+if {[S 26 == sfArk]} {emit {sfArk compressed Soundfont}
+if {[S 21 == 2]} {if {[S 1 x {}]} {emit {Version %s}}
+if {[S 42 x {}]} {emit {: %s}}
+}
+}
+if {[S 0 == {Packed\ File\ }]} {emit {Personal NetWare Packed File}
+if {[S 12 x {}]} {emit {\b, was \"%.12s\"}}
+}
+if {[S 0 == *STA]} {emit Aster*x
+if {[S 7 == WORD]} {emit {Words Document}}
+if {[S 7 == GRAP]} {emit Graphic}
+if {[S 7 == SPRE]} {emit Spreadsheet}
+if {[S 7 == MACR]} {emit Macro}
+}
+if {[S 0 == 2278]} {emit {Aster*x Version 2}
+switch -- [Nv c 29] 54 {emit {Words Document}} 53 {emit Graphic} 50 {emit Spreadsheet} 56 {emit Macro}
+}
+if {[S 0 == {\000\004\036\212\200}]} {emit {3b2 core file}
+if {[S 364 x {}]} {emit {of '%s'}}
+}
+if {[S 0 == .snd]} {emit {Sun/NeXT audio data:}
+switch -- [Nv I 12] 1 {emit {8-bit ISDN mu-law,}} 2 {emit {8-bit linear PCM [REF-PCM],}} 3 {emit {16-bit linear PCM,}} 4 {emit {24-bit linear PCM,}} 5 {emit {32-bit linear PCM,}} 6 {emit {32-bit IEEE floating point,}} 7 {emit {64-bit IEEE floating point,}} 8 {emit {Fragmented sample data,}} 10 {emit {DSP program,}} 11 {emit {8-bit fixed point,}} 12 {emit {16-bit fixed point,}} 13 {emit {24-bit fixed point,}} 14 {emit {32-bit fixed point,}} 18 {emit {16-bit linear with emphasis,}} 19 {emit {16-bit linear compressed,}} 20 {emit {16-bit linear with emphasis and compression,}} 21 {emit {Music kit DSP commands,}} 23 {emit {8-bit ISDN mu-law compressed \(CCITT G.721 ADPCM voice data encoding\),}} 24 {emit {compressed \(8-bit CCITT G.722 ADPCM\)}} 25 {emit {compressed \(3-bit CCITT G.723.3 ADPCM\),}} 26 {emit {compressed \(5-bit CCITT G.723.5 ADPCM\),}} 27 {emit {8-bit A-law \(CCITT G.711\),}}
+switch -- [Nv I 20] 1 {emit mono,} 2 {emit stereo,} 4 {emit quad,}
+if {[N I 16 > 0x0]} {emit {%d Hz}}
+}
+if {[S 0 == MThd]} {emit {Standard MIDI data}
+if {[N S 8 x {}]} {emit {\(format %d\)}}
+if {[N S 10 x {}]} {emit {using %d track}}
+if {[N S 10 > 0x1]} {emit {\bs}}
+if {[N S 12 x {} &0x7fff]} {emit {at 1/%d}}
+if {[N S 12 > 0x0 &0x8000]} {emit SMPTE}
+}
+if {[S 0 == CTMF]} {emit {Creative Music \(CMF\) data}}
+if {[S 0 == SBI]} {emit {SoundBlaster instrument data}}
+if {[S 0 == {Creative\ Voice\ File}]} {emit {Creative Labs voice data}
+if {[N c 19 == 0x1a]} {emit 139 0}
+if {[N c 23 > 0x0]} {emit {- version %d}}
+if {[N c 22 > 0x0]} {emit {\b.%d}}
+}
+if {[S 0 == EMOD]} {emit {Extended MOD sound data,}
+if {[N c 4 x {} &0xf0]} {emit {version %d}}
+if {[N c 4 x {} &0x0f]} {emit {\b.%d,}}
+if {[N c 45 x {}]} {emit {%d instruments}}
+switch -- [Nv c 83] 0 {emit {\(module\)}} 1 {emit {\(song\)}}
+}
+if {[S 0 == .RMF]} {emit {RealMedia file}}
+if {[S 0 == MAS_U]} {emit {ULT\(imate\) Module sound data}}
+if {[S 44 == SCRM]} {emit {ScreamTracker III Module sound data}
+if {[S 0 x {}]} {emit {Title: \"%s\"}}
+}
+if {[S 0 == {GF1PATCH110\0ID\#000002\0}]} {emit {GUS patch}}
+if {[S 0 == {GF1PATCH100\0ID\#000002\0}]} {emit {Old GUS patch}}
+if {[S 0 == MAS_UTrack_V00]} {if {[S 14 > /0]} {emit {ultratracker V1.%.1s module sound data}}
+}
+if {[S 0 == UN05]} {emit {MikMod UNI format module sound data}}
+if {[S 0 == {Extended\ Module:}]} {emit {Fasttracker II module sound data}
+if {[S 17 x {}]} {emit {Title: \"%s\"}}
+}
+if {[S 21 == !SCREAM! c]} {emit {Screamtracker 2 module sound data}}
+if {[S 21 == BMOD2STM]} {emit {Screamtracker 2 module sound data}}
+if {[S 1080 == M.K.]} {emit {4-channel Protracker module sound data}
+if {[S 0 x {}]} {emit {Title: \"%s\"}}
+}
+if {[S 1080 == M!K!]} {emit {4-channel Protracker module sound data}
+if {[S 0 x {}]} {emit {Title: \"%s\"}}
+}
+if {[S 1080 == FLT4]} {emit {4-channel Startracker module sound data}
+if {[S 0 x {}]} {emit {Title: \"%s\"}}
+}
+if {[S 1080 == FLT8]} {emit {8-channel Startracker module sound data}
+if {[S 0 x {}]} {emit {Title: \"%s\"}}
+}
+if {[S 1080 == 4CHN]} {emit {4-channel Fasttracker module sound data}
+if {[S 0 x {}]} {emit {Title: \"%s\"}}
+}
+if {[S 1080 == 6CHN]} {emit {6-channel Fasttracker module sound data}
+if {[S 0 x {}]} {emit {Title: \"%s\"}}
+}
+if {[S 1080 == 8CHN]} {emit {8-channel Fasttracker module sound data}
+if {[S 0 x {}]} {emit {Title: \"%s\"}}
+}
+if {[S 1080 == CD81]} {emit {8-channel Octalyser module sound data}
+if {[S 0 x {}]} {emit {Title: \"%s\"}}
+}
+if {[S 1080 == OKTA]} {emit {8-channel Oktalyzer module sound data}
+if {[S 0 x {}]} {emit {Title: \"%s\"}}
+}
+if {[S 1080 == 16CN]} {emit {16-channel Taketracker module sound data}
+if {[S 0 x {}]} {emit {Title: \"%s\"}}
+}
+if {[S 1080 == 32CN]} {emit {32-channel Taketracker module sound data}
+if {[S 0 x {}]} {emit {Title: \"%s\"}}
+}
+if {[S 0 == TOC]} {emit {TOC sound file}}
+if {[S 0 == {SIDPLAY\ INFOFILE}]} {emit {Sidplay info file}}
+if {[S 0 == PSID]} {emit {PlaySID v2.2+ \(AMIGA\) sidtune}
+if {[N S 4 > 0x0]} {emit {w/ header v%d,}}
+if {[N S 14 == 0x1]} {emit {single song,}}
+if {[N S 14 > 0x1]} {emit {%d songs,}}
+if {[N S 16 > 0x0]} {emit {default song: %d}}
+if {[S 22 x {}]} {emit {name: \"%s\"}}
+if {[S 54 x {}]} {emit {author: \"%s\"}}
+if {[S 86 x {}]} {emit {copyright: \"%s\"}}
+}
+if {[S 0 == RSID]} {emit {RSID sidtune PlaySID compatible}
+if {[N S 4 > 0x0]} {emit {w/ header v%d,}}
+if {[N S 14 == 0x1]} {emit {single song,}}
+if {[N S 14 > 0x1]} {emit {%d songs,}}
+if {[N S 16 > 0x0]} {emit {default song: %d}}
+if {[S 22 x {}]} {emit {name: \"%s\"}}
+if {[S 54 x {}]} {emit {author: \"%s\"}}
+if {[S 86 x {}]} {emit {copyright: \"%s\"}}
+}
+if {[S 0 == {NIST_1A\n\ \ \ 1024\n}]} {emit {NIST SPHERE file}}
+if {[S 0 == {SOUND\ SAMPLE\ DATA\ }]} {emit {Sample Vision file}}
+if {[S 0 == 2BIT]} {emit {Audio Visual Research file,}
+switch -- [Nv S 12] 0 {emit mono,} -1 {emit stereo,}
+if {[N S 14 x {}]} {emit {%d bits}}
+switch -- [Nv S 16] 0 {emit unsigned,} -1 {emit signed,}
+if {[N I 22 x {} &0x00ffffff]} {emit {%d Hz,}}
+switch -- [Nv S 18] 0 {emit {no loop,}} -1 {emit loop,}
+if {[N c 21 <= 0x7f]} {emit {note %d,}}
+switch -- [Nv c 22] 0 {emit {replay 5.485 KHz}} 1 {emit {replay 8.084 KHz}} 2 {emit {replay 10.971 Khz}} 3 {emit {replay 16.168 Khz}} 4 {emit {replay 21.942 KHz}} 5 {emit {replay 32.336 KHz}} 6 {emit {replay 43.885 KHz}} 7 {emit {replay 47.261 KHz}}
+}
+if {[S 0 == _SGI_SoundTrack]} {emit {SGI SoundTrack project file}}
+if {[S 0 == ID3]} {emit {MP3 file with ID3 version 2.}
+if {[N c 3 < 0xff]} {emit {\b%d.}}
+if {[N c 4 < 0xff]} {emit {\b%d tag}}
+}
+if {[S 0 == {NESM\x1a}]} {emit {NES Sound File}
+if {[S 14 x {}]} {emit {\(\"%s\" by}}
+if {[S 46 x {}]} {emit {%s, copyright}}
+if {[S 78 x {}]} {emit {%s\),}}
+if {[N c 5 x {}]} {emit {version %d,}}
+if {[N c 6 x {}]} {emit {%d tracks,}}
+if {[N c 122 == 0x1 &0x2]} {emit {dual PAL/NTSC}}
+switch -- [Nv c 122 &0x1] 1 {emit PAL} 0 {emit NTSC}
+}
+if {[S 0 == IMPM]} {emit {Impulse Tracker module sound data -}
+if {[S 4 x {}]} {emit {\"%s\"}}
+if {[N s 40 != 0x0]} {emit {compatible w/ITv%x}}
+if {[N s 42 != 0x0]} {emit {created w/ITv%x}}
+}
+if {[S 60 == IM10]} {emit {Imago Orpheus module sound data -}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 0 == IMPS]} {emit {Impulse Tracker Sample}
+if {[N c 18 & 0x2]} {emit {16 bit}}
+if {[N c 18 ^ 0x2]} {emit {8 bit}}
+if {[N c 18 & 0x4]} {emit stereo}
+if {[N c 18 ^ 0x4]} {emit mono}
+}
+if {[S 0 == IMPI]} {emit {Impulse Tracker Instrument}
+if {[N s 28 != 0x0]} {emit ITv%x}
+if {[N c 30 != 0x0]} {emit {%d samples}}
+}
+if {[S 0 == LM8953]} {emit {Yamaha TX Wave}
+switch -- [Nv c 22] 73 {emit looped} -55 {emit non-looped}
+switch -- [Nv c 23] 1 {emit 33kHz} 2 {emit 50kHz} 3 {emit 16kHz}
+}
+if {[S 76 == SCRS]} {emit {Scream Tracker Sample}
+switch -- [Nv c 0] 1 {emit sample} 2 {emit {adlib melody}}
+if {[N c 0 > 0x2]} {emit {adlib drum}}
+if {[N c 31 & 0x2]} {emit stereo}
+if {[N c 31 ^ 0x2]} {emit mono}
+if {[N c 31 & 0x4]} {emit {16bit little endian}}
+if {[N c 31 ^ 0x4]} {emit 8bit}
+switch -- [Nv c 30] 0 {emit unpacked} 1 {emit packed}
+}
+if {[S 0 == MMD0]} {emit {MED music file, version 0}}
+if {[S 0 == MMD1]} {emit {OctaMED Pro music file, version 1}}
+if {[S 0 == MMD3]} {emit {OctaMED Soundstudio music file, version 3}}
+if {[S 0 == OctaMEDCmpr]} {emit {OctaMED Soundstudio compressed file}}
+if {[S 0 == MED]} {emit MED_Song}
+if {[S 0 == SymM]} {emit {Symphonie SymMOD music file}}
+if {[S 0 == THX]} {emit {AHX version}
+switch -- [Nv c 3] 0 {emit {1 module data}} 1 {emit {2 module data}}
+}
+if {[S 0 == OKTASONG]} {emit {Oktalyzer module data}}
+if {[S 0 == {DIGI\ Booster\ module\0}]} {emit %s
+if {[N c 20 > 0x0]} {emit %c
+if {[N c 21 > 0x0]} {emit {\b%c}
+if {[N c 22 > 0x0]} {emit {\b%c}
+if {[N c 23 > 0x0]} {emit {\b%c}}
+}
+}
+}
+if {[S 610 x {}]} {emit {\b, \"%s\"}}
+}
+if {[S 0 == DBM0]} {emit {DIGI Booster Pro Module}
+if {[N c 4 > 0x0]} {emit V%X.
+if {[N c 5 x {}]} {emit {\b%02X}}
+}
+if {[S 16 x {}]} {emit {\b, \"%s\"}}
+}
+if {[S 0 == FTMN]} {emit {FaceTheMusic module}
+if {[S 16 > {\0d}]} {emit {\b, \"%s\"}}
+}
+if {[S 0 == {AMShdr\32}]} {emit {Velvet Studio AMS Module v2.2}}
+if {[S 0 == Extreme]} {emit {Extreme Tracker AMS Module v1.3}}
+if {[S 0 == DDMF]} {emit {Xtracker DMF Module}
+if {[N c 4 x {}]} {emit v%i}
+if {[S 13 x {}]} {emit {Title: \"%s\"}}
+if {[S 43 x {}]} {emit {Composer: \"%s\"}}
+}
+if {[S 0 == {DSM\32}]} {emit {Dynamic Studio Module DSM}}
+if {[S 0 == SONG]} {emit {DigiTrekker DTM Module}}
+if {[S 0 == DMDL]} {emit {DigiTrakker MDL Module}}
+if {[S 0 == {PSM\32}]} {emit {Protracker Studio PSM Module}}
+if {[S 44 == PTMF]} {emit {Poly Tracker PTM Module}
+if {[S 0 > {\32}]} {emit {Title: \"%s\"}}
+}
+if {[S 0 == MT20]} {emit {MadTracker 2.0 Module MT2}}
+if {[S 0 == {RAD\40by\40REALiTY!!}]} {emit {RAD Adlib Tracker Module RAD}}
+if {[S 0 == RTMM]} {emit {RTM Module}}
+if {[S 1062 == MaDoKaN96]} {emit {XMS Adlib Module}
+if {[S 0 x {}]} {emit {Composer: \"%s\"}}
+}
+if {[S 0 == AMF]} {emit {AMF Module}
+if {[S 4 x {}]} {emit {Title: \"%s\"}}
+}
+if {[S 0 == MODINFO1]} {emit {Open Cubic Player Module Inforation MDZ}}
+if {[S 0 == {Extended\40Instrument:}]} {emit {Fast Tracker II Instrument}}
+if {[S 0 == {\210NOA\015\012\032}]} {emit {NOA Nancy Codec Movie file}}
+if {[S 0 == MMMD]} {emit {Yamaha SMAF file}}
+if {[S 0 == {\001Sharp\040JisakuMelody}]} {emit {SHARP Cell-Phone ringing Melody}
+if {[S 20 == Ver01.00]} {emit {Ver. 1.00}
+if {[N c 32 x {}]} {emit {, %d tracks}}
+}
+}
+if {[S 0 == fLaC]} {emit {FLAC audio bitstream data}
+if {[N c 4 > 0x0 &0x7f]} {emit {\b, unknown version}}
+if {[N c 4 == 0x0 &0x7f]} {emit {\b}
+switch -- [Nv S 20 &0x1f0] 48 {emit {\b, 4 bit}} 80 {emit {\b, 6 bit}} 112 {emit {\b, 8 bit}} 176 {emit {\b, 12 bit}} 240 {emit {\b, 16 bit}} 368 {emit {\b, 24 bit}}
+switch -- [Nv c 20 &0xe] 0 {emit {\b, mono}} 2 {emit {\b, stereo}} 4 {emit {\b, 3 channels}} 6 {emit {\b, 4 channels}} 8 {emit {\b, 5 channels}} 10 {emit {\b, 6 channels}} 12 {emit {\b, 7 channels}} 14 {emit {\b, 8 channels}}
+switch -- [Nv I 17 &0xfffff0] 705600 {emit {\b, 44.1 kHz}} 768000 {emit {\b, 48 kHz}} 512000 {emit {\b, 32 kHz}} 352800 {emit {\b, 22.05 kHz}} 384000 {emit {\b, 24 kHz}} 256000 {emit {\b, 16 kHz}} 176400 {emit {\b, 11.025 kHz}} 192000 {emit {\b, 12 kHz}} 128000 {emit {\b, 8 kHz}} 1536000 {emit {\b, 96 kHz}} 1024000 {emit {\b, 64 kHz}}
+if {[N c 21 > 0x0 &0xf]} {emit {\b, >4G samples}}
+if {[N c 21 == 0x0 &0xf]} {emit {\b}
+if {[N I 22 > 0x0]} {emit {\b, %u samples}}
+if {[N I 22 == 0x0]} {emit {\b, length unknown}}
+}
+}
+}
+if {[S 0 == VBOX]} {emit {VBOX voice message data}}
+if {[S 8 == RB40]} {emit {RBS Song file}
+if {[S 29 == ReBorn]} {emit {created by ReBorn}}
+if {[S 37 == Propellerhead]} {emit {created by ReBirth}}
+}
+if {[S 0 == {A\#S\#C\#S\#S\#L\#V\#3}]} {emit {Synthesizer Generator or Kimwitu data}}
+if {[S 0 == {A\#S\#C\#S\#S\#L\#HUB}]} {emit {Kimwitu++ data}}
+if {[S 0 == TFMX-SONG]} {emit {TFMX module sound data}}
+if {[S 0 == {MAC\ X/Monkey}]} {emit audio,
+if {[N s 4 > 0x0]} {emit {version %d,}}
+if {[N s 6 > 0x0]} {emit {compression level %d,}}
+if {[N s 8 > 0x0]} {emit {flags %x,}}
+if {[N s 10 > 0x0]} {emit {channels %d,}}
+if {[N i 12 > 0x0]} {emit {samplerate %d,}}
+if {[N i 24 > 0x0]} {emit {frames %d}}
+}
+if {[S 0 == bFLT]} {emit {BFLT executable}
+if {[N I 4 x {}]} {emit {- version %ld}}
+if {[N I 4 == 0x4]} {if {[N I 36 == 0x1 &0x1]} {emit ram}
+if {[N I 36 == 0x2 &0x2]} {emit gotpic}
+if {[N I 36 == 0x4 &0x4]} {emit gzip}
+if {[N I 36 == 0x8 &0x8]} {emit gzdata}
+}
+}
+if {[S 0 == BLENDER]} {emit Blender3D,
+if {[S 7 == _]} {emit {saved as 32-bits}}
+if {[S 7 == -]} {emit {saved as 64-bits}}
+if {[S 8 == v]} {emit {little endian}}
+if {[S 8 == V]} {emit {big endian}}
+if {[N c 9 x {}]} {emit {with version %c.}}
+if {[N c 10 x {}]} {emit {\b%c}}
+if {[N c 11 x {}]} {emit {\b%c}}
+}
+if {[S 0 == !<bout>]} {emit {b.out archive}
+if {[S 8 == __.SYMDEF]} {emit {random library}}
+}
+switch -- [Nv I 0 &077777777] 196875 {emit {sparc demand paged}
+if {[N c 0 & 0x80]} {if {[N I 20 < 0x1000]} {emit {shared library}}
+if {[N I 20 == 0x1000]} {emit {dynamically linked executable}}
+if {[N I 20 > 0x1000]} {emit {dynamically linked executable}}
+}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+if {[N I 36 == 0xb4100001]} {emit {\(uses shared libs\)}}
+} 196872 {emit {sparc pure}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+if {[N I 36 == 0xb4100001]} {emit {\(uses shared libs\)}}
+} 196871 {emit sparc
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+if {[N I 36 == 0xb4100001]} {emit {\(uses shared libs\)}}
+} 196875 {emit {sparc demand paged}
+if {[N c 0 & 0x80]} {if {[N I 20 < 0x1000]} {emit {shared library}}
+if {[N I 20 == 0x1000]} {emit {dynamically linked executable}}
+if {[N I 20 > 0x1000]} {emit {dynamically linked executable}}
+}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 196872 {emit {sparc pure}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 196871 {emit sparc
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 131339 {emit {mc68020 demand paged}
+if {[N c 0 & 0x80]} {if {[N I 20 < 0x1000]} {emit {shared library}}
+if {[N I 20 == 0x1000]} {emit {dynamically linked executable}}
+if {[N I 20 > 0x1000]} {emit {dynamically linked executable}}
+}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 131336 {emit {mc68020 pure}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 131335 {emit mc68020
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 65803 {emit {mc68010 demand paged}
+if {[N c 0 & 0x80]} {if {[N I 20 < 0x1000]} {emit {shared library}}
+if {[N I 20 == 0x1000]} {emit {dynamically linked executable}}
+if {[N I 20 > 0x1000]} {emit {dynamically linked executable}}
+}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 65800 {emit {mc68010 pure}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 65799 {emit mc68010
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+}
+if {[S 0 == cscope]} {emit {cscope reference data}
+if {[S 7 x {}]} {emit {version %.2s}}
+if {[S 7 > 14]} {emit 218 1}
+}
+switch -- [Nv I 91392] 302072064 {emit {D64 Image}} 302072192 {emit {D71 Image}}
+if {[N I 399360 == 0x28034400]} {emit {D81 Image}}
+if {[S 0 == {C64\40CARTRIDGE}]} {emit {CCS C64 Emultar Cartridge Image}}
+if {[S 0 == GCR-1541]} {emit {GCR Image}
+if {[N c 8 x {}]} {emit {version: $i}}
+if {[N c 9 x {}]} {emit {tracks: %i}}
+}
+if {[S 9 == PSUR]} {emit {ARC archive \(c64\)}}
+if {[S 2 == -LH1-]} {emit {LHA archive \(c64\)}}
+if {[S 0 == C64File]} {emit {PC64 Emulator file}
+if {[S 8 x {}]} {emit {\"%s\"}}
+}
+if {[S 0 == C64Image]} {emit {PC64 Freezer Image}}
+if {[S 0 == {CBM\144\0\0}]} {emit {Power 64 C64 Emulator Snapshot}}
+if {[S 0 == {\101\103\061\060\061}]} {emit AutoCAD
+if {[S 5 == {\062\000\000\000\000}]} {emit {DWG ver. R13}}
+if {[S 5 == {\064\000\000\000\000}]} {emit {DWG ver. R14}}
+}
+if {[S 0 == {\010\011\376}]} {emit Microstation
+if {[S 3 == {\002}]} {if {[S 30 == {\372\104}]} {emit {DGN File}}
+if {[S 30 == {\172\104}]} {emit {DGN File}}
+if {[S 30 == {\026\105}]} {emit {DGN File}}
+}
+if {[S 4 == {\030\000\000}]} {emit {CIT File}}
+}
+if {[S 0 == AC1012]} {emit {AutoCad \(release 12\)}}
+if {[S 0 == AC1014]} {emit {AutoCad \(release 14\)}}
+if {[S 0 == {\#\040xmcd} b]} {emit {CDDB\(tm\) format CD text data}}
+if {[S 0 == {\\1cw\ }]} {emit {ChiWriter file}
+if {[S 5 x {}]} {emit {version %s}}
+}
+if {[S 0 == {\\1cw}]} {emit {ChiWriter file}}
+if {[S 0 == {\{title}]} {emit {Chord text file}}
+if {[S 0 == RuneCT]} {emit {Citrus locale declaration for LC_CTYPE}}
+if {[S 514 == {\377\377\377\377\000}]} {emit {Claris clip art?}
+if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0}]} {emit yes.}
+}
+if {[S 514 == {\377\377\377\377\001}]} {emit {Claris clip art?}
+if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0}]} {emit yes.}
+}
+if {[S 0 == {\002\000\210\003\102\117\102\117\000\001\206}]} {emit {Claris works document}}
+if {[S 0 == {\020\341\000\000\010\010}]} {emit {Claris Works pallete files .plt}}
+if {[S 0 == {\002\271\262\000\040\002\000\164}]} {emit {Claris works dictionary}}
+if {[S 0 == GRG]} {emit {Gringotts data file}
+if {[S 3 == 1]} {emit {v.1, MCRYPT S2K, SERPENT crypt, SHA-256 hash, ZLib lvl.9}}
+if {[S 3 == 2]} {emit {v.2, MCRYPT S2K,}
+switch -- [Nv c 8 &0x70] 0 {emit {RIJNDAEL-128 crypt,}} 16 {emit {SERPENT crypt,}} 32 {emit {TWOFISH crypt,}} 48 {emit {CAST-256 crypt,}} 64 {emit {SAFER+ crypt,}} 80 {emit {LOKI97 crypt,}} 96 {emit {3DES crypt,}} 112 {emit {RIJNDAEL-256 crypt,}}
+switch -- [Nv c 8 &0x08] 0 {emit {SHA1 hash,}} 8 {emit {RIPEMD-160 hash,}}
+switch -- [Nv c 8 &0x04] 0 {emit ZLib} 4 {emit BZip2}
+switch -- [Nv c 8 &0x03] 0 {emit lvl.0} 1 {emit lvl.3} 2 {emit lvl.6} 3 {emit lvl.9}
+}
+if {[S 3 == 3]} {emit {v.3, OpenPGP S2K,}
+switch -- [Nv c 8 &0x70] 0 {emit {RIJNDAEL-128 crypt,}} 16 {emit {SERPENT crypt,}} 32 {emit {TWOFISH crypt,}} 48 {emit {CAST-256 crypt,}} 64 {emit {SAFER+ crypt,}} 80 {emit {LOKI97 crypt,}} 96 {emit {3DES crypt,}} 112 {emit {RIJNDAEL-256 crypt,}}
+switch -- [Nv c 8 &0x08] 0 {emit {SHA1 hash,}} 8 {emit {RIPEMD-160 hash,}}
+switch -- [Nv c 8 &0x04] 0 {emit ZLib} 4 {emit BZip2}
+switch -- [Nv c 8 &0x03] 0 {emit lvl.0} 1 {emit lvl.3} 2 {emit lvl.6} 3 {emit lvl.9}
+}
+if {[S 3 > 3]} {emit {v.%.1s \(unknown details\)}}
+}
+if {[S 0 == :]} {emit {shell archive or script for antique kernel text}}
+if {[S 0 == {\#!\ /bin/sh} b]} {emit {Bourne shell script text executable}}
+if {[S 0 == {\#!\ /bin/csh} b]} {emit {C shell script text executable}}
+if {[S 0 == {\#!\ /bin/ksh} b]} {emit {Korn shell script text executable}}
+if {[S 0 == {\#!\ /bin/tcsh} b]} {emit {Tenex C shell script text executable}}
+if {[S 0 == {\#!\ /usr/local/tcsh} b]} {emit {Tenex C shell script text executable}}
+if {[S 0 == {\#!\ /usr/local/bin/tcsh} b]} {emit {Tenex C shell script text executable}}
+if {[S 0 == {\#!\ /bin/zsh} b]} {emit {Paul Falstad's zsh script text executable}}
+if {[S 0 == {\#!\ /usr/bin/zsh} b]} {emit {Paul Falstad's zsh script text executable}}
+if {[S 0 == {\#!\ /usr/local/bin/zsh} b]} {emit {Paul Falstad's zsh script text executable}}
+if {[S 0 == {\#!\ /usr/local/bin/ash} b]} {emit {Neil Brown's ash script text executable}}
+if {[S 0 == {\#!\ /usr/local/bin/ae} b]} {emit {Neil Brown's ae script text executable}}
+if {[S 0 == {\#!\ /bin/nawk} b]} {emit {new awk script text executable}}
+if {[S 0 == {\#!\ /usr/bin/nawk} b]} {emit {new awk script text executable}}
+if {[S 0 == {\#!\ /usr/local/bin/nawk} b]} {emit {new awk script text executable}}
+if {[S 0 == {\#!\ /bin/gawk} b]} {emit {GNU awk script text executable}}
+if {[S 0 == {\#!\ /usr/bin/gawk} b]} {emit {GNU awk script text executable}}
+if {[S 0 == {\#!\ /usr/local/bin/gawk} b]} {emit {GNU awk script text executable}}
+if {[S 0 == {\#!\ /bin/awk} b]} {emit {awk script text executable}}
+if {[S 0 == {\#!\ /usr/bin/awk} b]} {emit {awk script text executable}}
+if {[S 0 == BEGIN]} {emit {awk script text}}
+if {[S 0 == {\#!\ /bin/rc} b]} {emit {Plan 9 rc shell script text executable}}
+if {[S 0 == {\#!\ /bin/bash} b]} {emit {Bourne-Again shell script text executable}}
+if {[S 0 == {\#!\ /usr/local/bin/bash} b]} {emit {Bourne-Again shell script text executable}}
+if {[S 0 == {\#!/usr/bin/env}]} {emit a
+if {[S 15 x {}]} {emit {%s script text executable}}
+}
+if {[S 0 == {\#!\ /usr/bin/env}]} {emit a
+if {[S 16 x {}]} {emit {%s script text executable}}
+}
+if {[S 0 == <?php c]} {emit {PHP script text}}
+if {[S 0 == {<?\n}]} {emit {PHP script text}}
+if {[S 0 == {<?\r}]} {emit {PHP script text}}
+if {[S 0 == {\#!\ /usr/local/bin/php} b]} {emit {PHP script text executable}}
+if {[S 0 == {\#!\ /usr/bin/php} b]} {emit {PHP script text executable}}
+if {[S 0 == {Zend\x00}]} {emit {PHP script Zend Optimizer data}}
+if {[Sx 1 0 == {$Suite}]} {emit {TTCN Abstract Test Suite}
+if {[Sx 2 [R 1] == {$SuiteId}]} {if {[S [R 1] > {\n}]} {emit %s}
+}
+L 1;if {[Sx 2 [R 2] == {$SuiteId}]} {if {[S [R 1] > {\n}]} {emit %s}
+}
+L 1;if {[Sx 2 [R 3] == {$SuiteId}]} {if {[S [R 1] > {\n}]} {emit %s}
+}
+}
+if {[S 0 == mscdocument]} {emit {Message Sequence Chart \(document\)}}
+if {[S 0 == msc]} {emit {Message Sequence Chart \(chart\)}}
+if {[S 0 == submsc]} {emit {Message Sequence Chart \(subchart\)}}
+if {[S 0 == {\037\235}]} {emit {compress'd data}
+if {[N c 2 > 0x0 &0x80]} {emit {block compressed}}
+if {[N c 2 x {} &0x1f]} {emit {%d bits}}
+}
+if {[S 0 == {\037\213}]} {emit {gzip compressed data}
+if {[N c 2 < 0x8]} {emit {\b, reserved method}}
+if {[N c 2 > 0x8]} {emit {\b, unknown method}}
+if {[N c 3 & 0x1]} {emit {\b, ASCII}}
+if {[N c 3 & 0x2]} {emit {\b, continuation}}
+if {[N c 3 & 0x4]} {emit {\b, extra field}}
+if {[N c 3 == 0x8 &0xC]} {if {[S 10 x {}]} {emit {\b, was \"%s\"}}
+}
+switch -- [Nv c 9] 0 {emit {\b, from MS-DOS}} 1 {emit {\b, from Amiga}} 2 {emit {\b, from VMS}} 3 {emit {\b, from Unix}} 5 {emit {\b, from Atari}} 6 {emit {\b, from OS/2}} 7 {emit {\b, from MacOS}} 10 {emit {\b, from Tops/20}} 11 {emit {\b, from Win/32}}
+if {[N c 3 & 0x10]} {emit {\b, comment}}
+if {[N c 3 & 0x20]} {emit {\b, encrypted}}
+switch -- [Nv c 8] 2 {emit {\b, max compression}} 4 {emit {\b, max speed}}
+}
+if {[S 0 == {\037\036}]} {emit {packed data}
+if {[N I 2 > 0x1]} {emit {\b, %d characters originally}}
+if {[N I 2 == 0x1]} {emit {\b, %d character originally}}
+}
+if {[S 0 == {\377\037}]} {emit {compacted data}}
+if {[S 0 == BZh]} {emit {bzip2 compressed data}
+if {[N c 3 > 0x2f]} {emit {\b, block size = %c00k}}
+}
+if {[S 0 == {\037\237}]} {emit {frozen file 2.1}}
+if {[S 0 == {\037\236}]} {emit {frozen file 1.0 \(or gzip 0.5\)}}
+if {[S 0 == {\037\240}]} {emit {SCO compress -H \(LZH\) data}}
+if {[S 0 == BZ]} {emit {bzip compressed data}
+if {[N c 2 x {}]} {emit {\b, version: %c}}
+if {[S 3 == 1]} {emit {\b, compression block size 100k}}
+if {[S 3 == 2]} {emit {\b, compression block size 200k}}
+if {[S 3 == 3]} {emit {\b, compression block size 300k}}
+if {[S 3 == 4]} {emit {\b, compression block size 400k}}
+if {[S 3 == 5]} {emit {\b, compression block size 500k}}
+if {[S 3 == 6]} {emit {\b, compression block size 600k}}
+if {[S 3 == 7]} {emit {\b, compression block size 700k}}
+if {[S 3 == 8]} {emit {\b, compression block size 800k}}
+if {[S 3 == 9]} {emit {\b, compression block size 900k}}
+}
+if {[S 0 == {\x89\x4c\x5a\x4f\x00\x0d\x0a\x1a\x0a}]} {emit {lzop compressed data}
+if {[N S 9 < 0x940]} {if {[N c 9 == 0x0 &0xf0]} {emit {- version 0.}}
+if {[N S 9 x {} &0x0fff]} {emit {\b%03x,}}
+switch -- [Nv c 13] 1 {emit LZO1X-1,} 2 {emit {LZO1X-1\(15\),}} 3 {emit LZO1X-999,}
+switch -- [Nv c 14] 0 {emit {os: MS-DOS}} 1 {emit {os: Amiga}} 2 {emit {os: VMS}} 3 {emit {os: Unix}} 5 {emit {os: Atari}} 6 {emit {os: OS/2}} 7 {emit {os: MacOS}} 10 {emit {os: Tops/20}} 11 {emit {os: WinNT}} 14 {emit {os: Win32}}
+}
+if {[N S 9 > 0x939]} {switch -- [Nv c 9 &0xf0] 0 {emit {- version 0.}} 16 {emit {- version 1.}} 32 {emit {- version 2.}}
+if {[N S 9 x {} &0x0fff]} {emit {\b%03x,}}
+switch -- [Nv c 15] 1 {emit LZO1X-1,} 2 {emit {LZO1X-1\(15\),}} 3 {emit LZO1X-999,}
+switch -- [Nv c 17] 0 {emit {os: MS-DOS}} 1 {emit {os: Amiga}} 2 {emit {os: VMS}} 3 {emit {os: Unix}} 5 {emit {os: Atari}} 6 {emit {os: OS/2}} 7 {emit {os: MacOS}} 10 {emit {os: Tops/20}} 11 {emit {os: WinNT}} 14 {emit {os: Win32}}
+}
+}
+if {[S 0 == {\037\241}]} {emit {Quasijarus strong compressed data}}
+if {[S 0 == XPKF]} {emit {Amiga xpkf.library compressed data}}
+if {[S 0 == PP11]} {emit {Power Packer 1.1 compressed data}}
+if {[S 0 == PP20]} {emit {Power Packer 2.0 compressed data,}
+switch -- [Nv I 4] 151587081 {emit {fast compression}} 151652874 {emit {mediocre compression}} 151653131 {emit {good compression}} 151653388 {emit {very good compression}} 151653389 {emit {best compression}}
+}
+if {[S 0 == {7z\274\257\047\034}]} {emit {7z archive data,}
+if {[N c 6 x {}]} {emit {version %d}}
+if {[N c 7 x {}]} {emit {\b.%d}}
+}
+if {[S 2 == -afx-]} {emit {AFX compressed file data}}
+if {[S 0 == {NES\032}]} {emit {iNES ROM dump,}
+if {[N c 4 x {}]} {emit {%dx16k PRG}}
+if {[N c 5 x {}]} {emit {\b, %dx8k CHR}}
+switch -- [Nv c 6 &0x01] 1 {emit {\b, [Vert.]}} 0 {emit {\b, [Horiz.]}}
+if {[N c 6 == 0x2 &0x02]} {emit {\b, [SRAM]}}
+switch -- [Nv c 6 &0x04] 4 {emit {\b, [Trainer]}} 8 {emit {\b, [4-Scr]}}
+}
+if {[N I 260 == 0xceed6666]} {emit {Gameboy ROM:}
+if {[S 308 x {}]} {emit {\"%.16s\"}}
+if {[N c 326 == 0x3]} {emit {\b,[SGB]}}
+switch -- [Nv c 327] 0 {emit {\b, [ROM ONLY]}} 1 {emit {\b, [ROM+MBC1]}} 2 {emit {\b, [ROM+MBC1+RAM]}} 3 {emit {\b, [ROM+MBC1+RAM+BATT]}} 5 {emit {\b, [ROM+MBC2]}} 6 {emit {\b, [ROM+MBC2+BATTERY]}} 8 {emit {\b, [ROM+RAM]}} 9 {emit {\b, [ROM+RAM+BATTERY]}} 11 {emit {\b, [ROM+MMM01]}} 12 {emit {\b, [ROM+MMM01+SRAM]}} 13 {emit {\b, [ROM+MMM01+SRAM+BATT]}} 15 {emit {\b, [ROM+MBC3+TIMER+BATT]}} 16 {emit {\b, [ROM+MBC3+TIMER+RAM+BATT]}} 17 {emit {\b, [ROM+MBC3]}} 18 {emit {\b, [ROM+MBC3+RAM]}} 19 {emit {\b, [ROM+MBC3+RAM+BATT]}} 25 {emit {\b, [ROM+MBC5]}} 26 {emit {\b, [ROM+MBC5+RAM]}} 27 {emit {\b, [ROM+MBC5+RAM+BATT]}} 28 {emit {\b, [ROM+MBC5+RUMBLE]}} 29 {emit {\b, [ROM+MBC5+RUMBLE+SRAM]}} 30 {emit {\b, [ROM+MBC5+RUMBLE+SRAM+BATT]}} 31 {emit {\b, [Pocket Camera]}} -3 {emit {\b, [Bandai TAMA5]}} -2 {emit {\b, [Hudson HuC-3]}} -1 {emit {\b, [Hudson HuC-1]}}
+switch -- [Nv c 328] 0 {emit {\b, ROM: 256Kbit}} 1 {emit {\b, ROM: 512Kbit}} 2 {emit {\b, ROM: 1Mbit}} 3 {emit {\b, ROM: 2Mbit}} 4 {emit {\b, ROM: 4Mbit}} 5 {emit {\b, ROM: 8Mbit}} 6 {emit {\b, ROM: 16Mbit}} 82 {emit {\b, ROM: 9Mbit}} 83 {emit {\b, ROM: 10Mbit}} 84 {emit {\b, ROM: 12Mbit}}
+switch -- [Nv c 329] 1 {emit {\b, RAM: 16Kbit}} 2 {emit {\b, RAM: 64Kbit}} 3 {emit {\b, RAM: 128Kbit}} 4 {emit {\b, RAM: 1Mbit}}
+}
+if {[S 256 == SEGA]} {emit {Sega MegaDrive/Genesis raw ROM dump}
+if {[S 288 x {}]} {emit {Name: \"%.16s\"}}
+if {[S 272 x {}]} {emit %.16s}
+if {[S 432 == RA]} {emit {with SRAM}}
+}
+if {[S 640 == EAGN]} {emit {Super MagicDrive ROM dump}
+if {[N c 0 x {}]} {emit {%dx16k blocks}}
+if {[N c 2 == 0x0]} {emit {\b, last in series or standalone}}
+if {[N c 2 > 0x0]} {emit {\b, split ROM}}
+if {[N c 8 == 0xaa]} {emit 298 3}
+if {[N c 9 == 0xbb]} {emit 298 4}
+}
+if {[S 640 == EAMG]} {emit {Super MagicDrive ROM dump}
+if {[N c 0 x {}]} {emit {%dx16k blocks}}
+if {[N c 2 x {}]} {emit {\b, last in series or standalone}}
+if {[N c 8 == 0xaa]} {emit 299 2}
+if {[N c 9 == 0xbb]} {emit 299 3}
+}
+if {[S 0 == LCDi]} {emit {Dream Animator file}}
+if {[S 0 == {PS-X\ EXE}]} {emit {Sony Playstation executable}
+if {[S 113 x {}]} {emit {\(%s\)}}
+}
+if {[S 0 == XBEH]} {emit {XBE, Microsoft Xbox executable}
+if {[Nx 2 i 4 == 0x0]} {if {[Nx 3 i [R 2] == 0x0]} {if {[N i [R 2] == 0x0]} {emit {\b, not signed}}
+}
+}
+if {[Nx 2 i 4 > 0x0]} {if {[Nx 3 i [R 2] > 0x0]} {if {[N i [R 2] > 0x0]} {emit {\b, signed}}
+}
+}
+if {[N i 260 == 0x10000]} {if {[N i [I 280 Q -65376] == 0x80000007 &0x80000007]} {emit {\b, all regions}}
+if {[N i [I 280 Q -65376] != 0x80000007 &0x80000007]} {if {[N i [I 280 Q -65376] > 0x0]} {emit {\(regions:}
+if {[N i [I 280 Q -65376] & 0x1]} {emit NA}
+if {[N i [I 280 Q -65376] & 0x2]} {emit Japan}
+if {[N i [I 280 Q -65376] & 0x4]} {emit Rest_of_World}
+if {[N i [I 280 Q -65376] & 0x80000000]} {emit Manufacturer}
+}
+if {[N i [I 280 Q -65376] > 0x0]} {emit {\b\)}}
+}
+}
+}
+if {[S 0 == XIP0]} {emit {XIP, Microsoft Xbox data}}
+if {[S 0 == XTF0]} {emit {XTF, Microsoft Xbox data}}
+if {[S 0 == Glul]} {emit {Glulx game data}
+if {[S 8 == IFRS]} {emit {\b, Blorb Interactive Fiction}
+if {[S 24 == Exec]} {emit {with executable chunk}}
+}
+if {[S 8 == IFZS]} {emit {\b, Z-machine or Glulx saved game file \(Quetzal\)}}
+}
+switch -- [Nv I 24] 60011 {emit {dump format, 4.1 BSD or earlier}} 60012 {emit {dump format, 4.2 or 4.3 BSD without IDC}} 60013 {emit {dump format, 4.2 or 4.3 BSD \(IDC compatible\)}} 60014 {emit {dump format, Convex Storage Manager by-reference dump}} 60012 {emit {new-fs dump file \(big endian\),}
+if {[N S 4 x {}]} {emit {Previous dump %s,}}
+if {[N S 8 x {}]} {emit {This dump %s,}}
+if {[N I 12 > 0x0]} {emit {Volume %ld,}}
+if {[N I 692 == 0x0]} {emit {Level zero, type:}}
+if {[N I 692 > 0x0]} {emit {Level %d, type:}}
+switch -- [Nv I 0] 1 {emit {tape header,}} 2 {emit {beginning of file record,}} 3 {emit {map of inodes on tape,}} 4 {emit {continuation of file record,}} 5 {emit {end of volume,}} 6 {emit {map of inodes deleted,}} 7 {emit {end of medium \(for floppy\),}}
+if {[S 676 x {}]} {emit {Label %s,}}
+if {[S 696 x {}]} {emit {Filesystem %s,}}
+if {[S 760 x {}]} {emit {Device %s,}}
+if {[S 824 x {}]} {emit {Host %s,}}
+if {[N I 888 > 0x0]} {emit {Flags %x}}
+} 60011 {emit {old-fs dump file \(big endian\),}
+if {[N I 12 > 0x0]} {emit {Volume %ld,}}
+if {[N I 692 == 0x0]} {emit {Level zero, type:}}
+if {[N I 692 > 0x0]} {emit {Level %d, type:}}
+switch -- [Nv I 0] 1 {emit {tape header,}} 2 {emit {beginning of file record,}} 3 {emit {map of inodes on tape,}} 4 {emit {continuation of file record,}} 5 {emit {end of volume,}} 6 {emit {map of inodes deleted,}} 7 {emit {end of medium \(for floppy\),}}
+if {[S 676 x {}]} {emit {Label %s,}}
+if {[S 696 x {}]} {emit {Filesystem %s,}}
+if {[S 760 x {}]} {emit {Device %s,}}
+if {[S 824 x {}]} {emit {Host %s,}}
+if {[N I 888 > 0x0]} {emit {Flags %x}}
+}
+if {[S 0 == !_TAG]} {emit {Exuberant Ctags tag file text}}
+if {[S 0 == GDBM]} {emit {GNU dbm 2.x database}}
+switch -- [Nv Q 12] 398689 {emit {Berkeley DB}
+if {[N Q 16 > 0x0]} {emit {\(Hash, version %d, native byte-order\)}}
+} 340322 {emit {Berkeley DB}
+if {[N Q 16 > 0x0]} {emit {\(Btree, version %d, native byte-order\)}}
+} 270931 {emit {Berkeley DB}
+if {[N Q 16 > 0x0]} {emit {\(Queue, version %d, native byte-order\)}}
+} 264584 {emit {Berkeley DB}
+if {[N Q 16 > 0x0]} {emit {\(Log, version %d, native byte-order\)}}
+}
+switch -- [Nv I 12] 398689 {emit {Berkeley DB}
+if {[N I 16 > 0x0]} {emit {\(Hash, version %d, big-endian\)}}
+} 340322 {emit {Berkeley DB}
+if {[N I 16 > 0x0]} {emit {\(Btree, version %d, big-endian\)}}
+} 270931 {emit {Berkeley DB}
+if {[N I 16 > 0x0]} {emit {\(Queue, version %d, big-endian\)}}
+} 264584 {emit {Berkeley DB}
+if {[N I 16 > 0x0]} {emit {\(Log, version %d, big-endian\)}}
+}
+switch -- [Nv i 12] 398689 {emit {Berkeley DB}
+if {[N i 16 > 0x0]} {emit {\(Hash, version %d, little-endian\)}}
+} 340322 {emit {Berkeley DB}
+if {[N i 16 > 0x0]} {emit {\(Btree, version %d, little-endian\)}}
+} 270931 {emit {Berkeley DB}
+if {[N i 16 > 0x0]} {emit {\(Queue, version %d, little-endian\)}}
+} 264584 {emit {Berkeley DB}
+if {[N i 16 > 0x0]} {emit {\(Log, version %d, little-endian\)}}
+}
+if {[S 0 == RRD]} {emit {RRDTool DB}
+if {[S 4 x {}]} {emit {version %s}}
+}
+if {[S 0 == {root\0}]} {emit {ROOT file}
+if {[N I 4 x {}]} {emit {Version %d}}
+if {[N I 33 x {}]} {emit {\(Compression: %d\)}}
+}
+if {[S 4 == {Standard\ Jet\ DB}]} {emit {Microsoft Access Database}}
+if {[S 0 == {TDB\ file}]} {emit {TDB database}
+if {[N i 32 == 0x2601196d]} {emit {version 6, little-endian}
+if {[N i 36 x {}]} {emit {hash size %d bytes}}
+}
+}
+if {[S 2 == ICE]} {emit {ICE authority data}}
+if {[S 10 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}}
+if {[S 11 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}}
+if {[S 12 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}}
+if {[S 13 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}}
+if {[S 14 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}}
+if {[S 15 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}}
+if {[S 16 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}}
+if {[S 17 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}}
+if {[S 18 == MIT-MAGIC-COOKIE-1]} {emit {X11 Xauthority data}}
+if {[S 0 == {<list>\n<protocol\ bbn-m}]} {emit {Diamond Multimedia Document}}
+if {[S 0 == {diff\ }]} {emit {'diff' output text}}
+if {[S 0 == {***\ }]} {emit {'diff' output text}}
+if {[S 0 == {Only\ in\ }]} {emit {'diff' output text}}
+if {[S 0 == {Common\ subdirectories:\ }]} {emit {'diff' output text}}
+if {[S 0 == {!<arch>\n________64E}]} {emit {Alpha archive}
+if {[S 22 == X]} {emit {-- out of date}}
+}
+if {[S 0 == {\377\377\177}]} {emit ddis/ddif}
+if {[S 0 == {\377\377\174}]} {emit {ddis/dots archive}}
+if {[S 0 == {\377\377\176}]} {emit {ddis/dtif table data}}
+if {[S 0 == {\033c\033}]} {emit {LN03 output}}
+if {[S 0 == {!<PDF>!\n}]} {emit {profiling data file}}
+switch -- [Nv i 24] 60012 {emit {new-fs dump file \(little endian\),}
+if {[N s 4 x {}]} {emit {This dump %s,}}
+if {[N s 8 x {}]} {emit {Previous dump %s,}}
+if {[N i 12 > 0x0]} {emit {Volume %ld,}}
+if {[N i 692 == 0x0]} {emit {Level zero, type:}}
+if {[N i 692 > 0x0]} {emit {Level %d, type:}}
+switch -- [Nv i 0] 1 {emit {tape header,}} 2 {emit {beginning of file record,}} 3 {emit {map of inodes on tape,}} 4 {emit {continuation of file record,}} 5 {emit {end of volume,}} 6 {emit {map of inodes deleted,}} 7 {emit {end of medium \(for floppy\),}}
+if {[S 676 x {}]} {emit {Label %s,}}
+if {[S 696 x {}]} {emit {Filesystem %s,}}
+if {[S 760 x {}]} {emit {Device %s,}}
+if {[S 824 x {}]} {emit {Host %s,}}
+if {[N i 888 > 0x0]} {emit {Flags %x}}
+} 60011 {emit {old-fs dump file \(little endian\),}
+if {[N i 12 > 0x0]} {emit {Volume %ld,}}
+if {[N i 692 == 0x0]} {emit {Level zero, type:}}
+if {[N i 692 > 0x0]} {emit {Level %d, type:}}
+switch -- [Nv i 0] 1 {emit {tape header,}} 2 {emit {beginning of file record,}} 3 {emit {map of inodes on tape,}} 4 {emit {continuation of file record,}} 5 {emit {end of volume,}} 6 {emit {map of inodes deleted,}} 7 {emit {end of medium \(for floppy\),}}
+if {[S 676 x {}]} {emit {Label %s,}}
+if {[S 696 x {}]} {emit {Filesystem %s,}}
+if {[S 760 x {}]} {emit {Device %s,}}
+if {[S 824 x {}]} {emit {Host %s,}}
+if {[N i 888 > 0x0]} {emit {Flags %x}}
+}
+switch -- [Nv c 0] -86 {emit {}
+if {[N c 1 < 0x4]} {emit {Dyalog APL}
+switch -- [Nv c 1] 0 {emit {incomplete workspace}} 1 {emit {component file}} 2 {emit {external variable}} 3 {emit workspace}
+if {[N c 2 x {}]} {emit {version %d}}
+if {[N c 3 x {}]} {emit .%d}
+}
+} 3 {emit {DBase 3 data file}
+if {[N i 4 == 0x0]} {emit {\(no records\)}}
+if {[N i 4 > 0x0]} {emit {\(%ld records\)}}
+} -125 {emit {DBase 3 data file with memo\(s\)}
+if {[N i 4 == 0x0]} {emit {\(no records\)}}
+if {[N i 4 > 0x0]} {emit {\(%ld records\)}}
+} 38 {emit {Sendmail frozen configuration}
+if {[S 16 x {}]} {emit {- version %s}}
+} -16 {emit {SysEx File -}
+switch -- [Nv c 1] 1 {emit Sequential} 2 {emit IDP} 3 {emit OctavePlateau} 4 {emit Moog} 5 {emit Passport} 6 {emit Lexicon} 7 {emit Kurzweil} 8 {emit Fender} 9 {emit Gulbransen} 10 {emit AKG} 11 {emit Voyce} 12 {emit Waveframe} 13 {emit ADA} 14 {emit Garfield} 15 {emit Ensoniq} 16 {emit Oberheim} 17 {emit Apple} 18 {emit GreyMatter} 20 {emit PalmTree} 21 {emit JLCooper} 22 {emit Lowrey} 23 {emit AdamsSmith} 24 {emit E-mu} 25 {emit Harmony} 26 {emit ART} 27 {emit Baldwin} 28 {emit Eventide} 29 {emit Inventronics} 31 {emit Clarity} 33 {emit SIEL} 34 {emit Synthaxe} 36 {emit Hohner} 37 {emit Twister} 38 {emit Solton} 39 {emit Jellinghaus} 40 {emit Southworth} 41 {emit PPG} 42 {emit JEN} 43 {emit SSL} 44 {emit AudioVertrieb} 47 {emit ELKA
+if {[N c 3 == 0x9]} {emit EK-44}
+} 48 {emit Dynacord} 51 {emit Clavia} 57 {emit Soundcraft} 62 {emit Waldorf
+if {[N c 3 == 0x7f]} {emit {Microwave I}}
+} 64 {emit Kawai
+switch -- [Nv c 3] 32 {emit K1} 34 {emit K4}
+} 65 {emit Roland
+switch -- [Nv c 3] 20 {emit D-50} 43 {emit U-220} 2 {emit TR-707}
+} 66 {emit Korg
+if {[N c 3 == 0x19]} {emit M1}
+} 67 {emit Yamaha} 68 {emit Casio} 70 {emit Kamiya} 71 {emit Akai} 72 {emit Victor} 73 {emit Mesosha} 75 {emit Fujitsu} 76 {emit Sony} 78 {emit Teac} 80 {emit Matsushita} 81 {emit Fostex} 82 {emit Zoom} 84 {emit Matsushita} 87 {emit {Acoustic tech. lab.}}
+switch -- [Nv I 1 &0xffffff00] 29696 {emit {Ta Horng}} 29952 {emit e-Tek} 30208 {emit E-Voice} 30464 {emit Midisoft} 30720 {emit Q-Sound} 30976 {emit Westrex} 31232 {emit Nvidia*} 31488 {emit ESS} 31744 {emit Mediatrix} 32000 {emit Brooktree} 32256 {emit Otari} 32512 {emit {Key Electronics}} 65536 {emit Shure} 65792 {emit AuraSound} 66048 {emit Crystal} 66304 {emit Rockwell} 66560 {emit {Silicon Graphics}} 66816 {emit Midiman} 67072 {emit PreSonus} 67584 {emit Topaz} 67840 {emit {Cast Lightning}} 68096 {emit Microsoft} 68352 {emit {Sonic Foundry}} 68608 {emit {Line 6}} 68864 {emit {Beatnik Inc.}} 69120 {emit {Van Koerving}} 69376 {emit {Altech Systems}} 69632 {emit {S & S Research}} 69888 {emit {VLSI Technology}} 70144 {emit Chromatic} 70400 {emit Sapphire} 70656 {emit IDRC} 70912 {emit {Justonic Tuning}} 71168 {emit TorComp} 71424 {emit {Newtek Inc.}} 71680 {emit {Sound Sculpture}} 71936 {emit {Walker Technical}} 72192 {emit {Digital Harmony}} 72448 {emit InVision} 72704 {emit T-Square} 72960 {emit Nemesys} 73216 {emit DBX} 73472 {emit Syndyne} 73728 {emit {Bitheadz }} 73984 {emit Cakewalk} 74240 {emit Staccato} 74496 {emit {National Semicon.}} 74752 {emit {Boom Theory}} 75008 {emit {Virtual DSP Corp}} 75264 {emit Antares} 75520 {emit {Angel Software}} 75776 {emit {St Louis Music}} 76032 {emit {Lyrrus dba G-VOX}} 76288 {emit {Ashley Audio}} 76544 {emit Vari-Lite} 76800 {emit {Summit Audio}} 77056 {emit {Aureal Semicon.}} 77312 {emit SeaSound} 77568 {emit {U.S. Robotics}} 77824 {emit Aurisis} 78080 {emit {Nearfield Multimedia}} 78336 {emit {FM7 Inc.}} 78592 {emit {Swivel Systems}} 78848 {emit Hyperactive} 79104 {emit MidiLite} 79360 {emit Radical} 79616 {emit {Roger Linn}} 79872 {emit Helicon} 80128 {emit Event} 80384 {emit {Sonic Network}} 80640 {emit {Realtime Music}} 80896 {emit {Apogee Digital}} 2108160 {emit {Medeli Electronics}} 2108416 {emit {Charlie Lab}} 2108672 {emit {Blue Chip Music}} 2108928 {emit {BEE OH Corp}} 2109184 {emit {LG Semicon America}} 2109440 {emit TESI} 2109696 {emit EMAGIC} 2109952 {emit Behringer} 2110208 {emit {Access Music}} 2110464 {emit Synoptic} 2110720 {emit {Hanmesoft Corp}} 2110976 {emit Terratec} 2111232 {emit {Proel SpA}} 2111488 {emit {IBK MIDI}} 2111744 {emit IRCAM} 2112000 {emit {Propellerhead Software}} 2112256 {emit {Red Sound Systems}} 2112512 {emit {Electron ESI AB}} 2112768 {emit {Sintefex Audio}} 2113024 {emit {Music and More}} 2113280 {emit Amsaro} 2113536 {emit {CDS Advanced Technology}} 2113792 {emit {Touched by Sound}} 2114048 {emit {DSP Arts}} 2114304 {emit {Phil Rees Music}} 2114560 {emit {Stamer Musikanlagen GmbH}} 2114816 {emit Soundart} 2115072 {emit {C-Mexx Software}} 2115328 {emit {Klavis Tech.}} 2115584 {emit {Noteheads AB}}
+} -128 {emit {8086 relocatable \(Microsoft\)}}
+if {[S 0 == {@CT\ }]} {emit {T602 document data,}
+if {[S 4 == 0]} {emit Kamenicky}
+if {[S 4 == 1]} {emit {CP 852}}
+if {[S 4 == 2]} {emit KOI8-CS}
+if {[S 4 > 2]} {emit {unknown encoding}}
+}
+if {[S 0 == VimCrypt~]} {emit {Vim encrypted file data}}
+if {[S 0 == {\177ELF}]} {emit ELF
+switch -- [Nv c 4] 0 {emit {invalid class}} 1 {emit 32-bit
+switch -- [Nv s 18] 8 {emit {}
+if {[N i 36 & 0x20]} {emit N32}
+} 10 {emit {}
+if {[N i 36 & 0x20]} {emit N32}
+}
+switch -- [Nv S 18] 8 {emit {}
+if {[N I 36 & 0x20]} {emit N32}
+} 10 {emit {}
+if {[N I 36 & 0x20]} {emit N32}
+}
+} 2 {emit 64-bit}
+switch -- [Nv c 5] 0 {emit {invalid byte order}} 1 {emit LSB
+switch -- [Nv s 18] 8 {emit {}
+switch -- [Nv c 4] 1 {emit {}
+switch -- [Nv i 36 &0xf0000000] 0 {emit MIPS-I} 268435456 {emit MIPS-II} 536870912 {emit MIPS-III} 805306368 {emit MIPS-IV} 1073741824 {emit MIPS-V} 1610612736 {emit MIPS32} 1879048192 {emit MIPS64} -2147483648 {emit {MIPS32 rel2}} -1879048192 {emit {MIPS64 rel2}}
+} 2 {emit {}
+switch -- [Nv i 48 &0xf0000000] 0 {emit MIPS-I} 268435456 {emit MIPS-II} 536870912 {emit MIPS-III} 805306368 {emit MIPS-IV} 1073741824 {emit MIPS-V} 1610612736 {emit MIPS32} 1879048192 {emit MIPS64} -2147483648 {emit {MIPS32 rel2}} -1879048192 {emit {MIPS64 rel2}}
+}
+} 0 {emit {no machine,}} 1 {emit {AT&T WE32100 - invalid byte order,}} 2 {emit {SPARC - invalid byte order,}} 3 {emit {Intel 80386,}} 4 {emit Motorola
+if {[N i 36 & 0x1000000]} {emit {68000 - invalid byte order,}}
+if {[N i 36 & 0x810000]} {emit {CPU32 - invalid byte order,}}
+if {[N i 36 == 0x0]} {emit {68020 - invalid byte order,}}
+} 5 {emit {Motorola 88000 - invalid byte order,}} 6 {emit {Intel 80486,}} 7 {emit {Intel 80860,}} 8 {emit MIPS,} 9 {emit {Amdahl - invalid byte order,}} 10 {emit {MIPS \(deprecated\),}} 11 {emit {RS6000 - invalid byte order,}} 15 {emit {PA-RISC - invalid byte order,}
+if {[N s 50 == 0x214]} {emit 2.0}
+if {[N s 48 & 0x8]} {emit {\(LP64\),}}
+} 16 {emit nCUBE,} 17 {emit {Fujitsu VPP500,}} 18 {emit SPARC32PLUS,} 20 {emit PowerPC,} 22 {emit {IBM S/390,}} 36 {emit {NEC V800,}} 37 {emit {Fujitsu FR20,}} 38 {emit {TRW RH-32,}} 39 {emit {Motorola RCE,}} 40 {emit ARM,} 41 {emit Alpha,} -23664 {emit {IBM S/390 \(obsolete\),}} 42 {emit {Hitachi SH,}} 43 {emit {SPARC V9 - invalid byte order,}} 44 {emit {Siemens Tricore Embedded Processor,}} 45 {emit {Argonaut RISC Core, Argonaut Technologies Inc.,}} 46 {emit {Hitachi H8/300,}} 47 {emit {Hitachi H8/300H,}} 48 {emit {Hitachi H8S,}} 49 {emit {Hitachi H8/500,}} 50 {emit {IA-64 \(Intel 64 bit architecture\)}} 51 {emit {Stanford MIPS-X,}} 52 {emit {Motorola Coldfire,}} 53 {emit {Motorola M68HC12,}} 62 {emit {AMD x86-64,}} 75 {emit {Digital VAX,}} 88 {emit {Renesas M32R,}} 97 {emit {NatSemi 32k,}} -28634 {emit {Alpha \(unofficial\),}}
+switch -- [Nv s 16] 0 {emit {no file type,}} 1 {emit relocatable,} 2 {emit executable,} 3 {emit {shared object,}} 4 {emit {core file}}
+if {[N s 16 & 0xff00]} {emit processor-specific,}
+switch -- [Nv i 20] 0 {emit {invalid version}} 1 {emit {version 1}}
+if {[N i 36 == 0x1]} {emit {MathCoPro/FPU/MAU Required}}
+} 2 {emit MSB
+switch -- [Nv S 18] 8 {emit {}
+switch -- [Nv c 4] 1 {emit {}
+switch -- [Nv I 36 &0xf0000000] 0 {emit MIPS-I} 268435456 {emit MIPS-II} 536870912 {emit MIPS-III} 805306368 {emit MIPS-IV} 1073741824 {emit MIPS-V} 1610612736 {emit MIPS32} 1879048192 {emit MIPS64} -2147483648 {emit {MIPS32 rel2}} -1879048192 {emit {MIPS64 rel2}}
+} 2 {emit {}
+switch -- [Nv I 48 &0xf0000000] 0 {emit MIPS-I} 268435456 {emit MIPS-II} 536870912 {emit MIPS-III} 805306368 {emit MIPS-IV} 1073741824 {emit MIPS-V} 1610612736 {emit MIPS32} 1879048192 {emit MIPS64} -2147483648 {emit {MIPS32 rel2}} -1879048192 {emit {MIPS64 rel2}}
+}
+} 0 {emit {no machine,}} 1 {emit {AT&T WE32100,}} 2 {emit SPARC,} 3 {emit {Intel 80386 - invalid byte order,}} 4 {emit Motorola
+if {[N I 36 & 0x1000000]} {emit 68000,}
+if {[N I 36 & 0x810000]} {emit CPU32,}
+if {[N I 36 == 0x0]} {emit 68020,}
+} 5 {emit {Motorola 88000,}} 6 {emit {Intel 80486 - invalid byte order,}} 7 {emit {Intel 80860,}} 8 {emit MIPS,} 9 {emit Amdahl,} 10 {emit {MIPS \(deprecated\),}} 11 {emit RS6000,} 15 {emit PA-RISC
+if {[N S 50 == 0x214]} {emit 2.0}
+if {[N S 48 & 0x8]} {emit {\(LP64\)}}
+} 16 {emit nCUBE,} 17 {emit {Fujitsu VPP500,}} 18 {emit SPARC32PLUS,
+if {[N I 36 & 0x100 &0xffff00]} {emit {V8+ Required,}}
+if {[N I 36 & 0x200 &0xffff00]} {emit {Sun UltraSPARC1 Extensions Required,}}
+if {[N I 36 & 0x400 &0xffff00]} {emit {HaL R1 Extensions Required,}}
+if {[N I 36 & 0x800 &0xffff00]} {emit {Sun UltraSPARC3 Extensions Required,}}
+} 20 {emit {PowerPC or cisco 4500,}} 21 {emit {cisco 7500,}} 22 {emit {IBM S/390,}} 24 {emit {cisco SVIP,}} 25 {emit {cisco 7200,}} 36 {emit {NEC V800 or cisco 12000,}} 37 {emit {Fujitsu FR20,}} 38 {emit {TRW RH-32,}} 39 {emit {Motorola RCE,}} 40 {emit ARM,} 41 {emit Alpha,} 42 {emit {Hitachi SH,}} 43 {emit {SPARC V9,}} 44 {emit {Siemens Tricore Embedded Processor,}} 45 {emit {Argonaut RISC Core, Argonaut Technologies Inc.,}} 46 {emit {Hitachi H8/300,}} 47 {emit {Hitachi H8/300H,}} 48 {emit {Hitachi H8S,}} 49 {emit {Hitachi H8/500,}} 50 {emit {Intel Merced Processor,}} 51 {emit {Stanford MIPS-X,}} 52 {emit {Motorola Coldfire,}} 53 {emit {Motorola M68HC12,}} 73 {emit {Cray NV1,}} 75 {emit {Digital VAX,}} 88 {emit {Renesas M32R,}} 97 {emit {NatSemi 32k,}} -28634 {emit {Alpha \(unofficial\),}} -23664 {emit {IBM S/390 \(obsolete\),}}
+switch -- [Nv S 16] 0 {emit {no file type,}} 1 {emit relocatable,} 2 {emit executable,} 3 {emit {shared object,}} 4 {emit {core file,}}
+if {[N S 16 & 0xff00]} {emit processor-specific,}
+switch -- [Nv I 20] 0 {emit {invalid version}} 1 {emit {version 1}}
+if {[N I 36 == 0x1]} {emit {MathCoPro/FPU/MAU Required}}
+}
+if {[N c 4 < 0x80]} {if {[S 8 x {}]} {emit {\(%s\)}}
+}
+if {[S 8 == {\0}]} {switch -- [Nv c 7] 0 {emit {\(SYSV\)}} 1 {emit {\(HP-UX\)}} 2 {emit {\(NetBSD\)}} 3 {emit {\(GNU/Linux\)}} 4 {emit {\(GNU/Hurd\)}} 5 {emit {\(86Open\)}} 6 {emit {\(Solaris\)}} 7 {emit {\(Monterey\)}} 8 {emit {\(IRIX\)}} 9 {emit {\(FreeBSD\)}} 10 {emit {\(Tru64\)}} 11 {emit {\(Novell Modesto\)}} 12 {emit {\(OpenBSD\)}} 97 {emit {\(ARM\)}} -1 {emit {\(embedded\)}}
+}
+}
+if {[N i 4 == 0x1000006d]} {emit {{7 lelong {} == 8 0x1000007f Word} {8 lelong {} == 8 0x10000088 Sheet} {9 lelong {} == 8 0x1000007d Sketch} {10 lelong {} == 8 0x10000085 TextEd}}}
+if {[S 0 == FCS1.0]} {emit {Flow Cytometry Standard \(FCS\) data, version 1.0}}
+if {[S 0 == FCS2.0]} {emit {Flow Cytometry Standard \(FCS\) data, version 2.0}}
+if {[S 0 == FCS3.0]} {emit {Flow Cytometry Standard \(FCS\) data, version 3.0}}
+if {[S 0 == {\366\366\366\366}]} {emit {PC formatted floppy with no filesystem}}
+if {[N S 508 == 0xdabe]} {emit {Sun disk label}
+if {[S 0 x {}]} {emit '%s
+if {[S 31 x {}]} {emit {\b%s}
+if {[S 63 x {}]} {emit {\b%s}
+if {[S 95 x {}]} {emit {\b%s}}
+}
+}
+}
+if {[S 0 x {}]} {emit {\b'}}
+if {[N Y 476 > 0x0]} {emit {%d rpm,}}
+if {[N Y 478 > 0x0]} {emit {%d phys cys,}}
+if {[N Y 480 > 0x0]} {emit {%d alts/cyl,}}
+if {[N Y 486 > 0x0]} {emit {%d interleave,}}
+if {[N Y 488 > 0x0]} {emit {%d data cyls,}}
+if {[N Y 490 > 0x0]} {emit {%d alt cyls,}}
+if {[N Y 492 > 0x0]} {emit {%d heads/partition,}}
+if {[N Y 494 > 0x0]} {emit {%d sectors/track,}}
+if {[N Q 500 > 0x0]} {emit {start cyl %ld,}}
+if {[N Q 504 x {}]} {emit {%ld blocks}}
+if {[N I 512 == 0x30107 &077777777]} {emit {\b, boot block present}}
+}
+if {[S 0 == {DOSEMU\0}]} {if {[N s 638 == 0xaa55]} {emit {DOS Emulator image}}
+}
+if {[N s 510 == 0xaa55]} {emit {x86 boot sector}
+if {[S 2 == OSBS]} {emit {\b, OS/BS MBR}}
+if {[S 140 == {Invalid\ partition\ table}]} {emit {\b, MS-DOS MBR}}
+if {[S 157 == {Invalid\ partition\ table$}]} {if {[S 181 == {No\ Operating\ System$}]} {if {[S 201 == {Operating\ System\ load\ error$}]} {emit {\b, DR-DOS MBR, Version 7.01 to 7.03}}
+}
+}
+if {[S 157 == {Invalid\ partition\ table$}]} {if {[S 181 == {No\ operating\ system$}]} {if {[S 201 == {Operating\ system\ load\ error$}]} {emit {\b, DR-DOS MBR, Version 7.01 to 7.03}}
+}
+}
+if {[S 342 == {Invalid\ partition\ table$}]} {if {[S 366 == {No\ operating\ system$}]} {if {[S 386 == {Operating\ system\ load\ error$}]} {emit {\b, DR-DOS MBR, version 7.01 to 7.03}}
+}
+}
+if {[S 295 == {NEWLDR\0}]} {if {[S 302 == {Bad\ PT\ $}]} {if {[S 310 == {No\ OS\ $}]} {if {[S 317 == {OS\ load\ err$}]} {if {[S 329 == {Moved\ or\ missing\ IBMBIO.LDR\n\r}]} {if {[S 358 == {Press\ any\ key\ to\ continue.\n\r$}]} {if {[S 387 == {Copyright\ (c)\ 1984,1998}]} {if {[S 411 == {Caldera\ Inc.\0}]} {emit {\b, DR-DOS MBR \(IBMBIO.LDR\)}}
+}
+}
+}
+}
+}
+}
+}
+if {[S 271 == {Ung\201ltige\ Partitionstabelle}]} {emit {\b, MS-DOS MBR, german version 4.10.1998, 4.10.2222}}
+if {[S 139 == {Ung\201ltige\ Partitionstabelle}]} {emit {\b, MS-DOS MBR, german version 5.00 to 4.00.950}}
+if {[S 300 == {Invalid\ partition\ table\0}]} {if {[S 324 == {Error\ loading\ operating\ system\0}]} {if {[S 355 == {Missing\ operating\ system\0}]} {emit {\b, Microsoft Windows XP MBR}}
+}
+}
+if {[S 300 == {Ung\201ltige\ Partitionstabelle}]} {if {[S 328 == {Fehler\ beim\ Laden\ }]} {if {[S 346 == {des\ Betriebssystems}]} {if {[S 366 == {Betriebssystem\ nicht\ vorhanden}]} {emit {\b, Microsoft Windows XP MBR \(german\)}}
+}
+}
+}
+if {[S 325 == {Default:\ F}]} {emit {\b, FREE-DOS MBR}}
+if {[S 64 == {no\ active\ partition\ found}]} {if {[S 96 == {read\ error\ while\ reading\ drive}]} {emit {\b, FREE-DOS Beta9 MBR}}
+}
+if {[S 43 == {SMART\ BTMGRFAT12\ \ \ }]} {if {[S 430 == {SBMK\ Bad!\r}]} {if {[S 3 == SBM]} {emit {\b, Smart Boot Manager}
+if {[S 6 x {}]} {emit {\b, version %s}}
+}
+}
+}
+if {[S 382 == XOSLLOADXCF]} {emit {\b, EXtended Operating System Loader}}
+if {[S 6 == LILO]} {emit {\b, LInux i386 boot LOader}
+if {[S 120 == LILO]} {emit {\b, version 22.3.4 SuSe}}
+if {[S 172 == LILO]} {emit {\b, version 22.5.8 Debian}}
+}
+if {[S 402 == {Geom\0Hard\ Disk\0Read\0\ Error\0}]} {if {[S 394 == stage1]} {emit {\b, GRand Unified Bootloader \(0.5.95\)}}
+}
+if {[S 380 == {Geom\0Hard\ Disk\0Read\0\ Error\0}]} {if {[S 374 == {GRUB\ \0}]} {emit {\b, GRand Unified Bootloader}}
+}
+if {[S 382 == {Geom\0Hard\ Disk\0Read\0\ Error\0}]} {if {[S 376 == {GRUB\ \0}]} {emit {\b, GRand Unified Bootloader \(0.93\)}}
+}
+if {[S 383 == {Geom\0Hard\ Disk\0Read\0\ Error\0}]} {if {[S 377 == {GRUB\ \0}]} {emit {\b, GRand Unified Bootloader \(0.94\)}}
+}
+if {[S 480 == {Boot\ failed\r}]} {if {[S 495 == {LDLINUX\ SYS}]} {emit {\b, SYSLINUX bootloader \(2.06\)}}
+}
+if {[S 395 == {chksum\0\ ERROR!\0}]} {emit {\b, Gujin bootloader}}
+if {[S 185 == {FDBOOT\ Version\ }]} {if {[S 204 == {\rNo\ Systemdisk.\ }]} {if {[S 220 == {Booting\ from\ harddisk.\n\r}]} {emit 349 21 0 0}
+if {[S 245 == {Cannot\ load\ from\ harddisk.\n\r}]} {if {[S 273 == {Insert\ Systemdisk\ }]} {if {[S 291 == {and\ press\ any\ key.\n\r}]} {emit {\b, FDBOOT harddisk Bootloader}
+if {[S 200 x {}]} {emit {\b, version %-3s}}
+}
+}
+}
+}
+}
+if {[S 242 == {Bootsector\ from\ C.H.\ Hochst\204}]} {if {[S 278 == {No\ Systemdisk.\ }]} {if {[S 293 == {Booting\ from\ harddisk.\n\r}]} {emit 349 22 0 0}
+if {[S 441 == {Cannot\ load\ from\ harddisk.\n\r}]} {if {[S 469 == {Insert\ Systemdisk\ }]} {if {[S 487 == {and\ press\ any\ key.\n\r}]} {emit {\b, WinImage harddisk Bootloader}
+if {[S 209 x {}]} {emit {\b, version %-4.4s}}
+}
+}
+}
+}
+}
+if {[N c [I 1 c 2] == 0xe]} {if {[N c [I 1 c 3] == 0x1f]} {if {[N c [I 1 c 4] == 0xbe]} {if {[N c [I 1 c 5] == 0x77]} {emit 349 23 0 0 0}
+if {[N c [I 1 c 6] == 0x7c]} {if {[N c [I 1 c 7] == 0xac]} {if {[N c [I 1 c 8] == 0x22]} {if {[N c [I 1 c 9] == 0xc0]} {if {[N c [I 1 c 10] == 0x74]} {if {[N c [I 1 c 11] == 0xb]} {if {[N c [I 1 c 12] == 0x56]} {emit 349 23 0 0 1 0 0 0 0 0 0}
+if {[N c [I 1 c 13] == 0xb4]} {emit {\b, mkdosfs boot message display}}
+}
+}
+}
+}
+}
+}
+}
+}
+}
+if {[S 430 == {NTLDR\ is\ missing\xFF\r\n}]} {if {[S 449 == {Disk\ error\xFF\r\n}]} {if {[S 462 == {Press\ any\ key\ to\ restart\r}]} {emit {\b, Microsoft Windows XP Bootloader}
+if {[N c 417 < 0x7e]} {if {[S 417 > {\ }]} {emit %-.5s
+if {[N c 422 < 0x7e]} {if {[S 422 > {\ }]} {emit {\b%-.3s}}
+}
+if {[S 425 > {\ }]} {emit {\b.%-.3s}}
+}
+}
+if {[N c 368 < 0x7e]} {if {[S 368 > {\ }]} {emit %-.5s
+if {[N c 373 < 0x7e]} {if {[S 373 > {\ }]} {emit {\b%-.3s}}
+}
+if {[S 376 > {\ }]} {emit {\b.%-.3s}}
+}
+}
+}
+}
+}
+if {[S 430 == {NTLDR\ nicht\ gefunden\xFF\r\n}]} {if {[S 453 == {Datentr\204gerfehler\xFF\r\n}]} {if {[S 473 == {Neustart\ mit\ beliebiger\ Taste\r}]} {emit {\b, Microsoft Windows XP Bootloader \(german\)}
+if {[N c 417 < 0x7e]} {if {[S 417 > {\ }]} {emit %-.5s
+if {[N c 422 < 0x7e]} {if {[S 422 > {\ }]} {emit {\b%-.3s}}
+}
+if {[S 425 > {\ }]} {emit {\b.%-.3s}}
+}
+}
+if {[N c 368 < 0x7e]} {if {[S 368 > {\ }]} {emit %-.5s
+if {[N c 373 < 0x7e]} {if {[S 373 > {\ }]} {emit {\b%-.3s}}
+}
+if {[S 376 > {\ }]} {emit {\b.%-.3s}}
+}
+}
+}
+}
+}
+if {[S 430 == {NTLDR\ fehlt\xFF\r\n}]} {if {[S 444 == {Datentr\204gerfehler\xFF\r\n}]} {if {[S 464 == {Neustart\ mit\ beliebiger\ Taste\r}]} {emit {\b, Microsoft Windows XP Bootloader \(2.german\)}
+if {[N c 417 < 0x7e]} {if {[S 417 > {\ }]} {emit %-.5s
+if {[N c 422 < 0x7e]} {if {[S 422 > {\ }]} {emit {\b%-.3s}}
+}
+if {[S 425 > {\ }]} {emit {\b.%-.3s}}
+}
+}
+}
+}
+}
+if {[S 430 == {NTLDR\ fehlt\xFF\r\n}]} {if {[S 444 == {Medienfehler\xFF\r\n}]} {if {[S 459 == {Neustart:\ Taste\ dr\201cken\r}]} {emit {\b, Microsoft Windows XP Bootloader \(3.german\)}
+if {[N c 368 < 0x7e]} {if {[S 368 > {\ }]} {emit %-.5s
+if {[N c 373 < 0x7e]} {if {[S 373 > {\ }]} {emit {\b%-.3s}}
+}
+if {[S 376 > {\ }]} {emit {\b.%-.3s}}
+}
+}
+if {[N c 417 < 0x7e]} {if {[S 417 > {\ }]} {emit %-.5s
+if {[N c 422 < 0x7e]} {if {[S 422 > {\ }]} {emit {\b%-.3s}}
+}
+if {[S 425 > {\ }]} {emit {\b.%-.3s}}
+}
+}
+}
+}
+}
+if {[S 430 == {Datentr\204ger\ entfernen\xFF\r\n}]} {if {[S 454 == {Medienfehler\xFF\r\n}]} {if {[S 469 == {Neustart:\ Taste\ dr\201cken\r}]} {emit {\b, Microsoft Windows XP Bootloader \(4.german\)}
+if {[N c 368 < 0x7e]} {if {[S 368 > {\ }]} {emit %-.5s
+if {[N c 373 < 0x7e]} {if {[S 373 > {\ }]} {emit {\b%-.3s}}
+}
+if {[S 376 > {\ }]} {emit {\b.%-.3s}}
+}
+}
+}
+}
+}
+if {[S 389 == {Fehler\ beim\ Lesen\ }]} {if {[S 407 == {des\ Datentr\204gers}]} {if {[S 426 == {NTLDR\ fehlt}]} {if {[S 440 == {NTLDR\ ist\ komprimiert}]} {if {[S 464 == {Neustart\ mit\ Strg+Alt+Entf\r}]} {emit {\b, Microsoft Windows XP Bootloader NTFS \(german\)}}
+}
+}
+}
+}
+if {[S 313 == {A\ disk\ read\ error\ occurred.\r}]} {if {[S 345 == {A\ kernel\ file\ is\ missing\ }]} {if {[S 370 == {from\ the\ disk.\r}]} {if {[S 484 == {NTLDR\ is\ compressed}]} {if {[S 429 == {Insert\ a\ system\ diskette\ }]} {if {[S 454 == {and\ restart\r\nthe\ system.\r}]} {emit {\b, Microsoft Windows XP Bootloader NTFS}}
+}
+}
+}
+}
+}
+if {[S 472 == {IO\ \ \ \ \ \ SYSMSDOS\ \ \ SYS}]} {if {[S 497 == {WINBOOT\ SYS}]} {emit 349 31 0}
+if {[S 389 == {Invalid\ system\ disk\xFF\r\n}]} {if {[S 411 == {Disk\ I/O\ error}]} {if {[S 428 == {Replace\ the\ disk,\ and\ }]} {if {[S 455 == {press\ any\ key}]} {emit {\b, Microsoft Windows 98 Bootloader}}
+}
+}
+}
+if {[S 390 == {Invalid\ system\ disk\xFF\r\n}]} {if {[S 412 == {Disk\ I/O\ error\xFF\r\n}]} {if {[S 429 == {Replace\ the\ disk,\ and\ }]} {if {[S 451 == {then\ press\ any\ key\r}]} {emit {\b, Microsoft Windows 98 Bootloader}}
+}
+}
+}
+if {[S 388 == {Ungueltiges\ System\ \xFF\r\n}]} {if {[S 410 == {E/A-Fehler\ \ \ \ \xFF\r\n}]} {if {[S 427 == {Datentraeger\ wechseln\ und\ }]} {if {[S 453 == {Taste\ druecken\r}]} {emit {\b, Microsoft Windows 95/98/ME Bootloader \(german\)}}
+}
+}
+}
+if {[S 390 == {Ungueltiges\ System\ \xFF\r\n}]} {if {[S 412 == {E/A-Fehler\ \ \ \ \xFF\r\n}]} {if {[S 429 == {Datentraeger\ wechseln\ und\ }]} {if {[S 455 == {Taste\ druecken\r}]} {emit {\b, Microsoft Windows 95/98/ME Bootloader \(German\)}}
+}
+}
+}
+if {[S 389 == {Ungueltiges\ System\ \xFF\r\n}]} {if {[S 411 == {E/A-Fehler\ \ \ \ \xFF\r\n}]} {if {[S 428 == {Datentraeger\ wechseln\ und\ }]} {if {[S 454 == {Taste\ druecken\r}]} {emit {\b, Microsoft Windows 95/98/ME Bootloader \(GERMAN\)}}
+}
+}
+}
+}
+if {[S 479 == {IO\ \ \ \ \ \ SYSMSDOS\ \ \ SYS}]} {if {[S 416 == {Kein\ System\ oder\ }]} {if {[S 433 == Laufwerksfehler]} {if {[S 450 == {Wechseln\ und\ Taste\ dr\201cken}]} {emit {\b, Microsoft DOS Bootloader \(german\)}}
+}
+}
+}
+if {[S 486 == {IO\ \ \ \ \ \ SYSMSDOS\ \ \ SYS}]} {if {[S 416 == {Non-System\ disk\ or\ }]} {if {[S 435 == {disk\ error\r}]} {if {[S 447 == {Replace\ and\ press\ any\ key\ }]} {if {[S 473 == {when\ ready\r}]} {emit {\b, Microsoft DOS Bootloader}}
+}
+}
+}
+}
+if {[S 480 == {IO\ \ \ \ \ \ SYSMSDOS\ \ \ SYS}]} {if {[S 393 == {Non-System\ disk\ or\ }]} {if {[S 412 == {disk\ error\r}]} {if {[S 424 == {Replace\ and\ press\ any\ key\ }]} {if {[S 450 == {when\ ready\r}]} {emit {\b, Microsoft DOS bootloader}}
+}
+}
+}
+}
+if {[S 54 == SYS]} {if {[S 324 == VASKK]} {if {[S 495 == {NEWLDR\0}]} {emit {\b, DR-DOS Bootloader \(LOADER.SYS\)}}
+}
+}
+if {[S 70 == {IBMBIO\ \ COM}]} {if {[S 472 == {Cannot\ load\ DOS!\ }]} {if {[S 489 == {Any\ key\ to\ retry}]} {emit {\b, DR-DOS Bootloader}}
+}
+if {[S 471 == {Cannot\ load\ DOS\ }]} {emit 349 36 1}
+if {[S 487 == {press\ key\ to\ retry}]} {emit {\b, Open-DOS Bootloader}}
+}
+if {[S 444 == {KERNEL\ \ SYS}]} {if {[S 314 == {BOOT\ error!}]} {emit {\b, FREE-DOS Bootloader}}
+}
+if {[S 499 == {KERNEL\ \ SYS}]} {if {[S 305 == {BOOT\ err!\0}]} {emit {\b, Free-DOS Bootloader}}
+}
+if {[S 449 == {KERNEL\ \ SYS}]} {if {[S 319 == {BOOT\ error!}]} {emit {\b, FREE-DOS 5.0 Bootloader}}
+}
+if {[S 124 == {FreeDOS\0}]} {if {[S 331 == {\ err\0}]} {emit {\b, FREE-DOS BETa 9 Bootloader}
+if {[S 497 > {\ }]} {emit %-.6s
+if {[S 503 > {\ }]} {emit {\b%-.1s}}
+if {[S 504 > {\ }]} {emit {\b%-.1s}}
+}
+if {[S 505 > {\ }]} {emit {\b.%-.3s}}
+}
+if {[S 333 == {\ err\0}]} {emit {\b, FREE-DOS BEta 9 Bootloader}
+if {[S 497 > {\ }]} {emit %-.6s
+if {[S 503 > {\ }]} {emit {\b%-.1s}}
+if {[S 504 > {\ }]} {emit {\b%-.1s}}
+}
+if {[S 505 > {\ }]} {emit {\b.%-.3s}}
+}
+if {[S 334 == {\ err\0}]} {emit {\b, FREE-DOS Beta 9 Bootloader}
+if {[S 497 > {\ }]} {emit %-.6s
+if {[S 503 > {\ }]} {emit {\b%-.1s}}
+if {[S 504 > {\ }]} {emit {\b%-.1s}}
+}
+if {[S 505 > {\ }]} {emit {\b.%-.3s}}
+}
+}
+if {[S 0 == {\0\0\0\0}]} {emit {\b, extended partition table}}
+if {[N i 0 == 0x9000eb &0x009000EB]} {emit 349 42}
+if {[N i 0 == 0xe9 &0x000000E9]} {if {[N c 1 > 0x25]} {emit {\b, code offset 0x%x}
+if {[N s 11 < 0x801]} {if {[N s 11 > 0x1f]} {if {[S 3 x {}]} {emit {\b, OEM-ID \"%8.8s\"}}
+if {[N s 11 > 0x200]} {emit {\b, Bytes/sector %u}}
+if {[N s 11 < 0x200]} {emit {\b, Bytes/sector %u}}
+if {[N c 13 > 0x1]} {emit {\b, sectors/cluster %u}}
+if {[N s 14 > 0x20]} {emit {\b, reserved sectors %u}}
+if {[N s 14 < 0x1]} {emit {\b, reserved sectors %u}}
+if {[N c 16 > 0x2]} {emit {\b, FATs %u}}
+if {[N c 16 == 0x1]} {emit {\b, FAT %u}}
+if {[N c 16 > 0x0]} {emit 349 43 0 0 0 8}
+if {[N s 17 > 0x0]} {emit {\b, root entries %u}}
+if {[N s 19 > 0x0]} {emit {\b, sectors %u \(volumes <=32 MB\)}}
+if {[N c 21 > 0xf0]} {emit {\b, Media descriptor 0x%x}}
+if {[N c 21 < 0xf0]} {emit {\b, Media descriptor 0x%x}}
+if {[N s 22 > 0x0]} {emit {\b, sectors/FAT %u}}
+if {[N c 26 > 0x2]} {emit {\b, heads %u}}
+if {[N c 26 == 0x1]} {emit {\b, heads %u}}
+if {[N i 28 > 0x0]} {emit {\b, hidden sectors %u}}
+if {[N i 32 > 0x0]} {emit {\b, sectors %u \(volumes > 32 MB\)}}
+if {[N i 82 > 0x0 &0xCCABBEB9]} {if {[N c 36 > 0x80]} {emit {\b, physical drive 0x%x}}
+if {[N c 36 > 0x0 &0x7F]} {emit {\b, physical drive 0x%x}}
+if {[N c 37 > 0x0]} {emit {\b, reserved 0x%x}}
+if {[N c 38 > 0x29]} {emit {\b, dos < 4.0 BootSector \(0x%x\)}}
+if {[N c 38 < 0x29]} {emit {\b, dos < 4.0 BootSector \(0x%x\)}}
+if {[N c 38 == 0x29]} {if {[N i 39 x {}]} {emit {\b, serial number 0x%x}}
+if {[S 43 < {NO\ NAME}]} {emit {\b, label: \"%11.11s\"}}
+if {[S 43 > {NO\ NAME}]} {emit {\b, label: \"%11.11s\"}}
+if {[S 43 == {NO\ NAME}]} {emit {\b, unlabeled}}
+}
+if {[S 54 == FAT1]} {emit {\b, FAT}
+if {[S 54 == FAT12]} {emit {\b \(12 bit\)}}
+if {[S 54 == FAT16]} {emit {\b \(16 bit\)}}
+}
+}
+if {[S 82 == FAT32]} {emit {\b, FAT \(32 bit\)}
+if {[N i 36 x {}]} {emit {\b, sectors/FAT %u}}
+if {[N s 40 > 0x0]} {emit {\b, extension flags %u}}
+if {[N s 42 > 0x0]} {emit {\b, fsVersion %u}}
+if {[N i 44 > 0x2]} {emit {\b, rootdir cluster %u}}
+if {[N s 48 > 0x1]} {emit {\b, infoSector %u}}
+if {[N s 48 < 0x1]} {emit {\b, infoSector %u}}
+if {[N s 50 > 0x6]} {emit {\b, Backup boot sector %u}}
+if {[N s 50 < 0x6]} {emit {\b, Backup boot sector %u}}
+if {[N i 54 > 0x0]} {emit {\b, reserved1 0x%x}}
+if {[N i 58 > 0x0]} {emit {\b, reserved2 0x%x}}
+if {[N i 62 > 0x0]} {emit {\b, reserved3 0x%x}}
+if {[N c 64 > 0x80]} {emit {\b, physical drive 0x%x}}
+if {[N c 64 > 0x0 &0x7F]} {emit {\b, physical drive 0x%x}}
+if {[N c 65 > 0x0]} {emit {\b, reserved 0x%x}}
+if {[N c 66 > 0x29]} {emit {\b, dos < 4.0 BootSector \(0x%x\)}}
+if {[N c 66 < 0x29]} {emit {\b, dos < 4.0 BootSector \(0x%x\)}}
+if {[N c 66 == 0x29]} {if {[N i 67 x {}]} {emit {\b, serial number 0x%x}}
+if {[S 71 < {NO\ NAME}]} {emit {\b, label: \"%11.11s\"}}
+}
+if {[S 71 > {NO\ NAME}]} {emit {\b, label: \"%11.11s\"}}
+if {[S 71 == {NO\ NAME}]} {emit {\b, unlabeled}}
+}
+}
+}
+}
+}
+if {[N i 512 == 0x82564557]} {emit {\b, BSD disklabel}}
+}
+if {[S 0 == FATX]} {emit {FATX filesystem data}}
+switch -- [Nv s 1040] 4991 {emit {Minix filesystem}} 5007 {emit {Minix filesystem, 30 char names}} 9320 {emit {Minix filesystem, version 2}} 9336 {emit {Minix filesystem, version 2, 30 char names}}
+if {[N S 1040 == 0x137f]} {emit {Minix filesystem \(big endian\),}
+if {[N S 1026 != 0x0]} {emit {\b, %d zones}}
+if {[S 30 == minix]} {emit {\b, bootable}}
+}
+if {[S 0 == {-rom1fs-\0}]} {emit {romfs filesystem, version 1}
+if {[N I 8 x {}]} {emit {%d bytes,}}
+if {[S 16 x {}]} {emit {named %s.}}
+}
+if {[S 395 == OS/2]} {emit {OS/2 Boot Manager}}
+if {[N i 9564 == 0x11954]} {emit {Unix Fast File system \(little-endian\),}
+if {[S 8404 x {}]} {emit {last mounted on %s,}}
+if {[N s 8224 x {}]} {emit {last written at %s,}}
+if {[N c 8401 x {}]} {emit {clean flag %d,}}
+if {[N i 8228 x {}]} {emit {number of blocks %d,}}
+if {[N i 8232 x {}]} {emit {number of data blocks %d,}}
+if {[N i 8236 x {}]} {emit {number of cylinder groups %d,}}
+if {[N i 8240 x {}]} {emit {block size %d,}}
+if {[N i 8244 x {}]} {emit {fragment size %d,}}
+if {[N i 8252 x {}]} {emit {minimum percentage of free blocks %d,}}
+if {[N i 8256 x {}]} {emit {rotational delay %dms,}}
+if {[N i 8260 x {}]} {emit {disk rotational speed %drps,}}
+switch -- [Nv i 8320] 0 {emit {TIME optimization}} 1 {emit {SPACE optimization}}
+}
+if {[N I 9564 == 0x11954]} {emit {Unix Fast File system \(big-endian\),}
+if {[N Q 7168 == 0x4c41424c]} {emit {Apple UFS Volume}
+if {[S 7186 x {}]} {emit {named %s,}}
+if {[N I 7176 x {}]} {emit {volume label version %d,}}
+if {[N S 7180 x {}]} {emit {created on %s,}}
+}
+if {[S 8404 x {}]} {emit {last mounted on %s,}}
+if {[N S 8224 x {}]} {emit {last written at %s,}}
+if {[N c 8401 x {}]} {emit {clean flag %d,}}
+if {[N I 8228 x {}]} {emit {number of blocks %d,}}
+if {[N I 8232 x {}]} {emit {number of data blocks %d,}}
+if {[N I 8236 x {}]} {emit {number of cylinder groups %d,}}
+if {[N I 8240 x {}]} {emit {block size %d,}}
+if {[N I 8244 x {}]} {emit {fragment size %d,}}
+if {[N I 8252 x {}]} {emit {minimum percentage of free blocks %d,}}
+if {[N I 8256 x {}]} {emit {rotational delay %dms,}}
+if {[N I 8260 x {}]} {emit {disk rotational speed %drps,}}
+switch -- [Nv I 8320] 0 {emit {TIME optimization}} 1 {emit {SPACE optimization}}
+}
+if {[N s 1080 == 0xef53]} {emit Linux
+if {[N i 1100 x {}]} {emit {rev %d}}
+if {[N s 1086 x {}]} {emit {\b.%d}}
+if {[N i 1116 ^ 0x4]} {emit {ext2 filesystem data}
+if {[N s 1082 ^ 0x1]} {emit {\(mounted or unclean\)}}
+}
+if {[N i 1116 & 0x4]} {emit {ext3 filesystem data}
+if {[N i 1120 & 0x4]} {emit {\(needs journal recovery\)}}
+}
+if {[N s 1082 & 0x2]} {emit {\(errors\)}}
+if {[N i 1120 & 0x1]} {emit {\(compressed\)}}
+if {[N i 1124 & 0x2]} {emit {\(large files\)}}
+}
+if {[N I 2048 == 0x46fc2700]} {emit {Atari-ST Minix kernel image}
+if {[S 19 == {\240\5\371\5\0\011\0\2\0}]} {emit {\b, 720k floppy}}
+if {[S 19 == {\320\2\370\5\0\011\0\1\0}]} {emit {\b, 360k floppy}}
+}
+if {[S 19 == {\320\2\360\3\0\011\0\1\0}]} {emit {DOS floppy 360k}
+if {[N s 510 == 0xaa55]} {emit {\b, x86 hard disk boot sector}}
+}
+if {[S 19 == {\240\5\371\3\0\011\0\2\0}]} {emit {DOS floppy 720k}
+if {[N s 510 == 0xaa55]} {emit {\b, x86 hard disk boot sector}}
+}
+if {[S 19 == {\100\013\360\011\0\022\0\2\0}]} {emit {DOS floppy 1440k}
+if {[N s 510 == 0xaa55]} {emit {\b, x86 hard disk boot sector}}
+}
+if {[S 19 == {\240\5\371\5\0\011\0\2\0}]} {emit {DOS floppy 720k, IBM}
+if {[N s 510 == 0xaa55]} {emit {\b, x86 hard disk boot sector}}
+}
+if {[S 19 == {\100\013\371\5\0\011\0\2\0}]} {emit {DOS floppy 1440k, mkdosfs}
+if {[N s 510 == 0xaa55]} {emit {\b, x86 hard disk boot sector}}
+}
+if {[S 19 == {\320\2\370\5\0\011\0\1\0}]} {emit {Atari-ST floppy 360k}}
+if {[S 19 == {\240\5\371\5\0\011\0\2\0}]} {emit {Atari-ST floppy 720k}}
+if {[S 32769 == CD001]} {emit {ISO 9660 CD-ROM filesystem data}
+if {[S 32808 x {}]} {emit '%s'}
+if {[S 34816 == {\000CD001\001EL\ TORITO\ SPECIFICATION}]} {emit {\(bootable\)}}
+}
+if {[S 37633 == CD001]} {emit {ISO 9660 CD-ROM filesystem data \(raw 2352 byte sectors\)}}
+if {[S 32776 == CDROM]} {emit {High Sierra CD-ROM filesystem data}}
+if {[S 65588 == ReIsErFs]} {emit {ReiserFS V3.5}}
+if {[S 65588 == ReIsEr2Fs]} {emit {ReiserFS V3.6}
+if {[N s 65580 x {}]} {emit {block size %d}}
+if {[N s 65586 & 0x2]} {emit {\(mounted or unclean\)}}
+if {[N i 65536 x {}]} {emit {num blocks %d}}
+switch -- [Nv i 65600] 1 {emit {tea hash}} 2 {emit {yura hash}} 3 {emit {r5 hash}}
+}
+if {[S 0 == ESTFBINR]} {emit {EST flat binary}}
+if {[S 0 == {VoIP\ Startup\ and}]} {emit {Aculab VoIP firmware}
+if {[S 35 x {}]} {emit {format %s}}
+}
+if {[S 0 == sqsh]} {emit {Squashfs filesystem, big endian,}
+if {[N S 28 x {}]} {emit {version %d.}}
+if {[N S 30 x {}]} {emit {\b%d,}}
+if {[N I 8 x {}]} {emit {%d bytes,}}
+if {[N I 4 x {}]} {emit {%d inodes,}}
+if {[N S 28 < 0x2]} {if {[N S 32 x {}]} {emit {blocksize: %d bytes,}}
+}
+if {[N S 28 > 0x1]} {if {[N I 51 x {}]} {emit {blocksize: %d bytes,}}
+}
+if {[N S 39 x {}]} {emit {created: %s}}
+}
+if {[S 0 == hsqs]} {emit {Squashfs filesystem, little endian,}
+if {[N s 28 x {}]} {emit {version %d.}}
+if {[N s 30 x {}]} {emit {\b%d,}}
+if {[N i 8 x {}]} {emit {%d bytes,}}
+if {[N i 4 x {}]} {emit {%d inodes,}}
+if {[N s 28 < 0x2]} {if {[N s 32 x {}]} {emit {blocksize: %d bytes,}}
+}
+if {[N s 28 > 0x1]} {if {[N i 51 x {}]} {emit {blocksize: %d bytes,}}
+}
+if {[N s 39 x {}]} {emit {created: %s}}
+}
+if {[S 0 == FWS]} {emit {Macromedia Flash data,}
+if {[N c 3 x {}]} {emit {version %d}}
+}
+if {[S 0 == CWS]} {emit {Macromedia Flash data \(compressed\),}
+if {[N c 3 x {}]} {emit {version %d}}
+}
+if {[S 0 == {AGD4\xbe\xb8\xbb\xcb\x00}]} {emit {Macromedia Freehand 9 Document}}
+if {[S 0 == FONT]} {emit {ASCII vfont text}}
+if {[S 0 == %!PS-AdobeFont-1.]} {emit {PostScript Type 1 font text}
+if {[S 20 x {}]} {emit {\(%s\)}}
+}
+if {[S 6 == %!PS-AdobeFont-1.]} {emit {PostScript Type 1 font program data}}
+if {[S 0 == {STARTFONT\040}]} {emit {X11 BDF font text}}
+if {[S 0 == {\001fcp}]} {emit {X11 Portable Compiled Font data}
+switch -- [Nv c 12] 2 {emit {\b, LSB first}} 10 {emit {\b, MSB first}}
+}
+if {[S 0 == {D1.0\015}]} {emit {X11 Speedo font data}}
+if {[S 0 == flf]} {emit {FIGlet font}
+if {[S 3 > 2a]} {emit {version %-2.2s}}
+}
+if {[S 0 == flc]} {emit {FIGlet controlfile}
+if {[S 3 > 2a]} {emit {version %-2.2s}}
+}
+switch -- [Nv I 7] 4540225 {emit {DOS code page font data}} 5654852 {emit {DOS code page font data \(from Linux?\)}}
+if {[S 4098 == DOSFONT]} {emit {DOSFONT2 encrypted font data}}
+if {[S 0 == PFR1]} {emit {PFR1 font}
+if {[S 102 > 0]} {emit {\b: %s}}
+}
+if {[S 0 == {\000\001\000\000\000}]} {emit {TrueType font data}}
+if {[S 0 == {\007\001\001\000Copyright\ (c)\ 199}]} {emit {Adobe Multiple Master font}}
+if {[S 0 == {\012\001\001\000Copyright\ (c)\ 199}]} {emit {Adobe Multiple Master font}}
+if {[S 0 == OTTO]} {emit {OpenType font data}}
+if {[S 0 == <MakerFile]} {emit {FrameMaker document}
+if {[S 11 == 5.5]} {emit {\(5.5}}
+if {[S 11 == 5.0]} {emit {\(5.0}}
+if {[S 11 == 4.0]} {emit {\(4.0}}
+if {[S 11 == 3.0]} {emit {\(3.0}}
+if {[S 11 == 2.0]} {emit {\(2.0}}
+if {[S 11 == 1.0]} {emit {\(1.0}}
+if {[N c 14 x {}]} {emit {%c\)}}
+}
+if {[S 0 == <MIFFile]} {emit {FrameMaker MIF \(ASCII\) file}
+if {[S 9 == 4.0]} {emit {\(4.0\)}}
+if {[S 9 == 3.0]} {emit {\(3.0\)}}
+if {[S 9 == 2.0]} {emit {\(2.0\)}}
+if {[S 9 == 1.0]} {emit {\(1.x\)}}
+}
+if {[S 0 == <MakerDictionary]} {emit {FrameMaker Dictionary text}
+if {[S 17 == 3.0]} {emit {\(3.0\)}}
+if {[S 17 == 2.0]} {emit {\(2.0\)}}
+if {[S 17 == 1.0]} {emit {\(1.x\)}}
+}
+if {[S 0 == <MakerScreenFont]} {emit {FrameMaker Font file}
+if {[S 17 == 1.01]} {emit {\(%s\)}}
+}
+if {[S 0 == <MML]} {emit {FrameMaker MML file}}
+if {[S 0 == <BookFile]} {emit {FrameMaker Book file}
+if {[S 10 == 3.0]} {emit {\(3.0}}
+if {[S 10 == 2.0]} {emit {\(2.0}}
+if {[S 10 == 1.0]} {emit {\(1.0}}
+if {[N c 13 x {}]} {emit {%c\)}}
+}
+if {[S 0 == <Maker]} {emit {Intermediate Print File FrameMaker IPL file}}
+switch -- [Nv i 0 &0377777777] 8782087 {emit FreeBSD/i386
+if {[N i 20 < 0x1000]} {if {[N c 3 & 0x80 &0xC0]} {emit {shared library}}
+switch -- [Nv c 3 &0xC0] 64 {emit {PIC object}} 0 {emit object}
+}
+if {[N i 20 > 0xfff]} {switch -- [Nv c 3 &0x80] -128 {emit {dynamically linked executable}} 0 {emit executable}
+}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 8782088 {emit {FreeBSD/i386 pure}
+if {[N i 20 < 0x1000]} {if {[N c 3 & 0x80 &0xC0]} {emit {shared library}}
+switch -- [Nv c 3 &0xC0] 64 {emit {PIC object}} 0 {emit object}
+}
+if {[N i 20 > 0xfff]} {switch -- [Nv c 3 &0x80] -128 {emit {dynamically linked executable}} 0 {emit executable}
+}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 8782091 {emit {FreeBSD/i386 demand paged}
+if {[N i 20 < 0x1000]} {if {[N c 3 & 0x80 &0xC0]} {emit {shared library}}
+switch -- [Nv c 3 &0xC0] 64 {emit {PIC object}} 0 {emit object}
+}
+if {[N i 20 > 0xfff]} {switch -- [Nv c 3 &0x80] -128 {emit {dynamically linked executable}} 0 {emit executable}
+}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 8782028 {emit {FreeBSD/i386 compact demand paged}
+if {[N i 20 < 0x1000]} {if {[N c 3 & 0x80 &0xC0]} {emit {shared library}}
+switch -- [Nv c 3 &0xC0] 64 {emit {PIC object}} 0 {emit object}
+}
+if {[N i 20 > 0xfff]} {switch -- [Nv c 3 &0x80] -128 {emit {dynamically linked executable}} 0 {emit executable}
+}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+}
+if {[S 7 == {\357\020\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0}]} {emit {FreeBSD/i386 a.out core file}
+if {[S 1039 x {}]} {emit {from '%s'}}
+}
+if {[S 0 == SCRSHOT_]} {emit {scrshot\(1\) screenshot,}
+if {[N c 8 x {}]} {emit {version %d,}}
+if {[N c 9 == 0x2]} {emit {%d bytes in header,}
+if {[N c 10 x {}]} {emit {%d chars wide by}}
+if {[N c 11 x {}]} {emit {%d chars high}}
+}
+}
+if {[S 1 == WAD]} {emit {DOOM data,}
+if {[S 0 == I]} {emit {main wad}}
+if {[S 0 == P]} {emit {patch wad}}
+if {[N c 0 x {}]} {emit {unknown junk}}
+}
+if {[S 0 == IDP2]} {emit {Quake II 3D Model file,}
+if {[N Q 20 x {}]} {emit {%lu skin\(s\),}}
+if {[N Q 8 x {}]} {emit {\(%lu x}}
+if {[N Q 12 x {}]} {emit {%lu\),}}
+if {[N Q 40 x {}]} {emit {%lu frame\(s\),}}
+if {[N Q 16 x {}]} {emit {Frame size %lu bytes,}}
+if {[N Q 24 x {}]} {emit {%lu vertices/frame,}}
+if {[N Q 28 x {}]} {emit {%lu texture coordinates,}}
+if {[N Q 32 x {}]} {emit {%lu triangles/frame}}
+}
+if {[S 0 == IBSP]} {emit Quake
+switch -- [Nv Q 4] 38 {emit {II Map file \(BSP\)}} 46 {emit {III Map file \(BSP\)}}
+}
+if {[S 0 == IDS2]} {emit {Quake II SP2 sprite file}}
+if {[S 0 == IWAD]} {emit {DOOM or DOOM ][ world}}
+if {[S 0 == PWAD]} {emit {DOOM or DOOM ][ extension world}}
+if {[S 0 == {\xcb\x1dBoom\xe6\xff\x03\x01}]} {emit {Boom or linuxdoom demo}}
+if {[S 24 == {LxD\ 203}]} {emit {Linuxdoom save}
+if {[S 0 x {}]} {emit {, name=%s}}
+if {[S 44 x {}]} {emit {, world=%s}}
+}
+if {[S 0 == PACK]} {emit {Quake I or II world or extension}}
+if {[S 0 == {5\x0aIntroduction}]} {emit {Quake I save: start Introduction}}
+if {[S 0 == {5\x0athe_Slipgate_Complex}]} {emit {Quake I save: e1m1 The slipgate complex}}
+if {[S 0 == {5\x0aCastle_of_the_Damned}]} {emit {Quake I save: e1m2 Castle of the damned}}
+if {[S 0 == {5\x0athe_Necropolis}]} {emit {Quake I save: e1m3 The necropolis}}
+if {[S 0 == {5\x0athe_Grisly_Grotto}]} {emit {Quake I save: e1m4 The grisly grotto}}
+if {[S 0 == {5\x0aZiggurat_Vertigo}]} {emit {Quake I save: e1m8 Ziggurat vertigo \(secret\)}}
+if {[S 0 == {5\x0aGloom_Keep}]} {emit {Quake I save: e1m5 Gloom keep}}
+if {[S 0 == {5\x0aThe_Door_To_Chthon}]} {emit {Quake I save: e1m6 The door to Chthon}}
+if {[S 0 == {5\x0aThe_House_of_Chthon}]} {emit {Quake I save: e1m7 The house of Chthon}}
+if {[S 0 == {5\x0athe_Installation}]} {emit {Quake I save: e2m1 The installation}}
+if {[S 0 == {5\x0athe_Ogre_Citadel}]} {emit {Quake I save: e2m2 The ogre citadel}}
+if {[S 0 == {5\x0athe_Crypt_of_Decay}]} {emit {Quake I save: e2m3 The crypt of decay \(dopefish lives!\)}}
+if {[S 0 == {5\x0aUnderearth}]} {emit {Quake I save: e2m7 Underearth \(secret\)}}
+if {[S 0 == {5\x0athe_Ebon_Fortress}]} {emit {Quake I save: e2m4 The ebon fortress}}
+if {[S 0 == {5\x0athe_Wizard's_Manse}]} {emit {Quake I save: e2m5 The wizard's manse}}
+if {[S 0 == {5\x0athe_Dismal_Oubliette}]} {emit {Quake I save: e2m6 The dismal oubliette}}
+if {[S 0 == {5\x0aTermination_Central}]} {emit {Quake I save: e3m1 Termination central}}
+if {[S 0 == {5\x0aVaults_of_Zin}]} {emit {Quake I save: e3m2 Vaults of Zin}}
+if {[S 0 == {5\x0athe_Tomb_of_Terror}]} {emit {Quake I save: e3m3 The tomb of terror}}
+if {[S 0 == {5\x0aSatan's_Dark_Delight}]} {emit {Quake I save: e3m4 Satan's dark delight}}
+if {[S 0 == {5\x0athe_Haunted_Halls}]} {emit {Quake I save: e3m7 The haunted halls \(secret\)}}
+if {[S 0 == {5\x0aWind_Tunnels}]} {emit {Quake I save: e3m5 Wind tunnels}}
+if {[S 0 == {5\x0aChambers_of_Torment}]} {emit {Quake I save: e3m6 Chambers of torment}}
+if {[S 0 == {5\x0athe_Sewage_System}]} {emit {Quake I save: e4m1 The sewage system}}
+if {[S 0 == {5\x0aThe_Tower_of_Despair}]} {emit {Quake I save: e4m2 The tower of despair}}
+if {[S 0 == {5\x0aThe_Elder_God_Shrine}]} {emit {Quake I save: e4m3 The elder god shrine}}
+if {[S 0 == {5\x0athe_Palace_of_Hate}]} {emit {Quake I save: e4m4 The palace of hate}}
+if {[S 0 == {5\x0aHell's_Atrium}]} {emit {Quake I save: e4m5 Hell's atrium}}
+if {[S 0 == {5\x0athe_Nameless_City}]} {emit {Quake I save: e4m8 The nameless city \(secret\)}}
+if {[S 0 == {5\x0aThe_Pain_Maze}]} {emit {Quake I save: e4m6 The pain maze}}
+if {[S 0 == {5\x0aAzure_Agony}]} {emit {Quake I save: e4m7 Azure agony}}
+if {[S 0 == {5\x0aShub-Niggurath's_Pit}]} {emit {Quake I save: end Shub-Niggurath's pit}}
+if {[S 0 == {5\x0aPlace_of_Two_Deaths}]} {emit {Quake I save: dm1 Place of two deaths}}
+if {[S 0 == {5\x0aClaustrophobopolis}]} {emit {Quake I save: dm2 Claustrophobopolis}}
+if {[S 0 == {5\x0aThe_Abandoned_Base}]} {emit {Quake I save: dm3 The abandoned base}}
+if {[S 0 == {5\x0aThe_Bad_Place}]} {emit {Quake I save: dm4 The bad place}}
+if {[S 0 == {5\x0aThe_Cistern}]} {emit {Quake I save: dm5 The cistern}}
+if {[S 0 == {5\x0aThe_Dark_Zone}]} {emit {Quake I save: dm6 The dark zone}}
+if {[S 0 == {5\x0aCommand_HQ}]} {emit {Quake I save: start Command HQ}}
+if {[S 0 == {5\x0aThe_Pumping_Station}]} {emit {Quake I save: hip1m1 The pumping station}}
+if {[S 0 == {5\x0aStorage_Facility}]} {emit {Quake I save: hip1m2 Storage facility}}
+if {[S 0 == {5\x0aMilitary_Complex}]} {emit {Quake I save: hip1m5 Military complex \(secret\)}}
+if {[S 0 == {5\x0athe_Lost_Mine}]} {emit {Quake I save: hip1m3 The lost mine}}
+if {[S 0 == {5\x0aResearch_Facility}]} {emit {Quake I save: hip1m4 Research facility}}
+if {[S 0 == {5\x0aAncient_Realms}]} {emit {Quake I save: hip2m1 Ancient realms}}
+if {[S 0 == {5\x0aThe_Gremlin's_Domain}]} {emit {Quake I save: hip2m6 The gremlin's domain \(secret\)}}
+if {[S 0 == {5\x0aThe_Black_Cathedral}]} {emit {Quake I save: hip2m2 The black cathedral}}
+if {[S 0 == {5\x0aThe_Catacombs}]} {emit {Quake I save: hip2m3 The catacombs}}
+if {[S 0 == {5\x0athe_Crypt__}]} {emit {Quake I save: hip2m4 The crypt}}
+if {[S 0 == {5\x0aMortum's_Keep}]} {emit {Quake I save: hip2m5 Mortum's keep}}
+if {[S 0 == {5\x0aTur_Torment}]} {emit {Quake I save: hip3m1 Tur torment}}
+if {[S 0 == {5\x0aPandemonium}]} {emit {Quake I save: hip3m2 Pandemonium}}
+if {[S 0 == {5\x0aLimbo}]} {emit {Quake I save: hip3m3 Limbo}}
+if {[S 0 == {5\x0athe_Edge_of_Oblivion}]} {emit {Quake I save: hipdm1 The edge of oblivion \(secret\)}}
+if {[S 0 == {5\x0aThe_Gauntlet}]} {emit {Quake I save: hip3m4 The gauntlet}}
+if {[S 0 == {5\x0aArmagon's_Lair}]} {emit {Quake I save: hipend Armagon's lair}}
+if {[S 0 == {5\x0aThe_Academy}]} {emit {Quake I save: start The academy}}
+if {[S 0 == {5\x0aThe_Lab}]} {emit {Quake I save: d1 The lab}}
+if {[S 0 == {5\x0aArea_33}]} {emit {Quake I save: d1b Area 33}}
+if {[S 0 == {5\x0aSECRET_MISSIONS}]} {emit {Quake I save: d3b Secret missions}}
+if {[S 0 == {5\x0aThe_Hospital}]} {emit {Quake I save: d10 The hospital \(secret\)}}
+if {[S 0 == {5\x0aThe_Genetics_Lab}]} {emit {Quake I save: d11 The genetics lab \(secret\)}}
+if {[S 0 == {5\x0aBACK_2_MALICE}]} {emit {Quake I save: d4b Back to Malice}}
+if {[S 0 == {5\x0aArea44}]} {emit {Quake I save: d1c Area 44}}
+if {[S 0 == {5\x0aTakahiro_Towers}]} {emit {Quake I save: d2 Takahiro towers}}
+if {[S 0 == {5\x0aA_Rat's_Life}]} {emit {Quake I save: d3 A rat's life}}
+if {[S 0 == {5\x0aInto_The_Flood}]} {emit {Quake I save: d4 Into the flood}}
+if {[S 0 == {5\x0aThe_Flood}]} {emit {Quake I save: d5 The flood}}
+if {[S 0 == {5\x0aNuclear_Plant}]} {emit {Quake I save: d6 Nuclear plant}}
+if {[S 0 == {5\x0aThe_Incinerator_Plant}]} {emit {Quake I save: d7 The incinerator plant}}
+if {[S 0 == {5\x0aThe_Foundry}]} {emit {Quake I save: d7b The foundry}}
+if {[S 0 == {5\x0aThe_Underwater_Base}]} {emit {Quake I save: d8 The underwater base}}
+if {[S 0 == {5\x0aTakahiro_Base}]} {emit {Quake I save: d9 Takahiro base}}
+if {[S 0 == {5\x0aTakahiro_Laboratories}]} {emit {Quake I save: d12 Takahiro laboratories}}
+if {[S 0 == {5\x0aStayin'_Alive}]} {emit {Quake I save: d13 Stayin' alive}}
+if {[S 0 == {5\x0aB.O.S.S._HQ}]} {emit {Quake I save: d14 B.O.S.S. HQ}}
+if {[S 0 == {5\x0aSHOWDOWN!}]} {emit {Quake I save: d15 Showdown!}}
+if {[S 0 == {5\x0aThe_Seventh_Precinct}]} {emit {Quake I save: ddm1 The seventh precinct}}
+if {[S 0 == {5\x0aSub_Station}]} {emit {Quake I save: ddm2 Sub station}}
+if {[S 0 == {5\x0aCrazy_Eights!}]} {emit {Quake I save: ddm3 Crazy eights!}}
+if {[S 0 == {5\x0aEast_Side_Invertationa}]} {emit {Quake I save: ddm4 East side invertationa}}
+if {[S 0 == {5\x0aSlaughterhouse}]} {emit {Quake I save: ddm5 Slaughterhouse}}
+if {[S 0 == {5\x0aDOMINO}]} {emit {Quake I save: ddm6 Domino}}
+if {[S 0 == {5\x0aSANDRA'S_LADDER}]} {emit {Quake I save: ddm7 Sandra's ladder}}
+if {[S 0 == MComprHD]} {emit {MAME CHD compressed hard disk image,}
+if {[N I 12 x {}]} {emit {version %lu}}
+}
+if {[S 0 == gpch]} {emit {GCC precompiled header}
+if {[N c 5 x {}]} {emit {\(version %c}}
+if {[N c 6 x {}]} {emit {\b%c}}
+if {[N c 7 x {}]} {emit {\b%c\)}}
+switch -- [Nv c 4] 67 {emit {for C}} 111 {emit {for Objective C}} 43 {emit {for C++}} 79 {emit {for Objective C++}}
+}
+if {[S 0 == {GIMP\ Gradient}]} {emit {GIMP gradient data}}
+if {[S 0 == {gimp\ xcf}]} {emit {GIMP XCF image data,}
+if {[S 9 == file]} {emit {version 0,}}
+if {[S 9 == v]} {emit version
+if {[S 10 x {}]} {emit %s,}
+}
+if {[N I 14 x {}]} {emit {%lu x}}
+if {[N I 18 x {}]} {emit %lu,}
+switch -- [Nv I 22] 0 {emit {RGB Color}} 1 {emit Greyscale} 2 {emit {Indexed Color}}
+if {[N I 22 > 0x2]} {emit {Unknown Image Type.}}
+}
+if {[S 20 == GPAT]} {emit {GIMP pattern data,}
+if {[S 24 x {}]} {emit %s}
+}
+if {[S 20 == GIMP]} {emit {GIMP brush data}}
+if {[S 0 == {\336\22\4\225}]} {emit {GNU message catalog \(little endian\),}
+if {[N i 4 x {}]} {emit {revision %d,}}
+if {[N i 8 x {}]} {emit {%d messages}}
+}
+if {[S 0 == {\225\4\22\336}]} {emit {GNU message catalog \(big endian\),}
+if {[N I 4 x {}]} {emit {revision %d,}}
+if {[N I 8 x {}]} {emit {%d messages}}
+}
+if {[S 0 == *nazgul*]} {emit {Nazgul style compiled message catalog}
+if {[N i 8 > 0x0]} {emit {\b, version %ld}}
+}
+if {[S 0 == {\001gpg}]} {emit {GPG key trust database}
+if {[N c 4 x {}]} {emit {version %d}}
+}
+if {[S 39 == <gmr:Workbook]} {emit {Gnumeric spreadsheet}}
+if {[S 0 == {\0LOCATE}]} {emit {GNU findutils locate database data}
+if {[S 7 x {}]} {emit {\b, format %s}}
+if {[S 7 == 02]} {emit {\b \(frcode\)}}
+}
+if {[S 0 == {\000\000\0001\000\000\0000\000\000\0000\000\000\0002\000\000\0000\000\000\0000\000\000\0003}]} {emit {old ACE/gr binary file}
+if {[N c 39 > 0x0]} {emit {- version %c}}
+}
+if {[S 0 == {\#\ xvgr\ parameter\ file}]} {emit {ACE/gr ascii file}}
+if {[S 0 == {\#\ xmgr\ parameter\ file}]} {emit {ACE/gr ascii file}}
+if {[S 0 == {\#\ ACE/gr\ parameter\ file}]} {emit {ACE/gr ascii file}}
+if {[S 0 == {\#\ Grace\ project\ file}]} {emit {Grace project file}
+if {[S 23 == {@version\ }]} {emit {\(version}
+if {[N c 32 > 0x0]} {emit %c}
+if {[S 33 x {}]} {emit {\b.%.2s}}
+if {[S 35 x {}]} {emit {\b.%.2s\)}}
+}
+}
+if {[S 0 == {\#\ ACE/gr\ fit\ description\ }]} {emit {ACE/gr fit description file}}
+if {[S 0 == {\211HDF\r\n\032}]} {emit {Hierarchical Data Format \(version 5\) data}}
+if {[S 0 == Bitmapfile]} {emit {HP Bitmapfile}}
+if {[S 0 == IMGfile]} {emit {CIS compimg HP Bitmapfile}}
+if {[S 0 == msgcat01]} {emit {HP NLS message catalog,}
+if {[N Q 8 > 0x0]} {emit {%d messages}}
+}
+if {[S 0 == HPHP48-]} {emit {HP48 binary}
+if {[N c 7 > 0x0]} {emit {- Rev %c}}
+switch -- [Nv S 8] 4393 {emit {\(ADR\)}} 13097 {emit {\(REAL\)}} 21801 {emit {\(LREAL\)}} 30505 {emit {\(COMPLX\)}} -25303 {emit {\(LCOMPLX\)}} -16599 {emit {\(CHAR\)}} -6103 {emit {\(ARRAY\)}} 2602 {emit {\(LNKARRAY\)}} 11306 {emit {\(STRING\)}} 20010 {emit {\(HXS\)}} 29738 {emit {\(LIST\)}} -27094 {emit {\(DIR\)}} -18390 {emit {\(ALG\)}} -9686 {emit {\(UNIT\)}} -982 {emit {\(TAGGED\)}} 7723 {emit {\(GROB\)}} 16427 {emit {\(LIB\)}} 25131 {emit {\(BACKUP\)}} -30677 {emit {\(LIBDATA\)}} -25299 {emit {\(PROG\)}} -13267 {emit {\(CODE\)}} 18478 {emit {\(GNAME\)}} 27950 {emit {\(LNAME\)}} -28114 {emit {\(XLIB\)}}
+}
+if {[S 0 == %%HP:]} {emit {HP48 text}
+if {[S 6 == T(0)]} {emit {- T\(0\)}}
+if {[S 6 == T(1)]} {emit {- T\(1\)}}
+if {[S 6 == T(2)]} {emit {- T\(2\)}}
+if {[S 6 == T(3)]} {emit {- T\(3\)}}
+if {[S 10 == A(D)]} {emit {A\(D\)}}
+if {[S 10 == A(R)]} {emit {A\(R\)}}
+if {[S 10 == A(G)]} {emit {A\(G\)}}
+if {[S 14 == F(.)]} {emit {F\(.\);}}
+if {[S 14 == F(,)]} {emit {F\(,\);}}
+}
+if {[S 16 == HP-UX]} {if {[N I 0 == 0x2]} {if {[N I 12 == 0x3c]} {switch -- [Nv I 76] 256 {emit {}
+if {[N I 88 == 0x44]} {if {[N I 160 == 0x1]} {if {[N I 172 == 0x4]} {if {[N I 176 == 0x1]} {if {[N I 180 == 0x4]} {emit {core file}
+if {[S 144 x {}]} {emit {from '%s'}}
+switch -- [Nv I 196] 3 {emit {- received SIGQUIT}} 4 {emit {- received SIGILL}} 5 {emit {- received SIGTRAP}} 6 {emit {- received SIGABRT}} 7 {emit {- received SIGEMT}} 8 {emit {- received SIGFPE}} 10 {emit {- received SIGBUS}} 11 {emit {- received SIGSEGV}} 12 {emit {- received SIGSYS}} 33 {emit {- received SIGXCPU}} 34 {emit {- received SIGXFSZ}}
+}
+}
+}
+}
+}
+} 1 {emit {}
+if {[N I 88 == 0x4]} {if {[N I 92 == 0x1]} {if {[N I 96 == 0x100]} {if {[N I 108 == 0x44]} {if {[N I 180 == 0x4]} {emit {core file}
+if {[S 164 x {}]} {emit {from '%s'}}
+switch -- [Nv I 196] 3 {emit {- received SIGQUIT}} 4 {emit {- received SIGILL}} 5 {emit {- received SIGTRAP}} 6 {emit {- received SIGABRT}} 7 {emit {- received SIGEMT}} 8 {emit {- received SIGFPE}} 10 {emit {- received SIGBUS}} 11 {emit {- received SIGSEGV}} 12 {emit {- received SIGSYS}} 33 {emit {- received SIGXCPU}} 34 {emit {- received SIGXFSZ}}
+}
+}
+}
+}
+}
+}
+}
+}
+}
+if {[S 36 == HP-UX]} {if {[N I 0 == 0x1]} {if {[N I 12 == 0x4]} {if {[N I 16 == 0x1]} {if {[N I 20 == 0x2]} {if {[N I 32 == 0x3c]} {if {[N I 96 == 0x100]} {if {[N I 108 == 0x44]} {if {[N I 180 == 0x4]} {emit {core file}
+if {[S 164 x {}]} {emit {from '%s'}}
+switch -- [Nv I 196] 3 {emit {- received SIGQUIT}} 4 {emit {- received SIGILL}} 5 {emit {- received SIGTRAP}} 6 {emit {- received SIGABRT}} 7 {emit {- received SIGEMT}} 8 {emit {- received SIGFPE}} 10 {emit {- received SIGBUS}} 11 {emit {- received SIGSEGV}} 12 {emit {- received SIGSYS}} 33 {emit {- received SIGXCPU}} 34 {emit {- received SIGXFSZ}}
+}
+}
+}
+}
+}
+}
+}
+}
+}
+if {[S 100 == HP-UX]} {if {[N I 0 == 0x100]} {if {[N I 12 == 0x44]} {if {[N I 84 == 0x2]} {if {[N I 96 == 0x3c]} {if {[N I 160 == 0x1]} {if {[N I 172 == 0x4]} {if {[N I 176 == 0x1]} {if {[N I 180 == 0x4]} {emit {core file}
+if {[S 68 x {}]} {emit {from '%s'}}
+switch -- [Nv I 196] 3 {emit {- received SIGQUIT}} 4 {emit {- received SIGILL}} 5 {emit {- received SIGTRAP}} 6 {emit {- received SIGABRT}} 7 {emit {- received SIGEMT}} 8 {emit {- received SIGFPE}} 10 {emit {- received SIGBUS}} 11 {emit {- received SIGSEGV}} 12 {emit {- received SIGSYS}} 33 {emit {- received SIGXCPU}} 34 {emit {- received SIGXFSZ}}
+}
+}
+}
+}
+}
+}
+}
+}
+}
+if {[S 120 == HP-UX]} {switch -- [Nv I 0] 1 {emit {}
+if {[N I 12 == 0x4]} {if {[N I 16 == 0x1]} {if {[N I 20 == 0x100]} {if {[N I 32 == 0x44]} {if {[N I 104 == 0x2]} {if {[N I 116 == 0x3c]} {if {[N I 180 == 0x4]} {emit {core file}
+if {[S 88 x {}]} {emit {from '%s'}}
+switch -- [Nv I 196] 3 {emit {- received SIGQUIT}} 4 {emit {- received SIGILL}} 5 {emit {- received SIGTRAP}} 6 {emit {- received SIGABRT}} 7 {emit {- received SIGEMT}} 8 {emit {- received SIGFPE}} 10 {emit {- received SIGBUS}} 11 {emit {- received SIGSEGV}} 12 {emit {- received SIGSYS}} 33 {emit {- received SIGXCPU}} 34 {emit {- received SIGXFSZ}}
+}
+}
+}
+}
+}
+}
+}
+} 256 {emit {}
+if {[N I 12 == 0x44]} {if {[N I 84 == 0x1]} {if {[N I 96 == 0x4]} {if {[N I 100 == 0x1]} {if {[N I 104 == 0x2]} {if {[N I 116 == 0x2c]} {if {[N I 180 == 0x4]} {emit {core file}
+if {[S 68 x {}]} {emit {from '%s'}}
+switch -- [Nv I 196] 3 {emit {- received SIGQUIT}} 4 {emit {- received SIGILL}} 5 {emit {- received SIGTRAP}} 6 {emit {- received SIGABRT}} 7 {emit {- received SIGEMT}} 8 {emit {- received SIGFPE}} 10 {emit {- received SIGBUS}} 11 {emit {- received SIGSEGV}} 12 {emit {- received SIGSYS}} 33 {emit {- received SIGXCPU}} 34 {emit {- received SIGXFSZ}}
+}
+}
+}
+}
+}
+}
+}
+}
+}
+if {[S 0 == HPHP49-]} {emit {HP49 binary}}
+if {[S 0 == 0xabcdef]} {emit {AIX message catalog}}
+if {[S 0 == <aiaff>]} {emit archive}
+if {[S 0 == <bigaf>]} {emit {archive \(big format\)}}
+if {[S 0 == FORM]} {emit {IFF data}
+if {[S 8 == AIFF]} {emit {\b, AIFF audio}}
+if {[S 8 == AIFC]} {emit {\b, AIFF-C compressed audio}}
+if {[S 8 == 8SVX]} {emit {\b, 8SVX 8-bit sampled sound voice}}
+if {[S 8 == SAMP]} {emit {\b, SAMP sampled audio}}
+if {[S 8 == DTYP]} {emit {\b, DTYP datatype description}}
+if {[S 8 == PTCH]} {emit {\b, PTCH binary patch}}
+if {[S 8 == ILBMBMHD]} {emit {\b, ILBM interleaved image}
+if {[N S 20 x {}]} {emit {\b, %d x}}
+if {[N S 22 x {}]} {emit %d}
+}
+if {[S 8 == RGBN]} {emit {\b, RGBN 12-bit RGB image}}
+if {[S 8 == RGB8]} {emit {\b, RGB8 24-bit RGB image}}
+if {[S 8 == DR2D]} {emit {\b, DR2D 2-D object}}
+if {[S 8 == TDDD]} {emit {\b, TDDD 3-D rendering}}
+if {[S 8 == FTXT]} {emit {\b, FTXT formatted text}}
+if {[S 8 == CTLG]} {emit {\b, CTLG message catalog}}
+if {[S 8 == PREF]} {emit {\b, PREF preferences}}
+}
+switch -- [Nv I 1 &0xfff7ffff] 16842752 {emit {Targa image data - Map}
+if {[N c 2 == 0x8 &8]} {emit {- RLE}}
+if {[N s 12 > 0x0]} {emit {%hd x}}
+if {[N s 14 > 0x0]} {emit %hd}
+} 131072 {emit {Targa image data - RGB}
+if {[N c 2 == 0x8 &8]} {emit {- RLE}}
+if {[N s 12 > 0x0]} {emit {%hd x}}
+if {[N s 14 > 0x0]} {emit %hd}
+} 196608 {emit {Targa image data - Mono}
+if {[N c 2 == 0x8 &8]} {emit {- RLE}}
+if {[N s 12 > 0x0]} {emit {%hd x}}
+if {[N s 14 > 0x0]} {emit %hd}
+}
+if {[S 0 == P1]} {emit {Netpbm PBM image text}}
+if {[S 0 == P2]} {emit {Netpbm PGM image text}}
+if {[S 0 == P3]} {emit {Netpbm PPM image text}}
+if {[S 0 == P4]} {emit {Netpbm PBM \"rawbits\" image data}}
+if {[S 0 == P5]} {emit {Netpbm PGM \"rawbits\" image data}}
+if {[S 0 == P6]} {emit {Netpbm PPM \"rawbits\" image data}}
+if {[S 0 == P7]} {emit {Netpbm PAM image file}}
+if {[S 0 == {\117\072}]} {emit {Solitaire Image Recorder format}
+if {[S 4 == {\013}]} {emit {MGI Type 11}}
+if {[S 4 == {\021}]} {emit {MGI Type 17}}
+}
+if {[S 0 == .MDA]} {emit {MicroDesign data}
+switch -- [Nv c 21] 48 {emit {version 2}} 51 {emit {version 3}}
+}
+if {[S 0 == .MDP]} {emit {MicroDesign page data}
+switch -- [Nv c 21] 48 {emit {version 2}} 51 {emit {version 3}}
+}
+if {[S 0 == IIN1]} {emit {NIFF image data}}
+if {[S 0 == {MM\x00\x2a}]} {emit {TIFF image data, big-endian}}
+if {[S 0 == {II\x2a\x00}]} {emit {TIFF image data, little-endian}}
+if {[S 0 == {\x89PNG}]} {emit {PNG image data,}
+if {[N I 4 != 0xd0a1a0a]} {emit CORRUPTED,}
+if {[N I 4 == 0xd0a1a0a]} {if {[N I 16 x {}]} {emit {%ld x}}
+if {[N I 20 x {}]} {emit %ld,}
+if {[N c 24 x {}]} {emit %d-bit}
+switch -- [Nv c 25] 0 {emit grayscale,} 2 {emit {\b/color RGB,}} 3 {emit colormap,} 4 {emit gray+alpha,} 6 {emit {\b/color RGBA,}}
+switch -- [Nv c 28] 0 {emit non-interlaced} 1 {emit interlaced}
+}
+}
+if {[S 1 == PNG]} {emit {PNG image data, CORRUPTED}}
+if {[S 0 == GIF8]} {emit {GIF image data}
+if {[S 4 == 7a]} {emit {\b, version 8%s,}}
+if {[S 4 == 9a]} {emit {\b, version 8%s,}}
+if {[N s 6 > 0x0]} {emit {%hd x}}
+if {[N s 8 > 0x0]} {emit %hd}
+}
+if {[S 0 == {\361\0\100\273}]} {emit {CMU window manager raster image data}
+if {[N i 4 > 0x0]} {emit {%d x}}
+if {[N i 8 > 0x0]} {emit %d,}
+if {[N i 12 > 0x0]} {emit %d-bit}
+}
+if {[S 0 == id=ImageMagick]} {emit {MIFF image data}}
+if {[S 0 == {\#FIG}]} {emit {FIG image text}
+if {[S 5 x {}]} {emit {\b, version %.3s}}
+}
+if {[S 0 == ARF_BEGARF]} {emit {PHIGS clear text archive}}
+if {[S 0 == {@(\#)SunPHIGS}]} {emit SunPHIGS
+if {[S 40 == SunBin]} {emit binary}
+if {[S 32 == archive]} {emit archive}
+}
+if {[S 0 == GKSM]} {emit {GKS Metafile}
+if {[S 24 == SunGKS]} {emit {\b, SunGKS}}
+}
+if {[S 0 == BEGMF]} {emit {clear text Computer Graphics Metafile}}
+if {[N S 0 == 0x20 &0xffe0]} {emit {binary Computer Graphics Metafile}}
+if {[S 0 == yz]} {emit {MGR bitmap, modern format, 8-bit aligned}}
+if {[S 0 == zz]} {emit {MGR bitmap, old format, 1-bit deep, 16-bit aligned}}
+if {[S 0 == xz]} {emit {MGR bitmap, old format, 1-bit deep, 32-bit aligned}}
+if {[S 0 == yx]} {emit {MGR bitmap, modern format, squeezed}}
+if {[S 0 == {%bitmap\0}]} {emit {FBM image data}
+switch -- [Nv Q 30] 49 {emit {\b, mono}} 51 {emit {\b, color}}
+}
+if {[S 1 == {PC\ Research,\ Inc}]} {emit {group 3 fax data}
+switch -- [Nv c 29] 0 {emit {\b, normal resolution \(204x98 DPI\)}} 1 {emit {\b, fine resolution \(204x196 DPI\)}}
+}
+if {[S 0 == Sfff]} {emit {structured fax file}}
+if {[S 0 == BM]} {emit {PC bitmap data}
+switch -- [Nv s 14] 12 {emit {\b, OS/2 1.x format}
+if {[N s 18 x {}]} {emit {\b, %d x}}
+if {[N s 20 x {}]} {emit %d}
+} 64 {emit {\b, OS/2 2.x format}
+if {[N s 18 x {}]} {emit {\b, %d x}}
+if {[N s 20 x {}]} {emit %d}
+} 40 {emit {\b, Windows 3.x format}
+if {[N i 18 x {}]} {emit {\b, %d x}}
+if {[N i 22 x {}]} {emit {%d x}}
+if {[N s 28 x {}]} {emit %d}
+}
+}
+if {[S 0 == {/*\ XPM\ */}]} {emit {X pixmap image text}}
+if {[S 0 == {Imagefile\ version-}]} {emit {iff image data}
+if {[S 10 x {}]} {emit %s}
+}
+if {[S 0 == IT01]} {emit {FIT image data}
+if {[N I 4 x {}]} {emit {\b, %d x}}
+if {[N I 8 x {}]} {emit {%d x}}
+if {[N I 12 x {}]} {emit %d}
+}
+if {[S 0 == IT02]} {emit {FIT image data}
+if {[N I 4 x {}]} {emit {\b, %d x}}
+if {[N I 8 x {}]} {emit {%d x}}
+if {[N I 12 x {}]} {emit %d}
+}
+if {[S 2048 == PCD_IPI]} {emit {Kodak Photo CD image pack file}
+switch -- [Nv c 3586 &0x03] 0 {emit {, landscape mode}} 1 {emit {, portrait mode}} 2 {emit {, landscape mode}} 3 {emit {, portrait mode}}
+}
+if {[S 0 == PCD_OPA]} {emit {Kodak Photo CD overview pack file}}
+if {[S 0 == {SIMPLE\ \ =}]} {emit {FITS image data}
+if {[S 109 == 8]} {emit {\b, 8-bit, character or unsigned binary integer}}
+if {[S 108 == 16]} {emit {\b, 16-bit, two's complement binary integer}}
+if {[S 107 == {\ 32}]} {emit {\b, 32-bit, two's complement binary integer}}
+if {[S 107 == -32]} {emit {\b, 32-bit, floating point, single precision}}
+if {[S 107 == -64]} {emit {\b, 64-bit, floating point, double precision}}
+}
+if {[S 0 == {This\ is\ a\ BitMap\ file}]} {emit {Lisp Machine bit-array-file}}
+if {[S 0 == !!]} {emit {Bennet Yee's \"face\" format}}
+if {[S 1536 == {Visio\ (TM)\ Drawing}]} {emit %s}
+if {[S 0 == {\%TGIF\ x}]} {emit {Tgif file version %s}}
+if {[S 128 == DICM]} {emit {DICOM medical imaging data}}
+switch -- [Nv I 4] 7 {emit {XWD X Window Dump image data}
+if {[S 100 x {}]} {emit {\b, \"%s\"}}
+if {[N I 16 x {}]} {emit {\b, %dx}}
+if {[N I 20 x {}]} {emit {\b%dx}}
+if {[N I 12 x {}]} {emit {\b%d}}
+} 2097152000 {emit GLF_BINARY_LSB_FIRST} 125 {emit GLF_BINARY_MSB_FIRST} 268435456 {emit GLS_BINARY_LSB_FIRST} 16 {emit GLS_BINARY_MSB_FIRST} 19195 {emit {QDOS executable}
+if {[S 9 x {} p]} {emit '%s'}
+}
+if {[S 0 == NJPL1I00]} {emit {PDS \(JPL\) image data}}
+if {[S 2 == NJPL1I]} {emit {PDS \(JPL\) image data}}
+if {[S 0 == CCSD3ZF]} {emit {PDS \(CCSD\) image data}}
+if {[S 2 == CCSD3Z]} {emit {PDS \(CCSD\) image data}}
+if {[S 0 == PDS_]} {emit {PDS image data}}
+if {[S 0 == LBLSIZE=]} {emit {PDS \(VICAR\) image data}}
+if {[S 0 == pM85]} {emit {Atari ST STAD bitmap image data \(hor\)}
+switch -- [Nv c 5] 0 {emit {\(white background\)}} -1 {emit {\(black background\)}}
+}
+if {[S 0 == pM86]} {emit {Atari ST STAD bitmap image data \(vert\)}
+switch -- [Nv c 5] 0 {emit {\(white background\)}} -1 {emit {\(black background\)}}
+}
+if {[S 0 == {\x37\x00\x00\x10\x42\x00\x00\x10\x00\x00\x00\x00\x39\x64\x39\x47}]} {emit {EPOC MBM image file}}
+if {[S 0 == 8BPS]} {emit {Adobe Photoshop Image}}
+if {[S 0 == {P7\ 332}]} {emit {XV thumbnail image data}}
+if {[S 0 == NITF]} {emit {National Imagery Transmission Format}
+if {[S 25 x {}]} {emit {dated %.14s}}
+}
+if {[S 0 == {\0\nSMJPEG}]} {emit SMJPEG
+if {[N I 8 x {}]} {emit {%d.x data}}
+if {[S 16 == _SND]} {emit {\b,}
+if {[N S 24 > 0x0]} {emit {%d Hz}}
+switch -- [Nv c 26] 8 {emit 8-bit} 16 {emit 16-bit}
+if {[S 28 == NONE]} {emit uncompressed}
+if {[N c 27 == 0x1]} {emit mono}
+if {[N c 28 == 0x2]} {emit stereo}
+if {[S 32 == _VID]} {emit {\b,}
+if {[N I 40 > 0x0]} {emit {%d frames}}
+if {[N S 44 > 0x0]} {emit {\(%d x}}
+if {[N S 46 > 0x0]} {emit {%d\)}}
+}
+}
+if {[S 16 == _VID]} {emit {\b,}
+if {[N I 24 > 0x0]} {emit {%d frames}}
+if {[N S 28 > 0x0]} {emit {\(%d x}}
+if {[N S 30 > 0x0]} {emit {%d\)}}
+}
+}
+if {[S 0 == {Paint\ Shop\ Pro\ Image\ File}]} {emit {Paint Shop Pro Image File}}
+if {[S 0 == {P7\ 332}]} {emit {XV \"thumbnail file\" \(icon\) data}}
+if {[S 0 == KiSS]} {emit KISS/GS
+switch -- [Nv c 4] 16 {emit color
+if {[N c 5 x {}]} {emit {%d bit}}
+if {[N s 8 x {}]} {emit {%d colors}}
+if {[N s 10 x {}]} {emit {%d groups}}
+} 32 {emit cell
+if {[N c 5 x {}]} {emit {%d bit}}
+if {[N s 8 x {}]} {emit {%d x}}
+if {[N s 10 x {}]} {emit %d}
+if {[N s 12 x {}]} {emit +%d}
+if {[N s 14 x {}]} {emit +%d}
+}
+}
+if {[S 0 == {C\253\221g\230\0\0\0}]} {emit {Webshots Desktop .wbz file}}
+if {[S 0 == CKD_P370]} {emit {Hercules CKD DASD image file}
+if {[N Q 8 x {}]} {emit {\b, %d heads per cylinder}}
+if {[N Q 12 x {}]} {emit {\b, track size %d bytes}}
+if {[N c 16 x {}]} {emit {\b, device type 33%2.2X}}
+}
+if {[S 0 == CKD_C370]} {emit {Hercules compressed CKD DASD image file}
+if {[N Q 8 x {}]} {emit {\b, %d heads per cylinder}}
+if {[N Q 12 x {}]} {emit {\b, track size %d bytes}}
+if {[N c 16 x {}]} {emit {\b, device type 33%2.2X}}
+}
+if {[S 0 == CKD_S370]} {emit {Hercules CKD DASD shadow file}
+if {[N Q 8 x {}]} {emit {\b, %d heads per cylinder}}
+if {[N Q 12 x {}]} {emit {\b, track size %d bytes}}
+if {[N c 16 x {}]} {emit {\b, device type 33%2.2X}}
+}
+if {[S 0 == {\146\031\0\0}]} {emit {Squeak image data}}
+if {[S 0 == {'From\040Squeak}]} {emit {Squeak program text}}
+if {[S 0 == PaRtImAgE-VoLuMe]} {emit PartImage
+if {[S 32 == 0.6.1]} {emit {file version %s}
+if {[N i 96 > 0xffffffff]} {emit {volume %ld}}
+if {[S 512 x {}]} {emit {type %s}}
+if {[S 5120 x {}]} {emit {device %s,}}
+if {[S 5632 x {}]} {emit {original filename %s,}}
+switch -- [Nv i 10052] 0 {emit {not compressed}} 1 {emit {gzip compressed}} 2 {emit {bzip2 compressed}}
+if {[N i 10052 > 0x2]} {emit {compressed with unknown algorithm}}
+}
+if {[S 32 > 0.6.1]} {emit {file version %s}}
+if {[S 32 < 0.6.1]} {emit {file version %s}}
+}
+if {[N s 54 == 0x3039]} {emit {Bio-Rad .PIC Image File}
+if {[N s 0 > 0x0]} {emit {%hd x}}
+if {[N s 2 > 0x0]} {emit %hd,}
+if {[N s 4 == 0x1]} {emit {1 image in file}}
+if {[N s 4 > 0x1]} {emit {%hd images in file}}
+}
+if {[S 0 == {\000MRM}]} {emit {Minolta Dimage camera raw image data}}
+if {[S 0 == AT&TFORM]} {emit {DjVu Image file}}
+if {[S 0 == {CDF\001}]} {emit {NetCDF Data Format data}}
+if {[S 0 == {\211HDF\r\n\032}]} {emit {Hierarchical Data Format \(version 5\) data}}
+if {[S 0 == {\210OPS}]} {emit {Interleaf saved data}}
+if {[S 0 == <!OPS]} {emit {Interleaf document text}
+if {[S 5 == {,\ Version\ =}]} {emit {\b, version}
+if {[S 17 x {}]} {emit %.3s}
+}
+}
+if {[S 4 == pgscriptver]} {emit {IslandWrite document}}
+if {[S 13 == DrawFile]} {emit {IslandDraw document}}
+if {[N s 0 == 0x9600 &0xFFFC]} {emit {little endian ispell}
+switch -- [Nv c 0] 0 {emit {hash file \(?\),}} 1 {emit {3.0 hash file,}} 2 {emit {3.1 hash file,}} 3 {emit {hash file \(?\),}}
+switch -- [Nv s 2] 0 {emit {8-bit, no capitalization, 26 flags}} 1 {emit {7-bit, no capitalization, 26 flags}} 2 {emit {8-bit, capitalization, 26 flags}} 3 {emit {7-bit, capitalization, 26 flags}} 4 {emit {8-bit, no capitalization, 52 flags}} 5 {emit {7-bit, no capitalization, 52 flags}} 6 {emit {8-bit, capitalization, 52 flags}} 7 {emit {7-bit, capitalization, 52 flags}} 8 {emit {8-bit, no capitalization, 128 flags}} 9 {emit {7-bit, no capitalization, 128 flags}} 10 {emit {8-bit, capitalization, 128 flags}} 11 {emit {7-bit, capitalization, 128 flags}} 12 {emit {8-bit, no capitalization, 256 flags}} 13 {emit {7-bit, no capitalization, 256 flags}} 14 {emit {8-bit, capitalization, 256 flags}} 15 {emit {7-bit, capitalization, 256 flags}}
+if {[N s 4 > 0x0]} {emit {and %d string characters}}
+}
+if {[N S 0 == 0x9600 &0xFFFC]} {emit {big endian ispell}
+switch -- [Nv c 1] 0 {emit {hash file \(?\),}} 1 {emit {3.0 hash file,}} 2 {emit {3.1 hash file,}} 3 {emit {hash file \(?\),}}
+switch -- [Nv S 2] 0 {emit {8-bit, no capitalization, 26 flags}} 1 {emit {7-bit, no capitalization, 26 flags}} 2 {emit {8-bit, capitalization, 26 flags}} 3 {emit {7-bit, capitalization, 26 flags}} 4 {emit {8-bit, no capitalization, 52 flags}} 5 {emit {7-bit, no capitalization, 52 flags}} 6 {emit {8-bit, capitalization, 52 flags}} 7 {emit {7-bit, capitalization, 52 flags}} 8 {emit {8-bit, no capitalization, 128 flags}} 9 {emit {7-bit, no capitalization, 128 flags}} 10 {emit {8-bit, capitalization, 128 flags}} 11 {emit {7-bit, capitalization, 128 flags}} 12 {emit {8-bit, no capitalization, 256 flags}} 13 {emit {7-bit, no capitalization, 256 flags}} 14 {emit {8-bit, capitalization, 256 flags}} 15 {emit {7-bit, capitalization, 256 flags}}
+if {[N S 4 > 0x0]} {emit {and %d string characters}}
+}
+if {[S 0 == ISPL]} {emit ispell
+if {[N Q 4 x {}]} {emit {hash file version %d,}}
+if {[N Q 8 x {}]} {emit {lexletters %d,}}
+if {[N Q 12 x {}]} {emit {lexsize %d,}}
+if {[N Q 16 x {}]} {emit {hashsize %d,}}
+if {[N Q 20 x {}]} {emit {stblsize %d}}
+}
+if {[S 0 == hsi1]} {emit {JPEG image data, HSI proprietary}}
+if {[S 0 == {\x00\x00\x00\x0C\x6A\x50\x20\x20\x0D\x0A\x87\x0A}]} {emit {JPEG 2000 image data}}
+if {[S 0 == KarmaRHD]} {emit {Version Karma Data Structure Version}
+if {[N I 16 x {}]} {emit %lu}
+}
+if {[S 0 == lect]} {emit {DEC SRC Virtual Paper Lectern file}}
+if {[S 53 == yyprevious]} {emit {C program text \(from lex\)}
+if {[S 3 x {}]} {emit {for %s}}
+}
+if {[S 21 == {generated\ by\ flex}]} {emit {C program text \(from flex\)}}
+if {[S 0 == {%\{}]} {emit {lex description text}}
+if {[S 0 == {\007\001\000}]} {emit {Linux/i386 object file}
+if {[N i 20 > 0x1020]} {emit {\b, DLL library}}
+}
+if {[S 0 == {\01\03\020\04}]} {emit {Linux-8086 impure executable}
+if {[N Q 28 != 0x0]} {emit {not stripped}}
+}
+if {[S 0 == {\01\03\040\04}]} {emit {Linux-8086 executable}
+if {[N Q 28 != 0x0]} {emit {not stripped}}
+}
+if {[S 0 == {\243\206\001\0}]} {emit {Linux-8086 object file}}
+if {[S 0 == {\01\03\020\20}]} {emit {Minix-386 impure executable}
+if {[N Q 28 != 0x0]} {emit {not stripped}}
+}
+if {[S 0 == {\01\03\040\20}]} {emit {Minix-386 executable}
+if {[N Q 28 != 0x0]} {emit {not stripped}}
+}
+if {[N i 216 == 0x111]} {emit {Linux/i386 core file}
+if {[S 220 x {}]} {emit {of '%s'}}
+if {[N i 200 > 0x0]} {emit {\(signal %d\)}}
+}
+if {[S 2 == LILO]} {emit {Linux/i386 LILO boot/chain loader}}
+if {[S 4086 == SWAP-SPACE]} {emit {Linux/i386 swap file}}
+if {[S 4086 == SWAPSPACE2]} {emit {Linux/i386 swap file \(new style\)}
+if {[N Q 1024 x {}]} {emit {%d \(4K pages\)}}
+if {[N Q 1028 x {}]} {emit {size %d pages}}
+}
+if {[S 514 == HdrS]} {emit {Linux kernel}
+if {[N s 510 == 0xaa55]} {emit {x86 boot executable}
+if {[N c 529 == 0x0]} {emit zImage,
+if {[N c 529 == 0x1]} {emit bzImage,}
+if {[S [I 526 s 512] x {}]} {emit {version %s,}}
+}
+switch -- [Nv s 498] 1 {emit RO-rootFS,} 0 {emit RW-rootFS,}
+if {[N s 508 > 0x0]} {emit {root_dev 0x%X,}}
+if {[N s 502 > 0x0]} {emit {swap_dev 0x%X,}}
+if {[N s 504 > 0x0]} {emit {RAMdisksize %u KB,}}
+switch -- [Nv s 506] -1 {emit {Normal VGA}} -2 {emit {Extended VGA}} -3 {emit {Prompt for Videomode}}
+if {[N s 506 > 0x0]} {emit {Video mode %d}}
+}
+}
+if {[S 8 == {\ A\ _text}]} {emit {Linux kernel symbol map text}}
+if {[S 0 == Begin3]} {emit {Linux Software Map entry text}}
+if {[S 0 == Begin4]} {emit {Linux Software Map entry text \(new format\)}}
+if {[S 0 == {\xb8\xc0\x07\x8e\xd8\xb8\x00\x90}]} {emit Linux
+if {[N s 497 == 0x0]} {emit {x86 boot sector}
+switch -- [Nv I 514] 142 {emit {of a kernel from the dawn of time!}} -1869686604 {emit {version 0.99-1.1.42}} -1869686600 {emit {for memtest86}}
+}
+if {[N s 497 != 0x0]} {emit {x86 kernel}
+if {[N s 504 > 0x0]} {emit {RAMdisksize=%u KB}}
+if {[N s 502 > 0x0]} {emit swap=0x%X}
+if {[N s 508 > 0x0]} {emit root=0x%X
+switch -- [Nv s 498] 1 {emit {\b-ro}} 0 {emit {\b-rw}}
+}
+switch -- [Nv s 506] -1 {emit vga=normal} -2 {emit vga=extended} -3 {emit vga=ask}
+if {[N s 506 > 0x0]} {emit vga=%d}
+switch -- [Nv I 514] -1869686655 {emit {version 1.1.43-1.1.45}} 364020173 {emit {}
+if {[N I 2702 == 0x55aa5a5a]} {emit {version 1.1.46-1.2.13,1.3.0}}
+if {[N I 2713 == 0x55aa5a5a]} {emit {version 1.3.1,2}}
+if {[N I 2723 == 0x55aa5a5a]} {emit {version 1.3.3-1.3.30}}
+if {[N I 2726 == 0x55aa5a5a]} {emit {version 1.3.31-1.3.41}}
+if {[N I 2859 == 0x55aa5a5a]} {emit {version 1.3.42-1.3.45}}
+if {[N I 2807 == 0x55aa5a5a]} {emit {version 1.3.46-1.3.72}}
+}
+if {[S 514 == HdrS]} {if {[N s 518 > 0x1ff]} {switch -- [Nv c 529] 0 {emit {\b, zImage}} 1 {emit {\b, bzImage}}
+if {[S [I 526 s 512] x {}]} {emit {\b, version %s}}
+}
+}
+}
+}
+if {[N i 0 == 0xc30000e9 &0xFF0000FF]} {emit {Linux-Dev86 executable, headerless}
+if {[S 5 == .]} {if {[S 4 x {}]} {emit {\b, libc version %s}}
+}
+}
+if {[N i 0 == 0x4000301 &0xFF00FFFF]} {emit {Linux-8086 executable}
+if {[N c 2 != 0x0 &0x01]} {emit {\b, unmapped zero page}}
+if {[N c 2 == 0x0 &0x20]} {emit {\b, impure}}
+if {[N c 2 != 0x0 &0x20]} {if {[N c 2 != 0x0 &0x10]} {emit {\b, A_EXEC}}
+}
+if {[N c 2 != 0x0 &0x02]} {emit {\b, A_PAL}}
+if {[N c 2 != 0x0 &0x04]} {emit {\b, A_NSYM}}
+if {[N c 2 != 0x0 &0x08]} {emit {\b, A_STAND}}
+if {[N c 2 != 0x0 &0x40]} {emit {\b, A_PURE}}
+if {[N c 2 != 0x0 &0x80]} {emit {\b, A_TOVLY}}
+if {[N Q 28 != 0x0]} {emit {\b, not stripped}}
+if {[S 37 == .]} {if {[S 36 x {}]} {emit {\b, libc version %s}}
+}
+}
+if {[S 0 == {;;}]} {emit {Lisp/Scheme program text}}
+if {[S 0 == {\012(}]} {emit {Emacs v18 byte-compiled Lisp data}}
+if {[S 0 == {;ELC}]} {if {[N c 4 > 0x13]} {emit 636 0}
+if {[N c 4 < 0x20]} {emit {Emacs/XEmacs v%d byte-compiled Lisp data}}
+}
+if {[S 0 == {(SYSTEM::VERSION\040'}]} {emit {CLISP byte-compiled Lisp program text}}
+if {[S 0 == {\372\372\372\372}]} {emit {MIT scheme \(library?\)}}
+if {[S 0 == <TeXmacs|]} {emit {TeXmacs document text}}
+if {[S 11 == {must\ be\ converted\ with\ BinHex}]} {emit {BinHex binary text}
+if {[S 41 x {}]} {emit {\b, version %.3s}}
+}
+if {[S 0 == SIT!]} {emit {StuffIt Archive \(data\)}
+if {[S 2 x {}]} {emit {: %s}}
+}
+if {[S 0 == SITD]} {emit {StuffIt Deluxe \(data\)}
+if {[S 2 x {}]} {emit {: %s}}
+}
+if {[S 0 == Seg]} {emit {StuffIt Deluxe Segment \(data\)}
+if {[S 2 x {}]} {emit {: %s}}
+}
+if {[S 0 == StuffIt]} {emit {StuffIt Archive}}
+if {[S 0 == APPL]} {emit {Macintosh Application \(data\)}
+if {[S 2 x {}]} {emit {\b: %s}}
+}
+if {[S 0 == zsys]} {emit {Macintosh System File \(data\)}}
+if {[S 0 == FNDR]} {emit {Macintosh Finder \(data\)}}
+if {[S 0 == libr]} {emit {Macintosh Library \(data\)}
+if {[S 2 x {}]} {emit {: %s}}
+}
+if {[S 0 == shlb]} {emit {Macintosh Shared Library \(data\)}
+if {[S 2 x {}]} {emit {: %s}}
+}
+if {[S 0 == cdev]} {emit {Macintosh Control Panel \(data\)}
+if {[S 2 x {}]} {emit {: %s}}
+}
+if {[S 0 == INIT]} {emit {Macintosh Extension \(data\)}
+if {[S 2 x {}]} {emit {: %s}}
+}
+if {[S 0 == FFIL]} {emit {Macintosh Truetype Font \(data\)}
+if {[S 2 x {}]} {emit {: %s}}
+}
+if {[S 0 == LWFN]} {emit {Macintosh Postscript Font \(data\)}
+if {[S 2 x {}]} {emit {: %s}}
+}
+if {[S 0 == PACT]} {emit {Macintosh Compact Pro Archive \(data\)}
+if {[S 2 x {}]} {emit {: %s}}
+}
+if {[S 0 == ttro]} {emit {Macintosh TeachText File \(data\)}
+if {[S 2 x {}]} {emit {: %s}}
+}
+if {[S 0 == TEXT]} {emit {Macintosh TeachText File \(data\)}
+if {[S 2 x {}]} {emit {: %s}}
+}
+if {[S 0 == PDF]} {emit {Macintosh PDF File \(data\)}
+if {[S 2 x {}]} {emit {: %s}}
+}
+if {[S 102 == mBIN]} {emit {MacBinary III data with surprising version number}}
+if {[S 0 == SAS]} {emit SAS
+if {[S 24 == DATA]} {emit {data file}}
+if {[S 24 == CATALOG]} {emit catalog}
+if {[S 24 == INDEX]} {emit {data file index}}
+if {[S 24 == VIEW]} {emit {data view}}
+}
+if {[S 84 == SAS]} {emit {SAS 7+}
+if {[S 156 == DATA]} {emit {data file}}
+if {[S 156 == CATALOG]} {emit catalog}
+if {[S 156 == INDEX]} {emit {data file index}}
+if {[S 156 == VIEW]} {emit {data view}}
+}
+if {[S 0 == {$FL2}]} {emit {SPSS System File}
+if {[S 24 x {}]} {emit %s}
+}
+switch -- [Nvx 1 S 1024] -11561 {emit {Macintosh MFS data}
+if {[N S 0 == 0x4c4b]} {emit {\(bootable\)}}
+if {[N S 1034 & 0x8000]} {emit {\(locked\)}}
+if {[N I 1026 x {} -0x7C25B080]} {emit {created: %s,}}
+if {[N I 1030 > 0x0 -0x7C25B080]} {emit {last backup: %s,}}
+if {[N I 1044 x {}]} {emit {block size: %d,}}
+if {[N S 1042 x {}]} {emit {number of blocks: %d,}}
+if {[S 1060 x {} p]} {emit {volume name: %s}}
+} 18475 {emit {Macintosh HFS Extended}
+if {[N S [R 0] x {}]} {emit {version %d data}}
+if {[N S 0 == 0x4c4b]} {emit {\(bootable\)}}
+if {[N I 1028 ^ 0x100]} {emit {\(mounted\)}}
+if {[N I [R 2] & 0x200]} {emit {\(spared blocks\)}}
+if {[N I [R 2] & 0x800]} {emit {\(unclean\)}}
+if {[N I [R 2] & 0x8000]} {emit {\(locked\)}}
+if {[S [R 6] x {}]} {emit {last mounted by: '%.4s',}}
+if {[N I [R 14] x {} -0x7C25B080]} {emit {created: %s,}}
+if {[N S [R 18] x {} -0x7C25B080]} {emit {last modified: %s,}}
+if {[N S [R 22] > 0x0 -0x7C25B080]} {emit {last backup: %s,}}
+if {[N S [R 26] > 0x0 -0x7C25B080]} {emit {last checked: %s,}}
+if {[N I [R 38] x {}]} {emit {block size: %d,}}
+if {[N I [R 42] x {}]} {emit {number of blocks: %d,}}
+if {[N I [R 46] x {}]} {emit {free blocks: %d}}
+}
+switch -- [Nv S 512] 20557 {emit {Apple Partition data}
+if {[N S 2 x {}]} {emit {block size: %d,}}
+if {[S 560 x {}]} {emit {first type: %s,}}
+if {[S 528 x {}]} {emit {name: %s,}}
+if {[N I 596 x {}]} {emit {number of blocks: %d,}}
+if {[N S 1024 == 0x504d]} {if {[S 1072 x {}]} {emit {second type: %s,}}
+if {[S 1040 x {}]} {emit {name: %s,}}
+if {[N I 1108 x {}]} {emit {number of blocks: %d,}}
+if {[N S 2048 == 0x504d]} {if {[S 2096 x {}]} {emit {third type: %s,}}
+if {[S 2064 x {}]} {emit {name: %s,}}
+if {[N I 2132 x {}]} {emit {number of blocks: %d,}}
+if {[N S 2560 == 0x504d]} {if {[S 2608 x {}]} {emit {fourth type: %s,}}
+if {[S 2576 x {}]} {emit {name: %s,}}
+if {[N I 2644 x {}]} {emit {number of blocks: %d}}
+}
+}
+}
+} 21587 {emit {Apple Old Partition data}
+if {[N S 2 x {}]} {emit {block size: %d,}}
+if {[S 560 x {}]} {emit {first type: %s,}}
+if {[S 528 x {}]} {emit {name: %s,}}
+if {[N I 596 x {}]} {emit {number of blocks: %d,}}
+if {[N S 1024 == 0x504d]} {if {[S 1072 x {}]} {emit {second type: %s,}}
+if {[S 1040 x {}]} {emit {name: %s,}}
+if {[N I 1108 x {}]} {emit {number of blocks: %d,}}
+if {[N S 2048 == 0x504d]} {if {[S 2096 x {}]} {emit {third type: %s,}}
+if {[S 2064 x {}]} {emit {name: %s,}}
+if {[N I 2132 x {}]} {emit {number of blocks: %d,}}
+if {[N S 2560 == 0x504d]} {if {[S 2608 x {}]} {emit {fourth type: %s,}}
+if {[S 2576 x {}]} {emit {name: %s,}}
+if {[N I 2644 x {}]} {emit {number of blocks: %d}}
+}
+}
+}
+}
+if {[S 0 == BOMStore]} {emit {Mac OS X bill of materials \(BOM\) fil}}
+if {[S 0 == {\#\ Magic}]} {emit {magic text file for file\(1\) cmd}}
+if {[S 0 == Relay-Version:]} {emit {old news text}}
+if {[S 0 == {\#!\ rnews}]} {emit {batched news text}}
+if {[S 0 == {N\#!\ rnews}]} {emit {mailed, batched news text}}
+if {[S 0 == {Forward\ to}]} {emit {mail forwarding text}}
+if {[S 0 == {Pipe\ to}]} {emit {mail piping text}}
+if {[S 0 == Return-Path:]} {emit {smtp mail text}}
+if {[S 0 == Path:]} {emit {news text}}
+if {[S 0 == Xref:]} {emit {news text}}
+if {[S 0 == From:]} {emit {news or mail text}}
+if {[S 0 == Article]} {emit {saved news text}}
+if {[S 0 == BABYL]} {emit {Emacs RMAIL text}}
+if {[S 0 == Received:]} {emit {RFC 822 mail text}}
+if {[S 0 == MIME-Version:]} {emit {MIME entity text}}
+if {[S 0 == *mbx*]} {emit {MBX mail folder}}
+if {[S 0 == {\241\002\213\015skiplist\ file\0\0\0}]} {emit {Cyrus skiplist DB}}
+if {[S 0 == {JAM\0}]} {emit {JAM message area header file}
+if {[N s 12 > 0x0]} {emit {\(%d messages\)}}
+}
+if {[S 0 == {\000MVR4\nI}]} {emit {MapleVr4 library}}
+if {[S 0 == {\000\004\000\000}]} {emit {Maple help database}}
+if {[S 0 == <PACKAGE=]} {emit {Maple help file}}
+if {[S 0 == {<HELP\ NAME=}]} {emit {Maple help file}}
+if {[S 0 == {\n\<HELP\ NAME=}]} {emit {Maple help file with extra carriage return at start \(yuck\)}}
+if {[S 0 == {\#\ daub}]} {emit {Maple help file, old style}}
+if {[S 0 == {\000\000\001\044\000\221}]} {emit {Maple worksheet}}
+if {[S 0 == {WriteNow\000\002\000\001\000\000\000\000\100\000\000\000\000\000}]} {emit {Maple worksheet, but weird}}
+if {[S 0 == {\{VERSION\ }]} {emit {Maple worksheet}
+if {[S 9 x {}]} {emit {version %.1s. {36 string {} x 11 {} %.1s}}}
+}
+if {[S 0 == {\0\0\001$}]} {emit {Maple something}
+if {[S 4 == {\000\105}]} {emit {An old revision}}
+if {[S 4 == {\001\122}]} {emit {The latest save}}
+}
+if {[S 0 == {\#\n\#\#\ <SHAREFILE=}]} {emit {Maple something}}
+if {[S 0 == {\n\#\n\#\#\ <SHAREFILE=}]} {emit {Maple something}}
+if {[S 0 == {\#\#\ <SHAREFILE=}]} {emit {Maple something}}
+if {[S 0 == {\#\r\#\#\ <SHAREFILE=}]} {emit {Maple something}}
+if {[S 0 == {\r\#\r\#\#\ <SHAREFILE=}]} {emit {Maple something}}
+if {[S 0 == {\#\ \r\#\#\ <DESCRIBE>}]} {emit {Maple something anomalous.}}
+if {[S 0 == {\064\024\012\000\035\000\000\000}]} {emit {Mathematica version 2 notebook}}
+if {[S 0 == {\064\024\011\000\035\000\000\000}]} {emit {Mathematica version 2 notebook}}
+if {[S 0 == {(*^\n\n::[\011frontEndVersion\ =\ }]} {emit {Mathematica notebook}}
+if {[S 0 == {(*^\r\r::[\011}]} {emit {Mathematica notebook version 2.x}}
+if {[S 0 == {\(\*\^\r\n\r\n\:\:\[\011}]} {emit {Mathematica notebook version 2.x}}
+if {[S 0 == {(*^\015}]} {emit {Mathematica notebook version 2.x}}
+if {[S 0 == {(*^\n\r\n\r::[\011}]} {emit {Mathematica notebook version 2.x}}
+if {[S 0 == {(*^\r::[\011}]} {emit {Mathematica notebook version 2.x}}
+if {[S 0 == {(*^\r\n::[\011}]} {emit {Mathematica notebook version 2.x}}
+if {[S 0 == {(*^\n\n::[\011}]} {emit {Mathematica notebook version 2.x}}
+if {[S 0 == {(*^\n::[\011}]} {emit {Mathematica notebook version 2.x}}
+if {[S 0 == {(*This\ is\ a\ Mathematica\ binary\ }]} {emit {Mathematica binary file}
+if {[S 88 x {}]} {emit {from %s}}
+}
+if {[S 0 == {MMAPBF\000\001\000\000\000\203\000\001\000}]} {emit {Mathematica PBF \(fonts I think\)}}
+if {[S 4 == {\ A~}]} {emit {MAthematica .ml file}}
+if {[S 0 == (***********************]} {emit {Mathematica 3.0 notebook}}
+if {[S 0 == (*]} {emit {Mathematica, or Pascal, Modula-2 or 3 code text}}
+if {[S 0 == MATLAB]} {emit {Matlab v5 mat-file}
+switch -- [Nv Y 126] 18765 {emit {\(big endian\)}
+if {[N S 124 x {}]} {emit {version 0x%04x}}
+} 19785 {emit {\(little endian\)}
+if {[N s 124 x {}]} {emit {version 0x%04x}}
+}
+}
+if {[S 0 == {\0m\3}]} {emit {mcrypt 2.5 encrypted data,}
+if {[Sx 2 4 x {}]} {emit {algorithm: %s,}
+if {[Nx 3 s [R 1] > 0x0]} {emit {keysize: %d bytes,}
+if {[S [R 0] x {}]} {emit {mode: %s,}}
+}
+}
+}
+if {[S 0 == {\0m\2}]} {emit {mcrypt 2.2 encrypted data,}
+switch -- [Nv c 3] 0 {emit {algorithm: blowfish-448,}} 1 {emit {algorithm: DES,}} 2 {emit {algorithm: 3DES,}} 3 {emit {algorithm: 3-WAY,}} 4 {emit {algorithm: GOST,}} 6 {emit {algorithm: SAFER-SK64,}} 7 {emit {algorithm: SAFER-SK128,}} 8 {emit {algorithm: CAST-128,}} 9 {emit {algorithm: xTEA,}} 10 {emit {algorithm: TWOFISH-128,}} 11 {emit {algorithm: RC2,}} 12 {emit {algorithm: TWOFISH-192,}} 13 {emit {algorithm: TWOFISH-256,}} 14 {emit {algorithm: blowfish-128,}} 15 {emit {algorithm: blowfish-192,}} 16 {emit {algorithm: blowfish-256,}} 100 {emit {algorithm: RC6,}} 101 {emit {algorithm: IDEA,}}
+switch -- [Nv c 4] 0 {emit {mode: CBC,}} 1 {emit {mode: ECB,}} 2 {emit {mode: CFB,}} 3 {emit {mode: OFB,}} 4 {emit {mode: nOFB,}}
+switch -- [Nv c 5] 0 {emit {keymode: 8bit}} 1 {emit {keymode: 4bit}} 2 {emit {keymode: SHA-1 hash}} 3 {emit {keymode: MD5 hash}}
+}
+if {[S 0 == {Content-Type:\ }]} {if {[S 14 x {}]} {emit %s}
+}
+if {[S 0 == Content-Type:]} {if {[S 13 x {}]} {emit %s}
+}
+if {[S 0 == kbd!map]} {emit {kbd map file}
+if {[N c 8 > 0x0]} {emit {Ver %d:}}
+if {[N Y 10 > 0x0]} {emit {with %d table\(s\)}}
+}
+if {[S 0 == {\x43\x72\x73\x68\x44\x75\x6d\x70}]} {emit {IRIX vmcore dump of}
+if {[S 36 x {}]} {emit '%s'}
+}
+if {[S 0 == SGIAUDIT]} {emit {SGI Audit file}
+if {[N c 8 x {}]} {emit {- version %d}}
+if {[N c 9 x {}]} {emit .%ld}
+}
+if {[S 0 == WNGZWZSC]} {emit {Wingz compiled script}}
+if {[S 0 == WNGZWZSS]} {emit {Wingz spreadsheet}}
+if {[S 0 == WNGZWZHP]} {emit {Wingz help file}}
+if {[S 0 == {\\#Inventor}]} {emit {V IRIS Inventor 1.0 file}}
+if {[S 0 == {\\#Inventor}]} {emit {V2 Open Inventor 2.0 file}}
+if {[S 0 == {glfHeadMagic();}]} {emit GLF_TEXT}
+if {[S 0 == glsBeginGLS(]} {emit GLS_TEXT}
+if {[S 0 == %%!!]} {emit {X-Post-It-Note text}}
+if {[S 0 == BEGIN:VCALENDAR]} {emit {vCalendar calendar file}}
+if {[S 0 == {\311\304}]} {emit {ID tags data}
+if {[N Y 2 > 0x0]} {emit {version %d}}
+}
+if {[S 0 == {\001\001\001\001}]} {emit {MMDF mailbox}}
+if {[S 4 == Research,]} {emit Digifax-G3-File
+switch -- [Nv c 29] 1 {emit {, fine resolution}} 0 {emit {, normal resolution}}
+}
+if {[S 0 == RMD1]} {emit {raw modem data}
+if {[S 4 x {}]} {emit {\(%s /}}
+if {[N Y 20 > 0x0]} {emit {compression type 0x%04x\)}}
+}
+if {[S 0 == {PVF1\n}]} {emit {portable voice format}
+if {[S 5 x {}]} {emit {\(binary %s\)}}
+}
+if {[S 0 == {PVF2\n}]} {emit {portable voice format}
+if {[S 5 x {}]} {emit {\(ascii %s\)}}
+}
+if {[S 0 == S0]} {emit {Motorola S-Record; binary data in text format}}
+switch -- [Nv I 0 &0xFFFFFFF0] 1612316672 {emit {Atari ST M68K contiguous executable}
+if {[N I 2 x {}]} {emit {\(txt=%ld,}}
+if {[N I 6 x {}]} {emit dat=%ld,}
+if {[N I 10 x {}]} {emit bss=%ld,}
+if {[N I 14 x {}]} {emit {sym=%ld\)}}
+} 1612382208 {emit {Atari ST M68K non-contig executable}
+if {[N I 2 x {}]} {emit {\(txt=%ld,}}
+if {[N I 6 x {}]} {emit dat=%ld,}
+if {[N I 10 x {}]} {emit bss=%ld,}
+if {[N I 14 x {}]} {emit {sym=%ld\)}}
+}
+if {[S 0 == {@echo\ off} c]} {emit {MS-DOS batch file text}}
+if {[S 128 == {PE\0\0}]} {emit {MS Windows PE}
+if {[N s 150 > 0x0 &0x0100]} {emit 32-bit}
+switch -- [Nv s 132] 0 {emit {unknown processor}} 332 {emit {Intel 80386}} 358 {emit {MIPS R4000}} 388 {emit Alpha} 616 {emit {Motorola 68000}} 496 {emit PowerPC} 656 {emit PA-RISC}
+if {[N s 148 > 0x1b]} {switch -- [Nv s 220] 0 {emit {unknown subsystem}} 1 {emit native} 2 {emit GUI} 3 {emit console} 7 {emit POSIX}
+}
+if {[N s 150 == 0x0 &0x2000]} {emit executable
+if {[N s 150 > 0x0 &0x0001]} {emit {not relocatable}}
+if {[N s 150 > 0x0 &0x1000]} {emit {system file}}
+}
+if {[N s 150 > 0x0 &0x2000]} {emit DLL
+if {[N s 150 > 0x0 &0x0001]} {emit {not relocatable}}
+if {[N s 150 > 0x0 &0x1000]} {emit {system file}}
+}
+}
+if {[S 0 == MZ]} {emit {MS-DOS executable \(EXE\)}
+if {[S 24 == @]} {emit {\b, OS/2 or MS Windows}
+if {[S 231 == {LH/2\ Self-Extract}]} {emit {\b, %s}}
+if {[S 233 == PKSFX2]} {emit {\b, %s}}
+if {[S 122 == {Windows\ self-extracting\ ZIP}]} {emit {\b, %s}}
+}
+if {[S 28 == {RJSX\xff\xff}]} {emit {\b, ARJ SFX}}
+if {[S 28 == {diet\xf9\x9c}]} {emit {\b, diet compressed}}
+if {[S 28 == LZ09]} {emit {\b, LZEXE v0.90 compressed}}
+if {[S 28 == LZ91]} {emit {\b, LZEXE v0.91 compressed}}
+if {[S 30 == {Copyright\ 1989-1990\ PKWARE\ Inc.}]} {emit {\b, PKSFX}}
+if {[S 30 == {PKLITE\ Copr.}]} {emit {\b, %.6s compressed}}
+if {[S 36 == {LHa's\ SFX}]} {emit {\b, %.15s}}
+if {[S 36 == {LHA's\ SFX}]} {emit {\b, %.15s}}
+if {[S 1638 == -lh5-]} {emit {\b, LHa SFX archive v2.13S}}
+if {[S 7195 == Rar!]} {emit {\b, RAR self-extracting archive}}
+if {[S 11696 == {PK\003\004}]} {emit {\b, PKZIP SFX archive v1.1}}
+if {[S 13297 == {PK\003\004}]} {emit {\b, PKZIP SFX archive v1.93a}}
+if {[S 15588 == {PK\003\004}]} {emit {\b, PKZIP2 SFX archive v1.09}}
+if {[S 15770 == {PK\003\004}]} {emit {\b, PKZIP SFX archive v2.04g}}
+if {[S 28374 == {PK\003\004}]} {emit {\b, PKZIP2 SFX archive v1.02}}
+if {[S 25115 == {PK\003\004}]} {emit {\b, Info-ZIP SFX archive v5.12}}
+if {[S 26331 == {PK\003\004}]} {emit {\b, Info-ZIP SFX archive v5.12 w/decryption}}
+if {[S 47031 == {PK\003\004}]} {emit {\b, Info-ZIP SFX archive v5.12}}
+if {[S 49845 == {PK\003\004}]} {emit {\b, Info-ZIP SFX archive v5.12 w/decryption}}
+if {[S 69120 == {PK\003\004}]} {emit {\b, Info-ZIP NT SFX archive v5.12 w/decryption}}
+if {[S 49801 == {\x79\xff\x80\xff\x76\xff}]} {emit {\b, CODEC archive v3.21}
+if {[N s 49824 == 0x1]} {emit {\b, 1 file}}
+if {[N s 49824 > 0x1]} {emit {\b, %u files}}
+}
+}
+if {[S 0 == LZ]} {emit {MS-DOS executable \(built-in\)}}
+if {[S 0 == regf]} {emit {Windows NT registry file}}
+if {[S 0 == CREG]} {emit {Windows 95 registry file}}
+if {[S 0 == {\320\317\021\340\241\261\032\341AAFB\015\000OM\006\016\053\064\001\001\001\377}]} {emit {AAF legacy file using MS Structured Storage}
+switch -- [Nv c 30] 9 {emit {\(512B sectors\)}} 12 {emit {\(4kB sectors\)}}
+}
+if {[S 0 == {\320\317\021\340\241\261\032\341\001\002\001\015\000\002\000\000\006\016\053\064\003\002\001\001}]} {emit {AAF file using MS Structured Storage}
+switch -- [Nv c 30] 9 {emit {\(512B sectors\)}} 12 {emit {\(4kB sectors\)}}
+}
+if {[S 2080 == {Microsoft\ Word\ 6.0\ Document}]} {emit %s}
+if {[S 2080 == {Documento\ Microsoft\ Word\ 6}]} {emit {Spanish Microsoft Word 6 document data}}
+if {[S 2112 == MSWordDoc]} {emit {Microsoft Word document data}}
+if {[S 0 == PO^Q`]} {emit {Microsoft Word 6.0 Document}}
+if {[S 0 == {\376\067\0\043}]} {emit {Microsoft Office Document}}
+if {[S 0 == {\320\317\021\340\241\261\032\341}]} {emit {Microsoft Office Document}}
+if {[S 0 == {\333\245-\0\0\0}]} {emit {Microsoft Office Document}}
+if {[S 2080 == {Microsoft\ Excel\ 5.0\ Worksheet}]} {emit %s}
+if {[S 2080 == {Foglio\ di\ lavoro\ Microsoft\ Exce}]} {emit %s}
+if {[S 2114 == Biff5]} {emit {Microsoft Excel 5.0 Worksheet}}
+if {[S 2121 == Biff5]} {emit {Microsoft Excel 5.0 Worksheet}}
+if {[S 0 == {\x09\x04\x06\x00\x00\x00\x10\x00}]} {emit {Microsoft Excel Worksheet}}
+if {[S 0 == {?_\3\0}]} {emit {MS Windows Help Data}}
+if {[S 0 == {\161\250\000\000\001\002}]} {emit {DeIsL1.isu whatever that is}}
+if {[S 0 == {Nullsoft\ AVS\ Preset\ }]} {emit {Winamp plug in}}
+if {[S 0 == {HyperTerminal\ }]} {emit hyperterm
+if {[S 15 == {1.0\ --\ HyperTerminal\ data\ file}]} {emit {MS-windows Hyperterminal}}
+}
+if {[S 0 == {\327\315\306\232\000\000\000\000\000\000}]} {emit {ms-windows metafont .wmf}}
+if {[S 0 == {\003\001\001\004\070\001\000\000}]} {emit {tz3 ms-works file}}
+if {[S 0 == {\003\002\001\004\070\001\000\000}]} {emit {tz3 ms-works file}}
+if {[S 0 == {\003\003\001\004\070\001\000\000}]} {emit {tz3 ms-works file}}
+if {[S 0 == {\211\000\077\003\005\000\063\237\127\065\027\266\151\064\005\045\101\233\021\002}]} {emit {PGP sig}}
+if {[S 0 == {\211\000\077\003\005\000\063\237\127\066\027\266\151\064\005\045\101\233\021\002}]} {emit {PGP sig}}
+if {[S 0 == {\211\000\077\003\005\000\063\237\127\067\027\266\151\064\005\045\101\233\021\002}]} {emit {PGP sig}}
+if {[S 0 == {\211\000\077\003\005\000\063\237\127\070\027\266\151\064\005\045\101\233\021\002}]} {emit {PGP sig}}
+if {[S 0 == {\211\000\077\003\005\000\063\237\127\071\027\266\151\064\005\045\101\233\021\002}]} {emit {PGP sig}}
+if {[S 0 == {\211\000\225\003\005\000\062\122\207\304\100\345\042}]} {emit {PGP sig}}
+if {[S 0 == {MDIF\032\000\010\000\000\000\372\046\100\175\001\000\001\036\001\000}]} {emit {Ms-windows special zipped file}}
+if {[S 0 == {\164\146\115\122\012\000\000\000\001\000\000\000}]} {emit {ms-windows help cache}}
+if {[S 0 == {\120\115\103\103}]} {emit {Ms-windows 3.1 group files}}
+if {[S 0 == {\114\000\000\000\001\024\002\000\000\000\000\000\300\000\000\000\000\000\000\106}]} {emit {ms-Windows shortcut}}
+if {[S 0 == {\102\101\050\000\000\000\056\000\000\000\000\000\000\000}]} {emit {Icon for ms-windows}}
+if {[S 0 == {\000\000\001\000}]} {emit {ms-windows icon resource}
+if {[N c 4 == 0x1]} {emit {- 1 icon}}
+if {[N c 4 > 0x1]} {emit {- %d icons}
+if {[N c 6 > 0x0]} {emit {\b, %dx}
+if {[N c 7 > 0x0]} {emit {\b%d}}
+}
+if {[N c 8 == 0x0]} {emit {\b, 256-colors}}
+if {[N c 8 > 0x0]} {emit {\b, %d-colors}}
+}
+}
+if {[S 0 == {PK\010\010BGI}]} {emit {Borland font}
+if {[S 4 x {}]} {emit %s}
+}
+if {[S 0 == {pk\010\010BGI}]} {emit {Borland device}
+if {[S 4 x {}]} {emit %s}
+}
+if {[S 9 == {\000\000\000\030\001\000\000\000}]} {emit {ms-windows recycled bin info}}
+if {[S 9 == GERBILDOC]} {emit {First Choice document}}
+if {[S 9 == GERBILDB]} {emit {First Choice database}}
+if {[S 9 == GERBILCLIP]} {emit {First Choice database}}
+if {[S 0 == GERBIL]} {emit {First Choice device file}}
+if {[S 9 == RABBITGRAPH]} {emit {RabbitGraph file}}
+if {[S 0 == DCU1]} {emit {Borland Delphi .DCU file}}
+if {[S 0 == !<spell>]} {emit {MKS Spell hash list \(old format\)}}
+if {[S 0 == !<spell2>]} {emit {MKS Spell hash list}}
+if {[S 0 == PMCC]} {emit {Windows 3.x .GRP file}}
+if {[S 1 == RDC-meg]} {emit MegaDots
+if {[N c 8 > 0x2f]} {emit {version %c}}
+if {[N c 9 > 0x2f]} {emit {\b.%c file}}
+}
+if {[S 0 == {ITSF\003\000\000\000\x60\000\000\000\001\000\000\000}]} {emit {MS Windows HtmlHelp Data}}
+if {[S 2 == GFA-BASIC3]} {emit {GFA-BASIC 3 data}}
+if {[S 512 == go32stub]} {emit {DOS-executable compiled w/DJGPP}
+if {[S 524 > 0]} {emit {\(stub v%.4s\)}
+if {[Sx 3 2226 == djp]} {emit {[compressed w/%s}
+if {[S [R 1] x {}]} {emit %.4s\]}
+}
+if {[Sx 3 2221 == UPX]} {emit {[compressed w/%s}
+if {[S [R 1] x {}]} {emit %.4s\]}
+}
+if {[S 28 == pmodedj]} {emit {stubbed with %s}}
+}
+}
+if {[S 0 == {MSCF\0\0\0\0}]} {emit {Microsoft Cabinet file}
+if {[N i 8 x {}]} {emit {\b, %u bytes}}
+if {[N s 28 == 0x1]} {emit {\b, 1 file}}
+if {[N s 28 > 0x1]} {emit {\b, %u files}}
+}
+if {[S 0 == ISc(]} {emit {InstallShield Cabinet file}
+if {[N c 5 == 0x60 &0xf0]} {emit {version 6,}}
+if {[N c 5 != 0x60 &0xf0]} {emit {version 4/5,}}
+if {[N i [I 12 i 40] x {}]} {emit {%u files}}
+}
+if {[S 0 == {MSCE\0\0\0\0}]} {emit {Microsoft WinCE install header}
+switch -- [Nv i 20] 0 {emit {\b, architecture-independent}} 103 {emit {\b, Hitachi SH3}} 104 {emit {\b, Hitachi SH4}} 2577 {emit {\b, StrongARM}} 4000 {emit {\b, MIPS R4000}} 10003 {emit {\b, Hitachi SH3}} 10004 {emit {\b, Hitachi SH3E}} 10005 {emit {\b, Hitachi SH4}} 70001 {emit {\b, ARM 7TDMI}}
+if {[N s 52 == 0x1]} {emit {\b, 1 file}}
+if {[N s 52 > 0x1]} {emit {\b, %u files}}
+if {[N s 56 == 0x1]} {emit {\b, 1 registry entry}}
+if {[N s 56 > 0x1]} {emit {\b, %u registry entries}}
+}
+if {[S 0 == {Client\ UrlCache\ MMF}]} {emit {Microsoft Internet Explorer Cache File}
+if {[S 20 x {}]} {emit {Version %s}}
+}
+if {[S 0 == {\xCF\xAD\x12\xFE}]} {emit {Microsoft Outlook Express DBX File}
+switch -- [Nv c 4] -59 {emit {Message database}} -58 {emit {Folder database}} -57 {emit {Accounts informations}} 48 {emit {Offline database}}
+}
+if {[N i 40 == 0x464d4520]} {emit {Windows Enhanced Metafile \(EMF\) image data}
+if {[N i 44 x {}]} {emit {version 0x%x.}}
+if {[N i 64 > 0x0]} {emit {Description available at offset 0x%x}
+if {[N i 60 > 0x0]} {emit {\(length 0x%x\)}}
+}
+}
+if {[S 0 == {HWB\000\377\001\000\000\000}]} {emit {Microsoft Visual C .APS file}}
+if {[S 0 == {\102\157\162\154\141\156\144\040\103\053\053\040\120\162\157}]} {emit {MSVC .ide}}
+if {[S 0 == {\000\000\000\000\040\000\000\000\377}]} {emit {MSVC .res}}
+if {[S 0 == {\377\003\000\377\001\000\020\020\350}]} {emit {MSVC .res}}
+if {[S 0 == {\377\003\000\377\001\000\060\020\350}]} {emit {MSVC .res}}
+if {[S 0 == {\360\015\000\000}]} {emit {Microsoft Visual C library}}
+if {[S 0 == {\360\075\000\000}]} {emit {Microsoft Visual C library}}
+if {[S 0 == {\360\175\000\000}]} {emit {Microsoft Visual C library}}
+if {[S 0 == {DTJPCH0\000\022\103\006\200}]} {emit {Microsoft Visual C .pch}}
+if {[S 0 == {Microsoft\ C/C++\ }]} {emit {MSVC program database}
+if {[S 18 == {program\ database\ }]} {emit 810 0}
+if {[S 33 x {}]} {emit {ver %s}}
+}
+if {[S 0 == {\000\002\000\007\000}]} {emit {MSVC .sbr}
+if {[S 5 x {}]} {emit %s}
+}
+if {[S 0 == {\002\000\002\001}]} {emit {MSVC .bsc}}
+if {[S 0 == {1.00\ .0000.0000\000\003}]} {emit {MSVC .wsp version 1.0000.0000}}
+if {[S 0 == RSRC]} {emit {National Instruments,}
+if {[S 8 == LV]} {emit {LabVIEW File,}
+if {[S 10 == SB]} {emit {Code Resource File, data}}
+if {[S 10 == IN]} {emit {Virtual Instrument Program, data}}
+if {[S 10 == AR]} {emit {VI Library, data}}
+}
+if {[S 8 == LMNULBVW]} {emit {Portable File Names, data}}
+if {[S 8 == rsc]} {emit {Resources File, data}}
+}
+if {[S 0 == VMAP]} {emit {National Instruments, VXI File, data}}
+switch -- [Nv I 0 &0377777777] 8782091 {emit {a.out NetBSD/i386 demand paged}
+if {[N c 0 & 0x80]} {if {[N i 20 < 0x1000]} {emit {shared library}}
+if {[N i 20 == 0x1000]} {emit {dynamically linked executable}}
+if {[N i 20 > 0x1000]} {emit {dynamically linked executable}}
+}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 8782088 {emit {a.out NetBSD/i386 pure}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 8782087 {emit {a.out NetBSD/i386}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}}
+if {[N i 20 != 0x0]} {emit executable}
+if {[N i 20 == 0x0]} {emit {object file}}
+}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 8782151 {emit {a.out NetBSD/i386 core}
+if {[S 12 x {}]} {emit {from '%s'}}
+if {[N i 32 != 0x0]} {emit {\(signal %d\)}}
+} 8847627 {emit {a.out NetBSD/m68k demand paged}
+if {[N c 0 & 0x80]} {if {[N I 20 < 0x2000]} {emit {shared library}}
+if {[N I 20 == 0x2000]} {emit {dynamically linked executable}}
+if {[N I 20 > 0x2000]} {emit {dynamically linked executable}}
+}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 8847624 {emit {a.out NetBSD/m68k pure}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 8847623 {emit {a.out NetBSD/m68k}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}}
+if {[N I 20 != 0x0]} {emit executable}
+if {[N I 20 == 0x0]} {emit {object file}}
+}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 8847687 {emit {a.out NetBSD/m68k core}
+if {[S 12 x {}]} {emit {from '%s'}}
+if {[N I 32 != 0x0]} {emit {\(signal %d\)}}
+} 8913163 {emit {a.out NetBSD/m68k4k demand paged}
+if {[N c 0 & 0x80]} {if {[N I 20 < 0x1000]} {emit {shared library}}
+if {[N I 20 == 0x1000]} {emit {dynamically linked executable}}
+if {[N I 20 > 0x1000]} {emit {dynamically linked executable}}
+}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 8913160 {emit {a.out NetBSD/m68k4k pure}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 8913159 {emit {a.out NetBSD/m68k4k}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}}
+if {[N I 20 != 0x0]} {emit executable}
+if {[N I 20 == 0x0]} {emit {object file}}
+}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 8913223 {emit {a.out NetBSD/m68k4k core}
+if {[S 12 x {}]} {emit {from '%s'}}
+if {[N I 32 != 0x0]} {emit {\(signal %d\)}}
+} 8978699 {emit {a.out NetBSD/ns32532 demand paged}
+if {[N c 0 & 0x80]} {if {[N i 20 < 0x1000]} {emit {shared library}}
+if {[N i 20 == 0x1000]} {emit {dynamically linked executable}}
+if {[N i 20 > 0x1000]} {emit {dynamically linked executable}}
+}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 8978696 {emit {a.out NetBSD/ns32532 pure}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 8978695 {emit {a.out NetBSD/ns32532}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}}
+if {[N i 20 != 0x0]} {emit executable}
+if {[N i 20 == 0x0]} {emit {object file}}
+}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 8978759 {emit {a.out NetBSD/ns32532 core}
+if {[S 12 x {}]} {emit {from '%s'}}
+if {[N i 32 != 0x0]} {emit {\(signal %d\)}}
+} 9765191 {emit {a.out NetBSD/powerpc core}
+if {[S 12 x {}]} {emit {from '%s'}}
+} 9044235 {emit {a.out NetBSD/sparc demand paged}
+if {[N c 0 & 0x80]} {if {[N I 20 < 0x2000]} {emit {shared library}}
+if {[N I 20 == 0x2000]} {emit {dynamically linked executable}}
+if {[N I 20 > 0x2000]} {emit {dynamically linked executable}}
+}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 9044232 {emit {a.out NetBSD/sparc pure}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 9044231 {emit {a.out NetBSD/sparc}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}}
+if {[N I 20 != 0x0]} {emit executable}
+if {[N I 20 == 0x0]} {emit {object file}}
+}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 9044295 {emit {a.out NetBSD/sparc core}
+if {[S 12 x {}]} {emit {from '%s'}}
+if {[N I 32 != 0x0]} {emit {\(signal %d\)}}
+} 9109771 {emit {a.out NetBSD/pmax demand paged}
+if {[N c 0 & 0x80]} {if {[N i 20 < 0x1000]} {emit {shared library}}
+if {[N i 20 == 0x1000]} {emit {dynamically linked executable}}
+if {[N i 20 > 0x1000]} {emit {dynamically linked executable}}
+}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 9109768 {emit {a.out NetBSD/pmax pure}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 9109767 {emit {a.out NetBSD/pmax}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}}
+if {[N i 20 != 0x0]} {emit executable}
+if {[N i 20 == 0x0]} {emit {object file}}
+}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 9109831 {emit {a.out NetBSD/pmax core}
+if {[S 12 x {}]} {emit {from '%s'}}
+if {[N i 32 != 0x0]} {emit {\(signal %d\)}}
+} 9175307 {emit {a.out NetBSD/vax 1k demand paged}
+if {[N c 0 & 0x80]} {if {[N i 20 < 0x1000]} {emit {shared library}}
+if {[N i 20 == 0x1000]} {emit {dynamically linked executable}}
+if {[N i 20 > 0x1000]} {emit {dynamically linked executable}}
+}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 9175304 {emit {a.out NetBSD/vax 1k pure}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 9175303 {emit {a.out NetBSD/vax 1k}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}}
+if {[N i 20 != 0x0]} {emit executable}
+if {[N i 20 == 0x0]} {emit {object file}}
+}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 9175367 {emit {a.out NetBSD/vax 1k core}
+if {[S 12 x {}]} {emit {from '%s'}}
+if {[N i 32 != 0x0]} {emit {\(signal %d\)}}
+} 9830667 {emit {a.out NetBSD/vax 4k demand paged}
+if {[N c 0 & 0x80]} {if {[N i 20 < 0x1000]} {emit {shared library}}
+if {[N i 20 == 0x1000]} {emit {dynamically linked executable}}
+if {[N i 20 > 0x1000]} {emit {dynamically linked executable}}
+}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 9830664 {emit {a.out NetBSD/vax 4k pure}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 9830663 {emit {a.out NetBSD/vax 4k}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}}
+if {[N i 20 != 0x0]} {emit executable}
+if {[N i 20 == 0x0]} {emit {object file}}
+}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 9830727 {emit {a.out NetBSD/vax 4k core}
+if {[S 12 x {}]} {emit {from '%s'}}
+if {[N i 32 != 0x0]} {emit {\(signal %d\)}}
+} 9240903 {emit {a.out NetBSD/alpha core}
+if {[S 12 x {}]} {emit {from '%s'}}
+if {[N i 32 != 0x0]} {emit {\(signal %d\)}}
+} 9306379 {emit {a.out NetBSD/mips demand paged}
+if {[N c 0 & 0x80]} {if {[N I 20 < 0x2000]} {emit {shared library}}
+if {[N I 20 == 0x2000]} {emit {dynamically linked executable}}
+if {[N I 20 > 0x2000]} {emit {dynamically linked executable}}
+}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 9306376 {emit {a.out NetBSD/mips pure}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 9306375 {emit {a.out NetBSD/mips}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}}
+if {[N I 20 != 0x0]} {emit executable}
+if {[N I 20 == 0x0]} {emit {object file}}
+}
+if {[N I 16 > 0x0]} {emit {not stripped}}
+} 9306439 {emit {a.out NetBSD/mips core}
+if {[S 12 x {}]} {emit {from '%s'}}
+if {[N I 32 != 0x0]} {emit {\(signal %d\)}}
+} 9371915 {emit {a.out NetBSD/arm32 demand paged}
+if {[N c 0 & 0x80]} {if {[N i 20 < 0x1000]} {emit {shared library}}
+if {[N i 20 == 0x1000]} {emit {dynamically linked executable}}
+if {[N i 20 > 0x1000]} {emit {dynamically linked executable}}
+}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 9371912 {emit {a.out NetBSD/arm32 pure}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {emit executable}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 9371911 {emit {a.out NetBSD/arm32}
+if {[N c 0 & 0x80]} {emit {dynamically linked executable}}
+if {[N c 0 ^ 0x80]} {if {[N c 0 & 0x40]} {emit {position independent}}
+if {[N i 20 != 0x0]} {emit executable}
+if {[N i 20 == 0x0]} {emit {object file}}
+}
+if {[N i 16 > 0x0]} {emit {not stripped}}
+} 9371975 {emit {a.out NetBSD/arm core}
+if {[S 12 x {}]} {emit {from '%s'}}
+if {[N i 32 != 0x0]} {emit {\(signal %d\)}}
+}
+if {[S 0 == {\000\017\102\104\000\000\000\000\000\000\001\000\000\000\000\002\000\000\000\002\000\000\004\000}]} {emit {Netscape Address book}}
+if {[S 0 == {\000\017\102\111}]} {emit {Netscape Communicator address book}}
+if {[S 0 == {\#\ Netscape\ folder\ cache}]} {emit {Netscape folder cache}}
+if {[S 0 == {\000\036\204\220\000}]} {emit {Netscape folder cache}}
+if {[S 0 == SX961999]} {emit Net2phone}
+if {[S 0 == {JG\004\016\0\0\0\0}]} {emit ART}
+if {[S 0 == StartFontMetrics]} {emit {ASCII font metrics}}
+if {[S 0 == StartFont]} {emit {ASCII font bits}}
+switch -- [Nv I 8] 326773573 {emit {X11/NeWS bitmap font}} 326773576 {emit {X11/NeWS font family}}
+if {[S 0 == NPFF]} {emit {NItpicker Flow File}
+if {[N c 4 x {}]} {emit V%d.}
+if {[N c 5 x {}]} {emit %d}
+if {[N S 6 x {}]} {emit {started: %s}}
+if {[N S 10 x {}]} {emit {stopped: %s}}
+if {[N I 14 x {}]} {emit {Bytes: %u}}
+if {[N I 18 x {}]} {emit {Bytes1: %u}}
+if {[N I 22 x {}]} {emit {Flows: %u}}
+if {[N I 26 x {}]} {emit {Pkts: %u}}
+}
+if {[S 0 == Caml1999]} {emit {Objective caml}
+if {[S 8 == X]} {emit {exec file}}
+if {[S 8 == I]} {emit {interface file \(.cmi\)}}
+if {[S 8 == O]} {emit {object file \(.cmo\)}}
+if {[S 8 == A]} {emit {library file \(.cma\)}}
+if {[S 8 == Y]} {emit {native object file \(.cmx\)}}
+if {[S 8 == Z]} {emit {native library file \(.cmxa\)}}
+if {[S 8 == M]} {emit {abstract syntax tree implementation file}}
+if {[S 8 == N]} {emit {abstract syntax tree interface file}}
+if {[S 9 x {}]} {emit {\(Version %3.3s\).}}
+}
+if {[S 0 == Octave-1-L]} {emit {Octave binary data \(little endian\)}}
+if {[S 0 == Octave-1-B]} {emit {Octave binary data \(big endian\)}}
+if {[S 0 == {\177OLF}]} {emit OLF
+switch -- [Nv c 4] 0 {emit {invalid class}} 1 {emit 32-bit} 2 {emit 64-bit}
+switch -- [Nv c 7] 0 {emit {invalid os}} 1 {emit OpenBSD} 2 {emit NetBSD} 3 {emit FreeBSD} 4 {emit 4.4BSD} 5 {emit Linux} 6 {emit SVR4} 7 {emit esix} 8 {emit Solaris} 9 {emit Irix} 10 {emit SCO} 11 {emit Dell} 12 {emit NCR}
+switch -- [Nv c 5] 0 {emit {invalid byte order}} 1 {emit LSB
+switch -- [Nv s 16] 0 {emit {no file type,}} 1 {emit relocatable,} 2 {emit executable,} 3 {emit {shared object,}} 4 {emit {core file}
+if {[S [I 56 Q 204] x {}]} {emit {of '%s'}}
+if {[N i [I 56 Q 16] > 0x0]} {emit {\(signal %d\),}}
+}
+if {[N s 16 & 0xff00]} {emit processor-specific,}
+switch -- [Nv s 18] 0 {emit {no machine,}} 1 {emit {AT&T WE32100 - invalid byte order,}} 2 {emit {SPARC - invalid byte order,}} 3 {emit {Intel 80386,}} 4 {emit {Motorola 68000 - invalid byte order,}} 5 {emit {Motorola 88000 - invalid byte order,}} 6 {emit {Intel 80486,}} 7 {emit {Intel 80860,}} 8 {emit {MIPS R3000_BE - invalid byte order,}} 9 {emit {Amdahl - invalid byte order,}} 10 {emit {MIPS R3000_LE,}} 11 {emit {RS6000 - invalid byte order,}} 15 {emit {PA-RISC - invalid byte order,}} 16 {emit nCUBE,} 17 {emit VPP500,} 18 {emit SPARC32PLUS,} 20 {emit PowerPC,} -28634 {emit Alpha,}
+switch -- [Nv i 20] 0 {emit {invalid version}} 1 {emit {version 1}}
+if {[N i 36 == 0x1]} {emit {MathCoPro/FPU/MAU Required}}
+} 2 {emit MSB
+switch -- [Nv S 16] 0 {emit {no file type,}} 1 {emit relocatable,} 2 {emit executable,} 3 {emit {shared object,}} 4 {emit {core file,}
+if {[S [I 56 Q 204] x {}]} {emit {of '%s'}}
+if {[N I [I 56 Q 16] > 0x0]} {emit {\(signal %d\),}}
+}
+if {[N S 16 & 0xff00]} {emit processor-specific,}
+switch -- [Nv S 18] 0 {emit {no machine,}} 1 {emit {AT&T WE32100,}} 2 {emit SPARC,} 3 {emit {Intel 80386 - invalid byte order,}} 4 {emit {Motorola 68000,}} 5 {emit {Motorola 88000,}} 6 {emit {Intel 80486 - invalid byte order,}} 7 {emit {Intel 80860,}} 8 {emit {MIPS R3000_BE,}} 9 {emit Amdahl,} 10 {emit {MIPS R3000_LE - invalid byte order,}} 11 {emit RS6000,} 15 {emit PA-RISC,} 16 {emit nCUBE,} 17 {emit VPP500,} 18 {emit SPARC32PLUS,} 20 {emit {PowerPC or cisco 4500,}} 21 {emit {cisco 7500,}} 24 {emit {cisco SVIP,}} 25 {emit {cisco 7200,}} 36 {emit {cisco 12000,}} -28634 {emit Alpha,}
+switch -- [Nv I 20] 0 {emit {invalid version}} 1 {emit {version 1}}
+if {[N I 36 == 0x1]} {emit {MathCoPro/FPU/MAU Required}}
+}
+if {[S 8 x {}]} {emit {\(%s\)}}
+}
+if {[S 1 == InternetShortcut]} {emit {MS Windows 95 Internet shortcut text}
+if {[S 24 > {\ }]} {emit {\(URL=<%s>\)}}
+}
+if {[S 0 == {HSP\x01\x9b\x00}]} {emit {OS/2 INF}
+if {[S 107 > 0]} {emit {\(%s\)}}
+}
+if {[S 0 == {HSP\x10\x9b\x00}]} {emit {OS/2 HLP}
+if {[S 107 > 0]} {emit {\(%s\)}}
+}
+if {[S 0 == {\xff\xff\xff\xff\x14\0\0\0}]} {emit {OS/2 INI}}
+switch -- [Nv I 60] 1634758764 {emit {PalmOS application}
+if {[S 0 x {}]} {emit {\"%s\"}}
+} 1413830772 {emit {AportisDoc file}
+if {[S 0 x {}]} {emit {\"%s\"}}
+} 1212236619 {emit {HackMaster hack}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == BVokBDIC]} {emit {BDicty PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == DB99DBOS]} {emit {DB PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == vIMGView]} {emit {FireViewer/ImageViewer PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == PmDBPmDB]} {emit {HanDBase PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == InfoINDB]} {emit {InfoView PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == ToGoToGo]} {emit {iSilo PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == JfDbJBas]} {emit {JFile PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == JfDbJFil]} {emit {JFile Pro PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == DATALSdb]} {emit {List PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == Mdb1Mdb1]} {emit {MobileDB PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == PNRdPPrs]} {emit {PeanutPress PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == DataPlkr]} {emit {Plucker PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == DataSprd]} {emit {QuickSheet PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == SM01SMem]} {emit {SuperMemo PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == DataTlPt]} {emit {TealDoc PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == InfoTlIf]} {emit {TealInfo PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == DataTlMl]} {emit {TealMeal PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == DataTlPt]} {emit {TealPaint PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == dataTDBP]} {emit {ThinkDB PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == TdatTide]} {emit {Tides PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == ToRaTRPW]} {emit {TomeRaider PalmOS document}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == zTXT]} {emit {A GutenPalm zTXT e-book}
+if {[S 0 x {}]} {emit {\"%s\"}}
+switch -- [Nv c [I 78 I 0]] 0 {emit {}
+if {[N c [I 78 I 1] x {}]} {emit {\(v0.%02d\)}}
+} 1 {emit {}
+if {[N c [I 78 I 1] x {}]} {emit {\(v1.%02d\)}
+if {[N S [I 78 I 10] > 0x0]} {if {[N S [I 78 I 10] < 0x2]} {emit {- 1 bookmark}}
+if {[N S [I 78 I 10] > 0x1]} {emit {- %d bookmarks}}
+}
+if {[N S [I 78 I 14] > 0x0]} {if {[N S [I 78 I 14] < 0x2]} {emit {- 1 annotation}}
+if {[N S [I 78 I 14] > 0x1]} {emit {- %d annotations}}
+}
+}
+}
+if {[N c [I 78 I 0] > 0x1]} {emit {\(v%d.}
+if {[N c [I 78 I 1] x {}]} {emit {%02d\)}}
+}
+}
+if {[S 60 == libr]} {emit {Palm OS dynamic library data}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == ptch]} {emit {Palm OS operating system patch data}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[S 60 == BOOKMOBI]} {emit {Mobipocket E-book}
+if {[S 0 x {}]} {emit {\"%s\"}}
+}
+if {[N S 0 == 0xace &0xfff]} {emit PARIX
+switch -- [Nv c 0 &0xf0] -128 {emit T800} -112 {emit T9000}
+switch -- [Nv c 19 &0x02] 2 {emit executable} 0 {emit object}
+if {[N c 19 == 0x0 &0x0c]} {emit {not stripped}}
+}
+if {[S 0 == %PDF-]} {emit {PDF document}
+if {[N c 5 x {}]} {emit {\b, version %c}}
+if {[N c 7 x {}]} {emit {\b.%c}}
+}
+if {[S 0 == {\#!\ /bin/perl} b]} {emit {perl script text executable}}
+if {[S 0 == {eval\ \"exec\ /bin/perl}]} {emit {perl script text}}
+if {[S 0 == {\#!\ /usr/bin/perl} b]} {emit {perl script text executable}}
+if {[S 0 == {eval\ \"exec\ /usr/bin/perl}]} {emit {perl script text}}
+if {[S 0 == {\#!\ /usr/local/bin/perl} b]} {emit {perl script text}}
+if {[S 0 == {eval\ \"exec\ /usr/local/bin/perl}]} {emit {perl script text executable}}
+if {[S 0 == {eval\ '(exit\ $?0)'\ &&\ eval\ 'exec}]} {emit {perl script text}}
+if {[S 0 == package]} {emit {Perl5 module source text}}
+if {[S 0 == perl-store]} {emit {perl Storable\(v0.6\) data}
+if {[N c 4 > 0x0]} {emit {\(net-order %d\)}
+if {[N c 4 & 0x1]} {emit {\(network-ordered\)}}
+switch -- [Nv c 4] 3 {emit {\(major 1\)}} 2 {emit {\(major 1\)}}
+}
+}
+if {[S 0 == pst0]} {emit {perl Storable\(v0.7\) data}
+if {[N c 4 > 0x0]} {if {[N c 4 & 0x1]} {emit {\(network-ordered\)}}
+switch -- [Nv c 4] 5 {emit {\(major 2\)}} 4 {emit {\(major 2\)}}
+if {[N c 5 > 0x0]} {emit {\(minor %d\)}}
+}
+}
+if {[S 0 == {-----BEGIN\040PGP}]} {emit {PGP armored data}
+if {[S 15 == {PUBLIC\040KEY\040BLOCK-}]} {emit {public key block}}
+if {[S 15 == MESSAGE-]} {emit message}
+if {[S 15 == {SIGNED\040MESSAGE-}]} {emit {signed message}}
+if {[S 15 == {PGP\040SIGNATURE-}]} {emit signature}
+}
+if {[S 0 == {\#\ PaCkAgE\ DaTaStReAm}]} {emit {pkg Datastream \(SVR4\)}}
+if {[S 0 == %!]} {emit {PostScript document text}
+if {[S 2 == PS-Adobe-]} {emit conforming
+if {[S 11 x {}]} {emit {at level %.3s}
+if {[S 15 == EPS]} {emit {- type %s}}
+if {[S 15 == Query]} {emit {- type %s}}
+if {[S 15 == ExitServer]} {emit {- type %s}}
+}
+}
+}
+if {[S 0 == {\004%!}]} {emit {PostScript document text}
+if {[S 3 == PS-Adobe-]} {emit conforming
+if {[S 12 x {}]} {emit {at level %.3s}
+if {[S 16 == EPS]} {emit {- type %s}}
+if {[S 16 == Query]} {emit {- type %s}}
+if {[S 16 == ExitServer]} {emit {- type %s}}
+}
+}
+}
+if {[S 0 == {\033%-12345X%!PS}]} {emit {PostScript document}}
+if {[S 0 == *PPD-Adobe:]} {emit {PPD file}
+if {[S 13 x {}]} {emit {\b, ve}}
+}
+if {[S 0 == {\033%-12345X@PJL}]} {emit {HP Printer Job Language data}}
+if {[Sx 1 0 == {\033%-12345X@PJL}]} {emit {HP Printer Job Language data}
+if {[Sx 2 [R 0] x {}]} {emit {%s }
+if {[Sx 3 [R 0] x {}]} {emit {%s }
+if {[Sx 4 [R 0] x {}]} {emit {%s }
+if {[S [R 0] x {}]} {emit {%s }}
+}
+}
+}
+}
+if {[S 0 == {\033E\033}]} {emit {HP PCL printer data}
+if {[S 3 == {\&l0A}]} {emit {- default page size}}
+if {[S 3 == {\&l1A}]} {emit {- US executive page size}}
+if {[S 3 == {\&l2A}]} {emit {- US letter page size}}
+if {[S 3 == {\&l3A}]} {emit {- US legal page size}}
+if {[S 3 == {\&l26A}]} {emit {- A4 page size}}
+if {[S 3 == {\&l80A}]} {emit {- Monarch envelope size}}
+if {[S 3 == {\&l81A}]} {emit {- No. 10 envelope size}}
+if {[S 3 == {\&l90A}]} {emit {- Intl. DL envelope size}}
+if {[S 3 == {\&l91A}]} {emit {- Intl. C5 envelope size}}
+if {[S 3 == {\&l100A}]} {emit {- Intl. B5 envelope size}}
+if {[S 3 == {\&l-81A}]} {emit {- No. 10 envelope size \(landscape\)}}
+if {[S 3 == {\&l-90A}]} {emit {- Intl. DL envelope size \(landscape\)}}
+}
+if {[S 0 == @document(]} {emit {Imagen printer}
+if {[S 10 == {language\ impress}]} {emit {\(imPRESS data\)}}
+if {[S 10 == {language\ daisy}]} {emit {\(daisywheel text\)}}
+if {[S 10 == {language\ diablo}]} {emit {\(daisywheel text\)}}
+if {[S 10 == {language\ printer}]} {emit {\(line printer emulation\)}}
+if {[S 10 == {language\ tektronix}]} {emit {\(Tektronix 4014 emulation\)}}
+}
+if {[S 0 == Rast]} {emit {RST-format raster font data}
+if {[S 45 > 0]} {emit {face %s}}
+}
+if {[S 0 == {\033[K\002\0\0\017\033(a\001\0\001\033(g}]} {emit {Canon Bubble Jet BJC formatted data}}
+if {[S 0 == {\x1B\x40\x1B\x28\x52\x08\x00\x00REMOTE1P}]} {emit {Epson Stylus Color 460 data}}
+if {[S 0 == JZJZ]} {if {[S 18 == ZZ]} {emit {Zenographics ZjStream printer data \(big-endian\)}}
+}
+if {[S 0 == ZJZJ]} {if {[S 18 == ZZ]} {emit {Zenographics ZjStream printer data \(little-endian\)}}
+}
+if {[S 0 == OAK]} {if {[N c 7 == 0x0]} {emit 888 0}
+if {[N c 11 == 0x0]} {emit {Oak Technologies printer stream}}
+}
+if {[S 0 == %!VMF]} {emit {SunClock's Vector Map Format data}}
+if {[S 0 == {\xbe\xefABCDEFGH}]} {emit {HP LaserJet 1000 series downloadable firmware}}
+if {[S 0 == {\x1b\x01@EJL}]} {emit {Epson ESC/Page language printer data}}
+if {[S 0 == {FTNCHEK_\ P}]} {emit {project file for ftnchek}
+if {[S 10 == 1]} {emit {version 2.7}}
+if {[S 10 == 2]} {emit {version 2.8 to 2.10}}
+if {[S 10 == 3]} {emit {version 2.11 or later}}
+}
+if {[N I 0 == 0x56000000 &0xff00ffff]} {emit {ps database}
+if {[S 1 x {}]} {emit {version %s}}
+if {[S 4 x {}]} {emit {from kernel %s}}
+}
+if {[S 0 == {\"\"\"}]} {emit {a python script text executable}}
+if {[S 0 == {/1\ :pserver:}]} {emit {cvs password text file}}
+if {[S 0 == RIFF]} {emit {RIFF \(little-endian\) data}
+if {[S 8 == PAL]} {emit {\b, palette}
+if {[N s 16 x {}]} {emit {\b, version %d}}
+if {[N s 18 x {}]} {emit {\b, %d entries}}
+}
+if {[S 8 == RDIB]} {emit {\b, device-independent bitmap}
+if {[S 16 == BM]} {switch -- [Nv s 30] 12 {emit {\b, OS/2 1.x format}
+if {[N s 34 x {}]} {emit {\b, %d x}}
+if {[N s 36 x {}]} {emit %d}
+} 64 {emit {\b, OS/2 2.x format}
+if {[N s 34 x {}]} {emit {\b, %d x}}
+if {[N s 36 x {}]} {emit %d}
+} 40 {emit {\b, Windows 3.x format}
+if {[N i 34 x {}]} {emit {\b, %d x}}
+if {[N i 38 x {}]} {emit {%d x}}
+if {[N s 44 x {}]} {emit %d}
+}
+}
+}
+if {[S 8 == RMID]} {emit {\b, MIDI}}
+if {[S 8 == RMMP]} {emit {\b, multimedia movie}}
+if {[S 8 == WAVE]} {emit {\b, WAVE audio}
+switch -- [Nv s 20] 1 {emit {\b, Microsoft PCM}
+if {[N s 34 > 0x0]} {emit {\b, %d bit}}
+} 2 {emit {\b, Microsoft ADPCM}} 6 {emit {\b, ITU G.711 A-law}} 7 {emit {\b, ITU G.711 mu-law}} 17 {emit {\b, IMA ADPCM}} 20 {emit {\b, ITU G.723 ADPCM \(Yamaha\)}} 49 {emit {\b, GSM 6.10}} 64 {emit {\b, ITU G.721 ADPCM}} 80 {emit {\b, MPEG}} 85 {emit {\b, MPEG Layer 3}}
+switch -- [Nv s 22] 1 {emit {\b, mono}} 2 {emit {\b, stereo}}
+if {[N s 22 > 0x2]} {emit {\b, %d channels}}
+if {[N i 24 > 0x0]} {emit {%d Hz}}
+}
+if {[S 8 == CDRA]} {emit {\b, Corel Draw Picture}}
+if {[S 8 == {AVI\040}]} {emit {\b, AVI}
+if {[S 12 == LIST]} {if {[Sx 4 20 == hdrlavih]} {if {[N i [R 36] x {}]} {emit {\b, %lu x}}
+if {[N i [R 40] x {}]} {emit %lu,}
+if {[N i [R 4] > 0xf4240]} {emit {<1 fps,}}
+switch -- [Nvx 5 i [R 4]] 1000000 {emit {1.00 fps,}} 500000 {emit {2.00 fps,}} 333333 {emit {3.00 fps,}} 250000 {emit {4.00 fps,}} 200000 {emit {5.00 fps,}} 166667 {emit {6.00 fps,}} 142857 {emit {7.00 fps,}} 125000 {emit {8.00 fps,}} 111111 {emit {9.00 fps,}} 100000 {emit {10.00 fps,}} 83333 {emit {12.00 fps,}} 66667 {emit {15.00 fps,}} 50000 {emit {20.00 fps,}} 41708 {emit {23.98 fps,}} 41667 {emit {24.00 fps,}} 40000 {emit {25.00 fps,}} 33367 {emit {29.97 fps,}} 33333 {emit {30.00 fps,}}
+L 4;if {[Nx 5 i [R 4] < 0x18a92]} {if {[Nx 6 i [R -4] > 0x182c2]} {if {[N i [R -4] != 0x186a0]} {emit {~10 fps,}}
+}
+}
+L 4;if {[Nx 5 i [R 4] < 0x14842]} {if {[Nx 6 i [R -4] > 0x142d5]} {if {[N i [R -4] != 0x14585]} {emit {~12 fps,}}
+}
+}
+L 4;if {[Nx 5 i [R 4] < 0x1062a]} {if {[Nx 6 i [R -4] > 0x102b1]} {if {[N i [R -4] != 0x1046b]} {emit {~15 fps,}}
+}
+}
+L 4;if {[Nx 5 i [R 4] < 0xa371]} {if {[Nx 6 i [R -4] > 0xa216]} {if {[Nx 7 i [R -4] != 0xa2ec]} {if {[N i [R -4] != 0xa2c3]} {emit {~24 fps,}}
+}
+}
+}
+L 4;if {[Nx 5 i [R 4] < 0x9ce1]} {if {[Nx 6 i [R -4] > 0x9ba1]} {if {[N i [R -4] != 0x9c40]} {emit {~25 fps,}}
+}
+}
+L 4;if {[Nx 5 i [R 4] < 0x82a5]} {if {[Nx 6 i [R -4] > 0x81c7]} {if {[Nx 7 i [R -4] != 0x8257]} {if {[N i [R -4] != 0x8235]} {emit {~30 fps,}}
+}
+}
+}
+L 4;if {[N i [R 4] < 0x7de0]} {emit {>30 fps,}}
+}
+if {[S 88 == LIST]} {if {[S 96 == strlstrh]} {if {[Sx 6 108 == vids]} {emit video:
+if {[N i [R 0] == 0x0]} {emit uncompressed}
+if {[S [I 104 i 108] == strf]} {switch -- [Nv i [I 104 i 132]] 1 {emit {RLE 8bpp}} 0 {emit {}}
+if {[S [I 104 i 132] == cvid c]} {emit Cinepak}
+if {[S [I 104 i 132] == i263 c]} {emit {Intel I.263}}
+if {[S [I 104 i 132] == iv32 c]} {emit {Indeo 3.2}}
+if {[S [I 104 i 132] == iv41 c]} {emit {Indeo 4.1}}
+if {[S [I 104 i 132] == iv50 c]} {emit {Indeo 5.0}}
+if {[S [I 104 i 132] == mp42 c]} {emit {Microsoft MPEG-4 v2}}
+if {[S [I 104 i 132] == mp43 c]} {emit {Microsoft MPEG-4 v3}}
+if {[S [I 104 i 132] == mjpg c]} {emit {Motion JPEG}}
+if {[S [I 104 i 132] == div3 c]} {emit {DivX 3}
+if {[S 112 == div3 c]} {emit Low-Motion}
+if {[S 112 == div4 c]} {emit Fast-Motion}
+}
+if {[S [I 104 i 132] == divx c]} {emit {DivX 4}}
+if {[S [I 104 i 132] == dx50 c]} {emit {DivX 5}}
+if {[S [I 104 i 132] == xvid c]} {emit XviD}
+}
+}
+}
+if {[S [I 92 i 96] == LIST]} {if {[S [I 92 i 104] == strlstrh]} {if {[S [I 92 i 116] == auds]} {emit {\b, audio:}
+if {[S [I 92 i 172] == strf]} {switch -- [Nv s [I 92 i 180]] 1 {emit {uncompressed PCM}} 2 {emit ADPCM} 85 {emit {MPEG-1 Layer 3}} 8192 {emit {Dolby AC3}} 353 {emit DivX}
+switch -- [Nv s [I 92 i 182]] 1 {emit {\(mono,}} 2 {emit {\(stereo,}}
+if {[N s [I 92 i 182] > 0x2]} {emit {\(%d channels,}}
+if {[N i [I 92 i 184] x {}]} {emit {%d Hz\)}}
+}
+if {[S [I 92 i 180] == strf]} {switch -- [Nv s [I 92 i 188]] 1 {emit {uncompressed PCM}} 2 {emit ADPCM} 85 {emit {MPEG-1 Layer 3}} 8192 {emit {Dolby AC3}} 353 {emit DivX}
+switch -- [Nv s [I 92 i 190]] 1 {emit {\(mono,}} 2 {emit {\(stereo,}}
+if {[N s [I 92 i 190] > 0x2]} {emit {\(%d channels,}}
+if {[N i [I 92 i 192] x {}]} {emit {%d Hz\)}}
+}
+}
+}
+}
+}
+}
+}
+if {[S 8 == ACON]} {emit {\b, animated cursor}}
+if {[S 8 == sfbk]} {emit SoundFont/Bank}
+if {[S 8 == CDXA]} {emit {\b, wrapped MPEG-1 \(CDXA\)}}
+if {[S 8 == 4XMV]} {emit {\b, 4X Movie file}}
+}
+if {[S 0 == RIFX]} {emit {RIFF \(big-endian\) data}
+if {[S 8 == PAL]} {emit {\b, palette}
+if {[N S 16 x {}]} {emit {\b, version %d}}
+if {[N S 18 x {}]} {emit {\b, %d entries}}
+}
+if {[S 8 == RDIB]} {emit {\b, device-independent bitmap}
+if {[S 16 == BM]} {switch -- [Nv S 30] 12 {emit {\b, OS/2 1.x format}
+if {[N S 34 x {}]} {emit {\b, %d x}}
+if {[N S 36 x {}]} {emit %d}
+} 64 {emit {\b, OS/2 2.x format}
+if {[N S 34 x {}]} {emit {\b, %d x}}
+if {[N S 36 x {}]} {emit %d}
+} 40 {emit {\b, Windows 3.x format}
+if {[N I 34 x {}]} {emit {\b, %d x}}
+if {[N I 38 x {}]} {emit {%d x}}
+if {[N S 44 x {}]} {emit %d}
+}
+}
+}
+if {[S 8 == RMID]} {emit {\b, MIDI}}
+if {[S 8 == RMMP]} {emit {\b, multimedia movie}}
+if {[S 8 == WAVE]} {emit {\b, WAVE audio}
+if {[N s 20 == 0x1]} {emit {\b, Microsoft PCM}
+if {[N s 34 > 0x0]} {emit {\b, %d bit}}
+}
+switch -- [Nv S 22] 1 {emit {\b, mono}} 2 {emit {\b, stereo}}
+if {[N S 22 > 0x2]} {emit {\b, %d channels}}
+if {[N I 24 > 0x0]} {emit {%d Hz}}
+}
+if {[S 8 == CDRA]} {emit {\b, Corel Draw Picture}}
+if {[S 8 == {AVI\040}]} {emit {\b, AVI}}
+if {[S 8 == ACON]} {emit {\b, animated cursor}}
+if {[S 8 == NIFF]} {emit {\b, Notation Interchange File Format}}
+if {[S 8 == sfbk]} {emit SoundFont/Bank}
+}
+if {[S 0 == {\{\\rtf}]} {emit {Rich Text Format data,}
+if {[N c 5 x {}]} {emit {version %c,}}
+if {[S 6 == {\\ansi}]} {emit ANSI}
+if {[S 6 == {\\mac}]} {emit {Apple Macintosh}}
+if {[S 6 == {\\pc}]} {emit {IBM PC, code page 437}}
+if {[S 6 == {\\pca}]} {emit {IBM PS/2, code page 850}}
+}
+if {[S 38 == Spreadsheet]} {emit {sc spreadsheet file}}
+if {[S 8 == {\001s\ }]} {emit {SCCS archive data}}
+if {[S 0 == {divert(-1)\n}]} {emit {sendmail m4 text file}}
+if {[S 0 == PmNs]} {emit {PCP compiled namespace \(V.0\)}}
+if {[S 0 == PmN]} {emit {PCP compiled namespace}
+if {[S 3 x {}]} {emit {\(V.%1.1s\)}}
+}
+if {[N i 3 == 0x84500526]} {emit {PCP archive}
+if {[N c 7 x {}]} {emit {\(V.%d\)}}
+switch -- [Nv i 20] -2 {emit {temporal index}} -1 {emit metadata} 0 {emit {log volume \#0}}
+if {[N i 20 > 0x0]} {emit {log volume \#%ld}}
+if {[S 24 x {}]} {emit {host: %s}}
+}
+if {[S 0 == PCPFolio]} {emit PCP
+if {[S 9 == Version:]} {emit {Archive Folio}}
+if {[S 18 x {}]} {emit {\(V.%s\)}}
+}
+if {[S 0 == {\#pmchart}]} {emit {PCP pmchart view}
+if {[S 9 == Version]} {emit 906 0}
+if {[S 17 x {}]} {emit {\(V%-3.3s\)}}
+}
+if {[S 0 == pmview]} {emit {PCP pmview config}
+if {[S 7 == Version]} {emit 907 0}
+if {[S 15 x {}]} {emit {\(V%-3.3s\)}}
+}
+if {[S 0 == {\#pmlogger}]} {emit {PCP pmlogger config}
+if {[S 10 == Version]} {emit 908 0}
+if {[S 18 x {}]} {emit {\(V%1.1s\)}}
+}
+if {[S 0 == PcPh]} {emit {PCP Help}
+if {[S 4 == 1]} {emit Index}
+if {[S 4 == 2]} {emit Text}
+if {[S 5 x {}]} {emit {\(V.%1.1s\)}}
+}
+if {[S 0 == {\#pmieconf-rules}]} {emit {PCP pmieconf rules}
+if {[S 16 x {}]} {emit {\(V.%1.1s\)}}
+}
+if {[S 3 == pmieconf-pmie]} {emit {PCP pmie config}
+if {[S 17 x {}]} {emit {\(V.%1.1s\)}}
+}
+if {[S 0 == mdbm]} {emit {mdbm file,}
+if {[N c 5 x {}]} {emit {version %d,}}
+if {[N c 6 x {}]} {emit {2^%d pages,}}
+if {[N c 7 x {}]} {emit {pagesize 2^%d,}}
+if {[N c 17 x {}]} {emit {hash %d,}}
+if {[N c 11 x {}]} {emit {dataformat %d}}
+}
+if {[S 0 == //Maya]} {emit {ASCII Alias|Wavefront Maya Ascii File,}
+if {[S 13 x {}]} {emit {version %s}}
+}
+if {[S 8 == MAYAFOR4]} {emit {Alias|Wavefront Maya Binary File,}
+if {[S 32 x {}]} {emit {version %s scene}}
+}
+if {[S 8 == MayaFOR4]} {emit {Alias|Wavefront Maya Binary File,}
+if {[S 32 x {}]} {emit {version %s scene}}
+}
+if {[S 8 == CIMG]} {emit {Alias|Wavefront Maya Image File}}
+if {[S 8 == DEEP]} {emit {Alias|Wavefront Maya Image File}}
+if {[S 0 == {<!DOCTYPE\ html} cB]} {emit {HTML document text}}
+if {[S 0 == <head cb]} {emit {HTML document text}}
+if {[S 0 == <title cb]} {emit {HTML document text}}
+if {[S 0 == <html cb]} {emit {HTML document text}}
+if {[S 0 == <?xml cb]} {emit {XML document text}}
+if {[S 0 == {<?xml\ version}]} {emit {\" XML}}
+if {[S 0 == {<?xml\ version=\"}]} {emit XML
+if {[S 15 x {}]} {emit {%.3s document text}
+if {[S 23 == <xsl:stylesheet]} {emit {\(XSL stylesheet\)}}
+if {[S 24 == <xsl:stylesheet]} {emit {\(XSL stylesheet\)}}
+}
+}
+if {[S 0 == <?xml b]} {emit {XML document text}}
+if {[S 0 == <?xml cb]} {emit {broken XML document text}}
+if {[S 0 == <!doctype cb]} {emit {exported SGML document text}}
+if {[S 0 == <!subdoc cb]} {emit {exported SGML subdocument text}}
+if {[S 0 == <!-- cb]} {emit {exported SGML document text}}
+if {[S 0 == {\#\ HTTP\ Cookie\ File}]} {emit {Web browser cookie text}}
+if {[S 0 == {\#\ Netscape\ HTTP\ Cookie\ File}]} {emit {Netscape cookie text}}
+if {[S 0 == {\#\ KDE\ Cookie\ File}]} {emit {Konqueror cookie text}}
+if {[S 0 == Draw]} {emit {RiscOS Drawfile}}
+if {[S 0 == PACK]} {emit {RiscOS PackdDir archive}}
+if {[S 0 == !]} {emit {Assembler source}}
+if {[S 0 == Analog]} {emit {ADi asm listing file}}
+if {[S 0 == .SYSTEM]} {emit {SHARC architecture file}}
+if {[S 0 == .system]} {emit {SHARC architecture file}}
+if {[S 0 == QL5]} {emit {QL disk dump data,}
+if {[S 3 == A]} {emit {720 KB,}}
+if {[S 3 == B]} {emit {1.44 MB,}}
+if {[S 3 == C]} {emit {3.2 MB,}}
+if {[S 4 x {}]} {emit label:%.10s}
+}
+if {[S 0 == {NqNqNq`\004}]} {emit {QL firmware executable \(BCPL\)}}
+if {[S 0 == {\#\#Sketch}]} {emit {Sketch document text}}
+if {[S 0 == {GSTIm\0\0}]} {emit {GNU SmallTalk}
+switch -- [Nv c 7 &1] 0 {emit {LE image version}
+if {[N c 10 x {}]} {emit %d.}
+if {[N c 9 x {}]} {emit {\b%d.}}
+if {[N c 8 x {}]} {emit {\b%d}}
+} 1 {emit {BE image version}
+if {[N c 8 x {}]} {emit %d.}
+if {[N c 9 x {}]} {emit {\b%d.}}
+if {[N c 10 x {}]} {emit {\b%d}}
+}
+}
+if {[S 0 == RTSS]} {emit {NetMon capture file}
+if {[N c 5 x {}]} {emit {- version %d}}
+if {[N c 4 x {}]} {emit {\b.%d}}
+switch -- [Nv s 6] 0 {emit {\(Unknown\)}} 1 {emit {\(Ethernet\)}} 2 {emit {\(Token Ring\)}} 3 {emit {\(FDDI\)}} 4 {emit {\(ATM\)}}
+}
+if {[S 0 == GMBU]} {emit {NetMon capture file}
+if {[N c 5 x {}]} {emit {- version %d}}
+if {[N c 4 x {}]} {emit {\b.%d}}
+switch -- [Nv s 6] 0 {emit {\(Unknown\)}} 1 {emit {\(Ethernet\)}} 2 {emit {\(Token Ring\)}} 3 {emit {\(FDDI\)}} 4 {emit {\(ATM\)}}
+}
+if {[S 0 == {TRSNIFF\ data\ \ \ \ \032}]} {emit {Sniffer capture file}
+if {[N c 33 == 0x2]} {emit {\(compressed\)}}
+if {[N s 23 x {}]} {emit {- version %d}}
+if {[N s 25 x {}]} {emit {\b.%d}}
+switch -- [Nv c 32] 0 {emit {\(Token Ring\)}} 1 {emit {\(Ethernet\)}} 2 {emit {\(ARCNET\)}} 3 {emit {\(StarLAN\)}} 4 {emit {\(PC Network broadband\)}} 5 {emit {\(LocalTalk\)}} 6 {emit {\(Znet\)}} 7 {emit {\(Internetwork Analyzer\)}} 9 {emit {\(FDDI\)}} 10 {emit {\(ATM\)}}
+}
+if {[S 0 == {XCP\0}]} {emit {NetXRay capture file}
+if {[S 4 x {}]} {emit {- version %s}}
+switch -- [Nv s 44] 0 {emit {\(Ethernet\)}} 1 {emit {\(Token Ring\)}} 2 {emit {\(FDDI\)}} 3 {emit {\(WAN\)}} 8 {emit {\(ATM\)}} 9 {emit {\(802.11\)}}
+}
+if {[S 0 == {iptrace\ 1.0}]} {emit {\"iptrace\" capture file}}
+if {[S 0 == {iptrace\ 2.0}]} {emit {\"iptrace\" capture file}}
+if {[S 0 == {\x54\x52\x00\x64\x00}]} {emit {\"nettl\" capture file}}
+if {[S 0 == {\x42\xd2\x00\x34\x12\x66\x22\x88}]} {emit {RADCOM WAN/LAN Analyzer capture file}}
+if {[S 0 == NetS]} {emit {NetStumbler log file}
+if {[N i 8 x {}]} {emit {\b, %d stations found}}
+}
+if {[S 0 == {\177ver}]} {emit {EtherPeek/AiroPeek capture file}}
+if {[S 0 == {\x05VNF}]} {emit {Visual Networks traffic capture file}}
+if {[S 0 == ObserverPktBuffe]} {emit {Network Instruments Observer capture file}}
+if {[S 0 == {\xaa\xaa\xaa\xaa}]} {emit {5View capture file}}
+if {[S 0 == {<!SQ\ DTD>}]} {emit {Compiled SGML rules file}
+if {[S 9 x {}]} {emit {Type %s}}
+}
+if {[S 0 == {<!SQ\ A/E>}]} {emit {A/E SGML Document binary}
+if {[S 9 x {}]} {emit {Type %s}}
+}
+if {[S 0 == {<!SQ\ STS>}]} {emit {A/E SGML binary styles file}
+if {[S 9 x {}]} {emit {Type %s}}
+}
+if {[S 0 == {SQ\ BITMAP1}]} {emit {SoftQuad Raster Format text}}
+if {[S 0 == {X\ }]} {emit {SoftQuad troff Context intermediate}
+if {[S 2 == 495]} {emit {for AT&T 495 laser printer}}
+if {[S 2 == hp]} {emit {for Hewlett-Packard LaserJet}}
+if {[S 2 == impr]} {emit {for IMAGEN imPRESS}}
+if {[S 2 == ps]} {emit {for PostScript}}
+}
+if {[S 0 == spec]} {emit SPEC
+if {[S 4 == .cpu]} {emit CPU
+if {[S 8 < :]} {emit {\b%.4s}}
+if {[S 12 == .]} {emit {raw result text}}
+}
+}
+if {[S 17 == version=SPECjbb]} {emit SPECjbb
+if {[S 32 < :]} {emit {\b%.4s}
+if {[S 37 < :]} {emit {v%.4s raw result text}}
+}
+}
+if {[S 0 == {BEGIN\040SPECWEB}]} {emit SPECweb
+if {[S 13 < :]} {emit {\b%.2s}
+if {[S 15 == _SSL]} {emit {\b_SSL}
+if {[S 20 < :]} {emit {v%.4s raw result text}}
+}
+if {[S 16 < :]} {emit {v%.4s raw result text}}
+}
+}
+if {[S 0 == {PLUS3DOS\032}]} {emit {Spectrum +3 data}
+switch -- [Nv c 15] 0 {emit {- BASIC program}} 1 {emit {- number array}} 2 {emit {- character array}} 3 {emit {- memory block}
+if {[N I 16 == 0x1b0040]} {emit {\(screen\)}}
+} 4 {emit {- Tasword document}}
+if {[S 15 == TAPEFILE]} {emit {- ZXT tapefile}}
+}
+if {[S 0 == {\023\000\000}]} {emit {Spectrum .TAP data}
+if {[S 4 x {}]} {emit {\"%-10.10s\"}}
+switch -- [Nv c 3] 0 {emit {- BASIC program}} 1 {emit {- number array}} 2 {emit {- character array}} 3 {emit {- memory block}
+if {[N I 14 == 0x1b0040]} {emit {\(screen\)}}
+}
+}
+if {[S 0 == {ZXTape!\x1a}]} {emit {Spectrum .TZX data}
+if {[N c 8 x {}]} {emit {version %d}}
+if {[N c 9 x {}]} {emit .%d}
+}
+if {[S 0 == RZX!]} {emit {Spectrum .RZX data}
+if {[N c 4 x {}]} {emit {version %d}}
+if {[N c 5 x {}]} {emit .%d}
+}
+if {[S 0 == {MV\ -\ CPCEMU\ Disk-Fil}]} {emit {Amstrad/Spectrum .DSK data}}
+if {[S 0 == {MV\ -\ CPC\ format\ Dis}]} {emit {Amstrad/Spectrum DU54 .DSK data}}
+if {[S 0 == {EXTENDED\ CPC\ DSK\ Fil}]} {emit {Amstrad/Spectrum Extended .DSK data}}
+if {[S 0 == {\376bin}]} {emit {MySQL replication log}}
+if {[S 0 == {\#SUNPC_CONFIG}]} {emit {SunPC 4.0 Properties Values}}
+if {[S 0 == snoop]} {emit {Snoop capture file}
+if {[N I 8 > 0x0]} {emit {- version %ld}}
+switch -- [Nv I 12] 0 {emit {\(IEEE 802.3\)}} 1 {emit {\(IEEE 802.4\)}} 2 {emit {\(IEEE 802.5\)}} 3 {emit {\(IEEE 802.6\)}} 4 {emit {\(Ethernet\)}} 5 {emit {\(HDLC\)}} 6 {emit {\(Character synchronous\)}} 7 {emit {\(IBM channel-to-channel adapter\)}} 8 {emit {\(FDDI\)}} 9 {emit {\(Unknown\)}}
+}
+if {[S 36 == acspMSFT]} {emit {Microsoft ICM Color Profile}}
+if {[S 36 == acsp]} {emit {Kodak Color Management System, ICC Profile}}
+if {[S 0 == {Cobalt\ Networks\ Inc.\nFirmware\ v}]} {emit {Paged COBALT boot rom}
+if {[S 38 x {}]} {emit V%.4s}
+}
+if {[S 0 == CRfs]} {emit {COBALT boot rom data \(Flat boot rom or file system\)}}
+if {[S 0 == T707]} {emit {Roland TR-707 Data}}
+if {[S 0 == {\#!teapot\012xdr}]} {emit {teapot work sheet \(XDR format\)}}
+if {[S 0 == {\032\001}]} {emit {Compiled terminfo entry}}
+if {[S 0 == {\367\002}]} {emit {TeX DVI file}
+if {[S 16 x {}]} {emit {\(%s\)}}
+}
+if {[S 0 == {\367\203}]} {emit {TeX generic font data}}
+if {[S 0 == {\367\131}]} {emit {TeX packed font data}
+if {[S 3 x {}]} {emit {\(%s\)}}
+}
+if {[S 0 == {\367\312}]} {emit {TeX virtual font data}}
+if {[S 0 == {This\ is\ TeX,}]} {emit {TeX transcript text}}
+if {[S 0 == {This\ is\ METAFONT,}]} {emit {METAFONT transcript text}}
+if {[S 2 == {\000\021}]} {emit {TeX font metric data}
+if {[S 33 x {}]} {emit {\(%s\)}}
+}
+if {[S 2 == {\000\022}]} {emit {TeX font metric data}
+if {[S 33 x {}]} {emit {\(%s\)}}
+}
+if {[S 0 == {\\input\ texinfo}]} {emit {Texinfo source text}}
+if {[S 0 == {This\ is\ Info\ file}]} {emit {GNU Info text}}
+if {[S 0 == {\\input}]} {emit {TeX document text}}
+if {[S 0 == {\\section}]} {emit {LaTeX document text}}
+if {[S 0 == {\\setlength}]} {emit {LaTeX document text}}
+if {[S 0 == {\\documentstyle}]} {emit {LaTeX document text}}
+if {[S 0 == {\\chapter}]} {emit {LaTeX document text}}
+if {[S 0 == {\\documentclass}]} {emit {LaTeX 2e document text}}
+if {[S 0 == {\\relax}]} {emit {LaTeX auxiliary file}}
+if {[S 0 == {\\contentsline}]} {emit {LaTeX table of contents}}
+if {[S 0 == {%\ -*-latex-*-}]} {emit {LaTeX document text}}
+if {[S 0 == {\\ifx}]} {emit {TeX document text}}
+if {[S 0 == {\\indexentry}]} {emit {LaTeX raw index file}}
+if {[S 0 == {\\begin\{theindex\}}]} {emit {LaTeX sorted index}}
+if {[S 0 == {\\glossaryentry}]} {emit {LaTeX raw glossary}}
+if {[S 0 == {\\begin\{theglossary\}}]} {emit {LaTeX sorted glossary}}
+if {[S 0 == {This\ is\ makeindex}]} {emit {Makeindex log file}}
+if {[S 0 == {@article\{} c]} {emit {BibTeX text file}}
+if {[S 0 == {@book\{} c]} {emit {BibTeX text file}}
+if {[S 0 == {@inbook\{} c]} {emit {BibTeX text file}}
+if {[S 0 == {@incollection\{} c]} {emit {BibTeX text file}}
+if {[S 0 == {@inproceedings\{} c]} {emit {BibTeX text file}}
+if {[S 0 == {@manual\{} c]} {emit {BibTeX text file}}
+if {[S 0 == {@misc\{} c]} {emit {BibTeX text file}}
+if {[S 0 == {@preamble\{} c]} {emit {BibTeX text file}}
+if {[S 0 == {@phdthesis\{} c]} {emit {BibTeX text file}}
+if {[S 0 == {@techreport\{} c]} {emit {BibTeX text file}}
+if {[S 0 == {@unpublished\{} c]} {emit {BibTeX text file}}
+if {[S 73 == {%%%\ \ BibTeX-file\{}]} {emit {BibTex text file \(with full header\)}}
+if {[S 73 == {%%%\ \ @BibTeX-style-file\{}]} {emit {BibTeX style text file \(with full header\)}}
+if {[S 0 == {%\ BibTeX\ standard\ bibliography\ }]} {emit {BibTeX standard bibliography style text file}}
+if {[S 0 == {%\ BibTeX\ `}]} {emit {BibTeX custom bibliography style text file}}
+if {[S 0 == {@c\ @mapfile\{}]} {emit {TeX font aliases text file}}
+if {[S 0 == {%TGIF\ 4}]} {emit {tgif version 4 object file}}
+if {[S 0 == **TI80**]} {emit {TI-80 Graphing Calculator File.}}
+if {[S 0 == **TI81**]} {emit {TI-81 Graphing Calculator File.}}
+if {[S 0 == **TI73**]} {emit {TI-73 Graphing Calculator}
+switch -- [Nv c 59] 0 {emit {\(real number\)}} 1 {emit {\(list\)}} 2 {emit {\(matrix\)}} 3 {emit {\(equation\)}} 4 {emit {\(string\)}} 5 {emit {\(program\)}} 6 {emit {\(assembly program\)}} 7 {emit {\(picture\)}} 8 {emit {\(gdb\)}} 12 {emit {\(complex number\)}} 15 {emit {\(window settings\)}} 16 {emit {\(zoom\)}} 17 {emit {\(table setup\)}} 19 {emit {\(backup\)}}
+}
+if {[S 0 == **TI82**]} {emit {TI-82 Graphing Calculator}
+switch -- [Nv c 59] 0 {emit {\(real\)}} 1 {emit {\(list\)}} 2 {emit {\(matrix\)}} 3 {emit {\(Y-variable\)}} 5 {emit {\(program\)}} 6 {emit {\(protected prgm\)}} 7 {emit {\(picture\)}} 8 {emit {\(gdb\)}} 11 {emit {\(window settings\)}} 12 {emit {\(window settings\)}} 13 {emit {\(table setup\)}} 14 {emit {\(screenshot\)}} 15 {emit {\(backup\)}}
+}
+if {[S 0 == **TI83**]} {emit {TI-83 Graphing Calculator}
+switch -- [Nv c 59] 0 {emit {\(real\)}} 1 {emit {\(list\)}} 2 {emit {\(matrix\)}} 3 {emit {\(Y-variable\)}} 4 {emit {\(string\)}} 5 {emit {\(program\)}} 6 {emit {\(protected prgm\)}} 7 {emit {\(picture\)}} 8 {emit {\(gdb\)}} 11 {emit {\(window settings\)}} 12 {emit {\(window settings\)}} 13 {emit {\(table setup\)}} 14 {emit {\(screenshot\)}} 19 {emit {\(backup\)}}
+}
+if {[S 0 == **TI83F*]} {emit {TI-83+ Graphing Calculator}
+switch -- [Nv c 59] 0 {emit {\(real number\)}} 1 {emit {\(list\)}} 2 {emit {\(matrix\)}} 3 {emit {\(equation\)}} 4 {emit {\(string\)}} 5 {emit {\(program\)}} 6 {emit {\(assembly program\)}} 7 {emit {\(picture\)}} 8 {emit {\(gdb\)}} 12 {emit {\(complex number\)}} 15 {emit {\(window settings\)}} 16 {emit {\(zoom\)}} 17 {emit {\(table setup\)}} 19 {emit {\(backup\)}} 21 {emit {\(application variable\)}} 23 {emit {\(group of variable\)}}
+}
+if {[S 0 == **TI85**]} {emit {TI-85 Graphing Calculator}
+switch -- [Nv c 59] 0 {emit {\(real number\)}} 1 {emit {\(complex number\)}} 2 {emit {\(real vector\)}} 3 {emit {\(complex vector\)}} 4 {emit {\(real list\)}} 5 {emit {\(complex list\)}} 6 {emit {\(real matrix\)}} 7 {emit {\(complex matrix\)}} 8 {emit {\(real constant\)}} 9 {emit {\(complex constant\)}} 10 {emit {\(equation\)}} 12 {emit {\(string\)}} 13 {emit {\(function GDB\)}} 14 {emit {\(polar GDB\)}} 15 {emit {\(parametric GDB\)}} 16 {emit {\(diffeq GDB\)}} 17 {emit {\(picture\)}} 18 {emit {\(program\)}} 19 {emit {\(range\)}} 23 {emit {\(window settings\)}} 24 {emit {\(window settings\)}} 25 {emit {\(window settings\)}} 26 {emit {\(window settings\)}} 27 {emit {\(zoom\)}} 29 {emit {\(backup\)}} 30 {emit {\(unknown\)}} 42 {emit {\(equation\)}}
+if {[S 50 == ZS4]} {emit {- ZShell Version 4 File.}}
+if {[S 50 == ZS3]} {emit {- ZShell Version 3 File.}}
+}
+if {[S 0 == **TI86**]} {emit {TI-86 Graphing Calculator}
+switch -- [Nv c 59] 0 {emit {\(real number\)}} 1 {emit {\(complex number\)}} 2 {emit {\(real vector\)}} 3 {emit {\(complex vector\)}} 4 {emit {\(real list\)}} 5 {emit {\(complex list\)}} 6 {emit {\(real matrix\)}} 7 {emit {\(complex matrix\)}} 8 {emit {\(real constant\)}} 9 {emit {\(complex constant\)}} 10 {emit {\(equation\)}} 12 {emit {\(string\)}} 13 {emit {\(function GDB\)}} 14 {emit {\(polar GDB\)}} 15 {emit {\(parametric GDB\)}} 16 {emit {\(diffeq GDB\)}} 17 {emit {\(picture\)}} 18 {emit {\(program\)}} 19 {emit {\(range\)}} 23 {emit {\(window settings\)}} 24 {emit {\(window settings\)}} 25 {emit {\(window settings\)}} 26 {emit {\(window settings\)}} 27 {emit {\(zoom\)}} 29 {emit {\(backup\)}} 30 {emit {\(unknown\)}} 42 {emit {\(equation\)}}
+}
+if {[S 0 == **TI89**]} {emit {TI-89 Graphing Calculator}
+switch -- [Nv c 72] 0 {emit {\(expression\)}} 4 {emit {\(list\)}} 6 {emit {\(matrix\)}} 10 {emit {\(data\)}} 11 {emit {\(text\)}} 12 {emit {\(string\)}} 13 {emit {\(graphic data base\)}} 14 {emit {\(figure\)}} 16 {emit {\(picture\)}} 18 {emit {\(program\)}} 19 {emit {\(function\)}} 20 {emit {\(macro\)}} 28 {emit {\(zipped\)}} 33 {emit {\(assembler\)}}
+}
+if {[S 0 == **TI92**]} {emit {TI-92 Graphing Calculator}
+switch -- [Nv c 72] 0 {emit {\(expression\)}} 4 {emit {\(list\)}} 6 {emit {\(matrix\)}} 10 {emit {\(data\)}} 11 {emit {\(text\)}} 12 {emit {\(string\)}} 13 {emit {\(graphic data base\)}} 14 {emit {\(figure\)}} 16 {emit {\(picture\)}} 18 {emit {\(program\)}} 19 {emit {\(function\)}} 20 {emit {\(macro\)}} 29 {emit {\(backup\)}}
+}
+if {[S 0 == **TI92P*]} {emit {TI-92+/V200 Graphing Calculator}
+switch -- [Nv c 72] 0 {emit {\(expression\)}} 4 {emit {\(list\)}} 6 {emit {\(matrix\)}} 10 {emit {\(data\)}} 11 {emit {\(text\)}} 12 {emit {\(string\)}} 13 {emit {\(graphic data base\)}} 14 {emit {\(figure\)}} 16 {emit {\(picture\)}} 18 {emit {\(program\)}} 19 {emit {\(function\)}} 20 {emit {\(macro\)}} 28 {emit {\(zipped\)}} 33 {emit {\(assembler\)}}
+}
+if {[S 22 == Advanced]} {emit {TI-XX Graphing Calculator \(FLASH\)}}
+if {[S 0 == **TIFL**]} {emit {TI-XX Graphing Calculator \(FLASH\)}
+if {[N c 8 > 0x0]} {emit {- Revision %d}
+if {[N c 9 x {}]} {emit {\b.%d,}}
+}
+if {[N c 12 > 0x0]} {emit {Revision date %02x}
+if {[N c 13 x {}]} {emit {\b/%02x}}
+if {[N S 14 x {}]} {emit {\b/%04x,}}
+}
+if {[S 17 > /0]} {emit {name: '%s',}}
+switch -- [Nv c 48] 116 {emit {device: TI-73,}} 115 {emit {device: TI-83+,}} -104 {emit {device: TI-89,}} -120 {emit {device: TI-92+,}}
+switch -- [Nv c 49] 35 {emit {type: OS upgrade,}} 36 {emit {type: application,}} 37 {emit {type: certificate,}} 62 {emit {type: license,}}
+if {[N i 74 > 0x0]} {emit {size: %ld bytes}}
+}
+if {[S 0 == VTI]} {emit {Virtual TI skin}
+if {[S 3 == v]} {emit {- Version}
+if {[N c 4 > 0x0]} {emit {\b %c}}
+if {[N c 6 x {}]} {emit {\b.%c}}
+}
+}
+if {[S 0 == TiEmu]} {emit {TiEmu skin}
+if {[S 6 == v]} {emit {- Version}
+if {[N c 7 > 0x0]} {emit {\b %c}}
+if {[N c 9 x {}]} {emit {\b.%c}}
+if {[N c 10 x {}]} {emit {\b%c}}
+}
+}
+if {[S 0 == TZif]} {emit {timezone data}}
+if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\1\0}]} {emit {old timezone data}}
+if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\2\0}]} {emit {old timezone data}}
+if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\3\0}]} {emit {old timezone data}}
+if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\4\0}]} {emit {old timezone data}}
+if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\5\0}]} {emit {old timezone data}}
+if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\6\0}]} {emit {old timezone data}}
+if {[S 0 == {.\\\"}]} {emit {troff or preprocessor input text}}
+if {[S 0 == {'\\\"}]} {emit {troff or preprocessor input text}}
+if {[S 0 == {'.\\\"}]} {emit {troff or preprocessor input text}}
+if {[S 0 == {\\\"}]} {emit {troff or preprocessor input text}}
+if {[S 0 == ''']} {emit {troff or preprocessor input text}}
+if {[S 0 == {x\ T}]} {emit {ditroff output text}
+if {[S 4 == cat]} {emit {for the C/A/T phototypesetter}}
+if {[S 4 == ps]} {emit {for PostScript}}
+if {[S 4 == dvi]} {emit {for DVI}}
+if {[S 4 == ascii]} {emit {for ASCII}}
+if {[S 4 == lj4]} {emit {for LaserJet 4}}
+if {[S 4 == latin1]} {emit {for ISO 8859-1 \(Latin 1\)}}
+if {[S 4 == X75]} {emit {for xditview at 75dpi}
+if {[S 7 == -12]} {emit {\(12pt\)}}
+}
+if {[S 4 == X100]} {emit {for xditview at 100dpi}
+if {[S 8 == -12]} {emit {\(12pt\)}}
+}
+}
+if {[S 0 == {\100\357}]} {emit {very old \(C/A/T\) troff output data}}
+if {[S 0 == {\0\0\1\236\0\0\0\0\0\0\0\0\0\0\0\0}]} {emit {BEA TUXEDO DES mask data}}
+if {[S 0 == Interpress/Xerox]} {emit {Xerox InterPress data}
+if {[S 16 == /]} {emit {\(version}
+if {[S 17 x {}]} {emit {%s\)}}
+}
+}
+if {[S 0 == {begin\040}]} {emit {uuencoded or xxencoded text}}
+if {[S 0 == {xbtoa\ Begin}]} {emit {btoa'd text}}
+if {[S 0 == {$\012ship}]} {emit {ship'd binary text}}
+if {[S 0 == {Decode\ the\ following\ with\ bdeco}]} {emit {bencoded News text}}
+if {[S 11 == {must\ be\ converted\ with\ BinHex}]} {emit {BinHex binary text}
+if {[S 41 x {}]} {emit {\b, version %.3s}}
+}
+if {[N S 6 == 0x107]} {emit {unicos \(cray\) executable}}
+if {[S 596 == {\130\337\377\377}]} {emit {Ultrix core file}
+if {[S 600 x {}]} {emit {from '%s'}}
+}
+if {[S 0 == Joy!peffpwpc]} {emit {header for PowerPC PEF executable}}
+if {[S 0 == avaobj]} {emit {AVR assembler object code}
+if {[S 7 x {}]} {emit {version '%s'}}
+}
+if {[S 0 == gmon]} {emit {GNU prof performance data}
+if {[N Q 4 x {}]} {emit {- version %ld}}
+}
+if {[S 0 == {\xc0HRB}]} {emit {Harbour HRB file}
+if {[N Y 4 x {}]} {emit {version %d}}
+}
+if {[S 0 == {\#!\ /}]} {emit a
+if {[S 3 x {}]} {emit {%s script text executable}}
+}
+if {[S 0 == {\#!\ /}]} {emit a
+if {[S 3 x {}]} {emit {%s script text executable}}
+}
+if {[S 0 == {\#!/}]} {emit a
+if {[S 2 x {}]} {emit {%s script text executable}}
+}
+if {[S 0 == {\#!\ }]} {emit {script text executable}
+if {[S 3 x {}]} {emit {for %s}}
+}
+if {[S 0 == LBLSIZE=]} {emit {VICAR image data}
+if {[S 32 == BYTE]} {emit {\b, 8 bits = VAX byte}}
+if {[S 32 == HALF]} {emit {\b, 16 bits = VAX word = Fortran INTEGER*2}}
+if {[S 32 == FULL]} {emit {\b, 32 bits = VAX longword = Fortran INTEGER*4}}
+if {[S 32 == REAL]} {emit {\b, 32 bits = VAX longword = Fortran REAL*4}}
+if {[S 32 == DOUB]} {emit {\b, 64 bits = VAX quadword = Fortran REAL*8}}
+if {[S 32 == COMPLEX]} {emit {\b, 64 bits = VAX quadword = Fortran COMPLEX*8}}
+}
+if {[S 43 == SFDU_LABEL]} {emit {VICAR label file}}
+if {[S 0 == {\211\277\036\203}]} {emit {Virtutech CRAFF}
+if {[N I 4 x {}]} {emit v%d}
+switch -- [Nv I 20] 0 {emit uncompressed} 1 {emit bzipp2ed} 2 {emit gzipped}
+if {[N I 24 == 0x0]} {emit {not clean}}
+}
+if {[S 0 == {\xb0\0\x30\0}]} {emit {VMS VAX executable}
+if {[S 44032 == {PK\003\004}]} {emit {\b, Info-ZIP SFX archive v5.12 w/decryption}}
+}
+if {[S 0 == OggS]} {emit {Ogg data}
+if {[N c 4 != 0x0]} {emit {UNKNOWN REVISION %u}}
+if {[N c 4 == 0x0]} {if {[S 28 == fLaC]} {emit {\b, FLAC audio}}
+if {[S 28 == {\x80theora}]} {emit {\b, Theora video}}
+if {[S 28 == {Speex\ \ \ }]} {emit {\b, Speex audio}}
+if {[S 28 == {\x01video\0\0\0}]} {emit {\b, OGM video}
+if {[S 37 == div3 c]} {emit {\(DivX 3\)}}
+if {[S 37 == divx c]} {emit {\(DivX 4\)}}
+if {[S 37 == dx50 c]} {emit {\(DivX 5\)}}
+if {[S 37 == xvid c]} {emit {\(XviD\)}}
+}
+if {[S 28 == {\x01vorbis}]} {emit {\b, Vorbis audio,}
+if {[N i 35 != 0x0]} {emit {UNKNOWN VERSION %lu,}}
+if {[N i 35 == 0x0]} {switch -- [Nv c 39] 1 {emit mono,} 2 {emit stereo,}
+if {[N c 39 > 0x2]} {emit {%u channels,}}
+if {[N i 40 x {}]} {emit {%lu Hz}}
+if {[S 48 < {\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff}]} {emit {\b,}
+if {[N i 52 != 0xffffffff]} {if {[N i 52 != 0x0]} {if {[N i 52 != 0xfffffc18]} {if {[N i 52 x {}]} {emit <%lu}
+}
+}
+}
+if {[N i 48 != 0xffffffff]} {if {[N i 48 x {}]} {emit ~%lu}
+}
+if {[N i 44 != 0xffffffff]} {if {[N i 44 != 0xfffffc18]} {if {[N i 44 != 0x0]} {if {[N i 44 x {}]} {emit >%lu}
+}
+}
+}
+if {[S 48 < {\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff}]} {emit bps}
+}
+}
+if {[S [I 84 c 85] == {\x03vorbis}]} {if {[S [I 84 c 96] == {Xiphophorus\ libVorbis\ I} c]} {emit {\b, created by: Xiphophorus libVorbis I}
+if {[S [I 84 c 120] > 00000000]} {if {[S [I 84 c 120] < 20000508]} {emit {\(<beta1, prepublic\)}}
+if {[S [I 84 c 120] == 20000508]} {emit {\(1.0 beta 1 or beta 2\)}}
+if {[S [I 84 c 120] > 20000508]} {if {[S [I 84 c 120] < 20001031]} {emit {\(beta2-3\)}}
+}
+if {[S [I 84 c 120] == 20001031]} {emit {\(1.0 beta 3\)}}
+if {[S [I 84 c 120] > 20001031]} {if {[S [I 84 c 120] < 20010225]} {emit {\(beta3-4\)}}
+}
+if {[S [I 84 c 120] == 20010225]} {emit {\(1.0 beta 4\)}}
+if {[S [I 84 c 120] > 20010225]} {if {[S [I 84 c 120] < 20010615]} {emit {\(beta4-RC1\)}}
+}
+if {[S [I 84 c 120] == 20010615]} {emit {\(1.0 RC1\)}}
+if {[S [I 84 c 120] == 20010813]} {emit {\(1.0 RC2\)}}
+if {[S [I 84 c 120] == 20010816]} {emit {\(RC2 - Garf tuned v1\)}}
+if {[S [I 84 c 120] == 20011014]} {emit {\(RC2 - Garf tuned v2\)}}
+if {[S [I 84 c 120] == 20011217]} {emit {\(1.0 RC3\)}}
+if {[S [I 84 c 120] == 20011231]} {emit {\(1.0 RC3\)}}
+if {[S [I 84 c 120] > 20011231]} {emit {\(pre-1.0 CVS\)}}
+}
+}
+if {[S [I 84 c 96] == {Xiph.Org\ libVorbis\ I} c]} {emit {\b, created by: Xiph.Org libVorbis I}
+if {[S [I 84 c 117] > 00000000]} {if {[S [I 84 c 117] < 20020717]} {emit {\(pre-1.0 CVS\)}}
+if {[S [I 84 c 117] == 20020717]} {emit {\(1.0\)}}
+if {[S [I 84 c 117] == 20030909]} {emit {\(1.0.1\)}}
+if {[S [I 84 c 117] == 20040629]} {emit {\(1.1.0 RC1\)}}
+}
+}
+}
+}
+}
+}
+if {[N i 2 == 0x472b2c4e]} {emit {VXL data file,}
+if {[N s 0 > 0x0]} {emit {schema version no %d}}
+}
+if {[S 2 == {\040\040\040\040\040\040\040\040\040\040\040ML4D\040\'92}]} {emit {Smith Corona PWP}
+switch -- [Nv c 24] 2 {emit {\b, single spaced}} 3 {emit {\b, 1.5 spaced}} 4 {emit {\b, double spaced}}
+switch -- [Nv c 25] 66 {emit {\b, letter}} 84 {emit {\b, legal}}
+if {[N c 26 == 0x46]} {emit {\b, A4}}
+}
+if {[S 0 == {\377WPC\020\000\000\000\022\012\001\001\000\000\000\000}]} {emit {\(WP\) loadable text}
+switch -- [Nv c 15] 0 {emit {Optimized for Intel}} 1 {emit {Optimized for Non-Intel}}
+}
+if {[S 1 == WPC]} {emit {\(Corel/WP\)}
+switch -- [Nv Y 8] 257 {emit {WordPerfect macro}} 258 {emit {WordPerfect help file}} 259 {emit {WordPerfect keyboard file}} 266 {emit {WordPerfect document}} 267 {emit {WordPerfect dictionary}} 268 {emit {WordPerfect thesaurus}} 269 {emit {WordPerfect block}} 270 {emit {WordPerfect rectangular block}} 271 {emit {WordPerfect column block}} 272 {emit {WordPerfect printer data}} 275 {emit {WordPerfect printer data}} 276 {emit {WordPerfect driver resource data}} 279 {emit {WordPerfect hyphenation code}} 280 {emit {WordPerfect hyphenation data}} 281 {emit {WordPerfect macro resource data}} 283 {emit {WordPerfect hyphenation lex}} 285 {emit {WordPerfect wordlist}} 286 {emit {WordPerfect equation resource data}} 289 {emit {WordPerfect spell rules}} 290 {emit {WordPerfect dictionary rules}} 295 {emit {WordPerfect spell rules \(Microlytics\)}} 299 {emit {WordPerfect settings file}} 301 {emit {WordPerfect 4.2 document}} 325 {emit {WordPerfect dialog file}} 332 {emit {WordPerfect button bar}} 513 {emit {Shell macro}} 522 {emit {Shell definition}} 769 {emit {Notebook macro}} 770 {emit {Notebook help file}} 771 {emit {Notebook keyboard file}} 778 {emit {Notebook definition}} 1026 {emit {Calculator help file}} 1538 {emit {Calendar help file}} 1546 {emit {Calendar data file}} 1793 {emit {Editor macro}} 1794 {emit {Editor help file}} 1795 {emit {Editor keyboard file}} 1817 {emit {Editor macro resource file}} 2049 {emit {Macro editor macro}} 2050 {emit {Macro editor help file}} 2051 {emit {Macro editor keyboard file}} 2305 {emit {PlanPerfect macro}} 2306 {emit {PlanPerfect help file}} 2307 {emit {PlanPerfect keyboard file}} 2314 {emit {PlanPerfect worksheet}} 2319 {emit {PlanPerfect printer definition}} 2322 {emit {PlanPerfect graphic definition}} 2323 {emit {PlanPerfect data}} 2324 {emit {PlanPerfect temporary printer}} 2329 {emit {PlanPerfect macro resource data}} 2818 {emit {help file}} 2821 {emit {distribution list}} 2826 {emit {out box}} 2827 {emit {in box}} 2836 {emit {users archived mailbox}} 2837 {emit {archived message database}} 2838 {emit {archived attachments}} 3083 {emit {Printer temporary file}} 3330 {emit {Scheduler help file}} 3338 {emit {Scheduler in file}} 3339 {emit {Scheduler out file}} 3594 {emit {GroupWise settings file}} 3601 {emit {GroupWise directory services}} 3627 {emit {GroupWise settings file}} 4362 {emit {Terminal resource data}} 4363 {emit {Terminal resource data}} 4395 {emit {Terminal resource data}} 4619 {emit {GUI loadable text}} 4620 {emit {graphics resource data}} 4621 {emit {printer settings file}} 4622 {emit {port definition file}} 4623 {emit {print queue parameters}} 4624 {emit {compressed file}} 5130 {emit {Network service msg file}} 5131 {emit {Network service msg file}} 5132 {emit {Async gateway login msg}} 5134 {emit {GroupWise message file}} 7956 {emit {GroupWise admin domain database}} 7957 {emit {GroupWise admin host database}} 7959 {emit {GroupWise admin remote host database}} 7960 {emit {GroupWise admin ADS deferment data file}} 8458 {emit {IntelliTAG \(SGML\) compiled DTD}}
+if {[N c 8 == 0xb]} {emit Mail}
+switch -- [Nv Q 8] 18219264 {emit {WordPerfect graphic image \(1.0\)}} 18219520 {emit {WordPerfect graphic image \(2.0\)}}
+}
+if {[S 0 == {HWP\ Document\ File}]} {emit {Hangul \(Korean\) Word Processor File}}
+if {[S 0 == CSBK]} {emit {Ted Neslson's CosmicBook hypertext file}}
+if {[S 0 == %XDELTA%]} {emit {XDelta binary patch file 0.14}}
+if {[S 0 == %XDZ000%]} {emit {XDelta binary patch file 0.18}}
+if {[S 0 == %XDZ001%]} {emit {XDelta binary patch file 0.20}}
+if {[S 0 == %XDZ002%]} {emit {XDelta binary patch file 1.0}}
+if {[S 0 == %XDZ003%]} {emit {XDelta binary patch file 1.0.4}}
+if {[S 0 == %XDZ004%]} {emit {XDelta binary patch file 1.1}}
+if {[S 0 == core]} {emit {core file \(Xenix\)}}
+if {[S 0 == {\x55\x7A\x6E\x61}]} {emit {xo65 object,}
+if {[N s 4 x {}]} {emit {version %d,}}
+switch -- [Nv s 6 &0x0001] 1 {emit {with debug info}} 0 {emit {no debug info}}
+}
+if {[S 0 == {\x6E\x61\x55\x7A}]} {emit {xo65 library,}
+if {[N s 4 x {}]} {emit {version %d}}
+}
+if {[S 0 == {\x01\x00\x6F\x36\x35}]} {emit o65
+switch -- [Nv s 6 &0x1000] 0 {emit executable,} 4096 {emit object,}
+if {[N c 5 x {}]} {emit {version %d,}}
+switch -- [Nv s 6 &0x8000] -32768 {emit 65816,} 0 {emit 6502,}
+switch -- [Nv s 6 &0x2000] 8192 {emit {32 bit,}} 0 {emit {16 bit,}}
+switch -- [Nv s 6 &0x4000] 16384 {emit {page reloc,}} 0 {emit {byte reloc,}}
+switch -- [Nv s 6 &0x0003] 0 {emit {alignment 1}} 1 {emit {alignment 2}} 2 {emit {alignment 4}} 3 {emit {alignment 256}}
+}
+if {[S 1 == mkx]} {emit {Compiled XKB Keymap: lsb,}
+if {[N c 0 > 0x0]} {emit {version %d}}
+if {[N c 0 == 0x0]} {emit obsolete}
+}
+if {[S 0 == xkm]} {emit {Compiled XKB Keymap: msb,}
+if {[N c 3 > 0x0]} {emit {version %d}}
+if {[N c 0 == 0x0]} {emit obsolete}
+}
+if {[S 0 == xFSdump0]} {emit {xfsdump archive}
+if {[N Q 8 x {}]} {emit {\(version %d\)}}
+}
+if {[S 0 == {ZyXEL\002}]} {emit {ZyXEL voice data}
+if {[N c 10 == 0x0]} {emit {- CELP encoding}}
+switch -- [Nv c 10 &0x0B] 1 {emit {- ADPCM2 encoding}} 2 {emit {- ADPCM3 encoding}} 3 {emit {- ADPCM4 encoding}} 8 {emit {- New ADPCM3 encoding}}
+if {[N c 10 == 0x4 &0x04]} {emit {with resync}}
+}
+
+result
+
+return {}
+}
+
+## -- ** END GENERATED CODE ** --
+## -- Do not edit before this line !
+##
+
+# ### ### ### ######### ######### #########
+## Ready for use.
+# EOF
diff --git a/tcllib/modules/fumagic/filetypes.test b/tcllib/modules/fumagic/filetypes.test
new file mode 100644
index 0000000..5812e46
--- /dev/null
+++ b/tcllib/modules/fumagic/filetypes.test
@@ -0,0 +1,186 @@
+# -*- tcl -*-
+#
+# Testing "fumagic" (FileUtil Magic). Filetype recognizer.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2005-2006 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: filetypes.test,v 1.9 2006/10/09 21:41:40 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 1.0
+
+catch {namespace delete ::fileutil::magic}
+support {
+ useLocalFile fumagic.testsupport
+ useLocal rtcore.tcl fileutil::magic::rt
+}
+testing {
+ useLocal filetypes.tcl fileutil::magic::filetype
+}
+
+# -------------------------------------------------------------------------
+# Now the package specific tests....
+
+set path [makeFile {} bogus]
+removeFile bogus
+
+test fumagic.filetype-1.1 {test file non-existance} {
+ set res [catch {fileutil::magic::filetype $path} msg]
+ list $res $msg
+} [list 1 "file not found: \"$path\""]
+
+test fumagic.filetype-1.2 {test file directory} {
+ set f [makeDirectory fileTypeTest]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ regsub {file[0-9]+} $msg {fileXXX} msg
+ removeDirectory fileTypeTest
+ list $res $msg
+} {0 directory}
+
+test fumagic.filetype-1.3 {test file empty} {
+ set f [makeEmptyFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removeEmptyFile
+ list $res $msg
+} {0 {}}
+
+test fumagic.filetype-1.4 {test simple binary} {
+ set f [makeBinFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removeBinFile
+ list $res $msg
+} {0 {}}
+
+test fumagic.filetype-1.5 {test elf executable} {
+ set f [makeElfFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removeElfFile
+ list $res $msg
+} {0 {ELF 32-bit LSB AT&T WE32100 - invalid byte order, relocatable, \(\) \(SYSV\)}}
+
+test fumagic.filetype-1.6 {test simple text} {
+ set f [makeTextFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removeTextFile
+ list $res $msg
+} {0 {}}
+
+test fumagic.filetype-1.7 {test script file} {
+ set f [makeScriptFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removeScriptFile
+ list $res $msg
+} {0 {a /bin/tclsh script text executable}}
+
+test fumagic.filetype-1.8 {test html text} {
+ set f [makeHtmlFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removeHtmlFile
+ list $res $msg
+} {0 {HTML document text}}
+
+# 1.9/.10 possibly broken output.
+test fumagic.filetype-1.9 {test xml text} {
+ set f [makeXmlFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removeXmlFile
+ list $res $msg
+} {0 {XML document text \" XML XML %.3s document text broken XML document text}}
+
+test fumagic.filetype-1.10 {test xml with dtd text} {
+ set f [makeXmlDTDFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removeXmlDTDFile
+ list $res $msg
+} {0 {XML document text \" XML XML %.3s document text broken XML document text}}
+
+test fumagic.filetype-1.11 {test PGP message} {
+ set f [makePGPFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removePGPFile
+ list $res $msg
+} {0 {PGP armored data message}}
+
+test fumagic.filetype-1.12 {test binary graphic jpeg} {
+ set f [makeJpegFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removeJpegFile
+ list $res $msg
+} {0 {JPEG image data , JFIF standard 1. %02d , thumbnail 2x 2}}
+
+test fumagic.filetype-1.13 {test binary graphic gif} {
+ set f [makeGifFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removeGifFile
+ list $res $msg
+} {0 {GIF image data , version 89a,}}
+
+test fumagic.filetype-1.14 {test binary graphic png} {
+ set f [makePngFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removePngFile
+ list $res $msg
+} {0 {PNG image data, CORRUPTED, PNG image data, CORRUPTED}}
+
+test fumagic.filetype-1.15 {test binary graphic tiff} {
+ set f [makeTiffFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removeTiffFile
+ list $res $msg
+} {0 {TIFF image data, big-endian}}
+
+# 1.16 output possibly broken, missing substs.
+test fumagic.filetype-1.16 {test binary pdf} {
+ set f [makePdfFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removePdfFile
+ list $res $msg
+} {0 {PDF document , version %c .%c}}
+
+test fumagic.filetype-1.17 {test text ps} {
+ set f [makePSFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removePSFile
+ list $res $msg
+} {0 {PostScript document text}}
+
+test fumagic.filetype-1.18 {test text eps} {
+ set f [makeEPSFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removeEPSFile
+ list $res $msg
+} {0 {PostScript document text}}
+
+test fumagic.filetype-1.19 {test binary gravity_wave_data_frame} {
+ set f [makeIgwdFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removeIgwdFile
+ list $res $msg
+} {0 {}}
+
+test fumagic.filetype-1.20 {test binary compressed bzip} {
+ set f [makeBzipFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removeBzipFile
+ list $res $msg
+} {0 {bzip2 compressed data bzip compressed data , version: %c , compression block size 900k}}
+
+test fumagic.filetype-1.21 {test binary compressed gzip} {
+ set f [makeGzipFile]
+ set res [catch {fileutil::magic::filetype $f} msg]
+ removeGzipFile
+ list $res $msg
+} {0 {gzip compressed data , unknown method , ASCII , from MS-DOS}}
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/fumagic/fileutil_magic_cfront.pcx b/tcllib/modules/fumagic/fileutil_magic_cfront.pcx
new file mode 100644
index 0000000..99ad5c3
--- /dev/null
+++ b/tcllib/modules/fumagic/fileutil_magic_cfront.pcx
@@ -0,0 +1,35 @@
+# -*- tcl -*- fileutil::magic::cfront.pcx
+# Syntax of the commands provided by package fileutil::magic::cfront.
+#
+# 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 fileutil::magic::cfront
+pcx::tcldep 1.0 needs tcl 8.4
+
+namespace eval ::fileutil::magic::cfront {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.0 std ::fileutil::magic::cfront::compile \
+ {checkSimpleArgs 1 -1 {
+ checkFileName
+ }}
+pcx::check 1.0 std ::fileutil::magic::cfront::install \
+ {checkSimpleArgs 1 -1 {
+ checkFileName
+ }}
+pcx::check 1.0 std ::fileutil::magic::cfront::procdef \
+ {checkSimpleArgs 2 -1 {
+ checkWord
+ checkFileName
+ }}
+
+# Initialization via pcx::init.
+# Use a ::fileutil::magic::cfront::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/fumagic/fileutil_magic_cgen.pcx b/tcllib/modules/fumagic/fileutil_magic_cgen.pcx
new file mode 100644
index 0000000..0f9a423
--- /dev/null
+++ b/tcllib/modules/fumagic/fileutil_magic_cgen.pcx
@@ -0,0 +1,35 @@
+# -*- tcl -*- fileutil::magic::cgen.pcx
+# Syntax of the commands provided by package fileutil::magic::cgen.
+#
+# 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 fileutil::magic::cgen
+pcx::tcldep 1.0 needs tcl 8.4
+
+namespace eval ::fileutil::magic::cgen {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.0 std ::fileutil::magic::cgen::2tree \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 1.0 std ::fileutil::magic::cgen::treedump \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 1.0 std ::fileutil::magic::cgen::treegen \
+ {checkSimpleArgs 2 2 {
+ checkWord
+ checkWord
+ }}
+
+# Initialization via pcx::init.
+# Use a ::fileutil::magic::cgen::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/fumagic/fileutil_magic_filetype.pcx b/tcllib/modules/fumagic/fileutil_magic_filetype.pcx
new file mode 100644
index 0000000..7f1d7b9
--- /dev/null
+++ b/tcllib/modules/fumagic/fileutil_magic_filetype.pcx
@@ -0,0 +1,26 @@
+# -*- tcl -*- fileutil::magic::filetype.pcx
+# Syntax of the commands provided by package fileutil::magic::filetype.
+#
+# 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 fileutil::magic::filetype
+pcx::tcldep 1.0.2 needs tcl 8.4
+
+namespace eval ::fileutil::magic::filetype {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.0.2 std ::fileutil::magic::filetype \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+
+# Initialization via pcx::init.
+# Use a ::fileutil::magic::filetype::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/fumagic/fileutil_magic_mimetype.pcx b/tcllib/modules/fumagic/fileutil_magic_mimetype.pcx
new file mode 100644
index 0000000..e7f4749
--- /dev/null
+++ b/tcllib/modules/fumagic/fileutil_magic_mimetype.pcx
@@ -0,0 +1,26 @@
+# -*- tcl -*- fileutil::magic::mimetype.pcx
+# Syntax of the commands provided by package fileutil::magic::mimetype.
+#
+# 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 fileutil::magic::mimetype
+pcx::tcldep 1.0.2 needs tcl 8.4
+
+namespace eval ::fileutil::magic::mimetype {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.0.2 std ::fileutil::magic::mimetype \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+
+# Initialization via pcx::init.
+# Use a ::fileutil::magic::mimetype::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/fumagic/fileutil_magic_rt.pcx b/tcllib/modules/fumagic/fileutil_magic_rt.pcx
new file mode 100644
index 0000000..9dc45d1
--- /dev/null
+++ b/tcllib/modules/fumagic/fileutil_magic_rt.pcx
@@ -0,0 +1,116 @@
+# -*- tcl -*- fileutil::magic::rt.pcx
+# Syntax of the commands provided by package fileutil::magic::rt.
+#
+# 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 fileutil::magic::rt
+pcx::tcldep 1.0 needs tcl 8.4
+
+namespace eval ::fileutil::magic::rt {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.0 std ::fileutil::magic::rt::I \
+ {checkSimpleArgs 3 3 {
+ checkWholeNum
+ fileutil::magic::rt::checkType
+ checkInt
+ }}
+pcx::check 1.0 std ::fileutil::magic::rt::L \
+ {checkSimpleArgs 1 1 {
+ checkWholeNum
+ }}
+pcx::check 1.0 std ::fileutil::magic::rt::N \
+ {checkSimpleArgs 4 5 {
+ fileutil::magic::rt::checkType
+ checkWholeNum
+ {checkKeyword 1 {x < > <= >= == !=}}
+ checkInt
+ checkWord
+ }}
+# TODO: syntax of qualifiers.
+pcx::check 1.0 std ::fileutil::magic::rt::Nv \
+ {checkSimpleArgs 2 3 {
+ fileutil::magic::rt::checkType
+ checkWholeNum
+ checkWord
+ }}
+pcx::check 1.0 std ::fileutil::magic::rt::Nvx \
+ {checkSimpleArgs 3 4 {
+ checkWholeNum
+ fileutil::magic::rt::checkType
+ checkWholeNum
+ checkWord
+ }}
+pcx::check 1.0 std ::fileutil::magic::rt::Nx \
+ {checkSimpleArgs 5 6 {
+ checkWholeNum
+ fileutil::magic::rt::checkType
+ checkWholeNum
+ {checkKeyword 1 {x < > <= >= == !=}}
+ checkInt
+ checkWord
+ }}
+pcx::check 1.0 std ::fileutil::magic::rt::R \
+ {checkSimpleArgs 1 1 {
+ checkWholeNum
+ }}
+pcx::check 1.0 std ::fileutil::magic::rt::S \
+ {checkSimpleArgs 3 4 {
+ checkWholeNum
+ {checkKeyword 1 {x < > <= >= == !=}}
+ checkInt
+ checkWord
+
+ }}
+pcx::check 1.0 std ::fileutil::magic::rt::Sx \
+ {checkSimpleArgs 4 -5 {
+ checkWholeNum
+ checkWholeNum
+ {checkKeyword 1 {x < > <= >= == !=}}
+ checkInt
+ checkWord
+ }}
+pcx::check 1.0 std ::fileutil::magic::rt::close \
+ {checkAtEnd}
+# TODO: check string for the special placeholders
+pcx::check 1.0 std ::fileutil::magic::rt::emit \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 1.0 std ::fileutil::magic::rt::file_start \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+# TODO: syntax of complex offsets.
+pcx::check 1.0 std ::fileutil::magic::rt::offset \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 1.0 std ::fileutil::magic::rt::open \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+# TODO: check string for the special placeholders
+pcx::check 1.0 std ::fileutil::magic::rt::result \
+ {checkSimpleArgs 0 1 {
+ checkWord
+ }}
+pcx::check 1.0 std ::fileutil::magic::rt::resultv \
+ {checkSimpleArgs 0 1 {
+ checkWord
+ }}
+
+proc fileutil::magic::rt::checkType {t i} {
+ return [checkKeyword 1 {c s S i I Q Y date bedate ledate ldatebeldate leldate byte short beshort leshort long belong lelong ubyte ushort ubeshort uleshort ulong ubelong ulelong} $t $i]
+}
+
+# Initialization via pcx::init.
+# Use a ::fileutil::magic::rt::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/fumagic/fumagic.testsupport b/tcllib/modules/fumagic/fumagic.testsupport
new file mode 100644
index 0000000..a2f490c
--- /dev/null
+++ b/tcllib/modules/fumagic/fumagic.testsupport
@@ -0,0 +1,70 @@
+# -*- tcl -*-
+# Testsuite support specific to 'fileutil::magic'.
+# ### ### ### ######### ######### #########
+
+# This file can assume that the general testsupport (see
+# devtools/testutilities.tcl) is already loaded and active.
+
+# ### ### ### ######### ######### #########
+## Transient variables to hold more complex texts
+
+set xmlData {<?xml version="1.0" encoding="ISO-8859-1"?>
+
+<foobar></foobar>
+}
+
+set xmlDataWithDTD {<?xml version="1.0" encoding="ISO-8859-1"?>
+
+<!DOCTYPE foobar SYSTEM bogus.dtd>
+<foobar></foobar>
+}
+
+set pgpData {-----BEGIN PGP MESSAGE-----
+Version: PGP 6.5.8
+
+abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
+}
+
+# ### ### ### ######### ######### #########
+## Creates a series of commands for the creation of small data files
+## for various file formats.
+
+foreach {name data} [list \
+ Empty {} \
+ Bin "\u0000" \
+ Elf [cat "\x7F" "ELF" "\x01\x01\x01\x00\x00"] \
+ Bzip "BZh91AY&SY\x01\x01\x01\x00\x00" \
+ Gzip "\x1f\x8b\x01\x01\x01\x00\x00" \
+ Jpeg [cat "\xFF\xD8\xFF\xE0\x00\x10JFIF" "\x00\x01\x02\x01\x01\x2c"] \
+ Gif "GIF89a\x2b\x00\x40\x00\xf7\xff\x00" \
+ Png "\x89PNG\x00\x01\x02\x01\x01\x2c" \
+ Tiff "MM\x00\*\x00\x01\x02\x01\x01\x2c" \
+ Pdf "%PDF-1.2 \x00\x01\x02\x01\x01\x2c" \
+ Igwd "IGWD\x00\x01\x02\x01\x01\x2c"
+ ] {
+ proc make${name}File {} [list makeBinaryFile $data $name]
+ proc remove${name}File {} [list removeFile $name]
+}
+
+foreach {name data} [list \
+ PS "%!PS-ADOBO-123 EPSF-1.4" \
+ EPS "%!PS-ADOBO-123 EPSF-1.4" \
+ Text "simple text" \
+ Script "#!/bin/tclsh" \
+ Html "<html></html>" \
+ Xml $xmlData \
+ XmlDTD $xmlDataWithDTD \
+ PGP $pgpData
+ ] {
+ proc make${name}File {} [list makeFile $data $name]
+ proc remove${name}File {} [list removeFile $name]
+}
+
+# ### ### ### ######### ######### #########
+## Clean up the transient globals.
+
+unset xmlData
+unset xmlDataWithDTD
+unset pgpData
+
+# ### ### ### ######### ######### #########
diff --git a/tcllib/modules/fumagic/mimetypes.man b/tcllib/modules/fumagic/mimetypes.man
new file mode 100644
index 0000000..7b4cfa0
--- /dev/null
+++ b/tcllib/modules/fumagic/mimetypes.man
@@ -0,0 +1,60 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin fileutil::magic::mimetype n 1.0.2]
+[see_also file(1)]
+[see_also fileutil]
+[see_also magic(5)]
+[keywords {file recognition}]
+[keywords {file type}]
+[keywords {file utilities}]
+[keywords mime]
+[keywords type]
+[moddesc {file utilities}]
+[titledesc {Procedures implementing mime-type recognition}]
+[category {Programming tools}]
+[require Tcl 8.4]
+[require fileutil::magic::mimetype [opt 1.0.2]]
+[description]
+[para]
+
+This package provides a command for the recognition of file types in
+pure Tcl. The output is standardized to mime-types.
+
+[para]
+
+The core part of the recognizer was generated from a "magic(5)" file
+containing the checks to perform to recognize files, and associated
+mime-types.
+
+[list_begin definitions]
+
+[call [cmd ::fileutil::magic::mimetype] [arg filename]]
+
+This command is similar to the command [cmd fileutil::fileType].
+
+[para]
+
+The output of the command for the specified file is not a list of
+attributes describing the type of the file, but a list of standard
+mime-types the file may have.
+
+[para]
+
+This list will be empty if the type of the file is not recognized.
+
+[list_end]
+
+[section REFERENCES]
+
+[list_begin enumerated]
+[enum]
+[uri ftp://ftp.astron.com/pub/file/ {File(1) sources}]
+
+This site contains the current sources for the file command, including
+the magic definitions used by it. The latter were used by us to
+generate this recognizer.
+
+[list_end]
+
+[vset CATEGORY {fileutil :: magic}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/fumagic/mimetypes.tcl b/tcllib/modules/fumagic/mimetypes.tcl
new file mode 100644
index 0000000..d73f573
--- /dev/null
+++ b/tcllib/modules/fumagic/mimetypes.tcl
@@ -0,0 +1,583 @@
+# mimetypes.tcl --
+#
+# Tcl based file type recognizer using the runtime core and
+# generated from /usr/share/misc/magic.mime. Limited output,
+# but only mime-types, i.e. standardized.
+#
+# Copyright (c) 2004-2005 Colin McCormack <coldstore@users.sourceforge.net>
+# Copyright (c) 2005-2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: mimetypes.tcl,v 1.8 2006/09/27 21:19:35 andreas_kupries Exp $
+
+#####
+#
+# "mime type discriminator"
+# http://wiki.tcl.tk/12537
+#
+# Tcl code harvested on: 10 Feb 2005, 04:16 GMT
+# Wiki page last updated: ???
+#
+#####
+
+# ### ### ### ######### ######### #########
+## Requirements.
+
+package require Tcl 8.4
+package require fileutil::magic::rt ; # We need the runtime core.
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+namespace eval ::fileutil::magic {}
+
+proc ::fileutil::magic::mimetype {file} {
+ if {![file exists $file]} {
+ return -code error "file not found: \"$file\""
+ }
+ if {[file isdirectory $file]} {
+ return application/x-directory
+ }
+
+ rt::open $file
+ mimetype::run
+ rt::close
+ set types [rt::resultv]
+
+ if {[llength $types]} {
+ # We postprocess the data if needed, as the low-level
+ # recognizer can return duplicate information.
+
+ array set _ {}
+ set utypes {}
+ foreach t $types {
+ if {[info exists _($t)]} continue
+ lappend utypes $t
+ set _($t) .
+ set types $utypes
+ }
+ }
+ return $types
+}
+
+package provide fileutil::magic::mimetype 1.0.2
+# The actual recognizer is the command below.
+
+##
+## -- Do not edit after this line !
+## -- ** BEGIN GENERATED CODE ** --
+
+package require fileutil::magic::rt
+namespace eval ::fileutil::magic::mimetype {
+ namespace import ::fileutil::magic::rt::*
+}
+
+proc ::fileutil::magic::mimetype::run {} {
+ switch -- [Nv s 0 ] 1538 {emit application/x-alan-adventure-game} 387 {emit application/x-executable-file} -147 {emit application/data} -155 {emit application/data} -5536 {emit application/x-arj} -138 {emit application/data} -394 {emit application/data} -650 {emit application/x-lzh} 387 {emit application/x-executable-file} 392 {emit application/x-executable-file} 399 {emit application/x-object-file} -13230 {emit {RLE image data,}} 322 {emit {basic-16 executable}} 323 {emit {basic-16 executable \(TV\)}} 328 {emit application/x-executable-file} 329 {emit application/x-executable-file} 330 {emit application/x-executable-file} 338 {emit application/x-executable-file} 332 {emit application/x-executable-file} 1078 {emit font/linux-psf} 387 {emit {ECOFF alpha}} 332 {emit {MS Windows COFF Intel 80386 object file}} 358 {emit {MS Windows COFF MIPS R4000 object file}} 388 {emit {MS Windows COFF Alpha object file}} 616 {emit {MS Windows COFF Motorola 68000 object file}} 496 {emit {MS Windows COFF PowerPC object file}} 656 {emit {MS Windows COFF PA-RISC object file}} 263 {emit {PDP-11 executable}} 257 {emit {PDP-11 UNIX/RT ldp}} 261 {emit {PDP-11 old overlay}} 264 {emit {PDP-11 pure executable}} 265 {emit {PDP-11 separate I&D executable}} 287 {emit {PDP-11 kernel overlay}} 4843 {emit {SYMMETRY i386 .o}} 8939 {emit {SYMMETRY i386 executable \(0 @ 0\)}} 13035 {emit {SYMMETRY i386 executable \(invalid @ 0\)}} 17131 {emit {SYMMETRY i386 standalone executable}} 376 {emit {VAX COFF executable}} 381 {emit {VAX COFF pure executable}} -155 {emit x.out} 518 {emit {Microsoft a.out}} 320 {emit {old Microsoft 8086 x.out}} 1408 {emit {XENIX 8086 relocatable or 80286 small model}}
+ if {[S 0 == TADS ]} {emit application/x-tads-game}
+ switch -- [Nv S 0 ] 272 {emit application/x-executable-file} 273 {emit application/x-executable-file} 29127 {emit application/x-cpio} -14479 {emit application/x-bcpio} -147 {emit application/data} -155 {emit application/data} 368 {emit application/x-executable-file} 369 {emit application/x-executable-file} 1793 {emit application/x-executable-file} 262 {emit application/x-executable-file} 1537 {emit application/x-executable-file} 381 {emit application/x-executable-file} 383 {emit application/x-executable-file} 7967 {emit application/data} 8191 {emit application/data} -13563 {emit application/data} 1281 {emit application/x-locale} 340 {emit application/data} 341 {emit application/x-executable-file} 286 {emit font/x-vfont} 7681 {emit font/x-vfont} 407 {emit application/x-executable-file} 404 {emit application/x-executable-file} 200 {emit {hp200 \(68010\) BSD}} 300 {emit {hp300 \(68020+68881\) BSD}} 351 {emit {370 XA sysV executable}} 346 {emit {370 XA sysV pure executable}} 22529 {emit {370 sysV pure executable}} 23041 {emit {370 XA sysV pure executable}} 23809 {emit {370 sysV executable}} 24321 {emit {370 XA sysV executable}} 345 {emit {SVR2 executable \(Amdahl-UTS\)}} 348 {emit {SVR2 pure executable \(Amdahl-UTS\)}} 344 {emit {SVR2 pure executable \(USS/370\)}} 349 {emit {SVR2 executable \(USS/370\)}} 479 {emit {executable \(RISC System/6000 V3.1\) or obj module}} 260 {emit {shared library}} 261 {emit {ctab data}} -508 {emit {structured file}} 12320 {emit {character Computer Graphics Metafile}} -40 {emit image/jpeg} 474 {emit x/x-image-sgi} 4112 {emit {PEX Binary Archive}} -21267 {emit {Java serialization data}} -32768 {emit {lif file}} 256 {emit {raw G3 data, byte-padded}} 5120 {emit {raw G3 data}} 336 {emit {mc68k COFF}} 337 {emit {mc68k executable \(shared\)}} 338 {emit {mc68k executable \(shared demand paged\)}} 364 {emit {68K BCS executable}} 365 {emit {88K BCS executable}} 392 {emit {Tower/XP rel 2 object}} 397 {emit {Tower/XP rel 2 object}} 400 {emit {Tower/XP rel 3 object}} 405 {emit {Tower/XP rel 3 object}} 408 {emit {Tower32/600/400 68020 object}} 416 {emit {Tower32/800 68020}} 421 {emit {Tower32/800 68010}} -30771 {emit {OS9/6809 module:}} 19196 {emit {OS9/68K module:}} 373 {emit {i386 COFF object}} 10775 {emit {\"compact bitmap\" format \(Poskanzer\)}} -26368 {emit {PGP key public ring}} -27391 {emit {PGP key security ring}} -27392 {emit {PGP key security ring}} -23040 {emit {PGP encrypted data}} 601 {emit {mumps avl global}} 602 {emit {mumps blt global}} -4693 {emit {}} 10012 {emit {Sendmail frozen configuration}} -30875 {emit {disk quotas file}} 1286 {emit {IRIS Showcase file}} 550 {emit {IRIS Showcase template}} 352 {emit {MIPSEB COFF executable}} 354 {emit {MIPSEL COFF executable}} 24577 {emit {MIPSEB-LE COFF executable}} 25089 {emit {MIPSEL-LE COFF executable}} 355 {emit {MIPSEB MIPS-II COFF executable}} 358 {emit {MIPSEL MIPS-II COFF executable}} 25345 {emit {MIPSEB-LE MIPS-II COFF executable}} 26113 {emit {MIPSEL-LE MIPS-II COFF executable}} 320 {emit {MIPSEB MIPS-III COFF executable}} 322 {emit {MIPSEL MIPS-III COFF executable}} 16385 {emit {MIPSEB-LE MIPS-III COFF executable}} 16897 {emit {MIPSEL-LE MIPS-III COFF executable}} 384 {emit {MIPSEB Ucode}} 386 {emit {MIPSEL Ucode}} -16162 {emit {Compiled PSI \(v1\) data}} -16166 {emit {Compiled PSI \(v2\) data}} -21846 {emit {SoftQuad DESC or font file binary}} 283 {emit {Curses screen image}} 284 {emit {Curses screen image}} 263 {emit {unknown machine executable}} 264 {emit {unknown pure executable}} 265 {emit {PDP-11 separate I&D}} 267 {emit {unknown pure executable}} 392 {emit {Perkin-Elmer executable}} 378 {emit {amd 29k coff noprebar executable}} 890 {emit {amd 29k coff prebar executable}} -8185 {emit {amd 29k coff archive}} 21845 {emit {VISX image file}}
+ if {[S 0 == {Core\001} ]} {emit application/x-executable-file}
+ if {[S 0 == {AMANDA:\ TAPESTART\ DATE} ]} {emit application/x-amanda-header}
+ switch -- [Nv I 0 ] 1011 {emit application/x-executable-file} 999 {emit application/x-library-file} 435 {emit video/mpeg} 442 {emit video/mpeg} 33132 {emit application/x-apl-workspace} 333312 {emit application/data} 333319 {emit application/data} 65389 {emit application/x-ar} 65381 {emit application/data} 33132 {emit application/x-apl-workspace} 1711210496 {emit application/x-ar} 1013019198 {emit application/x-ar} 557605234 {emit application/x-ar} 1314148939 {emit audio/x-multitrack} 779248125 {emit audio/x-pn-realaudio} 262 {emit application/x-executable-file} 327 {emit application/x-object-file} 331 {emit application/x-executable-file} 333 {emit application/x-executable-file} 335 {emit application/x-executable-file} 70231 {emit application/core} 385 {emit application/x-object-file} 391 {emit application/data} 324508366 {emit application/x-gdbm} 398689 {emit application/x-db} 340322 {emit application/x-db} 1234567 {emit image/x11} 4 {emit font/x-snf} 335698201 {emit font/x-libgrx} -12169394 {emit font/x-dos} 168757262 {emit application/data} 252317192 {emit application/data} 135137807 {emit application/data} 235409162 {emit application/data} 34603270 {emit application/x-object-file} 34603271 {emit application/x-executable-file} 34603272 {emit application/x-executable-file} 34603275 {emit application/x-executable-file} 34603278 {emit application/x-library-file} 34603277 {emit application/x-library-file} 34865414 {emit application/x-object-file} 34865415 {emit application/x-executable-file} 34865416 {emit application/x-executable-file} 34865419 {emit application/x-executable-file} 34865422 {emit application/x-library-file} 34865421 {emit application/x-object-file} 34275590 {emit application/x-object-file} 34275591 {emit application/x-executable-file} 34275592 {emit application/x-executable-file} 34275595 {emit application/x-executable-file} 34275598 {emit application/x-library-file} 34275597 {emit application/x-library-file} 557605234 {emit application/x-ar} 34078982 {emit application/x-executable-file} 34078983 {emit application/x-executable-file} 34078984 {emit application/x-executable-file} 34341128 {emit application/x-executable-file} 34341127 {emit application/x-executable-file} 34341131 {emit application/x-executable-file} 34341126 {emit application/x-executable-file} 34210056 {emit application/x-executable-file} 34210055 {emit application/x-executable-file} 34341134 {emit application/x-library-file} 34341133 {emit application/x-library-file} 65381 {emit application/x-library-file} 34275173 {emit application/x-library-file} 34406245 {emit application/x-library-file} 34144101 {emit application/x-library-file} 22552998 {emit application/core} 1302851304 {emit font/x-hp-windows} 34341132 {emit application/x-lisp} 505 {emit {AIX compiled message catalog}} 1123028772 {emit {Artisan image data}} 1504078485 {emit x/x-image-sun-raster} -889275714 {emit {compiled Java class data,}} -1195374706 {emit {Linux kernel}} 1886817234 {emit {CLISP memory image data}} -762612112 {emit {CLISP memory image data, other endian}} -569244523 {emit {GNU-format message catalog data}} -1794895138 {emit {GNU-format message catalog data}} -889275714 {emit {mach-o fat file}} -17958194 {emit mach-o} 31415 {emit {Mirage Assembler m.out executable}} 834535424 {emit text/vnd.ms-word} 6656 {emit {Lotus 1-2-3}} 512 {emit {Lotus 1-2-3}} 263 {emit {NetBSD big-endian object file}} 326773060 {emit font/x-sunos-news} 326773063 {emit font/x-sunos-news} 326773072 {emit font/x-sunos-news} 326773073 {emit font/x-sunos-news} 61374 {emit {OSF/Rose object}} -976170042 {emit {DOS EPS Binary File}} 1351614727 {emit {Pyramid 90x family executable}} 1351614728 {emit {Pyramid 90x family pure executable}} 1351614731 {emit {Pyramid 90x family demand paged pure executable}} 263 {emit {old SGI 68020 executable}} 264 {emit {old SGI 68020 pure executable}} 1396917837 {emit {IRIS Showcase file}} 1413695053 {emit {IRIS Showcase template}} -559039810 {emit {IRIX Parallel Arena}} -559043152 {emit {IRIX core dump}} -559043264 {emit {IRIX 64-bit core dump}} -1161903941 {emit {IRIX N32 core dump}} -1582119980 {emit {tcpdump capture file \(big-endian\)}} 263 {emit {old sun-2 executable}} 264 {emit {old sun-2 pure executable}} 267 {emit {old sun-2 demand paged executable}} 525398 {emit {SunOS core file}} -97271666 {emit {SunPC 4.0 Hard Disk}} 268 {emit {unknown demand paged pure executable}} 269 {emit {unknown demand paged pure executable}} 270 {emit {unknown readable demand paged pure executable}} 50331648 {emit {VMS Alpha executable}} 59399 {emit {object file \(z8000 a.out\)}} 59400 {emit {pure object file \(z8000 a.out\)}} 59401 {emit {separate object file \(z8000 a.out\)}} 59397 {emit {overlay object file \(z8000 a.out\)}}
+ if {[N S 0 == 0xfff0 &0xfff0]} {emit audio/mpeg}
+ switch -- [Nv s 4 ] -20719 {emit video/fli} -20718 {emit video/flc}
+ if {[S 8 == {AVI\ } ]} {emit video/x-msvideo}
+ if {[S 0 == MOVI ]} {emit video/x-sgi-movie}
+ if {[S 4 == moov ]} {emit video/quicktime}
+ if {[S 4 == mdat ]} {emit video/quicktime}
+ if {[S 0 == FiLeStArTfIlEsTaRt ]} {emit text/x-apple-binscii}
+ if {[S 0 == {\x0aGL} ]} {emit application/data}
+ if {[S 0 == {\x76\xff} ]} {emit application/data}
+ if {[S 0 == NuFile ]} {emit application/data}
+ if {[S 0 == {N\xf5F\xe9l\xe5} ]} {emit application/data}
+ if {[S 257 == {ustar\0} ]} {emit application/x-tar}
+ if {[S 257 == {ustar\040\040\0} ]} {emit application/x-gtar}
+ if {[S 0 == 070707 ]} {emit application/x-cpio}
+ if {[S 0 == 070701 ]} {emit application/x-cpio}
+ if {[S 0 == 070702 ]} {emit application/x-cpio}
+ if {[S 0 == {!<arch>\ndebian} ]} {emit application/x-dpkg}
+ if {[S 0 == <ar> ]} {emit application/x-ar}
+ if {[S 0 == {!<arch>\n__________E} ]} {emit application/x-ar}
+ if {[S 0 == -h- ]} {emit application/data}
+ if {[S 0 == !<arch> ]} {emit application/x-ar}
+ if {[S 0 == <ar> ]} {emit application/x-ar}
+ if {[S 0 == <ar> ]} {emit application/x-ar}
+ switch -- [Nv i 0 ] 65389 {emit application/data} 65381 {emit application/data} 236525 {emit application/data} 236526 {emit application/data} 6583086 {emit audio/basic} 204 {emit application/x-executable-file} 324508366 {emit application/x-gdbm} 453186358 {emit application/x-bootable} 4 {emit font/x-snf} 1279543401 {emit application/data} 6553863 {emit {Linux/i386 impure executable \(OMAGIC\)}} 6553864 {emit {Linux/i386 pure executable \(NMAGIC\)}} 6553867 {emit {Linux/i386 demand-paged executable \(ZMAGIC\)}} 6553804 {emit {Linux/i386 demand-paged executable \(QMAGIC\)}} 263 {emit {NetBSD little-endian object file}} 459141 {emit {ECOFF NetBSD/alpha binary}} 33645 {emit {PDP-11 single precision APL workspace}} 33644 {emit {PDP-11 double precision APL workspace}} 234 {emit {BALANCE NS32000 .o}} 4330 {emit {BALANCE NS32000 executable \(0 @ 0\)}} 8426 {emit {BALANCE NS32000 executable \(invalid @ 0\)}} 12522 {emit {BALANCE NS32000 standalone executable}} -1582119980 {emit {tcpdump capture file \(little-endian\)}} 33647 {emit {VAX single precision APL workspace}} 33646 {emit {VAX double precision APL workspace}} 263 {emit {VAX executable}} 264 {emit {VAX pure executable}} 267 {emit {VAX demand paged pure executable}} 518 {emit b.out}
+ switch -- [Nv i 0 &0x8080ffff] 2074 {emit application/x-arc} 2330 {emit application/x-arc} 538 {emit application/x-arc} 794 {emit application/x-arc} 1050 {emit application/x-arc} 1562 {emit application/x-arc}
+ if {[S 0 == {\032archive} ]} {emit application/data}
+ if {[S 0 == HPAK ]} {emit application/data}
+ if {[S 0 == {\351,\001JAM\ } ]} {emit application/data}
+ if {[S 2 == -lh0- ]} {emit application/x-lha}
+ if {[S 2 == -lh1- ]} {emit application/x-lha}
+ if {[S 2 == -lz4- ]} {emit application/x-lha}
+ if {[S 2 == -lz5- ]} {emit application/x-lha}
+ if {[S 2 == -lzs- ]} {emit application/x-lha}
+ if {[S 2 == {-lh\40-} ]} {emit application/x-lha}
+ if {[S 2 == -lhd- ]} {emit application/x-lha}
+ if {[S 2 == -lh2- ]} {emit application/x-lha}
+ if {[S 2 == -lh3- ]} {emit application/x-lha}
+ if {[S 2 == -lh4- ]} {emit application/x-lha}
+ if {[S 2 == -lh5- ]} {emit application/x-lha}
+ if {[S 0 == Rar! ]} {emit application/x-rar}
+ if {[S 0 == SQSH ]} {emit application/data}
+ if {[S 0 == {UC2\x1a} ]} {emit application/data}
+ if {[S 0 == {PK\003\004} ]} {emit application/zip}
+ if {[N i 20 == 0xfdc4a7dc ]} {emit application/x-zoo}
+ if {[S 10 == {\#\ This\ is\ a\ shell\ archive} ]} {emit application/x-shar}
+ if {[S 0 == *STA ]} {emit application/data}
+ if {[S 0 == 2278 ]} {emit application/data}
+ if {[S 0 == {\000\004\036\212\200} ]} {emit application/core}
+ if {[S 0 == .snd ]} {emit audio/basic}
+ if {[S 0 == MThd ]} {emit audio/midi}
+ if {[S 0 == CTMF ]} {emit audio/x-cmf}
+ if {[S 0 == SBI ]} {emit audio/x-sbi}
+ if {[S 0 == {Creative\ Voice\ File} ]} {emit audio/x-voc}
+ if {[S 0 == RIFF ]} {emit audio/x-wav}
+ if {[S 8 == AIFC ]} {emit audio/x-aifc}
+ if {[S 8 == AIFF ]} {emit audio/x-aiff}
+ if {[S 0 == {.ra\375} ]} {emit audio/x-real-audio}
+ if {[S 8 == WAVE ]} {emit audio/x-wav}
+ if {[S 8 == {WAV\ } ]} {emit audio/x-wav}
+ if {[S 0 == RIFF ]} {emit audio/x-riff}
+ if {[S 0 == EMOD ]} {emit audio/x-emod}
+ if {[S 0 == MTM ]} {emit audio/x-multitrack}
+ if {[S 0 == if ]} {emit audio/x-669-mod}
+ if {[S 0 == FAR ]} {emit audio/mod}
+ if {[S 0 == MAS_U ]} {emit audio/x-multimate-mod}
+ if {[S 44 == SCRM ]} {emit audio/x-st3-mod}
+ if {[S 0 == {GF1PATCH110\0ID\#000002\0} ]} {emit audio/x-gus-patch}
+ if {[S 0 == {GF1PATCH100\0ID\#000002\0} ]} {emit audio/x-gus-patch}
+ if {[S 0 == JN ]} {emit audio/x-669-mod}
+ if {[S 0 == UN05 ]} {emit audio/x-mikmod-uni}
+ if {[S 0 == {Extended\ Module:} ]} {emit audio/x-ft2-mod}
+ if {[S 21 == !SCREAM! ]} {emit audio/x-st2-mod}
+ if {[S 1080 == M.K. ]} {emit audio/x-protracker-mod}
+ if {[S 1080 == M!K! ]} {emit audio/x-protracker-mod}
+ if {[S 1080 == FLT4 ]} {emit audio/x-startracker-mod}
+ if {[S 1080 == 4CHN ]} {emit audio/x-fasttracker-mod}
+ if {[S 1080 == 6CHN ]} {emit audio/x-fasttracker-mod}
+ if {[S 1080 == 8CHN ]} {emit audio/x-fasttracker-mod}
+ if {[S 1080 == CD81 ]} {emit audio/x-oktalyzer-mod}
+ if {[S 1080 == OKTA ]} {emit audio/x-oktalyzer-mod}
+ if {[S 1080 == 16CN ]} {emit audio/x-taketracker-mod}
+ if {[S 1080 == 32CN ]} {emit audio/x-taketracker-mod}
+ if {[S 0 == TOC ]} {emit audio/x-toc}
+ if {[S 0 == // ]} {emit text/cpp}
+ if {[S 0 == {\\1cw\ } ]} {emit application/data}
+ if {[S 0 == {\\1cw} ]} {emit application/data}
+ switch -- [Nv I 0 &0xffffff00] -2063526912 {emit application/data} -2063480064 {emit application/data}
+ if {[S 4 == pipe ]} {emit application/data}
+ if {[S 4 == prof ]} {emit application/data}
+ if {[S 0 == {:\ shell} ]} {emit application/data}
+ if {[S 0 == {\#!/bin/sh} ]} {emit application/x-sh}
+ if {[S 0 == {\#!\ /bin/sh} ]} {emit application/x-sh}
+ if {[S 0 == {\#!\ /bin/sh} ]} {emit application/x-sh}
+ if {[S 0 == {\#!/bin/csh} ]} {emit application/x-csh}
+ if {[S 0 == {\#!\ /bin/csh} ]} {emit application/x-csh}
+ if {[S 0 == {\#!\ /bin/csh} ]} {emit application/x-csh}
+ if {[S 0 == {\#!/bin/ksh} ]} {emit application/x-ksh}
+ if {[S 0 == {\#!\ /bin/ksh} ]} {emit application/x-ksh}
+ if {[S 0 == {\#!\ /bin/ksh} ]} {emit application/x-ksh}
+ if {[S 0 == {\#!/bin/tcsh} ]} {emit application/x-csh}
+ if {[S 0 == {\#!\ /bin/tcsh} ]} {emit application/x-csh}
+ if {[S 0 == {\#!\ /bin/tcsh} ]} {emit application/x-csh}
+ if {[S 0 == {\#!/usr/local/tcsh} ]} {emit application/x-csh}
+ if {[S 0 == {\#!\ /usr/local/tcsh} ]} {emit application/x-csh}
+ if {[S 0 == {\#!/usr/local/bin/tcsh} ]} {emit application/x-csh}
+ if {[S 0 == {\#!\ /usr/local/bin/tcsh} ]} {emit application/x-csh}
+ if {[S 0 == {\#!\ /usr/local/bin/tcsh} ]} {emit application/x-csh}
+ if {[S 0 == {\#!/usr/local/bin/zsh} ]} {emit application/x-zsh}
+ if {[S 0 == {\#!\ /usr/local/bin/zsh} ]} {emit application/x-zsh}
+ if {[S 0 == {\#!\ /usr/local/bin/zsh} ]} {emit application/x-zsh}
+ if {[S 0 == {\#!/usr/local/bin/ash} ]} {emit application/x-sh}
+ if {[S 0 == {\#!\ /usr/local/bin/ash} ]} {emit application/x-zsh}
+ if {[S 0 == {\#!\ /usr/local/bin/ash} ]} {emit application/x-zsh}
+ if {[S 0 == {\#!/usr/local/bin/ae} ]} {emit text/script}
+ if {[S 0 == {\#!\ /usr/local/bin/ae} ]} {emit text/script}
+ if {[S 0 == {\#!\ /usr/local/bin/ae} ]} {emit text/script}
+ if {[S 0 == {\#!/bin/nawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /bin/nawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /bin/nawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!/usr/bin/nawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /usr/bin/nawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /usr/bin/nawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!/usr/local/bin/nawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /usr/local/bin/nawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /usr/local/bin/nawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!/bin/gawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /bin/gawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /bin/gawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!/usr/bin/gawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /usr/bin/gawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /usr/bin/gawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!/usr/local/bin/gawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /usr/local/bin/gawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /usr/local/bin/gawk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!/bin/awk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /bin/awk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /bin/awk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!/usr/bin/awk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /usr/bin/awk} ]} {emit application/x-awk}
+ if {[S 0 == {\#!\ /usr/bin/awk} ]} {emit application/x-awk}
+ if {[S 0 == BEGIN ]} {emit application/x-awk}
+ if {[S 0 == {\#!/bin/perl} ]} {emit application/x-perl}
+ if {[S 0 == {\#!\ /bin/perl} ]} {emit application/x-perl}
+ if {[S 0 == {\#!\ /bin/perl} ]} {emit application/x-perl}
+ if {[S 0 == {eval\ \"exec\ /bin/perl} ]} {emit application/x-perl}
+ if {[S 0 == {\#!/usr/bin/perl} ]} {emit application/x-perl}
+ if {[S 0 == {\#!\ /usr/bin/perl} ]} {emit application/x-perl}
+ if {[S 0 == {\#!\ /usr/bin/perl} ]} {emit application/x-perl}
+ if {[S 0 == {eval\ \"exec\ /usr/bin/perl} ]} {emit application/x-perl}
+ if {[S 0 == {\#!/usr/local/bin/perl} ]} {emit application/x-perl}
+ if {[S 0 == {\#!\ /usr/local/bin/perl} ]} {emit application/x-perl}
+ if {[S 0 == {\#!\ /usr/local/bin/perl} ]} {emit application/x-perl}
+ if {[S 0 == {eval\ \"exec\ /usr/local/bin/perl} ]} {emit application/x-perl}
+ if {[S 0 == {\#!/bin/rc} ]} {emit text/script}
+ if {[S 0 == {\#!\ /bin/rc} ]} {emit text/script}
+ if {[S 0 == {\#!\ /bin/rc} ]} {emit text/script}
+ if {[S 0 == {\#!/bin/bash} ]} {emit application/x-sh}
+ if {[S 0 == {\#!\ /bin/bash} ]} {emit application/x-sh}
+ if {[S 0 == {\#!\ /bin/bash} ]} {emit application/x-sh}
+ if {[S 0 == {\#!/usr/local/bin/bash} ]} {emit application/x-sh}
+ if {[S 0 == {\#!\ /usr/local/bin/bash} ]} {emit application/x-sh}
+ if {[S 0 == {\#!\ /usr/local/bin/bash} ]} {emit application/x-sh}
+ if {[S 0 == {\#!\ /} ]} {emit text/script}
+ if {[S 0 == {\#!\ /} ]} {emit text/script}
+ if {[S 0 == {\#!/} ]} {emit text/script}
+ if {[S 0 == {\#!\ } ]} {emit text/script}
+ if {[S 0 == {\037\235} ]} {emit application/compress}
+ if {[S 0 == {\037\213} ]} {emit application/x-gzip}
+ if {[S 0 == {\037\036} ]} {emit application/data}
+ if {[S 0 == {\377\037} ]} {emit application/data}
+ if {[S 0 == BZh ]} {emit application/x-bzip2}
+ if {[S 0 == {\037\237} ]} {emit application/data}
+ if {[S 0 == {\037\236} ]} {emit application/data}
+ if {[S 0 == {\037\240} ]} {emit application/data}
+ if {[S 0 == BZ ]} {emit application/x-bzip}
+ if {[S 0 == {\x89\x4c\x5a\x4f\x00\x0d\x0a\x1a\x0a} ]} {emit application/data}
+ switch -- [Nv I 24 ] 60011 {emit application/data} 60012 {emit application/data} 60013 {emit application/data} 60014 {emit application/data} 60012 {emit application/x-dump} 60011 {emit application/x-dump}
+ if {[S 0 == GDBM ]} {emit application/x-gdbm}
+ if {[S 0 == {<list>\n<protocol\ bbn-m} ]} {emit application/data}
+ if {[S 0 == {diff\ } ]} {emit text/x-patch}
+ if {[S 0 == {***\ } ]} {emit text/x-patch}
+ if {[S 0 == {Only\ in\ } ]} {emit text/x-patch}
+ if {[S 0 == {Common\ subdirectories:\ } ]} {emit text/x-patch}
+ if {[S 0 == {!<arch>\n________64E} ]} {emit application/data}
+ if {[S 0 == {\377\377\177} ]} {emit application/data}
+ if {[S 0 == {\377\377\174} ]} {emit application/data}
+ if {[S 0 == {\377\377\176} ]} {emit application/data}
+ if {[S 0 == {\033c\033} ]} {emit application/data}
+ if {[S 0 == {!<PDF>!\n} ]} {emit application/x-prof}
+ switch -- [Nv i 24 ] 60012 {emit application/x-dump} 60011 {emit application/x-dump}
+ if {[S 0 == {\177ELF} ]} {emit application/x-executable-file}
+ if {[N s 1080 == 0xef53 ]} {emit application/x-linux-ext2fs}
+ if {[S 0 == {\366\366\366\366} ]} {emit application/x-pc-floppy}
+ if {[N S 508 == 0xdabe ]} {emit application/data}
+ if {[N s 510 == 0xaa55 ]} {emit application/data}
+ switch -- [Nv s 1040 ] 4991 {emit application/x-filesystem} 5007 {emit application/x-filesystem} 9320 {emit application/x-filesystem} 9336 {emit application/x-filesystem}
+ if {[S 0 == {-rom1fs-\0} ]} {emit application/x-filesystem}
+ if {[S 395 == OS/2 ]} {emit application/x-bootable}
+ if {[S 0 == FONT ]} {emit font/x-vfont}
+ if {[S 0 == %!PS-AdobeFont-1.0 ]} {emit font/type1}
+ if {[S 6 == %!PS-AdobeFont-1.0 ]} {emit font/type1}
+ if {[S 0 == {STARTFONT\040} ]} {emit font/x-bdf}
+ if {[S 0 == {\001fcp} ]} {emit font/x-pcf}
+ if {[S 0 == {D1.0\015} ]} {emit font/x-speedo}
+ if {[S 0 == flf ]} {emit font/x-figlet}
+ if {[S 0 == flc ]} {emit application/x-font}
+ switch -- [Nv I 7 ] 4540225 {emit font/x-dos} 5654852 {emit font/x-dos}
+ if {[S 4098 == DOSFONT ]} {emit font/x-dos}
+ if {[S 0 == <MakerFile ]} {emit application/x-framemaker}
+ if {[S 0 == <MIFFile ]} {emit application/x-framemaker}
+ if {[S 0 == <MakerDictionary ]} {emit application/x-framemaker}
+ if {[S 0 == <MakerScreenFont ]} {emit font/x-framemaker}
+ if {[S 0 == <MML ]} {emit application/x-framemaker}
+ if {[S 0 == <BookFile ]} {emit application/x-framemaker}
+ if {[S 0 == <Maker ]} {emit application/x-framemaker}
+ switch -- [Nv i 0 &0377777777] 8782087 {emit application/x-executable-file} 8782088 {emit application/x-executable-file} 8782091 {emit application/x-executable-file} 8782028 {emit application/x-executable-file}
+ if {[S 7 == {\357\020\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0} ]} {emit application/core}
+ if {[S 0 == {GIMP\ Gradient} ]} {emit application/x-gimp-gradient}
+ if {[S 0 == {gimp\ xcf} ]} {emit application/x-gimp-image}
+ if {[S 20 == GPAT ]} {emit application/x-gimp-pattern}
+ if {[S 20 == GIMP ]} {emit application/x-gimp-brush}
+ if {[S 0 == {\336\22\4\225} ]} {emit application/x-locale}
+ if {[S 0 == {\225\4\22\336} ]} {emit application/x-locale}
+ if {[S 0 == {\000\001\000\000\000} ]} {emit font/ttf}
+ if {[S 0 == Bitmapfile ]} {emit image/unknown}
+ if {[S 0 == IMGfile ]} {emit {CIS image/unknown}}
+ if {[S 0 == msgcat01 ]} {emit application/x-locale}
+ if {[S 0 == HPHP48- ]} {emit {HP48 binary}}
+ if {[S 0 == %%HP: ]} {emit {HP48 text}}
+ if {[S 0 == 0xabcdef ]} {emit {AIX message catalog}}
+ if {[S 0 == <aiaff> ]} {emit archive}
+ if {[S 0 == FORM ]} {emit {IFF data}}
+ if {[S 0 == P1 ]} {emit image/x-portable-bitmap}
+ if {[S 0 == P2 ]} {emit image/x-portable-graymap}
+ if {[S 0 == P3 ]} {emit image/x-portable-pixmap}
+ if {[S 0 == P4 ]} {emit image/x-portable-bitmap}
+ if {[S 0 == P5 ]} {emit image/x-portable-graymap}
+ if {[S 0 == P6 ]} {emit image/x-portable-pixmap}
+ if {[S 0 == IIN1 ]} {emit image/tiff}
+ if {[S 0 == {MM\x00\x2a} ]} {emit image/tiff}
+ if {[S 0 == {II\x2a\x00} ]} {emit image/tiff}
+ if {[S 0 == {\x89PNG} ]} {emit image/x-png}
+ if {[S 1 == PNG ]} {emit image/x-png}
+ if {[S 0 == GIF8 ]} {emit image/gif}
+ if {[S 0 == {\361\0\100\273} ]} {emit image/x-cmu-raster}
+ if {[S 0 == id=ImageMagick ]} {emit {MIFF image data}}
+ if {[S 0 == {\#FIG} ]} {emit {FIG image text}}
+ if {[S 0 == ARF_BEGARF ]} {emit {PHIGS clear text archive}}
+ if {[S 0 == {@(\#)SunPHIGS} ]} {emit SunPHIGS}
+ if {[S 0 == GKSM ]} {emit {GKS Metafile}}
+ if {[S 0 == BEGMF ]} {emit {clear text Computer Graphics Metafile}}
+ if {[N S 0 == 0x20 &0xffe0]} {emit {binary Computer Graphics Metafile}}
+ if {[S 0 == yz ]} {emit {MGR bitmap, modern format, 8-bit aligned}}
+ if {[S 0 == zz ]} {emit {MGR bitmap, old format, 1-bit deep, 16-bit aligned}}
+ if {[S 0 == xz ]} {emit {MGR bitmap, old format, 1-bit deep, 32-bit aligned}}
+ if {[S 0 == yx ]} {emit {MGR bitmap, modern format, squeezed}}
+ if {[S 0 == {%bitmap\0} ]} {emit {FBM image data}}
+ if {[S 1 == {PC\ Research,\ Inc} ]} {emit {group 3 fax data}}
+ if {[S 0 == hsi1 ]} {emit image/x-jpeg-proprietary}
+ if {[S 0 == BM ]} {emit image/x-bmp}
+ if {[S 0 == IC ]} {emit image/x-ico}
+ if {[S 0 == PI ]} {emit {PC pointer image data}}
+ if {[S 0 == CI ]} {emit {PC color icon data}}
+ if {[S 0 == CP ]} {emit {PC color pointer image data}}
+ if {[S 0 == {/*\ XPM\ */} ]} {emit {X pixmap image text}}
+ if {[S 0 == {Imagefile\ version-} ]} {emit {iff image data}}
+ if {[S 0 == IT01 ]} {emit {FIT image data}}
+ if {[S 0 == IT02 ]} {emit {FIT image data}}
+ if {[S 2048 == PCD_IPI ]} {emit x/x-photo-cd-pack-file}
+ if {[S 0 == PCD_OPA ]} {emit x/x-photo-cd-overfiew-file}
+ if {[S 0 == {SIMPLE\ \ =} ]} {emit {FITS image data}}
+ if {[S 0 == {This\ is\ a\ BitMap\ file} ]} {emit {Lisp Machine bit-array-file}}
+ if {[S 0 == !! ]} {emit {Bennet Yee's \"face\" format}}
+ if {[S 1536 == {Visio\ (TM)\ Drawing} ]} {emit %s}
+ if {[S 0 == {\210OPS} ]} {emit {Interleaf saved data}}
+ if {[S 0 == <!OPS ]} {emit {Interleaf document text}}
+ if {[S 4 == pgscriptver ]} {emit {IslandWrite document}}
+ if {[S 13 == DrawFile ]} {emit {IslandDraw document}}
+ if {[N s 0 == 0x9600 &0xFFFC]} {emit {little endian ispell}}
+ if {[N S 0 == 0x9600 &0xFFFC]} {emit {big endian ispell}}
+ if {[S 0 == KarmaRHD ]} {emit {Version Karma Data Structure Version}}
+ if {[S 0 == lect ]} {emit {DEC SRC Virtual Paper Lectern file}}
+ if {[S 53 == yyprevious ]} {emit {C program text \(from lex\)}}
+ if {[S 21 == {generated\ by\ flex} ]} {emit {C program text \(from flex\)}}
+ if {[S 0 == {%\{} ]} {emit {lex description text}}
+ if {[S 0 == {\007\001\000} ]} {emit {Linux/i386 object file}}
+ if {[S 0 == {\01\03\020\04} ]} {emit {Linux-8086 impure executable}}
+ if {[S 0 == {\01\03\040\04} ]} {emit {Linux-8086 executable}}
+ if {[S 0 == {\243\206\001\0} ]} {emit {Linux-8086 object file}}
+ if {[S 0 == {\01\03\020\20} ]} {emit {Minix-386 impure executable}}
+ if {[S 0 == {\01\03\040\20} ]} {emit {Minix-386 executable}}
+ if {[S 0 == *nazgul* ]} {emit {Linux compiled message catalog}}
+ if {[N i 216 == 0x111 ]} {emit {Linux/i386 core file}}
+ if {[S 2 == LILO ]} {emit {Linux/i386 LILO boot/chain loader}}
+ if {[S 0 == 0.9 ]} {emit 300}
+ if {[S 4086 == SWAP-SPACE ]} {emit {Linux/i386 swap file}}
+ if {[S 514 == HdrS ]} {emit {Linux kernel}}
+ if {[S 0 == Begin3 ]} {emit {Linux Software Map entry text}}
+ if {[S 0 == {;;} ]} {emit {Lisp/Scheme program text}}
+ if {[S 0 == {\012(} ]} {emit {byte-compiled Emacs-Lisp program data}}
+ if {[S 0 == {;ELC\023\000\000\000} ]} {emit {byte-compiled Emacs-Lisp program data}}
+ if {[S 0 == {(SYSTEM::VERSION\040'} ]} {emit {CLISP byte-compiled Lisp program text}}
+ if {[S 11 == {must\ be\ converted\ with\ BinHex} ]} {emit {BinHex binary text}}
+ if {[S 0 == SIT! ]} {emit {StuffIt Archive \(data\)}}
+ if {[S 65 == SIT! ]} {emit {StuffIt Archive \(rsrc + data\)}}
+ if {[S 0 == SITD ]} {emit {StuffIt Deluxe \(data\)}}
+ if {[S 65 == SITD ]} {emit {StuffIt Deluxe \(rsrc + data\)}}
+ if {[S 0 == Seg ]} {emit {StuffIt Deluxe Segment \(data\)}}
+ if {[S 65 == Seg ]} {emit {StuffIt Deluxe Segment \(rsrc + data\)}}
+ if {[S 0 == APPL ]} {emit {Macintosh Application \(data\)}}
+ if {[S 65 == APPL ]} {emit {Macintosh Application \(rsrc + data\)}}
+ if {[S 0 == zsys ]} {emit {Macintosh System File \(data\)}}
+ if {[S 65 == zsys ]} {emit {Macintosh System File\(rsrc + data\)}}
+ if {[S 0 == FNDR ]} {emit {Macintosh Finder \(data\)}}
+ if {[S 65 == FNDR ]} {emit {Macintosh Finder\(rsrc + data\)}}
+ if {[S 0 == libr ]} {emit {Macintosh Library \(data\)}}
+ if {[S 65 == libr ]} {emit {Macintosh Library\(rsrc + data\)}}
+ if {[S 0 == shlb ]} {emit {Macintosh Shared Library \(data\)}}
+ if {[S 65 == shlb ]} {emit {Macintosh Shared Library\(rsrc + data\)}}
+ if {[S 0 == cdev ]} {emit {Macintosh Control Panel \(data\)}}
+ if {[S 65 == cdev ]} {emit {Macintosh Control Panel\(rsrc + data\)}}
+ if {[S 0 == INIT ]} {emit {Macintosh Extension \(data\)}}
+ if {[S 65 == INIT ]} {emit {Macintosh Extension\(rsrc + data\)}}
+ if {[S 0 == FFIL ]} {emit font/ttf}
+ if {[S 65 == FFIL ]} {emit font/ttf}
+ if {[S 0 == LWFN ]} {emit font/type1}
+ if {[S 65 == LWFN ]} {emit font/type1}
+ if {[S 0 == PACT ]} {emit {Macintosh Compact Pro Archive \(data\)}}
+ if {[S 65 == PACT ]} {emit {Macintosh Compact Pro Archive\(rsrc + data\)}}
+ if {[S 0 == ttro ]} {emit {Macintosh TeachText File \(data\)}}
+ if {[S 65 == ttro ]} {emit {Macintosh TeachText File\(rsrc + data\)}}
+ if {[S 0 == TEXT ]} {emit {Macintosh TeachText File \(data\)}}
+ if {[S 65 == TEXT ]} {emit {Macintosh TeachText File\(rsrc + data\)}}
+ if {[S 0 == PDF ]} {emit {Macintosh PDF File \(data\)}}
+ if {[S 65 == PDF ]} {emit {Macintosh PDF File\(rsrc + data\)}}
+ if {[S 0 == {\#\ Magic} ]} {emit {magic text file for file\(1\) cmd}}
+ if {[S 0 == Relay-Version: ]} {emit {old news text}}
+ if {[S 0 == {\#!\ rnews} ]} {emit {batched news text}}
+ if {[S 0 == {N\#!\ rnews} ]} {emit {mailed, batched news text}}
+ if {[S 0 == {Forward\ to} ]} {emit {mail forwarding text}}
+ if {[S 0 == {Pipe\ to} ]} {emit {mail piping text}}
+ if {[S 0 == Return-Path: ]} {emit message/rfc822}
+ if {[S 0 == Path: ]} {emit message/news}
+ if {[S 0 == Xref: ]} {emit message/news}
+ if {[S 0 == From: ]} {emit message/rfc822}
+ if {[S 0 == Article ]} {emit message/news}
+ if {[S 0 == BABYL ]} {emit message/x-gnu-rmail}
+ if {[S 0 == Received: ]} {emit message/rfc822}
+ if {[S 0 == MIME-Version: ]} {emit {MIME entity text}}
+ if {[S 0 == {Content-Type:\ } ]} {emit 355}
+ if {[S 0 == Content-Type: ]} {emit 356}
+ if {[S 0 == {\311\304} ]} {emit {ID tags data}}
+ if {[S 0 == {\001\001\001\001} ]} {emit {MMDF mailbox}}
+ if {[S 4 == Research, ]} {emit Digifax-G3-File}
+ if {[S 0 == RMD1 ]} {emit {raw modem data}}
+ if {[S 0 == {PVF1\n} ]} {emit {portable voice format}}
+ if {[S 0 == {PVF2\n} ]} {emit {portable voice format}}
+ if {[S 0 == S0 ]} {emit {Motorola S-Record; binary data in text format}}
+ if {[S 0 == {@echo\ off} ]} {emit {MS-DOS batch file text}}
+ if {[S 128 == {PE\0\0} ]} {emit {MS Windows PE}}
+ if {[S 0 == MZ ]} {emit application/x-ms-dos-executable}
+ if {[S 0 == LZ ]} {emit {MS-DOS executable \(built-in\)}}
+ if {[S 0 == regf ]} {emit {Windows NT Registry file}}
+ if {[S 2080 == {Microsoft\ Word\ 6.0\ Document} ]} {emit text/vnd.ms-word}
+ if {[S 2080 == {Documento\ Microsoft\ Word\ 6} ]} {emit text/vnd.ms-word}
+ if {[S 2112 == MSWordDoc ]} {emit text/vnd.ms-word}
+ if {[S 0 == PO^Q` ]} {emit text/vnd.ms-word}
+ if {[S 2080 == {Microsoft\ Excel\ 5.0\ Worksheet} ]} {emit application/vnd.ms-excel}
+ if {[S 2114 == Biff5 ]} {emit application/vnd.ms-excel}
+ if {[S 1 == WPC ]} {emit text/vnd.wordperfect}
+ switch -- [Nv I 0 &0377777777] 8782091 {emit {NetBSD/i386 demand paged}} 8782088 {emit {NetBSD/i386 pure}} 8782087 {emit NetBSD/i386} 8782151 {emit {NetBSD/i386 core}} 8847627 {emit {NetBSD/m68k demand paged}} 8847624 {emit {NetBSD/m68k pure}} 8847623 {emit NetBSD/m68k} 8847687 {emit {NetBSD/m68k core}} 8913163 {emit {NetBSD/m68k4k demand paged}} 8913160 {emit {NetBSD/m68k4k pure}} 8913159 {emit NetBSD/m68k4k} 8913223 {emit {NetBSD/m68k4k core}} 8978699 {emit {NetBSD/ns32532 demand paged}} 8978696 {emit {NetBSD/ns32532 pure}} 8978695 {emit NetBSD/ns32532} 8978759 {emit {NetBSD/ns32532 core}} 9044235 {emit {NetBSD/sparc demand paged}} 9044232 {emit {NetBSD/sparc pure}} 9044231 {emit NetBSD/sparc} 9044295 {emit {NetBSD/sparc core}} 9109771 {emit {NetBSD/pmax demand paged}} 9109768 {emit {NetBSD/pmax pure}} 9109767 {emit NetBSD/pmax} 9109831 {emit {NetBSD/pmax core}} 9175307 {emit {NetBSD/vax demand paged}} 9175304 {emit {NetBSD/vax pure}} 9175303 {emit NetBSD/vax} 9175367 {emit {NetBSD/vax core}} 9240903 {emit {NetBSD/alpha core}} 9306379 {emit {NetBSD/mips demand paged}} 9306376 {emit {NetBSD/mips pure}} 9306375 {emit NetBSD/mips} 9306439 {emit {NetBSD/mips core}} 9371915 {emit {NetBSD/arm32 demand paged}} 9371912 {emit {NetBSD/arm32 pure}} 9371911 {emit NetBSD/arm32} 9371975 {emit {NetBSD/arm32 core}}
+ if {[S 0 == StartFontMetrics ]} {emit font/x-sunos-news}
+ if {[S 0 == StartFont ]} {emit font/x-sunos-news}
+ switch -- [Nv I 8 ] 326773573 {emit font/x-sunos-news} 326773576 {emit font/x-sunos-news}
+ if {[S 0 == Octave-1-L ]} {emit {Octave binary data \(little endian\)}}
+ if {[S 0 == Octave-1-B ]} {emit {Octave binary data \(big endian\)}}
+ if {[S 0 == {\177OLF} ]} {emit OLF}
+ if {[S 0 == %PDF- ]} {emit {PDF document}}
+ if {[S 0 == {-----BEGIN\040PGP} ]} {emit {PGP armored data}}
+ if {[S 0 == {\#\ PaCkAgE\ DaTaStReAm} ]} {emit {pkg Datastream \(SVR4\)}}
+ if {[S 0 == %! ]} {emit application/postscript}
+ if {[S 0 == {\004%!} ]} {emit application/postscript}
+ if {[S 0 == *PPD-Adobe: ]} {emit {PPD file}}
+ if {[S 0 == {\033%-12345X@PJL} ]} {emit {HP Printer Job Language data}}
+ if {[S 0 == {\033%-12345X@PJL} ]} {emit {HP Printer Job Language data}}
+ if {[S 0 == {\033E\033} ]} {emit image/x-pcl-hp}
+ if {[S 0 == @document( ]} {emit {Imagen printer}}
+ if {[S 0 == Rast ]} {emit {RST-format raster font data}}
+ if {[N I 0 == 0x56000000 &0xff00ffff]} {emit {ps database}}
+ if {[S 0 == {\{\\rtf} ]} {emit {Rich Text Format data,}}
+ if {[S 38 == Spreadsheet ]} {emit {sc spreadsheet file}}
+ if {[S 8 == {\001s\ } ]} {emit {SCCS archive data}}
+ switch -- [Nv c 0 ] 38 {emit {Sendmail frozen configuration}} -128 {emit {8086 relocatable \(Microsoft\)}}
+ if {[S 0 == kbd!map ]} {emit {kbd map file}}
+ if {[S 0 == {\x43\x72\x73\x68\x44\x75\x6d\x70} ]} {emit {IRIX vmcore dump of}}
+ if {[S 0 == SGIAUDIT ]} {emit {SGI Audit file}}
+ if {[S 0 == WNGZWZSC ]} {emit {Wingz compiled script}}
+ if {[S 0 == WNGZWZSS ]} {emit {Wingz spreadsheet}}
+ if {[S 0 == WNGZWZHP ]} {emit {Wingz help file}}
+ if {[S 0 == {\\#Inventor} ]} {emit {V IRIS Inventor 1.0 file}}
+ if {[S 0 == {\\#Inventor} ]} {emit {V2 Open Inventor 2.0 file}}
+ if {[S 0 == {glfHeadMagic();} ]} {emit GLF_TEXT}
+ switch -- [Nv I 4 ] 1090584576 {emit GLF_BINARY_LSB_FIRST} 321 {emit GLF_BINARY_MSB_FIRST}
+ if {[S 0 == {<!DOCTYPE\ HTML} ]} {emit text/html}
+ if {[S 0 == {<!doctype\ html} ]} {emit text/html}
+ if {[S 0 == <HEAD ]} {emit text/html}
+ if {[S 0 == <head ]} {emit text/html}
+ if {[S 0 == <TITLE ]} {emit text/html}
+ if {[S 0 == <title ]} {emit text/html}
+ if {[S 0 == <html ]} {emit text/html}
+ if {[S 0 == <HTML ]} {emit text/html}
+ if {[S 0 == <!DOCTYPE ]} {emit {exported SGML document text}}
+ if {[S 0 == <!doctype ]} {emit {exported SGML document text}}
+ if {[S 0 == <!SUBDOC ]} {emit {exported SGML subdocument text}}
+ if {[S 0 == <!subdoc ]} {emit {exported SGML subdocument text}}
+ if {[S 0 == <!-- ]} {emit {exported SGML document text}}
+ if {[S 0 == RTSS ]} {emit {NetMon capture file}}
+ if {[S 0 == {TRSNIFF\ data\ \ \ \ \032} ]} {emit {Sniffer capture file}}
+ if {[S 0 == {XCP\0} ]} {emit {NetXRay capture file}}
+ if {[S 0 == {<!SQ\ DTD>} ]} {emit {Compiled SGML rules file}}
+ if {[S 0 == {<!SQ\ A/E>} ]} {emit {A/E SGML Document binary}}
+ if {[S 0 == {<!SQ\ STS>} ]} {emit {A/E SGML binary styles file}}
+ if {[S 0 == {SQ\ BITMAP1} ]} {emit {SoftQuad Raster Format text}}
+ if {[S 0 == {X\ } ]} {emit {SoftQuad troff Context intermediate}}
+ switch -- [Nv I 0 &077777777] 196875 {emit {sparc demand paged}} 196872 {emit {sparc pure}} 196871 {emit sparc} 131339 {emit {mc68020 demand paged}} 131336 {emit {mc68020 pure}} 131335 {emit mc68020} 65803 {emit {mc68010 demand paged}} 65800 {emit {mc68010 pure}} 65799 {emit mc68010}
+ if {[S 0 == {\#SUNPC_CONFIG} ]} {emit {SunPC 4.0 Properties Values}}
+ if {[S 0 == snoop ]} {emit {Snoop capture file}}
+ if {[S 36 == acsp ]} {emit {Kodak Color Management System, ICC Profile}}
+ if {[S 0 == {\#!teapot\012xdr} ]} {emit {teapot work sheet \(XDR format\)}}
+ if {[S 0 == {\032\001} ]} {emit {Compiled terminfo entry}}
+ if {[S 0 == {\367\002} ]} {emit {TeX DVI file}}
+ if {[S 0 == {\367\203} ]} {emit font/x-tex}
+ if {[S 0 == {\367\131} ]} {emit font/x-tex}
+ if {[S 0 == {\367\312} ]} {emit font/x-tex}
+ if {[S 0 == {This\ is\ TeX,} ]} {emit {TeX transcript text}}
+ if {[S 0 == {This\ is\ METAFONT,} ]} {emit {METAFONT transcript text}}
+ if {[S 2 == {\000\021} ]} {emit font/x-tex-tfm}
+ if {[S 2 == {\000\022} ]} {emit font/x-tex-tfm}
+ if {[S 0 == {\\input\ texinfo} ]} {emit {Texinfo source text}}
+ if {[S 0 == {This\ is\ Info\ file} ]} {emit {GNU Info text}}
+ if {[S 0 == {\\input} ]} {emit {TeX document text}}
+ if {[S 0 == {\\section} ]} {emit {LaTeX document text}}
+ if {[S 0 == {\\setlength} ]} {emit {LaTeX document text}}
+ if {[S 0 == {\\documentstyle} ]} {emit {LaTeX document text}}
+ if {[S 0 == {\\chapter} ]} {emit {LaTeX document text}}
+ if {[S 0 == {\\documentclass} ]} {emit {LaTeX 2e document text}}
+ if {[S 0 == {\\relax} ]} {emit {LaTeX auxiliary file}}
+ if {[S 0 == {\\contentsline} ]} {emit {LaTeX table of contents}}
+ if {[S 0 == {\\indexentry} ]} {emit {LaTeX raw index file}}
+ if {[S 0 == {\\begin\{theindex\}} ]} {emit {LaTeX sorted index}}
+ if {[S 0 == {\\glossaryentry} ]} {emit {LaTeX raw glossary}}
+ if {[S 0 == {\\begin\{theglossary\}} ]} {emit {LaTeX sorted glossary}}
+ if {[S 0 == {This\ is\ makeindex} ]} {emit {Makeindex log file}}
+ if {[S 0 == **TI82** ]} {emit {TI-82 Graphing Calculator}}
+ if {[S 0 == **TI83** ]} {emit {TI-83 Graphing Calculator}}
+ if {[S 0 == **TI85** ]} {emit {TI-85 Graphing Calculator}}
+ if {[S 0 == **TI92** ]} {emit {TI-92 Graphing Calculator}}
+ if {[S 0 == **TI80** ]} {emit {TI-80 Graphing Calculator File.}}
+ if {[S 0 == **TI81** ]} {emit {TI-81 Graphing Calculator File.}}
+ if {[S 0 == TZif ]} {emit {timezone data}}
+ if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\1\0} ]} {emit {old timezone data}}
+ if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\2\0} ]} {emit {old timezone data}}
+ if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\3\0} ]} {emit {old timezone data}}
+ if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\4\0} ]} {emit {old timezone data}}
+ if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\5\0} ]} {emit {old timezone data}}
+ if {[S 0 == {\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\6\0} ]} {emit {old timezone data}}
+ if {[S 0 == {.\\\"} ]} {emit {troff or preprocessor input text}}
+ if {[S 0 == {'\\\"} ]} {emit {troff or preprocessor input text}}
+ if {[S 0 == {'.\\\"} ]} {emit {troff or preprocessor input text}}
+ if {[S 0 == {\\\"} ]} {emit {troff or preprocessor input text}}
+ if {[S 0 == {x\ T} ]} {emit {ditroff text}}
+ if {[S 0 == {\100\357} ]} {emit {very old \(C/A/T\) troff output data}}
+ if {[S 0 == Interpress/Xerox ]} {emit {Xerox InterPress data}}
+ if {[S 0 == {begin\040} ]} {emit {uuencoded or xxencoded text}}
+ if {[S 0 == {xbtoa\ Begin} ]} {emit {btoa'd text}}
+ if {[S 0 == {$\012ship} ]} {emit {ship'd binary text}}
+ if {[S 0 == {Decode\ the\ following\ with\ bdeco} ]} {emit {bencoded News text}}
+ if {[S 11 == {must\ be\ converted\ with\ BinHex} ]} {emit {BinHex binary text}}
+ if {[N S 6 == 0x107 ]} {emit {unicos \(cray\) executable}}
+ if {[S 596 == {\130\337\377\377} ]} {emit {Ultrix core file}}
+ if {[S 0 == Joy!peffpwpc ]} {emit {header for PowerPC PEF executable}}
+ if {[S 0 == LBLSIZE= ]} {emit {VICAR image data}}
+ if {[S 43 == SFDU_LABEL ]} {emit {VICAR label file}}
+ if {[S 0 == {\xb0\0\x30\0} ]} {emit {VMS VAX executable}}
+ if {[S 1 == WPC ]} {emit {\(Corel/WP\)}}
+ if {[S 0 == core ]} {emit {core file \(Xenix\)}}
+ if {[S 0 == {ZyXEL\002} ]} {emit {ZyXEL voice data}}
+
+ result
+
+ return {}
+}
+
+## -- ** END GENERATED CODE ** --
+## -- Do not edit before this line !
+##
+
+# ### ### ### ######### ######### #########
+## Ready for use.
+# EOF
diff --git a/tcllib/modules/fumagic/mimetypes.test b/tcllib/modules/fumagic/mimetypes.test
new file mode 100644
index 0000000..a43eb55
--- /dev/null
+++ b/tcllib/modules/fumagic/mimetypes.test
@@ -0,0 +1,185 @@
+# -*- tcl -*-
+#
+# Testing "fumagic" (FileUtil Magic). Mimetype recognizer.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2005-2006 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: mimetypes.test,v 1.10 2006/10/09 21:41:40 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 1.0
+
+catch {namespace delete ::fileutil::magic}
+support {
+ useLocalFile fumagic.testsupport
+ useLocal rtcore.tcl fileutil::magic::rt
+}
+testing {
+ useLocal mimetypes.tcl fileutil::magic::mimetype
+}
+
+# -------------------------------------------------------------------------
+# Now the package specific tests....
+
+set path [makeFile {} bogus]
+removeFile bogus
+
+test fumagic.mimetype-1.1 {test file non-existance} {
+ set res [catch {fileutil::magic::mimetype $path} msg]
+ list $res $msg
+} [list 1 "file not found: \"$path\""]
+
+test fumagic.mimetype-1.2 {test file directory} {
+ set f [makeDirectory fileTypeTest]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ regsub {file[0-9]+} $msg {fileXXX} msg
+ removeDirectory fileTypeTest
+ list $res $msg
+} {0 application/x-directory}
+
+test fumagic.mimetype-1.3 {test file empty} {
+ set f [makeEmptyFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removeEmptyFile
+ list $res $msg
+} {0 {}}
+
+test fumagic.mimetype-1.4 {test simple binary} {
+ set f [makeBinFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removeBinFile
+ list $res $msg
+} {0 {}}
+
+test fumagic.mimetype-1.5 {test elf executable} {
+ set f [makeElfFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removeElfFile
+ list $res $msg
+} {0 application/x-executable-file}
+
+test fumagic.mimetype-1.6 {test simple text} {
+ set f [makeTextFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removeTextFile
+ list $res $msg
+} {0 {}}
+
+test fumagic.mimetype-1.7 {test script file} {
+ set f [makeScriptFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removeScriptFile
+ list $res $msg
+} {0 text/script}
+
+test fumagic.mimetype-1.8 {test html text} {
+ set f [makeHtmlFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removeHtmlFile
+ list $res $msg
+} {0 text/html}
+
+test fumagic.mimetype-1.9 {test xml text} {knownBug} {
+ set f [makeXmlFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removeXmlFile
+ list $res $msg
+} {0 text/xml}
+
+test fumagic.mimetype-1.10 {test xml with dtd text} {knownBug} {
+ set f [makeXmlDTDFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removeXmlDTDFile
+ list $res $msg
+} {0 text/xml}
+
+test fumagic.mimetype-1.11 {test PGP message} {knownBug} {
+ set f [makePgpFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removePgpFile
+ list $res $msg
+} {0 {PGP armored data}} ; # Result is not a mime type.
+
+test fumagic.mimetype-1.12 {test binary graphic jpeg} {
+ set f [makeJpegFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removeJpegFile
+ list $res $msg
+} {0 image/jpeg}
+
+test fumagic.mimetype-1.13 {test binary graphic gif} {
+ set f [makeGifFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removeGifFile
+ list $res $msg
+} {0 image/gif}
+
+test fumagic.mimetype-1.14 {test binary graphic png} {
+ set f [makePngFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removePngFile
+ list $res $msg
+} {0 image/x-png}
+
+test fumagic.mimetype-1.15 {test binary graphic tiff} {
+ set f [makeTiffFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removeTiffFile
+ list $res $msg
+} {0 image/tiff}
+
+test fumagic.mimetype-1.16 {test binary pdf} {knownBug} {
+ set f [makePdfFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removePdfFile
+ list $res $msg
+} {0 {PDF document}} ; # Result is not a mime type
+
+test fumagic.mimetype-1.17 {test text ps} {
+ set f [makePSFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removePSFile
+ list $res $msg
+} {0 application/postscript}
+
+test fumagic.mimetype-1.18 {test text eps} {
+ set f [makeEPSFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removeEPSFile
+ list $res $msg
+} {0 application/postscript}
+
+test fumagic.mimetype-1.19 {test binary gravity_wave_data_frame} {
+ set f [makeIgwdFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removeIgwdFile
+ list $res $msg
+} {0 {}}
+
+test fumagic.mimetype-1.20 {test binary compressed bzip} {
+ set f [makeBzipFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removeBzipFile
+ list $res $msg
+} {0 {application/x-bzip2 application/x-bzip}}
+
+test fumagic.mimetype-1.21 {test binary compressed gzip} {
+ set f [makeGzipFile]
+ set res [catch {fileutil::magic::mimetype $f} msg]
+ removeGzipFile
+ list $res $msg
+} {0 application/x-gzip}
+
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/fumagic/pkgIndex.tcl b/tcllib/modules/fumagic/pkgIndex.tcl
new file mode 100644
index 0000000..7fa87fe
--- /dev/null
+++ b/tcllib/modules/fumagic/pkgIndex.tcl
@@ -0,0 +1,15 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+
+# Recognizers
+package ifneeded fileutil::magic::filetype 1.0.2 [list source [file join $dir filetypes.tcl]]
+package ifneeded fileutil::magic::mimetype 1.0.2 [list source [file join $dir mimetypes.tcl]]
+
+# Runtime
+package ifneeded fileutil::magic::rt 1.0 [list source [file join $dir rtcore.tcl]]
+
+# Compiler packages
+package ifneeded fileutil::magic::cgen 1.0 [list source [file join $dir cgen.tcl]]
+package ifneeded fileutil::magic::cfront 1.0 [list source [file join $dir cfront.tcl]]
+
+
+
diff --git a/tcllib/modules/fumagic/regenerate.sh b/tcllib/modules/fumagic/regenerate.sh
new file mode 100644
index 0000000..c69a1a6
--- /dev/null
+++ b/tcllib/modules/fumagic/regenerate.sh
@@ -0,0 +1,13 @@
+#!/bin/sh
+
+# Point this to an unpacked source distribution of file(1) to
+# regenerate the recognizers.
+
+filesrc="$1"
+
+mime="${filesrc}/magic/magic.mime"
+type="${filesrc}/magic/Magdir"
+
+`dirname $0`/tmc -merge mimetypes.tcl '::fileutil::magic::mimetype::run' "${mime}"
+`dirname $0`/tmc -merge filetypes.tcl '::fileutil::magic::filetype::run' "${type}"
+exit 0
diff --git a/tcllib/modules/fumagic/rtcore.man b/tcllib/modules/fumagic/rtcore.man
new file mode 100644
index 0000000..3fcfe38
--- /dev/null
+++ b/tcllib/modules/fumagic/rtcore.man
@@ -0,0 +1,238 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin fileutil::magic::rt n 1.0]
+[see_also file(1)]
+[see_also fileutil]
+[see_also magic(5)]
+[keywords {file recognition}]
+[keywords {file type}]
+[keywords {file utilities}]
+[keywords mime]
+[keywords type]
+[moddesc {file utilities}]
+[titledesc {Runtime core for file type recognition engines written in pure Tcl}]
+[category {Programming tools}]
+[require Tcl 8.4]
+[require fileutil::magic::rt [opt 1.0]]
+[description]
+[para]
+
+This package provides the runtime core for file type recognition
+engines written in pure Tcl and is thus used by all other packages in
+this module, i.e. the two frontend packages
+[package fileutil::magic::mimetypes] and
+
+[package fileutil::magic::filetypes], and the two engine compiler
+packages [package fileutil::magic::cgen] and
+[package fileutil::magic::cfront].
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::fileutil::magic::rt::open] [arg filename]]
+
+This command initializes the runtime and prepares the file
+[arg filename] for use by the system.
+
+This command has to be invoked first, before any other command of this
+package.
+
+[para]
+
+The command returns the channel handle of the opened file as its
+result.
+
+[call [cmd ::fileutil::magic::rt::close]]
+
+This command closes the last file opened via
+[cmd ::fileutil::magic::rt::open] and shuts the runtime down.
+
+This command has to be invoked last, after the file has been dealt
+with completely.
+
+Afterward another invokation of [cmd ::fileutil::magic::rt::open] is
+required to process another file.
+
+[para]
+
+This command returns the empty string as its result.
+
+[call [cmd ::fileutil::magic::rt::file_start] [arg name]]
+
+This command marks the start of a magic file when debugging. It
+returns the empty string as its result.
+
+[call [cmd ::fileutil::magic::rt::result] [opt [arg msg]]]
+
+This command returns the current result and stops processing.
+
+[para]
+
+If [arg msg] is specified its text is added to the result before it is
+returned. See [cmd ::fileutil::magic::rt::emit] for the allowed
+special character sequences.
+
+[call [cmd ::fileutil::magic::rt::resultv] [opt [arg msg]]]
+
+This command returns the current result.
+
+In contrast to [cmd ::fileutil::magic::rt::result] processing
+continues.
+
+[para]
+
+If [arg msg] is specified its text is added to the result before it is
+returned. See [cmd ::fileutil::magic::rt::emit] for the allowed
+special character sequences.
+
+[call [cmd ::fileutil::magic::rt::emit] [arg msg]]
+
+This command adds the text [arg msg] to the result buffer. The
+message may contain the following special character sequences. They
+will be replaced with buffered values before the message is added to
+the result. The command returns the empty string as its result.
+
+[list_begin definitions]
+[def [const \\b]] This sequence is removed
+[def [const %s]] Replaced with the last buffered string value.
+[def [const %ld]] Replaced with the last buffered numeric value.
+[def [const %d]] See above.
+[list_end]
+
+[comment [call [cmd ::fileutil::magic::rt::offset] [arg where]]]
+[comment {
+ Handling of complex offsets. Currently not implemented.
+ Always returns zero.
+}]
+
+[call [cmd ::fileutil::magic::rt::Nv] [arg type] [arg offset] [opt [arg qual]]]
+
+This command fetches the numeric value with [arg type] from the
+absolute location [arg offset] and returns it as its result. The
+fetched value is further stored in the numeric buffer.
+
+[para]
+
+If [arg qual] is specified it is considered to be a mask and applied
+to the fetched value before it is stored and returned. It has to have
+the form of a partial Tcl bit-wise expression, i.e.
+
+[example {
+ & number
+}]
+
+For example:
+
+[example {
+ Nv lelong 0 &0x8080ffff
+}]
+
+For the possible types see section [sectref {NUMERIC TYPES}].
+
+[call [cmd ::fileutil::magic::rt::N] [arg type] [arg offset] [arg comp] [arg val] [opt [arg qual]]]
+
+This command behaves mostly like [cmd ::fileutil::magic::rt::Nv],
+except that it compares the fetched and masked value against [arg val]
+as specified with [arg comp] and returns the result of that
+comparison.
+
+[para]
+
+The argument [arg comp] has to contain one of Tcl's comparison
+operators, and the comparison made will be
+
+[example {
+ <val> <comp> <fetched-and-masked-value>
+}]
+
+[para]
+
+The special comparison operator [const x] signals that no comparison
+should be done, or, in other words, that the fetched value will always
+match [arg val].
+
+[call [cmd ::fileutil::magic::rt::Nvx] [arg atlevel] [arg type] [arg offset] [opt [arg qual]]]
+
+This command behaves like [cmd ::fileutil::magic::rt::Nv], except that
+it additionally remembers the location in the file after the fetch in
+the calling context, for the level [arg atlevel], for later use by
+[cmd ::fileutil::magic::rt::R].
+
+[call [cmd ::fileutil::magic::rt::Nx] [arg atlevel] [arg type] [arg offset] [arg comp] [arg val] [opt [arg qual]]]
+
+This command behaves like [cmd ::fileutil::magic::rt::N], except that
+it additionally remembers the location in the file after the fetch in
+the calling context, for the level [arg atlevel], for later use by
+[cmd ::fileutil::magic::rt::R].
+
+[call [cmd ::fileutil::magic::rt::S] [arg offset] [arg comp] [arg val] [opt [arg qual]]]
+
+This command behaves like [cmd ::fileutil::magic::rt::N], except that
+it fetches and compares strings, not numeric data. The fetched value
+is also stored in the internal string buffer instead of the numeric
+buffer.
+
+[call [cmd ::fileutil::magic::rt::Sx] [arg atlevel] [arg offset] [arg comp] [arg val] [opt [arg qual]]]
+
+This command behaves like [cmd ::fileutil::magic::rt::S], except that
+it additionally remembers the location in the file after the fetch in
+the calling context, for the level [arg atlevel], for later use by
+[cmd ::fileutil::magic::rt::R].
+
+[call [cmd ::fileutil::magic::rt::L] [arg newlevel]]
+
+This command sets the current level in the calling context to
+[arg newlevel]. The command returns the empty string as its result.
+
+[call [cmd ::fileutil::magic::rt::I] [arg base] [arg type] [arg delta]]
+
+This command handles base locations specified indirectly through the
+contents of the inspected file. It returns the sum of [arg delta] and
+the value of numeric [arg type] fetched from the absolute location
+[arg base].
+
+[para]
+
+For the possible types see section [sectref {NUMERIC TYPES}].
+
+[call [cmd ::fileutil::magic::rt::R] [arg offset]]
+
+This command handles base locations specified relative to the end of
+the last field one level above.
+
+[para]
+
+In other words, the command computes an absolute location in the file
+based on the relative [arg offset] and returns it as its result. The
+base the offset is added to is the last location remembered for the
+level in the calling context.
+
+[list_end]
+
+[section {NUMERIC TYPES}]
+
+[list_begin definitions]
+[def [const byte]] 8-bit integer
+[def [const short]] 16-bit integer, stored in native endianess
+[def [const beshort]] see above, stored in big endian
+[def [const leshort]] see above, stored in small/little endian
+[def [const long]] 32-bit integer, stored in native endianess
+[def [const belong]] see above, stored in big endian
+[def [const lelong]] see above, stored in small/little endian
+[list_end]
+
+All of the types above exit in an unsigned form as well. The type
+names are the same, with the character "u" added as prefix.
+
+[list_begin definitions]
+[def [const date]] 32-bit integer timestamp, stored in native endianess
+[def [const bedate]] see above, stored in big endian
+[def [const ledate]] see above, stored in small/little endian
+[def [const ldate]] 32-bit integer timestamp, stored in native endianess
+[def [const beldate]] see above, stored in big endian
+[def [const leldate]] see above, stored in small/little endian
+[list_end]
+
+[vset CATEGORY {fileutil :: magic}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/fumagic/rtcore.tcl b/tcllib/modules/fumagic/rtcore.tcl
new file mode 100644
index 0000000..e87efb3
--- /dev/null
+++ b/tcllib/modules/fumagic/rtcore.tcl
@@ -0,0 +1,500 @@
+# rtcore.tcl --
+#
+# Runtime core for file type recognition engines written in pure Tcl.
+#
+# Copyright (c) 2004-2005 Colin McCormack <coldstore@users.sourceforge.net>
+# Copyright (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: rtcore.tcl,v 1.5 2005/09/28 04:51:19 andreas_kupries Exp $
+
+#####
+#
+# "mime type recognition in pure tcl"
+# http://wiki.tcl.tk/12526
+#
+# Tcl code harvested on: 10 Feb 2005, 04:06 GMT
+# Wiki page last updated: ???
+#
+#####
+
+# TODO - Required Functionality:
+
+# implement full offset language
+# implement pstring (pascal string, blerk)
+# implement regex form (blerk!)
+# implement string qualifiers
+
+# ### ### ### ######### ######### #########
+## Requirements
+
+package require Tcl 8.4
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+namespace eval ::fileutil::magic::rt {
+ # Configuration flag. (De)activate debugging output.
+ # This is done during initialization.
+ # Changes at runtime have no effect.
+
+ variable debug 0
+
+ # Runtime state.
+
+ variable fd {} ; # Channel to file under scrutiny
+ variable strbuf {} ; # Input cache [*].
+ variable cache ; # Cache of fetched and decoded numeric
+ array set cache {} ; # values.
+ variable result {} ; # Accumulated recognition result.
+ variable string {} ; # Last recognized string | For substitution
+ variable numeric -9999 ; # Last recognized number | into the message
+
+ variable last ; # Behind last fetch locations,
+ array set last {} ; # per nesting level.
+
+ # [*] The vast majority of magic strings are in the first 4k of the file.
+
+ # Export APIs (full public, recognizer public)
+ namespace export open close file_start result
+ namespace export emit offset Nv N S Nvx Nx Sx L R I
+}
+
+# ### ### ### ######### ######### #########
+## Public API, general use.
+
+# open the file to be scanned
+proc ::fileutil::magic::rt::open {file} {
+ variable result {}
+ variable string {}
+ variable numeric -9999
+ variable strbuf
+ variable fd
+ variable cache
+
+ set fd [::open $file]
+ ::fconfigure $fd -translation binary
+
+ # fill the string cache
+ set strbuf [::read $fd 4096]
+
+ # clear the fetch cache
+ catch {unset cache}
+ array set cache {}
+
+ return $fd
+}
+
+proc ::fileutil::magic::rt::close {} {
+ variable fd
+ ::close $fd
+ return
+}
+
+# mark the start of a magic file in debugging
+proc ::fileutil::magic::rt::file_start {name} {
+ ::fileutil::magic::rt::Debug {puts stderr "File: $name"}
+}
+
+# return the emitted result
+proc ::fileutil::magic::rt::result {{msg ""}} {
+ variable result
+ if {$msg ne ""} {emit $msg}
+ return -code return $result
+}
+
+proc ::fileutil::magic::rt::resultv {{msg ""}} {
+ variable result
+ if {$msg ne ""} {emit $msg}
+ return $result
+}
+
+# ### ### ### ######### ######### #########
+## Public API, for use by a recognizer.
+
+# emit a message
+proc ::fileutil::magic::rt::emit {msg} {
+ variable string
+ variable numeric
+ variable result
+
+ set map [list \
+ \\b "" \
+ %s $string \
+ %ld $numeric \
+ %d $numeric \
+ ]
+
+ lappend result [::string map $map $msg]
+ return
+}
+
+# handle complex offsets - TODO
+proc ::fileutil::magic::rt::offset {where} {
+ ::fileutil::magic::rt::Debug {puts stderr "OFFSET: $where"}
+ return 0
+}
+
+proc ::fileutil::magic::rt::Nv {type offset {qual ""}} {
+ variable typemap
+ variable numeric
+
+ # unpack the type characteristics
+ foreach {size scan} $typemap($type) break
+
+ # fetch the numeric field from the file
+ set numeric [Fetch $offset $size $scan]
+
+ if {$qual ne ""} {
+ # there's a mask to be applied
+ set numeric [expr $numeric $qual]
+ }
+
+ ::fileutil::magic::rt::Debug {puts stderr "NV $type $offset $qual: $numeric"}
+ return $numeric
+}
+
+# Numeric - get bytes of $type at $offset and $compare to $val
+# qual might be a mask
+proc ::fileutil::magic::rt::N {type offset comp val {qual ""}} {
+ variable typemap
+ variable numeric
+
+ # unpack the type characteristics
+ foreach {size scan} $typemap($type) break
+
+ # fetch the numeric field
+ set numeric [Fetch $offset $size $scan]
+
+ # Would moving this before the fetch an optimisation ? The
+ # tradeoff is that we give up filling the cache, and it is unclear
+ # how often that value would be used. -- Profile!
+ if {$comp eq "x"} {
+ # anything matches - don't care
+ return 1
+ }
+
+ # get value in binary form, then back to numeric
+ # this avoids problems with sign, as both values are
+ # [binary scan]-converted identically
+ binary scan [binary format $scan $val] $scan val
+
+ if {$qual ne ""} {
+ # there's a mask to be applied
+ set numeric [expr $numeric $qual]
+ }
+
+ # perform comparison
+ set c [expr $val $comp $numeric]
+
+ ::fileutil::magic::rt::Debug {puts stderr "numeric $type: $val $comp $numeric / $qual - $c"}
+ return $c
+}
+
+proc ::fileutil::magic::rt::S {offset comp val {qual ""}} {
+ variable fd
+ variable string
+
+ # convert any backslashes
+ set val [subst -nocommands -novariables $val]
+
+ if {$comp eq "x"} {
+ # match anything - don't care, just get the value
+ set string ""
+
+ # Query: Can we use GetString here ?
+ # Or at least the strbuf cache ?
+
+ # move to the offset
+ ::seek $fd $offset
+ while {
+ ([::string length $string] < 100) &&
+ [::string is print [set c [::read $fd 1]]]
+ } {
+ if {[::string is space $c]} {
+ break
+ }
+ append string $c
+ }
+
+ return 1
+ }
+
+ # get the string and compare it
+ set string [GetString $offset [::string length $val]]
+ set cmp [::string compare $val $string]
+ set c [expr $cmp $comp 0]
+
+ ::fileutil::magic::rt::Debug {
+ puts "String '$val' $comp '$string' - $c"
+ if {$c} {
+ puts "offset $offset - $string"
+ }
+ }
+ return $c
+}
+
+proc ::fileutil::magic::rt::Nvx {atlevel type offset {qual ""}} {
+ variable typemap
+ variable numeric
+ variable last
+
+ upvar 1 level l
+ set l $atlevel
+
+ # unpack the type characteristics
+ foreach {size scan} $typemap($type) break
+
+ # fetch the numeric field from the file
+ set numeric [Fetch $offset $size $scan]
+
+ set last($atlevel) [expr {$offset + $size}]
+
+ if {$qual ne ""} {
+ # there's a mask to be applied
+ set numeric [expr $numeric $qual]
+ }
+
+ ::fileutil::magic::rt::Debug {puts stderr "NV $type $offset $qual: $numeric"}
+ return $numeric
+}
+
+# Numeric - get bytes of $type at $offset and $compare to $val
+# qual might be a mask
+proc ::fileutil::magic::rt::Nx {atlevel type offset comp val {qual ""}} {
+ variable typemap
+ variable numeric
+ variable last
+
+ upvar 1 level l
+ set l $atlevel
+
+ # unpack the type characteristics
+ foreach {size scan} $typemap($type) break
+
+ set last($atlevel) [expr {$offset + $size}]
+
+ # fetch the numeric field
+ set numeric [Fetch $offset $size $scan]
+
+ if {$comp eq "x"} {
+ # anything matches - don't care
+ return 1
+ }
+
+ # get value in binary form, then back to numeric
+ # this avoids problems with sign, as both values are
+ # [binary scan]-converted identically
+ binary scan [binary format $scan $val] $scan val
+
+ if {$qual ne ""} {
+ # there's a mask to be applied
+ set numeric [expr $numeric $qual]
+ }
+
+ # perform comparison
+ set c [expr $val $comp $numeric]
+
+ ::fileutil::magic::rt::Debug {puts stderr "numeric $type: $val $comp $numeric / $qual - $c"}
+ return $c
+}
+
+proc ::fileutil::magic::rt::Sx {atlevel offset comp val {qual ""}} {
+ variable fd
+ variable string
+ variable last
+
+ upvar 1 level l
+ set l $atlevel
+
+ # convert any backslashes
+ set val [subst -nocommands -novariables $val]
+
+ if {$comp eq "x"} {
+ # match anything - don't care, just get the value
+ set string ""
+
+ # Query: Can we use GetString here ?
+ # Or at least the strbuf cache ?
+
+ # move to the offset
+ ::seek $fd $offset
+ while {
+ ([::string length $string] < 100) &&
+ [::string is print [set c [::read $fd 1]]]
+ } {
+ if {[::string is space $c]} {
+ break
+ }
+ append string $c
+ }
+
+ set last($atlevel) [expr {$offset + [string length $string]}]
+
+ return 1
+ }
+
+ set len [::string length $val]
+ set last($atlevel) [expr {$offset + $len}]
+
+ # get the string and compare it
+ set string [GetString $offset $len]
+ set cmp [::string compare $val $string]
+ set c [expr $cmp $comp 0]
+
+ ::fileutil::magic::rt::Debug {
+ puts "String '$val' $comp '$string' - $c"
+ if {$c} {
+ puts "offset $offset - $string"
+ }
+ }
+ return $c
+}
+proc ::fileutil::magic::rt::L {newlevel} {
+ # Regenerate level information in the calling context.
+ upvar 1 level l ; set l $newlevel
+ return
+}
+
+proc ::fileutil::magic::rt::I {base type delta} {
+ # Handling of base locations specified indirectly through the
+ # contents of the inspected file.
+
+ variable typemap
+ foreach {size scan} $typemap($type) break
+ return [expr {[Fetch $base $size $scan] + $delta}]
+}
+
+proc ::fileutil::magic::rt::R {base} {
+ # Handling of base locations specified relative to the end of the
+ # last field one level above.
+
+ variable last ; # Remembered locations.
+ upvar 1 level l ; # The level to get data from.
+ return [expr {$last($l) + $base}]
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Retrieval of the data used in comparisons.
+
+# fetch and cache a numeric value from the file
+proc ::fileutil::magic::rt::Fetch {where what scan} {
+ variable cache
+ variable numeric
+ variable fd
+
+ if {![info exists cache($where,$what,$scan)]} {
+ ::seek $fd $where
+ binary scan [::read $fd $what] $scan numeric
+ set cache($where,$what,$scan) $numeric
+
+ # Optimization: If we got 4 bytes, i.e. long we implicitly
+ # know the short and byte data as well. Should put them into
+ # the cache. -- Profile: How often does such an overlap truly
+ # happen ?
+
+ } else {
+ set numeric $cache($where,$what,$scan)
+ }
+ return $numeric
+}
+
+proc ::fileutil::magic::rt::GetString {offset len} {
+ # We have the first 1k of the file cached
+ variable string
+ variable strbuf
+ variable fd
+
+ set end [expr {$offset + $len - 1}]
+ if {$end < 4096} {
+ # in the string cache, copy the requested part.
+ set string [::string range $strbuf $offset $end]
+ } else {
+ # an unusual one, move to the offset and read directly from
+ # the file.
+ ::seek $fd $offset
+ set string [::read $fd $len]
+ }
+ return $string
+}
+
+# ### ### ### ######### ######### #########
+## Internal, debugging.
+
+if {!$::fileutil::magic::rt::debug} {
+ # This procedure definition is optimized out of using code by the
+ # core bcc. It knows that neither argument checks are required,
+ # nor is anything done. So neither results, nor errors are
+ # possible, a true no-operation.
+ proc ::fileutil::magic::rt::Debug {args} {}
+
+} else {
+ proc ::fileutil::magic::rt::Debug {script} {
+ # Run the commands in the debug script. This usually generates
+ # some output. The uplevel is required to ensure the proper
+ # resolution of all variables found in the script.
+ uplevel 1 $script
+ return
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Initialize constants
+
+namespace eval ::fileutil::magic::rt {
+ # maps magic typenames to field characteristics: size (#byte),
+ # binary scan format
+
+ variable typemap
+}
+
+proc ::fileutil::magic::rt::Init {} {
+ variable typemap
+ global tcl_platform
+
+ # Set the definitions for all types which have their endianess
+ # explicitly specified n their name.
+
+ array set typemap {
+ byte {1 c} ubyte {1 c}
+ beshort {2 S} ubeshort {2 S}
+ leshort {2 s} uleshort {2 s}
+ belong {4 I} ubelong {4 I}
+ lelong {4 i} ulelong {4 i}
+ bedate {4 S} ledate {4 s}
+ beldate {4 I} leldate {4 i}
+
+ long {4 Q} ulong {4 Q} date {4 Q} ldate {4 Q}
+ short {2 Y} ushort {2 Y}
+ }
+
+ # Now set the definitions for the types without explicit
+ # endianess. They assume/use 'native' byteorder. We also put in
+ # special forms for the compiler, so that it can use short names
+ # for the native-endian types as well.
+
+ # generate short form names
+ foreach {n v} [array get typemap] {
+ foreach {len scan} $v break
+ #puts stderr "Adding $scan - [list $len $scan]"
+ set typemap($scan) [list $len $scan]
+ }
+
+ # The special Q and Y short forms are incorrect, correct now to
+ # use the proper native endianess.
+
+ if {$tcl_platform(byteOrder) eq "littleEndian"} {
+ array set typemap {Q {4 i} Y {2 s}}
+ } else {
+ array set typemap {Q {4 I} Y {2 S}}
+ }
+}
+
+::fileutil::magic::rt::Init
+# ### ### ### ######### ######### #########
+## Ready for use.
+
+package provide fileutil::magic::rt 1.0
+# EOF
diff --git a/tcllib/modules/fumagic/tmc b/tcllib/modules/fumagic/tmc
new file mode 100755
index 0000000..ae51569
--- /dev/null
+++ b/tcllib/modules/fumagic/tmc
@@ -0,0 +1,248 @@
+#! /bin/sh
+# -*- tcl -*- \
+exec tclsh "$0" ${1+"$@"}
+
+# TMC - Trival Magic Compiler
+# === = =====================
+
+# Use cases
+# ---------
+
+# (-) Compilation of one or more files in magic(5) syntax into a
+# single recognizer performing all the checks and mappings
+# encoded in them.
+#
+# Command syntax
+# --------------
+#
+# Ad 1) tmc procname magic-file ?magic-file...?
+#
+# Compile all magic files into a recognizer, put it into the
+# named procedure, and write the result to stdout.
+#
+# Ad 2) tmc -merge tclfile procname magic-file ?magic-file...?
+#
+# Same as (1), but does not write to stdout. Instead the part of
+# the 'tclfile' delineated by marker lines containing "BEGIN
+# GENERATED CODE" and "END GENERATED CODE" is replaced with the
+# generated code.
+
+package require Tcl 8.4
+lappend auto_path [file dirname [file normalize [info script]]] ; # This directory
+lappend auto_path [file dirname [lindex $auto_path end]] ; # and the one above
+#puts *\t[join $auto_path \n*\t]
+package require fileutil::magic::cfront
+
+# ### ### ### ######### ######### #########
+## Internal data and status
+
+namespace eval ::tmc {
+
+ # Path to where the output goes to. An empty string signals that
+ # the output is written to stdout. Otherwise it goes to the
+ # specified file, which has to exist, and is merged into it.
+ #
+ # Specified through the optional option '-merge'.
+
+ variable output ""
+
+ # Name of the procedure to generate from the input files.
+
+ variable proc ""
+
+ # List of the input files to process.
+
+ variable magic {}
+}
+
+# ### ### ### ######### ######### #########
+## External data and status
+#
+## Only the file merge mode uses external data, which is explicitly
+## specified via the command line. It is a template the generated
+## recognizer is merged into, completely replacing an existing
+## recognizer.
+
+# ### ### ### ######### ######### #########
+## Option processing.
+## Validate command line.
+## Full command line syntax.
+##
+# tmc ?-merge iofile? procname magic ?magic...?
+##
+
+proc ::tmc::processCmdline {} {
+ global argv
+
+ variable output
+ variable magic
+ variable proc
+
+ set output ""
+ set magic {}
+ set proc ""
+
+ # Process the options, perform basic validation.
+
+ while {[llength $argv]} {
+ set opt [lindex $argv 0]
+ if {![string match "-*" $opt]} break
+ if {$opt eq "-merge"} {
+ if {[llength $argv] < 2} Usage
+ set output [lindex $argv 1]
+ set argv [lrange $argv 2 end]
+ } else {
+ Usage
+ }
+ }
+
+ # Additional validation, and extraction of the non-option
+ # arguments.
+
+ if {[llength $argv] != 2} Usage
+
+ set proc [lindex $argv 0]
+ set magic [lrange $argv 1 end]
+
+ # Final validation across the whole configuration.
+
+ if {$proc eq ""} {
+ ArgError "Illegal empty proc name"
+ }
+ foreach m $magic {
+ CheckInput $m {Magic file}
+ }
+ if {$output ne ""} {
+ CheckTheMerge
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Option processing.
+## Helpers: Generation of error messages.
+## I. General usage/help message.
+## II. Specific messages.
+#
+# Both write their messages to stderr and then
+# exit the application with status 1.
+##
+
+proc ::tmc::Usage {} {
+ global argv0
+ puts stderr "$argv0 wrong#args, expected:\
+ ?-merge iofile? procname magic magic..."
+ exit 1
+}
+
+proc ::tmc::ArgError {text} {
+ global argv0
+ puts stderr "$argv0: $text"
+ exit 1
+}
+
+proc in {list item} {
+ expr {([lsearch -exact $list $item] >= 0)}
+}
+
+# ### ### ### ######### ######### #########
+## Check existence and permissions of an input/output file or
+## directory.
+
+proc ::tmc::CheckInput {f label} {
+ if {![file exists $f]} {
+ ArgError "Unable to find $label \"$f\""
+ } elseif {![file readable $f]} {
+ ArgError "$label \"$f\" not readable (permission denied)"
+ }
+ return
+}
+
+proc ::tmc::CheckTheMerge {} {
+ variable output
+
+ if {$output eq ""} {
+ ArgError "No merge file specified"
+ }
+ if {![file exists $output]} {
+ ArgError "Merge file \"$output\" not found"
+ } elseif {![file isfile $output]} {
+ ArgError "Merge file \"$output\" is no such (is a directory)"
+ } elseif {![file readable $output]} {
+ ArgError "Merge file \"$output\" not readable (permission denied)"
+ } elseif {![file writable $output]} {
+ ArgError "Merge file \"$output\" not writable (permission denied)"
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Helper commands. File reading and writing.
+
+proc ::tmc::Get {f} {
+ return [read [set in [open $f r]]][close $in]
+}
+
+proc ::tmc::Write {f data} {
+ puts -nonewline [set out [open $f w]] $data
+ close $out
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Configuation phase, validate command line.
+
+::tmc::processCmdline
+
+# ### ### ### ######### ######### #########
+## Helper command implementing the file merge functionality.
+
+proc ::tmc::Merge {f script} {
+ set out {}
+ set skip 0
+ foreach l [split [Get $f] \n] {
+ if {$skip == 0} {
+ lappend out $l
+ if {[string match {*BEGIN GENERATED CODE*} $l]} {
+ set skip 1
+ lappend out $script
+ }
+ } elseif {$skip == 1} {
+ if {[string match {*END GENERATED CODE*} $l]} {
+ lappend out $l
+ set skip 2
+ }
+ } else {
+ # Skip == 2
+ lappend out $l
+ }
+ }
+ Write $f [join $out \n]
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Invoking the functionality.
+
+if {[catch {
+ # Read and process all input files.
+ # Generate a single tcl procedure from them.
+ # Write the result either to stdout, or merge
+ # into the specified output file.
+
+ set tcl [eval [linsert $tmc::magic 0 \
+ fileutil::magic::cfront::procdef \
+ $tmc::proc]]
+
+ if {$tmc::output eq ""} {
+ puts stdout $tcl
+ } else {
+ ::tmc::Merge $tmc::output \n${tcl}\n
+ }
+} msg]} {
+ puts $::errorInfo
+ ::tmc::ArgError $msg
+}
+
+# ### ### ### ######### ######### #########
+exit
diff --git a/tcllib/modules/generator/ChangeLog b/tcllib/modules/generator/ChangeLog
new file mode 100644
index 0000000..fa83529
--- /dev/null
+++ b/tcllib/modules/generator/ChangeLog
@@ -0,0 +1,11 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2012-08-07 Andreas Kupries <andreask@activestate.com>
+
+ * New Module. Provided by Neil Madden.
+
+
diff --git a/tcllib/modules/generator/generator.man b/tcllib/modules/generator/generator.man
new file mode 100644
index 0000000..1a37669
--- /dev/null
+++ b/tcllib/modules/generator/generator.man
@@ -0,0 +1,482 @@
+[manpage_begin generator n 0.1]
+[keywords {control structure}]
+[keywords coroutine]
+[keywords filter]
+[keywords foldl]
+[keywords foldr]
+[keywords foreach]
+[keywords generator]
+[keywords iterator]
+[keywords map]
+[keywords reduce]
+[keywords scanl]
+[moddesc {Tcl Generator Commands}]
+[titledesc {Procedures for creating and using generators.}]
+[require Tcl 8.6]
+[require generator [opt 0.1]]
+[description]
+[para]
+
+The [cmd generator] package provides commands to define and iterate over
+generator expressions. A [emph generator] is a command that returns a sequence
+of values. However, unlike an ordinary command that returns a list, a
+generator [emph yields] each value and then suspends, allowing subsequent
+values to be fetched on-demand. As such, generators can be used to efficiently
+iterate over a set of values, without having to generate all answers in-memory.
+Generators can be used to iterate over elements of a data structure, or rows
+in the result set of a database query, or to decouple producer/consumer software
+designs such as parsers and tokenizers, or to implement sophisticated custom
+control strategies such as backtracking search. Generators reduce the need to
+implement custom control structures, as many such structures can be recast as
+generators, leading to both a simpler implementation and a more standardised
+interface. The generator mechanism is built on top of the Tcl 8.6 coroutine
+mechanism.
+
+[para]
+
+The package exports a single ensemble command, [cmd generator]. All
+functionality is provided as subcommands of this command. The core subcommands
+of the package are [method define], [method yield], and [method foreach]. The
+[method define] command works like Tcl's [cmd proc] command, but creates a
+generator procedure; that is, a procedure that returns a generator when called.
+The generator itself is a command that can be called multiple times: each time
+it returns the next value in the generated series. When the
+series has been exhausted, the generator command returns an empty list and then
+destroys itself. Rather than manually call a generator, however, the package
+also provides a flexible [method foreach] command that loops through the values of
+one or more generators. This loop construct mimicks the functionality of the
+built-in Tcl [cmd foreach] command, including handling multiple return values
+and looping over multiple generators at once. Writing a generator is also a
+simple task, much like writing a normal procedure: simply use the [method define]
+command to define the generator, and then call [method yield] instead of [cmd return].
+For example, we can define a generator for looping through the integers
+in a particular range:
+
+[para]
+[example {
+ generator define range {n m} {
+ for {set i $n} {$i <= $m} {incr i} { generator yield $i }
+ }
+ generator foreach x [range 1 10] {
+ puts "x = $x"
+ }
+}]
+
+[para]
+
+The above example will print the numbers from 1 to 10 in sequence, as you would
+expect. The difference from a normal loop over a list is that the numbers are
+only generated as they are needed. If we insert a break into the loop then any
+remaining numbers in the sequence would never be generated. To illustrate, we
+can define a generator that produces the sequence of natural numbers: an
+infinite series. A normal procedure would never return trying to produce this
+series as a list. By using a generator we only have to generate those values
+which are actually used:
+
+[para]
+[example {
+ generator define nats {} {
+ while 1 { generator yield [incr nat] }
+ }
+ generator foreach n [nats] {
+ if {$n > 100} { break }
+ }
+}]
+
+[section COMMANDS]
+[list_begin definitions]
+
+[call [cmd generator] [method define] [arg name] [arg params] [arg body]]
+
+Creates a new generator procedure. The arguments to the command are identical to
+those for [cmd proc]: a [arg name], a list of parameters, and a body. The
+parameter list format is identical to a procedure. In particular, default values
+and the [opt args] syntax can be used as usual. Each time the resulting
+generator procedure is called it creates a new generator command (coroutine)
+that will yield a list of values on each call. Each result from a generator is
+guaranteed to be a non-empty list of values. When a generator is exhausted it
+returns an empty list and then destroys itself to free up resources. It is an
+error to attempt to call an exhausted generator as the command no longer exists.
+
+[call [cmd generator] [method yield] [arg arg] [opt [arg args..]]]
+
+Used in the definition of a generator, this command returns the next set of
+values to the consumer. Once the [method yield] command has been called the
+generator will suspend to allow the consumer to process that value. When the
+next value is requested, the generator will resume as if the yield command had
+just returned, and can continue processing to yield the next result. The
+[method yield] command must be called with at least one argument, but can be called with
+multiple arguments, in which case this is equivalent to calling [method yield]
+once for each argument.
+
+[call [cmd generator] [method foreach] [arg varList] [arg generator] [arg varList] \
+ [arg generator] [opt ...] [arg body]]
+
+Loops through one or more generators, assigning the next values to variables and
+then executing the loop body. Works much like the built-in [cmd foreach]
+command, but working with generators rather than lists. Multiple generators can
+be iterated over in parallel, and multiple results can be retrieved from a
+single generator at once. Like the built-in [cmd foreach], the loop will
+continue until all of the generators have been exhausted: variables for
+generators that are exhausted early will be set to the empty string.
+
+[para]
+
+The [method foreach] command will automatically clean-up all of the generators
+at the end of the loop, regardless of whether the loop terminated early or not.
+This behaviour is provided as a convenience to avoid having to explicitly
+clean up a generator in the usual cases. Generators can however be destroyed
+before the end of the loop, in which case the loop will continue as normal until
+all the other generators have been destroyed or exhausted.
+
+[para]
+
+The [method foreach] command does not take a snapshot of the generator. Any
+changes in the state of the generator made inside the loop or by other code will
+affect the state of the loop. In particular, if the code in the loop invokes the
+generator to manually retrieve the next element, this element will then be
+excluded from the loop, and the next iteration will continue from the element
+after that one. Care should be taken to avoid concurrent updates to generators
+unless this behaviour is required (e.g., in argument processing).
+
+[call [cmd generator] [method next] [arg generator] [opt [arg varName..]]]
+
+Manually retrieves the next values from a generator. One value is retrieved for
+each variable supplied and assigned to the corresponding variable. If the
+generator becomes exhausted at any time then any remaining variables are set to
+the empty string.
+
+[call [cmd generator] [method exists] [arg generator]]
+
+Returns 1 if the generator (still) exists, or 0 otherwise.
+
+[call [cmd generator] [method names]]
+
+Returns a list of all currently existing generator commands.
+
+[call [cmd generator] [method destroy] [opt [arg generator..]]]
+
+Destroys one or more generators, freeing any associated resources.
+
+[call [cmd generator] [method finally] [arg cmd] [opt [arg arg..]]]
+
+Used in the definition of a generator procedure, this command arranges for a
+resource to be cleaned up whenever the generator is destroyed, either explicitly
+or implicitly when the generator is exhausted. This command can be used like a
+[method finally] block in the [cmd try] command, except that it is tied to the
+life-cycle of the generator rather than to a particular scope. For example, if
+we create a generator to iterate over the lines in a text file, we can use
+[method finally] to ensure that the file is closed whenever the generator is
+destroyed:
+
+[para]
+[example {
+ generator define lines file {
+ set in [open $file]
+ # Ensure file is always closed
+ generator finally close $in
+ while {[gets $in line] >= 0} {
+ generator yield $line
+ }
+ }
+ generator foreach line [lines /etc/passwd] {
+ puts "[incr count]: $line"
+ if {$count > 10} { break }
+ }
+ # File will be closed even on early exit
+}]
+
+[para]
+
+If you create a generator that consumes another generator (such as the standard
+[method map] and [method filter] generators defined later), then you should use
+a [method finally] command to ensure that this generator is destroyed when its
+parent is. For example, the [method map] generator is defined as follows:
+
+[para]
+[example {
+ generator define map {f xs} {
+ generator finally generator destroy $xs
+ generator foreach x $xs { generator yield [{*}$f $x] }
+ }
+}]
+
+[call [cmd generator] [method from] [arg format] [arg value]]
+
+Creates a generator from a data structure. Currently, supported formats are
+[option list], [option dict], or [option string]. The list format yields each
+element in turn. For dictionaries, each key and value are yielded separately.
+Finally, strings are yielded a character at a time.
+
+[call [cmd generator] [method to] [arg format] [arg generator]]
+
+Converts a generator into a data structure. This is the reverse operation of the
+[method from] command, and supports the same data structures. The two operations
+obey the following identity laws (where [method =] is interpreted
+appropriately):
+
+[para]
+[example {
+ [generator to $fmt [generator from $fmt $value]] = $value
+ [generator from $fmt [generator to $fmt $gen]] = $gen
+
+}]
+
+[list_end]
+
+[section PRELUDE]
+[para]
+
+The following commands are provided as a standard library of generator
+combinators and functions that perform convenience operations on generators. The
+functions in this section are loosely modelled on the equivalent functions from
+the Haskell Prelude. [emph Warning:] most of the functions in this prelude
+destroy any generator arguments they are passed as a side-effect. If you want to
+have persistent generators, see the streams library.
+
+[list_begin definitions]
+
+[call [cmd generator] [method map] [arg function] [arg generator]]
+
+Apply a function to every element of a generator, returning a new generator of
+the results. This is the classic map function from functional programming,
+applied to generators. For example, we can generate all the square numbers using
+the following code (where [cmd nats] is defined as earlier):
+
+[para]
+[example {
+ proc square x { expr {$x * $x} }
+ generator foreach n [generator map square [nats]] {
+ puts "n = $n"
+ if {$n > 1000} { break }
+ }
+}]
+
+[call [cmd generator] [method filter] [arg predicate] [arg generator]]
+
+Another classic functional programming gem. This command returns a generator
+that yields only those items from the argument generator that satisfy the
+predicate (boolean function). For example, if we had a generator [var employees]
+that returned a stream of dictionaries representing people, we could filter all
+those whose salaries are above 100,000 dollars (or whichever currency you prefer)
+using a simple filter:
+
+[para]
+[example {
+ proc salary> {amount person} { expr {[dict get $person salary] > $amount} }
+ set fat-cats [generator filter {salary> 100000} $employees]
+}]
+
+[call [cmd generator] [method reduce] [arg function] [arg zero] [arg generator]]
+
+This is the classic left-fold operation. This command takes a function, an
+initial value, and a generator of values. For each element in the generator it
+applies the function to the current accumulator value (the [arg zero] argument
+initially) and that element, and then uses the result as the new accumulator
+value. This process is repeated through the entire generator (eagerly) and the
+final accumulator value is then returned. If we consider the function to be a
+binary operator, and the zero argument to be the left identity element of that
+operation, then we can consider the [method reduce] command as [emph folding]
+the operator between each successive pair of values in the generator in a
+left-associative fashion. For example, the sum of a sequence of numbers can be
+calculated by folding a [cmd +] operator between them, with 0 as the identity:
+
+[para]
+[example {
+ # sum xs = reduce + 0 xs
+ # sum [range 1 5] = reduce + 0 [range 1 5]
+ # = reduce + [+ 0 1] [range 2 5]
+ # = reduce + [+ 1 2] [range 3 5]
+ # = ...
+ # = reduce + [+ 10 5] <empty>
+ # = ((((0+1)+2)+3)+4)+5
+ # = 15
+ proc + {a b} { expr {$a + $b} }
+ proc sum gen { generator reduce + 0 $gen }
+ puts [sum [range 1 10]]
+}]
+
+[para]
+
+The [method reduce] operation is an extremely useful one, and a great variety of
+different operations can be defined using it. For example, we can define a
+factorial function as the product of a range using generators. This definition
+is both very clear and also quite efficient (in both memory and running time):
+
+[para]
+[example {
+ proc * {x y} { expr {$x * $y} }
+ proc prod gen { generator reduce * 0 $gen }
+ proc fac n { prod [range 1 $n] }
+}]
+
+[para]
+
+However, while the [method reduce] operation is efficient for finite generators,
+care should be taken not to apply it to an infinite generator, as this will
+result in an infinite loop:
+
+[para]
+[example {
+ sum [nats]; # Never returns
+}]
+
+[call [cmd generator] [method foldl] [arg function] [arg zero] [arg generator]]
+
+This is an alias for the [method reduce] command.
+
+[call [cmd generator] [method foldr] [arg function] [arg zero] [arg generator]]
+
+This is the right-associative version of [method reduce]. This operation is
+generally inefficient, as the entire generator needs to be evaluated into memory
+(as a list) before the reduction can commence. In an eagerly evaluated language
+like Tcl, this operation has limited use, and should be avoided if possible.
+
+[call [cmd generator] [method all] [arg predicate] [arg generator]]
+
+Returns true if all elements of the generator satisfy the given predicate.
+
+[call [cmd generator] [method and] [arg generator]]
+
+Returns true if all elements of the generator are true (i.e., takes the logical
+conjunction of the elements).
+
+[call [cmd generator] [method any] [arg generator]]
+
+Returns true if any of the elements of the generator are true (i.e., logical
+disjunction).
+
+[call [cmd generator] [method concat] [arg generator] [opt [arg generator..]]]
+
+Returns a generator which is the concatenation of each of the argument
+generators.
+
+[call [cmd generator] [method concatMap] [arg function] [arg generator]]
+
+Given a function which maps a value to a series of values, and a generator of
+values of that type, returns a generator of all of the results in one flat
+series. Equivalent to [method concat] applied to the result of [method map].
+
+[call [cmd generator] [method drop] [arg n] [arg generator]]
+
+Removes the given number of elements from the front of the generator and returns
+the resulting generator with those elements removed.
+
+[call [cmd generator] [method dropWhile] [arg predicate] [arg generator]]
+
+Removes all elements from the front of the generator that satisfy the predicate.
+
+[call [cmd generator] [method contains] [arg element] [arg generator]]
+
+Returns true if the generator contains the given element. Note that this will
+destroy the generator!
+
+[call [cmd generator] [method foldl1] [arg function] [arg generator]]
+
+A version of [method foldl] that takes the [arg zero] argument from the first
+element of the generator. Therefore this function is only valid on non-empty
+generators.
+
+[call [cmd generator] [method foldli] [arg function] [arg zero] [arg generator]]
+
+A version of [method foldl] that supplies the integer index of each element as
+the first argument to the function. The first element in the generator at this
+point is given index 0.
+
+[call [cmd generator] [method foldri] [arg function] [arg zero] [arg generator]]
+
+Right-associative version of [method foldli].
+
+[call [cmd generator] [method head] [arg generator]]
+
+Returns the first element of the generator.
+
+[call [cmd generator] [method tail] [arg generator]]
+
+Removes the first element of the generator, returning the rest.
+
+[call [cmd generator] [method init] [arg generator]]
+
+Returns a new generator consisting of all elements except the last of the
+argument generator.
+
+[call [cmd generator] [method takeList] [arg n] [arg generator]]
+
+Returns the next [arg n] elements of the generator as a list. If not enough
+elements are left in the generator, then just the remaining elements are
+returned.
+
+[call [cmd generator] [method take] [arg n] [arg generator]]
+
+Returns the next [arg n] elements of the generator as a new generator. The old
+generator is destroyed.
+
+[call [cmd generator] [method iterate] [arg function] [arg init]]
+
+Returns an infinite generator formed by repeatedly applying the function to the
+initial argument. For example, the Fibonacci numbers can be defined as follows:
+
+[para]
+[example {
+ proc fst pair { lindex $pair 0 }
+ proc snd pair { lindex $pair 1 }
+ proc nextFib ab { list [snd $ab] [expr {[fst $ab] + [snd $ab]}] }
+ proc fibs {} { generator map fst [generator iterate nextFib {0 1}] }
+}]
+
+[call [cmd generator] [method last] [arg generator]]
+
+Returns the last element of the generator (if it exists).
+
+[call [cmd generator] [method length] [arg generator]]
+
+Returns the length of the generator, destroying it in the process.
+
+[call [cmd generator] [method or] [arg predicate] [arg generator]]
+
+Returns 1 if any of the elements of the generator satisfy the predicate.
+
+[call [cmd generator] [method product] [arg generator]]
+
+Returns the product of the numbers in a generator.
+
+[call [cmd generator] [method repeat] [arg n] [arg value..]]
+
+Returns a generator that consists of [arg n] copies of the given elements. The
+special value [emph Inf] can be used to generate an infinite sequence.
+
+[call [cmd generator] [method sum] [arg generator]]
+
+Returns the sum of the values in the generator.
+
+[call [cmd generator] [method takeWhile] [arg predicate] [arg generator]]
+
+Returns a generator of the first elements in the argument generator that satisfy
+the predicate.
+
+[call [cmd generator] [method splitWhen] [arg predicate] [arg generator]]
+
+Splits the generator into lists of elements using the predicate to identify
+delimiters. The resulting lists are returned as a generator. Elements matching
+the delimiter predicate are discarded. For example, to split up a generator
+using the string "|" as a delimiter:
+
+[para]
+[example {
+ set xs [generator from list {a | b | c}]
+ generator split {string equal "|"} $xs ;# returns a then b then c
+}]
+
+[call [cmd generator] [method scanl] [arg function] [arg zero] [arg generator]]
+
+Similar to [method foldl], but returns a generator of all of the intermediate
+values for the accumulator argument. The final element of this generator is
+equivalent to [method foldl] called on the same arguments.
+
+[list_end]
+
+[section {BUGS, IDEAS, FEEDBACK}]
+
+Please report any errors in this document, or in the package it describes, to
+[uri {mailto:nem@cs.nott.ac.uk} {Neil Madden}].
+[manpage_end]
diff --git a/tcllib/modules/generator/generator.tcl b/tcllib/modules/generator/generator.tcl
new file mode 100644
index 0000000..03bf9da
--- /dev/null
+++ b/tcllib/modules/generator/generator.tcl
@@ -0,0 +1,378 @@
+# generator.tcl --
+#
+# Iterators and generators via coroutines.
+#
+# Copyright (c) 2009 by Neil Madden <nem@cs.nott.ac.uk>
+#
+# See the file "license.terms" for information on Usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: generator.tcl,v 1.1 2012/08/08 23:23:06 andreas_kupries Exp $
+#
+
+package require Tcl 8.6
+package provide generator 0.1
+
+namespace eval generator {
+ namespace export {[a-z]*}
+ namespace ensemble create
+
+ # next generator varName ?varName ..? --
+ #
+ # Fetch the next values from a generator, assigning them to variables. If
+ # the generator is exhausted any remaining variables are assigned the
+ # empty string.
+ #
+ proc next {generator args} {
+ set items [takeList [llength $args] $generator]
+ uplevel 1 [list lassign $items {*}$args]
+ }
+
+ proc takeList {n generator} {
+ if {![exists $generator]} { return [list] }
+ set ret [list]
+ for {set i 0} {$i < $n} {incr i} {
+ set item [$generator]
+ if {[llength $item] == 0} { break }
+ lappend ret [lindex $item 0]
+ }
+ return $ret
+ }
+
+
+ # foreach varSpec generator ?varSpec generator ...? body --
+ #
+ # Iterate over the elements of one or more generator functions. Each
+ # generator is a command that yields successive elements. The syntax
+ # of this construct closely matches that of the built-in foreach
+ # command.
+ #
+ proc foreach args {
+ if {[llength $args] < 3 || ([llength $args] % 2) != 1} {
+ Usage "foreach varSpec generator ?varSpec generator ..? body"
+ }
+ set body [lindex $args end]
+ set genSpec [lrange $args 0 end-1]
+ set items [list]
+ ::foreach {varList generator} $genSpec {
+ lappend items [takeList [llength $varList] $generator]
+ }
+
+ try {
+ # Keep going until all of the generators are exhausted
+ # This is the foreach behaviour: empty strings are substituted for
+ # exhausted generators.
+ while 1 {
+ set count 0
+ ::foreach {varList generator} $genSpec item $items {
+ incr count [llength $item]
+ uplevel 1 [list lassign $item {*}$varList]
+ }
+ if {$count == 0} {
+ # All exhausted
+ break
+ }
+ try {
+ uplevel 1 $body
+ } on continue {} {
+ # Continue processing
+ } on return {result options} {
+ # increment -level to remove implementation details
+ dict incr options -level
+ return -options $options $result
+ }
+ set items [list]
+ ::foreach {varList generator} $genSpec {
+ lappend items [takeList [llength $varList] $generator]
+ }
+ }
+ } finally {
+ # Ensure generators are all cleaned up
+ ::foreach {_ generator} $genSpec {
+ destroy $generator
+ }
+ }
+ return
+ }
+
+ # finally cmd args.. --
+ #
+ # Arranges for cmd to be called when the generator is destroyed. This
+ # can be used to perform cleanup in the event that a generator is
+ # terminated early.
+ #
+ proc finally args {
+ set ns [uplevel 1 { namespace current }]
+ trace add command [info coroutine] delete [list ::apply [list args $args $ns]]
+ }
+ proc exists generator { expr {[llength [info commands $generator]] != 0} }
+ proc destroy args {
+ ::foreach generator $args {
+ if {[exists $generator]} { rename $generator "" }
+ }
+ }
+ proc yield args {
+ # Each argument is yielded individually as a separate value.
+ ::foreach arg $args {
+ ::yield [list $arg]
+ }
+ }
+
+ proc define {name params body} {
+ set name [Resolve 1 $name]
+ set ns [namespace qualifiers $name]
+ set lambda [list $params $body $ns]
+ interp alias {} $name {} ::generator::spawn $lambda
+ return $name
+ }
+ ##### PRIVATE METHODS #####
+
+ proc spawn {lambda args} {
+ set it [Gensym]
+ coroutine $it ::generator::generate $it $lambda $args
+ }
+
+ proc generate {name lambda argList} {
+ ::yield $name
+ apply $lambda {*}$argList
+ }
+
+ proc Resolve {level name} {
+ if {[string match ::* $name]} { return $name }
+ if {[string is integer -strict $level] && $level >= 0} { incr level }
+ set ns [uplevel $level { namespace current }]
+ if {$ns eq "::"} { return ::$name }
+ return $ns\::$name
+ }
+
+ proc All {p xs} {
+ ::foreach x $xs { if {![{*}$p $x]} { return 0 } }
+ return 1
+ }
+
+ proc Empty? xs { expr {[llength $xs] == 0} }
+
+
+ variable Gensymid 0
+ proc Gensym {} {
+ variable Gensymid
+ set prefix [namespace current]::generator
+ while {1} {
+ set name $prefix[incr Gensymid]
+ if {[llength [info commands $name]] == 0} { break }
+ }
+ return $name
+ }
+
+ proc Usage msg {
+ return -code error -level 2 "wrong # args: should be \"$msg\""
+ }
+
+ proc names {} {
+ set pat {[0-9]*}
+ return [info commands [namespace current]::generator$pat]
+ }
+
+ ##### STANDARD GENERATORS #####
+
+ define map {f xs} {
+ # Ensure underlying generator is cleaned up too
+ finally destroy $xs
+ foreach x $xs { yield [{*}$f $x] }
+ }
+ define filter {p xs} {
+ finally destroy $xs
+ foreach x $xs {
+ if {[{*}$p $x]} { yield $x }
+ }
+ }
+ proc reduce {f z xs} {
+ foreach x $xs { set z [{*}$f $z $x] }
+ return $z
+ }
+ proc foldl {f z xs} { reduce $f $z $xs }
+ proc foldr {f z xs} {
+ set ys [generator to list $xs]
+ for {set i 0} {$i < [llength $ys]} {incr i} {
+ set z [{*}$f [lindex $ys end-$i] $z]
+ }
+ return $z
+ }
+ define zipWith {f xs ys} {
+ finally destroy $xs $ys
+ foreach x $xs y $ys { yield [{*}$f $x $y] }
+ }
+ proc zip {xs ys} { zipWith list $xs $ys }
+
+ proc all {p xs} {
+ and [map $p $xs]
+ }
+ proc and xs {
+ # foldl && true $xs
+ # more efficient implementation (bail-out on first non-true element):
+ foreach x $xs { if {!$x} { return 0 } }
+ return 1
+ }
+ proc any {p xs} { reduce or 0 [map $p $xs] }
+ define concat args {
+ ::foreach xs $args { finally destroy $xs }
+ ::foreach xs $args {
+ foreach x $xs { yield $x }
+ }
+ }
+ define concatMap {f xs} {
+ concat {*}[map $f $xs]
+ }
+ proc drop {n xs} {
+ takeList $n $xs
+ return $xs
+ }
+ define dropWhile {p xs} {
+ finally destroy $xs
+ foreach x $xs {
+ if {![{*}$p $x]} { yield $x; break }
+ }
+ foreach x $xs { yield $x }
+ }
+ proc contains {elem xs} {
+ foreach x $xs { if {$x eq $elem} { return 1 } }
+ return 0
+ }
+
+ proc foldl1 {f xs} { foldl $f [take 1 $xs] $xs }
+ proc foldli {f z xs} {
+ foreach x $xs { set z [{*}$f [incr i] $z $x] }
+ return $z
+ }
+ proc foldri {f z xs} {
+ set ys [to list $xs]
+ for {set i [llength $ys]} {$i > 0} {incr i -1} {
+ set z [{*}$f [incr j] [lindex $ys $i-1] $z]
+ }
+ return $z
+ }
+ proc head xs { take 1 $xs }
+ proc tail xs { drop 1 $xs }
+ proc last xs {
+ foreach x $xs { }
+ return $x
+ }
+ define init xs {
+ finally destroy $xs
+ set last [head $xs]
+ foreach x $xs {
+ yield $last
+ set last $x
+ }
+ }
+ define take {n xs} {
+ finally destroy $xs
+ foreach x $xs {
+ if {[incr i] >= $n} { break }
+ yield $x
+ }
+ }
+ define iterate {f x} {
+ while 1 {
+ yield $x
+ set x [{*}$f $x]
+ }
+ }
+
+ proc Count {x y} { incr x }
+ proc length xs { foldl Count 0 $xs }
+
+ proc or {p xs} {
+ foreach x $xs { if {[{*}$p $x]} { return 1 } }
+ return 0
+ }
+
+ proc product xs { foldl ::tcl::mathop::* 1 $xs }
+ define repeat {n args} {
+ for {set i 0} {$i < $n} {incr i} {
+ yield {*}$args
+ }
+ }
+ proc sum xs { foldl ::tcl::mathop::+ 0 $xs }
+
+ define takeWhile {p xs} {
+ finally destroy $xs
+ foreach x $xs {
+ if {[{*}$p $x]} { yield $x }
+ }
+ }
+
+ define splitWhen {p xs} {
+ finally destroy $xs
+ set token [list]
+ foreach x $xs {
+ if {[{*}$p $x]} {
+ yield $token
+ set token [list]
+ } else {
+ lappend token $x
+ }
+ }
+ if {[llength $token]} { yield $token }
+ }
+
+ define scanl {f z xs} {
+ finally destroy $xs
+ yield $z
+ foreach x $xs {
+ set z [{*}$f $z $x]
+ yield $z
+ }
+ }
+
+ # from ?list|dict? xs
+ # Converts a list or dictionary into a generator: over elements or key/value
+ # pairs.
+ namespace eval from {
+ namespace export list dict string
+ namespace ensemble create
+
+ generator define list xs {
+ foreach x $xs { generator yield $x }
+ }
+
+ generator define dict d {
+ ::dict for {k v} $d { generator yield $k $v }
+ }
+
+ generator define string s {
+ foreach c [split $s ""] { generator yield $c }
+ }
+ }
+
+ # to ?list|dict? g
+ # Converts a generator into a list or dictionary by extracting all elements.
+ # Dictionaries are created by assuming the generator returns a pair of
+ # values per element, and using these as the key and value.
+ namespace eval to {
+ namespace export list dict string
+ namespace ensemble create
+
+ proc list g {
+ set xs [::list]
+ generator foreach x $g { lappend xs $x }
+ return $xs
+ }
+
+ proc dict g {
+ set d [dict create]
+ generator foreach {k v} $g { dict set d $k $v }
+ return $d
+ }
+
+ proc string g {
+ set s ""
+ generator foreach c $g { append s $c }
+ return $s
+ }
+ }
+ # The conversion functions should follow these identity laws:
+ # [to list [from list $xs]] == $xs
+ # [to dict [from dict $xs]] == $xs
+
+}
diff --git a/tcllib/modules/generator/license.terms b/tcllib/modules/generator/license.terms
new file mode 100644
index 0000000..ecf2c9f
--- /dev/null
+++ b/tcllib/modules/generator/license.terms
@@ -0,0 +1,38 @@
+This software is copyrighted by Neil Madden. The following terms apply to
+all files associated with the software unless explicitly disclaimed in
+individual files.
+
+The authors hereby grant permission to use, copy, modify, distribute,
+and license this software and its documentation for any purpose, provided
+that existing copyright notices are retained in all copies and that this
+notice is included verbatim in any distributions. No written agreement,
+license, or royalty fee is required for any of the authorized uses.
+Modifications to this software may be copyrighted by their authors
+and need not follow the licensing terms described here, provided that
+the new terms are clearly indicated on the first page of each file where
+they apply.
+
+IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+MODIFICATIONS.
+
+GOVERNMENT USE: If you are acquiring this software on behalf of the
+U.S. government, the Government shall have only "Restricted Rights"
+in the software and related documentation as defined in the Federal
+Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
+are acquiring the software on behalf of the Department of Defense, the
+software shall be classified as "Commercial Computer Software" and the
+Government shall have only "Restricted Rights" as defined in Clause
+252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
+authors grant the U.S. Government and others acting in its behalf
+permission to use and distribute the software in accordance with the
+terms specified in this license.
diff --git a/tcllib/modules/generator/pkgIndex.tcl b/tcllib/modules/generator/pkgIndex.tcl
new file mode 100644
index 0000000..eaf9f65
--- /dev/null
+++ b/tcllib/modules/generator/pkgIndex.tcl
@@ -0,0 +1,3 @@
+# Requires Tcl 8.6 and higher, to have the coroutines underlying generators.
+if {![package vsatisfies [package provide Tcl] 8.6]} return
+package ifneeded generator 0.1 [list source [file join $dir generator.tcl]]
diff --git a/tcllib/modules/gpx/ChangeLog b/tcllib/modules/gpx/ChangeLog
new file mode 100644
index 0000000..70b073e
--- /dev/null
+++ b/tcllib/modules/gpx/ChangeLog
@@ -0,0 +1,44 @@
+2013-02-22 Andreas Kupries <andreask@activestate.com>
+
+ * gpx.man: Fixed outdated doctools markup.
+
+2013-02-08 Andreas Kupries <andreask@activestate.com>
+
+ * gpx.man: Fixed categorization.
+
+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-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * gpx.test: Extended testsuite, provided by Keith.
+
+2010-07-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * gpx.man: Added documentation, written by Keith.
+
+2010-07-09 Andreas Kupries <andreask@activestate.com>
+
+ * gpx.tcl (::gpx::GetTrackPoints, ::gpx::GetRoutePoints): Fixed
+ bugs reported by Keith through mail, using his code.
+
+2010-07-08 Andreas Kupries <andreask@activestate.com>
+
+ * gpx.tcl: New module and package for the parsing of GPS eXChange
+ * pkgIndex.tcl: files, by Keith Vetter.
+ * gpx.test: Beginnings of a testsuite.
diff --git a/tcllib/modules/gpx/gpx.man b/tcllib/modules/gpx/gpx.man
new file mode 100644
index 0000000..cf9b52a
--- /dev/null
+++ b/tcllib/modules/gpx/gpx.man
@@ -0,0 +1,158 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin gpx n 0.9]
+[keywords gps]
+[keywords gpx]
+[copyright {2010, Keith Vetter <kvetter@gmail.com>}]
+[moddesc {GPS eXchange Format (GPX)}]
+[titledesc {Extracts waypoints, tracks and routes from GPX files}]
+[category {File formats}]
+[require Tcl 8.5]
+[require gpx [opt 0.9]]
+[description]
+[para]
+
+This module parses and extracts waypoints, tracks, routes and
+metadata from a GPX (GPS eXchange) file. Both GPX version 1.0
+and 1.1 are supported.
+
+[section {COMMANDS}]
+
+[list_begin definitions]
+
+[call [cmd "::gpx::Create"] [arg gpxFilename] [opt [arg "rawXML"]]]
+
+The [cmd ::gpx::Create] is the first command called to process GPX
+data. It takes the GPX data from either the [arg rawXML]
+parameter if present or from the contents of [arg gpxFilename],
+and parses it using [emph tdom]. It returns a token value that is used
+by all the other commands.
+
+[call [cmd "::gpx::Cleanup"] [arg token]]
+
+This procedure cleans up resources associated with [arg token].
+It is [emph strongly] recommended that you call this
+function after you are done with a given GPX file.
+Not doing so will result in memory not being freed, and
+if your app calls [cmd ::gpx::Create] enough times, the
+memory leak could cause a performance hit...or worse.
+
+[call [cmd ::gpx::GetGPXMetadata] [arg token]]
+
+This procedure returns a dictionary of the metadata
+associated with the GPX data identified by [arg token].
+The format of the metadata dictionary is described
+below, but keys [emph version] and [emph creator]
+will always be present.
+
+[call [cmd ::gpx::GetWaypointCount] [arg token]]
+
+This procedure returns the number of waypoints defined in the GPX
+data identified by [arg token].
+
+[call [cmd ::gpx::GetAllWaypoints] [arg token]]
+
+This procedure returns the a list of waypoints defined in the GPX
+data identified by [arg token]. The format of each waypoint item
+is described below.
+
+[call [cmd ::gpx::GetTrackCount] [arg token]]
+
+This procedure returns the number of tracks defined in the GPX
+data identified by [arg token].
+
+[call [cmd ::gpx::GetTrackMetadata] [arg token] [arg whichTrack]]
+
+This procedure returns a dictionary of the metadata
+associated track number [arg whichTrack] (1 based) in
+the GPX data identified by [arg token].
+The format of the metadata dictionary is described below.
+
+[call [cmd ::gpx::GetTrackPoints] [arg token] [arg whichTrack]]
+
+The procedure returns a list of track points comprising track
+number [arg whichTrack] (1 based) in the GPX data identified by
+[arg token]. The format of the metadata dictionary is described below.
+
+[call [cmd ::gpx::GetRouteCount] [arg token]]
+
+This procedure returns the number of routes defined in the GPX
+data identified by [arg token].
+
+[call [cmd ::gpx::GetRouteMetadata] [arg token] [arg whichRoute]]
+
+This procedure returns a dictionary of the metadata
+associated route number [arg whichRoute] (1 based) in
+the GPX data identified by [arg token].
+The format of the metadata dictionary is described below.
+
+[call [cmd ::gpx::GetRoutePoints] [arg token] [arg whichRoute]]
+
+The procedure returns a list of route points comprising route
+number [arg whichRoute] (1 based) in the GPX data identified by
+[arg token]. The format of the metadata dictionary is described below.
+
+[list_end]
+
+[section "DATA STRUCTURES"]
+
+[list_begin definitions]
+
+[def "metadata dictionary"]
+
+The metadata associated with either the GPX document, a
+track, a route, a waypoint, a track point or route
+point is returned in a dictionary. The keys of that
+dictionary will be whatever optional GPX elements are
+present. The value for each key depends on the GPX schema
+for that element. For example, the value for a version
+key will be a string, while for a link key will be
+a sub-dictionary with keys [emph href] and optionally
+[emph text] and [emph type].
+
+[def "point item"]
+Each item in a track or route list of points consists of
+a list of three elements: [emph latitude], [emph longitude] and
+[emph "metadata dictionary"]. [emph Latitude] and [emph longitude]
+are decimal numbers. The [emph "metadata dictionary"] format is
+described above. For points in a track, typically there will
+always be ele (elevation) and time metadata keys.
+
+[list_end]
+
+[section "EXAMPLE"]
+
+[example {
+% set token [::gpx::Create myGpxFile.gpx]
+% set version [dict get [::gpx::GetGPXMetadata $token] version]
+% set trackCnt [::gpx::GetTrackCount $token]
+% set firstPoint [lindex [::gpx::GetTrackPoints $token 1] 0]
+% lassign $firstPoint lat lon ptMetadata
+% puts "first point in the first track is at $lat, $lon"
+% if {[dict exists $ptMetadata ele]} {
+ puts "at elevation [dict get $ptMetadata ele] meters"
+ }
+% ::gpx::Cleanup $token
+}]
+
+[section "REFERENCES"]
+
+[list_begin enumerated]
+
+[enum]
+ GPX: the GPS Exchange Format
+ ([uri http://www.topografix.com/gpx.asp])
+
+[enum]
+ GPX 1.1 Schema Documentation ([uri http://www.topografix.com/GPX/1/1/])
+
+[enum]
+ GPX 1.0 Developer's Manual ([uri http://www.topografix.com/gpx_manual.asp])
+
+[list_end]
+
+[section AUTHOR]
+Keith Vetter
+
+[vset CATEGORY gpx]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/gpx/gpx.tcl b/tcllib/modules/gpx/gpx.tcl
new file mode 100644
index 0000000..739ab96
--- /dev/null
+++ b/tcllib/modules/gpx/gpx.tcl
@@ -0,0 +1,294 @@
+##+##########################################################################
+#
+# gpx.tcl -- Parse gpx files
+# by Keith Vetter, July 7, 2010
+#
+# gpx definition:
+# http://www.topografix.com/gpx.asp
+# http://www.topografix.com/GPX/1/1/
+# GPX 1.0 => http://www.topografix.com/gpx_manual.asp
+#
+# code reference:
+# http://wiki.tcl.tk/26635
+
+# API
+# set token [::gpx::Create gpxFilename]
+# ::gpx::Cleanup $token
+# ::gpx::GetGPXMetadata $token => dict of metadata
+# ::gpx::GetWaypointCount $token => number of waypoints
+# ::gpx::GetAllWaypoints $token => list of waypoint items
+# ::gpx::GetTrackCount $token => number of tracks
+# ::gpx::GetTrackMetadata $token $whichTrack => dict of metadata for this track
+# ::gpx::GetTrackPoints $token $whichTrack => list of trkpts for this track
+# ::gpx::GetRouteCount $token => number of routes
+# ::gpx::GetRouteMetadata $token $whichRoute => dict of metadata for this route
+# ::gpx::GetRoutePoints $token $whichRoute => list of rtepts for this route
+#
+# o metadata is a dictionary whose keys depends on the which optional elements
+# are present and whose structure depends on the element's schema
+#
+# o a waypoint/trackpoint is a 3 element list consisting of latitude,
+# longitude and a dictionary of metadata:
+# e.g. 41.61716028 -70.61758477 {ele 35.706 time 2010-06-17T16:02:28Z}
+#
+
+package require Tcl 8.5
+package require tdom
+
+namespace eval gpx {
+ variable nameSpaces {
+ gpx "http://www.topografix.com/GPX/1/1"
+ xsi "http://www.w3.org/2001/XMLSchema-instance"
+ }
+ # gpx 1.0 was obsoleted August 9, 2004, but we handle it anyway
+ variable nameSpaces10 {
+ gpx "http://www.topografix.com/GPX/1/0"
+ topografix "http://www.topografix.com/GPX/Private/TopoGrafix/0/2"
+ }
+ variable gpx
+ set gpx(id) 0
+
+ # Cleanup any existing doms if we reload this module
+ ::apply {{} {
+ foreach arr [array names ::gpx::gpx dom,*] {
+ catch {$::gpx::gpx($arr) delete}
+ unset ::gpx::gpx($arr)
+ }
+ }}
+}
+
+##+##########################################################################
+#
+# ::gpx::Create -- Creates a tdom object, returns opaque token to it
+# parameters: gpxFilename
+# returns: token for this tdom object
+#
+proc ::gpx::Create {gpxFilename {rawXML {}}} {
+ variable nameSpaces
+ variable gpx
+
+ if {$rawXML eq ""} {
+ set fin [open $gpxFilename r]
+ set rawXML [read $fin] ; list
+ close $fin
+ }
+
+ set token "gpx[incr gpx(id)]"
+ dom parse $rawXML gpx(dom,$token)
+
+ # Check version 1.0, 1.1 or fail
+ set version [[$gpx(dom,$token) documentElement] getAttribute version 0.0]
+ if {[package vcompare $version 1.1] >= 0} {
+ $gpx(dom,$token) selectNodesNamespaces $::gpx::nameSpaces
+ } elseif {[package vcompare $version 1.0] == 0} {
+ $gpx(dom,$token) selectNodesNamespaces $::gpx::nameSpaces10
+ } else {
+ $gpx(dom,$token) delete
+ error "$gpxFilename is version $version, need 1.0 or better"
+ }
+ set gpx(version,$token) $version
+ return $token
+}
+##+##########################################################################
+#
+# ::gpx::Cleanup -- Cleans up an instance of a tdom object
+# parameter: token returned by ::gpx::Create
+#
+proc ::gpx::Cleanup {token} {
+ variable gpx
+ $gpx(dom,$token) delete
+ unset gpx(dom,$token)
+}
+
+
+##+##########################################################################
+#
+# ::gpx::GetGPXMetadata -- Return metadata dictionary for entire document
+# parameter: token returned by ::gpx::Create
+# returns: metadata dictionary for entire document
+#
+proc ::gpx::GetGPXMetadata {token} {
+ set gpxNode [$::gpx::gpx(dom,$token) documentElement]
+ set version $::gpx::gpx(version,$token)
+ set creator [$gpxNode getAttribute creator ?]
+ set attr [dict create version $version creator $creator]
+
+ if {[package vcompare $version 1.0] == 0} {
+ set result [::gpx::_ExtractNodeMetadata $token $gpxNode]
+ } else {
+ set meta [$::gpx::gpx(dom,$token) selectNodes /gpx:gpx/gpx:metadata]
+ set result [::gpx::_ExtractNodeMetadata $token $meta]
+ }
+ set result [dict merge $attr $result]
+ return $result
+}
+
+##+##########################################################################
+#
+# ::gpx::GetWaypointCount -- Return number of waypoints defined in gpx file
+# parameter: token returned by ::gpx::Create
+# returns: number of waypoints
+#
+proc ::gpx::GetWaypointCount {token} {
+ set wpts [$::gpx::gpx(dom,$token) selectNodes /gpx:gpx/gpx:wpt]
+ return [llength $wpts]
+}
+##+##########################################################################
+#
+# ::gpx::GetAllWaypoints -- Returns list of waypoints, each item consists
+# of {lat lon <dictionary of metadata>}
+# parameter: token returned by ::gpx::Create
+# returns: list of waypoint items
+#
+proc ::gpx::GetAllWaypoints {token} {
+ set wpts [$::gpx::gpx(dom,$token) selectNodes /gpx:gpx/gpx:wpt]
+
+ set result {}
+ foreach wpt $wpts {
+ set lat [$wpt getAttribute "lat" ?]
+ set lon [$wpt getAttribute "lon" ?]
+ set meta [::gpx::_ExtractNodeMetadata $token $wpt]
+ lappend result [list $lat $lon $meta]
+ }
+ return $result
+}
+##+##########################################################################
+#
+# ::gpx::GetTrackCount -- returns how many tracks
+# parameter: token returned by ::gpx::Create
+# returns: number of tracks
+#
+proc ::gpx::GetTrackCount {token} {
+ set trks [$::gpx::gpx(dom,$token) selectNodes /gpx:gpx/gpx:trk]
+ return [llength $trks]
+}
+##+##########################################################################
+#
+# ::gpx::GetTrackMetadata -- Returns metadata dictionary for this track
+# parameter: token returned by ::gpx::Create
+# whichTrack: which track to get (1 based)
+# returns: metadata dictionary for this track
+#
+proc ::gpx::GetTrackMetadata {token whichTrack} {
+ set trkNode [$::gpx::gpx(dom,$token) selectNodes \
+ /gpx:gpx/gpx:trk\[$whichTrack\]]
+
+ set meta [::gpx::_ExtractNodeMetadata $token $trkNode]
+}
+##+##########################################################################
+#
+# ::gpx::GetTrackPoints -- Returns track consisting of a list of track points,
+# each of which consists of {lat lon <dictionary of metadata>}
+# parameter: token returned by ::gpx::Create
+# whichTrack: which track to get (1 based)
+# returns: list of trackpoints for given track
+#
+proc ::gpx::GetTrackPoints {token whichTrack} {
+ set trkpts [$::gpx::gpx(dom,$token) selectNodes \
+ /gpx:gpx/gpx:trk\[$whichTrack\]//gpx:trkpt]
+ set result {}
+ foreach trkpt $trkpts {
+ set lat [$trkpt getAttribute "lat" ?]
+ set lon [$trkpt getAttribute "lon" ?]
+ set meta [::gpx::_ExtractNodeMetadata $token $trkpt]
+ lappend result [list $lat $lon $meta]
+ }
+ return $result
+}
+##+##########################################################################
+#
+# ::gpx::GetRouteCount -- returns how many routes
+# parameter: token returned by ::gpx::Create
+# returns: number of routes
+#
+proc ::gpx::GetRouteCount {token} {
+ set rtes [$::gpx::gpx(dom,$token) selectNodes /gpx:gpx/gpx:rte]
+ return [llength $rtes]
+}
+##+##########################################################################
+#
+# ::gpx::GetRouteMetadata -- Returns metadata dictionary for this route
+# parameter: token returned by ::gpx::Create
+# whichRoute: which route to get (1 based)
+# returns: metadata dictionary for this route
+#
+proc ::gpx::GetRouteMetadata {token whichRoute} {
+ set rteNode [$::gpx::gpx(dom,$token) selectNodes \
+ /gpx:gpx/gpx:rte\[$whichRoute\]]
+
+ set meta [::gpx::_ExtractNodeMetadata $token $rteNode]
+}
+##+##########################################################################
+#
+# ::gpx::GetRoutePoints -- Returns route consisting of a list of route points,
+# each of which consists of {lat lon <dictionary of metadata>}
+# parameter: token returned by ::gpx::Create
+# whichRoute: which route to get (1 based)
+# returns: list of routepoints for given route
+#
+proc ::gpx::GetRoutePoints {token whichRoute} {
+ set rtepts [$::gpx::gpx(dom,$token) selectNodes \
+ /gpx:gpx/gpx:rte\[$whichRoute\]//gpx:rtept]
+ set result {}
+ foreach rtept $rtepts {
+ set lat [$rtept getAttribute "lat" ?]
+ set lon [$rtept getAttribute "lon" ?]
+ set meta [::gpx::_ExtractNodeMetadata $token $rtept]
+ lappend result [list $lat $lon $meta]
+ }
+ return $result
+}
+##+##########################################################################
+#
+# ::gpx::_ExtractNodeMetadata -- Internal routine to get all
+# the optional data associated with an xml element. For most
+# elements we just want element name and text value but some
+# we want their attributes and some we want children metadata.
+#
+proc ::gpx::_ExtractNodeMetadata {token node} {
+ set result {}
+ if {$node eq ""} { return $result }
+
+ # author and email elements are different in version 1.0 and 1.1
+ set onlyAttributes [list "bounds" "email"]
+ set attributesAndElements [list "extension" "author" "link" "copyright"]
+ if {$::gpx::gpx(version,$token) == 1.0} {
+ set onlyAttributes [list "bounds"]
+ set attributesAndElements [list "extension" "link" "copyright"]
+ }
+
+ foreach child [$node childNodes] {
+ set nodeName [$child nodeName]
+
+ if {$nodeName in {"wpt" "trk" "trkseg" "trkpt" "rte" "rtept"}} continue
+ if {[string match "topografix:*" $nodeName]} continue
+
+ if {$nodeName in $onlyAttributes} {
+ set attr [::gpx::_GetAllAttributes $child]
+ lappend result $nodeName $attr
+ } elseif {$nodeName in $attributesAndElements} {
+ set attr [::gpx::_GetAllAttributes $child]
+ set meta [::gpx::_ExtractNodeMetadata $token $child]
+ set meta [concat $attr $meta]
+ lappend result $nodeName $meta
+ } else {
+ lappend result $nodeName [$child asText]
+ }
+ }
+ return $result
+}
+##+##########################################################################
+#
+# ::gpx::_GetAllAttributes -- Returns dictionary of attribute name and value
+#
+proc ::gpx::_GetAllAttributes {node} {
+ set result {}
+ foreach attr [$node attributes] {
+ lappend result $attr [$node getAttribute $attr]
+ }
+ return $result
+}
+################################################################
+
+package provide gpx 1
+return
diff --git a/tcllib/modules/gpx/gpx.test b/tcllib/modules/gpx/gpx.test
new file mode 100644
index 0000000..90b0442
--- /dev/null
+++ b/tcllib/modules/gpx/gpx.test
@@ -0,0 +1,317 @@
+# -*- tcl -*-
+# gpx.test: tests for the gpx package.
+#
+# Copyright (c) 2010-2015 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: gpx.test,v 1.2 2010/07/10 15:58:23 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+if {[file exists testutilities.tcl]} {
+ source testutilities.tcl
+} else {
+ source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+}
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+testsNeed tdom 0.8
+
+testing {
+ useLocal gpx.tcl gpx
+}
+# -------------------------------------------------------------------------
+
+set rawXML {<?xml version="1.0" encoding="UTF-8"?>
+<gpx xmlns="http://www.topografix.com/GPX/1/1" version="1.1"
+ creator="ExpertGPS 3.80"
+ xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
+ xsi:schemaLocation="http://www.topografix.com/GPX/1/1 http://www.topografix.com/GPX/1/1/gpx.xsd http://www.topografix.com/GPX/gpx_overlay/0/3 http://www.topografix.com/GPX/gpx_overlay/0/3/gpx_overlay.xsd http://www.topografix.com/GPX/gpx_modified/0/1 http://www.topografix.com/GPX/gpx_modified/0/1/gpx_modified.xsd">
+ <metadata>
+ <name>Sample GPX file</name>
+ <desc>GPX data for testing</desc>
+ <author>
+ <name>Keith Vetter</name>
+ <email id="kvetter" domain="gmail.com"/>
+ <link href="http://www.klimb.org">
+ <text>KLIMB Bike Mapping program</text>
+ <type>text/html</type>
+ </link>
+ </author>
+ <copyright author="Keith Vetter">
+ <year>2010</year>
+ <license>http://anywhere.com</license>
+ </copyright>
+ <link href="http://www.garmin.com">
+ <text>Garmin International</text>
+ <type>text/html</type>
+ </link>
+ <time>2009-10-17T22:58:43Z</time>
+ <keywords>gpx test file</keywords>
+ </metadata>
+ <wpt lat="41.61629786" lon="-70.61782860">
+ <ele>33.531</ele>
+ <time>2010-06-17T16:02:28Z</time>
+ <name>Trail head</name>
+ </wpt>
+ <wpt lat="41.61794834" lon="-70.61709418">
+ <ele>31.128</ele>
+ <time>2010-06-17T16:06:58Z</time>
+ <name>Abandoned car</name>
+ </wpt>
+ <trk>
+ <name>First track</name>
+ <type>GPS Tracklog</type>
+ <trkseg>
+ <trkpt lat="41.61716028" lon="-70.61758477">
+ <ele>35.706</ele>
+ <time>2010-06-17T16:02:28Z</time>
+ </trkpt>
+ <trkpt lat="41.61718609" lon="-70.61757144">
+ <ele>36.667</ele>
+ <time>2010-06-17T16:02:40Z</time>
+ </trkpt>
+ <trkpt lat="41.61736211" lon="-70.61755426">
+ <ele>35.706</ele>
+ <time>2010-06-17T16:02:49Z</time>
+ </trkpt>
+ </trkseg>
+ </trk>
+ <trk>
+ <name>Second track</name>
+ <type>GPS Tracklog</type>
+ <trkseg>
+ <trkpt lat="41.64316086" lon="-70.60154080">
+ <ele>15.038</ele>
+ <time>2010-07-09T14:28:20Z</time>
+ </trkpt>
+ <trkpt lat="41.64325641" lon="-70.60175169">
+ <ele>13.596</ele>
+ <time>2010-07-09T14:28:32Z</time>
+ </trkpt>
+ </trkseg>
+ <trkseg>
+ <trkpt lat="41.64335188" lon="-70.60195579">
+ <ele>13.596</ele>
+ <time>2010-07-09T14:28:43Z</time>
+ </trkpt>
+ <trkpt lat="41.64339547" lon="-70.60203558">
+ <ele>13.596</ele>
+ <time>2010-07-09T14:28:48Z</time>
+ </trkpt>
+ <trkpt lat="41.64344785" lon="-70.60210507">
+ <ele>13.115</ele>
+ <time>2010-07-09T14:28:53Z</time>
+ </trkpt>
+ </trkseg>
+ </trk>
+ <rte>
+ <name>KLIMB Route 1</name>
+ <number>1</number>
+ <rtept lat="41.64383611111111" lon="-70.60295833333333">
+ <ele>21.6</ele>
+ <name>M1</name>
+ <desc><![CDATA[Node 1]]></desc>
+ <sym>Waypoint</sym>
+ <type>KLIMB node</type>
+ </rtept>
+ <rtept lat="41.64373333333333" lon="-70.6031611111111">
+ <ele>22.9</ele>
+ </rtept>
+ <rtept lat="41.64364166666667" lon="-70.60331388888888">
+ <ele>23.5</ele>
+ </rtept>
+ <rtept lat="41.643502777777776" lon="-70.60352777777777">
+ <ele>23.8</ele>
+ </rtept>
+ <rtept lat="41.64322222222222" lon="-70.603725">
+ <ele>23.5</ele>
+ </rtept>
+ <rtept lat="41.64293055555555" lon="-70.6038611111111">
+ <ele>23.5</ele>
+ <name>M2</name>
+ <desc><![CDATA[Node 2]]></desc>
+ <sym>Waypoint</sym>
+ <type>KLIMB node</type>
+ </rtept>
+ </rte>
+</gpx>}
+set gpxFile [tcltest::makeFile $rawXML testGPXfile.gpx]
+
+# -------------------------------------------------------------------------
+
+test gpx-1.0 {create error} -body {
+ gpx::Create
+} -returnCodes error \
+ -result {wrong # args: should be "gpx::Create gpxFilename ?rawXML?"}
+
+test gpx-1.1 {create error} -body {
+ gpx::Create F XML X
+} -returnCodes error \
+ -result {wrong # args: should be "gpx::Create gpxFilename ?rawXML?"}
+
+test gpx-2.0 {create & destroy} -body {
+ gpx::Cleanup [gpx::Create $gpxFile]
+} -result {}
+
+test gpx-2.1 {create & destroy} -body {
+ gpx::Cleanup [gpx::Create {} $rawXML]
+} -result {}
+
+# -------------------------------------------------------------------------
+#
+# GetGPXMetadata tests
+#
+set token [gpx::Create "" $rawXML]
+
+test gpx-3.0 {GetGPXMetadata simple} -body {
+ llength [gpx::GetGPXMetadata $token]
+} -result 18
+
+test gpx-3.1 {GetGPXMetadata item} -body {
+ dict get [gpx::GetGPXMetadata $token] version
+} -result {1.1}
+
+test gpx-3.2 {GetGPXMetadata complex item} -body {
+ dict get [gpx::GetGPXMetadata $token] link href
+} -result {http://www.garmin.com}
+
+# -------------------------------------------------------------------------
+#
+# Waypoint tests
+#
+test gpx-4.0 {GetWaypointCount} -body {
+ gpx::GetWaypointCount $token
+} -result {2}
+
+test gpx-4.1 {Waypoint location} -body {
+ lrange [lindex [gpx::GetAllWaypoints $token] 0] 0 1
+} -result {41.61629786 -70.61782860}
+
+test gpx-4.2 {first waypoint metadata} -body {
+ llength [lindex [gpx::GetAllWaypoints $token] 0 2]
+} -result 6
+
+test gpx-4.3 {first waypoint metadata item} -body {
+ dict get [lindex [gpx::GetAllWaypoints $token] 0 2] ele
+} -result {33.531}
+
+test gpx-4.4 {second waypoint metadata} -body {
+ llength [lindex [gpx::GetAllWaypoints $token] 1 2]
+} -result 6
+
+test gpx-4.5 {second waypoint metadata item} -body {
+ dict get [lindex [gpx::GetAllWaypoints $token] 1 2] name
+} -result {Abandoned car}
+
+#----------------------------------------------------------------------
+#
+# Track tests
+#
+
+test gpx-5.0 {track count} -body {
+ gpx::GetTrackCount $token
+} -result {2}
+
+test gpx-5.1 {track metadata} -body {
+ llength [gpx::GetTrackMetadata $token 1]
+} -result 4
+
+test gpx-5.2 {track metadata item} -body {
+ dict get [gpx::GetTrackMetadata $token 1] name
+} -result {First track}
+
+test gpx-5.3 {total track points} -body {
+ llength [gpx::GetTrackPoints $token 1]
+} -result {3}
+
+test gpx-5.4 {total track points second track} -body {
+ llength [gpx::GetTrackPoints $token 2]
+} -result {5}
+
+test gpx-5.5 {first track first point location} -body {
+ lrange [lindex [gpx::GetTrackPoints $token 1] 0] 0 1
+} -result {41.61716028 -70.61758477}
+
+test gpx-5.6 {first track first point metadata} -body {
+ llength [lindex [gpx::GetTrackPoints $token 1] 0 2]
+} -result 4
+
+test gpx-5.7 {first track first point metadata item} -body {
+ dict get [lindex [gpx::GetTrackPoints $token 1] 0 2] ele
+} -result {35.706}
+
+test gpx-5.8 {second track last point location} -body {
+ lrange [lindex [gpx::GetTrackPoints $token 2] end] 0 1
+} -result {41.64344785 -70.60210507}
+
+test gpx-5.9 {second track last point metadata} -body {
+ llength [lindex [gpx::GetTrackPoints $token 2] end 2]
+} -result 4
+
+test gpx-5.10 {second track last point metadata item} -body {
+ dict get [lindex [gpx::GetTrackPoints $token 2] end 2] ele
+} -result {13.115}
+
+#----------------------------------------------------------------------
+#
+# Route tests
+#
+
+test gpx-6.0 {route count} -body {
+ gpx::GetRouteCount $token
+} -result 1
+
+test gpx-6.1 {route metadata} -body {
+ llength [gpx::GetRouteMetadata $token 1]
+} -result 4
+
+test gpx-6.2 {route metadata item} -body {
+ dict get [gpx::GetRouteMetadata $token 1] name
+} -result {KLIMB Route 1}
+
+test gpx-6.3 {total route points} -body {
+ llength [gpx::GetRoutePoints $token 1]
+} -result 6
+
+test gpx-6.4 {route first point location} -body {
+ lrange [lindex [gpx::GetRoutePoints $token 1] 0] 0 1
+} -result {41.64383611111111 -70.60295833333333}
+
+test gpx-6.5 {route first point metadata} -body {
+ llength [lindex [gpx::GetRoutePoints $token 1] 0 2]
+} -result 10
+
+test gpx-6.6 {route first point metadata item} -body {
+ dict get [lindex [gpx::GetRoutePoints $token 1] 0 2] type
+} -result {KLIMB node}
+
+test gpx-6.7 {route second point metadata} -body {
+ llength [lindex [gpx::GetRoutePoints $token 1] 1 2]
+} -result 2
+
+test gpx-6.8 {route last point location} -body {
+ lrange [lindex [gpx::GetRoutePoints $token 1] end] 0 1
+} -result {41.64293055555555 -70.6038611111111}
+
+test gpx-6.8 {route last point metadata} -body {
+ llength [lindex [gpx::GetRoutePoints $token 1] end 2]
+} -result 10
+
+test gpx-6.9 {route last point metadata item} -body {
+ dict get [lindex [gpx::GetRoutePoints $token 1] end 2] desc
+} -result {Node 2}
+
+
+#----------------------------------------------------------------------
+gpx::Cleanup $token
+tcltest::removeFile $gpxFile
+unset rawXML gpxFile token
+
+#----------------------------------------------------------------------
+testsuiteCleanup
+return
diff --git a/tcllib/modules/gpx/pkgIndex.tcl b/tcllib/modules/gpx/pkgIndex.tcl
new file mode 100644
index 0000000..39884df
--- /dev/null
+++ b/tcllib/modules/gpx/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+package ifneeded gpx 1 [list source [file join $dir gpx.tcl]]
diff --git a/tcllib/modules/grammar_aycock/ChangeLog b/tcllib/modules/grammar_aycock/ChangeLog
new file mode 100644
index 0000000..244ef2a
--- /dev/null
+++ b/tcllib/modules/grammar_aycock/ChangeLog
@@ -0,0 +1,54 @@
+2013-02-22 Andreas Kupries <andreask@activestate.com>
+
+ * aycock.man: Fixed outdated doctools markup.
+
+2013-02-08 Andreas Kupries <andreask@activestate.com>
+
+ * aycock.man: Fixed missing short package title.
+
+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-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2011-01-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: Fixed guard condition, requiring 8.5+.
+
+ * aycock.test: Fixed test setup, i.e. added the standard
+ boilerplate.
+
+ * aycock-build.tcl: Made proc names fully qualified.
+ * aycock-debug.tcl:
+ * aycock-runtime.tcl:
+
+ All files changed from Windows to Unix line endings.
+
+2010-10-22 Kevin B. Kenny <kennykb@acm.org>
+
+ * aycock.man: Added a missing [list_begin] [list_end]
+ pair bracketing the list of methods for
+ the parser.
+
+2010-10-18 Kevin B, Kenny <kennykb@acm.org>
+
+ * aycock-build.tcl:
+ * aycock-debug.tcl:
+ * aycock-runtime.tcl:
+ * aycock.man:
+ * aycock.test:
+ * pkgIndex.tcl: 1.0 release of an Aycock-Earley-Horspool
+ parser generator for Tcl.
diff --git a/tcllib/modules/grammar_aycock/aycock-build.tcl b/tcllib/modules/grammar_aycock/aycock-build.tcl
new file mode 100644
index 0000000..f0eb2ae
--- /dev/null
+++ b/tcllib/modules/grammar_aycock/aycock-build.tcl
@@ -0,0 +1,735 @@
+#----------------------------------------------------------------------
+#
+# aycock-build.tcl --
+#
+# Procedures needed to compile an Aycock-Horspool-Earley parser.
+#
+# Copyright (c) 2006 by Kevin B. Kenny. All rights reserved.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: aycock-build.tcl,v 1.2 2011/01/13 02:47:47 andreas_kupries Exp $
+#
+#----------------------------------------------------------------------
+
+package provide grammar::aycock 1.0
+package require Tcl 8.4
+
+# Bring in procedures that aid in debugging a parser; they will in turn
+# bring in procedures that implement the runtime system.
+
+package require grammar::aycock::debug 1.0
+
+namespace eval grammar::aycock {
+
+ # The 'aycock' namespace exports only the 'parser' command, which
+ # constructs a parser.
+
+ namespace export parser
+
+}
+
+# grammar::aycock::parser --
+#
+# Creates an Aycock-Earley parser.
+#
+# Parameters:
+# rules - A list that can be broken down into productions.
+# dump - The optional flag, '-verbose'. If supplied, the rules
+# and resulting LRE(0) automaton are dumped to the standard
+# output.
+#
+# Results:
+# Returns the name of a parser, which is an ensemble
+# supporting a number of subcommands for processing the
+# language defined by $rules.
+#
+# Each production takes the form
+# symbol ::= rhs { action }
+# where symbol is a single word defining a nonterminal
+# symbol; rhs is the right-hand side (a sequence of nonterminal
+# or terminal symbols) and action is a single word giving
+# a script to execute when the production is reduced. Within the
+# action, a variable $_ is defined, which is a list of the same
+# length as rhs giving the semantic values of each symbol on the
+# right-hand side.
+
+proc ::grammar::aycock::parser {rules {dump {}}} {
+ set name [MakeParser]
+ ProcessRules $name $rules
+ ComputeNullable $name
+ RewriteGrammar $name
+ MakeState0 $name
+ MakeState $name 0 \u22a2
+ CompleteAutomaton $name
+ unset ${name}::Cores
+ if {$dump eq {-verbose}} {
+ puts "parser: $name"
+ puts "Rules:"
+ DumpRuleSet $name stdout
+ puts "------------------------------------------------------------"
+ DumpAutomaton $name stdout
+ }
+ set l [NeverReduced $name]
+ if {[llength $l] != 0} {
+ return -code error "Rules never reduced: $l"
+ }
+ unset ${name}::Items
+ return $name
+}
+
+# grammar::aycock::MakeParser --
+#
+# Constructs the ensemble that will contain an Aycock parser.
+#
+# Results:
+# Returns the name of the parser, which is an ensemble within
+# the "aycock" namespace.
+#
+# The following commands are members of the ensemble:
+# parse -- Parses a sequence of symbols and returns its lexical
+# value.
+# destroy -- Destroys the parser.
+# terminals -- Lists the terminal symbols accepted by the parser
+# nonterminals -- Lists the nonterminal symbols reduced by the parser
+# save -- Returns a command to recreate the parser without needing
+# to analyze the rule set.
+
+proc ::grammar::aycock::MakeParser {} {
+ variable parserCount
+ set name [namespace current]::parser[incr parserCount]
+ namespace eval $name {
+ namespace export parse terminals nonterminals save destroy
+ }
+ proc ${name}::parse {symList vallist {clientData {}}} \
+ [string map [list \
+ PROC [namespace current]::Parse \
+ PARSER $name] {
+ PROC PARSER $symList $vallist $clientData
+ }]
+ proc ${name}::terminals {} \
+ [list [namespace current]::Terminals $name]
+ proc ${name}::nonterminals {} \
+ [list [namespace current]::Nonterminals $name]
+ proc ${name}::save {} \
+ [list [namespace current]::Save $name]
+ proc ${name}::destroy {} \
+ [list namespace delete $name]
+ namespace eval $name {
+ namespace ensemble create
+ }
+ return $name
+}
+
+# grammar::aycock::ProcessRules --
+#
+# Processes the rule set presented to grammar::aycock::parser
+#
+# Parameters:
+# parser -- Name of the parser
+# rules -- Rule set
+#
+# Results:
+# None.
+#
+# Side effects:
+# RuleSet is set to be a dictionary indexed by nonterminal symbol
+# name, whose values are alternating right-hand sides and names
+# of action procedures. A set of Action procedures is constructed
+# for the reduction actions.
+
+proc ::grammar::aycock::ProcessRules {parser rules} {
+ namespace upvar $parser \
+ RuleSet RuleSet \
+ ActionProcs ActionProcs \
+ APCount APCount
+
+ # Locate the "::=" symbols within the rules.
+
+ set RuleSet [dict create]
+ set ActionProcs [dict create]
+ set APCount 0
+ set positions {}
+ set i 0
+ foreach sym $rules {
+ if {$sym eq {::=}} {
+ lappend positions [expr {$i-1}]
+ }
+ incr i
+ }
+ lappend positions [llength $rules]
+
+ # For each rule, place the right-hand side and action into
+ # the appropriate RuleSet entry.
+
+ set lastp [lindex $positions 0]
+ set top [lindex $rules $lastp]
+ foreach p [lrange $positions 1 end] {
+ set lhs [lindex $rules $lastp]
+ set rhs [lrange $rules [expr {$lastp + 2}] [expr {$p - 2}]]
+ set action [MakeAction $parser [lindex $rules [expr {$p - 1}]]]
+ set lastp $p
+ dict lappend RuleSet $lhs $rhs
+ dict lappend RuleSet $lhs $action
+ }
+
+ # Make a special "start" rule (whose name is the empty string)
+ # whose right-hand side is "right tack" followed by the name of
+ # the initial rule.
+
+ dict lappend RuleSet {} [list \u22a2 $top]
+ dict lappend RuleSet {} [MakeAction $parser {lindex $_ 1}]
+
+ # Clean up memory.
+
+ unset ${parser}::ActionProcs
+ unset ${parser}::APCount
+ return
+}
+
+# grammar::aycock::MakeAction --
+#
+# Defines an action procedure for the parser to use at run time.
+#
+# Parameters:
+# parser -- Name of the parser
+# body -- Body of the action procedure, which is expected to
+# return the semantic value of some nonterminal after reduction.
+#
+# Results:
+# Returns the name of the action procedure.
+#
+# Side effects:
+# Creates the action procedure, which will accept a single parameter,
+# "_", containing the semantic values of the symbols on the right-hand
+# side.
+
+proc ::grammar::aycock::MakeAction {parser {body {lindex $_ 0}}} {
+ namespace upvar $parser \
+ ActionProcs ActionProcs \
+ APCount APCount
+ if {$body eq {}} {
+ set body {lindex $_ 0}
+ }
+ if {![dict exists $ActionProcs $body]} {
+ set pname Action\#[incr APCount]
+ dict set ActionProcs $body $pname
+ namespace eval $parser [list proc $pname {_ clientData} $body]
+ }
+ return [dict get $ActionProcs $body]
+}
+
+# grammar::aycock::ComputeNullable --
+#
+# Determines which rules in the parser's rule set are nullable, that
+# is, can match the empty sequence of input symbols.
+#
+# Parameters:
+# parser -- Name of the parser.
+#
+# Results:
+# None.
+#
+# Side effects:
+# Sets 'Nullable' to a dictionary whose keys are nonterminal symbol
+# names and whose values are 1 if the symbol is nullable and 0 otherwise.
+
+proc ::grammar::aycock::ComputeNullable {parser} {
+ namespace upvar $parser \
+ RuleSet RuleSet \
+ Nullable Nullable
+ set Nullable [dict create]
+ set tbd {}
+ dict for {lhs rules} $RuleSet {
+ dict set Nullable $lhs 0
+ foreach {rhs action} $rules {
+ if {[llength $rhs] == 0} {
+ dict set Nullable $lhs 1
+ } else {
+ set ntonly 1
+ foreach sym $rhs {
+ if {![dict exists $RuleSet $sym]} {
+ set ntonly 0
+ break
+ }
+ }
+ if {$ntonly} {
+ lappend tbd $lhs $rhs
+ }
+ }
+ }
+ }
+ set changed 1
+ while {$changed} {
+ set changed 0
+ foreach {lhs rhs} $tbd {
+ if {![dict get $Nullable $lhs]} {
+ set nullable 1
+ foreach sym $rhs {
+ if {![dict get $Nullable $sym]} {
+ set nullable 0
+ break
+ }
+ }
+ if {$nullable} {
+ dict set Nullable $lhs 1
+ set changed 1
+ }
+ }
+ }
+ }
+ return
+}
+
+# grammar::aycock::RewriteGrammar --
+#
+# Rewrite $parser's grammar into Nihilistic Normal Form {NNF}
+#
+# Parameters:
+# parser -- Parser to rewrite.
+#
+# Results:
+# None.
+#
+# Side effects:
+# Rewrites the rule set to separate nullable rules from other
+# rules. The nullable rules are distinguished by having
+# "{\u00d8}" appended to their names.
+
+proc ::grammar::aycock::RewriteGrammar {parser} {
+ namespace upvar $parser \
+ RuleSet RuleSet \
+ Nullable Nullable
+ set newRuleSet [dict create]
+
+ # Create a work list wth all rules not yet examined
+
+ set worklist {}
+ dict for {lhs rules} $RuleSet {
+ foreach {rhs action} $rules {
+ lappend worklist $lhs $rhs 0 1 $action
+ }
+ }
+
+ # Process the rules in sequence from the worklist. For each rule,
+ # determine whether it contains a sequence of nullable symbols
+ # on the right-hand side. If it does, split it on the last nullable
+ # symbol. Continue until all possible splits have been done.
+
+ for {set k 0} {$k < [llength $worklist]} {incr k 5} {
+ foreach {lhs rhs position candidateFlag action} \
+ [lrange $worklist $k [expr {$k+4}]] break
+ set n [llength $rhs]
+ while {$position < $n} {
+ set sym [lindex $rhs $position]
+ if {![dict exists $Nullable $sym]
+ || ![dict get $Nullable $sym]} {
+ set candidateFlag 0
+ } else {
+ set newrhs $rhs
+ lset newrhs $position ${sym}\{\u00d8\}
+ lappend worklist $lhs $newrhs [expr {$position+1}] \
+ $candidateFlag $action
+ set candidateFlag 0
+ }
+ incr position
+ }
+ if {$position >= $n} {
+ if {$candidateFlag} {
+ set lhs ${lhs}\{\u00d8\}
+ }
+ dict lappend newRuleSet $lhs $rhs
+ dict lappend newRuleSet $lhs $action
+ }
+ }
+ set RuleSet $newRuleSet
+ unset Nullable
+ return
+}
+
+# grammar::aycock::DumpRuleSet --
+#
+# Displays the set of rules in a parser.
+#
+# Parameters:
+# parser - Name of the parser
+# chan - Channel on which to display the rules
+#
+# Results:
+# None.
+#
+# Side effects:
+# Displays the rule set on the given channel.
+
+proc ::grammar::aycock::DumpRuleSet {parser chan} {
+ namespace upvar $parser RuleSet RuleSet
+ dict for {lhs rules} $RuleSet {
+ dict for {rhs action} $rules {
+ puts $chan "$lhs ::= $rhs [list [info body ${parser}::${action}]]"
+ }
+ }
+ return
+}
+
+# grammar::aycock::MakeState0 --
+#
+# Makes the first state of a parser's automaton.
+#
+# Parameters:
+# parser -- Parser under construction.
+#
+# Results:
+# None.
+#
+# Side effects:
+# Builds a state corresponding to the reduction of the start
+# symbol. Creates "Completions", "Items", "Cores", and "Edges";
+# Completions will be a list of lists of right-hand-sides
+# completed in each state.
+# Items will be a list of LRE(0) items belonging to
+# the states. Each item is represented as three elements:
+# the nonterminal symbol, the rule number in that nonterminal's
+# rule list, and the position of the dot within the right-hand side.
+# Edges will be a two-level dictionary - the outer key is state
+# number and the inner key is a symbol - giving the 'goto' symbol
+# for a given state and symbol.
+# Cores is a work dictionary used to avoid state duplication.
+
+proc ::grammar::aycock::MakeState0 {parser} {
+ namespace upvar $parser \
+ RuleSet RuleSet \
+ Completions Completions \
+ Items Items \
+ Cores Cores \
+ Edges Edges
+ set items {}
+ set i 0
+ foreach {rhs action} [dict get $RuleSet {}] {
+ lappend items {} $i 0
+ incr i 2
+ }
+ set Completions [list {}]
+ set Items [list $items]
+ set Cores [dict create]
+ set Edges [dict create]
+ return
+}
+
+# grammar::aycock::MakeState --
+#
+# Constructs a state of the parsing automaton.
+#
+# Parameters:
+# parser -- Parser under construction
+# stateIdx - Ordinal number of a state being examined.
+# sym - Symbol whose goto is being computed
+#
+# Results:
+# Returns goto(state,sym)
+#
+# Side effects:
+# Constructs a new state if necessary, updating Completions, Items
+# Cores and Edges to reflect it.
+
+proc ::grammar::aycock::MakeState {parser stateIdx sym} {
+ namespace upvar $parser \
+ RuleSet RuleSet \
+ Completions Completions \
+ Items Items \
+ Cores Cores \
+ Edges Edges
+
+ if {$sym == {}} {
+ error "Null symbol in MakeState"
+ }
+
+ set complete [lindex $Completions $stateIdx]
+
+ # Compute the epsilon-kernel items for the given transition.
+
+ set Kitems {}
+ set items [lindex $Items $stateIdx]
+ foreach {lhs prodIndex pos} $items {
+ set rhs [lindex [dict get $RuleSet $lhs] $prodIndex]
+ if {[lindex $rhs $pos] == $sym} {
+ set nextPos [SkipOver $rhs [expr {$pos+1}]]
+ lappend Kitems [list $lhs $prodIndex $nextPos]
+ }
+ }
+
+ # Determine whether we've already built the state.
+
+ set core {}
+ foreach tuple \
+ [lsort -index 0 \
+ [lsort -integer -index 1 \
+ [lsort -integer -index 2 $Kitems]]] {
+ foreach {lhs prodIndex pos} $tuple break
+ lappend core $lhs $prodIndex $pos
+ }
+
+ if {[dict exists $Cores $core]} {
+ return [dict get $Cores $core]
+ }
+
+ # We haven't built it yet - so we need to build it now. Let k and
+ # nk be the state numbers for the epsilon-kernel and epsilon-non-kernel
+ # states.
+
+ set k [llength $Items]
+ set nk [expr {$k + 1}]
+
+ set Kitems $core
+ set NKitems {}
+
+ set Kedges [dict create]
+ set predicted [dict create]
+ set Kcomplete {}
+
+ # enumerate all the LRE(0) items in the epsilon-kernel set
+
+ foreach {lhs rhsIndex pos} $Kitems {
+ set rhs [lindex [dict get $RuleSet $lhs] $rhsIndex]
+ if {$pos == [llength $rhs]} {
+ # reduction
+ lappend Kcomplete $lhs $rhsIndex $pos
+ continue
+ } elseif {![dict exists $RuleSet [set nextSym [lindex $rhs $pos]]]} {
+ # transition on a terminal symbol
+ if {![dict exists $Kedges $nextSym] } {
+ dict set Kedges $nextSym {}
+ }
+ } else {
+ # GOTO on a nonterminal
+ dict set Kedges $nextSym {}
+ if {![dict exists $predicted $nextSym]} {
+ dict set predicted $nextSym 1
+ set prhsIndex 0
+ foreach {prhs paction} [dict get $RuleSet $nextSym] {
+ set ppos [SkipOver $prhs]
+ lappend NKitems $nextSym $prhsIndex $ppos
+ incr prhsIndex 2
+ }
+ }
+ }
+ }
+
+ # build the state for the epsilon-kernel
+
+ lappend Completions $Kcomplete
+ lappend Items $Kitems
+ dict set Edges $stateIdx $sym $k
+ dict set Edges $k $Kedges
+
+ if {[llength $NKitems] == 0} {
+ return $k
+ }
+
+ # now start with the non-kernel set. We need to build it before
+ # we can figure out whether we've built it already
+
+ set NKcomplete {}
+
+ # enumerate all the LRE(0) items in the non-kernel set
+
+ set NKedges [dict create]
+ set w 0
+ while {$w < [llength $NKitems] } {
+ foreach {lhs rhsIndex pos} [lrange $NKitems $w [expr {$w+2}]] break
+ incr w 3
+ set rhs [lindex [dict get $RuleSet $lhs] $rhsIndex]
+ if {$pos == [llength $rhs]} {
+ # reduction
+ lappend NKComplete [list $lhs $rhsIndex $pos]
+ continue
+ }
+ set nextSym [lindex $rhs $pos]
+ if {![dict exists $RuleSet $nextSym]} {
+ # transition on a terminal symbol
+ if {![dict exists $NKedges $nextSym]} {
+ dict set NKedges $nextSym {}
+ }
+ } else {
+ # GOTO on a nonterminal
+ dict set NKedges $nextSym {}
+ if {![dict exists $predicted $nextSym]} {
+ dict set predicted $nextSym 1
+ set prhsIndex 0
+ dict for {prhs paction} [dict get $RuleSet $nextSym] {
+ set ppos [SkipOver $prhs]
+ lappend NKitems $nextSym $prhsIndex $ppos
+ incr prhsIndex 2
+ }
+ }
+ }
+ }
+
+ # Now we might be able to add NKedges, and NK, or maybe we don't need to.
+
+ set core [lsort [dict keys $predicted]]
+ if {[dict exists $Cores $core]} {
+ dict set Edges $k {} [dict get $Cores $core]
+ } else {
+ dict set Cores $core $nk
+ dict set Edges $k {} $nk
+ lappend Completions $NKcomplete
+ lappend Items $NKitems
+ dict set Edges $nk $NKedges
+ }
+
+ # Return the new kernel state's number.
+
+ return $k
+
+}
+
+# grammar::aycock::SkipOver --
+#
+# Service procedure that skips over nullable symbols beginning at
+# a given position on a right-hand side.
+#
+# Parameters:
+# rhs - Right-hand side being analyzed
+# pos - Starting position within the rhs
+#
+# Results:
+# Returns the index of the first non-nullable symbol after $pos,
+# which will be the fictitious symbol beyond the end of the right-hand
+# side if no non-nullable symbols remain.
+
+proc ::grammar::aycock::SkipOver {rhs {pos 0}} {
+ set n [llength $rhs]
+ while {$pos < $n} {
+ if {[string range [lindex $rhs $pos] end-2 end] ne "\{\u00d8\}"} {
+ break
+ }
+ incr pos
+ }
+ return $pos
+}
+
+# grammar::aycock::CopmpleteAutomaton --
+#
+# Completes building the parser automaton once the first state
+# has been constructed.
+#
+# Parameters:
+# parser -- Name of the parser.
+#
+# Results:
+# None.
+#
+# Works by a brute-force approach: for each state, for each symbol
+# that the state can transition on, add goto(state,symbol) to the
+# state set; iterate until convergence.
+
+proc ::grammar::aycock::CompleteAutomaton {parser} {
+ namespace upvar $parser \
+ RuleSet RuleSet \
+ Items Items \
+ Edges Edges
+
+ set changes 1
+ while {$changes} {
+ set changes 0
+ set worklist {}
+ dict for {state d} [dict get $Edges] {
+ dict for {sym v} $d {
+ if {$v eq {}} {
+ if {$state < [llength $Items]} {
+ lappend worklist \
+ [list $state [dict exists $RuleSet $sym] $sym]
+ set changes 1
+ }
+ }
+ }
+ }
+ foreach tuple \
+ [lsort -integer -index 0 \
+ [lsort -integer -index 1 \
+ [lsort -dictionary -index 2 $worklist]]] {
+ foreach {state - sym} $tuple break
+ ::grammar::aycock::GoTo $parser $state $sym
+ }
+ }
+}
+
+# grammar::aycock::GoTo --
+#
+# Computes goto(state,symbol) in a parser.
+#
+# Parameters:
+# parser -- Name of the parser
+# state -- Index of the state
+# sym -- Symbol whose goto is being computed.
+#
+# Results:
+# Returns the goto entry.
+#
+# Side effects:
+# Constructs a new state if needed.
+
+proc ::grammar::aycock::GoTo {parser state sym} {
+ namespace upvar $parser Edges Edges
+ if {![dict exists $Edges $state] || ![dict exists $Edges $state $sym]} {
+ return {}
+ } else {
+ set rv [dict get $Edges $state $sym]
+ if {$rv eq {}} {
+ set rv [MakeState $parser $state $sym]
+ dict set Edges $state $sym $rv
+ }
+ }
+ return $rv
+}
+
+# grammar::aycock::DumpAutomaton --
+#
+# Displays the parsing automaton of an Aycock-Earley parser on a
+# channel.
+#
+# Parameters:
+# parser - Parser to display
+# chan - Channel to use
+#
+# Results:
+# None.
+#
+# Side effects:
+# Dumps the grammar (in NNF) and the states of the parsing
+# automaton. For each state, indicates the LRE(0) items in that
+# state, the completion list for the state, and the GOTO function
+# for the state.
+
+proc ::grammar::aycock::DumpAutomaton {parser chan} {
+ namespace upvar $parser \
+ Completions Completions \
+ Items Items \
+ Edges Edges
+ for {set ns 0} {$ns < [llength $Completions]} {incr ns} {
+ set completions [lindex $Completions $ns]
+ puts $chan "state $ns:"
+ if {[info exists Items]} {
+ set items [lindex $Items $ns]
+ DumpItemSet $parser $items $chan
+ puts $chan " ------------------------------"
+ }
+ puts $chan " completions:"
+ DumpItemSet $parser $completions $chan
+ puts $chan " ------------------------------"
+ puts $chan " goto:"
+ set worklist {}
+ dict for {sym nexts} [dict get $Edges $ns] {
+ if {$sym eq {}} {
+ set sym \u03b5
+ }
+ lappend worklist [list $sym $nexts]
+ }
+ foreach pair [lsort -integer -index 1 $worklist] {
+ foreach {sym nexts} $pair break
+ puts $chan [format " %-22s%4d" $sym $nexts]
+ }
+ puts $chan "------------------------------------"
+ }
+}
diff --git a/tcllib/modules/grammar_aycock/aycock-debug.tcl b/tcllib/modules/grammar_aycock/aycock-debug.tcl
new file mode 100644
index 0000000..883d639
--- /dev/null
+++ b/tcllib/modules/grammar_aycock/aycock-debug.tcl
@@ -0,0 +1,189 @@
+#----------------------------------------------------------------------
+#
+# aycock-debug.tcl --
+#
+# Procedures needed to debug an Aycock-Horspool-Earley parser.
+#
+# Copyright (c) 2006 by Kevin B. Kenny. All rights reserved.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: aycock-debug.tcl,v 1.2 2011/01/13 02:47:47 andreas_kupries Exp $
+#
+#----------------------------------------------------------------------
+
+package provide grammar::aycock::debug 1.0
+package require Tcl 8.4
+
+# Bring in the runtime library
+
+package require grammar::aycock::runtime 1.0
+
+# grammar::aycock::Terminals --
+#
+# List the terminal symbols used in a parser's grammar
+#
+# Usage:
+# $parser terminals
+#
+# Results:
+# Returns a list of the terminal symbols
+
+proc ::grammar::aycock::Terminals {parser} {
+ namespace upvar $parser RuleSet RuleSet
+ set t [dict create]
+ dict for {lhs rules} $RuleSet {
+ dict for {rhs action} $rules {
+ foreach sym $rhs {
+ if {$sym ne "\u22a2"} {
+ if {![dict exists $RuleSet $sym]} {
+ dict set t $sym {}
+ }
+ }
+ }
+ }
+ }
+ return [lsort -dictionary [dict keys $t]]
+}
+
+# grammar::aycock::Nonterminals --
+#
+# List the nonterminal symbols used in a parser's grammar
+#
+# Usage:
+# $parser nonterminals
+#
+# Results:
+# Returns a list of the nonterminal symbols
+
+proc ::grammar::aycock::Nonterminals {parser} {
+ namespace upvar $parser RuleSet RuleSet
+ set t [dict create]
+ dict for {lhs rules} $RuleSet {
+ dict for {rhs action} $rules {
+ foreach sym $rhs {
+ if {$sym ne "\u22a2"} {
+ if {[dict exists $RuleSet $sym]} {
+ dict set t $sym {}
+ }
+ }
+ }
+ }
+ }
+ return [lsort -dictionary [dict keys $t]]
+}
+
+# grammar::aycock::NeverReduced --
+#
+# Checks a parser's grammar for rules that cannot be reduced.
+#
+# Parameters:
+# parser -- Name of the parser
+#
+# Results:
+# Return a list of the left-hand sides of rules never reduced.
+
+proc ::grammar::aycock::NeverReduced {parser} {
+ namespace upvar $parser RuleSet RuleSet
+ set t [dict create]
+ foreach {lhs rules} $RuleSet {
+ dict set t $lhs {}
+ }
+ foreach s [Nonterminals $parser] {
+ dict unset t $s
+ }
+ dict unset t {}
+ return [lsort [dict keys $t]]
+}
+
+# grammar::aycock::Save --
+#
+# Produces a script that will load an Aycock-Earley parser without
+# needing to do all the state analysis.
+#
+# Usage:
+# $parser save
+#
+# Results:
+# Returns a script that when evaluated will reload the parser.
+
+proc ::grammar::aycock::Save {parser} {
+ namespace upvar $parser \
+ RuleSet RuleSet \
+ Completions Completions \
+ Edges Edges
+ set actions [dict create]
+ set rex1 {}
+ dict for {lhs rules} $RuleSet {
+ set rex2 {}
+ foreach {rhs action} $rules {
+ dict set actions $action {}
+ append rex2 \n \t [list $rhs $action]
+ }
+ append rex2 \n " "
+ append rex1 \n " " [list $lhs $rex2]
+ }
+ append rex1 \n
+ set i 0
+ set sex1 {}
+ foreach {completions} $Completions {
+ set nc 0
+ append sex1 \n " " [list $completions [dict get $Edges $i]]
+ incr i
+ }
+ append sex1 \n
+ set retval [list [namespace current]::Restore $rex1 $sex1]
+ foreach action [lsort -dictionary [dict keys $actions]] {
+ lappend retval $action \
+ [string trimright [info body ${parser}::$action]]\n
+ }
+ return $retval
+}
+
+# grammar::aycock::DumpItemSet --
+#
+# Displays a representation of an LRE(0) item set on a channel
+#
+# Parameters:
+# parser - Name of the parser
+# s - Item set to display
+# chan - Channel to use
+#
+# Results:
+# None
+#
+# Side effects:
+# Writes the LRE(0) item set on the given channel
+
+proc ::grammar::aycock::DumpItemSet {parser s {chan stdout}} {
+ foreach {lhs prodIndex pos} $s {
+ DumpItem $parser $lhs $prodIndex $pos $chan
+ }
+ return
+}
+
+# grammar::aycock::DumpItem --
+#
+# Displays a representation of an LRE(0) item on a channel
+#
+# Parameters:
+# parser - Name of the parser
+# lhs - Left-hand side of the reduction
+# prodIndex - Ordinal position of the right-hand side among
+# all right-hand sides for that LHS
+# pos - Position of the dot on the right-hand side
+# chan - Channel to use
+#
+# Results:
+# None
+#
+# Side effects:
+# Writes the LRE(0) item on the given channel
+
+proc ::grammar::aycock::DumpItem {parser lhs prodIndex pos {chan stdout}} {
+ namespace upvar $parser RuleSet RuleSet
+ set rhs [lindex [dict get $RuleSet $lhs] $prodIndex]
+ puts $chan " $lhs ::= [linsert $rhs $pos \u00b7]"
+ return
+}
diff --git a/tcllib/modules/grammar_aycock/aycock-runtime.tcl b/tcllib/modules/grammar_aycock/aycock-runtime.tcl
new file mode 100644
index 0000000..3a0081c
--- /dev/null
+++ b/tcllib/modules/grammar_aycock/aycock-runtime.tcl
@@ -0,0 +1,425 @@
+#----------------------------------------------------------------------
+#
+# aycock-runtime.tcl --
+#
+# Procedures needed to execute an Aycock-Horspool-Earley parser.
+#
+# Copyright (c) 2006 by Kevin B. Kenny. All rights reserved.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: aycock-runtime.tcl,v 1.2 2011/01/13 02:47:47 andreas_kupries Exp $
+#
+#----------------------------------------------------------------------
+
+package provide grammar::aycock::runtime 1.0
+package require Tcl 8.5
+
+# Define the directory containing this package's scripts
+
+namespace eval grammar {}
+namespace eval grammar::aycock {
+ variable parserCount 0
+}
+
+# grammar::aycock::Restore --
+#
+# Restores a parser from saved state.
+#
+# Parameters;
+# rules - Saved rule set
+# automaton - Saved automaton
+# args - Saved action procedures
+#
+# Results:
+# Returns the constructed parser's name
+#
+# Side effects:
+# Reconstructs the parser
+
+proc ::grammar::aycock::Restore {rules automaton args} {
+ set name [MakeParser]
+ variable ${name}::RuleSet
+ variable ${name}::Completions
+ variable ${name}::Edges
+ set RuleSet $rules
+ set Edges [dict create]
+ set Completions {}
+ set i 0
+ foreach {completions edges} $automaton {
+ lappend Completions $completions
+ dict set Edges $i $edges
+ incr i
+ }
+ foreach {actionName actionBody} $args {
+ namespace eval ${name} \
+ [list proc $actionName {_ clientData} $actionBody]
+ }
+ return ${name}
+}
+
+# grammar::aycock::MakeParser --
+#
+# Constructs the ensemble that will contain an Aycock parser.
+#
+# Results:
+# Returns the name of the parser, which is an ensemble within
+# the "aycock" namespace.
+#
+# The following commands are members of the ensemble:
+# parse -- Parses a sequence of symbols and returns its lexical
+# value.
+# destroy -- Destroys the parser.
+# terminals -- Lists the terminal symbols accepted by the parser
+# nonterminals -- Lists the nonterminal symbols reduced by the parser
+# save -- Returns a command to recreate the parser without needing
+# to analyze the rule set.
+
+proc ::grammar::aycock::MakeParser {} {
+ variable parserCount
+ set name [namespace current]::parser[incr parserCount]
+ namespace eval $name {
+ namespace export parse destroy
+ namespace export terminals nonterminals save
+ }
+ proc ${name}::parse {symList vallist {clientData {}}} \
+ [string map [list \
+ PROC [namespace current]::Parse \
+ PARSER $name] {
+ PROC PARSER $symList $vallist $clientData
+ }]
+ proc ${name}::terminals {} \
+ [list [namespace current]::Terminals $name]
+ proc ${name}::nonterminals {} \
+ [list [namespace current]::Nonterminals $name]
+ proc ${name}::save {} \
+ [list [namespace current]::Save $name]
+ proc ${name}::destroy {} \
+ [list namespace delete $name]
+ namespace eval $name {
+ namespace ensemble create
+ }
+ return $name
+}
+
+# grammar::aycock::MakeSet --
+#
+# Run one step of an Earley parse.
+#
+# Parameters:
+# parser -- Name of the parser
+# setsVar -- Sets of parser states already constructed
+# sym -- Input symbol
+#
+# Results:
+# Returns the sets of parser states updated with the transition on the
+# given input
+#
+# Each parser state is an ordered pair (automaton state, parent)
+# where parent is the position in the input string where the substring
+# matching the given state begins. A state set is a dictionary whose
+# keys are parser states and whose values are "links" - a link consists of
+# the automaton state, parent, and state set of the predecessor,
+# the automaton state, parent and state set of the cause, and
+# the LRE(0) parser state of the symbol being reduced - see Aycock's
+# paper for the details on how these are interpreted.
+
+proc ::grammar::aycock::MakeSet {parser setsVar sym} {
+ upvar 1 $setsVar sets
+ namespace upvar $parser \
+ Completions Completions \
+ Edges Edges
+
+ # Find the state index and set up "current" and "next" state sets.
+
+ set ip1 [llength $sets]
+ set i [expr {$ip1 - 1}]
+ set curSet [lindex $sets end]
+ set newSet {}
+
+ # Work through the "current" set to determine "next state" transitions.
+
+ set j 0
+ set worklist $curSet
+ while {$j < [llength $worklist]} {
+ set item [lindex $worklist $j]
+ incr j 2
+ foreach {state parent} $item break
+
+ # Advance using the 'goto' on the current input symbol
+
+ if {$sym ne {} && [dict exists $Edges $state $sym]} {
+ set k [dict get $Edges $state $sym]
+ set createdItem [list $k $parent]
+ set links [list $state $parent $i]
+ dict set newSet $createdItem $links {}
+
+ # Also add the epsilon-transition from that state
+
+ if {[dict exists $Edges $k {}]} {
+ set nk [dict get $Edges $k {}]
+ set createdItem [list $nk [expr {$i+1}]]
+ dict set newSet $createdItem {} {}
+ }
+ }
+
+ if {$parent != $i} {
+
+ # Reduce any completions in the current state, adding
+ # them to the worklist because their 'goto' items may
+ # also be shifted.
+
+ foreach {lhs rhs pos} [lindex $Completions $state] {
+ if {$lhs eq {}} continue
+ foreach pitem [lindex $sets $parent] {
+ foreach {pstate pparent} $pitem break
+ if {[dict exists $Edges $pstate $lhs]} {
+
+ # goto on the newly-reduced nonterminal
+
+ set k [dict get $Edges $pstate $lhs]
+ set createdItem [list $k $pparent]
+ set links [list $pstate $pparent $parent \
+ $state $parent $i \
+ $lhs $rhs $pos]
+ if {![dict exists $curSet $createdItem]} {
+ lappend worklist $createdItem $links
+ }
+ dict set curSet $createdItem $links {}
+ if {[dict exists $Edges $k {}]} {
+
+ # epsilon-transition from the nonterminal's goto
+
+ set nk [dict get $Edges $k {}]
+ set createdItem [list $nk $i]
+ if {![dict exists $curSet $createdItem]} {
+ lappend worklist $createdItem {}
+ }
+ dict set curSet $createdItem {} {}
+ }
+ }
+ }
+ }
+ }
+ }
+ set sets [lreplace $sets[set sets {}] end end $curSet $newSet]
+}
+
+# grammar::aycock::Parse --
+#
+# Runs an Aycock-Earley parser
+#
+# Usage:
+# $parser parse symlist vallist
+#
+# Parameters:
+# symlist - List of token names created by scanning an input
+# vallist - List of semantic values corresponding to the
+# tokens in $symlist
+# clientData - Client data to be passed to semantic action procedures
+#
+# Results:
+# Returns whatever the semantic action in the top-level reduction
+# of the parse returns.
+
+proc ::grammar::aycock::Parse {parser symlist vallist {clientData {}}} {
+ namespace upvar $parser \
+ RuleSet RuleSet \
+ Edges Edges
+ set sets [list [dict create [list 1 0] {} [list 2 0] {}]]
+ set i 0
+ foreach sym $symlist {
+ MakeSet $parser sets $sym
+ if {[llength [lindex $sets end]] == 0} {
+ return -code error "syntax error before symbol $i ($sym: [lindex $vallist $i])"
+ }
+ incr i
+ }
+ MakeSet $parser sets {}
+
+ set startSym [lindex [dict get $RuleSet {}] 0 1]
+ #set finalState [dict get $Edges 2 $startSym]
+ set finalState [dict get $Edges 1 $startSym]
+ # TODO - check that the final state *is* final... it has to contain an
+ # acceptor somewhere.
+ return [Reconstruct $parser {} $finalState 0 $vallist $sets \
+ [expr {[llength $sets] - 2}] $clientData]
+
+}
+
+# grammar::aycock::Reconstruct --
+#
+# Reconstructs the parse that leads to reducing a given nonterminal
+# symbol, and determines the nonterminal's semantic value.
+#
+# Parameters:
+# parser -- Aycock parser
+# nt - Name of the nonterminal being reduced
+# state - Parser state that contains the reduction
+# parent - Position in the input list of the start of the reduction
+# vallist - List of semantic values corresponding the the symbols
+# on the right hand side of the reduction
+# sets - List of sets generated by grammar::aycock::MakeSet
+# k - Position in the input list at the start of the reduction
+# clientData - Client data for semantic actions
+#
+# Results:
+# Returns the semantic value of the left-hand side of the reduction
+
+proc ::grammar::aycock::Reconstruct {parser nt state parent vallist sets k clientData} {
+ namespace upvar $parser \
+ RuleSet RuleSet \
+ Completions Completions \
+ Edges Edges
+ set choices {}
+ # Here it's possible that Completions contains completions for the
+ # wrong nonterminal?
+ set complete [lindex $Completions $state]
+ if {[llength $complete] != 3} {
+ set complete {}
+ foreach {lhs rhs pos} [lindex $Completions $state] {
+ if {$lhs eq $nt} {
+ lappend complete $lhs $rhs $pos
+ }
+ }
+ }
+ set compIdx [ChooseReduction $parser $complete]
+ foreach {lhs rhsIndex pos} \
+ [lrange $complete [expr {3*$compIdx}] [expr {3*$compIdx+2}]] break
+ foreach {rhs action} [lrange [dict get $RuleSet $lhs] $rhsIndex [expr {$rhsIndex+1}]] break
+ set cmd [list ${parser}::$action]
+ set args {}
+ foreach sym $rhs {
+ lappend args {}
+ }
+ for {set i [expr {[llength $rhs]-1}]} {$i >= 0} {incr i -1} {
+ set sym [lindex $rhs $i]
+ if {![dict exists $RuleSet $sym]} {
+ # terminal symbol
+ if {$sym != "\u22a2"} {
+ lset args $i [lindex $vallist [expr {$k-1}]]
+ set predecessors {}
+ dict for {key v} \
+ [dict get [lindex $sets $k] [list $state $parent]] {
+ foreach {pstate pparent pk cstate cparent ck
+ lhs rhsIndex pos} $key break
+ # should be only one transition on a terminal
+ break
+ }
+ set state $pstate
+ set parent $pparent
+ set k $pk
+ }
+ } elseif {[string range $sym end-2 end] == "\{\u00d8\}"} {
+ lset args $i [DeriveEpsilon $parser $sym $clientData]
+ } elseif {[dict exists [lindex $sets $k] [list $state $parent]]} {
+ set causes {}
+ set links [dict get [lindex $sets $k] [list $state $parent]]
+ set keys {}
+ set reductions {}
+ dict for {key v} $links {
+ foreach {pstate pparent pk cstate cparent ck \
+ lhs rhsIndex pos} $key break
+ lappend reductions $lhs $rhsIndex $pos
+ lappend keys $key
+ }
+ set keyIdx [ChooseReduction $parser $reductions]
+ set key [lindex $keys $keyIdx]
+ foreach {pstate pparent pk cstate cparent ck \
+ lhs rhsIndex pos} $key break
+ lset args $i \
+ [Reconstruct $parser $sym $cstate $cparent $vallist \
+ $sets $ck $clientData]
+ set state $pstate
+ set parent $pparent
+ set k $pk
+ } else {
+ return -code error "syntax error: incomplete parse"
+ }
+
+ }
+ set v [eval [list $cmd $args $clientData]]
+ return $v
+}
+
+# grammar::aycock::ChooseReduction --
+#
+# Resolves an ambiguity in an Aycock-Earley parse
+#
+# Parameters:
+# parser - Parser structure
+# lritems - List of LR items that could be reduced.
+#
+# Results:
+# Returns the ordinal number of the reduction to choose
+#
+# Always resolves in favour of the shortest right-hand side. This choice
+# is equivalent to choosing "resolve shift/reduce conflicts in favour
+# of shifting" in an LR parser, and is adequate to handling situations
+# like "dangling ELSE." It is not adequate for handling things like a
+# YACC-style ambiguous expression grammar with precedence and associativity;
+# that sort of processing would need additional investigation.
+
+proc ::grammar::aycock::ChooseReduction {parser lritems} {
+# if {[llength $lritems] != 3} {
+# puts "Need to choose which item to reduce:"
+# DumpItemSet $parser $lritems
+# }
+ # choose the shortest reduction - this is equivalent to
+ # "resolve in favour of shift"
+ set ind -1
+ set shortest 99999
+ set i 0
+ foreach {lhs rhsIndex pos} $lritems {
+ if {$pos < $shortest} {
+ set shortest $pos
+ set ind $i
+ }
+ incr i
+ }
+ return $ind
+}
+
+# grammar::aycock::DeriveEpsilon --
+#
+# Performs a set of semantic actions needed to derive the
+# empty string within a set of reductions in an Aycock-Earley parser.
+#
+# Parameters:
+# parser -- Parser data structure
+# sym -- Non-terminal symbol that reduces to the empty string.
+# clientData - Client data for semantic actions
+#
+# Results:
+# Returns the semantic value of the given symbol
+
+proc ::grammar::aycock::DeriveEpsilon {parser sym clientData} {
+ # need to find the rule that derives the null string, and
+ # expand it out.
+ namespace upvar $parser RuleSet RuleSet
+ set rules [dict get $RuleSet $sym]
+ set idx 0
+ if { [llength $rules] != 2 } {
+ set items {}
+ set i 0
+ foreach {rhs action} $rules {
+ lappend items $sym $i [llength $rhs]
+ incr i 2
+ }
+ set idx [expr {2 * [ChooseReduction $parser $items]}]
+ }
+ set rhs [lindex $rules $idx]
+ set action [lindex $rules [expr {$idx + 1}]]
+ set cmd [list ${parser}::$action]
+ set args {}
+ foreach sym $rhs {
+ lappend args {}
+ }
+ for {set i [expr {[llength $rhs] - 1}]} {$i >= 0} {incr i -1} {
+ lset args $i [DeriveEpsilon $parser [lindex $rhs $i] $clientData]
+ }
+ set r [eval [list $cmd $args $clientData]]
+ return $r
+
+}
diff --git a/tcllib/modules/grammar_aycock/aycock.man b/tcllib/modules/grammar_aycock/aycock.man
new file mode 100644
index 0000000..18f6340
--- /dev/null
+++ b/tcllib/modules/grammar_aycock/aycock.man
@@ -0,0 +1,139 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin grammar::aycock n 1.0]
+[keywords ambiguous]
+[keywords aycock]
+[keywords earley]
+[keywords grammar]
+[keywords horspool]
+[keywords parser]
+[keywords parsing]
+[keywords transducer]
+[copyright "2006 by Kevin B. Kenny <kennykb@acm.org>
+Redistribution permitted under the terms of the Open\
+Publication License <http://www.opencontent.org/openpub/>"]
+[moddesc "Aycock-Horspool-Earley parser generator for Tcl"]
+[titledesc "Aycock-Horspool-Earley parser generator for Tcl"]
+[category "Grammars and finite automata"]
+[require Tcl 8.5]
+[require grammar::aycock [opt 1.0]]
+[description]
+[para]
+The [package grammar::aycock] package
+implements a parser generator for the class of parsers described
+in John Aycock and R. Nigel Horspool. Practical Earley Parsing.
+[emph "The Computer Journal,"] [emph 45](6):620-630, 2002.
+[uri http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.12.4254]
+[section "PROCEDURES"]
+
+The [package grammar::aycock] package exports the single procedure:
+
+[list_begin definitions]
+[call [cmd ::aycock::parser] [arg grammar] [opt [option -verbose]]]
+
+Generates a parser for the given [arg grammar], and returns its
+name. If the optional [option -verbose] flag is given, dumps verbose
+information relating to the generated parser to the standard output.
+The returned parser is an object that accepts commands as shown in
+[sectref {OBJECT COMMAND}] below.
+
+[list_end]
+
+[section "OBJECT COMMAND"]
+
+[list_begin definitions]
+[call [arg parserName] [method parse] [arg symList] [arg valList] [opt [arg clientData]]]
+
+Invokes a parser returned from [cmd ::aycock::parser]. [arg symList] is
+a list of grammar symbols representing the terminals in an input
+string, and [arg valList] is a list of their semantic values. The
+result is the semantic value of the entire string when parsed.
+
+[call [arg parserName] [method destroy]]
+
+Destroys a parser constructed by [cmd ::aycock::parser].
+
+[call [arg parserName] [method terminals]]
+
+Returns a list of terminal symbols that may be presented in the
+[arg symList] argument to the [method parse] object command.
+
+[call [arg parserName] [method nonterminals]]
+
+Returns a list of nonterminal symbols that were defined in the
+parser's grammar.
+
+[call [arg parserName] [method save]]
+
+Returns a Tcl script that will reconstruct the parser without
+needing all the mechanism of the parser generator at run time.
+The reconstructed parser depends on a set of commands in the
+package [package grammar::aycock::runtime],
+which is also automatically loaded
+when the [package grammar::aycock] package is loaded.
+
+[list_end]
+
+[section "DESCRIPTION"]
+
+The [cmd grammar::aycock::parser] command accepts a grammar expressed as
+a Tcl list. The list must be structured as the concatenation of a set
+of [term rule]s. Each [term rule] comprises a variable number of
+elements in the list:
+
+[list_begin itemized]
+
+[item] The name of the nonterminal symbol that the rule reduces.
+
+[item] The literal string, [const "::="]
+
+[item] Zero or more names of terminal or nonterminal symbols that
+comprise the right-hand-side of the rule.
+
+[item] Finally, a Tcl script to execute when the rule is reduced.
+Within the given script, a variable called [var _] contains a list of
+the semantic values of the symbols on the right-hand side. The value
+returned by the script is expected to be the semantic value of the
+left-hand side. If the [arg clientData] parameter was passed to the
+[method parse] method, it is available in a variable called
+[var clientData]. It is permissible for the script to be the empty
+string. In this case, the semantic value of the rule will be the same
+as the semantic value of the first symbol on the right-hand side. If
+the right-hand side is also empty, the semantic value will be the
+empty string.
+
+[list_end]
+
+Parsing is done with an Earley parser, which is not terribly efficient
+in speed or memory consumption, but which deals effectively with
+ambiguous grammars. For this reason, the [package grammar::aycock] package is
+perhaps best adapted to natural-language processing or the parsing of
+extraordinarily complex languages in which ambiguity can be tolerated.
+
+[section EXAMPLE]
+
+The following code demonstrates a trivial desk calculator, admitting
+only [const +], [const *] and parentheses as its operators. It also
+shows the format in which the lexical analyzer is expected to present
+terminal symbols to the parser.
+
+[example {
+set p [aycock::parser {
+ start ::= E {}
+ E ::= E + T {expr {[lindex $_ 0] + [lindex $_ 2]}}
+ E ::= T {}
+ T ::= T * F {expr {[lindex $_ 0] * [lindex $_ 2]}}
+ T ::= F {}
+ F ::= NUMBER {}
+ F ::= ( E ) {lindex $_ 1}
+}]
+puts [$p parse {( NUMBER + NUMBER ) * ( NUMBER + NUMBER ) } \
+ {{} 2 {} 3 {} {} {} 7 {} 1 {}}]
+$p destroy
+}]
+
+The example, when run, prints [const 40].
+
+[section KEYWORDS]
+
+Aycock, Earley, Horspool, parser, compiler
+[manpage_end]
diff --git a/tcllib/modules/grammar_aycock/aycock.test b/tcllib/modules/grammar_aycock/aycock.test
new file mode 100644
index 0000000..f3ae1b1
--- /dev/null
+++ b/tcllib/modules/grammar_aycock/aycock.test
@@ -0,0 +1,196 @@
+# -*- tcl -*-
+# aycock.test --
+#
+# Tests for the Aycock-Earley-Horspool parser generator
+#
+# Tests for the Aycock-Earley-Horspool parser generator are quite rudimentary
+# at this point; they walk through only basic functionality and surely do not
+# explore corner cases.
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+support {
+ useLocal aycock-runtime.tcl grammar::aycock::runtime grammar::aycock
+ useLocalKeep aycock-debug.tcl grammar::aycock::debug grammar::aycock
+}
+testing {
+ useLocalKeep aycock-build.tcl grammar::aycock grammar::aycock
+}
+
+# -------------------------------------------------------------------------
+
+proc parser1 {} {
+ grammar::aycock::parser {
+ S ::= if E then S else S {
+ set _
+ }
+ S ::= if E then S {
+ set _
+ }
+ S ::= X {}
+ }
+}
+
+test aycock-1.1 {basic parser for an ambiguous grammar} {
+ -body {
+ set parser [parser1]
+ set result [$parser parse \
+ {if E then if E then X else X } \
+ {if E1 then if E2 then S1 else S2}]
+ $parser destroy
+ unset parser
+ set result
+ }
+ -cleanup {unset result}
+ -result {if E1 then {if E2 then S1 else S2}}
+}
+test aycock-1.2 {basic parser, another case} {
+ -setup {
+ set parser [parser1]
+ }
+ -body {
+ $parser parse \
+ {if E then if E then X else X else if E then X else X } \
+ {if E1 then if E2 then S1 else S2 else if E3 then S3 else S4}
+ }
+ -cleanup {$parser destroy; unset parser}
+ -result {if E1 then {if E2 then S1 else S2} else {if E3 then S3 else S4}}
+}
+
+test aycock-2.1 {save and restore a parser} {
+ -body {
+ set parser1 [parser1]
+ set saved [$parser1 save]
+ $parser1 destroy
+ set parser2 [eval $saved]
+ $parser2 parse \
+ {if E then if E then X else X } \
+ {if E1 then if E2 then S1 else S2}
+ }
+ -cleanup {
+ catch {$parser2 destroy}
+ catch {unset parser2}
+ catch {unset saved}
+ catch {$parser1 destroy}
+ catch {unset parser1}
+ }
+ -result {if E1 then {if E2 then S1 else S2}}
+}
+
+rename parser1 {}
+
+test aycock-3.1 {dangling else grammar, another form} {
+ -body {
+ set parser [grammar::aycock::parser {
+ S ::= if E then S elsepart {
+ set _
+ }
+ elsepart ::= else S {
+ set _
+ }
+ elsepart ::= {
+ list (empty)
+ }
+ S ::= X {}
+ }]
+ list [$parser parse \
+ {if E then if E then X else X } \
+ {if E1 then if E2 then S1 else S2}] \
+ [$parser parse \
+ {if E then if E then X else X else if E then X else X } \
+ {if E1 then if E2 then S1 else S2 else if E3 then S3 else S4}]
+ }
+ -cleanup {
+ catch {$parser destroy}
+ catch {unset parser}
+ }
+ -result {{if E1 then {if E2 then S1 (empty)} {else S2}} {if E1 then {if E2 then S1 {else S2}} {else {if E3 then S3 {else S4}}}}}
+}
+
+test aycock-3.2 {unary and binary operations, wrong precedence} {
+ -body {
+ set parser [grammar::aycock::parser {
+ E ::= E - E {set _}
+ E ::= E + E {set _}
+ E ::= UMINUS E {set _}
+ E ::= X {set _}
+ UMINUS ::= - {list UMINUS}
+ }]
+ list \
+ [$parser parse \
+ {- X - X} \
+ {- a - b}] \
+ [$parser parse \
+ {X - X - X} \
+ {a - b - c}] \
+ [$parser parse \
+ {X + X - X} \
+ {a + b - c}]
+ }
+ -cleanup {
+ catch {$parser destroy}
+ catch {unset parser}
+ }
+ -result {{UMINUS {a - b}} {{a - b} - c} {{a + b} - c}}
+}
+
+test aycock-4.1 {parses with lots of ambiguity} {
+ -body {
+ set parser [grammar::aycock::parser {
+ A ::= b B {set _}
+ B ::= P P Q {linsert $_ 0 rule1}
+ B ::= P Q Q {linsert $_ 0 rule2}
+ P ::= p {}
+ P ::= {list empty P}
+ Q ::= q {}
+ Q ::= {list empty Q}
+ }]
+ list \
+ [$parser parse {b} {b}] \
+ [$parser parse {b p q} {b p q}] \
+ [$parser parse {b q q} {b q q}]
+ }
+ -cleanup {
+ catch {$parser destroy}
+ catch {unset parser}
+ }
+ -result {{b {rule1 {empty P} {empty P} {empty Q}}} {b {rule1 {empty P} p q}} {b {rule2 {empty P} q q}}}
+}
+
+test aycock-5.1 {desk calculator skeleton} {
+ -body {
+ set p [grammar::aycock::parser {
+ start ::= E {}
+ E ::= E + T {expr {[lindex $_ 0] + [lindex $_ 2]}}
+ E ::= T {}
+ T ::= T * F {expr {[lindex $_ 0] * [lindex $_ 2]}}
+ T ::= F {}
+ F ::= NUMBER {}
+ F ::= ( E ) {lindex $_ 1}
+ }]
+ list \
+ [$p parse \
+ {NUMBER * NUMBER + NUMBER} \
+ {2 * 3 + 4 }] \
+ [$p parse \
+ {NUMBER * ( NUMBER + NUMBER )} \
+ {2 * ( 3 + 4 )}]
+ }
+ -cleanup {
+ catch {$p destroy}
+ catch {unset p}
+ }
+ -result {10 14}
+}
+
+# -------------------------------------------------------------------------
+
+tcltest::cleanupTests
+return
diff --git a/tcllib/modules/grammar_aycock/pkgIndex.tcl b/tcllib/modules/grammar_aycock/pkgIndex.tcl
new file mode 100644
index 0000000..1dc5d2f
--- /dev/null
+++ b/tcllib/modules/grammar_aycock/pkgIndex.tcl
@@ -0,0 +1,8 @@
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+
+package ifneeded grammar::aycock 1.0 \
+ [list source [file join $dir aycock-build.tcl]]
+package ifneeded grammar::aycock::debug 1.0 \
+ [list source [file join $dir aycock-debug.tcl]]
+package ifneeded grammar::aycock::runtime 1.0 \
+ [list source [file join $dir aycock-runtime.tcl]]
diff --git a/tcllib/modules/grammar_fa/ChangeLog b/tcllib/modules/grammar_fa/ChangeLog
new file mode 100644
index 0000000..44d50fb
--- /dev/null
+++ b/tcllib/modules/grammar_fa/ChangeLog
@@ -0,0 +1,368 @@
+2013-11-06 Andreas Kupries <andreask@activestate.com>
+
+ * fa.tcl: Extended the range of acceptable snit beyond 1.3-2 to
+ * pkgIndex.tcl: beyond 2. Bumped version to 0.5. Testsuite update
+ defered. Requires more work to update the wrong#args messages.
+
+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-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 ========================
+ *
+
+2009-10-27 Andreas Kupries <andreask@activestate.com>
+
+ * fa.man: Noted that the implementation could be simplified by
+ * fa.tcl: using snit's hierarchical methods. The changed methods
+ * pkgIndex.tcl: are 'start', 'final', 'symbol', and 'state'.
+ * tests/fa_final.test: Updated the testsuite, the error messages
+ * tests/fa_state.test: changed across branches of Tcl. Bumped
+ * tests/fa_symbol.test: version to 0.4 (Due to us bumping the
+ required snit to 1.3+).
+
+2009-02-13 Andreas Kupries <andreask@activestate.com>
+
+ * fa.tcl: Fixed [SF Tcllib Bug 2595296], renaming of states
+ * fa.man: having loop transitions. Bumped version to 0.3.1.
+ * pkgIndex.tcl: Extended testsuite.
+ * tests/fa_state.test:
+
+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 ========================
+ *
+
+2008-03-14 Andreas Kupries <andreask@activestate.com>
+
+ * faop.tcl (::grammar::fa::op::cons): Fixed bad return code,
+ * pkgIndex.tcl: reported in [SF Tcllib Bug 1826418], by Erik
+ * faop.man: Leunissen. Bumped to version 0.4.1.
+
+2007-12-03 Andreas Kupries <andreask@activestate.com>
+
+ * tests/faop_regex.test: Added examples for to(Tcl)Regexp provided
+ by Lars Hellstroem <lars_h@users.sourceforge.net>, see [Tcllib SF
+ Bug 1841979].
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-22 Andreas Kupries <andreask@activestate.com>
+
+ * faop.tcl: Extended the package with commands to convert finite
+ * faop.man: automatons back to regular expressions, simplify
+ * pkgIndex.tcl: regular expressions, and translate regular
+ * tests/faop_regexp.test: expressions to Tcl syntax. Extended the
+ documentation and testsuite. This fixes [SF Tcllib RFE 1735601],
+ submitted by Lars Hellstroem <lars_h@users.sourceforge.net>. He
+ submitted the code used for this as well. Documentation however
+ by myself, based on his comments in the original code (dtx
+ format). Version of the package bumped to 0.4.
+
+2007-08-21 Andreas Kupries <andreask@activestate.com>
+
+ * faop.man: Extend fromRegex and helper commands to accept zero
+ * faop.tcl: arguments for "|" (Choice) and "." (Sequence), to
+ * pkgIndex.tcl: represent empty language and epsilon
+ language. Documentation extended. Version of package fa::op
+ bumped to 0.3. This implements [SF Tcllib Bug 1759532], an RFE
+ submitted by Lars Hellstroem <lars_h@users.sourceforge.net>.
+
+2007-08-14 Andreas Kupries <andreask@activestate.com>
+
+ * tests/fa_symbols_at.test: Added proper documentation for the
+ * fa.tcl: methods symbols@ and symbols@set. Extended method
+ * fa.man: symbols@ to allow querying of symbols between two
+ * pkgIndex.tcl: states, extended documentation, and updated
+ testsuite. Bumped package version to 0.3.
+
+2007-06-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * faop.tcl: Replaced deprecated {expand} syntax in comments with
+ {*}.
+
+2007-04-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dacceptor.test: Added the switching of struct::set
+ * dexec.test: implementations to the testsuite.
+ * fa.test:
+ * faop.test:
+ * tests/da_accept.test:
+ * tests/da_cons.test:
+ * tests/de_cons.test:
+ * tests/de_exec.test:
+ * tests/fa_cons.test:
+ * tests/fa_ec.test:
+ * tests/fa_final.test:
+ * tests/fa_is.test:
+ * tests/fa_is_complete.test:
+ * tests/fa_is_deterministic.test:
+ * tests/fa_is_epsfree.test:
+ * tests/fa_is_useful.test:
+ * tests/fa_next.test:
+ * tests/fa_reach.test:
+ * tests/fa_serial.test:
+ * tests/fa_start.test:
+ * tests/fa_state.test:
+ * tests/fa_states.test:
+ * tests/fa_symbol.test:
+ * tests/fa_symbols.test:
+ * tests/fa_symbols_at.test:
+ * tests/fa_useful.test:
+ * tests/faop_complete.test:
+ * tests/faop_concat.test:
+ * tests/faop_determinize.test:
+ * tests/faop_difference.test:
+ * tests/faop_intersect.test:
+ * tests/faop_kleene.test:
+ * tests/faop_minimize.test:
+ * tests/faop_optional.test:
+ * tests/faop_regex.test:
+ * tests/faop_remeps.test:
+ * tests/faop_reverse.test:
+ * tests/faop_trim.test:
+ * tests/faop_union.test:
+
+2007-04-03 Andreas Kupries <andreask@activestate.com>
+
+ * dexec.tcl: Accepted [Tcllib RFE 1692954] and the associated
+ * dexec.man: patch [Tcllib Patch 1693491], by Bogdan
+ * pkgIndex.tcl: <rftghost@users.sourceforge.net>. Bumped version
+ * test/de_exec.test: number to 0.2. New API: State introspection,
+ additional callback invokation for state transitions. Updated
+ testsuite to accept the additional callbacks in the activity
+ traces.
+
+2007-03-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dacceptor.man: Fixed all warnings due to use of now deprecated
+ * dexec.man: commands. Added a section about how to give feedback.
+ * fa.man:
+ * faop.man:
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * faop.man: Bumped versions to 0.2
+ * faop.tcl:
+ * fa.man:
+ * fa.tcl:
+ * pkgIndex.tcl:
+
+2006-06-15 Andreas Kupries <andreask@activestate.com>
+
+ * fa.tcl: Reworked the internal of the container and
+ * faop.tcl: operations packages to break their circularity.
+ * fa.test: The user of the operations packages now has to
+ * faop.test: specify a command to construct containers. The
+ * dexec.test: uses the ops package and sets its own class
+ * dacceptor.text: command as constructor.
+ * fa.man:
+ * faop.man:
+
+2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tests/fa_symbols_at.test: Fixed use of duplicate test names.
+ * tests/fa_symbol.test:
+ * tests/faop_remeps.test:
+ * tests/faop_reverse.test:
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dacceptor.test: More boilerplate simplified via use of test support.
+ * dexec.test:
+ * fa.test:
+ * faop.test:
+
+ * tests/faop_trim.test: Replaced old 'queryconstraint' with proper
+ * tests/fa_serial.test: 'testConstraint' call.
+ * tests/fa_is_useful.test:
+ * tests/fa_is_deterministic.test:
+ * tests/da_cons.test:
+ * tests/de_cons.test:
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dacceptor.test: Hooked into the new common test support code.
+ * dexec.test:
+ * fa.test:
+ * faop.test:
+
+2006-01-10 Andreas Kupries <andreask@activestate.com>
+
+ * dacceptor.test: Fixed [SF Tcllib Bug 1316040]. Uncluttering test
+ * dexec.test: output.
+ * fa.test:
+ * faop.test:
+ * tests/da_accept.test:
+ * tests/de_exec.test:
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-09-20 Andreas Kupries <akupries@shaw.ca>
+
+ * tests/fa_final.test: Fixed problems of testsuite with
+ * tests/fa_next.test: Tcl 8.5, caused by changes to the
+ * tests/fa_start.test: proc error messages.
+ * tests/fa_state.test:
+ * tests/fa_symbol.test:
+
+2004-11-22 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Fixed usage of wrong file for package 'dacceptor'.
+
+2004-11-11 Andreas Kupries <andreask@activestate.com>
+
+ * fa.man: Removed duplicate description of method
+ startstates. Fixed typos (wrong term, missing word).
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-08-05 Andreas Kupries <andreask@activestate.com>
+
+ * tests/fa_is_deterministic.test:
+ * tests/fa_is_useful.test:
+ * tests/da_cons.test: Introduced constraint 'runtotal'.
+ * tests/de_cons.test: Skip the most timeconsuming tests
+ * tests/fa_serial.test: if the constraint is off (default).
+ * tests/faop_trim.test: Reduces #tests from 58143 to 2410.
+ (fa_serial, faop_trim are the biggest hitters).
+
+ * ../../all.tcl: Added command 'queryConstraint' for portability.
+
+2004-07-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tests/da_cons.test: Updated tests to changed error message of snit.
+ * tests/de_cons.test:
+
+ * tests/faop_difference.test: Fixed problem with missing object
+ * tests/faop_intersect.test: destruction uncovered by the new
+ checks in snit which cause it to avoid overwriting an existing
+ command.
+
+2004-07-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * faop.man: Inserted the correct package names into the
+ * fa.man: manpage headers.
+ * dexec.man:
+ * dacceptor.man:
+
+2004-05-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dacceptor.test: Adapted to changes in the struct package.
+ * dexec.test: Now importing only the needed structures
+ * fa.test: (list, set operations). Updated all test
+ * faop.test: suites in the same way. Updated all manpages
+ * dacceptor.tcl: to contain the correct package requirements
+ * dexec.tcl: as well.
+ * fa.tcl:
+ * faop.tcl:
+ * dacceptor.man:
+ * dexec.man:
+ * fa.man:
+ * faop.man:
+
+2004-04-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dacceptor.man: Slight renaming of a section for better
+ understanding.
+
+ * dexec.tcl: New package, execution of deterministic
+ * dexec.man: finite automatons. Executors can do only this,
+ * dexec.test: and cannot be manipulated. Added reference
+ * fa.man: to this package to the FA documenation.
+ * tests/de_cons.test:
+ * tests/de_exec.test:
+
+2004-04-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * dacceptor.tcl: New package, deterministic acceptors
+ * dacceptor.man: out of deterministic finite automaton.
+ * dacceptor.test: Acceptors do only this check, and cannot
+ * fa.man: be manipulated. Added reference to this
+ package to the FA documenation.
+ * tests/da_cons.test:
+ * tests/da_accept.test:
+
+ * fa.tcl: Added fromRegex constructor operation. Updated
+ * fa.man: the documentation, and testsuite. Typo fixes in
+ * fa.test: documentation as well.
+
+2004-04-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * faop.tcl: Complement requires deterministic input for a correct
+ * faop.man: result. Fixed. Updated documentation as well. Typo
+ fixes in doc.
+
+2004-04-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * test_support.tcl: Renamed to tests.support. Prevents the
+ * fa.test: installation of this internal file.
+ * faop.test: Updated the test suites.
+
+2004-04-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * All files: Bugfixes in basic FA support. Updated tests, updated
+ documentation. Completed implementation of more comlex FA
+ operations, their documentation, and their tests. Test suite is
+ now definitely in overkill, taking 13 minutes to run :P
+
+2004-03-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tests/fa_state.test
+ * tests/fa_is_complete.test
+ * tests/fa_is_cons.test
+ * fa.tcl: Fixed definition of 'is complete' for FAs without
+ symbols. Updated tests. Fixed deletion of states, added test for
+ the fixed case. Aded construction from serialization. Updated
+ tests. Added cache for epsilon closures.
+
+ * fa.man: Removed the remnants of the documentation for 'state
+ priority'. Added the missing documentation for all 'is' commands
+ beyond 'deterministic'.
+
+2004-03-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module: Grammar operations, Finite Automatons.
+
diff --git a/tcllib/modules/grammar_fa/dacceptor.man b/tcllib/modules/grammar_fa/dacceptor.man
new file mode 100644
index 0000000..6407ce5
--- /dev/null
+++ b/tcllib/modules/grammar_fa/dacceptor.man
@@ -0,0 +1,102 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin grammar::fa::dacceptor n 0.1.1]
+[keywords acceptance]
+[keywords acceptor]
+[keywords automaton]
+[keywords {finite automaton}]
+[keywords grammar]
+[keywords parsing]
+[keywords {regular expression}]
+[keywords {regular grammar}]
+[keywords {regular languages}]
+[keywords state]
+[keywords transducer]
+[copyright {2004 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Finite automaton operations and usage}]
+[titledesc {Create and use deterministic acceptors}]
+[category {Grammars and finite automata}]
+[require Tcl 8.4]
+[require snit]
+[require struct::set]
+[require grammar::fa::dacceptor [opt 0.1.1]]
+[description]
+[para]
+
+This package provides a class for acceptors constructed from
+deterministic [term {finite automatons}] (DFA). Acceptors are objects
+which can be given a string of symbols and tell if the DFA they are
+constructed from would [term accept] that string.
+
+For the actual creation of the DFAs the acceptors are based on we have
+the packages [package grammar::fa] and [package grammar::fa::op].
+
+[para]
+
+[section API]
+
+The package exports the API described here.
+
+[list_begin definitions]
+
+[call [cmd ::grammar::fa::dacceptor] [arg daName] [arg fa] [opt "[option -any] [arg any]"]]
+
+Creates a new deterministic acceptor with an associated global Tcl command
+whose name is [arg daName]. This command may be used to invoke various
+operations on the acceptor. It has the following general form:
+
+[list_begin definitions]
+
+[call [cmd daName] [arg option] [opt [arg "arg arg ..."]]]
+
+[arg Option] and the [arg arg]s determine the exact behavior of the
+command. See section [sectref {ACCEPTOR METHODS}] for more explanations.
+
+[para]
+
+The acceptor will be based on the deterministic finite automaton
+stored in the object [arg fa]. It will keep a copy of the relevant
+data of the FA in its own storage, in a form easy to use for its
+purposes. This also means that changes made to the [arg fa] after the
+construction of the acceptor [emph {will not}] influence the acceptor.
+
+[para]
+
+If [arg any] has been specified, then the acceptor will convert all
+symbols in the input which are unknown to the base FA to that symbol
+before proceeding with the processing.
+
+[list_end]
+[list_end]
+
+[section {ACCEPTOR METHODS}]
+[para]
+
+All acceptors provide the following methods for their manipulation:
+
+[list_begin definitions]
+
+[call [arg daName] [method destroy]]
+
+Destroys the automaton, including its storage space and associated
+command.
+
+[call [arg daName] [method accept?] [arg symbols]]
+
+Takes the list of [arg symbols] and checks if the FA the acceptor is
+based on would accept it. The result is a boolean value. [const True]
+is returned if the symbols are accepted, and [const False]
+otherwise. Note that bogus symbols in the input are either translated
+to the [arg any] symbol (if specified), or cause the acceptance test
+to simply fail. No errors will be thrown. The method will process only
+just that prefix of the input which is enough to fully determine
+(non-)acceptance.
+
+[list_end]
+
+[para]
+
+[section EXAMPLES]
+
+[vset CATEGORY grammar_fa]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/grammar_fa/dacceptor.tcl b/tcllib/modules/grammar_fa/dacceptor.tcl
new file mode 100644
index 0000000..479db0c
--- /dev/null
+++ b/tcllib/modules/grammar_fa/dacceptor.tcl
@@ -0,0 +1,166 @@
+# -*- tcl -*-
+# Grammar / Finite Automatons / Acceptance checker, DFA only
+
+# ### ### ### ######### ######### #########
+## Package description
+
+## A class whose instances take a FA and are able to check strings of
+## symbols for acceptance. This class is restricted to deterministic
+## FAs. The FA can be either a reference to some external FA container
+## object, or a copy of such. The latter makes the acceptor impervious
+## to changes in the original definition.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require snit ; # Tcllib | OO system used
+package require struct::set ; # Tcllib | Extended set operations.
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+snit::type ::grammar::fa::dacceptor {
+ # ### ### ### ######### ######### #########
+ ## Type API.
+
+ # ### ### ### ######### ######### #########
+ ## Instance API.
+
+ #constructor {fa args} {}
+ #destructor {}
+
+ method accept? {symbolstring} {}
+
+ option -any {}
+
+ # ### ### ### ######### ######### #########
+ ## Internal data structures.
+
+ ## We take the relevant information from the FA specified during
+ ## construction, i.e. start state, final states, and transition
+ ## table in form for direct indexing and keep it local. No need to
+ ## access or even the full FA. We require a deterministic one, and
+ ## will complete it, if necessary.
+
+ variable start ; # Name of start state.
+ variable final ; # Array, existence = state is final.
+ variable trans ; # Transition array: state x symbol -> state
+ variable sym ; # Symbol set (as array), for checking existence.
+ variable any ; # Symbol to map any unknown symbol to. If not
+ # ; # specified (eq "") then unknown symbols will cause non-
+ # ; # acceptance.
+ variable stop ; # Stop state, causing immediate non-acceptance when entered.
+
+ # ### ### ### ######### ######### #########
+ ## Instance API Implementation.
+
+ constructor {fa args} {
+ set any {}
+ $self configurelist $args
+
+ if {![$fa is deterministic]} {
+ return -code error "Source FA is not deterministic"
+ }
+ if {($any ne "") && ![$fa symbol exists $any]} {
+ return -code error "Chosen any symbol \"$any\" does not exist"
+ }
+
+ if {![$fa is complete]} {
+ set istmp 1
+ set tmp [grammar::fa ${selfns}::fa = $fa]
+ set before [$tmp states]
+ $tmp complete
+ # Our sink is a stop state.
+ set stop [struct::set difference [$tmp states] $before]
+ } else {
+ set istmp 0
+ set tmp $fa
+ # We don't know if there is a sink, so no quickstop.
+ set stop {}
+ }
+
+ set start [lindex [$tmp startstates] 0]
+ foreach s [$tmp finalstates] {set final($s) .}
+ foreach s [set syms [$tmp symbols]] {set sym($s) .}
+
+ foreach s [$tmp states] {
+ foreach sy $syms {
+ set trans($s,$sy) [lindex [$tmp next $s $sy] 0]
+ }
+ }
+
+ if {$istmp} {$tmp destroy}
+ return
+ }
+
+ #destructor {}
+
+ onconfigure -any {value} {
+ set options(-any) $value
+ set any $value
+ return
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ method accept? {symbolstring} {
+ set state $start
+
+ ## puts "\n====================== ($symbolstring)"
+
+ if {$any eq ""} {
+ # No any mapping of unknown symbols.
+
+ foreach sy $symbolstring {
+ if {![info exists sym($sy)]} {
+ # Bad symbol in input. String is not accepted,
+ # abort immediately.
+ ## puts " \[$state\] -- Unknown symbol ($sy)"
+ return 0
+ }
+
+ ## puts " \[$state\] --($sy)--> "
+
+ set state $trans($state,$sy)
+ # state == "" cannot happen, as our FA is complete.
+ if {$state eq $stop} {
+ # This is a known sink, we can stop processing input now.
+ ## puts " \[$state\] FULL STOP"
+ return 0
+ }
+ }
+
+ } else {
+ # Mapping of unknown symbols to any.
+
+ foreach sy $symbolstring {
+ if {![info exists sym($sy)]} {set sy $any}
+ ## puts " \[$state\] --($sy)--> "
+ set state $trans($state,$sy)
+ # state == "" cannot happen, as our FA is complete.
+ if {$state eq $stop} {
+ # This is a known sink, we can stop processing input now.
+ ## puts " \[$state\] FULL STOP"
+ return 0
+ }
+ }
+ }
+
+ ## puts " \[$state\][expr {[info exists final($state)] ? " ACCEPT" : ""}]"
+
+ return [info exists final($state)]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Type API implementation.
+
+ # ### ### ### ######### ######### #########
+ ## Type Internals.
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Package Management
+
+package provide grammar::fa::dacceptor 0.1.1
diff --git a/tcllib/modules/grammar_fa/dacceptor.test b/tcllib/modules/grammar_fa/dacceptor.test
new file mode 100644
index 0000000..e12898b
--- /dev/null
+++ b/tcllib/modules/grammar_fa/dacceptor.test
@@ -0,0 +1,45 @@
+# -*- tcl -*-
+# daccept.test: tests for the grammar::fa::dacceptor - DFA acceptor class
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: dacceptor.test,v 1.10 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 1.0
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use snit/snit.tcl snit ; # 1.1 always, even when Tcl 8.5 runs the testsuite.
+ use struct/list.tcl struct::list
+
+ useLocal faop.tcl grammar::fa::op
+ useLocalKeep fa.tcl grammar::fa
+
+ useLocalFile tests/Xsupport
+}
+testing {
+ useLocal dacceptor.tcl grammar::fa::dacceptor
+}
+
+# -------------------------------------------------------------------------
+
+set class ::grammar::fa::dacceptor
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::set setimpl {
+ TestFiles tests/da_*.test
+}
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
diff --git a/tcllib/modules/grammar_fa/dexec.man b/tcllib/modules/grammar_fa/dexec.man
new file mode 100644
index 0000000..fac0074
--- /dev/null
+++ b/tcllib/modules/grammar_fa/dexec.man
@@ -0,0 +1,183 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin grammar::fa::dexec n 0.2]
+[keywords automaton]
+[keywords execution]
+[keywords {finite automaton}]
+[keywords grammar]
+[keywords parsing]
+[keywords {regular expression}]
+[keywords {regular grammar}]
+[keywords {regular languages}]
+[keywords running]
+[keywords state]
+[keywords transducer]
+[copyright {2004 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[copyright {2007 Bogdan <rftghost@users.sourceforge.net>}]
+[moddesc {Finite automaton operations and usage}]
+[titledesc {Execute deterministic finite automatons}]
+[category {Grammars and finite automata}]
+[require Tcl 8.4]
+[require snit]
+[require grammar::fa::dexec [opt 0.2]]
+[description]
+[para]
+
+This package provides a class for executors constructed from
+deterministic [term {finite automatons}] (DFA). Executors are objects
+which are given a string of symbols in a piecemal fashion, perform
+state transitions and report back when they enter a final state, or
+find an error in the input.
+
+For the actual creation of the DFAs the executors are based on we have
+the packages [package grammar::fa] and [package grammar::fa::op].
+
+[para]
+
+The objects follow a push model. Symbols are pushed into the executor,
+and when something important happens, i.e. error occurs, a state transition,
+or a final state is entered this will be reported via the callback
+specified via the option [option -command]. Note that conversion of
+this into a pull model where the environment retrieves messages from
+the object and the object uses a callback to ask for more symbols is
+a trivial thing.
+
+[para]
+
+[emph {Side note}]:
+
+The acceptor objects provided by [package grammar::fa::dacceptor]
+could have been implemented on top of the executors provided here, but
+were not, to get a bit more performance (we avoid a number of method
+calls and the time required for their dispatch).
+
+[para]
+
+[section API]
+
+The package exports the API described here.
+
+[list_begin definitions]
+
+[call [cmd ::grammar::fa::dexec] [arg daName] [arg fa] [opt "[option -any] [arg any]"] [opt "[option -command] [arg cmdprefix]"]]
+
+Creates a new deterministic executor with an associated global Tcl
+command whose name is [arg daName]. This command may be used to invoke
+various operations on the executor. It has the following general form:
+
+[list_begin definitions]
+
+[call [cmd daName] [arg option] [opt [arg "arg arg ..."]]]
+
+[arg Option] and the [arg arg]s determine the exact behavior of the
+command. See section [sectref {EXECUTOR METHODS}] for more
+explanations.
+
+[para]
+
+The executor will be based on the deterministic finite automaton
+stored in the object [arg fa]. It will keep a copy of the relevant
+data of the FA in its own storage, in a form easy to use for its
+purposes. This also means that changes made to the [arg fa] after the
+construction of the executor [emph {will not}] influence the executor.
+
+[para]
+
+If [arg any] has been specified, then the executor will convert all
+symbols in the input which are unknown to the base FA to that symbol
+before proceeding with the processing.
+
+[list_end]
+[list_end]
+
+[section {EXECUTOR METHODS}]
+[para]
+
+All executors provide the following methods for their manipulation:
+
+[list_begin definitions]
+
+[call [arg daName] [method destroy]]
+
+Destroys the automaton, including its storage space and associated
+command.
+
+[call [arg daName] [method put] [arg symbol]]
+
+Takes the current state of the executor and the [arg symbol] and
+performs the appropriate state transition. Reports any errors
+encountered via the command callback, as well as entering a final
+state of the underlying FA.
+
+[para]
+
+When an error is reported all further invokations of [method put] will
+do nothing, until the error condition has been cleared via an
+invokation of method [method reset].
+
+[call [arg daName] [method reset]]
+
+Unconditionally sets the executor into the start state of the
+underlying FA. This also clears any error condition [method put] may
+have encountered.
+
+[call [arg daName] [method state]]
+
+Returns the current state of the underlying FA. This allow for
+introspection without the need to pass data from the callback command.
+
+[list_end]
+
+[section {EXECUTOR CALLBACK}]
+
+The callback command [arg cmdprefix] given to an executor via the
+option [option -command] will be executed by the object at the global
+level, using the syntax described below. Note that [arg cmdprefix] is
+not simply the name of a command, but a full command prefix. In other
+words it may contain additional fixed argument words beyond the
+command word.
+
+[list_begin definitions]
+
+[call [arg cmdprefix] [method error] [arg code] [arg message]]
+
+The executor has encountered an error, and [arg message] contains a
+human-readable text explaining the nature of the problem.
+
+The [arg code] on the other hand is a fixed machine-readable text.
+The following error codes can be generated by executor objects.
+
+[list_begin definitions]
+[def [const BADSYM]]
+
+An unknown symbol was found in the input. This can happen if and only
+if no [option -any] symbol was specified.
+
+[def [const BADTRANS]]
+
+The underlying FA has no transition for the current combination of
+input symbol and state. In other words, the executor was not able to
+compute a new state for this combination.
+
+[list_end]
+
+[call [arg cmdprefix] [method final] [arg stateid]]
+
+The executor has entered the final state [arg stateid].
+
+[call [arg cmdprefix] [method reset]]
+
+The executor was reset.
+
+[call [arg cmdprefix] [method state] [arg stateid]]
+
+The FA changed state due to a transition. [arg stateid] is the new state.
+
+[list_end]
+
+[para]
+
+[section EXAMPLES]
+
+[vset CATEGORY grammar_fa]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/grammar_fa/dexec.tcl b/tcllib/modules/grammar_fa/dexec.tcl
new file mode 100644
index 0000000..022ec18
--- /dev/null
+++ b/tcllib/modules/grammar_fa/dexec.tcl
@@ -0,0 +1,188 @@
+# -*- tcl -*-
+# Grammar / Finite Automatons / Executor, DFA only
+
+# ### ### ### ######### ######### #########
+## Package description
+
+## Instances take a DFA, keep a current state and update it in
+## reaction incoming symbols. Notable events are reported via
+## callback. Currently notable: Reset, reached a final state,
+# reached an error.
+
+## From the above description it should be clear that this class is
+## run in a push fashion. If not the last sentence has made this
+## explicit, right ? Right!
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require snit ; # Tcllib | OO system used
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+snit::type ::grammar::fa::dexec {
+ # ### ### ### ######### ######### #########
+ ## Type API.
+
+ # ### ### ### ######### ######### #########
+ ## Instance API.
+
+ #constructor {fa args} {}
+ #destructor {}
+
+ method reset {} {}
+ method put {sy} {}
+ method state {} {}
+
+ option -command {}
+ option -any {}
+
+ # ### ### ### ######### ######### #########
+ ## Internal data structures.
+
+ ## We take the relevant information from the FA specified during
+ ## construction, i.e. start state, final states, and transition
+ ## table in form for direct indexing and keep it local. No need to
+ ## access or even the full FA. We require a deterministic one, and
+ ## will complete it, if necessary.
+
+ variable start ; # Name of start state.
+ variable final ; # Array, existence = state is final.
+ variable trans ; # Transition array: state x symbol -> state
+ variable sym ; # Symbol set (as array), for checking existence.
+ variable cmd ; # Command to call for various events. Required.
+ variable any ; # Symbol to map any unknown symbol to. If not
+ # ; # specified (eq "") then unknown symbols will cause non-
+ # ; # acceptance.
+ variable curr ; # State the underlying DFA is currently in.
+ variable inerr ; # Boolean flag. Set if an error was reached.
+
+
+ # ### ### ### ######### ######### #########
+ ## Instance API Implementation.
+
+ constructor {fa args} {
+ set any {}
+ set cmd {}
+ $self configurelist $args
+
+ if {![$fa is deterministic]} {
+ return -code error "Source FA is not deterministic"
+ }
+ if {($any ne "") && ![$fa symbol exists $any]} {
+ return -code error "Chosen any symbol \"$any\" does not exist"
+ }
+ if {![llength $cmd]} {
+ return -code error "Command callback missing"
+ }
+
+ # In contrast to the acceptor we do not complete the FA. We
+ # will later report BADTRANS errors instead if a non-existing
+ # transition is attempted. For the acceptor it made sense as
+ # it made the accept/!accept decision easier. However here for
+ # the generic execution it is unreasonable interference with
+ # whatever higher levels might wish to do when encountering
+ # this.
+
+ set start [lindex [$fa startstates] 0]
+ foreach s [$fa finalstates] {set final($s) .}
+ foreach s [set syms [$fa symbols]] {set sym($s) .}
+
+ foreach s [$fa states] {
+ foreach sy [$fa symbols@ $s] {
+ set trans($s,$sy) [lindex [$fa next $s $sy] 0]
+ }
+ }
+
+ $self reset
+ return
+ }
+
+ #destructor {}
+
+ onconfigure -command {value} {
+ set options(-command) $value
+ set cmd $value
+ return
+ }
+
+ onconfigure -any {value} {
+ set options(-any) $value
+ set any $value
+ return
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ method reset {} {
+ set curr $start
+ set inerr 0
+ ## puts -nonewline " \[$curr\]" ; flush stdout
+
+ uplevel #0 [linsert $cmd end \
+ reset]
+ return
+ }
+
+ method state {} {
+ return $curr
+ }
+
+ method put {sy} {
+ if {$inerr} return
+ ## puts " --($sy)-->"
+
+ if {![info exists sym($sy)]} {
+ if {$any eq ""} {
+ # No any mapping of unknown symbols, report as error
+ ## puts " BAD SYMBOL"
+
+ set inerr 1
+ uplevel #0 [linsert $cmd end \
+ error BADSYM "Bad symbol \"$sy\""]
+ return
+ } else {
+ # Mapping of unknown symbols to any.
+ set sy $any
+ }
+ }
+
+ if {[catch {
+ set new $trans($curr,$sy)
+ }]} {
+ ## puts " NO DESTINATION"
+ set inerr 1
+ uplevel #0 [linsert $cmd end \
+ error BADTRANS "Bad transition (\"$curr\" \"$sy\"), no destination"]
+ return
+ }
+ set curr $new
+
+ uplevel #0 [linsert $cmd end \
+ state $curr]
+
+ ## puts -nonewline " \[$curr\]" ; flush stdout
+
+ if {[info exists final($curr)]} {
+ ## puts -nonewline " FINAL" ; flush stdout
+
+ uplevel #0 [linsert $cmd end \
+ final $curr]
+ }
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Type API implementation.
+
+ # ### ### ### ######### ######### #########
+ ## Type Internals.
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Package Management
+
+package provide grammar::fa::dexec 0.2
diff --git a/tcllib/modules/grammar_fa/dexec.test b/tcllib/modules/grammar_fa/dexec.test
new file mode 100644
index 0000000..463203c
--- /dev/null
+++ b/tcllib/modules/grammar_fa/dexec.test
@@ -0,0 +1,45 @@
+# -*- tcl -*-
+# dexec.test: tests for the grammar::fa::dexec - DFA executor class
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: dexec.test,v 1.10 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 1.0
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use snit/snit.tcl snit ; # 1.1 always, even when Tcl 8.5 runs the testsuite.
+ use struct/list.tcl struct::list
+
+ useLocal faop.tcl grammar::fa::op
+ useLocalKeep fa.tcl grammar::fa
+
+ useLocalFile tests/Xsupport
+}
+testing {
+ useLocal dexec.tcl grammar::fa::dexec
+}
+
+# -------------------------------------------------------------------------
+
+set class ::grammar::fa::dexec
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::set setimpl {
+ TestFiles tests/de_*.test
+}
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
diff --git a/tcllib/modules/grammar_fa/fa.man b/tcllib/modules/grammar_fa/fa.man
new file mode 100644
index 0000000..fa341a3
--- /dev/null
+++ b/tcllib/modules/grammar_fa/fa.man
@@ -0,0 +1,652 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin grammar::fa n 0.4]
+[keywords automaton]
+[keywords {finite automaton}]
+[keywords grammar]
+[keywords parsing]
+[keywords {regular expression}]
+[keywords {regular grammar}]
+[keywords {regular languages}]
+[keywords state]
+[keywords transducer]
+[copyright {2004-2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Finite automaton operations and usage}]
+[titledesc {Create and manipulate finite automatons}]
+[category {Grammars and finite automata}]
+[require Tcl 8.4]
+[require snit 1.3]
+[require struct::list]
+[require struct::set]
+[require grammar::fa::op [opt 0.2]]
+[require grammar::fa [opt 0.4]]
+[description]
+[para]
+
+This package provides a container class for
+[term {finite automatons}] (Short: FA).
+
+It allows the incremental definition of the automaton, its
+manipulation and querying of the definition.
+
+While the package provides complex operations on the automaton
+(via package [package grammar::fa::op]), it does not have the
+ability to execute a definition for a stream of symbols.
+
+Use the packages
+[package grammar::fa::dacceptor] and
+[package grammar::fa::dexec] for that.
+
+Another package related to this is [package grammar::fa::compiler]. It
+turns a FA into an executor class which has the definition of the FA
+hardwired into it. The output of this package is configurable to suit
+a large number of different implementation languages and paradigms.
+
+[para]
+
+For more information about what a finite automaton is see section
+[sectref {FINITE AUTOMATONS}].
+
+[section API]
+
+The package exports the API described here.
+
+[list_begin definitions]
+
+[call [cmd ::grammar::fa] [arg faName] [opt "[const =]|[const :=]|[const <--]|[const as]|[const deserialize] [arg src]|[const fromRegex] [arg re] [opt [arg over]]"]]
+
+Creates a new finite automaton with an associated global Tcl command
+whose name is [arg faName]. This command may be used to invoke various
+operations on the automaton. It has the following general form:
+
+[list_begin definitions]
+
+[call [cmd faName] [arg option] [opt [arg "arg arg ..."]]]
+
+[arg Option] and the [arg arg]s determine the exact behavior of the
+command. See section [sectref {FA METHODS}] for more explanations. The
+new automaton will be empty if no [arg src] is specified. Otherwise
+it will contain a copy of the definition contained in the [arg src].
+
+The [arg src] has to be a FA object reference for all operators except
+[const deserialize] and [const fromRegex]. The [const deserialize]
+operator requires [arg src] to be the serialization of a FA instead,
+and [const fromRegex] takes a regular expression in the form a of a
+syntax tree. See [cmd ::grammar::fa::op::fromRegex] for more detail on
+that.
+
+[list_end]
+[list_end]
+
+[section {FA METHODS}]
+[para]
+
+All automatons provide the following methods for their manipulation:
+
+[list_begin definitions]
+
+[call [arg faName] [method destroy]]
+
+Destroys the automaton, including its storage space and associated
+command.
+
+[call [arg faName] [method clear]]
+
+Clears out the definition of the automaton contained in [arg faName],
+but does [emph not] destroy the object.
+
+[call [arg faName] [method =] [arg srcFA]]
+
+Assigns the contents of the automaton contained
+in [arg srcFA] to [arg faName], overwriting any
+existing definition.
+
+This is the assignment operator for automatons. It copies the
+automaton contained in the FA object [arg srcFA] over the automaton
+definition in [arg faName]. The old contents of [arg faName] are
+deleted by this operation.
+
+[para]
+
+This operation is in effect equivalent to
+[para]
+[example_begin]
+ [arg faName] [method deserialize] [lb][arg srcFA] [method serialize][rb]
+[example_end]
+
+[call [arg faName] [method -->] [arg dstFA]]
+
+This is the reverse assignment operator for automatons. It copies the
+automation contained in the object [arg faName] over the automaton
+definition in the object [arg dstFA].
+
+The old contents of [arg dstFA] are deleted by this operation.
+
+[para]
+
+This operation is in effect equivalent to
+[para]
+[example_begin]
+ [arg dstFA] [method deserialize] [lb][arg faName] [method serialize][rb]
+[example_end]
+
+[call [arg faName] [method serialize]]
+
+This method serializes the automaton stored in [arg faName]. In other
+words it returns a tcl [emph value] completely describing that
+automaton.
+
+This allows, for example, the transfer of automatons over arbitrary
+channels, persistence, etc.
+
+This method is also the basis for both the copy constructor and the
+assignment operator.
+
+[para]
+
+The result of this method has to be semantically identical over all
+implementations of the [package grammar::fa] interface. This is what
+will enable us to copy automatons between different implementations of
+the same interface.
+
+[para]
+
+The result is a list of three elements with the following structure:
+
+[list_begin enumerated]
+[enum]
+The constant string [const grammar::fa].
+
+[enum]
+A list containing the names of all known input symbols. The order of
+elements in this list is not relevant.
+
+[enum]
+The last item in the list is a dictionary, however the order of the
+keys is important as well. The keys are the states of the serialized
+FA, and their order is the order in which to create the states when
+deserializing. This is relevant to preserve the order relationship
+between states.
+
+[para]
+
+The value of each dictionary entry is a list of three elements
+describing the state in more detail.
+
+[list_begin enumerated]
+[enum]
+A boolean flag. If its value is [const true] then the state is a
+start state, otherwise it is not.
+
+[enum]
+A boolean flag. If its value is [const true] then the state is a
+final state, otherwise it is not.
+
+[enum]
+The last element is a dictionary describing the transitions for the
+state. The keys are symbols (or the empty string), and the values are
+sets of successor states.
+
+[list_end]
+[list_end]
+[para]
+
+Assuming the following FA (which describes the life of a truck driver
+in a very simple way :)
+
+[para]
+[example {
+ Drive -- yellow --> Brake -- red --> (Stop) -- red/yellow --> Attention -- green --> Drive
+ (...) is the start state.
+}]
+[para]
+
+a possible serialization is
+
+[para]
+[example {
+ grammar::fa \\
+ {yellow red green red/yellow} \\
+ {Drive {0 0 {yellow Brake}} \\
+ Brake {0 0 {red Stop}} \\
+ Stop {1 0 {red/yellow Attention}} \\
+ Attention {0 0 {green Drive}}}
+}]
+[para]
+
+A possible one, because I did not care about creation order here
+
+[call [arg faName] [method deserialize] [arg serialization]]
+
+This is the complement to [method serialize]. It replaces the
+automaton definition in [arg faName] with the automaton described by
+the [arg serialization] value. The old contents of [arg faName] are
+deleted by this operation.
+
+[call [arg faName] [method states]]
+
+Returns the set of all states known to [arg faName].
+
+[call [arg faName] [method state] [method add] [arg s1] [opt "[arg s2] ..."]]
+
+Adds the states [arg s1], [arg s2], et cetera to the FA definition in
+[arg faName]. The operation will fail any of the new states is already
+declared.
+
+[call [arg faName] [method state] [method delete] [arg s1] [opt "[arg s2] ..."]]
+
+Deletes the state [arg s1], [arg s2], et cetera, and all associated
+information from the FA definition in [arg faName]. The latter means
+that the information about in- or outbound transitions is deleted as
+well. If the deleted state was a start or final state then this
+information is invalidated as well. The operation will fail if the
+state [arg s] is not known to the FA.
+
+[call [arg faName] [method state] [method exists] [arg s]]
+
+A predicate. It tests whether the state [arg s] is known to the FA in
+[arg faName].
+
+The result is a boolean value. It will be set to [const true] if the
+state [arg s] is known, and [const false] otherwise.
+
+[call [arg faName] [method state] [method rename] [arg s] [arg snew]]
+
+Renames the state [arg s] to [arg snew]. Fails if [arg s] is not a
+known state. Also fails if [arg snew] is already known as a state.
+
+[call [arg faName] [method startstates]]
+
+Returns the set of states which are marked as [term start] states,
+also known as [term initial] states.
+
+See [sectref {FINITE AUTOMATONS}] for explanations what this means.
+
+[call [arg faName] [method start] [method add] [arg s1] [opt "[arg s2] ..."]]
+
+Mark the states [arg s1], [arg s2], et cetera in the FA [arg faName]
+as [term start] (aka [term initial]).
+
+[call [arg faName] [method start] [method remove] [arg s1] [opt "[arg s2] ..."]]
+
+Mark the states [arg s1], [arg s2], et cetera in the FA [arg faName]
+as [term {not start}] (aka [term {not accepting}]).
+
+[call [arg faName] [method start?] [arg s]]
+
+A predicate. It tests if the state [arg s] in the FA [arg faName] is
+[term start] or not.
+
+The result is a boolean value. It will be set to [const true] if the
+state [arg s] is [term start], and [const false] otherwise.
+
+[call [arg faName] [method start?set] [arg stateset]]
+
+A predicate. It tests if the set of states [arg stateset] contains at
+least one start state. They operation will fail if the set contains an
+element which is not a known state.
+
+The result is a boolean value. It will be set to [const true] if a
+start state is present in [arg stateset], and [const false] otherwise.
+
+[call [arg faName] [method finalstates]]
+
+Returns the set of states which are marked as [term final] states,
+also known as [term accepting] states.
+
+See [sectref {FINITE AUTOMATONS}] for explanations what this means.
+
+[call [arg faName] [method final] [method add] [arg s1] [opt "[arg s2] ..."]]
+
+Mark the states [arg s1], [arg s2], et cetera in the FA [arg faName]
+as [term final] (aka [term accepting]).
+
+[call [arg faName] [method final] [method remove] [arg s1] [opt "[arg s2] ..."]]
+
+Mark the states [arg s1], [arg s2], et cetera in the FA [arg faName]
+as [term {not final}] (aka [term {not accepting}]).
+
+[call [arg faName] [method final?] [arg s]]
+
+A predicate. It tests if the state [arg s] in the FA [arg faName] is
+[term final] or not.
+
+The result is a boolean value. It will be set to [const true] if the
+state [arg s] is [term final], and [const false] otherwise.
+
+[call [arg faName] [method final?set] [arg stateset]]
+
+A predicate. It tests if the set of states [arg stateset] contains at
+least one final state. They operation will fail if the set contains an
+element which is not a known state.
+
+The result is a boolean value. It will be set to [const true] if a
+final state is present in [arg stateset], and [const false] otherwise.
+
+[call [arg faName] [method symbols]]
+
+Returns the set of all symbols known to the FA [arg faName].
+
+[call [arg faName] [method symbols@] [arg s] [opt [arg d]]]
+
+Returns the set of all symbols for which the state [arg s] has transitions.
+If the empty symbol is present then [arg s] has epsilon transitions. If two
+states are specified the result is the set of symbols which have transitions
+from [arg s] to [arg t]. This set may be empty if there are no transitions
+between the two specified states.
+
+[call [arg faName] [method symbols@set] [arg stateset]]
+
+Returns the set of all symbols for which at least one state in the set
+of states [arg stateset] has transitions.
+
+In other words, the union of [lb][arg faName] [method symbols@] [var s][rb]
+for all states [var s] in [arg stateset].
+
+If the empty symbol is present then at least one state contained in
+[arg stateset] has epsilon transitions.
+
+[call [arg faName] [method symbol] [method add] [arg sym1] [opt "[arg sym2] ..."]]
+
+Adds the symbols [arg sym1], [arg sym2], et cetera to the FA
+definition in [arg faName]. The operation will fail any of the symbols
+is already declared. The empty string is not allowed as a value for the symbols.
+
+[call [arg faName] [method symbol] [method delete] [arg sym1] [opt "[arg sym2] ..."]]
+
+Deletes the symbols [arg sym1], [arg sym2] et cetera, and all
+associated information from the FA definition in [arg faName]. The
+latter means that all transitions using the symbols are deleted as
+well. The operation will fail if any of the symbols is not known to
+the FA.
+
+[call [arg faName] [method symbol] [method rename] [arg sym] [arg newsym]]
+
+Renames the symbol [arg sym] to [arg newsym]. Fails if [arg sym] is
+not a known symbol. Also fails if [arg newsym] is already known as a
+symbol.
+
+[call [arg faName] [method symbol] [method exists] [arg sym]]
+
+A predicate. It tests whether the symbol [arg sym] is known to the FA
+in [arg faName].
+
+The result is a boolean value. It will be set to [const true] if the
+symbol [arg sym] is known, and [const false] otherwise.
+
+[call [arg faName] [method next ] [arg s] [arg sym] [opt "[const -->] [arg next]"]]
+
+Define or query transition information.
+
+[para]
+
+If [arg next] is specified, then the method will add a transition from
+the state [arg s] to the [term successor] state [arg next] labeled with
+the symbol [arg sym] to the FA contained in [arg faName]. The
+operation will fail if [arg s], or [arg next] are not known states, or
+if [arg sym] is not a known symbol. An exception to the latter is that
+[arg sym] is allowed to be the empty string. In that case the new
+transition is an [term {epsilon transition}] which will not consume
+input when traversed. The operation will also fail if the combination
+of ([arg s], [arg sym], and [arg next]) is already present in the FA.
+
+[para]
+
+If [arg next] was not specified, then the method will return
+the set of states which can be reached from [arg s] through
+a single transition labeled with symbol [arg sym].
+
+[call [arg faName] [method !next] [arg s] [arg sym] [opt "[const -->] [arg next]"]]
+
+Remove one or more transitions from the Fa in [arg faName].
+[para]
+
+If [arg next] was specified then the single transition from the state
+[arg s] to the state [arg next] labeled with the symbol [arg sym] is
+removed from the FA. Otherwise [emph all] transitions originating in
+state [arg s] and labeled with the symbol [arg sym] will be removed.
+
+[para]
+
+The operation will fail if [arg s] and/or [arg next] are not known as
+states. It will also fail if a non-empty [arg sym] is not known as
+symbol. The empty string is acceptable, and allows the removal of
+epsilon transitions.
+
+[call [arg faName] [method nextset] [arg stateset] [arg sym]]
+
+Returns the set of states which can be reached by a single transition
+originating in a state in the set [arg stateset] and labeled with the
+symbol [arg sym].
+
+[para]
+
+In other words, this is the union of
+[lb][arg faName] next [var s] [arg symbol][rb]
+for all states [var s] in [arg stateset].
+
+[call [arg faName] [method is] [method deterministic]]
+
+A predicate. It tests whether the FA in [arg faName] is a
+deterministic FA or not.
+
+The result is a boolean value. It will be set to [const true] if the
+FA is deterministic, and [const false] otherwise.
+
+[call [arg faName] [method is] [method complete]]
+
+A predicate. It tests whether the FA in [arg faName] is a complete FA
+or not. A FA is complete if it has at least one transition per state
+and symbol. This also means that a FA without symbols, or states is
+also complete.
+
+The result is a boolean value. It will be set to [const true] if the
+FA is deterministic, and [const false] otherwise.
+
+[para]
+
+Note: When a FA has epsilon-transitions transitions over a symbol for
+a state S can be indirect, i.e. not attached directly to S, but to a
+state in the epsilon-closure of S. The symbols for such indirect
+transitions count when computing completeness.
+
+[call [arg faName] [method is] [method useful]]
+
+A predicate. It tests whether the FA in [arg faName] is an useful FA
+or not. A FA is useful if all states are [term reachable]
+and [term useful].
+
+The result is a boolean value. It will be set to [const true] if the
+FA is deterministic, and [const false] otherwise.
+
+[call [arg faName] [method is] [method epsilon-free]]
+
+A predicate. It tests whether the FA in [arg faName] is an
+epsilon-free FA or not. A FA is epsilon-free if it has no epsilon
+transitions. This definition means that all deterministic FAs are
+epsilon-free as well, and epsilon-freeness is a necessary
+pre-condition for deterministic'ness.
+
+The result is a boolean value. It will be set to [const true] if the
+FA is deterministic, and [const false] otherwise.
+
+[call [arg faName] [method reachable_states]]
+
+Returns the set of states which are reachable from a start state by
+one or more transitions.
+
+[call [arg faName] [method unreachable_states]]
+
+Returns the set of states which are not reachable from any start state
+by any number of transitions. This is
+
+[para]
+[example {
+ [faName states] - [faName reachable_states]
+}]
+
+[call [arg faName] [method reachable] [arg s]]
+
+A predicate. It tests whether the state [arg s] in the FA [arg faName]
+can be reached from a start state by one or more transitions.
+
+The result is a boolean value. It will be set to [const true] if the
+state can be reached, and [const false] otherwise.
+
+[call [arg faName] [method useful_states]]
+
+Returns the set of states which are able to reach a final state by
+one or more transitions.
+
+[call [arg faName] [method unuseful_states]]
+
+Returns the set of states which are not able to reach a final state by
+any number of transitions. This is
+
+[para]
+[example {
+ [faName states] - [faName useful_states]
+}]
+
+[call [arg faName] [method useful] [arg s]]
+
+A predicate. It tests whether the state [arg s] in the FA [arg faName]
+is able to reach a final state by one or more transitions.
+
+The result is a boolean value. It will be set to [const true] if the
+state is useful, and [const false] otherwise.
+
+[call [arg faName] [method epsilon_closure] [arg s]]
+
+Returns the set of states which are reachable from the state [arg s]
+in the FA [arg faName] by one or more epsilon transitions, i.e
+transitions over the empty symbol, transitions which do not consume
+input. This is called the [term {epsilon closure}] of [arg s].
+
+[call [arg faName] [method reverse]]
+[call [arg faName] [method complete]]
+[call [arg faName] [method remove_eps]]
+[call [arg faName] [method trim] [opt [arg what]]]
+[call [arg faName] [method determinize] [opt [arg mapvar]]]
+[call [arg faName] [method minimize] [opt [arg mapvar]]]
+
+[call [arg faName] [method complement]]
+[call [arg faName] [method kleene]]
+[call [arg faName] [method optional]]
+[call [arg faName] [method union] [arg fa] [opt [arg mapvar]]]
+[call [arg faName] [method intersect] [arg fa] [opt [arg mapvar]]]
+[call [arg faName] [method difference] [arg fa] [opt [arg mapvar]]]
+[call [arg faName] [method concatenate] [arg fa] [opt [arg mapvar]]]
+
+[call [arg faName] [method fromRegex] [arg regex] [opt [arg over]]]
+
+These methods provide more complex operations on the FA. Please see
+the same-named commands in the package [package grammar::fa::op] for
+descriptions of what they do.
+
+[list_end]
+
+[para]
+
+[section EXAMPLES]
+[para]
+
+[section {FINITE AUTOMATONS}]
+[para]
+
+For the mathematically inclined, a FA is a 5-tuple (S,Sy,St,Fi,T) where
+
+[list_begin itemized]
+[item]
+S is a set of [term {states}],
+
+[item]
+Sy a set of [term {input symbols}],
+
+[item]
+St is a subset of S, the set of [term start] states, also known as
+[term initial] states.
+
+[item]
+Fi is a subset of S, the set of [term final] states, also known as
+[term accepting].
+
+[item]
+T is a function from S x (Sy + epsilon) to {S}, the [term {transition function}].
+
+Here [const epsilon] denotes the empty input symbol and is distinct
+from all symbols in Sy; and {S} is the set of subsets of S. In other
+words, T maps a combination of State and Input (which can be empty) to
+a set of [term {successor states}].
+
+[list_end]
+[para]
+
+In computer theory a FA is most often shown as a graph where the nodes
+represent the states, and the edges between the nodes encode the
+transition function: For all n in S' = T (s, sy) we have one edge
+between the nodes representing s and n resp., labeled with sy. The
+start and accepting states are encoded through distinct visual
+markers, i.e. they are attributes of the nodes.
+
+[para]
+
+FA's are used to process streams of symbols over Sy.
+
+[para]
+
+A specific FA is said to [term accept] a finite stream sy_1 sy_2
+... sy_n if there is a path in the graph of the FA beginning at a
+state in St and ending at a state in Fi whose edges have the labels
+sy_1, sy_2, etc. to sy_n.
+
+The set of all strings accepted by the FA is the [term language] of
+the FA. One important equivalence is that the set of languages which
+can be accepted by an FA is the set of [term {regular languages}].
+
+[para]
+
+Another important concept is that of deterministic FAs. A FA is said
+to be [term deterministic] if for each string of input symbols there
+is exactly one path in the graph of the FA beginning at the start
+state and whose edges are labeled with the symbols in the string.
+
+While it might seem that non-deterministic FAs to have more power of
+recognition, this is not so. For each non-deterministic FA we can
+construct a deterministic FA which accepts the same language (-->
+Thompson's subset construction).
+
+[para]
+
+While one of the premier applications of FAs is in [term parsing],
+especially in the [term lexer] stage (where symbols == characters),
+this is not the only possibility by far.
+
+[para]
+
+Quite a lot of processes can be modeled as a FA, albeit with a
+possibly large set of states. For these the notion of accepting states
+is often less or not relevant at all. What is needed instead is the
+ability to act to state changes in the FA, i.e. to generate some
+output in response to the input.
+
+This transforms a FA into a [term {finite transducer}], which has an
+additional set OSy of [term {output symbols}] and also an additional
+[term {output function}] O which maps from "S x (Sy + epsilon)" to
+"(Osy + epsilon)", i.e a combination of state and input, possibly
+empty to an output symbol, or nothing.
+
+[para]
+
+For the graph representation this means that edges are additional
+labeled with the output symbol to write when this edge is traversed
+while matching input. Note that for an application "writing an output
+symbol" can also be "executing some code".
+
+[para]
+
+Transducers are not handled by this package. They will get their own
+package in the future.
+
+[vset CATEGORY grammar_fa]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/grammar_fa/fa.tcl b/tcllib/modules/grammar_fa/fa.tcl
new file mode 100644
index 0000000..8e116d0
--- /dev/null
+++ b/tcllib/modules/grammar_fa/fa.tcl
@@ -0,0 +1,1242 @@
+# -*- tcl -*-
+# (c) 2004-2013 Andreas Kupries
+# Grammar / Finite Automatons / Container
+
+# ### ### ### ######### ######### #########
+## Package description
+
+## A class whose instances hold all the information describing a
+## single finite automaton (states, symbols, start state, set of
+## accepting states, transition function), and operations to define,
+## manipulate, and query this information.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.4
+if {[package vcompare [package present Tcl] 8.5] >= 0} {
+ # Tcl 8.5+, extended package version numbers.
+ # Require 1.3 and beyond, regardless of major version number.
+ package require snit 1.3- ; # OO system in use (Using hierarchical methods)
+} else {
+ # Tcl 8.4, emulate, ask for 2.x first, then 1.3+.
+ if {[catch {
+ package require snit 2 ; # OO system in use (Using hierarchical methods)
+ }]} {
+ package require snit 1.3 ; # OO system in use (Using hierarchical methods)
+ }
+}
+
+package require grammar::fa::op ; # Heavy FA operations.
+package require struct::list ; # Extended list operations.
+package require struct::set ; # Extended set operations.
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+snit::type ::grammar::fa {
+ # ### ### ### ######### ######### #########
+ ## Type API. A number of operations on FAs
+
+ # ### ### ### ######### ######### #########
+ ## Instance API
+
+ #constructor {args} {}
+ #destructor {}
+
+ method = {b} {}
+ method --> {b} {}
+
+ method serialize {} {}
+ method deserialize {value} {}
+ method deserialize_merge {value} {}
+
+ method states {} {}
+ #method state {cmd s args} {}
+
+ method startstates {} {}
+ method start? {s} {}
+ method start?set {states} {}
+ #method start {cmd args} {}
+
+ method finalstates {} {}
+ method final? {s} {}
+ method final?set {states} {}
+ #method final {cmd args} {}
+
+ method symbols {} {}
+ method symbols@ {state} {}
+ method symbols@set {states} {}
+ #method symbol {cmd sym} {}
+
+ method next {s sym args} {}
+ method !next {s sym args} {}
+ method nextset {states sym} {}
+
+ method is {cmd} {}
+
+ method reachable_states {} {}
+ method unreachable_states {} {}
+ method reachable {s} {}
+
+ method useful_states {} {}
+ method unuseful_states {} {}
+ method useful {s} {}
+
+ method epsilon_closure {s} {}
+
+ method clear {} {}
+
+ # ### ### ### ######### ######### #########
+ ## Instance API. Complex FA operations.
+ ## The heavy lifting is done by the operations package.
+
+ method reverse {} {op::reverse $self}
+ method complete {{sink {}}} {op::complete $self $sink}
+ method remove_eps {} {op::remove_eps $self}
+ method trim {{what !reachable|!useful}} {op::trim $self $what}
+ method complement {} {op::complement $self}
+ method kleene {} {op::kleene $self}
+ method optional {} {op::optional $self}
+ method fromRegex {regex {over {}}} {op::fromRegex $self $regex $over}
+
+ method determinize {{mapvar {}}} {
+ if {$mapvar ne ""} {upvar 1 $mapvar map}
+ op::determinize $self map
+ }
+
+ method minimize {{mapvar {}}} {
+ if {$mapvar ne ""} {upvar 1 $mapvar map}
+ op::minimize $self map
+ }
+
+ method union {fa {mapvar {}}} {
+ if {$mapvar ne ""} {upvar 1 $mapvar map}
+ op::union $self $fa map
+ }
+
+ method intersect {fa {mapvar {}}} {
+ if {$mapvar ne ""} {upvar 1 $mapvar map}
+ op::intersect $self $fa map
+ }
+
+ method difference {fa {mapvar {}}} {
+ if {$mapvar ne ""} {upvar 1 $mapvar map}
+ op::difference $self $fa map
+ }
+
+ method concatenate {fa {mapvar {}}} {
+ if {$mapvar ne ""} {upvar 1 $mapvar map}
+ op::concatenate $self $fa map
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal data structures.
+
+ ## State information:
+ ## - Order : Defined for all states, values provide creation order.
+ ## - Start : Defined for states which are "start" (Input processing begins in).
+ ## - Final : Defined for states which are "final" ("accept" input).
+ ## - Transinv : Inverse transitions. Per state the set of (state,sym)'s
+ ## which have transitions into the state. Defined only for
+ ## states which have inbound transitions.
+ ##
+ ## Transinv is maintained to make state deletion easier: Direct
+ ## access to the states and transitions which are inbound, for
+ ## their deletion.
+
+ variable order ; # Map : State -> Order of creation
+ variable final ; # Map : State -> . Exists <=> Is a final State
+ variable start ; # Map : State -> . Exists <=> Is a start State
+ variable transinv ; # Map : State -> {(State, Sym)}
+
+ ## Global information:
+ ## - Scount : Counter for creation order of states.
+
+ variable scount 0 ; # Counter for orderering states.
+
+ ## Symbol information:
+ ## - Symbol : Defined for all symbols, values irrelevant.
+
+ variable symbol ; # Map : Symbol -> . Exists = Symbol declared.
+
+ ## Transition data:
+ ## - TransN : Dynamically created instance variables. Transition tables
+ ## for single states. Defined only for states which have
+ ## transitions.
+ ## - Transym : List of states having transitions on that symbol.
+
+ ## Transym is maintained for symbol deletion. Direct access to the transitions
+ ## we have to delete as well.
+
+ ## selfns::trans_$order(state) : Per state map : symbol -> list of destinations.
+ variable transym ; # Map : Sym -> {State}
+
+ ## Derived information:
+ ## - Reach : Cache for set of states reachable from start.
+ ## - Reachvalid : Boolean flag. True iff the reach cache contains valid data
+ ## - Useful : Cache for set of states able to reach final.
+ ## - Usefulvalid : Boolean flag. True iff the useful cache contains valid data
+ ## - Nondete : Set of states which are non-deterministic, because they have
+ # epsilon-transitions.
+ # - EC : Cache of epsilon-closures
+
+ variable reach {} ; # Set of states reachable from 'start'.
+ variable reachvalid 0 ; # Boolean flag, if 'reach' is valid.
+
+ variable useful {} ; # Set of states able to reach 'final'.
+ variable usefulvalid 0 ; # Boolean flag, if 'useful' is valid.
+
+ variable nondete {} ; # Set of non-deterministic states, by epsilon/non-epsilon.
+ variable nondets ; # Per non-det state the set of symbols it is non-det in.
+
+ variable ec ; # Cache of epsilon-closures for states.
+
+
+ # ### ### ### ######### ######### #########
+ ## Instance API Implementation.
+
+ constructor {args} {
+ set alen [llength $args]
+ if {($alen != 2) && ($alen != 0) && ($alen != 3)} {
+ return -code error "wrong#args: $self ?=|:=|<--|as|deserialize a'|fromRegex re ?over??"
+ }
+
+ array set order {} ; set nondete {}
+ array set start {} ; set scount 0
+ array set final {} ; set reach {}
+ array set symbol {} ; set reachvalid 0
+ array set transym {} ; set useful {}
+ array set transinv {} ; set usefulvalid 0
+ array set nondets {}
+ array set ec {}
+
+ if {$alen == 0} return
+
+ foreach {cmd object} $args break
+ switch -exact -- $cmd {
+ = - := - <-- - as {
+ if {$alen != 2} {
+ return -code error "wrong#args: $self ?=|:=|<--|as|deserialize a'|fromRegex re ?over??"
+ }
+ $self = $object
+ }
+ deserialize {
+ if {$alen != 2} {
+ return -code error "wrong#args: $self ?=|:=|<--|as|deserialize a'|fromRegex re ?over??"
+ }
+ # Object is actually a value, the deserialization to use.
+ $self deserialize $object
+ }
+ fromRegex {
+ # Object is actually a value, the regular expression to use.
+ if {$alen == 2} {
+ $self fromRegex $object
+ } else {
+ $self fromRegex $object [lindex $args 2]
+ }
+ }
+ default {
+ return -code error "bad assignment: $self ?=|:=|<--|as|deserialize a'|fromRegex re ?over??"
+ }
+ }
+ return
+ }
+
+ # destructor {}
+
+ # --- --- --- --------- --------- ---------
+
+ method = {b} {
+ $self deserialize [$b serialize]
+ }
+
+ method --> {b} {
+ $b deserialize [$self serialize]
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ method serialize {} {
+ set ord {}
+ foreach {s n} [array get order] {
+ lappend ord [list $s $n]
+ }
+ set states {} ; # Dictionary
+ foreach item [lsort -index 1 -integer -increasing $ord] {
+ set s [lindex $item 0]
+ set sdata {}
+
+ # Dict data per state :
+
+ lappend sdata [info exists start($s)]
+ lappend sdata [info exists final($s)]
+
+ # Transitions from the state.
+
+ upvar #0 ${selfns}::trans_$order($s) jump
+
+ if {![info exists jump]} {
+ lappend sdata {}
+ } else {
+ lappend sdata [array get jump]
+ }
+
+ # ----------------------
+ lappend states $s $sdata
+ }
+
+ return [::list \
+ grammar::fa \
+ [array names symbol] \
+ $states \
+ ]
+ }
+
+ method deserialize {value} {
+ $self CheckSerialization $value st states acc tr newsymbols
+ $self clear
+
+ foreach s $states {set order($s) [incr scount]}
+ foreach sym $newsymbols {set symbol($sym) .}
+ foreach s $acc {set final($s) .}
+ foreach s $st {set start($s) .}
+
+ foreach {sa sym se} $tr {$self Next $sa $sym $se}
+ return
+ }
+
+ method deserialize_merge {value} {
+ $self CheckSerialization $value st states acc tr newsymbols
+
+ foreach s $states {set order($s) [incr scount]}
+ foreach sym $newsymbols {set symbol($sym) .}
+ foreach s $acc {set final($s) .}
+ foreach s $st {set start($s) .}
+
+ foreach {sa sym se} $tr {$self Next $sa $sym $se}
+ return
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ method states {} {
+ return [array names order]
+ }
+
+ method {state add} {s args} {
+ set args [linsert $args 0 $s]
+ foreach s $args {
+ if {[info exists order($s)]} {
+ return -code error "State \"$s\" is already known"
+ }
+ }
+ foreach s $args {set order($s) [incr scount]}
+ return
+ }
+
+ method {state delete} {s args} {
+ set args [linsert $args 0 $s]
+ $self StateCheckSet $args
+
+ foreach s $args {
+ unset -nocomplain start($s) ; # Start/Initial indicator
+ unset -nocomplain final($s) ; # Final/Accept indicator
+
+ # Remove all inbound transitions.
+ if {[info exists transinv($s)]} {
+ set src $transinv($s)
+ unset transinv($s)
+
+ foreach srcitem $src {
+ struct::list assign $srcitem sin sym
+ $self !Next $sin $sym $s
+ }
+ }
+
+ # We remove transition data only after the inbound
+ # ones. Otherwise we screw up the removal of
+ # looping transitions. We have to consider the
+ # backpointers to us in transinv as well.
+
+ upvar #0 ${selfns}::trans_$order($s) jump
+ if {[info exists jump]} {
+ foreach sym [array names jump] {
+ $self !Transym $s $sym
+ foreach nexts $jump($sym) {
+ $self !Transinv $s $sym $nexts
+ }
+ }
+
+ unset ${selfns}::trans_$order($s) ; # Transitions from s
+ }
+ unset order($s) ; # State ordering
+
+ # Removal of a state may break the automaton into
+ # disconnected pieces. This means that the set of
+ # reachable and useful states may change, and the
+ # cache cannot be used from now on.
+
+ $self InvalidateReach
+ $self InvalidateUseful
+ }
+ return
+ }
+
+ method {state rename} {s snew} {
+ $self StateCheck $s
+ if {[info exists order($snew)]} {
+ return -code error "State \"$snew\" is already known"
+ }
+
+ set o $order($s)
+ unset order($s) ; # State ordering
+ set order($snew) $o
+
+ # Start/Initial indicator
+ if {[info exists start($s)]} {
+ set start($snew) $start($s)
+ unset start($s)
+ }
+ # Final/Accept indicator
+ if {[info exists final($s)]} {
+ set final($snew) $final($s)
+ unset final($s)
+ }
+ # Update all inbound transitions.
+ if {[info exists transinv($s)]} {
+ set transinv($snew) $transinv($s)
+ unset transinv($s)
+
+ # We have to perform a bit more here. We have to
+ # go through the inbound transitions and change the
+ # listed destination state to the new name.
+
+ foreach srcitem $transinv($snew) {
+ struct::list assign $srcitem sin sym
+ # For loops access the 'order' array under the
+ # new name, the old entry is already gone. See
+ # above. See bug SF 2595296.
+ if {$sin eq $s} {
+ set sin $snew
+ }
+ upvar #0 ${selfns}::trans_$order($sin) jump
+ upvar 0 jump($sym) destinations
+ set pos [lsearch -exact $destinations $s]
+ set destinations [lreplace $destinations $pos $pos $snew]
+ }
+ }
+
+ # Another place to change are the back pointers from
+ # all the states we have transitions to, i.e. transinv
+ # for all outbound states.
+
+ upvar #0 ${selfns}::trans_$o jump
+ if {[info exists jump]} {
+ foreach sym [array names jump] {
+ foreach sout $jump($sym) {
+ upvar 0 transinv($sout) backpointer
+ set pos [lsearch -exact $backpointer [list $s $sym]]
+ set backpointer [lreplace $backpointer $pos $pos [list $snew $sym]]
+ }
+
+ # And also to update: Transym information for the symbol.
+ upvar 0 transym($sym) users
+ set pos [lsearch -exact $users $s]
+ set users [lreplace $users $pos $pos $snew]
+ }
+ }
+
+ # Changing the name of a state does not change the
+ # reachables / useful states per se. We just may have
+ # to replace the name in the caches as well.
+
+ # - Invalidation will do the same, at the expense of a
+ # - larger computation later.
+
+ $self InvalidateReach
+ $self InvalidateUseful
+ return
+ }
+
+ method {state exists} {s} {
+ return [info exists order($s)]
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ method startstates {} {
+ return [array names start]
+ }
+
+ method start? {s} {
+ $self StateCheck $s
+ return [info exists start($s)]
+ }
+
+ method start?set {states} {
+ $self StateCheckSet $states
+ foreach s $states {
+ if {[info exists start($s)]} {return 1}
+ }
+ return 0
+ }
+
+ # Note: Adding or removing start states does not change
+ # usefulness, only reachability
+
+ method {start add} {state args} {
+ set args [linsert $args 0 $state]
+ $self StateCheckSet $args
+ foreach s $args {set start($s) .}
+ $self InvalidateReach
+ return
+ }
+
+ method {start set} {states} {
+ $self StateCheckSet $states
+ array unset start
+ foreach s $states {set start($s) .}
+ $self InvalidateReach
+ return
+ }
+
+ method {start remove} {state args} {
+ set args [linsert $args 0 $state]
+ $self StateCheckSet $args
+ foreach s $args {
+ unset -nocomplain start($s)
+ }
+ $self InvalidateReach
+ return
+ }
+
+ method {start clear} {} {
+ array unset start
+ $self InvalidateReach
+ return
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ method finalstates {} {
+ return [array names final]
+ }
+
+ method final? {s} {
+ $self StateCheck $s
+ return [info exists final($s)]
+ }
+
+ method final?set {states} {
+ $self StateCheckSet $states
+ foreach s $states {
+ if {[info exists final($s)]} {return 1}
+ }
+ return 0
+ }
+
+ # Note: Adding or removing final states does not change
+ # reachability, only usefulness
+
+ method {final add} {state args} {
+ set args [linsert $args 0 $state]
+ $self StateCheckSet $args
+ foreach s $args {set final($s) .}
+ $self InvalidateUseful
+ return
+ }
+
+ method {final set} {states} {
+ $self StateCheckSet $states
+ array unset final
+ foreach s $states {set final($s) .}
+ $self InvalidateReach
+ return
+ }
+
+ method {final remove} {state args} {
+ set args [linsert $args 0 $state]
+ $self StateCheckSet $args
+ foreach s $args {
+ unset -nocomplain final($s)
+ }
+ $self InvalidateUseful
+ return
+ }
+
+ method {final clear} {} {
+ array unset final
+ $self InvalidateReach
+ return
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ method symbols {} {
+ return [array names symbol]
+ }
+
+ method symbols@ {s {t {}}} {
+ $self StateCheck $s
+ if {$t ne ""} { $self StateCheck $t}
+ upvar #0 ${selfns}::trans_$order($s) jump
+ if {![info exists jump]} {return {}}
+ if {$t eq ""} {
+ # No destination, all symbols.
+ return [array names jump]
+ }
+ # Specific destination, locate the symbols going there.
+ set result {}
+ foreach sym [array names jump] {
+ if {[lsearch -exact $jump($sym) $t] < 0} continue
+ lappend result $sym
+ }
+ return [lsort -uniq $result]
+ }
+
+ method symbols@set {states} {
+ # Union (fa symbol@ s, f.a. s in states)
+
+ $self StateCheckSet $states
+ set result {}
+ foreach s $states {
+ upvar #0 ${selfns}::trans_$order($s) jump
+ if {![info exists jump]} continue
+ foreach sym [array names jump] {
+ lappend result $sym
+ }
+ }
+ return [lsort -uniq $result]
+ }
+
+ method {symbol add} {sym args} {
+ set args [linsert $args 0 $sym]
+ foreach sym $args {
+ if {$sym eq ""} {
+ return -code error "Cannot add illegal empty symbol \"\""
+ }
+ if {[info exists symbol($sym)]} {
+ return -code error "Symbol \"$sym\" is already known"
+ }
+ }
+ foreach sym $args {set symbol($sym) .}
+ return
+ }
+
+ method {symbol delete} {sym args} {
+ set args [linsert $args 0 $sym]
+ $self SymbolCheckSetNE $args
+ foreach sym $args {
+ unset symbol($sym)
+
+ # Delete all transitions using the removed symbol.
+
+ if {[info exists transym($sym)]} {
+ foreach s $transym($sym) {
+ $self !Next $s $sym
+ }
+ }
+ }
+ return
+ }
+
+ method {symbol rename} {sym newsym} {
+ $self SymbolCheckNE $sym
+ if {$newsym eq ""} {
+ return -code error "Cannot add illegal empty symbol \"\""
+ }
+ if {[info exists symbol($newsym)]} {
+ return -code error "Symbol \"$newsym\" is already known"
+ }
+
+ unset symbol($sym)
+ set symbol($newsym) .
+
+ if {[info exists transym($sym)]} {
+ set transym($newsym) [set states $transym($sym)]
+ unset transym($sym)
+
+ foreach s $states {
+ # Update the jump tables for each of the states
+ # using this symbol, and the reverse tables as
+ # well.
+
+ upvar #0 ${selfns}::trans_$order($s) jump
+ set jump($newsym) [set destinations $jump($sym)]
+ unset jump($sym)
+
+ foreach sd $destinations {
+ upvar 0 transinv($sd) backpointer
+ set pos [lsearch -exact $backpointer [list $s $sym]]
+ set backpointer [lreplace $backpointer $pos $pos [list $s $newsym]]
+ }
+ }
+ }
+ return
+ }
+
+ method {symbol exists} {sym} {
+ return [info exists symbol($sym)]
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ method next {s sym args} {
+ ## Split into checking and functionality ...
+
+ set alen [llength $args]
+ if {($alen != 2) && ($alen != 0)} {
+ return -code error "wrong#args: [list $self] next s sym ?--> s'?"
+ }
+ $self StateCheck $s
+ $self SymbolCheck $sym
+
+ if {($alen == 2) && [set cmd [lindex $args 0]] ne "-->"} {
+ return -code error "Expected -->, got \"$cmd\""
+ }
+
+ if {$alen == 0} {
+ # Query transition table.
+ upvar #0 ${selfns}::trans_$order($s) jump
+ if {![info exists jump($sym)]} {return {}}
+ return $jump($sym)
+ }
+
+ set nexts [lindex $args 1]
+ $self StateCheck $nexts
+
+ upvar #0 ${selfns}::trans_$order($s) jump
+ if {[info exists jump($sym)] && [struct::set contains $jump($sym) $nexts]} {
+ return -code error "Transition \"($s, ($sym)) --> $nexts\" is already known"
+ }
+
+ $self Next $s $sym $nexts
+ return
+ }
+
+ method !next {s sym args} {
+ set alen [llength $args]
+ if {($alen != 2) && ($alen != 0)} {
+ return -code error "wrong#args: [list $self] !next s sym ?--> s'?"
+ }
+ $self StateCheck $s
+ $self SymbolCheck $sym
+
+ if {$alen == 2} {
+ if {[lindex $args 0] ne "-->"} {
+ return -code error "Expected -->, got \"[lindex $args 0]\""
+ }
+ set nexts [lindex $args 1]
+ $self StateCheck $nexts
+ $self !Next $s $sym $nexts
+ } else {
+ $self !Next $s $sym
+ }
+ }
+
+ method nextset {states sym} {
+ $self SymbolCheck $sym
+ $self StateCheckSet $states
+
+ set result {}
+ foreach s $states {
+ upvar #0 ${selfns}::trans_$order($s) jump
+ if {![info exists jump($sym)]} continue
+ struct::set add result $jump($sym)
+ }
+ return $result
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ method is {cmd} {
+ switch -exact -- $cmd {
+ complete {
+ # The FA is complete if Trans(State, Sym) != {} for all
+ # states and symbols (Not counting epsilon transitions).
+ # Without symbols the FA is deemed complete. Note:
+ # States with epsilon transitions can use symbols
+ # indirectly! Need their closures for exact
+ # computation.
+
+ set nsymbols [llength [array names symbol]]
+ if {$nsymbols == 0} {return 1}
+ foreach s [array names order] {
+ upvar #0 ${selfns}::trans_$order($s) jump
+ if {![info exists jump]} {return 0}
+ set njsym [array size jump]
+ if {[info exists jump()]} {
+ set njsym [llength [$self symbols@set [$self epsilon_closure $s]]]
+ incr njsym -1
+ }
+ if {$njsym != $nsymbols} {return 0}
+ }
+ return 1
+ }
+ deterministic {
+ # The FA is deterministic if it has on start state, no
+ # epsilon transitions, and the transition function is
+ # State x Symbol -> State, and not
+ # State x Symbol -> P(State).
+
+ return [expr {
+ ([array size start] == 1) &&
+ ![llength $nondete] &&
+ ![array size nondets]
+ }] ;#{}
+ }
+ epsilon-free {
+ # FA is epsion-free if there are no states having epsilon transitions.
+ return [expr {![llength $nondete]}]
+ }
+ useful {
+ # The FA is useful if and only if we have states and
+ # all states are reachable and useful.
+
+ set states [$self states]
+ return [expr {
+ [struct::set size $states] &&
+ [struct::set equal $states [$self reachable_states]] &&
+ [struct::set equal $states [$self useful_states]]
+ }] ;# {}
+ }
+ }
+ return -code error "Expected complete, deterministic, epsilon-free, or useful, got \"$cmd\""
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ method reachable_states {} {
+ if {$reachvalid} {return $reach}
+ if {![array size start]} {
+ set reach {}
+ } else {
+ # Basic algorithm like for epsilon_closure, except that we
+ # process all transitions, not only epsilons, and that
+ # the initial state is fixed to start.
+
+ set reach [array names start]
+ set pending $reach
+ array set visited {}
+ while {[llength $pending]} {
+ set s [struct::list shift pending]
+ if {[info exists visited($s)]} continue
+ set visited($s) .
+ upvar #0 ${selfns}::trans_$order($s) jump
+ if {![info exists jump]} continue
+ if {![array size jump]} continue
+ foreach sym [array names jump] {
+ struct::set add reach $jump($sym)
+ struct::set add pending $jump($sym)
+ }
+ }
+ }
+ set reachvalid 1
+ return $reach
+ }
+
+ method unreachable_states {} {
+ # unreachable = states - reachables
+ return [struct::set difference \
+ [$self states] [$self reachable_states]]
+ }
+
+ method reachable {s} {
+ $self StateCheck $s
+ return [struct::set contains [$self reachable_states] $s]
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ method useful_states {} {
+ if {$usefulvalid} {return $useful}
+
+ # A state is useful if a final state
+ # can be reached from it.
+
+ if {![array size final]} {
+ set useful {}
+ } else {
+ # Basic algorithm like for epsilon_closure, except that we
+ # process all transitions, not only epsilons, and that
+ # the initial set of states is fixed to final.
+
+ set useful [array names final]
+ array set known [array get final]
+ set pending $useful
+ array set visited {}
+ while {[llength $pending]} {
+ set s [struct::list shift pending]
+ if {[info exists visited($s)]} continue
+ set visited($s) .
+
+ # All predecessors are useful, and have to be visited as well.
+ # We get the predecessors from the transinv structure.
+
+ if {![info exists transinv($s)]} continue
+ foreach before $transinv($s) {
+ set before [lindex $before 0]
+ if {[info exists visited($before)]} continue
+ lappend pending $before
+ if {[info exists known($before)]} continue
+ lappend useful $before
+ set known($before) .
+ }
+ }
+ }
+ set usefulvalid 1
+ return $useful
+ }
+
+ method unuseful_states {} {
+ # unuseful = states - useful
+ return [struct::set difference \
+ [$self states] [$self useful_states]]
+ }
+
+ method useful {s} {
+ $self StateCheck $s
+ return [struct::set contains [$self useful_states] $s]
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ method epsilon_closure {s} {
+ # Iterative graph traversal. Keeps a set of states to look at,
+ # and adds to them everything it can reach from the current
+ # state via epsilon-transitions. Loops are handled through the
+ # visited array to weed out all the states already processed.
+
+ $self StateCheck $s
+
+ # Prefer cached information
+ if {[info exists ec($s)]} {
+ return $ec($s)
+ }
+
+ set closure [list $s]
+ set pending [list $s]
+ array set visited {}
+ while {[llength $pending]} {
+ set t [struct::list shift pending]
+ if {[info exists visited($t)]} continue
+ set visited($t) .
+ upvar #0 ${selfns}::trans_$order($t) jump
+ if {![info exists jump()]} continue
+ struct::set add closure $jump()
+ struct::set add pending $jump()
+ }
+ set ec($s) $closure
+ return $closure
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ method clear {} {
+ array unset order ; set nondete {}
+ array unset start ; set scount 0
+ array unset final ; set reach {}
+ array unset symbol ; set reachvalid 0
+ array unset transym ; set useful {}
+ array unset transinv ; set usefulvalid 0
+ array unset nondets
+ array unset ec
+
+ # Locate all 'trans_' arrays and remove them as well.
+
+ foreach v [info vars ${selfns}::trans_*] {
+ unset $v
+ }
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Instance Internals.
+
+ method StateCheck {s} {
+ if {![info exists order($s)]} {
+ return -code error "Illegal state \"$s\""
+ }
+ }
+
+ method StateCheckSet {states} {
+ foreach s $states {
+ if {![info exists order($s)]} {
+ return -code error "Illegal state \"$s\""
+ }
+ }
+ }
+
+ method SymbolCheck {sym} {
+ if {$sym eq ""} return
+ if {![info exists symbol($sym)]} {
+ return -code error "Illegal symbol \"$sym\""
+ }
+ }
+
+ method SymbolCheckNE {sym} {
+ if {($sym eq "") || ![info exists symbol($sym)]} {
+ return -code error "Illegal symbol \"$sym\""
+ }
+ }
+
+ if 0 {
+ # Unused. Activate when needed.
+ method SymbolCheckSet {symbols} {
+ foreach sym $symbols {
+ if {$sym eq ""} continue
+ if {![info exists symbol($sym)]} {
+ return -code error "Illegal symbol \"$sym\""
+ }
+ }
+ }
+ }
+
+ method SymbolCheckSetNE {symbols} {
+ foreach sym $symbols {
+ if {($sym eq "") || ![info exists symbol($sym)]} {
+ return -code error "Illegal symbol \"$sym\""
+ }
+ }
+ }
+
+ method Next {s sym nexts} {
+ # Modify transition table. May update the set of
+ # non-deterministic states. Invalidates reachable
+ # cache, as states may become reachable. Updates
+ # the transym and transinv mappings.
+
+ upvar #0 ${selfns}::trans_$order($s) jump
+
+ $self InvalidateReach
+ $self InvalidateUseful
+ # Clear closure cache when epsilons change.
+ if {$sym eq ""} {array unset ec}
+
+ if {[info exists transym($sym)]} {
+ struct::set include transym($sym) $s
+ } else {
+ set transym($sym) [list $s]
+ }
+
+ if {[info exists transinv($nexts)]} {
+ struct::set include transinv($nexts) [list $s $sym]
+ } else {
+ set transinv($nexts) [list [list $s $sym]]
+ }
+
+ if {![info exists jump($sym)]} {
+ set jump($sym) [list $nexts]
+ } else {
+ struct::set include jump($sym) $nexts
+ }
+ $self NonDeterministic $s $sym
+ return
+ }
+
+ method !Next {s sym args} {
+ upvar #0 ${selfns}::trans_$order($s) jump
+ # Anything to do at all ?
+ if {![info exists jump($sym)]} return
+ $self InvalidateReach
+ $self InvalidateUseful
+ # Clear closure cache when epsilons change.
+ if {$sym eq ""} {array unset ec}
+
+ if {![llength $args]} {
+ # Unset all transitions for (s, sym)
+ # Update transym and transinv mappings as well, if existing.
+
+ $self !Transym $s $sym
+ foreach nexts $jump($sym) {
+ $self !Transinv $s $sym $nexts
+ }
+
+ unset jump($sym)
+ } else {
+ # Remove the single transition (s, sym) -> nexts
+ set nexts [lindex $args 0]
+
+ struct::set exclude jump($sym) $nexts
+ $self !Transinv $s $sym $nexts
+
+ if {![struct::set size $jump($sym)]} {
+ $self !Transym $s $sym
+ unset jump($sym)
+ if {![array size jump]} {
+ unset jump
+ }
+ }
+ }
+
+ $self NonDeterministic $s $sym
+ return
+ }
+
+ method !Transym {s sym} {
+ struct::set exclude transym($sym) $s
+ if {![struct::set size $transym($sym)]} {
+ unset transym($sym)
+ }
+ }
+
+ method !Transinv {s sym nexts} {
+ if {[info exists transinv($nexts)]} {
+ struct::set exclude transinv($nexts) [list $s $sym]
+ if {![struct::set size $transinv($nexts)]} {
+ unset transinv($nexts)
+ }
+ }
+ }
+
+ method InvalidateReach {} {
+ set reachvalid 0
+ set reach {}
+ return
+ }
+
+ method InvalidateUseful {} {
+ set usefulvalid 0
+ set useful {}
+ return
+ }
+
+ method NonDeterministic {s sym} {
+ upvar #0 ${selfns}::trans_$order($s) jump
+
+ # Epsilon rule, whole state check. Epslion present <=> Not a DFA.
+
+ if {[info exists jump()]} {
+ struct::set include nondete $s
+ } else {
+ struct::set exclude nondete $s
+ }
+
+ # Non-determinism over a symbol.
+
+ upvar #0 ${selfns}::trans_$order($s) jump
+
+ if {[info exists jump($sym)] && [struct::set size $jump($sym)] > 1} {
+ if {![info exists nondets($s)]} {
+ set nondets($s) [list $sym]
+ } else {
+ struct::set include nondets($s) $sym
+ }
+ return
+ } else {
+ if {![info exists nondets($s)]} return
+ struct::set exclude nondets($s) $sym
+ if {![struct::set size $nondets($s)]} {
+ unset nondets($s)
+ }
+ }
+ return
+ }
+
+ method CheckSerialization {value startst states acc trans syms} {
+ # value is list/3 ('grammar::fa' symbols states)
+ # !("" in symbols)
+ # states is ordered dict (key is state, value is statedata)
+ # statedata is list/3 (start final trans|"")
+ # start is boolean
+ # final is boolean
+ # trans is dict (key in symbols, value is destinations)
+ # destinations is set of states
+
+ upvar 1 $startst startstates \
+ $states sts \
+ $acc a \
+ $trans t \
+ $syms symbols
+
+ set prefix "error in serialization:"
+ if {[llength $value] != 3} {
+ return -code error "$prefix list length not 3"
+ }
+
+ struct::list assign $value stype symbols statedata
+
+ if {$stype ne "grammar::fa"} {
+ return -code error "$prefix unknown type \"$stype\""
+ }
+ if {[struct::set contains $symbols ""]} {
+ return -code error "$prefix empty symbol is not legal"
+ }
+
+ if {[llength $statedata] % 2 == 1} {
+ return -code error "$prefix state data is not a dictionary"
+ }
+ array set _states $statedata
+ if {[llength $statedata] != (2*[array size _states])} {
+ return -code error "$prefix state data contains duplicate states"
+ }
+ set startstates {}
+ set sts {}
+ set p {}
+ set a {}
+ set e {}
+ set l {}
+ set m {}
+ set t {}
+ foreach {k v} $statedata {
+ lappend sts $k
+ if {[llength $v] != 3} {
+ return -code error "$prefix state list length not 3"
+ }
+
+ struct::list assign $v begin accept trans
+
+ if {![string is boolean -strict $begin]} {
+ return -code error "$prefix expected boolean for start, got \"$begin\""
+ }
+ if {$begin} {lappend startstates $k}
+ if {![string is boolean -strict $accept]} {
+ return -code error "$prefix expected boolean for final, got \"$accept\""
+ }
+ if {$accept} {lappend a $k}
+
+ if {[llength $trans] % 2 == 1} {
+ return -code error "$prefix transition data is not a dictionary"
+ }
+ array set _trans $trans
+ if {[llength $trans] != (2*[array size _trans])} {
+ return -code error "$prefix transition data contains duplicate symbols"
+ }
+ unset _trans
+
+ foreach {sym destinations} $trans {
+ # destinations = list of state
+ if {($sym ne "") && ![struct::set contains $symbols $sym]} {
+ return -code error "$prefix illegal symbol \"$sym\" in transition"
+ }
+ foreach dest $destinations {
+ if {![info exists _states($dest)]} {
+ return -code error "$prefix illegal destination state \"$dest\""
+ }
+ lappend t $k $sym $dest
+ }
+ }
+ }
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Type API implementation.
+
+ # ### ### ### ######### ######### #########
+ ## Type Internals.
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Initialization. Specify the container constructor command to use by
+## the operations package.
+
+::grammar::fa::op::constructor ::grammar::fa
+
+# ### ### ### ######### ######### #########
+## Package Management
+
+package provide grammar::fa 0.5
diff --git a/tcllib/modules/grammar_fa/fa.test b/tcllib/modules/grammar_fa/fa.test
new file mode 100644
index 0000000..b64a4a3
--- /dev/null
+++ b/tcllib/modules/grammar_fa/fa.test
@@ -0,0 +1,44 @@
+# -*- tcl -*-
+# fa.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa.test,v 1.12 2009/10/27 21:17:23 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 1.0
+snitErrors
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use snit/snit.tcl snit ; # 1.1 always, even when Tcl 8.5 runs the testsuite.
+ use struct/list.tcl struct::list
+
+ useLocalFile tests/Xsupport
+ useLocal faop.tcl grammar::fa::op
+}
+testing {
+ useLocalKeep fa.tcl grammar::fa
+}
+
+# -------------------------------------------------------------------------
+
+set class ::grammar::fa
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::set setimpl {
+ TestFiles tests/fa_*.test
+}
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
diff --git a/tcllib/modules/grammar_fa/faop.man b/tcllib/modules/grammar_fa/faop.man
new file mode 100644
index 0000000..f087391
--- /dev/null
+++ b/tcllib/modules/grammar_fa/faop.man
@@ -0,0 +1,480 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin grammar::fa::op n 0.4]
+[keywords automaton]
+[keywords {finite automaton}]
+[keywords grammar]
+[keywords parsing]
+[keywords {regular expression}]
+[keywords {regular grammar}]
+[keywords {regular languages}]
+[keywords state]
+[keywords transducer]
+[copyright {2004-2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Finite automaton operations and usage}]
+[titledesc {Operations on finite automatons}]
+[category {Grammars and finite automata}]
+[require Tcl 8.4]
+[require snit]
+[require struct::list]
+[require struct::set]
+[require grammar::fa::op [opt 0.4.1]]
+[description]
+[para]
+
+This package provides a number of complex operations on finite
+automatons (Short: FA),
+
+as provided by the package [package grammar::fa].
+
+The package does not provide the ability to create and/or manipulate
+such FAs, nor the ability to execute a FA for a stream of symbols.
+
+Use the packages [package grammar::fa]
+and [package grammar::fa::interpreter] for that.
+
+Another package related to this is [package grammar::fa::compiler]
+which turns a FA into an executor class which has the definition of
+the FA hardwired into it.
+
+[para]
+
+For more information about what a finite automaton is see section
+[emph {FINITE AUTOMATONS}] in package [package grammar::fa].
+
+[section API]
+
+The package exports the API described here. All commands modify their
+first argument. I.e. whatever FA they compute is stored back into
+it. Some of the operations will construct an automaton whose states
+are all new, but related to the states in the source
+automaton(s). These operations take variable names as optional
+arguments where they will store mappings which describe the
+relationship(s).
+
+The operations can be loosely partitioned into structural and language
+operations. The latter are defined in terms of the language the
+automaton(s) accept, whereas the former are defined in terms of the
+structural properties of the involved automaton(s). Some operations
+are both.
+
+[emph {Structure operations}]
+
+[list_begin definitions]
+
+[call [cmd ::grammar::fa::op::constructor] [arg cmd]]
+
+This command has to be called by the user of the package before any other
+operations is performed, to establish a command which can be used to
+construct a FA container object. If this is not done several operations
+will fail as they are unable to construct internal and transient containers
+to hold state and/or partial results.
+
+[para]
+
+Any container class using this package for complex operations should set
+its own class command as the constructor. See package [package grammar::fa]
+for an example.
+
+[call [cmd ::grammar::fa::op::reverse] [arg fa]]
+
+Reverses the [arg fa]. This is done by reversing the direction of all
+transitions and swapping the sets of [term start] and [term final]
+states. The language of [arg fa] changes unpredictably.
+
+[call [cmd ::grammar::fa::op::complete] [arg fa] [opt [arg sink]]]
+
+Completes the [arg fa] [term complete], but nothing is done if the
+[arg fa] is already [term complete]. This implies that only the first
+in a series of multiple consecutive complete operations on [arg fa]
+will perform anything. The remainder will be null operations.
+
+[para]
+
+The language of [arg fa] is unchanged by this operation.
+
+[para]
+
+This is done by adding a single new state, the [term sink], and
+transitions from all other states to that sink for all symbols they
+have no transitions for. The sink itself is made complete by adding
+loop transitions for all symbols.
+
+[para]
+
+Note: When a FA has epsilon-transitions transitions over a symbol for
+a state S can be indirect, i.e. not attached directly to S, but to a
+state in the epsilon-closure of S. The symbols for such indirect
+transitions count when computing completeness of a state. In other
+words, these indirectly reached symbols are [emph not] missing.
+
+[para]
+
+The argument [arg sink] provides the name for the new state and most
+not be present in the [arg fa] if specified. If the name is not
+specified the command will name the state "sink[var n]", where [var n]
+is set so that there are no collisions with existing states.
+
+[para]
+
+Note that the sink state is [term {not useful}] by definition. In
+other words, while the FA becomes complete, it is also
+[term {not useful}] in the strict sense as it has a state from which
+no final state can be reached.
+
+[call [cmd ::grammar::fa::op::remove_eps] [arg fa]]
+
+Removes all epsilon-transitions from the [arg fa] in such a manner the
+the language of [arg fa] is unchanged. However nothing is done if the
+[arg fa] is already [term epsilon-free].
+
+This implies that only the first in a series of multiple consecutive
+complete operations on [arg fa] will perform anything. The remainder
+will be null operations.
+
+[para]
+
+[emph Note:] This operation may cause states to become unreachable or
+not useful. These states are not removed by this operation.
+
+Use [cmd ::grammar::fa::op::trim] for that instead.
+
+[call [cmd ::grammar::fa::op::trim] [arg fa] [opt [arg what]]]
+
+Removes unwanted baggage from [arg fa].
+
+The legal values for [arg what] are listed below. The command defaults
+to [const !reachable|!useful] if no specific argument was given.
+
+[list_begin definitions]
+[def [const !reachable]]
+Removes all states which are not reachable from a start state.
+
+[def [const !useful]]
+Removes all states which are unable to reach a final state.
+
+[def [const !reachable&!useful]]
+[def [const !(reachable|useful)]]
+Removes all states which are not reachable from a start state and are
+unable to reach a final state.
+
+[def [const !reachable|!useful]]
+[def [const !(reachable&useful)]]
+Removes all states which are not reachable from a start state or are
+unable to reach a final state.
+
+[list_end]
+[para]
+
+[call [cmd ::grammar::fa::op::determinize] [arg fa] [opt [arg mapvar]]]
+
+Makes the [arg fa] deterministic without changing the language
+accepted by the [arg fa]. However nothing is done if the [arg fa] is
+already [term deterministic]. This implies that only the first in a
+series of multiple consecutive complete operations on [arg fa] will
+perform anything. The remainder will be null operations.
+
+[para]
+
+The command will store a dictionary describing the relationship
+between the new states of the resulting dfa and the states of the
+input nfa in [arg mapvar], if it has been specified. Keys of the
+dictionary are the handles for the states of the resulting dfa, values
+are sets of states from the input nfa.
+
+[para]
+
+[emph Note]: An empty dictionary signals that the command was able to
+make the [arg fa] deterministic without performing a full subset
+construction, just by removing states and shuffling transitions around
+(As part of making the FA epsilon-free).
+
+[para]
+
+[emph Note]: The algorithm fails to make the FA deterministic in the
+technical sense if the FA has no start state(s), because determinism
+requires the FA to have exactly one start states.
+
+In that situation we make a best effort; and the missing start state
+will be the only condition preventing the generated result from being
+[term deterministic].
+
+It should also be noted that in this case the possibilities for
+trimming states from the FA are also severely reduced as we cannot
+declare states unreachable.
+
+[call [cmd ::grammar::fa::op::minimize] [arg fa] [opt [arg mapvar]]]
+
+Creates a FA which accepts the same language as [arg fa], but has a
+minimal number of states. Uses Brzozowski's method to accomplish this.
+
+[para]
+
+The command will store a dictionary describing the relationship
+between the new states of the resulting minimal fa and the states of
+the input fa in [arg mapvar], if it has been specified. Keys of the
+dictionary are the handles for the states of the resulting minimal fa,
+values are sets of states from the input fa.
+
+[para]
+
+[emph Note]: An empty dictionary signals that the command was able to
+minimize the [arg fa] without having to compute new states. This
+should happen if and only if the input FA was already minimal.
+
+[para]
+
+[emph Note]: If the algorithm has no start or final states to work
+with then the result might be technically minimal, but have a very
+unexpected structure.
+
+It should also be noted that in this case the possibilities for
+trimming states from the FA are also severely reduced as we cannot
+declare states unreachable.
+
+[list_end]
+
+[emph {Language operations}]
+
+All operations in this section require that all input FAs have at
+least one start and at least one final state. Otherwise the language of
+the FAs will not be defined, making the operation senseless (as it
+operates on the languages of the FAs in a defined manner).
+
+[list_begin definitions]
+
+[call [cmd ::grammar::fa::op::complement] [arg fa]]
+
+Complements [arg fa]. This is possible if and only if [arg fa] is
+[term complete] and [term deterministic]. The resulting FA accepts the
+complementary language of [arg fa]. In other words, all inputs not
+accepted by the input are accepted by the result, and vice versa.
+
+[para]
+
+The result will have all states and transitions of the input, and
+different final states.
+
+[call [cmd ::grammar::fa::op::kleene] [arg fa]]
+
+Applies Kleene's closure to [arg fa].
+
+The resulting FA accepts all strings [var S] for which we can find a
+natural number [var n] (0 inclusive) and strings [var A1] ... [var An]
+in the language of [arg fa] such that [var S] is the concatenation of
+[var A1] ... [var An].
+
+In other words, the language of the result is the infinite union over
+finite length concatenations over the language of [arg fa].
+
+[para]
+
+The result will have all states and transitions of the input, and new
+start and final states.
+
+[call [cmd ::grammar::fa::op::optional] [arg fa]]
+
+Makes the [arg fa] optional. In other words it computes the FA which
+accepts the language of [arg fa] and the empty the word (epsilon) as
+well.
+
+[para]
+
+The result will have all states and transitions of the input, and new
+start and final states.
+
+[call [cmd ::grammar::fa::op::union] [arg fa] [arg fb] [opt [arg mapvar]]]
+
+Combines the FAs [arg fa] and [arg fb] such that the resulting FA
+accepts the union of the languages of the two FAs.
+
+[para]
+
+The result will have all states and transitions of the two input FAs,
+and new start and final states. All states of [arg fb] which exist in
+[arg fa] as well will be renamed, and the [arg mapvar] will contain a
+mapping from the old states of [arg fb] to the new ones, if present.
+
+[para]
+
+It should be noted that the result will be non-deterministic, even if
+the inputs are deterministic.
+
+[call [cmd ::grammar::fa::op::intersect] [arg fa] [arg fb] [opt [arg mapvar]]]
+
+Combines the FAs [arg fa] and [arg fb] such that the resulting FA
+accepts the intersection of the languages of the two FAs. In other
+words, the result will accept a word if and only if the word is
+accepted by both [arg fa] and [arg fb]. The result will be useful, but
+not necessarily deterministic or minimal.
+
+[para]
+
+The command will store a dictionary describing the relationship
+between the new states of the resulting fa and the pairs of states of
+the input FAs in [arg mapvar], if it has been specified. Keys of the
+dictionary are the handles for the states of the resulting fa, values
+are pairs of states from the input FAs. Pairs are represented by
+lists. The first element in each pair will be a state in [arg fa], the
+second element will be drawn from [arg fb].
+
+[call [cmd ::grammar::fa::op::difference] [arg fa] [arg fb] [opt [arg mapvar]]]
+
+Combines the FAs [arg fa] and [arg fb] such that the resulting FA
+accepts the difference of the languages of the two FAs. In other
+words, the result will accept a word if and only if the word is
+accepted by [arg fa], but not by [arg fb]. This can also be expressed
+as the intersection of [arg fa] with the complement of [arg fb]. The
+result will be useful, but not necessarily deterministic or minimal.
+
+[para]
+
+The command will store a dictionary describing the relationship
+between the new states of the resulting fa and the pairs of states of
+the input FAs in [arg mapvar], if it has been specified. Keys of the
+dictionary are the handles for the states of the resulting fa, values
+are pairs of states from the input FAs. Pairs are represented by
+lists. The first element in each pair will be a state in [arg fa], the
+second element will be drawn from [arg fb].
+
+[call [cmd ::grammar::fa::op::concatenate] [arg fa] [arg fb] [opt [arg mapvar]]]
+
+Combines the FAs [arg fa] and [arg fb] such that the resulting FA
+accepts the cross-product of the languages of the two FAs. I.e. a word
+W will be accepted by the result if there are two words A and B
+accepted by [arg fa], and [arg fb] resp. and W is the concatenation of
+A and B.
+
+[para]
+
+The result FA will be non-deterministic.
+
+[call [cmd ::grammar::fa::op::fromRegex] [arg fa] [arg regex] [opt [arg over]]]
+
+Generates a non-deterministic FA which accepts the same language as
+the regular expression [arg regex]. If the [arg over] is specified it
+is treated as the set of symbols the regular expression and the
+automaton are defined over. The command will compute the set from the
+"S" constructors in [arg regex] when [arg over] was not
+specified. This set is important if and only if the complement
+operator "!" is used in [arg regex] as the complementary language of
+an FA is quite different for different sets of symbols.
+
+[para]
+
+The regular expression is represented by a nested list, which forms
+a syntax tree. The following structures are legal:
+
+[list_begin definitions]
+
+[def "{S x}"]
+
+Atomic regular expression. Everything else is constructed from
+these. Accepts the [const S]ymbol "x".
+
+[def "{. A1 A2 ...}"]
+
+Concatenation operator. Accepts the concatenation of the regular
+expressions [var A1], [var A2], etc.
+
+[para]
+
+[emph Note] that this operator accepts zero or more arguments. With zero
+arguments the represented language is [term epsilon], the empty word.
+
+[def "{| A1 A2 ...}"]
+
+Choice operator, also called "Alternative". Accepts all input accepted
+by at least one of the regular expressions [var A1], [var A2], etc. In
+other words, the union of [var A1], [var A2].
+
+[para]
+
+[emph Note] that this operator accepts zero or more arguments. With zero
+arguments the represented language is the [term empty] language,
+the language without words.
+
+[def "{& A1 A2 ...}"]
+
+Intersection operator, logical and. Accepts all input accepted which
+is accepted by all of the regular expressions [var A1], [var A2],
+etc. In other words, the intersection of [var A1], [var A2].
+
+[def "{? A}"]
+
+Optionality operator. Accepts the empty word and anything from the
+regular expression [var A].
+
+[def "{* A}"]
+
+Kleene closure. Accepts the empty word and any finite concatenation of
+words accepted by the regular expression [var A].
+
+[def "{+ A}"]
+
+Positive Kleene closure. Accepts any finite concatenation of words
+accepted by the regular expression [var A], but not the empty word.
+
+[def "{! A}"]
+
+Complement operator. Accepts any word not accepted by the regular
+expression [var A]. Note that the complement depends on the set of
+symbol the result should run over. See the discussion of the argument
+[arg over] before.
+
+[list_end]
+
+[call [cmd ::grammar::fa::op::toRegexp] [arg fa]]
+
+This command generates and returns a regular expression which accepts
+the same language as the finite automaton [arg fa]. The regular
+expression is in the format as described above, for
+[cmd ::grammar::fa::op::fromRegex].
+
+[call [cmd ::grammar::fa::op::toRegexp2] [arg fa]]
+
+This command has the same functionality as [cmd ::grammar::fa::op::toRegexp],
+but uses a different algorithm to simplify the generated regular expressions.
+
+[call [cmd ::grammar::fa::op::toTclRegexp] [arg regexp] [arg symdict]]
+
+This command generates and returns a regular expression in Tcl syntax for the
+regular expression [arg regexp], if that is possible. [arg regexp] is in the
+same format as expected by [cmd ::grammar::fa::op::fromRegex].
+
+[para]
+
+The command will fail and throw an error if [arg regexp] contains
+complementation and intersection operations.
+
+[para]
+
+The argument [arg symdict] is a dictionary mapping symbol names to
+pairs of [term {syntactic type}] and Tcl-regexp. If a symbol
+occurring in the [arg regexp] is not listed in this dictionary then
+single-character symbols are considered to designate themselves
+whereas multiple-character symbols are considered to be a character
+class name.
+
+[call [cmd ::grammar::fa::op::simplifyRegexp] [arg regexp]]
+
+This command simplifies a regular expression by applying the following
+algorithm first to the main expression and then recursively to all
+sub-expressions:
+
+[list_begin enum]
+[enum] Convert the expression into a finite automaton.
+[enum] Minimize the automaton.
+[enum] Convert the automaton back to a regular expression.
+[enum] Choose the shorter of original expression and expression from
+the previous step.
+[list_end]
+
+[list_end]
+
+[para]
+
+[section EXAMPLES]
+
+[vset CATEGORY grammar_fa]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/grammar_fa/faop.tcl b/tcllib/modules/grammar_fa/faop.tcl
new file mode 100644
index 0000000..5c0804e
--- /dev/null
+++ b/tcllib/modules/grammar_fa/faop.tcl
@@ -0,0 +1,1618 @@
+# -*- tcl -*-
+# Grammar / FA / Operations
+
+# ### ### ### ######### ######### #########
+## Package description
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require struct::list ; # Extended list operations.
+package require struct::set ; # Extended set operations.
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+namespace eval ::grammar::fa::op {
+
+ # ### ### ### ######### ######### #########
+ ## API. Structure / Language / Compilation
+
+ proc reverse {fa} {}
+ proc complete {fa {sink {}}} {}
+ proc remove_eps {fa} {}
+ proc trim {fa {what !reachable|!useful}} {}
+ proc determinize {fa {mapvar {}} {idstart 0}} {}
+ proc minimize {fa {mapvar {}}} {}
+
+ proc complement {fa} {}
+ proc kleene {fa} {}
+ proc optional {fa} {}
+ proc union {fa fb {mapvar {}}} {}
+ proc intersect {fa fb {mapvar {}} {idstart 0}} {}
+ proc difference {fa fb {mapvar {}}} {}
+ proc concatenate {fa fb {mapvar {}}} {}
+
+ proc fromRegex {fa regex {over {}}} {}
+
+ proc toRegexp {fa} {}
+ proc toRegexp2 {fa} {}
+
+ proc simplifyRegexp {rex} {}
+ proc toTclRegexp {rex symdict} {}
+
+ # ### ### ### ######### ######### #########
+
+ namespace export reverse complete remove_eps trim \
+ determinize minimize complement kleene \
+ optional union intersect difference \
+ concatenate fromRegex toRegexp toRegexp2 \
+ simplifyRegexp toTclRegexp
+
+ # ### ### ### ######### ######### #########
+ ## Internal data structures.
+
+ variable cons {}
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## API implementation. Structure
+
+proc ::grammar::fa::op::reverse {fa} {
+ # Reversal means that all transitions change their direction
+ # and start and final states are swapped.
+
+ # Note that reversed FA might not be deterministic, even if the FA
+ # itself was.
+
+ # One loop is not enough for this. If we reverse the
+ # transitions for a state immediately we may modify a state
+ # which has not been processed yet. And when we come to this
+ # state we reverse already reversed transitions, creating a
+ # complete mess. Thus two loops, one to collect the current
+ # transitions (and also remove them), and a second to insert
+ # the reversed transitions.
+
+ set tmp [$fa finalstates]
+ $fa final set [$fa startstates]
+ $fa start set $tmp
+
+ # FUTURE : Method to retrieve all transitions
+ # FUTURE : Method to delete all transitions
+
+ set trans {}
+ foreach s [$fa states] {
+ foreach sym [$fa symbols@ $s] {
+ lappend trans $s $sym [$fa next $s $sym]
+ $fa !next $s $sym
+ }
+ }
+ foreach {s sym destinations} $trans {
+ foreach d $destinations {
+ $fa next $d $sym --> $s
+ }
+ }
+ return
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::complete {fa {sink {}}} {
+ if {[$fa is complete]} return
+
+ # We have an incomplete FA.
+
+ if {$sink eq ""} {
+ set sink [FindNewState $fa sink]
+ } elseif {[$fa state exists $sink]} {
+ return -code error "The chosen sink state exists already"
+ }
+ $fa state add $sink
+
+ # Add transitions to it from all states which are not
+ # complete. The sink state itself loops on all inputs. IOW it is a
+ # non-useful state.
+
+ set symbols [$fa symbols]
+ foreach sym $symbols {
+ $fa next $sink $sym --> $sink
+ }
+
+ if {[$fa is epsilon-free]} {
+ foreach s [$fa states] {
+ foreach missing [struct::set difference \
+ $symbols \
+ [$fa symbols@ $s]] {
+ $fa next $s $missing --> $sink
+ }
+ }
+ } else {
+ # For an FA with epsilon-transitions we cannot simply look at
+ # the direct transitions to find the used symbols. We have to
+ # determine this for the epsilon-closure of the state in
+ # question. Oh, and we have to defer actually adding the
+ # transitions after we have picked them all, or otherwise the
+ # newly added transitions throw the symbol calculations for
+ # epsilon closures off.
+
+ set new {}
+ foreach s [$fa states] {
+ foreach missing [struct::set difference \
+ $symbols \
+ [$fa symbols@set [$fa epsilon_closure $s]]] {
+ lappend new $s $missing
+ }
+ }
+
+ foreach {s missing} $new {
+ $fa next $s $missing --> $sink
+ }
+ }
+ return
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::remove_eps {fa} {
+ # We eliminate all epsilon transitions by duplicating a number
+ # of regular transitions, which we get through the epsilon
+ # closure of the states having epsilon transitions. We do
+ # nothing if the FA is epsilon free to begin with.
+
+ if {[$fa is epsilon-free]} return
+
+ # Note: Epsilon transitions touching start and final states
+ # propagate the start markers forward and final markers
+ # backward. We do this first by propagating start markers twice,
+ # once with a reversed FA. This also gives us some
+ # epsilon-closures as well.
+
+ foreach n {1 2} {
+ foreach s [$fa startstates] {
+ foreach e [$fa epsilon_closure $s] {
+ $fa start add $e
+ }
+ }
+ reverse $fa
+ }
+
+ # Now duplicate all transitions which are followed or preceeded by
+ # epsilon transitions of any number greater than zero.
+
+ # Note: The closure computations done by the FA are cached in the
+ # FA, so doing it multiple times is no big penalty.
+
+ # FUTURE : Retrieve all transitions on one command.
+
+ # FUTURE : Different algorithm ...
+ # Retrieve non-eps transitions for all states ...
+ # Iterate this list. Compute e-closures for endpoints, cache
+ # them. Duplicate the transition if needed, in that case add it to
+ # the end of the list, for possible more duplication (may touch
+ # different e-closures). Stop when the list is empty again.
+
+ set changed 1
+ while {$changed} {
+ set changed 0
+ foreach s [$fa states] {
+ foreach sym [$fa symbols@ $s] {
+ set dest [$fa next $s $sym]
+ if {$sym eq ""} {
+ # Epsilon transitions.
+
+ # Get the closure, and duplicate all transitions for all
+ # non-empty symbols as transitions of the original state.
+ # This may lead to parallel transitions between states, hence
+ # the catch. It prevents the generated error from stopping the
+ # action, and no actual parallel transitions are created.
+
+ set clos [$fa epsilon_closure $s]
+ foreach csym [$fa symbols@set $clos] {
+ if {$csym eq ""} continue
+ foreach d [$fa nextset $clos $csym] {
+ if {![catch {$fa next $s $csym --> $d} msg]} {
+ set changed 1
+ }
+ }
+ }
+ } else {
+ # Regular transition. Go through all destination
+ # states, compute their closures and replicate the
+ # transition if the closure contains more than the
+ # destination itself, to all states in the closure.
+
+ foreach d $dest {
+ set clos [$fa epsilon_closure $d]
+ if {[llength $clos] > 1} {
+ foreach e $clos {
+ if {![catch {$fa next $s $sym --> $e}]} {
+ set changed 1
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+
+ # At last, drop the epsilons for all states. Only now is this
+ # possible because otherwise we might compute bad epsilon
+ # closures in the previous loop.
+
+ foreach s [$fa states] {
+ $fa !next $s ""
+ }
+ return
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::trim {fa {what !reachable|!useful}} {
+ # Remove various unwanted pices from the FA.
+
+ switch -exact -- $what {
+ !reachable {
+ set remove [$fa unreachable_states]
+ }
+ !useful {
+ set remove [$fa unuseful_states]
+ }
+ !reachable&!useful -
+ !(reachable|useful) {
+ set remove [struct::set intersect [$fa unreachable_states] [$fa unuseful_states]]
+ }
+ !reachable|!useful -
+ !(reachable&useful) {
+ set remove [struct::set union [$fa unreachable_states] [$fa unuseful_states]]
+ }
+ default {
+ return -code error "Expected !reachable, !useful, !reachable&!useful, !(reachable|useful), !reachable|!useful, or !(reachable&useful), got \"$what\""
+ }
+ }
+
+ foreach s $remove {
+ $fa state delete $s
+ }
+ return
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::determinize {fa {mapvar {}} {idstart 0}} {
+ # We do the operation in several stages instead of jumping
+ # directly in the subset construction. Basically we try the less
+ # expensive operations first to see if they are enough. It does
+ # help that they will us also bring nearer to the ultimate goal
+ # even if they are not enough.
+
+ set hasmap 0
+ if {$mapvar ne ""} {
+ upvar 1 $mapvar map ; set hasmap 1
+ }
+
+ # First, is the input already deterministic ?
+ # There is nothing to do in that case.
+
+ if {[$fa is deterministic]} {
+ if {$hasmap} {set map {}}
+ return
+ }
+
+ # Second, trim unreachable and unuseables. We are done if only
+ # they carried the non-determinism. Otherwise we might have made
+ # the FA smaller and was less time consuming to convert.
+
+ if {[llength [$fa startstates]]} {trim $fa !reachable}
+ if {[llength [$fa finalstates]]} {trim $fa !useful}
+ if {[$fa is deterministic]} {
+ if {$hasmap} {set map {}}
+ return
+ }
+
+ # Third, remove any epsilon transitions, and stop if that was
+ # enough. Of course, weed out again states which have become
+ # irrelevant. The removal of the epsilons will at least ensure
+ # that the subset construction won't have to deal with
+ # closures. I.e. simpler.
+
+ remove_eps $fa
+ if {[llength [$fa startstates]]} {trim $fa !reachable}
+ if {[llength [$fa finalstates]]} {trim $fa !useful}
+ if {[$fa is deterministic]} {
+ if {$hasmap} {set map {}}
+ return
+ }
+
+ # Fourth. There is no way to avoid the subset construction.
+ # Dive in. This is the only part of the algorithm which requires
+ # us to keep a map. We construct the dfa in a transient container
+ # and copy the result back to fa when completed.
+
+ array set subsets {}
+ set id $idstart
+ set pending {}
+ set dfa [[cons] %AUTO%]
+ # FUTURE : $dfa symbol set [$fa symbols]
+ foreach sym [$fa symbols] {$dfa symbol add $sym}
+
+ # If we have start states we can initialize the algorithm with
+ # their set. Otherwise we have to the single-element sets of all
+ # states as the beginning.
+
+ set starts [$fa startstates]
+ if {[llength $starts] > 0} {
+ # Make the set of start states the initial stae of the result.
+
+ set starts [lsort $starts] ; # Sort to get canonical form.
+ $dfa state add $id
+ $dfa start add $id
+
+ # The start may also be a final state
+ if {[$fa final?set $starts]} {
+ $dfa final add $id
+ }
+
+ set subsets(dfa,$starts) $id
+ set subsets(nfa,$id) $starts
+
+ lappend pending $id
+ incr id
+ } else {
+ # Convert all states of the input into sets (of one element)
+ # in the output. Do not forget to mark all final states we
+ # come by. No start states, otherwise we wouldn't be here.
+
+ foreach s [$fa states] {
+ set nfaset [list $s]
+
+ $dfa state add $id
+ if {[$fa final? $s]} {
+ $dfa final add $id
+ }
+
+ set subsets(dfa,$nfaset) $id
+ set subsets(nfa,$id) $nfaset
+ lappend pending $id
+ incr id
+ }
+ }
+
+ while {[llength $pending]} {
+ set dfastate [struct::list shift pending]
+
+ # We have to compute the transition function for this dfa state.
+
+ set nfaset $subsets(nfa,$dfastate)
+
+ foreach sym [$fa symbols@set $nfaset] {
+ set nfanext [lsort [$fa nextset $nfaset $sym]]
+
+ if {![info exists subsets(dfa,$nfanext)]} {
+ # Unknown destination. Add it as a new state.
+
+ $dfa state add $id
+ if {[$fa final?set $nfanext]} {
+ $dfa final add $id
+ }
+
+ set subsets(dfa,$nfanext) $id
+ set subsets(nfa,$id) $nfanext
+
+ # Schedule the calculation of the transition function
+ # of the new state.
+
+ lappend pending $id
+ incr id
+ }
+
+ # Add the transition
+ $dfa next $dfastate $sym --> $subsets(dfa,$nfanext)
+ }
+ }
+
+ if {[llength [$fa startstates]]} {trim $fa !reachable}
+ if {[llength [$fa finalstates]]} {trim $fa !useful}
+
+ if {$hasmap} {
+ # The map is from new dfa states to the sets of nfa states.
+
+ set map {}
+ foreach s [$dfa states] {
+ lappend map $s $subsets(nfa,$s)
+ }
+ }
+
+ $fa = $dfa
+ $dfa destroy
+
+ # ASSERT : $fa is deterministic
+ return
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::minimize {fa {mapvar {}}} {
+ # Brzozowski's method:
+ # Reverse, determinize, reverse again, determinize again.
+
+ reverse $fa
+ determinize $fa mapa
+ reverse $fa
+ determinize $fa mapb
+
+ if {$mapvar ne ""} {
+ upvar 1 $mapvar map
+
+ if {![llength $mapa] && ![llength $mapb]} {
+ # No state reorganizations, signal up
+ set map {}
+ } elseif {[llength $mapa] && ![llength $mapb]} {
+ # Only one reorg, this is the combined reorg as well.
+ set map $mapa
+ } elseif {![llength $mapa] && [llength $mapb]} {
+ # Only one reorg, this is the combined reorg as well.
+ set map $mapb
+ } else {
+ # Two reorgs. Compose the maps into the final map signaled
+ # up.
+
+ # mapb : final state -> set of states in mapa -> sets of original states.
+
+ set map {}
+ array set tmp $mapa
+ foreach {b aset} $mapb {
+ set compose {}
+ foreach a $aset {foreach o $tmp($a) {lappend compose $o}}
+ lappend map $b [lsort -uniq $compose]
+ }
+ }
+ }
+
+ # The FA is implicitly trimmed by the determinize's.
+ return
+}
+
+# ### ### ### ######### ######### #########
+## API implementation. Language.
+
+proc ::grammar::fa::op::complement {fa} {
+ # Complementing is possible if and only if the FA is complete,
+ # and accomplished by swapping the final and non-final states.
+
+ if {![$fa is complete]} {
+ return -code error "Unable to complement incomplete FA"
+ }
+ if {![$fa is deterministic]} {
+ return -code error "Unable to complement non-deterministic FA"
+ }
+
+ set newfinal [struct::set difference [$fa states] [$fa finalstates]]
+ $fa final set $newfinal
+ return
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::kleene {fa} {
+ # The Kleene Closure of the FA makes no sense if we don't have
+ # start and final states we can work from.
+
+ set start [$fa startstates]
+ set final [$fa finalstates]
+
+ if {![llength $start] || ![llength $final]} {
+ return -code error "Unable to add Kleene's closure to a FA without start/final states"
+ }
+
+ # FUTURE :: If final states have no outgoing transitions, and start
+ # FUTURE :: states have no input transitions, then place the new
+ # FUTURE :: transitions directly between start and final
+ # FUTURE :: states. In that case we don't need new states.
+
+ # We need new start/final states, like for optional (see below)
+
+ set ns [NewState $fa s]
+ set nf [NewState $fa f]
+
+ foreach s $start {$fa next $ns "" --> $s}
+ foreach f $final {$fa next $f "" --> $nf}
+
+ $fa start clear ; $fa start add $ns
+ $fa final clear ; $fa final add $nf
+
+ $fa next $ns "" --> $nf ; # Optionality
+ $fa next $nf "" --> $ns ; # Loop for closure
+ return
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::optional {fa} {
+ # The Optionality of the FA makes no sense if we don't have
+ # start and final states we can work from.
+
+ set start [$fa startstates]
+ set final [$fa finalstates]
+
+ if {![llength $start] || ![llength $final]} {
+ return -code error "Unable to make a FA without start/final states optional"
+ }
+
+ # We have to introduce new start and final states to ensure
+ # that we do not get additional recognized words from the FA
+ # due to epsilon transitions. IOW just placing epsilons from
+ # all start to all final states is wrong. Consider unreachable
+ # final states, they become reachable. Or final states able to
+ # reach final states from. Again the epsilons would extend the
+ # language. We have to detach our optional epsilon from anything
+ # in the existing start/final states. Hence the new start/final.
+
+ # FUTURE : Recognize if there are no problems with placing direct
+ # FUTURE : epsilons from start to final.
+
+ set ns [NewState $fa s]
+ set nf [NewState $fa f]
+
+ foreach s $start {$fa next $ns "" --> $s}
+ foreach f $final {$fa next $f "" --> $nf}
+
+ $fa start clear ; $fa start add $ns
+ $fa final clear ; $fa final add $nf
+
+ $fa next $ns "" --> $nf ; # This is the transition which creates the optionality.
+ return
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::union {fa fb {mapvar {}}} {
+ # We union the input symbols, then add the states and
+ # transitions of the second FA to the first, adding in
+ # epsilons for the start and final states as well. When
+ # adding states we make sure that the new states do not
+ # intersect with the existing states.
+
+ struct::list assign \
+ [MergePrepare $fa $fb union smap] \
+ astart afinal bstart bfinal
+
+ if {$mapvar ne ""} {
+ upvar 1 $mapvar map
+ set map $smap
+ }
+
+ # And now the new start & final states
+
+ set ns [NewState $fa s]
+ set nf [NewState $fa f]
+
+ eLink1N $fa $ns $astart
+ eLink1N $fa $ns $bstart
+
+ eLinkN1 $fa $afinal $nf
+ eLinkN1 $fa $bfinal $nf
+
+ $fa start clear ; $fa start add $ns
+ $fa final clear ; $fa final add $nf
+ return
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::intersect {fa fb {mapvar {}} {idstart 0}} {
+ # Intersection has to run the two automata in parallel, using
+ # paired states. If we have start states we begin the
+ # construction with them. This leads to a smaller result as we
+ # do not have create a full cross-crossproduct. The latter is
+ # unfortunately required if there are no start states.
+
+ struct::list assign [CrossPrepare $fa $fb intersection] tmp res
+
+ # The start states of the new FA consist of the cross-product of
+ # the start states of fa with fb. These are also the states used
+ # to seed DoCross.
+
+ set id $idstart
+ set smap {}
+ set bstart [$tmp startstates]
+ foreach a [$fa startstates] {
+ foreach b $bstart {
+ set pair [list $a $b]
+ lappend smap $id $pair
+ lappend pending $pair $id
+ $res state add $id
+ $res start add $id
+ incr id
+ }
+ }
+
+ set cp [DoCross $fa $tmp $res $id $pending smap]
+
+ foreach {id pair} $smap {
+ struct::list assign $pair a b
+ if {[$fa final? $a] && [$tmp final? $b]} {
+ $res final add $id
+ }
+ }
+
+ # Remove excess states (generated because of the sinks).
+ trim $res
+ if {$mapvar ne ""} {
+ upvar 1 $mapvar map
+ # The loop is required to filter out the mappings for all
+ # states which were trimmed off.
+ set map {}
+ foreach {id pair} $smap {
+ if {![$res state exists $id]} continue
+ lappend map $id $pair
+ }
+ }
+
+ # Copy result into permanent storage and delete all intermediaries
+ $fa = $res
+ $res destroy
+ if {$tmp ne $fb} {$tmp destroy}
+ return
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::difference {fa fb {mapvar {}}} {
+ # Difference has to run the two automata in parallel, using
+ # paired states. Only the final states are defined differently
+ # than for intersection. It has to be final in fa and _not_ final
+ # in fb to be a final state of the result. <=> Accepted by A, but
+ # not B, to be in the difference.
+
+ struct::list assign [CrossPrepare $fa $fb difference] tmp res
+
+ # The start states of the new FA consist of the cross-product of
+ # the start states of fa with fb. These are also the states used
+ # to seed DoCross.
+
+ set id 0
+ set smap {}
+ set bstart [$tmp startstates]
+ foreach a [$fa startstates] {
+ foreach b $bstart {
+ set pair [list $a $b]
+ lappend smap $id $pair
+ lappend pending $pair $id
+ $res state add $id
+ $res start add $id
+ incr id
+ }
+ }
+
+ set cp [DoCross $fa $tmp $res $id $pending smap]
+
+ foreach {id pair} $smap {
+ struct::list assign $pair a b
+ if {[$fa final? $a] && ![$tmp final? $b]} {
+ $res final add $id
+ }
+ }
+
+ # Remove excess states (generated because of the sinks).
+ trim $res
+ if {$mapvar ne ""} {
+ upvar 1 $mapvar map
+ # The loop is required to filter out the mappings for all
+ # states which were trimmed off.
+ set map {}
+ foreach {id pair} $smap {
+ if {![$res state exists $id]} continue
+ lappend map $id $pair
+ }
+ }
+
+ # Copy result into permanent storage and delete all intermediaries
+ $fa = $res
+ $res destroy
+ if {$tmp ne $fb} {$tmp destroy}
+ return
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::concatenate {fa fb {mapvar {}}} {
+ # Like union, only the interconnect between existing and new FA is different.
+
+ struct::list assign \
+ [MergePrepare $fa $fb concatenate smap] \
+ astart afinal bstart bfinal
+
+ if {$mapvar ne ""} {
+ upvar 1 $mapvar map
+ set map $smap
+ }
+
+ set ns [NewState $fa s]
+ set nm [NewState $fa m] ;# Midpoint.
+ set nf [NewState $fa f]
+
+ eLink1N $fa $ns $astart
+ eLinkN1 $fa $afinal $nm
+
+ eLink1N $fa $nm $bstart
+ eLinkN1 $fa $bfinal $nf
+
+ $fa start clear ; $fa start add $ns
+ $fa final clear ; $fa final add $nf
+ return
+}
+
+# ### ### ### ######### ######### #########
+## API implementation. Compilation (regexp -> FA).
+
+proc ::grammar::fa::op::fromRegex {fa regex {over {}}} {
+ # Convert a regular expression into a FA. The regex is given as
+ # parse tree in the form of a nested list.
+
+ # {. A B ...} ... Concatenation (accepts zero|one arguments).
+ # {| A B ...} ... Alternatives (accepts zero|one arguments).
+ # {? A} ... Optional.
+ # {* A} ... Kleene.
+ # {+ A} ... Pos.Kleene.
+ # {! A} ... Complement/Negation.
+ # {S Symbol} ... Atom, Symbol
+ #
+ # Recursive descent with a helper ...
+
+ if {![llength $regex]} {
+ $fa clear
+ return
+ }
+
+ set tmp [[cons] %AUTO%]
+
+ if {![llength $over]} {
+ set over [lsort -uniq [RESymbols $regex]]
+ }
+ foreach sym $over {
+ $tmp symbol add $sym
+ }
+
+ set id 0
+ struct::list assign [Regex $tmp $regex id] s f
+ $tmp start set [list $s]
+ $tmp final set [list $f]
+
+ $fa = $tmp
+ $tmp destroy
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal helpers.
+
+proc ::grammar::fa::op::RESymbols {regex} {
+ set cmd [lindex $regex 0]
+ switch -exact -- $cmd {
+ ? - * - ! - + {
+ return [RESymbols [lindex $regex 1]]
+ }
+ . - | - & {
+ set res {}
+ foreach sub [lrange $regex 1 end] {
+ foreach sym [RESymbols $sub] {lappend res $sym}
+ }
+ return $res
+ }
+ S {
+ return [list [lindex $regex 1]]
+ }
+ default {
+ return -code error "Expected . ! ? * | &, or S, got \"$cmd\""
+ }
+ }
+}
+
+proc ::grammar::fa::op::Regex {fa regex idvar} {
+ upvar 1 $idvar id
+ set cmd [lindex $regex 0]
+ switch -exact -- $cmd {
+ ? {
+ # Optional
+ set a $id ; incr id ; $fa state add $a
+ set b $id ; incr id ; $fa state add $b
+
+ struct::list assign [Regex $fa [lindex $regex 1] id] s f
+ $fa next $a "" --> $s
+ $fa next $f "" --> $b
+ $fa next $a "" --> $b
+ }
+ * {
+ # Kleene
+ set a $id ; incr id ; $fa state add $a
+ set b $a
+
+ struct::list assign [Regex $fa [lindex $regex 1] id] s f
+ $fa next $a "" --> $s
+ $fa next $f "" --> $a ;# == b
+ }
+ + {
+ # Pos. Kleene
+ set a $id ; incr id ; $fa state add $a
+ set b $id ; incr id ; $fa state add $b
+
+ struct::list assign [Regex $fa [lindex $regex 1] id] s f
+ $fa next $a "" --> $s
+ $fa next $f "" --> $b
+ $fa next $b "" --> $a
+ }
+ ! {
+ # Complement.
+ # Build up in a temp FA, complement, and
+ # merge nack into the current
+
+ set a $id ; incr id ; $fa state add $a
+ set b $id ; incr id ; $fa state add $b
+
+ set tmp [[cons] %AUTO%]
+ foreach sym [$fa symbols] {$tmp symbol add $sym}
+ struct::list assign [Regex $tmp [lindex $regex 1] id] s f
+ $tmp start add $s
+ $tmp final add $f
+
+ determinize $tmp {} $id
+ incr id [llength [$tmp states]]
+ if {![$tmp is complete]} {
+ complete $tmp $id
+ incr id
+ }
+ complement $tmp
+
+ # Merge and link.
+ $fa deserialize_merge [$tmp serialize]
+
+ eLink1N $fa $a [$tmp startstates]
+ eLinkN1 $fa [$tmp finalstates] $b
+ $tmp destroy
+ }
+ & {
+ # Intersection ... /And
+
+ if {[llength $regex] < 3} {
+ # Optimized path. Intersection of one sub-expression
+ # is the sub-expression itself.
+
+ struct::list assign [Regex $fa [lindex $regex 1] id] a b
+ } else {
+ set a $id ; incr id ; $fa state add $a
+ set b $id ; incr id ; $fa state add $b
+
+ set tmp [[cons] %AUTO%]
+ foreach sym [$fa symbols] {$tmp symbol add $sym}
+ set idsub 0
+ struct::list assign [Regex $tmp [lindex $regex 1] idsub] s f
+ $tmp start add $s
+ $tmp final add $f
+
+ set beta [[cons] %AUTO%]
+ foreach sub [lrange $regex 2 end] {
+ foreach sym [$fa symbols] {$beta symbol add $sym}
+ struct::list assign [Regex $beta $sub idsub] s f
+ $beta start add $s
+ $beta final add $f
+ intersect $tmp $beta {} $id
+ }
+ $beta destroy
+ determinize $tmp {} $id
+ incr id [llength [$tmp states]]
+
+ # Merge and link.
+ $fa deserialize_merge [$tmp serialize]
+
+ eLink1N $fa $a [$tmp startstates]
+ eLinkN1 $fa [$tmp finalstates] $b
+ $tmp destroy
+ }
+ }
+ . {
+ # Concatenation ...
+
+ if {[llength $regex] == 1} {
+ # Optimized path. No sub-expressions. This represents
+ # language containing only the empty string, aka
+ # epsilon.
+
+ set a $id ; incr id ; $fa state add $a
+ set b $id ; incr id ; $fa state add $b
+ $fa next $a "" --> $b
+
+ } elseif {[llength $regex] == 2} {
+ # Optimized path. Concatenation of one sub-expression
+ # is the sub-expression itself.
+
+ struct::list assign [Regex $fa [lindex $regex 1] id] a b
+ } else {
+ set first 1
+ set last {}
+ foreach sub [lrange $regex 1 end] {
+ struct::list assign [Regex $fa $sub id] s f
+ if {$first} {set first 0 ; set a $s}
+ if {$last != {}} {
+ $fa next $last "" --> $s
+ }
+ set last $f
+ }
+ set b $f
+ }
+ }
+ | {
+ # Alternatives ... (Union)
+
+ if {[llength $regex] == 1} {
+ # Optimized path. No sub-expressions. This represents
+ # the empty language, i.e. the language without words.
+
+ set a $id ; incr id ; $fa state add $a
+ set b $id ; incr id ; $fa state add $b
+
+ } elseif {[llength $regex] == 2} {
+ # Optimized path. Choice/Union of one sub-expression
+ # is the sub-expression itself.
+
+ struct::list assign [Regex $fa [lindex $regex 1] id] a b
+ } else {
+ set a $id ; incr id ; $fa state add $a
+ set b $id ; incr id ; $fa state add $b
+ foreach sub [lrange $regex 1 end] {
+ struct::list assign [Regex $fa $sub id] s f
+ $fa next $a "" --> $s
+ $fa next $f "" --> $b
+ }
+ }
+ }
+ S {
+ # Atom, base transition.
+ set sym [lindex $regex 1]
+ set a $id ; incr id ; $fa state add $a
+ set b $id ; incr id ; $fa state add $b
+ $fa next $a $sym --> $b
+ }
+ default {
+ return -code error "Expected . ! ? * | &, or S, got \"$cmd\""
+ }
+ }
+ return [list $a $b]
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::CrossPrepare {fa fb label} {
+ set starta [$fa startstates]
+ set finala [$fa finalstates]
+ set startb [$fb startstates]
+ set finalb [$fb finalstates]
+ if {
+ ![llength $starta] || ![llength $finala] ||
+ ![llength $startb] || ![llength $finalb]
+ } {
+ return -code error "Unable to perform the $label of two FAs without start/final states"
+ }
+
+ # The inputs are made complete over the union of their symbol
+ # sets. A temp. container is used for the second input if necessary.
+
+ set totals [struct::set union [$fa symbols] [$fb symbols]]
+ foreach sym [struct::set difference $totals [$fa symbols]] {
+ $fa symbol add $sym
+ }
+ if {![$fa is epsilon-free]} {
+ remove_eps $fa
+ trim $fa
+ }
+ if {![$fa is complete]} {
+ complete $fa
+ }
+ set tmp $fb
+ set bnew [struct::set difference $totals [$fb symbols]]
+ if {[llength $bnew]} {
+ set tmp [[cons] %AUTO% = $fb]
+ foreach sym $bnew {
+ $tmp symbol add $sym
+ }
+ }
+ if {![$fb is epsilon-free]} {
+ if {$tmp eq $fb} {set tmp [[cons] %AUTO% = $fb]}
+ remove_eps $tmp
+ trim $tmp
+ }
+ if {![$fb is complete]} {
+ if {$tmp eq $fb} {set tmp [[cons] %AUTO% = $fb]}
+ complete $tmp
+ }
+
+ set res [[cons] %AUTO%]
+ foreach sym $totals {
+ $res symbol add $sym
+ }
+
+ return [list $tmp $res]
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::DoCross {fa fb res id seed smapvar} {
+ upvar 1 $smapvar smap
+
+ set symbols [$fa symbols]
+ array set tmp $seed
+
+ set pending $seed
+ while {[llength $pending]} {
+ set cpair [struct::list shift pending]
+ set cid [struct::list shift pending]
+
+ struct::list assign $cpair a b
+
+ # ASSERT: /res state exists /cid
+
+ # Generate the transitions for the pair, add the resulting
+ # destinations to the FA, and schedule them for a visit if
+ # they are new.
+
+ foreach sym $symbols {
+ set adestinations [$fa next $a $sym]
+ set bdestinations [$fb next $b $sym]
+
+ foreach ad $adestinations {
+ foreach bd $bdestinations {
+ set dest [list $ad $bd]
+
+ if {![info exists tmp($dest)]} {
+ $res state add $id
+ lappend smap $id $dest
+ lappend pending $dest $id
+ set tmp($dest) $id
+ incr id
+ }
+ $res next $cid $sym --> $tmp($dest)
+ }
+ }
+ }
+ }
+ return
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::MergePrepare {fa fb label mapvar} {
+ upvar 1 $mapvar map
+
+ set starta [$fa startstates]
+ set finala [$fa finalstates]
+ set startb [$fb startstates]
+ set finalb [$fb finalstates]
+ if {
+ ![llength $starta] || ![llength $finala] ||
+ ![llength $startb] || ![llength $finalb]
+ } {
+ return -code error "Unable to $label FAs without start/final states"
+ }
+
+ # FUTURE: add {*}[symbols], ignore dup's
+ foreach sym [$fb symbols] {catch {$fa symbol add $sym}}
+
+ set dup [struct::set intersect [$fa states] [$fb states]]
+ if {![llength $dup]} {
+ # The states do not overlap. A plain merge of fb is enough to
+ # copy the information.
+
+ $fa deserialize_merge [$fb serialize]
+ set map {}
+ } else {
+ # We have duplicate states, therefore we have to remap fb to
+ # prevent interference between the two.
+
+ set map {}
+ set tmp [[cons] %AUTO% = $fb]
+ set id 0
+ foreach s $dup {
+ # The renaming process has to ensure that the new name is
+ # in neither fa, nor already in fb as well.
+ while {
+ [$fa state exists $id] ||
+ [$tmp state exists $id]
+ } {incr id}
+ $tmp state rename $s $id
+ lappend map $id $s
+ incr id
+ }
+
+ set startb [$tmp startstates]
+ set finalb [$tmp finalstates]
+
+ $fa deserialize_merge [$tmp serialize]
+ $tmp destroy
+ }
+
+ return [list $starta $finala $startb $finalb]
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::eLink1N {fa from states} {
+ foreach s $states {
+ $fa next $from "" --> $s
+ }
+ return
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::eLinkN1 {fa states to} {
+ foreach s $states {
+ $fa next $s "" --> $to
+ }
+ return
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::NewState {fa prefix} {
+ set newstate [FindNewState $fa $prefix]
+ $fa state add $newstate
+ return $newstate
+}
+
+# --- --- --- --------- --------- ---------
+
+proc ::grammar::fa::op::FindNewState {fa prefix} {
+ #if {![$fa state exists $prefix]} {return $prefix}
+ set n 0
+ while {[$fa state exists ${prefix}.$n]} {incr n}
+ return ${prefix}.$n
+}
+
+# ### ### ### ######### ######### #########
+## API implementation. Decompilation (FA -> regexp).
+
+proc ::grammar::fa::op::toRegexp {fa} {
+ # NOTE: FUTURE - Do not go through the serialization, nor through
+ # a matrix. The algorithm can be expressed more directly as
+ # operations on the automaton (states and transitions).
+
+ set ET [ser_to_ematrix [$fa serialize]]
+ while {[llength $ET] > 2} {
+ set ET [matrix_drop_state $ET]
+ }
+ return [lindex $ET 0 1]
+}
+
+proc ::grammar::fa::op::toRegexp2 {fa} {
+ # NOTE: FUTURE - See above.
+ set ET [ser_to_ematrix [$fa serialize]]
+ while {[llength $ET] > 2} {
+ set ET [matrix_drop_state $ET re2]
+ }
+ return [lindex $ET 0 1]
+}
+
+# ### ### ### ######### ######### #########
+## Internal helpers.
+
+proc ::grammar::fa::op::ser_to_ematrix {ser} {
+ if {[lindex $ser 0] ne "grammar::fa"} then {
+ error "Expected grammar::fa automaton serialisation"
+ }
+ set stateL {}
+ set n 2; foreach {state des} [lindex $ser 2] {
+ lappend stateL $state
+ set N($state) $n
+ incr n
+ }
+ set row0 {}
+ for {set k 0} {$k<$n} {incr k} {lappend row0 [list |]}
+ set res [list $row0 $row0]
+ foreach {from des} [lindex $ser 2] {
+ set row [lrange $row0 0 1]
+ if {[lindex $des 0]} then {lset res 0 $N($from) [list .]}
+ if {[lindex $des 1]} then {lset row 1 [list .]}
+ foreach to $stateL {set S($to) [list |]}
+ foreach {symbol targetL} [lindex $des 2] {
+ if {$symbol eq ""} then {
+ set atom [list .]
+ } else {
+ set atom [list S $symbol]
+ }
+ foreach to $targetL {lappend S($to) $atom}
+ }
+ foreach to $stateL {
+ if {[llength $S($to)] == 2} then {
+ lappend row [lindex $S($to) 1]
+ } else {
+ lappend row $S($to)
+ }
+ }
+ lappend res $row
+ }
+ return $res
+}
+
+proc ::grammar::fa::op::matrix_drop_state {T_in {ns re1}} {
+ set sumcmd ${ns}::|
+ set prodcmd ${ns}::.
+ set T1 {}
+ set lastcol {}
+ foreach row $T_in {
+ lappend T1 [lreplace $row end end]
+ lappend lastcol [lindex $row end]
+ }
+ set lastrow [lindex $T1 end]
+ set T1 [lreplace $T1 end end]
+ set b [${ns}::* [lindex $lastcol end]]
+ set lastcol [lreplace $lastcol end end]
+ set res {}
+ foreach row $T1 a $lastcol {
+ set newrow {}
+ foreach pos $row c $lastrow {
+ lappend newrow [$sumcmd $pos [$prodcmd $a $b $c]]
+ }
+ lappend res $newrow
+ }
+ return $res
+}
+
+# ### ### ### ######### ######### #########
+## Internal helpers. Regexp simplification I.
+
+namespace eval ::grammar::fa::op::re1 {
+ namespace export | . {\*}
+}
+
+proc ::grammar::fa::op::re1::| {args} {
+ set L {}
+
+ # | = Choices.
+ # Sub-choices are lifted into the top expression (foreach).
+ # Identical choices are reduced to a single term (lsort -uniq).
+
+ foreach re $args {
+ switch -- [lindex $re 0] "|" {
+ foreach term [lrange $re 1 end] {lappend L $term}
+ } default {
+ lappend L $re
+ }
+ }
+ set L [lsort -unique $L]
+ if {[llength $L] == 1} then {
+ return [lindex $L 0]
+ } else {
+ return [linsert $L 0 |]
+ }
+}
+
+proc ::grammar::fa::op::re1::. {args} {
+ set L {}
+
+ # . = Sequence.
+ # One element sub-choices are lifted into the top expression.
+ # Sub-sequences are lifted into the top expression.
+
+ foreach re $args {
+ switch -- [lindex $re 0] "." {
+ foreach term [lrange $re 1 end] {lappend L $term}
+ } "|" {
+ if {[llength $re] == 1} then {return $re}
+ lappend L $re
+ } default {
+ lappend L $re
+ }
+ }
+ if {[llength $L] == 1} then {
+ return [lindex $L 0]
+ } else {
+ return [linsert $L 0 .]
+ }
+}
+
+proc ::grammar::fa::op::re1::* {re} {
+ # * = Kleene closure.
+ # Sub-closures are lifted into the top expression.
+ # One-element sub-(choices,sequences) are lifted into the top expression.
+
+ switch -- [lindex $re 0] "|" - "." {
+ if {[llength $re] == 1} then {
+ return [list .]
+ } else {
+ return [list * $re]
+ }
+ } "*" {
+ return $re
+ } default {
+ return [list * $re]
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Internal helpers. Regexp simplification II.
+
+namespace eval ::grammar::fa::op::re2 {
+ # Inherit choices and kleene-closure from the basic simplifier.
+
+ namespace import [namespace parent]::re1::|
+ namespace import [namespace parent]::re1::\\*
+}
+
+proc ::grammar::fa::op::re2::. {args} {
+
+ # . = Sequences
+ # Sub-sequences are lifted into the top expression.
+ # Sub-choices are multiplied out.
+ # <Example a(b|c) => ab|ac >
+
+ set L {}
+ set n -1
+ foreach re $args {
+ incr n
+ switch -- [lindex $re 0] "." {
+ foreach term [lrange $re 1 end] {lappend L $term}
+ } "|" {
+ set res [list |]
+ set L2 [lreplace $args 0 $n]
+ foreach term [lrange $re 1 end] {
+ lappend res [eval [list .] $L [list $term] $L2]
+ }
+ return [eval $res]
+ } default {
+ lappend L $re
+ }
+ }
+ if {[llength $L] == 1} then {
+ return [lindex $L 0]
+ } else {
+ return [linsert $L 0 .]
+ }
+}
+
+# ### ### ### ######### ######### #########
+## API. Simplification of regular expressions.
+
+proc ::grammar::fa::op::simplifyRegexp {RE0} {
+ set RE1 [namespace inscope nonnull $RE0]
+ if {[lindex $RE1 0] eq "S" || $RE1 eq "." || $RE1 eq "|"} then {
+ return $RE1
+ }
+ set tmp [grammar::fa %AUTO% fromRegex $RE1]
+ $tmp minimize
+ set RE1 [toRegexp $tmp]
+ $tmp destroy
+ if {[string length $RE1] < [string length $RE0]} then {
+ set RE0 $RE1
+ }
+ if {[lindex $RE0 0] eq "S"} then {return $RE0}
+ set res [lrange $RE0 0 0]
+ foreach branch [lrange $RE0 1 end] {
+ lappend res [simplifyRegexp $branch]
+ }
+ return $res
+}
+
+# ### ### ### ######### ######### #########
+## Internal helpers.
+
+namespace eval ::grammar::fa::op::nonnull {}
+
+proc ::grammar::fa::op::nonnull::| {args} {
+ set also_empty false
+ set res [list |]
+ foreach branch $args {
+ set RE [eval $branch]
+ if {[lindex $RE 0] eq "?"} then {
+ set also_empty true
+ set RE [lindex $RE 1]
+ }
+ switch -- [lindex $RE 0] "|" {
+ eval [lreplace $RE 0 0 lappend res]
+ } "." {
+ if {[llength $RE] == 1} then {
+ set also_empty true
+ } else {
+ lappend res $RE
+ }
+ } default {
+ lappend res $RE
+ }
+ }
+ if {!$also_empty} then {return $res}
+ foreach branch [lrange $res 1 end] {
+ if {[lindex $branch 0] eq "*"} then {return $res}
+ }
+ if {[llength $res] == 1} then {
+ return [list .]
+ } elseif {[llength $res] == 2} then {
+ return [lreplace $res 0 0 ?]
+ } else {
+ return [list ? $res]
+ }
+}
+
+proc ::grammar::fa::op::nonnull::. {args} {
+ set res [list .]
+ foreach branch $args {
+ set RE [eval $branch]
+ switch -- [lindex $RE 0] "|" {
+ if {[llength $RE] == 1} then {return $RE}
+ lappend res $RE
+ } "." {
+ eval [lreplace $RE 0 0 lappend res]
+ } default {
+ lappend res $RE
+ }
+ }
+ return $res
+}
+
+proc ::grammar::fa::op::nonnull::* {sub} {
+ set RE [eval $sub]
+ switch -- [lindex $RE 0] "*" - "?" - "+" {
+ return [lreplace $RE 0 0 *]
+ } default {
+ return [list * $RE]
+ }
+}
+
+proc ::grammar::fa::op::nonnull::+ {sub} {
+ set RE [eval $sub]
+ switch -- [lindex $RE 0] "+" {
+ return $RE
+ } "*" - "?" {
+ return [lreplace $RE 0 0 *]
+ } default {
+ return [list * $RE]
+ }
+}
+
+proc ::grammar::fa::op::nonnull::? {sub} {
+ set RE [eval $sub]
+ switch -- [lindex $RE 0] "?" - "*" {
+ return $RE
+ } "+" {
+ return [lreplace $RE 0 0 *]
+ } default {
+ return [list ? $RE]
+ }
+}
+
+proc ::grammar::fa::op::nonnull::S {name} {
+ return [list S $name]
+}
+
+# ### ### ### ######### ######### #########
+## API. Translate RE of this package to Tcl REs
+
+proc ::grammar::fa::op::toTclRegexp {re symdict} {
+ return [lindex [namespace inscope tclre $re $symdict] 1]
+}
+
+# ### ### ### ######### ######### #########
+## Internal helpers.
+
+namespace eval ::grammar::fa::op::tclre {}
+
+proc ::grammar::fa::op::tclre::S {name dict} {
+ array set A $dict
+ if {[info exists A($name)]} then {
+ return $A($name)
+ } elseif {[string length $name] == 1} then {
+ if {[regexp {[\\\[\]{}.()*+?^$]} $name]} then {
+ return [list char \\$name]
+ } else {
+ return [list char $name]
+ }
+ } else {
+ return [list class "\[\[:${name}:\]\]"]
+ }
+}
+
+proc ::grammar::fa::op::tclre::. {args} {
+ set suffix [lrange $args end end]
+ set L {}
+ foreach factor [lrange $args 0 end-1] {
+ set pair [eval $factor $suffix]
+ switch -- [lindex $pair 0] "sum" {
+ lappend L ([lindex $pair 1])
+ } default {
+ lappend L [lindex $pair 1]
+ }
+ }
+ return [list prod [join $L ""]]
+}
+
+proc ::grammar::fa::op::tclre::* {re dict} {
+ set pair [eval $re [list $dict]]
+ switch -- [lindex $pair 0] "sum" - "prod" {
+ return [list prod "([lindex $pair 1])*"]
+ } default {
+ return [list prod "[lindex $pair 1]*"]
+ }
+}
+
+proc ::grammar::fa::op::tclre::+ {re dict} {
+ set pair [eval $re [list $dict]]
+ switch -- [lindex $pair 0] "sum" - "prod" {
+ return [list prod "([lindex $pair 1])+"]
+ } default {
+ return [list prod "[lindex $pair 1]+"]
+ }
+}
+
+proc ::grammar::fa::op::tclre::? {re dict} {
+ set pair [eval $re [list $dict]]
+ switch -- [lindex $pair 0] "sum" - "prod" {
+ return [list prod "([lindex $pair 1])?"]
+ } default {
+ return [list prod "[lindex $pair 1]?"]
+ }
+}
+
+proc ::grammar::fa::op::tclre::| {args} {
+ set suffix [lrange $args end end]
+ set charL {}
+ set classL {}
+ set prodL {}
+ foreach factor [lrange $args 0 end-1] {
+ set pair [eval $factor $suffix]
+ switch -- [lindex $pair 0] "char" {
+ lappend charL [lindex $pair 1]
+ } "class" {
+ lappend classL [string range [lindex $pair 1] 1 end-1]
+ } default {
+ lappend prodL [lindex $pair 1]
+ }
+ }
+ if {[llength $charL]>1 || [llength $classL]>0} then {
+ while {[set n [lsearch $charL -]] >= 0} {
+ lset charL $n {\-}
+ }
+ set bracket "\[[join $charL ""][join $classL ""]\]"
+ if {![llength $prodL]} then {
+ return [list atom $bracket]
+ }
+ lappend prodL $bracket
+ } else {
+ eval [list lappend prodL] $charL
+ }
+ return [list sum [join $prodL |]]
+}
+
+proc ::grammar::fa::op::tclre::& {args} {
+ error "Cannot express language intersection in Tcl-RE's"
+
+ # Note: This can be translated by constructing an automaton for
+ # the intersection, and then translating its conversion to a
+ # regular expression.
+}
+
+proc ::grammar::fa::op::tclre::! {args} {
+ error "Cannot express language complementation in Tcl-RE's"
+
+ # Note: This can be translated by constructing an automaton for
+ # the complement, and then translating its conversion to a regular
+ # expression. This however requires knowledge regarding the set of
+ # symbols. Large (utf-8) for Tcl regexes.
+}
+
+# ### ### ### ######### ######### #########
+
+proc ::grammar::fa::op::constructor {cmd} {
+ variable cons $cmd
+ return
+}
+
+proc ::grammar::fa::op::cons {} {
+ variable cons
+ if {$cons ne ""} {return $cons}
+ return -code error "No constructor for FA container was established."
+}
+
+# ### ### ### ######### ######### #########
+## Package Management
+
+package provide grammar::fa::op 0.4.1
diff --git a/tcllib/modules/grammar_fa/faop.test b/tcllib/modules/grammar_fa/faop.test
new file mode 100644
index 0000000..8357734
--- /dev/null
+++ b/tcllib/modules/grammar_fa/faop.test
@@ -0,0 +1,45 @@
+# -*- tcl -*-
+# faop.test: tests for complex operations on the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: faop.test,v 1.11 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 1.0
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use snit/snit.tcl snit ; # 1.1 always, even when Tcl 8.5 runs the testsuite.
+ use struct/list.tcl struct::list
+
+ useLocalFile tests/Xsupport
+}
+testing {
+ useLocal faop.tcl grammar::fa::op
+}
+support {
+ useLocalKeep fa.tcl grammar::fa
+}
+
+# -------------------------------------------------------------------------
+
+set class ::grammar::fa::op
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::set setimpl {
+ TestFiles tests/faop_*.test
+}
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
diff --git a/tcllib/modules/grammar_fa/pkgIndex.tcl b/tcllib/modules/grammar_fa/pkgIndex.tcl
new file mode 100644
index 0000000..155fe7c
--- /dev/null
+++ b/tcllib/modules/grammar_fa/pkgIndex.tcl
@@ -0,0 +1,6 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+
+package ifneeded grammar::fa 0.5 [list source [file join $dir fa.tcl]]
+package ifneeded grammar::fa::op 0.4.1 [list source [file join $dir faop.tcl]]
+package ifneeded grammar::fa::dacceptor 0.1.1 [list source [file join $dir dacceptor.tcl]]
+package ifneeded grammar::fa::dexec 0.2 [list source [file join $dir dexec.tcl]]
diff --git a/tcllib/modules/grammar_fa/tests/Xsupport b/tcllib/modules/grammar_fa/tests/Xsupport
new file mode 100644
index 0000000..73c2d56
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/Xsupport
@@ -0,0 +1,371 @@
+# -*- tcl -*-
+# -------------------------------------------------------------------------
+# Helper for tests: Validation of serializations.
+
+proc validate_serial {value fa} {
+ # value is list/3 ('grammar::fa' symbols states)
+ # !("" in symbols)
+ # states is ordered dict (key is state, value is statedata)
+ # statedata is list/3 (start final trans|"")
+ # start is boolean
+ # final is boolean
+ # trans is dict (key in symbols, value is list (state))
+
+ # Output for debug ...
+ ##puts "$fa => ($value)"
+
+ # symbols set-equal symbols(fa)
+ # states set-equal states(fa)
+ # finalstates set-equal finalstates(fa)
+ # startstates set-equal startstates(fa)
+
+ set prefix "error in serialization:"
+ if {[llength $value] != 3} {
+ return "$prefix list length not 3"
+ }
+
+ struct::list assign $value type symbols statedata
+
+ if {$type ne "grammar::fa"} {
+ return "$prefix unknown type \"$type\""
+ }
+ if {[struct::set contains $symbols ""]} {
+ return "$prefix empty symbol is not legal"
+ }
+ if {![struct::set equal $symbols [$fa symbols]]} {
+ return "$prefix set of symbols does not match"
+ }
+ if {[llength $statedata] % 2 == 1} {
+ return "$prefix state data is not a dictionary"
+ }
+ array set _states $statedata
+ if {[llength $statedata] != (2*[array size _states])} {
+ return "$prefix state data contains duplicate states"
+ }
+ if {![struct::set equal [array names _states] [$fa states]]} {
+ return "$prefix set of states does not match"
+ }
+ foreach {k v} $statedata {
+ if {[llength $v] != 3} {
+ return "$prefix state list length not 3"
+ }
+ struct::list assign $v start final trans
+ if {![string is boolean -strict $start]} {
+ return "$prefix expected boolean for start, got \"$start\", for state \"$k\""
+ }
+ if {($start && ![$fa start? $k]) || (!$start && [$fa start? $k])} {
+ return "$prefix start does not match for state \"$k\""
+ }
+ if {![string is boolean -strict $final]} {
+ return "$prefix expected boolean for final, got \"$final\", for state \"$k\""
+ }
+ if {($final && ![$fa final? $k]) || (!$final && [$fa final? $k])} {
+ return "$prefix final does not match for state \"$k\""
+ }
+ if {[llength $trans] % 2 == 1} {
+ return "$prefix transition data is not a dictionary for state \"$k\""
+ }
+ array set _trans $trans
+ if {[llength $trans] != (2*[array size _trans])} {
+ return "$prefix transition data contains duplicate symbols for state \"$k\""
+ }
+ # trans keys set-equal to trans/symbols(fa,k)
+ if {![struct::set equal [$fa symbols@ $k] [array names _trans]]} {
+ return "$prefix transition symbols do not match for state \"$k\""
+ }
+ unset _trans
+
+ foreach {sym destinations} $trans {
+ if {($sym ne "") && ![struct::set contains $symbols $sym]} {
+ return "$prefix illegal symbol \"$sym\" in transition for state \"$k\""
+ }
+ foreach dest $destinations {
+ if {![info exists _states($dest)]} {
+ return "$prefix illegal destination state \"$dest\" for state \"$k\""
+ }
+ }
+ if {![struct::set equal $destinations [$fa next $k $sym]]} {
+ return "$prefix destination set does not match for state \"$k\""
+ }
+ }
+ }
+ return ok
+}
+
+# -------------------------------------------------------------------------
+# Helper for tests: Serialization of empty FA.
+
+set fa_empty {grammar::fa {} {}}
+
+# -------------------------------------------------------------------------
+# Helper for tests: Predefined graphs for use in tests.
+# (Properties and such). Number of graphs: 30.
+
+array set fa_pre {}
+
+proc gen {code} {
+ global fa_pre
+ uplevel #0 $fa_pre($code)
+ return
+}
+proc def {code script} {
+ global fa_pre
+ set fa_pre($code) $script
+ return
+}
+
+
+def x {
+ a state add x
+}
+def x- {
+ a state add x
+ a symbol add @
+ a next x @ --> x
+}
+def xe {
+ a state add x
+ a next x "" --> x
+}
+def xy {
+ a state add x y
+}
+def xy- {
+ a state add x y
+ a symbol add @
+ a next x @ --> y
+}
+def xye {
+ a state add x y
+ a next x "" --> y
+}
+def xyee {
+ a state add x y
+ a next x "" --> y
+ a next y "" --> x
+}
+def xye- {
+ a state add x y
+ a symbol add @
+ a next x "" --> y
+ a next y @ --> x
+}
+def xy-- {
+ a state add x y
+ a symbol add @
+ a next x @ --> y
+ a next y @ --> x
+}
+def xy-= {
+ a state add x y
+ a symbol add @ =
+ a next x @ --> y
+ a next y = --> x
+}
+def xyz/ee {
+ a state add x y z
+ a next x "" --> y
+ a next x "" --> z
+}
+def xyz/e- {
+ a state add x y z
+ a symbol add @
+ a next x @ --> y
+ a next x "" --> z
+}
+def xyz/-- {
+ a state add x y z
+ a symbol add @
+ a next x @ --> y
+ a next x @ --> z
+}
+def xyz/-= {
+ a state add x y z
+ a symbol add @ =
+ a next x @ --> y
+ a next x = --> z
+}
+def xyz|ee {
+ a state add x y z
+ a next x "" --> z
+ a next y "" --> z
+}
+def xyz|e- {
+ a state add x y z
+ a symbol add @
+ a next x @ --> z
+ a next y "" --> z
+}
+def xyz|-- {
+ a state add x y z
+ a symbol add @
+ a next x @ --> z
+ a next y @ --> z
+}
+def xyz|-= {
+ a state add x y z
+ a symbol add @ =
+ a next x @ --> z
+ a next y = --> z
+}
+def xyz+eee {
+ a state add x y z
+ a next x "" --> y
+ a next y "" --> z
+ a next z "" --> x
+}
+def xyz+ee- {
+ a state add x y z
+ a symbol add @
+ a next x "" --> y
+ a next y "" --> z
+ a next z @ --> x
+}
+def xyz+e-- {
+ a state add x y z
+ a symbol add @
+ a next x "" --> y
+ a next y @ --> z
+ a next z @ --> x
+}
+def xyz+e-= {
+ a state add x y z
+ a symbol add @ =
+ a next x "" --> y
+ a next y @ --> z
+ a next z = --> x
+}
+def xyz+--- {
+ a state add x y z
+ a symbol add @
+ a next x @ --> y
+ a next y @ --> z
+ a next z @ --> x
+}
+def xyz+--= {
+ a state add x y z
+ a symbol add @ =
+ a next x @ --> y
+ a next y @ --> z
+ a next z = --> x
+}
+def xyz+-=_ {
+ a state add x y z
+ a symbol add @ = %
+ a next x @ --> y
+ a next y = --> z
+ a next z % --> x
+}
+def xyz&eee {
+ a state add x y z
+ a next x "" --> y
+ a next x "" --> z
+ a next y "" --> z
+}
+def xyz&ee- {
+ a state add x y z
+ a symbol add @
+ a next x "" --> y
+ a next x "" --> z
+ a next y @ --> z
+}
+def xyz&e-- {
+ a state add x y z
+ a symbol add @
+ a next x "" --> y
+ a next x @ --> z
+ a next y @ --> z
+}
+def xyz&e-= {
+ a state add x y z
+ a symbol add @ =
+ a next x "" --> y
+ a next x @ --> z
+ a next y = --> z
+}
+def xyz&--- {
+ a state add x y z
+ a symbol add @
+ a next x @ --> y
+ a next x @ --> z
+ a next y @ --> z
+}
+def xyz&--= {
+ a state add x y z
+ a symbol add @ =
+ a next x @ --> y
+ a next x @ --> z
+ a next y = --> z
+}
+def xyz&-=_ {
+ a state add x y z
+ a symbol add @ = %
+ a next x @ --> y
+ a next x = --> z
+ a next y % --> z
+}
+def xyz!ee {
+ a state add x y z
+ a next x "" --> y
+ a next y "" --> z
+}
+def xyz!e- {
+ a state add x y z
+ a symbol add @
+ a next x "" --> y
+ a next y @ --> z
+}
+def xyz!-- {
+ a state add x y z
+ a symbol add @
+ a next x @ --> y
+ a next y @ --> z
+}
+def xyz!-= {
+ a state add x y z
+ a symbol add @ = %
+ a next x @ --> y
+ a next y = --> z
+}
+def xyz!-e {
+ a state add x y z
+ a symbol add @
+ a next x @ --> y
+ a next y "" --> z
+}
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+def datom {
+ a state add x y
+ a symbol add @
+ a next x @ --> y
+}
+def dalt {
+ a state add u v w x y z
+ a symbol add @ =
+ a next u "" --> v ; a next v @ --> x ; a next x "" --> z
+ a next u "" --> w ; a next w = --> y ; a next y "" --> z
+}
+def daltb {
+ a state add u v w x y z
+ a symbol add @ =
+ a next u "" --> v ; a next v @ --> x ; a next x "" --> z
+ a next u "" --> w ; a next w = --> y ; a next y "" --> z
+ a next z "" --> u
+}
+def dopt {
+ a state add u v w x
+ a symbol add @
+ a next u "" --> v ; a next v @ --> w ; a next w "" --> x
+ a next u "" --> x
+}
+def drep {
+ a state add u v w x
+ a symbol add @
+ a next u "" --> v ; a next v @ --> w ; a next w "" --> x
+ a next u "" --> x
+ a next x "" --> u
+}
+
+# -------------------------------------------------------------------------
diff --git a/tcllib/modules/grammar_fa/tests/da_accept.test b/tcllib/modules/grammar_fa/tests/da_accept.test
new file mode 100644
index 0000000..3ea7cc1
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/da_accept.test
@@ -0,0 +1,84 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa::dacceptor engine
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: da_accept.test,v 1.5 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+# Regular expression for C comments (Extended notation, using the 'not' operator).
+#
+# '/' . '*' . (! (ALL* . '*' . '/' . ALL*)) . '*' . '/'
+# ALL = '/' | '*' | 'any'
+#
+# Generated minimal DFA
+#
+# any/ *
+# | |
+# 0 -/-> 1 -*-> 2 -*-> 3 -/-> 4
+# \<-any-/
+
+#puts -nonewline " RE compile, " ; flush stdout
+
+grammar::fa ccomments fromRegex {. {S /}
+ {S *}
+ {! {. {* {| {S *} {S /} {S any}}}
+ {S *}
+ {S /}
+ {* {| {S *} {S /} {S any}}}}}
+ {S *}
+ {S /}
+ } {/ * any}
+
+#puts -nonewline {FA, } ; flush stdout
+
+ccomments determinize ; #puts -nonewline {deterministic, } ; flush stdout
+ccomments minimize ; #puts minimal ; flush stdout
+
+
+# -------------------------------------------------------------------------
+
+test da-accept-${setimpl}-1.0 {accept? error} {
+ grammar::fa::dacceptor da ccomments
+ catch {da accept?} msg
+ da destroy
+ set msg
+} {wrong # args: should be "::grammar::fa::dacceptor::Snit_methodaccept? type selfns win self symbolstring"}
+
+
+test da-accept-${setimpl}-1.1 {accept? error} {
+ grammar::fa::dacceptor da ccomments
+ catch {da accept? x y} msg
+ da destroy
+ set msg
+} {wrong # args: should be "::grammar::fa::dacceptor::Snit_methodaccept? type selfns win self symbolstring"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+foreach {n acceptany accept string} {
+ 0 0 0 {x y}
+ 1 1 1 {/ * * /}
+ 2 1 0 {/ * x * /}
+ 3 0 0 {/ * * / * /}
+ 4 0 0 {/ * x * / x * /}
+ 5 0 0 {/ * * * / * * /}
+} {
+ test da-accept-${setimpl}-2.$n {accept?, -any any} {
+ grammar::fa::dacceptor da ccomments -any any
+ set res [da accept? $string]
+ da destroy
+ set res
+ } $acceptany ; # {}
+
+ test da-accept-${setimpl}-3.$n {accept?} {
+ grammar::fa::dacceptor da ccomments
+ set res [da accept? $string]
+ da destroy
+ set res
+ } $accept ; # {}
+}
+
+# -------------------------------------------------------------------------
+ccomments destroy
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/da_cons.test b/tcllib/modules/grammar_fa/tests/da_cons.test
new file mode 100644
index 0000000..42cdb6a
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/da_cons.test
@@ -0,0 +1,140 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa::dacceptor engine
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: da_cons.test,v 1.8 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+if {![::tcltest::testConstraint runtotal]} {
+ ::tcltest::cleanupTests
+ return
+}
+
+# -------------------------------------------------------------------------
+
+test da-cons-${setimpl}-1.0 {construction error} {
+ catch {grammar::fa::dacceptor a} msg
+ set msg
+} {Error in constructor: wrong # args: should be "::grammar::fa::dacceptor::Snit_constructor type selfns win self fa args"}
+
+
+test da-cons-${setimpl}-1.1 {construction error} {
+ catch {grammar::fa::dacceptor a foo fie far} msg
+ set msg
+} {Error in constructor: unknown option "fie"}
+
+
+test da-cons-${setimpl}-1.2 {construction error} {
+ catch {grammar::fa::dacceptor a b} msg
+ set msg
+} {Error in constructor: invalid command name "b"}
+
+foreach {n code setup_result} {
+ 00 x {{} 0 x 1}
+ 01 x- {{} 0 x 1}
+ 02 xe {{} 0 x 0}
+ 03 xy {{} 0 x 1 y 1 {x y} 0}
+ 04 xy- {{} 0 x 1 y 1 {x y} 0}
+ 05 xye {{} 0 x 0 y 0 {x y} 0}
+ 06 xyee {{} 0 x 0 y 0 {x y} 0}
+ 07 xye- {{} 0 x 0 y 0 {x y} 0}
+ 08 xy-- {{} 0 x 1 y 1 {x y} 0}
+ 09 xy-= {{} 0 x 1 y 1 {x y} 0}
+ 10 xyz/ee {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 11 xyz/e- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 12 xyz/-- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 13 xyz/-= {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 14 xyz|ee {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 15 xyz|e- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 16 xyz|-- {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 17 xyz|-= {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 18 xyz+eee {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 19 xyz+ee- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 20 xyz+e-- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 21 xyz+e-= {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 22 xyz+--- {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 23 xyz+--= {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 24 xyz+-=_ {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 25 xyz&eee {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 26 xyz&ee- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 27 xyz&e-- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 28 xyz&e-= {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 29 xyz&--- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 30 xyz&--= {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 31 xyz&-=_ {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 32 xyz!ee {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 33 xyz!e- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 34 xyz!-- {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 35 xyz!-= {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 36 xyz!-e {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+} {
+ foreach {stset expected} $setup_result {
+ foreach {fset __} $setup_result {
+ set key ${n}.${code}.([join $stset {}]).([join $fset {}])
+
+ test da-cons-${setimpl}-1.3.$key {construction error} {
+ grammar::fa a
+ gen $code
+ a start set $stset
+ a final set $fset
+ set nfa [expr {![a is deterministic]}]
+ set fail [catch {grammar::fa::dacceptor da a} msg]
+ a destroy
+ catch {da destroy}
+
+ expr {($nfa && $fail) || (!$nfa && !$fail)}
+ } 1
+ }
+ }
+}
+
+test da-cons-${setimpl}-1.4 {construction error} {
+ grammar::fa a
+ gen xyz+-=_
+ a start add x
+ catch {grammar::fa::dacceptor da a -any *} msg
+ a destroy
+ set msg
+} {Error in constructor: Chosen any symbol "*" does not exist}
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test da-cons-${setimpl}-2.0 {construction} {
+ grammar::fa a
+ gen xyz+-=_
+ a start add x
+ grammar::fa::dacceptor da a
+ a destroy
+ da destroy
+} {}
+
+
+test da-cons-${setimpl}-2.1 {construction} {
+ set res {}
+ grammar::fa a
+ gen xyz+-=_
+ a start add x
+ lappend res [info commands ::da]
+ grammar::fa::dacceptor da a
+ a destroy
+ lappend res [info commands ::da]
+ da destroy
+ lappend res [info commands ::da]
+ set res
+} {{} ::da {}}
+
+
+test da-cons-${setimpl}-2.2 {construction} {
+ grammar::fa a
+ gen xyz+-=_
+ a start add x
+ grammar::fa::dacceptor da a -any @
+ a destroy
+ da destroy
+} {}
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/de_cons.test b/tcllib/modules/grammar_fa/tests/de_cons.test
new file mode 100644
index 0000000..5ff8407
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/de_cons.test
@@ -0,0 +1,157 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa::dexec engine
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: de_cons.test,v 1.8 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+if {![::tcltest::testConstraint runtotal]} {
+ ::tcltest::cleanupTests
+ return
+}
+
+# -------------------------------------------------------------------------
+
+global events
+
+# -------------------------------------------------------------------------
+
+test de-cons-${setimpl}-1.0 {construction error} {
+ catch {grammar::fa::dexec a} msg
+ set msg
+} {Error in constructor: wrong # args: should be "::grammar::fa::dexec::Snit_constructor type selfns win self fa args"}
+
+
+test de-cons-${setimpl}-1.1 {construction error} {
+ catch {grammar::fa::dexec a foo fie far} msg
+ set msg
+} {Error in constructor: unknown option "fie"}
+
+
+test de-cons-${setimpl}-1.2 {construction error} {
+ catch {grammar::fa::dexec a b} msg
+ set msg
+} {Error in constructor: invalid command name "b"}
+
+foreach {n code setup_result} {
+ 00 x {{} 0 x 1}
+ 01 x- {{} 0 x 1}
+ 02 xe {{} 0 x 0}
+ 03 xy {{} 0 x 1 y 1 {x y} 0}
+ 04 xy- {{} 0 x 1 y 1 {x y} 0}
+ 05 xye {{} 0 x 0 y 0 {x y} 0}
+ 06 xyee {{} 0 x 0 y 0 {x y} 0}
+ 07 xye- {{} 0 x 0 y 0 {x y} 0}
+ 08 xy-- {{} 0 x 1 y 1 {x y} 0}
+ 09 xy-= {{} 0 x 1 y 1 {x y} 0}
+ 10 xyz/ee {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 11 xyz/e- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 12 xyz/-- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 13 xyz/-= {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 14 xyz|ee {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 15 xyz|e- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 16 xyz|-- {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 17 xyz|-= {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 18 xyz+eee {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 19 xyz+ee- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 20 xyz+e-- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 21 xyz+e-= {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 22 xyz+--- {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 23 xyz+--= {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 24 xyz+-=_ {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 25 xyz&eee {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 26 xyz&ee- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 27 xyz&e-- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 28 xyz&e-= {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 29 xyz&--- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 30 xyz&--= {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 31 xyz&-=_ {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 32 xyz!ee {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 33 xyz!e- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 34 xyz!-- {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 35 xyz!-= {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 36 xyz!-e {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+} {
+ foreach {stset expected} $setup_result {
+ foreach {fset __} $setup_result {
+ set key ${n}.${code}.([join $stset {}]).([join $fset {}])
+
+ test de-cons-${setimpl}-1.3.$key {construction error} {
+ grammar::fa a
+ gen $code
+ a start set $stset
+ a final set $fset
+ set nfa [expr {![a is deterministic]}]
+ set fail [catch {grammar::fa::dexec de a -command {lappend events}} msg]
+ a destroy
+ catch {de destroy}
+
+ set res [expr {($nfa && $fail) || (!$nfa && !$fail)}]
+ if {!$res} {set res $msg}
+ set res
+ } 1
+ }
+ }
+}
+
+test de-cons-${setimpl}-1.4 {construction error} {
+ grammar::fa a
+ gen xyz+-=_
+ a start add x
+ catch {grammar::fa::dexec de a -any *} msg
+ a destroy
+ set msg
+} {Error in constructor: Chosen any symbol "*" does not exist}
+
+test de-cons-${setimpl}-1.5 {construction error} {
+ grammar::fa a
+ gen xyz+-=_
+ a start add x
+ catch {grammar::fa::dexec de a -any @} msg
+ a destroy
+ set msg
+} {Error in constructor: Command callback missing}
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test de-cons-${setimpl}-2.0 {construction} {
+ grammar::fa a
+ gen xyz+-=_
+ a start add x
+ grammar::fa::dexec de a -command {lappend events}
+ a destroy
+ de destroy
+} {}
+
+
+test de-cons-${setimpl}-2.1 {construction} {
+ set res {}
+ grammar::fa a
+ gen xyz+-=_
+ a start add x
+ lappend res [info commands ::de]
+ grammar::fa::dexec de a -command {lappend events}
+ a destroy
+ lappend res [info commands ::de]
+ de destroy
+ lappend res [info commands ::de]
+ set res
+} {{} ::de {}}
+
+
+test de-cons-${setimpl}-2.2 {construction} {
+ grammar::fa a
+ gen xyz+-=_
+ a start add x
+ grammar::fa::dexec de a -any @ -command {lappend events}
+ a destroy
+ de destroy
+} {}
+
+
+# -------------------------------------------------------------------------
+unset events
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/de_exec.test b/tcllib/modules/grammar_fa/tests/de_exec.test
new file mode 100644
index 0000000..ab0cce9
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/de_exec.test
@@ -0,0 +1,104 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa::dexec engine
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: de_exec.test,v 1.6 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+# Regular expression for C comments (Extended notation, using the 'not' operator).
+#
+# '/' . '*' . (! (ALL* . '*' . '/' . ALL*)) . '*' . '/'
+# ALL = '/' | '*' | 'any'
+#
+# Generated minimal DFA
+#
+# any/ *
+# | |
+# 0 -/-> 1 -*-> 2 -*-> 3 -/-> 4
+# \<-any-/
+
+#puts -nonewline " RE compile, " ; flush stdout
+
+grammar::fa ccomments fromRegex {. {S /}
+ {S *}
+ {! {. {* {| {S *} {S /} {S any}}}
+ {S *}
+ {S /}
+ {* {| {S *} {S /} {S any}}}}}
+ {S *}
+ {S /}
+ } {/ * any}
+
+#puts -nonewline {FA, } ; flush stdout
+
+ccomments determinize ; #puts -nonewline {deterministic, } ; flush stdout
+ccomments minimize ; #puts minimal ; flush stdout
+
+# -------------------------------------------------------------------------
+
+global events
+
+# -------------------------------------------------------------------------
+
+test de-reset-${setimpl}-1.0 {reset error} {
+ grammar::fa::dexec de ccomments -command {lappend events}
+ catch {de reset x} msg
+ de destroy
+ set msg
+} {wrong # args: should be "::grammar::fa::dexec::Snit_methodreset type selfns win self"}
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+foreach {n string acceptany accept} {
+ 0 {x y}
+ {reset . error BADTRANS {Bad transition ("0" "any"), no destination} .}
+ {reset . error BADSYM {Bad symbol "x"} .}
+
+ 1 {/ * * /}
+ {reset . state 1 . state 2 . state 3 . state 4 final 4}
+ {reset . state 1 . state 2 . state 3 . state 4 final 4}
+
+ 2 {/ * x * /}
+ {reset . state 1 . state 2 . state 2 . state 3 . state 4 final 4}
+ {reset . state 1 . state 2 . error BADSYM {Bad symbol "x"} . .}
+
+ 3 {/ * * / * /}
+ {reset . state 1 . state 2 . state 3 . state 4 final 4 . error BADTRANS {Bad transition ("4" "*"), no destination} .}
+ {reset . state 1 . state 2 . state 3 . state 4 final 4 . error BADTRANS {Bad transition ("4" "*"), no destination} .}
+
+ 4 {/ * x * / x * /}
+ {reset . state 1 . state 2 . state 2 . state 3 . state 4 final 4 . error BADTRANS {Bad transition ("4" "any"), no destination} . .}
+ {reset . state 1 . state 2 . error BADSYM {Bad symbol "x"} . . . . .}
+
+ 5 {/ * * * / * * /}
+ {reset . state 1 . state 2 . state 3 . state 3 . state 4 final 4 . error BADTRANS {Bad transition ("4" "*"), no destination} . .}
+ {reset . state 1 . state 2 . state 3 . state 3 . state 4 final 4 . error BADTRANS {Bad transition ("4" "*"), no destination} . .}
+} {
+ test de-put-${setimpl}-2.$n {put, -any any} {
+ set events {}
+ grammar::fa::dexec de ccomments -any any -command {lappend events}
+ foreach sy $string {
+ lappend events .
+ de put $sy
+ }
+ de destroy
+ set events
+ } $acceptany ; # {}
+
+ test de-put-${setimpl}-3.$n {put} {
+ set events {}
+ grammar::fa::dexec de ccomments -command {lappend events}
+ foreach sy $string {
+ lappend events .
+ de put $sy
+ }
+ de destroy
+ set events
+ } $accept ; # {}
+}
+
+# -------------------------------------------------------------------------
+ccomments destroy
+unset events
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_cons.test b/tcllib/modules/grammar_fa/tests/fa_cons.test
new file mode 100644
index 0000000..6bbfaf1
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_cons.test
@@ -0,0 +1,87 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_cons.test,v 1.6 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test fa-cons-${setimpl}-1.0 {construction error} {
+ catch {grammar::fa a foo} msg
+ set msg
+} {Error in constructor: wrong#args: ::a ?=|:=|<--|as|deserialize a'|fromRegex re ?over??}
+
+
+test fa-cons-${setimpl}-1.1 {construction error} {
+ catch {grammar::fa a foo fie far fux} msg
+ set msg
+} {Error in constructor: wrong#args: ::a ?=|:=|<--|as|deserialize a'|fromRegex re ?over??}
+
+
+test fa-cons-${setimpl}-1.2 {construction error} {
+ catch {grammar::fa a foo fie far} msg
+ set msg
+} {Error in constructor: bad assignment: ::a ?=|:=|<--|as|deserialize a'|fromRegex re ?over??}
+
+
+test fa-cons-${setimpl}-1.3 {construction error} {
+ catch {grammar::fa a foo fie} msg
+ set msg
+} {Error in constructor: bad assignment: ::a ?=|:=|<--|as|deserialize a'|fromRegex re ?over??}
+
+
+test fa-cons-${setimpl}-1.4 {construction error} {
+ catch {grammar::fa a = b} msg
+ set msg
+} {Error in constructor: invalid command name "b"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-cons-${setimpl}-2.0 {construction} {
+ grammar::fa a
+ a destroy
+} {}
+
+test fa-cons-${setimpl}-2.1 {construction} {
+ set res {}
+ lappend res [info commands ::a]
+ grammar::fa a
+ lappend res [info commands ::a]
+ a destroy
+ lappend res [info commands ::a]
+ set res
+} {{} ::a {}}
+
+
+test fa-cons-${setimpl}-2.2 {construction, properties of empty fa} {
+ set res {}
+ grammar::fa a
+ lappend res [a info type]
+ lappend res [a symbols]
+ lappend res [a states]
+ lappend res [a finalstates]
+ lappend res [a startstates]
+ lappend res [a reachable_states]
+ lappend res [a useful_states]
+ lappend res [a is deterministic]
+ lappend res [a is useful]
+ lappend res [a is complete]
+ lappend res [a is epsilon-free]
+ a destroy
+ set res
+} {::grammar::fa {} {} {} {} {} {} 0 0 1 1}
+
+
+test fa-cons-${setimpl}-2.3 {construction, serial} {
+ grammar::fa a
+ set res [a serialize]
+ a destroy
+ set res
+} $fa_empty
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_ec.test b/tcllib/modules/grammar_fa/tests/fa_ec.test
new file mode 100644
index 0000000..ef488e7
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_ec.test
@@ -0,0 +1,84 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_ec.test,v 1.4 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test fa-ec-${setimpl}-1.0 {epsilon closure} {
+ grammar::fa a
+ catch {a epsilon_closure} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodepsilon_closure type selfns win self s"}
+
+test fa-ec-${setimpl}-1.1 {epsilon closure} {
+ grammar::fa a
+ catch {a epsilon_closure x} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+test fa-ec-${setimpl}-1.2 {epsilon closure} {
+ grammar::fa a
+ catch {a epsilon_closure x y} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodepsilon_closure type selfns win self s"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+foreach {n code ec} {
+ 00 x {x}
+ 01 x- {x}
+ 02 xe {x}
+ 03 xy {x}
+ 04 xy- {x}
+ 05 xye {x y}
+ 06 xyee {x y}
+ 07 xye- {x y}
+ 08 xy-- {x}
+ 09 xy-= {x}
+ 10 xyz/ee {x y z}
+ 11 xyz/e- {x z}
+ 12 xyz/-- {x}
+ 13 xyz/-= {x}
+ 14 xyz|ee {x z}
+ 15 xyz|e- {x}
+ 16 xyz|-- {x}
+ 17 xyz|-= {x}
+ 18 xyz+eee {x y z}
+ 19 xyz+ee- {x y z}
+ 20 xyz+e-- {x y}
+ 21 xyz+e-= {x y}
+ 22 xyz+--- {x}
+ 23 xyz+--= {x}
+ 24 xyz+-=_ {x}
+ 25 xyz&eee {x y z}
+ 26 xyz&ee- {x y z}
+ 27 xyz&e-- {x y}
+ 28 xyz&e-= {x y}
+ 29 xyz&--- {x}
+ 30 xyz&--= {x}
+ 31 xyz&-=_ {x}
+ 32 xyz!ee {x y z}
+ 33 xyz!e- {x y}
+ 34 xyz!-- {x}
+ 35 xyz!-= {x}
+ 36 xyz!-e {x}
+} {
+ test fa-ec-${setimpl}-2.${n}.$code {epsilon closure} {
+ grammar::fa a
+ gen $code
+ set res [lsort [a epsilon_closure x]]
+ a destroy
+ set res
+ } $ec
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_final.test b/tcllib/modules/grammar_fa/tests/fa_final.test
new file mode 100644
index 0000000..0927af3
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_final.test
@@ -0,0 +1,391 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_final.test,v 1.6 2009/10/27 21:17:23 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test fa-final-${setimpl}-1.0 {final states, error} {
+ grammar::fa a
+ catch {a finalstates x} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodfinalstates type selfns win self"}
+
+
+test fa-final-${setimpl}-1.1 {final query, error} {
+ grammar::fa a
+ catch {a final?} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodfinal? type selfns win self s"}
+
+
+test fa-final-${setimpl}-1.2 {final query, error} {
+ grammar::fa a
+ catch {a final? x y} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodfinal? type selfns win self s"}
+
+
+test fa-final-${setimpl}-1.3 {final query, error} {
+ grammar::fa a
+ catch {a final? x} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-final-${setimpl}-1.4 {final query set, error} {
+ grammar::fa a
+ catch {a final?set} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodfinal?set type selfns win self states"}
+
+
+test fa-final-${setimpl}-1.5 {final query set, error} {
+ grammar::fa a
+ catch {a final?set x y} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodfinal?set type selfns win self states"}
+
+
+test fa-final-${setimpl}-1.6 {final query set, error} {
+ grammar::fa a
+ catch {a final?set x} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-final-${setimpl}-1.7 {final query set, error} {
+ grammar::fa a
+ a state add x
+ catch {a final?set {x y}} res
+ a destroy
+ set res
+} {Illegal state "y"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-final-${setimpl}-2.0 {final, error} {
+ grammar::fa a
+ catch {a final} res
+ a destroy
+ set res
+} {wrong number args: should be "::a final method args"}
+# [tcltest::wrongNumArgs {::a final method} {args} 0]
+
+
+test fa-final-${setimpl}-2.1 {final, error} {
+ grammar::fa a
+ catch {a final foo} res
+ a destroy
+ set res
+} {"::a final foo" is not defined}
+
+
+test fa-final-${setimpl}-2.2 {final, error} {
+ grammar::fa a
+ catch {a final add} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs {::grammar::fa::Snit_hmethodfinal_add} {type selfns win self state args} 0]
+# [snitWrongNumArgs a {final add} {state args} 0]
+# {wrong # args: should be "::grammar::fa::Snit_hmethodfinal_add type selfns win self state args"}
+
+
+test fa-final-${setimpl}-2.3 {final, error} {
+ grammar::fa a
+ catch {a final add x y} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-final-${setimpl}-2.4 {final, error} {
+ grammar::fa a
+ catch {a final add x} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-final-${setimpl}-2.5 {final states} {
+ grammar::fa a
+ catch {a final remove} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs {::grammar::fa::Snit_hmethodfinal_remove} {type selfns win self state args} 0]
+# {wrong # args: should be "::grammar::fa::Snit_hmethodfinal_remove type selfns win self state args"}
+
+
+test fa-final-${setimpl}-2.6 {final states} {
+ grammar::fa a
+ catch {a final remove x y} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-final-${setimpl}-2.7 {final states} {
+ grammar::fa a
+ catch {a final remove x} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-final-${setimpl}-2.8 {final states} {
+ grammar::fa a
+ catch {a final set} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_hmethodfinal_set type selfns win self states"}
+
+
+test fa-final-${setimpl}-2.9 {final states} {
+ grammar::fa a
+ a state add x
+ catch {a final set {x y}} res
+ a destroy
+ set res
+} {Illegal state "y"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-final-${setimpl}-3.0 {final states, empty fa} {
+ grammar::fa a
+ set res [a finalstates]
+ a destroy
+ set res
+} {}
+
+
+test fa-final-${setimpl}-3.1 {final states, plain state} {
+ grammar::fa a
+ a state add x
+ set res [a finalstates]
+ a destroy
+ set res
+} {}
+
+
+test fa-final-${setimpl}-3.2 {final states, state addition} {
+ grammar::fa a
+ a state add x
+ a final add x
+ set res [a finalstates]
+ a destroy
+ set res
+} x
+
+
+test fa-final-${setimpl}-3.3 {final states, state addition} {
+ grammar::fa a
+ a state add x y
+ a final add x y
+ set res [lsort [a finalstates]]
+ a destroy
+ set res
+} {x y}
+
+
+test fa-final-${setimpl}-3.4 {final states, state addition, and remova;} {
+ grammar::fa a
+ a state add x y
+ a final add x y
+ set res {}
+ lappend res [a finalstates]
+ a final remove y
+ lappend res [a finalstates]
+ a final remove x
+ lappend res [a finalstates]
+ a destroy
+ set res
+} {{x y} x {}}
+
+
+test fa-final-${setimpl}-3.5 {final states, state addition, and remova;} {
+ grammar::fa a
+ a state add x y
+ a final add x y
+ set res {}
+ lappend res [a finalstates]
+ a state delete y
+ lappend res [a finalstates]
+ a state delete x
+ lappend res [a finalstates]
+ a destroy
+ set res
+} {{x y} x {}}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-final-${setimpl}-4.0 {final?} {
+ grammar::fa a
+ a state add x
+ set res [a final? x]
+ a destroy
+ set res
+} 0
+
+
+test fa-final-${setimpl}-4.1 {final?} {
+ grammar::fa a
+ a state add x
+ a final add x
+ set res [a final? x]
+ a destroy
+ set res
+} 1
+
+
+test fa-final-${setimpl}-4.2 {final?} {
+ grammar::fa a
+ a state add x
+ a final add x
+ set res [a final? x]
+ a final remove x
+ lappend res [a final? x]
+ a destroy
+ set res
+} {1 0}
+
+
+test fa-final-${setimpl}-4.3 {final?} {
+ grammar::fa a
+ a state add x
+ a final add x
+ set res [a final? x]
+ a state delete x
+ catch {a final? x} msg
+ lappend res $msg
+ a destroy
+ set res
+} {1 {Illegal state "x"}}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-final-${setimpl}-5.0 {final?set} {
+ grammar::fa a
+ a state add x
+ set res [a final?set x]
+ a destroy
+ set res
+} 0
+
+
+test fa-final-${setimpl}-5.1 {final?set} {
+ grammar::fa a
+ a state add x
+ a final add x
+ set res [a final?set x]
+ a destroy
+ set res
+} 1
+
+
+test fa-final-${setimpl}-5.2 {final?set} {
+ grammar::fa a
+ set res {}
+ a state add x
+ a final add x
+ lappend res [a final?set x]
+ a final remove x
+ lappend res [a final?set x]
+ a destroy
+ set res
+} {1 0}
+
+
+test fa-final-${setimpl}-5.3 {final?set} {
+ grammar::fa a
+ set res {}
+ a state add x y
+ a final add x
+ lappend res [a final?set y]
+ lappend res [a final?set {x y}]
+ a destroy
+ set res
+} {0 1}
+
+
+test fa-final-${setimpl}-5.4 {final?set} {
+ grammar::fa a
+ a state add x
+ set res {}
+ lappend res [a final? x]
+ lappend res [a final remove x]
+ lappend res [a final? x]
+ a destroy
+ set res
+} {0 {} 0}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+test fa-final-${setimpl}-6.0 {final clear} {
+ grammar::fa a
+ a state add x
+ a final add x
+ set res {}
+ lappend res [a finalstates]
+ a final clear
+ lappend res [a finalstates]
+ a destroy
+ set res
+} {x {}}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-final-${setimpl}-7.0 {final set} {
+ grammar::fa a
+ a state add x
+ a final set x
+ set res [a finalstates]
+ a destroy
+ set res
+} x
+
+
+test fa-final-${setimpl}-7.1 {final set} {
+ grammar::fa a
+ a state add x y
+ a final set {x y}
+ set res [lsort [a finalstates]]
+ a destroy
+ set res
+} {x y}
+
+
+test fa-final-${setimpl}-7.2 {final set} {
+ grammar::fa a
+ set res {}
+ a state add x y z
+ a final add z
+ lappend res [a finalstates]
+ a final set {x y}
+ lappend res [lsort [a finalstates]]
+ a destroy
+ set res
+} {z {x y}}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_is.test b/tcllib/modules/grammar_fa/tests/fa_is.test
new file mode 100644
index 0000000..8f8e36a
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_is.test
@@ -0,0 +1,59 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_is.test,v 1.4 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test fa-is-${setimpl}-1.0 {is, error} {
+ grammar::fa a
+ catch {a is} msg
+ a destroy
+ set msg
+} {wrong # args: should be "::grammar::fa::Snit_methodis type selfns win self cmd"}
+
+
+test fa-is-${setimpl}-1.1 {is, error} {
+ grammar::fa a
+ catch {a is foo} msg
+ a destroy
+ set msg
+} {Expected complete, deterministic, epsilon-free, or useful, got "foo"}
+
+
+test fa-is-${setimpl}-1.2 {is, error} {
+ grammar::fa a
+ catch {a is complete bar} msg
+ a destroy
+ set msg
+} {wrong # args: should be "::grammar::fa::Snit_methodis type selfns win self cmd"}
+
+
+test fa-is-${setimpl}-1.3 {is, error} {
+ grammar::fa a
+ catch {a is deterministic bar} msg
+ a destroy
+ set msg
+} {wrong # args: should be "::grammar::fa::Snit_methodis type selfns win self cmd"}
+
+
+test fa-is-${setimpl}-1.4 {is, error} {
+ grammar::fa a
+ catch {a is useful bar} msg
+ a destroy
+ set msg
+} {wrong # args: should be "::grammar::fa::Snit_methodis type selfns win self cmd"}
+
+
+test fa-is-${setimpl}-1.5 {is, error} {
+ grammar::fa a
+ catch {a is epsilon-free bar} msg
+ a destroy
+ set msg
+} {wrong # args: should be "::grammar::fa::Snit_methodis type selfns win self cmd"}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_is_complete.test b/tcllib/modules/grammar_fa/tests/fa_is_complete.test
new file mode 100644
index 0000000..7229303
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_is_complete.test
@@ -0,0 +1,60 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_is_complete.test,v 1.5 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+foreach {n code result} {
+ 00 x 1
+ 01 x- 1
+ 02 xe 1
+ 03 xy 1
+ 04 xy- 0
+ 05 xye 1
+ 06 xyee 1
+ 07 xye- 1
+ 08 xy-- 1
+ 09 xy-= 0
+ 10 xyz/ee 1
+ 11 xyz/e- 0
+ 12 xyz/-- 0
+ 13 xyz/-= 0
+ 14 xyz|ee 1
+ 15 xyz|e- 0
+ 16 xyz|-- 0
+ 17 xyz|-= 0
+ 18 xyz+eee 1
+ 19 xyz+ee- 1
+ 20 xyz+e-- 1
+ 21 xyz+e-= 0
+ 22 xyz+--- 1
+ 23 xyz+--= 0
+ 24 xyz+-=_ 0
+ 25 xyz&eee 1
+ 26 xyz&ee- 0
+ 27 xyz&e-- 0
+ 28 xyz&e-= 0
+ 29 xyz&--- 0
+ 30 xyz&--= 0
+ 31 xyz&-=_ 0
+ 32 xyz!ee 1
+ 33 xyz!e- 0
+ 34 xyz!-- 0
+ 35 xyz!-= 0
+ 36 xyz!-e 0
+} {
+ test fa-is-${setimpl}-complete-1.${n}.$code {is complete} {
+ grammar::fa a
+ gen $code
+ set res [a is complete]
+ a destroy
+ set res
+ } $result ;# {}
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_is_deterministic.test b/tcllib/modules/grammar_fa/tests/fa_is_deterministic.test
new file mode 100644
index 0000000..3be3831
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_is_deterministic.test
@@ -0,0 +1,75 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_is_deterministic.test,v 1.7 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+if {![::tcltest::testConstraint runtotal]} {
+ ::tcltest::cleanupTests
+ return
+}
+
+# -------------------------------------------------------------------------
+
+foreach {n code setup_result} {
+ 00 x {{} 0 x 1}
+ 01 x- {{} 0 x 1}
+ 02 xe {{} 0 x 0}
+ 03 xy {{} 0 x 1 y 1 {x y} 0}
+ 04 xy- {{} 0 x 1 y 1 {x y} 0}
+ 05 xye {{} 0 x 0 y 0 {x y} 0}
+ 06 xyee {{} 0 x 0 y 0 {x y} 0}
+ 07 xye- {{} 0 x 0 y 0 {x y} 0}
+ 08 xy-- {{} 0 x 1 y 1 {x y} 0}
+ 09 xy-= {{} 0 x 1 y 1 {x y} 0}
+ 10 xyz/ee {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 11 xyz/e- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 12 xyz/-- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 13 xyz/-= {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 14 xyz|ee {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 15 xyz|e- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 16 xyz|-- {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 17 xyz|-= {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 18 xyz+eee {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 19 xyz+ee- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 20 xyz+e-- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 21 xyz+e-= {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 22 xyz+--- {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 23 xyz+--= {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 24 xyz+-=_ {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 25 xyz&eee {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 26 xyz&ee- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 27 xyz&e-- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 28 xyz&e-= {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 29 xyz&--- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 30 xyz&--= {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 31 xyz&-=_ {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 32 xyz!ee {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 33 xyz!e- {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 34 xyz!-- {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 35 xyz!-= {{} 0 x 1 y 1 z 1 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+ 36 xyz!-e {{} 0 x 0 y 0 z 0 {x y} 0 {x z} 0 {y z} 0 {x y z} 0}
+} {
+ foreach {stset expected} $setup_result {
+ foreach {fset __} $setup_result {
+ set key ${n}.${code}.([join $stset {}]).([join $fset {}])
+
+ test fa-is-${setimpl}-deterministic-1.$key {is deterministic} {
+ grammar::fa a
+ gen $code
+ a start set $stset
+ a final set $fset
+ set res [a is deterministic]
+ a destroy
+ set res
+ } $expected ; # {}
+ }
+ }
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_is_epsfree.test b/tcllib/modules/grammar_fa/tests/fa_is_epsfree.test
new file mode 100644
index 0000000..32d2f36
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_is_epsfree.test
@@ -0,0 +1,60 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_is_epsfree.test,v 1.4 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+foreach {n code result} {
+ 00 x 1
+ 01 x- 1
+ 02 xe 0
+ 03 xy 1
+ 04 xy- 1
+ 05 xye 0
+ 06 xyee 0
+ 07 xye- 0
+ 08 xy-- 1
+ 09 xy-= 1
+ 10 xyz/ee 0
+ 11 xyz/e- 0
+ 12 xyz/-- 1
+ 13 xyz/-= 1
+ 14 xyz|ee 0
+ 15 xyz|e- 0
+ 16 xyz|-- 1
+ 17 xyz|-= 1
+ 18 xyz+eee 0
+ 19 xyz+ee- 0
+ 20 xyz+e-- 0
+ 21 xyz+e-= 0
+ 22 xyz+--- 1
+ 23 xyz+--= 1
+ 24 xyz+-=_ 1
+ 25 xyz&eee 0
+ 26 xyz&ee- 0
+ 27 xyz&e-- 0
+ 28 xyz&e-= 0
+ 29 xyz&--- 1
+ 30 xyz&--= 1
+ 31 xyz&-=_ 1
+ 32 xyz!ee 0
+ 33 xyz!e- 0
+ 34 xyz!-- 1
+ 35 xyz!-= 1
+ 36 xyz!-e 0
+} {
+ test fa-is-${setimpl}-epsilonfree-1.${n}.$code {is epsilon free} {
+ grammar::fa a
+ gen $code
+ set res [a is epsilon-free]
+ a destroy
+ set res
+ } $result ; # {}
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_is_useful.test b/tcllib/modules/grammar_fa/tests/fa_is_useful.test
new file mode 100644
index 0000000..65d870b
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_is_useful.test
@@ -0,0 +1,715 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_is_useful.test,v 1.7 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+if {![::tcltest::testConstraint runtotal]} {
+ ::tcltest::cleanupTests
+ return
+}
+
+# -------------------------------------------------------------------------
+unset -nocomplain expected
+array set expected {
+ 04.xy-.(x,y) _
+ 04.xy-.(x,xy) _
+ 04.xy-.(xy,y) _
+ 05.xye.(x,y) _
+ 05.xye.(x,xy) _
+ 05.xye.(xy,y) _
+ 06.xyee.(x,x) _
+ 06.xyee.(x,y) _
+ 06.xyee.(x,xy) _
+ 06.xyee.(y,x) _
+ 06.xyee.(y,y) _
+ 06.xyee.(y,xy) _
+ 06.xyee.(xy,x) _
+ 06.xyee.(xy,y) _
+ 07.xye-.(x,x) _
+ 07.xye-.(x,y) _
+ 07.xye-.(x,xy) _
+ 07.xye-.(y,x) _
+ 07.xye-.(y,y) _
+ 07.xye-.(y,xy) _
+ 07.xye-.(xy,x) _
+ 07.xye-.(xy,y) _
+ 08.xy--.(x,x) _
+ 08.xy--.(x,y) _
+ 08.xy--.(x,xy) _
+ 08.xy--.(y,x) _
+ 08.xy--.(y,y) _
+ 08.xy--.(y,xy) _
+ 08.xy--.(xy,x) _
+ 08.xy--.(xy,y) _
+ 09.xy-=.(x,x) _
+ 09.xy-=.(x,y) _
+ 09.xy-=.(x,xy) _
+ 09.xy-=.(y,x) _
+ 09.xy-=.(y,y) _
+ 09.xy-=.(y,xy) _
+ 09.xy-=.(xy,x) _
+ 09.xy-=.(xy,y) _
+ 10.xyz/ee.(x,yz) _
+ 10.xyz/ee.(x,xyz) _
+ 10.xyz/ee.(xy,yz) _
+ 10.xyz/ee.(xy,xyz) _
+ 10.xyz/ee.(xz,yz) _
+ 10.xyz/ee.(xz,xyz) _
+ 10.xyz/ee.(xyz,yz) _
+ 11.xyz/e-.(x,yz) _
+ 11.xyz/e-.(x,xyz) _
+ 11.xyz/e-.(xy,yz) _
+ 11.xyz/e-.(xy,xyz) _
+ 11.xyz/e-.(xz,yz) _
+ 11.xyz/e-.(xz,xyz) _
+ 11.xyz/e-.(xyz,yz) _
+ 12.xyz/--.(x,yz) _
+ 12.xyz/--.(x,xyz) _
+ 12.xyz/--.(xy,yz) _
+ 12.xyz/--.(xy,xyz) _
+ 12.xyz/--.(xz,yz) _
+ 12.xyz/--.(xz,xyz) _
+ 12.xyz/--.(xyz,yz) _
+ 13.xyz/-=.(x,yz) _
+ 13.xyz/-=.(x,xyz) _
+ 13.xyz/-=.(xy,yz) _
+ 13.xyz/-=.(xy,xyz) _
+ 13.xyz/-=.(xz,yz) _
+ 13.xyz/-=.(xz,xyz) _
+ 13.xyz/-=.(xyz,yz) _
+ 14.xyz|ee.(xy,z) _
+ 14.xyz|ee.(xy,xz) _
+ 14.xyz|ee.(xy,yz) _
+ 14.xyz|ee.(xy,xyz) _
+ 14.xyz|ee.(xyz,z) _
+ 14.xyz|ee.(xyz,xz) _
+ 14.xyz|ee.(xyz,yz) _
+ 15.xyz|e-.(xy,z) _
+ 15.xyz|e-.(xy,xz) _
+ 15.xyz|e-.(xy,yz) _
+ 15.xyz|e-.(xy,xyz) _
+ 15.xyz|e-.(xyz,z) _
+ 15.xyz|e-.(xyz,xz) _
+ 15.xyz|e-.(xyz,yz) _
+ 16.xyz|--.(xy,z) _
+ 16.xyz|--.(xy,xz) _
+ 16.xyz|--.(xy,yz) _
+ 16.xyz|--.(xy,xyz) _
+ 16.xyz|--.(xyz,z) _
+ 16.xyz|--.(xyz,xz) _
+ 16.xyz|--.(xyz,yz) _
+ 17.xyz|-=.(xy,z) _
+ 17.xyz|-=.(xy,xz) _
+ 17.xyz|-=.(xy,yz) _
+ 17.xyz|-=.(xy,xyz) _
+ 17.xyz|-=.(xyz,z) _
+ 17.xyz|-=.(xyz,xz) _
+ 17.xyz|-=.(xyz,yz) _
+ 18.xyz+eee.(x,x) _
+ 18.xyz+eee.(x,y) _
+ 18.xyz+eee.(x,z) _
+ 18.xyz+eee.(x,xy) _
+ 18.xyz+eee.(x,xz) _
+ 18.xyz+eee.(x,yz) _
+ 18.xyz+eee.(x,xyz) _
+ 18.xyz+eee.(y,x) _
+ 18.xyz+eee.(y,y) _
+ 18.xyz+eee.(y,z) _
+ 18.xyz+eee.(y,xy) _
+ 18.xyz+eee.(y,xz) _
+ 18.xyz+eee.(y,yz) _
+ 18.xyz+eee.(y,xyz) _
+ 18.xyz+eee.(z,x) _
+ 18.xyz+eee.(z,y) _
+ 18.xyz+eee.(z,z) _
+ 18.xyz+eee.(z,xy) _
+ 18.xyz+eee.(z,xz) _
+ 18.xyz+eee.(z,yz) _
+ 18.xyz+eee.(z,xyz) _
+ 18.xyz+eee.(xy,x) _
+ 18.xyz+eee.(xy,y) _
+ 18.xyz+eee.(xy,z) _
+ 18.xyz+eee.(xy,xy) _
+ 18.xyz+eee.(xy,xz) _
+ 18.xyz+eee.(xy,yz) _
+ 18.xyz+eee.(xy,xyz) _
+ 18.xyz+eee.(xz,x) _
+ 18.xyz+eee.(xz,y) _
+ 18.xyz+eee.(xz,z) _
+ 18.xyz+eee.(xz,xy) _
+ 18.xyz+eee.(xz,xz) _
+ 18.xyz+eee.(xz,yz) _
+ 18.xyz+eee.(xz,xyz) _
+ 18.xyz+eee.(yz,x) _
+ 18.xyz+eee.(yz,y) _
+ 18.xyz+eee.(yz,z) _
+ 18.xyz+eee.(yz,xy) _
+ 18.xyz+eee.(yz,xz) _
+ 18.xyz+eee.(yz,yz) _
+ 18.xyz+eee.(yz,xyz) _
+ 18.xyz+eee.(xyz,x) _
+ 18.xyz+eee.(xyz,y) _
+ 18.xyz+eee.(xyz,z) _
+ 18.xyz+eee.(xyz,xy) _
+ 18.xyz+eee.(xyz,xz) _
+ 18.xyz+eee.(xyz,yz) _
+ 19.xyz+ee-.(x,x) _
+ 19.xyz+ee-.(x,y) _
+ 19.xyz+ee-.(x,z) _
+ 19.xyz+ee-.(x,xy) _
+ 19.xyz+ee-.(x,xz) _
+ 19.xyz+ee-.(x,yz) _
+ 19.xyz+ee-.(x,xyz) _
+ 19.xyz+ee-.(y,x) _
+ 19.xyz+ee-.(y,y) _
+ 19.xyz+ee-.(y,z) _
+ 19.xyz+ee-.(y,xy) _
+ 19.xyz+ee-.(y,xz) _
+ 19.xyz+ee-.(y,yz) _
+ 19.xyz+ee-.(y,xyz) _
+ 19.xyz+ee-.(z,x) _
+ 19.xyz+ee-.(z,y) _
+ 19.xyz+ee-.(z,z) _
+ 19.xyz+ee-.(z,xy) _
+ 19.xyz+ee-.(z,xz) _
+ 19.xyz+ee-.(z,yz) _
+ 19.xyz+ee-.(z,xyz) _
+ 19.xyz+ee-.(xy,x) _
+ 19.xyz+ee-.(xy,y) _
+ 19.xyz+ee-.(xy,z) _
+ 19.xyz+ee-.(xy,xy) _
+ 19.xyz+ee-.(xy,xz) _
+ 19.xyz+ee-.(xy,yz) _
+ 19.xyz+ee-.(xy,xyz) _
+ 19.xyz+ee-.(xz,x) _
+ 19.xyz+ee-.(xz,y) _
+ 19.xyz+ee-.(xz,z) _
+ 19.xyz+ee-.(xz,xy) _
+ 19.xyz+ee-.(xz,xz) _
+ 19.xyz+ee-.(xz,yz) _
+ 19.xyz+ee-.(xz,xyz) _
+ 19.xyz+ee-.(yz,x) _
+ 19.xyz+ee-.(yz,y) _
+ 19.xyz+ee-.(yz,z) _
+ 19.xyz+ee-.(yz,xy) _
+ 19.xyz+ee-.(yz,xz) _
+ 19.xyz+ee-.(yz,yz) _
+ 19.xyz+ee-.(yz,xyz) _
+ 19.xyz+ee-.(xyz,x) _
+ 19.xyz+ee-.(xyz,y) _
+ 19.xyz+ee-.(xyz,z) _
+ 19.xyz+ee-.(xyz,xy) _
+ 19.xyz+ee-.(xyz,xz) _
+ 19.xyz+ee-.(xyz,yz) _
+ 20.xyz+e--.(x,x) _
+ 20.xyz+e--.(x,y) _
+ 20.xyz+e--.(x,z) _
+ 20.xyz+e--.(x,xy) _
+ 20.xyz+e--.(x,xz) _
+ 20.xyz+e--.(x,yz) _
+ 20.xyz+e--.(x,xyz) _
+ 20.xyz+e--.(y,x) _
+ 20.xyz+e--.(y,y) _
+ 20.xyz+e--.(y,z) _
+ 20.xyz+e--.(y,xy) _
+ 20.xyz+e--.(y,xz) _
+ 20.xyz+e--.(y,yz) _
+ 20.xyz+e--.(y,xyz) _
+ 20.xyz+e--.(z,x) _
+ 20.xyz+e--.(z,y) _
+ 20.xyz+e--.(z,z) _
+ 20.xyz+e--.(z,xy) _
+ 20.xyz+e--.(z,xz) _
+ 20.xyz+e--.(z,yz) _
+ 20.xyz+e--.(z,xyz) _
+ 20.xyz+e--.(xy,x) _
+ 20.xyz+e--.(xy,y) _
+ 20.xyz+e--.(xy,z) _
+ 20.xyz+e--.(xy,xy) _
+ 20.xyz+e--.(xy,xz) _
+ 20.xyz+e--.(xy,yz) _
+ 20.xyz+e--.(xy,xyz) _
+ 20.xyz+e--.(xz,x) _
+ 20.xyz+e--.(xz,y) _
+ 20.xyz+e--.(xz,z) _
+ 20.xyz+e--.(xz,xy) _
+ 20.xyz+e--.(xz,xz) _
+ 20.xyz+e--.(xz,yz) _
+ 20.xyz+e--.(xz,xyz) _
+ 20.xyz+e--.(yz,x) _
+ 20.xyz+e--.(yz,y) _
+ 20.xyz+e--.(yz,z) _
+ 20.xyz+e--.(yz,xy) _
+ 20.xyz+e--.(yz,xz) _
+ 20.xyz+e--.(yz,yz) _
+ 20.xyz+e--.(yz,xyz) _
+ 20.xyz+e--.(xyz,x) _
+ 20.xyz+e--.(xyz,y) _
+ 20.xyz+e--.(xyz,z) _
+ 20.xyz+e--.(xyz,xy) _
+ 20.xyz+e--.(xyz,xz) _
+ 20.xyz+e--.(xyz,yz) _
+ 21.xyz+e-=.(x,x) _
+ 21.xyz+e-=.(x,y) _
+ 21.xyz+e-=.(x,z) _
+ 21.xyz+e-=.(x,xy) _
+ 21.xyz+e-=.(x,xz) _
+ 21.xyz+e-=.(x,yz) _
+ 21.xyz+e-=.(x,xyz) _
+ 21.xyz+e-=.(y,x) _
+ 21.xyz+e-=.(y,y) _
+ 21.xyz+e-=.(y,z) _
+ 21.xyz+e-=.(y,xy) _
+ 21.xyz+e-=.(y,xz) _
+ 21.xyz+e-=.(y,yz) _
+ 21.xyz+e-=.(y,xyz) _
+ 21.xyz+e-=.(z,x) _
+ 21.xyz+e-=.(z,y) _
+ 21.xyz+e-=.(z,z) _
+ 21.xyz+e-=.(z,xy) _
+ 21.xyz+e-=.(z,xz) _
+ 21.xyz+e-=.(z,yz) _
+ 21.xyz+e-=.(z,xyz) _
+ 21.xyz+e-=.(xy,x) _
+ 21.xyz+e-=.(xy,y) _
+ 21.xyz+e-=.(xy,z) _
+ 21.xyz+e-=.(xy,xy) _
+ 21.xyz+e-=.(xy,xz) _
+ 21.xyz+e-=.(xy,yz) _
+ 21.xyz+e-=.(xy,xyz) _
+ 21.xyz+e-=.(xz,x) _
+ 21.xyz+e-=.(xz,y) _
+ 21.xyz+e-=.(xz,z) _
+ 21.xyz+e-=.(xz,xy) _
+ 21.xyz+e-=.(xz,xz) _
+ 21.xyz+e-=.(xz,yz) _
+ 21.xyz+e-=.(xz,xyz) _
+ 21.xyz+e-=.(yz,x) _
+ 21.xyz+e-=.(yz,y) _
+ 21.xyz+e-=.(yz,z) _
+ 21.xyz+e-=.(yz,xy) _
+ 21.xyz+e-=.(yz,xz) _
+ 21.xyz+e-=.(yz,yz) _
+ 21.xyz+e-=.(yz,xyz) _
+ 21.xyz+e-=.(xyz,x) _
+ 21.xyz+e-=.(xyz,y) _
+ 21.xyz+e-=.(xyz,z) _
+ 21.xyz+e-=.(xyz,xy) _
+ 21.xyz+e-=.(xyz,xz) _
+ 21.xyz+e-=.(xyz,yz) _
+ 22.xyz+---.(x,x) _
+ 22.xyz+---.(x,y) _
+ 22.xyz+---.(x,z) _
+ 22.xyz+---.(x,xy) _
+ 22.xyz+---.(x,xz) _
+ 22.xyz+---.(x,yz) _
+ 22.xyz+---.(x,xyz) _
+ 22.xyz+---.(y,x) _
+ 22.xyz+---.(y,y) _
+ 22.xyz+---.(y,z) _
+ 22.xyz+---.(y,xy) _
+ 22.xyz+---.(y,xz) _
+ 22.xyz+---.(y,yz) _
+ 22.xyz+---.(y,xyz) _
+ 22.xyz+---.(z,x) _
+ 22.xyz+---.(z,y) _
+ 22.xyz+---.(z,z) _
+ 22.xyz+---.(z,xy) _
+ 22.xyz+---.(z,xz) _
+ 22.xyz+---.(z,yz) _
+ 22.xyz+---.(z,xyz) _
+ 22.xyz+---.(xy,x) _
+ 22.xyz+---.(xy,y) _
+ 22.xyz+---.(xy,z) _
+ 22.xyz+---.(xy,xy) _
+ 22.xyz+---.(xy,xz) _
+ 22.xyz+---.(xy,yz) _
+ 22.xyz+---.(xy,xyz) _
+ 22.xyz+---.(xz,x) _
+ 22.xyz+---.(xz,y) _
+ 22.xyz+---.(xz,z) _
+ 22.xyz+---.(xz,xy) _
+ 22.xyz+---.(xz,xz) _
+ 22.xyz+---.(xz,yz) _
+ 22.xyz+---.(xz,xyz) _
+ 22.xyz+---.(yz,x) _
+ 22.xyz+---.(yz,y) _
+ 22.xyz+---.(yz,z) _
+ 22.xyz+---.(yz,xy) _
+ 22.xyz+---.(yz,xz) _
+ 22.xyz+---.(yz,yz) _
+ 22.xyz+---.(yz,xyz) _
+ 22.xyz+---.(xyz,x) _
+ 22.xyz+---.(xyz,y) _
+ 22.xyz+---.(xyz,z) _
+ 22.xyz+---.(xyz,xy) _
+ 22.xyz+---.(xyz,xz) _
+ 22.xyz+---.(xyz,yz) _
+ 23.xyz+--=.(x,x) _
+ 23.xyz+--=.(x,y) _
+ 23.xyz+--=.(x,z) _
+ 23.xyz+--=.(x,xy) _
+ 23.xyz+--=.(x,xz) _
+ 23.xyz+--=.(x,yz) _
+ 23.xyz+--=.(x,xyz) _
+ 23.xyz+--=.(y,x) _
+ 23.xyz+--=.(y,y) _
+ 23.xyz+--=.(y,z) _
+ 23.xyz+--=.(y,xy) _
+ 23.xyz+--=.(y,xz) _
+ 23.xyz+--=.(y,yz) _
+ 23.xyz+--=.(y,xyz) _
+ 23.xyz+--=.(z,x) _
+ 23.xyz+--=.(z,y) _
+ 23.xyz+--=.(z,z) _
+ 23.xyz+--=.(z,xy) _
+ 23.xyz+--=.(z,xz) _
+ 23.xyz+--=.(z,yz) _
+ 23.xyz+--=.(z,xyz) _
+ 23.xyz+--=.(xy,x) _
+ 23.xyz+--=.(xy,y) _
+ 23.xyz+--=.(xy,z) _
+ 23.xyz+--=.(xy,xy) _
+ 23.xyz+--=.(xy,xz) _
+ 23.xyz+--=.(xy,yz) _
+ 23.xyz+--=.(xy,xyz) _
+ 23.xyz+--=.(xz,x) _
+ 23.xyz+--=.(xz,y) _
+ 23.xyz+--=.(xz,z) _
+ 23.xyz+--=.(xz,xy) _
+ 23.xyz+--=.(xz,xz) _
+ 23.xyz+--=.(xz,yz) _
+ 23.xyz+--=.(xz,xyz) _
+ 23.xyz+--=.(yz,x) _
+ 23.xyz+--=.(yz,y) _
+ 23.xyz+--=.(yz,z) _
+ 23.xyz+--=.(yz,xy) _
+ 23.xyz+--=.(yz,xz) _
+ 23.xyz+--=.(yz,yz) _
+ 23.xyz+--=.(yz,xyz) _
+ 23.xyz+--=.(xyz,x) _
+ 23.xyz+--=.(xyz,y) _
+ 23.xyz+--=.(xyz,z) _
+ 23.xyz+--=.(xyz,xy) _
+ 23.xyz+--=.(xyz,xz) _
+ 23.xyz+--=.(xyz,yz) _
+ 24.xyz+-=_.(x,x) _
+ 24.xyz+-=_.(x,y) _
+ 24.xyz+-=_.(x,z) _
+ 24.xyz+-=_.(x,xy) _
+ 24.xyz+-=_.(x,xz) _
+ 24.xyz+-=_.(x,yz) _
+ 24.xyz+-=_.(x,xyz) _
+ 24.xyz+-=_.(y,x) _
+ 24.xyz+-=_.(y,y) _
+ 24.xyz+-=_.(y,z) _
+ 24.xyz+-=_.(y,xy) _
+ 24.xyz+-=_.(y,xz) _
+ 24.xyz+-=_.(y,yz) _
+ 24.xyz+-=_.(y,xyz) _
+ 24.xyz+-=_.(z,x) _
+ 24.xyz+-=_.(z,y) _
+ 24.xyz+-=_.(z,z) _
+ 24.xyz+-=_.(z,xy) _
+ 24.xyz+-=_.(z,xz) _
+ 24.xyz+-=_.(z,yz) _
+ 24.xyz+-=_.(z,xyz) _
+ 24.xyz+-=_.(xy,x) _
+ 24.xyz+-=_.(xy,y) _
+ 24.xyz+-=_.(xy,z) _
+ 24.xyz+-=_.(xy,xy) _
+ 24.xyz+-=_.(xy,xz) _
+ 24.xyz+-=_.(xy,yz) _
+ 24.xyz+-=_.(xy,xyz) _
+ 24.xyz+-=_.(xz,x) _
+ 24.xyz+-=_.(xz,y) _
+ 24.xyz+-=_.(xz,z) _
+ 24.xyz+-=_.(xz,xy) _
+ 24.xyz+-=_.(xz,xz) _
+ 24.xyz+-=_.(xz,yz) _
+ 24.xyz+-=_.(xz,xyz) _
+ 24.xyz+-=_.(yz,x) _
+ 24.xyz+-=_.(yz,y) _
+ 24.xyz+-=_.(yz,z) _
+ 24.xyz+-=_.(yz,xy) _
+ 24.xyz+-=_.(yz,xz) _
+ 24.xyz+-=_.(yz,yz) _
+ 24.xyz+-=_.(yz,xyz) _
+ 24.xyz+-=_.(xyz,x) _
+ 24.xyz+-=_.(xyz,y) _
+ 24.xyz+-=_.(xyz,z) _
+ 24.xyz+-=_.(xyz,xy) _
+ 24.xyz+-=_.(xyz,xz) _
+ 24.xyz+-=_.(xyz,yz) _
+ 25.xyz&eee.(x,z) _
+ 25.xyz&eee.(x,xz) _
+ 25.xyz&eee.(x,yz) _
+ 25.xyz&eee.(x,xyz) _
+ 25.xyz&eee.(xy,z) _
+ 25.xyz&eee.(xy,xz) _
+ 25.xyz&eee.(xy,yz) _
+ 25.xyz&eee.(xy,xyz) _
+ 25.xyz&eee.(xz,z) _
+ 25.xyz&eee.(xz,xz) _
+ 25.xyz&eee.(xz,yz) _
+ 25.xyz&eee.(xz,xyz) _
+ 25.xyz&eee.(xyz,z) _
+ 25.xyz&eee.(xyz,xz) _
+ 25.xyz&eee.(xyz,yz) _
+ 26.xyz&ee-.(x,z) _
+ 26.xyz&ee-.(x,xz) _
+ 26.xyz&ee-.(x,yz) _
+ 26.xyz&ee-.(x,xyz) _
+ 26.xyz&ee-.(xy,z) _
+ 26.xyz&ee-.(xy,xz) _
+ 26.xyz&ee-.(xy,yz) _
+ 26.xyz&ee-.(xy,xyz) _
+ 26.xyz&ee-.(xz,z) _
+ 26.xyz&ee-.(xz,xz) _
+ 26.xyz&ee-.(xz,yz) _
+ 26.xyz&ee-.(xz,xyz) _
+ 26.xyz&ee-.(xyz,z) _
+ 26.xyz&ee-.(xyz,xz) _
+ 26.xyz&ee-.(xyz,yz) _
+ 27.xyz&e--.(x,z) _
+ 27.xyz&e--.(x,xz) _
+ 27.xyz&e--.(x,yz) _
+ 27.xyz&e--.(x,xyz) _
+ 27.xyz&e--.(xy,z) _
+ 27.xyz&e--.(xy,xz) _
+ 27.xyz&e--.(xy,yz) _
+ 27.xyz&e--.(xy,xyz) _
+ 27.xyz&e--.(xz,z) _
+ 27.xyz&e--.(xz,xz) _
+ 27.xyz&e--.(xz,yz) _
+ 27.xyz&e--.(xz,xyz) _
+ 27.xyz&e--.(xyz,z) _
+ 27.xyz&e--.(xyz,xz) _
+ 27.xyz&e--.(xyz,yz) _
+ 28.xyz&e-=.(x,z) _
+ 28.xyz&e-=.(x,xz) _
+ 28.xyz&e-=.(x,yz) _
+ 28.xyz&e-=.(x,xyz) _
+ 28.xyz&e-=.(xy,z) _
+ 28.xyz&e-=.(xy,xz) _
+ 28.xyz&e-=.(xy,yz) _
+ 28.xyz&e-=.(xy,xyz) _
+ 28.xyz&e-=.(xz,z) _
+ 28.xyz&e-=.(xz,xz) _
+ 28.xyz&e-=.(xz,yz) _
+ 28.xyz&e-=.(xz,xyz) _
+ 28.xyz&e-=.(xyz,z) _
+ 28.xyz&e-=.(xyz,xz) _
+ 28.xyz&e-=.(xyz,yz) _
+ 29.xyz&---.(x,z) _
+ 29.xyz&---.(x,xz) _
+ 29.xyz&---.(x,yz) _
+ 29.xyz&---.(x,xyz) _
+ 29.xyz&---.(xy,z) _
+ 29.xyz&---.(xy,xz) _
+ 29.xyz&---.(xy,yz) _
+ 29.xyz&---.(xy,xyz) _
+ 29.xyz&---.(xz,z) _
+ 29.xyz&---.(xz,xz) _
+ 29.xyz&---.(xz,yz) _
+ 29.xyz&---.(xz,xyz) _
+ 29.xyz&---.(xyz,z) _
+ 29.xyz&---.(xyz,xz) _
+ 29.xyz&---.(xyz,yz) _
+ 30.xyz&--=.(x,z) _
+ 30.xyz&--=.(x,xz) _
+ 30.xyz&--=.(x,yz) _
+ 30.xyz&--=.(x,xyz) _
+ 30.xyz&--=.(xy,z) _
+ 30.xyz&--=.(xy,xz) _
+ 30.xyz&--=.(xy,yz) _
+ 30.xyz&--=.(xy,xyz) _
+ 30.xyz&--=.(xz,z) _
+ 30.xyz&--=.(xz,xz) _
+ 30.xyz&--=.(xz,yz) _
+ 30.xyz&--=.(xz,xyz) _
+ 30.xyz&--=.(xyz,z) _
+ 30.xyz&--=.(xyz,xz) _
+ 30.xyz&--=.(xyz,yz) _
+ 31.xyz&-=_.(x,z) _
+ 31.xyz&-=_.(x,xz) _
+ 31.xyz&-=_.(x,yz) _
+ 31.xyz&-=_.(x,xyz) _
+ 31.xyz&-=_.(xy,z) _
+ 31.xyz&-=_.(xy,xz) _
+ 31.xyz&-=_.(xy,yz) _
+ 31.xyz&-=_.(xy,xyz) _
+ 31.xyz&-=_.(xz,z) _
+ 31.xyz&-=_.(xz,xz) _
+ 31.xyz&-=_.(xz,yz) _
+ 31.xyz&-=_.(xz,xyz) _
+ 31.xyz&-=_.(xyz,z) _
+ 31.xyz&-=_.(xyz,xz) _
+ 31.xyz&-=_.(xyz,yz) _
+ 32.xyz!ee.(x,z) _
+ 32.xyz!ee.(x,xz) _
+ 32.xyz!ee.(x,yz) _
+ 32.xyz!ee.(x,xyz) _
+ 32.xyz!ee.(xy,z) _
+ 32.xyz!ee.(xy,xz) _
+ 32.xyz!ee.(xy,yz) _
+ 32.xyz!ee.(xy,xyz) _
+ 32.xyz!ee.(xz,z) _
+ 32.xyz!ee.(xz,xz) _
+ 32.xyz!ee.(xz,yz) _
+ 32.xyz!ee.(xz,xyz) _
+ 32.xyz!ee.(xyz,z) _
+ 32.xyz!ee.(xyz,xz) _
+ 32.xyz!ee.(xyz,yz) _
+ 33.xyz!e-.(x,z) _
+ 33.xyz!e-.(x,xz) _
+ 33.xyz!e-.(x,yz) _
+ 33.xyz!e-.(x,xyz) _
+ 33.xyz!e-.(xy,z) _
+ 33.xyz!e-.(xy,xz) _
+ 33.xyz!e-.(xy,yz) _
+ 33.xyz!e-.(xy,xyz) _
+ 33.xyz!e-.(xz,z) _
+ 33.xyz!e-.(xz,xz) _
+ 33.xyz!e-.(xz,yz) _
+ 33.xyz!e-.(xz,xyz) _
+ 33.xyz!e-.(xyz,z) _
+ 33.xyz!e-.(xyz,xz) _
+ 33.xyz!e-.(xyz,yz) _
+ 34.xyz!--.(x,z) _
+ 34.xyz!--.(x,xz) _
+ 34.xyz!--.(x,yz) _
+ 34.xyz!--.(x,xyz) _
+ 34.xyz!--.(xy,z) _
+ 34.xyz!--.(xy,xz) _
+ 34.xyz!--.(xy,yz) _
+ 34.xyz!--.(xy,xyz) _
+ 34.xyz!--.(xz,z) _
+ 34.xyz!--.(xz,xz) _
+ 34.xyz!--.(xz,yz) _
+ 34.xyz!--.(xz,xyz) _
+ 34.xyz!--.(xyz,z) _
+ 34.xyz!--.(xyz,xz) _
+ 34.xyz!--.(xyz,yz) _
+ 35.xyz!-=.(x,z) _
+ 35.xyz!-=.(x,xz) _
+ 35.xyz!-=.(x,yz) _
+ 35.xyz!-=.(x,xyz) _
+ 35.xyz!-=.(xy,z) _
+ 35.xyz!-=.(xy,xz) _
+ 35.xyz!-=.(xy,yz) _
+ 35.xyz!-=.(xy,xyz) _
+ 35.xyz!-=.(xz,z) _
+ 35.xyz!-=.(xz,xz) _
+ 35.xyz!-=.(xz,yz) _
+ 35.xyz!-=.(xz,xyz) _
+ 35.xyz!-=.(xyz,z) _
+ 35.xyz!-=.(xyz,xz) _
+ 35.xyz!-=.(xyz,yz) _
+ 36.xyz!-e.(x,z) _
+ 36.xyz!-e.(x,xz) _
+ 36.xyz!-e.(x,yz) _
+ 36.xyz!-e.(x,xyz) _
+ 36.xyz!-e.(xy,z) _
+ 36.xyz!-e.(xy,xz) _
+ 36.xyz!-e.(xy,yz) _
+ 36.xyz!-e.(xy,xyz) _
+ 36.xyz!-e.(xz,z) _
+ 36.xyz!-e.(xz,xz) _
+ 36.xyz!-e.(xz,yz) _
+ 36.xyz!-e.(xz,xyz) _
+ 36.xyz!-e.(xyz,z) _
+ 36.xyz!-e.(xyz,xz) _
+ 36.xyz!-e.(xyz,yz) _
+}
+
+foreach {n code} {
+ 00 x
+ 01 x-
+ 02 xe
+ 03 xy
+ 04 xy-
+ 05 xye
+ 06 xyee
+ 07 xye-
+ 08 xy--
+ 09 xy-=
+ 10 xyz/ee
+ 11 xyz/e-
+ 12 xyz/--
+ 13 xyz/-=
+ 14 xyz|ee
+ 15 xyz|e-
+ 16 xyz|--
+ 17 xyz|-=
+ 18 xyz+eee
+ 19 xyz+ee-
+ 20 xyz+e--
+ 21 xyz+e-=
+ 22 xyz+---
+ 23 xyz+--=
+ 24 xyz+-=_
+ 25 xyz&eee
+ 26 xyz&ee-
+ 27 xyz&e--
+ 28 xyz&e-=
+ 29 xyz&---
+ 30 xyz&--=
+ 31 xyz&-=_
+ 32 xyz!ee
+ 33 xyz!e-
+ 34 xyz!--
+ 35 xyz!-=
+ 36 xyz!-e
+} {
+ if {[string match xyz* $code]} {
+ set sets {{} x y z {x y} {x z} {y z} {x y z}}
+ set max 2
+ } elseif {[string match xy* $code]} {
+ set sets {{} x y {x y}}
+ set max 1
+ } elseif {[string match x* $code]} {
+ set sets {{} x}
+ set max 0
+ } else {
+ set sets {{}}
+ set max 4
+ }
+
+ foreach st $sets {
+ foreach fin $sets {
+ set key $n.$code.([join $st {}],[join $fin {}])
+
+ if {
+ ([join $st {}] eq [join $fin {}]) &&
+ ([join $st {}] eq [string range $code 0 $max])
+ } {
+ # If all states are both start and final the FA cannot
+ # be other than useful.
+ set expected($key) .
+ }
+
+ test fa-is-${setimpl}-useful-1.$key {is useful} {
+ grammar::fa a
+ gen $code
+ a start set $st
+ a final set $fin
+ set res [a is useful]
+ a destroy
+ set res
+ } [info exists expected($key)] ;# {}
+ }
+ }
+}
+
+
+#parray expected
+unset expected
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_next.test b/tcllib/modules/grammar_fa/tests/fa_next.test
new file mode 100644
index 0000000..749d354
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_next.test
@@ -0,0 +1,421 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_next.test,v 1.5 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test fa-next-${setimpl}-1.0 {next} {
+ grammar::fa a
+ catch {a next} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_methodnext {type selfns win self s sym args} 5]
+
+
+test fa-next-${setimpl}-1.1 {next} {
+ grammar::fa a
+ catch {a next a} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_methodnext {type selfns win self s sym args} 5]
+
+
+test fa-next-${setimpl}-1.2 {next} {
+ grammar::fa a
+ catch {a next a b c} res
+ a destroy
+ set res
+} {wrong#args: ::a next s sym ?--> s'?}
+
+
+test fa-next-${setimpl}-1.3 {next} {
+ grammar::fa a
+ catch {a next a b c d e} res
+ a destroy
+ set res
+} {wrong#args: ::a next s sym ?--> s'?}
+
+
+test fa-next-${setimpl}-1.4 {next} {
+ grammar::fa a
+ catch {a next a b} res
+ a destroy
+ set res
+} {Illegal state "a"}
+
+
+test fa-next-${setimpl}-1.5 {next} {
+ grammar::fa a
+ a state add a
+ catch {a next a b} res
+ a destroy
+ set res
+} {Illegal symbol "b"}
+
+
+test fa-next-${setimpl}-1.6 {next} {
+ grammar::fa a
+ a state add a
+ a symbol add b
+ catch {a next a b --> c} res
+ a destroy
+ set res
+} {Illegal state "c"}
+
+
+test fa-next-${setimpl}-1.7 {next} {
+ grammar::fa a
+ a state add a
+ a state add c
+ a symbol add b
+ catch {a next a b x c} res
+ a destroy
+ set res
+} {Expected -->, got "x"}
+
+
+test fa-next-${setimpl}-1.8 {next} {
+ grammar::fa a
+ a state add a c
+ a symbol add b
+ a next a b --> c
+ catch {a next a b --> c} res
+ a destroy
+ set res
+} {Transition "(a, (b)) --> c" is already known}
+
+
+test fa-next-${setimpl}-1.9 {!next} {
+ grammar::fa a
+ catch {a !next} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_method!next {type selfns win self s sym args} 5]
+
+
+test fa-next-${setimpl}-1.10 {!next} {
+ grammar::fa a
+ catch {a !next a} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_method!next {type selfns win self s sym args} 5]
+
+
+test fa-next-${setimpl}-1.11 {!next} {
+ grammar::fa a
+ catch {a !next a b c} res
+ a destroy
+ set res
+} {wrong#args: ::a !next s sym ?--> s'?}
+
+
+test fa-next-${setimpl}-1.12 {!next} {
+ grammar::fa a
+ catch {a !next a b c d e} res
+ a destroy
+ set res
+} {wrong#args: ::a !next s sym ?--> s'?}
+
+
+test fa-next-${setimpl}-1.13 {!next} {
+ grammar::fa a
+ catch {a !next a b} res
+ a destroy
+ set res
+} {Illegal state "a"}
+
+
+test fa-next-${setimpl}-1.14 {!next} {
+ grammar::fa a
+ a state add a
+ catch {a !next a b} res
+ a destroy
+ set res
+} {Illegal symbol "b"}
+
+
+test fa-next-${setimpl}-1.15 {!next} {
+ grammar::fa a
+ a state add a
+ a symbol add b
+ catch {a !next a b --> c} res
+ a destroy
+ set res
+} {Illegal state "c"}
+
+
+test fa-next-${setimpl}-1.16 {!next} {
+ grammar::fa a
+ a state add a
+ a state add c
+ a symbol add b
+ catch {a !next a b x c} res
+ a destroy
+ set res
+} {Expected -->, got "x"}
+
+
+test fa-next-${setimpl}-1.17 {nextset} {
+ grammar::fa a
+ catch {a nextset} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodnextset type selfns win self states sym"}
+
+
+test fa-next-${setimpl}-1.18 {nextset} {
+ grammar::fa a
+ catch {a nextset a} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodnextset type selfns win self states sym"}
+
+
+test fa-next-${setimpl}-1.19 {nextset} {
+ grammar::fa a
+ catch {a nextset a b c} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodnextset type selfns win self states sym"}
+
+
+test fa-next-${setimpl}-1.20 {nextset} {
+ grammar::fa a
+ catch {a nextset a b} res
+ a destroy
+ set res
+} {Illegal symbol "b"}
+
+
+test fa-next-${setimpl}-1.21 {nextset} {
+ grammar::fa a
+ a symbol add b
+ catch {a nextset a b} res
+ a destroy
+ set res
+} {Illegal state "a"}
+
+
+test fa-next-${setimpl}-1.22 {nextset} {
+ grammar::fa a
+ a symbol add b
+ a state add a
+ catch {a nextset {a c} b} res
+ a destroy
+ set res
+} {Illegal state "c"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-next-${setimpl}-2.0 {next} {
+ grammar::fa a
+ a state add a
+ a symbol add b
+ set res [a next a b]
+ a destroy
+ set res
+} {}
+
+
+test fa-next-${setimpl}-2.1 {next} {
+ grammar::fa a
+ a state add a
+ a state add c
+ a symbol add b
+ a next a b --> c
+ set res [a next a b]
+ a destroy
+ set res
+} c
+
+
+test fa-next-${setimpl}-2.2 {next} {
+ grammar::fa a
+ a state add a c d
+ a symbol add b
+ a next a b --> c
+ a next a b --> d
+ set res [lsort [a next a b]]
+ a destroy
+ set res
+} {c d}
+
+
+test fa-next-${setimpl}-2.3 {next, loop} {
+ grammar::fa a
+ a state add a
+ a symbol add @
+ a next a @ --> a
+ set res [a next a @]
+ a destroy
+ set res
+} a
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-next-${setimpl}-3.0 {!next} {
+ set res {}
+ grammar::fa a
+ a state add a
+ a symbol add b
+ a next a b --> a
+ lappend res [a next a b]
+ a !next a b --> a
+ lappend res [a next a b]
+ a destroy
+ set res
+} {a {}}
+
+
+test fa-next-${setimpl}-3.1 {!next} {
+ set res {}
+ grammar::fa a
+ a state add a
+ a symbol add b
+ a next a b --> a
+ lappend res [a next a b]
+ a !next a b
+ lappend res [a next a b]
+ a destroy
+ set res
+} {a {}}
+
+
+test fa-next-${setimpl}-3.2 {!next} {
+ set res {}
+ grammar::fa a
+ a state add a
+ a state add b
+ a symbol add b
+ a next a b --> a
+ a next a b --> b
+ lappend res [lsort [a next a b]]
+ a !next a b --> a
+ lappend res [a next a b]
+ a destroy
+ set res
+} {{a b} b}
+
+
+test fa-next-${setimpl}-3.3 {!next} {
+ set res {}
+ grammar::fa a
+ a state add a
+ a state add b
+ a symbol add b
+ a next a b --> a
+ a next a b --> b
+ lappend res [lsort [a next a b]]
+ a !next a b
+ lappend res [a next a b]
+ a destroy
+ set res
+} {{a b} {}}
+
+
+test fa-next-${setimpl}-3.4 {!next} {
+ set res {}
+ grammar::fa a
+ a state add a
+ a symbol add b
+ a !next a b
+ a destroy
+ set res
+} {}
+
+
+test fa-next-${setimpl}-3.5 {!next} {
+ set res {}
+ grammar::fa a
+ a state add a
+ a symbol add b
+ a !next a b --> a
+ a destroy
+ set res
+} {}
+
+
+test fa-next-${setimpl}-3.6 {!next, loop} {
+ grammar::fa a
+ a state add a
+ a symbol add @
+ a next a @ --> a
+ set res [a next a @]
+ a !next a @ --> a
+ a destroy
+ set res
+} a
+
+
+test fa-next-${setimpl}-3.7 {!next, loop} {
+ grammar::fa a
+ a state add a
+ a symbol add @
+ a next a @ --> a
+ set res [a next a @]
+ a !next a @
+ a destroy
+ set res
+} a
+
+
+test fa-next-${setimpl}-3.8 {!next, loop} {
+ grammar::fa a
+ a state add a
+ a symbol add @ =
+ a next a @ --> a
+ a next a = --> a
+ a !next a @ --> a
+ a !next a = --> a
+ a destroy
+} {}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-next-${setimpl}-4.0 {nextset} {
+ grammar::fa a
+ a symbol add b
+ a state add a
+ a state add c
+ set res [a nextset {a c} b]
+ a destroy
+ set res
+} {}
+
+
+test fa-next-${setimpl}-4.1 {nextset} {
+ grammar::fa a
+ a symbol add b
+ a state add a
+ a state add c
+ a next a b --> c
+ set res [a nextset {a c} b]
+ a destroy
+ set res
+} c
+
+
+test fa-next-${setimpl}-4.2 {nextset} {
+ grammar::fa a
+ a symbol add b
+ a state add a
+ a state add c
+ a next a b --> c
+ a next c b --> a
+ set res [lsort [a nextset {a c} b]]
+ a destroy
+ set res
+} {a c}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_reach.test b/tcllib/modules/grammar_fa/tests/fa_reach.test
new file mode 100644
index 0000000..21ac0d1
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_reach.test
@@ -0,0 +1,344 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_reach.test,v 1.4 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test fa-reach-${setimpl}-1.0 {reachability} {
+ grammar::fa a
+ catch {a reachable_states x} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodreachable_states type selfns win self"}
+
+
+test fa-reach-${setimpl}-1.1 {!reachability} {
+ grammar::fa a
+ catch {a unreachable_states a} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodunreachable_states type selfns win self"}
+
+
+test fa-reach-${setimpl}-1.2 {reachability} {
+ grammar::fa a
+ catch {a reachable} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodreachable type selfns win self s"}
+
+
+test fa-reach-${setimpl}-1.3 {reachability} {
+ grammar::fa a
+ catch {a reachable x} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-reach-${setimpl}-1.4 {reachability} {
+ grammar::fa a
+ catch {a reachable x y} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodreachable type selfns win self s"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-reach-${setimpl}-2.0 {reachable states, empty fa} {
+ grammar::fa a
+ set res [a reachable_states]
+ a destroy
+ set res
+} {}
+
+
+test fa-reach-${setimpl}-2.1 {reachable states, state addition, plain} {
+ grammar::fa a
+ a state add x
+ set res [a reachable_states]
+ a destroy
+ set res
+} {}
+
+test fa-reach-${setimpl}-2.2 {reachable states, state addition, final} {
+ grammar::fa a
+ a state add x
+ a final add x
+ set res [a reachable_states]
+ a destroy
+ set res
+} {}
+
+
+test fa-reach-${setimpl}-2.3 {reachable states, state addition, start} {
+ grammar::fa a
+ a state add x
+ a start add x
+ set res [a reachable_states]
+ a destroy
+ set res
+} x
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-reach-${setimpl}-3.0 {unreachable states, empty fa} {
+ grammar::fa a
+ set res [a unreachable_states]
+ a destroy
+ set res
+} {}
+
+
+test fa-reach-${setimpl}-3.1 {unreachable states, state addition, plain} {
+ grammar::fa a
+ a state add x
+ set res [a unreachable_states]
+ a destroy
+ set res
+} x
+
+test fa-reach-${setimpl}-3.2 {unreachable states, state addition, final} {
+ grammar::fa a
+ a state add x
+ a final add x
+ set res [a unreachable_states]
+ a destroy
+ set res
+} x
+
+
+test fa-reach-${setimpl}-3.3 {unreachable states, state addition, start} {
+ grammar::fa a
+ a state add x
+ a start add x
+ set res [a unreachable_states]
+ a destroy
+ set res
+} {}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+foreach {n code setup_result} {
+ 00 x {{} {} x x x {}}
+ 01 x- {{} {} x x x {}}
+ 02 xe {{} {} x x x {}}
+ 03 xy {{} {} {x y} x x y y y x {x y} {x y} {}}
+ 04 xy- {{} {} {x y} x {x y} {} y y x {x y} {x y} {}}
+ 05 xye {{} {} {x y} x {x y} {} y y x {x y} {x y} {}}
+ 06 xyee {{} {} {x y} x {x y} {} y {x y} {} {x y} {x y} {}}
+ 07 xye- {{} {} {x y} x {x y} {} y {x y} {} {x y} {x y} {}}
+ 08 xy-- {{} {} {x y} x {x y} {} y {x y} {} {x y} {x y} {}}
+ 09 xy-= {{} {} {x y} x {x y} {} y {x y} {} {x y} {x y} {}}
+ 10 xyz/ee {
+ {} {} {x y z} x {x y z} {}
+ y y {x z} z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 11 xyz/e- {
+ {} {} {x y z} x {x y z} {}
+ y y {x z} z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 12 xyz/-- {
+ {} {} {x y z} x {x y z} {}
+ y y {x z} z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 13 xyz/-= {
+ {} {} {x y z} x {x y z} {}
+ y y {x z} z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 14 xyz|ee {
+ {} {} {x y z} x {x z} y
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x z} y
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 15 xyz|e- {
+ {} {} {x y z} x {x z} y
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x z} y
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 16 xyz|-- {
+ {} {} {x y z} x {x z} y
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x z} y
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 17 xyz|-= {
+ {} {} {x y z} x {x z} y
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x z} y
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 18 xyz+eee {
+ {} {} {x y z} x {x y z} {}
+ y {x y z} {} z {x y z} {}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 19 xyz+ee- {
+ {} {} {x y z} x {x y z} {}
+ y {x y z} {} z {x y z} {}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 20 xyz+e-- {
+ {} {} {x y z} x {x y z} {}
+ y {x y z} {} z {x y z} {}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 21 xyz+e-= {
+ {} {} {x y z} x {x y z} {}
+ y {x y z} {} z {x y z} {}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 22 xyz+--- {
+ {} {} {x y z} x {x y z} {}
+ y {x y z} {} z {x y z} {}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 23 xyz+--= {
+ {} {} {x y z} x {x y z} {}
+ y {x y z} {} z {x y z} {}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 24 xyz+-=_ {
+ {} {} {x y z} x {x y z} {}
+ y {x y z} {} z {x y z} {}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 25 xyz&eee {
+ {} {} {x y z} x {x y z} {}
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 26 xyz&ee- {
+ {} {} {x y z} x {x y z} {}
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 27 xyz&e-- {
+ {} {} {x y z} x {x y z} {}
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 28 xyz&e-= {
+ {} {} {x y z} x {x y z} {}
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 29 xyz&--- {
+ {} {} {x y z} x {x y z} {}
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 30 xyz&--= {
+ {} {} {x y z} x {x y z} {}
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 31 xyz&-=_ {
+ {} {} {x y z} x {x y z} {}
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 32 xyz!ee {
+ {} {} {x y z} x {x y z} {}
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 33 xyz!e- {
+ {} {} {x y z} x {x y z} {}
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 34 xyz!-- {
+ {} {} {x y z} x {x y z} {}
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 35 xyz!-= {
+ {} {} {x y z} x {x y z} {}
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+ 36 xyz!-e {
+ {} {} {x y z} x {x y z} {}
+ y {y z} x z z {x y}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {y z} x {x y z} {x y z} {}
+ }
+} {
+ foreach {fset reachable unreach} $setup_result {
+ set key ${n}.${code}.([join $fset {}])
+ set expected {}
+ foreach x $reachable {lappend expected 1}
+ foreach x $unreach {lappend expected 0}
+
+ test fa-reach-${setimpl}-4.$key {reachable states} {
+ grammar::fa a
+ gen $code
+ a start set $fset
+ set res [lsort [a reachable_states]]
+ a destroy
+ set res
+ } $reachable ; # {}
+
+ test fa-reach-${setimpl}-5.$key {!reachable states} {
+ grammar::fa a
+ gen $code
+ a start set $fset
+ set res [lsort [a unreachable_states]]
+ a destroy
+ set res
+ } $unreach ; # {}
+
+ test fa-reach-${setimpl}-6.$key {reachability testing} {
+ grammar::fa a
+ gen $code
+ a start set $fset
+ set res {}
+ foreach x $reachable {lappend res [a reachable $x]}
+ foreach x $unreach {lappend res [a reachable $x]}
+ a destroy
+ set res
+ } $expected ; # {}
+ }
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_serial.test b/tcllib/modules/grammar_fa/tests/fa_serial.test
new file mode 100644
index 0000000..46b018f
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_serial.test
@@ -0,0 +1,221 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_serial.test,v 1.8 2007/04/12 03:43:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+if {![::tcltest::testConstraint runtotal]} {
+ ::tcltest::cleanupTests
+ return
+}
+
+# -------------------------------------------------------------------------
+
+test fa-serial-${setimpl}-1.0 {serialize, error} {
+ grammar::fa a
+ catch {a serialize a} msg
+ a destroy
+ set msg
+} {wrong # args: should be "::grammar::fa::Snit_methodserialize type selfns win self"}
+
+
+test fa-serial-${setimpl}-1.1 {deserialize, error} {
+ grammar::fa a
+ catch {a deserialize} msg
+ a destroy
+ set msg
+} {wrong # args: should be "::grammar::fa::Snit_methoddeserialize type selfns win self value"}
+
+
+test fa-serial-${setimpl}-1.2 {deserialize, error} {
+ grammar::fa a
+ catch {a deserialize a b} msg
+ a destroy
+ set msg
+} {wrong # args: should be "::grammar::fa::Snit_methoddeserialize type selfns win self value"}
+
+
+test fa-serial-${setimpl}-1.3 {assignment, error} {
+ grammar::fa a
+ catch {a =} msg
+ a destroy
+ set msg
+} {wrong # args: should be "::grammar::fa::Snit_method= type selfns win self b"}
+
+
+test fa-serial-${setimpl}-1.4 {assignment, error} {
+ grammar::fa a
+ catch {a = a b} msg
+ a destroy
+ set msg
+} {wrong # args: should be "::grammar::fa::Snit_method= type selfns win self b"}
+
+
+test fa-serial-${setimpl}-1.5 {assignment, error} {
+ grammar::fa a
+ catch {a -->} msg
+ a destroy
+ set msg
+} {wrong # args: should be "::grammar::fa::Snit_method--> type selfns win self b"}
+
+test fa-serial-${setimpl}-1.6 {assignment, error} {
+ grammar::fa a
+ catch {a --> a b} msg
+ a destroy
+ set msg
+} {wrong # args: should be "::grammar::fa::Snit_method--> type selfns win self b"}
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+foreach {n code} {
+ 00 x
+ 01 x-
+ 02 xe
+ 03 xy
+ 04 xy-
+ 05 xye
+ 06 xyee
+ 07 xye-
+ 08 xy--
+ 09 xy-=
+ 10 xyz/ee
+ 11 xyz/e-
+ 12 xyz/--
+ 13 xyz/-=
+ 14 xyz|ee
+ 15 xyz|e-
+ 16 xyz|--
+ 17 xyz|-=
+ 18 xyz+eee
+ 19 xyz+ee-
+ 20 xyz+e--
+ 21 xyz+e-=
+ 22 xyz+---
+ 23 xyz+--=
+ 24 xyz+-=_
+ 25 xyz&eee
+ 26 xyz&ee-
+ 27 xyz&e--
+ 28 xyz&e-=
+ 29 xyz&---
+ 30 xyz&--=
+ 31 xyz&-=_
+ 32 xyz!ee
+ 33 xyz!e-
+ 34 xyz!--
+ 35 xyz!-=
+ 36 xyz!-e
+} {
+ if {[string match xyz* $code]} {
+ set sets {{} x y z {x y} {x z} {y z} {x y z}}
+ } elseif {[string match xy* $code]} {
+ set sets {{} x y {x y}}
+ } elseif {[string match x* $code]} {
+ set sets {{} x}
+ } else {
+ set sets {{}}
+ }
+
+ foreach st $sets {
+ foreach fin $sets {
+ set key $n.$code.([join $st {}],[join $fin {}])
+
+ test fa-serial-${setimpl}-2.$key {serialize} {
+ grammar::fa a
+ gen $code
+ foreach s $st {if {[a state exists $s]} {a start add $s}}
+ foreach s $fin {if {[a state exists $s]} {a final add $s}}
+ set res [validate_serial [a serialize] a]
+ a destroy
+ set res
+ } ok
+
+ test fa-serial-${setimpl}-3.$key {deserialize} {
+ grammar::fa a
+ gen $code
+ foreach s $st {if {[a state exists $s]} {a start add $s}}
+ foreach s $fin {if {[a state exists $s]} {a final add $s}}
+
+ grammar::fa b
+ b deserialize [a serialize]
+ set res [validate_serial [b serialize] a]
+ lappend res [validate_serial [a serialize] b]
+
+ a destroy
+ b destroy
+ set res
+ } {ok ok}
+
+ test fa-serial-${setimpl}-4.$key {assignment} {
+ grammar::fa a
+ gen $code
+ foreach s $st {if {[a state exists $s]} {a start add $s}}
+ foreach s $fin {if {[a state exists $s]} {a final add $s}}
+
+ grammar::fa b
+ b = a
+ set res [validate_serial [b serialize] a]
+ lappend res [validate_serial [a serialize] b]
+
+ a destroy
+ b destroy
+ set res
+ } {ok ok}
+
+ test fa-serial-${setimpl}-5.$key {reverse assignment} {
+ grammar::fa a
+ gen $code
+ foreach s $st {if {[a state exists $s]} {a start add $s}}
+ foreach s $fin {if {[a state exists $s]} {a final add $s}}
+
+ grammar::fa b
+ a --> b
+ set res [validate_serial [b serialize] a]
+ lappend res [validate_serial [a serialize] b]
+
+ a destroy
+ b destroy
+ set res
+ } {ok ok}
+
+ foreach op {= := <-- as} {
+ test fa-serial-${setimpl}-6.$key.$op {construction from fa} {
+ grammar::fa a
+ gen $code
+ foreach s $st {if {[a state exists $s]} {a start add $s}}
+ foreach s $fin {if {[a state exists $s]} {a final add $s}}
+
+ grammar::fa b $op a
+ set res [validate_serial [b serialize] a]
+ lappend res [validate_serial [a serialize] b]
+
+ a destroy
+ b destroy
+ set res
+ } {ok ok}
+ }
+
+ test fa-serial-${setimpl}-7.$key {construction from fa} {
+ grammar::fa a
+ gen $code
+ foreach s $st {if {[a state exists $s]} {a start add $s}}
+ foreach s $fin {if {[a state exists $s]} {a final add $s}}
+
+ grammar::fa b deserialize [a serialize]
+ set res [validate_serial [b serialize] a]
+ lappend res [validate_serial [a serialize] b]
+
+ a destroy
+ b destroy
+ set res
+ } {ok ok}
+ }
+ }
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_start.test b/tcllib/modules/grammar_fa/tests/fa_start.test
new file mode 100644
index 0000000..bc12f1c
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_start.test
@@ -0,0 +1,386 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_start.test,v 1.6 2009/10/27 21:17:23 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test fa-start-${setimpl}-1.0 {start states, error} {
+ grammar::fa a
+ catch {a startstates x} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodstartstates type selfns win self"}
+
+
+test fa-start-${setimpl}-1.1 {start query, error} {
+ grammar::fa a
+ catch {a start?} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodstart? type selfns win self s"}
+
+
+test fa-start-${setimpl}-1.2 {start query, error} {
+ grammar::fa a
+ catch {a start? x y} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodstart? type selfns win self s"}
+
+
+test fa-start-${setimpl}-1.3 {start query, error} {
+ grammar::fa a
+ catch {a start? x} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-start-${setimpl}-1.4 {start query set, error} {
+ grammar::fa a
+ catch {a start?set} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodstart?set type selfns win self states"}
+
+
+test fa-start-${setimpl}-1.5 {start query set, error} {
+ grammar::fa a
+ catch {a start?set x y} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodstart?set type selfns win self states"}
+
+
+test fa-start-${setimpl}-1.6 {start query set, error} {
+ grammar::fa a
+ catch {a start?set x} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-start-${setimpl}-1.7 {start query set, error} {
+ grammar::fa a
+ a state add x
+ catch {a start?set {x y}} res
+ a destroy
+ set res
+} {Illegal state "y"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-start-${setimpl}-2.0 {start, error} {
+ grammar::fa a
+ catch {a start} res
+ a destroy
+ set res
+} {wrong number args: should be "::a start method args"}
+# [tcltest::wrongNumArgs ::grammar::fa::Snit_methodstart {type selfns win self cmd args} 5]
+
+
+test fa-start-${setimpl}-2.1 {start, error} {
+ grammar::fa a
+ catch {a start foo} res
+ a destroy
+ set res
+} {"::a start foo" is not defined}
+
+
+test fa-start-${setimpl}-2.2 {start, error} {
+ grammar::fa a
+ catch {a start add} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_hmethodstart_add {type selfns win self state args} 5]
+
+test fa-start-${setimpl}-2.3 {start, error} {
+ grammar::fa a
+ catch {a start add x y} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-start-${setimpl}-2.4 {start, error} {
+ grammar::fa a
+ catch {a start add x} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-start-${setimpl}-2.5 {start states} {
+ grammar::fa a
+ catch {a start remove} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_hmethodstart_remove {type selfns win self state args} 5]
+
+
+test fa-start-${setimpl}-2.6 {start states} {
+ grammar::fa a
+ catch {a start remove x y} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-start-${setimpl}-2.7 {start states} {
+ grammar::fa a
+ catch {a start remove x} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-start-${setimpl}-2.8 {start states} {
+ grammar::fa a
+ catch {a start set} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_hmethodstart_set {type selfns win self states} 4]
+
+
+test fa-start-${setimpl}-2.9 {start states} {
+ grammar::fa a
+ a state add x
+ catch {a start set {x y}} res
+ a destroy
+ set res
+} {Illegal state "y"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-start-${setimpl}-3.0 {start states, empty fa} {
+ grammar::fa a
+ set res [a startstates]
+ a destroy
+ set res
+} {}
+
+
+test fa-start-${setimpl}-3.1 {start states, plain state} {
+ grammar::fa a
+ a state add x
+ set res [a startstates]
+ a destroy
+ set res
+} {}
+
+
+test fa-start-${setimpl}-3.2 {start states, state addition} {
+ grammar::fa a
+ a state add x
+ a start add x
+ set res [a startstates]
+ a destroy
+ set res
+} x
+
+
+test fa-start-${setimpl}-3.3 {start states, state addition} {
+ grammar::fa a
+ a state add x y
+ a start add x y
+ set res [lsort [a startstates]]
+ a destroy
+ set res
+} {x y}
+
+
+test fa-start-${setimpl}-3.4 {start states, state addition, and remova;} {
+ grammar::fa a
+ a state add x y
+ a start add x y
+ set res {}
+ lappend res [a startstates]
+ a start remove y
+ lappend res [a startstates]
+ a start remove x
+ lappend res [a startstates]
+ a destroy
+ set res
+} {{x y} x {}}
+
+
+test fa-start-${setimpl}-3.5 {start states, state addition, and remova;} {
+ grammar::fa a
+ a state add x y
+ a start add x y
+ set res {}
+ lappend res [a startstates]
+ a state delete y
+ lappend res [a startstates]
+ a state delete x
+ lappend res [a startstates]
+ a destroy
+ set res
+} {{x y} x {}}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-start-${setimpl}-4.0 {start?} {
+ grammar::fa a
+ a state add x
+ set res [a start? x]
+ a destroy
+ set res
+} 0
+
+
+test fa-start-${setimpl}-4.1 {start?} {
+ grammar::fa a
+ a state add x
+ a start add x
+ set res [a start? x]
+ a destroy
+ set res
+} 1
+
+
+test fa-start-${setimpl}-4.2 {start?} {
+ grammar::fa a
+ a state add x
+ a start add x
+ set res [a start? x]
+ a start remove x
+ lappend res [a start? x]
+ a destroy
+ set res
+} {1 0}
+
+
+test fa-start-${setimpl}-4.3 {start?} {
+ grammar::fa a
+ a state add x
+ a start add x
+ set res [a start? x]
+ a state delete x
+ catch {a start? x} msg
+ lappend res $msg
+ a destroy
+ set res
+} {1 {Illegal state "x"}}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-start-${setimpl}-5.0 {start?set} {
+ grammar::fa a
+ a state add x
+ set res [a start?set x]
+ a destroy
+ set res
+} 0
+
+
+test fa-start-${setimpl}-5.1 {start?set} {
+ grammar::fa a
+ a state add x
+ a start add x
+ set res [a start?set x]
+ a destroy
+ set res
+} 1
+
+
+test fa-start-${setimpl}-5.2 {start?set} {
+ grammar::fa a
+ set res {}
+ a state add x
+ a start add x
+ lappend res [a start?set x]
+ a start remove x
+ lappend res [a start?set x]
+ a destroy
+ set res
+} {1 0}
+
+
+test fa-start-${setimpl}-5.3 {start?set} {
+ grammar::fa a
+ set res {}
+ a state add x y
+ a start add x
+ lappend res [a start?set y]
+ lappend res [a start?set {x y}]
+ a destroy
+ set res
+} {0 1}
+
+
+test fa-start-${setimpl}-5.4 {start?set} {
+ grammar::fa a
+ a state add x
+ set res {}
+ lappend res [a start? x]
+ lappend res [a start remove x]
+ lappend res [a start? x]
+ a destroy
+ set res
+} {0 {} 0}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+test fa-start-${setimpl}-6.0 {start clear} {
+ grammar::fa a
+ a state add x
+ a start add x
+ set res {}
+ lappend res [a startstates]
+ a start clear
+ lappend res [a startstates]
+ a destroy
+ set res
+} {x {}}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+test fa-start-${setimpl}-7.0 {start set} {
+ grammar::fa a
+ a state add x
+ a start set x
+ set res [a startstates]
+ a destroy
+ set res
+} x
+
+
+test fa-start-${setimpl}-7.1 {start set} {
+ grammar::fa a
+ a state add x y
+ a start set {x y}
+ set res [lsort [a startstates]]
+ a destroy
+ set res
+} {x y}
+
+
+test fa-start-${setimpl}-7.2 {start set} {
+ grammar::fa a
+ set res {}
+ a state add x y z
+ a start add z
+ lappend res [a startstates]
+ a start set {x y}
+ lappend res [lsort [a startstates]]
+ a destroy
+ set res
+} {z {x y}}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_state.test b/tcllib/modules/grammar_fa/tests/fa_state.test
new file mode 100644
index 0000000..d752b72
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_state.test
@@ -0,0 +1,304 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_state.test,v 1.8 2009/10/27 21:17:23 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test fa-state-${setimpl}-1.0 {state, error} {
+ grammar::fa a
+ catch {a state} res
+ a destroy
+ set res
+} {wrong number args: should be "::a state method args"}
+# [tcltest::wrongNumArgs {::a state method} {args} 0]
+
+
+test fa-state-${setimpl}-1.1 {state, error} {
+ grammar::fa a
+ catch {a state add} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_hmethodstate_add {type selfns win self s args} 4]
+
+
+test fa-state-${setimpl}-1.2 {state, error} {
+ grammar::fa a
+ a state add x
+ catch {a state foo x} res
+ a destroy
+ set res
+} {"::a state foo" is not defined}
+
+
+test fa-state-${setimpl}-1.3 {state, error} {
+ grammar::fa a
+ a state add x
+ catch {a state add x} res
+ a destroy
+ set res
+} {State "x" is already known}
+
+
+test fa-state-${setimpl}-1.4 {state, error} {
+ grammar::fa a
+ catch {a state exists} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_hmethodstate_exists {type selfns win self s} 4]
+
+
+test fa-state-${setimpl}-1.5 {state, error} {
+ grammar::fa a
+ catch {a state exists a b} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_hmethodstate_exists type selfns win self s"}
+
+
+test fa-state-${setimpl}-1.6 {state, error} {
+ grammar::fa a
+ catch {a state delete} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_hmethodstate_delete {type selfns win self s args} 4]
+
+
+test fa-state-${setimpl}-1.7 {state, error} {
+ grammar::fa a
+ catch {a state delete x} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-state-${setimpl}-1.8 {state, error} {
+ grammar::fa a
+ catch {a state rename} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_hmethodstate_rename {type selfns win self s snew} 0]
+
+
+test fa-state-${setimpl}-1.9 {state, error} {
+ grammar::fa a
+ catch {a state rename foo} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_hmethodstate_rename {type selfns win self s snew} 1]
+
+
+test fa-state-${setimpl}-1.10 {state, error} {
+ grammar::fa a
+ catch {a state rename x y} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-state-${setimpl}-1.11 {state, error} {
+ grammar::fa a
+ a state add x y
+ catch {a state rename x y} res
+ a destroy
+ set res
+} {State "y" is already known}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-state-${setimpl}-2.0 {state add} {
+ grammar::fa a
+ set res [a state add x]
+ a destroy
+ set res
+} {}
+
+
+test fa-state-${setimpl}-2.1 {state add, variadic} {
+ grammar::fa a
+ set res [a state add x y]
+ a destroy
+ set res
+} {}
+
+
+test fa-state-${setimpl}-2.2 {state add / states / exists} {
+ grammar::fa a
+ a state add x
+ set res [a states]
+ lappend res [a state exists x]
+ lappend res [a state exists y]
+ a destroy
+ set res
+} {x 1 0}
+
+
+test fa-state-${setimpl}-2.3 {state add / states / exists} {
+ grammar::fa a
+ a state add x y
+ set res {}
+ lappend res [lsort [a states]]
+ lappend res [a state exists x]
+ lappend res [a state exists y]
+ a destroy
+ set res
+} {{x y} 1 1}
+
+
+test fa-state-${setimpl}-2.4 {state add, basic properties} {
+ grammar::fa a
+ a state add x
+ set res {}
+ lappend res [a final? x]
+ lappend res [a start? x]
+ lappend res [a symbols@ x]
+ a destroy
+ set res
+} {0 0 {}}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+test fa-state-${setimpl}-3.0 {state delete} {
+ grammar::fa a
+ a state add x
+ set res [a states]
+ lappend res [a state exists x]
+ a state delete x
+ lappend res [a states]
+ lappend res [a state exists x]
+ a destroy
+ set res
+} {x 1 {} 0}
+
+test fa-state-${setimpl}-3.1 {state delete, variadic} {
+ grammar::fa a
+ a state add x y
+ set res {}
+ lappend res [lsort [a states]]
+ lappend res [a state exists x]
+ lappend res [a state exists y]
+ a state delete x y
+ lappend res [a states]
+ lappend res [a state exists x]
+ lappend res [a state exists y]
+ a destroy
+ set res
+} {{x y} 1 1 {} 0 0}
+
+test fa-state-${setimpl}-3.2 {state delete, loop} {
+ grammar::fa a
+ a state add a
+ a symbol add @
+ a next a @ --> a
+ a state delete a
+ a destroy
+} {}
+
+test fa-state-${setimpl}-3.3 {state delete, inbound transition} {
+ grammar::fa a
+ gen xyz!-=
+ set res [a next x @]
+ a state delete y
+ lappend res [a next x @]
+ a destroy
+ set res
+} {y {}}
+
+
+test fa-state-${setimpl}-3.4 {state delete, outbound transition} {
+ grammar::fa a
+ gen xy-
+ a state delete x
+ a state delete y
+ a symbol delete @
+ a destroy
+ set res {}
+} {}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-state-${setimpl}-4.0 {state, exists} {
+ grammar::fa a
+ set res [a state exists x]
+ a destroy
+ set res
+} 0
+
+
+test fa-state-${setimpl}-4.1 {state, exists} {
+ grammar::fa a
+ a state add x
+ set res [a state exists x]
+ a destroy
+ set res
+} 1
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-state-${setimpl}-5.4 {state rename} {
+ grammar::fa a
+ a state add x y
+ a state rename x z
+ set res [a serialize]
+ a destroy
+ set res
+} {grammar::fa {} {z {0 0 {}} y {0 0 {}}}}
+
+
+test fa-state-${setimpl}-5.5 {state rename} {
+ grammar::fa a
+ a state add x y
+ a state rename y z
+ set res [a serialize]
+ a destroy
+ set res
+} {grammar::fa {} {x {0 0 {}} z {0 0 {}}}}
+
+
+test fa-state-${setimpl}-5.6 {state rename} {
+ grammar::fa a
+ a state add x y
+ a symbol add @
+ a next x @ --> y
+ a state rename x z
+ set res [a serialize]
+ a destroy
+ set res
+} {grammar::fa @ {z {0 0 {@ y}} y {0 0 {}}}}
+
+
+test fa-state-${setimpl}-5.7 {state rename} {
+ grammar::fa a
+ a state add x y
+ a symbol add @
+ a next x @ --> y
+ a state rename y z
+ set res [a serialize]
+ a destroy
+ set res
+} {grammar::fa @ {x {0 0 {@ z}} z {0 0 {}}}}
+
+
+test fa-state-${setimpl}-6.0 {state rename with loop, SF bug 2595296} {
+ grammar::fa a
+ a state add x
+ a symbol add @
+ a next x @ --> x
+ a state rename x y
+ set res [a serialize]
+ a destroy
+ set res
+} {grammar::fa @ {y {0 0 {@ y}}}}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_states.test b/tcllib/modules/grammar_fa/tests/fa_states.test
new file mode 100644
index 0000000..788993c
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_states.test
@@ -0,0 +1,76 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_states.test,v 1.4 2007/04/12 03:43:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test fa-states-${setimpl}-1.0 {states, argument errors} {
+ grammar::fa a
+ catch {a states x} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodstates type selfns win self"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-states-${setimpl}-2.0 {states, empty fa} {
+ grammar::fa a
+ set res [a states]
+ a destroy
+ set res
+} {}
+
+test fa-states-${setimpl}-2.1 {states, state addition} {
+ grammar::fa a
+ a state add x
+ set res [a states]
+ a destroy
+ set res
+} x
+
+test fa-states-${setimpl}-2.2 {states, state addition} {
+ grammar::fa a
+ a state add x y
+ set res [lsort [a states]]
+ a destroy
+ set res
+} {x y}
+
+
+test fa-states-${setimpl}-2.3 {states, state addition and removal} {
+ grammar::fa a
+ a state add x y
+ a state delete x
+ set res [a states]
+ a destroy
+ set res
+} y
+
+
+test fa-states-${setimpl}-2.4 {states, state addition and removal} {
+ grammar::fa a
+ a state add x y
+ a state delete y
+ set res [a states]
+ a destroy
+ set res
+} x
+
+
+test fa-states-${setimpl}-2.5 {states, state addition and removal} {
+ grammar::fa a
+ a state add x y
+ a state delete x y
+ set res [a states]
+ a destroy
+ set res
+} {}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_symbol.test b/tcllib/modules/grammar_fa/tests/fa_symbol.test
new file mode 100644
index 0000000..673baa5
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_symbol.test
@@ -0,0 +1,254 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_symbol.test,v 1.7 2009/10/27 21:17:23 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test fa-symbol-${setimpl}-1.0 {symbol, error} {
+ grammar::fa a
+ catch {a symbol} res
+ a destroy
+ set res
+} {wrong number args: should be "::a symbol method args"}
+# [tcltest::wrongNumArgs {::a symbol method} {sym args} 0]
+
+
+test fa-symbol-${setimpl}-1.1 {symbol, error} {
+ grammar::fa a
+ catch {a symbol foo @} res
+ a destroy
+ set res
+} {"::a symbol foo" is not defined}
+
+
+test fa-symbol-${setimpl}-1.2 {symbol, error} {
+ grammar::fa a
+ catch {a symbol add} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_hmethodsymbol_add {type selfns win self sym args} 4]
+
+
+test fa-symbol-${setimpl}-1.3 {symbol, error} {
+ grammar::fa a
+ a symbol add x
+ catch {a symbol add x} res
+ a destroy
+ set res
+} {Symbol "x" is already known}
+
+
+test fa-symbol-${setimpl}-1.4 {symbol, error} {
+ grammar::fa a
+ catch {a symbol add ""} res
+ a destroy
+ set res
+} {Cannot add illegal empty symbol ""}
+
+
+test fa-symbol-${setimpl}-1.5 {symbol, error} {
+ grammar::fa a
+ catch {a symbol delete} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_hmethodsymbol_delete {type selfns win self sym args} 4]
+
+
+test fa-symbol-${setimpl}-1.6 {symbol, error} {
+ grammar::fa a
+ catch {a symbol delete @} res
+ a destroy
+ set res
+} {Illegal symbol "@"}
+
+
+test fa-symbol-${setimpl}-1.7 {symbol, error} {
+ grammar::fa a
+ catch {a symbol exists} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_hmethodsymbol_exists {type selfns win self sym} 4]
+
+
+test fa-symbol-${setimpl}-1.8 {symbol, error} {
+ grammar::fa a
+ catch {a symbol exists a b} res
+ a destroy
+ set res
+} [tcltest::tooManyArgs ::grammar::fa::Snit_hmethodsymbol_exists {type selfns win self sym}]
+
+
+test fa-symbol-${setimpl}-1.9 {symbol, error} {
+ grammar::fa a
+ catch {a symbol rename} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_hmethodsymbol_rename {type selfns win self sym newsym} 4]
+
+
+test fa-symbol-${setimpl}-1.10 {symbol, error} {
+ grammar::fa a
+ catch {a symbol rename foo} res
+ a destroy
+ set res
+} [tcltest::wrongNumArgs ::grammar::fa::Snit_hmethodsymbol_rename {type selfns win self sym newsym} 5]
+
+
+test fa-symbol-${setimpl}-1.11 {symbol, error} {
+ grammar::fa a
+ catch {a symbol rename foo bar snarf} res
+ a destroy
+ set res
+} [tcltest::tooManyArgs ::grammar::fa::Snit_hmethodsymbol_rename {type selfns win self sym newsym}]
+
+
+test fa-symbol-${setimpl}-1.12 {symbol, error} {
+ grammar::fa a
+ catch {a symbol rename x y} res
+ a destroy
+ set res
+} {Illegal symbol "x"}
+
+
+test fa-symbol-${setimpl}-1.13 {symbol, error} {
+ grammar::fa a
+ catch {a symbol rename "" y} res
+ a destroy
+ set res
+} {Illegal symbol ""}
+
+
+test fa-symbol-${setimpl}-1.14 {symbol, error} {
+ grammar::fa a
+ a symbol add x y
+ catch {a symbol rename x y} res
+ a destroy
+ set res
+} {Symbol "y" is already known}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-symbol-${setimpl}-2.0 {symbol add} {
+ grammar::fa a
+ set res {}
+ lappend res [a symbol add x y]
+ lappend res [lsort [a symbols]]
+ a destroy
+ set res
+} {{} {x y}}
+
+
+test fa-symbol-${setimpl}-2.1 {symbol add} {
+ grammar::fa a
+ a symbol add x
+ set res [a symbols]
+ a destroy
+ set res
+} x
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-symbol-${setimpl}-3.0 {symbol delete} {
+ grammar::fa a
+ a symbol add x
+ set res [a symbols]
+ lappend res [a symbol exists x]
+ a symbol delete x
+ lappend res [a symbols]
+ lappend res [a symbol exists x]
+ a destroy
+ set res
+} {x 1 {} 0}
+
+
+test fa-symbol-${setimpl}-3.1 {symbol delete, transitions} {
+ grammar::fa a
+ a state add x y
+ a symbol add @
+ a next x @ --> y
+
+ set res [a symbols]
+ lappend res [a symbol exists @]
+ a symbol delete @
+ lappend res [a symbols]
+ lappend res [a symbol exists @]
+ lappend res [validate_serial {grammar::fa {} {x {0 0 {}} y {0 0 {}}}} a]
+ a destroy
+ set res
+} {@ 1 {} 0 ok}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-symbol-${setimpl}-4.0 {symbol exists} {
+ grammar::fa a
+ set res [a symbol exists x]
+ a destroy
+ set res
+} 0
+
+
+test fa-symbol-${setimpl}-4.1 {symbol exists} {
+ grammar::fa a
+ a symbol add x
+ set res [a symbol exists x]
+ a destroy
+ set res
+} 1
+
+
+test fa-symbol-${setimpl}-4.2 {symbol exists} {
+ grammar::fa a
+ a symbol add x
+ set res [a symbol exists x]
+ a symbol delete x
+ lappend res [a symbol exists x]
+ a destroy
+ set res
+} {1 0}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+test fa-symbol-${setimpl}-5.0 {symbol rename} {
+ grammar::fa a
+ a symbol add x y
+ a symbol rename x z
+ set res [validate_serial {grammar::fa {y z} {}} a]
+ a destroy
+ set res
+} ok
+
+
+test fa-symbol-${setimpl}-5.1 {symbol rename} {
+ grammar::fa a
+ a symbol add x y
+ a symbol rename y z
+ set res [validate_serial {grammar::fa {x z} {}} a]
+ a destroy
+ set res
+} ok
+
+
+test fa-symbol-${setimpl}-5.2 {symbol rename} {
+ grammar::fa a
+ a state add x y
+ a symbol add @
+ a next x @ --> y
+ a symbol rename @ =
+ set res [validate_serial {grammar::fa = {x {0 0 {= y}} y {0 0 {}}}} a]
+ a destroy
+ set res
+} ok
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_symbols.test b/tcllib/modules/grammar_fa/tests/fa_symbols.test
new file mode 100644
index 0000000..06054b4
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_symbols.test
@@ -0,0 +1,81 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_symbols.test,v 1.4 2007/04/12 03:43:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test fa-symbols-${setimpl}-1.0 {symbols, argument errors} {
+ grammar::fa a
+ catch {a symbols x} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodsymbols type selfns win self"}
+
+
+test fa-symbols-${setimpl}-1.1 {symbol mgmt} {
+ grammar::fa a
+ catch {a symbols x y} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodsymbols type selfns win self"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-symbols-${setimpl}-2.0 {symbols, empty fa} {
+ grammar::fa a
+ set res [a symbols]
+ a destroy
+ set res
+} {}
+
+test fa-symbols-${setimpl}-2.1 {symbols, symbol addition} {
+ grammar::fa a
+ a symbol add x
+ set res [a symbols]
+ a destroy
+ set res
+} x
+
+test fa-symbols-${setimpl}-2.2 {symbols, symbol addition} {
+ grammar::fa a
+ a symbol add x y
+ set res [lsort [a symbols]]
+ a destroy
+ set res
+} {x y}
+
+test fa-symbols-${setimpl}-2.3 {symbols, symbol addition and removal} {
+ grammar::fa a
+ a symbol add x y
+ a symbol delete x
+ set res [a symbols]
+ a destroy
+ set res
+} y
+
+test fa-symbols-${setimpl}-2.4 {symbols, symbol addition and removal} {
+ grammar::fa a
+ a symbol add x y
+ a symbol delete y
+ set res [a symbols]
+ a destroy
+ set res
+} x
+
+test fa-symbols-${setimpl}-2.5 {symbols, symbol addition and removal} {
+ grammar::fa a
+ a symbol add x y
+ a symbol delete x y
+ set res [a symbols]
+ a destroy
+ set res
+} {}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_symbols_at.test b/tcllib/modules/grammar_fa/tests/fa_symbols_at.test
new file mode 100644
index 0000000..0a9057f
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_symbols_at.test
@@ -0,0 +1,138 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_symbols_at.test,v 1.6 2007/08/14 21:42:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test fa-symbols-${setimpl}-at-1.0 {symbols@, error} {
+ grammar::fa a
+ catch {a symbols@} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodsymbols@ type selfns win self s ?t?"}
+
+
+test fa-symbols-${setimpl}-at-1.1 {symbols@, error} {
+ grammar::fa a
+ catch {a symbols@ x} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-symbols-${setimpl}-at-1.2 {symbols@, error} {
+ grammar::fa a
+ catch {a symbols@ x y z} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodsymbols@ type selfns win self s ?t?"}
+
+
+test fa-symbols-${setimpl}-at-1.3 {symbols@set, error} {
+ grammar::fa a
+ catch {a symbols@set} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodsymbols@set type selfns win self states"}
+
+
+test fa-symbols-${setimpl}-at-1.4 {symbols@set, error} {
+ grammar::fa a
+ catch {a symbols@set x y} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodsymbols@set type selfns win self states"}
+
+
+test fa-symbols-${setimpl}-at-1.5 {symbols@set, error} {
+ grammar::fa a
+ catch {a symbols@set x} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-symbols-${setimpl}-at-1.6 {symbols@set, error} {
+ grammar::fa a
+ a state add y
+ catch {a symbols@set {y x}} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+foreach {n code setup_result} {
+ 00 x {x {}}
+ 01 x- {x @}
+ 02 xe {x {{}}}
+ 03 xy {x {} y {}}
+ 04 xy- {x @ y {}}
+ 05 xye {x {{}} y {}}
+ 06 xyee {x {{}} y {{}}}
+ 07 xye- {x {{}} y @}
+ 08 xy-- {x @ y @}
+ 09 xy-= {x @ y =}
+ 10 xyz/ee {x {{}} y {} z {}}
+ 11 xyz/e- {x {{} @} y {} z {}}
+ 12 xyz/-- {x @ y {} z {}}
+ 13 xyz/-= {x {= @} y {} z {}}
+ 14 xyz|ee {x {{}} y {{}} z {}}
+ 15 xyz|e- {x @ y {{}} z {}}
+ 16 xyz|-- {x @ y @ z {}}
+ 17 xyz|-= {x @ y = z {}}
+ 18 xyz+eee {x {{}} y {{}} z {{}}}
+ 19 xyz+ee- {x {{}} y {{}} z @}
+ 20 xyz+e-- {x {{}} y @ z @}
+ 21 xyz+e-= {x {{}} y @ z =}
+ 22 xyz+--- {x @ y @ z @}
+ 23 xyz+--= {x @ y @ z =}
+ 24 xyz+-=_ {x @ y = z %}
+ 25 xyz&eee {x {{}} y {{}} z {}}
+ 26 xyz&ee- {x {{}} y @ z {}}
+ 27 xyz&e-- {x {{} @} y @ z {}}
+ 28 xyz&e-= {x {{} @} y = z {}}
+ 29 xyz&--- {x @ y @ z {}}
+ 30 xyz&--= {x @ y = z {}}
+ 31 xyz&-=_ {x {= @} y % z {}}
+ 32 xyz!ee {x {{}} y {{}} z {}}
+ 33 xyz!e- {x {{}} y @ z {}}
+ 34 xyz!-- {x @ y @ z {}}
+ 35 xyz!-= {x @ y = z {}}
+ 36 xyz!-e {x @ y {{}} z {}}
+} {
+ foreach {state expected} $setup_result {
+ set key ${n}.$code.$state
+
+ test fa-symbols-${setimpl}-at-2.$key {symbols@} {
+ grammar::fa a
+ gen $code
+ set res [lsort [a symbols@ $state]]
+ a destroy
+ set res
+ } $expected ; # {}
+ }
+}
+
+foreach {n code setup_result} {
+} {
+ foreach {states expected} $setup_result {
+ set key ${n}.$code.[join $states {}]
+
+ test fa-symbols-${setimpl}-at-3.$key {symbols@set} {
+ grammar::fa a
+ gen $code
+ set res [lsort [a symbols@set $states]]
+ a destroy
+ set res
+ } $expected ; # {}
+ }
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/fa_useful.test b/tcllib/modules/grammar_fa/tests/fa_useful.test
new file mode 100644
index 0000000..131740a
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/fa_useful.test
@@ -0,0 +1,344 @@
+# -*- tcl -*-
+# finite_automaton.test: tests for the grammar::fa container.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: fa_useful.test,v 1.4 2007/04/12 03:43:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test fa-useful-${setimpl}-1.0 {usefulness} {
+ grammar::fa a
+ catch {a useful_states x} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methoduseful_states type selfns win self"}
+
+
+test fa-useful-${setimpl}-1.1 {!usefulness} {
+ grammar::fa a
+ catch {a unuseful_states a} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methodunuseful_states type selfns win self"}
+
+
+test fa-useful-${setimpl}-1.2 {usefulness} {
+ grammar::fa a
+ catch {a useful} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methoduseful type selfns win self s"}
+
+
+test fa-useful-${setimpl}-1.3 {usefulness} {
+ grammar::fa a
+ catch {a useful x} res
+ a destroy
+ set res
+} {Illegal state "x"}
+
+
+test fa-useful-${setimpl}-1.4 {usefulness} {
+ grammar::fa a
+ catch {a useful x y} res
+ a destroy
+ set res
+} {wrong # args: should be "::grammar::fa::Snit_methoduseful type selfns win self s"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-useful-${setimpl}-2.0 {useful states, empty fa} {
+ grammar::fa a
+ set res [a useful_states]
+ a destroy
+ set res
+} {}
+
+
+test fa-useful-${setimpl}-2.1 {useful states, state addition, plain} {
+ grammar::fa a
+ a state add x
+ set res [a useful_states]
+ a destroy
+ set res
+} {}
+
+test fa-useful-${setimpl}-2.2 {useful states, state addition, final} {
+ grammar::fa a
+ a state add x
+ a final add x
+ set res [a useful_states]
+ a destroy
+ set res
+} x
+
+
+test fa-useful-${setimpl}-2.3 {useful states, state addition, start} {
+ grammar::fa a
+ a state add x
+ a start add x
+ set res [a useful_states]
+ a destroy
+ set res
+} {}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+test fa-useful-${setimpl}-3.0 {unuseful states, empty fa} {
+ grammar::fa a
+ set res [a unuseful_states]
+ a destroy
+ set res
+} {}
+
+
+test fa-useful-${setimpl}-3.1 {unuseful states, state addition, plain} {
+ grammar::fa a
+ a state add x
+ set res [a unuseful_states]
+ a destroy
+ set res
+} x
+
+test fa-useful-${setimpl}-3.2 {unuseful states, state addition, final} {
+ grammar::fa a
+ a state add x
+ a final add x
+ set res [a unuseful_states]
+ a destroy
+ set res
+} {}
+
+
+test fa-useful-${setimpl}-3.3 {unuseful states, state addition, start} {
+ grammar::fa a
+ a state add x
+ a start add x
+ set res [a unuseful_states]
+ a destroy
+ set res
+} x
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+foreach {n code setup_result} {
+ 00 x {{} {} x x x {}}
+ 01 x- {{} {} x x x {}}
+ 02 xe {{} {} x x x {}}
+ 03 xy {{} {} {x y} x x y y y x {x y} {x y} {}}
+ 04 xy- {{} {} {x y} x x y y {x y} {} {x y} {x y} {}}
+ 05 xye {{} {} {x y} x x y y {x y} {} {x y} {x y} {}}
+ 06 xyee {{} {} {x y} x {x y} {} y {x y} {} {x y} {x y} {}}
+ 07 xye- {{} {} {x y} x {x y} {} y {x y} {} {x y} {x y} {}}
+ 08 xy-- {{} {} {x y} x {x y} {} y {x y} {} {x y} {x y} {}}
+ 09 xy-= {{} {} {x y} x {x y} {} y {x y} {} {x y} {x y} {}}
+ 10 xyz/ee {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x z} y
+ {x y} {x y} z {x z} {x z} y
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 11 xyz/e- {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x z} y
+ {x y} {x y} z {x z} {x z} y
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 12 xyz/-- {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x z} y
+ {x y} {x y} z {x z} {x z} y
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 13 xyz/-= {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x z} y
+ {x y} {x y} z {x z} {x z} y
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 14 xyz|ee {
+ {} {} {x y z} x x {y z}
+ y y {x z} z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 15 xyz|e- {
+ {} {} {x y z} x x {y z}
+ y y {x z} z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 16 xyz|-- {
+ {} {} {x y z} x x {y z}
+ y y {x z} z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 17 xyz|-= {
+ {} {} {x y z} x x {y z}
+ y y {x z} z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 18 xyz+eee {
+ {} {} {x y z} x {x y z} {}
+ y {x y z} {} z {x y z} {}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 19 xyz+ee- {
+ {} {} {x y z} x {x y z} {}
+ y {x y z} {} z {x y z} {}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 20 xyz+e-- {
+ {} {} {x y z} x {x y z} {}
+ y {x y z} {} z {x y z} {}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 21 xyz+e-= {
+ {} {} {x y z} x {x y z} {}
+ y {x y z} {} z {x y z} {}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 22 xyz+--- {
+ {} {} {x y z} x {x y z} {}
+ y {x y z} {} z {x y z} {}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 23 xyz+--= {
+ {} {} {x y z} x {x y z} {}
+ y {x y z} {} z {x y z} {}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 24 xyz+-=_ {
+ {} {} {x y z} x {x y z} {}
+ y {x y z} {} z {x y z} {}
+ {x y} {x y z} {} {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 25 xyz&eee {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 26 xyz&ee- {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 27 xyz&e-- {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 28 xyz&e-= {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 29 xyz&--- {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 30 xyz&--= {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 31 xyz&-=_ {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 32 xyz!ee {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 33 xyz!e- {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 34 xyz!-- {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 35 xyz!-= {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+ 36 xyz!-e {
+ {} {} {x y z} x x {y z}
+ y {x y} z z {x y z} {}
+ {x y} {x y} z {x z} {x y z} {}
+ {y z} {x y z} {} {x y z} {x y z} {}
+ }
+} {
+ foreach {fset useful unuse} $setup_result {
+ set key ${n}.${code}.([join $fset {}])
+ set expected {}
+ foreach x $useful {lappend expected 1}
+ foreach x $unuse {lappend expected 0}
+
+ test fa-useful-${setimpl}-4.$key {useful states} {
+ grammar::fa a
+ gen $code
+ a final set $fset
+ set res [lsort [a useful_states]]
+ a destroy
+ set res
+ } $useful ; # {}
+
+ test fa-useful-${setimpl}-5.$key {!useful states} {
+ grammar::fa a
+ gen $code
+ a final set $fset
+ set res [lsort [a unuseful_states]]
+ a destroy
+ set res
+ } $unuse ; # {}
+
+ test fa-useful-${setimpl}-6.$key {usefulness testing} {
+ grammar::fa a
+ gen $code
+ a final set $fset
+ set res {}
+ foreach x $useful {lappend res [a useful $x]}
+ foreach x $unuse {lappend res [a useful $x]}
+ a destroy
+ set res
+ } $expected ; # {}
+ }
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/faop_complete.test b/tcllib/modules/grammar_fa/tests/faop_complete.test
new file mode 100644
index 0000000..ff87a9d
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/faop_complete.test
@@ -0,0 +1,107 @@
+# -*- tcl -*-
+# fa_operations.test: tests for the FA operations.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: faop_complete.test,v 1.4 2007/04/12 03:43:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test faop-complete-${setimpl}-1.0 {complete, error} {
+ catch {grammar::fa::op::complete} res
+ set res
+} {wrong # args: should be "grammar::fa::op::complete fa ?sink?"}
+
+
+test faop-complete-${setimpl}-1.1 {complete, error} {
+ catch {grammar::fa::op::complete a b c} res
+ set res
+} {wrong # args: should be "grammar::fa::op::complete fa ?sink?"}
+
+
+test faop-complete-${setimpl}-1.2 {complete, error} {
+ catch {grammar::fa::op::complete a} res
+ set res
+} {invalid command name "a"}
+
+
+test faop-complete-${setimpl}-1.3 {complete, error} {
+ grammar::fa a
+ a state add sink x
+ a symbol add @
+ catch {grammar::fa::op::complete a sink} res
+ a destroy
+ set res
+} {The chosen sink state exists already}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+foreach {n code result} {
+ 00 x {grammar::fa {} {x {0 0 {}}}}
+ 01 x- {grammar::fa @ {x {0 0 {@ x}}}}
+ 02 xe {grammar::fa {} {x {0 0 {{} x}}}}
+ 03 xy {grammar::fa {} {x {0 0 {}} y {0 0 {}}}}
+ 04 xy- {grammar::fa @ {x {0 0 {@ y}} y {0 0 {@ sink}} sink {0 0 {@ sink}}}}
+ 05 xye {grammar::fa {} {x {0 0 {{} y}} y {0 0 {}}}}
+ 06 xyee {grammar::fa {} {x {0 0 {{} y}} y {0 0 {{} x}}}}
+ 07 xyz/ee {grammar::fa {} {x {0 0 {{} {y z}}} y {0 0 {}} z {0 0 {}}}}
+ 08 xyz/-= {grammar::fa {@ =} {x {0 0 {@ y = z}} y {0 0 {@ sink = sink}} z {0 0 {@ sink = sink}} sink {0 0 {@ sink = sink}}}}
+ 09 xyz|ee {grammar::fa {} {x {0 0 {{} z}} y {0 0 {{} z}} z {0 0 {}}}}
+ 10 xyz|-= {grammar::fa {@ =} {x {0 0 {@ z = sink}} y {0 0 {@ sink = z}} z {0 0 {@ sink = sink}} sink {0 0 {@ sink = sink}}}}
+ 11 xyz+eee {grammar::fa {} {x {0 0 {{} y}} y {0 0 {{} z}} z {0 0 {{} x}}}}
+ 12 xyz+-=_ {grammar::fa {@ % =} {x {0 0 {@ y % sink = sink}} y {0 0 {@ sink % sink = z}} z {0 0 {@ sink = sink % x}} sink {0 0 {@ sink = sink % sink}}}}
+ 13 xyz&eee {grammar::fa {} {x {0 0 {{} {y z}}} y {0 0 {{} z}} z {0 0 {}}}}
+ 14 xyz&-=_ {grammar::fa {@ % =} {x {0 0 {@ y % sink = z}} y {0 0 {@ sink = sink % z}} z {0 0 {@ sink = sink % sink}} sink {0 0 {@ sink = sink % sink}}}}
+ 15 xyz!ee {grammar::fa {} {x {0 0 {{} y}} y {0 0 {{} z}} z {0 0 {}}}}
+ 16 xyz!-= {grammar::fa {@ % =} {x {0 0 {@ y % sink = sink}} y {0 0 {@ sink % sink = z}} z {0 0 {@ sink = sink % sink}} sink {0 0 {@ sink = sink % sink}}}}
+} {
+ set key ${n}.${code}
+
+ test faop-complete-${setimpl}-2.$key {complete} {
+ grammar::fa a
+ gen $code
+ grammar::fa::op::complete a sink
+ set res [a is complete]
+ lappend res [validate_serial $result a]
+ a destroy
+ set res
+ } {1 ok}
+
+ test faop-complete-${setimpl}-3.$key {second complete is a null operation} {
+ grammar::fa a
+ gen $code
+ grammar::fa::op::complete a
+ set res [a serialize]
+ grammar::fa::op::complete a
+ set res [validate_serial $res a]
+ a destroy
+ set res
+ } ok
+
+ test faop-complete-${setimpl}-4.$key {complete, as method} {
+ grammar::fa a
+ gen $code
+ a complete sink
+ set res [a is complete]
+ lappend res [validate_serial $result a]
+ a destroy
+ set res
+ } {1 ok}
+
+ test faop-complete-${setimpl}-5.$key {as method, second complete is a null operation} {
+ grammar::fa a
+ gen $code
+ a complete
+ set res [a serialize]
+ a complete
+ set res [validate_serial $res a]
+ a destroy
+ set res
+ } ok
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/faop_concat.test b/tcllib/modules/grammar_fa/tests/faop_concat.test
new file mode 100644
index 0000000..ad2b422
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/faop_concat.test
@@ -0,0 +1,113 @@
+# -*- tcl -*-
+# fa_operations.test: tests for the FA operations.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: faop_concat.test,v 1.4 2007/04/12 03:43:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test faop-concat-${setimpl}-1.0 {concat, error} {
+ catch {grammar::fa::op::concatenate} res
+ set res
+} {wrong # args: should be "grammar::fa::op::concatenate fa fb ?mapvar?"}
+
+
+test faop-concat-${setimpl}-1.1 {concat, error} {
+ catch {grammar::fa::op::concatenate a b c d} res
+ set res
+} {wrong # args: should be "grammar::fa::op::concatenate fa fb ?mapvar?"}
+
+
+test faop-concat-${setimpl}-1.2 {concat, error} {
+ catch {grammar::fa::op::concatenate a b} res
+ set res
+} {invalid command name "a"}
+
+
+test faop-concat-${setimpl}-1.3 {concat, error} {
+ grammar::fa a
+ catch {grammar::fa::op::concatenate a b} res
+ a destroy
+ set res
+} {invalid command name "b"}
+
+
+test faop-concat-${setimpl}-1.4 {concat, error} {
+ grammar::fa a
+ grammar::fa b
+ catch {grammar::fa::op::concatenate a b} res
+ a destroy
+ b destroy
+ set res
+} {Unable to concatenate FAs without start/final states}
+
+
+test faop-concat-${setimpl}-1.5 {concat, error} {
+ grammar::fa a
+ grammar::fa b
+ a state add x
+ a start add x
+ catch {grammar::fa::op::concatenate a b} res
+ a destroy
+ b destroy
+ set res
+} {Unable to concatenate FAs without start/final states}
+
+
+test faop-concat-${setimpl}-1.6 {concat, error} {
+ grammar::fa a
+ grammar::fa b
+ a state add x
+ a final add x
+ catch {grammar::fa::op::concatenate a b} res
+ a destroy
+ b destroy
+ set res
+} {Unable to concatenate FAs without start/final states}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+foreach {n fa fb fres rmap} {
+ 0
+ {grammar::fa @ {x {1 0 {@ y}} y {0 1 {}}}}
+ {grammar::fa = {u {1 0 {= v}} v {0 1 {}}}}
+ {grammar::fa {= @} {x {0 0 {@ y}} y {0 0 {{} m.0}} u {0 0 {= v}} v {0 0 {{} f.0}} s.0 {1 0 {{} x}} f.0 {0 1 {}} m.0 {0 0 {{} u}}}}
+ {}
+
+ 1
+ {grammar::fa @ {x {1 0 {@ y}} y {0 1 {}}}}
+ {grammar::fa = {x {1 0 {= y}} y {0 1 {}}}}
+ {grammar::fa {= @} {x {0 0 {@ y}} y {0 0 {{} m.0}} 0 {0 0 {= 1}} 1 {0 0 {{} f.0}} s.0 {1 0 {{} x}} f.0 {0 1 {}} m.0 {0 0 {{} 0}}}}
+ {0 x 1 y}
+} {
+ set key ${n}
+
+ test faop-concat-${setimpl}-2.$key {concat} {
+ grammar::fa a deserialize $fa
+ grammar::fa b deserialize $fb
+ grammar::fa::op::concatenate a b map
+ set res [validate_serial $fres a]
+ lappend res [string equal $rmap [dictsort $map]]
+ a destroy
+ b destroy
+ set res
+ } {ok 1}
+
+ test faop-concat-${setimpl}-3.$key {concat, as method} {
+ grammar::fa a deserialize $fa
+ grammar::fa b deserialize $fb
+ a concatenate b map
+ set res [validate_serial $fres a]
+ lappend res [string equal $rmap [dictsort $map]]
+ a destroy
+ b destroy
+ set res
+ } {ok 1}
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/faop_determinize.test b/tcllib/modules/grammar_fa/tests/faop_determinize.test
new file mode 100644
index 0000000..4daaeed
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/faop_determinize.test
@@ -0,0 +1,117 @@
+# -*- tcl -*-
+# fa_operations.test: tests for the FA operations.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: faop_determinize.test,v 1.4 2007/04/12 03:43:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test faop-determinize-${setimpl}-1.0 {determinize, error} {
+ catch {grammar::fa::op::determinize} res
+ set res
+} {wrong # args: should be "grammar::fa::op::determinize fa ?mapvar? ?idstart?"}
+
+
+test faop-determinize-${setimpl}-1.1 {determinize, error} {
+ catch {grammar::fa::op::determinize a b c d} res
+ set res
+} {wrong # args: should be "grammar::fa::op::determinize fa ?mapvar? ?idstart?"}
+
+
+test faop-determinize-${setimpl}-1.2 {determinize, error} {
+ catch {grammar::fa::op::determinize a} res
+ set res
+} {invalid command name "a"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+foreach {n code st fin mapres result} {
+ 00 datom x y {}
+ {grammar::fa @ {x {1 0 {@ y}} y {0 1 {}}}}
+
+ 01 dalt u z {0 {u v w} 1 {y z} 2 {x z}}
+ {grammar::fa {@ =} {0 {1 0 {@ 2 = 1}} 1 {0 1 {}} 2 {0 1 {}}}}
+
+ 02 dopt u x {0 {u v x} 1 {w x}}
+ {grammar::fa @ {0 {1 1 {@ 1}} 1 {0 1 {}}}}
+
+ 03 drep u x {0 {u v x} 1 {u v w x}}
+ {grammar::fa @ {0 {1 1 {@ 1}} 1 {0 1 {@ 1}}}}
+} {
+ set key ${n}.${code}
+
+ test faop-determinize-${setimpl}-2.$key {determinize, bounded} {
+ grammar::fa a
+ gen $code
+ a start add $st
+ a final add $fin
+ grammar::fa::op::determinize a map
+ set res [validate_serial $result a]
+ lappend res [string equal $mapres [dictsort $map]]
+ lappend res [a is deterministic]
+ a destroy
+ set res
+ } {ok 1 1}
+
+ test faop-determinize-${setimpl}-3.$key {determinize, bounded, as method} {
+ grammar::fa a
+ gen $code
+ a start add $st
+ a final add $fin
+ a determinize map
+ set res [validate_serial $result a]
+ lappend res [string equal $mapres [dictsort $map]]
+ lappend res [a is deterministic]
+ a destroy
+ set res
+ } {ok 1 1}
+}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+foreach {n code mapres result} {
+ 00 datom {0 x 1 y}
+ {grammar::fa @ {0 {0 0 {@ 1}} 1 {0 0 {}}}}
+
+ 01 dalt {0 x 1 y 2 u 3 z 4 v 5 w 6 {y z} 7 {x z}}
+ {grammar::fa {@ =} {0 {0 0 {}} 1 {0 0 {}} 2 {0 0 {@ 7 = 6}} 3 {0 0 {}} 4 {0 0 {@ 7}} 5 {0 0 {= 6}} 6 {0 0 {}} 7 {0 0 {}}}}
+
+ 02 dopt {0 x 1 u 2 v 3 w 4 {w x}}
+ {grammar::fa @ {0 {0 0 {}} 1 {0 0 {@ 4}} 2 {0 0 {@ 4}} 3 {0 0 {}} 4 {0 0 {}}}}
+
+ 03 drep {0 x 1 u 2 v 3 w 4 {u v w x}}
+ {grammar::fa @ {0 {0 0 {@ 4}} 1 {0 0 {@ 4}} 2 {0 0 {@ 4}} 3 {0 0 {@ 4}} 4 {0 0 {@ 4}}}}
+} {
+ set key ${n}.${code}
+
+ test faop-determinize-${setimpl}-4.$key {determinize, unbounded} {
+ grammar::fa a
+ gen $code
+ grammar::fa::op::determinize a map
+ set res [validate_serial $result a]
+ lappend res [string equal $mapres [dictsort $map]]
+ lappend res [a is deterministic] ; # Never formally det, because of missing start.
+ a destroy
+ set res
+ } {ok 1 0}
+
+ test faop-determinize-${setimpl}-5.$key {determinize, unbounded, as method} {
+ grammar::fa a
+ gen $code
+ a determinize map
+ set res [validate_serial $result a]
+ lappend res [string equal $mapres [dictsort $map]]
+ lappend res [a is deterministic] ; # Never formally det, because of missing start.
+ a destroy
+ set res
+ } {ok 1 0}
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/faop_difference.test b/tcllib/modules/grammar_fa/tests/faop_difference.test
new file mode 100644
index 0000000..8c3f1f0
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/faop_difference.test
@@ -0,0 +1,110 @@
+# -*- tcl -*-
+# fa_operations.test: tests for the FA operations.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: faop_difference.test,v 1.6 2007/04/12 03:43:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test faop-difference-${setimpl}-1.0 {difference, error} {
+ catch {grammar::fa::op::difference} res
+ set res
+} {wrong # args: should be "grammar::fa::op::difference fa fb ?mapvar?"}
+
+
+test faop-difference-${setimpl}-1.1 {difference, error} {
+ catch {grammar::fa::op::difference a b c d} res
+ set res
+} {wrong # args: should be "grammar::fa::op::difference fa fb ?mapvar?"}
+
+
+test faop-difference-${setimpl}-1.2 {difference, error} {
+ catch {grammar::fa::op::difference a b} res
+ set res
+} {invalid command name "a"}
+
+
+test faop-difference-${setimpl}-1.3 {difference, error} {
+ grammar::fa a
+ catch {grammar::fa::op::difference a b} res
+ a destroy
+ set res
+} {invalid command name "b"}
+
+
+test faop-difference-${setimpl}-1.4 {difference, error} {
+ grammar::fa a
+ grammar::fa b
+ catch {grammar::fa::op::difference a b} res
+ a destroy
+ b destroy
+ set res
+} {Unable to perform the difference of two FAs without start/final states}
+
+
+test faop-difference-${setimpl}-1.5 {difference, error} {
+ grammar::fa a
+ grammar::fa b
+ a state add x
+ a start add x
+ catch {grammar::fa::op::difference a b} res
+ a destroy
+ b destroy
+ set res
+} {Unable to perform the difference of two FAs without start/final states}
+
+
+test faop-difference-${setimpl}-1.6 {difference, error} {
+ grammar::fa a
+ grammar::fa b
+ a state add x
+ a final add x
+ catch {grammar::fa::op::difference a b} res
+ a destroy
+ b destroy
+ set res
+} {Unable to perform the difference of two FAs without start/final states}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+foreach {n fa fb fres rmap} {
+ 00
+ {grammar::fa {a b c} {x {1 0 {a y}} y {0 0 {b y c z}} z {0 1 {}}}}
+ {grammar::fa {a d c} {u {1 0 {a v}} v {0 0 {d v c w}} w {0 1 {}}}}
+ {grammar::fa {a b c d} {0 {1 0 {a 2}} 2 {0 0 {b 4}} 4 {0 0 {c 7 b 4}} 7 {0 1 {}}}}
+ {0 {x u} 2 {y v} 4 {y sink.0} 7 {z sink.0}}
+
+} {
+ set key $n
+
+ test faop-difference-${setimpl}-2.$key {difference} {
+ grammar::fa a deserialize $fa
+ grammar::fa b deserialize $fb
+ set res {}
+ grammar::fa::op::difference a b map
+ lappend res [validate_serial $fres a]
+ lappend res [string equal $rmap [dictsort $map]]
+ a destroy
+ b destroy
+ set res
+ } {ok 1}
+
+ test faop-difference-${setimpl}-3.$key {difference, as method} {
+ grammar::fa a deserialize $fa
+ grammar::fa b deserialize $fb
+ set res {}
+ a difference b map
+ lappend res [validate_serial $fres a]
+ lappend res [string equal $rmap [dictsort $map]]
+ a destroy
+ b destroy
+ set res
+ } {ok 1}
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/faop_intersect.test b/tcllib/modules/grammar_fa/tests/faop_intersect.test
new file mode 100644
index 0000000..8abced6
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/faop_intersect.test
@@ -0,0 +1,111 @@
+# -*- tcl -*-
+# fa_operations.test: tests for the FA operations.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: faop_intersect.test,v 1.6 2007/04/12 03:43:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test faop-intersect-${setimpl}-1.0 {intersect, error} {
+ catch {grammar::fa::op::intersect} res
+ set res
+} {wrong # args: should be "grammar::fa::op::intersect fa fb ?mapvar? ?idstart?"}
+
+
+test faop-intersect-${setimpl}-1.1 {intersect, error} {
+ catch {grammar::fa::op::intersect a b c d e} res
+ set res
+} {wrong # args: should be "grammar::fa::op::intersect fa fb ?mapvar? ?idstart?"}
+
+
+test faop-intersect-${setimpl}-1.2 {intersect, error} {
+ catch {grammar::fa::op::intersect a b} res
+ set res
+} {invalid command name "a"}
+
+
+test faop-intersect-${setimpl}-1.3 {intersect, error} {
+ grammar::fa a
+ catch {grammar::fa::op::intersect a b} res
+ a destroy
+ set res
+} {invalid command name "b"}
+
+
+test faop-intersect-${setimpl}-1.4 {intersect, error} {
+ grammar::fa a
+ grammar::fa b
+ catch {grammar::fa::op::intersect a b} res
+ a destroy
+ b destroy
+ set res
+} {Unable to perform the intersection of two FAs without start/final states}
+
+
+test faop-intersect-${setimpl}-1.5 {intersect, error} {
+ grammar::fa a
+ grammar::fa b
+ a state add x
+ a start add x
+ catch {grammar::fa::op::intersect a b} res
+ a destroy
+ b destroy
+ set res
+} {Unable to perform the intersection of two FAs without start/final states}
+
+
+test faop-intersect-${setimpl}-1.6 {intersect, error} {
+ grammar::fa a
+ grammar::fa b
+ a state add x
+ a final add x
+ catch {grammar::fa::op::intersect a b} res
+ a destroy
+ b destroy
+ set res
+} {Unable to perform the intersection of two FAs without start/final states}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+foreach {n fa fb fres rmap} {
+ 00
+ {grammar::fa {a b c} {x {1 0 {a y}} y {0 0 {b y c z}} z {0 1 {}}}}
+ {grammar::fa {a d c} {u {1 0 {a v}} v {0 0 {d v c w}} w {0 1 {}}}}
+ {grammar::fa {a b c d} {0 {1 0 {a 2}} 2 {0 0 {c 5}} 5 {0 1 {}}}}
+ {0 {x u} 2 {y v} 5 {z w}}
+} {
+ set key $n
+
+ test faop-intersect-${setimpl}-2.$key {intersect} {
+ grammar::fa a deserialize $fa
+ grammar::fa b deserialize $fb
+ set res {}
+ grammar::fa::op::intersect a b map
+
+ lappend res [validate_serial $fres a]
+ lappend res [string equal $rmap [dictsort $map]]
+ a destroy
+ b destroy
+ set res
+ } {ok 1}
+
+ test faop-intersect-${setimpl}-3.$key {intersect, as method} {
+ grammar::fa a deserialize $fa
+ grammar::fa b deserialize $fb
+ set res {}
+ a intersect b map
+
+ lappend res [validate_serial $fres a]
+ lappend res [string equal $rmap [dictsort $map]]
+ a destroy
+ b destroy
+ set res
+ } {ok 1}
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/faop_kleene.test b/tcllib/modules/grammar_fa/tests/faop_kleene.test
new file mode 100644
index 0000000..3db1e72
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/faop_kleene.test
@@ -0,0 +1,102 @@
+# -*- tcl -*-
+# fa_operations.test: tests for the FA operations.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: faop_kleene.test,v 1.4 2007/04/12 03:43:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test faop-kleene-${setimpl}-1.0 {kleene, error} {
+ catch {grammar::fa::op::kleene} res
+ set res
+} {wrong # args: should be "grammar::fa::op::kleene fa"}
+
+
+test faop-kleene-${setimpl}-1.1 {kleene, error} {
+ catch {grammar::fa::op::kleene a b} res
+ set res
+} {wrong # args: should be "grammar::fa::op::kleene fa"}
+
+
+test faop-kleene-${setimpl}-1.2 {kleene, error} {
+ catch {grammar::fa::op::kleene a} res
+ set res
+} {invalid command name "a"}
+
+
+test faop-kleene-${setimpl}-1.3 {kleene, error} {
+ grammar::fa a
+ catch {grammar::fa::op::kleene a} res
+ a destroy
+ set res
+} {Unable to add Kleene's closure to a FA without start/final states}
+
+
+test faop-kleene-${setimpl}-1.4 {kleene, error} {
+ grammar::fa a
+ a state add x
+ a start add x
+ catch {grammar::fa::op::kleene a} res
+ a destroy
+ set res
+} {Unable to add Kleene's closure to a FA without start/final states}
+
+
+test faop-kleene-${setimpl}-1.5 {kleene, error} {
+ grammar::fa a
+ a state add x
+ a final add x
+ catch {grammar::fa::op::kleene a} res
+ a destroy
+ set res
+} {Unable to add Kleene's closure to a FA without start/final states}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+foreach {n code st fin result} {
+ 00 datom x y
+ {grammar::fa @ {x {0 0 {@ y}} y {0 0 {{} f.0}} s.0 {1 0 {{} {x f.0}}} f.0 {0 1 {{} s.0}}}}
+
+ 01 dalt u z
+ {grammar::fa {@ =} {u {0 0 {{} {v w}}} v {0 0 {@ x}} w {0 0 {= y}} x {0 0 {{} z}} y {0 0 {{} z}} z {0 0 {{} f.0}} s.0 {1 0 {{} {u f.0}}} f.0 {0 1 {{} s.0}}}}
+
+ 02 daltb u z
+ {grammar::fa {@ =} {u {0 0 {{} {v w}}} v {0 0 {@ x}} w {0 0 {= y}} x {0 0 {{} z}} y {0 0 {{} z}} z {0 0 {{} {u f.0}}} s.0 {1 0 {{} {u f.0}}} f.0 {0 1 {{} s.0}}}}
+
+ 03 dopt u x
+ {grammar::fa @ {u {0 0 {{} {v x}}} v {0 0 {@ w}} w {0 0 {{} x}} x {0 0 {{} f.0}} s.0 {1 0 {{} {u f.0}}} f.0 {0 1 {{} s.0}}}}
+
+ 04 drep u x
+ {grammar::fa @ {u {0 0 {{} {v x}}} v {0 0 {@ w}} w {0 0 {{} x}} x {0 0 {{} {u f.0}}} s.0 {1 0 {{} {u f.0}}} f.0 {0 1 {{} s.0}}}}
+} {
+ set key ${n}.${code}
+
+ test faop-kleene-${setimpl}-2.$key {kleene} {
+ grammar::fa a
+ gen $code
+ a start add $st
+ a final add $fin
+ grammar::fa::op::kleene a
+ set res [validate_serial $result a]
+ a destroy
+ set res
+ } ok
+
+ test faop-kleene-${setimpl}-3.$key {kleene, as method} {
+ grammar::fa a
+ gen $code
+ a start add $st
+ a final add $fin
+ a kleene
+ set res [validate_serial $result a]
+ a destroy
+ set res
+ } ok
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/faop_minimize.test b/tcllib/modules/grammar_fa/tests/faop_minimize.test
new file mode 100644
index 0000000..949d069
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/faop_minimize.test
@@ -0,0 +1,117 @@
+# -*- tcl -*-
+# fa_operations.test: tests for the FA operations.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: faop_minimize.test,v 1.4 2007/04/12 03:43:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test faop-minimize-${setimpl}-1.0 {minimize, error} {
+ catch {grammar::fa::op::minimize} res
+ set res
+} {wrong # args: should be "grammar::fa::op::minimize fa ?mapvar?"}
+
+
+test faop-minimize-${setimpl}-1.1 {minimize, error} {
+ catch {grammar::fa::op::minimize a b c} res
+ set res
+} {wrong # args: should be "grammar::fa::op::minimize fa ?mapvar?"}
+
+
+test faop-minimize-${setimpl}-1.2 {minimize, error} {
+ catch {grammar::fa::op::minimize a} res
+ set res
+} {invalid command name "a"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+foreach {n code st fin mapres result} {
+ 00 datom x y {}
+ {grammar::fa @ {x {1 0 {@ y}} y {0 1 {}}}}
+
+ 01 dalt u z {0 {u v w} 1 {x y z}}
+ {grammar::fa {@ =} {0 {1 0 {@ 1 = 1}} 1 {0 1 {}}}}
+
+ 02 dopt u x {0 {u v w x} 1 {u w x}}
+ {grammar::fa @ {0 {1 1 {@ 1}} 1 {0 1 {}}}}
+
+ 03 drep u x {0 {u v w x}}
+ {grammar::fa @ {0 {1 1 {@ 0}}}}
+} {
+ set key ${n}.${code}
+
+ test faop-minimize-${setimpl}-2.$key {minimize, bounded} {
+ grammar::fa a
+ gen $code
+ a start add $st
+ a final add $fin
+ grammar::fa::op::minimize a map
+ set res [validate_serial $result a]
+ lappend res [string equal $mapres [dictsort $map]]
+ lappend res [a is deterministic]
+ a destroy
+ set res
+ } {ok 1 1}
+
+ test faop-minimize-${setimpl}-3.$key {minimize, bounded, as method} {
+ grammar::fa a
+ gen $code
+ a start add $st
+ a final add $fin
+ a minimize map
+ set res [validate_serial $result a]
+ lappend res [string equal $mapres [dictsort $map]]
+ lappend res [a is deterministic]
+ a destroy
+ set res
+ } {ok 1 1}
+}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+foreach {n code mapres result} {
+ 00 datom {0 x 1 y}
+ {grammar::fa @ {0 {0 0 {@ 1}} 1 {0 0 {}}}}
+
+ 01 dalt {0 v 1 x 2 w 3 y 4 {u v} 5 u 6 {u w} 7 z 8 {x z} 9 {y z}}
+ {grammar::fa {@ =} {0 {0 0 {}} 1 {0 0 {}} 2 {0 0 {}} 3 {0 0 {}} 4 {0 0 {@ 8}} 5 {0 0 {}} 6 {0 0 {= 9}} 7 {0 0 {}} 8 {0 0 {}} 9 {0 0 {}}}}
+
+ 02 dopt {0 {u v} 1 x 2 u 3 v 4 w 5 {w x}}
+ {grammar::fa @ {0 {0 0 {@ 5}} 1 {0 0 {}} 2 {0 0 {}} 3 {0 0 {}} 4 {0 0 {}} 5 {0 0 {}}}}
+
+ 03 drep {0 {u v w x} 1 x 2 u 3 v 4 w 5 {u v w x}}
+ {grammar::fa @ {0 {0 0 {@ 5}} 1 {0 0 {}} 2 {0 0 {}} 3 {0 0 {}} 4 {0 0 {}} 5 {0 0 {@ 5}}}}
+} {
+ set key ${n}.${code}
+
+ test faop-minimize-${setimpl}-4.$key {minimize, unbounded} {
+ grammar::fa a
+ gen $code
+ grammar::fa::op::minimize a map
+ set res [validate_serial $result a]
+ lappend res [string equal $mapres [dictsort $map]]
+ lappend res [a is deterministic] ; # Never formally det, because of missing start.
+ a destroy
+ set res
+ } {ok 1 0}
+
+ test faop-minimize-${setimpl}-5.$key {minimize, unbounded, as method} {
+ grammar::fa a
+ gen $code
+ a minimize map
+ set res [validate_serial $result a]
+ lappend res [string equal $mapres [dictsort $map]]
+ lappend res [a is deterministic] ; # Never formally det, because of missing start.
+ a destroy
+ set res
+ } {ok 1 0}
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/faop_optional.test b/tcllib/modules/grammar_fa/tests/faop_optional.test
new file mode 100644
index 0000000..fcb455f
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/faop_optional.test
@@ -0,0 +1,102 @@
+# -*- tcl -*-
+# fa_operations.test: tests for the FA operations.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: faop_optional.test,v 1.4 2007/04/12 03:43:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test faop-optional-${setimpl}-1.0 {optional, error} {
+ catch {grammar::fa::op::optional} res
+ set res
+} {wrong # args: should be "grammar::fa::op::optional fa"}
+
+
+test faop-optional-${setimpl}-1.1 {optional, error} {
+ catch {grammar::fa::op::optional a b} res
+ set res
+} {wrong # args: should be "grammar::fa::op::optional fa"}
+
+
+test faop-optional-${setimpl}-1.2 {optional, error} {
+ catch {grammar::fa::op::optional a} res
+ set res
+} {invalid command name "a"}
+
+
+test faop-optional-${setimpl}-1.3 {optional, error} {
+ grammar::fa a
+ catch {grammar::fa::op::optional a} res
+ a destroy
+ set res
+} {Unable to make a FA without start/final states optional}
+
+
+test faop-optional-${setimpl}-1.4 {optional, error} {
+ grammar::fa a
+ a state add x
+ a start add x
+ catch {grammar::fa::op::optional a} res
+ a destroy
+ set res
+} {Unable to make a FA without start/final states optional}
+
+
+test faop-optional-${setimpl}-1.5 {optional, error} {
+ grammar::fa a
+ a state add x
+ a final add x
+ catch {grammar::fa::op::optional a} res
+ a destroy
+ set res
+} {Unable to make a FA without start/final states optional}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+foreach {n code st fin result} {
+ 00 datom x y
+ {grammar::fa @ {x {0 0 {@ y}} y {0 0 {{} f.0}} s.0 {1 0 {{} {x f.0}}} f.0 {0 1 {}}}}
+
+ 01 dalt u z
+ {grammar::fa {@ =} {u {0 0 {{} {v w}}} v {0 0 {@ x}} w {0 0 {= y}} x {0 0 {{} z}} y {0 0 {{} z}} z {0 0 {{} f.0}} s.0 {1 0 {{} {u f.0}}} f.0 {0 1 {}}}}
+
+ 02 daltb u z
+ {grammar::fa {@ =} {u {0 0 {{} {v w}}} v {0 0 {@ x}} w {0 0 {= y}} x {0 0 {{} z}} y {0 0 {{} z}} z {0 0 {{} {u f.0}}} s.0 {1 0 {{} {u f.0}}} f.0 {0 1 {}}}}
+
+ 03 dopt u x
+ {grammar::fa @ {u {0 0 {{} {v x}}} v {0 0 {@ w}} w {0 0 {{} x}} x {0 0 {{} f.0}} s.0 {1 0 {{} {u f.0}}} f.0 {0 1 {}}}}
+
+ 04 drep u x
+ {grammar::fa @ {u {0 0 {{} {v x}}} v {0 0 {@ w}} w {0 0 {{} x}} x {0 0 {{} {u f.0}}} s.0 {1 0 {{} {u f.0}}} f.0 {0 1 {}}}}
+} {
+ set key ${n}.${code}
+
+ test faop-optional-${setimpl}-2.$key {optional} {
+ grammar::fa a
+ gen $code
+ a start add $st
+ a final add $fin
+ grammar::fa::op::optional a
+ set res [validate_serial $result a]
+ a destroy
+ set res
+ } ok
+
+ test faop-optional-${setimpl}-3.$key {optional, as method} {
+ grammar::fa a
+ gen $code
+ a start add $st
+ a final add $fin
+ a optional
+ set res [validate_serial $result a]
+ a destroy
+ set res
+ } ok
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/faop_regex.test b/tcllib/modules/grammar_fa/tests/faop_regex.test
new file mode 100644
index 0000000..961e135
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/faop_regex.test
@@ -0,0 +1,256 @@
+# -*- tcl -*-
+# fa_operations.test: tests for the FA operations.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: faop_regex.test,v 1.7 2007/12/03 21:46:25 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test faop-regex-${setimpl}-1.0 {fromRegex, error} {
+ catch {grammar::fa::op::fromRegex} res
+ set res
+} {wrong # args: should be "grammar::fa::op::fromRegex fa regex ?over?"}
+
+
+test faop-regex-${setimpl}-1.1 {fromRegex, error} {
+ catch {grammar::fa::op::fromRegex a b c d} res
+ set res
+} {wrong # args: should be "grammar::fa::op::fromRegex fa regex ?over?"}
+
+
+test faop-regex-${setimpl}-1.2 {fromRegex, error} {
+ catch {grammar::fa::op::fromRegex a b} res
+ set res
+} {Expected . ! ? * | &, or S, got "b"}
+
+
+test faop-regex-${setimpl}-1.3 {fromRegex, error} {
+ catch {grammar::fa::op::fromRegex a {S b}} res
+ set res
+} {invalid command name "a"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+foreach {n over re fres} {
+ 00 {} {}
+ {grammar::fa {} {}}
+
+ 01 {} {S x}
+ {grammar::fa x {0 {1 0 {x 1}} 1 {0 1 {}}}}
+
+ 02 {} {. {S x} {S y}}
+ {grammar::fa {x y} {0 {1 0 {x 1}} 1 {0 0 {{} 2}} 2 {0 0 {y 3}} 3 {0 1 {}}}}
+
+ 03 {} {| {S x} {S y}}
+ {grammar::fa {x y} {0 {1 0 {{} {2 4}}} 1 {0 1 {}} 2 {0 0 {x 3}} 3 {0 0 {{} 1}} 4 {0 0 {y 5}} 5 {0 0 {{} 1}}}}
+
+ 04 {} {? {S x}}
+ {grammar::fa x {0 {1 0 {{} {2 1}}} 1 {0 1 {}} 2 {0 0 {x 3}} 3 {0 0 {{} 1}}}}
+
+ 05 {} {* {S x}}
+ {grammar::fa x {0 {1 1 {{} 1}} 1 {0 0 {x 2}} 2 {0 0 {{} 0}}}}
+
+ 06 {} {+ {S x}}
+ {grammar::fa x {0 {1 0 {{} 2}} 1 {0 1 {{} 0}} 2 {0 0 {x 3}} 3 {0 0 {{} 1}}}}
+
+ 07 {} {! {S x}}
+ {grammar::fa x {0 {1 0 {{} 2}} 1 {0 1 {}} 2 {0 0 {x 3 {} 1}} 3 {0 0 {x 6}} 6 {0 0 {x 6 {} 1}}}}
+
+ 08 {/ * { } a} {. {S /} {S *} {+ {! {. {S *} {S /}}}} {S *} {S /}}
+ {grammar::fa {{ } a * /} {0 {1 0 {/ 1}} 1 {0 0 {{} 2}} 2 {0 0 {* 3}} 3 {0 0 {{} 4}} 4 {0 0 {{} 6}} 5 {0 0 {{} {4 16}}} 6 {0 0 {{} 12}} 7 {0 0 {{} 5}} 12 {0 0 {{ } 15 {} 7 a 15 * 13 / 15}} 13 {0 0 {{ } 15 {} 7 a 15 * 15 / 14}} 14 {0 0 {{ } 15 a 15 * 15 / 15}} 15 {0 0 {{ } 15 {} 7 a 15 * 15 / 15}} 16 {0 0 {* 17}} 17 {0 0 {{} 18}} 18 {0 0 {/ 19}} 19 {0 1 {}}}}
+
+ 09 {} {. {S x}}
+ {grammar::fa x {0 {1 0 {x 1}} 1 {0 1 {}}}}
+
+ 10 {} {| {S x}}
+ {grammar::fa x {0 {1 0 {x 1}} 1 {0 1 {}}}}
+
+ 11 {} {& {S x}}
+ {grammar::fa x {0 {1 0 {x 1}} 1 {0 1 {}}}}
+
+ 12 {} {& {. {S a} {* {S d}} {S c}} {. {S a} {* {S b}} {S c}}}
+ {grammar::fa {a b c d} {0 {1 0 {{} 2}} 1 {0 1 {}} 2 {0 0 {a 3}} 3 {0 0 {c 4}} 4 {0 0 {{} 1}}}}
+} {
+ set key ${n}
+
+ test faop-regex-${setimpl}-2.$key {fromRegex} {
+ grammar::fa a
+ grammar::fa::op::fromRegex a $re $over
+ set res [validate_serial $fres a]
+ a destroy
+ set res
+
+ } ok
+
+ test faop-regex-${setimpl}-3.$key {fromRegex, as method} {
+ grammar::fa a
+ a fromRegex $re $over
+ set res [validate_serial $fres a]
+ a destroy
+ set res
+ } ok
+}
+
+# -------------------------------------------------------------------------
+
+test faop-regex-${setimpl}-4.0 {toRegexp, error} {
+ catch {grammar::fa::op::toRegexp} res
+ set res
+} {wrong # args: should be "grammar::fa::op::toRegexp fa"}
+
+test faop-regex-${setimpl}-4.1 {toRegexp, error} {
+ catch {grammar::fa::op::toRegexp a b} res
+ set res
+} {wrong # args: should be "grammar::fa::op::toRegexp fa"}
+
+test faop-regex-${setimpl}-4.2 {toRegexp, error} {
+ catch {grammar::fa::op::toRegexp a} res
+ set res
+} {invalid command name "a"}
+
+test faop-regex-${setimpl}-4.3 {toRegexp} {
+ grammar::fa a
+ a state add 0 1 2
+ a symbol add a
+ a symbol add b
+ a next 0 a --> 1
+ a next 0 b --> 2
+ a next 1 b --> 0
+ a next 2 b --> 0
+ a start add 0
+ a final add 0
+
+ set res [grammar::fa::op::toRegexp a]
+ a destroy
+ set res
+} {* {| {. {S a} {S b}} {. {S b} {S b}}}}
+
+
+test faop-regex-${setimpl}-5.0 {toRegexp2, error} {
+ catch {grammar::fa::op::toRegexp2} res
+ set res
+} {wrong # args: should be "grammar::fa::op::toRegexp2 fa"}
+
+test faop-regex-${setimpl}-5.1 {toRegexp2, error} {
+ catch {grammar::fa::op::toRegexp2 a b} res
+ set res
+} {wrong # args: should be "grammar::fa::op::toRegexp2 fa"}
+
+test faop-regex-${setimpl}-5.2 {toRegexp2, error} {
+ catch {grammar::fa::op::toRegexp2 a} res
+ set res
+} {invalid command name "a"}
+
+test faop-regex-${setimpl}-5.3 {toRegexp2} {
+ grammar::fa a
+ a state add 0 1 2
+ a symbol add a
+ a symbol add b
+ a next 0 a --> 1
+ a next 0 b --> 2
+ a next 1 b --> 0
+ a next 2 b --> 0
+ a start add 0
+ a final add 0
+
+ set res [grammar::fa::op::toRegexp2 a]
+ a destroy
+ set res
+} {* {| {. {S a} {S b}} {. {S b} {S b}}}}
+
+# -------------------------------------------------------------------------
+
+test faop-regex-${setimpl}-6.0 {toTclRegexp, error} {
+ catch {grammar::fa::op::toTclRegexp} res
+ set res
+} {wrong # args: should be "grammar::fa::op::toTclRegexp re symdict"}
+
+test faop-regex-${setimpl}-6.1 {toTclRegexp, error} {
+ catch {grammar::fa::op::toTclRegexp a b c} res
+ set res
+} {wrong # args: should be "grammar::fa::op::toTclRegexp re symdict"}
+
+test faop-regex-${setimpl}-6.2 {toTclRegexp, error} {
+ catch {grammar::fa::op::toTclRegexp a {}} res
+ set res
+} {invalid command name "a"}
+
+test faop-regex-${setimpl}-6.3 {toTclRegexp} {
+ grammar::fa::op::toTclRegexp {* {| {. {S a} {S b}} {. {S b} {S b}}}} {}
+} {(ab|bb)*}
+
+# -------------------------------------------------------------------------
+
+test faop-regex-${setimpl}-7.0 {simplifyRegexp, error} {
+ catch {grammar::fa::op::simplifyRegexp} res
+ set res
+} {wrong # args: should be "grammar::fa::op::simplifyRegexp RE0"}
+
+test faop-regex-${setimpl}-7.1 {simplifyRegexp, error} {
+ catch {grammar::fa::op::simplifyRegexp a b} res
+ set res
+} {wrong # args: should be "grammar::fa::op::simplifyRegexp RE0"}
+
+test faop-regex-${setimpl}-7.2 {simplifyRegexp} {
+ set re {* {. {| {S a} {S b}} {S b}}}
+ grammar::fa::op::simplifyRegexp $re
+} {* {. {| {S a} {S b}} {S b}}}
+
+test faop-regex-${setimpl}-7.3 {simplifyRegexp} {
+ set re {* {| {. {S a} {S b}} {. {S b} {S b}}}}
+ grammar::fa::op::simplifyRegexp $re
+} {* {. {| {S a} {S b}} {S b}}}
+
+# -------------------------------------------------------------------------
+## Two larger examples
+
+test faop-regex-${setimpl}-8.0 {to(Tcl)Regexp, match 2 mod 3, decimal} {
+ set fa [grammar::fa decimal_2_mod_3]
+ $fa state add 0 1 2
+ $fa symbol add 0 1 2 3 4 5 6 7 8 9
+ foreach state [$fa states] {
+ foreach digit [$fa symbols] {
+ $fa next $state $digit --> [expr {(10*$state + $digit) % 3}]
+ }
+ }
+ $fa start add 0
+ $fa final add 2
+ set RE ^([grammar::fa::op::toTclRegexp [grammar::fa::op::toRegexp $fa] {}])\$
+ # Check the generated regex for correctness. Should match all ints 2 mod 3.
+ set res {}
+ for {set n 0} {$n<1000} {incr n} {
+ if {[regexp $RE $n] != ($n % 3 == 2)} {
+ lappend res $n
+ }
+ }
+ $fa destroy
+ set res
+} {}
+
+test faop-regex-${setimpl}-8.1 {to(Tcl)Regexp, match 1 mod 8, octal} {
+
+ set fa [grammar::fa octal_1_mod_3]
+ $fa state add 0 1 2
+ $fa symbol add 0 1 2 3 4 5 6 7
+ foreach state [$fa states] {
+ foreach digit [$fa symbols] {
+ $fa next $state $digit --> [expr {(8*$state + $digit) % 3}]
+ }
+ }
+ $fa start add 0
+ $fa final add 1
+ set RE ^([grammar::fa::op::toTclRegexp [grammar::fa::op::toRegexp $fa] {}])\$
+ set res {}
+ for {set n 0} {$n<4096} {incr n} {
+ if {[regexp $RE [format %o $n]] != ($n % 3 == 1)} {
+ lappend res $n
+ }
+ }
+ $fa destroy
+ set res
+} {}
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/faop_remeps.test b/tcllib/modules/grammar_fa/tests/faop_remeps.test
new file mode 100644
index 0000000..4951fad
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/faop_remeps.test
@@ -0,0 +1,158 @@
+# -*- tcl -*-
+# fa_operations.test: tests for the FA operations.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: faop_remeps.test,v 1.5 2007/04/12 03:43:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test faop-remove-${setimpl}-eps-1.0 {remove-eps, error} {
+ catch {grammar::fa::op::remove_eps} res
+ set res
+} {wrong # args: should be "grammar::fa::op::remove_eps fa"}
+
+
+test faop-remove-${setimpl}-eps-1.1 {remove-eps, error} {
+ catch {grammar::fa::op::remove_eps a b} res
+ set res
+} {wrong # args: should be "grammar::fa::op::remove_eps fa"}
+
+
+test faop-remove-${setimpl}-eps-1.2 {remove-eps, error} {
+ catch {grammar::fa::op::remove_eps a} res
+ set res
+} {invalid command name "a"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+foreach {n code result} {
+ 00 x id
+ 01 x- id
+ 02 xe {grammar::fa {} {x {0 0 {}}}}
+ 03 xy id
+ 04 xy- id
+ 05 xye {grammar::fa {} {x {0 0 {}} y {0 0 {}}}}
+ 06 xyee {grammar::fa {} {x {0 0 {}} y {0 0 {}}}}
+ 07 xye- {grammar::fa @ {x {0 0 {@ {x y}}} y {0 0 {@ {x y}}}}}
+ 08 xy-- id
+ 09 xy-= id
+ 10 xyz/ee {grammar::fa {} {x {0 0 {}} y {0 0 {}} z {0 0 {}}}}
+ 11 xyz/e- {grammar::fa @ {x {0 0 {@ y}} y {0 0 {}} z {0 0 {}}}}
+ 12 xyz/-- id
+ 13 xyz/-= id
+ 14 xyz|ee {grammar::fa {} {x {0 0 {}} y {0 0 {}} z {0 0 {}}}}
+ 15 xyz|e- {grammar::fa @ {x {0 0 {@ z}} y {0 0 {}} z {0 0 {}}}}
+ 16 xyz|-- id
+ 17 xyz|-= id
+ 18 xyz+eee {grammar::fa {} {x {0 0 {}} y {0 0 {}} z {0 0 {}}}}
+ 19 xyz+ee- {grammar::fa @ {x {0 0 {@ {x y z}}} y {0 0 {@ {x y z}}} z {0 0 {@ {x y z}}}}}
+ 20 xyz+e-- {grammar::fa @ {x {0 0 {@ z}} y {0 0 {@ z}} z {0 0 {@ {x y}}}}}
+ 21 xyz+e-= {grammar::fa {@ =} {x {0 0 {@ z}} y {0 0 {@ z}} z {0 0 {= {x y}}}}}
+ 22 xyz+--- id
+ 23 xyz+--= id
+ 24 xyz+-=_ id
+ 25 xyz&eee {grammar::fa {} {x {0 0 {}} y {0 0 {}} z {0 0 {}}}}
+ 26 xyz&ee- {grammar::fa @ {x {0 0 {@ z}} y {0 0 {@ z}} z {0 0 {}}}}
+ 27 xyz&e-- {grammar::fa @ {x {0 0 {@ z}} y {0 0 {@ z}} z {0 0 {}}}}
+ 28 xyz&e-= {grammar::fa {@ =} {x {0 0 {= z @ z}} y {0 0 {= z}} z {0 0 {}}}}
+ 29 xyz&--- id
+ 30 xyz&--= id
+ 31 xyz&-=_ id
+ 32 xyz!ee {grammar::fa {} {x {0 0 {}} y {0 0 {}} z {0 0 {}}}}
+ 33 xyz!e- {grammar::fa @ {x {0 0 {@ z}} y {0 0 {@ z}} z {0 0 {}}}}
+ 34 xyz!-- id
+ 35 xyz!-= id
+ 36 xyz!-e {grammar::fa @ {x {0 0 {@ {y z}}} y {0 0 {}} z {0 0 {}}}}
+} {
+ set key ${n}.${code}
+ if {$result eq "id"} {
+ grammar::fa a
+ gen $code
+ set result [a serialize]
+ a destroy
+ }
+
+ test faop-remove-${setimpl}-eps-2.$key {remove-eps} {
+ grammar::fa a
+ gen $code
+ grammar::fa::op::remove_eps a
+ set res [a is epsilon-free]
+ lappend res [validate_serial $result a]
+ a destroy
+ set res
+ } {1 ok}
+
+ test faop-remove-${setimpl}-eps-3.$key {second remove eps is null operation} {
+ grammar::fa a
+ gen $code
+ grammar::fa::op::remove_eps a
+ set res [a serialize]
+ grammar::fa::op::remove_eps a
+ set res [validate_serial $res a]
+ a destroy
+ set res
+ } ok
+
+ test faop-remove-${setimpl}-eps-4.$key {remove-eps, as method} {
+ grammar::fa a
+ gen $code
+ a remove_eps
+ set res [a is epsilon-free]
+ lappend res [validate_serial $result a]
+ a destroy
+ set res
+ } {1 ok}
+
+ test faop-remove-${setimpl}-eps-5.$key {second remove eps is null operation, as method} {
+ grammar::fa a
+ gen $code
+ a remove_eps
+ set res [a serialize]
+ a remove_eps
+ set res [validate_serial $res a]
+ a destroy
+ set res
+ } ok
+}
+
+
+foreach {n code st fin stnew finnew} {
+ 00 datom x y x y
+ 01 dalt u z {u v w} {x y z}
+ 02 dopt u x {u v x} {u w x}
+ 03 drep u x {u v x} {u w x}
+} {
+ test faop-remove-${setimpl}-eps-6.$n.$code {remove epsilon, start/final propagation} {
+ grammar::fa a
+ gen $code
+ a start add $st
+ a final add $fin
+ grammar::fa::op::remove_eps a
+
+ set res {}
+ lappend res [string equal $stnew [lsort [a startstates]]]
+ lappend res [string equal $finnew [lsort [a finalstates]]]
+ a destroy
+ set res
+ } {1 1}
+
+ test faop-remove-${setimpl}-eps-7.$n.$code {remove epsilon, start/final propagation, as method} {
+ grammar::fa a
+ gen $code
+ a start add $st
+ a final add $fin
+ a remove_eps
+
+ set res {}
+ lappend res [string equal $stnew [lsort [a startstates]]]
+ lappend res [string equal $finnew [lsort [a finalstates]]]
+ a destroy
+ set res
+ } {1 1}
+}
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/faop_reverse.test b/tcllib/modules/grammar_fa/tests/faop_reverse.test
new file mode 100644
index 0000000..d997707
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/faop_reverse.test
@@ -0,0 +1,95 @@
+# -*- tcl -*-
+# fa_operations.test: tests for the FA operations.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: faop_reverse.test,v 1.5 2007/04/12 03:43:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test faop-reverse-${setimpl}-1.0 {reverse, error} {
+ catch {grammar::fa::op::reverse} res
+ set res
+} {wrong # args: should be "grammar::fa::op::reverse fa"}
+
+
+test faop-reverse-${setimpl}-1.1 {reverse, error} {
+ catch {grammar::fa::op::reverse a b} res
+ set res
+} {wrong # args: should be "grammar::fa::op::reverse fa"}
+
+
+test faop-reverse-${setimpl}-1.2 {reverse, error} {
+ catch {grammar::fa::op::reverse a} res
+ set res
+} {invalid command name "a"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+foreach {n code result} {
+ 00 x {grammar::fa {} {x {0 0 {}}}}
+ 01 x- {grammar::fa @ {x {0 0 {@ x}}}}
+ 02 xe {grammar::fa {} {x {0 0 {{} x}}}}
+ 03 xy {grammar::fa {} {x {0 0 {}} y {0 0 {}}}}
+ 04 xy- {grammar::fa @ {x {0 0 {}} y {0 0 {@ x}}}}
+ 05 xye {grammar::fa {} {x {0 0 {}} y {0 0 {{} x}}}}
+ 06 xyee {grammar::fa {} {x {0 0 {{} y}} y {0 0 {{} x}}}}
+ 07 xyz/ee {grammar::fa {} {x {0 0 {}} y {0 0 {{} x}} z {0 0 {{} x}}}}
+ 08 xyz/-= {grammar::fa {@ =} {x {0 0 {}} y {0 0 {@ x}} z {0 0 {= x}}}}
+ 09 xyz|ee {grammar::fa {} {x {0 0 {}} y {0 0 {}} z {0 0 {{} {x y}}}}}
+ 10 xyz|-= {grammar::fa {@ =} {x {0 0 {}} y {0 0 {}} z {0 0 {@ x = y}}}}
+ 11 xyz+eee {grammar::fa {} {x {0 0 {{} z}} y {0 0 {{} x}} z {0 0 {{} y}}}}
+ 12 xyz+-=_ {grammar::fa {@ % =} {x {0 0 {% z}} y {0 0 {@ x}} z {0 0 {= y}}}}
+ 13 xyz&eee {grammar::fa {} {x {0 0 {}} y {0 0 {{} x}} z {0 0 {{} {x y}}}}}
+ 14 xyz&-=_ {grammar::fa {@ % =} {x {0 0 {}} y {0 0 {@ x}} z {0 0 {= x % y}}}}
+ 15 xyz!ee {grammar::fa {} {x {0 0 {}} y {0 0 {{} x}} z {0 0 {{} y}}}}
+ 16 xyz!-= {grammar::fa {@ % =} {x {0 0 {}} y {0 0 {@ x}} z {0 0 {= y}}}}
+} {
+ set key ${n}.${code}
+
+ test faop-reverse-${setimpl}-2.$key {reverse} {
+ grammar::fa a
+ gen $code
+ grammar::fa::op::reverse a
+ set res [validate_serial $result a]
+ a destroy
+ set res
+ } ok
+
+ test faop-reverse-${setimpl}-3.$key {double reverse is identity} {
+ grammar::fa a
+ gen $code
+ set res [a serialize]
+ grammar::fa::op::reverse a
+ grammar::fa::op::reverse a
+ set res [validate_serial $res a]
+ a destroy
+ set res
+ } ok
+
+ test faop-reverse-${setimpl}-4.$key {reverse, as method} {
+ grammar::fa a
+ gen $code
+ a reverse
+ set res [validate_serial $result a]
+ a destroy
+ set res
+ } ok
+
+ test faop-reverse-${setimpl}-5.$key {double reverse is identity, for method} {
+ grammar::fa a
+ gen $code
+ set res [a serialize]
+ a reverse
+ a reverse
+ set res [validate_serial $res a]
+ a destroy
+ set res
+ } ok
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/faop_trim.test b/tcllib/modules/grammar_fa/tests/faop_trim.test
new file mode 100644
index 0000000..7fd880b
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/faop_trim.test
@@ -0,0 +1,209 @@
+# -*- tcl -*-
+# fa_operations.test: tests for the FA operations.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: faop_trim.test,v 1.7 2007/04/12 03:43:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+if {![::tcltest::testConstraint runtotal]} {
+ ::tcltest::cleanupTests
+ return
+}
+
+# -------------------------------------------------------------------------
+
+test faop-trim-${setimpl}-1.0 {trim, error} {
+ catch {grammar::fa::op::trim} res
+ set res
+} {wrong # args: should be "grammar::fa::op::trim fa ?what?"}
+
+
+test faop-trim-${setimpl}-1.1 {trim, error} {
+ catch {grammar::fa::op::trim a foo} res
+ set res
+} {Expected !reachable, !useful, !reachable&!useful, !(reachable|useful), !reachable|!useful, or !(reachable&useful), got "foo"}
+
+
+test faop-trim-${setimpl}-1.2 {trim, error} {
+ catch {grammar::fa::op::trim a} res
+ set res
+} {invalid command name "a"}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+if 0 {
+ 00 x
+ 01 x-
+ 02 xy
+ 03 xy-
+ 04 xy-=
+ 05 xyz/-=
+ 06 xyz|-=
+ 07 xyz+-=_
+ 08 xyz&-=_
+ 09 xyz!-=
+ 10 xyz!-e
+}
+
+foreach {n code} {
+ 00 x
+ 01 x-
+ 02 xe
+ 03 xy
+ 04 xy-
+ 05 xye
+ 06 xyee
+ 07 xye-
+ 08 xy--
+ 09 xy-=
+ 10 xyz/ee
+ 11 xyz/e-
+ 12 xyz/--
+ 13 xyz/-=
+ 14 xyz|ee
+ 15 xyz|e-
+ 16 xyz|--
+ 17 xyz|-=
+ 18 xyz+eee
+ 19 xyz+ee-
+ 20 xyz+e--
+ 21 xyz+e-=
+ 22 xyz+---
+ 23 xyz+--=
+ 24 xyz+-=_
+ 25 xyz&eee
+ 26 xyz&ee-
+ 27 xyz&e--
+ 28 xyz&e-=
+ 29 xyz&---
+ 30 xyz&--=
+ 31 xyz&-=_
+ 32 xyz!ee
+ 33 xyz!e-
+ 34 xyz!--
+ 35 xyz!-=
+ 36 xyz!-e
+} {
+ if {[string match xyz* $code]} {
+ set sets {{} x y z {x y} {x z} {y z} {x y z}}
+ set max 2
+ } elseif {[string match xy* $code]} {
+ set sets {{} x y {x y}}
+ set max 1
+ } elseif {[string match x* $code]} {
+ set sets {{} x}
+ set max 0
+ } else {
+ set sets {{}}
+ set max 4
+ }
+
+ # Pre-loop, generate the relevant combinations of input.
+
+ set states [string range $code 0 $max]
+ set combinations {}
+
+ foreach st $sets {
+ lappend combinations !reachable $st {}
+ lappend combinations !useful {} $st
+ }
+ foreach method {
+ !reachable&!useful !(reachable|useful)
+ !reachable|!useful !(reachable&useful)
+ } {
+ foreach st $sets {
+ foreach fin $sets {
+ lappend combinations $method $st $fin
+ }
+ }
+ }
+
+ foreach {method st fin} $combinations {
+ set key $n.$code.([join $st {}],[join $fin {}]).$method
+
+ test faop-trim-${setimpl}-2.$key {trim} {
+ grammar::fa a
+ gen $code
+ a start set $st
+ a final set $fin
+
+ switch -exact -- $method {
+ !reachable {set kept [a reachable_states]}
+ !useful {set kept [a useful_states]}
+ !reachable&!useful -
+ !(reachable|useful) {
+ set kept [struct::set union [a reachable_states] [a useful_states]]
+ }
+ !reachable|!useful -
+ !(reachable&useful) {
+ set kept [struct::set intersect [a reachable_states] [a useful_states]]
+ }
+ }
+ set kept [join [lsort $kept] {}]
+
+ grammar::fa::op::trim a $method
+ set res [expr {$kept eq [join [lsort [a states]] {}]}]
+ a destroy
+ set res
+ } 1 ; # {}
+
+ test faop-trim-${setimpl}-3.$key {second trim is null operation} {
+ grammar::fa a
+ gen $code
+ a start set $st
+ a final set $fin
+ grammar::fa::op::trim a $method
+ set res [a serialize]
+ grammar::fa::op::trim a $method
+ set res [validate_serial $res a]
+ a destroy
+ set res
+ } ok ; # {}
+
+
+ test faop-trim-${setimpl}-3.$key {trim, as method} {
+ grammar::fa a
+ gen $code
+ a start set $st
+ a final set $fin
+
+ switch -exact -- $method {
+ !reachable {set kept [a reachable_states]}
+ !useful {set kept [a useful_states]}
+ !reachable&!useful -
+ !(reachable|useful) {
+ set kept [struct::set union [a reachable_states] [a useful_states]]
+ }
+ !reachable|!useful -
+ !(reachable&useful) {
+ set kept [struct::set intersect [a reachable_states] [a useful_states]]
+ }
+ }
+ set kept [join [lsort $kept] {}]
+
+ a trim $method
+ set res [expr {$kept eq [join [lsort [a states]] {}]}]
+ a destroy
+ set res
+ } 1 ; # {}
+
+ test faop-trim-${setimpl}-4.$key {second trim is null operation, for method} {
+ grammar::fa a
+ gen $code
+ a start set $st
+ a final set $fin
+ a trim $method
+ set res [a serialize]
+ a trim $method
+ set res [validate_serial $res a]
+ a destroy
+ set res
+ } ok ; # {}
+ }
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_fa/tests/faop_union.test b/tcllib/modules/grammar_fa/tests/faop_union.test
new file mode 100644
index 0000000..86b1c67
--- /dev/null
+++ b/tcllib/modules/grammar_fa/tests/faop_union.test
@@ -0,0 +1,113 @@
+# -*- tcl -*-
+# fa_operations.test: tests for the FA operations.
+#
+# Copyright (c) 2004-2007 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: faop_union.test,v 1.4 2007/04/12 03:43:15 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+test faop-union-${setimpl}-1.0 {union, error} {
+ catch {grammar::fa::op::union} res
+ set res
+} {wrong # args: should be "grammar::fa::op::union fa fb ?mapvar?"}
+
+
+test faop-union-${setimpl}-1.1 {union, error} {
+ catch {grammar::fa::op::union a b c d} res
+ set res
+} {wrong # args: should be "grammar::fa::op::union fa fb ?mapvar?"}
+
+
+test faop-union-${setimpl}-1.2 {union, error} {
+ catch {grammar::fa::op::union a b} res
+ set res
+} {invalid command name "a"}
+
+
+test faop-union-${setimpl}-1.3 {union, error} {
+ grammar::fa a
+ catch {grammar::fa::op::union a b} res
+ a destroy
+ set res
+} {invalid command name "b"}
+
+
+test faop-union-${setimpl}-1.4 {union, error} {
+ grammar::fa a
+ grammar::fa b
+ catch {grammar::fa::op::union a b} res
+ a destroy
+ b destroy
+ set res
+} {Unable to union FAs without start/final states}
+
+
+test faop-union-${setimpl}-1.5 {union, error} {
+ grammar::fa a
+ grammar::fa b
+ a state add x
+ a start add x
+ catch {grammar::fa::op::union a b} res
+ a destroy
+ b destroy
+ set res
+} {Unable to union FAs without start/final states}
+
+
+test faop-union-${setimpl}-1.6 {union, error} {
+ grammar::fa a
+ grammar::fa b
+ a state add x
+ a final add x
+ catch {grammar::fa::op::union a b} res
+ a destroy
+ b destroy
+ set res
+} {Unable to union FAs without start/final states}
+
+
+# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+
+foreach {n fa fb fres rmap} {
+ 0
+ {grammar::fa @ {x {1 0 {@ y}} y {0 1 {}}}}
+ {grammar::fa = {u {1 0 {= v}} v {0 1 {}}}}
+ {grammar::fa {= @} {x {0 0 {@ y}} y {0 0 {{} f.0}} u {0 0 {= v}} v {0 0 {{} f.0}} s.0 {1 0 {{} {x u}}} f.0 {0 1 {}}}}
+ {}
+
+ 1
+ {grammar::fa @ {x {1 0 {@ y}} y {0 1 {}}}}
+ {grammar::fa = {x {1 0 {= y}} y {0 1 {}}}}
+ {grammar::fa {= @} {x {0 0 {@ y}} y {0 0 {{} f.0}} 0 {0 0 {= 1}} 1 {0 0 {{} f.0}} s.0 {1 0 {{} {x 0}}} f.0 {0 1 {}}}}
+ {0 x 1 y}
+} {
+ set key ${n}
+
+ test faop-union-${setimpl}-2.$key {union} {
+ grammar::fa a deserialize $fa
+ grammar::fa b deserialize $fb
+ grammar::fa::op::union a b map
+ set res [validate_serial $fres a]
+ lappend res [string equal $rmap [dictsort $map]]
+ a destroy
+ b destroy
+ set res
+ } {ok 1}
+
+ test faop-union-${setimpl}-3.$key {union, as method} {
+ grammar::fa a deserialize $fa
+ grammar::fa b deserialize $fb
+ a union b map
+ set res [validate_serial $fres a]
+ lappend res [string equal $rmap [dictsort $map]]
+ a destroy
+ b destroy
+ set res
+ } {ok 1}
+}
+
+
+# -------------------------------------------------------------------------
+::tcltest::cleanupTests
diff --git a/tcllib/modules/grammar_me/ChangeLog b/tcllib/modules/grammar_me/ChangeLog
new file mode 100644
index 0000000..07b3df3
--- /dev/null
+++ b/tcllib/modules/grammar_me/ChangeLog
@@ -0,0 +1,211 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2013-01-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * me_tcl.test: (mevmtcl-ict_match_tokclass-1.2*): Fixed test
+ results for Tcl 8.6 and higher.
+
+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 ========================
+ *
+
+2008-05-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * me_cpucore.man: Updated to changes in doctools (sub)section
+ * me_cpu.man: reference handling.
+ * me_tcl.man:
+
+2008-03-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * gasm.man: Added documentation for package 'grammar::me::cpu::gasm'.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-01 Andreas Kupries <andreask@activestate.com>
+
+ * me_util.test: Updated to use the TestAccel utility commands to
+ handle accelerators.
+ * me_tcl.test: Updated 8.5 specific test to extensions in 'string is'.
+
+2007-06-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * me_cpu.testsuite: Replaced deprecated {expand} syntax in
+ comments with {*}.
+
+2007-03-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * me_ast.man: Fixed all warnings due to use of now deprecated
+ * me_cpu.man: commands. Added a section about how to give
+ * me_cpucore.man: feedback.
+ * me_intro.man:
+ * me_tcl.man:
+ * me_util.man:
+ * me_vm.man:
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * me_cpu.testsuite: Replaced hardwired snit error messages with
+ command constructing them based on the version of snit
+ used. Fixed test names as well.
+
+ * me_cpucore.testsuite: Replaced hardwired error messages with
+ command constructing them based on the version of Tcl used.
+
+2006-06-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * grammar_me/me_cpucore.tests.semantics.txt: Extended to cover the
+ remaining untested instructions. This completes the behavioural
+ tests.
+
+ * grammar_me/me_cpucore.man: Added documentation for the new
+ * grammar_me/me_cpucore.tcl: accessor commands. Fixed problems
+ * grammar_me/me_cpucore.test: uncovered by the last tests.
+
+ * grammar_me/me_cpu.man: Lifted all changes to the cpucore into
+ * grammar_me/me_cpu.tcl: the cpu object (extended acessors,
+ * grammar_me/me_cpu.test: documentation, etc.). Created testsuite
+ * grammar_me/me_cpu.testsuite: using the core testsuite as
+ template, and sharing the instruction descriptions with it.
+
+ * grammar_me/gasm.tcl: New package for the assembly of a ME
+ * grammar_me/pkgIndex.tcl: program, using a graph as internal
+ structure. Bumped the versions of the cpu::core and cpu packages
+ as well.
+
+2006-06-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * me_cpucore.tcl (asm): Extended the assembler to detect and
+ ignore comment pseudo instructions.
+
+2006-06-20 Andreas Kupries <andreask@activestate.com>
+
+ * me_cpucore.tests.semantics.txt: Extended coverage of testsuite,
+ * me_cpucore.testsuite: more bugfixes.
+ * me_cpucore.tcl:
+
+ * me_cpucore.tcl: Bug fixes, additional state accessor commands,
+ more argument checking, extended error messages from validator
+ used by disassembler and state creation.
+
+ * me_cpucore.test: Added testsuite for the cpu,
+ * me_cpucore.testsuite: already semi-prepared for when
+ * me_cpucore.tests.asm-map.txt: we get a C impl. of the ME cpu.
+ * me_cpucore.tests.badasm-map.txt: Largely table-driven.
+ * me_cpucore.tests.badmach-map.txt: Incomplete.
+ * me_cpucore.tests.semantics.txt:
+
+2006-06-15 Andreas Kupries <andreask@activestate.com>
+
+ * me_util.test: Split tests into separate file and added handling
+ of both regular and critcl tree.
+ * me_util.testsuite: New file. Actual tests.
+
+2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * me_tcl.test: Fixed use of duplicate test names.
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * me_tcl.test: More boilerplate simplified via use of test support.
+ * me_util.test:
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * me_tcl.test: Hooked into the new common test support code.
+ * me_util.test:
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-10-03 Andreas Kupries <andreask@activestate.com>
+
+ * me_tcl.test (ME_state): token ranks are stored in an array/dict,
+ used dictsort to generate a canonical representation we can
+ compare against. ... Also duplicate tokclass test depending on
+ error message by "string is", different results in 8.4 and 8.5.
+
+2005-09-30 Andreas Kupries <andreask@activestate.com>
+
+ * me_cpucore.tcl: Fixed more typos.
+ * me_cpucore.tcl: Fixed namespace typo.
+
+ * me_tcl.test: Added forgotten check to tests, the packages cannot
+ * me_utils.test: run against Tcl 8.3 and below.
+
+2005-09-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * me_vm.man: Removed the hardwired generation of error
+ * me_tcl.man: messages and made them explicit arguments of the
+ * me_tcl.tcl: instructions which can generate errors. More
+ * me_tcl.test: work for a generator, but ensures that
+ * me_cpucore.man: user-strings are not contaminated by Tcl code
+ * me_cpucore.tcl: (character representation).
+
+2005-09-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * me_tcl.tcl: Fixed bug uncovered by the testuite.
+
+ * me_tcl.test: Completed the testsuite.
+
+2005-08-31 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * me_tcl.man: Added more accessor commands, to be able to inspect
+ the full state of the ME vm when running the testsuite.
+
+ * me_tcl.tcl: Implemented the newly specified accessor commands.
+
+ * me_tcl.test: **New file** Skeleton framework for the testsuite
+ of the ME vm.
+
+ * me_util.tcl: Added argument sanity checking.
+
+ * me_util.test: **New file** Added a testsuite for the commands
+ doing the conversions between AST representations.
+
+2005-04-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module: Virtual machine for parsing, various
+ implementations, utilities.
diff --git a/tcllib/modules/grammar_me/gasm.man b/tcllib/modules/grammar_me/gasm.man
new file mode 100644
index 0000000..10172fc
--- /dev/null
+++ b/tcllib/modules/grammar_me/gasm.man
@@ -0,0 +1,439 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin grammar::me::cpu::gasm n 0.1]
+[keywords assembler]
+[keywords grammar]
+[keywords graph]
+[keywords parsing]
+[keywords tree]
+[keywords {virtual machine}]
+[copyright {2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Grammar operations and usage}]
+[titledesc {ME assembler}]
+[category {Grammars and finite automata}]
+[require grammar::me::cpu::gasm [opt 0.1]]
+[description]
+
+This package provides a simple in-memory assembler. Its origin is that
+of a support package for use by packages converting PEG and other
+grammars into a corresponding matcher based on the ME virtual machine,
+like [package page::compiler::peg::mecpu]. Despite that it is actually
+mostly agnostic regarding the instructions, users can choose any
+instruction set they like.
+
+[para]
+
+The program under construction is held in a graph structure (See
+package [package struct::graph]) during assembly and subsequent
+manipulation, with instructions represented by nodes, and the flow of
+execution between instructions explicitly encoded in the arcs between
+them.
+
+[para]
+
+In this model jumps are not encoded explicitly, they are implicit in
+the arcs. The generation of explicit jumps is left to any code
+converting the graph structure into a more conventional
+representation. The same goes for branches. They are implicitly
+encoded by all instructions which have two outgoing arcs, whereas all
+other instructions have only one outgoing arc. Their conditonality is
+handled by tagging their outgoing arcs with information about the
+conditions under which they are taken.
+
+[para]
+
+While the graph the assembler operates on is supplied from the
+outside, i.e. external, it does manage some internal state, namely:
+
+[list_begin enumerated]
+[enum] The handle of the graph node most assembler operations will
+work on, the [term anchor].
+
+[enum] A mapping from arbitrary strings to instructions. I.e. it is
+possible to [term label] an instruction during assembly, and later
+recall that instruction by its label.
+
+[enum] The condition code to use when creating arcs between
+instructions, which is one of [const always], [const ok], and
+[const fail].
+
+[enum] The current operation mode, one of [const halt],
+[const okfail], and [const !okfail].
+
+[enum] The name of a node in a tree. This, and the operation mode
+above are the parts most heavily influenced by the needs of a grammar
+compiler, as they assume some basic program structures (selected
+through the operation mode), and intertwine the graph with a tree,
+like the AST for the grammar to be compiled.
+
+[list_end]
+
+[section DEFINITIONS]
+
+As the graph the assembler is operating on, and the tree it is
+intertwined with, are supplied to the assembler from the outside it is
+necessary to specify the API expected from them, and to describe the
+structures expected and/or generated by the assembler in either.
+
+[para]
+
+[list_begin enumerated]
+
+[enum] Any graph object command used by the assembler has to provide
+the API as specified in the documentation for the package
+[package struct::graph].
+
+[enum] Any tree object command used by the assembler has to provide
+the API as specified in the documentation for the package
+[package struct::tree].
+
+[enum] Any instruction (node) generated by the assembler in a graph
+will have at least two, and at most three attributes:
+
+[list_begin definitions]
+
+[def [const instruction]] The value of this attribute is the name of
+the instruction. The only names currently defined by the assembler are
+the three pseudo-instructions
+
+[comment {Fix nroff backend so that the put the proper . on the command name}]
+[list_begin definitions]
+
+[def [const NOP]] This instruction does nothing. Useful for fixed
+framework nodes, unchanging jump destinations, and the like. No
+arguments.
+
+[def [const C]] A .NOP to allow the insertion of arbitrary comments
+into the instruction stream, i.e. a comment node. One argument, the
+text of the comment.
+
+[def [const BRA]] A .NOP serving as explicitly coded conditional
+branch. No arguments.
+
+[list_end]
+
+However we reserve the space of all instructions whose names begin
+with a "." (dot) for future use by the assembler.
+
+[def [const arguments]] The value of this attribute is a list of
+strings, the arguments of the instruction. The contents are dependent
+on the actual instruction and the assembler doesn't know or care about
+them. This means for example that it has no builtin knowledge about
+what instruction need which arguments and thus doesn't perform any
+type of checking.
+
+[def [const expr]] This attribute is optional. When it is present its
+value is the name of a node in the tree intertwined with the graph.
+
+[list_end]
+
+[enum] Any arc between two instructions will have one attribute:
+
+[list_begin definitions]
+
+[def [const condition]] The value of this attribute determines under which
+condition execution will take this arc. It is one of [const always],
+[const ok], and [const fail]. The first condition is used for all arcs
+which are the single outgoing arc of an instruction. The other two are
+used for the two outgoing arcs of an instruction which implicitly
+encode a branch.
+
+[list_end]
+
+[enum] A tree node given to the assembler for cross-referencing will
+be written to and given the following attributes, some fixed, some
+dependent on the operation mode. All values will be references to
+nodes in the instruction graph. Some of the instruction will expect
+some or specific sets of these attributes.
+
+[list_begin definitions]
+[def [const gas::entry]] Always written.
+[def [const gas::exit]] Written for all modes but [const okfail].
+[def [const gas::exit::ok]] Written for mode [const okfail].
+[def [const gas::exit::fail]] Written for mode [const okfail].
+[list_end]
+
+[list_end]
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::grammar::me::cpu::gasm::begin] [arg g] [arg n] [opt [arg mode]] [opt [arg note]]]
+
+This command starts the assembly of an instruction sequence, and
+(re)initializes the state of the assembler. After completion of the
+instruction sequence use [cmd ::grammar::me::cpu::gasm::done] to
+finalize the assembler.
+
+[para]
+
+It will operate on the graph [arg g] in the specified [arg mode]
+(Default is [const okfail]). As part of the initialization it will
+always create a standard .NOP instruction and label it "entry". The
+creation of the remaining standard instructions is
+[arg mode]-dependent:
+
+[list_begin definitions]
+
+[def [const halt]] An "icf_halt" instruction labeled "exit/return".
+
+[def [const !okfail]] An "icf_ntreturn" instruction labeled "exit/return".
+
+[def [const okfail]] Two .NOP instructions labeled "exit/ok" and
+"exit/fail" respectively.
+
+[list_end]
+
+The [arg note], if specified (default is not), is given to the "entry" .NOP instruction.
+
+[para]
+
+The node reference [arg n] is simply stored for use by
+[cmd ::grammar::me::cpu::gasm::done]. It has to refer to a node in the
+tree [arg t] argument of that command.
+
+[para]
+
+After the initialization is done the "entry" instruction will be the
+[term anchor], and the condition code will be set to [const always].
+
+[para]
+
+The command returns the empy string as its result.
+
+[call [cmd ::grammar::me::cpu::gasm::done] [const -->] [arg t]]
+
+This command finalizes the creation of an instruction sequence and
+then clears the state of the assembler.
+[emph NOTE] that this [emph {does not}] delete any of the created
+instructions. They can be made available to future begin/done cycles.
+Further assembly will be possible only after reinitialization of the
+system via [cmd ::grammar::me::cpu::gasm::begin].
+
+[para]
+
+Before the state is cleared selected references to selected
+instructions will be written to attributes of the node [arg n] in the
+tree [arg t].
+
+Which instructions are saved is [arg mode]-dependent. Both [arg mode]
+and the destination node [arg n] were specified during invokation of
+[cmd ::grammar::me::cpu::gasm::begin].
+
+[para]
+
+Independent of the mode a reference to the instruction labeled "entry"
+will be saved to the attribute [const gas::entry] of [arg n]. The
+reference to the node [arg n] will further be saved into the attribute
+"expr" of the "entry" instruction. Beyond that
+
+[list_begin definitions]
+
+[def [const halt]] A reference to the instruction labeled
+"exit/return" will be saved to the attribute [const gas::exit] of
+[arg n].
+
+[def [const okfail]] See [const halt].
+
+[def [const !okfail]] Reference to the two instructions labeled
+"exit/ok" and "exit/fail" will be saved to the attributes
+[const gas::exit::ok] and [const gas::exit::fail] of [arg n]
+respectively.
+
+[list_end]
+
+[para]
+
+The command returns the empy string as its result.
+
+[call [cmd ::grammar::me::cpu::gasm::state]]
+
+This command returns the current state of the assembler. Its format is
+not documented and considered to be internal to the package.
+
+[call [cmd ::grammar::me::cpu::gasm::state!] [arg s]]
+
+This command takes a serialized assembler state [arg s] as returned by
+[cmd ::grammar::me::cpu::gasm::state] and makes it the current state
+of the assembler.
+
+[para]
+
+[emph Note] that this may overwrite label definitions, however all
+non-conflicting label definitions in the state before are not touched
+and merged with [arg s].
+
+[para]
+
+The command returns the empty string as its result.
+
+[call [cmd ::grammar::me::cpu::gasm::lift] [arg t] [arg dst] [const =] [arg src]]
+
+This command operates on the tree [arg t]. It copies the contents of
+the attributes [const gas::entry], [const gas::exit::ok] and
+[const gas::exit::fail] from the node [arg src] to the node [arg dst].
+
+It returns the empty string as its result.
+
+[call [cmd ::grammar::me::cpu::gasm::Inline] [arg t] [arg node] [arg label]]
+
+This command links an instruction sequence created by an earlier
+begin/done pair into the current instruction sequence.
+
+[para]
+
+To this end it
+
+[list_begin enumerated]
+
+[enum] reads the instruction references from the attributes
+[const gas::entry], [const gas::exit::ok], and [const gas::exit::fail]
+from the node [arg n] of the tree [arg t] and makes them available to
+assembler und the labels [arg label]/entry, [arg label]/exit::ok, and
+[arg label]/exit::fail respectively.
+
+[enum] Creates an arc from the [term anchor] to the node labeled
+[arg label]/entry, and tags it with the current condition code.
+
+[enum] Makes the node labeled [arg label]/exit/ok the new [term anchor].
+
+[list_end]
+
+The command returns the empty string as its result.
+
+[call [cmd ::grammar::me::cpu::gasm::Cmd] [arg cmd] [opt [arg arg]...]]
+
+This is the basic command to add instructions to the graph.
+
+It creates a new instruction of type [arg cmd] with the given
+arguments [arg arg]...
+
+If the [term anchor] was defined it will also create an arc from the
+[term anchor] to the new instruction using the current condition code.
+
+After the call the new instruction will be the [term anchor] and the
+current condition code will be set to [const always].
+
+[para]
+
+The command returns the empty string as its result.
+
+[call [cmd ::grammar::me::cpu::gasm::Bra]]
+
+This is a convenience command to create a .BRA pseudo-instruction. It
+uses [cmd ::grammar::me::cpu::gasm::Cmd] to actually create the
+instruction and inherits its behaviour.
+
+[call [cmd ::grammar::me::cpu::gasm::Nop] [arg text]]
+
+This is a convenience command to create a .NOP pseudo-instruction. It
+uses [cmd ::grammar::me::cpu::gasm::Cmd] to actually create the
+instruction and inherits its behaviour.
+
+The [arg text] will be saved as the first and only argument of the new
+instruction.
+
+[call [cmd ::grammar::me::cpu::gasm::Note] [arg text]]
+
+This is a convenience command to create a .C pseudo-instruction,
+i.e. a comment. It uses [cmd ::grammar::me::cpu::gasm::Cmd] to
+actually create the instruction and inherits its behaviour.
+
+The [arg text] will be saved as the first and only argument of the new
+instruction.
+
+[call [cmd ::grammar::me::cpu::gasm::Jmp] [arg label]]
+
+This command creates an arc from the [term anchor] to the instruction
+labeled with [arg label], and tags with the the current condition
+code.
+
+[para]
+
+The command returns the empty string as its result.
+
+[call [cmd ::grammar::me::cpu::gasm::Exit]]
+
+This command creates an arc from the [term anchor] to one of the exit
+instructions, based on the operation mode (see
+[cmd ::grammar::me::cpu::gasm::begin]), and tags it with current
+condition code.
+
+[para]
+
+For mode [const okfail] it links to the instruction labeled either
+"exit/ok" or "exit/fail", depending on the current condition code, and
+tagging it with the current condition code
+
+For the other two modes it links to the instruction labeled
+"exit/return", tagging it condition code [const always], independent
+the current condition code.
+
+[para]
+
+The command returns the empty string as its result.
+
+[call [cmd ::grammar::me::cpu::gasm::Who] [arg label]]
+
+This command returns a reference to the instruction labeled with
+[arg label].
+
+[call [cmd ::grammar::me::cpu::gasm::/Label] [arg name]]
+
+This command labels the [term anchor] with [arg name].
+
+[emph Note] that an instruction can have more than one label.
+
+[para]
+
+The command returns the empty string as its result.
+
+[call [cmd ::grammar::me::cpu::gasm::/Clear]]
+
+This command clears the [term anchor], leaving it undefined, and
+further resets the current condition code to [const always].
+
+[para]
+
+The command returns the empty string as its result.
+
+[call [cmd ::grammar::me::cpu::gasm::/Ok]]
+
+This command sets the current condition code to [const ok].
+
+[para]
+
+The command returns the empty string as its result.
+
+[call [cmd ::grammar::me::cpu::gasm::/Fail]]
+
+This command sets the current condition code to [const fail].
+
+[para]
+
+The command returns the empty string as its result.
+
+[call [cmd ::grammar::me::cpu::gasm::/At] [arg name]]
+
+This command sets the [term anchor] to the instruction labeled with
+[arg name], and further resets the current condition code to
+[const always].
+
+[para]
+
+The command returns the empty string as its result.
+
+[call [cmd ::grammar::me::cpu::gasm::/CloseLoop]]
+
+This command marks the [term anchor] as the last instruction in a loop
+body, by creating the attribute [const LOOP].
+
+[para]
+
+The command returns the empty string as its result.
+
+[list_end]
+
+[vset CATEGORY grammar_me]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/grammar_me/gasm.tcl b/tcllib/modules/grammar_me/gasm.tcl
new file mode 100644
index 0000000..a42fd40
--- /dev/null
+++ b/tcllib/modules/grammar_me/gasm.tcl
@@ -0,0 +1,207 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Package description
+
+## (struct::)Graph based ME Assembler, for use in grammar
+## translations.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+namespace eval grammar::me::cpu::gasm {}
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+proc ::grammar::me::cpu::gasm::begin {g n {mode okfail} {note {}}} {
+ variable gas
+ array unset gas *
+
+ # (Re)initialize the assmebler state, create the framework nodes
+ # upon which we will hang all instructions on.
+
+ set gas(mode) $mode
+ set gas(node) $n
+ set gas(grap) $g
+ array set gas {last {} cond always}
+
+ Nop $note ; /Label entry ; /Clear
+ if {$mode eq "okfail"} {
+ Nop Exit'OK ; /Label exit/ok ; /Clear
+ Nop Exit'FAIL ; /Label exit/fail ; /Clear
+ } elseif {$mode eq "halt"} {
+ Cmd icf_halt ; /Label exit/return ; /Clear
+ } else {
+ Cmd icf_ntreturn ; /Label exit/return ; /Clear
+ }
+
+ /At entry
+ return
+}
+
+proc ::grammar::me::cpu::gasm::done {__ t} {
+ variable gas
+
+ # Save the framework nodes in a grammar tree and shut the
+ # assembler down.
+
+ $t set $gas(node) gas::entry $gas(_entry)
+
+ if {$gas(mode) eq "okfail"} {
+ $t set $gas(node) gas::exit::ok $gas(_exit/ok)
+ $t set $gas(node) gas::exit::fail $gas(_exit/fail)
+ } else {
+ $t set $gas(node) gas::exit $gas(_exit/return)
+ }
+
+ # Remember the node in the grammar tree which is responsible for
+ # this entry point.
+
+ $gas(grap) node set $gas(_entry) expr $gas(node)
+
+ array unset gas *
+ return
+}
+
+proc ::grammar::me::cpu::gasm::lift {t dst __ src} {
+
+ $t set $dst gas::entry [$t get $src gas::entry]
+ $t set $dst gas::exit::ok [$t get $src gas::exit::ok]
+ $t set $dst gas::exit::fail [$t get $src gas::exit::fail]
+ return
+}
+
+proc ::grammar::me::cpu::gasm::state {} {
+ variable gas
+ return [array get gas]
+}
+
+proc ::grammar::me::cpu::gasm::state! {s} {
+ variable gas
+ array set gas $s
+}
+
+proc ::grammar::me::cpu::gasm::Inline {t node label} {
+ variable gas
+
+ set gas(_${label}/entry) [$t get $node gas::entry]
+ set gas(_${label}/exit/ok) [$t get $node gas::exit::ok]
+ set gas(_${label}/exit/fail) [$t get $node gas::exit::fail]
+
+ __Link $gas(_${label}/entry) $gas(cond)
+ /At ${label}/exit/ok
+ return
+}
+
+proc ::grammar::me::cpu::gasm::Cmd {cmd args} {
+ variable gas
+
+ # Add a new instruction, and link it to the anchor. The created
+ # instruction becomes the new anchor.
+
+ upvar 0 gas(grap) g gas(last) anchor gas(cond) cond
+
+ set node [$g node insert]
+ $g node set $node instruction $cmd
+ $g node set $node arguments $args
+
+ if {$anchor ne ""} {__Link $node $cond}
+
+ set anchor $node
+ set cond always
+ return
+}
+
+proc ::grammar::me::cpu::gasm::Bra {} {
+ Cmd .BRA
+}
+
+proc ::grammar::me::cpu::gasm::Nop {{text {}}} {
+ Cmd .NOP $text
+}
+
+proc ::grammar::me::cpu::gasm::Note {text} {
+ Cmd .C $text
+}
+
+proc ::grammar::me::cpu::gasm::Jmp {label} {
+ variable gas
+ __Link $gas(_$label) $gas(cond)
+ return
+}
+
+proc ::grammar::me::cpu::gasm::Exit {} {
+ variable gas
+ if {$gas(mode) eq "okfail"} {
+ __Link $gas(_exit/$gas(cond)) $gas(cond)
+ } else {
+ __Link $gas(_exit/return) always
+ }
+ return
+}
+
+proc ::grammar::me::cpu::gasm::Who {label} {
+ variable gas
+ return $gas(_$label)
+}
+
+proc ::grammar::me::cpu::gasm::__Link {to cond} {
+ variable gas
+ upvar 0 gas(grap) g gas(last) anchor
+
+ set arc [$g arc insert $anchor $to]
+ $g arc set $arc condition $cond
+ return
+}
+
+proc ::grammar::me::cpu::gasm::/Label {name} {
+ variable gas
+ set gas(_$name) $gas(last)
+ return
+}
+
+proc ::grammar::me::cpu::gasm::/Clear {} {
+ variable gas
+ set gas(last) {}
+ set gas(cond) always
+ return
+}
+
+proc ::grammar::me::cpu::gasm::/Ok {} {
+ variable gas
+ set gas(cond) ok
+ return
+}
+
+proc ::grammar::me::cpu::gasm::/Fail {} {
+ variable gas
+ set gas(cond) fail
+ return
+}
+
+proc ::grammar::me::cpu::gasm::/At {name} {
+ variable gas
+ set gas(last) $gas(_$name)
+ set gas(cond) always
+ return
+}
+
+proc ::grammar::me::cpu::gasm::/CloseLoop {} {
+ variable gas
+ $gas(grap) node set $gas(last) LOOP .
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Interfacing
+
+namespace eval grammar::me::cpu::gasm {
+ namespace export begin done lift state state!
+ namespace export Inline Cmd Bra Nop Note Jmp Exit Who
+ namespace export /Label /Clear /Ok /Fail /At /CloseLoop
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide grammar::me::cpu::gasm 0.1
diff --git a/tcllib/modules/grammar_me/me_ast.man b/tcllib/modules/grammar_me/me_ast.man
new file mode 100644
index 0000000..2768ffa
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_ast.man
@@ -0,0 +1,134 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin grammar::me_ast n 0.1]
+[keywords {abstract syntax tree}]
+[keywords AST]
+[copyright {2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Grammar operations and usage}]
+[titledesc {Various representations of ASTs}]
+[category {Grammars and finite automata}]
+[description]
+
+This document specifies various representations for the
+
+[term {abstract syntax tree}]s (short [term AST]) generated by
+instances of ME virtual machines, independent of variant.
+
+Please go and read the document [syscmd grammar::me_intro] first if
+you do not know what a ME virtual machine is.
+
+[para]
+
+ASTs and all the representations we specify distinguish between two
+types of nodes, namely:
+
+[para]
+[list_begin definitions]
+
+[def Terminal]
+
+Terminal nodes refer to the terminal symbols found in the token
+stream. They are always leaf nodes. I.e. terminal nodes never have
+children.
+
+[def Nonterminal]
+
+Nonterminal nodes represent a nonterminal symbol of the grammar used
+during parsing. They can occur as leaf and inner nodes of the
+tree.
+
+[list_end]
+[para]
+
+Both types of nodes carry basic range information telling a user which
+parts of the input are covered by the node by providing the location
+of the first and last tokens found within the range. Locations are
+provided as non-negative integer offsets from the beginning of the
+token stream, with the first token found in the stream located at
+offset 0 (zero).
+
+[para]
+
+The root of an AS tree can be either a terminal or nonterminal node.
+
+[section {AST VALUES}]
+
+This representation of ASTs is a Tcl list. The main list represents
+the root node of the tree, with the representations of the children
+nested within.
+
+[para]
+
+Each node is represented by a single Tcl list containing three or more
+elements. The first element is either the empty string or the name of
+a nonterminal symbol (which is never the empty string). The second and
+third elements are then the locations of the first and last tokens.
+
+Any additional elements after the third are then the representations
+of the children, with the leftmost child first, i.e. as the fourth
+element of the list representing the node.
+
+[section {AST OBJECTS}]
+
+In this representation an AST is represented by a Tcl object command
+whose API is compatible to the tree objects provided by the package
+[package struct::tree]. I.e it has to support at least all of the
+methods described by that package, and may support more.
+
+[para]
+
+Because of this the remainder of the specifications is written using
+the terms of [package struct::tree].
+
+[para]
+
+Each node of the AST directly maps to a node in the tree object. All
+data beyond the child nodes, i.e. node type and input locations, are
+stored in attributes of the node in the tree object. They are:
+
+[list_begin definitions]
+[def type]
+
+The type of the AST node. The recognized values are [const terminal]
+and [const nonterminal].
+
+[def range]
+
+The locations of the first and last token of the terminal data in the
+input covered by the node. This is a list containing two locations.
+
+[def detail]
+
+This attribute is present only for nonterminal nodes. It contains the
+name of the nonterminal symbol stored in the node.
+
+[list_end]
+
+[section {EXTENDED AST OBJECTS}]
+
+Extended AST objects are like AST objects, with additional
+information.
+
+[list_begin definitions]
+
+[def detail]
+
+This attribute is now present at all nodes. Its contents are unchanged
+for nonterminal nodes. For terminal nodes it contains a list
+describing all tokens from the input which are covered by the node.
+
+[para]
+
+Each element of the list contains the token name, the associated
+lexeme attribute, line number, and column index, in this order.
+
+[def range_lc]
+
+This new attribute is defined for all nodes, and contains the
+locations from attribute [term range] translated into line number and
+column index. Lines are counted from 1, columns are counted from 0.
+
+[list_end]
+
+[vset CATEGORY grammar_me]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/grammar_me/me_cpu.man b/tcllib/modules/grammar_me/me_cpu.man
new file mode 100644
index 0000000..5961cf3
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_cpu.man
@@ -0,0 +1,289 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin grammar::me::cpu n 0.2]
+[keywords grammar]
+[keywords parsing]
+[keywords {virtual machine}]
+[copyright {2005-2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Grammar operations and usage}]
+[titledesc {Virtual machine implementation II for parsing token streams}]
+[category {Grammars and finite automata}]
+[require Tcl 8.4]
+[require grammar::me::cpu [opt 0.2]]
+[description]
+[para]
+
+This package provides an implementation of the ME virtual machine.
+
+Please go and read the document [syscmd grammar::me_intro] first if
+you do not know what a ME virtual machine is.
+
+[para]
+
+This implementation provides an object-based API and the machines are
+not truly tied to Tcl. A C implementation of the same API is quite
+possible.
+
+[para]
+
+Internally the package actually uses the value-based machine
+manipulation commands as provided by the package
+
+[package grammar::me::cpu::core] to perform its duties.
+
+[section API]
+[subsection {CLASS API}]
+
+The package directly provides only a single command for the
+construction of ME virtual machines.
+
+[list_begin definitions]
+
+[call [cmd ::grammar::me::cpu] [arg meName] [arg matchcode]]
+
+The command creates a new ME machine object with an associated global
+Tcl command whose name is [arg meName]. This command may be used to
+invoke various operations on the machine.
+
+It has the following general form:
+
+[list_begin definitions]
+[call [cmd meName] [method option] [opt [arg "arg arg ..."]]]
+
+[arg Option] and the [arg arg]s determine the exact behavior of the
+command.
+
+[list_end]
+[para]
+
+The argument [arg matchcode] contains the match instructions the
+machine has to execute while parsing the input stream. Please read
+section [sectref-external {MATCH CODE REPRESENTATION}] of the
+documentation for the package [package grammar::me::cpu::core] for
+the specification of the structure of this value.
+
+[para]
+
+The [arg tokmap] argument taken by the implementation provided by the
+package [package grammar::me::tcl] is here hidden inside of the match
+instructions and therefore not needed.
+
+[list_end]
+[para]
+
+[subsection {OBJECT API}]
+
+All ME virtual machine objects created by the class command specified
+in section [sectref {CLASS API}] support the methods listed below.
+
+[para]
+
+The machines provided by this package provide methods for operation in
+both push- and pull-styles. Push-style means that tokens are pushed
+into the machine state when they arrive, triggering further execution
+until they are consumed. In other words, this allows the machine to be
+suspended and resumed at will and an arbitrary number of times, the
+quasi-parallel operation of several machines, and the operation as
+part of the event loop.
+
+[list_begin definitions]
+[call [arg meName] [method lc] [arg location]]
+
+This method converts the location of a token given as offset in the
+input stream into the associated line number and column index. The
+result of the command is a 2-element list containing the two values,
+in the order mentioned in the previous sentence.
+
+This allows higher levels to convert the location information found in
+the error status and the generated AST into more human readable data.
+
+[para]
+
+[emph Note] that the command is not able to convert locations which
+have not been reached by the machine yet. In other words, if the
+machine has read 7 tokens the command is able to convert the offsets
+[const 0] to [const 6], but nothing beyond that. This also shows that
+it is not possible to convert offsets which refer to locations before
+the beginning of the stream.
+
+[call [arg meName] [method tok] [opt "[arg from] [opt [arg to]]"]]
+
+This method returns a Tcl list containing the part of the input stream
+between the locations [arg from] and [arg to] (both inclusive). If
+[arg to] is not specified it will default to the value of [arg from].
+If [arg from] is not specified either the whole input stream is returned.
+
+[para]
+
+Each element of the returned list is a list of four elements, the
+token, its associated lexeme, line number, and column index, in this
+order.
+
+This command places the same restrictions on its location arguments as
+the method [method lc].
+
+[call [arg meName] [method pc] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the current value of the stored program counter.
+
+[call [arg meName] [method iseof] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the current value of the stored eof flag.
+
+[call [arg meName] [method at] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the current location in the input stream.
+
+[call [arg meName] [method cc] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the current token.
+
+[call [arg meName] [method sv]]
+
+This command returns the current semantic value [term SV] stored in
+the machine. This is an abstract syntax tree as specified in the
+document [syscmd grammar::me_ast], section [sectref-external {AST VALUES}].
+
+[call [arg meName] [method ok]]
+
+This method returns the current match status [term OK].
+
+[call [arg meName] [method error]]
+
+This method returns the current error status [term ER].
+
+[call [arg meName] [method lstk] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the location stack.
+
+[call [arg meName] [method astk] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the AST stack.
+
+[call [arg meName] [method mstk] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the AST marker stack.
+
+[call [arg meName] [method estk] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the error stack.
+
+[call [arg meName] [method rstk] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the subroutine return stack.
+
+[call [arg meName] [method nc] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the nonterminal match cache as a dictionary.
+
+[call [arg meName] [method ast]]
+
+This method returns the current top entry of the AST stack [term AS].
+
+This is an abstract syntax tree as specified in the document
+[syscmd grammar::me_ast], section [sectref-external {AST VALUES}].
+
+[call [arg meName] [method halted]]
+
+This method returns a boolean value telling the caller whether the
+engine has halted execution or not. Halt means that no further
+matching is possible, and the information retrieved via the other
+method is final. Attempts to [method run] the engine will be ignored,
+until a [method reset] is made.
+
+[call [arg meName] [method code]]
+
+This method returns the [arg code] information used to construct the
+object. In other words, the match program executed by the machine.
+
+[call [arg meName] [method eof]]
+
+This method adds an end of file marker to the end of the input stream.
+This signals the machine that the current contents of the input queue
+are the final parts of the input and nothing will come after. Attempts
+to put more characters into the queue will fail.
+
+[call [arg meName] [method put] [arg tok] [arg lex] [arg line] [arg col]]
+
+This method adds the token [arg tok] to the end of the input stream,
+with associated lexeme data [arg lex] and [arg line]/[arg col]umn
+information.
+
+[call [arg meName] [method putstring] [arg string] [arg lvar] [arg cvar]]
+
+This method adds each individual character in the [arg string] as a
+token to the end of the input stream, from first to last. The lexemes
+will be empty and the line/col information is computed based on the
+characters encountered and the data in the variables [arg lvar] and
+[arg cvar].
+
+[call [arg meName] [method run] [opt [arg n]]]
+
+This methods causes the engine to execute match instructions until
+either
+
+[list_begin itemized]
+[item] [arg n] instructions have been executed, or
+[item] a halt instruction was executed, or
+[item]
+the input queue is empty and the code is asking for more tokens to
+process.
+[list_end]
+[para]
+
+If no limit [arg n] was set only the last two conditions are checked
+for.
+
+[call [arg meName] [method pull] [arg nextcmd]]
+
+This method implements pull-style operation of the machine. It causes
+it to execute match instructions until either a halt instruction is
+reached, or the command prefix
+
+[arg nextcmd] ceases to deliver more tokens.
+
+[para]
+
+The command prefix [arg nextcmd] represents the input stream of
+characters and is invoked by the machine whenever the a new character
+from the stream is required. The instruction for handling this is
+[term ict_advance].
+
+The callback has to return either the empty list, or a list of 4
+elements containing the token, its lexeme attribute, and its location
+as line number and column index, in this order.
+
+The empty list is the signal that the end of the input stream has been
+reached. The lexeme attribute is stored in the terminal cache, but
+otherwise not used by the machine.
+
+[para]
+
+The end of the input stream for this method does not imply that method
+[method eof] is called for the machine as a whole. By avoiding this
+and still asking for an explicit call of the method it is possible to
+mix push- and pull-style operation during the lifetime of the machine.
+
+[call [arg meName] [method reset]]
+
+This method resets the machine to its initial state, discarding any
+state it may have.
+
+[call [arg meName] [method destroy]]
+
+This method deletes the object and releases all resurces it claimed.
+
+[list_end]
+
+[vset CATEGORY grammar_me]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/grammar_me/me_cpu.tcl b/tcllib/modules/grammar_me/me_cpu.tcl
new file mode 100644
index 0000000..89d7eae
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_cpu.tcl
@@ -0,0 +1,103 @@
+# -*- tcl -*-
+# (C) 2005-2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# ### ### ### ######### ######### #########
+## Package description
+
+## Implementation of ME virtual machines, object-based API to the
+## state values provided by "grammar::me::cpu::core".
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require snit
+package require grammar::me::cpu::core
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+snit::type ::grammar::me::cpu {
+ constructor {code_} {
+ # The 'core new' call validates the code as well.
+
+ set state [core::new $code_]
+ return
+ }
+
+ method lc {location} {return [core::lc $state $location]}
+ method tok {args} {return [eval [linsert $args 0 core::tok $state]]}
+ method pc {} {return [core::pc $state]}
+ method iseof {} {return [core::iseof $state]}
+ method at {} {return [core::at $state]}
+ method cc {} {return [core::cc $state]}
+ method sv {} {return [core::sv $state]}
+ method ok {} {return [core::ok $state]}
+ method error {} {return [core::error $state]}
+ method lstk {} {return [core::lstk $state]}
+ method astk {} {return [core::astk $state]}
+ method mstk {} {return [core::mstk $state]}
+ method estk {} {return [core::estk $state]}
+ method rstk {} {return [core::rstk $state]}
+ method nc {} {return [core::nc $state]}
+ method ast {} {return [core::ast $state]}
+ method halted {} {return [core::halted $state]}
+ method code {} {return [core::code $state]}
+
+ method eof {} {
+ core::eof state
+ return
+ }
+
+ method put {tok lex line col} {
+ core::put state $tok $lex $line $col
+ return
+ }
+
+ method putstring {str lvar cvar} {
+ upvar 1 $lvar line $cvar col
+ foreach ch [split $str {}] {
+ core::put state $ch {} $line $col
+ if {$ch eq "\n"} {
+ incr line
+ set col 0
+ } else {
+ incr col
+ }
+ }
+ return
+ }
+
+ method run {{n -1}} {
+ core::run state $n
+ return
+ }
+
+ method pull {next} {
+ while {1} {
+ core::run state
+ if {[core::halted $state]} break
+
+ set tokdata [uplevel \#0 $next]
+ if {![llength $tokdata]} break
+ if {[llength $tokdata] != 4} {
+ return -code error "Bad callback result, expected 4 elements"
+ }
+ foreach {tok lex line col} $tokdata break
+ core::put state $tok $lex $line $col
+ }
+ }
+
+ method reset {} {
+ set state [core::new [core::code $state]]
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Data structures
+
+ variable state ; # State of ME cpu handled here.
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide grammar::me::cpu 0.2
diff --git a/tcllib/modules/grammar_me/me_cpu.test b/tcllib/modules/grammar_me/me_cpu.test
new file mode 100644
index 0000000..3555ab2
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_cpu.test
@@ -0,0 +1,162 @@
+# me_cpucore.test: Tests for the ME virtual machine -*- tcl -*-
+#
+# This file contains a collection of tests for one or more of the
+# commands making up the ME virtual machine. Sourcing this file into
+# Tcl runs the tests and generates output for errors. No output means
+# no errors were found.
+#
+# Copyright (c) 2005-2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: me_cpu.test,v 1.3 2006/10/09 21:41:40 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.1
+
+support {
+ use fileutil/fileutil.tcl fileutil
+ useLocal me_cpucore.tcl grammar::me::cpu::core
+}
+testing {
+ useLocalKeep me_cpu.tcl grammar::me::cpu
+}
+
+# -------------------------------------------------------------------------
+
+snitErrors
+
+proc cpustate {cpu} {
+ set vstate {}
+ lappend vstate cd [$cpu code ]
+ lappend vstate pc [$cpu pc ]
+ lappend vstate ht [$cpu halted]
+ lappend vstate eo [$cpu iseof ]
+ lappend vstate tc [$cpu tok ]
+ lappend vstate at [$cpu at ]
+ lappend vstate cc [$cpu cc ]
+ lappend vstate ok [$cpu ok ]
+ lappend vstate sv [$cpu sv ]
+ lappend vstate er [$cpu error ]
+ lappend vstate ls [$cpu lstk ]
+ lappend vstate as [$cpu astk ]
+ lappend vstate ms [$cpu mstk ]
+ lappend vstate es [$cpu estk ]
+ lappend vstate rs [$cpu rstk ]
+ lappend vstate nc [$cpu nc ]
+ return $vstate
+}
+
+proc cpudelta {prev now} {
+ array set _ {}
+ foreach {k v} $prev {
+ set _($k) $v
+ }
+ set res {}
+ foreach {k v} $now {
+ if {[info exists _($k)] && ($_($k) eq $v)} continue
+ lappend res $k $v
+ }
+ return $res
+}
+
+proc cpufstate {vstate} {
+ set res {}
+ foreach {k v} $vstate {lappend res [list $k $v]}
+ join $res \n
+}
+
+proc cpusubst {vstate args} {
+ array set _ $vstate
+ foreach {k v} $args {set _($k) $v}
+ set res {}
+ foreach k {cd pc ht eo tc at cc ok sv er ls as ms es rs nc} {
+ if {![info exists _($k)]} continue
+ lappend res $k $_($k)
+ }
+ return $res
+}
+
+proc cpufilter {vstate args} {
+ array set _ $vstate
+ set res {}
+ foreach k $args { lappend res $k $_($k) }
+ return $res
+}
+
+proc canon_code {code} {
+ foreach {i p t} $code break
+ # Sorting the token map, canonical rep for direct comparison
+ return [list $i $p [dictsort $t]]
+}
+
+# -------------------------------------------------------------------------
+
+set asm_table [string trimright \
+ [fileutil::cat \
+ [localPath me_cpucore.tests.asm-map.txt]]]
+
+set badmach_table [string trimright \
+ [fileutil::cat \
+ [localPath me_cpucore.tests.badmach-map.txt]]]
+
+set semantics [string trimright \
+ [fileutil::cat \
+ [localPath me_cpucore.tests.semantics.txt]]]
+
+# -------------------------------------------------------------------------
+# In this section we run all the tests depending on a grammar::me::cpu::core,
+# and thus have to test all the available implementations.
+
+set tests [file join [file dirname [info script]] me_cpu.testsuite]
+
+catch {memory validate on}
+
+set impl tcl
+set usec [time {source $tests} 1]
+
+if 0 {
+ foreach impl [grammar::me::cpu::core::Implementations] {
+ grammar::me::cpu::core::SwitchTo $impl
+
+ # The global variable 'impl' is part of the public API the
+ # testsuit (in htmlparse_tree.testsuite) can expect from the
+ # environment.
+
+ namespace import -force grammar::me::cpu::core
+
+ set usec [time {source $tests} 1]
+
+ #puts "$impl:\t$usec"
+ }
+}
+
+catch {memory validate off}
+
+unset usec
+unset tests
+
+#puts ""
+
+# Reset system to fully inactive state.
+# grammar::me::cpu::core::SwitchTo {}
+
+# -------------------------------------------------------------------------
+
+# ### ### ### ######### ######### #########
+## Cleanup and statistics.
+
+rename cpustate {}
+rename cpufstate {}
+rename cpudelta {}
+rename cpufilter {}
+rename canon_code {}
+
+unset asm_table badmach_table semantics
+
+testsuiteCleanup
diff --git a/tcllib/modules/grammar_me/me_cpu.testsuite b/tcllib/modules/grammar_me/me_cpu.testsuite
new file mode 100644
index 0000000..9d4f8a7
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_cpu.testsuite
@@ -0,0 +1,445 @@
+# -*- tcl -*- me_cpu.test
+# ### ### ### ######### ######### #########
+
+# ### ### ### ######### ######### #########
+## Cpu creation.
+
+test me-cpu-new-${impl}-1.0 {new, wrong args} -body {
+ grammar::me::cpu cpu
+} -result {Error in constructor: wrong # args: should be "::grammar::me::cpu::Snit_constructor type selfns win self code_"} \
+ -returnCodes error
+
+test me-cpu-new-${impl}-1.1 {new, wrong args} -body {
+ grammar::me::cpu cpu a b
+} -result {Error in constructor: wrong # args: should be "::grammar::me::cpu::Snit_constructor type selfns win self code_"} \
+ -returnCodes error
+
+test me-cpu-run-${impl}-2.0 run -setup {
+ grammar::me::cpu cpu {{} {} {}}
+} -body {
+ cpu run
+} -cleanup {
+ cpu destroy
+} -returnCodes error -result {No instructions to execute}
+
+set n -1
+foreach {cmd cargs expected} $asm_table {
+ set asm [list [linsert $cargs 0 branchlabel $cmd]]
+ incr n
+
+ test me-cpu-new-${impl}-3.$n "new, $cmd, code" -body {
+ grammar::me::cpu cpu \
+ [canon_code [grammar::me::cpu::core::asm $asm]]
+ cpu code
+ } -cleanup {
+ cpu destroy
+ } -result $expected
+
+ test me-cpu-new-${impl}-4.$n "new, $cmd, state" -body {
+ grammar::me::cpu cpu \
+ [canon_code [grammar::me::cpu::core::asm $asm]]
+ cpusubst [cpustate cpu] cd {}
+ } -cleanup {
+ cpu destroy
+ } -result {cd {} pc 0 ht 0 eo 0 tc {} at -1 cc {} ok 0 sv {} er {} ls {} as {} ms {} es {} rs {} nc {}}
+}
+
+set n -1
+foreach {insns expected} $badmach_table {
+ incr n
+
+ test me-cpu-new-${impl}-5.$n "new error" -body {
+ grammar::me::cpu cpu $insns
+ } -result "Error in constructor: $expected" -returnCodes error
+}
+
+# ### ### ### ######### ######### #########
+## CPU manipulation - Add tokens I
+
+test me-cpu-put-${impl}-1.0 {put, wrong args} -setup {
+ grammar::me::cpu cpu {{} {} {}}
+} -body {
+ cpu put
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result [snitWrongNumArgs cpu ::grammar::me::cpu::Snit_methodput {tok lex line col} 0]
+
+test me-cpu-put-${impl}-1.1 {put, wrong args} -setup {
+ grammar::me::cpu cpu {{} {} {}}
+} -body {
+ cpu put a
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result [snitWrongNumArgs cpu ::grammar::me::cpu::Snit_methodput {tok lex line col} 1]
+
+test me-cpu-put-${impl}-1.2 {put, wrong args} -setup {
+ grammar::me::cpu cpu {{} {} {}}
+} -body {
+ cpu put a b
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result [snitWrongNumArgs cpu ::grammar::me::cpu::Snit_methodput {tok lex line col} 2]
+
+test me-cpu-put-${impl}-1.3 {put, wrong args} -setup {
+ grammar::me::cpu cpu {{} {} {}}
+} -body {
+ cpu put a b c
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result [snitWrongNumArgs cpu ::grammar::me::cpu::Snit_methodput {tok lex line col} 3]
+
+test me-cpu-put-${impl}-1.4 {put, wrong args} -setup {
+ grammar::me::cpu cpu {{} {} {}}
+} -body {
+ cpu put a b c d e
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result [snitTooManyArgs cpu ::grammar::me::cpu::Snit_methodput {tok lex line col}]
+
+test me-cpu-put-${impl}-2.0 put -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ set base [cpustate cpu]
+} -body {
+ cpu put ID ident 1 0
+ cpu put NUM 12345 1 5
+ cpudelta $base [cpustate cpu]
+} -cleanup {
+ cpu destroy
+ unset base
+} -result {tc {{ID ident 1 0} {NUM 12345 1 5}}}
+
+test me-cpu-put-${impl}-3.0 {put after eof} -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu eof
+} -body {
+ cpu put ID ident 1 0
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result {Cannot add input data after eof}
+
+
+# ### ### ### ######### ######### #########
+## CPU manipulation - Add tokens II
+
+test me-cpu-putstring-${impl}-1.0 {putstring, wrong args} -setup {
+ grammar::me::cpu cpu {{} {} {}}
+} -body {
+ cpu putstring
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result [snitWrongNumArgs cpu ::grammar::me::cpu::Snit_methodputstring {str lvar cvar} 0]
+
+test me-cpu-putstring-${impl}-1.1 {putstring, wrong args} -setup {
+ grammar::me::cpu cpu {{} {} {}}
+} -body {
+ cpu putstring a
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result [snitWrongNumArgs cpu ::grammar::me::cpu::Snit_methodputstring {str lvar cvar} 1]
+
+test me-cpu-putstring-${impl}-1.2 {putstring, wrong args} -setup {
+ grammar::me::cpu cpu {{} {} {}}
+} -body {
+ cpu putstring a b
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result [snitWrongNumArgs cpu ::grammar::me::cpu::Snit_methodputstring {str lvar cvar} 2]
+
+test me-cpu-putstring-${impl}-1.3 {putstring, wrong args} -setup {
+ grammar::me::cpu cpu {{} {} {}}
+} -body {
+ cpu putstring a b c d
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result [snitTooManyArgs cpu ::grammar::me::cpu::Snit_methodputstring {str lvar cvar}]
+
+test me-cpu-putstring-${impl}-2.0 put -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ set base [cpustate cpu]
+ set l 0
+ set c 0
+} -body {
+ cpu putstring ID l c
+ list $l $c [cpudelta $base [cpustate cpu]]
+} -cleanup {
+ cpu destroy
+ unset base
+} -result {0 2 {tc {{I {} 0 0} {D {} 0 1}}}}
+
+test me-cpu-putstring-${impl}-3.0 {put after eof} -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu eof
+ set l 0
+ set c 0
+} -body {
+ cpu putstring ID l c
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result {Cannot add input data after eof}
+
+# ### ### ### ######### ######### #########
+## State manipulation - Set eof
+
+test me-cpu-eof-${impl}-1.0 {eof, wrong args} -setup {
+ grammar::me::cpu cpu {{} {} {}}
+} -body {
+ cpu eof x
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result [snitTooManyArgs cpu ::grammar::me::cpu::Snit_methodeof {}]
+
+test me-cpu-eof-${impl}-2.0 eof -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ set base [cpustate cpu]
+} -body {
+ cpu eof
+ cpudelta $base [cpustate cpu]
+} -cleanup {
+ cpu destroy
+} -result {eo 1}
+
+# ### ### ### ######### ######### #########
+## State accessors - line/col retrieval
+
+test me-cpu-lc-${impl}-1.0 {lc, wrong args} -setup {
+ grammar::me::cpu cpu {{} {} {}}
+} -body {
+ cpu lc
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result [snitWrongNumArgs cpu ::grammar::me::cpu::Snit_methodlc {location} 0]
+
+test me-cpu-lc-${impl}-1.1 {lc, wrong args} -setup {
+ grammar::me::cpu cpu {{} {} {}}
+} -body {
+ cpu lc a b
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result [snitTooManyArgs cpu ::grammar::me::cpu::Snit_methodlc {location}]
+
+test me-cpu-lc-${impl}-2.0 lc -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put NUM 12345 1 5
+} -body {
+ cpu lc 0
+} -cleanup {
+ cpu destroy
+} -result {1 5}
+
+test me-cpu-lc-${impl}-3.0 {lc, bad index} -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put NUM 12345 1 5
+} -body {
+ cpu lc -1
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result {Illegal location -1}
+
+test me-cpu-lc-${impl}-3.1 {lc, bad index} -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put NUM 12345 1 5
+} -body {
+ cpu lc 1
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result {Illegal location 1}
+
+test me-cpu-lc-${impl}-3.2 {lc, bad index} -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+} -body {
+ cpu lc 0
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result {Illegal location 0}
+
+# ### ### ### ######### ######### #########
+## State accessors - Token retrieval
+
+test me-cpu-tok-${impl}-1.0 {tok, wrong args} -setup {
+ grammar::me::cpu cpu {{} {} {}}
+} -body {
+ cpu tok a b c
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result {wrong # args: should be "grammar::me::cpu::core::tok state ?from ?to??"}
+
+test me-cpu-tok-${impl}-2.0 tok -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+} -body {
+ cpu tok
+} -cleanup {
+ cpu destroy
+} -result {}
+
+test me-cpu-tok-${impl}-2.1 tok -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put NUM 12345 1 5
+} -body {
+ cpu tok
+} -cleanup {
+ cpu destroy
+} -result {{NUM 12345 1 5}}
+
+test me-cpu-tok-${impl}-2.2 tok -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put ID lalal 0 0
+ cpu put NUM 12345 1 5
+} -body {
+ cpu tok
+} -cleanup {
+ cpu destroy
+} -result {{ID lalal 0 0} {NUM 12345 1 5}}
+
+test me-cpu-tok-${impl}-3.0 tok -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+} -body {
+ cpu tok 0
+} -cleanup {
+ cpu destroy
+} -result {Illegal location 0} -returnCodes error
+
+test me-cpu-tok-${impl}-3.1 tok -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put NUM 12345 1 5
+} -body {
+ cpu tok -1
+} -cleanup {
+ cpu destroy
+} -result {Illegal location -1} -returnCodes error
+
+test me-cpu-tok-${impl}-3.2 tok -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put NUM 12345 1 5
+} -body {
+ cpu tok 1
+} -cleanup {
+ cpu destroy
+} -result {Illegal location 1} -returnCodes error
+
+test me-cpu-tok-${impl}-3.3 tok -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put NUM 12345 1 5
+} -body {
+ cpu tok 0
+} -cleanup {
+ cpu destroy
+} -result {{NUM 12345 1 5}}
+
+test me-cpu-tok-${impl}-3.4 tok -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put ID lalal 0 0
+ cpu put NUM 12345 1 5
+} -body {
+ cpu tok 0
+} -cleanup {
+ cpu destroy
+} -result {{ID lalal 0 0}}
+
+test me-cpu-tok-${impl}-4.0 tok -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put NUM 12345 1 5
+} -body {
+ cpu tok -1 0
+} -cleanup {
+ cpu destroy
+} -result {Illegal start location -1} -returnCodes error
+
+test me-cpu-tok-${impl}-4.1 tok -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put NUM 12345 1 5
+} -body {
+ cpu tok 1 0
+} -cleanup {
+ cpu destroy
+} -result {Illegal start location 1} -returnCodes error
+
+test me-cpu-tok-${impl}-4.2 tok -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put NUM 12345 1 5
+} -body {
+ cpu tok 0 -1
+} -cleanup {
+ cpu destroy
+} -result {Illegal end location -1} -returnCodes error
+
+test me-cpu-tok-${impl}-4.3 tok -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put NUM 12345 1 5
+} -body {
+ cpu tok 0 1
+} -cleanup {
+ cpu destroy
+} -result {Illegal end location 1} -returnCodes error
+
+test me-cpu-tok-${impl}-4.4 tok -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put ID lalal 0 0
+ cpu put NUM 12345 1 5
+} -body {
+ cpu tok 1 0
+} -cleanup {
+ cpu destroy
+} -result {Illegal empty location range 1 .. 0} -returnCodes error
+
+test me-cpu-tok-${impl}-4.5 tok -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put ID lalal 0 0
+ cpu put NUM 12345 1 5
+} -body {
+ cpu tok 0 1
+} -cleanup {
+ cpu destroy
+} -result {{ID lalal 0 0} {NUM 12345 1 5}}
+
+test me-cpu-tok-${impl}-4.6 tok -setup {
+ grammar::me::cpu cpu [canon_code [grammar::me::cpu::core::asm {}]]
+ cpu put ID lalal 0 0
+ cpu put ID lalal 0 0
+} -body {
+ cpu tok 0 0
+} -cleanup {
+ cpu destroy
+} -result {{ID lalal 0 0}}
+
+# ### ### ### ######### ######### #########
+## Checking the instruction semantics
+
+test me-cpu-run-${impl}-1.0 {run, wrong args} -setup {
+ grammar::me::cpu cpu {{} {} {}}
+} -body {
+ cpu run a b
+} -returnCodes error -cleanup {
+ cpu destroy
+} -result [snitTooManyArgs cpu ::grammar::me::cpu::Snit_methodrun {?n?}]
+
+set n -1
+foreach {description input eof stepsSetup steps code expectedDelta} $semantics {
+ incr n
+
+ if 0 {
+ puts ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ puts $description
+ puts "INPUT $input"
+ puts "EOF $eof"
+ puts "CODE $stepsSetup $steps $code"
+ puts $expectedDelta
+ }
+
+ test me-cpu-run-${impl}-2.$n "run $description" -setup {
+ grammar::me::cpu cpu $code
+ foreach token $input {
+ eval [linsert $token 0 cpu put]
+ # cpu put {*}$token
+ }
+ if {$eof} {cpu eof}
+ if {$stepsSetup} {cpu run $stepsSetup}
+ set save [cpustate cpu]
+ } -body {
+ cpu run $steps
+ cpudelta $save [cpustate cpu]
+ } -cleanup {
+ cpu destroy
+ } -result $expectedDelta
+}
+
+return
diff --git a/tcllib/modules/grammar_me/me_cpucore.man b/tcllib/modules/grammar_me/me_cpucore.man
new file mode 100644
index 0000000..b81c046
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_cpucore.man
@@ -0,0 +1,374 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin grammar::me::cpu::core n 0.2]
+[keywords grammar]
+[keywords parsing]
+[keywords {virtual machine}]
+[copyright {2005-2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Grammar operations and usage}]
+[titledesc {ME virtual machine state manipulation}]
+[category {Grammars and finite automata}]
+[require Tcl 8.4]
+[require grammar::me::cpu::core [opt 0.2]]
+[description]
+[para]
+
+This package provides an implementation of the ME virtual machine.
+
+Please go and read the document [syscmd grammar::me_intro] first if
+you do not know what a ME virtual machine is.
+
+[para]
+
+This implementation represents each ME virtual machine as a Tcl value
+and provides commands to manipulate and query such values to show the
+effects of executing instructions, adding tokens, retrieving state,
+etc.
+
+[para]
+
+The values fully follow the paradigm of Tcl that every value is a
+string and while also allowing C implementations for a proper
+Tcl_ObjType to keep all the important data in native data structures.
+
+Because of the latter it is recommended to access the state values
+[emph only] through the commands of this package to ensure that
+internal representation is not shimmered away.
+
+[para]
+
+The actual structure used by all state values is described in section
+[sectref {CPU STATE}].
+
+[section API]
+
+The package directly provides only a single command, and all the
+functionality is made available through its methods.
+
+[list_begin definitions]
+
+[call [cmd ::grammar::me::cpu::core] [method disasm] [arg asm]]
+
+This method returns a list containing a disassembly of the match
+instructions in [arg asm]. The format of [arg asm] is specified in the
+section [sectref {MATCH PROGRAM REPRESENTATION}].
+
+[para]
+
+Each element of the result contains instruction label, instruction
+name, and the instruction arguments, in this order. The label can be
+the empty string. Jump destinations are shown as labels, strings and
+tokens unencoded. Token names are prefixed with their numeric id, if,
+and only if a tokmap is defined. The two components are separated by a
+colon.
+
+[call [cmd ::grammar::me::cpu::core] [method asm] [arg asm]]
+
+This method returns code in the format as specified in section
+[sectref {MATCH PROGRAM REPRESENTATION}] generated from ME assembly
+code [arg asm], which is in the format as returned by the method
+[method disasm].
+
+[call [cmd ::grammar::me::cpu::core] [method new] [arg asm]]
+
+This method creates state value for a ME virtual machine in its
+initial state and returns it as its result.
+
+[para]
+
+The argument [arg matchcode] contains a Tcl representation of the
+match instructions the machine has to execute while parsing the input
+stream. Its format is specified in the section
+[sectref {MATCH PROGRAM REPRESENTATION}].
+
+[para]
+
+The [arg tokmap] argument taken by the implementation provided by the
+package [package grammar::me::tcl] is here hidden inside of the match
+instructions and therefore not needed.
+
+[call [cmd ::grammar::me::cpu::core] [method lc] [arg state] [arg location]]
+
+This method takes the state value of a ME virtual machine and uses it
+to convert a location in the input stream (as offset) into a line
+number and column index. The result of the method is a 2-element list
+containing the two pieces in the order mentioned in the previous
+sentence.
+
+[para]
+
+[emph Note] that the method cannot convert locations which the machine
+has not yet read from the input stream. In other words, if the machine
+has read 7 characters so far it is possible to convert the offsets
+[const 0] to [const 6], but nothing beyond that. This also shows that
+it is not possible to convert offsets which refer to locations before
+the beginning of the stream.
+
+[para]
+
+This utility allows higher levels to convert the location offsets
+found in the error status and the AST into more human readable data.
+
+[call [cmd ::grammar::me::cpu::core] [method tok] [arg state] [opt "[arg from] [opt [arg to]]"]]
+
+This method takes the state value of a ME virtual machine and returns
+a Tcl list containing the part of the input stream between the
+locations [arg from] and [arg to] (both inclusive). If [arg to] is not
+specified it will default to the value of [arg from]. If [arg from] is
+not specified either the whole input stream is returned.
+
+[para]
+
+This method places the same restrictions on its location arguments as
+the method [method lc].
+
+[call [cmd ::grammar::me::cpu::core] [method pc] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the current value of the stored program counter.
+
+[call [cmd ::grammar::me::cpu::core] [method iseof] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the current value of the stored eof flag.
+
+[call [cmd ::grammar::me::cpu::core] [method at] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the current location in the input stream.
+
+[call [cmd ::grammar::me::cpu::core] [method cc] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the current token.
+
+[call [cmd ::grammar::me::cpu::core] [method sv] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the current semantic value stored in it.
+
+This is an abstract syntax tree as specified in the document
+[syscmd grammar::me_ast], section [sectref-external {AST VALUES}].
+
+[call [cmd ::grammar::me::cpu::core] [method ok] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the match status stored in it.
+
+[call [cmd ::grammar::me::cpu::core] [method error] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the current error status stored in it.
+
+[call [cmd ::grammar::me::cpu::core] [method lstk] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the location stack.
+
+[call [cmd ::grammar::me::cpu::core] [method astk] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the AST stack.
+
+[call [cmd ::grammar::me::cpu::core] [method mstk] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the AST marker stack.
+
+[call [cmd ::grammar::me::cpu::core] [method estk] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the error stack.
+
+[call [cmd ::grammar::me::cpu::core] [method rstk] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the subroutine return stack.
+
+[call [cmd ::grammar::me::cpu::core] [method nc] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the nonterminal match cache as a dictionary.
+
+[call [cmd ::grammar::me::cpu::core] [method ast] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the abstract syntax tree currently at the top of the AST stack stored
+in it.
+
+This is an abstract syntax tree as specified in the document
+[syscmd grammar::me_ast], section [sectref-external {AST VALUES}].
+
+[call [cmd ::grammar::me::cpu::core] [method halted] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the current halt status stored in it, i.e. if the machine has stopped
+or not.
+
+[call [cmd ::grammar::me::cpu::core] [method code] [arg state]]
+
+This method takes the state value of a ME virtual machine and returns
+the code stored in it, i.e. the instructions executed by the machine.
+
+[call [cmd ::grammar::me::cpu::core] [method eof] [arg statevar]]
+
+This method takes the state value of a ME virtual machine as stored in
+the variable named by [arg statevar] and modifies it so that the eof
+flag inside is set. This signals to the machine that whatever token
+are in the input queue are the last to be processed. There will be no
+more.
+
+[call [cmd ::grammar::me::cpu::core] [method put] [arg statevar] [arg tok] [arg lex] [arg line] [arg col]]
+
+This method takes the state value of a ME virtual machine as stored in
+the variable named by [arg statevar] and modifies it so that the token
+[arg tok] is added to the end of the input queue, with associated
+lexeme data [arg lex] and [arg line]/[arg col]umn information.
+
+[para]
+
+The operation will fail with an error if the eof flag of the machine
+has been set through the method [method eof].
+
+[call [cmd ::grammar::me::cpu::core] [method run] [arg statevar] [opt [arg n]]]
+
+This method takes the state value of a ME virtual machine as stored in
+the variable named by [arg statevar], executes a number of
+instructions and stores the state resulting from their modifications
+back into the variable.
+
+[para]
+
+The execution loop will run until either
+
+[list_begin itemized]
+[item] [arg n] instructions have been executed, or
+[item] a halt instruction was executed, or
+[item]
+the input queue is empty and the code is asking for more tokens to
+process.
+[list_end]
+[para]
+
+If no limit [arg n] was set only the last two conditions are checked
+for.
+
+[list_end]
+
+[subsection {MATCH PROGRAM REPRESENTATION}]
+
+A match program is represented by nested Tcl list. The first element,
+[term asm], is a list of integer numbers, the instructions to execute,
+and their arguments. The second element, [term pool], is a list of
+strings, referenced by the instructions, for error messages, token
+names, etc. The third element, [term tokmap], provides ordering
+information for the tokens, mapping their names to their numerical
+rank. This element can be empty, forcing lexicographic comparison when
+matching ranges.
+
+[para]
+
+All ME instructions are encoded as integer numbers, with the mapping
+given below. A number of the instructions, those which handle error
+messages, have been given an additional argument to supply that
+message explicitly instead of having it constructed from token names,
+etc. This allows the machine state to store only the message ids
+instead of the full strings.
+
+[para]
+
+Jump destination arguments are absolute indices into the [term asm]
+element, refering to the instruction to jump to. Any string arguments
+are absolute indices into the [term pool] element. Tokens, characters,
+messages, and token (actually character) classes to match are coded as
+references into the [term pool] as well.
+
+[para]
+[list_begin enumerated]
+
+[enum] "[cmd ict_advance] [arg message]"
+[enum] "[cmd ict_match_token] [arg tok] [arg message]"
+[enum] "[cmd ict_match_tokrange] [arg tokbegin] [arg tokend] [arg message]"
+[enum] "[cmd ict_match_tokclass] [arg code] [arg message]"
+[enum] "[cmd inc_restore] [arg branchlabel] [arg nt]"
+[enum] "[cmd inc_save] [arg nt]"
+[enum] "[cmd icf_ntcall] [arg branchlabel]"
+[enum] "[cmd icf_ntreturn]"
+[enum] "[cmd iok_ok]"
+[enum] "[cmd iok_fail]"
+[enum] "[cmd iok_negate]"
+[enum] "[cmd icf_jalways] [arg branchlabel]"
+[enum] "[cmd icf_jok] [arg branchlabel]"
+[enum] "[cmd icf_jfail] [arg branchlabel]"
+[enum] "[cmd icf_halt]"
+[enum] "[cmd icl_push]"
+[enum] "[cmd icl_rewind]"
+[enum] "[cmd icl_pop]"
+[enum] "[cmd ier_push]"
+[enum] "[cmd ier_clear]"
+[enum] "[cmd ier_nonterminal] [arg message]"
+[enum] "[cmd ier_merge]"
+[enum] "[cmd isv_clear]"
+[enum] "[cmd isv_terminal]"
+[enum] "[cmd isv_nonterminal_leaf] [arg nt]"
+[enum] "[cmd isv_nonterminal_range] [arg nt]"
+[enum] "[cmd isv_nonterminal_reduce] [arg nt]"
+[enum] "[cmd ias_push]"
+[enum] "[cmd ias_mark]"
+[enum] "[cmd ias_mrewind]"
+[enum] "[cmd ias_mpop]"
+[list_end]
+
+[section {CPU STATE}]
+
+A state value is a list containing the following elements, in the order listed below:
+
+[list_begin enumerated]
+[enum] [term code]: Match instructions, see [sectref {MATCH PROGRAM REPRESENTATION}].
+[enum] [term pc]: Program counter, [term int].
+[enum] [term halt]: Halt flag, [term boolean].
+[enum] [term eof]: Eof flag, [term boolean]
+[enum] [term tc]: Terminal cache, and input queue. Structure see below.
+[enum] [term cl]: Current location, [term int].
+[enum] [term ct]: Current token, [term string].
+[enum] [term ok]: Match status, [term boolean].
+[enum] [term sv]: Semantic value, [term list].
+[enum] [term er]: Error status, [term list].
+[enum] [term ls]: Location stack, [term list].
+[enum] [term as]: AST stack, [term list].
+[enum] [term ms]: AST marker stack, [term list].
+[enum] [term es]: Error stack, [term list].
+[enum] [term rs]: Return stack, [term list].
+[enum] [term nc]: Nonterminal cache, [term dictionary].
+[list_end]
+[para]
+
+[term tc], the input queue of tokens waiting for processing and the
+terminal cache containing the tokens already processing are one
+unified data structure simply holding all tokens and their
+information, with the current location separating that which has been
+processed from that which is waiting.
+
+Each element of the queue/cache is a list containing the token, its
+lexeme information, line number, and column index, in this order.
+
+[para]
+
+All stacks have their top element aat the end, i.e. pushing an item is
+equivalent to appending to the list representing the stack, and
+popping it removes the last element.
+
+[para]
+
+[term er], the error status is either empty or a list of two elements,
+a location in the input, and a list of messages, encoded as references
+into the [term pool] element of the [term code].
+
+[para]
+
+[term nc], the nonterminal cache is keyed by nonterminal name and
+location, each value a four-element list containing current location,
+match status, semantic value, and error status, in this order.
+
+[vset CATEGORY grammar_me]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/grammar_me/me_cpucore.tcl b/tcllib/modules/grammar_me/me_cpucore.tcl
new file mode 100644
index 0000000..9a3a402
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_cpucore.tcl
@@ -0,0 +1,1156 @@
+# -*- tcl -*-
+# (C) 2005-2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# ### ### ### ######### ######### #########
+## Package description
+
+## Implementation of ME virtual machines based on state values
+## manipulated by the commands according to the match
+## instructions. Allows for implementation in C.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+namespace eval ::grammar::me::cpu::core {}
+
+# ### ### ### ######### ######### #########
+## Implementation, API. Ensemble command.
+
+proc ::grammar::me::cpu::core {cmd args} {
+ # Dispatcher for the ensemble command.
+ variable core::cmds
+ return [uplevel 1 [linsert $args 0 $cmds($cmd)]]
+}
+
+namespace eval grammar::me::cpu::core {
+ variable cmds
+
+ # Mapping from cmd names to procedures for quick dispatch. The
+ # objects will shimmer into resolved command references.
+
+ array set cmds {
+ disasm ::grammar::me::cpu::core::disasm
+ asm ::grammar::me::cpu::core::asm
+ new ::grammar::me::cpu::core::new
+ lc ::grammar::me::cpu::core::lc
+ tok ::grammar::me::cpu::core::tok
+ pc ::grammar::me::cpu::core::pc
+ iseof ::grammar::me::cpu::core::iseof
+ at ::grammar::me::cpu::core::at
+ cc ::grammar::me::cpu::core::cc
+ sv ::grammar::me::cpu::core::sv
+ ok ::grammar::me::cpu::core::ok
+ error ::grammar::me::cpu::core::error
+ lstk ::grammar::me::cpu::core::lstk
+ astk ::grammar::me::cpu::core::astk
+ mstk ::grammar::me::cpu::core::mstk
+ estk ::grammar::me::cpu::core::estk
+ rstk ::grammar::me::cpu::core::rstk
+ nc ::grammar::me::cpu::core::nc
+ ast ::grammar::me::cpu::core::ast
+ halted ::grammar::me::cpu::core::halted
+ code ::grammar::me::cpu::core::code
+ eof ::grammar::me::cpu::core::eof
+ put ::grammar::me::cpu::core::put
+ run ::grammar::me::cpu::core::run
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Ensemble implementation
+
+proc ::grammar::me::cpu::core::disasm {code} {
+ variable iname
+ variable tclass
+ variable anum
+
+ Validate $code ord dst jmp
+
+ set label 0
+ foreach k [array names jmp] {
+ set jmp($k) bra$label
+ incr label
+ }
+ foreach k [array names dst] {
+ if {![info exists jmp($k)]} {
+ set jmp($k) {}
+ }
+ }
+
+ set result {}
+ foreach {asm pool tokmap} $code break
+
+ set pc 0
+ set pcend [llength $asm]
+
+ while {$pc < $pcend} {
+ set base $pc
+ set insn [lindex $asm $pc] ; incr pc
+ set an [lindex $anum $insn]
+
+ if {$an == 1} {
+ set a [lindex $asm $pc] ; incr pc
+ } elseif {$an == 2} {
+ set a [lindex $asm $pc] ; incr pc
+ set b [lindex $asm $pc] ; incr pc
+ } elseif {$an == 3} {
+ set a [lindex $asm $pc] ; incr pc
+ set b [lindex $asm $pc] ; incr pc
+ set c [lindex $asm $pc] ; incr pc
+ }
+
+ set instruction {}
+ lappend instruction $jmp($base)
+ lappend instruction $iname($insn)
+
+ switch -exact $insn {
+ 0 - 5 - 20 - 24 - 25 - 26 -
+ a/string {
+ lappend instruction [lindex $pool $a]
+ }
+ 1 {
+ # a/tok b/string
+ if {![llength $tokmap]} {
+ lappend instruction [lindex $pool $a]
+ } else {
+ lappend instruction ${a}:$ord($a)
+ }
+ lappend instruction [lindex $pool $b]
+ }
+ 2 {
+ # a/tokstart b/tokend c/string
+ if {![llength $tokmap]} {
+ lappend instruction [lindex $pool $a]
+ lappend instruction [lindex $pool $b]
+ } else {
+ # tokmap defined: a = b = order rank.
+ lappend instruction ${a}:$ord($a)
+ lappend instruction ${b}:$ord($b)
+ }
+ lappend instruction [lindex $pool $c]
+ }
+ 3 {
+ # a/class(0-5) b/string
+ lappend instruction [lindex $tclass $a]
+ lappend instruction [lindex $pool $b]
+ }
+ 4 {
+ # a/branch b/string
+ lappend instruction $jmp($a)
+ lappend instruction [lindex $pool $b]
+ }
+ 6 - 11 - 12 - 13 -
+ a/branch {
+ lappend instruction $jmp($a)
+ }
+ default {}
+ }
+
+ lappend result $instruction
+ }
+
+ return $result
+}
+
+proc ::grammar::me::cpu::core::asm {code} {
+ variable iname
+ variable anum
+ variable tccode
+
+ # code = list(insn), insn = list (label insn-name ...)
+
+ # I. Indices for the labels, based on instruction sizes.
+
+ array set jmp {}
+ set off 0
+ foreach insn $code {
+ foreach {label name} $insn break
+ # Ignore embedded comments, except for labels
+ if {$label ne ""} {
+ set jmp($label) $off
+ }
+ if {$name eq ".C"} continue
+ if {![info exists iname($name)]} {
+ return -code error "Bad instruction \"$insn\", unknown command \"$name\""
+ }
+ set an [lindex $anum $iname($name)]
+ if {[llength $insn] != ($an+2)} {
+ return -code error "Bad instruction \"$insn\", expected $an argument[expr {$an == 1 ? "" : "s"}]"
+ }
+ incr off
+ incr off [lindex $anum $iname($name)]
+ }
+
+ set asm {}
+ set pool {}
+ array set poolh {}
+ array set tokmap {}
+ array set ord {}
+ set plain 0
+
+ foreach insn $code {
+ foreach {label name} $insn break
+ # Ignore embedded comments
+ if {$name eq ".C"} continue
+ set an [lindex $anum $iname($name)]
+
+ # Instruction code to assembly ...
+ lappend asm $iname($name)
+
+ # Encode arguments ...
+ switch -exact -- $name {
+ ict_advance -
+ inc_save -
+ ier_nonterminal -
+ isv_nonterminal_leaf -
+ isv_nonterminal_range -
+ isv_nonterminal_reduce {
+ lappend asm [Str [lindex $insn 2]]
+ }
+ ict_match_token {
+ lappend asm [Tok [lindex $insn 2]]
+ lappend asm [Str [lindex $insn 3]]
+ }
+ ict_match_tokrange {
+ lappend asm [Tok [lindex $insn 2]]
+ lappend asm [Tok [lindex $insn 3]]
+ lappend asm [Str [lindex $insn 4]]
+ }
+ ict_match_tokclass {
+ set ccode [lindex $insn 2]
+ if {![info exists tccode($ccode)]} {
+ return -code error "Bad instruction \"$insn\", unknown class code \"$ccode\""
+ }
+ lappend asm $tccode($ccode)
+ lappend asm [Str [lindex $insn 3]]
+
+ }
+ inc_restore {
+ set jmpto [lindex $insn 2]
+ if {![info exists jmp($jmpto)]} {
+ return -code error "Bad instruction \"$insn\", unknown branch destination \"$jmpto\""
+ }
+ lappend asm $jmp($jmpto)
+ lappend asm [Str [lindex $insn 3]]
+ }
+ icf_ntcall -
+ icf_jalways -
+ icf_jok -
+ icf_jfail {
+ set jmpto [lindex $insn 2]
+ if {![info exists jmp($jmpto)]} {
+ return -code error "Bad instruction \"$insn\", unknown branch destination \"$jmpto\""
+ }
+ lappend asm $jmp($jmpto)
+ }
+ }
+ }
+
+ return [list $asm $pool [array get tokmap]]
+}
+
+proc ::grammar::me::cpu::core::new {code} {
+ # The code generating the state is drawn out to integrate a
+ # specification of how the machine state is mapped to Tcl as well.
+
+ Validate $code
+
+ set state {} ; # The state is representend as a Tcl list.
+ # ### ### ### ######### ######### #########
+ lappend state $code ; # [_0] code - list - code to run (-)
+ lappend state 0 ; # [_1] pc - int - Program counter
+ lappend state 0 ; # [_2] halt - bool - Flag, set (internal) when machine was halted (icf_halt).
+ lappend state 0 ; # [_3] eof - bool - Flag, set (external) when where will be no more input.
+ lappend state {} ; # [_4] tc - list - Terminal cache, pending and processed tokens.
+ lappend state -1 ; # [_5] cl - int - Current Location
+ lappend state {} ; # [_6] ct - token - Current Character
+ lappend state 0 ; # [_7] ok - bool - Match Status
+ lappend state {} ; # [_8] sv - any - Semantic Value
+ lappend state {} ; # [_9] er - list - Error status (*)
+ lappend state {} ; # [10] ls - list - Location Stack (x)
+ lappend state {} ; # [11] as - list - Ast Stack
+ lappend state {} ; # [12] ms - list - Ast Marker Stack
+ lappend state {} ; # [13] es - list - Error Stack
+ lappend state {} ; # [14] rs - list - Return Stack
+ lappend state {} ; # [15] nc - dict - Nonterminal Cache (backtracking)
+ # ### ### ### ######### ######### #########
+
+ # tc = list(token)
+ # token = list(str lexeme line col)
+
+
+ # (-) See manpage of this package for the representation.
+
+ # (*) 2 elements, first is error location, second is list of
+ # ... strings, the error messages. The strings are actually
+ # ... represented by references into the pool element of the code.
+
+ # (x) Regarding the various stacks maintained in the state, their
+ # top element is always at the right end, i.e. the last
+ # element in the list representing it.
+
+ return $state
+}
+
+proc ::grammar::me::cpu::core::ntok {state} {
+ return [llength [lindex $state 4]]
+}
+
+proc ::grammar::me::cpu::core::lc {state loc} {
+ set tc [lindex $state 4]
+ set loc [INDEX $tc $loc "Illegal location"]
+ return [lrange [lindex $tc $loc] 2 3]
+ # result = list(line col)
+}
+
+proc ::grammar::me::cpu::core::tok {state args} {
+ if {[llength $args] > 2} {
+ return -code error {wrong # args: should be "grammar::me::cpu::core::tok state ?from ?to??"}
+ }
+ set tc [lindex $state 4]
+ if {[llength $args] == 0} {
+ return $tc
+ } elseif {[llength $args] == 1} {
+ set at [INDEX $tc [lindex $args 0] "Illegal location"]
+ return [lrange $tc $at $at]
+ } else {
+ set from [INDEX $tc [lindex $args 0] "Illegal start location"]
+ set to [INDEX $tc [lindex $args 1] "Illegal end location"]
+ if {$from > $to} {
+ return -code error "Illegal empty location range $from .. $to"
+ }
+ return [lrange $tc $from $to]
+ }
+ # result = list(token), token = list(str lex line col)
+}
+
+proc ::grammar::me::cpu::core::pc {state} {
+ return [lindex $state 1]
+}
+
+proc ::grammar::me::cpu::core::iseof {state} {
+ return [lindex $state 3]
+}
+
+proc ::grammar::me::cpu::core::at {state} {
+ return [lindex $state 5]
+}
+
+proc ::grammar::me::cpu::core::cc {state} {
+ return [lindex $state 6]
+}
+
+proc ::grammar::me::cpu::core::sv {state} {
+ return [lindex $state 8]
+}
+
+proc ::grammar::me::cpu::core::ok {state} {
+ return [lindex $state 7]
+}
+
+proc ::grammar::me::cpu::core::error {state} {
+ set er [lindex $state 9]
+ if {[llength $er]} {
+ foreach {l m} $er break
+
+ set pool [lindex $state 0 1] ; # state ->/0 code ->/1 pool
+ set mx {}
+ foreach id $m {
+ lappend mx [lindex $pool $id]
+ }
+ set er [list $l $mx]
+ }
+ return $er
+}
+
+proc ::grammar::me::cpu::core::lstk {state} {
+ return [lindex $state 10]
+}
+
+proc ::grammar::me::cpu::core::astk {state} {
+ return [lindex $state 11]
+}
+
+proc ::grammar::me::cpu::core::mstk {state} {
+ return [lindex $state 12]
+}
+
+proc ::grammar::me::cpu::core::estk {state} {
+ return [lindex $state 13]
+}
+
+proc ::grammar::me::cpu::core::rstk {state} {
+ return [lindex $state 14]
+}
+
+proc ::grammar::me::cpu::core::nc {state} {
+ return [lindex $state 15]
+}
+
+proc ::grammar::me::cpu::core::ast {state} {
+ return [lindex $state 11 end]
+}
+
+proc ::grammar::me::cpu::core::halted {state} {
+ return [lindex $state 2]
+}
+
+proc ::grammar::me::cpu::core::code {state} {
+ return [lindex $state 0]
+}
+
+proc ::grammar::me::cpu::core::eof {statevar} {
+ upvar 1 $statevar state
+ lset state 3 1
+ return
+}
+
+proc ::grammar::me::cpu::core::put {statevar tok lex line col} {
+ upvar 1 $statevar state
+ if {[lindex $state 3]} {
+ return -code error "Cannot add input data after eof"
+ }
+ set tc [K [lindex $state 4] [lset state 4 {}]]
+ lappend tc [list $tok $lex $line $col]
+ lset state 4 $tc
+ return
+}
+
+proc ::grammar::me::cpu::core::run {statevar {steps -1}} {
+ # Execution loop. Should be instrumented for statistics about
+ # dynamic instruction frequency. I.e. which instructions are
+ # executed the most => put them at the front of the if/switch for
+ # quicker selection. I.e. frequency coding of the branches for
+ # speed.
+
+ # A C implementation can shimmer the state into a directly
+ # accessible data structure. And the asm instructions can shimmer
+ # into an integer index upon which we can switch fast.
+
+ variable anum
+ variable tclass
+ upvar 1 $statevar state
+ variable iname ; # For debug output
+
+ # Do nothing for a stopped machine (halt flag set).
+ if {[lindex $state 2]} {return $state}
+
+ # Fail if there are no instruction to execute
+ if {![llength [lindex $state 0 0]]} {
+ # No instructions to execute
+ return -code error "No instructions to execute"
+ }
+
+ # Unpack state into locally accessible variables
+ # 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
+ foreach {code pc halt eof tc cl ct ok sv er ls as ms es rs nc} $state break
+
+ # Unpack match program for easy access as well.
+ # 0 1 2
+ foreach {asm pool tokmap} $code break
+
+ if 0 {
+ puts ________________________
+ puts [join [disasm $code] \n]
+ puts ________________________
+ }
+
+ # Ensure that the unpacked information is not shared
+ unset state
+
+ # Internal flags for optimal handling of the nonterminal
+ # cache. Avoid multiple unpacking of the dictionary, and avoid
+ # repacking if it was not modified.
+
+ set ncunpacked 0
+ set ncmodified 0
+ set tmunpacked 0
+
+ while {1} {
+ # Stop execution if the specified number of instructions have
+ # been executed. Ignore if infinity was specified.
+ if {$steps == 0} break
+ if {$steps > 0} {incr steps -1}
+
+ # Get current instruction ...
+
+ if 0 {puts .$pc:\t$iname([lindex $asm $pc])}
+ if 0 {puts -nonewline .$pc:\t$iname([lindex $asm $pc])}
+
+ set insn [lindex $asm $pc] ; incr pc
+
+ # And its arguments ...
+
+ set an [lindex $anum $insn]
+ if {$an == 1} {
+ set a [lindex $asm $pc] ; incr pc
+ if 0 {puts \t<$a>}
+ } elseif {$an == 2} {
+ set a [lindex $asm $pc] ; incr pc
+ set b [lindex $asm $pc] ; incr pc
+ if 0 {puts \t<$a|$b>}
+ } elseif {$an == 3} {
+ set a [lindex $asm $pc] ; incr pc
+ set b [lindex $asm $pc] ; incr pc
+ set c [lindex $asm $pc] ; incr pc
+ if 0 {puts \t<$a|$b|$c>}
+ } ;# else {puts ""}
+
+ # Dispatch to implementation of the instruction ...
+
+ # Separate if commands are used for easier ordering of the
+ # dispatch. The order of the branches should be frequency
+ # coded to have the most frequently used instructions first.
+
+ # ict_advance <a:message>
+ if {$insn == 0} {
+ if 0 {puts \t\[$cl|[llength $tc]|$eof\]}
+ incr cl
+ if {$cl < [llength $tc]} {
+ if 0 {puts \tConsume}
+
+ set ct [lindex $tc $cl 0]
+ set ok 1
+ set er {}
+ } elseif {$eof} {
+ if 0 {puts \tFail<Eof>}
+
+ # We have no input, and there won't be more coming in
+ # either. Fail the advance. We do _not_ stop the match
+ # loop, the program has to complete. The failure might
+ # be no such, revealed during backtracking. The current
+ # location is not rewound automatically, this is the
+ # responsibility of any backtracking.
+
+ set er [list $cl [list $a]]
+ set ok 0
+ } else {
+ if 0 {puts \tSuspend&Wait}
+
+ # We have no input, stop matching and wait for
+ # more. We reset the machine into a state
+ # which will restart this instruction when
+ # execution resumes.
+
+ incr cl -1
+ incr pc -2 ; # code and message argument
+ break
+ }
+ if 0 {puts .Next}
+ continue
+ }
+
+ # ict_match_token <a:token> <b:message>
+ if {$insn == 1} {
+ if {[llength $tokmap]} {
+ if {!$tmunpacked} {
+ array set tm $tokmap
+ set tmunpacked 1
+ }
+ set ok [expr {$a == $tm($ct)}]
+ } else {
+ set xch [lindex $pool $a]
+ set ok [expr {$xch eq $ct}]
+ }
+ if {!$ok} {
+ set er [list $cl [list $b]]
+ } else {
+ set er {}
+ }
+ continue
+ }
+
+ # ict_match_tokrange <a:tokstart> <b:tokend> <c:message>
+ if {$insn == 2} {
+ if {[llength $tokmap]} {
+ if {!$tmunpacked} {
+ array set tm $tokmap
+ set tmunpacked 1
+ }
+ set x $tm($ct)
+ set ok [expr {($a <= $x) && ($x <= $b)}]
+ } else {
+ set a [lindex $pool $a]
+ set b [lindex $pool $b]
+ set ok [expr {
+ ([string compare $a $ct] <= 0) &&
+ ([string compare $ct $b] <= 0)
+ }] ; # {}
+ }
+ if {!$ok} {
+ set er [list $cl [list $c]]
+ } else {
+ set er {}
+ }
+ continue
+ }
+
+ # ict_match_tokclass <a:code> <b:message>
+ if {$insn == 3} {
+ set strcode [lindex $tclass $a]
+ set ok [string is $strcode -strict $ct]
+ if {!$ok} {
+ set er [list $cl [list $b]]
+ } else {
+ set er {}
+ }
+ continue
+ }
+
+ # inc_restore <a:branchtarget> <b:nonterminal>
+ if {$insn == 4} {
+ set sym [lindex $pool $b]
+
+ # Unpack the cache dict, only here.
+ # 8.5 - Use dict operations instead.
+
+ if {!$ncunpacked} {
+ array set ncc $nc
+ set ncunpacked 1
+ }
+
+ if {[info exists ncc($cl,$sym)]} {
+ foreach {go ok error sv} $ncc($cl,$sym) break
+
+ # Go forward, as the nonterminal matches (or not).
+ set cl $go
+ set pc $a
+ }
+ continue
+ }
+
+ # inc_save <a:nonterminal>
+ if {$insn == 5} {
+ set sym [lindex $pool $a]
+ set at [lindex $ls end]
+ set ls [lrange $ls 0 end-1]
+
+ # Unpack, modify, only here.
+ # 8.5 - Use dict operations instead.
+
+ if {!$ncunpacked} {
+ array set ncc $nc
+ set ncunpacked 1
+ }
+
+ set ncc($at,$sym) [list $cl $ok $er $sv]
+ set ncmodified 1
+ continue
+ }
+
+ # icf_ntcall <a:branchtarget>
+ if {$insn == 6} {
+ lappend rs $pc
+ set pc $a
+ continue
+ }
+
+ # icf_ntreturn
+ if {$insn == 7} {
+ set pc [lindex $rs end]
+ set rs [lrange $rs 0 end-1]
+ continue
+ }
+
+ # iok_ok
+ if {$insn == 8} {
+ set ok 1
+ continue
+ }
+
+ # iok_fail
+ if {$insn == 9} {
+ set ok 0
+ continue
+ }
+
+ # iok_negate
+ if {$insn == 10} {
+ set ok [expr {!$ok}]
+ continue
+ }
+
+ # icf_jalways <a:branchtarget>
+ if {$insn == 11} {
+ set pc $a
+ continue
+ }
+
+ # icf_jok <a:branchtarget>
+ if {$insn == 12} {
+ if {$ok} {set pc $a}
+ # !ok => pc is already on next instruction.
+ continue
+ }
+
+ # icf_jfail <a:branchtarget>
+ if {$insn == 13} {
+ if {!$ok} {set pc $a}
+ # ok => pc is already on next instruction.
+ continue
+ }
+
+ # icf_halt
+ if {$insn == 14} {
+ set halt 1
+ break
+ }
+
+ # icl_push
+ if {$insn == 15} {
+ lappend ls $cl
+ continue
+ }
+
+ # icl_rewind
+ if {$insn == 16} {
+ set cl [lindex $ls end]
+ set ls [lrange $ls 0 end-1]
+ continue
+ }
+
+ # icl_pop
+ if {$insn == 17} {
+ set ls [lrange $ls 0 end-1]
+ continue
+ }
+
+ # ier_push
+ if {$insn == 18} {
+ lappend es $er
+ continue
+ }
+
+ # ier_clear
+ if {$insn == 19} {
+ set er {}
+ continue
+ }
+
+ # ier_nonterminal <a:nonterminal>
+ if {$insn == 20} {
+ if {[llength $er]} {
+ set pos [lindex $ls end]
+ incr pos
+ set eloc [lindex $er 0]
+ if {$eloc == $pos} {
+ set er [list $eloc [list $a]]
+ }
+ }
+ continue
+ }
+
+ # ier_merge
+ if {$insn == 21} {
+ set old [lindex $es end]
+ set es [lrange $es 0 end-1]
+
+ # We have either old or current error data, keep it.
+
+ if {![llength $er]} {
+ # No current data, keep old
+ set er $old
+ } elseif {[llength $old]} {
+ # If one of the errors is further on in the input
+ # choose that as the information to propagate.
+
+ foreach {loe msgse} $er break
+ foreach {lon msgsn} $old break
+
+ if {$lon > $loe} {
+ set er $old
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists.
+
+ foreach m $msgsn {lappend msgse $m}
+ set er [list $loe [lsort -uniq $msgse]]
+ }
+ # else lon < loe - er is better - nothing
+ }
+ # else - !old, but er - nothing
+
+ continue
+ }
+
+ # isv_clear
+ if {$insn == 22} {
+ set sv {}
+ continue
+ }
+
+ # isv_terminal (implied ias_push)
+ if {$insn == 23} {
+ set sv [list {} $cl $cl]
+ lappend as $sv
+ continue
+ }
+
+ # isv_nonterminal_leaf <a:nonterminal>
+ if {$insn == 24} {
+ set pos [lindex $ls end]
+ set sv [list $a $pos $cl]
+ continue
+ }
+
+ # isv_nonterminal_range <a:nonterminal>
+ if {$insn == 25} {
+ set pos [lindex $ls end]
+ set sv [list $a $pos $cl [list {} $pos $cl]]
+ continue
+ }
+
+ # isv_nonterminal_reduce <a:nonterminal>
+ if {$insn == 26} {
+ set pos [lindex $ls end]
+ if {[llength $ms]} {
+ set mrk [lindex $ms end]
+ incr mrk
+ } else {
+ set mrk 0
+ }
+ set sv [lrange $as $mrk end]
+ set sv [linsert $sv 0 $a $pos $cl]
+ continue
+ }
+
+ # ias_push
+ if {$insn == 27} {
+ lappend as $sv
+ continue
+ }
+
+ # ias_mark
+ if {$insn == 28} {
+ set mark [llength $as]
+ incr mark -1
+ lappend ms $mark
+ continue
+ }
+
+ # ias_mrewind
+ if {$insn == 29} {
+ set mark [lindex $ms end]
+ set ms [lrange $ms 0 end-1]
+ set as [lrange $as 0 $mark]
+ continue
+ }
+
+ # ias_mpop
+ if {$insn == 30} {
+ set ms [lrange $ms 0 end-1]
+ continue
+ }
+
+ return -code error "Illegal instruction $insn"
+ }
+
+ # Repack a modified cache dictionary, then repack and store the
+ # updated state value.
+
+ if 0 {puts .Repackage\ state}
+
+ if {$ncmodified} {set nc [array get ncc]}
+ set state [list $code $pc $halt $eof $tc $cl $ct $ok $sv $er $ls $as $ms $es $rs $nc]
+ return
+}
+
+namespace eval grammar::me::cpu::core {
+ # Map between class codes and names
+ variable tclass {}
+ variable tccode
+
+ foreach {x code} {
+ 0 alnum
+ 1 alpha
+ 2 digit
+ 3 xdigit
+ 4 punct
+ 5 space
+ } {
+ lappend tclass $code
+ set tccode($code) $x
+ }
+
+ # Number of arguments per ME instruction.
+ # Indexed by instruction code.
+ variable anum {}
+
+ # Mapping between instruction codes and names.
+ variable iname
+
+ foreach {z insn x notes} {
+ 0 ict_advance 1 {-- TESTED}
+ 1 ict_match_token 2 {-- TESTED}
+ 2 ict_match_tokrange 3 {-- TESTED}
+ 3 ict_match_tokclass 2 {-- TESTED}
+ 4 inc_restore 2 {-- TESTED}
+ 5 inc_save 1 {-- TESTED}
+ 6 icf_ntcall 1 {-- TESTED}
+ 7 icf_ntreturn 0 {-- TESTED}
+ 8 iok_ok 0 {-- TESTED}
+ 9 iok_fail 0 {-- TESTED}
+ 10 iok_negate 0 {-- TESTED}
+ 11 icf_jalways 1 {-- TESTED}
+ 12 icf_jok 1 {-- TESTED}
+ 13 icf_jfail 1 {-- TESTED}
+ 14 icf_halt 0 {-- TESTED}
+ 15 icl_push 0 {-- TESTED}
+ 16 icl_rewind 0 {-- TESTED}
+ 17 icl_pop 0 {-- TESTED}
+ 18 ier_push 0 {-- TESTED}
+ 19 ier_clear 0 {-- TESTED}
+ 20 ier_nonterminal 1 {-- TESTED}
+ 21 ier_merge 0 {-- TESTED}
+ 22 isv_clear 0 {-- TESTED}
+ 23 isv_terminal 0 {-- TESTED}
+ 24 isv_nonterminal_leaf 1 {-- TESTED}
+ 25 isv_nonterminal_range 1 {-- TESTED}
+ 26 isv_nonterminal_reduce 1 {-- TESTED}
+ 27 ias_push 0 {-- TESTED}
+ 28 ias_mark 0 {-- TESTED}
+ 29 ias_mrewind 0 {-- TESTED}
+ 30 ias_mpop 0 {-- TESTED}
+ } {
+ lappend anum $x
+ set iname($z) $insn
+ set iname($insn) $z
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Helper commands ((Dis)Assembler, runtime).
+
+proc ::grammar::me::cpu::core::INDEX {list i label} {
+ if {$i eq "end"} {
+ set i [expr {[llength $list] - 1}]
+ } elseif {[regexp {^end-([0-9]+)$} $i -> n]} {
+ set i [expr {[llength $list] - $n -1}]
+ }
+ if {
+ ![string is integer -strict $i] ||
+ ($i < 0) ||
+ ($i >= [llength $list])
+ } {
+ return -code error "$label $i"
+ }
+ return $i
+}
+
+proc ::grammar::me::cpu::core::K {x y} {set x}
+
+proc ::grammar::me::cpu::core::Str {str} {
+ upvar 1 pool pool poolh poolh
+ if {![info exists poolh($str)]} {
+ set poolh($str) [llength $pool]
+ lappend pool $str
+ }
+ return $poolh($str)
+}
+
+proc ::grammar::me::cpu::core::Tok {str} {
+ upvar 1 tokmap tokmap ord ord plain plain
+
+ if {[regexp {^([^:]+):(.+)$} $str -> id name]} {
+ if {$plain} {
+ return -code error "Bad assembly, mixing plain and ranked tokens"
+ }
+ if {[info exists ord($id)]} {
+ return -code error "Bad assembly, non-total ordering for $name and $ord($id), at rank $id"
+ }
+ set ord($id) $name
+ set tokmap($name) $id
+
+ return $id
+ } else {
+ if {[array size ord]} {
+ return -code error "Bad assembly, mixing plain and ranked tokens"
+ }
+ set plain 1
+ return [uplevel 1 [list Str $str]]
+ }
+}
+
+proc ::grammar::me::cpu::core::Validate {code {ovar {}} {tvar {}} {jvar {}}} {
+ variable anum
+ variable iname
+
+ # Basic validation of structure ...
+
+ if {[llength $code] != 3} {
+ return -code error "Bad length"
+ }
+
+ foreach {asm pool tokmap} $code break
+
+ if {[llength $tokmap] % 2 == 1} {
+ return -code error "Bad tokmap, expected a dictionary"
+ }
+
+ array set ord {}
+ if {[llength $tokmap] > 0} {
+ foreach {tok rank} $tokmap {
+ if {[info exists ord($rank)]} {
+ return -code error "Bad tokmap, non-total ordering for $tok and $ord($rank), at rank $rank"
+ }
+ set ord($rank) $tok
+ }
+ }
+
+ # Basic validation of ME code: Valid instructions, collect valid
+ # branch target indices
+
+ array set target {}
+
+ set pc 0
+ set pcend [llength $asm]
+ set poolend [llength $pool]
+
+ while {$pc < $pcend} {
+ set target($pc) .
+
+ set insn [lindex $asm $pc]
+ if {($insn < 0) || ($insn > 30)} {
+ return -code error "Invalid instruction $insn at PC $pc"
+ }
+
+ incr pc
+ incr pc [lindex $anum $insn]
+ }
+
+ if {$pc > $pcend} {
+ return -code error "Bad program, last instruction $insn ($iname($insn)) is truncated"
+ }
+
+ # Validation of ME instruction arguments (pool references, branch
+ # targets, ...)
+
+ if {$jvar ne ""} {
+ upvar 1 $jvar jmp
+ }
+ array set jmp {}
+
+ set pc 0
+ while {$pc < $pcend} {
+ set base $pc
+ set insn [lindex $asm $pc] ; incr pc
+ set an [lindex $anum $insn]
+
+ if {$an == 1} {
+ set a [lindex $asm $pc] ; incr pc
+ } elseif {$an == 2} {
+ set a [lindex $asm $pc] ; incr pc
+ set b [lindex $asm $pc] ; incr pc
+ } elseif {$an == 3} {
+ set a [lindex $asm $pc] ; incr pc
+ set b [lindex $asm $pc] ; incr pc
+ set c [lindex $asm $pc] ; incr pc
+ }
+
+ switch -exact $insn {
+ 0 - 5 - 20 - 24 - 25 - 26 -
+ a/string {
+ if {($a < 0) || ($a >= $poolend)} {
+ return -code error "Invalid string reference $a for instruction $insn ($iname($insn)) at $base"
+ }
+ }
+ 1 {
+ # a/tok b/string
+ if {![llength $tokmap]} {
+ if {($a < 0) || ($a >= $poolend)} {
+ return -code error "Invalid string reference $a for instruction $insn ($iname($insn)) at $base"
+ }
+ } else {
+ if {![info exists ord($a)]} {
+ return -code error "Invalid token rank $a for instruction $insn ($iname($insn)) at $base"
+ }
+ }
+ if {($b < 0) || ($b >= $poolend)} {
+ return -code error "Invalid string reference $b for instruction $insn ($iname($insn)) at $base"
+ }
+ }
+ 2 {
+ # a/tokstart b/tokend c/string
+
+ if {![llength $tokmap]} {
+ # a = b = string references.
+ if {($a < 0) || ($a >= $poolend)} {
+ return -code error "Invalid string reference $a for instruction $insn ($iname($insn)) at $base"
+ }
+ if {($b < 0) || ($b >= $poolend)} {
+ return -code error "Invalid string reference $b for instruction $insn ($iname($insn)) at $base"
+ }
+ if {$a == $b} {
+ return -code error "Invalid single-token range for instruction $insn ($iname($insn)) at $base"
+ }
+ if {[string compare [lindex $pool $a] [lindex $pool $b]] > 0} {
+ return -code error "Invalid empty range for instruction $insn ($iname($insn)) at $base"
+ }
+ } else {
+ # tokmap defined: a = b = order rank.
+ if {![info exists ord($a)]} {
+ return -code error "Invalid token rank $a for instruction $insn ($iname($insn)) at $base"
+ }
+ if {![info exists ord($b)]} {
+ return -code error "Invalid token rank $b for instruction $insn ($iname($insn)) at $base"
+ }
+ if {$a == $b} {
+ return -code error "Invalid single-token range for instruction $insn ($iname($insn)) at $base"
+ }
+ if {$a > $b} {
+ return -code error "Invalid empty range for instruction $insn ($iname($insn)) at $base"
+ }
+ }
+ if {($c < 0) || ($c >= $poolend)} {
+ return -code error "Invalid string reference $c for instruction $insn ($iname($insn)) at $base"
+ }
+ }
+ 3 {
+ # a/class(0-5) b/string
+ if {($a < 0) || ($a > 5)} {
+ return -code error "Invalid token-class $a for instruction $insn ($iname($insn)) at $base"
+ }
+ if {($b < 0) || ($b >= $poolend)} {
+ return -code error "Invalid string reference $b for instruction $insn ($iname($insn)) at $base"
+ }
+ }
+ 4 {
+ # a/branch b/string
+ if {![info exists target($a)]} {
+ return -code error "Invalid branch target $a for instruction $insn ($iname($insn)) at $base"
+ } else {
+ set jmp($a) .
+ }
+ if {($b < 0) || ($b >= $poolend)} {
+ return -code error "Invalid string reference $b for instruction $insn ($iname($insn)) at $base"
+ }
+ }
+ 6 - 11 - 12 - 13 -
+ a/branch {
+ if {![info exists target($a)]} {
+ return -code error "Invalid branch target $a for instruction $insn ($iname($insn)) at $base"
+ } else {
+ set jmp($base) $a
+ }
+ }
+ default {}
+ }
+ }
+
+ # All checks passed, code is deemed good enough.
+ # Caller may have asked for some of the collected
+ # information.
+
+ if {$ovar ne ""} {
+ upvar 1 $ovar o
+ array set o [array get ord]
+ }
+ if {$tvar ne ""} {
+ upvar 1 $tvar t
+ array set t [array get target]
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide grammar::me::cpu::core 0.2
diff --git a/tcllib/modules/grammar_me/me_cpucore.test b/tcllib/modules/grammar_me/me_cpucore.test
new file mode 100644
index 0000000..b163e19
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_cpucore.test
@@ -0,0 +1,163 @@
+# me_cpucore.test: Tests for the ME virtual machine -*- tcl -*-
+#
+# This file contains a collection of tests for one or more of the
+# commands making up the ME virtual machine. Sourcing this file into
+# Tcl runs the tests and generates output for errors. No output means
+# no errors were found.
+#
+# Copyright (c) 2005-2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: me_cpucore.test,v 1.3 2006/10/09 21:41:40 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.1
+
+support {
+ use fileutil/fileutil.tcl fileutil
+}
+testing {
+ useLocal me_cpucore.tcl grammar::me::cpu::core
+}
+
+# -------------------------------------------------------------------------
+
+proc cpustate {state} {
+ set vstate {}
+ lappend vstate cd [::grammar::me::cpu::core::code $state]
+ lappend vstate pc [::grammar::me::cpu::core::pc $state]
+ lappend vstate ht [::grammar::me::cpu::core::halted $state]
+ lappend vstate eo [::grammar::me::cpu::core::iseof $state]
+ lappend vstate tc [::grammar::me::cpu::core::tok $state]
+ lappend vstate at [::grammar::me::cpu::core::at $state]
+ lappend vstate cc [::grammar::me::cpu::core::cc $state]
+ lappend vstate ok [::grammar::me::cpu::core::ok $state]
+ lappend vstate sv [::grammar::me::cpu::core::sv $state]
+ lappend vstate er [::grammar::me::cpu::core::error $state]
+ lappend vstate ls [::grammar::me::cpu::core::lstk $state]
+ lappend vstate as [::grammar::me::cpu::core::astk $state]
+ lappend vstate ms [::grammar::me::cpu::core::mstk $state]
+ lappend vstate es [::grammar::me::cpu::core::estk $state]
+ lappend vstate rs [::grammar::me::cpu::core::rstk $state]
+ lappend vstate nc [::grammar::me::cpu::core::nc $state]
+ return $vstate
+}
+
+proc cpudelta {prev now} {
+ array set _ {}
+ foreach {k v} [cpustate $prev] {
+ set _($k) $v
+ }
+ set res {}
+ foreach {k v} [cpustate $now] {
+ if {[info exists _($k)] && ($_($k) eq $v)} continue
+ lappend res $k $v
+ }
+ return $res
+}
+
+proc cpufstate {vstate} {
+ set res {}
+ foreach {k v} $vstate {lappend res [list $k $v]}
+ join $res \n
+}
+
+proc cpusubst {vstate args} {
+ array set _ $vstate
+ foreach {k v} $args {set _($k) $v}
+ set res {}
+ foreach k {cd pc ht eo tc at cc ok sv er ls as ms es rs nc} {
+ if {![info exists _($k)]} continue
+ lappend res $k $_($k)
+ }
+ return $res
+}
+
+proc cpufilter {vstate args} {
+ array set _ $vstate
+ set res {}
+ foreach k $args { lappend res $k $_($k) }
+ return $res
+}
+
+proc canon_code {code} {
+ foreach {i p t} $code break
+ # Sorting the token map, canonical rep for direct comparison
+ return [list $i $p [dictsort $t]]
+}
+
+# -------------------------------------------------------------------------
+
+set asm_table [string trimright \
+ [fileutil::cat \
+ [localPath me_cpucore.tests.asm-map.txt]]]
+
+set badasm_table [string trimright \
+ [fileutil::cat \
+ [localPath me_cpucore.tests.badasm-map.txt]]]
+
+set badmach_table [string trimright \
+ [fileutil::cat \
+ [localPath me_cpucore.tests.badmach-map.txt]]]
+
+set semantics [string trimright \
+ [fileutil::cat \
+ [localPath me_cpucore.tests.semantics.txt]]]
+
+# -------------------------------------------------------------------------
+# In this section we run all the tests depending on a grammar::me::cpu::core,
+# and thus have to test all the available implementations.
+
+set tests [file join [file dirname [info script]] me_cpucore.testsuite]
+
+catch {memory validate on}
+
+set impl tcl
+set usec [time {source $tests} 1]
+
+if 0 {
+ foreach impl [grammar::me::cpu::core::Implementations] {
+ grammar::me::cpu::core::SwitchTo $impl
+
+ # The global variable 'impl' is part of the public API the
+ # testsuit (in htmlparse_tree.testsuite) can expect from the
+ # environment.
+
+ namespace import -force grammar::me::cpu::core
+
+ set usec [time {source $tests} 1]
+
+ #puts "$impl:\t$usec"
+ }
+}
+
+catch {memory validate off}
+
+unset usec
+unset tests
+
+#puts ""
+
+# Reset system to fully inactive state.
+# grammar::me::cpu::core::SwitchTo {}
+
+# -------------------------------------------------------------------------
+
+# ### ### ### ######### ######### #########
+## Cleanup and statistics.
+
+rename cpustate {}
+rename cpufstate {}
+rename cpudelta {}
+rename cpufilter {}
+rename canon_code {}
+
+unset asm_table badmach_table semantics
+
+testsuiteCleanup
diff --git a/tcllib/modules/grammar_me/me_cpucore.tests.asm-map.txt b/tcllib/modules/grammar_me/me_cpucore.tests.asm-map.txt
new file mode 100644
index 0000000..b9690be
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_cpucore.tests.asm-map.txt
@@ -0,0 +1,38 @@
+ict_advance message {{0 0} message {}}
+ict_match_token {tok message} {{1 0 1} {tok message} {}}
+ict_match_token {5:tok message} {{1 5 0} message {tok 5}}
+ict_match_tokrange {tokbegin tokend message} {{2 0 1 2} {tokbegin tokend message} {}}
+ict_match_tokrange {5:tokbegin 6:tokend message} {{2 5 6 0} message {tokbegin 5 tokend 6}}
+ict_match_tokclass {alnum message} {{3 0 0} message {}}
+ict_match_tokclass {alpha message} {{3 1 0} message {}}
+ict_match_tokclass {digit message} {{3 2 0} message {}}
+ict_match_tokclass {xdigit message} {{3 3 0} message {}}
+ict_match_tokclass {punct message} {{3 4 0} message {}}
+ict_match_tokclass {space message} {{3 5 0} message {}}
+inc_restore {branchlabel nt} {{4 0 0} nt {}}
+inc_save nt {{5 0} nt {}}
+icf_ntcall branchlabel {{6 0} {} {}}
+icf_ntreturn {} {7 {} {}}
+iok_ok {} {8 {} {}}
+iok_fail {} {9 {} {}}
+iok_negate {} {10 {} {}}
+icf_jalways branchlabel {{11 0} {} {}}
+icf_jok branchlabel {{12 0} {} {}}
+icf_jfail branchlabel {{13 0} {} {}}
+icf_halt {} {14 {} {}}
+icl_push {} {15 {} {}}
+icl_rewind {} {16 {} {}}
+icl_pop {} {17 {} {}}
+ier_push {} {18 {} {}}
+ier_clear {} {19 {} {}}
+ier_nonterminal message {{20 0} message {}}
+ier_merge {} {21 {} {}}
+isv_clear {} {22 {} {}}
+isv_terminal {} {23 {} {}}
+isv_nonterminal_leaf nt {{24 0} nt {}}
+isv_nonterminal_range nt {{25 0} nt {}}
+isv_nonterminal_reduce nt {{26 0} nt {}}
+ias_push {} {27 {} {}}
+ias_mark {} {28 {} {}}
+ias_mrewind {} {29 {} {}}
+ias_mpop {} {30 {} {}}
diff --git a/tcllib/modules/grammar_me/me_cpucore.tests.badasm-map.txt b/tcllib/modules/grammar_me/me_cpucore.tests.badasm-map.txt
new file mode 100644
index 0000000..5cfdc82
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_cpucore.tests.badasm-map.txt
@@ -0,0 +1,58 @@
+barf {} {Bad instruction "branchlabel barf", unknown command "barf"}
+ict_advance {} {Bad instruction "branchlabel ict_advance", expected 1 argument}
+ict_advance {goob message} {Bad instruction "branchlabel ict_advance goob message", expected 1 argument}
+ict_match_token {} {Bad instruction "branchlabel ict_match_token", expected 2 arguments}
+ict_match_token {message} {Bad instruction "branchlabel ict_match_token message", expected 2 arguments}
+ict_match_token {foo tok message} {Bad instruction "branchlabel ict_match_token foo tok message", expected 2 arguments}
+ict_match_tokrange {} {Bad instruction "branchlabel ict_match_tokrange", expected 3 arguments}
+ict_match_tokrange {foo} {Bad instruction "branchlabel ict_match_tokrange foo", expected 3 arguments}
+ict_match_tokrange {foo bar} {Bad instruction "branchlabel ict_match_tokrange foo bar", expected 3 arguments}
+ict_match_tokrange {tokb:1 tokend message} {Bad assembly, mixing plain and ranked tokens}
+ict_match_tokrange {feh tokbegin tokend message} {Bad instruction "branchlabel ict_match_tokrange feh tokbegin tokend message", expected 3 arguments}
+ict_match_tokclass {} {Bad instruction "branchlabel ict_match_tokclass", expected 2 arguments}
+ict_match_tokclass {alnum} {Bad instruction "branchlabel ict_match_tokclass alnum", expected 2 arguments}
+ict_match_tokclass {bogus message} {Bad instruction "branchlabel ict_match_tokclass bogus message", unknown class code "bogus"}
+ict_match_tokclass {fee alnum message} {Bad instruction "branchlabel ict_match_tokclass fee alnum message", expected 2 arguments}
+inc_restore {} {Bad instruction "branchlabel inc_restore", expected 2 arguments}
+inc_restore {branchlabel} {Bad instruction "branchlabel inc_restore branchlabel", expected 2 arguments}
+inc_restore {badlabel nt} {Bad instruction "branchlabel inc_restore badlabel nt", unknown branch destination "badlabel"}
+inc_restore {branchlabel nt foo} {Bad instruction "branchlabel inc_restore branchlabel nt foo", expected 2 arguments}
+inc_save {} {Bad instruction "branchlabel inc_save", expected 1 argument}
+inc_save {foo nt} {Bad instruction "branchlabel inc_save foo nt", expected 1 argument}
+icf_ntcall {} {Bad instruction "branchlabel icf_ntcall", expected 1 argument}
+icf_ntcall badlabel {Bad instruction "branchlabel icf_ntcall badlabel", unknown branch destination "badlabel"}
+icf_ntcall {foo branchlabel} {Bad instruction "branchlabel icf_ntcall foo branchlabel", expected 1 argument}
+icf_ntreturn {bogus} {Bad instruction "branchlabel icf_ntreturn bogus", expected 0 arguments}
+iok_ok {bogus} {Bad instruction "branchlabel iok_ok bogus", expected 0 arguments}
+iok_fail {bogus} {Bad instruction "branchlabel iok_fail bogus", expected 0 arguments}
+iok_negate {bogus} {Bad instruction "branchlabel iok_negate bogus", expected 0 arguments}
+icf_jalways {} {Bad instruction "branchlabel icf_jalways", expected 1 argument}
+icf_jalways badlabel {Bad instruction "branchlabel icf_jalways badlabel", unknown branch destination "badlabel"}
+icf_jalways {foo branchlabel} {Bad instruction "branchlabel icf_jalways foo branchlabel", expected 1 argument}
+icf_jok {} {Bad instruction "branchlabel icf_jok", expected 1 argument}
+icf_jok badlabel {Bad instruction "branchlabel icf_jok badlabel", unknown branch destination "badlabel"}
+icf_jok {foo branchlabel} {Bad instruction "branchlabel icf_jok foo branchlabel", expected 1 argument}
+icf_jfail {} {Bad instruction "branchlabel icf_jfail", expected 1 argument}
+icf_jfail badlabel {Bad instruction "branchlabel icf_jfail badlabel", unknown branch destination "badlabel"}
+icf_jfail {foo branchlabel} {Bad instruction "branchlabel icf_jfail foo branchlabel", expected 1 argument}
+icf_halt {bogus} {Bad instruction "branchlabel icf_halt bogus", expected 0 arguments}
+icl_push {bogus} {Bad instruction "branchlabel icl_push bogus", expected 0 arguments}
+icl_rewind {bogus} {Bad instruction "branchlabel icl_rewind bogus", expected 0 arguments}
+icl_pop {bogus} {Bad instruction "branchlabel icl_pop bogus", expected 0 arguments}
+ier_push {bogus} {Bad instruction "branchlabel ier_push bogus", expected 0 arguments}
+ier_clear {bogus} {Bad instruction "branchlabel ier_clear bogus", expected 0 arguments}
+ier_nonterminal {} {Bad instruction "branchlabel ier_nonterminal", expected 1 argument}
+ier_nonterminal {foo message} {Bad instruction "branchlabel ier_nonterminal foo message", expected 1 argument}
+ier_merge {bogus} {Bad instruction "branchlabel ier_merge bogus", expected 0 arguments}
+isv_clear {bogus} {Bad instruction "branchlabel isv_clear bogus", expected 0 arguments}
+isv_terminal {bogus} {Bad instruction "branchlabel isv_terminal bogus", expected 0 arguments}
+isv_nonterminal_leaf {} {Bad instruction "branchlabel isv_nonterminal_leaf", expected 1 argument}
+isv_nonterminal_leaf {foo nt} {Bad instruction "branchlabel isv_nonterminal_leaf foo nt", expected 1 argument}
+isv_nonterminal_range {} {Bad instruction "branchlabel isv_nonterminal_range", expected 1 argument}
+isv_nonterminal_range {foo nt} {Bad instruction "branchlabel isv_nonterminal_range foo nt", expected 1 argument}
+isv_nonterminal_reduce {} {Bad instruction "branchlabel isv_nonterminal_reduce", expected 1 argument}
+isv_nonterminal_reduce {foo nt} {Bad instruction "branchlabel isv_nonterminal_reduce foo nt", expected 1 argument}
+ias_push {bogus} {Bad instruction "branchlabel ias_push bogus", expected 0 arguments}
+ias_mark {bogus} {Bad instruction "branchlabel ias_mark bogus", expected 0 arguments}
+ias_mrewind {bogus} {Bad instruction "branchlabel ias_mrewind bogus", expected 0 arguments}
+ias_mpop {bogus} {Bad instruction "branchlabel ias_mpop bogus", expected 0 arguments}
diff --git a/tcllib/modules/grammar_me/me_cpucore.tests.badmach-map.txt b/tcllib/modules/grammar_me/me_cpucore.tests.badmach-map.txt
new file mode 100644
index 0000000..9980cb6
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_cpucore.tests.badmach-map.txt
@@ -0,0 +1,67 @@
+{} {Bad length}
+{{}} {Bad length}
+{{} {}} {Bad length}
+{{} {} {} {}} {Bad length}
+{{} {} x} {Bad tokmap, expected a dictionary}
+{{} {} {x 3 y 3}} {Bad tokmap, non-total ordering for y and x, at rank 3}
+{-1 {} {}} {Invalid instruction -1 at PC 0}
+{31 {} {}} {Invalid instruction 31 at PC 0}
+{0 {} {}} {Bad program, last instruction 0 (ict_advance) is truncated}
+{1 {} {}} {Bad program, last instruction 1 (ict_match_token) is truncated}
+{{1 0} {} {}} {Bad program, last instruction 1 (ict_match_token) is truncated}
+{2 {} {}} {Bad program, last instruction 2 (ict_match_tokrange) is truncated}
+{{2 0} {} {}} {Bad program, last instruction 2 (ict_match_tokrange) is truncated}
+{{2 0 0} {} {}} {Bad program, last instruction 2 (ict_match_tokrange) is truncated}
+{3 {} {}} {Bad program, last instruction 3 (ict_match_tokclass) is truncated}
+{{3 0} {} {}} {Bad program, last instruction 3 (ict_match_tokclass) is truncated}
+{4 {} {}} {Bad program, last instruction 4 (inc_restore) is truncated}
+{{4 0} {} {}} {Bad program, last instruction 4 (inc_restore) is truncated}
+{5 {} {}} {Bad program, last instruction 5 (inc_save) is truncated}
+{6 {} {}} {Bad program, last instruction 6 (icf_ntcall) is truncated}
+{11 {} {}} {Bad program, last instruction 11 (icf_jalways) is truncated}
+{12 {} {}} {Bad program, last instruction 12 (icf_jok) is truncated}
+{13 {} {}} {Bad program, last instruction 13 (icf_jfail) is truncated}
+{20 {} {}} {Bad program, last instruction 20 (ier_nonterminal) is truncated}
+{24 {} {}} {Bad program, last instruction 24 (isv_nonterminal_leaf) is truncated}
+{25 {} {}} {Bad program, last instruction 25 (isv_nonterminal_range) is truncated}
+{26 {} {}} {Bad program, last instruction 26 (isv_nonterminal_reduce) is truncated}
+{{0 -1} {} {}} {Invalid string reference -1 for instruction 0 (ict_advance) at 0}
+{{0 0} {} {}} {Invalid string reference 0 for instruction 0 (ict_advance) at 0}
+{{1 0 -1} {x} {}} {Invalid string reference -1 for instruction 1 (ict_match_token) at 0}
+{{1 0 1} {x} {}} {Invalid string reference 1 for instruction 1 (ict_match_token) at 0}
+{{2 0 1 -1} {x y} {}} {Invalid string reference -1 for instruction 2 (ict_match_tokrange) at 0}
+{{2 0 1 2} {x y} {}} {Invalid string reference 2 for instruction 2 (ict_match_tokrange) at 0}
+{{3 0 -1} {} {}} {Invalid string reference -1 for instruction 3 (ict_match_tokclass) at 0}
+{{3 0 0} {} {}} {Invalid string reference 0 for instruction 3 (ict_match_tokclass) at 0}
+{{4 0 -1} {} {}} {Invalid string reference -1 for instruction 4 (inc_restore) at 0}
+{{4 0 0} {} {}} {Invalid string reference 0 for instruction 4 (inc_restore) at 0}
+{{5 -1} {} {}} {Invalid string reference -1 for instruction 5 (inc_save) at 0}
+{{5 0} {} {}} {Invalid string reference 0 for instruction 5 (inc_save) at 0}
+{{20 -1} {} {}} {Invalid string reference -1 for instruction 20 (ier_nonterminal) at 0}
+{{20 0} {} {}} {Invalid string reference 0 for instruction 20 (ier_nonterminal) at 0}
+{{24 -1} {} {}} {Invalid string reference -1 for instruction 24 (isv_nonterminal_leaf) at 0}
+{{24 0} {} {}} {Invalid string reference 0 for instruction 24 (isv_nonterminal_leaf) at 0}
+{{25 -1} {} {}} {Invalid string reference -1 for instruction 25 (isv_nonterminal_range) at 0}
+{{25 0} {} {}} {Invalid string reference 0 for instruction 25 (isv_nonterminal_range) at 0}
+{{26 -1} {} {}} {Invalid string reference -1 for instruction 26 (isv_nonterminal_reduce) at 0}
+{{26 0} {} {}} {Invalid string reference 0 for instruction 26 (isv_nonterminal_reduce) at 0}
+{{4 -1 0} x {}} {Invalid branch target -1 for instruction 4 (inc_restore) at 0}
+{{6 -1} {} {}} {Invalid branch target -1 for instruction 6 (icf_ntcall) at 0}
+{{11 -1} {} {}} {Invalid branch target -1 for instruction 11 (icf_jalways) at 0}
+{{12 -1} {} {}} {Invalid branch target -1 for instruction 12 (icf_jok) at 0}
+{{13 -1} {} {}} {Invalid branch target -1 for instruction 13 (icf_jfail) at 0}
+{{3 -1 0} x {}} {Invalid token-class -1 for instruction 3 (ict_match_tokclass) at 0}
+{{3 6 0} x {}} {Invalid token-class 6 for instruction 3 (ict_match_tokclass) at 0}
+{{1 -1 0} x {}} {Invalid string reference -1 for instruction 1 (ict_match_token) at 0}
+{{1 1 0} x {}} {Invalid string reference 1 for instruction 1 (ict_match_token) at 0}
+{{1 0 0} x {z 1}} {Invalid token rank 0 for instruction 1 (ict_match_token) at 0}
+{{2 -1 0 0} x {}} {Invalid string reference -1 for instruction 2 (ict_match_tokrange) at 0}
+{{2 1 0 0} x {}} {Invalid string reference 1 for instruction 2 (ict_match_tokrange) at 0}
+{{2 0 -1 0} x {}} {Invalid string reference -1 for instruction 2 (ict_match_tokrange) at 0}
+{{2 0 1 0} x {}} {Invalid string reference 1 for instruction 2 (ict_match_tokrange) at 0}
+{{2 0 0 0} x {}} {Invalid single-token range for instruction 2 (ict_match_tokrange) at 0}
+{{2 0 1 0} {y x} {}} {Invalid empty range for instruction 2 (ict_match_tokrange) at 0}
+{{2 0 1 0} x {z 1}} {Invalid token rank 0 for instruction 2 (ict_match_tokrange) at 0}
+{{2 1 0 0} x {z 1}} {Invalid token rank 0 for instruction 2 (ict_match_tokrange) at 0}
+{{2 0 0 0} x {z 0}} {Invalid single-token range for instruction 2 (ict_match_tokrange) at 0}
+{{2 1 0 0} x {a 1 b 0}} {Invalid empty range for instruction 2 (ict_match_tokrange) at 0}
diff --git a/tcllib/modules/grammar_me/me_cpucore.tests.semantics.txt b/tcllib/modules/grammar_me/me_cpucore.tests.semantics.txt
new file mode 100644
index 0000000..90a0a43
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_cpucore.tests.semantics.txt
@@ -0,0 +1,279 @@
+{ict_advance, no input, no eof -- suspend&wait}
+{} 0
+0 1 {{0 0} x {}}
+{}
+
+{ict_advance, no input, at eof -- fail}
+{} 1
+0 1 {{0 0} x {}}
+{pc 2 at 0 er {0 x}}
+
+{ict_advance, has input, no eof -- consume}
+{{NUM 1 0 0}} 1
+0 1 {{0 0} x {}}
+{pc 2 at 0 cc NUM ok 1}
+
+{ict_advance, has input, at eof -- consume}
+{{NUM 1 0 0}} 1
+0 1 {{0 0} x {}}
+{pc 2 at 0 cc NUM ok 1}
+
+{icf_halt -- stop engine}
+{} 0
+0 2 {{14 14 14} {} {}}
+{pc 1 ht 1}
+
+{icf_halt -- stopped engine, no instruction advance}
+{} 0
+1 2 {{14 14 14} {} {}}
+{}
+
+{iok_ok -- always match}
+{} 0
+0 1 {8 {} {}}
+{pc 1 ok 1}
+
+{iok_fail -- never match}
+{} 0
+1 1 {{8 9} {} {}}
+{pc 2 ok 0}
+
+{iok_negate -- match negation}
+{} 0
+1 1 {{8 10} {} {}}
+{pc 2 ok 0}
+
+{iok_negate -- match negation}
+{} 0
+1 1 {{9 10} {} {}}
+{pc 2 ok 1}
+
+{icf_jalways -- jump always}
+{} 0
+0 1 {{11 5 8 8 8 8} {} {}}
+{pc 5}
+
+{icf_jok -- jump on ok, !ok -- no jump}
+{} 0
+0 1 {{12 5 8 8 8 8} {} {}}
+{pc 2}
+
+{icf_jok -- jump on ok, ok -- jump}
+{} 0
+1 1 {{8 12 5 8 8 8 8} {} {}}
+{pc 5}
+
+{icf_jfail -- jump on !ok, !ok -- jump}
+{} 0
+0 1 {{13 5 8 8 8 8} {} {}}
+{pc 5}
+
+{icf_jfail -- jump on !ok, ok -- no jump}
+{} 0
+1 1 {{8 13 5 8 8 8 8} {} {}}
+{pc 3}
+
+{icl_push, save current location}
+{{ID lalal 0 0} {NUM 1 0 5}} 0
+2 2 {{0 0 0 0 15 15} x {}}
+{pc 6 ls {1 1}}
+
+{icl_rewind, reset to last saved location}
+{{ID lalal 0 0} {NUM 1 0 5}} 0
+3 1 {{0 0 15 0 0 16} x {}}
+{pc 6 at 0 ls {}}
+
+{icl_pop, discard last saved location}
+{{ID lalal 0 0} {NUM 1 0 5}} 0
+4 1 {{0 0 15 0 0 15 17} x {}}
+{pc 7 ls 0}
+
+{isv_terminal -- semantic value, set for terminal}
+{{ID lalal 0 0} {NUM 1 0 5}} 0
+2 1 {{0 0 0 0 23} x {}}
+{pc 5 sv {{} 1 1} as {{{} 1 1}}}
+
+{isv_clear -- semantic value, clear}
+{{ID lalal 0 0} {NUM 1 0 5}} 0
+3 1 {{0 0 0 0 23 22} x {}}
+{pc 6 sv {}}
+
+{isv_nonterminal_leaf -- semantic value, set for leaf nonterminal}
+{{ID lalal 0 0} {NUM 1 0 5} {NUM 1 0 5}} 0
+4 1 {{0 0 0 0 15 0 0 24 0} x {}}
+{pc 9 sv {0 1 2}}
+
+{isv_nonterminal_range -- semantic value, set for range nonterminal}
+{{ID lalal 0 0} {NUM 1 0 5} {NUM 1 0 5}} 0
+4 1 {{0 0 0 0 15 0 0 25 0} x {}}
+{pc 9 sv {0 1 2 {{} 1 2}}}
+
+{ias_push -- save semantic value on ast stack}
+{{ID lalal 0 0} {NUM 1 0 5} {NUM 1 0 5}} 0
+5 1 {{0 0 0 0 15 0 0 24 0 27} x {}}
+{pc 10 as {{0 1 2}}}
+
+{ias_mark -- remember location on ast stack}
+{{ID lalal 0 0} {NUM 1 0 5} {NUM 1 0 5}} 0
+6 1 {{0 0 0 0 15 0 0 24 0 27 28} x {}}
+{pc 11 ms 0}
+
+{ias_mark -- remember location on ast stack, empty ast stack}
+{{ID lalal 0 0} {NUM 1 0 5} {NUM 1 0 5}} 0
+0 1 {28 {} {}}
+{pc 1 ms -1}
+
+{ias_mrewind -- discard ast stack to last saved location}
+{{ID lalal 0 0} {NUM 1 0 5} {NUM 1 0 5}} 0
+10 1 {{0 0 0 0 15 0 0 24 0 27 28 27 27 27 29} x {}}
+{pc 15 as {{0 1 2}} ms {}}
+
+{ias_mpop -- discard last saved ast location}
+{{ID lalal 0 0} {NUM 1 0 5} {NUM 1 0 5}} 0
+10 1 {{0 0 0 0 15 0 0 24 0 27 28 27 27 27 30} x {}}
+{pc 15 ms {}}
+
+{ict_match_token, no match}
+{{NUM 1 0 0}} 1
+1 1 {{0 0 1 0 1} {x bad} {}}
+{pc 5 ok 0 er {0 bad}}
+
+{ict_match_token, match}
+{{NUM 1 0 0}} 1
+1 1 {{0 0 1 0 1} {NUM bad} {}}
+{pc 5}
+
+{ict_match_token, no match, token map}
+{{NUM 1 0 0}} 1
+1 1 {{0 0 1 5 1} {x bad} {x 5 NUM 7}}
+{pc 5 ok 0 er {0 bad}}
+
+{ict_match_token, match, token map}
+{{NUM 1 0 0}} 1
+1 1 {{0 0 1 7 1} {NUM bad} {NUM 7}}
+{pc 5}
+
+{ict_match_tokrange, no match}
+{{NUM 1 0 0}} 1
+1 1 {{0 0 2 0 1 2} {a z bad} {}}
+{pc 6 ok 0 er {0 bad}}
+
+{ict_match_tokrange, match}
+{{f 1 0 0}} 1
+1 1 {{0 0 2 0 1 2} {a z bad} {}}
+{pc 6}
+
+{ict_match_tokrange, no match, token map}
+{{k 1 0 0}} 1
+1 1 {{0 0 2 5 7 0} {bad} {a 5 x 6 z 7 k 0}}
+{pc 6 ok 0 er {0 bad}}
+
+{ict_match_tokrange, match, token map}
+{{x 1 0 0}} 1
+1 1 {{0 0 2 5 7 0} {bad} {a 5 x 6 z 7 k 0}}
+{pc 6}
+
+{ict_match_tokclass, no match}
+{{NUM 1 0 0}} 1
+1 1 {{0 0 3 2 0} bad {}}
+{pc 5 ok 0 er {0 bad}}
+
+{ict_match_tokclass, match}
+{{8 1 0 0}} 1
+1 1 {{0 0 3 2 0} bad {}}
+{pc 5}
+
+{icf_ntcall -- subroutine invokation}
+{} 0
+0 1 {{6 5 8 8 8 8} {} {}}
+{pc 5 rs 2}
+
+{icf_ntcall -- nested subroutine invokation}
+{} 0
+0 2 {{6 3 8 6 8 8 8 8 8} {} {}}
+{pc 8 rs {2 5}}
+
+{icf_ntreturn -- subroutine return}
+{} 0
+1 1 {{6 5 8 8 8 7} {} {}}
+{pc 2 rs {}}
+
+{icf_ntreturn -- nested subroutine return}
+{} 0
+2 2 {{6 3 7 6 6 7 7} {} {}}
+{pc 2 rs {}}
+
+{inc_save - save match status for nonterminal}
+{{NUM 1 0 0} {SPACE { } 0 1} {ID ident 0 2}} 0
+6 1 {{0 0 0 0 15 15 0 0 23 5 0} {NT} {}}
+{pc 11 ls 1 nc {1,NT {2 1 {} {{} 2 2}}}}
+
+{inc_restore - restore match status for nonterminal - wrong location for restore}
+{{NUM 1 0 0} {SPACE { } 0 1} {ID ident 0 2}} 1
+10 1 {{0 0 0 0 15 15 0 0 23 5 0 0 0 9 22 4 0 0} {NT} {}}
+{pc 18}
+
+{inc_restore - restore match status for nonterminal}
+{{NUM 1 0 0} {SPACE { } 0 1} {ID ident 0 2}} 1
+10 2 {{0 0 0 0 15 15 0 0 23 5 0 0 0 9 22 16 4 0 0} {NT} {}}
+{pc 0 at 2 ok 1 sv {{} 2 2} ls {}}
+
+{ier_push -- save error information}
+{} 0
+0 1 {18 {} {}}
+{pc 1 es {{}}}
+
+{ier_clear -- clear error information, nothing to clear}
+{} 0
+0 1 {19 {} {}}
+{pc 1}
+
+{ier_merge - merge current and pushed error - keep current, pushed is empty}
+{{NUM 1 0 0} {SPACE { } 0 1} {ID ident 0 2}} 0
+3 1 {{18 0 0 1 0 0 21} {XX} {}}
+{pc 7 es {}}
+
+{ier_merge - merge current and pushed error - current is empty, keep pushed}
+{{NUM 1 0 0} {SPACE { } 0 1} {ID ident 0 2}} 0
+5 1 {{18 0 0 1 0 0 18 19 21} {XX} {}}
+{pc 9 er {0 XX} es {{}}}
+
+{ier_merge - merge current and pushed error - old/new identical}
+{{NUM 1 0 0} {SPACE { } 0 1} {ID ident 0 2}} 0
+4 1 {{18 0 0 1 0 0 18 21} {XX} {}}
+{pc 8 es {{}}}
+
+{ier_merge - merge current and pushed error - old/new sam location, merge messages}
+{{NUM 1 0 0} {SPACE { } 0 1} {ID ident 0 2}} 0
+5 1 {{18 0 0 1 0 0 18 1 0 1 21} {XX YY} {}}
+{pc 11 er {0 {XX YY}} es {{}}}
+
+{ier_merge - merge current and pushed error - current further than pushed}
+{{NUM 1 0 0} {SPACE { } 0 1} {ID ident 0 2}} 0
+5 1 {{0 0 1 0 0 18 0 0 1 0 0 21} {XX} {}}
+{pc 12 es {}}
+
+{ier_merge - merge current and pushed error - pushed further than current}
+{{NUM 1 0 0} {SPACE { } 0 1} {ID ident 0 2}} 0
+7 1 {{0 0 15 0 0 1 0 0 18 16 1 0 0 21} {XX} {}}
+{pc 14 er {1 XX} es {}}
+
+{ier_nonterminal - replace token error against nt error}
+{{NUM 1 0 0} {SPACE { } 0 1} {ID ident 0 2}} 0
+4 1 {{0 0 15 0 0 1 0 0 20 1} {X NT} {}}
+{pc 10 er {1 NT}}
+
+{isv_nonterminal_reduce - reduce to bottom}
+{{NUM 1 0 0} {SPACE { } 0 1} {ID ident 0 2}} 0
+6 1 {{0 0 15 0 0 23 23 23 26 2} {NT XX YY} {}}
+{pc 10 sv {2 0 1 {{} 1 1} {{} 1 1} {{} 1 1}}}
+
+{isv_nonterminal_reduce - reduce to mark}
+{{NUM 1 0 0} {SPACE { } 0 1} {ID ident 0 2}} 0
+7 1 {{0 0 15 0 0 23 28 23 23 26 2} {NT XX YY} {}}
+{pc 11 sv {2 0 1 {{} 1 1} {{} 1 1}}}
+
+{isv_nonterminal_reduce - reduce to mark and rewind}
+{{NUM 1 0 0} {SPACE { } 0 1} {ID ident 0 2}} 0
+7 2 {{0 0 15 0 0 23 28 23 23 26 2 29} {NT XX YY} {}}
+{pc 12 sv {2 0 1 {{} 1 1} {{} 1 1}} as {{{} 1 1}} ms {}}
diff --git a/tcllib/modules/grammar_me/me_cpucore.testsuite b/tcllib/modules/grammar_me/me_cpucore.testsuite
new file mode 100644
index 0000000..786b63c
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_cpucore.testsuite
@@ -0,0 +1,419 @@
+# -*- tcl -*- me_cpucore.test
+# ### ### ### ######### ######### #########
+
+# ### ### ### ######### ######### #########
+## Assembler
+
+test me-cpucore-asm-${impl}-1.0 {asm, wrong args} -body {
+ grammar::me::cpu::core::asm
+} -result {wrong # args: should be "grammar::me::cpu::core::asm code"} \
+ -returnCodes error
+
+test me-cpucore-asm-${impl}-1.1 {asm, wrong args} -body {
+ grammar::me::cpu::core::asm a b
+} -result {wrong # args: should be "grammar::me::cpu::core::asm code"} \
+ -returnCodes error
+
+test me-cpucore-asm-${impl}-2.0 {asm, empty} -body {
+ grammar::me::cpu::core::asm {}
+ # No instructions, empty string pool, no token map
+} -result {{} {} {}}
+
+set n -1
+foreach {cmd cargs expected} $asm_table {
+ set asm [list [linsert $cargs 0 branchlabel $cmd]]
+ incr n
+
+ test me-cpucore-asm-${impl}-3.$n "asm, $cmd" -body {
+ canon_code [grammar::me::cpu::core::asm $asm]
+ } -result $expected
+}
+
+set n -1
+foreach {cmd cargs expected} $badasm_table {
+ set asm [list [linsert $cargs 0 branchlabel $cmd]]
+ incr n
+
+ test me-cpucore-asm-${impl}-4.$n "asm, bad $cmd" -body {
+ grammar::me::cpu::core::asm $asm
+ } -result $expected -returnCodes error
+}
+
+# ### ### ### ######### ######### #########
+## Disassembler
+
+test me-cpucore-disasm-${impl}-1.0 {disasm, wrong args} -body {
+ grammar::me::cpu::core::disasm
+} -result {wrong # args: should be "grammar::me::cpu::core::disasm code"} \
+ -returnCodes error
+
+test me-cpucore-disasm-${impl}-1.1 {disasm, wrong args} -body {
+ grammar::me::cpu::core::disasm a b
+} -result {wrong # args: should be "grammar::me::cpu::core::disasm code"} \
+ -returnCodes error
+
+test me-cpucore-disasm-${impl}-2.0 {disasm, empty} -body {
+ # No instructions, empty string pool, no token map
+ grammar::me::cpu::core::disasm {{} {} {}}
+} -result {}
+
+set n -1
+foreach {cmd cargs code} $asm_table {
+ set asm [list [linsert $cargs 0 branchlabel $cmd]]
+ incr n
+
+ # We have to distinguish between regular instructions and
+ # instruction jumping somewhere. For the latter we have to perform
+ # a bit of fixup to get our expections of the branch labeling
+ # right.
+
+ set pos [lsearch -exact $cargs branchlabel]
+ if {$pos >= 0} {
+ set expected [list [linsert [lreplace $cargs $pos $pos bra0] 0 bra0 $cmd]]
+ } else {
+ set expected [list [linsert $cargs 0 {} $cmd]]
+ }
+
+ test me-cpucore-disasm-${impl}-3.$n "disasm, $cmd" -body {
+ grammar::me::cpu::core::disasm $code
+ } -result $expected
+}
+
+set n -1
+foreach {insns expected} $badmach_table {
+ incr n
+
+ test me-cpucore-disasm-${impl}-4.$n "disasm, error" -body {
+ grammar::me::cpu::core::disasm $insns
+ } -result $expected -returnCodes error
+}
+
+# ### ### ### ######### ######### #########
+## State creation.
+
+test me-cpucore-new-${impl}-1.0 {new, wrong args} -body {
+ grammar::me::cpu::core::new
+} -result {wrong # args: should be "grammar::me::cpu::core::new code"} \
+ -returnCodes error
+
+test me-cpucore-new-${impl}-1.1 {new, wrong args} -body {
+ grammar::me::cpu::core::new a b
+} -result {wrong # args: should be "grammar::me::cpu::core::new code"} \
+ -returnCodes error
+
+test me-cpucore-run-${impl}-2.0 run -setup {
+ set state [grammar::me::cpu::core::new {{} {} {}}]
+} -returnCodes error -body {
+ grammar::me::cpu::core::run state
+} -result {No instructions to execute}
+
+set n -1
+foreach {cmd cargs expected} $asm_table {
+ set asm [list [linsert $cargs 0 branchlabel $cmd]]
+ incr n
+
+ test me-cpucore-new-${impl}-3.$n "new, $cmd, code" -body {
+ grammar::me::cpu::core::code \
+ [grammar::me::cpu::core::new \
+ [canon_code [grammar::me::cpu::core::asm $asm]]]
+ } -result $expected
+
+ test me-cpucore-new-${impl}-4.$n "new, $cmd, state" -body {
+ cpusubst [cpustate \
+ [grammar::me::cpu::core::new \
+ [canon_code [grammar::me::cpu::core::asm $asm]]]] \
+ cd {}
+ } -result {cd {} pc 0 ht 0 eo 0 tc {} at -1 cc {} ok 0 sv {} er {} ls {} as {} ms {} es {} rs {} nc {}}
+}
+
+set n -1
+foreach {insns expected} $badmach_table {
+ incr n
+
+ test me-cpucore-new-${impl}-5.$n "new error" -body {
+ grammar::me::cpu::core::new $insns
+ } -result $expected -returnCodes error
+}
+
+# ### ### ### ######### ######### #########
+## State manipulation - Add tokens
+
+test me-cpucore-put-${impl}-1.0 {put, wrong args} -body {
+ grammar::me::cpu::core::put
+} -result {wrong # args: should be "grammar::me::cpu::core::put statevar tok lex line col"} \
+ -returnCodes error
+
+test me-cpucore-put-${impl}-1.1 {put, wrong args} -body {
+ grammar::me::cpu::core::put a
+} -result {wrong # args: should be "grammar::me::cpu::core::put statevar tok lex line col"} \
+ -returnCodes error
+
+test me-cpucore-put-${impl}-1.2 {put, wrong args} -body {
+ grammar::me::cpu::core::put a b
+} -result {wrong # args: should be "grammar::me::cpu::core::put statevar tok lex line col"} \
+ -returnCodes error
+
+test me-cpucore-put-${impl}-1.3 {put, wrong args} -body {
+ grammar::me::cpu::core::put a b c
+} -result {wrong # args: should be "grammar::me::cpu::core::put statevar tok lex line col"} \
+ -returnCodes error
+
+test me-cpucore-put-${impl}-1.4 {put, wrong args} -body {
+ grammar::me::cpu::core::put a b c d
+} -result {wrong # args: should be "grammar::me::cpu::core::put statevar tok lex line col"} \
+ -returnCodes error
+
+test me-cpucore-put-${impl}-1.5 {put, wrong args} -body {
+ grammar::me::cpu::core::put a b c d e f
+} -result {wrong # args: should be "grammar::me::cpu::core::put statevar tok lex line col"} \
+ -returnCodes error
+
+test me-cpucore-put-${impl}-2.0 put -setup {
+ set base [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ set next $base
+} -body {
+ grammar::me::cpu::core::put next ID ident 1 0
+ grammar::me::cpu::core::put next NUM 12345 1 5
+
+ cpudelta $base $next
+} -result {tc {{ID ident 1 0} {NUM 12345 1 5}}}
+
+test me-cpucore-put-${impl}-3.0 {put after eof} -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::eof state
+} -returnCodes error -body {
+ grammar::me::cpu::core::put state ID ident 1 0
+} -result {Cannot add input data after eof}
+
+# ### ### ### ######### ######### #########
+## State manipulation - Set eof
+
+test me-cpucore-eof-${impl}-1.0 {eof, wrong args} -body {
+ grammar::me::cpu::core::eof
+} -result {wrong # args: should be "grammar::me::cpu::core::eof statevar"} \
+ -returnCodes error
+
+test me-cpucore-eof-${impl}-1.1 {eof, wrong args} -body {
+ grammar::me::cpu::core::eof a b
+} -result {wrong # args: should be "grammar::me::cpu::core::eof statevar"} \
+ -returnCodes error
+
+test me-cpucore-eof-${impl}-2.0 eof -setup {
+ set base [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ set next $base
+} -body {
+ grammar::me::cpu::core::eof next
+ cpudelta $base $next
+} -result {eo 1}
+
+# ### ### ### ######### ######### #########
+## State accessors - line/col retrieval
+
+test me-cpucore-lc-${impl}-1.0 {lc, wrong args} -body {
+ grammar::me::cpu::core::lc
+} -result {wrong # args: should be "grammar::me::cpu::core::lc state loc"} \
+ -returnCodes error
+
+test me-cpucore-lc-${impl}-1.1 {lc, wrong args} -body {
+ grammar::me::cpu::core::lc a
+} -result {wrong # args: should be "grammar::me::cpu::core::lc state loc"} \
+ -returnCodes error
+
+test me-cpucore-lc-${impl}-1.2 {lc, wrong args} -body {
+ grammar::me::cpu::core::lc a b c
+} -result {wrong # args: should be "grammar::me::cpu::core::lc state loc"} \
+ -returnCodes error
+
+test me-cpucore-lc-${impl}-2.0 lc -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state NUM 12345 1 5
+} -body {
+ grammar::me::cpu::core::lc $state 0
+} -result {1 5}
+
+test me-cpucore-lc-${impl}-3.0 {lc, bad index} -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state NUM 12345 1 5
+} -body {
+ grammar::me::cpu::core::lc $state -1
+} -result {Illegal location -1} -returnCodes error
+
+test me-cpucore-lc-${impl}-3.1 {lc, bad index} -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state NUM 12345 1 5
+} -body {
+ grammar::me::cpu::core::lc $state 1
+} -result {Illegal location 1} -returnCodes error
+
+test me-cpucore-lc-${impl}-3.2 {lc, bad index} -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+} -body {
+ grammar::me::cpu::core::lc $state 0
+} -result {Illegal location 0} -returnCodes error
+
+# ### ### ### ######### ######### #########
+## State accessors - Token retrieval
+
+test me-cpucore-tok-${impl}-1.0 {tok, wrong args} -body {
+ grammar::me::cpu::core::tok
+} -result [tcltest::wrongNumArgs grammar::me::cpu::core::tok {state args} 0] \
+ -returnCodes error
+
+test me-cpucore-tok-${impl}-1.1 {tok, wrong args} -body {
+ grammar::me::cpu::core::tok a b c d
+} -result {wrong # args: should be "grammar::me::cpu::core::tok state ?from ?to??"} \
+ -returnCodes error
+
+test me-cpucore-tok-${impl}-2.0 tok -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+} -body {
+ grammar::me::cpu::core::tok $state
+} -result {}
+
+test me-cpucore-tok-${impl}-2.1 tok -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state NUM 12345 1 5
+} -body {
+ grammar::me::cpu::core::tok $state
+} -result {{NUM 12345 1 5}}
+
+test me-cpucore-tok-${impl}-2.2 tok -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state ID lalal 0 0
+ grammar::me::cpu::core::put state NUM 12345 1 5
+} -body {
+ grammar::me::cpu::core::tok $state
+} -result {{ID lalal 0 0} {NUM 12345 1 5}}
+
+test me-cpucore-tok-${impl}-3.0 tok -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+} -body {
+ grammar::me::cpu::core::tok $state 0
+} -result {Illegal location 0} -returnCodes error
+
+test me-cpucore-tok-${impl}-3.1 tok -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state NUM 12345 1 5
+} -body {
+ grammar::me::cpu::core::tok $state -1
+} -result {Illegal location -1} -returnCodes error
+
+test me-cpucore-tok-${impl}-3.2 tok -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state NUM 12345 1 5
+} -body {
+ grammar::me::cpu::core::tok $state 1
+} -result {Illegal location 1} -returnCodes error
+
+test me-cpucore-tok-${impl}-3.3 tok -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state NUM 12345 1 5
+} -body {
+ grammar::me::cpu::core::tok $state 0
+} -result {{NUM 12345 1 5}}
+
+test me-cpucore-tok-${impl}-3.4 tok -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state ID lalal 0 0
+ grammar::me::cpu::core::put state NUM 12345 1 5
+} -body {
+ grammar::me::cpu::core::tok $state 0
+} -result {{ID lalal 0 0}}
+
+test me-cpucore-tok-${impl}-4.0 tok -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state NUM 12345 1 5
+} -body {
+ grammar::me::cpu::core::tok $state -1 0
+} -result {Illegal start location -1} -returnCodes error
+
+test me-cpucore-tok-${impl}-4.1 tok -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state NUM 12345 1 5
+} -body {
+ grammar::me::cpu::core::tok $state 1 0
+} -result {Illegal start location 1} -returnCodes error
+
+test me-cpucore-tok-${impl}-4.2 tok -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state NUM 12345 1 5
+} -body {
+ grammar::me::cpu::core::tok $state 0 -1
+} -result {Illegal end location -1} -returnCodes error
+
+test me-cpucore-tok-${impl}-4.3 tok -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state NUM 12345 1 5
+} -body {
+ grammar::me::cpu::core::tok $state 0 1
+} -result {Illegal end location 1} -returnCodes error
+
+test me-cpucore-tok-${impl}-4.4 tok -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state ID lalal 0 0
+ grammar::me::cpu::core::put state NUM 12345 1 5
+} -body {
+ grammar::me::cpu::core::tok $state 1 0
+} -result {Illegal empty location range 1 .. 0} -returnCodes error
+
+test me-cpucore-tok-${impl}-4.5 tok -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state ID lalal 0 0
+ grammar::me::cpu::core::put state NUM 12345 1 5
+} -body {
+ grammar::me::cpu::core::tok $state 0 1
+} -result {{ID lalal 0 0} {NUM 12345 1 5}}
+
+test me-cpucore-tok-${impl}-4.6 tok -setup {
+ set state [grammar::me::cpu::core::new [canon_code [grammar::me::cpu::core::asm {}]]]
+ grammar::me::cpu::core::put state ID lalal 0 0
+ grammar::me::cpu::core::put state ID lalal 0 0
+} -body {
+ grammar::me::cpu::core::tok $state 0 0
+} -result {{ID lalal 0 0}}
+
+# ### ### ### ######### ######### #########
+## Checking the instruction semantics
+
+test me-cpucore-run-${impl}-1.0 {run, wrong args} -body {
+ grammar::me::cpu::core::run
+} -result {wrong # args: should be "grammar::me::cpu::core::run statevar ?steps?"} \
+ -returnCodes error
+
+test me-cpucore-run-${impl}-1.1 {run, wrong args} -body {
+ grammar::me::cpu::core::run a b c
+} -result {wrong # args: should be "grammar::me::cpu::core::run statevar ?steps?"} \
+ -returnCodes error
+
+set n -1
+foreach {description input eof stepsSetup steps code expectedDelta} $semantics {
+ incr n
+
+ if 0 {
+ puts ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ puts $description
+ puts "INPUT $input"
+ puts "EOF $eof"
+ puts "CODE $stepsSetup $steps $code"
+ puts $expectedDelta
+ }
+
+ test me-cpucore-run-${impl}-2.$n "run $description" -setup {
+ set state [grammar::me::cpu::core::new $code]
+ foreach token $input {
+ eval [linsert $token 0 grammar::me::cpu::core::put state]
+ }
+ if {$eof} {
+ grammar::me::cpu::core::eof state
+ }
+ if {$stepsSetup} {
+ grammar::me::cpu::core::run state $stepsSetup
+ }
+ set save $state
+ } -body {
+ grammar::me::cpu::core::run state $steps
+ cpudelta $save $state
+ } -result $expectedDelta
+}
+
+return
diff --git a/tcllib/modules/grammar_me/me_intro.man b/tcllib/modules/grammar_me/me_intro.man
new file mode 100644
index 0000000..ee59bc1
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_intro.man
@@ -0,0 +1,94 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin grammar::me_intro n 0.1]
+[keywords CFG]
+[keywords CFL]
+[keywords {context-free grammar}]
+[keywords {context-free languages}]
+[keywords expression]
+[keywords grammar]
+[keywords LL(k)]
+[keywords matching]
+[keywords parsing]
+[keywords {parsing expression grammar}]
+[keywords PEG]
+[keywords {push down automaton}]
+[keywords {recursive descent}]
+[keywords {top-down parsing languages}]
+[keywords TPDL]
+[keywords transducer]
+[keywords {virtual machine}]
+[copyright {2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Grammar operations and usage}]
+[titledesc {Introduction to virtual machines for parsing token streams}]
+[category {Grammars and finite automata}]
+[description]
+
+This document is an introduction to and overview of the basic
+facilities for the parsing and/or matching of [term token]
+streams. One possibility often used for the token domain are
+characters.
+
+[para]
+
+The packages themselves all provide variants of one
+
+[term {virtual machine}], called a [term {match engine}] (short
+
+[term ME]), which has all the facilities needed for the matching and
+parsing of a stream, and which are either controlled directly, or are
+customized with a match program. The virtual machine is basically a
+pushdown automaton, with additional elements for backtracking and/or
+handling of semantic data and construction of abstract syntax trees
+([term AST]).
+
+[para]
+
+Because of the high degree of similarity in the actual implementations
+of the aforementioned virtual machine and the data structures they
+receive and generate these common parts are specified in a separate
+document which will be referenced by the documentation for packages
+actually implementing it.
+
+[para]
+
+The relevant documents are:
+
+[para]
+[list_begin definitions]
+
+[def [package grammar::me_vm]]
+
+Virtual machine specification.
+
+[def [package grammar::me_ast]]
+
+Specification of various representations used for abstract syntax
+trees.
+
+[def [package grammar::me::util]]
+
+Utility commands.
+
+[def [package grammar::me::tcl]]
+
+Singleton ME virtual machine implementation tied to Tcl for control
+flow and stacks. Hardwired for pull operation. Uninteruptible during
+processing.
+
+[def [package grammar::me::cpu]]
+
+Object-based ME virtual machine implementation with explicit control
+flow, and stacks, using bytecodes. Suspend/Resumable. Push/pull
+operation.
+
+[def [package grammar::me::cpu::core]]
+
+Core functionality for state manipulation and stepping used in the
+bytecode based implementation of ME virtual machines.
+
+[list_end]
+[para]
+
+[vset CATEGORY grammar_me]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/grammar_me/me_tcl.man b/tcllib/modules/grammar_me/me_tcl.man
new file mode 100644
index 0000000..da64b98
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_tcl.man
@@ -0,0 +1,343 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin grammar::me::tcl n 0.1]
+[keywords grammar]
+[keywords parsing]
+[keywords {virtual machine}]
+[copyright {2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Grammar operations and usage}]
+[titledesc {Virtual machine implementation I for parsing token streams}]
+[category {Grammars and finite automata}]
+[require Tcl 8.4]
+[require grammar::me::tcl [opt 0.1]]
+[description]
+[para]
+
+This package provides an implementation of the ME virtual machine.
+Please go and read the document [syscmd grammar::me_intro] first if
+you do not know what a ME virtual machine is.
+
+[para]
+
+This implementation is tied very strongly to Tcl. All the stacks in
+the machine state are handled through the Tcl stack, all control flow
+is handled by Tcl commands, and the remaining machine instructions are
+directly mapped to Tcl commands. Especially the matching of
+nonterminal symbols is handled by Tcl procedures as well, essentially
+extending the machine implementation with custom instructions.
+
+[para]
+
+Further on the implementation handles only a single machine which is
+uninteruptible during execution and hardwired for pull operation. I.e.
+it explicitly requests each new token through a callback, pulling them
+into its state.
+
+[para]
+
+A related package is [package grammar::peg::interp] which provides a
+generic interpreter / parser for parsing expression grammars (PEGs),
+implemented on top of this implementation of the ME virtual machine.
+
+[section {API}]
+
+The commands documented in this section do not implement any of the
+instructions of the ME virtual machine. They provide the facilities
+for the initialization of the machine and the retrieval of important
+information.
+
+[list_begin definitions]
+
+[call [cmd ::grammar::me::tcl] [method cmd] [arg ...]]
+
+This is an ensemble command providing access to the commands listed in
+this section. See the methods themselves for detailed specifications.
+
+[call [cmd ::grammar::me::tcl] [method init] [arg nextcmd] [opt [arg tokmap]]]
+
+This command (re)initializes the machine. It returns the empty
+string. This command has to be invoked before any other command of
+this package.
+
+[para]
+
+The command prefix [arg nextcmd] represents the input stream of
+characters and is invoked by the machine whenever the a new character
+from the stream is required. The instruction for handling this is
+[term ict_advance].
+
+The callback has to return either the empty list, or a list of 4
+elements containing the token, its lexeme attribute, and its location
+as line number and column index, in this order.
+
+The empty list is the signal that the end of the input stream has been
+reached. The lexeme attribute is stored in the terminal cache, but
+otherwise not used by the machine.
+
+[para]
+
+The optional dictionary [arg tokmap] maps from tokens to integer
+numbers. If present the numbers impose an order on the tokens, which
+is subsequently used by [term ict_match_tokrange] to determine if a
+token is in the specified range or not. If no token map is specified
+the lexicographic order of th token names will be used instead. This
+choice is especially asensible when using characters as tokens.
+
+[call [cmd ::grammar::me::tcl] [method lc] [arg location]]
+
+This command converts the location of a token given as offset in the
+input stream into the associated line number and column index. The
+result of the command is a 2-element list containing the two values,
+in the order mentioned in the previous sentence.
+
+This allows higher levels to convert the location information found in
+the error status and the generated AST into more human readable data.
+
+[para]
+
+[emph Note] that the command is not able to convert locations which
+have not been reached by the machine yet. In other words, if the
+machine has read 7 tokens the command is able to convert the offsets
+[const 0] to [const 6], but nothing beyond that. This also shows that
+it is not possible to convert offsets which refer to locations before
+the beginning of the stream.
+
+[para]
+
+After a call of [method init] the state used for the conversion is
+cleared, making further conversions impossible until the machine has
+read tokens again.
+
+[call [cmd ::grammar::me::tcl] [method tok] [arg from] [opt [arg to]]]
+
+This command returns a Tcl list containing the part of the input
+stream between the locations [arg from] and [arg to] (both
+inclusive). If [arg to] is not specified it will default to the value
+of [arg from].
+
+[para]
+
+Each element of the returned list is a list of four elements, the
+token, its associated lexeme, line number, and column index, in this
+order.
+
+In other words, each element has the same structure as the result of
+the [arg nextcmd] callback given to [cmd ::grammar::me::tcl::init]
+
+[para]
+
+This command places the same restrictions on its location arguments as
+[cmd ::grammar::me::tcl::lc].
+
+[call [cmd ::grammar::me::tcl] [method tokens]]
+
+This command returns the number of tokens currently known to the ME
+virtual machine.
+
+[call [cmd ::grammar::me::tcl] [method sv]]
+
+This command returns the current semantic value [term SV] stored in
+the machine. This is an abstract syntax tree as specified in the
+document [syscmd grammar::me_ast], section [sectref-external {AST VALUES}].
+
+[call [cmd ::grammar::me::tcl] [method ast]]
+
+This method returns the abstract syntax tree currently at the top of
+the AST stack of the ME virtual machine. This is an abstract syntax
+tree as specified in the document [syscmd grammar::me_ast], section
+[sectref-external {AST VALUES}].
+
+[call [cmd ::grammar::me::tcl] [method astall]]
+
+This method returns the whole stack of abstract syntax trees currently
+known to the ME virtual machine. Each element of the returned list is
+an abstract syntax tree as specified in the document
+
+[syscmd grammar::me_ast], section [sectref-external {AST VALUES}].
+The top of the stack resides at the end of the list.
+
+[call [cmd ::grammar::me::tcl] [method ctok]]
+
+This method returns the current token considered by the ME virtual
+machine.
+
+[call [cmd ::grammar::me::tcl] [method nc]]
+
+This method returns the contents of the nonterminal cache as a
+dictionary mapping from "[var symbol],[var location]" to match
+information.
+
+[call [cmd ::grammar::me::tcl] [method next]]
+
+This method returns the next token callback as specified during
+initialization of the ME virtual machine.
+
+[call [cmd ::grammar::me::tcl] [method ord]]
+
+This method returns a dictionary containing the [arg tokmap] specified
+during initialization of the ME virtual machine.
+
+[var [cmd ::grammar::me::tcl::ok]]
+
+This variable contains the current match status [term OK]. It is
+provided as variable instead of a command because that makes access to
+this information faster, and the speed of access is considered very
+important here as this information is used constantly to determine the
+control flow.
+
+[list_end]
+[para]
+
+[section {MACHINE STATE}]
+
+Please go and read the document [syscmd grammar::me_vm] first for a
+specification of the basic ME virtual machine and its state.
+
+[para]
+
+This implementation manages the state described in that document,
+except for the stacks minus the AST stack. In other words, location
+stack, error stack, return stack, and ast marker stack are implicitly
+managed through standard Tcl scoping, i.e. Tcl variables in
+procedures, outside of this implementation.
+
+[section {MACHINE INSTRUCTIONS}]
+
+Please go and read the document [syscmd grammar::me_vm] first for a
+specification of the basic ME virtual machine and its instruction set.
+
+[para]
+
+This implementation maps all instructions to Tcl commands in the
+namespace "::grammar::me::tcl", except for the stack related commands,
+nonterminal symbols and control flow.
+
+Here we simply list the commands and explain the differences to the
+specified instructions, if there are any. For their semantics see the
+aforementioned specification. The machine commands are [emph not]
+reachable through the ensemble command [cmd ::grammar::me::tcl].
+
+[para]
+[list_begin definitions]
+
+[call [cmd ::grammar::me::tcl::ict_advance] [arg message]]
+No changes.
+
+[call [cmd ::grammar::me::tcl::ict_match_token] [arg tok] [arg message]]
+No changes.
+
+[call [cmd ::grammar::me::tcl::ict_match_tokrange] [arg tokbegin] [arg tokend] [arg message]]
+
+If, and only if a token map was specified during initialization then
+the arguments are the numeric representations of the smallest and
+largest tokens in the range. Otherwise they are the relevant tokens
+themselves and lexicographic comparison is used.
+
+[call [cmd ::grammar::me::tcl::ict_match_tokclass] [arg code] [arg message]]
+No changes.
+
+[call [cmd ::grammar::me::tcl::inc_restore] [arg nt]]
+
+Instead of taking a branchlabel the command returns a boolean value.
+The result will be [const true] if and only if cached information was
+found. The caller has to perform the appropriate branching.
+
+[call [cmd ::grammar::me::tcl::inc_save] [arg nt] [arg startlocation]]
+
+The command takes the start location as additional argument, as it is
+managed on the Tcl stack, and not in the machine state.
+
+[def "[cmd icf_ntcall] [arg branchlabel]"]
+[def [cmd icf_ntreturn]]
+
+These two instructions are not mapped to commands. They are control
+flow instructions and handled in Tcl.
+
+[call [cmd ::grammar::me::tcl::iok_ok]]
+No changes.
+
+[call [cmd ::grammar::me::tcl::iok_fail]]
+No changes.
+
+[call [cmd ::grammar::me::tcl::iok_negate]]
+No changes.
+
+[def "[cmd icf_jalways] [arg branchlabel]"]
+[def "[cmd icf_jok] [arg branchlabel]"]
+[def "[cmd icf_jfail] [arg branchlabel]"]
+[def [cmd icf_halt]]
+
+These four instructions are not mapped to commands. They are control
+flow instructions and handled in Tcl.
+
+[call [cmd ::grammar::me::tcl::icl_get]]
+
+This command returns the current location [term CL] in the input.
+It replaces [term icl_push].
+
+[call [cmd ::grammar::me::tcl::icl_rewind] [arg oldlocation]]
+
+The command takes the location as argument as it comes from the
+Tcl stack, not the machine state.
+
+[def [cmd icl_pop]]
+
+Not mapped, the stacks are not managed by the package.
+
+[call [cmd ::grammar::me::tcl::ier_get]]
+
+This command returns the current error state [term ER].
+It replaces [term ier_push].
+
+[call [cmd ::grammar::me::tcl::ier_clear]]
+No changes.
+
+[call [cmd ::grammar::me::tcl::ier_nonterminal] [arg message] [arg location]]
+
+The command takes the location as argument as it comes from the
+Tcl stack, not the machine state.
+
+[call [cmd ::grammar::me::tcl::ier_merge] [arg olderror]]
+
+The command takes the second error state to merge as argument as it
+comes from the Tcl stack, not the machine state.
+
+[call [cmd ::grammar::me::tcl::isv_clear]]
+No changes.
+
+[call [cmd ::grammar::me::tcl::isv_terminal]]
+No changes.
+
+[call [cmd ::grammar::me::tcl::isv_nonterminal_leaf] [arg nt] [arg startlocation]]
+
+The command takes the start location as argument as it comes from the
+Tcl stack, not the machine state.
+
+[call [cmd ::grammar::me::tcl::isv_nonterminal_range] [arg nt] [arg startlocation]]
+
+The command takes the start location as argument as it comes from the
+Tcl stack, not the machine state.
+
+[call [cmd ::grammar::me::tcl::isv_nonterminal_reduce] [arg nt] [arg startlocation] [opt [arg marker]]]
+
+The command takes start location and marker as argument as it comes
+from the Tcl stack, not the machine state.
+
+[call [cmd ::grammar::me::tcl::ias_push]]
+No changes.
+
+[call [cmd ::grammar::me::tcl::ias_mark]]
+
+This command returns a marker for the current state of the AST stack
+[term AS]. The marker stack is not managed by the machine.
+
+[call [cmd ::grammar::me::tcl::ias_pop2mark] [arg marker]]
+
+The command takes the marker as argument as it comes from the
+Tcl stack, not the machine state. It replaces [term ias_mpop].
+
+[list_end]
+[para]
+
+[vset CATEGORY grammar_me]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/grammar_me/me_tcl.tcl b/tcllib/modules/grammar_me/me_tcl.tcl
new file mode 100644
index 0000000..e0e86e4
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_tcl.tcl
@@ -0,0 +1,521 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Package description
+
+## Implementation of the ME virtual machine as a singleton, tied to
+## Tcl for control flow and stack handling (except the AST stack).
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+namespace eval ::grammar::me::tcl {
+ namespace export \
+ init lc tok sv tokens ast \
+ astall ctok nc next ord \
+ \
+ isv_clear ict_advance inc_save \
+ isv_terminal ict_match_token inc_restore \
+ isv_nonterminal_leaf ict_match_tokrange icl_get \
+ isv_nonterminal_range ict_match_tokclass icl_rewind \
+ isv_nonterminal_reduce iok_ok \
+ ier_clear iok_fail \
+ ier_get iok_negate \
+ ier_expected ias_push \
+ ier_nonterminal ias_mark \
+ ier_merge ias_pop2mark
+
+ variable ok
+}
+
+# ### ### ### ######### ######### #########
+## Implementation, API. Ensemble command.
+
+proc ::grammar::me::tcl {cmd args} {
+ # Dispatcher for the ensemble command.
+ variable tcl::cmds
+ return [uplevel 1 [linsert $args 0 $cmds($cmd)]]
+}
+
+namespace eval grammar::me::tcl {
+ variable cmds
+
+ # Mapping from cmd names to procedures for quick dispatch. The
+ # objects will shimmer into resolved command references.
+
+ array set cmds {
+ init ::grammar::me::tcl::init
+ lc ::grammar::me::tcl::lc
+ tok ::grammar::me::tcl::tok
+ sv ::grammar::me::tcl::sv
+ tokens ::grammar::me::tcl::tokens
+ ast ::grammar::me::tcl::ast
+ astall ::grammar::me::tcl::astall
+ ctok ::grammar::me::tcl::ctok
+ nc ::grammar::me::tcl::nc
+ next ::grammar::me::tcl::next
+ ord ::grammar::me::tcl::ord
+ }
+}
+
+# ### ### ### ######### ######### #########
+## API Implementation.
+
+proc ::grammar::me::tcl::init {nxcmd {tokmap {}}} {
+ variable next $nxcmd
+ variable as {}
+ variable ok 0
+ variable error {}
+ variable sv {}
+ variable loc -1
+ variable ct {}
+ variable tc {}
+ variable nc
+ variable tokOrd
+ variable tokUseOrd 0
+
+ array unset nc *
+ array unset tokOrd *
+
+ if {[llength $tokmap]} {
+ if {[llength $tokmap] % 2 == 1} {
+ return -code error \
+ "Bad token order map, not a dictionary"
+ }
+ array set tokOrd $tokmap
+ set tokUseOrd 1
+ }
+ return
+}
+
+proc ::grammar::me::tcl::lc {pos} {
+ variable tc
+ return [lrange [lindex $tc $pos] 2 3]
+}
+
+proc ::grammar::me::tcl::tok {from {to {}}} {
+ variable tc
+ if {$to == {}} {set to $from}
+ return [lrange $tc $from $to]
+}
+
+proc ::grammar::me::tcl::tokens {} {
+ variable tc
+ return [llength $tc]
+}
+
+proc ::grammar::me::tcl::sv {} {
+ variable sv
+ return $sv
+}
+
+proc ::grammar::me::tcl::ast {} {
+ variable as
+ return [lindex $as end]
+}
+
+proc ::grammar::me::tcl::astall {} {
+ variable as
+ return $as
+}
+
+proc ::grammar::me::tcl::ctok {} {
+ variable ct
+ return $ct
+}
+
+proc ::grammar::me::tcl::nc {} {
+ variable nc
+ return [array get nc]
+}
+
+proc ::grammar::me::tcl::next {} {
+ variable next
+ return $next
+}
+
+proc ::grammar::me::tcl::ord {} {
+ variable tokOrd
+ return [array get tokOrd]
+}
+
+# ### ### ### ######### ######### #########
+## Terminal matching
+
+proc ::grammar::me::tcl::ict_advance {msg} {
+ # Inlined: Getch, Expected, ClearErrors
+
+ variable ok
+ variable error
+ # ------------------------
+ variable tc
+ variable loc
+ variable ct
+ # ------------------------
+ variable next
+ # ------------------------
+
+ # Satisfy from input cache if possible.
+ incr loc
+ if {$loc < [llength $tc]} {
+ set ct [lindex $tc $loc 0]
+ set ok 1
+ set error {}
+ return
+ }
+
+ # Actually read from the input, and remember
+ # the information.
+
+ # Read from buffer, and remember.
+ # Note: loc is the instance variable.
+ # This implicitly increments the location!
+
+ set tokdata [uplevel \#0 $next]
+ if {![llength $tokdata]} {
+ set ok 0
+ set error [list $loc [list $msg]]
+ return
+ } elseif {[llength $tokdata] != 4} {
+ return -code error "Bad callback result, expected 4 elements"
+ }
+
+ lappend tc $tokdata
+ set ct [lindex $tokdata 0]
+ set ok 1
+ set error {}
+ return
+}
+
+proc ::grammar::me::tcl::ict_match_token {tok msg} {
+ variable ct
+ variable ok
+
+ set ok [expr {$tok eq $ct}]
+
+ OkFail $msg
+ return
+}
+
+proc ::grammar::me::tcl::ict_match_tokrange {toks toke msg} {
+ variable ct
+ variable ok
+ variable tokUseOrd
+ variable tokOrd
+
+ if {$tokUseOrd} {
+ set ord $tokOrd($ct)
+ set ok [expr {
+ ($toks <= $ord) &&
+ ($ord <= $toke)
+ }] ; # {}
+ } else {
+ set ok [expr {
+ ([string compare $toks $ct] <= 0) &&
+ ([string compare $ct $toke] <= 0)
+ }] ; # {}
+ }
+
+ OkFail $msg
+ return
+}
+
+proc ::grammar::me::tcl::ict_match_tokclass {code msg} {
+ variable ct
+ variable ok
+
+ set ok [string is $code -strict $ct]
+
+ OkFail $msg
+ return
+}
+
+proc ::grammar::me::tcl::OkFail {msg} {
+ variable ok
+ variable error
+ variable loc
+
+ # Inlined: Expected, Unget, ClearErrors
+
+ if {!$ok} {
+ set error [list $loc [list $msg]]
+ incr loc -1
+ } else {
+ set error {}
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Nonterminal cache
+
+proc ::grammar::me::tcl::inc_restore {symbol} {
+ variable loc
+ variable nc
+ variable ok
+ variable error
+ variable sv
+
+ # Satisfy from cache if possible.
+ if {[info exists nc($loc,$symbol)]} {
+ foreach {go ok error sv} $nc($loc,$symbol) break
+
+ # Go forward, as the nonterminal matches (or not).
+ set loc $go
+ return 1
+ }
+ return 0
+}
+
+proc ::grammar::me::tcl::inc_save {symbol at} {
+ variable loc
+ variable nc
+ variable ok
+ variable error
+ variable sv
+
+ if 0 {
+ if {[info exists nc($at,$symbol)]} {
+ return -code error "Cannot overwrite\
+ existing data @ ($at, $symbol)"
+ }
+ }
+
+ # FIXME - end location should be argument.
+
+ # Store not only the value, but also how far
+ # the match went (if it was a match).
+
+ set nc($at,$symbol) [list $loc $ok $error $sv]
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Unconditional matching.
+
+proc ::grammar::me::tcl::iok_ok {} {
+ variable ok 1
+ return
+}
+
+proc ::grammar::me::tcl::iok_fail {} {
+ variable ok 0
+ return
+}
+
+proc ::grammar::me::tcl::iok_negate {} {
+ variable ok
+ set ok [expr {!$ok}]
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Basic input handling and tracking
+
+proc ::grammar::me::tcl::icl_get {} {
+ variable loc
+ return $loc
+}
+
+proc ::grammar::me::tcl::icl_rewind {oldloc} {
+ variable loc
+
+ if 0 {
+ if {($oldloc < -1) || ($oldloc > $loc)} {
+ return -code error "Bad location \"$oldloc\" (vs $loc)"
+ }
+ }
+ set loc $oldloc
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Error handling.
+
+proc ::grammar::me::tcl::ier_get {} {
+ variable error
+ return $error
+}
+
+proc ::grammar::me::tcl::ier_clear {} {
+ variable error {}
+ return
+}
+
+proc ::grammar::me::tcl::ier_nonterminal {msg pos} {
+ # Inlined: Errors, Expected.
+
+ variable error
+
+ if {[llength $error]} {
+ foreach {l m} $error break
+ incr pos
+ if {$l == $pos} {
+ set error [list $l [list $msg]]
+ }
+ }
+}
+
+proc ::grammar::me::tcl::ier_merge {new} {
+ variable error
+
+ # We have either old or new error data, keep it.
+
+ if {![llength $error]} {set error $new ; return}
+ if {![llength $new]} {return}
+
+ # If one of the errors is further on in the input choose that as
+ # the information to propagate.
+
+ foreach {loe msgse} $error break
+ foreach {lon msgsn} $new break
+
+ if {$lon > $loe} {set error $new ; return}
+ if {$loe > $lon} {return}
+
+ # Equal locations, merge the message lists.
+
+ foreach m $msgsn {lappend msgse $m}
+ set error [list $loe [lsort -uniq $msgse]]
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Operations for the construction of the
+## abstract syntax tree (AST).
+
+proc ::grammar::me::tcl::isv_clear {} {
+ variable sv {}
+ return
+}
+
+proc ::grammar::me::tcl::isv_terminal {} {
+ variable loc
+ variable sv
+ variable as
+
+ set sv [list {} $loc $loc]
+ lappend as $sv
+ return
+}
+
+proc ::grammar::me::tcl::isv_nonterminal_leaf {nt pos} {
+ # Inlined clear, reduce, and optimized.
+ variable ok
+ variable loc
+ variable sv {}
+
+ # Clear ; if {$ok} {Reduce $nt}
+
+ if {$ok} {
+ incr pos
+ set sv [list $nt $pos $loc]
+ }
+ return
+}
+
+proc ::grammar::me::tcl::isv_nonterminal_range {nt pos} {
+ variable ok
+ variable loc
+ variable sv {}
+
+ if {$ok} {
+ # TerminalString $pos
+ # Get all characters after 'pos' to current location as terminal data.
+
+ incr pos
+ set sv [list $nt $pos $loc [list {} $pos $loc]]
+
+ #set sv [linsert $sv 0 $nt] ;#Reduce $nt
+ }
+ return
+}
+
+proc ::grammar::me::tcl::isv_nonterminal_reduce {nt pos {mrk 0}} {
+ variable ok
+ variable as
+ variable loc
+ variable sv {}
+
+ if {$ok} {
+ incr pos
+ set sv [lrange $as $mrk end] ;#SaveToMark $mrk
+ set sv [linsert $sv 0 $nt $pos $loc] ;#Reduce $nt
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## AST stack handling
+
+proc ::grammar::me::tcl::ias_push {} {
+ variable as
+ variable sv
+ lappend as $sv
+ return
+}
+
+proc ::grammar::me::tcl::ias_mark {} {
+ variable as
+ return [llength $as]
+}
+
+proc ::grammar::me::tcl::ias_pop2mark {mark} {
+ variable as
+ if {[llength $as] <= $mark} return
+ incr mark -1
+ set as [lrange $as 0 $mark]
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Data structures.
+
+namespace eval ::grammar::me::tcl {
+ # ### ### ### ######### ######### #########
+ ## Public State of MVM (Matching Virtual Machine)
+
+ variable ok 0 ; # Boolean: Ok/Fail of last match operation.
+
+ # ### ### ### ######### ######### #########
+ ## Internal state.
+
+ variable ct {} ; # Current token.
+ variable loc 0 ; # Location of 'ct' as offset in input.
+
+ variable error {} ; # Error data for last match.
+ # ; # == List (loc, list of strings)
+ # ; # or empty list
+ variable sv {} ; # Semantic value for last match.
+
+ # ### ### ### ######### ######### #########
+ ## Data structures for AST construction
+
+ variable as {} ; # Stack of values for AST
+
+ # ### ### ### ######### ######### #########
+ ## Memo data structures for tokens and match results.
+
+ variable tc {}
+ variable nc ; array set nc {}
+
+ # ### ### ### ######### ######### #########
+ ## Input buffer, location of next character to read.
+ ## ASSERT (loc <= cloc)
+
+ variable next ; # Callback to get next character.
+
+ # Token ordering for range checks. Optional
+
+ variable tokOrd ; array set tokOrd {}
+ variable tokUseOrd 0
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Package Management
+
+package provide grammar::me::tcl 0.1
diff --git a/tcllib/modules/grammar_me/me_tcl.test b/tcllib/modules/grammar_me/me_tcl.test
new file mode 100644
index 0000000..4847a4b
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_tcl.test
@@ -0,0 +1,1615 @@
+# me_tcl.test: Tests for the ME virtual machine -*- tcl -*-
+#
+# This file contains a collection of tests for one or more of the
+# commands making up the ME virtual machine. Sourcing this file into
+# Tcl runs the tests and generates output for errors. No output means
+# no errors were found.
+#
+# Copyright (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: me_tcl.test,v 1.8 2007/08/01 22:49:26 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.1
+
+testing {
+ useLocal me_tcl.tcl grammar::me::tcl
+}
+
+# ### ### ### ######### ######### #########
+## Pre-requisites. Helper commands to inspect the state of the ME
+## virtual machine.
+
+proc ME_state {} {
+ # This command retrieves all parts of the ME virtual machine state
+ # for inspection by the testing commands. The result is a dictionary.
+
+ set res {}
+
+ lappend res [list tok__ [grammar::me::tcl ctok]]
+ lappend res [list loc__ [grammar::me::tcl::icl_get]]
+ lappend res [list ok___ $grammar::me::tcl::ok]
+ lappend res [list error [grammar::me::tcl::ier_get]]
+ lappend res [list sv___ [grammar::me::tcl sv]]
+ lappend res [list ast__ [grammar::me::tcl astall]]
+
+ set nt [grammar::me::tcl tokens]
+ incr nt -1
+ lappend res [list input [grammar::me::tcl tok 0 $nt]]
+
+ lappend res [list cache [dictsort [grammar::me::tcl nc]]]
+ lappend res [list next_ [grammar::me::tcl next]]
+ lappend res [list ord__ [dictsort [grammar::me::tcl ord]]]
+
+ return $res
+}
+
+proc ME_stateText {} {
+ join [ME_state] \n
+}
+
+proc next_badresult {} {return a}
+
+proc next_eof {} {return {}}
+
+proc next_char {x} {return [list $x 3 4 {}]}
+
+proc next_count {} {
+ global count
+ incr count
+ return [list T$count 1 $count $count]
+}
+proc nc_init {} {
+ global count
+ set count 0
+ return
+}
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-init-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -body {
+ grammar::me::tcl::init
+ } -result {wrong # args: should be "grammar::me::tcl::init nxcmd ?tokmap?"}
+
+test mevmtcl-init-1.1 {Call with too many arguments} \
+ -returnCodes error \
+ -body {
+ grammar::me::tcl::init a b c
+ } -result {wrong # args: should be "grammar::me::tcl::init nxcmd ?tokmap?"}
+
+test mevmtcl-init-1.2 {Call with bad token map} \
+ -returnCodes error \
+ -body {
+ grammar::me::tcl::init a b
+ } -result {Bad token order map, not a dictionary}
+
+
+test mevmtcl-init-2.0 {Basic initialization} \
+ -body {
+ grammar::me::tcl::init fake
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 0
+error {}
+sv___ {}
+ast__ {}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+test mevmtcl-init-2.1 {Basic initialization, with map} \
+ -body {
+ grammar::me::tcl::init fakeB {ident 0}
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 0
+error {}
+sv___ {}
+ast__ {}
+input {}
+cache {}
+next_ fakeB
+ord__ {ident 0}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-ict_advance-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ict_advance
+ } -result {wrong # args: should be "grammar::me::tcl::ict_advance msg"}
+
+test mevmtcl-ict_advance-1.1 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ict_advance a b
+ } -result {wrong # args: should be "grammar::me::tcl::ict_advance msg"}
+
+test mevmtcl-ict_advance-1.2 {Bad next callback} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ict_advance foo
+ } -result {invalid command name "fake"}
+
+test mevmtcl-ict_advance-1.3 {Bad next callback, bad results} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init next_badresult
+ } -body {
+ grammar::me::tcl::ict_advance foo
+ } -result {Bad callback result, expected 4 elements}
+
+
+test mevmtcl-ict_advance-2.0 {Behaviour at eof} \
+ -setup {
+ grammar::me::tcl::init next_eof
+ } -body {
+ grammar::me::tcl::ict_advance "foo (got EOF)"
+ ME_stateText
+ } -result {tok__ {}
+loc__ 0
+ok___ 0
+error {0 {{foo (got EOF)}}}
+sv___ {}
+ast__ {}
+input {}
+cache {}
+next_ next_eof
+ord__ {}}
+
+test mevmtcl-ict_advance-2.1 {Behaviour for regular token} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ } -body {
+ grammar::me::tcl::ict_advance foo
+ ME_stateText
+ } -result {tok__ T1
+loc__ 0
+ok___ 1
+error {}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {}}
+
+test mevmtcl-ict_advance-2.2 {Behaviour for backtracing in input} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::icl_rewind 0
+ } -body {
+ grammar::me::tcl::ict_advance foo
+ ME_stateText
+ } -result {tok__ T2
+loc__ 1
+ok___ 1
+error {}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1} {T2 1 2 2} {T3 1 3 3}}
+cache {}
+next_ next_count
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-ict_match_token-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ict_match_token
+ } -result {wrong # args: should be "grammar::me::tcl::ict_match_token tok msg"}
+
+test mevmtcl-ict_match_token-1.1 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ict_match_token a b c
+ } -result {wrong # args: should be "grammar::me::tcl::ict_match_token tok msg"}
+
+
+test mevmtcl-ict_match_token-2.0 {Token is matching} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::ict_match_token T1 "Expected foo"
+ ME_stateText
+ } -result {tok__ T1
+loc__ 0
+ok___ 1
+error {}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {}}
+
+test mevmtcl-ict_match_token-2.1 {Token is not matching} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::ict_match_token BOGUS "Expected 'BOGUS'"
+ ME_stateText
+ } -result {tok__ T1
+loc__ -1
+ok___ 0
+error {0 {{Expected 'BOGUS'}}}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-ict_match_tokrange-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ict_match_tokrange
+ } -result {wrong # args: should be "grammar::me::tcl::ict_match_tokrange toks toke msg"}
+
+test mevmtcl-ict_match_tokrange-1.1 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ict_match_tokrange a b c d
+ } -result {wrong # args: should be "grammar::me::tcl::ict_match_tokrange toks toke msg"}
+
+
+test mevmtcl-ict_match_tokrange-2.0 {Token range, lexicographic compare, outside low} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::ict_match_tokrange T2 T4 "\[T2 .. T4\]"
+ ME_stateText
+ } -result {tok__ T1
+loc__ -1
+ok___ 0
+error {0 {{[T2 .. T4]}}}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {}}
+
+test mevmtcl-ict_match_tokrange-2.1 {Token range, lexicographic compare, outside up} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::ict_match_tokrange A S "\[A .. S\]"
+ ME_stateText
+ } -result {tok__ T1
+loc__ -1
+ok___ 0
+error {0 {{[A .. S]}}}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {}}
+
+test mevmtcl-ict_match_tokrange-2.2 {Token range, lexicographic compare, in range} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::ict_match_tokrange A T2 "\[A .. T2\]"
+ ME_stateText
+ } -result {tok__ T1
+loc__ 0
+ok___ 1
+error {}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {}}
+
+test mevmtcl-ict_match_tokrange-2.3 {Token range, lexicographic compare, in range, low edge} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::ict_match_tokrange T1 T5 "\[T1 .. T5\]"
+ ME_stateText
+ } -result {tok__ T1
+loc__ 0
+ok___ 1
+error {}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {}}
+
+test mevmtcl-ict_match_tokrange-2.4 {Token range, lexicographic compare, in range, upper edge} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::ict_match_tokrange A T1 "\[A .. T1\]"
+ ME_stateText
+ } -result {tok__ T1
+loc__ 0
+ok___ 1
+error {}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {}}
+
+
+test mevmtcl-ict_match_tokrange-3.0 {Token range, map order compare, outside low} \
+ -setup {
+ grammar::me::tcl::init next_count {T1 0 A 1 B 2}
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::ict_match_tokrange 1 2 "\[A .. B\]"
+ ME_stateText
+ } -result {tok__ T1
+loc__ -1
+ok___ 0
+error {0 {{[A .. B]}}}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {A 1 B 2 T1 0}}
+
+test mevmtcl-ict_match_tokrange-3.1 {Token range, map order compare, outside up} \
+ -setup {
+ grammar::me::tcl::init next_count {A 1 B 2 T1 3}
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::ict_match_tokrange 1 2 "\[A .. B\]"
+ ME_stateText
+ } -result {tok__ T1
+loc__ -1
+ok___ 0
+error {0 {{[A .. B]}}}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {A 1 B 2 T1 3}}
+
+test mevmtcl-ict_match_tokrange-3.2 {Token range, map order compare, in range} \
+ -setup {
+ grammar::me::tcl::init next_count {A 1 T1 2 B 3}
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::ict_match_tokrange 1 3 "\[A .. B\]"
+ ME_stateText
+ } -result {tok__ T1
+loc__ 0
+ok___ 1
+error {}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {A 1 B 3 T1 2}}
+
+test mevmtcl-ict_match_tokrange-3.3 {Token range, map order compare, in range, low edge} \
+ -setup {
+ grammar::me::tcl::init next_count {T1 0 A 1 B 2}
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::ict_match_tokrange 0 1 "\[T1 .. A\]"
+ ME_stateText
+ } -result {tok__ T1
+loc__ 0
+ok___ 1
+error {}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {A 1 B 2 T1 0}}
+
+test mevmtcl-ict_match_tokrange-3.4 {Token range, map order compare, in range, upper edge} \
+ -setup {
+ grammar::me::tcl::init next_count {A 0 B 1 T1 2}
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::ict_match_tokrange 0 2 "\[A .. T1\]"
+ ME_stateText
+ } -result {tok__ T1
+loc__ 0
+ok___ 1
+error {}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {A 0 B 1 T1 2}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-ict_match_tokclass-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ict_match_tokclass
+ } -result {wrong # args: should be "grammar::me::tcl::ict_match_tokclass code msg"}
+
+test mevmtcl-ict_match_tokclass-1.1 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ict_match_tokclass a b c
+ } -result {wrong # args: should be "grammar::me::tcl::ict_match_tokclass code msg"}
+
+test mevmtcl-ict_match_tokclass-1.2a {Call with bad code} \
+ -constraints {tcl8.5plus tcl8.5minus} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ict_match_tokclass gargle foo
+ } -result {bad class "gargle": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}
+
+test mevmtcl-ict_match_tokclass-1.2b {Call with bad code} \
+ -constraints {!tcl8.5plus} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ict_match_tokclass gargle foo
+ } -result {bad class "gargle": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, lower, print, punct, space, true, upper, wordchar, or xdigit}
+
+test mevmtcl-ict_match_tokclass-1.2c {Call with bad code} \
+ -constraints tcl8.6plus \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ict_match_tokclass gargle foo
+ } -result {bad class "gargle": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}
+
+test mevmtcl-ict_match_tokclass-2.0 {Token is matching} \
+ -setup {
+ grammar::me::tcl::init {next_char X}
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::ict_match_tokclass alpha "<alpha>"
+ ME_stateText
+ } -result {tok__ X
+loc__ 0
+ok___ 1
+error {}
+sv___ {}
+ast__ {}
+input {{X 3 4 {}}}
+cache {}
+next_ {next_char X}
+ord__ {}}
+
+test mevmtcl-ict_match_tokclass-2.1 {Token is not matching} \
+ -setup {
+ grammar::me::tcl::init {next_char 0}
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::ict_match_tokclass alpha "<alpha>"
+ ME_stateText
+ } -result {tok__ 0
+loc__ -1
+ok___ 0
+error {0 <alpha>}
+sv___ {}
+ast__ {}
+input {{0 3 4 {}}}
+cache {}
+next_ {next_char 0}
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-inc_save-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::inc_save
+ } -result {wrong # args: should be "grammar::me::tcl::inc_save symbol at"}
+
+test mevmtcl-inc_save-1.1 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::inc_save a b c
+ } -result {wrong # args: should be "grammar::me::tcl::inc_save symbol at"}
+
+
+test mevmtcl-inc_save-2.0 {Basic save of nonterminal match data} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::inc_save A -1
+ ME_stateText
+ } -result {tok__ T2
+loc__ 1
+ok___ 1
+error {}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1} {T2 1 2 2}}
+cache {-1,A {1 1 {} {}}}
+next_ next_count
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-inc_restore-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::inc_restore
+ } -result {wrong # args: should be "grammar::me::tcl::inc_restore symbol"}
+
+test mevmtcl-inc_restore-1.1 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::inc_restore a b
+ } -result {wrong # args: should be "grammar::me::tcl::inc_restore symbol"}
+
+
+test mevmtcl-inc_restore-2.0 {Restore match data, not present} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::icl_rewind -1
+ grammar::me::tcl::iok_fail
+ } -body {
+ list [grammar::me::tcl::inc_restore A] [ME_stateText]
+ } -result {0 {tok__ T2
+loc__ -1
+ok___ 0
+error {}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1} {T2 1 2 2}}
+cache {}
+next_ next_count
+ord__ {}}}
+
+test mevmtcl-inc_restore-2.1 {Restore match data from cache} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::inc_save A -1
+ grammar::me::tcl::icl_rewind -1
+ grammar::me::tcl::iok_fail
+ } -body {
+ list [grammar::me::tcl::inc_restore A] [ME_stateText]
+ } -result {1 {tok__ T2
+loc__ 1
+ok___ 1
+error {}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1} {T2 1 2 2}}
+cache {-1,A {1 1 {} {}}}
+next_ next_count
+ord__ {}}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-iok_ok-1.0 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::iok_ok a
+ } -result {wrong # args: should be "grammar::me::tcl::iok_ok"}
+
+
+test mevmtcl-iok_ok-2.0 {Regular behaviour} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::iok_ok
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 1
+error {}
+sv___ {}
+ast__ {}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-iok_fail-1.0 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::iok_fail a
+ } -result {wrong # args: should be "grammar::me::tcl::iok_fail"}
+
+
+test mevmtcl-iok_fail-2.0 {Regular behaviour} \
+ -setup {
+ grammar::me::tcl::init fake
+ grammar::me::tcl::iok_ok
+ } -body {
+ grammar::me::tcl::iok_fail
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 0
+error {}
+sv___ {}
+ast__ {}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-iok_negate-1.0 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::iok_negate a
+ } -result {wrong # args: should be "grammar::me::tcl::iok_negate"}
+
+
+test mevmtcl-iok_negate-2.0 {Regular behaviour} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::iok_negate
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 1
+error {}
+sv___ {}
+ast__ {}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+test mevmtcl-iok_negate-2.1 {Regular behaviour} \
+ -setup {
+ grammar::me::tcl::init fake
+ grammar::me::tcl::iok_ok
+ } -body {
+ grammar::me::tcl::iok_negate
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 0
+error {}
+sv___ {}
+ast__ {}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-icl_get-1.0 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::icl_get a
+ } -result {wrong # args: should be "grammar::me::tcl::icl_get"}
+
+
+test mevmtcl-icl_get-2.0 {Get current location} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::icl_get
+ } -result -1
+
+test mevmtcl-icl_get-2.1 {Get current location after advancing} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::icl_get
+ } -result 2
+
+test mevmtcl-icl_get-2.2 {Get current location after advance & rewind} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::icl_rewind 1
+ } -body {
+ grammar::me::tcl::icl_get
+ } -result 1
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-icl_rewind-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::icl_rewind
+ } -result {wrong # args: should be "grammar::me::tcl::icl_rewind oldloc"}
+
+test mevmtcl-icl_rewind-1.1 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::icl_rewind a b
+ } -result {wrong # args: should be "grammar::me::tcl::icl_rewind oldloc"}
+
+
+test mevmtcl-icl_rewind-2.0 {Rewind travels back} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::icl_rewind 1
+ grammar::me::tcl::icl_get
+ } -result 1
+
+test mevmtcl-icl_rewind-2.1 {Rewind is not sanity checked} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::icl_rewind -4
+ grammar::me::tcl::icl_get
+ } -result -4
+
+test mevmtcl-icl_rewind-2.2 {Rewind is not sanity checked} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::icl_rewind 50
+ grammar::me::tcl::icl_get
+ } -result 50
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-ier_get-1.0 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ier_get a
+ } -result {wrong # args: should be "grammar::me::tcl::ier_get"}
+
+
+test mevmtcl-ier_get-2.0 {Get current error} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ier_get
+ } -result {}
+
+test mevmtcl-ier_get-2.1 {Get current error} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_match_token BOGUS 'BOGUS'
+ } -body {
+ grammar::me::tcl::ier_get
+ } -result {0 'BOGUS'}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-ier_clear-1.0 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ier_clear a
+ } -result {wrong # args: should be "grammar::me::tcl::ier_clear"}
+
+
+test mevmtcl-ier_clear-2.0 {Clear error, no preceding error} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ier_clear
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 0
+error {}
+sv___ {}
+ast__ {}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+test mevmtcl-ier_clear-2.1 {Clear error} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_match_token BOGUS 'BOGUS'
+ } -body {
+ grammar::me::tcl::ier_clear
+ ME_stateText
+ } -result {tok__ T1
+loc__ -1
+ok___ 0
+error {}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-ier_nonterminal-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ier_nonterminal
+ } -result {wrong # args: should be "grammar::me::tcl::ier_nonterminal msg pos"}
+
+test mevmtcl-ier_nonterminal-1.1 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ier_nonterminal a b c
+ } -result {wrong # args: should be "grammar::me::tcl::ier_nonterminal msg pos"}
+
+
+test mevmtcl-ier_nonterminal-2.0 {No-op if there is no error} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ier_nonterminal A 4
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 0
+error {}
+sv___ {}
+ast__ {}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+test mevmtcl-ier_nonterminal-2.1 {No-op for non-matching locations} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_match_token BOGUS 'BOGUS'
+ } -body {
+ grammar::me::tcl::ier_nonterminal A 4
+ ME_stateText
+ } -result {tok__ T1
+loc__ -1
+ok___ 0
+error {0 'BOGUS'}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {}}
+
+test mevmtcl-ier_nonterminal-2.2 {Replace error for matching locations} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_match_token BOGUS 'BOGUS'
+ } -body {
+ grammar::me::tcl::ier_nonterminal A -1
+ ME_stateText
+ } -result {tok__ T1
+loc__ -1
+ok___ 0
+error {0 A}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-ier_merge-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ier_merge
+ } -result {wrong # args: should be "grammar::me::tcl::ier_merge new"}
+
+test mevmtcl-ier_merge-1.1 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ier_merge a b
+ } -result {wrong # args: should be "grammar::me::tcl::ier_merge new"}
+
+
+test mevmtcl-ier_merge-2.0 {Both errors empty} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ier_merge {}
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 0
+error {}
+sv___ {}
+ast__ {}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+test mevmtcl-ier_merge-2.1 {Stored error empty, argument not} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ier_merge {3 {A dot bar}}
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 0
+error {3 {A dot bar}}
+sv___ {}
+ast__ {}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+test mevmtcl-ier_merge-2.2 {Stored error non-empty, argument is} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_match_token BOGUS 'BOGUS'
+ } -body {
+ grammar::me::tcl::ier_merge {}
+ ME_stateText
+ } -result {tok__ T1
+loc__ -1
+ok___ 0
+error {0 'BOGUS'}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1}}
+cache {}
+next_ next_count
+ord__ {}}
+
+test mevmtcl-ier_merge-2.3 {Both errors non-empty, stored further} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_match_token BOGUS 'BOGUS'
+ } -body {
+ grammar::me::tcl::ier_merge {0 {A C}}
+ ME_stateText
+ } -result {tok__ T3
+loc__ 1
+ok___ 0
+error {2 'BOGUS'}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1} {T2 1 2 2} {T3 1 3 3}}
+cache {}
+next_ next_count
+ord__ {}}
+
+test mevmtcl-ier_merge-2.4 {Both errors non-empty, argument further} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_match_token BOGUS 'BOGUS'
+ } -body {
+ grammar::me::tcl::ier_merge {4 {A C}}
+ ME_stateText
+ } -result {tok__ T3
+loc__ 1
+ok___ 0
+error {4 {A C}}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1} {T2 1 2 2} {T3 1 3 3}}
+cache {}
+next_ next_count
+ord__ {}}
+
+test mevmtcl-ier_merge-2.5 {Both errors non-empty, same location} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_match_token BOGUS 'BOGUS'
+ } -body {
+ grammar::me::tcl::ier_merge {2 {A C}}
+ ME_stateText
+ } -result {tok__ T3
+loc__ 1
+ok___ 0
+error {2 {'BOGUS' A C}}
+sv___ {}
+ast__ {}
+input {{T1 1 1 1} {T2 1 2 2} {T3 1 3 3}}
+cache {}
+next_ next_count
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-isv_clear-1.0 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::isv_clear a
+ } -result {wrong # args: should be "grammar::me::tcl::isv_clear"}
+
+
+test mevmtcl-isv_clear-2.0 {Clear sv, was already clear} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::isv_clear
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 0
+error {}
+sv___ {}
+ast__ {}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+test mevmtcl-isv_clear-2.1 {Clear sv, after creating something} \
+ -setup {
+ grammar::me::tcl::init fake
+ grammar::me::tcl::isv_terminal
+ } -body {
+ grammar::me::tcl::isv_clear
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 0
+error {}
+sv___ {}
+ast__ {{{} -1 -1}}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-isv_terminal-1.0 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::isv_terminal a
+ } -result {wrong # args: should be "grammar::me::tcl::isv_terminal"}
+
+
+test mevmtcl-isv_terminal-2.0 {Create terminal sv & push} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::isv_terminal
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 0
+error {}
+sv___ {{} -1 -1}
+ast__ {{{} -1 -1}}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+test mevmtcl-isv_terminal-2.1 {Create terminal sv & push, after advancing} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::ict_advance foo
+ } -body {
+ grammar::me::tcl::isv_terminal
+ ME_stateText
+ } -result {tok__ T3
+loc__ 2
+ok___ 1
+error {}
+sv___ {{} 2 2}
+ast__ {{{} 2 2}}
+input {{T1 1 1 1} {T2 1 2 2} {T3 1 3 3}}
+cache {}
+next_ next_count
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-isv_nonterminal_leaf-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::isv_nonterminal_leaf
+ } -result {wrong # args: should be "grammar::me::tcl::isv_nonterminal_leaf nt pos"}
+
+test mevmtcl-isv_nonterminal_leaf-1.1 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::isv_nonterminal_leaf a b c
+ } -result {wrong # args: should be "grammar::me::tcl::isv_nonterminal_leaf nt pos"}
+
+
+test mevmtcl-isv_nonterminal_leaf-2.0 {No-op if not ok} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::isv_nonterminal_leaf A -3
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 0
+error {}
+sv___ {}
+ast__ {}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+test mevmtcl-isv_nonterminal_leaf-2.1 {Generate sv} \
+ -setup {
+ grammar::me::tcl::init fake
+ grammar::me::tcl::iok_ok
+ } -body {
+ grammar::me::tcl::isv_nonterminal_leaf A -3
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 1
+error {}
+sv___ {A -2 -1}
+ast__ {}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-isv_nonterminal_range-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::isv_nonterminal_range
+ } -result {wrong # args: should be "grammar::me::tcl::isv_nonterminal_range nt pos"}
+
+test mevmtcl-isv_nonterminal_range-1.1 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::isv_nonterminal_range a b c
+ } -result {wrong # args: should be "grammar::me::tcl::isv_nonterminal_range nt pos"}
+
+
+test mevmtcl-isv_nonterminal_range-2.0 {No-op if not ok} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::isv_nonterminal_range A -3
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 0
+error {}
+sv___ {}
+ast__ {}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+test mevmtcl-isv_nonterminal_range-2.1 {Generate sv} \
+ -setup {
+ grammar::me::tcl::init fake
+ grammar::me::tcl::iok_ok
+ } -body {
+ grammar::me::tcl::isv_nonterminal_range A -3
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 1
+error {}
+sv___ {A -2 -1 {{} -2 -1}}
+ast__ {}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-isv_nonterminal_reduce-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::isv_nonterminal_reduce
+ } -result {wrong # args: should be "grammar::me::tcl::isv_nonterminal_reduce nt pos ?mrk?"}
+
+test mevmtcl-isv_nonterminal_reduce-1.1 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::isv_nonterminal_reduce a b c d
+ } -result {wrong # args: should be "grammar::me::tcl::isv_nonterminal_reduce nt pos ?mrk?"}
+
+
+test mevmtcl-isv_nonterminal_reduce-2.0 {No-op if not ok} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::isv_nonterminal_reduce A -3
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 0
+error {}
+sv___ {}
+ast__ {}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+test mevmtcl-isv_nonterminal_reduce-2.1 {Generate sv, reduce all} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::isv_terminal
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::isv_terminal
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::isv_terminal
+ } -body {
+ grammar::me::tcl::isv_nonterminal_reduce A -1
+ ME_stateText
+ } -result {tok__ T3
+loc__ 2
+ok___ 1
+error {}
+sv___ {A 0 2 {{} 0 0} {{} 1 1} {{} 2 2}}
+ast__ {{{} 0 0} {{} 1 1} {{} 2 2}}
+input {{T1 1 1 1} {T2 1 2 2} {T3 1 3 3}}
+cache {}
+next_ next_count
+ord__ {}}
+
+test mevmtcl-isv_nonterminal_reduce-2.2 {Generate sv, reduce partial} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::isv_terminal
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::isv_terminal
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::isv_terminal
+ } -body {
+ grammar::me::tcl::isv_nonterminal_reduce A 0 1
+ ME_stateText
+ } -result {tok__ T3
+loc__ 2
+ok___ 1
+error {}
+sv___ {A 1 2 {{} 1 1} {{} 2 2}}
+ast__ {{{} 0 0} {{} 1 1} {{} 2 2}}
+input {{T1 1 1 1} {T2 1 2 2} {T3 1 3 3}}
+cache {}
+next_ next_count
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-ias_push-1.0 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ias_push a
+ } -result {wrong # args: should be "grammar::me::tcl::ias_push"}
+
+
+test mevmtcl-ias_push-2.0 {Push sv to ast stack} \
+ -setup {
+ grammar::me::tcl::init fake
+ grammar::me::tcl::iok_ok
+ grammar::me::tcl::isv_nonterminal_leaf A -3
+ } -body {
+ grammar::me::tcl::ias_push
+ ME_stateText
+ } -result {tok__ {}
+loc__ -1
+ok___ 1
+error {}
+sv___ {A -2 -1}
+ast__ {{A -2 -1}}
+input {}
+cache {}
+next_ fake
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-ias_mark-1.0 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ias_mark a
+ } -result {wrong # args: should be "grammar::me::tcl::ias_mark"}
+
+
+test mevmtcl-ias_mark-2.0 {Get ast stack size} \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ias_mark
+ } -result 0
+
+test mevmtcl-ias_mark-2.1 {Get ast stack size} \
+ -setup {
+ grammar::me::tcl::init fake
+ grammar::me::tcl::iok_ok
+ grammar::me::tcl::isv_nonterminal_leaf A -3
+ grammar::me::tcl::ias_push
+ } -body {
+ grammar::me::tcl::ias_mark
+ } -result 1
+
+
+# ### ### ### ######### ######### #########
+##
+
+test mevmtcl-ias_pop2mark-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ias_pop2mark
+ } -result {wrong # args: should be "grammar::me::tcl::ias_pop2mark mark"}
+
+test mevmtcl-ias_pop2mark-1.1 {Call with too many arguments} \
+ -returnCodes error \
+ -setup {
+ grammar::me::tcl::init fake
+ } -body {
+ grammar::me::tcl::ias_pop2mark a b
+ } -result {wrong # args: should be "grammar::me::tcl::ias_pop2mark mark"}
+
+
+test mevmtcl-ias_pop2mark-2.0 {No-op if stack smaller than mark} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::isv_terminal
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::isv_terminal
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::isv_terminal
+ } -body {
+ grammar::me::tcl::ias_pop2mark 5
+ ME_stateText
+ } -result {tok__ T3
+loc__ 2
+ok___ 1
+error {}
+sv___ {{} 2 2}
+ast__ {{{} 0 0} {{} 1 1} {{} 2 2}}
+input {{T1 1 1 1} {T2 1 2 2} {T3 1 3 3}}
+cache {}
+next_ next_count
+ord__ {}}
+
+test mevmtcl-ias_pop2mark-2.1 {Reduce to chosen size} \
+ -setup {
+ grammar::me::tcl::init next_count
+ nc_init
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::isv_terminal
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::isv_terminal
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::isv_terminal
+ grammar::me::tcl::ict_advance foo
+ grammar::me::tcl::isv_terminal
+ } -body {
+ grammar::me::tcl::ias_pop2mark 2
+ ME_stateText
+ } -result {tok__ T4
+loc__ 3
+ok___ 1
+error {}
+sv___ {{} 3 3}
+ast__ {{{} 0 0} {{} 1 1}}
+input {{T1 1 1 1} {T2 1 2 2} {T3 1 3 3} {T4 1 4 4}}
+cache {}
+next_ next_count
+ord__ {}}
+
+
+# ### ### ### ######### ######### #########
+## Cleanup and statistics.
+
+rename ME_state {}
+testsuiteCleanup
diff --git a/tcllib/modules/grammar_me/me_util.man b/tcllib/modules/grammar_me/me_util.man
new file mode 100644
index 0000000..f8f660e
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_util.man
@@ -0,0 +1,83 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin grammar::me::util n 0.1]
+[keywords {abstract syntax tree}]
+[keywords {syntax tree}]
+[keywords tree]
+[copyright {2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Grammar operations and usage}]
+[titledesc {AST utilities}]
+[category {Grammars and finite automata}]
+[require Tcl 8.4]
+[require grammar::me::util [opt 0.1]]
+[description]
+[para]
+
+This package provides a number of utility command for the conversion
+between the various representations of abstract syntax trees as
+specified in the document [syscmd grammar::me_ast].
+
+[list_begin definitions]
+
+[call [cmd ::grammar::me::util::ast2tree] [arg ast] [arg tree] [opt [arg root]]]
+
+This command converts an [arg ast] from value to object
+representation. All nodes in the [arg ast] will be converted into
+nodes of this [arg tree], with the root of the AST a child of the node
+[arg root]. If this node is not explicitly specified the root of the
+tree is used. Existing content of tree is not touched, i.e. neither
+removed nor changed, with the exception of the specified root node,
+which will gain a new child.
+
+[call [cmd ::grammar::me::util::ast2etree] [arg ast] [arg mcmd] [arg tree] [opt [arg root]]]
+
+This command is like [cmd ::grammar::me::util::ast2tree], except that
+the result is in the extended object representation of the input AST.
+
+The source of the extended information is the command prefix
+
+[arg mcmd].
+
+It has to understand two methods, [method lc], and [method tok], with
+the semantics specified below.
+
+[list_begin definitions]
+
+[call [cmd mcmd] [method lc] [arg location]]
+
+Takes the location of a token given as offset in the input stream and
+return a 2-element list containing the associated line number and
+column index, in this order.
+
+[call [cmd mcmd] [method tok] [arg from] [opt [arg to]]]
+
+Takes one or two locations [arg from] and [arg to] as offset in the
+input stream and returns a Tcl list containing the specified part of
+the input stream. Both location are inclusive. If [arg to] is not
+specified it will default to the value of [arg from].
+
+[para]
+
+Each element of the returned list is a list containing the token, its
+associated lexeme, the line number, and column index, in this order.
+
+[list_end]
+[para]
+
+Both the ensemble command [cmd ::grammar::me::tcl] provided by the
+package [package grammar::me::tcl] and the objects command created by
+the package [package ::grammar::me::cpu] fit the above specification.
+
+[call [cmd ::grammar::me::util::tree2ast] [arg tree] [opt [arg root]]]
+
+This command converts an [arg ast] in (extended) object representation
+into a value and returns it.
+
+If a [arg root] node is specified the AST is generated from that node
+downward. Otherwise the root of the tree object is used as the
+starting point.
+
+[list_end]
+
+[vset CATEGORY grammar_me]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/grammar_me/me_util.tcl b/tcllib/modules/grammar_me/me_util.tcl
new file mode 100644
index 0000000..625e894
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_util.tcl
@@ -0,0 +1,188 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Package description
+
+## Utility commands for the conversion between various representations
+## of abstract syntax trees.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+namespace eval ::grammar::me::util {
+ namespace export ast2tree ast2etree tree2ast
+}
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+# ### ### ### ######### ######### #########
+## API Implementation.
+
+proc ::grammar::me::util::ast2tree {ast tree {root {}}} {
+ # See grammar::me_ast for the specification of both value and tree
+ # representations.
+
+ if {$root eq ""} {
+ set root [$tree rootname]
+ }
+
+ # Decompose the AST value into its components.
+
+ if {[llength $ast] < 3} {
+ return -code error "Bad node \"$ast\", not enough elements"
+ }
+
+ set type [lindex $ast 0]
+ set range [lrange $ast 1 2]
+ set children [lrange $ast 3 end]
+
+ if {($type eq "") && [llength $children]} {
+ return -code error \
+ "Terminal node \"[lrange $ast 0 2]\" has children"
+ }
+ foreach {s e} $range break
+ if {
+ ![string is integer -strict $s] || ($s < 0) ||
+ ![string is integer -strict $e] || ($e < 0)
+ } {
+ return -code error "Bad range information \"$range\""
+ }
+
+ # Create a node for the root of the AST and fill it with the data
+ # from the value. Afterward recurse and build the tree for the
+ # children of the root.
+
+ set new [lindex [$tree insert $root end] 0]
+
+ if {$type eq ""} {
+ $tree set $new type terminal
+ } else {
+ $tree set $new type nonterminal
+ $tree set $new detail $type
+ }
+
+ $tree set $new range $range
+
+ foreach child $children {
+ ast2tree $child $tree $new
+ }
+ return
+}
+
+proc ::grammar::me::util::ast2etree {ast mcmd tree {root {}}} {
+ # See grammar::me_ast for the specification of both value and tree
+ # representations.
+
+ if {$root eq ""} {
+ set root [$tree rootname]
+ }
+
+ # Decompose the AST value into its components.
+
+ if {[llength $ast] < 3} {
+ return -code error "Bad node \"$ast\", not enough elements"
+ }
+
+ set type [lindex $ast 0]
+ set range [lrange $ast 1 2]
+ set children [lrange $ast 3 end]
+
+ if {($type eq "") && [llength $children]} {
+ return -code error \
+ "Terminal node \"[lrange $ast 0 2]\" has children"
+ }
+ foreach {s e} $range break
+ if {
+ ![string is integer -strict $s] || ($s < 0) ||
+ ![string is integer -strict $e] || ($e < 0)
+ } {
+ return -code error "Bad range information \"$range\""
+ }
+
+ # Create a node for the root of the AST and fill it with the data
+ # from the value. Afterward recurse and build the tree for the
+ # children of the root.
+
+ set new [lindex [$tree insert $root end] 0]
+
+ if {$type eq ""} {
+ set cmd $mcmd
+ lappend cmd tok
+ foreach loc $range {lappend cmd $loc}
+
+ $tree set $new type terminal
+ $tree set $new detail [uplevel \#0 $cmd]
+ } else {
+ $tree set $new type nonterminal
+ $tree set $new detail $type
+ }
+
+ set range_lc {}
+ foreach loc $range {
+ lappend range_lc [uplevel \#0 \
+ [linsert $mcmd end lc $loc]]
+ }
+
+ $tree set $new range $range
+ $tree set $new range_lc $range_lc
+
+ foreach child $children {
+ ast2etree $child $mcmd $tree $new
+ }
+ return
+}
+
+proc ::grammar::me::util::tree2ast {tree {root {}}} {
+ # See grammar::me_ast for the specification of both value and tree
+ # representations.
+
+ if {$root eq ""} {
+ set root [$tree rootname]
+ }
+
+ set value {}
+
+ if {![$tree keyexists $root type]} {
+ return -code error "Bad node \"$root\", type information is missing"
+ }
+ if {![$tree keyexists $root range]} {
+ return -code error "Bad node \"$root\", range information is missing"
+ }
+
+ set range [$tree get $root range]
+ if {[llength $range] != 2} {
+ return -code error "Bad node \"root\", bad range information \"$range\""
+ }
+
+ foreach {s e} $range break
+ if {
+ ![string is integer -strict $s] || ($s < 0) ||
+ ![string is integer -strict $e] || ($e < 0)
+ } {
+ return -code error "Bad node \"root\", bad range information \"$range\""
+ }
+
+ if {[$tree get $root type] eq "terminal"} {
+ lappend value {}
+ } else {
+ if {![$tree keyexists $root detail]} {
+ return -code error "Bad node \"$root\", nonterminal detail is missing"
+ }
+
+ lappend value [$tree get $root detail]
+ }
+
+ # Range data ...
+ lappend value $s $e
+
+ foreach child [$tree children $root] {
+ lappend value [tree2ast $tree $child]
+ }
+
+ return $value
+}
+
+# ### ### ### ######### ######### #########
+## Package Management
+
+package provide grammar::me::util 0.1
diff --git a/tcllib/modules/grammar_me/me_util.test b/tcllib/modules/grammar_me/me_util.test
new file mode 100644
index 0000000..c49dd73
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_util.test
@@ -0,0 +1,168 @@
+# me_util.test: tests for the AST utilities -*- tcl -*-
+#
+# 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) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: me_util.test,v 1.7 2007/08/01 22:49:26 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.1
+
+support {
+ useAccel [useTcllibC] struct/tree.tcl struct::tree
+ TestAccelInit struct::tree
+}
+testing {
+ useLocal me_util.tcl grammar::me::util
+}
+
+# -------------------------------------------------------------------------
+
+# -------------------------------------------------------------------------
+
+## Pre-requisites. An AST value and various serializations of plain
+## and extended tree representations of the same AST. Plus helper
+## commands for the checking of trees for structural equality.
+
+set ast {a 0 56 {{} 3 15} {b 16 40 {d 16 20} {{} 21 40}} {c 41 56}}
+
+set serial_0 {
+ root {} {}
+ node0 0 {type nonterminal detail a range {0 56}}
+ node1 3 {type terminal range {3 15}}
+ node2 3 {type nonterminal detail b range {16 40}}
+ node3 3 {type nonterminal detail c range {41 56}}
+ node4 9 {type nonterminal detail d range {16 20}}
+ node5 9 {type terminal range {21 40}}
+}
+
+set serial_0a {
+ node0 {} {type nonterminal detail a range {0 56}}
+ node1 0 {type terminal range {3 15}}
+ node2 0 {type nonterminal detail b range {16 40}}
+ node3 0 {type nonterminal detail c range {41 56}}
+ node4 6 {type nonterminal detail d range {16 20}}
+ node5 6 {type terminal range {21 40}}
+}
+
+set serial_1 {
+ root {} {}
+ foo 0 {}
+ node0 3 {type nonterminal detail a range {0 56}}
+ node1 6 {type terminal range {3 15}}
+ node2 6 {type nonterminal detail b range {16 40}}
+ node3 6 {type nonterminal detail c range {41 56}}
+ node4 12 {type nonterminal detail d range {16 20}}
+ node5 12 {type terminal range {21 40}}
+}
+
+set serial_2 {
+ root {} {}
+ node0 0 {type nonterminal detail a range {0 56} range_lc {{l0 c0} {l56 c56}}}
+ node1 3 {type terminal range {3 15} range_lc {{l3 c3} {l15 c15}} detail {{T3 l3 c3 L3} {T4 l4 c4 L4} {T5 l5 c5 L5} {T6 l6 c6 L6} {T7 l7 c7 L7} {T8 l8 c8 L8} {T9 l9 c9 L9} {T10 l10 c10 L10} {T11 l11 c11 L11} {T12 l12 c12 L12} {T13 l13 c13 L13} {T14 l14 c14 L14} {T15 l15 c15 L15}}}
+ node2 3 {type nonterminal detail b range {16 40} range_lc {{l16 c16} {l40 c40}}}
+ node3 3 {type nonterminal detail c range {41 56} range_lc {{l41 c41} {l56 c56}}}
+ node4 9 {type nonterminal detail d range {16 20} range_lc {{l16 c16} {l20 c20}}}
+ node5 9 {type terminal range {21 40} range_lc {{l21 c21} {l40 c40}} detail {{T21 l21 c21 L21} {T22 l22 c22 L22} {T23 l23 c23 L23} {T24 l24 c24 L24} {T25 l25 c25 L25} {T26 l26 c26 L26} {T27 l27 c27 L27} {T28 l28 c28 L28} {T29 l29 c29 L29} {T30 l30 c30 L30} {T31 l31 c31 L31} {T32 l32 c32 L32} {T33 l33 c33 L33} {T34 l34 c34 L34} {T35 l35 c35 L35} {T36 l36 c36 L36} {T37 l37 c37 L37} {T38 l38 c38 L38} {T39 l39 c39 L39} {T40 l40 c40 L40}}}
+}
+
+set serial_2a {
+ node0 {} {type nonterminal detail a range {0 56}}
+ node1 0 {type terminal range {3 15}}
+ node2 0 {type nonterminal detail b range {16 40}}
+ node3 0 {type nonterminal detail c range {41 56}}
+ node4 6 {type nonterminal detail d range {16 20}}
+ node5 6 {type terminal range {21 40}}
+}
+
+set serial_3 {
+ root {} {}
+ foo 0 {}
+ node0 3 {type nonterminal detail a range {0 56} range_lc {{l0 c0} {l56 c56}}}
+ node1 6 {type terminal range {3 15} range_lc {{l3 c3} {l15 c15}} detail {{T3 l3 c3 L3} {T4 l4 c4 L4} {T5 l5 c5 L5} {T6 l6 c6 L6} {T7 l7 c7 L7} {T8 l8 c8 L8} {T9 l9 c9 L9} {T10 l10 c10 L10} {T11 l11 c11 L11} {T12 l12 c12 L12} {T13 l13 c13 L13} {T14 l14 c14 L14} {T15 l15 c15 L15}}}
+ node2 6 {type nonterminal detail b range {16 40} range_lc {{l16 c16} {l40 c40}}}
+ node3 6 {type nonterminal detail c range {41 56} range_lc {{l41 c41} {l56 c56}}}
+ node4 12 {type nonterminal detail d range {16 20} range_lc {{l16 c16} {l20 c20}}}
+ node5 12 {type terminal range {21 40} range_lc {{l21 c21} {l40 c40}} detail {{T21 l21 c21 L21} {T22 l22 c22 L22} {T23 l23 c23 L23} {T24 l24 c24 L24} {T25 l25 c25 L25} {T26 l26 c26 L26} {T27 l27 c27 L27} {T28 l28 c28 L28} {T29 l29 c29 L29} {T30 l30 c30 L30} {T31 l31 c31 L31} {T32 l32 c32 L32} {T33 l33 c33 L33} {T34 l34 c34 L34} {T35 l35 c35 L35} {T36 l36 c36 L36} {T37 l37 c37 L37} {T38 l38 c38 L38} {T39 l39 c39 L39} {T40 l40 c40 L40}}}
+}
+
+proc tree_equal {ta tb} {
+ set tna [llength [$ta nodes]]
+ set tnb [llength [$tb nodes]]
+
+ if {$tna != $tnb} {
+ puts "sizes: $ta n = $tna != $tnb = $tb n"
+ return 0
+ }
+ node_equal $ta $tb [$ta rootname] [$tb rootname]
+}
+
+proc node_equal {ta tb na nb} {
+ if {[dictsort [$ta getall $na]] ne [dictsort [$tb getall $nb]]} {
+ puts "attr delta $ta $na: [dictsort [$ta getall $na]]\n $tb $nb: [dictsort [$tb getall $nb]]"
+ return 0
+ }
+ if {[$ta numchildren $na] != [$tb numchildren $nb]} {
+ puts "#c $na / $nb: [$ta numchildren $na] != [$tb numchildren $nb]"
+ return 0
+ }
+ foreach ca [$ta children $na] cb [$tb children $nb] {
+ if {![node_equal $ta $tb $ca $cb]} {
+ return 0
+ }
+ }
+ return 1
+}
+
+proc tsdump {ser} {
+ set line {}
+ foreach {a b c} $ser {
+ lappend line [list $a $b $c]
+ }
+ return \t[join $line \n\t]
+}
+
+# -------------------------------------------------------------------------
+# In this section we run all the tests depending on a struct::tree,
+# and thus have to test all the available implementations.
+
+set tests [file join [file dirname [info script]] me_util.testsuite]
+
+catch {memory validate on}
+
+TestAccelDo struct::tree impl {
+ # The global variable 'impl' is part of the public API the
+ # testsuit (in htmlparse_tree.testsuite) can expect from the
+ # environment.
+
+ namespace import -force struct::tree
+
+ set usec [time {source $tests} 1]
+
+ #puts "$impl:\t$usec"
+}
+
+catch {memory validate off}
+
+unset usec
+unset tests
+
+# -------------------------------------------------------------------------
+
+## Cleanup and statistics.
+
+rename tree_equal {}
+rename node_equal {}
+rename tsdump {}
+TestAccelExit struct::tree
+testsuiteCleanup
diff --git a/tcllib/modules/grammar_me/me_util.testsuite b/tcllib/modules/grammar_me/me_util.testsuite
new file mode 100644
index 0000000..6423544
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_util.testsuite
@@ -0,0 +1,384 @@
+# -*- tcl -*- me_util.test
+# ### ### ### ######### ######### #########
+## Suite 1: Values to tree objects.
+
+set tname [expr {$impl eq "critcl" ? "t" : "::t"}]
+
+
+test ast2tree-${impl}-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -body {
+ grammar::me::util::ast2tree
+ } -result {wrong # args: should be "grammar::me::util::ast2tree ast tree ?root?"}
+
+test ast2tree-${impl}-1.1 {Call with to many arguments} \
+ -returnCodes error \
+ -body {
+ grammar::me::util::ast2tree a b c d
+ } -result {wrong # args: should be "grammar::me::util::ast2tree ast tree ?root?"}
+
+test ast2tree-${impl}-1.2 {Call with bad tree object} \
+ -returnCodes error \
+ -body {
+ grammar::me::util::ast2tree {a 1 2} foo
+ } -result {invalid command name "foo"}
+
+test ast2tree-${impl}-1.3 {Call with bad node in tree} \
+ -returnCodes error \
+ -setup {
+ struct::tree t
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::ast2tree {a 1 2} t blub
+ } -result "parent node \"blub\" does not exist in tree \"$tname\""
+
+test ast2tree-${impl}-1.4 {Call with bad AST, terminal node with children} \
+ -returnCodes error \
+ -setup {
+ struct::tree t
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::ast2tree {{} 1 2 {a 3 4} {c 5 6}} t
+ } -result {Terminal node "{} 1 2" has children}
+
+foreach {n range} {
+ 0 {0 a}
+ 1 {0 -1}
+ 2 {a 0}
+ 3 {-1 0}
+ 4 {a b}
+ 5 {a -1}
+ 6 {-1 b}
+ 7 {-1 -1}
+} {
+ test ast2tree-${impl}-1.5.$n {Call with bad AST, bad location information} \
+ -returnCodes error \
+ -setup {
+ struct::tree t
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::ast2tree [linsert $range 0 {}] t
+ } -result "Bad range information \"[lrange $range 0 end]\""
+}
+
+foreach {n node} {
+ 0 {}
+ 1 {{}}
+ 2 {{} 0}
+} {
+ test ast2tree-${impl}-1.6.$n {Call with bad AST, node representation too short} \
+ -returnCodes error \
+ -setup {
+ struct::tree t
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::ast2tree $node t
+ } -result "Bad node \"[lrange $node 0 end]\", not enough elements"
+}
+
+
+
+test ast2tree-${impl}-2.0 {Regular conversion} \
+ -setup {
+ struct::tree t
+ struct::tree tex deserialize $serial_0
+ } -cleanup {
+ t destroy
+ tex destroy
+ } -body {
+ grammar::me::util::ast2tree $ast t
+ tree_equal t tex
+ } -result 1
+
+test ast2tree-${impl}-2.1 {Regular conversion under non-root root} \
+ -setup {
+ struct::tree t
+ t insert root end foo
+ struct::tree tex deserialize $serial_1
+ } -cleanup {
+ t destroy
+ tex destroy
+ } -body {
+ grammar::me::util::ast2tree $ast t foo
+ tree_equal t tex
+ } -result 1
+
+# ### ### ### ######### ######### #########
+## Suite 2: Values to extended tree objects
+
+proc tinfo {cmd args} {
+ # 'tinfo lc 0' is a nice check that things work.
+ switch -exact -- $cmd {
+ lc {
+ return [list l[lindex $args 0] c[lindex $args 0]]
+ }
+ tok {
+ foreach {s e} $args break
+ set res {}
+ for {set i $s} {$i <= $e} {incr i} {
+ lappend res [list T$i l$i c$i L$i]
+ }
+ return $res
+ }
+ }
+ return -code error BOGUS
+}
+
+test ast2etree-${impl}-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -body {
+ grammar::me::util::ast2etree
+ } -result {wrong # args: should be "grammar::me::util::ast2etree ast mcmd tree ?root?"}
+
+test ast2etree-${impl}-1.1 {Call with to many arguments} \
+ -returnCodes error \
+ -body {
+ grammar::me::util::ast2etree a b c d e
+ } -result {wrong # args: should be "grammar::me::util::ast2etree ast mcmd tree ?root?"}
+
+test ast2etree-${impl}-1.2 {Call with bad tree object} \
+ -returnCodes error \
+ -body {
+ grammar::me::util::ast2etree {a 1 2} tinfo foo
+ } -result {invalid command name "foo"}
+
+test ast2etree-${impl}-1.3 {Call with bad info callback} \
+ -returnCodes error \
+ -setup {
+ struct::tree t
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::ast2etree {a 1 2} foo t
+ } -result {invalid command name "foo"}
+
+test ast2etree-${impl}-1.4 {Call with bad node in tree} \
+ -returnCodes error \
+ -setup {
+ struct::tree t
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::ast2etree {a 1 2} tinfo t blub
+ } -result "parent node \"blub\" does not exist in tree \"$tname\""
+
+test ast2etree-${impl}-1.6 {Call with bad AST, terminal node with children} \
+ -returnCodes error \
+ -setup {
+ struct::tree t
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::ast2etree {{} 1 2 {a 3 4} {c 5 6}} tinfo t
+ } -result {Terminal node "{} 1 2" has children}
+
+foreach {n range} {
+ 0 {0 a}
+ 1 {0 -1}
+ 2 {a 0}
+ 3 {-1 0}
+ 4 {a b}
+ 5 {a -1}
+ 6 {-1 b}
+ 7 {-1 -1}
+} {
+ test ast2etree-${impl}-1.7.$n {Call with bad AST, bad location information} \
+ -returnCodes error \
+ -setup {
+ struct::tree t
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::ast2etree [linsert $range 0 {}] tinfo t
+ } -result "Bad range information \"[lrange $range 0 end]\""
+}
+
+foreach {n node} {
+ 0 {}
+ 1 {{}}
+ 2 {{} 0}
+} {
+ test ast2tree-${impl}-1.8.$n {Call with bad AST, node representation too short} \
+ -returnCodes error \
+ -setup {
+ struct::tree t
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::ast2etree $node tinfo t
+ } -result "Bad node \"[lrange $node 0 end]\", not enough elements"
+}
+
+
+
+test ast2etree-${impl}-2.0 {Regular conversion} \
+ -setup {
+ struct::tree t
+ struct::tree tex deserialize $serial_2
+ } -cleanup {
+ t destroy
+ tex destroy
+ } -body {
+ grammar::me::util::ast2etree $ast tinfo t
+ tree_equal t tex
+ } -result 1
+
+test ast2etree-${impl}-2.1 {Regular conversion under non-root root} \
+ -setup {
+ struct::tree t
+ t insert root end foo
+ struct::tree tex deserialize $serial_3
+ } -cleanup {
+ t destroy
+ tex destroy
+ } -body {
+ grammar::me::util::ast2etree $ast tinfo t foo
+ tree_equal t tex
+ } -result 1
+
+# ### ### ### ######### ######### #########
+## Suite 3: Tree objects to values.
+
+test tree2ast-1.0 {Call without enough arguments} \
+ -returnCodes error \
+ -body {
+ grammar::me::util::tree2ast
+ } -result {wrong # args: should be "grammar::me::util::tree2ast tree ?root?"}
+
+test tree2ast-1.1 {Call with to many arguments} \
+ -returnCodes error \
+ -body {
+ grammar::me::util::tree2ast a b c
+ } -result {wrong # args: should be "grammar::me::util::tree2ast tree ?root?"}
+
+test tree2ast-1.2 {Call with bad tree object} \
+ -returnCodes error \
+ -body {
+ grammar::me::util::tree2ast foo
+ } -result {invalid command name "foo"}
+
+test tree2ast-1.3 {Call with bad node in tree} \
+ -returnCodes error \
+ -setup {
+ struct::tree t
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::tree2ast t blub
+ } -result "node \"blub\" does not exist in tree \"$tname\""
+
+test tree2ast-1.4 {Call with broken tree, missing type} \
+ -returnCodes error \
+ -setup {
+ struct::tree t deserialize {root {} {range {0 2} detail x}}
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::tree2ast t
+ } -result {Bad node "root", type information is missing}
+
+test tree2ast-1.5.0 {Call with broken tree, missing range, nonterminal} \
+ -returnCodes error \
+ -setup {
+ struct::tree t deserialize {root {} {type nonterminal detail x}}
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::tree2ast t
+ } -result {Bad node "root", range information is missing}
+
+test tree2ast-1.5.1 {Call with broken tree, missing range, terminal} \
+ -returnCodes error \
+ -setup {
+ struct::tree t deserialize {root {} {type terminal}}
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::tree2ast t
+ } -result {Bad node "root", range information is missing}
+
+test tree2ast-1.6 {Call with broken tree, missing detail} \
+ -returnCodes error \
+ -setup {
+ struct::tree t deserialize {root {} {type nonterminal range {0 2}}}
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::tree2ast t
+ } -result {Bad node "root", nonterminal detail is missing}
+
+foreach {n range} {
+ 0 {0 a}
+ 1 {0 -1}
+ 2 {a 0}
+ 3 {-1 0}
+ 4 {a b}
+ 5 {a -1}
+ 6 {-1 b}
+ 7 {-1 -1}
+ 8 {}
+ 9 {1}
+ 10 {1 2 3}
+} {
+ test tree2ast-1.7.$n {Call with broken tree, bad location, terminal} \
+ -returnCodes error \
+ -setup {
+ struct::tree t deserialize [list root {} [list type terminal range $range]]
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::tree2ast t
+ } -result "Bad node \"root\", bad range information \"$range\""
+
+ test tree2ast-1.8.$n {Call with broken tree, bad location, nonterminal} \
+ -returnCodes error \
+ -setup {
+ struct::tree t deserialize [list root {} [list type nonterminal detail x range $range]]
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::tree2ast t
+ } -result "Bad node \"root\", bad range information \"$range\""
+}
+
+
+
+test tree2ast-2.0 {Regular conversion} \
+ -setup {
+ struct::tree t deserialize $serial_0a
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::tree2ast t
+ } -result $ast
+
+test tree2ast-2.1 {Regular conversion under non-root root} \
+ -setup {
+ struct::tree t deserialize $serial_1
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::tree2ast t node0
+ } -result $ast
+
+test tree2ast-2.2 {Regular conversion, of extended tree} \
+ -setup {
+ struct::tree t deserialize $serial_2a
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::tree2ast t
+ } -result $ast
+
+test tree2ast-2.3 {Regular conversion under non-root root} \
+ -setup {
+ struct::tree t deserialize $serial_3
+ } -cleanup {
+ t destroy
+ } -body {
+ grammar::me::util::tree2ast t node0
+ } -result $ast
diff --git a/tcllib/modules/grammar_me/me_vm.man b/tcllib/modules/grammar_me/me_vm.man
new file mode 100644
index 0000000..b5bd36e
--- /dev/null
+++ b/tcllib/modules/grammar_me/me_vm.man
@@ -0,0 +1,663 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin grammar::me_vm n 0.1]
+[keywords grammar]
+[keywords parsing]
+[keywords {virtual machine}]
+[copyright {2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Grammar operations and usage}]
+[titledesc {Virtual machine for parsing token streams}]
+[category {Grammars and finite automata}]
+[description]
+
+Please go and read the document [syscmd grammar::me_intro] first for
+an overview of the various documents and their relations.
+
+[para]
+
+This document specifies a virtual machine for the controlled matching
+and parsing of token streams, creating an
+
+[term {abstract syntax tree}] (short [term AST]) reflecting the
+structure of the input. Special machine features are the caching and
+reuse of partial results, caching of the encountered input, and the
+ability to backtrack in both input and AST creation.
+
+[para]
+
+These features make the specified virtual machine especially useful to
+packrat parsers based on parsing expression grammars. It is however
+not restricted to this type of parser. Normal LL and LR parsers can be
+implemented with it as well.
+
+[para]
+
+The following sections will discuss first the abstract state kept by
+ME virtual machines, and then their instruction set.
+
+[section {MACHINE STATE}]
+
+A ME virtual machine manages the following state:
+
+[list_begin definitions]
+[def "[term {Current token}] CT"]
+
+The token from the input under consideration by the machine.
+
+[para]
+
+This information is used and modified by the instructions defined in
+the section
+
+[sectref {TERMINAL MATCHING}].
+
+[def "[term {Current location}] CL"]
+
+The location of the [term {current token}] in the input stream, as
+offset relative to the beginning of the stream. The first token is
+considered to be at offset [const 0].
+
+[para]
+
+This information is implicitly used and modified by the instructions
+defined in the sections
+
+[sectref {TERMINAL MATCHING}] and
+[sectref {NONTERMINAL MATCHING}],
+
+and can be directly queried and modified by the instructions defined
+in section
+
+[sectref {INPUT LOCATION HANDLING}].
+
+[def "[term {Location stack}] LS"]
+
+In addition to the above a stack of locations, for backtracking.
+Locations can put on the stack, removed from it, and removed with
+setting the current location.
+
+[para]
+
+This information is implicitly used and modified by the instructions
+defined in the sections
+
+[sectref {TERMINAL MATCHING}] and
+[sectref {NONTERMINAL MATCHING}],
+
+and can be directly queried and modified by the instructions defined
+in section
+
+[sectref {INPUT LOCATION HANDLING}].
+
+[def "[term {Match status}] OK"]
+
+A boolean value, the result of the last attempt at matching input.
+It is set to [const true] if that attempt was successful, and
+[const false] otherwise.
+
+[para]
+
+This information is influenced by the instructions defined in the
+sections
+
+[sectref {TERMINAL MATCHING}],
+[sectref {NONTERMINAL MATCHING}], and
+[sectref {UNCONDITIONAL MATCHING}].
+
+It is queried by the instructions defined in the section
+
+[sectref {CONTROL FLOW}].
+
+[def "[term {Semantic value}] SV"]
+
+The semantic value associated with (generated by) the last attempt at
+matching input. Contains either the empty string or a node for the
+abstract syntax tree constructed from the input.
+
+[para]
+
+This information is influenced by the instructions defined in the
+sections
+
+[sectref {SEMANTIC VALUES}], and
+[sectref {AST STACK HANDLING}].
+
+[def "[term {AST stack}] AS"]
+
+A stack of partial abstract syntax trees constructed by the machine
+during matching.
+
+[para]
+
+This information is influenced by the instructions defined in the
+sections
+
+[sectref {SEMANTIC VALUES}], and
+[sectref {AST STACK HANDLING}].
+
+[def "[term {AST Marker stack}] MS"]
+
+In addition to the above a stack of stacks, for backtracking. This is
+actually a stack of markers into the AST stack, thus implicitly
+snapshooting the state of the AST stack at some point in time. Markers
+can be put on the stack, dropped from it, and used to roll back the
+AST stack to an earlier state.
+
+[para]
+
+This information is influenced by the instructions defined in the
+sections
+
+[sectref {SEMANTIC VALUES}], and
+[sectref {AST STACK HANDLING}].
+
+[def "[term {Error status}] ER"]
+
+Error information associated with the last attempt at matching
+input. Contains either the empty string or a list of 2 elements, a
+location in the input and a list of error messages associated with
+it, in this order.
+
+[para]
+
+[emph Note] that error information can be set even if the last attempt
+at matching input was successful. For example the *-operator (matching
+a sub-expression zero or more times) in a parsing expression grammar
+is always successful, even if it encounters a problem further in the
+input and has to backtrack. Such problems must not be forgotten when
+continuing to match.
+
+[para]
+
+This information is queried and influenced by the instructions defined
+in the sections
+
+[sectref {TERMINAL MATCHING}],
+[sectref {NONTERMINAL MATCHING}], and
+[sectref {ERROR HANDLING}].
+
+[def "[term {Error stack}] ES"]
+
+In addition to the above a stack of error information, to allow the
+merging of current and older error information when performing
+backtracking in choices after an unsucessful match.
+
+[para]
+
+This information is queried and influenced by the instructions defined
+in the sections
+
+[sectref {TERMINAL MATCHING}],
+[sectref {NONTERMINAL MATCHING}], and
+[sectref {ERROR HANDLING}].
+
+[def "[term {Return stack}] RS"]
+
+A stack of program counter values, i.e. locations in the code
+controlling the virtual machine, for the management of subroutine
+calls, i.e. the matching of nonterminal symbols.
+
+[para]
+
+This information is queried and influenced by the instructions defined
+in the section
+
+[sectref {NONTERMINAL MATCHING}].
+
+[def "[term {Nonterminal cache}] NC"]
+
+A cache of machine states (A 4-tuple containing a location in the
+input, match status [term OK], semantic value [term SV], and error
+status [term ER]) keyed by name of nonterminal symbol and location in
+the input stream.
+
+[para]
+
+The key location is where machine started the attempt to match the
+named nonterminal symbol, and the location in the value is where
+machine ended up after the attempt completed, independent of the
+success of the attempt.
+
+[para]
+
+This status is queried and influenced by the instructions defined in
+the section
+
+[sectref {NONTERMINAL MATCHING}].
+
+[list_end]
+
+[section {MACHINE INSTRUCTIONS}]
+
+With the machine state specified it is now possible to explain the
+instruction set of ME virtual machines. They are grouped roughly by
+the machine state they influence and/or query.
+
+[subsection {TERMINAL MATCHING}]
+
+First the instructions to match tokens from the input stream, and
+by extension all terminal symbols.
+
+[para]
+
+These instructions are the only ones which may retrieve a new token
+from the input stream. This is a [emph may] and not a [emph will]
+because the instructions will a retrieve new token if, and only if the
+current location [term CL] is at the head of the stream.
+
+If the machine has backtracked (see [cmd icl_rewind]) the instructions
+will retrieve the token to compare against from the internal cache.
+
+[para]
+[list_begin definitions]
+
+[def "[cmd ict_advance] [arg message]"]
+
+This instruction tries to advance to the next token in the input
+stream, i.e. the one after the current location [term CL]. The
+instruction will fail if, and only if the end of the input stream is
+reached, i.e. if there is no next token.
+
+[para]
+
+The sucess/failure of the instruction is remembered in the match
+status [term OK]. In the case of failure the error status [term ER] is
+set to the current location and the message [arg message].
+
+In the case of success the error status [term ER] is cleared, the new
+token is made the current token [term CT], and the new location is
+made the current location [term CL].
+
+[para]
+
+The argument [arg message] is a reference to the string to put into
+the error status [term ER], if such is needed.
+
+[def "[cmd ict_match_token] [arg tok] [arg message]"]
+
+This instruction tests the current token [term CT] for equality
+with the argument [arg tok] and records the result in the match
+status [term OK]. The instruction fails if the current token is
+not equal to [arg tok].
+
+[para]
+
+In case of failure the error status [term ER] is set to the current
+location [term CL] and the message [arg message], and the
+current location [term CL] is moved one token backwards.
+
+Otherwise, i.e. upon success, the error status [term ER] is cleared
+and the current location [term CL] is not touched.
+
+[def "[cmd ict_match_tokrange] [arg tokbegin] [arg tokend] [arg message]"]
+
+This instruction tests the current token [term CT] for being in
+the range of tokens from [arg tokbegin] to [arg tokend]
+(inclusive) and records the result in the match status [term OK]. The
+instruction fails if the current token is not inside the range.
+
+[para]
+
+In case of failure the error status [term ER] is set to the current
+location [term CL] and the message [arg message], and the current location
+[term CL] is moved one token backwards.
+
+Otherwise, i.e. upon success, the error status [term ER] is cleared
+and the current location [term CL] is not touched.
+
+[def "[cmd ict_match_tokclass] [arg code] [arg message]"]
+
+This instruction tests the current token [term CT] for being a member
+of the token class [arg code] and records the result in the match
+status [term OK]. The instruction fails if the current token is not a
+member of the specified class.
+
+[para]
+
+In case of failure the error status [term ER] is set to the current
+location [term CL] and the message [arg message], and the
+current location [term CL] is moved one token backwards.
+
+Otherwise, i.e. upon success, the error status [term ER] is cleared
+and the current location [term CL] is not touched.
+
+[para]
+
+Currently the following classes are legal:
+
+[list_begin definitions]
+[def alnum]
+A token is accepted if it is a unicode alphabetical character, or a digit.
+[def alpha]
+A token is accepted if it is a unicode alphabetical character.
+[def digit]
+A token is accepted if it is a unicode digit character.
+[def xdigit]
+A token is accepted if it is a hexadecimal digit character.
+[def punct]
+A token is accepted if it is a unicode punctuation character.
+[def space]
+A token is accepted if it is a unicode space character.
+[list_end]
+
+[list_end]
+[para]
+
+[subsection {NONTERMINAL MATCHING}]
+
+The instructions in this section handle the matching of nonterminal
+symbols. They query the nonterminal cache [term NC] for saved
+information, and put such information into the cache.
+
+[para]
+
+The usage of the cache is a performance aid for backtracking parsers,
+allowing them to avoid an expensive rematch of complex nonterminal
+symbols if they have been encountered before.
+
+[para]
+
+[list_begin definitions]
+
+[def "[cmd inc_restore] [arg branchlabel] [arg nt]"]
+
+This instruction checks if the nonterminal cache [term NC] contains
+information about the nonterminal symbol [arg nt], at the current
+location [term CL]. If that is the case the instruction will update
+the machine state (current location [term CL], match status [term OK],
+semantic value [term SV], and error status [term ER]) with the found
+information and continue execution at the instruction refered to by
+the [arg branchlabel]. The new current location [term CL] will be the
+last token matched by the nonterminal symbol, i.e. belonging to it.
+
+[para]
+
+If no information was found the instruction will continue execution at
+the next instruction.
+
+[para]
+
+Together with [cmd icf_ntcall] it is possible to generate code for
+memoized and non-memoized matching of nonterminal symbols, either as
+subroutine calls, or inlined in the caller.
+
+[def "[cmd inc_save] [arg nt]"]
+
+This instruction saves the current state of the machine (current
+location [term CL], match status [term OK], semantic value [term SV],
+and error status [term ER]), to the nonterminal cache [term NC]. It
+will also pop an entry from the location stack [term LS] and save it
+as the start location of the match.
+
+[para]
+
+It is expected to be called at the end of matching a nonterminal
+symbol, with [arg nt] the name of the nonterminal symbol the code was
+working on. This allows the instruction [cmd inc_restore] to check for
+and retrieve the data, should we have to match this nonterminal symbol
+at the same location again, during backtracking.
+
+[def "[cmd icf_ntcall] [arg branchlabel]"]
+
+This instruction invokes the code for matching the nonterminal symbol
+[arg nt] as a subroutine. To this end it stores the current program
+counter [term PC] on the return stack [term RS], the current location
+[term CL] on the location stack [term LS], and then continues
+execution at the address [arg branchlabel].
+
+[para]
+
+The next matching [cmd icf_ntreturn] will cause the execution to
+continue at the instruction coming after the call.
+
+[def [cmd icf_ntreturn]]
+
+This instruction will pop an entry from the return stack [term RS],
+assign it to the program counter [term PC], and then continue
+execution at the new address.
+
+[list_end]
+[para]
+
+[subsection {UNCONDITIONAL MATCHING}]
+
+The instructions in this section are the remaining match
+operators. They change the match status [term OK] directly and
+unconditionally.
+
+[list_begin definitions]
+
+[def [cmd iok_ok]]
+
+This instruction sets the match status [term OK] to [const true],
+indicating a successful match.
+
+[def [cmd iok_fail]]
+
+This instruction sets the match status [term OK] to [const false],
+indicating a failed match.
+
+[def [cmd iok_negate]]
+
+This instruction negates the match status [term OK], turning a failure
+into a success and vice versa.
+
+[list_end]
+[para]
+
+[subsection {CONTROL FLOW}]
+
+The instructions in this section implement both conditional and
+unconditional control flow. The conditional jumps query the match
+status [term OK].
+
+[list_begin definitions]
+
+[def "[cmd icf_jalways] [arg branchlabel]"]
+
+This instruction sets the program counter [term PC] to the address
+specified by [arg branchlabel] and then continues execution from
+there. This is an unconditional jump.
+
+[def "[cmd icf_jok] [arg branchlabel]"]
+
+This instruction sets the program counter [term PC] to the address
+specified by [arg branchlabel]. This happens if, and only if the match
+status [term OK] indicates a success. Otherwise it simply continues
+execution at the next instruction. This is a conditional jump.
+
+[def "[cmd icf_jfail] [arg branchlabel]"]
+
+This instruction sets the program counter [term PC] to the address
+specified by [arg branchlabel]. This happens if, and only if the match
+status [term OK] indicates a failure. Otherwise it simply continues
+execution at the next instruction. This is a conditional jump.
+
+[def [cmd icf_halt]]
+
+This instruction halts the machine and blocks any further execution.
+
+[list_end]
+
+[subsection {INPUT LOCATION HANDLING}]
+
+The instructions in this section are for backtracking, they manipulate
+the current location [term CL] of the machine state.
+
+They allow a user of the machine to query and save locations in the
+input, and to rewind the current location [term CL] to saved
+locations, making them one of the components enabling the
+implementation of backtracking parsers.
+
+[list_begin definitions]
+
+[def [cmd icl_push]]
+
+This instruction pushes a copy of the current location [term CL] on
+the location stack [term LS].
+
+[def [cmd icl_rewind]]
+
+This instruction pops an entry from the location stack [term LS] and
+then moves the current location [term CL] back to this point in the
+input.
+
+[def [cmd icl_pop]]
+
+This instruction pops an entry from the location stack [term LS] and
+discards it.
+
+[list_end]
+[para]
+
+[subsection {ERROR HANDLING}]
+
+The instructions in this section provide read and write access to the
+error status [term ER] of the machine.
+
+[list_begin definitions]
+
+[def [cmd ier_push]]
+
+This instruction pushes a copy of the current error status [term ER]
+on the error stack [term ES].
+
+[def [cmd ier_clear]]
+
+This instruction clears the error status [term ER].
+
+[def "[cmd ier_nonterminal] [arg message]"]
+
+This instruction checks if the error status [term ER] contains an
+error whose location is just past the location found in the top entry
+of the location stack [term LS].
+
+Nothing happens if no such error is found.
+
+Otherwise the found error is replaced by an error at the location
+found on the stack, having the message [arg message].
+
+[def [cmd ier_merge]]
+
+This instruction pops an entry from the error stack [term ES], merges
+it with the current error status [term ER] and stores the result of
+the merge as the new error status [term ER].
+
+[para]
+
+The merge is performed as described below:
+
+[para]
+
+If one of the two error states is empty the other is chosen. If
+neither error state is empty, and refering to different locations,
+then the error state with the location further in the input is
+chosen. If both error states refer to the same location their messages
+are merged (with removing duplicates).
+
+[list_end]
+
+[subsection {SEMANTIC VALUES}]
+
+The instructions in this section manipulate the semantic value
+[term SV].
+
+[list_begin definitions]
+
+[def [cmd isv_clear]]
+
+This instruction clears the semantic value [term SV].
+
+[def [cmd isv_terminal]]
+
+This instruction creates a terminal AST node for the current token
+[term CT], makes it the semantic value [term SV], and also pushes the
+node on the AST stack [term AS].
+
+[def "[cmd isv_nonterminal_leaf] [arg nt]"]
+
+This instruction creates a nonterminal AST node without any children
+for the nonterminal [arg nt], and makes it the semantic value
+[term SV].
+
+[para]
+
+This instruction should be executed if, and only if the match status
+[term OK] indicates a success.
+
+In the case of a failure [cmd isv_clear] should be called.
+
+[def "[cmd isv_nonterminal_range] [arg nt]"]
+
+This instruction creates a nonterminal AST node for the nonterminal
+
+[arg nt], with a single terminal node as its child, and makes this AST
+the semantic value [term SV]. The terminal node refers to the input
+string from the location found on top of the location stack [term LS]
+to the current location [term CL] (both inclusive).
+
+[para]
+
+This instruction should be executed if, and only if the match status
+[term OK] indicates a success.
+
+In the case of a failure [cmd isv_clear] should be called.
+
+[def "[cmd isv_nonterminal_reduce] [arg nt]"]
+
+This instruction creates a nonterminal AST node for the nonterminal
+[arg nt] and makes it the semantic value [term SV].
+
+[para]
+
+All entries on the AST stack [term AS] above the marker found in the
+top entry of the AST Marker stack [term MS] become children of the new
+node, with the entry at the stack top becoming the rightmost child. If
+the AST Marker stack [term MS] is empty the whole stack is used. The
+AST marker stack [term MS] is left unchanged.
+
+[para]
+
+This instruction should be executed if, and only if the match status
+[term OK] indicates a success.
+
+In the case of a failure [cmd isv_clear] should be called.
+
+[list_end]
+[para]
+
+[subsection {AST STACK HANDLING}]
+
+The instructions in this section manipulate the AST stack [term AS],
+and the AST Marker stack [term MS].
+
+[list_begin definitions]
+
+[def [cmd ias_push]]
+
+This instruction pushes the semantic value [term SV] on the AST stack
+[term AS].
+
+[def [cmd ias_mark]]
+
+This instruction pushes a marker for the current state of the AST
+stack [term AS] on the AST Marker stack [term MS].
+
+[def [cmd ias_mrewind]]
+
+This instruction pops an entry from the AST Marker stack [term MS] and
+then proceeds to pop entries from the AST stack [term AS] until the
+state represented by the popped marker has been reached again.
+
+Nothing is done if the AST stack [term AS] is already smaller than
+indicated by the popped marker.
+
+[def [cmd ias_mpop]]
+
+This instruction pops an entry from the AST Marker stack [term MS] and
+discards it.
+
+[list_end]
+
+[vset CATEGORY grammar_me]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/grammar_me/pkgIndex.tcl b/tcllib/modules/grammar_me/pkgIndex.tcl
new file mode 100644
index 0000000..f43762a
--- /dev/null
+++ b/tcllib/modules/grammar_me/pkgIndex.tcl
@@ -0,0 +1,7 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+
+package ifneeded grammar::me::util 0.1 [list source [file join $dir me_util.tcl]]
+package ifneeded grammar::me::tcl 0.1 [list source [file join $dir me_tcl.tcl]]
+package ifneeded grammar::me::cpu 0.2 [list source [file join $dir me_cpu.tcl]]
+package ifneeded grammar::me::cpu::core 0.2 [list source [file join $dir me_cpucore.tcl]]
+package ifneeded grammar::me::cpu::gasm 0.1 [list source [file join $dir gasm.tcl]]
diff --git a/tcllib/modules/grammar_peg/ChangeLog b/tcllib/modules/grammar_peg/ChangeLog
new file mode 100644
index 0000000..cb14026
--- /dev/null
+++ b/tcllib/modules/grammar_peg/ChangeLog
@@ -0,0 +1,101 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2012-02-22 Andreas Kupries <andreask@activestate.com>
+
+ * peg.tcl: [Bug 3490008]: Fixed variable name typo reported by
+ * pkgIndex.tcl: glastonbridge2. Bumped version to 0.2.
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-01-24 Andreas Kupries <akupries@shaw.ca>
+
+ * peg_interp.tcl (::grammar::peg::interp::MatchExpr):
+ * peg_interp.man: [Bug 3163541] Fixed broken call to
+ * pkgIndex.tcl: ict_match_token, missing the token. Bumped to
+ version 0.1.1.
+
+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 ========================
+ *
+
+2008-07-18 Andreas Kupries <andreask@activestate.com>
+
+ * peg_interp.man (::grammar::peg::interp::parse): Added
+ description of what is expected from the nextcmd callback to
+ this command. Fixed reference to description of the AST format.
+
+2008-05-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * peg_interp.man: Updated to changes in doctools (sub)section
+ reference handling.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-06-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * peg.man: Fixed [Bug 1735588], added text explaining the relation
+ to context-free grammars, per Lars Hellstrom's proposal.
+
+2007-03-26 Andreas Kupries <andreask@activestate.com>
+
+ * peg.man: Uh, the section was put into the list instead of
+ after. Fixed. [Bug 1688650].
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * peg.man: Fixed all warnings due to use of now deprecated
+ * peg_interp.man: 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 ========================
+ *
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-05-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * peg_interp.tcl: Restructured the loops for * and + a bit.
+
+2005-04-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module: Container for parsing expression grammars (PEGs),
+ and an interpreter for them, using the matcher engine.
diff --git a/tcllib/modules/grammar_peg/peg.man b/tcllib/modules/grammar_peg/peg.man
new file mode 100644
index 0000000..c5d7de8
--- /dev/null
+++ b/tcllib/modules/grammar_peg/peg.man
@@ -0,0 +1,721 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin grammar::peg n 0.1]
+[keywords {context-free languages}]
+[keywords expression]
+[keywords grammar]
+[keywords LL(k)]
+[keywords parsing]
+[keywords {parsing expression}]
+[keywords {parsing expression grammar}]
+[keywords {push down automaton}]
+[keywords {recursive descent}]
+[keywords state]
+[keywords TDPL]
+[keywords {top-down parsing languages}]
+[keywords transducer]
+[copyright {2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Grammar operations and usage}]
+[titledesc {Create and manipulate parsing expression grammars}]
+[category {Grammars and finite automata}]
+[require Tcl 8.4]
+[require snit]
+[require grammar::peg [opt 0.1]]
+[description]
+[para]
+
+This package provides a container class for
+[term {parsing expression grammars}] (Short: PEG).
+
+It allows the incremental definition of the grammar, its manipulation
+and querying of the definition.
+
+The package neither provides complex operations on the grammar, nor has
+it the ability to execute a grammar definition for a stream of symbols.
+
+Two packages related to this one are [package grammar::mengine] and
+[package grammar::peg::interpreter]. The first of them defines a
+general virtual machine for the matching of a character stream, and
+the second implements an interpreter for parsing expression grammars
+on top of that virtual machine.
+
+[subsection {TERMS & CONCEPTS}]
+
+PEGs are similar to context-free grammars, but not equivalent; in some
+cases PEGs are strictly more powerful than context-free grammars (there
+exist PEGs for some non-context-free languages).
+
+The formal mathematical definition of parsing expressions and parsing
+expression grammars can be found in section
+[sectref {PARSING EXPRESSION GRAMMARS}].
+
+[para]
+
+In short, we have [term {terminal symbols}], which are the most basic
+building blocks for [term sentences], and [term {nonterminal symbols}]
+with associated [term {parsing expressions}], defining the grammatical
+structure of the sentences. The two sets of symbols are distinctive,
+and do not overlap. When speaking about symbols the word "symbol" is
+often left out. The union of the sets of terminal and nonterminal
+symbols is called the set of [term symbols].
+
+[para]
+
+Here the set of [term {terminal symbols}] is not explicitly managed,
+but implicitly defined as the set of all characters. Note that this
+means that we inherit from Tcl the ability to handle all of Unicode.
+
+[para]
+
+A pair of [term nonterminal] and [term {parsing expression}] is also
+called a [term {grammatical rule}], or [term rule] for short. In the
+context of a rule the nonterminal is often called the left-hand-side
+(LHS), and the parsing expression the right-hand-side (RHS).
+
+[para]
+
+The [term {start expression}] of a grammar is a parsing expression
+from which all the sentences contained in the language specified by
+the grammar are [term derived].
+
+To make the understanding of this term easier let us assume for a
+moment that the RHS of each rule, and the start expression, is either
+a sequence of symbols, or a series of alternate parsing expressions.
+In the latter case the rule can be seen as a set of rules, each
+providing one alternative for the nonterminal.
+
+A parsing expression A' is now a derivation of a parsing expression A
+if we pick one of the nonterminals N in the expression, and one of the
+alternative rules R for N, and then replace the nonterminal in A with
+the RHS of the chosen rule. Here we can see why the terminal symbols
+are called such. They cannot be expanded any further, thus terminate
+the process of deriving new expressions.
+
+An example
+
+[para][example {
+ Rules
+ (1) A <- a B c
+ (2a) B <- d B
+ (2b) B <- e
+
+ Some derivations, using starting expression A.
+
+ A -/1/-> a B c -/2a/-> a d B c -/2b/-> a d e c
+}][para]
+
+A derived expression containing only terminal symbols is a
+[term sentence]. The set of all sentences which can be derived from
+the start expression is the [term language] of the grammar.
+
+[para]
+
+Some definitions for nonterminals and expressions:
+
+[list_begin enumerated]
+[enum]
+A nonterminal A is called [term reachable] if it is possible to derive
+a parsing expression from the start expression which contains A.
+
+[enum]
+A nonterminal A is called [term useful] if it is possible to derive a
+sentence from it.
+
+[enum]
+A nonterminal A is called [term recursive] if it is possible to derive
+a parsing expression from it which contains A, again.
+
+[enum]
+The [term {FIRST set}] of a nonterminal A contains all the symbols which
+can occur of as the leftmost symbol in a parsing expression derived from
+A. If the FIRST set contains A itself then that nonterminal is called
+[term left-recursive].
+
+[enum]
+The [term {LAST set}] of a nonterminal A contains all the symbols which
+can occur of as the rightmost symbol in a parsing expression derived from
+A. If the LAST set contains A itself then that nonterminal is called
+[term right-recursive].
+
+[enum]
+The [term {FOLLOW set}] of a nonterminal A contains all the symbols which
+can occur after A in a parsing expression derived from the start
+expression.
+
+[enum]
+A nonterminal (or parsing expression) is called [term nullable] if the
+empty sentence can be derived from it.
+
+[list_end]
+[para]
+
+And based on the above definitions for grammars:
+
+[list_begin enumerated]
+[enum]
+A grammar G is [term recursive] if and only if it contains a nonterminal
+A which is recursive. The terms [term left-] and [term right-recursive],
+and [term useful] are analogously defined.
+
+[enum]
+A grammar is [term minimal] if it contains only [term reachable] and
+[term useful] nonterminals.
+
+[enum]
+A grammar is [term wellformed] if it is not left-recursive. Such
+grammars are also [term complete], which means that they always succeed
+or fail on all input sentences. For an incomplete grammar on the
+other hand input sentences exist for which an attempt to match them
+against the grammar will not terminate.
+
+[enum]
+As we wish to allow ourselves to build a grammar incrementally in a
+container object we will encounter stages where the RHS of one or more
+rules reference symbols which are not yet known to the container. Such
+a grammar we call [term invalid].
+
+We cannot use the term [term incomplete] as this term is already
+taken, see the last item.
+
+[list_end]
+[para]
+
+[subsection {CONTAINER CLASS API}]
+
+The package exports the API described here.
+
+[list_begin definitions]
+
+[call [cmd ::grammar::peg] [arg pegName] \
+ [opt "[const =]|[const :=]|[const <--]|[const as]|[const deserialize] [arg src]"]]
+
+The command creates a new container object for a parsing expression
+grammar and returns the fully qualified name of the object command as
+its result. The API the returned command is following is described in
+the section [sectref {CONTAINER OBJECT API}]. It may be used to invoke
+various operations on the container and the grammar within.
+
+[para]
+
+The new container, i.e. grammar will be empty if no [arg src] is
+specified. Otherwise it will contain a copy of the grammar contained
+in the [arg src].
+
+The [arg src] has to be a container object reference for all operators
+except [const deserialize].
+
+The [const deserialize] operator requires [arg src] to be the
+serialization of a parsing expression grammar instead.
+
+[para]
+
+An empty grammar has no nonterminal symbols, and the start expression
+is the empty expression, i.e. epsilon. It is [term valid], but not
+[term useful].
+
+[list_end]
+
+[subsection {CONTAINER OBJECT API}]
+[para]
+
+All grammar container objects provide the following methods for the
+manipulation of their contents:
+
+[list_begin definitions]
+
+[call [arg pegName] [method destroy]]
+
+Destroys the grammar, including its storage space and associated
+command.
+
+[call [arg pegName] [method clear]]
+
+Clears out the definition of the grammar contained in [arg pegName],
+but does [emph not] destroy the object.
+
+[call [arg pegName] [method =] [arg srcPEG]]
+
+Assigns the contents of the grammar contained in [arg srcPEG] to
+[arg pegName], overwriting any existing definition.
+
+This is the assignment operator for grammars. It copies the grammar
+contained in the grammar object [arg srcPEG] over the grammar
+definition in [arg pegName]. The old contents of [arg pegName] are
+deleted by this operation.
+
+[para]
+
+This operation is in effect equivalent to
+[para]
+[example_begin]
+ [arg pegName] [method deserialize] [lb][arg srcPEG] [method serialize][rb]
+[example_end]
+
+[call [arg pegName] [method -->] [arg dstPEG]]
+
+This is the reverse assignment operator for grammars. It copies the
+automation contained in the object [arg pegName] over the grammar
+definition in the object [arg dstPEG].
+
+The old contents of [arg dstPEG] are deleted by this operation.
+
+[para]
+
+This operation is in effect equivalent to
+[para]
+[example_begin]
+ [arg dstPEG] [method deserialize] [lb][arg pegName] [method serialize][rb]
+[example_end]
+
+[call [arg pegName] [method serialize]]
+
+This method serializes the grammar stored in [arg pegName]. In other
+words it returns a tcl [emph value] completely describing that
+grammar.
+
+This allows, for example, the transfer of grammars over arbitrary
+channels, persistence, etc.
+
+This method is also the basis for both the copy constructor and the
+assignment operator.
+
+[para]
+
+The result of this method has to be semantically identical over all
+implementations of the [package grammar::peg] interface. This is what
+will enable us to copy grammars between different implementations of
+the same interface.
+
+[para]
+
+The result is a list of four elements with the following structure:
+
+[list_begin enumerated]
+[enum]
+The constant string [const grammar::peg].
+
+[enum]
+A dictionary. Its keys are the names of all known nonterminal symbols,
+and their associated values are the parsing expressions describing
+their sentennial structure.
+
+[enum]
+A dictionary. Its keys are the names of all known nonterminal symbols,
+and their associated values hints to a matcher regarding the semantic
+values produced by the symbol.
+
+[enum]
+The last item is a parsing expression, the [term {start expression}]
+of the grammar.
+
+[list_end]
+[para]
+
+Assuming the following PEG for simple mathematical expressions
+
+[para]
+[example {
+ Digit <- '0'/'1'/'2'/'3'/'4'/'5'/'6'/'7'/'8'/'9'
+ Sign <- '+' / '-'
+ Number <- Sign? Digit+
+ Expression <- '(' Expression ')' / (Factor (MulOp Factor)*)
+ MulOp <- '*' / '/'
+ Factor <- Term (AddOp Term)*
+ AddOp <- '+'/'-'
+ Term <- Number
+}]
+[para]
+
+a possible serialization is
+
+[para]
+[example {
+ grammar::peg \\
+ {Expression {/ {x ( Expression )} {x Factor {* {x MulOp Factor}}}} \\
+ Factor {x Term {* {x AddOp Term}}} \\
+ Term Number \\
+ MulOp {/ * /} \\
+ AddOp {/ + -} \\
+ Number {x {? Sign} {+ Digit}} \\
+ Sign {/ + -} \\
+ Digit {/ 0 1 2 3 4 5 6 7 8 9} \\
+ } \\
+ {Expression value Factor value \\
+ Term value MulOp value \\
+ AddOp value Number value \\
+ Sign value Digit value \\
+ }
+ Expression
+}]
+[para]
+
+A possible one, because the order of the nonterminals in the
+dictionary is not relevant.
+
+[call [arg pegName] [method deserialize] [arg serialization]]
+
+This is the complement to [method serialize]. It replaces the grammar
+definition in [arg pegName] with the grammar described by the
+[arg serialization] value. The old contents of [arg pegName] are
+deleted by this operation.
+
+[call [arg pegName] [method {is valid}]]
+
+A predicate. It tests whether the PEG in [arg pegName] is [term valid].
+See section [sectref {TERMS & CONCEPTS}] for the definition of this
+grammar property.
+
+The result is a boolean value. It will be set to [const true] if
+the PEG has the tested property, and [const false] otherwise.
+
+[call [arg pegName] [method start] [opt [arg pe]]]
+
+This method defines the [term {start expression}] of the grammar. It
+replaces the previously defined start expression with the parsing
+expression [arg pe].
+
+The method fails and throws an error if [arg pe] does not contain a
+valid parsing expression as specified in the section
+[sectref {PARSING EXPRESSIONS}]. In that case the existing start
+expression is not changed.
+
+The method returns the empty string as its result.
+
+[para]
+
+If the method is called without an argument it will return the currently
+defined start expression.
+
+[call [arg pegName] [method nonterminals]]
+
+Returns the set of all nonterminal symbols known to the grammar.
+
+[call [arg pegName] [method {nonterminal add}] [arg nt] [arg pe]]
+
+This method adds the nonterminal [arg nt] and its associated parsing
+expression [arg pe] to the set of nonterminal symbols and rules of the
+PEG contained in the object [arg pegName].
+
+The method fails and throws an error if either the string [arg nt] is
+already known as a symbol of the grammar, or if [arg pe] does not
+contain a valid parsing expression as specified in the section
+[sectref {PARSING EXPRESSIONS}]. In that case the current set of
+nonterminal symbols and rules is not changed.
+
+The method returns the empty string as its result.
+
+[call [arg pegName] [method {nonterminal delete}] [arg nt1] [opt "[arg nt2] ..."]]
+
+This method removes the named symbols [arg nt1], [arg nt2] from the
+set of nonterminal symbols of the PEG contained in the object
+[arg pegName].
+
+The method fails and throws an error if any of the strings is not
+known as a nonterminal symbol. In that case the current set of
+nonterminal symbols is not changed.
+
+The method returns the empty string as its result.
+
+[para]
+
+The stored grammar becomes invalid if the deleted nonterminals are
+referenced by the RHS of still-known rules.
+
+[call [arg pegName] [method {nonterminal exists}] [arg nt]]
+
+A predicate. It tests whether the nonterminal symbol [arg nt] is known
+to the PEG in [arg pegName].
+
+The result is a boolean value. It will be set to [const true] if the
+symbol [arg nt] is known, and [const false] otherwise.
+
+[call [arg pegName] [method {nonterminal rename}] [arg nt] [arg ntnew]]
+
+This method renames the nonterminal symbol [arg nt] to [arg ntnew].
+
+The method fails and throws an error if either [arg nt] is not known
+as a nonterminal, or if [arg ntnew] is a known symbol.
+
+The method returns the empty string as its result.
+
+[call [arg pegName] [method {nonterminal mode}] [arg nt] [opt [arg mode]]]
+
+This mode returns or sets the semantic mode associated with the
+nonterminal symbol [arg nt]. If no [arg mode] is specified the
+current mode of the nonterminal is returned. Otherwise the current
+mode is set to [arg mode].
+
+The method fails and throws an error if [arg nt] is not known as a
+nonterminal.
+
+The grammar interpreter implemented by the package
+[package grammar::peg::interpreter] recognizes the
+following modes:
+
+[list_begin definitions]
+[def value]
+
+The semantic value of the nonterminal is the abstract syntax tree
+created from the AST's of the RHS and a node for the nonterminal
+itself.
+
+[def match]
+
+The semantic value of the nonterminal is an the abstract syntax tree
+consisting of single a node for the string matched by the RHS. The ASTs
+generated by the RHS are discarded.
+
+[def leaf]
+
+The semantic value of the nonterminal is an the abstract syntax tree
+consisting of single a node for the nonterminal itself. The ASTs
+generated by the RHS are discarded.
+
+[def discard]
+
+The nonterminal has no semantic value. The ASTs generated by the RHS
+are discarded (as well).
+
+[list_end]
+
+[call [arg pegName] [method {nonterminal rule}] [arg nt]]
+
+This method returns the parsing expression associated with the
+nonterminal [arg nt].
+
+The method fails and throws an error if [arg nt] is not known as a
+nonterminal.
+
+[call [arg pegName] [method {unknown nonterminals}]]
+
+This method returns a list containing the names of all nonterminal
+symbols which are referenced on the RHS of a grammatical rule, but
+have no rule definining their structure. In other words, a list of
+the nonterminal symbols which make the grammar invalid. The grammar
+is valid if this list is empty.
+
+[list_end]
+
+[para]
+
+[subsection {PARSING EXPRESSIONS}]
+[para]
+
+Various methods of PEG container objects expect a parsing expression
+as their argument, or will return such. This section specifies the
+format such parsing expressions are in.
+
+[para]
+
+[list_begin enumerated]
+[enum]
+The string [const epsilon] is an atomic parsing expression. It matches
+the empty string.
+
+[enum]
+The string [const alnum] is an atomic parsing expression. It matches
+any alphanumeric character.
+
+[enum]
+The string [const alpha] is an atomic parsing expression. It matches
+any alphabetical character.
+
+[enum]
+The string [const dot] is an atomic parsing expression. It matches
+any character.
+
+[enum]
+The expression
+ [lb]list t [var x][rb]
+is an atomic parsing expression. It matches the terminal string [var x].
+
+[enum]
+The expression
+ [lb]list n [var A][rb]
+is an atomic parsing expression. It matches the nonterminal [var A].
+
+[enum]
+For parsing expressions [var e1], [var e2], ... the result of
+
+ [lb]list / [var e1] [var e2] ... [rb]
+
+is a parsing expression as well.
+
+This is the [term {ordered choice}], aka [term {prioritized choice}].
+
+[enum]
+For parsing expressions [var e1], [var e2], ... the result of
+
+ [lb]list x [var e1] [var e2] ... [rb]
+
+is a parsing expression as well.
+
+This is the [term {sequence}].
+
+[enum]
+For a parsing expression [var e] the result of
+
+ [lb]list * [var e][rb]
+
+is a parsing expression as well.
+
+This is the [term {kleene closure}], describing zero or more
+repetitions.
+
+[enum]
+For a parsing expression [var e] the result of
+
+ [lb]list + [var e][rb]
+
+is a parsing expression as well.
+
+This is the [term {positive kleene closure}], describing one or more
+repetitions.
+
+[enum]
+For a parsing expression [var e] the result of
+
+ [lb]list & [var e][rb]
+
+is a parsing expression as well.
+
+This is the [term {and lookahead predicate}].
+
+[enum]
+For a parsing expression [var e] the result of
+
+ [lb]list ! [var e][rb]
+
+is a parsing expression as well.
+
+This is the [term {not lookahead predicate}].
+
+[enum]
+For a parsing expression [var e] the result of
+
+ [lb]list ? [var e][rb]
+
+is a parsing expression as well.
+
+This is the [term {optional input}].
+
+[list_end]
+[para]
+
+Examples of parsing expressions where already shown, in the
+description of the method [method serialize].
+
+[section {PARSING EXPRESSION GRAMMARS}]
+[para]
+
+For the mathematically inclined, a PEG is a 4-tuple (VN,VT,R,eS) where
+
+[list_begin itemized]
+[item]
+VN is a set of [term {nonterminal symbols}],
+
+[item]
+VT is a set of [term {terminal symbols}],
+
+[item]
+R is a finite set of rules, where each rule is a pair (A,e), A in VN,
+and [term e] a [term {parsing expression}].
+
+[item]
+eS is a parsing expression, the [term {start expression}].
+
+[list_end]
+[para]
+
+Further constraints are
+
+[list_begin itemized]
+[item]
+The intersection of VN and VT is empty.
+
+[item]
+For all A in VT exists exactly one pair (A,e) in R. In other words, R
+is a function from nonterminal symbols to parsing expressions.
+
+[list_end]
+[para]
+
+Parsing expression are inductively defined via
+
+[list_begin itemized]
+[item]
+The empty string (epsilon) is a parsing expression.
+
+[item]
+A terminal symbol [term a] is a parsing expression.
+
+[item]
+A nonterminal symbol [term A] is a parsing expression.
+
+[item]
+[term e1][term e2] is a parsing expression for parsing expressions
+[term e1] and [term 2]. This is called [term sequence].
+
+[item]
+[term e1]/[term e2] is a parsing expression for parsing expressions
+[term e1] and [term 2]. This is called [term {ordered choice}].
+
+[item]
+[term e]* is a parsing expression for parsing expression
+[term e]. This is called [term {zero-or-more repetitions}], also known
+as [term {kleene closure}].
+
+[item]
+[term e]+ is a parsing expression for parsing expression
+[term e]. This is called [term {one-or-more repetitions}], also known
+as [term {positive kleene closure}].
+
+[item]
+![term e] is a parsing expression for parsing expression
+[term e1]. This is called a [term {not lookahead predicate}].
+
+[item]
+&[term e] is a parsing expression for parsing expression
+[term e1]. This is called an [term {and lookahead predicate}].
+
+[list_end]
+[para]
+
+[para]
+
+PEGs are used to define a grammatical structure for streams of symbols
+over VT. They are a modern phrasing of older formalisms invented by
+Alexander Birham. These formalisms were called TS (TMG recognition
+scheme), and gTS (generalized TS). Later they were renamed to TPDL
+(Top-Down Parsing Languages) and gTPDL (generalized TPDL).
+
+[para]
+
+They can be easily implemented by recursive descent parsers with
+backtracking. This makes them relatives of LL(k) Context-Free
+Grammars.
+
+[section REFERENCES]
+
+[list_begin enumerated]
+[enum]
+[uri {http://www.pdos.lcs.mit.edu/~baford/packrat/} \
+ {The Packrat Parsing and Parsing Expression Grammars Page}],
+by Bryan Ford, Massachusetts Institute of Technology. This is the main
+entry page to PEGs, and their realization through Packrat Parsers.
+
+[enum]
+[uri {http://www.cs.vu.nl/~dick/PTAPG.html} \
+ {Parsing Techniques - A Practical Guide }], an online book
+offering a clear, accessible, and thorough discussion of many
+different parsing techniques with their interrelations and
+applicabilities, including error recovery techniques.
+
+[enum]
+[uri {http://scifac.ru.ac.za/compilers/} \
+ {Compilers and Compiler Generators}], an online book using
+CoCo/R, a generator for recursive descent parsers.
+[list_end]
+
+[vset CATEGORY grammar_peg]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/grammar_peg/peg.tcl b/tcllib/modules/grammar_peg/peg.tcl
new file mode 100644
index 0000000..2ccfa72
--- /dev/null
+++ b/tcllib/modules/grammar_peg/peg.tcl
@@ -0,0 +1,541 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Grammars / Parsing Expression Grammars / Container
+
+# ### ### ### ######### ######### #########
+## Package description
+
+# A class whose instances hold all the information describing a single
+# parsing expression grammar (terminal symbols, nonterminal symbols,
+# nonterminal rules, start expression, hints), and operations to
+# define, manipulate, and query this information.
+#
+# The container has only one functionality beyond the simple storage
+# of the aforementioned information. It keeps track if the provided
+# grammar is valid (*). The container provides no higher-level
+# operations on the grammar, like removal of unreachable nonterminals,
+# rule rewriting, etc.
+#
+# The set of terminal symbols is the set of characters (i.e.
+# implicitly defined). For Tcl this means that all the unicode
+# characters are supported.
+#
+# (*) A grammar is valid if and only if all its rules are valid. A
+# rule is valid if and only if all nonterminals referenced by the RHS
+# of the rule are in the set of nonterminals, and if only the allowed
+# operators are used in the expression.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require snit ; # Tcllib | OO system used
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+snit::type ::grammar::peg {
+ # ### ### ### ######### ######### #########
+ ## Type API. Helpful methods for PEs.
+
+ proc ValidateSerial {e prefix} {}
+ proc Validate {e} {}
+ proc References {e} {}
+ proc Rename {e old new} {}
+
+ # ### ### ### ######### ######### #########
+ ## Instance API
+
+ constructor {args} {}
+
+ method clear {} {}
+
+ method = {src} {}
+ method --> {dst} {}
+ method serialize {} {}
+ method deserialize {value} {}
+
+ method {is valid} {} {}
+ method start {args} {}
+
+ method nonterminals {} {}
+ method {nonterminal add} {nts pae} {}
+ method {nonterminal delete} {nts pae} {}
+ method {nonterminal exists} {nts} {}
+ method {nonterminal rename} {ntsold ntsnew} {}
+ method {nonterminal mode} {nts args} {}
+
+ method {unknown nonterminals} {} {}
+
+ method {nonterminal rule} {nts} {}
+
+ # ### ### ### ######### ######### #########
+ ## Internal data structures.
+
+ ## - Set of nonterminal symbols, and
+ ## - Mapping from nonterminals to their defining parsing
+ ## expressions, and
+ ## - Start parsing expression.
+ ## - And usage of nonterminals by others, required for tracking
+ ## of validity.
+
+ ## se: expression | Start expression
+ ## nt: nonterm -> expression | Known Nt's, their rules
+ ## re: nonterm -> list(nonterm) | Known Nt's, what others they use.
+ ## ir: nonterm -> list(nonterm) | Nt's, possibly unknown, their users.
+ ## uk: nonterm -> use counter | Nt's which are unknown.
+ ##
+ ## Both 're' and 'ir' can list a nonterminal A multiple times,
+ ## if it uses or is used multiple times.
+ ##
+ ## Grammar is invalid <=> '[array size uk] > 0'
+
+ variable se epsilon
+ variable nt -array {}
+ variable re -array {}
+ variable ir -array {}
+ variable uk -array {}
+ variable mo -array {}
+
+ # ### ### ### ######### ######### #########
+ ## Instance API Implementation.
+
+ constructor {args} {
+ if {
+ (([llength $args] != 0) && ([llength $args] != 2)) ||
+ (([llength $args] == 2) && ([lsearch {= := <-- as deserialize} [lindex $args 0]]) < 0)
+ } {
+ return -code error "wrong#args: $self ?=|:=|<--|as|deserialize a'?"
+ }
+
+ # Serialization arguments.
+ # [llength args] in {0 2}
+ #
+ # = src-obj
+ # := src-obj
+ # <-- src-obj
+ # as src-obj
+ # deserialize src-value
+
+ if {[llength $args] == 2} {
+ foreach {op val} $args break
+ switch -exact -- $op {
+ = - := - <-- - as {
+ $self deserialize [$val serialize]
+ }
+ deserialize {
+ $self deserialize $val
+ }
+ }
+ }
+ return
+ }
+
+ #destructor {}
+
+ method clear {} {
+ array unset nt *
+ array unset re *
+ array unset ir *
+ array unset uk *
+ array unset mo *
+ set se epsilon
+ return
+ }
+
+ method = {src} {
+ $self dserialize [$src serialize]
+ }
+
+ method --> {dst} {
+ $dst deserialize [$self serialize]
+ }
+
+ method serialize {} {
+ return [::list \
+ grammar::pegc \
+ [array get nt] \
+ [array get mo] \
+ $se]
+ }
+
+ method deserialize {value} {
+ # Validate value, then clear and refill.
+
+ $self CheckSerialization $value ntv mov sev
+ $self clear
+
+ foreach {s e} $ntv {
+ $self NtAdd $s $e
+ }
+ array set mo $mov
+ $self start $sev
+ return
+ }
+
+ method {is valid} {} {
+ return [expr {[array size uk] == 0}]
+ }
+
+ method start {args} {
+ if {[llength $args] == 0} {
+ return $se
+ }
+ if {[llength $args] > 1} {
+ return -code error "wrong#args: $self start ?pe?"
+ }
+ set newse [lindex $args 0]
+ Validate $newse
+ set se $newse
+ return
+ }
+
+ method nonterminals {} {
+ return [array names nt]
+ }
+
+ method {nonterminal add} {nts pae} {
+ $self CheckNtKnown $nts
+ Validate $pae
+ $self NtAdd $nts $pae
+ return
+ }
+
+ method {nonterminal mode} {nts args} {
+ $self CheckNt $nts
+ if {![llength $args]} {
+ return $mo($nts)
+ } elseif {[llength $args] == 1} {
+ set mo($nts) [lindex $args 0]
+ return
+ } else {
+ return -code error "wrong#args"
+ }
+ return
+ }
+
+ method {nonterminal delete} {nts args} {
+ set args [linsert $args 0 $nts]
+ foreach nts $args {
+ $self CheckNt $nts
+ }
+
+ foreach nts $args {
+ $self NtDelete $nts
+ }
+ return
+ }
+
+ method {nonterminal exists} {nts} {
+ return [info exists nt($nts)]
+ }
+
+ method {nonterminal rename} {ntsold ntsnew} {
+ $self CheckNt $ntsold
+ $self CheckNtKnown $ntsnew
+
+ # Difficult. We have to go through all rules and rewrite their
+ # RHS to use the new name of the nonterminal. We can however
+ # restrict ourselves to the rules which actually use the
+ # changed nonterminal.
+
+ # We also have to update the used/user information. We know
+ # that the validity of the grammar is unchanged by this
+ # operation. The unknown information is unchanged as well, as
+ # we cannot rename an unknown nonterminal. IOW we know that
+ # 'ntsold' is not in 'uk', and so 'ntsnew' will not be in that
+ # array either after the rename.
+
+ set myusers $ir($ntsold)
+ set myused $re($ntsold)
+
+ set nt($ntsnew) $nt($ntsold)
+ unset nt($ntsold)
+
+ set mo($ntsnew) $mo($ntsold)
+ unset mo($ntsold)
+
+ foreach x $myusers {
+ set nt($x) [Rename $nt($x) $ntsold $ntsnew]
+ }
+
+ # It is possible to use myself, and be used by myself.
+
+ while {[set pos [lsearch -exact $myusers $ntsold]] >= 0} {
+ set myusers [lreplace $myusers $pos $pos $ntsnew]
+ }
+ while {[set pos [lsearch -exact $myused $ntsold]] >= 0} {
+ set myused [lreplace $myused $pos $pos $ntsnew]
+ }
+
+ set re($ntsnew) $myusers
+ set ir($ntsnew) $myused
+
+ unset re($ntsold)
+ unset ir($ntsold)
+ return
+ }
+
+ method {unknown nonterminals} {} {
+ return [array names uk]
+ }
+
+ method {nonterminal rule} {nts} {
+ $self CheckNt $nts
+ return $nt($nts)
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal helper methods
+
+ method NtAdd {nts pae} {
+ # None of the symbols is known. We can add them to the
+ # grammar. If however any of their PEs is known to the PE
+ # storage then we had expressions refering to unknown
+ # symbols. The grammar is most certainly invalid and may have
+ # become valid right now. We have to invalidate the validity
+ # cache.
+
+ set nt($nts) $pae
+ set mo($nts) value
+
+ # Track users, uses, and unknowns.
+
+ set references [References $pae]
+
+ # We use the refered symbols
+ set re($nts) $references
+
+ # We are a user for the refered symbols
+ # Record unknown symbols immediately.
+ foreach x $references {
+ lappend ir($x) $nts
+ if {[info exists nt($x)]} continue
+ if {[catch {incr uk($x)}]} {set uk($x) 1}
+ }
+
+ # We are definitely not unknown.
+ unset -nocomplain uk($nts)
+ return
+ }
+
+ method NtDelete {nts} {
+ set references $re($nts)
+
+ # We are gone. We are not using anything anymore.
+ unset nt($nts)
+ unset re($nts)
+ unset mo($nts)
+
+ # Our references loose us as their user.
+ foreach x $references {
+ set pos [lsearch -exact $ir($x) $x]
+ if {$pos < 0} {error PANIC}
+ set ir($x) [lreplace $ir($x) $pos $pos]
+ if {[llength $ir($x)] == 0} {
+ unset ir($x)
+ # x is not referenced anywhere, cannot be unknown.
+ unset -nocomplain uk($x)
+ }
+ if {[info exists uk($x)]} {
+ incr uk($x) -1
+ }
+ }
+
+ # We might be used by others still, and therefore become
+ # unknown.
+
+ if {[info exists ir($nts]} {
+ set uk($nts) [llength $ir($nts)]
+ }
+ return
+ }
+
+ method CheckNt {nts} {
+ if {![info exists nt($nts)]} {
+ return -code error "Invalid nonterminal \"$nts\""
+ }
+ return
+ }
+
+ method CheckNtKnown {nts} {
+ if {[info exists nt($nts)]} {
+ return -code error "Nonterminal \"$nts\" is already known"
+ }
+ return
+ }
+
+ method CheckSerialization {value ntv mov sev} {
+ # value is list/3 ('grammar::pegc' nonterminals start)
+ # terminals is list of string.
+ # nonterminals is doct (key is string, value is expr)
+ # start is expr
+ # terminals * nonterminals == empty
+ # expr is parsing expression (Validate PE).
+
+ upvar 1 \
+ $ntv ntvs \
+ $mov movs \
+ $sev sevs
+
+ set prefix "error in serialization:"
+ if {[llength $value] != 4} {
+ return -code error "$prefix list length not 4"
+ }
+
+ struct::list assign $value type nonterminals hints start
+ if {$type ne "grammar::pegc"} {
+ return -code error "$prefix unknown type \"$type\""
+ }
+
+ ValidateSerial $start "$prefix invalid start expression"
+
+ if {[llength $nonterminals] % 2 == 1} {
+ return -code error "$prefix nonterminal data is not a dictionary"
+ }
+ array set _nt $nonterminals
+ if {[llength $nonterminals] != (2*[array size _nt])} {
+ return -code error "$prefix nonterminal data contains duplicate names, or misses some"
+ }
+
+ foreach {s e} $nonterminals {
+ ValidateSerial $start "$prefix nonterminal \"$s\", invalid parsing expression"
+ }
+
+
+ if {[llength $hints] % 2 == 1} {
+ return -code error "$prefix nonterminal modes is not a dictionary"
+ }
+ array set _mo $hints
+ if {[llength $hints] != (2*[array size _mo])} {
+ return -code error "$prefix nonterminal modes contains duplicate names, or misses some"
+ }
+ foreach {s _} $hints {
+ if {![info exists _nt($s)]} {
+ return -code error "$prefix nonterminal mode for unknown nonterminal \"$s\""
+ }
+ }
+
+ set ntvs $nonterminals
+ set sevs $start
+ set movs $hints
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+
+ # ### ### ### ######### ######### #########
+ ## Type API implementation.
+
+ proc ValidateSerial {e prefix} {
+ if {![catch {Validate $e} msg]} return
+ return -code error "$prefix, $msg"
+ }
+
+ proc Validate {e} {
+ if {[llength $e] == 0} {
+ return -code error "invalid empty expression list"
+ }
+
+ set op [lindex $e 0]
+ set ar [lrange $e 1 end]
+
+ switch -exact -- $op {
+ epsilon - alpha - alnum - dot {
+ if {[llength $ar] > 0} {
+ return -code error "wrong#args for \"$op\""
+ }
+ }
+ .. {
+ if {[llength $ar] != 2} {
+ return -code error "wrong#args for \"$op\""
+ }
+ # Leaf, arguments are not expressions to validate.
+ }
+ n - t {
+ if {[llength $ar] != 1} {
+ return -code error "wrong#args for \"$op\""
+ }
+ # Leaf, argument is not expression to validate.
+ }
+ & - ! - * - + - ? {
+ if {[llength $ar] != 1} {
+ return -code error "wrong#args for \"$op\""
+ }
+ Validate [lindex $ar 0]
+ }
+ x - / {
+ if {![llength $ar]} {
+ return -code error "wrong#args for \"$op\""
+ }
+ foreach e $ar {
+ Validate $e
+ }
+ }
+ default {
+ return -code error "invalid operator \"$op\""
+ }
+ }
+ }
+
+ proc References {e} {
+ set references {}
+
+ set op [lindex $e 0]
+ set ar [lrange $e 1 end]
+
+ switch -exact -- $op {
+ epsilon - t - alpha - alnum - dot - .. {}
+ n {
+ # Remember referenced nonterminal
+ lappend references [lindex $ar 0]
+ }
+ & - ! - * - + - ? {
+ foreach r [References [lindex $ar 0]] {
+ lappend references $r
+ }
+ }
+ x - / {
+ foreach e $ar {
+ foreach r [References $e] {
+ lappend references $r
+ }
+ }
+ }
+ }
+ return $references
+ }
+
+ proc Rename {e old new} {
+ set op [lindex $e 0]
+ set ar [lrange $e 1 end]
+
+ switch -exact -- $op {
+ epsilon - t - alpha - alnum - dot - .. {return $e}
+ n {
+ if {[lindex $ar 0] ne $old} {return $e}
+ return [list n $new]
+ }
+ & - ! - * - + - ? {
+ return [list $op [Rename [lindex $ar 0] $old $new]]
+ }
+ x - / {
+ set res $op
+ foreach e $ar {
+ lappend res [Rename $e $old $new]
+ }
+ return $res
+ }
+ }
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Type Internals.
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Package Management
+
+package provide grammar::peg 0.2
diff --git a/tcllib/modules/grammar_peg/peg_interp.man b/tcllib/modules/grammar_peg/peg_interp.man
new file mode 100644
index 0000000..6543f87
--- /dev/null
+++ b/tcllib/modules/grammar_peg/peg_interp.man
@@ -0,0 +1,122 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin grammar::peg::interp n 0.1.1]
+[keywords {context-free languages}]
+[keywords expression]
+[keywords grammar]
+[keywords LL(k)]
+[keywords matching]
+[keywords parsing]
+[keywords {parsing expression}]
+[keywords {parsing expression grammar}]
+[keywords {push down automaton}]
+[keywords {recursive descent}]
+[keywords state]
+[keywords TDPL]
+[keywords {top-down parsing languages}]
+[keywords transducer]
+[keywords {virtual machine}]
+[copyright {2005-2011 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Grammar operations and usage}]
+[titledesc {Interpreter for parsing expression grammars}]
+[category {Grammars and finite automata}]
+[require Tcl 8.4]
+[require grammar::mengine [opt 0.1]]
+[require grammar::peg::interp [opt 0.1.1]]
+[description]
+[para]
+
+This package provides commands for the controlled matching of a
+character stream via a parsing expression grammar and the creation
+of an abstract syntax tree for the stream and partials.
+
+[para]
+
+It is built on top of the virtual machine provided by the package
+[package grammar::me::tcl] and directly interprets the parsing
+expression grammar given to it.
+
+In other words, the grammar is [emph not] pre-compiled but used as is.
+
+[para]
+
+The grammar to be interpreted is taken from a container object
+following the interface specified by the package
+[package grammar::peg::container]. Only the relevant parts
+are copied into the state of this package.
+
+[para]
+
+It should be noted that the package provides exactly one instance
+of the interpreter, and interpreting a second grammar requires
+the user to either abort or complete a running interpretation, or
+to put them into different Tcl interpreters.
+
+[para]
+
+Also of note is that the implementation assumes a pull-type
+handling of the input. In other words, the interpreter pulls
+characters from the input stream as it needs them. For usage
+in a push environment, i.e. where the environment pushes new
+characters as they come we have to put the engine into its
+own thread.
+
+[section {THE INTERPRETER API}]
+
+The package exports the following API
+
+[list_begin definitions]
+
+[call [cmd ::grammar::peg::interp::setup] [arg peg]]
+
+This command (re)initializes the interpreter. It returns the
+empty string. This command has to be invoked first, before any
+matching run.
+
+[para]
+
+Its argument [arg peg] is the handle of an object containing the
+parsing expression grammar to interpret. This grammar has to be
+valid, or an error will be thrown.
+
+[call [cmd ::grammar::peg::interp::parse] [arg nextcmd] [arg errorvar] [arg astvar]]
+
+This command interprets the loaded grammar and tries to match it
+against the stream of characters represented by the command prefix
+[arg nextcmd].
+
+[para]
+
+The command prefix [arg nextcmd] represents the input stream of
+characters and is invoked by the interpreter whenever the a new
+character from the stream is required.
+
+The callback has to return either the empty list, or a list of 4
+elements containing the token, its lexeme attribute, and its location
+as line number and column index, in this order.
+
+The empty list is the signal that the end of the input stream has been
+reached. The lexeme attribute is stored in the terminal cache, but
+otherwise not used by the machine.
+
+[para]
+
+The result of the command is a boolean value indicating whether the
+matching process was successful ([const true]), or not
+([const false]). In the case of a match failure error information will
+be stored into the variable referenced by [arg errorvar]. The variable
+referenced by [arg astvar] will always contain the generated abstract
+syntax tree, however in the case of an error it will be only partial
+and possibly malformed.
+
+[para]
+
+The abstract syntax tree is represented by a nested list, as
+described in section [sectref-external {AST VALUES}] of
+document [term grammar::me_ast].
+
+[list_end]
+[para]
+
+[vset CATEGORY grammar_peg]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/grammar_peg/peg_interp.tcl b/tcllib/modules/grammar_peg/peg_interp.tcl
new file mode 100644
index 0000000..b0c7f2f
--- /dev/null
+++ b/tcllib/modules/grammar_peg/peg_interp.tcl
@@ -0,0 +1,350 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Grammar / Parsing Expression Grammar / Interpreter (Namespace based)
+
+# ### ### ### ######### ######### #########
+## Package description
+
+## The instances of this class match an input provided by a buffer to
+## a parsing expression grammar provided by a peg container. The
+## matching process is interpretative, i.e. expressions are matched on
+## the fly and multiple as they are encountered. The interpreter
+## operates in pull-push mode, i.e. the interpreter object is in
+## charge and reads the character stream from the buffer as it needs,
+## and returns with the result of the match either when encountering
+## an error, or when the match was successful.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require grammar::me::tcl
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+namespace eval ::grammar::peg::interp {
+ # Import the virtual machine for matching.
+
+ namespace import ::grammar::me::tcl::*
+ upvar #0 ::grammar::me::tcl::ok ok
+}
+
+# ### ### ### ######### ######### #########
+## Instance API Implementation.
+
+proc ::grammar::peg::interp::setup {peg} {
+ variable ru
+ variable mo
+ variable se
+
+ if {![$peg is valid]} {
+ return -code error "Cannot initialize interpreter for invalid grammar"
+ }
+ set se [$peg start]
+ foreach s [$peg nonterminals] {
+ set ru($s) [$peg nonterminal rule $s]
+ set mo($s) [$peg nonterminal mode $s]
+ }
+
+ #parray mo
+ return
+}
+
+proc ::grammar::peg::interp::parse {nxcmd emvar astvar} {
+ variable ok
+ variable se
+
+ upvar 1 $emvar emsg $astvar ast
+
+ init $nxcmd
+
+ MatchExpr $se
+ isv_nonterminal_reduce ALL -1
+ set ast [sv]
+ if {!$ok} {
+ foreach {l m} [ier_get] break
+ lappend l [lc $l]
+ set emsg [list $l $m]
+ }
+
+ return $ok
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper methods
+
+proc ::grammar::peg::interp::MatchExpr {e} {
+ variable ok
+ variable mode
+ variable mo
+ variable ru
+
+ set op [lindex $e 0]
+ set ar [lrange $e 1 end]
+
+ switch -exact -- $op {
+ epsilon {
+ # No input to match, nor consume. Match always.
+ iok_ok
+ }
+ dot {
+ # Match and consume one character. No matter which
+ # character. Fails only when reaching eof. Does not
+ # consume input on failure.
+
+ ict_advance "Expected any character (got EOF)"
+ if {$ok && ($mode eq "value")} {isv_terminal}
+ }
+ alnum - alpha {
+ ict_advance "Expected <$op> (got EOF)"
+ if {!$ok} return
+
+ ict_match_tokclass $op "Expected <$op>"
+ if {$ok && ($mode eq "value")} {isv_terminal}
+ }
+ t {
+ # Match and consume one specific character. Fails if
+ # the character at the location is not what was
+ # expected. Does not consume input on failure.
+
+ set ch [lindex $ar 0]
+
+ ict_advance "Expected $ch (got EOF)"
+ if {!$ok} return
+
+ ict_match_token $ch "Expected $ch"
+ if {$ok && ($mode eq "value")} {isv_terminal}
+ }
+ .. {
+ # Match and consume one character, if in the specified
+ # range. Fails if the read character is outside of the
+ # range. Does not consume input on failure.
+
+ foreach {chbegin chend} $ar break
+
+ ict_advance "Expected \[$chbegin .. $chend\] (got EOF)"
+ if {!$ok} return
+
+ ict_match_tokrange $chbegin $chend "Expected \[$chbegin .. $chend\]"
+ if {$ok && ($mode eq "value")} {isv_terminal}
+ }
+ n {
+ # To match a nonterminal in the input we match its
+ # parsing expression. This can be cut short if the
+ # necessary information can be obtained from the memo
+ # cache. Does not consume input on failure.
+
+ set nt [lindex $ar 0]
+ set savemode $mode
+ set mode $mo($nt)
+
+ if {[inc_restore $nt]} {
+ if {$ok && ($mode ne "discard")} ias_push
+ set mode $savemode
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ MatchExpr $ru($nt)
+
+ # Generate semantic value, based on mode.
+ if {$mode eq "value"} {
+ isv_nonterminal_reduce $nt $pos $mrk
+ } elseif {$mode eq "match"} {
+ isv_nonterminal_range $nt $pos
+ } elseif {$mode eq "leaf"} {
+ isv_nonterminal_leaf $nt $pos
+ } else {
+ # mode eq "discard"
+ isv_clear
+ }
+ inc_save $nt $pos
+
+ # AST operations ...
+ ias_pop2mark $mrk
+ if {$ok && ($mode ne "discard")} ias_push
+
+ set mode $savemode
+ # Even if match is ok.
+ ier_nonterminal "Expected $nt" $pos
+ }
+ & {
+ # Lookahead predicate. And. Matches the expression
+ # against the input and returns match result. Never
+ # consumes any input.
+
+ set pos [icl_get]
+
+ MatchExpr [lindex $ar 0]
+
+ icl_rewind $pos
+ return
+ }
+ ! {
+ # Negated lookahead predicate. Matches the expression
+ # against the input and returns the negated match
+ # result. Never consumes any input.
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ MatchExpr [lindex $ar 0]
+
+ if {$ok} {ias_pop2mark $mrk}
+ icl_rewind $pos
+
+ iok_negate
+ return
+ }
+ * {
+ # Zero or more repetitions. This consumes as much
+ # input as it was able to match the sub
+ # expression. The expresion as a whole always matches,
+ # even if the sub expression fails (zero repetition).
+
+ set sub [lindex $ar 0]
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ MatchExpr $sub
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+ }
+ + {
+ # One or more repetition. Like *, except for one match
+ # at the front which has to match for success. This
+ # expression can fail. It will consume only as much
+ # input as it was able to match.
+
+ set sub [lindex $ar 0]
+
+ set pos [icl_get]
+
+ MatchExpr $sub
+ if {!$ok} {
+ icl_rewind $pos
+ return
+ }
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ MatchExpr $sub
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+ }
+ ? {
+ # Optional matching. Tries to match the sub
+ # expression. Will never fail, even if the sub
+ # expression is not matching. Consumes only input as
+ # it could match in the sub expression. Like *, but
+ # without the repetition.
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ MatchExpr [lindex $ar 0]
+ ier_merge $old
+
+ if {!$ok} {
+ icl_rewind $pos
+ iok_ok
+ }
+ return
+ }
+ x {
+ # Sequence. Matches each sub expression in turn, each
+ # consuming input. In case of failure by one of the
+ # sequence elements nothing is consumed at all.
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+ ier_clear
+
+ foreach e $ar {
+
+ set old [ier_get]
+ MatchExpr $e
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+ }
+ # OK
+ return
+ }
+ / {
+ # Choice. Matches each sub expression in turn, always
+ # starting from the current location. Nothing is
+ # consumed if all branches fail. Consumes as much as
+ # was consumed by the matching branch.
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ ier_clear
+ foreach e $ar {
+
+ set old [ier_get]
+ MatchExpr $e
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ continue
+ }
+ return
+ }
+ # FAIL
+ iok_fail
+ return
+ }
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Interpreter data structures.
+
+namespace eval ::grammar::peg::interp {
+ ## Start expression.
+ ## Map from nonterminals to their expressions.
+ ## Reference to internal memo cache.
+
+ variable se {} ; # Start expression.
+ variable ru ; # Nonterminals and rule map.
+ variable mo ; # Nonterminal modes.
+
+ variable mode value ; # Matching mode.
+
+ array set ru {}
+ array set mo {}
+}
+
+# ### ### ### ######### ######### #########
+## Package Management
+
+package provide grammar::peg::interp 0.1.1
diff --git a/tcllib/modules/grammar_peg/pkgIndex.tcl b/tcllib/modules/grammar_peg/pkgIndex.tcl
new file mode 100644
index 0000000..dfed1ef
--- /dev/null
+++ b/tcllib/modules/grammar_peg/pkgIndex.tcl
@@ -0,0 +1,2 @@
+package ifneeded grammar::peg 0.2 [list source [file join $dir peg.tcl]]
+package ifneeded grammar::peg::interp 0.1.1 [list source [file join $dir peg_interp.tcl]]
diff --git a/tcllib/modules/hook/ChangeLog b/tcllib/modules/hook/ChangeLog
new file mode 100644
index 0000000..473c050
--- /dev/null
+++ b/tcllib/modules/hook/ChangeLog
@@ -0,0 +1,27 @@
+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-02-23 Andreas Kupries <andreask@activestate.com>
+
+ * hook.man: [Bug 3167244]: Moved examples to their own lines to
+ avoid placement of following text on the .CE lines, causing a
+ staircase effect. The doctools should be fixed as well.
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2011-01-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module 'hook'.
diff --git a/tcllib/modules/hook/hook.man b/tcllib/modules/hook/hook.man
new file mode 100644
index 0000000..3a0e009
--- /dev/null
+++ b/tcllib/modules/hook/hook.man
@@ -0,0 +1,375 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin hook n 0.1]
+[see_also uevent(n)]
+[keywords callback]
+[keywords event]
+[keywords hook]
+[keywords observer]
+[keywords producer]
+[keywords publisher]
+[keywords subject]
+[keywords subscriber]
+[keywords uevent]
+[copyright {2010, by William H. Duquette}]
+[moddesc {Hooks}]
+[titledesc {Hooks}]
+[category {Programming tools}]
+[require Tcl 8.5]
+[require hook [opt 0.1]]
+[description]
+[para]
+
+This package provides the [cmd hook] ensemble command, which
+implements the Subject/Observer pattern. It allows [term subjects],
+which may be [term modules], [term objects], [term widgets], and so
+forth, to synchronously call [term hooks] which may be bound to an
+arbitrary number of subscribers, called [term observers]. A subject
+may call any number of distinct hooks, and any number of observers can
+bind callbacks to a particular hook called by a particular
+subject. Hook bindings can be queried and deleted.
+
+[para]
+
+This man page is intended to be a reference only.
+
+[section Concepts]
+[subsection Introduction]
+
+Tcl modules usually send notifications to other modules in two ways:
+via Tk events, and via callback options like the text widget's
+
+[option -yscrollcommand] option. Tk events are available only in Tk,
+and callback options require tight coupling between the modules
+sending and receiving the notification.
+
+[para]
+
+Loose coupling between sender and receiver is often desirable,
+however. In Model/View/Controller terms, a View can send a command
+(stemming from user input) to the Controller, which updates the
+Model. The Model can then call a hook [emph {to which all relevant
+Views subscribe.}] The Model is decoupled from the Views, and indeed
+need not know whether any Views actually exist.
+
+At present, Tcl/Tk has no standard mechanism for implementing loose
+coupling of this kind. This package defines a new command, [cmd hook],
+which implements just such a mechanism.
+
+[subsection Bindings]
+
+The [cmd hook] command manages a collection of hook bindings. A hook
+binding has four elements:
+
+[list_begin enumerated]
+[enum]
+A [term subject]: the name of the entity that will be calling the
+hook.
+
+[enum]
+The [term hook] itself. A hook usually reflects some occurrence in the
+life of the [term subject] that other entities might care to know
+about. A [term hook] has a name, and may also have arguments. Hook
+names are arbitrary strings. Each [term subject] must document the
+names and arguments of the hooks it can call.
+
+[enum]
+The name of the [term observer] that wishes to receive the [term hook]
+from the [term subject].
+
+[enum]
+A command prefix to which the [term hook] arguments will be appended
+when the binding is executed.
+
+[list_end]
+
+[subsection {Subjects and observers}]
+
+For convenience, this document collectively refers to subjects and
+observers as [term objects], while placing no requirements on how
+these [term objects] are actually implemented. An object can be a
+[package TclOO] or [package Snit] or [package XOTcl] object, a Tcl
+command, a namespace, a module, a pseudo-object managed by some other
+object (as tags are managed by the Tk text widget) or simply a
+well-known name.
+
+[para]
+Subject and observer names are arbitrary strings; however, as
+[cmd hook] might be used at the package level, it's necessary to have
+conventions that avoid name collisions between packages written by
+different people.
+
+[para]
+Therefore, any subject or observer name used in core or package level
+code should look like a Tcl command name, and should be defined in a
+namespace owned by the package. Consider, for example, an ensemble
+command [cmd ::foo] that creates a set of pseudo-objects and uses
+[package hook] to send notifications. The pseudo-objects have names
+that are not commands and exist in their own namespace, rather like
+file handles do. To avoid name collisions with subjects defined by
+other packages, users of [package hook], these [cmd ::foo] handles
+should have names like [const ::foo::1], [const ::foo::2], and so on.
+
+[para]
+Because object names are arbitrary strings, application code can use
+whatever additional conventions are dictated by the needs of the
+application.
+
+[section Reference]
+
+Hook provides the following commands:
+
+[list_begin definitions]
+
+[call [cmd hook] [method bind] [opt [arg subject]] [opt [arg hook]] [opt [arg observer]] [opt [arg cmdPrefix]]]
+
+This subcommand is used to create, update, delete, and query hook
+bindings.
+
+[para] Called with no arguments it returns a list of the subjects with
+hooks to which observers are currently bound.
+
+[para] Called with one argument, a [arg subject], it returns a list of
+the subject's hooks to which observers are currently bound.
+
+[para] Called with two arguments, a [arg subject] and a [arg hook], it
+returns a list of the observers which are currently bound to this
+[arg subject] and [arg hook].
+
+[para] Called with three arguments, a [arg subject], a [arg hook], and
+an [arg observer], it returns the binding proper, the command prefix
+to be called when the hook is called, or the empty string if there is
+no such binding.
+
+[para] Called with four arguments, it creates, updates, or deletes a
+binding. If [arg cmdPrefix] is the empty string, it deletes any
+existing binding for the [arg subject], [arg hook], and
+[arg observer]; nothing is returned. Otherwise, [arg cmdPrefix] must
+be a command prefix taking as many additional arguments as are
+documented for the [arg subject] and [arg hook]. The binding is added
+or updated, and the observer is returned.
+
+[para] If the [arg observer] is the empty string, "", it will create a
+new binding using an automatically generated observer name of the form
+[const ::hook::ob]<[var number]>. The automatically generated name
+will be returned, and can be used to query, update, and delete the
+binding as usual. If automated observer names are always used, the
+observer name effectively becomes a unique binding ID.
+
+[para] It is possible to call [cmd {hook bind}] to create or delete a
+binding to a [arg subject] and [arg hook] while in an observer binding
+for that same [arg subject] and [arg hook]. The following rules
+determine what happens when
+
+[example {
+ hook bind $s $h $o $binding
+}]
+
+is called during the execution of
+
+[example {
+ hook call $s $h
+}]
+
+[list_begin enumerated]
+[enum]
+No binding is ever called after it is deleted.
+
+[enum]
+When a binding is called, the most recently given command prefix is
+always used.
+
+[enum]
+The set of observers whose bindings are to be called is determined
+when this method begins to execute, and does not change thereafter,
+except that deleted bindings are not called.
+
+[list_end]
+
+In particular:
+
+[list_begin enumerated]
+[enum]
+
+If [var \$o]s binding to [var \$s] and [var \$h] is deleted, and
+[var \$o]s binding has not yet been called during this execution of
+
+[example {
+ hook call $s $h
+}]
+
+it will not be called. (Note that it might already have been called;
+and in all likelihood, it is probably deleting itself.)
+
+[enum]
+If [var \$o] changes the command prefix that's bound to [var \$s] and
+[var \$h], and if [var \$o]s binding has not yet been called during
+this execution of
+
+[example {
+ hook call $s $h
+}]
+
+the new binding will be called when the time comes. (But again, it is
+probably [var \$o]s binding that is is making the change.)
+
+[enum]
+If a new observer is bound to [var \$s] and [var \$h], its binding will
+not be called until the next invocation of
+
+[example {
+ hook call $s $h
+}]
+
+[list_end]
+
+[call [cmd hook] [method call] [arg subject] [arg hook] [opt [arg args]...]]
+
+This command is called when the named [arg subject] wishes to call the
+named [arg hook]. All relevant bindings are called with the specified
+arguments in the global namespace. Note that the bindings are called
+synchronously, before the command returns; this allows the [arg args]
+to include references to entities that will be cleaned up as soon as
+the hook has been called.
+
+[para]
+The order in which the bindings are called is not guaranteed. If
+sequence among observers must be preserved, define one observer and
+have its bindings call the other callbacks directly in the proper
+sequence.
+
+[para]
+Because the [cmd hook] mechanism is intended to support loose
+coupling, it is presumed that the [arg subject] has no knowledge of
+the observers, nor any expectation regarding return values. This has a
+number of implications:
+
+[list_begin enumerated]
+[enum]
+[cmd {hook call}] returns the empty string.
+
+[enum]
+Normal return values from observer bindings are ignored.
+
+[enum]
+Errors and other exceptional returns propagate normally by
+default. This will rarely be what is wanted, because the subjects
+usually have no knowledge of the observers and will therefore have no
+particular competence at handling their errors. That makes it an
+application issue, and so applications will usually want to define an
+[option -errorcommand].
+
+[list_end]
+
+If the [option -errorcommand] configuration option has a non-empty
+value, its value will be invoked for all errors and other exceptional
+returns in observer bindings. See [cmd {hook configure}], below, for
+more information on configuration options.
+
+[call [cmd hook] [method forget] [arg object]]
+
+This command deletes any existing bindings in which the named
+[arg object] appears as either the [term subject] or the
+[term observer].
+
+Bindings deleted by this method will never be called again. In
+particular,
+
+[list_begin enumerated]
+[enum]
+If an observer is forgotten during a call to [cmd {hook call}], any
+uncalled binding it might have had to the relevant subject and hook
+will [emph not] be called subsequently.
+
+[enum]
+If a subject [var \$s] is forgotten during a call to
+
+[example {hook call $s $h}]
+
+then [cmd {hook call}] will return as soon as the current binding
+returns. No further bindings will be called.
+
+[list_end]
+
+[call [cmd hook] [method cget] [arg option]]
+
+This command returns the value of one of the [cmd hook] command's
+configuration options.
+
+[call [cmd hook] [method configure] [option option] [arg value] ...]
+
+This command sets the value of one or more of the [cmd hook] command's
+configuration options:
+
+[list_begin options]
+
+[opt_def -errorcommand [arg cmdPrefix]]
+If the value of this option is the empty string, "", then errors
+and other exception returns in binding scripts are propagated
+normally. Otherwise, it must be a command prefix taking three
+additional arguments:
+
+[list_begin enumerated]
+[enum] a 4-element list {subject hook arglist observer},
+[enum] the result string, and
+[enum] the return options dictionary.
+[list_end]
+
+Given this information, the [option -errorcommand] can choose to log
+the error, call [cmd {interp bgerror}], delete the errant binding
+(thus preventing the error from arising a second time) and so forth.
+
+[opt_def -tracecommand [arg cmdPrefix]]
+The option's value should be a command prefix taking four
+arguments:
+
+[list_begin enumerated]
+[enum] a [term subject],
+[enum] a [term hook],
+[enum] a list of the hook's argument values, and
+[enum] a list of [term objects] the hook was called for.
+[list_end]
+
+The command will be called for each hook that is called. This allows
+the application to trace hook execution for debugging purposes.
+
+[list_end]
+[list_end]
+
+[section Example]
+
+The [cmd ::model] module calls the <Update> hook in response to
+commands that change the model's data:
+
+[example {
+ hook call ::model <Update>
+}]
+
+The [widget .view] megawidget displays the model state, and needs to
+know about model updates. Consequently, it subscribes to the ::model's
+<Update> hook.
+
+[example {
+ hook bind ::model <Update> .view [list .view ModelUpdate]
+}]
+
+When the [cmd ::model] calls the hook, the [widget .view]s
+ModelUpdate subcommand will be called.
+
+[para]
+
+Later the [widget .view] megawidget is destroyed. In its destructor,
+it tells the [term hook] that it no longer exists:
+
+[example {
+ hook forget .view
+}]
+
+All bindings involving [widget .view] are deleted.
+
+[section Credits]
+
+Hook has been designed and implemented by William H. Duquette.
+
+[vset CATEGORY hook]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/hook/hook.tcl b/tcllib/modules/hook/hook.tcl
new file mode 100644
index 0000000..ed00430
--- /dev/null
+++ b/tcllib/modules/hook/hook.tcl
@@ -0,0 +1,354 @@
+# hook.tcl
+#
+# This file implements the hook(n) Subject/Observer
+# callback mechanism. Any number of observers can register for
+# a particular hook from a particular subject; when the
+# subject calls the hook, all observers are called.
+#
+# Copyright (C) 2010 by Will Duquette
+#
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL
+# WARRANTIES.
+
+namespace eval hook {
+ namespace export bind call cget configure forget
+ namespace ensemble create
+
+ # Subject Dictionary:
+ #
+ # Dictionary subject -> hook -> observer -> binding
+
+ variable sdict [dict create]
+
+ # Observer Dictionary:
+ #
+ # Dictionary observer -> subject -> hook -> 1
+ #
+ # The "1" is so that the hook name is a key, and can be
+ # cleared using [dict unset $o $s $h]
+
+ variable odict [dict create]
+
+ # Observer counter
+ #
+ # Used to auto-generate observer names in [hook bind].
+
+ variable observerCounter 0
+
+ # Configuration options
+ #
+ # -errorcommand Handles errors in hook bindings.
+ # -tracecommand Trace called hooks.
+
+ variable options
+ array set options {
+ -errorcommand {}
+ -tracecommand {}
+ }
+}
+
+
+# hook::bind --
+#
+# By default, binds an observer to a subject's hook.
+# Alternatively, bind can delete or query a binding, or query a
+# number of bindings.
+#
+# Arguments:
+# subject (optional) The name of the entity that owns the hook.
+# It will usually be a fully-qualified command
+# name, but "virtual" subjects are also allowed.
+#
+# hook (optional) The name of the hook. By convention,
+# hook names are enclosed in angle brackets and contain
+# no whitespace; however, any non-empty string is allowed.
+#
+# observer (optional) The name of the entity observing the hook.
+# It will usually be a fully-qualified command name,
+# but "virtual" observers are also allowed.
+#
+# If observer is the empty string, an observer name
+# of the form "::hook::ob<num>" will be generated.
+#
+# binding (optional) The binding proper, a command prefix to which
+# the hook's arguments will be appended.
+#
+# Results:
+# If called with no arguments, returns a list of the names of the
+# subjects to which observers are bound.
+#
+# If called with just a subject name, returns a list of the names
+# of the subject's hooks to which bindings are bound.
+#
+# If called with just a subject name and a hook name, returns a
+# list of the names of the observers bound to that subject and hook.
+#
+# If called with a subject name, hook name, and observer name,
+# returns the associated binding, or the empty string if none.
+#
+# If called with all four arguments, it either adds or deletes
+# a binding. If the binding is the empty string, any existing
+# binding is deleted and the empty string is returned.
+# Otherwise the binding is saved, and the observer name is
+# returned. The observer will be automatically
+# generated if the empty string is given.
+
+proc hook::bind {args} {
+ variable sdict
+ variable odict
+ variable observerCounter
+
+ # FIRST, there should be no more than four args.
+ set argc [llength $args]
+
+ if {$argc > 4} {
+ return -code error "wrong # args: should be \"hook bind ?subject? ?hook? ?observer? ?binding?\""
+ }
+
+ lassign $args subject hook observer binding
+
+ # NEXT, Add, update, or delete a binding.
+ if {$argc == 4} {
+ if {$binding ne ""} {
+ # FIRST, auto-generate an observer, if need be. Note that
+ # with bignums there's no chance of running out of valid
+ # observer IDs.
+ if {$observer eq ""} {
+ set observer [namespace current]::ob[incr observerCounter]
+ }
+
+ # NEXT, add or update the binding
+ dict set sdict $subject $hook $observer $binding
+ dict set odict $observer $subject $hook 1
+
+ # NEXT, return the observer.
+ return $observer
+ } else {
+ dict unset sdict $subject $hook $observer
+ dict unset odict $observer $subject $hook
+ }
+
+ return
+ }
+
+ # NEXT, Query a binding
+ if {$argc == 3} {
+ if {[dict exists $sdict $subject $hook $observer]} {
+ return [dict get $sdict $subject $hook $observer]
+ } else {
+ return {}
+ }
+ }
+
+ # NEXT, Query the observers bound to a subject and hook.
+ if {$argc == 2} {
+ if {[dict exists $sdict $subject $hook]} {
+ return [dict keys [dict get $sdict $subject $hook]]
+ } else {
+ return {}
+ }
+ }
+
+ # NEXT, query the bound hooks for a given subject.
+ if {$argc == 1} {
+ if {[dict exists $sdict $subject]} {
+ return [dict keys [dict get $sdict $subject]]
+ } else {
+ return {}
+ }
+ }
+
+ # FINALLY, query the subjects with active bindings.
+ return [dict keys $sdict]
+}
+
+
+# hook::forget --
+#
+# Forget all bindings in which a named entity appears as either
+# subject or observer. No error is raised if the named entity
+# appears in no bindings at all.
+#
+# Arguments:
+# object The name of a subject, an observer, or both.
+#
+# Results:
+# Returns the empty string.
+
+proc hook::forget {object} {
+ variable sdict
+ variable odict
+
+ # FIRST, get rid of any odict entries for which this object
+ # is the subject.
+ if {[dict exists $sdict $object]} {
+ dict for {hook dict_o} [dict get $sdict $object] {
+ dict for {observer binding} $dict_o {
+ dict unset odict $observer $object $hook
+ }
+ }
+ }
+
+
+ # NEXT, get rid of any sdict entries for which this object is
+ # the observer.
+ if {[dict exists $odict $object]} {
+ dict for {subject hdict} [dict get $odict $object] {
+ dict for {hook dummy} $hdict {
+ dict unset sdict $subject $hook $object
+ }
+ }
+ }
+
+
+ # NEXT, get rid of this object from sdict as subject.
+ dict unset sdict $object
+
+ # NEXT, get rid of this object form odict as observers.
+ dict unset odict $object
+
+
+ return
+}
+
+# hook::call --
+#
+# A subject calls a hook. Bindings are called for all bound
+# observers. There is no guarantee of the order in which bindings
+# will be called. All bindings are called before the call returns.
+# Note that modules should document the hooks they call, including
+# details of any arguments associated with each hook.
+#
+# Arguments:
+# subject The subject sending the hook
+# hook The name of the hook being sent
+# args (optional) any arguments for this subject and hook.
+#
+# Results:
+# The bindings are called in no particular order; the args are
+# appended to each binding. Returns the empty string.
+#
+# If -errorcommand is defined, errors in bindings are handled
+# by the specified command. It is called with three arguments:
+# a list of the subject, hook, args, and observer, the error result,
+# and the return options dictionary.
+#
+# When the -tracecommand is set, it is called with four arguments:
+# the subject, the hook, a list of the hook arguments, and a
+# list of the receiving observers.
+
+proc hook::call {subject hook args} {
+ variable sdict
+ variable options
+
+ # FIRST, If there are no observers we're done.
+ if {[dict exists $sdict $subject $hook]} {
+ set observers [dict keys [dict get $sdict $subject $hook]]
+ } else {
+ set observers [list]
+ }
+
+ # NEXT, for each observer, retrieve the binding (if it
+ # still exists) and execute it. Keep track of the observers
+ # for which the hook was actually called.
+ set called [list]
+
+ foreach observer $observers {
+ # FIRST, skip bindings that no longer exist.
+ if {![dict exists $sdict $subject $hook $observer]} {
+ continue
+ }
+
+ set binding [dict get $sdict $subject $hook $observer]
+
+ # NEXT, remember that we called a binding for this observer.
+ lappend called $observer
+
+ if {$options(-errorcommand) eq ""} {
+ uplevel #0 [list {*}$binding {*}$args]
+ } elseif {[catch {
+ uplevel #0 [list {*}$binding {*}$args]
+ } result opts]} {
+ uplevel #0 \
+ [list {*}$options(-errorcommand) \
+ [list $subject $hook $args $observer] \
+ $result \
+ $opts]
+ }
+ }
+
+ if {$options(-tracecommand) ne ""} {
+ {*}$options(-tracecommand) $subject $hook $args $called
+ }
+
+ return
+}
+
+# hook::cget --
+#
+# Returns the value of a hook configuration option.
+#
+# Arguments:
+# option The name of the option
+#
+# Results:
+# Returns the option's value. Throws an error if the
+# option name is invalid.
+
+proc hook::cget {option} {
+ variable options
+
+ if {$option ni [array names options]} {
+ return -code error "unknown option \"$option\""
+ }
+
+ return $options($option)
+}
+
+
+# hook::configure --
+#
+# Sets the value of one or more hook configuration options.
+#
+# Arguments:
+# args A list of option names and their values
+#
+# Results:
+# Saves the option values. Throws an error for unknown options
+# and invalid values. No option values are changed on error.
+
+proc hook::configure {args} {
+ variable options
+
+ # FIRST, validate the options
+ set argc [llength $args]
+ set i 0
+
+ while {$i < $argc} {
+ # FIRST, make sure it's a known option.
+ set option [lindex $args [incr i]-1]
+
+ if {$option ni [array names options]} {
+ return -code error "unknown option \"$option\""
+ }
+
+ # NEXT, make sure a value is specified.
+ if {$i == $argc} {
+ return -code error "value for \"$option\" missing"
+ }
+
+ # NEXT, skip the value
+ incr i
+ }
+
+ # NEXT, save the values
+ array set options $args
+
+ return
+}
+
+# ---------------------------------------------------------------
+# Ready
+
+package provide hook 0.1
diff --git a/tcllib/modules/hook/hook.test b/tcllib/modules/hook/hook.test
new file mode 100644
index 0000000..58bafb4
--- /dev/null
+++ b/tcllib/modules/hook/hook.test
@@ -0,0 +1,492 @@
+# hook.test -*- tcl -*-
+#
+# This file contains the test suite for hook-0.1.tcl.
+#
+# Copyright (C) 2010 by Will Duquette
+#
+# See the file "license.terms" for information on usage and
+# redistribution of this file, and for a DISCLAIMER OF ALL
+# WARRANTIES.
+
+#-----------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.1
+
+support {
+}
+testing {
+ useLocal hook.tcl hook
+}
+
+#-----------------------------------------------------------------------
+# Helper procs
+
+variable info
+array set info {
+ callList {}
+ traceList {}
+ errorList {}
+}
+
+proc cleanup {} {
+ variable info
+ array set info {
+ callList {}
+ traceList {}
+ errorList {}
+ }
+
+ foreach subject [hook bind] {
+ hook forget $subject
+ }
+
+ hook configure -errorcommand {} -tracecommand {}
+
+ # Ensure that auto-generated observers are repeatable.
+ set ::hook::observerCounter 0
+}
+
+proc TestBinding {subject hook observer args} {
+ variable info
+
+ lappend info(callList) [list $subject $hook $observer $args]
+
+ return
+}
+
+proc GetCalls {} {
+ variable info
+
+ return $info(callList)
+}
+
+proc TraceCommand {subject hook args observers} {
+ variable info
+
+ lappend info(traceList) [list $subject $hook $args $observers]
+}
+
+proc GetTrace {} {
+ variable info
+
+ return $info(traceList)
+}
+
+proc TestBind {subject hook observer} {
+ hook bind $subject $hook $observer \
+ [list TestBinding $subject $hook $observer]
+}
+
+proc ErrorCommand {call result opts} {
+ variable info
+
+ set opts [dict remove $opts -errorinfo -errorline]
+
+ lappend info(errorList) [list $call $result $opts]
+}
+
+proc GetError {} {
+ variable info
+
+ return $info(errorList)
+}
+
+if {[package vsatisfies [package provide Tcl] 8.6]} {
+ proc EResult {a b} { return $b }
+} else {
+ proc EResult {a b} { return $a }
+}
+
+#-----------------------------------------------------------------------
+# cget
+
+test cget-1.1 {unknown option name} -body {
+ hook cget -nonesuch
+} -returnCodes {
+ error
+} -result {unknown option "-nonesuch"}
+
+test cget-1.2 {retrieve option value} -body {
+ hook cget -errorcommand
+} -result {}
+
+#-----------------------------------------------------------------------
+# configure
+
+test configure-1.1 {unknown option name} -body {
+ hook configure -nonesuch
+} -returnCodes {
+ error
+} -result {unknown option "-nonesuch"}
+
+test configure-1.2 {missing option value} -body {
+ hook configure -errorcommand
+} -returnCodes {
+ error
+} -result {value for "-errorcommand" missing}
+
+test configure-2.1 {set values} -body {
+ hook configure -errorcommand foo -tracecommand bar
+
+ list [hook cget -errorcommand] [hook cget -tracecommand]
+} -cleanup {
+ hook configure -errorcommand {} -tracecommand {}
+} -result {foo bar}
+
+#-----------------------------------------------------------------------
+# bind
+
+test bind-1.1 {too many arguments} -body {
+ hook bind a b c d e
+} -returnCodes {
+ error
+} -result "wrong # args: should be \"hook bind ?subject? ?hook? ?observer? ?binding?\""
+
+test bind-2.1 {bindings can be made} -body {
+ hook bind S1 <H1> O1 {B1 arg1 arg2}
+ hook bind S1 <H1> O1
+} -cleanup {
+ cleanup
+} -result {B1 arg1 arg2}
+
+test bind-2.2 {bindings can be deleted} -body {
+ hook bind S1 <H1> O1 {B1 arg1 arg2}
+ hook bind S1 <H1> O1 {}
+ hook bind S1 <H1> O1
+} -cleanup {
+ cleanup
+} -result {}
+
+test bind-3.1 {bound observers can be queried} -body {
+ hook bind S1 <H1> O1 B1
+ hook bind S1 <H1> O2 B2
+ hook bind S2 <H1> O2 B3
+
+ set a [hook bind S1 <H1>]
+ set b [hook bind S2 <H1>]
+ set c [hook bind S2 <H2>]
+
+ list $a $b $c
+} -cleanup {
+ cleanup
+} -result {{O1 O2} O2 {}}
+
+test bind-3.2 {bound hooks can be queried} -body {
+ hook bind S1 <H1> O1 B1
+ hook bind S1 <H2> O2 B2
+ hook bind S2 <H3> O2 B3
+
+ set a [hook bind S1]
+ set b [hook bind S2]
+ set c [hook bind S3]
+
+ list $a $b $c
+} -cleanup {
+ cleanup
+} -result {{<H1> <H2>} <H3> {}}
+
+test bind-3.3 {bound subjects can be queried} -body {
+ hook bind S1 <H1> O1 B1
+ hook bind S1 <H2> O2 B2
+ hook bind S2 <H3> O2 B3
+
+ hook bind
+} -cleanup {
+ cleanup
+} -result {S1 S2}
+
+test bind-3.4 {deleted bindings can no longer be queried} -body {
+ hook bind S1 <H1> O1 B1
+ hook bind S1 <H1> O2 B2
+ hook bind S2 <H1> O2 B3
+
+ hook bind S1 <H1> O2 {}
+
+ set a [hook bind S1 <H1>]
+ set b [hook bind S2 <H1>]
+ set c [hook bind S2 <H2>]
+
+ list $a $b $c
+} -cleanup {
+ cleanup
+} -result {O1 O2 {}}
+
+
+test bind-4.1 {auto-generated observer is returned} -body {
+ hook bind S1 <H1> "" {B1 arg1 arg2}
+} -cleanup {
+ cleanup
+} -result {::hook::ob1}
+
+test bind-4.2 {auto-generated observer is a real observer} -body {
+ set ob [hook bind S1 <H1> "" {B1 arg1 arg2}]
+ hook bind S1 <H1> $ob
+} -cleanup {
+ cleanup
+} -result {B1 arg1 arg2}
+
+test bind-4.3 {successive calls get distinct observers} -body {
+ set a [hook bind S1 <H1> "" {B1 arg1 arg2}]
+ set b [hook bind S1 <H2> "" {B2 arg1 arg2}]
+ list $a $b
+} -cleanup {
+ cleanup
+} -result {::hook::ob1 ::hook::ob2}
+
+test bind-5.1 {binding deleted during hook call is not called} -body {
+ # If a subject/hook is called, and if a binding deletes some
+ # other binding to that same subject/hook, and if the second binding
+ # has not yet been called, it should not be called.
+
+ hook bind S1 <H1> O1 {hook bind S1 <H1> O2 ""}
+ TestBind S1 <H1> O2
+ TestBind S1 <H1> O3
+ hook call S1 <H1>
+
+ # Should see O3 but not O2.
+ GetCalls
+} -cleanup {
+ cleanup
+} -result {{S1 <H1> O3 {}}}
+
+test bind-5.2 {binding revised during hook call is called} -body {
+ # If a subject/hook is called, and if a binding changes some
+ # other observer's binding to that same subject/hook, and if the
+ # other observer's binding has not yet been called, it is the
+ # changed binding that will be called.
+
+ hook bind S1 <H1> O1 {TestBind S1 <H1> O2}
+ hook bind S1 <H1> O2 {error "Rebind Failed"}
+
+ hook call S1 <H1>
+
+ # Should see O2 in result, instead of getting "Rebind Failed" error.
+ GetCalls
+} -cleanup {
+ cleanup
+} -result {{S1 <H1> O2 {}}}
+
+test bind-5.3 {binding added during hook call is not called} -body {
+ # If a subject/hook is called, and a binding adds a new binding
+ # for a new observer for this same subject/hook, the new binding
+ # will not be called this time around.
+
+ hook bind S1 <H1> O1 {TestBind S1 <H1> O3}
+ TestBind S1 <H1> O2
+
+ hook call S1 <H1>
+
+ # Should see O2 in result, but not O3
+ GetCalls
+} -cleanup {
+ cleanup
+} -result {{S1 <H1> O2 {}}}
+
+
+#-----------------------------------------------------------------------
+# forget
+
+test forget-1.1 {can forget safely when not yet initialized} -body {
+ hook forget NONESUCH
+} -result {}
+
+test forget-1.2 {can forget unbound entity safely} -body {
+ hook bind S1 <H1> O1 B1
+ hook forget NONESUCH
+ hook bind S1 <H1> O1
+} -cleanup {
+ cleanup
+} -result {B1}
+
+test forget-1.3 {can forget subject} -body {
+ hook bind S1 <H1> O1 B1
+ hook bind S2 <H2> O2 B2
+ hook bind S3 <H3> O3 B3
+
+ hook forget S2
+ hook bind
+} -cleanup {
+ cleanup
+} -result {S1 S3}
+
+test forget-1.4 {can forget subject} -body {
+ hook bind S1 <H1> O1 B1
+ hook bind S2 <H2> O2 B2
+ hook bind S3 <H3> O3 B3
+
+ hook forget O2
+ hook bind S2 <H2>
+} -cleanup {
+ cleanup
+} -result {}
+
+test forget-2.1 {observer forgotten during hook call is not called} -body {
+ # If an observer has a binding to a particular subject/hook, and if
+ # in a call to that subject/hook the observer is forgotten, and
+ # if that observer's binding has not yet been called, it should not
+ # be called.
+
+ hook bind S1 <H1> O1 {hook forget O2}
+ TestBind S1 <H1> O2
+ TestBind S1 <H1> O3
+
+ hook call S1 <H1>
+
+ # Should get O3 but not O2
+ GetCalls
+} -cleanup {
+ cleanup
+} -result {{S1 <H1> O3 {}}}
+
+test forget-2.2 {subject forgotten during hook call, no more calls} -body {
+ # If a subject/hook is called, and some binding forgets the subject,
+ # no uncalled bindings for that subject/hook should be called.
+
+ TestBind S1 <H1> O1
+ hook bind S1 <H1> O2 {hook forget S1}
+ TestBind S1 <H1> O3
+
+ hook call S1 <H1>
+
+ # Should get O1 but not O3
+ GetCalls
+} -cleanup {
+ cleanup
+} -result {{S1 <H1> O1 {}}}
+
+
+
+#-----------------------------------------------------------------------
+# call
+
+test call-1.1 {can call safely before anything is bound} -body {
+ hook call S1 <H1>
+} -result {}
+
+test call-1.2 {can call safely when hook isn't bound} -body {
+ hook bind S1 <H1> O1 B1
+ hook call S2 <H2>
+} -cleanup {
+ cleanup
+} -result {}
+
+test call-1.3 {bindings are executed} -body {
+ TestBind S1 <H1> O1
+ hook call S1 <H1>
+ GetCalls
+} -cleanup {
+ cleanup
+} -result {{S1 <H1> O1 {}}}
+
+test call-1.4 {multiple bindings are executed} -body {
+ TestBind S1 <H1> O1
+ TestBind S1 <H1> O2
+ hook call S1 <H1>
+ GetCalls
+} -cleanup {
+ cleanup
+} -result {{S1 <H1> O1 {}} {S1 <H1> O2 {}}}
+
+test call-1.5 {only relevant bindings are executed} -body {
+ TestBind S1 <H1> O1
+ TestBind S2 <H1> O2
+ hook call S1 <H1>
+ GetCalls
+} -cleanup {
+ cleanup
+} -result {{S1 <H1> O1 {}}}
+
+test call-2.1 {errors propagate normally} -body {
+ hook bind S1 <H1> O1 {error "Simulated Error"}
+ hook call S1 <H1>
+} -returnCodes {
+ error
+} -cleanup {
+ cleanup
+} -result {Simulated Error}
+
+test call-2.2 {other exceptions propagate normally} -body {
+ hook bind S1 <H1> O1 {return -code break "Simulated Break"}
+ hook call S1 <H1>
+} -returnCodes {
+ break
+} -cleanup {
+ cleanup
+} -result {Simulated Break}
+
+
+#-----------------------------------------------------------------------
+# -errorcommand
+
+test errorerror-1.1 {error with -errorcommand {}} -body {
+ hook bind S1 <H1> O1 {error "simulated error"}
+ hook call S1 <H1>
+} -returnCodes {
+ error
+} -cleanup {
+ cleanup
+} -result {simulated error}
+
+test errorcommand-1.2 {error with -errorcommand set} -body {
+ hook configure -errorcommand ErrorCommand
+
+ hook bind S1 <H1> O1 {error "simulated error"}
+ hook call S1 <H1>
+ GetError
+} -cleanup {
+ cleanup
+} -result [EResult \
+ {{{S1 <H1> {} O1} {simulated error} {-code 1 -level 0 -errorcode NONE}}} \
+ {{{S1 <H1> {} O1} {simulated error} {-code 1 -level 0 -errorstack {INNER {error {simulated error}} UP 1 CALL {::hook::call S1 <H1>}} -errorcode NONE}}}]
+
+test errorcommand-1.3 {handled errors don't break sequence of calls} -body {
+ hook configure -errorcommand ErrorCommand
+
+ TestBind S1 <H1> O1
+ hook bind S1 <H1> O2 {error "simulated error"}
+ TestBind S1 <H1> O3
+ hook call S1 <H1>
+ list [GetCalls] [GetError]
+} -cleanup {
+ cleanup
+} -result [EResult \
+ {{{S1 <H1> O1 {}} {S1 <H1> O3 {}}} {{{S1 <H1> {} O2} {simulated error} {-code 1 -level 0 -errorcode NONE}}}} \
+ {{{S1 <H1> O1 {}} {S1 <H1> O3 {}}} {{{S1 <H1> {} O2} {simulated error} {-code 1 -level 0 -errorstack {INNER {error {simulated error}} UP 1 CALL {::hook::call S1 <H1>}} -errorcode NONE}}}}]
+
+test errorcommand-1.4 {-errorcommand handles other exceptions} -body {
+ hook configure -errorcommand ErrorCommand
+
+ hook bind S1 <H1> O1 {return -code break "simulated break"}
+ hook call S1 <H1>
+ GetError
+} -cleanup {
+ cleanup
+} -result {{{S1 <H1> {} O1} {simulated break} {-code 3 -level 1}}}
+
+
+#-----------------------------------------------------------------------
+# -tracecommand
+
+test tracecommand-1.1 {-tracecommand is called} -body {
+ TestBind S1 <H1> O1
+ TestBind S1 <H1> O2
+ TestBind S2 <H2> O2
+
+ hook configure -tracecommand TraceCommand
+ hook call S1 <H1>
+ hook call S2 <H2>
+ hook call S3 <H3>
+ GetTrace
+} -cleanup {
+ cleanup
+} -result {{S1 <H1> {} {O1 O2}} {S2 <H2> {} O2} {S3 <H3> {} {}}}
+
+#-----------------------------------------------------------------------
+# Clean up and finish
+
+::tcltest::cleanupTests \ No newline at end of file
diff --git a/tcllib/modules/hook/license.terms b/tcllib/modules/hook/license.terms
new file mode 100644
index 0000000..8406c2e
--- /dev/null
+++ b/tcllib/modules/hook/license.terms
@@ -0,0 +1,38 @@
+This software is copyrighted by William H. Duquette. The following
+terms apply to all files associated with the software unless
+explicitly disclaimed in individual files.
+
+The authors hereby grant permission to use, copy, modify, distribute,
+and license this software and its documentation for any purpose, provided
+that existing copyright notices are retained in all copies and that this
+notice is included verbatim in any distributions. No written agreement,
+license, or royalty fee is required for any of the authorized uses.
+Modifications to this software may be copyrighted by their authors
+and need not follow the licensing terms described here, provided that
+the new terms are clearly indicated on the first page of each file where
+they apply.
+
+IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+MODIFICATIONS.
+
+GOVERNMENT USE: If you are acquiring this software on behalf of the
+U.S. government, the Government shall have only "Restricted Rights"
+in the software and related documentation as defined in the Federal
+Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
+are acquiring the software on behalf of the Department of Defense, the
+software shall be classified as "Commercial Computer Software" and the
+Government shall have only "Restricted Rights" as defined in Clause
+252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
+authors grant the U.S. Government and others acting in its behalf
+permission to use and distribute the software in accordance with the
+terms specified in this license.
diff --git a/tcllib/modules/hook/pkgIndex.tcl b/tcllib/modules/hook/pkgIndex.tcl
new file mode 100644
index 0000000..08746aa
--- /dev/null
+++ b/tcllib/modules/hook/pkgIndex.tcl
@@ -0,0 +1,5 @@
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ # PRAGMA: returnok
+ return
+}
+package ifneeded hook 0.1 [list source [file join $dir hook.tcl]]
diff --git a/tcllib/modules/html/ChangeLog b/tcllib/modules/html/ChangeLog
new file mode 100644
index 0000000..2628b6a
--- /dev/null
+++ b/tcllib/modules/html/ChangeLog
@@ -0,0 +1,300 @@
+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-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-08-21 Andreas Kupries <andreask@activestate.com>
+
+ * html.man: Documentation of tableFrom{Array,List} extended per
+ [Tcllib SF Bug 1740573] (David Scott Cargo). Disabled the
+ documentation of 'html::title', per the same report, the command
+ seems to be not really for users, but only for internal use.
+
+2007-06-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * html.man: Fixed bug [SF Bug 1740573], documentation typos,
+ etc. Thanks to David Scott Cargo <escargo@users.sourceforge.net>
+ for the report.
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * html.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-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * html.man: Bumped version to 1.4.
+ * html.tcl:
+ * pkgIndex.tcl:
+
+2006-09-12 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * html.tcl : fixed [SF Tcllib Bug 1557268], and
+ html.test: updated the test suite.
+
+2006-07-02 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * html.tcl : fixed [SF Tcllib Bug 1230699] and updated the tests.
+ html.test: Removed unused variables leftover from use in tclhttpd.
+
+2006-06-28 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * html.tcl (::html::meta): fixed [SF Tcllib Bug 1494597] and
+ changed tests so the test against the correct HTML 4.01 spec
+ for <meta>.
+
+2006-06-13 Andreas Kupries <andreask@activestate.com>
+
+ * html.tcl (::html::css, ::html::js): New commands, implementing
+ [SF Tcllib RFE 970878]. Reworked the internals to be cleaner.
+
+ * html.tcl (::html::doctype): New command, implements [SF Tcllib
+ RFE 1494660], proposed by <robert_hicks@users.sourceforge.net>.
+ Changed the implementation to be table-driven.
+
+2006-01-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * html.test: Fixed use of duplicate test names.
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * html.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * html.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-03 Andreas Kupries <andreask@activestate.com>
+
+ * html.tcl (::html::html_entities): Accepted the [SF Tcllib Patch
+ * html.tcl (::html::nl2br): 1294733], creating two small
+ * html.man: commands for the conversion of
+ * html.test: special characters to their
+ entities, and line-endings to
+ <br>. Extended documentation
+ and testsuite.
+
+2005-01-19 Andreas Kupries <andreask@activestate.com>
+
+ * html.tcl (::html::font): Fixed [Tcllib SF Bug 1105010], reported
+ by Luciano <lucianoes@users.sourceforge.net>. The parameters for
+ the font tag were duplicated.
+ * html.test: Added tests for "html::font".
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+Wed Sep 29 12:01:34 2004 Andreas Kupries <andreask@activestate.com>
+
+ * html.man: Accepted patch provided by Michael Schlenker
+ <mic42@users.sourceforge.net>, completes the documentation of
+ html::checkSet. This fixes [Tcllib SF Bug 898774].
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl:
+ * html.man:
+ * html.tcl: Fixed bug #614591. Set version of the package to to
+ 1.2.2. Fixed equivalent of bug #648679.
+
+2003-02-24 David N. Welton <davidw@dedasys.com>
+
+ * html.tcl (html::quoteFormValue): Package requires Tcl 8.2 in any
+ case, so having an implementation of this proc for older Tcl
+ versions doesn't make much sense.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * html.man: More semantic markup, less visual one.
+
+2002-08-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * html.tcl: Updated 'info exist' to 'info exists'.
+
+2002-06-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl:
+ * html.tcl:
+ * html.n:
+ * html.man: Bumped to version 1.2.1.
+
+2002-04-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * html.man: Added doctools manpage.
+
+2002-02-14 Joe English <jenglish@users.sourceforge.net>
+
+ * html.n: Remove mention of (unimplemented, undocumented)
+ formatCode procedure (SF BUG #461434).
+
+2002-01-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bumped version to 1.2
+
+2002-01-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * html.n:
+ * html.tcl: Accepted patch #484117 provided by Decoster Jos
+ <decosterjos@users.sourceforge.net> providing two new function
+ to generated lists and parameterized table rows.
+
+2001-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * html.n:
+ * html.test:
+ * html.tcl:
+ * pkgIndex.tcl: Version up to 1.1.1
+
+2001-08-01 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * html.tcl: added 8.1+ improved version of quoteFormValue.
+
+2001-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * html.tcl: Frink 2.2 run, fixed dubious code.
+
+2001-06-19 Melissa Chawla <melissachawla@yahoo.com>
+
+ * modules/html/html.tcl: Added set and eval commands to this
+ package. These commands have the same syntax as those built in to
+ Tcl, but they are reworked to return "" so they blend into HTML
+ template files without appending unwanted results. The html::set
+ command must take two arguments.
+
+2001-06-15 Brent Welch <welch@panasas.com>
+
+ * modules/html/html.tcl: Updated the version to 1.1
+ Removed the "namespace export *" because you really do not
+ want to import these routines, especialy the new "if", "foreach", etc.
+
+2001-06-15 Melissa Chawla <melissachawla@yahoo.com>
+
+ * modules/html/html.tcl: Added if, for, foreach, and while control
+ structures to this package. The control structures have the same
+ syntax as those built in to Tcl, but these are reworked to blend
+ into HTML template files. Rather than evaluating a body clause,
+ we return the subst'ed body (concatenated to eachother in cases
+ where multiple loop bodies were subst'ed).
+
+ Fixed minor bug in textInput that caused tests to fail.
+
+2000-08-22 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * modules/html/html.tcl:
+ Removed the 'html::resolveUrl' procedure because it provided
+ the same functionality as the uri::resolve function, only
+ html::resolveUrl was undocumented and untested and as a result
+ did not seem to work as well as uri::resolve.
+
+2000-07-31 Brent Welch <welch@scriptics.com>
+
+ * modules/html/html.tcl:
+ Changed html::textInput to take "args" for additional stuff to
+ put into the <text> tag instead of "defaultValue". The ncgi
+ module now has ncgi::setDefaultValue for that purpose.
+
+2000-07-28 Brent Welch <welch@scriptics.com>
+
+ * modules/html/html.tcl, html.n: Added html::passwordInputRow
+
+2000-07-24 Brent Welch <welch@scriptics.com>
+
+ * modules/html/html.tcl: Fixed html::closeTag to tolerate
+ bad calls - when noone has called openTag on anything
+ or when the tag stack is empty.
+
+2000-06-04 Brent Welch <welch@scriptics.com>
+
+ * modules/html/html.tcl: Added html::headTag to add any tag
+ to the HEAD section generated by html::head.
+
+2000-05-16 Brent Welch <welch@scriptics.com>
+
+ * modules/html/html.tcl: Added html::refresh to generate
+ META tags that cause a page to refresh.
+
+2000-04-26 Brent Welch <welch@scriptics.com>
+
+ * html/html.tcl: Added urlResove and urlParent URL parsing
+ routines.
+
+2000-04-26 Brent Welch <welch@scriptics.com>
+
+ * html/html.tcl: track name changes in ncgi
+
+2000-04-24 Brent Welch <welch@scriptics.com>
+
+ * html/html.tcl, html.test: Cleanup of procedure names in html package.
+ * html/html.n: Updates to the man page
+ * html/html.test: 60% through tests
+
diff --git a/tcllib/modules/html/html.man b/tcllib/modules/html/html.man
new file mode 100644
index 0000000..f18cf4b
--- /dev/null
+++ b/tcllib/modules/html/html.man
@@ -0,0 +1,476 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset HTML_VERSION 1.4.4]
+[manpage_begin html n [vset HTML_VERSION]]
+[see_also htmlparse]
+[see_also ncgi]
+[keywords checkbox]
+[keywords checkbutton]
+[keywords form]
+[keywords html]
+[keywords radiobutton]
+[keywords table]
+[moddesc {HTML Generation}]
+[titledesc {Procedures to generate HTML structures}]
+[category {CGI programming}]
+[require Tcl 8.2]
+[require html [opt [vset HTML_VERSION]]]
+[description]
+[para]
+
+The package [package html] provides commands that generate HTML.
+These commands typically return an HTML string as their result. In
+particular, they do not output their result to [const stdout].
+
+[para]
+
+The command [cmd ::html::init] should be called early to initialize
+the module. You can also use this procedure to define default values
+for HTML tag parameters.
+
+[list_begin definitions]
+
+[call [cmd ::html::author] [arg author]]
+
+[emph {Side effect only}]. Call this before [cmd ::html::head] to
+define an author for the page. The author is noted in a comment in
+the HEAD section.
+
+[call [cmd ::html::bodyTag] [arg args]]
+
+Generate a [term body] tag. The tag parameters are taken from [arg args] or
+from the body.* attributes define with [cmd ::html::init].
+
+[call [cmd ::html::cell] [arg {param value}] [opt [arg tag]]]
+
+Generate a [term td] (or [term th]) tag, a value, and a closing
+[term td] (or [term th]) tag. The
+tag parameters come from [arg param] or TD.* attributes defined with
+[cmd ::html::init]. This uses [cmd ::html::font] to insert a standard
+[term font] tag into the table cell. The [arg tag] argument defaults to "td".
+
+[call [cmd ::html::checkbox] [arg {name value}]]
+
+Generate a [term checkbox] form element with the specified name and value.
+This uses [cmd ::html::checkValue].
+
+[call [cmd ::html::checkSet] [arg {key sep list}]]
+
+Generate a set of [term checkbox] form elements and associated labels. The
+[arg list] should contain an alternating list of labels and values.
+This uses [cmd ::html::checkbox]. All the [term checkbox] buttons share the
+same [arg key] for their name. The [arg sep] is text used to separate
+the elements.
+
+[call [cmd ::html::checkValue] [arg name] [opt [arg value]]]
+
+Generate the "name=[arg name] value=[arg value]" for a [term checkbox] form
+element. If the CGI variable [arg name] has the value [arg value],
+then SELECTED is added to the return value. [arg value] defaults to
+"1".
+
+[call [cmd ::html::closeTag]]
+
+Pop a tag off the stack created by [cmd ::html::openTag] and generate
+the corresponding close tag (e.g., </body>).
+
+[call [cmd ::html::default] [arg key] [opt [arg param]]]
+
+This procedure is used by [cmd ::html::tagParam] to generate the name,
+value list of parameters for a tag. The [cmd ::html::default]
+procedure is used to generate default values for those items not
+already in [arg param]. If the value identified by [arg key] matches
+a value in [arg param] then this procedure returns the empty string.
+Otherwise, it returns a "parameter=value" string for a form element
+identified by [arg key]. The [arg key] has the form "tag.parameter"
+(e.g., body.bgcolor). Use [cmd ::html::init] to register default
+values. [arg param] defaults to the empty string.
+
+[call [cmd ::html::description] [arg description]]
+
+[emph {Side effect only}]. Call this before [cmd ::html::head] to
+define a description [term meta] tag for the page. This tag is generated
+later in the call to [cmd ::html::head].
+
+[call [cmd ::html::end]]
+
+Pop all open tags from the stack and generate the corresponding close
+HTML tags, (e.g., </body></html>).
+
+[call [cmd ::html::eval] [arg arg] [opt [arg args]]]
+
+This procedure is similar to the built-in Tcl [cmd eval] command. The
+only difference is that it returns "" so it can be called from an HTML
+template file without appending unwanted results.
+
+[call [cmd ::html::extractParam] [arg {param key}] [opt [arg varName]]]
+
+This is a parsing procedure that extracts the value of [arg key] from
+[arg param], which is a HTML-style "name=quotedvalue" list.
+
+[arg varName] is used as the name of a Tcl variable that is changed to
+have the value found in the parameters. The function returns 1 if the
+parameter was found in [arg param], otherwise it returns 0. If the
+[arg varName] is not specified, then [arg key] is used as the variable
+name.
+
+[call [cmd ::html::font] [arg args]]
+
+Generate a standard [term font] tag. The parameters to the tag are taken
+from [arg args] and the HTML defaults defined with [cmd ::html::init].
+
+[call [cmd ::html::for] [arg {start test next body}]]
+
+This procedure is similar to the built-in Tcl [cmd for] control
+structure. Rather than evaluating the body, it returns the subst'ed
+[arg body]. Each iteration of the loop causes another string to be
+concatenated to the result value.
+
+[call [cmd ::html::foreach] [arg {varlist1 list1}] [opt [arg {varlist2 list2 ...}]] [arg body]]
+
+This procedure is similar to the built-in Tcl [cmd foreach] control
+structure. Rather than evaluating the body, it returns the subst'ed
+[arg body]. Each iteration of the loop causes another string to be
+concatenated to the result value.
+
+[call [cmd ::html::formValue] [arg name] [opt [arg defvalue]]]
+
+Return a name and value pair, where the value is initialized from
+existing CGI data, if any. The result has this form:
+
+[para]
+[example {
+ name="fred" value="freds value"
+}]
+
+[call [cmd ::html::getFormInfo] [arg args]]
+
+Generate hidden fields to capture form values. If [arg args] is
+empty, then hidden fields are generated for all CGI values. Otherwise
+args is a list of string match patterns for form element names.
+
+[call [cmd ::html::getTitle]]
+
+Return the title string, with out the surrounding [term title] tag,
+set with a previous call to [cmd ::html::title].
+
+[call [cmd ::html::h] [arg {level string}] [opt [arg param]]]
+
+Generate a heading (e.g., [term h[var level]]) tag. The [arg string] is nested in the
+heading, and [arg param] is used for the tag parameters.
+
+[call [cmd ::html::h1] [arg string] [opt [arg param]]]
+
+Generate an [term h1] tag. See [cmd ::html::h].
+
+[call [cmd ::html::h2] [arg string] [opt [arg param]]]
+
+Generate an [term h2] tag. See [cmd ::html::h].
+
+[call [cmd ::html::h3] [arg string] [opt [arg param]]]
+
+Generate an [term h3] tag. See [cmd ::html::h].
+
+[call [cmd ::html::h4] [arg string] [opt [arg param]]]
+
+Generate an [term h4] tag. See [cmd ::html::h].
+
+[call [cmd ::html::h5] [arg string] [opt [arg param]]]
+
+Generate an [term h5] tag. See [cmd ::html::h].
+
+[call [cmd ::html::h6] [arg string] [opt [arg param]]]
+
+Generate an [term h6] tag. See [cmd ::html::h].
+
+[call [cmd ::html::hdrRow] [arg args]]
+
+Generate a table row, including [term tr] and [term th] tags.
+Each value in [arg args] is place into its own table cell.
+This uses [cmd ::html::cell].
+
+[call [cmd ::html::head] [arg title]]
+
+Generate the [term head] section that includes the page [term title].
+If previous calls have been made to
+[cmd ::html::author],
+[cmd ::html::keywords],
+[cmd ::html::description],
+or
+[cmd ::html::meta]
+then additional tags are inserted into the [term head] section.
+This leaves an open [term html] tag pushed on the stack with
+[cmd ::html::openTag].
+
+[call [cmd ::html::headTag] [arg string]]
+
+Save a tag for inclusion in the [term head] section generated by
+
+[cmd ::html::head]. The [arg string] is everything in the tag except
+the enclosing angle brackets, < >.
+
+[call [cmd ::html::html_entities] [arg string]]
+
+This command replaces all special characters in the [arg string] with
+their HTML entities and returns the modified text.
+
+[call [cmd ::html::if] [arg {expr1 body1}] [opt "[const elseif] [arg {expr2 body2 ...}]"] [opt "[const else] [arg bodyN]"]]
+
+This procedure is similar to the built-in Tcl [cmd if] control
+structure. Rather than evaluating the body of the branch that is
+taken, it returns the subst'ed [arg body]. Note that the syntax is
+slightly more restrictive than that of the built-in Tcl [cmd if]
+control structure.
+
+[call [cmd ::html::init] [opt [arg list]]]
+
+[cmd ::html::init] accepts a Tcl-style name-value list that defines
+values for items with a name of the form "tag.parameter". For
+example, a default with key "body.bgcolor" defines the background
+color for the [term body] tag.
+
+[call [cmd ::html::keywords] [arg args]]
+
+[emph {Side effect only}]. Call this before [cmd ::html::head] to
+define a keyword [term meta] tag for the page. The [term meta] tag
+is included in the result of [cmd ::html::head].
+
+[call [cmd ::html::mailto] [arg email] [opt [arg subject]]]
+
+Generate a hypertext link to a mailto: URL.
+
+[call [cmd ::html::meta] [arg args]]
+
+[emph {Side effect only}]. Call this before [cmd ::html::head] to
+define a [term meta] tag for the page. The [arg args] is a Tcl-style name,
+value list that is used for the name= and value= parameters for the
+[term meta] tag. The [term meta] tag is included in the result of
+[cmd ::html::head].
+
+[call [cmd ::html::css] [arg href]]
+
+[emph {Side effect only}]. Call this before [cmd ::html::head] to
+define a [term link] tag for a linked CSS document. The [arg href]
+value is a HTTP URL to a CSS document. The [term link] tag is included
+in the result of [cmd ::html::head].
+
+[para]
+
+Multiple calls of this command are allowed, enabling the use of
+multiple CSS document references. In other words, the arguments
+of multiple calls are accumulated, and do not overwrite each other.
+
+[call [cmd ::html::css-clear]]
+
+[emph {Side effect only}]. Call this before [cmd ::html::head] to
+clear all links to CSS documents.
+[para]
+
+Multiple calls of this command are allowed, doing nothing after the
+first of a sequence with no intervening [cmd ::html::css].
+
+[call [cmd ::html::js] [arg href]]
+
+[emph {Side effect only}]. Call this before [cmd ::html::head] to
+define a [term script] tag for a linked JavaScript document. The
+[arg href] is a HTTP URL to a JavaScript document. The [term script]
+tag is included in the result of [cmd ::html::head].
+
+[para]
+
+Multiple calls of this command are allowed, enabling the use of
+multiple JavaScript document references. In other words, the arguments
+of multiple calls are accumulated, and do not overwrite each other.
+
+
+[call [cmd ::html::js-clear]]
+
+[emph {Side effect only}]. Call this before [cmd ::html::head] to
+clear all links to JavaScript documents.
+[para]
+
+Multiple calls of this command are allowed, doing nothing after the
+first of a sequence with no intervening [cmd ::html::js].
+
+[call [cmd ::html::minorList] [arg list] [opt [arg ordered]]]
+
+Generate an ordered or unordered list of links. The [arg list] is a
+Tcl-style name, value list of labels and urls for the links.
+
+[arg ordered] is a boolean used to choose between an ordered or
+unordered list. It defaults to [const false].
+
+[call [cmd ::html::minorMenu] [arg list] [opt [arg sep]]]
+
+Generate a series of hypertext links. The [arg list] is a Tcl-style
+name, value list of labels and urls for the links. The [arg sep] is
+the text to put between each link. It defaults to " | ".
+
+[call [cmd ::html::nl2br] [arg string]]
+
+This command replaces all line-endings in the [arg string] with a
+[term br] tag and returns the modified text.
+
+[call [cmd ::html::openTag] [arg tag] [opt [arg param]]]
+
+Push [arg tag] onto a stack and generate the opening tag for
+[arg tag]. Use [cmd ::html::closeTag] to pop the tag from the
+stack. The second argument provides any tag arguments, as a
+list whose elements are formatted to be in the form
+"[var key]=[const value]".
+
+[call [cmd ::html::paramRow] [arg list] [opt [arg rparam]] [opt [arg cparam]]]
+
+Generate a table row, including [term tr] and [term td] tags. Each value in
+
+[arg list] is placed into its own table cell. This uses
+
+[cmd ::html::cell]. The value of [arg rparam] is used as parameter for
+the [term tr] tag. The value of [arg cparam] is passed to [cmd ::html::cell]
+as parameter for the [term td] tags.
+
+[call [cmd ::html::passwordInput] [opt [arg name]]]
+
+Generate an [term input] tag of type [term password]. The [arg name] defaults to
+"password".
+
+[call [cmd ::html::passwordInputRow] [arg label] [opt [arg name]]]
+
+Format a table row containing a label and an [term input] tag of type
+[term password]. The [arg name] defaults to "password".
+
+[call [cmd ::html::quoteFormValue] [arg value]]
+
+Quote special characters in [arg value] by replacing them with HTML
+entities for quotes, ampersand, and angle brackets.
+
+[call [cmd ::html::radioSet] [arg {key sep list}]]
+
+Generate a set of [term input] tags of type [term radio] and an associated text
+label. All the radio buttons share the same [arg key] for their name.
+The [arg sep] is text used to separate the elements. The [arg list]
+is a Tcl-style label, value list.
+
+[call [cmd ::html::radioValue] [arg {name value}]]
+
+Generate the "name=[arg name] value=[arg value]" for a [term radio] form
+element. If the CGI variable [arg name] has the value [arg value],
+then SELECTED is added to the return value.
+
+[call [cmd ::html::refresh] [arg {seconds url}]]
+
+Set up a refresh [term meta] tag. Call this before [cmd ::html::head] and the
+HEAD section will contain a [term meta] tag that causes the document to
+refresh in [arg seconds] seconds. The [arg url] is optional. If
+specified, it specifies a new page to load after the refresh interval.
+
+[call [cmd ::html::row] [arg args]]
+
+Generate a table row, including [term tr] and [term td] tags. Each value in
+[arg args] is place into its own table cell. This uses
+[cmd ::html::cell]. Ignores any default information set up via
+[cmd ::html::init].
+
+[call [cmd ::html::select] [arg {name param choices}] [opt [arg current]]]
+
+Generate a [term select] form element and nested [term option] tags. The [arg name]
+and [arg param] are used to generate the [term select] tag. The [arg choices]
+list is a Tcl-style name, value list.
+
+[call [cmd ::html::selectPlain] [arg {name param choices}] [opt [arg current]]]
+
+Like [cmd ::html::select] except that [arg choices] is a Tcl list of
+values used for the [term option] tags. The label and the value for each
+[term option] are the same.
+
+[call [cmd ::html::set] [arg {var val}]]
+
+This procedure is similar to the built-in Tcl [cmd set] command. The
+main difference is that it returns "" so it can be called from an HTML
+template file without appending unwanted results. The other
+difference is that it must take two arguments.
+
+[call [cmd ::html::submit] [arg label] [opt [arg name]]]
+
+Generate an [term input] tag of type [term submit]. [arg name] defaults to "submit".
+
+[call [cmd ::html::tableFromArray] [arg arrname] [opt [arg param]] [opt [arg pat]]]
+
+Generate a two-column [term table] and nested rows to display a Tcl array. The
+table gets a heading that matches the array name, and each generated row
+contains a name, value pair. The array names are sorted ([cmd lsort] without
+special options). The argument [arg param] is for the [term table] tag and has
+to contain a pre-formatted string. The [arg pat] is a [cmd {string match}]
+pattern used to select the array elements to show in the table. It defaults to
+[const *], i.e. the whole array is shown.
+
+[call [cmd ::html::tableFromList] [arg querylist] [opt [arg param]]]
+
+Generate a two-column [term table] and nested rows to display [arg querylist],
+which is a Tcl dictionary. Each generated row contains a name, value pair. The
+information is shown in the same order as specified in the dictionary. The
+argument [arg param] is for the [term table] tag and has to contain a
+pre-formatted string.
+
+[call [cmd ::html::textarea] [arg name] [opt [arg param]] [opt [arg current]]]
+
+Generate a [term textarea] tag wrapped around its current values.
+
+[call [cmd ::html::textInput] [arg {name value args}]]
+
+Generate an [term input] form tag with type [term text]. This uses
+
+[cmd ::html::formValue]. The args is any additional tag attributes
+you want to put into the [term input] tag.
+
+[call [cmd ::html::textInputRow] [arg {label name value args}]]
+
+Generate an [term input] form tag with type [term text] formatted into a table row
+with an associated label. The args is any additional tag attributes
+you want to put into the [term input] tag.
+
+[comment {
+[call [cmd ::html::title] [arg title]]
+
+[emph {Side effect only}]. Call this before [cmd ::html::head] to
+define the [term title] for a page.
+}]
+
+[call [cmd ::html::varEmpty] [arg name]]
+
+This returns 1 if the named variable either does not exist or has the
+empty string for its value.
+
+[call [cmd ::html::while] [arg {test body}]]
+
+This procedure is similar to the built-in Tcl [cmd while] control
+structure. Rather than evaluating the body, it returns the subst'ed
+[arg body]. Each iteration of the loop causes another string to be
+concatenated to the result value.
+
+[call [cmd ::html::doctype] [arg id]]
+
+This procedure can be used to build the standard DOCTYPE
+declaration string. It will return the standard declaration
+string for the id, or throw an error if the id is not known.
+The following id's are defined:
+
+[list_begin enumerated]
+[enum] HTML32
+[enum] HTML40
+[enum] HTML40T
+[enum] HTML40F
+[enum] HTML401
+[enum] HTML401T
+[enum] HTML401F
+[enum] XHTML10S
+[enum] XHTML10T
+[enum] XHTML10F
+[enum] XHTML11
+[enum] XHTMLB
+[list_end]
+
+[list_end]
+
+[vset CATEGORY html]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/html/html.tcl b/tcllib/modules/html/html.tcl
new file mode 100644
index 0000000..3c0c443
--- /dev/null
+++ b/tcllib/modules/html/html.tcl
@@ -0,0 +1,1506 @@
+# html.tcl --
+#
+# Procedures to make generating HTML easier.
+#
+# This module depends on the ncgi module for the procedures
+# that initialize form elements based on current CGI values.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2006 Michael Schlenker <mic42@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# Originally by Brent Welch, with help from Dan Kuchler and Melissa Chawla
+
+package require Tcl 8.2
+package require ncgi
+package provide html 1.4.4
+
+namespace eval ::html {
+
+ # State about the current page
+
+ variable page
+
+ # A simple set of global defaults for tag parameters is implemented
+ # by storing into elements indexed by "key.param", where key is
+ # often the name of an HTML tag (anything for scoping), and
+ # param must be the name of the HTML tag parameter (e.g., "href" or "size")
+ # input.size
+ # body.bgcolor
+ # body.text
+ # font.face
+ # font.size
+ # font.color
+
+ variable defaults
+ array set defaults {
+ input.size 45
+ body.bgcolor white
+ body.text black
+ }
+
+ # In order to nandle nested calls to redefined control structures,
+ # we need a temporary variable that is known not to exist. We keep this
+ # counter to append to the varname. Each time we need a temporary
+ # variable, we increment this counter.
+
+ variable randVar 0
+
+ # No more export, because this defines things like
+ # foreach and if that do HTML things, not Tcl control
+ # namespace export *
+
+ # Dictionary mapping from special characters to their entities.
+
+ variable entities {
+ \xa0 &nbsp; \xa1 &iexcl; \xa2 &cent; \xa3 &pound; \xa4 &curren;
+ \xa5 &yen; \xa6 &brvbar; \xa7 &sect; \xa8 &uml; \xa9 &copy;
+ \xaa &ordf; \xab &laquo; \xac &not; \xad &shy; \xae &reg;
+ \xaf &macr; \xb0 &deg; \xb1 &plusmn; \xb2 &sup2; \xb3 &sup3;
+ \xb4 &acute; \xb5 &micro; \xb6 &para; \xb7 &middot; \xb8 &cedil;
+ \xb9 &sup1; \xba &ordm; \xbb &raquo; \xbc &frac14; \xbd &frac12;
+ \xbe &frac34; \xbf &iquest; \xc0 &Agrave; \xc1 &Aacute; \xc2 &Acirc;
+ \xc3 &Atilde; \xc4 &Auml; \xc5 &Aring; \xc6 &AElig; \xc7 &Ccedil;
+ \xc8 &Egrave; \xc9 &Eacute; \xca &Ecirc; \xcb &Euml; \xcc &Igrave;
+ \xcd &Iacute; \xce &Icirc; \xcf &Iuml; \xd0 &ETH; \xd1 &Ntilde;
+ \xd2 &Ograve; \xd3 &Oacute; \xd4 &Ocirc; \xd5 &Otilde; \xd6 &Ouml;
+ \xd7 &times; \xd8 &Oslash; \xd9 &Ugrave; \xda &Uacute; \xdb &Ucirc;
+ \xdc &Uuml; \xdd &Yacute; \xde &THORN; \xdf &szlig; \xe0 &agrave;
+ \xe1 &aacute; \xe2 &acirc; \xe3 &atilde; \xe4 &auml; \xe5 &aring;
+ \xe6 &aelig; \xe7 &ccedil; \xe8 &egrave; \xe9 &eacute; \xea &ecirc;
+ \xeb &euml; \xec &igrave; \xed &iacute; \xee &icirc; \xef &iuml;
+ \xf0 &eth; \xf1 &ntilde; \xf2 &ograve; \xf3 &oacute; \xf4 &ocirc;
+ \xf5 &otilde; \xf6 &ouml; \xf7 &divide; \xf8 &oslash; \xf9 &ugrave;
+ \xfa &uacute; \xfb &ucirc; \xfc &uuml; \xfd &yacute; \xfe &thorn;
+ \xff &yuml; \u192 &fnof; \u391 &Alpha; \u392 &Beta; \u393 &Gamma;
+ \u394 &Delta; \u395 &Epsilon; \u396 &Zeta; \u397 &Eta; \u398 &Theta;
+ \u399 &Iota; \u39A &Kappa; \u39B &Lambda; \u39C &Mu; \u39D &Nu;
+ \u39E &Xi; \u39F &Omicron; \u3A0 &Pi; \u3A1 &Rho; \u3A3 &Sigma;
+ \u3A4 &Tau; \u3A5 &Upsilon; \u3A6 &Phi; \u3A7 &Chi; \u3A8 &Psi;
+ \u3A9 &Omega; \u3B1 &alpha; \u3B2 &beta; \u3B3 &gamma; \u3B4 &delta;
+ \u3B5 &epsilon; \u3B6 &zeta; \u3B7 &eta; \u3B8 &theta; \u3B9 &iota;
+ \u3BA &kappa; \u3BB &lambda; \u3BC &mu; \u3BD &nu; \u3BE &xi;
+ \u3BF &omicron; \u3C0 &pi; \u3C1 &rho; \u3C2 &sigmaf; \u3C3 &sigma;
+ \u3C4 &tau; \u3C5 &upsilon; \u3C6 &phi; \u3C7 &chi; \u3C8 &psi;
+ \u3C9 &omega; \u3D1 &thetasym; \u3D2 &upsih; \u3D6 &piv;
+ \u2022 &bull; \u2026 &hellip; \u2032 &prime; \u2033 &Prime;
+ \u203E &oline; \u2044 &frasl; \u2118 &weierp; \u2111 &image;
+ \u211C &real; \u2122 &trade; \u2135 &alefsym; \u2190 &larr;
+ \u2191 &uarr; \u2192 &rarr; \u2193 &darr; \u2194 &harr; \u21B5 &crarr;
+ \u21D0 &lArr; \u21D1 &uArr; \u21D2 &rArr; \u21D3 &dArr; \u21D4 &hArr;
+ \u2200 &forall; \u2202 &part; \u2203 &exist; \u2205 &empty;
+ \u2207 &nabla; \u2208 &isin; \u2209 &notin; \u220B &ni; \u220F &prod;
+ \u2211 &sum; \u2212 &minus; \u2217 &lowast; \u221A &radic;
+ \u221D &prop; \u221E &infin; \u2220 &ang; \u2227 &and; \u2228 &or;
+ \u2229 &cap; \u222A &cup; \u222B &int; \u2234 &there4; \u223C &sim;
+ \u2245 &cong; \u2248 &asymp; \u2260 &ne; \u2261 &equiv; \u2264 &le;
+ \u2265 &ge; \u2282 &sub; \u2283 &sup; \u2284 &nsub; \u2286 &sube;
+ \u2287 &supe; \u2295 &oplus; \u2297 &otimes; \u22A5 &perp;
+ \u22C5 &sdot; \u2308 &lceil; \u2309 &rceil; \u230A &lfloor;
+ \u230B &rfloor; \u2329 &lang; \u232A &rang; \u25CA &loz;
+ \u2660 &spades; \u2663 &clubs; \u2665 &hearts; \u2666 &diams;
+ \x22 &quot; \x26 &amp; \x3C &lt; \x3E &gt; \u152 &OElig;
+ \u153 &oelig; \u160 &Scaron; \u161 &scaron; \u178 &Yuml;
+ \u2C6 &circ; \u2DC &tilde; \u2002 &ensp; \u2003 &emsp; \u2009 &thinsp;
+ \u200C &zwnj; \u200D &zwj; \u200E &lrm; \u200F &rlm; \u2013 &ndash;
+ \u2014 &mdash; \u2018 &lsquo; \u2019 &rsquo; \u201A &sbquo;
+ \u201C &ldquo; \u201D &rdquo; \u201E &bdquo; \u2020 &dagger;
+ \u2021 &Dagger; \u2030 &permil; \u2039 &lsaquo; \u203A &rsaquo;
+ \u20AC &euro;
+ }
+}
+
+# ::html::foreach
+#
+# Rework the "foreach" command to blend into HTML template files.
+# Rather than evaluating the body, we return the subst'ed body. Each
+# iteration of the loop causes another string to be concatenated to
+# the result value. No error checking is done on any arguments.
+#
+# Arguments:
+# varlist Variables to instantiate with values from the next argument.
+# list Values to set variables in varlist to.
+# args ?varlist2 list2 ...? body, where body is the string to subst
+# during each iteration of the loop.
+#
+# Results:
+# Returns a string composed of multiple concatenations of the
+# substitued body.
+#
+# Side Effects:
+# None.
+
+proc ::html::foreach {vars vals args} {
+ variable randVar
+
+ # The body of the foreach loop must be run in the stack frame
+ # above this one in order to have access to local variable at that stack
+ # level.
+
+ # To support nested foreach loops, we use a uniquely named
+ # variable to store incremental results.
+ incr randVar
+ ::set resultVar "result_$randVar"
+
+ # Extract the body and any varlists and valuelists from the args.
+ ::set body [lindex $args end]
+ ::set varvals [linsert [lreplace $args end end] 0 $vars $vals]
+
+ # Create the script to eval in the stack frame above this one.
+ ::set script "::foreach"
+ ::foreach {vars vals} $varvals {
+ append script " [list $vars] [list $vals]"
+ }
+ append script " \{\n"
+ append script " append $resultVar \[subst \{$body\}\]\n"
+ append script "\}\n"
+
+ # Create a temporary variable in the stack frame above this one,
+ # and use it to store the incremental results of the multiple loop
+ # iterations. Remove the temporary variable when we're done so there's
+ # no trace of this loop left in that stack frame.
+
+ upvar 1 $resultVar tmp
+ ::set tmp ""
+ uplevel 1 $script
+ ::set result $tmp
+ unset tmp
+ return $result
+}
+
+# ::html::for
+#
+# Rework the "for" command to blend into HTML template files.
+# Rather than evaluating the body, we return the subst'ed body. Each
+# iteration of the loop causes another string to be concatenated to
+# the result value. No error checking is done on any arguments.
+#
+# Arguments:
+# start A script to evaluate once at the very beginning.
+# test An expression to eval before each iteration of the loop.
+# Once the expression is false, the command returns.
+# next A script to evaluate after each iteration of the loop.
+# body The string to subst during each iteration of the loop.
+#
+# Results:
+# Returns a string composed of multiple concatenations of the
+# substitued body.
+#
+# Side Effects:
+# None.
+
+proc ::html::for {start test next body} {
+ variable randVar
+
+ # The body of the for loop must be run in the stack frame
+ # above this one in order to have access to local variable at that stack
+ # level.
+
+ # To support nested for loops, we use a uniquely named
+ # variable to store incremental results.
+ incr randVar
+ ::set resultVar "result_$randVar"
+
+ # Create the script to eval in the stack frame above this one.
+ ::set script "::for [list $start] [list $test] [list $next] \{\n"
+ append script " append $resultVar \[subst \{$body\}\]\n"
+ append script "\}\n"
+
+ # Create a temporary variable in the stack frame above this one,
+ # and use it to store the incremental resutls of the multiple loop
+ # iterations. Remove the temporary variable when we're done so there's
+ # no trace of this loop left in that stack frame.
+
+ upvar 1 $resultVar tmp
+ ::set tmp ""
+ uplevel 1 $script
+ ::set result $tmp
+ unset tmp
+ return $result
+}
+
+# ::html::while
+#
+# Rework the "while" command to blend into HTML template files.
+# Rather than evaluating the body, we return the subst'ed body. Each
+# iteration of the loop causes another string to be concatenated to
+# the result value. No error checking is done on any arguments.
+#
+# Arguments:
+# test An expression to eval before each iteration of the loop.
+# Once the expression is false, the command returns.
+# body The string to subst during each iteration of the loop.
+#
+# Results:
+# Returns a string composed of multiple concatenations of the
+# substitued body.
+#
+# Side Effects:
+# None.
+
+proc ::html::while {test body} {
+ variable randVar
+
+ # The body of the while loop must be run in the stack frame
+ # above this one in order to have access to local variable at that stack
+ # level.
+
+ # To support nested while loops, we use a uniquely named
+ # variable to store incremental results.
+ incr randVar
+ ::set resultVar "result_$randVar"
+
+ # Create the script to eval in the stack frame above this one.
+ ::set script "::while [list $test] \{\n"
+ append script " append $resultVar \[subst \{$body\}\]\n"
+ append script "\}\n"
+
+ # Create a temporary variable in the stack frame above this one,
+ # and use it to store the incremental resutls of the multiple loop
+ # iterations. Remove the temporary variable when we're done so there's
+ # no trace of this loop left in that stack frame.
+
+ upvar 1 $resultVar tmp
+ ::set tmp ""
+ uplevel 1 $script
+ ::set result $tmp
+ unset tmp
+ return $result
+}
+
+# ::html::if
+#
+# Rework the "if" command to blend into HTML template files.
+# Rather than evaluating a body clause, we return the subst'ed body.
+# No error checking is done on any arguments.
+#
+# Arguments:
+# test An expression to eval to decide whether to use the then body.
+# body The string to subst if the test case was true.
+# args ?elseif test body2 ...? ?else bodyn?, where bodyn is the string
+# to subst if none of the tests are true.
+#
+# Results:
+# Returns a string composed by substituting a body clause.
+#
+# Side Effects:
+# None.
+
+proc ::html::if {test body args} {
+ variable randVar
+
+ # The body of the then/else clause must be run in the stack frame
+ # above this one in order to have access to local variable at that stack
+ # level.
+
+ # To support nested if's, we use a uniquely named
+ # variable to store incremental results.
+ incr randVar
+ ::set resultVar "result_$randVar"
+
+ # Extract the elseif clauses and else clause if they exist.
+ ::set cmd [linsert $args 0 "::if" $test $body]
+
+ ::foreach {keyword test body} $cmd {
+ ::if {[string equal $keyword "else"]} {
+ append script " else \{\n"
+ ::set body $test
+ } else {
+ append script " $keyword [list $test] \{\n"
+ }
+ append script " append $resultVar \[subst \{$body\}\]\n"
+ append script "\} "
+ }
+
+ # Create a temporary variable in the stack frame above this one,
+ # and use it to store the incremental resutls of the multiple loop
+ # iterations. Remove the temporary variable when we're done so there's
+ # no trace of this loop left in that stack frame.
+
+ upvar $resultVar tmp
+ ::set tmp ""
+ uplevel $script
+ ::set result $tmp
+ unset tmp
+ return $result
+}
+
+# ::html::set
+#
+# Rework the "set" command to blend into HTML template files.
+# The return value is always "" so nothing is appended in the
+# template. No error checking is done on any arguments.
+#
+# Arguments:
+# var The variable to set.
+# val The new value to give the variable.
+#
+# Results:
+# Returns "".
+#
+# Side Effects:
+# None.
+
+proc ::html::set {var val} {
+
+ # The variable must be set in the stack frame above this one.
+
+ ::set cmd [list set $var $val]
+ uplevel 1 $cmd
+ return ""
+}
+
+# ::html::eval
+#
+# Rework the "eval" command to blend into HTML template files.
+# The return value is always "" so nothing is appended in the
+# template. No error checking is done on any arguments.
+#
+# Arguments:
+# args The args to evaluate. At least one must be given.
+#
+# Results:
+# Returns "".
+#
+# Side Effects:
+# Throws an error if no arguments are given.
+
+proc ::html::eval {args} {
+
+ # The args must be evaluated in the stack frame above this one.
+ ::eval [linsert $args 0 uplevel 1]
+ return ""
+}
+
+# ::html::init
+#
+# Reset state that gets accumulated for the current page.
+#
+# Arguments:
+# nvlist Name, value list that is used to initialize default namespace
+# variables that set font, size, etc.
+#
+# Side Effects:
+# Wipes the page state array
+
+proc ::html::init {{nvlist {}}} {
+ variable page
+ variable defaults
+ ::if {[info exists page]} {
+ unset page
+ }
+ ::if {[info exists defaults]} {
+ unset defaults
+ }
+ array set defaults $nvlist
+}
+
+# ::html::head
+#
+# Generate the <head> section. There are a number of
+# optional calls you make *before* this to inject
+# meta tags - see everything between here and the bodyTag proc.
+#
+# Arguments:
+# title The page title
+#
+# Results:
+# HTML for the <head> section
+
+proc ::html::head {title} {
+ variable page
+ ::set html "[openTag html][openTag head]\n"
+ append html "\t[title $title]"
+ ::if {[info exists page(author)]} {
+ append html "\t$page(author)"
+ }
+ ::if {[info exists page(meta)]} {
+ ::foreach line $page(meta) {
+ append html "\t$line\n"
+ }
+ }
+ ::if {[info exists page(css)]} {
+ ::foreach style $page(css) {
+ append html "\t$style\n"
+ }
+ }
+ ::if {[info exists page(js)]} {
+ ::foreach script $page(js) {
+ append html "\t$script\n"
+ }
+ }
+ append html "[closeTag]\n"
+}
+
+# ::html::title
+#
+# Wrap up the <title> and tuck it away for use in the page later.
+#
+# Arguments:
+# title The page title
+#
+# Results:
+# HTML for the <title> section
+
+proc ::html::title {title} {
+ variable page
+ ::set page(title) $title
+ ::set html "<title>$title</title>\n"
+ return $html
+}
+
+# ::html::getTitle
+#
+# Return the title of the current page.
+#
+# Arguments:
+# None
+#
+# Results:
+# The title
+
+proc ::html::getTitle {} {
+ variable page
+ ::if {[info exists page(title)]} {
+ return $page(title)
+ } else {
+ return ""
+ }
+}
+
+# ::html::meta
+#
+# Generate a meta tag. This tag gets bundled into the <head>
+# section generated by html::head
+#
+# Arguments:
+# args A name-value list of meta tag names and values.
+#
+# Side Effects:
+# Stores HTML for the <meta> tag for use later by html::head
+
+proc ::html::meta {args} {
+ variable page
+ ::set html ""
+ ::foreach {name value} $args {
+ append html "<meta name=\"$name\" content=\"[quoteFormValue $value]\">"
+ }
+ lappend page(meta) $html
+ return ""
+}
+
+# ::html::refresh
+#
+# Generate a meta refresh tag. This tag gets bundled into the <head>
+# section generated by html::head
+#
+# Arguments:
+# content Time period, in seconds, before the refresh
+# url (option) new page to view. If not specified, then
+# the current page is reloaded.
+#
+# Side Effects:
+# Stores HTML for the <meta> tag for use later by html::head
+
+proc ::html::refresh {content {url {}}} {
+ variable page
+ ::set html "<meta http-equiv=\"Refresh\" content=\"$content"
+ ::if {[string length $url]} {
+ append html "; url=$url"
+ }
+ append html "\">"
+ lappend page(meta) $html
+ return ""
+}
+
+# ::html::headTag
+#
+# Embed a tag into the HEAD section
+# generated by html::head
+#
+# Arguments:
+# string Everything but the < > for the tag.
+#
+# Side Effects:
+# Stores HTML for the tag for use later by html::head
+
+proc ::html::headTag {string} {
+ variable page
+ lappend page(meta) <$string>
+ return ""
+}
+
+# ::html::keywords
+#
+# Add META tag keywords to the <head> section.
+# Call this before you call html::head
+#
+# Arguments:
+# args The keywords
+#
+# Side Effects:
+# See html::meta
+
+proc ::html::keywords {args} {
+ html::meta keywords [join $args ", "]
+}
+
+# ::html::description
+#
+# Add a description META tag to the <head> section.
+# Call this before you call html::head
+#
+# Arguments:
+# description The description
+#
+# Side Effects:
+# See html::meta
+
+proc ::html::description {description} {
+ html::meta description $description
+}
+
+# ::html::author
+#
+# Add an author comment to the <head> section.
+# Call this before you call html::head
+#
+# Arguments:
+# author Author's name
+#
+# Side Effects:
+# sets page(author)
+
+proc ::html::author {author} {
+ variable page
+ ::set page(author) "<!-- $author -->\n"
+ return ""
+}
+
+# ::html::tagParam
+#
+# Return a name, value string for the tag parameters.
+# The values come from "hard-wired" values in the
+# param agrument, or from the defaults set with html::init.
+#
+# Arguments:
+# tag Name of the HTML tag (case insensitive).
+# param pname=value info that overrides any default values
+#
+# Results
+# A string of the form:
+# pname="keyvalue" name2="2nd value"
+
+proc ::html::tagParam {tag {param {}}} {
+ variable defaults
+
+ ::set def ""
+ ::foreach key [lsort [array names defaults $tag.*]] {
+ append def [default $key $param]
+ }
+ return [string trimleft $param$def]
+}
+
+# ::html::default
+#
+# Return a default value, if one has been registered
+# and an overriding value does not occur in the existing
+# tag parameters.
+#
+# Arguments:
+# key Index into the defaults array defined by html::init
+# This is expected to be in the form tag.pname where
+# the pname part is used in the tag parameter name
+# param pname=value info that overrides any default values
+#
+# Results
+# pname="keyvalue"
+
+proc ::html::default {key {param {}}} {
+ variable defaults
+ ::set pname [string tolower [lindex [split $key .] 1]]
+ ::set key [string tolower $key]
+ ::if {![regexp -nocase "(\[ \]|^)$pname=" $param] &&
+ [info exists defaults($key)] &&
+ [string length $defaults($key)]} {
+ return " $pname=\"$defaults($key)\""
+ } else {
+ return ""
+ }
+}
+
+# ::html::bodyTag
+#
+# Generate a body tag
+#
+# Arguments:
+# none
+#
+# Results
+# A body tag
+
+proc ::html::bodyTag {args} {
+ return [openTag body [join $args]]\n
+}
+
+# The following procedures are all related to generating form elements
+# that are initialized to store the current value of the form element
+# based on the CGI state. These functions depend on the ncgi::value
+# procedure and assume that the caller has called ncgi::parse and/or
+# ncgi::init appropriately to initialize the ncgi module.
+
+# ::html::formValue
+#
+# Return a name and value pair, where the value is initialized
+# from existing form data, if any.
+#
+# Arguments:
+# name The name of the form element
+# defvalue A default value to use, if not appears in the CGI
+# inputs. DEPRECATED - use ncgi::defValue instead.
+#
+# Retults:
+# A string like:
+# name="fred" value="freds value"
+
+proc ::html::formValue {name {defvalue {}}} {
+ ::set value [ncgi::value $name]
+ ::if {[string length $value] == 0} {
+ ::set value $defvalue
+ }
+ return "name=\"$name\" value=\"[quoteFormValue $value]\""
+}
+
+# ::html::quoteFormValue
+#
+# Quote a value for use in a value=\"$value\" fragment.
+#
+# Arguments:
+# value The value to quote
+#
+# Retults:
+# A string like:
+# &#34;Hello, &lt;b&gt;World!&#34;
+
+proc ::html::quoteFormValue {value} {
+ return [string map [list "&" "&amp;" "\"" "&#34;" \
+ "'" "&#39;" "<" "&lt;" ">" "&gt;"] $value]
+}
+
+# ::html::textInput --
+#
+# Return an <input type=text> element. This uses the
+# input.size default falue.
+#
+# Arguments:
+# name The form element name
+# args Additional attributes for the INPUT tag
+#
+# Results:
+# The html fragment
+
+proc ::html::textInput {name {value {}} args} {
+ ::set html "<input type=\"text\" "
+ append html [formValue $name $value]
+ append html [default input.size $args]
+ ::if {[llength $args] != 0} then {
+ append html " " [join $args]
+ }
+ append html ">\n"
+ return $html
+}
+
+# ::html::textInputRow --
+#
+# Format a table row containing a text input element and a label.
+#
+# Arguments:
+# label Label to display next to the form element
+# name The form element name
+# args Additional attributes for the INPUT tag
+#
+# Results:
+# The html fragment
+
+proc ::html::textInputRow {label name {value {}} args} {
+ ::set html [row $label [::eval [linsert $args 0 html::textInput $name $value]]]
+ return $html
+}
+
+# ::html::passwordInputRow --
+#
+# Format a table row containing a password input element and a label.
+#
+# Arguments:
+# label Label to display next to the form element
+# name The form element name
+#
+# Results:
+# The html fragment
+
+proc ::html::passwordInputRow {label {name password}} {
+ ::set html [row $label [passwordInput $name]]
+ return $html
+}
+
+# ::html::passwordInput --
+#
+# Return an <input type=password> element.
+#
+# Arguments:
+# name The form element name. Defaults to "password"
+#
+# Results:
+# The html fragment
+
+proc ::html::passwordInput {{name password}} {
+ ::set html "<input type=\"password\" name=\"$name\">\n"
+ return $html
+}
+
+# ::html::checkbox --
+#
+# Format a checkbox so that it retains its state based on
+# the current CGI values
+#
+# Arguments:
+# name The form element name
+# value The value associated with the checkbox
+#
+# Results:
+# The html fragment
+
+proc ::html::checkbox {name value} {
+ ::set html "<input type=\"checkbox\" [checkValue $name $value]>\n"
+}
+
+# ::html::checkValue
+#
+# Like html::formalue, but for checkboxes that need CHECKED
+#
+# Arguments:
+# name The name of the form element
+# defvalue A default value to use, if not appears in the CGI
+# inputs
+#
+# Retults:
+# A string like:
+# name="fred" value="freds value" CHECKED
+
+
+proc ::html::checkValue {name {value 1}} {
+ ::foreach v [ncgi::valueList $name] {
+ ::if {[string compare $value $v] == 0} {
+ return "name=\"$name\" value=\"[quoteFormValue $value]\" checked"
+ }
+ }
+ return "name=\"$name\" value=\"[quoteFormValue $value]\""
+}
+
+# ::html::radioValue
+#
+# Like html::formValue, but for radioboxes that need CHECKED
+#
+# Arguments:
+# name The name of the form element
+# value The value associated with the radio button.
+#
+# Retults:
+# A string like:
+# name="fred" value="freds value" CHECKED
+
+proc ::html::radioValue {name value {defaultSelection {}}} {
+ ::if {[string equal $value [ncgi::value $name $defaultSelection]]} {
+ return "name=\"$name\" value=\"[quoteFormValue $value]\" checked"
+ } else {
+ return "name=\"$name\" value=\"[quoteFormValue $value]\""
+ }
+}
+
+# ::html::radioSet --
+#
+# Display a set of radio buttons while looking for an existing
+# value from the query data, if any.
+
+proc ::html::radioSet {key sep list {defaultSelection {}}} {
+ ::set html ""
+ ::set s ""
+ ::foreach {label v} $list {
+ append html "$s<input type=\"radio\" [radioValue $key $v $defaultSelection]> $label"
+ ::set s $sep
+ }
+ return $html
+}
+
+# ::html::checkSet --
+#
+# Display a set of check buttons while looking for an existing
+# value from the query data, if any.
+
+proc ::html::checkSet {key sep list} {
+ ::set s ""
+ ::foreach {label v} $list {
+ append html "$s<input type=\"checkbox\" [checkValue $key $v]> $label"
+ ::set s $sep
+ }
+ return $html
+}
+
+# ::html::select --
+#
+# Format a <select> element that retains the state of the
+# current CGI values.
+#
+# Arguments:
+# name The form element name
+# param The various size, multiple parameters for the tag
+# choices A simple list of choices
+# current Value to assume if nothing is in CGI state
+#
+# Results:
+# The html fragment
+
+proc ::html::select {name param choices {current {}}} {
+ ::set def [ncgi::valueList $name $current]
+ ::set html "<select name=\"$name\"[string trimright " $param"]>\n"
+ ::foreach {label v} $choices {
+ ::if {[lsearch -exact $def $v] != -1} {
+ ::set SEL " selected"
+ } else {
+ ::set SEL ""
+ }
+ append html "<option value=\"$v\"$SEL>$label\n"
+ }
+ append html "</select>\n"
+ return $html
+}
+
+# ::html::selectPlain --
+#
+# Format a <select> element where the values are the same
+# as those that are displayed.
+#
+# Arguments:
+# name The form element name
+# param Tag parameters
+# choices A simple list of choices
+#
+# Results:
+# The html fragment
+
+proc ::html::selectPlain {name param choices {current {}}} {
+ ::set namevalue {}
+ ::foreach c $choices {
+ lappend namevalue $c $c
+ }
+ return [select $name $param $namevalue $current]
+}
+
+# ::html::textarea --
+#
+# Format a <textarea> element that retains the state of the
+# current CGI values.
+#
+# Arguments:
+# name The form element name
+# param The various size, multiple parameters for the tag
+# current Value to assume if nothing is in CGI state
+#
+# Results:
+# The html fragment
+
+proc ::html::textarea {name {param {}} {current {}}} {
+ ::set value [quoteFormValue [ncgi::value $name $current]]
+ return "<[string trimright \
+ "textarea name=\"$name\"\
+ [tagParam textarea $param]"]>$value</textarea>\n"
+}
+
+# ::html::submit --
+#
+# Format a submit button.
+#
+# Arguments:
+# label The string to appear in the submit button.
+# name The name for the submit button element
+#
+# Results:
+# The html fragment
+
+
+proc ::html::submit {label {name submit}} {
+ ::set html "<input type=\"submit\" name=\"$name\" value=\"$label\">\n"
+}
+
+# ::html::varEmpty --
+#
+# Return true if the variable doesn't exist or is an empty string
+#
+# Arguments:
+# varname Name of the variable
+#
+# Results:
+# 1 if the variable doesn't exist or has the empty value
+
+proc ::html::varEmpty {name} {
+ upvar 1 $name var
+ ::if {[info exists var]} {
+ ::set value $var
+ } else {
+ ::set value ""
+ }
+ return [expr {[string length [string trim $value]] == 0}]
+}
+
+# ::html::getFormInfo --
+#
+# Generate hidden fields to capture form values.
+#
+# Arguments:
+# args List of elements to save. If this is empty, everything is
+# saved in hidden fields. This is a list of string match
+# patterns.
+#
+# Results:
+# A bunch of <input type=hidden> elements
+
+proc ::html::getFormInfo {args} {
+ ::if {[llength $args] == 0} {
+ ::set args *
+ }
+ ::set html ""
+ ::foreach {n v} [ncgi::nvlist] {
+ ::foreach pat $args {
+ ::if {[string match $pat $n]} {
+ append html "<input type=\"hidden\" name=\"$n\" \
+ value=\"[quoteFormValue $v]\">\n"
+ }
+ }
+ }
+ return $html
+}
+
+# ::html::h1
+# Generate an H1 tag.
+#
+# Arguments:
+# string
+# param
+#
+# Results:
+# Formats the tag.
+
+proc ::html::h1 {string {param {}}} {
+ html::h 1 $string $param
+}
+proc ::html::h2 {string {param {}}} {
+ html::h 2 $string $param
+}
+proc ::html::h3 {string {param {}}} {
+ html::h 3 $string $param
+}
+proc ::html::h4 {string {param {}}} {
+ html::h 4 $string $param
+}
+proc ::html::h5 {string {param {}}} {
+ html::h 5 $string $param
+}
+proc ::html::h6 {string {param {}}} {
+ html::h 6 $string $param
+}
+proc ::html::h {level string {param {}}} {
+ return "<[string trimright "h$level [tagParam h$level $param]"]>$string</h$level>\n"
+}
+
+# ::html::openTag
+# Remember that a tag is opened so it can be closed later.
+# This is used to automatically clean up at the end of a page.
+#
+# Arguments:
+# tag The HTML tag name
+# param Any parameters for the tag
+#
+# Results:
+# Formats the tag. Also keeps it around in a per-page stack
+# of open tags.
+
+proc ::html::openTag {tag {param {}}} {
+ variable page
+ lappend page(stack) $tag
+ return "<[string trimright "$tag [tagParam $tag $param]"]>"
+}
+
+# ::html::closeTag
+# Pop a tag from the stack and close it.
+#
+# Arguments:
+# None
+#
+# Results:
+# A close tag. Also pops the stack.
+
+proc ::html::closeTag {} {
+ variable page
+ ::if {[info exists page(stack)]} {
+ ::set top [lindex $page(stack) end]
+ ::set page(stack) [lreplace $page(stack) end end]
+ }
+ ::if {[info exists top] && [string length $top]} {
+ return </$top>
+ } else {
+ return ""
+ }
+}
+
+# ::html::end
+#
+# Close out all the open tags. Especially useful for
+# Tables that do not display at all if they are unclosed.
+#
+# Arguments:
+# None
+#
+# Results:
+# Some number of close HTML tags.
+
+proc ::html::end {} {
+ variable page
+ ::set html ""
+ ::while {[llength $page(stack)]} {
+ append html [closeTag]\n
+ }
+ return $html
+}
+
+# ::html::row
+#
+# Format a table row. If the default font has been set, this
+# takes care of wrapping the table cell contents in a font tag.
+#
+# Arguments:
+# args Values to put into the row
+#
+# Results:
+# A <tr><td>...</tr> fragment
+
+proc ::html::row {args} {
+ ::set html <tr>\n
+ ::foreach x $args {
+ append html \t[cell "" $x td]\n
+ }
+ append html "</tr>\n"
+ return $html
+}
+
+# ::html::hdrRow
+#
+# Format a table row. If the default font has been set, this
+# takes care of wrapping the table cell contents in a font tag.
+#
+# Arguments:
+# args Values to put into the row
+#
+# Results:
+# A <tr><th>...</tr> fragment
+
+proc ::html::hdrRow {args} {
+ variable defaults
+ ::set html <tr>\n
+ ::foreach x $args {
+ append html \t[cell "" $x th]\n
+ }
+ append html "</tr>\n"
+ return $html
+}
+
+# ::html::paramRow
+#
+# Format a table row. If the default font has been set, this
+# takes care of wrapping the table cell contents in a font tag.
+#
+# Based on html::row
+#
+# Arguments:
+# list Values to put into the row
+# rparam Parameters for row
+# cparam Parameters for cells
+#
+# Results:
+# A <tr><td>...</tr> fragment
+
+proc ::html::paramRow {list {rparam {}} {cparam {}}} {
+ ::set html "<tr $rparam>\n"
+ ::foreach x $list {
+ append html \t[cell $cparam $x td]\n
+ }
+ append html "</tr>\n"
+ return $html
+}
+
+# ::html::cell
+#
+# Format a table cell. If the default font has been set, this
+# takes care of wrapping the table cell contents in a font tag.
+#
+# Arguments:
+# param Td tag parameters
+# value The value to put into the cell
+# tag (option) defaults to TD
+#
+# Results:
+# <td>...</td> fragment
+
+proc ::html::cell {param value {tag td}} {
+ ::set font [font]
+ ::if {[string length $font]} {
+ ::set value $font$value</font>
+ }
+ return "<[string trimright "$tag $param"]>$value</$tag>"
+}
+
+# ::html::tableFromArray
+#
+# Format a Tcl array into an HTML table
+#
+# Arguments:
+# arrname The name of the array
+# param The <table> tag parameters, if any.
+# pat A string match pattern for the element keys
+#
+# Results:
+# A <table>
+
+proc ::html::tableFromArray {arrname {param {}} {pat *}} {
+ upvar 1 $arrname arr
+ ::set html ""
+ ::if {[info exists arr]} {
+ append html "<table $param>\n"
+ append html "<tr><th colspan=2>$arrname</th></tr>\n"
+ ::foreach name [lsort [array names arr $pat]] {
+ append html [row $name $arr($name)]
+ }
+ append html </table>\n
+ }
+ return $html
+}
+
+# ::html::tableFromList
+#
+# Format a table from a name, value list
+#
+# Arguments:
+# querylist A name, value list
+# param The <table> tag parameters, if any.
+#
+# Results:
+# A <table>
+
+proc ::html::tableFromList {querylist {param {}}} {
+ ::set html ""
+ ::if {[llength $querylist]} {
+ append html "<table $param>"
+ ::foreach {label value} $querylist {
+ append html [row $label $value]
+ }
+ append html </table>
+ }
+ return $html
+}
+
+# ::html::mailto
+#
+# Format a mailto: HREF tag
+#
+# Arguments:
+# email The target
+# subject The subject of the email, if any
+#
+# Results:
+# A <a href=mailto> tag </a>
+
+proc ::html::mailto {email {subject {}}} {
+ ::set html "<a href=\"mailto:$email"
+ ::if {[string length $subject]} {
+ append html ?subject=$subject
+ }
+ append html "\">$email</a>"
+ return $html
+}
+
+# ::html::font
+#
+# Generate a standard <font> tag. This depends on defaults being
+# set via html::init
+#
+# Arguments:
+# args Font parameters.
+#
+# Results:
+# HTML
+
+proc ::html::font {args} {
+
+ # e.g., font.face, font.size, font.color
+ ::set param [tagParam font [join $args]]
+
+ ::if {[string length $param]} {
+ return "<[string trimright "font $param"]>"
+ } else {
+ return ""
+ }
+}
+
+# ::html::minorMenu
+#
+# Create a menu of links given a list of label, URL pairs.
+# If the URL is the current page, it is not highlighted.
+#
+# Arguments:
+#
+# list List that alternates label, url, label, url
+# sep Separator between elements
+#
+# Results:
+# html
+
+proc ::html::minorMenu {list {sep { | }}} {
+ ::set s ""
+ ::set html ""
+ regsub -- {index.h?tml$} [ncgi::urlStub] {} this
+ ::foreach {label url} $list {
+ regsub -- {index.h?tml$} $url {} that
+ ::if {[string compare $this $that] == 0} {
+ append html "$s$label"
+ } else {
+ append html "$s<a href=\"$url\">$label</a>"
+ }
+ ::set s $sep
+ }
+ return $html
+}
+
+# ::html::minorList
+#
+# Create a list of links given a list of label, URL pairs.
+# If the URL is the current page, it is not highlighted.
+#
+# Based on html::minorMenu
+#
+# Arguments:
+#
+# list List that alternates label, url, label, url
+# ordered Boolean flag to choose between ordered and
+# unordered lists. Defaults to 0, i.e. unordered.
+#
+# Results:
+# A <ul><li><a...><\li>.....<\ul> fragment
+# or a <ol><li><a...><\li>.....<\ol> fragment
+
+proc ::html::minorList {list {ordered 0}} {
+ ::set s ""
+ ::set html ""
+ ::if { $ordered } {
+ append html [openTag ol]
+ } else {
+ append html [openTag ul]
+ }
+ regsub -- {index.h?tml$} [ncgi::urlStub] {} this
+ ::foreach {label url} $list {
+ append html [openTag li]
+ regsub -- {index.h?tml$} $url {} that
+ ::if {[string compare $this $that] == 0} {
+ append html "$s$label"
+ } else {
+ append html "$s<a href=\"$url\">$label</a>"
+ }
+ append html [closeTag]
+ append html \n
+ }
+ append html [closeTag]
+ return $html
+}
+
+# ::html::extractParam
+#
+# Extract a value from parameter list (this needs a re-do)
+#
+# Arguments:
+# param A parameter list. It should alredy have been processed to
+# remove any entity references
+# key The parameter name
+# varName The variable to put the value into (use key as default)
+#
+# Results:
+# returns "1" if the keyword is found, "0" otherwise
+
+proc ::html::extractParam {param key {varName ""}} {
+ ::if {$varName == ""} {
+ upvar $key result
+ } else {
+ upvar $varName result
+ }
+ ::set ws " \t\n\r"
+
+ # look for name=value combinations. Either (') or (") are valid delimeters
+ ::if {
+ [regsub -nocase [format {.*%s[%s]*=[%s]*"([^"]*).*} $key $ws $ws] $param {\1} value] ||
+ [regsub -nocase [format {.*%s[%s]*=[%s]*'([^']*).*} $key $ws $ws] $param {\1} value] ||
+ [regsub -nocase [format {.*%s[%s]*=[%s]*([^%s]+).*} $key $ws $ws $ws] $param {\1} value] } {
+ ::set result $value
+ return 1
+ }
+
+ # now look for valueless names
+ # I should strip out name=value pairs, so we don't end up with "name"
+ # inside the "value" part of some other key word - some day
+
+ ::set bad \[^a-zA-Z\]+
+ ::if {[regexp -nocase "$bad$key$bad" -$param-]} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# ::html::urlParent --
+# This is like "file dirname", but doesn't screw with the slashes
+# (file dirname will collapse // into /)
+#
+# Arguments:
+# url The URL
+#
+# Results:
+# The parent directory of the URL.
+
+proc ::html::urlParent {url} {
+ ::set url [string trimright $url /]
+ regsub -- {[^/]+$} $url {} url
+ return $url
+}
+
+# ::html::html_entities --
+# Replaces all special characters in the text with their
+# entities.
+#
+# Arguments:
+# s The near-HTML text
+#
+# Results:
+# The text with entities in place of specials characters.
+
+proc ::html::html_entities {s} {
+ variable entities
+ return [string map $entities $s]
+}
+
+# ::html::nl2br --
+# Replaces all line-endings in the text with <br> tags.
+#
+# Arguments:
+# s The near-HTML text
+#
+# Results:
+# The text with <br> in place of line-endings.
+
+proc ::html::nl2br {s} {
+ return [string map [list \n\r <br> \r\n <br> \n <br> \r <br>] $s]
+}
+
+# ::html::doctype
+# Create the DOCTYPE tag and tuck it away for usage
+#
+# Arguments:
+# arg The DOCTYPE you want to declare
+#
+# Results:
+# HTML for the doctype section
+
+proc ::html::doctype {arg} {
+ variable doctypes
+ ::set code [string toupper $arg]
+ ::if {![info exists doctypes($code)]} {
+ return -code error -errorcode {HTML DOCTYPE BAD} \
+ "Unknown doctype \"$arg\""
+ }
+ return $doctypes($code)
+}
+
+namespace eval ::html {
+ variable doctypes
+ array set doctypes {
+ HTML32 {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN">}
+ HTML40 {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN" "http://www.w3.org/TR/REC-html40/strict.dtd">}
+ HTML40T {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">}
+ HTML40F {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Frameset//EN" "http://www.w3.org/TR/REC-html40/frameset.dtd">}
+ HTML401 {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">}
+ HTML401T {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">}
+ HTML401F {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Frameset//EN" "http://www.w3.org/TR/html4/frameset.dtd">}
+ XHTML10S {<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">}
+ XHTML10T {<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">}
+ XHTML10F {<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd">}
+ XHTML11 {<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">}
+ XHTMLB {<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML Basic 1.0//EN" "http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd">}
+ }
+}
+
+# ::html::css
+# Create the text/css tag and tuck it away for usage
+#
+# Arguments:
+# href The location of the css file to include the filename and path
+#
+# Results:
+# None.
+
+proc ::html::css {href} {
+ variable page
+ lappend page(css) "<link rel=\"stylesheet\" type=\"text/css\" href=\"[quoteFormValue $href]\">"
+ return
+}
+
+# ::html::css-clear
+# Drop all text/css references.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc ::html::css-clear {} {
+ variable page
+ catch { unset page(css) }
+ return
+}
+
+# ::html::js
+# Create the text/javascript tag and tuck it away for usage
+#
+# Arguments:
+# href The location of the javascript file to include the filename and path
+#
+# Results:
+# None.
+
+proc ::html::js {href} {
+ variable page
+ lappend page(js) "<script language=\"javascript\" type=\"text/javascript\" src=\"[quoteFormValue $href]\"></script>"
+ return
+}
+
+# ::html::js-clear
+# Drop all text/javascript references.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc ::html::js-clear {} {
+ variable page
+ catch { unset page(js) }
+ return
+}
diff --git a/tcllib/modules/html/html.test b/tcllib/modules/html/html.test
new file mode 100644
index 0000000..6646fb6
--- /dev/null
+++ b/tcllib/modules/html/html.test
@@ -0,0 +1,958 @@
+# -*- tcl -*- Tests for the html module.
+#
+# This file contains a collection of tests for a module in the
+# Standard Tcl Library. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2006 Michael Schlenker <mic42@users.sourceforge.net>
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: html.test,v 1.23 2006/10/09 21:41:40 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+testing {
+ useLocal html.tcl html
+}
+
+# -------------------------------------------------------------------------
+
+test html-1.1 {html::init} -body {
+ html::init
+ list \
+ [array exists html::defaults] \
+ [array size html::defaults] \
+ [info exists html::page]
+} -result {1 0 0}
+
+test html-1.2 {html::init} -body {
+ html::init {
+ font.face arial
+ body.bgcolor white
+ body.text black
+ }
+ lsort [array names html::defaults]
+} -result {body.bgcolor body.text font.face}
+
+test html-1.3 {html::init, too many args} -body {
+ html::init wrong num args
+} -returnCodes error -result {wrong # args: should be "html::init ?nvlist?"}
+
+test html-1.4 {html::init, bad arg, odd-length list} -body {
+ html::init {wrong num args}
+} -returnCodes error -result {list must have an even number of elements}
+
+test html-2.1 {html::head, not enough args} -body {
+ html::head
+} -returnCodes error -result {wrong # args: should be "html::head title"}
+
+test html-2.2 {html::head} -body {
+ html::head "The Title"
+} -result "<html><head>\n\t<title>The Title</title>\n</head>\n"
+
+test html-2.3 {html::head} -body {
+ html::description "The Description"
+ html::keywords key word
+ html::author "Cathy Coder"
+ html::meta metakey metavalue
+ html::head "The Title"
+} -result {<html><head>
+ <title>The Title</title>
+ <!-- Cathy Coder -->
+ <meta name="description" content="The Description">
+ <meta name="keywords" content="key, word">
+ <meta name="metakey" content="metavalue">
+</head>
+}
+
+test html-3.1 {html::title, not enough args} -body {
+ html::title
+} -returnCodes error -result {wrong # args: should be "html::title title"}
+
+test html-3.2 {html::title} -body {
+ html::title "blah blah"
+} -result "<title>blah blah</title>\n"
+
+test html-4.1 {html::getTitle} -body {
+ html::init
+ html::getTitle
+} -result ""
+
+test html-4.2 {html::getTitle} -body {
+ html::init
+ html::title "blah blah"
+ html::getTitle
+} -result {blah blah}
+
+test html-5.1 {html::meta} {
+ html::init
+ html::meta one two
+} {}
+
+test html-5.2 {html::meta} {
+ html::init
+ html::meta one two
+ lindex $html::page(meta) 0
+} {<meta name="one" content="two">}
+
+test html-5.3 {html::meta} {
+ html::init
+ html::meta one {"one val"}
+ lindex $html::page(meta) 0
+} {<meta name="one" content="&#34;one val&#34;">}
+
+test html-6.1 {html::keywords} {
+ html::init
+ html::keywords one two
+} {}
+
+test html-6.2 {html::keywords} {
+ html::init
+ html::keywords one two
+ lindex $html::page(meta) 0
+} {<meta name="keywords" content="one, two">}
+
+test html-6.3 {html::keywords} {
+ html::init
+ html::keywords one {"one val"} &
+ lindex $html::page(meta) 0
+} {<meta name="keywords" content="one, &#34;one val&#34;, &amp;">}
+
+test html-7.1 {html::description} {
+ html::init
+ html::description "This is the description."
+} {}
+
+test html-7.2 {html::description} {
+ html::init
+ html::description "This is the description."
+ lindex $html::page(meta) 0
+} {<meta name="description" content="This is the description.">}
+
+test html-7.3 {html::description} {
+ html::init
+ html::description {one "one val" &}
+ lindex $html::page(meta) 0
+} {<meta name="description" content="one &#34;one val&#34; &amp;">}
+
+test html-8.1 {html::author} {
+ html::init
+ html::author "This is the author."
+} {}
+
+test html-8.2 {html::author} {
+ html::init
+ html::author "This is the author."
+ set html::page(author)
+} {<!-- This is the author. -->
+}
+
+test html-8.3 {html::author} {
+ html::init
+ html::author {one "one val" &}
+ set html::page(author)
+} {<!-- one "one val" & -->
+}
+
+test html-9.0 {html::tagParams} {
+ html::init {
+ body.bgcolor red
+ font.face times
+ }
+ html::tagParam font color="red"
+} {color="red" face="times"}
+
+test html-9.1 {html::default} {
+ html::init {
+ body.bgcolor red
+ font.face times
+ }
+ html::default xyzzy
+} {}
+
+test html-9.2 {html::default} {
+ html::init {
+ body.bgcolor red
+ font.face times
+ }
+ html::default body.bgcolor
+} { bgcolor="red"}
+
+test html-9.3 {html::default} {
+ html::init {
+ body.bgcolor red
+ font.face times
+ }
+ html::default font.face "face=arial"
+} {}
+
+test html-9.4 {html::default} {
+ html::init {
+ body.bgcolor red
+ font.face times
+ }
+ html::default font.face "color=blue size=1"
+} { face="times"}
+
+test html-10.1 {html::bodyTag} {
+ html::init
+ html::bodyTag
+} {<body>
+}
+
+test html-10.2 {html::bodyTag} {
+ html::init {
+ body.bgcolor white
+ body.text black
+ }
+ html::bodyTag
+} {<body bgcolor="white" text="black">
+}
+
+test html-10.3 {html::bodyTag} {
+ html::init {
+ body.bgcolor white
+ body.text black
+ }
+ html::bodyTag "text=red"
+} {<body text=red bgcolor="white">
+}
+
+test html-11.1 {html::formValue} {
+ ncgi::reset name=value
+ ncgi::parse
+ html::formValue name
+} {name="name" value="value"}
+
+test html-11.2 {html::formValue} {
+ ncgi::reset name=value
+ ncgi::parse
+ html::formValue name2
+} {name="name2" value=""}
+
+test html-11.3 {html::formValue} {
+ ncgi::reset "name=one+value&name2=%7e"
+ ncgi::parse
+ html::formValue name2
+} {name="name2" value="~"}
+
+test html-12.1 {html::quoteFormValue} {
+ html::quoteFormValue name2
+} {name2}
+
+test html-12.2 {html::quoteFormValue} {
+ html::quoteFormValue {"name2"}
+} {&#34;name2&#34;}
+
+test html-12.3 {html::quoteFormValue} {
+ html::quoteFormValue {"'><&} ;# need a " for balance
+} {&#34;&#39;&gt;&lt;&amp;}
+
+test html-12.4 {html::quoteFormValue} {
+ html::quoteFormValue "This is the value."
+} {This is the value.}
+
+test html-13.1 {html::textInput} {
+ html::init
+ ncgi::reset
+ ncgi::parse
+ html::textInput email
+} {<input type="text" name="email" value="">
+}
+
+test html-13.2 {html::textInput} {
+ html::init
+ ncgi::reset email=welch@scriptics.com
+ ncgi::parse
+ html::textInput email
+} {<input type="text" name="email" value="welch@scriptics.com">
+}
+
+test html-13.3 {html::textInput} {
+ html::init {
+ input.size 30
+ }
+ ncgi::reset
+ ncgi::parse
+ html::textInput email
+} {<input type="text" name="email" value="" size="30">
+}
+
+test html-13.4 {html::textInput} {
+ html::init {
+ input.size 30
+ }
+ ncgi::reset
+ ncgi::parse
+ html::textInput email default@foo.com
+} {<input type="text" name="email" value="default@foo.com" size="30">
+}
+
+test html-13.5 {html::textInput} {
+ html::init
+ ncgi::reset email=welch@scriptics.com
+ ncgi::parse
+ html::textInput email value=default@foo.com
+} {<input type="text" name="email" value="welch@scriptics.com">
+}
+
+test html-13.6 {html::textInput} {
+ html::init
+ ncgi::reset
+ ncgi::parse
+ html::textInput email default@foo.com size="80"
+} {<input type="text" name="email" value="default@foo.com" size="80">
+}
+
+test html-13.7 {html::textInput} {
+ html::init {
+ input.size 30
+ }
+ ncgi::reset
+ ncgi::parse
+ html::textInput email default@foo.com size="80"
+} {<input type="text" name="email" value="default@foo.com" size="80">
+}
+
+test html-14.1 {html::textInputRow} {
+ html::init
+ ncgi::reset email=welch@scriptics.com
+ ncgi::parse
+ html::textInputRow Email email
+} {<tr>
+ <td>Email</td>
+ <td><input type="text" name="email" value="welch@scriptics.com">
+</td>
+</tr>
+}
+
+test html-15.1 {html::passwordInput} {
+ html::passwordInput
+} {<input type="password" name="password">
+}
+
+test html-15.2 {html::passwordInput} {
+ html::passwordInput form_pass
+} {<input type="password" name="form_pass">
+}
+
+test html-16.1 {html::checkbox} {
+ ncgi::reset email=welch@scriptics.com
+ ncgi::parse
+ html::checkbox item value
+} {<input type="checkbox" name="item" value="value">
+}
+
+test html-16.2 {html::checkbox} {
+ ncgi::reset email=welch@scriptics.com
+ ncgi::parse
+ html::checkbox email value
+} {<input type="checkbox" name="email" value="value">
+}
+
+test html-17.1 {html::checkValue} {
+ ncgi::reset item=xyz
+ ncgi::parse
+ html::checkbox item xyz
+} {<input type="checkbox" name="item" value="xyz" checked>
+}
+
+test html-18.1 {html::radioValue} {
+ ncgi::reset item=xyz
+ ncgi::parse
+ html::radioValue item xyz
+} {name="item" value="xyz" checked}
+
+test html-19.1 {html::radioSet} {
+ ncgi::reset item=2
+ ncgi::parse
+ html::radioSet item " |\n" {
+ One 1
+ Two 2
+ Three 3
+ }
+} {<input type="radio" name="item" value="1"> One |
+<input type="radio" name="item" value="2" checked> Two |
+<input type="radio" name="item" value="3"> Three}
+
+test html-20.1 {html::checkSet} {
+ ncgi::reset item=2&item=3+4&x=y
+ ncgi::parse
+ html::checkSet item " |\n" {
+ One 1
+ Two 2
+ Three {3 4}
+ }
+} {<input type="checkbox" name="item" value="1"> One |
+<input type="checkbox" name="item" value="2" checked> Two |
+<input type="checkbox" name="item" value="3 4" checked> Three}
+
+test html-21.1 {html::select} {
+ ncgi::reset item=2&x=y
+ ncgi::parse
+ html::select item "multiple" {
+ One 1
+ Two 2
+ Three {3 4}
+ }
+} {<select name="item" multiple>
+<option value="1">One
+<option value="2" selected>Two
+<option value="3 4">Three
+</select>
+}
+
+test html-22.1 {html::selectPlain} {
+ ncgi::reset item=Three
+ ncgi::parse
+ html::selectPlain item "" {
+ One Two Three
+ }
+} {<select name="item">
+<option value="One">One
+<option value="Two">Two
+<option value="Three" selected>Three
+</select>
+}
+
+test html-22.2 {html::selectPlain} {
+ ncgi::reset item=Three
+ ncgi::parse
+ html::selectPlain another "" {
+ One Two Three
+ } One
+} {<select name="another">
+<option value="One" selected>One
+<option value="Two">Two
+<option value="Three">Three
+</select>
+}
+
+test html-23.1 {html::textarea} {
+ ncgi::reset item=Three
+ ncgi::parse
+ html::textarea info
+} {<textarea name="info"></textarea>
+}
+test html-23.2 {html::textarea} {
+ html::init {
+ textarea.cols 50
+ textarea.rows 8
+ }
+ ncgi::reset info=[ncgi::encode "The textarea value."]
+ ncgi::parse
+ html::textarea info
+} {<textarea name="info" cols="50" rows="8">The textarea value.</textarea>
+}
+
+test html-23.3 {html::textarea, dangerous input} {
+ html::init {
+ textarea.cols 50
+ textarea.rows 8
+ }
+ ncgi::reset info=[ncgi::encode "</textarea><script>alert(1)</script>"]
+ ncgi::parse
+ html::textarea info
+} {<textarea name="info" cols="50" rows="8">&lt;/textarea&gt;&lt;script&gt;alert(1)&lt;/script&gt;</textarea>
+}
+
+
+test html-24.1 {html::submit} {
+ catch {html::submit}
+} {1}
+
+test html-24.2 {html::submit} {
+ catch {html::submit wrong num args}
+} {1}
+
+test html-24.3 {html::submit} {
+ html::submit "Push Me"
+} {<input type="submit" name="submit" value="Push Me">
+}
+
+test html-24.4 {html::submit} {
+ html::submit "Push Me" push
+} {<input type="submit" name="push" value="Push Me">
+}
+
+test html-25.1 {html::varEmpty} {
+ catch {html::varEmpty}
+} 1
+test html-25.2 {html::varEmpty} {
+ catch {html::varEmpty wrong num args}
+} 1
+
+test html-25.3 {html::varEmpty} {
+ if {[info exist x]} {
+ unset x
+ }
+ html::varEmpty x
+} 1
+test html-25.4 {html::varEmpty} {
+ if {[info exist x]} {
+ unset x
+ }
+ set x ""
+ html::varEmpty x
+} 1
+
+test html-25.5 {html::varEmpty} {
+ if {[info exist x]} {
+ unset x
+ }
+ set x "foo"
+ html::varEmpty x
+} 0
+
+test html-26.1 {html::refresh} {
+ catch {html::refresh}
+} 1
+test html-26.2 {html::refresh} {
+ catch {html::refresh wrong num args}
+} 1
+test html-26.3 {html::refresh} {
+ html::refresh 4
+} {}
+test html-26.4 {html::refresh} {
+ html::init
+ html::refresh 4
+ html::head title
+} {<html><head>
+ <title>title</title>
+ <meta http-equiv="Refresh" content="4">
+</head>
+}
+test html-26.5 {html::refresh} {
+ html::init
+ html::refresh 9 http://www.scriptics.com
+ html::head title
+} {<html><head>
+ <title>title</title>
+ <meta http-equiv="Refresh" content="9; url=http://www.scriptics.com">
+</head>
+}
+
+test html-27.1 {html::foreach--1 var, 1 iteration} {
+ html::foreach x {a} {<td>$x</td>}
+} {<td>a</td>}
+
+test html-27.2 {html::foreach--1 var, multiple iterations} {
+ html::foreach x {a b} {<td>$x</td>}
+} {<td>a</td><td>b</td>}
+
+test html-27.3 {html::foreach--1 var, 0 iterations} {
+ html::foreach x {} {<td>$x</td>}
+} {}
+
+test html-27.4 {html::foreach--multiple vars, 1 iteration} {
+ html::foreach {x y} {a b} {<td>$x</td><td>$y</td>}
+} {<td>a</td><td>b</td>}
+
+test html-27.5 {html::foreach--multiple vars, multiple iterations} {
+ html::foreach {x y} {a b c d} {<td>$x</td><td>$y</td>}
+} {<td>a</td><td>b</td><td>c</td><td>d</td>}
+
+test html-27.6 {html::foreach--multiple varlists and vallists} {
+ html::foreach {a b} {1 2 3 4} {c d} {5 6 7 8} {e f} {9 10 11 12} {
+ $a$b$c$d$e$f}
+} {
+ 1256910
+ 34781112}
+
+test html-27.7 {html::foreach--subst body w/ vars and procs} {
+ html::foreach x {2 8} {<td>$x</td><td>[incr x]</td>}
+} {<td>2</td><td>3</td><td>8</td><td>9</td>}
+
+test html-27.8 {html::foreach--subst body w/ nested foreach} {
+ html::foreach x {a b} {
+ [html::foreach y {c d} {$x$y}]
+ }
+} {
+ acad
+
+ bcbd
+ }
+
+test html-27.9 {html::foreach--subst body w/ multiple nested foreach's} {
+ html::foreach x {a b} {
+ [html::foreach y {c d} {$x$y
+ [html::foreach z {e f} {$z}]
+ }]}
+} {
+ ac
+ ef
+ ad
+ ef
+
+ bc
+ ef
+ bd
+ ef
+ }
+
+test html-28.1 {html::for--1 iteration} {
+ html::for {set i 0} {$i < 1} {incr i} {<td>$i</td>}
+} {<td>0</td>}
+
+test html-28.2 {html::for--multiple iterations} {
+ html::for {set i 0} {$i < 3} {incr i} {<td>$i</td>}
+} {<td>0</td><td>1</td><td>2</td>}
+
+test html-28.3 {html::for--0 iterations} {
+ html::for {set i 0} {$i < 0} {incr i} {<td>$i</td>}
+} {}
+
+test html-28.4 {html::for--complex start, text, and next} {
+ html::for {set i 0; set j 10} {$i < 1 && $j < 11} {incr i; incr j} {$i $j}
+} {0 10}
+
+test html-28.5 {html::for--subst body w/ vars and procs} {
+ html::for {set i 0} {$i < 3} {incr i} {$i [expr {$i + 5}] }
+} {0 5 1 6 2 7 }
+
+test html-28.6 {html::for--subst body w/ nested for} {
+ set result [html::for {set i 0} {$i < 3} {incr i} {
+ [html::for {set j $i} {$j < 3} {incr j} {${i}__${j} }]
+ }]
+ regsub -all "\n" $result " " result
+ regsub -all " +" $result " " result
+ set result
+} { 0__0 0__1 0__2 1__1 1__2 2__2 }
+
+test html-28.7 {html::for--subst body w/ multiple nested for's} {
+ set result [html::for {set i 0} {$i < 3} {incr i} {
+ [html::for {set j $i} {$j < 3} {incr j} {
+ [html::for {set k $j} {$k < 3} {incr k} {${i}__${j}__${k} }]
+ }]
+ }]
+ regsub -all "\n" $result " " result
+ regsub -all " +" $result " " result
+ set result
+} { 0__0__0 0__0__1 0__0__2 0__1__1 0__1__2 0__2__2 1__1__1 1__1__2 1__2__2 2__2__2 }
+
+test html-29.1 {html::while--1 iteration} {
+ set i 0
+ html::while {$i < 1} {<td>$i, [incr i]</td>}
+} {<td>0, 1</td>}
+
+test html-29.2 {html::while--multiple iterations} {
+ set i 0
+ html::while {$i < 3} {<td>$i, [incr i]</td>}
+} {<td>0, 1</td><td>1, 2</td><td>2, 3</td>}
+
+test html-29.3 {html::while--0 iterations} {
+ set i 0
+ html::while {$i < 0} {<td>$i</td>}
+} {}
+
+test html-29.4 {html::while--complex start, text, and next} {
+ set i 0
+ set j 10
+ html::while {$i < 1 && $j < 11} {$i $j, [incr i] [incr j]}
+} {0 10, 1 11}
+
+test html-29.5 {html::while--subst body w/ nested while} {
+ set i 0
+ set result [html::while {$i < 3} {
+ [set j $i]
+ [html::while {$j < 3} {
+ ${i}__${j}
+ [incr j]
+ }]
+ [incr i]
+ }]
+ regsub -all "\n" $result " " result
+ regsub -all " +" $result " " result
+ set result
+} { 0 0__0 1 0__1 2 0__2 3 1 1 1__1 2 1__2 3 2 2 2__2 3 3 }
+
+test html-29.7 {html::while--subst body w/ multiple nested while's} {
+ set i 0
+ set result [html::while {$i < 3} {
+ [set j $i]
+ [html::while {$j != 3} {
+ [set k $j]
+ [html::while {$k != 3} {
+ ${i}__${j}__${k}
+ [incr k]
+ }]
+ [incr j]
+ }]
+ [incr i]
+ }]
+ regsub -all "\n" $result " " result
+ regsub -all " +" $result " " result
+ set result
+} { 0 0 0__0__0 1 0__0__1 2 0__0__2 3 1 1 0__1__1 2 0__1__2 3 2 2 0__2__2 3 3 1 1 1 1__1__1 2 1__1__2 3 2 2 1__2__2 3 3 2 2 2 2__2__2 3 3 3 }
+
+test html-30.1 {html::if--eval then clause} {
+ set i 0
+ html::if {$i < 1} {$i, [incr i]}
+} {0, 1}
+
+test html-30.2 {html::if--don't eval then clause} {
+ set i 0
+ html::if {$i == 1} {$i, [incr i]}
+} {}
+
+test html-30.3 {html::if--eval else clause} {
+ set i 0
+ html::if {$i == 1} {then clause} else {$i, [incr i]}
+} {0, 1}
+
+test html-30.4 {html::if--1 elseif clause, eval else cause} {
+ set i 0
+ html::if {$i < 0} {
+ then clause
+ } elseif {$i == 1} {
+ elseif clause
+ } else {$i, [incr i]}
+} {0, 1}
+
+test html-30.5 {html::if--1 elseif clause, eval elseif cause} {
+ set i 0
+ html::if {$i < 0} {
+ then clause
+ } elseif {$i == 0} {$i, [incr i]}
+} {0, 1}
+
+test html-30.6 {html::if--1 elseif clause, eval elseif cause} {
+ set i 0
+ html::if {$i < 0} {
+ then clause
+ } elseif {$i == 1} {
+ $i, [incr i]
+ }
+} {}
+
+test html-30.7 {html::if--1 elseif clause, eval elseif cause} {
+ set i 0
+ html::if {$i < 0} {
+ then clause
+ } elseif {$i == 0} {$i, [incr i]} else {
+ else clause
+ }
+} {0, 1}
+
+test html-30.8 {html::if--1 elseif clause, eval elseif cause} {
+ set i 0
+ html::if {$i < 0} {
+ then clause
+ } elseif {$i == 1} {
+ elseif1 clause
+ } elseif {$i == 0} {$i, [incr i]} elseif {$i == 2} {
+ elseif3 clause
+ } else {
+ else clause
+ }
+} {0, 1}
+
+test html-30.9 {html::if--1 elseif clause, eval elseif cause} {
+ set i 0
+ html::if {$i < 0} {
+ then clause
+ } elseif {$i == 1} {
+ elseif3 clause
+ } elseif {$i == 2} {
+ elseif1 clause
+ } elseif {$i == 0} {$i, [incr i]} else {
+ else clause
+ }
+} {0, 1}
+
+test html-30.10 {html::if--multiple nested} {
+ set i 0
+ set result [html::if {$i < 1} {
+ begin1
+ [html::if {$i > -1} {
+ begin2
+ [html::if {$i == 0} {
+ begin3
+ [html::if {$i} {4}]
+ end3
+ }]
+ end2
+ }]
+ end1
+ }]
+ regsub -all "\n" $result " " result
+ regsub -all " +" $result " " result
+ set result
+} { begin1 begin2 begin3 end3 end2 end1 }
+
+test html-31.1 {html::set--set a new variable} {
+ set result [html::set x 1]
+ list $result $x
+} {{} 1}
+
+test html-31.2 {html::set--set an existing variable} {
+ set x 0
+ set result [html::set x 1]
+ list $result $x
+} {{} 1}
+
+test html-32.1 {single argument} {
+ set x 0
+ set result [html::eval {set x [format 22]}]
+ list $result $x
+} {{} 22}
+
+test html-32.2 {multiple arguments} {
+ set a {$b}
+ set b xyzzy
+ set x 0
+ set result [html::eval {set x [eval format $a]}]
+ list $result $x
+} {{} xyzzy}
+
+test html-32.3 {single argument} {
+ set x [list]
+ set y 1
+ set result [html::eval lappend x a b c d {$y} e f g]
+ list $result $x
+} {{} {a b c d 1 e f g}}
+
+test html-32.4 {error: not enough arguments} -body {
+ html::eval
+} -returnCodes error -result {wrong # args: should be "uplevel ?level? command ?arg ...?"}
+
+test html-32.6 {error in eval'ed command} -body {
+ html::eval {error "test error"}
+} -returnCodes error -result {test error}
+
+test html-33.0 {html::font} -body {
+ html::font
+} -result {}
+
+test html-33.1 {html::font} -body {
+ html::font size=18
+} -result {<font size=18>}
+
+test html-34.0 {html::nl2br} -body {
+ html::nl2br "a\n\rb\nc\rd"
+} -result {a<br>b<br>c<br>d}
+
+test html-34.1 {html::nl2br, ticket 1742078} -body {
+ html::nl2br "a\r\nb"
+} -result {a<br>b}
+
+# -------------------------------------------------------------------------
+
+test html-tkt3439702-35.0 {html::css, not enough arguments} -body {
+ html::css
+} -returnCodes error -result {wrong # args: should be "html::css href"}
+
+test html-tkt3439702-35.1 {html::css, too many arguments} -body {
+ html::css REF X
+} -returnCodes error -result {wrong # args: should be "html::css href"}
+
+test html-tkt3439702-35.2 {html::css, single ref} -setup {
+ html::css-clear
+} -body {
+ html::css "http://test.css"
+ string trim [html::head T]
+} -cleanup {
+ html::css-clear
+} -result "<html><head>\n\t<title>T</title>\n\t<meta http-equiv=\"Refresh\" content=\"9; url=http://www.scriptics.com\">\n\t<link rel=\"stylesheet\" type=\"text/css\" href=\"http://test.css\">\n</head>"
+
+test html-tkt3439702-35.3 {html::css, multiple ref} -setup {
+ html::css-clear
+} -body {
+ html::css "http://test1.css"
+ html::css "http://test2.css"
+ string trim [html::head T]
+} -cleanup {
+ html::css-clear
+} -result {<html><head>
+ <title>T</title>
+ <meta http-equiv="Refresh" content="9; url=http://www.scriptics.com">
+ <link rel="stylesheet" type="text/css" href="http://test1.css">
+ <link rel="stylesheet" type="text/css" href="http://test2.css">
+</head>}
+
+# -------------------------------------------------------------------------
+
+test html-tkt3439702-36.0 {html::js, not enough arguments} -body {
+ html::js
+} -returnCodes error -result {wrong # args: should be "html::js href"}
+
+test html-tkt3439702-36.1 {html::js, too many arguments} -body {
+ html::js REF X
+} -returnCodes error -result {wrong # args: should be "html::js href"}
+
+test html-tkt3439702-36.2 {html::js, single ref} -setup {
+ html::js-clear
+} -body {
+ html::js "http://test.js"
+ string trim [html::head T]
+} -cleanup {
+ html::js-clear
+} -result {<html><head>
+ <title>T</title>
+ <meta http-equiv="Refresh" content="9; url=http://www.scriptics.com">
+ <script language="javascript" type="text/javascript" src="http://test.js"></script>
+</head>}
+
+test html-tkt3439702-36.3 {html::js, multiple ref} -setup {
+ html::js-clear
+} -body {
+ html::js "http://test1.js"
+ html::js "http://test2.js"
+ string trim [html::head T]
+} -cleanup {
+ html::js-clear
+} -result {<html><head>
+ <title>T</title>
+ <meta http-equiv="Refresh" content="9; url=http://www.scriptics.com">
+ <script language="javascript" type="text/javascript" src="http://test1.js"></script>
+ <script language="javascript" type="text/javascript" src="http://test2.js"></script>
+</head>}
+
+test html-tkt3439702-37.0 {html::js, html::css, mixed} -setup {
+ html::css-clear
+ html::js-clear
+} -body {
+ html::css "http://test.css"
+ html::js "http://test.js"
+ string trim [html::head T]
+} -cleanup {
+ html::js-clear
+ html::css-clear
+} -result {<html><head>
+ <title>T</title>
+ <meta http-equiv="Refresh" content="9; url=http://www.scriptics.com">
+ <link rel="stylesheet" type="text/css" href="http://test.css">
+ <script language="javascript" type="text/javascript" src="http://test.js"></script>
+</head>}
+
+# -------------------------------------------------------------------------
+# TODO: html::css-clear, html::js-clear
+
+
+test html-tktafe4366e2e-38.0 {html::doctype, not enough args} -body {
+ html::doctype
+} -returnCodes error -result {wrong # args: should be "html::doctype arg"}
+
+test html-tktafe4366e2e-38.1 {html::doctype, too many args} -body {
+ html::doctype HTML401T X
+} -returnCodes error -result {wrong # args: should be "html::doctype arg"}
+
+test html-tktafe4366e2e-38.2 {html::doctype, unknown type} -body {
+ html::doctype HTML401TXXX
+} -returnCodes error -result {Unknown doctype "HTML401TXXX"}
+
+test html-tktafe4366e2e-38.3 {html::doctype} -body {
+ html::doctype HTML401T
+} -result {<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">}
+
+# -------------------------------------------------------------------------
+testsuiteCleanup
diff --git a/tcllib/modules/html/pkgIndex.tcl b/tcllib/modules/html/pkgIndex.tcl
new file mode 100644
index 0000000..9d91097
--- /dev/null
+++ b/tcllib/modules/html/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded html 1.4.4 [list source [file join $dir html.tcl]]
diff --git a/tcllib/modules/htmlparse/ChangeLog b/tcllib/modules/htmlparse/ChangeLog
new file mode 100644
index 0000000..352e2cb
--- /dev/null
+++ b/tcllib/modules/htmlparse/ChangeLog
@@ -0,0 +1,321 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2012-08-02 Andreas Kupries <andreask@activestate.com>
+
+ * htmlparse.tcl: [Bug 3553350]: Fixed bad handling of characters
+ special to regsub in the callback. Bumped version to 1.2.1.
+ * htmlparse.test: New test case for the above.
+ * htmlparse.man: Bumped version number.
+ * pkgIndex.tcl: Bumped version number.
+ Thanks to Jeff Rogers <dvrsn@users.sourceforge.net> for the
+ report.
+
+ * htmlparse.tcl: [Bug 2941841]: Fixed bad handling of broken html.
+ * htmlparse.test: New test cases for the above.
+ Thanks to Jeff Rogers <dvrsn@users.sourceforge.net> for the
+ report and fix.
+
+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 ========================
+ *
+
+2009-02-10 Andreas Kupries <andreask@activestate.com>
+
+ * htmlparse.tcl (::htmlparse::parse): Replaced the backslashed
+ * htmlparse.man: placeholder \\win\\ with the more regular @win@,
+ * htmlparse.text: to prevent quoting horrors. This fixes Glenn
+ * pkgIndex.tcl: Jackman's [SF Tcllib Bug 2586112]. Bumped the
+ package version to 1.2.
+
+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 ========================
+ *
+
+2008-07-28 Andreas Kupries <andreask@activestate.com>
+
+ * htmlparse.tcl (mapEscapes): Extended to handle the XHML/XML
+ * htmlparse.test: entity apos (apostrophe). Extended the
+ * htmlparse.man: testsuite. This fixes [Bug 2028993]. Bumped
+ * pkgIndex.tcl: package version to 1.1.3.
+
+2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * htmlparse.pcx: New file. Syntax definitions for the public
+ commands of the htmlparse package.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-01 Andreas Kupries <andreask@activestate.com>
+
+ * htmlparse.test: Updated to use the TestAccel utility commands to
+ handle accelerators.
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * htmlparse.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-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * htmlparse.man: Bumped version to 1.1.2
+ * htmlparse.tcl:
+ * pkgIndex.tcl:
+
+2006-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * htmlparse.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * htmlparse.test: Hooked into the new common test support code.
+
+2006-01-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * htmlparse.tree_testsuite: Made the helper command reordering the
+ * htmlparse.tcl: tree a bit less agressive. See [SF
+ Tcllib Patch 953854]. Advice by Ramon Ribo. Updated the
+ testsuite as well.
+
+2006-01-10 Andreas Kupries <andreask@activestate.com>
+
+ * htmlparse.test: Fixed [SF Tcllib Bug 1316049]. Uncluttering test
+ output.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-10-06 Andreas Kupries <andreask@activestate.com>
+
+ * htmlparse.test: Reworked to use all available implementations of
+ struct::tree. Moved all tests using it into a separate file.
+
+ * htmlparse.tree_testsuite: New file. Now contains all the tests
+ using struct::tree.
+
+2005-01-11 Andreas Kupries <andreask@activestate.com>
+
+ * htmlparse.tcl: Modified to load only the data structure we need,
+ stacks, and not all eleven. This fixes the Tcllib SF Bug
+ 1087173, reported by Don Porter <dgp@users.sourceforge.net>.
+
+ * htmlparse.test: Ensured usage of local packages, nothing
+ installed, and updated for the new struct usage. Updated to
+ fixes in cmdline.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-10-04 Andreas Kupries <andreask@activestate.com>
+
+ * htmlparse.tcl (::htmlparse::PrepareHtml): Refixed the [Tcllib SF
+ * htmlparse.test: Bug 861277]. This came back because of the
+ changes to entity processing for [Tcllib SF Bug 1018574]. We are
+ now using standard numeric entities to protect these special
+ characters, instead of nonstandard entities. Extended the test
+ suite to cover this. Thanks to Joe English for the catch.
+
+2004-10-04 Joe English <jenglish@users.sourceforge.net>
+
+ * htmlparse.tcl(DoDecMap): Make sure numeric character references
+ are interpreted as decimal (Bug #1039961).
+ * htmlparse.test: Added test case.
+
+2004-09-29 Andreas Kupries <andreask@activestate.com>
+
+ * htmlparse.test: Fixed [Tcllib SF Bug 1034580], see also
+ * htmlparse.tcl: [Tcllib SF Bug 900041]. Thanks to Georgios
+ Petasis <petasis@users.sourceforge.net> for the report and
+ proposed solution. While the solution was not used as-is, it
+ gave enough clues to make writing the actual solution
+ trivial. It converts <tag attr /> to <tag attr></tag>. Added
+ testcases.
+
+2004-09-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * htmlparse.tcl (PrepareHtml): Fixed processing of comments
+ [Tcllib SF Bug 861287]. A legal end of comment is allowed to
+ have whitespace between '--' and '>'. Also recognize <-- as
+ bogus start of a comment (Should be <!-- to be legal). Convert
+ this to entities, making the bogus comment a PCDATA section
+ which shows up in the when a browser renders the document.
+
+2004-09-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * htmlparse.test: Another patch coming from [Tcllib SF Bug
+ 1018574]. Extended htmlparse-4.2 for better checking of &amp
+ handling.
+
+2004-09-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * htmlparse.tcl: Accepted patch by David Graveraux fixing a number
+ of problems with HTML entities.
+ This fixes [Tcllib SF Bug 1018574].
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * htmlparse.tcl: When changing the 'walk' method of 'struct::tree'
+ * htmlparse.test: adaption of this module was forgotten. Fixed.
+ Also fixed problem with usage of 8.3'ism in 'mapEscapes.
+
+2003-12-16 Joe English <jenglish@users.sourceforge.net>
+
+ * htmlparse.tcl: Fix for bug #861277 (backslashes in content)
+ * htmlparse.test: Added test case.
+
+2003-10-24 Andreas Kupries <andreask@activestate.com>
+
+ * htmlparse.tcl: Applied [Patch 823346] by Michael Schlenker
+ <mic42@users.sourceforge.net>. Cleans the code up a bit, using
+ faster string ops in place of regexes and -subs, where possible.
+
+2003-10-21 Andreas Kupries <andreask@activestate.com>
+
+ * htmlparse.man: Extended documentation of command '2tree' with
+ description of how the found tags and text is stored in the
+ nodes of the tree [Bug 827645].
+
+2003-08-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl:
+ * htmlparse.test:
+ * htmlparse.man:
+ * htmlparse.tcl: Updated to use struct v2 when handling trees
+ (Different way of accessing attributes). Bumped version number
+ up to the next major version (1.0) for this incompatible change.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * htmlparse.tcl:
+ * htmlparse.man:
+ * pkgIndex.tcl: Set version of the package to to 0.3.1.
+
+2003-03-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * htmlparse.test: Added htmlparse-3.4 to exercise the fix.
+ * htmlparse.tcl (::htmlparse::parse): Fixed bug #640932, reported
+ by Scott Goodwin <scottg@users.sourceforge.net>. Cause of the
+ bug: Incomplete tags were correctly detected and stored for the
+ next call, but incorrectly not used in said next call.
+
+2003-02-24 David N. Welton <davidw@dedasys.com>
+
+ * htmlparse.tcl (::htmlparse::PrepareHtml): Use string map instead
+ of regsub.
+
+2003-02-07 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * htmlparse.tcl (::htmlparse::mapEscapes): Fixed typo (strimg ->
+ string) to pass test suite.
+
+2003-02-05 David N. Welton <davidw@dedasys.com>
+
+ * htmlparse.tcl (::htmlparse::mapEscapes): Use string match
+ instead of regexp. Feature [ 676536 ].
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * htmlparse.man: More semantic markup, less visual one.
+
+2002-08-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * htmlparse.tcl: Fixed SF bug #579853. Added an 'bsl' key and
+ value to 'htmlparse::escapes' required to reconvert the
+ backslash escapes inserted by 'htmlparse::PrepareHtml'. Thanks
+ to Michael Cleverly <cleverly@users.sourceforge.net> for the
+ report.
+
+2002-06-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl:
+ * htmlparse.tcl:
+ * htmlparse.n:
+ * htmlparse.man: Bumped to version 0.3.
+
+2002-02-09 David N. Welton <davidw@dedasys.com>
+
+ * htmlparse.n: Cleaned up some of the language in the man page.
+
+2001-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * htmlparse.tcl: Frink 2.2 run, fixed dubious code.
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * htmlparse.tcl: Fixed dubious code reported by frink.
+
+2001-03-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * htmlparse.tcl: Changed the implementation to allow incremental
+ processing (taken from plume, in essence). Interface is
+ different too (more option oriented). Fixed errors in the
+ conversion into a tree (nesting of <p>, <li> and <hxx> tags),
+ through an internal postproessing step for the tree..
+
+ * htmlparse.n: Adapted documentstion to changes above.
+ * htmlparse.test: Created testsuite.
+
+2001-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module 'htmlparse', a HTML parser based upon Steve Uhler's
+ venerable 'html_library' and some of my work in the book
+ scanning project.
diff --git a/tcllib/modules/htmlparse/htmlparse.man b/tcllib/modules/htmlparse/htmlparse.man
new file mode 100644
index 0000000..fa4910f
--- /dev/null
+++ b/tcllib/modules/htmlparse/htmlparse.man
@@ -0,0 +1,266 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset VERSION 1.2.2]
+[manpage_begin htmlparse n [vset VERSION]]
+[see_also struct::tree]
+[keywords html]
+[keywords parsing]
+[keywords queue]
+[keywords tree]
+[moddesc {HTML Parser}]
+[titledesc {Procedures to parse HTML strings}]
+[category {Text processing}]
+[require Tcl 8.2]
+[require struct::stack 1.3]
+[require cmdline 1.1]
+[require htmlparse [opt [vset VERSION]]]
+[description]
+[para]
+
+The [package htmlparse] package provides commands that allow libraries
+and applications to parse HTML in a string into a representation of
+their choice.
+
+[para]
+The following commands are available:
+
+[list_begin definitions]
+
+[call [cmd ::htmlparse::parse] [opt "-cmd [arg cmd]"] [opt "-vroot [arg tag]"] [opt "-split [arg n]"] [opt "-incvar [arg var]"] [opt "-queue [arg q]"] [arg html]]
+
+This command is the basic parser for HTML. It takes an HTML string,
+parses it and invokes a command prefix for every tag encountered. It
+is not necessary for the HTML to be valid for this parser to
+function. It is the responsibility of the command invoked for every
+tag to check this. Another responsibility of the invoked command is
+the handling of tag attributes and character entities (escaped
+characters). The parser provides the un-interpreted tag attributes to
+the invoked command to aid in the former, and the package at large
+provides a helper command, [cmd ::htmlparse::mapEscapes], to aid in
+the handling of the latter. The parser [emph does] ignore leading
+DOCTYPE declarations and all valid HTML comments it encounters.
+
+[para]
+
+All information beyond the HTML string itself is specified via
+options, these are explained below.
+
+[para]
+
+To help understand the options, some more background information about
+the parser.
+
+[para]
+
+It is capable of detecting incomplete tags in the HTML string given to
+it. Under normal circumstances this will cause the parser to throw an
+error, but if the option [arg -incvar] is used to specify a global (or
+namespace) variable, the parser will store the incomplete part of the
+input into this variable instead. This will aid greatly in the
+handling of incrementally arriving HTML, as the parser will handle
+whatever it can and defer the handling of the incomplete part until
+more data has arrived.
+
+[para]
+
+Another feature of the parser are its two possible modes of
+operation. The normal mode is activated if the option [arg -queue] is
+not present on the command line invoking the parser. If it is present,
+the parser will go into the incremental mode instead.
+
+[para]
+
+The main difference is that a parser in normal mode will immediately
+invoke the command prefix for each tag it encounters. In incremental
+mode however the parser will generate a number of scripts which invoke
+the command prefix for groups of tags in the HTML string and then
+store these scripts in the specified queue. It is then the
+responsibility of the caller of the parser to ensure the execution of
+the scripts in the queue.
+
+[para]
+
+[emph Note]: The queue object given to the parser has to provide the
+same interface as the queue defined in tcllib -> struct. This means,
+for example, that all queues created via that tcllib module can be
+immediately used here. Still, the queue doesn't have to come from
+tcllib -> struct as long as the same interface is provided.
+
+[para]
+In both modes the parser will return an empty string to the caller.
+
+[para]
+The [arg -split] option may be given to a parser in incremental mode to
+specify the size of the groups it creates. In other words, -split 5
+means that each of the generated scripts will invoke the command
+prefix for 5 consecutive tags in the HTML string. A parser in normal
+mode will ignore this option and its value.
+
+[para]
+The option [arg -vroot] specifies a virtual root tag. A parser in
+normal mode will invoke the command prefix for it immediately before
+and after it processes the tags in the HTML, thus simulating that the
+HTML string is enclosed in a <vroot> </vroot> combination. In
+incremental mode however the parser is unable to provide the closing
+virtual root as it never knows when the input is complete. In this
+case the first script generated by each invocation of the parser will
+contain an invocation of the command prefix for the virtual root as
+its first command.
+
+The following options are available:
+
+[list_begin definitions]
+
+[def "[option -cmd] [arg cmd]"]
+
+The command prefix to invoke for every tag in the HTML
+string. Defaults to [arg ::htmlparse::debugCallback].
+
+[def "[option -vroot] [arg tag]"]
+
+The virtual root tag to add around the HTML in normal mode. In
+incremental mode it is the first tag in each chunk processed by the
+parser, but there will be no closing tags. Defaults to
+[arg hmstart].
+
+[def "[option -split] [arg n]"]
+
+The size of the groups produced by an incremental mode parser. Ignored
+when in normal mode. Defaults to 10. Values <= 0 are not allowed.
+
+[def "[option -incvar] [arg var]"]
+
+The name of the variable where to store any incomplete HTML into. This
+makes most sense for the incremental mode. The parser will throw an
+error if it sees incomplete HTML and has no place to store it to. This
+makes sense for the normal mode. Only incomplete tags are detected,
+not missing tags. Optional, defaults to 'no variable'.
+
+[list_end]
+
+[list_begin definitions]
+[para]
+[def [emph "Interface to the command prefix"]]
+
+In normal mode the parser will invoke the command prefix with four
+arguments appended. See [cmd ::htmlparse::debugCallback] for a
+description.
+
+[para]
+
+In incremental mode, however, the generated scripts will invoke the
+command prefix with five arguments appended. The last four of these
+are the same which were mentioned above. The first is a placeholder
+string ([const "@win@"]) for a clientdata value to be supplied later
+during the actual execution of the generated scripts. This could be a
+tk window path, for example. This allows the user of this package to
+preprocess HTML strings without committing them to a specific window,
+object, whatever during parsing. This connection can be made
+later. This also means that it is possible to cache preprocessed
+HTML. Of course, nothing prevents the user of the parser from
+replacing the placeholder with an empty string.
+
+[list_end]
+
+[call [cmd ::htmlparse::debugCallback] [opt [arg clientdata]] [arg "tag slash param textBehindTheTag"]]
+
+This command is the standard callback used by the parser in
+
+[cmd ::htmlparse::parse] if none was specified by the user. It simply
+dumps its arguments to stdout. This callback can be used for both
+normal and incremental mode of the calling parser. In other words, it
+accepts four or five arguments. The last four arguments are described
+below. The optional fifth argument contains the clientdata value
+passed to the callback by a parser in incremental mode. All callbacks
+have to follow the signature of this command in the last four
+arguments, and callbacks used in incremental parsing have to follow
+this signature in the last five arguments.
+
+[para]
+
+The first argument, [arg clientdata], is optional and present only if
+this command is invoked by a parser in incremental mode. It contains
+whatever the user of this package wishes.
+
+[para]
+
+The second argument, [arg tag], contains the name of the tag which is
+currently processed by the parser.
+
+[para]
+
+The third argument, [arg slash], is either empty or contains a slash
+character. It allows the callback to distinguish between opening
+(slash is empty) and closing tags (slash contains a slash character).
+
+[para]
+
+The fourth argument, [arg param], contains the un-interpreted list of
+parameters to the tag.
+
+[para]
+
+The fifth and last argument, [arg textBehindTheTag], contains the text
+found by the parser behind the tag named in [arg tag].
+
+[call [cmd ::htmlparse::mapEscapes] [arg html]]
+
+This command takes a HTML string, substitutes all escape sequences
+with their actual characters and then returns the resulting string.
+HTML strings which do not contain escape sequences are returned
+unchanged.
+
+[call [cmd ::htmlparse::2tree] [arg {html tree}]]
+
+This command is a wrapper around [cmd ::htmlparse::parse] which takes
+an HTML string (in [arg html]) and converts it into a tree containing
+the logical structure of the parsed document. The name of the tree is
+given to the command as its second argument ([arg tree]). The command
+does [cmd not] generate the tree by itself but expects that the caller
+provided it with an existing and empty tree. It also expects that the
+specified tree object follows the same interface as the tree object in
+tcllib -> struct. It doesn't have to be from tcllib -> struct, but it
+must provide the same interface.
+
+[para]
+
+The internal callback does some basic checking of HTML validity and
+tries to recover from the most basic errors. The command returns the
+contents of its second argument. Side effects are the creation and
+manipulation of a tree object.
+
+[para]
+
+Each node in the generated tree represent one tag in the input. The
+name of the tag is stored in the attribute [emph type] of the
+node. Any html attributes coming with the tag are stored unmodified in
+the attribute [emph data] of the tag. In other words, the command does
+[emph not] parse html attributes into their names and values.
+
+[para]
+
+If a tag contains text its node will have children of type
+[emph PCDATA] containing this text. The text will be stored in the
+attribute [emph data] of these children.
+
+[call [cmd ::htmlparse::removeVisualFluff] [arg tree]]
+
+This command walks a tree as generated by [cmd ::htmlparse::2tree] and
+removes all the nodes which represent visual tags and not structural
+ones. The purpose of the command is to make the tree easier to
+navigate without getting bogged down in visual information not
+relevant to the search. Its only argument is the name of the tree to
+cut down.
+
+[call [cmd ::htmlparse::removeFormDefs] [arg tree]]
+
+Like [cmd ::htmlparse::removeVisualFluff] this command is here to cut
+down on the size of the tree as generated by
+
+[cmd ::htmlparse::2tree]. It removes all nodes representing forms and
+form elements. Its only argument is the name of the tree to cut down.
+
+[list_end]
+
+[vset CATEGORY htmlparse]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/htmlparse/htmlparse.pcx b/tcllib/modules/htmlparse/htmlparse.pcx
new file mode 100644
index 0000000..9db5a00
--- /dev/null
+++ b/tcllib/modules/htmlparse/htmlparse.pcx
@@ -0,0 +1,57 @@
+# -*- tcl -*- htmlparse.pcx
+# Syntax of the commands provided by package htmlparse.
+
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register htmlparse
+pcx::tcldep 1.1.2 needs tcl 8.2
+
+namespace eval ::htmlparse {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.1.2 std ::htmlparse::2tree \
+ {checkSimpleArgs 2 2 {
+ checkWord
+ checkWord
+ }}
+pcx::check 1.1.2 std ::htmlparse::debugCallback \
+ {checkSimpleArgs 4 5 {
+ checkWord
+ checkWord
+ checkWord
+ checkWord
+ checkWord
+ }}
+pcx::check 1.1.2 std ::htmlparse::mapEscapes \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 1.1.2 std ::htmlparse::parse \
+ {checkSimpleArgs 1 -1 {
+ {checkSwitches 1 {
+ {-cmd checkList}
+ {-vroot checkWord}
+ {-split checkNatNum}
+ {-incvar checkVarNameWrite}
+ {-queue checkWord}
+ } {checkSimpleArgs 1 1 {checkWord}}}
+ }}
+pcx::check 1.1.2 std ::htmlparse::removeFormDefs \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 1.1.2 std ::htmlparse::removeVisualFluff \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+
+# Initialization via pcx::init.
+# Use a ::htmlparse::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/htmlparse/htmlparse.tcl b/tcllib/modules/htmlparse/htmlparse.tcl
new file mode 100644
index 0000000..190cd4f
--- /dev/null
+++ b/tcllib/modules/htmlparse/htmlparse.tcl
@@ -0,0 +1,1444 @@
+# htmlparse.tcl --
+#
+# This file implements a simple HTML parsing library in Tcl.
+# It may take advantage of parsers coded in C in the future.
+#
+# The functionality here is a subset of the
+#
+# Simple HTML display library by Stephen Uhler (stephen.uhler@sun.com)
+# Copyright (c) 1995 by Sun Microsystems
+# Version 0.3 Fri Sep 1 10:47:17 PDT 1995
+#
+# The main restriction is that all Tk-related code in the above
+# was left out of the code here. It is expected that this code
+# will go into a 'tklib' in the future.
+#
+# Copyright (c) 2001 by ActiveState Tool Corp.
+# See the file license.terms.
+
+package require Tcl 8.2
+package require struct::stack
+package require cmdline 1.1
+
+namespace eval ::htmlparse {
+ namespace export \
+ parse \
+ debugCallback \
+ mapEscapes \
+ 2tree \
+ removeVisualFluff \
+ removeFormDefs
+
+ # Table of escape characters. Maps from their names to the actual
+ # character. See http://htmlhelp.org/reference/html40/entities/
+
+ variable namedEntities
+
+ # I. Latin-1 Entities (HTML 4.01)
+ array set namedEntities {
+ nbsp \xa0 iexcl \xa1 cent \xa2 pound \xa3 curren \xa4
+ yen \xa5 brvbar \xa6 sect \xa7 uml \xa8 copy \xa9
+ ordf \xaa laquo \xab not \xac shy \xad reg \xae
+ macr \xaf deg \xb0 plusmn \xb1 sup2 \xb2 sup3 \xb3
+ acute \xb4 micro \xb5 para \xb6 middot \xb7 cedil \xb8
+ sup1 \xb9 ordm \xba raquo \xbb frac14 \xbc frac12 \xbd
+ frac34 \xbe iquest \xbf Agrave \xc0 Aacute \xc1 Acirc \xc2
+ Atilde \xc3 Auml \xc4 Aring \xc5 AElig \xc6 Ccedil \xc7
+ Egrave \xc8 Eacute \xc9 Ecirc \xca Euml \xcb Igrave \xcc
+ Iacute \xcd Icirc \xce Iuml \xcf ETH \xd0 Ntilde \xd1
+ Ograve \xd2 Oacute \xd3 Ocirc \xd4 Otilde \xd5 Ouml \xd6
+ times \xd7 Oslash \xd8 Ugrave \xd9 Uacute \xda Ucirc \xdb
+ Uuml \xdc Yacute \xdd THORN \xde szlig \xdf agrave \xe0
+ aacute \xe1 acirc \xe2 atilde \xe3 auml \xe4 aring \xe5
+ aelig \xe6 ccedil \xe7 egrave \xe8 eacute \xe9 ecirc \xea
+ euml \xeb igrave \xec iacute \xed icirc \xee iuml \xef
+ eth \xf0 ntilde \xf1 ograve \xf2 oacute \xf3 ocirc \xf4
+ otilde \xf5 ouml \xf6 divide \xf7 oslash \xf8 ugrave \xf9
+ uacute \xfa ucirc \xfb uuml \xfc yacute \xfd thorn \xfe
+ yuml \xff
+ }
+
+ # II. Entities for Symbols and Greek Letters (HTML 4.01)
+ array set namedEntities {
+ fnof \u192 Alpha \u391 Beta \u392 Gamma \u393 Delta \u394
+ Epsilon \u395 Zeta \u396 Eta \u397 Theta \u398 Iota \u399
+ Kappa \u39A Lambda \u39B Mu \u39C Nu \u39D Xi \u39E
+ Omicron \u39F Pi \u3A0 Rho \u3A1 Sigma \u3A3 Tau \u3A4
+ Upsilon \u3A5 Phi \u3A6 Chi \u3A7 Psi \u3A8 Omega \u3A9
+ alpha \u3B1 beta \u3B2 gamma \u3B3 delta \u3B4 epsilon \u3B5
+ zeta \u3B6 eta \u3B7 theta \u3B8 iota \u3B9 kappa \u3BA
+ lambda \u3BB mu \u3BC nu \u3BD xi \u3BE omicron \u3BF
+ pi \u3C0 rho \u3C1 sigmaf \u3C2 sigma \u3C3 tau \u3C4
+ upsilon \u3C5 phi \u3C6 chi \u3C7 psi \u3C8 omega \u3C9
+ thetasym \u3D1 upsih \u3D2 piv \u3D6 bull \u2022
+ hellip \u2026 prime \u2032 Prime \u2033 oline \u203E
+ frasl \u2044 weierp \u2118 image \u2111 real \u211C
+ trade \u2122 alefsym \u2135 larr \u2190 uarr \u2191
+ rarr \u2192 darr \u2193 harr \u2194 crarr \u21B5
+ lArr \u21D0 uArr \u21D1 rArr \u21D2 dArr \u21D3 hArr \u21D4
+ forall \u2200 part \u2202 exist \u2203 empty \u2205
+ nabla \u2207 isin \u2208 notin \u2209 ni \u220B prod \u220F
+ sum \u2211 minus \u2212 lowast \u2217 radic \u221A
+ prop \u221D infin \u221E ang \u2220 and \u2227 or \u2228
+ cap \u2229 cup \u222A int \u222B there4 \u2234 sim \u223C
+ cong \u2245 asymp \u2248 ne \u2260 equiv \u2261 le \u2264
+ ge \u2265 sub \u2282 sup \u2283 nsub \u2284 sube \u2286
+ supe \u2287 oplus \u2295 otimes \u2297 perp \u22A5
+ sdot \u22C5 lceil \u2308 rceil \u2309 lfloor \u230A
+ rfloor \u230B lang \u2329 rang \u232A loz \u25CA
+ spades \u2660 clubs \u2663 hearts \u2665 diams \u2666
+ }
+
+ # III. Special Entities (HTML 4.01)
+ array set namedEntities {
+ quot \x22 amp \x26 lt \x3C gt \x3E OElig \u152 oelig \u153
+ Scaron \u160 scaron \u161 Yuml \u178 circ \u2C6
+ tilde \u2DC ensp \u2002 emsp \u2003 thinsp \u2009
+ zwnj \u200C zwj \u200D lrm \u200E rlm \u200F ndash \u2013
+ mdash \u2014 lsquo \u2018 rsquo \u2019 sbquo \u201A
+ ldquo \u201C rdquo \u201D bdquo \u201E dagger \u2020
+ Dagger \u2021 permil \u2030 lsaquo \u2039 rsaquo \u203A
+ euro \u20AC
+ }
+
+ # IV. Special Entities (XHTML, XML)
+ array set namedEntities {
+ apos \u0027
+ }
+
+ # HTML5 section 8.5 Named character references (additions only)
+ # http://www.w3.org/TR/2011/WD-html5-20110113/named-character-references.html
+
+ array set namedEntities {
+ Abreve \u102 abreve \u103 ac \u223e acd \u223f
+ acE \u223e\u333 Acy \u410 acy \u430 af \u2061
+ Afr \ud835\udd04 afr \ud835\udd1e aleph \u2135 Amacr \u100
+ amacr \u101 amalg \u2a3f AMP \u26 andand \u2a55 And \u2a53
+ andd \u2a5c andslope \u2a58 andv \u2a5a ange \u29a4
+ angle \u2220 angmsdaa \u29a8 angmsdab \u29a9 angmsdac \u29aa
+ angmsdad \u29ab angmsdae \u29ac angmsdaf \u29ad
+ angmsdag \u29ae angmsdah \u29af angmsd \u2221 angrt \u221f
+ angrtvb \u22be angrtvbd \u299d angsph \u2222 angst \uc5
+ angzarr \u237c Aogon \u104 aogon \u105 Aopf \ud835\udd38
+ aopf \ud835\udd52 apacir \u2a6f ap \u2248 apE \u2a70
+ ape \u224a apid \u224b ApplyFunction \u2061 approx \u2248
+ approxeq \u224a Ascr \ud835\udc9c ascr \ud835\udcb6
+ Assign \u2254 ast \u2a asympeq \u224d awconint \u2233
+ awint \u2a11 backcong \u224c backepsilon \u3f6
+ backprime \u2035 backsim \u223d backsimeq \u22cd
+ Backslash \u2216 Barv \u2ae7 barvee \u22bd barwed \u2305
+ Barwed \u2306 barwedge \u2305 bbrk \u23b5 bbrktbrk \u23b6
+ bcong \u224c Bcy \u411 bcy \u431 becaus \u2235 because \u2235
+ Because \u2235 bemptyv \u29b0 bepsi \u3f6 bernou \u212c
+ Bernoullis \u212c beth \u2136 between \u226c Bfr \ud835\udd05
+ bfr \ud835\udd1f bigcap \u22c2 bigcirc \u25ef bigcup \u22c3
+ bigodot \u2a00 bigoplus \u2a01 bigotimes \u2a02
+ bigsqcup \u2a06 bigstar \u2605 bigtriangledown \u25bd
+ bigtriangleup \u25b3 biguplus \u2a04 bigvee \u22c1
+ bigwedge \u22c0 bkarow \u290d blacklozenge \u29eb
+ blacksquare \u25aa blacktriangle \u25b4
+ blacktriangledown \u25be blacktriangleleft \u25c2
+ blacktriangleright \u25b8 blank \u2423 blk12 \u2592
+ blk14 \u2591 blk34 \u2593 block \u2588 bne \u3d\u20e5
+ bnequiv \u2261\u20e5 bNot \u2aed bnot \u2310 Bopf \ud835\udd39
+ bopf \ud835\udd53 bot \u22a5 bottom \u22a5 bowtie \u22c8
+ boxbox \u29c9 boxdl \u2510 boxdL \u2555 boxDl \u2556
+ boxDL \u2557 boxdr \u250c boxdR \u2552 boxDr \u2553
+ boxDR \u2554 boxh \u2500 boxH \u2550 boxhd \u252c
+ boxHd \u2564 boxhD \u2565 boxHD \u2566 boxhu \u2534
+ boxHu \u2567 boxhU \u2568 boxHU \u2569 boxminus \u229f
+ boxplus \u229e boxtimes \u22a0 boxul \u2518 boxuL \u255b
+ boxUl \u255c boxUL \u255d boxur \u2514 boxuR \u2558
+ boxUr \u2559 boxUR \u255a boxv \u2502 boxV \u2551
+ boxvh \u253c boxvH \u256a boxVh \u256b boxVH \u256c
+ boxvl \u2524 boxvL \u2561 boxVl \u2562 boxVL \u2563
+ boxvr \u251c boxvR \u255e boxVr \u255f boxVR \u2560
+ bprime \u2035 breve \u2d8 Breve \u2d8 bscr \ud835\udcb7
+ Bscr \u212c bsemi \u204f bsim \u223d bsime \u22cd
+ bsolb \u29c5 bsol \u5c bsolhsub \u27c8 bullet \u2022
+ bump \u224e bumpE \u2aae bumpe \u224f Bumpeq \u224e
+ bumpeq \u224f Cacute \u106 cacute \u107 capand \u2a44
+ capbrcup \u2a49 capcap \u2a4b Cap \u22d2 capcup \u2a47
+ capdot \u2a40 CapitalDifferentialD \u2145 caps \u2229\ufe00
+ caret \u2041 caron \u2c7 Cayleys \u212d ccaps \u2a4d
+ Ccaron \u10c ccaron \u10d Ccirc \u108 ccirc \u109
+ Cconint \u2230 ccups \u2a4c ccupssm \u2a50 Cdot \u10a
+ cdot \u10b Cedilla \ub8 cemptyv \u29b2 centerdot \ub7
+ CenterDot \ub7 cfr \ud835\udd20 Cfr \u212d CHcy \u427
+ chcy \u447 check \u2713 checkmark \u2713 circeq \u2257
+ circlearrowleft \u21ba circlearrowright \u21bb
+ circledast \u229b circledcirc \u229a circleddash \u229d
+ CircleDot \u2299 circledR \uae circledS \u24c8
+ CircleMinus \u2296 CirclePlus \u2295 CircleTimes \u2297
+ cir \u25cb cirE \u29c3 cire \u2257 cirfnint \u2a10
+ cirmid \u2aef cirscir \u29c2 ClockwiseContourIntegral \u2232
+ CloseCurlyDoubleQuote \u201d CloseCurlyQuote \u2019
+ clubsuit \u2663 colon \u3a Colon \u2237 Colone \u2a74
+ colone \u2254 coloneq \u2254 comma \u2c commat \u40
+ comp \u2201 compfn \u2218 complement \u2201 complexes \u2102
+ congdot \u2a6d Congruent \u2261 conint \u222e Conint \u222f
+ ContourIntegral \u222e copf \ud835\udd54 Copf \u2102
+ coprod \u2210 Coproduct \u2210 COPY \ua9 copysr \u2117
+ CounterClockwiseContourIntegral \u2233 cross \u2717
+ Cross \u2a2f Cscr \ud835\udc9e cscr \ud835\udcb8 csub \u2acf
+ csube \u2ad1 csup \u2ad0 csupe \u2ad2 ctdot \u22ef
+ cudarrl \u2938 cudarrr \u2935 cuepr \u22de cuesc \u22df
+ cularr \u21b6 cularrp \u293d cupbrcap \u2a48 cupcap \u2a46
+ CupCap \u224d Cup \u22d3 cupcup \u2a4a cupdot \u228d
+ cupor \u2a45 cups \u222a\ufe00 curarr \u21b7 curarrm \u293c
+ curlyeqprec \u22de curlyeqsucc \u22df curlyvee \u22ce
+ curlywedge \u22cf curvearrowleft \u21b6 curvearrowright \u21b7
+ cuvee \u22ce cuwed \u22cf cwconint \u2232 cwint \u2231
+ cylcty \u232d daleth \u2138 Darr \u21a1 dash \u2010
+ Dashv \u2ae4 dashv \u22a3 dbkarow \u290f dblac \u2dd
+ Dcaron \u10e dcaron \u10f Dcy \u414 dcy \u434 ddagger \u2021
+ ddarr \u21ca DD \u2145 dd \u2146 DDotrahd \u2911
+ ddotseq \u2a77 Del \u2207 demptyv \u29b1 dfisht \u297f
+ Dfr \ud835\udd07 dfr \ud835\udd21 dHar \u2965 dharl \u21c3
+ dharr \u21c2 DiacriticalAcute \ub4 DiacriticalDot \u2d9
+ DiacriticalDoubleAcute \u2dd DiacriticalGrave \u60
+ DiacriticalTilde \u2dc diam \u22c4 diamond \u22c4
+ Diamond \u22c4 diamondsuit \u2666 die \ua8
+ DifferentialD \u2146 digamma \u3dd disin \u22f2 div \uf7
+ divideontimes \u22c7 divonx \u22c7 DJcy \u402 djcy \u452
+ dlcorn \u231e dlcrop \u230d dollar \u24 Dopf \ud835\udd3b
+ dopf \ud835\udd55 Dot \ua8 dot \u2d9 DotDot \u20dc
+ doteq \u2250 doteqdot \u2251 DotEqual \u2250 dotminus \u2238
+ dotplus \u2214 dotsquare \u22a1 doublebarwedge \u2306
+ DoubleContourIntegral \u222f DoubleDot \ua8
+ DoubleDownArrow \u21d3 DoubleLeftArrow \u21d0
+ DoubleLeftRightArrow \u21d4 DoubleLeftTee \u2ae4
+ DoubleLongLeftArrow \u27f8 DoubleLongLeftRightArrow \u27fa
+ DoubleLongRightArrow \u27f9 DoubleRightArrow \u21d2
+ DoubleRightTee \u22a8 DoubleUpArrow \u21d1
+ DoubleUpDownArrow \u21d5 DoubleVerticalBar \u2225
+ DownArrowBar \u2913 downarrow \u2193 DownArrow \u2193
+ Downarrow \u21d3 DownArrowUpArrow \u21f5 DownBreve \u311
+ downdownarrows \u21ca downharpoonleft \u21c3
+ downharpoonright \u21c2 DownLeftRightVector \u2950
+ DownLeftTeeVector \u295e DownLeftVectorBar \u2956
+ DownLeftVector \u21bd DownRightTeeVector \u295f
+ DownRightVectorBar \u2957 DownRightVector \u21c1
+ DownTeeArrow \u21a7 DownTee \u22a4 drbkarow \u2910
+ drcorn \u231f drcrop \u230c Dscr \ud835\udc9f
+ dscr \ud835\udcb9 DScy \u405 dscy \u455 dsol \u29f6
+ Dstrok \u110 dstrok \u111 dtdot \u22f1 dtri \u25bf
+ dtrif \u25be duarr \u21f5 duhar \u296f dwangle \u29a6
+ DZcy \u40f dzcy \u45f dzigrarr \u27ff easter \u2a6e
+ Ecaron \u11a ecaron \u11b ecir \u2256 ecolon \u2255 Ecy \u42d
+ ecy \u44d eDDot \u2a77 Edot \u116 edot \u117 eDot \u2251
+ ee \u2147 efDot \u2252 Efr \ud835\udd08 efr \ud835\udd22
+ eg \u2a9a egs \u2a96 egsdot \u2a98 el \u2a99 Element \u2208
+ elinters \u23e7 ell \u2113 els \u2a95 elsdot \u2a97
+ Emacr \u112 emacr \u113 emptyset \u2205
+ EmptySmallSquare \u25fb emptyv \u2205
+ EmptyVerySmallSquare \u25ab emsp13 \u2004 emsp14 \u2005
+ ENG \u14a eng \u14b Eogon \u118 eogon \u119 Eopf \ud835\udd3c
+ eopf \ud835\udd56 epar \u22d5 eparsl \u29e3 eplus \u2a71
+ epsi \u3b5 epsiv \u3f5 eqcirc \u2256 eqcolon \u2255
+ eqsim \u2242 eqslantgtr \u2a96 eqslantless \u2a95 Equal \u2a75
+ equals \u3d EqualTilde \u2242 equest \u225f Equilibrium \u21cc
+ equivDD \u2a78 eqvparsl \u29e5 erarr \u2971 erDot \u2253
+ escr \u212f Escr \u2130 esdot \u2250 Esim \u2a73 esim \u2242
+ excl \u21 Exists \u2203 expectation \u2130 exponentiale \u2147
+ ExponentialE \u2147 fallingdotseq \u2252 Fcy \u424 fcy \u444
+ female \u2640 ffilig \ufb03 fflig \ufb00 ffllig \ufb04
+ Ffr \ud835\udd09 ffr \ud835\udd23 filig \ufb01
+ FilledSmallSquare \u25fc FilledVerySmallSquare \u25aa
+ fjlig \u66\u6a flat \u266d fllig \ufb02 fltns \u25b1
+ Fopf \ud835\udd3d fopf \ud835\udd57 ForAll \u2200 fork \u22d4
+ forkv \u2ad9 Fouriertrf \u2131 fpartint \u2a0d frac13 \u2153
+ frac15 \u2155 frac16 \u2159 frac18 \u215b frac23 \u2154
+ frac25 \u2156 frac35 \u2157 frac38 \u215c frac45 \u2158
+ frac56 \u215a frac58 \u215d frac78 \u215e frown \u2322
+ fscr \ud835\udcbb Fscr \u2131 gacute \u1f5 Gammad \u3dc
+ gammad \u3dd gap \u2a86 Gbreve \u11e gbreve \u11f
+ Gcedil \u122 Gcirc \u11c gcirc \u11d Gcy \u413 gcy \u433
+ Gdot \u120 gdot \u121 gE \u2267 gEl \u2a8c gel \u22db
+ geq \u2265 geqq \u2267 geqslant \u2a7e gescc \u2aa9
+ ges \u2a7e gesdot \u2a80 gesdoto \u2a82 gesdotol \u2a84
+ gesl \u22db\ufe00 gesles \u2a94 Gfr \ud835\udd0a
+ gfr \ud835\udd24 gg \u226b Gg \u22d9 ggg \u22d9 gimel \u2137
+ GJcy \u403 gjcy \u453 gla \u2aa5 gl \u2277 glE \u2a92
+ glj \u2aa4 gnap \u2a8a gnapprox \u2a8a gne \u2a88 gnE \u2269
+ gneq \u2a88 gneqq \u2269 gnsim \u22e7 Gopf \ud835\udd3e
+ gopf \ud835\udd58 grave \u60 GreaterEqual \u2265
+ GreaterEqualLess \u22db GreaterFullEqual \u2267
+ GreaterGreater \u2aa2 GreaterLess \u2277
+ GreaterSlantEqual \u2a7e GreaterTilde \u2273 Gscr \ud835\udca2
+ gscr \u210a gsim \u2273 gsime \u2a8e gsiml \u2a90 gtcc \u2aa7
+ gtcir \u2a7a GT \u3e Gt \u226b gtdot \u22d7 gtlPar \u2995
+ gtquest \u2a7c gtrapprox \u2a86 gtrarr \u2978 gtrdot \u22d7
+ gtreqless \u22db gtreqqless \u2a8c gtrless \u2277
+ gtrsim \u2273 gvertneqq \u2269\ufe00 gvnE \u2269\ufe00
+ Hacek \u2c7 hairsp \u200a half \ubd hamilt \u210b
+ HARDcy \u42a hardcy \u44a harrcir \u2948 harrw \u21ad
+ Hat \u5e hbar \u210f Hcirc \u124 hcirc \u125 heartsuit \u2665
+ hercon \u22b9 hfr \ud835\udd25 Hfr \u210c HilbertSpace \u210b
+ hksearow \u2925 hkswarow \u2926 hoarr \u21ff homtht \u223b
+ hookleftarrow \u21a9 hookrightarrow \u21aa hopf \ud835\udd59
+ Hopf \u210d horbar \u2015 HorizontalLine \u2500
+ hscr \ud835\udcbd Hscr \u210b hslash \u210f Hstrok \u126
+ hstrok \u127 HumpDownHump \u224e HumpEqual \u224f
+ hybull \u2043 hyphen \u2010 ic \u2063 Icy \u418 icy \u438
+ Idot \u130 IEcy \u415 iecy \u435 iff \u21d4 ifr \ud835\udd26
+ Ifr \u2111 ii \u2148 iiiint \u2a0c iiint \u222d iinfin \u29dc
+ iiota \u2129 IJlig \u132 ijlig \u133 Imacr \u12a imacr \u12b
+ ImaginaryI \u2148 imagline \u2110 imagpart \u2111 imath \u131
+ Im \u2111 imof \u22b7 imped \u1b5 Implies \u21d2
+ incare \u2105 in \u2208 infintie \u29dd inodot \u131
+ intcal \u22ba Int \u222c integers \u2124 Integral \u222b
+ intercal \u22ba Intersection \u22c2 intlarhk \u2a17
+ intprod \u2a3c InvisibleComma \u2063 InvisibleTimes \u2062
+ IOcy \u401 iocy \u451 Iogon \u12e iogon \u12f
+ Iopf \ud835\udd40 iopf \ud835\udd5a iprod \u2a3c
+ iscr \ud835\udcbe Iscr \u2110 isindot \u22f5 isinE \u22f9
+ isins \u22f4 isinsv \u22f3 isinv \u2208 it \u2062
+ Itilde \u128 itilde \u129 Iukcy \u406 iukcy \u456 Jcirc \u134
+ jcirc \u135 Jcy \u419 jcy \u439 Jfr \ud835\udd0d
+ jfr \ud835\udd27 jmath \u237 Jopf \ud835\udd41
+ jopf \ud835\udd5b Jscr \ud835\udca5 jscr \ud835\udcbf
+ Jsercy \u408 jsercy \u458 Jukcy \u404 jukcy \u454
+ kappav \u3f0 Kcedil \u136 kcedil \u137 Kcy \u41a kcy \u43a
+ Kfr \ud835\udd0e kfr \ud835\udd28 kgreen \u138 KHcy \u425
+ khcy \u445 KJcy \u40c kjcy \u45c Kopf \ud835\udd42
+ kopf \ud835\udd5c Kscr \ud835\udca6 kscr \ud835\udcc0
+ lAarr \u21da Lacute \u139 lacute \u13a laemptyv \u29b4
+ lagran \u2112 Lang \u27ea langd \u2991 langle \u27e8
+ lap \u2a85 Laplacetrf \u2112 larrb \u21e4 larrbfs \u291f
+ Larr \u219e larrfs \u291d larrhk \u21a9 larrlp \u21ab
+ larrpl \u2939 larrsim \u2973 larrtl \u21a2 latail \u2919
+ lAtail \u291b lat \u2aab late \u2aad lates \u2aad\ufe00
+ lbarr \u290c lBarr \u290e lbbrk \u2772 lbrace \u7b
+ lbrack \u5b lbrke \u298b lbrksld \u298f lbrkslu \u298d
+ Lcaron \u13d lcaron \u13e Lcedil \u13b lcedil \u13c lcub \u7b
+ Lcy \u41b lcy \u43b ldca \u2936 ldquor \u201e ldrdhar \u2967
+ ldrushar \u294b ldsh \u21b2 lE \u2266 LeftAngleBracket \u27e8
+ LeftArrowBar \u21e4 leftarrow \u2190 LeftArrow \u2190
+ Leftarrow \u21d0 LeftArrowRightArrow \u21c6
+ leftarrowtail \u21a2 LeftCeiling \u2308
+ LeftDoubleBracket \u27e6 LeftDownTeeVector \u2961
+ LeftDownVectorBar \u2959 LeftDownVector \u21c3 LeftFloor \u230a
+ leftharpoondown \u21bd leftharpoonup \u21bc
+ leftleftarrows \u21c7 leftrightarrow \u2194
+ LeftRightArrow \u2194 Leftrightarrow \u21d4
+ leftrightarrows \u21c6 leftrightharpoons \u21cb
+ leftrightsquigarrow \u21ad LeftRightVector \u294e
+ LeftTeeArrow \u21a4 LeftTee \u22a3 LeftTeeVector \u295a
+ leftthreetimes \u22cb LeftTriangleBar \u29cf
+ LeftTriangle \u22b2 LeftTriangleEqual \u22b4
+ LeftUpDownVector \u2951 LeftUpTeeVector \u2960
+ LeftUpVectorBar \u2958 LeftUpVector \u21bf LeftVectorBar \u2952
+ LeftVector \u21bc lEg \u2a8b leg \u22da leq \u2264
+ leqq \u2266 leqslant \u2a7d lescc \u2aa8 les \u2a7d
+ lesdot \u2a7f lesdoto \u2a81 lesdotor \u2a83 lesg \u22da\ufe00
+ lesges \u2a93 lessapprox \u2a85 lessdot \u22d6
+ lesseqgtr \u22da lesseqqgtr \u2a8b LessEqualGreater \u22da
+ LessFullEqual \u2266 LessGreater \u2276 lessgtr \u2276
+ LessLess \u2aa1 lesssim \u2272 LessSlantEqual \u2a7d
+ LessTilde \u2272 lfisht \u297c Lfr \ud835\udd0f
+ lfr \ud835\udd29 lg \u2276 lgE \u2a91 lHar \u2962
+ lhard \u21bd lharu \u21bc lharul \u296a lhblk \u2584
+ LJcy \u409 ljcy \u459 llarr \u21c7 ll \u226a Ll \u22d8
+ llcorner \u231e Lleftarrow \u21da llhard \u296b lltri \u25fa
+ Lmidot \u13f lmidot \u140 lmoustache \u23b0 lmoust \u23b0
+ lnap \u2a89 lnapprox \u2a89 lne \u2a87 lnE \u2268 lneq \u2a87
+ lneqq \u2268 lnsim \u22e6 loang \u27ec loarr \u21fd
+ lobrk \u27e6 longleftarrow \u27f5 LongLeftArrow \u27f5
+ Longleftarrow \u27f8 longleftrightarrow \u27f7
+ LongLeftRightArrow \u27f7 Longleftrightarrow \u27fa
+ longmapsto \u27fc longrightarrow \u27f6 LongRightArrow \u27f6
+ Longrightarrow \u27f9 looparrowleft \u21ab
+ looparrowright \u21ac lopar \u2985 Lopf \ud835\udd43
+ lopf \ud835\udd5d loplus \u2a2d lotimes \u2a34 lowbar \u5f
+ LowerLeftArrow \u2199 LowerRightArrow \u2198 lozenge \u25ca
+ lozf \u29eb lpar \u28 lparlt \u2993 lrarr \u21c6
+ lrcorner \u231f lrhar \u21cb lrhard \u296d lrtri \u22bf
+ lscr \ud835\udcc1 Lscr \u2112 lsh \u21b0 Lsh \u21b0
+ lsim \u2272 lsime \u2a8d lsimg \u2a8f lsqb \u5b lsquor \u201a
+ Lstrok \u141 lstrok \u142 ltcc \u2aa6 ltcir \u2a79 LT \u3c
+ Lt \u226a ltdot \u22d6 lthree \u22cb ltimes \u22c9
+ ltlarr \u2976 ltquest \u2a7b ltri \u25c3 ltrie \u22b4
+ ltrif \u25c2 ltrPar \u2996 lurdshar \u294a luruhar \u2966
+ lvertneqq \u2268\ufe00 lvnE \u2268\ufe00 male \u2642
+ malt \u2720 maltese \u2720 Map \u2905 map \u21a6
+ mapsto \u21a6 mapstodown \u21a7 mapstoleft \u21a4
+ mapstoup \u21a5 marker \u25ae mcomma \u2a29 Mcy \u41c
+ mcy \u43c mDDot \u223a measuredangle \u2221 MediumSpace \u205f
+ Mellintrf \u2133 Mfr \ud835\udd10 mfr \ud835\udd2a mho \u2127
+ midast \u2a midcir \u2af0 mid \u2223 minusb \u229f
+ minusd \u2238 minusdu \u2a2a MinusPlus \u2213 mlcp \u2adb
+ mldr \u2026 mnplus \u2213 models \u22a7 Mopf \ud835\udd44
+ mopf \ud835\udd5e mp \u2213 mscr \ud835\udcc2 Mscr \u2133
+ mstpos \u223e multimap \u22b8 mumap \u22b8 Nacute \u143
+ nacute \u144 nang \u2220\u20d2 nap \u2249 napE \u2a70\u338
+ napid \u224b\u338 napos \u149 napprox \u2249 natural \u266e
+ naturals \u2115 natur \u266e nbump \u224e\u338
+ nbumpe \u224f\u338 ncap \u2a43 Ncaron \u147 ncaron \u148
+ Ncedil \u145 ncedil \u146 ncong \u2247 ncongdot \u2a6d\u338
+ ncup \u2a42 Ncy \u41d ncy \u43d nearhk \u2924 nearr \u2197
+ neArr \u21d7 nearrow \u2197 nedot \u2250\u338
+ NegativeMediumSpace \u200b NegativeThickSpace \u200b
+ NegativeThinSpace \u200b NegativeVeryThinSpace \u200b
+ nequiv \u2262 nesear \u2928 nesim \u2242\u338
+ NestedGreaterGreater \u226b NestedLessLess \u226a NewLine \ua
+ nexist \u2204 nexists \u2204 Nfr \ud835\udd11 nfr \ud835\udd2b
+ ngE \u2267\u338 nge \u2271 ngeq \u2271 ngeqq \u2267\u338
+ ngeqslant \u2a7e\u338 nges \u2a7e\u338 nGg \u22d9\u338
+ ngsim \u2275 nGt \u226b\u20d2 ngt \u226f ngtr \u226f
+ nGtv \u226b\u338 nharr \u21ae nhArr \u21ce nhpar \u2af2
+ nis \u22fc nisd \u22fa niv \u220b NJcy \u40a njcy \u45a
+ nlarr \u219a nlArr \u21cd nldr \u2025 nlE \u2266\u338
+ nle \u2270 nleftarrow \u219a nLeftarrow \u21cd
+ nleftrightarrow \u21ae nLeftrightarrow \u21ce nleq \u2270
+ nleqq \u2266\u338 nleqslant \u2a7d\u338 nles \u2a7d\u338
+ nless \u226e nLl \u22d8\u338 nlsim \u2274 nLt \u226a\u20d2
+ nlt \u226e nltri \u22ea nltrie \u22ec nLtv \u226a\u338
+ nmid \u2224 NoBreak \u2060 NonBreakingSpace \ua0
+ nopf \ud835\udd5f Nopf \u2115 Not \u2aec NotCongruent \u2262
+ NotCupCap \u226d NotDoubleVerticalBar \u2226 NotElement \u2209
+ NotEqual \u2260 NotEqualTilde \u2242\u338 NotExists \u2204
+ NotGreater \u226f NotGreaterEqual \u2271
+ NotGreaterFullEqual \u2267\u338 NotGreaterGreater \u226b\u338
+ NotGreaterLess \u2279 NotGreaterSlantEqual \u2a7e\u338
+ NotGreaterTilde \u2275 NotHumpDownHump \u224e\u338
+ NotHumpEqual \u224f\u338 notindot \u22f5\u338
+ notinE \u22f9\u338 notinva \u2209 notinvb \u22f7
+ notinvc \u22f6 NotLeftTriangleBar \u29cf\u338
+ NotLeftTriangle \u22ea NotLeftTriangleEqual \u22ec
+ NotLess \u226e NotLessEqual \u2270 NotLessGreater \u2278
+ NotLessLess \u226a\u338 NotLessSlantEqual \u2a7d\u338
+ NotLessTilde \u2274 NotNestedGreaterGreater \u2aa2\u338
+ NotNestedLessLess \u2aa1\u338 notni \u220c notniva \u220c
+ notnivb \u22fe notnivc \u22fd NotPrecedes \u2280
+ NotPrecedesEqual \u2aaf\u338 NotPrecedesSlantEqual \u22e0
+ NotReverseElement \u220c NotRightTriangleBar \u29d0\u338
+ NotRightTriangle \u22eb NotRightTriangleEqual \u22ed
+ NotSquareSubset \u228f\u338 NotSquareSubsetEqual \u22e2
+ NotSquareSuperset \u2290\u338 NotSquareSupersetEqual \u22e3
+ NotSubset \u2282\u20d2 NotSubsetEqual \u2288 NotSucceeds \u2281
+ NotSucceedsEqual \u2ab0\u338 NotSucceedsSlantEqual \u22e1
+ NotSucceedsTilde \u227f\u338 NotSuperset \u2283\u20d2
+ NotSupersetEqual \u2289 NotTilde \u2241 NotTildeEqual \u2244
+ NotTildeFullEqual \u2247 NotTildeTilde \u2249
+ NotVerticalBar \u2224 nparallel \u2226 npar \u2226
+ nparsl \u2afd\u20e5 npart \u2202\u338 npolint \u2a14
+ npr \u2280 nprcue \u22e0 nprec \u2280 npreceq \u2aaf\u338
+ npre \u2aaf\u338 nrarrc \u2933\u338 nrarr \u219b nrArr \u21cf
+ nrarrw \u219d\u338 nrightarrow \u219b nRightarrow \u21cf
+ nrtri \u22eb nrtrie \u22ed nsc \u2281 nsccue \u22e1
+ nsce \u2ab0\u338 Nscr \ud835\udca9 nscr \ud835\udcc3
+ nshortmid \u2224 nshortparallel \u2226 nsim \u2241
+ nsime \u2244 nsimeq \u2244 nsmid \u2224 nspar \u2226
+ nsqsube \u22e2 nsqsupe \u22e3 nsubE \u2ac5\u338 nsube \u2288
+ nsubset \u2282\u20d2 nsubseteq \u2288 nsubseteqq \u2ac5\u338
+ nsucc \u2281 nsucceq \u2ab0\u338 nsup \u2285 nsupE \u2ac6\u338
+ nsupe \u2289 nsupset \u2283\u20d2 nsupseteq \u2289
+ nsupseteqq \u2ac6\u338 ntgl \u2279 ntlg \u2278
+ ntriangleleft \u22ea ntrianglelefteq \u22ec
+ ntriangleright \u22eb ntrianglerighteq \u22ed num \u23
+ numero \u2116 numsp \u2007 nvap \u224d\u20d2 nvdash \u22ac
+ nvDash \u22ad nVdash \u22ae nVDash \u22af nvge \u2265\u20d2
+ nvgt \u3e\u20d2 nvHarr \u2904 nvinfin \u29de nvlArr \u2902
+ nvle \u2264\u20d2 nvlt \u3c\u20d2 nvltrie \u22b4\u20d2
+ nvrArr \u2903 nvrtrie \u22b5\u20d2 nvsim \u223c\u20d2
+ nwarhk \u2923 nwarr \u2196 nwArr \u21d6 nwarrow \u2196
+ nwnear \u2927 oast \u229b ocir \u229a Ocy \u41e ocy \u43e
+ odash \u229d Odblac \u150 odblac \u151 odiv \u2a38
+ odot \u2299 odsold \u29bc ofcir \u29bf Ofr \ud835\udd12
+ ofr \ud835\udd2c ogon \u2db ogt \u29c1 ohbar \u29b5 ohm \u3a9
+ oint \u222e olarr \u21ba olcir \u29be olcross \u29bb
+ olt \u29c0 Omacr \u14c omacr \u14d omid \u29b6 ominus \u2296
+ Oopf \ud835\udd46 oopf \ud835\udd60 opar \u29b7
+ OpenCurlyDoubleQuote \u201c OpenCurlyQuote \u2018 operp \u29b9
+ orarr \u21bb Or \u2a54 ord \u2a5d order \u2134 orderof \u2134
+ origof \u22b6 oror \u2a56 orslope \u2a57 orv \u2a5b oS \u24c8
+ Oscr \ud835\udcaa oscr \u2134 osol \u2298 otimesas \u2a36
+ Otimes \u2a37 ovbar \u233d OverBar \u203e OverBrace \u23de
+ OverBracket \u23b4 OverParenthesis \u23dc parallel \u2225
+ par \u2225 parsim \u2af3 parsl \u2afd PartialD \u2202
+ Pcy \u41f pcy \u43f percnt \u25 period \u2e pertenk \u2031
+ Pfr \ud835\udd13 pfr \ud835\udd2d phiv \u3d5 phmmat \u2133
+ phone \u260e pitchfork \u22d4 planck \u210f planckh \u210e
+ plankv \u210f plusacir \u2a23 plusb \u229e pluscir \u2a22
+ plus \u2b plusdo \u2214 plusdu \u2a25 pluse \u2a72
+ PlusMinus \ub1 plussim \u2a26 plustwo \u2a27 pm \ub1
+ Poincareplane \u210c pointint \u2a15 popf \ud835\udd61
+ Popf \u2119 prap \u2ab7 Pr \u2abb pr \u227a prcue \u227c
+ precapprox \u2ab7 prec \u227a preccurlyeq \u227c
+ Precedes \u227a PrecedesEqual \u2aaf PrecedesSlantEqual \u227c
+ PrecedesTilde \u227e preceq \u2aaf precnapprox \u2ab9
+ precneqq \u2ab5 precnsim \u22e8 pre \u2aaf prE \u2ab3
+ precsim \u227e primes \u2119 prnap \u2ab9 prnE \u2ab5
+ prnsim \u22e8 Product \u220f profalar \u232e profline \u2312
+ profsurf \u2313 Proportional \u221d Proportion \u2237
+ propto \u221d prsim \u227e prurel \u22b0 Pscr \ud835\udcab
+ pscr \ud835\udcc5 puncsp \u2008 Qfr \ud835\udd14
+ qfr \ud835\udd2e qint \u2a0c qopf \ud835\udd62 Qopf \u211a
+ qprime \u2057 Qscr \ud835\udcac qscr \ud835\udcc6
+ quaternions \u210d quatint \u2a16 quest \u3f questeq \u225f
+ QUOT \u22 rAarr \u21db race \u223d\u331 Racute \u154
+ racute \u155 raemptyv \u29b3 Rang \u27eb rangd \u2992
+ range \u29a5 rangle \u27e9 rarrap \u2975 rarrb \u21e5
+ rarrbfs \u2920 rarrc \u2933 Rarr \u21a0 rarrfs \u291e
+ rarrhk \u21aa rarrlp \u21ac rarrpl \u2945 rarrsim \u2974
+ Rarrtl \u2916 rarrtl \u21a3 rarrw \u219d ratail \u291a
+ rAtail \u291c ratio \u2236 rationals \u211a rbarr \u290d
+ rBarr \u290f RBarr \u2910 rbbrk \u2773 rbrace \u7d
+ rbrack \u5d rbrke \u298c rbrksld \u298e rbrkslu \u2990
+ Rcaron \u158 rcaron \u159 Rcedil \u156 rcedil \u157 rcub \u7d
+ Rcy \u420 rcy \u440 rdca \u2937 rdldhar \u2969 rdquor \u201d
+ rdsh \u21b3 realine \u211b realpart \u211c reals \u211d
+ Re \u211c rect \u25ad REG \uae ReverseElement \u220b
+ ReverseEquilibrium \u21cb ReverseUpEquilibrium \u296f
+ rfisht \u297d rfr \ud835\udd2f Rfr \u211c rHar \u2964
+ rhard \u21c1 rharu \u21c0 rharul \u296c rhov \u3f1
+ RightAngleBracket \u27e9 RightArrowBar \u21e5 rightarrow \u2192
+ RightArrow \u2192 Rightarrow \u21d2 RightArrowLeftArrow \u21c4
+ rightarrowtail \u21a3 RightCeiling \u2309
+ RightDoubleBracket \u27e7 RightDownTeeVector \u295d
+ RightDownVectorBar \u2955 RightDownVector \u21c2
+ RightFloor \u230b rightharpoondown \u21c1 rightharpoonup \u21c0
+ rightleftarrows \u21c4 rightleftharpoons \u21cc
+ rightrightarrows \u21c9 rightsquigarrow \u219d
+ RightTeeArrow \u21a6 RightTee \u22a2 RightTeeVector \u295b
+ rightthreetimes \u22cc RightTriangleBar \u29d0
+ RightTriangle \u22b3 RightTriangleEqual \u22b5
+ RightUpDownVector \u294f RightUpTeeVector \u295c
+ RightUpVectorBar \u2954 RightUpVector \u21be
+ RightVectorBar \u2953 RightVector \u21c0 ring \u2da
+ risingdotseq \u2253 rlarr \u21c4 rlhar \u21cc
+ rmoustache \u23b1 rmoust \u23b1 rnmid \u2aee roang \u27ed
+ roarr \u21fe robrk \u27e7 ropar \u2986 ropf \ud835\udd63
+ Ropf \u211d roplus \u2a2e rotimes \u2a35 RoundImplies \u2970
+ rpar \u29 rpargt \u2994 rppolint \u2a12 rrarr \u21c9
+ Rrightarrow \u21db rscr \ud835\udcc7 Rscr \u211b rsh \u21b1
+ Rsh \u21b1 rsqb \u5d rsquor \u2019 rthree \u22cc
+ rtimes \u22ca rtri \u25b9 rtrie \u22b5 rtrif \u25b8
+ rtriltri \u29ce RuleDelayed \u29f4 ruluhar \u2968 rx \u211e
+ Sacute \u15a sacute \u15b scap \u2ab8 Sc \u2abc sc \u227b
+ sccue \u227d sce \u2ab0 scE \u2ab4 Scedil \u15e scedil \u15f
+ Scirc \u15c scirc \u15d scnap \u2aba scnE \u2ab6
+ scnsim \u22e9 scpolint \u2a13 scsim \u227f Scy \u421
+ scy \u441 sdotb \u22a1 sdote \u2a66 searhk \u2925
+ searr \u2198 seArr \u21d8 searrow \u2198 semi \u3b
+ seswar \u2929 setminus \u2216 setmn \u2216 sext \u2736
+ Sfr \ud835\udd16 sfr \ud835\udd30 sfrown \u2322 sharp \u266f
+ SHCHcy \u429 shchcy \u449 SHcy \u428 shcy \u448
+ ShortDownArrow \u2193 ShortLeftArrow \u2190 shortmid \u2223
+ shortparallel \u2225 ShortRightArrow \u2192 ShortUpArrow \u2191
+ sigmav \u3c2 simdot \u2a6a sime \u2243 simeq \u2243
+ simg \u2a9e simgE \u2aa0 siml \u2a9d simlE \u2a9f
+ simne \u2246 simplus \u2a24 simrarr \u2972 slarr \u2190
+ SmallCircle \u2218 smallsetminus \u2216 smashp \u2a33
+ smeparsl \u29e4 smid \u2223 smile \u2323 smt \u2aaa
+ smte \u2aac smtes \u2aac\ufe00 SOFTcy \u42c softcy \u44c
+ solbar \u233f solb \u29c4 sol \u2f Sopf \ud835\udd4a
+ sopf \ud835\udd64 spadesuit \u2660 spar \u2225 sqcap \u2293
+ sqcaps \u2293\ufe00 sqcup \u2294 sqcups \u2294\ufe00
+ Sqrt \u221a sqsub \u228f sqsube \u2291 sqsubset \u228f
+ sqsubseteq \u2291 sqsup \u2290 sqsupe \u2292 sqsupset \u2290
+ sqsupseteq \u2292 square \u25a1 Square \u25a1
+ SquareIntersection \u2293 SquareSubset \u228f
+ SquareSubsetEqual \u2291 SquareSuperset \u2290
+ SquareSupersetEqual \u2292 SquareUnion \u2294 squarf \u25aa
+ squ \u25a1 squf \u25aa srarr \u2192 Sscr \ud835\udcae
+ sscr \ud835\udcc8 ssetmn \u2216 ssmile \u2323 sstarf \u22c6
+ Star \u22c6 star \u2606 starf \u2605 straightepsilon \u3f5
+ straightphi \u3d5 strns \uaf Sub \u22d0 subdot \u2abd
+ subE \u2ac5 subedot \u2ac3 submult \u2ac1 subnE \u2acb
+ subne \u228a subplus \u2abf subrarr \u2979 subset \u2282
+ Subset \u22d0 subseteq \u2286 subseteqq \u2ac5
+ SubsetEqual \u2286 subsetneq \u228a subsetneqq \u2acb
+ subsim \u2ac7 subsub \u2ad5 subsup \u2ad3 succapprox \u2ab8
+ succ \u227b succcurlyeq \u227d Succeeds \u227b
+ SucceedsEqual \u2ab0 SucceedsSlantEqual \u227d
+ SucceedsTilde \u227f succeq \u2ab0 succnapprox \u2aba
+ succneqq \u2ab6 succnsim \u22e9 succsim \u227f SuchThat \u220b
+ Sum \u2211 sung \u266a Sup \u22d1 supdot \u2abe
+ supdsub \u2ad8 supE \u2ac6 supedot \u2ac4 Superset \u2283
+ SupersetEqual \u2287 suphsol \u27c9 suphsub \u2ad7
+ suplarr \u297b supmult \u2ac2 supnE \u2acc supne \u228b
+ supplus \u2ac0 supset \u2283 Supset \u22d1 supseteq \u2287
+ supseteqq \u2ac6 supsetneq \u228b supsetneqq \u2acc
+ supsim \u2ac8 supsub \u2ad4 supsup \u2ad6 swarhk \u2926
+ swarr \u2199 swArr \u21d9 swarrow \u2199 swnwar \u292a
+ Tab \u9 target \u2316 tbrk \u23b4 Tcaron \u164 tcaron \u165
+ Tcedil \u162 tcedil \u163 Tcy \u422 tcy \u442 tdot \u20db
+ telrec \u2315 Tfr \ud835\udd17 tfr \ud835\udd31
+ therefore \u2234 Therefore \u2234 thetav \u3d1
+ thickapprox \u2248 thicksim \u223c ThickSpace \u205f\u200a
+ ThinSpace \u2009 thkap \u2248 thksim \u223c Tilde \u223c
+ TildeEqual \u2243 TildeFullEqual \u2245 TildeTilde \u2248
+ timesbar \u2a31 timesb \u22a0 timesd \u2a30 tint \u222d
+ toea \u2928 topbot \u2336 topcir \u2af1 top \u22a4
+ Topf \ud835\udd4b topf \ud835\udd65 topfork \u2ada tosa \u2929
+ tprime \u2034 TRADE \u2122 triangle \u25b5 triangledown \u25bf
+ triangleleft \u25c3 trianglelefteq \u22b4 triangleq \u225c
+ triangleright \u25b9 trianglerighteq \u22b5 tridot \u25ec
+ trie \u225c triminus \u2a3a TripleDot \u20db triplus \u2a39
+ trisb \u29cd tritime \u2a3b trpezium \u23e2 Tscr \ud835\udcaf
+ tscr \ud835\udcc9 TScy \u426 tscy \u446 TSHcy \u40b
+ tshcy \u45b Tstrok \u166 tstrok \u167 twixt \u226c
+ twoheadleftarrow \u219e twoheadrightarrow \u21a0 Uarr \u219f
+ Uarrocir \u2949 Ubrcy \u40e ubrcy \u45e Ubreve \u16c
+ ubreve \u16d Ucy \u423 ucy \u443 udarr \u21c5 Udblac \u170
+ udblac \u171 udhar \u296e ufisht \u297e Ufr \ud835\udd18
+ ufr \ud835\udd32 uHar \u2963 uharl \u21bf uharr \u21be
+ uhblk \u2580 ulcorn \u231c ulcorner \u231c ulcrop \u230f
+ ultri \u25f8 Umacr \u16a umacr \u16b UnderBar \u5f
+ UnderBrace \u23df UnderBracket \u23b5 UnderParenthesis \u23dd
+ Union \u22c3 UnionPlus \u228e Uogon \u172 uogon \u173
+ Uopf \ud835\udd4c uopf \ud835\udd66 UpArrowBar \u2912
+ uparrow \u2191 UpArrow \u2191 Uparrow \u21d1
+ UpArrowDownArrow \u21c5 updownarrow \u2195 UpDownArrow \u2195
+ Updownarrow \u21d5 UpEquilibrium \u296e upharpoonleft \u21bf
+ upharpoonright \u21be uplus \u228e UpperLeftArrow \u2196
+ UpperRightArrow \u2197 upsi \u3c5 Upsi \u3d2 UpTeeArrow \u21a5
+ UpTee \u22a5 upuparrows \u21c8 urcorn \u231d urcorner \u231d
+ urcrop \u230e Uring \u16e uring \u16f urtri \u25f9
+ Uscr \ud835\udcb0 uscr \ud835\udcca utdot \u22f0 Utilde \u168
+ utilde \u169 utri \u25b5 utrif \u25b4 uuarr \u21c8
+ uwangle \u29a7 vangrt \u299c varepsilon \u3f5 varkappa \u3f0
+ varnothing \u2205 varphi \u3d5 varpi \u3d6 varpropto \u221d
+ varr \u2195 vArr \u21d5 varrho \u3f1 varsigma \u3c2
+ varsubsetneq \u228a\ufe00 varsubsetneqq \u2acb\ufe00
+ varsupsetneq \u228b\ufe00 varsupsetneqq \u2acc\ufe00
+ vartheta \u3d1 vartriangleleft \u22b2 vartriangleright \u22b3
+ vBar \u2ae8 Vbar \u2aeb vBarv \u2ae9 Vcy \u412 vcy \u432
+ vdash \u22a2 vDash \u22a8 Vdash \u22a9 VDash \u22ab
+ Vdashl \u2ae6 veebar \u22bb vee \u2228 Vee \u22c1
+ veeeq \u225a vellip \u22ee verbar \u7c Verbar \u2016
+ vert \u7c Vert \u2016 VerticalBar \u2223 VerticalLine \u7c
+ VerticalSeparator \u2758 VerticalTilde \u2240
+ VeryThinSpace \u200a Vfr \ud835\udd19 vfr \ud835\udd33
+ vltri \u22b2 vnsub \u2282\u20d2 vnsup \u2283\u20d2
+ Vopf \ud835\udd4d vopf \ud835\udd67 vprop \u221d vrtri \u22b3
+ Vscr \ud835\udcb1 vscr \ud835\udccb vsubnE \u2acb\ufe00
+ vsubne \u228a\ufe00 vsupnE \u2acc\ufe00 vsupne \u228b\ufe00
+ Vvdash \u22aa vzigzag \u299a Wcirc \u174 wcirc \u175
+ wedbar \u2a5f wedge \u2227 Wedge \u22c0 wedgeq \u2259
+ Wfr \ud835\udd1a wfr \ud835\udd34 Wopf \ud835\udd4e
+ wopf \ud835\udd68 wp \u2118 wr \u2240 wreath \u2240
+ Wscr \ud835\udcb2 wscr \ud835\udccc xcap \u22c2 xcirc \u25ef
+ xcup \u22c3 xdtri \u25bd Xfr \ud835\udd1b xfr \ud835\udd35
+ xharr \u27f7 xhArr \u27fa xlarr \u27f5 xlArr \u27f8
+ xmap \u27fc xnis \u22fb xodot \u2a00 Xopf \ud835\udd4f
+ xopf \ud835\udd69 xoplus \u2a01 xotime \u2a02 xrarr \u27f6
+ xrArr \u27f9 Xscr \ud835\udcb3 xscr \ud835\udccd xsqcup \u2a06
+ xuplus \u2a04 xutri \u25b3 xvee \u22c1 xwedge \u22c0
+ YAcy \u42f yacy \u44f Ycirc \u176 ycirc \u177 Ycy \u42b
+ ycy \u44b Yfr \ud835\udd1c yfr \ud835\udd36 YIcy \u407
+ yicy \u457 Yopf \ud835\udd50 yopf \ud835\udd6a
+ Yscr \ud835\udcb4 yscr \ud835\udcce YUcy \u42e yucy \u44e
+ Zacute \u179 zacute \u17a Zcaron \u17d zcaron \u17e Zcy \u417
+ zcy \u437 Zdot \u17b zdot \u17c zeetrf \u2128
+ ZeroWidthSpace \u200b zfr \ud835\udd37 Zfr \u2128 ZHcy \u416
+ zhcy \u436 zigrarr \u21dd zopf \ud835\udd6b Zopf \u2124
+ Zscr \ud835\udcb5 zscr \ud835\udccf
+ }
+
+ # Internal cache for the foreach variable-lists and the
+ # substitution strings used to split a HTML string into
+ # incrementally handleable scripts. This should reduce the
+ # time compute this information for repeated calls with the same
+ # split-factor. The array is indexed by a combination of the
+ # numerical split factor and the length of the command prefix and
+ # maps this to a 2-element list containing variable- and
+ # subst-string.
+
+ variable splitdata
+ array set splitdata {}
+
+}
+
+# htmlparse::parse --
+#
+# This command is the basic parser for HTML. It takes a HTML
+# string, parses it and invokes a command prefix for every tag
+# encountered. It is not necessary for the HTML to be valid for
+# this parser to function. It is the responsibility of the
+# command invoked for every tag to check this. Another
+# responsibility of the invoked command is the handling of tag
+# attributes and character entities (escaped characters). The
+# parser provides the un-interpreted tag attributes to the
+# invoked command to aid in the former, and the package at large
+# provides a helper command, '::htmlparse::mapEscapes', to aid
+# in the handling of the latter. The parser *does* ignore
+# leading DOCTYPE declarations and all valid HTML comments it
+# encounters.
+#
+# All information beyond the HTML string itself is specified via
+# options, these are explained below.
+#
+# To help understanding the options some more background
+# information about the parser.
+#
+# It is capable to detect incomplete tags in the HTML string
+# given to it. Under normal circumstances this will cause the
+# parser to throw an error, but if the option '-incvar' is used
+# to specify a global (or namespace) variable the parser will
+# store the incomplete part of the input into this variable
+# instead. This will aid greatly in the handling of
+# incrementally arriving HTML as the parser will handle whatever
+# he can and defer the handling of the incomplete part until
+# more data has arrived.
+#
+# Another feature of the parser are its two possible modes of
+# operation. The normal mode is activated if the option '-queue'
+# is not present on the command line invoking the parser. If it
+# is present the parser will go into the incremental mode instead.
+#
+# The main difference is that a parser in normal mode will
+# immediately invoke the command prefix for each tag it
+# encounters. In incremental mode however the parser will
+# generate a number of scripts which invoke the command prefix
+# for groups of tags in the HTML string and then store these
+# scripts in the specified queue. It is then the responsibility
+# of the caller of the parser to ensure the execution of the
+# scripts in the queue.
+#
+# Note: The queue objecct given to the parser has to provide the
+# same interface as the queue defined in tcllib -> struct. This
+# does for example mean that all queues created via that part of
+# tcllib can be immediately used here. Still, the queue doesn't
+# have to come from tcllib -> struct as long as the same
+# interface is provided.
+#
+# In both modes the parser will return an empty string to the
+# caller.
+#
+# To a parser in incremental mode the option '-split' can be
+# given and will specify the size of the groups he creates. In
+# other words, -split 5 means that each of the generated scripts
+# will invoke the command prefix for 5 consecutive tags in the
+# HTML string. A parser in normal mode will ignore this option
+# and its value.
+#
+# The option '-vroot' specifies a virtual root tag. A parser in
+# normal mode will invoke the command prefix for it immediately
+# before and after he processes the tags in the HTML, thus
+# simulating that the HTML string is enclosed in a <vroot>
+# </vroot> combination. In incremental mode however the parser
+# is unable to provide the closing virtual root as he never
+# knows when the input is complete. In this case the first
+# script generated by each invocation of the parser will contain
+# an invocation of the command prefix for the virtual root as
+# its first command.
+#
+# Interface to the command prefix:
+#
+# In normal mode the parser will invoke the command prefix with
+# for arguments appended. See '::htmlparse::debugCallback' for a
+# description. In incremental mode however the generated scripts
+# will invoke the command prefix with five arguments
+# appended. The last four of these are the same which were
+# mentioned above. The first however is a placeholder string
+# (\win\) for a clientdata value to be supplied later during the
+# actual execution of the generated scripts. This could be a tk
+# window path, for example. This allows the user of this package
+# to preprocess HTML strings without commiting them to a
+# specific window, object, whatever during parsing. This
+# connection can be made later. This also means that it is
+# possible to cache preprocessed HTML. Of course, nothing
+# prevents the user of the parser to replace the placeholder
+# with an empty string.
+#
+# Arguments:
+# args An option/value-list followed by the string to
+# parse. Available options are:
+#
+# -cmd The command prefix to invoke for every tag in
+# the HTML string. Defaults to
+# '::htmlparse::debugCallback'.
+#
+# -vroot The virtual root tag to add around the HTML in
+# normal mode. In incremental mode it is the
+# first tag in each chunk processed by the
+# parser, but there will be no closing tags.
+# Defaults to 'hmstart'.
+#
+# -split The size of the groups produced by an
+# incremental mode parser. Ignored when in
+# normal mode. Defaults to 10. Values <= 0 are
+# not allowed.
+#
+# -incvar The name of the variable where to store any
+# incomplete HTML into. Optional.
+#
+# -queue
+# The handle/name of the queue objecct to store
+# the generated scripts into. Activates
+# incremental mode. Normal mode is used if this
+# option is not present.
+#
+# After the options the command expects a single argument
+# containing the HTML string to parse.
+#
+# Side Effects:
+# In normal mode as of the invoked command. Else none.
+#
+# Results:
+# None.
+
+proc ::htmlparse::parse {args} {
+ # Convert the HTML string into a evaluable command sequence.
+
+ variable splitdata
+
+ # Option processing, start with the defaults, then run through the
+ # list of arguments.
+
+ set cmd ::htmlparse::debugCallback
+ set vroot hmstart
+ set incvar ""
+ set split 10
+ set queue ""
+
+ while {[set err [cmdline::getopt args {cmd.arg vroot.arg incvar.arg split.arg queue.arg} opt arg]]} {
+ if {$err < 0} {
+ return -code error "::htmlparse::parse : $arg"
+ }
+ switch -exact -- $opt {
+ cmd -
+ vroot -
+ incvar -
+ queue {
+ if {[string length $arg] == 0} {
+ return -code error "::htmlparse::parse : -$opt illegal argument (empty)"
+ }
+ # Each option has an variable with the same name associated with it.
+ # FRINK: nocheck
+ set $opt $arg
+ }
+ split {
+ if {$arg <= 0} {
+ return -code error "::htmlparse::parse : -split illegal argument (<= 0)"
+ }
+ set split $arg
+ }
+ default {
+ # Cannot happen
+ }
+ }
+ }
+
+ if {[llength $args] > 1} {
+ return -code error "::htmlparse::parse : to many arguments behind the options, expected one"
+ }
+ if {[llength $args] < 1} {
+ return -code error "::htmlparse::parse : html string missing"
+ }
+
+ set html [PrepareHtml [lindex $args 0]]
+
+ # Look for incomplete HTML from the last iteration and prepend it
+ # to the input we just got.
+
+ if {$incvar != {}} {
+ upvar $incvar incomplete
+ } else {
+ set incomplete ""
+ }
+
+ if {[catch {set new $incomplete$html}]} {set new $html}
+ set html $new
+
+ # Handle incomplete HTML (Recognize incomplete tag at end, buffer
+ # it up for the next call).
+
+ set end [lindex \{$html\} end]
+ if {[set idx [string last < $end]] > [string last > $end]} {
+
+ if {$incvar == {}} {
+ return -code error "::htmlparse::parse : HTML is incomplete, option -incvar is missing"
+ }
+
+ # upvar $incvar incomplete -- Already done, s.a.
+ set incomplete [string range $end $idx end]
+ incr idx -1
+ set html [string range $end 0 $idx]
+
+ } else {
+ set incomplete ""
+ }
+
+ # Convert the HTML string into a script. First look for tag
+ # patterns and convert them into command invokations. The command
+ # is actually a placeholder ((LF) NUL SOH @ NUL). See step 2 for
+ # the explanation.
+
+ regsub -all -- {<([^\s>]+)\s*([^>]*)/>} $html {<\1 \2></\1>} html
+
+ #set sub "\}\n\0\1@\0 {\\1} {} {\\2} \{\}\n\0\1@\0 {\\1} {/} {} \{"
+ #regsub -all -- {<([^\s>]+)\s*([^>]*)/>} $html $sub html
+
+ set sub "\}\n\0\1@\0 {\\2} {\\1} {\\3} \{"
+ regsub -all -- {<(/?)([^\s>]+)\s*([^>]*)>} $html $sub html
+
+ # Step 2, replace the command placeholder with the command
+ # itself. This way any characters in the command prefix which are
+ # special to regsub are kept from the regsub.
+
+ set html [string map [list \n\0\1@\0 \n$cmd] $html]
+
+ # The value of queue now determines wether we process the HTML by
+ # ourselves (queue is empty) or if we generate a list of scripts
+ # each of which processes n tags, n the argument to -split.
+
+ if {$queue == {}} {
+ # And evaluate it. This is the main parsing step.
+
+ eval "$cmd {$vroot} {} {} \{$html\}"
+ eval "$cmd {$vroot} / {} {}"
+ } else {
+ # queue defined, generate list of scripts doing small chunks of tags.
+
+ set lcmd [llength $cmd]
+ set key $split,$lcmd
+
+ if {![info exists splitdata($key)]} {
+ for {set i 0; set group {}} {$i < $split} {incr i} {
+ # Use the length of the command prefix to generate
+ # additional variables before the main variable after
+ # which the placeholder will be inserted.
+
+ for {set j 1} {$j < $lcmd} {incr j} {
+ append group "b${j}_$i "
+ }
+
+ append group "a$i c$i d$i e$i f$i\n"
+ }
+ regsub -all -- {(a[0-9]+)} $group {{$\1} @win@} subgroup
+ regsub -all -- {([b-z_0-9]+[0-9]+)} $subgroup {{$\1}} subgroup
+
+ set splitdata($key) [list $group $subgroup]
+ }
+
+ foreach {group subgroup} $splitdata($key) break ; # lassign
+ foreach $group "$cmd {$vroot} {} {} \{$html\}" {
+ $queue put [string trimright [subst $subgroup]]
+ }
+ }
+ return
+}
+
+# htmlparse::PrepareHtml --
+#
+# Internal helper command of '::htmlparse::parse'. Removes
+# leading DOCTYPE declarations and comments, protects the
+# special characters of tcl from evaluation.
+#
+# Arguments:
+# html The HTML string to prepare
+#
+# Side Effects:
+# None.
+#
+# Results:
+# The provided HTML string with the described modifications
+# applied to it.
+
+proc ::htmlparse::PrepareHtml {html} {
+ # Remove the following items from the text:
+ # - A leading <!DOCTYPE...> declaration.
+ # - All comments <!-- ... -->
+ #
+ # Also normalize the line endings (\r -> \n).
+
+ # Tcllib SF Bug 861287 - Processing of comments.
+ # Recognize EOC by RE, instead of fixed string.
+
+ set html [string map [list \r \n] $html]
+
+ regsub -- "^.*<!DOCTYPE\[^>\]*>" $html {} html
+ regsub -all -- "--(\[ \t\n\]*)>" $html "\001\\1\002" html
+
+ # Recognize borken beginnings of a comment and convert them to PCDATA.
+ regsub -all -- "<--(\[^\001\]*)\001(\[^\002\]*)\002" $html {\&lt;--\1--\2\&gt;} html
+
+ # And now recognize true comments, remove them.
+ regsub -all -- "<!--\[^\001\]*\001(\[^\002\]*)\002" $html {} html
+
+ # Protect characters special to tcl (braces, slashes) by
+ # converting them to their escape sequences.
+
+ return [string map [list \
+ "\{" "&#123;" \
+ "\}" "&#125;" \
+ "\\" "&#92;"] $html]
+}
+
+
+
+# htmlparse::debugCallback --
+#
+# The standard callback used by the parser in
+# '::htmlparse::parse' if none was specified by the user. Simply
+# dumps its arguments to stdout. This callback can be used for
+# both normal and incremental mode of the calling parser. In
+# other words, it accepts four or five arguments. The last four
+# arguments are described below. The optional fifth argument
+# contains the clientdata value given to the callback by a
+# parser in incremental mode. All callbacks have to follow the
+# signature of this command in the last four arguments, and
+# callbacks used in incremental parsing have to follow this
+# signature in the last five arguments.
+#
+# Arguments:
+# tag The name of the tag currently
+# processed by the parser.
+#
+# slash Either empty or a slash. Allows us to
+# distinguish between opening (slash is
+# empty) and closing tags (slash is
+# equal to a '/').
+#
+# param The un-interpreted list of parameters
+# to the tag.
+#
+# textBehindTheTag The text found by the parser behind
+# the tag named in 'tag'.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# None.
+
+proc ::htmlparse::debugCallback {args} {
+ # args = ?clientData? tag slash param textBehindTheTag
+ puts "==> $args"
+ return
+}
+
+# htmlparse::mapEscapes --
+#
+# Takes a HTML string, substitutes all escape sequences with
+# their actual characters and returns the resulting string.
+# HTML not containing escape sequences or invalid escape
+# sequences is returned unchanged.
+#
+# Arguments:
+# html The string to modify
+#
+# Side Effects:
+# None.
+#
+# Results:
+# The argument string with all escape sequences replaced with
+# their actual characters.
+
+proc ::htmlparse::mapEscapes {html} {
+ # Find HTML escape characters of the form &xxx(;|EOW)
+
+ # Quote special Tcl chars so they pass through [subst] unharmed.
+ set new [string map [list \] \\\] \[ \\\[ \$ \\\$ \\ \\\\] $html]
+ regsub -all -- {&([[:alnum:]]{2,31})(;|\M)} $new {[DoNamedMap \1 {\2}]} new
+ regsub -all -- {&#([[:digit:]]{1,5})(;|\M)} $new {[DoDecMap \1 {\2}]} new
+ regsub -all -- {&#x([[:xdigit:]]{1,4})(;|\M)} $new {[DoHexMap \1 {\2}]} new
+ return [subst $new]
+}
+
+proc ::htmlparse::DoNamedMap {name endOf} {
+ variable namedEntities
+ if {[info exist namedEntities($name)]} {
+ return $namedEntities($name)
+ } else {
+ # Put it back..
+ return "&$name$endOf"
+ }
+}
+
+proc ::htmlparse::DoDecMap {dec endOf} {
+ scan $dec %d dec
+ if {$dec <= 0xFFFD} {
+ return [format %c $dec]
+ } else {
+ # Put it back..
+ return "&#$dec$endOf"
+ }
+}
+
+proc ::htmlparse::DoHexMap {hex endOf} {
+ scan $hex %x value
+ if {$value <= 0xFFFD} {
+ return [format %c $value]
+ } else {
+ # Put it back..
+ return "&#x$hex$endOf"
+ }
+}
+
+# htmlparse::2tree --
+#
+# This command is a wrapper around '::htmlparse::parse' which
+# takes a HTML string and converts it into a tree containing the
+# logical structure of the parsed document. The tree object has
+# to be created by the caller. It is also expected that the tree
+# object provides the same interface as the tree object from
+# tcllib -> struct. It doesn't have to come from that module
+# though. The internal callback does some basic checking of HTML
+# validity and tries to recover from the most basic errors.
+#
+# Arguments:
+# html The HTML string to parse and convert.
+# tree The name of the tree to fill.
+#
+# Side Effects:
+# Creates a tree object (see tcllib -> struct)
+# and modifies it.
+#
+# Results:
+# The contents of 'tree'.
+
+proc ::htmlparse::2tree {html tree} {
+
+ # One internal datastructure is required, a stack of open
+ # tags. This stack is also provided by the 'struct' module of
+ # tcllib. As the operation of this command is synchronuous we
+ # don't have to take care against multiple running copies at the
+ # same times (Such are possible, but will be in different
+ # interpreters and true concurrency is possible only if they are
+ # in different threads too). IOW, no need for tricks to make the
+ # internal datastructure unique.
+
+ catch {::htmlparse::tags destroy}
+
+ ::struct::stack ::htmlparse::tags
+ ::htmlparse::tags push root
+ $tree set root type root
+
+ parse -cmd [list ::htmlparse::2treeCallback $tree] $html
+
+ # A bit hackish, correct the ordering of nodes for the optional
+ # tag types, over a larger area when was seen by the parser itself.
+
+ $tree walk root -order post n {
+ ::htmlparse::Reorder $tree $n
+ }
+
+ ::htmlparse::tags destroy
+ return $tree
+}
+
+# htmlparse::2treeCallback --
+#
+# Internal helper command. A special callback to
+# '::htmlparse::parse' used by '::htmlparse::2tree' which takes
+# the incoming stream of tags and converts them into a tree
+# representing the inner structure of the parsed HTML
+# document. Recovers from simple HTML errors like missing
+# opening tags, missing closing tags and overlapping tags.
+#
+# Arguments:
+# tree The name of the tree to manipulate.
+# tag See '::htmlparse::debugCallback'.
+# slash See '::htmlparse::debugCallback'.
+# param See '::htmlparse::debugCallback'.
+# textBehindTheTag See '::htmlparse::debugCallback'.
+#
+# Side Effects:
+# Manipulates the tree object whose name was given as the first
+# argument.
+#
+# Results:
+# None.
+
+proc ::htmlparse::2treeCallback {tree tag slash param textBehindTheTag} {
+ # This could be table-driven I think but for now the switches
+ # should work fine.
+
+ # Normalize tag information for later comparisons. Also remove
+ # superfluous whitespace. Don't forget to decode the standard
+ # entities.
+
+ set tag [string tolower $tag]
+ set textBehindTheTag [string trim $textBehindTheTag]
+ if {$textBehindTheTag != {}} {
+ set text [mapEscapes $textBehindTheTag]
+ }
+
+ if {"$slash" == "/"} {
+ # Handle closing tags. Standard operation is to pop the tag
+ # from the stack of open tags. We don't do this for </p> and
+ # </li>. As they were optional they were never pushed onto the
+ # stack (Well, actually they are just popped immediately after
+ # they were pusheed, see below).
+
+ switch -exact -- $tag {
+ base - option - meta - li - p {
+ # Ignore, nothing to do.
+ }
+ default {
+ # The moment we get a closing tag which does not match
+ # the tag on the stack we have two possibilities on how
+ # this came into existence to choose from:
+ #
+ # a) A tag is now closed but was never opened.
+ # b) A tag requiring an end tag was opened but the end
+ # tag was omitted and we now are at a tag which was
+ # opened before the one with the omitted end tag.
+
+ # NOTE:
+ # Pages delivered from the amazon.uk site contain both
+ # cases: </a> without opening, <b> & <font> without
+ # closing. Another error: <a><b></a></b>, i.e. overlapping
+ # tags. Fortunately this can be handled by the algorithm
+ # below, in two cycles, one of which is case (b), followed
+ # by case (a). It seems as if Amazon/UK believes that visual
+ # markup like <b> and <font> is an option (switch-on) instead
+ # of a region.
+
+ # Algorithm used here to deal with these:
+ # 1) Search whole stack for the matching opening tag.
+ # If there is one assume case (b) and pop everything
+ # until and including this opening tag.
+ # 2) If no matching opening tag was found assume case
+ # (a) and ignore the tag.
+ #
+ # Part (1) also subsumes the normal case, i.e. the
+ # matching tag is at the top of the stack.
+
+ set nodes [::htmlparse::tags peek [::htmlparse::tags size]]
+ # Note: First item is top of stack, last item is bottom of stack !
+ # (This behaviour of tcllib stacks is not documented
+ # -> we should update the manpage).
+
+ #foreach n $nodes {lappend tstring [p get $n -key type]}
+ #puts stderr --[join $tstring]--
+
+ set level 1
+ set found 0
+ foreach n $nodes {
+ set type [$tree get $n type]
+ if {0 == [string compare $tag $type]} {
+ # Found an earlier open tag -> (b).
+ set found 1
+ break
+ }
+ incr level
+ }
+ if {$found} {
+ ::htmlparse::tags pop $level
+ if {$level > 1} {
+ #foreach n $nodes {lappend tstring [$tree get $n type]}
+ #puts stderr "\tdesync at <$tag> ($tstring) => pop $level"
+ }
+ } else {
+ #foreach n $nodes {lappend tstring [$tree get $n type]}
+ #puts stderr "\tdesync at <$tag> ($tstring) => ignore"
+ }
+ }
+ }
+
+ # If there is text behind a closing tag X it belongs to the
+ # parent tag of X.
+
+ if {$textBehindTheTag != {}} {
+ # Attach the text behind the closing tag to the reopened
+ # context.
+
+ set pcd [$tree insert [::htmlparse::tags peek] end]
+ $tree set $pcd type PCDATA
+ $tree set $pcd data $textBehindTheTag
+ }
+
+ } else {
+ # Handle opening tags. The standard operation for most is to
+ # push them onto the stack and thus open a nested context.
+ # This does not happen for both the optional tags (p, li) and
+ # the ones which don't have closing tags (meta, br, option,
+ # input, area, img).
+ #
+ # The text coming with the tag will be added after the tag if
+ # it is a tag without a matching close, else it will be added
+ # as a node below the tag (as it is the region between the
+ # opening and closing tag and thus nested inside). Empty text
+ # is ignored under all circcumstances.
+
+ set node [$tree insert [::htmlparse::tags peek] end]
+ $tree set $node type $tag
+ $tree set $node data $param
+
+ if {$textBehindTheTag != {}} {
+ switch -exact -- $tag {
+ input - area - img - br {
+ set pcd [$tree insert [::htmlparse::tags peek] end]
+ }
+ default {
+ set pcd [$tree insert $node end]
+ }
+ }
+ $tree set $pcd type PCDATA
+ $tree set $pcd data $textBehindTheTag
+ }
+
+ ::htmlparse::tags push $node
+
+ # Special handling: <p>, <li> may have no closing tag => pop
+ # : them immediately.
+ #
+ # Special handling: <meta>, <br>, <option>, <input>, <area>,
+ # : <img>: no closing tags for these.
+
+ switch -exact -- $tag {
+ hr - base - meta - li - br - option - input - area - img - p - h1 - h2 - h3 - h4 - h5 - h6 {
+ ::htmlparse::tags pop
+ }
+ default {}
+ }
+ }
+}
+
+# htmlparse::removeVisualFluff --
+#
+# This command walks a tree as generated by '::htmlparse::2tree'
+# and removes all the nodes which represent visual tags and not
+# structural ones. The purpose of the command is to make the
+# tree easier to navigate without getting bogged down in visual
+# information not relevant to the search.
+#
+# Arguments:
+# tree The name of the tree to cut down.
+#
+# Side Effects:
+# Modifies the specified tree.
+#
+# Results:
+# None.
+
+proc ::htmlparse::removeVisualFluff {tree} {
+ $tree walk root -order post n {
+ ::htmlparse::RemoveVisualFluff $tree $n
+ }
+ return
+}
+
+# htmlparse::removeFormDefs --
+#
+# Like '::htmlparse::removeVisualFluff' this command is here to
+# cut down on the size of the tree as generated by
+# '::htmlparse::2tree'. It removes all nodes representing forms
+# and form elements.
+#
+# Arguments:
+# tree The name of the tree to cut down.
+#
+# Side Effects:
+# Modifies the specified tree.
+#
+# Results:
+# None.
+
+proc ::htmlparse::removeFormDefs {tree} {
+ $tree walk root -order post n {
+ ::htmlparse::RemoveFormDefs $tree $n
+ }
+ return
+}
+
+# htmlparse::RemoveVisualFluff --
+#
+# Internal helper command to
+# '::htmlparse::removeVisualFluff'. Does the actual work.
+#
+# Arguments:
+# tree The name of the tree currently processed
+# node The name of the node to look at.
+#
+# Side Effects:
+# Modifies the specified tree.
+#
+# Results:
+# None.
+
+proc ::htmlparse::RemoveVisualFluff {tree node} {
+ switch -exact -- [$tree get $node type] {
+ hmstart - html - font - center - div - sup - b - i {
+ # Removes the node, but does not affect the nodes below
+ # it. These are just made into chiildren of the parent of
+ # this node, in its place.
+
+ $tree cut $node
+ }
+ script - option - select - meta - map - img {
+ # Removes this node and everything below it.
+ $tree delete $node
+ }
+ default {
+ # Ignore tag
+ }
+ }
+}
+
+# htmlparse::RemoveFormDefs --
+#
+# Internal helper command to
+# '::htmlparse::removeFormDefs'. Does the actual work.
+#
+# Arguments:
+# tree The name of the tree currently processed
+# node The name of the node to look at.
+#
+# Side Effects:
+# Modifies the specified tree.
+#
+# Results:
+# None.
+
+proc ::htmlparse::RemoveFormDefs {tree node} {
+ switch -exact -- [$tree get $node type] {
+ form {
+ $tree delete $node
+ }
+ default {
+ # Ignore tag
+ }
+ }
+}
+
+# htmlparse::Reorder --
+
+# Internal helper command to '::htmlparse::2tree'. Moves the
+# nodes between p/p, li/li and h<i> sequences below the
+# paragraphs and items. IOW, corrects misconstructions for
+# the optional node types.
+#
+# Arguments:
+# tree The name of the tree currently processed
+# node The name of the node to look at.
+#
+# Side Effects:
+# Modifies the specified tree.
+#
+# Results:
+# None.
+
+proc ::htmlparse::Reorder {tree node} {
+ switch -exact -- [set tp [$tree get $node type]] {
+ h1 - h2 - h3 - h4 - h5 - h6 - p - li {
+ # Look for right siblings until the next node with a
+ # similar type (or end of level) and move these below this
+ # node.
+
+ while {1} {
+ set sibling [$tree next $node]
+ if {
+ ($sibling == {}) ||
+ ([lsearch -exact {h1 h2 h3 h4 h5 h6 p li} [$tree get $sibling type]] != -1)
+ } {
+ break
+ }
+ $tree move $node end $sibling
+ }
+ }
+ default {
+ # Ignore tag
+ }
+ }
+}
+
+# ### ######### ###########################
+
+package provide htmlparse 1.2.2
diff --git a/tcllib/modules/htmlparse/htmlparse.test b/tcllib/modules/htmlparse/htmlparse.test
new file mode 100644
index 0000000..e1d26bd
--- /dev/null
+++ b/tcllib/modules/htmlparse/htmlparse.test
@@ -0,0 +1,577 @@
+# -*- tcl -*-
+# Tests for the HTML parser
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2001-2005 by ActiveState Tool Corp.
+# All rights reserved.
+#
+# RCS: @(#) $Id: htmlparse.test,v 1.27 2012/08/02 22:21:54 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.3 ; # htmlparse itself is 8.2+, however struct::* need 8.3+
+testsNeedTcltest 1.0
+
+support {
+ use struct/list.tcl struct::list
+
+ useAccel [useTcllibC] struct/tree.tcl struct::tree
+ TestAccelInit struct::tree
+
+ use struct/queue.tcl struct::queue
+ use struct/stack.tcl struct::stack
+ use cmdline/cmdline.tcl cmdline
+}
+testing {
+ useLocal htmlparse.tcl htmlparse
+}
+
+# -------------------------------------------------------------------------
+
+set html1 {<html><head><title>foo</title><meta name="..."></head><body><h2>Header<p>burble</body></html>}
+set html2 {<html><head><title>foo</title><meta name="..."></head><body><h2>Header<p>burble</b}
+set html3 {<html><head><title>foo</title><meta name="..."></head><body><h2>Header<p><b>burble</b><p><form><input type="..."></form></body></html>}
+
+# Simple remembering callback ...
+proc cb {args} {global tags ; lappend tags $args}
+
+proc tlist {t n} {
+ set tt [list]
+ foreach c [$t children $n] {
+ lappend tt [$t get $c synth]
+ }
+ $t set $n -key synth [list [$t get $n type] $tt]
+}
+
+# -------------------------------------------------------------------------
+
+test htmlparse-1.0 {basic errors} {
+ catch {htmlparse::parse} msg
+ set msg
+} {::htmlparse::parse : html string missing}
+
+test htmlparse-1.2 {basic errors} {
+ catch {htmlparse::parse -cmd "" -split -1 -incvar "" -vroot "" -queue "" a b} msg
+ set msg
+} {::htmlparse::parse : -cmd illegal argument (empty)}
+
+test htmlparse-1.3 {basic errors} {
+ catch {htmlparse::parse -split -1 -incvar "" -vroot "" -queue "" a b} msg
+ set msg
+} {::htmlparse::parse : -split illegal argument (<= 0)}
+
+test htmlparse-1.4 {basic errors} {
+ catch {htmlparse::parse -incvar "" -vroot "" -queue "" a b} msg
+ set msg
+} {::htmlparse::parse : -incvar illegal argument (empty)}
+
+test htmlparse-1.5 {basic errors} {
+ catch {htmlparse::parse -vroot "" -queue "" a b} msg
+ set msg
+} {::htmlparse::parse : -vroot illegal argument (empty)}
+
+test htmlparse-1.6 {basic errors} {
+ catch {htmlparse::parse -queue "" a b} msg
+ set msg
+} {::htmlparse::parse : -queue illegal argument (empty)}
+
+test htmlparse-1.7 {basic errors} {
+ catch {htmlparse::parse a b} msg
+ set msg
+} {::htmlparse::parse : to many arguments behind the options, expected one}
+
+test htmlparse-1.8 {basic errors} {
+ catch {htmlparse::parse -foo a} msg
+ set msg
+} {::htmlparse::parse : Illegal option "-foo"}
+
+test htmlparse-1.9 {parsing errors} {
+ catch {htmlparse::parse -cmd cb $html2} msg
+ set msg
+} {::htmlparse::parse : HTML is incomplete, option -incvar is missing}
+
+
+test htmlparse-2.0 {normal parsing} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot foo $html1
+ set tags
+} [list \
+ [list foo {} {} {}] \
+ [list html {} {} {}] \
+ [list head {} {} {}] \
+ [list title {} {} foo] \
+ [list title / {} {}] \
+ [list meta {} {name="..."} {}] \
+ [list head / {} {}] \
+ [list body {} {} {}] \
+ [list h2 {} {} Header] \
+ [list p {} {} burble] \
+ [list body / {} {}] \
+ [list html / {} {}] \
+ [list foo / {} {}] \
+ ]
+
+test htmlparse-2.1 {normal parsing} {
+ set tags [list]
+ htmlparse::parse -cmd {cb @} -vroot foo $html1
+ set tags
+} [list \
+ [list @ foo {} {} {}] \
+ [list @ html {} {} {}] \
+ [list @ head {} {} {}] \
+ [list @ title {} {} foo] \
+ [list @ title / {} {}] \
+ [list @ meta {} {name="..."} {}] \
+ [list @ head / {} {}] \
+ [list @ body {} {} {}] \
+ [list @ h2 {} {} Header] \
+ [list @ p {} {} burble] \
+ [list @ body / {} {}] \
+ [list @ html / {} {}] \
+ [list @ foo / {} {}] \
+ ]
+
+test htmlparse-2.2 {normal parsing} {
+ set tags [list]
+ set incomplete ""
+ htmlparse::parse -cmd cb -incvar incomplete -vroot foo $html2
+ list $tags $incomplete
+} [list [list \
+ [list foo {} {} {}] \
+ [list html {} {} {}] \
+ [list head {} {} {}] \
+ [list title {} {} foo] \
+ [list title / {} {}] \
+ [list meta {} {name="..."} {}] \
+ [list head / {} {}] \
+ [list body {} {} {}] \
+ [list h2 {} {} Header] \
+ [list p {} {} burble] \
+ [list foo / {} {}] \
+ ] "</b"]
+
+test htmlparse-3.0 {incremental parsing} {
+ set tags [list]
+ catch {q destroy}
+ struct::queue q
+ htmlparse::parse -cmd cb -vroot foo -queue q -split 1 $html1
+
+ list $tags [q size] [q peek [q size]]
+} {{} 12 {{{cb} @win@ {foo} {} {} {}} {{cb} @win@ {html} {} {} {}} {{cb} @win@ {head} {} {} {}} {{cb} @win@ {title} {} {} {foo}} {{cb} @win@ {title} {/} {} {}} {{cb} @win@ {meta} {} {name="..."} {}} {{cb} @win@ {head} {/} {} {}} {{cb} @win@ {body} {} {} {}} {{cb} @win@ {h2} {} {} {Header}} {{cb} @win@ {p} {} {} {burble}} {{cb} @win@ {body} {/} {} {}} {{cb} @win@ {html} {/} {} {}}}}
+
+test htmlparse-3.1 {incremental parsing} {
+ set tags [list]
+ catch {q destroy}
+ struct::queue q
+ htmlparse::parse -cmd cb -vroot foo -queue q -split 2 $html1
+
+ list $tags [q size] [q peek [q size]]
+} {{} 6 {{{cb} @win@ {foo} {} {} {}
+{cb} @win@ {html} {} {} {}} {{cb} @win@ {head} {} {} {}
+{cb} @win@ {title} {} {} {foo}} {{cb} @win@ {title} {/} {} {}
+{cb} @win@ {meta} {} {name="..."} {}} {{cb} @win@ {head} {/} {} {}
+{cb} @win@ {body} {} {} {}} {{cb} @win@ {h2} {} {} {Header}
+{cb} @win@ {p} {} {} {burble}} {{cb} @win@ {body} {/} {} {}
+{cb} @win@ {html} {/} {} {}}}}
+
+test htmlparse-3.2 {incremental parsing} {
+ set tags [list]
+ set incomplete ""
+ catch {q destroy}
+ struct::queue q
+
+ htmlparse::parse -cmd cb -incvar incomplete -vroot foo -queue q -split 1 $html2
+ list $tags [q size] [q peek [q size]] $incomplete
+} {{} 10 {{{cb} @win@ {foo} {} {} {}} {{cb} @win@ {html} {} {} {}} {{cb} @win@ {head} {} {} {}} {{cb} @win@ {title} {} {} {foo}} {{cb} @win@ {title} {/} {} {}} {{cb} @win@ {meta} {} {name="..."} {}} {{cb} @win@ {head} {/} {} {}} {{cb} @win@ {body} {} {} {}} {{cb} @win@ {h2} {} {} {Header}} {{cb} @win@ {p} {} {} {burble}}} </b}
+
+test htmlparse-3.3 {incremental parsing} {
+ set tags [list]
+ set incomplete ""
+ catch {q destroy}
+ struct::queue q
+
+ htmlparse::parse -cmd {cb @} -incvar incomplete -vroot foo -queue q -split 1 $html2
+ list $tags [q size] [q peek [q size]] $incomplete
+} {{} 10 {{{cb} {@} @win@ {foo} {} {} {}} {{cb} {@} @win@ {html} {} {} {}} {{cb} {@} @win@ {head} {} {} {}} {{cb} {@} @win@ {title} {} {} {foo}} {{cb} {@} @win@ {title} {/} {} {}} {{cb} {@} @win@ {meta} {} {name="..."} {}} {{cb} {@} @win@ {head} {/} {} {}} {{cb} {@} @win@ {body} {} {} {}} {{cb} {@} @win@ {h2} {} {} {Header}} {{cb} {@} @win@ {p} {} {} {burble}}} </b}
+
+
+proc cb_foo {args} {
+ if {[string equal [lindex $args 1] FOO]} {return }
+ global tags ; lappend tags $args
+}
+
+test htmlparse-3.4 {incremental parsing} {
+ set tags [list]
+ set incomplete ""
+ catch {q destroy}
+ struct::queue q
+
+ set lines [list]
+ lappend lines {<root>}
+ lappend lines {<tag>Hi there</tag>}
+ lappend lines {<tag}
+ lappend lines {>Hi there<}
+ lappend lines {/tag></root>}
+
+ foreach l $lines {
+ htmlparse::parse -cmd {cb_foo @} -incvar incomplete -vroot FOO $l
+ }
+ list $tags $incomplete
+} {{{@ root {} {} {}} {@ tag {} {} {Hi there}} {@ tag / {} {}} {@ tag {} {} {Hi there}} {@ tag / {} {}} {@ root / {} {}}} {}}
+
+
+# Don't test: ::htmlparse::debugCallback
+
+test htmlparse-4.0 {predefined (HTML 2.0) entities} {
+ ::htmlparse::mapEscapes {&gt;&lt;&amp;}
+} {><&}
+
+test htmlparse-4.1 {non entities unharmed} {
+ ::htmlparse::mapEscapes {this&that&those as well}
+} {this&that&those as well}
+
+test htmlparse-4.2 {loose SGML parsing for entities} {
+ ::htmlparse::mapEscapes "&amp&amp &amp\n&amp"
+} {&& &
+&}
+
+test htmlparse-4.3 {numeric, decimal entities} {
+ ::htmlparse::mapEscapes {emdash: &#8212; euro: &#8364;}
+} "emdash: \u2014 euro: \u20ac"
+
+test htmlparse-4.4 {numeric, hexadecimal entities} {
+ ::htmlparse::mapEscapes {emdash: &#x2014; euro: &#x20ac;}
+} "emdash: \u2014 euro: \u20ac"
+
+test htmlparse-4.5 {Unknown named entities shall not be mangled} {
+ ::htmlparse::mapEscapes {I am &FOO;! You are &FOO
+We all are &FOO}
+} {I am &FOO;! You are &FOO
+We all are &FOO}
+
+test htmlparse-4.6 {numeric, decimal entities; out-of-range} {
+ ::htmlparse::mapEscapes {too big: &#89998; and unharmed}
+} {too big: &#89998; and unharmed}
+
+test htmlparse-4.7 {numeric, hexadecimal entities; out-of-range} {
+ ::htmlparse::mapEscapes {too big: &#xffff; and unharmed}
+} {too big: &#xffff; and unharmed}
+
+# Bug #1039961
+test htmlparse-4.8 {numeric character references, leading zeros} {
+ ::htmlparse::mapEscapes {Ampersand: &#038;.}
+} {Ampersand: &.}
+
+test htmlparse-4.9 {XHTML/XML entity apos, bug 2028993} {
+ ::htmlparse::mapEscapes {Apostrophe &apos;}
+} {Apostrophe '}
+
+# Ticket 86c971506c - HTML 5.1 entities
+test htmlparse-4.10 {predefined (HTML 5.1) entities} {
+ ::htmlparse::mapEscapes {&blacktriangle;&hbar;}
+} "\u25b4\u210f"
+
+# Bug #861277
+test htmlparse-6.1 {Backslashes in content} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<p>\\</p>"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list p {} {} {&#92;}] \
+ [list p / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-6.2 {More backslashes in content} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<p>\\abcde</p>"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list p {} {} {&#92;abcde}] \
+ [list p / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-6.3 {Substitutions from backslashes in content} {
+ htmlparse::mapEscapes {&#92;abcde}
+} {\abcde}
+
+test htmlparse-6.4 {$ in content} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html {<p>$abcde</p>}
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list p {} {} {$abcde}] \
+ [list p / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-6.5 {Substitutions from $ in content} {
+ htmlparse::mapEscapes {$abcde}
+} {$abcde}
+
+test htmlparse-6.6 {Braces in content} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<p>\{\}</p>"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list p {} {} {&#123;&#125;}] \
+ [list p / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-6.7 {More braces in content} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<p>\{abcde\}</p>"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list p {} {} {&#123;abcde&#125;}] \
+ [list p / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-6.8 {Substitutions from braces in content} {
+ htmlparse::mapEscapes {&#123;abcde&#125;}
+} {{abcde}}
+
+# Tcllib SF Bug 861287 - Processing of comments.
+test htmlparse-7.1 {html comments} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<pre>&<!-- a comment --></pre>"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list pre {} {} &] \
+ [list pre / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-7.2 {html comments} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<pre>&</pre><!-- a comment -->"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list pre {} {} &] \
+ [list pre / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-7.3 {html comments} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<!-- a comment --><pre>&</pre>"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list pre {} {} &] \
+ [list pre / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-7.4 {html comments} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<pre>&<!-- a comment -- ></pre>"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list pre {} {} &] \
+ [list pre / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-7.5 {html comments} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<pre>&</pre><!-- a comment -- >"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list pre {} {} &] \
+ [list pre / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-7.6 {html comments} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<!-- a comment -- ><pre>&</pre>"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list pre {} {} &] \
+ [list pre / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-8.1 {html comments} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<pre>&<-- no comment --></pre>"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list pre {} {} {&&lt;-- no comment --&gt;}] \
+ [list pre / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-8.2 {html comments} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<pre>&</pre><-- no comment -->"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list pre {} {} &] \
+ [list pre / {} {&lt;-- no comment --&gt;}] \
+ [list html / {} {}] ]
+
+test htmlparse-8.3 {html comments} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<-- no comment --><pre>&</pre>"
+ set tags
+} [list \
+ [list html {} {} {&lt;-- no comment --&gt;}] \
+ [list pre {} {} &] \
+ [list pre / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-8.4 {html comments} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<pre>&<-- no comment -- ></pre>"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list pre {} {} {&&lt;-- no comment -- &gt;}] \
+ [list pre / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-8.5 {html comments} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<pre>&</pre><-- no comment -- >"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list pre {} {} &] \
+ [list pre / {} {&lt;-- no comment -- &gt;}] \
+ [list html / {} {}] ]
+
+test htmlparse-8.6 {html comments} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<-- no comment -- ><pre>&</pre>"
+ set tags
+} [list \
+ [list html {} {} {&lt;-- no comment -- &gt;}] \
+ [list pre {} {} &] \
+ [list pre / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-9.0 {handle empty tags} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<b><a/></b>"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list b {} {} {}] \
+ [list a {} {} {}] \
+ [list a / {} {}] \
+ [list b / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-9.1 {handle empty tags, attributes} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<b><a href=\"b\"/></b>"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list b {} {} {}] \
+ [list a {} {href="b"} {}] \
+ [list a / {} {}] \
+ [list b / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-9.2 {handle empty tags, text coming after} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<b><a/>xx</b>"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list b {} {} {}] \
+ [list a {} {} {}] \
+ [list a / {} xx] \
+ [list b / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-9.3 {handle empty tags, text coming before} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<b>xx<a/></b>"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list b {} {} xx] \
+ [list a {} {} {}] \
+ [list a / {} {}] \
+ [list b / {} {}] \
+ [list html / {} {}] ]
+
+test htmlparse-10.0 {bad html, raising error} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html "<a<a/>>"
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list a<a {} {} {}] \
+ [list a<a / {} {>}] \
+ [list html / {} {}] ]
+
+test htmlparse-10.1 {bad html, varying argument counts} {
+ set tags [list]
+ htmlparse::parse -cmd cb -vroot html {<a b="<a"/><a>}
+ set tags
+} [list \
+ [list html {} {} {}] \
+ [list a {} {b="<a"} {}] \
+ [list a / {} {}] \
+ [list a {} {} {}] \
+ [list html / {} {}] ]
+
+
+set extraarg {a & b \1 \0 \\1 \\0 \} $ [ ] }
+test htmlparse-11.0 {metachar callback} {
+ set tags [list]
+ htmlparse::parse -cmd [list cb $extraarg] -vroot html {<a b="a">x</a>}
+ set tags
+} [list \
+ [list $extraarg html {} {} {}] \
+ [list $extraarg a {} {b="a"} {x}] \
+ [list $extraarg a / {} {}] \
+ [list $extraarg html / {} {}] ]
+
+
+# -------------------------------------------------------------------------
+# In this section we run all the tests depending on a struct::tree,
+# and thus have to test all the available implementations.
+
+set tests [file join [file dirname [info script]] htmlparse.tree_testsuite]
+
+catch {memory validate on}
+
+TestAccelDo struct::tree impl {
+ # The global variable 'impl' is part of the public API the
+ # testsuit (in htmlparse_tree.testsuite) can expect from the
+ # environment.
+
+ namespace import -force struct::tree
+
+ set usec [time {source $tests} 1]
+
+ #puts "$impl:\t$usec"
+}
+
+catch {memory validate off}
+
+unset usec
+unset tests
+
+# -------------------------------------------------------------------------
+
+# Take a look at the cache.
+#parray ::htmlparse::splitdata
+TestAccelExit struct::tree
+testsuiteCleanup
+return
diff --git a/tcllib/modules/htmlparse/htmlparse.tree_testsuite b/tcllib/modules/htmlparse/htmlparse.tree_testsuite
new file mode 100644
index 0000000..4cf19ef
--- /dev/null
+++ b/tcllib/modules/htmlparse/htmlparse.tree_testsuite
@@ -0,0 +1,53 @@
+# -*- tcl -*- htmlparse.test:
+# tests for the interaction of html parser and tree structure.
+
+test htmlparse-${impl}-5.0 {conversion to tree} {
+ struct::tree t
+ ::htmlparse::2tree $html3 t
+
+ set tx [list]
+ t walk root n {
+ lappend tx [list [t depth $n] [t get $n type]]
+ }
+ t destroy
+ set tx
+} [list \
+ {0 root} {1 hmstart} {2 html} {3 head} \
+ {4 title} {5 PCDATA} {4 meta} {3 body} \
+ {4 h2} {5 PCDATA} \
+ {4 p} {5 b} {6 PCDATA} \
+ {4 p} {5 form} {6 input}]
+
+test htmlparse-${impl}-5.1 {conversion to tree} {
+ struct::tree t
+ ::htmlparse::2tree $html3 t
+ ::htmlparse::removeVisualFluff t
+
+ set tx [list]
+ t walk root n {
+ lappend tx [list [t depth $n] [t get $n type]]
+ }
+ t destroy
+ set tx
+} [list \
+ {0 root} {1 head} {2 title} {3 PCDATA} \
+ {1 body} {2 h2} {3 PCDATA} \
+ {2 p} {3 PCDATA} \
+ {2 p} {3 form} {4 input}]
+
+test htmlparse-${impl}-5.2 {conversion to tree} {
+ struct::tree t
+ ::htmlparse::2tree $html3 t
+ ::htmlparse::removeVisualFluff t
+ ::htmlparse::removeFormDefs t
+
+ set tx [list]
+ t walk root n {
+ lappend tx [list [t depth $n] [t get $n type]]
+ }
+ t destroy
+ set tx
+} [list \
+ {0 root} {1 head} {2 title} {3 PCDATA} \
+ {1 body} {2 h2} {3 PCDATA} \
+ {2 p} {3 PCDATA} {2 p}]
diff --git a/tcllib/modules/htmlparse/pkgIndex.tcl b/tcllib/modules/htmlparse/pkgIndex.tcl
new file mode 100644
index 0000000..e5993b1
--- /dev/null
+++ b/tcllib/modules/htmlparse/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded htmlparse 1.2.2 [list source [file join $dir htmlparse.tcl]]
diff --git a/tcllib/modules/http/ChangeLog b/tcllib/modules/http/ChangeLog
new file mode 100644
index 0000000..74f393e
--- /dev/null
+++ b/tcllib/modules/http/ChangeLog
@@ -0,0 +1,159 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2012-05-28 Andreas Kupries <andreask@activestate.com>
+
+ * autoproxy.tcl: Fixed bug where https proxying was attempted
+ * autoproxy.man: in the face of a domain exception. The TLS
+ * pkgIndex.tcl: setup code has to 'filter' properly. Further
+ check for existence of state(code), it may not exist (Server
+ accepts initial connection, then eof's during the TLS
+ handshake). Bumped version number to 1.5.3.
+
+2012-02-08 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * autoproxy.tcl: Applied suggested fix from bug #3313923 to fix
+ handling of the -authProc option.
+
+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 ========================
+ *
+
+2010-10-26 Andreas Kupries <andreask@activestate.com>
+
+ * autoproxy.man: [Bug 3094654]: Made the spelling of options
+ consistent, all using their '-'.
+
+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 ========================
+ *
+
+2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * autoproxy.pcx: New file. Syntax definitions for the public
+ commands of the autoproxy package.
+
+2008-02-29 Andreas Kupries <andreask@activestate.com>
+
+ * autoproxy.tcl (::autoproxy::init, ::autoproxy::GetWin32Proxy):
+ Added tclchecker pragmas to suppress false non-portable command
+ warnings.
+
+ * autoproxy.tcl (::autoproxy::cget): Removed bogus closing
+ * autoproxy.man: bracket. Bumped version to 1.5.1
+ * pkgIndex.tcl:
+
+2008-02-27 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * autoproxy.tcl: Fix title usage in defAuthProc
+
+2008-02-05 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * autoproxy.man: Increment version to 1.5 and document.
+ * autoproxy.tcl: Fixed architectural problems that prevented the
+ http registered command from having tls package options
+ appended. This makes an incompatible change to the tls_connect
+ command and the host and port must now be the last two options.
+ * autoproxy.tcl: Re-organised the tls_connect code to split out
+ the connect and the tls parts to create a tunnel_connect command
+ that can form a non-SSL tunnel through a proxy.
+
+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>
+
+ * autoproxy.man: Fixed all warnings due to use of now deprecated
+ commands. Added a section about how to give feedback.
+
+2007-03-12 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * autoproxy.tcl: Removed even the demo reference to BWidgets to
+ avoid confising the auto-dependency checker. Rearranged the tls
+ connection code to permit use outside of the http package as
+ tls_connect.
+ * autoproxy.man: Documented the tls functions.
+ * pkgIndex.tcl: Increment version to 1.4
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * autoproxy.man: Bumped version to 1.3
+ * autoproxy.tcl:
+ * pkgIndex.tcl:
+
+2006-04-20 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * autoproxy.tcl: Added a tls_socket procedure that can use
+ registered as the protocol handler for https
+ with the core http package and will do the right
+ thing when a proxy is in use.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-02-17 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * autoproxy.tcl: Dealt with the parsing requirements as mentioned
+ * autoproxy.man: in bug #1099162. In theory we may have different
+ * pkgIndex.tcl: proxy settings for https and http (and other
+ protocols) but to deal with these we will need to change the http
+ package so we do not deal with them now.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-07-19 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * autoproxy.tcl: Removed the stuff for Digest and NTLM until it
+ is working properly. Added an authProc configuration option to
+ permit application code to specify a procedure to get
+ authentication information from the user.
+
+2004-07-19 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * autoproxy.tcl: Fix the version number.
+
+2004-07-17 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * autoproxy.tcl: Import of the wiki version.
+ * autoproxy.man: Wrote a manual page.
diff --git a/tcllib/modules/http/autoproxy.man b/tcllib/modules/http/autoproxy.man
new file mode 100644
index 0000000..2401cf1
--- /dev/null
+++ b/tcllib/modules/http/autoproxy.man
@@ -0,0 +1,199 @@
+[manpage_begin autoproxy n 1.5.3]
+[see_also http(n)]
+[keywords authentication]
+[keywords http]
+[keywords proxy]
+[moddesc {HTTP protocol helper modules}]
+[titledesc {Automatic HTTP proxy usage and authentication}]
+[category Networking]
+[require Tcl 8.2]
+[require http [opt 2.0]]
+[require autoproxy [opt 1.5.3]]
+[description]
+[para]
+
+This package attempts to automate the use of HTTP proxy servers in Tcl
+HTTP client code. It tries to initialize the web access settings from
+system standard locations and can be configured to negotiate
+authentication with the proxy if required.
+
+[para]
+
+On Unix the standard for identifying the local HTTP proxy server
+seems to be to use the environment variable http_proxy or ftp_proxy and
+no_proxy to list those domains to be excluded from proxying.
+On Windows we can retrieve the Internet Settings values from the registry
+to obtain pretty much the same information.
+With this information we can setup a suitable filter procedure for the
+Tcl http package and arrange for automatic use of the proxy.
+
+[para]
+
+There seem to be a number of ways that the http_proxy environment
+variable may be set up. Either a plain host:port or more commonly a
+URL and sometimes the URL may contain authentication parameters or
+these may be requested from the user or provided via http_proxy_user
+and http_proxy_pass. This package attempts to deal with all these
+schemes. It will do it's best to get the required parameters from the
+environment or registry and if it fails can be reconfigured.
+
+[include ../common-text/tls-security-notes.inc]
+
+[section "COMMANDS"]
+
+[list_begin definitions]
+
+[call [cmd ::autoproxy::init]]
+
+Initialize the autoproxy package from system resources. Under unix
+this means we look for environment variables. Under windows we look
+for the same environment variables but also look at the registry
+settings used by Internet Explorer.
+
+[call [cmd ::autoproxy::cget] [arg "-option"]]
+
+Retrieve individual package configuration options. See [sectref OPTIONS].
+
+[call [cmd ::autoproxy::configure] [opt "-option [arg value]"]]
+
+Configure the autoproxy package. Calling [cmd configure] with no
+options will return a list of all option names and values.
+See [sectref OPTIONS].
+
+[call [cmd ::autoproxy::tls_connect] [arg args]]
+
+Connect to a secure socket through a proxy. HTTP proxy servers permit
+the use of the CONNECT HTTP command to open a link through the proxy
+to the target machine. This function hides the details. For use with
+the http package see [cmd tls_socket].
+[para]
+The [arg args] list may contain any of the [package tls] package options but
+must end with the host and port as the last two items.
+
+[call [cmd ::autoproxy::tunnel_connect] [arg args]]
+
+Connect to a target host throught a proxy. This uses the same CONNECT
+HTTP command as the [cmd tls_connect] but does not promote the link
+security once the connection is established.
+[para]
+The [arg args] list may contain any of the [package tls] package options but
+must end with the host and port as the last two items.
+[para]
+Note that many proxy servers will permit CONNECT calls to a limited
+set of ports - typically only port 443 (the secure HTTP port).
+
+[call [cmd ::autoproxy::tls_socket] [arg args]]
+
+This function is to be used to register a proxy-aware secure socket
+handler for the https protocol. It may only be used with the Tcl http
+package and should be registered using the http::register command (see
+the examples below). The job of actually creating the tunnelled
+connection is done by the tls_connect command and this may be used
+when not registering with the http package.
+
+[list_end]
+
+[section {OPTIONS}]
+
+[list_begin options]
+
+[opt_def -host hostname]
+[opt_def -proxy_host hostname]
+Set the proxy hostname. This is normally set up by [cmd init] but may
+be configured here as well.
+
+[opt_def -port number]
+[opt_def -proxy_port number]
+Set the proxy port number. This is normally set up by [cmd init].
+e.g. [cmd configure] [option -port] [arg 3128]
+
+[opt_def -no_proxy list]
+You may manipulate the [option no_proxy] list that was setup by
+[cmd init]. The value of this option is a tcl list of
+strings that are matched against the http request host using the tcl
+[cmd "string match"] command. Therefore glob patterns are permitted.
+For instance, [cmd configure] [option -no_proxy] [arg "*.localdomain"]
+
+[opt_def -authProc procedure]
+This option may be used to set an application defined procedure to be
+called when [cmd configure] [option -basic] is called with either no or
+insufficient authentication details. This can be used to present a
+dialog to the user to request the additional information.
+
+[opt_def -basic]
+Following options are for configuring the Basic authentication
+scheme parameters. See [sectref "Basic Authentication"].
+
+[list_end]
+
+[section "Basic Authentication"]
+
+Basic is the simplest and most commonly use HTTP proxy authentication
+scheme. It is described in (1 section 11) and also in (2). It offers
+no privacy whatsoever and its use should be discouraged in favour of
+more secure alternatives like Digest. To perform Basic authentication
+the client base64 encodes the username and plaintext password
+separated by a colon. This encoded text is prefixed with the word
+"Basic" and a space.
+
+[para]
+
+The following options exists for this scheme:
+[list_begin options]
+[opt_def "-username" "name"]
+The username required to authenticate with the configured proxy.
+[opt_def "-password" "password"]
+The password required for the username specified.
+[opt_def "-realm" "realm"]
+This option is not used.
+[list_end]
+
+[section "EXAMPLES"]
+
+[para]
+[example {
+package require autoproxy
+autoproxy::init
+autoproxy::configure -basic -username ME -password SEKRET
+set tok [http::geturl http://wiki.tcl.tk/]
+http::data $tok
+}]
+
+[example {
+package require http
+package require tls
+package require autoproxy
+autoproxy::init
+http::register https 443 autoproxy::tls_socket
+set tok [http::geturl https://www.example.com/]
+}]
+
+[section {REFERENCES}]
+
+[list_begin enumerated]
+
+[enum]
+ Berners-Lee, T., Fielding R. and Frystyk, H.
+ "Hypertext Transfer Protocol -- HTTP/1.0",
+ RFC 1945, May 1996,
+ ([uri http://www.rfc-editor.org/rfc/rfc1945.txt])
+
+[enum]
+ Franks, J. et al.
+ "HTTP Authentication: Basic and Digest Access Authentication",
+ RFC 2617, June 1999
+ ([uri http://www.rfc-editor.org/rfc/rfc2617.txt])
+
+[list_end]
+
+[section {BUGS}]
+
+At this time only Basic authentication (1) (2) is supported. It is
+planned to add support for Digest (2) and NTLM in the future.
+
+[section AUTHORS]
+Pat Thoyts
+
+[vset CATEGORY {http :: autoproxy}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/http/autoproxy.pcx b/tcllib/modules/http/autoproxy.pcx
new file mode 100644
index 0000000..8edad89
--- /dev/null
+++ b/tcllib/modules/http/autoproxy.pcx
@@ -0,0 +1,62 @@
+# -*- tcl -*- autoproxy.pcx
+# Syntax of the commands provided by package autoproxy.
+
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register autoproxy
+pcx::tcldep 1.5.1 needs tcl 8.2
+
+namespace eval ::autoproxy {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.5.1 std ::autoproxy::cget \
+ {checkSimpleArgs 1 1 {
+ checkKeyword 1 {-host -proxy_host -port -proxy_port -no_proxy -basic -authProc}
+ }}
+pcx::check 1.5.1 std ::autoproxy::configure \
+ {checkSimpleArgs 0 -1 {
+ {checkConfigure 1 {
+ {-host checkWord}
+ {-proy_host checkWord}
+ {-port checkWholeNum}
+ {-proxy_port checkWholeNum}
+ {-no_proxy checkList}
+ {-basic {checkConfigure 0 {
+ {-username checkWord}
+ {-password checkWord}
+ {-realm checkWord}
+ }}}
+ {-authProc checkProcName}
+ }}
+ }}
+pcx::check 1.5.1 std ::autoproxy::init \
+ {checkSimpleArgs 0 2 {
+ checkWord
+ checkList
+ }}
+# TODO: Get options/syntax for tls::socket
+pcx::check 1.5.1 std ::autoproxy::tls_connect \
+ {checkSimpleArgs 0 -1 {
+ checkWord
+ }}
+# TODO: Get options/syntax for tls_connect (s.a.)
+pcx::check 1.5.1 std ::autoproxy::tls_socket \
+ {checkSimpleArgs 0 -1 {
+ checkWord
+ }}
+# TODO: Get options/syntax for tls::socket
+pcx::check 1.5.1 std ::autoproxy::tunnel_connect \
+ {checkSimpleArgs 0 -1 {
+ checkWord
+ }}
+
+# Initialization via pcx::init.
+# Use a ::autoproxy::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/http/autoproxy.tcl b/tcllib/modules/http/autoproxy.tcl
new file mode 100644
index 0000000..6cc7c08
--- /dev/null
+++ b/tcllib/modules/http/autoproxy.tcl
@@ -0,0 +1,539 @@
+# autoproxy.tcl - Copyright (C) 2002-2008 Pat Thoyts <patthoyts@users.sf.net>
+#
+# On Unix the standard for identifying the local HTTP proxy server
+# seems to be to use the environment variable http_proxy or ftp_proxy and
+# no_proxy to list those domains to be excluded from proxying.
+#
+# On Windows we can retrieve the Internet Settings values from the registry
+# to obtain pretty much the same information.
+#
+# With this information we can setup a suitable filter procedure for the
+# Tcl http package and arrange for automatic use of the proxy.
+#
+# Example:
+# package require autoproxy
+# autoproxy::init
+# set tok [http::geturl http://wiki.tcl.tk/]
+# http::data $tok
+#
+# To support https add:
+# package require tls
+# http::register https 443 ::autoproxy::tls_socket
+
+package require http; # tcl
+package require uri; # tcllib
+package require base64; # tcllib
+
+namespace eval ::autoproxy {
+ variable options
+
+ if {! [info exists options]} {
+ array set options {
+ proxy_host ""
+ proxy_port 80
+ no_proxy {}
+ basic {}
+ authProc {}
+ }
+ }
+
+ variable uid
+ if {![info exists uid]} { set uid 0 }
+
+ variable winregkey
+ set winregkey [join {
+ HKEY_CURRENT_USER
+ Software Microsoft Windows
+ CurrentVersion "Internet Settings"
+ } \\]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Obtain configuration options for the server.
+#
+proc ::autoproxy::cget {option} {
+ variable options
+ switch -glob -- $option {
+ -host -
+ -proxy_h* { set options(proxy_host) }
+ -port -
+ -proxy_p* { set options(proxy_port) }
+ -no* { set options(no_proxy) }
+ -basic { set options(basic) }
+ -authProc { set options(authProc) }
+ default {
+ set err [join [lsort [array names options]] ", -"]
+ return -code error "bad option \"$option\":\
+ must be one of -$err"
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Configure the autoproxy package settings.
+# You may only configure one type of authorisation at a time as once we hit
+# -basic, -digest or -ntlm - all further args are passed to the protocol
+# specific script.
+#
+# Of course, most of the point of this package is to fill as many of these
+# fields as possible automatically. You should call autoproxy::init to
+# do automatic configuration and then call this method to refine the details.
+#
+proc ::autoproxy::configure {args} {
+ variable options
+
+ if {[llength $args] == 0} {
+ foreach {opt value} [array get options] {
+ lappend r -$opt $value
+ }
+ return $r
+ }
+
+ while {[string match "-*" [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -host -
+ -proxy_h* { set options(proxy_host) [Pop args 1]}
+ -port -
+ -proxy_p* { set options(proxy_port) [Pop args 1]}
+ -no* { set options(no_proxy) [Pop args 1] }
+ -basic { Pop args; configure:basic $args ; break }
+ -authProc { set options(authProc) [Pop args 1] }
+ -- { Pop args; break }
+ default {
+ set opts [join [lsort [array names options]] ", -"]
+ return -code error "bad option \"$option\":\
+ must be one of -$opts"
+ }
+ }
+ Pop args
+ }
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Initialise the http proxy information from the environment or the
+# registry (Win32)
+#
+# This procedure will load the http package and re-writes the
+# http::geturl method to add in the authorisation header.
+#
+# A better solution will be to arrange for the http package to request the
+# authorisation key on receiving an authorisation reqest.
+#
+proc ::autoproxy::init {{httpproxy {}} {no_proxy {}}} {
+ global tcl_platform
+ global env
+ variable winregkey
+ variable options
+
+ # Look for standard environment variables.
+ if {[string length $httpproxy] > 0} {
+
+ # nothing to do
+
+ } elseif {[info exists env(http_proxy)]} {
+ set httpproxy $env(http_proxy)
+ if {[info exists env(no_proxy)]} {
+ set no_proxy $env(no_proxy)
+ }
+ } else {
+ if {$tcl_platform(platform) == "windows"} {
+ #checker -scope block exclude nonPortCmd
+ package require registry 1.0
+ array set reg {ProxyEnable 0 ProxyServer "" ProxyOverride {}}
+ catch {
+ # IE5 changed ProxyEnable from a binary to a dword value.
+ switch -exact -- [registry type $winregkey "ProxyEnable"] {
+ dword {
+ set reg(ProxyEnable) [registry get $winregkey "ProxyEnable"]
+ }
+ binary {
+ set v [registry get $winregkey "ProxyEnable"]
+ binary scan $v i reg(ProxyEnable)
+ }
+ default {
+ return -code error "unexpected type found for\
+ ProxyEnable registry item"
+ }
+ }
+ set reg(ProxyServer) [GetWin32Proxy http]
+ set reg(ProxyOverride) [registry get $winregkey "ProxyOverride"]
+ }
+ if {![string is bool $reg(ProxyEnable)]} {
+ set reg(ProxyEnable) 0
+ }
+ if {$reg(ProxyEnable)} {
+ set httpproxy $reg(ProxyServer)
+ set no_proxy $reg(ProxyOverride)
+ }
+ }
+ }
+
+ # If we found something ...
+ if {[string length $httpproxy] > 0} {
+ # The http_proxy is supposed to be a URL - lets make sure.
+ if {![regexp {\w://.*} $httpproxy]} {
+ set httpproxy "http://$httpproxy"
+ }
+
+ # decompose the string.
+ array set proxy [uri::split $httpproxy]
+
+ # turn the no_proxy value into a tcl list
+ set no_proxy [string map {; " " , " "} $no_proxy]
+
+ # configure ourselves
+ configure -proxy_host $proxy(host) \
+ -proxy_port $proxy(port) \
+ -no_proxy $no_proxy
+
+ # Lift the authentication details from the environment if present.
+ if {[string length $proxy(user)] < 1 \
+ && [info exists env(http_proxy_user)] \
+ && [info exists env(http_proxy_pass)]} {
+ set proxy(user) $env(http_proxy_user)
+ set proxy(pwd) $env(http_proxy_pass)
+ }
+
+ # Maybe the proxy url has authentication parameters?
+ # At this time, only Basic is supported.
+ if {[string length $proxy(user)] > 0} {
+ configure -basic -username $proxy(user) -password $proxy(pwd)
+ }
+
+ # setup and configure the http package to use our proxy info.
+ http::config -proxyfilter [namespace origin filter]
+ }
+ return $httpproxy
+}
+
+# autoproxy::GetWin32Proxy --
+#
+# Parse the Windows Internet Settings registry key and return the
+# protocol proxy requested. If the same proxy is in use for all
+# protocols, then that will be returned. Otherwise the string is
+# parsed. Example:
+# ftp=proxy:80;http=proxy:80;https=proxy:80
+#
+proc ::autoproxy::GetWin32Proxy {protocol} {
+ variable winregkey
+ #checker exclude nonPortCmd
+ set proxies [split [registry get $winregkey "ProxyServer"] ";"]
+ foreach proxy $proxies {
+ if {[string first = $proxy] == -1} {
+ return $proxy
+ } else {
+ foreach {prot host} [split $proxy =] break
+ if {[string compare $protocol $prot] == 0} {
+ return $host
+ }
+ }
+ }
+ return -code error "failed to identify an '$protocol' proxy"
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Pop the nth element off a list. Used in options processing.
+proc ::autoproxy::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# Description
+# An example user authentication procedure.
+# Returns:
+# A two element list consisting of the users authentication id and
+# password.
+proc ::autoproxy::defAuthProc {{user {}} {passwd {}} {realm {}}} {
+ if {[string length $realm] > 0} {
+ set title "Realm: $realm"
+ } else {
+ set title {}
+ }
+
+ # If you are using BWidgets then the following will do:
+ #
+ # package require BWidget
+ # return [PasswdDlg .defAuthDlg -parent {} -transient 0 \
+ # -title $title -logintext $user -passwdtext $passwd]
+ #
+ # if you just have Tk and no BWidgets --
+
+ set dlg [toplevel .autoproxy_defAuthProc -class Dialog]
+ wm title $dlg $title
+ wm withdraw $dlg
+ label $dlg.ll -text Login -underline 0 -anchor w
+ entry $dlg.le -textvariable [namespace current]::${dlg}:l
+ label $dlg.pl -text Password -underline 0 -anchor w
+ entry $dlg.pe -show * -textvariable [namespace current]::${dlg}:p
+ button $dlg.ok -text OK -default active -width -11 \
+ -command [list set [namespace current]::${dlg}:ok 1]
+ grid $dlg.ll $dlg.le -sticky news
+ grid $dlg.pl $dlg.pe -sticky news
+ grid $dlg.ok - -sticky e
+ grid columnconfigure $dlg 1 -weight 1
+ bind $dlg <Return> [list $dlg.ok invoke]
+ bind $dlg <Alt-l> [list focus $dlg.le]
+ bind $dlg <Alt-p> [list focus $dlg.pe]
+ variable ${dlg}:l $user; variable ${dlg}:p $passwd
+ variable ${dlg}:ok 0
+ wm deiconify $dlg; focus $dlg.pe; update idletasks
+ set old [::grab current]; grab $dlg
+ tkwait variable [namespace current]::${dlg}:ok
+ grab release $dlg ; if {[llength $old] > 0} {::grab $old}
+ set r [list [set ${dlg}:l] [set ${dlg}:p]]
+ unset ${dlg}:l; unset ${dlg}:p; unset ${dlg}:ok
+ destroy $dlg
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Implement support for the Basic authentication scheme (RFC 1945,2617).
+# Options:
+# -user userid - pass in the user ID (May require Windows NT domain
+# as DOMAIN\\username)
+# -password pwd - pass in the user's password.
+# -realm realm - pass in the http realm.
+#
+proc ::autoproxy::configure:basic {arglist} {
+ variable options
+ array set opts {user {} passwd {} realm {}}
+ foreach {opt value} $arglist {
+ switch -glob -- $opt {
+ -u* { set opts(user) $value}
+ -p* { set opts(passwd) $value}
+ -r* { set opts(realm) $value}
+ default {
+ return -code error "invalid option \"$opt\": must be one of\
+ -username or -password or -realm"
+ }
+ }
+ }
+
+ # If nothing was provided, try calling the authProc
+ if {$options(authProc) != {} \
+ && ($opts(user) == {} || $opts(passwd) == {})} {
+ set r [$options(authProc) $opts(user) $opts(passwd) $opts(realm)]
+ set opts(user) [lindex $r 0]
+ set opts(passwd) [lindex $r 1]
+ }
+
+ # Store the encoded string to avoid re-encoding all the time.
+ set options(basic) [list "Proxy-Authorization" \
+ [concat "Basic" \
+ [base64::encode $opts(user):$opts(passwd)]]]
+ return
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# An http package proxy filter. This attempts to work out if a request
+# should go via the configured proxy using a glob comparison against the
+# no_proxy list items. A typical no_proxy list might be
+# [list localhost *.my.domain.com 127.0.0.1]
+#
+# If we are going to use the proxy - then insert the proxy authorization
+# header.
+#
+proc ::autoproxy::filter {host} {
+ variable options
+
+ if {$options(proxy_host) == {}} {
+ return {}
+ }
+
+ foreach domain $options(no_proxy) {
+ if {[string match $domain $host]} {
+ return {}
+ }
+ }
+
+ # Add authorisation header to the request (by Anders Ramdahl)
+ catch {
+ upvar state State
+ if {$options(basic) != {}} {
+ set State(-headers) [concat $options(basic) $State(-headers)]
+ }
+ }
+ return [list $options(proxy_host) $options(proxy_port)]
+}
+
+# -------------------------------------------------------------------------
+# autoproxy::tls_connect --
+#
+# Create a connection to a remote machine through a proxy
+# if necessary. This is used by the tls_socket command for
+# use with the http package but can also be used more generally
+# provided your proxy will permit CONNECT attempts to ports
+# other than port 443 (many will not).
+# This command defers to 'tunnel_connect' to link to the target
+# host and then upgrades the link to SSL/TLS
+#
+proc ::autoproxy::tls_connect {args} {
+ variable options
+ if {[string length $options(proxy_host)] > 0} {
+ set s [eval [linsert $args 0 tunnel_connect]]
+ fconfigure $s -blocking 1 -buffering none -translation binary
+ if {[string equal "-async" [lindex $args end-2]]} {
+ eval [linsert [lrange $args 0 end-3] 0 ::tls::import $s]
+ } else {
+ eval [linsert [lrange $args 0 end-2] 0 ::tls::import $s]
+ }
+ } else {
+ set s [eval [linsert $args 0 ::tls::socket]]
+ }
+ return $s
+}
+
+# autoproxy::tunnel_connect --
+#
+# Create a connection to a remote machine through a proxy
+# if necessary. This is used by the tls_socket command for
+# use with the http package but can also be used more generally
+# provided your proxy will permit CONNECT attempts to ports
+# other than port 443 (many will not).
+# Note: this command just opens the socket through the proxy to
+# the target machine -- no SSL/TLS negotiation is done yet.
+#
+proc ::autoproxy::tunnel_connect {args} {
+ variable options
+ variable uid
+ set code ok
+
+ # args = ... host port
+ # and the host/port is the actual endpoint we want to talk to,
+ # regardless of any proxying. See our caller tls_connect for
+ # ensuring this by peeking into the http package internals.
+
+ # To handle proxying properly we have to run through 'filter'
+ # (again), to ensure that proxy exceptions are correctly taken
+ # into account.
+
+ set proxy [filter [lindex $args end-1]]
+
+ if {[llength $proxy]} {
+ foreach {proxy_host proxy_port} $proxy break
+
+ set token [namespace current]::[incr uid]
+ upvar #0 $token state
+ set state(endpoint) [lrange $args end-1 end]
+ set state(state) connect
+ set state(data) ""
+ set state(useragent) [http::config -useragent]
+ set state(sock) [::socket $proxy_host $proxy_port]
+ fileevent $state(sock) writable [namespace code [list tunnel_write $token]]
+ vwait [set token](state)
+
+ if {[string length $state(error)] > 0} {
+ set result $state(error)
+ close $state(sock)
+ unset state
+ set code error
+ } elseif {[info exists state(code)] &&
+ (($state(code) >= 300) ||
+ ($state(code) < 200))} {
+ set result [lindex $state(headers) 0]
+ regexp {HTTP/\d.\d\s+\d+\s+(.*)} $result -> result
+ close $state(sock)
+ set code error
+ } else {
+ set result $state(sock)
+ }
+ unset state
+ } else {
+ set result [eval [linsert $args 0 ::socket]]
+ }
+ return -code $code $result
+}
+
+proc ::autoproxy::tunnel_write {token} {
+ upvar #0 $token state
+ variable options
+ fileevent $state(sock) writable {}
+ if {[catch {set state(error) [fconfigure $state(sock) -error]} err]} {
+ set state(error) $err
+ }
+ if {[string length $state(error)] > 0} {
+ set state(state) error
+ return
+ }
+ fconfigure $state(sock) -blocking 0 -buffering line -translation crlf
+ foreach {host port} $state(endpoint) break
+ puts $state(sock) "CONNECT $host:$port HTTP/1.1"
+ puts $state(sock) "Host: $host"
+ if {[string length $state(useragent)] > 0} {
+ puts $state(sock) "User-Agent: $state(useragent)"
+ }
+ puts $state(sock) "Proxy-Connection: keep-alive"
+ puts $state(sock) "Connection: keep-alive"
+ if {[string length $options(basic)] > 0} {
+ puts $state(sock) [join $options(basic) ": "]
+ }
+ puts $state(sock) ""
+
+ fileevent $state(sock) readable [namespace code [list tunnel_read $token]]
+ return
+}
+
+proc ::autoproxy::tunnel_read {token} {
+ upvar #0 $token state
+ set len [gets $state(sock) line]
+ if {[eof $state(sock)]} {
+ fileevent $state(sock) readable {}
+ set state(state) eof
+ } elseif {$len == 0} {
+ set state(code) [lindex [split [lindex $state(headers) 0] { }] 1]
+ fileevent $state(sock) readable {}
+ set state(state) ok
+ } else {
+ lappend state(headers) $line
+ }
+}
+
+# autoproxy::tls_socket --
+#
+# This can be used to handle TLS connections independently of
+# proxy presence. It can only be used with the Tcl http package
+# and to use it you must do:
+# http::register https 443 ::autoproxy::tls_socket
+# After that you can use the http::geturl command to access
+# secure web pages and any proxy details will be handled for you.
+#
+proc ::autoproxy::tls_socket {args} {
+ variable options
+
+ # Look into the http package for the actual target. If a proxy is in use then
+ # The function appends the proxy host and port and not the target.
+
+ upvar host uhost port uport
+ set args [lrange $args 0 end-2]
+ lappend args $uhost $uport
+
+ set s [eval [linsert $args 0 tls_connect]]
+
+ # record the tls connection status in the http state array.
+ upvar state state
+ tls::handshake $s
+ set state(tls_status) [tls::status $s]
+
+ return $s
+}
+
+# -------------------------------------------------------------------------
+
+package provide autoproxy 1.5.3
+
+# -------------------------------------------------------------------------
+#
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/http/pkgIndex.tcl b/tcllib/modules/http/pkgIndex.tcl
new file mode 100644
index 0000000..c3ead43
--- /dev/null
+++ b/tcllib/modules/http/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded autoproxy 1.5.3 [list source [file join $dir autoproxy.tcl]]
diff --git a/tcllib/modules/httpd/content.tcl b/tcllib/modules/httpd/content.tcl
new file mode 100644
index 0000000..0303723
--- /dev/null
+++ b/tcllib/modules/httpd/content.tcl
@@ -0,0 +1,395 @@
+###
+# Standard library of HTTP/SCGI content
+# Each of these classes are intended to be mixed into
+# either an HTTPD or SCGI reply
+###
+package require Markdown
+package require fileutil::magic::mimetype
+package require tool 0.4
+package require fileutil
+namespace eval httpd::content {}
+
+###
+# Class to deliver Static content
+# When utilized, this class is fed a local filename
+# by the dispatcher
+###
+::tool::define ::httpd::content::file {
+
+ method FileName {} {
+ set uri [string trimleft [my query_headers get REQUEST_URI] /]
+ set path [my query_headers get path]
+ set prefix [my query_headers get prefix]
+ set fname [string range $uri [string length $prefix] end]
+ if {$fname in "{} index.html index.md index"} {
+ return $path
+ }
+ if {[file exists [file join $path $fname]]} {
+ return [file join $path $fname]
+ }
+ if {[file exists [file join $path $fname.md]]} {
+ return [file join $path $fname.md]
+ }
+ if {[file exists [file join $path $fname.html]]} {
+ return [file join $path $fname.html]
+ }
+ if {[file exists [file join $path $fname.tml]]} {
+ return [file join $path $fname.tml]
+ }
+ return {}
+ }
+
+
+ method DirectoryListing {local_file} {
+ my puts "<HTML><BODY><TABLE>"
+ foreach file [glob -nocomplain [file join $local_file *]] {
+ my puts "<TR><TD><a href=\"[file tail $file]\">[file tail $file]</a></TD><TD>[file size $file]</TD></TR>"
+ }
+ my puts "</TABLE></BODY></HTML>"
+ }
+
+ method dispatch {newsock datastate} {
+ # No need to process the rest of the headers
+ my variable chan dipatched_time
+ set dispatched_time [clock seconds]
+ my query_headers replace $datastate
+ set chan $newsock
+ my content
+ my output
+ }
+
+ method content {} {
+ my reset
+ ###
+ # When delivering static content, allow web caches to save
+ ###
+ my reply_headers set Cache-Control: {max-age=3600}
+ my variable reply_file
+ set local_file [my FileName]
+ if {$local_file eq {} || ![file exist $local_file]} {
+ my <server> log httpNotFound [my query_headers get REQUEST_URI]
+ tailcall my error 404 {Not Found}
+ }
+ if {[file isdirectory $local_file]} {
+ ###
+ # Produce an index page
+ ###
+ set idxfound 0
+ foreach name {
+ index.html
+ index.tml
+ index.md
+ } {
+ if {[file exists [file join $local_file $name]]} {
+ set idxfound 1
+ set local_file [file join $local_file $name]
+ break
+ }
+ }
+ if {!$idxfound} {
+ tailcall DirectoryListing $local_file
+ }
+ }
+ switch [file extension $local_file] {
+ .md {
+ package require Markdown
+ my reply_headers set Content-Type: {text/html; charset=ISO-8859-1}
+ set mdtxt [::fileutil::cat $local_file]
+ my puts [::Markdown::convert $mdtxt]
+ }
+ .tml {
+ my reply_headers set Content-Type: {text/html; charset=ISO-8859-1}
+ set tmltxt [::fileutil::cat $local_file]
+ set headers [my query_headers dump]
+ dict with headers {}
+ my puts [subst $tmltxt]
+ }
+ default {
+ ###
+ # Assume we are returning a binary file
+ ###
+ my reply_headers set Content-Type: [::fileutil::magic::mimetype $local_file]
+ set reply_file $local_file
+ }
+ }
+ }
+
+ ###
+ # Output the result or error to the channel
+ # and destroy this object
+ ###
+ method output {} {
+ my variable reply_body reply_file reply_chan chan
+ chan configure $chan -translation {binary binary}
+
+ set headers [my reply_headers dump]
+ if {[dict exists $headers Status:]} {
+ set result "[my EncodeStatus [dict get $headers Status:]]\n"
+ } else {
+ set result "[my EncodeStatus {505 Internal Error}]\n"
+
+ }
+ foreach {key value} $headers {
+ # Ignore Status and Content-length, if given
+ if {$key in {Status: Content-length:}} continue
+ append result "$key $value" \n
+ }
+ if {![info exists reply_file] || [string length $reply_body]} {
+ ###
+ # Return dynamic content
+ ###
+ set reply_body [string trim $reply_body]
+ append result "Content-length: [string length $reply_body]" \n \n
+ append result $reply_body
+ puts -nonewline $chan $result
+ chan flush $chan
+ my destroy
+ } else {
+ ###
+ # Return a stream of data from a file
+ ###
+ set size [file size $reply_file]
+ append result "Content-length: $size" \n \n
+ puts -nonewline $chan $result
+ set reply_chan [open $reply_file r]
+ chan configure $reply_chan -translation {binary binary}
+ chan copy $reply_chan $chan -command [namespace code [list my TransferComplete $reply_chan]]
+ }
+ }
+}
+
+###
+# Return data from an SCGI process
+###
+::tool::define ::httpd::content::scgi {
+
+ method scgi_info {} {
+ ###
+ # This method should check if a process is launched
+ # or launch it if needed, and return a list of
+ # HOST PORT SCRIPT_NAME
+ ###
+ # return {localhost 8016 /some/path}
+ error unimplemented
+ }
+
+ method content {} {
+ my variable sock chan
+ set sockinfo [my scgi_info]
+ if {$sockinfo eq {}} {
+ my error 404 {Not Found}
+ return
+ }
+ lassign $sockinfo scgihost scgiport scgiscript
+ set sock [::socket $scgihost $scgiport]
+ # Add a few headers that SCGI needs
+ my query_headers set SCRIPT_NAME $scgiscript
+ my query_headers set SCGI 1.0
+
+ chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
+ ###
+ # Convert our query headers into netstring format. Note that
+ # MimeParse as already rigged it such that CONTENT_LENGTH is first
+ # and always populated (even if zero), per SCGI requirements
+ ###
+ set block [my query_headers netstring]
+ puts -nonewline $sock $block
+ set length [my query_headers get CONTENT_LENGTH]
+ if {$length} {
+ ###
+ # Send any POST/PUT/etc content
+ ###
+ chan copy $chan $sock -size $length
+ }
+ chan flush $sock
+ ###
+ # Wake this object up after the SCGI process starts to respond
+ ###
+ #chan configure $sock -translation {auto crlf} -blocking 0 -buffering line
+ chan event $sock readable [namespace code {my output}]
+ }
+
+ method output {} {
+ if {[my query_headers getnull HTTP_ERROR] ne {}} {
+ ###
+ # If something croaked internally, handle this page as a normal reply
+ ###
+ next
+ }
+ my variable sock chan
+ set replyhead [my HttpHeaders $sock]
+ set replydat [my MimeParse $replyhead]
+ ###
+ # Convert the Status: header from the SCGI service to
+ # a standard service reply line from a web server, but
+ # otherwise spit out the rest of the headers verbatim
+ ###
+ set replybuffer "HTTP/1.1 [dict get $replydat HTTP_STATUS]\n"
+ append replybuffer $replyhead
+ chan configure $chan -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
+ puts $chan $replybuffer
+ ###
+ # Output the body
+ ###
+ chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
+ set length [dict get $replydat CONTENT_LENGTH]
+ if {$length} {
+ ###
+ # Send any POST/PUT/etc content
+ ###
+ chan copy $sock $chan -command [namespace code [list my TransferComplete $sock]]
+ } else {
+ catch {close $sock}
+ chan flush $chan
+ my destroy
+ }
+ }
+}
+
+# Act as a proxy server
+::tool::define ::httpd::content::proxy {
+
+ method proxy_info {} {
+ ###
+ # This method should check if a process is launched
+ # or launch it if needed, and return a list of
+ # HOST PORT PROXYURI
+ ###
+ # return {localhost 8016 /some/path}
+ error unimplemented
+ }
+
+ method content {} {
+ my variable chan sock rawrequest
+ set sockinfo [my proxy_info]
+ if {$sockinfo eq {}} {
+ tailcall my error 404 {Not Found}
+ }
+ lassign $sockinfo proxyhost proxyport proxyscript
+ set sock [::socket $proxyhost $proxyport]
+
+ chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan configure $sock -translation {auto crlf} -blocking 1 -buffering line
+
+ # Pass along our modified METHOD URI PROTO
+ puts $sock "$proxyscript"
+ # Pass along the headers as we saw them
+ puts $sock $rawrequest
+ set length [my query_headers get CONTENT_LENGTH]
+ if {$length} {
+ ###
+ # Send any POST/PUT/etc content
+ ###
+ chan copy $chan $sock -size $length
+ }
+ chan flush $sock
+ ###
+ # Wake this object up after the proxied process starts to respond
+ ###
+ chan configure $sock -translation {auto crlf} -blocking 1 -buffering line
+ chan event $sock readable [namespace code {my output}]
+ }
+
+ method output {} {
+ if {[my query_headers getnull HTTP_ERROR] ne {}} {
+ ###
+ # If something croaked internally, handle this page as a normal reply
+ ###
+ next
+ }
+ my variable sock chan
+ set length 0
+ chan configure $sock -translation {crlf crlf} -blocking 1
+ set replystatus [gets $sock]
+ set replyhead [my HttpHeaders $sock]
+ set replydat [my MimeParse $replyhead]
+
+ ###
+ # Pass along the status line and MIME headers
+ ###
+ set replybuffer "$replystatus\n"
+ append replybuffer $replyhead
+ chan configure $chan -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
+ puts $chan $replybuffer
+ ###
+ # Output the body
+ ###
+ chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
+ set length [dict get $replydat CONTENT_LENGTH]
+ if {$length} {
+ ###
+ # Send any POST/PUT/etc content
+ ###
+ chan copy $sock $chan -command [namespace code [list my TransferComplete $sock]]
+ } else {
+ catch {close $sock}
+ chan flush $chan
+ my destroy
+ }
+ }
+}
+
+###
+# Modified httpd server with a template engine
+# and a shim to insert URL domains
+###
+::tool::define ::httpd::server::dispatch {
+ array template
+ option doc_root {default {}}
+ variable url_patterns {}
+
+ method add_uri {pattern info} {
+ my variable url_patterns
+ dict set url_patterns $pattern $info
+ }
+
+ method PrefixNormalize prefix {
+ set prefix [string trimright $prefix /]
+ set prefix [string trimright $prefix *]
+ set prefix [string trimright $prefix /]
+ return $prefix
+ }
+
+ method dispatch {data} {
+ set reply $data
+ set uri [dict get $data REQUEST_PATH]
+ # Search from longest pattern to shortest
+ my variable url_patterns
+ foreach {pattern info} $url_patterns {
+ if {[string match ${pattern} /$uri]} {
+ set reply [dict merge $data $info]
+ if {![dict exists $reply prefix]} {
+ dict set reply prefix [my PrefixNormalize $pattern]
+ }
+ return $reply
+ }
+ }
+ set doc_root [my cget doc_root]
+ if {$doc_root ne {}} {
+ ###
+ # Fall back to doc_root handling
+ ###
+ dict set reply prefix {}
+ dict set reply path $doc_root
+ dict set reply mixin httpd::content::file
+ return $reply
+ }
+ return {}
+ }
+
+ method TemplateSearch page {
+ set doc_root [my cget doc_root]
+ if {$doc_root ne {} && [file exists [file join $doc_root $page.tml]]} {
+ return [::fileutil::cat [file join $doc_root $page.tml]]
+ }
+ if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
+ return [::fileutil::cat [file join $doc_root $page.html]]
+ }
+ return [next $page]
+ }
+}
+
+package provide httpd::content 4.0
diff --git a/tcllib/modules/httpd/demos/content.file.md b/tcllib/modules/httpd/demos/content.file.md
new file mode 100644
index 0000000..b2c1b3a
--- /dev/null
+++ b/tcllib/modules/httpd/demos/content.file.md
@@ -0,0 +1,55 @@
+httpd::content::file
+====================
+Back to: [Index](index.md) | [Package httpd::content](content.md)
+
+The **httpd::content::file** class implements a system for sharing a
+local file structure via http.
+
+## Special file handling
+
+### Directories
+
+When a directory path is requested, the system searches for one of the following (in order):
+
+* index.tml
+* index.md
+* index.html
+
+If one of these files is found, it is delivered as the response to the request. If no index file
+was found, the object will call the object's *DirectoryListing* method to
+deliver a dynamic listing of the files in the directory.
+
+### .md files
+
+Files with the .md extension are parsed using the *Markdown* package.
+
+### .tml files
+
+Files with the .tml extension are parsed using a call to *subst*.
+This allows them to deliver content in the same manner as tclhttpd. The
+contents of the *query_headers* are loaded as local variables prior to
+the *subst* call. NOTE: Unlike Tclhttpd, the substitution is performed
+inside of the reply object's namespace, not the local interpreter. Thus,
+template files can exercise the object's methods using the "my" command.
+
+## Dispatch Parameters
+
+Objects of this class needs additional information from the server in
+order to operate. These fields should be coded into the **add_root** call.
+
+### path *filepath*
+
+The **path** parameter specifies the root of the file path to be exposed.
+
+## Methods
+
+### DirectoryListing *local_file*
+
+Generates an HTML listing of a file path. The default implementation is a *very*
+rudimentary **glob --nocomplain [file join $local_path \*]**
+
+### FileName
+
+Converts the **REQUEST_URI** from query_headers into a local file path. This
+method searches first for the file name verbatim. If not found, it then searches
+for the same file name with a .md, .html, or .tml extension (in that order.)
diff --git a/tcllib/modules/httpd/demos/content.form.md b/tcllib/modules/httpd/demos/content.form.md
new file mode 100644
index 0000000..6a950fb
--- /dev/null
+++ b/tcllib/modules/httpd/demos/content.form.md
@@ -0,0 +1,17 @@
+httpd::content::form
+=============
+Back to: [Index](index.md) | [Package httpd::content](content.md)
+
+This class is intended as a mixin. It has no ancestors, nor does it contain
+any dispatch, content, or output methods.
+
+### Method Url_Decode *data*
+
+Translates a standard http query encoding string into a stream of key/value pairs.
+
+### Method ReadForm
+
+For GET requests, this method will convert the URI to key/value pairs.
+
+For POST requests, this method will read the body of the request and convert
+that block of text to a stream of key/value pairs. \ No newline at end of file
diff --git a/tcllib/modules/httpd/demos/content.md b/tcllib/modules/httpd/demos/content.md
new file mode 100644
index 0000000..abde776
--- /dev/null
+++ b/tcllib/modules/httpd/demos/content.md
@@ -0,0 +1,14 @@
+http::content
+=============
+[Back to Index](index.md)
+
+The **httpd::content** package is an extension to the core **httpd** package
+which provides all of the bread and butter functions needed to implement a
+basic webserver.
+
+* [Content Server](content.server.md)
+* [Form handler](content.form.md)
+* [File handler](content.file.md)
+* [SCGI handler](content.scgi.md)
+* [Proxy handler](content.proxy.md)
+ \ No newline at end of file
diff --git a/tcllib/modules/httpd/demos/content.proxy.md b/tcllib/modules/httpd/demos/content.proxy.md
new file mode 100644
index 0000000..32f757b
--- /dev/null
+++ b/tcllib/modules/httpd/demos/content.proxy.md
@@ -0,0 +1,20 @@
+httpd::content::proxy
+=============
+Back to: [Index](index.md) | [Package httpd::content](content.md)
+
+The proxy handler farms out the generation of content to an external process running
+on a known port. The external process is assumed to be a proxy server, and it is the job
+of this object to transform the query as received into a form that is understood by
+the external server.
+
+To implement a proxy handler, replace **proxy_info** with one that will return a list
+containing the following:
+
+ PROXYHOST PROXYPORT PROXYURI
+
+* PROXYHOST - The hostname or IP address of the server running the process
+* PROXYPORT - The port to connect to
+* PROXYURI - The replacement GET/POST/etc request to make to the external process.
+
+The **proxy_info** method also makes a handly place to spawn a locally hosted process on demand.
+For an example of this, see the [docserver.tcl](docserver.tcl) Example. \ No newline at end of file
diff --git a/tcllib/modules/httpd/demos/content.scgi.md b/tcllib/modules/httpd/demos/content.scgi.md
new file mode 100644
index 0000000..07b7f11
--- /dev/null
+++ b/tcllib/modules/httpd/demos/content.scgi.md
@@ -0,0 +1,20 @@
+httpd::content::scgi
+=============
+Back to: [Index](index.md) | [Package httpd::content](content.md)
+
+The SCGI handler farms out the generation of content to an external process
+running at a known port. Because this process is persistent, the SCGI system
+avoids the overhead of spawning and spooling up an external process with
+every page view.
+
+To implement an SCGI handler, replace the **scgi_info** method with one
+that will return a list containing the following:
+
+ SCGIHOST SCGIPORT SCGISCRIPT
+
+* SCGIHOST - The hostname or IP address of the server running the process
+* SCGIPORT - The port to connect to
+* SCGISCRIPT - The SCGISCRIPT parameter which will be passed to the external process via headers.
+
+The **scgi_info** method also makes a handly place to spawn a locally hosted process on demand.
+For an example of this, see the [docserver.tcl](docserver.tcl) Example. \ No newline at end of file
diff --git a/tcllib/modules/httpd/demos/content.server.md b/tcllib/modules/httpd/demos/content.server.md
new file mode 100644
index 0000000..fae985e
--- /dev/null
+++ b/tcllib/modules/httpd/demos/content.server.md
@@ -0,0 +1,42 @@
+http::content
+=============
+Back to: [Index](index.md) | [Package httpd::content](content.md)
+
+
+## Class: httpd::server::dispatch
+
+The **httpd::server::dispatch** adds additional functionality to the basic
+**httpd::server** class. It's *dispatch* method performs a pattern search
+based on url's registered via the *add_uri* method. That *add_uri* method
+allows the developer to specify which class will handle replies, as well as
+pass configuration information onto those objects.
+
+### Option doc_root
+
+Specifiying a *doc_root* will introduce a pattern search of last resort to
+find a matching URI as a file subordinate to the *doc_root*. Also, if the
+*doc_root* is specified, the system will search the root folder for the following
+templates:
+
+* notfound.tml - A site specific "404 File not found" template
+* internal_error.tml - A site specific "505 Internal Server Error" template
+
+### Method add_uri *pattern* *info*
+
+*add_uri* appends a new pattern to the server's internal pattern search dict.
+Patterns utilize **string match**, so any global characters or patterns for
+string match will work.
+
+Patterns are matched in the order in which they were given. In the example:
+
+<pre><code>SERVER add_uri /home* {...}
+SERVER add_uri /home/star/runner* {...}</code></pre>
+
+The pattern for /home/star/runner* will never be reached because /home* was specified first.
+
+The **info** argument contains a dict that will be passed by the *connect* method of the
+server to the *dispatch* method of the reply. Only two fields are reserved by the core of
+httpd:
+
+* class - The base class for the reply
+* mixin - The class to be mixed into the new object immediately prior to invoking the object's *dispatch* method.
diff --git a/tcllib/modules/httpd/demos/docserver.tcl b/tcllib/modules/httpd/demos/docserver.tcl
new file mode 100644
index 0000000..9bba988
--- /dev/null
+++ b/tcllib/modules/httpd/demos/docserver.tcl
@@ -0,0 +1,134 @@
+###
+# This script creates two toplevel domains:
+# * Hosting the tcllib embedded documentation as static content
+# * Hosting a local fossil mirror of the tcllib repository
+###
+set here [file dirname [file join [pwd] [info script]]]
+set DEMOROOT $here
+set tcllibroot [file normalize [file join $here .. .. ..]]
+set auto_path [linsert $auto_path 0 [file join $tcllibroot modules]]
+package require httpd
+package require httpd::content
+
+tool::class create ::docserver::reply::scgi_fossil {
+ superclass httpd::content::scgi
+
+ method scgi_info {} {
+ ###
+ # We could calculate this all out ahead of time
+ # but it's a nice demo to be able to launch the process
+ # and compute the parameters needed on the fly
+ ###
+ set uri [my query_headers get REQUEST_URI]
+ set prefix [my query_headers get prefix]
+ set prefix [string trimright $prefix *]
+ set prefix [string trimright $prefix /]
+ set module tcllib
+ ###
+ #
+ if {![info exists ::fossil_process($module)]} {
+ set info [exec fossil status]
+ set dbfile {}
+ foreach line [split $info \n] {
+ if {[lindex $line 0] eq "repository:"} {
+ set dbfile [string trim [string range $line 12 end]]
+ break
+ }
+ }
+ if {$dbfile eq {}} {
+ tailcall my error 505 "Could not locate fossil respository database"
+ }
+ puts [list LAUNCHING $module $dbfile]
+ package require processman
+ package require nettool
+ set port [::nettool::allocate_port 40000]
+ set handle fossil:$port
+ set mport [my <server> port_listening]
+ set cmd [list fossil server $dbfile --port $port --localhost --scgi --baseurl http://[my query_headers get HTTP_HOST]$prefix 2>/tmp/$module.err >/tmp/$module.log]
+ dict set ::fossil_process($module) port $port
+ dict set ::fossil_process($module) handle $handle
+ dict set ::fossil_process($module) cmd $cmd
+ dict set ::fossil_process($module) SCRIPT_NAME $prefix
+ }
+ dict with ::fossil_process($module) {}
+ if {![::processman::running $handle]} {
+ puts "LAUNCHING $module as $cmd"
+ set process [::processman::spawn $handle {*}$cmd]
+ puts "LAUNCHED"
+ my varname paused
+ after 500
+ puts "RESUMED"
+ }
+ return [list localhost $port $SCRIPT_NAME]
+ }
+}
+
+tool::class create ::docserver::reply::proxy_fossil {
+ superclass httpd::content::proxy
+
+ method proxy_info {} {
+ ###
+ # We could calculate this all out ahead of time
+ # but it's a nice demo to be able to launch the process
+ # and compute the parameters needed on the fly
+ ###
+ set uri [my query_headers get REQUEST_URI]
+ set prefix [my query_headers get prefix]
+ set prefix [string trimright $prefix *]
+ set prefix [string trimright $prefix /]
+ set module tcllib.proxy
+ ###
+ #
+ if {![info exists ::fossil_process($module)]} {
+ set info [exec fossil status]
+ set dbfile {}
+ foreach line [split $info \n] {
+ if {[lindex $line 0] eq "repository:"} {
+ set dbfile [string trim [string range $line 12 end]]
+ break
+ }
+ }
+ if {$dbfile eq {}} {
+ tailcall my error 505 "Could not locate fossil respository database"
+ }
+ puts [list LAUNCHING $module $dbfile]
+ package require processman
+ package require nettool
+ set port [::nettool::allocate_port 40000]
+ set handle fossil:$port
+ set mport [my <server> port_listening]
+ set cmd [list fossil server $dbfile --port $port --localhost --baseurl http://[my query_headers get HTTP_HOST]$prefix 2>/tmp/$module.err >/tmp/$module.log]
+ dict set ::fossil_process($module) port $port
+ dict set ::fossil_process($module) handle $handle
+ dict set ::fossil_process($module) cmd $cmd
+ dict set ::fossil_process($module) SCRIPT_NAME $prefix
+ }
+ dict with ::fossil_process($module) {}
+ if {![::processman::running $handle]} {
+ puts "LAUNCHING $module as $cmd"
+ set process [::processman::spawn $handle {*}$cmd]
+ puts "LAUNCHED"
+ my varname paused
+ after 500
+ puts "RESUMED"
+ }
+ set rawreq [my query_headers get REQUEST_RAW]
+ set URI [string range [lindex $rawreq 1] [string length $prefix] end]
+ if {$URI eq {}} {
+ set URI /
+ }
+ set proxyuri "[lindex $rawreq 0] $URI [lindex $rawreq 2]"
+ return [list localhost $port $proxyuri]
+ }
+}
+
+tool::class create ::docserver::server {
+ superclass ::httpd::server::dispatch ::httpd::server
+}
+
+::docserver::server create appmain doc_root $DEMOROOT
+appmain add_uri /tcllib* [list mixin httpd::content::file path [file join $tcllibroot embedded www]]
+appmain add_uri /fossil* {mixin ::docserver::reply::scgi_fossil}
+appmain add_uri /proxy* {mixin ::docserver::reply::proxy_fossil}
+
+tool::main
diff --git a/tcllib/modules/httpd/demos/index.md b/tcllib/modules/httpd/demos/index.md
new file mode 100644
index 0000000..689f769
--- /dev/null
+++ b/tcllib/modules/httpd/demos/index.md
@@ -0,0 +1,18 @@
+Your test server works!
+
+* [Tcllib embedded docs](/tcllib/index.html)
+* [Tcllib's fossil repo (hosted via SCGI)](/fossil)
+* [Tcllib's fossil repo (hosted via proxy)](/proxy)
+
+Internal documentation for httpd:
+
+* [Operating Principals](operations.md)
+* [Program Listing for docserver.tcl](docserver.tcl)
+* [Class httpd::reply](reply.md)
+* [Class httpd::server](server.md)
+* [Class httpd::content](content.md)
+ * [Content Server](content.server.md)
+ * [Form handler](content.form.md)
+ * [File handler](content.file.md)
+ * [SCGI handler](content.scgi.md)
+ * [Proxy handler](content.proxy.md) \ No newline at end of file
diff --git a/tcllib/modules/httpd/demos/operations.md b/tcllib/modules/httpd/demos/operations.md
new file mode 100644
index 0000000..eb9b236
--- /dev/null
+++ b/tcllib/modules/httpd/demos/operations.md
@@ -0,0 +1,30 @@
+httpd: Operations Manual
+===============================
+[Back to Index](index.md)
+
+The httpd module is designed to be an http server which is embeddable within another project.
+
+1. When a reply socket is opened, the *connect* method is exercised.
+2. The *connect* method then populates a dict with basic information such as the REMOTE_IP and the URI.
+3. *connect* calls the Server's *dispatch* method with this new dict as a parameter.
+4. *dispatch* returns with a dict describing the response to this request, or an empty list to indicate that this is an invalid request.
+5. A new object is created to manage the reply.
+ * If a **class** field is present in the dispatch dict, a new object will be of that class.
+ * If no **class** was given, the new object will be of the class specified by the server's *reply_class* property.
+6. If the field *mixin* is present and non-empty, the new reply object will mixin the class specified.
+7. The server object will then call the reply object's *dispatch* process, with the complete reply description dict as a paramter.
+8. The server adds the object to a list of objects it is tracking. If the reply object does not destroy itself within 2 minutes, the server will destroy it.
+
+Once the *dispatch* method is called, it is the reply object's job to:
+
+1. Parse the HTTP headers of the incoming request
+2. Formulate a response
+3. Transmit that response back across the request socket.
+4. Destroy itself when finished.
+5. On destruction, unregister itself from the server object.
+
+The basic reply class perfoms the following:
+
+1. Reads the HTTP years
+2. Invokes the *content* class, which utilizes the *puts* method to populate an internal buffer.
+3. Invokes the *output* class which will prepare reply headers and output the reply buffer to the request socket.
diff --git a/tcllib/modules/httpd/demos/reply.md b/tcllib/modules/httpd/demos/reply.md
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/httpd/demos/reply.md
diff --git a/tcllib/modules/httpd/demos/server.md b/tcllib/modules/httpd/demos/server.md
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/httpd/demos/server.md
diff --git a/tcllib/modules/httpd/dispatch.tcl b/tcllib/modules/httpd/dispatch.tcl
new file mode 100644
index 0000000..7849b30
--- /dev/null
+++ b/tcllib/modules/httpd/dispatch.tcl
@@ -0,0 +1,11 @@
+###
+# This file implements an extensible dispatch server for the httpd package
+# The package is seperate because the code is equally applicable for either
+# the httpd and scgi modes, and it also injects a suite of assumptions
+# that may not be applicable to a general purpose tool
+###
+package require tool
+package require httpd::content
+
+
+package provide httpd::dispatch 4.0
diff --git a/tcllib/modules/httpd/httpd.tcl b/tcllib/modules/httpd/httpd.tcl
new file mode 100644
index 0000000..dc6e95f
--- /dev/null
+++ b/tcllib/modules/httpd/httpd.tcl
@@ -0,0 +1,665 @@
+###
+# Author: Sean Woods, yoda@etoyoc.com
+##
+# Adapted from the "minihttpd.tcl" file distributed with Tclhttpd
+#
+# The working elements have been updated to operate as a TclOO object
+# running with Tcl 8.6+. Global variables and hard coded tables are
+# now resident with the object, allowing this server to be more easily
+# embedded another program, as well as be adapted and extended to
+# support the SCGI module
+###
+
+package require uri
+package require cron
+package require tool 0.4.1
+package require oo::dialect
+
+namespace eval ::url {}
+namespace eval ::httpd {}
+namespace eval ::scgi {}
+
+set ::httpd::version 4.0.0
+
+###
+# Define the reply class
+###
+::tool::define ::httpd::reply {
+
+ property reply_headers_default {
+ Status: {200 OK}
+ Content-Type: {text/html; charset=ISO-8859-1}
+ Cache-Control: {no-cache}
+ Connection: close
+ }
+
+ array error_codes {
+ 200 {Data follows}
+ 204 {No Content}
+ 302 {Found}
+ 304 {Not Modified}
+ 400 {Bad Request}
+ 401 {Authorization Required}
+ 403 {Permission denied}
+ 404 {Not Found}
+ 408 {Request Timeout}
+ 411 {Length Required}
+ 419 {Expectation Failed}
+ 500 {Server Internal Error}
+ 501 {Server Busy}
+ 503 {Service Unavailable}
+ 504 {Service Temporarily Unavailable}
+ 505 {Internal Server Error}
+ }
+
+ constructor {ServerObj args} {
+ my variable chan
+ oo::objdefine [self] forward <server> $ServerObj
+ foreach {field value} [::oo::meta::args_to_options {*}$args] {
+ my meta set config $field: $value
+ }
+ }
+
+ ###
+ # clean up on exit
+ ###
+ destructor {
+ my close
+ }
+
+ method close {} {
+ my variable chan
+ catch {flush $chan}
+ catch {close $chan}
+ }
+
+ method HttpHeaders {sock {debug {}}} {
+ set result {}
+ ###
+ # Set up a channel event to stream the data from the socket line by
+ # line. When a blank line is read, the HttpHeaderLine method will send
+ # a flag which will terminate the vwait.
+ #
+ # We do this rather than entering blocking mode to prevent the process
+ # from locking up if it's starved for input. (Or in the case of the test
+ # suite, when we are opening a blocking channel on the other side of the
+ # socket back to ourselves.)
+ ###
+ chan configure $sock -translation {auto crlf} -blocking 0 -buffering line
+ my variable MimeHeadersSock
+ set MimeHeadersSock($sock) {}
+ set MimeHeadersSock($sock.done) {}
+ chan event $sock readable [namespace code [list my HttpHeaderLine $sock]]
+ vwait [my varname MimeHeadersSock]($sock.done)
+ chan event $sock readable {}
+ ###
+ # Return our buffer
+ ###
+ return $MimeHeadersSock($sock)
+ }
+
+ method HttpHeaderLine {sock} {
+ my variable MimeHeadersSock
+ if {[chan eof $sock]} {
+ # Socket closed... die
+ tailcall my destroy
+ }
+ try {
+ if {[gets $sock line]==0} {
+ set [my varname MimeHeadersSock]($sock.done) 1
+ } else {
+ append MimeHeadersSock($sock) $line \n
+ }
+ } trap {POSIX EBUSY} {err info} {
+ # Happens...
+ } on error {err info} {
+ puts "ERROR $err"
+ puts [dict print $info]
+ }
+ }
+
+ method MimeParse mimetext {
+ foreach line [split $mimetext \n] {
+ # This regexp picks up
+ # key: value
+ # MIME headers. MIME headers may be continue with a line
+ # that starts with spaces or a tab
+ if {[string length [string trim $line]]==0} break
+ if {[regexp {^([^ :]+):[ ]*(.*)} $line dummy key value]} {
+ # The following allows something to
+ # recreate the headers exactly
+ lappend data(headerlist) $key $value
+ # The rest of this makes it easier to pick out
+ # headers from the data(mime,headername) array
+ #set key [string tolower $key]
+ if {[info exists data(mime,$key)]} {
+ append data(mime,$key) ,$value
+ } else {
+ set data(mime,$key) $value
+ lappend data(mimeorder) $key
+ }
+ set data(key) $key
+ } elseif {[regexp {^[ ]+(.*)} $line dummy value]} {
+ # Are there really continuation lines in the spec?
+ if {[info exists data(key)]} {
+ append data(mime,$data(key)) " " $value
+ } else {
+ my error 400 "INVALID HTTP HEADER FORMAT: $line"
+ tailcall my output
+ }
+ } else {
+ my error 400 "INVALID HTTP HEADER FORMAT: $line"
+ tailcall my output
+ }
+ }
+ ###
+ # To make life easier for our SCGI implementation rig things
+ # such that CONTENT_LENGTH is always first
+ ###
+ set result {
+ CONTENT_LENGTH 0
+ }
+ foreach {key} $data(mimeorder) {
+ switch $key {
+ Content-Length {
+ dict set result CONTENT_LENGTH $data(mime,$key)
+ }
+ Content-Type {
+ dict set result CONTENT_TYPE $data(mime,$key)
+ }
+ default {
+ dict set result HTTP_[string map {"-" "_"} [string toupper $key]] $data(mime,$key)
+ }
+ }
+ }
+ return $result
+ }
+
+ method dispatch {newsock datastate} {
+ my query_headers replace $datastate
+ my variable chan rawrequest dipatched_time
+ set chan $newsock
+ chan event $chan readable {}
+ chan configure $chan -translation {auto crlf} -buffering line
+ set dispatched_time [clock seconds]
+ try {
+ set rawrequest [my HttpHeaders $chan]
+ foreach {field value} [my MimeParse $rawrequest] {
+ my query_headers set $field $value
+ }
+ # Dispatch to the URL implementation.
+ my content
+ } on error {err info} {
+ dict print $info
+ #puts stderr $::errorInfo
+ my error 500 $err
+ } finally {
+ my output
+ }
+ }
+
+ dictobj query_headers query_headers {
+ initialize {
+ CONTENT_LENGTH 0
+ }
+ netstring {
+ set result {}
+ foreach {name value} $%VARNAME% {
+ append result $name \x00 $value \x00
+ }
+ return "[string length $result]:$result,"
+ }
+ }
+ dictobj reply_headers reply_headers {
+ initialize {
+ Content-Type: {text/html; charset=ISO-8859-1}
+ Connection: close
+ }
+ }
+
+ method error {code {msg {}}} {
+ puts [list [self] ERROR $code $msg]
+ my query_headers set HTTP_ERROR $code
+ my reset
+ my variable error_codes
+ set qheaders [my query_headers dump]
+ if {![info exists error_codes($code)]} {
+ set errorstring "Unknown Error Code"
+ } else {
+ set errorstring $error_codes($code)
+ }
+ dict with qheaders {}
+ my reply_headers replace {}
+ my reply_headers set Status: "$code $errorstring"
+ my reply_headers set Content-Type: {text/html; charset=ISO-8859-1}
+ my puts "
+<HTML>
+<HEAD>
+<TITLE>$code $errorstring</TITLE>
+</HEAD>
+<BODY>"
+ if {$msg eq {}} {
+ my puts "
+Got the error <b>$code $errorstring</b>
+<p>
+while trying to obtain $REQUEST_URI
+ "
+ } else {
+ my puts "
+Guru meditation #[clock seconds]
+<p>
+The server encountered an internal error:
+<p>
+<pre>$msg</pre>
+<p>
+For deeper understanding:
+<p>
+<pre>$::errorInfo</pre>
+"
+ }
+ my puts "</BODY>
+</HTML>"
+ }
+
+
+ ###
+ # REPLACE ME:
+ # This method is the "meat" of your application.
+ # It writes to the result buffer via the "puts" method
+ # and can tweak the headers via "meta put header_reply"
+ ###
+ method content {} {
+ my puts "<HTML>"
+ my puts "<BODY>"
+ my puts "<H1>HELLO WORLD!</H1>"
+ my puts "</BODY>"
+ my puts "</HTML>"
+ }
+
+ method EncodeStatus {status} {
+ return "HTTP/1.0 $status"
+ }
+
+ ###
+ # Output the result or error to the channel
+ # and destroy this object
+ ###
+ method output {} {
+ my variable reply_body reply_chan chan
+ chan configure $chan -translation {binary binary}
+
+ set headers [my reply_headers dump]
+ if {[dict exists $headers Status:]} {
+ set result "[my EncodeStatus [dict get $headers Status:]]\n"
+ } else {
+ set result "[my EncodeStatus {505 Internal Error}]\n"
+ }
+ foreach {key value} $headers {
+ # Ignore Status and Content-length, if given
+ if {$key in {Status: Content-length:}} continue
+ append result "$key $value" \n
+ }
+ ###
+ # Return dynamic content
+ ###
+ #set reply_body [string trim $reply_body]
+ set length [string length $reply_body]
+ if {${length} > 0} {
+ append result "Content-length: [string length $reply_body]" \n \n
+ append result $reply_body
+ } else {
+ append result \n
+ }
+ puts -nonewline $chan $result
+ chan flush $chan
+ my destroy
+ }
+
+ method Url_Decode data {
+ regsub -all {\+} $data " " data
+ regsub -all {([][$\\])} $data {\\\1} data
+ regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
+ return [subst $data]
+ }
+
+ method FormData {} {
+ my variable formdata
+ # Run this only once
+ if {[info exists formdata]} {
+ return $formdata
+ }
+ if {[my query_headers get REQUEST_METHOD] in {"POST" "PUSH"}} {
+ set body [my PostData]
+ switch [my query_headers get CONTENT_TYPE] {
+ application/x-www-form-urlencoded {
+ # These foreach loops are structured this way to ensure there are matched
+ # name/value pairs. Sometimes query data gets garbled.
+
+ set result {}
+ foreach pair [split $body "&"] {
+ foreach {name value} [split $pair "="] {
+ lappend formdata [my Url_Decode $name] [my Url_Decode $value]
+ }
+ }
+ }
+ }
+ } else {
+ foreach pair [split [my query_headers getnull QUERY_STRING] "&"] {
+ foreach {name value} [split $pair "="] {
+ lappend formdata [my Url_Decode $name] [my Url_Decode $value]
+ }
+ }
+ }
+ return $formdata
+ }
+
+ method PostData {} {
+ my variable postdata
+ # Run this only once
+ if {[info exists postdata]} {
+ return $postdata
+ }
+ set postdata {}
+ if {[my query_headers get REQUEST_METHOD] in {"POST" "PUSH"}} {
+ my variable chan
+ chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
+ set length [my query_headers get CONTENT_LENGTH]
+ set postdata [read $chan $length]
+ }
+ return $postdata
+ }
+
+ method TransferComplete args {
+ foreach c $args {
+ catch {close $c}
+ }
+ my destroy
+ }
+
+ ###
+ # Append to the result buffer
+ ###
+ method puts line {
+ my variable reply_body
+ append reply_body $line \n
+ }
+
+ ###
+ # Read out the contents of the POST
+ ###
+ method query_body {} {
+ my variable query_body
+ return $query_body
+ }
+
+ ###
+ # Reset the result
+ ###
+ method reset {} {
+ my variable reply_body
+ my reply_headers replace [my meta cget reply_headers_default]
+ my reply_headers set Server: [my <server> cget server_string]
+ my reply_headers set Date: [my timestamp]
+ set reply_body {}
+ }
+
+ ###
+ # Return true of this class as waited too long to respond
+ ###
+ method timeOutCheck {} {
+ my variable dipatched_time
+ if {([clock seconds]-$dipatched_time)>30} {
+ ###
+ # Something has lasted over 2 minutes. Kill this
+ ###
+ my error 505 {Operation Timed out}
+ my output
+ }
+ }
+
+ ###
+ # Return a timestamp
+ ###
+ method timestamp {} {
+ return [clock format [clock seconds] -format {%a, %d %b %Y %T %Z}]
+ }
+}
+
+###
+# A simplistic web server, with a few caveats:
+# 1) It only really understands "GET" style queries.
+# 2) It is not hardened in any way against malicious attacks
+# 3) By default it will only listen on localhost
+###
+::tool::define ::httpd::server {
+
+ option port {default: auto}
+ option myaddr {default: 127.0.0.1}
+ option server_string [list default: [list TclHttpd $::httpd::version]]
+
+ property socket buffersize 32768
+ property socket translation {auto crlf}
+ property reply_class ::httpd::reply
+
+ constructor {args} {
+ my configure {*}$args
+ my start
+ }
+
+ destructor {
+ my stop
+ }
+
+ method connect {sock ip port} {
+ ###
+ # If an IP address is blocked
+ # send a "go to hell" message
+ ###
+ if {[my validation Blocked_IP $sock $ip]} {
+ catch {close $sock}
+ return
+ }
+
+ chan configure $sock \
+ -blocking 1 \
+ -translation {auto crlf} \
+ -buffering line
+
+ my counter url_hit
+ try {
+ set readCount [gets $sock line]
+ dict set query REQUEST_METHOD [lindex $line 0]
+ set uriinfo [::uri::split [lindex $line 1]]
+ dict set query REQUEST_URI [lindex $line 1]
+ dict set query REQUEST_PATH [dict get $uriinfo path]
+ dict set query REQUEST_VERSION [lindex [split [lindex $line end] /] end]
+ if {[dict get $uriinfo host] eq {}} {
+ dict set query HTTP_HOST [info hostname]
+ } else {
+ dict set query HTTP_HOST [dict get $uriinfo host]
+ }
+ dict set query HTTP_CLIENT_IP $ip
+ dict set query QUERY_STRING [dict get $uriinfo query]
+ dict set query REQUEST_RAW $line
+ } on error {err errdat} {
+ puts stderr $err
+ my log HttpError $line
+ catch {close $sock}
+ return
+ }
+ try {
+ set reply [my dispatch $query]
+ if {[llength $reply]} {
+ if {[dict exists $reply class]} {
+ set class [dict get $reply class]
+ } else {
+ set class [my cget reply_class]
+ }
+ set pageobj [$class create [namespace current]::reply::[::tool::uuid_short] [self]]
+ if {[dict exists $reply mixin]} {
+ oo::objdefine $pageobj mixin [dict get $reply mixin]
+ }
+ $pageobj dispatch $sock $reply
+ my log HttpAccess $line
+ } else {
+ try {
+ my log HttpMissing $line
+ puts $sock "HTTP/1.0 404 NOT FOUND"
+ dict with query {}
+ set body [subst [my template notfound]]
+ puts $sock "Content-length: [string length $body]"
+ puts $sock
+ puts $sock $body
+ } on error {err errdat} {
+ puts stderr "FAILED ON 404: $err"
+ } finally {
+ catch {close $sock}
+ }
+ }
+ } on error {err errdat} {
+ try {
+ puts stderr [dict print $errdat]
+ puts $sock "HTTP/1.0 505 INTERNAL ERROR"
+ dict with query {}
+ set body [subst [my template internal_error]]
+ puts $sock "Content-length: [string length $body]"
+ puts $sock
+ puts $sock $body
+ my log HttpError $line
+ } on error {err errdat} {
+ puts stderr "FAILED ON 505: $::errorInfo"
+ } finally {
+ catch {close $sock}
+ }
+ }
+ }
+
+ method counter which {
+ my variable counters
+ incr counters($which)
+ }
+
+ ###
+ # Clean up any process that has gone out for lunch
+ ###
+ method CheckTimeout {} {
+ foreach obj [info commands [namespace current]::reply::*] {
+ try {
+ $obj timeOutCheck
+ } on error {} {
+ catch {$obj destroy}
+ }
+ }
+ }
+
+ ###
+ # REPLACE ME:
+ # This method should perform any transformations
+ # or setup to the page object based on headers/state/etc
+ # If all is well, return 200. Any other code will be interpreted
+ # as an error
+ ###
+ method dispatch {data} {
+ return $data
+ }
+
+ method log args {
+ # Do nothing for now
+ }
+
+ method port_listening {} {
+ my variable port_listening
+ return $port_listening
+ }
+
+ method start {} {
+ # Build a namespace to contain replies
+ namespace eval [namespace current]::reply {}
+
+ my variable socklist port_listening
+ set port [my cget port]
+ if { $port in {auto {}} } {
+ package require nettool
+ set port [::nettool::allocate_port 8015]
+ }
+ set port_listening $port
+ set myaddr [my cget myaddr]
+ #puts [list [self] listening on $port $myaddr]
+
+ if {$myaddr ne {}} {
+ foreach ip $myaddr {
+ lappend socklist [socket -server [namespace code [list my connect]] -myaddr $ip $port]
+ }
+ } else {
+ lappend socklist [socket -server [namespace code [list my connect]] $port]
+ }
+ ::cron::every [self] 120 [namespace code {my CheckTimeout}]
+ }
+
+ method stop {} {
+ my variable socklist
+ foreach sock $socklist {
+ catch {close $sock}
+ }
+ set socklist {}
+ ::cron::cancel [self]
+ }
+
+
+ method template page {
+ my variable template
+ if {[info exists template($page)]} {
+ return $template($page)
+ }
+ set template($page) [my TemplateSearch $page]
+ return $template($page)
+ }
+
+ method TemplateSearch page {
+ set doc_root [my cget doc_root]
+ if {$doc_root ne {} && [file exists [file join $doc_root $page.tml]]} {
+ return [::fileutil::cat [file join $doc_root $page.tml]]
+ }
+ if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
+ return [::fileutil::cat [file join $doc_root $page.html]]
+ }
+ switch $page {
+ internal_error {
+ return {
+<HTML>
+<HEAD><TITLE>505: Internal Server Error</TITLE></HEAD>
+<BODY>
+Error serving <b>${REQUEST_URI}</b>:
+<p>
+The server encountered an internal server error
+<pre><code>
+$::errorInfo
+</code></pre>
+</BODY>
+</HTML>
+ }
+ }
+ notfound {
+ return {
+<HTML>
+<HEAD><TITLE>404: Page Not Found</TITLE></HEAD>
+<BODY>
+The page you are looking for: <b>${REQUEST_URI}</b> does not exist.
+</BODY>
+</HTML>
+ }
+ }
+ }
+ }
+
+ ###
+ # Return true if this IP address is blocked
+ # The socket will be closed immediately after returning
+ # This handler is welcome to send a polite error message
+ ###
+ method validation::Blocked_IP {sock ip} {
+ return 0
+ }
+}
+
+package provide httpd 4.0
diff --git a/tcllib/modules/httpd/httpd.test b/tcllib/modules/httpd/httpd.test
new file mode 100644
index 0000000..5e3f7d6
--- /dev/null
+++ b/tcllib/modules/httpd/httpd.test
@@ -0,0 +1,285 @@
+# httpd.test - Copyright (c) 2015 Sean Woods
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.6 ;# tool requires 8.6
+testsNeedTcltest 2
+
+testsNeed TclOO 1
+
+support {
+ use cmdline/cmdline.tcl cmdline
+ use fileutil/fileutil.tcl fileutil
+ use sha1/sha1.tcl sha1
+ use uri/uri.tcl uri
+ use ncgi/ncgi.tcl ncgi
+
+ use dns/ip.tcl ip
+ use nettool/nettool.tcl nettool
+
+ use dicttool/dicttool.tcl dicttool
+ use cron/cron.tcl cron
+ use oodialect/oodialect.tcl oo::dialect
+ use oometa/oometa.tcl oo::meta
+ use tool/index.tcl tool
+}
+
+testing {
+ useLocal httpd.tcl httpd
+}
+
+# -------------------------------------------------------------------------
+
+namespace eval ::httpd {}
+namespace eval ::httpd::test {}
+
+###
+# Minimal test harness for the .tests
+# Not intended for public consumption
+# (But if you find it handy, please steal!)
+namespace eval ::httpd::test {}
+
+proc ::httpd::test::send {port text} {
+ set sock [socket localhost $port]
+ variable reply
+ set reply($sock) {}
+ chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan event $sock readable [list ::httpd::test::get_reply $sock]
+
+ set headers {}
+ set body {}
+ set read_headers 1
+ foreach line [split $text \n] {
+ if {$read_headers} {
+ if { $line eq {} } {
+ set read_headers 0
+ } else {
+ append headers $line \n
+ }
+ } else {
+ append body $line \n
+ }
+ }
+ append headers "Content-Type: text/plain" \n
+ append headers "Content-Length: [string length $body]" \n
+ puts $sock "$headers\n$body"
+ flush $sock
+ while {$reply($sock) eq {}} {
+ update
+ }
+ #vwait [namespace current]::reply($sock)
+ return $reply($sock)
+}
+
+proc ::httpd::test::get_reply {sock} {
+ variable buffer
+ set data [read $sock]
+ append buffer($sock) $data
+ if {[eof $sock]} {
+ chan event $sock readable {}
+ set [namespace current]::reply($sock) $buffer($sock)
+ unset buffer($sock)
+ }
+}
+
+
+
+###
+# Build the reply class
+###
+tool::class create ::httpd::test::reply {
+ superclass ::httpd::reply
+
+ method error {code {msg {}}} {
+ my reset
+ my variable data error_codes
+ if {![info exists data(url)]} {
+ set data(url) {}
+ }
+ if {![info exists error_codes($code)]} {
+ set errorstring "Unknown Error Code"
+ } else {
+ set errorstring $error_codes($code)
+ }
+ my reply_headers replace {}
+ my reply_headers set Status: "$code $errorstring"
+ my reply_headers set Content-Type: {text/plain}
+ my puts "
+$code $errorstring
+Got the error $code $errorstring
+
+while trying to obtain $data(url)
+"
+ }
+
+ method reset {} {
+ my variable reply_body
+ my reply_headers replace {Status: {200 OK} Content-Type: text/plain}
+ set reply_body {}
+ }
+
+ method content {} {
+ my reset
+ switch [my query_headers get REQUEST_URI] {
+ /file {
+ my variable reply_file
+ set reply_file [file join $::here pkgIndex.tcl]
+ }
+ /time {
+ my puts [clock seconds]
+ }
+ /error {
+ error {
+The programmer asked me to die this way
+ }
+ }
+ /echo -
+ default {
+ my puts [my PostData]
+ }
+ }
+ }
+
+ ###
+ # Output the result or error to the channel
+ # and destroy this object
+ ###
+ method output {} {
+ my variable reply_body reply_file reply_chan chan
+ chan configure $chan -translation {binary binary}
+
+ set headers [my reply_headers dump]
+ if {[dict exists $headers Status:]} {
+ set result "[my EncodeStatus [dict get $headers Status:]]\n"
+ } else {
+ set result "[my EncodeStatus {505 Internal Error}]\n"
+
+ }
+ foreach {key value} $headers {
+ # Ignore Status and Content-length, if given
+ if {$key in {Status: Content-length:}} continue
+ append result "$key $value" \n
+ }
+ if {![info exists reply_file] || [string length $reply_body]} {
+ ###
+ # Return dynamic content
+ ###
+ set reply_body [string trim $reply_body]
+ append result "Content-length: [string length $reply_body]" \n \n
+ append result $reply_body
+ puts -nonewline $chan $result
+ } else {
+ ###
+ # Return a stream of data from a file
+ ###
+ append result "Content-length: [file size $reply_file]" \n \n
+ puts -nonewline $chan $result
+ set reply_chan [open $reply_file r]
+ chan copy $reply_chan $chan
+ catch {close $reply_chan}
+ }
+ chan flush $chan
+ my destroy
+ }
+}
+
+###
+# Build the server
+###
+tool::class create httpd::test::app {
+ superclass ::httpd::server
+
+ property reply_class ::httpd::test::reply
+}
+
+httpd::test::app create TESTAPP port 10001
+
+
+test httpd-client-0001 {Do an echo request} {
+
+set reply [::httpd::test::send 10001 {POST /echo HTTP/1.0
+
+THIS IS MY CODE
+}]
+} {HTTP/1.0 200 OK
+Content-Type: text/plain
+Connection: close
+Content-length: 15
+
+THIS IS MY CODE}
+
+test httpd-client-0002 {Do another echo request} {
+set reply [::httpd::test::send 10001 {POST /echo HTTP/1.0
+
+THOUGH THERE ARE MANY LIKE IT
+}]
+} {HTTP/1.0 200 OK
+Content-Type: text/plain
+Connection: close
+Content-length: 29
+
+THOUGH THERE ARE MANY LIKE IT}
+
+test httpd-client-0003 {Do another echo request} {
+set reply [::httpd::test::send 10001 {POST /echo HTTP/1.0
+
+THIS ONE ALONE IS MINE
+}]
+} {HTTP/1.0 200 OK
+Content-Type: text/plain
+Connection: close
+Content-length: 22
+
+THIS ONE ALONE IS MINE}
+
+test httpd-client-0004 {URL Generates Error} {
+
+set reply [::httpd::test::send 10001 {POST /error HTTP/1.0
+
+THIS ONE ALONE IS MINE
+}] } {HTTP/1.0 500 Server Internal Error
+Content-Type: text/plain
+Connection: close
+Content-length: 89
+
+500 Server Internal Error
+Got the error 500 Server Internal Error
+
+while trying to obtain}
+
+set checkreply [subst {HTTP/1.0 200 OK
+Content-Type: text/plain
+Connection: close
+Content-length: 10
+
+[clock seconds]}]
+
+test httpd-client-0005 {URL Different output with a different request} {
+set reply [::httpd::test::send 10001 {POST /time HTTP/1.0
+
+THIS ONE ALONE IS MINE
+}] } $checkreply
+
+set fin [open [file join $here pkgIndex.tcl] r]
+set checkreply [read $fin]
+close $fin
+test httpd-client-0006 {Return a file} {
+set reply [::httpd::test::send 10001 {POST /file HTTP/1.0
+}] } "HTTP/1.0 200 OK
+Content-Type: text/plain
+Connection: close
+Content-length: [string length $checkreply]
+
+$checkreply"
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/httpd/pkgIndex.tcl b/tcllib/modules/httpd/pkgIndex.tcl
new file mode 100644
index 0000000..6d935a5
--- /dev/null
+++ b/tcllib/modules/httpd/pkgIndex.tcl
@@ -0,0 +1,15 @@
+# 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 scgi::server 0.1 [list source [file join $dir scgi-server.tcl]]
+package ifneeded scgi::app 0.1 [list source [file join $dir scgi-app.tcl]]
+package ifneeded httpd 4.0 [list source [file join $dir httpd.tcl]]
+package ifneeded httpd::dispatch 4.0 [list source [file join $dir dispatch.tcl]]
+package ifneeded httpd::content 4.0 [list source [file join $dir content.tcl]]
diff --git a/tcllib/modules/httpd/scgi-app.tcl b/tcllib/modules/httpd/scgi-app.tcl
new file mode 100644
index 0000000..021726c
--- /dev/null
+++ b/tcllib/modules/httpd/scgi-app.tcl
@@ -0,0 +1,135 @@
+###
+# Author: Sean Woods, yoda@etoyoc.com
+###
+# This file provides the "application" side of the SCGI protocol
+###
+
+package require html
+package require TclOO
+package require httpd 4.0
+
+namespace eval ::scgi {}
+
+tool::class create ::scgi::reply {
+ superclass ::httpd::reply
+
+ ###
+ # A modified dispatch method from a standard HTTP reply
+ # Unlike in HTTP, our headers were spoon fed to use from
+ # the server
+ ###
+ method dispatch {newsock datastate} {
+ my query_headers replace $datastate
+ my variable chan rawrequest dipatched_time
+ set chan $newsock
+ chan event $chan readable {}
+ chan configure $chan -translation {auto crlf} -buffering line
+ set dispatched_time [clock seconds]
+ try {
+ # Dispatch to the URL implementation.
+ my content
+ } on error {err info} {
+ puts stderr $::errorInfo
+ my error 500 $err
+ } finally {
+ my output
+ }
+ }
+
+ method EncodeStatus {status} {
+ return "Status: $status"
+ }
+}
+
+tool::class create scgi::app {
+ superclass ::httpd::server
+
+ property socket buffersize 32768
+ property socket blocking 0
+ property socket translation {binary binary}
+
+ property reply_class ::scgi::reply
+
+ method connect {sock ip port} {
+ ###
+ # If an IP address is blocked
+ # send a "go to hell" message
+ ###
+ if {[my validation Blocked_IP $sock $ip]} {
+ catch {close $sock}
+ return
+ }
+ set query {
+ REQUEST_URI {NOT_POPULATED}
+ }
+ try {
+ chan configure $sock \
+ -blocking 1 \
+ -translation {binary binary} \
+ -buffersize 4096 \
+ -buffering none
+
+ # Read the SCGI request on byte at a time until we reach a ":"
+ set size {}
+ while 1 {
+ set char [read $sock 1]
+ if {[chan eof $sock]} {
+ catch {close $sock}
+ return
+ }
+ if {$char eq ":"} break
+ append size $char
+ }
+ # With length in hand, read the netstring encoded headers
+ set inbuffer [read $sock [expr $size+1]]
+ chan configure $sock -blocking 0 -buffersize 4096 -buffering full
+ set query [lrange [split [string range $inbuffer 0 end-1] \0] 0 end-1]
+ set reply [my dispatch $query]
+ dict with query {}
+ if {[llength $reply]} {
+ if {[dict exists $reply class]} {
+ set class [dict get $reply class]
+ } else {
+ set class [my cget reply_class]
+ }
+ set pageobj [$class create [namespace current]::reply::[::tool::uuid_short] [self]]
+ if {[dict exists $reply mixin]} {
+ oo::objdefine $pageobj mixin [dict get $reply mixin]
+ }
+ $pageobj dispatch $sock $reply
+ my log HttpAccess $REQUEST_URI
+ } else {
+ try {
+ my log HttpMissing $REQUEST_URI
+ puts $sock "Status: 404 NOT FOUND"
+ dict with query {}
+ set body [subst [my template notfound]]
+ puts $sock "Content-length: [string length $body]"
+ puts $sock
+ puts $sock $body
+ } on error {err errdat} {
+ puts stderr "FAILED ON 404: $err"
+ } finally {
+ catch {close $sock}
+ }
+ }
+ } on error {err errdat} {
+ try {
+ puts stderr $::errorInfo
+ puts $sock "Status: 505 INTERNAL ERROR"
+ dict with query {}
+ set body [subst [my template internal_error]]
+ puts $sock "Content-length: [string length $body]"
+ puts $sock
+ puts $sock $body
+ my log HttpError $REQUEST_URI
+ } on error {err errdat} {
+ puts stderr "FAILED ON 505: $err $::errorInfo"
+ } finally {
+ catch {close $sock}
+ }
+ }
+ }
+}
+
+package provide scgi::app 0.1
diff --git a/tcllib/modules/httpd/scgi.test b/tcllib/modules/httpd/scgi.test
new file mode 100644
index 0000000..6efa617
--- /dev/null
+++ b/tcllib/modules/httpd/scgi.test
@@ -0,0 +1,330 @@
+###
+# scgi.test - Copyright (c) 2015 Sean Woods
+#
+# Author: Sean Woods, yoda@etoyoc.com
+# Unit tests of the SCGI server
+###
+
+# -------------------------------------------------------------------------
+
+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 cmdline/cmdline.tcl cmdline
+ use fileutil/fileutil.tcl fileutil
+
+ use md5/md5.tcl md5
+ use base64/base64.tcl base64
+ use mime/mime.tcl mime
+
+ use uri/uri.tcl uri
+ use ncgi/ncgi.tcl ncgi
+
+ use dns/ip.tcl ip
+ use nettool/nettool.tcl nettool
+ use html/html.tcl html
+
+ use dicttool/dicttool.tcl dicttool
+ use cron/cron.tcl cron
+ use oodialect/oodialect.tcl oo::dialect
+ use oometa/oometa.tcl oo::meta
+ use sha1/sha1.tcl sha1
+ use tool/index.tcl tool
+}
+
+testing {
+ useLocal httpd.tcl httpd
+ useLocal scgi-app.tcl scgi::app
+}
+
+# -------------------------------------------------------------------------
+namespace eval ::scgi {}
+namespace eval ::scgi::test {}
+
+###
+# Minimal test harness for the .tests
+# Not intended for public consumption
+# (But if you find it handy, please steal!)
+namespace eval ::scgi::test {}
+
+proc ::scgi::encode_request {headers body info} {
+ variable server_block
+
+ dict set outdict CONTENT_LENGTH [string length $body]
+ set outdict [dict merge $outdict $server_block $info]
+ dict set outdict PWD [pwd]
+ foreach {key value} $headers {
+ switch $key {
+ SCRIPT_NAME -
+ REQUEST_METHOD -
+ REQUEST_URI {
+ dict set outdict $key $value
+ }
+ default {
+ dict set outdict HTTP_[string map {"-" "_"} [string toupper $key]] $value
+ }
+ }
+ }
+ set result {}
+ foreach {name value} $outdict {
+ append result $name \x00 $value \x00
+ }
+ return "[string length $result]:$result,"
+}
+
+proc ::scgi::test::send {port text} {
+ set sock [socket localhost $port]
+ variable reply
+ set reply($sock) {}
+ chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
+ chan event $sock readable [list ::scgi::test::get_reply $sock]
+
+ set headers {}
+ set body {}
+ set read_headers 1
+ foreach line [split $text \n] {
+ if {$read_headers} {
+ if { $line eq {} } {
+ set read_headers 0
+ } else {
+ append headers $line \n
+ }
+ } else {
+ append body $line \n
+ }
+ }
+ set block [::scgi::encode_request $headers $body {}]
+ puts -nonewline $sock $block
+ flush $sock
+ puts -nonewline $sock $body
+ flush $sock
+ while {$reply($sock) eq {}} {
+ update
+ }
+ #vwait [namespace current]::reply($sock)
+ return $reply($sock)
+}
+
+proc ::scgi::test::get_reply {sock} {
+ variable buffer
+ set data [read $sock]
+ append buffer($sock) $data
+ if {[eof $sock]} {
+ chan event $sock readable {}
+ set [namespace current]::reply($sock) $buffer($sock)
+ unset buffer($sock)
+ }
+}
+
+namespace eval ::scgi {
+ variable server_block {SCGI 1.0 SERVER_SOFTWARE {TclScgiServer/0.1}}
+}
+
+###
+# Build the reply class
+###
+tool::class create ::scgi::test::reply {
+ superclass ::scgi::reply
+
+ method error {code {msg {}}} {
+ my reset
+ my variable data error_codes
+ if {![info exists data(url)]} {
+ set data(url) {}
+ }
+ if {![info exists error_codes($code)]} {
+ set errorstring "Unknown Error Code"
+ } else {
+ set errorstring $error_codes($code)
+ }
+ my reply_headers replace {}
+ my reply_headers set Status: "$code $errorstring"
+ my reply_headers set Content-Type: {text/plain}
+ my puts "
+$code $errorstring
+Got the error $code $errorstring
+
+while trying to obtain $data(url)
+"
+ }
+
+ method reset {} {
+ my variable reply_body
+ my reply_headers replace {Status: {200 OK} Content-Type: text/plain}
+ set reply_body {}
+ }
+
+ method content {} {
+ my reset
+ switch [my query_headers get REQUEST_URI] {
+ /file {
+ my variable reply_file
+ set reply_file [file join $::here pkgIndex.tcl]
+ }
+ /time {
+ my puts [clock seconds]
+ }
+ /error {
+ error {
+The programmer asked me to die this way
+ }
+ }
+ /echo -
+ default {
+ my puts [my PostData]
+ }
+ }
+ }
+
+ ###
+ # Output the result or error to the channel
+ # and destroy this object
+ ###
+ method output {} {
+ my variable reply_body reply_file reply_chan chan
+ chan configure $chan -translation {binary binary}
+
+ set headers [my reply_headers dump]
+ if {[dict exists $headers Status:]} {
+ set result "[my EncodeStatus [dict get $headers Status:]]\n"
+ } else {
+ set result "[my EncodeStatus {505 Internal Error}]\n"
+
+ }
+ foreach {key value} $headers {
+ # Ignore Status and Content-length, if given
+ if {$key in {Status: Content-length:}} continue
+ append result "$key $value" \n
+ }
+ if {![info exists reply_file] || [string length $reply_body]} {
+ ###
+ # Return dynamic content
+ ###
+ set reply_body [string trim $reply_body]
+ append result "Content-length: [string length $reply_body]" \n \n
+ append result $reply_body
+ puts -nonewline $chan $result
+ } else {
+ ###
+ # Return a stream of data from a file
+ ###
+ append result "Content-length: [file size $reply_file]" \n \n
+ puts -nonewline $chan $result
+ set reply_chan [open $reply_file r]
+ chan copy $reply_chan $chan
+ catch {close $reply_chan}
+ }
+ chan flush $chan
+ my destroy
+ }
+}
+
+###
+# Build the server
+###
+tool::class create scgi::test::app {
+ superclass ::scgi::app
+
+ property reply_class ::scgi::test::reply
+}
+
+scgi::test::app create TESTAPP port 10001
+
+test scgi-client-0001 {Do an echo request} {
+
+set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
+REQUEST_URI /echo
+
+THIS IS MY CODE
+}]
+} {Status: 200 OK
+Content-Type: text/plain
+Connection: close
+Content-length: 15
+
+THIS IS MY CODE}
+
+test scgi-client-0002 {Do another echo request} {
+set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
+REQUEST_URI /echo
+
+THOUGH THERE ARE MANY LIKE IT
+}]
+} {Status: 200 OK
+Content-Type: text/plain
+Connection: close
+Content-length: 29
+
+THOUGH THERE ARE MANY LIKE IT}
+
+test scgi-client-0003 {Do another echo request} {
+set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
+REQUEST_URI /echo
+
+THIS ONE ALONE IS MINE
+}]
+} {Status: 200 OK
+Content-Type: text/plain
+Connection: close
+Content-length: 22
+
+THIS ONE ALONE IS MINE}
+
+test scgi-client-0004 {URL Generates Error} {
+
+set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
+REQUEST_URI /error
+
+THIS ONE ALONE IS MINE
+}] } {Status: 500 Server Internal Error
+Content-Type: text/plain
+Connection: close
+Content-length: 89
+
+500 Server Internal Error
+Got the error 500 Server Internal Error
+
+while trying to obtain}
+
+set checkreply [subst {Status: 200 OK
+Content-Type: text/plain
+Connection: close
+Content-length: 10
+
+[clock seconds]}]
+
+test scgi-client-0005 {URL Different output with a different request} {
+set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
+REQUEST_URI /time
+
+THIS ONE ALONE IS MINE
+}] } $checkreply
+
+set fin [open [file join $here pkgIndex.tcl] r]
+set checkreply [read $fin]
+close $fin
+test scgi-client-0006 {Return a file} {
+set reply [::scgi::test::send 10001 {REQUEST_METHOD POST
+REQUEST_URI /file
+}] } "Status: 200 OK
+Content-Type: text/plain
+Connection: close
+Content-length: [string length $checkreply]
+
+$checkreply"
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/httpwget/pkgIndex.tcl b/tcllib/modules/httpwget/pkgIndex.tcl
new file mode 100644
index 0000000..9ffd345
--- /dev/null
+++ b/tcllib/modules/httpwget/pkgIndex.tcl
@@ -0,0 +1,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 http::wget 0.1 [list source [file join $dir wget.tcl]]
diff --git a/tcllib/modules/httpwget/wget.tcl b/tcllib/modules/httpwget/wget.tcl
new file mode 100644
index 0000000..4b9728e
--- /dev/null
+++ b/tcllib/modules/httpwget/wget.tcl
@@ -0,0 +1,54 @@
+###
+# Tool to download file from the web
+# Enhacements to http
+###
+package provide http::wget 0.1
+package require http
+
+::namespace eval ::http {}
+
+###
+# topic: 1ed971e03ae89415e2f25d20e59b765c
+# description: this proc contributed by Donal Fellows
+###
+proc ::http::_followRedirects {url args} {
+ while 1 {
+ set token [geturl $url -validate 1]
+ set ncode [ncode $token]
+ if { $ncode eq "404" } {
+ error "URL Not found"
+ }
+ switch -glob $ncode {
+ 30[1237] {### redirect - see below ###}
+ default {cleanup $token ; return $url}
+ }
+ upvar #0 $token state
+ array set meta [set ${token}(meta)]
+ cleanup $token
+ if {![info exists meta(Location)]} {
+ return $url
+ }
+ set url $meta(Location)
+ unset meta
+ }
+ return $url
+}
+
+###
+# topic: fced7bc395596569ac225a719c686dcc
+###
+proc ::http::wget {url destfile {verbose 1}} {
+ set tmpchan [open $destfile w]
+ fconfigure $tmpchan -translation binary
+ if { $verbose } {
+ puts [list GETTING [file tail $destfile] from $url]
+ }
+ set real_url [_followRedirects $url]
+ set token [geturl $real_url -channel $tmpchan -binary yes]
+ if {[ncode $token] != "200"} {
+ error "DOWNLOAD FAILED"
+ }
+ cleanup $token
+ close $tmpchan
+}
+
diff --git a/tcllib/modules/ident/ChangeLog b/tcllib/modules/ident/ChangeLog
new file mode 100644
index 0000000..4382fd1
--- /dev/null
+++ b/tcllib/modules/ident/ChangeLog
@@ -0,0 +1,101 @@
+2013-03-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * rfc1413.txt: Removed copies of RFC documents. Keep only links.
+
+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-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 ========================
+ *
+
+2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ident.pcx: New file. Syntax definitions for the public commands
+ of the ident package.
+
+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>
+
+ * ident.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-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ident.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ident.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 ========================
+ *
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-07-19 Andreas Kupries <andreask@activestate.com>
+
+ * ident.man: Polishing the docs (added link to RFC, a 'title', and
+ keywords).
+
+2004-07-10 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * pkgIndex.tcl: Specify Tcl >= 8.2
+ * ident.test: Added cleanupTests so it reports the test stats.
+ * ident.tcl: Changed the package name to 'ident' to correspond
+ with the namespace name. Added license declaration.
+
+2004-07-09 Reinhard Max <max@suse.de>
+
+ * ident.tcl: Ident client implementation, test suite,
+ * ident.test: and documentation
+ * ident.man:
+
+ * rfc1413.txt: RFC describing the Identification Protocol
diff --git a/tcllib/modules/ident/ident.man b/tcllib/modules/ident/ident.man
new file mode 100644
index 0000000..a5d418a
--- /dev/null
+++ b/tcllib/modules/ident/ident.man
@@ -0,0 +1,54 @@
+[comment {-*- Tcl -*- doctools manpage}]
+[manpage_begin ident n 0.42]
+[keywords ident]
+[keywords identification]
+[keywords {rfc 1413}]
+[copyright {2004 Reinhard Max <max@tclers.tk>}]
+[titledesc {Ident protocol client}]
+[moddesc {Identification protocol client}]
+[category Networking]
+[require Tcl 8.3]
+[require ident [opt 0.42]]
+[description]
+
+The [package ident] package provides a client implementation of the ident
+protocol as defined in
+
+RFC 1413 ([uri http://www.rfc-editor.org/rfc/rfc1413.txt]).
+
+[list_begin definitions]
+[call [cmd ::ident::query] [arg socket] [opt [arg callback]]]
+
+This command queries the ident daemon on the remote side of the given
+socket, and returns the result of the query as a dictionary.
+
+Interpreting the dictionary as list the first key will always be
+[const resp-type], and can have one of the values [const USERID],
+[const ERROR], and [const FATAL]. These [term {response types}] have
+the following meanings:
+
+[list_begin definitions]
+[def USERID]
+
+This indicates a successful response. Two more keys and associated
+values are returned, [const opsys], and [const user-id].
+
+[def ERROR]
+
+This means the ident server has returned an error. A second key named
+[const error] is present whose value contains the [const error-type]
+field from the server response.
+
+[def FATAL]
+
+Fatal errors happen when no ident server is listening on the remote
+side, or when the ident server gives a response that does not conform
+to the RFC. A detailed error message is returned under the
+[const error] key.
+
+[list_end]
+[list_end]
+
+[vset CATEGORY ident]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/ident/ident.pcx b/tcllib/modules/ident/ident.pcx
new file mode 100644
index 0000000..e64415c
--- /dev/null
+++ b/tcllib/modules/ident/ident.pcx
@@ -0,0 +1,27 @@
+# -*- tcl -*- ident.pcx
+# Syntax of the commands provided by package ident.
+#
+# 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 ident
+pcx::tcldep 0.42 needs tcl 8.2
+
+namespace eval ::ident {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 0.42 std ::ident::query \
+ {checkSimpleArgs 2 2 {
+ checkChannelID
+ {checkProcCall 1}
+ }}
+
+# Initialization via pcx::init.
+# Use a ::ident::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/ident/ident.tcl b/tcllib/modules/ident/ident.tcl
new file mode 100644
index 0000000..72e0c7c
--- /dev/null
+++ b/tcllib/modules/ident/ident.tcl
@@ -0,0 +1,90 @@
+# ident.tcl --
+#
+# Implemetation of the client side of the ident protocol.
+# See RFC 1413 for details on the protocol.
+#
+# Copyright (c) 2004 Reinhard Max <max@tclers.tk>
+#
+# -------------------------------------------------------------------------
+# This software is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+# or FITNESS FOR A PARTICULAR PURPOSE. See the file 'license.terms' for
+# more details.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: ident.tcl,v 1.2 2004/07/12 14:01:04 patthoyts Exp $
+
+package provide ident 0.42
+
+namespace eval ident {
+ namespace export query configure
+}
+
+proc ident::parse {string} {
+
+ # remove all white space for easier parsing
+ regsub -all {\s} $string "" s
+ if {[regexp {^\d+,\d+:(\w+):(.*)} $s -> resptype addinfo]} {
+ switch -exact -- $resptype {
+ USERID {
+ if { [regexp {^([^,]+)(,([^:]+))?:} \
+ $addinfo -> opsys . charset]
+ } then {
+ # get the user-if from the original string, because it
+ # is allowed to contain white space.
+ set index [string last : $string]
+ incr index
+ set userid [string range $string $index end]
+ if {$charset != ""} {
+ set (user-id) \
+ [encoding convertfrom $charset $userid]
+ }
+ set answer [list resp-type USERID opsys $opsys \
+ user-id $userid]
+ }
+ }
+ ERROR {
+ set answer [list resp-type ERROR error $addinfo]
+ }
+ }
+ }
+ if {![info exists answer]} {
+ set answer [list resp-type FATAL \
+ error "Unexpected response:\"$string\""]
+ }
+ return $answer
+}
+
+proc ident::Callback {sock command} {
+ gets $sock answer
+ close $sock
+ lappend command [parse $answer]
+ eval $command
+}
+
+proc ident::query {socket {command {}}} {
+
+ foreach {sock_ip sock_host sock_port} [fconfigure $socket -sockname] break
+ foreach {peer_ip peer_host peer_port} [fconfigure $socket -peername] break
+
+ set blocking [string equal $command ""]
+ set failed [catch {socket $peer_ip ident} sock]
+ if {$failed} {
+ set result [list resp-type FATAL error $sock]
+ if {$blocking} {
+ return $result
+ } else {
+ after idle [list $command $result]
+ return
+ }
+ }
+ fconfigure $sock -encoding binary -buffering line -blocking $blocking
+ puts $sock "$peer_port,$sock_port"
+ if {$blocking} {
+ gets $sock answer
+ close $sock
+ return [parse $answer]
+ } else {
+ fileevent $sock readable \
+ [namespace code [list Callback $sock $command]]
+ }
+}
diff --git a/tcllib/modules/ident/ident.test b/tcllib/modules/ident/ident.test
new file mode 100644
index 0000000..e6dc03d
--- /dev/null
+++ b/tcllib/modules/ident/ident.test
@@ -0,0 +1,54 @@
+# ident.test -- -*- tcl -*-
+#
+# Tests for the ident package
+#
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal ident.tcl ident
+}
+
+# -------------------------------------------------------------------------
+# Tests
+# -------------------------------------------------------------------------
+
+# good responses
+test {ident-1.0} {normal response} {
+ ident::parse "8888 , 9999 : USERID : UNIX :max"
+} {resp-type USERID opsys UNIX user-id max}
+
+test {ident-1.1} {response with charset} {
+ ident::parse "8888 , 9999 : USERID : UNIX , utf-8 :max"
+} {resp-type USERID opsys UNIX user-id max}
+
+test {ident-1.2} {response with spaces in the user-id} {
+ ident::parse "8888 , 9999 : USERID : UNIX , utf-8 : foo bar "
+} {resp-type USERID opsys UNIX user-id { foo bar }}
+
+# errors from the server
+test {ident-2.0} {error response} {
+ ident::parse "2222,3333 : ERROR : NO-USER"
+} {resp-type ERROR error NO-USER}
+
+# fatal errors
+test {ident-3.0} {empty response} {
+ ident::parse ""
+} {resp-type FATAL error {Unexpected response:""}}
+
+test {ident-3.1} {nonsense} {
+ ident::parse "sadf liubsv"
+} {resp-type FATAL error {Unexpected response:"sadf liubsv"}}
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+
+# -------------------------------------------------------------------------
diff --git a/tcllib/modules/ident/pkgIndex.tcl b/tcllib/modules/ident/pkgIndex.tcl
new file mode 100644
index 0000000..1ffdeb0
--- /dev/null
+++ b/tcllib/modules/ident/pkgIndex.tcl
@@ -0,0 +1,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.2]} {return}
+package ifneeded ident 0.42 [list source [file join $dir ident.tcl]]
+
diff --git a/tcllib/modules/imap4/ChangeLog b/tcllib/modules/imap4/ChangeLog
new file mode 100644
index 0000000..1806558
--- /dev/null
+++ b/tcllib/modules/imap4/ChangeLog
@@ -0,0 +1,73 @@
+2013-10-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * imap4.tcl: Ticket [a761133422]. cleanup called imap close, not
+ * imap4.man: channel close. Fixed. isableto failed to initialize
+ * pkgIndex.tcl: the result variable. Fixed. Bumped version to 0.5.2.
+
+2013-02-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * imap4.tcl: [Bug 3604129] Accepted patch by Gerhard Reithofer.
+ * imap4.man: Missing chan parameter added to all imaptotcl*
+ * pkgIndex.tcl: procs. Bumped version to 0.5.1.
+
+2013-02-11 Andreas Kupries <andreask@activestate.com>
+
+ * imap4.tcl: [Bug 3604129] Applied contribution
+ * imap4.man: by Magnatune. Additional command (copy).
+ * pkgIndex.tcl: Bumped version to 0.5.
+
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2013-01-25 Andreas Kupries <andreask@activestate.com>
+
+ * imap4.man: Updated documentation with text contributed by Nicola
+ Hall, explaining the new commands.
+
+2013-01-22 Andreas Kupries <andreask@activestate.com>
+
+ * imap4.tcl: Applied contribution by Nicola Hall.
+ * imap4.man: Additional commands. Bumped version
+ * pkgIndex.tcl: to 0.4.
+
+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 ========================
+ *
+
+2010-07-16 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Fixed a very stupid typo of mine in the package
+ index.
+
+2010-07-16 Gerhard Reithofer <gerhard.rithofer@tech-edv.co.at>
+
+ * imap4.tcl: Bug in parsing FLAGS in FETCH command repaired.
+ * imap4.man: Updated man pages for package version 0.3
+ removed section "KNOWN BUGS".
+
+2010-07-09 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Added the missing package index. Oops.
+ * imap4.man: Added feedback section, moved openssl uri to
+ references.
+
+2010-07-09 Gerhard Reithofer <gerhard.rithofer@tech-edv.co.at>
+
+ * imap4.tcl: Addining support for TLS/SSL, small cleanups.
+ * imap4.man: Updated man pages for package version 0.2
+
+2010-07-06 Andreas Kupries <andreask@activestate.com>
+
+ * imap4.tcl: Updated to Gerhard Reithofer's re-implementation.
+ * imap4.man: Added Gerhard Reithofer's package documentation.
diff --git a/tcllib/modules/imap4/imap4.man b/tcllib/modules/imap4/imap4.man
new file mode 100644
index 0000000..24d51f8
--- /dev/null
+++ b/tcllib/modules/imap4/imap4.man
@@ -0,0 +1,367 @@
+[manpage_begin imap4 n 0.5.3]
+[see_also ftp]
+[see_also http]
+[see_also imap]
+[see_also mime]
+[see_also pop3]
+[see_also tls]
+[keywords email]
+[keywords imap]
+[keywords internet]
+[keywords mail]
+[keywords net]
+[keywords rfc3501]
+[keywords ssl]
+[keywords tls]
+[moddesc {imap client}]
+[titledesc {imap client-side tcl implementation of imap protocol}]
+
+[require Tcl 8.5]
+[require imap4 [opt 0.5.2]]
+
+[description]
+
+The [package imap4] library package provides the client side of the
+[emph "Internet Message Access Protocol"] (IMAP) using standard
+sockets or secure connection via TLS/SSL.
+The package is fully implemented in Tcl.
+
+[para]
+This document describes the procedures and explains their usage.
+
+[section "PROCEDURES"]
+This package defines the following public procedures:
+
+[list_begin definitions]
+[call [cmd ::imap4::open] [arg hostname] [opt [arg port]]]
+[para]Open a new IMAP connection and initalize the handler,
+the imap communication channel (handler) is returned.
+[para][arg hostname] - mail server
+[para][arg port] - connection port, defaults to 143
+[para]The namespace variable [option ::imap4::use_ssl]
+can be used to establish to a secure connection
+via TSL/SSL if set to true. In this case default connection port
+defaults to 993.
+[para][emph Note:]
+For connecting via SSL the Tcl module [emph tls] must be already
+loaded otherwise an error is raised.
+[example {
+ package require tls ; # must be loaded for TLS/SSL
+ set ::imap4::use_ssl 1 ; # request a secure connection
+ set chan [::imap4::open $server] ; # default port is now 993 }]
+
+[call [cmd ::imap4::starttls] [arg chan]]
+
+Use this when tasked with connecting to an unsecure port which must be
+changed to a secure port prior to user login. This feature is known
+as [term STARTTLS].
+
+[call [cmd ::imap4::login] [arg chan] [arg user] [arg pass]]
+[para]Login using the IMAP LOGIN command, 0 is returned on successful login.
+[para][arg chan] - imap channel
+[para][arg user] - username
+[para][arg pass] - password
+
+[call [cmd ::imap4::folders] [arg chan] [opt [arg "-inline"]] [opt [arg mboxref]] [opt [arg mboxname]]]
+[para]Get list of matching folders, 0 is returned on success.
+[para]Wildcards '*' as '%' are allowed for [arg mboxref] and [arg mboxname],
+command [cmd ::imap4::folderinfo] can be used to retrieve folder information.
+[para][arg chan] - imap channel
+[para][arg mboxref] - mailbox reference, defaults to ""
+[para][arg mboxname] - mailbox name, defaults to "*"
+[para]If [option "-inline"] is specified a compact folderlist is
+returned instead of the result code. All flags are converted to
+lowercase and leading special characters are removed.
+[example {{{Arc08 noselect} {Arc08/Private {noinferiors unmarked}} {INBOX noinferiors}}}]
+
+[call [cmd ::imap4::select] [arg chan] [opt [arg mailbox]]]
+[para]Select a mailbox, 0 is returned on success.
+[para][arg chan] - imap channel
+[para][arg mailbox] - Path of the mailbox, defaults to [emph INBOX]
+[para]Prior to examine/select an open mailbox must be closed - see: [cmd ::imap4::close].
+
+[call [cmd ::imap4::examine] [arg chan] [opt [arg mailbox]]]
+[para]"Examines" a mailbox, read-only equivalent of [cmd ::imap4::select].
+[para][arg chan] - imap channel
+[para][arg mailbox] - mailbox name or path to mailbox,
+defaults to [emph INBOX]
+[para]Prior to examine/select an open mailbox must be closed - see: [cmd ::imap4::close].
+
+[call [cmd ::imap4::fetch] [arg chan] [arg range] [opt [arg -inline]] [opt [arg "attr ..."]]]
+[para]Fetch attributes from messages.
+[para]The attributes are fetched and stored in the internal state
+which can be retrieved with command [cmd ::imap4::msginfo], 0 is returned
+on success.
+If [option -inline] is specified, alle records are returned as list
+in order as defined in the [arg attr] argument.
+[para][arg chan] - imap channel
+[para][arg range] - message index in format [emph FROM]:[emph TO]
+[para][arg attr] - imap attributes to fetch
+[para][emph Note:]
+If [emph FROM] is omitted, the 1st message is assumed,
+if [emph TO] is ommitted the last message is assumed.
+All message index ranges are 1-based.
+
+[call [cmd ::imap4::noop] [arg chan]]
+Send NOOP command to server. May get information as untagged data.
+[para][arg chan] - imap channel
+
+[call [cmd ::imap4::check] [arg chan]]
+Send CHECK command to server. Flush to disk.
+[para][arg chan] - imap channel
+
+[call [cmd ::imap4::folderinfo] [arg chan] [opt [arg info]]]
+[para]Get information on the recently selected folderlist.
+If the [arg info] argument is omitted or a null string, the full list
+of information available for the mailbox is returned.
+[para]If the required information name is suffixed with a ? character,
+the command returns true if the information is available, or
+false if it is not.
+[para][arg chan] - imap channel
+[para][arg info] - folderlist options to retrieve
+[para]
+Currently supported options:
+[emph delim] - hierarchy delimiter only,
+[emph match] - ref and mbox search patterns (see [cmd ::imap4::folders]),
+[emph names] - list of folder names only,
+[emph flags] - list of folder names with flags in format
+[emph "{ {name {flags}} ... }"] (see also compact format in function
+[cmd ::imap4::folders]).
+[example {
+{{Arc08 {{\NoSelect}}} {Arc08/Private {{\NoInferiors} {\UnMarked}}} {INBOX {\NoInferiors}}}
+}]
+[call [cmd ::imap4::msginfo] [arg chan] [arg msgid] [opt [arg info]] [opt [arg defval]]]
+[para]Get information (from previously collected using fetch) from a given
+[emph msgid]. If the 'info' argument is omitted or a null string,
+the list of available information options for the given message is
+returned.
+[para]If the required information name is suffixed with a ? character,
+the command returns true if the information is available, or
+false if it is not.
+[para][arg chan] - imap channel
+[para][arg msgid] - message number
+[para][arg info] - imap keyword to retrieve
+[para][arg defval] - default value, returned if info is empty
+
+[para]
+[emph Note:]
+All message index ranges are 1-based.
+
+[call [cmd ::imap4::mboxinfo] [arg chan] [opt [arg info]]]
+[para]Get information on the currently selected mailbox.
+If the [arg info] argument is omitted or a null string, the list
+of available information options for the mailbox is returned.
+[para]If the required information name is suffixed with a ? character,
+the command returns true if the information is available, or
+false if it is not.
+[para][arg chan] - imap channel
+[para][arg opt] - mailbox option to retrieve
+[para]
+Currently supported options:
+[emph EXISTS] (noof msgs),
+[emph RECENT] (noof 'recent' flagged msgs),
+[emph FLAGS]
+[para]In conjunction with OK:
+[emph PERMFLAGS], [emph UIDNEXT], [emph UIDVAL], [emph UNSEEN]
+[para]Div. states:
+[emph CURRENT], [emph FOUND], [emph PERM].
+
+[example {
+ ::imap4::select $chan INBOX
+ puts "[::imap4::mboxinfo $chan exists] mails in INBOX"}]
+
+[call [cmd ::imap4::isableto] [arg chan] [opt [arg capability]]]
+[para]Test for capability.
+It returns 1 if requested capability is supported, 0 otherwise.
+If [arg capability] is omitted all capability imap
+codes are retured as list.
+[para][arg chan] - imap channel
+[para][arg info] - imap keyword to retrieve
+
+[para]
+[emph Note:]
+Use the capability command to ask the server if not
+already done by the user.
+
+[call [cmd ::imap4::create] [arg chan] [arg mailbox]]
+[para]Create a new mailbox.
+[para][arg chan] - imap channel
+[para][arg mailbox] - mailbox name
+
+[call [cmd ::imap4::delete] [arg chan] [arg mailbox]]
+[para]Delete a new mailbox.
+[para][arg chan] - imap channel
+[para][arg mailbox] - mailbox name
+
+[call [cmd ::imap4::rename] [arg chan] [arg oldname] [arg newname]]
+[para]Rename a new mailbox.
+[para][arg chan] - imap channel
+[para][arg mailbox] - old mailbox name
+[para][arg mailbox] - new mailbox name
+
+[call [cmd ::imap4::subscribe] [arg chan] [arg mailbox]]
+[para]Subscribe a new mailbox.
+[para][arg chan] - imap channel
+[para][arg mailbox] - mailbox name
+
+[call [cmd ::imap4::unsubscribe] [arg chan] [arg mailbox]]
+[para]Unsubscribe a new mailbox.
+[para][arg chan] - imap channel
+[para][arg mailbox] - mailbox name
+
+[call [cmd ::imap4::search] [arg chan] [arg expr] [opt [arg "..."]] ]
+[para]Search for mails matching search criterions, 0 is returned on success.
+[para][arg chan] - imap channel
+[para][arg expr] - imap search expression
+
+[para]
+[emph Notes:]
+Currently the following search expressions are handled:
+[para][emph "Mail header flags:"]
+all mail header entries (ending with a colon ":"), like "From:", "Bcc:", ...
+[para][emph "Imap message search flags:"]
+ANSWERED, DELETED, DRAFT, FLAGGED, RECENT,
+SEEN, NEW, OLD, UNANSWERED, UNDELETED,
+UNDRAFT, UNFLAGGED, UNSEEN, ALL
+[para][emph "Imap header search flags:"]
+BODY, CC, FROM, SUBJECT, TEXT, KEYWORD, BCC
+[para][emph "Imap conditional search flags:"]
+SMALLER, LARGER, ON, SENTBEFORE, SENTON, SENTSINCE, SINCE,
+BEFORE (not implemented),
+UID (not implemented)
+[para][emph "Logical search conditions:"]
+OR, NOT
+[example {::imap4::search $chan larger 4000 seen
+puts "Found messages: [::imap4::mboxinfo $chan found]"
+Found messages: 1 3 6 7 8 9 13 14 15 19 20}]
+
+[call [cmd ::imap4::close] [arg chan]]
+[para]Close the mailbox. Permanently removes \Deleted messages and
+return to the AUTH state.
+[para][arg chan] - imap channel
+
+[call [cmd ::imap4::cleanup] [arg chan]]
+[para]Destroy an IMAP connection and free the used space.
+Close the mailbox. Permanently removes \Deleted messages
+and return to the AUTH state.
+[para][arg chan] - imap channel
+
+[call [cmd ::imap4::debugmode] [arg chan] [opt [arg errormsg]]]
+Switch client into command line debug mode.
+[para]This is a developers mode only that pass the control to the
+programmer. Every line entered is sent verbatim to the
+server (after the addition of the request identifier).
+The ::imap4::debug variable is automatically set to '1' on enter.
+[para]It's possible to execute Tcl commands starting the line
+with a slash.
+[para][arg chan] - imap channel
+[para][arg errormsg] - optional error message to display
+
+[call [cmd ::imap4::store] [arg chan] [arg range] [arg data] [arg flaglist]]
+
+[para] Alters data associated with a message in the selected
+mailbox.
+
+[para][arg chan] - imap channel
+[para][arg range] - message index in format [emph FROM]:[emph TO]
+[para][arg flaglist] - Flags the [arg data] operates on.
+[para][arg data] - The currently defined [arg data] items that can be
+stored are shown below. [emph Note] that all of these data types may
+also be suffixed with ".SILENT" to suppress the untagged FETCH
+response.
+
+[list_begin definitions]
+[def FLAGS]
+Replace the flags for the message (other than \Recent) with the
+[arg flaglist].
+[def "+FLAGS"]
+Add the flags in [arg flaglist] to the existing flags for the message.
+[def "-FLAGS"]
+Remove the flags in [arg flaglist] to the existing flags for the
+message.
+[list_end]
+
+For example:
+[example {
+ ::imap4::store $chan $start_msgid:$end_msgid +FLAGS "Deleted"
+}]
+
+[call [cmd ::imap4::expunge] [arg chan]]
+
+[para] Permanently removes all messages that have the \Deleted flag
+set from the currently selected mailbox, without the need to close the
+connection.
+
+[para][arg chan] - imap channel
+
+[call [cmd ::imap4::copy] [arg chan] [arg msgid] [arg mailbox]]
+
+[para] Copies the specified message (identified by its message number)
+to the named mailbox, i.e. imap folder.
+
+[para][arg chan] - imap channel
+[para][arg msgid] - message number
+[para][arg mailbox] - mailbox name
+
+[call [cmd ::imap4::logout] [arg chan]]
+
+[para] Informs the server that the client is done with the connection
+and closes the network connection. Permanently removes \Deleted
+messages.
+
+[para] A new connection will need to be established to login once
+more.
+
+[para][arg chan] - imap channel
+
+[list_end]
+
+[section EXAMPLES]
+
+[example_begin]
+ set user myusername
+ set pass xtremescrt
+ set server imap.test.tld
+ set FOLDER INBOX
+ # Connect to server
+ set imap [lb]::imap4::open $server[rb]
+ ::imap4::login $imap $user $pass
+ ::imap4::select $imap $FOLDER
+ # Output all the information about that mailbox
+ foreach info [lb]::imap4::mboxinfo $imap[rb] {
+ puts "$info -> [lb]::imap4::mboxinfo $imap $info[rb]"
+ }
+ # fetch 3 records inline
+ set fields {from: to: subject: size}
+ foreach rec [lb]::imap4::fetch $imap :3 -inline {*}$fields[rb] {
+ puts -nonewline "#[lb]incr idx[rb])"
+ for {set j 0} {$j<[lb]llength $fields[rb]} {incr j} {
+ puts "\t[lb]lindex $fields $j[rb] [lb]lindex $rec $j[rb]"
+ }
+ }
+
+ # Show all the information available about the message ID 1
+ puts "Available info about message 1: [lb]::imap4::msginfo $imap 1[rb]"
+
+ # Use the capability stuff
+ puts "Capabilities: [lb]::imap4::isableto $imap[rb]"
+ puts "Is able to imap4rev1? [lb]::imap4::isableto $imap imap4rev1[rb]"
+
+ # Cleanup
+ ::imap4::cleanup $imap
+[example_end]
+
+[include ../common-text/tls-security-notes.inc]
+
+[section REFERENCES]
+Mark R. Crispin, "INTERNET MESSAGE ACCESS PROTOCOL - VERSION 4rev1",
+RFC 3501, March 2003, [uri http://www.rfc-editor.org/rfc/rfc3501.txt]
+
+[para]
+OpenSSL, [uri http://www.openssl.org/]
+
+[vset CATEGORY imap4]
+[include ../doctools2base/include/feedback.inc]
+
+Only a small part of rfc3501 implemented.
+[manpage_end]
diff --git a/tcllib/modules/imap4/imap4.tcl b/tcllib/modules/imap4/imap4.tcl
new file mode 100644
index 0000000..460c065
--- /dev/null
+++ b/tcllib/modules/imap4/imap4.tcl
@@ -0,0 +1,1382 @@
+# IMAP4 protocol pure Tcl implementation.
+#
+# COPYRIGHT AND PERMISSION NOTICE
+#
+# Copyright (C) 2004 Salvatore Sanfilippo <antirez@invece.org>.
+# Copyright (C) 2013 Nicola Hall <nicci.hall@gmail.com>
+# Copyright (C) 2013 Magnatune <magnatune@users.sourceforge.net>
+#
+# All rights reserved.
+#
+# Permission is hereby granted, free of charge, to any person obtaining a
+# copy of this software and associated documentation files (the
+# "Software"), to deal in the Software without restriction, including
+# without limitation the rights to use, copy, modify, merge, publish,
+# distribute, and/or sell copies of the Software, and to permit persons
+# to whom the Software is furnished to do so, provided that the above
+# copyright notice(s) and this permission notice appear in all copies of
+# the Software and that both the above copyright notice(s) and this
+# permission notice appear in supporting documentation.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+# OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT
+# OF THIRD PARTY RIGHTS. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
+# HOLDERS INCLUDED IN THIS NOTICE BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL
+# INDIRECT OR CONSEQUENTIAL DAMAGES, OR ANY DAMAGES WHATSOEVER RESULTING
+# FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
+# NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
+# WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+#
+# Except as contained in this notice, the name of a copyright holder
+# shall not be used in advertising or otherwise to promote the sale, use
+# or other dealings in this Software without prior written authorization
+# of the copyright holder.
+
+# TODO
+# - Idle mode
+# - Async mode
+# - Authentications
+# - Literals on file mode
+# - fix OR in search, and implement time-related searches
+# All the rest... see the RFC
+
+# History
+# 20100623: G. Reithofer, creating tcl package 0.1, adding some todos
+# option -inline for ::imap4::fetch, in order to return data as a Tcl list
+# isableto without arguments returns the capability list
+# implementation of LIST command
+# 20100709: Adding suppport for SSL connections, namespace variable
+# use_ssl must be set to 1 and package TLS must be loaded
+# 20100716: Bug in parsing special leading FLAGS characters in FETCH
+# command repaired, documentation cleanup.
+# 20121221: Added basic scope, expunge and logout function
+# 20130212: Added basic copy function
+# 20130212: Missing chan parameter added to all imaptotcl* procs -ger
+
+package require Tcl 8.5
+package provide imap4 0.5.3
+
+namespace eval imap4 {
+ variable debugmode 0 ;# inside debug mode? usually not.
+ variable folderinfo
+ variable mboxinfo
+ variable msginfo
+ variable info
+
+ # if set to 1 tls::socket must be loaded
+ variable use_ssl 0
+
+ # Debug mode? Don't use it for production! It will print debugging
+ # information to standard output and run a special IMAP debug mode shell
+ # on protocol error.
+ variable debug 0
+
+ # Version
+ variable version "2013-02-12"
+
+ # This is where we take state of all the IMAP connections.
+ # The following arrays are indexed with the connection channel
+ # to access the per-channel information.
+ array set folderinfo {} ;# list of folders.
+ array set mboxinfo {} ;# selected mailbox info.
+ array set msginfo {} ;# messages info.
+ array set info {} ;# general connection state info.
+
+ # Return the next tag to use in IMAP requests.
+ proc tag {chan} {
+ variable info
+ incr info($chan,curtag)
+ }
+
+ # Assert that the channel is one of the specified states
+ # by the 'states' list.
+ # otherwise raise an error.
+ proc requirestate {chan states} {
+ variable info
+ if {[lsearch $states $info($chan,state)] == -1} {
+ error "IMAP channel not in one of the following states: '$states' (current state is '$info($chan,state)')"
+ }
+ }
+
+ # Open a new IMAP connection and initalize the handler.
+ proc open {hostname {port 0}} {
+ variable info
+ variable debug
+ variable use_ssl
+ if {$debug} {
+ puts "I: open $hostname $port (SSL=$use_ssl)"
+ }
+
+ if {$use_ssl} {
+ if {[info procs ::tls::socket] eq ""} {
+ error "Package TLS must be loaded for secure connections."
+ }
+ if {!$port} {
+ set port 993
+ }
+ set chan [::tls::socket $hostname $port]
+ } else {
+ if {!$port} {
+ set port 143
+ }
+ set chan [socket $hostname $port]
+ }
+ fconfigure $chan -encoding binary -translation binary
+ # Intialize the connection state array
+ initinfo $chan
+ # Get the banner
+ processline $chan
+ # Save the banner
+ set info($chan,banner) [lastline $chan]
+ return $chan
+ }
+
+ # Initialize the info array for a new connection.
+ proc initinfo {chan} {
+ variable info
+ set info($chan,curtag) 0
+ set info($chan,state) NOAUTH
+ set info($chan,folders) {}
+ set info($chan,capability) {}
+ set info($chan,raise_on_NO) 1
+ set info($chan,raise_on_BAD) 1
+ set info($chan,idle) {}
+ set info($chan,lastcode) {}
+ set info($chan,lastline) {}
+ set info($chan,lastrequest) {}
+ }
+
+ # Destroy an IMAP connection and free the used space.
+ proc cleanup {chan} {
+ variable info
+ variable folderinfo
+ variable mboxinfo
+ variable msginfo
+
+ ::close $chan
+
+ array unset folderinfo $chan,*
+ array unset mboxinfo $chan,*
+ array unset msginfo $chan,*
+ array unset info $chan,*
+
+ return $chan
+ }
+
+ # STARTTLS
+ # This is a new procc added to runs the STARTTLS command. Use
+ # this when tasked with connecting to an unsecure port which must
+ # be changed to a secure port prior to user login. This feature
+ # is known as STARTTLS.
+
+ proc starttls {chan} {
+ #puts "Starting TLS"
+ request $chan "STARTTLS"
+ if {[getresponse $chan]} {
+ #puts "error sending STARTTLS"
+ return 1
+ }
+
+ #puts "TLS import"
+ set chan [::tls::import $chan -tls1 1]
+ #puts "TLS handshake"
+ set chan [::tls::handshake $chan]
+ return 0
+ }
+
+ # Returns the last error code received.
+ proc lastcode {chan} {
+ variable info
+ return $info($chan,lastcode)
+ }
+
+ # Returns the last line received from the server.
+ proc lastline {chan} {
+ variable info
+ return $info($chan,lastline)
+ }
+
+ # Process an IMAP response line.
+ # This function trades semplicity in IMAP commands
+ # implementation with monolitic handling of responses.
+ # However note that the IMAP server can reply to a command
+ # with many different untagged info, so to have the reply
+ # processing centralized makes this simple to handle.
+ #
+ # Returns the line's tag.
+ proc processline {chan} {
+ variable info
+ variable debug
+ variable mboxinfo
+ variable folderinfo
+
+ set literals {}
+ while {1} {
+ # Read a line
+ if {[gets $chan buf] == -1} {
+ error "IMAP unexpected EOF from server."
+ }
+
+ append line $buf
+ # Remove the trailing CR at the end of the line, if any.
+ if {[string index $line end] eq "\r"} {
+ set line [string range $line 0 end-1]
+ }
+
+ # Check if there is a literal to read, and read it if any.
+ if {[regexp {{([0-9]+)}\s+$} $buf => length]} {
+ # puts "Reading $length bytes of literal..."
+ lappend literals [read $chan $length]
+ } else {
+ break
+ }
+ }
+ set info($chan,lastline) $line
+
+ if {$debug} {
+ puts "S: $line"
+ }
+
+ # Extract the tag.
+ set idx [string first { } $line]
+ if {$idx <= 0} {
+ protoerror $chan "IMAP: malformed response '$line'"
+ }
+
+ set tag [string range $line 0 [expr {$idx-1}]]
+ set line [string range $line [expr {$idx+1}] end]
+ # If it's just a command continuation response, return.
+ if {$tag eq {+}} {return +}
+
+ # Extract the error code, if it's a tagged line
+ if {$tag ne "*"} {
+ set idx [string first { } $line]
+ if {$idx <= 0} {
+ protoerror $chan "IMAP: malformed response '$line'"
+ }
+ set code [string range $line 0 [expr {$idx-1}]]
+ set line [string trim [string range $line [expr {$idx+1}] end]]
+ set info($chan,lastcode) $code
+ }
+
+ # Extract information from the line
+ set dirty 0
+ switch -glob -- $line {
+ {*\[READ-ONLY\]*} {set mboxinfo($chan,perm) READ-ONLY; incr dirty}
+ {*\[READ-WRITE\]*} {set mboxinfo($chan,perm) READ-WRITE; incr dirty}
+ {*\[TRYCREATE\]*} {set mboxinfo($chan,perm) TRYCREATE; incr dirty}
+ {LIST *(*)*} {
+ # regexp not secure enough ... delimiters must be PLAIN SPACES (see RFC)
+ # set res [regexp {LIST (\(.*\))(!?\s)[ ](.*)$} $line => flags delim fname]
+ # p1| p2| p3|
+ # LIST (\Noselect) "/" ~/Mail/foo
+ set p1 [string first "(" $line]
+ set p2 [string first ")" $line [expr {$p1+1}]]
+ set p3 [string first " " $line [expr {$p2+2}]]
+ if {$p1<0||$p2<0||$p3<0} {
+ protoerror $chan "IMAP: Not a valid RFC822 LIST format in '$line'"
+ }
+ set flags [string range $line [expr {$p1+1}] [expr {$p2-1}]]
+ set delim [string range $line [expr {$p2+2}] [expr {$p3-1}]]
+ set fname [string range $line [expr {$p3+1}] end]
+ if {$fname eq ""} {
+ set folderinfo($chan,delim) [string trim $delim "\""]
+ } else {
+ set fflag {}
+ foreach f [split $flags] {
+ lappend fflag $f
+ }
+ lappend folderinfo($chan,names) $fname
+ lappend folderinfo($chan,flags) [list $fname $fflag]
+ if {$delim ne "NIL"} {
+ set folderinfo($chan,delim) [string trim $delim "\""]
+ }
+ }
+ incr dirty
+ }
+ {FLAGS *(*)*} {
+ regexp {.*\((.*)\).*} $line => flags
+ set mboxinfo($chan,flags) $flags
+ incr dirty
+ }
+ {*\[PERMANENTFLAGS *(*)*\]*} {
+ regexp {.*\[PERMANENTFLAGS \((.*)\).*\].*} $line => flags
+ set mboxinfo($chan,permflags) $flags
+ incr dirty
+ }
+ }
+
+ if {!$dirty && $tag eq {*}} {
+ switch -regexp -nocase -- $line {
+ {^[0-9]+\s+EXISTS} {
+ regexp {^([0-9]+)\s+EXISTS} $line => mboxinfo($chan,exists)
+ incr dirty
+ }
+ {^[0-9]+\s+RECENT} {
+ regexp {^([0-9]+)\s+RECENT} $line => mboxinfo($chan,recent)
+ incr dirty
+ }
+ {.*?\[UIDVALIDITY\s+[0-9]+?\]} {
+ regexp {.*?\[UIDVALIDITY\s+([0-9]+?)\]} $line => \
+ mboxinfo($chan,uidval)
+ incr dirty
+ }
+ {.*?\[UNSEEN\s+[0-9]+?\]} {
+ regexp {.*?\[UNSEEN\s+([0-9]+?)\]} $line => \
+ mboxinfo($chan,unseen)
+ incr dirty
+ }
+ {.*?\[UIDNEXT\s+[0-9]+?\]} {
+ regexp {.*?\[UIDNEXT\s+([0-9]+?)\]} $line => \
+ mboxinfo($chan,uidnext)
+ incr dirty
+ }
+ {^[0-9]+\s+FETCH} {
+ processfetchline $chan $line $literals
+ incr dirty
+ }
+ {^CAPABILITY\s+.*} {
+ regexp {^CAPABILITY\s+(.*)\s*$} $line => capstring
+ set info($chan,capability) [split [string toupper $capstring]]
+ incr dirty
+ }
+ {^LIST\s*$} {
+ regexp {^([0-9]+)\s+EXISTS} $line => mboxinfo($chan,exists)
+ incr dirty
+ }
+ {^SEARCH\s*$} {
+ # Search tag without list of messages. Nothing found
+ # so we set an empty list.
+ set mboxinfo($chan,found) {}
+ }
+ {^SEARCH\s+.*} {
+ regexp {^SEARCH\s+(.*)\s*$} $line => foundlist
+ set mboxinfo($chan,found) $foundlist
+ incr dirty
+ }
+ default {
+ if {$debug} {
+ puts "*** WARNING: unprocessed server reply '$line'"
+ }
+ }
+ }
+ }
+
+ if {[string length [set info($chan,idle)]] && $dirty} {
+ # ... Notify.
+ }
+
+ # if debug and no dirty and untagged line... warning: unprocessed IMAP line
+ return $tag
+ }
+
+ # Process untagged FETCH lines.
+ proc processfetchline {chan line literals} {
+ variable msginfo
+ regexp -nocase {([0-9]+)\s+FETCH\s+(\(.*\))} $line => msgnum items
+ foreach {name val} [imaptotcl $chan items literals] {
+ set attribname [switch -glob -- [string toupper $name] {
+ INTERNALDATE {format internaldate}
+ BODYSTRUCTURE {format bodystructure}
+ {BODY\[HEADER.FIELDS*\]} {format fields}
+ {BODY.PEEK\[HEADER.FIELDS*\]} {format fields}
+ {BODY\[*\]} {format body}
+ {BODY.PEEK\[*\]} {format body}
+ HEADER {format header}
+ RFC822.HEADER {format header}
+ RFC822.SIZE {format size}
+ RFC822.TEXT {format text}
+ ENVELOPE {format envelope}
+ FLAGS {format flags}
+ UID {format uid}
+ default {
+ protoerror $chan "IMAP: Unknown FETCH item '$name'. Upgrade the software"
+ }
+ }]
+
+ switch -- $attribname {
+ fields {
+ set last_fieldname __garbage__
+ foreach f [split $val "\n\r"] {
+ # Handle multi-line headers. Append to the last header
+ # if this line starts with a tab character.
+ if {[string is space [string index $f 0]]} {
+ append msginfo($chan,$msgnum,$last_fieldname) " [string range $f 1 end]"
+ continue
+ }
+ # Process the line searching for a new field.
+ if {![string length $f]} continue
+ if {[set fnameidx [string first ":" $f]] == -1} {
+ protoerror $chan "IMAP: Not a valid RFC822 field '$f'"
+ }
+ set fieldname [string tolower [string range $f 0 $fnameidx]]
+ set last_fieldname $fieldname
+ set fieldval [string trim \
+ [string range $f [expr {$fnameidx+1}] end]]
+ set msginfo($chan,$msgnum,$fieldname) $fieldval
+ }
+ }
+ default {
+ set msginfo($chan,$msgnum,$attribname) $val
+ }
+ }
+ #puts "$attribname -> [string range $val 0 20]"
+ }
+ # parray msginfo
+ }
+
+ # Convert IMAP data into Tcl data. Consumes the part of the
+ # string converted.
+ # 'literals' is a list with all the literals extracted
+ # from the original line, in the same order they appeared.
+ proc imaptotcl {chan datavar literalsvar} {
+ upvar 1 $datavar data $literalsvar literals
+ set data [string trim $data]
+ switch -- [string index $data 0] {
+ \{ {imaptotcl_literal $chan data literals}
+ "(" {imaptotcl_list $chan data literals}
+ "\"" {imaptotcl_quoted $chan data}
+ 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 {imaptotcl_number $chan data}
+ \) {imaptotcl_endlist $chan data;# that's a trick to parse lists}
+ default {imaptotcl_symbol $chan data}
+ }
+ }
+
+ # Extract a literal
+ proc imaptotcl_literal {chan datavar literalsvar} {
+ upvar 1 $datavar data $literalsvar literals
+ if {![regexp {{.*?}} $data match]} {
+ protoerror $chan "IMAP data format error: '$data'"
+ }
+ set data [string range $data [string length $match] end]
+ set retval [lindex $literals 0]
+ set literals [lrange $literals 1 end]
+ return $retval
+ }
+
+ # Extract a quoted string
+ proc imaptotcl_quoted {chan datavar} {
+ upvar 1 $datavar data
+ if {![regexp "\\s*?(\".*?\[^\\\\\]\"|\"\")\\s*?" $data => match]} {
+ protoerror $chan "IMAP data format error: '$data'"
+ }
+ set data [string range $data [string length $match] end]
+ return [string range $match 1 end-1]
+ }
+
+ # Extract a number
+ proc imaptotcl_number {chan datavar} {
+ upvar 1 $datavar data
+ if {![regexp {^[0-9]+} $data match]} {
+ protoerror $chan "IMAP data format error: '$data'"
+ }
+ set data [string range $data [string length $match] end]
+ return $match
+ }
+
+ # Extract a "symbol". Not really exists in IMAP, but there
+ # are named items, and this names have a strange unquoted
+ # syntax like BODY[HEAEDER.FIELD (From To)] and other stuff
+ # like that.
+ proc imaptotcl_symbol {chan datavar} {
+ upvar 1 $datavar data
+ # matching patterns: "BODY[HEAEDER.FIELD",
+ # "HEAEDER.FIELD", "\Answered", "$Forwarded"
+ set pattern {([\w\.]+\[[^\[]+\]|[\w\.]+|[\\\$]\w+)}
+ if {![regexp $pattern $data => match]} {
+ protoerror $chan "IMAP data format error: '$data'"
+ }
+ set data [string range $data [string length $match] end]
+ return $match
+ }
+
+ # Extract an IMAP list.
+ proc imaptotcl_list {chan datavar literalsvar} {
+ upvar 1 $datavar data $literalsvar literals
+ set list {}
+ # Remove the first '(' char
+ set data [string range $data 1 end]
+ # Get all the elements of the list. May indirectly recurse called
+ # by [imaptotcl].
+ while {[string length $data]} {
+ set ele [imaptotcl $chan data literals]
+ if {$ele eq {)}} {
+ break
+ }
+ lappend list $ele
+ }
+ return $list
+ }
+
+ # Just extracts the ")" character alone.
+ # This is actually part of the list extraction work.
+ proc imaptotcl_endlist {chan datavar} {
+ upvar 1 $datavar data
+ set data [string range $data 1 end]
+ return ")"
+ }
+
+ # Process IMAP responses. If the IMAP channel is not
+ # configured to raise errors on IMAP errors, returns 0
+ # on OK response, otherwise 1 is returned.
+ proc getresponse {chan} {
+ variable info
+
+ # Process lines until the tagged one.
+ while {[set tag [processline $chan]] eq {*} || $tag eq {+}} {}
+ switch -- [lastcode $chan] {
+ OK {return 0}
+ NO {
+ if {$info($chan,raise_on_NO)} {
+ error "IMAP error: [lastline $chan]"
+ }
+ return 1
+ }
+ BAD {
+ if {$info($chan,raise_on_BAD)} {
+ protoerror $chan "IMAP error: [lastline $chan]"
+ }
+ return 1
+ }
+ default {
+ protoerror $chan "IMAP protocol error. Unknown response code '[lastcode $chan]'"
+ }
+ }
+ }
+
+ # Write a request.
+ proc request {chan request} {
+ variable debug
+ variable info
+
+ set t "[tag $chan] [string trim $request]"
+ if {$debug} {
+ puts "C: $t"
+ }
+ set info($chan,lastrequest) $t
+ puts -nonewline $chan "$t\r\n"
+ flush $chan
+ }
+
+ # Write a multiline request. The 'request' list must contain
+ # parts of command and literals interleaved. Literals are ad odd
+ # list positions (1, 3, ...).
+ proc multiline_request {chan request} {
+ variable debug
+ variable info
+
+ lset request 0 "[tag $chan][lindex $request 0]"
+ set items [llength $request]
+ foreach {line literal} $request {
+ # Send the line
+ if {$debug} {
+ puts "C: $line"
+ }
+ puts -nonewline $chan "$line\r\n"
+ flush $chan
+ incr items -1
+ if {!$items} break
+
+ # Wait for the command continuation response
+ if {[processline $chan] ne {+}} {
+ protoerror $chan "Expected a command continuation response but got '[lastline $chan]'"
+ }
+
+ # Send the literal
+ if {$debug} {
+ puts "C> $literal"
+ }
+ puts -nonewline $chan $literal
+ flush $chan
+ incr items -1
+ }
+ set info($chan,lastrequest) $request
+ }
+
+ # Login using the IMAP LOGIN command.
+ proc login {chan user pass} {
+ variable info
+
+ requirestate $chan NOAUTH
+ request $chan "LOGIN $user $pass"
+ if {[getresponse $chan]} {
+ return 1
+ }
+ set info($chan,state) AUTH
+ return 0
+ }
+
+ # Mailbox selection.
+ proc select {chan {mailbox INBOX}} {
+ selectmbox $chan SELECT $mailbox
+ }
+
+ # Read-only equivalent of SELECT.
+ proc examine {chan {mailbox INBOX}} {
+ selectmbox $chan EXAMINE $mailbox
+ }
+
+ # General function for selection.
+ proc selectmbox {chan cmd mailbox} {
+ variable info
+ variable mboxinfo
+
+ requirestate $chan AUTH
+ # Clean info about the previous mailbox if any,
+ # but save a copy to restore this info on error.
+ set savedmboxinfo [array get mboxinfo $chan,*]
+ array unset mboxinfo $chan,*
+ request $chan "$cmd $mailbox"
+ if {[getresponse $chan]} {
+ array set mboxinfo $savedmboxinfo
+ return 1
+ }
+
+ set info($chan,state) SELECT
+ # Set the new name as mbox->current.
+ set mboxinfo($chan,current) $mailbox
+ return 0
+ }
+
+ # Parse an IMAP range, store 'start' and 'end' in the
+ # named vars. If the first number of the range is omitted,
+ # 1 is assumed. If the second number of the range is omitted,
+ # the value of "exists" of the current mailbox is assumed.
+ #
+ # So : means all the messages.
+ proc parserange {chan range startvar endvar} {
+
+ upvar $startvar start $endvar end
+ set rangelist [split $range :]
+ switch -- [llength $rangelist] {
+ 1 {
+ if {![string is integer $range]} {
+ error "Invalid range"
+ }
+ set start $range
+ set end $range
+ }
+ 2 {
+ foreach {start end} $rangelist break
+ if {![string length $start]} {
+ set start 1
+ }
+ if {![string length $end]} {
+ set end [mboxinfo $chan exists]
+ }
+ if {![string is integer $start] || ![string is integer $end]} {
+ error "Invalid range"
+ }
+ }
+ default {
+ error "Invalid range"
+ }
+ }
+ }
+
+ # Fetch a number of attributes from messages
+ proc fetch {chan range opt args} {
+ if {$opt eq "-inline"} {
+ set inline 1
+ } else {
+ set inline 0
+ set args [linsert $args 0 $opt]
+ }
+ requirestate $chan SELECT
+ parserange $chan $range start end
+
+ set items {}
+ set hdrfields {}
+ foreach w $args {
+ switch -glob -- [string toupper $w] {
+ ALL {lappend items ALL}
+ BODYSTRUCTURE {lappend items BODYSTRUCTURE}
+ ENVELOPE {lappend items ENVELOPE}
+ FLAGS {lappend items FLAGS}
+ SIZE {lappend items RFC822.SIZE}
+ TEXT {lappend items RFC822.TEXT}
+ HEADER {lappend items RFC822.HEADER}
+ UID {lappend items UID}
+ *: {lappend hdrfields $w}
+ default {
+ # Fixme: better to raise an error here?
+ lappend hdrfields $w:
+ }
+ }
+ }
+
+ if {[llength $hdrfields]} {
+ set item {BODY[HEADER.FIELDS (}
+ foreach field $hdrfields {
+ append item [string toupper [string range $field 0 end-1]] { }
+ }
+ set item [string range $item 0 end-1]
+ append item {)]}
+ lappend items $item
+ }
+
+ # Send the request
+ request $chan "FETCH $start:$end ([join $items])"
+ if {[getresponse $chan]} {
+ if {$inline} {
+ # Should we throw an error here?
+ return ""
+ }
+ return 1
+ }
+
+ if {!$inline} {
+ return 0
+ }
+
+ # -inline procesing begins here
+ set mailinfo {}
+ for {set i $start} {$i <= $end} {incr i} {
+ set mailrec {}
+ foreach {h} $args {
+ lappend mailrec [msginfo $chan $i $h ""]
+ }
+ lappend mailinfo $mailrec
+ }
+ return $mailinfo
+ }
+
+ # Get information (previously collected using fetch) from a given message.
+ # If the 'info' argument is omitted or a null string, the full list
+ # of information available for the given message is returned.
+ #
+ # If the required information name is suffixed with a ? character,
+ # the command requires true if the information is available, or
+ # false if it is not.
+ proc msginfo {chan msgid args} {
+ variable msginfo
+
+ switch -- [llength $args] {
+ 0 {
+ set info {}
+ }
+ 1 {
+ set info [lindex $args 0]
+ set use_defval 0
+ }
+ 2 {
+ set info [lindex $args 0]
+ set defval [lindex $args 1]
+ set use_defval 1
+ }
+ default {
+ error "msginfo called with bad number of arguments! Try msginfo channel messageid ?info? ?defaultvalue?"
+ }
+ }
+ set info [string tolower $info]
+ # Handle the missing info case
+ if {![string length $info]} {
+ set list [array names msginfo $chan,$msgid,*]
+ set availinfo {}
+ foreach l $list {
+ lappend availinfo [string range $l \
+ [string length $chan,$msgid,] end]
+ }
+ return $availinfo
+ }
+
+ if {[string index $info end] eq {?}} {
+ set info [string range $info 0 end-1]
+ return [info exists msginfo($chan,$msgid,$info)]
+ } else {
+ if {![info exists msginfo($chan,$msgid,$info)]} {
+ if {$use_defval} {
+ return $defval
+ } else {
+ error "No such information '$info' available for message id '$msgid'"
+ }
+ }
+ return $msginfo($chan,$msgid,$info)
+ }
+ }
+
+ # Get information on the currently selected mailbox.
+ # If the 'info' argument is omitted or a null string, the full list
+ # of information available for the mailbox is returned.
+ #
+ # If the required information name is suffixed with a ? character,
+ # the command requires true if the information is available, or
+ # false if it is not.
+ proc mboxinfo {chan {info {}}} {
+ variable mboxinfo
+
+ # Handle the missing info case
+ if {![string length $info]} {
+ set list [array names mboxinfo $chan,*]
+ set availinfo {}
+ foreach l $list {
+ lappend availinfo [string range $l \
+ [string length $chan,] end]
+ }
+ return $availinfo
+ }
+
+ set info [string tolower $info]
+ if {[string index $info end] eq {?}} {
+ set info [string range $info 0 end-1]
+ return [info exists mboxinfo($chan,$info)]
+ } else {
+ if {![info exists mboxinfo($chan,$info)]} {
+ error "No such information '$info' available for the current mailbox"
+ }
+ return $mboxinfo($chan,$info)
+ }
+ }
+
+ # Get information on the last folders list.
+ # If the 'info' argument is omitted or a null string, the full list
+ # of information available for the folders is returned.
+ #
+ # If the required information name is suffixed with a ? character,
+ # the command requires true if the information is available, or
+ # false if it is not.
+ proc folderinfo {chan {info {}}} {
+ variable folderinfo
+
+ # Handle the missing info case
+ if {![string length $info]} {
+ set list [array names folderinfo $chan,*]
+ set availinfo {}
+ foreach l $list {
+ lappend availinfo [string range $l \
+ [string length $chan,] end]
+ }
+ return $availinfo
+ }
+
+ set info [string tolower $info]
+ if {[string index $info end] eq {?}} {
+ set info [string range $info 0 end-1]
+ return [info exists folderinfo($chan,$info)]
+ } else {
+ if {![info exists folderinfo($chan,$info)]} {
+ error "No such information '$info' available for the current folders"
+ }
+ return $folderinfo($chan,$info)
+ }
+ }
+
+
+ # Get capabilties
+ proc capability {chan} {
+ request $chan "CAPABILITY"
+ if {[getresponse $chan]} {
+ return 1
+ }
+ return 0
+ }
+
+ # Get the current state
+ proc state {chan} {
+ variable info
+ return $info($chan,state)
+ }
+
+ # Test for capability. Use the capability command
+ # to ask the server if not already done by the user.
+ proc isableto {chan {capa ""}} {
+ variable info
+
+ set result 0
+ if {![llength $info($chan,capability)]} {
+ set result [capability $chan]
+ }
+
+ if {$capa eq ""} {
+ if {$result} {
+ # We return empty string on error
+ return ""
+ }
+ return $info($chan,capability)
+ }
+
+ set capa [string toupper $capa]
+ expr {[lsearch -exact $info($chan,capability) $capa] != -1}
+ }
+
+ # NOOP command. May get information as untagged data.
+ proc noop {chan} {
+ simplecmd $chan NOOP {NOAUTH AUTH SELECT} {}
+ }
+
+ # CHECK. Flush to disk.
+ proc check {chan} {
+ simplecmd $chan CHECK SELECT {}
+ }
+
+ # Close the mailbox. Permanently removes \Deleted messages and return to
+ # the AUTH state.
+ proc close {chan} {
+ variable info
+
+ if {[simplecmd $chan CLOSE SELECT {}]} {
+ return 1
+ }
+
+ set info($chan,state) AUTH
+ return 0
+ }
+
+ # Create a new mailbox.
+ proc create {chan mailbox} {
+ simplecmd $chan CREATE {AUTH SELECT} $mailbox
+ }
+
+ # Delete a mailbox
+ proc delete {chan mailbox} {
+ simplecmd $chan DELETE {AUTH SELECT} $mailbox
+ }
+
+ # Rename a mailbox
+ proc rename {chan oldname newname} {
+ simplecmd $chan RENAME {AUTH SELECT} $oldname $newname
+ }
+
+ # Subscribe to a mailbox
+ proc subscribe {chan mailbox} {
+ simplecmd $chan SUBSCRIBE {AUTH SELECT} $mailbox
+ }
+
+ # Unsubscribe to a mailbox
+ proc unsubscribe {chan mailbox} {
+ simplecmd $chan UNSUBSCRIBE {AUTH SELECT} $mailbox
+ }
+
+ # List of folders
+ proc folders {chan {opt ""} {ref ""} {mbox "*"}} {
+ variable folderinfo
+ array unset folderinfo $chan,*
+
+ if {$opt eq "-inline"} {
+ set inline 1
+ } else {
+ set ref $opt
+ set mbox $ref
+ set inline 0
+ }
+
+ set folderinfo($chan,match) [list $ref $mbox]
+ # parray folderinfo
+ set rv [simplecmd $chan LIST {SELECT AUTH} \"$ref\" \"$mbox\"]
+ if {$inline} {
+ set rv {}
+ foreach f [folderinfo $chan flags] {
+ set lflags {}
+ foreach fl [lindex $f 1] {
+ if {[string is alnum [string index $fl 0]]} {
+ lappend lflags [string tolower $fl]
+ } else {
+ lappend lflags [string tolower [string range $fl 1 end]]
+ }
+ }
+ lappend rv [list [lindex $f 0] $lflags]
+ }
+ }
+ # parray folderinfo
+ return $rv
+ }
+
+ # This a general implementation for a simple implementation
+ # of an IMAP command that just requires to call ::imap4::request
+ # and ::imap4::getresponse.
+ proc simplecmd {chan command validstates args} {
+ requirestate $chan $validstates
+
+ set req "$command"
+ foreach arg $args {
+ append req " $arg"
+ }
+
+ request $chan $req
+ if {[getresponse $chan]} {
+ return 1
+ }
+
+ return 0
+ }
+
+ # Search command.
+ proc search {chan args} {
+ if {![llength $args]} {
+ error "missing arguments. Usage: search chan arg ?arg ...?"
+ }
+
+ requirestate $chan SELECT
+ set imapexpr [convert_search_expr $args]
+ multiline_prefix_command imapexpr "SEARCH"
+ multiline_request $chan $imapexpr
+ if {[getresponse $chan]} {
+ return 1
+ }
+
+ return 0
+ }
+
+ # Creates an IMAP octect-count.
+ # Used to send literals.
+ proc literalcount {string} {
+ return "{[string length $string]}"
+ }
+
+ # Append a command part to a multiline request
+ proc multiline_append_command {reqvar cmd} {
+ upvar 1 $reqvar req
+
+ if {[llength $req] == 0} {
+ lappend req {}
+ }
+
+ lset req end "[lindex $req end] $cmd"
+ }
+
+ # Append a literal to a multiline request. Uses a quoted
+ # string in simple cases.
+ proc multiline_append_literal {reqvar lit} {
+ upvar 1 $reqvar req
+
+ if {![string is alnum $lit]} {
+ lset req end "[lindex $req end] [literalcount $lit]"
+ lappend req $lit {}
+ } else {
+ multiline_append_command req "\"$lit\""
+ }
+ }
+
+ # Prefix a multiline request with a command.
+ proc multiline_prefix_command {reqvar cmd} {
+ upvar 1 $reqvar req
+
+ if {![llength $req]} {
+ lappend req {}
+ }
+
+ lset req 0 " $cmd[lindex $req 0]"
+ }
+
+ # Concat an already created search expression to a multiline request.
+ proc multiline_concat_expr {reqvar expr} {
+ upvar 1 $reqvar req
+ lset req end "[lindex $req end] ([string range [lindex $expr 0] 1 end]"
+ set req [concat $req [lrange $expr 1 end]]
+ lset req end "[lindex $req end])"
+ }
+
+ # Helper for the search command. Convert a programmer friendly expression
+ # (actually a tcl list) to the IMAP syntax. Returns a list composed of
+ # request, literal, request, literal, ... (to be sent with
+ # ::imap4::multiline_request).
+ proc convert_search_expr {expr} {
+ set result {}
+
+ while {[llength $expr]} {
+ switch -glob -- [string toupper [set token [lpop expr]]] {
+ *: {
+ set wanted [lpop expr]
+ multiline_append_command result "HEADER [string range $token 0 end-1]"
+ multiline_append_literal result $wanted
+ }
+
+ ANSWERED - DELETED - DRAFT - FLAGGED - RECENT -
+ SEEN - NEW - OLD - UNANSWERED - UNDELETED -
+ UNDRAFT - UNFLAGGED - UNSEEN -
+ ALL {multiline_append_command result [string toupper $token]}
+
+ BODY - CC - FROM - SUBJECT - TEXT - KEYWORD -
+ BCC {
+ set wanted [lpop expr]
+ multiline_append_command result "$token"
+ multiline_append_literal result $wanted
+ }
+
+ OR {
+ set first [convert_search_expr [lpop expr]]
+ set second [convert_search_expr [lpop expr]]
+ multiline_append_command result "OR"
+ multiline_concat_expr result $first
+ multiline_concat_expr result $second
+ }
+
+ NOT {
+ set e [convert_search_expr [lpop expr]]
+ multiline_append_command result "NOT"
+ multiline_concat_expr result $e
+ }
+
+ SMALLER -
+ LARGER {
+ set len [lpop expr]
+ if {![string is integer $len]} {
+ error "Invalid integer follows '$token' in IMAP search"
+ }
+ multiline_append_command result "$token $len"
+ }
+
+ ON - SENTBEFORE - SENTON - SENTSINCE - SINCE -
+ BEFORE {error "TODO"}
+
+ UID {error "TODO"}
+ default {
+ error "Syntax error in search expression: '... $token $expr'"
+ }
+ }
+ }
+ return $result
+ }
+
+ # Pop an element from the list inside the named variable and return it.
+ # If a list is empty, raise an error. The error is specific for the
+ # search command since it's the only one calling this function.
+ proc lpop {listvar} {
+ upvar 1 $listvar l
+
+ if {![llength $l]} {
+ error "Bad syntax for search expression (missing argument)"
+ }
+
+ set res [lindex $l 0]
+ set l [lrange $l 1 end]
+ return $res
+ }
+
+ # Debug mode.
+ # This is a developers mode only that pass the control to the
+ # programmer. Every line entered is sent verbatim to the
+ # server (after the addition of the request identifier).
+ # The ::imap4::debug variable is automatically set to '1' on enter.
+ #
+ # It's possible to execute Tcl commands starting the line
+ # with a slash.
+
+ proc debugmode {chan {errormsg {None}}} {
+ variable debugmode 1
+ variable debugchan $chan
+ variable version
+ variable folderinfo
+ variable mboxinfo
+ variable msginfo
+ variable info
+
+ set welcometext [list \
+ "------------------------ IMAP DEBUG MODE --------------------" \
+ "IMAP Debug mode usage: Every line typed will be sent" \
+ "verbatim to the IMAP server prefixed with a unique IMAP tag." \
+ "To execute Tcl commands prefix the line with a / character." \
+ "The current debugged channel is returned by the \[me\] command." \
+ "Type ! to exit" \
+ "Type 'info' to see information about the connection" \
+ "Type 'help' to display this information" \
+ "" \
+ "Last error: '$errormsg'" \
+ "IMAP library version: '$version'" \
+ "" \
+ ]
+ foreach l $welcometext {
+ puts $l
+ }
+
+ debugmode_info $chan
+ while 1 {
+ puts -nonewline "imap debug> "
+ flush stdout
+ gets stdin line
+ if {![string length $line]} continue
+ if {$line eq {!}} exit
+ if {$line eq {info}} {
+ debugmode_info $chan
+ continue
+ }
+ if {$line eq {help}} {
+ foreach l $welcometext {
+ if {$l eq ""} break
+ puts $l
+ }
+ continue
+ }
+ if {[string index $line 0] eq {/}} {
+ catch {eval [string range $line 1 end]} result
+ puts $result
+ continue
+ }
+ # Let's send the request to imap server
+ request $chan $line
+ if {[catch {getresponse $chan} error]} {
+ puts "--- ERROR ---\n$error\n-------------\n"
+ }
+ }
+ }
+
+ # Little helper for debugmode command.
+ proc debugmode_info {chan} {
+ variable info
+ puts "Last sent request: '$info($chan,lastrequest)'"
+ puts "Last received line: '$info($chan,lastline)'"
+ puts ""
+ }
+
+ # Protocol error! Enter the debug mode if ::imap4::debug is true.
+ # Otherwise just raise the error.
+ proc protoerror {chan msg} {
+ variable debug
+ variable debugmode
+
+ if {$debug && !$debugmode} {
+ debugmode $chan $msg
+ } else {
+ error $msg
+ }
+ }
+
+ proc me {} {
+ variable debugchan
+ set debugchan
+ }
+
+ # Other stuff to do in random order...
+ #
+ # proc ::imap4::idle notify-command
+ # proc ::imap4::auth plain ...
+ # proc ::imap4::securestauth user pass
+ # proc ::imap4::store
+ # proc ::imap4::logout (need to clean both msg and mailbox info arrays)
+
+ # Amend the flags of a message to be updated once CLOSE/EXPUNGE is initiated
+ proc store {chan range key values} {
+ set valid_keys {
+ FLAGS
+ FLAGS.SILENT
+ +FLAGS
+ +FLAGS.SILENT
+ -FLAGS
+ -FLAGS.SILENT
+ }
+ if {$key ni $valid_keys} {
+ error "Invalid data item: $key. Must be one of [join $valid_keys ,]"
+ }
+ parserange $chan $range start end
+ set newflags {}
+ foreach val $values {
+ if {[regexp {^\\+(.*?)$} $val]} {
+ lappend newflags $values
+ } else {
+ lappend newflags "\\$val"
+ }
+ }
+ request $chan "STORE $start:$end $key ([join $newflags])"
+ if {[getresponse $chan]} {
+ return 1
+ }
+ return 0
+ }
+
+ # Logout
+ proc logout {chan} {
+ if {[simplecmd $chan LOGOUT SELECT {}]} {
+ # clean out info arrays
+ variable info
+ variable folderinfo
+ variable mboxinfo
+ variable msginfo
+
+ array unset folderinfo $chan,*
+ array unset mboxinfo $chan,*
+ array unset msginfo $chan,*
+ array unset info $chan,*
+
+ return 1
+ }
+ return 0
+ }
+
+ # Expunge : force removal of any messages with the
+ # flag \Deleted
+ proc expunge {chan} {
+ if {[simplecmd $chan EXPUNGE SELECT {}]} {
+ return 1
+ }
+ return 0
+ }
+
+ # copy : copy a message to a destination mailbox
+ proc copy {chan msgid mailbox} {
+ if {[simplecmd $chan COPY SELECT [list $msgid $mailbox]]} {
+ return 1
+ }
+ return 0
+ }
+
+}
+
+################################################################################
+# Example and test
+################################################################################
+if {[info script] eq $argv0} {
+ # set imap4::debug 0
+ set FOLDER INBOX
+ set port 0
+ if {[llength $argv] < 3} {
+ puts "Usage: imap4.tcl <server> <user> <pass> ?folder? ?-secure? ?-debug?"
+ exit
+ }
+
+ lassign $argv server user pass
+ if {$argc > 3} {
+ for {set i 3} {$i<$argc} {incr i} {
+ set opt [lindex $argv $i]
+ switch -- $opt {
+ "-debug" {
+ set imap4::debug 1
+ }
+ "-secure" {
+ set imap4::use_ssl 1
+ puts "Package TLS [package require tls] loaded"
+ }
+ default {
+ set FOLDER $opt
+ }
+ }
+ }
+ }
+
+ # open and login ...
+ set imap [imap4::open $server]
+ imap4::login $imap $user $pass
+
+ imap4::select $imap $FOLDER
+ # Output all the information about that mailbox
+ foreach info [imap4::mboxinfo $imap] {
+ puts "$info -> [imap4::mboxinfo $imap $info]"
+ }
+ set num_mails [imap4::mboxinfo $imap exists]
+ if {!$num_mails} {
+ puts "No mail in folder '$FOLDER'"
+ } else {
+ set fields {from: to: subject: size}
+ # fetch 3 records (at most)) inline
+ set max [expr {$num_mails<=3?$num_mails:3}]
+ foreach rec [imap4::fetch $imap :$max -inline {*}$fields] {
+ puts -nonewline "#[incr idx])"
+ for {set j 0} {$j<[llength $fields]} {incr j} {
+ puts "\t[lindex $fields $j] [lindex $rec $j]"
+ }
+ }
+
+ # Show all the information available about the message ID 1
+ puts "Available info about message 1 => [imap4::msginfo $imap 1]"
+ }
+
+ # Use the capability stuff
+ puts "Capabilities: [imap4::isableto $imap]"
+ puts "Is able to imap4rev1? [imap4::isableto $imap imap4rev1]"
+ if {$imap4::debug} {
+ imap4::debugmode $imap
+ }
+
+ # Cleanup
+ imap4::cleanup $imap
+}
diff --git a/tcllib/modules/imap4/pkgIndex.tcl b/tcllib/modules/imap4/pkgIndex.tcl
new file mode 100644
index 0000000..3ad4d0c
--- /dev/null
+++ b/tcllib/modules/imap4/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+package ifneeded imap4 0.5.3 [list source [file join $dir imap4.tcl]]
diff --git a/tcllib/modules/inifile/ChangeLog b/tcllib/modules/inifile/ChangeLog
new file mode 100644
index 0000000..8da18ed
--- /dev/null
+++ b/tcllib/modules/inifile/ChangeLog
@@ -0,0 +1,182 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2012-01-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ini.tcl: [Bug 3469006]: Followup to [Bug 3419727]. Fixed
+ * ini.man: the unscoped 'close' command left in the code.
+ * pkgIndex.tcl: Bumped version to 0.2.5
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-12-02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ini.tcl: [Bug 3419727]: Fixed the creative writing issue
+ * ini.man: with what should be local variables of _loadfile
+ * pkgIndex.tcl: and _commit. Generally reworked to use the
+ 'variable' command to bring object state into scope.
+ Bumped version to 0.2.4
+
+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 ========================
+ *
+
+2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * inifile.pcx: New file. Syntax definitions for the public
+ commands of the inifile package.
+
+2008-05-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ini.tcl: Fixed definition of procedure 'commentchar'. Was
+ * ini.man: defined global instead of in the '::ini' namespace.
+ * pkgIndex.tcl: This fixes [SF Tcllib Bug 1917035]. Bumped version
+ to 0.2.3.
+
+2008-03-14 Andreas Kupries <andreask@activestate.com>
+
+ * ini.tcl: Simplified the initialization code. Bumped version to
+ * ini.man: 0.2.2.
+ * pkgIndex.tcl:
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-20 Andreas Kupries <andreask@activestate.com>
+
+ * ini.man: Bumped package version to 0.2.1, due to bugfix in last
+ * ini.tcl: entry.
+ * pkgIndex.tcl:
+
+2007-08-16 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * ini.man: clarifications to ini::open and ini::remove
+ * ini.tcl fixed bug in ini::value where default value only
+ worked if the section didnt exist
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ini.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-06-29 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * ini.tcl: added default value option for value command, and added
+ commentchar command. change in comment behavior
+ * ini.man: clarifications for open, commit, and comment commands; added
+ commentchar command
+
+2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * inifile.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * inifile.test: Hooked into the new common test support code.
+
+2005-17-11 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * ini.tcl: fixed bug causing empty ini files when opening
+ with w modes introduced on 2005-31-03
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-09-05 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * ini.tcl: Fix for bug #1280529 - collision with global
+ * inifile.test: variable names. Added tests for these.
+
+2005-31-03 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * ini.tcl: fixed bug where ini files were corrupted when
+ saving a shorter version. due to not closing
+ and truncating file before writing.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-03-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * inifile.test: Fixed [Tcllib SF Bug 899204] by (a) rewriting all
+ tests to be completely independent of each other and (b)
+ changing the mode when opening the test file to 'r'. It should
+ be noted that the write facilities of the module are not covered
+ by the testsuite. That is unfortunate.
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * inifile.test: It was easier to make this package useable for Tcl
+ * ini.tcl: 8.2 than excluding it from test for versions of Tcl
+ * ini.man: before 8.4. So that was done.
+
+2003-07-15 Andreas Kupries <andreask@pliers.activestate.com>
+
+ * ini.tcl: Got a rewritten system from Aaron.
+ * ini.man: Updated the documentation.
+
+ * infile.test: New testsuite for module.
+ * test.ini:
+
+2003-07-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ini.tcl: Added a comment header for RCS id, copyright notices,
+ etc. Slight reformatting of the code. Slight code changes to
+ make 'procheck' complain less (proper import of variables into
+ the scope).
+
+ Documented possible bug.
diff --git a/tcllib/modules/inifile/ini.man b/tcllib/modules/inifile/ini.man
new file mode 100644
index 0000000..ce36ea1
--- /dev/null
+++ b/tcllib/modules/inifile/ini.man
@@ -0,0 +1,100 @@
+[vset VERSION 0.3]
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin inifile n [vset VERSION]]
+[moddesc {Parsing of Windows INI files}]
+[titledesc {Parsing of Windows INI files}]
+[category {Text processing}]
+[require Tcl 8.2]
+[require inifile [opt [vset VERSION]]]
+[description]
+
+This package provides an interface for easy manipulation of Windows INI files.
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd ::ini::open] [arg file] [opt "[option -encoding] [arg encoding]"] [opt [arg access]]]
+
+Opens an INI file and returns a handle that is used by other commands.
+[arg access] is the same as the first form (non POSIX) of the [const open]
+command, with the exception that mode [const a] is not supported. The
+default mode is [const r+].
+
+[para] The default [arg encoding] is the system encoding.
+
+
+[call [cmd ::ini::close] [arg ini]]
+
+Close the specified handle. If any changes were made and not written by
+[const commit] they are lost.
+
+[call [cmd ::ini::commit] [arg ini]]
+
+Writes the file and all changes to disk. The sections are written in
+arbitrary order. The keys in a section are written in alphabetical
+order. If the ini was opened in read only mode an error will be thrown.
+
+[call [cmd ::ini::revert] [arg ini]]
+
+Rolls all changes made to the inifile object back to the last
+committed state.
+
+[call [cmd ::ini::filename] [arg ini]]
+
+Returns the name of the file the [arg ini] object is associated with.
+
+[call [cmd ::ini::sections] [arg ini]]
+
+Returns a list of all the names of the existing sections in the file handle
+specified.
+
+[call [cmd ::ini::keys] [arg ini] [arg section]]
+
+Returns a list of all they key names in the section and file specified.
+
+[call [cmd ::ini::get] [arg ini] [arg section]]
+
+Returns a list of key value pairs that exist in the section and file specified.
+
+[call [cmd ::ini::exists] [arg ini] [arg section] [opt [arg key]]]
+
+Returns a boolean value indicating the existance of the specified section as a
+whole or the specified key within that section.
+
+[call [cmd ::ini::value] [arg ini] [arg section] [arg key] [opt [arg default]]]
+
+Returns the value of the named key and section. If specified,
+the default value will be returned if the key does not exist. If the key does
+not exist and no default is specified an error will be thrown.
+
+[call [cmd ::ini::set] [arg ini] [arg section] [arg key] [arg value]]
+
+Sets the value of the key in the specified section. If the section does not
+exist then a new one is created.
+
+[call [cmd ::ini::delete] [arg ini] [arg section] [opt [arg key]]]
+
+Removes the key or the entire section and all its keys. A section is not
+automatically deleted when it has no remaining keys.
+
+[call [cmd ::ini::comment] [arg ini] [arg section] [opt [arg key]] [opt [arg text]]]
+
+Reads and modifies comments for sections and keys. To write a section comment use an
+empty string for the [arg key]. To remove all comments use an empty string for [arg text].
+[arg text] may consist of a list of lines or one single line. Any embedded newlines in
+[arg text] are properly handled. Comments may be written to nonexistant
+sections or keys and will not return an error. Reading a comment from a nonexistant
+section or key will return an empty string.
+
+[call [cmd ::ini::commentchar] [opt char]]
+
+Reads and sets the comment character. Lines that begin with this character are treated as
+comments. When comments are written out each line is preceded by this character. The default
+is [const \;].
+
+[list_end]
+
+[vset CATEGORY inifile]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/inifile/ini.tcl b/tcllib/modules/inifile/ini.tcl
new file mode 100644
index 0000000..938cb64
--- /dev/null
+++ b/tcllib/modules/inifile/ini.tcl
@@ -0,0 +1,403 @@
+# ini.tcl --
+#
+# Querying and modifying old-style windows configuration files (.ini)
+#
+# Copyright (c) 2003-2007 Aaron Faupell <afaupell@users.sourceforge.net>
+# Copyright (c) 2008-2012 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: ini.tcl,v 1.17 2012/01/05 21:04:55 andreas_kupries Exp $
+
+package provide inifile 0.3
+
+namespace eval ini {
+ variable nexthandle 0
+ variable commentchar \;
+}
+
+proc ::ini::open {ini args} {
+ variable nexthandle
+
+ while {[string match -* [::set opt [lindex $args 0]]]} {
+ switch -exact -- $opt {
+ -- {
+ ::set args [lrange $args 1 end]
+ break
+ }
+ -encoding {
+ ::set enc [lindex $args 1]
+ ::set args [lrange $args 2 end]
+ }
+ default {
+ return -code error \
+ -errorcode {INIFILE OPTION INVALID} \
+ "Invalid option $opt, expected -encoding"
+ }
+ }
+ }
+
+ ::set remainder [llength $args]
+ if {$remainder > 1} {
+ return -code error \
+ -errorcode {WRONG-ARGS INIFILE} \
+ "wrong\#args: should be \"ini::open ?-encoding E? ?mode?\""
+ } elseif {$remainder == 1} {
+ ::set mode [lindex $args 0]
+ } else {
+ ::set mode r+
+ }
+
+ if { ![regexp {^(w|r)\+?$} $mode] } {
+ return -code error \
+ -errorcode {INIFILE MODE INVALID} \
+ "$mode is not a valid access mode"
+ }
+
+ ::set fh ini$nexthandle
+ ::set tmp [::open $ini $mode]
+ fconfigure $tmp -translation crlf
+ if {[info exists enc]} {
+ if {[catch {
+ fconfigure $tmp -encoding $enc
+ } msg]} {
+ ::close $tmp
+ return -code error $msg
+ }
+ }
+
+ namespace eval ::ini::$fh {
+ variable data; array set data {}
+ variable comments; array set comments {}
+ variable sections; array set sections {}
+ }
+ ::set ::ini::${fh}::channel $tmp
+ ::set ::ini::${fh}::file [_normalize $ini]
+ ::set ::ini::${fh}::mode $mode
+
+ incr nexthandle
+ if { [string match "r*" $mode] } {
+ _loadfile $fh
+ }
+ return $fh
+}
+
+# close the file and delete all stored info about it
+# this does not save any changes. see ::ini::commit
+
+proc ::ini::close {fh} {
+ _valid_ns $fh
+ variable ::ini::${fh}::channel
+ ::close $channel
+ namespace delete ::ini::$fh
+ return
+}
+
+# write all changes to disk
+
+proc ::ini::commit {fh} {
+ _valid_ns $fh
+
+ variable ::ini::${fh}::data
+ variable ::ini::${fh}::comments
+ variable ::ini::${fh}::sections
+ variable ::ini::${fh}::channel
+ variable ::ini::${fh}::file
+ variable ::ini::${fh}::mode
+ variable commentchar
+
+ if { $mode == "r" } {
+ return -code error \
+ -errorcode {INIFILE READ-ONLY} \
+ "cannot write to read-only file"
+ }
+ ::close $channel
+ ::set channel [::open $file w]
+ ::set char $commentchar
+ #seek $channel 0 start
+ foreach sec [array names sections] {
+ if { [info exists comments($sec)] } {
+ puts $channel "$char [join $comments($sec) "\n$char "]\n"
+ }
+ puts $channel "\[$sec\]"
+ foreach key [lsort -dictionary [array names data [_globescape $sec]\000*]] {
+ ::set key [lindex [split $key \000] 1]
+ if {[info exists comments($sec\000$key)]} {
+ puts $channel "$char [join $comments($sec\000$key) "\n$char "]"
+ }
+ puts $channel "$key=$data($sec\000$key)"
+ }
+ puts $channel ""
+ }
+ ::close $channel
+ ::set channel [::open $file r+]
+ return
+}
+
+# internal command to read in a file
+# see open and revert for public commands
+
+proc ::ini::_loadfile {fh} {
+ variable ::ini::${fh}::data
+ variable ::ini::${fh}::comments
+ variable ::ini::${fh}::sections
+ variable ::ini::${fh}::channel
+ variable ::ini::${fh}::file
+ variable ::ini::${fh}::mode
+ variable commentchar
+
+ ::set cur {}
+ ::set com {}
+
+ ::set char $commentchar
+ seek $channel 0 start
+
+ foreach line [split [read $channel] "\n"] {
+ # bug 3612465 - allow and ignore leading and trailing whitespace.
+ ::set line [string trim $line]
+
+ if { [string match "$char*" $line] } {
+ lappend com [string trim [string range $line [string length $char] end]]
+ } elseif { [string match {\[*\]} $line] } {
+ ::set cur [string range $line 1 end-1]
+ if { $cur == "" } { continue }
+ ::set sections($cur) 1
+ if { $com != "" } {
+ ::set comments($cur) $com
+ ::set com {}
+ }
+ } elseif { [string match {*=*} $line] } {
+ ::set line [split $line =]
+ ::set key [string trim [lindex $line 0]]
+ if { $key == "" || $cur == "" } { continue }
+ ::set value [string trim [join [lrange $line 1 end] =]]
+ if { [regexp "^(\".*\")\s+${char}(.*)$" $value -> 1 2] } {
+ ::set value $1
+ lappend com $2
+ }
+ ::set data($cur\000$key) $value
+ if { $com != "" } {
+ ::set comments($cur\000$key) $com
+ ::set com {}
+ }
+ }
+ }
+ return
+}
+
+# internal command to escape glob special characters
+
+proc ::ini::_globescape {string} {
+ return [string map {* \\* ? \\? \\ \\\\ \[ \\\[ \] \\\]} $string]
+}
+
+# internal command to check if a section or key is nonexistant
+
+proc ::ini::_exists {fh sec args} {
+ variable ::ini::${fh}::sections
+ variable ::ini::${fh}::data
+
+ if { ![info exists sections($sec)] } {
+ return -code error \
+ -errorcode {INIFILE SECTION INVALID} \
+ "no such section \"$sec\""
+ }
+ if { [llength $args] > 0 } {
+ ::set key [lindex $args 0]
+ if { ![info exists data($sec\000$key)] } {
+ return -code error \
+ -errorcode {INIFILE KEY INVALID} \
+ "can't read key \"$key\""
+ }
+ }
+ return
+}
+
+# internal command to check validity of a handle
+
+if { [package vcompare [package provide Tcl] 8.4] < 0 } {
+ proc ::ini::_normalize {path} {
+ return $path
+ }
+ proc ::ini::_valid_ns {name} {
+ variable ::ini::${name}::data
+ if { ![info exists data] } {
+ return -code error \
+ -errorcode {INIFILE HANDLE INVALID} \
+ "$name is not an open INI file"
+ }
+ }
+} else {
+ proc ::ini::_normalize {path} {
+ file normalize $path
+ }
+ proc ::ini::_valid_ns {name} {
+ if { ![namespace exists ::ini::$name] } {
+ return -code error \
+ -errorcode {INIFILE HANDLE INVALID} \
+ "$name is not an open INI file"
+ }
+ }
+}
+
+# get and set the ini comment character
+
+proc ::ini::commentchar { {new {}} } {
+ variable commentchar
+ if {$new != ""} {
+ if {[string length $new] > 1} {
+ return -code error \
+ -errorcode {INIFILE COMMENT-CHAR INVALID} \
+ "comment char must be a single character"
+ }
+ ::set commentchar $new
+ }
+ return $commentchar
+}
+
+# return all section names
+
+proc ::ini::sections {fh} {
+ _valid_ns $fh
+ variable ::ini::${fh}::sections
+ return [array names sections]
+}
+
+# return boolean indicating existance of section or key in section
+
+proc ::ini::exists {fh sec {key {}}} {
+ _valid_ns $fh
+ variable ::ini::${fh}::sections
+ variable ::ini::${fh}::data
+
+ if { $key == "" } {
+ return [info exists sections($sec)]
+ }
+ return [info exists data($sec\000$key)]
+}
+
+# return all key names of section
+# error if section is nonexistant
+
+proc ::ini::keys {fh sec} {
+ _valid_ns $fh
+ _exists $fh $sec
+ variable ::ini::${fh}::data
+
+ ::set keys {}
+ foreach x [array names data [_globescape $sec]\000*] {
+ lappend keys [lindex [split $x \000] 1]
+ }
+ return $keys
+}
+
+# return all key value pairs of section
+# error if section is nonexistant
+
+proc ::ini::get {fh sec} {
+ _valid_ns $fh
+ _exists $fh $sec
+ variable ::ini::${fh}::data
+
+ ::set r {}
+ foreach x [array names data [_globescape $sec]\000*] {
+ lappend r [lindex [split $x \000] 1] $data($x)
+ }
+ return $r
+}
+
+# return the value of a key
+# return default value if key or section is nonexistant otherwise error
+
+proc ::ini::value {fh sec key {default {}}} {
+ _valid_ns $fh
+ variable ::ini::${fh}::data
+
+ if {$default != "" && ![info exists data($sec\000$key)]} {
+ return $default
+ }
+ _exists $fh $sec $key
+ return [::set data($sec\000$key)]
+}
+
+# set the value of a key
+# new section or key names are created
+
+proc ::ini::set {fh sec key value} {
+ _valid_ns $fh
+ variable ::ini::${fh}::sections
+ variable ::ini::${fh}::data
+
+ ::set sec [string trim $sec]
+ ::set key [string trim $key]
+ if { $sec == "" || $key == "" } {
+ return -code error \
+ -errorcode {INIFILE SYNTAX} \
+ "section or key may not be empty"
+ }
+ ::set data($sec\000$key) $value
+ ::set sections($sec) 1
+ return $value
+}
+
+# delete a key or an entire section
+# may delete nonexistant keys and sections
+
+proc ::ini::delete {fh sec {key {}}} {
+ _valid_ns $fh
+ variable ::ini::${fh}::sections
+ variable ::ini::${fh}::data
+
+ if { $key == "" } {
+ array unset data [_globescape $sec]\000*
+ array unset sections [_globescape $sec]
+ }
+ catch {unset data($sec\000$key)}
+}
+
+# read and set comments for sections and keys
+# may comment nonexistant sections and keys
+
+proc ::ini::comment {fh sec key args} {
+ _valid_ns $fh
+ variable ::ini::${fh}::comments
+
+ ::set r $sec
+ if { $key != "" } { append r \000$key }
+ if { [llength $args] == 0 } {
+ if { ![info exists comments($r)] } { return {} }
+ return $comments($r)
+ }
+ if { [llength $args] == 1 && [lindex $args 0] == "" } {
+ unset -nocomplain comments($r)
+ return {}
+ }
+ # take care of any embedded newlines
+ for {::set i 0} {$i < [llength $args]} {incr i} {
+ ::set args [eval [list lreplace $args $i $i] [split [lindex $args $i] \n]]
+ }
+ eval [list lappend comments($r)] $args
+}
+
+# return the physical filename for the handle
+
+proc ::ini::filename {fh} {
+ _valid_ns $fh
+ variable ::ini::${fh}::file
+ return $file
+}
+
+# reload the file from disk losing all changes since the last commit
+
+proc ::ini::revert {fh} {
+ _valid_ns $fh
+ namespace eval ::ini::$fh {
+ array set data {}
+ array set comments {}
+ array set sections {}
+ }
+ if { ![string match "w*" $mode] } {
+ _loadfile $fh
+ }
+}
diff --git a/tcllib/modules/inifile/inifile.pcx b/tcllib/modules/inifile/inifile.pcx
new file mode 100644
index 0000000..f74749e
--- /dev/null
+++ b/tcllib/modules/inifile/inifile.pcx
@@ -0,0 +1,89 @@
+# -*- tcl -*- inifile.pcx
+# Syntax of the commands provided by package inifile.
+
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register inifile
+pcx::tcldep 0.2.1 needs tcl 8.2
+
+namespace eval ::inifile {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 0.2.1 std ::ini::close \
+ {checkSimpleArgs 1 1 {
+ checkChannelID
+ }}
+pcx::check 0.2.1 std ::ini::comment \
+ {checkSimpleArgs 4 4 {
+ checkChannelID
+ checkWord
+ checkWord
+ checkWord
+ }}
+pcx::check 0.2.1 std ::ini::commit \
+ {checkSimpleArgs 1 1 {
+ checkChannelID
+ }}
+pcx::check 0.2.1 std ::ini::delete \
+ {checkSimpleArgs 2 3 {
+ checkChannelID
+ checkWord
+ checkWord
+ }}
+pcx::check 0.2.1 std ::ini::exists \
+ {checkSimpleArgs 1 1 {
+ checkChannelID
+ }}
+pcx::check 0.2.1 std ::ini::filename \
+ {checkSimpleArgs 1 1 {
+ checkChannelID
+ }}
+pcx::check 0.2.1 std ::ini::get \
+ {checkSimpleArgs 1 2 {
+ checkWord
+ checkWord
+ }}
+pcx::check 0.2.1 std ::ini::keys \
+ {checkSimpleArgs 2 2 {
+ checkChannelID
+ checkWord
+ }}
+# TODO: file open access mode
+pcx::check 0.2.1 std ::ini::open \
+ {checkSimpleArgs 1 2 {
+ checkWord
+ checkWord
+ }}
+pcx::check 0.2.1 std ::ini::revert \
+ {checkSimpleArgs 1 1 {
+ checkChannelID
+ }}
+pcx::check 0.2.1 std ::ini::sections \
+ {checkSimpleArgs 1 1 {
+ checkChannelID
+ }}
+pcx::check 0.2.1 std ::ini::set \
+ {checkSimpleArgs 4 4 {
+ checkChannelID
+ checkWord
+ checkWord
+ checkWord
+ }}
+pcx::check 0.2.1 std ::ini::value \
+ {checkSimpleArgs 3 4 {
+ checkChannelID
+ checkWord
+ checkWord
+ checkWord
+ }}
+
+# Initialization via pcx::init.
+# Use a ::inifile::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/inifile/inifile.test b/tcllib/modules/inifile/inifile.test
new file mode 100644
index 0000000..3aa9627
--- /dev/null
+++ b/tcllib/modules/inifile/inifile.test
@@ -0,0 +1,218 @@
+# -*- tcl -*-
+# Tests for module 'inifile'
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal ini.tcl inifile
+}
+
+#---------------------------------------------------------------------
+
+set inifile [localPath ini.tcl]
+set testini [localPath test.ini]
+set sampini [localPath sample.ini]
+
+#---------------------------------------------------------------------
+
+test inifile-1.1 {ini::open} {
+ set res [ini::open $testini r]
+ ini::close $res
+ set res
+} {ini0}
+
+test inifile-1.2 {ini::sections} {
+ set hdl [ini::open $testini r]
+ set res [ini::sections $hdl]
+ ini::close $hdl
+ set res
+} {emptysection section1 \{test section2}
+
+test inifile-1.3 {ini::keys} {
+ set hdl [ini::open $testini r]
+ set res [ini::keys $hdl section1]
+ ini::close $hdl
+ set res
+} {testkey key}
+
+test inifile-1.4 {ini::keys} {
+ set hdl [ini::open $testini r]
+ set res [ini::keys $hdl \{test]
+ ini::close $hdl
+ set res
+} {\}key}
+
+test inifile-1.5 {ini::get} {
+ set hdl [ini::open $testini r]
+ set res [ini::get $hdl section1]
+ ini::close $hdl
+ set res
+} {testkey hi key value}
+
+test inifile-1.6 {ini::get} {
+ set hdl [ini::open $testini r]
+ set res [ini::get $hdl \{test]
+ ini::close $hdl
+ set res
+} {\}key {$blah}}
+
+test inifile-1.7 {ini::value} {
+ set hdl [ini::open $testini r]
+ set res [ini::value $hdl section1 key]
+ ini::close $hdl
+ set res
+} {value}
+
+test inifile-1.8 {ini::value} {
+ set hdl [ini::open $testini r]
+ set res [ini::value $hdl \{test \}key]
+ ini::close $hdl
+ set res
+} {$blah}
+
+test inifile-1.9 {ini::exists} {
+ set hdl [ini::open $testini r]
+ set res [ini::exists $hdl section1]
+ ini::close $hdl
+ set res
+} {1}
+
+test inifile-1.10 {ini::exists} {
+ set hdl [ini::open $testini r]
+ set res [ini::exists $hdl section]
+ ini::close $hdl
+ set res
+} {0}
+
+test inifile-1.11 {ini::exists} {
+ set hdl [ini::open $testini r]
+ set res [ini::exists $hdl section1 testkey]
+ ini::close $hdl
+ set res
+} {1}
+
+test inifile-1.12 {ini:::exists} {
+ set hdl [ini::open $testini r]
+ set res [ini::exists $hdl section1 blah]
+ ini::close $hdl
+ set res
+} {0}
+
+test inifile-1.13 {ini:::exists} {
+ set hdl [ini::open $testini r]
+ set res [ini::exists $hdl \{test]
+ ini::close $hdl
+ set res
+} {1}
+
+test inifile-1.14 {ini:::exists} {
+ set hdl [ini::open $testini r]
+ set res [ini::exists $hdl \{test \}key]
+ ini::close $hdl
+ set res
+} {1}
+
+#---------------------------------------------------------------------
+# Tests for bug #1281136 --
+set N 0
+foreach name {nexthandle commentchar} {
+ test inifile-2.$N {bug 1281136 - collision with global variable names} {
+ set script {list [catch {
+ array set ::%var {}
+ source %file
+ } err] $err}
+ regsub {%file} $script $inifile script
+ regsub {%var} $script $name script
+ interp create slave0
+ set r [slave0 eval $script]
+ interp delete slave0
+ set r
+ } {0 {}}
+ incr N
+}
+foreach name {data comments sections} {
+ test inifile-2.$N {bug 1281136 - collision with global variable names} {
+ set script {list [catch {
+ ::set ::%var 0
+ source %file
+ set res [ini::open %testini r]
+ ini::close $res
+ } err] $err}
+ foreach {s v} [list %file $inifile %var $name %testini $testini] {
+ regsub $s $script $v script
+ }
+ interp create slave0
+ set r [slave0 eval $script]
+ interp delete slave0
+ set r
+ } {0 {}}
+ incr N
+}
+
+#---------------------------------------------------------------------
+
+test inifile-3.0 {bug 3612465, leading & trailing spaces} {
+ set fh [ini::open $sampini]
+ set res [ini::sections $fh]
+ ini::close $fh
+ unset fh
+ set res
+} General
+
+test inifile-3.1 {bug 3612465, leading & trailing spaces} {
+ set fh [ini::open $sampini]
+ #set res [llength [ini::sections $fh]]
+ set res [lsort -dict [ini::keys $fh General]]
+ ini::close $fh
+ unset fh
+ set res
+} {key key2}
+
+#---------------------------------------------------------------------
+
+test inifile-4.0 {bug c4b8162da5 - ini::open} {
+ set res [ini::open $testini -encoding unicode r]
+ ini::close $res
+ set res
+} {ini16}
+
+# Test various error conditions.
+test inifile-4.1 {bug c4b8162da5 - ini::open - invalid encoding} {
+ catch {
+ ini::open $testini -encoding foo r
+ } res
+ set res
+} {unknown encoding "foo"}
+
+test inifile-4.2 {bug c4b8162da5 - ini::open - invalid option} {
+ catch {
+ ini::open $testini -bogus foo r
+ } res
+ set res
+} {Invalid option -bogus, expected -encoding}
+
+test inifile-4.3 {bug c4b8162da5 - ini::open - invalid mode} {
+ catch {
+ ini::open $testini x
+ } res
+ set res
+} {x is not a valid access mode}
+
+test inifile-4.4 {bug c4b8162da5 - ini::open - invalid mode} {
+ catch {
+ set res [ini::open $testini w-]
+ } res
+ set res
+} {w- is not a valid access mode}
+
+#---------------------------------------------------------------------
+# Clean up
+testsuiteCleanup
+return
diff --git a/tcllib/modules/inifile/pkgIndex.tcl b/tcllib/modules/inifile/pkgIndex.tcl
new file mode 100644
index 0000000..9aa3f98
--- /dev/null
+++ b/tcllib/modules/inifile/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if { ![package vsatisfies [package provide Tcl] 8.2] } { return }
+package ifneeded inifile 0.3 [list source [file join $dir ini.tcl]]
diff --git a/tcllib/modules/inifile/sample.ini b/tcllib/modules/inifile/sample.ini
new file mode 100644
index 0000000..884ccae
--- /dev/null
+++ b/tcllib/modules/inifile/sample.ini
@@ -0,0 +1,5 @@
+[General]
+ key=value
+key2=value2
+
+ ; ....
diff --git a/tcllib/modules/inifile/test.ini b/tcllib/modules/inifile/test.ini
new file mode 100644
index 0000000..ac8eb56
--- /dev/null
+++ b/tcllib/modules/inifile/test.ini
@@ -0,0 +1,15 @@
+[emptysection]
+
+; a comment for section 1
+
+[section1]
+key=value
+testkey=hi
+
+[section2]
+; key comment
+key=othervalue
+
+
+[{test]
+}key = $blah
diff --git a/tcllib/modules/interp/ChangeLog b/tcllib/modules/interp/ChangeLog
new file mode 100644
index 0000000..0fb2cb9
--- /dev/null
+++ b/tcllib/modules/interp/ChangeLog
@@ -0,0 +1,108 @@
+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-11-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * interp.tcl (::interp::createEmpty): Fixed problem with 8.6,
+ * interp.man: where the removal of the ::tcl namespace also kills
+ * pkgIndex.tcl: the 'namespace' command, as it is ensemblified.
+ Version bumped to 0.1.2.
+
+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-08-20 Andreas Kupries <andreask@activestate.com>
+
+ * tcllib_interp.tcl: Bumped package version to 0.1.1.
+ * interp.man:
+ * pkgIndex.tcl:
+
+2007-08-02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * interp.tcl (::interp::createEmpty): Modified the sequence
+ clearing an interpreter of commands to properly handle the ::tcl
+ system namespace of Tcl 8.5.
+
+2007-08-01 Andreas Kupries <andreask@activestate.com>
+
+ * deleg_method.test: Updated tests for changes in snit internal,
+ now using the new method introspection methods. Requires snit
+ 1.3.1
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tcllib_interp.man: Fixed all warnings due to use of now
+ * deleg_method.man: deprecated commands. Added a section about how
+ * deleg_proc.man: to give feedback.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-01 Andreas Kupries <andreask@activestate.com>
+
+ * deleg_proc.man: Added manpages for the packages creating
+ * deleg_merthod.man: delegation procedures and methods.
+
+ * deleg_proc.tcl: Fixed bug, forgot that not only a comm
+ * deleg_method.tcl: channel is needed, but also the id of
+ * deleg_proc.test: the remote location. Added argument,
+ * deleg_method.test: shuffled arguments, updated testsuites.
+ * pkgIndex.tcl: ** INCOMPATIBILITY ** Version bumped to 0.2
+
+2006-08-30 Andreas Kupries <andreask@activestate.com>
+
+ * interp.man: Renamed the manpage, avoid clash with
+ * tcllib_interp.man: core documentation.
+
+2006-08-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * deleg_proc.tcl: Creation of delegation procedures.
+ * deleg_proc.test:
+
+ * deleg_method.tcl: Creation of delegation methods.
+ * deleg_method.test:
+
+2006-08-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * interp.tcl: New module. Interpreter creation and alias
+ * interp.man: utility commands. Basic testsuite.
+ * interp.test:
diff --git a/tcllib/modules/interp/deleg_method.man b/tcllib/modules/interp/deleg_method.man
new file mode 100644
index 0000000..89c0824
--- /dev/null
+++ b/tcllib/modules/interp/deleg_method.man
@@ -0,0 +1,49 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin deleg_method n 0.2]
+[keywords comm]
+[keywords delegation]
+[keywords interpreter]
+[keywords method]
+[keywords snit]
+[copyright {2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Interpreter utilities}]
+[titledesc {Creation of comm delegates (snit methods)}]
+[category {Programming tools}]
+[require Tcl 8.3]
+[require snit [opt 1.1]]
+[require interp::delegate::method [opt 0.2]]
+[description]
+[para]
+
+This package provides a single command for use within [package snit]
+type definition (i.e. actually a [cmd snit::macro]) for the convenient
+creation of methods which delegate the actual work to a remote
+location via a "channel" created by the package [package comm].
+
+[section API]
+[list_begin definitions]
+
+[call [cmd ::interp::delegate::method] [opt [option -async]] [arg name] [arg arguments] [arg comm] [arg id]]
+
+This commands creates a method which is named by [arg name]. All
+invokations of this method will delegate the actual work to the remote
+location identified by the comm channel [arg comm] and the endpoint
+[arg id].
+
+[para]
+
+The name of the remote method invoked by the delegator is identical to
+the name of the method itself.
+
+[para]
+
+Normally the generated method marshalls the [arg arguments], and
+returns the result from the remote method as its own result. If
+however the option [option -async] was specified then the generated
+method will not wait for a result and return immediately.
+
+[list_end]
+
+[vset CATEGORY interp]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/interp/deleg_method.tcl b/tcllib/modules/interp/deleg_method.tcl
new file mode 100644
index 0000000..c25f9a6
--- /dev/null
+++ b/tcllib/modules/interp/deleg_method.tcl
@@ -0,0 +1,64 @@
+# interp.tcl
+# Some utility commands for creation of delegation methods.
+# (Delegation of methods to a remote interpreter via a comm
+# handle).
+#
+# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: deleg_method.tcl,v 1.2 2006/09/01 19:58:21 andreas_kupries Exp $
+
+package require Tcl 8.3
+package require snit
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+namespace eval ::interp::delegate {}
+
+# ### ### ### ######### ######### #########
+## Public API
+
+snit::macro ::interp::delegate::method {args} {
+ # syntax: ?-async? name arguments comm id
+
+ set async 0
+ while {[string match -* [set opt [lindex $args 0]]]} {
+ switch -exact -- $opt {
+ -async {set async 1 ; set args [lrange $args 1 end]}
+ default {
+ return -code error "unknown option \"$opt\", expected -async"
+ }
+ }
+ }
+ if {[llength $args] != 4} {
+ return -code error "wrong # args"
+ }
+ foreach {name arguments comm rid} $args break
+
+ if {![llength $arguments]} {
+ set delegate "[list $name]"
+ } elseif {[string equal args [lindex $arguments end]]} {
+ if {[llength $arguments] == 1} {
+ set delegate "\[linsert \$args 0 [list $name]\]"
+ } else {
+ set delegate "\[linsert \$args 0 [list $name] \$[join [lrange $arguments 0 end-1] " \$"]\]"
+ }
+ } else {
+ set delegate "\[list [list $name] \$[join $arguments " \$"]\]"
+ }
+
+ set body ""
+ append body [list $comm] " " "send "
+ if {$async} {append body "-async "}
+ append body [list $rid] " " $delegate
+
+ ::method $name $arguments $body
+}
+
+# ### ### ### ######### ######### #########
+## Ready to go
+
+package provide interp::delegate::method 0.2
diff --git a/tcllib/modules/interp/deleg_method.test b/tcllib/modules/interp/deleg_method.test
new file mode 100644
index 0000000..5625b28
--- /dev/null
+++ b/tcllib/modules/interp/deleg_method.test
@@ -0,0 +1,192 @@
+# -*- tcl -*-
+# interp.test: tests for the interp alias and creation utilities
+#
+# Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.3
+testsNeedTcltest 1.0
+
+support {
+ use snit/snit.tcl snit
+ testsNeed snit 1.3.1 ; # method introspection arguments/body
+}
+testing {
+ useLocal deleg_method.tcl interp::delegate::method
+}
+
+# -------------------------------------------------------------------------
+
+test dmethod-1.0 {wrong#args} {
+ catch {snit::type foo {interp::delegate::method}} msg
+ set msg
+} {wrong # args}
+
+test dmethod-1.1 {wrong#args} {
+ catch {snit::type foo {interp::delegate::method a}} msg
+ set msg
+} {wrong # args}
+
+test dmethod-1.2 {wrong#args} {
+ catch {snit::type foo {interp::delegate::method a b}} msg
+ set msg
+} {wrong # args}
+
+test dmethod-1.3 {wrong#args} {
+ catch {snit::type foo {interp::delegate::method a b c}} msg
+ set msg
+} {wrong # args}
+
+test dmethod-1.4 {wrong#args} {
+ catch {snit::type foo {interp::delegate::method a b c d e}} msg
+ set msg
+} {wrong # args}
+
+# -------------------------------------------------------------------------
+
+test dmethod-2.0 {bad switch} {
+ catch {snit::type foo {interp::delegate::method -bogus}} msg
+ set msg
+} {unknown option "-bogus", expected -async}
+
+# -------------------------------------------------------------------------
+
+test dmethod-3.0 {delegation result} {
+ snit::type foo {
+ interp::delegate::method request {} COMM ID
+ }
+ res!
+ foo bar
+ res+ [info commands foo::Snit_methodrequest]
+ res+ [lsort [bar info methods]]
+ bar destroy
+ foo destroy
+ res?
+} {::foo::Snit_methodrequest {{destroy info request}}}
+
+# -------------------------------------------------------------------------
+
+test dmethod-4.0 {signature} {
+ snit::type foo {
+ interp::delegate::method request {} COMM ID
+ }
+ foo X
+ res!
+ res+ \
+ [X info args request] \
+ [string trimleft [X info body request]]
+ X destroy
+ foo destroy
+ res?
+} {{{} {COMM send ID request}}}
+
+test dmethod-4.1 {signature} {
+ snit::type foo {
+ interp::delegate::method request {a b} COMM ID
+ }
+ foo X
+ res!
+ res+ \
+ [X info args request] \
+ [string trimleft [X info body request]]
+ X destroy
+ foo destroy
+ res?
+} {{{a b} {COMM send ID [list request $a $b]}}}
+
+test dmethod-4.2 {signature} {
+ snit::type foo {
+ interp::delegate::method request {a b args} COMM ID
+ }
+ foo X
+ res!
+ res+ \
+ [X info args request] \
+ [string trimleft [X info body request]]
+ X destroy
+ foo destroy
+ res?
+} {{{a b args} {COMM send ID [linsert $args 0 request $a $b]}}}
+
+test dmethod-4.3 {signature} {
+ snit::type foo {
+ interp::delegate::method request {args} COMM ID
+ }
+ foo X
+ res!
+ res+ \
+ [X info args request] \
+ [string trimleft [X info body request]]
+ X destroy
+ foo destroy
+ res?
+} {{args {COMM send ID [linsert $args 0 request]}}}
+
+# -------------------------------------------------------------------------
+
+test dmethod-5.0 {signature} {
+ snit::type foo {
+ interp::delegate::method -async request {} COMM ID
+ }
+ foo X
+ res!
+ res+ \
+ [X info args request] \
+ [string trimleft [X info body request]]
+ X destroy
+ foo destroy
+ res?
+} {{{} {COMM send -async ID request}}}
+
+test dmethod-5.1 {signature} {
+ snit::type foo {
+ interp::delegate::method -async request {a b} COMM ID
+ }
+ foo X
+ res!
+ res+ \
+ [X info args request] \
+ [string trimleft [X info body request]]
+ X destroy
+ foo destroy
+ res?
+} {{{a b} {COMM send -async ID [list request $a $b]}}}
+
+test dmethod-5.2 {signature} {
+ snit::type foo {
+ interp::delegate::method -async request {a b args} COMM ID
+ }
+ foo X
+ res!
+ res+ \
+ [X info args request] \
+ [string trimleft [X info body request]]
+ X destroy
+ foo destroy
+ res?
+} {{{a b args} {COMM send -async ID [linsert $args 0 request $a $b]}}}
+
+test dmethod-5.3 {signature} {
+ snit::type foo {
+ interp::delegate::method -async request {args} COMM ID
+ }
+ foo X
+ res!
+ res+ \
+ [X info args request] \
+ [string trimleft [X info body request]]
+ X destroy
+ foo destroy
+ res?
+} {{args {COMM send -async ID [linsert $args 0 request]}}}
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/interp/deleg_proc.man b/tcllib/modules/interp/deleg_proc.man
new file mode 100644
index 0000000..6060bd2
--- /dev/null
+++ b/tcllib/modules/interp/deleg_proc.man
@@ -0,0 +1,47 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin deleg_proc n 0.2]
+[keywords comm]
+[keywords delegation]
+[keywords interpreter]
+[keywords procedure]
+[copyright {2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Interpreter utilities}]
+[titledesc {Creation of comm delegates (procedures)}]
+[category {Programming tools}]
+[require Tcl 8.3]
+[require interp::delegate::proc [opt 0.2]]
+[description]
+[para]
+
+This package provides a single command for the convenient creation of
+procedures which delegate the actual work to a remote location via a
+"channel" created by the package [package comm].
+
+[section API]
+[list_begin definitions]
+
+[call [cmd ::interp::delegate::proc] [opt [option -async]] [arg name] [arg arguments] [arg comm] [arg id]]
+
+This commands creates a procedure which is named by [arg name] and
+returns its fully-qualified name. All invokations of this procedure
+will delegate the actual work to the remote location identified by the
+comm channel [arg comm] and the endpoint [arg id].
+
+[para]
+
+The name of the remote procedure invoked by the delegator is
+[lb]namespace tail [arg name][rb]. I.e., namespace information is
+stripped from the call.
+
+[para]
+
+Normally the generated procedure marshalls the [arg arguments], and
+returns the result from the remote procedure as its own result. If
+however the option [option -async] was specified then the generated
+procedure will not wait for a result and return immediately.
+
+[list_end]
+
+[vset CATEGORY interp]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/interp/deleg_proc.tcl b/tcllib/modules/interp/deleg_proc.tcl
new file mode 100644
index 0000000..8aee165
--- /dev/null
+++ b/tcllib/modules/interp/deleg_proc.tcl
@@ -0,0 +1,68 @@
+# interp.tcl
+# Some utility commands for creation of delegation procedures
+# (Delegation of commands to a remote interpreter via a comm
+# handle).
+#
+# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: deleg_proc.tcl,v 1.2 2006/09/01 19:58:21 andreas_kupries Exp $
+
+package require Tcl 8.3
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+namespace eval ::interp::delegate {}
+
+# ### ### ### ######### ######### #########
+## Public API
+
+proc ::interp::delegate::proc {args} {
+ # syntax: ?-async? name arguments comm id
+
+ set async 0
+ while {[string match -* [set opt [lindex $args 0]]]} {
+ switch -exact -- $opt {
+ -async {
+ set async 1
+ set args [lrange $args 1 end]
+ }
+ default {
+ return -code error "unknown option \"$opt\", expected -async"
+ }
+ }
+ }
+ if {[llength $args] != 4} {
+ return -code error "wrong # args"
+ }
+ foreach {name arguments comm rid} $args break
+ set base [namespace tail $name]
+
+ if {![llength $arguments]} {
+ set delegate "[list $base]"
+ } elseif {[string equal args [lindex $arguments end]]} {
+ if {[llength $arguments] == 1} {
+ set delegate "\[linsert \$args 0 [list $base]\]"
+ } else {
+ set delegate "\[linsert \$args 0 [list $base] \$[join [lrange $arguments 0 end-1] " \$"]\]"
+ }
+ } else {
+ set delegate "\[list [list $base] \$[join $arguments " \$"]\]"
+ }
+
+ set body ""
+ append body [list $comm] " " "send "
+ if {$async} {append body "-async "}
+ append body [list $rid] " " $delegate
+
+ uplevel 1 [list ::proc $name $arguments $body]
+ return $name
+}
+
+# ### ### ### ######### ######### #########
+## Ready to go
+
+package provide interp::delegate::proc 0.2
diff --git a/tcllib/modules/interp/deleg_proc.test b/tcllib/modules/interp/deleg_proc.test
new file mode 100644
index 0000000..02ecf3e
--- /dev/null
+++ b/tcllib/modules/interp/deleg_proc.test
@@ -0,0 +1,153 @@
+# -*- tcl -*-
+# interp.test: tests for the interp alias and creation utilities
+#
+# Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.3
+testsNeedTcltest 1.0
+
+testing {
+ useLocal deleg_proc.tcl interp::delegate::proc
+}
+
+# -------------------------------------------------------------------------
+
+test dproc-1.0 {wrong#args} {
+ catch {interp::delegate::proc} msg
+ set msg
+} {wrong # args}
+
+test dproc-1.1 {wrong#args} {
+ catch {interp::delegate::proc a} msg
+ set msg
+} {wrong # args}
+
+test dproc-1.2 {wrong#args} {
+ catch {interp::delegate::proc a b} msg
+ set msg
+} {wrong # args}
+
+test dproc-1.3 {wrong#args} {
+ catch {interp::delegate::proc a b c} msg
+ set msg
+} {wrong # args}
+
+test dproc-1.4 {wrong#args} {
+ catch {interp::delegate::proc a b c d e} msg
+ set msg
+} {wrong # args}
+
+# -------------------------------------------------------------------------
+
+test dproc-2.0 {bad switch} {
+ catch {interp::delegate::proc -bogus} msg
+ set msg
+} {unknown option "-bogus", expected -async}
+
+# -------------------------------------------------------------------------
+
+test dproc-3.0 {delegation result} {
+ res!
+ res+ \
+ [info commands request] \
+ [interp::delegate::proc request {} FOO ID] \
+ [info commands request]
+ rename request {}
+ res?
+} {{{} request request}}
+
+# -------------------------------------------------------------------------
+
+test dproc-4.0 {signature} {
+ res!
+ res+ \
+ [interp::delegate::proc {re quest} {} COMM ID] \
+ [info args {re quest}] \
+ [info body {re quest}]
+ rename {re quest} {}
+ res?
+} {{{re quest} {} {COMM send ID {re quest}}}}
+
+test dproc-4.1 {signature} {
+ res!
+ res+ \
+ [interp::delegate::proc {re quest} {a b} COMM ID] \
+ [info args {re quest}] \
+ [info body {re quest}]
+ rename {re quest} {}
+ res?
+} {{{re quest} {a b} {COMM send ID [list {re quest} $a $b]}}}
+
+test dproc-4.2 {signature} {
+ res!
+ res+ \
+ [interp::delegate::proc {re quest} {a b args} COMM ID] \
+ [info args {re quest}] \
+ [info body {re quest}]
+ rename {re quest} {}
+ res?
+} {{{re quest} {a b args} {COMM send ID [linsert $args 0 {re quest} $a $b]}}}
+
+test dproc-4.3 {signature} {
+ res!
+ res+ \
+ [interp::delegate::proc {re quest} {args} COMM ID] \
+ [info args {re quest}] \
+ [info body {re quest}]
+ rename {re quest} {}
+ res?
+} {{{re quest} args {COMM send ID [linsert $args 0 {re quest}]}}}
+
+# -------------------------------------------------------------------------
+
+test dproc-5.0 {signature} {
+ res!
+ res+ \
+ [interp::delegate::proc -async {re quest} {} COMM ID] \
+ [info args {re quest}] \
+ [info body {re quest}]
+ rename {re quest} {}
+ res?
+} {{{re quest} {} {COMM send -async ID {re quest}}}}
+
+test dproc-5.1 {signature} {
+ res!
+ res+ \
+ [interp::delegate::proc -async {re quest} {a b} COMM ID] \
+ [info args {re quest}] \
+ [info body {re quest}]
+ rename {re quest} {}
+ res?
+} {{{re quest} {a b} {COMM send -async ID [list {re quest} $a $b]}}}
+
+test dproc-5.2 {signature} {
+ res!
+ res+ \
+ [interp::delegate::proc -async {re quest} {a b args} COMM ID] \
+ [info args {re quest}] \
+ [info body {re quest}]
+ rename {re quest} {}
+ res?
+} {{{re quest} {a b args} {COMM send -async ID [linsert $args 0 {re quest} $a $b]}}}
+
+test dproc-5.3 {signature} {
+ res!
+ res+ \
+ [interp::delegate::proc -async {re quest} {args} COMM ID] \
+ [info args {re quest}] \
+ [info body {re quest}]
+ rename {re quest} {}
+ res?
+} {{{re quest} args {COMM send -async ID [linsert $args 0 {re quest}]}}}
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/interp/interp.tcl b/tcllib/modules/interp/interp.tcl
new file mode 100644
index 0000000..7fefa5f
--- /dev/null
+++ b/tcllib/modules/interp/interp.tcl
@@ -0,0 +1,87 @@
+# interp.tcl
+# Some utility commands for interpreter creation
+#
+# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: interp.tcl,v 1.5 2011/11/08 02:40:31 andreas_kupries Exp $
+
+package require Tcl 8.3
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+namespace eval ::interp {}
+
+# ### ### ### ######### ######### #########
+## Public API
+
+proc ::interp::createEmpty {args} {
+ # Create interpreter, predefined path or
+ # automatic naming.
+
+ if {[llength $args] > 1} {
+ return -code error "wrong#args: Expected ?path?"
+ } elseif {[llength $args] == 1} {
+ set i [interp create [lindex $args 0]]
+ } else {
+ set i [interp create]
+ }
+
+ # Clear out namespaces and commands, leaving an empty interpreter
+ # behind. Take care to delete the rename command last, as it is
+ # needed to perform the deletions. We have to keep the 'rename'
+ # command until last to allow us to delete all ocmmands. We also
+ # have to defer deletion of the ::tcl namespace (if present), as
+ # it may contain state for the auto-loader, which may be
+ # invoked. This also forces us to defer the deletion of the
+ # builtin command 'namespace' so that we can delete ::tcl at last.
+
+ foreach n [interp eval $i [list ::namespace children ::]] {
+ if {[string equal $n ::tcl]} continue
+ interp eval $i [list namespace delete $n]
+ }
+ foreach c [interp eval $i [list ::info commands]] {
+ if {[string equal $c rename]} continue
+ if {[string equal $c namespace]} continue
+ interp eval $i [list ::rename $c {}]
+ }
+
+ interp eval $i [list ::namespace delete ::tcl]
+ catch {
+ # In 8.6 the removal of the ::tcl namespace killed the
+ # ensemblified namespace command already, so a deletion will
+ # fail. Easier to catch than being conditional.
+ interp eval $i [list ::rename namespace {}]
+ }
+ interp eval $i [list ::rename rename {}]
+
+ # Done. Result is ready.
+
+ return $i
+}
+
+proc ::interp::snitLink {path methods} {
+ foreach m $methods {
+ set dst [uplevel 1 [linsert $m 0 mymethod]]
+ set alias [linsert $dst 0 interp alias $path [lindex $m 0] {}]
+ eval $alias
+ }
+ return
+}
+
+proc ::interp::snitDictLink {path methoddict} {
+ foreach {c m} $methoddict {
+ set dst [uplevel 1 [linsert $m 0 mymethod]]
+ set alias [linsert $dst 0 interp alias $path $c {}]
+ eval $alias
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Ready to go
+
+package provide interp 0.1.2
diff --git a/tcllib/modules/interp/interp.test b/tcllib/modules/interp/interp.test
new file mode 100644
index 0000000..bcbc65a
--- /dev/null
+++ b/tcllib/modules/interp/interp.test
@@ -0,0 +1,127 @@
+# -*- tcl -*-
+# interp.test: tests for the interp alias and creation utilities
+#
+# Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.3
+testsNeedTcltest 1.0
+
+support {
+ use snit/snit.tcl snit
+}
+testing {
+ useLocal interp.tcl interp
+}
+
+# -------------------------------------------------------------------------
+
+test interp-1.0 {wrong#args} {
+ catch {interp::createEmpty a b} msg
+ set msg
+} {wrong#args: Expected ?path?}
+
+# -------------------------------------------------------------------------
+
+test interp-2.0 {auto naming, empty} {
+ set i [interp::createEmpty]
+ catch {$i eval {set x}} msg
+ interp delete $i
+ set msg
+} {invalid command name "set"}
+
+test interp-2.1 {explicit naming, empty} {
+ set i [interp::createEmpty A]
+ catch {$i eval {set x}} msg
+ interp delete $i
+ list $i $msg
+} {A {invalid command name "set"}}
+
+# -------------------------------------------------------------------------
+
+test interp-3.0 {wrong#args} {
+ catch {interp::snitLink} msg
+ set msg
+} [tcltest::wrongNumArgs interp::snitLink {path methods} 0]
+
+test interp-3.1 {wrong#args} {
+ catch {interp::snitLink a} msg
+ set msg
+} [tcltest::wrongNumArgs interp::snitLink {path methods} 1]
+
+test interp-3.2 {wrong#args} {
+ catch {interp::snitLink a b c} msg
+ set msg
+} [tcltest::tooManyArgs interp::snitLink {path methods}]
+
+test interp-3.3 {create, test redirection} {
+ res!
+ snit::type foo {
+ variable i
+ constructor {} {
+ set i [interp::createEmpty]
+ interp::snitLink $i Duck
+ }
+ method Duck {} {
+ res+ Ducking
+ }
+ method ho {} {$i eval Duck}
+ }
+ set i [foo %AUTO%]
+ $i ho
+ $i destroy
+ foo destroy
+ res?
+} Ducking
+
+# -------------------------------------------------------------------------
+
+test interp-4.0 {wrong#args} {
+ catch {interp::snitDictLink} msg
+ set msg
+} [tcltest::wrongNumArgs interp::snitDictLink {path methoddict} 0]
+
+test interp-4.1 {wrong#args} {
+ catch {interp::snitDictLink a} msg
+ set msg
+} [tcltest::wrongNumArgs interp::snitDictLink {path methoddict} 1]
+
+test interp-4.2 {wrong#args} {
+ catch {interp::snitDictLink a b c} msg
+ set msg
+} [tcltest::tooManyArgs interp::snitDictLink {path methoddict}]
+
+test interp-4.3 {create, test redirection} {
+ res!
+ snit::type foo {
+ variable i
+ constructor {} {
+ set i [interp::createEmpty]
+ interp::snitDictLink $i {
+ Wail {The wailer}
+ Quack {The duck}
+ }
+ }
+ method The {what} {
+ res+ $what
+ }
+ method ho {sound} {$i eval $sound}
+ }
+ set i [foo %AUTO%]
+ $i ho Quack
+ $i ho Wail
+ $i destroy
+ foo destroy
+ res?
+} {duck wailer}
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/interp/pkgIndex.tcl b/tcllib/modules/interp/pkgIndex.tcl
new file mode 100644
index 0000000..072c3b1
--- /dev/null
+++ b/tcllib/modules/interp/pkgIndex.tcl
@@ -0,0 +1,4 @@
+if {![package vsatisfies [package provide Tcl] 8.3]} return
+package ifneeded interp 0.1.2 [list source [file join $dir interp.tcl]]
+package ifneeded interp::delegate::proc 0.2 [list source [file join $dir deleg_proc.tcl]]
+package ifneeded interp::delegate::method 0.2 [list source [file join $dir deleg_method.tcl]]
diff --git a/tcllib/modules/interp/tcllib_interp.man b/tcllib/modules/interp/tcllib_interp.man
new file mode 100644
index 0000000..87978f2
--- /dev/null
+++ b/tcllib/modules/interp/tcllib_interp.man
@@ -0,0 +1,74 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin interp n 0.1.2]
+[keywords alias]
+[keywords {empty interpreter}]
+[keywords interpreter]
+[keywords method]
+[keywords snit]
+[copyright {2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Interpreter utilities}]
+[titledesc {Interp creation and aliasing}]
+[category {Programming tools}]
+[require Tcl 8.3]
+[require interp [opt 0.1.2]]
+[description]
+[para]
+
+This package provides a number of commands for the convenient creation
+of Tcl interpreters for highly restricted execution.
+
+[section API]
+[list_begin definitions]
+
+[call [cmd ::interp::createEmpty] [opt [arg path]]]
+
+This commands creates an empty Tcl interpreter and returns it
+name. Empty means that the new interpreter has neither namespaces, nor
+any commands. It is useful only for the creation of aliases.
+
+[para]
+
+If a [arg path] is specified then it is taken as the name of the new
+interpreter.
+
+[call [cmd ::interp::snitLink] [arg path] [arg methodlist]]
+
+This command assumes that it was called from within a method of a snit
+object, and that the command [cmd mymethod] is available.
+
+[para]
+
+It extends the interpreter specified by [arg path] with aliases for
+all methods found in the [arg methodlist], with the alias directing
+execution to the same-named method of the snit object invoking this
+command.
+
+Each element of [arg methodlist] is actually interpreted as a command
+prefix, with the first word of each prefix the name of the method to
+link to.
+
+[para]
+
+The result of the command is the empty string.
+
+[call [cmd ::interp::snitDictLink] [arg path] [arg methoddict]]
+
+This command behaves like [cmd ::interp::snitLink], except that it
+takes a dictionary mapping from commands to methods as its input, and
+not a list of methods.
+
+Like for [cmd ::interp::snitLink] the method references are actually
+command prefixes.
+
+This command allows the creation of more complex command-method
+mappings than [cmd ::interp::snitLink].
+
+[para]
+
+The result of the command is the empty string.
+
+[list_end]
+
+[vset CATEGORY interp]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/irc/ChangeLog b/tcllib/modules/irc/ChangeLog
new file mode 100644
index 0000000..4dec8fa
--- /dev/null
+++ b/tcllib/modules/irc/ChangeLog
@@ -0,0 +1,259 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2013-01-09 Andreas Kupries <andreask@activestate.com>
+
+ * irc.man: Documented the callback for EOF as required.
+
+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 ========================
+ *
+
+2008-08-05 Andreas Kupries <andreask@activestate.com>
+
+ * irc.tcl (::irc::connection): Fixed [Bug 2038217], a
+ * irc.man: creative-writing problem. Bumped the package
+ * pkgIndex.tcl: version to 0.6.1.
+
+2008-06-24 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * picoirc.tcl: Fixed ctcp responses (should use NOTICE).
+
+2008-03-14 Andreas Kupries <andreask@activestate.com>
+
+ * picoirc.man: Cleaned up a bit, replaced deprecated [nl] usage
+ with [para].
+
+2007-10-19 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * picoirc.man: Added an alternative that is somewhat simpler
+ * picoirc.tcl: to embed in an application. Based upon the picoirc
+ code posted to the wiki and as used in tkchat.
+
+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>
+
+ * irc.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-04-23 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * irc.tcl: Applied patch #1349154 by Kristoffer Lawson to add
+ * irc.man: a command to retrieve the socket in use.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-09-24 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * irc.tcl: removed package require for logger and added config
+ option to use logger. removed backwards compatibility code from
+ connection and connect. added log and logname commands.
+
+2004-09-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * irc.tcl: Fixed expr'essions without braces.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-01-24 Andreas Kupries <andreask@activestate.com>
+
+ * irc.man: Small documentation cleanups.
+
+2004-01-20 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * irc.tcl Fixed incorrect usage of linsert in previous change.
+ Removed uneeded state variable.
+
+2003-10-22 David N. Welton <davidw@dedasys.com>
+
+ * irc.tcl (network): Fixed usage of eval - thanks to Jeff Hobbs.
+
+2003-07-27 Aaron Faupell <afaupell@users.sourceforge.net>
+ * irc.tcl removed catch around socket creation
+
+2003-07-02 Aaron Faupell <afaupell@users.sourceforge.net>
+ * irc.tcl fixed logger not being turned off if debug
+ was turned off prior to creating new connection.
+
+2003-07-02 Aaron Faupell
+ * irc.tcl moved cmd-reload to ::irc::reload. removed
+ unused nick variable.
+ * irc.man added all the recently created
+ commands to the man page.
+
+
+2003-06-30 David N. Welton <davidw@dedasys.com>
+
+ * irc.tcl (::irc::connection): connection no longer takes
+ host/port arguments. This is done by connect now. Added note
+ that compatibility code for older versions should be removed after
+ a release cycle or two. (Aaron Faupell)
+ (cmd-connect): connect command now takes hostname and port
+ arguments. (Aaron Faupell)
+ (cmd-reload): New command reloads irc.tcl file, making it possible
+ to make changes in a running system without losing the connection.
+ (::irc::connection): The unique namespace for irc connections no
+ longer includes the hostname. (Aaron Faupell)
+ (::irc::connections): New command - return list of existing
+ connections (Aaron Faupell).
+ (cmd-config): Per connection configuration (Aaron Faupell).
+ (cmd-peername): New command - get socket peername.
+ (cmd-sockname): New command - get socket name.
+ (cmd-disconnect): New command - disconnect the connection without
+ destroying it.
+
+ * irc.man: Updated the man page to reflect the new connect and
+ connection commands.
+
+2003-05-28 David N. Welton <davidw@dedasys.com>
+
+ * irc.tcl (cmd-quit): Add default QUIT message.
+
+2003-05-25 David N. Welton <davidw@dedasys.com>
+
+ * irc.tcl: Several cleanups/improvements by Aaron Faupell.
+ (cmd-getevent) Fixed typo.
+ (cmd-user): Added backwards compatible cmd-user.
+ (cmd-connect): Minor improvements/cleanup.
+ (GetEvent): Changed parsing of $line components.
+
+2003-05-22 Andreas Kupries <andreask@activestate.com>
+
+ * irc.man: Fixed some typos in the manpage which prevented
+ conversion.
+
+2003-05-17 David N. Welton <davidw@dedasys.com>
+
+ * irc.man: Add key option to channel join command. Provided by
+ Aaron Faupell.
+
+2003-05-16 David N. Welton <davidw@dedasys.com>
+
+ * irc.man: Added Aaron's updated documentation, including the new
+ commands.
+
+ * irc.tcl: Lots of improvements by Aaron Faupell, including: new
+ commands, and a new method of dispatching events. Server PINGs
+ (as opposed to CTCP PINGS) automatically generate a reply, as a
+ convenience. Version number 0.4.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * irc.tcl: Accepted the patch in report [#718985] for a more
+ robust 'GetEvent' routine. Provided by Donal Fellows
+ <dkf@users.sourceforge.net>.
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * irc.man:
+ * irc.tcl: Fixed bug #614591. Set version of the package to
+ to 0.3 throughout. Was insonsistent.
+
+2003-01-25 David N. Welton <davidw@dedasys.com>
+
+ * irc.tcl: Added Tcl requirement to package itself.
+
+2003-01-24 David N. Welton <davidw@dedasys.com>
+
+ * pkgIndex.tcl: Added dependency on Tcl 8.3 in the pkgIndex.tcl
+ file. I'm not sure that this code won't work with earlier
+ versions of Tcl, but 8.3 is all I have to test against. Please
+ let me know if you successfully run it with earlier versions.
+ Fixes [674331].
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * irc.man: More semantic markup, less visual one.
+
+2003-01-08 David N. Welton <davidw@dedasys.com>
+
+ * irc.tcl: Make sure 'api' commands return strings, not lists.
+ (DispatchServerEvent): Add a missing join, to keep
+
+2002-12-16 David N. Welton <davidw@dedasys.com>
+
+ * irc.tcl: Use 'logger' package for error/debug reporting.
+ Cleanups with regards to possible 'bgerror' situations (network
+ input/output). Bumped version number to 0.3.
+
+2002-04-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * irc.man: Added doctools manpage.
+
+2002-02-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * irc.tcl: Frink run.
+
+ * irc: Version is now 0.2 to distinguish this from the code in
+ tcllib release 1.2
+
+2001-11-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * irc.n:
+ * irc.tcl: Applied patch #481477.
diff --git a/tcllib/modules/irc/irc.man b/tcllib/modules/irc/irc.man
new file mode 100644
index 0000000..a0d5423
--- /dev/null
+++ b/tcllib/modules/irc/irc.man
@@ -0,0 +1,239 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin irc n 0.6.1]
+[see_also {rfc 1459}]
+[keywords chat]
+[keywords irc]
+[moddesc {Low Level Tcl IRC Interface}]
+[titledesc {Create IRC connection and interface.}]
+[category Networking]
+[require Tcl]
+[require irc [opt 0.6.1]]
+[description]
+
+This package provides low-level commands to deal with the IRC protocol
+(Internet Relay Chat) for immediate and interactive multi-cast
+communication.
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd ::irc::config] [opt key] [opt value]]
+
+Sets configuration [opt key] to [opt value]. The configuration keys
+currently defined are the boolean flags [const logger] and [const debug].
+[const logger] makes [package irc] use the logger package for printing
+error. [const debug] requires [const logger] and prints extra debug output.
+
+If no [opt key] or [opt value] is given the current values are returned.
+
+[call [cmd ::irc::connection]]
+
+The command creates a new object to deal with an IRC connection.
+Creating this IRC object does not automatically create the network
+connection. It returns a new irc namespace command which can be used
+to interact with the new IRC connection. NOTE: the old form of the
+connection command, which took a hostname and port as arguments, is
+deprecated. Use [cmd connect] instead to specify this information.
+
+[call [cmd ::irc::connections]]
+
+Returns a list of all the current connections that were created with
+[const connection]
+
+[list_end]
+
+[section {Per-connection Commands}]
+[para]
+
+In the following list of available connection methods [arg net]
+represents a connection command as returned by
+[cmd ::irc::connection].
+
+[list_begin definitions]
+
+[call [arg net] [method registerevent] [arg event] [arg script]]
+
+Registers a callback handler for the specific event. Events available
+are those described in RFC 1459
+
+[uri http://www.rfc-editor.org/rfc/rfc1459.txt].
+
+In addition, there are several other events defined.
+
+[const defaultcmd] adds a command that is called if no other callback
+is present. [const EOF] is called if the connection signals an End of
+File condition. The events [const defaultcmd], [const defaultnumeric],
+[const defaultevent], and [const EOF] are required.
+
+[arg script] is executed in the connection namespace, which can take
+advantage of several commands (see [sectref {Callback Commands}]
+below) to aid in the parsing of data.
+
+[call [arg net] [method getevent] [arg event] [arg script]]
+
+Returns the current handler for the event if one exists. Otherwise an
+empty string is returned.
+
+[call [arg net] [method eventexists] [arg event] [arg script]]
+
+Returns a boolean value indicating the existence of the event handler.
+
+[call [arg net] [method connect] [arg hostname] [opt port]]
+
+This causes the socket to be established. [cmd ::irc::connection]
+created the namespace and the commands to be used, but did not
+actually open the socket. This is done here. NOTE: the older form of
+'connect' did not require the user to specify a hostname and port,
+which were specified with 'connection'. That form is deprecated.
+
+[call [arg net] [method config] [opt key] [opt value]]
+
+The same as [cmd ::irc::config] but sets and gets options for the [arg net]
+connection only.
+
+[call [arg net] [method log] [arg level] [arg message]]
+
+If logger is turned on by [method config] this will write a log [arg message]
+at [arg level].
+
+[call [arg net] [method logname]]
+
+Returns the name of the logger instance if logger is turned on.
+
+[call [arg net] [method connected]]
+
+Returns a boolean value indicating if this connection is connected to a server.
+
+[call [arg net] [method sockname]]
+
+Returns a 3 element list consisting of the ip address, the hostname, and the port
+of the local end of the connection, if currently connected.
+
+[call [arg net] [method peername]]
+
+Returns a 3 element list consisting of the ip address, the hostname, and the port
+of the remote end of the connection, if currently connected.
+
+[call [arg net] [method socket]]
+
+Return the Tcl channel for the socket used by the connection.
+
+[call [arg net] [method user] [arg username] [arg localhostname] [arg localdomainname] [arg userinfo]]
+
+Sends USER command to server. [arg username] is the username you want
+to appear. [arg localhostname] is the host portion of your hostname, [arg localdomainname]
+is your domain name, and [arg userinfo] is a short description of who you are. The 2nd and 3rd
+arguments are normally ignored by the IRC server.
+
+[call [arg net] [method nick] [arg nick]]
+
+NICK command. [arg nick] is the nickname you wish to use for the
+particular connection.
+
+[call [arg net] [method ping] [arg target]]
+
+Send a CTCP PING to [arg target].
+
+[call [arg net] [method serverping]]
+
+PING the server.
+
+[call [arg net] [method join] [arg channel] [opt [arg key]]]
+
+[arg channel] is the IRC channel to join. IRC channels typically
+begin with a hashmark ("#") or ampersand ("&").
+
+[call [arg net] [method part] [arg channel] [opt [arg message]]]
+
+Makes the client leave [arg channel]. Some networks may support the optional
+argument [arg message]
+
+[call [arg net] [method quit] [opt [arg message]]]
+
+Instructs the IRC server to close the current connection. The package
+will use a generic default if no [arg message] was specified.
+
+[call [arg net] [method privmsg] [arg target] [arg message]]
+
+Sends [arg message] to [arg target], which can be either a channel, or
+another user, in which case their nick is used.
+
+[call [arg net] [method notice] [arg target] [arg message]]
+
+Sends a [const notice] with message [arg message] to [arg target],
+which can be either a channel, or another user, in which case their nick is used.
+
+[call [arg net] [method ctcp] [arg target] [arg message]]
+
+Sends a CTCP of type [arg message] to [arg target]
+
+[call [arg net] [method kick] [arg channel] [arg target] [opt [arg message]]]
+
+Kicks the user [arg target] from the channel [arg channel] with a [arg message].
+The latter can be left out.
+
+[call [arg net] [method mode] [arg target] [arg args]]
+
+Sets the mode [arg args] on the target [arg target]. [arg target] may be a channel,
+a channel user, or yourself.
+
+[call [arg net] [method topic] [arg channel] [arg message]]
+
+Sets the topic on [arg channel] to [arg message] specifying an empty string
+will remove the topic.
+
+[call [arg net] [method invite] [arg channel] [arg target]]
+
+Invites [arg target] to join the channel [arg channel]
+
+[call [arg net] [method send] [arg text]]
+
+Sends [arg text] to the IRC server.
+
+[call [arg net] [method destroy]]
+
+Deletes the connection and its associated namespace and information.
+
+[list_end]
+
+[section {Callback Commands}]
+[para]
+
+These commands can be used within callbacks
+
+[list_begin definitions]
+
+[call [cmd who] [opt [const address]]]
+
+Returns the nick of the user who performed a command. The optional
+keyword [const address] causes the command to return the user in the
+format "username@address".
+
+[call [cmd action]]
+
+Returns the action performed, such as KICK, PRIVMSG, MODE, etc...
+Normally not useful, as callbacks are bound to a particular event.
+
+[call [cmd target]]
+
+Returns the target of a particular command, such as the channel or
+user to whom a PRIVMSG is sent.
+
+[call [cmd additional]]
+
+Returns a list of any additional arguments after the target.
+
+[call [cmd header]]
+
+Returns the entire event header (everything up to the :) as a proper list.
+
+[call [cmd msg]]
+
+Returns the message portion of the command (the part after the :).
+
+[list_end]
+
+[vset CATEGORY irc]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/irc/irc.tcl b/tcllib/modules/irc/irc.tcl
new file mode 100644
index 0000000..c8a7db8
--- /dev/null
+++ b/tcllib/modules/irc/irc.tcl
@@ -0,0 +1,523 @@
+# irc.tcl --
+#
+# irc implementation for Tcl.
+#
+# Copyright (c) 2001-2003 by David N. Welton <davidw@dedasys.com>.
+# This code may be distributed under the same terms as Tcl.
+
+package require Tcl 8.3
+
+namespace eval ::irc {
+ # counter used to differentiate connections
+ variable conn 0
+ variable config
+ variable irctclfile [info script]
+ array set config {
+ debug 0
+ logger 0
+ }
+}
+
+# ::irc::config --
+#
+# Set global configuration options.
+#
+# Arguments:
+#
+# key name of the configuration option to change.
+#
+# value value of the configuration option.
+
+proc ::irc::config { args } {
+ variable config
+ if { [llength $args] == 0 } {
+ return [array get config]
+ } elseif { [llength $args] == 1 } {
+ return $config($key)
+ } elseif { [llength $args] > 2 } {
+ error "wrong # args: should be \"config key ?val?\""
+ }
+ set key [lindex $args 0]
+ set value [lindex $args 1]
+ foreach ns [namespace children] {
+ if { [info exists config($key)] && [info exists ${ns}::config($key)] \
+ && [set ${ns}::config($key)] == $config($key)} {
+ ${ns}::cmd-config $key $value
+ }
+ }
+ set config($key) $value
+}
+
+
+# ::irc::connections --
+#
+# Return a list of handles to all existing connections
+
+proc ::irc::connections { } {
+ set r {}
+ foreach ns [namespace children] {
+ lappend r ${ns}::network
+ }
+ return $r
+}
+
+# ::irc::reload --
+#
+# Reload this file, and merge the current connections into
+# the new one.
+
+proc ::irc::reload { } {
+ variable conn
+ set oldconn $conn
+ namespace eval :: {
+ source [set ::irc::irctclfile]
+ }
+ foreach ns [namespace children] {
+ foreach var {sock logger host port} {
+ set $var [set ${ns}::$var]
+ }
+ array set dispatch [array get ${ns}::dispatch]
+ array set config [array get ${ns}::config]
+ # make sure our new connection uses the same namespace
+ set conn [string range $ns 10 end]
+ ::irc::connection
+ foreach var {sock logger host port} {
+ set ${ns}::$var [set $var]
+ }
+ array set ${ns}::dispatch [array get dispatch]
+ array set ${ns}::config [array get config]
+ }
+ set conn $oldconn
+}
+
+# ::irc::connection --
+#
+# Create an IRC connection namespace and associated commands.
+
+proc ::irc::connection { args } {
+ variable conn
+ variable config
+
+ # Create a unique namespace of the form irc$conn::$host
+
+ set name [format "%s::irc%s" [namespace current] $conn]
+
+ namespace eval $name {
+ variable sock
+ variable dispatch
+ variable linedata
+ variable config
+
+ set sock {}
+ array set dispatch {}
+ array set linedata {}
+ array set config [array get ::irc::config]
+ if { $config(logger) || $config(debug)} {
+ package require logger
+ variable logger
+ set logger [logger::init [namespace tail [namespace current]]]
+ if { !$config(debug) } { ${logger}::disable debug }
+ }
+
+
+ # ircsend --
+ # send text to the IRC server
+
+ proc ircsend { msg } {
+ variable sock
+ variable dispatch
+ if { $sock == "" } { return }
+ cmd-log debug "ircsend: '$msg'"
+ if { [catch {puts $sock $msg} err] } {
+ catch { close $sock }
+ set sock {}
+ if { [info exists dispatch(EOF)] } {
+ eval $dispatch(EOF)
+ }
+ cmd-log error "Error in ircsend: $err"
+ }
+ }
+
+
+ #########################################################
+ # Implemented user-side commands, meaning that these commands
+ # cause the calling user to perform the given action.
+ #########################################################
+
+
+ # cmd-config --
+ #
+ # Set or return per-connection configuration options.
+ #
+ # Arguments:
+ #
+ # key name of the configuration option to change.
+ #
+ # value value (optional) of the configuration option.
+
+ proc cmd-config { args } {
+ variable config
+ variable logger
+
+ if { [llength $args] == 0 } {
+ return [array get config]
+ } elseif { [llength $args] == 1 } {
+ return $config($key)
+ } elseif { [llength $args] > 2 } {
+ error "wrong # args: should be \"config key ?val?\""
+ }
+ set key [lindex $args 0]
+ set value [lindex $args 1]
+ if { $key == "debug" } {
+ if {$value} {
+ if { !$config(logger) } { cmd-config logger 1 }
+ ${logger}::enable debug
+ } elseif { [info exists logger] } {
+ ${logger}::disable debug
+ }
+ }
+ if { $key == "logger" } {
+ if { $value && !$config(logger)} {
+ package require logger
+ set logger [logger::init [namespace tail [namespace current]]]
+ } elseif { [info exists logger] } {
+ ${logger}::delete
+ unset logger
+ }
+ }
+ set config($key) $value
+ }
+
+ proc cmd-log {level text} {
+ variable logger
+ if { ![info exists logger] } return
+ ${logger}::$level $text
+ }
+
+ proc cmd-logname { } {
+ variable logger
+ if { ![info exists logger] } return
+ return $logger
+ }
+
+ # cmd-destroy --
+ #
+ # destroys the current connection and its namespace
+
+ proc cmd-destroy { } {
+ variable logger
+ variable sock
+ if { [info exists logger] } { ${logger}::delete }
+ catch {close $sock}
+ namespace delete [namespace current]
+ }
+
+ proc cmd-connected { } {
+ variable sock
+ if { $sock == "" } { return 0 }
+ return 1
+ }
+
+ proc cmd-user { username hostname servername {userinfo ""} } {
+ if { $userinfo == "" } {
+ ircsend "USER $username $hostname server :$servername"
+ } else {
+ ircsend "USER $username $hostname $servername :$userinfo"
+ }
+ }
+
+ proc cmd-nick { nk } {
+ ircsend "NICK $nk"
+ }
+
+ proc cmd-ping { target } {
+ ircsend "PRIVMSG $target :\001PING [clock seconds]\001"
+ }
+
+ proc cmd-serverping { } {
+ ircsend "PING [clock seconds]"
+ }
+
+ proc cmd-ctcp { target line } {
+ ircsend "PRIVMSG $target :\001$line\001"
+ }
+
+ proc cmd-join { chan {key {}} } {
+ ircsend "JOIN $chan $key"
+ }
+
+ proc cmd-part { chan {msg ""} } {
+ if { $msg == "" } {
+ ircsend "PART $chan"
+ } else {
+ ircsend "PART $chan :$msg"
+ }
+ }
+
+ proc cmd-quit { {msg {tcllib irc module - http://core.tcl.tk/tcllib/}} } {
+ ircsend "QUIT :$msg"
+ }
+
+ proc cmd-privmsg { target msg } {
+ ircsend "PRIVMSG $target :$msg"
+ }
+
+ proc cmd-notice { target msg } {
+ ircsend "NOTICE $target :$msg"
+ }
+
+ proc cmd-kick { chan target {msg {}} } {
+ ircsend "KICK $chan $target :$msg"
+ }
+
+ proc cmd-mode { target args } {
+ ircsend "MODE $target [join $args]"
+ }
+
+ proc cmd-topic { chan msg } {
+ ircsend "TOPIC $chan :$msg"
+ }
+
+ proc cmd-invite { chan target } {
+ ircsend "INVITE $target $chan"
+ }
+
+ proc cmd-send { line } {
+ ircsend $line
+ }
+
+ proc cmd-peername { } {
+ variable sock
+ if { $sock == "" } { return {} }
+ return [fconfigure $sock -peername]
+ }
+
+ proc cmd-sockname { } {
+ variable sock
+ if { $sock == "" } { return {} }
+ return [fconfigure $sock -sockname]
+ }
+
+ proc cmd-socket { } {
+ variable sock
+ return $sock
+ }
+
+ proc cmd-disconnect { } {
+ variable sock
+ if { $sock == "" } { return -1 }
+ catch { close $sock }
+ set sock {}
+ return 0
+ }
+
+ # Connect --
+ # Create the actual tcp connection.
+
+ proc cmd-connect { h {p 6667} } {
+ variable sock
+ variable host
+ variable port
+
+ set host $h
+ set port $p
+
+ if { $sock == "" } {
+ set sock [socket $host $port]
+ fconfigure $sock -translation crlf -buffering line
+ fileevent $sock readable [namespace current]::GetEvent
+ }
+ return 0
+ }
+
+ # Callback API:
+
+ # These are all available from within callbacks, so as to
+ # provide an interface to provide some information on what is
+ # coming out of the server.
+
+ # action --
+
+ # Action returns the action performed, such as KICK, PRIVMSG,
+ # MODE etc, including numeric actions such as 001, 252, 353,
+ # and so forth.
+
+ proc action { } {
+ variable linedata
+ return $linedata(action)
+ }
+
+ # msg --
+
+ # The last argument of the line, after the last ':'.
+
+ proc msg { } {
+ variable linedata
+ return $linedata(msg)
+ }
+
+ # who --
+
+ # Who performed the action. If the command is called as [who address],
+ # it returns the information in the form
+ # nick!ident@host.domain.net
+
+ proc who { {address 0} } {
+ variable linedata
+ if { $address == 0 } {
+ return [lindex [split $linedata(who) !] 0]
+ } else {
+ return $linedata(who)
+ }
+ }
+
+ # target --
+
+ # To whom was this action done.
+
+ proc target { } {
+ variable linedata
+ return $linedata(target)
+ }
+
+ # additional --
+
+ # Returns any additional header elements beyond the target as a list.
+
+ proc additional { } {
+ variable linedata
+ return $linedata(additional)
+ }
+
+ # header --
+
+ # Returns the entire header in list format.
+
+ proc header { } {
+ variable linedata
+ return [concat [list $linedata(who) $linedata(action) \
+ $linedata(target)] $linedata(additional)]
+ }
+
+ # GetEvent --
+
+ # Get a line from the server and dispatch it.
+
+ proc GetEvent { } {
+ variable linedata
+ variable sock
+ variable dispatch
+ array set linedata {}
+ set line "eof"
+ if { [eof $sock] || [catch {gets $sock} line] } {
+ close $sock
+ set sock {}
+ cmd-log error "Error receiving from network: $line"
+ if { [info exists dispatch(EOF)] } {
+ eval $dispatch(EOF)
+ }
+ return
+ }
+ cmd-log debug "Recieved: $line"
+ if { [set pos [string first " :" $line]] > -1 } {
+ set header [string range $line 0 [expr {$pos - 1}]]
+ set linedata(msg) [string range $line [expr {$pos + 2}] end]
+ } else {
+ set header [string trim $line]
+ set linedata(msg) {}
+ }
+
+ if { [string match :* $header] } {
+ set header [split [string trimleft $header :]]
+ } else {
+ set header [linsert [split $header] 0 {}]
+ }
+ set linedata(who) [lindex $header 0]
+ set linedata(action) [lindex $header 1]
+ set linedata(target) [lindex $header 2]
+ set linedata(additional) [lrange $header 3 end]
+ if { [info exists dispatch($linedata(action))] } {
+ eval $dispatch($linedata(action))
+ } elseif { [string match {[0-9]??} $linedata(action)] } {
+ eval $dispatch(defaultnumeric)
+ } elseif { $linedata(who) == "" } {
+ eval $dispatch(defaultcmd)
+ } else {
+ eval $dispatch(defaultevent)
+ }
+ }
+
+ # registerevent --
+
+ # Register an event in the dispatch table.
+
+ # Arguments:
+ # evnt: name of event as sent by IRC server.
+ # cmd: proc to register as the event handler
+
+ proc cmd-registerevent { evnt cmd } {
+ variable dispatch
+ set dispatch($evnt) $cmd
+ if { $cmd == "" } {
+ unset dispatch($evnt)
+ }
+ }
+
+ # getevent --
+
+ # Return the currently registered handler for the event.
+
+ # Arguments:
+ # evnt: name of event as sent by IRC server.
+
+ proc cmd-getevent { evnt } {
+ variable dispatch
+ if { [info exists dispatch($evnt)] } {
+ return $dispatch($evnt)
+ }
+ return {}
+ }
+
+ # eventexists --
+
+ # Return a boolean value indicating if there is a handler
+ # registered for the event.
+
+ # Arguments:
+ # evnt: name of event as sent by IRC server.
+
+ proc cmd-eventexists { evnt } {
+ variable dispatch
+ return [info exists dispatch($evnt)]
+ }
+
+ # network --
+
+ # Accepts user commands and dispatches them.
+
+ # Arguments:
+ # cmd: command to invoke
+ # args: arguments to the command
+
+ proc network { cmd args } {
+ eval [linsert $args 0 [namespace current]::cmd-$cmd]
+ }
+
+ # Create default handlers.
+
+ set dispatch(PING) {network send "PONG :[msg]"}
+ set dispatch(defaultevent) #
+ set dispatch(defaultcmd) #
+ set dispatch(defaultnumeric) #
+ }
+
+ set returncommand [format "%s::irc%s::network" [namespace current] $conn]
+ incr conn
+ return $returncommand
+}
+
+# -------------------------------------------------------------------------
+
+package provide irc 0.6.1
+
+# -------------------------------------------------------------------------
diff --git a/tcllib/modules/irc/picoirc.man b/tcllib/modules/irc/picoirc.man
new file mode 100644
index 0000000..fe7224b
--- /dev/null
+++ b/tcllib/modules/irc/picoirc.man
@@ -0,0 +1,162 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset VERSION 0.5.2]
+[manpage_begin picoirc n [vset VERSION]]
+[see_also {rfc 1459}]
+[keywords chat]
+[keywords irc]
+[moddesc {Simple embeddable IRC interface}]
+[titledesc {Small and simple embeddable IRC client.}]
+[category Networking]
+[require Tcl]
+[require picoirc [opt [vset VERSION]]]
+[description]
+
+This package provides a general purpose minimal IRC client suitable for
+embedding in other applications. All communication with the parent
+application is done via an application provided callback procedure.
+Each connection has its own state so you can hook up multiple servers
+in a single application instance.
+
+[para]
+
+To initiate an IRC connection you must call [cmd picoirc::connect]
+with a callback procedure, a nick-name to use on IRC and the IRC URL
+that describes the connection. This will return a variable name that
+is the irc connection context. See [sectref CALLBACK] for details.
+
+[para]
+
+This package is a fairly simple IRC client. If you need something with
+more capability investigate the [package irc] package.
+
+[para]
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::picoirc::connect] [arg callback] [arg nick] [arg url]]
+
+Create a new irc connection to the server specified by [arg url] and
+login using the [arg nick] as the username. The [arg callback] must be
+as specified in [sectref CALLBACK]. Returns a package-specific variable
+that is used when calling other commands in this package.
+
+[call [cmd ::picoirc::post] [arg context] [arg channel] [arg message]]
+
+This should be called to process user input and send it to the
+server. A number of commands are recognised when prefixed with a
+forward-slash (/). Such commands are converted to IRC command
+sequences and then sent.
+
+[call [cmd ::picoirc::splituri] [arg uri]]
+
+Splits an IRC scheme uniform resource indicator into its component
+parts. Returns a list of server, port and channel. The default port is
+6667 and there is no default channel.
+
+[call [cmd ::picoirc::send] [arg context] [arg line]]
+
+This command is where all raw output to the server is handled. The
+default action is to write the [arg line] to the irc socket. However,
+before this happens the callback is called with "debug write". This
+permits the application author to inspect the raw IRC data and if
+desired to return a break error code to halt further processing. In
+this way the application can override the default send via the
+callback procedure.
+
+[list_end]
+
+[section CALLBACK]
+
+The callback must look like:
+
+[example {
+proc Callback {context state args} {
+}
+}]
+
+where context is the irc context variable name (in case you need to pass
+it back to a picoirc procedure). state is one of a number of states as
+described below.
+
+[list_begin options]
+
+[opt_def init]
+
+called just before the socket is created
+
+[opt_def connect]
+
+called once we have connected, before we join any channels
+
+[opt_def close]
+
+called when the socket gets closed, before the context is deleted. If
+an error occurs before we get connected the only argument will be the
+socket error message.
+
+[opt_def userlist "[arg channel] [arg nicklist]"]
+
+called to notify the application of an updated userlist. This is
+generated when the output of the NAMES irc command is seen. The
+package collects the entire output which can span a number of output
+lines from the server and calls this callback when they have all been
+received.
+
+[opt_def chat "[arg target] [arg nick] [arg message] [arg type]"]
+
+called when a message arrives. [arg target] is the identity that the
+message was targetted for. This can be the logged in nick or a channel
+name. [arg nick] is the name of the sender of the message.
+[arg message] is the message text. [arg type] is set to "ACTION" if the
+message was sent as a CTCP ACTION
+
+[opt_def system "[arg channel] [arg message]"]
+
+called when a system message is received
+
+[opt_def topic "[arg channel] [arg topic]"]
+
+called when the channel topic string is seen. [arg topic] is the text
+of the channel topic.
+
+[opt_def traffic "[arg action] [arg channel] [arg nick] [opt [arg newnick]]"]
+
+called when users join, leave or change names.
+[arg action] is either entered, left or nickchange and [arg nick]
+is the user doing the action. [arg newnick] is
+the new name if [arg action] is nickchange.
+[para]
+[emph NOTE]: [arg channel] is often empty for these messages as nick
+activities are global for the irc server. You will have
+to manage the nick for all connected channels yourself.
+
+[opt_def version]
+
+This is called to request a version string to use to
+override the internal version. If implemented, you should
+return as colon delimited string as
+[para]
+ Appname:Appversion:LibraryVersion
+[para]
+For example, the default is
+[para]
+ PicoIRC:[lb]package provide picoirc[rb]:Tcl [lb]info patchlevel[rb]
+
+[opt_def debug "[arg type] [arg raw]"]
+
+called when data is either being read or written to the network
+socket. [arg type] is set to [const read] when reading data and
+[const write] if the data is to be written. [arg raw] is the
+unprocessed IRC protocol data.
+[para]
+In both cases the application can return a break error code to
+interrupt further processing of the raw data. If this is a
+[const read] operation then the package will not handle this line. If
+the operation is [const write] then the package will not send the
+data. This callback is intended for debugging protocol issues but
+could be used to redirect all input and output if desired.
+
+[list_end]
+[manpage_end]
diff --git a/tcllib/modules/irc/picoirc.tcl b/tcllib/modules/irc/picoirc.tcl
new file mode 100644
index 0000000..1728fe2
--- /dev/null
+++ b/tcllib/modules/irc/picoirc.tcl
@@ -0,0 +1,271 @@
+# Based upon the picoirc code by Salvatore Sanfillipo and Richard Suchenwirth
+# See http://wiki.tcl.tk/13134 for the original standalone version.
+#
+# This package provides a general purpose minimal IRC client suitable for
+# embedding in other applications. All communication with the parent
+# application is done via an application provided callback procedure.
+#
+# Copyright (c) 2004 Salvatore Sanfillipo
+# Copyright (c) 2004 Richard Suchenwirth
+# Copyright (c) 2007 Patrick Thoyts
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+namespace eval ::picoirc {
+ variable uid
+ if {![info exists uid]} { set uid 0 }
+
+ variable defaults {
+ server "irc.freenode.net"
+ port 6667
+ channel ""
+ callback ""
+ motd {}
+ users {}
+ }
+ namespace export connect send post splituri
+}
+
+proc ::picoirc::splituri {uri} {
+ foreach {server port channel} {{} {} {}} break
+ if {![regexp {^irc://([^:/]+)(?::([^/]+))?(?:/([^,]+))?} $uri -> server port channel]} {
+ regexp {^(?:([^@]+)@)?([^:]+)(?::(\d+))?} $uri -> channel server port
+ }
+ if {$port eq {}} { set port 6667 }
+ return [list $server $port $channel]
+}
+
+proc ::picoirc::connect {callback nick args} {
+ if {[llength $args] > 2} {
+ return -code error "wrong # args: must be \"callback nick ?passwd? url\""
+ } elseif {[llength $args] == 1} {
+ set url [lindex $args 0]
+ } else {
+ foreach {passwd url} $args break
+ }
+ variable defaults
+ variable uid
+ set context [namespace current]::irc[incr uid]
+ upvar #0 $context irc
+ array set irc $defaults
+ foreach {server port channel} [splituri $url] break
+ if {[info exists channel] && $channel ne ""} {set irc(channel) $channel}
+ if {[info exists server] && $server ne ""} {set irc(server) $server}
+ if {[info exists port] && $port ne ""} {set irc(port) $port}
+ if {[info exists passwd] && $passwd ne ""} {set irc(passwd) $passwd}
+ set irc(callback) $callback
+ set irc(nick) $nick
+ Callback $context init
+ set irc(socket) [socket -async $irc(server) $irc(port)]
+ fileevent $irc(socket) readable [list [namespace origin Read] $context]
+ fileevent $irc(socket) writable [list [namespace origin Write] $context]
+ return $context
+}
+
+proc ::picoirc::Callback {context state args} {
+ upvar #0 $context irc
+ if {[llength $irc(callback)] > 0
+ && [llength [info commands [lindex $irc(callback) 0]]] == 1} {
+ if {[catch {eval $irc(callback) [list $context $state] $args} err]} {
+ puts stderr "callback error: $err"
+ }
+ }
+}
+
+proc ::picoirc::Version {context} {
+ if {[catch {Callback $context version} ver]} { set ver {} }
+ if {$ver eq {}} {
+ set ver "PicoIRC:[package provide picoirc]:Tcl [info patchlevel]"
+ }
+ return $ver
+}
+
+proc ::picoirc::Write {context} {
+ upvar #0 $context irc
+ fileevent $irc(socket) writable {}
+ if {[set err [fconfigure $irc(socket) -error]] ne ""} {
+ Callback $context close $err
+ close $irc(socket)
+ unset irc
+ return
+ }
+ fconfigure $irc(socket) -blocking 0 -buffering line -translation crlf -encoding utf-8
+ Callback $context connect
+ if {[info exists irc(passwd)]} {
+ send $context "PASS $irc(passwd)"
+ }
+ set ver [join [lrange [split [Version $context] :] 0 1] " "]
+ send $context "NICK $irc(nick)"
+ send $context "USER $::tcl_platform(user) 0 * :$ver user"
+ if {$irc(channel) ne {}} {
+ after idle [list [namespace origin send] $context "JOIN $irc(channel)"]
+ }
+ return
+}
+
+proc ::picoirc::Splitirc {s} {
+ foreach v {nick flags user host} {set $v {}}
+ regexp {^([^!]*)!([^=]*)=([^@]+)@(.*)} $s -> nick flags user host
+ return [list $nick $flags $user $host]
+}
+
+proc ::picoirc::Read {context} {
+ upvar #0 $context irc
+ if {[eof $irc(socket)]} {
+ fileevent $irc(socket) readable {}
+ Callback $context close
+ close $irc(socket)
+ unset irc
+ return
+ }
+ if {[gets $irc(socket) line] != -1} {
+ if {[string match "PING*" $line]} {
+ send $context "PONG [info hostname] [lindex [split $line] 1]"
+ return
+ }
+ # the callback can return -code break to prevent processing the read
+ if {[catch {Callback $context debug read $line}] == 3} {
+ return
+ }
+ if {[regexp {:([^!]*)![^ ].* +PRIVMSG ([^ :]+) +:(.*)} $line -> \
+ nick target msg]} {
+ set type ""
+ if {[regexp {\001(\S+)(.*)?\001} $msg -> ctcp data]} {
+ switch -- $ctcp {
+ ACTION { set type ACTION ; set msg $data }
+ VERSION {
+ send $context "NOTICE $nick :\001VERSION [Version $context]\001"
+ return
+ }
+ PING {
+ send $context "NOTICE $nick :\001PING [lindex $data 0]\001"
+ return
+ }
+ TIME {
+ set time [clock format [clock seconds] \
+ -format {%a %b %d %H:%M:%S %Y %Z}]
+ send $context "NOTICE $nick :\001TIME $time\001"
+ return
+ }
+ default {
+ set err [string map [list \001 ""] $msg]
+ send $context "NOTICE $nick :\001ERRMSG $err : unknown query\001"
+ return
+ }
+ }
+ }
+ if {[lsearch -exact {ijchain wubchain} $nick] != -1} {
+ if {$type eq "ACTION"} {
+ regexp {(\S+) (.+)} $msg -> nick msg
+ } else {
+ regexp {<([^>]+)> (.+)} $msg -> nick msg
+ }
+ }
+ Callback $context chat $target $nick $msg $type
+ } elseif {[regexp {^:((?:([^ ]+) +){1,}?):(.*)$} $line -> parts junk rest]} {
+ foreach {server code target fourth fifth} [split $parts] break
+ switch -- $code {
+ 001 - 002 - 003 - 004 - 005 - 250 - 251 - 252 -
+ 254 - 255 - 265 - 266 { return }
+ 433 {
+ variable nickid ; if {![info exists nickid]} {set nickid 0}
+ set seqlen [string length [incr nickid]]
+ set irc(nick) [string range $irc(nick) 0 [expr 8-$seqlen]]$nickid
+ send $context "NICK $irc(nick)"
+ }
+ 353 { set irc(users) [concat $irc(users) $rest]; return }
+ 366 {
+ Callback $context userlist $fourth $irc(users)
+ set irc(users) {}
+ return
+ }
+ 332 { Callback $context topic $fourth $rest; return }
+ 333 { return }
+ 375 { set irc(motd) {} ; return }
+ 372 { append irc(motd) $rest ; return}
+ 376 { return }
+ 311 {
+ foreach {server code target nick name host x} [split $parts] break
+ set irc(whois,$fourth) [list name $name host $host userinfo $rest]
+ return
+ }
+ 301 - 312 - 317 - 320 { return }
+ 319 { lappend irc(whois,$fourth) channels $rest; return }
+ 318 {
+ if {[info exists irc(whois,$fourth)]} {
+ Callback $context userinfo $fourth $irc(whois,$fourth)
+ unset irc(whois,$fourth)
+ }
+ return
+ }
+ JOIN {
+ foreach {n f u h} [Splitirc $server] break
+ Callback $context traffic entered $rest $n
+ return
+ }
+ NICK {
+ foreach {n f u h} [Splitirc $server] break
+ Callback $context traffic nickchange {} $n $rest
+ return
+ }
+ QUIT - PART {
+ foreach {n f u h} [Splitirc $server] break
+ Callback $context traffic left $target $n
+ return
+ }
+ }
+ Callback $context system "" "[lrange [split $parts] 1 end] $rest"
+ } else {
+ Callback $context system "" $line
+ }
+ }
+}
+
+proc ::picoirc::post {context channel msg} {
+ upvar #0 $context irc
+ set type ""
+ if [regexp {^/([^ ]+) *(.*)} $msg -> cmd msg] {
+ regexp {^([^ ]+)?(?: +(.*))?} $msg -> first rest
+ switch -- $cmd {
+ me {set msg "\001ACTION $msg\001";set type ACTION}
+ nick {send $context "NICK $msg"; set $irc(nick) $msg}
+ quit {send $context "QUIT" }
+ part {send $context "PART $channel" }
+ names {send $context "NAMES $channel"}
+ whois {send $context "WHOIS $channel $msg"}
+ kick {send $context "KICK $channel $first :$rest"}
+ mode {send $context "MODE $msg"}
+ topic {send $context "TOPIC $channel :$msg" }
+ quote {send $context $msg}
+ join {send $context "JOIN $msg" }
+ version {send $context "PRIVMSG $first :\001VERSION\001"}
+ msg {
+ if {[regexp {([^ ]+) +(.*)} $msg -> target querymsg]} {
+ send $context "PRIVMSG $target :$querymsg"
+ Callback $context chat $target $target $querymsg ""
+ }
+ }
+ default {Callback $context system $channel "unknown command /$cmd"}
+ }
+ if {$cmd ne {me} || $cmd eq {msg}} return
+ }
+ foreach line [split $msg \n] {send $context "PRIVMSG $channel :$line"}
+ Callback $context chat $channel $irc(nick) $msg $type
+}
+
+proc ::picoirc::send {context line} {
+ upvar #0 $context irc
+ # the callback can return -code break to prevent writing to socket
+ if {[catch {Callback $context debug write $line}] != 3} {
+ puts $irc(socket) $line
+ }
+}
+
+# -------------------------------------------------------------------------
+
+package provide picoirc 0.5.2
+
+# -------------------------------------------------------------------------
diff --git a/tcllib/modules/irc/pkgIndex.tcl b/tcllib/modules/irc/pkgIndex.tcl
new file mode 100644
index 0000000..c16c58d
--- /dev/null
+++ b/tcllib/modules/irc/pkgIndex.tcl
@@ -0,0 +1,8 @@
+# pkgIndex.tcl -*- tcl -*-
+# $Id: pkgIndex.tcl,v 1.10 2008/08/05 20:40:04 andreas_kupries Exp $
+if { ![package vsatisfies [package provide Tcl] 8.3] } {
+ # PRAGMA: returnok
+ return
+}
+package ifneeded irc 0.6.1 [list source [file join $dir irc.tcl]]
+package ifneeded picoirc 0.5.2 [list source [file join $dir picoirc.tcl]]
diff --git a/tcllib/modules/javascript/ChangeLog b/tcllib/modules/javascript/ChangeLog
new file mode 100644
index 0000000..759e1da
--- /dev/null
+++ b/tcllib/modules/javascript/ChangeLog
@@ -0,0 +1,114 @@
+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-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-06-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * javascript.man: Fixed bug [SF Bug 1740574], typos in the
+ documentation. Thanks to David Scott Cargo
+ <escargo@users.sourceforge.net> for the report.
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * javascript.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 ========================
+ *
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-09-28 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Removed the check for ncgi v1 being loaded before
+ javascript. This type of check has been done traditionally in
+ the implementation itself. Only checks for Tcl versions should
+ be done in the index.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * javascript.tcl:
+ * javascript.man:
+ * pkgIndex.tcl: Fixed bug #614591. Set version of the package to
+ to 1.0.1.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * javascript.man: More semantic markup, less visual one.
+
+2002-04-12 Andreas Kupries <andreas_kupries@user.sourceforge.net>
+
+ * javascript.man: Added doctools manpage.
+
+2000-11-01 Melissa Chawla <hershey@ajubasolutions.com>
+
+ * javascript.tcl: created this package.
diff --git a/tcllib/modules/javascript/javascript.man b/tcllib/modules/javascript/javascript.man
new file mode 100644
index 0000000..594eb99
--- /dev/null
+++ b/tcllib/modules/javascript/javascript.man
@@ -0,0 +1,96 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin javascript n 1.0.2]
+[see_also html]
+[see_also ncgi]
+[keywords checkbox]
+[keywords html]
+[keywords javascript]
+[keywords selectionbox]
+[keywords submitbutton]
+[moddesc {HTML and Java Script Generation}]
+[titledesc {Procedures to generate HTML and Java Script structures.}]
+[category {CGI programming}]
+[require Tcl 8]
+[require javascript [opt 1.0.2]]
+[description]
+[para]
+
+The [package ::javascript] package provides commands that generate
+HTML and Java Script code. These commands typically return an HTML
+string as their result. In particular, they do not output their
+result to [const stdout].
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd ::javascript::makeSelectorWidget] [arg {id leftLabel leftValueList rightLabel rightValueList rightNameList}] [opt [arg length]] [opt [arg minWidth]]]
+
+Construct HTML code to create a dual-multi-selection megawidget. This
+megawidget consists of two side-by-side multi-selection boxes
+separated by a left arrow and a right arrow button. The right arrow
+button moves all items selected in the left box to the right box. The
+left arrow button moves all items selected in the right box to the
+left box. The [arg id] argument is the suffix of all HTML objects in
+this megawidget. The [arg leftLabel] argument is the text that
+appears above the left selection box. The [arg leftValueList]
+argument is the values of items in the left selection box. The
+
+[arg leftNameList] argument is the names to appear in the left
+selection box. The [arg rightLabel] argument is the text that appears
+above the right selection box. The [arg rightValueList] argument is
+the values of items in the right selection box. The
+
+[arg rightNameList] argument is the names to appear in the right
+selection box. The [arg length] argument (optional) determines the
+number of elts to show before adding a vertical scrollbar; it defaults
+to 8. The [arg minWidth] argument (optional) is the number of spaces
+to determine the minimum box width; it defaults to 32.
+
+[call [cmd ::javascript::makeSubmitButton] [arg {name value}]]
+
+Create an HTML submit button that resets a hidden field for each
+registered multi-selection box. The [arg name] argument is the name
+of the HTML button object to create. The [arg value] argument is the
+label of the HTML button object to create.
+
+[call [cmd ::javascript::makeProtectedSubmitButton] [arg {name value msg}]]
+
+Create an HTML submit button that prompts the user with a
+continue/cancel shutdown warning before the form is submitted. The
+[arg name] argument is the name of the HTML button object to create.
+The [arg value] argument is the label of the HTML button object to
+create. The [arg msg] argument is the message to display when the
+button is pressed.
+
+[call [cmd ::javascript::makeMasterButton] [arg {master value slavePattern boolean}]]
+
+Create an HTML button that sets its slave checkboxs to the boolean
+value. The [arg master] argument is the name of the child's parent
+html checkbox object. The [arg value] argument is the value of the
+master. The [arg slaves] argument is the name of child html checkbox
+object to create. The [arg boolean] argument is the java script
+boolean value that will be given to all the slaves; it must be "true"
+or "false".
+
+[call [cmd ::javascript::makeParentCheckbox] [arg {parentName childName}]]
+
+Create an HTML checkbox and tie its value to that of its child
+checkbox. If the parent is unchecked, the child is automatically
+unchecked. The [arg parentName] argument is the name of parent html
+checkbox object to create. The [arg childName] argument is the name of
+the parent's child html checkbox object.
+
+[call [cmd ::javascript::makeChildCheckbox] [arg {parentName childName}]]
+
+Create an HTML checkbox and tie its value to that of its parent
+checkbox. If the child is checked, the parent is automatically
+checked. The [arg parentName] argument is the name of the child's
+parent html checkbox object. The [arg childName] argument is the name
+of child html checkbox object to create.
+
+[list_end]
+
+[vset CATEGORY javascript]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/javascript/javascript.tcl b/tcllib/modules/javascript/javascript.tcl
new file mode 100644
index 0000000..27abc55
--- /dev/null
+++ b/tcllib/modules/javascript/javascript.tcl
@@ -0,0 +1,453 @@
+# javascript.tcl --
+#
+# This file contains procedures that create HTML and Java Script
+# functions that implement objects such as:
+#
+# paired multi-selection boxes
+# guarded submit buttons
+# parent and child checkboxes
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: javascript.tcl,v 1.5 2005/09/30 05:36:39 andreas_kupries Exp $
+
+package require Tcl 8
+package require ncgi 1
+package provide javascript 1.0.2
+
+
+namespace eval ::javascript {
+
+ # The SelectionObjList namespace variable is used to keep the list of
+ # selection boxes that were created as parts of paired multi-selection
+ # boxes. When a submit button is made for pages that have paired
+ # multi-selection boxes, we set a hidden field to store the initial values
+ # in the box.
+
+ variable SelectionObjList {}
+}
+
+# ::javascript::BeginJS --
+#
+# Create HTML code to begin a java script program.
+#
+# Arguments:
+# none.
+#
+# Results:
+# Returns HTML code.
+
+proc ::javascript::BeginJS {} {
+ return "\n<SCRIPT LANGUAGE=\"JavaScript\">\n"
+}
+
+# ::javascript::EndJS --
+#
+# Create HTML code to end a java script program.
+#
+# Arguments:
+# none.
+#
+# Results:
+# Returns HTML code.
+
+proc ::javascript::EndJS {} {
+ return "\n</SCRIPT>\n"
+}
+
+# ::javascript::MakeMultiSel --
+#
+# Construct HTML code to create a multi-selection box.
+#
+# Arguments:
+# id The suffix of all HTML objects in this megawidget.
+# side Either "left" or "right".
+# eltValues The values to populate the selection box with.
+# eltNames The values to populate the selection box with.
+# emptyElts The number of empty box entry to stuff in the
+# Selection box as placeholders for elts to be added.
+# length The number of elts to show before adding a vertical
+# scrollbar.
+# minWidth Number of spaces to determin the minimum box width.
+#
+# Results:
+# Returns HTML to show the selection box.
+
+proc ::javascript::MakeMultiSel {id side eltValues eltNames emptyElts \
+ length minWidth} {
+
+ variable SelectionObjList
+
+ # Add this selection box to the list.
+
+ set name "$side$id"
+ lappend SelectionObjList $name
+
+ # Create the selection box and populate it with elts.
+
+ set html ""
+ append html "<select name=$name multiple size=$length>"
+ foreach elt $eltValues name $eltNames {
+ set encodedElt [ncgi::encode $elt]
+ append html "<option value=$encodedElt>$name"
+ }
+
+ # Add empty values for the remaining elements.
+
+ for {set i 0} {$i < $emptyElts} {incr i} {
+ append html "<option value=\"\"> "
+ }
+
+ # Add an empty value with text that is as wide as the minWidth.
+
+ set filler ""
+ for {set i 0} {$i < $minWidth} {incr i} {
+ append filler "&nbsp;&nbsp;"
+ }
+ append html "<option value=\"\">$filler"
+
+ append html "</select>"
+ return $html
+}
+
+# ::javascript::MakeClickProc --
+#
+# Create a "moveSelected$id" java script procedure to move selected items
+# from one selection box to the other.
+#
+# Arguments:
+# id The suffix of all objects in this multiselection megawidget.
+#
+# Results:
+# Returns java script code.
+
+proc ::javascript::MakeClickProc {id} {
+
+ set result "\nfunction moveSelected${id}(fromObj,toObj) \{\n"
+
+ # If nothing is selected, do nothing.
+
+ append result "\n if (fromObj.selectedIndex > -1) \{"
+
+ # Find the first empty element in the toObj.
+
+ append result {
+ for (var k = 0; toObj.options[k].value != ""; k++) {}
+}
+
+ # Move the selected elements from the fromObj to the end of the toObj.
+ # Shift the objects in the fromObj to fill any empty spots.
+ # Clear out any extra slots in the fromObj.
+ # Deselect any selected elements (deselect with both 'selected = false'
+ # and by setting selectedIndex to -1, because setting selectedIndex to
+ # -1 didn't seem to clear selection on all windows browsers.
+
+ append result {
+ for (var i = fromObj.selectedIndex, j = fromObj.selectedIndex; fromObj.options[i].value != ""; i++) {
+ if (fromObj.options[i].selected) {
+ toObj.options[k].text = fromObj.options[i].text
+ toObj.options[k++].value = fromObj.options[i].value
+ fromObj.options[i].selected = false
+ } else {
+ fromObj.options[j].text = fromObj.options[i].text
+ fromObj.options[j++].value = fromObj.options[i].value
+ }
+ }
+ for (; j < i; j++) {
+ fromObj.options[j].text = ""
+ fromObj.options[j].value = ""
+ }
+ fromObj.selectedIndex = -1
+}
+
+ # Close the if statement and the function
+
+ append result " \}
+\}
+"
+ return $result
+}
+
+# ::javascript::makeSelectorWidget --
+#
+# Construct HTML code to create a dual-multi-selection megawidget. This
+# megawidget consists of two side-by-side multi-selection boxes
+# separated by a left arrow and a right arrow button. The right arrow
+# button moves all items selected in the left box to the right box. The
+# left arrow button moves all items selected in the right box to the left
+# box.
+#
+# Arguments:
+# id The suffix of all HTML objects in this megawidget.
+# leftLabel The text that appears above the left selection box.
+# leftValueList The values of items in the left selection box.
+# leftNameList The names to appear in the left selection box.
+# rightLabel The text that appears above the right selection box.
+# rightValueList The values of items in the right selection box.
+# rightNameList The names to appear in the right selection box.
+# length (optional) The number of elts to show before adding a
+# vertical scrollbar. Defaults to 8.
+# minWidth (optional) The number of spaces to determin the
+# minimum box width. Defaults to 32.
+#
+# Results:
+# Returns HTML to show the dual-multi-selection megawidget.
+
+proc ::javascript::makeSelectorWidget {id leftLabel leftValueList leftNameList \
+ rightLabel rightValueList rightNameList {length 8} {minWidth 32}} {
+
+ set html ""
+ append html [BeginJS] \
+ [MakeClickProc $id] \
+ [EndJS]
+
+ append html "<table border=0 cellspacing=0 cellpadding=2>\n<tr><th>" \
+ $leftLabel "</th><th></th><th>" $rightLabel "</th></tr>\n<tr>"
+
+ set leftLen [llength $leftValueList]
+ set rightLen [llength $rightValueList]
+ set len [expr {$leftLen + $rightLen}]
+
+ append html "<td valign=top colspan=1>" \
+ [MakeMultiSel $id "left" $leftValueList $leftNameList \
+ $rightLen $length $minWidth] \
+ "&nbsp;&nbsp;</td>\n"
+
+ append html "<td>" \
+ "<table border=0 cellspacing=0 cellpadding=2>\n"
+
+ set args "this.form.left${id},this.form.right${id}"
+
+ append html "<tr><td><input type=button name=left${id}Button
+ onClick=\"moveSelected${id}(${args})\" value=\" >> \"></td></tr>"
+
+ set args "this.form.right${id},this.form.left${id}"
+
+ append html "<tr><td><input type=button name=right${id}Button
+ onClick=\"moveSelected${id}(${args})\" value=\" << \"></td></tr>"
+
+ append html "</table>\n" \
+ "</td>\n"
+
+ append html "<td valign=top colspan=1>" \
+ [MakeMultiSel $id "right" $rightValueList $rightNameList \
+ $leftLen $length $minWidth] \
+ "&nbsp;&nbsp;</td>\n"
+
+ append html "</tr>\n" \
+ "</table>\n"
+
+ # Add a hidden field to collect the data.
+
+ append html "<input type=hidden name=valleft${id} " \
+ "value=\"$leftValueList\">\n" \
+ "<input type=hidden name=valright${id} " \
+ "value=\"$rightValueList\">\n"
+
+ return $html
+}
+
+# ::javascript::makeSubmitButton --
+#
+# Create an HTML submit button that resets a hidden field for each
+# registered multi-selection box.
+#
+# Arguments:
+# name the name of the HTML button object to create.
+# value the label of the HTML button object to create.
+#
+# Results:
+# Returns HTML submit button code.
+
+proc ::javascript::makeSubmitButton {name value} {
+ variable SelectionObjList
+ set html ""
+
+ # Create the java script procedure that gathers the current values for each
+ # registered multi-selection box.
+
+ append html [BeginJS]
+ append html "\nfunction getSelections(form) \{\n"
+
+ # For each registered selection box, reset hidden field to
+ # store nonempty values.
+
+ foreach obj $SelectionObjList {
+ set selObj "form.$obj"
+ set hiddenObj "form.val$obj"
+ append html " var tmp$obj = \"\"\n"
+ append html " for (var i$obj = 0; i$obj < $selObj.length; i$obj++) {\n"
+ append html " if ($selObj.options\[i$obj\].value == \"\") {\n"
+ append html " break\n"
+ append html " }\n"
+ append html " tmp$obj += \" \" + $selObj.options\[i$obj\].value\n"
+ append html " }\n"
+ append html " $hiddenObj.value = tmp$obj \n"
+ }
+ append html "\}\n"
+ append html [EndJS]
+
+ # Empty the selection box for the next page.
+
+ set SelectionObjList {}
+
+ # Create the HTML submit button.
+
+ append html "<input type=submit name=\"$name\" value=\"$value\"
+ onClick=\"getSelections(this.form)\">"
+
+ return $html
+}
+
+# ::javascript::makeProtectedSubmitButton --
+#
+# Create an HTML submit button that prompts the user with a
+# continue/cancel shutdown warning before the form is submitted.
+#
+# Arguments:
+# name the name of the HTML button object to create.
+# value the label of the HTML button object to create.
+# msg The message to display when the button is pressed.
+#
+# Results:
+# Returns HTML submit button code.
+
+proc ::javascript::makeProtectedSubmitButton {name value msg} {
+ set html ""
+
+ # Create the java script procedure that gives the user the option to cancel
+ # the server shutdown request.
+
+ append html [BeginJS]
+ append html "\nfunction areYouSure${name}(form) \{\n"
+ append html " if (confirm(\"$msg\")) \{\n"
+ append html " return true\n"
+ append html " \} else \{\n"
+ append html " return false\n"
+ append html " \}\n"
+ append html "\}\n"
+ append html [EndJS]
+
+ # Create the HTML submit button.
+
+ append html "<input type=submit name=\"$name\" value=\"$value\"
+ onClick=\"return areYouSure${name}(this.form)\">"
+
+ return $html
+}
+
+# ::javascript::makeMasterButton --
+#
+# Create an HTML button that sets it's slave checkboxs to the boolean
+# value.
+#
+# Arguments:
+# master the name of the child's parent html checkbox object.
+# value the value of the master.
+# slaves the name of child html checkbox object to create.
+# boolean the java script boolean value that will be given to all the
+# slaves. Must be true or false.
+#
+# Results:
+# Returns HTML code to create the child checkbox.
+
+proc ::javascript::makeMasterButton {master value slavePattern boolean} {
+ set html ""
+
+ # Create the java script "checkMaster$name" proc that gets called when the
+ # master checkbox is selected or de-selected.
+
+ append html [BeginJS]
+ append html "\nfunction checkMaster${master}(form) \{\n"
+ append html " for (var i = 0; i < form.elements.length; i++) \{\n"
+ append html " if (form.elements\[i\].name.match('$slavePattern')) \{\n"
+ append html " form.elements\[i\].checked = $boolean \n"
+ append html " \}\n"
+ append html " \}\n"
+
+ append html "\}\n"
+ append html [EndJS]
+
+ # Create the HTML button object.
+
+ append html "<input type=button name=\"$master\" value=\"$value\" " \
+ "onClick=\"checkMaster${master}(this.form)\">\n"
+
+ return $html
+}
+
+# ::javascript::makeParentCheckbox --
+#
+# Create an HTML checkbox and tie its value to that of it's child
+# checkbox. If the parent is unchecked, the child is automatically
+# unchecked.
+#
+# Arguments:
+# parentName the name of parent html checkbox object to create.
+# childName the name of the parent's child html checkbox object
+# Results:
+# Returns HTML code to create the child checkbox.
+
+proc ::javascript::makeParentCheckbox {parentName childName} {
+ set parentObj "form.$parentName"
+ set childObj "form.$childName"
+ set html ""
+
+ # Create the java script "checkParent$name" proc that gets called when the
+ # parent checkbox is selected or de-selected.
+
+ append html [BeginJS]
+ append html "\nfunction checkParent${parentName}(form) \{\n"
+ append html " if (!$parentObj.checked && $childObj.checked) \{\n"
+ append html " $childObj.checked = false\n"
+ append html " \}\n"
+ append html "\}\n"
+ append html [EndJS]
+
+ # Create the HTML checkbox object.
+
+ append html "<input type=checkbox name=$parentName value=1 " \
+ "onClick=\"checkParent${parentName}(this.form)\">"
+
+ return $html
+}
+
+# ::javascript::makeChildCheckbox --
+#
+# Create an HTML checkbox and tie its value to that of it's parent
+# checkbox. If the child is checked, the parent is automatically
+# checked.
+#
+# Arguments:
+# parentName the name of the child's parent html checkbox object
+# childName the name of child html checkbox object to create.
+#
+# Results:
+# Returns HTML code to create the child checkbox.
+
+proc ::javascript::makeChildCheckbox {parentName childName} {
+ set parentObj "form.$parentName"
+ set childObj "form.$childName"
+ set html ""
+
+ # Create the java script "checkChild$name" proc that gets called when the
+ # child checkbox is selected or de-selected.
+
+ append html [BeginJS]
+ append html "\nfunction checkChild${childName}(form) \{\n"
+ append html " if ($childObj.checked && !$parentObj.checked) \{\n"
+ append html " $parentObj.checked = true\n"
+ append html " \}\n"
+ append html "\}\n"
+ append html [EndJS]
+
+ # Create the HTML checkbox object.
+
+ append html "<input type=checkbox name=$childName value=1 " \
+ "onClick=\"checkChild${childName}(this.form)\">"
+
+ return $html
+}
diff --git a/tcllib/modules/javascript/pkgIndex.tcl b/tcllib/modules/javascript/pkgIndex.tcl
new file mode 100644
index 0000000..3387be7
--- /dev/null
+++ b/tcllib/modules/javascript/pkgIndex.tcl
@@ -0,0 +1,4 @@
+# Tcl package index file, version 1.1
+
+if {![package vsatisfies [package provide Tcl] 8]} {return}
+package ifneeded javascript 1.0.2 [list source [file join $dir javascript.tcl]]
diff --git a/tcllib/modules/jpeg/ChangeLog b/tcllib/modules/jpeg/ChangeLog
new file mode 100644
index 0000000..f15eb1c
--- /dev/null
+++ b/tcllib/modules/jpeg/ChangeLog
@@ -0,0 +1,197 @@
+2013-11-07 Andreas Kupries <andreask@activestate.com>
+
+ * testimage/1000.JPG: Ticket [1d2b62d10d] followup.
+ * testimage/1000.exif.txt: Extended testsuite with an
+ * testimage/1000.thumbexif.txt: example image missing the
+ thumbnail and triggering the issue. With thanks to
+ aldo.w.buratti@gmail.com for donating the image.
+
+2013-10-30 Andreas Kupries <andreask@activestate.com>
+
+ * testimage/IMG_7950_dt.JPG: Ticket [1d2b62d10d] followup.
+ * testimage/IMG_7950_dt.exif.txt: Extended testsuite with
+ * testimage/IMG_7950_dt.thumbexif.txt: example image missing any
+ embedded exif information (Not triggering the issue). Made
+ testsuite 8.4+ and converted to tcltest 2 format.
+
+2013-10-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * jpeg.tcl: Ticket [1d2b62d10d]: Fixed unwanted double-close of
+ * jpeg.man: channel when accessing a non-existing thumbnail in a
+ * pkgIndex.tcl: file. Introduced by the refactoring. Bumped
+ version to 0.5. Thanks to Aldo Buratti for the report.
+
+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-05-06 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * jpeg.tcl: Refactored the getExif function into two parts with
+ * pkgIndex.tcl: one that operates on a previously opened
+ * jpeg.man: channel. This means it can be used with other channel
+ * jpeg.test: implementations such as memchan or embedded
+ streams. Updated the documentation and version.
+
+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 ========================
+ *
+
+2009-06-05 Andreas Kupries <andreask@activestate.com>
+
+ * jpeg.tcl (::jpeg::exif): Accepted (with slight changes) and
+ * pkgIndex.tcl: applied patch by Matt Plumlee <mdplumlee@users.sourceforge.net>
+ * jpeg.man: to parse GPS data in the EXIF block. Bumped the
+ package to version 0.3.5. This fixes [Bug 2801896].
+
+ * jpeg.man: Added binary settings to the thumbnail example. This
+ fixes [Bug 2801587].
+
+2009-03-02 Andreas Kupries <andreask@activestate.com>
+
+ * jpeg.tcl (::jpeg::imageInfo): Accepted and applied patch by
+ * pkgIndex.tcl: Mikhail Teterin <kot@users.sourceforge.net> to
+ * jpeg.man: have imageInfo open the image only for reading. Bumped
+ to version 0.3.4. This fixes [Bug 2646568].
+
+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 ========================
+ *
+
+2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * jpeg.pcx: New file. Syntax definitions for the public commands
+ of the jpeg package.
+
+2008-03-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * jpeg.tcl (::jpeg::getExif): Added check to reject bad section
+ * jpeg.man: types outside of {main, thumbnail}. Bumped version to
+ * pkgIndex.tcl: 0.3.3
+
+ * jpeg.test: Added testsuite and example images for it.
+ * testimages/IMG_7898.JPG:
+ * testimages/IMG_7898.JPG.thumb:
+ * testimages/IMG_7898.exif.txt:
+ * testimages/IMG_7898.thumbexif.txt:
+ * testimages/IMG_7917.JPG:
+ * testimages/IMG_7917.JPG.thumb:
+ * testimages/IMG_7917.exif.txt:
+ * testimages/IMG_7917.thumbexif.txt:
+ * testimages/IMG_7950.JPG:
+ * testimages/IMG_7950.JPG.thumb:
+ * testimages/IMG_7950.exif.txt:
+ * testimages/IMG_7950.thumbexif.txt:
+
+2008-1-10 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * jpeg.tcl: fix for bug 1868088 "Integer value too large to
+ represent" in MaxAperture arm of formatExif. Bumped version to
+ 0.3.2
+
+2007-11-20 Andreas Kupries <andreask@activestate.com>
+
+ * jpeg.tcl (::jpeg::stripJPEG): Fixed encoding bug reported by
+ * pkgIndex.tcl: Martin Lemburg on news:clt, and solved by Ohtsuka
+ * jpeg.man: Yoshio. The output file was not set to binary,
+ breaking the jpeg data written to it. Bumped version to 0.3.1.
+
+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>
+
+ * jpeg.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-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * jpeg.man: Bumped version to 0.3
+ * jpeg.tcl:
+ * pkgIndex.tcl:
+
+2005-12-15 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * jpeg.tcl fixed bug in removeComments and removeExif
+ where file was opened and not configured as binary
+
+2005-11-10 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * Added support for non-baseline and progressive files by
+ accepting c0-3 for SOF marker
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-04-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * jpeg.man: Synchronized indexed vs provided versions.
+ * pkgIndex.tcl:
+
+2005-04-01 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * jpeg.tcl: added comments, bumped version number because of
+ potential incompatibility due to inverting the return value
+ of isJPEG.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-10-05 Andreas Kupries <andreask@activestate.com>
+
+ * jpeg.tcl: Accepted last-minute fixes from Aaron in the exif
+ decoder code.
+
+2004-08-16 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * jpeg.tcl: added commands isJPEG, stripJPEG, formatExif, exifKeys
+ * jpeg.man: updated for new commands, new examples
+
+2004-05-26 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * jpeg.tcl: rewritten/factored
+ * jpeg.man: updated
+
+2004-05-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module for querying JPEG images, and manipulating their
+ comments.
diff --git a/tcllib/modules/jpeg/jpeg.man b/tcllib/modules/jpeg/jpeg.man
new file mode 100644
index 0000000..2661cbd
--- /dev/null
+++ b/tcllib/modules/jpeg/jpeg.man
@@ -0,0 +1,196 @@
+[manpage_begin jpeg n 0.5]
+[keywords comment]
+[keywords exif]
+[keywords image]
+[keywords jfif]
+[keywords jpeg]
+[keywords thumbnail]
+[copyright {2004-2005, Code: Aaron Faupell <afaupell@users.sourceforge.net>}]
+[copyright {2007, Code: Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[copyright {2004-2009, Doc: Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[copyright {2011, Code: Pat Thoyts <patthoyts@users.sourceforge.net>}]
+[moddesc {JPEG image manipulation}]
+[titledesc {JPEG querying and manipulation of meta data}]
+[category {File formats}]
+[require Tcl 8.2]
+[require jpeg [opt 0.5]]
+[description]
+[para]
+
+This package provides commands to query and modify JPEG images. JPEG
+stands for [term {Joint Photography Experts Group}] and is a standard
+for the lossy compression of photographical images. It is specified at
+[uri LINK_HERE].
+
+[section COMMANDS]
+[list_begin definitions]
+
+[call [cmd ::jpeg::isJPEG] [arg file]]
+
+Returns a boolean value indicating if [arg file] is a
+JPEG image.
+
+[call [cmd ::jpeg::imageInfo] [arg file]]
+
+Returns a dictionary with keys [const version], [const units],
+[const xdensity], [const ydensity], [const xthumb], and
+[const ythumb]. The values are the associated properties of the JPEG
+image in [arg file].
+
+Throws an error if [arg file] is not a JPEG image.
+
+[call [cmd ::jpeg::dimensions] [arg file]]
+
+Returns the dimensions of the JPEG [arg file] as a list of the
+horizontal and vertical pixel count.
+
+Throws an error if [arg file] is not a JPEG image.
+
+[call [cmd ::jpeg::getThumbnail] [arg file]]
+
+This procedure will return the binary thumbnail image data, if a JPEG
+thumbnail is included in [arg file], and the empty string
+otherwise. Note that it is possible to include thumbnails in formats
+other than JPEG although that is not common. The command finds
+thumbnails that are encoded in either the JFXX or EXIF segments of the
+JPEG information. If both are present the EXIF thumbnail will take precedence.
+
+Throws an error if [arg file] is not a JPEG image.
+
+[example {
+ set fh [open thumbnail.jpg w+]
+ fconfigure $fh -translation binary -encoding binary
+ puts -nonewline $fh [::jpeg::getThumbnail photo.jpg]
+ close $fh
+}]
+
+[call [cmd ::jpeg::getExif] [arg file] [opt [arg section]]]
+
+[arg section] must be one of [const main] or [const thumbnail].
+The default is [const main].
+
+Returns a dictionary containing the EXIF information for the specified section.
+
+For example:
+[para]
+[example {
+ set exif {
+ Make Canon
+ Model {Canon DIGITAL IXUS}
+ DateTime {2001:06:09 15:17:32}
+ }
+}]
+
+Throws an error if [arg file] is not a JPEG image.
+
+[call [cmd ::jpeg::getExifFromChannel] [arg channel] [opt [arg section]]]
+
+This command is as per [cmd ::jpeg::getExif] except that it uses a
+previously opened channel. [arg channel] should be a seekable channel
+and [arg section] is as described in the documentation of
+[cmd ::jpeg::getExif].
+
+[para][emph Note]: The jpeg parser expects that the start of the
+channel is the start of the image data. If working with an image
+embedded in a container file format it may be necessary to read the
+jpeg data into a temporary container: either a temporary file or a
+memory channel.
+
+[para][emph Attention]: It is the resonsibility of the caller to close
+the channel after its use.
+
+
+[call [cmd ::jpeg::formatExif] [arg keys]]
+
+Takes a list of key-value pairs as returned by [cmd getExif] and formats
+many of the values into a more human readable form. As few as one key-value
+may be passed in, the entire exif is not required.
+
+[example {
+ foreach {key val} [::jpeg::formatExif [::jpeg::getExif photo.jpg]] {
+ puts "$key: $val"
+ }
+}]
+[para]
+[example {
+ array set exif [::jpeg::getExif photo.jpg]
+ puts "max f-stop: [::jpeg::formatExif [list MaxAperture $exif(MaxAperture)]]
+}]
+
+[call [cmd ::jpeg::exifKeys]]
+
+Returns a list of the EXIF keys which are currently understood.
+There may be keys present in [cmd getExif] data that are not understood.
+Those keys will appear in a 4 digit hexadecimal format.
+
+[call [cmd ::jpeg::removeExif] [arg file]]
+
+Removes the Exif data segment from the specified file and replaces
+it with a standard JFIF segment.
+
+Throws an error if [arg file] is not a JPEG image.
+
+[call [cmd ::jpeg::stripJPEG] [arg file]]
+
+Removes all metadata from the JPEG file leaving only
+the image. This includes comments, EXIF segments, JFXX
+segments, and application specific segments.
+
+Throws an error if [arg file] is not a JPEG image.
+
+[call [cmd ::jpeg::getComments] [arg file]]
+
+Returns a list containing all the JPEG comments found in
+the [arg file].
+
+Throws an error if [arg file] is not a valid JPEG image.
+
+[call [cmd ::jpeg::addComment] [arg file] [arg text]...]
+
+Adds one or more plain [arg text] comments to the JPEG image
+in [arg file].
+
+Throws an error if [arg file] is not a valid JPEG image.
+
+[call [cmd ::jpeg::removeComments] [arg file]]
+
+Removes all comments from the file specified.
+
+Throws an error if [arg file] is not a valid JPEG image.
+
+[call [cmd ::jpeg::replaceComment] [arg file] [arg text]]
+
+Replaces the first comment in the file with the new [arg text].
+This is merely a shortcut for [cmd ::jpeg::removeComments]
+and [cmd ::jpeg::addComment]
+
+Throws an error if [arg file] is not a valid JPEG image.
+
+[call [cmd ::jpeg::debug] [arg file]]
+
+Prints everything we know about the given file in a nice format.
+
+[call [cmd ::jpeg::markers] [arg channel]]
+
+This is an internal helper command, we document it for use by advanced
+users of the package. The argument [arg channel] is an open file
+handle positioned at the start of the first marker (usually 2
+bytes). The command returns a list with one element for each JFIF
+marker found in the file. Each element consists of a list of the
+marker name, its offset in the file, and its length. The offset points
+to the beginning of the sections data, not the marker itself. The
+length is the length of the data from the offset listed to the start
+of the next marker.
+
+[list_end]
+
+[section LIMITATIONS]
+
+can only work with files
+cant write exif data
+gps exif data not parsed
+makernote data not yet implemented
+
+[vset CATEGORY jpeg]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/jpeg/jpeg.pcx b/tcllib/modules/jpeg/jpeg.pcx
new file mode 100644
index 0000000..4b626c1
--- /dev/null
+++ b/tcllib/modules/jpeg/jpeg.pcx
@@ -0,0 +1,83 @@
+# -*- tcl -*- jpeg.pcx
+# Syntax of the commands provided by package jpeg.
+#
+# 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 jpeg
+pcx::tcldep 0.3.2 needs tcl 8.2
+
+namespace eval ::jpeg {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 0.3.2 std ::jpeg::addComment \
+ {checkSimpleArgs 2 -1 {
+ checkFileName
+ checkWord
+ }}
+pcx::check 0.3.2 std ::jpeg::debug \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+pcx::check 0.3.2 std ::jpeg::dimensions \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+pcx::check 0.3.2 std ::jpeg::exifKeys \
+ {checkSimpleArgs 0 0 {}}
+pcx::check 0.3.2 std ::jpeg::formatExif \
+ {checkSimpleArgs 1 1 {
+ checkDict
+ }}
+pcx::check 0.3.2 std ::jpeg::getComments \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+pcx::check 0.3.2 std ::jpeg::getExif \
+ {checkSimpleArgs 1 2 {
+ checkFileName
+ {checkKeyword 1 {main thumbnail}}
+ }}
+pcx::check 0.3.2 std ::jpeg::getThumbnail \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+pcx::check 0.3.2 std ::jpeg::imageInfo \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+pcx::check 0.3.2 std ::jpeg::isJPEG \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+pcx::check 0.3.2 std ::jpeg::markers \
+ {checkSimpleArgs 1 1 {
+ checkChannelID
+ }}
+pcx::check 0.3.2 std ::jpeg::removeComments \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+pcx::check 0.3.2 std ::jpeg::removeExif \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+pcx::check 0.3.2 std ::jpeg::replaceComment \
+ {checkSimpleArgs 2 2 {
+ checkFileName
+ checkWord
+ }}
+pcx::check 0.3.2 std ::jpeg::stripJPEG \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+
+# Initialization via pcx::init.
+# Use a ::jpeg::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/jpeg/jpeg.tcl b/tcllib/modules/jpeg/jpeg.tcl
new file mode 100644
index 0000000..0c37f90
--- /dev/null
+++ b/tcllib/modules/jpeg/jpeg.tcl
@@ -0,0 +1,1125 @@
+# jpeg.tcl --
+#
+# Querying and modifying JPEG image files.
+#
+# Copyright (c) 2004 Aaron Faupell <afaupell@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: jpeg.tcl,v 1.19 2011/05/06 13:39:27 patthoyts Exp $
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+namespace eval ::jpeg {}
+
+# ### ### ### ######### ######### #########
+## Notes :: Structure of jpeg files.
+
+# Base types
+#
+# BYTE = 1 byte
+# SHORT = 2 bytes, endianess determined by context.
+# BESHORT = 2 bytes, big endian
+# INT = 4 bytes, endianess determined by context.
+
+# JPEG types
+#
+# JPEG = <
+# BYTE [2] == 0xFF 0xD8 (SOI (Start Of Image))
+# JSEGMENT [.] 1 or more jpeg segments, variadic size
+# BYTE [2] == 0xFF 0xD9 (EOI (End Of Image))
+# >
+#
+# JSEGMENT = <
+# BYTE [1] == 0xFF
+# BYTE [1] Segment Tag, type marker
+# BESHORT [1] Segment Length N
+# BYTE [N-2] Segment Data, interpreted dependent on tag.
+# >
+#
+# Notable segments, and their structure.
+#
+# Comment = JSEGMENT (Tag = 0xFE, Data = <
+#
+# >)
+
+
+# Type 0xFE (Comment)
+# Data BYTE [ ]
+# Note: Multiple comment segments are allowed.
+
+# Type 0xC0/0xC1/0xC2/0xC3 (Start of Frame)
+# Data BYTE [1] Precision
+# BESHORT [1] Height
+# BESHORT [1] Width
+# BYTE [1] Number of color components
+# ...
+
+# Type 0xEx (x=0-9A-F) (App0 - App15)
+# Data It is expected that the data starts with a checkable marker, as
+# the app segments can be used by multiple applications for
+# different purposes. I.e. a sub-type is needed before the
+# segment data can be processed.
+
+# App0/JFIF image info
+# Type 0xE0
+# Data BYTE [5] 'JFIF\0' JFIF sub-type marker
+# BYTE [1] Version1 (major)
+# BYTE [1] Version2 (minor)
+# BYTE [1] Units
+# BESHORT [1] X-density (dots per inch ?)
+# BESHORT [1] Y-density
+# BYTE [1] X-thumb (Width of thumbnail, if any, or zero)
+# BYTE [1] Y-thumb (Height of thumbnail, if any, or zero)
+
+# App0/JFXX extended image information
+# Type 0xE0
+# Data BYTE [5] 'JFXX\0' JFXX sub-type marker
+# BYTE [1] Extension code 10 -> JPEG thumbnail
+# 11 -> Palletized thumbnail
+# 13 -> RGB thumbnail
+# BYTE [ ] Data per the extension code.
+
+# App1/EXIF
+# Type 0xE1
+# Data BYTE [6] 'Exif\0\0' EXIF sub-type marker. (1)
+# BYTE [2] Byte Order 0x4d 0x4d = big endian
+# or 0x49 0x49 = small endian
+# SHORT [1] Magic == 42 under the specified byteorder.
+# INT [1] Next == Offset to the first actual EXIF data block.
+#
+# EXIF data block structure (IFD = Image File Directory)
+#
+# 1. SHORT [1] Number N of exif entries
+# 2. ENTRY [N] Array of exif entries
+# 3. INT [1] Offset to the next EXIF data block, or <0 for the last block.
+#
+
+# exif ENTRY structure
+#
+# 1. SHORT [1] num
+# 2. SHORT [1] tag = exif key
+# 3. SHORT [1] format
+# 4. INT [1] component
+# 5. INT [1] value
+
+# The 'value is interpreted dependent on the values of tag, format,
+# and component.
+#
+# A. Tag in ( 0x8769, 0xA005 )
+# Value is offset to a subordinate exif data block, process recursively.
+# B. Size = components * sizeof(format)
+# B1. Size > 4
+# Value is offset to the actual value.
+# B2. Size <= 4
+# Value is the actual value.
+
+# Usually a jpeg with exif information has two exif data blocks. The
+# first is the main block, the second the thumbnail block.
+#
+# Note that all the exif data structures are within the app1/exif
+# segment.
+#
+# (1) The offset of the first byte after the exif marker is what all
+# the offsets in exif are relative to.
+
+# Type 0xDA (SOS, Start of Stream/Scan)
+# Followed by the JPEG data. Last segment before EOI
+
+# ### ### ### ######### ######### #########
+
+# open a file, check jpeg signature, and a return a file handle
+# at the start of the first marker
+proc ::jpeg::openJFIF {file {mode r}} {
+ set fh [open $file $mode]
+ fconfigure $fh -encoding binary -translation binary -eofchar {}
+ # jpeg sig is FFD8, FF is start of first marker
+ if {[read $fh 3] != "\xFF\xD8\xFF"} { close $fh; return -code error "not a jpg file" }
+ # rewind to first marker
+ seek $fh -1 current
+ return $fh
+}
+
+# return a boolean indicating if a file starts with the jpeg sig
+proc ::jpeg::isJPEG {file} {
+ set is [catch {openJFIF $file} fh]
+ catch {close $fh}
+ return [expr {!$is}]
+}
+
+# takes an open filehandle at the start of a jpeg marker, and returns a list
+# containing information about the file markers in the jpeg file. each list
+# element itself a list of the marker type, offset of the start of its data,
+# and the length of its data.
+proc ::jpeg::markers {fh} {
+ set chunks [list]
+ while {[read $fh 1] == "\xFF"} {
+ binary scan [read $fh 3] H2S type len
+ # convert to unsigned
+ set len [expr {$len & 0x0000FFFF}]
+ # decrement len to account for marker bytes
+ incr len -2
+ lappend chunks [list $type [tell $fh] $len]
+ seek $fh $len current
+ }
+ # chunks = list (list (type offset length) ...)
+ return $chunks
+}
+
+proc ::jpeg::imageInfo {file} {
+ set fh [openJFIF $file r]
+ set data {}
+ if {[set app0 [lsearch -inline [markers $fh] "e0 *"]] != ""} {
+ seek $fh [lindex $app0 1] start
+ set id [read $fh 5]
+ if {$id == "JFIF\x00"} {
+ binary scan [read $fh 9] cccSScc ver1 ver2 units xr yr xt yt
+ set data [list version $ver1.$ver2 units $units xdensity $xr ydensity $yr xthumb $xt ythumb $yt]
+ }
+ }
+ close $fh
+ return $data
+}
+
+# return an images dimensions by reading the Start Of Frame marker
+proc ::jpeg::dimensions {file} {
+ set fh [openJFIF $file]
+ set sof [lsearch -inline [markers $fh] {c[0-3] *}]
+ seek $fh [lindex $sof 1] start
+ binary scan [read $fh 5] cSS precision height width
+ close $fh
+ return [list $width $height]
+}
+
+# returns a list of all comments (FE segments) in the file
+proc ::jpeg::getComments {file} {
+ set fh [openJFIF $file]
+ set comments {}
+ foreach x [lsearch -all -inline [markers $fh] "fe *"] {
+ seek $fh [lindex $x 1] start
+ lappend comments [read $fh [lindex $x 2]]
+ }
+ close $fh
+ return $comments
+}
+
+# add a new comment to the file
+proc ::jpeg::addComment {file comment args} {
+ set fh [openJFIF $file r+]
+ # find the SoF and save all data after it
+ set sof [lsearch -inline [markers $fh] {c[0-3] *}]
+ seek $fh [expr {[lindex $sof 1] - 4}] start
+ set data2 [read $fh]
+ # seek back to the SoF and write comment(s) segment
+ seek $fh [expr {[lindex $sof 1] - 4}] start
+ foreach x [linsert $args 0 $comment] {
+ if {$x == ""} continue
+ puts -nonewline $fh [binary format a2Sa* "\xFF\xFE" [expr {[string length $x] + 2}] $x]
+ }
+ # write the saved data bac
+ puts -nonewline $fh $data2
+ close $fh
+}
+
+proc ::jpeg::replaceComment {file comment} {
+ set com [getComments $file]
+ removeComments $file
+ eval [list addComment $file] [lreplace $com 0 0 $comment]
+}
+
+# removes all comment segments from the file
+proc ::jpeg::removeComments {file} {
+ set fh [openJFIF $file]
+ set data "\xFF\xD8"
+ foreach marker [markers $fh] {
+ if {[lindex $marker 0] != "fe"} {
+ # seek back 4 bytes to include the marker and length bytes
+ seek $fh [expr {[lindex $marker 1] - 4}] start
+ append data [read $fh [expr {[lindex $marker 2] + 4}]]
+ }
+ }
+ append data [read $fh]
+ close $fh
+ set fh [open $file w]
+ fconfigure $fh -encoding binary -translation binary -eofchar {}
+ puts -nonewline $fh $data
+ close $fh
+}
+
+# rewrites a jpeg file and removes all metadata (comments, exif, photoshop)
+proc ::jpeg::stripJPEG {file} {
+ set fh [openJFIF $file]
+ set data {}
+
+ set markers [markers $fh]
+ # look for a jfif header segment and save it
+ if {[lindex $markers 0 0] == "e0"} {
+ seek $fh [lindex $markers 0 1] start
+ if {[read $fh 5] == "JFIF\x00"} {
+ seek $fh -9 current
+ set jfif [read $fh [expr {[lindex $markers 0 2] + 4}]]
+ }
+ }
+ # if we dont have a jfif header (exif files), create a fake one
+ if {![info exists jfif]} {
+ set jfif [binary format a2Sa5cccSScc "\xFF\xE0" 16 "JFIF\x00" 1 2 1 72 72 0 0]
+ }
+
+ # remove all the e* and f* markers (metadata)
+ foreach marker $markers {
+ if {![string match {[ef]*} [lindex $marker 0]]} {
+ seek $fh [expr {[lindex $marker 1] - 4}] start
+ append data [read $fh [expr {[lindex $marker 2] + 4}]]
+ }
+ }
+ append data [read $fh]
+
+ close $fh
+ set fh [open $file w+]
+ fconfigure $fh -encoding binary -translation binary -eofchar {}
+ # write a jpeg file sig, a jfif header, and all the remaining data
+ puts -nonewline $fh \xFF\xD8$jfif$data
+ close $fh
+}
+
+# if file contains a jpeg thumbnail return it. the returned data is the actual
+# jpeg data, it can be written directly to a file
+proc ::jpeg::getThumbnail {file} {
+ # check if the exif information contains a thumbnail
+ array set exif [getExif $file thumbnail]
+ if {[info exists exif(Compression)] && \
+ $exif(Compression) == 6 && \
+ [info exists exif(JPEGInterchangeFormat)] && \
+ [info exists exif(JPEGInterchangeFormatLength)]} {
+ set fh [openJFIF $file]
+ seek $fh [expr {$exif(ExifOffset) + $exif(JPEGInterchangeFormat)}] start
+ set thumb [read $fh $exif(JPEGInterchangeFormatLength)]
+ close $fh
+ return $thumb
+ }
+ # check for a JFXX segment which contains a thumbnail
+ set fh [openJFIF $file]
+ foreach x [lsearch -inline -all [markers $fh] "e0 *"] {
+ seek $fh [lindex $x 1] start
+ binary scan [read $fh 6] a5H2 id excode
+ # excode 10 is jpeg encoding, we cant interpret the other types
+ if {$id == "JFXX\x00" && $excode == "10"} {
+ set thumb [read $fh [expr {[lindex $x 2] - 6}]]
+ close $fh
+ return $thumb
+ }
+ }
+ close $fh
+}
+
+
+# takes key-value pairs returned by getExif and converts their values into
+# human readable format
+proc ::jpeg::formatExif {exif} {
+ variable exif_values
+ set out {}
+ foreach {tag val} $exif {
+ if {[info exists exif_values($tag,$val)]} {
+ set val $exif_values($tag,$val)
+ } elseif {[info exists exif_values($tag,)]} {
+ set val $exif_values($tag,)
+ } else {
+ switch -exact -- $tag {
+ UserComment {set val [string trim [string range $val 8 end] \x00]}
+ ComponentsConfiguration {binary scan $val cccc a b c d; set val $a,$b,$c,$d}
+ ExifVersion {set val [expr [string range $val 0 1].[string range $val 2 3]]}
+ FNumber {set val [format %2.1f $val]}
+ MaxApertureValue -
+ ApertureValue {
+ if {$val > 0} {
+ set val [format %2.1f [expr {2 * (log($val) / log(2))}]]
+ }
+ }
+ ShutterSpeedValue {
+ set val [expr {pow(2, $val)}]
+ if {abs(round($val) - $val) < 0.2} {set val [expr {round($val)}]}
+ set val 1/[string trimright [string trimright [format %.2f $val] 0] .]
+ }
+ ExposureTime {
+ set val 1/[string trimright [string trimright [format %.4f [expr {1 / $val}]] 0] .]
+ }
+ }
+ }
+ lappend out $tag $val
+ }
+ return $out
+}
+
+# returns a list of all known exif keys
+proc ::jpeg::exifKeys {} {
+ variable exif_tags
+ set ret {}
+ foreach {x y} [array get exif_tags] {lappend ret $y}
+ return $ret
+}
+
+proc ::jpeg::getExif {file {type main}} {
+ set fh [openJFIF $file]
+ set r [catch {getExifFromChannel $fh $type} err]
+ close $fh
+ return -code $r $err
+}
+
+proc ::jpeg::getExifFromChannel {chan {type main}} {
+ # foreach because file may have multiple e1 markers
+ foreach app1 [lsearch -inline -all [markers $chan] "e1 *"] {
+ seek $chan [lindex $app1 1] start
+ # check that this e1 is really an Exif segment
+ if {[read $chan 6] != "Exif\x00\x00"} continue
+ # save offset because exif offsets are relative to this
+ set start [tell $chan]
+ # next 2 bytes determine byte order
+ binary scan [read $chan 2] H4 byteOrder
+ if {$byteOrder == "4d4d"} {
+ set byteOrder big
+ } elseif {$byteOrder == "4949"} {
+ set byteOrder little
+ } else {
+ return -code error "invalid byte order magic"
+ }
+ # the answer is 42, if we have our byte order correct
+ _scan $byteOrder [read $chan 6] si magic next
+ if {$magic != 42} { return -code error "invalid byte order"}
+
+ seek $chan [expr {$start + $next}] start
+ if {$type != "thumbnail"} {
+ if {$type != "main"} {
+ return -code error "Bad type \"$type\", expected one of \"main\", or \"thumbnail\""
+ }
+ set data [_exif $chan $byteOrder $start]
+ } else {
+ # number of entries in this exif block
+ _scan $byteOrder [read $chan 2] s num
+ # each entry is 12 bytes
+ seek $chan [expr {$num * 12}] current
+ # offset of next exif block (for thumbnail)
+ _scan $byteOrder [read $chan 4] i next
+ if {$next <= 0} { return }
+ # but its relative to start
+ seek $chan [expr {$start + $next}] start
+ set data [_exif $chan $byteOrder $start]
+ }
+ lappend data ExifOffset $start ExifByteOrder $byteOrder
+ return $data
+ }
+ return
+}
+
+proc ::jpeg::removeExif {file} {
+ set fh [openJFIF $file]
+ set data {}
+ set markers [markers $fh]
+ if {[lsearch $markers "e1 *"] < 0} { close $fh; return }
+ foreach marker $markers {
+ if {[lindex $marker 0] != "e1"} {
+ seek $fh [expr {[lindex $marker 1] - 4}] start
+ append data [read $fh [expr {[lindex $marker 2] + 4}]]
+ } else {
+ seek $fh [lindex $marker 1] start
+ if {[read $fh 6] == "Exif\x00\x00"} continue
+ seek $fh -10 current
+ append data [read $fh [expr {[lindex $marker 2] + 4}]]
+ }
+ }
+ append data [read $fh]
+ close $fh
+ set fh [open $file w]
+ fconfigure $fh -encoding binary -translation binary -eofchar {}
+ puts -nonewline $fh "\xFF\xD8"
+ if {[lindex $markers 0 0] != "e0"} {
+ puts -nonewline $fh [binary format a2Sa5cccSScc "\xFF\xE0" 16 "JFIF\x00" 1 2 1 72 72 0 0]
+ }
+ puts -nonewline $fh $data
+ close $fh
+}
+
+proc ::jpeg::_exif2 {data} {
+ variable exif_tags
+ set byteOrder little
+ set start 0
+ set i 2
+ for {_scan $byteOrder $data @0s num} {$num > 0} {incr num -1} {
+ binary scan $data @${i}H2H2 t1 t2
+ if {$byteOrder == "big"} {
+ set tag $t1$t2
+ } else {
+ set tag $t2$t1
+ }
+ incr i 2
+ _scan $byteOrder $data @${i}si format components
+ incr i 6
+ set value [string range $data $i [expr {$i + 3}]]
+ if {$tag == "8769" || $tag == "a005"} {
+ _scan $byteOrder $value i next
+ #set pos [tell $fh]
+ #seek $fh [expr {$offset + $next}] start
+ #eval lappend return [_exif $fh $byteOrder $offset]
+ #seek $fh $pos start
+ continue
+ }
+ if {![info exists exif_formats($format)]} continue
+ if {[info exists exif_tags($tag)]} { set tag $exif_tags($tag) }
+ set size [expr {$exif_formats($format) * $components}]
+ if {$size > 4} {
+ _scan $byteOrder $value i value
+ #puts "$value"
+ #set value [string range $data [expr {$i + $offset + $value}] [expr {$size - 1}]]
+ }
+ lappend ret $tag [_format $byteOrder $value $format $components]
+ }
+}
+
+# reads an exif block and returns key-value pairs
+proc ::jpeg::_exif {fh byteOrder offset {tag_info exif_tags}} {
+ variable exif_formats
+ variable exif_tags
+ variable gps_tags
+ set return {}
+ for {_scan $byteOrder [read $fh 2] s num} {$num > 0} {incr num -1} {
+ binary scan [read $fh 2] H2H2 t1 t2
+ _scan $byteOrder [read $fh 6] si format components
+ if {$byteOrder == "big"} {
+ set tag $t1$t2
+ } else {
+ set tag $t2$t1
+ }
+ set value [read $fh 4]
+ # special tags, they point to more exif blocks
+ if {$tag == "8769" || $tag == "a005"} {
+ _scan $byteOrder $value i next
+ set pos [tell $fh]
+ seek $fh [expr {$offset + $next}] start
+ eval lappend return [_exif $fh $byteOrder $offset]
+ seek $fh $pos start
+ continue
+ }
+ # special tag, another exif block holding GPS/location information.
+ if {$tag == "8825"} {
+ _scan $byteOrder $value i next
+ set pos [tell $fh]
+ seek $fh [expr {$offset + $next}] start
+ eval lappend return [_exif $fh $byteOrder $offset gps_tags]
+ seek $fh $pos start
+ continue
+ }
+ if {![info exists exif_formats($format)]} continue
+ upvar 0 $tag_info thetags
+ if {[info exists thetags($tag)]} { set tag $thetags($tag) }
+ set size [expr {$exif_formats($format) * $components}]
+ # if the data is over 4 bytes, its stored later in the file, with the
+ # data being the offset relative to the exif header
+ if {$size > 4} {
+ set pos [tell $fh]
+ _scan $byteOrder $value i value
+ seek $fh [expr {$offset + $value}] start
+ set value [read $fh $size]
+ seek $fh $pos start
+ }
+ lappend return $tag [_format $byteOrder $value $format $components]
+ }
+ return $return
+}
+
+proc ::jpeg::MakerNote {offset byteOrder Make data} {
+ if {$Make == "Canon"} {
+ set data [MakerNoteCanon $offset $byteOrder $data]
+ } elseif {[string match Nikon* $data] || $Make == "NIKON"} {
+ set data [MakerNoteNikon $offset $byteOrder $data]
+ } elseif {[string match FUJIFILM* $data]} {
+ set data [MakerNoteFuji $offset $byteOrder $data]
+ } elseif {[string match OLYMP* $data]} {
+ set data [MakerNoteOlympus $offset $byteOrder $data]
+ }
+ return $data
+}
+
+proc ::jpeg::MakerNoteNikon {offset byteOrder data} {
+ variable exif_formats
+ set return {}
+ if {[string match Nikon* $data]} {
+ set i 8
+ } else {
+ set i 0
+ }
+ binary scan $data @8s num
+ incr i 2
+ puts [expr {($num * 12) + $i}]
+ puts [string range $data 142 150]
+ #exit
+ for {} {$num > 0} {incr num -1} {
+ binary scan $data @${i}H2H2 t1 t2
+ if {$byteOrder == "big"} {
+ set tag $t1$t2
+ } else {
+ set tag $t2$t1
+ }
+ incr i 2
+ _scan $byteOrder $data @${i}si format components
+ incr i 6
+ set value [string range $data $i [expr {$i + 3}]]
+ if {![info exists exif_formats($format)]} continue
+ #if {[info exists exif_tags($tag)]} { set tag $exif_tags($tag) }
+ set size [expr {$exif_formats($format) * $components}]
+ if {$size > 4} {
+ _scan $byteOrder $value i value
+ puts "$value"
+ set value 1
+ #set value [string range $data [expr {$i + $offset + $value}] [expr {$size - 1}]]
+ } else {
+
+ lappend ret $tag [_format $byteOrder $value $format $components]
+ }
+ puts "$tag $format $components $value"
+ }
+ return $return
+}
+
+proc ::jpeg::debug {file} {
+ set fh [openJFIF $file]
+
+ puts "marker: d8 length: 0"
+ puts " SOI (Start Of Image)"
+
+ foreach marker [markers $fh] {
+ seek $fh [lindex $marker 1]
+ puts "marker: [lindex $marker 0] length: [lindex $marker 2]"
+ switch -glob -- [lindex $marker 0] {
+ c[0-3] {
+ binary scan [read $fh 6] cSSc precision height width color
+ puts " SOF (Start Of Frame) [string map {c0 "Baseline" c1 "Non-baseline" c2 "Progressive" c3 "Lossless"} [lindex $marker 0]]"
+ puts " Image dimensions: $width $height"
+ puts " Precision: $precision"
+ puts " Color Components: $color"
+ }
+ c4 {
+ puts " DHT (Define Huffman Table)"
+ binary scan [read $fh 17] cS bits symbols
+ puts " $symbols symbols"
+ }
+ da {
+ puts " SOS (Start Of Scan)"
+ binary scan [read $fh 2] c num
+ puts " Components: $num"
+ }
+ db {
+ puts " DQT (Define Quantization Table)"
+ }
+ dd {
+ puts " DRI (Define Restart Interval)"
+ binary scan [read $fh 2] S num
+ puts " Interval: $num blocks"
+ }
+ e0 {
+ set id [read $fh 5]
+ if {$id == "JFIF\x00"} {
+ puts " JFIF"
+ binary scan [read $fh 9] cccSScc ver1 ver2 units xr vr xt yt
+ puts " Header: $ver1.$ver2 $units $xr $vr $xt $yt"
+ } elseif {$id == "JFXX\x00"} {
+ puts " JFXX (JFIF Extension)"
+ binary scan [read $fh 1] H2 excode
+ if {$excode == "10"} { set excode "10 (JPEG thumbnail)" }
+ if {$excode == "11"} { set excode "11 (Palletized thumbnail)" }
+ if {$excode == "13"} { set excode "13 (RGB thumbnail)" }
+ puts " Extension code: 0x$excode"
+ } else {
+ puts " Unknown APP0 segment: $id"
+ }
+ }
+ e1 {
+ if {[read $fh 6] == "Exif\x00\x00"} {
+ puts " EXIF data"
+ puts " MAIN EXIF"
+ foreach {x y} [getExif $file] {
+ puts " $x $y"
+ }
+ puts " THUMBNAIL EXIF"
+ foreach {x y} [getExif $file thumbnail] {
+ puts " $x $y"
+ }
+ } else {
+ puts " APP1 (unknown)"
+ }
+ }
+ e2 {
+ if {[read $fh 12] == "ICC_PROFILE\x00"} {
+ puts " ICC profile"
+ } else {
+ puts " APP2 (unknown)"
+ }
+ }
+ ed {
+ if {[read $fh 18] == "Photoshop 3.0\0008BIM"} {
+ puts " Photoshop 8BIM data"
+ } else {
+ puts " APP13 (unknown)"
+ }
+ }
+ ee {
+ if {[read $fh 5] == "Adobe"} {
+ puts " Adobe metadata"
+ } else {
+ puts " APP14 (unknown)"
+ }
+ }
+ e[3456789abcf] {
+ puts [format " %s%d %s" APP 0x[string index [lindex $marker 0] 1] (unknown)]
+ }
+ fe {
+ puts " Comment: [read $fh [lindex $marker 2]]"
+ }
+ default {
+ puts " Unknown"
+ }
+ }
+ }
+}
+
+# for mapping the exif format types to byte lengths
+array set ::jpeg::exif_formats [list 1 1 2 1 3 2 4 4 5 8 6 1 7 1 8 2 9 4 10 8 11 4 12 8]
+
+# list of recognized exif tags. if a tag is not listed here it will show up as its raw hex value
+array set ::jpeg::exif_tags {
+ 0100 ImageWidth
+ 0101 ImageLength
+ 0102 BitsPerSample
+ 0103 Compression
+ 0106 PhotometricInterpretation
+ 0112 Orientation
+ 0115 SamplesPerPixel
+ 011c PlanarConfiguration
+ 0212 YCbCrSubSampling
+ 0213 YCbCrPositioning
+ 011a XResolution
+ 011b YResolution
+ 0128 ResolutionUnit
+
+ 0111 StripOffsets
+ 0116 RowsPerStrip
+ 0117 StripByteCounts
+ 0201 JPEGInterchangeFormat
+ 0202 JPEGInterchangeFormatLength
+
+ 012d TransferFunction
+ 013e WhitePoint
+ 013f PrimaryChromaticities
+ 0211 YCbCrCoefficients
+ 0213 YCbCrPositioning
+ 0214 ReferenceBlackWhite
+
+ 0132 DateTime
+ 010e ImageDescription
+ 010f Make
+ 0110 Model
+ 0131 Software
+ 013b Artist
+ 8298 Copyright
+
+ 9000 ExifVersion
+ a000 FlashpixVersion
+
+ a001 ColorSpace
+
+ 9101 ComponentsConfiguration
+ 9102 CompressedBitsPerPixel
+ a002 ExifImageWidth
+ a003 ExifImageHeight
+
+ 927c MakerNote
+ 9286 UserComment
+
+ a004 RelatedSoundFile
+
+ 9003 DateTimeOriginal
+ 9004 DateTimeDigitized
+ 9290 SubsecTime
+ 9291 SubsecTimeOriginal
+ 9292 SubsecTimeDigitized
+
+ 829a ExposureTime
+ 829d FNumber
+ 8822 ExposureProgram
+ 8824 SpectralSensitivity
+ 8827 ISOSpeedRatings
+ 8828 OECF
+ 9201 ShutterSpeedValue
+ 9202 ApertureValue
+ 9203 BrightnessValue
+ 9204 ExposureBiasValue
+ 9205 MaxApertureValue
+ 9206 SubjectDistance
+ 9207 MeteringMode
+ 9208 LightSource
+ 9209 Flash
+ 920a FocalLength
+ 9214 SubjectArea
+ a20b FlashEnergy
+ a20c SpatialFrequencyResponse
+ a20e FocalPlaneXResolution
+ a20f FocalPlaneYResolution
+ a210 FocalPlaneResolutionUnit
+ a214 SubjectLocation
+ a215 ExposureIndex
+ a217 SensingMethod
+ a300 FileSource
+ a301 SceneType
+ a302 CFAPattern
+ a401 CustomRendered
+ a402 ExposureMode
+ a403 WhiteBalance
+ a404 DigitalZoomRatio
+ a405 FocalLengthIn35mmFilm
+ a406 SceneCaptureType
+ a407 GainControl
+ a408 Contrast
+ a409 Saturation
+ a40a Sharpness
+ a40b DeviceSettingDescription
+ a40c SubjectDistanceRange
+ a420 ImageUniqueID
+
+
+ 0001 InteroperabilityIndex
+ 0002 InteroperabilityVersion
+ 1000 RelatedImageFileFormat
+ 1001 RelatedImageWidth
+ 1002 RelatedImageLength
+
+ 00fe NewSubfileType
+ 00ff SubfileType
+ 013d Predictor
+ 0142 TileWidth
+ 0143 TileLength
+ 0144 TileOffsets
+ 0145 TileByteCounts
+ 014a SubIFDs
+ 015b JPEGTables
+ 828d CFARepeatPatternDim
+ 828e CFAPattern
+ 828f BatteryLevel
+ 83bb IPTC/NAA
+ 8773 InterColorProfile
+ 8825 GPSInfo
+ 8829 Interlace
+ 882a TimeZoneOffset
+ 882b SelfTimerMode
+ 920c SpatialFrequencyResponse
+ 920d Noise
+ 9211 ImageNumber
+ 9212 SecurityClassification
+ 9213 ImageHistory
+ 9215 ExposureIndex
+ 9216 TIFF/EPStandardID
+}
+
+# list of recognized exif tags for the GPSInfo section--added by mdp 6/5/2009
+array set ::jpeg::gps_tags {
+ 0000 GPSVersionID
+ 0001 GPSLatitudeRef
+ 0002 GPSLatitude
+ 0003 GPSLongitudeRef
+ 0004 GPSLongitude
+ 0005 GPSAltitudeRef
+ 0006 GPSAltitude
+ 0007 GPSTimeStamp
+ 0008 GPSSatellites
+ 0009 GPSStatus
+ 000a GPSMeasureMode
+ 000b GPSDOP
+ 000c GPSSpeedRef
+ 000d GPSSpeed
+ 000e GPSTrackRef
+ 000f GPSTrack
+ 0010 GPSImgDirectionRef
+ 0011 GPSImgDirection
+ 0012 GPSMapDatum
+ 0013 GPSDestLatitudeRef
+ 0014 GPSDestLatitude
+ 0015 GPSDestLongitudeRef
+ 0016 GPSDestLongitude
+ 0017 GPSDestBearingRef
+ 0018 GPSDestBearing
+ 0019 GPSDestDistanceRef
+ 001a GPSDestDistance
+ 001b GPSProcessingMethod
+ 001c GPSAreaInformation
+ 001d GPSDateStamp
+ 001e GPSDifferential
+}
+
+# for mapping exif values to plain english by [formatExif]
+array set ::jpeg::exif_values {
+ Compression,1 none
+ Compression,6 JPEG
+ Compression, unknown
+
+ PhotometricInterpretation,2 RGB
+ PhotometricInterpretation,6 YCbCr
+ PhotometricInterpretation, unknown
+
+ Orientation,1 normal
+ Orientation,2 mirrored
+ Orientation,3 "180 degrees"
+ Orientation,4 "180 degrees, mirrored"
+ Orientation,5 "90 degrees ccw, mirrored"
+ Orientation,6 "90 degrees cw"
+ Orientation,7 "90 degrees cw, mirrored"
+ Orientation,8 "90 degrees ccw"
+ Orientation, unknown
+
+ PlanarConfiguration,1 chunky
+ PlanarConfiguration,2 planar
+ PlanarConfiguration, unknown
+
+ YCbCrSubSampling,2,1 YCbCr4:2:2
+ YCbCrSubSampling,2,2 YCbCr4:2:0
+ YCbCrSubSampling, unknown
+
+ YCbCrPositioning,1 centered
+ YCbCrPositioning,2 co-sited
+ YCbCrPositioning, unknown
+
+ FlashpixVersion,0100 "Flashpix Format Version 1.0"
+ FlashpixVersion, unknown
+
+ ColorSpace,1 sRGB
+ ColorSpace,32768 uncalibrated
+ ColorSpace, unknown
+
+ ExposureProgram,0 undefined
+ ExposureProgram,1 manual
+ ExposureProgram,2 normal
+ ExposureProgram,3 "aperture priority"
+ ExposureProgram,4 "shutter priority"
+ ExposureProgram,5 creative
+ ExposureProgram,6 action
+ ExposureProgram,7 portrait
+ ExposureProgram,8 landscape
+ ExposureProgram, unknown
+
+ LightSource,0 unknown
+ LightSource,1 daylight
+ LightSource,2 flourescent
+ LightSource,3 tungsten
+ LightSource,4 flash
+ LightSource,9 "fine weather"
+ LightSource,10 "cloudy weather"
+ LightSource,11 shade
+ LightSource,12 "daylight flourescent"
+ LightSource,13 "day white flourescent"
+ LightSource,14 "cool white flourescent"
+ LightSource,15 "white flourescent"
+ LightSource,17 "standard light A"
+ LightSource,18 "standard light B"
+ LightSource,19 "standard light C"
+ LightSource,20 D55
+ LightSource,21 D65
+ LightSource,22 D75
+ LightSource,23 D50
+ LightSource,24 "ISO studio tungsten"
+ LightSource,255 other
+ LightSource, unknown
+
+ Flash,0 "no flash"
+ Flash,1 "flash fired"
+ Flash,5 "strobe return light not detected"
+ Flash,7 "strobe return light detected"
+ Flash,9 "flash fired, compulsory flash mode"
+ Flash,13 "flash fired, compulsory flash mode, return light not detected"
+ Flash,15 "flash fired, compulsory flash mode, return light detected"
+ Flash,16 "flash did not fire, compulsory flash mode"
+ Flash,24 "flash did not fire, auto mode"
+ Flash,25 "flash fired, auto mode"
+ Flash,29 "flash fired, auto mode, return light not detected"
+ Flash,31 "flash fired, auto mode, return light detected"
+ Flash,32 "no flash function"
+ Flash,65 "flash fired, red-eye reduction mode"
+ Flash,69 "flash fired, red-eye reduction mode, return light not detected"
+ Flash,71 "flash fired, red-eye reduction mode, return light detected"
+ Flash,73 "flash fired, compulsory mode, red-eye reduction mode"
+ Flash,77 "flash fired, compulsory mode, red-eye reduction mode, return light not detected"
+ Flash,79 "flash fired, compulsory mode, red-eye reduction mode, return light detected"
+ Flash,89 "flash fired, auto mode, red-eye reduction mode"
+ Flash,93 "flash fired, auto mode, return light not detected, red-eye reduction mode"
+ Flash,95 "flash fired, auto mode, return light detected, red-eye reduction mode"
+ Flash, unknown
+
+ ResolutionUnit,2 inch
+ ResolutionUnit,3 centimeter
+ ResolutionUnit, unknown
+
+ SensingMethod,1 undefined
+ SensingMethod,2 "one chip color area sensor"
+ SensingMethod,3 "two chip color area sensor"
+ SensingMethod,4 "three chip color area sensor"
+ SensingMethod,5 "color sequential area sensor"
+ SensingMethod,7 "trilinear sensor"
+ SensingMethod,8 "color sequential linear sensor"
+ SensingMethod, unknown
+
+ SceneType,\x01\x00\x00\x00 "directly photographed image"
+ SceneType, unknown
+
+ CustomRendered,0 normal
+ CustomRendered,1 custom
+
+ ExposureMode,0 auto
+ ExposureMode,1 manual
+ ExposureMode,2 "auto bracket"
+ ExposureMode, unknown
+
+ WhiteBalance,0 auto
+ WhiteBlanace,1 manual
+ WhiteBlanace, unknown
+
+ SceneCaptureType,0 standard
+ SceneCaptureType,1 landscape
+ SceneCaptureType,2 portrait
+ SceneCaptureType,3 night
+ SceneCaptureType, unknown
+
+ GainControl,0 none
+ GainControl,1 "low gain up"
+ GainControl,2 "high gain up"
+ GainControl,3 "low gain down"
+ GainControl,4 "high gain down"
+ GainControl, unknown
+
+ Contrast,0 normal
+ Contrast,1 soft
+ Contrast,2 hard
+ Contrast, unknown
+
+ Saturation,0 normal
+ Saturation,1 low
+ Saturation,2 high
+ Saturation, unknown
+
+ Sharpness,0 normal
+ Sharpness,1 soft
+ Sharpness,2 hard
+ Sharpness, unknown
+
+ SubjectDistanceRange,0 unknown
+ SubjectDistanceRange,1 macro
+ SubjectDistanceRange,2 close
+ SubjectDistanceRange,3 distant
+ SubjectDistanceRange, unknown
+
+ MeteringMode,0 unknown
+ MeteringMode,1 average
+ MeteringMode,2 "center weighted average"
+ MeteringMode,3 spot
+ MeteringMode,4 multi-spot
+ MeteringMode,5 multi-segment
+ MeteringMode,6 partial
+ MeteringMode,255 other
+ MeteringMode, unknown
+
+ FocalPlaneResolutionUnit,2 inch
+ FocalPlaneResolutionUnit,3 centimeter
+ FocalPlaneResolutionUnit, none
+
+ DigitalZoomRatio,0 "not used"
+
+ FileSource,\x03\x00\x00\x00 "digital still camera"
+ FileSource, unknown
+}
+
+# [binary scan], in the byte order indicated by $e
+proc ::jpeg::_scan {e v f args} {
+ foreach x $args { upvar 1 $x $x }
+ if {$e == "big"} {
+ eval [list binary scan $v [string map {b B h H s S i I} $f]] $args
+ } else {
+ eval [list binary scan $v $f] $args
+ }
+}
+
+
+# formats exif values, the numbers correspond to data types
+# values may be either byte order, as indicated by $end
+# see the exif spec for more info
+proc ::jpeg::_format {end value type num} {
+ if {$num > 1 && $type != 2 && $type != 7} {
+ variable exif_formats
+ set r {}
+ for {set i 0} {$i < $num} {incr i} {
+ set len $exif_formats($type)
+ lappend r [_format $end [string range $value [expr {$len * $i}] [expr {($len * $i) + $len - 1}]] $type 1]
+ }
+ return [join $r ,]
+ }
+ switch -exact -- $type {
+ 1 { _scan $end $value c value }
+ 2 { set value [string trimright $value \x00] }
+ 3 {
+ _scan $end $value s value
+ set value [format %u $value]
+ }
+ 4 {
+ _scan $end $value i value
+ set value [format %u $value]
+ }
+ 5 {
+ _scan $end $value ii n d
+ set n [format %u $n]
+ set d [format %u $d]
+ if {$d == 0} {set d 1}
+ #set value [string trimright [string trimright [format %5.4f [expr {double($n) / $d}]] 0] .]
+ set value [string trimright [string trimright [expr {double($n) / $d}] 0] .]
+ #set value "$n/$d"
+ }
+ 6 { _scan $end $value c value }
+ 8 { _scan $end $value s value }
+ 9 { _scan $end $value i value }
+ 10 {
+ _scan $end $value ii n d
+ if {$d == 0} {set d 1}
+ #set value [string trimright [string trimright [format %5.4f [expr {double($n) / $d}]] 0] .]
+ set value [string trimright [string trimright [expr {double($n) / $d}] 0] .]
+ #set value "$n/$d"
+ }
+ 11 { _scan $end $value i value }
+ 12 { _scan $end $value w value }
+ }
+ return $value
+}
+
+# Do a compatibility version of [lassign] for versions of Tcl without
+# that command. Not using a version check as special builds may have
+# the command even if they are a version which nominally would not.
+
+if {![llength [info commands lassign]]} {
+ proc ::jpeg::lassign {sequence v args} {
+ set args [linsert $args 0 $v]
+ set a [::llength $args]
+
+ # Nothing to assign.
+ #if {$a == 0} {return $sequence}
+
+ # Perform assignments
+ set i 0
+ foreach v $args {
+ upvar 1 $v var
+ set var [::lindex $sequence $i]
+ incr i
+ }
+
+ # Return remainder, if there is any.
+ return [::lrange $sequence $a end]
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide jpeg 0.5
+
diff --git a/tcllib/modules/jpeg/jpeg.test b/tcllib/modules/jpeg/jpeg.test
new file mode 100644
index 0000000..8c28751
--- /dev/null
+++ b/tcllib/modules/jpeg/jpeg.test
@@ -0,0 +1,503 @@
+# -*- tcl -*-
+# jpeg.test: Tests for the JPEG utilities.
+#
+# Copyright (c) 2008-2013 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# JPEG: @(#) $Id: jpeg.test,v 1.2 2011/05/06 13:39:27 patthoyts Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2
+
+support {
+ use fileutil/fileutil.tcl fileutil
+}
+testing {
+ useLocal jpeg.tcl jpeg
+}
+
+# -------------------------------------------------------------------------
+
+proc strdiff {a b} {
+ set la [string length $a]
+ set lb [string length $b]
+ if {$la < $lb} {
+ set b [string range $b 0 [expr {$la - 1}]]
+ set s b
+ } elseif {$lb < $la} {
+ set a [string range $a 0 [expr {$lb - 1}]]
+ set s a
+ } else {
+ set s -
+ }
+ set n -1
+ foreach ca [split $a {}] cb [split $b {}] {
+ incr n
+ if {[string equal $ca $cb]} continue
+ lappend s $n $ca $cb
+ }
+ return $s
+}
+
+proc fixupdata {dict} {
+ array set tmp $dict
+ catch {unset tmp(MakerNote)}
+ foreach k {
+ FocalPlaneXResolution
+ FocalPlaneYResolution
+ } {
+ if {![info exists tmp($k)]} continue
+ set tmp($k) [format %8.2f $tmp($k)]
+ }
+ return [array get tmp]
+}
+
+# -------------------------------------------------------------------------
+
+test jpeg-1.0 {isJPEG error, wrong#args, not enough} -body {
+ ::jpeg::isJPEG
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::isJPEG} {file} 0]
+
+test jpeg-1.1 {isJPEG error, wrong#args, too many} -body {
+ ::jpeg::isJPEG foo bar
+} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::isJPEG} {file}]
+
+# -------------------------------------------------------------------------
+
+set n 0
+foreach f [TestFilesGlob testimages/*JPG*] {
+ test jpeg-2.$n "isJPEG, ok, [file tail $f]" -body {
+ ::jpeg::isJPEG $f
+ } -result 1
+ incr n
+}
+
+test jpeg-2.$n "isJPEG, fail, [file tail [info script]]" -body {
+ ::jpeg::isJPEG [info script]
+} -result 0
+
+# -------------------------------------------------------------------------
+
+test jpeg-2.0 {imageInfo error, wrong#args, not enough} -body {
+ ::jpeg::imageInfo
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::imageInfo} {file} 0]
+
+test jpeg-2.1 {imageInfo error, wrong#args, too many} -body {
+ ::jpeg::imageInfo foo bar
+} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::imageInfo} {file}]
+
+# -------------------------------------------------------------------------
+
+set n 0
+foreach f [TestFilesGlob testimages/*.JPG] {
+ test jpeg-3.$n "imageInfo regular, [file tail $f]" -body {
+ ::jpeg::imageInfo $f
+ } -result [string trim [fileutil::cat [file rootname $f].info.txt]]
+ incr n
+}
+
+set n 0
+foreach f [TestFilesGlob testimages/*.thumb] {
+ test jpeg-4.$n "imageInfo thumbnails, [file tail $f]" -body {
+ ::jpeg::imageInfo $f
+ } -result {}
+ incr n
+}
+
+test jpeg-5.0 "imageInfo, fail, [file tail [info script]]" -body {
+ ::jpeg::imageInfo [info script]
+} -returnCodes error -result {not a jpg file}
+
+# -------------------------------------------------------------------------
+
+test jpeg-6.0 {dimensions error, wrong#args, not enough} -body {
+ ::jpeg::dimensions
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::dimensions} {file} 0]
+
+test jpeg-6.1 {dimensions error, wrong#args, too many} -body {
+ ::jpeg::dimensions foo bar
+} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::dimensions} {file}]
+
+# -------------------------------------------------------------------------
+
+set n 0
+foreach f [TestFilesGlob testimages/*.JPG] {
+ test jpeg-7.$n "dimensions regular, [file tail $f]" -body {
+ ::jpeg::dimensions $f
+ } -result [string trim [fileutil::cat [file rootname $f].WxH.txt]]
+ incr n
+}
+
+set n 0
+foreach f [TestFilesGlob testimages/*.thumb] {
+ test jpeg-8.$n "dimensions thumbnails, [file tail $f]" -body {
+ ::jpeg::dimensions $f
+ } -result {160 120}
+ incr n
+}
+
+test jpeg-9.0 "dimensions, fail, [file tail [info script]]" -body {
+::jpeg::dimensions [info script]
+} -returnCodes error -result {not a jpg file}
+
+# -------------------------------------------------------------------------
+
+test jpeg-10.0 {getThumbnail error, wrong#args, not enough} -body {
+ ::jpeg::getThumbnail
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::getThumbnail} {file} 0]
+
+test jpeg-10.1 {getThumbnail error, wrong#args, too many} -body {
+ ::jpeg::getThumbnail foo bar
+} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::getThumbnail} {file}]
+
+# -------------------------------------------------------------------------
+
+set n 0
+foreach f [TestFilesGlob testimages/*.JPG] {
+ if {![file exists $f.thumb]} {
+ test jpeg-11.$n "getThumbnail - no thumbnail, [file tail $f]" -body {
+ ::jpeg::getThumbnail $f
+ } -result {}
+ } else {
+ test jpeg-11.$n "getThumbnail regular, [file tail $f]" -body {
+ #fileutil::writeFile -translation binary ${f}.x.jpg [::jpeg::getThumbnail $f]
+ # Note: The .thumb files were created from the .JPG files
+ # using 'jhead -st', version 2.6.
+ set expected [fileutil::cat -translation binary ${f}.thumb]
+ set have [::jpeg::getThumbnail $f]
+ list [string equal $expected $have] [strdiff $expected $have]
+ } -result {1 -}
+ }
+
+ incr n
+}
+
+set n 0
+foreach f [TestFilesGlob testimages/*.thumb] {
+ test jpeg-12.$n "getThumbnail thumbnails, [file tail $f]" -body {
+ ::jpeg::getThumbnail $f
+ } -result {}
+ incr n
+}
+
+test jpeg-13.0 "getThumbnail, fail, [file tail [info script]]" -body {
+ ::jpeg::getThumbnail [info script]
+} -returnCodes error -result {not a jpg file}
+
+# -------------------------------------------------------------------------
+
+test jpeg-14.0 {exifKeys error, wrong#args, too many} -body {
+ ::jpeg::exifKeys bar
+} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::exifKeys} {}]
+
+# -------------------------------------------------------------------------
+
+test jpeg-15.0 {exifKeys} -body {
+ ::jpeg::exifKeys
+} -result {SubjectDistanceRange InterColorProfile InteroperabilityIndex InteroperabilityVersion Copyright ShutterSpeedValue ApertureValue BrightnessValue ImageDescription ExposureBiasValue Make MaxApertureValue SubjectDistance FlashpixVersion MeteringMode ColorSpace LightSource XResolution ExifImageWidth Flash YResolution ExifImageHeight ImageNumber PlanarConfiguration RelatedSoundFile SecurityClassification CustomRendered ImageHistory ExposureMode WhiteBalance SubjectArea ExposureIndex DigitalZoomRatio ImageWidth UserComment TIFF/EPStandardID FocalLengthIn35mmFilm ImageLength TimeZoneOffset SceneCaptureType BitsPerSample SelfTimerMode GainControl Compression SubsecTime Contrast SubsecTimeOriginal Saturation SubsecTimeDigitized PhotometricInterpretation TransferFunction RelatedImageFileFormat RelatedImageWidth Model NewSubfileType RelatedImageLength StripOffsets SubfileType Orientation FlashEnergy SpatialFrequencyResponse Artist ImageUniqueID SamplesPerPixel Predictor FocalPlaneXResolution RowsPerStrip FocalPlaneYResolution StripByteCounts WhitePoint ExifVersion PrimaryChromaticities JPEGInterchangeFormat JPEGInterchangeFormatLength DateTimeOriginal ExposureProgram DateTimeDigitized CFARepeatPatternDim SubIFDs SpectralSensitivity GPSInfo CFAPattern BatteryLevel ISOSpeedRatings OECF Interlace ResolutionUnit YCbCrCoefficients ExposureTime YCbCrSubSampling Software YCbCrPositioning DateTime IPTC/NAA ReferenceBlackWhite FNumber JPEGTables ComponentsConfiguration FocalPlaneResolutionUnit FocalLength CompressedBitsPerPixel MakerNote SpatialFrequencyResponse Noise TileWidth TileLength SubjectLocation TileOffsets ExposureIndex TileByteCounts SensingMethod FileSource SceneType Sharpness CFAPattern DeviceSettingDescription}
+
+# -------------------------------------------------------------------------
+
+test jpeg-16.0 {getComments error, wrong#args, not enough} -body {
+ ::jpeg::getComments
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::getComments} {file} 0]
+
+test jpeg-16.1 {getComments error, wrong#args, too many} -body {
+ ::jpeg::getComments foo bar
+} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::getComments} {file}]
+
+# -------------------------------------------------------------------------
+
+set n 0
+foreach f [TestFilesGlob testimages/*.JPG] {
+ test jpeg-17.$n "getComments regular, [file tail $f]" -body {
+ ::jpeg::getComments $f
+ } -result {}
+ incr n
+}
+
+set n 0
+foreach f [TestFilesGlob testimages/*.thumb] {
+ test jpeg-18.$n "getComments thumbnails, [file tail $f]" -body {
+ ::jpeg::getComments $f
+ } -result {}
+ incr n
+}
+
+test jpeg-19.0 "getComments, fail, [file tail [info script]]" -body {
+ ::jpeg::getComments [info script]
+} -returnCodes error -result {not a jpg file}
+
+# -------------------------------------------------------------------------
+
+test jpeg-20.0 {addComment error, wrong#args, not enough} -body {
+ ::jpeg::addComment
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::addComment} {file comment args} 0]
+
+test jpeg-20.1 {addComment error, wrong#args, not enough} -body {
+ ::jpeg::addComment foo
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::addComment} {file comment args} 1]
+
+# -------------------------------------------------------------------------
+
+set n 0
+foreach f [TestFilesGlob testimages/*JPG*] {
+ test jpeg-21.$n "addComment regular, [file tail $f]" -setup {
+ file copy -force $f [set fx [makeFile {} jtmp]]
+ ::jpeg::addComment $fx {a b} {c d}
+ } -body {
+ ::jpeg::getComments $fx
+ } -cleanup {
+ removeFile $fx
+ unset fx
+ } -result {{a b} {c d}}
+ incr n
+}
+
+test jpeg-22.0 "addComment, fail, [file tail [info script]]" -body {
+ ::jpeg::addComment [info script] foo
+} -returnCodes error -result {not a jpg file}
+
+# -------------------------------------------------------------------------
+
+test jpeg-23.0 {removeComments error, wrong#args, not enough} -body {
+ ::jpeg::removeComments
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::removeComments} {file} 0]
+
+test jpeg-23.1 {removeComments error, wrong#args, too many} -body {
+ ::jpeg::removeComments foo bar
+} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::removeComments} {file}]
+
+# -------------------------------------------------------------------------
+
+set n 0
+foreach f [TestFilesGlob testimages/*JPG*] {
+ test jpeg-24.$n "removeComments regular, [file tail $f]" -setup {
+ file copy -force $f [set fx [makeFile {} jtmp]]
+ ::jpeg::addComment $fx {a b} {c d}
+ } -body {
+ ::jpeg::removeComments $fx
+ ::jpeg::getComments $fx
+ } -cleanup {
+ removeFile $fx
+ unset fx
+ } -result {}
+ incr n
+}
+
+test jpeg-25.0 "removeComments, fail, [file tail [info script]]" -body {
+ ::jpeg::removeComments [info script]
+} -returnCodes error -result {not a jpg file}
+
+# -------------------------------------------------------------------------
+
+test jpeg-26.0 {replaceComment error, wrong#args, not enough} -body {
+ ::jpeg::replaceComment
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::replaceComment} {file comment} 0]
+
+test jpeg-26.1 {replaceComment error, wrong#args, not enough} -body {
+ ::jpeg::replaceComment foo
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::replaceComment} {file comment} 0]
+
+test jpeg-26.2 {replaceComment error, wrong#args, too many} -body {
+ ::jpeg::replaceComment foo bar barf
+} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::replaceComment} {file comment}]
+
+# -------------------------------------------------------------------------
+
+set n 0
+foreach f [TestFilesGlob testimages/*JPG*] {
+ test jpeg-27.$n "replaceComment regular, [file tail $f]" -setup {
+ file copy -force $f [set fx [makeFile {} jtmp]]
+ ::jpeg::addComment $fx {a b} {c d}
+ } -body {
+ ::jpeg::replaceComment $fx new
+ ::jpeg::getComments $fx
+ } -cleanup {
+ removeFile $fx
+ unset fx
+ } -result {new {c d}}
+ incr n
+}
+
+test jpeg-28.0 "replaceComment, fail, [file tail [info script]]" -body {
+ ::jpeg::replaceComment [info script] foo
+} -returnCodes error -result {not a jpg file}
+
+# -------------------------------------------------------------------------
+
+test jpeg-29.0 {getExif error, wrong#args, not enough} -body {
+ ::jpeg::getExif
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::getExif} {file ?type?} 0]
+
+test jpeg-29.1 {getExif error, wrong#args, too many} -body {
+ ::jpeg::getExif foo bar barf
+} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::getExif} {file ?type?}]
+
+test jpeg-29.2 {getExif error, bad section type} -body {
+ ::jpeg::getExif [localPath testimages/IMG_7950.JPG] fufara
+} -returnCodes error -result {Bad type "fufara", expected one of "main", or "thumbnail"}
+
+test jpeg-29.3 {getExifFromChannel error, wrong#args, not enough} -body {
+ ::jpeg::getExifFromChannel
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::getExifFromChannel} {chan ?type?} 0]
+
+test jpeg-29.4 {getExifFromChannel error, wrong#args, too many} -body {
+ ::jpeg::getExifFromChannel foo bar barf
+} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::getExifFromChannel} {chan ?type?}]
+
+test jpeg-29.5 {getExifFromChannel error, bad section type} -setup {
+ set fd [::jpeg::openJFIF [localPath testimages/IMG_7950.JPG] r]
+} -body {
+ ::jpeg::getExifFromChannel $fd fufara
+} -cleanup {
+ close $fd
+ unset fd
+} -returnCodes error -result {Bad type "fufara", expected one of "main", or "thumbnail"}
+
+# -------------------------------------------------------------------------
+
+set n 0
+foreach f [TestFilesGlob testimages/*.JPG] {
+ test jpeg-30.$n "getExif, main section, $f" -body {
+ dictsort [fixupdata [::jpeg::formatExif [::jpeg::getExif $f]]]
+ } -result [string trimright [fileutil::cat [file rootname $f].exif.txt]]
+ incr n
+}
+
+set n 0
+foreach f [TestFilesGlob testimages/*.thumb] {
+ test jpeg-31.$n "getExif, main section, $f" -body {
+ dictsort [fixupdata [::jpeg::formatExif [::jpeg::getExif $f]]]
+ } -result {}
+ incr n
+}
+
+set n 0
+foreach f [TestFilesGlob testimages/*.JPG] {
+ test jpeg-32.$n "getExif, thumbnail section, $f" -body {
+ dictsort [fixupdata [::jpeg::formatExif [::jpeg::getExif $f thumbnail]]]
+ } -result [string trimright [fileutil::cat [file rootname $f].thumbexif.txt]]
+ incr n
+}
+
+set n 0
+foreach f [TestFilesGlob testimages/*.thumb] {
+ test jpeg-33.$n "getExif, thumbnail section, $f" -body {
+ dictsort [fixupdata [::jpeg::formatExif [::jpeg::getExif $f thumbnail]]]
+ } -result {}
+ incr n
+}
+
+test jpeg-34.0 "getExif, fail, [file tail [info script]]" -body {
+ ::jpeg::getExif [info script]
+} -returnCodes error -result {not a jpg file}
+
+# -------------------------------------------------------------------------
+# formatExif is implicitly tested in the previous tests (30-33), with getExif.
+
+test jpeg-33.0 {formatExif error, wrong#args, not enough} -body {
+ ::jpeg::formatExif
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::formatExif} {exif} 0]
+
+test jpeg-33.1 {formatExif error, wrong#args, too many} -body {
+ ::jpeg::formatExif foo bar
+} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::formatExif} {exif}]
+
+# -------------------------------------------------------------------------
+
+test jpeg-34.0 {removeExif error, wrong#args, not enough} -body {
+ ::jpeg::removeExif
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::removeExif} {file} 0]
+
+test jpeg-34.1 {removeExif error, wrong#args, too many} -body {
+ ::jpeg::removeExif foo bar
+} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::removeExif} {file}]
+
+# -------------------------------------------------------------------------
+
+set n 0
+foreach f [TestFilesGlob testimages/*JPG*] {
+ test jpeg-35.$n "removeExif ok, [file tail $f]" -setup {
+ file copy -force $f [set fx [makeFile {} jtmp]]
+ ::jpeg::addComment $fx {a b} {c d}
+ } -body {
+ ::jpeg::removeExif $fx
+ set res [list [::jpeg::getComments $fx] [::jpeg::getExif $fx] [::jpeg::getExif $fx thumbnail]]
+ } -cleanup {
+ removeFile $fx
+ unset fx
+ } -result {{{a b} {c d}} {} {}}
+ incr n
+}
+
+test jpeg-36.0 "removeExif, fail, [file tail [info script]]" -body {
+::jpeg::removeExif [info script]
+} -returnCodes error -result {not a jpg file}
+
+# -------------------------------------------------------------------------
+
+test jpeg-37.0 {stripJPEG error, wrong#args, not enough} -body {
+ ::jpeg::stripJPEG
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::stripJPEG} {file} 0]
+
+test jpeg-37.1 {stripJPEG error, wrong#args, too many} -body {
+ ::jpeg::stripJPEG foo bar
+} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::stripJPEG} {file}]
+
+# -------------------------------------------------------------------------
+
+set n 0
+foreach f [TestFilesGlob testimages/*JPG*] {
+ test jpeg-38.$n "stripJPEG ok, [file tail $f]" -setup {
+ file copy -force $f [set fx [makeFile {} jtmp]]
+ ::jpeg::addComment $fx {a b} {c d}
+ } -body {
+ ::jpeg::stripJPEG $fx
+ set res [list [::jpeg::getComments $fx] [::jpeg::getExif $fx] [::jpeg::getExif $fx thumbnail]]
+ } -cleanup {
+ removeFile $fx
+ unset fx
+ } -result {{} {} {}}
+ incr n
+}
+
+test jpeg-39.0 "stripJPEG, fail, [file tail [info script]]" -body {
+ ::jpeg::stripJPEG [info script]
+} -returnCodes error -result {not a jpg file}
+
+# -------------------------------------------------------------------------
+
+test jpeg-40.0 {debug error, wrong#args, not enough} -body {
+ ::jpeg::debug
+} -returnCodes error -result [tcltest::wrongNumArgs {::jpeg::debug} {file} 0]
+
+test jpeg-40.1 {debug error, wrong#args, too many} -body {
+ ::jpeg::debug foo bar
+} -returnCodes error -result [tcltest::tooManyArgs {::jpeg::debug} {file}]
+
+# -------------------------------------------------------------------------
+# We do not try to actually run 'debug', because it prints its results
+# to stdout. This may change when we can capture stdout as test result
+
+set n 0
+foreach f [TestFilesGlob testimages/*JPG*] {
+ test jpeg-41.$n "debug ok, [file tail $f]" -constraints donotrun -body {
+ ::jpeg::debug $f
+ } -result {}
+ incr n
+}
+
+test jpeg-42.0 "debug, fail, [file tail [info script]]" -body {
+ ::jpeg::debug [info script]
+} -returnCodes error -result {not a jpg file}
+
+# -------------------------------------------------------------------------
+rename strdiff {}
+testsuiteCleanup
diff --git a/tcllib/modules/jpeg/pkgIndex.tcl b/tcllib/modules/jpeg/pkgIndex.tcl
new file mode 100644
index 0000000..a5aeabc
--- /dev/null
+++ b/tcllib/modules/jpeg/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded jpeg 0.5 [list source [file join $dir jpeg.tcl]]
diff --git a/tcllib/modules/jpeg/testimages/1000.JPG b/tcllib/modules/jpeg/testimages/1000.JPG
new file mode 100644
index 0000000..551d9cb
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/1000.JPG
Binary files differ
diff --git a/tcllib/modules/jpeg/testimages/1000.WxH.txt b/tcllib/modules/jpeg/testimages/1000.WxH.txt
new file mode 100644
index 0000000..42cd169
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/1000.WxH.txt
@@ -0,0 +1 @@
+1000 1000
diff --git a/tcllib/modules/jpeg/testimages/1000.exif.txt b/tcllib/modules/jpeg/testimages/1000.exif.txt
new file mode 100644
index 0000000..fe5a223
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/1000.exif.txt
@@ -0,0 +1 @@
+ExifByteOrder little ExifOffset 30
diff --git a/tcllib/modules/jpeg/testimages/1000.info.txt b/tcllib/modules/jpeg/testimages/1000.info.txt
new file mode 100644
index 0000000..78ebf12
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/1000.info.txt
@@ -0,0 +1 @@
+version 1.1 units 1 xdensity 96 ydensity 96 xthumb 0 ythumb 0
diff --git a/tcllib/modules/jpeg/testimages/1000.thumbexif.txt b/tcllib/modules/jpeg/testimages/1000.thumbexif.txt
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/1000.thumbexif.txt
diff --git a/tcllib/modules/jpeg/testimages/IMG_7898.JPG b/tcllib/modules/jpeg/testimages/IMG_7898.JPG
new file mode 100644
index 0000000..8932ee9
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7898.JPG
Binary files differ
diff --git a/tcllib/modules/jpeg/testimages/IMG_7898.JPG.thumb b/tcllib/modules/jpeg/testimages/IMG_7898.JPG.thumb
new file mode 100644
index 0000000..cd25b58
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7898.JPG.thumb
Binary files differ
diff --git a/tcllib/modules/jpeg/testimages/IMG_7898.WxH.txt b/tcllib/modules/jpeg/testimages/IMG_7898.WxH.txt
new file mode 100644
index 0000000..d27cc65
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7898.WxH.txt
@@ -0,0 +1 @@
+320 240
diff --git a/tcllib/modules/jpeg/testimages/IMG_7898.exif.txt b/tcllib/modules/jpeg/testimages/IMG_7898.exif.txt
new file mode 100644
index 0000000..9eb78a7
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7898.exif.txt
@@ -0,0 +1 @@
+ApertureValue 4.0 ColorSpace sRGB ComponentsConfiguration 1,2,3,0 CompressedBitsPerPixel 5 CustomRendered normal DateTime {2008:03:14 15:40:06} DateTimeDigitized {2008:03:14 15:40:06} DateTimeOriginal {2008:03:14 15:40:06} DigitalZoomRatio 1 ExifByteOrder little ExifImageHeight 2448 ExifImageWidth 3264 ExifOffset 30 ExifVersion 2.2 ExposureBiasValue 0 ExposureMode auto ExposureTime 1/60 FNumber 4.0 FileSource {digital still camera} Flash {flash did not fire, compulsory flash mode} FlashpixVersion {Flashpix Format Version 1.0} FocalLength 6 FocalPlaneResolutionUnit inch FocalPlaneXResolution 14506.67 FocalPlaneYResolution 14485.21 ISOSpeedRatings 80 InteroperabilityIndex R98 InteroperabilityVersion 0100 Make Canon MaxApertureValue 3.0 MeteringMode multi-segment Model {Canon PowerShot S5 IS} Orientation normal RelatedImageLength 2448 RelatedImageWidth 3264 ResolutionUnit inch SceneCaptureType standard SensingMethod {one chip color area sensor} ShutterSpeedValue 1/60 UserComment {} WhiteBalance auto XResolution 180 YCbCrPositioning centered YResolution 180
diff --git a/tcllib/modules/jpeg/testimages/IMG_7898.info.txt b/tcllib/modules/jpeg/testimages/IMG_7898.info.txt
new file mode 100644
index 0000000..855f1f7
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7898.info.txt
@@ -0,0 +1 @@
+version 1.1 units 1 xdensity 180 ydensity 180 xthumb 0 ythumb 0
diff --git a/tcllib/modules/jpeg/testimages/IMG_7898.thumbexif.txt b/tcllib/modules/jpeg/testimages/IMG_7898.thumbexif.txt
new file mode 100644
index 0000000..2cee21a
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7898.thumbexif.txt
@@ -0,0 +1 @@
+Compression JPEG ExifByteOrder little ExifOffset 30 JPEGInterchangeFormat 5108 JPEGInterchangeFormatLength 6496 ResolutionUnit inch XResolution 180 YResolution 180
diff --git a/tcllib/modules/jpeg/testimages/IMG_7917.JPG b/tcllib/modules/jpeg/testimages/IMG_7917.JPG
new file mode 100644
index 0000000..3b5d22e
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7917.JPG
Binary files differ
diff --git a/tcllib/modules/jpeg/testimages/IMG_7917.JPG.thumb b/tcllib/modules/jpeg/testimages/IMG_7917.JPG.thumb
new file mode 100644
index 0000000..75b3991
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7917.JPG.thumb
Binary files differ
diff --git a/tcllib/modules/jpeg/testimages/IMG_7917.WxH.txt b/tcllib/modules/jpeg/testimages/IMG_7917.WxH.txt
new file mode 100644
index 0000000..d27cc65
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7917.WxH.txt
@@ -0,0 +1 @@
+320 240
diff --git a/tcllib/modules/jpeg/testimages/IMG_7917.exif.txt b/tcllib/modules/jpeg/testimages/IMG_7917.exif.txt
new file mode 100644
index 0000000..5bd3c38
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7917.exif.txt
@@ -0,0 +1 @@
+ApertureValue 3.5 ColorSpace sRGB ComponentsConfiguration 1,2,3,0 CompressedBitsPerPixel 5 CustomRendered normal DateTime {2008:03:14 16:20:16} DateTimeDigitized {2008:03:14 16:20:16} DateTimeOriginal {2008:03:14 16:20:16} DigitalZoomRatio 1 ExifByteOrder little ExifImageHeight 2448 ExifImageWidth 3264 ExifOffset 30 ExifVersion 2.2 ExposureBiasValue 0 ExposureMode auto ExposureTime 1/60 FNumber 3.2 FileSource {digital still camera} Flash {flash did not fire, compulsory flash mode} FlashpixVersion {Flashpix Format Version 1.0} FocalLength 6 FocalPlaneResolutionUnit inch FocalPlaneXResolution 14506.67 FocalPlaneYResolution 14485.21 ISOSpeedRatings 80 InteroperabilityIndex R98 InteroperabilityVersion 0100 Make Canon MaxApertureValue 3.0 MeteringMode multi-segment Model {Canon PowerShot S5 IS} Orientation normal RelatedImageLength 2448 RelatedImageWidth 3264 ResolutionUnit inch SceneCaptureType standard SensingMethod {one chip color area sensor} ShutterSpeedValue 1/60 UserComment {} WhiteBalance auto XResolution 180 YCbCrPositioning centered YResolution 180
diff --git a/tcllib/modules/jpeg/testimages/IMG_7917.info.txt b/tcllib/modules/jpeg/testimages/IMG_7917.info.txt
new file mode 100644
index 0000000..855f1f7
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7917.info.txt
@@ -0,0 +1 @@
+version 1.1 units 1 xdensity 180 ydensity 180 xthumb 0 ythumb 0
diff --git a/tcllib/modules/jpeg/testimages/IMG_7917.thumbexif.txt b/tcllib/modules/jpeg/testimages/IMG_7917.thumbexif.txt
new file mode 100644
index 0000000..681ce4d
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7917.thumbexif.txt
@@ -0,0 +1 @@
+Compression JPEG ExifByteOrder little ExifOffset 30 JPEGInterchangeFormat 5108 JPEGInterchangeFormatLength 5219 ResolutionUnit inch XResolution 180 YResolution 180
diff --git a/tcllib/modules/jpeg/testimages/IMG_7950.JPG b/tcllib/modules/jpeg/testimages/IMG_7950.JPG
new file mode 100644
index 0000000..a395a37
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7950.JPG
Binary files differ
diff --git a/tcllib/modules/jpeg/testimages/IMG_7950.JPG.thumb b/tcllib/modules/jpeg/testimages/IMG_7950.JPG.thumb
new file mode 100644
index 0000000..f821d3f
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7950.JPG.thumb
Binary files differ
diff --git a/tcllib/modules/jpeg/testimages/IMG_7950.WxH.txt b/tcllib/modules/jpeg/testimages/IMG_7950.WxH.txt
new file mode 100644
index 0000000..d27cc65
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7950.WxH.txt
@@ -0,0 +1 @@
+320 240
diff --git a/tcllib/modules/jpeg/testimages/IMG_7950.exif.txt b/tcllib/modules/jpeg/testimages/IMG_7950.exif.txt
new file mode 100644
index 0000000..a2b58f7
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7950.exif.txt
@@ -0,0 +1 @@
+ApertureValue 3.7 ColorSpace sRGB ComponentsConfiguration 1,2,3,0 CompressedBitsPerPixel 5 CustomRendered normal DateTime {2008:03:14 16:54:36} DateTimeDigitized {2008:03:14 16:54:36} DateTimeOriginal {2008:03:14 16:54:36} DigitalZoomRatio 1 ExifByteOrder little ExifImageHeight 2448 ExifImageWidth 3264 ExifOffset 30 ExifVersion 2.2 ExposureBiasValue 0 ExposureMode auto ExposureTime 1/60 FNumber 3.5 FileSource {digital still camera} Flash {flash did not fire, compulsory flash mode} FlashpixVersion {Flashpix Format Version 1.0} FocalLength 6 FocalPlaneResolutionUnit inch FocalPlaneXResolution 14506.67 FocalPlaneYResolution 14485.21 ISOSpeedRatings 80 InteroperabilityIndex R98 InteroperabilityVersion 0100 Make Canon MaxApertureValue 3.0 MeteringMode multi-segment Model {Canon PowerShot S5 IS} Orientation normal RelatedImageLength 2448 RelatedImageWidth 3264 ResolutionUnit inch SceneCaptureType standard SensingMethod {one chip color area sensor} ShutterSpeedValue 1/60 UserComment {} WhiteBalance auto XResolution 180 YCbCrPositioning centered YResolution 180
diff --git a/tcllib/modules/jpeg/testimages/IMG_7950.info.txt b/tcllib/modules/jpeg/testimages/IMG_7950.info.txt
new file mode 100644
index 0000000..855f1f7
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7950.info.txt
@@ -0,0 +1 @@
+version 1.1 units 1 xdensity 180 ydensity 180 xthumb 0 ythumb 0
diff --git a/tcllib/modules/jpeg/testimages/IMG_7950.thumbexif.txt b/tcllib/modules/jpeg/testimages/IMG_7950.thumbexif.txt
new file mode 100644
index 0000000..efd2bf0
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7950.thumbexif.txt
@@ -0,0 +1 @@
+Compression JPEG ExifByteOrder little ExifOffset 30 JPEGInterchangeFormat 5108 JPEGInterchangeFormatLength 4181 ResolutionUnit inch XResolution 180 YResolution 180
diff --git a/tcllib/modules/jpeg/testimages/IMG_7950_none.JPG b/tcllib/modules/jpeg/testimages/IMG_7950_none.JPG
new file mode 100644
index 0000000..ca4c947
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7950_none.JPG
Binary files differ
diff --git a/tcllib/modules/jpeg/testimages/IMG_7950_none.WxH.txt b/tcllib/modules/jpeg/testimages/IMG_7950_none.WxH.txt
new file mode 100644
index 0000000..d27cc65
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7950_none.WxH.txt
@@ -0,0 +1 @@
+320 240
diff --git a/tcllib/modules/jpeg/testimages/IMG_7950_none.exif.txt b/tcllib/modules/jpeg/testimages/IMG_7950_none.exif.txt
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7950_none.exif.txt
diff --git a/tcllib/modules/jpeg/testimages/IMG_7950_none.info.txt b/tcllib/modules/jpeg/testimages/IMG_7950_none.info.txt
new file mode 100644
index 0000000..1cf8542
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7950_none.info.txt
@@ -0,0 +1 @@
+version 1.1 units 1 xdensity 300 ydensity 300 xthumb 0 ythumb 0
diff --git a/tcllib/modules/jpeg/testimages/IMG_7950_none.thumbexif.txt b/tcllib/modules/jpeg/testimages/IMG_7950_none.thumbexif.txt
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/jpeg/testimages/IMG_7950_none.thumbexif.txt
diff --git a/tcllib/modules/json/ChangeLog b/tcllib/modules/json/ChangeLog
new file mode 100644
index 0000000..4b4c2e7
--- /dev/null
+++ b/tcllib/modules/json/ChangeLog
@@ -0,0 +1,206 @@
+2014-01-07 Andreas Kupries <andreask@activestate.com>
+
+ * json.tcl: Move many-* wrapper to before its usage. Bumped
+ version to 1.3.2. v1.3.1 is broken.
+
+ * c/json.tab.c: Worked around issues with the critcl v2
+ * c/json.y: application the Tcllib C code is geared towards.
+ * json.tcl: Bumped json version to 1.3.1, jsonc to 1.1.1,
+ * jsonc.tcl: and tcllibc to 0.3.13.
+ * tcllibc.tcl: See ticket [6efa4f571af052].
+
+2014-01-06 Andreas Kupries <andreask@activestate.com>
+
+ See ticket [6efa4f571af052].
+ c: Removed json-parser files.
+ c/json.y: New parser.
+ c/json.tab.c: Generated parser code.
+ c/json_y.h: Header to binding.
+ jsonc.tcl:
+ json_tcl.tcl:
+
+ Reworked the Json/C code to use a bison-pased parser provided by
+ Mikhail. No separate data structures to convert, just direct
+ generation of Tcl structures. Changes compared to the original
+ submission:
+
+ - Use List, not Dict operations for objects, i.e. be Tcl 8.4
+ compatible.
+
+ - Do not generate Int/Double objects, only strings. Conversion to
+ actual int is lazy, when actually needed. Also ensures that
+ compile-time Tcl version does not restrict range of integers,
+ only runtime Tcl version.
+
+ - Allow all values as toplevel json, not just array and object.
+
+ - Currently no shared objects for the fixed values (null, true,
+ false).
+
+ Note that the RE-based json validation is still faster on even
+ moderatly sized strings, even when just using a stripped C lexer
+ not generating token values.
+
+ Bumped jsonc to version 1.1 and tcllibc to version 0.3.12.
+
+2013-12-11 Andreas Kupries <andreask@activestate.com>
+
+ * c: [Ticket 6efa4f571a]: Integrated a critcl binding of
+ * json.bench: the json-c parser. Moved to a standard
+ * json.man: switchable setup. json2dict and manyy-json2dict
+ * json.tcl: are now switchable to C. Everything else kept
+ * json.test: to Tcl. Note especially that Tcl 'validate'
+ * json.testsuite: (regexp-based) was still faster than json-c.
+ * json_tcl.tcl: Which has no mode for pure syntax checking,
+ * jsonc.tcl: thus overhead with construction of irelevant data
+ * pkgIndex.tcl: structures. Extended testsuite. New benchmark
+ * test-data: suite. Version bumped to 1.3.
+
+2013-06-19 Andreas Kupries <andreask@activestate.com>
+
+ * json.man: New command 'many-json2dict' to parse strings
+ * json.pcx: containing more than one JSON entity. The existing
+ * json.tcl: json2dict command will return only the first. Updated
+ * json.test: documentation. Extended testsuite. Package version
+ * pkgIndex.tcl: bumped to 1.2
+
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2013-02-01 Andreas Kupries <aku@hephaistos>
+
+ * json_write.tcl: While we can quote / (solidus) via \/ as per the
+ * json_write.man: JSON syntax there is no reason why we should.
+ * json_write.test: Bumped version to 1.0.2.
+ * pkgIndex.tcl:
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-11-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * json.tcl: [Bug 3426178]: Fixed bug in "list2json",
+ * json.test: reported by <a11426@users.sourceforge.net>.
+ * json.man: Updated testsuite. Bumped version to 1.1.2.
+ * pkgIndex.tcl:
+
+2011-08-24 Andreas Kupries <andreask@activestate.com>
+
+ * json_write.man:
+ * json_write.test:
+ * json_write.tcl: [Bug 3396787]: Fixed missing argument to call of
+ * pkgIndex.tcl: [info level], breaking the argument checks. Bumped
+ version to 1.0.1
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2011-01-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * json.tcl (json::parseValue): Fixed a missing -- older 8.4 seems
+ * json.man: to require to handle a dash in $leadingChar. Bumped
+ * pkgIndex.tcl: version to 1.1.1
+
+2009-12-10 Andreas Kupries <andreask@activestate.com>
+
+ * json.tcl: [Patch 2909962]: Accepted rewrite of the json parser
+ * json.man: internals by Thomas Maeder
+ * pkgIndex.tcl: <thomasmaeder@users.sourceforge.net>. The new
+ (regex-based) parser is considerably faster than the previous
+ implementation. Bumped version to 1.1.
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-11-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * json_write.tcl: New package 'json::write', supporting the
+ * json_write.test: generation of text in JSON format.
+ * json_write.man: Package version 1.
+ * json_write.pcx:
+ * pkgIndex.tcl:
+
+2009-11-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * json.tcl: Bumped package to version 1.0.1 due to the bugfix made
+ * pkgIndex.tcl: on 2009-04-18.
+
+2009-05-26 KATO Kanryu <kanryu6@users.sourceforge.net>
+
+ * json.test: improved to compare dicts
+
+2009-04-18 KATO Kanryu <kanryu6@users.sourceforge.net>
+
+ * json.tcl: fixed to parse last integer
+ * json.test: improved to compare dicts
+
+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 ========================
+ *
+
+2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * json.pcx: New file. Syntax definitions for the public commands
+ of the json package.
+
+2007-12-05 Andreas Kupries <andreask@activestate.com>
+
+ * json.test: Brought the test results into sync with the ordered
+ dicts of Tcl 8.5. NOTE: This will cause the combination of Tcl
+ 8.4 with a backported dict to fail, at least until either the
+ backported dict does the same ordering, or the tests are split
+ into variants, one for both of the two cases. This fixes [Tcllib
+ SF Bug 1844104], reported by Larry Virden
+ <lvirden@users.sourceforge.net>. Thanks.
+
+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>
+
+ * json.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-08-25 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * json.test: empty list test cases
+ * json.tcl (json::_json2dict): handle empty list case
+
+2006-08-18 Andreas Kupries <andreask@activestate.com>
+
+ * json.man: Added some more keywords to the docs.
+
+2006-08-17 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * json.tcl, json.man, json.test, pkgIndex.tcl: json package v1.0
+ Parses JSON formatted text into Tcl dicts.
+ See http://www.json.org/ for format details.
diff --git a/tcllib/modules/json/c/json.tab.c b/tcllib/modules/json/c/json.tab.c
new file mode 100644
index 0000000..615d61b
--- /dev/null
+++ b/tcllib/modules/json/c/json.tab.c
@@ -0,0 +1,1785 @@
+/* A Bison parser, made by GNU Bison 2.0. */
+
+/* Skeleton parser for Yacc-like parsing with Bison,
+ Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place - Suite 330,
+ Boston, MA 02111-1307, USA. */
+
+/* As a special exception, when this file is copied by Bison into a
+ Bison output file, you may use that output file without restriction.
+ This special exception was added by the Free Software Foundation
+ in version 1.24 of Bison. */
+
+/* Written by Richard Stallman by simplifying the original so called
+ ``semantic'' parser. */
+
+/* All symbols defined below should begin with yy or YY, to avoid
+ infringing on user name space. This should be done even for local
+ variables, as they might otherwise be expanded by user macros.
+ There are some unavoidable exceptions within include files to
+ define necessary library symbols; they are noted "INFRINGES ON
+ USER NAME SPACE" below. */
+
+/* Identify Bison output. */
+#define YYBISON 1
+
+/* Skeleton name. */
+#define YYSKELETON_NAME "yacc.c"
+
+/* Pure parsers. */
+#define YYPURE 0
+
+/* Using locations. */
+#define YYLSP_NEEDED 0
+
+
+
+/* Tokens. */
+#ifndef YYTOKENTYPE
+# define YYTOKENTYPE
+ /* Put the tokens into the symbol table, so that GDB and other debuggers
+ know about them. */
+ enum yytokentype {
+ STRING = 258,
+ CONSTANT = 259
+ };
+#endif
+#define STRING 258
+#define CONSTANT 259
+
+
+
+
+/* Copy the first part of user declarations. */
+#line 6 "json.y"
+
+#include <tcl.h>
+#include <ctype.h>
+#include <math.h>
+#include <string.h>
+#include <stdlib.h>
+#include <assert.h>
+
+#include <json_y.h>
+
+#define TOKEN(tok) TRACE (("TOKEN %s\n", tok))
+#define TOKEN1(tok) TRACE (("TOKEN %s (%s)\n", tok, Tcl_GetString(context->obj)))
+#define REDUCE(rule) TRACE (("REDUCE %s\n", rule))
+
+#define TRUE_O (Tcl_NewStringObj("true", 4))
+#define FALSE_O (Tcl_NewStringObj("false", 5))
+#define NULL_O (Tcl_NewStringObj("null", 4))
+
+static void jsonerror(struct context *, const char *);
+static int jsonlexp(struct context *context);
+
+#define YYPARSE_PARAM_TYPE void *
+#define YYPARSE_PARAM context
+#define YYPARSE_PARAM_DECL
+
+#define yylex() jsonlexp(context)
+#define yyerror(msg) jsonerror(context, msg)
+
+#ifndef YYBISON
+static int yyparse(YYPARSE_PARAM_TYPE YYPARSE_PARAM);
+#endif
+
+
+
+/* Enabling traces. */
+#ifndef YYDEBUG
+# define YYDEBUG 0
+#endif
+
+/* Enabling verbose error messages. */
+#ifdef YYERROR_VERBOSE
+# undef YYERROR_VERBOSE
+# define YYERROR_VERBOSE 1
+#else
+# define YYERROR_VERBOSE 0
+#endif
+
+#if ! defined (YYSTYPE) && ! defined (YYSTYPE_IS_DECLARED)
+#line 40 "json.y"
+typedef union YYSTYPE {
+ Tcl_Obj *obj;
+ struct {
+ Tcl_Obj *key;
+ Tcl_Obj *val;
+ } keyval;
+} YYSTYPE;
+/* Line 190 of yacc.c. */
+#line 126 "json.tab.c"
+# define yystype YYSTYPE /* obsolescent; will be withdrawn */
+# define YYSTYPE_IS_DECLARED 1
+# define YYSTYPE_IS_TRIVIAL 1
+#endif
+
+
+
+/* Copy the second part of user declarations. */
+
+
+/* Line 213 of yacc.c. */
+#line 138 "json.tab.c"
+
+#if ! defined (yyoverflow) || YYERROR_VERBOSE
+
+# ifndef YYFREE
+# define YYFREE free
+# endif
+# ifndef YYMALLOC
+# define YYMALLOC malloc
+# endif
+
+/* The parser invokes alloca or malloc; define the necessary symbols. */
+
+# ifdef YYSTACK_USE_ALLOCA
+# if YYSTACK_USE_ALLOCA
+# ifdef __GNUC__
+# define YYSTACK_ALLOC __builtin_alloca
+# else
+# define YYSTACK_ALLOC alloca
+# endif
+# endif
+# endif
+
+# ifdef YYSTACK_ALLOC
+ /* Pacify GCC's `empty if-body' warning. */
+# define YYSTACK_FREE(Ptr) do { /* empty */; } while (0)
+# else
+# if defined (__STDC__) || defined (__cplusplus)
+# include <stdlib.h> /* INFRINGES ON USER NAME SPACE */
+# define YYSIZE_T size_t
+# endif
+# define YYSTACK_ALLOC YYMALLOC
+# define YYSTACK_FREE YYFREE
+# endif
+#endif /* ! defined (yyoverflow) || YYERROR_VERBOSE */
+
+
+#if (! defined (yyoverflow) \
+ && (! defined (__cplusplus) \
+ || (defined (YYSTYPE_IS_TRIVIAL) && YYSTYPE_IS_TRIVIAL)))
+
+/* A type that is properly aligned for any stack member. */
+union yyalloc
+{
+ short int yyss;
+ YYSTYPE yyvs;
+ };
+
+/* The size of the maximum gap between one aligned stack and the next. */
+# define YYSTACK_GAP_MAXIMUM (sizeof (union yyalloc) - 1)
+
+/* The size of an array large to enough to hold all stacks, each with
+ N elements. */
+# define YYSTACK_BYTES(N) \
+ ((N) * (sizeof (short int) + sizeof (YYSTYPE)) \
+ + YYSTACK_GAP_MAXIMUM)
+
+/* Copy COUNT objects from FROM to TO. The source and destination do
+ not overlap. */
+# ifndef YYCOPY
+# if defined (__GNUC__) && 1 < __GNUC__
+# define YYCOPY(To, From, Count) \
+ __builtin_memcpy (To, From, (Count) * sizeof (*(From)))
+# else
+# define YYCOPY(To, From, Count) \
+ do \
+ { \
+ register YYSIZE_T yyi; \
+ for (yyi = 0; yyi < (Count); yyi++) \
+ (To)[yyi] = (From)[yyi]; \
+ } \
+ while (0)
+# endif
+# endif
+
+/* Relocate STACK from its old location to the new one. The
+ local variables YYSIZE and YYSTACKSIZE give the old and new number of
+ elements in the stack, and YYPTR gives the new location of the
+ stack. Advance YYPTR to a properly aligned location for the next
+ stack. */
+# define YYSTACK_RELOCATE(Stack) \
+ do \
+ { \
+ YYSIZE_T yynewbytes; \
+ YYCOPY (&yyptr->Stack, Stack, yysize); \
+ Stack = &yyptr->Stack; \
+ yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \
+ yyptr += yynewbytes / sizeof (*yyptr); \
+ } \
+ while (0)
+
+#endif
+
+#if defined (__STDC__) || defined (__cplusplus)
+ typedef signed char yysigned_char;
+#else
+ typedef short int yysigned_char;
+#endif
+
+/* YYFINAL -- State number of the termination state. */
+#define YYFINAL 18
+/* YYLAST -- Last index in YYTABLE. */
+#define YYLAST 23
+
+/* YYNTOKENS -- Number of terminals. */
+#define YYNTOKENS 11
+/* YYNNTS -- Number of nonterminals. */
+#define YYNNTS 10
+/* YYNRULES -- Number of rules. */
+#define YYNRULES 17
+/* YYNRULES -- Number of states. */
+#define YYNSTATES 27
+
+/* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */
+#define YYUNDEFTOK 2
+#define YYMAXUTOK 259
+
+#define YYTRANSLATE(YYX) \
+ ((unsigned int) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK)
+
+/* YYTRANSLATE[YYLEX] -- Bison symbol number corresponding to YYLEX. */
+static const unsigned char yytranslate[] =
+{
+ 0, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 9, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 10, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 7, 2, 8, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 5, 2, 6, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 1, 2, 3, 4
+};
+
+#if YYDEBUG
+/* YYPRHS[YYN] -- Index of the first RHS symbol of rule number YYN in
+ YYRHS. */
+static const unsigned char yyprhs[] =
+{
+ 0, 0, 3, 5, 7, 11, 14, 18, 21, 23,
+ 27, 29, 33, 37, 39, 41, 43, 45
+};
+
+/* YYRHS -- A `-1'-separated list of the rules' RHS. */
+static const yysigned_char yyrhs[] =
+{
+ 12, 0, -1, 13, -1, 20, -1, 5, 17, 6,
+ -1, 5, 6, -1, 7, 16, 8, -1, 7, 8,
+ -1, 20, -1, 16, 9, 20, -1, 18, -1, 17,
+ 9, 18, -1, 19, 10, 20, -1, 3, -1, 4,
+ -1, 19, -1, 14, -1, 15, -1
+};
+
+/* YYRLINE[YYN] -- source line where rule number YYN was defined. */
+static const unsigned char yyrline[] =
+{
+ 0, 62, 62, 74, 77, 81, 87, 91, 97, 101,
+ 108, 114, 122, 129, 135, 139, 140, 141
+};
+#endif
+
+#if YYDEBUG || YYERROR_VERBOSE
+/* YYTNME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM.
+ First, the terminals, then, starting at YYNTOKENS, nonterminals. */
+static const char *const yytname[] =
+{
+ "$end", "error", "$undefined", "STRING", "CONSTANT", "'{'", "'}'",
+ "'['", "']'", "','", "':'", "$accept", "tree", "json", "object", "list",
+ "values", "members", "member", "string", "value", 0
+};
+#endif
+
+# ifdef YYPRINT
+/* YYTOKNUM[YYLEX-NUM] -- Internal token number corresponding to
+ token YYLEX-NUM. */
+static const unsigned short int yytoknum[] =
+{
+ 0, 256, 257, 258, 259, 123, 125, 91, 93, 44,
+ 58
+};
+# endif
+
+/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */
+static const unsigned char yyr1[] =
+{
+ 0, 11, 12, 13, 14, 14, 15, 15, 16, 16,
+ 17, 17, 18, 19, 20, 20, 20, 20
+};
+
+/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */
+static const unsigned char yyr2[] =
+{
+ 0, 2, 1, 1, 3, 2, 3, 2, 1, 3,
+ 1, 3, 3, 1, 1, 1, 1, 1
+};
+
+/* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state
+ STATE-NUM when YYTABLE doesn't specify something else to do. Zero
+ means the default is an error. */
+static const unsigned char yydefact[] =
+{
+ 0, 13, 14, 0, 0, 0, 2, 16, 17, 15,
+ 3, 5, 0, 10, 0, 7, 0, 8, 1, 4,
+ 0, 0, 6, 0, 11, 12, 9
+};
+
+/* YYDEFGOTO[NTERM-NUM]. */
+static const yysigned_char yydefgoto[] =
+{
+ -1, 5, 6, 7, 8, 16, 12, 13, 9, 10
+};
+
+/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing
+ STATE-NUM. */
+#define YYPACT_NINF -6
+static const yysigned_char yypact[] =
+{
+ 5, -6, -6, 8, -1, 15, -6, -6, -6, -6,
+ -6, -6, 7, -6, -5, -6, 12, -6, -6, -6,
+ 19, 5, -6, 5, -6, -6, -6
+};
+
+/* YYPGOTO[NTERM-NUM]. */
+static const yysigned_char yypgoto[] =
+{
+ -6, -6, -6, -6, -6, -6, -6, 3, -2, -4
+};
+
+/* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If
+ positive, shift that token. If negative, reduce the rule which
+ number is the opposite. If zero, do what YYDEFACT says.
+ If YYTABLE_NINF, syntax error. */
+#define YYTABLE_NINF -1
+static const unsigned char yytable[] =
+{
+ 17, 14, 1, 2, 3, 21, 4, 15, 1, 2,
+ 3, 1, 4, 19, 11, 18, 20, 25, 14, 26,
+ 22, 23, 1, 24
+};
+
+static const unsigned char yycheck[] =
+{
+ 4, 3, 3, 4, 5, 10, 7, 8, 3, 4,
+ 5, 3, 7, 6, 6, 0, 9, 21, 20, 23,
+ 8, 9, 3, 20
+};
+
+/* YYSTOS[STATE-NUM] -- The (internal number of the) accessing
+ symbol of state STATE-NUM. */
+static const unsigned char yystos[] =
+{
+ 0, 3, 4, 5, 7, 12, 13, 14, 15, 19,
+ 20, 6, 17, 18, 19, 8, 16, 20, 0, 6,
+ 9, 10, 8, 9, 18, 20, 20
+};
+
+#if ! defined (YYSIZE_T) && defined (__SIZE_TYPE__)
+# define YYSIZE_T __SIZE_TYPE__
+#endif
+#if ! defined (YYSIZE_T) && defined (size_t)
+# define YYSIZE_T size_t
+#endif
+#if ! defined (YYSIZE_T)
+# if defined (__STDC__) || defined (__cplusplus)
+# include <stddef.h> /* INFRINGES ON USER NAME SPACE */
+# define YYSIZE_T size_t
+# endif
+#endif
+#if ! defined (YYSIZE_T)
+# define YYSIZE_T unsigned int
+#endif
+
+#define yyerrok (yyerrstatus = 0)
+#define yyclearin (yychar = YYEMPTY)
+#define YYEMPTY (-2)
+#define YYEOF 0
+
+#define YYACCEPT goto yyacceptlab
+#define YYABORT goto yyabortlab
+#define YYERROR goto yyerrorlab
+
+
+/* Like YYERROR except do call yyerror. This remains here temporarily
+ to ease the transition to the new meaning of YYERROR, for GCC.
+ Once GCC version 2 has supplanted version 1, this can go. */
+
+#define YYFAIL goto yyerrlab
+
+#define YYRECOVERING() (!!yyerrstatus)
+
+#define YYBACKUP(Token, Value) \
+do \
+ if (yychar == YYEMPTY && yylen == 1) \
+ { \
+ yychar = (Token); \
+ yylval = (Value); \
+ yytoken = YYTRANSLATE (yychar); \
+ YYPOPSTACK; \
+ goto yybackup; \
+ } \
+ else \
+ { \
+ yyerror ("syntax error: cannot back up");\
+ YYERROR; \
+ } \
+while (0)
+
+
+#define YYTERROR 1
+#define YYERRCODE 256
+
+
+/* YYLLOC_DEFAULT -- Set CURRENT to span from RHS[1] to RHS[N].
+ If N is 0, then set CURRENT to the empty location which ends
+ the previous symbol: RHS[0] (always defined). */
+
+#define YYRHSLOC(Rhs, K) ((Rhs)[K])
+#ifndef YYLLOC_DEFAULT
+# define YYLLOC_DEFAULT(Current, Rhs, N) \
+ do \
+ if (N) \
+ { \
+ (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \
+ (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \
+ (Current).last_line = YYRHSLOC (Rhs, N).last_line; \
+ (Current).last_column = YYRHSLOC (Rhs, N).last_column; \
+ } \
+ else \
+ { \
+ (Current).first_line = (Current).last_line = \
+ YYRHSLOC (Rhs, 0).last_line; \
+ (Current).first_column = (Current).last_column = \
+ YYRHSLOC (Rhs, 0).last_column; \
+ } \
+ while (0)
+#endif
+
+
+/* YY_LOCATION_PRINT -- Print the location on the stream.
+ This macro was not mandated originally: define only if we know
+ we won't break user code: when these are the locations we know. */
+
+#ifndef YY_LOCATION_PRINT
+# if YYLTYPE_IS_TRIVIAL
+# define YY_LOCATION_PRINT(File, Loc) \
+ fprintf (File, "%d.%d-%d.%d", \
+ (Loc).first_line, (Loc).first_column, \
+ (Loc).last_line, (Loc).last_column)
+# else
+# define YY_LOCATION_PRINT(File, Loc) ((void) 0)
+# endif
+#endif
+
+
+/* YYLEX -- calling `yylex' with the right arguments. */
+
+#ifdef YYLEX_PARAM
+# define YYLEX yylex (YYLEX_PARAM)
+#else
+# define YYLEX yylex ()
+#endif
+
+/* Enable debugging if requested. */
+#if YYDEBUG
+
+# ifndef YYFPRINTF
+# include <stdio.h> /* INFRINGES ON USER NAME SPACE */
+# define YYFPRINTF fprintf
+# endif
+
+# define YYDPRINTF(Args) \
+do { \
+ if (yydebug) \
+ YYFPRINTF Args; \
+} while (0)
+
+# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \
+do { \
+ if (yydebug) \
+ { \
+ YYFPRINTF (stderr, "%s ", Title); \
+ yysymprint (stderr, \
+ Type, Value); \
+ YYFPRINTF (stderr, "\n"); \
+ } \
+} while (0)
+
+/*------------------------------------------------------------------.
+| yy_stack_print -- Print the state stack from its BOTTOM up to its |
+| TOP (included). |
+`------------------------------------------------------------------*/
+
+#if defined (__STDC__) || defined (__cplusplus)
+static void
+yy_stack_print (short int *bottom, short int *top)
+#else
+static void
+yy_stack_print (bottom, top)
+ short int *bottom;
+ short int *top;
+#endif
+{
+ YYFPRINTF (stderr, "Stack now");
+ for (/* Nothing. */; bottom <= top; ++bottom)
+ YYFPRINTF (stderr, " %d", *bottom);
+ YYFPRINTF (stderr, "\n");
+}
+
+# define YY_STACK_PRINT(Bottom, Top) \
+do { \
+ if (yydebug) \
+ yy_stack_print ((Bottom), (Top)); \
+} while (0)
+
+
+/*------------------------------------------------.
+| Report that the YYRULE is going to be reduced. |
+`------------------------------------------------*/
+
+#if defined (__STDC__) || defined (__cplusplus)
+static void
+yy_reduce_print (int yyrule)
+#else
+static void
+yy_reduce_print (yyrule)
+ int yyrule;
+#endif
+{
+ int yyi;
+ unsigned int yylno = yyrline[yyrule];
+ YYFPRINTF (stderr, "Reducing stack by rule %d (line %u), ",
+ yyrule - 1, yylno);
+ /* Print the symbols being reduced, and their result. */
+ for (yyi = yyprhs[yyrule]; 0 <= yyrhs[yyi]; yyi++)
+ YYFPRINTF (stderr, "%s ", yytname [yyrhs[yyi]]);
+ YYFPRINTF (stderr, "-> %s\n", yytname [yyr1[yyrule]]);
+}
+
+# define YY_REDUCE_PRINT(Rule) \
+do { \
+ if (yydebug) \
+ yy_reduce_print (Rule); \
+} while (0)
+
+/* Nonzero means print parse trace. It is left uninitialized so that
+ multiple parsers can coexist. */
+int yydebug;
+#else /* !YYDEBUG */
+# define YYDPRINTF(Args)
+# define YY_SYMBOL_PRINT(Title, Type, Value, Location)
+# define YY_STACK_PRINT(Bottom, Top)
+# define YY_REDUCE_PRINT(Rule)
+#endif /* !YYDEBUG */
+
+
+/* YYINITDEPTH -- initial size of the parser's stacks. */
+#ifndef YYINITDEPTH
+# define YYINITDEPTH 200
+#endif
+
+/* YYMAXDEPTH -- maximum size the stacks can grow to (effective only
+ if the built-in stack extension method is used).
+
+ Do not make this value too large; the results are undefined if
+ SIZE_MAX < YYSTACK_BYTES (YYMAXDEPTH)
+ evaluated with infinite-precision integer arithmetic. */
+
+#ifndef YYMAXDEPTH
+# define YYMAXDEPTH 10000
+#endif
+
+
+
+#if YYERROR_VERBOSE
+
+# ifndef yystrlen
+# if defined (__GLIBC__) && defined (_STRING_H)
+# define yystrlen strlen
+# else
+/* Return the length of YYSTR. */
+static YYSIZE_T
+# if defined (__STDC__) || defined (__cplusplus)
+yystrlen (const char *yystr)
+# else
+yystrlen (yystr)
+ const char *yystr;
+# endif
+{
+ register const char *yys = yystr;
+
+ while (*yys++ != '\0')
+ continue;
+
+ return yys - yystr - 1;
+}
+# endif
+# endif
+
+# ifndef yystpcpy
+# if defined (__GLIBC__) && defined (_STRING_H) && defined (_GNU_SOURCE)
+# define yystpcpy stpcpy
+# else
+/* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in
+ YYDEST. */
+static char *
+# if defined (__STDC__) || defined (__cplusplus)
+yystpcpy (char *yydest, const char *yysrc)
+# else
+yystpcpy (yydest, yysrc)
+ char *yydest;
+ const char *yysrc;
+# endif
+{
+ register char *yyd = yydest;
+ register const char *yys = yysrc;
+
+ while ((*yyd++ = *yys++) != '\0')
+ continue;
+
+ return yyd - 1;
+}
+# endif
+# endif
+
+#endif /* !YYERROR_VERBOSE */
+
+
+
+#if YYDEBUG
+/*--------------------------------.
+| Print this symbol on YYOUTPUT. |
+`--------------------------------*/
+
+#if defined (__STDC__) || defined (__cplusplus)
+static void
+yysymprint (FILE *yyoutput, int yytype, YYSTYPE *yyvaluep)
+#else
+static void
+yysymprint (yyoutput, yytype, yyvaluep)
+ FILE *yyoutput;
+ int yytype;
+ YYSTYPE *yyvaluep;
+#endif
+{
+ /* Pacify ``unused variable'' warnings. */
+ (void) yyvaluep;
+
+ if (yytype < YYNTOKENS)
+ YYFPRINTF (yyoutput, "token %s (", yytname[yytype]);
+ else
+ YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]);
+
+
+# ifdef YYPRINT
+ if (yytype < YYNTOKENS)
+ YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep);
+# endif
+ switch (yytype)
+ {
+ default:
+ break;
+ }
+ YYFPRINTF (yyoutput, ")");
+}
+
+#endif /* ! YYDEBUG */
+/*-----------------------------------------------.
+| Release the memory associated to this symbol. |
+`-----------------------------------------------*/
+
+#if defined (__STDC__) || defined (__cplusplus)
+static void
+yydestruct (const char *yymsg, int yytype, YYSTYPE *yyvaluep)
+#else
+static void
+yydestruct (yymsg, yytype, yyvaluep)
+ const char *yymsg;
+ int yytype;
+ YYSTYPE *yyvaluep;
+#endif
+{
+ /* Pacify ``unused variable'' warnings. */
+ (void) yyvaluep;
+
+ if (!yymsg)
+ yymsg = "Deleting";
+ YY_SYMBOL_PRINT (yymsg, yytype, yyvaluep, yylocationp);
+
+ switch (yytype)
+ {
+
+ default:
+ break;
+ }
+}
+
+
+/* Prevent warnings from -Wmissing-prototypes. */
+
+#ifdef YYPARSE_PARAM
+# if defined (__STDC__) || defined (__cplusplus)
+int yyparse (void *YYPARSE_PARAM);
+# else
+int yyparse ();
+# endif
+#else /* ! YYPARSE_PARAM */
+#if defined (__STDC__) || defined (__cplusplus)
+int yyparse (void);
+#else
+int yyparse ();
+#endif
+#endif /* ! YYPARSE_PARAM */
+
+
+
+/* The look-ahead symbol. */
+int yychar;
+
+/* The semantic value of the look-ahead symbol. */
+YYSTYPE yylval;
+
+/* Number of syntax errors so far. */
+int yynerrs;
+
+
+
+/*----------.
+| yyparse. |
+`----------*/
+
+#ifdef YYPARSE_PARAM
+# if defined (__STDC__) || defined (__cplusplus)
+int yyparse (void *YYPARSE_PARAM)
+# else
+int yyparse (YYPARSE_PARAM)
+ void *YYPARSE_PARAM;
+# endif
+#else /* ! YYPARSE_PARAM */
+#if defined (__STDC__) || defined (__cplusplus)
+int
+yyparse (void)
+#else
+int
+yyparse ()
+
+#endif
+#endif
+{
+
+ register int yystate;
+ register int yyn;
+ int yyresult;
+ /* Number of tokens to shift before error messages enabled. */
+ int yyerrstatus;
+ /* Look-ahead token as an internal (translated) token number. */
+ int yytoken = 0;
+
+ /* Three stacks and their tools:
+ `yyss': related to states,
+ `yyvs': related to semantic values,
+ `yyls': related to locations.
+
+ Refer to the stacks thru separate pointers, to allow yyoverflow
+ to reallocate them elsewhere. */
+
+ /* The state stack. */
+ short int yyssa[YYINITDEPTH];
+ short int *yyss = yyssa;
+ register short int *yyssp;
+
+ /* The semantic value stack. */
+ YYSTYPE yyvsa[YYINITDEPTH];
+ YYSTYPE *yyvs = yyvsa;
+ register YYSTYPE *yyvsp;
+
+
+
+#define YYPOPSTACK (yyvsp--, yyssp--)
+
+ YYSIZE_T yystacksize = YYINITDEPTH;
+
+ /* The variables used to return semantic value and location from the
+ action routines. */
+ YYSTYPE yyval;
+
+
+ /* When reducing, the number of symbols on the RHS of the reduced
+ rule. */
+ int yylen;
+
+ YYDPRINTF ((stderr, "Starting parse\n"));
+
+ yystate = 0;
+ yyerrstatus = 0;
+ yynerrs = 0;
+ yychar = YYEMPTY; /* Cause a token to be read. */
+
+ /* Initialize stack pointers.
+ Waste one element of value and location stack
+ so that they stay on the same level as the state stack.
+ The wasted elements are never initialized. */
+
+ yyssp = yyss;
+ yyvsp = yyvs;
+
+
+ yyvsp[0] = yylval;
+
+ goto yysetstate;
+
+/*------------------------------------------------------------.
+| yynewstate -- Push a new state, which is found in yystate. |
+`------------------------------------------------------------*/
+ yynewstate:
+ /* In all cases, when you get here, the value and location stacks
+ have just been pushed. so pushing a state here evens the stacks.
+ */
+ yyssp++;
+
+ yysetstate:
+ *yyssp = yystate;
+
+ if (yyss + yystacksize - 1 <= yyssp)
+ {
+ /* Get the current used size of the three stacks, in elements. */
+ YYSIZE_T yysize = yyssp - yyss + 1;
+
+#ifdef yyoverflow
+ {
+ /* Give user a chance to reallocate the stack. Use copies of
+ these so that the &'s don't force the real ones into
+ memory. */
+ YYSTYPE *yyvs1 = yyvs;
+ short int *yyss1 = yyss;
+
+
+ /* Each stack pointer address is followed by the size of the
+ data in use in that stack, in bytes. This used to be a
+ conditional around just the two extra args, but that might
+ be undefined if yyoverflow is a macro. */
+ yyoverflow ("parser stack overflow",
+ &yyss1, yysize * sizeof (*yyssp),
+ &yyvs1, yysize * sizeof (*yyvsp),
+
+ &yystacksize);
+
+ yyss = yyss1;
+ yyvs = yyvs1;
+ }
+#else /* no yyoverflow */
+# ifndef YYSTACK_RELOCATE
+ goto yyoverflowlab;
+# else
+ /* Extend the stack our own way. */
+ if (YYMAXDEPTH <= yystacksize)
+ goto yyoverflowlab;
+ yystacksize *= 2;
+ if (YYMAXDEPTH < yystacksize)
+ yystacksize = YYMAXDEPTH;
+
+ {
+ short int *yyss1 = yyss;
+ union yyalloc *yyptr =
+ (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize));
+ if (! yyptr)
+ goto yyoverflowlab;
+ YYSTACK_RELOCATE (yyss);
+ YYSTACK_RELOCATE (yyvs);
+
+# undef YYSTACK_RELOCATE
+ if (yyss1 != yyssa)
+ YYSTACK_FREE (yyss1);
+ }
+# endif
+#endif /* no yyoverflow */
+
+ yyssp = yyss + yysize - 1;
+ yyvsp = yyvs + yysize - 1;
+
+
+ YYDPRINTF ((stderr, "Stack size increased to %lu\n",
+ (unsigned long int) yystacksize));
+
+ if (yyss + yystacksize - 1 <= yyssp)
+ YYABORT;
+ }
+
+ YYDPRINTF ((stderr, "Entering state %d\n", yystate));
+
+ goto yybackup;
+
+/*-----------.
+| yybackup. |
+`-----------*/
+yybackup:
+
+/* Do appropriate processing given the current state. */
+/* Read a look-ahead token if we need one and don't already have one. */
+/* yyresume: */
+
+ /* First try to decide what to do without reference to look-ahead token. */
+
+ yyn = yypact[yystate];
+ if (yyn == YYPACT_NINF)
+ goto yydefault;
+
+ /* Not known => get a look-ahead token if don't already have one. */
+
+ /* YYCHAR is either YYEMPTY or YYEOF or a valid look-ahead symbol. */
+ if (yychar == YYEMPTY)
+ {
+ YYDPRINTF ((stderr, "Reading a token: "));
+ yychar = YYLEX;
+ }
+
+ if (yychar <= YYEOF)
+ {
+ yychar = yytoken = YYEOF;
+ YYDPRINTF ((stderr, "Now at end of input.\n"));
+ }
+ else
+ {
+ yytoken = YYTRANSLATE (yychar);
+ YY_SYMBOL_PRINT ("Next token is", yytoken, &yylval, &yylloc);
+ }
+
+ /* If the proper action on seeing token YYTOKEN is to reduce or to
+ detect an error, take that action. */
+ yyn += yytoken;
+ if (yyn < 0 || YYLAST < yyn || yycheck[yyn] != yytoken)
+ goto yydefault;
+ yyn = yytable[yyn];
+ if (yyn <= 0)
+ {
+ if (yyn == 0 || yyn == YYTABLE_NINF)
+ goto yyerrlab;
+ yyn = -yyn;
+ goto yyreduce;
+ }
+
+ if (yyn == YYFINAL)
+ YYACCEPT;
+
+ /* Shift the look-ahead token. */
+ YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc);
+
+ /* Discard the token being shifted unless it is eof. */
+ if (yychar != YYEOF)
+ yychar = YYEMPTY;
+
+ *++yyvsp = yylval;
+
+
+ /* Count tokens shifted since error; after three, turn off error
+ status. */
+ if (yyerrstatus)
+ yyerrstatus--;
+
+ yystate = yyn;
+ goto yynewstate;
+
+
+/*-----------------------------------------------------------.
+| yydefault -- do the default action for the current state. |
+`-----------------------------------------------------------*/
+yydefault:
+ yyn = yydefact[yystate];
+ if (yyn == 0)
+ goto yyerrlab;
+ goto yyreduce;
+
+
+/*-----------------------------.
+| yyreduce -- Do a reduction. |
+`-----------------------------*/
+yyreduce:
+ /* yyn is the number of a rule to reduce with. */
+ yylen = yyr2[yyn];
+
+ /* If YYLEN is nonzero, implement the default value of the action:
+ `$$ = $1'.
+
+ Otherwise, the following line sets YYVAL to garbage.
+ This behavior is undocumented and Bison
+ users should not rely upon it. Assigning to YYVAL
+ unconditionally makes the parser a bit smaller, and it avoids a
+ GCC warning that YYVAL may be used uninitialized. */
+ yyval = yyvsp[1-yylen];
+
+
+ YY_REDUCE_PRINT (yyn);
+ switch (yyn)
+ {
+ case 2:
+#line 63 "json.y"
+ {
+ struct context *c = context;
+ REDUCE("TREE");
+ if (c->I) {
+ Tcl_SetObjResult(c->I, (yyvsp[0].obj));
+ TRACE ((" RESULT (%s)\n", Tcl_GetString((yyvsp[0].obj))));
+ }
+ c->result = TCL_OK;
+ ;}
+ break;
+
+ case 4:
+#line 78 "json.y"
+ {
+ (yyval.obj) = (yyvsp[-1].obj);
+ ;}
+ break;
+
+ case 5:
+#line 82 "json.y"
+ {
+ (yyval.obj) = Tcl_NewObj();
+ ;}
+ break;
+
+ case 6:
+#line 88 "json.y"
+ {
+ (yyval.obj) = (yyvsp[-1].obj);
+ ;}
+ break;
+
+ case 7:
+#line 92 "json.y"
+ {
+ (yyval.obj) = Tcl_NewObj();
+ ;}
+ break;
+
+ case 8:
+#line 98 "json.y"
+ {
+ (yyval.obj) = Tcl_NewListObj(1, &(yyvsp[0].obj));
+ ;}
+ break;
+
+ case 9:
+#line 102 "json.y"
+ {
+ Tcl_ListObjAppendElement(NULL, (yyvsp[-2].obj), (yyvsp[0].obj));
+ (yyval.obj) = (yyvsp[-2].obj);
+ ;}
+ break;
+
+ case 10:
+#line 109 "json.y"
+ {
+ (yyval.obj) = Tcl_NewListObj(0, NULL);
+ Tcl_ListObjAppendElement(NULL, (yyval.obj), (yyvsp[0].keyval).key);
+ Tcl_ListObjAppendElement(NULL, (yyval.obj), (yyvsp[0].keyval).val);
+ ;}
+ break;
+
+ case 11:
+#line 115 "json.y"
+ {
+ Tcl_ListObjAppendElement(NULL, (yyvsp[-2].obj), (yyvsp[0].keyval).key);
+ Tcl_ListObjAppendElement(NULL, (yyvsp[-2].obj), (yyvsp[0].keyval).val);
+ (yyval.obj) = (yyvsp[-2].obj);
+ ;}
+ break;
+
+ case 12:
+#line 123 "json.y"
+ {
+ (yyval.keyval).key = (yyvsp[-2].obj);
+ (yyval.keyval).val = (yyvsp[0].obj);
+ ;}
+ break;
+
+ case 13:
+#line 130 "json.y"
+ {
+ (yyval.obj) = ((struct context *)context)->obj;
+ ;}
+ break;
+
+ case 14:
+#line 136 "json.y"
+ {
+ (yyval.obj) = ((struct context *)context)->obj;
+ ;}
+ break;
+
+
+ }
+
+/* Line 1037 of yacc.c. */
+#line 1148 "json.tab.c"
+
+ yyvsp -= yylen;
+ yyssp -= yylen;
+
+
+ YY_STACK_PRINT (yyss, yyssp);
+
+ *++yyvsp = yyval;
+
+
+ /* Now `shift' the result of the reduction. Determine what state
+ that goes to, based on the state we popped back to and the rule
+ number reduced by. */
+
+ yyn = yyr1[yyn];
+
+ yystate = yypgoto[yyn - YYNTOKENS] + *yyssp;
+ if (0 <= yystate && yystate <= YYLAST && yycheck[yystate] == *yyssp)
+ yystate = yytable[yystate];
+ else
+ yystate = yydefgoto[yyn - YYNTOKENS];
+
+ goto yynewstate;
+
+
+/*------------------------------------.
+| yyerrlab -- here on detecting error |
+`------------------------------------*/
+yyerrlab:
+ /* If not already recovering from an error, report this error. */
+ if (!yyerrstatus)
+ {
+ ++yynerrs;
+#if YYERROR_VERBOSE
+ yyn = yypact[yystate];
+
+ if (YYPACT_NINF < yyn && yyn < YYLAST)
+ {
+ YYSIZE_T yysize = 0;
+ int yytype = YYTRANSLATE (yychar);
+ const char* yyprefix;
+ char *yymsg;
+ int yyx;
+
+ /* Start YYX at -YYN if negative to avoid negative indexes in
+ YYCHECK. */
+ int yyxbegin = yyn < 0 ? -yyn : 0;
+
+ /* Stay within bounds of both yycheck and yytname. */
+ int yychecklim = YYLAST - yyn;
+ int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS;
+ int yycount = 0;
+
+ yyprefix = ", expecting ";
+ for (yyx = yyxbegin; yyx < yyxend; ++yyx)
+ if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR)
+ {
+ yysize += yystrlen (yyprefix) + yystrlen (yytname [yyx]);
+ yycount += 1;
+ if (yycount == 5)
+ {
+ yysize = 0;
+ break;
+ }
+ }
+ yysize += (sizeof ("syntax error, unexpected ")
+ + yystrlen (yytname[yytype]));
+ yymsg = (char *) YYSTACK_ALLOC (yysize);
+ if (yymsg != 0)
+ {
+ char *yyp = yystpcpy (yymsg, "syntax error, unexpected ");
+ yyp = yystpcpy (yyp, yytname[yytype]);
+
+ if (yycount < 5)
+ {
+ yyprefix = ", expecting ";
+ for (yyx = yyxbegin; yyx < yyxend; ++yyx)
+ if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR)
+ {
+ yyp = yystpcpy (yyp, yyprefix);
+ yyp = yystpcpy (yyp, yytname[yyx]);
+ yyprefix = " or ";
+ }
+ }
+ yyerror (yymsg);
+ YYSTACK_FREE (yymsg);
+ }
+ else
+ yyerror ("syntax error; also virtual memory exhausted");
+ }
+ else
+#endif /* YYERROR_VERBOSE */
+ yyerror ("syntax error");
+ }
+
+
+
+ if (yyerrstatus == 3)
+ {
+ /* If just tried and failed to reuse look-ahead token after an
+ error, discard it. */
+
+ if (yychar <= YYEOF)
+ {
+ /* If at end of input, pop the error token,
+ then the rest of the stack, then return failure. */
+ if (yychar == YYEOF)
+ for (;;)
+ {
+
+ YYPOPSTACK;
+ if (yyssp == yyss)
+ YYABORT;
+ yydestruct ("Error: popping",
+ yystos[*yyssp], yyvsp);
+ }
+ }
+ else
+ {
+ yydestruct ("Error: discarding", yytoken, &yylval);
+ yychar = YYEMPTY;
+ }
+ }
+
+ /* Else will try to reuse look-ahead token after shifting the error
+ token. */
+ goto yyerrlab1;
+
+
+/*---------------------------------------------------.
+| yyerrorlab -- error raised explicitly by YYERROR. |
+`---------------------------------------------------*/
+yyerrorlab:
+
+#ifdef __GNUC__
+ /* Pacify GCC when the user code never invokes YYERROR and the label
+ yyerrorlab therefore never appears in user code. */
+ if (0)
+ goto yyerrorlab;
+#endif
+
+yyvsp -= yylen;
+ yyssp -= yylen;
+ yystate = *yyssp;
+ goto yyerrlab1;
+
+
+/*-------------------------------------------------------------.
+| yyerrlab1 -- common code for both syntax error and YYERROR. |
+`-------------------------------------------------------------*/
+yyerrlab1:
+ yyerrstatus = 3; /* Each real token shifted decrements this. */
+
+ for (;;)
+ {
+ yyn = yypact[yystate];
+ if (yyn != YYPACT_NINF)
+ {
+ yyn += YYTERROR;
+ if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR)
+ {
+ yyn = yytable[yyn];
+ if (0 < yyn)
+ break;
+ }
+ }
+
+ /* Pop the current state because it cannot handle the error token. */
+ if (yyssp == yyss)
+ YYABORT;
+
+
+ yydestruct ("Error: popping", yystos[yystate], yyvsp);
+ YYPOPSTACK;
+ yystate = *yyssp;
+ YY_STACK_PRINT (yyss, yyssp);
+ }
+
+ if (yyn == YYFINAL)
+ YYACCEPT;
+
+ *++yyvsp = yylval;
+
+
+ /* Shift the error token. */
+ YY_SYMBOL_PRINT ("Shifting", yystos[yyn], yyvsp, yylsp);
+
+ yystate = yyn;
+ goto yynewstate;
+
+
+/*-------------------------------------.
+| yyacceptlab -- YYACCEPT comes here. |
+`-------------------------------------*/
+yyacceptlab:
+ yyresult = 0;
+ goto yyreturn;
+
+/*-----------------------------------.
+| yyabortlab -- YYABORT comes here. |
+`-----------------------------------*/
+yyabortlab:
+ yydestruct ("Error: discarding lookahead",
+ yytoken, &yylval);
+ yychar = YYEMPTY;
+ yyresult = 1;
+ goto yyreturn;
+
+#ifndef yyoverflow
+/*----------------------------------------------.
+| yyoverflowlab -- parser overflow comes here. |
+`----------------------------------------------*/
+yyoverflowlab:
+ yyerror ("parser stack overflow");
+ yyresult = 2;
+ /* Fall through. */
+#endif
+
+yyreturn:
+#ifndef yyoverflow
+ if (yyss != yyssa)
+ YYSTACK_FREE (yyss);
+#endif
+ return yyresult;
+}
+
+
+#line 144 "json.y"
+
+void
+jsonparse (struct context* context)
+{
+ yyparse (context);
+}
+
+#define HAVE(n) (context->remaining >= n)
+
+#define DRAIN(n) context->text += n, context->remaining -= n
+
+#define STORESTRINGSEGMENT() \
+ if (initialized) { \
+ if (context->text != bp) { \
+ Tcl_AppendToObj(context->obj, \
+ bp, context->text - bp); \
+ } \
+ } else { \
+ context->obj = Tcl_NewStringObj( \
+ bp, context->text - bp); \
+ initialized = 1; \
+ }
+
+void
+jsonskip(struct context *context)
+{
+ while (context->remaining) {
+ switch (*context->text) {
+ case '\n':
+ case ' ':
+ case '\t':
+ case '\r':
+ DRAIN(1);
+ continue;
+ }
+ break;
+ }
+}
+
+static int
+jsonlexp(struct context *context)
+{
+ const char *bp = NULL;
+
+ /* Question: Why not plain numbers 1,2 for the states
+ * but these specific hex patterns ?
+ */
+ enum {
+ PLAIN = 0x0000ff00,
+ INSTR = 0x00ff0000
+ } lstate;
+ double d;
+ char *end;
+ const char *p;
+ int initialized = 0;
+
+ /*
+ * Do not auto-lex beyond a full json structure.
+ */
+ if (context->result == TCL_OK) {
+ TOKEN ("<<eof>>");
+ return 0;
+ }
+
+ /*
+ * Quickly skip and ignore whitespace.
+ */
+ while (context->remaining) {
+ switch (*context->text) {
+ case '\n':
+ case ' ':
+ case '\t':
+ case '\r':
+ DRAIN(1);
+ continue;
+ }
+ break;
+ }
+
+ /*
+ * Handle the token following the whitespace. Small state machine to
+ * handle strings and escapes in them, and bare words (various
+ * contants, and numbers).
+ */
+ for (lstate = PLAIN; context->remaining > 0; DRAIN(1)) {
+ if (lstate == INSTR) {
+ if (*context->text == '"') {
+ /*
+ * End of quoted string
+ */
+
+ STORESTRINGSEGMENT();
+ DRAIN(1);
+ TOKEN1 ("STRING");
+ return STRING;
+ }
+
+ if (*context->text == '\\') {
+ /*
+ * Escaped sequence. The 9 sequences specified at json.org
+ * are:
+ * \" \\ \/ \b \f \n \r \t \uXXXX
+ */
+ char buf[TCL_UTF_MAX];
+ int len, consumed;
+
+ STORESTRINGSEGMENT();
+
+ /*
+ * Perform additional checks to restrict the set of accepted
+ * escape sequence to what is allowed by json.org instead of
+ * Tcl_UtfBackslash.
+ */
+
+ if (!HAVE(1)) {
+ Tcl_AppendToObj(context->obj, "\\", 1);
+ yyerror("incomplete escape at <<eof> error");
+ TOKEN("incomplete escape at <<eof>> error");
+ return -1;
+ }
+ switch (context->text[1]) {
+ case '"':
+ case '\\':
+ case '/':
+ case 'b':
+ case 'f':
+ case 'n':
+ case 'r':
+ case 't':
+ break;
+ case 'u':
+ if (!HAVE(5)) {
+ Tcl_AppendToObj(context->obj, "\\u", 2);
+ yyerror("incomplete escape at <<eof> error");
+ TOKEN("incomplete escape at <<eof>> error");
+ return -1;
+ }
+ break;
+ default:
+ Tcl_AppendToObj(context->obj, context->text + 1, 1);
+ yyerror("bad escape");
+ TOKEN("bad escape");
+ return -1;
+ }
+
+ /*
+ * XXX Tcl_UtfBackslash() may be more
+ * XXX permissive, than JSON standard.
+ * XXX But that may be a good thing:
+ * XXX "be generous in what you accept".
+ */
+ len = Tcl_UtfBackslash(context->text,
+ &consumed, buf);
+ DRAIN(consumed - 1);
+ bp = context->text + 1;
+ Tcl_AppendToObj(context->obj, buf, len);
+ }
+ continue;
+ }
+
+ switch (*context->text) {
+ case ',':
+ case '{':
+ case ':':
+ case '}':
+ case '[':
+ case ']':
+ DRAIN(1);
+ TOKEN (context->text[-1]);
+ return context->text[-1];
+ case 't':
+ if ((context->remaining < 4) ||
+ strncmp("rue", context->text + 1, 3))
+ goto bareword;
+ DRAIN(4);
+ context->obj = TRUE_O;
+ TOKEN1 ("CONSTANT");
+ return CONSTANT;
+ case 'f':
+ if ((context->remaining < 5) ||
+ strncmp("alse", context->text + 1, 4))
+ goto bareword;
+ DRAIN(5);
+ context->obj = FALSE_O;
+ TOKEN1 ("CONSTANT");
+ return CONSTANT;
+ case 'n':
+ if ((context->remaining < 4) ||
+ strncmp("ull", context->text + 1, 3))
+ goto bareword;
+ DRAIN(4);
+ context->obj = NULL_O;
+ TOKEN1 ("CONSTANT");
+ return CONSTANT;
+ case '"':
+ bp = context->text + 1;
+ lstate = INSTR;
+ continue;
+ case '\\':
+ yyerror("Escape character outside of string");
+ TOKEN ("escape error");
+ return -1;
+ }
+
+ /*
+ * We already considered the null, true, and false
+ * above, so it can only be a number now.
+ *
+ * NOTE: At this point we do not care about double
+ * versus integer, nor about the possible integer
+ * range. We generate a plain string Tcl_Obj and leave
+ * it to the user of the generated structure to
+ * convert to a number when actually needed. This
+ * defered conversion also ensures that the Tcl and
+ * platform we are building against does not matter
+ * regarding integer range, only the abilities of the
+ * Tcl at runtime.
+ */
+
+ d = strtod(context->text, &end);
+ if (end == context->text)
+ goto bareword; /* Nothing parsed */
+
+ context->obj = Tcl_NewStringObj (context->text,
+ end - context->text);
+
+ context->remaining -= (end - context->text);
+ context->text = end;
+ TOKEN1 ("CONSTANT");
+ return CONSTANT;
+ }
+
+ TOKEN ("<<eof>>");
+ return 0;
+ bareword:
+ yyerror("Bare word encountered");
+ TOKEN ("bare word error");
+ return -1;
+}
+
+#if 0
+int
+jsonlex(struct context *context)
+{
+ const char *bp = NULL;
+
+ /* Question: Why not plain numbers 1,2 for the states
+ * but these specific hex patterns ?
+ */
+ enum {
+ PLAIN = 0x0000ff00,
+ INSTR = 0x00ff0000
+ } lstate;
+ double d;
+ char *end;
+ const char *p;
+ int initialized = 0;
+
+ while (context->remaining) {
+ /* Iterate over the whole string and check all tokens.
+ * Nothing else.
+ */
+
+ /*
+ * Quickly skip and ignore whitespace.
+ */
+ while (context->remaining) {
+ switch (*context->text) {
+ case '\n':
+ case ' ':
+ case '\t':
+ case '\r':
+ DRAIN(1);
+ continue;
+ }
+ break;
+ }
+
+ /*
+ * Handle the token following the whitespace. Small state machine to
+ * handle strings and escapes in them, and bare words (various
+ * contants, and numbers).
+ */
+ for (lstate = PLAIN; context->remaining > 0; DRAIN(1)) {
+ if (lstate == INSTR) {
+ if (*context->text == '"') {
+ /*
+ * End of quoted string
+ */
+ DRAIN(1);
+ goto next_token;
+ }
+
+ if (*context->text == '\\') {
+ /*
+ * Escaped sequence
+ */
+ char buf[TCL_UTF_MAX];
+ int len, consumed;
+
+ /*
+ * XXX Tcl_UtfBackslash() may be more
+ * XXX permissive, than JSON standard.
+ * XXX But that may be a good thing:
+ * XXX "be generous in what you accept".
+ */
+ len = Tcl_UtfBackslash(context->text, &consumed, buf);
+ DRAIN(consumed - 1);
+ }
+ continue;
+ }
+
+ switch (*context->text) {
+ case ',':
+ case '{':
+ case ':':
+ case '}':
+ case '[':
+ case ']':
+ DRAIN(1);
+ goto next_token;
+
+ case 't':
+ if ((context->remaining < 4) ||
+ strncmp("rue", context->text + 1, 3))
+ return -1; /* bare word */
+ DRAIN(4);
+ goto next_token;
+ case 'f':
+ if ((context->remaining < 5) ||
+ strncmp("alse", context->text + 1, 4))
+ return -1; /* bare word */
+ DRAIN(5);
+ goto next_token;
+ case 'n':
+ if ((context->remaining < 4) ||
+ strncmp("ull", context->text + 1, 3))
+ return -1; /* bare word */
+ DRAIN(4);
+ goto next_token;
+ case '"':
+ bp = context->text + 1;
+ lstate = INSTR;
+ continue;
+ case '\\':
+ /* Escape outside string, abort. */
+ return -1;
+ }
+
+ /*
+ * We already considered the null, true, and false
+ * above, so it can only be a number now.
+ *
+ * NOTE: At this point we do not care about double
+ * versus integer, nor about the possible integer
+ * range. We generate a plain string Tcl_Obj and leave
+ * it to the user of the generated structure to
+ * convert to a number when actually needed. This
+ * defered conversion also ensures that the Tcl and
+ * platform we are building against does not matter
+ * regarding integer range, only the abilities of the
+ * Tcl at runtime.
+ */
+
+ d = strtod(context->text, &end);
+ if (end == context->text)
+ return -1; /* bare word */
+
+ context->remaining -= (end - context->text);
+ context->text = end;
+ goto next_token;
+ }
+
+ return 0;
+
+ next_token:
+ continue;
+ }
+}
+#endif
+
+static void
+jsonerror(struct context *context, const char *message)
+{
+ char *fullmessage;
+ char *yytext;
+ int yyleng;
+
+ if (context->has_error) return;
+
+ if (context->obj) {
+ yytext = Tcl_GetStringFromObj(context->obj, &yyleng);
+ fullmessage = Tcl_Alloc(strlen(message) + 63 + yyleng);
+
+ sprintf(fullmessage, "%s %d bytes before end, around ``%.*s''",
+ message, context->remaining, yyleng, yytext);
+ } else {
+ fullmessage = Tcl_Alloc(strlen(message) + 63);
+
+ sprintf(fullmessage, "%s %d bytes before end",
+ message, context->remaining);
+ }
+
+ TRACE ((">>> %s\n",fullmessage));
+ Tcl_SetResult (context->I, fullmessage, TCL_DYNAMIC);
+ Tcl_SetErrorCode (context->I, "JSON", "SYNTAX", NULL);
+ context->has_error = 1;
+}
+
+
diff --git a/tcllib/modules/json/c/json.y b/tcllib/modules/json/c/json.y
new file mode 100644
index 0000000..57c7315
--- /dev/null
+++ b/tcllib/modules/json/c/json.y
@@ -0,0 +1,551 @@
+/*
+ * JSON parser, yacc/bison based. Manual lexer.
+ * Mikhail.
+ */
+
+%{
+#include <tcl.h>
+#include <ctype.h>
+#include <math.h>
+#include <string.h>
+#include <stdlib.h>
+#include <assert.h>
+
+#include <json_y.h>
+
+#define TOKEN(tok) TRACE (("TOKEN %s\n", tok))
+#define TOKEN1(tok) TRACE (("TOKEN %s (%s)\n", tok, Tcl_GetString(context->obj)))
+#define REDUCE(rule) TRACE (("REDUCE %s\n", rule))
+
+#define TRUE_O (Tcl_NewStringObj("true", 4))
+#define FALSE_O (Tcl_NewStringObj("false", 5))
+#define NULL_O (Tcl_NewStringObj("null", 4))
+
+static void jsonerror(struct context *, const char *);
+static int jsonlexp(struct context *context);
+
+#define YYPARSE_PARAM_TYPE void *
+#define YYPARSE_PARAM context
+#define YYPARSE_PARAM_DECL
+
+#define yylex() jsonlexp(context)
+#define yyerror(msg) jsonerror(context, msg)
+
+#ifndef YYBISON
+static int yyparse(YYPARSE_PARAM_TYPE YYPARSE_PARAM);
+#endif
+
+%}
+
+%union {
+ Tcl_Obj *obj;
+ struct {
+ Tcl_Obj *key;
+ Tcl_Obj *val;
+ } keyval;
+};
+
+%token STRING CONSTANT
+
+%type <obj> tree
+%type <obj> json
+%type <obj> object
+%type <obj> list
+%type <obj> values
+%type <obj> members
+%type <obj> value
+%type <obj> string
+%type <keyval> member
+
+%%
+
+tree : json
+ {
+ struct context *c = context;
+ REDUCE("TREE");
+ if (c->I) {
+ Tcl_SetObjResult(c->I, $1);
+ TRACE ((" RESULT (%s)\n", Tcl_GetString($1)));
+ }
+ c->result = TCL_OK;
+ }
+ ;
+
+json : value
+ ;
+
+object : '{' members '}'
+ {
+ $$ = $2;
+ }
+ | '{' '}'
+ {
+ $$ = Tcl_NewObj();
+ }
+ ;
+
+list : '[' values ']'
+ {
+ $$ = $2;
+ }
+ | '[' ']'
+ {
+ $$ = Tcl_NewObj();
+ }
+ ;
+
+values : value
+ {
+ $$ = Tcl_NewListObj(1, &$1);
+ }
+ | values ',' value
+ {
+ Tcl_ListObjAppendElement(NULL, $1, $3);
+ $$ = $1;
+ }
+ ;
+
+members : member
+ {
+ $$ = Tcl_NewListObj(0, NULL);
+ Tcl_ListObjAppendElement(NULL, $$, $1.key);
+ Tcl_ListObjAppendElement(NULL, $$, $1.val);
+ }
+ | members ',' member
+ {
+ Tcl_ListObjAppendElement(NULL, $1, $3.key);
+ Tcl_ListObjAppendElement(NULL, $1, $3.val);
+ $$ = $1;
+ }
+ ;
+
+member : string ':' value
+ {
+ $$.key = $1;
+ $$.val = $3;
+ }
+ ;
+
+string : STRING
+ {
+ $$ = ((struct context *)context)->obj;
+ }
+ ;
+
+value : CONSTANT
+ {
+ $$ = ((struct context *)context)->obj;
+ }
+ | string
+ | object
+ | list
+ ;
+
+%%
+void
+jsonparse (struct context* context)
+{
+ yyparse (context);
+}
+
+#define HAVE(n) (context->remaining >= n)
+
+#define DRAIN(n) context->text += n, context->remaining -= n
+
+#define STORESTRINGSEGMENT() \
+ if (initialized) { \
+ if (context->text != bp) { \
+ Tcl_AppendToObj(context->obj, \
+ bp, context->text - bp); \
+ } \
+ } else { \
+ context->obj = Tcl_NewStringObj( \
+ bp, context->text - bp); \
+ initialized = 1; \
+ }
+
+void
+jsonskip(struct context *context)
+{
+ while (context->remaining) {
+ switch (*context->text) {
+ case '\n':
+ case ' ':
+ case '\t':
+ case '\r':
+ DRAIN(1);
+ continue;
+ }
+ break;
+ }
+}
+
+static int
+jsonlexp(struct context *context)
+{
+ const char *bp = NULL;
+
+ /* Question: Why not plain numbers 1,2 for the states
+ * but these specific hex patterns ?
+ */
+ enum {
+ PLAIN = 0x0000ff00,
+ INSTR = 0x00ff0000
+ } lstate;
+ double d;
+ char *end;
+ const char *p;
+ int initialized = 0;
+
+ /*
+ * Do not auto-lex beyond a full json structure.
+ */
+ if (context->result == TCL_OK) {
+ TOKEN ("<<eof>>");
+ return 0;
+ }
+
+ /*
+ * Quickly skip and ignore whitespace.
+ */
+ while (context->remaining) {
+ switch (*context->text) {
+ case '\n':
+ case ' ':
+ case '\t':
+ case '\r':
+ DRAIN(1);
+ continue;
+ }
+ break;
+ }
+
+ /*
+ * Handle the token following the whitespace. Small state machine to
+ * handle strings and escapes in them, and bare words (various
+ * contants, and numbers).
+ */
+ for (lstate = PLAIN; context->remaining > 0; DRAIN(1)) {
+ if (lstate == INSTR) {
+ if (*context->text == '"') {
+ /*
+ * End of quoted string
+ */
+
+ STORESTRINGSEGMENT();
+ DRAIN(1);
+ TOKEN1 ("STRING");
+ return STRING;
+ }
+
+ if (*context->text == '\\') {
+ /*
+ * Escaped sequence. The 9 sequences specified at json.org
+ * are:
+ * \" \\ \/ \b \f \n \r \t \uXXXX
+ */
+ char buf[TCL_UTF_MAX];
+ int len, consumed;
+
+ STORESTRINGSEGMENT();
+
+ /*
+ * Perform additional checks to restrict the set of accepted
+ * escape sequence to what is allowed by json.org instead of
+ * Tcl_UtfBackslash.
+ */
+
+ if (!HAVE(1)) {
+ Tcl_AppendToObj(context->obj, "\\", 1);
+ yyerror("incomplete escape at <<eof> error");
+ TOKEN("incomplete escape at <<eof>> error");
+ return -1;
+ }
+ switch (context->text[1]) {
+ case '"':
+ case '\\':
+ case '/':
+ case 'b':
+ case 'f':
+ case 'n':
+ case 'r':
+ case 't':
+ break;
+ case 'u':
+ if (!HAVE(5)) {
+ Tcl_AppendToObj(context->obj, "\\u", 2);
+ yyerror("incomplete escape at <<eof> error");
+ TOKEN("incomplete escape at <<eof>> error");
+ return -1;
+ }
+ break;
+ default:
+ Tcl_AppendToObj(context->obj, context->text + 1, 1);
+ yyerror("bad escape");
+ TOKEN("bad escape");
+ return -1;
+ }
+
+ /*
+ * XXX Tcl_UtfBackslash() may be more
+ * XXX permissive, than JSON standard.
+ * XXX But that may be a good thing:
+ * XXX "be generous in what you accept".
+ */
+ len = Tcl_UtfBackslash(context->text,
+ &consumed, buf);
+ DRAIN(consumed - 1);
+ bp = context->text + 1;
+ Tcl_AppendToObj(context->obj, buf, len);
+ }
+ continue;
+ }
+
+ switch (*context->text) {
+ case ',':
+ case '{':
+ case ':':
+ case '}':
+ case '[':
+ case ']':
+ DRAIN(1);
+ TOKEN (context->text[-1]);
+ return context->text[-1];
+ case 't':
+ if ((context->remaining < 4) ||
+ strncmp("rue", context->text + 1, 3))
+ goto bareword;
+ DRAIN(4);
+ context->obj = TRUE_O;
+ TOKEN1 ("CONSTANT");
+ return CONSTANT;
+ case 'f':
+ if ((context->remaining < 5) ||
+ strncmp("alse", context->text + 1, 4))
+ goto bareword;
+ DRAIN(5);
+ context->obj = FALSE_O;
+ TOKEN1 ("CONSTANT");
+ return CONSTANT;
+ case 'n':
+ if ((context->remaining < 4) ||
+ strncmp("ull", context->text + 1, 3))
+ goto bareword;
+ DRAIN(4);
+ context->obj = NULL_O;
+ TOKEN1 ("CONSTANT");
+ return CONSTANT;
+ case '"':
+ bp = context->text + 1;
+ lstate = INSTR;
+ continue;
+ case '\\':
+ yyerror("Escape character outside of string");
+ TOKEN ("escape error");
+ return -1;
+ }
+
+ /*
+ * We already considered the null, true, and false
+ * above, so it can only be a number now.
+ *
+ * NOTE: At this point we do not care about double
+ * versus integer, nor about the possible integer
+ * range. We generate a plain string Tcl_Obj and leave
+ * it to the user of the generated structure to
+ * convert to a number when actually needed. This
+ * defered conversion also ensures that the Tcl and
+ * platform we are building against does not matter
+ * regarding integer range, only the abilities of the
+ * Tcl at runtime.
+ */
+
+ d = strtod(context->text, &end);
+ if (end == context->text)
+ goto bareword; /* Nothing parsed */
+
+ context->obj = Tcl_NewStringObj (context->text,
+ end - context->text);
+
+ context->remaining -= (end - context->text);
+ context->text = end;
+ TOKEN1 ("CONSTANT");
+ return CONSTANT;
+ }
+
+ TOKEN ("<<eof>>");
+ return 0;
+ bareword:
+ yyerror("Bare word encountered");
+ TOKEN ("bare word error");
+ return -1;
+}
+
+#if 0
+int
+jsonlex(struct context *context)
+{
+ const char *bp = NULL;
+
+ /* Question: Why not plain numbers 1,2 for the states
+ * but these specific hex patterns ?
+ */
+ enum {
+ PLAIN = 0x0000ff00,
+ INSTR = 0x00ff0000
+ } lstate;
+ double d;
+ char *end;
+ const char *p;
+ int initialized = 0;
+
+ while (context->remaining) {
+ /* Iterate over the whole string and check all tokens.
+ * Nothing else.
+ */
+
+ /*
+ * Quickly skip and ignore whitespace.
+ */
+ while (context->remaining) {
+ switch (*context->text) {
+ case '\n':
+ case ' ':
+ case '\t':
+ case '\r':
+ DRAIN(1);
+ continue;
+ }
+ break;
+ }
+
+ /*
+ * Handle the token following the whitespace. Small state machine to
+ * handle strings and escapes in them, and bare words (various
+ * contants, and numbers).
+ */
+ for (lstate = PLAIN; context->remaining > 0; DRAIN(1)) {
+ if (lstate == INSTR) {
+ if (*context->text == '"') {
+ /*
+ * End of quoted string
+ */
+ DRAIN(1);
+ goto next_token;
+ }
+
+ if (*context->text == '\\') {
+ /*
+ * Escaped sequence
+ */
+ char buf[TCL_UTF_MAX];
+ int len, consumed;
+
+ /*
+ * XXX Tcl_UtfBackslash() may be more
+ * XXX permissive, than JSON standard.
+ * XXX But that may be a good thing:
+ * XXX "be generous in what you accept".
+ */
+ len = Tcl_UtfBackslash(context->text, &consumed, buf);
+ DRAIN(consumed - 1);
+ }
+ continue;
+ }
+
+ switch (*context->text) {
+ case ',':
+ case '{':
+ case ':':
+ case '}':
+ case '[':
+ case ']':
+ DRAIN(1);
+ goto next_token;
+
+ case 't':
+ if ((context->remaining < 4) ||
+ strncmp("rue", context->text + 1, 3))
+ return -1; /* bare word */
+ DRAIN(4);
+ goto next_token;
+ case 'f':
+ if ((context->remaining < 5) ||
+ strncmp("alse", context->text + 1, 4))
+ return -1; /* bare word */
+ DRAIN(5);
+ goto next_token;
+ case 'n':
+ if ((context->remaining < 4) ||
+ strncmp("ull", context->text + 1, 3))
+ return -1; /* bare word */
+ DRAIN(4);
+ goto next_token;
+ case '"':
+ bp = context->text + 1;
+ lstate = INSTR;
+ continue;
+ case '\\':
+ /* Escape outside string, abort. */
+ return -1;
+ }
+
+ /*
+ * We already considered the null, true, and false
+ * above, so it can only be a number now.
+ *
+ * NOTE: At this point we do not care about double
+ * versus integer, nor about the possible integer
+ * range. We generate a plain string Tcl_Obj and leave
+ * it to the user of the generated structure to
+ * convert to a number when actually needed. This
+ * defered conversion also ensures that the Tcl and
+ * platform we are building against does not matter
+ * regarding integer range, only the abilities of the
+ * Tcl at runtime.
+ */
+
+ d = strtod(context->text, &end);
+ if (end == context->text)
+ return -1; /* bare word */
+
+ context->remaining -= (end - context->text);
+ context->text = end;
+ goto next_token;
+ }
+
+ return 0;
+
+ next_token:
+ continue;
+ }
+}
+#endif
+
+static void
+jsonerror(struct context *context, const char *message)
+{
+ char *fullmessage;
+ char *yytext;
+ int yyleng;
+
+ if (context->has_error) return;
+
+ if (context->obj) {
+ yytext = Tcl_GetStringFromObj(context->obj, &yyleng);
+ fullmessage = Tcl_Alloc(strlen(message) + 63 + yyleng);
+
+ sprintf(fullmessage, "%s %d bytes before end, around ``%.*s''",
+ message, context->remaining, yyleng, yytext);
+ } else {
+ fullmessage = Tcl_Alloc(strlen(message) + 63);
+
+ sprintf(fullmessage, "%s %d bytes before end",
+ message, context->remaining);
+ }
+
+ TRACE ((">>> %s\n",fullmessage));
+ Tcl_SetResult (context->I, fullmessage, TCL_DYNAMIC);
+ Tcl_SetErrorCode (context->I, "JSON", "SYNTAX", NULL);
+ context->has_error = 1;
+}
diff --git a/tcllib/modules/json/c/json_y.h b/tcllib/modules/json/c/json_y.h
new file mode 100644
index 0000000..a8503ce
--- /dev/null
+++ b/tcllib/modules/json/c/json_y.h
@@ -0,0 +1,63 @@
+/*
+ * Data structures and declarations for yacc/bison based json parser.
+ * External to .y file for communication and use within the binding layer.
+ */
+
+struct context {
+ /*
+ * General state.
+ */
+
+ Tcl_Interp *I; /* Tcl interpreter we are in. */
+ int result; /* Tcl result of the parse.
+ **
+ * NOTE: A value of TCL_OK (set when
+ * successfully reducing the main rule)
+ * causes the lexer to return <<EOF>> from
+ * then on, preventing parsing beyond a
+ * single json structure.
+ */
+
+ /*
+ * Lexer Input.
+ */
+
+ const char *text; /* Text to parse */
+ int remaining; /* Number of characters left to parse. */
+
+ /*
+ * Lexer -> Parser communication.
+ */
+
+ Tcl_Obj *obj; /* Tcl value of the last returned token. */
+ int has_error;
+};
+
+/*
+ * Note: The parser function automatically sets the Tcl_Interp (See
+ * field "I") result to the parse result, or an error message.
+ */
+
+extern void
+jsonparse (struct context *);
+
+#if 0
+extern int
+jsonlex(struct context *);
+#endif
+
+extern void
+jsonskip (struct context *);
+
+/*
+ * Default: Tracing off.
+ */
+#ifndef JSON_DEBUG
+#define JSON_DEBUG 0
+#endif
+
+#if JSON_DEBUG
+#define TRACE(x) do { printf x ; fflush (stdout); } while (0)
+#else
+#define TRACE(x)
+#endif
diff --git a/tcllib/modules/json/json.bench b/tcllib/modules/json/json.bench
new file mode 100644
index 0000000..fb08f29
--- /dev/null
+++ b/tcllib/modules/json/json.bench
@@ -0,0 +1,167 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'json' parser
+# to allow developers to monitor package performance.
+#
+# (c) 2013 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.4 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package present Tcl] 8.4]} {
+ bench_puts "Need Tcl 8.4+, found Tcl [package present Tcl]"
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+package require Tcl 8.4
+
+package forget json
+
+set self [file join [pwd] [file dirname [info script]]]
+set mod [file dirname $self]
+set index [file join [file dirname $self] tcllibc pkgIndex.tcl]
+
+if 1 {
+ if {[file exists $index]} {
+ set ::dir [file dirname $index]
+ uplevel #0 [list source $index]
+ unset ::dir
+ package require tcllibc
+ }
+}
+
+source [file join $self json.tcl]
+
+# ### ### ### ######### ######### ######### ###########################
+## Helpers
+
+proc cat {f} {
+ set c [open $f]
+ set d [read $c]
+ close $c
+ return $d
+}
+
+proc iota {n} {
+ set r {}
+ while {$n > 0} {
+ lappend r [json::string2json $n]
+ incr n -1
+ }
+ return $r
+}
+
+proc iota-dict {n} {
+ set r {}
+ while {$n > 0} {
+ lappend r f$n [json::string2json $n]
+ incr n -1
+ }
+ return $r
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Get all the possible implementations
+
+json::SwitchTo {}
+foreach e [json::KnownImplementations] {
+ ::json::LoadAccelerator $e
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+## Just the parser, on the valid inputs for the testsuite.
+
+foreach impl [json::Implementations] {
+ json::SwitchTo $impl
+
+ if {$impl eq "tcl"} {
+ set series {0 1 10 100 1000}
+ } else {
+ set series {0 1 10 100 1000}
+ }
+
+ bench_puts "=== === === === === ==="
+ bench_puts "=== === === $impl ==="
+ bench_puts "=== === === === === ==="
+
+ bench_puts {=== test-data =========}
+
+ foreach f [glob -nocomplain -directory $self/tests *.json] {
+ set in [cat $f]
+
+ bench -desc "parse [file rootname [file tail $f]] ($impl)" -body {
+ json::json2dict $in
+ }
+
+ bench -desc "validate [file rootname [file tail $f]] ($impl)" -body {
+ json::validate $in
+ }
+ }
+
+ foreach f [glob -nocomplain -directory $self/tests *.bench] {
+ set in [cat $f]
+
+ bench -desc "parse [file rootname [file tail $f]] ($impl)" -body {
+ json::json2dict $in
+ }
+
+ bench -desc "validate [file rootname [file tail $f]] ($impl)" -body {
+ json::validate $in
+ }
+ }
+
+ bench_puts {=== synthetic array =========}
+
+ foreach n $series {
+ set in [json::list2json [iota $n]]
+
+ bench -desc "parse array-$n ($impl)" -body {
+ json::json2dict $in
+ }
+
+ bench -desc "validate array-$n ($impl)" -body {
+ json::validate $in
+ }
+ }
+
+ bench_puts {=== synthetic object =========}
+
+ foreach n $series {
+ set in [json::dict2json [iota-dict $n]]
+
+ bench -desc "parse object-$n ($impl)" -body {
+ json::json2dict $in
+ }
+
+ bench -desc "validate object-$n ($impl)" -body {
+ json::validate $in
+ }
+ }
+
+ bench_puts {=== synthetic string =========}
+
+ foreach n $series {
+ set in [json::string2json [string repeat . $n]]
+
+ bench -desc "parse string-$n ($impl)" -body {
+ json::json2dict $in
+ }
+
+ bench -desc "validate string-$n ($impl)" -body {
+ json::validate $in
+ }
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
+
+return
+
+# ### ### ### ######### ######### ######### ###########################
+## Notes ...
diff --git a/tcllib/modules/json/json.man b/tcllib/modules/json/json.man
new file mode 100644
index 0000000..1e9088c
--- /dev/null
+++ b/tcllib/modules/json/json.man
@@ -0,0 +1,110 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset VERSION 1.3.3]
+[manpage_begin json n [vset VERSION]]
+[keywords {data exchange}]
+[keywords {exchange format}]
+[keywords javascript]
+[keywords json]
+[copyright {2006 ActiveState Software Inc.}]
+[copyright {2009 Thomas Maeder, Glue Software Engineering AG}]
+[moddesc {JSON}]
+[titledesc {JSON parser}]
+[category {CGI programming}]
+[require Tcl 8.4]
+[require json [opt [vset VERSION]]]
+[description]
+[para]
+
+The [package json] package provides a simple Tcl-only library for parsing the
+JSON [uri http://www.json.org/] data exchange format as specified in RFC 4627
+[uri http://www.ietf.org/rfc/rfc4627.txt].
+
+There is some ambiguity in parsing JSON because JSON has type information that
+is not maintained by the Tcl conversion. The [package json] package returns
+data as a Tcl [cmd dict]. Either the [package dict] package or Tcl 8.5 is
+required for use.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::json::json2dict] [arg txt]]
+
+Parse JSON formatted text [arg txt] into a Tcl dict and return
+the value.
+
+[para] If [arg txt] contains more than one JSON entity only the
+first one is returned.
+
+
+[call [cmd ::json::many-json2dict] [arg txt] [opt [arg max]]]
+
+Parse JSON formatted text [arg txt] containing multiple JSON entities
+into a list of dictionaries and return that list.
+
+[para] If [arg max] is specified exactly that many entities are extracted
+from [arg txt]. By default the command will attempt to extract all, without
+limits. A value of "[arg max] == 0" does not make sense and will cause the
+command to throw an error.
+
+[list_end]
+[para]
+
+[section EXAMPLES]
+[para]
+
+An example of a JSON array converted to Tcl. A JSON array is returned as a
+single item with multiple elements.
+
+[para]
+[example {[
+ {
+ "precision": "zip",
+ "Latitude": 37.7668,
+ "Longitude": -122.3959,
+ "Address": "",
+ "City": "SAN FRANCISCO",
+ "State": "CA",
+ "Zip": "94107",
+ "Country": "US"
+ },
+ {
+ "precision": "zip",
+ "Latitude": 37.371991,
+ "Longitude": -122.026020,
+ "Address": "",
+ "City": "SUNNYVALE",
+ "State": "CA",
+ "Zip": "94085",
+ "Country": "US"
+ }
+]
+=>
+{Country US Latitude 37.7668 precision zip State CA City {SAN FRANCISCO} Address {} Zip 94107 Longitude -122.3959} {Country US Latitude 37.371991 precision zip State CA City SUNNYVALE Address {} Zip 94085 Longitude -122.026020}
+}]
+[para]
+
+An example of a JSON object converted to Tcl. A JSON object is returned as a
+multi-element list (a dict).
+
+[para]
+[example {{
+ "Image": {
+ "Width": 800,
+ "Height": 600,
+ "Title": "View from 15th Floor",
+ "Thumbnail": {
+ "Url": "http://www.example.com/image/481989943",
+ "Height": 125,
+ "Width": "100"
+ },
+ "IDs": [116, 943, 234, 38793]
+ }
+}
+=>
+Image {IDs {116 943 234 38793} Thumbnail {Width 100 Height 125 Url http://www.example.com/image/481989943} Width 800 Height 600 Title {View from 15th Floor}}
+}]
+
+[vset CATEGORY json]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/json/json.pcx b/tcllib/modules/json/json.pcx
new file mode 100644
index 0000000..e44b8b5
--- /dev/null
+++ b/tcllib/modules/json/json.pcx
@@ -0,0 +1,32 @@
+# -*- tcl -*- json.pcx
+# Syntax of the commands provided by package json.
+#
+# 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 json
+pcx::tcldep 1.0 needs tcl 8.4
+pcx::tcldep 1.2 needs tcl 8.4
+
+namespace eval ::json {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.0 std ::json::json2dict \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+
+pcx::check 1.2 std ::json::many-json2dict \
+ {checkSimpleArgs 1 2 {
+ checkWord checkInt
+ }}
+
+# Initialization via pcx::init.
+# Use a ::json::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/json/json.tcl b/tcllib/modules/json/json.tcl
new file mode 100644
index 0000000..90308ac
--- /dev/null
+++ b/tcllib/modules/json/json.tcl
@@ -0,0 +1,282 @@
+# json.tcl --
+#
+# JSON parser for Tcl. Management code, Tcl/C detection and selection.
+#
+# Copyright (c) 2013 by Andreas Kupries
+
+# @mdgen EXCLUDE: jsonc.tcl
+
+package require Tcl 8.4
+namespace eval ::json {}
+
+# ### ### ### ######### ######### #########
+## Management of json implementations.
+
+# ::json::LoadAccelerator --
+#
+# Loads a named implementation, if possible.
+#
+# Arguments:
+# key Name of the implementation to load.
+#
+# Results:
+# A boolean flag. True if the implementation
+# was successfully loaded; and False otherwise.
+
+proc ::json::LoadAccelerator {key} {
+ variable accel
+ set r 0
+ switch -exact -- $key {
+ critcl {
+ # Critcl implementation of json requires Tcl 8.4.
+ if {![package vsatisfies [package provide Tcl] 8.4]} {return 0}
+ if {[catch {package require tcllibc}]} {return 0}
+ # Check for the jsonc 1.1.1 API we are fixing later.
+ set r [llength [info commands ::json::many_json2dict_critcl]]
+ }
+ tcl {
+ variable selfdir
+ source [file join $selfdir json_tcl.tcl]
+ set r 1
+ }
+ default {
+ return -code error "invalid accelerator/impl. package $key:\
+ must be one of [join [KnownImplementations] {, }]"
+ }
+ }
+ set accel($key) $r
+ return $r
+}
+
+# ::json::SwitchTo --
+#
+# Activates a loaded named implementation.
+#
+# Arguments:
+# key Name of the implementation to activate.
+#
+# Results:
+# None.
+
+proc ::json::SwitchTo {key} {
+ variable accel
+ variable loaded
+ variable apicmds
+
+ if {[string equal $key $loaded]} {
+ # No change, nothing to do.
+ return
+ } elseif {![string equal $key ""]} {
+ # Validate the target implementation of the switch.
+
+ if {![info exists accel($key)]} {
+ return -code error "Unable to activate unknown implementation \"$key\""
+ } elseif {![info exists accel($key)] || !$accel($key)} {
+ return -code error "Unable to activate missing implementation \"$key\""
+ }
+ }
+
+ # Deactivate the previous implementation, if there was any.
+
+ if {![string equal $loaded ""]} {
+ foreach c $apicmds {
+ rename ::json::${c} ::json::${c}_$loaded
+ }
+ }
+
+ # Activate the new implementation, if there is any.
+
+ if {![string equal $key ""]} {
+ foreach c $apicmds {
+ rename ::json::${c}_$key ::json::${c}
+ }
+ }
+
+ # Remember the active implementation, for deactivation by future
+ # switches.
+
+ set loaded $key
+ return
+}
+
+# ::json::Implementations --
+#
+# Determines which implementations are
+# present, i.e. loaded.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A list of implementation keys.
+
+proc ::json::Implementations {} {
+ variable accel
+ set res {}
+ foreach n [array names accel] {
+ if {!$accel($n)} continue
+ lappend res $n
+ }
+ return $res
+}
+
+# ::json::KnownImplementations --
+#
+# Determines which implementations are known
+# as possible implementations.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A list of implementation keys. In the order
+# of preference, most prefered first.
+
+proc ::json::KnownImplementations {} {
+ return {critcl tcl}
+}
+
+proc ::json::Names {} {
+ return {
+ critcl {tcllibc based}
+ tcl {pure Tcl}
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Initialization: Data structures.
+
+namespace eval ::json {
+ variable selfdir [file dirname [info script]]
+ variable accel
+ array set accel {tcl 0 critcl 0}
+ variable loaded {}
+
+ variable apicmds {
+ json2dict
+ many-json2dict
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Wrapper fix for the jsonc package to match APIs.
+
+proc ::json::many-json2dict_critcl {args} {
+ eval [linsert $args 0 ::json::many_json2dict_critcl]
+}
+
+# ### ### ### ######### ######### #########
+## Initialization: Choose an implementation,
+## most prefered first. Loads only one of the
+## possible implementations. And activates it.
+
+namespace eval ::json {
+ variable e
+ foreach e [KnownImplementations] {
+ if {[LoadAccelerator $e]} {
+ SwitchTo $e
+ break
+ }
+ }
+ unset e
+}
+
+# ### ### ### ######### ######### #########
+## Tcl implementation of validation, shared for Tcl and C implementation.
+##
+## The regexp based validation is consistently faster than json-c.
+## Suspected reasons: Tcl REs are mainly in C as well, and json-c has
+## overhead in constructing its own data structures. While irrelevant
+## to validation json-c still builds them, it has no mode doing pure
+## syntax checking.
+
+namespace eval ::json {
+ # Regular expression for tokenizing a JSON text (cf. http://json.org/)
+
+ # tokens consisting of a single character
+ variable singleCharTokens { "{" "}" ":" "\\[" "\\]" "," }
+ variable singleCharTokenRE "\[[join $singleCharTokens {}]\]"
+
+ # quoted string tokens
+ variable escapableREs { "[\\\"\\\\/bfnrt]" "u[[:xdigit:]]{4}" "." }
+ variable escapedCharRE "\\\\(?:[join $escapableREs |])"
+ variable unescapedCharRE {[^\\\"]}
+ variable stringRE "\"(?:$escapedCharRE|$unescapedCharRE)*\""
+
+ # as above, for validation
+ variable escapableREsv { "[\\\"\\\\/bfnrt]" "u[[:xdigit:]]{4}" }
+ variable escapedCharREv "\\\\(?:[join $escapableREsv |])"
+ variable stringREv "\"(?:$escapedCharREv|$unescapedCharRE)*\""
+
+ # (unquoted) words
+ variable wordTokens { "true" "false" "null" }
+ variable wordTokenRE [join $wordTokens "|"]
+
+ # number tokens
+ # negative lookahead (?!0)[[:digit:]]+ might be more elegant, but
+ # would slow down tokenizing by a factor of up to 3!
+ variable positiveRE {[1-9][[:digit:]]*}
+ variable cardinalRE "-?(?:$positiveRE|0)"
+ variable fractionRE {[.][[:digit:]]+}
+ variable exponentialRE {[eE][+-]?[[:digit:]]+}
+ variable numberRE "${cardinalRE}(?:$fractionRE)?(?:$exponentialRE)?"
+
+ # JSON token, and validation
+ variable tokenRE "$singleCharTokenRE|$stringRE|$wordTokenRE|$numberRE"
+ variable tokenREv "$singleCharTokenRE|$stringREv|$wordTokenRE|$numberRE"
+
+
+ # 0..n white space characters
+ set whiteSpaceRE {[[:space:]]*}
+
+ # Regular expression for validating a JSON text
+ variable validJsonRE "^(?:${whiteSpaceRE}(?:$tokenREv))*${whiteSpaceRE}$"
+}
+
+
+# Validate JSON text
+# @param jsonText JSON text
+# @return 1 iff $jsonText conforms to the JSON grammar
+# (@see http://json.org/)
+proc ::json::validate {jsonText} {
+ variable validJsonRE
+
+ return [regexp -- $validJsonRE $jsonText]
+}
+
+# ### ### ### ######### ######### #########
+## These three procedures shared between Tcl and Critcl implementations.
+## See also package "json::write".
+
+proc ::json::dict2json {dictVal} {
+ # XXX: Currently this API isn't symmetrical, as to create proper
+ # XXX: JSON text requires type knowledge of the input data
+ set json ""
+ set prefix ""
+
+ foreach {key val} $dictVal {
+ # key must always be a string, val may be a number, string or
+ # bare word (true|false|null)
+ if {0 && ![string is double -strict $val]
+ && ![regexp {^(?:true|false|null)$} $val]} {
+ set val "\"$val\""
+ }
+ append json "$prefix\"$key\": $val" \n
+ set prefix ,
+ }
+
+ return "\{${json}\}"
+}
+
+proc ::json::list2json {listVal} {
+ return "\[[join $listVal ,]\]"
+}
+
+proc ::json::string2json {str} {
+ return "\"$str\""
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide json 1.3.3
diff --git a/tcllib/modules/json/json.test b/tcllib/modules/json/json.test
new file mode 100644
index 0000000..56c04d8
--- /dev/null
+++ b/tcllib/modules/json/json.test
@@ -0,0 +1,94 @@
+# json.test - Copyright (C) 2006 ActiveState Software Inc.
+#
+# Tests for the Tcllib json package
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: json.test,v 1.8 2011/11/10 21:05:58 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl [expr {[catch {package require dict}] ? "8.5" : "8.4"}]
+testsNeedTcltest 2.0
+
+support {
+ useLocalFile tests/support.tcl
+}
+
+testing {
+ useAccel [useTcllibC] json/json.tcl json
+ TestAccelInit json
+}
+
+# -------------------------------------------------------------------------
+# Tests
+# -------------------------------------------------------------------------
+
+TestAccelDo json impl {
+ switch -exact -- $impl {
+ critcl {
+ set MY myjson
+
+ proc tmWrong {m loarg n {xarg {}}} {
+ return [tcltest::wrongNumArgs "myjson $m" $loarg $n]
+ }
+
+ proc tmTooMany {m loarg {xarg {}}} {
+ return [tcltest::tooManyArgs "myjson $m" $loarg]
+ }
+
+ proc tmTake {tcl c} { return $c }
+ }
+ tcl {
+ set MY ::myjson
+
+ if {[package vsatisfies [package provide Tcl] 8.5]} {
+ proc tmWrong {m loarg n {xarg {}}} {
+ if {$xarg == {}} {set xarg $loarg}
+ if {$xarg != {}} {set xarg " $xarg"}
+ incr n
+ return [tcltest::wrongNumArgs "I $m" "name$xarg" $n]
+ }
+
+ proc tmTooMany {m loarg {xarg {}}} {
+ if {$xarg == {}} {set xarg $loarg}
+ if {$xarg != {}} {set xarg " $xarg"}
+ return [tcltest::tooManyArgs "I $m" "name$xarg"]
+ }
+ } else {
+ proc tmWrong {m loarg n {xarg {}}} {
+ if {$xarg == {}} {set xarg $loarg}
+ if {$xarg != {}} {set xarg " $xarg"}
+ incr n
+ return [tcltest::wrongNumArgs "::struct::json::I::$m" "name$xarg" $n]
+ }
+
+ proc tmTooMany {m loarg {xarg {}}} {
+ if {$xarg == {}} {set xarg $loarg}
+ if {$xarg != {}} {set xarg " $xarg"}
+ return [tcltest::tooManyArgs "::struct::json::I::$m" "name$xarg"]
+ }
+ }
+
+ proc tmTake {tcl c} { return $tcl }
+ }
+ }
+ source [localPath json.testsuite]
+}
+
+# -------------------------------------------------------------------------
+catch {unset JSON}
+catch {unset TCL}
+catch {unset DICTSORT}
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/json/json.testsuite b/tcllib/modules/json/json.testsuite
new file mode 100644
index 0000000..a793451
--- /dev/null
+++ b/tcllib/modules/json/json.testsuite
@@ -0,0 +1,102 @@
+# -*- tcl -*-
+# -------------------------------------------------------------------------
+# Tests
+# -------------------------------------------------------------------------
+
+set i 0
+foreach name [lsort -dict [array names JSON]] {
+ test json-${impl}-1.[incr i] "test JSON $name" -body {
+ transform [json::json2dict $JSON($name)] $name
+ } -result [resultfor $name]
+}
+
+set i 0
+foreach name [lsort -dict [array names JSON]] {
+ test json-${impl}-7.[incr i] "validate JSON $name" -body {
+ json::validate $JSON($name)
+ } -result 1
+}
+
+set i 0
+foreach name [lsort -dict [array names FAIL]] {
+ test json-${impl}-8.[incr i] "test FAIL $name" -body {
+ json::json2dict $FAIL($name)
+ } -returnCodes error -result $ERR(${name}-${impl})
+}
+
+set i 0
+foreach name [lsort -dict [array names FAIL]] {
+ test json-${impl}-9.[incr i] "validate FAIL $name" -body {
+ json::validate $FAIL($name)
+ } -result 0
+}
+
+# -------------------------------------------------------------------------
+# More Tests - list2json, string2json
+# TODO: dict2json
+# -------------------------------------------------------------------------
+
+test json-${impl}-2.0 {list2json} -body {
+ json::list2json {{"a"} {"b"} {"c"}}
+} -result {["a","b","c"]}
+
+test json-${impl}-2.1 {string2json} -body {
+ json::string2json a
+} -result {"a"}
+
+# -------------------------------------------------------------------------
+# many-json2dict
+# -------------------------------------------------------------------------
+
+test json-${impl}-3.0 {many-json2dict, wrong args, not enough} -body {
+ json::many-json2dict
+} -returnCodes error -match glob -result {wrong # args: should be "*json::many[-_]json2dict* jsonText ?max?"}
+
+test json-${impl}-3.1 {many-json2dict, wrong args, too many} -body {
+ json::many-json2dict J M X
+} -returnCodes error -match glob -result {wrong # args: should be "*json::many[-_]json2dict* jsonText ?max?"}
+
+test json-${impl}-3.2 {many-json2dict, bad limit, zero} -body {
+ json::many-json2dict {[]} 0
+} -returnCodes error -result {Bad limit 0 of json entities to extract.}
+
+set i 0
+foreach first [lsort -dict [array names JSON]] {
+ foreach second [lsort -dict [array names JSON]] {
+ set input $JSON($first)
+ append input " " $JSON($second)
+
+ set output {}
+ lappend output [resultfor $first]
+ lappend output [resultfor $second]
+
+ test json-${impl}-4.[incr i] "many-json2dict: $first/$second, all" -body {
+ transform* [json::many-json2dict $input] $first $second
+ } -result $output
+ }
+}
+
+set i 0
+foreach first [lsort -dict [array names JSON]] {
+ foreach second [lsort -dict [array names JSON]] {
+ set input $JSON($first)
+ append input " " $JSON($second)
+
+ set output {}
+ lappend output [resultfor $first]
+
+ test json-${impl}-5.[incr i] "many-json2dict: $first/$second, first only" -body {
+ transform* [json::many-json2dict $input 1] $first
+ } -result $output
+ }
+}
+
+set i 0
+foreach first [lsort -dict [array names JSON]] {
+ set input $JSON($first)
+ test json-${impl}-6.[incr i] "many-json2dict, bad limit, 3 over 1" -body {
+ json::many-json2dict $input 3
+ } -returnCodes error -result {Bad limit 3 of json entities to extract, found only 1.}
+}
+
+# -------------------------------------------------------------------------
diff --git a/tcllib/modules/json/json_tcl.tcl b/tcllib/modules/json/json_tcl.tcl
new file mode 100644
index 0000000..fabeda3
--- /dev/null
+++ b/tcllib/modules/json/json_tcl.tcl
@@ -0,0 +1,290 @@
+#
+# JSON parser for Tcl.
+#
+# See http://www.json.org/ && http://www.ietf.org/rfc/rfc4627.txt
+#
+# Total rework of the code published with version number 1.0 by
+# Thomas Maeder, Glue Software Engineering AG
+#
+# $Id: json.tcl,v 1.7 2011/11/10 21:05:58 andreas_kupries Exp $
+#
+
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ package require dict
+}
+
+# Parse JSON text into a dict
+# @param jsonText JSON text
+# @return dict (or list) containing the object represented by $jsonText
+proc ::json::json2dict_tcl {jsonText} {
+ variable tokenRE
+
+ set tokens [regexp -all -inline -- $tokenRE $jsonText]
+ set nrTokens [llength $tokens]
+ set tokenCursor 0
+
+#puts T:\t[join $tokens \nT:\t]
+ return [parseValue $tokens $nrTokens tokenCursor]
+}
+
+# Parse multiple JSON entities in a string into a list of dictionaries
+# @param jsonText JSON text to parse
+# @param max Max number of entities to extract.
+# @return list of (dict (or list) containing the objects) represented by $jsonText
+proc ::json::many-json2dict_tcl {jsonText {max -1}} {
+ variable tokenRE
+
+ if {$max == 0} {
+ return -code error -errorCode {JSON BAD-LIMIT ZERO} \
+ "Bad limit 0 of json entities to extract."
+ }
+
+ set tokens [regexp -all -inline -- $tokenRE $jsonText]
+ set nrTokens [llength $tokens]
+ set tokenCursor 0
+
+ set result {}
+ set found 0
+ set n $max
+ while {$n != 0} {
+ if {$tokenCursor >= $nrTokens} break
+ lappend result [parseValue $tokens $nrTokens tokenCursor]
+ incr found
+ if {$n > 0} {incr n -1}
+ }
+
+ if {$n > 0} {
+ return -code error -errorCode {JSON BAD-LIMIT TOO LARGE} \
+ "Bad limit $max of json entities to extract, found only $found."
+ }
+
+ return $result
+}
+
+# Throw an exception signaling an unexpected token
+proc ::json::unexpected {tokenCursor token expected} {
+ return -code error -errorcode [list JSON UNEXPECTED $tokenCursor $expected] \
+ "unexpected token \"$token\" at position $tokenCursor; expecting $expected"
+}
+
+# Get rid of the quotes surrounding a string token and substitute the
+# real characters for escape sequences within it
+# @param token
+# @return unquoted unescaped value of the string contained in $token
+proc ::json::unquoteUnescapeString {tokenCursor token} {
+ variable stringREv
+ set unquoted [string range $token 1 end-1]
+
+ if {![regexp $stringREv $token]} {
+ unexpected $tokenCursor $token STRING
+ }
+
+ set res [subst -nocommands -novariables $unquoted]
+ return $res
+}
+
+# Parse an object member
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+# holding current position in $tokens
+# @param objectDictName name (in caller's context) of dict
+# representing the JSON object of which to
+# parse the next member
+proc ::json::parseObjectMember {tokens nrTokens tokenCursorName objectDictName} {
+ upvar $tokenCursorName tokenCursor
+ upvar $objectDictName objectDict
+
+ set token [lindex $tokens $tokenCursor]
+ set tc $tokenCursor
+ incr tokenCursor
+
+ set leadingChar [string index $token 0]
+ if {$leadingChar eq "\""} {
+ set memberName [unquoteUnescapeString $tc $token]
+
+ if {$tokenCursor == $nrTokens} {
+ unexpected $tokenCursor "END" "\":\""
+ } else {
+ set token [lindex $tokens $tokenCursor]
+ incr tokenCursor
+
+ if {$token eq ":"} {
+ set memberValue [parseValue $tokens $nrTokens tokenCursor]
+ dict set objectDict $memberName $memberValue
+ } else {
+ unexpected $tokenCursor $token "\":\""
+ }
+ }
+ } else {
+ unexpected $tokenCursor $token "STRING"
+ }
+}
+
+# Parse the members of an object
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+# holding current position in $tokens
+# @param objectDictName name (in caller's context) of dict
+# representing the JSON object of which to
+# parse the next member
+proc ::json::parseObjectMembers {tokens nrTokens tokenCursorName objectDictName} {
+ upvar $tokenCursorName tokenCursor
+ upvar $objectDictName objectDict
+
+ while true {
+ parseObjectMember $tokens $nrTokens tokenCursor objectDict
+
+ set token [lindex $tokens $tokenCursor]
+ incr tokenCursor
+
+ switch -exact $token {
+ "," {
+ # continue
+ }
+ "\}" {
+ break
+ }
+ default {
+ unexpected $tokenCursor $token "\",\"|\"\}\""
+ }
+ }
+ }
+}
+
+# Parse an object
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+# holding current position in $tokens
+# @return parsed object (Tcl dict)
+proc ::json::parseObject {tokens nrTokens tokenCursorName} {
+ upvar $tokenCursorName tokenCursor
+
+ if {$tokenCursor == $nrTokens} {
+ unexpected $tokenCursor "END" "OBJECT"
+ } else {
+ set result [dict create]
+
+ set token [lindex $tokens $tokenCursor]
+
+ if {$token eq "\}"} {
+ # empty object
+ incr tokenCursor
+ } else {
+ parseObjectMembers $tokens $nrTokens tokenCursor result
+ }
+
+ return $result
+ }
+}
+
+# Parse the elements of an array
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+# holding current position in $tokens
+# @param resultName name (in caller's context) of the list
+# representing the JSON array
+proc ::json::parseArrayElements {tokens nrTokens tokenCursorName resultName} {
+ upvar $tokenCursorName tokenCursor
+ upvar $resultName result
+
+ while true {
+ lappend result [parseValue $tokens $nrTokens tokenCursor]
+
+ if {$tokenCursor == $nrTokens} {
+ unexpected $tokenCursor "END" "\",\"|\"\]\""
+ } else {
+ set token [lindex $tokens $tokenCursor]
+ incr tokenCursor
+
+ switch -exact $token {
+ "," {
+ # continue
+ }
+ "\]" {
+ break
+ }
+ default {
+ unexpected $tokenCursor $token "\",\"|\"\]\""
+ }
+ }
+ }
+ }
+}
+
+# Parse an array
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+# holding current position in $tokens
+# @return parsed array (Tcl list)
+proc ::json::parseArray {tokens nrTokens tokenCursorName} {
+ upvar $tokenCursorName tokenCursor
+
+ if {$tokenCursor == $nrTokens} {
+ unexpected $tokenCursor "END" "ARRAY"
+ } else {
+ set result {}
+
+ set token [lindex $tokens $tokenCursor]
+
+ set leadingChar [string index $token 0]
+ if {$leadingChar eq "\]"} {
+ # empty array
+ incr tokenCursor
+ } else {
+ parseArrayElements $tokens $nrTokens tokenCursor result
+ }
+
+ return $result
+ }
+}
+
+# Parse a value
+# @param tokens list of tokens
+# @param nrTokens length of $tokens
+# @param tokenCursorName name (in caller's context) of variable
+# holding current position in $tokens
+# @return parsed value (dict, list, string, number)
+proc ::json::parseValue {tokens nrTokens tokenCursorName} {
+ upvar $tokenCursorName tokenCursor
+
+ if {$tokenCursor == $nrTokens} {
+ unexpected $tokenCursor "END" "VALUE"
+ } else {
+ set token [lindex $tokens $tokenCursor]
+ set tc $tokenCursor
+ incr tokenCursor
+
+ set leadingChar [string index $token 0]
+ switch -exact -- $leadingChar {
+ "\{" {
+ return [parseObject $tokens $nrTokens tokenCursor]
+ }
+ "\[" {
+ return [parseArray $tokens $nrTokens tokenCursor]
+ }
+ "\"" {
+ # quoted string
+ return [unquoteUnescapeString $tc $token]
+ }
+ "t" -
+ "f" -
+ "n" {
+ # bare word: true, false, null (return as is)
+ return $token
+ }
+ default {
+ # number?
+ if {[string is double -strict $token]} {
+ return $token
+ } else {
+ unexpected $tokenCursor $token "VALUE"
+ }
+ }
+ }
+ }
+}
diff --git a/tcllib/modules/json/json_write.man b/tcllib/modules/json/json_write.man
new file mode 100644
index 0000000..a06029e
--- /dev/null
+++ b/tcllib/modules/json/json_write.man
@@ -0,0 +1,88 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset PACKAGE_VERSION 1.0.3]
+[manpage_begin json::write n [vset PACKAGE_VERSION]]
+[keywords {data exchange}]
+[keywords {exchange format}]
+[keywords javascript]
+[keywords json]
+[copyright {2009-2013 Andreas Kupries <andreas_kupries@sourceforge.net>}]
+[moddesc {JSON}]
+[titledesc {JSON generation}]
+[category {CGI programming}]
+[require Tcl 8.5]
+[require json::write [opt [vset PACKAGE_VERSION]]]
+[description]
+[para]
+
+The [package json::write] package provides a simple Tcl-only library
+for generation of text in the JSON [uri http://www.json.org/] data
+exchange format as specified in
+RFC 4627 [uri http://www.ietf.org/rfc/rfc4627.txt].
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::json::write] [method indented]]
+
+This method returns the current state of the indentation setting.
+
+[call [cmd ::json::write] [method indented] [arg flag]]
+
+This and the method [method aligned] configure the layout of the JSON
+generated by the package.
+
+[para]
+
+If this [arg flag] is set (default) the package will break the
+generated JSON code across lines and indent it according to its inner
+structure, with each key of an object on a separate line.
+
+[para]
+
+If this flag is not set, the whole JSON object will be written on a
+single line, with minimum spacing between all elements.
+
+[call [cmd ::json::write] [method aligned]]
+
+This method returns the current state of the alignment setting.
+
+[call [cmd ::json::write] [method aligned] [arg flag]]
+
+This and the method [method indented] configure the layout of the JSON
+generated by the package.
+
+[para]
+
+If this [arg flag] is set (default) the package ensures that the
+values for the keys in an object are vertically aligned with each
+other, for a nice table effect. To make this work this also implies
+that [var indented] is set as well.
+
+[para]
+
+If this flag is not set, the output is formatted as per the value of
+[var indented], without trying to align the values for object keys.
+
+[call [cmd ::json::write] [method string] [arg s]]
+
+This method takes the string [arg s] and returns it properly quoted
+for JSON as its result.
+
+[call [cmd ::json::write] [method array] [arg arg]...]
+
+This method takes a series of JSON formatted arguments and returns
+them as a properly formatted JSON array as its result.
+
+[call [cmd ::json::write] [method object] [arg key] [arg value]...]
+
+This method takes a series of key/value arguments, the values already
+formatted for JSON, and returns them as a properly formatted JSON
+object as its result, with the keys formatted as JSON strings.
+
+[list_end]
+[para]
+
+[vset CATEGORY json]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/json/json_write.pcx b/tcllib/modules/json/json_write.pcx
new file mode 100644
index 0000000..3d2dd14
--- /dev/null
+++ b/tcllib/modules/json/json_write.pcx
@@ -0,0 +1,42 @@
+# -*- tcl -*- json_write.pcx
+# Syntax of the commands provided by package json::write.
+#
+# 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 json::write
+pcx::tcldep 1.0 needs tcl 8.5
+
+namespace eval ::json::write {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.0 std ::json::write {checkSimpleArgs 1 -1 {
+ {checkOption {
+ {indented {checkSimpleArgs 0 1 {
+ checkBoolean
+ }}}
+ {aligned {checkSimpleArgs 0 1 {
+ checkBoolean
+ }}}
+ {string {checkSimpleArgs 1 1 {
+ checkWord
+ }}}
+ {array {checkSimpleArgs 0 -1 {
+ checkWord
+ }}}
+ {object {checkSimpleArgsModNk 0 2 {
+ checkWord
+ checkWord
+ }}}
+ } {}}
+}
+
+# Initialization via pcx::init.
+# Use a ::json::write::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/json/json_write.tcl b/tcllib/modules/json/json_write.tcl
new file mode 100644
index 0000000..c60c12e
--- /dev/null
+++ b/tcllib/modules/json/json_write.tcl
@@ -0,0 +1,200 @@
+# json_write.tcl --
+#
+# Commands for the generation of JSON (Java Script Object Notation).
+#
+# Copyright (c) 2009-2011 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: json_write.tcl,v 1.2 2011/08/24 20:09:44 andreas_kupries Exp $
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+
+namespace eval ::json::write {
+ namespace export \
+ string array object indented aligned
+
+ namespace ensemble create
+}
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc ::json::write::indented {{bool {}}} {
+ variable indented
+
+ if {[llength [info level 0]] > 2} {
+ return -code error {wrong # args: should be "json::write indented ?bool?"}
+ } elseif {[llength [info level 0]] == 2} {
+ if {![::string is boolean -strict $bool]} {
+ return -code error "Expected boolean, got \"$bool\""
+ }
+ set indented $bool
+ if {!$indented} {
+ variable aligned 0
+ }
+ }
+
+ return $indented
+}
+
+proc ::json::write::aligned {{bool {}}} {
+ variable aligned
+
+ if {[llength [info level 0]] > 2} {
+ return -code error {wrong # args: should be "json::write aligned ?bool?"}
+ } elseif {[llength [info level 0]] == 2} {
+ if {![::string is boolean -strict $bool]} {
+ return -code error "Expected boolean, got \"$bool\""
+ }
+ set aligned $bool
+ if {$aligned} {
+ variable indented 1
+ }
+ }
+
+ return $aligned
+}
+
+proc ::json::write::string {s} {
+ variable quotes
+ return "\"[::string map $quotes $s]\""
+}
+
+proc ::json::write::array {args} {
+ # always compact form.
+ return "\[[join $args ,]\]"
+}
+
+proc ::json::write::object {args} {
+ # The dict in args maps string keys to json-formatted data. I.e.
+ # we have to quote the keys, but not the values, as the latter are
+ # already in the proper format.
+
+ variable aligned
+ variable indented
+
+ if {[llength $args] %2 == 1} {
+ return -code error {wrong # args, expected an even number of arguments}
+ }
+
+ set dict {}
+ foreach {k v} $args {
+ lappend dict [string $k] $v
+ }
+
+ if {$aligned} {
+ set max [MaxKeyLength $dict]
+ }
+
+ if {$indented} {
+ set content {}
+ foreach {k v} $dict {
+ if {$aligned} {
+ set k [AlignLeft $max $k]
+ }
+ if {[::string match *\n* $v]} {
+ # multi-line value
+ lappend content " $k : [Indent $v { } 1]"
+ } else {
+ # single line value.
+ lappend content " $k : $v"
+ }
+ }
+ if {[llength $content]} {
+ return "\{\n[join $content ,\n]\n\}"
+ } else {
+ return "\{\}"
+ }
+ } else {
+ # ultra compact form.
+ set tmp {}
+ foreach {k v} $dict {
+ lappend tmp "$k:$v"
+ }
+ return "\{[join $tmp ,]\}"
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Internals.
+
+proc ::json::write::Indent {text prefix skip} {
+ set pfx ""
+ set result {}
+ foreach line [split $text \n] {
+ if {!$skip} { set pfx $prefix } else { incr skip -1 }
+ lappend result ${pfx}$line
+ }
+ return [join $result \n]
+}
+
+proc ::json::write::MaxKeyLength {dict} {
+ # Find the max length of the keys in the dictionary.
+
+ set lengths 0 ; # This will be the max if the dict is empty, and
+ # prevents the mathfunc from throwing errors for
+ # that case.
+
+ foreach str [dict keys $dict] {
+ lappend lengths [::string length $str]
+ }
+
+ return [tcl::mathfunc::max {*}$lengths]
+}
+
+proc ::json::write::AlignLeft {fieldlen str} {
+ return [format %-${fieldlen}s $str]
+ #return $str[::string repeat { } [expr {$fieldlen - [::string length $str]}]]
+}
+
+# ### ### ### ######### ######### #########
+
+namespace eval ::json::write {
+ # Configuration of the layout to write.
+
+ # indented = boolean. objects are indented.
+ # aligned = boolean. object keys are aligned vertically.
+
+ # aligned => indented.
+
+ # Combinations of the format specific entries
+ # I A |
+ # - - + ---------------------
+ # 0 0 | Ultracompact (no whitespace, single line)
+ # 1 0 | Indented
+ # 0 1 | Not possible, per the implications above.
+ # 1 1 | Indented + vertically aligned keys
+ # - - + ---------------------
+
+ variable indented 1
+ variable aligned 1
+
+ variable quotes \
+ [list "\"" "\\\"" \\ \\\\ \b \\b \f \\f \n \\n \r \\r \t \\t \
+ \x00 \\u0000 \x01 \\u0001 \x02 \\u0002 \x03 \\u0003 \
+ \x04 \\u0004 \x05 \\u0005 \x06 \\u0006 \x07 \\u0007 \
+ \x0b \\u000b \x0e \\u000e \x0f \\u000f \x10 \\u0010 \
+ \x11 \\u0011 \x12 \\u0012 \x13 \\u0013 \x14 \\u0014 \
+ \x15 \\u0015 \x16 \\u0016 \x17 \\u0017 \x18 \\u0018 \
+ \x19 \\u0019 \x1a \\u001a \x1b \\u001b \x1c \\u001c \
+ \x1d \\u001d \x1e \\u001e \x1f \\u001f \x7f \\u007f \
+ \x80 \\u0080 \x81 \\u0081 \x82 \\u0082 \x83 \\u0083 \
+ \x84 \\u0084 \x85 \\u0085 \x86 \\u0086 \x87 \\u0087 \
+ \x88 \\u0088 \x89 \\u0089 \x8a \\u008a \x8b \\u008b \
+ \x8c \\u008c \x8d \\u008d \x8e \\u008e \x8f \\u008f \
+ \x90 \\u0090 \x91 \\u0091 \x92 \\u0092 \x93 \\u0093 \
+ \x94 \\u0094 \x95 \\u0095 \x96 \\u0096 \x97 \\u0097 \
+ \x98 \\u0098 \x99 \\u0099 \x9a \\u009a \x9b \\u009b \
+ \x9c \\u009c \x9d \\u009d \x9e \\u009e \x9f \\u009f ]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide json::write 1.0.3
+return
diff --git a/tcllib/modules/json/json_write.test b/tcllib/modules/json/json_write.test
new file mode 100644
index 0000000..78d745a
--- /dev/null
+++ b/tcllib/modules/json/json_write.test
@@ -0,0 +1,218 @@
+# json_write.test - Copyright (C) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# Tests for the Tcllib json::write package
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: json_write.test,v 1.1 2009/11/25 04:41:01 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+testing {
+ useLocal json_write.tcl json::write
+}
+
+# -------------------------------------------------------------------------
+
+set data {grammar {
+ rules {
+ A {is {/ {t +} {t -}} mode value}
+ D {is {/ {t 0} {t 1} } mode value}
+ E {is {/ {x {t (} {n E} {t )}} {x {n F} {* {x {n M} {n F}}}}} mode value}
+ F {is {x {n T} {* {x {n A} {n T}}}} mode value}
+ M {is {/ {t *} {t /}} mode value}
+ N {is {x {? {n S}} {+ {n D}}} mode value}
+ S {is {/ {t +} {t -}} mode value}
+ T {is {n N} mode value}
+ }
+ start {n Expression}
+}}
+
+proc gen {serial} {
+ array set g $serial
+ array set g $g(grammar)
+ unset g(grammar)
+
+ # Assemble the rules ...
+ set rules {}
+ foreach {symbol def} $g(rules) {
+ lassign $def _ is _ mode
+ lappend rules $symbol \
+ [json::write object \
+ is [json::write string $is] \
+ mode [json::write string $mode]]
+ }
+
+ # Assemble the final result ...
+ return [json::write object grammar \
+ [json::write object \
+ rules [json::write object {*}$rules] \
+ start [json::write string $g(start)]]]
+}
+
+# -------------------------------------------------------------------------
+# Tests
+# -------------------------------------------------------------------------
+
+test json-write-1.0 {default configuration} -body {
+ list [json::write indented] [json::write aligned]
+} -result {1 1}
+
+test json-write-1.1 {implied configurations} -body {
+ json::write indented 0
+ list [json::write indented] [json::write aligned]
+} -result {0 0}
+
+test json-write-1.2 {implied configurations} -body {
+ json::write indented 0
+ json::write aligned 0
+ json::write aligned 1
+ list [json::write indented] [json::write aligned]
+} -result {1 1}
+
+# -------------------------------------------------------------------------
+
+test json-write-2.0 {argument errors} -body {
+ json::write indented X Y
+} -returnCodes 1 -result {wrong # args: should be "json::write indented ?bool?"}
+
+test json-write-2.1 {argument errors} -body {
+ json::write aligned X Y
+} -returnCodes 1 -result {wrong # args: should be "json::write aligned ?bool?"}
+
+test json-write-2.2 {argument errors} -body {
+ json::write string
+} -returnCodes 1 -result {wrong # args: should be "json::write string s"}
+
+test json-write-2.3 {argument errors} -body {
+ json::write string A B
+} -returnCodes 1 -result {wrong # args: should be "json::write string s"}
+
+test json-write-2.4 {argument errors} -body {
+ json::write object A
+} -returnCodes 1 -result {wrong # args, expected an even number of arguments}
+
+# -------------------------------------------------------------------------
+
+test json-write-3.0 {indented, aligned} -setup {
+ json::write indented 1
+ json::write aligned 1
+} -body {
+ gen $data
+} -result {{
+ "grammar" : {
+ "rules" : {
+ "A" : {
+ "is" : "/ {t +} {t -}",
+ "mode" : "value"
+ },
+ "D" : {
+ "is" : "/ {t 0} {t 1} ",
+ "mode" : "value"
+ },
+ "E" : {
+ "is" : "/ {x {t (} {n E} {t )}} {x {n F} {* {x {n M} {n F}}}}",
+ "mode" : "value"
+ },
+ "F" : {
+ "is" : "x {n T} {* {x {n A} {n T}}}",
+ "mode" : "value"
+ },
+ "M" : {
+ "is" : "/ {t *} {t /}",
+ "mode" : "value"
+ },
+ "N" : {
+ "is" : "x {? {n S}} {+ {n D}}",
+ "mode" : "value"
+ },
+ "S" : {
+ "is" : "/ {t +} {t -}",
+ "mode" : "value"
+ },
+ "T" : {
+ "is" : "n N",
+ "mode" : "value"
+ }
+ },
+ "start" : "n Expression"
+ }
+}}
+
+test json-write-3.1 {indented, !aligned} -setup {
+ json::write indented 1
+ json::write aligned 0
+} -body {
+ gen $data
+} -result {{
+ "grammar" : {
+ "rules" : {
+ "A" : {
+ "is" : "/ {t +} {t -}",
+ "mode" : "value"
+ },
+ "D" : {
+ "is" : "/ {t 0} {t 1} ",
+ "mode" : "value"
+ },
+ "E" : {
+ "is" : "/ {x {t (} {n E} {t )}} {x {n F} {* {x {n M} {n F}}}}",
+ "mode" : "value"
+ },
+ "F" : {
+ "is" : "x {n T} {* {x {n A} {n T}}}",
+ "mode" : "value"
+ },
+ "M" : {
+ "is" : "/ {t *} {t /}",
+ "mode" : "value"
+ },
+ "N" : {
+ "is" : "x {? {n S}} {+ {n D}}",
+ "mode" : "value"
+ },
+ "S" : {
+ "is" : "/ {t +} {t -}",
+ "mode" : "value"
+ },
+ "T" : {
+ "is" : "n N",
+ "mode" : "value"
+ }
+ },
+ "start" : "n Expression"
+ }
+}}
+
+test json-write-3.1 {!indented, !aligned} -setup {
+ json::write indented 0
+ json::write aligned 0
+} -body {
+ gen $data
+} -result {{"grammar":{"rules":{"A":{"is":"/ {t +} {t -}","mode":"value"},"D":{"is":"/ {t 0} {t 1} ","mode":"value"},"E":{"is":"/ {x {t (} {n E} {t )}} {x {n F} {* {x {n M} {n F}}}}","mode":"value"},"F":{"is":"x {n T} {* {x {n A} {n T}}}","mode":"value"},"M":{"is":"/ {t *} {t /}","mode":"value"},"N":{"is":"x {? {n S}} {+ {n D}}","mode":"value"},"S":{"is":"/ {t +} {t -}","mode":"value"},"T":{"is":"n N","mode":"value"}},"start":"n Expression"}}}
+
+
+# -------------------------------------------------------------------------
+
+test json-write-4.0 {string quoting} -body {
+ json::write string "a\"b\\c\bd\fe\nf\rg\th\0i\1j\2k\3l\177m"
+} -result "\"a\\\"b\\\\c\\bd\\fe\\nf\\rg\\th\\u0000i\\u0001j\\u0002k\\u0003l\\u007fm\""
+
+# -------------------------------------------------------------------------
+unset data
+rename gen {}
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/json/jsonc.tcl b/tcllib/modules/json/jsonc.tcl
new file mode 100644
index 0000000..a82226ee
--- /dev/null
+++ b/tcllib/modules/json/jsonc.tcl
@@ -0,0 +1,171 @@
+# jsonc.tcl --
+#
+# Implementation of a JSON parser in C.
+# Binding to a yacc/bison parser by Mikhail.
+#
+# Copyright (c) 2013,2015 - critcl wrapper - Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Copyright (c) 2013 - C binding - mi+tcl.tk-2013@aldan.algebra.com
+
+package require critcl
+# @sak notprovided jsonc
+package provide jsonc 1.1.2
+package require Tcl 8.4
+
+#critcl::cheaders -g
+#critcl::debug memory symbols
+critcl::cheaders -Ic c/*.h
+critcl::csources c/*.c
+
+# # ## ### Import base declarations, forwards ### ## # #
+
+critcl::ccode {
+ #include <json_y.h>
+}
+
+# # ## ### Main Conversion ### ## # #
+
+namespace eval ::json {
+ critcl::ccommand json2dict_critcl {dummy I objc objv} {
+ struct context context = { NULL };
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(I, 1, objv, "json");
+ return TCL_ERROR;
+ }
+
+ context.text = Tcl_GetStringFromObj(objv[1], &context.remaining);
+ context.I = I;
+ context.has_error = 0;
+ context.result = TCL_ERROR;
+
+ jsonparse (&context);
+ return context.result;
+ }
+
+ # Issue with critcl 2 used here. Cannot use '-', incomplete distinction of C and Tcl names.
+ # The json.tcl file making use of this code has a wrapper fixing the issue.
+ critcl::ccommand many_json2dict_critcl {dummy I objc objv} {
+ struct context context = { NULL };
+
+ int max;
+ int found;
+
+ Tcl_Obj* result = Tcl_NewListObj (0, NULL);
+
+ if ((objc < 2) || (objc > 3)) {
+ Tcl_WrongNumArgs(I, 1, objv, "jsonText ?max?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 3) {
+ if (Tcl_GetIntFromObj(I, objv[2], &max) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (max <= 0) {
+ Tcl_AppendResult (I, "Bad limit ",
+ Tcl_GetString (objv[2]),
+ " of json entities to extract.",
+ NULL);
+ Tcl_SetErrorCode (I, "JSON", "BAD-LIMIT", NULL);
+ return TCL_ERROR;
+ }
+
+ } else {
+ max = -1;
+ }
+
+ context.text = Tcl_GetStringFromObj(objv[1], &context.remaining);
+ context.I = I;
+ context.has_error = 0;
+ found = 0;
+
+ /* Iterate over the input until
+ * - we have gotten all requested values.
+ * - we have run out of input
+ * - we have run into an error
+ */
+
+ while ((max < 0) || max) {
+ context.result = TCL_ERROR;
+ jsonparse (&context);
+
+ /* parse error, abort */
+ if (context.result != TCL_OK) {
+ Tcl_DecrRefCount (result);
+ return TCL_ERROR;
+ }
+
+ /* Proper value extracted, extend result */
+ found ++;
+ Tcl_ListObjAppendElement(I, result,
+ Tcl_GetObjResult (I));
+
+ /* Count down on the number of still missing
+ * values, if not asking for all (-1)
+ */
+ if (max > 0) max --;
+
+ /* Jump over trailing whitespace for proper end-detection */
+ jsonskip (&context);
+
+ /* Abort if we have consumed all input */
+ if (!context.remaining) break;
+
+ /* Clear scratch pad before continuing */
+ context.obj = NULL;
+ }
+
+ /* While all parses were ok we reached end of
+ * input without getting all requested values,
+ * this is an error
+ */
+ if (max > 0) {
+ char buf [30];
+ sprintf (buf, "%d", found);
+ Tcl_ResetResult (I);
+ Tcl_AppendResult (I, "Bad limit ",
+ Tcl_GetString (objv[2]),
+ " of json entities to extract, found only ",
+ buf,
+ ".",
+ NULL);
+ Tcl_SetErrorCode (I, "JSON", "BAD-LIMIT", "TOO", "LARGE", NULL);
+ Tcl_DecrRefCount (result);
+ return TCL_ERROR;
+ }
+
+ /* We are good and done */
+ Tcl_SetObjResult(I, result);
+ return TCL_OK;
+ }
+
+ if 0 {critcl::ccommand validate_critcl {dummy I objc objv} {
+ struct context context = { NULL };
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(I, 1, objv, "jsonText");
+ return TCL_ERROR;
+ }
+
+ context.text = Tcl_GetStringFromObj(objv[1], &context.remaining);
+ context.I = I;
+ context.result = TCL_ERROR;
+
+ /* Iterate over the input until we have run
+ * out of text, or encountered an error. We
+ * use only the lexer here, and told it to not
+ * create superfluous token values.
+ */
+
+ while (context.remaining) {
+ if (jsonlex (&context) == -1) {
+ Tcl_SetObjResult(I, Tcl_NewBooleanObj (0));
+ return TCL_OK;
+ }
+ }
+
+ /* We are good and done */
+ Tcl_SetObjResult(I, Tcl_NewBooleanObj (1));
+ return TCL_OK;
+ }}
+}
diff --git a/tcllib/modules/json/pkgIndex.tcl b/tcllib/modules/json/pkgIndex.tcl
new file mode 100644
index 0000000..f605f0c
--- /dev/null
+++ b/tcllib/modules/json/pkgIndex.tcl
@@ -0,0 +1,7 @@
+# Tcl package index file, version 1.1
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded json 1.3.3 [list source [file join $dir json.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+package ifneeded json::write 1.0.3 [list source [file join $dir json_write.tcl]]
diff --git a/tcllib/modules/json/tests/array.json b/tcllib/modules/json/tests/array.json
new file mode 100644
index 0000000..8d87420
--- /dev/null
+++ b/tcllib/modules/json/tests/array.json
@@ -0,0 +1,22 @@
+[
+ {
+ "precision": "zip",
+ "Latitude": 37.7668,
+ "Longitude": -122.3959,
+ "Address": "",
+ "City": "SAN FRANCISCO",
+ "State": "CA",
+ "Zip": "94107",
+ "Country": "US"
+ },
+ {
+ "precision": "zip",
+ "Latitude": 37.371991,
+ "Longitude": -122.026020,
+ "Address": "",
+ "City": "SUNNYVALE",
+ "State": "CA",
+ "Zip": "94085",
+ "Country": "US"
+ }
+ ]
diff --git a/tcllib/modules/json/tests/array.result b/tcllib/modules/json/tests/array.result
new file mode 100644
index 0000000..e97b275
--- /dev/null
+++ b/tcllib/modules/json/tests/array.result
@@ -0,0 +1 @@
+{precision zip Latitude 37.7668 Longitude -122.3959 Address {} City {SAN FRANCISCO} State CA Zip 94107 Country US} {precision zip Latitude 37.371991 Longitude -122.026020 Address {} City SUNNYVALE State CA Zip 94085 Country US}
diff --git a/tcllib/modules/json/tests/array.sort b/tcllib/modules/json/tests/array.sort
new file mode 100644
index 0000000..3f440d5
--- /dev/null
+++ b/tcllib/modules/json/tests/array.sort
@@ -0,0 +1 @@
+list dict
diff --git a/tcllib/modules/json/tests/glossary.json b/tcllib/modules/json/tests/glossary.json
new file mode 100644
index 0000000..f61999e
--- /dev/null
+++ b/tcllib/modules/json/tests/glossary.json
@@ -0,0 +1,15 @@
+{
+ "glossary": {
+ "title": "example glossary",
+ "mixlist": ["a \"\" str", -0.09, null, "", {"member":true}],
+ "GlossDiv": {
+ "title": "S",
+ "GlossList": [{
+ "ID": "SGML",
+ "GlossTerm": "Standard \\\" Language",
+ "Acronym": "SGML\\",
+ "Abbrev": "ISO 8879:1986",
+ "GlossDef":
+ "A meta-markup language, used ...",
+ "GlossSeeAlso": ["GML", "XML", "markup"]}]}}
+}
diff --git a/tcllib/modules/json/tests/glossary.result b/tcllib/modules/json/tests/glossary.result
new file mode 100644
index 0000000..fdb463f
--- /dev/null
+++ b/tcllib/modules/json/tests/glossary.result
@@ -0,0 +1 @@
+glossary {title {example glossary} mixlist {{a "" str} -0.09 null {} {member true}} GlossDiv {title S GlossList {{ID SGML GlossTerm {Standard \" Language} Acronym SGML\\ Abbrev {ISO 8879:1986} GlossDef {A meta-markup language, used ...} GlossSeeAlso {GML XML markup}}}}}
diff --git a/tcllib/modules/json/tests/glossary.sort b/tcllib/modules/json/tests/glossary.sort
new file mode 100644
index 0000000..742cd19
--- /dev/null
+++ b/tcllib/modules/json/tests/glossary.sort
@@ -0,0 +1 @@
+dict * {dict GlossDiv {dict GlossList {list dict}}} \ No newline at end of file
diff --git a/tcllib/modules/json/tests/menu.json b/tcllib/modules/json/tests/menu.json
new file mode 100644
index 0000000..fecef53
--- /dev/null
+++ b/tcllib/modules/json/tests/menu.json
@@ -0,0 +1,12 @@
+{"menu": {
+ "id": "file",
+ "value": "File:",
+ "unival": "\u6021:",
+ "popup": {
+ "menuitem": [
+ {"value": "Open", "onclick": "OpenDoc()"},
+ {"value": "Close", "onclick": "CloseDoc()"}
+ ]
+ }
+}
+}
diff --git a/tcllib/modules/json/tests/menu.result b/tcllib/modules/json/tests/menu.result
new file mode 100644
index 0000000..1855db8
--- /dev/null
+++ b/tcllib/modules/json/tests/menu.result
@@ -0,0 +1 @@
+menu {id file value File: unival @@@: popup {menuitem {{value Open onclick OpenDoc()} {value Close onclick CloseDoc()}}}}
diff --git a/tcllib/modules/json/tests/menu.sort b/tcllib/modules/json/tests/menu.sort
new file mode 100644
index 0000000..d7bcb35
--- /dev/null
+++ b/tcllib/modules/json/tests/menu.sort
@@ -0,0 +1 @@
+dict * {dict popup {dict * {list dict}}} \ No newline at end of file
diff --git a/tcllib/modules/json/tests/menu2.json b/tcllib/modules/json/tests/menu2.json
new file mode 100644
index 0000000..f082a32
--- /dev/null
+++ b/tcllib/modules/json/tests/menu2.json
@@ -0,0 +1,14 @@
+{"menu": {
+ "header": "Viewer",
+ "items": [
+ {"id": "Open"},
+ {"id": "OpenNew", "label": "Open New"},
+ null,
+ {"id": "ZoomIn", "label": "Zoom In"},
+ {"id": "ZoomOut", "label": "Zoom Out"},
+ null,
+ {"id": "Help"},
+ {"id": "About", "label": "About Viewer..."}
+ ]
+}
+}
diff --git a/tcllib/modules/json/tests/menu2.result b/tcllib/modules/json/tests/menu2.result
new file mode 100644
index 0000000..bc7e285
--- /dev/null
+++ b/tcllib/modules/json/tests/menu2.result
@@ -0,0 +1 @@
+menu {header Viewer items {{id Open} {id OpenNew label {Open New}} null {id ZoomIn label {Zoom In}} {id ZoomOut label {Zoom Out}} null {id Help} {id About label {About Viewer...}}}}
diff --git a/tcllib/modules/json/tests/menu2.sort b/tcllib/modules/json/tests/menu2.sort
new file mode 100644
index 0000000..f47f7e9
--- /dev/null
+++ b/tcllib/modules/json/tests/menu2.sort
@@ -0,0 +1 @@
+dict * {dict items {list 0 dict 1 dict 3 dict 4 dict 6 dict 7 dict}}
diff --git a/tcllib/modules/json/tests/support.tcl b/tcllib/modules/json/tests/support.tcl
new file mode 100644
index 0000000..b755027
--- /dev/null
+++ b/tcllib/modules/json/tests/support.tcl
@@ -0,0 +1,148 @@
+
+#use fileutil/fileutil.tcl fileutil
+
+catch {unset JSON}
+catch {unset TCL}
+catch {unset DICTSORT}
+
+proc dictsort3 {spec data} {
+ while [llength $spec] {
+ set type [lindex $spec 0]
+ set spec [lrange $spec 1 end]
+
+ switch -- $type {
+ dict {
+ lappend spec * string
+
+ set json {}
+ foreach {key} [lsort [dict keys $data]] {
+ set val [dict get $data $key]
+ foreach {keymatch valtype} $spec {
+ if {[string match $keymatch $key]} {
+ lappend json $key [dictsort3 $valtype $val]
+ break
+ }
+ }
+ }
+ return $json
+ }
+ list {
+ lappend spec * string
+ set json {}
+ set idx 0
+ foreach {val} $data {
+ foreach {keymatch valtype} $spec {
+ if {$idx == $keymatch || $keymatch eq "*"} {
+ lappend json [dictsort3 $valtype $val]
+ break
+ }
+ }
+ incr idx
+ }
+ return $json
+ }
+ string {
+ return $data
+ }
+ default {
+ error "Invalid type"
+ }
+ }
+ }
+}
+
+foreach f [TestFilesGlob tests/*.json] {
+ set name [file rootname [file tail $f]]
+ set JSON($name) [tcltest::viewFile $f]
+}
+
+foreach f [TestFilesGlob tests/*.result] {
+ set name [file rootname [file tail $f]]
+ set TCL($name) [tcltest::viewFile $f]
+}
+
+foreach f [TestFilesGlob tests/*.sort] {
+ set name [file rootname [file tail $f]]
+ set DICTSORT($name) [tcltest::viewFile $f]
+}
+
+# Postprocessing result of one test case, insert proper expected unicodepoint
+set TCL(menu) [string map [list @@@ \u6021] $TCL(menu)]
+
+set JSON(emptyList) {[]}
+set TCL(emptyList) {}
+
+set JSON(emptyList2) {{"menu": []}}
+set TCL(emptyList2) {menu {}}
+
+set JSON(emptyList3) {["menu", []]}
+set TCL(emptyList3) {menu {}}
+
+set JSON(emptyList4) {[[]]}
+set TCL(emptyList4) {{}}
+
+set JSON(escapes) {"\t\r\n\f\b\/\\\""}
+set TCL(escapes) "\t\r\n\f\b/\\\""
+
+
+
+foreach f [TestFilesGlob tests/*.fail] {
+ set name [file rootname [file tail $f]]
+ set FAIL($name) [tcltest::viewFile $f]
+}
+
+foreach f [TestFilesGlob tests/*.err] {
+ set name [file rootname [file tail $f]]
+ set ERR($name) [tcltest::viewFile $f]
+}
+
+## Tcl has strict escape checking.
+## C uses Tcl_UtfBacklash, and allows lots of irregular escapes.
+
+set FAIL(escape1) {"\%"}
+set ERR(escape1-tcl) {unexpected token ""\%"" at position 0; expecting STRING}
+set ERR(escape1-critcl) {bad escape 3 bytes before end, around ``%''}
+
+set FAIL(escape2) {"\."}
+set ERR(escape2-tcl) {unexpected token ""\."" at position 0; expecting STRING}
+set ERR(escape2-critcl) {bad escape 3 bytes before end, around ``.''}
+
+set FAIL(escape3) {["\%"]}
+set ERR(escape3-tcl) {unexpected token ""\%"" at position 1; expecting STRING}
+set ERR(escape3-critcl) {bad escape 4 bytes before end, around ``%''}
+
+set FAIL(escape4) {["\."]}
+set ERR(escape4-tcl) {unexpected token ""\."" at position 1; expecting STRING}
+set ERR(escape4-critcl) {bad escape 4 bytes before end, around ``.''}
+
+set FAIL(escape5) {{"a":"\%"}}
+set ERR(escape5-tcl) {unexpected token ""\%"" at position 3; expecting STRING}
+set ERR(escape5-critcl) {bad escape 4 bytes before end, around ``%''}
+
+set FAIL(escape6) {{"a":"\."}}
+set ERR(escape6-tcl) {unexpected token ""\."" at position 3; expecting STRING}
+set ERR(escape6-critcl) {bad escape 4 bytes before end, around ``.''}
+
+
+
+proc resultfor {name} {
+ global TCL
+ transform $TCL($name) $name
+}
+
+proc transform {res name} {
+ global DICTSORT
+ if {[info exists DICTSORT($name)]} {
+ return [dictsort3 $DICTSORT($name) $res]
+ } else {
+ return $res
+ }
+}
+
+proc transform* {res args} {
+ set t {}
+ foreach r $res n $args {
+ lappend t [transform $r $n]
+ }
+ return $t
+}
diff --git a/tcllib/modules/json/tests/widget.json b/tcllib/modules/json/tests/widget.json
new file mode 100644
index 0000000..0bcce8b
--- /dev/null
+++ b/tcllib/modules/json/tests/widget.json
@@ -0,0 +1,19 @@
+{"widget": {
+ "debug": "on",
+ "window": {
+ "title":"Sample Widget",
+ "name": "main_window",
+ "width": 500,
+ "height": 500},
+ "text": {
+ "data": "Click Here",
+ "size": 36,
+ "style": "bold",
+ "name": null,
+ "hOffset":250,
+ "vOffset": 100,
+ "alignment": "center",
+ "onMouseUp": "sun1.opacity = (sun1.opacity / 100) * 90;"
+ }
+}
+}
diff --git a/tcllib/modules/json/tests/widget.result b/tcllib/modules/json/tests/widget.result
new file mode 100644
index 0000000..feaa6b2
--- /dev/null
+++ b/tcllib/modules/json/tests/widget.result
@@ -0,0 +1 @@
+widget {debug on window {title {Sample Widget} name main_window width 500 height 500} text {data {Click Here} size 36 style bold name null hOffset 250 vOffset 100 alignment center onMouseUp {sun1.opacity = (sun1.opacity / 100) * 90;}}}
diff --git a/tcllib/modules/json/tests/widget.sort b/tcllib/modules/json/tests/widget.sort
new file mode 100644
index 0000000..4ae41f7
--- /dev/null
+++ b/tcllib/modules/json/tests/widget.sort
@@ -0,0 +1 @@
+dict * {dict text dict window dict}
diff --git a/tcllib/modules/lambda/ChangeLog b/tcllib/modules/lambda/ChangeLog
new file mode 100644
index 0000000..a81d60e
--- /dev/null
+++ b/tcllib/modules/lambda/ChangeLog
@@ -0,0 +1,16 @@
+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-05-31 Andreas Kupries <andreask@activestate.com>
+
+ * New module and package: lambda. Easy anonymous procedures for
+ Tcl 8.5+.
diff --git a/tcllib/modules/lambda/lambda.man b/tcllib/modules/lambda/lambda.man
new file mode 100644
index 0000000..ceda76a
--- /dev/null
+++ b/tcllib/modules/lambda/lambda.man
@@ -0,0 +1,89 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin lambda n 1]
+[see_also apply(n)]
+[see_also proc(n)]
+[keywords {anonymous procedure}]
+[keywords callback]
+[keywords {command prefix}]
+[keywords currying]
+[keywords lambda]
+[keywords {partial application}]
+[keywords proc]
+[copyright {2011 Andreas Kupries, BSD licensed}]
+[moddesc {Utility commands for anonymous procedures}]
+[titledesc {Utility commands for anonymous procedures}]
+[category Utility]
+[require Tcl 8.5]
+[require lambda [opt 1]]
+[description]
+[para]
+
+This package provides two convenience commands to make the writing of
+anonymous procedures, i.e. lambdas more [cmd proc]-like. Instead of,
+for example, to write
+
+[example {
+ set f {::apply {{x} {
+ ....
+ }}}
+}]
+
+with its deep nesting of braces, or
+
+[example {
+ set f [list ::apply {{x y} {
+ ....
+ }} $value_for_x]
+}]
+
+with a list command to insert some of the arguments of a partial
+application, just write
+
+[example {
+ set f [lambda {x} {
+ ....
+ }]
+}]
+
+and
+
+[example {
+ set f [lambda {x y} {
+ ....
+ } $value_for_x]
+}]
+
+[section {COMMANDS}]
+
+[list_begin definitions]
+[comment {- - -- --- ----- -------- ------------- ---------------------}]
+[call [cmd ::lambda] [arg arguments] [arg body] [opt [arg arg]...]]
+
+The command constructs an anonymous procedure from the list of
+arguments, body script and (optional) predefined argument values and
+returns a command prefix representing this anonymous procedure.
+
+[para] When invoked the [arg body] is run in a new procedure scope
+just underneath the global scope, with the arguments set to the values
+supplied at both construction and invokation time.
+
+[comment {- - -- --- ----- -------- ------------- ---------------------}]
+[call [cmd ::lambda@] [arg namespace] [arg arguments] [arg body] [opt [arg arg]...]]
+
+The command constructs an anonymous procedure from the namespace name,
+list of arguments, body script and (optional) predefined argument
+values and returns a command prefix representing this anonymous
+procedure.
+
+[para] When invoked the [arg body] is run in a new procedure scope in
+the [arg namespace], with the arguments set to the values supplied at
+both construction and invokation time.
+
+[list_end]
+
+[section AUTHORS]
+Andreas Kupries
+
+[vset CATEGORY lambda]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/lambda/lambda.tcl b/tcllib/modules/lambda/lambda.tcl
new file mode 100644
index 0000000..800babc
--- /dev/null
+++ b/tcllib/modules/lambda/lambda.tcl
@@ -0,0 +1,43 @@
+# # ## ### ##### ######## ############# ####################
+## -*- tcl -*-
+## (C) 2011 Andreas Kupries, BSD licensed.
+
+# Two convenience commands to make the writing of anonymous
+# procedures, i.e. lambdas more proc-like. Instead of, for example, to
+# write
+#
+# set f {::apply {{x} { .... }}}
+#
+# with its deep nesting of braces, or (if we wish to curry (*))
+#
+# set f [list ::apply {{x y} { .... }} $valueforx]
+#
+# with a list command to insert the arguments, just write
+#
+# set f [lambda {x} { .... }]
+# and
+# set f [lambda {x y} { .... } $valueforx]
+#
+# (*) Pre-supply arguments to the anon proc, making the lambda a
+# partial application.
+
+# # ## ### ##### ######## ############# ####################
+## Requisites
+
+package require Tcl 8.5
+
+# # ## ### ##### ######## ############# #####################
+## Public API implementation
+
+proc lambda {arguments body args} {
+ return [list ::apply [list $arguments $body] {*}$args]
+}
+
+proc lambda@ {ns arguments body args} {
+ return [list ::apply [list $arguments $body $ns] {*}$args]
+}
+
+# # ## ### ##### ######## ############# ####################
+## Ready
+package provide lambda 1
+
diff --git a/tcllib/modules/lambda/pkgIndex.tcl b/tcllib/modules/lambda/pkgIndex.tcl
new file mode 100644
index 0000000..898e431
--- /dev/null
+++ b/tcllib/modules/lambda/pkgIndex.tcl
@@ -0,0 +1,8 @@
+#checker -scope global exclude warnUndefinedVar
+# var in question is 'dir'.
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ # PRAGMA: returnok
+ return
+}
+# Utility wrapper around ::apply for easier writing.
+package ifneeded lambda 1 [list source [file join $dir lambda.tcl]]
diff --git a/tcllib/modules/ldap/ChangeLog b/tcllib/modules/ldap/ChangeLog
new file mode 100644
index 0000000..069f995
--- /dev/null
+++ b/tcllib/modules/ldap/ChangeLog
@@ -0,0 +1,358 @@
+2016-01-02 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldapx.man: Fix wrong example [Ticket: 2886893fff]
+
+
+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-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-11-24 Andreas Kupries <andreask@activestate.com>
+
+ * ldap.man: Fixed syntax error in unvalidated documentation of
+ last checkin.
+
+2008-11-22 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.tcl: Added handling for search result references.
+ * ldap.man: Those are common for ActiveDirectory.
+ * pkgIndex.tcl: Bumped version to 1.8.
+ * ldap.test:
+
+2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11 ========================
+ *
+
+2008-10-02 Andreas Kupries <andreask@activestate.com>
+
+ * ldapx.man: Redirected the reference to non-existing subsection
+ 'Data' to 'Entry Instance Data'. Fixed [SF Bug 2124523].
+
+2008-03-26 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.tcl: Applied Tcllib patch #2018141 with some changes,
+ * ldap.man: This fixes and enhances the ldap search
+ * ldap.test: filter handling. Big thanks to Konstantin
+ * pkgIndex.tcl: Khomoutov for the patch and tests.
+ This fixes Tcllib bugs #1751871 and #1852718.
+ Additionally fixed the other ldap tests to use
+ a more concise style.
+ Bumped version to 1.7.
+
+2008-03-26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ldap.tcl (ldap::buildSASLBindRequest): Fixed a bad continuation
+ * ldap.man: line, i.e. whitespace between the backslash and the
+ * pkgIndex.tcl: end-of-line. Generally removed all trailing
+ whitespace from the whole file. Bumped version to 1.6.9.
+
+2008-02-07 Pierre David <pdav@users.sourceforge.net>
+
+ * ldapx.tcl: Fixed a small bug when reading an LDIF modrdn.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-xx Pierre David <pdav@users.sourceforge.net>
+
+ * ldapx.tcl: Modified format for "change" entries
+ * ldapx.test: Adapted tests
+ * ldapx.man: Added a note about the format: for internal use only.
+
+ ***POTENTIAL INCOMPATIBILITY***
+ Format of ldapx::entry "change" data was not sufficient
+ to represent all modifications made on entries. So, the
+ format has been modified to include several invidual
+ changes. This should not be a problem since "change"
+ format is intended to be used only by ldapx methods.
+
+2007-08-06 Pierre David <pdav@users.sourceforge.net>
+
+ * ldapx.tcl: Saved dn was not restored during swap method.
+ ldapx.test: Added test for backuped dn.
+
+2007-08-03 Andreas Kupries <andreask@activestate.com>
+
+ * ldapx.man: Fix class command which was broken across lines.
+
+2007-08-03 Pierre David <pdav@users.sourceforge.net>
+
+ * ldapx.tcl: Fixed reading of LDIF change entries.
+ Fixed modification of an entry by replacing
+ values instead of removing and adding the minimal
+ set of changes, since LDAP schemas don't necessarily
+ include equality operator for each attribute.
+ Introduced a "-utf8" option in the LDIF class.
+ Fixed indentation for LDIF continuation lines
+ for Base64 encoded values.
+ Fixed set1 when given an empty value: it deletes
+ the attribute (as with set).
+ * ldapx.test: Fixed test for the new replacement mode.
+ * ldapx.man: Added documentation for "-utf8" option.
+
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ldap.man: Fixed all warnings due to use of now deprecated
+ * ldapx.man: commands. Added a section about how to give feedback.
+
+2006-11-15 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.tcl: Removed a leftover debug output..
+
+2006-11-08 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldapx.tcl: Whitespace fixes. Tests for fixed bug
+ * ldapx.test: added.
+
+2006-11-04 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldapx.tcl: Fix for entry diff applied.
+ * ldap.man: Thanks to Pierre David for providing it.
+ * pkgIndex.tcl:
+
+2006-10-26 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.man: Some typo fixes, minor clarifications
+ and rewording.
+
+2006-10-09 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.tcl: The abandon operation was incorrectly encoded.
+ This is now fixed and the operation works
+ as expected.
+
+2006-10-09 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldapx.tcl: Fixed incorrect utf-8 conversion and
+ broken ldif::write method.
+ Thanks to Pierre David for providing
+ the fix.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-28 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.tcl: Nasty bug in ReceiveBytes, not detecting
+ partial results correctly.
+
+2006-09-27 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldapx.test: New test file for the ldapx entry functions.
+ Thanks to Pierre David for providing it.
+
+2006-09-26 Andreas Kupries <andreask@activestate.com>
+
+ * ldapx.man: Fixed ambigous subsection titles reported by Larry
+ Virden via [SF Tcllib Bug 1565836]. Additionally fixed a syntax
+ error (missing closed double-apostroph) in an example.
+
+2006-09-24 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.tcl Fixed bug in secure_connect. The
+ channel wasn't fconfigured correctly and
+ the fileevent handler was not installed
+ in the correct way.
+
+2006-09-22 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.test Added some more smoketests for the public
+ API, so that at least some brokenness is
+ detected.
+
+2006-09-20 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.tcl Completly redone broken error handling in
+ pkgIndex.tcl the fileevent handler, now it no
+ ldap.man longer calls bgerror but cleans up
+ the outstanding messages for the
+ connection and delivers the error
+ to those waiting handlers. More stupid
+ typo fixes.
+
+ * ldapx.tcl Some bugfixes for error handling
+ ldap.tcl when searchInit is called with invalid
+ ldap.man arguments. Thanks to Pierre David
+ pkgIndex.tcl <pdav@users.sourceforge.net> for finding
+ them.
+
+2006-09-15 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldapx.tcl Some more fixes in the ldif part.
+
+ * ldapx.tcl Imported some bug fixes from a new
+ ldapx.man version of ldapx by Pierre David.
+ pkgIndex.tcl Fixed bug in modifyDN, fixed wrong start
+ of SASL handshake, some mechanisms require
+ the client to send first.
+
+ * ldap.tcl Fixed broken length calculation in message receiver.
+ pkgIndex.tcl This fixes bug [SF Tcllib Bug 1558564].
+ Fixed various smaller bugs with upvaring handles
+ in info functions.
+ Fixed wrong debug setting.
+
+2006-09-11 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.tcl Fixed missing tlsHandshakeInProgress variable when
+ ldap.man when using ldap::connect.
+ pkgIndex.tcl
+
+2006-09-08 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldapx.tcl New subpackage ldapx provides a snit
+ ldapx.man based OO wrapper around the ldap package.
+ pkgIndex.tcl Based on patch [SF Tcllib Patch 1545931]
+ by Pierre David <pdav@users.sourceforge.net>.
+
+2006-09-01 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.tcl Major changes to the implementation.
+ ldap.man The package now uses a fileevent based
+ ldap.test protocol handler instead of the older blocking
+ pkgIndex.tcl calls.
+ SASL.txt
+
+ ***POTENTIAL INCOMPATIBILITY***
+ Connection failures are no longer handled in the blocking
+ ldap::* commands, instead they appear in the fileevent handler
+ and have to be handled with a bgerror procedure.
+
+ I will add a per handle -errorcallback to the package soon,
+ which will allow user specified handlers, but those are not
+ yet done.
+
+ Applied modified patches [SF Tcllib Patches 1542666, 1541828],
+ thanks to Pierre David for comments and code.
+
+ In addition to this change experimental new (sub-)commands
+ were added:
+
+ This change introduces new subcommands to ldap::info:
+
+ saslmechanisms - show the supported SASL mechanisms
+ features - show the supported server features
+ control - show the supported server controls
+ extensions - show the supported server extensions
+ whoami - show the current authzId
+
+ In addition it introduces a new ldap::starttls command,
+ which allows to upgrade an existing connection to TLS,
+ if the tls extension is present and the server supports it.
+ This may be part of a fix for [Tcllib Bug # 1403369].
+
+ There is also a new ldap::bindSASL command available,
+ which allows a SASL based bind with the help of the
+ tcllib SASL package. See the SASL.txt file for an example.
+
+ The code has been tested a bit against OpenLDAP 2.3, but is
+ not entirely stable yet.
+
+2006-08-03 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.tcl : Applied patch from [SF Tcllib Bug 1191326].
+ * pkgIndex.tcl: Thanks to Pierre David for comments.
+ Version raised to 1.5
+ Removed the duplicated asn code from the
+ module, it now package requires asn 0.6 and
+ namespace imports the appropriate code.
+
+2006-08-03 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.tcl : Applied patch from [SF Tcllib Bug 1533868].
+ * pkgIndex.tcl: Thanks to Pierre David for spotting this.
+ Version raised to 1.4.1
+
+2006-06-20 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.tcl : Applied patch from [SF Tcllib RFE 1082061].
+ * ldap.man : ldap needs Tcl 8.4, raised the level
+ * pkgIndex.tcl: in the docs. Version now 1.4.
+
+2006-06-13 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.tcl : Added ldap::info command for introspection.
+ * ldap.man : Added documentation.
+ * ldap.test : Testsuite for the new info command.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-07-20 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.tcl :
+ pkgIndex.tcl: Applied fix for [SF Tcllib Bug 1239915].
+ Thanks to Pierre David for the patch. Version number now 1.2.1.
+
+2005-03-16 Andreas Kupries <andreask@activestate.com>
+
+ * ldap.tcl (ldap::asnGetInteger): Fixed [SF Tcllib Bug 1164663], a
+ copy/paste bug in the definition of this procedure. It belongs
+ into the ldap namespace, not the asn namespace.
+
+2005-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ldap.tcl: Reformatted to get clean indentation, also trimmed
+ trailing whitespace.
+
+2005-02-15 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ldap.tcl: Fixed various issue with signed/unsigned integers in
+ length and integer encoding/decoding, by crossporting the 64-bit
+ aware integer and length code from the asn module.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-09-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ldap.tcl: Fixed expr'essions without braces.
+
+2004-04-27 Andreas Kupries <andreask@activestate.com>
+
+ * ldap.man: small fixes in the docs, additional example for
+ searches and search result processing.
+
+ * New module: Provided to us by Joechen Loewer <loewerj@web.de>.
+ * Added doctools documentation.
diff --git a/tcllib/modules/ldap/SASL.txt b/tcllib/modules/ldap/SASL.txt
new file mode 100644
index 0000000..8b7b3de
--- /dev/null
+++ b/tcllib/modules/ldap/SASL.txt
@@ -0,0 +1,48 @@
+Using SASL with the tcllib ldap client
+
+The current SASL support for the ldap client has been tested with openLDAP 2.3 and CyrusSASL,
+but is considered experimental.
+
+The OpenLDAP slapd.conf file used for testing had the following entries to map the
+SASL auth information, the actual SASL passwords were stored in the sasldb with the help
+of saslpasswd2:
+
+ # SASL Mappings
+ #
+
+ sasl-host localhost
+ sasl-realm ldap
+ authz-regexp
+ uid=([^,]+),(cn=[^,]+,)?cn=digest-md5,cn=auth
+ ldap:///ou=SomeOU,dc=tcllib,dc=tcltk??one?(uid=$i)
+
+ authz-regexp
+ uid=([^,]+),(cn=[^,]+,)?cn=cram-md5,cn=auth
+ ldap:///ou=SomeOU,dc=tcllib,dc=tcltk??one?(uid=$i)
+
+
+A rather typical user of that server would be for example:
+
+ cn=James Bond,ou=SomeOU,dc=tcllib,dc=tcltk
+ objectClass inetOrgPerson
+ cn James Bond
+ sn Bond
+ uid u007
+
+Now you can SASL auth with the tcllib ldap client with the following:
+
+ package require ldap 1.6
+
+ set handle [ldap::connect localhost]
+ set auth [ldap::bindSASL u007 "mollypenny"]
+ if {$auth} {
+ puts "Succesfully bound with SASL"
+ } else {
+ puts "SASL bind failed"
+ }
+
+To find out your real authzId, you can then use the ldap::whoami command.
+
+ puts "auhtzId: [ldap::whoami $handle]"
+
+
diff --git a/tcllib/modules/ldap/ldap.man b/tcllib/modules/ldap/ldap.man
new file mode 100644
index 0000000..1e6e9ed
--- /dev/null
+++ b/tcllib/modules/ldap/ldap.man
@@ -0,0 +1,525 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin ldap n 1.6.9]
+[keywords {directory access}]
+[keywords internet]
+[keywords ldap]
+[keywords {ldap client}]
+[keywords protocol]
+[keywords {rfc 2251}]
+[keywords {rfc 4511}]
+[keywords x.500]
+[copyright {2004 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[copyright {2004 Jochen Loewer <loewerj@web.de>}]
+[copyright {2006 Michael Schlenker <mic42@users.sourceforge.net>}]
+[moddesc {LDAP client}]
+[titledesc {LDAP client}]
+[category Networking]
+[require Tcl 8.4]
+[require ldap [opt 1.8]]
+[description]
+[para]
+
+The [package ldap] package provides a Tcl-only client library
+for the LDAPv3 protocol as specified in
+
+RFC 4511 ([uri http://www.rfc-editor.org/rfc/rfc4511.txt]).
+
+It works by opening the standard (or secure) LDAP socket on the
+server, and then providing a Tcl API to access the LDAP protocol
+commands. All server errors are returned as Tcl errors (thrown) which
+must be caught with the Tcl [cmd catch] command.
+
+[include ../common-text/tls-security-notes.inc]
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::ldap::connect] [arg host] [opt [arg port]]]
+
+Opens a LDAPv3 connection to the specified [arg host], at the given
+[arg port], and returns a token for the connection. This token is the
+[arg handle] argument for all other commands. If no [arg port] is
+specified it will default to [const 389].
+
+[para]
+
+The command blocks until the connection has been established, or
+establishment definitely failed.
+
+[call [cmd ::ldap::secure_connect] [arg host] [opt [arg port]]]
+
+Like [cmd ::ldap::connect], except that the created connection is
+secured by SSL. The port defaults to [const 636]. This command
+depends on the availability of the package [package TLS], which is a
+SSL binding for Tcl. If [package TLS] is not available, then this
+command will fail.
+
+[para]
+
+The command blocks until the connection has been established, or
+establishment definitely failed.
+
+[call [cmd ::ldap::disconnect] [arg handle]]
+
+Closes the ldap connection refered to by the token
+[arg handle]. Returns the empty string as its result.
+
+[call [cmd ::ldap::starttls] [arg handle] [opt [arg cafile]] [opt [arg certfile]] [opt [arg keyfile]]]
+
+Start TLS negotiation on the connection denoted by [arg handle].
+
+This is currently experimental and subject to change, more control over the TLS details
+will probably be exposed later, to allow users to fine tune the negotiation according
+to their security needs.
+
+[call [cmd ::ldap::bind] [arg handle] [opt [arg name]] [opt [arg password]]]
+
+This command authenticates the ldap connection refered to by the token
+in [arg handle], with a user name and associated password. It blocks
+until a response from the ldap server arrives. Its result is the empty
+string.
+
+Both [arg name] and [arg passwd] default to the empty string if they
+are not specified.
+
+By leaving out [arg name] and [arg passwd] you can make an anonymous bind to
+the ldap server.
+
+You can issue [cmd ::ldap::bind] again to bind with different credentials.
+
+[call [cmd ::ldap::bindSASL] [arg handle] [opt [arg name]] [opt [arg password]]]
+
+This command uses SASL authentication mechanisms to do a multistage bind.
+
+Its otherwise identical to the standard [cmd ::ldap::bind].
+
+This feature is currently experimental and subject to change. See the documentation
+for the [package SASL] and the [file SASL.txt] in the tcllib CVS repository for
+details how to setup and use SASL with openldap.
+
+[call [cmd ::ldap::unbind] [arg handle]]
+
+This command asks the ldap server to release the last bind done for
+the connection refered to by the token in [arg handle].
+
+The [arg handle] is invalid after the unbind, as the server closes the connection.
+So this is effectivly just a more polite disconnect operation.
+
+[call [cmd ::ldap::search] [arg handle] [arg baseObject] [arg filterString] [arg attributes] [arg options]]
+
+This command performs a LDAP search below the [arg baseObject] tree
+using a complex LDAP search expression [arg filterString] and returns
+the specified [arg attributes] of all matching objects (DNs). If the
+list of [arg attributes] was empty all attributes are returned. The
+command blocks until it has received all results.
+
+The valid [arg options] are identical to the options listed for [cmd ::ldap::searchInit].
+
+[para]
+An example of a search expression is
+[para]
+[example {
+ set filterString "|(cn=Linus*)(sn=Torvalds*)"
+}]
+[para]
+
+The return value of the command is a list of nested dictionaries. The
+first level keys are object identifiers (DNs), second levels keys are
+attribute names. In other words, it is in the form
+
+[para]
+[example {
+ {dn1 {attr1 {val11 val12 ...} attr2 {val21...} ...}} {dn2 {a1 {v11 ...} ...}} ...
+}]
+[para]
+
+[call [cmd ::ldap::searchInit] [arg handle] [arg baseObject] [arg filterString] [arg attributes] [arg options]]
+
+This command initiates a LDAP search below the [arg baseObject] tree
+using a complex LDAP search expression [arg filterString].
+The search gets the specified [arg attributes] of all matching objects (DNs).
+
+The command itself just starts the search, to retrieve the actual results, use
+[cmd ::ldap::searchNext].
+A search can be terminated at any time by
+[cmd ::ldap::searchEnd]. This informs the server that no further results should be sent by sending and ABANDON message
+and cleans up the internal state of the search.
+
+Only one [cmd ::ldap::search] can be active at a given time, this
+includes the introspection commands [cmd {::ldap::info saslmechanisms}], [cmd {ldap::info control}] and
+[cmd {ldap::info extensions}], which invoke a search internally.
+
+Error responses from the server due to wrong arguments or similar things are returned
+with the first [cmd ::ldap::searchNext] call and should be checked and dealed with there.
+
+If the list of requested [arg attributes] is empty all attributes will be returned.
+The parameter [arg options] specifies the options to be used in the search,
+and has the following format:
+
+[para]
+[example {
+ {-option1 value1 -option2 value2 ... }
+}]
+[para]
+
+Following options are available:
+
+[list_begin options]
+[opt_def -scope {base one sub} ]
+
+Control the scope of the search to be one of [const base], [const one], or [const sub], to specify a base
+object, one-level or subtree search. The default is [const sub].
+
+[opt_def {-derefaliases} {never search find always}]
+
+Control how aliases dereferencing is done. Should be one of [const never], [const always], [const search], or [const find] to
+specify that aliases are never dereferenced, always dereferenced, dereferenced when searching, or
+dereferenced only when locating the base object for the search.
+The default is to never dereference aliases.
+
+[opt_def {-sizelimit} num ]
+
+Determines the maximum number of entries to return in a search. If specified as
+0 no limit is enforced. The server may enforce a configuration dependent sizelimit,
+which may be lower than the one given by this option. The default is 0, no limit.
+
+[opt_def {-timelimit} seconds]
+
+Asks the server to use a timelimit of [arg seconds] for the search. Zero means no
+limit. The default is 0, no limit.
+
+[opt_def {-attrsonly} boolean]
+
+If set to 1 only the attribute names but not the values will be present in the search result.
+The default is to retrieve attribute names and values.
+
+[opt_def {-referencevar} varname]
+
+If set the search result reference LDAPURIs, if any, are returned in the given variable.
+The caller can than decide to follow those references and query other LDAP servers for
+further results.
+
+[list_end]
+[para]
+
+[call [cmd ::ldap::searchNext] [arg handle]]
+
+This command returns the next entry from a LDAP search initiated
+by [cmd ::ldap::searchInit]. It returns only after a new result is received
+or when no further results are available, but takes care to keep
+the event loop alive.
+
+The returned entry is a list with
+two elements: the first is the DN of the entry, the second is the
+list of attributes and values, under the format:
+
+[para]
+[example {
+ dn {attr1 {val11 val12 ...} attr2 {val21...} ...}
+}]
+[para]
+
+The [cmd ::ldap::searchNext] command returns an empty list at the
+end of the search.
+
+[para]
+
+[call [cmd ::ldap::searchEnd] [arg handle]]
+
+This command terminates a LDAP search initiated
+by [cmd ::ldap::searchInit]. It also cleans up
+the internal state so a new search can be initiated.
+
+If the client has not yet received all results, the client
+sends an ABANDON message to inform the server that no
+further results for the previous search should to be sent.
+
+[para]
+
+[call [cmd ::ldap::modify] [arg handle] [arg dn] \
+ [arg attrValToReplace] \
+ [opt [arg attrToDelete]] \
+ [opt [arg attrValToAdd]]]
+
+This command modifies the object [arg dn] on the ldap server we are
+connected to via [arg handle]. It replaces attributes with new values,
+deletes attributes, and adds new attributes with new values.
+
+All arguments are dictionaries mapping attribute names to values. The
+optional arguments default to the empty dictionary, which means that
+no attributes will be deleted nor added.
+
+[list_begin arguments]
+[arg_def dictionary attrValToReplace in]
+
+No attributes will be changed if this argument is empty. The
+dictionary contains the new attributes and their values. They
+[emph {replace all}] attributes known to the object.
+
+[arg_def dictionary attrToDelete in]
+
+No attributes will be deleted if this argument is empty. The
+dictionary values are restrictions on the deletion. An attribute
+listed here will be deleted if and only if its current value at the
+server matches the value specified in the dictionary, or if the value
+in the dictionary is the empty string.
+
+[arg_def dictionary attrValToAdd in]
+
+No attributes will be added if this argument is empty. The dictionary
+values are the values for the new attributes.
+
+[list_end]
+[para]
+
+The command blocks until all modifications have completed. Its result
+is the empty string.
+
+[call [cmd ::ldap::modifyMulti] [arg handle] [arg dn] \
+ [arg attrValToReplace] \
+ [opt [arg attrValToDelete]] \
+ [opt [arg attrValToAdd]]]
+
+This command modifies the object [arg dn] on the ldap server we are
+connected to via [arg handle]. It replaces attributes with new values,
+deletes attributes, and adds new attributes with new values.
+
+All arguments are lists with the format:
+[para]
+[example {
+ attr1 {val11 val12 ...} attr2 {val21...} ...
+}]
+[para]
+where each value list may be empty for deleting all attributes.
+The optional arguments default to empty lists of attributes to
+delete and to add.
+
+[list_begin arguments]
+[arg_def list attrValToReplace in]
+
+No attributes will be changed if this argument is empty. The
+dictionary contains the new attributes and their values. They
+[emph {replace all}] attributes known to the object.
+
+[arg_def list attrValToDelete in]
+
+No attributes will be deleted if this argument is empty. If no
+value is specified, the whole set of values for an attribute
+will be deleted.
+
+[arg_def list attrValToAdd in]
+
+No attributes will be added if this argument is empty.
+
+[list_end]
+[para]
+
+The command blocks until all modifications have completed. Its result
+is the empty string.
+
+[call [cmd ::ldap::add] [arg handle] [arg dn] [arg attrValueTuples]]
+
+This command creates a new object using the specified [arg dn]. The
+attributes of the new object are set to the values in the list
+[arg attrValueTuples].
+Multiple valuated attributes may be specified using multiple tuples.
+
+The command blocks until the operation has completed. Its result
+is the empty string.
+
+[call [cmd ::ldap::addMulti] [arg handle] [arg dn] [arg attrValueTuples]]
+
+This command is the preferred one to create
+a new object using the specified [arg dn]. The
+attributes of the new object are set to the values in the dictionary
+[arg attrValueTuples] (which is keyed by the attribute names).
+Each tuple is a list containing multiple values.
+
+The command blocks until the operation has completed. Its result
+is the empty string.
+
+[call [cmd ::ldap::delete] [arg handle] [arg dn]]
+
+This command removes the object specified by [arg dn], and all its
+attributes from the server.
+
+The command blocks until the operation has completed. Its result
+is the empty string.
+
+[call [cmd ::ldap::modifyDN] [arg handle] [arg dn] [arg newrdn] [opt [arg deleteOld]] [opt [arg newSuperior]]]]
+
+This command moves or copies the object specified by [arg dn]
+to a new location in the tree of object. This location is
+specified by [arg newrdn], a [emph relative] designation,
+or by [arg newrdn] and [arg newSuperior], a [emph absolute] designation.
+
+The optional argument [arg deleteOld] defaults to [const true],
+i.e. a move operation. If [arg deleteOld] is not set, then the
+operation will create a copy of [arg dn] in the new location.
+
+The optional argument [arg newSuperior] defaults an empty string,
+meaning that the object must not be relocated in another branch of
+the tree. If this argument is given, the argument [arg deleteOld]
+must be specified also.
+
+The command blocks until the operation has completed. Its result
+is the empty string.
+
+[call [cmd ::ldap::info] [cmd ip] [arg handle]]
+
+This command returns the IP address of the remote LDAP server the handle is connected to.
+
+[call [cmd ::ldap::info] [cmd bound] [arg handle]]
+
+This command returns 1 if a handle has successfully completed a [cmd ::ldap::bind].
+If no bind was done or it failed, a 0 is returned.
+
+[call [cmd ::ldap::info] [cmd bounduser] [arg handle]]
+
+This command returns the username used in the bind operation if a handle has successfully completed a [cmd ::ldap::bind].
+If no bound was done or it failed, an empty string is returned.
+
+[call [cmd ::ldap::info] [cmd connections] ]
+
+This command returns all currently existing ldap connection handles.
+
+[call [cmd ::ldap::info] [cmd tls] [arg handle] ]
+
+This command returns 1 if the ldap connection [arg handle] used TLS/SSL for
+connection via [cmd ldap::secure_connect] or completed [cmd ldap::starttls], 0 otherwise.
+
+[call [cmd ::ldap::info] [cmd saslmechanisms] [arg handle]]
+
+Return the supported SASL mechanisms advertised by the server. Only valid in a
+bound state (anonymous or other).
+
+[call [cmd ::ldap::info] [cmd control] [arg handle] ]
+
+Return the supported controls advertised by the server as a list of OIDs. Only valid in a bound state.
+
+This is currently experimental and subject to change.
+
+[call [cmd ::ldap::info] [cmd extensions] [arg extensions] ]
+
+Returns the supported LDAP extensions as list of OIDs. Only valid in a bound state.
+
+This is currently experimental and subject to change.
+
+[call [cmd ::ldap::info] [cmd whoami] [arg handle]]
+
+Returns authzId for the current connection. This implements the RFC 4532
+protocol extension.
+
+[list_end]
+[para]
+
+[section EXAMPLES]
+[para]
+
+A small example, extracted from the test application coming with this
+code.
+
+[para]
+[example {
+ package require ldap
+
+ # Connect, bind, add a new object, modify it in various ways
+
+ set handle [ldap::connect localhost 9009]
+
+ set dn "cn=Manager, o=University of Michigan, c=US"
+ set pw secret
+
+ ldap::bind $handle $dn $pw
+
+ set dn "cn=Test User,ou=People,o=University of Michigan,c=US"
+
+ ldap::add $handle $dn {
+ objectClass OpenLDAPperson
+ cn {Test User}
+ mail test.user@google.com
+ uid testuid
+ sn User
+ telephoneNumber +31415926535
+ telephoneNumber +27182818285
+ }
+
+ set dn "cn=Another User,ou=People,o=University of Michigan,c=US"
+
+ ldap::addMulti $handle $dn {
+ objectClass {OpenLDAPperson}
+ cn {{Anotther User}}
+ mail {test.user@google.com}
+ uid {testuid}
+ sn {User}
+ telephoneNumber {+31415926535 +27182818285}
+ }
+
+ # Replace all attributes
+ ldap::modify $handle $dn [list drink icetea uid JOLO]
+
+ # Add some more
+ ldap::modify $handle $dn {} {} [list drink water \
+ drink orangeJuice pager "+1 313 555 7671"]
+
+ # Delete
+ ldap::modify $handle $dn {} [list drink water \
+ pager ""]
+
+ # Move
+ ldap::modifyDN $handle $dn "cn=Tester"
+
+ # Kill the test object, and shut the connection down.
+ set dn "cn=Tester,ou=People,o=University of Michigan,c=US"
+ ldap::delete $handle $dn
+
+ ldap::unbind $handle
+ ldap::disconnect $handle
+}]
+[para]
+
+And a another example, a simple query, and processing the
+results.
+
+[para]
+[example {
+ package require ldap
+ set handle [ldap::connect ldap.acme.com 389]
+ ldap::bind $handle
+ set results [ldap::search $handle "o=acme,dc=com" "(uid=jdoe)" {}]
+ foreach result $results {
+ foreach {object attributes} $result break
+
+ # The processing here is similar to what 'parray' does.
+ # I.e. finding the longest attribute name and then
+ # generating properly aligned output listing all attributes
+ # and their values.
+
+ set width 0
+ set sortedAttribs {}
+ foreach {type values} $attributes {
+ if {[string length $type] > $width} {
+ set width [string length $type]
+ }
+ lappend sortedAttribs [list $type $values]
+ }
+
+ puts "object='$object'"
+
+ foreach sortedAttrib $sortedAttribs {
+ foreach {type values} $sortedAttrib break
+ foreach value $values {
+ regsub -all "\[\x01-\x1f\]" $value ? value
+ puts [format " %-${width}s %s" $type $value]
+ }
+ }
+ puts ""
+ }
+ ldap::unbind $handle
+ ldap::disconnect $handle
+}]
+
+[vset CATEGORY ldap]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/ldap/ldap.tcl b/tcllib/modules/ldap/ldap.tcl
new file mode 100644
index 0000000..eb82b6e
--- /dev/null
+++ b/tcllib/modules/ldap/ldap.tcl
@@ -0,0 +1,2144 @@
+#-----------------------------------------------------------------------------
+# Copyright (C) 1999-2004 Jochen C. Loewer (loewerj@web.de)
+# Copyright (C) 2006 Michael Schlenker (mic42@users.sourceforge.net)
+#-----------------------------------------------------------------------------
+#
+# A (partial) LDAPv3 protocol implementation in plain Tcl.
+#
+# See RFC 4510 and ASN.1 (X.680) and BER (X.690).
+#
+#
+# This software is copyrighted by Jochen C. Loewer (loewerj@web.de). The
+# following terms apply to all files associated with the software unless
+# explicitly disclaimed in individual files.
+#
+# The authors hereby grant permission to use, copy, modify, distribute,
+# and license this software and its documentation for any purpose, provided
+# that existing copyright notices are retained in all copies and that this
+# notice is included verbatim in any distributions. No written agreement,
+# license, or royalty fee is required for any of the authorized uses.
+# Modifications to this software may be copyrighted by their authors
+# and need not follow the licensing terms described here, provided that
+# the new terms are clearly indicated on the first page of each file where
+# they apply.
+#
+# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+#
+# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+# MODIFICATIONS.
+#
+# $Id: ldap.tcl,v 1.26 2008/11/22 12:25:27 mic42 Exp $
+#
+# written by Jochen Loewer
+# 3 June, 1999
+#
+#-----------------------------------------------------------------------------
+
+package require Tcl 8.4
+package require asn 0.7
+package provide ldap 1.8
+
+namespace eval ldap {
+
+ namespace export connect secure_connect \
+ disconnect \
+ bind unbind \
+ bindSASL \
+ search \
+ searchInit \
+ searchNext \
+ searchEnd \
+ modify \
+ modifyMulti \
+ add \
+ addMulti \
+ delete \
+ modifyDN \
+ info
+
+ namespace import ::asn::*
+
+ variable SSLCertifiedAuthoritiesFile
+ variable doDebug
+
+ set doDebug 0
+
+ # LDAP result codes from the RFC
+ variable resultCode2String
+ array set resultCode2String {
+ 0 success
+ 1 operationsError
+ 2 protocolError
+ 3 timeLimitExceeded
+ 4 sizeLimitExceeded
+ 5 compareFalse
+ 6 compareTrue
+ 7 authMethodNotSupported
+ 8 strongAuthRequired
+ 10 referral
+ 11 adminLimitExceeded
+ 12 unavailableCriticalExtension
+ 13 confidentialityRequired
+ 14 saslBindInProgress
+ 16 noSuchAttribute
+ 17 undefinedAttributeType
+ 18 inappropriateMatching
+ 19 constraintViolation
+ 20 attributeOrValueExists
+ 21 invalidAttributeSyntax
+ 32 noSuchObject
+ 33 aliasProblem
+ 34 invalidDNSyntax
+ 35 isLeaf
+ 36 aliasDereferencingProblem
+ 48 inappropriateAuthentication
+ 49 invalidCredentials
+ 50 insufficientAccessRights
+ 51 busy
+ 52 unavailable
+ 53 unwillingToPerform
+ 54 loopDetect
+ 64 namingViolation
+ 65 objectClassViolation
+ 66 notAllowedOnNonLeaf
+ 67 notAllowedOnRDN
+ 68 entryAlreadyExists
+ 69 objectClassModsProhibited
+ 80 other
+ }
+
+}
+
+
+#-----------------------------------------------------------------------------
+# Lookup an numerical ldap result code and return a string version
+#
+#-----------------------------------------------------------------------------
+proc ::ldap::resultCode2String {code} {
+ variable resultCode2String
+ if {[::info exists resultCode2String($code)]} {
+ return $resultCode2String($code)
+ } else {
+ return "unknownError"
+ }
+}
+
+#-----------------------------------------------------------------------------
+# Basic sanity check for connection handles
+# must be an array
+#-----------------------------------------------------------------------------
+proc ::ldap::CheckHandle {handle} {
+ if {![array exists $handle]} {
+ return -code error \
+ [format "Not a valid LDAP connection handle: %s" $handle]
+ }
+}
+
+#-----------------------------------------------------------------------------
+# info
+#
+#-----------------------------------------------------------------------------
+
+proc ldap::info {args} {
+ set cmd [lindex $args 0]
+ set cmds {connections bound bounduser control extensions features ip saslmechanisms tls whoami}
+ if {[llength $args] == 0} {
+ return -code error \
+ "Usage: \"info subcommand ?handle?\""
+ }
+ if {[lsearch -exact $cmds $cmd] == -1} {
+ return -code error \
+ "Invalid subcommand \"$cmd\", valid commands are\
+ [join [lrange $cmds 0 end-1] ,] and [lindex $cmds end]"
+ }
+ eval [linsert [lrange $args 1 end] 0 ldap::info_$cmd]
+}
+
+#-----------------------------------------------------------------------------
+# get the ip address of the server we connected to
+#
+#-----------------------------------------------------------------------------
+proc ldap::info_ip {args} {
+ if {[llength $args] != 1} {
+ return -code error \
+ "Wrong # of arguments. Usage: ldap::info ip handle"
+ }
+ CheckHandle [lindex $args 0]
+ upvar #0 [lindex $args 0] conn
+ if {![::info exists conn(sock)]} {
+ return -code error \
+ "\"[lindex $args 0]\" is not a ldap connection handle"
+ }
+ return [lindex [fconfigure $conn(sock) -peername] 0]
+}
+
+#-----------------------------------------------------------------------------
+# get the list of open ldap connections
+#
+#-----------------------------------------------------------------------------
+proc ldap::info_connections {args} {
+ if {[llength $args] != 0} {
+ return -code error \
+ "Wrong # of arguments. Usage: ldap::info connections"
+ }
+ return [::info vars ::ldap::ldap*]
+}
+
+#-----------------------------------------------------------------------------
+# check if the connection is bound
+#
+#-----------------------------------------------------------------------------
+proc ldap::info_bound {args} {
+ if {[llength $args] != 1} {
+ return -code error \
+ "Wrong # of arguments. Usage: ldap::info bound handle"
+ }
+ CheckHandle [lindex $args 0]
+ upvar #0 [lindex $args 0] conn
+ if {![::info exists conn(bound)]} {
+ return -code error \
+ "\"[lindex $args 0]\" is not a ldap connection handle"
+ }
+
+ return $conn(bound)
+}
+
+#-----------------------------------------------------------------------------
+# check with which user the connection is bound
+#
+#-----------------------------------------------------------------------------
+proc ldap::info_bounduser {args} {
+ if {[llength $args] != 1} {
+ return -code error \
+ "Wrong # of arguments. Usage: ldap::info bounduser handle"
+ }
+ CheckHandle [lindex $args 0]
+ upvar #0 [lindex $args 0] conn
+ if {![::info exists conn(bound)]} {
+ return -code error \
+ "\"[lindex $args 0]\" is not a ldap connection handle"
+ }
+
+ return $conn(bounduser)
+}
+
+#-----------------------------------------------------------------------------
+# check if the connection uses tls
+#
+#-----------------------------------------------------------------------------
+
+proc ldap::info_tls {args} {
+ if {[llength $args] != 1} {
+ return -code error \
+ "Wrong # of arguments. Usage: ldap::info tls handle"
+ }
+ CheckHandle [lindex $args 0]
+ upvar #0 [lindex $args 0] conn
+ if {![::info exists conn(tls)]} {
+ return -code error \
+ "\"[lindex $args 0]\" is not a ldap connection handle"
+ }
+ return $conn(tls)
+}
+
+proc ldap::info_saslmechanisms {args} {
+ if {[llength $args] != 1} {
+ return -code error \
+ "Wrong # of arguments. Usage: ldap::info saslmechanisms handle"
+ }
+ return [Saslmechanisms [lindex $args 0]]
+}
+
+proc ldap::info_extensions {args} {
+ if {[llength $args] != 1} {
+ return -code error \
+ "Wrong # of arguments. Usage: ldap::info extensions handle"
+ }
+ return [Extensions [lindex $args 0]]
+}
+
+proc ldap::info_control {args} {
+ if {[llength $args] != 1} {
+ return -code error \
+ "Wrong # of arguments. Usage: ldap::info control handle"
+ }
+ return [Control [lindex $args 0]]
+}
+
+proc ldap::info_features {args} {
+ if {[llength $args] != 1} {
+ return -code error \
+ "Wrong # of arguments. Usage: ldap::info features handle"
+ }
+ return [Features [lindex $args 0]]
+}
+
+proc ldap::info_whoami {args} {
+ if {[llength $args] != 1} {
+ return -code error \
+ "Wrong # of arguments. Usage: ldap::info whoami handle"
+ }
+ return [Whoami [lindex $args 0]]
+}
+
+
+#-----------------------------------------------------------------------------
+# Basic server introspection support
+#
+#-----------------------------------------------------------------------------
+proc ldap::Saslmechanisms {conn} {
+ CheckHandle $conn
+ lindex [ldap::search $conn {} {(objectClass=*)} \
+ {supportedSASLMechanisms} -scope base] 0 1 1
+}
+
+proc ldap::Extensions {conn} {
+ CheckHandle $conn
+ lindex [ldap::search $conn {} {(objectClass=*)} \
+ {supportedExtension} -scope base] 0 1 1
+}
+
+proc ldap::Control {conn} {
+ CheckHandle $conn
+ lindex [ldap::search $conn {} {(objectClass=*)} \
+ {supportedControl} -scope base] 0 1 1
+}
+
+proc ldap::Features {conn} {
+ CheckHandle $conn
+ lindex [ldap::search $conn {} {(objectClass=*)} \
+ {supportedFeatures} -scope base] 0 1 1
+}
+
+#-------------------------------------------------------------------------------
+# Implements the RFC 4532 extension "Who am I?"
+#
+#-------------------------------------------------------------------------------
+proc ldap::Whoami {handle} {
+ CheckHandle $handle
+ if {[lsearch [ldap::Extensions $handle] 1.3.6.1.4.1.4203.1.11.3] == -1} {
+ return -code error \
+ "Server does not support the \"Who am I?\" extension"
+ }
+
+ set request [asnApplicationConstr 23 [asnOctetString 1.3.6.1.4.1.4203.1.11.3]]
+ set mid [SendMessage $handle $request]
+ set response [WaitForResponse $handle $mid]
+
+ asnGetApplication response appNum
+ if {$appNum != 24} {
+ return -code error \
+ "unexpected application number ($appNum != 24)"
+ }
+
+ asnGetEnumeration response resultCode
+ asnGetOctetString response matchedDN
+ asnGetOctetString response errorMessage
+ if {$resultCode != 0} {
+ return -code error \
+ -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \
+ "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage"
+ }
+ set whoami ""
+ if {[string length $response]} {
+ asnRetag response 0x04
+ asnGetOctetString response whoami
+ }
+ return $whoami
+}
+
+#-----------------------------------------------------------------------------
+# connect
+#
+#-----------------------------------------------------------------------------
+proc ldap::connect { host {port 389} } {
+
+ #--------------------------------------
+ # connect via TCP/IP
+ #--------------------------------------
+ set sock [socket $host $port]
+ fconfigure $sock -blocking no -translation binary -buffering full
+
+ #--------------------------------------
+ # initialize connection array
+ #--------------------------------------
+ upvar #0 ::ldap::ldap$sock conn
+ catch { unset conn }
+
+ set conn(host) $host
+ set conn(sock) $sock
+ set conn(messageId) 0
+ set conn(tls) 0
+ set conn(bound) 0
+ set conn(bounduser) ""
+ set conn(saslBindInProgress) 0
+ set conn(tlsHandshakeInProgress) 0
+ set conn(lastError) ""
+ set conn(referenceVar) [namespace current]::searchReferences
+ set conn(returnReferences) 0
+
+ fileevent $sock readable [list ::ldap::MessageReceiver ::ldap::ldap$sock]
+ return ::ldap::ldap$sock
+}
+
+#-----------------------------------------------------------------------------
+# secure_connect
+#
+#-----------------------------------------------------------------------------
+proc ldap::secure_connect { host {port 636} } {
+
+ variable SSLCertifiedAuthoritiesFile
+
+ package require tls
+
+ #------------------------------------------------------------------
+ # connect via TCP/IP
+ #------------------------------------------------------------------
+ set sock [socket $host $port]
+ fconfigure $sock -blocking no -translation binary -buffering full
+
+ #------------------------------------------------------------------
+ # make it a SSL connection
+ #
+ #------------------------------------------------------------------
+ #tls::import $sock -cafile $SSLCertifiedAuthoritiesFile -ssl2 no -ssl3 yes -tls1 yes
+ tls::import $sock -cafile "" -certfile "" -keyfile "" \
+ -request 1 -server 0 -require 0 -ssl2 no -ssl3 yes -tls1 yes
+ set retry 0
+ while {1} {
+ if {$retry > 20} {
+ close $sock
+ return -code error "too long retry to setup SSL connection"
+ }
+ if {[catch { tls::handshake $sock } err]} {
+ if {[string match "*resource temporarily unavailable*" $err]} {
+ after 50
+ incr retry
+ } else {
+ close $sock
+ return -code error $err
+ }
+ } else {
+ break
+ }
+ }
+
+ #--------------------------------------
+ # initialize connection array
+ #--------------------------------------
+ upvar ::ldap::ldap$sock conn
+ catch { unset conn }
+
+ set conn(host) $host
+ set conn(sock) $sock
+ set conn(messageId) 0
+ set conn(tls) 1
+ set conn(bound) 0
+ set conn(bounduser) ""
+ set conn(saslBindInProgress) 0
+ set conn(tlsHandshakeInProgress) 0
+ set conn(lasterror) ""
+ set conn(referenceVar) [namespace current]::searchReferences
+ set conn(returnReferences) 0
+
+ fileevent $sock readable [list ::ldap::MessageReceiver ::ldap::ldap$sock]
+ return ::ldap::ldap$sock
+}
+
+
+#------------------------------------------------------------------------------
+# starttls - negotiate tls on an open ldap connection
+#
+#------------------------------------------------------------------------------
+proc ldap::starttls {handle {cafile ""} {certfile ""} {keyfile ""}} {
+ CheckHandle $handle
+
+ upvar #0 $handle conn
+
+ if {$conn(tls)} {
+ return -code error \
+ "Cannot StartTLS on connection, TLS already running"
+ }
+
+ if {[ldap::waitingForMessages $handle]} {
+ return -code error \
+ "Cannot StartTLS while waiting for repsonses"
+ }
+
+ if {$conn(saslBindInProgress)} {
+ return -code error \
+ "Cannot StartTLS while SASL bind in progress"
+ }
+
+ if {[lsearch -exact [ldap::Extensions $handle] 1.3.6.1.4.1.1466.20037] == -1} {
+ return -code error \
+ "Server does not support the StartTLS extension"
+ }
+ package require tls
+
+
+ set request [asnApplicationConstr 23 [asnOctetString 1.3.6.1.4.1.1466.20037]]
+ set mid [SendMessage $handle $request]
+ set conn(tlsHandshakeInProgress) 1
+ set response [WaitForResponse $handle $mid]
+
+ asnGetApplication response appNum
+ if {$appNum != 24} {
+ set conn(tlsHandshakeInProgress) 0
+ return -code error \
+ "unexpected application number ($appNum != 24)"
+ }
+
+ asnGetEnumeration response resultCode
+ asnGetOctetString response matchedDN
+ asnGetOctetString response errorMessage
+ if {$resultCode != 0} {
+ set conn(tlsHandshakeInProgress) 0
+ return -code error \
+ -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \
+ "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage"
+ }
+ set oid "1.3.6.1.4.1.1466.20037"
+ if {[string length $response]} {
+ asnRetag response 0x04
+ asnGetOctetString response oid
+ }
+ if {$oid ne "1.3.6.1.4.1.1466.20037"} {
+ set conn(tlsHandshakeInProgress) 0
+ return -code error \
+ "Unexpected LDAP response"
+ }
+
+ tls::import $conn(sock) -cafile $cafile -certfile $certfile -keyfile $keyfile \
+ -request 1 -server 0 -require 0 -ssl2 no -ssl3 yes -tls1 yes
+ set retry 0
+ while {1} {
+ if {$retry > 20} {
+ close $sock
+ return -code error "too long retry to setup SSL connection"
+ }
+ if {[catch { tls::handshake $conn(sock) } err]} {
+ if {[string match "*resource temporarily unavailable*" $err]} {
+ after 50
+ incr retry
+ } else {
+ close $conn(sock)
+ return -code error $err
+ }
+ } else {
+ break
+ }
+ }
+ set conn(tls) 1
+ set conn(tlsHandshakeInProgress) 0
+ return 1
+}
+
+
+
+#------------------------------------------------------------------------------
+# Create a new unique message and send it over the socket.
+#
+#------------------------------------------------------------------------------
+
+proc ldap::CreateAndSendMessage {handle payload} {
+ upvar #0 $handle conn
+
+ if {$conn(tlsHandshakeInProgress)} {
+ return -code error \
+ "Cannot send other LDAP PDU while TLS handshake in progress"
+ }
+
+ incr conn(messageId)
+ set message [asnSequence [asnInteger $conn(messageId)] $payload]
+ debugData "Message $conn(messageId) Sent" $message
+ puts -nonewline $conn(sock) $message
+ flush $conn(sock)
+ return $conn(messageId)
+}
+
+#------------------------------------------------------------------------------
+# Send a message to the server which expects a response,
+# returns the messageId which is to be used with FinalizeMessage
+# and WaitForResponse
+#
+#------------------------------------------------------------------------------
+proc ldap::SendMessage {handle pdu} {
+ upvar #0 $handle conn
+ set mid [CreateAndSendMessage $handle $pdu]
+
+ # safe the state to match responses
+ set conn(message,$mid) [list]
+ return $mid
+}
+
+#------------------------------------------------------------------------------
+# Send a message to the server without expecting a response
+#
+#------------------------------------------------------------------------------
+proc ldap::SendMessageNoReply {handle pdu} {
+ upvar #0 $handle conn
+ return [CreateAndSendMessage $handle $pdu]
+}
+
+#------------------------------------------------------------------------------
+# Cleanup the storage associated with a messageId
+#
+#------------------------------------------------------------------------------
+proc ldap::FinalizeMessage {handle messageId} {
+ upvar #0 $handle conn
+ trace "Message $messageId finalized"
+ unset -nocomplain conn(message,$messageId)
+}
+
+#------------------------------------------------------------------------------
+# Wait for a response for the given messageId.
+#
+# This waits in a vwait if no message has yet been received or returns
+# the oldest message at once, if it is queued.
+#
+#------------------------------------------------------------------------------
+proc ldap::WaitForResponse {handle messageId} {
+ upvar #0 $handle conn
+
+ trace "Waiting for Message $messageId"
+ # check if the message waits for a reply
+ if {![::info exists conn(message,$messageId)]} {
+ return -code error \
+ [format "Cannot wait for message %d." $messageId]
+ }
+
+ # check if we have a received response in the buffer
+ if {[llength $conn(message,$messageId)] > 0} {
+ set response [lindex $conn(message,$messageId) 0]
+ set conn(message,$messageId) [lrange $conn(message,$messageId) 1 end]
+ return $response
+ }
+
+ # wait for an incoming response
+ vwait [namespace which -variable $handle](message,$messageId)
+ if {[llength $conn(message,$messageId)] == 0} {
+ # We have waited and have been awakended but no message is there
+ if {[string length $conn(lastError)]} {
+ return -code error \
+ [format "Protocol error: %s" $conn(lastError)]
+ } else {
+ return -code error \
+ [format "Broken response for message %d" $messageId]
+ }
+ }
+ set response [lindex $conn(message,$messageId) 0]
+ set conn(message,$messageId) [lrange $conn(message,$messageId) 1 end]
+ return $response
+}
+
+proc ldap::waitingForMessages {handle} {
+ upvar #0 $handle conn
+ return [llength [array names conn message,*]]
+}
+
+#------------------------------------------------------------------------------
+# Process a single response PDU. Decodes the messageId and puts the
+# message into the appropriate queue.
+#
+#------------------------------------------------------------------------------
+
+proc ldap::ProcessMessage {handle response} {
+ upvar #0 $handle conn
+
+ # decode the messageId
+ asnGetInteger response messageId
+
+ # check if we wait for a response
+ if {[::info exists conn(message,$messageId)]} {
+ # append the new message, which triggers
+ # message handlers using vwait on the entry
+ lappend conn(message,$messageId) $response
+ return
+ }
+
+ # handle unsolicited server responses
+
+ if {0} {
+ asnGetApplication response appNum
+ #if { $appNum != 24 } {
+ # error "unexpected application number ($appNum != 24)"
+ #}
+ asnGetEnumeration response resultCode
+ asnGetOctetString response matchedDN
+ asnGetOctetString response errorMessage
+ if {[string length $response]} {
+ asnGetOctetString response responseName
+ }
+ if {[string length $response]} {
+ asnGetOctetString response responseValue
+ }
+ if {$resultCode != 0} {
+ return -code error \
+ -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \
+ "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage"
+ }
+ }
+ #dumpASN1Parse $response
+ #error "Unsolicited message from server"
+
+}
+
+#-------------------------------------------------------------------------------
+# Get the code out of waitForResponse in case of errors
+#
+#-------------------------------------------------------------------------------
+proc ldap::CleanupWaitingMessages {handle} {
+ upvar #0 $handle conn
+ foreach message [array names conn message,*] {
+ set conn($message) [list]
+ }
+}
+
+#-------------------------------------------------------------------------------
+# The basic fileevent based message receiver.
+# It reads PDU's from the network in a non-blocking fashion.
+#
+#-------------------------------------------------------------------------------
+proc ldap::MessageReceiver {handle} {
+ upvar #0 $handle conn
+
+ # We have to account for partial PDUs received, so
+ # we keep some state information.
+ #
+ # conn(pdu,partial) -- we are reading a partial pdu if non zero
+ # conn(pdu,length_bytes) -- the buffer for loading the length
+ # conn(pdu,length) -- we have decoded the length if >= 0, if <0 it contains
+ # the length of the length encoding in bytes
+ # conn(pdu,payload) -- the payload buffer
+ # conn(pdu,received) -- the data received
+
+ # fetch the sequence byte
+ if {[::info exists conn(pdu,partial)] && $conn(pdu,partial) != 0} {
+ # we have decoded at least the type byte
+ } else {
+ foreach {code type} [ReceiveBytes $conn(sock) 1] {break}
+ switch -- $code {
+ ok {
+ binary scan $type c byte
+ set type [expr {($byte + 0x100) % 0x100}]
+ if {$type != 0x30} {
+ CleanupWaitingMessages $handle
+ set conn(lastError) [format "Expected SEQUENCE (0x30) but got %x" $type]
+ return
+ } else {
+ set conn(pdu,partial) 1
+ append conn(pdu,received) $type
+ }
+ }
+ eof {
+ CleanupWaitingMessages $handle
+ set conn(lastError) "Server closed connection"
+ catch {close $conn(sock)}
+ return
+ }
+ default {
+ CleanupWaitingMessages $handle
+ set bytes $type[read $conn(sock)]
+ binary scan $bytes h* values
+ set conn(lastError) [format \
+ "Error reading SEQUENCE response for handle %s : %s : %s" $handle $code $values]
+ return
+ }
+ }
+ }
+
+
+ # fetch the length
+ if {[::info exists conn(pdu,length)] && $conn(pdu,length) >= 0} {
+ # we already have a decoded length
+ } else {
+ if {[::info exists conn(pdu,length)] && $conn(pdu,length) < 0} {
+ # we already know the length, but have not received enough bytes to decode it
+ set missing [expr {1+abs($conn(pdu,length))-[string length $conn(pdu,length_bytes)]}]
+ if {$missing != 0} {
+ foreach {code bytes} [ReceiveBytes $conn(sock) $missing] {break}
+ switch -- $code {
+ "ok" {
+ append conn(pdu,length_bytes) $bytes
+ append conn(pdu,received) $bytes
+ asnGetLength conn(pdu,length_bytes) conn(pdu,length)
+ }
+ "partial" {
+ append conn(pdu,length_bytes) $bytes
+ append conn(pdu,received) $bytes
+ return
+ }
+ "eof" {
+ CleanupWaitingMessages $handle
+ catch {close $conn(sock)}
+ set conn(lastError) "Server closed connection"
+ return
+ }
+ default {
+ CleanupWaitingMessages $handle
+ set conn(lastError) [format \
+ "Error reading LENGTH2 response for handle %s : %s" $handle $code]
+ return
+ }
+ }
+ }
+ } else {
+ # we know nothing, need to read the first length byte
+ foreach {code bytes} [ReceiveBytes $conn(sock) 1] {break}
+ switch -- $code {
+ "ok" {
+ set conn(pdu,length_bytes) $bytes
+ binary scan $bytes c byte
+ set size [expr {($byte + 0x100) % 0x100}]
+ if {$size > 0x080} {
+ set conn(pdu,length) [expr {-1* ($size & 0x7f)}]
+ # fetch the rest with the next fileevent
+ return
+ } else {
+ asnGetLength conn(pdu,length_bytes) conn(pdu,length)
+ }
+ }
+ "eof" {
+ CleanupWaitingMessages $handle
+ catch {close $conn(sock)}
+ set conn(lastError) "Server closed connection"
+ }
+ default {
+ CleanupWaitingMessages $handle
+ set conn(lastError) [format \
+ "Error reading LENGTH1 response for handle %s : %s" $handle $code]
+ return
+ }
+ }
+ }
+ }
+
+ if {[::info exists conn(pdu,payload)]} {
+ # length is decoded, we can read the rest
+ set missing [expr {$conn(pdu,length) - [string length $conn(pdu,payload)]}]
+ } else {
+ set missing $conn(pdu,length)
+ }
+ if {$missing > 0} {
+ foreach {code bytes} [ReceiveBytes $conn(sock) $missing] {break}
+ switch -- $code {
+ "ok" {
+ append conn(pdu,payload) $bytes
+ }
+ "partial" {
+ append conn(pdu,payload) $bytes
+ return
+ }
+ "eof" {
+ CleanupWaitingMessages $handle
+ catch {close $conn(sock)}
+ set conn(lastError) "Server closed connection"
+ }
+ default {
+ CleanupWaitingMessages $handle
+ set conn(lastError) [format \
+ "Error reading DATA response for handle %s : %s" $handle $code]
+ return
+ }
+ }
+ }
+
+ # we have a complete PDU, push it for processing
+ set pdu $conn(pdu,payload)
+ set conn(pdu,payload) ""
+ set conn(pdu,partial) 0
+ unset -nocomplain set conn(pdu,length)
+ set conn(pdu,length_bytes) ""
+
+ # reschedule message Processing
+ after 0 [list ::ldap::ProcessMessage $handle $pdu]
+}
+
+#-------------------------------------------------------------------------------
+# Receive the number of bytes from the socket and signal error conditions.
+#
+#-------------------------------------------------------------------------------
+proc ldap::ReceiveBytes {sock bytes} {
+ set status [catch {read $sock $bytes} block]
+ if { $status != 0 } {
+ return [list error $block]
+ } elseif { [string length $block] == $bytes } {
+ # we have all bytes we wanted
+ return [list ok $block]
+ } elseif { [eof $sock] } {
+ return [list eof $block]
+ } elseif { [fblocked $sock] || ([string length $block] < $bytes)} {
+ return [list partial $block]
+ } else {
+ error "Socket state for socket $sock undefined!"
+ }
+}
+
+#-----------------------------------------------------------------------------
+# bindSASL - does a bind with SASL authentication
+#-----------------------------------------------------------------------------
+
+proc ldap::bindSASL {handle {name ""} {password ""} } {
+ CheckHandle $handle
+
+ package require SASL
+
+ upvar #0 $handle conn
+
+ set mechs [ldap::Saslmechanisms $handle]
+
+ set conn(saslBindInProgress) 1
+ set auth 0
+ foreach mech [SASL::mechanisms] {
+ if {[lsearch -exact $mechs $mech] == -1} { continue }
+ trace "Using $mech for SASL Auth"
+ if {[catch {
+ SASLAuth $handle $mech $name $password
+ } msg]} {
+ trace [format "AUTH %s failed: %s" $mech $msg]
+ } else {
+ # AUTH was successful
+ if {$msg == 1} {
+ set auth 1
+ break
+ }
+ }
+ }
+
+ set conn(saslBindInProgress) 0
+ return $auth
+}
+
+#-----------------------------------------------------------------------------
+# SASLCallback - Callback to use for SASL authentication
+#
+# More or less cut and copied from the smtp module.
+# May need adjustments for ldap.
+#
+#-----------------------------------------------------------------------------
+proc ::ldap::SASLCallback {handle context command args} {
+ upvar #0 $handle conn
+ upvar #0 $context ctx
+ array set options $conn(options)
+ trace "SASLCallback $command"
+ switch -exact -- $command {
+ login { return $options(-username) }
+ username { return $options(-username) }
+ password { return $options(-password) }
+ hostname { return [::info hostname] }
+ realm {
+ if {[string equal $ctx(mech) "NTLM"] \
+ && [info exists ::env(USERDOMAIN)]} {
+ return $::env(USERDOMAIN)
+ } else {
+ return ""
+ }
+ }
+ default {
+ return -code error "error: unsupported SASL information requested"
+ }
+ }
+}
+
+#-----------------------------------------------------------------------------
+# SASLAuth - Handles the actual SASL message exchange
+#
+#-----------------------------------------------------------------------------
+
+proc ldap::SASLAuth {handle mech name password} {
+ upvar 1 $handle conn
+
+ set conn(options) [list -password $password -username $name]
+
+ # check for tcllib bug # 1545306 and reset the nonce-count if
+ # found, so a second call to this code does not fail
+ #
+ if {[::info exists ::SASL::digest_md5_noncecount]} {
+ set ::SASL::digest_md5_noncecount 0
+ }
+
+ set ctx [SASL::new -mechanism $mech \
+ -service ldap \
+ -callback [list ::ldap::SASLCallback $handle]]
+
+ set msg(serverSASLCreds) ""
+ # Do the SASL Message exchanges
+ while {[SASL::step $ctx $msg(serverSASLCreds)]} {
+ # Create and send the BindRequest
+ set request [buildSASLBindRequest "" $mech [SASL::response $ctx]]
+ set messageId [SendMessage $handle $request]
+ debugData bindRequest $request
+
+ set response [WaitForResponse $handle $messageId]
+ FinalizeMessage $handle $messageId
+ debugData bindResponse $response
+
+ array set msg [decodeSASLBindResponse $handle $response]
+
+ # Check for Bind success
+ if {$msg(resultCode) == 0} {
+ set conn(bound) 1
+ set conn(bounduser) $name
+ SASL::cleanup $ctx
+ break
+ }
+
+ # Check if next SASL step is requested
+ if {$msg(resultCode) == 14} {
+ continue
+ }
+
+ SASL::cleanup $ctx
+ # Something went wrong
+ return -code error \
+ -errorcode [list LDAP [resultCode2String $msg(resultCode)] \
+ $msg(matchedDN) $msg(errorMessage)] \
+ "LDAP error [resultCode2String $msg(resultCode)] '$msg(matchedDN)': $msg(errorMessage)"
+ }
+
+ return 1
+}
+
+#----------------------------------------------------------------------------
+#
+# Create a LDAP BindRequest using SASL
+#
+#----------------------------------------------------------------------------
+
+proc ldap::buildSASLBindRequest {name mech {credentials {}}} {
+ if {$credentials ne {}} {
+ set request [ asnApplicationConstr 0 \
+ [asnInteger 3] \
+ [asnOctetString $name] \
+ [asnChoiceConstr 3 \
+ [asnOctetString $mech] \
+ [asnOctetString $credentials] \
+ ] \
+ ]
+ } else {
+ set request [ asnApplicationConstr 0 \
+ [asnInteger 3] \
+ [asnOctetString $name] \
+ [asnChoiceConstr 3 \
+ [asnOctetString $mech] \
+ ] \
+ ]
+ }
+ return $request
+}
+
+#-------------------------------------------------------------------------------
+#
+# Decode an LDAP BindResponse
+#
+#-------------------------------------------------------------------------------
+proc ldap::decodeSASLBindResponse {handle response} {
+ upvar #0 $handle conn
+
+ asnGetApplication response appNum
+ if { $appNum != 1 } {
+ error "unexpected application number ($appNum != 1)"
+ }
+ asnGetEnumeration response resultCode
+ asnGetOctetString response matchedDN
+ asnGetOctetString response errorMessage
+
+ # Check if we have a serverSASLCreds field left,
+ # or if this is a simple response without it
+ # probably an error message then.
+ if {[string length $response]} {
+ asnRetag response 0x04
+ asnGetOctetString response serverSASLCreds
+ } else {
+ set serverSASLCreds ""
+ }
+ return [list appNum $appNum \
+ resultCode $resultCode matchedDN $matchedDN \
+ errorMessage $errorMessage serverSASLCreds $serverSASLCreds]
+}
+
+
+#-----------------------------------------------------------------------------
+# bind - does a bind with simple authentication
+#
+#-----------------------------------------------------------------------------
+proc ldap::bind { handle {name ""} {password ""} } {
+ CheckHandle $handle
+
+ upvar #0 $handle conn
+
+ #-----------------------------------------------------------------
+ # marshal bind request packet and send it
+ #
+ #-----------------------------------------------------------------
+ set request [asnApplicationConstr 0 \
+ [asnInteger 3] \
+ [asnOctetString $name] \
+ [asnChoice 0 $password] \
+ ]
+ set messageId [SendMessage $handle $request]
+ debugData bindRequest $request
+
+ set response [WaitForResponse $handle $messageId]
+ FinalizeMessage $handle $messageId
+ debugData bindResponse $response
+
+ asnGetApplication response appNum
+ if { $appNum != 1 } {
+ error "unexpected application number ($appNum != 1)"
+ }
+ asnGetEnumeration response resultCode
+ asnGetOctetString response matchedDN
+ asnGetOctetString response errorMessage
+ if {$resultCode != 0} {
+ return -code error \
+ -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \
+ "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage"
+ }
+ set conn(bound) 1
+ set conn(bounduser) $name
+}
+
+
+#-----------------------------------------------------------------------------
+# unbind
+#
+#-----------------------------------------------------------------------------
+proc ldap::unbind { handle } {
+ CheckHandle $handle
+
+ upvar #0 $handle conn
+
+ #------------------------------------------------
+ # marshal unbind request packet and send it
+ #------------------------------------------------
+ set request [asnApplication 2 ""]
+ SendMessageNoReply $handle $request
+
+ set conn(bounduser) ""
+ set conn(bound) 0
+ close $conn(sock)
+ set conn(sock) ""
+}
+
+
+#-----------------------------------------------------------------------------
+# search - performs a LDAP search below the baseObject tree using a
+# complex LDAP search expression (like "|(cn=Linus*)(sn=Torvalds*)"
+# and returns all matching objects (DNs) with given attributes
+# (or all attributes if empty list is given) as list:
+#
+# {dn1 { attr1 {val11 val12 ...} attr2 {val21 val22 ... } ... }} {dn2 { ... }} ...
+#
+#-----------------------------------------------------------------------------
+proc ldap::search { handle baseObject filterString attributes args} {
+ CheckHandle $handle
+
+ upvar #0 $handle conn
+
+ searchInit $handle $baseObject $filterString $attributes $args
+
+ set results {}
+ set lastPacket 0
+ while { !$lastPacket } {
+
+ set r [searchNext $handle]
+ if {[llength $r] > 0} then {
+ lappend results $r
+ } else {
+ set lastPacket 1
+ }
+ }
+ searchEnd $handle
+
+ return $results
+}
+#-----------------------------------------------------------------------------
+# searchInProgress - checks if a search is in progress
+#
+#-----------------------------------------------------------------------------
+
+proc ldap::searchInProgress {handle} {
+ CheckHandle $handle
+ upvar #0 $handle conn
+ if {[::info exists conn(searchInProgress)]} {
+ return $conn(searchInProgress)
+ } else {
+ return 0
+ }
+}
+
+#-----------------------------------------------------------------------------
+# searchInit - initiates an LDAP search
+#
+#-----------------------------------------------------------------------------
+proc ldap::searchInit { handle baseObject filterString attributes opt} {
+ CheckHandle $handle
+
+ upvar #0 $handle conn
+
+ if {[searchInProgress $handle]} {
+ return -code error \
+ "Cannot start search. Already a search in progress for this handle."
+ }
+
+ set scope 2
+ set derefAliases 0
+ set sizeLimit 0
+ set timeLimit 0
+ set attrsOnly 0
+
+ foreach {key value} $opt {
+ switch -- [string tolower $key] {
+ -scope {
+ switch -- $value {
+ base { set scope 0 }
+ one - onelevel { set scope 1 }
+ sub - subtree { set scope 2 }
+ default { }
+ }
+ }
+ -derefaliases {
+ switch -- $value {
+ never { set derefAliases 0 }
+ search { set derefAliases 1 }
+ find { set derefAliases 2 }
+ always { set derefAliases 3 }
+ default { }
+ }
+ }
+ -sizelimit {
+ set sizeLimit $value
+ }
+ -timelimit {
+ set timeLimit $value
+ }
+ -attrsonly {
+ set attrsOnly $value
+ }
+ -referencevar {
+ set referenceVar $value
+ }
+ default {
+ return -code error \
+ "Invalid search option '$key'"
+ }
+ }
+ }
+
+ set request [buildSearchRequest $baseObject $scope \
+ $derefAliases $sizeLimit $timeLimit $attrsOnly $filterString \
+ $attributes]
+ set messageId [SendMessage $handle $request]
+ debugData searchRequest $request
+
+ # Keep the message Id, so we know about the search
+ set conn(searchInProgress) $messageId
+ if {[::info exists referenceVar]} {
+ set conn(referenceVar) $referenceVar
+ set $referenceVar [list]
+ }
+
+ return $conn(searchInProgress)
+}
+
+proc ldap::buildSearchRequest {baseObject scope derefAliases
+ sizeLimit timeLimit attrsOnly filterString
+ attributes} {
+ #----------------------------------------------------------
+ # marshal filter and attributes parameter
+ #----------------------------------------------------------
+ set berFilter [filter::encode $filterString]
+
+ set berAttributes ""
+ foreach attribute $attributes {
+ append berAttributes [asnOctetString $attribute]
+ }
+
+ #----------------------------------------------------------
+ # marshal search request packet and send it
+ #----------------------------------------------------------
+ set request [asnApplicationConstr 3 \
+ [asnOctetString $baseObject] \
+ [asnEnumeration $scope] \
+ [asnEnumeration $derefAliases] \
+ [asnInteger $sizeLimit] \
+ [asnInteger $timeLimit] \
+ [asnBoolean $attrsOnly] \
+ $berFilter \
+ [asnSequence $berAttributes] \
+ ]
+
+}
+#-----------------------------------------------------------------------------
+# searchNext - returns the next result of an LDAP search
+#
+#-----------------------------------------------------------------------------
+proc ldap::searchNext { handle } {
+ CheckHandle $handle
+
+ upvar #0 $handle conn
+
+ if {! [::info exists conn(searchInProgress)]} then {
+ return -code error \
+ "No search in progress"
+ }
+
+ set result {}
+ set lastPacket 0
+
+ #----------------------------------------------------------
+ # Wait for a search response packet
+ #----------------------------------------------------------
+
+ set response [WaitForResponse $handle $conn(searchInProgress)]
+ debugData searchResponse $response
+
+ asnGetApplication response appNum
+
+ if {$appNum == 4} {
+ trace "Search Response Continue"
+ #----------------------------------------------------------
+ # unmarshal search data packet
+ #----------------------------------------------------------
+ asnGetOctetString response objectName
+ asnGetSequence response attributes
+ set result_attributes {}
+ while { [string length $attributes] != 0 } {
+ asnGetSequence attributes attribute
+ asnGetOctetString attribute attrType
+ asnGetSet attribute attrValues
+ set result_attrValues {}
+ while { [string length $attrValues] != 0 } {
+ asnGetOctetString attrValues attrValue
+ lappend result_attrValues $attrValue
+ }
+ lappend result_attributes $attrType $result_attrValues
+ }
+ set result [list $objectName $result_attributes]
+ } elseif {$appNum == 5} {
+ trace "Search Response Done"
+ #----------------------------------------------------------
+ # unmarshal search final response packet
+ #----------------------------------------------------------
+ asnGetEnumeration response resultCode
+ asnGetOctetString response matchedDN
+ asnGetOctetString response errorMessage
+ set result {}
+ FinalizeMessage $handle $conn(searchInProgress)
+ unset conn(searchInProgress)
+
+ if {$resultCode != 0} {
+ return -code error \
+ -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \
+ "LDAP error [resultCode2String $resultCode] : $errorMessage"
+ }
+ } elseif {$appNum == 19} {
+ trace "Search Result Reference"
+ #---------------------------------------------------------
+ # unmarshall search result reference packet
+ #---------------------------------------------------------
+
+ # This should be a sequence but Microsoft AD sends just
+ # a URI encoded as an OctetString, so have a peek at the tag
+ # and go on.
+
+ asnPeekTag response tag type constr
+ if {$tag == 0x04} {
+ set references $response
+ } elseif {$tag == 0x030} {
+ asnGetSequence response references
+ }
+
+ set urls {}
+ while {[string length $references]} {
+ asnGetOctetString references url
+ lappend urls $url
+ }
+ if {[::info exists conn(referenceVar)]} {
+ upvar 0 conn(referenceVar) refs
+ if {[llength $refs]} {
+ set refs [concat [set $refs $urls]]
+ } else {
+ set refs $urls
+ }
+ }
+
+ # Get the next search result instead
+ set result [searchNext $handle]
+ }
+
+ # Unknown application type of result set.
+ # We should just ignore it since the only PDU the server
+ # MUST return if it understood our request is the "search response
+ # done" (apptype 5) which we know how to process.
+
+ return $result
+}
+
+#-----------------------------------------------------------------------------
+# searchEnd - end an LDAP search
+#
+#-----------------------------------------------------------------------------
+proc ldap::searchEnd { handle } {
+ CheckHandle $handle
+
+ upvar #0 $handle conn
+
+ if {! [::info exists conn(searchInProgress)]} then {
+ # no harm done, just do nothing
+ return
+ }
+ abandon $handle $conn(searchInProgress)
+ FinalizeMessage $handle $conn(searchInProgress)
+
+ unset conn(searchInProgress)
+ unset -nocomplain conn(referenceVar)
+ return
+}
+
+#-----------------------------------------------------------------------------
+#
+# Send an LDAP abandon message
+#
+#-----------------------------------------------------------------------------
+proc ldap::abandon {handle messageId} {
+ CheckHandle $handle
+
+ upvar #0 $handle conn
+ trace "MessagesPending: [string length $conn(messageId)]"
+ set request [asnApplication 16 \
+ [asnInteger $messageId] \
+ ]
+ SendMessageNoReply $handle $request
+}
+
+#-----------------------------------------------------------------------------
+# modify - provides attribute modifications on one single object (DN):
+# o replace attributes with new values
+# o delete attributes (having certain values)
+# o add attributes with new values
+#
+#-----------------------------------------------------------------------------
+proc ldap::modify { handle dn
+ attrValToReplace { attrToDelete {} } { attrValToAdd {} } } {
+
+ CheckHandle $handle
+
+ upvar #0 $handle conn
+
+ set lrep {}
+ foreach {attr value} $attrValToReplace {
+ lappend lrep $attr [list $value]
+ }
+
+ set ldel {}
+ foreach {attr value} $attrToDelete {
+ if {[string equal $value ""]} then {
+ lappend ldel $attr {}
+ } else {
+ lappend ldel $attr [list $value]
+ }
+ }
+
+ set ladd {}
+ foreach {attr value} $attrValToAdd {
+ lappend ladd $attr [list $value]
+ }
+
+ modifyMulti $handle $dn $lrep $ldel $ladd
+}
+
+
+#-----------------------------------------------------------------------------
+# modify - provides attribute modifications on one single object (DN):
+# o replace attributes with new values
+# o delete attributes (having certain values)
+# o add attributes with new values
+#
+#-----------------------------------------------------------------------------
+proc ldap::modifyMulti {handle dn
+ attrValToReplace {attrValToDelete {}} {attrValToAdd {}}} {
+
+ CheckHandle $handle
+ upvar #0 $handle conn
+
+ set operationAdd 0
+ set operationDelete 1
+ set operationReplace 2
+
+ set modifications ""
+
+ #------------------------------------------------------------------
+ # marshal attribute modify operations
+ # - always mode 'replace' ! see rfc2251:
+ #
+ # replace: replace all existing values of the given attribute
+ # with the new values listed, creating the attribute if it
+ # did not already exist. A replace with no value will delete
+ # the entire attribute if it exists, and is ignored if the
+ # attribute does not exist.
+ #
+ #------------------------------------------------------------------
+ append modifications [ldap::packOpAttrVal $operationReplace \
+ $attrValToReplace]
+
+ #------------------------------------------------------------------
+ # marshal attribute add operations
+ #
+ #------------------------------------------------------------------
+ append modifications [ldap::packOpAttrVal $operationAdd \
+ $attrValToAdd]
+
+ #------------------------------------------------------------------
+ # marshal attribute delete operations
+ #
+ # - a non-empty value will trigger to delete only those
+ # attributes which have the same value as the given one
+ #
+ # - an empty value will trigger to delete the attribute
+ # in all cases
+ #
+ #------------------------------------------------------------------
+ append modifications [ldap::packOpAttrVal $operationDelete \
+ $attrValToDelete]
+
+ #----------------------------------------------------------
+ # marshal 'modify' request packet and send it
+ #----------------------------------------------------------
+ set request [asnApplicationConstr 6 \
+ [asnOctetString $dn ] \
+ [asnSequence $modifications ] \
+ ]
+ set messageId [SendMessage $handle $request]
+ debugData modifyRequest $request
+ set response [WaitForResponse $handle $messageId]
+ FinalizeMessage $handle $messageId
+ debugData bindResponse $response
+
+ asnGetApplication response appNum
+ if { $appNum != 7 } {
+ error "unexpected application number ($appNum != 7)"
+ }
+ asnGetEnumeration response resultCode
+ asnGetOctetString response matchedDN
+ asnGetOctetString response errorMessage
+ if {$resultCode != 0} {
+ return -code error \
+ -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \
+ "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage"
+ }
+}
+
+proc ldap::packOpAttrVal {op attrValueTuples} {
+ set p ""
+ foreach {attrName attrValues} $attrValueTuples {
+ set l {}
+ foreach v $attrValues {
+ lappend l [asnOctetString $v]
+ }
+ append p [asnSequence \
+ [asnEnumeration $op ] \
+ [asnSequence \
+ [asnOctetString $attrName ] \
+ [asnSetFromList $l] \
+ ] \
+ ]
+ }
+ return $p
+}
+
+
+#-----------------------------------------------------------------------------
+# add - will create a new object using given DN and sets the given
+# attributes. Multiple value attributes may be used, provided
+# that each attr-val pair be listed.
+#
+#-----------------------------------------------------------------------------
+proc ldap::add { handle dn attrValueTuples } {
+
+ CheckHandle $handle
+
+ #
+ # In order to handle multi-valuated attributes (see bug 1191326 on
+ # sourceforge), we walk through tuples to collect all values for
+ # an attribute.
+ # http://core.tcl.tk/tcllib/tktview?name=1191326fff
+ #
+
+ foreach { attrName attrValue } $attrValueTuples {
+ lappend avpairs($attrName) $attrValue
+ }
+
+ return [addMulti $handle $dn [array get avpairs]]
+}
+
+#-----------------------------------------------------------------------------
+# addMulti - will create a new object using given DN and sets the given
+# attributes. Argument is a list of attr-listOfVals pair.
+#
+#-----------------------------------------------------------------------------
+proc ldap::addMulti { handle dn attrValueTuples } {
+
+ CheckHandle $handle
+
+ upvar #0 $handle conn
+
+ #------------------------------------------------------------------
+ # marshal attribute list
+ #
+ #------------------------------------------------------------------
+ set attrList ""
+
+ foreach { attrName attrValues } $attrValueTuples {
+ set valList {}
+ foreach val $attrValues {
+ lappend valList [asnOctetString $val]
+ }
+ append attrList [asnSequence \
+ [asnOctetString $attrName ] \
+ [asnSetFromList $valList] \
+ ]
+ }
+
+ #----------------------------------------------------------
+ # marshal search 'add' request packet and send it
+ #----------------------------------------------------------
+ set request [asnApplicationConstr 8 \
+ [asnOctetString $dn ] \
+ [asnSequence $attrList ] \
+ ]
+
+ set messageId [SendMessage $handle $request]
+ debugData addRequest $request
+ set response [WaitForResponse $handle $messageId]
+ FinalizeMessage $handle $messageId
+ debugData bindResponse $response
+
+ asnGetApplication response appNum
+ if { $appNum != 9 } {
+ error "unexpected application number ($appNum != 9)"
+ }
+ asnGetEnumeration response resultCode
+ asnGetOctetString response matchedDN
+ asnGetOctetString response errorMessage
+ if {$resultCode != 0} {
+ return -code error \
+ -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \
+ "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage"
+ }
+}
+
+#-----------------------------------------------------------------------------
+# delete - removes the whole object (DN) inclusive all attributes
+#
+#-----------------------------------------------------------------------------
+proc ldap::delete { handle dn } {
+
+ CheckHandle $handle
+
+ upvar #0 $handle conn
+
+ #----------------------------------------------------------
+ # marshal 'delete' request packet and send it
+ #----------------------------------------------------------
+ set request [asnApplication 10 $dn ]
+ set messageId [SendMessage $handle $request]
+ debugData deleteRequest $request
+ set response [WaitForResponse $handle $messageId]
+ FinalizeMessage $handle $messageId
+
+ debugData deleteResponse $response
+
+ asnGetApplication response appNum
+ if { $appNum != 11 } {
+ error "unexpected application number ($appNum != 11)"
+ }
+ asnGetEnumeration response resultCode
+ asnGetOctetString response matchedDN
+ asnGetOctetString response errorMessage
+ if {$resultCode != 0} {
+ return -code error \
+ -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \
+ "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage"
+ }
+}
+
+
+#-----------------------------------------------------------------------------
+# modifyDN - moves an object (DN) to another (relative) place
+#
+#-----------------------------------------------------------------------------
+proc ldap::modifyDN { handle dn newrdn { deleteOld 1 } {newSuperior ! } } {
+
+ CheckHandle $handle
+
+ upvar #0 $handle conn
+
+ #----------------------------------------------------------
+ # marshal 'modifyDN' request packet and send it
+ #----------------------------------------------------------
+
+ if {[string equal $newSuperior "!"]} then {
+ set request [asnApplicationConstr 12 \
+ [asnOctetString $dn ] \
+ [asnOctetString $newrdn ] \
+ [asnBoolean $deleteOld ] \
+ ]
+
+ } else {
+ set request [asnApplicationConstr 12 \
+ [asnOctetString $dn ] \
+ [asnOctetString $newrdn ] \
+ [asnBoolean $deleteOld ] \
+ [asnContext 0 $newSuperior] \
+ ]
+ }
+ set messageId [SendMessage $handle $request]
+ debugData modifyRequest $request
+ set response [WaitForResponse $handle $messageId]
+
+ asnGetApplication response appNum
+ if { $appNum != 13 } {
+ error "unexpected application number ($appNum != 13)"
+ }
+ asnGetEnumeration response resultCode
+ asnGetOctetString response matchedDN
+ asnGetOctetString response errorMessage
+ if {$resultCode != 0} {
+ return -code error \
+ -errorcode [list LDAP [resultCode2String $resultCode] $matchedDN $errorMessage] \
+ "LDAP error [resultCode2String $resultCode] '$matchedDN': $errorMessage"
+
+ }
+}
+
+#-----------------------------------------------------------------------------
+# disconnect
+#
+#-----------------------------------------------------------------------------
+proc ldap::disconnect { handle } {
+
+ CheckHandle $handle
+
+ upvar #0 $handle conn
+
+ # should we sent an 'unbind' ?
+ catch {close $conn(sock)}
+ unset conn
+
+ return
+}
+
+
+
+#-----------------------------------------------------------------------------
+# trace
+#
+#-----------------------------------------------------------------------------
+proc ldap::trace { message } {
+
+ variable doDebug
+
+ if {!$doDebug} return
+
+ puts stderr $message
+}
+
+
+#-----------------------------------------------------------------------------
+# debugData
+#
+#-----------------------------------------------------------------------------
+proc ldap::debugData { info data } {
+
+ variable doDebug
+
+ if {!$doDebug} return
+
+ set len [string length $data]
+ trace "$info ($len bytes):"
+ set address ""
+ set hexnums ""
+ set ascii ""
+ for {set i 0} {$i < $len} {incr i} {
+ set v [string index $data $i]
+ binary scan $v H2 hex
+ binary scan $v c num
+ set num [expr {( $num + 0x100 ) % 0x100}]
+ set text .
+ if {$num > 31} {
+ set text $v
+ }
+ if { ($i % 16) == 0 } {
+ if {$address != ""} {
+ trace [format "%4s %-48s |%s|" $address $hexnums $ascii ]
+ set address ""
+ set hexnums ""
+ set ascii ""
+ }
+ append address [format "%04d" $i]
+ }
+ append hexnums "$hex "
+ append ascii $text
+ #trace [format "%3d %2s %s" $i $hex $text]
+ }
+ if {$address != ""} {
+ trace [format "%4s %-48s |%s|" $address $hexnums $ascii ]
+ }
+ trace ""
+}
+
+#-----------------------------------------------------------------------------
+# ldap::filter -- set of procedures for construction of BER-encoded
+# data defined by ASN.1 type Filter described in RFC 4511
+# from string representations of search filters
+# defined in RFC 4515.
+#-----------------------------------------------------------------------------
+namespace eval ldap::filter {
+ # Regexp which matches strings of type AttribyteType:
+ variable reatype {[A-Za-z][A-Za-z0-9-]*|\d+(?:\.\d+)+}
+
+ # Regexp which matches attribute options in strings
+ # of type AttributeDescription:
+ variable reaopts {(?:;[A-Za-z0-9-]+)*}
+
+ # Regexp which matches strings of type AttributeDescription.
+ # Note that this regexp captures attribute options,
+ # with leading ";", if any.
+ variable readesc (?:$reatype)($reaopts)
+
+ # Two regexps to match strings representing "left hand side" (LHS)
+ # in extensible match assertion.
+ # In fact there could be one regexp with two alterations,
+ # but this would complicate capturing of regexp parts.
+ # The first regexp captures, in this order:
+ # 1. Attribute description.
+ # 2. Attribute options.
+ # 3. ":dn" string, indicating "Use DN attribute types" flag.
+ # 4. Matching rule ID.
+ # The second regexp captures, in this order:
+ # 1. ":dn" string.
+ # 2. Matching rule ID.
+ variable reaextmatch1 ^($readesc)(:dn)?(?::($reatype))?\$
+ variable reaextmatch2 ^(:dn)?:($reatype)\$
+
+ # The only validation proc using this regexp requires it to be
+ # anchored to the boundaries of a string being validated,
+ # so we change it here to allow this regexp to be compiled:
+ set readesc ^$readesc\$
+
+ unset reatype reaopts
+
+ namespace import ::asn::*
+}
+
+# "Public API" function.
+# Parses the string represntation of an LDAP search filter expression
+# and returns its BER-encoded form.
+# NOTE While RFC 4515 strictly defines that any filter expression must
+# be surrounded by parentheses it is customary for LDAP client software
+# to allow specification of simple (i.e. non-compound) filter expressions
+# without enclosing parentheses, so we also do this (in fact, we allow
+# omission of outermost parentheses in any filter expression).
+proc ldap::filter::encode s {
+ if {[string match (*) $s]} {
+ ProcessFilter $s
+ } else {
+ ProcessFilterComp $s
+ }
+}
+
+# Parses the string represntation of an LDAP search filter expression
+# and returns its BER-encoded form.
+proc ldap::filter::ProcessFilter s {
+ if {![string match (*) $s]} {
+ return -code error "Invalid filter: filter expression must be\
+ surrounded by parentheses"
+ }
+ ProcessFilterComp [string range $s 1 end-1]
+}
+
+# Parses "internals" of a filter expression, i.e. what's contained
+# between its enclosing parentheses.
+# It classifies the type of filter expression (compound, negated or
+# simple) and invokes its corresponding handler.
+# Returns a BER-encoded form of the filter expression.
+proc ldap::filter::ProcessFilterComp s {
+ switch -- [string index $s 0] {
+ & {
+ ProcessFilterList 0 [string range $s 1 end]
+ }
+ | {
+ ProcessFilterList 1 [string range $s 1 end]
+ }
+ ! {
+ ProcessNegatedFilter [string range $s 1 end]
+ }
+ default {
+ ProcessMatch $s
+ }
+ }
+}
+
+# Parses string $s containing a chain of one or more filter
+# expressions (as found in compound filter expressions),
+# processes each filter in such chain and returns
+# a BER-encoded form of this chain tagged with specified
+# application type given as $apptype.
+proc ldap::filter::ProcessFilterList {apptype s} {
+ set data ""
+ set rest $s
+ while 1 {
+ foreach {filter rest} [ExtractFilter $rest] break
+ append data [ProcessFilter $filter]
+ if {$rest == ""} break
+ }
+ # TODO looks like it's impossible to hit this condition
+ if {[string length $data] == 0} {
+ return -code error "Invalid filter: filter composition must\
+ consist of at least one element"
+ }
+ asnChoiceConstr $apptype $data
+}
+
+# Parses a string $s representing a filter expression
+# and returns a BER construction representing negation
+# of that filter expression.
+proc ldap::filter::ProcessNegatedFilter s {
+ asnChoiceConstr 2 [ProcessFilter $s]
+}
+
+# Parses a string $s representing an "attribute matching rule"
+# (i.e. the contents of a non-compound filter expression)
+# and returns its BER-encoded form.
+proc ldap::filter::ProcessMatch s {
+ if {![regexp -indices {(=|~=|>=|<=|:=)} $s range]} {
+ return -code error "Invalid filter: no match operator in item"
+ }
+ foreach {a z} $range break
+ set lhs [string range $s 0 [expr {$a - 1}]]
+ set match [string range $s $a $z]
+ set val [string range $s [expr {$z + 1}] end]
+
+ switch -- $match {
+ = {
+ if {$val eq "*"} {
+ ProcessPresenceMatch $lhs
+ } else {
+ if {[regexp {^([^*]*)(\*(?:[^*]*\*)*)([^*]*)$} $val \
+ -> initial any final]} {
+ ProcessSubstringMatch $lhs $initial $any $final
+ } else {
+ ProcessSimpleMatch 3 $lhs $val
+ }
+ }
+ }
+ >= {
+ ProcessSimpleMatch 5 $lhs $val
+ }
+ <= {
+ ProcessSimpleMatch 6 $lhs $val
+ }
+ ~= {
+ ProcessSimpleMatch 8 $lhs $val
+ }
+ := {
+ ProcessExtensibleMatch $lhs $val
+ }
+ }
+}
+
+# From a string $s, containing a chain of filter
+# expressions (as found in compound filter expressions)
+# extracts the first filter expression and returns
+# a two element list composed of the extracted filter
+# expression and the remainder of the source string.
+proc ldap::filter::ExtractFilter s {
+ if {[string index $s 0] ne "("} {
+ return -code error "Invalid filter: malformed compound filter expression"
+ }
+ set pos 1
+ set nopen 1
+ while 1 {
+ if {![regexp -indices -start $pos {\)|\(} $s match]} {
+ return -code error "Invalid filter: unbalanced parenthesis"
+ }
+ set pos [lindex $match 0]
+ if {[string index $s $pos] eq "("} {
+ incr nopen
+ } else {
+ incr nopen -1
+ }
+ if {$nopen == 0} {
+ return [list [string range $s 0 $pos] \
+ [string range $s [incr pos] end]]
+ }
+ incr pos
+ }
+}
+
+# Constructs a BER-encoded form of a "presence" match
+# involving an attribute description string passed in $attrdesc.
+proc ldap::filter::ProcessPresenceMatch attrdesc {
+ ValidateAttributeDescription $attrdesc options
+ asnChoice 7 [LDAPString $attrdesc]
+}
+
+# Constructs a BER-encoded form of a simple match designated
+# by application type $apptype and involving an attribute
+# description $attrdesc and attribute value $val.
+# "Simple" match is one of: equal, less or equal, greater
+# or equal, approximate.
+proc ldap::filter::ProcessSimpleMatch {apptype attrdesc val} {
+ ValidateAttributeDescription $attrdesc options
+ append data [asnOctetString [LDAPString $attrdesc]] \
+ [asnOctetString [AssertionValue $val]]
+ asnChoiceConstr $apptype $data
+}
+
+# Constructs a BER-encoded form of a substrings match
+# involving an attribute description $attrdesc and parts of attribute
+# value -- $initial, $any and $final.
+# A string contained in any may be compound -- several strings
+# concatenated by asterisks ("*"), they are extracted and used as
+# multiple attribute value parts of type "any".
+proc ldap::filter::ProcessSubstringMatch {attrdesc initial any final} {
+ ValidateAttributeDescription $attrdesc options
+
+ set data [asnOctetString [LDAPString $attrdesc]]
+
+ set seq [list]
+ set parts 0
+ if {$initial != ""} {
+ lappend seq [asnChoice 0 [AssertionValue $initial]]
+ incr parts
+ }
+
+ foreach v [split [string trim $any *] *] {
+ if {$v != ""} {
+ lappend seq [asnChoice 1 [AssertionValue $v]]
+ incr parts
+ }
+ }
+
+ if {$final != ""} {
+ lappend seq [asnChoice 2 [AssertionValue $final]]
+ incr parts
+ }
+
+ if {$parts == 0} {
+ return -code error "Invalid filter: substrings match parses to zero parts"
+ }
+
+ append data [asnSequenceFromList $seq]
+
+ asnChoiceConstr 4 $data
+}
+
+# Constructs a BER-encoded form of an extensible match
+# involving an attribute value given in $value and a string
+# containing the matching rule OID, if present a "Use DN attribute
+# types" flag, if present, and an atttibute description, if present,
+# given in $lhs (stands for "Left Hand Side").
+proc ldap::filter::ProcessExtensibleMatch {lhs value} {
+ ParseExtMatchLHS $lhs attrdesc options dn ruleid
+ set data ""
+ foreach {apptype val} [list 1 $ruleid 2 $attrdesc] {
+ if {$val != ""} {
+ append data [asnChoice $apptype [LDAPString $val]]
+ }
+ }
+ append data [asnChoice 3 [AssertionValue $value]]
+ if {$dn} {
+ # [asnRetag] is broken in asn, so we use the trick
+ # to simulate "boolean true" BER-encoding which
+ # is octet 1 of length 1:
+ append data [asnChoice 4 [binary format cc 1 1]]
+ }
+ asnChoiceConstr 9 $data
+}
+
+# Parses a string $s, representing a "left hand side" of an extensible match
+# expression, into several parts: attribute desctiption, options,
+# "Use DN attribute types" flag and rule OID. These parts are
+# assigned to corresponding variables in the caller's scope.
+proc ldap::filter::ParseExtMatchLHS {s attrdescVar optionsVar dnVar ruleidVar} {
+ upvar 1 $attrdescVar attrdesc $optionsVar options $dnVar dn $ruleidVar ruleid
+ variable reaextmatch1
+ variable reaextmatch2
+ if {[regexp $reaextmatch1 $s -> attrdesc opts dnstr ruleid]} {
+ set options [ProcessAttrTypeOptions $opts]
+ set dn [expr {$dnstr != ""}]
+ } elseif {[regexp $reaextmatch2 $s -> dnstr ruleid]} {
+ set attrdesc ""
+ set options [list]
+ set dn [expr {$dnstr != ""}]
+ } else {
+ return -code error "Invalid filter: malformed attribute description"
+ }
+}
+
+# Validates an attribute description passed as $attrdesc.
+# Raises an error if it's ill-formed.
+# Variable in the caller's scope whose name is passed in optionsVar
+# is set to a list of attribute options (which may be empty if
+# there's no options in the attribute type).
+proc ldap::filter::ValidateAttributeDescription {attrdesc optionsVar} {
+ variable readesc
+ if {![regexp $readesc $attrdesc -> opts]} {
+ return -code error "Invalid filter: malformed attribute description"
+ }
+ upvar 1 $optionsVar options
+ set options [ProcessAttrTypeOptions $opts]
+ return
+}
+
+# Parses a string $s containing one or more attribute
+# options, delimited by seimcolons, with the leading semicolon,
+# if non-empty.
+# Returns a list of distinct options, lowercased for normalization
+# purposes.
+proc ldap::filter::ProcessAttrTypeOptions s {
+ set opts [list]
+ foreach opt [split [string trimleft $s \;] \;] {
+ lappend opts [string tolower $opt]
+ }
+ set opts
+}
+
+# Checks an assertion value $s for validity and substitutes
+# any backslash escapes in it with their respective values.
+# Returns canonical form of the attribute value
+# ready to be packed into a BER-encoded stream.
+proc ldap::filter::AssertionValue s {
+ set v [encoding convertto utf-8 $s]
+ if {[regexp {\\(?:[[:xdigit:]])?(?![[:xdigit:]])|[()*\0]} $v]} {
+ return -code error "Invalid filter: malformed assertion value"
+ }
+
+ variable escmap
+ if {![info exists escmap]} {
+ for {set i 0} {$i <= 0xff} {incr i} {
+ lappend escmap [format {\%02x} $i] [format %c $i]
+ }
+ }
+ string map -nocase $escmap $v
+}
+
+# Turns a given Tcl string $s into a binary blob ready to be packed
+# into a BER-encoded stream.
+proc ldap::filter::LDAPString s {
+ encoding convertto utf-8 $s
+}
+
+# vim:ts=8:sw=4:sts=4:noet
diff --git a/tcllib/modules/ldap/ldap.test b/tcllib/modules/ldap/ldap.test
new file mode 100644
index 0000000..34c713c
--- /dev/null
+++ b/tcllib/modules/ldap/ldap.test
@@ -0,0 +1,928 @@
+# ldap.test - Copyright (C) 2006 Michael Schlenker <mic42@user.sourceforge.net>
+#
+# Tests for the Tcllib ldap package
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: ldap.test,v 1.5 2008/07/20 19:50:55 mic42 Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+testing {
+ useLocal ldap.tcl ldap
+ useLocal ../asn/asn.tcl asn
+}
+
+
+namespace import ::asn::*
+
+# -------------------------------------------------------------------------
+# Tests
+# -------------------------------------------------------------------------
+
+test ldap-2.0 {check info ip subcommand error handling
+} -body {
+ ldap::info ip
+} -returnCodes {error} \
+ -result {Wrong # of arguments. Usage: ldap::info ip handle}
+
+test ldap-2.1 {check info ip subcommand error handling
+} -body {
+ ldap::info ip foobar
+} -returnCodes {error} \
+ -result {Not a valid LDAP connection handle: foobar}
+
+test ldap-3.0 {check info connections subcommand error handling
+} -body {
+ ldap::info connections foo
+} -returnCodes {error} \
+ -result {Wrong # of arguments. Usage: ldap::info connections}
+
+test ldap-4.0 {check info bound subcommand error handling
+} -body {
+ ldap::info bound
+} -returnCodes {error} \
+ -result {Wrong # of arguments. Usage: ldap::info bound handle}
+
+test ldap-4.1 {check info bound subcommand error handling
+} -body {
+ ldap::info bound foobar
+} -returnCodes {error} \
+ -result {Not a valid LDAP connection handle: foobar}
+
+test ldap-5.0 {check info tls subcommand error handling
+} -body {
+ ldap::info tls
+} -returnCodes {error} \
+ -result {Wrong # of arguments. Usage: ldap::info tls handle}
+
+test ldap-5.1 {check info tls subcommand error handling
+} -body {
+ ldap::info tls foobar
+} -returnCodes {error} \
+ -result {Not a valid LDAP connection handle: foobar}
+
+test ldap-6.0 {check info bounduser subcommand error handling
+} -body {
+ ldap::info bounduser
+} -returnCodes {error} \
+ -result {Wrong # of arguments. Usage: ldap::info bounduser handle}
+
+test ldap-6.1 {check info bounduser subcommand error handling
+} -body {
+ ldap::info bounduser foobar
+} -returnCodes {error} \
+ -result {Not a valid LDAP connection handle: foobar}
+
+test ldap-7.0 {check info saslmechanisms subcommand error handling
+} -body {
+ ldap::info saslmechanisms
+} -returnCodes {error} \
+ -result {Wrong # of arguments. Usage: ldap::info saslmechanisms handle}
+
+test ldap-7.1 {check info saslmechanisms subcommand error handling
+} -body {
+ ldap::info saslmechanisms foobar
+} -returnCodes {error} \
+ -result {Not a valid LDAP connection handle: foobar}
+
+test ldap-8.0 {check info extensions subcommand error handling
+} -body {
+ ldap::info extensions
+} -returnCodes {error} \
+ -result {Wrong # of arguments. Usage: ldap::info extensions handle}
+
+test ldap-8.1 {check info extensions subcommand error handling
+} -body {
+ ldap::info extensions foobar
+} -returnCodes {error} \
+ -result {Not a valid LDAP connection handle: foobar}
+
+test ldap-9.0 {check info control subcommand error handling
+} -body {
+ ldap::info control
+} -returnCodes {error} \
+ -result {Wrong # of arguments. Usage: ldap::info control handle}
+
+test ldap-9.1 {check info control subcommand error handling
+} -body {
+ ldap::info control foobar
+} -returnCodes {error} \
+ -result {Not a valid LDAP connection handle: foobar}
+
+test ldap-10.0 {check info features subcommand error handling
+} -body {
+ ldap::info features
+} -returnCodes {error} \
+ -result {Wrong # of arguments. Usage: ldap::info features handle}
+
+test ldap-10.1 {check info features subcommand error handling
+} -body {
+ ldap::info features foobar
+} -returnCodes {error} \
+ -result {Not a valid LDAP connection handle: foobar}
+
+test ldap-11.0 {check info whoami subcommand error handling
+} -body {
+ ldap::info whoami
+} -returnCodes {error} \
+ -result {Wrong # of arguments. Usage: ldap::info whoami handle}
+
+test ldap-11.1 {check info whoami subcommand error handling
+} -body {
+ ldap::info whoami foobar
+} -returnCodes {error} \
+ -result {Not a valid LDAP connection handle: foobar}
+
+test ldap-12.0 {check wrong num args for ldap::connect
+} -body {
+ ldap::connect
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs \
+ {ldap::connect} {host ?port?} 0]
+
+test ldap-13.0 {check wrong num args for ldap::secure_connect
+} -body {
+ ldap::secure_connect
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs \
+ {ldap::secure_connect} {host ?port?} 0]
+
+test ldap-14.0 {check wrong num args for ldap::starttls
+} -body {
+ ldap::starttls
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs {ldap::starttls} \
+ {handle ?cafile? ?certfile? ?keyfile?} 0]
+
+test ldap-15.0 {check wrong num args for ldap::bindSASL
+} -body {
+ ldap::bindSASL
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs {ldap::bindSASL} {handle ?name? ?password?} 0]
+
+test ldap-16.0 {check wrong num args for ldap::bind
+} -body {
+ ldap::bind
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs {ldap::bind} {handle ?name? ?password?} 0]
+
+test ldap-17.0 {check wrong num args for ldap::unbind
+} -body {
+ ldap::unbind
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs {ldap::unbind} {handle} 1 ]
+
+test ldap-18.0 {check wrong num args for ldap::search
+} -body {
+ ldap::search
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs {ldap::search} \
+ {handle baseObject filterString attributes args} 0]
+
+test ldap-19.0 {check wrong num args for ldap::searchInit
+} -body {
+ ldap::searchInit
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs {ldap::searchInit} \
+ {handle baseObject filterString attributes opt} 0]
+
+test ldap-20.0 {check wrong num args for ldap::searchNext
+} -body {
+ ldap::searchNext
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs {ldap::searchNext} {handle} 0 ]
+
+test ldap-21.0 {check wrong num args for ldap::searchEnd
+} -body {
+ ldap::searchEnd
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs {ldap::searchEnd} {handle} 0 ]
+
+test ldap-22.0 {check wrong num args for ldap::modify
+} -body {
+ ldap::modify
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs {ldap::modify} \
+ {handle dn attrValToReplace ?attrToDelete? ?attrValToAdd?} 0 ]
+
+test ldap-23.0 {check wrong num args for ldap::modifyMulti
+} -body {
+ ldap::modifyMulti
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs {ldap::modifyMulti} \
+ {handle dn attrValToReplace ?attrValToDelete? ?attrValToAdd?} 0 ]
+
+test ldap-24.0 {check wrong num args for ldap::add
+} -body {
+ ldap::add
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs {ldap::add} \
+ {handle dn attrValueTuples} 0 ]
+
+test ldap-25.0 {check wrong num args for ldap::addMulti
+} -body {
+ ldap::addMulti
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs {ldap::addMulti} \
+ {handle dn attrValueTuples} 0 ]
+
+test ldap-26.0 {check wrong num args for ldap::delete
+} -body {
+ ldap::delete
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs {ldap::delete} \
+ {handle dn} 0 ]
+
+test ldap-27.0 {check wrong num args for ldap::modifyDN
+} -body {
+ ldap::modifyDN
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs {ldap::modifyDN} \
+ {handle dn newrdn ?deleteOld? ?newSuperior?} 0 ]
+
+test ldap-28.0 {check wrong num args for ldap::disconnect
+} -body {
+ ldap::disconnect
+} -returnCodes {error} \
+ -result [tcltest::wrongNumArgs {ldap::disconnect} \
+ {handle} 0 ]
+# -------------------------------------------------------------------------
+# Handling of string representation of filters (RFC 4515):
+# -------------------------------------------------------------------------
+
+proc glue args {
+ join $args ""
+}
+
+test filter-0.0 {[glue] should concatenate its string arguments} -body {
+ glue a b c d \0 foo
+} -result abcd\0foo
+
+test filter-1.0 {LDAPString produces packed UTF-8} -body {
+ binary scan [ldap::filter::LDAPString \u043a\u0430\u0448\u0430] H* foo
+ set foo
+} -result d0bad0b0d188d0b0 -cleanup { unset foo }
+
+test filter-1.1 {AssertionValue produces packed UTF-8} -body {
+ binary scan [ldap::filter::AssertionValue \u043a\u0430\u0448\u0430] H* foo
+ set foo
+} -result d0bad0b0d188d0b0 -cleanup { unset foo }
+
+test filter-1.2 {AssertionValue produces packed UTF-8
+ but allows embedding of arbitrary bytes via escaping} -body {
+ binary scan [ldap::filter::AssertionValue \u043a\\FF\u0430\\ab\u0448\\de\u0430\\Fe] H* foo
+ set foo
+} -result d0baffd0b0abd188ded0b0fe -cleanup { unset foo }
+
+test filter-1.3 {LDAPString produces packed UTF-8, all characters pass as is} -body {
+ binary scan [ldap::filter::LDAPString \u043a\\FF\u0430\\ab\u0448\\de\u0430\\Fe] H* foo
+ set foo
+} -result d0ba5c4646d0b05c6162d1885c6465d0b05c4665 -cleanup { unset foo }
+
+test filter-2.0 {Backslash escaping in assertion values} -body {
+ set a ""
+ set b ""
+ for {set i 0} {$i <= 255} {incr i} {
+ append a [format \\%02x $i] ;# lowercase hex
+ append b [format %c $i]
+ }
+ string equal [ldap::filter::AssertionValue $a] $b
+} -result 1 -cleanup { unset a b i }
+
+test filter-2.1 {Backslash escaping in assertion values} -body {
+ set a ""
+ set b ""
+ for {set i 0} {$i <= 255} {incr i} {
+ append a [format \\%02X $i] ;# uppercase hex
+ append b [format %c $i]
+ }
+ string equal [ldap::filter::AssertionValue $a] $b
+} -result 1 -cleanup { unset a b i }
+
+test filter-3.1 {Malformed backslash escaping in assertion values} -body {
+ ldap::filter::AssertionValue foo\\0
+} -returnCodes error -result {Invalid filter: malformed assertion value}
+
+test filter-3.2 {Malformed backslash escaping in assertion values} -body {
+ ldap::filter::AssertionValue \\foo
+} -returnCodes error -result {Invalid filter: malformed assertion value}
+
+test filter-3.3 {Malformed backslash escaping in assertion values} -body {
+ ldap::filter::AssertionValue hA\\1x0rz
+} -returnCodes error -result {Invalid filter: malformed assertion value}
+
+test filter-3.4 {Malformed backslash escaping in assertion values} -body {
+ ldap::filter::AssertionValue \\value
+} -returnCodes error -result {Invalid filter: malformed assertion value}
+
+test filter-3.5 {Malformed backslash escaping in assertion values} -body {
+ ldap::filter::AssertionValue end\\
+} -returnCodes error -result {Invalid filter: malformed assertion value}
+
+test filter-4.0 {Presence match} -body {
+ ldap::filter::encode (Certificates=*)
+} -result [asnChoice 7 [ldap::filter::LDAPString Certificates]]
+
+test filter-4.1 {Presence match + attribute options} -body {
+ ldap::filter::encode (Certificates\;binary\;X-FooBar=*)
+} -result [asnChoice 7 [ldap::filter::LDAPString Certificates\;binary\;X-FooBar]]
+
+test filter-5.0 {Equality match} -body {
+ ldap::filter::encode (foo=bar)
+} -result [asnChoiceConstr 3 [glue \
+ [asnOctetString [ldap::filter::LDAPString foo]] \
+ [asnOctetString [ldap::filter::AssertionValue bar]]]]
+
+test filter-5.1 {Equality match with empty assertion value} -body {
+ ldap::filter::encode (seeAlso=)
+} -result [asnChoiceConstr 3 [glue \
+ [asnOctetString [ldap::filter::LDAPString seeAlso]] \
+ [asnOctetString [ldap::filter::AssertionValue ""]]]]
+
+test filter-5.2 {Equality match + attribute options} -body {
+ ldap::filter::encode (foo\;X-option=bar)
+} -result [asnChoiceConstr 3 [glue \
+ [asnOctetString [ldap::filter::LDAPString foo\;X-option]] \
+ [asnOctetString [ldap::filter::AssertionValue bar]]]]
+
+test filter-5.3 {Equality match, spaces in assertion value} -body {
+ ldap::filter::encode {(personName=Jane W. Random)}
+} -result [asnChoiceConstr 3 [glue \
+ [asnOctetString [ldap::filter::LDAPString personName]] \
+ [asnOctetString [ldap::filter::AssertionValue "Jane W. Random"]]]]
+
+test filter-6.0 {Approx match} -body {
+ ldap::filter::encode (descr~=val)
+} -result [asnChoiceConstr 8 [glue \
+ [asnOctetString [ldap::filter::LDAPString descr]] \
+ [asnOctetString [ldap::filter::AssertionValue val]]]]
+
+test filter-6.1 {Approx match with empty assertion value} -body {
+ ldap::filter::encode (cn~=)
+} -result [asnChoiceConstr 8 [glue \
+ [asnOctetString [ldap::filter::LDAPString cn]] \
+ [asnOctetString [ldap::filter::AssertionValue ""]]]]
+
+test filter-6.2 {Approx match + attribute options} -body {
+ ldap::filter::encode (binaryCert\;binary~=0000)
+} -result [asnChoiceConstr 8 [glue \
+ [asnOctetString [ldap::filter::LDAPString binaryCert\;binary]] \
+ [asnOctetString [ldap::filter::AssertionValue 0000]]]]
+
+test filter-7.0 {Less or equal match} -body {
+ ldap::filter::encode (attr<=string)
+} -result [asnChoiceConstr 6 [glue \
+ [asnOctetString [ldap::filter::LDAPString attr]] \
+ [asnOctetString [ldap::filter::AssertionValue string]]]]
+
+test filter-7.1 {Less or equal match with empty assertion value} -body {
+ ldap::filter::encode (attr<=)
+} -result [asnChoiceConstr 6 [glue \
+ [asnOctetString [ldap::filter::LDAPString attr]] \
+ [asnOctetString [ldap::filter::AssertionValue ""]]]]
+
+test filter-7.2 {Less or equal match + attribute options} -body {
+ ldap::filter::encode (binaryCert\;binary<=01234)
+} -result [asnChoiceConstr 6 [glue \
+ [asnOctetString [ldap::filter::LDAPString binaryCert\;binary]] \
+ [asnOctetString [ldap::filter::AssertionValue 01234]]]]
+
+test filter-8.0 {Greater or equal match} -body {
+ ldap::filter::encode (one>=two)
+} -result [asnChoiceConstr 5 [glue \
+ [asnOctetString [ldap::filter::LDAPString one]] \
+ [asnOctetString [ldap::filter::AssertionValue two]]]]
+
+test filter-8.1 {Greater or equal match with empty attribute} -body {
+ ldap::filter::encode (one>=)
+} -result [asnChoiceConstr 5 [glue \
+ [asnOctetString [ldap::filter::LDAPString one]] \
+ [asnOctetString [ldap::filter::AssertionValue ""]]]]
+
+test filter-8.2 {Greater or equal match + attribute options} -body {
+ ldap::filter::encode (exampleAttr\;X-experimental>=value)
+} -result [asnChoiceConstr 5 [glue \
+ [asnOctetString [ldap::filter::LDAPString exampleAttr\;X-experimental]] \
+ [asnOctetString [ldap::filter::AssertionValue value]]]]
+
+test filter-9.0 {Substrings match: only initial string} -body {
+ ldap::filter::encode (sAMAccountName=management-*)
+} -result [asnChoiceConstr 4 [glue \
+ [asnOctetString [ldap::filter::LDAPString sAMAccountName]] \
+ [asnSequence [asnChoice 0 [ldap::filter::AssertionValue management-]]]]]
+
+test filter-9.1 {Substrings match: only final string} -body {
+ ldap::filter::encode (User=*ish)
+} -result [asnChoiceConstr 4 [glue \
+ [asnOctetString [ldap::filter::LDAPString User]] \
+ [asnSequence [asnChoice 2 [ldap::filter::AssertionValue ish]]]]]
+
+test filter-9.2 {Substrings match: initial and final strings} -body {
+ ldap::filter::encode (OU=F*off)
+} -result [asnChoiceConstr 4 [glue \
+ [asnOctetString [ldap::filter::LDAPString OU]] \
+ [asnSequence \
+ [asnChoice 0 [ldap::filter::AssertionValue F]] \
+ [asnChoice 2 [ldap::filter::AssertionValue off]]]]]
+
+test filter-9.3 {Substrings match: initial, any and final strings} -body {
+ ldap::filter::encode (mail=Schlenk*@uni-*.de)
+} -result [asnChoiceConstr 4 [glue \
+ [asnOctetString [ldap::filter::LDAPString mail]] \
+ [asnSequence \
+ [asnChoice 0 [ldap::filter::AssertionValue Schlenk]] \
+ [asnChoice 1 [ldap::filter::AssertionValue @uni-]] \
+ [asnChoice 2 [ldap::filter::AssertionValue .de]]]]]
+
+test filter-9.4 {Substrings match: multiple any strings} -body {
+ ldap::filter::encode (Something=a*b*c*d*e)
+} -result [asnChoiceConstr 4 [glue \
+ [asnOctetString [ldap::filter::LDAPString Something]] \
+ [asnSequence \
+ [asnChoice 0 [ldap::filter::AssertionValue a]] \
+ [asnChoice 1 [ldap::filter::AssertionValue b]] \
+ [asnChoice 1 [ldap::filter::AssertionValue c]] \
+ [asnChoice 1 [ldap::filter::AssertionValue d]] \
+ [asnChoice 2 [ldap::filter::AssertionValue e]]]]]
+
+test filter-9.5 {Substrings match: no initial and final strings} -body {
+ ldap::filter::encode (Whatever=*foo*)
+} -result [asnChoiceConstr 4 [glue \
+ [asnOctetString [ldap::filter::LDAPString Whatever]] \
+ [asnSequence \
+ [asnChoice 1 [ldap::filter::AssertionValue foo]]]]]
+
+test filter-9.6 {Substrings match: empty any string prevention} -body {
+ ldap::filter::encode {(Person=J.Ra***m Hacker)}
+} -result [asnChoiceConstr 4 [glue \
+ [asnOctetString [ldap::filter::LDAPString Person]] \
+ [asnSequence \
+ [asnChoice 0 [ldap::filter::AssertionValue J.Ra]] \
+ [asnChoice 2 [ldap::filter::AssertionValue {m Hacker}]]]]]
+
+test filter-9.7 {Substrings match: empty any string prevention} -body {
+ ldap::filter::encode (SomeType=***foo***bar***baz**********)
+} -result [asnChoiceConstr 4 [glue \
+ [asnOctetString [ldap::filter::LDAPString SomeType]] \
+ [asnSequence \
+ [asnChoice 1 [ldap::filter::AssertionValue foo]] \
+ [asnChoice 1 [ldap::filter::AssertionValue bar]] \
+ [asnChoice 1 [ldap::filter::AssertionValue baz]]]]]
+
+test filter-9.8 {Substrings match: parsing to zero parts} -body {
+ ldap::filter::encode (SomeType=**)
+} -returnCodes error -result {Invalid filter: substrings match parses to zero parts}
+
+test filter-9.10 {Substrings match: parsing to zero parts} -body {
+ ldap::filter::encode (SomeOtherType=*****)
+} -returnCodes error -result {Invalid filter: substrings match parses to zero parts}
+
+test filter-9.11 {Substrings match: spaces in assertion value} -body {
+ ldap::filter::encode {(Something=Jane Random*and*J. Random Hacker)}
+} -result [asnChoiceConstr 4 [glue \
+ [asnOctetString [ldap::filter::LDAPString Something]] \
+ [asnSequence \
+ [asnChoice 0 [ldap::filter::AssertionValue "Jane Random"]] \
+ [asnChoice 1 [ldap::filter::AssertionValue and]] \
+ [asnChoice 2 [ldap::filter::AssertionValue "J. Random Hacker"]]]]]
+
+test filter-10.0 {Extensible match: only attribute description} -body {
+ ldap::filter::encode (AttrDesc:=10)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 2 [ldap::filter::LDAPString AttrDesc]] \
+ [asnChoice 3 [ldap::filter::AssertionValue 10]]]]
+
+test filter-10.1 {Extensible match: attribute description + matching rule} -body {
+ ldap::filter::encode (personKind:caseIgnoreMatch:=bad)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 1 [ldap::filter::LDAPString caseIgnoreMatch]] \
+ [asnChoice 2 [ldap::filter::LDAPString personKind]] \
+ [asnChoice 3 [ldap::filter::AssertionValue bad]]]]
+
+test filter-10.2 {Extensible match: attribute description
+ + matching rule in form of numericoid} -body {
+ ldap::filter::encode (personKind:1.3.6.1.4.1.1466.115.121.1.15:=good)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 1 [ldap::filter::LDAPString 1.3.6.1.4.1.1466.115.121.1.15]] \
+ [asnChoice 2 [ldap::filter::LDAPString personKind]] \
+ [asnChoice 3 [ldap::filter::AssertionValue good]]]]
+
+test filter-10.3 {Extensible match: attribute description + DN flag} -body {
+ ldap::filter::encode (Foobar:dn:=345)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 2 [ldap::filter::LDAPString Foobar]] \
+ [asnChoice 3 [ldap::filter::AssertionValue 345]] \
+ [asnChoice 4 [binary format cc 1 1]]]]
+
+test filter-10.4 {Extensible match: attribute description + DN flag + matching rule} -body {
+ ldap::filter::encode (NamelessOne:dn:caseIgnoreIA5Match:=who)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 1 [ldap::filter::LDAPString caseIgnoreIA5Match]] \
+ [asnChoice 2 [ldap::filter::LDAPString NamelessOne]] \
+ [asnChoice 3 [ldap::filter::AssertionValue who]] \
+ [asnChoice 4 [binary format cc 1 1]]]]
+
+test filter-10.5 {Extensible match: attribute description + DN flag
+ + matching rule numericoid} -body {
+ ldap::filter::encode (OU:dn:111.222.333.444:=test)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 1 [ldap::filter::LDAPString 111.222.333.444]] \
+ [asnChoice 2 [ldap::filter::LDAPString OU]] \
+ [asnChoice 3 [ldap::filter::AssertionValue test]] \
+ [asnChoice 4 [binary format cc 1 1]]]]
+
+test filter-10.6 {Extensible match: matching rule alone} -body {
+ ldap::filter::encode (:caseIgnoreIA5Match:=they)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 1 [ldap::filter::LDAPString caseIgnoreIA5Match]] \
+ [asnChoice 3 [ldap::filter::AssertionValue they]]]]
+
+test filter-10.7 {Extensible match: matching rule alone, in form of numericoid} -body {
+ ldap::filter::encode (:874.274.378.432:=value)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 1 [ldap::filter::LDAPString 874.274.378.432]] \
+ [asnChoice 3 [ldap::filter::AssertionValue value]]]]
+
+test filter-10.8 {Extensible match: matching rule + DN flag} -body {
+ ldap::filter::encode (:dn:caseIgnoreIA5Match:=they)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 1 [ldap::filter::LDAPString caseIgnoreIA5Match]] \
+ [asnChoice 3 [ldap::filter::AssertionValue they]] \
+ [asnChoice 4 [binary format cc 1 1]]]]
+
+test filter-10.9 {Extensible match: matching rule (numericoid) + DN flag} -body {
+ ldap::filter::encode (:dn:111.222.333.444:=value)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 1 [ldap::filter::LDAPString 111.222.333.444]] \
+ [asnChoice 3 [ldap::filter::AssertionValue value]] \
+ [asnChoice 4 [binary format cc 1 1]]]]
+
+test filter-10.10 {Extensible match: empty assertion value} -body {
+ ldap::filter::encode (AttrDesc:=)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 2 [ldap::filter::LDAPString AttrDesc]] \
+ [asnChoice 3 [ldap::filter::AssertionValue ""]]]]
+
+test filter-10.11 {Extensible match: empty assertion value, DN flag} -body {
+ ldap::filter::encode (AttrDesc:dn:=)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 2 [ldap::filter::LDAPString AttrDesc]] \
+ [asnChoice 3 [ldap::filter::AssertionValue ""]] \
+ [asnChoice 4 [binary format cc 1 1]]]]
+
+test filter-10.11 {Extensible match: matching rule with empty assertion value} -body {
+ ldap::filter::encode (:caseIgnoreIA5Match:=)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 1 [ldap::filter::LDAPString caseIgnoreIA5Match]] \
+ [asnChoice 3 [ldap::filter::AssertionValue ""]]]]
+
+test filter-10.12 {Extensible match: empty LHS} -body {
+ ldap::filter::encode (:=foo)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-10.12 {Extensible match: empty DN flag or matching rule OID} -body {
+ ldap::filter::encode (attrDesc::=bar)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-10.12 {Extensible match: empty matching rule OID} -body {
+ ldap::filter::encode (attrDesc:dn::=baz)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-10.13 {Extensible match: empty DN flag} -body {
+ ldap::filter::encode (attrDesc::caseIgnoreMatch:=quux)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-10.14 {Extensible match: empty DN flag} -body {
+ ldap::filter::encode (::caseIgnoreMatch:=foo)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-10.15 {Extensible match: empty matching rule OID} -body {
+ ldap::filter::encode (::=bar)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-10.16 {Extensible match: malformed matching rule numericoid} -body {
+ ldap::filter::encode (:111.222.333.xxx:=baz)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-10.17 {Extensible match: malformed matching rule numericoid} -body {
+ ldap::filter::encode (userCategory:111.222.333.444\;binary:=baz)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-10.18 {Extensible match: malformed matching rule numericoid} -body {
+ ldap::filter::encode (userCategory:dn:111.222.333.444\;x-bar:=foo)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-10.19 {Extensible match: malformed matching rule numericoid} -body {
+ ldap::filter::encode (:caseIgnoreIA5Match\;lang-ru:=quux)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-10.20 {Extensible match: camel-cased DN flag} -body {
+ ldap::filter::encode (attrDesc:Dn:caseIgnoreMatch:=quux)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-10.21 {Extensible match: prohibited character in attribute description} -body {
+ ldap::filter::encode (4cast:=foo)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-10.22 {Extensible match: gibberish in place of DN flag} -body {
+ ldap::filter::encode (OU:gibberish:caseIgnoreIA5Match:=bar)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-10.23 {Extensible match: options in attribute description} -body {
+ ldap::filter::encode (personAge\;lang-ru\;x-foo:numericMatch:=99)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 1 [ldap::filter::LDAPString numericMatch]] \
+ [asnChoice 2 [ldap::filter::LDAPString personAge\;lang-ru\;x-foo]] \
+ [asnChoice 3 [ldap::filter::AssertionValue 99]]]]
+
+test filter-10.24 {Extensible match: options in attribute description} -body {
+ ldap::filter::encode (111.222.333.444\;x-bar:dn:555.666.777.888:=foo)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 1 [ldap::filter::LDAPString 555.666.777.888]] \
+ [asnChoice 2 [ldap::filter::LDAPString 111.222.333.444\;x-bar]] \
+ [asnChoice 3 [ldap::filter::AssertionValue foo]] \
+ [asnChoice 4 [binary format cc 1 1]]]]
+
+test filter-11.1 {Prohibited characters in argument value} -body {
+ ldap::filter::encode (foo=bar(and)baz)
+} -returnCodes error -result {Invalid filter: malformed assertion value}
+
+test filter-11.2 {Prohibited characters in argument value} -body {
+ ldap::filter::encode (zero=lurks\0here)
+} -returnCodes error -result {Invalid filter: malformed assertion value}
+
+test filter-11.3 {Prohibited characters in argument value} -body {
+ ldap::filter::encode (extensible:=asterisk*)
+} -returnCodes error -result {Invalid filter: malformed assertion value}
+
+test filter-12.0 {Malformed attribute description: empty} -body {
+ ldap::filter::encode (=foo)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-12.1 {Malformed attribute description: doesn't start with a letter} -body {
+ ldap::filter::encode (2forTheRoad=bar)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-12.2 {Malformed attribute description: mix of descr and numericoid} -body {
+ ldap::filter::encode (foo.12.13=bar)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-12.3 {Malformed attribute description: bad numericoid} -body {
+ ldap::filter::encode (.11.12.13=bar)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-12.4 {Malformed attribute description: bad numericoid} -body {
+ ldap::filter::encode (11.12.13.=bar)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-12.5 {Malformed attribute description: prohibited character in descr} -body {
+ ldap::filter::encode (cn_2=bar)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-12.6 {Malformed attribute description: prohibited character in option} -body {
+ ldap::filter::encode (OU\;lang_en=bar)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-12.7 {Malformed attribute description:
+ colon in an LHS part of a rule which doesn't represent an extensible match} -body {
+ ldap::filter::encode (phoneNumber:dn=value)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-12.8 {Malformed attribute description: empty option} -body {
+ ldap::filter::encode (CN\;\;lang-ru=?)
+} -returnCodes error -result {Invalid filter: malformed attribute description}
+
+test filter-13.1 {Malformed assertion value: prohibited characters} -body {
+ ldap::filter::encode (foo<=*)
+} -returnCodes error -result {Invalid filter: malformed assertion value}
+
+test filter-13.2 {Malformed assertion value: prohibited characters} -body {
+ ldap::filter::encode (foo=()
+} -returnCodes error -result {Invalid filter: malformed assertion value}
+
+test filter-13.3 {Malformed assertion value: prohibited characters} -body {
+ ldap::filter::encode (foo=))
+} -returnCodes error -result {Invalid filter: malformed assertion value}
+
+test filter-13.4 {Malformed assertion value: prohibited characters} -body {
+ ldap::filter::encode (foo=\\)
+} -returnCodes error -result {Invalid filter: malformed assertion value}
+
+test filter-13.5 {Malformed assertion value: prohibited characters} -body {
+ ldap::filter::encode (foo=\0)
+} -returnCodes error -result {Invalid filter: malformed assertion value}
+
+test filter-15.0 {No match rule operator} -body {
+ ldap::filter::encode ()
+} -returnCodes error -result {Invalid filter: no match operator in item}
+
+test filter-15.1 {No match rule operator} -body {
+ ldap::filter::encode (11.12.14~value)
+} -returnCodes error -result {Invalid filter: no match operator in item}
+
+test filter-16.0 {Duplicated match rule operator} -body {
+ ldap::filter::encode (attrDesc=foo=bar)
+} -result [asnChoiceConstr 3 [glue \
+ [asnOctetString [ldap::filter::LDAPString attrDesc]] \
+ [asnOctetString [ldap::filter::AssertionValue foo=bar]]]]
+
+test filter-16.1 {Duplicated match rule operator} -body {
+ ldap::filter::encode (attrDesc~=foo~=)
+} -result [asnChoiceConstr 8 [glue \
+ [asnOctetString [ldap::filter::LDAPString attrDesc]] \
+ [asnOctetString [ldap::filter::AssertionValue foo~=]]]]
+
+test filter-16.2 {Duplicated match rule operator} -body {
+ ldap::filter::encode (attrDesc<=<=bar)
+} -result [asnChoiceConstr 6 [glue \
+ [asnOctetString [ldap::filter::LDAPString attrDesc]] \
+ [asnOctetString [ldap::filter::AssertionValue <=bar]]]]
+
+test filter-16.3 {Duplicated match rule operator} -body {
+ ldap::filter::encode (attrDesc>=>=>=)
+} -result [asnChoiceConstr 5 [glue \
+ [asnOctetString [ldap::filter::LDAPString attrDesc]] \
+ [asnOctetString [ldap::filter::AssertionValue >=>=]]]]
+
+test filter-16.4 {Duplicated match rule operator} -body {
+ ldap::filter::encode (AttrDesc:=:=what?:=)
+} -result [asnChoiceConstr 9 [glue \
+ [asnChoice 2 [ldap::filter::LDAPString AttrDesc]] \
+ [asnChoice 3 [ldap::filter::AssertionValue :=what?:=]]]]
+
+test filter-17.0 {Compound filters: negation} -body {
+ ldap::filter::encode (!(foo=bar))
+} -result [asnChoiceConstr 2 [asnChoiceConstr 3 [glue \
+ [asnOctetString [ldap::filter::LDAPString foo]] \
+ [asnOctetString [ldap::filter::AssertionValue bar]]]]]
+
+test filter-17.1 {Compound filters: AND} -body {
+ ldap::filter::encode (&(one=two)(three<=four)(five>=six))
+} -result [asnChoiceConstr 0 [glue \
+ [asnChoiceConstr 3 [glue \
+ [asnOctetString [ldap::filter::LDAPString one]] \
+ [asnOctetString [ldap::filter::AssertionValue two]]]] \
+ [asnChoiceConstr 6 [glue \
+ [asnOctetString [ldap::filter::LDAPString three]] \
+ [asnOctetString [ldap::filter::AssertionValue four]]]] \
+ [asnChoiceConstr 5 [glue \
+ [asnOctetString [ldap::filter::LDAPString five]] \
+ [asnOctetString [ldap::filter::AssertionValue six]]]]]]
+
+test filter-17.2 {Compound filters: OR} -body {
+ ldap::filter::encode (|(foo=bar)(baz:fuzzyMatch:=quux)(key~=value))
+} -result [asnChoiceConstr 1 [glue \
+ [asnChoiceConstr 3 [glue \
+ [asnOctetString [ldap::filter::LDAPString foo]] \
+ [asnOctetString [ldap::filter::AssertionValue bar]]]] \
+ [asnChoiceConstr 9 [glue \
+ [asnChoice 1 [ldap::filter::LDAPString fuzzyMatch]] \
+ [asnChoice 2 [ldap::filter::LDAPString baz]] \
+ [asnChoice 3 [ldap::filter::AssertionValue quux]]]] \
+ [asnChoiceConstr 8 [glue \
+ [asnOctetString [ldap::filter::LDAPString key]] \
+ [asnOctetString [ldap::filter::AssertionValue value]]]]]]
+
+test filter-17.3 {Compound filters: AND, spaces in assertion values} -body {
+ ldap::filter::encode {(&(OU=Research & Development)(DN=Rube Goldberg))}
+} -result [asnChoiceConstr 0 [glue \
+ [asnChoiceConstr 3 [glue \
+ [asnOctetString [ldap::filter::LDAPString OU]] \
+ [asnOctetString [ldap::filter::AssertionValue "Research & Development"]]]] \
+ [asnChoiceConstr 3 [glue \
+ [asnOctetString [ldap::filter::LDAPString DN]] \
+ [asnOctetString [ldap::filter::AssertionValue "Rube Goldberg"]]]]]]
+
+test filter-18.1 {Compound filters: unbalanced parenthesis} -body {
+ ldap::filter::encode (&(foo=bar)(baz=quux)
+} -returnCodes error -result {Invalid filter: unbalanced parenthesis}
+
+test filter-18.2 {Compound filters: unbalanced parenthesis} -body {
+ ldap::filter::encode (!(&(a=b)c=d))
+} -returnCodes error -result {Invalid filter: malformed compound filter expression}
+
+test filter-18.2 {Compound filters: unbalanced parenthesis} -body {
+ ldap::filter::encode (!(&(a=b)))c=d))
+} -returnCodes error -result {Invalid filter: malformed compound filter expression}
+
+test filter-18.3 {Compound filters: unbalanced parenthesis} -body {
+ ldap::filter::encode (!()
+} -returnCodes error -result {Invalid filter:\
+ filter expression must be surrounded by parentheses}
+
+test filter-19.1 {Compound filters: junk in expression} -body {
+ ldap::filter::encode {(& (foo=bar)(baz=quux))}
+} -returnCodes error -result {Invalid filter: malformed compound filter expression}
+
+test filter-19.2 {Compound filters: junk in expression} -body {
+ ldap::filter::encode {(&(foo=bar) (baz=quux))}
+} -returnCodes error -result {Invalid filter: malformed compound filter expression}
+
+test filter-19.3 {Compound filters: junk in expression} -body {
+ ldap::filter::encode {(|(foo=bar)(baz=quux) )}
+} -returnCodes error -result {Invalid filter: malformed compound filter expression}
+
+test filter-19.3 {Compound filters: junk in expression} -body {
+ ldap::filter::encode {(&&(foo=bar)(baz=quux))}
+} -returnCodes error -result {Invalid filter: malformed compound filter expression}
+
+test filter-19.4 {Compound filters: junk in expression} -body {
+ ldap::filter::encode {((foo=bar)&(baz=quux))}
+} -returnCodes error -match glob -result {Invalid filter: malformed attribute *}
+
+test filter-20.0 {Missing elements in filter composition} -body {
+ ldap::filter::encode (!)
+} -returnCodes error -result {Invalid filter:\
+ filter expression must be surrounded by parentheses}
+
+test filter-20.1 {Missing elements in filter composition} -body {
+ ldap::filter::encode (&)
+} -returnCodes error -result {Invalid filter: malformed compound filter expression}
+
+test filter-20.2 {Missing elements in filter composition} -body {
+ ldap::filter::encode (|)
+} -returnCodes error -result {Invalid filter: malformed compound filter expression}
+
+test filter-21.0 {Torture test} -body {
+ ldap::filter::encode [regsub -all \\s+ {
+ (|
+ (&
+ (userName=Jane\20Random\00)
+ (userCategory;x-lang-ru~=human)
+ )
+ (!
+ (|
+ (!
+ (salary=*)
+ )
+ (&
+ (personAge>=80)
+ (yearsEmployed<=70)
+ (employeeName=Joe*a**nd**Hacker)
+ )
+ )
+ )
+ (|
+ (11.22.33.44;x-files:dn:=value)
+ (:567.34.56:=\28\2a\29)
+ )
+ (foo=bar)
+ )
+ } ""]
+} -result [asnChoiceConstr 1 [glue \
+ [asnChoiceConstr 0 [glue \
+ [asnChoiceConstr 3 [glue \
+ [asnOctetString [ldap::filter::LDAPString userName]] \
+ [asnOctetString [encoding convertto utf-8 "Jane Random\0"]]]] \
+ [asnChoiceConstr 8 [glue \
+ [asnOctetString [ldap::filter::LDAPString userCategory\;x-lang-ru]] \
+ [asnOctetString [ldap::filter::AssertionValue human]]]]]] \
+ [asnChoiceConstr 2 \
+ [asnChoiceConstr 1 [glue \
+ [asnChoiceConstr 2 \
+ [asnChoice 7 [ldap::filter::LDAPString salary]]] \
+ [asnChoiceConstr 0 [glue \
+ [asnChoiceConstr 5 [glue \
+ [asnOctetString [ldap::filter::LDAPString personAge]] \
+ [asnOctetString [ldap::filter::AssertionValue 80]]]] \
+ [asnChoiceConstr 6 [glue \
+ [asnOctetString [ldap::filter::LDAPString yearsEmployed]] \
+ [asnOctetString [ldap::filter::AssertionValue 70]]]] \
+ [asnChoiceConstr 4 [glue \
+ [asnOctetString [ldap::filter::LDAPString employeeName]] \
+ [asnSequence [glue \
+ [asnChoice 0 [ldap::filter::AssertionValue Joe]] \
+ [asnChoice 1 [ldap::filter::AssertionValue a]] \
+ [asnChoice 1 [ldap::filter::AssertionValue nd]] \
+ [asnChoice 2 [ldap::filter::AssertionValue Hacker]]]]]]]]]]] \
+ [asnChoiceConstr 1 [glue \
+ [asnChoiceConstr 9 [glue \
+ [asnChoice 2 [ldap::filter::LDAPString 11.22.33.44\;x-files]] \
+ [asnChoice 3 [ldap::filter::AssertionValue value]] \
+ [asnChoice 4 [binary format cc 1 1]]]] \
+ [asnChoiceConstr 9 [glue \
+ [asnChoice 1 [ldap::filter::LDAPString 567.34.56]] \
+ [asnChoice 3 [encoding convertto utf-8 (*)]]]]]] \
+ [asnChoiceConstr 3 [glue \
+ [asnOctetString [ldap::filter::LDAPString foo]] \
+ [asnOctetString [ldap::filter::AssertionValue bar]]]] \
+ ]]
+
+# -------------------------------------------------------------------------
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
+# vim:ts=8:sw=4:sts=4:noet:syntax=tcl
diff --git a/tcllib/modules/ldap/ldapx.man b/tcllib/modules/ldap/ldapx.man
new file mode 100644
index 0000000..6234d2b
--- /dev/null
+++ b/tcllib/modules/ldap/ldapx.man
@@ -0,0 +1,772 @@
+[comment {-*- tcl -*- doctools manpage}]
+[comment {$Id: ldapx.man,v 1.14 2009/01/29 06:16:19 andreas_kupries Exp $}]
+[manpage_begin ldapx n 0.2.5]
+[keywords {directory access}]
+[keywords internet]
+[keywords ldap]
+[keywords {ldap client}]
+[keywords ldif]
+[keywords protocol]
+[keywords {rfc 2251}]
+[keywords {rfc 2849}]
+[copyright {2006 Pierre David <pdav@users.sourceforge.net>}]
+[moddesc {LDAP extended object interface}]
+[titledesc {LDAP extended object interface}]
+[category Networking]
+[require Tcl 8.4]
+[require ldapx [opt 1.0]]
+[description]
+[para]
+
+The [package ldapx] package provides an extended Tcl interface to
+LDAP directores and LDIF files. The [package ldapx] package is built
+upon the [package ldap] package in order to get low level LDAP access.
+
+[para]
+
+LDAP access is compatible with RFC 2251
+([uri http://www.rfc-editor.org/rfc/rfc2251.txt]).
+LDIF access is compatible with RFC 2849
+([uri http://www.rfc-editor.org/rfc/rfc2849.txt]).
+
+[section OVERVIEW]
+
+The [package ldapx] package provides objects to interact with LDAP
+directories and LDIF files with an easy to use programming interface.
+It implements three [package snit]::type classes.
+
+[para]
+
+The first class, [class entry], is used to store individual entries.
+Two different formats are available: the first one is the
+[emph standard] format, which represents an entry as read from the
+directory. The second format is the [emph change] format, which
+stores differences between two standard entries.
+
+[para]
+
+With these entries, an application which wants to modify an entry
+in a directory needs to read a (standard) entry from the directory,
+create a fresh copy into a new (standard) entry, modify the new
+copy, and then compute the differences between the two entries into
+a new (change) entry, which may be commited to the directory.
+
+[para]
+
+Such kinds of modifications are so heavily used that standard entries
+may contain their own copy of the original data. With such a copy,
+the application described above reads a (standard) entry from the
+directory, backs-up the original data, modifies the entry, and
+computes the differences between the entry and its backup. These
+differences are then commited to the directory.
+
+[para]
+
+Methods are provided to compute differences between two entries,
+to apply differences to an entry in order to get a new entry, and
+to get or set attributes in standard entries.
+
+[para]
+
+The second class is the [class ldap] class. It provides a method
+to [method connect] and bind to the directory with a uniform access
+to LDAP and LDAPS through an URL (ldap:// or ldaps://). The
+[method traverse] control structure executes a body for each entry
+found in the directory. The [method commit] method applies some
+changes (represented as [class entry] objects) to the directory.
+Since some attributes are represented as UTF-8 strings, the option
+[option -utf8] controls which attributes must be converted and
+which attributes must not be converted.
+
+[para]
+
+The last class is the [class ldif] class. It provides a method to
+associate a standard Tcl [emph channel] to an LDIF object. Then,
+methods [method read] and [method write] read or write entries from
+or to this channel. This class can make use of standard or change
+entries, according to the type of the LDIF file which may contain
+either standard entries or change entries (but not both at the same
+time). The option [option -utf8] works exactly as with the
+[class ldap] class.
+
+[section {ENTRY CLASS}]
+
+[subsection {Entry Instance Data}]
+
+An instance of the [class entry] class keeps the following data:
+
+[list_begin definitions]
+
+ [def dn]
+
+ This is the DN of the entry, which includes (in LDAP
+ terminology) the RDN (relative DN) and the Superior parts.
+
+ [def format]
+
+ The format may be [emph uninitialized] (entry not yet used),
+ [emph standard] or [emph change]. Most methods check the
+ format of the entry, which can be reset with the
+ [method reset] method.
+
+ [def attrvals]
+
+ In a [emph standard] entry, this is where the attributes
+ and associated values are stored. Many methods provide
+ access to these informations. Attribute names are always
+ converted into lower case.
+
+ [def backup]
+
+ In a [emph standard] entry, the backup may contain a copy
+ of the dn and all attributes and values. Methods
+ [method backup] and [method restore] manipulate these data,
+ and method [method diff] may use this backup.
+
+ [def change]
+
+ In a [emph change] entry, these data represent the
+ modifications. Such modifications are handled by specialized
+ methods such as [method apply] or [method commit].
+ Detailed format should not be used directly by programs.
+ [para]
+ Internally, modifications are represented as a list of
+ elements, each element has one of the following formats
+ (which match the corresponding LDAP operations):
+
+ [list_begin enumerated]
+
+ [enum]
+ {[const add] {attr1 {val1...valn} attr2 {...} ...}}
+ [para]
+ Addition of a new entry.
+
+ [enum]
+ {[const mod] {modop {attr1 [opt val1...valn]} attr2 ...} {modop ...} ...}
+ [para]
+ Modification of one or more attributes and/or values,
+ where <modop> can be [const modadd], [const moddel]
+ or [const modrepl] (see the LDAP modify operation).
+
+ [enum]
+ {[const del]}
+ [para]
+ Deletion of an old entry.
+
+ [enum]
+ {[const modrdn] newrdn deleteoldrdn [opt newsuperior]}
+ [para]
+ Renaming of an entry.
+
+ [list_end]
+
+[list_end]
+
+[subsection {Entry Options}]
+
+No option is defined by this class.
+
+[subsection {Methods for all kinds of entries}]
+
+[list_begin definitions]
+ [call [arg e] [method reset]]
+
+ This method resets the entry to an uninitialized state.
+
+ [call [arg e] [method dn] [opt [arg newdn]]]
+
+ This method returns the current DN of the entry. If the
+ optional [arg newdn] is specified, it replaces the current
+ DN of the entry.
+
+ [call [arg e] [method rdn]]
+
+ This method returns the RDN part of the DN of the entry.
+
+ [call [arg e] [method superior]]
+
+ This method returns the superior part of the DN of the entry.
+
+ [call [arg e] [method print]]
+
+ This method returns the entry as a string ready to be printed.
+
+[list_end]
+
+[para]
+
+[subsection {Methods for standard entries only}]
+
+In all methods, attribute names are converted in lower case.
+
+[list_begin definitions]
+ [call [arg se] [method isempty]]
+
+ This method returns 1 if the entry is empty (i.e. without
+ any attribute).
+
+ [call [arg se] [method get] [arg attr]]
+
+ This method returns all values of the attribute [arg attr],
+ or the empty list if the attribute is not fond.
+
+ [call [arg se] [method get1] [arg attr]]
+
+ This method returns the first value of the attribute.
+
+ [call [arg se] [method set] [arg attr] [arg values]]
+
+ This method sets the values (list [arg values]) of the
+ attribute [arg attr]. If the list is empty, this method
+ deletes all
+
+ [call [arg se] [method set1] [arg attr] [arg value]]
+
+ This method sets the values of the attribute [arg attr] to
+ be an unique value [arg value]. Previous values, if any,
+ are replaced by the new value.
+
+ [call [arg se] [method add] [arg attr] [arg values]]
+
+ This method adds all elements the list [arg values] to the
+ values of the attribute [arg attr].
+
+ [call [arg se] [method add1] [arg attr] [arg value]]
+
+ This method adds a single value given by the parameter
+ [arg value] to the attribute [arg attr].
+
+ [call [arg se] [method del] [arg attr] [opt [arg values]]]
+
+ If the optional list [arg values] is specified, this method
+ deletes all specified values from the attribute [arg attr].
+ If the argument [arg values] is not specified, this method
+ deletes all values.
+
+ [call [arg se] [method del1] [arg attr] [arg value]]
+
+ This method deletes a unique [arg value] from the attribute
+ [arg attr].
+
+ [call [arg se] [method getattr]]
+
+ This method returns all attributes names.
+
+ [call [arg se] [method getall]]
+
+ This method returns all attributes and values from the
+ entry, packed in a list of pairs <attribute, list of values>.
+
+ [call [arg se] [method setall] [arg avpairs]]
+
+ This method sets at once all attributes and values. The
+ format of the [arg avpairs] argument is the same as the one
+ returned by method [method getall].
+
+ [call [arg se] [method backup] [opt [arg other]]]
+
+ This method stores in an [arg other] standard entry object
+ a copy of the current DN and attributes/values. If the
+ optional [arg other] argument is not specified, copy is
+ done in the current entry (in a specific place, see section
+ [sectref OVERVIEW]).
+
+ [call [arg se] [method swap]]
+
+ This method swaps the current and backup contexts of the
+ entry.
+
+ [call [arg se] [method restore] [opt [arg other]]]
+
+ If the optional argument [arg other] is given, which must
+ then be a [emph standard] entry, this method restores the
+ current entry into the [arg other] entry. If the argument
+ [arg other] argument is not specified, this methods restores
+ the current entry from its internal backup (see section
+ [sectref OVERVIEW]).
+
+ [call [arg se] [method apply] [arg centry]]
+
+ This method applies changes defined in the [arg centry]
+ argument, which must be a [emph change] entry.
+
+[list_end]
+
+[subsection {Methods for change entries only}]
+
+[list_begin definitions]
+ [call [arg ce] [method change] [opt [arg new]]]
+
+ If the optional argument [arg new] is specified, this method
+ modifies the change list (see subsection [sectref {Entry Instance Data}] for
+ the exact format). In both cases, current change list is
+ returned.
+ Warning: values returned by this method should only be used
+ by specialized methods such as [method apply] or
+ [method commit].
+
+ [call [arg ce] [method diff] [arg new] [opt [arg old]]]
+
+ This method computes the differences between the [arg new]
+ and [arg old] entries under the form of a change list, and
+ stores this list into the current [emph change] entry. If
+ the optional argument [arg old] is not specified, difference
+ is computed from the entry and its internal backup (see
+ section [sectref OVERVIEW]). Return value is the computed
+ change list.
+
+[list_end]
+
+[subsection {Entry Example}]
+
+[example {
+ package require ldapx
+
+ #
+ # Create an entry and fill it as a standard entry with
+ # attributes and values
+ #
+ ::ldapx::entry create e
+ e dn "uid=joe,ou=people,o=mycomp"
+ e set1 "uid" "joe"
+ e set "objectClass" {person anotherObjectClass}
+ e set1 "givenName" "Joe"
+ e set1 "sn" "User"
+ e set "telephoneNumber" {+31415926535 +2182818}
+ e set1 "anotherAttr" "This is a beautiful day, isn't it?"
+
+ puts stdout "e\n[e print]"
+
+ #
+ # Create a second entry as a backup of the first, and
+ # make some changes on it.
+ # Entry is named automatically by snit.
+ #
+
+ set b [::ldapx::entry create %AUTO%]
+ e backup $b
+
+ puts stdout "$b\n[$b print]"
+
+ $b del "anotherAttr"
+ $b del1 "objectClass" "anotherObjectClass"
+
+ #
+ # Create a change entry, a compute differences between first
+ # and second entry.
+ #
+
+ ::ldapx::entry create c
+ c diff e $b
+
+ puts stdout "$c\n[$c print]"
+
+ #
+ # Apply changes to first entry. It should be the same as the
+ # second entry, now.
+ #
+
+ e apply c
+
+ ::ldapx::entry create nc
+ nc diff e $b
+
+ puts stdout "nc\n[nc print]"
+
+ #
+ # Clean-up
+ #
+
+ e destroy
+ $b destroy
+ c destroy
+ nc destroy
+}]
+
+[section {LDAP CLASS}]
+
+[subsection {Ldap Instance Data}]
+
+An instance of the [class ldap] class keeps the following data:
+
+[list_begin definitions]
+
+ [def channel]
+
+ This is the channel used by the [package ldap] package for
+ communication with the LDAP server.
+
+ [def lastError]
+
+ This variable contains the error message which appeared in
+ the last method of the [class ldap] class (this string is
+ modified in nearly all methods). The [method error] method
+ may be used to fetch this message.
+
+[list_end]
+
+[subsection {Ldap Options}]
+
+A first set of options of the [class ldap] class is used during
+search operations (methods [method traverse], [method search] and
+[method read], see below).
+
+[list_begin options]
+
+ [opt_def -scope [const base]|[const one]|[const sub]]
+
+ Specify the scope of the LDAP search to be one of
+ [const base], [const one] or [const sub] to specify
+ a base object, one-level or subtree search.
+ [para]
+ The default is [const sub].
+
+ [opt_def -derefaliases [const never]|[const seach]|[const find]|[const always]]
+
+ Specify how aliases dereferencing is handled:
+ [const never] is used to specify that aliases are never derefenced,
+ [const always] that aliases are always derefenced,
+ [const search] that aliases are dereferenced when searching,
+ or [const find] that aliases are dereferenced only when
+ locating the base object for the search.
+ [para]
+ The default is [const never].
+
+ [opt_def -sizelimit integer]
+
+ Specify the maximum number of entries to be retreived
+ during a search. A value of [const 0] means no limit.
+ [para]
+ Default is [const 0].
+
+ [opt_def -timelimit integer]
+
+ Specify the time limit for a search to complete.
+ A value of [const 0] means no limit.
+ [para]
+ Default is [const 0].
+
+ [opt_def -attrsonly [const 0]|[const 1]]
+
+ Specify if only attribute names are to be retrieved (value
+ [const 1]). Normally (value [const 0]), attribute values
+ are also retrieved.
+ [para]
+ Default is [const 0].
+
+[list_end]
+
+[para]
+
+The last option is used when getting entries or committing changes
+in the directory:
+
+[list_begin options]
+
+ [opt_def -utf8 {pattern-yes pattern-no}]
+
+ Specify which attribute values are encoded in UTF-8. This
+ information is specific to the LDAP schema in use by the
+ application, since some attributes such as jpegPhoto, for
+ example, are not encoded in UTF-8. This option takes the
+ form of a list with two regular expressions suitable for
+ the [cmd regexp] command (anchored by ^ and $).
+ The first specifies which attribute names are to be UTF-8
+ encoded, and the second selects, among those, the attribute
+ names which will not be UTF-8 encoded. It is thus possible
+ to say: convert all attributes, except jpegPhoto.
+
+ [para]
+
+ Default is {{.*} {}}, meaning: all attributes are converted,
+ without exception.
+
+[list_end]
+
+[subsection {Ldap Methods}]
+
+[list_begin definitions]
+ [call [arg la] [method error] [opt [arg newmsg]]]
+
+ This method returns the error message that occurred in the
+ last call to a [class ldap] class method. If the optional
+ argument [arg newmsg] is supplied, it becomes the last
+ error message.
+
+ [call [arg la] [method connect] [arg url] [opt [arg binddn]] [opt [arg bindpw]]]
+
+ This method connects to the LDAP server using given URL
+ (which can be of the form [uri ldap://host:port] or
+ [uri ldaps://host:port]). If an optional [arg binddn]
+ argument is given together with the [arg bindpw] argument,
+ the [method connect] binds to the LDAP server using the
+ specified DN and password.
+
+ [call [arg la] [method disconnect]]
+
+ This method disconnects (and unbinds, if necessary) from
+ the LDAP server.
+
+ [call [arg la] [method traverse] [arg base] [arg filter] [arg attrs] [arg entry] [arg body]]
+
+ This method is a new control structure. It searches the
+ LDAP directory from the specified base DN (given by the
+ [arg base] argument) and selects entries based on the
+ argument [arg filter]. For each entry found, this method
+ fetches attributes specified by the [arg attrs] argument
+ (or all attributes if it is an empty list), stores them in
+ the [arg entry] instance of class [class entry] and executes
+ the script defined by the argument [arg body]. Options are
+ used to refine the search.
+
+ [para]
+
+ Caution: when this method is used, the script [arg body]
+ cannot perform another LDAP search (methods [method traverse],
+ [method search] or [method read]).
+
+ [call [arg la] [method search] [arg base] [arg filter] [arg attrs]]
+
+ This method searches the directory using the same way as
+ method [method traverse]. All found entries are stored in
+ newly created instances of class [class entry], which are
+ returned in a list. The newly created instances should be
+ destroyed when they are no longer used.
+
+ [call [arg la] [method read] [arg base] [arg filter] [arg entry] ... [arg entry]]
+
+ This method reads one or more entries, using the same search
+ criteria as methods [method traverse] and [method search].
+ All attributes are stored in the entries. This method
+ provides a quick way to read some entries. It returns the
+ number of entries found in the directory (which may be more
+ than the number of read entries). If called without any
+ [arg entry] argument, this method just returns the number
+ of entries found, without returning any data.
+
+ [call [arg la] [method commit] [arg entry] ... [arg entry]]
+
+ This method commits the changes stored in the [arg entry]
+ arguments. Each [arg entry] may be either a [emph change]
+ entry, or a [emph standard] entry with a backup.
+ [para]
+ Note: in the future, this method should use the LDAP
+ transaction extension provided by OpenLDAP 2.3 and later.
+
+[list_end]
+
+[subsection {Ldap Example}]
+
+[example {
+ package require ldapx
+
+ #
+ # Connects to the LDAP directory
+ #
+
+ ::ldapx::ldap create l
+ set url "ldap://server.mycomp.com"
+ if {! [l connect $url "cn=admin,o=mycomp" "mypasswd"]} then {
+ puts stderr "error: [l error]"
+ exit 1
+ }
+
+ #
+ # Search all entries matching some criterion
+ #
+
+ l configure -scope one
+ ::ldapx::entry create e
+ set n 0
+ l traverse "ou=people,o=mycomp" "(sn=Joe*)" {sn givenName} e {
+ puts "dn: [e dn]"
+ puts " sn: [e get1 sn]"
+ puts " givenName: [e get1 givenName]"
+ incr n
+ }
+ puts "$n entries found"
+ e destroy
+
+ #
+ # Add a telephone number to some entries
+ # Note this modification cannot be done in the "traverse" operation.
+ #
+
+ set lent [l search "ou=people,o=mycomp" "(sn=Joe*)" {}]
+ ::ldapx::entry create c
+ foreach e $lent {
+ $e backup
+ $e add1 "telephoneNumber" "+31415926535"
+ c diff $e
+ if {! [l commit c]} then {
+ puts stderr "error: [l error]"
+ exit 1
+ }
+ $e destroy
+ }
+
+ l disconnect
+ l destroy
+}]
+
+[section {LDIF CLASS}]
+
+[subsection {Ldif Instance Data}]
+
+An instance of the [class ldif] class keeps the following data:
+
+[list_begin definitions]
+
+ [def channel]
+
+ This is the Tcl channel used to retrieve or store LDIF file
+ contents. The association between an instance and a channel
+ is made by the method [method channel]. There is no need
+ to disrupt this association when the LDIF file operation
+ has ended.
+
+ [def format]
+
+ LDIF files may contain [emph standard] entries or
+ [emph change] entries, but not both. This variable contains
+ the detected format of the file (when reading) or the format
+ of entries written to the file (when writing).
+
+ [def lastError]
+
+ This variable contains the error message which appeared in
+ the last method of the [class ldif] class (this string is
+ modified in nearly all methods). The [method error] method
+ may be used to fetch this message.
+
+ [def version]
+
+ This is the version of the LDIF file. Only version 1 is
+ supported: the method [method read] can only read from
+ version 1 files, and method [method write] only creates
+ version 1 files.
+
+[list_end]
+
+[subsection {Ldif Options}]
+
+This class defines two options:
+
+[list_begin options]
+
+ [opt_def -ignore {list-of-attributes}]
+
+ This option is used to ignore certain attribute names on
+ reading. For example, to read OpenLDAP replica files (replog),
+ one must ignore [const replica] and [const time] attributes
+ since they do not conform to the RFC 2849 standard for LDIF
+ files.
+ [para]
+ Default is empty list: no attribute is ignored.
+
+ [opt_def -utf8 {pattern-yes pattern-no}]
+
+ Specify which attribute values are encoded in UTF-8. This
+ information is specific to the LDAP schema in use by the
+ application, since some attributes such as jpegPhoto, for
+ example, are not encoded in UTF-8. This option takes the
+ form of a list with two regular expressions suitable for
+ the [cmd regexp] command (anchored by ^ and $).
+ The first specifies which attribute names are to be UTF-8
+ encoded, and the second selects, among those, the attribute
+ names which will not be UTF-8 encoded. It is thus possible
+ to say: convert all attributes, except jpegPhoto.
+
+ [para]
+
+ Default is {{.*} {}}, meaning: all attributes are converted,
+ without exception.
+
+[list_end]
+
+[subsection {Ldif Methods}]
+
+[list_begin definitions]
+
+ [call [arg li] [method channel] [arg chan]]
+
+ This method associates the Tcl channel named [arg chan]
+ with the LDIF instance. It resets the type of LDIF object
+ to [emph uninitialized].
+
+ [call [arg li] [method error] [opt [arg newmsg]]]
+
+ This method returns the error message that occurred in the
+ last call to a [class ldif] class method. If the optional
+ argument [arg newmsg] is supplied, it becomes the last
+ error message.
+
+ [call [arg li] [method read] [arg entry]]
+
+ This method reads the next entry from the LDIF file and
+ stores it in the [arg entry] object of class [class entry].
+ The entry may be a [emph standard] or [emph change] entry.
+
+ [call [arg li] [method write] [arg entry]]
+
+ This method writes the entry given in the argument
+ [arg entry] to the LDIF file.
+
+[list_end]
+
+[subsection {Ldif Example}]
+
+[example {
+ package require ldapx
+
+ # This examples reads a LDIF file containing entries,
+ # compare them to a LDAP directory, and writes on standard
+ # output an LDIF file containing changes to apply to the
+ # LDAP directory to match exactly the LDIF file.
+
+ ::ldapx::ldif create liin
+ liin channel stdin
+
+ ::ldapx::ldif create liout
+ liout channel stdout
+
+ ::ldapx::ldap create la
+ if {! [la connect "ldap://server.mycomp.com"]} then {
+ puts stderr "error: [la error]"
+ exit 1
+ }
+ la configure -scope one
+
+ # Reads LDIF file
+
+ ::ldapx::entry create e1
+ ::ldapx::entry create e2
+ ::ldapx::entry create c
+
+ while {[liin read e1] != 0} {
+ set base [e1 superior]
+ set id [e1 rdn]
+ if {[la read $base "($id)" e2] == 0} then {
+ e2 reset
+ }
+
+ c diff e1 e2
+ if {[llength [c change]] != 0} then {
+ liout write c
+ }
+ }
+
+ la disconnect
+ la destroy
+ e1 destroy
+ e2 destroy
+ c destroy
+ liout destroy
+ liin destroy
+}]
+
+[section References]
+
+[vset CATEGORY ldap]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/ldap/ldapx.tcl b/tcllib/modules/ldap/ldapx.tcl
new file mode 100644
index 0000000..aca3650
--- /dev/null
+++ b/tcllib/modules/ldap/ldapx.tcl
@@ -0,0 +1,1794 @@
+#
+# Extended object interface to entries in LDAP directories or LDIF files.
+#
+# (c) 2006 Pierre David (pdav@users.sourceforge.net)
+#
+# $Id: ldapx.tcl,v 1.12 2008/02/07 21:19:39 pdav Exp $
+#
+# History:
+# 2006/08/08 : pda : design
+#
+
+package require Tcl 8.4
+package require snit ;# tcllib
+package require uri 1.1.5 ;# tcllib
+package require base64 ;# tcllib
+package require ldap 1.6 ;# tcllib, low level code for LDAP directories
+
+package provide ldapx 1.0
+
+##############################################################################
+# LDAPENTRY object type
+##############################################################################
+
+snit::type ::ldapx::entry {
+ #########################################################################
+ # Variables
+ #########################################################################
+
+ #
+ # Format of an individual entry
+ # May be "standard" (standard LDAP entry, read from an LDAP directory
+ # or from a LDIF channel) or "change" (LDIF change, or result of the
+ # comparison of two standard entries).
+ # Special : "uninitialized" means that this entry has not been used,
+ # and the first use will initialize it.
+ #
+
+ variable format "uninitialized"
+
+ #
+ # DN
+ #
+
+ variable dn ""
+
+ #
+ # Standard entry
+ #
+ # Syntax:
+ # - array indexed by attribute names (lower case)
+ # - each value is the list of attributes
+ #
+ # The current state may be backed up in an internal state.
+ # (see backup and restore methods)
+ #
+
+ variable attrvals -array {}
+
+ variable backup 0
+ variable bckav -array {}
+ variable bckdn ""
+
+ #
+ # Change entry
+ #
+ # Syntax:
+ # {{<op> <parameters>} ... }
+ # if <op> = mod
+ # {mod {{<modop> <attr> [ {<val1> ... <valn>} ]} ...} }
+ # where <modop> = modrepl, modadd, moddel
+ # if <op> = add
+ # {add {<attr> {<val1> ... <valn>} ...}}
+ # if <op> = del
+ # {del}
+ # if <op> = modrdn
+ # {modrdn <newrdn> <deleteoldrdn> [ <newsuperior> ]}
+ #
+
+ variable change ""
+
+ #########################################################################
+ # Generic methods (for both standard and change entries)
+ #########################################################################
+
+ # Resets the entry to an empty state
+
+ method reset {} {
+
+ set format "uninitialized"
+ set dn ""
+ array unset attrvals
+ set backup 0
+ array unset bckav
+ set bckdn ""
+ set change ""
+ }
+
+ # Returns current format
+
+ method format {} {
+
+ return $format
+ }
+
+ # Checks if entry is compatible with a certain format
+ # errors out if not
+
+ method compatible {ref} {
+
+ if {$format eq "uninitialized"} then {
+ set format $ref
+ } elseif {$format ne $ref} then {
+ return -code error \
+ "Invalid operation on format $format (should be $ref)"
+ }
+ }
+
+ # Get or set the current dn
+
+ method dn {{newdn {-}}} {
+
+ if {$newdn ne "-"} then {
+ set dn $newdn
+ }
+ return $dn
+ }
+
+ # Get the "superior" (LDAP slang word) part of current dn
+
+ method superior {} {
+
+ set pos [string first "," $dn]
+ if {$pos == -1} then {
+ set r ""
+ } else {
+ set r [string range $dn [expr {$pos+1}] end]
+ }
+ return $r
+ }
+
+ # Get the "rdn" part of current dn
+
+ method rdn {} {
+
+ set pos [string first "," $dn]
+ if {$pos == -1} then {
+ set r ""
+ } else {
+ set r [string range $dn 0 [expr {$pos-1}]]
+ }
+ return $r
+ }
+
+ # Get a printable form of the contents
+
+ method print {} {
+
+ set r "dn: $dn"
+ switch -- $format {
+ uninitialized {
+ # nothing
+ }
+ standard {
+ foreach a [lsort [array names attrvals]] {
+ append r "\n$a: $attrvals($a)"
+ }
+ }
+ change {
+ if {[llength $change]} then {
+ append r "\n$change"
+ }
+ }
+ default {
+ append r " (inconsistent value)"
+ }
+ }
+ return $r
+ }
+
+ # Prints the whole state of an entry
+
+ method debug {} {
+
+ set r "dn = <$dn>\nformat = $format"
+ switch -- $format {
+ uninitialized {
+ # nothing
+ }
+ standard {
+ foreach a [lsort [array names attrvals]] {
+ append r "\n\t$a: $attrvals($a)"
+ }
+ if {$backup} then {
+ append r "\nbackup dn = $bckdn"
+ foreach a [lsort [array names bckav]] {
+ append r "\n\t$a: $bckav($a)"
+ }
+ } else {
+ append r "\nno backup"
+ }
+ }
+ change {
+ if {[llength $change]} then {
+ append r "\n$change"
+ } else {
+ append r "\nno change"
+ }
+ }
+ default {
+ append r " (inconsistent value)"
+ }
+ }
+ return $r
+ }
+
+
+ #########################################################################
+ # Methods for standard entries
+ #########################################################################
+
+ # Tells if the current entry is empty
+
+ method isempty {} {
+
+ $self compatible "standard"
+
+ return [expr {[array size attrvals] == 0}]
+ }
+
+ # Get all values for an attribute
+
+ method get {attr} {
+
+ $self compatible "standard"
+
+ set a [string tolower $attr]
+ if {[info exists attrvals($a)]} then {
+ set r $attrvals($a)
+ } else {
+ set r {}
+ }
+ return $r
+ }
+
+ # Get only the first value for an attribute
+
+ method get1 {attr} {
+
+ return [lindex [$self get $attr] 0]
+ }
+
+
+ # Set all values for an attribute
+
+ method set {attr vals} {
+
+ $self compatible "standard"
+
+ set a [string tolower $attr]
+ if {[llength $vals]} then {
+ set attrvals($a) $vals
+ } else {
+ unset -nocomplain attrvals($a)
+ }
+ return $vals
+ }
+
+ # Set only one value for an attribute
+
+ method set1 {attr val} {
+
+ if {$val eq ""} then {
+ set l {}
+ } else {
+ set l [list $val]
+ }
+
+ return [$self set $attr $l]
+ }
+
+ # Add some values to an attribute
+
+ method add {attr vals} {
+
+ $self compatible "standard"
+
+ set a [string tolower $attr]
+ foreach v $vals {
+ lappend attrvals($a) $v
+ }
+ return $attrvals($a)
+ }
+
+ # Add only one value to an attribute
+
+ method add1 {attr val} {
+
+ return [$self add $attr [list $val]]
+ }
+
+ # Delete all values (or some values only) for an attribute
+
+ method del {attr {vals {}}} {
+
+ $self compatible "standard"
+
+ set a [string tolower $attr]
+ if {[llength $vals]} then {
+ set l [$self get $attr]
+ foreach v $vals {
+ while {[set pos [lsearch -exact $l $v]] != -1} {
+ set l [lreplace $l $pos $pos]
+ }
+ }
+ } else {
+ set l {}
+ }
+
+ if {[llength $l]} then {
+ $self set $attr $l
+ } else {
+ unset -nocomplain attrvals($a)
+ }
+ return
+ }
+
+ # Delete only one value from an attribute
+
+ method del1 {attr val} {
+
+ $self del $attr [list $val]
+ }
+
+ # Get all attribute names
+
+ method getattr {} {
+
+ $self compatible "standard"
+
+ return [array names attrvals]
+ }
+
+ # Get all attribute names and values
+
+ method getall {} {
+
+ $self compatible "standard"
+
+ return [array get attrvals]
+ }
+
+ # Reset all attribute names and values at once
+
+ method setall {lst} {
+
+ $self compatible "standard"
+
+ array unset attrvals
+ foreach {attr vals} $lst {
+ set a [string tolower $attr]
+ set attrvals($a) $vals
+ }
+ }
+
+ # Back up current entry into a new one or into the internal backup state
+
+ method backup {{other {}}} {
+
+ $self compatible "standard"
+
+ if {$other eq ""} then {
+ #
+ # Back-up entry in $self->$oldav and $self->$dn
+ #
+ set backup 1
+ set bckdn $dn
+
+ array unset bckav
+ array set bckav [array get attrvals]
+ } else {
+ #
+ # Back-up entry in $other
+ #
+ $other compatible "standard"
+ $other dn $dn
+ $other setall [array get attrvals]
+ }
+ }
+
+ # Restore current entry from an old one or from the internal backup state
+
+ method restore {{other {}}} {
+
+ $self compatible "standard"
+
+ if {$backup} then {
+ if {$other eq ""} then {
+ #
+ # Restore in current context
+ #
+ set dn $bckdn
+ array unset attrvals
+ array set attrvals [array get bckav]
+ } else {
+ #
+ # Restore in another object
+ #
+ $other compatible "standard"
+ $other dn $bckdn
+ $other setall [array get bckav]
+ }
+ } else {
+ return -code error \
+ "Cannot restore a non backuped object"
+ }
+ }
+
+ # Swap current and backup data, if they reside in the same entry
+
+ method swap {} {
+
+ $self compatible "standard"
+
+ if {$backup} then {
+ #
+ # Swap current and backup contexts
+ #
+ set swdn $dn
+ set dn $bckdn
+ set bckdn $swdn
+
+ set swav [array get attrvals]
+ array unset attrvals
+ array set attrvals [array get bckav]
+ array unset bckav
+ array set bckav $swav
+ } else {
+ return -code error \
+ "Cannot swap a non backuped object"
+ }
+ }
+
+ # Apply some modifications (given by a change entry) to current entry
+
+ method apply {chg} {
+
+ $self compatible "standard"
+ $chg compatible "change"
+
+ #
+ # Apply $chg modifications to $self
+ #
+
+ foreach mod [$chg change] {
+ set op [lindex $mod 0]
+ switch -- $op {
+ add {
+ if {! [$self isempty]} then {
+ return -code error \
+ "Cannot add an entry to a non-empty entry"
+ }
+ $self setall [lindex $mod 1]
+ if {[string equal [$self dn] ""]} then {
+ $self dn [$chg dn]
+ }
+ }
+ mod {
+ foreach submod [lindex $mod 1] {
+ set subop [lindex $submod 0]
+ set attr [lindex $submod 1]
+ set vals [lindex $submod 2]
+ switch -- $subop {
+ modadd {
+ $self add $attr $vals
+ }
+ moddel {
+ $self del $attr $vals
+ }
+ modrepl {
+ $self del $attr
+ $self add $attr $vals
+ }
+ default {
+ return -code error \
+ "Invalid submod operation '$subop'"
+ }
+ }
+ }
+ }
+ del {
+ array unset attrvals
+ }
+ modrdn {
+ set newrdn [lindex $mod 1]
+ set delold [lindex $mod 2]
+ set newsup [lindex $mod 3]
+
+ if {! [regexp {^([^=]+)=([^,]+)$} $newrdn m nattr nval]} then {
+ return -code "Invalid new RDN '$newrdn'"
+ }
+
+ set olddn [$self dn]
+ if {! [regexp {^([^=]+)=([^,]+),(.*)} $olddn m oattr oval osup]} then {
+ return -code "Invalid old DN '$olddn'"
+ }
+
+ if {$newsup eq ""} then {
+ set dn "$newrdn,$osup"
+ } else {
+ set dn "$newrdn,$newsup"
+ }
+ $self dn $dn
+
+ if {$delold} then {
+ $self del1 $oattr $oval
+ }
+
+ # XXX should we ignore case ?
+ if {[lsearch -exact [$self get $nattr] $nval] == -1} then {
+ $self add1 $nattr $nval
+ }
+ }
+ default {
+ return -code error \
+ "Invalid change operation '$op'"
+ }
+ }
+ }
+ }
+
+ #########################################################################
+ # Methods for change entries
+ #########################################################################
+
+ # Get or set all modifications
+
+ method change {{newchg {-}}} {
+
+ $self compatible "change"
+
+ if {$newchg ne "-"} then {
+ set change $newchg
+ }
+ return $change
+ }
+
+ # Compute the difference between two entries (or between an entry
+ # and the backed-up internal state) into the current change entry
+ # e1 : new, e2 : old
+ # if e2 is not given, it defaults to backup in e1
+
+ method diff {new {old {}}} {
+
+ $self compatible "change"
+
+ #
+ # Select where backup is. If internal, creates a temporary
+ # standard entry.
+ #
+
+ if {$old eq ""} then {
+ set destroy_old 1
+ set old [::ldapx::entry create %AUTO%]
+ $new restore $old
+ } else {
+ set destroy_old 0
+ }
+
+ #
+ # Computes differences between values in the two entries
+ #
+
+ if {[$old dn] ne ""} then {
+ $self dn [$old dn]
+ } elseif {[$new dn] ne ""} then {
+ $self dn [$new dn]
+ } else {
+ $self dn ""
+ }
+
+ switch -- "[$new isempty][$old isempty]" {
+ 00 {
+ # They may differ
+ set change [DiffEntries $new $old]
+ }
+ 01 {
+ # new has been added
+ set change [list [list "add" [$new getall]]]
+ }
+ 10 {
+ # new has been deleted
+ set change [list [list "del"]]
+ }
+ 11 {
+ # they are both empty: no change
+ set change {}
+ }
+ }
+
+ #
+ # Remove temporary standard entry (backup was internal)
+ #
+
+ if {$destroy_old} then {
+ $old destroy
+ }
+
+ return $change
+ }
+
+ # local procedure to compute differences between two non empty entries
+
+ proc DiffEntries {new old} {
+ array set tnew [$new getall]
+ array set told [$old getall]
+
+ set lmod {}
+
+ #
+ # First step : is there a DN change?
+ #
+
+ set moddn [DiffDn [$new dn] [$old dn] tnew told]
+
+ #
+ # Second step : pick up changes in attributes and/or values
+ #
+
+ foreach a [array names tnew] {
+ if {[info exists told($a)]} then {
+ #
+ # They are new and old values for this attribute.
+ # We cannot use individual delete or add (rfc 4512,
+ # paragraph 2.5.1) for attributes which do not have an
+ # equality operator, so we use "replace" everywhere.
+ #
+
+ set lnew [lsort $tnew($a)]
+ set lold [lsort $told($a)]
+ if {$lold ne $lnew} then {
+ lappend lmod [list "modrepl" $a $tnew($a)]
+ }
+
+ unset tnew($a)
+ unset told($a)
+ } else {
+ lappend lmod [list "modadd" $a $tnew($a)]
+ unset tnew($a)
+ }
+ }
+
+ foreach a [array names told] {
+ lappend lmod [list "moddel" $a]
+ }
+
+ set lchg {}
+
+ if {[llength $lmod]} then {
+ lappend lchg [list "mod" $lmod]
+ }
+
+ #
+ # Third step : insert modDN changes
+ #
+
+ if {[llength $moddn]} then {
+ set newrdn [lindex $moddn 0]
+ set deleteoldrdn [lindex $moddn 1]
+ set newsuperior [lindex $moddn 2]
+
+ set lmod [list "modrdn" $newrdn $deleteoldrdn]
+ if {! [string equal $newsuperior ""]} then {
+ lappend lmod $newsuperior
+ }
+ lappend lchg $lmod
+ }
+
+ return $lchg
+ }
+
+ proc DiffDn {newdn olddn _tnew _told} {
+ upvar $_tnew tnew
+ upvar $_told told
+
+ #
+ # If DNs are the same, exit
+ #
+
+ if {[string equal -nocase $newdn $olddn]} then {
+ return {}
+ }
+
+ #
+ # Split components of both DNs : attribute, value, superior
+ #
+
+ if {! [regexp {^([^=]+)=([^,]+),(.*)} $olddn m oattr oval osup]} then {
+ return -code "Invalid old DN '$olddn'"
+ }
+ set oattr [string tolower $oattr]
+ set ordn "$oattr=$oval"
+
+ if {! [regexp {^([^=]+)=([^,]+),(.*)} $newdn m nattr nval nsup]} then {
+ return -code "Invalid new DN '$newdn'"
+ }
+ set nattr [string tolower $nattr]
+ set nrdn "$nattr=$nval"
+
+ #
+ # Checks if superior has changed
+ #
+
+ if {! [string equal -nocase $osup $nsup]} then {
+ set newsuperior $nsup
+ } else {
+ set newsuperior ""
+ }
+
+ #
+ # Checks if rdn has changed
+ #
+
+ if {! [string equal -nocase $ordn $nrdn]} then {
+ #
+ # Checks if old rdn must be deleted
+ #
+
+ set deleteoldrdn 1
+ if {[info exists tnew($oattr)]} then {
+ set pos [lsearch -exact [string tolower $tnew($oattr)] \
+ [string tolower $oval]]
+ if {$pos != -1} then {
+ set deleteoldrdn 0
+ }
+ }
+
+ #
+ # Remove old and new rdn such as DiffEntries doesn't
+ # detect any modification.
+ #
+
+ foreach t {tnew told} {
+ foreach {a v} [list $oattr $oval $nattr $nval] {
+ if {[info exists ${t}($a)]} then {
+ set l [set ${t}($a)]
+ set pos [lsearch -exact [string tolower $l] \
+ [string tolower $v] ]
+ if {$pos != -1} then {
+ set l [lreplace $l $pos $pos]
+ if {[llength $l]} then {
+ set ${t}($a) $l
+ } else {
+ unset -nocomplain ${t}($a)
+ }
+ }
+ }
+ }
+ }
+ } else {
+ set deleteoldrdn 0
+ }
+
+ return [list $nrdn $deleteoldrdn $newsuperior]
+ }
+
+
+ #########################################################################
+ # End of ldapentry
+ #########################################################################
+}
+
+##############################################################################
+# UTF8 translator, component used to manage the -utf8 option
+##############################################################################
+
+snit::type ::ldapx::utf8trans {
+
+ #########################################################################
+ # Option
+ #########################################################################
+
+ option -utf8 -default {{.*} {}}
+
+ #########################################################################
+ # Methods
+ #########################################################################
+
+ method must {attr} {
+ set utf8yes [lindex $options(-utf8) 0]
+ set utf8no [lindex $options(-utf8) 1]
+ set r 0
+ if {[regexp -expanded -nocase "^$utf8yes$" $attr]} then {
+ set r 1
+ if {[regexp -expanded -nocase "^$utf8no$" $attr]} then {
+ set r 0
+ }
+ }
+ return $r
+ }
+
+ method encode {attr val} {
+ if {[$self must $attr]} then {
+ set val [encoding convertto utf-8 $val]
+ }
+ return $val
+ }
+
+ method decode {attr val} {
+ if {[$self must $attr]} then {
+ set val [encoding convertfrom utf-8 $val]
+ }
+ return $val
+ }
+
+ method encodepairs {avpairs} {
+ set r {}
+ foreach {attr vals} $avpairs {
+ if {[llength $vals]} then {
+ lappend r $attr [$self encode $attr $vals]
+ } else {
+ lappend r $attr
+ }
+ }
+ return $r
+ }
+
+ method decodepairs {avpairs} {
+ set r {}
+ foreach {attr vals} $avpairs {
+ set vals [$self decode $attr $vals]
+ lappend r $attr $vals
+ }
+ return $r
+ }
+}
+
+##############################################################################
+# LDAP object type
+##############################################################################
+
+snit::type ::ldapx::ldap {
+ #########################################################################
+ # Options
+ #
+ # note : options are lowercase
+ #########################################################################
+
+ option -scope -default "sub"
+ option -derefaliases -default "never"
+ option -sizelimit -default 0
+ option -timelimit -default 0
+ option -attrsonly -default 0
+
+ component translator
+ delegate option -utf8 to translator
+
+ #
+ # Channel descriptor
+ #
+
+ variable channel ""
+ variable bind 0
+
+ #
+ # Last error
+ #
+
+ variable lastError ""
+
+ #
+ # Defaults connection modes
+ #
+
+ variable connect_defaults -array {
+ ldap {389 ::ldap::connect}
+ ldaps {636 ::ldap::secure_connect}
+ }
+
+
+ #########################################################################
+ # Constructor
+ #########################################################################
+
+ constructor {args} {
+ install translator using ::ldapx::utf8trans create %AUTO%
+ $self configurelist $args
+ }
+
+ destructor {
+ catch {$translator destroy}
+ }
+
+ #########################################################################
+ # Methods
+ #########################################################################
+
+ # Get or set the last error message
+
+ method error {{le {-}}} {
+
+ if {! [string equal $le "-"]} then {
+ set lastError $le
+ }
+ return $lastError
+ }
+
+ # Connect to the LDAP directory, and binds to it if needed
+
+ method connect {url {binddn {}} {bindpw {}}} {
+
+ array set comp [::uri::split $url "ldap"]
+
+ if {! [::info exists comp(host)]} then {
+ $self error "Invalid host in URL '$url'"
+ return 0
+ }
+
+ set scheme $comp(scheme)
+ if {! [::info exists connect_defaults($scheme)]} then {
+ $self error "Unrecognized URL '$url'"
+ return 0
+ }
+
+ set defport [lindex $connect_defaults($scheme) 0]
+ set fct [lindex $connect_defaults($scheme) 1]
+
+ if {[string equal $comp(port) ""]} then {
+ set comp(port) $defport
+ }
+
+ if {[Check $selfns {set channel [$fct $comp(host) $comp(port)]}]} then {
+ return 0
+ }
+
+ if {$binddn eq ""} then {
+ set bind 0
+ } else {
+ set bind 1
+ if {[Check $selfns {::ldap::bind $channel $binddn $bindpw}]} then {
+ return 0
+ }
+ }
+ return 1
+ }
+
+ # Disconnect from the LDAP directory
+
+ method disconnect {} {
+
+ Connected $selfns
+
+ if {$bind} {
+ if {[Check $selfns {::ldap::unbind $channel}]} then {
+ return 0
+ }
+ }
+ if {[Check $selfns {::ldap::disconnect $channel}]} then {
+ return 0
+ }
+ set channel ""
+ return 1
+ }
+
+ # New control structure : traverse the DIT and execute the body
+ # for each found entry.
+
+ method traverse {base filter attrs entry body} {
+
+ Connected $selfns
+
+ global errorInfo errorCode
+
+ set lastError ""
+
+ #
+ # Initiate search
+ #
+
+ set opt [list \
+ -scope $options(-scope) \
+ -derefaliases $options(-derefaliases) \
+ -sizelimit $options(-sizelimit) \
+ -timelimit $options(-timelimit) \
+ -attrsonly $options(-attrsonly) \
+ ]
+
+ ::ldap::searchInit $channel $base $filter $attrs $opt
+
+ #
+ # Execute the specific body for each result found
+ #
+
+ while {1} {
+ #
+ # The first call to searchNext may fail when searchInit
+ # is given some invalid parameters.
+ # We must terminate the current search in order to allow
+ # future searches.
+ #
+
+ set err [catch {::ldap::searchNext $channel} r]
+
+ if {$err} then {
+ set ei $errorInfo
+ set ec $errorCode
+ ::ldap::searchEnd $channel
+ return -code error -errorinfo $ei -errorcode $ec $r
+ }
+
+ #
+ # End of result messages
+ #
+
+ if {[llength $r] == 0} then {
+ break
+ }
+
+ #
+ # Set DN and attributes-values (converted from utf8 if needed)
+ # for the entry
+ #
+
+ $entry reset
+
+ $entry dn [lindex $r 0]
+ $entry setall [$translator decodepairs [lindex $r 1]]
+
+ #
+ # Execute body with the entry
+ #
+ # http://wiki.tcl.tk/685
+ #
+
+ set code [catch {uplevel 1 $body} msg]
+ switch -- $code {
+ 0 {
+ # ok
+ }
+ 1 {
+ # error
+ set ei $errorInfo
+ set ec $errorCode
+ ::ldap::searchEnd $channel
+ return -code error -errorinfo $ei -errorcode $ec $msg
+ }
+ 2 {
+ # return
+ ::ldap::searchEnd $channel
+ return -code return $msg
+ }
+ 3 {
+ # break
+ ::ldap::searchEnd $channel
+ return {}
+ }
+ 4 {
+ # continue
+ }
+ default {
+ # user defined
+ ::ldap::searchEnd $channel
+ return -code $code $msg
+ }
+ }
+ }
+
+ #
+ # Terminate search
+ #
+
+ ::ldap::searchEnd $channel
+ }
+
+ # Returns a list of newly created objects which match
+
+ method search {base filter attrs} {
+
+ Connected $selfns
+
+ set e [::ldapx::entry create %AUTO%]
+ set r {}
+ $self traverse $base $filter $attrs $e {
+ set new [::ldapx::entry create %AUTO%]
+ $e backup $new
+ lappend r $new
+ }
+ $e destroy
+ return $r
+ }
+
+ # Read one or more entries, and returns the number of entries found.
+ # Useful to easily read one or more entries.
+
+ method read {base filter args} {
+
+ set n 0
+ set max [llength $args]
+ set e [::ldapx::entry create %AUTO%]
+ $self traverse $base $filter {} $e {
+ if {$n < $max} then {
+ $e backup [lindex $args $n]
+ }
+ incr n
+ }
+ return $n
+ }
+
+ # Commit a list of changes (or standard, backuped entries)
+
+ method commit {args} {
+
+ Connected $selfns
+
+ foreach entry $args {
+ switch -- [$entry format] {
+ uninitialized {
+ return -code error \
+ "Uninitialized entry"
+ }
+ standard {
+ set echg [::ldapx::entry create %AUTO%]
+ set lchg [$echg diff $entry]
+ set dn [$echg dn]
+ $echg destroy
+ }
+ change {
+ set dn [$entry dn]
+ set lchg [$entry change]
+ }
+ }
+
+ foreach chg $lchg {
+ set op [lindex $chg 0]
+
+ switch -- $op {
+ {} {
+ # nothing to do
+ }
+ add {
+ set av [$translator encodepairs [lindex $chg 1]]
+ if {[Check $selfns {::ldap::addMulti $channel $dn $av}]} then {
+ return 0
+ }
+ }
+ del {
+ if {[Check $selfns {::ldap::delete $channel $dn}]} then {
+ return 0
+ }
+ }
+ mod {
+ set lrep {}
+ set ldel {}
+ set ladd {}
+
+ foreach submod [lindex $chg 1] {
+ set subop [lindex $submod 0]
+ set attr [lindex $submod 1]
+ set vals [lindex $submod 2]
+
+ set vals [$translator encode $attr $vals]
+ switch -- $subop {
+ modadd {
+ lappend ladd $attr $vals
+ }
+ moddel {
+ lappend ldel $attr $vals
+ }
+ modrepl {
+ lappend lrep $attr $vals
+ }
+ }
+ }
+
+ if {[Check $selfns {::ldap::modifyMulti $channel $dn \
+ $lrep $ldel $ladd}]} then {
+ return 0
+ }
+ }
+ modrdn {
+ set newrdn [lindex $chg 1]
+ set delOld [lindex $chg 2]
+ set newSup [lindex $chg 3]
+ if {[string equal $newSup ""]} then {
+ if {[Check $selfns {::ldap::modifyDN $channel $dn \
+ $newrdn $delOld}]} then {
+ return 0
+ }
+ } else {
+ if {[Check $selfns {::ldap::modifyDN $channel $dn \
+ $newrdn $delOld $newSup}]} then {
+ return 0
+ }
+ }
+ }
+ }
+ }
+ }
+
+ return 1
+ }
+
+ #########################################################################
+ # Local procedures
+ #########################################################################
+
+ proc Connected {selfns} {
+ if {$channel eq ""} then {
+ return -code error \
+ "Object not connected"
+ }
+ }
+
+ proc Check {selfns script} {
+ return [catch {uplevel 1 $script} lastError]
+ }
+
+ #########################################################################
+ # End of LDAP object type
+ #########################################################################
+}
+
+##############################################################################
+# LDIF object type
+##############################################################################
+
+snit::type ::ldapx::ldif {
+
+ #########################################################################
+ # Options
+ #########################################################################
+
+ #
+ # Fields to ignore when reading change file
+ #
+
+ option -ignore {}
+
+ component translator
+ delegate option -utf8 to translator
+
+
+ #########################################################################
+ # Variables
+ #########################################################################
+
+ #
+ # Version of LDIF file (0 means : uninitialized)
+ #
+
+ variable version 0
+
+ #
+ # Channel descriptor
+ #
+
+ variable channel ""
+
+ #
+ # Line number
+ #
+
+ variable lineno 0
+
+ #
+ # Last error message
+ #
+
+ variable lastError ""
+
+ #
+ # Number of entries read or written
+ #
+
+ variable nentries 0
+
+ #
+ # Type of LDIF file
+ #
+
+ variable format "uninitialized"
+
+ #########################################################################
+ # Constructor
+ #########################################################################
+
+ constructor {args} {
+ install translator using ::ldapx::utf8trans create %AUTO%
+ $self configurelist $args
+ }
+
+ destructor {
+ catch {$translator destroy}
+ }
+
+ #########################################################################
+ # Methods
+ #########################################################################
+
+ # Initialize a channel
+
+ method channel {newchan} {
+
+ set channel $newchan
+ set version 0
+ set nentries 0
+ set format "uninitialized"
+ set lineno 0
+ return
+ }
+
+ # Get or set the last error message
+
+ method error {{le {-}}} {
+
+ if {$le ne "-"} then {
+ set lastError $le
+ }
+ return $lastError
+ }
+
+ # An LDIF file cannot include both changes and standard entries
+ # (see RFC 2849, page 2). Check this.
+
+ method compatible {ref} {
+
+ if {$format eq "uninitialized"} then {
+ set format $ref
+ } elseif {$format ne $ref} then {
+ return -code error \
+ "Invalid entry ($ref) type for LDIF $format file"
+ }
+ }
+
+ # Reads an LDIF entry (standard or change) from the channel
+ # returns 1 if ok, 0 if error or EOF
+
+ # XXX this method is just coded for tests at this time
+
+ method debugread {entry} {
+
+ $entry compatible "standard"
+ $entry dn "uid=joe,ou=org,o=com"
+ $entry setall {uid {joe} sn {User} givenName {Joe} cn {{Joe User}}
+ telephoneNumber {+31415926535 +27182818285} objectClass {person}
+ }
+ return 1
+ }
+
+ # Read an LDIF entry (standard or change) from the channel
+ # returns 1 if ok, 0 if error or EOF
+
+ method read {entry} {
+ if {$channel eq ""} then {
+ return -code error \
+ "Channel not initialized"
+ }
+
+ set r [Lexical $selfns]
+ if {[lindex $r 0] ne "err"} then {
+ set r [Syntaxic $selfns [lindex $r 1]]
+ }
+
+ if {[lindex $r 0] eq "err"} then {
+ set lastError [lindex $r 1]
+ return 0
+ }
+
+ switch -- [lindex $r 0] {
+ uninitialized {
+ $entry reset
+ set lastError ""
+ set r 0
+ }
+ standard {
+ if {[catch {$self compatible "change"}]} then {
+ set lastError "Standard entry not allowed in LDIF change file"
+ set r 0
+ } else {
+ $entry reset
+ $entry dn [lindex $r 1]
+ $entry setall [lindex $r 2]
+ set r 1
+ }
+ }
+ change {
+ if {[catch {$self compatible "change"}]} then {
+ set lastError "Change entry not allowed in LDIF standard file"
+ set r 0
+ } else {
+ $entry reset
+ $entry dn [lindex $r 1]
+ $entry change [list [lindex $r 2]]
+ set r 1
+ }
+ }
+ default {
+ return -code error \
+ "Internal error (invalid returned entry format)"
+ }
+ }
+
+ return $r
+ }
+
+ # Write an LDIF entry to the channel
+
+ method write {entry} {
+
+ if {$channel eq ""} then {
+ return -code error \
+ "Channel not initialized"
+ }
+
+ switch -- [$entry format] {
+ uninitialized {
+ # nothing
+ }
+ standard {
+ if {[llength [$entry getall]]} then {
+ $self compatible "standard"
+
+ if {$nentries == 0} then {
+ if {$version == 0} then {
+ set version 1
+ }
+ WriteLine $selfns "version" "$version"
+ puts $channel ""
+ }
+
+ WriteLine $selfns "dn" [$entry dn]
+
+ foreach a [$entry getattr] {
+ foreach v [$entry get $a] {
+ WriteLine $selfns $a $v
+ }
+ }
+ puts $channel ""
+ }
+ }
+ change {
+ $self compatible "change"
+
+ set lchg [$entry change]
+ foreach chg $lchg {
+ if {$nentries == 0} then {
+ if {$version == 0} then {
+ set version 1
+ }
+ WriteLine $selfns "version" "$version"
+ puts $channel ""
+ }
+
+ WriteLine $selfns "dn" [$entry dn]
+
+ set op [lindex $chg 0]
+ switch -- $op {
+ add {
+ WriteLine $selfns "changetype" "add"
+ foreach {attr vals} [lindex $chg 1] {
+ foreach v $vals {
+ WriteLine $selfns $attr $v
+ }
+ }
+ }
+ del {
+ WriteLine $selfns "changetype" "delete"
+ }
+ mod {
+ WriteLine $selfns "changetype" "modify"
+ foreach submod [lindex $chg 1] {
+ set subop [lindex $submod 0]
+ set attr [lindex $submod 1]
+ set vals [lindex $submod 2]
+
+ switch -- $subop {
+ modadd {
+ WriteLine $selfns "add" $attr
+ }
+ moddel {
+ WriteLine $selfns "delete" $attr
+ }
+ modrepl {
+ WriteLine $selfns "replace" $attr
+ }
+ }
+ foreach v $vals {
+ WriteLine $selfns $attr $v
+ }
+ puts $channel "-"
+ }
+ }
+ modrdn {
+ WriteLine $selfns "changetype" "modrdn"
+ set newrdn [lindex $chg 1]
+ set delold [lindex $chg 2]
+ set newsup [lindex $chg 3]
+ WriteLine $selfns "newrdn" $newrdn
+ WriteLine $selfns "deleteOldRDN" $delold
+ if {$newsup ne ""} then {
+ WriteLine $selfns "newSuperior" $newsup
+ }
+ }
+ }
+ puts $channel ""
+ incr nentries
+ }
+ }
+ default {
+ return -code error \
+ "Invalid entry format"
+ }
+ }
+ return 1
+ }
+
+ #########################################################################
+ # Local procedures to read an entry
+ #########################################################################
+
+ #
+ # Lexical analysis of an entry
+ # Special case for "version:" entry.
+ # Returns a list of lines {ok {{<attr1> <val1>} {<attr2> <val2>} ...}}
+ # or a list {err <message>}
+ #
+
+ proc Lexical {selfns} {
+ set result {}
+ set prev ""
+
+ while {[gets $channel line] > -1} {
+ incr lineno
+
+ if {$line eq ""} then {
+ #
+ # Empty line: we are either before the beginning
+ # of the entry or at the empty line after the
+ # entry.
+ # We don't give up before getting something.
+ #
+
+ if {! [FlushLine $selfns "" result prev msg]} then {
+ return [list "err" $msg]
+ }
+
+ if {[llength $result]} then {
+ break
+ }
+
+ } elseif {[regexp {^[ \t]} $line]} then {
+ #
+ # Continuation line
+ #
+
+ append prev [string trim $line]
+
+ } elseif {[regexp {^-$} $line]} then {
+ #
+ # Separation between individual modifications
+ #
+
+ if {! [FlushLine $selfns "" result prev msg]} then {
+ return [list "err" $msg]
+ }
+ lappend result [list "-" {}]
+
+ } else {
+ #
+ # Should be a normal line (key: val)
+ #
+
+ if {! [FlushLine $selfns $line result prev msg]} then {
+ return [list "err" $msg]
+ }
+
+ }
+ }
+
+ #
+ # End of file, or end of entry. Flush buffered data from $prev
+ # for EOF case.
+ #
+
+ if {! [FlushLine $selfns "" result prev msg]} then {
+ return [list "err" $msg]
+ }
+
+ return [list "ok" $result]
+ }
+
+ proc FlushLine {selfns line _result _prev _msg} {
+ upvar $_result result $_prev prev $_msg msg
+
+ if {$prev ne ""} then {
+ set r [DecodeLine $selfns $prev]
+ if {[llength $r] != 2} then {
+ set msg "$lineno: invalid syntax"
+ return 0
+ }
+
+ #
+ # Special case for "version: 1". This code should not
+ # be in lexical analysis, but this would be too disruptive
+ # in syntaxic analysis
+ #
+
+ if {[string equal -nocase [lindex $r 0] "version"]} then {
+ if {$version != 0} then {
+ set msg "version attribute allowed only at the beginning of the LDIF file"
+ return 0
+ }
+ set val [lindex $r 1]
+ if {[catch {set val [expr {$val+0}]}]} then {
+ set msg "invalid version value"
+ return 0
+ }
+ if {$val != 1} then {
+ set msg "unrecognized version '$val'"
+ return 0
+ }
+ set version 1
+ } else {
+ lappend result $r
+ }
+ }
+ set prev $line
+
+ return 1
+ }
+
+ proc DecodeLine {selfns str} {
+ if {[regexp {^([^:]*)::[ \t]*(.*)} $str d key val]} then {
+ set key [string tolower $key]
+ set val [::base64::decode $val]
+ set val [$translator decode $key $val]
+ set r [list $key $val]
+ } elseif {[regexp {^([^:]*):[ \t]*(.*)} $str d key val]} then {
+ set key [string tolower $key]
+ set val [$translator decode $key $val]
+ set r [list $key $val]
+ } else {
+ # syntax error
+ set r {}
+ }
+ return $r
+ }
+
+ #
+ # Array indexed by current state of the LDIF automaton
+ # Each element is a list of actions, each with the format:
+ # pattern on on "attribute:value"
+ # next state
+ # script (to be evaled in Syntaxic local procedure)
+ #
+
+ variable ldifautomaton -array {
+ begin {
+ {dn:* dn {set dn $val}}
+ {EOF:* end {set r [list "empty"]}}
+ }
+ dn {
+ {changetype:modify mod {set t "change" ; set r {mod}}}
+ {changetype:modrdn modrdn {set t "change" ; set newsup {}}}
+ {changetype:add add {set t "change"}}
+ {changetype:delete del {set t "change"}}
+ {*:* standard {set t "standard" ; lappend tab($key) $val}}
+ }
+ standard {
+ {EOF:* end {set r [array get tab]}}
+ {*:* standard {lappend tab($key) $val}}
+ }
+ mod {
+ {add:* mod-add {set attr [string tolower $val] ; set vals {}}}
+ {delete:* mod-del {set attr [string tolower $val] ; set vals {}}}
+ {replace:* mod-repl {set attr [string tolower $val] ; set vals {}}}
+ {EOF:* end {}}
+ }
+ mod-add {
+ {*:* mod-add-attr {lappend vals $val}}
+ }
+ mod-add-attr {
+ {-:* mod {lappend r [list "modadd" $attr $vals]}}
+ {*:* mod-add-attr {lappend vals $val}}
+ }
+ mod-del {
+ {-:* mod {lappend r [list "moddel" $attr $vals]}}
+ {*:* mod-del {lappend vals $val}}
+ }
+ mod-repl {
+ {-:* mod {lappend r [list "modrepl" $attr $vals]}}
+ {*:* mod-repl {lappend vals $val}}
+ }
+ modrdn {
+ {newrdn:* modrdn-new {set newrdn $val}}
+ }
+ modrdn-new {
+ {deleteoldrdn:0 modrdn-del {set delold 0}}
+ {deleteoldrdn:1 modrdn-del {set delold 1}}
+ }
+ modrdn-del {
+ {newsuperior:* modrdn-end {set newsup $val}}
+ {EOF:* end {set r [list modrdn $newrdn $delold] }}
+ }
+ modrdn-end {
+ {EOF:* end {set r [list modrdn $newrdn $delold $newsup]}}
+ }
+ add {
+ {EOF:* end {set r [list add [array get tab]]}}
+ {*:* add {lappend tab($key) $val}}
+ }
+ del {
+ {EOF:* end {set r [list del]}}
+ }
+ }
+
+ proc Syntaxic {selfns lcouples} {
+ set state "begin"
+ set newsup {}
+ set t "uninitialized"
+ foreach c $lcouples {
+ set key [lindex $c 0]
+ if {[lsearch [string tolower $options(-ignore)] $key] == -1} then {
+ set val [lindex $c 1]
+ set a [Automaton $selfns $state $key $val]
+ if {$a eq ""} then {
+ return [list "err" "Syntax error before line $lineno"]
+ }
+ set state [lindex $a 0]
+ set script [lindex $a 1]
+ eval $script
+ }
+ }
+
+ set a [Automaton $selfns $state "EOF" "EOF"]
+ if {$a eq ""} then {
+ return [list "err" "Premature EOF"]
+ }
+ set script [lindex $a 1]
+ eval $script
+
+ set result [list $t]
+ switch $t {
+ uninitialized {
+ # nothing
+ }
+ standard {
+ lappend result $dn $r
+ }
+ change {
+ lappend result $dn $r
+ }
+ }
+
+ return $result
+ }
+
+ proc Automaton {selfns state key val} {
+ set r {}
+ if {[info exists ldifautomaton($state)]} then {
+ foreach a $ldifautomaton($state) {
+ if {[string match [lindex $a 0] "$key:$val"]} then {
+ set r [lreplace $a 0 0]
+ break
+ }
+ }
+ }
+ return $r
+ }
+
+ #########################################################################
+ # Local procedures to write an entry
+ #########################################################################
+
+ proc WriteLine {selfns attr val} {
+
+ if {[string is ascii $val] && [string is print $val]} then {
+ set sep ":"
+ } else {
+ set sep "::"
+ set val [$translator encode $attr $val]
+ set val [::base64::encode $val]
+ }
+
+ set first 1
+ foreach line [split $val "\n"] {
+ if {$first} then {
+ puts $channel "$attr$sep $line"
+ set first 0
+ } else {
+ puts $channel " $line"
+ }
+ }
+ }
+}
diff --git a/tcllib/modules/ldap/ldapx.test b/tcllib/modules/ldap/ldapx.test
new file mode 100644
index 0000000..cfdfd30
--- /dev/null
+++ b/tcllib/modules/ldap/ldapx.test
@@ -0,0 +1,375 @@
+# -*- tcl -*-
+# ldapx.test: tests for the ldapx module.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2006 by Pierre David <pdav@users.sourceforge.net>
+# All rights reserved.
+#
+# $Id: ldapx.test,v 1.6 2007/08/19 20:20:43 pdav Exp $
+
+# -------------------------------------------------------------------------
+
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 1.0
+
+testing {
+ useLocal ldapx.tcl ldapx
+}
+
+# -------------------------------------------------------------------------
+
+set rdn1 "uid=test"
+set rdn2 "uid=test2"
+set sup1 "ou=mydept,o=myorg"
+set sup2 "ou=x,$sup1"
+
+set entry {a1 {v11 v12} a2 {v21} a3 {v31 v32 v33}}
+
+# -------------------------------------------------------------------------
+
+test ldapx-1.0 {ldapx::entry - creation} {
+ ::ldapx::entry create t1
+} {::t1}
+
+test ldapx-1.1 {ldapx::entry - reset} {
+ t1 reset
+ t1 format
+} {uninitialized}
+
+test ldapx-1.2 {ldapx::entry - dn} {
+ t1 dn "$rdn1,$sup1"
+ t1 dn
+} "$rdn1,$sup1"
+
+test ldapx-1.3 {ldapx::entry - superior} {
+ t1 dn "$rdn1,$sup1"
+ t1 superior
+} $sup1
+
+test ldapx-1.4 {ldapx::entry - rdn} {
+ t1 rdn
+} $rdn1
+
+test ldapx-1.5 {ldapx::entry - print uninitialized} {
+ t1 print
+} "dn: $rdn1,$sup1"
+
+test ldapx-2.1 {ldapx::entry - standard} {
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t1 setall $entry
+ lsort [t1 getall]
+} [lsort $entry]
+
+test ldapx-2.2 {ldapx::entry - isempty} {
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t1 setall $entry
+ set e1 [t1 isempty]
+ ::ldapx::entry create t2
+ set e2 [t2 isempty]
+ t2 destroy
+ list $e1 $e2
+} {0 1}
+
+test ldapx-2.3 {ldapx::entry - set1/get1} {
+ t1 set1 A4 v41
+ t1 get1 A4
+} {v41}
+
+test ldapx-2.4 {ldapx::entry - add1} {
+ t1 add1 a4 {v 42}
+ t1 get A4
+} {v41 {v 42}}
+
+test ldapx-2.5 {ldapx::entry - set/add/get} {
+ t1 set a5 {v51}
+ t1 add a5 {{v 52} {v 53}}
+ t1 get a5
+} {v51 {v 52} {v 53}}
+
+test ldapx-2.6 {ldapx::entry - del1/del} {
+ t1 del1 A5 {v 52}
+ t1 del a5 {{v 53}}
+ t1 get a5
+} {v51}
+
+test ldapx-2.7 {ldapx::entry - del} {
+ t1 del A5
+ t1 get a5
+} {}
+
+test ldapx-2.8 {ldapx::entry - getattr} {
+ lsort [t1 getattr]
+} {a1 a2 a3 a4}
+
+
+test ldapx-3.1 {ldapx::entry - backup toanother} {
+ ::ldapx::entry create t2
+ ::ldapx::entry create t3
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t1 setall $entry
+ t1 backup t2
+ t3 diff t1 t2
+ t3 change
+} {}
+
+test ldapx-3.2 {ldapx::entry - diff toanother modrdn uid deleteoldrdn} {
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t1 setall $entry
+ t1 set1 "uid" "test"
+ t1 backup t2
+ t1 dn "$rdn2,$sup1"
+ t1 set1 "uid" "test2"
+ t3 diff t1 t2
+ t3 change
+} [list [list modrdn $rdn2 1]]
+
+test ldapx-3.3 {ldapx::entry - diff toanother modrdn uid keepoldrdn} {
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t1 setall $entry
+ t1 set1 "uid" "test"
+ t1 backup t2
+ t1 dn "$rdn2,$sup1"
+ t1 add1 "uid" "test2"
+ t3 diff t1 t2
+ t3 change
+} [list [list modrdn $rdn2 0]]
+
+test ldapx-3.4 {ldapx::entry - diff toanother modrdn superior} {
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t1 setall $entry
+ t1 backup t2
+ t1 dn "$rdn1,$sup2"
+ t3 diff t1 t2
+ t3 change
+} [list [list modrdn $rdn1 0 $sup2]]
+
+test ldapx-3.5 {ldapx::entry - diff toanother add attr} {
+ t1 reset
+ t1 setall $entry
+ t1 backup t2
+ t1 set anotherAttribute {v1 v2}
+ t3 diff t1 t2
+ t3 change
+} {{mod {{modadd anotherattribute {v1 v2}}}}}
+
+test ldapx-3.6 {ldapx::entry - diff toanother repl attr} {
+ t1 reset
+ t1 setall $entry
+ t1 backup t2
+ t1 del1 a3 v32
+ t3 diff t1 t2
+ t3 change
+} {{mod {{modrepl a3 {v31 v33}}}}}
+
+test ldapx-3.7 {ldapx::entry - diff toanother add value} {
+ t1 reset
+ t1 setall $entry
+ t1 backup t2
+ t1 add1 a3 v34
+ t3 diff t1 t2
+ t3 change
+} {{mod {{modrepl a3 {v31 v32 v33 v34}}}}}
+
+test ldapx-3.8 {ldapx::entry - diff toanother del attr} {
+ t1 reset
+ t1 setall $entry
+ t1 backup t2
+ t1 del A3
+ t3 diff t1 t2
+ t3 change
+} {{mod {{moddel a3}}}}
+
+test ldapx-3.9 {ldapx::entry - diff toanother del entry 1} {
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t1 setall $entry
+ t1 backup t2
+ t1 setall {}
+ t3 diff t1 t2
+ list [t3 dn] [lindex [t3 change] 0 0]
+} [list "$rdn1,$sup1" del]
+
+test ldapx-3.10 {ldapx::entry - diff toanother del entry 2} {
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t1 setall $entry
+ t1 backup t2
+ t1 dn ""
+ t1 setall {}
+ t3 diff t1 t2
+ list [t3 dn] [lindex [t3 change] 0 0]
+} [list "$rdn1,$sup1" del]
+
+test ldapx-3.11 {ldapx::entry - diff toanother add entry} {
+ t1 reset
+ t1 setall {}
+ t1 backup t2
+ t1 setall $entry
+ t3 diff t1 t2
+ lsort [list [lindex [t3 change] 0 0] \
+ [lsort [lindex [t3 change] 0 1]]]
+} [lsort [list add [lsort [string tolower $entry]]]]
+
+test ldapx-3.12 {ldapx::entry - diff toanother add entry dn 1} {
+ t1 reset
+ t1 backup t2
+ t1 dn "$rdn1,$sup1"
+ t1 setall $entry
+ t3 diff t1 t2
+ list [t3 dn] [lindex [t3 change] 0 0]
+} [list "$rdn1,$sup1" add]
+
+test ldapx-3.13 {ldapx::entry - diff toanother add entry dn 2} {
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t1 backup t2
+ t1 setall $entry
+ t3 diff t1 t2
+ list [t3 dn] [lindex [t3 change] 0 0]
+} [list "$rdn1,$sup1" add]
+
+
+test ldapx-3.14 {ldapx::entry - diff tothesame} {
+ t1 reset
+ t1 setall $entry
+ t1 backup
+ t1 set1 A3 v34
+ t3 diff t1
+ t3 change
+} {{mod {{modrepl a3 v34}}}}
+
+test ldapx-3.15 {ldapx::entry - restore toanother} {
+ t1 reset
+ t1 setall {a v}
+ t1 backup
+ t1 restore t2
+ t2 getall
+} {a v}
+
+test ldapx-3.16 {ldapx::entry - restore tothesame} {
+ t1 reset
+ t1 setall {a v}
+ t1 backup
+ t1 setall $entry
+ t1 restore
+ t1 getall
+} {a v}
+
+test ldapx-3.17 {ldapx::entry - swap} {
+ t1 reset
+ t1 setall {a v}
+ t1 dn d1
+ t1 backup
+ t1 setall {b w}
+ t1 dn d2
+ t1 swap
+ set l1 [list [t1 dn] [t1 getall]]
+ t1 swap
+ set l2 [list [t1 dn] [t1 getall]]
+ list $l1 $l2
+} {{d1 {a v}} {d2 {b w}}}
+
+test ldapx-3.18 {ldapx::entry - apply modrdn rdn} {
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t2 reset
+ t2 dn "$rdn1,$sup1"
+ t2 change [list [list modrdn $rdn2 0]]
+ t1 apply t2
+ t1 dn
+} "$rdn2,$sup1"
+
+test ldapx-3.19 {ldapx::entry - apply modrdn superior} {
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t2 reset
+ t2 dn "$rdn1,$sup1"
+ t2 change [list [list modrdn $rdn1 0 $sup2]]
+ t1 apply t2
+ t1 dn
+} "$rdn1,$sup2"
+
+test ldapx-3.20 {ldapx::entry - apply modrdn rdn+superior} {
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t2 reset
+ t2 dn "$rdn1,$sup1"
+ t2 change [list [list modrdn $rdn2 0 $sup2]]
+ t1 apply t2
+ t1 dn
+} "$rdn2,$sup2"
+
+test ldapx-3.21 {ldapx::entry - apply add} {
+ t1 reset
+ t2 reset
+ t2 dn "$rdn1,$sup1"
+ t2 change [list [list add $entry]]
+ t1 apply t2
+ lsort [t1 getall]
+} [lsort $entry]
+
+test ldapx-3.22 {ldapx::entry - apply del} {
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t1 setall $entry
+ t2 reset
+ t2 dn "$rdn1,$sup1"
+ t2 change {{del}}
+ t1 apply t2
+ lsort [t1 getall]
+} {}
+
+test ldapx-3.23 {ldapx::entry - apply mod add} {
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t1 setall $entry
+ t2 reset
+ t2 dn "$rdn1,$sup1"
+ t2 change {{mod {{modadd A4 {v41 v42}}}}}
+ t1 apply t2
+ t1 get a4
+} {v41 v42}
+
+test ldapx-3.24 {ldapx::entry - apply mod del} {
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t1 setall $entry
+ t2 reset
+ t2 dn "$rdn1,$sup1"
+ t2 change {{mod {{moddel A3}}}}
+ t1 apply t2
+ t1 get a3
+} {}
+
+test ldapx-3.25 {ldapx::entry - apply mod repl} {
+ t1 reset
+ t1 dn "$rdn1,$sup1"
+ t1 setall $entry
+ t2 reset
+ t2 dn "$rdn1,$sup1"
+ t2 change {{mod {{modrepl A3 {v34 v35}}}}}
+ t1 apply t2
+ t1 get a3
+} {v34 v35}
+
+test ldapx-4.1 {ldapx::entry - deletion} {
+ t1 destroy
+ t2 destroy
+ t3 destroy
+} {}
+
+
+testsuiteCleanup
diff --git a/tcllib/modules/ldap/pkgIndex.tcl b/tcllib/modules/ldap/pkgIndex.tcl
new file mode 100644
index 0000000..29c1b46
--- /dev/null
+++ b/tcllib/modules/ldap/pkgIndex.tcl
@@ -0,0 +1,7 @@
+# Tcl package index file, version 1.1
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded ldap 1.8 [list source [file join $dir ldap.tcl]]
+
+# the OO level wrapper for ldap
+package ifneeded ldapx 1.0 [list source [file join $dir ldapx.tcl]]
diff --git a/tcllib/modules/log/ChangeLog b/tcllib/modules/log/ChangeLog
new file mode 100644
index 0000000..3d52d10
--- /dev/null
+++ b/tcllib/modules/log/ChangeLog
@@ -0,0 +1,526 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2012-07-09 Andreas Kupries <aku@hephaistos>
+
+ * logger.tcl: [Bug 3541628]: Fixed creative writing issue in
+ * logger.man: logger::init. Bumped package to version 0.9.3
+ * pkgIndex.tcl: Whitespace cleanup in places.
+
+2011-12-20 Michael Schlenker <mic42@users.sourceforge.net>
+
+ Fix for [Bug 3463420]. The default loglevel was not
+ being inherited. Increased version to 0.9.2.
+ * logger.tcl:
+ * logger.test:
+ * pkgIndex.tcl:
+
+2011-12-20 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.man: Fix for [Bug 3462341].
+ * logger.tcl: The use of empty servicenames is not allowed.
+ * logger.test: The use of a name of only : is also forbidden.
+ * pkgIndex.tcl:
+
+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 ========================
+ *
+
+2009-10-27 Andreas Kupries <andreask@activestate.com>
+
+ * log.man: Flush writes to the log channel. Bumped to
+ * log.tcl: version 1.3.
+ * pkgIndex.tcl:
+
+2008-12-22 Andreas Kupries <andreask@activestate.com>
+
+ * log.man: Extended documentation a bit to tell about the levels
+ * log.tcl: which are suppressed by default. Added comment to code
+ to point from the first initialization to the second at the
+ bottom of the file. Fixes [Bug 2418580].
+
+2008-12-17 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.tcl: Applied modified patch [RFE 2381524].
+ * logger.test: Thanks to Hemang Lavana for the patch.
+ * pkgIndex.tcl: Added -errorcode arguments and msgcat::mc
+ calls to all error messages, so this could be localized.
+ Bumped version to 0.9.
+ Proc bodies are now constructed via format instead of
+ all the quoting hell.
+
+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 ========================
+ *
+
+2008-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * log.tcl: Bumped version to 1.2.1 for commit on
+ * log.man: 2008-09-25 by eee. API change, needs at
+ * pkgIndex.tcl: least a patchlevel bump.
+
+2008-09-25 Elchonon Edelson <eee@users.sourceforge.net>
+
+ * log.tcl: Changed the error message returned by the log::log
+ * log.test: function. Instead of saying ""foo" is no unique
+ abbreviation of a level name", it now gives a reasonable
+ error message that lists the valid levels.
+
+2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * log.pcx: New file. Syntax definitions for the public commands of
+ the log package.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-03-26 Andreas Kupries <andreask@activestate.com>
+
+ * loggerUtils.man: Uh, the section was put into the list instead
+ * loggerAppender.man: of after. Fixed. [Bug 1688650].
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * log.man: Fixed all warnings due to use of now deprecated
+ * logger.man: commands. Added a section about how to give
+ * loggerUtils.man: feedback.
+ * loggerAppender.man:
+
+2007-03-20 Andreas Kupries <andreask@activestate.com>
+
+ * loggerUtils.tcl: Added MD pragmas regarding ownership of the
+ message files.
+
+2007-02-08 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.tcl: Accepted patch for [SF Tcllib 1599978],
+ * logger.man: adding emergency and alert levels to the logger
+ * pkgIndex.tcl: package. Raising package version to 0.8,
+ even if it is just a rather minor change. But there is a
+
+ **** POTENTIAL INCOMPATIBILITY ****
+ If code uses explicitly 'criticalr' to disable all available loggers
+ instead of looking at the highest level in logger::levels, this
+ no longer disables all log messages.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * logger.test: Moved the tests of the new trace facility to a
+ * logger_trace.test: separate file, as they require a newer
+ version of tcltest (2.x), and Tcl 8.4 instead of 8.2.
+
+2006-08-18 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.tcl: Applied patch [SF Tcllib 1530725] to
+ * logger.man: add a command trace logging facility to
+ * logger.test: logger. This raises the package version
+ * pkgIndex.tcl: to 0.7.
+ * loggerUtils.tcl: Fixed abbreviated subcommands to use
+ * loggerAppender.tcl: the full form.
+
+2006-04-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * logger.tcl: Added a convenience command to fully initialize
+ * logger.man: a namespace for logging (create service, import
+ * pkgIndex.tcl: commands, set default logging level)
+
+2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * log.test: Fixed cleanup of temp. files used by testsuite.
+ * logger.test: Fixed usage of duplicate test names.
+
+2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * log.test: More boilerplate simplified via use of test support.
+ * logger.test:
+ * loggerUtils.test:
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * loggerUtils.tcl: The utilities require Tcl 8.4, they use
+ * loggerUtils.man: 'trace'-APIs not yet present before 8.4.
+ * pkgIndex.tcl:
+
+ * log.test: Hooked into the new common test support code.
+ * logger.test:
+ * loggerUtils.test:
+
+2005-12-02 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.tcl: Fixed bug [SF Tcllib 1329642]. There
+ * logger.man: is now a new global enabled state.
+ * logger.test: This needed a fix to the loggerUtils
+ * pkgIndex.tcl: testsuit, to set a working default log
+ loggerUtils.test: level (debug instead of critical).
+
+ **** Potential Incompatibility ****
+ New top level logger instances now start with the loglevel set
+ by logger::setlevel instead of debug. The default is still
+ set to debug.
+
+2005-11-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * loggerAppender.man: Fixed small typo in the appender
+ documentation, a reference to the wrong package.
+
+2005-10-11 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * loggerUtils.tcl: Avoid use of %G in time formats. (not
+ widely supported in C libraries)
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-09-28 Andreas Kupries <andreask@activestate.com>
+
+ * loggerAppender.tcl: Integrated the formatter/appender utilities
+ * loggerAppender.man: provided by [SF Tcllib 1267636]. Created
+ * loggerUtils.tcl: doctools based documentation. Fixed mis-
+ * loggerUtils.man: spellings. Moved the utility code into
+ * loggerUtils.test: the namespace "logger::utils". Added the
+ * pkgIndex.tcl: new packages to the package index.
+
+2005-09-23 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.man : Added section about logprocs and their effect
+ on the callstack, including a small example.
+
+2005-05-07 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.tcl :
+ logger.test :
+ pkgIndex.tcl: Added more tests to the new lvlchangeproc and
+ provided a sane default to the no-op proc to fix a bug reported
+ by Hemang Lavana. Callbacks are now checked to exist before they
+ are allowed or used. Added tests for these checks.
+ Raised package version to 0.6.1.
+
+2005-04-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: Synchronized indexed vs. provided versions of
+ logger.
+
+2005-03-04 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.test :
+ logger.tcl :
+ logger.man : Added a test (13.7) for a small glitch in the
+ fix for bug [1102131]. logprocs could be called with
+ too many arguments. Added new lvlchangeproc callback command
+ including tests and docs.
+
+2005-02-18 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.test : Added tests for the clean callstack (14.x)
+ to satisfy RFE 1120152. logger should not appear in the
+ callstacks of the logprocs from now on.
+
+2005-02-09 Michael Schlenker <mic42@users.sourceforge.net>
+ * logger.tcl : Added fix for sideeffect of bugfix [1102131].
+ The callstack for a logproc now looks nice again.
+
+2005-01-31 Michael Schlenker <mic42@users.sourceforge.net>
+ * logger.test : Added tests for bug [1102131].
+ The logger servicename can not be detected correctly.
+ logger.tcl : Fix for bug [1102131]. There is
+ still no way for a proc given to logproc to discover
+ the servicename, that requires an extension to the
+ logproc API (extra argument).
+ See the 13.x tests for an example how to get the
+ servicename with the help of the old logproc syntax.
+
+2005-01-12 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.tcl : Fixed bug [1099722]. New children did
+ logger.test: not inherit their parents loglevel if
+ it was set prior to their creation. Added a new test 5.2
+ for this case. Raised package version to 0.5.1.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-10-04 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.tcl : Added more tests for logger::import,
+ logger.test: minor fixes to error messages.
+
+2004-09-23 Andreas Kupries <andreask@activestate.com>
+
+ * logger.tcl (logger::import): Fixed malformed return value,
+ premature end of the string due to unquoted ".
+
+ * logger.tcl: A small fix in the new command [nsExists] for Tcl
+ 8.[23]. The condition was revers.
+
+2004-09-23 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.tcl : Added a workaround for non-existing
+ namespace exists in logger::import, so we can
+ stay at Tcl 8.2.
+
+2004-09-13 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.tcl : Changed defaults for logger::import,
+ logger.man : added a -force option and some more tests
+ logger.test:
+
+2004-09-13 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.tcl : Implemented and doc'ed new global logger::setlevel
+ logger.man :
+
+2004-09-06 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.tcl : Implemented and doc'ed new logger::import feature.
+ logger.man : Needs more tests.
+ logger.test:
+
+2004-09-06 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.tcl: Removed hardcoded level names in logger::init.
+
+2004-06-18 Andreas Kupries <andreask@activestate.com>
+
+ * log.man: Fixed bad formatting in documentation of 'logarray'.
+
+2004-06-04 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.tcl : Changed error handling from ::error to
+ logger.test: return -code error. Added more tests and
+ argument checking to make the code more robust.
+
+2004-05-26 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.tcl: Fixed bug with enable/disable
+ wrong enabled value was reported if disable critical was used.
+ Added "none" as result for currentloglevel for this situation.
+ * logger.test: Added tests 7.1-7.4 to check for the above bug.
+ * logger.man: Fixed docs and replaced the nonsensical "or" with
+ the correct "and" in enable/disable docs. Added a comment how
+ to completely disable logging for a service and its children.
+
+2004-05-25 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * logger.tcl: Fixed bug [948273] in ::logger::services
+ Fixed cleanup of services list in delproc
+ Implemented doc'ed but missing ${log}::services subcommand
+ Fixed misuse of set inside namespace eval to prevent
+ overwriting of global variables
+ Added new subcommands servicecmd and servicename
+ for introspection
+ Added introspection to logproc and delproc
+ Version number changed to 0.4
+ * pkgIndex.tcl: updated version number of logger package
+ * logger.man: updated docs for ${log}::services,
+ ${log}::delproc and ${log}::logproc.
+ Added docs for servicecmd and servicename.
+ * logger.test: Added tests for new features and fixed bugs
+
+2004-05-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * log.tcl: New command 'loghex' for logging of binary data.
+ * log.man: Documented the new 'loghex', and 'logarray'.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * log.tcl: Updated version number to sync with 1.6.1
+ * log.man: release.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * log.tcl: Rel. engineering. Updated version number
+ * log.man: of log to reflect its changes, to 1.1.1.
+ * pkgIndex.tcl:
+
+2004-03-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * log.tcl: Added initialization code to suppress the lower levels
+ (warning notice info debug) from generating output. In other
+ words, by default only statements with messages of level error
+ or higher will generate output when the package is loaded.
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * logger.man: Brought the version numbers back into sync
+ * pkgIndex.tcl: with 'logger.tcl'
+
+2004-02-13 David N. Welton <davidw@dedasys.com>
+
+ * logger.test: Added tests from Schlenker regarding new commands.
+
+ * logger.tcl (logproc): Better error message, bugfix for new code
+ from Schlenker.
+
+ * logger.man: Added documentation for new logger commands.
+
+2004-01-19 David N. Welton <davidw@dedasys.com>
+
+ * logger.tcl (currentloglevel): Added proc from Michael Schlenker
+ to get information about the current log level for a given
+ service.
+ (logproc): Make logproc optionally take a command as an argument.
+ From Michael Schlenker.
+ (::logger::levels): New proc - returns the available log levels.
+ From Michael Schlenker.
+
+2003-12-18 David N. Welton <davidw@dedasys.com>
+
+ * logger.man: Document changes to logger API.
+
+2003-12-16 David N. Welton <davidw@dedasys.com>
+
+ * logger.test (2.1): Test deletion callbacks.
+ (2.2): Test deletion callbacks.
+
+ * logger.tcl: Bump logger version number because of API change.
+ (::logger::walk): Do eval after walk on children.
+ (delproc): New procedure to set a deletion-time callback that is
+ called for each of the instance's children. Thanks to Michael
+ Schlenker for the suggestion [ 856280 ].
+
+2003-11-25 Andreas Kupries <andreask@activestate.com>
+
+ * log.tcl (log::log): Added better handling of multiple lines in log message.
+ (log::logarray): New command to dump the contents of an array into the log.
+
+2003-06-25 David N. Welton <davidw@dedasys.com>
+
+ * log.man: Fixed spelling bug (Supress -> Suppress), thanks to
+ Aaron Faupell.
+
+ * logger.man: Updated documentation example - destroy should have
+ been delete. Thanks to Aaron Faupell.
+
+2003-05-20 David N. Welton <davidw@dedasys.com>
+
+ * logger.test: Added test for setlevel command.
+
+ * logger.man: Document setlevel command in the 'man' page.
+
+ * logger.tcl (setlevel): New command that takes care of enabling
+ all levels above that specified, and disabling all those below
+ it.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-21 Andreas Kupries <andreask@activestate.com>
+
+ * loggerperformance.test: Renaming to 'loggerperformance'. This is
+ neither a .tcl file of the package itself, nor does it belong
+ into the testsuite (which is about functionality, not speed). It
+ is a benchmark application.
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * log.man:
+ * log.tcl:
+ * pkgIndex.tcl: Set version of the package 'log' to to 1.0.2.
+
+ * logger.tcl: Fixed bug #614591.
+
+2003-02-25 David N. Welton <davidw@dedasys.com>
+
+ * logger.tcl: Require Tcl 8.2 - we use string map.
+
+2003-01-30 David N. Welton <davidw@dedasys.com>
+
+ * loggerperformance.test: Changed file name so as to avoid
+ problems with autoindexer.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * logger.man: More semantic markup, less visual one.
+ * log.man:
+
+2002-12-16 David N. Welton <davidw@dedasys.com>
+
+ * logger.test: Logger tests.
+
+ * loggerperformance.tcl : Logger performance testing.
+
+ * logger.man : Logger documentation.
+
+ * logger.tcl: Initial commit of logger package.
+
+2002-02-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * log.n:
+ * log.man: Rewrote the introduction to the module for better
+ understanding by novices. Added examples to highlight use cases
+ from the simplest to more complex ones.
+
+2002-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Version up to 1.0.1 to differentiate development from the
+ version in the tcllib 1.2 release.
+
+ * log.tcl:
+ * log.test: Updated code and tests to cover all paths through the
+ code.
+
+2001-09-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * log.tcl: Restricted export list to public API.
+ [456255]. Patch by Hemang Lavana
+ <hemanglavana@users.sourceforge.net>
+
+2001-03-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module 'log', a logging facility.
diff --git a/tcllib/modules/log/log.man b/tcllib/modules/log/log.man
new file mode 100644
index 0000000..f30074c
--- /dev/null
+++ b/tcllib/modules/log/log.man
@@ -0,0 +1,277 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin log n 1.3]
+[keywords log]
+[keywords {log level}]
+[keywords message]
+[keywords {message level}]
+[copyright {2001-2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Logging facility}]
+[titledesc {Procedures to log messages of libraries and applications.}]
+[category {Programming tools}]
+[require Tcl 8]
+[require log [opt 1.3]]
+[description]
+
+[para]
+
+The [package log] package provides commands that allow libraries and
+applications to selectively log information about their internal
+operation and state.
+
+[para]
+
+To use the package just execute
+[para]
+
+[example {
+ package require log
+ log::log notice "Some message"
+}]
+[para]
+
+As can be seen above, each message given to the log facility is
+associated with a [emph level] determining the importance of the
+message. The user can then select which levels to log, what commands
+to use for the logging of each level and the channel to write the
+message to. In the following example the logging of all message with
+level [const debug] is deactivated.
+
+[para]
+
+[example {
+ package require log
+ log::lvSuppress debug
+ log::log debug "Unseen message" ; # No output
+}]
+[para]
+
+By default all messages associated with an error-level
+
+([const emergency], [const alert], [const critical], and
+
+[const error]) are written to [const stderr]. Messages with any
+other level are written to [const stdout]. In the following example
+the log module is reconfigured to write [const debug] messages to
+[const stderr] too.
+
+[para]
+
+[example {
+ package require log
+ log::lvChannel debug stderr
+ log::log debug "Written to stderr"
+}]
+
+[para]
+
+Each message level is also associated with a command to use when
+logging a message with that level. The behaviour above for example
+relies on the fact that all message levels use by default the standard
+command [cmd ::log::Puts] to log any message. In the following example
+all messages of level [const notice] are given to the non-standard
+command [cmd toText] for logging. This disables the channel setting
+for such messages, assuming that [cmd toText] does not use it by
+itself.
+
+[para]
+
+[example {
+ package require log
+ log::lvCmd notice toText
+ log::log notice "Handled by \"toText\""
+}]
+
+[para]
+
+Another database maintained by this facility is a map from message
+levels to colors. The information in this database has [emph no]
+influence on the behaviour of the module. It is merely provided as a
+convenience and in anticipation of the usage of this facility in
+[package tk]-based application which may want to colorize message
+logs.
+
+[section API]
+
+[para]
+
+The following commands are available:
+
+[list_begin definitions]
+
+[call [cmd ::log::levels]]
+
+Returns the names of all known levels, in alphabetical order.
+
+[call [cmd ::log::lv2longform] [arg level]]
+
+Converts any unique abbreviation of a level name to the full level
+name.
+
+[call [cmd ::log::lv2color] [arg level]]
+
+Converts any level name including unique abbreviations to the
+corresponding color.
+
+[call [cmd ::log::lv2priority] [arg level]]
+
+Converts any level name including unique abbreviations to the
+corresponding priority.
+
+[call [cmd ::log::lv2cmd] [arg level]]
+
+Converts any level name including unique abbreviations to the command
+prefix used to write messages with that level.
+
+[call [cmd ::log::lv2channel] [arg level]]
+
+Converts any level name including unique abbreviations to the channel
+used by [cmd ::log::Puts] to write messages with that level.
+
+[call [cmd ::log::lvCompare] [arg level1] [arg level2]]
+
+Compares two levels (including unique abbreviations) with respect to
+their priority. This command can be used by the -command option of
+lsort. The result is one of -1, 0 or 1 or an error. A result of -1
+signals that level1 is of less priority than level2. 0 signals that
+both levels have the same priority. 1 signals that level1 has higher
+priority than level2.
+
+[call [cmd ::log::lvSuppress] [arg level] "{[arg suppress] 1}"]]
+
+(Un)suppresses the output of messages having the specified
+level. Unique abbreviations for the level are allowed here too.
+
+[call [cmd ::log::lvSuppressLE] [arg level] "{[arg suppress] 1}"]]
+
+(Un)suppresses the output of messages having the specified level or
+one of lesser priority. Unique abbreviations for the level are allowed
+here too.
+
+[call [cmd ::log::lvIsSuppressed] [arg level]]
+
+Asks the package whether the specified level is currently
+suppressed. Unique abbreviations of level names are allowed.
+
+[call [cmd ::log::lvCmd] [arg level] [arg cmd]]
+
+Defines for the specified level with which command to write the
+messages having this level. Unique abbreviations of level names are
+allowed. The command is actually a command prefix and this facility
+will append 2 arguments before calling it, the level of the message
+and the message itself, in this order.
+
+[call [cmd ::log::lvCmdForall] [arg cmd]]
+
+Defines for all known levels with which command to write the messages
+having this level. The command is actually a command prefix and this
+facility will append 2 arguments before calling it, the level of the
+message and the message itself, in this order.
+
+[call [cmd ::log::lvChannel] [arg level] [arg chan]]
+
+Defines for the specified level into which channel [cmd ::log::Puts]
+(the standard command) shall write the messages having this
+level. Unique abbreviations of level names are allowed. The command is
+actually a command prefix and this facility will append 2 arguments
+before calling it, the level of the message and the message itself, in
+this order.
+
+[call [cmd ::log::lvChannelForall] [arg chan]]
+
+Defines for all known levels with which which channel
+[cmd ::log::Puts] (the standard command) shall write the messages
+having this level. The command is actually a command prefix and this
+facility will append 2 arguments before calling it, the level of the
+message and the message itself, in this order.
+
+[call [cmd ::log::lvColor] [arg level] [arg color]]
+
+Defines for the specified level the color to return for it in a call
+to [cmd ::log::lv2color]. Unique abbreviations of level names are
+allowed.
+
+[call [cmd ::log::lvColorForall] [arg color]]
+
+Defines for all known levels the color to return for it in a call to
+[cmd ::log::lv2color]. Unique abbreviations of level names are
+allowed.
+
+[call [cmd ::log::log] [arg level] [arg text]]
+
+Log a message according to the specifications for commands, channels
+and suppression. In other words: The command will do nothing if the
+specified level is suppressed. If it is not suppressed the actual
+logging is delegated to the specified command. If there is no command
+specified for the level the message won't be logged. The standard
+command [cmd ::log::Puts] will write the message to the channel
+specified for the given level. If no channel is specified for the
+level the message won't be logged. Unique abbreviations of level names
+are allowed. Errors in the actual logging command are [emph not]
+caught, but propagated to the caller, as they may indicate
+misconfigurations of the log facility or errors in the callers code
+itself.
+
+[call [cmd ::log::logarray] [arg level] [arg arrayvar] [opt [arg pattern]]]
+
+Like [cmd ::log::log], but logs the contents of the specified array
+variable [arg arrayvar], possibly restricted to entries matching the
+[arg pattern]. The pattern defaults to [const *] (i.e. all entries) if
+none was specified.
+
+[call [cmd ::log::loghex] [arg level] [arg text] [arg data]]
+
+Like [cmd ::log::log], but assumes that [arg data] contains binary
+data. It converts this into a mixed hex/ascii representation before
+writing them to the log.
+
+[call [cmd ::log::logMsg] [arg text]]
+
+Convenience wrapper around [cmd ::log::log].
+Equivalent to [cmd "::log::log info text"].
+
+[call [cmd ::log::logError] [arg text]]
+
+Convenience wrapper around [cmd ::log::log].
+Equivalent to [cmd "::log::log error text"].
+
+[call [cmd ::log::Puts] [arg level] [arg text]]
+
+The standard log command, it writes messages and their levels to
+user-specified channels. Assumes that the suppression checks were done
+by the caller. Expects full level names, abbreviations are
+[emph {not allowed}].
+
+[list_end]
+
+[section LEVELS]
+
+The package currently defines the following log levels, the level of
+highest importance listed first.
+
+[list_begin itemized]
+[item]
+emergency
+[item]
+alert
+[item]
+critical
+[item]
+error
+[item]
+warning
+[item]
+notice
+[item]
+info
+[item]
+debug
+[list_end]
+
+[emph Note] that by default all messages with levels [const warning] down to
+[const debug] are suppressed. This is done intentionally, because (we believe
+that) in most situations debugging output is not wanted. Most people wish to
+have such output only when actually debugging an application.
+
+[vset CATEGORY log]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/log/log.pcx b/tcllib/modules/log/log.pcx
new file mode 100644
index 0000000..9979223
--- /dev/null
+++ b/tcllib/modules/log/log.pcx
@@ -0,0 +1,122 @@
+# -*- tcl -*- log.pcx
+# Syntax of the commands provided by package log.
+
+# For use by TclDevKit's static syntax checker.
+# 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 documentation describing the format of the code contained in this file
+#
+
+package require pcx
+pcx::register log
+pcx::tcldep 1.2 needs tcl 8.2
+
+namespace eval ::log {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 1.2 std ::log::levels \
+ {checkSimpleArgs 0 0 {}}
+pcx::check 1.2 std ::log::log \
+ {checkSimpleArgs 2 2 {
+ log::checkLogLevel
+ checkWord
+ }}
+pcx::check 1.2 std ::log::logError \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 1.2 std ::log::logMsg \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 1.2 std ::log::logarray \
+ {checkSimpleArgs 2 3 {
+ log::checkLogLevel
+ checkVarNameRdAll
+ checkWord
+ }}
+pcx::check 1.2 std ::log::loghex \
+ {checkSimpleArgs 3 3 {
+ log::checkLogLevel
+ checkWord
+ checkWord
+ }}
+pcx::check 1.2 std ::log::lv2channel \
+ {checkSimpleArgs 1 1 {
+ log::checkLogLevel
+ }}
+pcx::check 1.2 std ::log::lv2cmd \
+ {checkSimpleArgs 1 1 {
+ log::checkLogLevel
+ }}
+pcx::check 1.2 std ::log::lv2color \
+ {checkSimpleArgs 1 1 {
+ log::checkLogLevel
+ }}
+pcx::check 1.2 std ::log::lv2longform \
+ {checkSimpleArgs 1 1 {
+ log::checkLogLevel
+ }}
+pcx::check 1.2 std ::log::lv2priority \
+ {checkSimpleArgs 1 1 {
+ log::checkLogLevel
+ }}
+pcx::check 1.2 std ::log::lvChannel \
+ {checkSimpleArgs 2 2 {
+ log::checkLogLevel
+ checkChannelID
+ }}
+pcx::check 1.2 std ::log::lvChannelForall \
+ {checkSimpleArgs 1 1 {
+ checkChannelID
+ }}
+pcx::check 1.2 std ::log::lvCmd \
+ {checkSimpleArgs 2 2 {
+ log::checkLogLevel
+ checkList
+ }}
+pcx::check 1.2 std ::log::lvCmdForall \
+ {checkSimpleArgs 1 1 {
+ checkList
+ }}
+pcx::check 1.2 std ::log::lvColor \
+ {checkSimpleArgs 2 2 {
+ log::checkLogLevel
+ checkWord
+ }}
+pcx::check 1.2 std ::log::lvColorForall \
+ {checkSimpleArgs 1 1 {
+ checkWord
+ }}
+pcx::check 1.2 std ::log::lvCompare \
+ {checkSimpleArgs 2 2 {
+ log::checkLogLevel
+ log::checkLogLevel
+ }}
+pcx::check 1.2 std ::log::lvIsSuppressed \
+ {checkSimpleArgs 1 1 {
+ log::checkLogLevel
+ }}
+pcx::check 1.2 std ::log::lvSuppress \
+ {checkSimpleArgs 1 2 {
+ log::checkLogLevel
+ checkBoolean
+ }}
+pcx::check 1.2 std ::log::lvSuppressLE \
+ {checkSimpleArgs 1 2 {
+ log::checkLogLevel
+ checkBoolean
+ }}
+
+# Initialization via pcx::init.
+# Use a ::log::init procedure for non-standard initialization.
+
+proc log::checkLogLevel {t i} {
+ return [checkKeyword 0 \
+ {emergency alert critical error warning notice info debug} \
+ $t $i]
+}
+
+pcx::complete
diff --git a/tcllib/modules/log/log.tcl b/tcllib/modules/log/log.tcl
new file mode 100644
index 0000000..3904cfb
--- /dev/null
+++ b/tcllib/modules/log/log.tcl
@@ -0,0 +1,855 @@
+# log.tcl --
+#
+# Tcl implementation of a general logging facility
+# (Reaped from Pool_Base and modified to fit into tcllib)
+#
+# Copyright (c) 2001 by ActiveState Tool Corp.
+# See the file license.terms.
+
+package require Tcl 8
+package provide log 1.3
+
+# ### ### ### ######### ######### #########
+
+namespace eval ::log {
+ namespace export levels lv2longform lv2color lv2priority
+ namespace export lv2cmd lv2channel lvCompare
+ namespace export lvSuppress lvSuppressLE lvIsSuppressed
+ namespace export lvCmd lvCmdForall
+ namespace export lvChannel lvChannelForall lvColor lvColorForall
+ namespace export log logMsg logError
+
+ # The known log-levels.
+
+ variable levels [list \
+ emergency \
+ alert \
+ critical \
+ error \
+ warning \
+ notice \
+ info \
+ debug]
+
+ # Array mapping from all unique prefixes for log levels to their
+ # corresponding long form.
+
+ # *future* Use a procedure from 'textutil' to calculate the
+ # prefixes and to fill the map.
+
+ variable levelMap
+ array set levelMap {
+ a alert
+ al alert
+ ale alert
+ aler alert
+ alert alert
+ c critical
+ cr critical
+ cri critical
+ crit critical
+ criti critical
+ critic critical
+ critica critical
+ critical critical
+ d debug
+ de debug
+ deb debug
+ debu debug
+ debug debug
+ em emergency
+ eme emergency
+ emer emergency
+ emerg emergency
+ emerge emergency
+ emergen emergency
+ emergenc emergency
+ emergency emergency
+ er error
+ err error
+ erro error
+ error error
+ i info
+ in info
+ inf info
+ info info
+ n notice
+ no notice
+ not notice
+ noti notice
+ notic notice
+ notice notice
+ w warning
+ wa warning
+ war warning
+ warn warning
+ warni warning
+ warnin warning
+ warning warning
+ }
+
+ # Map from log-levels to the commands to execute when a message
+ # with that level arrives in the system. The standard command for
+ # all levels is '::log::Puts' which writes the message to either
+ # stdout or stderr, depending on the level. The decision about the
+ # channel is stored in another map and modifiable by the user of
+ # the package.
+
+ variable cmdMap
+ array set cmdMap {}
+
+ variable lv
+ foreach lv $levels {set cmdMap($lv) ::log::Puts}
+ unset lv
+
+ # Map from log-levels to the channels ::log::Puts shall write
+ # messages with that level to. The map can be queried and changed
+ # by the user.
+
+ variable channelMap
+ array set channelMap {
+ emergency stderr
+ alert stderr
+ critical stderr
+ error stderr
+ warning stdout
+ notice stdout
+ info stdout
+ debug stdout
+ }
+
+ # Graphical user interfaces may want to colorize messages based
+ # upon their level. The following array stores a map from levels
+ # to colors. The map can be queried and changed by the user.
+
+ variable colorMap
+ array set colorMap {
+ emergency red
+ alert red
+ critical red
+ error red
+ warning yellow
+ notice seagreen
+ info {}
+ debug lightsteelblue
+ }
+
+ # To allow an easy comparison of the relative importance of a
+ # level the following array maps from levels to a numerical
+ # priority. The higher the number the more important the
+ # level. The user cannot change this map (for now). This package
+ # uses the priorities to allow the user to supress messages based
+ # upon their levels.
+
+ variable priorityMap
+ array set priorityMap {
+ emergency 7
+ alert 6
+ critical 5
+ error 4
+ warning 3
+ notice 2
+ info 1
+ debug 0
+ }
+
+ # The following array is internal and holds the information about
+ # which levels are suppressed, i.e. may not be written.
+ #
+ # 0 - messages with with level are written out.
+ # 1 - messages with this level are suppressed.
+
+ # Note: This initialization is partially overridden via
+ # 'log::lvSuppressLE' at the bottom of this file.
+
+ variable suppressed
+ array set suppressed {
+ emergency 0
+ alert 0
+ critical 0
+ error 0
+ warning 0
+ notice 0
+ info 0
+ debug 0
+ }
+
+ # Internal static information. Map from levels to a string of
+ # spaces. The number of spaces in each string is just enough to
+ # make all level names together with their string of the same
+ # length.
+
+ variable fill
+ array set fill {
+ emergency "" alert " " critical " " error " "
+ warning " " notice " " info " " debug " "
+ }
+}
+
+
+# log::levels --
+#
+# Retrieves the names of all known levels.
+#
+# Arguments:
+# None.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# A list containing the names of all known levels,
+# alphabetically sorted.
+
+proc ::log::levels {} {
+ variable levels
+ return [lsort $levels]
+}
+
+# log::lv2longform --
+#
+# Converts any unique abbreviation of a level name to the full
+# level name.
+#
+# Arguments:
+# level The prefix of a level name to convert.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# Returns the full name to the specified abbreviation or an
+# error.
+
+proc ::log::lv2longform {level} {
+ variable levelMap
+
+ if {[info exists levelMap($level)]} {
+ return $levelMap($level)
+ }
+
+ return -code error "bad level \"$level\": must be [join [lreplace [levels] end end "or [lindex [levels] end]"] ", "]."
+}
+
+# log::lv2color --
+#
+# Converts any level name including unique abbreviations to the
+# corresponding color.
+#
+# Arguments:
+# level The level to convert into a color.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# The name of a color or an error.
+
+proc ::log::lv2color {level} {
+ variable colorMap
+ set level [lv2longform $level]
+ return $colorMap($level)
+}
+
+# log::lv2priority --
+#
+# Converts any level name including unique abbreviations to the
+# corresponding priority.
+#
+# Arguments:
+# level The level to convert into a priority.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# The numerical priority of the level or an error.
+
+proc ::log::lv2priority {level} {
+ variable priorityMap
+ set level [lv2longform $level]
+ return $priorityMap($level)
+}
+
+# log::lv2cmd --
+#
+# Converts any level name including unique abbreviations to the
+# command prefix used to write messages with that level.
+#
+# Arguments:
+# level The level to convert into a command prefix.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# A string containing a command prefix or an error.
+
+proc ::log::lv2cmd {level} {
+ variable cmdMap
+ set level [lv2longform $level]
+ return $cmdMap($level)
+}
+
+# log::lv2channel --
+#
+# Converts any level name including unique abbreviations to the
+# channel used by ::log::Puts to write messages with that level.
+#
+# Arguments:
+# level The level to convert into a channel.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# A string containing a channel handle or an error.
+
+proc ::log::lv2channel {level} {
+ variable channelMap
+ set level [lv2longform $level]
+ return $channelMap($level)
+}
+
+# log::lvCompare --
+#
+# Compares two levels (including unique abbreviations) with
+# respect to their priority. This command can be used by the
+# -command option of lsort.
+#
+# Arguments:
+# level1 The first of the levels to compare.
+# level2 The second of the levels to compare.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# One of -1, 0 or 1 or an error. A result of -1 signals that
+# level1 is of less priority than level2. 0 signals that both
+# levels have the same priority. 1 signals that level1 has
+# higher priority than level2.
+
+proc ::log::lvCompare {level1 level2} {
+ variable priorityMap
+
+ set level1 $priorityMap([lv2longform $level1])
+ set level2 $priorityMap([lv2longform $level2])
+
+ if {$level1 < $level2} {
+ return -1
+ } elseif {$level1 > $level2} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# log::lvSuppress --
+#
+# (Un)suppresses the output of messages having the specified
+# level. Unique abbreviations for the level are allowed here
+# too.
+#
+# Arguments:
+# level The name of the level to suppress or
+# unsuppress. Unique abbreviations are allowed
+# too.
+# suppress Boolean flag. Optional. Defaults to the value
+# 1, which means to suppress the level. The
+# value 0 on the other hand unsuppresses the
+# level.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvSuppress {level {suppress 1}} {
+ variable suppressed
+ set level [lv2longform $level]
+
+ switch -exact -- $suppress {
+ 0 - 1 {} default {
+ return -code error "\"$suppress\" is not a member of \{0, 1\}"
+ }
+ }
+
+ set suppressed($level) $suppress
+ return
+}
+
+# log::lvSuppressLE --
+#
+# (Un)suppresses the output of messages having the specified
+# level or one of lesser priority. Unique abbreviations for the
+# level are allowed here too.
+#
+# Arguments:
+# level The name of the level to suppress or
+# unsuppress. Unique abbreviations are allowed
+# too.
+# suppress Boolean flag. Optional. Defaults to the value
+# 1, which means to suppress the specified
+# levels. The value 0 on the other hand
+# unsuppresses the levels.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvSuppressLE {level {suppress 1}} {
+ variable suppressed
+ variable levels
+ variable priorityMap
+
+ set level [lv2longform $level]
+
+ switch -exact -- $suppress {
+ 0 - 1 {} default {
+ return -code error "\"$suppress\" is not a member of \{0, 1\}"
+ }
+ }
+
+ set prio [lv2priority $level]
+
+ foreach l $levels {
+ if {$priorityMap($l) <= $prio} {
+ set suppressed($l) $suppress
+ }
+ }
+ return
+}
+
+# log::lvIsSuppressed --
+#
+# Asks the package wether the specified level is currently
+# suppressed. Unique abbreviations of level names are allowed.
+#
+# Arguments:
+# level The level to query.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# None.
+
+proc ::log::lvIsSuppressed {level} {
+ variable suppressed
+ set level [lv2longform $level]
+ return $suppressed($level)
+}
+
+# log::lvCmd --
+#
+# Defines for the specified level with which command to write
+# the messages having this level. Unique abbreviations of level
+# names are allowed. The command is actually a command prefix
+# and this facility will append 2 arguments before calling it,
+# the level of the message and the message itself, in this
+# order.
+#
+# Arguments:
+# level The level the command prefix is for.
+# cmd The command prefix to use for the specified level.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvCmd {level cmd} {
+ variable cmdMap
+ set level [lv2longform $level]
+ set cmdMap($level) $cmd
+ return
+}
+
+# log::lvCmdForall --
+#
+# Defines for all known levels with which command to write the
+# messages having this level. The command is actually a command
+# prefix and this facility will append 2 arguments before
+# calling it, the level of the message and the message itself,
+# in this order.
+#
+# Arguments:
+# cmd The command prefix to use for all levels.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvCmdForall {cmd} {
+ variable cmdMap
+ variable levels
+
+ foreach l $levels {
+ set cmdMap($l) $cmd
+ }
+ return
+}
+
+# log::lvChannel --
+#
+# Defines for the specified level into which channel ::log::Puts
+# (the standard command) shall write the messages having this
+# level. Unique abbreviations of level names are allowed. The
+# command is actually a command prefix and this facility will
+# append 2 arguments before calling it, the level of the message
+# and the message itself, in this order.
+#
+# Arguments:
+# level The level the channel is for.
+# chan The channel to use for the specified level.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvChannel {level chan} {
+ variable channelMap
+ set level [lv2longform $level]
+ set channelMap($level) $chan
+ return
+}
+
+# log::lvChannelForall --
+#
+# Defines for all known levels with which which channel
+# ::log::Puts (the standard command) shall write the messages
+# having this level. The command is actually a command prefix
+# and this facility will append 2 arguments before calling it,
+# the level of the message and the message itself, in this
+# order.
+#
+# Arguments:
+# chan The channel to use for all levels.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvChannelForall {chan} {
+ variable channelMap
+ variable levels
+
+ foreach l $levels {
+ set channelMap($l) $chan
+ }
+ return
+}
+
+# log::lvColor --
+#
+# Defines for the specified level the color to return for it in
+# a call to ::log::lv2color. Unique abbreviations of level names
+# are allowed.
+#
+# Arguments:
+# level The level the color is for.
+# color The color to use for the specified level.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvColor {level color} {
+ variable colorMap
+ set level [lv2longform $level]
+ set colorMap($level) $color
+ return
+}
+
+# log::lvColorForall --
+#
+# Defines for all known levels the color to return for it in a
+# call to ::log::lv2color. Unique abbreviations of level names
+# are allowed.
+#
+# Arguments:
+# color The color to use for all levels.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::lvColorForall {color} {
+ variable colorMap
+ variable levels
+
+ foreach l $levels {
+ set colorMap($l) $color
+ }
+ return
+}
+
+# log::logarray --
+#
+# Similar to parray, except that the contents of the array
+# printed out through the log system instead of directly
+# to stdout.
+#
+# See also 'log::log' for a general explanation
+#
+# Arguments:
+# level The level of the message.
+# arrayvar The name of the array varaibe to dump
+# pattern Optional pattern to restrict the dump
+# to certain elements in the array.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::logarray {level arrayvar {pattern *}} {
+ variable cmdMap
+
+ if {[lvIsSuppressed $level]} {
+ # Ignore messages for suppressed levels.
+ return
+ }
+
+ set level [lv2longform $level]
+
+ set cmd $cmdMap($level)
+ if {$cmd == {}} {
+ # Ignore messages for levels without a command
+ return
+ }
+
+ upvar 1 $arrayvar array
+ if {![array exists array]} {
+ error "\"$arrayvar\" isn't an array"
+ }
+ set maxl 0
+ foreach name [lsort [array names array $pattern]] {
+ if {[string length $name] > $maxl} {
+ set maxl [string length $name]
+ }
+ }
+ set maxl [expr {$maxl + [string length $arrayvar] + 2}]
+ foreach name [lsort [array names array $pattern]] {
+ set nameString [format %s(%s) $arrayvar $name]
+
+ eval [linsert $cmd end $level \
+ [format "%-*s = %s" $maxl $nameString $array($name)]]
+ }
+ return
+}
+
+# log::loghex --
+#
+# Like 'log::log', except that the logged data is assumed to
+# be binary and is logged as a block of hex numbers.
+#
+# See also 'log::log' for a general explanation
+#
+# Arguments:
+# level The level of the message.
+# text Message printed before the hex block
+# data Binary data to show as hex.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::loghex {level text data} {
+ variable cmdMap
+
+ if {[lvIsSuppressed $level]} {
+ # Ignore messages for suppressed levels.
+ return
+ }
+
+ set level [lv2longform $level]
+
+ set cmd $cmdMap($level)
+ if {$cmd == {}} {
+ # Ignore messages for levels without a command
+ return
+ }
+
+ # Format the messages and print them.
+
+ set len [string length $data]
+
+ eval [linsert $cmd end $level "$text ($len bytes):"]
+
+ set address ""
+ set hexnums ""
+ set ascii ""
+
+ for {set i 0} {$i < $len} {incr i} {
+ set v [string index $data $i]
+ binary scan $v H2 hex
+ binary scan $v c num
+ set num [expr {($num + 0x100) % 0x100}]
+
+ set text .
+ if {$num > 31} {set text $v}
+
+ if {($i % 16) == 0} {
+ if {$address != ""} {
+ eval [linsert $cmd end $level [format "%4s %-48s |%s|" $address $hexnums $ascii]]
+ set address ""
+ set hexnums ""
+ set ascii ""
+ }
+ append address [format "%04d" $i]
+ }
+ append hexnums "$hex "
+ append ascii $text
+ }
+ if {$address != ""} {
+ eval [linsert $cmd end $level [format "%4s %-48s |%s|" $address $hexnums $ascii]]
+ }
+ eval [linsert $cmd end $level ""]
+ return
+}
+
+# log::log --
+#
+# Log a message according to the specifications for commands,
+# channels and suppression. In other words: The command will do
+# nothing if the specified level is suppressed. If it is not
+# suppressed the actual logging is delegated to the specified
+# command. If there is no command specified for the level the
+# message won't be logged. The standard command ::log::Puts will
+# write the message to the channel specified for the given
+# level. If no channel is specified for the level the message
+# won't be logged. Unique abbreviations of level names are
+# allowed. Errors in the actual logging command are *not*
+# catched, but propagated to the caller, as they may indicate
+# misconfigurations of the log facility or errors in the callers
+# code itself.
+#
+# Arguments:
+# level The level of the message.
+# text The message to log.
+#
+# Side Effects:
+# See above.
+#
+# Results:
+# None.
+
+proc ::log::log {level text} {
+ variable cmdMap
+
+ if {[lvIsSuppressed $level]} {
+ # Ignore messages for suppressed levels.
+ return
+ }
+
+ set level [lv2longform $level]
+
+ set cmd $cmdMap($level)
+ if {$cmd == {}} {
+ # Ignore messages for levels without a command
+ return
+ }
+
+ # Delegate actual logging to the command.
+ # Handle multi-line messages correctly.
+
+ foreach line [split $text \n] {
+ eval [linsert $cmd end $level $line]
+ }
+ return
+}
+
+# log::logMsg --
+#
+# Convenience wrapper around ::log::log. Equivalent to
+# '::log::log info text'.
+#
+# Arguments:
+# text The message to log.
+#
+# Side Effects:
+# See ::log::log.
+#
+# Results:
+# None.
+
+proc ::log::logMsg {text} {
+ log info $text
+}
+
+# log::logError --
+#
+# Convenience wrapper around ::log::log. Equivalent to
+# '::log::log error text'.
+#
+# Arguments:
+# text The message to log.
+#
+# Side Effects:
+# See ::log::log.
+#
+# Results:
+# None.
+
+proc ::log::logError {text} {
+ log error $text
+}
+
+
+# log::Puts --
+#
+# Standard log command, writing messages and levels to
+# user-specified channels. Assumes that the supression checks
+# were done by the caller. Expects full level names,
+# abbreviations are *not allowed*.
+#
+# Arguments:
+# level The level of the message.
+# text The message to log.
+#
+# Side Effects:
+# Writes into channels.
+#
+# Results:
+# None.
+
+proc ::log::Puts {level text} {
+ variable channelMap
+ variable fill
+
+ set chan $channelMap($level)
+ if {$chan == {}} {
+ # Ignore levels without channel.
+ return
+ }
+
+ puts $chan "$level$fill($level) $text"
+ flush $chan
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Initialization code. Disable logging for the lower levels by
+## default.
+
+## log::lvSuppressLE emergency
+log::lvSuppressLE warning
diff --git a/tcllib/modules/log/log.test b/tcllib/modules/log/log.test
new file mode 100644
index 0000000..25eb4d3
--- /dev/null
+++ b/tcllib/modules/log/log.test
@@ -0,0 +1,393 @@
+# -*- tcl -*-
+# Tests for the log facility
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2001 by ActiveState Tool Corp.
+# All rights reserved.
+#
+# RCS: @(#) $Id: log.test,v 1.10 2008/09/25 21:52:57 eee Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal log.tcl log
+}
+
+# -------------------------------------------------------------------------
+
+test log-1.0 {levels} {
+ ::log::levels
+} {alert critical debug emergency error info notice warning}
+
+foreach {abbrev long} {
+ a alert d debug
+ al alert de debug
+ ale alert deb debug
+ aler alert debu debug
+ alert alert debug debug
+ c critical em emergency
+ cr critical eme emergency
+ cri critical emer emergency
+ crit critical emerg emergency
+ criti critical emerge emergency
+ critic critical emergen emergency
+ critica critical emergenc emergency
+ critical critical emergency emergency
+ er error i info
+ err error in info
+ erro error inf info
+ error error info info
+ n notice w warning
+ no notice wa warning
+ not notice war warning
+ noti notice warn warning
+ notic notice warni warning
+ notice notice warnin warning
+ warning warning
+} {
+ test log-2.0.$abbrev {level abbreviations} {
+ ::log::lv2longform $abbrev
+ } $long
+}
+
+test log-2.1 {abbreviation error} {
+ if {![catch {::log::lv2longform e} msg]} {
+ error "e is an unique abbreviation of a level name"
+ }
+ set msg
+} {bad level "e": must be alert, critical, debug, emergency, error, info, notice, or warning.}
+
+foreach {level color} {
+ emergency red warning yellow
+ alert red notice seagreen
+ critical red info {}
+ error red debug lightsteelblue
+} {
+ test log-3.0.$level {color conversion} {
+ ::log::lv2color $level
+ } $color
+}
+
+test log-3.1 {color conversion error} {
+ if {![catch {::log::lv2color foo} msg]} {
+ error "foo is an unique abbreviation of a level name"
+ }
+ set msg
+} {bad level "foo": must be alert, critical, debug, emergency, error, info, notice, or warning.}
+
+foreach {level priority} {
+ emergency 7 warning 3
+ alert 6 notice 2
+ critical 5 info 1
+ error 4 debug 0
+} {
+ test log-4.0.$level {priority conversion} {
+ ::log::lv2priority $level
+ } $priority
+}
+
+test log-4.1 {priority conversion error} {
+ if {![catch {::log::lv2priority foo} msg]} {
+ error "foo is an unique abbreviation of a level name"
+ }
+ set msg
+} {bad level "foo": must be alert, critical, debug, emergency, error, info, notice, or warning.}
+
+foreach level {alert critical debug error emergency info notice warning} {
+ test log-5.0.$level {cmd retrieval} {
+ ::log::lv2cmd $level
+ } ::log::Puts
+}
+
+test log-5.1 {cmd error} {
+ if {![catch {::log::lv2cmd foo} msg]} {
+ error "foo is an unique abbreviation of a level name"
+ }
+ set msg
+} {bad level "foo": must be alert, critical, debug, emergency, error, info, notice, or warning.}
+
+foreach {level chan} {
+ emergency stderr warning stdout
+ alert stderr notice stdout
+ critical stderr info stdout
+ error stderr debug stdout
+} {
+ test log-6.0.$level {channel retrieval} {
+ ::log::lv2channel $level
+ } $chan
+}
+
+test log-6.1 {channel error} {
+ if {![catch {::log::lv2channel foo} msg]} {
+ error "foo is an unique abbreviation of a level name"
+ }
+ set msg
+} {bad level "foo": must be alert, critical, debug, emergency, error, info, notice, or warning.}
+
+foreach level {alert critical error emergency} {
+ test log-7.0.$level {query suppression state} {
+ ::log::lvIsSuppressed $level
+ } 0
+}
+foreach level {debug info notice warning} {
+ test log-7.0.$level {query suppression state} {
+ ::log::lvIsSuppressed $level
+ } 1
+}
+
+test log-7.1 {error when querying suppression state} {
+ if {![catch {::log::lv2cmd foo} msg]} {
+ error "foo is an unique abbreviation of a level name"
+ }
+ set msg
+} {bad level "foo": must be alert, critical, debug, emergency, error, info, notice, or warning.}
+
+
+foreach {la lb res} {
+ emergency emergency 0 alert emergency -1 critical emergency -1 error emergency -1
+ emergency alert 1 alert alert 0 critical alert -1 error alert -1
+ emergency critical 1 alert critical 1 critical critical 0 error critical -1
+ emergency error 1 alert error 1 critical error 1 error error 0
+ emergency warning 1 alert warning 1 critical warning 1 error warning 1
+ emergency notice 1 alert notice 1 critical notice 1 error notice 1
+ emergency info 1 alert info 1 critical info 1 error info 1
+ emergency debug 1 alert debug 1 critical debug 1 error debug 1
+
+ warning emergency -1 notice emergency -1 info emergency -1 debug emergency -1
+ warning alert -1 notice alert -1 info alert -1 debug alert -1
+ warning critical -1 notice critical -1 info critical -1 debug critical -1
+ warning error -1 notice error -1 info error -1 debug error -1
+ warning warning 0 notice warning -1 info warning -1 debug warning -1
+ warning notice 1 notice notice 0 info notice -1 debug notice -1
+ warning info 1 notice info 1 info info 0 debug info -1
+ warning debug 1 notice debug 1 info debug 1 debug debug 0
+} {
+ test log-8.0.$la.$lb {level priority comparisons} {
+ list [::log::lvCompare $la $lb] $la $lb
+ } [list $res $la $lb]
+}
+
+test log-8.1 {comparison errors} {
+ if {![catch {::log::lvCompare foo error} msg]} {
+ error "foo is an unique abbreviation of a level name"
+ }
+ set msg
+} {bad level "foo": must be alert, critical, debug, emergency, error, info, notice, or warning.}
+
+test log-8.2 {comparison errors} {
+ if {![catch {::log::lvCompare error foo} msg]} {
+ error "foo is an unique abbreviation of a level name"
+ }
+ set msg
+} {bad level "foo": must be alert, critical, debug, emergency, error, info, notice, or warning.}
+
+
+foreach level {alert critical debug error emergency info notice warning} {
+ test log-9.0.$level {redefining colors} {
+ set old [::log::lv2color $level]
+ ::log::lvColor $level foo
+ set new [::log::lv2color $level]
+ ::log::lvColor $level $old
+ set new
+ } foo
+}
+
+test log-9.1 {redefining colors} {
+ ::log::lvColorForall fox
+ set res [list]
+ foreach level [::log::levels] {
+ lappend res [::log::lv2color $level]
+ }
+ set res
+} {fox fox fox fox fox fox fox fox}
+
+foreach level {alert critical debug error emergency info notice warning} {
+ test log-10.0.$level {redefining channels} {
+ set old [::log::lv2channel $level]
+ ::log::lvChannel $level foo
+ set new [::log::lv2channel $level]
+ ::log::lvChannel $level $old
+ set new
+ } foo
+}
+
+test log-10.1 {redefining channels} {
+ ::log::lvChannelForall fox
+ set res [list]
+ foreach level [::log::levels] {
+ lappend res [::log::lv2channel $level]
+ }
+ set res
+} {fox fox fox fox fox fox fox fox}
+
+foreach level {alert critical debug error emergency info notice warning} {
+ test log-11.0.$level {redefining cmds} {
+ set old [::log::lv2cmd $level]
+ ::log::lvCmd $level foo
+ set new [::log::lv2cmd $level]
+ ::log::lvCmd $level $old
+ set new
+ } foo
+}
+
+test log-11.1 {redefining cmds} {
+ ::log::lvCmdForall logMem
+ set res [list]
+ foreach level [::log::levels] {
+ lappend res [::log::lv2cmd $level]
+ }
+ set res
+} {logMem logMem logMem logMem logMem logMem logMem logMem}
+
+foreach level {alert critical debug error emergency info notice warning} {
+ test log-12.0.$level {change suppression state} {
+ set old [::log::lvIsSuppressed $level]
+ ::log::lvSuppress $level
+ set new [::log::lvIsSuppressed $level]
+ ::log::lvSuppress $level 0
+ lappend new [::log::lvIsSuppressed $level]
+ set new
+ } {1 0}
+}
+
+test log-12.1 {suppressor errors} {
+ if {![catch {::log::lvSuppress error foo} msg]} {
+ error "foo should be no boolean value"
+ }
+ set msg
+} {"foo" is not a member of {0, 1}}
+
+test log-12.2 {suppressor errors} {
+ if {![catch {::log::lvSuppressLE error foo} msg]} {
+ error "foo should be no boolean value"
+ }
+ set msg
+} {"foo" is not a member of {0, 1}}
+
+foreach {level range} {
+ emergency {1 1 1 1 1 1 1 1}
+ alert {1 1 1 0 1 1 1 1}
+ critical {0 1 1 0 1 1 1 1}
+ error {0 0 1 0 1 1 1 1}
+ warning {0 0 1 0 0 1 1 1}
+ notice {0 0 1 0 0 1 1 0}
+ info {0 0 1 0 0 1 0 0}
+ debug {0 0 1 0 0 0 0 0}
+} {
+ test log-12.3.$level {change suppression state, ranges} {
+ ::log::lvSuppressLE emergency 0 ; # initial full unsuppressed state
+ ::log::lvSuppressLE $level
+ set res [list]
+ foreach l [::log::levels] {
+ lappend res [::log::lvIsSuppressed $l]
+ }
+ set res
+ } $range
+}
+
+foreach {level range} {
+ debug {1 1 0 1 1 1 1 1}
+ info {1 1 0 1 1 0 1 1}
+ notice {1 1 0 1 1 0 0 1}
+ warning {1 1 0 1 1 0 0 0}
+ error {1 1 0 1 0 0 0 0}
+ critical {1 0 0 1 0 0 0 0}
+ alert {0 0 0 1 0 0 0 0}
+ emergency {0 0 0 0 0 0 0 0}
+} {
+ test log-12.4.$level {change suppression state, ranges} {
+ ::log::lvSuppressLE emergency ; # initial full supressed state
+ ::log::lvSuppressLE $level 0
+ set res [list]
+ foreach l [::log::levels] {
+ lappend res [::log::lvIsSuppressed $l]
+ }
+ set res
+ } $range
+}
+
+
+
+# Define our own logger command adding all messages to a global list
+# variable.
+
+global _log_
+set _log_ [list]
+proc logMem {level text} {
+ global _log_
+ lappend _log_ $level $text
+}
+
+# Setup some levels with different properties:
+# - Suppressed
+# - No command
+
+::log::lvCmdForall logMem
+::log::lvCmd alert {}
+::log::lvSuppress critical
+
+test log-13.0 {logging} {
+ set _log_ [list]
+ ::log::log emergency fofafraz
+ ::log::log alert fofafraz1
+ ::log::log critical fofafraz2
+ ::log::log error fofafraz3
+ ::log::log warning fofafraz4
+ set _log_
+} {emergency fofafraz error fofafraz3 warning fofafraz4}
+
+test log-13.1 {logging} {
+ set _log_ [list]
+ ::log::logMsg fobar
+ set _log_
+} {info fobar}
+
+test log-13.2 {logging} {
+ set _log_ [list]
+ ::log::logError buz
+ set _log_
+} {error buz}
+
+test log-13.3 {log error} {
+ if {![catch {::log::log e foobar} msg]} {
+ error "e is an unique abbreviation of a level name"
+ }
+ set msg
+} {bad level "e": must be alert, critical, debug, emergency, error, info, notice, or warning.}
+
+
+set lastlevel warning
+foreach level {alert critical debug error emergency info notice warning} {
+ test log-14.0.$level {log::Puts} {
+ makeFile {} test.log
+ ::log::lvCmdForall ::log::Puts
+ ::log::lvSuppressLE emergency 0
+
+ set old [::log::lv2channel $level]
+ ::log::lvChannelForall {}
+ ::log::lvChannel $level [open test.log w]
+
+ ::log::log $level __data__
+ ::log::log $lastlevel __NOT__
+
+ close [::log::lv2channel $level]
+ set lastlevel $level
+
+ set log [join [split [viewFile test.log] \n]]
+ removeFile test.log
+ list [string match *__data__* $log] [string match *__NOT__* $log]
+ } {1 0}
+}
+::log::lvChannelForall {}
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/log/logger.man b/tcllib/modules/log/logger.man
new file mode 100644
index 0000000..53ea370
--- /dev/null
+++ b/tcllib/modules/log/logger.man
@@ -0,0 +1,397 @@
+[comment {-*- tcl -*- doctools manpage}]
+[comment {$Id: logger.man,v 1.26 2012/07/10 03:34:47 andreas_kupries Exp $}]
+[vset VERSION 0.9.4]
+[manpage_begin logger n [vset VERSION]]
+[keywords log]
+[keywords {log level}]
+[keywords logger]
+[keywords service]
+[moddesc {Object Oriented logging facility}]
+[titledesc {System to control logging of events.}]
+[category {Programming tools}]
+[require Tcl 8.2]
+[require logger [opt [vset VERSION]]]
+[description]
+
+[para]
+
+The [package logger] package provides a flexible system for logging messages
+from different services, at priority levels, with different commands.
+
+[para]
+
+To begin using the logger package, we do the following:
+
+[para]
+
+[example {
+ package require logger
+ set log [logger::init myservice]
+ ${log}::notice "Initialized myservice logging"
+
+ ... code ...
+
+ ${log}::notice "Ending myservice logging"
+ ${log}::delete
+}]
+
+[para]
+
+In the above code, after the package is loaded, the following things
+happen:
+
+[list_begin definitions]
+
+[call [cmd logger::init] [arg service]]
+
+Initializes the service [arg service] for logging. The service names
+are actually Tcl namespace names, so they are separated with '::'.
+The service name may not be the empty string or only ':'s.
+
+When a logger service is initialized, it "inherits" properties from its
+parents. For instance, if there were a service [term foo], and
+we did a [cmd logger::init] [arg foo::bar] (to create a [term bar]
+service underneath [term foo]), [term bar] would copy the current
+configuration of the [term foo] service, although it would of
+course, also be possible to then separately configure [term bar].
+
+If a logger service is initialized and the parent does not yet exist, the
+parent is also created.
+
+The new logger service is initialized with the default loglevel set
+with [cmd logger::setlevel].
+
+[call [cmd logger::import] [opt [option -all] ] [opt [option -force]] [opt "[option -prefix] [arg prefix]" ] [opt "[option -namespace] [arg namespace]" ] [arg service] ]
+
+Import the logger service commands into the current namespace. Without the [option -all] option
+only the commands corresponding to the log levels are imported. If [option -all] is given,
+all the [cmd \${log}::cmd] style commands are imported. If the import would overwrite a command
+an error is returned and no command is imported. Use the [option -force] option to force the import
+and overwrite existing commands without complaining.
+
+If the [option -prefix] option is given, the commands are imported with the given [arg prefix]
+prepended to their names.
+
+If the [option -namespace] option is given, the commands are imported into the given namespace. If the
+namespace does not exist, it is created. If a namespace without a leading :: is given, it is interpreted as
+a child namespace to the current namespace.
+
+[call [cmd logger::initNamespace] [arg ns] [opt [arg level]]]
+
+Convenience command for setting up a namespace for logging. Creates a
+logger service named after the namespace [arg ns] (a :: prefix is
+stripped), imports all the log commands into the namespace, and sets
+the default logging level, either as specified by [arg level], or
+inherited from a service in the parent namespace, or a hardwired
+default, [const warn].
+
+[call [cmd logger::services]]
+
+Returns a list of all the available services.
+
+[call [cmd logger::enable] [arg level]]
+
+Globally enables logging at and "above" the given level. Levels are
+[const debug], [const info], [const notice], [const warn], [const error],
+[const critical], [const alert], [const emergency].
+
+[call [cmd logger::disable] [arg level]]
+
+Globally disables logging at and "below" the given level. Levels are
+those listed above.
+
+[call [cmd logger::setlevel] [arg level]]
+
+Globally enable logging at and "above" the given level. Levels are those
+listed above. This command changes the default loglevel for new loggers
+created with [cmd logger::init].
+
+[call [cmd logger::levels]]
+
+Returns a list of the available log levels (also listed above under [cmd enable]).
+
+[call [cmd logger::servicecmd] [arg service]]
+
+Returns the [cmd \${log}] token created by [cmd logger::init] for this service.
+
+[call [cmd \${log}::debug] [arg message]]
+[call [cmd \${log}::info] [arg message]]
+[call [cmd \${log}::notice] [arg message]]
+[call [cmd \${log}::warn] [arg message]]
+[call [cmd \${log}::error] [arg message]]
+[call [cmd \${log}::critical] [arg message]]
+[call [cmd \${log}::alert] [arg message]]
+[call [cmd \${log}::emergency] [arg message]]
+
+These are the commands called to actually log a message about an
+event. [var \${log}] is the variable obtained from [cmd logger::init].
+
+[call [cmd \${log}::setlevel] [arg level]]
+
+Enable logging, in the service referenced by [var \${log}], and its
+children, at and above the level specified, and disable logging below
+it.
+
+[call [cmd \${log}::enable] [arg level] ]
+
+Enable logging, in the service referenced by [var \${log}], and its
+children, at and above the level specified. Note that this does [emph not] disable logging below this level, so you should probably use
+[cmd setlevel] instead.
+
+[call [cmd \${log}::disable] [arg level]]
+
+Disable logging, in the service referenced by [var \${log}], and its
+children, at and below the level specified. Note that this does [emph not] enable logging above this level,
+so you should probably use [cmd setlevel] instead.
+Disabling the loglevel [const emergency] switches logging off for the service and its children.
+
+[call [cmd \${log}::lvlchangeproc] [arg command]]
+[call [cmd \${log}::lvlchangeproc]]
+
+Set the script to call when the log instance in question changes its log level.
+If called without a command it returns the currently registered command. The command gets two arguments
+appended, the old and the new loglevel. The callback is invoked after all changes have been done.
+If child loggers are affected, their callbacks are called before their parents callback.
+
+[example {
+ proc lvlcallback {old new} {
+ puts "Loglevel changed from $old to $new"
+ }
+ ${log}::lvlchangeproc lvlcallback
+ }]
+
+[call [cmd \${log}::logproc] [arg level]]
+[call [cmd \${log}::logproc] [arg level] [arg command]]
+[call [cmd \${log}::logproc] [arg level] [arg argname] [arg body]]
+
+This command comes in three forms - the third, older one is deprecated
+and may be removed from future versions of the logger package.
+The current set version takes one argument, a command to be executed when the
+level is called. The callback command takes on argument, the text to
+be logged. If called only with a valid level [cmd logproc] returns the name of the command
+currently registered as callback command.
+
+[cmd logproc] specifies which command will perform the actual logging
+for a given level. The logger package ships with default commands for
+all log levels, but with [cmd logproc] it is possible to replace them
+with custom code. This would let you send your logs over the network,
+to a database, or anything else. For example:
+
+[example {
+ proc logtoserver {txt} {
+ variable socket
+ puts $socket "Notice: $txt"
+ }
+
+ ${log}::logproc notice logtoserver
+}]
+
+Trace logs are slightly different: instead of a plain text argument,
+the argument provided to the logproc is a dictionary consisting of the
+[const enter] or [const leave] keyword along with another dictionary of
+details about the trace. These include:
+
+[list_begin itemized]
+
+[item] [const proc] - Name of the procedure being traced.
+
+[item] [const level] - The stack level for the procedure invocation
+(from [cmd info] [cmd level]).
+
+[item] [const script] - The name of the file in which the procedure is
+defined, or an empty string if defined in interactive mode.
+
+[item] [const caller] - The name of the procedure calling the procedure
+being traced, or an empty string if the procedure was called from the
+global scope (stack level 0).
+
+[item] [const procargs] - A dictionary consisting of the names of arguments
+to the procedure paired with values given for those arguments ([const enter]
+traces only).
+
+[item] [const status] - The Tcl return code (e.g. [const ok],
+[const continue], etc.) ([const leave] traces only).
+
+[item] [const result] - The value returned by the procedure ([const leave]
+traces only).
+
+[list_end]
+
+[call [cmd \${log}::services]]
+
+Returns a list of the registered logging services which are children of this service.
+
+[call [cmd \${log}::servicename]]
+
+Returns the name of this service.
+
+[call [cmd \${log}::currentloglevel]]
+
+Returns the currently enabled log level for this service. If no logging is enabled returns [const none].
+
+[call [cmd \${log}::delproc] [arg command]]
+[call [cmd \${log}::delproc]]
+
+Set the script to call when the log instance in question is deleted.
+If called without a command it returns the currently registered command.
+For example:
+
+[example {
+ ${log}::delproc [list closesock $logsock]
+}]
+
+[call [cmd \${log}::delete]]
+
+This command deletes a particular logging service, and its children.
+You must call this to clean up the resources used by a service.
+
+[call [cmd \${log}::trace] [arg command]]
+
+This command controls logging of enter/leave traces for specified procedures.
+It is used to enable and disable tracing, query tracing status, and
+specify procedures are to be traced. Trace handlers are unregistered when
+tracing is disabled. As a result, there is not performance impact to a
+library when tracing is disabled, just as with other log level commands.
+
+[example {
+ proc tracecmd { dict } {
+ puts $dict
+ }
+
+ set log [::logger::init example]
+ ${log}::logproc trace tracecmd
+
+ proc foo { args } {
+ puts "In foo"
+ bar 1
+ return "foo_result"
+ }
+
+ proc bar { x } {
+ puts "In bar"
+ return "bar_result"
+ }
+
+ ${log}::trace add foo bar
+ ${log}::trace on
+
+ foo
+
+# Output:
+enter {proc ::foo level 1 script {} caller {} procargs {args {}}}
+In foo
+enter {proc ::bar level 2 script {} caller ::foo procargs {x 1}}
+In bar
+leave {proc ::bar level 2 script {} caller ::foo status ok result bar_result}
+leave {proc ::foo level 1 script {} caller {} status ok result foo_result}
+}]
+
+[call [cmd \${log}::trace] [cmd on]]
+
+Turns on trace logging for procedures registered through the [cmd trace]
+[cmd add] command. This is similar to the [cmd enable] command for other
+logging levels, but allows trace logging to take place at any level.
+
+The trace logging mechanism takes advantage of the execution trace feature
+of Tcl 8.4 and later. The [cmd trace] [cmd on] command will return an
+error if called from earlier versions of Tcl.
+
+[call [cmd \${log}::trace] [cmd off]]
+
+Turns off trace logging for procedures registered for trace logging
+through the [cmd trace] [cmd add] command. This is similar to the
+[cmd disable] command for other logging levels, but allows trace logging
+to take place at any level.
+
+Procedures are not unregistered, so logging for them can be turned back
+on with the [cmd trace] [cmd on] command. There is no overhead imposed
+by trace registration when trace logging is disabled.
+
+[call [cmd \${log}::trace] [cmd status] [opt procName] [opt ...]]
+
+This command returns a list of the procedures currently registered for
+trace logging, or a flag indicating whether or not a trace is registered
+for one or more specified procedures.
+
+[call [cmd \${log}::trace] [cmd add] [arg procName] [opt ...]]
+[call [cmd \${log}::trace] [cmd add] [opt -ns] [arg nsName] [opt ...]]
+
+This command registers one or more procedures for logging of entry/exit
+traces. Procedures can be specified via a list of procedure names or
+namespace names (in which case all procedure within the namespace
+are targeted by the operation). By default, each name is first
+interpreted as a procedure name or glob-style search pattern, and if
+not found its interpreted as a namespace name. The [arg -ns] option can
+be used to force interpretation of all provided arguments as namespace names.
+
+Procedures must be defined prior to registering them for tracing
+through the [cmd trace] [cmd add] command. Any procedure or namespace
+names/patterns that don't match any existing procedures will be
+silently ignored.
+
+[call [cmd \${log}::trace] [cmd remove] [arg procName] [opt ...]]
+[call [cmd \${log}::trace] [cmd remove] [opt -ns] [arg nsName] [opt ...]]
+
+This command unregisters one or more procedures so that they will no
+longer have trace logging performed, with the same matching rules as
+that of the [cmd trace] [cmd add] command.
+
+[list_end]
+
+[section IMPLEMENTATION]
+
+The logger package is implemented in such a way as to optimize (for
+Tcl 8.4 and newer) log procedures which are disabled. They are
+aliased to a proc which has no body, which is compiled to a no op in
+bytecode. This should make the peformance hit minimal. If you really
+want to pull out all the stops, you can replace the ${log} token in
+your code with the actual namespace and command (${log}::warn becomes
+::logger::tree::myservice::warn), so that no variable lookup is done.
+This puts the performance of disabled logger commands very close to no
+logging at all.
+
+[para]
+
+The "object orientation" is done through a hierarchy of namespaces.
+Using an actual object oriented system would probably be a better way
+of doing things, or at least provide for a cleaner implementation.
+
+[para]
+
+The service "object orientation" is done with namespaces.
+
+[section {Logprocs and Callstack}]
+
+The logger package takes extra care to keep the logproc out of the call stack.
+This enables logprocs to execute code in the callers scope by using uplevel or
+linking to local variables by using upvar. This may fire traces with all usual
+side effects.
+
+[example {
+ # Print caller and current vars in the calling proc
+ proc log_local_var {txt} {
+ set caller [info level -1]
+ set vars [uplevel 1 info vars]
+ foreach var [lsort $vars] {
+ if {[uplevel 1 [list array exists $var]] == 1} {
+ lappend val $var <Array>
+ } else {
+ lappend val $var [uplevel 1 [list set $var]]
+ }
+ }
+ puts "$txt"
+ puts "Caller: $caller"
+ puts "Variables in callers scope:"
+ foreach {var value} $val {
+ puts "$var = $value"
+ }
+ }
+
+ # install as logproc
+ ${log}::logproc debug log_local_var
+ }
+]
+
+[vset CATEGORY logger]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/log/logger.tcl b/tcllib/modules/log/logger.tcl
new file mode 100644
index 0000000..22b8c7f
--- /dev/null
+++ b/tcllib/modules/log/logger.tcl
@@ -0,0 +1,1297 @@
+# logger.tcl --
+#
+# Tcl implementation of a general logging facility.
+#
+# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com>
+# Copyright (c) 2004-2011 by Michael Schlenker <mic42@users.sourceforge.net>
+# Copyright (c) 2006,2015 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# See the file license.terms.
+
+# The logger package provides an 'object oriented' log facility that
+# lets you have trees of services, that inherit from one another.
+# This is accomplished through the use of Tcl namespaces.
+
+
+package require Tcl 8.2
+package provide logger 0.9.4
+
+namespace eval ::logger {
+ namespace eval tree {}
+ namespace export init enable disable services servicecmd import
+
+ # The active services.
+ variable services {}
+
+ # The log 'levels'.
+ variable levels [list debug info notice warn error critical alert emergency]
+
+ # The default global log level used for new logging services
+ variable enabled "debug"
+
+ # Tcl return codes (in numeric order)
+ variable RETURN_CODES [list "ok" "error" "return" "break" "continue"]
+}
+
+# Try to load msgcat and fall back to format if it fails
+if {[catch {package require msgcat}]} {
+ interp alias {} ::logger::mc {} ::format
+} else {
+ namespace eval ::logger {
+ namespace import ::msgcat::mc
+ }
+}
+
+# ::logger::_nsExists --
+#
+# Workaround for missing namespace exists in Tcl 8.2 and 8.3.
+#
+
+if {[package vcompare [package provide Tcl] 8.4] < 0} {
+ proc ::logger::_nsExists {ns} {
+ expr {![catch {namespace parent $ns}]}
+ }
+} else {
+ proc ::logger::_nsExists {ns} {
+ namespace exists $ns
+ }
+}
+
+# ::logger::_cmdPrefixExists --
+#
+# Utility function to check if a given callback prefix exists,
+# this should catch all oddities in prefix names, including spaces,
+# glob patterns, non normalized namespaces etc.
+#
+# Arguments:
+# prefix - The command prefix to check
+#
+# Results:
+# 1 or 0 for yes or no
+#
+proc ::logger::_cmdPrefixExists {prefix} {
+ set cmd [lindex $prefix 0]
+ set full [namespace eval :: namespace which [list $cmd]]
+ if {[string equal $full ""]} {return 0} else {return 1}
+ # normalize namespaces
+ set ns [namespace qualifiers $cmd]
+ set cmd ${ns}::[namespace tail $cmd]
+ set matches [::info commands ${ns}::*]
+ if {[lsearch -exact $matches $cmd] != -1} {return 1}
+ return 0
+}
+
+# ::logger::walk --
+#
+# Walk namespaces, starting in 'start', and evaluate 'code' in
+# them.
+#
+# Arguments:
+# start - namespace to start in.
+# code - code to execute in namespaces walked.
+#
+# Side Effects:
+# Side effects of code executed.
+#
+# Results:
+# None.
+
+proc ::logger::walk { start code } {
+ set children [namespace children $start]
+ foreach c $children {
+ logger::walk $c $code
+ namespace eval $c $code
+ }
+}
+
+proc ::logger::init {service} {
+ variable levels
+ variable services
+ variable enabled
+
+ if {[string length [string trim $service {:}]] == 0} {
+ return -code error \
+ -errorcode [list LOGGER EMPTY_SERVICENAME] \
+ [::logger::mc "Service name invalid. May not consist only of : or be empty"]
+ }
+ # We create a 'tree' namespace to house all the services, so
+ # they are in a 'safe' namespace sandbox, and won't overwrite
+ # any commands.
+ namespace eval tree::${service} {
+ variable service
+ variable levels
+ variable oldname
+ variable enabled
+ }
+
+ lappend services $service
+
+ set [namespace current]::tree::${service}::service $service
+ set [namespace current]::tree::${service}::levels $levels
+ set [namespace current]::tree::${service}::oldname $service
+ set [namespace current]::tree::${service}::enabled $enabled
+
+ namespace eval tree::${service} {
+ # Callback to use when the service in question is shut down.
+ variable delcallback [namespace current]::no-op
+
+ # Callback when the loglevel is changed
+ variable levelchangecallback [namespace current]::no-op
+
+ # State variable to decide when to call levelcallback
+ variable inSetLevel 0
+
+ # The currently configured levelcommands
+ variable lvlcmds
+ array set lvlcmds {}
+
+ # List of procedures registered via the trace command
+ variable traceList ""
+
+ # Flag indicating whether or not tracing is currently enabled
+ variable tracingEnabled 0
+
+ # We use this to disable a service completely. In Tcl 8.4
+ # or greater, by using this, disabled log calls are a
+ # no-op!
+
+ proc no-op args {}
+
+ proc stdoutcmd {level text} {
+ variable service
+ puts "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'"
+ }
+
+ proc stderrcmd {level text} {
+ variable service
+ puts stderr "\[[clock format [clock seconds]]\] \[$service\] \[$level\] \'$text\'"
+ }
+
+
+ # setlevel --
+ #
+ # This command differs from enable and disable in that
+ # it disables all the levels below that selected, and
+ # then enables all levels above it, which enable/disable
+ # do not do.
+ #
+ # Arguments:
+ # lv - the level, as defined in $levels.
+ #
+ # Side Effects:
+ # Runs disable for the level, and then enable, in order
+ # to ensure that all levels are set correctly.
+ #
+ # Results:
+ # None.
+
+
+ proc setlevel {lv} {
+ variable inSetLevel 1
+ set oldlvl [currentloglevel]
+
+ # do not allow enable and disable to do recursion
+ if {[catch {
+ disable $lv 0
+ set newlvl [enable $lv 0]
+ } msg] == 1} {
+ return -code error -errorcode $::errorCode $msg
+ }
+ # do the recursion here
+ logger::walk [namespace current] [list setlevel $lv]
+
+ set inSetLevel 0
+ lvlchangewrapper $oldlvl $newlvl
+ return
+ }
+
+ # enable --
+ #
+ # Enable a particular 'level', and above, for the
+ # service, and its 'children'.
+ #
+ # Arguments:
+ # lv - the level, as defined in $levels.
+ #
+ # Side Effects:
+ # Enables logging for the particular level, and all
+ # above it (those more important). It also walks
+ # through all services that are 'children' and enables
+ # them at the same level or above.
+ #
+ # Results:
+ # None.
+
+ proc enable {lv {recursion 1}} {
+ variable levels
+ set lvnum [lsearch -exact $levels $lv]
+ if { $lvnum == -1 } {
+ return -code error \
+ -errorcode [list LOGGER INVALID_LEVEL] \
+ [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels]
+ }
+
+ variable enabled
+ set newlevel $enabled
+ set elnum [lsearch -exact $levels $enabled]
+ if {($elnum == -1) || ($elnum > $lvnum)} {
+ set newlevel $lv
+ }
+
+ variable service
+ while { $lvnum < [llength $levels] } {
+ interp alias {} [namespace current]::[lindex $levels $lvnum] \
+ {} [namespace current]::[lindex $levels $lvnum]cmd
+ incr lvnum
+ }
+
+ if {$recursion} {
+ logger::walk [namespace current] [list enable $lv]
+ }
+ lvlchangewrapper $enabled $newlevel
+ set enabled $newlevel
+ }
+
+ # disable --
+ #
+ # Disable a particular 'level', and below, for the
+ # service, and its 'children'.
+ #
+ # Arguments:
+ # lv - the level, as defined in $levels.
+ #
+ # Side Effects:
+ # Disables logging for the particular level, and all
+ # below it (those less important). It also walks
+ # through all services that are 'children' and disables
+ # them at the same level or below.
+ #
+ # Results:
+ # None.
+
+ proc disable {lv {recursion 1}} {
+ variable levels
+ set lvnum [lsearch -exact $levels $lv]
+ if { $lvnum == -1 } {
+ return -code error \
+ -errorcode [list LOGGER INVALID_LEVEL] \
+ [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels]
+ }
+
+ variable enabled
+ set newlevel $enabled
+ set elnum [lsearch -exact $levels $enabled]
+ if {($elnum > -1) && ($elnum <= $lvnum)} {
+ if {$lvnum+1 >= [llength $levels]} {
+ set newlevel "none"
+ } else {
+ set newlevel [lindex $levels [expr {$lvnum+1}]]
+ }
+ }
+
+ while { $lvnum >= 0 } {
+
+ interp alias {} [namespace current]::[lindex $levels $lvnum] {} \
+ [namespace current]::no-op
+ incr lvnum -1
+ }
+ if {$recursion} {
+ logger::walk [namespace current] [list disable $lv]
+ }
+ lvlchangewrapper $enabled $newlevel
+ set enabled $newlevel
+ }
+
+ # currentloglevel --
+ #
+ # Get the currently enabled log level for this service.
+ #
+ # Arguments:
+ # none
+ #
+ # Side Effects:
+ # none
+ #
+ # Results:
+ # current log level
+ #
+
+ proc currentloglevel {} {
+ variable enabled
+ return $enabled
+ }
+
+ # lvlchangeproc --
+ #
+ # Set or introspect a callback for when the logger instance
+ # changes its loglevel.
+ #
+ # Arguments:
+ # cmd - the Tcl command to call, it is called with two parameters, old and new log level.
+ # or none for introspection
+ #
+ # Side Effects:
+ # None.
+ #
+ # Results:
+ # If no arguments are given return the current callback cmd.
+
+ proc lvlchangeproc {args} {
+ variable levelchangecallback
+
+ switch -exact -- [llength [::info level 0]] {
+ 1 {return $levelchangecallback}
+ 2 {
+ if {[::logger::_cmdPrefixExists [lindex $args 0]]} {
+ set levelchangecallback [lindex $args 0]
+ } else {
+ return -code error \
+ -errorcode [list LOGGER INVALID_CMD] \
+ [::logger::mc "Invalid cmd '%s' - does not exist" [lindex $args 0]]
+ }
+ }
+ default {
+ return -code error \
+ -errorcode [list LOGGER WRONG_NUM_ARGS] \
+ [::logger::mc "Wrong # of arguments. Usage: \${log}::lvlchangeproc ?cmd?"]
+ }
+ }
+ }
+
+ proc lvlchangewrapper {old new} {
+ variable inSetLevel
+
+ # we are called after disable and enable are finished
+ if {$inSetLevel} {return}
+
+ # no action if level does not change
+ if {[string equal $old $new]} {return}
+
+ variable levelchangecallback
+ # no action if levelchangecallback isn't a valid command
+ if {[::logger::_cmdPrefixExists $levelchangecallback]} {
+ catch {
+ uplevel \#0 [linsert $levelchangecallback end $old $new]
+ }
+ }
+ }
+
+ # logproc --
+ #
+ # Command used to create a procedure that is executed to
+ # perform the logging. This could write to disk, out to
+ # the network, or something else.
+ # If two arguments are given, use an existing command.
+ # If three arguments are given, create a proc.
+ #
+ # Arguments:
+ # lv - the level to log, which must be one of $levels.
+ # args - either zero, one or two arguments.
+ # if zero this returns the current command registered
+ # if one, this is a cmd name that is called for this level
+ # if two, these are an argument and proc body
+ #
+ # Side Effects:
+ # Creates a logging command to take care of the details
+ # of logging an event.
+ #
+ # Results:
+ # If called with zero length args, returns the name of the currently
+ # configured logging procedure.
+ #
+ #
+
+ proc logproc {lv args} {
+ variable levels
+ variable lvlcmds
+
+ set lvnum [lsearch -exact $levels $lv]
+ if { ($lvnum == -1) && ($lv != "trace") } {
+ return -code error \
+ -errorcode [list LOGGER INVALID_LEVEL] \
+ [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels]
+ }
+ switch -exact -- [llength $args] {
+ 0 {
+ return $lvlcmds($lv)
+ }
+ 1 {
+ set cmd [lindex $args 0]
+ if {[string equal "[namespace current]::${lv}cmd" $cmd]} {return}
+ if {[llength [::info commands $cmd]]} {
+ proc ${lv}cmd args [format {
+ uplevel 1 [list %s [expr {[llength $args]==1 ? [lindex $args end] : $args}]]
+ } $cmd]
+ } else {
+ return -code error \
+ -errorcode [list LOGGER INVALID_CMD] \
+ [::logger::mc "Invalid cmd '%s' - does not exist" $cmd]
+ }
+ set lvlcmds($lv) $cmd
+ }
+ 2 {
+ foreach {arg body} $args {break}
+ proc ${lv}cmd args [format {\
+ _setservicename args
+ set val [%s [expr {[llength $args]==1 ? [lindex $args end] : $args}]]
+ _restoreservice
+ set val} ${lv}customcmd]
+ proc ${lv}customcmd $arg $body
+ set lvlcmds($lv) [namespace current]::${lv}customcmd
+ }
+ default {
+ return -code error \
+ -errorcode [list LOGGER WRONG_USAGE] \
+ [::logger::mc \
+ "Usage: \${log}::logproc level ?cmd?\nor \${log}::logproc level argname body" ]
+ }
+ }
+ }
+
+
+ # delproc --
+ #
+ # Set or introspect a callback for when the logger instance
+ # is deleted.
+ #
+ # Arguments:
+ # cmd - the Tcl command to call.
+ # or none for introspection
+ #
+ # Side Effects:
+ # None.
+ #
+ # Results:
+ # If no arguments are given return the current callback cmd.
+
+ proc delproc {args} {
+ variable delcallback
+
+ switch -exact -- [llength [::info level 0]] {
+ 1 {return $delcallback}
+ 2 { if {[::logger::_cmdPrefixExists [lindex $args 0]]} {
+ set delcallback [lindex $args 0]
+ } else {
+ return -code error \
+ -errorcode [list LOGGER INVALID_CMD] \
+ [::logger::mc "Invalid cmd '%s' - does not exist" [lindex $args 0]]
+ }
+ }
+ default {
+ return -code error \
+ -errorcode [list LOGGER WRONG_NUM_ARGS] \
+ [::logger::mc "Wrong # of arguments. Usage: \${log}::delproc ?cmd?"]
+ }
+ }
+ }
+
+
+ # delete --
+ #
+ # Delete the namespace and its children.
+
+ proc delete {} {
+ variable delcallback
+ variable service
+
+ logger::walk [namespace current] delete
+ if {[::logger::_cmdPrefixExists $delcallback]} {
+ uplevel \#0 [lrange $delcallback 0 end]
+ }
+ # clean up the global services list
+ set idx [lsearch -exact [logger::services] $service]
+ if {$idx !=-1} {
+ set ::logger::services [lreplace [logger::services] $idx $idx]
+ }
+
+ namespace delete [namespace current]
+
+ }
+
+ # services --
+ #
+ # Return all child services
+
+ proc services {} {
+ variable service
+
+ set children [list]
+ foreach srv [logger::services] {
+ if {[string match "${service}::*" $srv]} {
+ lappend children $srv
+ }
+ }
+ return $children
+ }
+
+ # servicename --
+ #
+ # Return the name of the service
+
+ proc servicename {} {
+ variable service
+ return $service
+ }
+
+ proc _setservicename {argname} {
+ variable service
+ variable oldname
+ upvar 1 $argname arg
+ if {[llength $arg] <= 1} {
+ return
+ }
+
+ set count -1
+ set newname ""
+ while {[string equal [lindex $arg [expr {$count+1}]] "-_logger::service"]} {
+ incr count 2
+ set newname [lindex $arg $count]
+ }
+ if {[string equal $newname ""]} {
+ return
+ }
+ set oldname $service
+ set service $newname
+ # Pop off "-_logger::service <service>" from argument list
+ set arg [lreplace $arg 0 $count]
+ }
+
+ proc _restoreservice {} {
+ variable service
+ variable oldname
+ set service $oldname
+ return
+ }
+
+ proc trace { action args } {
+ variable service
+
+ # Allow other boolean values (true, false, yes, no, 0, 1) to be used
+ # as synonymns for "on" and "off".
+
+ if {[string is boolean $action]} {
+ set xaction [expr {($action && 1) ? "on" : "off"}]
+ } else {
+ set xaction $action
+ }
+
+ # Check for required arguments for actions/subcommands and dispatch
+ # to the appropriate procedure.
+
+ switch -- $xaction {
+ "status" {
+ return [uplevel 1 [list logger::_trace_status $service $args]]
+ }
+ "on" {
+ if {[llength $args]} {
+ return -code error \
+ -errorcode [list LOGGER WRONG_NUM_ARGS] \
+ [::logger::mc "wrong # args: should be \"trace on\""]
+ }
+ return [logger::_trace_on $service]
+ }
+ "off" {
+ if {[llength $args]} {
+ return -code error \
+ -errorcode [list LOGGER WRONG_NUM_ARGS] \
+ [::logger::mc "wrong # args: should be \"trace off\""]
+ }
+ return [logger::_trace_off $service]
+ }
+ "add" {
+ if {![llength $args]} {
+ return -code error \
+ -errorcode [list LOGGER WRONG_NUM_ARGS] \
+ [::logger::mc "wrong # args: should be \"trace add ?-ns? <proc> ...\""]
+ }
+ return [uplevel 1 [list ::logger::_trace_add $service $args]]
+ }
+ "remove" {
+ if {![llength $args]} {
+ return -code error \
+ -errorcode [list LOGGER WRONG_NUM_ARGS] \
+ [::logger::mc "wrong # args: should be \"trace remove ?-ns? <proc> ...\""]
+ }
+ return [uplevel 1 [list ::logger::_trace_remove $service $args]]
+ }
+
+ default {
+ return -code error \
+ -errorcode [list LOGGER INVALID_ARG] \
+ [::logger::mc "Invalid action \"%s\": must be status, add, remove,\
+ on, or off" $action]
+ }
+ }
+ }
+
+ # Walk the parent service namespaces to see first, if they
+ # exist, and if any are enabled, and then, as a
+ # consequence, enable this one
+ # too.
+
+ enable $enabled
+ variable parent [namespace parent]
+ while {[string compare $parent "::logger::tree"]} {
+ # If the 'enabled' variable doesn't exist, create the
+ # whole thing.
+ if { ! [::info exists ${parent}::enabled] } {
+ logger::init [string range $parent 16 end]
+ }
+ set enabled [set ${parent}::enabled]
+ enable $enabled
+ set parent [namespace parent $parent]
+ }
+ }
+
+ # Now create the commands for different levels.
+
+ namespace eval tree::${service} {
+ set parent [namespace parent]
+
+ # We 'inherit' the commands from the parents. This
+ # means that, if you want to share the same methods with
+ # children, they should be instantiated after the parent's
+ # methods have been defined.
+
+ variable lvl ; # prevent creative writing to the global scope
+ if {[string compare $parent "::logger::tree"]} {
+ foreach lvl [::logger::levels] {
+ # OPTIMIZE: do not allow multiple aliases in the hierarchy
+ # they can always be replaced by more efficient
+ # direct aliases to the target procs.
+ interp alias {} [namespace current]::${lvl}cmd \
+ {} ${parent}::${lvl}cmd -_logger::service $service
+ }
+ # inherit the starting loglevel of the parent service
+ setlevel [${parent}::currentloglevel]
+ } else {
+ foreach lvl [concat [::logger::levels] "trace"] {
+ proc ${lvl}cmd args [format {\
+ _setservicename args
+ set val [stdoutcmd %s [expr {[llength $args]==1 ? [lindex $args end] : $args}]]
+ _restoreservice
+ set val } $lvl]
+
+ set lvlcmds($lvl) [namespace current]::${lvl}cmd
+ }
+ setlevel $::logger::enabled
+ }
+ unset lvl ; # drop the temp iteration variable
+ }
+
+ return ::logger::tree::${service}
+}
+
+# ::logger::services --
+#
+# Returns a list of all active services.
+#
+# Arguments:
+# None.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# List of active services.
+
+proc ::logger::services {} {
+ variable services
+ return $services
+}
+
+# ::logger::enable --
+#
+# Global enable for a certain level. NOTE - this implementation
+# isn't terribly effective at the moment, because it might hit
+# children before their parents, who will then walk down the
+# tree attempting to disable the children again.
+#
+# Arguments:
+# lv - level above which to enable logging.
+#
+# Side Effects:
+# Enables logging in a given level, and all higher levels.
+#
+# Results:
+# None.
+
+proc ::logger::enable {lv} {
+ variable services
+ if {[catch {
+ foreach sv $services {
+ ::logger::tree::${sv}::enable $lv
+ }
+ } msg] == 1} {
+ return -code error -errorcode $::errorCode $msg
+ }
+}
+
+proc ::logger::disable {lv} {
+ variable services
+ if {[catch {
+ foreach sv $services {
+ ::logger::tree::${sv}::disable $lv
+ }
+ } msg] == 1} {
+ return -code error -errorcode $::errorCode $msg
+ }
+}
+
+proc ::logger::setlevel {lv} {
+ variable services
+ variable enabled
+ variable levels
+ if {[lsearch -exact $levels $lv] == -1} {
+ return -code error \
+ -errorcode [list LOGGER INVALID_LEVEL] \
+ [::logger::mc "Invalid level '%s' - levels are %s" $lv $levels]
+ }
+ set enabled $lv
+ if {[catch {
+ foreach sv $services {
+ ::logger::tree::${sv}::setlevel $lv
+ }
+ } msg] == 1} {
+ return -code error -errorcode $::errorCode $msg
+ }
+}
+
+# ::logger::levels --
+#
+# Introspect the available log levels. Provided so a caller does
+# not need to know implementation details or code the list
+# himself.
+#
+# Arguments:
+# None.
+#
+# Side Effects:
+# None.
+#
+# Results:
+# levels - The list of valid log levels accepted by enable and disable
+
+proc ::logger::levels {} {
+ variable levels
+ return $levels
+}
+
+# ::logger::servicecmd --
+#
+# Get the command token for a given service name.
+#
+# Arguments:
+# service - name of the service.
+#
+# Side Effects:
+# none
+#
+# Results:
+# log - namespace token for this service
+
+proc ::logger::servicecmd {service} {
+ variable services
+ if {[lsearch -exact $services $service] == -1} {
+ return -code error \
+ -errorcode [list LOGGER NO_SUCH_SERVICE] \
+ [::logger::mc "Service \"%s\" does not exist." $service]
+ }
+ return "::logger::tree::${service}"
+}
+
+# ::logger::import --
+#
+# Import the logging commands.
+#
+# Arguments:
+# service - name of the service.
+#
+# Side Effects:
+# creates aliases in the target namespace
+#
+# Results:
+# none
+
+proc ::logger::import {args} {
+ variable services
+
+ if {[llength $args] == 0 || [llength $args] > 7} {
+ return -code error \
+ -errorcode [list LOGGER WRONG_NUM_ARGS] \
+ [::logger::mc \
+ "Wrong # of arguments: \"logger::import ?-all?\
+ ?-force?\
+ ?-prefix prefix? ?-namespace namespace? service\""]
+ }
+
+ # process options
+ #
+ set import_all 0
+ set force 0
+ set prefix ""
+ set ns [uplevel 1 namespace current]
+ while {[llength $args] > 1} {
+ set opt [lindex $args 0]
+ set args [lrange $args 1 end]
+ switch -exact -- $opt {
+ -all { set import_all 1}
+ -prefix { set prefix [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -namespace {
+ set ns [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -force {
+ set force 1
+ }
+ default {
+ return -code error \
+ -errorcode [list LOGGER UNKNOWN_ARG] \
+ [::logger::mc \
+ "Unknown argument: \"%s\" :\nUsage:\
+ \"logger::import ?-all? ?-force?\
+ ?-prefix prefix? ?-namespace namespace? service\"" $opt]
+ }
+ }
+ }
+
+ #
+ # build the list of commands to import
+ #
+
+ set cmds [logger::levels]
+ lappend cmds "trace"
+ if {$import_all} {
+ lappend cmds setlevel enable disable logproc delproc services
+ lappend cmds servicename currentloglevel delete
+ }
+
+ #
+ # check the service argument
+ #
+
+ set service [lindex $args 0]
+ if {[lsearch -exact $services $service] == -1} {
+ return -code error \
+ -errorcode [list LOGGER NO_SUCH_SERVICE] \
+ [::logger::mc "Service \"%s\" does not exist." $service]
+ }
+
+ #
+ # setup the namespace for the import
+ #
+
+ set sourcens [logger::servicecmd $service]
+ set localns [uplevel 1 namespace current]
+
+ if {[string match ::* $ns]} {
+ set importns $ns
+ } else {
+ set importns ${localns}::$ns
+ }
+
+ # fake namespace exists for Tcl 8.2 - 8.3
+ if {![_nsExists $importns]} {
+ namespace eval $importns {}
+ }
+
+
+ #
+ # prepare the import
+ #
+
+ set imports ""
+ foreach cmd $cmds {
+ set cmdname ${importns}::${prefix}$cmd
+ set collision [llength [info commands $cmdname]]
+ if {$collision && !$force} {
+ return -code error \
+ -errorcode [list LOGGER IMPORT_NAME_EXISTS] \
+ [::logger::mc "can't import command \"%s\": already exists" $cmdname]
+ }
+ lappend imports ${importns}::${prefix}$cmd ${sourcens}::${cmd}
+ }
+
+ #
+ # and execute the aliasing after checking all is well
+ #
+
+ foreach {target source} $imports {
+ proc $target {args} "uplevel 1 \[linsert \$args 0 $source \]"
+ }
+}
+
+# ::logger::initNamespace --
+#
+# Creates a logger for the specified namespace and makes the log
+# commands available to said namespace as well. Allows the initial
+# setting of a default log level.
+#
+# Arguments:
+# ns - Namespace to initialize, is also the service name, modulo a ::-prefix
+# level - Initial log level, optional, defaults to 'warn'.
+#
+# Side Effects:
+# creates aliases in the target namespace
+#
+# Results:
+# none
+
+proc ::logger::initNamespace {ns {level {}}} {
+ set service [string trimleft $ns :]
+ if {$level == ""} {
+ # No user-specified level. Figure something out.
+ # - If the parent service exists then the 'logger::init'
+ # below will automatically inherit its level. Good enough.
+ # - Without a parent service go and use a default level of 'warn'.
+ set parent [string trimleft [namespace qualifiers $service] :]
+ set hasparent [expr {($parent != {}) && [_nsExists ::logger::tree::${parent}]}]
+ if {!$hasparent} {
+ set level warn
+ }
+ }
+
+ namespace eval $ns [list ::logger::init $service]
+ namespace eval $ns [list ::logger::import -force -all -namespace log $service]
+ if {$level != ""} {
+ namespace eval $ns [list log::setlevel $level]
+ }
+ return
+}
+
+# This procedure handles the "logger::trace status" command. Given no
+# arguments, returns a list of all procedures that have been registered
+# via "logger::trace add". Given one or more procedure names, it will
+# return 1 if all were registered, or 0 if any were not.
+
+proc ::logger::_trace_status { service procList } {
+ upvar #0 ::logger::tree::${service}::traceList traceList
+
+ # If no procedure names were given, just return the registered list
+
+ if {![llength $procList]} {
+ return $traceList
+ }
+
+ # Get caller's namespace for qualifying unqualified procedure names
+
+ set caller_ns [uplevel 1 namespace current]
+ set caller_ns [string trimright $caller_ns ":"]
+
+ # Search for any specified proc names that are *not* registered
+
+ foreach procName $procList {
+ # Make sure the procedure namespace is qualified
+
+ if {![string match "::*" $procName]} {
+ set procName ${caller_ns}::$procName
+ }
+
+ # Check if the procedure has been registered for tracing
+
+ if {[lsearch -exact $traceList $procName] == -1} {
+ return 0
+ }
+ }
+
+ return 1
+}
+
+# This procedure handles the "logger::trace on" command. If tracing
+# is turned off, it will enable Tcl trace handlers for all of the procedures
+# registered via "logger::trace add". Does nothing if tracing is already
+# turned on.
+
+proc ::logger::_trace_on { service } {
+ set tcl_version [package provide Tcl]
+
+ if {[package vcompare $tcl_version "8.4"] < 0} {
+ return -code error \
+ -errorcode [list LOGGER TRACE_NOT_AVAILABLE] \
+ [::logger::mc "execution tracing is not available in Tcl %s" $tcl_version]
+ }
+
+ namespace eval ::logger::tree::${service} {
+ if {!$tracingEnabled} {
+ set tracingEnabled 1
+ ::logger::_enable_traces $service $traceList
+ }
+ }
+
+ return 1
+}
+
+# This procedure handles the "logger::trace off" command. If tracing
+# is turned on, it will disable Tcl trace handlers for all of the procedures
+# registered via "logger::trace add", leaving them in the list so they
+# tracing on all of them can be enabled again with "logger::trace on".
+# Does nothing if tracing is already turned off.
+
+proc ::logger::_trace_off { service } {
+ namespace eval ::logger::tree::${service} {
+ if {$tracingEnabled} {
+ ::logger::_disable_traces $service $traceList
+ set tracingEnabled 0
+ }
+ }
+
+ return 1
+}
+
+# This procedure is used by the logger::trace add and remove commands to
+# process the arguments in a common fashion. If the -ns switch is given
+# first, this procedure will return a list of all existing procedures in
+# all of the namespaces given in remaining arguments. Otherwise, each
+# argument is taken to be either a pattern for a glob-style search of
+# procedure names or, failing that, a namespace, in which case this
+# procedure returns a list of all the procedures matching the given
+# pattern (or all in the named namespace, if no procedures match).
+
+proc ::logger::_trace_get_proclist { inputList } {
+ set procList ""
+
+ if {[string equal [lindex $inputList 0] "-ns"]} {
+ # Verify that at least one target namespace was supplied
+
+ set inputList [lrange $inputList 1 end]
+ if {![llength $inputList]} {
+ return -code error \
+ -errorcode [list LOGGER TARGET_MISSING] \
+ [::logger::mc "Must specify at least one namespace target"]
+ }
+
+ # Rebuild the argument list to contain namespace procedures
+
+ foreach namespace $inputList {
+ # Don't allow tracing of the logger (or child) namespaces
+
+ if {![string match "::logger::*" $namespace]} {
+ set nsProcList [::info procs ${namespace}::*]
+ set procList [concat $procList $nsProcList]
+ }
+ }
+ } else {
+ # Search for procs or namespaces matching each of the specified
+ # patterns.
+
+ foreach pattern $inputList {
+ set matches [uplevel 1 ::info proc $pattern]
+
+ if {![llength $matches]} {
+ if {[uplevel 1 namespace exists $pattern]} {
+ set matches [::info procs ${pattern}::*]
+ }
+
+ # Matched procs will be qualified due to above pattern
+
+ set procList [concat $procList $matches]
+ } elseif {[string match "::*" $pattern]} {
+ # Patterns were pre-qualified - add them directly
+
+ set procList [concat $procList $matches]
+ } else {
+ # Qualify each proc with the namespace it was in
+
+ set ns [uplevel 1 namespace current]
+ if {$ns == "::"} {
+ set ns ""
+ }
+ foreach proc $matches {
+ lappend procList ${ns}::$proc
+ }
+ }
+ }
+ }
+
+ return $procList
+}
+
+# This procedure handles the "logger::trace add" command. If the tracing
+# feature is enabled, it will enable the Tcl entry and leave trace handlers
+# for each procedure specified that isn't already being traced. Each
+# procedure is added to the list of procedures that the logger trace feature
+# should log when tracing is enabled.
+
+proc ::logger::_trace_add { service procList } {
+ upvar #0 ::logger::tree::${service}::traceList traceList
+
+ # Handle -ns switch and glob search patterns for procedure names
+
+ set procList [uplevel 1 [list logger::_trace_get_proclist $procList]]
+
+ # Enable tracing for each procedure that has not previously been
+ # specified via logger::trace add. If tracing is off, this will just
+ # store the name of the procedure for later when tracing is turned on.
+
+ foreach procName $procList {
+ if {[lsearch -exact $traceList $procName] == -1} {
+ lappend traceList $procName
+ ::logger::_enable_traces $service [list $procName]
+ }
+ }
+}
+
+# This procedure handles the "logger::trace remove" command. If the tracing
+# feature is enabled, it will remove the Tcl entry and leave trace handlers
+# for each procedure specified. Each procedure is removed from the list
+# of procedures that the logger trace feature should log when tracing is
+# enabled.
+
+proc ::logger::_trace_remove { service procList } {
+ upvar #0 ::logger::tree::${service}::traceList traceList
+
+ # Handle -ns switch and glob search patterns for procedure names
+
+ set procList [uplevel 1 [list logger::_trace_get_proclist $procList]]
+
+ # Disable tracing for each proc that previously had been specified
+ # via logger::trace add. If tracing is off, this will just
+ # remove the name of the procedure from the trace list so that it
+ # will be excluded when tracing is turned on.
+
+ foreach procName $procList {
+ set index [lsearch -exact $traceList $procName]
+ if {$index != -1} {
+ set traceList [lreplace $traceList $index $index]
+ ::logger::_disable_traces $service [list $procName]
+ }
+ }
+}
+
+# This procedure enables Tcl trace handlers for all procedures specified.
+# It is used both to enable Tcl's tracing for a single procedure when
+# removed via "logger::trace add", as well as to enable all traces
+# via "logger::trace on".
+
+proc ::logger::_enable_traces { service procList } {
+ upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled
+
+ if {$tracingEnabled} {
+ foreach procName $procList {
+ ::trace add execution $procName enter \
+ [list ::logger::_trace_enter $service]
+ ::trace add execution $procName leave \
+ [list ::logger::_trace_leave $service]
+ }
+ }
+}
+
+# This procedure disables Tcl trace handlers for all procedures specified.
+# It is used both to disable Tcl's tracing for a single procedure when
+# removed via "logger::trace remove", as well as to disable all traces
+# via "logger::trace off".
+
+proc ::logger::_disable_traces { service procList } {
+ upvar #0 ::logger::tree::${service}::tracingEnabled tracingEnabled
+
+ if {$tracingEnabled} {
+ foreach procName $procList {
+ ::trace remove execution $procName enter \
+ [list ::logger::_trace_enter $service]
+ ::trace remove execution $procName leave \
+ [list ::logger::_trace_leave $service]
+ }
+ }
+}
+
+########################################################################
+# Trace Handlers
+########################################################################
+
+# This procedure is invoked upon entry into a procedure being traced
+# via "logger::trace add" when tracing is enabled via "logger::trace on"
+# to log information about how the procedure was called.
+
+proc ::logger::_trace_enter { service cmd op } {
+ # Parse the command
+ set procName [uplevel 1 namespace origin [lindex $cmd 0]]
+ set args [lrange $cmd 1 end]
+
+ # Display the message prefix
+ set callerLvl [expr {[::info level] - 1}]
+ set calledLvl [::info level]
+
+ lappend message "proc" $procName
+ lappend message "level" $calledLvl
+ lappend message "script" [uplevel ::info script]
+
+ # Display the caller information
+ set caller ""
+ if {$callerLvl >= 1} {
+ # Display the name of the caller proc w/prepended namespace
+ catch {
+ set callerProcName [lindex [::info level $callerLvl] 0]
+ set caller [uplevel 2 namespace origin $callerProcName]
+ }
+ }
+
+ lappend message "caller" $caller
+
+ # Display the argument names and values
+ set argSpec [uplevel 1 ::info args $procName]
+ set argList ""
+ if {[llength $argSpec]} {
+ foreach argName $argSpec {
+ lappend argList $argName
+
+ if {$argName == "args"} {
+ lappend argList $args
+ break
+ } else {
+ lappend argList [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ }
+ }
+
+ lappend message "procargs" $argList
+ set message [list $op $message]
+
+ ::logger::tree::${service}::tracecmd $message
+}
+
+# This procedure is invoked upon leaving into a procedure being traced
+# via "logger::trace add" when tracing is enabled via "logger::trace on"
+# to log information about the result of the procedure call.
+
+proc ::logger::_trace_leave { service cmd status rc op } {
+ variable RETURN_CODES
+
+ # Parse the command
+ set procName [uplevel 1 namespace origin [lindex $cmd 0]]
+
+ # Gather the caller information
+ set callerLvl [expr {[::info level] - 1}]
+ set calledLvl [::info level]
+
+ lappend message "proc" $procName "level" $calledLvl
+ lappend message "script" [uplevel ::info script]
+
+ # Get the name of the proc being returned to w/prepended namespace
+ set caller ""
+ catch {
+ set callerProcName [lindex [::info level $callerLvl] 0]
+ set caller [uplevel 2 namespace origin $callerProcName]
+ }
+
+ lappend message "caller" $caller
+
+ # Convert the return code from numeric to verbal
+
+ if {$status < [llength $RETURN_CODES]} {
+ set status [lindex $RETURN_CODES $status]
+ }
+
+ lappend message "status" $status
+ lappend message "result" $rc
+
+ # Display the leave message
+
+ set message [list $op $message]
+ ::logger::tree::${service}::tracecmd $message
+
+ return 1
+}
+
diff --git a/tcllib/modules/log/logger.test b/tcllib/modules/log/logger.test
new file mode 100644
index 0000000..30b8f02
--- /dev/null
+++ b/tcllib/modules/log/logger.test
@@ -0,0 +1,1307 @@
+# -*- tcl -*-
+# Tests for the logger facility.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2002 by David N. Welton <davidw@dedasys.com>.
+# Copyright (c) 2004,2005 by Michael Schlenker <mic42@users.sourceforge.net>.
+#
+# $Id: logger.test,v 1.33 2011/12/21 21:28:50 mic42 Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal logger.tcl logger
+}
+
+# -------------------------------------------------------------------------
+
+test logger-1.0 {init basic} {
+ set log [logger::init global]
+ ${log}::delete
+ set log
+} {::logger::tree::global}
+
+test logger-1.1 {init sub-system} {
+ set log [logger::init global::subsystem]
+ ${log}::delete
+ # cleanup the leftover global log
+ ::logger::tree::global::delete
+ set log
+} {::logger::tree::global::subsystem}
+
+test logger-1.2 {instantiate main logger and child} {
+ set log1 [logger::init global]
+ set log2 [logger::init global::subsystem]
+ ${log2}::delete
+ ${log1}::delete
+ list $log1 $log2
+} {::logger::tree::global ::logger::tree::global::subsystem}
+
+test logger-1.3 {instantiate logger with problematic name} {
+ set log [logger::init foo::logger::tree::bar]
+ set services [logger::services]
+ # direct cleanup of logger namespace
+ foreach srv $services {
+ ::logger::tree::${srv}::delete
+ }
+ set services_post [logger::services]
+ list $log [lsort $services] $services_post
+} {::logger::tree::foo::logger::tree::bar {foo foo::logger foo::logger::tree foo::logger::tree::bar} {}}
+
+test logger-1.4 {check default loglevel} {
+ set log [logger::init foo]
+ set lvl [${log}::currentloglevel]
+ ${log}::delete
+ set lvl
+} {debug}
+
+test logger-1.5 {init with empty name} {
+ catch { logger::init {} } err
+ set err
+} {Service name invalid. May not consist only of : or be empty}
+
+test logger-1.6 {init with empty name} {
+ catch { logger::init : } err
+ set err
+} {Service name invalid. May not consist only of : or be empty}
+
+test logger-1.7 {init with empty name} {
+ catch { logger::init ::: } err
+ set err
+} {Service name invalid. May not consist only of : or be empty}
+
+test logger-2.0 {delete} {
+ set log [logger::init global]
+ ${log}::delete
+ catch {set ${log}::enabled} err
+ set err
+} {can't read "::logger::tree::global::enabled": no such variable}
+
+proc dellog {ns args} {
+ lappend ::results "$ns $args"
+}
+
+test logger-2.1 {delete + callback} {
+ set ::results {}
+ set log1 [logger::init global]
+ set log2 [logger::init global::subsystem]
+ ${log1}::delproc [list dellog $log1]
+ ${log2}::delproc [list dellog $log2]
+ ${log1}::delete
+ set ::results
+} {{::logger::tree::global::subsystem } {::logger::tree::global }}
+
+test logger-2.2 {delete + complex callback} {
+ set ::results {}
+ set log1 [logger::init global]
+ set log2 [logger::init global::subsystem]
+ ${log1}::delproc [list dellog $log1 sock1]
+ ${log2}::delproc [list dellog $log2 sock2]
+ ${log1}::delete
+ set ::results
+} {{::logger::tree::global::subsystem sock2} {::logger::tree::global sock1}}
+
+test logger-2.3 {delproc introspection} {
+ set log [logger::init global]
+ ${log}::delproc [list dellog $log sock1]
+ set cmd [${log}::delproc]
+ ${log}::delete
+ set cmd
+} {dellog ::logger::tree::global sock1}
+
+test logger-2.4 {delproc with nonexisting proc} {
+ set l [logger::init global]
+ ${l}::setlevel [lindex [logger::levels] 0]
+ set code [catch {${l}::delproc ""} msg]
+ ${l}::delete
+ list $code $msg
+
+} {1 {Invalid cmd '' - does not exist}}
+
+# The tests 3.0 and 3.1 are a bit weak..
+test logger-3.0 {log} {
+ set log [logger::init global]
+ ${log}::logproc error txt {set ::INFO $txt}
+ ${log}::error "Danger Will Robinson!"
+ ${log}::delete
+ set ::INFO
+} {Danger Will Robinson!}
+
+test logger-3.1 {log} {
+ set log [logger::init global]
+ ${log}::logproc warn txt {set ::INFO $txt}
+ ${log}::warn "Danger Will Robinson!"
+ ${log}::delete
+ set ::INFO
+} {Danger Will Robinson!}
+
+test logger-3.2 {log} {
+ set log [logger::init global]
+ ${log}::logproc info txt {
+ set ::INFO "Danger Will Robinson!"
+ }
+ ${log}::info "Alert"
+ ${log}::delete
+ set ::INFO
+} {Danger Will Robinson!}
+
+test logger-3.3 {log} {
+ set log [logger::init global]
+ ${log}::logproc warn txt {set ::INFO $txt}
+ ${log}::warn Danger Will Robinson!
+ ${log}::delete
+ set ::INFO
+} {Danger Will Robinson!}
+
+test logger-3.4 {log} {
+ set log1 [logger::init global]
+ ${log1}::logproc info txt {
+ set ::INFO "LOGGED: $txt"
+ }
+ set log2 [logger::init global::subsystem]
+ ${log1}::info boo
+ lappend retval [set ::INFO]
+ ${log2}::info BOO
+ lappend retval [set ::INFO]
+ ${log2}::delete
+ ${log1}::delete
+ set retval
+} {{LOGGED: boo} {LOGGED: BOO}}
+
+test logger-4.0 {disable} {
+ set ::INFO {no change}
+ set log [logger::init global]
+ ${log}::logproc info txt {
+ set ::INFO "Danger Will Robinson!"
+ }
+ ${log}::disable warn
+ ${log}::info "Alert"
+ ${log}::delete
+ set ::INFO
+} {no change}
+
+test logger-4.1 {disable + enable} {
+ set ::INFO {no change}
+ set log [logger::init global]
+ ${log}::logproc info txt {
+ set ::INFO "Danger Will Robinson!"
+ }
+ ${log}::disable warn
+ ${log}::enable info
+ ${log}::info "Alert"
+ ${log}::delete
+ set ::INFO
+} {Danger Will Robinson!}
+
+test logger-4.2 {disable all} {
+ set ::INFO {no change}
+ set log [logger::init global]
+ ${log}::logproc critical txt {
+ set ::INFO "Danger Will Robinson!"
+ }
+ ${log}::disable critical
+ ${log}::critical "Alert"
+ ${log}::delete
+ set ::INFO
+} {no change}
+
+test logger-4.3 {enable all} {
+ set ::INFO {no change}
+ set log [logger::init global]
+ ${log}::logproc debug txt {
+ set ::INFO "Danger Will Robinson!"
+ }
+ ${log}::enable debug
+ ${log}::debug "Alert"
+ ${log}::delete
+ set ::INFO
+} {Danger Will Robinson!}
+
+test logger-4.4 {enable bad args} {
+ set log [logger::init global]
+ catch { ${log}::enable badargs } err
+ ${log}::delete
+ set err
+} {Invalid level 'badargs' - levels are debug info notice warn error critical alert emergency}
+
+test logger-4.5 {test method inheritance} {
+ set log1 [logger::init global]
+ set log2 [logger::init global::child]
+ ${log1}::logproc notice txt {
+ set ::INFO "Danger Will Robinson!"
+ }
+ ${log2}::notice "alert"
+ ${log2}::delete
+ ${log1}::delete
+ set ::INFO
+} {Danger Will Robinson!}
+
+test logger-4.6 {disable bad args} {
+ set log [logger::init global]
+ catch { ${log}::disable badargs } err
+ ${log}::delete
+ set err
+} {Invalid level 'badargs' - levels are debug info notice warn error critical alert emergency}
+
+test logger-5.0 {setlevel command} {
+ set ::INFO ""
+ set log1 [logger::init global]
+ ${log1}::setlevel warn
+ ${log1}::logproc error txt {
+ lappend ::INFO "Error Message"
+ }
+ ${log1}::logproc warn txt {
+ lappend ::INFO "Warning Message"
+ }
+ ${log1}::logproc notice txt {
+ lappend ::INFO "Notice Message"
+ }
+ ${log1}::error "error"
+ ${log1}::warn "warn"
+ ${log1}::notice "notice"
+ ${log1}::delete
+ set ::INFO
+} {{Error Message} {Warning Message}}
+
+test logger-5.1 {setlevel, invalid level} {
+ set log [logger::init global]
+ set code [catch {${log}::setlevel badargs} msg]
+ ${log}::delete
+ list $code $msg
+} {1 {Invalid level 'badargs' - levels are debug info notice warn error critical alert emergency}}
+
+test logger-5.2 {setlevel, with children} {
+ set log1 [logger::init global]
+ ${log1}::setlevel notice
+ set log2 [logger::init global::child]
+ set ::DEBUGINFO ""
+ set ::WARNINFO ""
+ ${log1}::logproc debug txt {
+ lappend ::DEBUGINFO $txt
+ }
+ ${log1}::logproc warn txt {
+ lappend ::WARNINFO $txt
+ }
+ ${log1}::debug Parent
+ ${log1}::warn Parent
+ ${log2}::debug Child
+ ${log2}::warn Child
+ ${log1}::delete
+ list $::DEBUGINFO $::WARNINFO
+} {{} {Parent Child}}
+
+test logger-5.3 {global setlevel before logger::init} {
+ logger::setlevel error
+ set log1 [logger::init global]
+ set level [${log1}::currentloglevel]
+ ${log1}::delete
+ logger::setlevel debug
+ set level
+} {error}
+
+test logger-5.4 {global setlevel after logger::init} {
+ logger::setlevel error
+ set log1 [logger::init global]
+ set level [${log1}::currentloglevel]
+ ${log1}::delete
+ logger::setlevel debug
+ set level
+} {error}
+
+test logger-5.5 {global setlevel with wrong level} {
+ catch {logger::setlevel badargs} msg
+ set msg
+} {Invalid level 'badargs' - levels are debug info notice warn error critical alert emergency}
+
+test logger-5.6 {global setlevel before logger::init, see log} {
+ logger::setlevel error
+ set log1 [logger::init global]
+ set ::called 0
+ proc logp {txt} {
+ set ::called 1
+ }
+ ${log1}::logproc warn logp
+ set pname [${log1}::logproc warn]
+ ${log1}::warn $pname
+ ${log1}::delete
+ logger::setlevel debug
+ set result $::called
+ unset -nocomplain ::called
+ set result
+} {0}
+
+test logger-6.0 {levels command} {
+ logger::levels
+} {debug info notice warn error critical alert emergency}
+
+test logger-7.0 {currentloglevel} {
+ set result [list]
+ set log [logger::init global]
+ foreach lvl [logger::levels] {
+ ${log}::setlevel $lvl
+ lappend result [${log}::currentloglevel]
+ }
+ ${log}::delete
+ set result
+} {debug info notice warn error critical alert emergency}
+
+test logger-7.1 {currentloglevel, disable all} {
+ set log [logger::init global]
+ ${log}::disable emergency
+ set result [${log}::currentloglevel]
+ ${log}::delete
+ set result
+} {none}
+
+test logger-7.2 {currentloglevel, enable incremental} {
+ set results ""
+ set log [logger::init global]
+ ${log}::disable critical
+ ${log}::enable critical
+ lappend results [${log}::currentloglevel]
+ ${log}::enable debug
+ lappend results [${log}::currentloglevel]
+ ${log}::delete
+ set results
+} {critical debug}
+
+test logger-7.3 {currentloglevel, enable incremental} {
+ set results ""
+ set log [logger::init global]
+ ${log}::disable critical
+ ${log}::enable debug
+ lappend results [${log}::currentloglevel]
+ ${log}::enable critical
+ lappend results [${log}::currentloglevel]
+ ${log}::delete
+ set results
+} {debug debug}
+
+test logger-7.4 {currentloglevel, disable incremental} {
+ set results ""
+ set log [logger::init global]
+ ${log}::enable debug
+ lappend results [${log}::currentloglevel]
+ ${log}::disable emergency
+ lappend results [${log}::currentloglevel]
+ ${log}::disable debug
+ lappend results [${log}::currentloglevel]
+ ${log}::delete
+ set results
+} {debug none none}
+
+test logger-7.5 {currentloglevel, disable incremental} {
+ set results ""
+ set log [logger::init global]
+ ${log}::enable debug
+ lappend results [${log}::currentloglevel]
+ ${log}::disable debug
+ lappend results [${log}::currentloglevel]
+ ${log}::disable emergency
+ lappend results [${log}::currentloglevel]
+ ${log}::delete
+ set results
+} {debug info none}
+
+test logger-8.0 {logproc with existing proc, non existing proc} {
+ set log [logger::init global]
+ catch { ${log}::logproc warn NoSuchProc } msg
+ ${log}::delete
+ set msg
+} {Invalid cmd 'NoSuchProc' - does not exist}
+
+test logger-8.1 {logproc with existing proc, introspection} {
+ set log [logger::init global]
+ catch { ${log}::logproc warn } msg
+ ${log}::delete
+ set msg
+} {::logger::tree::global::warncmd}
+
+test logger-8.2 {logproc with existing proc} {
+ set ::INFO ""
+ set log [logger::init global]
+ proc errorlogproc {txt} {
+ lappend ::INFO "Error Message: $txt"
+ }
+ set msg [info commands errorlogproc]
+ ${log}::logproc error errorlogproc
+ ${log}::error "error"
+ ${log}::error "second error"
+ ${log}::delete
+ rename errorlogproc ""
+ list $msg $::INFO
+} {errorlogproc {{Error Message: error} {Error Message: second error}}}
+
+test logger-8.3 {logproc with args and body} {
+ set ::INFO ""
+ set log [logger::init global]
+ ${log}::logproc error txt {lappend ::INFO "Error Message: $txt"}
+ ${log}::error "error"
+ ${log}::error "second error"
+ ${log}::delete
+ set ::INFO
+} {{Error Message: error} {Error Message: second error}}
+
+test logger-8.4 {logproc with existing proc, survive level switching} {
+ set ::INFO ""
+ set log [logger::init global]
+ proc errorlogproc {txt} {
+ lappend ::INFO "Error Message: $txt"
+ }
+ ${log}::logproc error errorlogproc
+ ${log}::error "error"
+ ${log}::setlevel critical
+ ${log}::error "this should not be in the logfile"
+ ${log}::setlevel notice
+ ${log}::error "second error"
+ ${log}::delete
+ rename errorlogproc ""
+ set ::INFO
+} {{Error Message: error} {Error Message: second error}}
+
+test logger-8.5 {logproc with existing proc, introspection} {
+ set ::INFO ""
+ set log [logger::init global]
+ proc errorlogproc {txt} {
+ lappend ::INFO "Error Message: $txt"
+ }
+ set msg [info commands errorlogproc]
+ ${log}::logproc error errorlogproc
+ set cmd [${log}::logproc error]
+ ${log}::delete
+ rename errorlogproc ""
+ list $msg $cmd
+} {errorlogproc errorlogproc}
+
+test logger-8.6 {logproc with args and body, introspection} {
+ set ::INFO ""
+ set log [logger::init global]
+ ${log}::logproc error txt {lappend ::INFO "Error Message: $txt"}
+ set cmd [${log}::logproc error]
+ ${log}::delete
+ set cmd
+} {::logger::tree::global::errorcustomcmd}
+
+test logger-8.7 {logproc with too many args} {
+ set log [logger::init global]
+ set code [catch {${log}::logproc error too many args]} msg]
+ ${log}::delete
+ list $code $msg
+} [list 1 [subst -novariable -nocommands \
+ "Usage: \${log}::logproc level ?cmd?\nor \${log}::logproc level argname body"]]
+
+test logger-9.0 {services subcommand} {
+ set log [logger::init global]
+ set result [logger::services]
+ ${log}::delete
+ set result
+} {global}
+
+test logger-9.1 {services subcommand, no child services} {
+ set log [logger::init global]
+ set services [${log}::services]
+ ${log}::delete
+ set services
+} {}
+
+test logger-9.2 {services subcommand, children services} {
+ set log [logger::init global]
+ set child [logger::init global::child]
+ set result [list [logger::services] [${log}::services] [${child}::services]]
+ ${log}::delete
+ set result
+} [list [list global global::child] global::child {}]
+
+test logger-10.0 {servicecmd test} {
+ set log [logger::init global]
+ set cmd [logger::servicecmd global]
+ ${log}::delete
+ list $log $cmd
+} {::logger::tree::global ::logger::tree::global}
+
+test logger-10.1 {servicecmd, nonexistent service} {
+ set code [catch {logger::servicecmd nonexistant} msg]
+ list $code $msg
+} {1 {Service "nonexistant" does not exist.}}
+
+test logger-11.0 {servicename subcommand} {
+ set log [logger::init global]
+ set name [${log}::servicename]
+ ${log}::delete
+ set name
+} {global}
+
+test logger-12.0 {import subcommand} {
+ set retval ""
+ set log [logger::init global]
+ ${log}::logproc info txt {
+ set ::INFO "LOGGED: $txt"
+ }
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace eval ::foo {
+ logger::import global
+ info "In"
+ }
+ lappend retval $::INFO
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace delete ::foo
+ ${log}::delete
+ set retval
+
+} {{LOGGED: Out} {LOGGED: In} {LOGGED: Out}}
+
+test logger-12.1 {import subcommand} {
+ set retval ""
+ set log [logger::init global]
+ ${log}::logproc info txt {
+ set ::INFO "LOGGED: $txt"
+ }
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace eval ::foo {
+ logger::import -prefix log_ global
+ log_info "In"
+ }
+ lappend retval $::INFO
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace delete ::foo
+ ${log}::delete
+ set retval
+} {{LOGGED: Out} {LOGGED: In} {LOGGED: Out}}
+
+test logger-12.2 {import subcommand} {
+ set retval ""
+ set log [logger::init global]
+ ${log}::logproc info txt {
+ set ::INFO "LOGGED: $txt"
+ }
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace eval ::bar { }
+ namespace eval ::foo {
+ logger::import -namespace ::bar global
+ ::bar::info "In"
+ }
+ lappend retval $::INFO
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace delete ::foo
+ namespace delete ::bar
+ ${log}::delete
+ set retval
+} {{LOGGED: Out} {LOGGED: In} {LOGGED: Out}}
+
+test logger-12.3 {import subcommand} {
+ set retval ""
+ set log [logger::init global]
+ ${log}::logproc info txt {
+ set ::INFO "LOGGED: $txt"
+ }
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace eval ::bar { }
+ namespace eval ::foo {
+ logger::import -prefix log_ -namespace ::bar global
+ ::bar::log_info "In"
+ }
+ lappend retval $::INFO
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace delete ::foo
+ namespace delete ::bar
+ ${log}::delete
+ set retval
+} {{LOGGED: Out} {LOGGED: In} {LOGGED: Out}}
+
+test logger-12.4 {import subcommand} {
+ set retval ""
+ set log [logger::init global]
+ ${log}::logproc info txt {
+ set ::INFO "LOGGED: $txt"
+ }
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace eval ::foo {
+ logger::import -all global
+ info "In"
+ set ::cmds [lsort [::info commands ::foo::*]]
+ }
+ lappend retval $::INFO
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace delete ::foo
+ ${log}::delete
+ list $retval $::cmds
+
+} {{{LOGGED: Out} {LOGGED: In} {LOGGED: Out}} {::foo::alert ::foo::critical\
+ ::foo::currentloglevel ::foo::debug ::foo::delete ::foo::delproc\
+ ::foo::disable ::foo::emergency ::foo::enable ::foo::error ::foo::info\
+ ::foo::logproc ::foo::notice ::foo::servicename ::foo::services\
+ ::foo::setlevel ::foo::trace ::foo::warn}}
+
+test logger-12.5 {import subcommand} {
+ set retval ""
+ set log [logger::init global]
+ ${log}::logproc info txt {
+ set ::INFO "LOGGED: $txt"
+ }
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace eval ::bar { }
+ namespace eval ::foo {
+ logger::import -all -namespace ::bar global
+ ::bar::info "In"
+ set ::cmds [lsort [::info commands ::bar::*]]
+ }
+ lappend retval $::INFO
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace delete ::foo
+ namespace delete ::bar
+ ${log}::delete
+
+ list $retval $::cmds
+
+} {{{LOGGED: Out} {LOGGED: In} {LOGGED: Out}} {::bar::alert ::bar::critical\
+ ::bar::currentloglevel ::bar::debug ::bar::delete ::bar::delproc\
+ ::bar::disable ::bar::emergency ::bar::enable ::bar::error ::bar::info\
+ ::bar::logproc ::bar::notice ::bar::servicename ::bar::services\
+ ::bar::setlevel ::bar::trace ::bar::warn}}
+
+test logger-12.6 {import subcommand} {
+ set retval ""
+ set log [logger::init global]
+ ${log}::logproc info txt {
+ set ::INFO "LOGGED: $txt"
+ }
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace eval ::bar {
+ proc services {} {}
+ }
+ namespace eval ::foo {
+ set ::code [catch {logger::import -all -namespace ::bar global} ::msg]
+ }
+ namespace delete ::foo
+ namespace delete ::bar
+ ${log}::delete
+
+ list $::code $::msg
+
+} [list 1 "can't import command \"::bar::services\": already exists" ]
+
+test logger-12.7 {import subcommand} {
+ set retval ""
+ set log [logger::init global]
+ ${log}::logproc info txt {
+ set ::INFO "LOGGED: $txt"
+ }
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace eval ::bar {
+ proc services {} {}
+ }
+ namespace eval ::foo {
+ set ::code [catch {logger::import -all -force -namespace ::bar global} ::msg]
+ }
+ namespace delete ::foo
+ namespace delete ::bar
+ ${log}::delete
+
+ list $::code $::msg
+
+} [list 0 "" ]
+
+test logger-12.8 {import subcommand} {
+ set retval ""
+ set log [logger::init global]
+ ${log}::logproc info txt {
+ set ::INFO "LOGGED: $txt"
+ }
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace eval ::bar { }
+ namespace eval ::foo {
+ logger::import -all -namespace bar global
+ ::foo::bar::info "In"
+ set ::cmds [lsort [::info commands ::foo::bar::*]]
+ }
+ lappend retval $::INFO
+ ${log}::info "Out"
+ lappend retval $::INFO
+ namespace delete ::foo
+ namespace delete ::bar
+ ${log}::delete
+
+ list $retval $::cmds
+
+} {{{LOGGED: Out} {LOGGED: In} {LOGGED: Out}} {::foo::bar::alert\
+ ::foo::bar::critical ::foo::bar::currentloglevel ::foo::bar::debug\
+ ::foo::bar::delete ::foo::bar::delproc ::foo::bar::disable\
+ ::foo::bar::emergency ::foo::bar::enable ::foo::bar::error\
+ ::foo::bar::info ::foo::bar::logproc ::foo::bar::notice\
+ ::foo::bar::servicename ::foo::bar::services\
+ ::foo::bar::setlevel ::foo::bar::trace ::foo::bar::warn}}
+
+test logger-12.9 {import subcommand, errors} {
+ set code [catch {
+ logger::import
+ } msg]
+ list $code $msg
+} {1 {Wrong # of arguments: "logger::import ?-all? ?-force? ?-prefix prefix? ?-namespace namespace? service"}}
+
+test logger-12.10 {import subcommand, errors} {
+ set code [catch {
+ logger::import 1 2 3 4 5 6 7 8
+ } msg]
+ list $code $msg
+} {1 {Wrong # of arguments: "logger::import ?-all? ?-force? ?-prefix prefix? ?-namespace namespace? service"}}
+
+test logger-12.11 {import subcommand, errors} {
+ set code [catch {
+ logger::import -foo 1
+ } msg]
+ list $code $msg
+} {1 {Unknown argument: "-foo" :
+Usage: "logger::import ?-all? ?-force? ?-prefix prefix? ?-namespace namespace? service"}}
+
+test logger-12.12 {import subcommand, errors} {
+ set code [catch {
+ logger::import foo
+ } msg]
+ list $code $msg
+} {1 {Service "foo" does not exist.}}
+
+test logger-12.13 {import subcommand, errors} {
+ set l [logger::init global]
+ namespace eval ::foo {
+ proc debug {args} { }
+ }
+ set code [catch {
+ logger::import -namespace ::foo global
+ } msg]
+ list $code $msg
+} {1 {can't import command "::foo::debug": already exists}}
+
+test logger-13.0 {test for correct servicename, Bug 1102131} {
+ set ::INFO ""
+ set l1 [logger::init global]
+ set l2 [logger::init global::child]
+ set l3 [logger::init global::child::child]
+ ${l1}::logproc info txt {
+ variable service
+ lappend ::INFO $service $txt
+ }
+ ${l1}::info global
+ ${l2}::info global::child
+ ${l3}::info global::child::child
+ ${l1}::delete
+ set ::INFO
+} [list global global global::child global::child global::child::child global::child::child]
+
+test logger-13.1 {test for correct servicename, Bug 1102131} {
+ set ::INFO ""
+ set ::INFO2 ""
+ set l1 [logger::init global]
+ set l2 [logger::init global::child]
+ set l3 [logger::init global::child::child]
+ ${l1}::logproc info txt {
+ variable service
+ lappend ::INFO $service $txt
+ }
+ ${l2}::logproc info txt {
+ variable service
+ lappend ::INFO2 $service $txt
+ }
+ ${l1}::info global
+ ${l2}::info global::child
+ ${l3}::info global::child::child
+ ${l1}::delete
+ list $::INFO $::INFO2
+} [list [list global global] [list global::child global::child global::child::child global::child::child] ]
+
+test logger-13.2 {test for correct servicename, Bug 1102131} {
+ set ::INFO ""
+ set l1 [logger::init global]
+ set l2 [logger::init global::child]
+ set l3 [logger::init global::child::child]
+ ${l1}::logproc info txt {
+ variable service
+ lappend ::INFO $service $txt
+ }
+ namespace eval ::foo {
+ logger::import -force -all -namespace log global::child::child
+ }
+
+ ${l1}::info global
+ ${l2}::info global::child
+ foo::log::info global::child::child
+ ${l1}::delete
+ namespace delete ::foo
+ set ::INFO
+} [list global global global::child global::child global::child::child global::child::child]
+
+test logger-13.3 {test for correct servicename, Bug 1102131} {
+ set ::INFO ""
+ set l1 [logger::init global]
+ set l2 [logger::init global::child]
+ set l3 [logger::init global::child::child]
+ ${l1}::logproc info txt {
+ variable service
+ lappend ::INFO $service $txt
+ }
+ namespace eval ::foo {
+ logger::import -force -namespace log global::child::child
+ }
+
+ ${l1}::info global
+ ${l2}::info global::child
+ foo::log::info global::child::child
+ ${l1}::delete
+ namespace delete ::foo
+ set ::INFO
+} [list global global global::child global::child global::child::child global::child::child]
+
+test logger-13.4 {test for correct servicename, Bug 1102131} {
+ set ::INFO ""
+ set l1 [logger::init global]
+ set l2 [logger::init global::child]
+ set l3 [logger::init global::child::child]
+ ${l1}::logproc info txt {
+ variable service
+ lappend ::INFO $service $txt
+ }
+ namespace eval ::foo {
+ logger::import -force -all -prefix log_ -namespace log global::child::child
+ }
+
+ ${l1}::info global
+ ${l2}::info global::child
+ foo::log::log_info global::child::child
+ ${l1}::delete
+ namespace delete ::foo
+ set ::INFO
+} [list global global global::child global::child global::child::child global::child::child]
+
+test logger-13.5 {test for correct servicename, Bug 1102131} {
+ set ::INFO ""
+ set l1 [logger::init global]
+ set l2 [logger::init global::child]
+ set l3 [logger::init global::child::child]
+ ${l1}::logproc info txt {
+ variable service
+ lappend ::INFO $service $txt
+ }
+ namespace eval ::foo {
+ logger::import -force -prefix log_ -namespace log global::child::child
+ }
+
+ ${l1}::info global
+ ${l2}::info global::child
+ foo::log::log_info global::child::child
+ ${l1}::delete
+ namespace delete ::foo
+ set ::INFO
+} [list global global global::child global::child global::child::child global::child::child]
+
+test logger-13.6 {test for correct servicename, Bug 1102131} {
+ set ::INFO ""
+ set l1 [logger::init global]
+ set l2 [logger::init global::child]
+ set l3 [logger::init global::child::child]
+ ${l1}::logproc info txt {
+ variable service
+ lappend ::INFO $service $txt
+ }
+ namespace eval ::foo {
+ logger::import -force -prefix log_ global::child::child
+ }
+
+ ${l1}::info global
+ ${l2}::info global::child
+ foo::log_info global::child::child
+ ${l1}::delete
+ namespace delete ::foo
+ set ::INFO
+} [list global global global::child global::child global::child::child global::child::child]
+
+test logger-13.7 {test for correct servicename, Bug 1102131} {
+ set ::INFO ""
+ set l1 [logger::init global]
+ set l2 [logger::init global::child]
+ set l3 [logger::init global::child::child]
+ ${l1}::logproc info txt {
+ variable service
+ lappend ::INFO $service $txt
+ }
+ namespace eval ::foo {
+ logger::import -force -all -prefix log_ global::child::child
+ }
+
+ ${l1}::info global
+ ${l2}::info global::child
+ foo::log_info global::child::child
+ ${l1}::delete
+ namespace delete ::foo
+ set ::INFO
+} [list global global global::child global::child global::child::child global::child::child]
+
+test logger-13.8 {test for logproc interations with childs} {
+ set l1 [logger::init global]
+ set l2 [logger::init global::child]
+ set l3 [logger::init global::child::child]
+
+ namespace eval ::logtest {
+ proc mylogproc {args} {
+ variable len
+ lappend len [llength $args]
+ }
+ }
+ ${l1}::logproc info ::logtest::mylogproc
+ ${l1}::info global
+ ${l2}::info global::child
+ ${l3}::info global::child::child
+ ${l1}::delete
+ set len $::logtest::len
+ namespace delete ::logtest
+ set len
+} [list 1 1 1]
+
+
+
+test logger-14.1 {test for a clean call stack for logprocs} {
+ namespace eval ::logtest {
+ proc mylog {txt} { set ::logtest::stack [info level]}
+ proc dolog {logger} {
+ ${logger}::info foo
+ }
+ }
+ set l1 [logger::init global]
+ ${l1}::logproc info ::logtest::mylog
+ ::logtest::dolog $l1
+ set val $::logtest::stack
+ namespace delete ::logtest
+ ${l1}::delete
+ set val
+} 2
+
+test logger-14.2 {test for a clean call stack for logprocs} {
+ namespace eval ::logtest {
+ proc mylog {txt} { set ::logtest::stack [list [info level 1] [info level 2]]}
+ proc dolog {logger} {
+ ${logger}::info foo
+ }
+ }
+ set l1 [logger::init global]
+ ${l1}::logproc info ::logtest::mylog
+ ::logtest::dolog $l1
+ set val $::logtest::stack
+ namespace delete ::logtest
+ ${l1}::delete
+ set val
+} {{::logtest::dolog ::logger::tree::global} {::logtest::mylog foo}}
+
+test logger-14.3 {test for a clean call stack for logprocs} {
+ namespace eval ::logtest {
+ proc mylog {txt} { set ::logtest::stack [list [info level 1] [info level 2]]}
+ }
+ set l1 [logger::init global]
+ ${l1}::logproc info ::logtest::mylog
+ namespace eval ::foo {
+ logger::import -force -all -prefix log_ global
+ proc dolog {logger} {
+ log_info foo
+ }
+ }
+ ::foo::dolog $l1
+ set val $::logtest::stack
+ namespace delete ::logtest
+ namespace delete ::foo
+ ${l1}::delete
+ set val
+} {{::foo::dolog ::logger::tree::global} {::logtest::mylog foo}}
+
+test logger-14.4 {test for a clean call stack for logprocs} {
+ namespace eval ::logtest {
+ proc mylog {txt} { set ::logtest::stack [list [info level 1] [info level 2]]
+ set ::logtest::info [uplevel 1 set someinfo]
+ }
+ proc dolog {logger} {
+ set someinfo bar
+ ${logger}::info foo
+ }
+ }
+ set l1 [logger::init global]
+ ${l1}::logproc info ::logtest::mylog
+ ::logtest::dolog $l1
+ set val [list $::logtest::stack $::logtest::info]
+ namespace delete ::logtest
+ ${l1}::delete
+ set val
+} {{{::logtest::dolog ::logger::tree::global} {::logtest::mylog foo}} bar}
+
+
+test logger-15.0 {test for logger levelchange callbacks} {
+ namespace eval ::logtest {
+ proc lvlchange {old new} {
+ variable changes
+ lappend changes [list $old $new]
+ return
+ }
+ }
+ set l [logger::init global]
+ set default [list [${l}::lvlchangeproc]]
+ ${l}::lvlchangeproc ::logtest::lvlchange
+ lappend default [${l}::lvlchangeproc]
+ ${l}::delete
+ namespace delete ::logtest
+ set default
+} {::logger::tree::global::no-op ::logtest::lvlchange}
+
+test logger-15.1 {test for logger levelchange callbacks} {
+ set l [logger::init global]
+ set ok [catch {${l}::lvlchangeproc a b} msg]
+ ${l}::delete
+ list $ok $msg
+} [list 1 {Wrong # of arguments. Usage: ${log}::lvlchangeproc ?cmd?} ]
+
+test logger-15.2 {test for logger levelchange callbacks} {
+ namespace eval ::logtest {
+ proc lvlchange {old new} {
+ variable changes
+ lappend changes [list $old $new]
+ return
+ }
+ }
+ set l [logger::init global]
+ ${l}::setlevel [lindex [logger::levels] 0]
+ ${l}::lvlchangeproc ::logtest::lvlchange
+ set rlvl [list]
+ foreach {lvl} [logger::levels] {
+ ${l}::setlevel $lvl
+ set rlvl [linsert $rlvl 0 $lvl]
+ }
+ foreach {lvl} $rlvl {
+ ${l}::setlevel $lvl
+ }
+ set changes $::logtest::changes
+ ${l}::delete
+ namespace delete ::logtest
+ set changes
+} [list {debug info} {info notice} {notice warn} {warn error} {error critical} \
+ {critical alert} {alert emergency} {emergency alert} {alert critical} \
+ {critical error} {error warn} {warn notice} {notice info} {info debug}]
+
+test logger-15.3 {test for logger levelchange callbacks} {
+ namespace eval ::logtest {
+ proc lvlchange {old new} {
+ variable changes
+ lappend changes [list $old $new]
+ return
+ }
+ }
+ set l [logger::init global]
+ ${l}::setlevel [lindex [logger::levels] 0]
+ set lc [logger::init global::child]
+ ${lc}::lvlchangeproc ::logtest::lvlchange
+ set rlvl [list]
+ foreach {lvl} [logger::levels] {
+ ${l}::setlevel $lvl
+ set rlvl [linsert $rlvl 0 $lvl]
+ }
+ foreach {lvl} $rlvl {
+ ${l}::setlevel $lvl
+ }
+ set changes $::logtest::changes
+ ${l}::delete
+ namespace delete ::logtest
+ set changes
+} [list {debug info} {info notice} {notice warn} {warn error} {error critical} \
+ {critical alert} {alert emergency} {emergency alert} {alert critical} \
+ {critical error} {error warn} {warn notice} {notice info} {info debug}]
+
+test logger-15.4 {test for logger with empty levelchange callback} {
+ set ::gotcalled 0
+ proc ::debug {args} {set ::gotcalled 1}
+ set l [logger::init global]
+ ${l}::setlevel [lindex [logger::levels] 0]
+ set code [catch {${l}::lvlchangeproc ""} msg]
+ ${l}::setlevel warn
+ ${l}::delete
+ rename ::debug ""
+ list $::gotcalled $code $msg
+} {0 1 {Invalid cmd '' - does not exist}}
+
+test logger-15.5 {test for strange callback names, glob pattern ::*} {
+ set ::gotcalled 0
+ proc ::* {args} {set ::gotcalled 1}
+ set l [logger::init global]
+ ${l}::setlevel [lindex [logger::levels] 0]
+ set code [catch {${l}::lvlchangeproc ::*} msg]
+ ${l}::setlevel warn
+ ${l}::delete
+ rename ::* ""
+ list $::gotcalled $code $msg
+} {1 0 ::*}
+
+test logger-15.6 {test for other [] glob pattern} {
+ set ::gotcalled 0
+ proc ::\[info\] {args} {set ::gotcalled 1}
+ set l [logger::init global]
+ ${l}::setlevel [lindex [logger::levels] 0]
+ set code [catch {${l}::lvlchangeproc {::[info]}} msg]
+ ${l}::setlevel warn
+ ${l}::delete
+ rename {::[info]} ""
+ list $::gotcalled $code $msg
+} {1 0 {::[info]}}
+
+test logger-15.7 {test for spaces in commands support} {
+ set ::gotcalled 0
+ proc what\ a\ stupid\ proc {args} {set ::gotcalled 1}
+ set l [logger::init global]
+ ${l}::setlevel [lindex [logger::levels] 0]
+ set code [catch {${l}::lvlchangeproc [list {what a stupid proc}]} msg]
+ ${l}::setlevel warn
+ ${l}::delete
+ rename {what a stupid proc} ""
+ list $::gotcalled $code $msg
+} {1 0 {{what a stupid proc}}}
+
+test logger-15.8 {test for other []* glob pattern} {
+ set ::gotcalled 0
+ proc ::\[info\]* {args} {set ::gotcalled 1}
+ set l [logger::init global]
+ ${l}::setlevel [lindex [logger::levels] 0]
+ set code [catch {${l}::lvlchangeproc {::[info]*}} msg]
+ ${l}::setlevel warn
+ ${l}::delete
+ rename {::[info]*} ""
+ list $::gotcalled $code $msg
+} {1 0 {::[info]*}}
+
+test logger-15.9 {test for other []* glob pattern} {
+ set ::gotcalled 0
+ set l [logger::init global]
+ ${l}::setlevel [lindex [logger::levels] 0]
+ set code [catch {${l}::lvlchangeproc {::[info]*}} msg]
+ ${l}::setlevel warn
+ ${l}::delete
+ list $::gotcalled $code $msg
+} {0 1 {Invalid cmd '::[info]*' - does not exist}}
+
+test logger-15.10 {test for non normalized namespace names} {
+ set ::gotcalled 0
+ namespace eval ::logtest {}
+ proc ::logtest::test {args} {set ::gotcalled 1}
+ set l [logger::init global]
+ ${l}::setlevel [lindex [logger::levels] 0]
+ set code [catch {${l}::lvlchangeproc {::::logtest:::test}} msg]
+ ${l}::setlevel warn
+ ${l}::delete
+ namespace delete ::logtest
+ list $::gotcalled $code $msg
+} {1 0 ::::logtest:::test}
+
+test logger-15.11 {test for non normalized namespace names} {
+ set ::gotcalled 0
+ namespace eval ::logtest {}
+ set l [logger::init global]
+ ${l}::setlevel [lindex [logger::levels] 0]
+ set code [catch {${l}::lvlchangeproc {::::logtest:::test}} msg]
+ ${l}::setlevel warn
+ ${l}::delete
+ namespace delete ::logtest
+ list $::gotcalled $code $msg
+} {0 1 {Invalid cmd '::::logtest:::test' - does not exist}}
+
+test logger-15.12 {test for namespace with glob pattern} {
+ set ::gotcalled 0
+ namespace eval ::logtest {}
+ namespace eval ::logtest::* {}
+ proc ::logtest::*::test {args} {set ::gotcalled 1}
+ set l [logger::init global]
+ ${l}::setlevel [lindex [logger::levels] 0]
+ set code [catch {${l}::lvlchangeproc {::logtest::*::test}} msg]
+ ${l}::setlevel warn
+ ${l}::delete
+ namespace delete ::logtest
+ list $::gotcalled $code $msg
+} {1 0 ::logtest::*::test}
+
+test logger-15.13 {test for namespace with glob pattern} {
+ set ::gotcalled 0
+ namespace eval ::logtest {}
+ namespace eval ::logtest::* {}
+ set l [logger::init global]
+ ${l}::setlevel [lindex [logger::levels] 0]
+ set code [catch {${l}::lvlchangeproc {::logtest::*::test}} msg]
+ ${l}::setlevel warn
+ ${l}::delete
+ namespace delete ::logtest
+ list $::gotcalled $code $msg
+} {0 1 {Invalid cmd '::logtest::*::test' - does not exist}}
+
+# # ## ### ##### ######## ############# #####################
+## Ticket cf775f72ef - initNamespace, level inheritance.
+
+test logger-17.0 {initNamespace, wrong args, not enough} {
+ catch {
+ logger::initNamespace
+ } msg
+ set msg
+} {wrong # args: should be "logger::initNamespace ns ?level?"}
+
+test logger-17.1 {initNamespace, wrong args, too many} {
+ catch {
+ logger::initNamespace ::foo error X
+ } msg
+ set msg
+} {wrong # args: should be "logger::initNamespace ns ?level?"}
+
+test logger-17.2 {initNamespace, explicit level} {
+ namespace eval ::foo {}
+ logger::initNamespace ::foo error
+ set lvl [::foo::log::currentloglevel]
+ ::foo::log::delete
+ namespace delete ::foo
+ set lvl
+} error
+
+test logger-17.3 {initNamespace, no parent, default log level} {
+ namespace eval ::foo {}
+ logger::initNamespace ::foo
+ set lvl [::foo::log::currentloglevel]
+ ::foo::log::delete
+ namespace delete ::foo
+ set lvl
+} warn
+
+test logger-17.4 {initNamespace, parent, inherit log level} {
+ namespace eval ::foo {}
+ namespace eval ::foo::bar {}
+ logger::initNamespace ::foo error
+ logger::initNamespace ::foo::bar
+ set lvl [::foo::bar::log::currentloglevel]
+ ::foo::bar::log::delete
+ ::foo::log::delete
+ namespace delete ::foo
+ set lvl
+} error
+
+# # ## ### ##### ######## ############# #####################
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/log/loggerAppender.man b/tcllib/modules/log/loggerAppender.man
new file mode 100644
index 0000000..9e334ab
--- /dev/null
+++ b/tcllib/modules/log/loggerAppender.man
@@ -0,0 +1,65 @@
+[comment {-*- tcl -*- doctools manpage}]
+[comment {$Id: loggerAppender.man,v 1.6 2009/01/29 06:16:19 andreas_kupries Exp $}]
+[manpage_begin logger::appender n 1.2]
+[keywords appender]
+[keywords logger]
+[copyright {2005 Aamer Akhter <aakhter@cisco.com>}]
+[moddesc {Object Oriented logging facility}]
+[titledesc {Collection of predefined appenders for logger}]
+[category {Programming tools}]
+[require Tcl 8.2]
+[require logger::appender [opt 1.2]]
+[description]
+
+This package provides a predefined set of logger templates.
+
+[list_begin definitions]
+
+[call [cmd ::logger::appender::console] \
+ [option -level] [arg level] \
+ [option -service] [arg service] [opt [arg options]...] \
+]
+
+[list_begin options]
+
+[opt_def -level level]
+
+Name of the level to fill in as "priority" in the log procedure.
+
+[opt_def -service service]
+
+Name of the service to fill in as "category" in the log procedure.
+
+[opt_def -appenderArgs appenderArgs]
+
+Any additional arguments for the log procedure in list form
+
+[opt_def -conversionPattern conversionPattern]
+
+The log pattern to use (see [cmd logger::utils::createLogProc] for the
+allowed substitutions).
+
+[opt_def -procName procName]
+
+Explicitly set the name of the created procedure.
+
+[opt_def -procNameVar procNameVar]
+
+Name of the variable to set in the calling context. This variable will
+contain the name of the procedure.
+
+[list_end]
+
+[call [cmd ::logger::appender::colorConsole] \
+ [option -level] [arg level] \
+ [option -service] [arg service] [opt [arg options]...] \
+]
+
+See [cmd ::logger::appender::colorConsole] for a description of the
+applicable options.
+
+[list_end]
+
+[vset CATEGORY logger]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/log/loggerAppender.tcl b/tcllib/modules/log/loggerAppender.tcl
new file mode 100644
index 0000000..6bbd24a
--- /dev/null
+++ b/tcllib/modules/log/loggerAppender.tcl
@@ -0,0 +1,449 @@
+##Library Header
+#
+# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::appender
+#
+# Purpose:
+# collection of appenders for tcllib logger
+#
+# Author:
+# Aamer Akhter / aakhter@cisco.com
+#
+# Support Alias:
+# aakhter@cisco.com
+#
+# Usage:
+# package require logger::appender
+#
+# Description:
+# set of logger templates
+#
+# Requirements:
+# package require logger
+# package require md5
+#
+# Variables:
+# namespace ::loggerExtension::
+# id: CVS ID: keyword extraction
+# version: current version of package
+# packageDir: directory where package is located
+# log: instance log
+#
+# Notes:
+# 1.
+#
+# Keywords:
+#
+#
+# Category:
+#
+#
+# End of Header
+
+package require md5
+
+namespace eval ::logger::appender {
+ variable fgcolor
+ array set fgcolor {
+ red {31m}
+ red-bold {1;31m}
+ black {m}
+ blue {1m}
+ green {32m}
+ yellow {33m}
+ cyan {36m}
+ }
+
+ variable levelToColor
+ array set levelToColor {
+ debug cyan
+ info blue
+ notice black
+ warn red
+ error red
+ critical red-bold
+ alert red-bold
+ emergency red-bold
+ }
+}
+
+
+
+##Procedure Header
+# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::appender::console
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::appender::console -level <level> -service <service> [options]
+#
+# Arguments:
+# -level <level>
+# name of level to fill in as 'priority' in log proc
+# -service <service>
+# name of service to fill in as 'category' in log proc
+# -appenderArgs <appenderArgs>
+# any additional args in list form
+# -conversionPattern <conversionPattern>
+# log pattern to use (see genLogProc)
+# -procName <procName>
+# explicitly set the proc name
+# -procNameVar <procNameVar>
+# name of variable to set in the calling context
+# variable has name of proc
+#
+#
+# Return Values:
+# a runnable command
+#
+# Description:
+#
+#
+# Examples:
+#
+#
+# Notes:
+# 1.
+#
+# End of Procedure Header
+
+
+proc ::logger::appender::console {args} {
+ set usage {console
+ ?-level level?
+ ?-service service?
+ ?-appenderArgs appenderArgs?
+ }
+ set bargs $args
+ set conversionPattern {\[%d\] \[%c\] \[%M\] \[%p\] %m}
+ while {[llength $args] > 1} {
+ set opt [lindex $args 0]
+ set args [lrange $args 1 end]
+ switch -exact -- $opt {
+ -level { set level [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -service { set service [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -appenderArgs {
+ set appenderArgs [lindex $args 0]
+ set args [lrange $args 1 end]
+ set args [concat $args $appenderArgs]
+ }
+ -conversionPattern {
+ set conversionPattern [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -procName {
+ set procName [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -procNameVar {
+ set procNameVar [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ default {
+ return -code error [msgcat::mc "Unknown argument: \"%s\" :\nUsage:\
+ %s" $opt $usage]
+ }
+ }
+ }
+ if {![info exists procName]} {
+ set procName [genProcName $bargs]
+ }
+ if {[info exists procNameVar]} {
+ upvar $procNameVar myProcNameVar
+ }
+ set procText \
+ [ ::logger::utils::createLogProc \
+ -procName $procName \
+ -conversionPattern $conversionPattern \
+ -category $service \
+ -priority $level ]
+ set myProcNameVar $procName
+ return $procText
+}
+
+
+
+##Procedure Header
+# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::appender::colorConsole
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::appender::console -level <level> -service <service> [options]
+#
+# Arguments:
+# -level <level>
+# name of level to fill in as 'priority' in log proc
+# -service <service>
+# name of service to fill in as 'category' in log proc
+# -appenderArgs <appenderArgs>
+# any additional args in list form
+# -conversionPattern <conversionPattern>
+# log pattern to use (see genLogProc)
+# -procName <procName>
+# explicitly set the proc name
+# -procNameVar <procNameVar>
+# name of variable to set in the calling context
+# variable has name of proc
+#
+#
+# Return Values:
+# a runnable command
+#
+# Description:
+# provides colorized logs
+#
+# Examples:
+#
+#
+# Notes:
+# 1.
+#
+# End of Procedure Header
+
+
+proc ::logger::appender::colorConsole {args} {
+ variable fgcolor
+ set usage {console
+ ?-level level?
+ ?-service service?
+ ?-appenderArgs appenderArgs?
+ }
+ set bargs $args
+ set conversionPattern {\[%d\] \[%c\] \[%M\] \[%p\] %m}
+ upvar 0 ::logger::appender::levelToColor colorMap
+ while {[llength $args] > 1} {
+ set opt [lindex $args 0]
+ set args [lrange $args 1 end]
+ switch -exact -- $opt {
+ -level { set level [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -service { set service [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -appenderArgs {
+ set appenderArgs [lindex $args 0]
+ set args [lrange $args 1 end]
+ set args [concat $args $appenderArgs]
+ }
+ -conversionPattern {
+ set conversionPattern [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -procName {
+ set procName [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -procNameVar {
+ set procNameVar [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ default {
+ return -code error [msgcat::mc "Unknown argument: \"%s\" :\nUsage:\
+ %s" $opt $usage]
+ }
+ }
+ }
+ if {![info exists procName]} {
+ set procName [genProcName $bargs]
+ }
+ upvar $procNameVar myProcNameVar
+ if {[info exists level]} {
+ #apply color
+ set colorCode $colorMap($level)
+ append newCPattern {\033\[} $fgcolor($colorCode) $conversionPattern {\033\[0m}
+ set conversionPattern $newCPattern
+ }
+ set procText \
+ [ ::logger::utils::createLogProc \
+ -procName $procName \
+ -conversionPattern $conversionPattern \
+ -category $service \
+ -priority $level ]
+ set myProcNameVar $procName
+ return $procText
+}
+
+##Procedure Header
+# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::appender::fileAppend
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::appender::fileAppend -level <level> -service <service> -outputChannel <channel> [options]
+#
+# Arguments:
+# -level <level>
+# name of level to fill in as 'priority' in log proc
+# -service <service>
+# name of service to fill in as 'category' in log proc
+# -appenderArgs <appenderArgs>
+# any additional args in list form
+# -conversionPattern <conversionPattern>
+# log pattern to use (see genLogProc)
+# -procName <procName>
+# explicitly set the proc name
+# -procNameVar <procNameVar>
+# name of variable to set in the calling context
+# variable has name of proc
+# -outputChannel <channel>
+# name of output channel (eg stdout, file handle)
+#
+#
+# Return Values:
+# a runnable command
+#
+# Description:
+#
+#
+# Examples:
+#
+#
+# Notes:
+# 1.
+#
+# End of Procedure Header
+
+
+proc ::logger::appender::fileAppend {args} {
+ set usage {console
+ ?-level level?
+ ?-service service?
+ ?-outputChannel channel?
+ ?-appenderArgs appenderArgs?
+ }
+ set bargs $args
+ set conversionPattern {\[%d\] \[%c\] \[%M\] \[%p\] %m}
+ while {[llength $args] > 1} {
+ set opt [lindex $args 0]
+ set args [lrange $args 1 end]
+ switch -exact -- $opt {
+ -level { set level [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -service { set service [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -appenderArgs {
+ set appenderArgs [lindex $args 0]
+ set args [lrange $args 1 end]
+ set args [concat $args $appenderArgs]
+ }
+ -conversionPattern {
+ set conversionPattern [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -procName {
+ set procName [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -procNameVar {
+ set procNameVar [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -outputChannel {
+ set outputChannel [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ default {
+ return -code error [msgcat::mc "Unknown argument: \"%s\" :\nUsage:\
+ %s" $opt $usage]
+ }
+ }
+ }
+ if {![info exists procName]} {
+ set procName [genProcName $bargs]
+ }
+ if {[info exists procNameVar]} {
+ upvar $procNameVar myProcNameVar
+ }
+ set procText \
+ [ ::logger::utils::createLogProc \
+ -procName $procName \
+ -conversionPattern $conversionPattern \
+ -category $service \
+ -outputChannel $outputChannel \
+ -priority $level ]
+ set myProcNameVar $procName
+ return $procText
+}
+
+
+
+
+##Internal Procedure Header
+# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::appender::genProcName
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::appender::genProcName <args>
+#
+# Arguments:
+# <formatString>
+# string composed of formatting chars (see description)
+#
+#
+# Return Values:
+# a runnable command
+#
+# Description:
+#
+#
+# Examples:
+# ::loggerExtension::new param1
+# ::loggerExtension::new param2
+# ::loggerExtension::new param3 <option1>
+#
+#
+# Sample Input:
+# (Optional) Sample of input to the proc provided by its argument values.
+#
+# Sample Output:
+# (Optional) For procs that output to files, provide
+# sample of format of output produced.
+# Notes:
+# 1.
+#
+# End of Procedure Header
+
+
+proc ::logger::appender::genProcName {args} {
+ set name [md5::md5 -hex $args]
+ return "::logger::appender::logProc-$name"
+}
+
+
+package provide logger::appender 1.3
+
+# ;;; Local Variables: ***
+# ;;; mode: tcl ***
+# ;;; End: ***
diff --git a/tcllib/modules/log/loggerUtils.man b/tcllib/modules/log/loggerUtils.man
new file mode 100644
index 0000000..d5630dd
--- /dev/null
+++ b/tcllib/modules/log/loggerUtils.man
@@ -0,0 +1,149 @@
+[comment {-*- tcl -*- doctools manpage}]
+[comment {$Id: loggerUtils.man,v 1.7 2009/01/29 06:16:19 andreas_kupries Exp $}]
+[manpage_begin logger::utils n 1.3]
+[keywords appender]
+[keywords logger]
+[copyright {2005 Aamer Akhter <aakhter@cisco.com>}]
+[moddesc {Object Oriented logging facility}]
+[titledesc {Utilities for logger}]
+[category {Programming tools}]
+[require Tcl 8.4]
+[require logger::utils [opt 1.3]]
+[description]
+
+This package adds template based [term appenders].
+
+[list_begin definitions]
+
+[call [cmd ::logger::utils::createFormatCmd] [arg formatString]]
+
+This command translates [arg formatString] into an expandable command
+string.
+
+The following strings are the known substitutions (from log4perl)
+allowed to occur in the [arg formatString]:
+
+[list_begin definitions]
+[def %c] Category of the logging event
+[def %C] Fully qualified name of logging event
+[def %d] Current date in yyyy/MM/dd hh:mm:ss
+[def %H] Hostname
+[def %m] Message to be logged
+[def %M] Method where logging event was issued
+[def %p] Priority of logging event
+[def %P] Pid of current process
+[list_end]
+
+[call [cmd ::logger::utils::createLogProc] \
+ [option -procName] [arg procName] \
+ [opt [arg options]...]]
+
+This command ...
+
+[list_begin options]
+
+[opt_def -procName procName]
+
+The name of the procedure to create.
+
+[opt_def -conversionPattern pattern]
+
+See [cmd ::logger::utils::createFormatCmd] for the substitutions
+allowed in the [arg pattern].
+
+[opt_def -category category]
+
+The category (service).
+
+[opt_def -priority priority]
+
+The priority (level).
+
+[opt_def -outputChannel channel]
+
+channel to output on (default stdout)
+
+[list_end]
+
+[call [cmd ::logger::utils::applyAppender] \
+ [option -appender] [arg appenderType] \
+ [opt [arg options]...]]
+
+This command will create an appender for the specified logger
+services. If no service is specified then the appender will be added
+as the default appender for the specified levels. If no levels are
+specified, then all levels are assumed.
+
+[para]
+
+[list_begin options]
+
+[opt_def -service loggerservices]
+[opt_def -serviceCmd loggerserviceCmds]
+
+Name of the logger instance to modify. [option -serviceCmd] takes as
+input the return of [cmd logger::init].
+
+[opt_def -appender appenderType]
+
+Type of the appender to use.
+One of [const console], [const colorConsole].
+
+
+[opt_def -appenderArgs appenderArgs]
+
+Additional arguments to apply to the appender.
+The argument of the option is a list of options
+and their arguments.
+
+[para] For example
+[example_begin]
+logger::utils::applyAppender -serviceCmd $log -appender console -appenderArgs {-conversionPattern {\[lb]%M\[rb] \[lb]%p\[rb] - %m}}
+[example_end]
+
+The usual Tcl quoting rules apply.
+
+
+[opt_def -levels levelList]
+
+The list of levels to apply this appender to. If not specified all
+levels are assumed.
+
+[list_end]
+[para]
+
+Example of usage:
+
+[para]
+[example {
+ % set log [logger::init testLog]
+ ::logger::tree::testLog
+ % logger::utils::applyAppender -appender console -serviceCmd $log
+ % ${log}::error "this is an error"
+ [2005/08/22 10:14:13] [testLog] [global] [error] this is an error
+}]
+
+[call [cmd ::logger::utils::autoApplyAppender] \
+ [arg command] [arg command-string] [arg log] [arg op] [arg args]... \
+]
+
+This command is designed to be added via [cmd {trace leave}] to calls
+of [cmd logger::init]. It will look at preconfigured state (via
+[cmd ::logger::utils::applyAppender]) to autocreate appenders for
+newly created logger instances.
+
+It will return its argument [arg log].
+
+[para]
+Example of usage:
+[para]
+[example {
+ logger::utils::applyAppender -appender console
+ set log [logger::init applyAppender-3]
+ ${log}::error "this is an error"
+}]
+[list_end]
+
+[vset CATEGORY logger]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/log/loggerUtils.tcl b/tcllib/modules/log/loggerUtils.tcl
new file mode 100644
index 0000000..acc08d6
--- /dev/null
+++ b/tcllib/modules/log/loggerUtils.tcl
@@ -0,0 +1,541 @@
+##Library Header
+#
+# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::utils::
+#
+# Purpose:
+# an extension to the tcllib logger module
+#
+# Author:
+# Aamer Akhter / aakhter@cisco.com
+#
+# Support Alias:
+# aakhter@cisco.com
+#
+# Usage:
+# package require logger::utils
+#
+# Description:
+# this extension adds template based appenders
+#
+# Requirements:
+# package require logger
+#
+# Variables:
+# namespace ::logger::utils::
+# id: CVS ID: keyword extraction
+# version: current version of package
+# packageDir: directory where package is located
+# log: instance log
+#
+# Notes:
+# 1.
+#
+# Keywords:
+#
+#
+# Category:
+#
+#
+# End of Header
+
+package require Tcl 8.4
+package require logger
+package require logger::appender
+package require msgcat
+
+namespace eval ::logger::utils {
+
+ variable packageDir [file dirname [info script]]
+ variable log [logger::init logger::utils]
+
+ logger::import -force -namespace log logger::utils
+
+ # @mdgen OWNER: msgs/*.msg
+ ::msgcat::mcload [file join $packageDir msgs]
+}
+
+##Internal Procedure Header
+# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::utils::createFormatCmd
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::utils::createFormatCmd <formatString>
+#
+# Arguments:
+# <formatString>
+# string composed of formatting chars (see description)
+#
+#
+# Return Values:
+# a runnable command
+#
+# Description:
+# createFormatCmd translates <formatString> into an expandable
+# command string.
+#
+# The following are the known substitutions (from log4perl):
+# %c category of the logging event
+# %C fully qualified name of logging event
+# %d current date in yyyy/MM/dd hh:mm:ss
+# %H hostname
+# %m message to be logged
+# %M method where logging event was issued
+# %p priority of logging event
+# %P pid of current process
+#
+#
+# Examples:
+# ::logger::new param1
+# ::logger::new param2
+# ::logger::new param3 <option1>
+#
+#
+# Sample Input:
+# (Optional) Sample of input to the proc provided by its argument values.
+#
+# Sample Output:
+# (Optional) For procs that output to files, provide
+# sample of format of output produced.
+# Notes:
+# 1.
+#
+# End of Procedure Header
+
+
+proc ::logger::utils::createFormatCmd {text args} {
+ variable log
+ array set opt $args
+
+ regsub -all -- \
+ {%P} \
+ $text \
+ [pid] \
+ text
+
+ regsub -all -- \
+ {%H} \
+ $text \
+ [info hostname] \
+ text
+
+
+ #the %d subst has to happen at the end
+ regsub -all -- \
+ {%d} \
+ $text \
+ {[clock format [clock seconds] -format {%Y/%m/%d %H:%M:%S}]} \
+ text
+
+ if {[info exists opt(-category)]} {
+ regsub -all -- \
+ {%c} \
+ $text \
+ $opt(-category) \
+ text
+
+ regsub -all -- \
+ {%C} \
+ $text \
+ [lindex [split $opt(-category) :: ] 0] \
+ text
+ }
+
+ if {[info exists opt(-priority)]} {
+ regsub -all -- \
+ {%p} \
+ $text \
+ $opt(-priority) \
+ text
+ }
+
+ return $text
+}
+
+
+
+##Procedure Header
+# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::utils::createLogProc
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::utils::createLogProc -procName <procName> [options]
+#
+# Arguments:
+# -procName <procName>
+# name of proc to create
+# -conversionPattern <pattern>
+# see createFormatCmd for <pattern>
+# -category <category>
+# the category (service)
+# -priority <priority>
+# the priority (level)
+# -outputChannel <channel>
+# channel to output on (default stdout)
+#
+#
+# Return Values:
+# a runnable command
+#
+# Description:
+# createFormatCmd translates <formatString> into an expandable
+# command string.
+#
+# The following are the known substitutions (from log4perl):
+# %c category of the logging event
+# %C fully qualified name of logging event
+# %d current date in yyyy/MM/dd hh:mm:ss
+# %H hostname
+# %m message to be logged
+# %M method where logging event was issued
+# %p priority of logging event
+# %P pid of current process
+#
+#
+# Examples:
+#
+#
+# Sample Input:
+# (Optional) Sample of input to the proc provided by its argument values.
+#
+# Sample Output:
+# (Optional) For procs that output to files, provide
+# sample of format of output produced.
+# Notes:
+# 1.
+#
+# End of Procedure Header
+
+
+proc ::logger::utils::createLogProc {args} {
+ variable log
+ array set opt $args
+
+ set formatText ""
+ set methodText ""
+ if {[info exists opt(-conversionPattern)]} {
+ set text $opt(-conversionPattern)
+
+ regsub -all -- \
+ {%P} \
+ $text \
+ [pid] \
+ text
+
+ regsub -all -- \
+ {%H} \
+ $text \
+ [info hostname] \
+ text
+
+ if {[info exists opt(-category)]} {
+ regsub -all -- \
+ {%c} \
+ $text \
+ $opt(-category) \
+ text
+
+ regsub -all -- \
+ {%C} \
+ $text \
+ [lindex [split $opt(-category) :: ] 0] \
+ text
+ }
+
+ if {[info exists opt(-priority)]} {
+ regsub -all -- \
+ {%p} \
+ $text \
+ $opt(-priority) \
+ text
+ }
+
+
+ if {[regexp {%M} $text]} {
+ set methodText {
+ if {[info level] < 2} {
+ set method "global"
+ } else {
+ set method [lindex [info level -1] 0]
+ }
+
+ }
+
+ regsub -all -- \
+ {%M} \
+ $text \
+ {$method} \
+ text
+ }
+
+ regsub -all -- \
+ {%m} \
+ $text \
+ {$text} \
+ text
+
+ regsub -all -- \
+ {%d} \
+ $text \
+ {[clock format [clock seconds] -format {%Y/%m/%d %H:%M:%S}]} \
+ text
+
+ }
+
+ if {[info exists opt(-outputChannel)]} {
+ set outputChannel $opt(-outputChannel)
+ } else {
+ set outputChannel stdout
+ }
+
+ set formatText $text
+ set outputCommand puts
+
+ set procText {
+ proc $opt(-procName) {text} {
+ $methodText
+ $outputCommand $outputChannel \"$formatText\"
+ }
+ }
+
+ set procText [subst $procText]
+ return $procText
+}
+
+
+##Procedure Header
+# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::utils::applyAppender
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::utils::applyAppender -appender <appenderType> [options]
+#
+# Arguments:
+# -service <logger service names>
+# -serviceCmd <logger serviceCmds>
+# name of logger instance to modify
+# -serviceCmd takes as input the return of logger::init
+#
+# -appender <appenderType>
+# type of appender to use
+# console|colorConsole...
+#
+# -appenderArgs <argumentlist>
+# A list of additional options plus their arguments
+#
+# -levels <levels to apply to>
+# list of levels to apply this appender to
+# by default all levels are applied to
+#
+# Return Values:
+#
+#
+# Description:
+# applyAppender will create an appender for the specified
+# logger services. If not service is specified then the
+# appender will be added as the default appender for
+# the specified levels. If no levels are specified, then
+# all levels are assumed.
+#
+# The following are the known substitutions (from log4perl):
+# %c category of the logging event
+# %C fully qualified name of logging event
+# %d current date in yyyy/MM/dd hh:mm:ss
+# %H hostname
+# %m message to be logged
+# %M method where logging event was issued
+# %p priority of logging event
+# %P pid of current process
+#
+#
+# Examples:
+# % set log [logger::init testLog]
+# ::logger::tree::testLog
+# % logger::utils::applyAppender -appender console -serviceCmd $log
+# % ${log}::error "this is error"
+# [2005/08/22 10:14:13] [testLog] [global] [error] this is error
+#
+#
+# End of Procedure Header
+
+
+proc ::logger::utils::applyAppender {args} {
+ set usage {logger::utils::applyAppender
+ -appender appender
+ ?-instance?
+ ?-levels levels?
+ ?-appenderArgs appenderArgs?
+ }
+ set levels [logger::levels]
+ set appenderArgs {}
+ set bargs $args
+ while {[llength $args] > 1} {
+ set opt [lindex $args 0]
+ set args [lrange $args 1 end]
+ switch -exact -- $opt {
+ -appender { set appender [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -serviceCmd { set serviceCmd [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -service { set serviceCmd [logger::servicecmd [lindex $args 0]]
+ set args [lrange $args 1 end]
+ }
+ -levels { set levels [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ -appenderArgs {
+ set appenderArgs [lindex $args 0]
+ set args [lrange $args 1 end]
+ }
+ default {
+ return -code error [msgcat::mc "Unknown argument: \"%s\" :\nUsage:\
+ %s" $opt $usage]
+ }
+ }
+ }
+
+ set appender ::logger::appender::${appender}
+ if {[info commands $appender] == {}} {
+ return -code error [msgcat::mc "could not find appender '%s'" $appender]
+ }
+
+ #if service is not specified make all future services with this appender
+ # spec
+ if {![info exists serviceCmd]} {
+ set ::logger::utils::autoApplyAppenderArgs $bargs
+ #add trace
+ #check to see if trace is already set
+ if {[lsearch [trace info execution logger::init] \
+ {leave ::logger::utils::autoApplyAppender} ] == -1} {
+ trace add execution ::logger::init leave ::logger::utils::autoApplyAppender
+ }
+ return
+ }
+
+
+ #foreach service specified, apply the appender for each of the levels
+ # specified
+ foreach srvCmd $serviceCmd {
+
+ foreach lvl $levels {
+ set procText [$appender -appenderArgs $appenderArgs \
+ -level $lvl \
+ -service [${srvCmd}::servicename] \
+ -procNameVar procName
+ ]
+ eval $procText
+ ${srvCmd}::logproc $lvl $procName
+ }
+ }
+}
+
+
+##Internal Procedure Header
+# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
+# Copyright (c) 2005 Cisco Systems, Inc.
+#
+# Name:
+# ::logger::utils::autoApplyAppender
+#
+# Purpose:
+#
+#
+# Synopsis:
+# ::logger::utils::autoApplyAppender <command> <command-string> <log> <op> <args>
+#
+# Arguments:
+# <command>
+# <command-string>
+# <log>
+# servicecmd generated by logger:init
+# <op>
+# <args>
+#
+# Return Values:
+# <log>
+#
+# Description:
+# autoApplyAppender is designed to be added via trace leave
+# to logger::init calls
+#
+# autoApplyAppender will look at preconfigred state (via applyAppender)
+# to autocreate appenders for newly created logger instances
+#
+# Examples:
+# logger::utils::applyAppender -appender console
+# set log [logger::init applyAppender-3]
+# ${log}::error "this is error"
+#
+#
+# Sample Input:
+#
+# Sample Output:
+#
+# Notes:
+# 1.
+#
+# End of Procedure Header
+
+
+proc ::logger::utils::autoApplyAppender {command command-string log op args} {
+ variable autoApplyAppenderArgs
+ set bAppArgs $autoApplyAppenderArgs
+ set levels [logger::levels]
+ set appenderArgs {}
+ while {[llength $bAppArgs] > 1} {
+ set opt [lindex $bAppArgs 0]
+ set bAppArgs [lrange $bAppArgs 1 end]
+ switch -exact -- $opt {
+ -appender { set appender [lindex $bAppArgs 0]
+ set bAppArgs [lrange $bAppArgs 1 end]
+ }
+ -levels { set levels [lindex $bAppArgs 0]
+ set bAppArgs [lrange $bAppArgs 1 end]
+ }
+ -appenderArgs {
+ set appenderArgs [lindex $bAppArgs 0]
+ set bAppArgs [lrange $bAppArgs 1 end]
+ }
+ default {
+ return -code error [msgcat::mc "Unknown argument: \"%s\" :\nUsage:\
+ %s" $opt $usage]
+ }
+ }
+ }
+ if {![info exists appender]} {
+ return -code error [msgcat::mc "need to specify -appender"]
+ }
+ logger::utils::applyAppender -appender $appender -serviceCmd $log \
+ -levels $levels -appenderArgs $appenderArgs
+ return $log
+}
+
+
+package provide logger::utils 1.3
+
+# ;;; Local Variables: ***
+# ;;; mode: tcl ***
+# ;;; End: ***
diff --git a/tcllib/modules/log/loggerUtils.test b/tcllib/modules/log/loggerUtils.test
new file mode 100644
index 0000000..771bbff
--- /dev/null
+++ b/tcllib/modules/log/loggerUtils.test
@@ -0,0 +1,224 @@
+# -*- tcl -*-
+# Tests for the utilities to the logger facility.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2005 by Aamer Aahkter
+#
+# $Id: loggerUtils.test,v 1.7 2006/10/09 21:41:41 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.2
+
+support {
+ useLocal logger.tcl logger
+ useLocal loggerAppender.tcl logger::appender
+}
+testing {
+ useLocal loggerUtils.tcl logger::utils
+}
+
+# -------------------------------------------------------------------------
+
+logger::setlevel debug
+
+# -------------------------------------------------------------------------
+
+namespace eval ::loggerExtension::test {
+
+ ::tcltest::test load {} -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ } -returnCodes {
+ ok
+ } -result {}
+
+
+ ::tcltest::test createFormatCmd-1 {
+ check for %d
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ set a [logger::utils::createFormatCmd %d]
+ set b [subst $a]
+ regexp {\d\d\d\d/\d\d/\d\d \d\d:\d\d:\d\d} $b
+ } -result {1}
+
+ ::tcltest::test createFormatCmd-2 {
+ check for %P
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ set a [logger::utils::createFormatCmd %P]
+ set b [subst $a]
+ } -returnCodes {
+ ok
+ } -result [pid]
+
+ ::tcltest::test createFormatCmd-3 {
+ check for %H
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ set a [logger::utils::createFormatCmd %H]
+ set b [subst $a]
+ } -returnCodes {
+ ok
+ } -result [info hostname]
+
+ ::tcltest::test createFormatCmd-4 {
+ check for %c
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ set a [logger::utils::createFormatCmd %c -category test::cat ]
+ set b [subst $a]
+ } -returnCodes {
+ ok
+ } -result test::cat
+
+ ::tcltest::test createFormatCmd-5 {
+ check for %C
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ set a [logger::utils::createFormatCmd %C -category test::cat ]
+ set b [subst $a]
+ } -returnCodes {
+ ok
+ } -result test
+
+ ::tcltest::test createFormatCmd-6 {
+ check for %p
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ set a [logger::utils::createFormatCmd %p -category test::cat -priority error]
+ set b [subst $a]
+ } -returnCodes {
+ ok
+ } -result error
+
+
+ ::tcltest::test createLogProc-1 {
+ create a proc and test it
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ set a [logger::utils::createLogProc \
+ -category catTest \
+ -priority critical \
+ -procName ::bobo \
+ -conversionPattern {\[%d\] \[%c\] \[%M\] \[%p\] %m}]
+ eval $a
+ ::bobo test
+ } -returnCodes {ls
+
+ ok
+ } -match regexp \
+ -output {\[[\d:\/ ]+\] \[catTest\] \[namespace\] \[critical\] test}
+
+ ::tcltest::test applyAppender-1 {
+ apply an appender
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ ${log}::delete
+ unset log
+ } -body {
+ set log [logger::init testLog]
+ logger::utils::applyAppender -appender console -serviceCmd $log
+ ${log}::error "this is error"
+ } -returnCodes {
+ ok
+ } -match regexp \
+ -output {\[[\d:\/ ]+\] \[testLog\] \[namespace\] \[error\] this is error}
+
+ ::tcltest::test applyAppender-2 {
+ apply an appender, to 2 loggers
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ ${log1}::delete
+ ${log2}::delete
+ unset log1
+ unset log2
+ } -body {
+ set log1 [logger::init testLog1]
+ set log2 [logger::init testLog2]
+ logger::utils::applyAppender -appender console -serviceCmd [list $log1 $log2]
+ ${log1}::error "this is error1"
+ ${log2}::error "this is error2"
+ } -returnCodes {
+ ok
+ } -match regexp \
+ -output {\[[\d:\/ ]+\] \[testLog1\] \[namespace\] \[error\] this is error1\n\[[\d:\/ ]+\] \[testLog2\] \[namespace\] \[error\] this is error2}
+
+
+ ::tcltest::test applyAppender-3 {
+ auto apply
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ logger::utils::applyAppender -appender console
+ set log [logger::init applyAppender-3]
+ ${log}::error "this is error"
+ } -returnCodes {
+ ok
+ } -match regexp \
+ -output {\[[\d:\/ ]+\] \[applyAppender-3\] \[namespace\] \[error\] this is error}
+
+ ::tcltest::test applyAppender-4 {
+ auto apply
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ logger::utils::applyAppender -appender colorConsole
+ set log [logger::init applyAppender-4]
+ ${log}::error "this is error"
+ } -returnCodes {
+ ok
+ } -match regexp \
+ -output {\[[\d:\/ ]+\] \[applyAppender-4\] \[namespace\] \[error\] this is error}
+
+ ::tcltest::test applyAppender-5 {
+ auto apply fileAppend
+ } -setup {
+ } -constraints {
+ } -cleanup {
+ } -body {
+ logger::utils::applyAppender \
+ -appender fileAppend -appenderArgs {-outputChannel stderr}
+ set log [logger::init applyAppender-5]
+ ${log}::error "this is error"
+ } -returnCodes {
+ ok
+ } -match regexp \
+ -errorOutput {\[[\d:\/ ]+\] \[applyAppender-5\] \[namespace\] \[error\] this is error}
+
+
+}
+
+
+testsuiteCleanup
+
+# ;;; Local Variables: ***
+# ;;; mode: tcl ***
+# ;;; End: ***
diff --git a/tcllib/modules/log/logger_trace.test b/tcllib/modules/log/logger_trace.test
new file mode 100644
index 0000000..3031fe1
--- /dev/null
+++ b/tcllib/modules/log/logger_trace.test
@@ -0,0 +1,280 @@
+# -*- tcl -*-
+# Tests for the logger facility.
+#
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2002 by David N. Welton <davidw@dedasys.com>.
+# Copyright (c) 2004,2005 by Michael Schlenker <mic42@users.sourceforge.net>.
+#
+# $Id: logger_trace.test,v 1.2 2006/10/09 21:41:41 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.0
+
+testing {
+ useLocal logger.tcl logger
+}
+
+# -------------------------------------------------------------------------
+
+proc traceproc0 { } {
+ traceproc1
+}
+
+proc traceproc1 { args } {
+ return "procresult1"
+}
+
+proc traceproc2 { args } {
+ return "procresult2"
+}
+
+proc traceproc3 { args } {
+ return "procresult3"
+}
+
+test logger-trace-1.1 {Test <service>::trace with no arguments.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace
+} -returnCodes 1 -result [::tcltest::wrongNumArgs ::logger::tree::tracetest::trace {action args} 0]
+
+test logger-trace-1.2 {Test <service>::trace with an unknown action} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace foo
+} -returnCodes 1 -result \
+ {Invalid action "foo": must be status, add, remove, on, or off}
+
+test logger-trace-on-1.1 {Verify that tracing is disabled by default.} -body {
+ set l [::logger::init tracetest]
+ set ${l}::tracingEnabled
+} -result 0
+
+test logger-trace-on-1.2 {Test <service>::trace on with extra arguments} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace on 1
+} -returnCodes 1 -result {wrong # args: should be "trace on"}
+
+test logger-trace-on-1.3 {Test <service>::trace on with no extra arguments and verify that the tracing state flag is enabled afterward.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace on
+ set ${l}::tracingEnabled
+} -cleanup {
+ ${l}::trace off
+} -result 1
+
+test logger-trace-on-1.4 {Verify <service>::trace on enables tracing only for the one service and not for any of its children.} -body {
+ set l1 [::logger::init tracetest]
+ set l2 [::logger::init tracetest::child]
+ ${l1}::trace on
+ set ${l2}::tracingEnabled
+} -cleanup {
+ ${l1}::trace off
+} -result 0
+
+test logger-trace-off-1.1 {Test <service>::trace off with extra arguments} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace off 1
+} -returnCodes 1 -result {wrong # args: should be "trace off"}
+
+test logger-trace-off-1.2 {Test <service>::trace off with no extra arguments and verify that tracing state flag is disabled afterward.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace off
+ set ${l}::tracingEnabled
+} -result 0
+
+test logger-trace-off-1.3 {Verify that <service>::trace on followed by off leaves tracing disabled.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace on
+ ${l}::trace off
+ set ${l}::tracingEnabled
+} -result 0
+
+test logger-trace-remove-1.1 {Test <service>::trace remove with no targets specified.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace remove
+} -returnCodes 1 -result \
+ {wrong # args: should be "trace remove ?-ns? <proc> ..."}
+
+test logger-trace-remove-1.2 {Test <service>::trace remove with procedure names that don't exist.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace remove nosuchproc1 nosuchproc2
+} -result {}
+
+test logger-trace-remove-1.3 {Test <service>::trace remove with -ns switch and namespace names that don't exist.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace remove -ns nosuchns
+} -result {}
+
+test logger-trace-remove-1.4 {Verify that <service>::trace remove does glob pattern matching on procedure names.} -body {
+ namespace eval ::tracetest {
+ proc foo1 {} {}
+ proc foo2 {} {}
+ proc bar1 {} {}
+ proc bar2 {} {}
+ proc bar3 {} {}
+ }
+ set l [::logger::init tracetest]
+ ${l}::trace add ::tracetest::bar1
+ ${l}::trace add ::tracetest::bar2
+ ${l}::trace add ::tracetest::bar3
+ ${l}::trace remove ::tracetest::bar*
+ ${l}::trace status
+} -cleanup {
+ namespace delete ::tracetest
+} -result {}
+
+test logger-trace-add-1.1 {Test <service>::trace add with no targets specified.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace add
+} -returnCodes 1 -result \
+ {wrong # args: should be "trace add ?-ns? <proc> ..."}
+
+test logger-trace-add-1.2 {Test <service>::trace add with procedure names that don't exist, and verify that they are not listed in <service>::trace status.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace add nosuchproc1 nosuchproc2
+ ${l}::trace status
+} -cleanup {
+ ${l}::trace remove nosuchproc1 nosuchproc2
+} -result {}
+
+test logger-trace-add-1.3 {Verify that <service>::trace add with the -ns switch followed by <service>::trace remove with the -ns switch, both with the same namespace, leaves no traces for the namespace remaining.} -body {
+ namespace eval ::tracetest {
+ proc test1 {} {}
+ proc test2 {} {}
+ proc test3 {} {}
+ }
+ set l [::logger::init tracetest]
+ ${l}::trace add -ns ::tracetest
+ ${l}::trace remove -ns ::tracetest
+ ${l}::trace status
+} -cleanup {
+ namespace delete ::tracetest
+} -result {}
+
+test logger-trace-add-1.4 {Verify that <service>::trace add with the -ns switch registers traces for all of the procedures in that namespace.} -body {
+ namespace eval ::tracetest {
+ proc test1 {} {}
+ proc test2 {} {}
+ proc test3 {} {}
+ }
+ set l [::logger::init tracetest]
+ ${l}::trace add -ns ::tracetest
+ lsort -dictionary [${l}::trace status]
+} -cleanup {
+ ${l}::trace remove -ns ::tracetest
+ namespace delete ::tracetest
+} -result {::tracetest::test1 ::tracetest::test2 ::tracetest::test3}
+
+test logger-trace-add-1.5 {Verify that <service>::trace add does glob pattern matching on procedure names.} -body {
+ namespace eval ::tracetest {
+ proc foo1 {} {}
+ proc foo2 {} {}
+ proc bar1 {} {}
+ proc bar2 {} {}
+ proc bar3 {} {}
+ }
+ set l [::logger::init tracetest]
+ ${l}::trace add ::tracetest::bar*
+ lsort -dictionary [${l}::trace status]
+} -cleanup {
+ ${l}::trace remove -ns ::tracetest
+ namespace delete ::tracetest
+} -result {::tracetest::bar1 ::tracetest::bar2 ::tracetest::bar3}
+
+test logger-trace-status-1.1 {Verify that <service>::trace status with no argument returns an empty list when no traces are currently active.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace status
+} -result {}
+
+test logger-trace-status-1.2 {Verify that <service>::trace status returns 0 when given the name of a procedure that is not currently being traced.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace status foo
+} -result 0
+
+test logger-trace-status-1.3 {Verify that <service>::trace status returns 0 when given the name of a procedure that was, but is no longer, being traced.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace add foo
+ ${l}::trace remove foo
+ ${l}::trace status foo
+} -result 0
+
+test logger-trace-status-1.4 {Verify that <service>::trace status returns 0 when given the name of a procedure that doesn't exist, but was passed to <service>::trace add.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace add nosuchproc
+ ${l}::trace status nosuchproc
+} -cleanup {
+ ${l}::trace remove nosuchproc
+} -result 0
+
+test logger-trace-status-1.5 {Verify that <service>::trace status returns 1 when given the name of an existing procedure that is currently registered via <service>::trace add.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace add traceproc1
+ ${l}::trace status traceproc1
+} -cleanup {
+ ${l}::trace remove traceproc1
+} -result 1
+
+test logger-trace-log-1.1 {Verify that invoking a procedure that has been registered for tracing via <service>::trace add does NOT generate a log message when tracing is turned off.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace off ;# Should already be off. Just in case.
+ ${l}::trace add traceproc1
+ traceproc1
+} -cleanup {
+ ${l}::trace remove traceproc1
+} -result "procresult1" -output {}
+
+test logger-trace-log-1.2 {Verify that invoking a procedure that has been registered for tracing via <service>::trace add DOES generate a log message when tracing is turned on BEFORE registration. This test calls the traced function through another function, which should result in a non-empty caller string.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace on
+ ${l}::trace add traceproc1
+ traceproc0
+} -cleanup {
+ ${l}::trace remove traceproc1
+ ${l}::trace off
+} -result "procresult1" -match regexp -output \
+{\[.*\] \[tracetest\] \[trace\] 'enter {proc ::traceproc1 level 2 script .*logger_trace.test caller ::traceproc0 procargs {args {}}}'
+\[.*\] \[tracetest\] \[trace\] 'leave {proc ::traceproc1 level 2 script .*logger_trace.test caller ::traceproc0 status ok result procresult1}'
+}
+
+test logger-trace-log-1.3 {Verify that invoking a procedure that has been registered for tracing via <service>::trace add DOES generate a log message when tracing is turned on AFTER registration. This test calls the traced function directly, which should result in the caller being an empty string.} -body {
+ set l [::logger::init tracetest]
+ ${l}::trace add traceproc2
+ ${l}::trace on
+ traceproc2
+} -cleanup {
+ ${l}::trace remove traceproc2
+ ${l}::trace off
+} -result "procresult2" -match regexp -output \
+{\[.*\] \[tracetest\] \[trace\] 'enter {proc ::traceproc2 level 1 script .*logger_trace.test caller {} procargs {args {}}}'
+\[.*\] \[tracetest\] \[trace\] 'leave {proc ::traceproc2 level 1 script .*logger_trace.test caller {} status ok result procresult2}'
+}
+
+test logger-trace-logproc-1.1 {Verify that a logproc can be specified for trace logging.} -body {
+ set l [::logger::init tracetest]
+ proc ::tracelog { message } {
+ puts $message
+ }
+ ${l}::logproc trace ::tracelog
+ ${l}::trace add traceproc2
+ ${l}::trace on
+ traceproc2
+} -cleanup {
+ ${l}::trace remove traceproc2
+ ${l}::trace off
+ rename ::tracelog {}
+} -result "procresult2" -match regexp -output \
+{enter {proc ::traceproc2 level 1 script .*logger_trace.test caller {} procargs {args {}}}
+leave {proc ::traceproc2 level 1 script .*logger_trace.test caller {} status ok result procresult2}
+}
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/log/loggerperformance b/tcllib/modules/log/loggerperformance
new file mode 100644
index 0000000..d9d9b0b
--- /dev/null
+++ b/tcllib/modules/log/loggerperformance
@@ -0,0 +1,79 @@
+# -*- tcl -*-
+# loggerperformance.tcl
+
+# $Id: loggerperformance,v 1.2 2004/01/15 06:36:13 andreas_kupries Exp $
+
+# This code is for benchmarking the performance of the log tools.
+
+set auto_path "[file dirname [info script]] $auto_path"
+package require logger
+package require log
+
+# Set up logger
+set log [logger::init date]
+
+# Create a custom log routine, so we don't deal with the overhead of
+# the default one, which does some system calls itself.
+
+${log}::logproc notice txt {
+ puts "$txt"
+}
+
+# Basic output.
+proc Test1 {} {
+ set date [clock format [clock seconds]]
+ puts "Date is now $date"
+}
+
+# No output at all. This is the benchmark by which 'turned off' log
+# systems should be judged.
+proc Test2 {} {
+ set date [clock format [clock seconds]]
+}
+
+# Use logger.
+proc Test3 {} {
+ set date [clock format [clock seconds]]
+ ${::log}::notice "Date is now $date"
+}
+
+# Use log.
+proc Test4 {} {
+ set date [clock format [clock seconds]]
+ log::log notice "Date is now $date"
+}
+
+set res1 [time {
+ Test1
+} 1000]
+
+set res2 [time {
+ Test2
+} 1000]
+
+set res3 [time {
+ Test3
+} 1000]
+
+${log}::disable notice
+
+set res4 [time {
+ Test3
+} 1000]
+
+set res5 [time {
+ Test4
+} 1000]
+
+log::lvSuppressLE notice
+
+set res6 [time {
+ Test4
+} 1000]
+
+puts "Puts output: $res1"
+puts "No output: $res2"
+puts "Logger: $res3"
+puts "Logger disabled: $res4"
+puts "Log: $res5"
+puts "Log disabled: $res6"
diff --git a/tcllib/modules/log/msgs/en.msg b/tcllib/modules/log/msgs/en.msg
new file mode 100644
index 0000000..9b6df9e
--- /dev/null
+++ b/tcllib/modules/log/msgs/en.msg
@@ -0,0 +1,7 @@
+# -*- tcl -*-
+package require msgcat
+namespace import ::msgcat::*
+
+mcset en "Unknown argument: \"%s\" :\nUsage: %s" "Unknown argument: \"%s\" :\nUsage: %s"
+mcset en "could not find appender '%s'" "could not find appender '%s'"
+mcset en "need to specify -appender" "need to specify -appender"
diff --git a/tcllib/modules/log/pkgIndex.tcl b/tcllib/modules/log/pkgIndex.tcl
new file mode 100644
index 0000000..8dc4e44
--- /dev/null
+++ b/tcllib/modules/log/pkgIndex.tcl
@@ -0,0 +1,9 @@
+if {![package vsatisfies [package provide Tcl] 8]} {return}
+package ifneeded log 1.3 [list source [file join $dir log.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded logger 0.9.4 [list source [file join $dir logger.tcl]]
+package ifneeded logger::appender 1.3 [list source [file join $dir loggerAppender.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded logger::utils 1.3 [list source [file join $dir loggerUtils.tcl]]
diff --git a/tcllib/modules/map/ChangeLog b/tcllib/modules/map/ChangeLog
new file mode 100644
index 0000000..7eb5fb1
--- /dev/null
+++ b/tcllib/modules/map/ChangeLog
@@ -0,0 +1,83 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2012-05-11 Andreas Kupries <andreask@activestate.com>
+
+ * map_slippy_fetcher.tcl: Added timeouts to the http queries issued
+ * map_geocode_nominatim.tcl: by the fetcher and geo-name
+ resolver. Fetcher bumped to version 0.3.
+
+ * map_slippy.tcl: Integrated code contributed by <tomasz@tuxteam.de>
+ * map_slippy.man: providing a command to compute a zoom level which
+ * pkgIndex.tcl: fits around a rectangular geographic area described
+ by the limiting lati- and longitudes. Version bumped to 0.5.
+
+ * map_geocode_nominatim.man: Added new package to resolve
+ * map_geocode_nominatim.tcl: geographical names via the
+ * pkgIndex.tcl: nominatim service, contributed by
+ <tomasz@tuxteam.de>.
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-03-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * map_slippy.man: Documented the three coordinate systems used.
+ * map_slippy.tcl: Extended the testsuite to cover all coordinate
+ * map_slippy.test: conversions. Fixed a number of problems (wrong
+ * pkgIndex.tcl: scaling, bad rounding) uncovered by this. Bumped
+ package version to 0.4.
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-05-27 Andreas Kupries <andreask@activestate.com>
+
+ * map_slippy.man: [Bug 2999022]: Fixed bogus use of integer
+ * map_slippy.tcl: division in 'tile 2geo'. Thanks to Matt
+ * map_slippy.test: Morian <mmoria01@users.sourceforge.net>
+ * pkgIndex.tcl: for the report. Bumped version to 0.3. Started a
+ testsuite.
+
+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-11-28 Andreas Kupries <andreask@activestate.com>
+
+ * map_slippy_cache.man: Version mismatch code / index.
+ * map_slippy_cache.tcl: Fix and bump to 0.2 as it was
+ * map_slippy_fetcher.man: already distributed.
+ * map_slippy_fetcher.tcl:
+ * map_slippy.man:
+ * map_slippy.tcl:
+ * pkgIndex.tcl:
+
+2008-11-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module for packages dealing with slippy-based maps.
+
+ * map_slippy_cache.man: Openstreetmap's slippy system. Accessing
+ * map_slippy_cache.tcl: slippy servers and fetching tiles, caching
+ * map_slippy_fetcher.man: tiles in the local filesystem, and shared
+ * map_slippy_fetcher.tcl: utility code.
+ * map_slippy.man:
+ * map_slippy.tcl:
+ * pkgIndex.tcl:
diff --git a/tcllib/modules/map/map_geocode_nominatim.man b/tcllib/modules/map/map_geocode_nominatim.man
new file mode 100644
index 0000000..123286c
--- /dev/null
+++ b/tcllib/modules/map/map_geocode_nominatim.man
@@ -0,0 +1,113 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin map::geocode::nominatim n 0.1]
+[keywords geocoding]
+[keywords http]
+[keywords location]
+[keywords map]
+[keywords nominatim]
+[keywords server]
+[keywords url]
+[moddesc {Mapping utilities}]
+[titledesc {Resolving geographical names with a Nominatim service}]
+[require Tcl 8.5]
+[require http]
+[require json]
+[require uri]
+[require snit]
+[require map::geocode::nominatim [opt 0.1]]
+[description]
+
+This package provides a class for accessing geocoding services which implement
+the [term Nominatim] interface (see [sectref {References}])
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::map::geocode::nominatim] [arg requestor] \
+ [opt "[option -baseurl] [arg url]"] \
+ [opt "[option -callback] [arg callback]"] \
+ [opt "[option -error] [arg {error callback}]"]]
+
+Creates a geocoding request object [arg requestor], which will send its requests to
+the [term Nominatim] server.
+
+[para]
+
+The result of the command is [arg name].
+
+[list_end]
+
+[subsection Options]
+
+[list_begin options]
+
+[opt_def -baseurl [arg url]]
+
+The base URL of the [term Nominatim] service. Default value is [term OpenStreetMap's] service at
+[uri http://nominatim.openstreetmap.org/search] A possible free alternative is at
+[uri http://open.mapquestapi.com//nominatim/v1/search]
+
+[opt_def -callback [arg cmdprefix]]
+
+A command prefix to be invoked when search result become available.
+
+The default setting, active when nothing was specified on object creation, is to print
+the [arg result] (see below) to [term stdout]. The result of the command prefix is
+ignored. Errors thrown by the command prefix are caught and cause the invokation of
+the error callback (see option [option -error] below), with the error message as argument.
+
+[para] The signature of the command prefix is:
+
+[list_begin definitions]
+[call [cmd \$cmdprefix] [arg result]]
+The [arg result] is a list of dictionaries, containing one item per hit.
+Each dictionary will have the following entries:
+
+[list_begin definitions]
+[def place_id] The place ID (FIXME: what's this?)
+[def licence] The data licence string
+[def osm_type] The OSM type of the location
+[def osm_id] FIXME
+[def boundingbox] The coordinates of the bounding box (min and max latitude, min and max longitude)
+[def lat] The location's latitude
+[def lon] The location's longitude
+[def display_name] the location's human readable name
+[def class] FIXME
+[def type] FIXME
+[def icon] FIXME
+[list_end]
+
+[list_end]
+
+[opt_def -error [arg cmdprefix]]
+
+A command prefix to be invoked when encountering errors. Typically these are HTTP errors.
+The default setting, active when nothing was specified on object creation, is to print
+the [arg errorstring] (see below) to [term stderr]. The result of the command prefix is
+ignored. Errors thrown by the command prefix are passed to higher levels.
+
+[para] The signature of the command prefix is:
+
+[list_begin definitions]
+[call [cmd \$cmdprefix] [arg errorstring]]
+[list_end]
+[list_end]
+
+[subsection Methods]
+
+[list_begin definitions]
+
+[call [arg requestor] [method search] [arg query]]
+
+This method returns a list of dictionaries, one item per hit for the specified [arg query].
+
+[list_end]
+
+[section References]
+
+[list_begin enum]
+[enum] [uri http://wiki.openstreetmap.org/wiki/Nominatim]
+[enum] [uri http://open.mapquestapi.com/nominatim/]
+[list_end]
+[manpage_end]
diff --git a/tcllib/modules/map/map_geocode_nominatim.tcl b/tcllib/modules/map/map_geocode_nominatim.tcl
new file mode 100644
index 0000000..adb6981
--- /dev/null
+++ b/tcllib/modules/map/map_geocode_nominatim.tcl
@@ -0,0 +1,91 @@
+## -*- tcl -*-
+# ### ### ### ######### ######### #########
+
+## Geocoding (finding geo coordinates from location names and keywords)
+## Reverse geocoding (putting names on coordinate sets)
+## Both based on the nominatim interface
+
+## See https://wiki.openstreetmap.org/wiki/Nominatim for details
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require http
+package require json
+package require uri
+package require snit
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+snit::type map::geocode::nominatim {
+ # ### ### ### ######### ######### #########
+ ## API
+
+ proc callbackdefault {result} {
+ # FIXME Is there a good default here?
+ puts "callback: $result"
+ }
+
+ proc errordefault {err} {
+ bgerror "nominatim error: $err"
+ }
+
+ option -baseurl "http://nominatim.openstreetmap.org/search"
+ option -callback callbackdefault
+ option -error errordefault
+
+
+ # No special constructor, so far
+
+ # ::nominatim::search
+ # Queries the location server. Returns a list of dicts, each item having
+ # - place_id
+ # - licence
+ # - osm_type
+ # - osm_id
+ # - boundingbox
+ # - lat
+ # - lon
+ # - display_name
+ # - class
+ # - type
+ # - icon
+ # Most interesting should be display_name, lat, lon and boundingbox
+ method search {query} {
+ set query [http::formatQuery q $query format json]
+ http::geturl [uri::join {*}[uri::split $options(-baseurl)] query $query] \
+ -command [mymethod Done] -timeout 60000
+ }
+
+ method Error {context err} {
+ uplevel \#0 [list {*}$options(-error) "$context: $err"]
+ return
+ }
+
+ # Private method
+ method Done {htok} {
+ if { [http::ncode $htok] != 200 } {
+ $self Error "HTTP" [http::code $htok]
+ return
+ }
+ if { [catch {
+ set res [::json::json2dict [encoding convertfrom utf-8 [::http::data $htok]]]
+ } _ err] } {
+ $self Error "JSON" $err
+ return
+ }
+ if { [catch {
+ uplevel \#0 [list {*}$options(-callback) $res]
+ } _ err] } {
+ $self Error "Callback" $err
+ }
+ }
+
+ # ### ### ### ######### ######### #########
+ ## State
+ # none, so far
+}
+
+package provide map::geocode::nominatim 0.1
diff --git a/tcllib/modules/map/map_slippy.man b/tcllib/modules/map/map_slippy.man
new file mode 100644
index 0000000..30bb39f
--- /dev/null
+++ b/tcllib/modules/map/map_slippy.man
@@ -0,0 +1,189 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin map::slippy n 0.5]
+[keywords geodesy]
+[keywords geography]
+[keywords latitute]
+[keywords location]
+[keywords longitude]
+[keywords map]
+[keywords slippy]
+[keywords zoom]
+[moddesc {Mapping utilities}]
+[titledesc {Common code for slippy based map packages}]
+[require Tcl 8.4]
+[require Tk 8.4]
+[require map::slippy [opt 0.5]]
+[description]
+
+This package provides a number of methods doing things needed by all
+types of slippy-based map packages.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::map::slippy] [method length] [arg level]]
+
+This method returns the width/height of a slippy-based map at the
+specified zoom [arg level], in pixels. This is, in essence, the result
+of
+
+[example {
+ expr { [tiles $level] * [tile size] }
+}]
+
+[call [cmd ::map::slippy] [method tiles] [arg level]]
+
+This method returns the width/height of a slippy-based map at the
+specified zoom [arg level], in [term tiles].
+
+[call [cmd ::map::slippy] [method {tile size}]]
+
+This method returns the width/height of a tile in a slippy-based map,
+in pixels.
+
+[call [cmd ::map::slippy] [method {tile valid}] [arg tile] \
+ [arg levels] [opt [arg msgvar]]]
+
+This method checks whether [arg tile] described a valid tile in a
+slippy-based map containing that many zoom [arg levels]. The result is
+a boolean value, [const true] if the tile is valid, and [const false]
+otherwise. For the latter a message is left in the variable named by
+[arg msgvar], should it be specified.
+
+[para]
+
+A tile identifier as stored in [arg tile] is a list containing zoom
+level, tile row, and tile column, in this order. The command
+essentially checks this, i.e. the syntax, that the zoom level is
+between 0 and "[arg levels]-1", and that the row/col information is
+within the boundaries for the zoom level, i.e. 0 ...
+"[lb]tiles $zoom[rb]-1".
+
+[call [cmd ::map::slippy] [method {geo 2tile}] [arg geo]]
+
+Converts a geographical location at a zoom level ([arg geo], a list
+containing zoom level, latitude, and longitude, in this order) to a
+tile identifier (list containing zoom level, row, and column) at that
+level. The tile identifier uses pure integer numbers for the tile
+coordinates, for all geographic coordinates mapping to that tile.
+
+[call [cmd ::map::slippy] [method {geo 2tile.float}] [arg geo]]
+
+Converts a geographical location at a zoom level ([arg geo], a list
+containing zoom level, latitude, and longitude, in this order) to a
+tile identifier (list containing zoom level, row, and column) at that
+level. The tile identifier uses floating point numbers for the tile
+coordinates, representing not only the tile the geographic coordinates
+map to, but also the fractional location inside of that tile.
+
+[call [cmd ::map::slippy] [method {geo 2point}] [arg geo]]
+
+Converts a geographical location at a zoom level ([arg geo], a list
+containing zoom level, latitude, and longitude, in this order) to a
+pixel position (list containing zoom level, y, and x) at that level.
+
+[call [cmd ::map::slippy] [method {tile 2geo}] [arg tile]]
+
+Converts a tile identifier at a zoom level ([arg tile], list
+containing zoom level, row, and column) to a geographical location
+(list containing zoom level, latitude, and longitude, in this order)
+at that level.
+
+[call [cmd ::map::slippy] [method {tile 2point}] [arg tile]]
+
+Converts a tile identifier at a zoom level ([arg tile], a list
+containing zoom level, row, and column, in this order) to a pixel
+position (list containing zoom level, y, and x) at that level.
+
+[call [cmd ::map::slippy] [method {point 2geo}] [arg point]]
+
+Converts a pixel position at a zoom level ([arg point], list
+containing zoom level, y, and x) to a geographical location (list
+containing zoom level, latitude, and longitude, in this order) at that
+level.
+
+[call [cmd ::map::slippy] [method {point 2tile}] [arg point]]
+
+Converts a pixel position at a zoom level ([arg point], a list
+containing zoom level, y, and x, in this order) to a tile identifier
+(list containing zoom level, row, and column) at that level.
+
+[call [cmd ::map::slippy] [method {fit geobox}] [arg canvdim] \
+ [arg geobox] [arg zmin] [arg zmax]]
+
+Calculates the zoom level (whithin the bounds [arg zmin] and
+[arg zmax]) such that [arg geobox] (a 4-element list containing the
+latitudes and longitudes lat0, lat1, lon0 and lon1 of a geo box,
+in this order) fits into a viewport given by [arg canvdim], a
+2-element list containing the width and height of the viewport, in
+this order.
+
+[list_end]
+
+[section {Coordinate systems}]
+
+The commands of this package operate on three distinct coordinate
+systems, which are explained below.
+
+[subsection Geographic]
+
+[term Geographic]al coordinates are represented by [term Latitude] and
+[term Longitude], each of which is measured in degrees, as they are
+essentially angles.
+
+[para] [const Zero] longitude is the [term {Greenwich meridian}], with
+positive values going [term east], and negative values going
+[term west], for a total range of +/- 180 degrees. Note that +180 and
+-180 longitude are the same [term meridian], opposite to greenwich.
+
+[para] [const zero] latitude the [term Equator], with positive values
+going [term north] and negative values going [term south]. While the
+true range is +/- 90 degrees the projection used by the package
+requires us to cap the range at +/- 85.05112877983284 degrees. This
+means that north and south pole are not representable and not part of
+any map.
+
+[subsection Tiles]
+
+While [sectref Geographic]al coordinates of the previous section are
+independent of zoom level the [term {tile coordinates}] are not.
+
+[para] Generally the integer part of tile coordinates represent the
+row and column number of the tile in question, wheras the fractional
+parts signal how far inside the tile the location in question is, with
+pure integer coordinates (no fractional part) representing the upper
+left corner of the tile.
+
+[para] The zero point of the map is at the upper left corner,
+regardless of zoom level, with larger coordinates going right (east)
+and down (south), and smaller coordinates going left (west) and up
+(north). Again regardless of zxoom level.
+
+[para] Negative tile coordinates are not allowed.
+
+[para] At zoom level 0 the whole map is represented by a single,
+putting the geographic zero at 1/2, 1/2 of tile coordinates, and the
+range of tile coordinates as [lb]0...1[rb].
+
+[para] To go from a zoom level N to the next deeper level N+1 each
+tile of level N is split into its four quadrants, which then are the
+tiles of level N+1.
+
+[para] This means that at zoom level N the map is sliced (horizontally
+and vertically) into 2^N stripes, for a total of 4^N tiles, with tile
+coordinates ranging from 0 to 2^N+1.
+
+[subsection Pixels/Points]
+
+[term {pixel coordinates}], also called [term {point coordinates}] are
+in essence [sectref Tiles {tile coordinates}] scaled by the size of
+the image representing a tile. This tile size currently has a fixed
+value, [const 256].
+
+[section References]
+
+[list_begin enum]
+[enum] [uri http://wiki.openstreetmap.org/wiki/Main_Page]
+[list_end]
+[manpage_end]
diff --git a/tcllib/modules/map/map_slippy.tcl b/tcllib/modules/map/map_slippy.tcl
new file mode 100644
index 0000000..aebc095
--- /dev/null
+++ b/tcllib/modules/map/map_slippy.tcl
@@ -0,0 +1,221 @@
+## -*- tcl -*-
+# ### ### ### ######### ######### #########
+
+## Common information for slippy based maps. I.e. tile size,
+## relationship between zoom level and map size, etc.
+
+## See http://wiki.openstreetmap.org/wiki/Slippy_map_tilenames#Pseudo-Code
+## for the coordinate conversions and other information.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.4
+package require snit
+package require math::constants
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+namespace eval ::map::slippy {
+ math::constants::constants pi radtodeg degtorad
+}
+
+snit::type map::slippy {
+ # ### ### ### ######### ######### #########
+ ## API
+
+ typemethod length {level} {
+ return [expr {$ourtilesize * [tiles $level]}]
+ }
+
+ typemethod tiles {level} {
+ return [tiles $level]
+ }
+
+ typemethod {tile size} {} {
+ return $ourtilesize
+ }
+
+ typemethod {tile valid} {tile levels {msgv {}}} {
+ if {$msgv ne ""} { upvar 1 $msgv msg }
+
+ # Bad syntax.
+
+ if {[llength $tile] != 3} {
+ set msg "Bad tile <[join $tile ,]>, expected 3 elements (zoom, row, col)"
+ return 0
+ }
+
+ foreach {z r c} $tile break
+
+ # Requests outside of the valid ranges are rejected
+ # immediately, without even going to the filesystem or
+ # provider.
+
+ if {($z < 0) || ($z >= $levels)} {
+ set msg "Bad zoom level '$z' (max: $levels)"
+ return 0
+ }
+
+ set tiles [tiles $z]
+ if {($r < 0) || ($r >= $tiles) ||
+ ($c < 0) || ($c >= $tiles)
+ } {
+ set msg "Bad cell '$r $c' (max: $tiles)"
+ return 0
+ }
+
+ return 1
+ }
+
+ # Coordinate conversions.
+ # geo = zoom, latitude, longitude
+ # tile = zoom, row, column
+ # point = zoom, y, x
+
+ typemethod {geo 2tile} {geo} {
+ ::variable degtorad
+ ::variable pi
+ foreach {zoom lat lon} $geo break
+ # lat, lon are in degrees.
+ # The missing sec() function is computed using the 1/cos equivalency.
+ set tiles [tiles $zoom]
+ set latrad [expr {$degtorad * $lat}]
+ set row [expr {int((1 - (log(tan($latrad) + 1.0/cos($latrad)) / $pi)) / 2 * $tiles)}]
+ set col [expr {int((($lon + 180.0) / 360.0) * $tiles)}]
+ return [list $zoom $row $col]
+ }
+
+ typemethod {geo 2tile.float} {geo} {
+ ::variable degtorad
+ ::variable pi
+ foreach {zoom lat lon} $geo break
+ # lat, lon are in degrees.
+ # The missing sec() function is computed using the 1/cos equivalency.
+ set tiles [tiles $zoom]
+ set latrad [expr {$degtorad * $lat}]
+ set row [expr {(1 - (log(tan($latrad) + 1.0/cos($latrad)) / $pi)) / 2 * $tiles}]
+ set col [expr {(($lon + 180.0) / 360.0) * $tiles}]
+ return [list $zoom $row $col]
+ }
+
+ typemethod {geo 2point} {geo} {
+ ::variable degtorad
+ ::variable pi
+ foreach {zoom lat lon} $geo break
+ # Essence: [geo 2tile $geo] * $ourtilesize, with 'geo 2tile' inlined.
+ set tiles [tiles $zoom]
+ set latrad [expr {$degtorad * $lat}]
+ set y [expr {$ourtilesize * ((1 - (log(tan($latrad) + 1.0/cos($latrad)) / $pi)) / 2 * $tiles)}]
+ set x [expr {$ourtilesize * ((($lon + 180.0) / 360.0) * $tiles)}]
+ return [list $zoom $y $x]
+ }
+
+ typemethod {tile 2geo} {tile} {
+ ::variable radtodeg
+ ::variable pi
+ foreach {zoom row col} $tile break
+ # Note: For integer row/col the geo location is for the upper
+ # left corner of the tile. To get the geo location of
+ # the center simply add 0.5 to the row/col values.
+ set tiles [tiles $zoom]
+ set lat [expr {$radtodeg * (atan(sinh($pi * (1 - 2 * $row / double($tiles)))))}]
+ set lon [expr {$col / double($tiles) * 360.0 - 180.0}]
+ return [list $zoom $lat $lon]
+ }
+
+ typemethod {tile 2point} {tile} {
+ foreach {zoom row col} $tile break
+ # Note: For integer row/col the pixel location is for the
+ # upper left corner of the tile. To get the pixel
+ # location of the center simply add 0.5 to the row/col
+ # values.
+ #set tiles [tiles $zoom]
+ set y [expr {$ourtilesize * $row}]
+ set x [expr {$ourtilesize * $col}]
+ return [list $zoom $y $x]
+ }
+
+ typemethod {point 2geo} {point} {
+ ::variable radtodeg
+ ::variable pi
+ foreach {zoom y x} $point break
+ set length [expr {$ourtilesize * [tiles $zoom]}]
+ set lat [expr {$radtodeg * (atan(sinh($pi * (1 - 2 * double($y) / $length))))}]
+ set lon [expr {double($x) / $length * 360.0 - 180.0}]
+ return [list $zoom $lat $lon]
+ }
+
+ typemethod {point 2tile} {point} {
+ foreach {zoom y x} $point break
+ #set tiles [tiles $zoom]
+ set row [expr {double($y) / $ourtilesize}]
+ set col [expr {double($x) / $ourtilesize}]
+ return [list $zoom $row $col]
+ }
+
+ typemethod {fit geobox} {canvdim geobox zmin zmax} {
+ foreach {canvw canvh} $canvdim break
+ foreach {lat0 lat1 lon0 lon1} $geobox break
+
+ # NOTE we assume ourtilesize == [map::slippy length 0].
+ # Further, we assume that each zoom step "grows" the
+ # linear resolution by 2 (that's the log(2) down there)
+ set canvw [expr {abs($canvw)}]
+ set canvh [expr {abs($canvh)}]
+ set z [expr {int(log(min( \
+ ($canvh/$ourtilesize) / (abs($lat1 - $lat0)/180), \
+ ($canvw/$ourtilesize) / (abs($lon1 - $lon0)/360))) \
+ / log(2))}]
+ # clamp $z
+ set z [expr {($z<$zmin) ? $zmin : (($z>$zmax) ? $zmax : $z)}]
+ # Now $zoom is an approximation, since the scale factor isn't uniform
+ # across the map (the vertical dimension depends on latitude). So we have
+ # to refine iteratively (I expect it to take just one step):
+ while {1} {
+ # Now we can run "uphill", then there's z0 = z - 1 and "downhill",
+ # then there's z1 = z + 1 (from the last iteration)
+ #puts "try zoom $z"
+ foreach {_ y0 x0} [map::slippy geo 2point [list $z $lat0 $lon0]] break
+ foreach {_ y1 x1} [map::slippy geo 2point [list $z $lat1 $lon1]] break
+ set w [expr {abs($x1 - $x0)}]
+ set h [expr {abs($y1 - $y0)}]
+ if { $w > $canvw || $h > $canvh } {
+ # too big: shrink
+ #puts "too big: shrink..."
+ if { [info exists z0] } break; # but not if we come "from below"
+ if {$z <= $zmin} break; # can't be < $zmin
+ set z1 $z
+ incr z -1
+ } else {
+ # fits: grow
+ #puts "fits: grow..."
+ if { [info exists z1] } break; # but not if we come "from above"
+ set z0 $z
+ incr z
+ }
+ }
+ if { [info exists z0] } { return $z0 }
+ return $z
+ }
+
+ proc tiles {level} {
+ return [expr {1 << $level}]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal commands
+
+ # ### ### ### ######### ######### #########
+ ## State
+
+ typevariable ourtilesize 256 ; # Size of slippy tiles <pixels>
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide map::slippy 0.5
diff --git a/tcllib/modules/map/map_slippy.test b/tcllib/modules/map/map_slippy.test
new file mode 100644
index 0000000..652345e
--- /dev/null
+++ b/tcllib/modules/map/map_slippy.test
@@ -0,0 +1,144 @@
+# Tests for the map::slippy module. -*- tcl -*-
+#
+# 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) 2010 Andreas Kupries
+# All rights reserved.
+#
+# RCS: @(#) $Id: map_slippy.test,v 1.2 2011/03/24 20:33:34 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+package require tcltest
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.1
+
+support {
+ use snit/snit.tcl snit
+ use math/math.tcl math
+ use math/constants.tcl math::constants
+}
+testing {
+ useLocal map_slippy.tcl map::slippy
+}
+
+# -------------------------------------------------------------------------
+
+proc 4digits {args} {
+ set res {}
+ foreach arg $args {lappend res [expr (round(10000*$arg))/10000.0]}
+ return $res
+}
+
+#
+# Match floating point numbers to within 4 digits.
+#
+
+proc matchNumbers {expected actual} {
+ set match 1
+ foreach a $actual e $expected {
+ if {abs($a-$e) > 1e-4} {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+
+customMatch 4digits matchNumbers
+
+# -------------------------------------------------------------------------
+# Encoding tests
+# -------------------------------------------------------------------------
+
+test map-slippy-7.0 {tile 2geo} -body {
+ ::map::slippy tile 2geo {11 504 775}
+} -match 4digits -result {11.0 67.0674 -43.7695}
+
+# -------------------------------------------------------------------------
+# Converting between the three coordinate systems.
+# -------------------------------------------------------------------------
+
+foreach {n tile point geo tilei} {
+ 0 {0 0 0} {0 0 0} {0 85.0511287798 -180.0} {0 0 0}
+ 1 {0 1 1} {0 256 256} {0 -85.0511287798 180.0} {0 0 1}
+ 2 {0 0.5 0.5} {0 128 128} {0 0 0} {0 0 0}
+ 3 {1 0 0} {1 0 0} {1 85.0511287798 -180.0} {1 0 0}
+ 4 {1 1 1} {1 256 256} {1 0 0} {1 1 1}
+ 5 {1 0.5 0.5} {1 128 128} {1 66.5132604431 -90.0} {1 0 0}
+ 6 {1 2 2} {1 512 512} {1 -85.0511287798 180.0} {1 1 2}
+ 7 {1 1.5 1.5} {1 384 384} {1 -66.5132604431 90.0} {1 1 1}
+} {
+ # The tilei results for .1/.6 are
+ # |0 0 1| instead of |0 1 1|
+ # |1 1 2| |1 2 2|
+ # due to round off. As a float is it shown as 1.0, internally it
+ # is actually 0.9999...
+
+ test map-slippy-8.$n {tile -> point} -body {
+ ::map::slippy tile 2point $tile
+ } -match 4digits -result $point
+
+ test map-slippy-9.$n {point -> tile} -body {
+ ::map::slippy point 2tile $point
+ } -match 4digits -result $tile
+
+ test map-slippy-10.$n {point -> tile -> point} -body {
+ ::map::slippy tile 2point [::map::slippy point 2tile $point]
+ } -match 4digits -result $point
+
+ test map-slippy-11.$n {tile -> point -> tile} -body {
+ ::map::slippy point 2tile [::map::slippy tile 2point $tile]
+ } -match 4digits -result $tile
+
+ test map-slippy-12.$n {tile -> geo} -body {
+ ::map::slippy tile 2geo $tile
+ } -match 4digits -result $geo
+
+ test map-slippy-13.$n {geo -> tile/float} -body {
+ ::map::slippy geo 2tile.float $geo
+ } -match 4digits -result $tile
+
+ test map-slippy-13a.$n {geo -> tile} -body {
+ ::map::slippy geo 2tile $geo
+ } -match 4digits -result $tilei
+
+ test map-slippy-14.$n {geo -> tile/float -> geo} -body {
+ ::map::slippy tile 2geo [::map::slippy geo 2tile.float $geo]
+ } -match 4digits -result $geo
+
+ test map-slippy-15.$n {tile/float -> geo -> tile/float} -body {
+ ::map::slippy geo 2tile.float [::map::slippy tile 2geo $tile]
+ } -match 4digits -result $tile
+
+ test map-slippy-16.$n {point -> geo} -body {
+ ::map::slippy point 2geo $point
+ } -match 4digits -result $geo
+
+ test map-slippy-17.$n {geo -> point} -body {
+ ::map::slippy geo 2point $geo
+ } -match 4digits -result $point
+
+ test map-slippy-18.$n {geo -> point -> geo} -body {
+ ::map::slippy point 2geo [::map::slippy geo 2point $geo]
+ } -match 4digits -result $geo
+
+ test map-slippy-19.$n {point -> geo -> point} -body {
+ ::map::slippy geo 2point [::map::slippy point 2geo $point]
+ } -match 4digits -result $point
+}
+
+# -------------------------------------------------------------------------
+testsuiteCleanup
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/map/map_slippy_cache.man b/tcllib/modules/map/map_slippy_cache.man
new file mode 100644
index 0000000..bab8ce5
--- /dev/null
+++ b/tcllib/modules/map/map_slippy_cache.man
@@ -0,0 +1,99 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin map::slippy::cache n 0.2]
+[keywords cache]
+[keywords filesystem]
+[keywords location]
+[keywords map]
+[keywords slippy]
+[keywords tile]
+[keywords zoom]
+[moddesc {Mapping utilities}]
+[titledesc {Management of a tile cache in the local filesystem}]
+[require Tcl 8.4]
+[require Tk 8.4]
+[require img::png]
+[require map::slippy]
+[require map::slippy::cache [opt 0.2]]
+[description]
+
+This package provides a class for managing a cache of tiles for
+slippy-based maps in the local filesystem.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::map::slippy::cache] [arg cacheName] [arg cachedir] [arg provider]]
+
+Creates the cache [arg cacheName] and configures it with both the path
+to the directory contaiing the locally cached tiles ([arg cachedir]),
+and the command prefix from which it will pull tiles asked for and not
+yet known to the cache itself ([arg provider]).
+
+[para]
+
+The result of the command is [arg cacheName].
+
+[list_end]
+
+[subsection Methods]
+
+[list_begin definitions]
+
+[call [arg cacheName] [method valid] [arg tile] [opt [arg msgvar]]]
+
+This method checks the validity of a the given [arg tile] identifier.
+This is a convenience wrapper to [cmd {::map::slippy tile valid}] and
+has the same interface.
+
+[call [arg cacheName] [method exists] [arg tile]]
+
+This methods tests whether the cache contains the specified [arg tile]
+or not. The result is a boolean value, [const true] if the tile is
+known, and [const false] otherwise. The tile is identified by a list
+containing three elements, zoom level, row, and column number, in this
+order.
+
+[call [arg cacheName] [method get] [arg tile] [arg donecmd]]
+
+This is the main method of the cache, retrieving the image for the
+specified [arg tile] from the cache. The tile identifier is a list
+containing three elements, the zoom level, row, and column number of
+the tile, in this order.
+
+[para]
+
+The command refix [arg donecmd] will be invoked when the cache
+either knows the image for the tile or that no image will forthcoming.
+It will be invoked with either 2 or 3 arguments, i.e.
+
+[list_begin enum]
+[enum] The string [const set], the [arg tile], and the image.
+[enum] The string [const unset], and the [arg tile].
+[list_end]
+
+These two possibilities are used to either signal the image for the
+[arg tile], or that the [arg tile] has no image defined for it.
+
+[para]
+
+When the cache has no information about the tile it will invoke the
+[arg provider] command prefix specified during its construction,
+adding three arguments: The string [const get], the [arg tile], and a
+callback into the cache. The latter will be invoked by the provider to
+either transfer the image to the cache, or signal that the tile has no
+image.
+
+[para]
+
+When multiple requests for the same tile are made only one request
+will be issued to the provider.
+
+[list_end]
+
+[section References]
+
+[list_begin enum]
+[enum] [uri http://wiki.openstreetmap.org/wiki/Main_Page]
+[list_end]
+[manpage_end]
diff --git a/tcllib/modules/map/map_slippy_cache.tcl b/tcllib/modules/map/map_slippy_cache.tcl
new file mode 100644
index 0000000..7372bf9
--- /dev/null
+++ b/tcllib/modules/map/map_slippy_cache.tcl
@@ -0,0 +1,141 @@
+## -*- tcl -*-
+# ### ### ### ######### ######### #########
+
+## A cache we put on top of a slippy fetcher, to satisfy requests for
+## tiles from the local filesystem first, if possible.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.4 ; # No {*}-expansion :(, no ** either, nor lassign
+package require Tk ; # image photo
+package require map::slippy ; # Slippy constants
+package require fileutil ; # Testing paths
+package require img::png ; # We write tile images using the PNG image file format.
+package require snit
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+snit::type map::slippy::cache {
+ # ### ### ### ######### ######### #########
+ ## API
+
+ constructor {cachedir provider} {
+ if {![fileutil::test $cachedir edrw msg]} {
+ return -code error "$type constructor: $msg"
+ }
+ set mycachedir $cachedir
+ set myprovider $provider
+ set mylevels [uplevel \#0 [linsert $myprovider end levels]]
+ return
+ }
+
+ delegate method * to myprovider
+ delegate option * to myprovider
+
+ method valid {tile {msgv {}}} {
+ if {$msgv ne ""} { upvar 1 $msgv msg }
+ return [map::slippy tile valid $tile $mylevels msg]
+ }
+
+ method exists {tile} {
+ if {![map::slippy tile valid $tile $mylevels msg]} {
+ return -code error $msg
+ }
+ return [file exists [FileOf $tile]]
+ }
+
+ method get {tile donecmd} {
+ if {![map::slippy tile valid $tile $mylevels msg]} {
+ return -code error $msg
+ }
+
+ # Query the filesystem for a cached tile and return
+ # immediately if such was found.
+
+ set tilefile [FileOf $tile]
+ if {[file exists $tilefile]} {
+ set tileimage [image create photo -file $tilefile]
+ after 0 [linsert $donecmd end set $tile $tileimage]
+ return
+ }
+
+ # The requested tile is not known to the cache, so we forward
+ # the request to our provider and intercept the result to
+ # update the cache. Only one retrieval request will be issued
+ # if multiple arrive from above.
+
+ lappend mypending($tile) $donecmd
+ if {[llength $mypending($tile)] > 1} return
+
+ uplevel \#0 [linsert $myprovider end get $tile [mymethod Done]]
+ return
+ }
+
+ method {Done set} {tile tileimage} {
+ # The requested tile was known to the provider, we can cache
+ # the image we got and then hand it over to the original
+ # requestor.
+
+ set tilefile [FileOf $tile]
+ file mkdir [file dirname $tilefile]
+ $tileimage write $tilefile -format png
+
+ set requests $mypending($tile)
+ unset mypending($tile)
+
+ # Note. The cache accepts empty callbacks for requests, and if
+ # no actual callback 'took' the image it is assumed to be not
+ # wanted and destroyed. This allows higher layers to request
+ # tiles before needng them without leaking imagas and yet also
+ # not throwing them away when a prefetch and regular fetch
+ # collide.
+
+ set taken 0
+ foreach d $requests {
+ if {![llength $d]} continue
+ uplevel \#0 [linsert $d end set $tile $tileimage]
+ set taken 1
+ }
+
+ if {!$taken} {
+ image delete $tileimage
+ }
+ return
+ }
+
+ method {Do unset} {donecmd tile} {
+ # The requested tile is not known. Nothing has to change in
+ # the cache (it did not know the tile either), the result can
+ # be directly handed over to the original requestor.
+
+ uplevel \#0 [linsert $donecmd end unset $tile]
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal commands
+
+ proc FileOf {tile} {
+ upvar 1 mycachedir mycachedir
+ foreach {z r c} $tile break
+ return [file join $mycachedir $z $c $r.png]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## State
+
+ variable mycachedir {} ; # Directory to cache tiles in.
+ variable myprovider {} ; # Command prefix, provider of tiles to cache.
+ variable mylevels {} ; # Zoom-levels, retrieved from provider.
+
+ variable mypending -array {} ; # tile -> list (done-cmd-prefix)
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide map::slippy::cache 0.2
diff --git a/tcllib/modules/map/map_slippy_fetcher.man b/tcllib/modules/map/map_slippy_fetcher.man
new file mode 100644
index 0000000..769f916
--- /dev/null
+++ b/tcllib/modules/map/map_slippy_fetcher.man
@@ -0,0 +1,85 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset VERSION 0.4]
+[manpage_begin map::slippy::fetcher n [vset VERSION]]
+[keywords http]
+[keywords location]
+[keywords map]
+[keywords server]
+[keywords slippy]
+[keywords tile]
+[keywords url]
+[keywords zoom]
+[moddesc {Mapping utilities}]
+[titledesc {Accessing a server providing tiles for slippy-based maps}]
+[require Tcl 8.4]
+[require Tk 8.4]
+[require img::png]
+[require map::slippy]
+[require map::slippy::fetcher [opt [vset VERSION]]]
+[description]
+
+This package provides a class for accessing http servers providing
+tiles for slippy-based maps.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::map::slippy::fetcher] [arg fetcherName] [arg levels] [arg url]]
+
+Creates the fetcher [arg fetcherName] and configures it with the
+number of zoom [arg levels] supported by the tile server, and the
+[arg url] it is listening on for tile requests.
+
+[para]
+
+The result of the command is [arg fetcherName].
+
+[list_end]
+
+[subsection Methods]
+
+[list_begin definitions]
+
+[call [arg fetcherName] [method levels]]
+
+This method returns the number of zoom levels supported by the fetcher
+object, and the tile server it is accessing.
+
+[call [arg fetcherName] [method tileheight]]
+
+This method returns the height of tiles served, in pixels.
+
+[call [arg fetcherName] [method tilewidth]]
+
+This method returns the width of tiles served, in pixels.
+
+[call [arg fetcherName] [method get] [arg tile] [arg donecmd]]
+
+This is the main method of the fetcher, retrieving the image for the
+specified [arg tile]. The tile identifier is a list containing three
+elements, the zoom level, row, and column number of the tile, in this
+order.
+
+[para]
+
+The command refix [arg donecmd] will be invoked when the fetcher
+either knows the image for the tile or that no image will forthcoming.
+It will be invoked with either 2 or 3 arguments, i.e.
+
+[list_begin enum]
+[enum] The string [const set], the [arg tile], and the image.
+[enum] The string [const unset], and the [arg tile].
+[list_end]
+
+These two possibilities are used to either signal the image for the
+[arg tile], or that the [arg tile] has no image defined for it.
+
+[list_end]
+
+[section References]
+
+[list_begin enum]
+[enum] [uri http://wiki.openstreetmap.org/wiki/Main_Page]
+[list_end]
+[manpage_end]
diff --git a/tcllib/modules/map/map_slippy_fetcher.tcl b/tcllib/modules/map/map_slippy_fetcher.tcl
new file mode 100644
index 0000000..1eefc95
--- /dev/null
+++ b/tcllib/modules/map/map_slippy_fetcher.tcl
@@ -0,0 +1,183 @@
+## -*- tcl -*-
+# ### ### ### ######### ######### #########
+
+## Fetch tile images for maps based on the slippy scheme.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.4 ; # No {*}-expansion :(, no ** either, nor lassign
+
+# Tk8.6 "image photo" supports PNG directly. Earlier versions requires
+# the IMG extension, aka TkImg.
+# See http://sourceforge.net/projects/tkimg
+
+if {[catch {
+ package require Tk 8.6
+}]} {
+ package require Tk;
+ package require img::png ; # Slippy tiles use the PNG image file format.
+}
+
+package require map::slippy ; # Slippy contants
+package require http ; # Retrieval method
+package require snit
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+snit::type map::slippy::fetcher {
+ # ### ### ### ######### ######### #########
+ ## API
+
+ constructor {levels baseurl} {
+ set mybase $baseurl
+ set mylevels $levels
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Query API
+
+ method levels {} { return $mylevels }
+ method tileheight {} {map::slippy tile size}
+ method tilewidth {} {map::slippy tile size}
+
+ # ### ### ### ######### ######### #########
+ ## Tile retrieval API
+
+ method get {tile donecmd} {
+ # tile = list (zoom, row, col)
+ if {![map::slippy tile valid $tile $mylevels msg]} {
+ return -code error $msg
+ }
+
+ # Compose the url for the requested tile
+
+ set url [urlOf $tile]
+
+ # Initiate tile download.
+
+ # Note however that a download is actually started if and only
+ # if there is no download of this tile already in progress. If
+ # there is we simply register the new request with that
+ # download. When the download is done we convert the data to
+ # an in-memory image and provide it to all the waiting requests.
+
+ lappend mypending($url) $donecmd
+ if {[llength $mypending($url)] > 1} return
+
+ # We keep the retrieved image data in memory, 256x256 is not
+ # that large for todays RAM sizes (Seen 124K max so far).
+
+ if {[catch {
+ set token [http::geturl $url -binary 1 -command [mymethod Done] \
+ -timeout 60000]
+ }]} {
+ puts $::errorInfo
+ # Some errors, like invalid urls, raise errors synchro-
+ # nously, even if a callback -command is specified.
+ after idle [linsert $donecmd end unset $tile]
+ return
+ }
+
+ # Remember the download settings.
+ set mytoken($token) [list $url $tile]
+ #puts "GET\t($url) = $token"
+ return
+ }
+
+ method Done {token} {
+ #puts GOT/$token
+
+ # We get the request settings and waiting callbacks first, and
+ # clean them up immediately, keeping the object state
+ # consistent even in the face of recursive calls. (Which
+ # should not be possible here).
+
+ foreach {url tile} $mytoken($token) break
+ set requests $mypending($url)
+
+ unset mytoken($token)
+ unset mypending($url)
+
+ # Then we get the request results, and clean them up as well.
+
+ set status [http::status $token]
+ set ncode [http::ncode $token]
+ set data [http::data $token]
+ http::cleanup $token
+
+ #puts URL|$url
+ #puts STT|$status
+ #puts COD|[http::code $token]
+ #puts NCO|[http::ncode $token]
+ #puts ERR|[http::error $token]
+
+ # Check whether the retrieval failed, bad url, server out,
+ # etc. or not, and report if yes.
+
+ if {($status ne "ok") || ($ncode != 200)} {
+ # error, eof, and other non-ok conditions.
+ foreach d $requests {
+ after idle [linsert $d end unset $tile]
+ }
+ return
+ }
+
+ # The request was ok. Note that we assume that the slippy
+ # server is not redirecting us to some other url. We expect
+ # the image at exactly this location. A redirection is treated
+ # as failure, see the check above.
+
+ #puts \t|[string length $data]|
+
+ if {[catch {
+ set tileimage [image create photo -data $data]
+ }]} {
+ # XXX AK: Here we need a better way to report internal
+ # problems. Maybe just throw the error?
+ #puts $::errorInfo
+ #puts $data
+
+ foreach d $requests {
+ after idle [linsert $d end unset $tile]
+ }
+ return
+ }
+
+ # Finally we have the image we seek, and can report it.
+
+ foreach d $requests {
+ after idle [linsert $d end set $tile $tileimage]
+ }
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal commands
+
+ proc urlOf {tile} {
+ upvar 1 mybase mybase
+ foreach {z r c} $tile break
+ return $mybase/$z/$c/$r.png
+ }
+
+ # ### ### ### ######### ######### #########
+ ## State
+
+ variable mybase {} ; # Base url to the tiles.
+ variable mylevels 0 ; # Number of zoom levels (0...mylevels-1)
+
+ # State of all http requests currently in flight.
+
+ variable mypending -array {} ; # tile url -> list (done-cmd-prefix)
+ variable mytoken -array {} ; # http token -> list (tile url, tile id)
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide map::slippy::fetcher 0.4
diff --git a/tcllib/modules/map/pkgIndex.tcl b/tcllib/modules/map/pkgIndex.tcl
new file mode 100644
index 0000000..a0351ec
--- /dev/null
+++ b/tcllib/modules/map/pkgIndex.tcl
@@ -0,0 +1,6 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded map::slippy 0.5 [list source [file join $dir map_slippy.tcl]]
+package ifneeded map::slippy::fetcher 0.4 [list source [file join $dir map_slippy_fetcher.tcl]]
+package ifneeded map::slippy::cache 0.2 [list source [file join $dir map_slippy_cache.tcl]]
+package ifneeded map::geocode::nominatim 0.1 [list source [file join $dir map_geocode_nominatim.tcl]]
+
diff --git a/tcllib/modules/mapproj/ChangeLog b/tcllib/modules/mapproj/ChangeLog
new file mode 100755
index 0000000..ce691da
--- /dev/null
+++ b/tcllib/modules/mapproj/ChangeLog
@@ -0,0 +1,47 @@
+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-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-08-24 Kevin B. Kenny <kennykb@acm.org>
+
+ * mapproj.man:
+ * mapproj.tcl:
+ * pkgIndex.tcl: Initial commit.
diff --git a/tcllib/modules/mapproj/mapproj.man b/tcllib/modules/mapproj/mapproj.man
new file mode 100755
index 0000000..4e642ce
--- /dev/null
+++ b/tcllib/modules/mapproj/mapproj.man
@@ -0,0 +1,308 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin mapproj n 0.1]
+[keywords geodesy]
+[keywords map]
+[keywords projection]
+[copyright {2007 Kevin B. Kenny <kennykb@acm.org>}]
+[moddesc {Tcl Library}]
+[titledesc {Map projection routines}]
+[require Tcl [opt 8.4]]
+[require math::interpolate [opt 1.0]]
+[require math::special [opt 0.2.1]]
+[require mapproj [opt 1.0]]
+[description]
+The [package mapproj] package provides a set of procedures for
+converting between world co-ordinates (latitude and longitude) and map
+co-ordinates on a number of different map projections.
+
+[section Commands]
+
+The following commands convert between world co-ordinates and
+map co-ordinates:
+
+[list_begin definitions]
+
+[call [cmd ::mapproj::toPlateCarree] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the [emph "plate carr\u00e9e"] (cylindrical equidistant)
+projection.
+[call [cmd ::mapproj::fromPlateCarree] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the [emph "plate carr\u00e9e"] (cylindrical equidistant)
+projection.
+[call [cmd ::mapproj::toCylindricalEqualArea] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the cylindrical equal-area projection.
+[call [cmd ::mapproj::fromCylindricalEqualArea] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the cylindrical equal-area projection.
+[call [cmd ::mapproj::toMercator] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the Mercator (cylindrical conformal) projection.
+[call [cmd ::mapproj::fromMercator] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the Mercator (cylindrical conformal) projection.
+[call [cmd ::mapproj::toMillerCylindrical] [arg lambda_0] [arg lambda] [arg phi]]
+Converts to the Miller Cylindrical projection.
+[call [cmd ::mapproj::fromMillerCylindrical] [arg lambda_0] [arg x] [arg y]]
+Converts from the Miller Cylindrical projection.
+[call [cmd ::mapproj::toSinusoidal] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the sinusoidal (Sanson-Flamsteed) projection.
+projection.
+[call [cmd ::mapproj::fromSinusoidal] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the sinusoidal (Sanson-Flamsteed) projection.
+projection.
+[call [cmd ::mapproj::toMollweide] [arg lambda_0] [arg lambda] [arg phi]]
+Converts to the Mollweide projection.
+[call [cmd ::mapproj::fromMollweide] [arg lambda_0] [arg x] [arg y]]
+Converts from the Mollweide projection.
+[call [cmd ::mapproj::toEckertIV] [arg lambda_0] [arg lambda] [arg phi]]
+Converts to the Eckert IV projection.
+[call [cmd ::mapproj::fromEckertIV] [arg lambda_0] [arg x] [arg y]]
+Converts from the Eckert IV projection.
+[call [cmd ::mapproj::toEckertVI] [arg lambda_0] [arg lambda] [arg phi]]
+Converts to the Eckert VI projection.
+[call [cmd ::mapproj::fromEckertVI] [arg lambda_0] [arg x] [arg y]]
+Converts from the Eckert VI projection.
+[call [cmd ::mapproj::toRobinson] [arg lambda_0] [arg lambda] [arg phi]]
+Converts to the Robinson projection.
+[call [cmd ::mapproj::fromRobinson] [arg lambda_0] [arg x] [arg y]]
+Converts from the Robinson projection.
+[call [cmd ::mapproj::toCassini] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the Cassini (transverse cylindrical equidistant)
+projection.
+[call [cmd ::mapproj::fromCassini] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the Cassini (transverse cylindrical equidistant)
+projection.
+[call [cmd ::mapproj::toPeirceQuincuncial] [arg lambda_0] [arg lambda] [arg phi]]
+Converts to the Peirce Quincuncial Projection.
+[call [cmd ::mapproj::fromPeirceQuincuncial] [arg lambda_0] [arg x] [arg y]]
+Converts from the Peirce Quincuncial Projection.
+[call [cmd ::mapproj::toOrthographic] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the orthographic projection.
+[call [cmd ::mapproj::fromOrthographic] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the orthographic projection.
+[call [cmd ::mapproj::toStereographic] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the stereographic (azimuthal conformal) projection.
+[call [cmd ::mapproj::fromStereographic] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the stereographic (azimuthal conformal) projection.
+[call [cmd ::mapproj::toGnomonic] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the gnomonic projection.
+[call [cmd ::mapproj::fromGnomonic] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the gnomonic projection.
+[call [cmd ::mapproj::toAzimuthalEquidistant] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the azimuthal equidistant projection.
+[call [cmd ::mapproj::fromAzimuthalEquidistant] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the azimuthal equidistant projection.
+[call [cmd ::mapproj::toLambertAzimuthalEqualArea] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the Lambert azimuthal equal-area projection.
+[call [cmd ::mapproj::fromLambertAzimuthalEqualArea] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the Lambert azimuthal equal-area projection.
+[call [cmd ::mapproj::toHammer] [arg lambda_0] [arg lambda] [arg phi]]
+Converts to the Hammer projection.
+[call [cmd ::mapproj::fromHammer] [arg lambda_0] [arg x] [arg y]]
+Converts from the Hammer projection.
+[call [cmd ::mapproj::toConicEquidistant] [arg lambda_0] [arg phi_0] [arg phi_1] [arg phi_2] [arg lambda] [arg phi]]
+Converts to the conic equidistant projection.
+[call [cmd ::mapproj::fromConicEquidistant] [arg lambda_0] [arg phi_0] [arg phi_1] [arg phi_2] [arg x] [arg y]]
+Converts from the conic equidistant projection.
+[call [cmd ::mapproj::toAlbersEqualAreaConic] [arg lambda_0] [arg phi_0] [arg phi_1] [arg phi_2] [arg lambda] [arg phi]]
+Converts to the Albers equal-area conic projection.
+[call [cmd ::mapproj::fromAlbersEqualAreaConic] [arg lambda_0] [arg phi_0] [arg phi_1] [arg phi_2] [arg x] [arg y]]
+Converts from the Albers equal-area conic projection.
+[call [cmd ::mapproj::toLambertConformalConic] [arg lambda_0] [arg phi_0] [arg phi_1] [arg phi_2] [arg lambda] [arg phi]]
+Converts to the Lambert conformal conic projection.
+[call [cmd ::mapproj::fromLambertConformalConic] [arg lambda_0] [arg phi_0] [arg phi_1] [arg phi_2] [arg x] [arg y]]
+Converts from the Lambert conformal conic projection.
+
+[list_end]
+
+Among the cylindrical equal-area projections, there are a number of
+choices of standard parallels that have names:
+
+[list_begin definitions]
+[call [cmd ::mapproj::toLambertCylindricalEqualArea] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the Lambert cylindrical equal area projection. (standard parallel
+is the Equator.)
+[call [cmd ::mapproj::fromLambertCylindricalEqualArea] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the Lambert cylindrical equal area projection. (standard parallel
+is the Equator.)
+[call [cmd ::mapproj::toBehrmann] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the Behrmann cylindrical equal area projection. (standard parallels
+are 30 degrees North and South)
+[call [cmd ::mapproj::fromBehrmann] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the Behrmann cylindrical equal area projection. (standard parallels
+are 30 degrees North and South.)
+[call [cmd ::mapproj::toTrystanEdwards] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the Trystan Edwards cylindrical equal area projection. (standard parallels
+are 37.4 degrees North and South)
+[call [cmd ::mapproj::fromTrystanEdwards] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the Trystan Edwards cylindrical equal area projection. (standard parallels
+are 37.4 degrees North and South.)
+[call [cmd ::mapproj::toHoboDyer] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the Hobo-Dyer cylindrical equal area projection. (standard parallels
+are 37.5 degrees North and South)
+[call [cmd ::mapproj::fromHoboDyer] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the Hobo-Dyer cylindrical equal area projection. (standard parallels
+are 37.5 degrees North and South.)
+[call [cmd ::mapproj::toGallPeters] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the Gall-Peters cylindrical equal area projection. (standard parallels
+are 45 degrees North and South)
+[call [cmd ::mapproj::fromGallPeters] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the Gall-Peters cylindrical equal area projection. (standard parallels
+are 45 degrees North and South.)
+[call [cmd ::mapproj::toBalthasart] [arg lambda_0] [arg phi_0] [arg lambda] [arg phi]]
+Converts to the Balthasart cylindrical equal area projection. (standard parallels
+are 50 degrees North and South)
+[call [cmd ::mapproj::fromBalthasart] [arg lambda_0] [arg phi_0] [arg x] [arg y]]
+Converts from the Balthasart cylindrical equal area projection. (standard parallels
+are 50 degrees North and South.)
+
+[list_end]
+
+[section Arguments]
+
+The following arguments are accepted by the projection commands:
+
+[list_begin definitions]
+
+[def [arg lambda]]
+
+Longitude of the point to be projected, in degrees.
+
+[def [arg phi]]
+
+Latitude of the point to be projected, in degrees.
+
+[def [arg lambda_0]]
+
+Longitude of the center of the sheet, in degrees. For many projections,
+this figure is also the reference meridian of the projection.
+
+[def [arg phi_0]]
+
+Latitude of the center of the sheet, in degrees. For the azimuthal
+projections, this figure is also the latitude of the center of the projection.
+
+[def [arg phi_1]]
+
+Latitude of the first reference parallel, for projections that use reference
+parallels.
+
+[def [arg phi_2]]
+
+Latitude of the second reference parallel, for projections that use reference
+parallels.
+
+[def [arg x]]
+
+X co-ordinate of a point on the map, in units of Earth radii.
+
+[def [arg y]]
+
+Y co-ordinate of a point on the map, in units of Earth radii.
+
+[list_end]
+
+[section Results]
+
+For all of the procedures whose names begin with 'to', the return value
+is a list comprising an [emph x] co-ordinate and a [emph y] co-ordinate.
+The co-ordinates are relative to the center of the map sheet to be drawn,
+measured in Earth radii at the reference location on the map.
+
+For all of the functions whose names begin with 'from', the return value
+is a list comprising the longitude and latitude, in degrees.
+
+[section {Choosing a projection}]
+
+This package offers a great many projections, because no single projection
+is appropriate to all maps. This section attempts to provide guidance
+on how to choose a projection.
+[para]
+First, consider the type of data that you intend to display on the map.
+If the data are [emph directional] ([emph e.g.,] winds, ocean currents, or
+magnetic fields) then you need to use a projection that preserves
+angles; these are known as [emph conformal] projections. Conformal
+projections include the Mercator, the Albers azimuthal equal-area,
+the stereographic, and the Peirce Quincuncial projection. If the
+data are [emph thematic], describing properties of land or water, such
+as temperature, population density, land use, or demographics; then
+you need a projection that will show these data with the areas on the map
+proportional to the areas in real life. These so-called [emph {equal area}]
+projections include the various cylindrical equal area projections,
+the sinusoidal projection, the Lambert azimuthal equal-area projection,
+the Albers equal-area conic projection, and several of the world-map
+projections (Miller Cylindrical, Mollweide, Eckert IV, Eckert VI, Robinson,
+and Hammer). If the significant factor in your data is distance from a
+central point or line (such as air routes), then you will do best with
+an [emph equidistant] projection such as [emph "plate carr\u00e9e"],
+Cassini, azimuthal equidistant, or conic equidistant. If direction from
+a central point is a critical factor in your data (for instance,
+air routes, radio antenna pointing), then you will almost surely want to
+use one of the azimuthal projections. Appropriate choices are azimuthal
+equidistant, azimuthal equal-area, stereographic, and perhaps orthographic.
+[para]
+Next, consider how much of the Earth your map will cover, and the general
+shape of the area of interest. For maps of the entire Earth,
+the cylindrical equal area, Eckert IV and VI, Mollweide, Robinson, and Hammer
+projections are good overall choices. The Mercator projection is traditional,
+but the extreme distortions of area at high latitudes make it
+a poor choice unless a conformal projection is required. The Peirce
+projection is a better choice of conformal projection, having less distortion
+of landforms. The Miller Cylindrical is a compromise designed to give
+shapes similar to the traditional Mercator, but with less polar stretching.
+The Peirce Quincuncial projection shows all the continents with acceptable
+distortion if a reference meridian close to +20 degrees is chosen.
+The Robinson projection yields attractive maps for things like political
+divisions, but should be avoided in presenting scientific data, since other
+projections have moe useful geometric properties.
+[para]
+If the map will cover a hemisphere, then choose stereographic,
+azimuthal-equidistant, Hammer, or Mollweide projections; these all project
+the hemisphere into a circle.
+[para]
+If the map will cover a large area (at least a few hundred km on a side),
+but less than
+a hemisphere, then you have several choices. Azimuthal projections
+are usually good (choose stereographic, azimuthal equidistant, or
+Lambert azimuthal equal-area according to whether shapes, distances from
+a central point, or areas are important). Azimuthal projections (and possibly
+the Cassini projection) are the only
+really good choices for mapping the polar regions.
+[para]
+If the large area is in one of the temperate zones and is round or has
+a primarily east-west extent, then the conic projections are good choices.
+Choose the Lambert conformal conic, the conic equidistant, or the Albers
+equal-area conic according to whether shape, distance, or area are the
+most important parameters. For any of these, the reference parallels
+should be chosen at approximately 1/6 and 5/6 of the range of latitudes
+to be displayed. For instance, maps of the 48 coterminous United States
+are attractive with reference parallels of 28.5 and 45.5 degrees.
+[para]
+If the large area is equatorial and is round or has a primarily east-west
+extent, then the Mercator projection is a good choice for a conformal
+projection; Lambert cylindrical equal-area and sinusoidal projections are
+good equal-area projections; and the [emph "plate carr\u00e9e"] is a
+good equidistant projection.
+[para]
+Large areas having a primarily North-South aspect, particularly those
+spanning the Equator, need some other choices. The Cassini projection
+is a good choice for an equidistant projection (for instance, a Cassini
+projection with a central meridian of 80 degrees West produces an
+attractive map of the Americas). The cylindrical equal-area, Albers
+equal-area conic, sinusoidal, Mollweide and Hammer
+projections are possible choices for equal-area projections.
+A good conformal projection in this situation is the Transverse
+Mercator, which alas, is not yet implemented.
+[para]
+Small areas begin to get into a realm where the ellipticity of the
+Earth affects the map scale. This package does not attempt to
+handle accurate mapping for large-scale topographic maps. If
+slight scale errors are acceptable in your application, then any
+of the projections appropriate to large areas should work for
+small ones as well.
+[para]
+There are a few projections that are included for their special
+properties. The orthographic projection produces views of the
+Earth as seen from space. The gnomonic projection produces a
+map on which all great circles (the shortest distance between
+two points on the Earth's surface) are rendered as straight lines.
+While this projection is useful for navigational planning, it
+has extreme distortions of shape and area, and can display
+only a limited area of the Earth (substantially less than a hemisphere).
+[manpage_end]
diff --git a/tcllib/modules/mapproj/mapproj.tcl b/tcllib/modules/mapproj/mapproj.tcl
new file mode 100755
index 0000000..1c545f9
--- /dev/null
+++ b/tcllib/modules/mapproj/mapproj.tcl
@@ -0,0 +1,1817 @@
+# mapproj.tcl --
+#
+# Package for map projections.
+#
+# Copyright (c) 2007 by Kevin B. Kenny.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: mapproj.tcl,v 1.1 2007/08/24 22:36:35 kennykb Exp $
+#------------------------------------------------------------------------------
+
+package require Tcl 8.4
+package require math::interpolate 1.0
+package require math::special 0.2.1
+
+package provide mapproj 1.0
+
+# ::mapproj --
+#
+# Namespace holding the procedures and values.
+
+namespace eval ::mapproj {
+
+ # Cylindrical projections
+
+ namespace export toPlateCarree fromPlateCarree
+ namespace export toCassini fromCassini
+ namespace export toCylindricalEqualArea fromCylindricalEqualArea
+ namespace export toMercator fromMercator
+
+ # Named cylindric equal-area projections with specific
+ # standard parallels
+
+ namespace export toLambertCylindricalEqualArea \
+ fromLambertCylindricalEqualArea
+ namespace export toBehrmann fromBehrmann
+ namespace export toTrystanEdwards fromTrystanEdwards
+ namespace export toHoboDyer fromHoboDyer
+ namespace export toGallPeters fromGallPeters
+ namespace export toBalthasart fromBalthasart
+
+ # Pseudocylindrical projections - equal area
+
+ namespace export toSinusoidal fromSinusoidal
+ namespace export toMillerCylindrical fromMillerCylindrical
+ namespace export toMollweide fromMollweide
+ namespace export toEckertIV fromEckertIV toEckertVI fromEckertVI
+
+ # Pseudocylindrical projections - compromise
+
+ namespace export toRobinson fromRobinson
+
+ # Azimuthal projections
+
+ namespace export toAzimuthalEquidistant fromAzimuthalEquidistant
+ namespace export toLambertAzimuthalEqualArea fromLambertAzimuthalEqualArea
+ namespace export toStereographic fromStereographic
+ namespace export toOrthographic fromOrthographic
+ namespace export toGnomonic fromGnomonic
+
+ # Pseudo-azimuthal projections
+
+ namespace export toHammer fromHammer
+
+ # Conic projections
+
+ namespace export toConicEquidistant fromConicEquidistant
+ namespace export toLambertConformalConic fromLambertConformalConic
+ namespace export toAlbersEqualAreaConic fromAlbersEqualAreaConic
+
+ # Miscellaneous projections
+
+ namespace export toPeirceQuincuncial fromPeirceQuincuncial
+
+ # Fundamental constants
+
+ variable pi [expr {acos(-1.0)}]
+ variable twopi [expr {2.0 * $pi}]
+ variable halfpi [expr {0.5 * $pi}]
+ variable quarterpi [expr {0.25 * $pi}]
+ variable threequarterpi [expr {0.75 * $pi}]
+ variable mquarterpi [expr {-0.25 * $pi}]
+ variable mthreequarterpi [expr {-0.75 * $pi}]
+ variable radian [expr {180. / $pi}]
+ variable degree [expr {$pi / 180.}]
+ variable sqrt2 [expr {sqrt(2.)}]
+ variable sqrt8 [expr {2. * $sqrt2}]
+ variable halfSqrt3 [expr {sqrt(3.) / 2.}]
+ variable halfSqrt2 [expr {sqrt(2.) / 2.}]
+ variable EckertIVK1 [expr {2.0 / sqrt($pi * (4.0 + $pi))}]
+ variable EckertIVK2 [expr {2.0 * sqrt($pi / (4.0 + $pi))}]
+ variable EckertVIK1 [expr {sqrt(2.0 + $pi)}]
+ variable PeirceQuincuncialScale 3.7081493546027438 ;# 2*K(1/2)
+ variable PeirceQuincuncialLimit 1.8540746773013719 ;# K(1/2)
+
+ # Table of parallel length and distance from equator for the
+ # Robinson projection
+
+ variable RobinsonLatitude {
+ -90.0 -85.0 -80.0 -75.0 -70.0 -65.0
+ -60.0 -55.0 -50.0 -45.0 -40.0 -35.0
+ -30.0 -25.0 -20.0 -15.0 -10.0 -5.0
+ 0.0 5.0 10.0 15.0 20.0 25.0 30.0
+ 35.0 40.0 45.0 50.0 55.0 60.0
+ 65.0 70.0 75.0 80.0 85.0 90.0
+ }
+ variable RobinsonPLEN {
+ 0.5322 0.5722 0.6213 0.6732 0.7186 0.7597
+ 0.7986 0.8350 0.8679 0.8962 0.9216 0.9427
+ 0.9600 0.9730 0.9822 0.9900 0.9954 0.9986
+ 1.0000 0.9986 0.9954 0.9900 0.9822 0.9730 0.9600
+ 0.9427 0.9216 0.8962 0.8679 0.8350 0.7986
+ 0.7597 0.7186 0.6732 0.6213 0.5722 0.5322
+ }
+ variable RobinsonPDFE {
+ -1.0000 -0.9761 -0.9394 -0.8936 -0.8435 -0.7903
+ -0.7346 -0.6769 -0.6176 -0.5571 -0.4958 -0.4340
+ -0.3720 -0.3100 -0.2480 -0.1860 -0.1240 -0.0620
+ 0.0000 0.0620 0.1240 0.1860 0.2480 0.3100 0.3720
+ 0.4340 0.4958 0.5571 0.6176 0.6769 0.7346
+ 0.7903 0.8435 0.8936 0.9394 0.9761 1.0000
+ }
+
+ # Interpolation tables for Robinson
+
+ variable RobinsonSplinePLEN \
+ [math::interpolate::prepare-cubic-splines \
+ $RobinsonLatitude $RobinsonPLEN]
+ variable RobinsonSplinePDFE \
+ [math::interpolate::prepare-cubic-splines \
+ $RobinsonLatitude $RobinsonPDFE]
+ variable RobinsonM [expr {0.5072 * $pi}]
+
+ namespace import ::math::special::cn
+
+}
+
+# ::mapproj::ellF -
+#
+# Computes the Legendre incomplete elliptic integral of the
+# first kind:
+#
+# F(phi, k) = \integral_0^phi dtheta/sqrt(1 - k**2 sin**2 theta)
+#
+#
+# Parameters:
+# phi -- Limit of integration; angle around the ellipse
+# k -- Eccentricity
+#
+# Results:
+# Returns F(phi, k)
+#
+# Notes:
+# We compute this integral in terms of the Carlson elliptic integral
+# ellRF(x, y, z).
+
+proc ::mapproj::ellF {phi k} {
+ return [ellFaux [expr {cos($phi)}] [expr {sin($phi)}] $k]
+}
+
+# ::mapproj::ellFaux -
+#
+# Computes the Legendre incomplete elliptic integral of the
+# first kind when circular functions of the 'phi' argument
+# are already available.
+#
+# Parameters:
+# cos_phi - Cosine of the argument
+# sin_phi - Sine of the argument
+# k - Parameter
+#
+# Results:
+# Returns F(atan(sin_phi/cos_phi), k)
+
+proc ::mapproj::ellFaux {cos_phi sin_phi k} {
+ set rf [ellRF [expr {$cos_phi * $cos_phi}] \
+ [expr {1.0 - $k * $k * $sin_phi * $sin_phi}] \
+ 1.0]
+ return [expr {$sin_phi * $rf}]
+}
+
+# ::mapproj::ellRF --
+#
+# Computes the Carlson incomplete elliptic integral of the
+# first kind:
+#
+# RF(x, y, z) = 1/2 * integral_0^inf dt/sqrt((t+x)*(t+y)*(t+z))
+#
+# Parameters:
+# x, y, z -- Interchangeable parameters of the integral
+#
+# Results:
+# Returns the value of RF
+
+proc ::mapproj::ellRF {x y z} {
+ if {$x < 0.0 || $y < 0.0 || $z < 0.0} {
+ return -code error "Negative argument to Carlson's ellRF" \
+ -errorCode "ellRF negArgument"
+ }
+ set delx 1.0; set dely 1.0; set delz 1.0
+ while {abs($delx) > 0.0025 || abs($dely) > 0.0025 || abs($delz) > 0.0025} {
+ set sx [expr {sqrt($x)}]
+ set sy [expr {sqrt($y)}]
+ set sz [expr {sqrt($z)}]
+ set len [expr {$sx * ($sy + $sz) + $sy * $sz}]
+ set x [expr {0.25 * ($x + $len)}]
+ set y [expr {0.25 * ($y + $len)}]
+ set z [expr {0.25 * ($z + $len)}]
+ set mean [expr {($x + $y + $z) / 3.0}]
+ set delx [expr {($mean - $x) / $mean}]
+ set dely [expr {($mean - $y) / $mean}]
+ set delz [expr {($mean - $z) / $mean}]
+ }
+ set e2 [expr {$delx * $dely - $delz * $delz}]
+ set e3 [expr {$delx * $dely * $delz}]
+ return [expr {(1.0 + ($e2 / 24.0 - 0.1 - 3.0 * $e3 / 44.0) * $e2
+ + $e3 / 14.) / sqrt($mean)}]
+}
+
+# ::mapproj::toPlateCarree --
+#
+# Project a latitude and longitude onto the plate carre.
+#
+# Parameters:
+# phi_0 -- Latitude of the center of the sheet in degrees
+# lambda_0 -- Longitude of the center of sheet in degrees
+# lambda -- Longitude of the point to be projected in degrees
+# phi -- Latitude of the point to be projected in degrees
+#
+# Results:
+# Returns x and y co-ordinates. Units of x and y are Earth radii;
+# scale is true at the Equator.
+
+proc ::mapproj::toPlateCarree {lambda_0 phi_0 lambda phi} {
+ variable degree
+ set lambda [expr {$lambda - $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ set x [expr {$lambda * $degree}]
+ set y [expr {($phi - $phi_0) * $degree}]
+ return [list $x $y]
+}
+
+# ::mapproj::fromPlateCarree --
+#
+# Solve a plate carre projection for the
+# latitude and longitude represented by a point on the map.
+#
+# Parameters:
+# phi_0 -- Latitude of the center of the sheet in degrees
+# lambda_0 -- Longitude of the center of projection
+# x,y -- normalized x and y co-ordinates of a point on the map
+#
+# Results:
+# Returns a list consisting of the longitude and latitude in degrees.
+
+proc ::mapproj::fromPlateCarree {phi_0 lambda_0 x y} {
+ variable radian
+ set lambda [expr {$lambda_0 + $x * $radian + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ set phi [expr {$y * $radian + $phi_0}]
+ return [list $lambda $phi]
+}
+
+# mapproj::toCylindricalEqualArea --
+#
+# Project a latitude and longitude into cylindrical equal-area
+# co-ordinates.
+#
+# Parameters:
+# phi_1 -- Standard latitude in degrees
+# phi_0 -- Latitude of the center of the sheet in degrees
+# lambda_0 -- Longitude of the center of projection in degrees
+# lambda -- Longitude of the point to be projected in degrees
+# phi -- Latitude of the point to be projected in degrees
+#
+# Results:
+# Returns x and y co-ordinates. Units of x and y are Earth radii;
+# scale is true at the reference latitude
+
+proc ::mapproj::toCylindricalEqualArea {phi_1 lambda_0 phi_0 lambda phi} {
+ variable degree
+ set cos_phi_s [expr {cos($phi_1 * $degree)}]
+ set lambda [expr {$lambda - $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ set x [expr {$lambda * $degree * $cos_phi_s}]
+ set y0 [expr {sin($phi_0 * $degree) / $cos_phi_s}]
+ set y [expr {sin($phi * $degree) / $cos_phi_s}]
+ return [list $x [expr {$y - $y0}]]
+}
+
+# ::mapproj::fromCylindricalEqualArea --
+#
+# Solve a cylindrical equal area map projection for the
+# latitude and longitude represented by a point on the map.
+#
+# Parameters:
+# phi_1 -- Standard latitude in degrees
+# phi_0 -- Latitude of the center of the sheet in degrees
+# lambda_0 -- Longitude of the center of sheet in degrees
+# x,y -- normalized x and y co-ordinates of a point on the map
+#
+# Results:
+# Returns a list consisting of the longitude and latitude in degrees.
+
+proc ::mapproj::fromCylindricalEqualArea {phi_1 lambda_0 phi_0 x y} {
+ variable degree
+ variable radian
+ set cos_phi_s [expr {cos($phi_1 * $degree)}]
+ set lambda [expr {$lambda_0 + $x / $cos_phi_s * $radian + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ set y0 [expr {sin($phi_0 * $degree) / $cos_phi_s}]
+ set phi [expr {asin(($y + $y0) * $cos_phi_s) * $radian}]
+ return [list $lambda $phi]
+}
+
+# ::mapproj::toMercator --
+#
+# Project a latitude and longitude into the Mercator projection
+# co-ordinates.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection in degrees
+# phi_0 -- Latitude of the center of sheet in degrees
+# lambda -- Longitude of the point to be projected in degrees
+# phi -- Latitude of the point to be projected in degrees
+#
+# Results:
+# Returns x and y co-ordinates in Earth radii. Scale is true
+# at the Equator and increases without bounds toward the Poles.
+
+proc ::mapproj::toMercator {lambda_0 phi_0 lambda phi} {
+ variable trace; if {[info exists trace]} { puts [info level 0] }
+ variable degree
+ variable quarterpi
+ set lambda [expr {$lambda - $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ set x [expr {$lambda * $degree}]
+ set y [expr {log(tan($quarterpi + 0.5 * $phi * $degree))}]
+ set y0 [expr {log(tan($quarterpi + 0.5 * $phi_0 * $degree))}]
+ if {[info exists trace]} { puts "[info level 0] -> $x [expr {$y - $y0}]" }
+ return [list $x [expr {$y - $y0}]]
+}
+
+# ::mapproj::fromMercator --
+#
+# Converts Mercator map co-ordinates to latitude and longitude.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection
+# phi_0 -- Latitude of the center of sheet in degrees
+# x,y -- normalized x and y co-ordinates of a point on the map
+#
+# Results:
+# Returns a list consisting of the longitude and latitude in degrees.
+
+proc ::mapproj::fromMercator {lambda_0 phi_0 x y} {
+ variable quarterpi
+ variable degree
+ variable radian
+ set y0 [expr {log(tan($quarterpi + 0.5 * $phi_0 * $degree))}]
+ set lambda [expr {$lambda_0 + $x * $radian + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ set phi [expr {$radian * 2.0 * atan(exp($y + $y0)) - 90.0}]
+ return [list $lambda $phi]
+}
+
+# ::mapproj::toMillerCylindrical --
+#
+# Project a latitude and longitude into the Miller Cylindrical projection
+# co-ordinates.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection in degrees
+# lambda -- Longitude of the point to be projected in degrees
+# phi -- Latitude of the point to be projected in degrees
+#
+# Results:
+# Returns x and y co-ordinates. The x co-ordinate ranges from
+# -$pi to pi.
+
+proc ::mapproj::toMillerCylindrical {lambda_0 lambda phi} {
+ foreach {x y} [toMercator $lambda_0 0.0 \
+ $lambda [expr {0.8 * $phi}]] break
+ set y [expr {1.25 * $y}]
+ return [list $x $y]
+}
+
+# ::mapproj::fromMillerCylindrical --
+#
+# Converts Miller Cylindrical projected map co-ordinates
+# to latitude and longitude.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection
+# x,y -- normalized x and y co-ordinates of a point on the map
+#
+# Results:
+# Returns a list consisting of the longitude and latitude in degrees.
+
+proc ::mapproj::fromMillerCylindrical {lambda_0 x y} {
+ foreach {lambda phi} [fromMercator $lambda_0 0.0 \
+ $x [expr {0.8 * $y}]] break
+ return [list $lambda [expr {1.25 * $phi}]]
+}
+
+# ::mapproj::toSinusoidal --
+#
+# Project a latitude and longitude into the sinusoidal
+# (Sanson-Flamsteed) projection.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection in degrees
+# phi_0 -- Latitude of the center of the sheet, in degrees
+# lambda -- Longitude of the point to be projected in degrees
+# phi -- Latitude of the point to be projected in degrees
+#
+# Results:
+# Returns x and y co-ordinates, in Earth radii.
+# Scale is true along the Equator and central meridian.
+
+proc ::mapproj::toSinusoidal {lambda_0 phi_0 lambda phi} {
+ variable degree
+ variable quarterpi
+ set lambda [expr {$lambda - $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {($lambda - 180.) * $degree}]
+ set phi [expr {$phi * $degree}]
+ set x [expr {$lambda * cos($phi)}]
+ set phi [expr {$phi - $phi_0 * $degree}]
+ return [list $x $phi]
+}
+
+# ::mapproj::fromSinusoidal --
+#
+# Converts sinusoidal (Sanson-Flamsteed) map co-ordinates
+# to latitude and longitude.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection
+# phi_0 -- Latitude of the center of the sheet, in degrees
+# x,y -- normalized x and y co-ordinates of a point on the map
+#
+# Results:
+# Returns a list consisting of the longitude and latitude in degrees.
+
+proc ::mapproj::fromSinusoidal {lambda_0 phi_0 x y} {
+ variable degree
+ variable radian
+ set y [expr {$y + $phi_0 * $degree}]
+ set phi [expr {$y * $radian}]
+ set lambda [expr {180. + $lambda_0 + $radian * $x / cos($y)}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ return [list $lambda $phi]
+}
+
+# ::mapproj::toMollweide --
+#
+# Project a latitude and longitude into the Mollweide projection
+# co-ordinates.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection in degrees
+# lambda -- Longitude of the point to be projected in degrees
+# phi -- Latitude of the point to be projected in degrees
+#
+# Results:
+# Returns x and y co-ordinates, in Earth radii.
+# Scale is true along the 40 deg 44 min parallels
+
+proc ::mapproj::toMollweide {lambda_0 lambda phi} {
+ variable degree
+ variable pi
+ variable halfpi
+ variable sqrt2
+ variable sqrt8
+ set lambda [expr {$lambda - $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {($lambda - 180.) * $degree}]
+ set phi [expr {$phi * $degree}]
+ set theta [expr {2.0 * asin(2.0 * $phi / $pi)}]
+ set diff 1.0
+ set pisinphi [expr {$pi * sin($phi)}]
+ while {abs($diff) >= 1.0e-4} {
+ set diff [expr {($theta + sin($theta) - $pisinphi)
+ / (1.0 + cos($theta))}]
+ set theta [expr {$theta - $diff}]
+ }
+ set theta [expr {0.5 * $theta}]
+ set x [expr {$sqrt8 * $lambda * cos($theta) / $pi}]
+ set y [expr {$sqrt2 * sin($theta)}]
+ return [list $x $y]
+}
+
+# ::mapproj::fromMollweide --
+#
+# Converts Mollweide projected map co-ordinates to latitude
+# and longitude.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection
+# x,y -- normalized x and y co-ordinates of a point on the map
+#
+# Results:
+# Returns a list consisting of the longitude and latitude in degrees.
+
+proc ::mapproj::fromMollweide {lambda_0 x y} {
+ variable pi
+ variable radian
+ variable degree
+ variable halfpi
+ variable sqrt2
+ variable sqrt8
+ set theta [expr {asin($y / $sqrt2)}]
+ set lambda [expr {$lambda_0 + $radian * $pi * $x /
+ ($sqrt8 * cos($theta)) + 180.}]
+ set phi [expr {asin((2.0 * $theta + sin(2.0 * $theta)) / $pi)}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ return [list $lambda [expr {$phi * $radian}]]
+}
+
+# ::mapproj::toEckertIV --
+#
+# Project a latitude and longitude into the Eckert IV projection
+# co-ordinates.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection in degrees
+# lambda -- Longitude of the point to be projected in degrees
+# phi -- Latitude of the point to be projected in degrees
+#
+# Results:
+# Returns x and y co-ordinates. Scale is true along the 40 deg 30 min
+# parallels.
+
+proc ::mapproj::toEckertIV {lambda_0 lambda phi} {
+ variable degree
+ variable pi
+ variable halfpi
+ variable EckertIVK1
+ variable EckertIVK2
+ set lambda [expr {$lambda - $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {($lambda - 180.) * $degree}]
+ set phi [expr {$phi * $degree}]
+ set theta [expr {$phi / 2}]
+ set diff 1.0
+ set A [expr {(2.0 + $halfpi) * sin($phi)}]
+ while {abs($diff) >= 1.0e-4} {
+ set costheta [expr {cos($theta)}]
+ set sintheta [expr {sin($theta)}]
+ set diff \
+ [expr {($theta + $sintheta * $costheta + 2.0 * sin($theta) - $A)
+ / (2.0 * $costheta * (1.0 + $costheta))}]
+ set theta [expr {$theta - $diff}]
+ }
+ set x [expr {$EckertIVK1 * $lambda * (1.0 + cos($theta))}]
+ set y [expr {$EckertIVK2 * sin($theta)}]
+ return [list $x $y]
+}
+
+# ::mapproj::fromEckertIV --
+#
+# Converts Eckert IV projected map co-ordinates to latitude
+# and longitude.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection
+# x,y -- normalized x and y co-ordinates of a point on the map
+#
+# Results:
+# Returns a list consisting of the longitude and latitude in degrees.
+
+proc ::mapproj::fromEckertIV {lambda_0 x y} {
+ variable pi
+ variable radian
+ variable degree
+ variable halfpi
+ variable sqrt2
+ variable EckertIVK1
+ variable EckertIVK2
+ set sintheta [expr {$y / $EckertIVK2}]
+ set costheta [expr {sqrt(1.0 - $sintheta * $sintheta)}]
+ set theta [expr {atan2($sintheta, $costheta)}]
+ set phi [expr {asin(($theta + $sintheta*$costheta + 2.*$sintheta)
+ / (2. + $halfpi))}]
+ set lambda [expr {180.0 + $lambda_0
+ + $radian / $EckertIVK1 * $x / (1.0 + $costheta)}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ return [list $lambda [expr {$phi * $radian}]]
+}
+
+# ::mapproj::toEckertVI --
+#
+# Project a latitude and longitude into the Eckert IV projection
+# co-ordinates.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection in degrees
+# lambda -- Longitude of the point to be projected in degrees
+# phi -- Latitude of the point to be projected in degrees
+#
+# Results:
+# Returns x and y co-ordinates. Scale is true along the 40 deg 30 min
+# parallels.
+
+proc ::mapproj::toEckertVI {lambda_0 lambda phi} {
+ variable degree
+ variable pi
+ variable halfpi
+ variable EckertVIK1
+ set lambda [expr {$lambda - $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {($lambda - 180.) * $degree}]
+ set phi [expr {$phi * $degree}]
+ set theta [expr {$phi / 2}]
+ set diff 1.0
+ set A [expr {(1.0 + $halfpi) * sin($phi)}]
+ while {abs($diff) >= 1.0e-4} {
+ set costheta [expr {cos($theta)}]
+ set sintheta [expr {sin($theta)}]
+ set diff \
+ [expr {($theta + $sintheta - $A)
+ / (1.0 + $costheta)}]
+ set theta [expr {$theta - $diff}]
+ }
+ set x [expr {$lambda * (1.0 + cos($theta)) / $EckertVIK1}]
+ set y [expr {2.0 * $theta / $EckertVIK1}]
+ return [list $x $y]
+}
+
+# ::mapproj::fromEckertVI --
+#
+# Converts Eckert IV projected map co-ordinates to latitude
+# and longitude.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection
+# x,y -- normalized x and y co-ordinates of a point on the map
+#
+# Results:
+# Returns a list consisting of the longitude and latitude in degrees.
+
+proc ::mapproj::fromEckertVI {lambda_0 x y} {
+ variable pi
+ variable radian
+ variable degree
+ variable halfpi
+ variable sqrt2
+ variable EckertVIK1
+ puts [info level 0]
+ set theta [expr {0.5 * $EckertVIK1 * $y}]
+ puts [list theta = $theta]
+ set phi [expr {asin(($theta + sin($theta)) / (1.0 + $halfpi))}]
+ puts [list phi = $phi]
+ set lambda [expr {180.0 + $lambda_0 + $radian * $EckertVIK1 * $x
+ / (1 + cos($theta))}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ return [list $lambda [expr {$phi * $radian}]]
+}
+
+# ::mapproj::toRobinson --
+#
+# Project a latitude and longitude into the Robinson projection.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection in degrees
+# lambda -- Longitude of the point to be projected in degrees
+# phi -- Latitude of the point to be projected in degrees
+#
+# Results:
+# Returns x and y co-ordinates, in Earth radii.
+# Scale is true along the Equator.
+
+proc ::mapproj::toRobinson {lambda_0 lambda phi} {
+ variable RobinsonLatitude
+ variable RobinsonSplinePLEN
+ variable RobinsonSplinePDFE
+ variable RobinsonM
+ variable pi
+ variable degree
+ set lambda [expr {$lambda - $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ set y [math::interpolate::interp-cubic-splines $RobinsonSplinePDFE $phi]
+ set y [expr {$RobinsonM * $y}]
+ set s [math::interpolate::interp-cubic-splines $RobinsonSplinePLEN $phi]
+ set x [expr {$degree * $s * $lambda}]
+ return [list $x $y]
+}
+
+# ::mapproj::fromRobinson --
+#
+# Solve the Robinson projection for the
+# latitude and longitude represented by a point on the map.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection
+# x,y -- normalized x and y co-ordinates of a point on the map
+#
+# Results:
+# Returns a list consisting of the longitude and latitude in degrees.
+
+proc ::mapproj::fromRobinson {lambda_0 x y} {
+ variable RobinsonLatitude
+ variable RobinsonPDFE
+ variable RobinsonSplinePLEN
+ variable RobinsonSplinePDFE
+ variable RobinsonM
+ variable radian
+
+ # We know that Robinson latitudes are equally spaced from [-90..90]
+ # at 5-degree intervals. Find the values for RobinsonPDFE that
+ # bracket the y co-ordinate.
+
+ set y [expr {$y / $RobinsonM}]
+ set l 0
+ set u [expr {[llength $RobinsonPDFE] - 1}]
+ while {$l < $u} {
+ set m [expr {($l + $u + 1) / 2}]
+ if {$y >= [lindex $RobinsonPDFE $m]} {
+ set l $m
+ } else {
+ set u [expr {$m - 1}]
+ }
+ }
+ set u [lindex $RobinsonLatitude [expr {$l+1}]]
+ set l [lindex $RobinsonLatitude $l]
+ for {set i 0} {$i < 12} {incr i} {
+ set m [expr {0.5 * ($u + $l)}]
+ set ystar [math::interpolate::interp-cubic-splines \
+ $RobinsonSplinePDFE $m]
+ if {$ystar < $y} {
+ set l $m
+ } else {
+ set u $m
+ }
+ }
+ puts "latitude $m"
+ set s [math::interpolate::interp-cubic-splines $RobinsonSplinePLEN $m]
+ puts "parallel length $s"
+ set lambda [expr {180.0 + $lambda_0 + $radian * $x / $s}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ return [list $lambda $m]
+}
+
+# ::mapproj::toCassini --
+#
+# Project a latitude and longitude into the Cassini projection.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection in degrees
+# phi_0 -- Latitude of the center of the sheet
+# lambda -- Longitude of the point to be projected in degrees
+# phi -- Latitude of the point to be projected in degrees
+#
+# Results:
+# Returns x and y co-ordinates, in Earth radii.
+# Scale is true along the central meridian.
+
+proc ::mapproj::toCassini {lambda_0 phi_0 lambda phi} {
+ variable degree
+ variable pi
+ variable twopi
+ variable quarterpi
+ set lambda [expr {$lambda - $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {($lambda - 180.) * $degree}]
+ set phi [expr {$phi * $degree}]
+ set x [expr {asin(cos($phi) * sin($lambda))}]
+ set y [expr {atan2(tan($phi), cos($lambda)) - $degree * $phi_0}]
+ if {$y < -$pi} {
+ set y [expr {$y + $twopi}]
+ } elseif {$y > $pi} {
+ set y [expr {$y - $twopi}]
+ }
+ return [list $x $y]
+}
+
+# ::mapproj::fromCassini --
+#
+# Converts Cassini map co-ordinates to latitude and longitude.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection
+# phi_0 -- Latitude of the center of the sheet
+# x,y -- normalized x and y co-ordinates of a point on the map
+#
+# Results:
+# Returns a list consisting of the longitude and latitude in degrees.
+
+proc ::mapproj::fromCassini {lambda_0 phi_0 x y} {
+ variable degree
+ variable radian
+ set y [expr {$y + $degree * $phi_0}]
+ set phi [expr {$radian * asin(cos($x) * sin($y))}]
+ set lambda [expr {180. + $lambda_0 + $radian * atan2(tan($x), cos($y))}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ return [list $lambda $phi]
+}
+
+# ::mapproj::toPeirceQuincuncial
+#
+# Converts geodetic co-ordinates to the Peirce Quincuncial projection.
+#
+# Parameters:
+# lambda_0 - Longitude of the central meridian. (Conventionally, 20.0).
+# lambda - Longitude of the point to be projected in degrees
+# phi - Latitude of the point to be projected in degrees.
+#
+# Results:
+# Returns a list of the x and y co-ordinates.
+
+proc ::mapproj::toPeirceQuincuncial {lambda_0 lambda phi} {
+ variable degree
+ variable halfSqrt2
+ variable pi
+ variable quarterpi
+ variable mquarterpi
+ variable threequarterpi
+ variable mthreequarterpi
+ variable PeirceQuincuncialScale
+
+ # Convert latitude and longitude to radians relative to the
+ # central meridian
+
+ set lambda [expr {$lambda - $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {($lambda - 180.) * $degree}]
+ set phi [expr {$phi * $degree}]
+
+ # Compute the auxiliary quantities 'm' and 'n'. Set 'm' to match
+ # the sign of 'lambda' and 'n' to be positive if |lambda| > pi/2
+
+ set cos_phiosqrt2 [expr {$halfSqrt2 * cos($phi)}]
+ set cos_lambda [expr {cos($lambda)}]
+ set sin_lambda [expr {sin($lambda)}]
+ set cos_a [expr {$cos_phiosqrt2 * ($sin_lambda + $cos_lambda)}]
+ set cos_b [expr {$cos_phiosqrt2 * ($sin_lambda - $cos_lambda)}]
+ set sin_a [expr {sqrt(1.0 - $cos_a * $cos_a)}]
+ set sin_b [expr {sqrt(1.0 - $cos_b * $cos_b)}]
+ set cos_a_cos_b [expr {$cos_a * $cos_b}]
+ set sin_a_sin_b [expr {$sin_a * $sin_b}]
+ set sin2_m [expr {1.0 + $cos_a_cos_b - $sin_a_sin_b}]
+ set sin2_n [expr {1.0 - $cos_a_cos_b - $sin_a_sin_b}]
+ if {$sin2_m < 0.0} {set sin2_m 0.0}
+ set sin_m [expr {sqrt($sin2_m)}]
+ if {$sin2_m > 1.0} { set sin2_m 1.0 }
+ set cos_m [expr {sqrt(1.0 - $sin2_m)}]
+ if {$sin_lambda < 0.0} {
+ set sin_m [expr {-$sin_m}]
+ }
+ if {$sin2_n < 0.0} { set sin2_n 0.0 }
+ set sin_n [expr {sqrt($sin2_n)}]
+ if {$sin2_n > 1.0} { set sin2_n 1.0 }
+ set cos_n [expr {sqrt(1.0 - $sin2_n)}]
+ if {$cos_lambda > 0.0} {
+ set sin_n [expr {-$sin_n}]
+ }
+
+ # Compute elliptic integrals to map the disc to the square
+
+ set x [ellFaux $cos_m $sin_m $halfSqrt2]
+ set y [ellFaux $cos_n $sin_n $halfSqrt2]
+
+ # Reflect the Southern Hemisphere outward
+
+ if {$phi < 0} {
+ if {$lambda < $mthreequarterpi} {
+ set y [expr {$PeirceQuincuncialScale - $y}]
+ } elseif {$lambda < $mquarterpi} {
+ set x [expr {-$PeirceQuincuncialScale - $x}]
+ } elseif {$lambda < $quarterpi} {
+ set y [expr {-$PeirceQuincuncialScale - $y}]
+ } elseif {$lambda < $threequarterpi} {
+ set x [expr {$PeirceQuincuncialScale - $x}]
+ } else {
+ set y [expr {$PeirceQuincuncialScale - $y}]
+ }
+ }
+
+ # Rotate the square by 45 degrees to fit the screen better
+
+ set X [expr {($x - $y) * $halfSqrt2}]
+ set Y [expr {($x + $y) * $halfSqrt2}]
+
+ return [list $X $Y]
+}
+
+# ::mapproj::fromPeirceQuincuncial --
+#
+# Converts Peirce Quincuncial map co-ordinates to latitude and longitude.
+#
+# Parameters:
+# lambda_0 -- Longitude of the center of projection
+# x,y -- normalized x and y co-ordinates of a point on the map
+#
+# Results:
+# Returns a list consisting of the longitude and latitude in degrees.
+
+proc ::mapproj::fromPeirceQuincuncial {lambda_0 x y} {
+ variable halfSqrt2
+ variable radian
+ variable pi
+ variable halfpi
+ variable quarterpi
+ variable PeirceQuincuncialScale
+ variable PeirceQuincuncialLimit
+
+ # Rotate x and y 45 degrees
+
+ set X [expr {($x + $y) * $halfSqrt2}]
+ set Y [expr {($y - $x) * $halfSqrt2}]
+
+ # Reflect Southern Hemisphere into the Northern
+
+ set southern 0
+ if {$X < -$PeirceQuincuncialLimit} {
+ set X [expr {-$PeirceQuincuncialScale - $X}]
+ set southern 1
+ } elseif {$X > $PeirceQuincuncialLimit} {
+ set X [expr {$PeirceQuincuncialScale - $X}]
+ set southern 1
+ } elseif {$Y < -$PeirceQuincuncialLimit} {
+ set Y [expr {-$PeirceQuincuncialScale - $Y}]
+ set southern 1
+ } elseif {$Y > $PeirceQuincuncialLimit} {
+ set Y [expr {$PeirceQuincuncialScale - $Y}]
+ set southern 1
+ }
+
+ # Now we know that latitude will be positive. If X is negative, then
+ # longitude will be negative; reflect the Western Hemisphere into the
+ # Eastern.
+
+ set western 0
+ if {$X < 0.0} {
+ set western 1
+ set X [expr {-$X}]
+ }
+
+ # If Y is positive, the point is in the back hemisphere. Reflect
+ # it to the front.
+
+ set back 0
+ if {$Y > 0.0} {
+ set back 1
+ set Y [expr {-$Y}]
+ }
+
+ # Finally, constrain longitude to be less than pi/4, by reflecting across
+ # the 45 degree meridian.
+
+ set complement 0
+ if {$X > -$Y} {
+ set complement 1
+ set t [expr {-$X}]
+ set X [expr {-$Y}]
+ set Y $t
+ }
+
+ # Compute the elliptic functions to map the plane onto the sphere
+
+ set cnx [cn $X $halfSqrt2]
+ set cny [cn $Y $halfSqrt2]
+
+ # Undo the mapping to latitude and longitude
+
+ set a1 [expr {acos(-$cnx * $cnx)}]
+ set a2 [expr {acos($cny * $cny)}]
+ set b [expr {0.5 * ($a1 + $a2)}]
+ set a [expr {0.5 * ($a1 - $a2)}]
+ set cos_a [expr {cos($a)}]
+ set cos_b [expr {-cos($b)}]
+ set lambda [expr {$quarterpi - atan2($cos_b, $cos_a)}]
+ set phi [expr {acos(hypot($cos_b, $cos_a))}]
+
+ # Undo the reflections that were done above, to get correct latitude
+ # and longitude
+
+ if {$complement} {
+ set lambda [expr {$halfpi - $lambda}]
+ }
+ if {$back} {
+ set lambda [expr {$pi - $lambda}]
+ }
+ if {$western} {
+ set lambda [expr {-$lambda}]
+ }
+ if {$southern} {
+ set phi [expr {-$phi}]
+ }
+
+ # Convert latitude and longitude to degrees
+
+ set lambda [expr {$lambda * $radian + 180. + $lambda_0}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ set phi [expr {$phi * $radian}]
+
+ return [list $lambda $phi]
+}
+
+# ::mapproj::RotateCartesianY
+#
+# Rotates Cartesian co-ordinates about the y axis
+#
+# Parameters:
+# phi - Angle (in degrees) about which to rotate.
+# x,y,z - Cartesian co-ordinates
+#
+# Results:
+# Returns a three-element list giving the rotated co-ordinates.
+
+proc ::mapproj::RotateCartesianY {phi x y z} {
+ variable degree
+ set phi [expr {$degree * $phi}]
+ set cos_phi [expr {cos($phi)}]
+ set sin_phi [expr {sin($phi)}]
+ return [list [expr {$x * $cos_phi - $z * $sin_phi}] \
+ $y \
+ [expr {$z * $cos_phi + $x * $sin_phi}]]
+}
+
+# ::mapproj::ToCartesian --
+#
+# Converts geodetic co-ordinates to Cartesian
+#
+# Parameters:
+# lambda - Longitude of the point to be projected, in degrees
+# phi - Latitude of the point to be projected, in degrees
+#
+# Results:
+# Returns a three-element list, x, y, z where x is the component
+# in the direction of longitude 0, latitude 0, y is the component
+# in the direction of longitude 90 East, latitude 0, and
+# z is the component in the direction of the North Pole
+#
+# Auxiliary procedure used in several projections to convert
+# geodetic coordinates to Cartesian range and bearing.
+
+proc ::mapproj::ToCartesian {lambda phi} {
+ variable degree
+ set lambda [expr {$degree * $lambda}]
+ set phi [expr {$degree * $phi}]
+ set cos_phi [expr cos($phi)]
+ return [list [expr {$cos_phi * cos($lambda)}] \
+ [expr {$cos_phi * sin($lambda)}] \
+ [expr {sin($phi)}]]
+}
+
+# ::mapproj::CartesianToRangeAndBearing
+#
+# Transforms view-relative Cartesian co-ordinates to range and
+# bearing.
+#
+# Parameters:
+# x,y,z - Cartesian co-ordinates relative to center of Earth;
+# +x points to the viewer and +z to the "view-up" direction.
+#
+# Results:
+# Returns a three-element list containing, in order,
+# the cosine (easting) of the bearing, the sine (northing) of the
+# bearing, and the range.
+
+proc ::mapproj::CartesianToRangeAndBearing {x y z} {
+ set c [expr {hypot($z, $y)}]
+ if {$c == 0} {
+ set cos_b 1.0
+ set sin_b 0.0
+ } else {
+ set cos_b [expr {$y / $c}]
+ set sin_b [expr {$z / $c}]
+ }
+ set range [expr {atan2($c, $x)}]
+ return [list $cos_b $sin_b $range]
+}
+
+# ::mapproj::RangeAndBearingToCartesian --
+#
+# Converts range and bearing to Cartesian co-ordinates.
+#
+# Parameters:
+# cos_b, sin_b -- Cosine (easting) and sine (northing) of the bearing
+# range - Range, in Earth radii
+#
+# Results:
+# Returns Cartesian co-ordinates relative to center of Earth.
+# x is toward the station, and z is "view up"
+
+proc ::mapproj::RangeAndBearingToCartesian {cos_b sin_b range} {
+ set c [expr {sin($range)}]
+ set x [expr {cos($range)}]
+ set y [expr {$cos_b * $c}]
+ set z [expr {$sin_b * $c}]
+ return [list $x $y $z]
+}
+
+
+# ::mapproj::CartesianToSpherical --
+#
+# Transforms Cartesian x, y, z to spherical co-ordinates
+#
+# Parameters:
+# x, y, z -- Coordinates of a point on the surface of the Earth,
+# in Earth radii
+#
+# Results:
+# Returns a two-element list comprising longitude and latitude
+# in radians
+
+proc ::mapproj::CartesianToSpherical {x y z} {
+ return [list [expr {atan2($y, $x)}] [expr {atan2($z, hypot($y, $x))}]]
+}
+
+# ::mapproj::toOrthographic --
+#
+# Transforms latitude and longitude to x and y co-ordinates
+# on an orthographic projection. Scale is true only at the
+# point of projection.
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of projection
+# in degrees
+# lambda, phi -- Longitude and latitude of the point to be projected
+# in degrees
+#
+# Results:
+# Returns map x and y co-ordinates, in Earth radii.
+
+proc ::mapproj::toOrthographic {lambda_0 phi_0 lambda phi} {
+ foreach {x y z} [ToCartesian [expr {$lambda-$lambda_0}] $phi] \
+ break
+ foreach {x y z} [RotateCartesianY [expr {-$phi_0}] $x $y $z] \
+ break
+ if {$x < 0} {
+ return {}
+ } else {
+ return [list $y $z]
+ }
+}
+
+# ::mapproj::fromOrthographic --
+#
+# Transforms x and y on an orthographic projection to latitude
+# and longitude.
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of projection
+# in degrees
+# x, y -- Co-ordinates of the projected point, in Earth radii
+#
+# Results:
+# Returns a two element list containing longitude and latitude
+# in degrees.
+
+proc ::mapproj::fromOrthographic {lambda_0 phi_0 x y} {
+ variable radian
+ set r [expr {hypot($x, $y)}]
+ set alpha [expr {asin($r)}]
+ set z [expr {sqrt(1.0 - $r*$r)}]
+ foreach {x y z} [RotateCartesianY $phi_0 $z $x $y] break
+ foreach {lambda phi} [CartesianToSpherical $x $y $z] break
+
+ # Convert latitude and longitude to degrees
+
+ set lambda [expr {$lambda * $radian + 180. + $lambda_0}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ set phi [expr {$phi * $radian}]
+
+ return [list $lambda $phi]
+}
+
+# ::mapproj::toStereographic --
+#
+# Transforms latitude and longitude to x and y co-ordinates
+# on an orthographic projection. Scale is true only at the
+# point of projection.
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of projection
+# in degrees
+# lambda, phi -- Longitude and latitude of the point to be projected
+# in degrees
+#
+# Results:
+# Returns map x and y co-ordinates, in Earth radii.
+
+proc ::mapproj::toStereographic {lambda_0 phi_0 lambda phi} {
+ foreach {x y z} [ToCartesian [expr {$lambda-$lambda_0}] $phi] \
+ break
+ foreach {x y z} [RotateCartesianY [expr {-$phi_0}] $x $y $z] \
+ break
+ if {$x < -0.5} {
+ return {}
+ } else {
+ set y [expr {2. * $y / (1. + $x)}]
+ set z [expr {2. * $z / (1. + $x)}]
+ return [list $y $z]
+ }
+}
+
+# ::mapproj::fromStereographic --
+#
+# Transforms x and y on an orthographic projection to latitude
+# and longitude.
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of projection
+# in degrees
+# x, y -- Co-ordinates of the projected point, in Earth radii
+#
+# Results:
+# Returns a two element list containing longitude and latitude
+# in degrees.
+
+proc ::mapproj::fromStereographic {lambda_0 phi_0 x y} {
+ variable radian
+ variable halfpi
+ set denom [expr {4.0 + $x*$x + $y*$y}]
+ foreach {x y z} [list \
+ [expr {(4.0 - $x*$x - $y*$y) / $denom}] \
+ [expr {4. * $x / $denom}] \
+ [expr {4. * $y / $denom}]] break
+
+ foreach {x y z} [RotateCartesianY $phi_0 $x $y $z] break
+ foreach {lambda phi} [CartesianToSpherical $x $y $z] break
+
+ # Convert latitude and longitude to degrees
+
+ set lambda [expr {$lambda * $radian + 180. + $lambda_0}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ set phi [expr {$phi * $radian}]
+
+ return [list $lambda $phi]
+}
+
+# ::mapproj::toGnomonic --
+#
+# Transforms latitude and longitude to x and y co-ordinates
+# on an orthographic projection. Scale is true only at the
+# point of projection.
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of projection
+# in degrees
+# lambda, phi -- Longitude and latitude of the point to be projected
+# in degrees
+#
+# Results:
+# Returns map x and y co-ordinates, in Earth radii.
+
+proc ::mapproj::toGnomonic {lambda_0 phi_0 lambda phi} {
+ foreach {x y z} [ToCartesian [expr {$lambda-$lambda_0}] $phi] \
+ break
+ foreach {x y z} [RotateCartesianY [expr {-$phi_0}] $x $y $z] \
+ break
+ if {$x < 0.01} {
+ return {}
+ } else {
+ set y [expr {$y / $x}]
+ set z [expr {$z / $x}]
+ return [list $y $z]
+ }
+}
+
+# ::mapproj::fromGnomonic --
+#
+# Transforms x and y on an orthographic projection to latitude
+# and longitude.
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of projection
+# in degrees
+# x, y -- Co-ordinates of the projected point, in Earth radii
+#
+# Results:
+# Returns a two element list containing longitude and latitude
+# in degrees.
+
+proc ::mapproj::fromGnomonic {lambda_0 phi_0 x y} {
+ variable radian
+ variable halfpi
+ set denom [expr {hypot(1.0, hypot($x, $y))}]
+ foreach {x y z} [list \
+ [expr {1.0 / $denom}] \
+ [expr {$x / $denom}] \
+ [expr {$y / $denom}]] break
+
+ foreach {x y z} [RotateCartesianY $phi_0 $x $y $z] break
+ foreach {lambda phi} [CartesianToSpherical $x $y $z] break
+
+ # Convert latitude and longitude to degrees
+
+ set lambda [expr {$lambda * $radian + 180. + $lambda_0}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ set phi [expr {$phi * $radian}]
+
+ return [list $lambda $phi]
+}
+
+# ::mapproj::toAzimuthalEquidistant --
+#
+# Transforms latitude and longitude to x and y co-ordinates
+# on an orthographic projection. Scale is true only at the
+# point of projection.
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of projection
+# in degrees
+# lambda, phi -- Longitude and latitude of the point to be projected
+# in degrees
+#
+# Results:
+# Returns map x and y co-ordinates, in Earth radii.
+
+proc ::mapproj::toAzimuthalEquidistant {lambda_0 phi_0 lambda phi} {
+ foreach {x y z} [ToCartesian [expr {$lambda-$lambda_0}] $phi] \
+ break
+ foreach {x y z} [RotateCartesianY [expr {-$phi_0}] $x $y $z] \
+ break
+ foreach {cs sn range} [CartesianToRangeAndBearing $x $y $z] break
+ return [list [expr {$cs * $range}] [expr {$sn * $range}]]
+}
+
+# ::mapproj::fromAzimuthalEquidistant --
+#
+# Transforms x and y on an orthographic projection to latitude
+# and longitude.
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of projection
+# in degrees
+# x, y -- Co-ordinates of the projected point, in Earth radii
+#
+# Results:
+# Returns a two element list containing longitude and latitude
+# in degrees.
+
+proc ::mapproj::fromAzimuthalEquidistant {lambda_0 phi_0 x y} {
+ variable radian
+ variable halfpi
+
+ set range [expr {hypot($y, $x)}]
+ set cos_b [expr {$x / $range}]
+ set sin_b [expr {$y / $range}]
+ foreach {x y z} [RangeAndBearingToCartesian $cos_b $sin_b $range] break
+ foreach {x y z} [RotateCartesianY $phi_0 $x $y $z] break
+ foreach {lambda phi} [CartesianToSpherical $x $y $z] break
+
+ # Convert latitude and longitude to degrees
+
+ set lambda [expr {$lambda * $radian + 180. + $lambda_0}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ set phi [expr {$phi * $radian}]
+
+ return [list $lambda $phi]
+}
+
+# ::mapproj::toLambertAzimuthalEqualArea --
+#
+# Transforms latitude and longitude to x and y co-ordinates
+# on an orthographic projection. Scale is true only at the
+# point of projection.
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of projection
+# in degrees
+# lambda, phi -- Longitude and latitude of the point to be projected
+# in degrees
+#
+# Results:
+# Returns map x and y co-ordinates, in Earth radii.
+
+proc ::mapproj::toLambertAzimuthalEqualArea {lambda_0 phi_0 lambda phi} {
+ foreach {x y z} [ToCartesian [expr {$lambda-$lambda_0}] $phi] \
+ break
+ foreach {x y z} [RotateCartesianY [expr {-$phi_0}] $x $y $z] \
+ break
+ foreach {cs sn range} [CartesianToRangeAndBearing $x $y $z] break
+ set range [expr {2.0 * sin(0.5 * $range)}]
+ return [list [expr {$cs * $range}] [expr {$sn * $range}]]
+}
+
+# ::mapproj::fromLambertAzimuthalEqualArea --
+#
+# Transforms x and y on an orthographic projection to latitude
+# and longitude.
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of projection
+# in degrees
+# x, y -- Co-ordinates of the projected point, in Earth radii
+#
+# Results:
+# Returns a two element list containing longitude and latitude
+# in degrees.
+
+proc ::mapproj::fromLambertAzimuthalEqualArea {lambda_0 phi_0 x y} {
+ variable radian
+ variable halfpi
+
+ set range [expr {hypot($y, $x)}]
+ set cos_b [expr {$x / $range}]
+ set sin_b [expr {$y / $range}]
+ set range [expr {2.0 * asin(0.5 * $range)}]
+ foreach {x y z} [RangeAndBearingToCartesian $cos_b $sin_b $range] break
+ foreach {x y z} [RotateCartesianY $phi_0 $x $y $z] break
+ foreach {lambda phi} [CartesianToSpherical $x $y $z] break
+
+ # Convert latitude and longitude to degrees
+
+ set lambda [expr {$lambda * $radian + 180. + $lambda_0}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ set phi [expr {$phi * $radian}]
+
+ return [list $lambda $phi]
+}
+
+# ::mapproj::toHammer --
+#
+# Transforms latitude and longitude to x and y co-ordinates
+# on an orthographic projection. Scale is true only at the
+# point of projection.
+#
+# Parameters:
+# lambda_0-- Longitude of the center of projection
+# in degrees
+# lambda, phi -- Longitude and latitude of the point to be projected
+# in degrees
+#
+# Results:
+# Returns map x and y co-ordinates, in Earth radii.
+
+proc ::mapproj::toHammer {lambda_0 lambda phi} {
+ set lambda [expr {$lambda - $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.0}]
+ foreach {x y z} [ToCartesian [expr {$lambda/2.}] $phi] \
+ break
+ foreach {cs sn range} [CartesianToRangeAndBearing $x $y $z] break
+ set range [expr {2.0 * sin(0.5 * $range)}]
+ return [list [expr {2.0 * $cs * $range}] [expr {$sn * $range}]]
+}
+
+# ::mapproj::fromHammer --
+#
+# Transforms x and y on an orthographic projection to latitude
+# and longitude.
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of projection
+# in degrees
+# x, y -- Co-ordinates of the projected point, in Earth radii
+#
+# Results:
+# Returns a two element list containing longitude and latitude
+# in degrees.
+
+proc ::mapproj::fromHammer {lambda_0 x y} {
+ variable radian
+ variable halfpi
+
+ set x [expr {0.5 * $x}]
+ set range [expr {hypot($y, $x)}]
+ set cos_b [expr {$x / $range}]
+ set sin_b [expr {$y / $range}]
+ set range [expr {2.0 * asin(0.5 * $range)}]
+ foreach {x y z} [RangeAndBearingToCartesian $cos_b $sin_b $range] break
+ foreach {lambda phi} [CartesianToSpherical $x $y $z] break
+
+ # Convert latitude and longitude to degrees
+
+ set lambda [expr {2.0 * $lambda * $radian + 180. + $lambda_0}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ set phi [expr {$phi * $radian}]
+
+ return [list $lambda $phi]
+}
+
+# ::mapproj::toConicEquidistant
+#
+# Converts latitude and longitude to map co-ordinates on a
+# conic equidistant projection.
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of the sheet.
+# phi_1, phi_2 -- Latitudes of the two standard parallels at which scale
+# is true
+# lambda, phi -- Longitude and latitude of the point to be projected
+#
+# Results:
+# Returns a list of map x and y measured in Earth radii.
+
+proc ::mapproj::toConicEquidistant {lambda_0 phi_0 phi_1 phi_2 lambda phi} {
+ variable degree
+ set phi_0 [expr {$phi_0 * $degree}]
+ set phi_1 [expr {$phi_1 * $degree}]
+ set phi_2 [expr {$phi_2 * $degree}]
+ set lambda [expr {$lambda - $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {($lambda - 180.0) * $degree}]
+ set phi [expr {$phi * $degree}]
+ set cos_phi_1 [expr {cos($phi_1)}]
+ set n [expr {($cos_phi_1 - cos($phi_2)) / ($phi_2 - $phi_1)}]
+ set G [expr {$cos_phi_1 / $n + $phi_1}]
+ set rho_0 [expr {$G - $phi_0}]
+ set theta [expr {$n * $lambda}]
+ set rho [expr {$G - $phi}]
+ set x [expr {$rho * sin($theta)}]
+ set y [expr {$rho_0 - $rho * cos($theta)}]
+ return [list $x $y]
+}
+
+# ::mapproj::fromConicEquidistant --
+#
+# Unprojects map x and y in a conic equidistant projection to
+# latitude and longitude
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of the sheet.
+# phi_1, phi_2 -- Latitudes of the two standard parallels at which scale
+# is true
+# x, y -- Map co-ordinates in Earth radii
+#
+# Results:
+# Returns a list of longitude and latitude in degrees.
+
+proc ::mapproj::fromConicEquidistant {lambda_0 phi_0 phi_1 phi_2 x y} {
+ variable degree
+ variable radian
+ set phi_0 [expr {$phi_0 * $degree}]
+ set phi_1 [expr {$phi_1 * $degree}]
+ set phi_2 [expr {$phi_2 * $degree}]
+ set cos_phi_1 [expr {cos($phi_1)}]
+ set n [expr {($cos_phi_1 - cos($phi_2)) / ($phi_2 - $phi_1)}]
+ set G [expr {$cos_phi_1 / $n + $phi_1}]
+ set rho_0 [expr {$G - $phi_0}]
+ set rho_0my [expr {$rho_0 - $y}]
+ set theta [expr {atan2($x, $rho_0my)}]
+ set rho [expr {sqrt($x*$x + $rho_0my * $rho_0my)}]
+ if {$n < 0.0} {set rho [expr {-$rho}]}
+ set phi [expr {($G - $rho) * $radian}]
+ set lambda [expr {($theta / $n * $radian) + $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ return [list $lambda $phi]
+}
+
+# ::mapproj::toAlbersEqualAreaConic
+#
+# Converts latitude and longitude to map co-ordinates on a
+# conic equal-area projection.
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of the sheet.
+# phi_1, phi_2 -- Latitudes of the two standard parallels at which scale
+# is true
+# lambda, phi -- Longitude and latitude of the point to be projected
+#
+# Results:
+# Returns a list of map x and y measured in Earth radii.
+
+proc ::mapproj::toAlbersEqualAreaConic {lambda_0 phi_0 phi_1 phi_2 lambda phi} {
+ variable degree
+ set phi_0 [expr {$phi_0 * $degree}]
+ set phi_1 [expr {$phi_1 * $degree}]
+ set phi_2 [expr {$phi_2 * $degree}]
+ set lambda [expr {$lambda - $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {($lambda - 180.0) * $degree}]
+ set phi [expr {$phi * $degree}]
+ set cos_phi_1 [expr {cos($phi_1)}]
+ set sin_phi_1 [expr {sin($phi_1)}]
+ set n [expr {0.5 * ($sin_phi_1 + sin($phi_2))}]
+ set theta [expr {$n * $lambda}]
+ set C [expr {$cos_phi_1 * $cos_phi_1 + 2.0 * $n * $sin_phi_1}]
+ set rho [expr {sqrt($C - 2.0 * $n * sin($phi)) / $n}]
+ set rho_0 [expr {sqrt($C - 2.0 * $n * sin($phi_0)) / $n}]
+ set x [expr {$rho * sin($theta)}]
+ set y [expr {$rho_0 - $rho * cos($theta)}]
+ return [list $x $y]
+}
+
+# ::mapproj::fromAlbersEqualAreaConic --
+#
+# Unprojects map x and y in a conic equal-area projection to
+# latitude and longitude
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of the sheet.
+# phi_1, phi_2 -- Latitudes of the two standard parallels at which scale
+# is true
+# x, y -- Map co-ordinates in Earth radii
+#
+# Results:
+# Returns a list of longitude and latitude in degrees.
+
+proc ::mapproj::fromAlbersEqualAreaConic {lambda_0 phi_0 phi_1 phi_2 x y} {
+ variable degree
+ variable radian
+ variable twopi
+ set phi_0 [expr {$phi_0 * $degree}]
+ set phi_1 [expr {$phi_1 * $degree}]
+ set phi_2 [expr {$phi_2 * $degree}]
+ set cos_phi_1 [expr {cos($phi_1)}]
+ set sin_phi_1 [expr {sin($phi_1)}]
+ set n [expr {0.5 * ($sin_phi_1 + sin($phi_2))}]
+ set C [expr {$cos_phi_1 * $cos_phi_1 + 2.0 * $n * $sin_phi_1}]
+ set rho_0 [expr {sqrt($C - 2.0 * $n * sin($phi_0)) / $n}]
+ set theta [expr {atan2($x, $rho_0 - $y)}]
+ set rho [expr {hypot($x, $rho_0 - $y)}]
+ set phi [expr {$radian * asin(($C - $rho*$rho*$n*$n) / (2.0 * $n))}]
+ set lambda [expr {($theta / $n * $radian) + $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ return [list $lambda $phi]
+}
+
+# ::mapproj::toLambertConformalConic
+#
+# Converts latitude and longitude to map co-ordinates on a
+# conformal conic projection.
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of the sheet.
+# phi_1, phi_2 -- Latitudes of the two standard parallels at which scale
+# is true
+# lambda, phi -- Longitude and latitude of the point to be projected
+#
+# Results:
+# Returns a list of map x and y measured in Earth radii.
+
+proc ::mapproj::toLambertConformalConic {lambda_0 phi_0 phi_1 phi_2 lambda phi} {
+ variable degree
+ variable quarterpi
+ set phi_0 [expr {$phi_0 * $degree}]
+ set phi_1 [expr {$phi_1 * $degree}]
+ set phi_2 [expr {$phi_2 * $degree}]
+ set lambda [expr {$lambda - $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {($lambda - 180.0) * $degree}]
+ set phi [expr {$phi * $degree}]
+ set cos_phi_1 [expr {cos($phi_1)}]
+ set sin_phi_1 [expr {sin($phi_1)}]
+ set tan1 [expr {tan($quarterpi + 0.5 * $phi_1)}]
+ set n [expr {log($cos_phi_1 / cos($phi_2))
+ / log(tan($quarterpi + 0.5 * $phi_2) / $tan1)}]
+ set F [expr {$cos_phi_1 * pow($tan1, $n) / $n}]
+ set rho [expr {$F * pow(tan($quarterpi + 0.5 * $phi), -$n)}]
+ set rho_0 [expr {$F * pow(tan($quarterpi + 0.5 * $phi_0), -$n)}]
+ set x [expr {$rho * sin($n * $lambda)}]
+ set y [expr {$rho_0 - $rho * cos($n * $lambda)}]
+ return [list $x $y]
+}
+
+# ::mapproj::fromLambertConformalConic --
+#
+# Unprojects map x and y in a conformal conic projection to
+# latitude and longitude
+#
+# Parameters:
+# lambda_0, phi_0 -- Longitude and latitude of the center of the sheet.
+# phi_1, phi_2 -- Latitudes of the two standard parallels at which scale
+# is true
+# x, y -- Map co-ordinates in Earth radii
+#
+# Results:
+# Returns a list of longitude and latitude in degrees.
+
+proc ::mapproj::fromLambertConformalConic {lambda_0 phi_0 phi_1 phi_2 x y} {
+ variable degree
+ variable radian
+ variable quarterpi
+ set phi_0 [expr {$phi_0 * $degree}]
+ set phi_1 [expr {$phi_1 * $degree}]
+ set phi_2 [expr {$phi_2 * $degree}]
+ set cos_phi_1 [expr {cos($phi_1)}]
+ set sin_phi_1 [expr {sin($phi_1)}]
+ set tan1 [expr {tan($quarterpi + 0.5 * $phi_1)}]
+ set n [expr {log($cos_phi_1 / cos($phi_2))
+ / log(tan($quarterpi + 0.5 * $phi_2) / $tan1)}]
+ set F [expr {$cos_phi_1 * pow($tan1, $n) / $n}]
+ set rho_0 [expr {$F * pow(tan($quarterpi + 0.5 * $phi_0), -$n)}]
+ set y [expr {$rho_0 - $y}]
+ set rho [expr {sqrt($x*$x + $y*$y)}]
+ if {$n < 0} { set rho [expr {-$rho}] }
+ set theta [expr {atan2($x, $y)}]
+ set phi [expr {$radian * 2 * atan(pow($F / $rho, 1.0 / $n)) - 90.}]
+ set lambda [expr {($theta / $n * $radian) + $lambda_0 + 180.}]
+ if {$lambda < 0.0 || $lambda > 360.0} {
+ set lambda [expr {$lambda - 360. * floor($lambda / 360.)}]
+ }
+ set lambda [expr {$lambda - 180.}]
+ return [list $lambda $phi]
+}
+
+# Define commonly used cylindrical equal-area projections
+
+proc ::mapproj::toLambertCylindricalEqualArea {lambda_0 phi_0 lambda phi} {
+ toCylindricalEqualArea 0.0 $lambda_0 $phi_0 $lambda $phi
+}
+proc ::mapproj::fromLambertCylindricalEqualArea {lambda_0 phi_0 x y} {
+ fromCylindricalEqualArea 0.0 $lambda_0 $phi_0 $x $y
+}
+proc ::mapproj::toBehrmann {lambda_0 phi_0 lambda phi} {
+ toCylindricalEqualArea 30.0 $lambda_0 $phi_0 $lambda $phi
+}
+proc ::mapproj::fromBehrmann {lambda_0 phi_0 x y} {
+ fromCylindricalEqualArea 30.0 $lambda_0 $phi_0 $x $y
+}
+proc ::mapproj::toTrystanEdwards {lambda_0 phi_0 lambda phi} {
+ toCylindricalEqualArea 37.4 $lambda_0 $phi_0 $lambda $phi
+}
+proc ::mapproj::fromTrystanEdwards {lambda_0 phi_0 x y} {
+ fromCylindricalEqualArea 37.4 $lambda_0 $phi_0 $x $y
+}
+proc ::mapproj::toHoboDyer {lambda_0 phi_0 lambda phi} {
+ toCylindricalEqualArea 37.5 $lambda_0 $phi_0 $lambda $phi
+}
+proc ::mapproj::fromHoboDyer {lambda_0 phi_0 x y} {
+ fromCylindricalEqualArea 37.5 $lambda_0 $phi_0 $x $y
+}
+proc ::mapproj::toGallPeters {lambda_0 phi_0 lambda phi} {
+ toCylindricalEqualArea 45.0 $lambda_0 $phi_0 $lambda $phi
+}
+proc ::mapproj::fromGallPeters {lambda_0 phi_0 x y} {
+ fromCylindricalEqualArea 45.0 $lambda_0 $phi_0 $x $y
+}
+proc ::mapproj::toBalthasart {lambda_0 phi_0 lambda phi} {
+ toCylindricalEqualArea 50.0 $lambda_0 $phi_0 $lambda $phi
+}
+proc ::mapproj::fromBalthasart {lambda_0 phi_0 x y} {
+ fromCylindricalEqualArea 50.0 $lambda_0 $phi_0 $x $y
+}
diff --git a/tcllib/modules/mapproj/pkgIndex.tcl b/tcllib/modules/mapproj/pkgIndex.tcl
new file mode 100755
index 0000000..c488e8f
--- /dev/null
+++ b/tcllib/modules/mapproj/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded mapproj 1.0 [list source [file join $dir mapproj.tcl]]
diff --git a/tcllib/modules/markdown/markdown.tcl b/tcllib/modules/markdown/markdown.tcl
new file mode 100644
index 0000000..3262855
--- /dev/null
+++ b/tcllib/modules/markdown/markdown.tcl
@@ -0,0 +1,755 @@
+#
+# The MIT License (MIT)
+#
+# Copyright (c) 2014 Caius Project
+#
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to deal
+# in the Software without restriction, including without limitation the rights
+# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+# copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in
+# all copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+# THE SOFTWARE.
+#
+
+package require textutil
+
+## \file
+# \brief Functions for converting markdown to HTML.
+
+##
+# \brief Functions for converting markdown to HTML.
+#
+namespace eval Markdown {
+
+ namespace export convert
+
+ ##
+ #
+ # Converts text written in markdown to HTML.
+ #
+ # @param markdown currently takes as a single argument the text in markdown
+ #
+ # The output of this function is only a fragment, not a complete HTML
+ # document. The format of the output is generic XHTML.
+ #
+ proc convert {markdown} {
+ set markdown [regsub {\r\n?} $markdown {\n}]
+ set markdown [::textutil::untabify2 $markdown 4]
+ set markdown [string trimright $markdown]
+
+ # COLLECT REFERENCES
+ array unset ::Markdown::_references
+ array set ::Markdown::_references [collect_references markdown]
+
+ # PROCESS
+ return [apply_templates markdown]
+ }
+
+ ## \private
+ proc collect_references {markdown_var} {
+ upvar $markdown_var markdown
+
+ set lines [split $markdown \n]
+ set no_lines [llength $lines]
+ set index 0
+
+ array set references {}
+
+ while {$index < $no_lines} {
+ set line [lindex $lines $index]
+
+ if {[regexp \
+ {^[ ]{0,3}\[((?:[^\]]|\[[^\]]*?\])+)\]:\s*(\S+)(?:\s+(([\"\']).*\4|\(.*\))\s*$)?} \
+ $line match ref link title]} \
+ {
+ set title [string trim [string range $title 1 end-1]]
+ if {$title eq {}} {
+ set next_line [lindex $lines [expr $index + 1]]
+
+ if {[regexp \
+ {^(?:\s+(?:([\"\']).*\1|\(.*\))\s*$)} \
+ $next_line]} \
+ {
+ set title [string range [string trim $next_line] 1 end-1]
+ incr index
+ }
+ }
+ set ref [string tolower $ref]
+ set link [string trim $link {<>}]
+ set references($ref) [list $link $title]
+ }
+
+ incr index
+ }
+
+ return [array get references]
+ }
+
+ ## \private
+ proc apply_templates {markdown_var {parent {}}} {
+ upvar $markdown_var markdown
+
+ set lines [split $markdown \n]
+ set no_lines [llength $lines]
+ set index 0
+ set result {}
+
+ set ul_match {^[ ]{0,3}(?:\*(?!\s*\*\s*\*\s*$)|-(?!\s*-\s*-\s*$)|\+) }
+ set ol_match {^[ ]{0,3}\d+\. }
+
+ # PROCESS MARKDOWN
+ while {$index < $no_lines} {
+ set line [lindex $lines $index]
+
+ switch -regexp $line {
+ {^\s*$} {
+ # EMPTY LINES
+ if {![regexp {^\s*$} [lindex $lines [expr $index - 1]]]} {
+ append result "\n\n"
+ }
+ incr index
+ }
+ {^[ ]{0,3}\[(?:[^\]]|\[[^\]]*?\])+\]:\s*\S+(?:\s+(?:([\"\']).*\1|\(.*\))\s*$)?} {
+ # SKIP REFERENCES
+ set next_line [lindex $lines [expr $index + 1]]
+
+ if {[regexp \
+ {^(?:\s+(?:([\"\']).*\1|\(.*\))\s*$)} \
+ $next_line]} \
+ {
+ incr index
+ }
+
+ incr index
+ }
+ {^[ ]{0,3}-[ ]*-[ ]*-[- ]*$} -
+ {^[ ]{0,3}_[ ]*_[ ]*_[_ ]*$} -
+ {^[ ]{0,3}\*[ ]*\*[ ]*\*[\* ]*$} {
+ # HORIZONTAL RULES
+ append result "<hr/>"
+ incr index
+ }
+ {^[ ]{0,3}#{1,6}} {
+ # ATX STYLE HEADINGS
+ set h_level 0
+ set h_result {}
+
+ while {$index < $no_lines && ![is_empty_line $line]} {
+ incr index
+
+ if {!$h_level} {
+ regexp {^\s*#+} $line m
+ set h_level [string length [string trim $m]]
+ }
+
+ lappend h_result $line
+
+ set line [lindex $lines $index]
+ }
+
+ set h_result [\
+ parse_inline [\
+ regsub -all {^\s*#+\s*|\s*#+\s*$} [join $h_result \n] {} \
+ ]\
+ ]
+
+ append result "<h$h_level>$h_result</h$h_level>"
+ }
+ {^[ ]{0,3}\>} {
+ # BLOCK QUOTES
+ set bq_result {}
+
+ while {$index < $no_lines} {
+ incr index
+
+ lappend bq_result [regsub {^[ ]{0,3}\>[ ]?} $line {}]
+
+ if {[is_empty_line [lindex $lines $index]]} {
+ set eoq 0
+
+ for {set peek $index} {$peek < $no_lines} {incr peek} {
+ set line [lindex $lines $peek]
+
+ if {![is_empty_line $line]} {
+ if {![regexp {^[ ]{0,3}\>} $line]} {
+ set eoq 1
+ }
+ break
+ }
+ }
+
+ if {$eoq} { break }
+ }
+
+ set line [lindex $lines $index]
+ }
+ set bq_result [string trim [join $bq_result \n]]
+
+ append result <blockquote>\n \
+ [apply_templates bq_result] \
+ \n</blockquote>
+ }
+ {^\s{4,}\S+} {
+ # CODE BLOCKS
+ set code_result {}
+
+ while {$index < $no_lines} {
+ incr index
+
+ lappend code_result [html_escape [\
+ regsub {^ } $line {}]\
+ ]
+
+ set eoc 0
+ for {set peek $index} {$peek < $no_lines} {incr peek} {
+ set line [lindex $lines $peek]
+
+ if {![is_empty_line $line]} {
+ if {![regexp {^\s{4,}} $line]} {
+ set eoc 1
+ }
+ break
+ }
+ }
+
+ if {$eoc} { break }
+
+ set line [lindex $lines $index]
+ }
+ set code_result [join $code_result \n]
+
+ append result <pre><code> $code_result \n </code></pre>
+ }
+ {^(?:(?:`{3,})|(?:~{3,}))(?:\{?\S+\}?)?\s*$} {
+ # FENCED CODE BLOCKS
+ set code_result {}
+
+ if {[string index $line 0] eq {`}} {
+ set end_match {^`{3,}\s*$}
+ } else {
+ set end_match {^~{3,}\s*$}
+ }
+
+ while {$index < $no_lines} {
+ incr index
+
+ set line [lindex $lines $index]
+
+ if {[regexp $end_match $line]} {
+ incr index
+ break
+ }
+
+ lappend code_result [html_escape $line]
+ }
+ set code_result [join $code_result \n]
+
+ append result <pre><code> $code_result </code></pre>
+ }
+ {^[ ]{0,3}(?:\*|-|\+) |^[ ]{0,3}\d+\. } {
+ # LISTS
+ set list_result {}
+
+ # continue matching same list type
+ if {[regexp $ol_match $line]} {
+ set list_type ol
+ set list_match $ol_match
+ } else {
+ set list_type ul
+ set list_match $ul_match
+ }
+
+ set last_line AAA
+
+ while {$index < $no_lines} \
+ {
+ if {![regexp $list_match [lindex $lines $index]]} {
+ break
+ }
+
+ set item_result {}
+ set in_p 1
+ set p_count 1
+
+ if {[is_empty_line $last_line]} {
+ incr p_count
+ }
+
+ set last_line $line
+ set line [regsub "$list_match\\s*" $line {}]
+
+ # prevent recursion on same line
+ set line [regsub {\A(\d+)\.(\s+)} $line {\1\\.\2}]
+ set line [regsub {\A(\*|\+|-)(\s+)} $line {\\\1\2}]
+
+ lappend item_result $line
+
+ for {set peek [expr $index + 1]} {$peek < $no_lines} {incr peek} {
+ set line [lindex $lines $peek]
+
+ if {[is_empty_line $line]} {
+ set in_p 0
+ }\
+ elseif {[regexp {^ } $line]} {
+ if {!$in_p} {
+ incr p_count
+ }
+ set in_p 1
+ }\
+ elseif {[regexp $list_match $line]} {
+ if {!$in_p} {
+ incr p_count
+ }
+ break
+ }\
+ elseif {!$in_p} {
+ break
+ }
+
+ set last_line $line
+ lappend item_result [regsub {^ } $line {}]
+ }
+
+ set item_result [join $item_result \n]
+
+ if {$p_count > 1} {
+ set item_result [apply_templates item_result li]
+ } else {
+ if {[regexp -lineanchor \
+ {(\A.*?)((?:^[ ]{0,3}(?:\*|-|\+) |^[ ]{0,3}\d+\. ).*\Z)} \
+ $item_result \
+ match para rest]} \
+ {
+ set item_result [parse_inline $para]
+ append item_result [apply_templates rest]
+ } else {
+ set item_result [parse_inline $item_result]
+ }
+ }
+
+ lappend list_result "<li>$item_result</li>"
+ set index $peek
+ }
+
+ append result <$list_type>\n \
+ [join $list_result \n] \
+ </$list_type>\n\n
+ }
+ {^<(?:p|div|h[1-6]|blockquote|pre|table|dl|ol|ul|script|noscript|form|fieldset|iframe|math|ins|del)} {
+ # HTML BLOCKS
+ set re_htmltag {<(/?)(\w+)(?:\s+\w+=(?:\"[^\"]+\"|'[^']+'))*\s*>}
+ set buffer {}
+
+ while {$index < $no_lines} \
+ {
+ while {$index < $no_lines} \
+ {
+ incr index
+
+ append buffer $line \n
+
+ if {[is_empty_line $line]} {
+ break
+ }
+
+ set line [lindex $lines $index]
+ }
+
+ set tags [regexp -inline -all $re_htmltag $buffer]
+ set stack_count 0
+
+ foreach {match type name} $tags {
+ if {$type eq {}} {
+ incr stack_count +1
+ } else {
+ incr stack_count -1
+ }
+ }
+
+ if {$stack_count == 0} { break }
+ }
+
+ append result $buffer
+ }
+ {(?:^\s{0,3}|[^\\]+)\|} {
+ # SIMPLE TABLES
+ set cell_align {}
+ set row_count 0
+
+ while {$index < $no_lines} \
+ {
+ # insert a space between || to handle empty cells
+ set row_cols [regexp -inline -all {(?:[^|]|\\\|)+} \
+ [regsub -all {\|(?=\|)} [string trim $line] {| }] \
+ ]
+
+ if {$row_count == 0} \
+ {
+ set sep_cols [lindex $lines [expr $index + 1]]
+
+ # check if we have a separator row
+ if {[regexp {^\s{0,3}\|?(?:\s*:?-+:?(?:\s*$|\s*\|))+} $sep_cols]} \
+ {
+ set sep_cols [regexp -inline -all {(?:[^|]|\\\|)+} \
+ [string trim $sep_cols]]
+
+ foreach {cell_data} $sep_cols \
+ {
+ switch -regexp $cell_data {
+ {:-*:} {
+ lappend cell_align center
+ }
+ {:-+} {
+ lappend cell_align left
+ }
+ {-+:} {
+ lappend cell_align right
+ }
+ default {
+ lappend cell_align {}
+ }
+ }
+ }
+
+ incr index
+ }
+
+ append result "<table class=\"table\">\n"
+ append result "<thead>\n"
+ append result " <tr>\n"
+
+ if {$cell_align ne {}} {
+ set num_cols [llength $cell_align]
+ } else {
+ set num_cols [llength $row_cols]
+ }
+
+ for {set i 0} {$i < $num_cols} {incr i} \
+ {
+ if {[set align [lindex $cell_align $i]] ne {}} {
+ append result " <th style=\"text-align: $align\">"
+ } else {
+ append result " <th>"
+ }
+
+ append result [parse_inline [string trim \
+ [lindex $row_cols $i]]] </th> "\n"
+ }
+
+ append result " </tr>\n"
+ append result "</thead>\n"
+ } else {
+ if {$row_count == 1} {
+ append result "<tbody>\n"
+ }
+
+ append result " <tr>\n"
+
+ if {$cell_align ne {}} {
+ set num_cols [llength $cell_align]
+ } else {
+ set num_cols [llength $row_cols]
+ }
+
+ for {set i 0} {$i < $num_cols} {incr i} \
+ {
+ if {[set align [lindex $cell_align $i]] ne {}} {
+ append result " <td style=\"text-align: $align\">"
+ } else {
+ append result " <td>"
+ }
+
+ append result [parse_inline [string trim \
+ [lindex $row_cols $i]]] </td> "\n"
+ }
+
+ append result " </tr>\n"
+ }
+
+ incr row_count
+
+ set line [lindex $lines [incr index]]
+
+ if {![regexp {(?:^\s{0,3}|[^\\]+)\|} $line]} {
+ switch $row_count {
+ 1 {
+ append result "</table>\n"
+ }
+ default {
+ append result "</tbody>\n"
+ append result "</table>\n"
+ }
+ }
+
+ break
+ }
+ }
+ }
+ default {
+ # PARAGRAPHS AND SETTEXT STYLE HEADERS
+ set p_type p
+ set p_result {}
+
+ while {($index < $no_lines) && ![is_empty_line $line]} \
+ {
+ incr index
+
+ switch -regexp $line {
+ {^[ ]{0,3}=+$} {
+ set p_type h1
+ break
+ }
+ {^[ ]{0,3}-+$} {
+ set p_type h2
+ break
+ }
+ {^[ ]{0,3}(?:\*|-|\+) |^[ ]{0,3}\d+\. } {
+ if {$parent eq {li}} {
+ incr index -1
+ break
+ } else {
+ lappend p_result $line
+ }
+ }
+ {^[ ]{0,3}-[ ]*-[ ]*-[- ]*$} -
+ {^[ ]{0,3}_[ ]*_[ ]*_[_ ]*$} -
+ {^[ ]{0,3}\*[ ]*\*[ ]*\*[\* ]*$} -
+ {^[ ]{0,3}#{1,6}} \
+ {
+ incr index -1
+ break
+ }
+ default {
+ lappend p_result $line
+ }
+ }
+
+ set line [lindex $lines $index]
+ }
+
+ set p_result [\
+ parse_inline [\
+ string trim [join $p_result \n]\
+ ]\
+ ]
+
+ if {[is_empty_line [regsub -all {<!--.*?-->} $p_result {}]]} {
+ # Do not make a new paragraph for just comments.
+ append result $p_result
+ } else {
+ append result "<$p_type>$p_result</$p_type>"
+ }
+ }
+ }
+ }
+
+ return $result
+ }
+
+ ## \private
+ proc parse_inline {text} {
+ set text [regsub -all -lineanchor {[ ]{2,}$} $text <br/>]
+
+ set index 0
+ set result {}
+
+ set re_backticks {\A`+}
+ set re_whitespace {\s}
+ set re_inlinelink {\A\!?\[((?:[^\]]|\[[^\]]*?\])+)\]\s*\(\s*((?:[^\s\)]+|\([^\s\)]+\))+)?(\s+([\"'])(.*)?\4)?\s*\)}
+ set re_reflink {\A\!?\[((?:[^\]]|\[[^\]]*?\])+)\](?:\s*\[((?:[^\]]|\[[^\]]*?\])*)\])?}
+ set re_htmltag {\A</?\w+\s*>|\A<\w+(?:\s+\w+=(?:\"[^\"]+\"|\'[^\']+\'))*\s*/?>}
+ set re_autolink {\A<(?:(\S+@\S+)|(\S+://\S+))>}
+ set re_comment {\A<!--.*?-->}
+ set re_entity {\A\&\S+;}
+
+ while {[set chr [string index $text $index]] ne {}} {
+ switch $chr {
+ "\\" {
+ # ESCAPES
+ set next_chr [string index $text [expr $index + 1]]
+
+ if {[string first $next_chr {\`*_\{\}[]()#+-.!>|}] != -1} {
+ set chr $next_chr
+ incr index
+ }
+ }
+ {_} -
+ {*} {
+ # EMPHASIS
+ if {[regexp $re_whitespace [string index $result end]] &&
+ [regexp $re_whitespace [string index $text [expr $index + 1]]]} \
+ {
+ #do nothing
+ } \
+ elseif {[regexp -start $index \
+ "\\A(\\$chr{1,3})((?:\[^\\$chr\\\\]|\\\\\\$chr)*)\\1" \
+ $text m del sub]} \
+ {
+ switch [string length $del] {
+ 1 {
+ append result "<em>[parse_inline $sub]</em>"
+ }
+ 2 {
+ append result "<strong>[parse_inline $sub]</strong>"
+ }
+ 3 {
+ append result "<strong><em>[parse_inline $sub]</em></strong>"
+ }
+ }
+
+ incr index [string length $m]
+ continue
+ }
+ }
+ {`} {
+ # CODE
+ regexp -start $index $re_backticks $text m
+ set start [expr $index + [string length $m]]
+
+ if {[regexp -start $start -indices $m $text m]} {
+ set stop [expr [lindex $m 0] - 1]
+
+ set sub [string trim [string range $text $start $stop]]
+
+ append result "<code>[html_escape $sub]</code>"
+ set index [expr [lindex $m 1] + 1]
+ continue
+ }
+ }
+ {!} -
+ {[} {
+ # LINKS AND IMAGES
+ if {$chr eq {!}} {
+ set ref_type img
+ } else {
+ set ref_type link
+ }
+
+ set match_found 0
+
+ if {[regexp -start $index $re_inlinelink $text m txt url ign del title]} {
+ # INLINE
+ incr index [string length $m]
+
+ set url [html_escape [string trim $url {<> }]]
+ set txt [parse_inline $txt]
+ set title [parse_inline $title]
+
+ set match_found 1
+ } elseif {[regexp -start $index $re_reflink $text m txt lbl]} {
+ if {$lbl eq {}} {
+ set lbl [regsub -all {\s+} $txt { }]
+ }
+
+ set lbl [string tolower $lbl]
+
+ if {[info exists ::Markdown::_references($lbl)]} {
+ lassign $::Markdown::_references($lbl) url title
+
+ set url [html_escape [string trim $url {<> }]]
+ set txt [parse_inline $txt]
+ set title [parse_inline $title]
+
+ # REFERENCED
+ incr index [string length $m]
+ set match_found 1
+ }
+ }
+
+ # PRINT IMG, A TAG
+ if {$match_found} {
+ if {$ref_type eq {link}} {
+ if {$title ne {}} {
+ append result "<a href=\"$url\" title=\"$title\">$txt</a>"
+ } else {
+ append result "<a href=\"$url\">$txt</a>"
+ }
+ } else {
+ if {$title ne {}} {
+ append result "<img src=\"$url\" alt=\"$txt\" title=\"$title\"/>"
+ } else {
+ append result "<img src=\"$url\" alt=\"$txt\"/>"
+ }
+ }
+
+ continue
+ }
+ }
+ {<} {
+ # HTML TAGS, COMMENTS AND AUTOLINKS
+ if {[regexp -start $index $re_comment $text m]} {
+ append result $m
+ incr index [string length $m]
+ continue
+ } elseif {[regexp -start $index $re_autolink $text m email link]} {
+ if {$link ne {}} {
+ set link [html_escape $link]
+ append result "<a href=\"$link\">$link</a>"
+ } else {
+ set mailto_prefix "mailto:"
+ if {![regexp "^${mailto_prefix}(.*)" $email mailto email]} {
+ # $email does not contain the prefix "mailto:".
+ set mailto "mailto:$email"
+ }
+ append result "<a href=\"$mailto\">$email</a>"
+ }
+ incr index [string length $m]
+ continue
+ } elseif {[regexp -start $index $re_htmltag $text m]} {
+ append result $m
+ incr index [string length $m]
+ continue
+ }
+
+ set chr [html_escape $chr]
+ }
+ {&} {
+ # ENTITIES
+ if {[regexp -start $index $re_entity $text m]} {
+ append result $m
+ incr index [string length $m]
+ continue
+ }
+
+ set chr [html_escape $chr]
+ }
+ {>} -
+ {'} -
+ "\"" {
+ # OTHER SPECIAL CHARACTERS
+ set chr [html_escape $chr]
+ }
+ default {}
+ }
+
+ append result $chr
+ incr index
+ }
+
+ return $result
+ }
+
+ ## \private
+ proc is_empty_line {line} {
+ return [regexp {^\s*$} $line]
+ }
+
+ ## \private
+ proc html_escape {text} {
+ return [string map {& &amp; < &lt; > &gt; \" &quot;} $text]
+ }
+}
+
+package provide Markdown 1.0
+
diff --git a/tcllib/modules/markdown/pkgIndex.tcl b/tcllib/modules/markdown/pkgIndex.tcl
new file mode 100644
index 0000000..8341ec7
--- /dev/null
+++ b/tcllib/modules/markdown/pkgIndex.tcl
@@ -0,0 +1,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 Markdown 1.0 [list source [file join $dir markdown.tcl]]
diff --git a/tcllib/modules/math/ChangeLog b/tcllib/modules/math/ChangeLog
new file mode 100644
index 0000000..0911406
--- /dev/null
+++ b/tcllib/modules/math/ChangeLog
@@ -0,0 +1,1440 @@
+2015-04-29 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * statistics.tcl: Add test-Duckworth
+ * pdf_stat.tcl: Add empirical-distribution
+ * statistics.test: Add tests for test-Duckworth and empirical-distribution
+ * statistics.man: Describe test-Duckworth and empirical-distribution
+
+2015-04-28 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * statistics.tcl: Bump version to 1.0 - Aku found the cause of earlier problems
+
+2015-04-26 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * statistics.tcl: Bump version to 0.9.3
+ Implemented an alternative to histogram (ticket 1502400fff)
+ Revised test-normal to use "significance" (ticket 2812473fff)
+ * statistics.man: Describe histogram-alt, changes to test-normal (and t-test-mean, again "confidence")
+ * pdf_stat.tcl: Correct the returned value for pdf-beta - if x is 0 or 1.
+
+2014-09-27 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * statistics.tcl: Bump version to 0.9.2
+ * statistics.test: Add tests for all pdf-* and cdf-* procedures, crude tests for random-* procedures
+ * pdf_stat.tcl: Fix a typo (cdf-uniform) and fix inadvertent integer divisions should arguments be integer
+ * special.tcl: Adding Christian's implementation of the inverse normal distribution function (invnorm)
+ * special.test: Adding test case for this new function
+ * special.man: Describing invnorm plus a correction in the overview (ierfc_n is not implemented)
+ * pkgIndex.tcl: Bumping version of math::special package to 0.3.0, of math::statistics to 0.9.2
+
+2014-09-26 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * pdf-stat.tcl: Solve ticket UUID a6d69107d5, a typo in the pdf-uniform procedure
+ * pkgIndex.tcl: Bumping version of math::statistics package to 0.9.1
+
+2014-09-21 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * bigfloat2.tcl: Solve ticket UUID 3309165, different implementation of isInt than suggested
+ * bigfloat2.test: Added several tests for the new implementation of isInt
+ * optimize.tcl: Solve ticket UUID 3193459, as suggested.
+ * optimize.tcl: Solve a problem with the detection of the exceptions in solving linear programs. Version 1.0.1
+ * optimize.test: Added tests to distinguish infeasible and unbounded linear programs
+ * optimize.test: Added test for ticket UUID 3193459
+ * pkgIndex.tcl: Bumping version of math::optimize package to 1.0.1, bigfloat2 to 2.0.2
+
+2014-08-21 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * calculus.tcl: Bumping version to 0.8
+ * pkgIndex.tcl: Bumping version of math::calculus package to 0.8
+
+2014-08-21 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * calculus.man: Describe the qk15 procedure implementing Gauss-Kronrod 15 points quadrature rule
+ * calculus.tcl: Implement the qk15 procedure for Gauss-Kronrod quadrature
+ * calculus.test: Provide a simple test procedure for Gauss-Kronrod quadrature
+
+2014-08-17 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * statistcs.man: Add missing documentation for random-poisson procedure
+
+2014-01-30 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * geometry.tcl: Corrected edge case in pointInsidePolygon (by closer checking
+ intersection of line segments; ticket c1ca34ead3).
+ Also introduced a procedure calculateDistanceToPolygon to solve ticket bff902be35
+ * math_geometry.man: Description of new procedure pointInsidePolygon
+ * geometry.test: Added test cases based on both tickets
+ * pkgIndex.tcl: Bumped version to 1.1.3
+
+2014-01-19 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * stat_kernel.tcl: Corrected use of bandwidth
+ * statistics.test: Added margin per kernel - not quite satisfactory in the case of the uniform kernel
+
+2014-01-18 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * statistics.tcl: Added stat_kernel.tcl
+ * stat_kernel.tcl: Implements a straightforward kernel density estimation procedure
+ * statistics.man: Describe the kernel denstity estimation procedure, moved the description of several
+ tests to the general section
+ * statistics.test: Added three tests for the kernel density estimation (note: one result is a bit troublesome)
+ * pkgIndex.tcl: Bumped version of statistics package to 0.9
+
+2013-12-20 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * interpolate.tcl: [Ticket 843c2257d2] Added special case for points coincident with the data points
+ * interpolate.test: [Ticket 843c2257d2] Added test case for coincident points
+
+2013-12-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * decimal.man: Fixed missing requirement of the package
+ * machineparameters.man: itself.
+
+2013-11-03 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * calculus.tcl: Corrected calculation of corrector in heunStep (now version 0.7.2)
+ * pkgIndex.tcl: [Ticket b25b826973] Bumped version of interpolate to 1.1
+ * interpolate.tcl: [Ticket b25b826973] Corrected inconsistency in use of tables for 1D interpolation
+ * interpolate.test: [Ticket b25b826973] Adjusted the test for 1D interpolation
+ * interpolate.man: [Ticket b25b826973] Added an example for 1D interpolation and note on the
+ incompatibility
+
+2013-03-05 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * statistics.tcl: [Ticket 05d055c2f5]: Added weights to histogram
+ * statistics.man: [Ticket 05d055c2f5]: Documented weights to histogram
+ * statistics.test: [Ticket 05d055c2f5]: Added test for weights to histogram
+ * pkgIndex.tcl: [Ticket 05d055c2f5]: Bumped to version 0.8.1
+
+2013-03-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * math.test (math-12.1): [Bug 3606620]: Disabled debug output
+ command lifting SafeBase error information into the test log.
+
+2013-03-05 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * decimal.tcl: Some rounding issues fixed (by Mark Alston)
+ * pkgIndex.tcl: Bumped version of decimal package to 1.0.3
+
+2013-02-08 Andreas Kupries <andreask@activestate.com>
+
+ * decimal.man: Fixed leading namespace qualifier in label.
+ * symdiff.man: Fixed missing short package title.
+
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2012-06-25 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * statistics.tcl: Add procedures for Wilcoxon test and Spearman
+ rank correlation to the export list
+
+2012-06-24 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * decimal.man: Correct documentation (namespace) for decimal package
+ * statistics.tcl: Add Wilcoxon test and Spearman rank correlation
+ Bumped version to 0.8
+ * statistics.test: Add test cases for Wilcoxon test and Spearman rank correlation
+ * statistics.man: Describe procs for Wilcoxon test and Spearman rank correlation
+ * wilcoxon.tcl: Added this file - contains implementation of the new procs
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-11-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * decimal.test: More fixes, now the test succeeds as
+ well. 'Simply' required the proper conversions for arguments and
+ results as most commands do not take regular numbers.
+
+2011-11-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * decimal.test: Fixed the testsuite to be at least properly
+ executable, i.e. bad file names and broken Tcl syntax. The
+ single test still but that sahall be a problem for the actual
+ maintainer.
+
+2011-08-09 Andreas Kupries <andreask@activestate.com>
+
+ * decimal.man: [Bug 3383039]: Fixed syntax errors in the
+ documentation of math::decimal, reported by Thomas Perschak
+ <tombert@users.sourceforge.net>
+
+2011-03-29 Andreas Kupries <andreask@activestate.com>
+
+ * linalg.man: Documentation tweak, added keyword 'matrix'.
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2011-01-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * symdiff.test: Fixed setup (added std boilerplate).
+ * pkgIndex.tcl: Moved symdiff to correct section, requires 8.5,
+ not 8.4.
+
+2010-05-24 Andreas Kupries <andreask@activestate.com>
+
+ * geometry.man: [Bug 3110860]: Renamed this file to avoid the
+ * math_geometry.man: conflict with Tcl 8.6's new geometry
+ manpage. Thanks to Reinhard Max for reporting.
+
+2010-10-19 Kevin B. Kenny <kennykb@acm.org>
+
+ * symdiff.man:
+ * symdiff.tcl: Added a math::calculus::symdiff package that
+ * symdiff.test: performs symbolic differentiation of Tcl math
+ * pkgIndex.tcl: exprs.
+
+2010-09-27 Lars Hellstr\"om <lars_h@users.sourceforge.net>
+
+ * numtheory.test: Fixed bug #3076576.
+ * numtheory.dtx:
+
+2010-09-22 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * kruskal.tcl: Added header to the file
+
+2010-09-21 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * kruskal.tcl: One-sided test according to Kruskal-Wallis
+ * statistics.tcl: Added test Kruskal-Wallis
+ * statistics.man: Describe Kruskal-Wallis
+ * statistics.test: Added simple test case
+ * pkgIndex.tcl: Bumped version to 0.7.0
+
+2010-09-20 Lars Hellstr\"om <lars_h@users.sourceforge.net>
+
+ * numtheory.dtx: New package math::numtheory (v1.0)
+ * numtheory.man: with command math::numtheory::isprime.
+ * numtheory.stitch: See numtheory.dtx for all the gory
+ * numtheory.tcl: details of the implementation of
+ * numtheory.test: package and tests.
+ * pkgIndex.tcl:
+
+2010-08-22 Andreas Kupries <andreask@activestate.com>
+
+ * linalg.tcl: Corrected bug #3036124 (shape of U matrix)
+ - should probably include an extra command for
+ truncated output of S and V
+
+2010-05-24 Andreas Kupries <andreask@activestate.com>
+
+ * geometry.man: A bit more commands, bumped to version 1.1.2.
+ * geometry.tcl:
+ * pkgIndex.tcl:
+
+2010-04-06 Andreas Kupries <andreask@activestate.com>
+
+ * geometry.tcl (findLineIntersection): Fixed numerical
+ * geometry.man: instability in the algorithm by replacing
+ * geometry.test: it with Kevin's parametric code. Updated
+ * pkgIndex.tcl: documentation, testsuite. Bumped to
+ version 1.1.1.
+
+2010-04-05 Andreas Kupries <andreask@activestate.com>
+
+ * geometry.tcl: Extended API with a number of basic point
+ * geometry.man: and vector operations (+, -, scale, ...).
+ * geometry.test: Updated documentation, testsuite.
+ * pkgIndex.tcl: Bumped to version 1.1.
+
+2010-01-17 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * fuzzy.tcl: [Bug 2933130]. Fixed procedure tlt
+ * fuzzy.test: [Bug 2933130]. Added test for this bug
+ * pkgIndex.tcl: Version increased to 0.2.1
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-12-04 Andreas Kupries <andreask@activestate.com>
+
+ * math.man: [Bug 1998628]. Accepted fix by Arjen Markus, with
+ * math.tcl: modifications. Extended testsuite. Bumped version
+ * math.test: to 1.2.5.
+ * pkgIndex.tcl:
+
+2009-11-17 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * statistics.tcl: Bumped version to 0.6.3
+ * geometry.tcl: Solved bug #1623653 - corner case in pointInsidePolygon
+ * geometry.test: Added two tests for the corner case
+ * pkgIndex.tcl: Updated version numbers
+
+2009-11-16 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * pdf_stat.tcl: Fix bug #2897419 - very small numbers with beta
+ distribution
+
+2009-10-22 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * interpolate.tcl: Fix bug #2881739 in cubic interpolation
+
+2009-09-28 Andreas Kupries <andreask@activestate.com>
+
+ * linalg.test: Switched the test setup back to 'regular' and also
+ fixed the version information in the non-regular branch of the
+ setup.
+
+2009-08-21 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * statistics.tcl: Remove a local variable from interval-mean-stdev
+
+2009-08-12 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * statistics.tcl: Solve bug 2835712 regarding interval-mean-stdev
+
+2009-07-13 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * statistics.tcl: Implement more robust computation of basic statistics
+ Fixes bug 2812832; simplified the code (as indicated by akupries)
+ * statistics.test: Added test for this more robust computation
+ * linalg.tcl: Corrected dim and shape procedures for scalars (version now 1.1.3;
+ Fixes bug 2818958
+ * linalg.test: Corrected result of dim and shape procedures for scalars
+ * pkgIndex.tcl: Updated version numbers
+
+2009-03-20 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * linalg.tcl: Solving bugs with test matrices (bugs #2695513, 2695564, 2695618)
+ * linalg.test: Added test cases for border matrix and Wilkinson W- and W+
+ * pkgIndex.tcl: Version of linear algebra package increased to 1.1.1
+
+2009-02-18 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * machineparameters.man: Replaced deprecated markup (bug #2597454)
+
+2009-02-06 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * pkgIndex.tcl: Added machineparameters package
+ * machineparameters.tcl: New package by Michael Baudin
+ * machineparameters.test: Test for the new package
+ * machineparameters.man: Man page for the new package
+
+2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11.1 ========================
+ *
+
+2008-12-01 Andreas Kupries <andreask@activestate.com>
+
+ * linalg.man: New commands in last checkin means extended API.
+ * linalg.tcl: Bumping minor version, to 1.1.
+ * pkgIndex.tcl:
+
+2008-12-01 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * linalg.man: changed int to integer, documented new procedures by Michael Baudin
+ * linalg.test: incorporated new tests by Michael Baudin
+ * linalg.tcl: incorporated new procedures, extensions and several bug fixes by Michael Baudin
+
+2008-11-09 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * optimize.man: corrected names of minimum and maximum procedures
+
+2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11 ========================
+ *
+
+2008-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * calculus.tcl: Bumped version to 0.7.1, for the commit on
+ * calculus.man: 2008-06-25 by Arjen. Was a bugfix, should
+ * pkgIndex.tcl: have bumped the version then.
+
+2008-08-12 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * special.tcl: bumped version to 0.2.2 (because of previous change)
+ * pkgIndex.tcl: bumped version of "special" to 0.2.2
+
+2008-08-11 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * special.tcl: Replaced old algorithm for erf() and erfc(). Bug
+ #2024843.
+
+2008-07-01 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * roman.man: corrected wrong mark-up command
+
+2008-06-25 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * calculus.tcl: solved problem with solveTriDiagonal (bug 2001539)
+ * calculus.tcl: repaired hidden problem with boundaryValueSecondOrder
+ * calculus.test: added test case for solveTriDiagonal
+
+2008-05-19 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * roman.man: correct namespace ::math::roman, was ::roman.
+
+2008-03-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: Synchronized indexed and provided versions of
+ * bigfloat.man: math::bigfloat.
+
+2008-03-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * constants.test: Fixed declaration of package under test, was
+ wrongly declared as support.
+
+2008-03-14 Andreas Kupries <andreask@activestate.com>
+
+ * statistics.man: Cleaned up a bit, replaced deprecated [nl] usage
+ with [para].
+
+2008-02-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * linalg.test (eigenvectors-1.0): Moved brace to correct location.
+
+2008-02-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * linalg.test (eigenvectors-1.0): Fixed missing closing brace.
+
+2008-02-21 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * elliptic.tcl: Error in expression (missing ))
+
+2008-01-18 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * statistics.man: Update manual; added beta distribution
+ * statistics.test: Added tests for beta distribution
+ * pdf-stat.tcl: Added procedures for beta distirbution
+ (Improved implementation by Eric K. Benedict)
+
+2008-01-13 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * statistics.man: Update manual; added description of various new procedures
+ * statistics.test: Added tests for chi square and Student's t distributions
+ * pdf-stat.tcl: Added procedures for chi square and Student's t distributions
+ (Next batch of feature requests by Eric K. Benedict)
+
+2008-01-11 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * statistics.man: Update manual; added description of various new procedures
+ * statistics.test: Added tests for Gamma and Poisson distributions
+ * pdf-stat.tcl: Added procedures for Gamma and Poission distributions
+ (Feature requests by Eric K. Benedict)
+
+2007-12-22 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * linalg.tcl: Corrected bug #1805912 (eigenvectorsSVD) by means of path #1852519
+ * linalg.test: Added simple test case for eigenvectorsSVD
+ * pkgIndex.tcl: Increased version number for linear algebra (1.0.3 now)
+
+2007-12-11 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * special.tcl: Corrected implementation of Gamma
+ function (reported by EKB)
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-09-11 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * linalg.test: Corrected test that was linked to SF bug 1784637
+ * linalg.tcl: Corrected case in matmul that was linked to SF bug
+ 1784637
+
+2007-09-06 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * linalg.tcl: Solved bug with matmul (SF bug 1784637)
+
+2007-08-21 Andreas Kupries <andreask@activestate.com>
+
+ * math.test (matchTolerant): Changed to not use tcltest 2.0+
+ features in a testsuite for tcltest 1.0. Rewritten the tests
+ using this custom comparison command to be tcltest 1.0
+ compliant.
+
+ * pkgIndex.tcl: With permission from Arjen moved math::statistics
+ * bessel.test: into the 8.4 section. Due to its new dependency on
+ * elliptic.test: math::linearalgebra via multi-variate linear
+ * statistics.test: regression it now depends on Tcl 8.4+ too.
+ * special.test: Updated the tests using math::statistics for this
+ as well.
+
+2007-08-20 Andreas Kupries <andreask@activestate.com>
+
+ * bessel.test: Added missing dependency on math::linearalgebra.
+ * elliptic.test: (For math::statistics). This not fully ok yet,
+ the Tcl core requirements are out of whack too.
+
+2007-07-10 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * statistics.tcl: Corrected a spelling mistake in name of Zachariadis
+ * linalg.test: Removed temporary reference to ferri/ferri.test
+
+2007-07-07 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * math.test: Added a small tolerance for two tests
+ * statistics.man: Added pvar and pstdev, difference between var and pvar documented
+ * statistics.tcl: Added population stdev and variance
+ * statistics.test: Added tests for pvar and pstdev
+ * special.test: Added dependency on math::linearalgebra
+
+2007-06-26 Kevin B. Kenny <kennykb@acm.org>
+
+ * elliptic.tcl: Removed a spurious 'puts' in the computation of
+ Jacobian elliptic functions.
+ * special.tcl: Advanced patchlevel to 0.2.1.
+
+2007-03-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bigfloat.man: Fixed all warnings due to use of now deprecated
+ * bignum.man: commands. Added a section about how to give
+ * calculus.man: feedback.
+ * combinatorics.man:
+ * constants.man:
+ * fourier.man:
+ * fuzzy.man:
+ * geometry.man:
+ * interpolate.man:
+ * linalg.man:
+ * math.man:
+ * optimize.man:
+ * polynomials.man:
+ * qcomplex.man:
+ * rational_funcs.man:
+ * roman.man:
+ * romberg.man:
+ * special.man:
+ * statistics.man:
+
+2007-03-20 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * mvlinreg.tcl : changed the API to make it more robust (no eval needed)
+ * statistics.man : updated description of mv-ols and mv-wls
+ * statistics.test : updated the API
+
+2007-03-18 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * statistics.man : updated description of tstat
+ * statistics.test : converted the example into a test
+
+2007-03-05 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * mvlinreg.tcl : polished the source code (adding standard headers)
+ Still to do: test cases
+
+2007-02-27 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * statistics.man : added description of multivariate linear regression procedures
+ (contribution by Eric Kemp-Benedict)
+ * statistics.tcl : sources "mvlinreg.tcl" now
+ * mvlinreg.tcl : original source code from Eric, still needs some polishing
+ (the test case needs to be integrated too)
+
+2006-11-06 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * fuzzy.test : fixed a dependency on Tcl 8.4 behaviour in one test case
+ (the value of tcl_precision)
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-26 Andreas Kupries <andreask@activestate.com>
+
+ * bigfloat.tcl: Bumped version to 1.2.1
+ * pkgIndex.tcl:
+
+2006-09-26 Stephane Arnold <sarnold75@users.sourceforge.net>
+ * bigfloat.man : fixed a bug in [math::bigfloat::tostr]
+ * bigfloat.tcl : when a number is close to zero,
+ * bigfloat.test it takes the precision into account,
+ * bigfloat2.tcl so instead of getting '0' we get '0.e-4'.
+ * bigfloat2.test [math::bigfloat::iszero] is not impacted
+
+2006-09-20 Andreas Kupries <andreask@activestate.com>
+
+ * math.tcl: Bumped version to 1.2.4
+ * math.man:
+ * qcomplex.man: Bumped version to 1.0.2
+ * qcomplex.tcl:
+ * fourier.man: Bumped version to 1.0.2
+ * fourier.tcl:
+ * interpolate.man: Bumped version to 1.0.2
+ * interpolate.tcl:
+ * linalg.tcl: Bumped version to 1.0.1
+ * linalg.man:
+ * pkgIndex.tcl:
+
+2006-09-19 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * linalg.tcl: removed print statement (left over from testing leastSquares)
+
+2006-09-15 Arjen Markus <arjenmarkus@users.sourceforge.net>
+ * linalg.man: added remark on name conflict with Tk
+ added missing descriptions of several procedures
+ * linalg.tcl: added crossproduct to the exported commands
+ implemented normalizeStat
+ corrected error in leastSquaresSVD
+ * linalg.test: added test for normalizeStat
+ added test for leastSquaresSVD
+
+2006-06-13 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * pdf_stat.tcl: check for existence of argv0 - child interpreters
+ * plotstat.tcl: ditto
+ * statistics.tcl: ditto
+
+2006-03-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * math.man: Fixed name of romberg package, resorted the list,
+ slight reformatting of items with regard to right margin.
+
+2006-03-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * math.man: Added a bit of markup to the package list for better
+ cross-referencing.
+
+ * statistics.man: Fixed unclosed bracket.
+
+2006-03-28 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * calculus.tcl (integral2D and integral3D): Fixed a bug concerning
+ intervals that do not start at 0.0
+ * calculus.tcl (integral2D and integral3D): Added accurate versions
+ for integration over rectangles and blocks (exact for polynomials
+ of degree 3 or less).
+ * statistics.tcl (test-normal): Added implementation of normality test
+ by Torsten Reincke (as it appeared on the Wiki)
+
+2006-03-02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: Resynchronized the ifneeded/provide version
+ information for math::bignum.
+
+2006-02-21 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * linalg.tcl (matmul): Fixed [SF Tcllib Bug xxxxxxx]. The bug
+ concerns the possibility of using row vectors. Because I
+ did not think they were possible/practical, I regarded all
+ vectors as column vectors or row vectors whenever suitable.
+ Row vectors are however practical, so I needed to add these
+ cases, at least for [matmul].
+
+2006-02-13 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * bignum.tcl (rshift): Fixed [SF Tcllib Bug 1098051]. (Solution
+ provided by Lars Hellstrom. Added tests for both rshift and lshift)
+
+2006-01-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bignum.tcl (testbit): Fixed [SF Tcllib Bug 1085562]. Thanks to
+ aubinroy <aroy@users.sf.net> for the report, bugfix, and his
+ patience while waiting for us to apply the fix.
+ * bignum.test: Extended the testsuite.
+
+2006-01-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bigfloat.test: Fixed use of duplicate test names.
+ * calculus.test:
+ * linalg.test:
+ * statistics.test:
+
+2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bessel.test: More boilerplate simplified via use of test support.
+ * bigfloat.test:
+ * bigfloat2.test:
+ * bignum.test:
+ * calculus.test:
+ * combinatorics.test:
+ * constants.test:
+ * elliptic.test:
+ * fourier.test:
+ * fuzzy.test:
+ * geometry.test:
+ * interpolate.test:
+ * linalg.test:
+ * math.test:
+ * optimize.test:
+ * polynomials.test:
+ * qcomplex.test:
+ * roman.test:
+ * special.test:
+ * statistics.test:
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bessel.test: Hooked into the new common test support code.
+ * bigfloat.test:
+ * bigfloat2.test:
+ * bignum.test:
+ * calculus.test:
+ * combinatorics.test:
+ * constants.test:
+ * elliptic.test:
+ * fourier.test:
+ * fuzzy.test:
+ * geometry.test:
+ * interpolate.test:
+ * linalg.test:
+ * math.test:
+ * optimize.test:
+ * polynomials.test:
+ * qcomplex.test:
+ * roman.test:
+ * special.test:
+ * statistics.test:
+
+2006-01-11 Andreas Kupries <andreask@activestate.com>
+
+ * fourier.tcl (::math::fourier::lowpass): Changed package
+ * fourier.tcl (::math::fourier::highpass): reference
+ "complexnumbers" to the correct "math::complexnumbers".
+
+2006-01-10 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * linalg.tcl: Fixed bug in procedure angle
+ Added a procedure crossproduct
+ * linalg.man: Added documentation on crossproduct
+
+2005-11-13 Stephane Arnold <sarnold75@users.sourceforge.net>
+
+ * bigfloat2.tcl : bug fix in trigonometry, functions may have
+ return a number more precise than the input
+ * bignum.tcl : a little performance enhancement by avoiding
+ the use of [upvar] in [_treat]
+ * bigfloat2.test : minor changes
+ * bigfloat.man : rewriting 40% of the documentation that
+ now covers both 1.2 and 2.0 versions
+
+2005-11-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: Reworked the extended package index a bit to keep
+ the general existing structure.
+
+2005-11-13 Stephane Arnold <sarnold75@users.sourceforge.net>
+
+ * bigfloat2.tcl,bigfloat2.test : two files
+ forming the math::bigfloat package for Tcl 8.5
+ * pkgIndex.tcl : updated to handle the different Tcl versions
+ Tcl 8.4 still has math::bigfloat 1.2
+
+2005-11-04 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * roman.test: removed extraneous messages
+
+2005-10-26 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * qcomplex.tcl: error in the computation of the complex
+ cosine. Found by Oscar Andreas Lopez.
+
+2005-10-21 Andreas Kupries <andreask@activestate.com>
+
+ * interpolate.test: Reduced requirement for struct down to
+ * interpolate.tcl: struct::matrix, as that is the only structure
+ used by this package. This means that we are loading 272 KB less
+ (344 KB - 72 KB). Also fixed the testsuite header code.
+
+2005-10-10 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * fixed one bug regarding cov in misc.tcl
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: Updated all version numbers to be in sync with the
+ * bignum.man: changes made to the various packages in this module.
+ * bignum.tcl:
+ * calculus.man:
+ * calculus.tcl:
+ * combinatorics.man:
+ * constants.man:
+ * constants.tcl:
+ * fourier.man:
+ * fourier.tcl:
+ * interpolate.man:
+ * interpolate.tcl:
+ * math.man:
+ * math.tcl:
+ * polynomials.man:
+ * polynomials.tcl:
+ * qcomplex.man:
+ * qcomplex.tcl:
+ * rational_funcs.man:
+ * rational_funcs.tcl:
+ * special.man:
+ * special.tcl:
+ * statistics.man:
+ * statistics.tcl:
+
+2005-10-04 Andreas Kupries <andreask@activestate.com>
+
+ * geometry.man: Fixed bad reversals of geometry version
+ * geometry.tcl: numbers. Bumped version to reflect the
+ documentation change.
+
+ * pkgIndex.tcl: Added new 'math::roman' to package index.
+
+2005-10-04 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Added roman numerals package by Kenneth Green
+ * geometry.man: Completed the description of the
+ current procedures
+
+2005-09-28 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * optimize.man: Removed note on linear programming. It is
+ working now (not fully, perhaps though)
+
+2005-09-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: Declared 8.4 dependency of packages
+ * optimize.man: math::optimize, math::calculus, and
+ * optimize.tcl: math::interpolate in package index, code, and
+ * optimize.test: testsuite.
+ * interpolate.man:
+ * interpolate.tcl:
+ * interpolate.test:
+ * calculus.man:
+ * calculus.tcl:
+ * calculus.test:
+
+2005-09-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: Declared 8.4 dependency of linalg package in
+ * linalg.tcl: package index, code, and testsuite.
+ * linalg.test:
+
+ * bessel.test: Fixed a number of typos in the abort messages.
+ * bigfloat.test: Indented abort messages for better visibility
+ * bignum.test: in the log.
+ * calculus.test: Declared 8.4 dependency of bignum/bigfloat in
+ * constants.test: package index, code, and testsuite.
+ * elliptic.test: Removed 8.4isms from testsuites for packages
+ * fourier.test: allowing use with Tcl 8.2+
+ * interpolate.test:
+ * linalg.test:
+ * math.test:
+ * optimize.test:
+ * polynomials.test:
+ * qcomplex.test:
+ * special.test:
+ * statistics.test:
+ * bigfloat.tcl:
+ * bignum.tcl:
+ * pkgIndex.tcl:
+
+2005-09-09 Stephane Arnold <sarnold75@users.sourceforge.net>
+
+ * bigfloat.tcl : went back to the old algorithm to compute Pi
+ after having done much benchmarks
+
+2005-09-06 Stephane Arnold <sarnold75@users.sourceforge.net>
+
+ * bigfloat.tcl : new and faster algorithm to compute Pi
+
+2005-08-31 Stephane Arnold <sarnold75@users.sourceforge.net>
+
+ * bigfloat.tcl : added many comments and fixed some minor bugs
+ (possibly following to inexact last digits)
+ * bigfloat.test : fixed a bug that causes the version number
+ of some tests to be replaced by 1.0 or by the string "version"
+
+2005-08-30 Andreas Kupries <andreask@activestate.com>
+
+ * bignum.tcl: Fixed code exporting the bignum commands, it was
+ done in the wrong namespace. This fixes [Tcllib SF Bug 1276680].
+
+2005-08-29 Kevin Kenny <kennykb@acm.org>
+
+ * combinatorics.test (combinatorics-2.7,3.10): Revised a few test cases
+ * math.test (math-7.4): to handle Infinity
+ in the interim (pre-TIP#237) 8.5 configuration as well as
+ kennykb-numerics-branch.
+
+2005-08-29 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Fixed bug #1272910: due to the different rounding
+ of 0.5 in Tcl 8.5, the Quantiles-1.0 test failed.
+ Using different levels steers the test away from
+ this odd edge case.
+
+2005-08-29 Stephane Arnold <sarnold75@users.sourceforge.net>
+
+ * bigfloat.tcl : added comments to make code easier to understand
+
+2005-08-28 Stephane Arnold <sarnold75@users.sourceforge.net>
+
+ * bigfloat.tcl : many optimizations around the fromstr
+ command and all kind of constants (mainly integer)
+ * bigfloat.test : updated test labels to more significant labels
+ * Bug #1272836 : the math round() function has changed
+ in Tcl 8.5a4 (intentionally) - now the round tests
+ do no more rely upon this function.
+
+2005-08-26 Stephane Arnold <sarnold75@users.sourceforge.net>
+
+ * Feature Request 1261101 : automatically convert
+ the strings "0" and "1" to bignums
+ * modified files : bignum.man,bignum.tcl,bignum.test
+ * Bug 1273403 : fixed in bigfloat.test (all tests shared
+ the same version number)
+
+2005-08-25 Kevin Kenny <kennykb@acm.org>
+
+ * combinatorics.test (combinatorics-2.7,3.10): Revised a few test cases
+ * math.test (math-7.4): to handle Infinity
+ as well as "overflow" and "division by zero" as an error result.
+
+2005-08-24 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * optimize.man: Corrected a few typos
+
+2005-08-23 Stephane Arnold <sarnold75@users.sourceforge.net>
+
+ * bigfloat.tcl : Fixed a small bug in [fromstr].
+ * bigfloat.man : Trying to make it more clear about accuracy
+ and interval computations.
+
+2005-08-17 Kevin Kenny <kennykb@acm.org>
+
+ * optimize.tcl (nelderMead): Added ::math::optimize::nelderMead,
+ * optimize.test (nelderMead-*): an implementation of multidimensional
+ * optimize.man: optimization using the downhill
+ simplex method of Nelder and Mead. (Addition includes test cases
+ and rudimentary documentation.)
+ * exponential.tcl: Changed the demo script not to error out.
+
+2005-08-09 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Added the linear programming routines that were
+ described in the man page, but not actually there
+ * Updated the test file and man page for this
+ * Updated the pkgIndex.tcl file (optimize now at 1.0)
+
+2005-08-05 Stephane Arnold <sarnold75@users.sourceforge.net>
+
+ * bigfloat.tcl : Fixed a bug in [fromstr] when a number
+ began with '+' ; another bug, in [fromdouble], when
+ a number began with '+' or '-'.
+ * bigfloat.test : Added tests for fromdouble.
+
+2005-08-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bigfloat.man: Replaced a number of ?...? occurences to markup
+ optional arguments with the more correct [opt ...].
+
+2005-08-04 Stephane Arnold <sarnold75@users.sourceforge.net>
+
+ * bigfloat : Fixed a bug in [fromstr] when a number
+ with an exponent beginning by 0 was given (like 1.1e+099)
+
+ * bigfloat : Added a [fromdouble] new proc.
+
+2005-08-01 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Changed the credits for Ed Hume at his request
+ (anti-spam measure)
+
+2005-07-26 Stephane Arnold
+
+ * Changed in many places : '[pi $precision]'
+ to '[pi $precision 1]' in which $precision is treated
+ as binary digit length (instead of decimals)
+ since the internal representation of the mantissa is binary
+
+2005-07-01 Stephane Arnold <sarnold75@users.sourceforge.net>
+
+ * bigfloat.man,bigfloat.test,bigfloat.tcl : updated
+ copyright 2005
+ * bigfloat.man : put the correct package version (1.2)
+
+2005-07-01 Stephane Arnold <sarnold75@users.sourceforge.net>
+
+ * bigfloat.tcl : new [int2float] conversion procedure
+ * bigfloat.test : updated test suite for the new procedure
+ * bigfloat.man : updated documentation and added a new EXAMPLES
+ section
+
+2005-06-23 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * bigfloat.tcl: Removed the namespace import statement
+ * bigfloat.test: Explicitly import the bigfloat procedures
+ * qcomplex.test: Force the import of complex number procedures
+ (conflict with bigfloat's sqrt)
+
+2005-06-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * statistics.test: Corrected typos in the test suite for the new
+ commands.
+
+2005-06-22 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * statistics.tcl/test/man:
+ Added several methods: 2x2 tables and two quality
+ control charts
+
+ * elliptic.tcl/man:
+ Added functions cn, dn and sn. Test cases still
+ needed.
+
+2005-06-07 Kevin Kenny <kennykb@acm.org>
+
+ * constants.tcl: Corrected ::math::constants::find_huge
+ and ::math::constants::find_tiny to not go
+ into an infinite loop when overflow is not an error.
+
+2005-05-04 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Removed reference to argv0 in optimize.tcl (in response
+ to a complaint by Bob Techentin)
+
+2005-04-25 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Corrected documentation of math::product (was math::prod)
+
+2005-03-16 Andreas Kupries <andreask@activestate.com>
+
+ * bigfloat.tcl: Added package require math::bignum. If we use the
+ package we should load it as well.
+
+ * rational_funcs.tcl: Redone entry '2004-11-22 Andreas Kupries
+ <andreask@activestate.com>'. Somehow the source command came
+ back.
+
+2005-03-11 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Corrected problem with exponential_Ei - doubly defined
+
+2005-01-14 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Added version 1.0 of Stephane Arnold's bigfloat package
+ (newer versions will come later on)
+
+2005-01-10 Andreas Kupries <andreask@activestate.com>
+
+ * bignum.tcl: Integrated [Tcllib SF Bug 1093414]. Basic bit
+ * bignum.test: operations (and, or, xor) on big numbers. Correct
+ * bignum.man: operation is limited to positive numbers (including
+ zero). The basic code was provided by Aamer Aakther
+ <aakther@users.sourceforge.net>, modifications of docs, and
+ small testsuite by myself.
+
+2005-01-05 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Added tests for matmul (and corrected the implementation)
+
+2005-01-04 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Expanded the documentation (it should now describe all
+ public procedures)
+ * Expanded the tests (not complete, but it should cover most
+ more complicated procedures)
+ * Expanded the set of procedures (only a few algorithms
+ await implementation)
+
+2005-01-03 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Added modified Gram-Schmidt method to the linear algebra package
+
+2004-12-06 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Fixed bug in rungeKuttaStep (calculus.tcl) found by Mark Stucky.
+ (Also moved the empty lines upward to better reflect the steps)
+
+2004-11-25 Andreas Kupries <andreask@activestate.com>
+
+ * linalg.man: Fixed a formatting bug in the file, found by a
+ regular run of the SAK tool.
+
+2004-11-25 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Added descriptions of various linear algebra procedures
+ * Updated the code and expanded test cases
+
+2004-11-22 Andreas Kupries <andreask@activestate.com>
+
+ * rational_funcs.tcl: Removed bad source'ing of file
+ polynomials.tcl. Depended on current working directory in the
+ right place, and superfluous as well, as immediately after a
+ 'package require' of the package loaded it in the proper
+ manner. Disabled the test code at the end as well.
+
+2004-11-08 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Added preliminary versions of a linear algebra module
+ (revision of Hume's LA). No documentation yet
+ * Removed the initialisation of CDF (that was left in there)
+
+2004-11-01 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Moved initialisation of CDF in statistics module to
+ first call
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-10-02 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Added preliminary documentation for the geometry module
+ * Added procedure areaPolygon to the geometry module
+ * Added Fourier transform module
+
+2004-09-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * bignum.test: Boilerplate reading file under test.
+
+2004-09-30 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Added a first set of test cases for the bignum module
+ * Corrected the namespace for the bignum module
+
+2004-09-29 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * Added the bignum module by Salvatore Sanfilippo. No test cases yet
+
+2004-09-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pdf_stat.tcl: Braced expr'essions, removed duplicated error
+ message.
+
+ * constants.tcl (find_eps): Fixed expr'essions without braces.
+ * statistics.tcl:
+
+ * exponential.tcl (proc): Removes superfluous no-op [append].
+
+2004-09-22 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * *.test: Made sure the test files check for version 2.1 of the
+ tcltest package
+
+ * *.tcl: Updated the package versions and consistently put the
+ "package provide" statement at the end
+
+ * interpolate.*: Added cubic splines as interpolation method
+
+2004-09-17 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * bessel.tcl: Better implementation of Bessel functions of integer
+ order.
+
+2004-09-09 Andreas Kupries <andreask@activestate.com>
+
+ * calculus.man: Fixed problems in the calculus manpage introduced
+ by the last commit done yesterday.
+
+2004-09-08 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * calculus.tcl: added regula falsi method for finding roots
+
+2004-07-19 Andreas Kupries <andreask@activestate.com>
+
+ * combinatorics.man: Polished minimally, name of manpage.
+
+ * qcomplex.tcl: Polished minimally, changed package name
+ * qcomplex.man: to math::complexnumbers.
+
+2004-07-07 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * bessel,tcl: Indentation adjusted to conform to
+ * bessel.test: the _Tcl Style Guide._ Errors
+ * constants.test: corrected in the documentation of
+ * elliptic.tcl: Romberg integration.
+ * elliptic.text:
+ * qcomplex.tcl:
+ * romberg.man:
+ * special.test:
+
+2004-07-05 Kevin Kenny <kennykb@acm.org>
+
+ * calculus.man: Added Romberg integration to
+ * romberg.man: the library. The procedures should
+ * calculus.tcl (romberg*): provide a "production quality"
+ * calculus.test (romberg-*): library for integrating functions
+ * math.tcl: of one variable, including functions
+ * misc.tcl (expectInteger): that have integrable singularities
+ and integrals over half-infinite
+ intervals.
+ * constants.tcl: Changes so that constants get defined in the
+ * constants.test: correct namespace. Changed tests so that they
+ * elliptic.test: don't fail when other tests have already run.
+ * special.tcl: Changed the definition of Gamma to the correct
+ * special.test: one.
+ Also added copyright notices and CVS IDs in several files that
+ lacked them, and corrected indentation in several files.
+
+2004-06-19 Kevin Kenny <kennykb@acm.org>
+
+ * interpolate.man: Added polynomial interpolation with Neville's
+ * interpolate.tcl: algorithm; this procedure will be needed in
+ * interpolate.test: Romberg integration, which is the next project.
+
+2004-06-18 Kevin Kenny <kennykb@acm.org>
+
+ * bessel.test: Fixed several problems that were causing tests
+ * combinatorics.test: to fail or to run noisily. Corrected inconsistent
+ * interpolate.tcl: package version number in interpolate.tcl.
+ * interpolate.test:
+ * qcomplex.test:
+
+ * optimize.man: Added min_bound_1d and min_unbound_1d functions
+ * optimize.tcl: to do one-dimensional function minimization,
+ * optimize.test: constrained and unconstrained, respectively,
+ without derivatives.
+
+2004-06-16 Andreas Kupries <andreask@activestate.com>
+
+ * interpolate.man: Added a missing list_end before section
+ examples. Fixed usage of braces in the example as well.
+
+2004-06-16 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * added the modules complexnumbers, special, interpolate, constants
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-09 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * combinatorics.tcl (::math::factorial): correct fac 171
+ off-by-one and use of -strict in string is int|double.
+
+2003-12-22 Joe English <jenglish@users.sourceforge.net>
+ * calculus.man (rungeKuttaStep): Add missing argument
+ in function synopsis (bug report from Richard Body).
+
+2003-10-29 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * statistics.tcl (BasicStat): Applied fix for [SF Tcllib Bug
+ 820807]. Uniform data may cause a small negative value when
+ computing the base value for a standard deviation, instead of
+ the correct 0.0. The fix now enforces 0.0 when encountering this
+ situation. This entry in the ChangeLog by Andreas Kupries.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-24 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Found math::optimize missing in index.
+ * optimize.man: Version number inconsistent with code,
+ corrected.
+
+ * calculus.test: Converted [puts] into log statements, and
+ suppress them by default. Reduces the noise when running the
+ testsuite.
+
+ * math.test: Added output listing the version of the
+ * statistics.test: package we are testing.
+ * calculus.test:
+ * geometry.test:
+ * combinatorics.test:
+ * optimize.test:
+
+2003-04-24 Arjen Markus <arjenmarkus@users.sourceforge.net>
+
+ * liststat.tcl: Corrected the handling of the expression in the
+ list manipulation procedures. This solves the scope problem (bug
+ 725231). AK: Lifted from the 'cvs log'. This passes the testsuite.
+
+2003-04-23 Andreas Kupries <andreask@activestate.com>
+
+ * fuzzy.test: Re-applied bug fixes I did before (See 2003-04-13)
+ to the newly committed version, which was not merged, but simply
+ overwrote my changes.
+
+2003-04-21 Andreas Kupries <andreask@activestate.com>
+
+ * optimize.test: Corrected errors in loading the functionality
+ under test, and of accessing tcltest. Now functional.
+
+2003-04-18 Joe English <jenglish@flightlab.com
+
+ * optimize.man: fix minor markup errors that doctools and tmml
+ were complaining about.
+
+2003-04-16 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Added math::statistics after yesterday's commit by
+ Arjen Markus.
+
+ * statistics.test: Changed to conform to standard of importing
+ tcltest, changed import of tested functionality, added checks
+ that actually tcltest 1.2 or higher is used (Aborting if not).
+
+ * statistics.tcl:
+ * liststat.tcl
+ * pdf_stat.tcl:
+ * plotstat.tcl: Reformatted a bit to be more near to the
+ style-guide with regard to indentation.
+
+2003-04-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl:
+ * fuzzy.tcl: Committed new code (see #535216), this also updates
+ the package to version 0.2
+
+ * fuzzy.man:
+ * fuzzy.test: New files for fuzzy comparisons, documentation and
+ testsuite. Fixed some bugs in them. NOTE: There are failures in
+ the testsuite.
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * combinatorics.man:
+ * math.man:
+ * math.tcl:
+ * pkgIndex.tcl: Set version of the package to to 1.2.2.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * combinatorics.man: More semantic markup, less visual one.
+ * calculus.man:
+
+2002-06-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: updated calculus to version 0.5.
+ * calculus.man: Added [require] declarations.
+
+ * calculus.README:
+ * calculus.CHANGES:
+ * calculus.tcl:
+ * calculus.test:
+ * calculus.man: Applied changes for #553773 on behalf of Arjen
+ Markus <arjenmarkus@users.sourceforge.net>.
+
+2002-05-08 Don Porter <dgp@users.sourceforge.net>
+
+ * calculus.test: Corrected testing problems by namespace-ifying
+ the file.
+
+2002-04-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * combinatorics.man: Added doctools manpage.
+ * math.man: Added doctools manpage.
+
+2002-03-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * calculus.man: Fixed formatting errors in the doctools manpage.
+
+2002-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Update of calculus. #528434
+
+ * calculus.man: New file, calculus documentation in doctools format.
+ * calculus.test: New file, beginnings of testsuite
+
+ * calculus.CHANGES:
+ * calculus.README:
+ * calculus.tcl:
+ * pkgIndex.tcl: updated to calculus 0.3
+
+2002-02-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * combinatorics.tcl
+ * geometry.tcl (proc): Frink run
+
+ * math::geometry: Version is now 1.0.1 to distinguish this from
+ the code in tcllib release 1.2
+
+ * math: Version is now 1.2.1 to distinguish this from
+ the code in tcllib release 1.2
+
+2002-01-18 Don Porter <dgp@users.sourceforge.net>
+
+ * math.tcl: [namespace export Beta] got out of sync with the
+ command name.
+ * misc.tcl: removed [package provide math]; duplicated in
+ math.tcl, a sync problem waiting to happen.
+
+2002-01-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bumped version to 1.2.
+
+2002-01-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Added calculus functionality and fuzzy FP comparison as provided
+ by Arjen Markus <arjen.markus@wldelft.nl> as is. This code
+ currently has neither true testsuite nor good documentation but
+ was considered important enough to get in now. Polish has to
+ come in the subsequent patch releases.
+
+2002-01-11 Kevin Kenny <kennykb@users.sourceforge.net>
+
+ * combinatorics.tcl: Removed incorrect 'package provide'.
+
+2002-01-11 Kevin Kenny <kennykb@users.sourceforge.net>
+
+ * math.tcl:
+ * misc.tcl:
+ * pkgIndex.tcl:
+ * tclIndex: Reorganized so that math.tcl is a top-level 'package
+ provide' script and loads a tclIndex. The code from 'math.tcl'
+ moves into 'misc.tcl'.
+ * combinatorics.n:
+ * combinatorics.tcl:
+ * combinatorics.test: Added a 'combinatorics' module containing
+ the Gamma function and several related functions (factorial,
+ binomial coefficient, and Beta). (Feature request #484850).
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * math.tcl: Fixed dubious code reported by frink.
+
+2000-10-06 Eric Melski <ericm@ajubasolutions.com>
+
+ * math.test:
+ * math.n:
+ * math.tcl: Added ::math::fibonacci function, to compute numbers
+ in the Fibonacci sequence.
+
+2000-09-08 Eric Melski <ericm@ajubasolutions.com>
+
+ * math.test:
+ * math.n:
+ * math.tcl: Added ::math::random function.
+
+ * pkgIndex.tcl: Bumped version number to 1.1.
+
+2000-06-15 Eric Melski <ericm@scriptics.com>
+
+ * math.n:
+ * math.test:
+ * math.tcl: Incorporated sigma, cov, stats, integrate functions
+ (from Philip Ehrens <pehrens@ligo.caltech.edu>). [RFE: 5060]
+
+2000-03-27 Eric Melski <ericm@scriptics.com>
+
+ * math.n:
+ * math.test:
+ * math.tcl: Added sum, mean, and product functions (from Philip
+ Ehrens <pehrens@ligo.caltech.edu>).
+
+2000-03-09 Eric Melski <ericm@scriptics.com>
+
+ * math.test: Adapted tests for use in/out of tcllib test framework.
+
+2000-03-07 Eric Melski <ericm@scriptics.com>
+
+ * pkgIndex.tcl:
+ * math.tcl:
+ * math.test:
+ * math.n: Initial versions of files for math library.
diff --git a/tcllib/modules/math/TODO b/tcllib/modules/math/TODO
new file mode 100755
index 0000000..ae15a3b
--- /dev/null
+++ b/tcllib/modules/math/TODO
@@ -0,0 +1,35 @@
+This file records outstanding actions for the math module
+
+dd. 26 april 2015, Arjen Markus
+Add:
+- additional linear algebra procedures by Federico Ferri
+- lognormal income library by Eric Benedict
+- empirical distribution
+- tukey-duckworth test
+
+
+
+dd. 18 january 2014, Arjen Markus
+test cases for kernel-density:
+One test case is troublesome - uniform kernel, checking the total density
+
+
+dd. 26 october 2005, Arjen Markus
+
+qcomplex.test: extend the tests for cos/sin .. to include
+ non-real results.
+
+dd. 28 september 2005, Arjen Markus
+
+optimize.tcl: linear programming algorithm ignores certain
+ constraints (of type x > 0). Needs to be
+ fixed
+
+dd. 22 june 2004, Arjen Markus
+
+interpolate.man: add examples
+interpolate.tcl: more consistency in the calling convention
+ checks on arguments (add tests for them)
+optimize.man: example of a parametrized function (also a test case!)
+optimize.tcl: provide an alternative for maximum
+
diff --git a/tcllib/modules/math/bessel.tcl b/tcllib/modules/math/bessel.tcl
new file mode 100755
index 0000000..811f242
--- /dev/null
+++ b/tcllib/modules/math/bessel.tcl
@@ -0,0 +1,194 @@
+# bessel.tcl --
+# Evaluate the most common Bessel functions
+#
+# TODO:
+# Yn - finding decent approximations seems tough
+# Jnu - for arbitrary values of the parameter
+# J'n - first derivative (from recurrence relation)
+# Kn - forward application of recurrence relation?
+#
+
+# namespace special
+# Create a convenient namespace for the "special" mathematical functions
+#
+namespace eval ::math::special {
+ #
+ # Define a number of common mathematical constants
+ #
+ ::math::constants::constants pi
+
+ #
+ # Export the functions
+ #
+ namespace export J0 J1 Jn J1/2 J-1/2 I_n
+}
+
+# J0 --
+# Zeroth-order Bessel function
+#
+# Arguments:
+# x Value of the x-coordinate
+# Result:
+# Value of J0(x)
+#
+proc ::math::special::J0 {x} {
+ Jn 0 $x
+}
+
+# J1 --
+# First-order Bessel function
+#
+# Arguments:
+# x Value of the x-coordinate
+# Result:
+# Value of J1(x)
+#
+proc ::math::special::J1 {x} {
+ Jn 1 $x
+}
+
+# Jn --
+# Compute the Bessel function of the first kind of order n
+# Arguments:
+# n Order of the function (must be integer)
+# x Value of the argument
+# Result:
+# Jn(x)
+# Note:
+# This relies on the integral representation for
+# the Bessel functions of integer order:
+# 1 I pi
+# Jn(x) = -- I cos(x sin t - nt) dt
+# pi 0 I
+#
+# For this kind of integrands the trapezoidal rule is
+# very efficient according to Davis and Rabinowitz
+# (Methods of numerical integration, 1984).
+#
+proc ::math::special::Jn {n x} {
+ variable pi
+
+ if { ![string is integer -strict $n] } {
+ return -code error "Order argument must be integer"
+ }
+
+ #
+ # Integrate over the interval [0,pi] using a small
+ # enough step - 40 points should do a good job
+ # with |x| < 20, n < 20 (an accuracy of 1.0e-8
+ # is reported by Davis and Rabinowitz)
+ #
+ set number 40
+ set step [expr {$pi/double($number)}]
+ set result 0.0
+
+ for { set i 0 } { $i <= $number } { incr i } {
+ set t [expr {double($i)*$step}]
+ set f [expr {cos($x * sin($t) - $n * $t)}]
+ if { $i == 0 || $i == $number } {
+ set f [expr {$f/2.0}]
+ }
+ set result [expr {$result+$f}]
+ }
+
+ expr {$result*$step/$pi}
+}
+
+# J1/2 --
+# Half-order Bessel function
+#
+# Arguments:
+# x Value of the x-coordinate
+# Result:
+# Value of J1/2(x)
+#
+proc ::math::special::J1/2 {x} {
+ variable pi
+ #
+ # This Bessel function can be expressed in terms of elementary
+ # functions. Therefore use the explicit formula
+ #
+ if { $x != 0.0 } {
+ expr {sqrt(2.0/$pi/$x)*sin($x)}
+ } else {
+ return 0.0
+ }
+}
+
+# J-1/2 --
+# Compute the Bessel function of the first kind of order -1/2
+# Arguments:
+# x Value of the argument (!= 0.0)
+# Result:
+# J-1/2(x)
+#
+proc ::math::special::J-1/2 {x} {
+ variable pi
+ if { $x == 0.0 } {
+ return -code error "Argument must not be zero (singularity)"
+ } else {
+ return [expr {-cos($x)/sqrt($pi*$x/2.0)}]
+ }
+}
+
+# I_n --
+# Compute the modified Bessel function of the first kind
+#
+# Arguments:
+# n Order of the function (must be positive integer or zero)
+# x Abscissa at which to compute it
+# Result:
+# Value of In(x)
+# Note:
+# This relies on Miller's algorithm for finding minimal solutions
+#
+namespace eval ::math::special {}
+
+proc ::math::special::I_n {n x} {
+ if { ! [string is integer $n] || $n < 0 } {
+ error "Wrong order: must be positive integer or zero"
+ }
+
+ set n2 [expr {$n+8}] ;# Note: just a guess that this will be enough
+
+ set ynp1 0.0
+ set yn 1.0
+ set sum 1.0
+
+ while { $n2 > 0 } {
+ set ynm1 [expr {$ynp1+2.0*$n2*$yn/$x}]
+ set sum [expr {$sum+$ynm1}]
+ if { $n2 == $n+1 } {
+ set result $ynm1
+ }
+ set ynp1 $yn
+ set yn $ynm1
+ incr n2 -1
+ }
+
+ set quotient [expr {(2.0*$sum-$ynm1)/exp($x)}]
+
+ expr {$result/$quotient}
+}
+
+#
+# some tests --
+#
+if { 0 } {
+set prec $::tcl_precision
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ set ::tcl_precision 17
+} else {
+ set ::tcl_precision 0
+}
+
+foreach x {0.0 2.0 4.4 6.0 10.0 11.0 12.0 13.0 14.0} {
+ puts "J0($x) = [::math::special::J0 $x] - J1($x) = [::math::special::J1 $x] \
+- J1/2($x) = [::math::special::J1/2 $x]"
+}
+foreach n {0 1 2 3 4 5} {
+ puts [::math::special::I_n $n 1.0]
+}
+
+set ::tcl_precision $prec
+}
diff --git a/tcllib/modules/math/bessel.test b/tcllib/modules/math/bessel.test
new file mode 100755
index 0000000..f70768a
--- /dev/null
+++ b/tcllib/modules/math/bessel.test
@@ -0,0 +1,81 @@
+# -*- tcl -*-
+# Tests for special (Bessel) functions in math library -*- tcl -*-
+#
+# This file contains a collection of tests for one or more of the Tcllib
+# procedures. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# $Id: bessel.test,v 1.15 2007/08/21 17:33:00 andreas_kupries Exp $
+#
+# Copyright (c) 2004 by Arjen Markus
+# All rights reserved.
+#
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4;# statistics,linalg!
+testsNeedTcltest 2.1
+
+support {
+ useLocal math.tcl math
+ useLocal constants.tcl math::constants
+ useLocal linalg.tcl math::linearalgebra ;# for statistics
+ useLocal statistics.tcl math::statistics
+}
+testing {
+ useLocal special.tcl math::special
+}
+
+# -------------------------------------------------------------------------
+
+#
+# As the values were given with four digits, an absolute
+# error is most appropriate
+#
+proc matchNumbers {expected actual} {
+ set match 1
+ foreach a $actual e $expected {
+ if {abs($a-$e) > 0.1e-4} {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+
+customMatch numbers matchNumbers
+
+# -------------------------------------------------------------------------
+
+test "Bessel-1.0" "Values of the zeroth-order Bessel function" \
+ -match numbers -body {
+ set result {}
+ foreach x {0.0 1.0 2.0 5.0 7.0 10.0 11.0 14.0} {
+ lappend result [::math::special::J0 $x]
+ }
+ set result
+} -result {1.0 0.765198 0.223891 -0.177597 0.300079 -0.245936 -0.171190 0.171073}
+
+test "Bessel-1.1" "Values of the first-order Bessel function" \
+ -match numbers -body {
+ set result {}
+ foreach x {0.0 1.0 2.0 5.0 7.0 10.0 11.0 14.0} {
+ lappend result [::math::special::J1 $x]
+ }
+ set result
+} -result {0.0 0.440050 0.576725 -0.327579 -0.004683 0.043473 -0.176785 0.133375}
+
+#
+# No tests for J1/2 yet
+#
+
+#
+# No tests for I_n yet
+#
+
+# End of test cases
+testsuiteCleanup
diff --git a/tcllib/modules/math/bigfloat.man b/tcllib/modules/math/bigfloat.man
new file mode 100755
index 0000000..13113b2
--- /dev/null
+++ b/tcllib/modules/math/bigfloat.man
@@ -0,0 +1,432 @@
+[manpage_begin math::bigfloat n 2.0.1]
+[keywords computations]
+[keywords floating-point]
+[keywords interval]
+[keywords math]
+[keywords multiprecision]
+[keywords tcl]
+[copyright {2004-2008, by Stephane Arnold <stephanearnold at yahoo dot fr>}]
+[moddesc {Tcl Math Library}]
+[titledesc {Arbitrary precision floating-point numbers}]
+[category Mathematics]
+[require Tcl 8.5]
+[require math::bigfloat [opt 2.0.1]]
+
+[description]
+
+The bigfloat package provides arbitrary precision floating-point math
+capabilities to the Tcl language. It is designed to work with Tcl 8.5,
+but for Tcl 8.4 is provided an earlier version of this package.
+See [sectref "WHAT ABOUT TCL 8.4 ?"] for more explanations.
+By convention, we will talk about the numbers treated in this library as :
+[list_begin itemized]
+[item]BigFloat for floating-point numbers of arbitrary length.
+[item]integers for arbitrary length signed integers, just as basic integers since Tcl 8.5.
+[list_end]
+Each BigFloat is an interval, namely [lb][emph "m-d, m+d"][rb],
+where [emph m] is the mantissa and [emph d] the uncertainty, representing the
+limitation of that number's precision.
+This is why we call such mathematics [emph "interval computations"].
+Just take an example in physics : when you measure a temperature, not all
+digits you read are [emph significant]. Sometimes you just cannot trust all digits - not to mention if doubles (f.p. numbers) can handle all these digits.
+BigFloat can handle this problem - trusting the digits you get - plus the ability to store numbers with an arbitrary precision.
+
+BigFloats are internally represented at Tcl lists: this
+package provides a set of procedures operating against
+the internal representation in order to :
+[list_begin itemized]
+[item]
+perform math operations on BigFloats and (optionnaly) with integers.
+
+[item]
+convert BigFloats from their internal representations to strings, and vice versa.
+
+[list_end]
+
+[section "INTRODUCTION"]
+[list_begin definitions]
+
+[call [cmd fromstr] [arg number] [opt [arg trailingZeros]]]
+Converts [emph number] into a BigFloat. Its precision
+is at least the number of digits provided by [emph number].
+If the [arg number] contains only digits and eventually a minus sign, it is considered as
+an integer. Subsequently, no conversion is done at all.
+[para]
+[arg trailingZeros] - the number of zeros to append at the end of the floating-point number
+to get more precision. It cannot be applied to an integer.
+
+[example_begin]
+# x and y are BigFloats : the first string contained a dot, and the second an e sign
+set x [lb]fromstr -1.000000[rb]
+set y [lb]fromstr 2000e30[rb]
+# let's see how we get integers
+set t 20000000000000
+# the old way (package 1.2) is still supported for backwards compatibility :
+set m [lb]fromstr 10000000000[rb]
+# but we do not need fromstr for integers anymore
+set n -39
+# t, m and n are integers
+[example_end]
+[para]
+The [emph number]'s last digit is considered by the procedure to be true at +/-1,
+For example, 1.00 is the interval [lb]0.99, 1.01[rb],
+and 0.43 the interval [lb]0.42, 0.44[rb].
+The Pi constant may be approximated by the number "3.1415".
+This string could be considered as the interval [lb]3.1414 , 3.1416[rb] by [cmd fromstr].
+So, when you mean 1.0 as a double, you may have to write 1.000000 to get enough precision.
+To learn more about this subject, see [sectref PRECISION].
+[para]
+For example :
+[example_begin]
+set x [lb]fromstr 1.0000000000[rb]
+# the next line does the same, but smarter
+set y [lb]fromstr 1. 10[rb]
+[example_end]
+
+[call [cmd tostr] [opt [option -nosci]] [arg number]]
+Returns a string form of a BigFloat, in which all digits are exacts.
+[emph "All exact digits"] means a rounding may occur, for example to zero,
+if the uncertainty interval does not clearly show the true digits.
+[emph number] may be an integer, causing the command to return exactly the input argument.
+With the [option -nosci] option, the number returned is never shown in scientific
+notation, i.e. not like '3.4523e+5' but like '345230.'.
+[example_begin]
+puts [lb]tostr [lb]fromstr 0.99999[rb][rb] ;# 1.0000
+puts [lb]tostr [lb]fromstr 1.00001[rb][rb] ;# 1.0000
+puts [lb]tostr [lb]fromstr 0.002[rb][rb] ;# 0.e-2
+[example_end]
+See [sectref PRECISION] for that matter.
+
+See also [cmd iszero] for how to detect zeros, which is useful when performing a division.
+
+[call [cmd fromdouble] [arg double] [opt [arg decimals]]]
+
+Converts a double (a simple floating-point value) to a BigFloat, with
+exactly [arg decimals] digits. Without the [arg decimals] argument,
+it behaves like [cmd fromstr].
+Here, the only important feature you might care of is the ability
+to create BigFloats with a fixed number of [arg decimals].
+
+[example_begin]
+tostr [lb]fromstr 1.111 4[rb]
+# returns : 1.111000 (3 zeros)
+tostr [lb]fromdouble 1.111 4[rb]
+# returns : 1.111
+[example_end]
+
+[call [cmd todouble] [arg number]]
+Returns a double, that may be used in [emph expr],
+from a BigFloat.
+
+[call [cmd isInt] [arg number]]
+Returns 1 if [emph number] is an integer, 0 otherwise.
+
+[call [cmd isFloat] [arg number]]
+Returns 1 if [emph number] is a BigFloat, 0 otherwise.
+
+[call [cmd int2float] [arg integer] [opt [arg decimals]]]
+Converts an integer to a BigFloat with [emph decimals] trailing zeros.
+The default, and minimal, number of [emph decimals] is 1.
+When converting back to string, one decimal is lost:
+[example_begin]
+set n 10
+set x [lb]int2float $n[rb]; # like fromstr 10.0
+puts [lb]tostr $x[rb]; # prints "10."
+set x [lb]int2float $n 3[rb]; # like fromstr 10.000
+puts [lb]tostr $x[rb]; # prints "10.00"
+[example_end]
+
+[list_end]
+
+[section "ARITHMETICS"]
+[list_begin definitions]
+
+[call [cmd add] [arg x] [arg y]]
+[call [cmd sub] [arg x] [arg y]]
+[call [cmd mul] [arg x] [arg y]]
+Return the sum, difference and product of [emph x] by [emph y].
+[arg x] - may be either a BigFloat or an integer
+[arg y] - may be either a BigFloat or an integer
+When both are integers, these commands behave like [cmd expr].
+
+[call [cmd div] [arg x] [arg y]]
+[call [cmd mod] [arg x] [arg y]]
+Return the quotient and the rest of [emph x] divided by [emph y].
+Each argument ([emph x] and [emph y]) can be either a BigFloat or an integer,
+but you cannot divide an integer by a BigFloat
+Divide by zero throws an error.
+
+[call [cmd abs] [arg x]]
+Returns the absolute value of [emph x]
+
+[call [cmd opp] [arg x]]
+Returns the opposite of [emph x]
+
+[call [cmd pow] [arg x] [arg n]]
+Returns [emph x] taken to the [emph n]th power.
+It only works if [emph n] is an integer.
+[emph x] might be a BigFloat or an integer.
+
+[list_end]
+
+[section COMPARISONS]
+[list_begin definitions]
+[call [cmd iszero] [arg x]]
+
+Returns 1 if [emph x] is :
+[list_begin itemized]
+[item]a BigFloat close enough to zero to raise "divide by zero".
+[item]the integer 0.
+[list_end]
+See here how numbers that are close to zero are converted to strings:
+[example_begin]
+tostr [lb]fromstr 0.001[rb] ; # -> 0.e-2
+tostr [lb]fromstr 0.000000[rb] ; # -> 0.e-5
+tostr [lb]fromstr -0.000001[rb] ; # -> 0.e-5
+tostr [lb]fromstr 0.0[rb] ; # -> 0.
+tostr [lb]fromstr 0.002[rb] ; # -> 0.e-2
+
+set a [lb]fromstr 0.002[rb] ; # uncertainty interval : 0.001, 0.003
+tostr $a ; # 0.e-2
+iszero $a ; # false
+
+set a [lb]fromstr 0.001[rb] ; # uncertainty interval : 0.000, 0.002
+tostr $a ; # 0.e-2
+iszero $a ; # true
+[example_end]
+
+[call [cmd equal] [arg x] [arg y]]
+
+Returns 1 if [emph x] and [emph y] are equal, 0 elsewhere.
+
+[call [cmd compare] [arg x] [arg y]]
+
+Returns 0 if both BigFloat arguments are equal,
+1 if [emph x] is greater than [emph y],
+and -1 if [emph x] is lower than [emph y].
+You would not be able to compare an integer to a BigFloat :
+the operands should be both BigFloats, or both integers.
+
+[list_end]
+
+[section ANALYSIS]
+[list_begin definitions]
+[call [cmd sqrt] [arg x]]
+[call [cmd log] [arg x]]
+[call [cmd exp] [arg x]]
+[call [cmd cos] [arg x]]
+[call [cmd sin] [arg x]]
+[call [cmd tan] [arg x]]
+[call [cmd cotan] [arg x]]
+[call [cmd acos] [arg x]]
+[call [cmd asin] [arg x]]
+[call [cmd atan] [arg x]]
+[call [cmd cosh] [arg x]]
+[call [cmd sinh] [arg x]]
+[call [cmd tanh] [arg x]]
+
+The above functions return, respectively, the following :
+square root, logarithm, exponential, cosine, sine,
+tangent, cotangent, arc cosine, arc sine, arc tangent, hyperbolic
+cosine, hyperbolic sine, hyperbolic tangent, of a BigFloat named [emph x].
+
+[call [cmd pi] [arg n]]
+Returns a BigFloat representing the Pi constant with [emph n] digits after the dot.
+[emph n] is a positive integer.
+
+[call [cmd rad2deg] [arg radians]]
+[call [cmd deg2rad] [arg degrees]]
+[arg radians] - angle expressed in radians (BigFloat)
+[para]
+[arg degrees] - angle expressed in degrees (BigFloat)
+[para]
+Convert an angle from radians to degrees, and [emph "vice versa"].
+
+[list_end]
+
+[section ROUNDING]
+[list_begin definitions]
+[call [cmd round] [arg x]]
+[call [cmd ceil] [arg x]]
+[call [cmd floor] [arg x]]
+
+The above functions return the [emph x] BigFloat,
+rounded like with the same mathematical function in [emph expr],
+and returns it as an integer.
+[list_end]
+
+[section PRECISION]
+
+How do conversions work with precision ?
+
+[list_begin itemized]
+[item] When a BigFloat is converted from string, the internal representation
+holds its uncertainty as 1 at the level of the last digit.
+[item] During computations, the uncertainty of each result
+is internally computed the closest to the reality, thus saving the memory used.
+[item] When converting back to string, the digits that are printed
+are not subject to uncertainty. However, some rounding is done, as not doing so
+causes severe problems.
+[list_end]
+Uncertainties are kept in the internal representation of the number ;
+it is recommended to use [cmd tostr] only for outputting data (on the screen or in a file),
+and NEVER call [cmd fromstr] with the result of [cmd tostr].
+It is better to always keep operands in their internal representation.
+Due to the internals of this library, the uncertainty interval may be slightly
+wider than expected, but this should not cause false digits.
+[para]
+
+Now you may ask this question : What precision am I going to get
+after calling add, sub, mul or div?
+First you set a number from the string representation and,
+by the way, its uncertainty is set:
+[example_begin]
+set a [lb]fromstr 1.230[rb]
+# $a belongs to [lb]1.229, 1.231[rb]
+set a [lb]fromstr 1.000[rb]
+# $a belongs to [lb]0.999, 1.001[rb]
+# $a has a relative uncertainty of 0.1% : 0.001(the uncertainty)/1.000(the medium value)
+[example_end]
+The uncertainty of the sum, or the difference, of two numbers, is the sum
+of their respective uncertainties.
+
+[example_begin]
+set a [lb]fromstr 1.230[rb]
+set b [lb]fromstr 2.340[rb]
+set sum [lb]add $a $b[rb][rb]
+# the result is : [lb]3.568, 3.572[rb] (the last digit is known with an uncertainty of 2)
+tostr $sum ; # 3.57
+[example_end]
+But when, for example, we add or substract an integer to a BigFloat,
+the relative uncertainty of the result is unchanged. So it is desirable
+not to convert integers to BigFloats:
+
+[example_begin]
+set a [lb]fromstr 0.999999999[rb]
+# now something dangerous
+set b [lb]fromstr 2.000[rb]
+# the result has only 3 digits
+tostr [lb]add $a $b[rb]
+
+# how to keep precision at its maximum
+puts [lb]tostr [lb]add $a 2[rb][rb]
+[example_end]
+[para]
+
+For multiplication and division, the relative uncertainties of the product
+or the quotient, is the sum of the relative uncertainties of the operands.
+Take care of division by zero : check each divider with [cmd iszero].
+
+[example_begin]
+set num [lb]fromstr 4.00[rb]
+set denom [lb]fromstr 0.01[rb]
+
+puts [lb]iszero $denom[rb];# true
+set quotient [lb]div $num $denom[rb];# error : divide by zero
+
+# opposites of our operands
+puts [lb]compare $num [lb]opp $num[rb][rb]; # 1
+puts [lb]compare $denom [lb]opp $denom[rb][rb]; # 0 !!!
+# No suprise ! 0 and its opposite are the same...
+[example_end]
+
+Effects of the precision of a number considered equal to zero
+to the cos function:
+[example_begin]
+puts [lb]tostr [lb]cos [lb]fromstr 0. 10[rb][rb][rb]; # -> 1.000000000
+puts [lb]tostr [lb]cos [lb]fromstr 0. 5[rb][rb][rb]; # -> 1.0000
+puts [lb]tostr [lb]cos [lb]fromstr 0e-10[rb][rb][rb]; # -> 1.000000000
+puts [lb]tostr [lb]cos [lb]fromstr 1e-10[rb][rb][rb]; # -> 1.000000000
+[example_end]
+
+BigFloats with different internal representations may be converted
+to the same string.
+
+[para]
+
+For most analysis functions (cosine, square root, logarithm, etc.), determining the precision
+of the result is difficult.
+It seems however that in many cases, the loss of precision in the result
+is of one or two digits.
+There are some exceptions : for example,
+[example_begin]
+tostr [lb]exp [lb]fromstr 100.0 10[rb][rb]
+# returns : 2.688117142e+43 which has only 10 digits of precision, although the entry
+# has 14 digits of precision.
+[example_end]
+
+[section "WHAT ABOUT TCL 8.4 ?"]
+If your setup do not provide Tcl 8.5 but supports 8.4, the package can still be loaded,
+switching back to [emph math::bigfloat] 1.2. Indeed, an important function introduced in Tcl 8.5
+is required - the ability to handle bignums, that we can do with [cmd expr].
+Before 8.5, this ability was provided by several packages,
+including the pure-Tcl [emph math::bignum] package provided by [emph tcllib].
+In this case, all you need to know, is that arguments to the commands explained here,
+are expected to be in their internal representation.
+So even with integers, you will need to call [cmd fromstr]
+and [cmd tostr] in order to convert them between string and internal representations.
+[example_begin]
+#
+# with Tcl 8.5
+# ============
+set a [lb]pi 20[rb]
+# round returns an integer and 'everything is a string' applies to integers
+# whatever big they are
+puts [lb]round [lb]mul $a 10000000000[rb][rb]
+#
+# the same with Tcl 8.4
+# =====================
+set a [lb]pi 20[rb]
+# bignums (arbitrary length integers) need a conversion hook
+set b [lb]fromstr 10000000000[rb]
+# round returns a bignum:
+# before printing it, we need to convert it with 'tostr'
+puts [lb]tostr [lb]round [lb]mul $a $b[rb][rb][rb]
+[example_end]
+[section "NAMESPACES AND OTHER PACKAGES"]
+We have not yet discussed about namespaces
+because we assumed that you had imported public commands into the global namespace,
+like this:
+[example_begin]
+namespace import ::math::bigfloat::*
+[example_end]
+If you matter much about avoiding names conflicts,
+I considere it should be resolved by the following :
+[example_begin]
+package require math::bigfloat
+# beware: namespace ensembles are not available in Tcl 8.4
+namespace eval ::math::bigfloat {namespace ensemble create -command ::bigfloat}
+# from now, the bigfloat command takes as subcommands all original math::bigfloat::* commands
+set a [lb]bigfloat sub [lb]bigfloat fromstr 2.000[rb] [lb]bigfloat fromstr 0.530[rb][rb]
+puts [lb]bigfloat tostr $a[rb]
+[example_end]
+[section "EXAMPLES"]
+Guess what happens when you are doing some astronomy. Here is an example :
+[example_begin]
+# convert acurrate angles with a millisecond-rated accuracy
+proc degree-angle {degrees minutes seconds milliseconds} {
+ set result 0
+ set div 1
+ foreach factor {1 1000 60 60} var [lb]list $milliseconds $seconds $minutes $degrees[rb] {
+ # we convert each entry var into milliseconds
+ set div [lb]expr {$div*$factor}[rb]
+ incr result [lb]expr {$var*$div}[rb]
+ }
+ return [lb]div [lb]int2float $result[rb] $div[rb]
+}
+# load the package
+package require math::bigfloat
+namespace import ::math::bigfloat::*
+# work with angles : a standard formula for navigation (taking bearings)
+set angle1 [lb]deg2rad [lb]degree-angle 20 30 40 0[rb][rb]
+set angle2 [lb]deg2rad [lb]degree-angle 21 0 50 500[rb][rb]
+set opposite3 [lb]deg2rad [lb]degree-angle 51 0 50 500[rb][rb]
+set sinProduct [lb]mul [lb]sin $angle1[rb] [lb]sin $angle2[rb][rb]
+set cosProduct [lb]mul [lb]cos $angle1[rb] [lb]cos $angle2[rb][rb]
+set angle3 [lb]asin [lb]add [lb]mul $sinProduct [lb]cos $opposite3[rb][rb] $cosProduct[rb][rb]
+puts "angle3 : [lb]tostr [lb]rad2deg $angle3[rb][rb]"
+[example_end]
+
+[vset CATEGORY {math :: bignum :: float}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/bigfloat.tcl b/tcllib/modules/math/bigfloat.tcl
new file mode 100755
index 0000000..a86f339
--- /dev/null
+++ b/tcllib/modules/math/bigfloat.tcl
@@ -0,0 +1,2316 @@
+########################################################################
+# BigFloat for Tcl
+# Copyright (C) 2003-2005 ARNOLD Stephane
+#
+# BIGFLOAT LICENSE TERMS
+#
+# This software is copyrighted by Stephane ARNOLD, (stephanearnold <at> yahoo.fr).
+# The following terms apply to all files associated
+# with the software unless explicitly disclaimed in individual files.
+#
+# The authors hereby grant permission to use, copy, modify, distribute,
+# and license this software and its documentation for any purpose, provided
+# that existing copyright notices are retained in all copies and that this
+# notice is included verbatim in any distributions. No written agreement,
+# license, or royalty fee is required for any of the authorized uses.
+# Modifications to this software may be copyrighted by their authors
+# and need not follow the licensing terms described here, provided that
+# the new terms are clearly indicated on the first page of each file where
+# they apply.
+#
+# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+#
+# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+# MODIFICATIONS.
+#
+# GOVERNMENT USE: If you are acquiring this software on behalf of the
+# U.S. government, the Government shall have only "Restricted Rights"
+# in the software and related documentation as defined in the Federal
+# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
+# are acquiring the software on behalf of the Department of Defense, the
+# software shall be classified as "Commercial Computer Software" and the
+# Government shall have only "Restricted Rights" as defined in Clause
+# 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
+# authors grant the U.S. Government and others acting in its behalf
+# permission to use and distribute the software in accordance with the
+# terms specified in this license.
+#
+########################################################################
+
+package require Tcl 8.4
+package require math::bignum
+
+# this line helps when I want to source this file again and again
+catch {namespace delete ::math::bigfloat}
+
+# private namespace
+# this software works only with Tcl v8.4 and higher
+# it is using the package math::bignum
+namespace eval ::math::bigfloat {
+ # cached constants
+ # ln(2) with arbitrary precision
+ variable Log2
+ # Pi with arb. precision
+ variable Pi
+ variable _pi0
+ # some constants (bignums) : {0 1 2 3 4 5 10}
+ variable zero
+ set zero [::math::bignum::fromstr 0]
+ variable one
+ set one [::math::bignum::fromstr 1]
+ variable two
+ set two [::math::bignum::fromstr 2]
+ variable three
+ set three [::math::bignum::fromstr 3]
+ variable four
+ set four [::math::bignum::fromstr 4]
+ variable five
+ set five [::math::bignum::fromstr 5]
+ variable ten
+ set ten [::math::bignum::fromstr 10]
+}
+
+
+
+
+################################################################################
+# procedures that handle floating-point numbers
+# these procedures are sorted by name (after eventually removing the underscores)
+#
+# BigFloats are internally represented as a list :
+# {"F" Mantissa Exponent Delta} where "F" is a character which determins
+# the datatype, Mantissa and Delta are two Big integers and Exponent a raw integer.
+#
+# The BigFloat value equals to (Mantissa +/- Delta)*2^Exponent
+# So the internal representation is binary, but trying to get as close as possible to
+# the decimal one.
+# When calling fromstr, the Delta parameter is set to the value of the last decimal digit.
+# Example : 1.50 belongs to [1.49,1.51], but internally Delta is probably not equal to 1,
+# because of the binary representation.
+#
+# So Mantissa and Delta are not limited in size, but in practice Delta is kept under
+# 2^32 by the 'normalize' procedure, to avoid a never-ended growth of memory used.
+# Indeed, when you perform some computations, the Delta parameter (which represent
+# the uncertainty on the value of the Mantissa) may increase.
+# Exponent, as a classic integer, is limited to the interval [-2147483648,2147483647]
+
+# Retrieving the parameters of a BigFloat is often done with that command :
+# foreach {dummy int exp delta} $bigfloat {break}
+# (dummy is not used, it is just used to get the "F" marker).
+# The isInt, isFloat, checkNumber and checkFloat procedures are used
+# to check data types
+#
+# Taylor development are often used to compute the analysis functions (like exp(),log()...)
+# To learn how it is done in practice, take a look at ::math::bigfloat::_asin
+# While doing computation on Mantissas, we do not care about the last digit,
+# because if we compute wisely Deltas, the digits that remain will be exact.
+################################################################################
+
+
+################################################################################
+# returns the absolute value
+################################################################################
+proc ::math::bigfloat::abs {number} {
+ checkNumber number
+ if {[isInt $number]} {
+ # set sign to positive for a BigInt
+ return [::math::bignum::abs $number]
+ }
+ # set sign to positive for a BigFloat into the Mantissa (index 1)
+ lset number 1 [::math::bignum::abs [lindex $number 1]]
+ return $number
+}
+
+
+################################################################################
+# arccosinus of a BigFloat
+################################################################################
+proc ::math::bigfloat::acos {x} {
+ # handy proc for checking datatype
+ checkFloat x
+ foreach {dummy entier exp delta} $x {break}
+ set precision [expr {($exp<0)?(-$exp):1}]
+ # acos(0.0)=Pi/2
+ # 26/07/2005 : changed precision from decimal to binary
+ # with the second parameter of pi command
+ set piOverTwo [floatRShift [pi $precision 1]]
+ if {[iszero $x]} {
+ # $x is too close to zero -> acos(0)=PI/2
+ return $piOverTwo
+ }
+ # acos(-x)= Pi/2 + asin(x)
+ if {[::math::bignum::sign $entier]} {
+ return [add $piOverTwo [asin [abs $x]]]
+ }
+ # we always use _asin to compute the result
+ # but as it is a Taylor development, the value given to [_asin]
+ # has to be a bit smaller than 1 ; by using that trick : acos(x)=asin(sqrt(1-x^2))
+ # we can limit the entry of the Taylor development below 1/sqrt(2)
+ if {[compare $x [fromstr 0.7071]]>0} {
+ # x > sqrt(2)/2 : trying to make _asin converge quickly
+ # creating 0 and 1 with the same precision as the entry
+ variable one
+ variable zero
+ set fzero [list F $zero -$precision $one]
+ set fone [list F [::math::bignum::lshift 1 $precision] \
+ -$precision $one]
+ # when $x is close to 1 (acos(1.0)=0.0)
+ if {[equal $fone $x]} {
+ return $fzero
+ }
+ if {[compare $fone $x]<0} {
+ # the behavior assumed because acos(x) is not defined
+ # when |x|>1
+ error "acos on a number greater than 1"
+ }
+ # acos(x) = asin(sqrt(1 - x^2))
+ # since 1 - cos(x)^2 = sin(x)^2
+ # x> sqrt(2)/2 so x^2 > 1/2 so 1-x^2<1/2
+ set x [sqrt [sub $fone [mul $x $x]]]
+ # the parameter named x is smaller than sqrt(2)/2
+ return [_asin $x]
+ }
+ # acos(x) = Pi/2 - asin(x)
+ # x<sqrt(2)/2 here too
+ return [sub $piOverTwo [_asin $x]]
+}
+
+
+################################################################################
+# returns A + B
+################################################################################
+proc ::math::bigfloat::add {a b} {
+ checkNumber a b
+ if {[isInt $a]} {
+ if {[isInt $b]} {
+ # intAdd adds two BigInts
+ return [::math::bignum::add $a $b]
+ }
+ # adds the BigInt a to the BigFloat b
+ return [addInt2Float $b $a]
+ }
+ if {[isInt $b]} {
+ # ... and vice-versa
+ return [addInt2Float $a $b]
+ }
+ # retrieving parameters from A and B
+ foreach {dummy integerA expA deltaA} $a {break}
+ foreach {dummy integerB expB deltaB} $b {break}
+ # when we add two numbers which have different digit numbers (after the dot)
+ # for example : 1.0 and 0.00001
+ # We promote the one with the less number of digits (1.0) to the same level as
+ # the other : so 1.00000.
+ # that is why we shift left the number which has the greater exponent
+ # But we do not forget the Delta parameter, which is lshift'ed too.
+ if {$expA>$expB} {
+ set diff [expr {$expA-$expB}]
+ set integerA [::math::bignum::lshift $integerA $diff]
+ set deltaA [::math::bignum::lshift $deltaA $diff]
+ set integerA [::math::bignum::add $integerA $integerB]
+ set deltaA [::math::bignum::add $deltaA $deltaB]
+ return [normalize [list F $integerA $expB $deltaA]]
+ } elseif {$expA==$expB} {
+ # nothing to shift left
+ return [normalize [list F [::math::bignum::add $integerA $integerB] \
+ $expA [::math::bignum::add $deltaA $deltaB]]]
+ } else {
+ set diff [expr {$expB-$expA}]
+ set integerB [::math::bignum::lshift $integerB $diff]
+ set deltaB [::math::bignum::lshift $deltaB $diff]
+ set integerB [::math::bignum::add $integerA $integerB]
+ set deltaB [::math::bignum::add $deltaB $deltaA]
+ return [normalize [list F $integerB $expA $deltaB]]
+ }
+}
+
+################################################################################
+# returns the sum A(BigFloat) + B(BigInt)
+# the greatest advantage of this method is that the uncertainty
+# of the result remains unchanged, in respect to the entry's uncertainty (deltaA)
+################################################################################
+proc ::math::bigfloat::addInt2Float {a b} {
+ # type checking
+ checkFloat a
+ if {![isInt $b]} {
+ error "'$b' is not a BigInt"
+ }
+ # retrieving data from $a
+ foreach {dummy integerA expA deltaA} $a {break}
+ # to add an int to a BigFloat,...
+ if {$expA>0} {
+ # we have to put the integer integerA
+ # to the level of zero exponent : 1e8 --> 100000000e0
+ set shift $expA
+ set integerA [::math::bignum::lshift $integerA $shift]
+ set deltaA [::math::bignum::lshift $deltaA $shift]
+ set integerA [::math::bignum::add $integerA $b]
+ # we have to normalize, because we have shifted the mantissa
+ # and the uncertainty left
+ return [normalize [list F $integerA 0 $deltaA]]
+ } elseif {$expA==0} {
+ # integerA is already at integer level : float=(integerA)e0
+ return [normalize [list F [::math::bignum::add $integerA $b] \
+ 0 $deltaA]]
+ } else {
+ # here we have something like 234e-2 + 3
+ # we have to shift the integer left by the exponent |$expA|
+ set b [::math::bignum::lshift $b [expr {-$expA}]]
+ set integerA [::math::bignum::add $integerA $b]
+ return [normalize [list F $integerA $expA $deltaA]]
+ }
+}
+
+
+################################################################################
+# arcsinus of a BigFloat
+################################################################################
+proc ::math::bigfloat::asin {x} {
+ # type checking
+ checkFloat x
+ foreach {dummy entier exp delta} $x {break}
+ if {$exp>-1} {
+ error "not enough precision on input (asin)"
+ }
+ set precision [expr {-$exp}]
+ # when x=0, return 0 at the same precision as the input was
+ if {[iszero $x]} {
+ variable one
+ variable zero
+ return [list F $zero -$precision $one]
+ }
+ # asin(-x)=-asin(x)
+ if {[::math::bignum::sign $entier]} {
+ return [opp [asin [abs $x]]]
+ }
+ # 26/07/2005 : changed precision from decimal to binary
+ set piOverTwo [floatRShift [pi $precision 1]]
+ # now a little trick : asin(x)=Pi/2-asin(sqrt(1-x^2))
+ # so we can limit the entry of the Taylor development
+ # to 1/sqrt(2)~0.7071
+ # the comparison is : if x>0.7071 then ...
+ if {[compare $x [fromstr 0.7071]]>0} {
+ variable one
+ set fone [list F [::math::bignum::lshift 1 $precision] \
+ -$precision $one]
+ # asin(1)=Pi/2 (with the same precision as the entry has)
+ if {[equal $fone $x]} {
+ return $piOverTwo
+ }
+ if {[compare $x $fone]>0} {
+ error "asin on a number greater than 1"
+ }
+ # asin(x)=Pi/2-asin(sqrt(1-x^2))
+ set x [sqrt [sub $fone [mul $x $x]]]
+ return [sub $piOverTwo [_asin $x]]
+ }
+ return [normalize [_asin $x]]
+}
+
+################################################################################
+# _asin : arcsinus of numbers between 0 and +1
+################################################################################
+proc ::math::bigfloat::_asin {x} {
+ # Taylor development
+ # asin(x)=x + 1/2 x^3/3 + 3/2.4 x^5/5 + 3.5/2.4.6 x^7/7 + ...
+ # into this iterative form :
+ # asin(x)=x * (1 + 1/2 * x^2 * (1/3 + 3/4 *x^2 * (...
+ # ...* (1/(2n-1) + (2n-1)/2n * x^2 / (2n+1))...)))
+ # we show how is really computed the development :
+ # we don't need to set a var with x^n or a product of integers
+ # all we need is : x^2, 2n-1, 2n, 2n+1 and a few variables
+ foreach {dummy mantissa exp delta} $x {break}
+ set precision [expr {-$exp}]
+ if {$precision+1<[::math::bignum::bits $mantissa]} {
+ error "sinus greater than 1"
+ }
+ # precision is the number of after-dot digits
+ set result $mantissa
+ set delta_final $delta
+ # resultat is the final result, and delta_final
+ # will contain the uncertainty of the result
+ # square is the square of the mantissa
+ set square [intMulShift $mantissa $mantissa $precision]
+ # dt is the uncertainty of Mantissa
+ set dt [::math::bignum::add 1 [intMulShift $mantissa $delta [expr {$precision-1}]]]
+ # these three are required to compute the fractions implicated into
+ # the development (of Taylor, see former)
+ variable one
+ set num $one
+ # two will be used into the loop
+ variable two
+ variable three
+ set i $three
+ set denom $two
+ # the nth factor equals : $num/$denom* $mantissa/$i
+ set delta [::math::bignum::add [::math::bignum::mul $delta $square] \
+ [::math::bignum::mul $dt [::math::bignum::add $delta $mantissa]]]
+ set delta [::math::bignum::add 1 [::math::bignum::rshift [::math::bignum::div \
+ [::math::bignum::mul $delta $num] $denom] $precision]]
+ # we do not multiply the Mantissa by $num right now because it is 1 !
+ # but we have Mantissa=$x
+ # and we want Mantissa*$x^2 * $num / $denom / $i
+ set mantissa [intMulShift $mantissa $square $precision]
+ set mantissa [::math::bignum::div $mantissa $denom]
+ # do not forget the modified Taylor development :
+ # asin(x)=x * (1 + 1/2*x^2*(1/3 + 3/4*x^2*(...*(1/(2n-1) + (2n-1)/2n*x^2/(2n+1))...)))
+ # all we need is : x^2, 2n-1, 2n, 2n+1 and a few variables
+ # $num=2n-1 $denom=2n $square=x^2 and $i=2n+1
+ set mantissa_temp [::math::bignum::div $mantissa $i]
+ set delta_temp [::math::bignum::add 1 [::math::bignum::div $delta $i]]
+ # when the Mantissa increment is smaller than the Delta increment,
+ # we would not get much precision by continuing the development
+ while {![::math::bignum::iszero $mantissa_temp]} {
+ # Mantissa = Mantissa * $num/$denom * $square
+ # Add Mantissa/$i, which is stored in $mantissa_temp, to the result
+ set result [::math::bignum::add $result $mantissa_temp]
+ set delta_final [::math::bignum::add $delta_final $delta_temp]
+ # here we have $two instead of [fromstr 2] (optimization)
+ # num=num+2,i=i+2,denom=denom+2
+ # because num=2n-1 denom=2n and i=2n+1
+ set num [::math::bignum::add $num $two]
+ set i [::math::bignum::add $i $two]
+ set denom [::math::bignum::add $denom $two]
+ # computes precisly the future Delta parameter
+ set delta [::math::bignum::add [::math::bignum::mul $delta $square] \
+ [::math::bignum::mul $dt [::math::bignum::add $delta $mantissa]]]
+ set delta [::math::bignum::add 1 [::math::bignum::rshift [::math::bignum::div \
+ [::math::bignum::mul $delta $num] $denom] $precision]]
+ set mantissa [intMulShift $mantissa $square $precision]
+ set mantissa [::math::bignum::div [::math::bignum::mul $mantissa $num] $denom]
+ set mantissa_temp [::math::bignum::div $mantissa $i]
+ set delta_temp [::math::bignum::add 1 [::math::bignum::div $delta $i]]
+ }
+ return [list F $result $exp $delta_final]
+}
+
+################################################################################
+# arctangent : returns atan(x)
+################################################################################
+proc ::math::bigfloat::atan {x} {
+ checkFloat x
+ variable one
+ variable two
+ variable three
+ variable four
+ variable zero
+ foreach {dummy mantissa exp delta} $x {break}
+ if {$exp>=0} {
+ error "not enough precision to compute atan"
+ }
+ set precision [expr {-$exp}]
+ # atan(0)=0
+ if {[iszero $x]} {
+ return [list F $zero -$precision $one]
+ }
+ # atan(-x)=-atan(x)
+ if {[::math::bignum::sign $mantissa]} {
+ return [opp [atan [abs $x]]]
+ }
+ # now x is strictly positive
+ # at this moment, we are trying to limit |x| to a fair acceptable number
+ # to ensure that Taylor development will converge quickly
+ set float1 [list F [::math::bignum::lshift 1 $precision] -$precision $one]
+ if {[compare $float1 $x]<0} {
+ # compare x to 2.4142
+ if {[compare $x [fromstr 2.4142]]<0} {
+ # atan(x)=Pi/4 + atan((x-1)/(x+1))
+ # as 1<x<2.4142 : (x-1)/(x+1)=1-2/(x+1) belongs to
+ # the range : ]0,1-2/3.414[
+ # that equals ]0,0.414[
+ set pi_sur_quatre [div [pi $precision 1] $four]
+ return [add $pi_sur_quatre [atan \
+ [div [sub $x $float1] [add $x $float1]]]]
+ }
+ # atan(x)=Pi/2-atan(1/x)
+ # 1/x < 1/2.414 so the argument is lower than 0.414
+ set pi_over_two [div [pi $precision 1] $two]
+ return [sub $pi_over_two [atan [div $float1 $x]]]
+ }
+ if {[compare $x [fromstr 0.4142]]>0} {
+ # atan(x)=Pi/4 + atan((x-1)/(x+1))
+ # x>0.420 so (x-1)/(x+1)=1 - 2/(x+1) > 1-2/1.414
+ # > -0.414
+ # x<1 so (x-1)/(x+1)<0
+ set pi_sur_quatre [div [pi $precision 1] $four]
+ return [add $pi_sur_quatre [atan \
+ [div [sub $x $float1] [add $x $float1]]]]
+ }
+ # precision increment : to have less uncertainty
+ # we add a little more precision so that the result would be more accurate
+ # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1)
+ # when we have n steps in Taylor development : the nth term is :
+ # x^(2n-1)/(2n-1)
+ # and the loss of precision is of 2n (n sums and n divisions)
+ # this command is called with x<sqrt(2)-1
+ # if we add an increment to the precision, say n:
+ # (sqrt(2)-1)^(2n-1)/(2n-1) has to be lower than 2^(-precision-n-1)
+ # (2n-1)*log(sqrt(2)-1)-log(2n-1)<-(precision+n+1)*log(2)
+ # 2n(log(sqrt(2)-1)-log(sqrt(2)))<-(precision-1)*log(2)+log(2n-1)+log(sqrt(2)-1)
+ # 2n*log(1-1/sqrt(2))<-(precision-1)*log(2)+log(2n-1)+log(2)/2
+ # 2n/sqrt(2)>(precision-3/2)*log(2)-log(2n-1)
+ # hence log(2n-1)<2n-1
+ # n*sqrt(2)>(precision-1.5)*log(2)+1-2n
+ # n*(sqrt(2)+2)>(precision-1.5)*log(2)+1
+ set n [expr {int((log(2)*($precision-1.5)+1)/(sqrt(2)+2)+1)}]
+ incr precision $n
+ set mantissa [::math::bignum::lshift $mantissa $n]
+ set delta [::math::bignum::lshift $delta $n]
+ # end of adding precision increment
+ # now computing Taylor development :
+ # atan(x)=x - x^3/3 + x^5/5 - x^7/7 ... + (-1)^n*x^(2n+1)/(2n+1)
+ # atan(x)=x * (1 - x^2 * (1/3 - x^2 * (1/5 - x^2 * (...*(1/(2n-1) - x^2 / (2n+1))...))))
+ # what do we need to compute this ?
+ # x^2 ($square), 2n+1 ($divider), $result, the nth term of the development ($t)
+ # and the nth term multiplied by 2n+1 ($temp)
+ # then we do this (with care keeping as much precision as possible):
+ # while ($t <>0) :
+ # $result=$result+$t
+ # $temp=$temp * $square
+ # $divider = $divider+2
+ # $t=$temp/$divider
+ # end-while
+ set result $mantissa
+ set delta_end $delta
+ # we store the square of the integer (mantissa)
+ set delta_square [::math::bignum::lshift $delta 1]
+ set square [intMulShift $mantissa $mantissa $precision]
+ # the (2n+1) divider
+ set divider $three
+ # computing precisely the uncertainty
+ set delta [::math::bignum::add 1 [::math::bignum::rshift [::math::bignum::add \
+ [::math::bignum::mul $delta_square $mantissa] \
+ [::math::bignum::mul $delta $square]] $precision]]
+ # temp contains (-1)^n*x^(2n+1)
+ set temp [opp [intMulShift $mantissa $square $precision]]
+ set t [::math::bignum::div $temp $divider]
+ set dt [::math::bignum::add 1 [::math::bignum::div $delta $divider]]
+ while {![::math::bignum::iszero $t]} {
+ set result [::math::bignum::add $result $t]
+ set delta_end [::math::bignum::add $delta_end $dt]
+ set divider [::math::bignum::add $divider $two]
+ set delta [::math::bignum::add 1 [::math::bignum::rshift [::math::bignum::add \
+ [::math::bignum::mul $delta_square [abs $temp]] [::math::bignum::mul $delta \
+ [::math::bignum::add $delta_square $square]]] $precision]]
+ set temp [opp [intMulShift $temp $square $precision]]
+ set t [::math::bignum::div $temp $divider]
+ set dt [::math::bignum::add [::math::bignum::div $delta $divider] $one]
+ }
+ # we have to normalize because the uncertainty might be greater than 99
+ # moreover it is the most often case
+ return [normalize [list F $result [expr {$exp-$n}] $delta_end]]
+}
+
+
+################################################################################
+# compute atan(1/integer) at a given precision
+# this proc is only used to compute Pi
+# it is using the same Taylor development as [atan]
+################################################################################
+proc ::math::bigfloat::_atanfract {integer precision} {
+ # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1)
+ # when we have n steps in Taylor development : the nth term is :
+ # 1/denom^(2n+1)/(2n+1)
+ # and the loss of precision is of 2n (n sums and n divisions)
+ # this command is called with integer>=5
+ #
+ # We do not want to compute the Delta parameter, so we just
+ # can increment precision (with lshift) in order for the result to be precise.
+ # Remember : we compute atan2(1,$integer) with $precision bits
+ # $integer has no Delta parameter as it is a BigInt, of course, so
+ # theorically we could compute *any* number of digits.
+ #
+ # if we add an increment to the precision, say n:
+ # (1/5)^(2n-1)/(2n-1) has to be lower than (1/2)^(precision+n-1)
+ # Calculus :
+ # log(left term) < log(right term)
+ # log(1/left term) > log(1/right term)
+ # (2n-1)*log(5)+log(2n-1)>(precision+n-1)*log(2)
+ # n(2log(5)-log(2))>(precision-1)*log(2)-log(2n-1)+log(5)
+ # -log(2n-1)>-(2n-1)
+ # n(2log(5)-log(2)+2)>(precision-1)*log(2)+1+log(5)
+ set n [expr {int((($precision-1)*log(2)+1+log(5))/(2*log(5)-log(2)+2)+1)}]
+ incr precision $n
+ # first term of the development : 1/integer
+ set a [::math::bignum::div [::math::bignum::lshift 1 $precision] $integer]
+ # 's' will contain the result
+ set s $a
+ # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1)
+ # equals x (1 - x^2 * (1/3 + x^2 * (... * (1/(2n-3) + (-1)^(n+1) * x^2 / (2n-1))...)))
+ # all we need to store is : 2n-1 ($denom), x^(2n+1) and x^2 ($square) and two results :
+ # - the nth term => $u
+ # - the nth term * (2n-1) => $t
+ # + of course, the result $s
+ set square [::math::bignum::mul $integer $integer]
+ variable two
+ variable three
+ set denom $three
+ # $t is (-1)^n*x^(2n+1)
+ set t [opp [::math::bignum::div $a $square]]
+ set u [::math::bignum::div $t $denom]
+ # we break the loop when the current term of the development is null
+ while {![::math::bignum::iszero $u]} {
+ set s [::math::bignum::add $s $u]
+ # denominator= (2n+1)
+ set denom [::math::bignum::add $denom $two]
+ # div $t by x^2
+ set t [opp [::math::bignum::div $t $square]]
+ set u [::math::bignum::div $t $denom]
+ }
+ # go back to the initial precision
+ return [::math::bignum::rshift $s $n]
+}
+
+
+################################################################################
+# returns the integer part of a BigFloat, as a BigInt
+# the result is the same one you would have
+# if you had called [expr {ceil($x)}]
+################################################################################
+proc ::math::bigfloat::ceil {number} {
+ checkFloat number
+ set number [normalize $number]
+ if {[iszero $number]} {
+ # returns the BigInt 0
+ variable zero
+ return $zero
+ }
+ foreach {dummy integer exp delta} $number {break}
+ if {$exp>=0} {
+ error "not enough precision to perform rounding (ceil)"
+ }
+ # saving the sign ...
+ set sign [::math::bignum::sign $integer]
+ set integer [abs $integer]
+ # integer part
+ set try [::math::bignum::rshift $integer [expr {-$exp}]]
+ if {$sign} {
+ return [opp $try]
+ }
+ # fractional part
+ if {![equal [::math::bignum::lshift $try [expr {-$exp}]] $integer]} {
+ return [::math::bignum::add 1 $try]
+ }
+ return $try
+}
+
+
+################################################################################
+# checks each variable to be a BigFloat
+# arguments : each argument is the name of a variable to be checked
+################################################################################
+proc ::math::bigfloat::checkFloat {args} {
+ foreach x $args {
+ upvar $x n
+ if {![isFloat $n]} {
+ error "BigFloat expected : received '$n'"
+ }
+ }
+}
+
+################################################################################
+# checks if each number is either a BigFloat or a BigInt
+# arguments : each argument is the name of a variable to be checked
+################################################################################
+proc ::math::bigfloat::checkNumber {args} {
+ foreach i $args {
+ upvar $i x
+ if {![isInt $x] && ![isFloat $x]} {
+ error "'$x' is not a number"
+ }
+ }
+}
+
+
+################################################################################
+# returns 0 if A and B are equal, else returns 1 or -1
+# accordingly to the sign of (A - B)
+################################################################################
+proc ::math::bigfloat::compare {a b} {
+ if {[isInt $a] && [isInt $b]} {
+ return [::math::bignum::cmp $a $b]
+ }
+ checkFloat a b
+ if {[equal $a $b]} {return 0}
+ return [expr {([::math::bignum::sign [lindex [sub $a $b] 1]])?-1:1}]
+}
+
+
+
+
+################################################################################
+# gets cos(x)
+# throws an error if there is not enough precision on the input
+################################################################################
+proc ::math::bigfloat::cos {x} {
+ checkFloat x
+ foreach {dummy integer exp delta} $x {break}
+ if {$exp>-2} {
+ error "not enough precision on floating-point number"
+ }
+ set precision [expr {-$exp}]
+ # cos(2kPi+x)=cos(x)
+ foreach {n integer} [divPiQuarter $integer $precision] {break}
+ # now integer>=0 and <Pi/2
+ set d [expr {[tostr $n]%4}]
+ # add trigonometric circle turns number to delta
+ set delta [::math::bignum::add [abs $n] $delta]
+ set signe 0
+ # cos(Pi-x)=-cos(x)
+ # cos(-x)=cos(x)
+ # cos(Pi/2-x)=sin(x)
+ switch -- $d {
+ 1 {set signe 1;set l [_sin2 $integer $precision $delta]}
+ 2 {set signe 1;set l [_cos2 $integer $precision $delta]}
+ 0 {set l [_cos2 $integer $precision $delta]}
+ 3 {set l [_sin2 $integer $precision $delta]}
+ default {error "internal error"}
+ }
+ # precision -> exp (multiplied by -1)
+ lset l 1 [expr {-([lindex $l 1])}]
+ # set the sign
+ set integer [lindex $l 0]
+ ::math::bignum::setsign integer $signe
+ lset l 0 $integer
+ return [normalize [linsert $l 0 F]]
+}
+
+################################################################################
+# compute cos(x) where 0<=x<Pi/2
+# returns : a list formed with :
+# 1. the mantissa
+# 2. the precision (opposite of the exponent)
+# 3. the uncertainty (doubt range)
+################################################################################
+proc ::math::bigfloat::_cos2 {x precision delta} {
+ # precision bits after the dot
+ set pi [_pi $precision]
+ set pis4 [::math::bignum::rshift $pi 2]
+ set pis2 [::math::bignum::rshift $pi 1]
+ if {[::math::bignum::cmp $x $pis4]>=0} {
+ # cos(Pi/2-x)=sin(x)
+ set x [::math::bignum::sub $pis2 $x]
+ set delta [::math::bignum::add 1 $delta]
+ return [_sin $x $precision $delta]
+ }
+ return [_cos $x $precision $delta]
+}
+
+################################################################################
+# compute cos(x) where 0<=x<Pi/4
+# returns : a list formed with :
+# 1. the mantissa
+# 2. the precision (opposite of the exponent)
+# 3. the uncertainty (doubt range)
+################################################################################
+proc ::math::bigfloat::_cos {x precision delta} {
+ variable zero
+ variable one
+ variable two
+ set float1 [::math::bignum::lshift $one $precision]
+ # Taylor development follows :
+ # cos(x)=1-x^2/2 + x^4/4! ... + (-1)^(2n)*x^(2n)/2n!
+ # cos(x)= 1 - x^2/1.2 * (1 - x^2/3.4 * (... * (1 - x^2/(2n.(2n-1))...))
+ # variables : $s (the Mantissa of the result)
+ # $denom1 & $denom2 (2n-1 & 2n)
+ # $x as the square of what is named x in 'cos(x)'
+ set s $float1
+ # 'd' is the uncertainty on x^2
+ set d [::math::bignum::mul $x [::math::bignum::lshift $delta 1]]
+ set d [::math::bignum::add 1 [::math::bignum::rshift $d $precision]]
+ # x=x^2 (because in this Taylor development, there are only even powers of x)
+ set x [intMulShift $x $x $precision]
+ set denom1 $one
+ set denom2 $two
+ set t [opp [::math::bignum::rshift $x 1]]
+ set delta $zero
+ set dt $d
+ while {![::math::bignum::iszero $t]} {
+ set s [::math::bignum::add $s $t]
+ set delta [::math::bignum::add $delta $dt]
+ set denom1 [::math::bignum::add $denom1 $two]
+ set denom2 [::math::bignum::add $denom2 $two]
+ set dt [::math::bignum::rshift [::math::bignum::add [::math::bignum::mul $x $dt]\
+ [::math::bignum::mul [::math::bignum::add $t $dt] $d]] $precision]
+ set dt [::math::bignum::add 1 $dt]
+ set t [intMulShift $x $t $precision]
+ set t [opp [::math::bignum::div $t [::math::bignum::mul $denom1 $denom2]]]
+ }
+ return [list $s $precision $delta]
+}
+
+################################################################################
+# cotangent : the trivial algorithm is used
+################################################################################
+proc ::math::bigfloat::cotan {x} {
+ return [::math::bigfloat::div [::math::bigfloat::cos $x] [::math::bigfloat::sin $x]]
+}
+
+################################################################################
+# converts angles from degrees to radians
+# deg/180=rad/Pi
+################################################################################
+proc ::math::bigfloat::deg2rad {x} {
+ checkFloat x
+ set xLen [expr {-[lindex $x 2]}]
+ if {$xLen<3} {
+ error "number too loose to convert to radians"
+ }
+ set pi [pi $xLen 1]
+ return [div [mul $x $pi] [::math::bignum::fromstr 180]]
+}
+
+
+
+################################################################################
+# private proc to get : x modulo Pi/2
+# and the quotient (x divided by Pi/2)
+# used by cos , sin & others
+################################################################################
+proc ::math::bigfloat::divPiQuarter {integer precision} {
+ incr precision 2
+ set integer [::math::bignum::lshift $integer 1]
+ set dpi [_pi $precision]
+ # modulo 2Pi
+ foreach {n integer} [::math::bignum::divqr $integer $dpi] {break}
+ # end modulo 2Pi
+ set pi [::math::bignum::rshift $dpi 1]
+ foreach {n integer} [::math::bignum::divqr $integer $pi] {break}
+ # now divide by Pi/2
+ # multiply n by 2
+ set n [::math::bignum::lshift $n 1]
+ # pis2=pi/2
+ set pis2 [::math::bignum::rshift $pi 1]
+ foreach {m integer} [::math::bignum::divqr $integer $pis2] {break}
+ return [list [::math::bignum::add $n $m] [::math::bignum::rshift $integer 1]]
+}
+
+
+################################################################################
+# divide A by B and returns the result
+# throw error : divide by zero
+################################################################################
+proc ::math::bigfloat::div {a b} {
+ variable one
+ checkNumber a b
+ # dispatch to an appropriate procedure
+ if {[isInt $a]} {
+ if {[isInt $b]} {
+ return [::math::bignum::div $a $b]
+ }
+ error "trying to divide a BigInt by a BigFloat"
+ }
+ if {[isInt $b]} {return [divFloatByInt $a $b]}
+ foreach {dummy integerA expA deltaA} $a {break}
+ foreach {dummy integerB expB deltaB} $b {break}
+ # computes the limits of the doubt (or uncertainty) interval
+ set BMin [::math::bignum::sub $integerB $deltaB]
+ set BMax [::math::bignum::add $integerB $deltaB]
+ if {[::math::bignum::cmp $BMin $BMax]>0} {
+ # swap BMin and BMax
+ set temp $BMin
+ set BMin $BMax
+ set BMax $temp
+ }
+ # multiply by zero gives zero
+ if {[::math::bignum::iszero $integerA]} {
+ # why not return any number or the integer 0 ?
+ # because there is an exponent that might be different between two BigFloats
+ # 0.00 --> exp = -2, 0.000000 -> exp = -6
+ return $a
+ }
+ # test of the division by zero
+ if {[::math::bignum::sign $BMin]+[::math::bignum::sign $BMax]==1 || \
+ [::math::bignum::iszero $BMin] || [::math::bignum::iszero $BMax]} {
+ error "divide by zero"
+ }
+ # shift A because we need accuracy
+ set l [math::bignum::bits $integerB]
+ set integerA [::math::bignum::lshift $integerA $l]
+ set deltaA [::math::bignum::lshift $deltaA $l]
+ set exp [expr {$expA-$l-$expB}]
+ # relative uncertainties (dX/X) are added
+ # to give the relative uncertainty of the result
+ # i.e. 3% on A + 2% on B --> 5% on the quotient
+ # d(A/B)/(A/B)=dA/A + dB/B
+ # Q=A/B
+ # dQ=dA/B + dB*A/B*B
+ # dQ is "delta"
+ set delta [::math::bignum::div [::math::bignum::mul $deltaB \
+ [abs $integerA]] [abs $integerB]]
+ set delta [::math::bignum::div [::math::bignum::add\
+ [::math::bignum::add 1 $delta]\
+ $deltaA] [abs $integerB]]
+ set quotient [::math::bignum::div $integerA $integerB]
+ if {[::math::bignum::sign $integerB]+[::math::bignum::sign $integerA]==1} {
+ set quotient [::math::bignum::sub $quotient 1]
+ }
+ return [normalize [list F $quotient $exp [::math::bignum::add $delta 1]]]
+}
+
+
+
+
+################################################################################
+# divide a BigFloat A by a BigInt B
+# throw error : divide by zero
+################################################################################
+proc ::math::bigfloat::divFloatByInt {a b} {
+ variable one
+ # type check
+ checkFloat a
+ if {![isInt $b]} {
+ error "'$b' is not a BigInt"
+ }
+ foreach {dummy integer exp delta} $a {break}
+ # zero divider test
+ if {[::math::bignum::iszero $b]} {
+ error "divide by zero"
+ }
+ # shift left for accuracy ; see other comments in [div] procedure
+ set l [::math::bignum::bits $b]
+ set integer [::math::bignum::lshift $integer $l]
+ set delta [::math::bignum::lshift $delta $l]
+ incr exp -$l
+ set integer [::math::bignum::div $integer $b]
+ # the uncertainty is always evaluated to the ceil value
+ # and as an absolute value
+ set delta [::math::bignum::add 1 [::math::bignum::div $delta [abs $b]]]
+ return [normalize [list F $integer $exp $delta]]
+}
+
+
+
+
+
+################################################################################
+# returns 1 if A and B are equal, 0 otherwise
+# IN : a, b (BigFloats)
+################################################################################
+proc ::math::bigfloat::equal {a b} {
+ if {[isInt $a] && [isInt $b]} {
+ return [expr {[::math::bignum::cmp $a $b]==0}]
+ }
+ # now a & b should only be BigFloats
+ checkFloat a b
+ foreach {dummy aint aexp adelta} $a {break}
+ foreach {dummy bint bexp bdelta} $b {break}
+ # set all Mantissas and Deltas to the same level (exponent)
+ # with lshift
+ set diff [expr {$aexp-$bexp}]
+ if {$diff<0} {
+ set diff [expr {-$diff}]
+ set bint [::math::bignum::lshift $bint $diff]
+ set bdelta [::math::bignum::lshift $bdelta $diff]
+ } elseif {$diff>0} {
+ set aint [::math::bignum::lshift $aint $diff]
+ set adelta [::math::bignum::lshift $adelta $diff]
+ }
+ # compute limits of the number's doubt range
+ set asupInt [::math::bignum::add $aint $adelta]
+ set ainfInt [::math::bignum::sub $aint $adelta]
+ set bsupInt [::math::bignum::add $bint $bdelta]
+ set binfInt [::math::bignum::sub $bint $bdelta]
+ # A & B are equal
+ # if their doubt ranges overlap themselves
+ if {[::math::bignum::cmp $bint $aint]==0} {
+ return 1
+ }
+ if {[::math::bignum::cmp $bint $aint]>0} {
+ set r [expr {[::math::bignum::cmp $asupInt $binfInt]>=0}]
+ } else {
+ set r [expr {[::math::bignum::cmp $bsupInt $ainfInt]>=0}]
+ }
+ return $r
+}
+
+################################################################################
+# returns exp(X) where X is a BigFloat
+################################################################################
+proc ::math::bigfloat::exp {x} {
+ checkFloat x
+ foreach {dummy integer exp delta} $x {break}
+ if {$exp>=0} {
+ # shift till exp<0 with respect to the internal representation
+ # of the number
+ incr exp
+ set integer [::math::bignum::lshift $integer $exp]
+ set delta [::math::bignum::lshift $delta $exp]
+ set exp -1
+ }
+ set precision [expr {-$exp}]
+ # add 8 bits of precision for safety
+ incr precision 8
+ set integer [::math::bignum::lshift $integer 8]
+ set delta [::math::bignum::lshift $delta 8]
+ set Log2 [_log2 $precision]
+ foreach {new_exp integer} [::math::bignum::divqr $integer $Log2] {break}
+ # new_exp = integer part of x/log(2)
+ # integer = remainder
+ # exp(K.log(2)+r)=2^K.exp(r)
+ # so we just have to compute exp(r), r is small so
+ # the Taylor development will converge quickly
+ set delta [::math::bignum::add $delta $new_exp]
+ foreach {integer delta} [_exp $integer $precision $delta] {break}
+ set delta [::math::bignum::rshift $delta 8]
+ incr precision -8
+ # multiply by 2^K , and take care of the sign
+ # example : X=-6.log(2)+0.01
+ # exp(X)=exp(0.01)*2^-6
+ if {![::math::bignum::iszero [::math::bignum::rshift [abs $new_exp] 30]]} {
+ error "floating-point overflow due to exp"
+ }
+ set new_exp [tostr $new_exp]
+ set exp [expr {$new_exp-$precision}]
+ set delta [::math::bignum::add 1 $delta]
+ return [normalize [list F [::math::bignum::rshift $integer 8] $exp $delta]]
+}
+
+
+################################################################################
+# private procedure to compute exponentials
+# using Taylor development of exp(x) :
+# exp(x)=1+ x + x^2/2 + x^3/3! +...+x^n/n!
+# input : integer (the mantissa)
+# precision (the number of decimals)
+# delta (the doubt limit, or uncertainty)
+# returns a list : 1. the mantissa of the result
+# 2. the doubt limit, or uncertainty
+################################################################################
+proc ::math::bigfloat::_exp {integer precision delta} {
+ set oneShifted [::math::bignum::lshift 1 $precision]
+ if {[::math::bignum::iszero $integer]} {
+ # exp(0)=1
+ return [list $oneShifted $delta]
+ }
+ set s [::math::bignum::add $oneShifted $integer]
+ variable two
+ set d [::math::bignum::add 1 [::math::bignum::div $delta $two]]
+ set delta [::math::bignum::add $delta $delta]
+ # dt = uncertainty on x^2
+ set dt [::math::bignum::add 1 [intMulShift $d $integer $precision]]
+ # t= x^2/2
+ set t [intMulShift $integer $integer $precision]
+ set t [::math::bignum::div $t $two]
+ set denom $two
+ while {![::math::bignum::iszero $t]} {
+ # the sum is called 's'
+ set s [::math::bignum::add $s $t]
+ set delta [::math::bignum::add $delta $dt]
+ # we do not have to keep trace of the factorial, we just iterate divisions
+ set denom [::math::bignum::add 1 $denom]
+ # add delta
+ set d [::math::bignum::add 1 [::math::bignum::div $d $denom]]
+ set dt [::math::bignum::add $dt $d]
+ # get x^n from x^(n-1)
+ set t [intMulShift $integer $t $precision]
+ # here we divide
+ set t [::math::bignum::div $t $denom]
+ }
+ return [list $s $delta]
+}
+################################################################################
+# divide a BigFloat by 2 power 'n'
+################################################################################
+proc ::math::bigfloat::floatRShift {float {n 1}} {
+ return [lset float 2 [expr {[lindex $float 2]-$n}]]
+}
+
+
+
+################################################################################
+# procedure floor : identical to [expr floor($x)] in functionality
+# arguments : number IN (a BigFloat)
+# returns : the floor value as a BigInt
+################################################################################
+proc ::math::bigfloat::floor {number} {
+ variable zero
+ checkFloat number
+ set number [normalize $number]
+ if {[::math::bignum::iszero $number]} {
+ # returns the BigInt 0
+ return $zero
+ }
+ foreach {dummy integer exp delta} $number {break}
+ if {$exp>=0} {
+ error "not enough precision to perform rounding (floor)"
+ }
+ # saving the sign ...
+ set sign [::math::bignum::sign $integer]
+ set integer [abs $integer]
+ # integer part
+ set try [::math::bignum::rshift $integer [expr {-$exp}]]
+ # floor(n.xxxx)=n
+ if {!$sign} {
+ return $try
+ }
+ # floor(-n.xxxx)=-(n+1) when xxxx!=0
+ if {![equal [::math::bignum::lshift $try [expr {-$exp}]] $integer]} {
+ set try [::math::bignum::add 1 $try]
+ }
+ ::math::bignum::setsign try $sign
+ return $try
+}
+
+
+################################################################################
+# returns a list formed by an integer and an exponent
+# x = (A +/- C) * 10 power B
+# return [list "F" A B C] (where F is the BigFloat tag)
+# A and C are BigInts, B is a raw integer
+# return also a BigInt when there is neither a dot, nor a 'e' exponent
+#
+# arguments : -base base integer
+# or integer
+# or float
+# or float trailingZeros
+################################################################################
+proc ::math::bigfloat::fromstr {args} {
+ if {[set string [lindex $args 0]]=="-base"} {
+ if {[llength $args]!=3} {
+ error "should be : fromstr -base base number"
+ }
+ # converts an integer i expressed in base b with : [fromstr b i]
+ return [::math::bignum::fromstr [lindex $args 2] [lindex $args 1]]
+ }
+ # trailingZeros are zeros appended to the Mantissa (it is optional)
+ set trailingZeros 0
+ if {[llength $args]==2} {
+ set trailingZeros [lindex $args 1]
+ }
+ if {$trailingZeros<0} {
+ error "second argument has to be a positive integer"
+ }
+ # eliminate the sign problem
+ # added on 05/08/2005
+ # setting '$signe' to the sign of the number
+ set string [string trimleft $string +]
+ if {[string index $string 0]=="-"} {
+ set signe 1
+ set string2 [string range $string 1 end]
+ } else {
+ set signe 0
+ set string2 $string
+ }
+ # integer case (not a floating-point number)
+ if {[string is digit $string2]} {
+ if {$trailingZeros!=0} {
+ error "second argument not allowed with an integer"
+ }
+ # we have completed converting an integer to a BigInt
+ # please note that most math::bigfloat procs accept BigInts as arguments
+ return [::math::bignum::fromstr $string]
+ }
+ set string $string2
+ # floating-point number : check for an exponent
+ # scientific notation
+ set tab [split $string e]
+ if {[llength $tab]>2} {
+ # there are more than one 'e' letter in the number
+ error "syntax error in number : $string"
+ }
+ if {[llength $tab]==2} {
+ set exp [lindex $tab 1]
+ # now exp can look like +099 so you need to handle octal numbers
+ # too bad...
+ # find the sign (if any?)
+ regexp {^[\+\-]?} $exp expsign
+ # trim the number with left-side 0's
+ set found [string length $expsign]
+ set exp $expsign[string trimleft [string range $exp $found end] 0]
+ set number [lindex $tab 0]
+ } else {
+ set exp 0
+ set number [lindex $tab 0]
+ }
+ # a floating-point number may have a dot
+ set tab [split $number .]
+ if {[llength $tab]>2} {error "syntax error in number : $string"}
+ if {[llength $tab]==2} {
+ set number [join $tab ""]
+ # increment by the number of decimals (after the dot)
+ incr exp -[string length [lindex $tab 1]]
+ }
+ # this is necessary to ensure we can call fromstr (recursively) with
+ # the mantissa ($number)
+ if {![string is digit $number]} {
+ error "$number is not a number"
+ }
+ # take account of trailing zeros
+ incr exp -$trailingZeros
+ # multiply $number by 10^$trailingZeros
+ set number [::math::bignum::mul [::math::bignum::fromstr $number]\
+ [tenPow $trailingZeros]]
+ ::math::bignum::setsign number $signe
+ # the F tags a BigFloat
+ # a BigInt in internal representation begins by the sign
+ # delta is 1 as a BigInt
+ return [_fromstr $number $exp]
+}
+
+################################################################################
+# private procedure to transform decimal floats into binary ones
+# IN :
+# - number : a BigInt representing the Mantissa
+# - exp : the decimal exponent (a simple integer)
+# OUT :
+# $number * 10^$exp, as the internal binary representation of a BigFloat
+################################################################################
+proc ::math::bigfloat::_fromstr {number exp} {
+ variable one
+ variable five
+ if {$exp==0} {
+ return [list F $number 0 $one]
+ }
+ if {$exp>0} {
+ # mul by 10^exp, and by 2^4, then normalize
+ set number [::math::bignum::lshift $number 4]
+ set exponent [tenPow $exp]
+ set number [::math::bignum::mul $number $exponent]
+ # normalize number*2^-4 +/- 2^4*10^exponent
+ return [normalize [list F $number -4 [::math::bignum::lshift $exponent 4]]]
+ }
+ # now exp is negative or null
+ # the closest power of 2 to the 'exp'th power of ten, but greater than it
+ set binaryExp [expr {int(ceil(-$exp*log(10)/log(2)))+4}]
+ # then compute n * 2^binaryExp / 10^(-exp)
+ # (exp is negative)
+ # equals n * 2^(binaryExp+exp) / 5^(-exp)
+ set diff [expr {$binaryExp+$exp}]
+ if {$diff<0} {
+ error "internal error"
+ }
+ set fivePow [::math::bignum::pow $five [::math::bignum::fromstr [expr {-$exp}]]]
+ set number [::math::bignum::div [::math::bignum::lshift $number \
+ $diff] $fivePow]
+ set delta [::math::bignum::div [::math::bignum::lshift 1 \
+ $diff] $fivePow]
+ return [normalize [list F $number [expr {-$binaryExp}] [::math::bignum::add $delta 1]]]
+}
+
+
+################################################################################
+# fromdouble :
+# like fromstr, but for a double scalar value
+# arguments :
+# double - the number to convert to a BigFloat
+# exp (optional) - the total number of digits
+################################################################################
+proc ::math::bigfloat::fromdouble {double {exp {}}} {
+ set mantissa [lindex [split $double e] 0]
+ # line added by SArnold on 05/08/2005
+ set mantissa [string trimleft [string map {+ "" - ""} $mantissa] 0]
+ set precision [string length [string map {. ""} $mantissa]]
+ if { $exp != {} && [incr exp]>$precision } {
+ return [fromstr $double [expr {$exp-$precision}]]
+ } else {
+ # tests have failed : not enough precision or no exp argument
+ return [fromstr $double]
+ }
+}
+
+
+################################################################################
+# converts a BigInt into a BigFloat with a given decimal precision
+################################################################################
+proc ::math::bigfloat::int2float {int {decimals 1}} {
+ # it seems like we need some kind of type handling
+ # very odd in this Tcl world :-(
+ if {![isInt $int]} {
+ error "first argument is not an integer"
+ }
+ if {$decimals<1} {
+ error "non-positive decimals number"
+ }
+ # the lowest number of decimals is 1, because
+ # [tostr [fromstr 10.0]] returns 10.
+ # (we lose 1 digit when converting back to string)
+ set int [::math::bignum::mul $int [tenPow $decimals]]
+ return [_fromstr $int [expr {-$decimals}]]
+
+}
+
+
+
+################################################################################
+# multiplies 'leftop' by 'rightop' and rshift the result by 'shift'
+################################################################################
+proc ::math::bigfloat::intMulShift {leftop rightop shift} {
+ return [::math::bignum::rshift [::math::bignum::mul $leftop $rightop] $shift]
+}
+
+################################################################################
+# returns 1 if x is a BigFloat, 0 elsewhere
+################################################################################
+proc ::math::bigfloat::isFloat {x} {
+ # a BigFloat is a list of : "F" mantissa exponent delta
+ if {[llength $x]!=4} {
+ return 0
+ }
+ # the marker is the letter "F"
+ if {[string equal [lindex $x 0] F]} {
+ return 1
+ }
+ return 0
+}
+
+################################################################################
+# checks that n is a BigInt (a number create by math::bignum::fromstr)
+################################################################################
+proc ::math::bigfloat::isInt {n} {
+ if {[llength $n]<3} {
+ return 0
+ }
+ if {[string equal [lindex $n 0] bignum]} {
+ return 1
+ }
+ return 0
+}
+
+
+
+################################################################################
+# returns 1 if x is null, 0 otherwise
+################################################################################
+proc ::math::bigfloat::iszero {x} {
+ if {[isInt $x]} {
+ return [::math::bignum::iszero $x]
+ }
+ checkFloat x
+ # now we do some interval rounding : if a number's interval englobs 0,
+ # it is considered to be equal to zero
+ foreach {dummy integer exp delta} $x {break}
+ set integer [::math::bignum::abs $integer]
+ if {[::math::bignum::cmp $delta $integer]>=0} {return 1}
+ return 0
+}
+
+
+################################################################################
+# compute log(X)
+################################################################################
+proc ::math::bigfloat::log {x} {
+ checkFloat x
+ foreach {dummy integer exp delta} $x {break}
+ if {[::math::bignum::iszero $integer]||[::math::bignum::sign $integer]} {
+ error "zero logarithm error"
+ }
+ if {[iszero $x]} {
+ error "number is null"
+ }
+ set precision [::math::bignum::bits $integer]
+ # uncertainty of the logarithm
+ set delta [::math::bignum::add 1 [_logOnePlusEpsilon $delta $integer $precision]]
+ # we got : x = 1xxxxxx (binary number with 'precision' bits) * 2^exp
+ # we need : x = 0.1xxxxxx(binary) *2^(exp+precision)
+ incr exp $precision
+ foreach {integer deltaIncr} [_log $integer] {break}
+ set delta [::math::bignum::add $delta $deltaIncr]
+ # log(a * 2^exp)= log(a) + exp*log(2)
+ # result = log(x) + exp*log(2)
+ # as x<1 log(x)<0 but 'integer' (result of '_log') is the absolute value
+ # that is why we substract $integer to log(2)*$exp
+ set integer [::math::bignum::sub [::math::bignum::mul [_log2 $precision] \
+ [set exp [::math::bignum::fromstr $exp]]] $integer]
+ set delta [::math::bignum::add $delta [abs $exp]]
+ return [normalize [list F $integer -$precision $delta]]
+}
+
+
+################################################################################
+# compute log(1-epsNum/epsDenom)=log(1-'epsilon')
+# Taylor development gives -x -x^2/2 -x^3/3 -x^4/4 ...
+# used by 'log' command because log(x+/-epsilon)=log(x)+log(1+/-(epsilon/x))
+# so the uncertainty equals abs(log(1-epsilon/x))
+# ================================================
+# arguments :
+# epsNum IN (the numerator of epsilon)
+# epsDenom IN (the denominator of epsilon)
+# precision IN (the number of bits after the dot)
+#
+# 'epsilon' = epsNum*2^-precision/epsDenom
+################################################################################
+proc ::math::bigfloat::_logOnePlusEpsilon {epsNum epsDenom precision} {
+ if {[::math::bignum::cmp $epsNum $epsDenom]>=0} {
+ error "number is null"
+ }
+ set s [::math::bignum::lshift $epsNum $precision]
+ set s [::math::bignum::div $s $epsDenom]
+ variable two
+ set divider $two
+ set t [::math::bignum::div [::math::bignum::mul $s $epsNum] $epsDenom]
+ set u [::math::bignum::div $t $divider]
+ # when u (the current term of the development) is zero, we have reached our goal
+ # it has converged
+ while {![::math::bignum::iszero $u]} {
+ set s [::math::bignum::add $s $u]
+ # divider = order of the term = 'n'
+ set divider [::math::bignum::add 1 $divider]
+ # t = (epsilon)^n
+ set t [::math::bignum::div [::math::bignum::mul $t $epsNum] $epsDenom]
+ # u = t/n = (epsilon)^n/n and is the nth term of the Taylor development
+ set u [::math::bignum::div $t $divider]
+ }
+ return $s
+}
+
+
+################################################################################
+# compute log(0.xxxxxxxx) : log(1-epsilon)=-eps-eps^2/2-eps^3/3...-eps^n/n
+################################################################################
+proc ::math::bigfloat::_log {integer} {
+ # the uncertainty is nbSteps with nbSteps<=nbBits
+ # take nbSteps=nbBits (the worse case) and log(nbBits+increment)=increment
+ set precision [::math::bignum::bits $integer]
+ set n [expr {int(log($precision+2*log($precision)))}]
+ set integer [::math::bignum::lshift $integer $n]
+ incr precision $n
+ variable three
+ set delta $three
+ # 1-epsilon=integer
+ set integer [::math::bignum::sub [::math::bignum::lshift 1 $precision] $integer]
+ set s $integer
+ # t=x^2
+ set t [intMulShift $integer $integer $precision]
+ variable two
+ set denom $two
+ # u=x^2/2 (second term)
+ set u [::math::bignum::div $t $denom]
+ while {![::math::bignum::iszero $u]} {
+ # while the current term is not zero, it has not converged
+ set s [::math::bignum::add $s $u]
+ set delta [::math::bignum::add 1 $delta]
+ # t=x^n
+ set t [intMulShift $t $integer $precision]
+ # denom = n (the order of the current development term)
+ set denom [::math::bignum::add 1 $denom]
+ # u = x^n/n (the nth term of Taylor development)
+ set u [::math::bignum::div $t $denom]
+ }
+ # shift right to restore the precision
+ set delta [::math::bignum::add 1 [::math::bignum::rshift $delta $n]]
+ return [list [::math::bignum::rshift $s $n] $delta]
+}
+
+################################################################################
+# computes log(num/denom) with 'precision' bits
+# used to compute some analysis constants with a given accuracy
+# you might not call this procedure directly : it assumes 'num/denom'>4/5
+# and 'num/denom'<1
+################################################################################
+proc ::math::bigfloat::__log {num denom precision} {
+ # Please Note : we here need a precision increment, in order to
+ # keep accuracy at $precision digits. If we just hold $precision digits,
+ # each number being precise at the last digit +/- 1,
+ # we would lose accuracy because small uncertainties add to themselves.
+ # Example : 0.0001 + 0.0010 = 0.0011 +/- 0.0002
+ # This is quite the same reason that made tcl_precision defaults to 12 :
+ # internally, doubles are computed with 17 digits, but to keep precision
+ # we need to limit our results to 12.
+ # The solution : given a precision target, increment precision with a
+ # computed value so that all digits of he result are exacts.
+ #
+ # p is the precision
+ # pk is the precision increment
+ # 2 power pk is also the maximum number of iterations
+ # for a number close to 1 but lower than 1,
+ # (denom-num)/denum is (in our case) lower than 1/5
+ # so the maximum nb of iterations is for:
+ # 1/5*(1+1/5*(1/2+1/5*(1/3+1/5*(...))))
+ # the last term is 1/n*(1/5)^n
+ # for the last term to be lower than 2^(-p-pk)
+ # the number of iterations has to be
+ # 2^(-pk).(1/5)^(2^pk) < 2^(-p-pk)
+ # log(1/5).2^pk < -p
+ # 2^pk > p/log(5)
+ # pk > log(2)*log(p/log(5))
+ # now set the variable n to the precision increment i.e. pk
+ set n [expr {int(log(2)*log($precision/log(5)))+1}]
+ incr precision $n
+ # log(num/denom)=log(1-(denom-num)/denom)
+ # log(1+x) = x + x^2/2 + x^3/3 + ... + x^n/n
+ # = x(1 + x(1/2 + x(1/3 + x(...+ x(1/(n-1) + x/n)...))))
+ set num [::math::bignum::fromstr [expr {$denom-$num}]]
+ set denom [::math::bignum::fromstr $denom]
+ # $s holds the result
+ set s [::math::bignum::div [::math::bignum::lshift $num $precision] $denom]
+ # $t holds x^n
+ set t [::math::bignum::div [::math::bignum::mul $s $num] $denom]
+ variable two
+ set d $two
+ # $u holds x^n/n
+ set u [::math::bignum::div $t $d]
+ while {![::math::bignum::iszero $u]} {
+ set s [::math::bignum::add $s $u]
+ # get x^n * x
+ set t [::math::bignum::div [::math::bignum::mul $t $num] $denom]
+ # get n+1
+ set d [::math::bignum::add 1 $d]
+ # then : $u = x^(n+1)/(n+1)
+ set u [::math::bignum::div $t $d]
+ }
+ # see head of the proc : we return the value with its target precision
+ return [::math::bignum::rshift $s $n]
+}
+
+################################################################################
+# computes log(2) with 'precision' bits and caches it into a namespace variable
+################################################################################
+proc ::math::bigfloat::__logbis {precision} {
+ set increment [expr {int(log($precision)/log(2)+1)}]
+ incr precision $increment
+ # ln(2)=3*ln(1-4/5)+ln(1-125/128)
+ set a [__log 125 128 $precision]
+ set b [__log 4 5 $precision]
+ variable three
+ set r [::math::bignum::add [::math::bignum::mul $b $three] $a]
+ set ::math::bigfloat::Log2 [::math::bignum::rshift $r $increment]
+ # formerly (when BigFloats were stored in ten radix) we had to compute log(10)
+ # ln(10)=10.ln(1-4/5)+3*ln(1-125/128)
+}
+
+
+################################################################################
+# retrieves log(2) with 'precision' bits ; the result is cached
+################################################################################
+proc ::math::bigfloat::_log2 {precision} {
+ variable Log2
+ if {![info exists Log2]} {
+ __logbis $precision
+ } else {
+ # the constant is cached and computed again when more precision is needed
+ set l [::math::bignum::bits $Log2]
+ if {$precision>$l} {
+ __logbis $precision
+ }
+ }
+ # return log(2) with 'precision' bits even when the cached value has more bits
+ return [_round $Log2 $precision]
+}
+
+
+################################################################################
+# returns A modulo B (like with fmod() math function)
+################################################################################
+proc ::math::bigfloat::mod {a b} {
+ checkNumber a b
+ if {[isInt $a] && [isInt $b]} {return [::math::bignum::mod $a $b]}
+ if {[isInt $a]} {error "trying to divide a BigInt by a BigFloat"}
+ set quotient [div $a $b]
+ # examples : fmod(3,2)=1 quotient=1.5
+ # fmod(1,2)=1 quotient=0.5
+ # quotient>0 and b>0 : get floor(quotient)
+ # fmod(-3,-2)=-1 quotient=1.5
+ # fmod(-1,-2)=-1 quotient=0.5
+ # quotient>0 and b<0 : get floor(quotient)
+ # fmod(-3,2)=-1 quotient=-1.5
+ # fmod(-1,2)=-1 quotient=-0.5
+ # quotient<0 and b>0 : get ceil(quotient)
+ # fmod(3,-2)=1 quotient=-1.5
+ # fmod(1,-2)=1 quotient=-0.5
+ # quotient<0 and b<0 : get ceil(quotient)
+ if {[sign $quotient]} {
+ set quotient [ceil $quotient]
+ } else {
+ set quotient [floor $quotient]
+ }
+ return [sub $a [mul $quotient $b]]
+}
+
+################################################################################
+# returns A times B
+################################################################################
+proc ::math::bigfloat::mul {a b} {
+ checkNumber a b
+ # dispatch the command to appropriate commands regarding types (BigInt & BigFloat)
+ if {[isInt $a]} {
+ if {[isInt $b]} {
+ return [::math::bignum::mul $a $b]
+ }
+ return [mulFloatByInt $b $a]
+ }
+ if {[isInt $b]} {return [mulFloatByInt $a $b]}
+ # now we are sure that 'a' and 'b' are BigFloats
+ foreach {dummy integerA expA deltaA} $a {break}
+ foreach {dummy integerB expB deltaB} $b {break}
+ # 2^expA * 2^expB = 2^(expA+expB)
+ set exp [expr {$expA+$expB}]
+ # mantissas are multiplied
+ set integer [::math::bignum::mul $integerA $integerB]
+ # compute precisely the uncertainty
+ set deltaAB [::math::bignum::mul $deltaA $deltaB]
+ set deltaA [::math::bignum::mul [abs $integerB] $deltaA]
+ set deltaB [::math::bignum::mul [abs $integerA] $deltaB]
+ set delta [::math::bignum::add [::math::bignum::add $deltaA $deltaB] \
+ [::math::bignum::add 1 $deltaAB]]
+ # we have to normalize because 'delta' may be too big
+ return [normalize [list F $integer $exp $delta]]
+}
+
+################################################################################
+# returns A times B, where B is a positive integer
+################################################################################
+proc ::math::bigfloat::mulFloatByInt {a b} {
+ checkFloat a
+ foreach {dummy integer exp delta} $a {break}
+ if {![isInt $b]} {
+ error "second argument expected to be a BigInt"
+ }
+ # Mantissa and Delta are simply multplied by $b
+ set integer [::math::bignum::mul $integer $b]
+ set delta [::math::bignum::mul $delta $b]
+ # We normalize because Delta could have seriously increased
+ return [normalize [list F $integer $exp $delta]]
+}
+
+################################################################################
+# normalizes a number : Delta (accuracy of the BigFloat)
+# has to be limited, because the memory use increase
+# quickly when we do some computations, as the Mantissa and Delta
+# increase together
+# The solution : keep the size of Delta under 9 bits
+################################################################################
+proc ::math::bigfloat::normalize {number} {
+ checkFloat number
+ foreach {dummy integer exp delta} $number {break}
+ set l [::math::bignum::bits $delta]
+ if {$l>8} {
+ # next line : $l holds the supplementary size (in bits)
+ incr l -8
+ # now we can shift right by $l bits
+ # always round upper the Delta
+ set delta [::math::bignum::add 1 [::math::bignum::rshift $delta $l]]
+ set integer [::math::bignum::rshift $integer $l]
+ incr exp $l
+ }
+ return [list F $integer $exp $delta]
+}
+
+
+
+################################################################################
+# returns -A (the opposite)
+################################################################################
+proc ::math::bigfloat::opp {a} {
+ checkNumber a
+ if {[iszero $a]} {
+ return $a
+ }
+ if {[isInt $a]} {
+ ::math::bignum::setsign a [expr {![::math::bignum::sign $a]}]
+ return $a
+ }
+ # recursive call
+ lset a 1 [opp [lindex $a 1]]
+ return $a
+}
+
+################################################################################
+# gets Pi with precision bits
+# after the dot (after you call [tostr] on the result)
+################################################################################
+proc ::math::bigfloat::pi {precision {binary 0}} {
+ if {[llength $precision]>1} {
+ if {[isInt $precision]} {
+ set precision [tostr $precision]
+ } else {
+ error "'$precision' expected to be an integer"
+ }
+ }
+ if {!$binary} {
+ # convert decimal digit length into bit length
+ set precision [expr {int(ceil($precision*log(10)/log(2)))}]
+ }
+ variable one
+ return [list F [_pi $precision] -$precision $one]
+}
+
+
+proc ::math::bigfloat::_pi {precision} {
+ # the constant Pi begins with 3.xxx
+ # so we need 2 digits to store the digit '3'
+ # and then we will have precision+2 bits in the mantissa
+ variable _pi0
+ if {![info exists _pi0]} {
+ set _pi0 [__pi $precision]
+ }
+ set lenPiGlobal [::math::bignum::bits $_pi0]
+ if {$lenPiGlobal<$precision} {
+ set _pi0 [__pi $precision]
+ }
+ return [::math::bignum::rshift $_pi0 [expr {[::math::bignum::bits $_pi0]-2-$precision}]]
+}
+
+################################################################################
+# computes an integer representing Pi in binary radix, with precision bits
+################################################################################
+proc ::math::bigfloat::__pi {precision} {
+ set safetyLimit 8
+ # for safety and for the better precision, we do so ...
+ incr precision $safetyLimit
+ # formula found in the Math litterature
+ # Pi/4 = 6.atan(1/18) + 8.atan(1/57) - 5.atan(1/239)
+ set a [::math::bignum::mul [_atanfract [::math::bignum::fromstr 18] $precision] \
+ [::math::bignum::fromstr 48]]
+ set a [::math::bignum::add $a [::math::bignum::mul \
+ [_atanfract [::math::bignum::fromstr 57] $precision] [::math::bignum::fromstr 32]]]
+ set a [::math::bignum::sub $a [::math::bignum::mul \
+ [_atanfract [::math::bignum::fromstr 239] $precision] [::math::bignum::fromstr 20]]]
+ return [::math::bignum::rshift $a $safetyLimit]
+}
+
+################################################################################
+# shift right an integer until it haves $precision bits
+# round at the same time
+################################################################################
+proc ::math::bigfloat::_round {integer precision} {
+ set shift [expr {[::math::bignum::bits $integer]-$precision}]
+ # $result holds the shifted integer
+ set result [::math::bignum::rshift $integer $shift]
+ # $shift-1 is the bit just rights the last bit of the result
+ # Example : integer=1000010 shift=2
+ # => result=10000 and the tested bit is '1'
+ if {[::math::bignum::testbit $integer [expr {$shift-1}]]} {
+ # we round to the upper limit
+ return [::math::bignum::add 1 $result]
+ }
+ return $result
+}
+
+################################################################################
+# returns A power B, where B is a positive integer
+################################################################################
+proc ::math::bigfloat::pow {a b} {
+ checkNumber a
+ if {![isInt $b]} {
+ error "pow : exponent is not a positive integer"
+ }
+ # case where it is obvious that we should use the appropriate command
+ # from math::bignum (added 5th March 2005)
+ if {[isInt $a]} {
+ return [::math::bignum::pow $a $b]
+ }
+ # algorithm : exponent=$b = Sum(i=0..n) b(i)2^i
+ # $a^$b = $a^( b(0) + 2b(1) + 4b(2) + ... + 2^n*b(n) )
+ # we have $a^(x+y)=$a^x * $a^y
+ # then $a^$b = Product(i=0...n) $a^(2^i*b(i))
+ # b(i) is boolean so $a^(2^i*b(i))= 1 when b(i)=0 and = $a^(2^i) when b(i)=1
+ # then $a^$b = Product(i=0...n and b(i)=1) $a^(2^i) and 1 when $b=0
+ variable one
+ if {[::math::bignum::iszero $b]} {return $one}
+ # $res holds the result
+ set res $one
+ while {1} {
+ # at the beginning i=0
+ # $remainder is b(i)
+ set remainder [::math::bignum::testbit $b 0]
+ # $b 'rshift'ed by 1 bit : i=i+1
+ # so next time we will test bit b(i+1)
+ set b [::math::bignum::rshift $b 1]
+ # if b(i)=1
+ if {$remainder} {
+ # mul the result by $a^(2^i)
+ # if i=0 we multiply by $a^(2^0)=$a^1=$a
+ set res [mul $res $a]
+ }
+ # no more bits at '1' in $b : $res is the result
+ if {[::math::bignum::iszero $b]} {
+ if {[isInt $res]} {
+ # we cannot (and should not) normalize an integer
+ return $res
+ }
+ return [normalize $res]
+ }
+ # i=i+1 : $a^(2^(i+1)) = square of $a^(2^i)
+ set a [mul $a $a]
+ }
+}
+
+################################################################################
+# converts angles for radians to degrees
+################################################################################
+proc ::math::bigfloat::rad2deg {x} {
+ checkFloat x
+ set xLen [expr {-[lindex $x 2]}]
+ if {$xLen<3} {
+ error "number too loose to convert to degrees"
+ }
+ set pi [pi $xLen 1]
+ # $rad/Pi=$deg/180
+ # so result in deg = $radians*180/Pi
+ return [div [mul $x [::math::bignum::fromstr 180]] $pi]
+}
+
+################################################################################
+# retourne la partie entire (ou 0) du nombre "number"
+################################################################################
+proc ::math::bigfloat::round {number} {
+ checkFloat number
+ #set number [normalize $number]
+ # fetching integers (or BigInts) from the internal representation
+ foreach {dummy integer exp delta} $number {break}
+ if {[::math::bignum::iszero $integer]} {
+ # returns the BigInt 0
+ variable zero
+ return $zero
+ }
+ if {$exp>=0} {
+ error "not enough precision to round (in round)"
+ }
+ set exp [expr {-$exp}]
+ # saving the sign, ...
+ set sign [::math::bignum::sign $integer]
+ set integer [abs $integer]
+ # integer part of the number
+ set try [::math::bignum::rshift $integer $exp]
+ # first bit after the dot
+ set way [::math::bignum::testbit $integer [expr {$exp-1}]]
+ # delta is shifted so it gives the integer part of 2*delta
+ set delta [::math::bignum::rshift $delta [expr {$exp-1}]]
+ # when delta is too big to compute rounded value (
+ if {![::math::bignum::iszero $delta]} {
+ error "not enough precision to round (in round)"
+ }
+ if {$way} {
+ set try [::math::bignum::add 1 $try]
+ }
+ # ... restore the sign now
+ ::math::bignum::setsign try $sign
+ return $try
+}
+
+################################################################################
+# round and divide by 10^n
+################################################################################
+proc ::math::bigfloat::roundshift {integer n} {
+ # $exp= 10^$n
+ set exp [tenPow $n]
+ foreach {result remainder} [::math::bignum::divqr $integer $exp] {}
+ # $remainder belongs to the interval [0, $exp-1]
+ # $remainder >= $exp/2 is the rounding condition
+ # that is better expressed in this form :
+ # $remainder*2 >= $exp , as we are treating integers, not rationals
+ # left shift $remainder by 1 equals to multiplying by 2 and is much faster
+ if {[::math::bignum::cmp $exp [::math::bignum::lshift $remainder 1]]<=0} {
+ return [::math::bignum::add 1 $result]
+ }
+ return $result
+}
+
+################################################################################
+# gets the sign of either a bignum, or a BitFloat
+# we keep the bignum convention : 0 for positive, 1 for negative
+################################################################################
+proc ::math::bigfloat::sign {n} {
+ if {[isInt $n]} {
+ return [::math::bignum::sign $n]
+ }
+ # sign of 0=0
+ if {[iszero $n]} {return 0}
+ # the sign of the Mantissa, which is a BigInt
+ return [::math::bignum::sign [lindex $n 1]]
+}
+
+
+################################################################################
+# gets sin(x)
+################################################################################
+proc ::math::bigfloat::sin {x} {
+ checkFloat x
+ foreach {dummy integer exp delta} $x {break}
+ if {$exp>-2} {
+ error "sin : not enough precision"
+ }
+ set precision [expr {-$exp}]
+ # sin(2kPi+x)=sin(x)
+ # $integer is now the modulo of the division of the mantissa by Pi/4
+ # and $n is the quotient
+ foreach {n integer} [divPiQuarter $integer $precision] {break}
+ set delta [::math::bignum::add $delta $n]
+ variable four
+ set d [::math::bignum::mod $n $four]
+ # now integer>=0
+ # x = $n*Pi/4 + $integer and $n belongs to [0,3]
+ # sin(2Pi-x)=-sin(x)
+ # sin(Pi-x)=sin(x)
+ # sin(Pi/2+x)=cos(x)
+ set sign 0
+ switch -- [tostr $d] {
+ 0 {set l [_sin2 $integer $precision $delta]}
+ 1 {set l [_cos2 $integer $precision $delta]}
+ 2 {set sign 1;set l [_sin2 $integer $precision $delta]}
+ 3 {set sign 1;set l [_cos2 $integer $precision $delta]}
+ default {error "internal error"}
+ }
+ # $l is a list : {Mantissa Precision Delta}
+ # precision --> the opposite of the exponent
+ # 1.000 = 1000*10^-3 so exponent=-3 and precision=3 digits
+ lset l 1 [expr {-([lindex $l 1])}]
+ set integer [lindex $l 0]
+ # the sign depends on the switch statement below
+ ::math::bignum::setsign integer $sign
+ lset l 0 $integer
+ # we insert the Bigfloat tag (F) and normalize the final result
+ return [normalize [linsert $l 0 F]]
+}
+
+proc ::math::bigfloat::_sin2 {x precision delta} {
+ set pi [_pi $precision]
+ # shift right by 1 = divide by 2
+ # shift right by 2 = divide by 4
+ set pis2 [::math::bignum::rshift $pi 1]
+ set pis4 [::math::bignum::rshift $pi 2]
+ if {[::math::bignum::cmp $x $pis4]>=0} {
+ # sin(Pi/2-x)=cos(x)
+ set delta [::math::bignum::add 1 $delta]
+ set x [::math::bignum::sub $pis2 $x]
+ return [_cos $x $precision $delta]
+ }
+ return [_sin $x $precision $delta]
+}
+
+################################################################################
+# sin(x) with 'x' lower than Pi/4 and positive
+# 'x' is the Mantissa - 'delta' is Delta
+# 'precision' is the opposite of the exponent
+################################################################################
+proc ::math::bigfloat::_sin {x precision delta} {
+ # $s holds the result
+ set s $x
+ # sin(x) = x - x^3/3! + x^5/5! - ... + (-1)^n*x^(2n+1)/(2n+1)!
+ # = x * (1 - x^2/(2*3) * (1 - x^2/(4*5) * (...* (1 - x^2/(2n*(2n+1)) )...)))
+ # The second expression allows us to compute the less we can
+
+ # $double holds the uncertainty (Delta) of x^2 : 2*(Mantissa*Delta) + Delta^2
+ # (Mantissa+Delta)^2=Mantissa^2 + 2*Mantissa*Delta + Delta^2
+ set double [::math::bignum::rshift [::math::bignum::mul $x $delta] [expr {$precision-1}]]
+ set double [::math::bignum::add [::math::bignum::add 1 $double] [::math::bignum::rshift \
+ [::math::bignum::mul $delta $delta] $precision]]
+ # $x holds the Mantissa of x^2
+ set x [intMulShift $x $x $precision]
+ set dt [::math::bignum::rshift [::math::bignum::add [::math::bignum::mul $x $delta] \
+ [::math::bignum::mul [::math::bignum::add $s $delta] $double]] $precision]
+ set dt [::math::bignum::add 1 $dt]
+ # $t holds $s * -(x^2) / (2n*(2n+1))
+ # mul by x^2
+ set t [intMulShift $s $x $precision]
+ variable two
+ set denom2 $two
+ variable three
+ set denom3 $three
+ # mul by -1 (opp) and divide by 2*3
+ set t [opp [::math::bignum::div $t [::math::bignum::mul $denom2 $denom3]]]
+ while {![::math::bignum::iszero $t]} {
+ set s [::math::bignum::add $s $t]
+ set delta [::math::bignum::add $delta $dt]
+ # incr n => 2n --> 2n+2 and 2n+1 --> 2n+3
+ set denom2 [::math::bignum::add $denom2 $two]
+ set denom3 [::math::bignum::add $denom3 $two]
+ # $dt is the Delta corresponding to $t
+ # $double "" "" "" "" $x (x^2)
+ # ($t+$dt) * ($x+$double) = $t*$x + ($dt*$x + $t*$double) + $dt*$double
+ # Mantissa^ ^--------Delta-------------------^
+ set dt [::math::bignum::rshift [::math::bignum::add [::math::bignum::mul $x $dt] \
+ [::math::bignum::mul [::math::bignum::add $t $dt] $double]] $precision]
+ set t [intMulShift $t $x $precision]
+ # removed 2005/08/31 by sarnold75
+ #set dt [::math::bignum::add $dt $double]
+ set denom [::math::bignum::mul $denom2 $denom3]
+ # now computing : div by -2n(2n+1)
+ set dt [::math::bignum::add 1 [::math::bignum::div $dt $denom]]
+ set t [opp [::math::bignum::div $t $denom]]
+ }
+ return [list $s $precision $delta]
+}
+
+
+################################################################################
+# procedure for extracting the square root of a BigFloat
+################################################################################
+proc ::math::bigfloat::sqrt {x} {
+ variable one
+ checkFloat x
+ foreach {dummy integer exp delta} $x {break}
+ # if x=0, return 0
+ if {[iszero $x]} {
+ variable zero
+ # return zero, taking care of its precision ($exp)
+ return [list F $zero $exp $one]
+ }
+ # we cannot get sqrt(x) if x<0
+ if {[lindex $integer 0]<0} {
+ error "negative sqrt input"
+ }
+ # (1+epsilon)^p = 1 + epsilon*(p-1) + epsilon^2*(p-1)*(p-2)/2! + ...
+ # + epsilon^n*(p-1)*...*(p-n)/n!
+ # sqrt(1 + epsilon) = (1 + epsilon)^(1/2)
+ # = 1 - epsilon/2 - epsilon^2*3/(4*2!) - ...
+ # - epsilon^n*(3*5*..*(2n-1))/(2^n*n!)
+ # sqrt(1 - epsilon) = 1 + Sum(i=1..infinity) epsilon^i*(3*5*...*(2i-1))/(i!*2^i)
+ # sqrt(n +/- delta)=sqrt(n) * sqrt(1 +/- delta/n)
+ # so the uncertainty on sqrt(n +/- delta) equals sqrt(n) * (sqrt(1 - delta/n) - 1)
+ # sqrt(1+eps) < sqrt(1-eps) because their logarithm compare as :
+ # -ln(2)(1+eps) < -ln(2)(1-eps)
+ # finally :
+ # Delta = sqrt(n) * Sum(i=1..infinity) (delta/n)^i*(3*5*...*(2i-1))/(i!*2^i)
+ # here we compute the second term of the product by _sqrtOnePlusEpsilon
+ set delta [_sqrtOnePlusEpsilon $delta $integer]
+ set intLen [::math::bignum::bits $integer]
+ # removed 2005/08/31 by sarnold75, readded 2005/08/31
+ set precision $intLen
+ # intLen + exp = number of bits before the dot
+ #set precision [expr {-$exp}]
+ # square root extraction
+ set integer [::math::bignum::lshift $integer $intLen]
+ incr exp -$intLen
+ incr intLen $intLen
+ # there is an exponent 2^$exp : when $exp is odd, we would need to compute sqrt(2)
+ # so we decrement $exp, in order to get it even, and we do not need sqrt(2) anymore !
+ if {$exp&1} {
+ incr exp -1
+ set integer [::math::bignum::lshift $integer 1]
+ incr intLen
+ incr precision
+ }
+ # using a low-level (in math::bignum) root extraction procedure
+ set integer [::math::bignum::sqrt $integer]
+ # delta has to be multiplied by the square root
+ set delta [::math::bignum::rshift [::math::bignum::mul $delta $integer] $precision]
+ # round to the ceiling the uncertainty (worst precision, the fastest to compute)
+ set delta [::math::bignum::add 1 $delta]
+ # we are sure that $exp is even, see above
+ return [normalize [list F $integer [expr {$exp/2}] $delta]]
+}
+
+
+
+################################################################################
+# compute abs(sqrt(1-delta/integer)-1)
+# the returned value is a relative uncertainty
+################################################################################
+proc ::math::bigfloat::_sqrtOnePlusEpsilon {delta integer} {
+ # sqrt(1-x) - 1 = x/2 + x^2*3/(2^2*2!) + x^3*3*5/(2^3*3!) + ...
+ # = x/2 * (1 + x*3/(2*2) * ( 1 + x*5/(2*3) *
+ # (...* (1 + x*(2n-1)/(2n) ) )...)))
+ variable one
+ set l [::math::bignum::bits $integer]
+ # to compute delta/integer we have to shift left to keep the same precision level
+ # we have a better accuracy computing (delta << lg(integer))/integer
+ # than computing (delta/integer) << lg(integer)
+ set x [::math::bignum::div [::math::bignum::lshift $delta $l] $integer]
+ variable four
+ variable two
+ # denom holds 2n
+ set denom $four
+ # x/2
+ set result [::math::bignum::div $x $two]
+ # x^2*3/(2!*2^2)
+ variable three
+ # numerator holds 2n-1
+ set numerator $three
+ set temp [::math::bignum::mul $result $delta]
+ set temp [::math::bignum::div [::math::bignum::mul $temp $numerator] $integer]
+ set temp [::math::bignum::add 1 [::math::bignum::div $temp $denom]]
+ while {![::math::bignum::iszero $temp]} {
+ set result [::math::bignum::add $result $temp]
+ set numerator [::math::bignum::add $numerator $two]
+ set denom [::math::bignum::add $two $denom]
+ # n = n+1 ==> num=num+2 denom=denom+2
+ # num=2n+1 denom=2n+2
+ set temp [::math::bignum::mul [::math::bignum::mul $temp $delta] $numerator]
+ set temp [::math::bignum::div [::math::bignum::div $temp $denom] $integer]
+ }
+ return $result
+}
+
+################################################################################
+# substracts B to A
+################################################################################
+proc ::math::bigfloat::sub {a b} {
+ checkNumber a b
+ if {[isInt $a] && [isInt $b]} {
+ # the math::bignum::sub proc is designed to work with BigInts
+ return [::math::bignum::sub $a $b]
+ }
+ return [add $a [opp $b]]
+}
+
+################################################################################
+# tangent (trivial algorithm)
+################################################################################
+proc ::math::bigfloat::tan {x} {
+ return [::math::bigfloat::div [::math::bigfloat::sin $x] [::math::bigfloat::cos $x]]
+}
+
+################################################################################
+# returns a power of ten
+################################################################################
+proc ::math::bigfloat::tenPow {n} {
+ variable ten
+ return [::math::bignum::pow $ten [::math::bignum::fromstr $n]]
+}
+
+
+################################################################################
+# converts a BigInt to a double (basic floating-point type)
+# with respect to the global variable 'tcl_precision'
+################################################################################
+proc ::math::bigfloat::todouble {x} {
+ global tcl_precision
+ checkFloat x
+ # get the string repr of x without the '+' sign
+ set result [string trimleft [tostr $x] +]
+ set minus ""
+ if {[string index $result 0]=="-"} {
+ set minus -
+ set result [string range $result 1 end]
+ }
+ set l [split $result e]
+ set exp 0
+ if {[llength $l]==2} {
+ # exp : x=Mantissa*10^Exp
+ set exp [lindex $l 1]
+ }
+ # Mantissa = integerPart.fractionalPart
+ set l [split [lindex $l 0] .]
+ set integerPart [lindex $l 0]
+ set integerLen [string length $integerPart]
+ set fractionalPart [lindex $l 1]
+ # The number of digits in Mantissa, excluding the dot and the leading zeros, of course
+ set len [string length [set integer $integerPart$fractionalPart]]
+ # Now Mantissa is stored in $integer
+ if {$len>$tcl_precision} {
+ set lenDiff [expr {$len-$tcl_precision}]
+ # true when the number begins with a zero
+ set zeroHead 0
+ if {[string index $integer 0]==0} {
+ incr lenDiff -1
+ set zeroHead 1
+ }
+ set integer [tostr [roundshift [::math::bignum::fromstr $integer] $lenDiff]]
+ if {$zeroHead} {
+ set integer 0$integer
+ }
+ set len [string length $integer]
+ if {$len<$integerLen} {
+ set exp [expr {$integerLen-$len}]
+ # restore the true length
+ set integerLen $len
+ }
+ }
+ # number = 'sign'*'integer'*10^'exp'
+ if {$exp==0} {
+ # no scientific notation
+ set exp ""
+ } else {
+ # scientific notation
+ set exp e$exp
+ }
+ # place the dot just before the index $integerLen in the Mantissa
+ set result [string range $integer 0 [expr {$integerLen-1}]]
+ append result .[string range $integer $integerLen end]
+ # join the Mantissa with the sign before and the exponent after
+ return $minus$result$exp
+}
+
+################################################################################
+# converts a number stored as a list to a string in which all digits are true
+################################################################################
+proc ::math::bigfloat::tostr {args} {
+ variable five
+ if {[llength $args]==2} {
+ if {![string equal [lindex $args 0] -nosci]} {error "unknown option: should be -nosci"}
+ set nosci yes
+ set number [lindex $args 1]
+ } else {
+ if {[llength $args]!=1} {error "syntax error: should be tostr ?-nosci? number"}
+ set nosci no
+ set number [lindex $args 0]
+ }
+ if {[isInt $number]} {
+ return [::math::bignum::tostr $number]
+ }
+ checkFloat number
+ foreach {dummy integer exp delta} $number {break}
+ if {[iszero $number]} {
+ # we do not matter how much precision $number has :
+ # it can be 0.0000000 or 0.0, the result is still the same : the "0" string
+ # not anymore : 0.000 is not 0.0 !
+ # return 0
+ }
+ if {$exp>0} {
+ # the power of ten the closest but greater than 2^$exp
+ # if it was lower than the power of 2, we would have more precision
+ # than existing in the number
+ set newExp [expr {int(ceil($exp*log(2)/log(10)))}]
+ # 'integer' <- 'integer' * 2^exp / 10^newExp
+ # equals 'integer' * 2^(exp-newExp) / 5^newExp
+ set binExp [expr {$exp-$newExp}]
+ if {$binExp<0} {
+ # it cannot happen
+ error "internal error"
+ }
+ # 5^newExp
+ set fivePower [::math::bignum::pow $five [::math::bignum::fromstr $newExp]]
+ # 'lshift'ing $integer by $binExp bits is like multiplying it by 2^$binExp
+ # but much, much faster
+ set integer [::math::bignum::div [::math::bignum::lshift $integer $binExp] \
+ $fivePower]
+ # $integer is the Mantissa - Delta should follow the same operations
+ set delta [::math::bignum::div [::math::bignum::lshift $delta $binExp] $fivePower]
+ set exp $newExp
+ } elseif {$exp<0} {
+ # the power of ten the closest but lower than 2^$exp
+ # same remark about the precision
+ set newExp [expr {int(floor(-$exp*log(2)/log(10)))}]
+ # 'integer' <- 'integer' * 10^newExp / 2^(-exp)
+ # equals 'integer' * 5^(newExp) / 2^(-exp-newExp)
+ set fivePower [::math::bignum::pow $five \
+ [::math::bignum::fromstr $newExp]]
+ set binShift [expr {-$exp-$newExp}]
+ # rshifting is like dividing by 2^$binShift, but faster as we said above about lshift
+ set integer [::math::bignum::rshift [::math::bignum::mul $integer $fivePower] \
+ $binShift]
+ set delta [::math::bignum::rshift [::math::bignum::mul $delta $fivePower] \
+ $binShift]
+ set exp -$newExp
+ }
+ # saving the sign, to restore it into the result
+ set sign [::math::bignum::sign $integer]
+ set result [::math::bignum::abs $integer]
+ # rounded 'integer' +/- 'delta'
+ set up [::math::bignum::add $result $delta]
+ set down [::math::bignum::sub $result $delta]
+ if {[sign $up]^[sign $down]} {
+ # $up>0 and $down<0 and vice-versa : then the number is considered equal to zero
+ # delta <= 2**n (n = bits(delta))
+ # 2**n <= 10**exp , then
+ # exp >= n.log(2)/log(10)
+ # delta <= 10**(n.log(2)/log(10))
+ incr exp [expr {int(ceil([::math::bignum::bits $delta]*log(2)/log(10)))}]
+ set result 0
+ set isZero yes
+ } else {
+ # iterate until the convergence of the rounding
+ # we incr $shift until $up and $down are rounded to the same number
+ # at each pass we lose one digit of precision, so necessarly it will success
+ for {set shift 1} {
+ [::math::bignum::cmp [roundshift $up $shift] [roundshift $down $shift]]
+ } {
+ incr shift
+ } {}
+ incr exp $shift
+ set result [::math::bignum::tostr [roundshift $up $shift]]
+ set isZero no
+ }
+ set l [string length $result]
+ # now formatting the number the most nicely for having a clear reading
+ # would'nt we allow a number being constantly displayed
+ # as : 0.2947497845e+012 , would we ?
+ if {$nosci} {
+ if {$exp >= 0} {
+ append result [string repeat 0 $exp].
+ } elseif {$l + $exp > 0} {
+ set result [string range $result 0 end-[expr {-$exp}]].[string range $result end-[expr {-1-$exp}] end]
+ } else {
+ set result 0.[string repeat 0 [expr {-$exp-$l}]]$result
+ }
+ } else {
+ if {$exp>0} {
+ # we display 423*10^6 as : 4.23e+8
+ # Length of mantissa : $l
+ # Increment exp by $l-1 because the first digit is placed before the dot,
+ # the other ($l-1) digits following the dot.
+ incr exp [incr l -1]
+ set result [string index $result 0].[string range $result 1 end]
+ append result "e+$exp"
+ } elseif {$exp==0} {
+ # it must have a dot to be a floating-point number (syntaxically speaking)
+ append result .
+ } else {
+ set exp [expr {-$exp}]
+ if {$exp < $l} {
+ # we can display the number nicely as xxxx.yyyy*
+ # the problem of the sign is solved finally at the bottom of the proc
+ set n [string range $result 0 end-$exp]
+ incr exp -1
+ append n .[string range $result end-$exp end]
+ set result $n
+ } elseif {$l==$exp} {
+ # we avoid to use the scientific notation
+ # because it is harder to read
+ set result "0.$result"
+ } else {
+ # ... but here there is no choice, we should not represent a number
+ # with more than one leading zero
+ set result [string index $result 0].[string range $result 1 end]e-[expr {$exp-$l+1}]
+ }
+ }
+ }
+ # restore the sign : we only put a minus on numbers that are different from zero
+ if {$sign==1 && !$isZero} {set result "-$result"}
+ return $result
+}
+
+################################################################################
+# PART IV
+# HYPERBOLIC FUNCTIONS
+################################################################################
+
+################################################################################
+# hyperbolic cosinus
+################################################################################
+proc ::math::bigfloat::cosh {x} {
+ # cosh(x) = (exp(x)+exp(-x))/2
+ # dividing by 2 is done faster by 'rshift'ing
+ return [floatRShift [add [exp $x] [exp [opp $x]]] 1]
+}
+
+################################################################################
+# hyperbolic sinus
+################################################################################
+proc ::math::bigfloat::sinh {x} {
+ # sinh(x) = (exp(x)-exp(-x))/2
+ # dividing by 2 is done faster by 'rshift'ing
+ return [floatRShift [sub [exp $x] [exp [opp $x]]] 1]
+}
+
+################################################################################
+# hyperbolic tangent
+################################################################################
+proc ::math::bigfloat::tanh {x} {
+ set up [exp $x]
+ set down [exp [opp $x]]
+ # tanh(x)=sinh(x)/cosh(x)= (exp(x)-exp(-x))/2/ [(exp(x)+exp(-x))/2]
+ # =(exp(x)-exp(-x))/(exp(x)+exp(-x))
+ # =($up-$down)/($up+$down)
+ return [div [sub $up $down] [add $up $down]]
+}
+
+# exporting public interface
+namespace eval ::math::bigfloat {
+ foreach function {
+ add mul sub div mod pow
+ iszero compare equal
+ fromstr tostr fromdouble todouble
+ int2float isInt isFloat
+ exp log sqrt round ceil floor
+ sin cos tan cotan asin acos atan
+ cosh sinh tanh abs opp
+ pi deg2rad rad2deg
+ } {
+ namespace export $function
+ }
+}
+
+# (AM) No "namespace import" - this should be left to the user!
+#namespace import ::math::bigfloat::*
+
+package provide math::bigfloat 1.2.2
diff --git a/tcllib/modules/math/bigfloat.test b/tcllib/modules/math/bigfloat.test
new file mode 100755
index 0000000..7fa05ed
--- /dev/null
+++ b/tcllib/modules/math/bigfloat.test
@@ -0,0 +1,683 @@
+# -*- tcl -*-
+########################################################################
+# BigFloat for Tcl
+# Copyright (C) 2003-2005 ARNOLD Stephane
+#
+# BIGFLOAT LICENSE TERMS
+#
+# This software is copyrighted by Stephane ARNOLD, (stephanearnold <at> yahoo.fr).
+# The following terms apply to all files associated
+# with the software unless explicitly disclaimed in individual files.
+#
+# The authors hereby grant permission to use, copy, modify, distribute,
+# and license this software and its documentation for any purpose, provided
+# that existing copyright notices are retained in all copies and that this
+# notice is included verbatim in any distributions. No written agreement,
+# license, or royalty fee is required for any of the authorized uses.
+# Modifications to this software may be copyrighted by their authors
+# and need not follow the licensing terms described here, provided that
+# the new terms are clearly indicated on the first page of each file where
+# they apply.
+#
+# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+#
+# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+# MODIFICATIONS.
+#
+# GOVERNMENT USE: If you are acquiring this software on behalf of the
+# U.S. government, the Government shall have only "Restricted Rights"
+# in the software and related documentation as defined in the Federal
+# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
+# are acquiring the software on behalf of the Department of Defense, the
+# software shall be classified as "Commercial Computer Software" and the
+# Government shall have only "Restricted Rights" as defined in Clause
+# 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
+# authors grant the U.S. Government and others acting in its behalf
+# permission to use and distribute the software in accordance with the
+# terms specified in this license.
+#
+########################################################################
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 1.0
+
+support {
+ useLocal math.tcl math
+ useLocal bignum.tcl math::bignum
+}
+testing {
+ useLocal bigfloat.tcl math::bigfloat
+}
+
+# -------------------------------------------------------------------------
+
+namespace import ::math::bigfloat::*
+
+# -------------------------------------------------------------------------
+
+proc assert {name version code result} {
+ #puts -nonewline $version,
+ test bigfloat-$name-$version \
+ "Some integer computations related to command $name" {
+ uplevel 1 $code
+ } $result ; # {}
+ return
+}
+
+interp alias {} zero {} string repeat 0
+# S.ARNOLD 08/01/2005
+# trying to set the precision of the comparisons to 15 digits
+set old_precision $::tcl_precision
+set ::tcl_precision 15
+proc Zero {x} {
+ global tcl_precision
+ set x [expr {abs($x)}]
+ set epsilon 10.0e-$tcl_precision
+ return [expr {$x<$epsilon}]
+}
+
+proc fassert {name version code result} {
+ #puts -nonewline $version,
+ set tested [uplevel 1 $code]
+
+ if {[Zero $tested]} {
+ tcltest::test bigfloat-$name-$version \
+ "Some floating-point computations related to command $name" {
+ return [Zero $result]
+ } 1 ; # {}
+ return
+ }
+
+ set resultat [Zero [expr {($tested-$result)/((abs($tested)>1)?($tested):1.0)}]]
+
+ tcltest::test bigfloat-$name-$version \
+ "Some floating-point computations related to command $name" {
+ return $resultat
+ } 1 ; # {}
+ return
+}
+# preprocessing is done
+#set n
+
+
+######################################################
+# Begin testsuite
+######################################################
+
+# adds 999..9 and 1 -> 1000..0
+for {set i 1} {$i<15} {incr i} {
+ assert add 1.0.$i {
+ tostr [add \
+ [fromstr [string repeat 999 $i]] [fromstr 1]]
+ } 1[string repeat 000 $i] ; # {}
+}
+
+# sub 1000..0 1 -> 999..9
+for {set i 1} {$i<15} {incr i} {
+ assert sub 1.1.$i {
+ tostr [sub [fromstr 1[string repeat 000 $i]] [fromstr 1]]
+ } [string repeat 999 $i] ; # {}
+}
+
+# mul 10001000..1000 with 1..9
+for {set i 1} {$i<15} {incr i} {
+ foreach j {1 2 3 4 5 6 7 8 9} {
+ assert mul 1.2.$i.$j {tostr [mul [fromstr [string repeat 1000 $i]] [fromstr $j]]} \
+ [string repeat ${j}000 $i]
+ }
+}
+
+# div 10^8 by 1 .. 9
+for {set i 1} {$i<=9} {incr i} {
+ assert div 1.3.$i {tostr [div [fromstr 100000000] [fromstr $i]]} [expr {wide(100000000)/$i}]
+}
+
+# 10^8 modulo 1 .. 9
+for {set i 1} {$i<=9} {incr i} {
+ assert mod 1.4.$i {tostr [mod [fromstr 100000000] [fromstr $i]]} [expr {wide(100000000)%$i}]
+}
+
+################################################################################
+# fromstr problem with octal exponents
+################################################################################
+
+fassert fromstr 2.0 {todouble [fromstr 1.0e+099]} 1.0e+099
+fassert fromstr 2.0a {todouble [fromstr 1.0e99]} 1.0e99
+fassert fromstr 2.0b {todouble [fromstr 1.0e-99]} 1.0e-99
+fassert fromstr 2.0c {todouble [fromstr 1.0e-099]} 1.0e-99
+
+################################################################################
+# fromdouble with precision
+################################################################################
+
+assert fromdouble 2.1 {tostr [ceil [fromdouble 1.0e99 100]]} 1[zero 99]
+assert fromdouble 2.1a {tostr [fromdouble 1.11 3]} 1.11
+assert fromdouble 2.1b {tostr [fromdouble +1.11 3]} 1.11
+assert fromdouble 2.1c {tostr [fromdouble -1.11 3]} -1.11
+assert fromdouble 2.1d {tostr [fromdouble +01.11 3]} 1.11
+assert fromdouble 2.1e {tostr [fromdouble -01.11 3]} -1.11
+
+# more to come...
+fassert fromdouble 2.1f {compare [fromdouble [expr {atan(1.0)*4}]] [pi $::tcl_precision]} 0
+
+################################################################################
+# abs()
+################################################################################
+proc absTest {version x {int 0}} {
+ if {!$int} {
+ fassert abs $version {
+ tostr [abs [fromstr $x]]
+ } [expr {abs($x)}] ; # {}
+ } else {
+ assert abs $version {
+ tostr [abs [fromstr $x]]
+ } [expr {($x<0)?(-$x):$x}] ; # {}
+ }
+}
+
+absTest 2.2a 1.000
+absTest 2.2b -1.000
+absTest 2.2c -0.10
+absTest 2.2d 0 1
+absTest 2.2e 1 1
+absTest 2.2f 10000 1
+absTest 2.2g -1 1
+absTest 2.2h -10000 1
+rename absTest ""
+
+################################################################################
+# opposite
+################################################################################
+proc oppTest {version x {int 0}} {
+ if {$int} {
+ assert opp $version {tostr [opp [fromstr $x]]} [expr {-$x}]
+ } else {
+ fassert opp $version {tostr [opp [fromstr $x]]} [expr {-$x}]
+ }
+}
+
+oppTest 2.3a 1.00
+oppTest 2.3b -1.00
+oppTest 2.3c 0.10
+oppTest 2.3d -0.10
+oppTest 2.3e 0.00
+oppTest 2.3f 1 1
+oppTest 2.3g -1 1
+oppTest 2.3h 0 1
+oppTest 2.3i 100000000 1
+oppTest 2.3j -100000000 1
+rename oppTest ""
+
+################################################################################
+# equal
+################################################################################
+proc equalTest {x y} {
+ equal [fromstr $x] [fromstr $y]
+}
+
+assert equal 2.4a {equalTest 0.0 0.1} 1
+assert equal 2.4b {equalTest 0.00 0.10} 0
+assert equal 2.4c {equalTest 0.0 -0.1} 1
+assert equal 2.4d {equalTest 0.00 -0.10} 0
+
+rename equalTest ""
+################################################################################
+# compare
+################################################################################
+proc compareTest {x y} {
+ compare [fromstr $x] [fromstr $y]
+}
+
+assert cmp 2.5a {compareTest 0.00 0.10} -1
+assert cmp 2.5b {compareTest 0.1 0.4} -1
+assert cmp 2.5c {compareTest 0.0 -1.0} 1
+assert cmp 2.5d {compareTest -1.0 0.0} -1
+assert cmp 2.5e {compareTest 0.00 0.10} -1
+
+# cleanup
+rename compareTest ""
+
+################################################################################
+# round
+################################################################################
+proc roundTest {version x rounded} {
+ assert round $version {tostr [round [fromstr $x]]} $rounded
+}
+
+roundTest 2.6.0 0.10 0
+roundTest 2.6.1 0.0 0
+roundTest 2.6.2 0.50 1
+roundTest 2.6.3 0.40 0
+roundTest 2.6.4 1.0 1
+roundTest 2.6.5 -0.40 0
+roundTest 2.6.6 -0.50 -1
+roundTest 2.6.7 -1.0 -1
+roundTest 2.6.8 -1.50 -2
+roundTest 2.6.9 1.50 2
+
+# cleanup
+rename roundTest ""
+
+################################################################################
+# floor
+################################################################################
+proc floorTest {version x} {
+ assert floor $version {tostr [floor [fromstr $x]]} [expr {int(floor($x))}]
+}
+floorTest 2.7a 0.10
+floorTest 2.7b 0.90
+floorTest 2.7c 1.0
+floorTest 2.7d -0.10
+floorTest 2.7e -1.0
+
+# cleanup
+rename floorTest ""
+
+################################################################################
+# ceil
+################################################################################
+proc ceilTest {version x} {
+ assert ceil $version {tostr [ceil [fromstr $x]]} [expr {int(ceil($x))}]
+}
+ceilTest 2.8a 0.10
+ceilTest 2.8b 0.90
+ceilTest 2.8c 1.0
+ceilTest 2.8d -0.10
+ceilTest 2.8e -1.0
+ceilTest 2.8f 0.0
+
+# cleanup
+rename ceilTest ""
+
+################################################################################
+# BigInt to BigFloat conversion
+################################################################################
+proc convTest {version x {decimals 1}} {
+ assert int2float $version {tostr [int2float [fromstr $x] $decimals]} \
+ $x.[string repeat 0 [expr {$decimals-1}]]
+}
+set subversion 0
+foreach decimals {1 2 5 10 100} {
+ set version 2.9.$subversion
+ fassert int2float $version.0 {tostr [int2float [fromstr 0] $decimals]} 0.0
+ convTest $version.1 1 $decimals
+ convTest $version.2 5 $decimals
+ convTest $version.3 5000000000 $decimals
+ incr subversion
+}
+#cleanup
+rename convTest ""
+
+################################################################################
+# addition
+################################################################################
+proc addTest {version x y} {
+ fassert add $version {todouble [add [fromstr $x] [fromstr $y]]} [expr {$x+$y}]
+}
+addTest 3.0a 1.00 2.00
+addTest 3.0b -1.00 2.00
+addTest 3.0c 1.00 -2.00
+addTest 3.0d -1.00 -2.00
+addTest 3.0e 0.00 1.00
+addTest 3.0f 0.00 -1.00
+addTest 3.0g 1 2.00
+addTest 3.0h 1 -2.00
+addTest 3.0i 0 1.00
+addTest 3.0j 0 -1.00
+addTest 3.0k 2.00 1
+addTest 3.0l -2.00 1
+addTest 3.0m 1.00 0
+addTest 3.0n -1.00 0
+#cleanup
+rename addTest ""
+
+################################################################################
+# substraction
+################################################################################
+proc subTest {version x y} {
+ fassert sub $version {todouble [sub [fromstr $x] [fromstr $y]]} [expr {$x-$y}]
+}
+subTest 3.1a 1.00 2.00
+subTest 3.1b -1.00 2.00
+subTest 3.1c 1.00 -2.00
+subTest 3.1d -1.00 -2.00
+subTest 3.1e 0.00 1.00
+subTest 3.1f 0.00 -1.00
+subTest 3.1g 1 2.00
+subTest 3.1h 1 -2.00
+subTest 3.1i 0 2.00
+subTest 3.1j 0 -2.00
+subTest 3.1k 2 0.00
+subTest 3.1l 2.00 1
+subTest 3.1m 1.00 2
+subTest 3.1n -1.00 1
+subTest 3.1o 0.00 2
+subTest 3.1p 2.00 0
+# cleanup
+rename subTest ""
+
+################################################################################
+# multiplication
+################################################################################
+proc mulTest {version x y} {
+ fassert mul $version {todouble [mul [fromstr $x] [fromstr $y]]} [expr {$x*$y}]
+}
+proc mulInt {version x y} {
+ mulTest $version.0 $x $y
+ mulTest $version.1 $y $x
+}
+mulTest 3.2a 1.00 2.00
+mulTest 3.2b -1.00 2.00
+mulTest 3.2c 1.00 -2.00
+mulTest 3.2d -1.00 -2.00
+mulTest 3.2e 0.00 1.00
+mulTest 3.2f 0.00 -1.00
+mulTest 3.2g 1.00 10.0
+mulInt 3.2h 1 2.00
+mulInt 3.2i 1 -2.00
+mulInt 3.2j 0 2.00
+mulInt 3.2k 0 -2.00
+mulInt 3.2l 10 2.00
+mulInt 3.2m 10 -2.00
+mulInt 3.2n 1 0.00
+
+
+# cleanup
+rename mulTest ""
+rename mulInt ""
+
+################################################################################
+# division
+################################################################################
+proc divTest {version x y} {
+ fassert div $version {
+ string trimright [todouble [div [fromstr $x] [fromstr $y]]] 0
+ } [string trimright [expr {$x/$y}] 0] ; # {}
+}
+
+
+divTest 3.3a 1.00 2.00
+divTest 3.3b 2.00 1.00
+divTest 3.3c -1.00 2.00
+divTest 3.3d 1.00 -2.00
+divTest 3.3e 2.00 -1.00
+divTest 3.3f -2.00 1.00
+divTest 3.3g -1.00 -2.00
+divTest 3.3h -2.00 -1.00
+divTest 3.3i 0.0 1.0
+divTest 3.3j 0.0 -1.0
+
+# cleanup
+rename divTest ""
+
+################################################################################
+# rest of the division
+################################################################################
+proc modTest {version x y} {
+ fassert mod $version {
+ todouble [mod [fromstr $x] [fromstr $y]]
+ } [expr {fmod($x,$y)}] ; # {}
+}
+
+modTest 3.4a 1.00 2.00
+modTest 3.4b 2.00 1.00
+modTest 3.4c -1.00 2.00
+modTest 3.4d 1.00 -2.00
+modTest 3.4e 2.00 -1.00
+modTest 3.4f -2.00 1.00
+modTest 3.4g -1.00 -2.00
+modTest 3.4h -2.00 -1.00
+modTest 3.4i 0.0 1.0
+modTest 3.4j 0.0 -1.0
+
+modTest 3.4k 1.00 2
+modTest 3.4l 2.00 1
+modTest 3.4m -1.00 2
+modTest 3.4n -2.00 1
+modTest 3.4o 0.0 1
+modTest 3.4p 1.50 1
+
+# cleanup
+rename modTest ""
+
+################################################################################
+# divide a BigFloat by an integer
+################################################################################
+proc divTest {version x y} {
+ fassert div $version {todouble [div [fromstr $x] [fromstr $y]]} \
+ [expr {double(round(1000*$x/$y))/1000.0}]
+}
+set subversion 0
+foreach a {1.0000 -1.0000} {
+ foreach b {2 3} {
+ divTest 3.5.$subversion $a $b
+ incr subversion
+ }
+}
+
+# cleanup
+rename divTest ""
+
+################################################################################
+# pow : takes a float to an integer power (>0)
+################################################################################
+proc powTest {version x y {int 0}} {
+ if {!$int} {
+ fassert pow $version {todouble [pow [fromstr $x 14] [fromstr $y]]}\
+ [expr [join [string repeat "[string trimright $x 0] " $y] *]]
+ } else {
+ assert pow $version {tostr [pow [fromstr $x] [fromstr $y]]}\
+ [expr [join [string repeat "$x " $y] *]]
+ }
+}
+set subversion 0
+foreach a {1 -1 2 -2 5 -5} {
+ foreach b {2 3 7 16} {
+ powTest 3.6.$subversion $a. $b
+ incr subversion
+ }
+}
+set subversion 0
+foreach a {1 2 3} {
+ foreach b {2 3 5 8} {
+ powTest 3.7.$subversion $a $b 1
+ incr subversion
+ }
+}
+
+# cleanup
+rename powTest ""
+
+
+################################################################################
+# pi constant and angles conversion
+################################################################################
+fassert pi 3.8.0 {todouble [pi 16]} [expr {atan(1)*4}]
+# converts Pi -> 180
+fassert rad2deg 3.8.1 {todouble [rad2deg [pi 20]]} 180.0
+# converts 180 -> Pi
+fassert deg2rad 3.8.2 {todouble [deg2rad [fromstr 180.0 20]]} [expr {atan(1.0)*4}]
+
+
+################################################################################
+# iszero : the precision is too small to determinate the number
+################################################################################
+
+assert iszero 4.0a {iszero [fromstr 0]} 1
+assert iszero 4.0b {iszero [fromstr 0.0]} 1
+assert iszero 4.0c {iszero [fromstr 1]} 0
+assert iszero 4.0d {iszero [fromstr 1.0]} 0
+assert iszero 4.0e {iszero [fromstr -1]} 0
+assert iszero 4.0f {iszero [fromstr -1.0]} 0
+
+################################################################################
+# sqrt : square root
+################################################################################
+proc sqrtTest {version x} {
+ fassert sqrt $version {todouble [sqrt [fromstr $x 18]]} [expr {sqrt($x)}]
+}
+sqrtTest 4.1a 1.
+sqrtTest 4.1b 0.001
+sqrtTest 4.1c 0.004
+sqrtTest 4.1d 4.
+
+# cleanup
+rename sqrtTest ""
+
+
+################################################################################
+# expTest : exponential function
+################################################################################
+proc expTest {version x} {
+ fassert exp $version {todouble [exp [fromstr $x 17]]} [expr {exp($x)}]
+}
+
+expTest 4.2a 1.
+expTest 4.2b 0.001
+expTest 4.2c 0.004
+expTest 4.2d 40.
+expTest 4.2e -0.001
+
+# cleanup
+rename expTest ""
+
+################################################################################
+# logTest : logarithm
+################################################################################
+proc logTest {version x} {
+ fassert log $version {todouble [log [fromstr $x 17]]} [expr {log($x)}]
+}
+
+logTest 4.3a 1.0
+logTest 4.3b 0.001
+logTest 4.3c 0.004
+logTest 4.3d 40.
+logTest 4.3e 1[zero 10].0
+
+# cleanup
+rename logTest ""
+
+################################################################################
+# cos & sin : trigonometry
+################################################################################
+proc cosEtSin {version quartersOfPi} {
+ set x [div [mul [pi 18] [fromstr $quartersOfPi]] [fromstr 4]]
+ #fassert cos {todouble [cos $x]} [expr {cos(atan(1)*$quartersOfPi)}]
+ #fassert sin {todouble [sin $x]} [expr {sin(atan(1)*$quartersOfPi)}]
+ fassert cos $version.0 {todouble [cos $x]} [expr {cos([todouble $x])}]
+ fassert sin $version.1 {todouble [sin $x]} [expr {sin([todouble $x])}]
+}
+
+fassert cos 4.4.0.0 {todouble [cos [fromstr 0. 17]]} [expr {cos(0)}]
+fassert sin 4.4.0.1 {todouble [sin [fromstr 0. 17]]} [expr {sin(0)}]
+foreach i {1 2 3 4 5 6 7 8} {
+ cosEtSin 4.4.$i $i
+}
+
+
+# cleanup
+rename cosEtSin ""
+
+################################################################################
+# tan & cotan : trigonometry
+################################################################################
+proc tanCotan {version i} {
+ upvar pi pi
+ set x [div [mul $pi [fromstr $i]] [fromstr 10]]
+ set double [expr {atan(1)*(double($i)*0.4)}]
+ fassert cos $version.0 {todouble [cos $x]} [expr {cos($double)}]
+ fassert sin $version.1 {todouble [sin $x]} [expr {sin($double)}]
+ fassert tan $version.2 {todouble [tan $x]} [expr {tan($double)}]
+ fassert cotan $version.3 {todouble [cotan $x]} [expr {double(1.0)/tan($double)}]
+}
+
+set pi [pi 20]
+set subversion 0
+foreach i {1 2 3 6 7 8 9} {
+ tanCotan 4.5.$subversion $i
+ incr subversion
+}
+
+
+# cleanup
+rename tanCotan ""
+
+
+################################################################################
+# atan , asin & acos : trigonometry (inverse functions)
+################################################################################
+proc atanTest {version x} {
+ set f [fromstr $x 20]
+ fassert atan $version.0 {todouble [atan $f]} [expr {atan($x)}]
+ if {abs($x)<=1.0} {
+ fassert acos $version.1 {todouble [acos $f]} [expr {acos($x)}]
+ fassert asin $version.2 {todouble [asin $f]} [expr {asin($x)}]
+ }
+}
+set subversion 0
+atanTest 4.6.0.0 0.0
+foreach i {1 2 3 4 5 6 7 8 9} {
+ atanTest 4.6.1.$subversion 0.$i
+ atanTest 4.6.2.$subversion $i.0
+ atanTest 4.6.3.$subversion -0.$i
+ atanTest 4.6.4.$subversion -$i.0
+ incr subversion
+}
+
+# cleanup
+rename atanTest ""
+
+################################################################################
+# cosh , sinh & tanh : hyperbolic functions
+################################################################################
+proc hyper {version x} {
+ set f [fromstr $x 18]
+ fassert cosh $version.0 {todouble [cosh $f]} [expr {cosh($x)}]
+ fassert sinh $version.1 {todouble [sinh $f]} [expr {sinh($x)}]
+ fassert tanh $version.2 {todouble [tanh $f]} [expr {tanh($x)}]
+}
+
+hyper 4.7.0 0.0
+set subversion 0
+foreach i {1 2 3 4 5 6 7 8 9} {
+ hyper 4.7.1.$subversion.$i 0.$i
+ hyper 4.7.2.$subversion.$i $i.0
+ hyper 4.7.3.$subversion.$i -0.$i
+ hyper 4.7.4.$subversion.$i -$i.0
+}
+
+# cleanup
+rename hyper ""
+
+################################################################################
+# tostr with -nosci option
+################################################################################
+set version 5.0
+fassert tostr-nosci $version.0 {tostr -nosci [fromstr 23450.e+7]} 234500000000.
+fassert tostr-nosci $version.1 {tostr -nosci [fromstr 23450.e-7]} 0.002345
+fassert tostr-nosci $version.2 {tostr -nosci [fromstr 23450000]} 23450000.
+fassert tostr-nosci $version.3 {tostr -nosci [fromstr 2345.0]} 2345.
+
+################################################################################
+# end of testsuite for bigfloat 1.0
+################################################################################
+# cleanup global procs
+rename assert ""
+rename fassert ""
+rename Zero ""
+
+testsuiteCleanup
+
+set ::tcl_precision $old_precision
diff --git a/tcllib/modules/math/bigfloat2.tcl b/tcllib/modules/math/bigfloat2.tcl
new file mode 100644
index 0000000..60898c8
--- /dev/null
+++ b/tcllib/modules/math/bigfloat2.tcl
@@ -0,0 +1,2218 @@
+########################################################################
+# BigFloat for Tcl
+# Copyright (C) 2003-2005 ARNOLD Stephane
+# It is published with the terms of tcllib's BSD-style license.
+# See the file named license.terms.
+########################################################################
+
+package require Tcl 8.5
+
+# this line helps when I want to source this file again and again
+catch {namespace delete ::math::bigfloat}
+
+# private namespace
+# this software works only with Tcl v8.4 and higher
+# it is using the package math::bignum
+namespace eval ::math::bigfloat {
+ # cached constants
+ # ln(2) with arbitrary precision
+ variable Log2
+ # Pi with arb. precision
+ variable Pi
+ variable _pi0
+}
+
+
+
+
+################################################################################
+# procedures that handle floating-point numbers
+# these procedures are sorted by name (after eventually removing the underscores)
+#
+# BigFloats are internally represented as a list :
+# {"F" Mantissa Exponent Delta} where "F" is a character which determins
+# the datatype, Mantissa and Delta are two big integers and Exponent another integer.
+#
+# The BigFloat value equals to (Mantissa +/- Delta)*2^Exponent
+# So the internal representation is binary, but trying to get as close as possible to
+# the decimal one when converted to a string.
+# When calling [fromstr], the Delta parameter is set to the value of 1 at the position
+# of the last decimal digit.
+# Example : 1.50 belongs to [1.49,1.51], but internally Delta may not equal to 1.
+# Because of the binary representation, it is between 1 and 1+(2^-15).
+#
+# So Mantissa and Delta are not limited in size, but in practice Delta is kept under
+# 2^32 by the 'normalize' procedure, to avoid a never-ended growth of memory used.
+# Indeed, when you perform some computations, the Delta parameter (which represent
+# the uncertainty on the value of the Mantissa) may increase.
+# Exponent, as an integer, is limited to 32 bits, and this limit seems fair.
+# The exponent is indeed involved in logarithmic computations, so it may be
+# a mistake to give it a too large value.
+
+# Retrieving the parameters of a BigFloat is often done with that command :
+# foreach {dummy int exp delta} $bigfloat {break}
+# (dummy is not used, it is just used to get the "F" marker).
+# The isInt, isFloat, checkNumber and checkFloat procedures are used
+# to check data types
+#
+# Taylor development are often used to compute the analysis functions (like exp(),log()...)
+# To learn how it is done in practice, take a look at ::math::bigfloat::_asin
+# While doing computation on Mantissas, we do not care about the last digit,
+# because if we compute correctly Deltas, the digits that remain will be exact.
+################################################################################
+
+
+################################################################################
+# returns the absolute value
+################################################################################
+proc ::math::bigfloat::abs {number} {
+ checkNumber $number
+ if {[isInt $number]} {
+ # set sign to positive for a BigInt
+ return [expr {abs($number)}]
+ }
+ # set sign to positive for a BigFloat into the Mantissa (index 1)
+ lset number 1 [expr {abs([lindex $number 1])}]
+ return $number
+}
+
+
+################################################################################
+# arccosinus of a BigFloat
+################################################################################
+proc ::math::bigfloat::acos {x} {
+ # handy proc for checking datatype
+ checkFloat $x
+ foreach {dummy entier exp delta} $x {break}
+ set precision [expr {($exp<0)?(-$exp):1}]
+ # acos(0.0)=Pi/2
+ # 26/07/2005 : changed precision from decimal to binary
+ # with the second parameter of pi command
+ set piOverTwo [floatRShift [pi $precision 1]]
+ if {[iszero $x]} {
+ # $x is too close to zero -> acos(0)=PI/2
+ return $piOverTwo
+ }
+ # acos(-x)= Pi/2 + asin(x)
+ if {$entier<0} {
+ return [add $piOverTwo [asin [abs $x]]]
+ }
+ # we always use _asin to compute the result
+ # but as it is a Taylor development, the value given to [_asin]
+ # has to be a bit smaller than 1 ; by using that trick : acos(x)=asin(sqrt(1-x^2))
+ # we can limit the entry of the Taylor development below 1/sqrt(2)
+ if {[compare $x [fromstr 0.7071]]>0} {
+ # x > sqrt(2)/2 : trying to make _asin converge quickly
+ # creating 0 and 1 with the same precision as the entry
+ set fzero [list F 0 -$precision 1]
+ # 1.000 with $precision zeros
+ set fone [list F [expr {1<<$precision}] -$precision 1]
+ # when $x is close to 1 (acos(1.0)=0.0)
+ if {[equal $fone $x]} {
+ return $fzero
+ }
+ if {[compare $fone $x]<0} {
+ # the behavior assumed because acos(x) is not defined
+ # when |x|>1
+ error "acos on a number greater than 1"
+ }
+ # acos(x) = asin(sqrt(1 - x^2))
+ # since 1 - cos(x)^2 = sin(x)^2
+ # x> sqrt(2)/2 so x^2 > 1/2 so 1-x^2<1/2
+ set x [sqrt [sub $fone [mul $x $x]]]
+ # the parameter named x is smaller than sqrt(2)/2
+ return [_asin $x]
+ }
+ # acos(x) = Pi/2 - asin(x)
+ # x<sqrt(2)/2 here too
+ return [sub $piOverTwo [_asin $x]]
+}
+
+
+################################################################################
+# returns A + B
+################################################################################
+proc ::math::bigfloat::add {a b} {
+ checkNumber $a
+ checkNumber $b
+ if {[isInt $a]} {
+ if {[isInt $b]} {
+ # intAdd adds two BigInts
+ return [incr a $b]
+ }
+ # adds the BigInt a to the BigFloat b
+ return [addInt2Float $b $a]
+ }
+ if {[isInt $b]} {
+ # ... and vice-versa
+ return [addInt2Float $a $b]
+ }
+ # retrieving parameters from A and B
+ foreach {dummy integerA expA deltaA} $a {break}
+ foreach {dummy integerB expB deltaB} $b {break}
+ if {$expA<$expB} {
+ foreach {dummy integerA expA deltaA} $b {break}
+ foreach {dummy integerB expB deltaB} $a {break}
+ }
+ # when we add two numbers which have different digit numbers (after the dot)
+ # for example : 1.0 and 0.00001
+ # We promote the one with the less number of digits (1.0) to the same level as
+ # the other : so 1.00000.
+ # that is why we shift left the number which has the greater exponent
+ # But we do not forget the Delta parameter, which is lshift'ed too.
+ if {$expA>$expB} {
+ set diff [expr {$expA-$expB}]
+ set integerA [expr {$integerA<<$diff}]
+ set deltaA [expr {$deltaA<<$diff}]
+ incr integerA $integerB
+ incr deltaA $deltaB
+ return [normalize [list F $integerA $expB $deltaA]]
+ } elseif {$expA==$expB} {
+ # nothing to shift left
+ return [normalize [list F [incr integerA $integerB] $expA [incr deltaA $deltaB]]]
+ } else {
+ error "internal error"
+ }
+}
+
+################################################################################
+# returns the sum A(BigFloat) + B(BigInt)
+# the greatest advantage of this method is that the uncertainty
+# of the result remains unchanged, in respect to the entry's uncertainty (deltaA)
+################################################################################
+proc ::math::bigfloat::addInt2Float {a b} {
+ # type checking
+ checkFloat $a
+ if {![isInt $b]} {
+ error "second argument is not an integer"
+ }
+ # retrieving data from $a
+ foreach {dummy integerA expA deltaA} $a {break}
+ # to add an int to a BigFloat,...
+ if {$expA>0} {
+ # we have to put the integer integerA
+ # to the level of zero exponent : 1e8 --> 100000000e0
+ set shift $expA
+ set integerA [expr {($integerA<<$shift)+$b}]
+ set deltaA [expr {$deltaA<<$shift}]
+ # we have to normalize, because we have shifted the mantissa
+ # and the uncertainty left
+ return [normalize [list F $integerA 0 $deltaA]]
+ } elseif {$expA==0} {
+ # integerA is already at integer level : float=(integerA)e0
+ return [normalize [list F [incr integerA $b] \
+ 0 $deltaA]]
+ } else {
+ # here we have something like 234e-2 + 3
+ # we have to shift the integer left by the exponent |$expA|
+ incr integerA [expr {$b<<(-$expA)}]
+ return [normalize [list F $integerA $expA $deltaA]]
+ }
+}
+
+
+################################################################################
+# arcsinus of a BigFloat
+################################################################################
+proc ::math::bigfloat::asin {x} {
+ # type checking
+ checkFloat $x
+ foreach {dummy entier exp delta} $x {break}
+ if {$exp>-1} {
+ error "not enough precision on input (asin)"
+ }
+ set precision [expr {-$exp}]
+ # when x=0, return 0 at the same precision as the input was
+ if {[iszero $x]} {
+ return [list F 0 -$precision 1]
+ }
+ # asin(-x)=-asin(x)
+ if {$entier<0} {
+ return [opp [asin [abs $x]]]
+ }
+ # 26/07/2005 : changed precision from decimal to binary
+ set piOverTwo [floatRShift [pi $precision 1]]
+ # now a little trick : asin(x)=Pi/2-asin(sqrt(1-x^2))
+ # so we can limit the entry of the Taylor development
+ # to 1/sqrt(2)~0.7071
+ # the comparison is : if x>0.7071 then ...
+ if {[compare $x [fromstr 0.7071]]>0} {
+ set fone [list F [expr {1<<$precision}] -$precision 1]
+ # asin(1)=Pi/2 (with the same precision as the entry has)
+ if {[equal $fone $x]} {
+ return $piOverTwo
+ }
+ if {[compare $x $fone]>0} {
+ error "asin on a number greater than 1"
+ }
+ # asin(x)=Pi/2-asin(sqrt(1-x^2))
+ set x [sqrt [sub $fone [mul $x $x]]]
+ return [sub $piOverTwo [_asin $x]]
+ }
+ return [normalize [_asin $x]]
+}
+
+################################################################################
+# _asin : arcsinus of numbers between 0 and +1
+################################################################################
+proc ::math::bigfloat::_asin {x} {
+ # Taylor development
+ # asin(x)=x + 1/2 x^3/3 + 3/2.4 x^5/5 + 3.5/2.4.6 x^7/7 + ...
+ # into this iterative form :
+ # asin(x)=x * (1 + 1/2 * x^2 * (1/3 + 3/4 *x^2 * (...
+ # ...* (1/(2n-1) + (2n-1)/2n * x^2 / (2n+1))...)))
+ # we show how is really computed the development :
+ # we don't need to set a var with x^n or a product of integers
+ # all we need is : x^2, 2n-1, 2n, 2n+1 and a few variables
+ foreach {dummy mantissa exp delta} $x {break}
+ set precision [expr {-$exp}]
+ if {$precision+1<[bits $mantissa]} {
+ error "sinus greater than 1"
+ }
+ # precision is the number of after-dot digits
+ set result $mantissa
+ set delta_final $delta
+ # resultat is the final result, and delta_final
+ # will contain the uncertainty of the result
+ # square is the square of the mantissa
+ set square [expr {$mantissa*$mantissa>>$precision}]
+ # dt is the uncertainty of Mantissa
+ set dt [expr {$mantissa*$delta>>($precision-1)}]
+ incr dt
+ set num 1
+ # two will be used into the loop
+ set i 3
+ set denom 2
+ # the nth factor equals : $num/$denom* $mantissa/$i
+ set delta [expr {$delta*$square + $dt*($delta+$mantissa)}]
+ set delta [expr {($delta*$num)/ $denom >>$precision}]
+ incr delta
+ # we do not multiply the Mantissa by $num right now because it is 1 !
+ # but we have Mantissa=$x
+ # and we want Mantissa*$x^2 * $num / $denom / $i
+ set mantissa [expr {($mantissa*$square>>$precision)/$denom}]
+ # do not forget the modified Taylor development :
+ # asin(x)=x * (1 + 1/2*x^2*(1/3 + 3/4*x^2*(...*(1/(2n-1) + (2n-1)/2n*x^2/(2n+1))...)))
+ # all we need is : x^2, 2n-1, 2n, 2n+1 and a few variables
+ # $num=2n-1 $denom=2n $square=x^2 and $i=2n+1
+ set mantissa_temp [expr {$mantissa/$i}]
+ set delta_temp [expr {1+$delta/$i}]
+ # when the Mantissa increment is smaller than the Delta increment,
+ # we would not get much precision by continuing the development
+ while {$mantissa_temp!=0} {
+ # Mantissa = Mantissa * $num/$denom * $square
+ # Add Mantissa/$i, which is stored in $mantissa_temp, to the result
+ incr result $mantissa_temp
+ incr delta_final $delta_temp
+ # here we have $two instead of [fromstr 2] (optimization)
+ # num=num+2,i=i+2,denom=denom+2
+ # because num=2n-1 denom=2n and i=2n+1
+ incr num 2
+ incr i 2
+ incr denom 2
+ # computes precisly the future Delta parameter
+ set delta [expr {$delta*$square+$dt*($delta+$mantissa)}]
+ set delta [expr {($delta*$num)/$denom>>$precision}]
+ incr delta
+ set mantissa [expr {$mantissa*$square>>$precision}]
+ set mantissa [expr {($mantissa*$num)/$denom}]
+ set mantissa_temp [expr {$mantissa/$i}]
+ set delta_temp [expr {1+$delta/$i}]
+ }
+ return [normalize [list F $result $exp $delta_final]]
+}
+
+################################################################################
+# arctangent : returns atan(x)
+################################################################################
+proc ::math::bigfloat::atan {x} {
+ checkFloat $x
+ foreach {dummy mantissa exp delta} $x {break}
+ if {$exp>=0} {
+ error "not enough precision to compute atan"
+ }
+ set precision [expr {-$exp}]
+ # atan(0)=0
+ if {[iszero $x]} {
+ return [list F 0 -$precision $delta]
+ }
+ # atan(-x)=-atan(x)
+ if {$mantissa<0} {
+ return [opp [atan [abs $x]]]
+ }
+ # now x is strictly positive
+ # at this moment, we are trying to limit |x| to a fair acceptable number
+ # to ensure that Taylor development will converge quickly
+ set float1 [list F [expr {1<<$precision}] -$precision 1]
+ if {[compare $float1 $x]<0} {
+ # compare x to 2.4142
+ if {[compare $x [fromstr 2.4142]]<0} {
+ # atan(x)=Pi/4 + atan((x-1)/(x+1))
+ # as 1<x<2.4142 : (x-1)/(x+1)=1-2/(x+1) belongs to
+ # the range : ]0,1-2/3.414[
+ # that equals ]0,0.414[
+ set pi_sur_quatre [floatRShift [pi $precision 1] 2]
+ return [add $pi_sur_quatre [atan \
+ [div [sub $x $float1] [add $x $float1]]]]
+ }
+ # atan(x)=Pi/2-atan(1/x)
+ # 1/x < 1/2.414 so the argument is lower than 0.414
+ set pi_over_two [floatRShift [pi $precision 1]]
+ return [sub $pi_over_two [atan [div $float1 $x]]]
+ }
+ if {[compare $x [fromstr 0.4142]]>0} {
+ # atan(x)=Pi/4 + atan((x-1)/(x+1))
+ # x>0.420 so (x-1)/(x+1)=1 - 2/(x+1) > 1-2/1.414
+ # > -0.414
+ # x<1 so (x-1)/(x+1)<0
+ set pi_sur_quatre [floatRShift [pi $precision 1] 2]
+ return [add $pi_sur_quatre [atan \
+ [div [sub $x $float1] [add $x $float1]]]]
+ }
+ # precision increment : to have less uncertainty
+ # we add a little more precision so that the result would be more accurate
+ # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1)
+ # when we have n steps in Taylor development : the nth term is :
+ # x^(2n-1)/(2n-1)
+ # and the loss of precision is of 2n (n sums and n divisions)
+ # this command is called with x<sqrt(2)-1
+ # if we add an increment to the precision, say n:
+ # (sqrt(2)-1)^(2n-1)/(2n-1) has to be lower than 2^(-precision-n-1)
+ # (2n-1)*log(sqrt(2)-1)-log(2n-1)<-(precision+n+1)*log(2)
+ # 2n(log(sqrt(2)-1)-log(sqrt(2)))<-(precision-1)*log(2)+log(2n-1)+log(sqrt(2)-1)
+ # 2n*log(1-1/sqrt(2))<-(precision-1)*log(2)+log(2n-1)+log(2)/2
+ # 2n/sqrt(2)>(precision-3/2)*log(2)-log(2n-1)
+ # hence log(2n-1)<2n-1
+ # n*sqrt(2)>(precision-1.5)*log(2)+1-2n
+ # n*(sqrt(2)+2)>(precision-1.5)*log(2)+1
+ set n [expr {int((log(2)*($precision-1.5)+1)/(sqrt(2)+2)+1)}]
+ incr precision $n
+ set mantissa [expr {$mantissa<<$n}]
+ set delta [expr {$delta<<$n}]
+ # end of adding precision increment
+ # now computing Taylor development :
+ # atan(x)=x - x^3/3 + x^5/5 - x^7/7 ... + (-1)^n*x^(2n+1)/(2n+1)
+ # atan(x)=x * (1 - x^2 * (1/3 - x^2 * (1/5 - x^2 * (...*(1/(2n-1) - x^2 / (2n+1))...))))
+ # what do we need to compute this ?
+ # x^2 ($square), 2n+1 ($divider), $result, the nth term of the development ($t)
+ # and the nth term multiplied by 2n+1 ($temp)
+ # then we do this (with care keeping as much precision as possible):
+ # while ($t <>0) :
+ # $result=$result+$t
+ # $temp=$temp * $square
+ # $divider = $divider+2
+ # $t=$temp/$divider
+ # end-while
+ set result $mantissa
+ set delta_end $delta
+ # we store the square of the integer (mantissa)
+ # Delta of Mantissa^2 = Delta * 2 = Delta << 1
+ set delta_square [expr {$delta<<1}]
+ set square [expr {$mantissa*$mantissa>>$precision}]
+ # the (2n+1) divider
+ set divider 3
+ # computing precisely the uncertainty
+ set delta [expr {1+($delta_square*$mantissa+$delta*$square>>$precision)}]
+ # temp contains (-1)^n*x^(2n+1)
+ set temp [expr {-$mantissa*$square>>$precision}]
+ set t [expr {$temp/$divider}]
+ set dt [expr {1+$delta/$divider}]
+ while {$t!=0} {
+ incr result $t
+ incr delta_end $dt
+ incr divider 2
+ set delta [expr {1+($delta_square*abs($temp)+$delta*($delta_square+$square)>>$precision)}]
+ set temp [expr {-$temp*$square>>$precision}]
+ set t [expr {$temp/$divider}]
+ set dt [expr {1+$delta/$divider}]
+ }
+ # we have to normalize because the uncertainty might be greater than 2**16
+ # moreover it is the most often case
+ return [normalize [list F $result [expr {$exp-$n}] $delta_end]]
+}
+
+
+################################################################################
+# compute atan(1/integer) at a given precision
+# this proc is only used to compute Pi
+# it is using the same Taylor development as [atan]
+################################################################################
+proc ::math::bigfloat::_atanfract {integer precision} {
+ # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1)
+ # when we have n steps in Taylor development : the nth term is :
+ # 1/denom^(2n+1)/(2n+1)
+ # and the loss of precision is of 2n (n sums and n divisions)
+ # this command is called with integer>=5
+ #
+ # We do not want to compute the Delta parameter, so we just
+ # can increment precision (with lshift) in order for the result to be precise.
+ # Remember : we compute atan2(1,$integer) with $precision bits
+ # $integer has no Delta parameter as it is a BigInt, of course, so
+ # theorically we could compute *any* number of digits.
+ #
+ # if we add an increment to the precision, say n:
+ # (1/5)^(2n-1)/(2n-1) has to be lower than (1/2)^(precision+n-1)
+ # Calculus :
+ # log(left term) < log(right term)
+ # log(1/left term) > log(1/right term)
+ # (2n-1)*log(5)+log(2n-1)>(precision+n-1)*log(2)
+ # n(2log(5)-log(2))>(precision-1)*log(2)-log(2n-1)+log(5)
+ # -log(2n-1)>-(2n-1)
+ # n(2log(5)-log(2)+2)>(precision-1)*log(2)+1+log(5)
+ set n [expr {int((($precision-1)*log(2)+1+log(5))/(2*log(5)-log(2)+2)+1)}]
+ incr precision $n
+ # first term of the development : 1/integer
+ set a [expr {(1<<$precision)/$integer}]
+ # 's' will contain the result
+ set s $a
+ # Taylor development : x - x^3/3 + x^5/5 - ... + (-1)^(n+1)*x^(2n-1)/(2n-1)
+ # equals x (1 - x^2 * (1/3 + x^2 * (... * (1/(2n-3) + (-1)^(n+1) * x^2 / (2n-1))...)))
+ # all we need to store is : 2n-1 ($denom), x^(2n+1) and x^2 ($square) and two results :
+ # - the nth term => $u
+ # - the nth term * (2n-1) => $t
+ # + of course, the result $s
+ set square [expr {$integer*$integer}]
+ set denom 3
+ # $t is (-1)^n*x^(2n+1)
+ set t [expr {-$a/$square}]
+ set u [expr {$t/$denom}]
+ # we break the loop when the current term of the development is null
+ while {$u!=0} {
+ incr s $u
+ # denominator= (2n+1)
+ incr denom 2
+ # div $t by x^2
+ set t [expr {-$t/$square}]
+ set u [expr {$t/$denom}]
+ }
+ # go back to the initial precision
+ return [expr {$s>>$n}]
+}
+
+#
+# bits : computes the number of bits of an integer, approx.
+#
+proc ::math::bigfloat::bits {int} {
+ set l [string length [set int [expr {abs($int)}]]]
+ # int<10**l -> log_2(int)=l*log_2(10)
+ set l [expr {int($l*log(10)/log(2))+1}]
+ if {$int>>$l!=0} {
+ error "bad result: $l bits"
+ }
+ while {($int>>($l-1))==0} {
+ incr l -1
+ }
+ return $l
+}
+
+################################################################################
+# returns the integer part of a BigFloat, as a BigInt
+# the result is the same one you would have
+# if you had called [expr {ceil($x)}]
+################################################################################
+proc ::math::bigfloat::ceil {number} {
+ checkFloat $number
+ set number [normalize $number]
+ if {[iszero $number]} {
+ return 0
+ }
+ foreach {dummy integer exp delta} $number {break}
+ if {$exp>=0} {
+ error "not enough precision to perform rounding (ceil)"
+ }
+ # saving the sign ...
+ set sign [expr {$integer<0}]
+ set integer [expr {abs($integer)}]
+ # integer part
+ set try [expr {$integer>>(-$exp)}]
+ if {$sign} {
+ return [opp $try]
+ }
+ # fractional part
+ if {($try<<(-$exp))!=$integer} {
+ return [incr try]
+ }
+ return $try
+}
+
+
+################################################################################
+# checks each variable to be a BigFloat
+# arguments : each argument is the name of a variable to be checked
+################################################################################
+proc ::math::bigfloat::checkFloat {number} {
+ if {![isFloat $number]} {
+ error "BigFloat expected"
+ }
+}
+
+################################################################################
+# checks if each number is either a BigFloat or a BigInt
+# arguments : each argument is the name of a variable to be checked
+################################################################################
+proc ::math::bigfloat::checkNumber {x} {
+ if {![isFloat $x] && ![isInt $x]} {
+ error "input is not an integer, nor a BigFloat"
+ }
+}
+
+
+################################################################################
+# returns 0 if A and B are equal, else returns 1 or -1
+# accordingly to the sign of (A - B)
+################################################################################
+proc ::math::bigfloat::compare {a b} {
+ if {[isInt $a] && [isInt $b]} {
+ set diff [expr {$a-$b}]
+ if {$diff>0} {return 1} elseif {$diff<0} {return -1}
+ return 0
+ }
+ checkFloat $a
+ checkFloat $b
+ if {[equal $a $b]} {return 0}
+ if {[lindex [sub $a $b] 1]<0} {return -1}
+ return 1
+}
+
+
+
+
+################################################################################
+# gets cos(x)
+# throws an error if there is not enough precision on the input
+################################################################################
+proc ::math::bigfloat::cos {x} {
+ checkFloat $x
+ foreach {dummy integer exp delta} $x {break}
+ if {$exp>-2} {
+ error "not enough precision on floating-point number"
+ }
+ set precision [expr {-$exp}]
+ # cos(2kPi+x)=cos(x)
+ foreach {n integer} [divPiQuarter $integer $precision] {break}
+ # now integer>=0 and <Pi/2
+ set d [expr {$n%4}]
+ # add trigonometric circle turns number to delta
+ incr delta [expr {abs($n)}]
+ set signe 0
+ # cos(Pi-x)=-cos(x)
+ # cos(-x)=cos(x)
+ # cos(Pi/2-x)=sin(x)
+ switch -- $d {
+ 1 {set signe 1;set l [_sin2 $integer $precision $delta]}
+ 2 {set signe 1;set l [_cos2 $integer $precision $delta]}
+ 0 {set l [_cos2 $integer $precision $delta]}
+ 3 {set l [_sin2 $integer $precision $delta]}
+ default {error "internal error"}
+ }
+ # precision -> exp (multiplied by -1)
+ #idebug break
+ lset l 1 [expr {-([lindex $l 1])}]
+ # set the sign
+ if {$signe} {
+ lset l 0 [expr {-[lindex $l 0]}]
+ }
+ #idebug break
+ return [normalize [linsert $l 0 F]]
+}
+
+################################################################################
+# compute cos(x) where 0<=x<Pi/2
+# returns : a list formed with :
+# 1. the mantissa
+# 2. the precision (opposite of the exponent)
+# 3. the uncertainty (doubt range)
+################################################################################
+proc ::math::bigfloat::_cos2 {x precision delta} {
+ # precision bits after the dot
+ set pi [_pi $precision]
+ set pis2 [expr {$pi>>1}]
+ set pis4 [expr {$pis2>>1}]
+ if {$x>=$pis4} {
+ # cos(Pi/2-x)=sin(x)
+ set x [expr {$pis2-$x}]
+ incr delta
+ return [_sin $x $precision $delta]
+ }
+ #idebug break
+ return [_cos $x $precision $delta]
+}
+
+################################################################################
+# compute cos(x) where 0<=x<Pi/4
+# returns : a list formed with :
+# 1. the mantissa
+# 2. the precision (opposite of the exponent)
+# 3. the uncertainty (doubt range)
+################################################################################
+proc ::math::bigfloat::_cos {x precision delta} {
+ set float1 [expr {1<<$precision}]
+ # Taylor development follows :
+ # cos(x)=1-x^2/2 + x^4/4! ... + (-1)^(2n)*x^(2n)/2n!
+ # cos(x)= 1 - x^2/1.2 * (1 - x^2/3.4 * (... * (1 - x^2/(2n.(2n-1))...))
+ # variables : $s (the Mantissa of the result)
+ # $denom1 & $denom2 (2n-1 & 2n)
+ # $x as the square of what is named x in 'cos(x)'
+ set s $float1
+ # 'd' is the uncertainty on x^2
+ set d [expr {$x*($delta<<1)}]
+ set d [expr {1+($d>>$precision)}]
+ # x=x^2 (because in this Taylor development, there are only even powers of x)
+ set x [expr {$x*$x>>$precision}]
+ set denom1 1
+ set denom2 2
+ set t [expr {-($x>>1)}]
+ set dt $d
+ while {$t!=0} {
+ incr s $t
+ incr delta $dt
+ incr denom1 2
+ incr denom2 2
+ set dt [expr {$x*$dt+($t+$dt)*$d>>$precision}]
+ incr dt
+ set t [expr {$x*$t>>$precision}]
+ set t [expr {-$t/($denom1*$denom2)}]
+ }
+ return [list $s $precision $delta]
+}
+
+################################################################################
+# cotangent : the trivial algorithm is used
+################################################################################
+proc ::math::bigfloat::cotan {x} {
+ return [::math::bigfloat::div [::math::bigfloat::cos $x] [::math::bigfloat::sin $x]]
+}
+
+################################################################################
+# converts angles from degrees to radians
+# deg/180=rad/Pi
+################################################################################
+proc ::math::bigfloat::deg2rad {x} {
+ checkFloat $x
+ set xLen [expr {-[lindex $x 2]}]
+ if {$xLen<3} {
+ error "number too loose to convert to radians"
+ }
+ set pi [pi $xLen 1]
+ return [div [mul $x $pi] 180]
+}
+
+
+
+################################################################################
+# private proc to get : x modulo Pi/2
+# and the quotient (x divided by Pi/2)
+# used by cos , sin & others
+################################################################################
+proc ::math::bigfloat::divPiQuarter {integer precision} {
+ incr precision 2
+ set integer [expr {$integer<<1}]
+ #idebug break
+ set P [_pi $precision]
+ # modulo 2Pi
+ set integer [expr {$integer%$P}]
+ # end modulo 2Pi
+ # 2Pi>>1 = Pi of course!
+ set P [expr {$P>>1}]
+ set n [expr {$integer/$P}]
+ set integer [expr {$integer%$P}]
+ # now divide by Pi/2
+ # multiply n by 2
+ set n [expr {$n<<1}]
+ # pi/2=Pi>>1
+ set P [expr {$P>>1}]
+ return [list [incr n [expr {$integer/$P}]] [expr {($integer%$P)>>1}]]
+}
+
+
+################################################################################
+# divide A by B and returns the result
+# throw error : divide by zero
+################################################################################
+proc ::math::bigfloat::div {a b} {
+ checkNumber $a
+ checkNumber $b
+ # dispatch to an appropriate procedure
+ if {[isInt $a]} {
+ if {[isInt $b]} {
+ return [expr {$a/$b}]
+ }
+ error "trying to divide an integer by a BigFloat"
+ }
+ if {[isInt $b]} {return [divFloatByInt $a $b]}
+ foreach {dummy integerA expA deltaA} $a {break}
+ foreach {dummy integerB expB deltaB} $b {break}
+ # computes the limits of the doubt (or uncertainty) interval
+ set BMin [expr {$integerB-$deltaB}]
+ set BMax [expr {$integerB+$deltaB}]
+ if {$BMin>$BMax} {
+ # swap BMin and BMax
+ set temp $BMin
+ set BMin $BMax
+ set BMax $temp
+ }
+ # multiply by zero gives zero
+ if {$integerA==0} {
+ # why not return any number or the integer 0 ?
+ # because there is an exponent that might be different between two BigFloats
+ # 0.00 --> exp = -2, 0.000000 -> exp = -6
+ return $a
+ }
+ # test of the division by zero
+ if {$BMin*$BMax<0 || $BMin==0 || $BMax==0} {
+ error "divide by zero"
+ }
+ # shift A because we need accuracy
+ set l [bits $integerB]
+ set integerA [expr {$integerA<<$l}]
+ set deltaA [expr {$deltaA<<$l}]
+ set exp [expr {$expA-$l-$expB}]
+ # relative uncertainties (dX/X) are added
+ # to give the relative uncertainty of the result
+ # i.e. 3% on A + 2% on B --> 5% on the quotient
+ # d(A/B)/(A/B)=dA/A + dB/B
+ # Q=A/B
+ # dQ=dA/B + dB*A/B*B
+ # dQ is "delta"
+ set delta [expr {($deltaB*abs($integerA))/abs($integerB)}]
+ set delta [expr {([incr delta]+$deltaA)/abs($integerB)}]
+ set quotient [expr {$integerA/$integerB}]
+ if {$integerB*$integerA<0} {
+ incr quotient -1
+ }
+ return [normalize [list F $quotient $exp [incr delta]]]
+}
+
+
+
+
+################################################################################
+# divide a BigFloat A by a BigInt B
+# throw error : divide by zero
+################################################################################
+proc ::math::bigfloat::divFloatByInt {a b} {
+ # type check
+ checkFloat $a
+ if {![isInt $b]} {
+ error "second argument is not an integer"
+ }
+ foreach {dummy integer exp delta} $a {break}
+ # zero divider test
+ if {$b==0} {
+ error "divide by zero"
+ }
+ # shift left for accuracy ; see other comments in [div] procedure
+ set l [bits $b]
+ set integer [expr {$integer<<$l}]
+ set delta [expr {$delta<<$l}]
+ incr exp -$l
+ set integer [expr {$integer/$b}]
+ # the uncertainty is always evaluated to the ceil value
+ # and as an absolute value
+ set delta [expr {$delta/abs($b)+1}]
+ return [normalize [list F $integer $exp $delta]]
+}
+
+
+
+
+
+################################################################################
+# returns 1 if A and B are equal, 0 otherwise
+# IN : a, b (BigFloats)
+################################################################################
+proc ::math::bigfloat::equal {a b} {
+ if {[isInt $a] && [isInt $b]} {
+ return [expr {$a==$b}]
+ }
+ # now a & b should only be BigFloats
+ checkFloat $a
+ checkFloat $b
+ foreach {dummy aint aexp adelta} $a {break}
+ foreach {dummy bint bexp bdelta} $b {break}
+ # set all Mantissas and Deltas to the same level (exponent)
+ # with lshift
+ set diff [expr {$aexp-$bexp}]
+ if {$diff<0} {
+ set diff [expr {-$diff}]
+ set bint [expr {$bint<<$diff}]
+ set bdelta [expr {$bdelta<<$diff}]
+ } elseif {$diff>0} {
+ set aint [expr {$aint<<$diff}]
+ set adelta [expr {$adelta<<$diff}]
+ }
+ # compute limits of the number's doubt range
+ set asupInt [expr {$aint+$adelta}]
+ set ainfInt [expr {$aint-$adelta}]
+ set bsupInt [expr {$bint+$bdelta}]
+ set binfInt [expr {$bint-$bdelta}]
+ # A & B are equal
+ # if their doubt ranges overlap themselves
+ if {$bint==$aint} {
+ return 1
+ }
+ if {$bint>$aint} {
+ set r [expr {$asupInt>=$binfInt}]
+ } else {
+ set r [expr {$bsupInt>=$ainfInt}]
+ }
+ return $r
+}
+
+################################################################################
+# returns exp(X) where X is a BigFloat
+################################################################################
+proc ::math::bigfloat::exp {x} {
+ checkFloat $x
+ foreach {dummy integer exp delta} $x {break}
+ if {$exp>=0} {
+ # shift till exp<0 with respect to the internal representation
+ # of the number
+ incr exp
+ set integer [expr {$integer<<$exp}]
+ set delta [expr {$delta<<$exp}]
+ set exp -1
+ }
+ # add 8 bits of precision for safety
+ set precision [expr {8-$exp}]
+ set integer [expr {$integer<<8}]
+ set delta [expr {$delta<<8}]
+ set Log2 [_log2 $precision]
+ set new_exp [expr {$integer/$Log2}]
+ set integer [expr {$integer%$Log2}]
+ # $new_exp = integer part of x/log(2)
+ # $integer = remainder
+ # exp(K.log(2)+r)=2^K.exp(r)
+ # so we just have to compute exp(r), r is small so
+ # the Taylor development will converge quickly
+ incr delta $new_exp
+ foreach {integer delta} [_exp $integer $precision $delta] {break}
+ set delta [expr {$delta>>8}]
+ incr precision -8
+ # multiply by 2^K , and take care of the sign
+ # example : X=-6.log(2)+0.01
+ # exp(X)=exp(0.01)*2^-6
+ # if {abs($new_exp)>>30!=0} {
+ # error "floating-point overflow due to exp"
+ # }
+ set exp [expr {$new_exp-$precision}]
+ incr delta
+ return [normalize [list F [expr {$integer>>8}] $exp $delta]]
+}
+
+
+################################################################################
+# private procedure to compute exponentials
+# using Taylor development of exp(x) :
+# exp(x)=1+ x + x^2/2 + x^3/3! +...+x^n/n!
+# input : integer (the mantissa)
+# precision (the number of decimals)
+# delta (the doubt limit, or uncertainty)
+# returns a list : 1. the mantissa of the result
+# 2. the doubt limit, or uncertainty
+################################################################################
+proc ::math::bigfloat::_exp {integer precision delta} {
+ if {$integer==0} {
+ # exp(0)=1
+ return [list [expr {1<<$precision}] $delta]
+ }
+ set s [expr {(1<<$precision)+$integer}]
+ set d [expr {1+$delta/2}]
+ incr delta $delta
+ # dt = uncertainty on x^2
+ set dt [expr {1+($d*$integer>>$precision)}]
+ # t= x^2/2 = x^2>>1
+ set t [expr {$integer*$integer>>$precision+1}]
+ set denom 2
+ while {$t!=0} {
+ # the sum is called 's'
+ incr s $t
+ incr delta $dt
+ # we do not have to keep trace of the factorial, we just iterate divisions
+ incr denom
+ # add delta
+ set d [expr {1+$d/$denom}]
+ incr dt $d
+ # get x^n from x^(n-1)
+ set t [expr {($integer*$t>>$precision)/$denom}]
+ }
+ return [list $s $delta]
+}
+################################################################################
+# divide a BigFloat by 2 power 'n'
+################################################################################
+proc ::math::bigfloat::floatRShift {float {n 1}} {
+ return [lset float 2 [expr {[lindex $float 2]-$n}]]
+}
+
+
+
+################################################################################
+# procedure floor : identical to [expr floor($x)] in functionality
+# arguments : number IN (a BigFloat)
+# returns : the floor value as a BigInt
+################################################################################
+proc ::math::bigfloat::floor {number} {
+ checkFloat $number
+ if {[iszero $number]} {
+ # returns the BigInt 0
+ return 0
+ }
+ foreach {dummy integer exp delta} $number {break}
+ if {$exp>=0} {
+ error "not enough precision to perform rounding (floor)"
+ }
+ # floor(n.xxxx)=n when n is positive
+ if {$integer>0} {return [expr {$integer>>(-$exp)}]}
+ set integer [expr {abs($integer)}]
+ # integer part
+ set try [expr {$integer>>(-$exp)}]
+ # floor(-n.xxxx)=-(n+1) when xxxx!=0
+ if {$try<<(-$exp)!=$integer} {
+ incr try
+ }
+ return [expr {-$try}]
+}
+
+
+################################################################################
+# returns a list formed by an integer and an exponent
+# x = (A +/- C) * 10 power B
+# return [list "F" A B C] (where F is the BigFloat tag)
+# A and C are BigInts, B is a raw integer
+# return also a BigInt when there is neither a dot, nor a 'e' exponent
+#
+# arguments : -base base integer
+# or integer
+# or float
+# or float trailingZeros
+################################################################################
+proc ::math::bigfloat::fromstr {number {addzeros 0}} {
+ if {$addzeros<0} {
+ error "second argument has to be a positive integer"
+ }
+ # eliminate the sign problem
+ # added on 05/08/2005
+ # setting '$signe' to the sign of the number
+ set number [string trimleft $number +]
+ if {[string index $number 0]=="-"} {
+ set signe 1
+ set string [string range $number 1 end]
+ } else {
+ set signe 0
+ set string $number
+ }
+ # integer case (not a floating-point number)
+ if {[string is digit $string]} {
+ if {$addzeros!=0} {
+ error "second argument not allowed with an integer"
+ }
+ # we have completed converting an integer to a BigInt
+ # please note that most math::bigfloat procs accept BigInts as arguments
+ return $number
+ }
+ # floating-point number : check for an exponent
+ # scientific notation
+ set tab [split $string e]
+ if {[llength $tab]>2} {
+ # there are more than one 'e' letter in the number
+ error "syntax error in number : $string"
+ }
+ if {[llength $tab]==2} {
+ set exp [lindex $tab 1]
+ # now exp can look like +099 so you need to handle octal numbers
+ # too bad...
+ # find the sign (if any?)
+ regexp {^[\+\-]?} $exp expsign
+ # trim the number with left-side 0's
+ set found [string length $expsign]
+ set exp $expsign[string trimleft [string range $exp $found end] 0]
+ set mantissa [lindex $tab 0]
+ } else {
+ set exp 0
+ set mantissa [lindex $tab 0]
+ }
+ # a floating-point number may have a dot
+ set tab [split [string trimleft $mantissa 0] .]
+ if {[llength $tab]>2} {error "syntax error in number : $string"}
+ if {[llength $tab]==2} {
+ set mantissa [join $tab ""]
+ # increment by the number of decimals (after the dot)
+ incr exp -[string length [lindex $tab 1]]
+ }
+ # this is necessary to ensure we can call fromstr (recursively) with
+ # the mantissa ($number)
+ if {![string is digit $mantissa]} {
+ error "$number is not a number"
+ }
+ # take account of trailing zeros
+ incr exp -$addzeros
+ # multiply $number by 10^$trailingZeros
+ append mantissa [string repeat 0 $addzeros]
+ # add the sign
+ # here we avoid octal numbers by trimming the leading zeros!
+ # 2005-10-28 S.ARNOLD
+ if {$signe} {set mantissa [expr {-[string trimleft $mantissa 0]}]}
+ # the F tags a BigFloat
+ # a BigInt is like any other integer since Tcl 8.5,
+ # because expr now supports arbitrary length integers
+ return [_fromstr $mantissa $exp]
+}
+
+################################################################################
+# private procedure to transform decimal floats into binary ones
+# IN :
+# - number : a BigInt representing the Mantissa
+# - exp : the decimal exponent (a simple integer)
+# OUT :
+# $number * 10^$exp, as the internal binary representation of a BigFloat
+################################################################################
+proc ::math::bigfloat::_fromstr {number exp} {
+ set number [string trimleft $number 0]
+ if {$number==""} {
+ return [list F 0 [expr {int($exp*log(10)/log(2))-15}] [expr {1<<15}]]
+ }
+ if {$exp==0} {
+ return [list F $number 0 1]
+ }
+ if {$exp>0} {
+ # mul by 10^exp, then normalize
+ set power [expr {10**$exp}]
+ set number [expr {$number*$power}]
+ return [normalize [list F $number 0 $power]]
+ }
+ # now exp is negative or null
+ # the closest power of 2 to the 'exp'th power of ten, but greater than it
+ # 10**$exp<2**$binaryExp
+ # $binaryExp>$exp*log(10)/log(2)
+ set binaryExp [expr {int(-$exp*log(10)/log(2))+1+16}]
+ # then compute n * 2^binaryExp / 10^(-exp)
+ # (exp is negative)
+ # equals n * 2^(binaryExp+exp) / 5^(-exp)
+ set diff [expr {$binaryExp+$exp}]
+ if {$diff<0} {
+ error "internal error"
+ }
+ set power [expr {5**(-$exp)}]
+ set number [expr {($number<<$diff)/$power}]
+ set delta [expr {(1<<$diff)/$power}]
+ return [normalize [list F $number [expr {-$binaryExp}] [incr delta]]]
+}
+
+
+################################################################################
+# fromdouble :
+# like fromstr, but for a double scalar value
+# arguments :
+# double - the number to convert to a BigFloat
+# exp (optional) - the total number of digits
+################################################################################
+proc ::math::bigfloat::fromdouble {double {exp {}}} {
+ set mantissa [lindex [split $double e] 0]
+ # line added by SArnold on 05/08/2005
+ set mantissa [string trimleft [string map {+ "" - ""} $mantissa] 0]
+ set precision [string length [string map {. ""} $mantissa]]
+ if { $exp != {} && [incr exp]>$precision } {
+ return [fromstr $double [expr {$exp-$precision}]]
+ } else {
+ # tests have failed : not enough precision or no exp argument
+ return [fromstr $double]
+ }
+}
+
+
+################################################################################
+# converts a BigInt into a BigFloat with a given decimal precision
+################################################################################
+proc ::math::bigfloat::int2float {int {decimals 1}} {
+ # it seems like we need some kind of type handling
+ # very odd in this Tcl world :-(
+ if {![isInt $int]} {
+ error "first argument is not an integer"
+ }
+ if {$decimals<1} {
+ error "non-positive decimals number"
+ }
+ # the lowest number of decimals is 1, because
+ # [tostr [fromstr 10.0]] returns 10.
+ # (we lose 1 digit when converting back to string)
+ set int [expr {$int*10**$decimals}]
+ return [_fromstr $int [expr {-$decimals}]]
+}
+
+
+
+################################################################################
+# multiplies 'leftop' by 'rightop' and rshift the result by 'shift'
+################################################################################
+proc ::math::bigfloat::intMulShift {leftop rightop shift} {
+ return [::math::bignum::rshift [::math::bignum::mul $leftop $rightop] $shift]
+}
+
+################################################################################
+# returns 1 if x is a BigFloat, 0 elsewhere
+################################################################################
+proc ::math::bigfloat::isFloat {x} {
+ # a BigFloat is a list of : "F" mantissa exponent delta
+ if {[llength $x]!=4} {
+ return 0
+ }
+ # the marker is the letter "F"
+ if {[string equal [lindex $x 0] F]} {
+ return 1
+ }
+ return 0
+}
+
+################################################################################
+# checks that n is a BigInt (a number create by math::bignum::fromstr)
+################################################################################
+proc ::math::bigfloat::isInt {n} {
+ set rc [catch {
+ expr {$n%2}
+ }]
+ return [expr {$rc == 0}]
+}
+
+
+
+################################################################################
+# returns 1 if x is null, 0 otherwise
+################################################################################
+proc ::math::bigfloat::iszero {x} {
+ if {[isInt $x]} {
+ return [expr {$x==0}]
+ }
+ checkFloat $x
+ # now we do some interval rounding : if a number's interval englobs 0,
+ # it is considered to be equal to zero
+ foreach {dummy integer exp delta} $x {break}
+ if {$delta>=abs($integer)} {return 1}
+ return 0
+}
+
+
+################################################################################
+# compute log(X)
+################################################################################
+proc ::math::bigfloat::log {x} {
+ checkFloat $x
+ foreach {dummy integer exp delta} $x {break}
+ if {$integer<=0} {
+ error "zero logarithm error"
+ }
+ if {[iszero $x]} {
+ error "number equals zero"
+ }
+ set precision [bits $integer]
+ # uncertainty of the logarithm
+ set delta [_logOnePlusEpsilon $delta $integer $precision]
+ incr delta
+ # we got : x = 1xxxxxx (binary number with 'precision' bits) * 2^exp
+ # we need : x = 0.1xxxxxx(binary) *2^(exp+precision)
+ incr exp $precision
+ foreach {integer deltaIncr} [_log $integer] {break}
+ incr delta $deltaIncr
+ # log(a * 2^exp)= log(a) + exp*log(2)
+ # result = log(x) + exp*log(2)
+ # as x<1 log(x)<0 but 'integer' (result of '_log') is the absolute value
+ # that is why we substract $integer to log(2)*$exp
+ set integer [expr {[_log2 $precision]*$exp-$integer}]
+ incr delta [expr {abs($exp)}]
+ return [normalize [list F $integer -$precision $delta]]
+}
+
+
+################################################################################
+# compute log(1-epsNum/epsDenom)=log(1-'epsilon')
+# Taylor development gives -x -x^2/2 -x^3/3 -x^4/4 ...
+# used by 'log' command because log(x+/-epsilon)=log(x)+log(1+/-(epsilon/x))
+# so the uncertainty equals abs(log(1-epsilon/x))
+# ================================================
+# arguments :
+# epsNum IN (the numerator of epsilon)
+# epsDenom IN (the denominator of epsilon)
+# precision IN (the number of bits after the dot)
+#
+# 'epsilon' = epsNum*2^-precision/epsDenom
+################################################################################
+proc ::math::bigfloat::_logOnePlusEpsilon {epsNum epsDenom precision} {
+ if {$epsNum>=$epsDenom} {
+ error "number is null"
+ }
+ set s [expr {($epsNum<<$precision)/$epsDenom}]
+ set divider 2
+ set t [expr {$s*$epsNum/$epsDenom}]
+ set u [expr {$t/$divider}]
+ # when u (the current term of the development) is zero, we have reached our goal
+ # it has converged
+ while {$u!=0} {
+ incr s $u
+ # divider = order of the term = 'n'
+ incr divider
+ # t = (epsilon)^n
+ set t [expr {$t*$epsNum/$epsDenom}]
+ # u = t/n = (epsilon)^n/n and is the nth term of the Taylor development
+ set u [expr {$t/$divider}]
+ }
+ return $s
+}
+
+
+################################################################################
+# compute log(0.xxxxxxxx) : log(1-epsilon)=-eps-eps^2/2-eps^3/3...-eps^n/n
+################################################################################
+proc ::math::bigfloat::_log {integer} {
+ # the uncertainty is nbSteps with nbSteps<=nbBits
+ # take nbSteps=nbBits (the worse case) and log(nbBits+increment)=increment
+ set precision [bits $integer]
+ set n [expr {int(log($precision+2*log($precision)))}]
+ set integer [expr {$integer<<$n}]
+ incr precision $n
+ set delta 3
+ # 1-epsilon=integer
+ set integer [expr {(1<<$precision)-$integer}]
+ set s $integer
+ # t=x^2
+ set t [expr {$integer*$integer>>$precision}]
+ set denom 2
+ # u=x^2/2 (second term)
+ set u [expr {$t/$denom}]
+ while {$u!=0} {
+ # while the current term is not zero, it has not converged
+ incr s $u
+ incr delta
+ # t=x^n
+ set t [expr {$t*$integer>>$precision}]
+ # denom = n (the order of the current development term)
+ # u = x^n/n (the nth term of Taylor development)
+ set u [expr {$t/[incr denom]}]
+ }
+ # shift right to restore the precision
+ set delta
+ return [list [expr {$s>>$n}] [expr {($delta>>$n)+1}]]
+}
+
+################################################################################
+# computes log(num/denom) with 'precision' bits
+# used to compute some analysis constants with a given accuracy
+# you might not call this procedure directly : it assumes 'num/denom'>4/5
+# and 'num/denom'<1
+################################################################################
+proc ::math::bigfloat::__log {num denom precision} {
+ # Please Note : we here need a precision increment, in order to
+ # keep accuracy at $precision digits. If we just hold $precision digits,
+ # each number being precise at the last digit +/- 1,
+ # we would lose accuracy because small uncertainties add to themselves.
+ # Example : 0.0001 + 0.0010 = 0.0011 +/- 0.0002
+ # This is quite the same reason that made tcl_precision defaults to 12 :
+ # internally, doubles are computed with 17 digits, but to keep precision
+ # we need to limit our results to 12.
+ # The solution : given a precision target, increment precision with a
+ # computed value so that all digits of he result are exacts.
+ #
+ # p is the precision
+ # pk is the precision increment
+ # 2 power pk is also the maximum number of iterations
+ # for a number close to 1 but lower than 1,
+ # (denom-num)/denum is (in our case) lower than 1/5
+ # so the maximum nb of iterations is for:
+ # 1/5*(1+1/5*(1/2+1/5*(1/3+1/5*(...))))
+ # the last term is 1/n*(1/5)^n
+ # for the last term to be lower than 2^(-p-pk)
+ # the number of iterations has to be
+ # 2^(-pk).(1/5)^(2^pk) < 2^(-p-pk)
+ # log(1/5).2^pk < -p
+ # 2^pk > p/log(5)
+ # pk > log(2)*log(p/log(5))
+ # now set the variable n to the precision increment i.e. pk
+ set n [expr {int(log(2)*log($precision/log(5)))+1}]
+ incr precision $n
+ # log(num/denom)=log(1-(denom-num)/denom)
+ # log(1+x) = x + x^2/2 + x^3/3 + ... + x^n/n
+ # = x(1 + x(1/2 + x(1/3 + x(...+ x(1/(n-1) + x/n)...))))
+ set num [expr {$denom-$num}]
+ # $s holds the result
+ set s [expr {($num<<$precision)/$denom}]
+ # $t holds x^n
+ set t [expr {$s*$num/$denom}]
+ set d 2
+ # $u holds x^n/n
+ set u [expr {$t/$d}]
+ while {$u!=0} {
+ incr s $u
+ # get x^n * x
+ set t [expr {$t*$num/$denom}]
+ # get n+1
+ incr d
+ # then : $u = x^(n+1)/(n+1)
+ set u [expr {$t/$d}]
+ }
+ # see head of the proc : we return the value with its target precision
+ return [expr {$s>>$n}]
+}
+
+################################################################################
+# computes log(2) with 'precision' bits and caches it into a namespace variable
+################################################################################
+proc ::math::bigfloat::__logbis {precision} {
+ set increment [expr {int(log($precision)/log(2)+1)}]
+ incr precision $increment
+ # ln(2)=3*ln(1-4/5)+ln(1-125/128)
+ set a [__log 125 128 $precision]
+ set b [__log 4 5 $precision]
+ set r [expr {$b*3+$a}]
+ set ::math::bigfloat::Log2 [expr {$r>>$increment}]
+ # formerly (when BigFloats were stored in ten radix) we had to compute log(10)
+ # ln(10)=10.ln(1-4/5)+3*ln(1-125/128)
+}
+
+
+################################################################################
+# retrieves log(2) with 'precision' bits ; the result is cached
+################################################################################
+proc ::math::bigfloat::_log2 {precision} {
+ variable Log2
+ if {![info exists Log2]} {
+ __logbis $precision
+ } else {
+ # the constant is cached and computed again when more precision is needed
+ set l [bits $Log2]
+ if {$precision>$l} {
+ __logbis $precision
+ }
+ }
+ # return log(2) with 'precision' bits even when the cached value has more bits
+ return [_round $Log2 $precision]
+}
+
+
+################################################################################
+# returns A modulo B (like with fmod() math function)
+################################################################################
+proc ::math::bigfloat::mod {a b} {
+ checkNumber $a
+ checkNumber $b
+ if {[isInt $a] && [isInt $b]} {return [expr {$a%$b}]}
+ if {[isInt $a]} {error "trying to divide an integer by a BigFloat"}
+ set quotient [div $a $b]
+ # examples : fmod(3,2)=1 quotient=1.5
+ # fmod(1,2)=1 quotient=0.5
+ # quotient>0 and b>0 : get floor(quotient)
+ # fmod(-3,-2)=-1 quotient=1.5
+ # fmod(-1,-2)=-1 quotient=0.5
+ # quotient>0 and b<0 : get floor(quotient)
+ # fmod(-3,2)=-1 quotient=-1.5
+ # fmod(-1,2)=-1 quotient=-0.5
+ # quotient<0 and b>0 : get ceil(quotient)
+ # fmod(3,-2)=1 quotient=-1.5
+ # fmod(1,-2)=1 quotient=-0.5
+ # quotient<0 and b<0 : get ceil(quotient)
+ if {[sign $quotient]} {
+ set quotient [ceil $quotient]
+ } else {
+ set quotient [floor $quotient]
+ }
+ return [sub $a [mul $quotient $b]]
+}
+
+################################################################################
+# returns A times B
+################################################################################
+proc ::math::bigfloat::mul {a b} {
+ checkNumber $a
+ checkNumber $b
+ # dispatch the command to appropriate commands regarding types (BigInt & BigFloat)
+ if {[isInt $a]} {
+ if {[isInt $b]} {
+ return [expr {$a*$b}]
+ }
+ return [mulFloatByInt $b $a]
+ }
+ if {[isInt $b]} {return [mulFloatByInt $a $b]}
+ # now we are sure that 'a' and 'b' are BigFloats
+ foreach {dummy integerA expA deltaA} $a {break}
+ foreach {dummy integerB expB deltaB} $b {break}
+ # 2^expA * 2^expB = 2^(expA+expB)
+ set exp [expr {$expA+$expB}]
+ # mantissas are multiplied
+ set integer [expr {$integerA*$integerB}]
+ # compute precisely the uncertainty
+ set delta [expr {$deltaA*(abs($integerB)+$deltaB)+abs($integerA)*$deltaB+1}]
+ # we have to normalize because 'delta' may be too big
+ return [normalize [list F $integer $exp $delta]]
+}
+
+################################################################################
+# returns A times B, where B is a positive integer
+################################################################################
+proc ::math::bigfloat::mulFloatByInt {a b} {
+ checkFloat $a
+ foreach {dummy integer exp delta} $a {break}
+ if {$b==0} {
+ return [list F 0 $exp $delta]
+ }
+ # Mantissa and Delta are simply multplied by $b
+ set integer [expr {$integer*$b}]
+ set delta [expr {$delta*$b}]
+ # We normalize because Delta could have seriously increased
+ return [normalize [list F $integer $exp $delta]]
+}
+
+################################################################################
+# normalizes a number : Delta (accuracy of the BigFloat)
+# has to be limited, because the memory use increase
+# quickly when we do some computations, as the Mantissa and Delta
+# increase together
+# The solution : limit the size of Delta to 16 bits
+################################################################################
+proc ::math::bigfloat::normalize {number} {
+ checkFloat $number
+ foreach {dummy integer exp delta} $number {break}
+ set l [bits $delta]
+ if {$l>16} {
+ incr l -16
+ # $l holds the supplementary size (in bits)
+ # now we can shift right by $l bits
+ # always round upper the Delta
+ set delta [expr {$delta>>$l}]
+ incr delta
+ set integer [expr {$integer>>$l}]
+ incr exp $l
+ }
+ return [list F $integer $exp $delta]
+}
+
+
+
+################################################################################
+# returns -A (the opposite)
+################################################################################
+proc ::math::bigfloat::opp {a} {
+ checkNumber $a
+ if {[iszero $a]} {
+ return $a
+ }
+ if {[isInt $a]} {
+ return [expr {-$a}]
+ }
+ # recursive call
+ lset a 1 [expr {-[lindex $a 1]}]
+ return $a
+}
+
+################################################################################
+# gets Pi with precision bits
+# after the dot (after you call [tostr] on the result)
+################################################################################
+proc ::math::bigfloat::pi {precision {binary 0}} {
+ if {![isInt $precision]} {
+ error "'$precision' expected to be an integer"
+ }
+ if {!$binary} {
+ # convert decimal digit length into bit length
+ set precision [expr {int(ceil($precision*log(10)/log(2)))}]
+ }
+ return [list F [_pi $precision] -$precision 1]
+}
+
+#
+# Procedure that resets the stored cached Pi constant
+#
+proc ::math::bigfloat::reset {} {
+ variable _pi0
+ if {[info exists _pi0]} {unset _pi0}
+}
+
+proc ::math::bigfloat::_pi {precision} {
+ # the constant Pi begins with 3.xxx
+ # so we need 2 digits to store the digit '3'
+ # and then we will have precision+2 bits in the mantissa
+ variable _pi0
+ if {![info exists _pi0]} {
+ set _pi0 [__pi $precision]
+ }
+ set lenPiGlobal [bits $_pi0]
+ if {$lenPiGlobal<$precision} {
+ set _pi0 [__pi $precision]
+ }
+ return [expr {$_pi0 >> [bits $_pi0]-2-$precision}]
+}
+
+################################################################################
+# computes an integer representing Pi in binary radix, with precision bits
+################################################################################
+proc ::math::bigfloat::__pi {precision} {
+ set safetyLimit 8
+ # for safety and for the better precision, we do so ...
+ incr precision $safetyLimit
+ # formula found in the Math litterature (on Wikipedia
+ # Pi/4 = 44.atan(1/57) + 7.atan(1/239) - 12.atan(1/682) + 24.atan(1/12943)
+ set a [expr {[_atanfract 57 $precision]*44}]
+ incr a [expr {[_atanfract 239 $precision]*7}]
+ set a [expr {$a - [_atanfract 682 $precision]*12}]
+ incr a [expr {[_atanfract 12943 $precision]*24}]
+ return [expr {$a>>$safetyLimit-2}]
+}
+
+################################################################################
+# shift right an integer until it haves $precision bits
+# round at the same time
+################################################################################
+proc ::math::bigfloat::_round {integer precision} {
+ set shift [expr {[bits $integer]-$precision}]
+ if {$shift==0} {
+ return $integer
+ }
+ # $result holds the shifted integer
+ set result [expr {$integer>>$shift}]
+ # $shift-1 is the bit just rights the last bit of the result
+ # Example : integer=1000010 shift=2
+ # => result=10000 and the tested bit is '1'
+ if {$integer & (1<<($shift-1))} {
+ # we round to the upper limit
+ return [incr result]
+ }
+ return $result
+}
+
+################################################################################
+# returns A power B, where B is a positive integer
+################################################################################
+proc ::math::bigfloat::pow {a b} {
+ checkNumber $a
+ if {$b<0} {
+ error "pow : exponent is not a positive integer"
+ }
+ # case where it is obvious that we should use the appropriate command
+ # from math::bignum (added 5th March 2005)
+ if {[isInt $a]} {
+ return [expr {$a**$b}]
+ }
+ # algorithm : exponent=$b = Sum(i=0..n) b(i)2^i
+ # $a^$b = $a^( b(0) + 2b(1) + 4b(2) + ... + 2^n*b(n) )
+ # we have $a^(x+y)=$a^x * $a^y
+ # then $a^$b = Product(i=0...n) $a^(2^i*b(i))
+ # b(i) is boolean so $a^(2^i*b(i))= 1 when b(i)=0 and = $a^(2^i) when b(i)=1
+ # then $a^$b = Product(i=0...n and b(i)=1) $a^(2^i) and 1 when $b=0
+ if {$b==0} {return 1}
+ # $res holds the result
+ set res 1
+ while {1} {
+ # at the beginning i=0
+ # $remainder is b(i)
+ set remainder [expr {$b&1}]
+ # $b 'rshift'ed by 1 bit : i=i+1
+ # so next time we will test bit b(i+1)
+ set b [expr {$b>>1}]
+ # if b(i)=1
+ if {$remainder} {
+ # mul the result by $a^(2^i)
+ # if i=0 we multiply by $a^(2^0)=$a^1=$a
+ set res [mul $res $a]
+ }
+ # no more bits at '1' in $b : $res is the result
+ if {$b==0} {
+ return [normalize $res]
+ }
+ # i=i+1 : $a^(2^(i+1)) = square of $a^(2^i)
+ set a [mul $a $a]
+ }
+}
+
+################################################################################
+# converts angles for radians to degrees
+################################################################################
+proc ::math::bigfloat::rad2deg {x} {
+ checkFloat $x
+ set xLen [expr {-[lindex $x 2]}]
+ if {$xLen<3} {
+ error "number too loose to convert to degrees"
+ }
+ # $rad/Pi=$deg/180
+ # so result in deg = $radians*180/Pi
+ return [div [mul $x 180] [pi $xLen 1]]
+}
+
+################################################################################
+# retourne la partie entire (ou 0) du nombre "number"
+################################################################################
+proc ::math::bigfloat::round {number} {
+ checkFloat $number
+ #set number [normalize $number]
+ # fetching integers (or BigInts) from the internal representation
+ foreach {dummy integer exp delta} $number {break}
+ if {$integer==0} {
+ return 0
+ }
+ if {$exp>=0} {
+ error "not enough precision to round (in round)"
+ }
+ set exp [expr {-$exp}]
+ # saving the sign, ...
+ set sign [expr {$integer<0}]
+ set integer [expr {abs($integer)}]
+ # integer part of the number
+ set try [expr {$integer>>$exp}]
+ # first bit after the dot
+ set way [expr {$integer>>($exp-1)&1}]
+ # delta is shifted so it gives the integer part of 2*delta
+ set delta [expr {$delta>>($exp-1)}]
+ # when delta is too big to compute rounded value (
+ if {$delta!=0} {
+ error "not enough precision to round (in round)"
+ }
+ if {$way} {
+ incr try
+ }
+ # ... restore the sign now
+ if {$sign} {return [expr {-$try}]}
+ return $try
+}
+
+################################################################################
+# round and divide by 10^n
+################################################################################
+proc ::math::bigfloat::roundshift {integer n} {
+ # $exp= 10^$n
+ incr n -1
+ set exp [expr {10**$n}]
+ set toround [expr {$integer/$exp}]
+ if {$toround%10>=5} {
+ return [expr {$toround/10+1}]
+ }
+ return [expr {$toround/10}]
+}
+
+################################################################################
+# gets the sign of either a bignum, or a BitFloat
+# we keep the bignum convention : 0 for positive, 1 for negative
+################################################################################
+proc ::math::bigfloat::sign {n} {
+ if {[isInt $n]} {
+ return [expr {$n<0}]
+ }
+ checkFloat $n
+ # sign of 0=0
+ if {[iszero $n]} {return 0}
+ # the sign of the Mantissa, which is a BigInt
+ return [sign [lindex $n 1]]
+}
+
+
+################################################################################
+# gets sin(x)
+################################################################################
+proc ::math::bigfloat::sin {x} {
+ checkFloat $x
+ foreach {dummy integer exp delta} $x {break}
+ if {$exp>-2} {
+ error "sin : not enough precision"
+ }
+ set precision [expr {-$exp}]
+ # sin(2kPi+x)=sin(x)
+ # $integer is now the modulo of the division of the mantissa by Pi/4
+ # and $n is the quotient
+ foreach {n integer} [divPiQuarter $integer $precision] {break}
+ incr delta $n
+ set d [expr {$n%4}]
+ # now integer>=0
+ # x = $n*Pi/4 + $integer and $n belongs to [0,3]
+ # sin(2Pi-x)=-sin(x)
+ # sin(Pi-x)=sin(x)
+ # sin(Pi/2+x)=cos(x)
+ set sign 0
+ switch -- $d {
+ 0 {set l [_sin2 $integer $precision $delta]}
+ 1 {set l [_cos2 $integer $precision $delta]}
+ 2 {set sign 1;set l [_sin2 $integer $precision $delta]}
+ 3 {set sign 1;set l [_cos2 $integer $precision $delta]}
+ default {error "internal error"}
+ }
+ # $l is a list : {Mantissa Precision Delta}
+ # precision --> the opposite of the exponent
+ # 1.000 = 1000*10^-3 so exponent=-3 and precision=3 digits
+ lset l 1 [expr {-([lindex $l 1])}]
+ # the sign depends on the switch statement below
+ #::math::bignum::setsign integer $sign
+ if {$sign} {
+ lset l 0 [expr {-[lindex $l 0]}]
+ }
+ # we insert the Bigfloat tag (F) and normalize the final result
+ return [normalize [linsert $l 0 F]]
+}
+
+proc ::math::bigfloat::_sin2 {x precision delta} {
+ set pi [_pi $precision]
+ # shift right by 1 = divide by 2
+ # shift right by 2 = divide by 4
+ set pis2 [expr {$pi>>1}]
+ set pis4 [expr {$pis2>>1}]
+ if {$x>=$pis4} {
+ # sin(Pi/2-x)=cos(x)
+ incr delta
+ set x [expr {$pis2-$x}]
+ return [_cos $x $precision $delta]
+ }
+ return [_sin $x $precision $delta]
+}
+
+################################################################################
+# sin(x) with 'x' lower than Pi/4 and positive
+# 'x' is the Mantissa - 'delta' is Delta
+# 'precision' is the opposite of the exponent
+################################################################################
+proc ::math::bigfloat::_sin {x precision delta} {
+ # $s holds the result
+ set s $x
+ # sin(x) = x - x^3/3! + x^5/5! - ... + (-1)^n*x^(2n+1)/(2n+1)!
+ # = x * (1 - x^2/(2*3) * (1 - x^2/(4*5) * (...* (1 - x^2/(2n*(2n+1)) )...)))
+ # The second expression allows us to compute the less we can
+
+ # $double holds the uncertainty (Delta) of x^2 : 2*(Mantissa*Delta) + Delta^2
+ # (Mantissa+Delta)^2=Mantissa^2 + 2*Mantissa*Delta + Delta^2
+ set double [expr {$x*$delta>>$precision-1}]
+ incr double [expr {1+$delta*$delta>>$precision}]
+ # $x holds the Mantissa of x^2
+ set x [expr {$x*$x>>$precision}]
+ set dt [expr {$x*$delta+$double*($s+$delta)>>$precision}]
+ incr dt
+ # $t holds $s * -(x^2) / (2n*(2n+1))
+ # mul by x^2
+ set t [expr {$s*$x>>$precision}]
+ set denom2 2
+ set denom3 3
+ # mul by -1 (opp) and divide by 2*3
+ set t [expr {-$t/($denom2*$denom3)}]
+ while {$t!=0} {
+ incr s $t
+ incr delta $dt
+ # incr n => 2n --> 2n+2 and 2n+1 --> 2n+3
+ incr denom2 2
+ incr denom3 2
+ # $dt is the Delta corresponding to $t
+ # $double "" "" "" "" $x (x^2)
+ # ($t+$dt) * ($x+$double) = $t*$x + ($dt*$x + $t*$double) + $dt*$double
+ # Mantissa^ ^--------Delta-------------------^
+ set dt [expr {$x*$dt+($t+$dt)*$double>>$precision}]
+ set t [expr {$t*$x>>$precision}]
+ # removed 2005/08/31 by sarnold75
+ #set dt [::math::bignum::add $dt $double]
+ set denom [expr {$denom2*$denom3}]
+ # now computing : div by -2n(2n+1)
+ set dt [expr {1+$dt/$denom}]
+ set t [expr {-$t/$denom}]
+ }
+ return [list $s $precision $delta]
+}
+
+
+################################################################################
+# procedure for extracting the square root of a BigFloat
+################################################################################
+proc ::math::bigfloat::sqrt {x} {
+ checkFloat $x
+ foreach {dummy integer exp delta} $x {break}
+ # if x=0, return 0
+ if {[iszero $x]} {
+ # return zero, taking care of its precision ($exp)
+ return [list F 0 $exp $delta]
+ }
+ # we cannot get sqrt(x) if x<0
+ if {[lindex $integer 0]<0} {
+ error "negative sqrt input"
+ }
+ # (1+epsilon)^p = 1 + epsilon*(p-1) + epsilon^2*(p-1)*(p-2)/2! + ...
+ # + epsilon^n*(p-1)*...*(p-n)/n!
+ # sqrt(1 + epsilon) = (1 + epsilon)^(1/2)
+ # = 1 - epsilon/2 - epsilon^2*3/(4*2!) - ...
+ # - epsilon^n*(3*5*..*(2n-1))/(2^n*n!)
+ # sqrt(1 - epsilon) = 1 + Sum(i=1..infinity) epsilon^i*(3*5*...*(2i-1))/(i!*2^i)
+ # sqrt(n +/- delta)=sqrt(n) * sqrt(1 +/- delta/n)
+ # so the uncertainty on sqrt(n +/- delta) equals sqrt(n) * (sqrt(1 - delta/n) - 1)
+ # sqrt(1+eps) < sqrt(1-eps) because their logarithm compare as :
+ # -ln(2)(1+eps) < -ln(2)(1-eps)
+ # finally :
+ # Delta = sqrt(n) * Sum(i=1..infinity) (delta/n)^i*(3*5*...*(2i-1))/(i!*2^i)
+ # here we compute the second term of the product by _sqrtOnePlusEpsilon
+ set delta [_sqrtOnePlusEpsilon $delta $integer]
+ set intLen [bits $integer]
+ # removed 2005/08/31 by sarnold75, readded 2005/08/31
+ set precision $intLen
+ # intLen + exp = number of bits before the dot
+ #set precision [expr {-$exp}]
+ # square root extraction
+ set integer [expr {$integer<<$intLen}]
+ incr exp -$intLen
+ incr intLen $intLen
+ # there is an exponent 2^$exp : when $exp is odd, we would need to compute sqrt(2)
+ # so we decrement $exp, in order to get it even, and we do not need sqrt(2) anymore !
+ if {$exp&1} {
+ incr exp -1
+ set integer [expr {$integer<<1}]
+ incr intLen
+ incr precision
+ }
+ # using a low-level (taken from math::bignum) root extraction procedure
+ # using binary operators
+ set integer [_sqrt $integer]
+ # delta has to be multiplied by the square root
+ set delta [expr {$delta*$integer>>$precision}]
+ # round to the ceiling the uncertainty (worst precision, the fastest to compute)
+ incr delta
+ # we are sure that $exp is even, see above
+ return [normalize [list F $integer [expr {$exp/2}] $delta]]
+}
+
+
+
+################################################################################
+# compute abs(sqrt(1-delta/integer)-1)
+# the returned value is a relative uncertainty
+################################################################################
+proc ::math::bigfloat::_sqrtOnePlusEpsilon {delta integer} {
+ # sqrt(1-x) - 1 = x/2 + x^2*3/(2^2*2!) + x^3*3*5/(2^3*3!) + ...
+ # = x/2 * (1 + x*3/(2*2) * ( 1 + x*5/(2*3) *
+ # (...* (1 + x*(2n-1)/(2n) ) )...)))
+ set l [bits $integer]
+ # to compute delta/integer we have to shift left to keep the same precision level
+ # we have a better accuracy computing (delta << lg(integer))/integer
+ # than computing (delta/integer) << lg(integer)
+ set x [expr {($delta<<$l)/$integer}]
+ # denom holds 2n
+ set denom 4
+ # x/2
+ set result [expr {$x>>1}]
+ # x^2*3/(2!*2^2)
+ # numerator holds 2n-1
+ set numerator 3
+ set temp [expr {($result*$delta*$numerator)/($integer*$denom)}]
+ incr temp
+ while {$temp!=0} {
+ incr result $temp
+ incr numerator 2
+ incr denom 2
+ # n = n+1 ==> num=num+2 denom=denom+2
+ # num=2n+1 denom=2n+2
+ set temp [expr {($temp*$delta*$numerator)/($integer*$denom)}]
+ }
+ return $result
+}
+
+#
+# Computes the square root of an integer
+# Returns an integer
+#
+proc ::math::bigfloat::_sqrt {n} {
+ set i [expr {(([bits $n]-1)/2)+1}]
+ set b [expr {$i*2}] ; # Bit to set to get 2^i*2^i
+
+ set r 0 ; # guess
+ set x 0 ; # guess^2
+ set s 0 ; # guess^2 backup
+ set t 0 ; # intermediate result
+ for {} {$i >= 0} {incr i -1; incr b -2} {
+ set x [expr {$s+($t|(1<<$b))}]
+ if {abs($x)<= abs($n)} {
+ set s $x
+ set r [expr {$r|(1<<$i)}]
+ set t [expr {$t|(1<<$b+1)}]
+ }
+ set t [expr {$t>>1}]
+ }
+ return $r
+}
+
+################################################################################
+# substracts B to A
+################################################################################
+proc ::math::bigfloat::sub {a b} {
+ checkNumber $a
+ checkNumber $b
+ if {[isInt $a] && [isInt $b]} {
+ # the math::bignum::sub proc is designed to work with BigInts
+ return [expr {$a-$b}]
+ }
+ return [add $a [opp $b]]
+}
+
+################################################################################
+# tangent (trivial algorithm)
+################################################################################
+proc ::math::bigfloat::tan {x} {
+ return [::math::bigfloat::div [::math::bigfloat::sin $x] [::math::bigfloat::cos $x]]
+}
+
+################################################################################
+# returns a power of ten
+################################################################################
+proc ::math::bigfloat::tenPow {n} {
+ return [expr {10**$n}]
+}
+
+
+################################################################################
+# converts a BigInt to a double (basic floating-point type)
+# with respect to the global variable 'tcl_precision'
+################################################################################
+proc ::math::bigfloat::todouble {x} {
+ global tcl_precision
+ set precision $tcl_precision
+ if {$precision==0} {
+ # this is a cheat, I must admit, for Tcl 8.5
+ set precision 16
+ }
+ checkFloat $x
+ # get the string repr of x without the '+' sign
+ # please note: here we call math::bigfloat::tostr
+ set result [string trimleft [tostr $x] +]
+ set minus ""
+ if {[string index $result 0]=="-"} {
+ set minus -
+ set result [string range $result 1 end]
+ }
+
+ set l [split $result e]
+ set exp 0
+ if {[llength $l]==2} {
+ # exp : x=Mantissa*2^Exp
+ set exp [lindex $l 1]
+ }
+ # caution with octal numbers : we have to remove heading zeros
+ # but count them as digits
+ regexp {^0*} $result zeros
+ incr exp -[string length $zeros]
+ # Mantissa = integerPart.fractionalPart
+ set l [split [lindex $l 0] .]
+ set integerPart [lindex $l 0]
+ set integerLen [string length $integerPart]
+ set fractionalPart [lindex $l 1]
+ # The number of digits in Mantissa, excluding the dot and the leading zeros, of course
+ set integer [string trimleft $integerPart$fractionalPart 0]
+ if {$integer eq ""} {
+ set integer 0
+ }
+ set len [string length $integer]
+ # Now Mantissa is stored in $integer
+ if {$len>$precision} {
+ set lenDiff [expr {$len-$precision}]
+ # true when the number begins with a zero
+ set zeroHead 0
+ if {[string index $integer 0]==0} {
+ incr lenDiff -1
+ set zeroHead 1
+ }
+ set integer [roundshift $integer $lenDiff]
+ if {$zeroHead} {
+ set integer 0$integer
+ }
+ set len [string length $integer]
+ if {$len<$integerLen} {
+ set exp [expr {$integerLen-$len}]
+ # restore the true length
+ set integerLen $len
+ }
+ }
+ # number = 'sign'*'integer'*10^'exp'
+ if {$exp==0} {
+ # no scientific notation
+ set exp ""
+ } else {
+ # scientific notation
+ set exp e$exp
+ }
+ # place the dot just before the index $integerLen in the Mantissa
+ set result [string range $integer 0 [expr {$integerLen-1}]]
+ append result .[string range $integer $integerLen end]
+ # join the Mantissa with the sign before and the exponent after
+ return $minus$result$exp
+}
+
+################################################################################
+# converts a number stored as a list to a string in which all digits are true
+################################################################################
+proc ::math::bigfloat::tostr {args} {
+ if {[llength $args]==2} {
+ if {![string equal [lindex $args 0] -nosci]} {error "unknown option: should be -nosci"}
+ set nosci yes
+ set number [lindex $args 1]
+ } else {
+ if {[llength $args]!=1} {error "syntax error: should be tostr ?-nosci? number"}
+ set nosci no
+ set number [lindex $args 0]
+ }
+ if {[isInt $number]} {
+ return $number
+ }
+ checkFloat $number
+ foreach {dummy integer exp delta} $number {break}
+ if {[iszero $number]} {
+ # we do matter how much precision $number has :
+ # it can be 0.0000000 or 0.0, the result is not the same zero
+ #return 0
+ }
+ if {$exp>0} {
+ # the power of ten the closest but greater than 2^$exp
+ # if it was lower than the power of 2, we would have more precision
+ # than existing in the number
+ set newExp [expr {int(ceil($exp*log(2)/log(10)))}]
+ # 'integer' <- 'integer' * 2^exp / 10^newExp
+ # equals 'integer' * 2^(exp-newExp) / 5^newExp
+ set binExp [expr {$exp-$newExp}]
+ if {$binExp<0} {
+ # it cannot happen
+ error "internal error"
+ }
+ # 5^newExp
+ set fivePower [expr {5**$newExp}]
+ # 'lshift'ing $integer by $binExp bits is like multiplying it by 2^$binExp
+ # but much, much faster
+ set integer [expr {($integer<<$binExp)/$fivePower}]
+ # $integer is the Mantissa - Delta should follow the same operations
+ set delta [expr {($delta<<$binExp)/$fivePower}]
+ set exp $newExp
+ } elseif {$exp<0} {
+ # the power of ten the closest but lower than 2^$exp
+ # same remark about the precision
+ set newExp [expr {int(floor(-$exp*log(2)/log(10)))}]
+ # 'integer' <- 'integer' * 10^newExp / 2^(-exp)
+ # equals 'integer' * 5^(newExp) / 2^(-exp-newExp)
+ set binShift [expr {-$exp-$newExp}]
+ set fivePower [expr {5**$newExp}]
+ # rshifting is like dividing by 2^$binShift, but faster as we said above about lshift
+ set integer [expr {$integer*$fivePower>>$binShift}]
+ set delta [expr {$delta*$fivePower>>$binShift}]
+ set exp -$newExp
+ }
+ # saving the sign, to restore it into the result
+ set result [expr {abs($integer)}]
+ set sign [expr {$integer<0}]
+ # rounded 'integer' +/- 'delta'
+ set up [expr {$result+$delta}]
+ set down [expr {$result-$delta}]
+ if {($up<0 && $down>0)||($up>0 && $down<0)} {
+ # $up>0 and $down<0 or vice-versa : then the number is considered equal to zero
+ set isZero yes
+ # delta <= 2**n (n = bits(delta))
+ # 2**n <= 10**exp , then
+ # exp >= n.log(2)/log(10)
+ # delta <= 10**(n.log(2)/log(10))
+ incr exp [expr {int(ceil([bits $delta]*log(2)/log(10)))}]
+ set result 0
+ } else {
+ # iterate until the convergence of the rounding
+ # we incr $shift until $up and $down are rounded to the same number
+ # at each pass we lose one digit of precision, so necessarly it will success
+ for {set shift 1} {
+ [roundshift $up $shift]!=[roundshift $down $shift]
+ } {
+ incr shift
+ } {}
+ incr exp $shift
+ set result [roundshift $up $shift]
+ set isZero no
+ }
+ set l [string length $result]
+ # now formatting the number the most nicely for having a clear reading
+ # would'nt we allow a number being constantly displayed
+ # as : 0.2947497845e+012 , would we ?
+ if {$nosci} {
+ if {$exp >= 0} {
+ append result [string repeat 0 $exp].
+ } elseif {$l + $exp > 0} {
+ set result [string range $result 0 end-[expr {-$exp}]].[string range $result end-[expr {-1-$exp}] end]
+ } else {
+ set result 0.[string repeat 0 [expr {-$exp-$l}]]$result
+ }
+ } else {
+ if {$exp>0} {
+ # we display 423*10^6 as : 4.23e+8
+ # Length of mantissa : $l
+ # Increment exp by $l-1 because the first digit is placed before the dot,
+ # the other ($l-1) digits following the dot.
+ incr exp [incr l -1]
+ set result [string index $result 0].[string range $result 1 end]
+ append result "e+$exp"
+ } elseif {$exp==0} {
+ # it must have a dot to be a floating-point number (syntaxically speaking)
+ append result .
+ } else {
+ set exp [expr {-$exp}]
+ if {$exp < $l} {
+ # we can display the number nicely as xxxx.yyyy*
+ # the problem of the sign is solved finally at the bottom of the proc
+ set n [string range $result 0 end-$exp]
+ incr exp -1
+ append n .[string range $result end-$exp end]
+ set result $n
+ } elseif {$l==$exp} {
+ # we avoid to use the scientific notation
+ # because it is harder to read
+ set result "0.$result"
+ } else {
+ # ... but here there is no choice, we should not represent a number
+ # with more than one leading zero
+ set result [string index $result 0].[string range $result 1 end]e-[expr {$exp-$l+1}]
+ }
+ }
+ }
+ # restore the sign : we only put a minus on numbers that are different from zero
+ if {$sign==1 && !$isZero} {set result "-$result"}
+ return $result
+}
+
+################################################################################
+# PART IV
+# HYPERBOLIC FUNCTIONS
+################################################################################
+
+################################################################################
+# hyperbolic cosinus
+################################################################################
+proc ::math::bigfloat::cosh {x} {
+ # cosh(x) = (exp(x)+exp(-x))/2
+ # dividing by 2 is done faster by 'rshift'ing
+ return [floatRShift [add [exp $x] [exp [opp $x]]] 1]
+}
+
+################################################################################
+# hyperbolic sinus
+################################################################################
+proc ::math::bigfloat::sinh {x} {
+ # sinh(x) = (exp(x)-exp(-x))/2
+ # dividing by 2 is done faster by 'rshift'ing
+ return [floatRShift [sub [exp $x] [exp [opp $x]]] 1]
+}
+
+################################################################################
+# hyperbolic tangent
+################################################################################
+proc ::math::bigfloat::tanh {x} {
+ set up [exp $x]
+ set down [exp [opp $x]]
+ # tanh(x)=sinh(x)/cosh(x)= (exp(x)-exp(-x))/2/ [(exp(x)+exp(-x))/2]
+ # =(exp(x)-exp(-x))/(exp(x)+exp(-x))
+ # =($up-$down)/($up+$down)
+ return [div [sub $up $down] [add $up $down]]
+}
+
+# exporting public interface
+namespace eval ::math::bigfloat {
+ foreach function {
+ add mul sub div mod pow
+ iszero compare equal
+ fromstr tostr fromdouble todouble
+ int2float isInt isFloat
+ exp log sqrt round ceil floor
+ sin cos tan cotan asin acos atan
+ cosh sinh tanh abs opp
+ pi deg2rad rad2deg
+ } {
+ namespace export $function
+ }
+}
+
+# (AM) No "namespace import" - this should be left to the user!
+#namespace import ::math::bigfloat::*
+
+package provide math::bigfloat 2.0.2
diff --git a/tcllib/modules/math/bigfloat2.test b/tcllib/modules/math/bigfloat2.test
new file mode 100644
index 0000000..0177d6d
--- /dev/null
+++ b/tcllib/modules/math/bigfloat2.test
@@ -0,0 +1,641 @@
+# -*- tcl -*-
+########################################################################
+# BigFloat for Tcl
+# Copyright (C) 2003-2005 ARNOLD Stephane
+# This software is covered by tcllib's license terms.
+# See the "license.terms" provided with tcllib.
+########################################################################
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 1.0
+
+support {
+ useLocal math.tcl math
+}
+testing {
+ useLocal bigfloat2.tcl math::bigfloat
+}
+
+# -------------------------------------------------------------------------
+
+namespace import ::math::bigfloat::*
+
+# -------------------------------------------------------------------------
+
+proc assert {name version code result} {
+ tcltest::test bigfloat-$name-$version "Some integer computations related to command $name" {uplevel 1 $code} $result
+ return
+}
+
+interp alias {} zero {} string repeat 0
+# S.ARNOLD 08/01/2005
+# trying to set the precision of the comparisons to 15 digits
+set old_precision $::tcl_precision
+set ::tcl_precision 15
+proc Zero {x} {
+ global tcl_precision
+ set x [expr {abs($x)}]
+ set epsilon 10.0e-$tcl_precision
+ return [expr {$x<$epsilon}]
+}
+
+proc fassert {name version code result} {
+ #puts -nonewline $version,
+ set tested [uplevel 1 $code]
+ if {[Zero $tested]} {
+ tcltest::test bigfloat-$name-$version "Some floating-point computations related to command $name" {return [Zero $result]} 1
+ return
+ }
+ set resultat [Zero [expr {($tested-$result)/((abs($tested)>1)?($tested):1.0)}]]
+ tcltest::test bigfloat-$name-$version "Some floating-point computations related to command $name" {return $resultat} 1
+ return
+}
+# preprocessing is done
+#set n
+
+
+######################################################
+# Begin testsuite
+######################################################
+
+proc testSuite {} {
+
+
+ # adds 999..9 and 1 -> 1000..0
+ for {set i 1} {$i<15} {incr i} {
+ assert add 1.0 {tostr [add \
+ [fromstr [string repeat 999 $i]] [fromstr 1]]
+ } 1[string repeat 000 $i]
+ }
+ # sub 1000..0 1 -> 999..9
+ for {set i 1} {$i<15} {incr i} {
+ assert sub 1.1 {tostr [sub [fromstr 1[string repeat 000 $i]] [fromstr 1]]} \
+ [string repeat 999 $i]
+ }
+ # mul 10001000..1000 with 1..9
+ for {set i 1} {$i<15} {incr i} {
+ foreach j {1 2 3 4 5 6 7 8 9} {
+ assert mul 1.2 {tostr [mul [fromstr [string repeat 1000 $i]] [fromstr $j]]} \
+ [string repeat ${j}000 $i]
+ }
+ }
+ # div 10^8 by 1 .. 9
+ for {set i 1} {$i<=9} {incr i} {
+ assert div 1.3 {tostr [div [fromstr 100000000] [fromstr $i]]} [expr {wide(100000000)/$i}]
+ }
+
+
+ # 10^8 modulo 1 .. 9
+ for {set i 1} {$i<=9} {incr i} {
+ assert mod 1.4 {tostr [mod [fromstr 100000000] [fromstr $i]]} [expr {wide(100000000)%$i}]
+ }
+
+ ################################################################################
+ # fromstr problem with octal exponents
+ ################################################################################
+ fassert fromstr 2.0 {todouble [fromstr 1.0e+099]} 1.0e+099
+ fassert fromstr 2.0a {todouble [fromstr 1.0e99]} 1.0e99
+ fassert fromstr 2.0b {todouble [fromstr 1.0e-99]} 1.0e-99
+ fassert fromstr 2.0c {todouble [fromstr 1.0e-099]} 1.0e-99
+
+
+ ################################################################################
+ # fromdouble with precision
+ ################################################################################
+ assert fromdouble 2.1 {tostr [ceil [fromdouble 1.0e99 100]]} 1[zero 99]
+ assert fromdouble 2.1a {tostr [fromdouble 1.11 3]} 1.11
+ assert fromdouble 2.1b {tostr [fromdouble +1.11 3]} 1.11
+ assert fromdouble 2.1c {tostr [fromdouble -1.11 3]} -1.11
+ assert fromdouble 2.1d {tostr [fromdouble +01.11 3]} 1.11
+ assert fromdouble 2.1e {tostr [fromdouble -01.11 3]} -1.11
+ # more to come...
+ fassert fromdouble 2.1f {compare [fromdouble [expr {atan(1.0)*4}]] [pi $::tcl_precision]} 0
+
+ ################################################################################
+ # abs()
+ ################################################################################
+ proc absTest {version x {int 0}} {
+ if {!$int} {
+ fassert abs $version {
+ tostr [abs [fromstr $x]]
+ } [expr {abs($x)}]
+ } else {
+ assert abs $version {
+ tostr [abs [fromstr $x]]
+ } [expr {($x<0)?(-$x):$x}]
+ }
+
+ }
+ absTest 2.2a 1.000
+ absTest 2.2b -1.000
+ absTest 2.2c -0.10
+ absTest 2.2d 0 1
+ absTest 2.2e 1 1
+ absTest 2.2f 10000 1
+ absTest 2.2g -1 1
+ absTest 2.2h -10000 1
+ rename absTest ""
+
+ ################################################################################
+ # opposite
+ ################################################################################
+ proc oppTest {version x {int 0}} {
+ if {$int} {
+ assert opp $version {tostr [opp [fromstr $x]]} [expr {-$x}]
+ } else {
+ fassert opp $version {tostr [opp [fromstr $x]]} [expr {-$x}]
+ }
+
+ }
+ oppTest 2.3a 1.00
+ oppTest 2.3b -1.00
+ oppTest 2.3c 0.10
+ oppTest 2.3d -0.10
+ oppTest 2.3e 0.00
+ oppTest 2.3f 1 1
+ oppTest 2.3g -1 1
+ oppTest 2.3h 0 1
+ oppTest 2.3i 100000000 1
+ oppTest 2.3j -100000000 1
+ rename oppTest ""
+
+ ################################################################################
+ # equal
+ ################################################################################
+ proc equalTest {x y} {
+ equal [fromstr $x] [fromstr $y]
+ }
+ assert equal 2.4a {equalTest 0.0 0.1} 1
+ assert equal 2.4b {equalTest 0.00 0.10} 0
+ assert equal 2.4c {equalTest 0.0 -0.1} 1
+ assert equal 2.4d {equalTest 0.00 -0.10} 0
+
+ rename equalTest ""
+ ################################################################################
+ # compare
+ ################################################################################
+ proc compareTest {x y} {
+ compare [fromstr $x] [fromstr $y]
+ }
+ assert cmp 2.5a {compareTest 0.00 0.10} -1
+ assert cmp 2.5b {compareTest 0.1 0.4} -1
+ assert cmp 2.5c {compareTest 0.0 -1.0} 1
+ assert cmp 2.5d {compareTest -1.0 0.0} -1
+ assert cmp 2.5e {compareTest 0.00 0.10} -1
+
+ # cleanup
+ rename compareTest ""
+
+ ################################################################################
+ # round
+ ################################################################################
+ proc roundTest {version x rounded} {
+ assert round $version {tostr [round [fromstr $x]]} $rounded
+ }
+ roundTest 2.6a 0.10 0
+ roundTest 2.6b 0.0 0
+ roundTest 2.6c 0.50 1
+ roundTest 2.6d 0.40 0
+ roundTest 2.6e 1.0 1
+ roundTest 2.6d -0.40 0
+ roundTest 2.6e -0.50 -1
+ roundTest 2.6f -1.0 -1
+ roundTest 2.6g -1.50 -2
+ roundTest 2.6h 1.50 2
+ roundTest 2.6i 0.49 0
+ roundTest 2.6j -0.49 0
+ roundTest 2.6k 1.49 1
+ roundTest 2.6l -1.49 -1
+
+
+ # cleanup
+ rename roundTest ""
+
+ ################################################################################
+ # floor
+ ################################################################################
+ proc floorTest {version x} {
+ assert floor $version {tostr [floor [fromstr $x]]} [expr {int(floor($x))}]
+ }
+ floorTest 2.7a 0.10
+ floorTest 2.7b 0.90
+ floorTest 2.7c 1.0
+ floorTest 2.7d -0.10
+ floorTest 2.7e -1.0
+
+ # cleanup
+ rename floorTest ""
+
+ ################################################################################
+ # ceil
+ ################################################################################
+ proc ceilTest {version x} {
+ assert ceil $version {tostr [ceil [fromstr $x]]} [expr {int(ceil($x))}]
+ }
+ ceilTest 2.8a 0.10
+ ceilTest 2.8b 0.90
+ ceilTest 2.8c 1.0
+ ceilTest 2.8d -0.10
+ ceilTest 2.8e -1.0
+ ceilTest 2.8f 0.0
+
+ # cleanup
+ rename ceilTest ""
+
+ ################################################################################
+ # BigInt to BigFloat conversion
+ ################################################################################
+ proc convTest {version x {decimals 1}} {
+ assert int2float $version {tostr [int2float [fromstr $x] $decimals]} \
+ $x.[string repeat 0 [expr {$decimals-1}]]
+ }
+ set subversion 0
+ foreach decimals {1 2 5 10 100} {
+ set version 2.9.$subversion
+ fassert int2float $version.0 {tostr [int2float [fromstr 0] $decimals]} 0.0
+ convTest $version.1 1 $decimals
+ convTest $version.2 5 $decimals
+ convTest $version.3 5000000000 $decimals
+ incr subversion
+ }
+ #cleanup
+ rename convTest ""
+
+ ################################################################################
+ # addition
+ ################################################################################
+ proc addTest {version x y} {
+ fassert add $version {todouble [add [fromstr $x] [fromstr $y]]} [expr {$x+$y}]
+ }
+ addTest 3.0a 1.00 2.00
+ addTest 3.0b -1.00 2.00
+ addTest 3.0c 1.00 -2.00
+ addTest 3.0d -1.00 -2.00
+ addTest 3.0e 0.00 1.00
+ addTest 3.0f 0.00 -1.00
+ addTest 3.0g 1 2.00
+ addTest 3.0h 1 -2.00
+ addTest 3.0i 0 1.00
+ addTest 3.0j 0 -1.00
+ addTest 3.0k 2.00 1
+ addTest 3.0l -2.00 1
+ addTest 3.0m 1.00 0
+ addTest 3.0n -1.00 0
+ #cleanup
+ rename addTest ""
+
+ ################################################################################
+ # substraction
+ ################################################################################
+ proc subTest {version x y} {
+ fassert sub $version {todouble [sub [fromstr $x] [fromstr $y]]} [expr {$x-$y}]
+ }
+ subTest 3.1a 1.00 2.00
+ subTest 3.1b -1.00 2.00
+ subTest 3.1c 1.00 -2.00
+ subTest 3.1d -1.00 -2.00
+ subTest 3.1e 0.00 1.00
+ subTest 3.1f 0.00 -1.00
+ subTest 3.1g 1 2.00
+ subTest 3.1h 1 -2.00
+ subTest 3.1i 0 2.00
+ subTest 3.1j 0 -2.00
+ subTest 3.1k 2 0.00
+ subTest 3.1l 2.00 1
+ subTest 3.1m 1.00 2
+ subTest 3.1n -1.00 1
+ subTest 3.1o 0.00 2
+ subTest 3.1p 2.00 0
+ # cleanup
+ rename subTest ""
+
+ ################################################################################
+ # multiplication
+ ################################################################################
+ proc mulTest {version x y} {
+ fassert mul $version {todouble [mul [fromstr $x] [fromstr $y]]} [expr {$x*$y}]
+ }
+ proc mulInt {version x y} {
+ mulTest $version.0 $x $y
+ mulTest $version.1 $y $x
+ }
+ mulTest 3.2a 1.00 2.00
+ mulTest 3.2b -1.00 2.00
+ mulTest 3.2c 1.00 -2.00
+ mulTest 3.2d -1.00 -2.00
+ mulTest 3.2e 0.00 1.00
+ mulTest 3.2f 0.00 -1.00
+ mulTest 3.2g 1.00 10.0
+ mulInt 3.2h 1 2.00
+ mulInt 3.2i 1 -2.00
+ mulInt 3.2j 0 2.00
+ mulInt 3.2k 0 -2.00
+ mulInt 3.2l 10 2.00
+ mulInt 3.2m 10 -2.00
+ mulInt 3.2n 1 0.00
+
+
+ # cleanup
+ rename mulTest ""
+ rename mulInt ""
+
+ ################################################################################
+ # division
+ ################################################################################
+ proc divTest {version x y} {
+ fassert div $version {
+ string trimright [todouble [div [fromstr $x] [fromstr $y]]] 0
+ } [string trimright [expr {$x/$y}] 0]
+ }
+
+
+ divTest 3.3a 1.00 2.00
+ divTest 3.3b 2.00 1.00
+ divTest 3.3c -1.00 2.00
+ divTest 3.3d 1.00 -2.00
+ divTest 3.3e 2.00 -1.00
+ divTest 3.3f -2.00 1.00
+ divTest 3.3g -1.00 -2.00
+ divTest 3.3h -2.00 -1.00
+ divTest 3.3i 0.0 1.0
+ divTest 3.3j 0.0 -1.0
+
+ # cleanup
+ rename divTest ""
+
+ ################################################################################
+ # rest of the division
+ ################################################################################
+ proc modTest {version x y} {
+ fassert mod $version {
+ todouble [mod [fromstr $x] [fromstr $y]]
+ } [expr {fmod($x,$y)}]
+ }
+
+ modTest 3.4a 1.00 2.00
+ modTest 3.4b 2.00 1.00
+ modTest 3.4c -1.00 2.00
+ modTest 3.4d 1.00 -2.00
+ modTest 3.4e 2.00 -1.00
+ modTest 3.4f -2.00 1.00
+ modTest 3.4g -1.00 -2.00
+ modTest 3.4h -2.00 -1.00
+ modTest 3.4i 0.0 1.0
+ modTest 3.4j 0.0 -1.0
+
+ modTest 3.4k 1.00 2
+ modTest 3.4l 2.00 1
+ modTest 3.4m -1.00 2
+ modTest 3.4n -2.00 1
+ modTest 3.4o 0.0 1
+ modTest 3.4p 1.50 1
+
+ # cleanup
+ rename modTest ""
+
+ ################################################################################
+ # divide a BigFloat by an integer
+ ################################################################################
+ proc divTest {version x y} {
+ fassert div $version {todouble [div [fromstr $x] [fromstr $y]]} \
+ [expr {double(round(1000*$x/$y))/1000.0}]
+ }
+ set subversion 0
+ foreach a {1.0000 -1.0000} {
+ foreach b {2 3} {
+ divTest 3.5.$subversion $a $b
+ incr subversion
+ }
+ }
+
+ # cleanup
+ rename divTest ""
+
+ ################################################################################
+ # pow : takes a float to an integer power (>0)
+ ################################################################################
+ proc powTest {version x y {int 0}} {
+ if {!$int} {
+ fassert pow $version {todouble [pow [fromstr $x 14] [fromstr $y]]}\
+ [expr [join [string repeat "[string trimright $x 0] " $y] *]]
+ } else {
+ assert pow $version {tostr [pow [fromstr $x] [fromstr $y]]}\
+ [expr [join [string repeat "$x " $y] *]]
+ }
+ }
+ set subversion 0
+ foreach a {1 -1 2 -2 5 -5} {
+ foreach b {2 3 7 16} {
+ powTest 3.6.$subversion $a. $b
+ incr subversion
+ }
+ }
+ set subversion 0
+ foreach a {1 2 3} {
+ foreach b {2 3 5 8} {
+ powTest 3.7.$subversion $a $b 1
+ incr subversion
+ }
+ }
+
+ # cleanup
+ rename powTest ""
+
+
+ ################################################################################
+ # pi constant and angles conversion
+ ################################################################################
+ fassert pi 3.8.0 {todouble [pi 16]} [expr {atan(1)*4}]
+ # converts Pi -> 180
+ fassert rad2deg 3.8.1 {todouble [rad2deg [pi 20]]} 180.0
+ # converts 180 -> Pi
+ fassert deg2rad 3.8.2 {todouble [deg2rad [fromstr 180.0 20]]} [expr {atan(1.0)*4}]
+
+
+ ################################################################################
+ # iszero : the precision is too small to determinate the number
+ ################################################################################
+
+ assert iszero 4.0a {iszero [fromstr 0]} 1
+ assert iszero 4.0b {iszero [fromstr 0.0]} 1
+ assert iszero 4.0c {iszero [fromstr 1]} 0
+ assert iszero 4.0d {iszero [fromstr 1.0]} 0
+ assert iszero 4.0e {iszero [fromstr -1]} 0
+ assert iszero 4.0f {iszero [fromstr -1.0]} 0
+
+ ################################################################################
+ # sqrt : square root
+ ################################################################################
+ proc sqrtTest {version x} {
+ fassert sqrt $version {todouble [sqrt [fromstr $x 18]]} [expr {sqrt($x)}]
+ }
+ sqrtTest 4.1a 1.
+ sqrtTest 4.1b 0.001
+ sqrtTest 4.1c 0.004
+ sqrtTest 4.1d 4.
+
+ # cleanup
+ rename sqrtTest ""
+
+
+ ################################################################################
+ # expTest : exponential function
+ ################################################################################
+ proc expTest {version x} {
+ fassert exp $version {todouble [exp [fromstr $x 17]]} [expr {exp($x)}]
+ }
+
+ expTest 4.2a 1.
+ expTest 4.2b 0.001
+ expTest 4.2c 0.004
+ expTest 4.2d 40.
+ expTest 4.2e -0.001
+
+ # cleanup
+ rename expTest ""
+
+ ################################################################################
+ # logTest : logarithm
+ ################################################################################
+ proc logTest {version x} {
+ fassert log $version {todouble [log [fromstr $x 17]]} [expr {log($x)}]
+ }
+
+ logTest 4.3a 1.0
+ logTest 4.3b 0.001
+ logTest 4.3c 0.004
+ logTest 4.3d 40.
+ logTest 4.3e 1[zero 10].0
+
+ # cleanup
+ rename logTest ""
+
+ ################################################################################
+ # cos & sin : trigonometry
+ ################################################################################
+ proc cosEtSin {version quartersOfPi} {
+ set x [div [mul [pi 18] [fromstr $quartersOfPi]] [fromstr 4]]
+ #fassert cos {todouble [cos $x]} [expr {cos(atan(1)*$quartersOfPi)}]
+ #fassert sin {todouble [sin $x]} [expr {sin(atan(1)*$quartersOfPi)}]
+ fassert cos $version.0 {todouble [cos $x]} [expr {cos([todouble $x])}]
+ fassert sin $version.1 {todouble [sin $x]} [expr {sin([todouble $x])}]
+ }
+
+ fassert cos 4.4.0.0 {todouble [cos [fromstr 0. 17]]} [expr {cos(0)}]
+ fassert sin 4.4.0.1 {todouble [sin [fromstr 0. 17]]} [expr {sin(0)}]
+ foreach i {1 2 3 4 5 6 7 8} {
+ cosEtSin 4.4.$i $i
+ }
+
+
+ # cleanup
+ rename cosEtSin ""
+
+ ################################################################################
+ # tan & cotan : trigonometry
+ ################################################################################
+ proc tanCotan {version i} {
+ upvar pi pi
+ set x [div [mul $pi [fromstr $i]] [fromstr 10]]
+ set double [expr {atan(1)*(double($i)*0.4)}]
+ fassert cos $version.0 {todouble [cos $x]} [expr {cos($double)}]
+ fassert sin $version.1 {todouble [sin $x]} [expr {sin($double)}]
+ fassert tan $version.2 {todouble [tan $x]} [expr {tan($double)}]
+ fassert cotan $version.3 {todouble [cotan $x]} [expr {double(1.0)/tan($double)}]
+ }
+
+ set pi [pi 20]
+ set subversion 0
+ foreach i {1 2 3 6 7 8 9} {
+ tanCotan 4.5.$subversion $i
+ incr subversion
+ }
+
+
+ # cleanup
+ rename tanCotan ""
+
+
+ ################################################################################
+ # atan , asin & acos : trigonometry (inverse functions)
+ ################################################################################
+ proc atanTest {version x} {
+ set f [fromstr $x 20]
+ fassert atan $version.0 {todouble [atan $f]} [expr {atan($x)}]
+ if {abs($x)<=1.0} {
+ fassert acos $version.1 {todouble [acos $f]} [expr {acos($x)}]
+ fassert asin $version.2 {todouble [asin $f]} [expr {asin($x)}]
+ }
+ }
+ set subversion 0
+ atanTest 4.6.0.0 0.0
+ foreach i {1 2 3 4 5 6 7 8 9} {
+ atanTest 4.6.1.$subversion 0.$i
+ atanTest 4.6.2.$subversion $i.0
+ atanTest 4.6.3.$subversion -0.$i
+ atanTest 4.6.4.$subversion -$i.0
+ incr subversion
+ }
+
+ # cleanup
+ rename atanTest ""
+
+ ################################################################################
+ # cosh , sinh & tanh : hyperbolic functions
+ ################################################################################
+ proc hyper {version x} {
+ set f [fromstr $x 18]
+ fassert cosh $version.0 {todouble [cosh $f]} [expr {cosh($x)}]
+ fassert sinh $version.1 {todouble [sinh $f]} [expr {sinh($x)}]
+ fassert tanh $version.2 {todouble [tanh $f]} [expr {tanh($x)}]
+ }
+
+ hyper 4.7.0 0.0
+ set subversion 0
+ foreach i {1 2 3 4 5 6 7 8 9} {
+ hyper 4.7.1.$subversion 0.$i
+ hyper 4.7.2.$subversion $i.0
+ hyper 4.7.3.$subversion -0.$i
+ hyper 4.7.4.$subversion -$i.0
+ }
+
+ # cleanup
+ rename hyper ""
+
+ ################################################################################
+ # tostr with -nosci option
+ ################################################################################
+ set version 5.0
+ fassert tostr-nosci $version.0 {tostr -nosci [fromstr 23450.e+7]} 234500000000.
+ fassert tostr-nosci $version.1 {tostr -nosci [fromstr 23450.e-7]} 0.002345
+ fassert tostr-nosci $version.2 {tostr -nosci [fromstr 23450000]} 23450000.
+ fassert tostr-nosci $version.3 {tostr -nosci [fromstr 2345.0]} 2345.
+
+ ################################################################################
+ # tests for isInt - ticket 3309165
+ ################################################################################
+ assert isInt $version.0 {isInt 12345678901234} 1
+ assert isInt $version.1 {isInt 12345678901234.0} 0
+ assert isInt $version.1 {isInt not-a-number} 0
+}
+
+testSuite
+################################################################################
+# end of testsuite for bigfloat 2.0
+################################################################################
+# cleanup global procs
+rename assert ""
+rename fassert ""
+rename Zero ""
+
+testsuiteCleanup
+
+set ::tcl_precision $old_precision
+
+
diff --git a/tcllib/modules/math/bignum.man b/tcllib/modules/math/bignum.man
new file mode 100755
index 0000000..26d0867
--- /dev/null
+++ b/tcllib/modules/math/bignum.man
@@ -0,0 +1,228 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin math::bignum n 3.1]
+[keywords bignums]
+[keywords math]
+[keywords multiprecision]
+[keywords tcl]
+[copyright {2004 Salvatore Sanfilippo <antirez at invece dot org>}]
+[copyright {2004 Arjen Markus <arjenmarkus at users dot sourceforge dot net>}]
+[moddesc {Tcl Math Library}]
+[titledesc {Arbitrary precision integer numbers}]
+[category Mathematics]
+[require Tcl [opt 8.4]]
+[require math::bignum [opt 3.1]]
+
+[description]
+[para]
+The bignum package provides arbitrary precision integer math
+(also known as "big numbers") capabilities to the Tcl language.
+Big numbers are internally represented at Tcl lists: this
+package provides a set of procedures operating against
+the internal representation in order to:
+[list_begin itemized]
+[item]
+perform math operations
+
+[item]
+convert bignums from the internal representation to a string in
+the desired radix and vice versa.
+
+[list_end]
+But the two constants "0" and "1" are automatically converted to
+the internal representation, in order to easily compare a number to zero,
+or increment a big number.
+[para]
+
+The bignum interface is opaque, so
+operations on bignums that are not returned by procedures
+in this package (but created by hand) may lead to unspecified behaviours.
+It's safe to treat bignums as pure values, so there is no need
+to free a bignum, or to duplicate it via a special operation.
+
+[section "EXAMPLES"]
+This section shows some simple example. This library being just
+a way to perform math operations, examples may be the simplest way
+to learn how to work with it. Consult the API section of
+this man page for information about individual procedures.
+
+[para]
+[example_begin]
+ package require math::bignum
+
+ # Multiplication of two bignums
+ set a [lb]::math::bignum::fromstr 88888881111111[rb]
+ set b [lb]::math::bignum::fromstr 22222220000000[rb]
+ set c [lb]::math::bignum::mul $a $b[rb]
+ puts [lb]::math::bignum::tostr $c[rb] ; # => will output 1975308271604953086420000000
+ set c [lb]::math::bignum::sqrt $c[rb]
+ puts [lb]::math::bignum::tostr $c[rb] ; # => will output 44444440277777
+
+ # From/To string conversion in different radix
+ set a [lb]::math::bignum::fromstr 1100010101010111001001111010111 2[rb]
+ puts [lb]::math::bignum::tostr $a 16[rb] ; # => will output 62ab93d7
+
+ # Factorial example
+ proc fact n {
+ # fromstr is not needed for 0 and 1
+ set z 1
+ for {set i 2} {$i <= $n} {incr i} {
+ set z [lb]::math::bignum::mul $z [lb]::math::bignum::fromstr $i[rb][rb]
+ }
+ return $z
+ }
+
+ puts [lb]::math::bignum::tostr [lb]fact 100[rb][rb]
+[example_end]
+
+[section "API"]
+[list_begin definitions]
+
+[call [cmd ::math::bignum::fromstr] [arg string] ?[arg radix]?]
+Convert [emph string] into a bignum. If [emph radix] is omitted or zero,
+the string is interpreted in hex if prefixed with
+[emph 0x], in octal if prefixed with [emph ox],
+in binary if it's pefixed with [emph bx], as a number in
+radix 10 otherwise. If instead the [emph radix] argument
+is specified in the range 2-36, the [emph string] is interpreted
+in the given radix. Please note that this conversion is
+not needed for two constants : [emph 0] and [emph 1]. (see the example)
+
+[call [cmd ::math::bignum::tostr] [arg bignum] ?[arg radix]?]
+Convert [emph bignum] into a string representing the number
+in the specified radix. If [emph radix] is omitted, the
+default is 10.
+
+[call [cmd ::math::bignum::sign] [arg bignum]]
+Return the sign of the bignum.
+The procedure returns 0 if the number is positive, 1 if it's negative.
+
+[call [cmd ::math::bignum::abs] [arg bignum]]
+Return the absolute value of the bignum.
+
+[call [cmd ::math::bignum::cmp] [arg a] [arg b]]
+Compare the two bignums a and b, returning [emph 0] if [emph {a == b}],
+[emph 1] if [emph {a > b}], and [emph -1] if [emph {a < b}].
+
+[call [cmd ::math::bignum::iszero] [arg bignum]]
+Return true if [emph bignum] value is zero, otherwise false is returned.
+
+[call [cmd ::math::bignum::lt] [arg a] [arg b]]
+Return true if [emph {a < b}], otherwise false is returned.
+
+[call [cmd ::math::bignum::le] [arg a] [arg b]]
+Return true if [emph {a <= b}], otherwise false is returned.
+
+[call [cmd ::math::bignum::gt] [arg a] [arg b]]
+Return true if [emph {a > b}], otherwise false is returned.
+
+[call [cmd ::math::bignum::ge] [arg a] [arg b]]
+Return true if [emph {a >= b}], otherwise false is returned.
+
+[call [cmd ::math::bignum::eq] [arg a] [arg b]]
+Return true if [emph {a == b}], otherwise false is returned.
+
+[call [cmd ::math::bignum::ne] [arg a] [arg b]]
+Return true if [emph {a != b}], otherwise false is returned.
+
+[call [cmd ::math::bignum::isodd] [arg bignum]]
+Return true if [emph bignum] is odd.
+
+[call [cmd ::math::bignum::iseven] [arg bignum]]
+Return true if [emph bignum] is even.
+
+[call [cmd ::math::bignum::add] [arg a] [arg b]]
+Return the sum of the two bignums [emph a] and [emph b].
+
+[call [cmd ::math::bignum::sub] [arg a] [arg b]]
+Return the difference of the two bignums [emph a] and [emph b].
+
+[call [cmd ::math::bignum::mul] [arg a] [arg b]]
+Return the product of the two bignums [emph a] and [emph b].
+The implementation uses Karatsuba multiplication if both
+the numbers are bigger than a given threshold, otherwise
+the direct algorith is used.
+
+[call [cmd ::math::bignum::divqr] [arg a] [arg b]]
+Return a two-elements list containing as first element
+the quotient of the division between the two bignums
+[emph a] and [emph b], and the remainder of the division as second element.
+
+[call [cmd ::math::bignum::div] [arg a] [arg b]]
+Return the quotient of the division between the two
+bignums [emph a] and [emph b].
+
+[call [cmd ::math::bignum::rem] [arg a] [arg b]]
+Return the remainder of the division between the two
+bignums [emph a] and [emph b].
+
+[call [cmd ::math::bignum::mod] [arg n] [arg m]]
+Return [emph n] modulo [emph m]. This operation is
+called modular reduction.
+
+[call [cmd ::math::bignum::pow] [arg base] [arg exp]]
+Return [emph base] raised to the exponent [emph exp].
+
+[call [cmd ::math::bignum::powm] [arg base] [arg exp] [arg m]]
+Return [emph base] raised to the exponent [emph exp],
+modulo [emph m]. This function is often used in the field
+of cryptography.
+
+[call [cmd ::math::bignum::sqrt] [arg bignum]]
+Return the integer part of the square root of [emph bignum]
+
+[call [cmd ::math::bignum::rand] [arg bits]]
+Return a random number of at most [emph bits] bits.
+The returned number is internally generated using Tcl's [emph {expr rand()}]
+function and is not suitable where an unguessable and cryptographically
+secure random number is needed.
+
+[call [cmd ::math::bignum::lshift] [arg bignum] [arg bits]]
+Return the result of left shifting [emph bignum]'s binary
+representation of [emph bits] positions on the left.
+This is equivalent to multiplying by 2^[emph bits] but much faster.
+
+[call [cmd ::math::bignum::rshift] [arg bignum] [arg bits]]
+Return the result of right shifting [emph bignum]'s binary
+representation of [emph bits] positions on the right.
+This is equivalent to dividing by [emph 2^bits] but much faster.
+
+[call [cmd ::math::bignum::bitand] [arg a] [arg b]]
+Return the result of doing a bitwise AND operation on a
+and b. The operation is restricted to positive numbers,
+including zero. When negative numbers are provided as
+arguments the result is undefined.
+
+[call [cmd ::math::bignum::bitor] [arg a] [arg b]]
+Return the result of doing a bitwise OR operation on a
+and b. The operation is restricted to positive numbers,
+including zero. When negative numbers are provided as
+arguments the result is undefined.
+
+[call [cmd ::math::bignum::bitxor] [arg a] [arg b]]
+Return the result of doing a bitwise XOR operation on a
+and b. The operation is restricted to positive numbers,
+including zero. When negative numbers are provided as
+arguments the result is undefined.
+
+[call [cmd ::math::bignum::setbit] [arg bignumVar] [arg bit]]
+Set the bit at [emph bit] position to 1 in the bignum stored
+in the variable [emph bignumVar]. Bit 0 is the least significant.
+
+[call [cmd ::math::bignum::clearbit] [arg bignumVar] [arg bit]]
+Set the bit at [emph bit] position to 0 in the bignum stored
+in the variable [emph bignumVar]. Bit 0 is the least significant.
+
+[call [cmd ::math::bignum::testbit] [arg bignum] [arg bit]]
+Return true if the bit at the [emph bit] position of [emph bignum]
+is on, otherwise false is returned. If [emph bit] is out of
+range, it is considered as set to zero.
+
+[call [cmd ::math::bignum::bits] [arg bignum]]
+Return the number of bits needed to represent bignum in radix 2.
+
+[list_end]
+[para]
+
+[vset CATEGORY {math :: bignum}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/bignum.tcl b/tcllib/modules/math/bignum.tcl
new file mode 100755
index 0000000..38e1fbb
--- /dev/null
+++ b/tcllib/modules/math/bignum.tcl
@@ -0,0 +1,900 @@
+# bignum library in pure Tcl [VERSION 7Sep2004]
+# Copyright (C) 2004 Salvatore Sanfilippo <antirez at invece dot org>
+# Copyright (C) 2004 Arjen Markus <arjen dot markus at wldelft dot nl>
+#
+# LICENSE
+#
+# This software is:
+# Copyright (C) 2004 Salvatore Sanfilippo <antirez at invece dot org>
+# Copyright (C) 2004 Arjen Markus <arjen dot markus at wldelft dot nl>
+# The following terms apply to all files associated with the software
+# unless explicitly disclaimed in individual files.
+#
+# The authors hereby grant permission to use, copy, modify, distribute,
+# and license this software and its documentation for any purpose, provided
+# that existing copyright notices are retained in all copies and that this
+# notice is included verbatim in any distributions. No written agreement,
+# license, or royalty fee is required for any of the authorized uses.
+# Modifications to this software may be copyrighted by their authors
+# and need not follow the licensing terms described here, provided that
+# the new terms are clearly indicated on the first page of each file where
+# they apply.
+#
+# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+#
+# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+# MODIFICATIONS.
+#
+# GOVERNMENT USE: If you are acquiring this software on behalf of the
+# U.S. government, the Government shall have only "Restricted Rights"
+# in the software and related documentation as defined in the Federal
+# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
+# are acquiring the software on behalf of the Department of Defense, the
+# software shall be classified as "Commercial Computer Software" and the
+# Government shall have only "Restricted Rights" as defined in Clause
+# 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
+# authors grant the U.S. Government and others acting in its behalf
+# permission to use and distribute the software in accordance with the
+# terms specified in this license.
+
+# TODO
+# - pow and powm should check if the exponent is zero in order to return one
+
+package require Tcl 8.4
+
+namespace eval ::math::bignum {}
+
+#################################### Misc ######################################
+
+# Don't change atombits define if you don't know what you are doing.
+# Note that it must be a power of two, and that 16 is too big
+# because expr may overflow in the product of two 16 bit numbers.
+set ::math::bignum::atombits 16
+set ::math::bignum::atombase [expr {1 << $::math::bignum::atombits}]
+set ::math::bignum::atommask [expr {$::math::bignum::atombase-1}]
+
+# Note: to change 'atombits' is all you need to change the
+# library internal representation base.
+
+# Return the max between a and b (not bignums)
+proc ::math::bignum::max {a b} {
+ expr {($a > $b) ? $a : $b}
+}
+
+# Return the min between a and b (not bignums)
+proc ::math::bignum::min {a b} {
+ expr {($a < $b) ? $a : $b}
+}
+
+############################ Basic bignum operations ###########################
+
+# Returns a new bignum initialized to the value of 0.
+#
+# The big numbers are represented as a Tcl lists
+# The all-is-a-string representation does not pay here
+# bignums in Tcl are already slow, we can't slow-down it more.
+#
+# The bignum representation is [list bignum <sign> <atom0> ... <atomN>]
+# Where the atom0 is the least significant. Atoms are the digits
+# of a number in base 2^$::math::bignum::atombits
+#
+# The sign is 0 if the number is positive, 1 for negative numbers.
+
+# Note that the function accepts an argument used in order to
+# create a bignum of <atoms> atoms. For default zero is
+# represented as a single zero atom.
+#
+# The function is designed so that "set b [zero [atoms $a]]" will
+# produce 'b' with the same number of atoms as 'a'.
+proc ::math::bignum::zero {{value 0}} {
+ set v [list bignum 0 0]
+ while { $value > 1 } {
+ lappend v 0
+ incr value -1
+ }
+ return $v
+}
+
+# Get the bignum sign
+proc ::math::bignum::sign bignum {
+ lindex $bignum 1
+}
+
+# Get the number of atoms in the bignum
+proc ::math::bignum::atoms bignum {
+ expr {[llength $bignum]-2}
+}
+
+# Get the i-th atom out of a bignum.
+# If the bignum is shorter than i atoms, the function
+# returns 0.
+proc ::math::bignum::atom {bignum i} {
+ if {[::math::bignum::atoms $bignum] < [expr {$i+1}]} {
+ return 0
+ } else {
+ lindex $bignum [expr {$i+2}]
+ }
+}
+
+# Set the i-th atom out of a bignum. If the bignum
+# has less than 'i+1' atoms, add zero atoms to reach i.
+proc ::math::bignum::setatom {bignumvar i atomval} {
+ upvar 1 $bignumvar bignum
+ while {[::math::bignum::atoms $bignum] < [expr {$i+1}]} {
+ lappend bignum 0
+ }
+ lset bignum [expr {$i+2}] $atomval
+}
+
+# Set the bignum sign
+proc ::math::bignum::setsign {bignumvar sign} {
+ upvar 1 $bignumvar bignum
+ lset bignum 1 $sign
+}
+
+# Remove trailing atoms with a value of zero
+# The normalized bignum is returned
+proc ::math::bignum::normalize bignumvar {
+ upvar 1 $bignumvar bignum
+ set atoms [expr {[llength $bignum]-2}]
+ set i [expr {$atoms+1}]
+ while {$atoms && [lindex $bignum $i] == 0} {
+ set bignum [lrange $bignum 0 end-1]
+ incr atoms -1
+ incr i -1
+ }
+ if {!$atoms} {
+ set bignum [list bignum 0 0]
+ }
+ return $bignum
+}
+
+# Return the absolute value of N
+proc ::math::bignum::abs n {
+ ::math::bignum::setsign n 0
+ return $n
+}
+
+################################# Comparison ###################################
+
+# Compare by absolute value. Called by ::math::bignum::cmp after the sign check.
+#
+# Returns 1 if |a| > |b|
+# 0 if a == b
+# -1 if |a| < |b|
+#
+proc ::math::bignum::abscmp {a b} {
+ if {[llength $a] > [llength $b]} {
+ return 1
+ } elseif {[llength $a] < [llength $b]} {
+ return -1
+ }
+ set j [expr {[llength $a]-1}]
+ while {$j >= 2} {
+ if {[lindex $a $j] > [lindex $b $j]} {
+ return 1
+ } elseif {[lindex $a $j] < [lindex $b $j]} {
+ return -1
+ }
+ incr j -1
+ }
+ return 0
+}
+
+# High level comparison. Return values:
+#
+# 1 if a > b
+# -1 if a < b
+# 0 if a == b
+#
+proc ::math::bignum::cmp {a b} { ; # same sign case
+ set a [_treat $a]
+ set b [_treat $b]
+ if {[::math::bignum::sign $a] == [::math::bignum::sign $b]} {
+ if {[::math::bignum::sign $a] == 0} {
+ ::math::bignum::abscmp $a $b
+ } else {
+ expr {-([::math::bignum::abscmp $a $b])}
+ }
+ } else { ; # different sign case
+ if {[::math::bignum::sign $a]} {return -1}
+ return 1
+ }
+}
+
+# Return true if 'z' is zero.
+proc ::math::bignum::iszero z {
+ set z [_treat $z]
+ expr {[llength $z] == 3 && [lindex $z 2] == 0}
+}
+
+# Comparison facilities
+proc ::math::bignum::lt {a b} {expr {[::math::bignum::cmp $a $b] < 0}}
+proc ::math::bignum::le {a b} {expr {[::math::bignum::cmp $a $b] <= 0}}
+proc ::math::bignum::gt {a b} {expr {[::math::bignum::cmp $a $b] > 0}}
+proc ::math::bignum::ge {a b} {expr {[::math::bignum::cmp $a $b] >= 0}}
+proc ::math::bignum::eq {a b} {expr {[::math::bignum::cmp $a $b] == 0}}
+proc ::math::bignum::ne {a b} {expr {[::math::bignum::cmp $a $b] != 0}}
+
+########################### Addition / Subtraction #############################
+
+# Add two bignums, don't care about the sign.
+proc ::math::bignum::rawAdd {a b} {
+ while {[llength $a] < [llength $b]} {lappend a 0}
+ while {[llength $b] < [llength $a]} {lappend b 0}
+ set r [::math::bignum::zero [expr {[llength $a]-1}]]
+ set car 0
+ for {set i 2} {$i < [llength $a]} {incr i} {
+ set sum [expr {[lindex $a $i]+[lindex $b $i]+$car}]
+ set car [expr {$sum >> $::math::bignum::atombits}]
+ set sum [expr {$sum & $::math::bignum::atommask}]
+ lset r $i $sum
+ }
+ if {$car} {
+ lset r $i $car
+ }
+ ::math::bignum::normalize r
+}
+
+# Subtract two bignums, don't care about the sign. a > b condition needed.
+proc ::math::bignum::rawSub {a b} {
+ set atoms [::math::bignum::atoms $a]
+ set r [::math::bignum::zero $atoms]
+ while {[llength $b] < [llength $a]} {lappend b 0} ; # b padding
+ set car 0
+ incr atoms 2
+ for {set i 2} {$i < $atoms} {incr i} {
+ set sub [expr {[lindex $a $i]-[lindex $b $i]-$car}]
+ set car 0
+ if {$sub < 0} {
+ incr sub $::math::bignum::atombase
+ set car 1
+ }
+ lset r $i $sub
+ }
+ # Note that if a > b there is no car in the last for iteration
+ ::math::bignum::normalize r
+}
+
+# Higher level addition, care about sign and call rawAdd or rawSub
+# as needed.
+proc ::math::bignum::add {a b} {
+ set a [_treat $a]
+ set b [_treat $b]
+ # Same sign case
+ if {[::math::bignum::sign $a] == [::math::bignum::sign $b]} {
+ set r [::math::bignum::rawAdd $a $b]
+ ::math::bignum::setsign r [::math::bignum::sign $a]
+ } else {
+ # Different sign case
+ set cmp [::math::bignum::abscmp $a $b]
+ # 's' is the sign, set accordingly to A or B negative
+ set s [expr {[::math::bignum::sign $a] == 1}]
+ switch -- $cmp {
+ 0 {return [::math::bignum::zero]}
+ 1 {
+ set r [::math::bignum::rawSub $a $b]
+ ::math::bignum::setsign r $s
+ return $r
+ }
+ -1 {
+ set r [::math::bignum::rawSub $b $a]
+ ::math::bignum::setsign r [expr {!$s}]
+ return $r
+ }
+ }
+ }
+ return $r
+}
+
+# Higher level subtraction, care about sign and call rawAdd or rawSub
+# as needed.
+proc ::math::bignum::sub {a b} {
+ set a [_treat $a]
+ set b [_treat $b]
+ # Different sign case
+ if {[::math::bignum::sign $a] != [::math::bignum::sign $b]} {
+ set r [::math::bignum::rawAdd $a $b]
+ ::math::bignum::setsign r [::math::bignum::sign $a]
+ } else {
+ # Same sign case
+ set cmp [::math::bignum::abscmp $a $b]
+ # 's' is the sign, set accordingly to A and B both negative or positive
+ set s [expr {[::math::bignum::sign $a] == 1}]
+ switch -- $cmp {
+ 0 {return [::math::bignum::zero]}
+ 1 {
+ set r [::math::bignum::rawSub $a $b]
+ ::math::bignum::setsign r $s
+ return $r
+ }
+ -1 {
+ set r [::math::bignum::rawSub $b $a]
+ ::math::bignum::setsign r [expr {!$s}]
+ return $r
+ }
+ }
+ }
+ return $r
+}
+
+############################### Multiplication #################################
+
+set ::math::bignum::karatsubaThreshold 32
+
+# Multiplication. Calls Karatsuba that calls Base multiplication under
+# a given threshold.
+proc ::math::bignum::mul {a b} {
+ set a [_treat $a]
+ set b [_treat $b]
+ set r [::math::bignum::kmul $a $b]
+ # The sign is the xor between the two signs
+ ::math::bignum::setsign r [expr {[::math::bignum::sign $a]^[::math::bignum::sign $b]}]
+}
+
+# Karatsuba Multiplication
+proc ::math::bignum::kmul {a b} {
+ set n [expr {[::math::bignum::max [llength $a] [llength $b]]-2}]
+ set nmin [expr {[::math::bignum::min [llength $a] [llength $b]]-2}]
+ if {$nmin < $::math::bignum::karatsubaThreshold} {return [::math::bignum::bmul $a $b]}
+ set m [expr {($n+($n&1))/2}]
+
+ set x0 [concat [list bignum 0] [lrange $a 2 [expr {$m+1}]]]
+ set y0 [concat [list bignum 0] [lrange $b 2 [expr {$m+1}]]]
+ set x1 [concat [list bignum 0] [lrange $a [expr {$m+2}] end]]
+ set y1 [concat [list bignum 0] [lrange $b [expr {$m+2}] end]]
+
+ if {0} {
+ puts "m: $m"
+ puts "x0: $x0"
+ puts "x1: $x1"
+ puts "y0: $y0"
+ puts "y1: $y1"
+ }
+
+ set p1 [::math::bignum::kmul $x1 $y1]
+ set p2 [::math::bignum::kmul $x0 $y0]
+ set p3 [::math::bignum::kmul [::math::bignum::add $x1 $x0] [::math::bignum::add $y1 $y0]]
+
+ set p3 [::math::bignum::sub $p3 $p1]
+ set p3 [::math::bignum::sub $p3 $p2]
+ set p1 [::math::bignum::lshiftAtoms $p1 [expr {$m*2}]]
+ set p3 [::math::bignum::lshiftAtoms $p3 $m]
+ set p3 [::math::bignum::add $p3 $p1]
+ set p3 [::math::bignum::add $p3 $p2]
+ return $p3
+}
+
+# Base Multiplication.
+proc ::math::bignum::bmul {a b} {
+ set r [::math::bignum::zero [expr {[llength $a]+[llength $b]-3}]]
+ for {set j 2} {$j < [llength $b]} {incr j} {
+ set car 0
+ set t [list bignum 0 0]
+ for {set i 2} {$i < [llength $a]} {incr i} {
+ # note that A = B * C + D + E
+ # with A of N*2 bits and C,D,E of N bits
+ # can't overflow since:
+ # (2^N-1)*(2^N-1)+(2^N-1)+(2^N-1) == 2^(2*N)-1
+ set t0 [lindex $a $i]
+ set t1 [lindex $b $j]
+ set t2 [lindex $r [expr {$i+$j-2}]]
+ set mul [expr {wide($t0)*$t1+$t2+$car}]
+ set car [expr {$mul >> $::math::bignum::atombits}]
+ set mul [expr {$mul & $::math::bignum::atommask}]
+ lset r [expr {$i+$j-2}] $mul
+ }
+ if {$car} {
+ lset r [expr {$i+$j-2}] $car
+ }
+ }
+ ::math::bignum::normalize r
+}
+
+################################## Shifting ####################################
+
+# Left shift 'z' of 'n' atoms. Low-level function used by ::math::bignum::lshift
+# Exploit the internal representation to go faster.
+proc ::math::bignum::lshiftAtoms {z n} {
+ while {$n} {
+ set z [linsert $z 2 0]
+ incr n -1
+ }
+ return $z
+}
+
+# Right shift 'z' of 'n' atoms. Low-level function used by ::math::bignum::lshift
+# Exploit the internal representation to go faster.
+proc ::math::bignum::rshiftAtoms {z n} {
+ set z [lreplace $z 2 [expr {$n+1}]]
+}
+
+# Left shift 'z' of 'n' bits. Low-level function used by ::math::bignum::lshift.
+# 'n' must be <= $::math::bignum::atombits
+proc ::math::bignum::lshiftBits {z n} {
+ set atoms [llength $z]
+ set car 0
+ for {set j 2} {$j < $atoms} {incr j} {
+ set t [lindex $z $j]
+ lset z $j \
+ [expr {wide($car)|((wide($t)<<$n)&$::math::bignum::atommask)}]
+ set car [expr {wide($t)>>($::math::bignum::atombits-$n)}]
+ }
+ if {$car} {
+ lappend z 0
+ lset z $j $car
+ }
+ return $z ; # No normalization needed
+}
+
+# Right shift 'z' of 'n' bits. Low-level function used by ::math::bignum::rshift.
+# 'n' must be <= $::math::bignum::atombits
+proc ::math::bignum::rshiftBits {z n} {
+ set atoms [llength $z]
+ set car 0
+ for {set j [expr {$atoms-1}]} {$j >= 2} {incr j -1} {
+ set t [lindex $z $j]
+ lset z $j [expr {wide($car)|(wide($t)>>$n)}]
+ set car \
+ [expr {(wide($t)<<($::math::bignum::atombits-$n))&$::math::bignum::atommask}]
+ }
+ ::math::bignum::normalize z
+}
+
+# Left shift 'z' of 'n' bits.
+proc ::math::bignum::lshift {z n} {
+ set z [_treat $z]
+ set atoms [expr {$n / $::math::bignum::atombits}]
+ set bits [expr {$n & ($::math::bignum::atombits-1)}]
+ ::math::bignum::lshiftBits [math::bignum::lshiftAtoms $z $atoms] $bits
+}
+
+# Right shift 'z' of 'n' bits.
+proc ::math::bignum::rshift {z n} {
+ set z [_treat $z]
+ set atoms [expr {$n / $::math::bignum::atombits}]
+ set bits [expr {$n & ($::math::bignum::atombits-1)}]
+
+ #
+ # Correct for "arithmetic shift" - signed integers
+ #
+ set corr 0
+ if { [::math::bignum::sign $z] == 1 } {
+ for {set j [expr {$atoms+1}]} {$j >= 2} {incr j -1} {
+ set t [lindex $z $j]
+ if { $t != 0 } {
+ set corr 1
+ }
+ }
+ if { $corr == 0 } {
+ set t [lindex $z [expr {$atoms+2}]]
+ if { ( $t & ~($::math::bignum::atommask<<($bits)) ) != 0 } {
+ set corr 1
+ }
+ }
+ }
+
+ set newz [::math::bignum::rshiftBits [math::bignum::rshiftAtoms $z $atoms] $bits]
+ if { $corr } {
+ set newz [::math::bignum::sub $newz 1]
+ }
+ return $newz
+}
+
+############################## Bit oriented ops ################################
+
+# Set the bit 'n' of 'bignumvar'
+proc ::math::bignum::setbit {bignumvar n} {
+ upvar 1 $bignumvar z
+ set atom [expr {$n / $::math::bignum::atombits}]
+ set bit [expr {1 << ($n & ($::math::bignum::atombits-1))}]
+ incr atom 2
+ while {$atom >= [llength $z]} {lappend z 0}
+ lset z $atom [expr {[lindex $z $atom]|$bit}]
+}
+
+# Clear the bit 'n' of 'bignumvar'
+proc ::math::bignum::clearbit {bignumvar n} {
+ upvar 1 $bignumvar z
+ set atom [expr {$n / $::math::bignum::atombits}]
+ incr atom 2
+ if {$atom >= [llength $z]} {return $z}
+ set mask [expr {$::math::bignum::atommask^(1 << ($n & ($::math::bignum::atombits-1)))}]
+ lset z $atom [expr {[lindex $z $atom]&$mask}]
+ ::math::bignum::normalize z
+}
+
+# Test the bit 'n' of 'z'. Returns true if the bit is set.
+proc ::math::bignum::testbit {z n} {
+ set atom [expr {$n / $::math::bignum::atombits}]
+ incr atom 2
+ if {$atom >= [llength $z]} {return 0}
+ set mask [expr {1 << ($n & ($::math::bignum::atombits-1))}]
+ expr {([lindex $z $atom] & $mask) != 0}
+}
+
+# does bitwise and between a and b
+proc ::math::bignum::bitand {a b} {
+ # The internal number rep is little endian. Appending zeros is
+ # equivalent to adding leading zeros to a regular big-endian
+ # representation. The two numbers are extended to the same length,
+ # then the operation is applied to the absolute value.
+ set a [_treat $a]
+ set b [_treat $b]
+ while {[llength $a] < [llength $b]} {lappend a 0}
+ while {[llength $b] < [llength $a]} {lappend b 0}
+ set r [::math::bignum::zero [expr {[llength $a]-1}]]
+ for {set i 2} {$i < [llength $a]} {incr i} {
+ set or [expr {[lindex $a $i] & [lindex $b $i]}]
+ lset r $i $or
+ }
+ ::math::bignum::normalize r
+}
+
+# does bitwise XOR between a and b
+proc ::math::bignum::bitxor {a b} {
+ # The internal number rep is little endian. Appending zeros is
+ # equivalent to adding leading zeros to a regular big-endian
+ # representation. The two numbers are extended to the same length,
+ # then the operation is applied to the absolute value.
+ set a [_treat $a]
+ set b [_treat $b]
+ while {[llength $a] < [llength $b]} {lappend a 0}
+ while {[llength $b] < [llength $a]} {lappend b 0}
+ set r [::math::bignum::zero [expr {[llength $a]-1}]]
+ for {set i 2} {$i < [llength $a]} {incr i} {
+ set or [expr {[lindex $a $i] ^ [lindex $b $i]}]
+ lset r $i $or
+ }
+ ::math::bignum::normalize r
+}
+
+# does bitwise or between a and b
+proc ::math::bignum::bitor {a b} {
+ # The internal number rep is little endian. Appending zeros is
+ # equivalent to adding leading zeros to a regular big-endian
+ # representation. The two numbers are extended to the same length,
+ # then the operation is applied to the absolute value.
+ set a [_treat $a]
+ set b [_treat $b]
+ while {[llength $a] < [llength $b]} {lappend a 0}
+ while {[llength $b] < [llength $a]} {lappend b 0}
+ set r [::math::bignum::zero [expr {[llength $a]-1}]]
+ for {set i 2} {$i < [llength $a]} {incr i} {
+ set or [expr {[lindex $a $i] | [lindex $b $i]}]
+ lset r $i $or
+ }
+ ::math::bignum::normalize r
+}
+
+# Return the number of bits needed to represent 'z'.
+proc ::math::bignum::bits z {
+ set atoms [::math::bignum::atoms $z]
+ set bits [expr {($atoms-1)*$::math::bignum::atombits}]
+ set atom [lindex $z [expr {$atoms+1}]]
+ while {$atom} {
+ incr bits
+ set atom [expr {$atom >> 1}]
+ }
+ return $bits
+}
+
+################################## Division ####################################
+
+# Division. Returns [list n/d n%d]
+#
+# I got this algorithm from PGP 2.6.3i (see the mp_udiv function).
+# Here is how it works:
+#
+# Input: N=(Nn,...,N2,N1,N0)radix2
+# D=(Dn,...,D2,D1,D0)radix2
+# Output: Q=(Qn,...,Q2,Q1,Q0)radix2 = N/D
+# R=(Rn,...,R2,R1,R0)radix2 = N%D
+#
+# Assume: N >= 0, D > 0
+#
+# For j from 0 to n
+# Qj <- 0
+# Rj <- 0
+# For j from n down to 0
+# R <- R*2
+# if Nj = 1 then R0 <- 1
+# if R => D then R <- (R - D), Qn <- 1
+#
+# Note that the doubling of R is usually done leftshifting one position.
+# The only operations needed are bit testing, bit setting and subtraction.
+#
+# This is the "raw" version, don't care about the sign, returns both
+# quotient and rest as a two element list.
+# This procedure is used by divqr, div, mod, rem.
+proc ::math::bignum::rawDiv {n d} {
+ set bit [expr {[::math::bignum::bits $n]-1}]
+ set r [list bignum 0 0]
+ set q [::math::bignum::zero [expr {[llength $n]-2}]]
+ while {$bit >= 0} {
+ set b_atom [expr {($bit / $::math::bignum::atombits) + 2}]
+ set b_bit [expr {1 << ($bit & ($::math::bignum::atombits-1))}]
+ set r [::math::bignum::lshiftBits $r 1]
+ if {[lindex $n $b_atom]&$b_bit} {
+ lset r 2 [expr {[lindex $r 2] | 1}]
+ }
+ if {[::math::bignum::abscmp $r $d] >= 0} {
+ set r [::math::bignum::rawSub $r $d]
+ lset q $b_atom [expr {[lindex $q $b_atom]|$b_bit}]
+ }
+ incr bit -1
+ }
+ ::math::bignum::normalize q
+ list $q $r
+}
+
+# Divide by single-atom immediate. Used to speedup bignum -> string conversion.
+# The procedure returns a two-elements list with the bignum quotient and
+# the remainder (that's just a number being <= of the max atom value).
+proc ::math::bignum::rawDivByAtom {n d} {
+ set atoms [::math::bignum::atoms $n]
+ set t 0
+ set j $atoms
+ incr j -1
+ for {} {$j >= 0} {incr j -1} {
+ set t [expr {($t << $::math::bignum::atombits)+[lindex $n [expr {$j+2}]]}]
+ lset n [expr {$j+2}] [expr {$t/$d}]
+ set t [expr {$t % $d}]
+ }
+ ::math::bignum::normalize n
+ list $n $t
+}
+
+# Higher level division. Returns a list with two bignums, the first
+# is the quotient of n/d, the second the remainder n%d.
+# Note that if you want the *modulo* operator you should use ::math::bignum::mod
+#
+# The remainder sign is always the same as the divident.
+proc ::math::bignum::divqr {n d} {
+ set n [_treat $n]
+ set d [_treat $d]
+ if {[::math::bignum::iszero $d]} {
+ error "Division by zero"
+ }
+ foreach {q r} [::math::bignum::rawDiv $n $d] break
+ ::math::bignum::setsign q [expr {[::math::bignum::sign $n]^[::math::bignum::sign $d]}]
+ ::math::bignum::setsign r [::math::bignum::sign $n]
+ list $q $r
+}
+
+# Like divqr, but only the quotient is returned.
+proc ::math::bignum::div {n d} {
+ lindex [::math::bignum::divqr $n $d] 0
+}
+
+# Like divqr, but only the remainder is returned.
+proc ::math::bignum::rem {n d} {
+ lindex [::math::bignum::divqr $n $d] 1
+}
+
+# Modular reduction. Returns N modulo M
+proc ::math::bignum::mod {n m} {
+ set n [_treat $n]
+ set m [_treat $m]
+ set r [lindex [::math::bignum::divqr $n $m] 1]
+ if {[::math::bignum::sign $m] != [::math::bignum::sign $r]} {
+ set r [::math::bignum::add $r $m]
+ }
+ return $r
+}
+
+# Returns true if n is odd
+proc ::math::bignum::isodd n {
+ expr {[lindex $n 2]&1}
+}
+
+# Returns true if n is even
+proc ::math::bignum::iseven n {
+ expr {!([lindex $n 2]&1)}
+}
+
+############################# Power and Power mod N ############################
+
+# Returns b^e
+proc ::math::bignum::pow {b e} {
+ set b [_treat $b]
+ set e [_treat $e]
+ if {[::math::bignum::iszero $e]} {return [list bignum 0 1]}
+ # The power is negative is the base is negative and the exponent is odd
+ set sign [expr {[::math::bignum::sign $b] && [::math::bignum::isodd $e]}]
+ # Set the base to it's abs value, i.e. make it positive
+ ::math::bignum::setsign b 0
+ # Main loop
+ set r [list bignum 0 1]; # Start with result = 1
+ while {[::math::bignum::abscmp $e [list bignum 0 1]] > 0} { ;# While the exp > 1
+ if {[::math::bignum::isodd $e]} {
+ set r [::math::bignum::mul $r $b]
+ }
+ set e [::math::bignum::rshiftBits $e 1] ;# exp = exp / 2
+ set b [::math::bignum::mul $b $b]
+ }
+ set r [::math::bignum::mul $r $b]
+ ::math::bignum::setsign r $sign
+ return $r
+}
+
+# Returns b^e mod m
+proc ::math::bignum::powm {b e m} {
+ set b [_treat $b]
+ set e [_treat $e]
+ set m [_treat $m]
+ if {[::math::bignum::iszero $e]} {return [list bignum 0 1]}
+ # The power is negative is the base is negative and the exponent is odd
+ set sign [expr {[::math::bignum::sign $b] && [::math::bignum::isodd $e]}]
+ # Set the base to it's abs value, i.e. make it positive
+ ::math::bignum::setsign b 0
+ # Main loop
+ set r [list bignum 0 1]; # Start with result = 1
+ while {[::math::bignum::abscmp $e [list bignum 0 1]] > 0} { ;# While the exp > 1
+ if {[::math::bignum::isodd $e]} {
+ set r [::math::bignum::mod [::math::bignum::mul $r $b] $m]
+ }
+ set e [::math::bignum::rshiftBits $e 1] ;# exp = exp / 2
+ set b [::math::bignum::mod [::math::bignum::mul $b $b] $m]
+ }
+ set r [::math::bignum::mul $r $b]
+ ::math::bignum::setsign r $sign
+ set r [::math::bignum::mod $r $m]
+ return $r
+}
+
+################################## Square Root #################################
+
+# SQRT using the 'binary sqrt algorithm'.
+#
+# The basic algoritm consists in starting from the higer-bit
+# the real square root may have set, down to the bit zero,
+# trying to set every bit and checking if guess*guess is not
+# greater than 'n'. If it is greater we don't set the bit, otherwise
+# we set it. In order to avoid to compute guess*guess a trick
+# is used, so only addition and shifting are really required.
+proc ::math::bignum::sqrt n {
+ if {[lindex $n 1]} {
+ error "Square root of a negative number"
+ }
+ set i [expr {(([::math::bignum::bits $n]-1)/2)+1}]
+ set b [expr {$i*2}] ; # Bit to set to get 2^i*2^i
+
+ set r [::math::bignum::zero] ; # guess
+ set x [::math::bignum::zero] ; # guess^2
+ set s [::math::bignum::zero] ; # guess^2 backup
+ set t [::math::bignum::zero] ; # intermediate result
+ for {} {$i >= 0} {incr i -1; incr b -2} {
+ ::math::bignum::setbit t $b
+ set x [::math::bignum::rawAdd $s $t]
+ ::math::bignum::clearbit t $b
+ if {[::math::bignum::abscmp $x $n] <= 0} {
+ set s $x
+ ::math::bignum::setbit r $i
+ ::math::bignum::setbit t [expr {$b+1}]
+ }
+ set t [::math::bignum::rshiftBits $t 1]
+ }
+ return $r
+}
+
+################################## Random Number ###############################
+
+# Returns a random number in the range [0,2^n-1]
+proc ::math::bignum::rand bits {
+ set atoms [expr {($bits+$::math::bignum::atombits-1)/$::math::bignum::atombits}]
+ set shift [expr {($atoms*$::math::bignum::atombits)-$bits}]
+ set r [list bignum 0]
+ while {$atoms} {
+ lappend r [expr {int(rand()*(1<<$::math::bignum::atombits))}]
+ incr atoms -1
+ }
+ set r [::math::bignum::rshiftBits $r $shift]
+ return $r
+}
+
+############################ Convertion to/from string #########################
+
+# The string representation charset. Max base is 36
+set ::math::bignum::cset "0123456789abcdefghijklmnopqrstuvwxyz"
+
+# Convert 'z' to a string representation in base 'base'.
+# Note that this is missing a simple but very effective optimization
+# that's to divide by the biggest power of the base that fits
+# in a Tcl plain integer, and then to perform divisions with [expr].
+proc ::math::bignum::tostr {z {base 10}} {
+ if {[string length $::math::bignum::cset] < $base} {
+ error "base too big for string convertion"
+ }
+ if {[::math::bignum::iszero $z]} {return 0}
+ set sign [::math::bignum::sign $z]
+ set str {}
+ while {![::math::bignum::iszero $z]} {
+ foreach {q r} [::math::bignum::rawDivByAtom $z $base] break
+ append str [string index $::math::bignum::cset $r]
+ set z $q
+ }
+ if {$sign} {append str -}
+ # flip the resulting string
+ set flipstr {}
+ set i [string length $str]
+ incr i -1
+ while {$i >= 0} {
+ append flipstr [string index $str $i]
+ incr i -1
+ }
+ return $flipstr
+}
+
+# Create a bignum from a string representation in base 'base'.
+proc ::math::bignum::fromstr {str {base 0}} {
+ set z [::math::bignum::zero]
+ set str [string trim $str]
+ set sign 0
+ if {[string index $str 0] eq {-}} {
+ set str [string range $str 1 end]
+ set sign 1
+ }
+ if {$base == 0} {
+ switch -- [string tolower [string range $str 0 1]] {
+ 0x {set base 16; set str [string range $str 2 end]}
+ ox {set base 8 ; set str [string range $str 2 end]}
+ bx {set base 2 ; set str [string range $str 2 end]}
+ default {set base 10}
+ }
+ }
+ if {[string length $::math::bignum::cset] < $base} {
+ error "base too big for string convertion"
+ }
+ set bigbase [list bignum 0 $base] ; # Build a bignum with the base value
+ set basepow [list bignum 0 1] ; # multiply every digit for a succ. power
+ set i [string length $str]
+ incr i -1
+ while {$i >= 0} {
+ set digitval [string first [string index $str $i] $::math::bignum::cset]
+ if {$digitval == -1} {
+ error "Illegal char '[string index $str $i]' for base $base"
+ }
+ set bigdigitval [list bignum 0 $digitval]
+ set z [::math::bignum::rawAdd $z [::math::bignum::mul $basepow $bigdigitval]]
+ set basepow [::math::bignum::mul $basepow $bigbase]
+ incr i -1
+ }
+ if {![::math::bignum::iszero $z]} {
+ ::math::bignum::setsign z $sign
+ }
+ return $z
+}
+
+#
+# Pre-treatment of some constants : 0 and 1
+# Updated 19/11/2005 : abandon the 'upvar' command and its cost
+#
+proc ::math::bignum::_treat {num} {
+ if {[llength $num]<2} {
+ if {[string equal $num 0]} {
+ # set to the bignum 0
+ return {bignum 0 0}
+ } elseif {[string equal $num 1]} {
+ # set to the bignum 1
+ return {bignum 0 1}
+ }
+ }
+ return $num
+}
+
+namespace eval ::math::bignum {
+ namespace export *
+}
+
+# Announce the package
+
+package provide math::bignum 3.1.1
diff --git a/tcllib/modules/math/bignum.test b/tcllib/modules/math/bignum.test
new file mode 100755
index 0000000..7183361
--- /dev/null
+++ b/tcllib/modules/math/bignum.test
@@ -0,0 +1,587 @@
+# -*- tcl -*-
+# bignum.test --
+# Test cases for the ::math::bignum package
+#
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.1
+
+support {
+ useLocal math.tcl math
+}
+testing {
+ useLocal bignum.tcl math::bignum
+}
+
+# -------------------------------------------------------------------------
+
+proc matchBignums { expected actual } {
+ set match 1
+ foreach a $actual e $expected {
+ if { $a != $b } {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+
+#
+# Note:
+# Some tests use the internal representation directly.
+# The variables atombits is assumed to be 16
+#
+if { $::math::bignum::atombits != 16 } {
+ puts "Prerequisite: atombits = 16"
+ #
+ # The maximum value for the atoms is 2**16-1 = 65535
+ #
+}
+
+# -------------------------------------------------------------------------
+
+#
+# Tests: fromstr/tostr (use the internal representation directly)
+#
+test "Fromstr-1.0" "Convert string representing small number (1)" -body {
+ ::math::bignum::fromstr 1
+} -result {bignum 0 1}
+
+test "Fromstr-1.1" "Convert string representing small number (2)" -body {
+ ::math::bignum::fromstr 257
+} -result {bignum 0 257}
+
+test "Fromstr-1.2" "Convert string representing big number (1)" -body {
+ ::math::bignum::fromstr "[expr {256*256*256}]"
+} -result {bignum 0 0 256}
+
+test "Fromstr-1.3" "Convert string representing big number (2)" -body {
+ ::math::bignum::fromstr "[expr {256*256*256+1}]"
+} -result {bignum 0 1 256}
+
+test "Fromstr-1.4" "Convert string representing negative number" -body {
+ ::math::bignum::fromstr "[expr {-256*256*256-1}]"
+} -result {bignum 1 1 256}
+
+test "Fromstr-1.5" "Convert string representing binary number (1)" -body {
+ ::math::bignum::fromstr "10000000000000000000000000000000" 2
+} -result {bignum 0 0 32768}
+
+test "Fromstr-1.6" "Convert string representing binary number (2)" -body {
+ ::math::bignum::fromstr "10000000000000000000000000000001" 2
+} -result {bignum 0 1 32768}
+
+test "Fromstr-1.7" "Convert string representing hex number (1)" -body {
+ ::math::bignum::fromstr "ffffffff" 16
+} -result {bignum 0 65535 65535}
+
+test "Fromstr-1.8" "Convert string representing hex number (2)" -body {
+ ::math::bignum::fromstr "-ffffffff" 16
+} -result {bignum 1 65535 65535}
+
+test "Fromstr-1.9" "Convert string representing 2*16+1" -body {
+ ::math::bignum::fromstr "65537"
+} -result {bignum 0 1 1}
+
+test "Fromstr-1.10" "Convert string representing 2*16" -body {
+ ::math::bignum::fromstr "65536"
+} -result {bignum 0 0 1}
+
+
+test "Tostr-2.0" "Convert small number (1)" -body {
+ ::math::bignum::tostr {bignum 0 1}
+} -result 1
+
+test "Tostr-2.1" "Convert small number (2)" -body {
+ ::math::bignum::tostr {bignum 0 257}
+} -result 257
+
+test "Tostr-2.2" "Convert big number (1)" -body {
+ ::math::bignum::tostr {bignum 0 0 256}
+} -result "[expr {256*256*256}]"
+
+test "Tostr-2.3" "Convert big number (2)" -body {
+ ::math::bignum::tostr {bignum 0 1 256}
+} -result "[expr {256*256*256+1}]"
+
+test "Tostr-2.4" "Convert negative number" -body {
+ ::math::bignum::tostr {bignum 1 1 256}
+} -result "[expr {-256*256*256-1}]"
+
+test "Tostr-2.5" "Convert binary number (1)" -body {
+ ::math::bignum::tostr {bignum 0 0 32768} 2
+} -result "10000000000000000000000000000000"
+
+test "Tostr-2.6" "Convert binary number (2)" -body {
+ ::math::bignum::tostr {bignum 0 1 32768} 2
+} -result "10000000000000000000000000000001"
+
+test "Tostr-2.7" "Convert hex number (1)" -body {
+ ::math::bignum::tostr {bignum 0 65535 65535} 16
+} -result "ffffffff"
+
+test "Tostr-2.8" "Convert hex number (2)" -body {
+ ::math::bignum::tostr {bignum 1 65535 65535} 16
+} -result "-ffffffff"
+
+test "Tostr-2.9" "Convert very big number" -body {
+ ::math::bignum::tostr [::math::bignum::fromstr "10000000000000000000"]
+} -result "10000000000000000000"
+
+test "Tostr-2.10" "Convert to ternary number" -body {
+ ::math::bignum::tostr {bignum 0 9} 3
+} -result "100"
+
+#
+# Arithmetic operations
+#
+test "Plus-3.0" "Add two smallish numbers" -body {
+ set a [::math::bignum::fromstr "100000"]
+ set b [::math::bignum::fromstr "100001"]
+
+ set c [::math::bignum::add $a $b]
+
+ ::math::bignum::tostr $c
+} -result "200001"
+
+test "Plus-3.1" "Add two big numbers" -body {
+ set a [::math::bignum::fromstr "100000000000000"]
+ set b [::math::bignum::fromstr "100001000000001"]
+
+ set c [::math::bignum::add $a $b]
+
+ ::math::bignum::tostr $c
+} -result "200001000000001"
+
+test "Plus-3.2" "Add two very large numbers" -body {
+ set a [::math::bignum::fromstr "1[string repeat 0 200]1"]
+ set b [::math::bignum::fromstr "2[string repeat 0 200]2"]
+
+ set c [::math::bignum::add $a $b]
+
+ ::math::bignum::tostr $c
+} -result "3[string repeat 0 200]3"
+
+test "Plus-3.3" "Add zero to a large number" -body {
+ set a [::math::bignum::fromstr "1[string repeat 0 200]1"]
+ set b 0
+
+ set c [::math::bignum::add $a $b]
+
+ ::math::bignum::tostr $c
+} -result "1[string repeat 0 200]1"
+
+test "Plus-3.4" "Add one to a large number" -body {
+ set a [::math::bignum::fromstr "1[string repeat 9 200]"]
+ set b 1
+
+ set c [::math::bignum::add $a $b]
+
+ ::math::bignum::tostr $c
+} -result "2[string repeat 0 200]"
+
+
+test "Minus-3.2" "Subtract two smallish numbers" -body {
+ set a [::math::bignum::fromstr "100000"]
+ set b [::math::bignum::fromstr "100001"]
+
+ set c [::math::bignum::sub $a $b]
+
+ ::math::bignum::tostr $c
+} -result "-1"
+
+test "Minus-3.3" "Subtract two big numbers" -body {
+ set a [::math::bignum::fromstr "100000000000000"]
+ set b [::math::bignum::fromstr "100001000000001"]
+
+ set c [::math::bignum::sub $a $b]
+
+ ::math::bignum::tostr $c
+} -result "-1000000001"
+
+test "Minus-3.4" "Subtract one from a big number" -body {
+ set a [::math::bignum::fromstr "1[string repeat 0 50]"]
+ set b 1
+
+ set c [::math::bignum::sub $a $b]
+
+ ::math::bignum::tostr $c
+} -result [string repeat 9 50]
+
+test "Compare-4.0" "Compare a set of two numbers" -body {
+ set okay 1
+ foreach {astring bstring op} {
+ 1 -1 gt
+ 1 -1 ge
+ 1 1 ge
+ 1 1 eq
+ -1 1 lt
+ -1 1 le
+ 10000000 -10000000 gt
+ 10000000 -10000000 ge
+ 10000000 10000000 eq
+ -10000000 10000000 lt
+ -10000000 10000000 le
+ 100000000000 -100000000000 gt
+ 100000000000 -100000000000 ge
+ 100000000000 100000000000 eq
+ -100000000000 100000000000 lt
+ -100000000000 100000000000 le
+ 1000000000000000000000 -1000000000000000000000 gt
+ 1000000000000000000000 -1000000000000000000000 ge
+ 1000000000000000000000 1000000000000000000000 eq
+ -1000000000000000000000 1000000000000000000000 lt
+ -1000000000000000000000 1000000000000000000000 le
+ -1000000000000000000000 1000000000000000000000 ne
+ } {
+ set a [::math::bignum::fromstr $astring]
+ set b [::math::bignum::fromstr $bstring]
+ if { ! [::math::bignum::$op $a $b] } {
+ set okay "False: $astring $op $bstring"
+ break
+ }
+ }
+ return $okay
+} -result 1
+
+test "Compare-4.1" "Compare a set of two numbers (inverse result)" -body {
+ set okay 1
+ foreach {astring bstring op} {
+ -1 1 gt
+ -1 1 ge
+ 1 1 ne
+ 1 -1 lt
+ 1 -1 le
+ -10000000 10000000 gt
+ -10000000 10000000 ge
+ 10000000 10000000 ne
+ 10000000 -10000000 lt
+ 10000000 -10000000 le
+ -100000000000 100000000000 gt
+ -100000000000 100000000000 ge
+ 100000000000 100000000000 ne
+ 100000000000 -100000000000 lt
+ 100000000000 -100000000000 le
+ -1000000000000000000000 1000000000000000000000 gt
+ -1000000000000000000000 1000000000000000000000 ge
+ 1000000000000000000000 1000000000000000000000 ne
+ 1000000000000000000000 -1000000000000000000000 lt
+ 1000000000000000000000 -1000000000000000000000 le
+ 1000000000000000000000 -1000000000000000000000 eq
+ } {
+ set a [::math::bignum::fromstr $astring]
+ set b [::math::bignum::fromstr $bstring]
+ #
+ # None should be true
+ #
+ if { [::math::bignum::$op $a $b] } {
+ set okay "True: $astring $op $bstring - should be false"
+ break
+ }
+ }
+ return $okay
+} -result 1
+
+test "Compare-4.2" "Compare a set of numbers against 0 and 1" -body {
+ set okay 1
+ foreach {astring opzero opone} {
+ -1 lt lt
+ 1 gt eq
+ -10000000 lt lt
+ 10000000 gt gt
+ 0 eq lt
+ 2 gt gt
+ } {
+ set a [::math::bignum::fromstr $astring]
+ foreach b {0 1} op [list $opzero $opone] {
+ #
+ # None should be true
+ #
+ if {! [::math::bignum::$op $a $b] } {
+ set okay "False: $astring $op $b - should be true"
+ break
+ }
+ }
+ }
+ return $okay
+} -result 1
+
+
+test "Mult-5.0" "Multiply two small numbers" -body {
+ set a [::math::bignum::fromstr 10]
+ set b [::math::bignum::fromstr 1000]
+
+ set c [::math::bignum::mul $a $b]
+
+ ::math::bignum::tostr $c
+} -result "10000"
+
+test "Mult-5.0a" "Multiply small numbers by 0" -body {
+ set okay 1
+ foreach a {1 0 -1 100000 -10000 100000000000 -100000000000} {
+ set n [::math::bignum::fromstr $a]
+ if {! [::math::bignum::iszero [::math::bignum::mul $n 0]]} {
+ set okay "Multiplying $a by 0 does not give 0"
+ return
+ }
+ }
+ set okay
+} -result 1
+
+test "Mult-5.0b" "Multiply small numbers by 1" -body {
+ set okay 1
+ foreach a {1 0 -1 100000 -10000 100000000000 -100000000000} {
+ set n [::math::bignum::fromstr $a]
+ if {! [::math::bignum::eq [::math::bignum::mul $n 1] $n]} {
+ set okay "Multiplying $a by 1 does not give $a"
+ return
+ }
+ }
+ set okay
+} -result 1
+
+
+test "Mult-5.1" "Multiply two small negative numbers" -body {
+ set a [::math::bignum::fromstr -10]
+ set b [::math::bignum::fromstr -1000]
+
+ set c [::math::bignum::mul $a $b]
+
+ ::math::bignum::tostr $c
+} -result "10000"
+
+test "Mult-5.2" "Multiply two very large numbers" -body {
+ set a [::math::bignum::fromstr "1[string repeat 0 100]"]
+ set b [::math::bignum::fromstr "2[string repeat 0 200]"]
+
+ set c [::math::bignum::mul $a $b]
+
+ ::math::bignum::tostr $c
+} -result "2[string repeat 0 300]"
+
+test "Mult-5.3" "Multiply two very large numbers of opposite sign" -body {
+ set a [::math::bignum::fromstr "1[string repeat 0 100]"]
+ set b [::math::bignum::fromstr "-2[string repeat 0 200]"]
+
+ set c [::math::bignum::mul $a $b]
+
+ ::math::bignum::tostr $c
+} -result "-2[string repeat 0 300]"
+
+test "Mult-5.4" "Katsabura multiplication with two very large numbers of opposite sign" -body {
+ set a [::math::bignum::fromstr "1[string repeat 0 1000]"]
+ set b [::math::bignum::fromstr "-2[string repeat 0 2000]"]
+
+ set c [::math::bignum::mul $a $b]
+
+ ::math::bignum::tostr $c
+} -result "-2[string repeat 0 3000]"
+
+# Div
+test "Div-6.1" "Divide 0 by any number" -body {
+ set okay 1
+ foreach n {1 -1 2 -2 10 -10 1000000000 -100000000} {
+ set a [::math::bignum::fromstr $n]
+ if {! [::math::bignum::iszero [::math::bignum::div 0 $a]]} {
+ set okay "Zero divided by $n does not give zero"
+ break
+ }
+ }
+ set okay
+} -result 1
+
+
+test "Div-6.2" "Divide small numbers by 1" -body {
+ set okay 1
+ foreach n {0 1 -1 2 -2 10 -10 1000000000 -100000000} {
+ set a [::math::bignum::fromstr $n]
+ if {! [::math::bignum::eq [::math::bignum::div $a 1] $a]} {
+ set okay "$n divided by 1 does not give $n"
+ break
+ }
+ }
+ set okay
+} -result 1
+
+test "Div-6.3" "Divide big numbers by 2" -body {
+ set okay 1
+ set two [::math::bignum::fromstr 2]
+ foreach p {2 5 10 50 100} {
+ set n 1[string repeat 0 $p]
+ set a [::math::bignum::fromstr $n]
+ set q 5[string repeat 0 [expr {$p-1}]]
+ if {! [string equal [::math::bignum::tostr [::math::bignum::div $a $two]] $q]} {
+ set okay "$n divided by 2 does not give $q"
+ break
+ }
+ }
+ set okay
+} -result 1
+
+test "Pow-7.1" "Exponentiate large numbers" -body {
+ set a [::math::bignum::fromstr "1[string repeat 0 10]"]
+ set b [::math::bignum::fromstr 1]
+
+ set okay 1
+ foreach p {1 2 3 4 5 6 7 8 9 10} {
+ set c [::math::bignum::mul $b $a]
+ set d [::math::bignum::pow $a $p]
+
+ if { [::math::bignum::ne $c $d] } {
+ set okay "False: $a**$p != $c"
+ }
+ }
+ return $okay
+} -result 1
+
+# Left and right shifts
+
+set c 0
+foreach {z n} {
+ 1 1
+ 2 1
+ 4 1
+ -1 1
+ -2 1
+ -4 1
+ 1 2
+ 2 2
+ 4 2
+ -1 2
+ -2 2
+ -4 2
+ 1000001 1
+ 2000001 1
+ 4000001 1
+ -1000001 1
+ -2000001 1
+ -4000001 1
+ 10000000001 1
+ 20000000001 1
+ 40000000001 1
+ -10000000001 1
+ -20000000001 1
+ -40000000001 1
+ 10000000001 11
+ 20000000001 11
+ 40000000001 11
+ -10000000001 11
+ -20000000001 11
+ -40000000001 11
+ 10000000001 21
+ 20000000001 21
+ 40000000001 21
+ -10000000001 21
+ -20000000001 21
+ -40000000001 21
+} {
+ incr c
+ test "Lshift-8.$c" "Lshift large numbers" -body {
+ set x [::math::bignum::lshift [::math::bignum::fromstr $z] $n]
+ set y [expr {$z << $n}]
+ ::math::bignum::cmp $x [::math::bignum::fromstr $y]
+ } -result 0
+
+ test "Rshift-8.$c" "Rshift large numbers" -body {
+ set x [::math::bignum::rshift [::math::bignum::fromstr $z] $n]
+ set y [expr {$z >> $n}]
+ ::math::bignum::cmp $x [::math::bignum::fromstr $y]
+ } -result 0
+}
+
+# Bit operations (And, Or, Xor)
+
+foreach {n a b zand zor zxor} {
+ 0 0 0 0 0 0
+ 1 1 2 0 3 3
+ 2 1 3 1 3 2
+ 3 2 3 2 3 1
+} {
+ set a [::math::bignum::fromstr $a]
+ set b [::math::bignum::fromstr $b]
+ set zand [::math::bignum::fromstr $zand]
+ set zor [::math::bignum::fromstr $zor]
+ set zxor [::math::bignum::fromstr $zxor]
+
+ test "Bitand-8.$n" "BitAnd large numbers" -body {
+ ::math::bignum::bitand $a $b
+ } -result $zand
+
+ test "Bitor-9.$n" "BitOr large numbers" -body {
+ ::math::bignum::bitor $a $b
+ } -result $zor
+
+ test "Bitxor-10.$n" "BitXor large numbers" -body {
+ ::math::bignum::bitxor $a $b
+ } -result $zxor
+}
+
+test "Mod-11.1" "Modulo and remainder for small numbers" -body {
+ set okay 1
+ foreach {n d m r} {
+ 100 -3 -2 1
+ -100 -3 -1 -1
+ -100 3 2 -1
+ 100 3 1 1
+ } {
+ set a [::math::bignum::fromstr $n]
+ set b [::math::bignum::fromstr $d]
+ set modulo [::math::bignum::tostr [::math::bignum::mod $a $b]]
+ set remainder [::math::bignum::tostr [::math::bignum::rem $a $b]]
+ if {! [string equal $modulo $m]} {
+ set okay "$n modulo $d does not give $m"
+ break
+ }
+ if {! [string equal $remainder $r]} {
+ set okay "the remainder of $n/$d is not given as $r"
+ break
+ }
+ }
+ return $okay
+} -result 1
+
+
+# Bit operations (Test bit)
+
+test testbit-1.0 {test with bit in range of used bits} -setup {
+ set z [::math::bignum::fromstr 3220]
+ ::math::bignum::setbit z 24
+} -body {
+ ::math::bignum::testbit $z 23
+} -cleanup {
+ unset z
+} -result 0
+
+test testbit-1.1 {test with bit beyond range of used bits} -setup {
+ set z [::math::bignum::fromstr 3220]
+} -body {
+ ::math::bignum::testbit $z 23
+} -cleanup {
+ unset z
+} -result 0
+
+test testbit-1.2 {test with bit in range of used bits} -setup {
+ set z [::math::bignum::fromstr 3220]
+ ::math::bignum::setbit z 24
+} -body {
+ ::math::bignum::testbit $z 24
+} -cleanup {
+ unset z
+} -result 1
+
+# -------------------------------------------------------------------------
+
+#
+# TODO: all the other operations and functions
+#
+
+# -------------------------------------------------------------------------
+
+# End of test cases
+testsuiteCleanup
diff --git a/tcllib/modules/math/calculus.CHANGES b/tcllib/modules/math/calculus.CHANGES
new file mode 100755
index 0000000..fb50f34
--- /dev/null
+++ b/tcllib/modules/math/calculus.CHANGES
@@ -0,0 +1,21 @@
+Package: Calculus
+-----------------
+
+This file contains information about the changes that have
+been made:
+
+Version 0.1: november 2001
+ Initial version, no differential equations yet
+
+Version 0.2: november 2001
+ Extended with Euler and Heun methods, 2D and 3D simple integration
+
+Version 0.3: march 2002
+ Implemented Runge-Kutta, converted documentation to doctools'
+ man format
+
+Version 0.4: march 2002
+ Implemented Newton-Raphson method for finding roots of equations
+
+Version 0.5: may 2002
+ Fixed problem with namespaces
diff --git a/tcllib/modules/math/calculus.README b/tcllib/modules/math/calculus.README
new file mode 100755
index 0000000..771e08c
--- /dev/null
+++ b/tcllib/modules/math/calculus.README
@@ -0,0 +1,21 @@
+Package: math::calculus
+-----------------------
+The math::calculus package is an all-Tcl package that implements
+several basic numerical algorithms, such as the integration
+of functions of one variable or the integration of ordinary
+differential equations.
+
+The directory contains the following files:
+README - This file
+CHANGES - Changes made since the previous version(s)
+calculus.tcl - The source code for the package
+calculus.test - Several simple tests
+calculus.html - Documentation of the package
+
+The current version is: 0.5, may 2002
+
+This package is available as part of Tcllib at:
+ http://core.tcl.tk/tcllib
+
+Please contact Arjen Markus (arjen.markus@wldelft.nl) for questions,
+bug reports, enhancements and so on.
diff --git a/tcllib/modules/math/calculus.doc b/tcllib/modules/math/calculus.doc
new file mode 100755
index 0000000..62fdd0a
--- /dev/null
+++ b/tcllib/modules/math/calculus.doc
@@ -0,0 +1,311 @@
+[pageheader "Package: Calculus"]
+[synopsis \
+{package require Tcl 8.2
+package require math::calculus 0.5
+::math::calculus::integral begin end nosteps func
+::math::calculus::integralExpr begin end nosteps expression
+::math::calculus::integral2D xinterval yinterval func
+::math::calculus::integral3D xinterval yinterval zinterval func
+::math::calculus::eulerStep t tstep xvec func
+::math::calculus::heunStep t tstep xvec func
+::math::calculus::rungeKuttaStep tstep xvec func
+::math::calculus::boundaryValueSecondOrder coeff_func force_func leftbnd rightbnd nostep}]
+::math::calculus::newtonRaphson func deriv initval
+::math::calculus::newtonRaphsonParameters maxiter tolerance
+
+[section "Introduction"]
+The package Calculus implements several simple mathematical algorithms,
+such as the integration of a function over an interval and the numerical
+integration of a system of ordinary differential equations.
+[par]
+It is fully implemented in Tcl. No particular attention has been paid to
+the accuracy of the calculations. Instead, well-known algorithms have
+been used in a straightforward manner.
+[par]
+This document describes the procedures and explains their usage.
+
+[section "Version and copyright"]
+This document describes [italic ::math::calculus], version 0.5, may 2002.
+[par]
+Usage of Calculus is free, as long as you acknowledge the
+author, Arjen Markus (e-mail: arjen.markus@wldelft.nl).
+[par]
+There is no guarantee nor claim that the results are accurate.
+
+[section "Procedures"]
+The Calculus package defines the following public procedures:
+[ulist]
+[item][italic "integral begin end nosteps func"]
+ [break]
+ Determine the integral of the given function using the Simpson
+ rule. The interval for the integration is [lb]begin,end[rb].
+ [break]
+ Other arguments:
+ [break]
+ [italic nosteps] - Number of steps in which the interval is divided.
+ [break]
+ [italic func] - Function to be integrated. It should take one
+ single argument.
+ [par]
+
+[item][italic "integralExpr begin end nosteps expression"]
+ [break]
+ Similar to the previous proc, this one determines the integral of
+ the given [italic expression] using the Simpson rule.
+ The interval for the integration is [lb]begin,end[rb].
+ [break]
+ Other arguments:
+ [break]
+ [italic nosteps] - Number of steps in which the interval is divided.
+ [break]
+ [italic expression] - Expression to be integrated. It should
+ use the variable "x" as the only variable (the "integrate")
+ [par]
+
+[item][italic "integral2D xinterval yinterval func"]
+ [break]
+ The [italic integral2D] procedure calculates the integral of
+ a function of two variables over the rectangle given by the
+ first two arguments, each a list of three items, the start and
+ stop interval for the variable and the number of steps.
+ [break]
+ The currently implemented integration is simple: the function is
+ evaluated at the centre of each rectangle and the content of
+ this block is added to the integral. In future this will be
+ replaced by a bilinear interpolation.
+ [break]
+ The function must take two arguments and return the function
+ value.
+ [par]
+
+[item][italic "integral3D xinterval yinterval zinterval func"]
+ [break]
+ The [italic integral3D] procedure is the three-dimensional
+ equivalent of [italic intergral2D]. The function taking three
+ arguments is integrated over the block in 3D space given by the
+ intervals.
+ [par]
+
+[item][italic "eulerStep t tstep xvec func"]
+ [break]
+ Set a single step in the numerical integration of a system of
+ differential equations. The method used is Euler's.
+ [break]
+ [italic t] - Value of the independent variable (typically time)
+ at the beginning of the step.
+ [break]
+ [italic tstep] - Step size for the independent variable.
+ [break]
+ [italic xvec] - List (vector) of dependent values
+ [break]
+ [italic func] - Function of t and the dependent values, returning
+ a list of the derivatives of the dependent values. (The lengths of
+ xvec and the return value of "func" must match).
+ [par]
+
+[item][italic "heunStep t tstep xvec func"]
+ [break]
+ Set a single step in the numerical integration of a system of
+ differential equations. The method used is Heun's.
+ [break]
+ [italic t] - Value of the independent variable (typically time)
+ at the beginning of the step.
+ [break]
+ [italic tstep] - Step size for the independent variable.
+ [break]
+ [italic xvec] - List (vector) of dependent values
+ [break]
+ [italic func] - Function of t and the dependent values, returning
+ a list of the derivatives of the dependent values. (The lengths of
+ xvec and the return value of "func" must match).
+ [par]
+
+[item][italic "rungeKuttaStep tstep xvec func"]
+ [break]
+ Set a single step in the numerical integration of a system of
+ differential equations. The method used is Runge-Kutta 4th
+ order.
+ [break]
+ [italic t] - Value of the independent variable (typically time)
+ at the beginning of the step.
+ [break]
+ [italic tstep] - Step size for the independent variable.
+ [break]
+ [italic xvec] - List (vector) of dependent values
+ [break]
+ [italic func] - Function of t and the dependent values, returning
+ a list of the derivatives of the dependent values. (The lengths of
+ xvec and the return value of "func" must match).
+ [par]
+
+[item][italic "boundaryValueSecondOrder coeff_func force_func leftbnd rightbnd nostep"]
+ [break]
+ Solve a second order linear differential equation with boundary
+ values at two sides. The equation has to be of the form:
+[preserve]
+ d dy d
+ -- A(x)-- + -- B(x)y + C(x)y = D(x)
+ dx dx dx
+[endpreserve]
+ Ordinarily, such an equation would be written as:
+[preserve]
+ d2y dy
+ a(x)--- + b(x)-- + c(x) y = D(x)
+ dx2 dx
+[endpreserve]
+ The first form is easier to discretise (by integrating over a
+ finite volume) than the second form. The relation between the two
+ forms is fairly straightforward:
+[preserve]
+ A(x) = a(x)
+ B(x) = b(x) - a'(x)
+ C(x) = c(x) - B'(x) = c(x) - b'(x) + a''(x)
+[endpreserve]
+ Because of the differentiation, however, it is much easier to ask
+ the user to provide the functions A, B and C directly.
+ [break]
+ [italic coeff_func] - Procedure returning the three coefficients
+ (A, B, C) of the equation, taking as its one argument the x-coordinate.
+ [italic force_func] - Procedure returning the right-hand side
+ (D) as a function of the x-coordinate.
+ [italic leftbnd] - A list of two values: the x-coordinate of the
+ left boundary and the value at that boundary.
+ [italic rightbnd] - A list of two values: the x-coordinate of the
+ right boundary and the value at that boundary.
+ [italic nostep] - Number of steps by which to discretise the
+ interval.
+ The procedure returns a list of x-coordinates and the approximated
+ values of the solution.
+ [par]
+
+[item][italic "solveTriDiagonal acoeff bcoeff ccoeff dvalue"]
+ [break]
+ Solve a system of linear equations Ax = b with A a tridiagonal
+ matrix. Returns the solution as a list.
+ [break]
+ [italic acoeff] - List of values on the lower diagonal
+ [italic bcoeff] - List of values on the main diagonal
+ [italic ccoeff] - List of values on the upper diagonal
+ [italic dvalue] - List of values on the righthand-side
+ [par]
+
+[item][italic "newtonRaphson func deriv initval"]
+ [break]
+ Determine the root of an equation given by [italic "f(x) = 0"],
+ using the Newton-Raphson method.
+ [break]
+ [italic func] - Name of the procedure that calculates the function value
+ [italic deriv - Name of the procedure that calculates the derivative of the function
+ [italic initval] - Initial value for the iteration
+ [par]
+
+[item][italic "newtonRaphsonParameters maxiter tolerance"]
+ [break]
+ Set new values for the two parameters that gouvern the Newton-Raphson method.
+ [break]
+ [italic maxiter] - Maximum number of iterations
+ [italic tolerance] - Relative error in the calculation
+ [par]
+[endlist]
+
+[italic Notes:]
+[break]
+Several of the above procedures take the [italic names] of procedures as
+arguments. To avoid problems with the [italic visibility] of these
+procedures, the fully-qualified name of these procedures is determined
+inside the calculus routines. For the user this has only one
+consequence: the named procedure must be visible in the calling
+procedure. For instance:
+
+[preserve]
+ namespace eval ::mySpace {
+ namespace export calcfunc
+ proc calcfunc { x } { return $x }
+ }
+ #
+ # Use a fully-qualified name
+ #
+ namespace eval ::myCalc {
+ proc detIntegral { begin end } {
+ return [lb]integral $begin $end 100 ::mySpace::calcfunc[rb]
+ }
+ }
+ #
+ # Import the name
+ #
+ namespace eval ::myCalc {
+ namespace import ::mySpace::calcfunc
+ proc detIntegral { begin end } {
+ return [lb]integral $begin $end 100 calcfunc[rb]
+ }
+ }
+[endpreserve]
+[par]
+Enhancements for the second-order boundary value problem:
+[ulist]
+[item]Other types of boundary conditions (zero gradient, zero flux)
+[item]Other schematisation of the first-order term (now central
+ differences are used, but upstream differences might be useful too).
+[endlist]
+
+[section Examples]
+Let us take a few simple examples:
+[par]
+Integrate x over the interval [lb]0,100[rb] (20 steps):
+[preserve]
+proc linear_func { x } { return $x }
+puts "Integral: [lb]::math::calculus::Integral 0 100 20 linear_func[rb]"
+[endpreserve]
+For simple functions, the alternative could be:
+[preserve]
+puts "Integral: [lb]::math::calculus::IntegralExpr 0 100 20 {$x}[rb]"
+[endpreserve]
+Do not forget the braces!
+[par]
+The differential equation for a dampened oscillator:
+[preserve]
+ x'' + rx' + wx = 0
+[endpreserve]
+can be split into a system of first-order equations:
+[preserve]
+ x' = y
+ y' = -ry - wx
+[endpreserve]
+Then this system can be solved with code like this:
+[preserve]
+proc dampened_oscillator { t xvec } {
+ set x [lb]lindex \$xvec 0[rb]
+ set x1 [lb]lindex \$xvec 1[rb]
+ return [lb]list \$x1 [lb]expr {-\$x1-\$x}[rb][rb]
+}
+
+set xvec { 1.0 0.0 }
+set t 0.0
+set tstep 0.1
+for { set i 0 } { \$i < 20 } { incr i } {
+ set result [lb]::math::calculus::eulerStep \$t \$tstep \$xvec dampened_oscillator[rb]
+ puts "Result (\$t): \$result"
+ set t [lb]expr {\$t+\$tstep}[rb]
+ set xvec \$result
+}
+[endpreserve]
+Suppose we have the boundary value problem:
+[preserve]
+ Dy'' + ky = 0
+ x = 0: y = 1
+ x = L: y = 0
+[endpreserve]
+This boundary value problem could originate from the diffusion of a
+decaying substance.
+[par]
+It can be solved with the following fragment:
+[preserve]
+ proc coeffs { x } { return [lb]list \$::Diff 0.0 \$::decay[rb] }
+ proc force { x } { return 0.0 }
+
+ set Diff 1.0e-2
+ set decay 0.0001
+ set length 100.0
+ set y [lb]::math::calculus::boundaryValueSecondOrder coeffs force {0.0 1.0} \
+ [lb]list \$length 0.0[rb] 100[rb]
+[endpreserve]
diff --git a/tcllib/modules/math/calculus.man b/tcllib/modules/math/calculus.man
new file mode 100755
index 0000000..2bad0b7
--- /dev/null
+++ b/tcllib/modules/math/calculus.man
@@ -0,0 +1,451 @@
+[vset VERSION 0.8.1]
+[manpage_begin math::calculus n [vset VERSION]]
+[see_also romberg]
+[keywords calculus]
+[keywords {differential equations}]
+[keywords integration]
+[keywords math]
+[keywords roots]
+[copyright {2002,2003,2004 Arjen Markus}]
+[moddesc {Tcl Math Library}]
+[titledesc {Integration and ordinary differential equations}]
+[category Mathematics]
+[require Tcl 8.4]
+[require math::calculus [vset VERSION]]
+[description]
+[para]
+This package implements several simple mathematical algorithms:
+
+[list_begin itemized]
+[item]
+The integration of a function over an interval
+
+[item]
+The numerical integration of a system of ordinary differential
+equations.
+
+[item]
+Estimating the root(s) of an equation of one variable.
+
+[list_end]
+
+[para]
+The package is fully implemented in Tcl. No particular attention has
+been paid to the accuracy of the calculations. Instead, well-known
+algorithms have been used in a straightforward manner.
+[para]
+This document describes the procedures and explains their usage.
+
+[section "PROCEDURES"]
+This package defines the following public procedures:
+[list_begin definitions]
+
+[call [cmd ::math::calculus::integral] [arg begin] [arg end] [arg nosteps] [arg func]]
+Determine the integral of the given function using the Simpson
+rule. The interval for the integration is [lb][arg begin], [arg end][rb].
+The remaining arguments are:
+
+[list_begin definitions]
+[def [arg nosteps]]
+Number of steps in which the interval is divided.
+
+[def [arg func]]
+Function to be integrated. It should take one single argument.
+[list_end]
+[para]
+
+[call [cmd ::math::calculus::integralExpr] [arg begin] [arg end] [arg nosteps] [arg expression]]
+Similar to the previous proc, this one determines the integral of
+the given [arg expression] using the Simpson rule.
+The interval for the integration is [lb][arg begin], [arg end][rb].
+The remaining arguments are:
+
+[list_begin definitions]
+[def [arg nosteps]]
+Number of steps in which the interval is divided.
+
+[def [arg expression]]
+Expression to be integrated. It should
+use the variable "x" as the only variable (the "integrate")
+[list_end]
+[para]
+
+[call [cmd ::math::calculus::integral2D] [arg xinterval] [arg yinterval] [arg func]]
+[call [cmd ::math::calculus::integral2D_accurate] [arg xinterval] [arg yinterval] [arg func]]
+The commands [cmd integral2D] and [cmd integral2D_accurate] calculate the
+integral of a function of two variables over the rectangle given by the
+first two arguments, each a list of three items, the start and
+stop interval for the variable and the number of steps.
+[para]
+The command [cmd integral2D] evaluates the function at the centre of
+each rectangle, whereas the command [cmd integral2D_accurate] uses a
+four-point quadrature formula. This results in an exact integration of
+polynomials of third degree or less.
+[para]
+The function must take two arguments and return the function
+value.
+
+[call [cmd ::math::calculus::integral3D] [arg xinterval] [arg yinterval] [arg zinterval] [arg func]]
+[call [cmd ::math::calculus::integral3D_accurate] [arg xinterval] [arg yinterval] [arg zinterval] [arg func]]
+The commands [cmd integral3D] and [cmd integral3D_accurate] are the
+three-dimensional equivalent of [cmd integral2D] and [cmd integral3D_accurate].
+The function [emph func] takes three arguments and is integrated over the block in
+3D space given by three intervals.
+
+[call [cmd ::math::calculus::qk15] [arg xstart] [arg xend] [arg func] [arg nosteps]]
+Determine the integral of the given function using the Gauss-Kronrod 15 points quadrature rule.
+The returned value is the estimate of the integral over the interval [lb][arg xstart], [arg xend][rb].
+The remaining arguments are:
+
+[list_begin definitions]
+[def [arg func]]
+Function to be integrated. It should take one single argument.
+
+[def [opt nosteps]]
+Number of steps in which the interval is divided. Defaults to 1.
+[list_end]
+[para]
+
+[call [cmd ::math::calculus::qk15_detailed] [arg xstart] [arg xend] [arg func] [arg nosteps]]
+Determine the integral of the given function using the Gauss-Kronrod 15 points quadrature rule.
+The interval for the integration is [lb][arg xstart], [arg xend][rb].
+The procedure returns a list of four values:
+[list_begin itemized]
+[item]
+The estimate of the integral over the specified interval (I).
+[item]
+An estimate of the absolute error in I.
+[item]
+The estimate of the integral of the absolute value of the function over the interval.
+[item]
+The estimate of the integral of the absolute value of the function minus its mean over the interval.
+[list_end]
+The remaining arguments are:
+
+[list_begin definitions]
+[def [arg func]]
+Function to be integrated. It should take one single argument.
+
+[def [opt nosteps]]
+Number of steps in which the interval is divided. Defaults to 1.
+[list_end]
+[para]
+
+[call [cmd ::math::calculus::eulerStep] [arg t] [arg tstep] [arg xvec] [arg func]]
+Set a single step in the numerical integration of a system of
+differential equations. The method used is Euler's.
+
+[list_begin definitions]
+[def [arg t]]
+Value of the independent variable (typically time)
+at the beginning of the step.
+
+[def [arg tstep]]
+Step size for the independent variable.
+
+[def [arg xvec]]
+List (vector) of dependent values
+
+[def [arg func]]
+Function of t and the dependent values, returning
+a list of the derivatives of the dependent values. (The lengths of
+xvec and the return value of "func" must match).
+[list_end]
+[para]
+
+[call [cmd ::math::calculus::heunStep] [arg t] [arg tstep] [arg xvec] [arg func]]
+Set a single step in the numerical integration of a system of
+differential equations. The method used is Heun's.
+
+[list_begin definitions]
+[def [arg t]]
+Value of the independent variable (typically time)
+at the beginning of the step.
+
+[def [arg tstep]]
+Step size for the independent variable.
+
+[def [arg xvec]]
+List (vector) of dependent values
+
+[def [arg func]]
+Function of t and the dependent values, returning
+a list of the derivatives of the dependent values. (The lengths of
+xvec and the return value of "func" must match).
+[list_end]
+[para]
+
+[call [cmd ::math::calculus::rungeKuttaStep] [arg t] [arg tstep] [arg xvec] [arg func]]
+Set a single step in the numerical integration of a system of
+differential equations. The method used is Runge-Kutta 4th
+order.
+
+[list_begin definitions]
+[def [arg t]]
+Value of the independent variable (typically time)
+at the beginning of the step.
+
+[def [arg tstep]]
+Step size for the independent variable.
+
+[def [arg xvec]]
+List (vector) of dependent values
+
+[def [arg func]]
+Function of t and the dependent values, returning
+a list of the derivatives of the dependent values. (The lengths of
+xvec and the return value of "func" must match).
+[list_end]
+[para]
+
+[call [cmd ::math::calculus::boundaryValueSecondOrder] [arg coeff_func] [arg force_func] [arg leftbnd] [arg rightbnd] [arg nostep]]
+Solve a second order linear differential equation with boundary
+values at two sides. The equation has to be of the form (the
+"conservative" form):
+[example_begin]
+ d dy d
+ -- A(x)-- + -- B(x)y + C(x)y = D(x)
+ dx dx dx
+[example_end]
+Ordinarily, such an equation would be written as:
+[example_begin]
+ d2y dy
+ a(x)--- + b(x)-- + c(x) y = D(x)
+ dx2 dx
+[example_end]
+The first form is easier to discretise (by integrating over a
+finite volume) than the second form. The relation between the two
+forms is fairly straightforward:
+[example_begin]
+ A(x) = a(x)
+ B(x) = b(x) - a'(x)
+ C(x) = c(x) - B'(x) = c(x) - b'(x) + a''(x)
+[example_end]
+Because of the differentiation, however, it is much easier to ask
+the user to provide the functions A, B and C directly.
+
+[list_begin definitions]
+[def [arg coeff_func]]
+Procedure returning the three coefficients
+(A, B, C) of the equation, taking as its one argument the x-coordinate.
+
+[def [arg force_func]]
+Procedure returning the right-hand side
+(D) as a function of the x-coordinate.
+
+[def [arg leftbnd]]
+A list of two values: the x-coordinate of the
+left boundary and the value at that boundary.
+
+[def [arg rightbnd]]
+A list of two values: the x-coordinate of the
+right boundary and the value at that boundary.
+
+[def [arg nostep]]
+Number of steps by which to discretise the
+interval.
+
+The procedure returns a list of x-coordinates and the approximated
+values of the solution.
+[list_end]
+[para]
+
+[call [cmd ::math::calculus::solveTriDiagonal] [arg acoeff] [arg bcoeff] [arg ccoeff] [arg dvalue]]
+Solve a system of linear equations Ax = b with A a tridiagonal
+matrix. Returns the solution as a list.
+
+[list_begin definitions]
+[def [arg acoeff]]
+List of values on the lower diagonal
+
+[def [arg bcoeff]]
+List of values on the main diagonal
+
+[def [arg ccoeff]]
+List of values on the upper diagonal
+
+[def [arg dvalue]]
+List of values on the righthand-side
+[list_end]
+[para]
+
+[call [cmd ::math::calculus::newtonRaphson] [arg func] [arg deriv] [arg initval]]
+Determine the root of an equation given by
+[example_begin]
+ func(x) = 0
+[example_end]
+using the method of Newton-Raphson. The procedure takes the following
+arguments:
+
+[list_begin definitions]
+[def [arg func]]
+Procedure that returns the value the function at x
+
+[def [arg deriv]]
+Procedure that returns the derivative of the function at x
+
+[def [arg initval]]
+Initial value for x
+[list_end]
+[para]
+
+[call [cmd ::math::calculus::newtonRaphsonParameters] [arg maxiter] [arg tolerance]]
+Set the numerical parameters for the Newton-Raphson method:
+
+[list_begin definitions]
+[def [arg maxiter]]
+Maximum number of iteration steps (defaults to 20)
+
+[def [arg tolerance]]
+Relative precision (defaults to 0.001)
+[list_end]
+
+[call [cmd ::math::calculus::regula_falsi] [arg f] [arg xb] [arg xe] [arg eps]]
+
+Return an estimate of the zero or one of the zeros of the function
+contained in the interval [lb]xb,xe[rb]. The error in this estimate is of the
+order of eps*abs(xe-xb), the actual error may be slightly larger.
+
+[para]
+The method used is the so-called [emph {regula falsi}] or
+[emph "false position"] method. It is a straightforward implementation.
+The method is robust, but requires that the interval brackets a zero or
+at least an uneven number of zeros, so that the value of the function at
+the start has a different sign than the value at the end.
+
+[para]
+In contrast to Newton-Raphson there is no need for the computation of
+the function's derivative.
+
+[list_begin arguments]
+[arg_def command f] Name of the command that evaluates the function for
+which the zero is to be returned
+
+[arg_def float xb] Start of the interval in which the zero is supposed
+to lie
+
+[arg_def float xe] End of the interval
+
+[arg_def float eps] Relative allowed error (defaults to 1.0e-4)
+
+[list_end]
+
+[list_end]
+[para]
+
+[emph Notes:]
+[para]
+Several of the above procedures take the [emph names] of procedures as
+arguments. To avoid problems with the [emph visibility] of these
+procedures, the fully-qualified name of these procedures is determined
+inside the calculus routines. For the user this has only one
+consequence: the named procedure must be visible in the calling
+procedure. For instance:
+[example_begin]
+ namespace eval ::mySpace {
+ namespace export calcfunc
+ proc calcfunc { x } { return $x }
+ }
+ #
+ # Use a fully-qualified name
+ #
+ namespace eval ::myCalc {
+ proc detIntegral { begin end } {
+ return [lb]integral $begin $end 100 ::mySpace::calcfunc[rb]
+ }
+ }
+ #
+ # Import the name
+ #
+ namespace eval ::myCalc {
+ namespace import ::mySpace::calcfunc
+ proc detIntegral { begin end } {
+ return [lb]integral $begin $end 100 calcfunc[rb]
+ }
+ }
+[example_end]
+[para]
+Enhancements for the second-order boundary value problem:
+[list_begin itemized]
+[item]
+Other types of boundary conditions (zero gradient, zero flux)
+[item]
+Other schematisation of the first-order term (now central
+differences are used, but upstream differences might be useful too).
+[list_end]
+
+[section EXAMPLES]
+Let us take a few simple examples:
+[para]
+Integrate x over the interval [lb]0,100[rb] (20 steps):
+[example_begin]
+proc linear_func { x } { return $x }
+puts "Integral: [lb]::math::calculus::integral 0 100 20 linear_func[rb]"
+[example_end]
+For simple functions, the alternative could be:
+[example_begin]
+puts "Integral: [lb]::math::calculus::integralExpr 0 100 20 {$x}[rb]"
+[example_end]
+Do not forget the braces!
+[para]
+The differential equation for a dampened oscillator:
+[para]
+[example_begin]
+x'' + rx' + wx = 0
+[example_end]
+[para]
+can be split into a system of first-order equations:
+[para]
+[example_begin]
+x' = y
+y' = -ry - wx
+[example_end]
+[para]
+Then this system can be solved with code like this:
+[para]
+[example_begin]
+proc dampened_oscillator { t xvec } {
+ set x [lb]lindex $xvec 0[rb]
+ set x1 [lb]lindex $xvec 1[rb]
+ return [lb]list $x1 [lb]expr {-$x1-$x}[rb][rb]
+}
+
+set xvec { 1.0 0.0 }
+set t 0.0
+set tstep 0.1
+for { set i 0 } { $i < 20 } { incr i } {
+ set result [lb]::math::calculus::eulerStep $t $tstep $xvec dampened_oscillator[rb]
+ puts "Result ($t): $result"
+ set t [lb]expr {$t+$tstep}[rb]
+ set xvec $result
+}
+[example_end]
+[para]
+Suppose we have the boundary value problem:
+[para]
+[example_begin]
+ Dy'' + ky = 0
+ x = 0: y = 1
+ x = L: y = 0
+[example_end]
+[para]
+This boundary value problem could originate from the diffusion of a
+decaying substance.
+[para]
+It can be solved with the following fragment:
+[para]
+[example_begin]
+ proc coeffs { x } { return [lb]list $::Diff 0.0 $::decay[rb] }
+ proc force { x } { return 0.0 }
+
+ set Diff 1.0e-2
+ set decay 0.0001
+ set length 100.0
+
+ set y [lb]::math::calculus::boundaryValueSecondOrder \
+ coeffs force {0.0 1.0} [lb]list $length 0.0[rb] 100[rb]
+[example_end]
+
+[vset CATEGORY {math :: calculus}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/calculus.tcl b/tcllib/modules/math/calculus.tcl
new file mode 100755
index 0000000..5667a6c
--- /dev/null
+++ b/tcllib/modules/math/calculus.tcl
@@ -0,0 +1,1645 @@
+# calculus.tcl --
+# Package that implements several basic numerical methods, such
+# as the integration of a one-dimensional function and the
+# solution of a system of first-order differential equations.
+#
+# Copyright (c) 2002, 2003, 2004, 2006 by Arjen Markus.
+# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: calculus.tcl,v 1.15 2008/10/08 03:30:48 andreas_kupries Exp $
+
+package require Tcl 8.4
+package require math::interpolate
+package provide math::calculus 0.8.1
+
+# math::calculus --
+# Namespace for the commands
+
+namespace eval ::math::calculus {
+
+ namespace import ::math::interpolate::neville
+
+ namespace import ::math::expectDouble ::math::expectInteger
+
+ namespace export \
+ integral integralExpr integral2D integral3D \
+ qk15 qk15_detailed \
+ eulerStep heunStep rungeKuttaStep \
+ boundaryValueSecondOrder solveTriDiagonal \
+ newtonRaphson newtonRaphsonParameters
+ namespace export \
+ integral2D_2accurate integral3D_accurate
+
+ namespace export romberg romberg_infinity
+ namespace export romberg_sqrtSingLower romberg_sqrtSingUpper
+ namespace export romberg_powerLawLower romberg_powerLawUpper
+ namespace export romberg_expLower romberg_expUpper
+
+ namespace export regula_falsi
+
+ variable nr_maxiter 20
+ variable nr_tolerance 0.001
+
+}
+
+# integral --
+# Integrate a function over a given interval using the Simpson rule
+#
+# Arguments:
+# begin Start of the interval
+# end End of the interval
+# nosteps Number of steps in which to divide the interval
+# func Name of the function to be integrated (takes one
+# argument)
+# Return value:
+# Computed integral
+#
+proc ::math::calculus::integral { begin end nosteps func } {
+
+ set delta [expr {($end-$begin)/double($nosteps)}]
+ set hdelta [expr {$delta/2.0}]
+ set result 0.0
+ set xval $begin
+ set func_end [uplevel 1 $func $xval]
+ for { set i 1 } { $i <= $nosteps } { incr i } {
+ set func_begin $func_end
+ set func_middle [uplevel 1 $func [expr {$xval+$hdelta}]]
+ set func_end [uplevel 1 $func [expr {$xval+$delta}]]
+ set result [expr {$result+$func_begin+4.0*$func_middle+$func_end}]
+
+ set xval [expr {$begin+double($i)*$delta}]
+ }
+
+ return [expr {$result*$delta/6.0}]
+}
+
+# integralExpr --
+# Integrate an expression with "x" as the integrate according to the
+# Simpson rule
+#
+# Arguments:
+# begin Start of the interval
+# end End of the interval
+# nosteps Number of steps in which to divide the interval
+# expression Expression with "x" as the integrate
+# Return value:
+# Computed integral
+#
+proc ::math::calculus::integralExpr { begin end nosteps expression } {
+
+ set delta [expr {($end-$begin)/double($nosteps)}]
+ set hdelta [expr {$delta/2.0}]
+ set result 0.0
+ set x $begin
+ # FRINK: nocheck
+ set func_end [expr $expression]
+ for { set i 1 } { $i <= $nosteps } { incr i } {
+ set func_begin $func_end
+ set x [expr {$x+$hdelta}]
+ # FRINK: nocheck
+ set func_middle [expr $expression]
+ set x [expr {$x+$hdelta}]
+ # FRINK: nocheck
+ set func_end [expr $expression]
+ set result [expr {$result+$func_begin+4.0*$func_middle+$func_end}]
+
+ set x [expr {$begin+double($i)*$delta}]
+ }
+
+ return [expr {$result*$delta/6.0}]
+}
+
+# integral2D --
+# Integrate a given fucntion of two variables over a block,
+# using bilinear interpolation (for this moment: block function)
+#
+# Arguments:
+# xinterval Start, stop and number of steps of the "x" interval
+# yinterval Start, stop and number of steps of the "y" interval
+# func Function of the two variables to be integrated
+# Return value:
+# Computed integral
+#
+proc ::math::calculus::integral2D { xinterval yinterval func } {
+
+ foreach { xbegin xend xnumber } $xinterval { break }
+ foreach { ybegin yend ynumber } $yinterval { break }
+
+ set xdelta [expr {($xend-$xbegin)/double($xnumber)}]
+ set ydelta [expr {($yend-$ybegin)/double($ynumber)}]
+ set hxdelta [expr {$xdelta/2.0}]
+ set hydelta [expr {$ydelta/2.0}]
+ set result 0.0
+ set dxdy [expr {$xdelta*$ydelta}]
+ for { set j 0 } { $j < $ynumber } { incr j } {
+ set y [expr {$ybegin+$hydelta+double($j)*$ydelta}]
+ for { set i 0 } { $i < $xnumber } { incr i } {
+ set x [expr {$xbegin+$hxdelta+double($i)*$xdelta}]
+ set func_value [uplevel 1 $func $x $y]
+ set result [expr {$result+$func_value}]
+ }
+ }
+
+ return [expr {$result*$dxdy}]
+}
+
+# integral3D --
+# Integrate a given fucntion of two variables over a block,
+# using trilinear interpolation (for this moment: block function)
+#
+# Arguments:
+# xinterval Start, stop and number of steps of the "x" interval
+# yinterval Start, stop and number of steps of the "y" interval
+# zinterval Start, stop and number of steps of the "z" interval
+# func Function of the three variables to be integrated
+# Return value:
+# Computed integral
+#
+proc ::math::calculus::integral3D { xinterval yinterval zinterval func } {
+
+ foreach { xbegin xend xnumber } $xinterval { break }
+ foreach { ybegin yend ynumber } $yinterval { break }
+ foreach { zbegin zend znumber } $zinterval { break }
+
+ set xdelta [expr {($xend-$xbegin)/double($xnumber)}]
+ set ydelta [expr {($yend-$ybegin)/double($ynumber)}]
+ set zdelta [expr {($zend-$zbegin)/double($znumber)}]
+ set hxdelta [expr {$xdelta/2.0}]
+ set hydelta [expr {$ydelta/2.0}]
+ set hzdelta [expr {$zdelta/2.0}]
+ set result 0.0
+ set dxdydz [expr {$xdelta*$ydelta*$zdelta}]
+ for { set k 0 } { $k < $znumber } { incr k } {
+ set z [expr {$zbegin+$hzdelta+double($k)*$zdelta}]
+ for { set j 0 } { $j < $ynumber } { incr j } {
+ set y [expr {$ybegin+$hydelta+double($j)*$ydelta}]
+ for { set i 0 } { $i < $xnumber } { incr i } {
+ set x [expr {$xbegin+$hxdelta+double($i)*$xdelta}]
+ set func_value [uplevel 1 $func $x $y $z]
+ set result [expr {$result+$func_value}]
+ }
+ }
+ }
+
+ return [expr {$result*$dxdydz}]
+}
+
+# integral2D_accurate --
+# Integrate a given function of two variables over a block,
+# using a four-point quadrature formula
+#
+# Arguments:
+# xinterval Start, stop and number of steps of the "x" interval
+# yinterval Start, stop and number of steps of the "y" interval
+# func Function of the two variables to be integrated
+# Return value:
+# Computed integral
+#
+proc ::math::calculus::integral2D_accurate { xinterval yinterval func } {
+
+ foreach { xbegin xend xnumber } $xinterval { break }
+ foreach { ybegin yend ynumber } $yinterval { break }
+
+ set alpha [expr {sqrt(2.0/3.0)}]
+ set minalpha [expr {-$alpha}]
+ set dpoints [list $alpha 0.0 $minalpha 0.0 0.0 $alpha 0.0 $minalpha]
+
+ set xdelta [expr {($xend-$xbegin)/double($xnumber)}]
+ set ydelta [expr {($yend-$ybegin)/double($ynumber)}]
+ set hxdelta [expr {$xdelta/2.0}]
+ set hydelta [expr {$ydelta/2.0}]
+ set result 0.0
+ set dxdy [expr {0.25*$xdelta*$ydelta}]
+
+ for { set j 0 } { $j < $ynumber } { incr j } {
+ set y [expr {$ybegin+$hydelta+double($j)*$ydelta}]
+ for { set i 0 } { $i < $xnumber } { incr i } {
+ set x [expr {$xbegin+$hxdelta+double($i)*$xdelta}]
+
+ foreach {dx dy} $dpoints {
+ set x1 [expr {$x+$dx}]
+ set y1 [expr {$y+$dy}]
+ set func_value [uplevel 1 $func $x1 $y1]
+ set result [expr {$result+$func_value}]
+ }
+ }
+ }
+
+ return [expr {$result*$dxdy}]
+}
+
+# integral3D_accurate --
+# Integrate a given function of three variables over a block,
+# using an 8-point quadrature formula
+#
+# Arguments:
+# xinterval Start, stop and number of steps of the "x" interval
+# yinterval Start, stop and number of steps of the "y" interval
+# zinterval Start, stop and number of steps of the "z" interval
+# func Function of the three variables to be integrated
+# Return value:
+# Computed integral
+#
+proc ::math::calculus::integral3D_accurate { xinterval yinterval zinterval func } {
+
+ foreach { xbegin xend xnumber } $xinterval { break }
+ foreach { ybegin yend ynumber } $yinterval { break }
+ foreach { zbegin zend znumber } $zinterval { break }
+
+ set alpha [expr {sqrt(1.0/3.0)}]
+ set minalpha [expr {-$alpha}]
+
+ set dpoints [list $alpha $alpha $alpha \
+ $alpha $alpha $minalpha \
+ $alpha $minalpha $alpha \
+ $alpha $minalpha $minalpha \
+ $minalpha $alpha $alpha \
+ $minalpha $alpha $minalpha \
+ $minalpha $minalpha $alpha \
+ $minalpha $minalpha $minalpha ]
+
+ set xdelta [expr {($xend-$xbegin)/double($xnumber)}]
+ set ydelta [expr {($yend-$ybegin)/double($ynumber)}]
+ set zdelta [expr {($zend-$zbegin)/double($znumber)}]
+ set hxdelta [expr {$xdelta/2.0}]
+ set hydelta [expr {$ydelta/2.0}]
+ set hzdelta [expr {$zdelta/2.0}]
+ set result 0.0
+ set dxdydz [expr {0.125*$xdelta*$ydelta*$zdelta}]
+
+ for { set k 0 } { $k < $znumber } { incr k } {
+ set z [expr {$zbegin+$hzdelta+double($k)*$zdelta}]
+ for { set j 0 } { $j < $ynumber } { incr j } {
+ set y [expr {$ybegin+$hydelta+double($j)*$ydelta}]
+ for { set i 0 } { $i < $xnumber } { incr i } {
+ set x [expr {$xbegin+$hxdelta+double($i)*$xdelta}]
+
+ foreach {dx dy dz} $dpoints {
+ set x1 [expr {$x+$dx}]
+ set y1 [expr {$y+$dy}]
+ set z1 [expr {$z+$dz}]
+ set func_value [uplevel 1 $func $x1 $y1 $z1]
+ set result [expr {$result+$func_value}]
+ }
+ }
+ }
+ }
+
+ return [expr {$result*$dxdydz}]
+}
+
+# eulerStep --
+# Integrate a system of ordinary differential equations of the type
+# x' = f(x,t), where x is a vector of quantities. Integration is
+# done over a single step according to Euler's method.
+#
+# Arguments:
+# t Start value of independent variable (time for instance)
+# tstep Step size of interval
+# xvec Vector of dependent values at the start
+# func Function taking the arguments t and xvec to return
+# the derivative of each dependent variable.
+# Return value:
+# List of values at the end of the step
+#
+proc ::math::calculus::eulerStep { t tstep xvec func } {
+
+ set xderiv [uplevel 1 $func $t [list $xvec]]
+ set result {}
+ foreach xv $xvec dx $xderiv {
+ set xnew [expr {$xv+$tstep*$dx}]
+ lappend result $xnew
+ }
+
+ return $result
+}
+
+# heunStep --
+# Integrate a system of ordinary differential equations of the type
+# x' = f(x,t), where x is a vector of quantities. Integration is
+# done over a single step according to Heun's method.
+#
+# Arguments:
+# t Start value of independent variable (time for instance)
+# tstep Step size of interval
+# xvec Vector of dependent values at the start
+# func Function taking the arguments t and xvec to return
+# the derivative of each dependent variable.
+# Return value:
+# List of values at the end of the step
+#
+proc ::math::calculus::heunStep { t tstep xvec func } {
+
+ #
+ # Predictor step
+ #
+ set funcq [uplevel 1 namespace which -command $func]
+ set xpred [eulerStep $t $tstep $xvec $funcq]
+
+ #
+ # Corrector step
+ #
+ set tcorr [expr {$t+$tstep}]
+ set xcorr [eulerStep $tcorr $tstep $xpred $funcq]
+
+ set result {}
+ foreach xv $xvec xc $xcorr {
+ set xnew [expr {0.5*($xv+$xc)}]
+ lappend result $xnew
+ }
+
+ return $result
+}
+
+# rungeKuttaStep --
+# Integrate a system of ordinary differential equations of the type
+# x' = f(x,t), where x is a vector of quantities. Integration is
+# done over a single step according to Runge-Kutta 4th order.
+#
+# Arguments:
+# t Start value of independent variable (time for instance)
+# tstep Step size of interval
+# xvec Vector of dependent values at the start
+# func Function taking the arguments t and xvec to return
+# the derivative of each dependent variable.
+# Return value:
+# List of values at the end of the step
+#
+proc ::math::calculus::rungeKuttaStep { t tstep xvec func } {
+
+ set funcq [uplevel 1 namespace which -command $func]
+
+ #
+ # Four steps:
+ # - k1 = tstep*func(t,x0)
+ # - k2 = tstep*func(t+0.5*tstep,x0+0.5*k1)
+ # - k3 = tstep*func(t+0.5*tstep,x0+0.5*k2)
+ # - k4 = tstep*func(t+ tstep,x0+ k3)
+ # - x1 = x0 + (k1+2*k2+2*k3+k4)/6
+ #
+ set tstep2 [expr {$tstep/2.0}]
+ set tstep6 [expr {$tstep/6.0}]
+
+ set xk1 [$funcq $t $xvec]
+ set xvec2 {}
+ foreach x1 $xvec xv $xk1 {
+ lappend xvec2 [expr {$x1+$tstep2*$xv}]
+ }
+ set xk2 [$funcq [expr {$t+$tstep2}] $xvec2]
+
+ set xvec3 {}
+ foreach x1 $xvec xv $xk2 {
+ lappend xvec3 [expr {$x1+$tstep2*$xv}]
+ }
+ set xk3 [$funcq [expr {$t+$tstep2}] $xvec3]
+
+ set xvec4 {}
+ foreach x1 $xvec xv $xk3 {
+ lappend xvec4 [expr {$x1+$tstep*$xv}]
+ }
+ set xk4 [$funcq [expr {$t+$tstep}] $xvec4]
+
+ set result {}
+ foreach x0 $xvec k1 $xk1 k2 $xk2 k3 $xk3 k4 $xk4 {
+ set dx [expr {$k1+2.0*$k2+2.0*$k3+$k4}]
+ lappend result [expr {$x0+$dx*$tstep6}]
+ }
+
+ return $result
+}
+
+# boundaryValueSecondOrder --
+# Integrate a second-order differential equation and solve for
+# given boundary values.
+#
+# The equation is (see the documentation):
+# d dy d
+# -- A(x) -- + -- B(x) y + C(x) y = D(x)
+# dx dx dx
+#
+# The procedure uses finite differences and tridiagonal matrices to
+# solve the equation. The boundary values are put in the matrix
+# directly.
+#
+# Arguments:
+# coeff_func Name of triple-valued function for coefficients A, B, C
+# force_func Name of the function providing the force term D(x)
+# leftbnd Left boundary condition (list of: xvalue, boundary
+# value or keyword zero-flux, zero-derivative)
+# rightbnd Right boundary condition (ditto)
+# nostep Number of steps
+# Return value:
+# List of x-values and calculated values (x1, y1, x2, y2, ...)
+#
+proc ::math::calculus::boundaryValueSecondOrder {
+ coeff_func force_func leftbnd rightbnd nostep } {
+
+ set coeffq [uplevel 1 namespace which -command $coeff_func]
+ set forceq [uplevel 1 namespace which -command $force_func]
+
+ if { [llength $leftbnd] != 2 || [llength $rightbnd] != 2 } {
+ error "Boundary condition(s) incorrect"
+ }
+ if { $nostep < 1 } {
+ error "Number of steps must be larger/equal 1"
+ }
+
+ #
+ # Set up the matrix, as three different lists and the
+ # righthand side as the fourth
+ #
+ set xleft [lindex $leftbnd 0]
+ set xright [lindex $rightbnd 0]
+ set xstep [expr {($xright-$xleft)/double($nostep)}]
+
+ set acoeff {}
+ set bcoeff {}
+ set ccoeff {}
+ set dvalue {}
+
+ set x $xleft
+ foreach {A B C} [$coeffq $x] { break }
+
+ set A1 [expr {$A/$xstep-0.5*$B}]
+ set B1 [expr {$A/$xstep+0.5*$B+0.5*$C*$xstep}]
+ set C1 0.0
+
+ for { set i 1 } { $i <= $nostep } { incr i } {
+ set x [expr {$xleft+double($i)*$xstep}]
+ if { [expr {abs($x)-0.5*abs($xstep)}] < 0.0 } {
+ set x 0.0
+ }
+ foreach {A B C} [$coeffq $x] { break }
+
+ set A2 0.0
+ set B2 [expr {$A/$xstep-0.5*$B+0.5*$C*$xstep}]
+ set C2 [expr {$A/$xstep+0.5*$B}]
+ lappend acoeff [expr {$A1+$A2}]
+ lappend bcoeff [expr {-$B1-$B2}]
+ lappend ccoeff [expr {$C1+$C2}]
+ set A1 [expr {$A/$xstep-0.5*$B}]
+ set B1 [expr {$A/$xstep+0.5*$B+0.5*$C*$xstep}]
+ set C1 0.0
+ }
+ set xvec {}
+ for { set i 0 } { $i < $nostep } { incr i } {
+ set x [expr {$xleft+(0.5+double($i))*$xstep}]
+ if { [expr {abs($x)-0.25*abs($xstep)}] < 0.0 } {
+ set x 0.0
+ }
+ lappend xvec $x
+ lappend dvalue [expr {$xstep*[$forceq $x]}]
+ }
+
+ #
+ # Substitute the boundary values
+ #
+ set A [lindex $acoeff 0]
+ set D [lindex $dvalue 0]
+ set D1 [expr {$D-$A*[lindex $leftbnd 1]}]
+ set C [lindex $ccoeff end]
+ set D [lindex $dvalue end]
+ set D2 [expr {$D-$C*[lindex $rightbnd 1]}]
+ set dvalue [concat $D1 [lrange $dvalue 1 end-1] $D2]
+
+ set yvec [solveTriDiagonal [lrange $acoeff 1 end] $bcoeff [lrange $ccoeff 0 end-1] $dvalue]
+
+ foreach x $xvec y $yvec {
+ lappend result $x $y
+ }
+ return $result
+}
+
+# solveTriDiagonal --
+# Solve a system of equations Ax = b where A is a tridiagonal matrix
+#
+# Arguments:
+# acoeff Values on lower diagonal
+# bcoeff Values on main diagonal
+# ccoeff Values on upper diagonal
+# dvalue Values on righthand side
+# Return value:
+# List of values forming the solution
+#
+proc ::math::calculus::solveTriDiagonal { acoeff bcoeff ccoeff dvalue } {
+
+ set nostep [llength $acoeff]
+ #
+ # First step: Gauss-elimination
+ #
+ set B [lindex $bcoeff 0]
+ set C [lindex $ccoeff 0]
+ set D [lindex $dvalue 0]
+ set acoeff [concat 0.0 $acoeff]
+ set bcoeff2 [list $B]
+ set dvalue2 [list $D]
+ for { set i 1 } { $i <= $nostep } { incr i } {
+ set A2 [lindex $acoeff $i]
+ set B2 [lindex $bcoeff $i]
+ set D2 [lindex $dvalue $i]
+ set ratab [expr {$A2/double($B)}]
+ set B2 [expr {$B2-$ratab*$C}]
+ set D2 [expr {$D2-$ratab*$D}]
+ lappend bcoeff2 $B2
+ lappend dvalue2 $D2
+ set B $B2
+ set C [lindex $ccoeff $i]
+ set D $D2
+ }
+
+ #
+ # Second step: substitution
+ #
+ set yvec {}
+ set B [lindex $bcoeff2 end]
+ set D [lindex $dvalue2 end]
+ set y [expr {$D/$B}]
+ for { set i [expr {$nostep-1}] } { $i >= 0 } { incr i -1 } {
+ set yvec [concat $y $yvec]
+ set B [lindex $bcoeff2 $i]
+ set C [lindex $ccoeff $i]
+ set D [lindex $dvalue2 $i]
+ set y [expr {($D-$C*$y)/$B}]
+ }
+ set yvec [concat $y $yvec]
+
+ return $yvec
+}
+
+# newtonRaphson --
+# Determine the root of an equation via the Newton-Raphson method
+#
+# Arguments:
+# func Function (proc) in x
+# deriv Derivative (proc) of func w.r.t. x
+# initval Initial value for x
+# Return value:
+# Estimate of root
+#
+proc ::math::calculus::newtonRaphson { func deriv initval } {
+ variable nr_maxiter
+ variable nr_tolerance
+
+ set funcq [uplevel 1 namespace which -command $func]
+ set derivq [uplevel 1 namespace which -command $deriv]
+
+ set value $initval
+ set diff [expr {10.0*$nr_tolerance}]
+
+ for { set i 0 } { $i < $nr_maxiter } { incr i } {
+ if { $diff < $nr_tolerance } {
+ break
+ }
+
+ set newval [expr {$value-[$funcq $value]/[$derivq $value]}]
+ if { $value != 0.0 } {
+ set diff [expr {abs($newval-$value)/abs($value)}]
+ } else {
+ set diff [expr {abs($newval-$value)}]
+ }
+ set value $newval
+ }
+
+ return $newval
+}
+
+# newtonRaphsonParameters --
+# Set the parameters for the Newton-Raphson method
+#
+# Arguments:
+# maxiter Maximum number of iterations
+# tolerance Relative precisiion of the result
+# Return value:
+# None
+#
+proc ::math::calculus::newtonRaphsonParameters { maxiter tolerance } {
+ variable nr_maxiter
+ variable nr_tolerance
+
+ if { $maxiter > 0 } {
+ set nr_maxiter $maxiter
+ }
+ if { $tolerance > 0 } {
+ set nr_tolerance $tolerance
+ }
+}
+
+#----------------------------------------------------------------------
+#
+# midpoint --
+#
+# Perform one set of steps in evaluating an integral using the
+# midpoint method.
+#
+# Usage:
+# midpoint f a b s ?n?
+#
+# Parameters:
+# f - function to integrate
+# a - One limit of integration
+# b - Other limit of integration. a and b need not be in ascending
+# order.
+# s - Value returned from a previous call to midpoint (see below)
+# n - Step number (see below)
+#
+# Results:
+# Returns an estimate of the integral obtained by dividing the
+# interval into 3**n equal intervals and using the midpoint rule.
+#
+# Side effects:
+# f is evaluated 2*3**(n-1) times and may have side effects.
+#
+# The 'midpoint' procedure is designed for successive approximations.
+# It should be called initially with n==0. On this initial call, s
+# is ignored. The function is evaluated at the midpoint of the interval, and
+# the value is multiplied by the width of the interval to give the
+# coarsest possible estimate of the integral.
+#
+# On each iteration except the first, n should be incremented by one,
+# and the previous value returned from [midpoint] should be supplied
+# as 's'. The function will be evaluated at additional points
+# to give a total of 3**n equally spaced points, and the estimate
+# of the integral will be updated and returned
+#
+# Under normal circumstances, user code will not call this function
+# directly. Instead, it will use ::math::calculus::romberg to
+# do error control and extrapolation to a zero step size.
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::midpoint { f a b { n 0 } { s 0. } } {
+
+ if { $n == 0 } {
+
+ # First iteration. Simply evaluate the function at the midpoint
+ # of the interval.
+
+ set cmd $f; lappend cmd [expr { 0.5 * ( $a + $b ) }]; set v [eval $cmd]
+ return [expr { ( $b - $a ) * $v }]
+
+ } else {
+
+ # Subsequent iterations. We've divided the interval into
+ # $it subintervals. Evaluate the function at the 1/3 and
+ # 2/3 points of each subinterval. Then update the estimate
+ # of the integral that we produced on the last step with
+ # the new sum.
+
+ set it [expr { pow( 3, $n-1 ) }]
+ set h [expr { ( $b - $a ) / ( 3. * $it ) }]
+ set h2 [expr { $h + $h }]
+ set x [expr { $a + 0.5 * $h }]
+ set sum 0
+ for { set j 0 } { $j < $it } { incr j } {
+ set cmd $f; lappend cmd $x; set y [eval $cmd]
+ set sum [expr { $sum + $y }]
+ set x [expr { $x + $h2 }]
+ set cmd $f; lappend cmd $x; set y [eval $cmd]
+ set sum [expr { $sum + $y }]
+ set x [expr { $x + $h}]
+ }
+ return [expr { ( $s + ( $b - $a ) * $sum / $it ) / 3. }]
+
+ }
+}
+
+#----------------------------------------------------------------------
+#
+# romberg --
+#
+# Compute the integral of a function over an interval using
+# Romberg's method.
+#
+# Usage:
+# romberg f a b ?-option value?...
+#
+# Parameters:
+# f - Function to integrate. Must be a single Tcl command,
+# to which will be appended the abscissa at which the function
+# should be evaluated. f should be analytic over the
+# region of integration, but may have a removable singularity
+# at either endpoint.
+# a - One bound of the interval
+# b - The other bound of the interval. a and b need not be in
+# ascending order.
+#
+# Options:
+# -abserror ABSERROR
+# Requests that the integration be performed to make
+# the estimated absolute error of the integral less than
+# the given value. Default is 1.e-10.
+# -relerror RELERROR
+# Requests that the integration be performed to make
+# the estimated absolute error of the integral less than
+# the given value. Default is 1.e-6.
+# -degree N
+# Specifies the degree of the polynomial that will be
+# used to extrapolate to a zero step size. -degree 0
+# requests integration with the midpoint rule; -degree 1
+# is equivalent to Simpson's 3/8 rule; higher degrees
+# are difficult to describe but (within reason) give
+# faster convergence for smooth functions. Default is
+# -degree 4.
+# -maxiter N
+# Specifies the maximum number of triplings of the
+# number of steps to take in integration. At most
+# 3**N function evaluations will be performed in
+# integrating with -maxiter N. The integration
+# will terminate at that time, even if the result
+# satisfies neither the -relerror nor -abserror tests.
+#
+# Results:
+# Returns a two-element list. The first element is the estimated
+# value of the integral; the second is the estimated absolute
+# error of the value.
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::romberg { f a b args } {
+
+ # Replace f with a context-independent version
+
+ set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]]
+
+ # Assign default parameters
+
+ array set params {
+ -abserror 1.0e-10
+ -degree 4
+ -relerror 1.0e-6
+ -maxiter 14
+ }
+
+ # Extract parameters
+
+ if { ( [llength $args] % 2 ) != 0 } {
+ return -code error -errorcode [list romberg wrongNumArgs] \
+ "wrong \# args, should be\
+ \"[lreplace [info level 0] 1 end \
+ f x1 x2 ?-option value?...]\""
+ }
+ foreach { key value } $args {
+ if { ![info exists params($key)] } {
+ return -code error -errorcode [list romberg badoption $key] \
+ "unknown option \"$key\",\
+ should be -abserror, -degree, -relerror, or -maxiter"
+ }
+ set params($key) $value
+ }
+
+ # Check params
+
+ if { ![string is double -strict $a] } {
+ return -code error [expectDouble $a]
+ }
+ if { ![string is double -strict $b] } {
+ return -code error [expectDouble $b]
+ }
+ if { ![string is double -strict $params(-abserror)] } {
+ return -code error [expectDouble $params(-abserror)]
+ }
+ if { ![string is integer -strict $params(-degree)] } {
+ return -code error [expectInteger $params(-degree)]
+ }
+ if { ![string is integer -strict $params(-maxiter)] } {
+ return -code error [expectInteger $params(-maxiter)]
+ }
+ if { ![string is double -strict $params(-relerror)] } {
+ return -code error [expectDouble $params(-relerror)]
+ }
+ foreach key {-abserror -degree -maxiter -relerror} {
+ if { $params($key) <= 0 } {
+ return -code error -errorcode [list romberg notPositive $key] \
+ "$key must be positive"
+ }
+ }
+ if { $params(-maxiter) <= $params(-degree) } {
+ return -code error -errorcode [list romberg tooFewIter] \
+ "-maxiter must be greater than -degree"
+ }
+
+ # Create lists of step size and sum with the given number of steps.
+
+ set x [list]
+ set y [list]
+ set s 0; # Current best estimate of integral
+ set indx end-$params(-degree)
+ set pow3 1.; # Current step size (times b-a)
+
+ # Perform successive integrations, tripling the number of steps each time
+
+ for { set i 0 } { $i < $params(-maxiter) } { incr i } {
+ set s [midpoint $f $a $b $i $s]
+ lappend x $pow3
+ lappend y $s
+ set pow3 [expr { $pow3 / 9. }]
+
+ # Once $degree steps have been done, start Richardson extrapolation
+ # to a zero step size.
+
+ if { $i >= $params(-degree) } {
+ set x [lrange $x $indx end]
+ set y [lrange $y $indx end]
+ foreach {estimate err} [neville $x $y 0.] break
+ if { $err < $params(-abserror)
+ || $err < $params(-relerror) * abs($estimate) } {
+ return [list $estimate $err]
+ }
+ }
+ }
+
+ # If -maxiter iterations have been done, give up, and return
+ # with the current error estimate.
+
+ return [list $estimate $err]
+}
+
+#----------------------------------------------------------------------
+#
+# u_infinity --
+# Change of variable for integrating over a half-infinite
+# interval
+#
+# Parameters:
+# f - Function being integrated
+# u - 1/x, where x is the abscissa where f is to be evaluated
+#
+# Results:
+# Returns f(1/u)/(u**2)
+#
+# Side effects:
+# Whatever f does.
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::u_infinity { f u } {
+ set cmd $f
+ lappend cmd [expr { 1.0 / $u }]
+ set y [eval $cmd]
+ return [expr { $y / ( $u * $u ) }]
+}
+
+#----------------------------------------------------------------------
+#
+# romberg_infinity --
+# Evaluate a function on a half-open interval
+#
+# Usage:
+# Same as 'romberg'
+#
+# The 'romberg_infinity' procedure performs Romberg integration on
+# an interval [a,b] where an infinite a or b may be represented by
+# a large number (e.g. 1.e30). It operates by a change of variable;
+# instead of integrating f(x) from a to b, it makes a change
+# of variable u = 1/x, and integrates from 1/b to 1/a f(1/u)/u**2 du.
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::romberg_infinity { f a b args } {
+ if { ![string is double -strict $a] } {
+ return -code error [expectDouble $a]
+ }
+ if { ![string is double -strict $b] } {
+ return -code error [expectDouble $b]
+ }
+ if { $a * $b <= 0. } {
+ return -code error -errorcode {romberg_infinity cross-axis} \
+ "limits of integration have opposite sign"
+ }
+ set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]]
+ set f [list u_infinity $f]
+ return [eval [linsert $args 0 \
+ romberg $f [expr { 1.0 / $b }] [expr { 1.0 / $a }]]]
+}
+
+#----------------------------------------------------------------------
+#
+# u_sqrtSingLower --
+# Change of variable for integrating over an interval with
+# an inverse square root singularity at the lower bound.
+#
+# Parameters:
+# f - Function being integrated
+# a - Lower bound
+# u - sqrt(x-a), where x is the abscissa where f is to be evaluated
+#
+# Results:
+# Returns 2 * u * f( a + u**2 )
+#
+# Side effects:
+# Whatever f does.
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::u_sqrtSingLower { f a u } {
+ set cmd $f
+ lappend cmd [expr { $a + $u * $u }]
+ set y [eval $cmd]
+ return [expr { 2. * $u * $y }]
+}
+
+#----------------------------------------------------------------------
+#
+# u_sqrtSingUpper --
+# Change of variable for integrating over an interval with
+# an inverse square root singularity at the upper bound.
+#
+# Parameters:
+# f - Function being integrated
+# b - Upper bound
+# u - sqrt(b-x), where x is the abscissa where f is to be evaluated
+#
+# Results:
+# Returns 2 * u * f( b - u**2 )
+#
+# Side effects:
+# Whatever f does.
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::u_sqrtSingUpper { f b u } {
+ set cmd $f
+ lappend cmd [expr { $b - $u * $u }]
+ set y [eval $cmd]
+ return [expr { 2. * $u * $y }]
+}
+
+#----------------------------------------------------------------------
+#
+# math::calculus::romberg_sqrtSingLower --
+# Integrate a function with an inverse square root singularity
+# at the lower bound
+#
+# Usage:
+# Same as 'romberg'
+#
+# The 'romberg_sqrtSingLower' procedure is a wrapper for 'romberg'
+# for integrating a function with an inverse square root singularity
+# at the lower bound of the interval. It works by making the change
+# of variable u = sqrt( x-a ).
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::romberg_sqrtSingLower { f a b args } {
+ if { ![string is double -strict $a] } {
+ return -code error [expectDouble $a]
+ }
+ if { ![string is double -strict $b] } {
+ return -code error [expectDouble $b]
+ }
+ if { $a >= $b } {
+ return -code error "limits of integration out of order"
+ }
+ set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]]
+ set f [list u_sqrtSingLower $f $a]
+ return [eval [linsert $args 0 \
+ romberg $f 0 [expr { sqrt( $b - $a ) }]]]
+}
+
+#----------------------------------------------------------------------
+#
+# math::calculus::romberg_sqrtSingUpper --
+# Integrate a function with an inverse square root singularity
+# at the upper bound
+#
+# Usage:
+# Same as 'romberg'
+#
+# The 'romberg_sqrtSingUpper' procedure is a wrapper for 'romberg'
+# for integrating a function with an inverse square root singularity
+# at the upper bound of the interval. It works by making the change
+# of variable u = sqrt( b-x ).
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::romberg_sqrtSingUpper { f a b args } {
+ if { ![string is double -strict $a] } {
+ return -code error [expectDouble $a]
+ }
+ if { ![string is double -strict $b] } {
+ return -code error [expectDouble $b]
+ }
+ if { $a >= $b } {
+ return -code error "limits of integration out of order"
+ }
+ set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]]
+ set f [list u_sqrtSingUpper $f $b]
+ return [eval [linsert $args 0 \
+ romberg $f 0. [expr { sqrt( $b - $a ) }]]]
+}
+
+#----------------------------------------------------------------------
+#
+# u_powerLawLower --
+# Change of variable for integrating over an interval with
+# an integrable power law singularity at the lower bound.
+#
+# Parameters:
+# f - Function being integrated
+# gammaover1mgamma - gamma / (1 - gamma), where gamma is the power
+# oneover1mgamma - 1 / (1 - gamma), where gamma is the power
+# a - Lower limit of integration
+# u - Changed variable u == (x-a)**(1-gamma)
+#
+# Results:
+# Returns u**(1/1-gamma) * f(a + u**(1/1-gamma) ).
+#
+# Side effects:
+# Whatever f does.
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::u_powerLawLower { f gammaover1mgamma oneover1mgamma
+ a u } {
+ set cmd $f
+ lappend cmd [expr { $a + pow( $u, $oneover1mgamma ) }]
+ set y [eval $cmd]
+ return [expr { $y * pow( $u, $gammaover1mgamma ) }]
+}
+
+#----------------------------------------------------------------------
+#
+# math::calculus::romberg_powerLawLower --
+# Integrate a function with an integrable power law singularity
+# at the lower bound
+#
+# Usage:
+# romberg_powerLawLower gamma f a b ?-option value...?
+#
+# Parameters:
+# gamma - Power (0<gamma<1) of the singularity
+# f - Function to integrate. Must be a single Tcl command,
+# to which will be appended the abscissa at which the function
+# should be evaluated. f is expected to have an integrable
+# power law singularity at the lower endpoint; that is, the
+# integrand is expected to diverge as (x-a)**gamma.
+# a - One bound of the interval
+# b - The other bound of the interval. a and b need not be in
+# ascending order.
+#
+# Options:
+# -abserror ABSERROR
+# Requests that the integration be performed to make
+# the estimated absolute error of the integral less than
+# the given value. Default is 1.e-10.
+# -relerror RELERROR
+# Requests that the integration be performed to make
+# the estimated absolute error of the integral less than
+# the given value. Default is 1.e-6.
+# -degree N
+# Specifies the degree of the polynomial that will be
+# used to extrapolate to a zero step size. -degree 0
+# requests integration with the midpoint rule; -degree 1
+# is equivalent to Simpson's 3/8 rule; higher degrees
+# are difficult to describe but (within reason) give
+# faster convergence for smooth functions. Default is
+# -degree 4.
+# -maxiter N
+# Specifies the maximum number of triplings of the
+# number of steps to take in integration. At most
+# 3**N function evaluations will be performed in
+# integrating with -maxiter N. The integration
+# will terminate at that time, even if the result
+# satisfies neither the -relerror nor -abserror tests.
+#
+# Results:
+# Returns a two-element list. The first element is the estimated
+# value of the integral; the second is the estimated absolute
+# error of the value.
+#
+# The 'romberg_sqrtSingLower' procedure is a wrapper for 'romberg'
+# for integrating a function with an integrable power law singularity
+# at the lower bound of the interval. It works by making the change
+# of variable u = (x-a)**(1-gamma).
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::romberg_powerLawLower { gamma f a b args } {
+ if { ![string is double -strict $gamma] } {
+ return -code error [expectDouble $gamma]
+ }
+ if { $gamma <= 0.0 || $gamma >= 1.0 } {
+ return -code error -errorcode [list romberg gammaTooBig] \
+ "gamma must lie in the interval (0,1)"
+ }
+ if { ![string is double -strict $a] } {
+ return -code error [expectDouble $a]
+ }
+ if { ![string is double -strict $b] } {
+ return -code error [expectDouble $b]
+ }
+ if { $a >= $b } {
+ return -code error "limits of integration out of order"
+ }
+ set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]]
+ set onemgamma [expr { 1. - $gamma }]
+ set f [list u_powerLawLower $f \
+ [expr { $gamma / $onemgamma }] \
+ [expr { 1 / $onemgamma }] \
+ $a]
+
+ set limit [expr { pow( $b - $a, $onemgamma ) }]
+ set result {}
+ foreach v [eval [linsert $args 0 romberg $f 0 $limit]] {
+ lappend result [expr { $v / $onemgamma }]
+ }
+ return $result
+
+}
+
+#----------------------------------------------------------------------
+#
+# u_powerLawLower --
+# Change of variable for integrating over an interval with
+# an integrable power law singularity at the upper bound.
+#
+# Parameters:
+# f - Function being integrated
+# gammaover1mgamma - gamma / (1 - gamma), where gamma is the power
+# oneover1mgamma - 1 / (1 - gamma), where gamma is the power
+# b - Upper limit of integration
+# u - Changed variable u == (b-x)**(1-gamma)
+#
+# Results:
+# Returns u**(1/1-gamma) * f(b-u**(1/1-gamma) ).
+#
+# Side effects:
+# Whatever f does.
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::u_powerLawUpper { f gammaover1mgamma oneover1mgamma
+ b u } {
+ set cmd $f
+ lappend cmd [expr { $b - pow( $u, $oneover1mgamma ) }]
+ set y [eval $cmd]
+ return [expr { $y * pow( $u, $gammaover1mgamma ) }]
+}
+
+#----------------------------------------------------------------------
+#
+# math::calculus::romberg_powerLawUpper --
+# Integrate a function with an integrable power law singularity
+# at the upper bound
+#
+# Usage:
+# romberg_powerLawLower gamma f a b ?-option value...?
+#
+# Parameters:
+# gamma - Power (0<gamma<1) of the singularity
+# f - Function to integrate. Must be a single Tcl command,
+# to which will be appended the abscissa at which the function
+# should be evaluated. f is expected to have an integrable
+# power law singularity at the upper endpoint; that is, the
+# integrand is expected to diverge as (b-x)**gamma.
+# a - One bound of the interval
+# b - The other bound of the interval. a and b need not be in
+# ascending order.
+#
+# Options:
+# -abserror ABSERROR
+# Requests that the integration be performed to make
+# the estimated absolute error of the integral less than
+# the given value. Default is 1.e-10.
+# -relerror RELERROR
+# Requests that the integration be performed to make
+# the estimated absolute error of the integral less than
+# the given value. Default is 1.e-6.
+# -degree N
+# Specifies the degree of the polynomial that will be
+# used to extrapolate to a zero step size. -degree 0
+# requests integration with the midpoint rule; -degree 1
+# is equivalent to Simpson's 3/8 rule; higher degrees
+# are difficult to describe but (within reason) give
+# faster convergence for smooth functions. Default is
+# -degree 4.
+# -maxiter N
+# Specifies the maximum number of triplings of the
+# number of steps to take in integration. At most
+# 3**N function evaluations will be performed in
+# integrating with -maxiter N. The integration
+# will terminate at that time, even if the result
+# satisfies neither the -relerror nor -abserror tests.
+#
+# Results:
+# Returns a two-element list. The first element is the estimated
+# value of the integral; the second is the estimated absolute
+# error of the value.
+#
+# The 'romberg_PowerLawUpper' procedure is a wrapper for 'romberg'
+# for integrating a function with an integrable power law singularity
+# at the upper bound of the interval. It works by making the change
+# of variable u = (b-x)**(1-gamma).
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::romberg_powerLawUpper { gamma f a b args } {
+ if { ![string is double -strict $gamma] } {
+ return -code error [expectDouble $gamma]
+ }
+ if { $gamma <= 0.0 || $gamma >= 1.0 } {
+ return -code error -errorcode [list romberg gammaTooBig] \
+ "gamma must lie in the interval (0,1)"
+ }
+ if { ![string is double -strict $a] } {
+ return -code error [expectDouble $a]
+ }
+ if { ![string is double -strict $b] } {
+ return -code error [expectDouble $b]
+ }
+ if { $a >= $b } {
+ return -code error "limits of integration out of order"
+ }
+ set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]]
+ set onemgamma [expr { 1. - $gamma }]
+ set f [list u_powerLawUpper $f \
+ [expr { $gamma / $onemgamma }] \
+ [expr { 1. / $onemgamma }] \
+ $b]
+
+ set limit [expr { pow( $b - $a, $onemgamma ) }]
+ set result {}
+ foreach v [eval [linsert $args 0 romberg $f 0 $limit]] {
+ lappend result [expr { $v / $onemgamma }]
+ }
+ return $result
+
+}
+
+#----------------------------------------------------------------------
+#
+# u_expUpper --
+#
+# Change of variable to integrate a function that decays
+# exponentially.
+#
+# Parameters:
+# f - Function to integrate
+# u - Changed variable u = exp(-x)
+#
+# Results:
+# Returns (1/u)*f(-log(u))
+#
+# Side effects:
+# Whatever f does.
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::u_expUpper { f u } {
+ set cmd $f
+ lappend cmd [expr { -log($u) }]
+ set y [eval $cmd]
+ return [expr { $y / $u }]
+}
+
+#----------------------------------------------------------------------
+#
+# romberg_expUpper --
+#
+# Integrate a function that decays exponentially over a
+# half-infinite interval.
+#
+# Parameters:
+# Same as romberg. The upper limit of integration, 'b',
+# is expected to be very large.
+#
+# Results:
+# Same as romberg.
+#
+# The romberg_expUpper function operates by making the change of
+# variable, u = exp(-x).
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::romberg_expUpper { f a b args } {
+ if { ![string is double -strict $a] } {
+ return -code error [expectDouble $a]
+ }
+ if { ![string is double -strict $b] } {
+ return -code error [expectDouble $b]
+ }
+ if { $a >= $b } {
+ return -code error "limits of integration out of order"
+ }
+ set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]]
+ set f [list u_expUpper $f]
+ return [eval [linsert $args 0 \
+ romberg $f [expr {exp(-$b)}] [expr {exp(-$a)}]]]
+}
+
+#----------------------------------------------------------------------
+#
+# u_expLower --
+#
+# Change of variable to integrate a function that grows
+# exponentially.
+#
+# Parameters:
+# f - Function to integrate
+# u - Changed variable u = exp(x)
+#
+# Results:
+# Returns (1/u)*f(log(u))
+#
+# Side effects:
+# Whatever f does.
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::u_expLower { f u } {
+ set cmd $f
+ lappend cmd [expr { log($u) }]
+ set y [eval $cmd]
+ return [expr { $y / $u }]
+}
+
+#----------------------------------------------------------------------
+#
+# romberg_expLower --
+#
+# Integrate a function that grows exponentially over a
+# half-infinite interval.
+#
+# Parameters:
+# Same as romberg. The lower limit of integration, 'a',
+# is expected to be very large and negative.
+#
+# Results:
+# Same as romberg.
+#
+# The romberg_expUpper function operates by making the change of
+# variable, u = exp(x).
+#
+#----------------------------------------------------------------------
+
+proc ::math::calculus::romberg_expLower { f a b args } {
+ if { ![string is double -strict $a] } {
+ return -code error [expectDouble $a]
+ }
+ if { ![string is double -strict $b] } {
+ return -code error [expectDouble $b]
+ }
+ if { $a >= $b } {
+ return -code error "limits of integration out of order"
+ }
+ set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]]
+ set f [list u_expLower $f]
+ return [eval [linsert $args 0 \
+ romberg $f [expr {exp($a)}] [expr {exp($b)}]]]
+}
+
+
+# regula_falsi --
+# Compute the zero of a function via regula falsi
+# Arguments:
+# f Name of the procedure/command that evaluates the function
+# xb Start of the interval that brackets the zero
+# xe End of the interval that brackets the zero
+# eps Relative error that is allowed (default: 1.0e-4)
+# Result:
+# Estimate of the zero, such that the estimated (!)
+# error < eps * abs(xe-xb)
+# Note:
+# f(xb)*f(xe) must be negative and eps must be positive
+#
+proc ::math::calculus::regula_falsi { f xb xe {eps 1.0e-4} } {
+ if { $eps <= 0.0 } {
+ return -code error "Relative error must be positive"
+ }
+
+ set fb [$f $xb]
+ set fe [$f $xe]
+
+ if { $fb * $fe > 0.0 } {
+ return -code error "Interval must be chosen such that the \
+function has a different sign at the beginning than at the end"
+ }
+
+ set max_error [expr {$eps * abs($xe-$xb)}]
+ set interval [expr {abs($xe-$xb)}]
+
+ while { $interval > $max_error } {
+ set coeff [expr {($fe-$fb)/($xe-$xb)}]
+ set xi [expr {$xb-$fb/$coeff}]
+ set fi [$f $xi]
+
+ if { $fi == 0.0 } {
+ break
+ }
+ set diff1 [expr {abs($xe-$xi)}]
+ set diff2 [expr {abs($xb-$xi)}]
+ if { $diff1 > $diff2 } {
+ set interval $diff2
+ } else {
+ set interval $diff1
+ }
+
+ if { $fb*$fi < 0.0 } {
+ set xe $xi
+ set fe $fi
+ } else {
+ set xb $xi
+ set fb $fi
+ }
+ }
+
+ return $xi
+}
+
+#
+
+# qk15_basic --
+# Apply the QK15 rule to a single interval and return all results
+#
+# Arguments:
+# f Function to integrate (name of procedure)
+# xstart Start of the interval
+# xend End of the interval
+#
+# Returns:
+# List of the following:
+# result Estimated integral (I) of function f
+# abserr Estimate of the absolute error in "result"
+# resabs Estimated integral of the absolute value of f
+# resasc Estimated integral of abs(f - I/(xend-xstart))
+#
+# Note:
+# Translation of the 15-point Gauss-Kronrod rule (QK15) as found
+# in the SLATEC library (QUADPACK) into Tcl.
+#
+namespace eval ::math::calculus {
+ variable qk15_xgk
+ variable qk15_wgk
+ variable qk15_wg
+
+ set qk15_xgk {
+ 0.9914553711208126e+00 0.9491079123427585e+00
+ 0.8648644233597691e+00 0.7415311855993944e+00
+ 0.5860872354676911e+00 0.4058451513773972e+00
+ 0.2077849550078985e+00 0.0e+00 }
+ set qk15_wgk {
+ 0.2293532201052922e-01 0.6309209262997855e-01
+ 0.1047900103222502e+00 0.1406532597155259e+00
+ 0.1690047266392679e+00 0.1903505780647854e+00
+ 0.2044329400752989e+00 0.2094821410847278e+00}
+ set qk15_wg {
+ 0.1294849661688697e+00 0.2797053914892767e+00
+ 0.3818300505051189e+00 0.4179591836734694e+00}
+}
+
+if {[package vsatisfies [package present Tcl] 8.5]} {
+ proc ::math::calculus::Min {a b} { expr {min ($a, $b)} }
+ proc ::math::calculus::Max {a b} { expr {max ($a, $b)} }
+} else {
+ proc ::math::calculus::Min {a b} { if {$a < $b} { return $a } else { return $b }}
+ proc ::math::calculus::Max {a b} { if {$a > $b} { return $a } else { return $b }}
+}
+
+proc ::math::calculus::qk15_basic {xstart xend func} {
+ variable qk15_wg
+ variable qk15_wgk
+ variable qk15_xgk
+
+ #
+ # Use fixed values for epmach and uflow:
+ # - epmach is the largest relative spacing.
+ # - uflow is the smallest positive magnitude.
+
+ set epmach [expr {2.3e-308}]
+ set uflow [expr {1.2e-16}]
+
+ set centr [expr {0.5e+00*($xstart+$xend)}]
+ set hlgth [expr {0.5e+00*($xend-$xstart)}]
+ set dhlgth [expr {abs($hlgth)}]
+
+ #
+ # Compute the 15-point Kronrod approximation to
+ # the integral, and estimate the absolute error.
+ #
+ set fc [uplevel 2 $func $centr]
+ set resg [expr {$fc*[lindex $qk15_wg 3]}]
+ set resk [expr {$fc*[lindex $qk15_wgk 7]}]
+ set resabs [expr {abs($resk)}]
+
+ set fv1 [lrepeat 7 0.0]
+ set fv2 [lrepeat 7 0.0]
+
+ for {set j 0} {$j < 3} {incr j} {
+ set jtw [expr {$j*2 +1}]
+ set absc [expr {$hlgth*[lindex $qk15_xgk $jtw]}]
+ set fval1 [uplevel 2 $func [expr {$centr-$absc}]]
+ set fval2 [uplevel 2 $func [expr {$centr+$absc}]]
+ lset fv1 $jtw $fval1
+ lset fv2 $jtw $fval2
+ set fsum [expr {$fval1+$fval2}]
+ set resg [expr {$resg+[lindex $qk15_wg $j]*$fsum}]
+ set resk [expr {$resk+[lindex $qk15_wgk $jtw]*$fsum}]
+ set resabs [expr {$resabs+[lindex $qk15_wgk $jtw]*(abs($fval1)+abs($fval2))}]
+ }
+ for {set j 0} {$j < 4} {incr j} {
+ set jtwm1 [expr {$j*2}]
+ set absc [expr {$hlgth*[lindex $qk15_xgk $jtwm1]}]
+ set fval1 [uplevel 2 $func [expr {$centr-$absc}]]
+ set fval2 [uplevel 2 $func [expr {$centr+$absc}]]
+ lset fv1 $jtwm1 $fval1
+ lset fv2 $jtwm1 $fval2
+ set fsum [expr {$fval1+$fval2}]
+ set resk [expr {$resk+[lindex $qk15_wgk $jtwm1]*$fsum}]
+ set resabs [expr {$resabs+[lindex $qk15_wgk $jtwm1]*(abs($fval1)+abs($fval2))}]
+ }
+
+ set reskh [expr {$resk*0.5e+00}]
+ set resasc [expr {[lindex $qk15_wgk 7]*abs($fc-$reskh)}]
+
+ for {set j 0} {$j < 7} {incr j} {
+ set wgk [lindex $qk15_wgk $j]
+ set FV1 [lindex $fv1 $j]
+ set FV2 [lindex $fv2 $j]
+ set resasc [expr {$resasc+$wgk*(abs($FV1-$reskh)+abs($FV2-$reskh))}]
+ }
+
+ set result [expr {$resk*$hlgth}]
+ set resabs [expr {$resabs*$dhlgth}]
+ set resasc [expr {$resasc*$dhlgth}]
+ set abserr [expr {abs(($resk-$resg)*$hlgth)}]
+ if { $resasc != 0.0e+00 && $abserr != 0.0e+00 } {
+ set abserr [expr {$resasc*[Min 0.1e+01 [expr {pow((0.2e+3*$abserr/$resasc),1.5e+00)}]]}]
+ }
+ if { $resabs > $uflow/(0.5e+02*$epmach) } {
+ set abserr [Max [expr {($epmach*0.5e+02)*$resabs}] $abserr]
+ }
+
+ return [list $result $abserr $resabs $resasc]
+}
+
+# qk15 --
+# Apply the QK15 rule to an interval and return the estimated integral
+#
+# Arguments:
+# xstart Start of the interval
+# xend End of the interval
+# func Function to integrate (name of procedure)
+# n Number of subintervals (default: 1)
+#
+# Returns:
+# Estimated integral of function func
+#
+proc ::math::calculus::qk15 {xstart xend func {n 1}} {
+ if { $n == 1 } {
+ return [lindex [qk15_basic $xstart $xend $func] 0]
+ } else {
+ set dx [expr {($xend-$xstart)/double($n)}]
+ set result 0.0
+ for {set i 0} {$i < $n} {incr i} {
+ set xb [expr {$xstart + $dx * $i}]
+ set xe [expr {$xstart + $dx * ($i+1)}]
+
+ set result [expr {$result + [lindex [qk15_basic $xb $xe $func] 0]}]
+ }
+ }
+
+ return $result
+}
+
+# qk15_detailed --
+# Apply the QK15 rule to an interval and return the estimated integral
+# as well as the other values
+#
+# Arguments:
+# xstart Start of the interval
+# xend End of the interval
+# func Function to integrate (name of procedure)
+# n Number of subintervals (default: 1)
+#
+# Returns:
+# List of the following:
+# result Estimated integral (I) of function func
+# abserr Estimate of the absolute error in "result"
+# resabs Estimated integral of the absolute value of f
+# resasc Estimated integral of abs(f - I/(xend-xstart))
+#
+proc ::math::calculus::qk15_detailed {xstart xend func {n 1}} {
+ if { $n == 1 } {
+ return [qk15_basic $xstart $xend $func]
+ } else {
+ set dx [expr {($xend-$xstart)/double($n)}]
+ set result 0.0
+ set abserr 0.0
+ set resabs 0.0
+ set resasc 0.0
+ for {set i 0} {$i < $n} {incr i} {
+ set xb [expr {$xstart + $dx * $i}]
+ set xe [expr {$xstart + $dx * ($i+1)}]
+
+ foreach {dresult dabserr dresabs dresasc} [qk15_basic $xb $xe $func] break
+ set result [expr {$result + $dresult}]
+ set abserr [expr {$abserr + $dabserr}]
+ set resabs [expr {$resabs + $dresabs}]
+ set resasc [expr {$resasc + $dresasc}]
+ }
+ }
+
+ return [list $result $abserr $resabs $resasc]
+}
diff --git a/tcllib/modules/math/calculus.test b/tcllib/modules/math/calculus.test
new file mode 100755
index 0000000..a1cdf6e
--- /dev/null
+++ b/tcllib/modules/math/calculus.test
@@ -0,0 +1,680 @@
+# calculus.test --
+# Test cases for the Calculus package
+#
+# This file contains a collection of tests for one or more of the Tcllib
+# procedures. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 2002, 2003, 2004 by Arjen Markus.
+# Copyright (c) 2004 by Kevin B. Kenny
+# All rights reserved.
+#
+# RCS: @(#) $Id: calculus.test,v 1.18 2011/01/18 07:49:53 arjenmarkus Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.1
+
+support {
+ useLocal math.tcl math
+ useLocal interpolate.tcl math::interpolate
+}
+testing {
+ useLocal calculus.tcl math::calculus
+}
+
+# -------------------------------------------------------------------------
+
+package require log
+log::lvSuppress notice
+
+# -------------------------------------------------------------------------
+
+namespace eval ::math::calculus::test {
+
+namespace import ::tcltest::test
+namespace import ::math::calculus::*
+
+set prec $::tcl_precision
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ set ::tcl_precision 17
+} else {
+ set ::tcl_precision 0
+}
+
+proc matchNumbers {expected actual} {
+ set match 1
+ foreach a $actual e $expected {
+ if {abs($a-$e) > 0.1e-4} {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+
+customMatch numbers matchNumbers
+
+#
+# Simple test functions - exact result predictable!
+#
+proc const_func { x } {
+ return 1
+}
+proc linear_func { x } {
+ return $x
+}
+proc downward_linear { x } {
+ return [expr {100.0-$x}]
+}
+
+#
+# Test the Integral proc
+#
+test "Integral-1.0" "Integral of constant function" {
+ integral 0 100 100 const_func
+} 100.0
+
+test "Integral-1.1" "Integral of linear function" {
+ integral 0 100 100 linear_func
+} 5000.0
+
+test "Integral-1.2" "Integral of downward linear function" {
+ integral 0 100 100 downward_linear
+} 5000.0
+
+test "Integral-1.3" "Integral of expression" {
+ integralExpr 0 100 100 {100.0-$x}
+} 5000.0
+
+
+proc const_func2d { x y } {
+ return 1
+}
+proc linear_func2d { x y } {
+ return $x
+}
+
+test "Integral2D-1.0" "Integral of constant 2D function" {
+ integral2D { 0 100 10 } { 0 50 1 } const_func2d
+} 5000.0
+test "Integral2D-1.1" "Integral of constant 2D function (different step)" {
+ integral2D { 0 100 1 } { 0 50 1 } const_func2d
+} 5000.0
+test "Integral2D-1.2" "Integral of linear 2D function" {
+ integral2D { 0 100 10 } { 0 50 1 } linear_func2d
+} 250000.0
+
+
+proc const_func3d { x y z } {
+ return 1
+}
+proc linear_func3d { x y z } {
+ return $x
+}
+
+test "Integral3D-1.0" "Integral of constant 2D function" {
+ integral3D { 0 100 10 } { 0 50 1 } { 0 50 1 } const_func3d
+} 250000.0
+test "Integral3D-1.1" "Integral of constant 2D function (different step)" {
+ integral3D { 0 100 1 } { 0 50 1 } { 0 50 1 } const_func3d
+} 250000.0
+test "Integral3D-1.2" "Integral of linear 2D function" {
+ integral3D { 0 100 10 } { 0 50 1 } { 0 50 1 } linear_func3d
+} 12500000.0
+
+proc f2d_1 {x y} {
+ return 1
+}
+proc f2d_x {x y} {
+ return $x
+}
+proc f2d_y {x y} {
+ return $y
+}
+proc f2d_x2 {x y} {
+ return [expr {$x*$x}]
+}
+proc f2d_y2 {x y} {
+ return [expr {$y*$y}]
+}
+
+test "Integral2D-2.0" "Integrals of 2D functions - accurate" -match numbers -body {
+ set result {}
+ foreach f {f2d_1 f2d_x f2d_y f2d_x2 f2d_y2} {
+ lappend result [::math::calculus::integral2D_accurate {-1 1 1} {-1 1 1} $f]
+ }
+ return $result
+} -result {4.0 0.0 0.0 1.333333333 1.333333333}
+
+
+proc f3d_1 {x y z} {
+ return 1
+}
+proc f3d_x {x y z} {
+ return $x
+}
+proc f3d_y {x y z} {
+ return $y
+}
+proc f3d_z {x y z} {
+ return $z
+}
+proc f3d_x2 {x y z} {
+ return [expr {$x*$x}]
+}
+proc f3d_y2 {x y z} {
+ return [expr {$y*$y}]
+}
+proc f3d_z2 {x y z} {
+ return [expr {$z*$z}]
+}
+
+test "Integral2D-2.0" "Integrals of 2D functions - accurate" -match numbers -body {
+ set result {}
+ foreach f {f3d_1 f3d_x f3d_y f3d_z f3d_x2 f3d_y2 f3d_z2} {
+ lappend result [::math::calculus::integral3D_accurate {-1 1 1} {-1 1 1} {-1 1 1} $f]
+ }
+ return $result
+} -result {8.0 0.0 0.0 0.0 2.666666667 2.666666667 2.666666667}
+
+
+#
+# Test cases: yet to be brought into the tcltest form!
+#
+
+# xvec should one long!
+proc const_func { t xvec } { return 1.0 }
+
+# xvec should be two long!
+proc dampened_oscillator { t xvec } {
+ set x [lindex $xvec 0]
+ set x1 [lindex $xvec 1]
+ return [list $x1 [expr {-$x1-$x}]]
+}
+
+foreach method {eulerStep heunStep rungeKuttaStep} {
+ log::log notice "Method: $method"
+
+ set xvec 0.0
+ set t 0.0
+ set tstep 1.0
+ for { set i 0 } { $i < 10 } { incr i } {
+ set result [$method $t $tstep $xvec const_func]
+ log::log notice "Result ($t): $result"
+ set t [expr {$t+$tstep}]
+ set xvec $result
+ }
+
+ set xvec { 1.0 0.0 }
+ set t 0.0
+ set tstep 0.1
+ for { set i 0 } { $i < 20 } { incr i } {
+ set result [$method $t $tstep $xvec dampened_oscillator]
+ log::log notice "Result ($t): $result"
+ set t [expr {$t+$tstep}]
+ set xvec $result
+ }
+}
+
+#
+# Boundary value problems:
+#
+proc coeffs { x } { return {1.0 0.0 0.0} }
+proc forces { x } { return 0.0 }
+
+log::log notice [boundaryValueSecondOrder coeffs forces {0.0 1.0} {100.0 0.0} 10]
+log::log notice [boundaryValueSecondOrder coeffs forces {0.0 0.0} {100.0 1.0} 10]
+
+#
+# Determining the root of an equation
+# use simple functions
+#
+proc func { x } { expr {$x*$x-1.0} }
+proc deriv { x } { expr {2.0*$x} }
+
+test "NewtonRaphson-1.0" "Result should be 1" {
+ set result [newtonRaphson func deriv 2.0]
+ if { abs($result-1.0) < 0.0001 } {
+ set answer 1
+ }
+} 1
+test "NewtonRaphson-1.1" "Result should be -1" {
+ set result [newtonRaphson func deriv -0.5]
+ if { abs($result+1.0) < 0.0001 } {
+ set answer 1
+ }
+} 1
+
+proc func2 { x } { expr {$x*exp($x)-1.0} }
+proc deriv2 { x } { expr {exp($x)+$x*exp($x)} }
+
+test "NewtonRaphson-2.1" "Result should be nearly 0.56714" {
+ set result [newtonRaphson func2 deriv2 2.0]
+ if { abs($result-0.56714) < 0.0001 } {
+ set answer 1
+ }
+} 1
+
+test "NewtonRaphson-2.2" "Result should be nearly 0.56714" {
+ set result [newtonRaphson func2 deriv2 -0.5]
+ if { abs($result-0.56714) < 0.0001 } {
+ set answer 1
+ }
+} 1
+
+proc checkout { expr integrator a b target } {
+ set problems {}
+ proc g x [list expr $expr]
+ set cmd $integrator
+ lappend cmd g $a $b
+ foreach { s error } [eval $cmd] break
+ set diff [expr { abs( $s - $target ) }]
+ if { $diff > 1.0e-6 * $target && $diff > 1.0e-10 } {
+ append problems \n "error underestimated!" \
+ \n "f =" $expr ", a=" $a ", b=" $b \
+ \n "machinery = " $integrator "," \
+ \n "estimated " $error " actual " $diff
+ }
+ return $problems
+}
+
+test romberg-1.1 {simple integral} {
+ checkout { pow( $x, 16 ) } romberg -1. 1. [expr { 2. / 17. }]
+} {}
+test romberg-1.2 {simple integral} {
+ checkout { exp( -$x * $x / 2. ) / sqrt( 2. * 3.1415926535897932 ) } \
+ romberg -1. 1. 0.68268949213708590
+} {}
+test romberg-1.3 {simple integral} {
+ checkout { sin($x) } romberg 0 3.1415926535897932 2.0
+} {}
+
+test romberg-1.4 { Singularity where limit exists } {
+ checkout { sin($x)/$x } romberg 0 3.1415926535897932 1.8519370519824662
+} {}
+
+test romberg-1.5 { Parameter error } {
+ catch {romberg irrelevant 0 1 -degree} result
+ set result
+} "wrong \# args, should be \"romberg f x1 x2 ?-option value?...\""
+
+test romberg-1.6 { Parameter error } {
+ catch {romberg irrelevant 0 1 -bad flag} result
+ set result
+} "unknown option \"-bad\", should be -abserror, -degree, -relerror, or\
+ -maxiter"
+
+test romberg-1.7 { Max iterations exceeded } \
+ -setup {
+ proc f x { expr { pow($x,4) } }
+ } \
+ -body {
+ foreach { value error } [romberg f -1. 1. -degree 1 -maxiter 3 ] break
+ expr { abs($value - 0.4) < $error }
+ } \
+ -cleanup {
+ rename f {}
+ } \
+ -result 1
+
+test romberg-1.8 {Bad param} {
+ catch {romberg irrelevant 0 1 -degree bad} result
+ set result
+} {expected an integer but found "bad"}
+
+test romberg-1.9 {Bad param} {
+ catch {romberg irrelevant 0 1 -degree 0} result
+ set result
+} {-degree must be positive}
+
+test romberg-1.10 {Bad param} {
+ catch {romberg irrelevant 0 1 -maxiter bad} result
+ set result
+} {expected an integer but found "bad"}
+
+test romberg-1.11 {Bad param} {
+ catch {romberg irrelevant 0 1 -maxiter 0} result
+ set result
+} {-maxiter must be positive}
+
+test romberg-1.12 {Bad param} {
+ catch {romberg irrelevant 0 1 -abserror bad} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-1.13 {Bad param} {
+ catch {romberg irrelevant 0 1 -abserror 0.} result
+ set result
+} {-abserror must be positive}
+
+test romberg-1.14 {Bad param} {
+ catch {romberg irrelevant 0 1 -relerror bad} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-1.15 {Bad param} {
+ catch {romberg irrelevant 0 1 -relerror 0.} result
+ set result
+} {-relerror must be positive}
+
+test romberg-1.16 {Bad limit } {
+ catch {romberg irrelevant bad 1} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-1.17 {Bad limit} {
+ catch {romberg irrelevant 0 bad} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-2.1 {Integral over half-infinite interval} {
+ checkout { exp( -$x * $x / 2. ) / sqrt( 2. * 3.1415926535897932 ) } \
+ romberg_infinity -30. -1. 0.15865525393145705
+} {}
+test romberg-2.2 {Integral over half-infinite interval} {
+ checkout { exp( -$x * $x / 2. ) / sqrt( 2. * 3.1415926535897932 ) } \
+ romberg_infinity 1. 30. 0.15865525393145705
+} {}
+test romberg-2.3 {Integral over half-infinite interval} {
+ checkout { exp( $x ) } romberg_infinity -1.e38 -1. [expr { exp(-1.) }]
+} {}
+test romberg-2.4 {Parameter error} {
+ catch {romberg_infinity irrelevant -1.e38 2.} result
+ set result
+} {limits of integration have opposite sign}
+
+test romberg-2.5 {Bad limit } {
+ catch {romberg_infinity irrelevant bad 1} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-2.6 {Bad limit} {
+ catch {romberg_infinity irrelevant 0 bad} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-3.1 {Square root singularity at the upper bound} {
+ checkout { sqrt( 1.0 / ( 1.0 - $x ) ) } romberg_sqrtSingUpper 0. 1. 2.
+} {}
+
+test romberg-3.2 \
+ {Square root singularity in the derivative at the upper bound} {
+ checkout { 4. * sqrt( 1.0 - $x * $x ) } romberg_sqrtSingUpper 0. 1. \
+ 3.1415926535897932
+ } {}
+
+test romberg-3.3 {Square root singularity at the lower bound} {
+ checkout { 1.0 / sqrt($x) } romberg_sqrtSingLower 0. 4. 4.
+} {}
+
+test romberg-3.4 \
+ {Square root singularity in the derivative at the lower bound} {
+ checkout { 4. * sqrt( 1.0 - $x * $x ) } romberg_sqrtSingLower -1. 0. \
+ 3.1415926535897932
+ } {}
+
+test romberg-3.5 {Bad limit } {
+ catch {romberg_sqrtSingUpper irrelevant bad 1} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-3.6 {Bad limit} {
+ catch {romberg_sqrtSingUpper irrelevant 0 bad} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-3.7 {Bad limits} {
+ catch {romberg_sqrtSingUpper irrelevant 1 0} result
+ set result
+} {limits of integration out of order}
+
+test romberg-3.8 {Bad limit } {
+ catch {romberg_sqrtSingLower irrelevant bad 1} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-3.9 {Bad limit} {
+ catch {romberg_sqrtSingLower irrelevant 0 bad} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-3.10 {Bad limits} {
+ catch {romberg_sqrtSingLower irrelevant 1 0} result
+ set result
+} {limits of integration out of order}
+
+test romberg-4.1 {Power law singularity at the lower bound} {
+ checkout { 1.0 / sqrt($x) } [list romberg_powerLawLower 0.5] 0. 4. 4.
+} {}
+
+test romberg-4.2 \
+ {Power law signularity in the derivative at the lower bound.} {
+ checkout { sqrt( sqrt( $x ) ) } \
+ [list romberg_powerLawLower 0.75] 0. 1. 0.8
+ } {}
+
+test romberg-4.3 {Power law singularity at the upper bound} {
+ checkout { 1.0 / sqrt(4.0 - $x) } \
+ [list romberg_powerLawUpper 0.5] 0. 4. 4.
+} {}
+
+test romberg-4.4 \
+ {Power law singularity in the derivative at the upper bound} {
+ checkout { sqrt( sqrt( -$x ) ) } \
+ [list romberg_powerLawUpper 0.75] -1. 0. 0.8
+ } {}
+
+test romberg-4.5 {Bad limit } {
+ catch {romberg_powerLawUpper 0.5 irrelevant bad 1} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-4.6 {Bad limit} {
+ catch {romberg_powerLawUpper 0.5 irrelevant 0 bad} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-4.7 {Bad limits} {
+ catch {romberg_powerLawUpper 0.5 irrelevant 1 0} result
+ set result
+} {limits of integration out of order}
+
+test romberg-4.8 {Bad limit } {
+ catch {romberg_powerLawLower 0.5 irrelevant bad 1} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-4.9 {Bad limit} {
+ catch {romberg_powerLawLower 0.5 irrelevant 0 bad} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-4.10 {Bad limits} {
+ catch {romberg_powerLawLower 0.5 irrelevant 1 0} result
+ set result
+} {limits of integration out of order}
+
+test romberg-4.11 {Bad gamma} {
+ catch {romberg_powerLawUpper bad irrelevant 1 0} result
+ set result
+} {expected a floating-point number but found "bad"}
+test romberg-4.12 {Bad gamma} {
+ catch {romberg_powerLawUpper 0. irrelevant 1. 0.} result
+ set result
+} {gamma must lie in the interval (0,1)}
+test romberg-4.13 {Bad gamma} {
+ catch {romberg_powerLawUpper 1. irrelevant 1. 0.} result
+ set result
+} {gamma must lie in the interval (0,1)}
+test romberg-4.14 {Bad gamma} {
+ catch {romberg_powerLawLower bad irrelevant 1 0} result
+ set result
+} {expected a floating-point number but found "bad"}
+test romberg-4.15 {Bad gamma} {
+ catch {romberg_powerLawLower 0. irrelevant 1. 0.} result
+ set result
+} {gamma must lie in the interval (0,1)}
+test romberg-4.16 {Bad gamma} {
+ catch {romberg_powerLawLower 1. irrelevant 1. 0.} result
+ set result
+} {gamma must lie in the interval (0,1)}
+
+test romberg-5.1 {Function that decays exponentially} {
+ checkout { exp( -$x * $x / 2. ) / sqrt( 2. * 3.1415926535897932 ) } \
+ romberg_expUpper 1. 100. 0.15865525393145705
+} {}
+
+test romberg-5.2 {Function that grows exponentially} {
+ checkout { exp( -$x * $x / 2. ) / sqrt( 2. * 3.1415926535897932 ) } \
+ romberg_expLower -100. -1. 0.15865525393145705
+} {}
+
+test romberg-5.3 {Bad limit } {
+ catch {romberg_sqrtSingUpper irrelevant bad 1} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-5.4 {Bad limit} {
+ catch {romberg_sqrtSingUpper irrelevant 0 bad} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-5.5 {Bad limits} {
+ catch {romberg_sqrtSingUpper irrelevant 1 0} result
+ set result
+} {limits of integration out of order}
+
+test romberg-5.6 {Bad limit } {
+ catch {romberg_sqrtSingLower irrelevant bad 1} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-5.7 {Bad limit} {
+ catch {romberg_sqrtSingLower irrelevant 0 bad} result
+ set result
+} {expected a floating-point number but found "bad"}
+
+test romberg-5.8 {Bad limits} {
+ catch {romberg_sqrtSingLower irrelevant 1 0} result
+ set result
+} {limits of integration out of order}
+
+test romberg-6.1 {Fancy integration} \
+ -setup {
+ proc v {f u} {
+ set x [expr { sin($u) }]
+ set cmd $f; lappend cmd $x; set y [eval $cmd]
+ return [expr { $y * cos($u) }]
+ }
+ proc romberg_sine { f a b args } {
+ set f [lreplace $f 0 0 \
+ [uplevel 1 [list namespace which [lindex $f 0]]]]
+ set f [list v $f]
+ return [eval [linsert $args 0 \
+ romberg $f \
+ [expr { asin($a) }] [expr { asin($b) }]]]
+ }
+ } \
+ -body {
+ checkout { exp($x) / sqrt( 1. - $x * $x ) } romberg_sine -1. 1. \
+ 3.97746326
+ } \
+ -cleanup {
+ rename v {}
+ rename romberg_sine {}
+ } \
+ -result {}
+
+
+proc matchNumbers {expected actual} {
+ set match 1
+ foreach a $actual e $expected {
+ if {abs($a-$e) > 0.1e-6} {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+
+customMatch numbers matchNumbers
+
+proc ::f1 {x} {expr {1.0-$x}}
+proc ::f2 {x} {expr {1.0-$x*$x}}
+proc ::f3 {x} {expr {cos($x)}}
+
+test "regula-1.0" "Zero of linear function" \
+ -match numbers -body {
+ set x1 [::math::calculus::regula_falsi ::f1 0.0 5.0]
+} -result 1.0
+
+test "regula-1.1" "Zero of quadratic function" \
+ -match numbers -body {
+ set x1 [::math::calculus::regula_falsi ::f2 0.0 5.0]
+} -result 0.99909822
+
+test "regula-1.2" "Zero of quadratic function (more accurate)" \
+ -match numbers -body {
+ set x1 [::math::calculus::regula_falsi ::f2 0.0 5.0 1.0e-6]
+} -result 0.99999305
+
+test "regula-1.3" "Zero of cosine" \
+ -match numbers -body {
+ set x1 [::math::calculus::regula_falsi ::f3 0.0 3.0]
+} -result 1.5707963
+
+test "regula-2.1" "Negative relative error" \
+ -match glob -body {
+ set x1 [::math::calculus::regula_falsi ::f1 0.0 3.0 -1.0e-4]
+} -result "Relative *" -returnCodes error
+
+test "regula-2.2" "Invalid interval" \
+ -match glob -body {
+ set x1 [::math::calculus::regula_falsi ::f3 0.0 5.0]
+} -result "Interval must be *" -returnCodes error
+
+test "solveTriDiagonal-1.0" "Solve tridiagonal system" \
+ -match numbers -body {
+ set x [::math::calculus::solveTriDiagonal {3 3} {1 1 1} {2 2} {1 0 0}]
+} -result [list [expr {5.0/11.0}] [expr {3.0/11.0}] [expr {-9.0/11.0}]]
+
+proc fcos {x} {
+ expr {cos($x)}
+}
+
+test "integrateQk15-1.0" "Integration according to Gauss-Kronrod quadrature" \
+ -match numbers -body {
+ set x [::math::calculus::qk15 0.0 10.0 fcos]
+} -result -0.5440211108893682
+
+test "integrateQk15-1.1" "Integration according to Gauss-Kronrod quadrature (10 steps)" \
+ -match numbers -body {
+ set x [::math::calculus::qk15 0.0 10.0 fcos 10]
+} -result -0.5440211108893697
+
+
+test "integrateQk15-1.2" "Integration according to Gauss-Kronrod quadrature (with details)" \
+ -match numbers -body {
+ set x [::math::calculus::qk15_detailed 0.0 10.0 fcos 10]
+} -result {-0.5440211108893697 6.577401743379832e-20 6.543992515206541 1.533698345844891}
+
+
+# End of test cases
+testsuiteCleanup
+
+set ::tcl_precision $prec
+
+testsuiteCleanup
+}
+
+namespace delete ::math::calculus::test
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tcllib/modules/math/calculus.testscript b/tcllib/modules/math/calculus.testscript
new file mode 100755
index 0000000..81dd091
--- /dev/null
+++ b/tcllib/modules/math/calculus.testscript
@@ -0,0 +1,86 @@
+# calculus.test --
+# Test cases for the Calculus package
+#
+source calculus.tcl
+
+#
+# Simple test functions - exact result predictable!
+#
+proc const_func { x } {
+ return 1
+}
+proc linear_func { x } {
+ return $x
+}
+proc downward_linear { x } {
+ return [expr {100.0-$x}]
+}
+proc downward_linear { x } {
+ return [expr {100.0-$x}]
+}
+
+#
+# Test the Integral proc
+#
+puts "[::Calculus::Integral 0 100 100 const_func] - expected: 100"
+puts "[::Calculus::Integral 0 100 100 linear_func] - expected: 5000"
+puts "[::Calculus::Integral 0 100 100 downward_linear] - expected: 5000"
+puts "[::Calculus::Integral 0 100 100 downward_linear] - expected: 5000"
+puts "[::Calculus::IntegralExpr 0 100 100 {100.0-$x}] - expected: 5000"
+
+proc const_func2d { x y } {
+ return 1
+}
+proc linear_func2d { x y } {
+ return $x
+}
+puts "[::Calculus::Integral2D { 0 100 10 } { 0 50 1 } const_func2d] - \
+ expected 5000"
+puts "[::Calculus::Integral2D { 0 100 1 } { 0 50 1 } const_func2d] - \
+ expected 5000"
+puts "[::Calculus::Integral2D { 0 100 10 } { 0 50 1 } linear_func2d] - \
+ expected 250000"
+
+# xvec should one long!
+proc const_func { t xvec } { return 1.0 }
+
+# xvec should be two long!
+proc dampened_oscillator { t xvec } {
+ set x [lindex $xvec 0]
+ set x1 [lindex $xvec 1]
+ return [list $x1 [expr {-$x1-$x}]]
+}
+
+foreach method {EulerStep HeunStep} {
+ puts "Method: $method"
+
+ set xvec 0.0
+ set t 0.0
+ set tstep 1.0
+ for { set i 0 } { $i < 10 } { incr i } {
+ set result [::Calculus::$method $t $tstep $xvec const_func]
+ puts "Result ($t): $result"
+ set t [expr {$t+$tstep}]
+ set xvec $result
+ }
+
+ set xvec { 1.0 0.0 }
+ set t 0.0
+ set tstep 0.1
+ for { set i 0 } { $i < 20 } { incr i } {
+ set result [::Calculus::$method $t $tstep $xvec dampened_oscillator]
+ puts "Result ($t): $result"
+ set t [expr {$t+$tstep}]
+ set xvec $result
+ }
+}
+
+#
+# Boundary value problems:
+# use simple functions
+#
+proc coeffs { x } { return {1.0 0.0 0.0} }
+proc forces { x } { return 0.0 }
+
+puts [::Calculus::BoundaryValueSecondOrder coeffs forces {0.0 1.0} {100.0 0.0} 10]
+puts [::Calculus::BoundaryValueSecondOrder coeffs forces {0.0 0.0} {100.0 1.0} 10]
diff --git a/tcllib/modules/math/classic_polyns.tcl b/tcllib/modules/math/classic_polyns.tcl
new file mode 100755
index 0000000..1fd9cd0
--- /dev/null
+++ b/tcllib/modules/math/classic_polyns.tcl
@@ -0,0 +1,200 @@
+# classic_polyns.tcl --
+# Implement procedures for the classic orthogonal polynomials
+#
+package require math::polynomials
+
+namespace eval ::math::special {
+ if {[info commands addPolyn] == {} } {
+ namespace import ::math::polynomials::*
+ }
+}
+
+
+# legendre --
+# Return the nth degree Legendre polynomial
+#
+# Arguments:
+# n The degree of the polynomial
+# Result:
+# Polynomial definition
+#
+proc ::math::special::legendre {n} {
+ if { ! [string is integer -strict $n] || $n < 0 } {
+ return -code error "Degree must be a non-negative integer"
+ }
+
+ set pnm1 [polynomial 1.0]
+ set pn [polynomial {0.0 1.0}]
+
+ if { $n == 0 } {return $pnm1}
+ if { $n == 1 } {return $pn}
+
+ set degree 1
+ while { $degree < $n } {
+ set an [expr {(2.0*$degree+1.0)/($degree+1.0)}]
+ set bn 0.0
+ set cn [expr {$degree/($degree+1.0)}]
+ set factor_n [polynomial [list $bn $an]]
+ set term_nm1 [multPolyn $pnm1 [expr {-1.0*$cn}]]
+ set term_n [multPolyn $factor_n $pn]
+ set pnp1 [addPolyn $term_n $term_nm1]
+
+ set pnm1 $pn
+ set pn $pnp1
+ incr degree
+ }
+
+ return $pnp1
+}
+
+# chebyshev --
+# Return the nth degree Chebeyshev polynomial of the first kind
+#
+# Arguments:
+# n The degree of the polynomial
+# Result:
+# Polynomial definition
+#
+proc ::math::special::chebyshev {n} {
+ if { ! [string is integer -strict $n] || $n < 0 } {
+ return -code error "Degree must be a non-negative integer"
+ }
+
+ set pnm1 [polynomial 1.0]
+ set pn [polynomial {0.0 1.0}]
+
+ if { $n == 0 } {return $pnm1}
+ if { $n == 1 } {return $pn}
+
+ set degree 1
+ while { $degree < $n } {
+ set an 2.0
+ set bn 0.0
+ set cn 1.0
+ set factor_n [polynomial [list $bn $an]]
+ set term_nm1 [multPolyn $pnm1 [expr {-1.0*$cn}]]
+ set term_n [multPolyn $factor_n $pn]
+ set pnp1 [addPolyn $term_n $term_nm1]
+
+ set pnm1 $pn
+ set pn $pnp1
+ incr degree
+ }
+
+ return $pnp1
+}
+
+# laguerre --
+# Return the nth degree Laguerre polynomial with parameter alpha
+#
+# Arguments:
+# alpha The parameter for the polynomial
+# n The degree of the polynomial
+# Result:
+# Polynomial definition
+#
+proc ::math::special::laguerre {alpha n} {
+ if { ! [string is double -strict $alpha] } {
+ return -code error "Parameter must be a double"
+ }
+ if { ! [string is integer -strict $n] || $n < 0 } {
+ return -code error "Degree must be a non-negative integer"
+ }
+
+ set pnm1 [polynomial 1.0]
+ set pn [polynomial [list [expr {1.0-$alpha}] -1.0]]
+
+ if { $n == 0 } {return $pnm1}
+ if { $n == 1 } {return $pn}
+
+ set degree 1
+ while { $degree < $n } {
+ set an [expr {-1.0/($degree+1.0)}]
+ set bn [expr {(2.0*$degree+$alpha+1)/($degree+1.0)}]
+ set cn [expr {($degree+$alpha)/($degree+1.0)}]
+ set factor_n [polynomial [list $bn $an]]
+ set term_nm1 [multPolyn $pnm1 [expr {-1.0*$cn}]]
+ set term_n [multPolyn $factor_n $pn]
+ set pnp1 [addPolyn $term_n $term_nm1]
+
+ set pnm1 $pn
+ set pn $pnp1
+ incr degree
+ }
+
+ return $pnp1
+}
+
+# hermite --
+# Return the nth degree Hermite polynomial
+#
+# Arguments:
+# n The degree of the polynomial
+# Result:
+# Polynomial definition
+#
+proc ::math::special::hermite {n} {
+ if { ! [string is integer -strict $n] || $n < 0 } {
+ return -code error "Degree must be a non-negative integer"
+ }
+
+ set pnm1 [polynomial 1.0]
+ set pn [polynomial {0.0 2.0}]
+
+ if { $n == 0 } {return $pnm1}
+ if { $n == 1 } {return $pn}
+
+ set degree 1
+ while { $degree < $n } {
+ set an 2.0
+ set bn 0.0
+ set cn [expr {2.0*$degree}]
+ set factor_n [polynomial [list $bn $an]]
+ set term_n [multPolyn $factor_n $pn]
+ set term_nm1 [multPolyn $pnm1 [expr {-1.0*$cn}]]
+ set pnp1 [addPolyn $term_n $term_nm1]
+
+ set pnm1 $pn
+ set pn $pnp1
+ incr degree
+ }
+
+ return $pnp1
+}
+
+# some tests --
+#
+if { 0 } {
+set prec $::tcl_precision
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ set ::tcl_precision 17
+} else {
+ set ::tcl_precision 0
+}
+
+puts "Legendre:"
+foreach n {0 1 2 3 4} {
+ puts [::math::special::legendre $n]
+}
+
+puts "Chebyshev:"
+foreach n {0 1 2 3 4} {
+ puts [::math::special::chebyshev $n]
+}
+
+puts "Laguerre (alpha=0):"
+foreach n {0 1 2 3 4} {
+ puts [::math::special::laguerre 0.0 $n]
+}
+puts "Laguerre (alpha=1):"
+foreach n {0 1 2 3 4} {
+ puts [::math::special::laguerre 1.0 $n]
+}
+
+puts "Hermite:"
+foreach n {0 1 2 3 4} {
+ puts [::math::special::hermite $n]
+}
+
+set ::tcl_precision $prec
+}
diff --git a/tcllib/modules/math/combinatorics.man b/tcllib/modules/math/combinatorics.man
new file mode 100644
index 0000000..4673e99
--- /dev/null
+++ b/tcllib/modules/math/combinatorics.man
@@ -0,0 +1,108 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin math::combinatorics n 1.2.3]
+[moddesc {Tcl Math Library}]
+[titledesc {Combinatorial functions in the Tcl Math Library}]
+[category Mathematics]
+[require Tcl 8.2]
+[require math [opt 1.2.3]]
+[description]
+[para]
+
+The [package math] package contains implementations of several
+functions useful in combinatorial problems.
+
+[section COMMANDS]
+[list_begin definitions]
+
+[call [cmd ::math::ln_Gamma] [arg z]]
+
+Returns the natural logarithm of the Gamma function for the argument
+[arg z].
+
+[para]
+
+The Gamma function is defined as the improper integral from zero to
+positive infinity of
+
+[example {
+ t**(x-1)*exp(-t) dt
+}]
+
+[para]
+
+The approximation used in the Tcl Math Library is from Lanczos,
+[emph {ISIAM J. Numerical Analysis, series B,}] volume 1, p. 86.
+For "[var x] > 1", the absolute error of the result is claimed to be
+smaller than 5.5*10**-10 -- that is, the resulting value of Gamma when
+
+[example {
+ exp( ln_Gamma( x) )
+}]
+
+is computed is expected to be precise to better than nine significant
+figures.
+
+[call [cmd ::math::factorial] [arg x]]
+
+Returns the factorial of the argument [arg x].
+
+[para]
+
+For integer [arg x], 0 <= [arg x] <= 12, an exact integer result is
+returned.
+
+[para]
+
+For integer [arg x], 13 <= [arg x] <= 21, an exact floating-point
+result is returned on machines with IEEE floating point.
+
+[para]
+
+For integer [arg x], 22 <= [arg x] <= 170, the result is exact to 1
+ULP.
+
+[para]
+
+For real [arg x], [arg x] >= 0, the result is approximated by
+computing [term Gamma(x+1)] using the [cmd ::math::ln_Gamma]
+function, and the result is expected to be precise to better than nine
+significant figures.
+
+[para]
+
+It is an error to present [arg x] <= -1 or [arg x] > 170, or a value
+of [arg x] that is not numeric.
+
+[call [cmd ::math::choose] [arg {n k}]]
+
+Returns the binomial coefficient [term {C(n, k)}]
+
+[example {
+ C(n,k) = n! / k! (n-k)!
+}]
+
+If both parameters are integers and the result fits in 32 bits, the
+result is rounded to an integer.
+
+[para]
+
+Integer results are exact up to at least [arg n] = 34. Floating point
+results are precise to better than nine significant figures.
+
+[call [cmd ::math::Beta] [arg {z w}]]
+
+Returns the Beta function of the parameters [arg z] and [arg w].
+
+[example {
+ Beta(z,w) = Beta(w,z) = Gamma(z) * Gamma(w) / Gamma(z+w)
+}]
+
+Results are returned as a floating point number precise to better than
+nine significant digits provided that [arg w] and [arg z] are both at
+least 1.
+
+[list_end]
+
+[vset CATEGORY math]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/combinatorics.tcl b/tcllib/modules/math/combinatorics.tcl
new file mode 100644
index 0000000..fdc61d5
--- /dev/null
+++ b/tcllib/modules/math/combinatorics.tcl
@@ -0,0 +1,441 @@
+#----------------------------------------------------------------------
+#
+# math/combinatorics.tcl --
+#
+# This file contains definitions of mathematical functions
+# useful in combinatorial problems.
+#
+# Copyright (c) 2001, by Kevin B. Kenny. All rights reserved.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: combinatorics.tcl,v 1.5 2004/02/09 19:31:54 hobbs Exp $
+#
+#----------------------------------------------------------------------
+
+package require Tcl 8.0
+
+namespace eval ::math {
+
+ # Commonly used combinatorial functions
+
+ # ln_Gamma is spelt thus because it's a capital gamma (\u0393)
+
+ namespace export ln_Gamma; # Logarithm of the Gamma function
+ namespace export factorial; # Factorial
+ namespace export choose; # Binomial coefficient
+
+ # Note that Beta is spelt thus because it's conventionally a
+ # capital beta (\u0392). It is exported from the package even
+ # though its name is capitalized.
+
+ namespace export Beta; # Beta function
+
+}
+
+#----------------------------------------------------------------------
+#
+# ::math::InitializeFactorial --
+#
+# Initialize a table of factorials for small integer arguments.
+#
+# Parameters:
+# None.
+#
+# Results:
+# None.
+#
+# Side effects:
+# The variable, ::math::factorialList, is initialized to hold
+# a table of factorial n for 0 <= n <= 170.
+#
+# This procedure is called once when the 'factorial' procedure is
+# being loaded.
+#
+#----------------------------------------------------------------------
+
+proc ::math::InitializeFactorial {} {
+
+ variable factorialList
+
+ set factorialList [list 1]
+ set f 1
+ for { set i 1 } { $i < 171 } { incr i } {
+ if { $i > 12. } {
+ set f [expr { $f * double($i)}]
+ } else {
+ set f [expr { $f * $i }]
+ }
+ lappend factorialList $f
+ }
+
+}
+
+#----------------------------------------------------------------------
+#
+# ::math::InitializePascal --
+#
+# Precompute the first few rows of Pascal's triangle and store
+# them in the variable ::math::pascal
+#
+# Parameters:
+# None.
+#
+# Results:
+# None.
+#
+# Side effects:
+# ::math::pascal is initialized to a flat list containing
+# the first 34 rows of Pascal's triangle. C(n,k) is to be found
+# at [lindex $pascal $i] where i = n * ( n + 1 ) + k. No attempt
+# is made to exploit symmetry.
+#
+#----------------------------------------------------------------------
+
+proc ::math::InitializePascal {} {
+
+ variable pascal
+
+ set pascal [list 1]
+ for { set n 1 } { $n < 34 } { incr n } {
+ lappend pascal 1
+ set l2 [list 1]
+ for { set k 1 } { $k < $n } { incr k } {
+ set km1 [expr { $k - 1 }]
+ set c [expr { [lindex $l $km1] + [lindex $l $k] }]
+ lappend pascal $c
+ lappend l2 $c
+ }
+ lappend pascal 1
+ lappend l2 1
+ set l $l2
+ }
+
+}
+
+#----------------------------------------------------------------------
+#
+# ::math::ln_Gamma --
+#
+# Returns ln(Gamma(x)), where x >= 0
+#
+# Parameters:
+# x - Argument to the Gamma function.
+#
+# Results:
+# Returns the natural logarithm of Gamma(x).
+#
+# Side effects:
+# None.
+#
+# Gamma(x) is defined as:
+#
+# +inf
+# _
+# | x-1 -t
+# Gamma(x)= _| t e dt
+#
+# 0
+#
+# The approximation used here is from Lanczos, SIAM J. Numerical Analysis,
+# series B, volume 1, p. 86. For x > 1, the absolute error of the
+# result is claimed to be smaller than 5.5 * 10**-10 -- that is, the
+# resulting value of Gamma when exp( ln_Gamma( x ) ) is computed is
+# expected to be precise to better than nine significant figures.
+#
+#----------------------------------------------------------------------
+
+proc ::math::ln_Gamma { x } {
+
+ # Handle the common case of a real argument that's within the
+ # permissible range.
+
+ if { [string is double -strict $x]
+ && ( $x > 0 )
+ && ( $x <= 2.5563481638716906e+305 )
+ } {
+ set x [expr { $x - 1.0 }]
+ set tmp [expr { $x + 5.5 }]
+ set tmp [ expr { ( $x + 0.5 ) * log( $tmp ) - $tmp }]
+ set ser 1.0
+ foreach cof {
+ 76.18009173 -86.50532033 24.01409822
+ -1.231739516 .00120858003 -5.36382e-6
+ } {
+ set x [expr { $x + 1.0 }]
+ set ser [expr { $ser + $cof / $x }]
+ }
+ return [expr { $tmp + log( 2.50662827465 * $ser ) }]
+ }
+
+ # Handle the error cases.
+
+ if { ![string is double -strict $x] } {
+ return -code error [expectDouble $x]
+ }
+
+ if { $x <= 0.0 } {
+ set proc [lindex [info level 0] 0]
+ return -code error \
+ -errorcode [list ARITH DOMAIN \
+ "argument to $proc must be positive"] \
+ "argument to $proc must be positive"
+ }
+
+ return -code error \
+ -errorcode [list ARITH OVERFLOW \
+ "floating-point value too large to represent"] \
+ "floating-point value too large to represent"
+
+}
+
+#----------------------------------------------------------------------
+#
+# math::factorial --
+#
+# Returns the factorial of the argument x.
+#
+# Parameters:
+# x -- Number whose factorial is to be computed.
+#
+# Results:
+# Returns x!, the factorial of x.
+#
+# Side effects:
+# None.
+#
+# For integer x, 0 <= x <= 12, an exact integer result is returned.
+#
+# For integer x, 13 <= x <= 21, an exact floating-point result is returned
+# on machines with IEEE floating point.
+#
+# For integer x, 22 <= x <= 170, the result is exact to 1 ULP.
+#
+# For real x, x >= 0, the result is approximated by computing
+# Gamma(x+1) using the ::math::ln_Gamma function, and the result is
+# expected to be precise to better than nine significant figures.
+#
+# It is an error to present x <= -1 or x > 170, or a value of x that
+# is not numeric.
+#
+#----------------------------------------------------------------------
+
+proc ::math::factorial { x } {
+
+ variable factorialList
+
+ # Common case: factorial of a small integer
+
+ if { [string is integer -strict $x]
+ && $x >= 0
+ && $x < [llength $factorialList] } {
+ return [lindex $factorialList $x]
+ }
+
+ # Error case: not a number
+
+ if { ![string is double -strict $x] } {
+ return -code error [expectDouble $x]
+ }
+
+ # Error case: gamma in the left half plane
+
+ if { $x <= -1.0 } {
+ set proc [lindex [info level 0] 0]
+ set message "argument to $proc must be greater than -1.0"
+ return -code error -errorcode [list ARITH DOMAIN $message] $message
+ }
+
+ # Error case - gamma fails
+
+ if { [catch { expr {exp( [ln_Gamma [expr { $x + 1 }]] )} } result] } {
+ return -code error -errorcode $::errorCode $result
+ }
+
+ # Success - computed factorial n as Gamma(n+1)
+
+ return $result
+
+}
+
+#----------------------------------------------------------------------
+#
+# ::math::choose --
+#
+# Returns the binomial coefficient C(n,k) = n!/k!(n-k)!
+#
+# Parameters:
+# n -- Number of objects in the sampling pool
+# k -- Number of objects to be chosen.
+#
+# Results:
+# Returns C(n,k).
+#
+# Side effects:
+# None.
+#
+# Results are expected to be accurate to ten significant figures.
+# If both parameters are integers and the result fits in 32 bits,
+# the result is rounded to an integer.
+#
+# Integer results are exact up to at least n = 34.
+# Floating point results are precise to better than nine significant
+# figures.
+#
+#----------------------------------------------------------------------
+
+proc ::math::choose { n k } {
+
+ variable pascal
+
+ # Use a precomputed table for small integer args
+
+ if { [string is integer -strict $n]
+ && $n >= 0 && $n < 34
+ && [string is integer -strict $k]
+ && $k >= 0 && $k <= $n } {
+
+ set i [expr { ( ( $n * ($n + 1) ) / 2 ) + $k }]
+
+ return [lindex $pascal $i]
+
+ }
+
+ # Test bogus arguments
+
+ if { ![string is double -strict $n] } {
+ return -code error [expectDouble $n]
+ }
+ if { ![string is double -strict $k] } {
+ return -code error [expectDouble $k]
+ }
+
+ # Forbid negative n
+
+ if { $n < 0. } {
+ set proc [lindex [info level 0] 0]
+ set msg "first argument to $proc must be non-negative"
+ return -code error -errorcode [list ARITH DOMAIN $msg] $msg
+ }
+
+ # Handle k out of range
+
+ if { [string is integer -strict $k] && [string is integer -strict $n]
+ && ( $k < 0 || $k > $n ) } {
+ return 0
+ }
+
+ if { $k < 0. } {
+ set proc [lindex [info level 0] 0]
+ set msg "second argument to $proc must be non-negative,\
+ or both must be integers"
+ return -code error -errorcode [list ARITH DOMAIN $msg] $msg
+ }
+
+ # Compute the logarithm of the desired binomial coefficient.
+
+ if { [catch { expr { [ln_Gamma [expr { $n + 1 }]]
+ - [ln_Gamma [expr { $k + 1 }]]
+ - [ln_Gamma [expr { $n - $k + 1 }]] } } r] } {
+ return -code error -errorcode $::errorCode $r
+ }
+
+ # Compute the binomial coefficient itself
+
+ if { [catch { expr { exp( $r ) } } r] } {
+ return -code error -errorcode $::errorCode $r
+ }
+
+ # Round to integer if both args are integers and the result fits
+
+ if { $r <= 2147483647.5
+ && [string is integer -strict $n]
+ && [string is integer -strict $k] } {
+ return [expr { round( $r ) }]
+ }
+
+ return $r
+
+}
+
+#----------------------------------------------------------------------
+#
+# ::math::Beta --
+#
+# Return the value of the Beta function of parameters z and w.
+#
+# Parameters:
+# z, w : Two real parameters to the Beta function
+#
+# Results:
+# Returns the value of the Beta function.
+#
+# Side effects:
+# None.
+#
+# Beta( w, z ) is defined as:
+#
+# 1_
+# | (z-1) (w-1)
+# Beta( w, z ) = Beta( z, w ) = | t (1-t) dt
+# _|
+# 0
+#
+# = Gamma( z ) Gamma( w ) / Gamma( z + w )
+#
+# Results are returned as a floating point number precise to better
+# than nine significant figures for w, z > 1.
+#
+#----------------------------------------------------------------------
+
+proc ::math::Beta { z w } {
+
+ # Check form of both args so that domain check can be made
+
+ if { ![string is double -strict $z] } {
+ return -code error [expectDouble $z]
+ }
+ if { ![string is double -strict $w] } {
+ return -code error [expectDouble $w]
+ }
+
+ # Check sign of both args
+
+ if { $z <= 0.0 } {
+ set proc [lindex [info level 0] 0]
+ set msg "first argument to $proc must be positive"
+ return -code error -errorcode [list ARITH DOMAIN $msg] $msg
+ }
+ if { $w <= 0.0 } {
+ set proc [lindex [info level 0] 0]
+ set msg "second argument to $proc must be positive"
+ return -code error -errorcode [list ARITH DOMAIN $msg] $msg
+ }
+
+ # Compute beta using gamma function, keeping stack trace clean.
+
+ if { [catch { expr { exp( [ln_Gamma $z] + [ln_Gamma $w]
+ - [ln_Gamma [ expr { $z + $w }]] ) } } beta] } {
+
+ return -code error -errorcode $::errorCode $beta
+
+ }
+
+ return $beta
+
+}
+
+#----------------------------------------------------------------------
+#
+# Initialization of this file:
+#
+# Initialize the precomputed tables of factorials and binomial
+# coefficients.
+#
+#----------------------------------------------------------------------
+
+namespace eval ::math {
+ InitializeFactorial
+ InitializePascal
+}
diff --git a/tcllib/modules/math/combinatorics.test b/tcllib/modules/math/combinatorics.test
new file mode 100644
index 0000000..1ea0efc
--- /dev/null
+++ b/tcllib/modules/math/combinatorics.test
@@ -0,0 +1,323 @@
+# Tests for combinatorics functions in math library -*- tcl -*-
+#
+# This file contains a collection of tests for one or more of the Tcllib
+# procedures. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 2001 by Kevin B. Kenny
+# All rights reserved.
+#
+# RCS: @(#) $Id: combinatorics.test,v 1.14 2006/10/09 21:41:41 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal math.tcl math
+}
+
+# -------------------------------------------------------------------------
+
+# Fake [lset] for Tcl releases that don't have it. We need only
+# lset into a flat list.
+
+if { [string compare lset [info commands lset]] } {
+ proc K { x y } { set x }
+ proc lset { listVar index var } {
+ upvar 1 $listVar list
+ set list [lreplace [K $list [set list {}]] $index $index $var]
+ }
+}
+
+# -------------------------------------------------------------------------
+
+test combinatorics-1.1 { math::ln_Gamma, wrong num args } {
+ catch { math::ln_Gamma } msg
+ set msg
+} [tcltest::wrongNumArgs math::ln_Gamma x 0]
+
+test combinatorics-1.2 { math::ln_Gamma, main line code } {
+ set maxerror 0.
+ set f 1.
+ for { set i 1 } { $i < 171 } { set i $ip1 } {
+ set f [expr { $f * $i }]
+ set ip1 [expr { $i + 1 }]
+ set f2 [expr { exp( [math::ln_Gamma $ip1] ) }]
+ set error [expr { abs( $f2 - $f ) / $f }]
+ if { $error > $maxerror } {
+ set maxerror $error
+ }
+ }
+ if { $maxerror > 5e-10 } {
+ error "max error of factorials computed using math::ln_Gamma\
+ specified to be 5e-10, was $maxerror"
+ }
+ concat
+} {}
+
+test combinatorics-1.3 { math::ln_Gamma, half integer args } {
+ set maxerror 0.
+ set z 0.5
+ set pi 3.1415926535897932
+ set g [expr { sqrt( $pi ) }]
+ while { $z < 170. } {
+ set g2 [expr { exp( [::math::ln_Gamma $z] ) }]
+ set error [expr { abs( $g2 - $g ) / $g }]
+ if { $error > $maxerror } {
+ set maxerror $error
+ }
+ set g [expr { $g * $z }]
+ set z [expr { $z + 1. }]
+ }
+ if { $maxerror > 5e-10 } {
+ error "max error of half integer gamma computed using math::ln_Gamma\
+ specified to be 5e-10, was $maxerror"
+ }
+ concat
+} {}
+
+test combinatorics-1.4 { math::ln_Gamma, bogus arg } {
+ catch { math::ln_Gamma bogus } msg
+ set msg
+} {expected a floating-point number but found "bogus"}
+
+test combinatorics-1.5 { math::ln_Gamma, evaluate at pole } {
+ catch { math::ln_Gamma 0.0 } msg
+ list $msg $::errorCode
+} {{argument to math::ln_Gamma must be positive} {ARITH DOMAIN {argument to math::ln_Gamma must be positive}}}
+
+test combinatorics-1.6 { math::ln_Gamma, exponent overflow } {
+ catch { math::ln_Gamma 2.556348163871691e+305 } msg
+ list $msg $::errorCode
+} {{floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}
+
+test combinatorics-2.1 { math::factorial, wrong num args } {
+ catch { math::factorial } msg
+ set msg
+} [tcltest::wrongNumArgs math::factorial x 0]
+
+test combinatorics-2.2 { math::factorial 0 } {
+ math::factorial 0
+} 1
+
+test combinatorics-2.3 { math::factorial, main line } {
+ set maxerror 0.
+ set f 1.
+ for { set i 1 } { $i < 171 } { set i $ip1 } {
+ set f [expr { $f * $i }]
+ set ip1 [expr { $i + 1 }]
+ set f2 [math::factorial $i]
+ set error [expr { abs( $f2 - $f ) / $f }]
+ if { $error > $maxerror } {
+ set maxerror $error
+ }
+ }
+ if { $maxerror > 1e-16 } {
+ error "max error of factorials computed using math::factorial\
+ specified to be 1e-16, was $maxerror"
+ }
+ concat
+} {}
+
+test combinatorics-2.4 { math::factorial, half integer args } {
+ set maxerror 0.
+ set z -0.5
+ set pi 3.1415926535897932
+ set g [expr { sqrt( $pi ) }]
+ while { $z < 169. } {
+ set g2 [math::factorial $z]
+ set error [expr { abs( $g2 - $g ) / $g }]
+ if { $error > $maxerror } {
+ set maxerror $error
+ }
+ set z [expr { $z + 1. }]
+ set g [expr { $g * $z }]
+ }
+ if { $maxerror > 1e-9 } {
+ error "max error of half integer factorial\
+ specified to be 1e-9, was $maxerror"
+ }
+ concat
+} {}
+
+test combinatorics-2.5 { math::factorial, bogus arg } {
+ catch { math::factorial bogus } msg
+ set msg
+} {expected a floating-point number but found "bogus"}
+
+test combinatorics-2.6 { math::factorial, evaluate at pole } {
+ catch { math::factorial -1.0 } msg
+ list $msg $::errorCode
+} {{argument to math::factorial must be greater than -1.0} {ARITH DOMAIN {argument to math::factorial must be greater than -1.0}}}
+
+test combinatorics-2.7 { math::factorial, exponent overflow } {
+ if {![catch {
+ math::factorial 171
+ } msg]} {
+ if { [string equal $msg Infinity] || [string equal $msg Inf] } {
+ set result ok
+ } else {
+ set result "result of factorial was [list $msg],\
+ should be Infinity"
+ }
+ } else {
+ if { [string equal [lrange $::errorCode 0 1] {ARITH OVERFLOW}] } {
+ set result ok
+ } else {
+ set result "error from factorial was [list $::errorCode],\
+ should be {ARITH IOVERFLOW *}"
+ }
+ }
+ set result
+} ok
+
+test combinatorics-2.8 { math::factorial, "" arg } {
+ catch { math::factorial "" } msg
+ list $msg
+} {{expected a floating-point number but found ""}}
+
+test combinatorics-3.1 { math::choose, wrong num args } {
+ catch { math::choose } msg
+ set msg
+} [tcltest::wrongNumArgs math::choose {n k} 0]
+
+test combinatorics-3.2 { math::choose, wrong num args } {
+ catch { math::choose 1 } msg
+ set msg
+} [tcltest::wrongNumArgs math::choose {n k} 1]
+
+test combinatorics-3.3 { math::choose, precomputed table and gamma evals } {
+ set maxError 0
+ set l {}
+ for { set n 0 } { $n < 100 } { incr n } {
+ lappend l 1.
+ for { set k [expr { $n - 1 }] } { $k > 0 } { set k $km1 } {
+ set km1 [expr { $k - 1 }]
+ set cnk [expr { [lindex $l $k] + [lindex $l $km1] }]
+ lset l $k $cnk
+ set ccnk [math::choose $n $k]
+ set error [expr { abs( $ccnk - $cnk ) / $cnk }]
+ if { $error > $maxError } {
+ set maxError $error
+ }
+ }
+ }
+ if { $maxError > 5e-10 } {
+ error "max error in math::choose was $maxError, specified to be 5e-10"
+ }
+ concat
+} {}
+
+test combinatorics-3.4 { math::choose, bogus n } {
+ catch { math::choose bogus 0 } msg
+ set msg
+} {expected a floating-point number but found "bogus"}
+
+test combinatorics-3.5 { math::choose bogus k } {
+ catch { math::choose 0 bogus } msg
+ set msg
+} {expected a floating-point number but found "bogus"}
+
+test combinatorics-3.6 { match::choose negative n } {
+ catch { math::choose -1 0 } msg
+ list $msg $::errorCode
+} {{first argument to math::choose must be non-negative} {ARITH DOMAIN {first argument to math::choose must be non-negative}}}
+
+test combinatorics-3.7 { math::choose negative k } {
+ math::choose 17 -1
+} 0
+
+test combinatorics-3.8 { math::choose excess k } {
+ math::choose 17 18
+} 0
+
+test combinatorics-3.9 {math::choose negative fraction } {
+ catch { math::choose 17 -0.5 } msg
+ list $msg $::errorCode
+} {{second argument to math::choose must be non-negative, or both must be integers} {ARITH DOMAIN {second argument to math::choose must be non-negative, or both must be integers}}}
+
+test combinatorics-3.10 { math::choose big args } {
+ if {![catch {
+ math::choose 1500 750
+ } msg]} {
+ if { [string equal $msg Infinity] || [string equal $msg Inf] } {
+ set result ok
+ } else {
+ set result "result of choose was [list $msg],\
+ should be Infinity"
+ }
+ } else {
+ if { [string equal [lrange $::errorCode 0 1] {ARITH OVERFLOW}] } {
+ set result ok
+ } else {
+ set result "error from choose was [list $::errorCode],\
+ should be {ARITH IOVERFLOW *}"
+ }
+ }
+ set result
+} ok
+
+test combinatorics-4.1 { math::Beta, wrong num args } {
+ catch { math::Beta } msg
+ set msg
+} [tcltest::wrongNumArgs math::Beta {z w} 0]
+
+test combinatorics-4.2 { math::Beta, wrong num args } {
+ catch { math::Beta 1 } msg
+ set msg
+} [tcltest::wrongNumArgs math::Beta {z w} 1]
+
+test combinatorics-4.3 { math::Beta, bogus z } {
+ catch { math::Beta bogus 1 } msg
+ set msg
+} {expected a floating-point number but found "bogus"}
+
+test combinatorics-4.4 { math::Beta, bogus w } {
+ catch { math::Beta 1 bogus } msg
+ set msg
+} {expected a floating-point number but found "bogus"}
+
+test combinatorics-4.5 { math::Beta, negative z } {
+ catch { math::Beta 0 1 } msg
+ list $msg $::errorCode
+} {{first argument to math::Beta must be positive} {ARITH DOMAIN {first argument to math::Beta must be positive}}}
+
+test combinatorics-4.6 { math::Beta, negative w } {
+ catch { math::Beta 1 0 } msg
+ list $msg $::errorCode
+} {{second argument to math::Beta must be positive} {ARITH DOMAIN {second argument to math::Beta must be positive}}}
+
+test combinatorics-4.7 { math::Beta, test with Pascal } {
+ set maxError 0
+ set l {}
+ for { set n 0 } { $n < 100 } { incr n } {
+ lappend l 1.
+ for { set k [expr { $n - 1 }] } { $k > 0 } { set k $km1 } {
+ set km1 [expr { $k - 1 }]
+ set cnk [expr { [lindex $l $k] + [lindex $l $km1] }]
+ lset l $k $cnk
+ set w [expr { $k + 1 }]
+ set z [expr { $n - $k + 1 }]
+ set beta [expr { 1.0 / $cnk / ( $z + $w - 1 )}]
+ set cbeta [math::Beta $z $w]
+ set error [expr { abs( $cbeta - $beta ) / $beta }]
+ if { $error > $maxError } {
+ set maxError $error
+ }
+ }
+ }
+ if { $maxError > 5e-10 } {
+ error "max error in math::Beta was $maxError, specified to be 5e-10"
+ }
+ concat
+} {}
+
+
+testsuiteCleanup
+
diff --git a/tcllib/modules/math/constants.man b/tcllib/modules/math/constants.man
new file mode 100755
index 0000000..9d95870
--- /dev/null
+++ b/tcllib/modules/math/constants.man
@@ -0,0 +1,136 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset VERSION 1.0.2]
+[manpage_begin math::constants n [vset VERSION]]
+[keywords constants]
+[keywords degrees]
+[keywords e]
+[keywords math]
+[keywords pi]
+[keywords radians]
+[copyright {2004 Arjen Markus <arjenmarkus@users.sourceforge.net>}]
+[moddesc {Tcl Math Library}]
+[titledesc {Mathematical and numerical constants}]
+[category Mathematics]
+[require Tcl [opt 8.3]]
+[require math::constants [opt [vset VERSION]]]
+
+[description]
+[para]
+This package defines some common mathematical and numerical constants.
+By using the package you get consistent values for numbers like pi and
+ln(10).
+
+[para]
+It defines two commands:
+
+[list_begin itemized]
+[item]
+One for importing the constants
+
+[item]
+One for reporting which constants are defined and what values they
+actually have.
+
+[list_end]
+
+[para]
+The motivation for this package is that quite often, with
+(mathematical) computations, you need a good approximation to, say,
+the ratio of degrees to radians. You can, of course, define this
+like:
+[example {
+ variable radtodeg [expr {180.0/(4.0*atan(1.0))}]
+}]
+and use the variable radtodeg whenever you need the conversion.
+
+[para]
+This has two drawbacks:
+
+[list_begin itemized]
+[item]
+You need to remember the proper formula or value and that is
+error-prone.
+
+[item]
+Especially with the use of mathematical functions like [emph atan]
+you assume that they have been accurately implemented. This is seldom or
+never the case and for each platform you can get subtle differences.
+
+[list_end]
+
+Here is the way you can do it with the [emph math::constants] package:
+[example {
+ package require math::constants
+ ::math::constants::constants radtodeg degtorad
+}]
+which creates two variables, radtodeg and (its reciprocal) degtorad
+in the calling namespace.
+
+[para]
+Constants that have been defined (their values are mostly taken
+from mathematical tables with more precision than usually can be
+handled) include:
+
+[list_begin itemized]
+[item]
+basic constants like pi, e, gamma (Euler's constant)
+
+[item]
+derived values like ln(10) and sqrt(2)
+
+[item]
+purely numerical values such as 1/3 that are included for convenience
+and for the fact that certain seemingly trivial computations like:
+[example {
+ set value [expr {3.0*$onethird}]
+}]
+give [emph exactly] the value you expect (if IEEE arithmetic is
+available).
+
+[list_end]
+
+The full set of named constants is listed in section [sectref Constants].
+
+[section "PROCEDURES"]
+
+The package defines the following public procedures:
+
+[list_begin definitions]
+
+[call [cmd ::math::constants::constants] [arg args]]
+
+Import the constants whose names are given as arguments
+
+[para]
+
+[call [cmd ::math::constants::print-constants] [arg args]]
+
+Print the constants whose names are given as arguments on the screen
+(name, value and description) or, if no arguments are given, print all
+defined constants. This is mainly a convenience procedure.
+
+[list_end]
+
+[section "Constants"]
+[list_begin definitions]
+[def [const pi]] Ratio of circle circumference to diameter
+[def [const e]] Base for natural logarithm
+[def [const ln10]] Natural logarithm of 10
+[def [const phi]] Golden ratio
+[def [const gamma]] Euler's constant
+[def [const sqrt2]] Square root of 2
+[def [const thirdrt2]] One-third power of 2
+[def [const sqrt3]] Square root of 3
+[def [const radtodeg]] Conversion from radians to degrees
+[def [const degtorad]] Conversion from degrees to radians
+[def [const onethird]] One third (0.3333....)
+[def [const twothirds]]Two thirds (0.6666....)
+[def [const onesixth]] One sixth (0.1666....)
+[def [const huge]] (Approximately) largest number
+[def [const tiny]] (Approximately) smallest number not equal zero
+[def [const eps]] Smallest number such that 1+eps != 1
+[list_end]
+
+[vset CATEGORY {math :: constants}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/constants.tcl b/tcllib/modules/math/constants.tcl
new file mode 100755
index 0000000..79e6ea5
--- /dev/null
+++ b/tcllib/modules/math/constants.tcl
@@ -0,0 +1,205 @@
+# constants.tcl --
+# Module defining common mathematical and numerical constants
+#
+# Copyright (c) 2004 by Arjen Markus. All rights reserved.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: constants.tcl,v 1.9 2011/01/18 07:49:53 arjenmarkus Exp $
+#
+#----------------------------------------------------------------------
+
+package require Tcl 8.2
+
+package provide math::constants 1.0.2
+
+# namespace constants
+# Create a convenient namespace for the constants
+#
+namespace eval ::math::constants {
+ #
+ # List of constants and their description
+ #
+ variable constants {
+ pi 3.14159265358979323846 "ratio of circle circumference and diameter"
+ e 2.71828182845904523536 "base for natural logarithm"
+ ln10 2.30258509299404568402 "natural logarithm of 10"
+ phi 1.61803398874989484820 "golden ratio"
+ gamma 0.57721566490153286061 "Euler's constant"
+ sqrt2 1.41421356237309504880 "Square root of 2"
+ thirdrt2 1.25992104989487316477 "One-third power of 2"
+ sqrt3 1.73205080756887729533 "Square root of 3"
+ radtodeg 57.2957795131 "Conversion from radians to degrees"
+ degtorad 0.017453292519943 "Conversion from degrees to radians"
+ onethird 1.0/3.0 "One third (0.3333....)"
+ twothirds 2.0/3.0 "Two thirds (0.6666....)"
+ onesixth 1.0/6.0 "One sixth (0.1666....)"
+ huge [find_huge] "(Approximately) largest number"
+ tiny [find_tiny] "(Approximately) smallest number not equal zero"
+ eps [find_eps] "Smallest number such that 1+eps != 1"
+ }
+ namespace export constants print-constants
+}
+
+# constants --
+# Expose the constants in the caller's routine or namespace
+#
+# Arguments:
+# args List of constants to be exposed
+# Result:
+# None
+#
+proc ::math::constants::constants {args} {
+
+ foreach const $args {
+ uplevel 1 [list variable $const [set ::math::constants::$const]]
+ }
+}
+
+# print-constants --
+# Print the selected or all constants to the screen
+#
+# Arguments:
+# args List of constants to be exposed
+# Result:
+# None
+#
+proc ::math::constants::print-constants {args} {
+ variable constants
+
+ if { [llength $args] != 0 } {
+ foreach const $args {
+ set idx [lsearch $constants $const]
+ if { $idx >= 0 } {
+ set descr [lindex $constants [expr {$idx+2}]]
+ puts "$const = [set ::math::constants::$const] = $descr"
+ } else {
+ puts "*** $const unknown ***"
+ }
+ }
+ } else {
+ foreach {const value descr} $constants {
+ puts "$const = [set ::math::constants::$const] = $descr"
+ }
+ }
+}
+
+# find_huge --
+# Find the largest possible number
+#
+# Arguments:
+# None
+# Result:
+# Estimate of the largest possible number
+#
+proc ::math::constants::find_huge {} {
+
+ set result 1.0
+ set Inf Inf
+ while {1} {
+ if {[catch {expr {2.0 * $result}} result]} {
+ break
+ }
+ if { $result == $Inf } {
+ break
+ }
+ set prev_result $result
+ }
+ set result $prev_result
+ set adder [expr { $result / 2. }]
+ while { $adder != 0.0 } {
+ if {![catch {expr {$adder + $prev_result}} result]} {
+ if { $result == $prev_result } break
+ if { $result != $Inf } {
+ set prev_result $result
+ }
+ }
+ set adder [expr { $adder / 2. }]
+ }
+ return $prev_result
+
+}
+
+# find_tiny --
+# Find the smallest possible number
+#
+# Arguments:
+# None
+# Result:
+# Estimate of the smallest possible number
+#
+proc ::math::constants::find_tiny {} {
+
+ set result 1.0
+
+ while { ! [catch {set result [expr {$result/2.0}]}] && $result > 0.0 } {
+ set prev_result $result
+ }
+ return $prev_result
+}
+
+# find_eps --
+# Find the smallest number eps such that 1+eps != 1
+#
+# Arguments:
+# None
+# Result:
+# Estimate of the machine epsilon
+#
+proc ::math::constants::find_eps { } {
+ set eps 1.0
+ while { [expr {1.0+$eps}] != 1.0 } {
+ set prev_eps $eps
+ set eps [expr {0.5*$eps}]
+ }
+ return $prev_eps
+}
+
+# Create the variables from the list:
+# - By using expr we ensure that the best double precision
+# approximation is assigned to the variable, rather than
+# just the string
+# - It also allows us to rely on IEEE arithmetic if available,
+# so that for instance 3.0*(1.0/3.0) is exactly 1.0
+#
+namespace eval ::math::constants {
+ foreach {const value descr} $constants {
+ # FRINK: nocheck
+ set [namespace current]::$const [expr 0.0+$value]
+ }
+ unset value
+ unset const
+ unset descr
+
+ rename find_eps {}
+ rename find_tiny {}
+ rename find_huge {}
+}
+
+# some tests --
+#
+if { [info exists ::argv0]
+ && [string equal $::argv0 [info script]] } {
+ ::math::constants::constants pi e ln10 onethird eps
+ set prec $::tcl_precision
+ if {![package vsatisfies [package provide Tcl] 8.5]} {
+ set ::tcl_precision 17
+ } else {
+ set ::tcl_precision 0
+ }
+ puts "$pi - [expr {1.0/$pi}]"
+ puts $e
+ puts $ln10
+ puts "onethird: [expr {3.0*$onethird}]"
+ ::math::constants::print-constants onethird pi e
+ puts "All defined constants:"
+ ::math::constants::print-constants
+
+ if { 1.0+$eps == 1.0 } {
+ puts "Something went wrong with eps!"
+ } else {
+ puts "Difference: [set ee [expr {1.0+$eps}]] - 1.0 = [expr {$ee-1.0}]"
+ }
+ set ::tcl_precision $prec
+}
diff --git a/tcllib/modules/math/constants.test b/tcllib/modules/math/constants.test
new file mode 100755
index 0000000..280fb8c
--- /dev/null
+++ b/tcllib/modules/math/constants.test
@@ -0,0 +1,56 @@
+# -*- tcl -*-
+# constants.test --
+# Test cases for the ::math::constants package
+#
+# This file contains a collection of tests for one or more of the Tcllib
+# procedures. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 2004 by Arjen Markus. All rights reserved.
+#
+# RCS: @(#) $Id: constants.test,v 1.10 2008/03/23 04:39:48 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 2.1
+
+support {
+ useLocal math.tcl math
+}
+testing {
+ useLocal constants.tcl math::constants
+}
+
+# -------------------------------------------------------------------------
+
+#
+# Test: do we get the constants into our namespace?
+#
+test "Constants-1.0" "Get constants into our namespace" -body {
+ ::math::constants::constants pi e
+ expr {[info exists pi] && [info exists e]}
+} -result 1
+
+test "Constants-1.1" "Get constants with the right values" -body {
+ #
+ # Only needed once!
+ #
+ #::math::constants::constants pi e
+ set result1 [expr {abs($pi-4.0*atan(1.0))<1.0e-10?1:0}]
+ set result2 [expr {abs($e-exp(1.0))<1.0e-10?1:0}]
+ expr {$result1+$result2}
+
+ # Note: this should enough accuracy!
+} -result 2
+
+#
+# No tests for print-constants defined ...
+#
+
+# End of test cases
+testsuiteCleanup
diff --git a/tcllib/modules/math/decimal.man b/tcllib/modules/math/decimal.man
new file mode 100755
index 0000000..a2b7ab4
--- /dev/null
+++ b/tcllib/modules/math/decimal.man
@@ -0,0 +1,199 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin math::decimal n 1.0.3]
+[keywords decimal]
+[keywords math]
+[keywords tcl]
+[copyright {2011 Mark Alston <mark at beernut dot com>}]
+[moddesc {Tcl Decimal Arithmetic Library}]
+[titledesc {General decimal arithmetic}]
+[category Mathematics]
+[require Tcl [opt 8.5]]
+[require math::decimal 1.0.3]
+
+[description]
+[para]
+The decimal package provides decimal arithmetic support for both limited
+precision floating point and arbitrary precision floating point.
+Additionally, integer arithmetic is supported.
+[para]
+More information and the specifications on which this package depends can be
+found on the general decimal arithmetic page at http://speleotrove.com/decimal
+
+This package provides for:
+[list_begin itemized]
+[item]
+A new data type decimal which is represented as a list containing sign,
+mantissa and exponent.
+[item]
+Arithmetic operations on those decimal numbers such as addition, subtraction,
+multiplication, etc...
+
+[list_end]
+[para]
+Numbers are converted to decimal format using the operation ::math::decimal::fromstr.
+[para]
+Numbers are converted back to string format using the operation
+::math::decimal::tostr.
+
+[para]
+
+[section "EXAMPLES"]
+This section shows some simple examples. Since the purpose of this library
+is to perform decimal math operations, examples may be the simplest way
+to learn how to work with it and to see the difference between using this
+package and sticking with expr. Consult the API section of
+this man page for information about individual procedures.
+
+[para]
+[example_begin]
+ package require decimal
+
+ # Various operations on two numbers.
+ # We first convert them to decimal format.
+ set a [lb]::math::decimal::fromstr 8.2[rb]
+ set b [lb]::math::decimal::fromstr .2[rb]
+
+ # Then we perform our operations. Here we multiply
+ set c [lb]::math::decimal::* $a $b[rb]
+
+ # Finally we convert back to string format for presentation to the user.
+ puts [lb]::math::decimal::tostr $c[rb] ; # => will output 8.4
+
+ # Other examples
+ #
+ # Subtraction
+ set c [lb]::math::decimal::- $a $b[rb]
+ puts [lb]::math::decimal::tostr $c[rb] ; # => will output 8.0
+
+ # Why bother using this instead of simply expr?
+ puts [expr {8.2 + .2}] ; # => will output 8.399999999999999
+ puts [expr {8.2 - .2}] ; # => will output 7.999999999999999
+ # See http://speleotrove.com/decimal to learn more about why this happens.
+[example_end]
+
+[section "API"]
+[list_begin definitions]
+
+[call [cmd ::math::decimal::fromstr] [arg string]]
+Convert [emph string] into a decimal.
+
+[call [cmd ::math::decimal::tostr] [arg decimal]]
+Convert [emph decimal] into a string representing the number in base 10.
+
+[call [cmd ::math::decimal::setVariable] [arg variable] [arg setting]]
+Sets the [emph variable] to [emph setting]. Valid variables are:
+[list_begin itemized]
+[item][arg rounding] - Method of rounding to use during rescale. Valid
+ methods are round_half_even, round_half_up, round_half_down,
+ round_down, round_up, round_floor, round_ceiling.
+[item][arg precision] - Maximum number of digits allowed in mantissa.
+[item][arg extended] - Set to 1 for extended mode. 0 for simplified mode.
+[item][arg maxExponent] - Maximum value for the exponent. Defaults to 999.
+[item][arg minExponent] - Minimum value for the exponent. Default to -998.
+[list_end]
+[call [cmd ::math::decimal::add] [arg a] [arg b]]
+[call [cmd ::math::decimal::+] [arg a] [arg b]]
+Return the sum of the two decimals [emph a] and [emph b].
+
+[call [cmd ::math::decimal::subtract] [arg a] [arg b]]
+[call [cmd ::math::decimal::-] [arg a] [arg b]]
+Return the differnece of the two decimals [emph a] and [emph b].
+
+[call [cmd ::math::decimal::multiply] [arg a] [arg b]]
+[call [cmd ::math::decimal::*] [arg a] [arg b]]
+Return the product of the two decimals [emph a] and [emph b].
+
+[call [cmd ::math::decimal::divide] [arg a] [arg b]]
+[call [cmd ::math::decimal::/] [arg a] [arg b]]
+Return the quotient of the division between the two
+decimals [emph a] and [emph b].
+
+[call [cmd ::math::decimal::divideint] [arg a] [arg b]]
+Return a the integer portion of the quotient of the division between
+decimals [emph a] and [emph b]
+
+[call [cmd ::math::decimal::remainder] [arg a] [arg b]]
+Return the remainder of the division between the two
+decimals [emph a] and [emph b].
+
+[call [cmd ::math::decimal::abs] [arg decimal]]
+Return the absolute value of the decimal.
+
+[call [cmd ::math::decimal::compare] [arg a] [arg b]]
+Compare the two decimals a and b, returning [emph 0] if [emph {a == b}],
+[emph 1] if [emph {a > b}], and [emph -1] if [emph {a < b}].
+
+[call [cmd ::math::decimal::max] [arg a] [arg b]]
+Compare the two decimals a and b, and return [emph a] if [emph {a >= b}], and [emph b] if [emph {a < b}].
+
+[call [cmd ::math::decimal::maxmag] [arg a] [arg b]]
+Compare the two decimals a and b while ignoring their signs, and return [emph a] if [emph {abs(a) >= abs(b)}], and [emph b] if [emph {abs(a) < abs(b)}].
+
+[call [cmd ::math::decimal::min] [arg a] [arg b]]
+Compare the two decimals a and b, and return [emph a] if [emph {a <= b}], and [emph b] if [emph {a > b}].
+
+[call [cmd ::math::decimal::minmag] [arg a] [arg b]]
+Compare the two decimals a and b while ignoring their signs, and return [emph a] if [emph {abs(a) <= abs(b)}], and [emph b] if [emph {abs(a) > abs(b)}].
+
+[call [cmd ::math::decimal::plus] [arg a]]
+Return the result from [emph {::math::decimal::+ 0 $a}].
+
+[call [cmd ::math::decimal::minus] [arg a]]
+Return the result from [emph {::math::decimal::- 0 $a}].
+
+[call [cmd ::math::decimal::copynegate] [arg a]]
+Returns [emph a] with the sign flipped.
+
+[call [cmd ::math::decimal::copysign] [arg a] [arg b]]
+Returns [emph a] with the sign set to the sign of the [emph b].
+
+[call [cmd ::math::decimal::is-signed] [arg decimal]]
+Return the sign of the decimal.
+The procedure returns 0 if the number is positive, 1 if it's negative.
+
+[call [cmd ::math::decimal::is-zero] [arg decimal]]
+Return true if [emph decimal] value is zero, otherwise false is returned.
+
+[call [cmd ::math::decimal::is-NaN] [arg decimal]]
+Return true if [emph decimal] value is NaN (not a number), otherwise false is returned.
+
+[call [cmd ::math::decimal::is-infinite] [arg decimal]]
+Return true if [emph decimal] value is Infinite, otherwise false is returned.
+
+[call [cmd ::math::decimal::is-finite] [arg decimal]]
+Return true if [emph decimal] value is finite, otherwise false is returned.
+
+[call [cmd ::math::decimal::fma] [arg a] [arg b] [arg c]]
+Return the result from first multiplying [emph a] by [emph b] and then adding [emph c]. Rescaling only occurs after completion of all operations. In this way the result may vary from that returned by performing the operations individually.
+
+[call [cmd ::math::decimal::round_half_even] [arg decimal] [arg digits]]
+Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round to the nearest. If equidistant, round so the final digit is even.
+
+[call [cmd ::math::decimal::round_half_up] [arg decimal] [arg digits]]
+Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round to the nearest. If equidistant, round up.
+
+[call [cmd ::math::decimal::round_half_down] [arg decimal] [arg digits]]
+Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round to the nearest. If equidistant, round down.
+
+[call [cmd ::math::decimal::round_down] [arg decimal] [arg digits]]
+Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round toward 0. (Truncate)
+
+[call [cmd ::math::decimal::round_up] [arg decimal] [arg digits]]
+Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round away from 0
+
+[call [cmd ::math::decimal::round_floor] [arg decimal] [arg digits]]
+Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round toward -Infinity.
+
+[call [cmd ::math::decimal::round_ceiling] [arg decimal] [arg digits]]
+Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round toward Infinity
+
+[call [cmd ::math::decimal::round_05up] [arg decimal] [arg digits]]
+Rounds [emph decimal] to [emph digits] number of decimal points with the following rules: Round zero or five away from 0. The same as round-up, except that rounding up only occurs if the digit to be rounded up is 0 or 5, and after overflow
+the result is the same as for round-down.
+
+[list_end]
+[para]
+
+[vset CATEGORY decimal]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/decimal.tcl b/tcllib/modules/math/decimal.tcl
new file mode 100755
index 0000000..6505fed
--- /dev/null
+++ b/tcllib/modules/math/decimal.tcl
@@ -0,0 +1,1741 @@
+package require Tcl 8.5
+package provide math::decimal 1.0.3
+#
+# Copyright 2011, 2013 Mark Alston. All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or
+# without modification, are permitted provided that the following
+# conditions are met:
+#
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+#
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in
+# the documentation and/or other materials provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY Mark Alston ``AS IS'' AND ANY EXPRESS
+# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+# ARE DISCLAIMED. IN NO EVENT SHALL Mark Alston OR CONTRIBUTORS
+# BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+# OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+# WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+# OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
+# EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+#
+#
+# decimal.tcl --
+#
+# Tcl implementation of a General Decimal Arithmetic as defined
+# by the IEEE 754 standard as given on http:://speleotrove.com/decimal
+#
+# Decimal numbers are defined as a list of sign mantissa exponent
+#
+# The following operations are current implemented:
+#
+# fromstr tostr -- for converting to and from decimal numbers.
+#
+# add subtract divide multiply abs compare -- basic operations
+# max min plus minus copynegate copysign is-zero is-signed
+# is-NaN is-infinite is-finite
+#
+# round_half_even round_half_up round_half_down -- rounding methods
+# round_down round_up round_floor round_ceiling
+# round_05up
+#
+# By setting the extended variable to 0 you get the behavior of the decimal
+# subset arithmetic X3.274 as defined on
+# http://speleotrove.com/decimal/dax3274.html#x3274
+#
+# This package passes all tests in test suites:
+# http://speleotrove.com/decimal/dectest.html
+# and http://speleotrove.com/decimal/dectest0.html
+#
+# with the following exceptions:
+#
+# This version fails some tests that require setting the max
+# or min exponent to force truncation or rounding.
+#
+# This version fails some tests which require the sign of zero to be set
+# correctly during rounding
+#
+# This version cannot handle sNaN's (Not sure that they are of any use for
+# tcl programmers anyway.
+#
+# If you find errors in this code please let me know at
+# mark at beernut dot com
+#
+# Decimal --
+# Namespace for the decimal arithmetic procedures
+#
+namespace eval ::math::decimal {
+ variable precision 20
+ variable maxExponent 999
+ variable minExponent -998
+ variable tinyExponent [expr {$minExponent - ($precision - 1)}]
+ variable rounding half_up
+ variable extended 1
+
+ # Some useful variables to set.
+ variable zero [list 0 0 0]
+ variable one [list 0 1 0]
+ variable ten [list 0 1 1]
+ variable onehundred [list 0 1 2]
+ variable minusone [list 1 1 0]
+
+ namespace export tostr fromstr setVariable getVariable\
+ add + subtract - divide / multiply * \
+ divide-int remainder \
+ fma fused-multiply-add \
+ plus minus copynegate negate copysign \
+ abs compare max min \
+ is-zero is-signed is-NaN is-infinite is-finite \
+ round_half_even round_half_up round_half_down \
+ round_down round_up round_floor round_ceiling round_05up
+
+}
+
+# setVariable
+# Set the desired variable
+#
+# Arguments:
+# variable setting
+#
+# Result:
+# None
+#
+proc ::math::decimal::setVariable {variable setting} {
+ variable rounding
+ variable precision
+ variable extended
+ variable maxExponent
+ variable minExponent
+ variable tinyExponent
+
+ switch -nocase -- $variable {
+ rounding {set rounding $setting}
+ precision {set precision $setting}
+ extended {set extended $setting}
+ maxExponent {set maxExponent $setting}
+ minExponent {
+ set minExponent $setting
+ set tinyExponent [expr {$minExponent - ($precision - 1)}]
+ }
+ default {}
+ }
+}
+
+# setVariable
+# Set the desired variable
+#
+# Arguments:
+# variable setting
+#
+# Result:
+# None
+#
+proc ::math::decimal::getVariable {variable} {
+ variable rounding
+ variable precision
+ variable extended
+ variable maxExponent
+ variable minExponent
+
+ switch -- $variable {
+ rounding {return $rounding}
+ precision {return $precision}
+ extended {return $extended}
+ maxExponent {return $maxExponent}
+ minExponent {return $minExponent}
+ default {}
+ }
+}
+
+# add or +
+# Add two numbers
+#
+# Arguments:
+# a First operand
+# b Second operand
+#
+# Result:
+# Sum of both (rescaled)
+#
+proc ::math::decimal::add {a b {rescale 1}} {
+ return [+ $a $b $rescale]
+}
+
+proc ::math::decimal::+ {a b {rescale 1}} {
+ variable extended
+ variable rounding
+ foreach {sa ma ea} $a {break}
+ foreach {sb mb eb} $b {break}
+
+ if {!$extended} {
+ if {$ma == 0 } {
+ return $b
+ }
+ if {$mb == 0 } {
+ return $a
+ }
+ }
+
+ if { $ma eq "NaN" || $mb eq "NaN" } {
+ return [list 0 "NaN" 0]
+ }
+
+ if { $ma eq "Inf" || $mb eq "Inf" } {
+ if { $ma ne "Inf" } {
+ return $b
+ } elseif { $mb ne "Inf" } {
+ return $a
+ } elseif { $sb != $sa } {
+ return [list 0 "NaN" 0]
+ } else {
+ return $a
+ }
+ }
+
+ if { $ea > $eb } {
+ set ma [expr {$ma * 10 ** ($ea-$eb)}]
+ set er $eb
+ } else {
+ set mb [expr {$mb * 10 ** ($eb-$ea)}]
+ set er $ea
+ }
+ if { $sa == $sb } {
+ # Both are either postive or negative
+ # Sign remains the same.
+ set mr [expr {$ma + $mb}]
+ set sr $sa
+ } else {
+ # one is negative and one is positive.
+ # Set sign to the same as the larger number
+ # and subract the smaller from the larger.
+ if { $ma > $mb } {
+ set sr $sa
+ set mr [expr {$ma - $mb}]
+ } elseif { $mb > $ma } {
+ set sr $sb
+ set mr [expr {$mb - $ma}]
+ } else {
+ if { $rounding == "floor" } {
+ set sr 1
+ } else {
+ set sr 0
+ }
+ set mr 0
+ }
+ }
+ if { $rescale } {
+ return [Rescale [list $sr $mr $er]]
+ } else {
+ return [list $sr $mr $er]
+ }
+}
+
+# copynegate --
+# Takes one operand and returns a copy with the sign inverted.
+# In this implementation it works nearly the same as minus
+# but is probably much faster. The main difference is that no
+# rescaling is done.
+#
+#
+# Arguments:
+# a operand
+#
+# Result:
+# a with sign flipped
+#
+proc ::math::decimal::negate { a } {
+ return [copynegate $a]
+}
+
+proc ::math::decimal::copynegate { a } {
+ lset a 0 [expr {![lindex $a 0]}]
+ return $a
+}
+
+# copysign --
+# Takes two operands and returns a copy of the first with the
+# sign set to the sign of the second.
+#
+#
+# Arguments:
+# a operand
+# b operand
+#
+# Result:
+# b with a's sign
+#
+proc ::math::decimal::copysign { a b } {
+ lset a 0 [lindex $b 0]
+ return $a
+}
+
+# minus --
+# subtract 0 $a
+#
+# Note: does not pass all tests on extended mode.
+#
+# Arguments:
+# a operand
+#
+# Result:
+# 0 - $a
+#
+proc ::math::decimal::minus { a } {
+ return [- [list 0 0 0] $a]
+}
+
+# plus --
+# add 0 $a
+#
+# Note: does not pass all tests on extended mode.
+#
+# Arguments:
+# a operand
+#
+# Result:
+# 0 + $a
+#
+proc ::math::decimal::plus {a} {
+ return [+ [list 0 0 0] $a]
+}
+
+
+
+# subtract or -
+# Subtract two numbers (or unary minus)
+#
+# Arguments:
+# a First operand
+# b Second operand (optional)
+#
+# Result:
+# Sum of both (rescaled)
+#
+proc ::math::decimal::subtract {a {b {}} {rescale 1}} {
+ return [- $a $b]
+}
+
+proc ::math::decimal::- {a {b {}} {rescale 1}} {
+ variable extended
+
+ if {!$extended} {
+ foreach {sa ma ea} $a {break}
+ foreach {sb mb eb} $b {break}
+ if {$ma == 0 } {
+ lset b 0 [expr {![lindex $b 0]}]
+ return $b
+ }
+ if {$mb == 0 } {
+ return $a
+ }
+ }
+
+ if { $b == {} } {
+ lset a 0 [expr {![lindex $a 0]}]
+ return $a
+ } else {
+ lset b 0 [expr {![lindex $b 0]}]
+ return [+ $a $b $rescale]
+ }
+}
+
+
+# compare
+# Compare two numbers.
+#
+# Arguments:
+# a First operand
+# b Second operand
+#
+# Result:
+# 1 if a is larger than b
+# 0 if a is equal to b
+# -1 if a is smaller than b.
+#
+proc ::math::decimal::compare {a b} {
+ foreach {sa ma ea} $a {break}
+ foreach {sb mb eb} $b {break}
+
+ if { $sa != $sb } {
+ if {$ma != 0 } {
+ set ma 1
+ set ea 0
+ } elseif { $mb != 0 } {
+ set mb 1
+ set eb 0
+ } else {
+ return 0
+ }
+ }
+ if { $ma eq "Inf" && $mb eq "Inf" } {
+ if { $sa == $sb } {
+ return 0
+ } elseif { $sa > $sb } {
+ return -1
+ } else {
+ return 1
+ }
+ }
+
+ set comparison [- [list $sa $ma $ea] [list $sb $mb $eb] 0]
+
+ if { [lindex $comparison 0] && [lindex $comparison 1] != 0 } {
+ return -1
+ } elseif { [lindex $comparison 1] == 0 } {
+ return 0
+ } else {
+ return 1
+ }
+}
+
+# min
+# Return the smaller of two numbers
+#
+# Arguments:
+# a First operand
+# b Second operand
+#
+# Result:
+# smaller of a or b
+#
+proc ::math::decimal::min {a b} {
+ foreach {sa ma ea} $a {break}
+ foreach {sb mb eb} $b {break}
+
+ if { $sa != $sb } {
+ if {$ma != 0 } {
+ set ma 1
+ set ea 0
+ } elseif { $mb != 0 } {
+ set mb 1
+ set eb 0
+ }
+ }
+ if { $ma eq "Inf" && $mb eq "Inf" } {
+ if { $sa == $sb } {
+ return [list $sa "Inf" 0]
+ } else {
+ return [list 1 "Inf" 0]
+ }
+ }
+
+ set comparison [compare [list $sa $ma $ea] [list $sb $mb $eb]]
+
+ if { $comparison == 1 } {
+ return [Rescale $b]
+ } elseif { $comparison == -1 } {
+ return [Rescale $a]
+ } elseif { $sb != $sa } {
+ if { $sa } {
+ return [Rescale $a]
+ } else {
+ return [Rescale $b]
+ }
+ } elseif { $sb && $eb > $ea } {
+ # Both are negative and the same numerically. So return the one with the largest exponent.
+ return [Rescale $b]
+ } elseif { $sb } {
+ # Negative with $eb < $ea now.
+ return [Rescale $a]
+ } elseif { $ea > $eb } {
+ # Both are positive so return the one with the smaller
+ return [Rescale $b]
+ } else {
+ return [Rescale $a]
+ }
+}
+
+# max
+# Return the larger of two numbers
+#
+# Arguments:
+# a First operand
+# b Second operand
+#
+# Result:
+# larger of a or b
+#
+proc ::math::decimal::max {a b} {
+ foreach {sa ma ea} $a {break}
+ foreach {sb mb eb} $b {break}
+
+ if { $sa != $sb } {
+ if {$ma != 0 } {
+ set ma 1
+ set ea 0
+ } elseif { $mb != 0 } {
+ set mb 1
+ set eb 0
+ }
+ }
+ if { $ma eq "Inf" && $mb eq "Inf" } {
+ if { $sa == $sb } {
+ return [list $sa "Inf" 0]
+ } else {
+ return [list 0 "Inf" 0]
+ }
+ }
+
+ set comparison [compare [list $sa $ma $ea] [list $sb $mb $eb]]
+
+ if { $comparison == 1 } {
+ return [Rescale $a]
+ } elseif { $comparison == -1 } {
+ return [Rescale $b]
+ } elseif { $sb != $sa } {
+ if { $sa } {
+ return [Rescale $b]
+ } else {
+ return [Rescale $a]
+ }
+ } elseif { $sb && $eb > $ea } {
+ # Both are negative and the same numerically. So return the one with the smallest exponent.
+ return [Rescale $a]
+ } elseif { $sb } {
+ # Negative with $eb < $ea now.
+ return [Rescale $b]
+ } elseif { $ea > $eb } {
+ # Both are positive so return the one with the larger exponent
+ return [Rescale $a]
+ } else {
+ return [Rescale $b]
+ }
+}
+
+# maxmag -- max-magnitude
+# Return the larger of two numbers ignoring their signs.
+#
+# Arguments:
+# a First operand
+# b Second operand
+#
+# Result:
+# larger of a or b ignoring their signs.
+#
+proc ::math::decimal::maxmag {a b} {
+ foreach {sa ma ea} $a {break}
+ foreach {sb mb eb} $b {break}
+
+
+ if { $ma eq "Inf" && $mb eq "Inf" } {
+ if { $sa == 0 || $sb == 0 } {
+ return [list 0 "Inf" 0]
+ } else {
+ return [list 1 "Inf" 0]
+ }
+ }
+
+ set comparison [compare [list 0 $ma $ea] [list 0 $mb $eb]]
+
+ if { $comparison == 1 } {
+ return [Rescale $a]
+ } elseif { $comparison == -1 } {
+ return [Rescale $b]
+ } elseif { $sb != $sa } {
+ if { $sa } {
+ return [Rescale $b]
+ } else {
+ return [Rescale $a]
+ }
+ } elseif { $sb && $eb > $ea } {
+ # Both are negative and the same numerically. So return the one with the smallest exponent.
+ return [Rescale $a]
+ } elseif { $sb } {
+ # Negative with $eb < $ea now.
+ return [Rescale $b]
+ } elseif { $ea > $eb } {
+ # Both are positive so return the one with the larger exponent
+ return [Rescale $a]
+ } else {
+ return [Rescale $b]
+ }
+}
+
+# minmag -- min-magnitude
+# Return the smaller of two numbers ignoring their signs.
+#
+# Arguments:
+# a First operand
+# b Second operand
+#
+# Result:
+# smaller of a or b ignoring their signs.
+#
+proc ::math::decimal::minmag {a b} {
+ foreach {sa ma ea} $a {break}
+ foreach {sb mb eb} $b {break}
+
+ if { $ma eq "Inf" && $mb eq "Inf" } {
+ if { $sa == 1 || $sb == 1 } {
+ return [list 1 "Inf" 0]
+ } else {
+ return [list 0 "Inf" 0]
+ }
+ }
+
+ set comparison [compare [list 0 $ma $ea] [list 0 $mb $eb]]
+
+ if { $comparison == 1 } {
+ return [Rescale $b]
+ } elseif { $comparison == -1 } {
+ return [Rescale $a]
+ } else {
+ # They compared the same so now we use a normal comparison including the signs. This is per the specs.
+ if { $sa > $sb } {
+ return [Rescale $a]
+ } elseif { $sb > $sa } {
+ return [Rescale $b]
+ } elseif { $sb && $eb > $ea } {
+ # Both are negative and the same numerically. So return the one with the largest exponent.
+ return [Rescale $b]
+ } elseif { $sb } {
+ # Negative with $eb < $ea now.
+ return [Rescale $a]
+ } elseif { $ea > $eb } {
+ return [Rescale $b]
+ } else {
+ return [Rescale $a]
+ }
+ }
+}
+
+# fma - fused-multiply-add
+# Takes three operands. Multiplies the first two and then adds the third.
+# Only one rounding (Rescaling) takes place at the end instead of after
+# both the multiplication and again after the addition.
+#
+# Arguments:
+# a First operand
+# b Second operand
+# c Third operand
+#
+# Result:
+# (a*b)+c
+#
+proc ::math::decimal::fused-multiply-add {a b c} {
+ return [fma $a $b $c]
+}
+
+proc ::math::decimal::fma {a b c} {
+ return [+ $c [* $a $b 0]]
+}
+
+# multiply or *
+# Multiply two numbers
+#
+# Arguments:
+# a First operand
+# b Second operand
+#
+# Result:
+# Product of both (rescaled)
+#
+proc ::math::decimal::multiply {a b {rescale 1}} {
+ return [* $a $b $rescale]
+}
+
+proc ::math::decimal::* {a b {rescale 1}} {
+ foreach {sa ma ea} $a {break}
+ foreach {sb mb eb} $b {break}
+
+ if { $ma eq "NaN" || $mb eq "NaN" } {
+ return [list 0 "NaN" 0]
+ }
+
+ set sr [expr {$sa^$sb}]
+
+ if { $ma eq "Inf" || $mb eq "Inf" } {
+ if { $ma == 0 || $mb == 0 } {
+ return [list 0 "NaN" 0]
+ } else {
+ return [list $sr "Inf" 0]
+ }
+ }
+
+ set mr [expr {$ma * $mb}]
+ set er [expr {$ea + $eb}]
+
+
+ if { $rescale } {
+ return [Rescale [list $sr $mr $er]]
+ } else {
+ return [list $sr $mr $er]
+ }
+}
+
+# divide or /
+# Divide two numbers
+#
+# Arguments:
+# a First operand
+# b Second operand
+#
+# Result:
+# Quotient of both (rescaled)
+#
+proc ::math::decimal::divide {a b {rescale 1}} {
+ return [/ $a $b]
+}
+
+proc ::math::decimal::/ {a b {rescale 1}} {
+ variable precision
+
+ foreach {sa ma ea} $a {break}
+ foreach {sb mb eb} $b {break}
+
+ if { $ma eq "NaN" || $mb eq "NaN" } {
+ return [list 0 "NaN" 0]
+ }
+
+ set sr [expr {$sa^$sb}]
+
+ if { $ma eq "Inf" } {
+ if { $mb ne "Inf"} {
+ return [list $sr "Inf" 0]
+ } else {
+ return [list 0 "NaN" 0]
+ }
+ }
+
+ if { $mb eq "Inf" } {
+ if { $ma ne "Inf"} {
+ return [list $sr 0 0]
+ } else {
+ return [list 0 "NaN" 0]
+ }
+ }
+
+ if { $mb == 0 } {
+ if { $ma == 0 } {
+ return [list 0 "NaN" 0]
+ } else {
+ return [list $sr "Inf" 0]
+ }
+ }
+ set adjust 0
+ set mr 0
+
+
+ if { $ma == 0 } {
+ set er [expr {$ea - $eb}]
+ return [list $sr 0 $er]
+ }
+ if { $ma < $mb } {
+ while { $ma < $mb } {
+ set ma [expr {$ma * 10}]
+ incr adjust
+ }
+ } elseif { $ma >= $mb * 10 } {
+ while { $ma >= [expr {$mb * 10}] } {
+ set mb [expr {$mb * 10}]
+ incr adjust -1
+ }
+ }
+
+ while { 1 } {
+ while { $mb <= $ma } {
+ set ma [expr {$ma - $mb}]
+ incr mr
+ }
+ if { ( $ma == 0 && $adjust >= 0 ) || [string length $mr] > $precision + 1 } {
+ break
+ } else {
+ set ma [expr {$ma * 10}]
+ set mr [expr {$mr * 10}]
+ incr adjust
+ }
+ }
+
+ set er [expr {$ea - ($eb + $adjust)}]
+
+ if { $rescale } {
+ return [Rescale [list $sr $mr $er]]
+ } else {
+ return [list $sr $mr $er]
+ }
+}
+
+# divideint -- Divide integer
+# Divide a by b and return the integer part of the division.
+#
+# Basically, if we send a and b to the divideint (which returns i)
+# and remainder function (which returns r) then the following is true:
+# a = i*b + r
+#
+# Arguments:
+# a First operand
+# b Second operand
+#
+#
+proc ::math::decimal::divideint { a b } {
+ foreach {sa ma ea} $a {break}
+ foreach {sb mb eb} $b {break}
+ set sr [expr {$sa^$sb}]
+
+
+
+ if { $sr == 1 } {
+ set sign_string "-"
+ } else {
+ set sign_string ""
+ }
+
+ if { ($ma eq "NaN" || $mb eq "NaN") || ($ma == 0 && $mb == 0 ) } {
+ return "NaN"
+ }
+
+ if { $ma eq "Inf" || $mb eq "Inf" } {
+ if { $ma eq $mb } {
+ return "NaN"
+ } elseif { $mb eq "Inf" } {
+ return "${sign_string}0"
+ } else {
+ return "${sign_string}Inf"
+ }
+ }
+
+ if { $mb == 0 } {
+ return "${sign_string}Inf"
+ }
+ if { $mb == "Inf" } {
+ return "${sign_string}0"
+ }
+ set adjust [expr {abs($ea - $eb)}]
+ if { $ea < $eb } {
+ set a_adjust 0
+ set b_adjust $adjust
+ } elseif { $ea > $eb } {
+ set b_adjust 0
+ set a_adjust $adjust
+ } else {
+ set a_adjust 0
+ set b_adjust 0
+ }
+
+ set integer [expr {($ma*10**$a_adjust)/($mb*10**$b_adjust)}]
+ return $sign_string$integer
+}
+
+# remainder -- Remainder from integer division.
+# Divide a by b and return the remainder part of the division.
+#
+# Basically, if we send a and b to the divideint (which returns i)
+# and remainder function (which returns r) then the following is true:
+# a = i*b + r
+#
+# Arguments:
+# a First operand
+# b Second operand
+#
+#
+proc ::math::decimal::remainder { a b } {
+ foreach {sa ma ea} $a {break}
+ foreach {sb mb eb} $b {break}
+
+ if { $sa == 1 } {
+ set sign_string "-"
+ } else {
+ set sign_string ""
+ }
+
+ if { ($ma eq "NaN" || $mb eq "NaN") || ($ma == 0 && $mb == 0 ) } {
+ if { $mb eq "NaN" && $mb ne $ma } {
+ if { $sb == 1 } {
+ set sign_string "-"
+ } else {
+ set sign_string ""
+ }
+ return "${sign_string}NaN"
+ } elseif { $ma eq "NaN" } {
+ return "${sign_string}NaN"
+ } else {
+ return "NaN"
+ }
+ } elseif { $mb == 0 } {
+ return "NaN"
+ }
+
+ if { $ma eq "Inf" || $mb eq "Inf" } {
+ if { $ma eq $mb } {
+ return "NaN"
+ } elseif { $mb eq "Inf" } {
+ return [tostr $a]
+ } else {
+ return "NaN"
+ }
+ }
+
+ if { $mb == 0 } {
+ return "${sign_string}Inf"
+ }
+ if { $mb == "Inf" } {
+ return "${sign_string}0"
+ }
+
+ lset a 0 0
+ lset b 0 0
+ if { $mb == 0 } {
+ return "${sign_string}Inf"
+ }
+ if { $mb == "Inf" } {
+ return "${sign_string}0"
+ }
+
+ set adjust [expr {abs($ea - $eb)}]
+ if { $ea < $eb } {
+ set a_adjust 0
+ set b_adjust $adjust
+ } elseif { $ea > $eb } {
+ set b_adjust 0
+ set a_adjust $adjust
+ } else {
+ set a_adjust 0
+ set b_adjust 0
+ }
+
+ set integer [expr {($ma*10**$a_adjust)/($mb*10**$b_adjust)}]
+
+ set remainder [tostr [- $a [* [fromstr $integer] $b 0]]]
+ return $sign_string$remainder
+}
+
+
+# abs --
+# Returns the Absolute Value of a number
+#
+# Arguments:
+# Number in the form of {sign mantisse exponent}
+#
+# Result:
+# Absolute value (as a list)
+#
+ proc ::math::decimal::abs {a} {
+ lset a 0 0
+ return [Rescale $a]
+ }
+
+
+# Rescale --
+# Rescale the number (using proper rounding)
+#
+# Arguments:
+# a Number in decimal format
+#
+# Result:
+# Rescaled number
+#
+proc ::math::decimal::Rescale { a } {
+
+
+
+ variable precision
+ variable rounding
+ variable maxExponent
+ variable minExponent
+ variable tinyExponent
+
+ foreach {sign mantisse exponent} $a {break}
+
+ set man_length [string length $mantisse]
+
+ set adjusted_exponent [expr {$exponent + ($man_length -1)}]
+
+ if { $adjusted_exponent < $tinyExponent } {
+ set mantisse [lindex [round_$rounding [list $sign $mantisse [expr {abs($tinyExponent) - abs($adjusted_exponent)}]] 0] 1]
+ return [list $sign $mantisse $tinyExponent]
+ } elseif { $adjusted_exponent > $maxExponent } {
+ if { $mantisse == 0 } {
+ return [list $sign 0 $maxExponent]
+ } else {
+ switch -- $rounding {
+ half_even -
+ half_up { return [list $sign "Inf" 0] }
+ down -
+ 05up {
+ return [list $sign [string repeat 9 $precision] $maxExponent]
+ }
+ ceiling {
+ if { $sign } {
+ return [list $sign [string repeat 9 $precision] $maxExponent]
+ } else {
+ return [list 0 "Inf" 0]
+ }
+ }
+ floor {
+ if { !$sign } {
+ return [list $sign [string repeat 9 $precision] $maxExponent]
+ } else {
+ return [list 1 "Inf" 0]
+ }
+ }
+ default { }
+ }
+ }
+ }
+
+ if { $man_length <= $precision } {
+ return [list $sign $mantisse $exponent]
+ }
+
+ set mantisse [lindex [round_$rounding [list $sign $mantisse [expr {$precision - $man_length}]] 0] 1]
+ set exponent [expr {$exponent + ($man_length - $precision)}]
+
+ # it is possible now that our rounding gave us a new digit in our mantisse
+ # example rounding 999.9 to 1 digits with precision 3 will give us
+ # 1000 back.
+ # This can only happen by adding a zero on the end of our mantisse however.
+ # So we just chomp it off.
+
+ set man_length_now [string length $mantisse]
+ if { $man_length_now > $precision } {
+ set mantisse [string range $mantisse 0 end-1]
+ incr exponent
+ # Check again to see if we have overflowed
+ # we change our test to >= because we have incremented exponent.
+ if { $adjusted_exponent >= $maxExponent } {
+ switch -- $rounding {
+ half_even -
+ half_up { return [list $sign "Inf" 0] }
+ down -
+ 05up {
+ return [list $sign [string repeat 9 $precision] $maxExponent]
+ }
+ ceiling {
+ if { $sign } {
+ return [list $sign [string repeat 9 $precision] $maxExponent]
+ } else {
+ return [list 0 "Inf" 0]
+ }
+ }
+ floor {
+ if { !$sign } {
+ return [list $sign [string repeat 9 $precision] $maxExponent]
+ } else {
+ return [list 1 "Inf" 0]
+ }
+ }
+ default { }
+ }
+ }
+ }
+ return [list $sign $mantisse $exponent]
+}
+
+# tostr --
+# Convert number to string using appropriate method depending on extended
+# attribute setting.
+#
+# Arguments:
+# number Number to be converted
+#
+# Result:
+# Number in the form of a string
+#
+proc ::math::decimal::tostr { number } {
+ variable extended
+ switch -- $extended {
+ 0 { return [tostr_numeric $number] }
+ 1 { return [tostr_scientific $number] }
+ }
+}
+
+# tostr_scientific --
+# Convert number to string using scientific notation as called for in
+# Decmath specifications.
+#
+# Arguments:
+# number Number to be converted
+#
+# Result:
+# Number in the form of a string
+#
+proc ::math::decimal::tostr_scientific {number} {
+ foreach {sign mantisse exponent} $number {break}
+
+ if { $sign } {
+ set sign_string "-"
+ } else {
+ set sign_string ""
+ }
+
+ if { $mantisse eq "NaN" } {
+ return "NaN"
+ }
+ if { $mantisse eq "Inf" } {
+ return ${sign_string}${mantisse}
+ }
+
+
+ set digits [string length $mantisse]
+ set adjusted_exponent [expr {$exponent + $digits - 1}]
+
+ # Why -6? Go read the specs on the website mentioned in the header.
+ # They choose it, I'm using it. They actually list some good reasons though.
+ if { $exponent <= 0 && $adjusted_exponent >= -6 } {
+ if { $exponent == 0 } {
+ set string $mantisse
+ } else {
+ set exponent [expr {abs($exponent)}]
+ if { $digits > $exponent } {
+ set string [string range $mantisse 0 [expr {$digits-$exponent-1}]].[string range $mantisse [expr {$digits-$exponent}] end]
+ set exponent [expr {-$exponent}]
+ } else {
+ set string 0.[string repeat 0 [expr {$exponent-$digits}]]$mantisse
+ }
+ }
+ } elseif { $exponent <= 0 && $adjusted_exponent < -6 } {
+ if { $digits > 1 } {
+
+ set string [string range $mantisse 0 0].[string range $mantisse 1 end]
+
+ set exponent [expr {$exponent + $digits - 1}]
+ set string "${string}E${exponent}"
+ } else {
+ set string "${mantisse}E${exponent}"
+ }
+ } else {
+ if { $adjusted_exponent >= 0 } {
+ set adjusted_exponent "+$adjusted_exponent"
+ }
+ if { $digits > 1 } {
+ set string "[string range $mantisse 0 0].[string range $mantisse 1 end]E$adjusted_exponent"
+ } else {
+ set string "${mantisse}E$adjusted_exponent"
+ }
+ }
+ return $sign_string$string
+}
+
+# tostr_numeric --
+# Convert number to string using the simplified number set conversion
+# from the X3.274 subset of Decimal Arithmetic specifications.
+#
+# Arguments:
+# number Number to be converted
+#
+# Result:
+# Number in the form of a string
+#
+proc ::math::decimal::tostr_numeric {number} {
+ variable precision
+ foreach {sign mantisse exponent} $number {break}
+
+ if { $sign } {
+ set sign_string "-"
+ } else {
+ set sign_string ""
+ }
+
+ if { $mantisse eq "NaN" } {
+ return "NaN"
+ }
+ if { $mantisse eq "Inf" } {
+ return ${sign_string}${mantisse}
+ }
+
+ set digits [string length $mantisse]
+ set adjusted_exponent [expr {$exponent + $digits - 1}]
+
+ if { $mantisse == 0 } {
+ set string 0
+ set sign_string ""
+ } elseif { $exponent <= 0 && $adjusted_exponent >= -6 } {
+ if { $exponent == 0 } {
+ set string $mantisse
+ } else {
+ set exponent [expr {abs($exponent)}]
+ if { $digits > $exponent } {
+ set string [string range $mantisse 0 [expr {$digits-$exponent-1}]]
+ set decimal_part [string range $mantisse [expr {$digits-$exponent}] end]
+ set string ${string}.${decimal_part}
+ set exponent [expr {-$exponent}]
+ } else {
+ set string 0.[string repeat 0 [expr {$exponent-$digits}]]$mantisse
+ }
+ }
+ } elseif { $exponent <= 0 && $adjusted_exponent < -6 } {
+ if { $digits > 1 } {
+ set string [string range $mantisse 0 0].[string range $mantisse 1 end]
+ set exponent [expr {$exponent + $digits - 1}]
+ set string "${string}E${exponent}"
+ } else {
+ set string "${mantisse}E${exponent}"
+ }
+ } else {
+ if { $adjusted_exponent >= 0 } {
+ set adjusted_exponent "+$adjusted_exponent"
+ }
+ if { $digits > 1 && $adjusted_exponent >= $precision } {
+ set string "[string range $mantisse 0 0].[string range $mantisse 1 end]E$adjusted_exponent"
+ } elseif { $digits + $exponent <= $precision } {
+ set string ${mantisse}[string repeat 0 [expr {$exponent}]]
+ } else {
+ set string "${mantisse}E$adjusted_exponent"
+ }
+ }
+ return $sign_string$string
+}
+
+# fromstr --
+# Convert string to number
+#
+# Arguments:
+# string String to be converted
+#
+# Result:
+# Number in the form of {sign mantisse exponent}
+#
+proc ::math::decimal::fromstr {string} {
+ variable extended
+
+ set string [string trim $string "'\""]
+
+ if { [string range $string 0 0] == "-" } {
+ set sign 1
+ set string [string trimleft $string -]
+ incr pos -1
+ } else {
+ set sign 0
+ }
+
+ if { $string eq "Inf" || $string eq "NaN" } {
+ if {!$extended} {
+ # we don't allow these strings in the subset arithmetic.
+ # throw error.
+ error "Infinities and NaN's not allowed in simplified decimal arithmetic"
+ } else {
+ return [list $sign $string 0]
+ }
+ }
+
+ set string [string trimleft $string "+-"]
+ set echeck [string first "E" [string toupper $string]]
+ set epart 0
+ if { $echeck >= 0 } {
+ set epart [string range $string [expr {$echeck+1}] end]
+ set string [string range $string 0 [expr {$echeck -1}]]
+ }
+
+ set pos [string first . $string]
+
+ if { $pos < 0 } {
+ if { $string == 0 } {
+ set mantisse 0
+ if { !$extended } {
+ set sign 0
+ }
+ } else {
+ set mantisse $string
+ }
+ set exponent 0
+ } else {
+ if { $string == "" } {
+ return [list 0 0 0]
+ } else {
+ #stripping the leading zeros here is required to avoid some octal issues.
+ #However, it causes us to fail some tests with numbers like 0.00 and 0.0
+ #which test differently but we can't deal with now.
+ set mantisse [string trimleft [string map {. ""} $string] 0]
+ if { $mantisse == "" } {
+ set mantisse 0
+ if {!$extended} {
+ set sign 0
+ }
+ }
+ set fraction [string range $string [expr {$pos+1}] end]
+ set exponent [expr {-[string length $fraction]}]
+ }
+ }
+ set exponent [expr {$exponent + $epart}]
+
+ if { $extended } {
+ return [list $sign $mantisse $exponent]
+ } else {
+ return [Rescale [list $sign $mantisse $exponent]]
+ }
+}
+
+# ipart --
+# Return the integer part of a Decimal Number
+#
+# Arguments:
+# Number in the form of {sign mantisse exponent}
+#
+#
+# Result:
+# Integer
+#
+proc ::math::decimal::ipart { a } {
+
+ foreach {sa ma ea} $a {break}
+
+ if { $ea == 0 } {
+ if { $sa } {
+ return -$ma
+ } else {
+ return $ma
+ }
+ } elseif { $ea > 0 } {
+ if { $sa } {
+ return [expr {-1 * $ma * 10**$ea}]
+ } else {
+ return [expr {$ma * 10**$ea}]
+ }
+ } else {
+ if { [string length $ma] <= abs($ea) } {
+ return 0
+ } else {
+ if { $sa } {
+ set string_sign "-"
+ } else {
+ set string_sign ""
+ }
+ set ea [expr {abs($ea)}]
+ return "${string_sign}[string range $ma 0 end-$ea]"
+ }
+ }
+}
+
+# round_05_up --
+# Round zero or five away from 0.
+# The same as round-up, except that rounding up only occurs
+# if the digit to be rounded up is 0 or 5, and after overflow
+# the result is the same as for round-down.
+#
+# Bias: away from zero
+#
+# Arguments:
+# Number in the form of {sign mantisse exponent}
+# Number of decimal points to round to.
+#
+# Result:
+# Number in the form of {sign mantisse exponent}
+#
+proc ::math::decimal::round_05up {a digits} {
+ foreach {sa ma ea} $a {break}
+
+ if { -$ea== $digits } {
+ return $a
+ } elseif { $digits + $ea > 0 } {
+ set mantissa [expr { $ma * 10**($digits+$ea) }]
+ set exponent [expr {-1 * $digits}]
+ } else {
+ set round_exponent [expr {$digits + $ea}]
+ if { [string length $ma] <= $round_exponent } {
+ if { $ma != 0 } {
+ set mantissa 1
+ } else {
+ set mantissa 0
+ }
+ set exponent 0
+ } else {
+ set integer_part [ipart [list 0 $ma $round_exponent]]
+
+ if { [compare [list 0 $ma $round_exponent] [list 0 ${integer_part}0 -1]] == 0 } {
+ # We are rounding something with fractional part .0
+ set mantissa $integer_part
+ } elseif { [string index $integer_part end] eq 0 || [string index $integer_part end] eq 5 } {
+ set mantissa [expr {$integer_part + 1}]
+ } else {
+ set mantissa $integer_part
+ }
+ set exponent [expr {-1 * $digits}]
+ }
+ }
+ return [list $sa $mantissa $exponent]
+}
+
+# round_half_up --
+#
+# Round to the nearest. If equidistant, round up.
+#
+#
+# Bias: away from zero
+#
+# Arguments:
+# Number in the form of {sign mantisse exponent}
+# Number of decimal points to round to.
+#
+# Result:
+# Number in the form of {sign mantisse exponent}
+#
+proc ::math::decimal::round_half_up {a digits} {
+ foreach {sa ma ea} $a {break}
+
+ if { $digits + $ea == 0 } {
+ return $a
+ } elseif { $digits + $ea > 0 } {
+ set mantissa [expr {$ma *10 **($digits+$ea)}]
+ } else {
+ set round_exponent [expr {$digits + $ea}]
+ set integer_part [ipart [list 0 $ma $round_exponent]]
+
+ switch -- [compare [list 0 $ma $round_exponent] [list 0 ${integer_part}5 -1]] {
+ 0 {
+ # We are rounding something with fractional part .5
+ set mantissa [expr {$integer_part + 1}]
+ }
+ -1 {
+ set mantissa $integer_part
+ }
+ 1 {
+ set mantissa [expr {$integer_part + 1}]
+ }
+
+ }
+ }
+ set exponent [expr {-1 * $digits}]
+ return [list $sa $mantissa $exponent]
+}
+
+# round_half_even --
+# Round to the nearest. If equidistant, round so the final digit is even.
+# Bias: none
+#
+# Arguments:
+# Number in the form of {sign mantisse exponent}
+# Number of decimal points to round to.
+#
+# Result:
+# Number in the form of {sign mantisse exponent}
+#
+proc ::math::decimal::round_half_even {a digits} {
+
+ foreach {sa ma ea} $a {break}
+
+ if { $digits + $ea == 0 } {
+ return $a
+ } elseif { $digits + $ea > 0 } {
+ set mantissa [expr {$ma * 10**($digits+$ea)}]
+ } else {
+ set round_exponent [expr {$digits + $ea}]
+ set integer_part [ipart [list 0 $ma $round_exponent]]
+
+ switch -- [compare [list 0 $ma $round_exponent] [list 0 ${integer_part}5 -1]] {
+ 0 {
+ # We are rounding something with fractional part .5
+ if { $integer_part % 2 } {
+ # We are odd so round up
+ set mantissa [expr {$integer_part + 1}]
+ } else {
+ # We are even so round down
+ set mantissa $integer_part
+ }
+ }
+ -1 {
+ set mantissa $integer_part
+ }
+ 1 {
+ set mantissa [expr {$integer_part + 1}]
+ }
+ }
+ }
+ set exponent [expr {-1 * $digits}]
+ return [list $sa $mantissa $exponent]
+}
+
+# round_half_down --
+#
+# Round to the nearest. If equidistant, round down.
+#
+# Bias: towards zero
+#
+# Arguments:
+# Number in the form of {sign mantisse exponent}
+# Number of decimal points to round to.
+#
+# Result:
+# Number in the form of {sign mantisse exponent}
+#
+proc ::math::decimal::round_half_down {a digits} {
+ foreach {sa ma ea} $a {break}
+
+ if { $digits + $ea == 0 } {
+ return $a
+ } elseif { $digits + $ea > 0 } {
+ set mantissa [expr {$ma * 10**($digits+$ea)}]
+ } else {
+ set round_exponent [expr {$digits + $ea}]
+ set integer_part [ipart [list 0 $ma $round_exponent]]
+ switch -- [compare [list 0 $ma $round_exponent] [list 0 ${integer_part}5 -1]] {
+ 0 {
+ # We are rounding something with fractional part .5
+ # The rule is to round half down.
+ set mantissa $integer_part
+ }
+ -1 {
+ set mantissa $integer_part
+ }
+ 1 {
+ set mantissa [expr {$integer_part + 1}]
+ }
+ }
+ }
+ set exponent [expr {-1 * $digits}]
+ return [list $sa $mantissa $exponent]
+}
+
+# round_down --
+#
+# Round toward 0. (Truncate)
+#
+# Bias: towards zero
+#
+# Arguments:
+# Number in the form of {sign mantisse exponent}
+# Number of decimal points to round to.
+#
+# Result:
+# Number in the form of {sign mantisse exponent}
+#
+proc ::math::decimal::round_down {a digits} {
+ foreach {sa ma ea} $a {break}
+
+
+ if { -$ea== $digits } {
+ return $a
+ } elseif { $digits + $ea > 0 } {
+ set mantissa [expr { $ma * 10**($digits+$ea) }]
+ } else {
+ set round_exponent [expr {$digits + $ea}]
+ set mantissa [ipart [list 0 $ma $round_exponent]]
+ }
+
+ set exponent [expr {-1 * $digits}]
+ return [list $sa $mantissa $exponent]
+}
+
+# round_floor --
+#
+# Round toward -Infinity.
+#
+# Bias: down toward -Inf.
+#
+# Arguments:
+# Number in the form of {sign mantisse exponent}
+# Number of decimal points to round to.
+#
+# Result:
+# Number in the form of {sign mantisse exponent}
+#
+proc ::math::decimal::round_floor {a digits} {
+ foreach {sa ma ea} $a {break}
+
+ if { -$ea== $digits } {
+ return $a
+ } elseif { $digits + $ea > 0 } {
+ set mantissa [expr { $ma * 10**($digits+$ea) }]
+ } else {
+ set round_exponent [expr {$digits + $ea}]
+ if { $ma == 0 } {
+ set mantissa 0
+ } elseif { !$sa } {
+ set mantissa [ipart [list 0 $ma $round_exponent]]
+ } else {
+ set mantissa [expr {[ipart [list 0 $ma $round_exponent]] + 1}]
+ }
+ }
+ set exponent [expr {-1 * $digits}]
+ return [list $sa $mantissa $exponent]
+}
+
+# round_up --
+#
+# Round away from 0
+#
+# Bias: away from 0
+#
+# Arguments:
+# Number in the form of {sign mantisse exponent}
+# Number of decimal points to round to.
+#
+# Result:
+# Number in the form of {sign mantisse exponent}
+#
+proc ::math::decimal::round_up {a digits} {
+ foreach {sa ma ea} $a {break}
+
+
+ if { -$ea== $digits } {
+ return $a
+ } elseif { $digits + $ea > 0 } {
+ set mantissa [expr { $ma * 10**($digits+$ea) }]
+ set exponent [expr {-1 * $digits}]
+ } else {
+ set round_exponent [expr {$digits + $ea}]
+ if { [string length $ma] <= $round_exponent } {
+ if { $ma != 0 } {
+ set mantissa 1
+ } else {
+ set mantissa 0
+ }
+ set exponent 0
+ } else {
+ set integer_part [ipart [list 0 $ma $round_exponent]]
+ switch -- [compare [list 0 $ma $round_exponent] [list 0 ${integer_part}0 -1]] {
+ 0 {
+ # We are rounding something with fractional part .0
+ set mantissa $integer_part
+ }
+ default {
+ set mantissa [expr {$integer_part + 1}]
+ }
+ }
+ set exponent [expr {-1 * $digits}]
+ }
+ }
+ return [list $sa $mantissa $exponent]
+}
+
+# round_ceiling --
+#
+# Round toward Infinity
+#
+# Bias: up toward Inf.
+#
+# Arguments:
+# Number in the form of {sign mantisse exponent}
+# Number of decimal points to round to.
+#
+# Result:
+# Number in the form of {sign mantisse exponent}
+#
+proc ::math::decimal::round_ceiling {a digits} {
+ foreach {sa ma ea} $a {break}
+ if { -$ea== $digits } {
+ return $a
+ } elseif { $digits + $ea > 0 } {
+ set mantissa [expr { $ma * 10**($digits+$ea) }]
+ set exponent [expr {-1 * $digits}]
+ } else {
+ set round_exponent [expr {$digits + $ea}]
+ if { [string length $ma] <= $round_exponent } {
+ if { $ma != 0 } {
+ set mantissa 1
+ } else {
+ set mantissa 0
+ }
+ set exponent 0
+ } else {
+ set integer_part [ipart [list 0 $ma $round_exponent]]
+ switch -- [compare [list 0 $ma $round_exponent] [list 0 ${integer_part}0 -1]] {
+ 0 {
+ # We are rounding something with fractional part .0
+ set mantissa $integer_part
+ }
+ default {
+ if { $sa } {
+ set mantissa [expr {$integer_part}]
+ } else {
+ set mantissa [expr {$integer_part + 1}]
+ }
+ }
+ }
+ set exponent [expr {-1 * $digits}]
+ }
+ }
+
+ return [list $sa $mantissa $exponent]
+}
+
+# is-finite
+#
+# Takes one operand and returns: 1 if neither Inf or Nan otherwise 0.
+#
+#
+# Arguments:
+# a - decimal number
+#
+# Returns:
+#
+proc ::math::decimal::is-finite { a } {
+ set mantissa [lindex $a 1]
+ if { $mantissa == "Inf" || $mantissa == "NaN" } {
+ return 0
+ } else {
+ return 1
+ }
+}
+
+# is-infinite
+#
+# Takes one operand and returns: 1 if Inf otherwise 0.
+#
+#
+# Arguments:
+# a - decimal number
+#
+# Returns:
+#
+proc ::math::decimal::is-infinite { a } {
+ set mantissa [lindex $a 1]
+ if { $mantissa == "Inf" } {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# is-NaN
+#
+# Takes one operand and returns: 1 if NaN otherwise 0.
+#
+#
+# Arguments:
+# a - decimal number
+#
+# Returns:
+#
+proc ::math::decimal::is-NaN { a } {
+ set mantissa [lindex $a 1]
+ if { $mantissa == "NaN" } {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# is-signed
+#
+# Takes one operand and returns: 1 if sign is 1 (negative).
+#
+#
+# Arguments:
+# a - decimal number
+#
+# Returns:
+#
+proc ::math::decimal::is-signed { a } {
+ set sign [lindex $a 0]
+ if { $sign } {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# is-zero
+#
+# Takes one operand and returns: 1 if operand is zero otherwise 0.
+#
+#
+# Arguments:
+# a - decimal number
+#
+# Returns:
+#
+proc ::math::decimal::is-zero { a } {
+ set mantisse [lindex $a 1]
+ if { $mantisse == 0 } {
+ return 1
+ } else {
+ return 0
+ }
+}
diff --git a/tcllib/modules/math/decimal.test b/tcllib/modules/math/decimal.test
new file mode 100755
index 0000000..bc68dfd
--- /dev/null
+++ b/tcllib/modules/math/decimal.test
@@ -0,0 +1,45 @@
+# -*- tcl -*-
+# Tests for decimal arithmetic package in math library -*- tcl -*-
+#
+# This file contains a collection of tests for one or more of the Tcllib
+# procedures. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# $Id: decimal.test,v 1.3 2011/11/09 18:33:22 andreas_kupries Exp $
+#
+# Copyright (c) 2011 by Mark Alston
+# All rights reserved.
+#
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.1
+
+support {
+ useLocal math.tcl math
+}
+testing {
+ useLocal decimal.tcl math::decimal
+}
+
+# -------------------------------------------------------------------------
+
+#
+# Simple tests
+#
+test decimal-plus-1.1 "Sum of two numbers" {
+ math::decimal::tostr \
+ [math::decimal::+ \
+ [math::decimal::fromstr 1.0] \
+ [math::decimal::fromstr 1.00]]
+} 2.00
+
+# -------------------------------------------------------------------------
+
+# End of test cases
+testsuiteCleanup
diff --git a/tcllib/modules/math/elliptic.tcl b/tcllib/modules/math/elliptic.tcl
new file mode 100755
index 0000000..e123318
--- /dev/null
+++ b/tcllib/modules/math/elliptic.tcl
@@ -0,0 +1,242 @@
+# elliptic.tcl --
+# Compute elliptic functions and integrals
+#
+# Computation of elliptic functions cn, dn and sn
+# adapted from:
+# Michael W. Pashea
+# Numerical computation of elliptic functions
+# Doctor Dobbs' Journal, May 2005
+#
+
+# namespace ::math::special
+#
+namespace eval ::math::special {
+ namespace export cn sn dn
+
+ ::math::constants::constants pi
+
+ variable halfpi [expr {$pi/2.0}]
+ variable tol
+
+ set tol 1.0e-10
+}
+
+# elliptic_K --
+# Compute the complete elliptic integral of the first kind
+#
+# Arguments:
+# k Parameter of the integral
+# Result:
+# Value of K(k)
+# Note:
+# This relies on the arithmetic-geometric mean
+#
+proc ::math::special::elliptic_K {k} {
+ variable halfpi
+ if { $k < 0.0 || $k >= 1.0 } {
+ error "Domain error: must be between 0 (inclusive) and 1 (not inclusive)"
+ }
+
+ if { $k == 0.0 } {
+ return $halfpi
+ }
+
+ set a 1.0
+ set b [expr {sqrt(1.0-$k*$k)}]
+
+ for {set i 0} {$i < 10} {incr i} {
+ set anew [expr {($a+$b)/2.0}]
+ set bnew [expr {sqrt($a*$b)}]
+
+ set a $anew
+ set b $bnew
+ #puts "$a $b"
+ }
+
+ return [expr {$halfpi/$a}]
+}
+
+# elliptic_E --
+# Compute the complete elliptic integral of the second kind
+#
+# Arguments:
+# k Parameter of the integral
+# Result:
+# Value of E(k)
+# Note:
+# This relies on the arithmetic-geometric mean
+#
+proc ::math::special::elliptic_E {k} {
+ variable halfpi
+ if { $k < 0.0 || $k >= 1.0 } {
+ error "Domain error: must be between 0 (inclusive) and 1 (not inclusive)"
+ }
+
+ if { $k == 0.0 } {
+ return $halfpi
+ }
+ if { $k == 1.0 } {
+ return 1.0
+ }
+
+ set a 1.0
+ set b [expr {sqrt(1.0-$k*$k)}]
+ set sumc [expr {$k*$k/2.0}]
+ set factor 0.25
+
+ for {set i 0} {$i < 10} {incr i} {
+ set anew [expr {($a+$b)/2.0}]
+ set bnew [expr {sqrt($a*$b)}]
+ set sumc [expr {$sumc+$factor*($a-$b)*($a-$b)}]
+ set factor [expr {$factor*2.0}]
+
+ set a $anew
+ set b $bnew
+ #puts "$a $b"
+ }
+
+ set Kk [expr {$halfpi/$a}]
+ return [expr {(1.0-$sumc)*$Kk}]
+}
+
+namespace eval ::math::special {
+}
+
+# Nextk --
+# Auxiliary function for computing next value of k
+#
+# Arguments:
+# k Parameter
+# Return value:
+# Next value to be used
+#
+proc ::math::special::Nextk { k } {
+ set ksq [expr {sqrt(1.0-$k*$k)}]
+ return [expr {(1.0-$ksq)/(1+$ksq)}]
+}
+
+# IterateUK --
+# Auxiliary function to compute the raw value (phi)
+#
+# Arguments:
+# u Independent variable
+# k Parameter
+# Return value:
+# phi
+#
+proc ::math::special::IterateUK { u k } {
+ variable tol
+ set kvalues {}
+ set nmax 1
+ while { $k > $tol } {
+ set k [Nextk $k]
+ set kvalues [concat $k $kvalues]
+ set u [expr {$u*2.0/(1.0+$k)}]
+ incr nmax
+ #puts "$nmax -$u - $k"
+ }
+ foreach k $kvalues {
+ set u [expr {( $u + asin($k*sin($u)) )/2.0}]
+ }
+ return $u
+}
+
+# cn --
+# Compute the elliptic function cn
+#
+# Arguments:
+# u Independent variable
+# k Parameter
+# Return value:
+# cn(u,k)
+# Note:
+# If k == 1, then the iteration does not stop
+#
+proc ::math::special::cn { u k } {
+ if { $k > 1.0 } {
+ return -code error "Parameter out of range - must be <= 1.0"
+ }
+ if { $k == 1.0 } {
+ return [expr {1.0/cosh($u)}]
+ } else {
+ set u [IterateUK $u $k]
+ return [expr {cos($u)}]
+ }
+}
+
+# sn --
+# Compute the elliptic function sn
+#
+# Arguments:
+# u Independent variable
+# k Parameter
+# Return value:
+# sn(u,k)
+# Note:
+# If k == 1, then the iteration does not stop
+#
+proc ::math::special::sn { u k } {
+ if { $k > 1.0 } {
+ return -code error "Parameter out of range - must be <= 1.0"
+ }
+ if { $k == 1.0 } {
+ return [expr {tanh($u)}]
+ } else {
+ set u [IterateUK $u $k]
+ return [expr {sin($u)}]
+ }
+}
+
+# dn --
+# Compute the elliptic function sn
+#
+# Arguments:
+# u Independent variable
+# k Parameter
+# Return value:
+# dn(u,k)
+# Note:
+# If k == 1, then the iteration does not stop
+#
+proc ::math::special::sn { u k } {
+ if { $k > 1.0 } {
+ return -code error "Parameter out of range - must be <= 1.0"
+ }
+ if { $k == 1.0 } {
+ return [expr {1.0/cosh($u)}]
+ } else {
+ set u [IterateUK $u $k]
+ return [expr {sqrt(1.0-$k*$k*sin($u))}]
+ }
+}
+
+
+# main --
+# Simple tests
+#
+if { 0 } {
+puts "Special cases:"
+puts "cos(1): [::math::special::cn 1.0 0.0] -- [expr {cos(1.0)}]"
+puts "1/cosh(1): [::math::special::cn 1.0 0.999] -- [expr {1.0/cosh(1.0)}]"
+}
+
+# some tests --
+#
+if { 0 } {
+set prec $::tcl_precision
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ set ::tcl_precision 17
+} else {
+ set ::tcl_precision 0
+}
+#foreach k {0.0 0.1 0.2 0.4 0.6 0.8 0.9} {
+# puts "$k: [::math::special::elliptic_K $k]"
+#}
+foreach k2 {0.0 0.1 0.2 0.4 0.6 0.8 0.9} {
+ set k [expr {sqrt($k2)}]
+ puts "$k2: [::math::special::elliptic_K $k] \
+[::math::special::elliptic_E $k]"
+}
+set ::tcl_precision $prec
+}
+
diff --git a/tcllib/modules/math/elliptic.test b/tcllib/modules/math/elliptic.test
new file mode 100755
index 0000000..fee0b5e
--- /dev/null
+++ b/tcllib/modules/math/elliptic.test
@@ -0,0 +1,78 @@
+# -*- tcl -*-
+# eliptic.test --
+# Test cases for the ::math::special package (Elliptic integrals)
+#
+# This file contains a collection of tests for one or more of the Tcllib
+# procedures. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 2004 by Arjen Markus. All rights reserved.
+#
+# RCS: @(#) $Id: elliptic.test,v 1.12 2007/08/21 17:33:00 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4;# statistics,linalg!
+testsNeedTcltest 2.1
+
+support {
+ useLocal math.tcl math
+ useLocal constants.tcl math::constants
+ useLocal linalg.tcl math::linearalgebra ;# for statistics
+ useLocal statistics.tcl math::statistics
+ useLocal polynomials.tcl math::polynomials
+}
+testing {
+ useLocal special.tcl math::special
+}
+
+# -------------------------------------------------------------------------
+
+# As the values were given with four digits, an absolute
+# error is most appropriate
+
+proc matchNumbers {expected actual} {
+ set match 1
+ foreach a $actual e $expected {
+ #puts "abs($a-$e) = [expr {abs($a-$e)}]"
+ if {abs($a-$e) > 0.1e-5} {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+
+::tcltest::customMatch numbers matchNumbers
+
+# -------------------------------------------------------------------------
+
+test "Elliptic-1.0" "Complete elliptic integral of the first kind" \
+ -match numbers -body {
+ set result {}
+ foreach k2 {0.0 0.1 0.2 0.4 0.5 0.7 0.8 0.95} {
+ set k [expr {sqrt($k2)}]
+ lappend result [::math::special::elliptic_K $k]
+ }
+ set result
+ } -result {1.570796 1.612441 1.659624 1.777519 1.854075
+ 2.075363 2.257205 2.908337}
+
+test "Elliptic-2.0" "Complete elliptic integral of the second kind" \
+ -match numbers -body {
+ set result {}
+ foreach k2 {0.0 0.1 0.2 0.4 0.5 0.7 0.8 0.95} {
+ set k [expr {sqrt($k2)}]
+ lappend result [::math::special::elliptic_E $k]
+ }
+ set result
+ } -result {1.570796 1.530758 1.489035 1.399392 1.350644
+ 1.241671 1.17849 1.060474}
+
+
+# End of test cases
+testsuiteCleanup
diff --git a/tcllib/modules/math/exact.man b/tcllib/modules/math/exact.man
new file mode 100644
index 0000000..5c46e0f
--- /dev/null
+++ b/tcllib/modules/math/exact.man
@@ -0,0 +1,218 @@
+[manpage_begin math::exact n 1.0]
+[copyright "2015 Kevin B. Kenny <kennykb@acm.org>
+Redistribution permitted under the terms of the Open\
+Publication License <http://www.opencontent.org/openpub/>"]
+[moddesc {Tcl Math Library}]
+[titledesc {Exact Real Arithmetic}]
+[category Mathematics]
+[require Tcl 8.6]
+[require grammar::aycock 1.0]
+[require math::exact 1.0]
+[description]
+[para]
+The [cmd exactexpr] command in the [cmd math::exact] package
+allows for exact computations over the computable real numbers.
+These are not arbitrary-precision calculations; rather they are
+exact, with numbers represented by algorithms that produce successive
+approximations. At the end of a calculation, the caller can
+request a given precision for the end result, and intermediate results are
+computed to whatever precision is necessary to satisfy the request.
+[section "Procedures"]
+The following procedure is the primary entry into the [cmd math::exact]
+package.
+[list_begin definitions]
+[call [cmd ::math::exact::exactexpr] [arg expr]]
+
+Accepts a mathematical expression in Tcl syntax, and returns an object
+that represents the program to calculate successive approximations to
+the expression's value. The result will be referred to as an
+exact real number.
+
+[call [arg number] [cmd ref]]
+
+Increases the reference count of a given exact real number.
+
+[call [arg number] [cmd unref]]
+
+Decreases the reference count of a given exact real number, and destroys
+the number if the reference count is zero.
+
+[call [arg number] [cmd asPrint] [arg precision]]
+
+Formats the given [arg number] for printing, with the specified [arg precision].
+(See below for how [arg precision] is interpreted). Numbers that are known to
+be rational are formatted as fractions.
+
+[call [arg number] [cmd asFloat] [arg precision]]
+
+Formats the given [arg number] for printing, with the specified [arg precision].
+(See below for how [arg precision] is interpreted). All numbers are formatted
+in floating-point E format.
+
+[list_end]
+
+[section Parameters]
+
+[list_begin definitions]
+
+[def [arg expr]]
+
+Expression to evaluate. The syntax for expressions is the same as it is in Tcl,
+but the set of operations is smaller. See [sectref Expressions] below
+for details.
+
+[def [arg number]]
+
+The object returned by an earlier invocation of [cmd math::exact::exactexpr]
+
+[def [arg precision]]
+
+The requested 'precision' of the result. The precision is (approximately)
+the absolute value of the binary exponent plus the number of bits of the
+binary significand. For instance, to return results to IEEE-754 double
+precision, 56 bits plus the exponent are required. Numbers between 1/2 and 2
+will require a precision of 57; numbers between 1/4 and 1/2 or between 2 and 4
+will require 58; numbers between 1/8 and 1/4 or between 4 and 8 will require
+59; and so on.
+
+[list_end]
+
+[section Expressions]
+
+The [cmd math::exact::exactexpr] command accepts expressions in a subset
+of Tcl's syntax. The following components may be used in an expression.
+
+[list_begin itemized]
+
+[item]Decimal integers.
+[item]Variable references with the dollar sign ([const \$]).
+The value of the variable must be the result of another call to
+[cmd math::exact::exactexpr]. The reference count of the value
+will be increased by one for each position at which it appears
+in the expression.
+[item]The exponentiation operator ([const **]).
+[item]Unary plus ([const +]) and minus ([const -]) operators.
+[item]Multiplication ([const *]) and division ([const /]) operators.
+[item]Parentheses used for grouping.
+[item]Functions. See [sectref Functions] below for the functions that are
+available.
+
+[list_end]
+
+[section Functions]
+
+The following functions are available for use within exact real expressions.
+
+[list_begin definitions]
+
+
+[def [const acos(][arg x][const )]]
+The inverse cosine of [arg x]. The result is expressed in radians.
+The absolute value of [arg x] must be less than 1.
+
+[def [const acosh(][arg x][const )]]
+The inverse hyperbolic cosine of [arg x].
+[arg x] must be greater than 1.
+
+[def [const asin(][arg x][const )]]
+The inverse sine of [arg x]. The result is expressed in radians.
+The absolute value of [arg x] must be less than 1.
+
+[def [const asinh(][arg x][const )]]
+The inverse hyperbolic sine of [arg x].
+
+[def [const atan(][arg x][const )]]
+The inverse tangent of [arg x]. The result is expressed in radians.
+
+[def [const atanh(][arg x][const )]]
+The inverse hyperbolic tangent of [arg x].
+The absolute value of [arg x] must be less than 1.
+
+[def [const cos(][arg x][const )]]
+The cosine of [arg x]. [arg x] is expressed in radians.
+
+[def [const cosh(][arg x][const )]]
+The hyperbolic cosine of [arg x].
+
+[def [const e()]]
+The base of the natural logarithms = [const 2.71828...]
+
+[def [const exp(][arg x][const )]]
+The exponential function of [arg x].
+
+[def [const log(][arg x][const )]]
+The natural logarithm of [arg x]. [arg x] must be positive.
+
+[def [const pi()]]
+The value of pi = [const 3.15159...]
+
+[def [const sin(][arg x][const )]]
+The sine of [arg x]. [arg x] is expressed in radians.
+
+[def [const sinh(][arg x][const )]]
+The hyperbolic sine of [arg x].
+
+[def [const sqrt(][arg x][const )]]
+The square root of [arg x]. [arg x] must be positive.
+
+[def [const tan(][arg x][const )]]
+The tangent of [arg x]. [arg x] is expressed in radians.
+
+[def [const tanh(][arg x][const )]]
+The hyperbolic tangent of [arg x].
+
+[list_end]
+
+[section Summary]
+
+The [cmd math::exact::exactexpr] command provides a system that
+performs exact arithmetic over computable real numbers, representing
+the numbers as algorithms for successive approximation.
+
+An example, which implements the high-school quadratic formula,
+is shown below.
+
+[example {
+namespace import math::exact::exactexpr
+proc exactquad {a b c} {
+ set d [[exactexpr {sqrt($b*$b - 4*$a*$c)}] ref]
+ set r0 [[exactexpr {(-$b - $d) / (2 * $a)}] ref]
+ set r1 [[exactexpr {(-$b + $d) / (2 * $a)}] ref]
+ $d unref
+ return [list $r0 $r1]
+}
+
+set a [[exactexpr 1] ref]
+set b [[exactexpr 200] ref]
+set c [[exactexpr {(-3/2) * 10**-12}] ref]
+lassign [exactquad $a $b $c] r0 r1
+$a unref; $b unref; $c unref
+puts [list [$r0 asFloat 70] [$r1 asFloat 110]]
+$r0 unref; $r1 unref
+}]
+
+The program prints the result:
+[example {
+-2.000000000000000075e2 7.499999999999999719e-15
+}]
+
+Note that if IEEE-754 floating point had been used, a catastrophic
+roundoff error would yield a smaller root that is a factor of two
+too high:
+
+[example {
+-200.0 1.4210854715202004e-14
+}]
+
+The invocations of [cmd exactexpr] should be fairly self-explanatory.
+The other commands of note are [cmd ref] and [cmd unref]. It is necessary
+for the caller to keep track of references to exact expressions - to call
+[cmd ref] every time an exact expression is stored in a variable and
+[cmd unref] every time the variable goes out of scope or is overwritten.
+
+The [cmd asFloat] method emits decimal digits as long as the requested
+precision supports them. It terminates when the requested precision
+yields an uncertainty of more than one unit in the least significant digit.
+
+[vset CATEGORY mathematics]
+[manpage_end]
diff --git a/tcllib/modules/math/exact.tcl b/tcllib/modules/math/exact.tcl
new file mode 100644
index 0000000..177c3df
--- /dev/null
+++ b/tcllib/modules/math/exact.tcl
@@ -0,0 +1,4059 @@
+# exact.tcl --
+#
+# Tcl package for exact real arithmetic.
+#
+# Copyright (c) 2015 by Kevin B. Kenny
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# This package provides a library for performing exact
+# computations over the computable real numbers. The algorithms
+# are largely based on the ones described in:
+#
+# Potts, Peter John. _Exact Real Arithmetic using Möbius Transformations._
+# PhD thesis, University of London, July 1998.
+# http://www.doc.ic.ac.uk/~ae/papers/potts-phd.pdf
+#
+# Some of the algorithms for the elementary functions are found instead
+# in:
+#
+# Menissier-Morain, Valérie. _Arbitrary Precision Real Arithmetic:
+# Design and Algorithms. J. Symbolic Computation 11 (1996)
+# http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.31.8983
+#
+#-----------------------------------------------------------------------------
+
+package require Tcl 8.6
+package require grammar::aycock 1.0
+
+namespace eval math::exact {
+
+ namespace eval function {
+ namespace path ::math::exact
+ }
+ namespace path ::tcl::mathop
+
+ # math::exact::parser --
+ #
+ # Grammar for parsing expressions in the exact real calculator
+ #
+ # The expression syntax is almost exactly that of Tcl expressions,
+ # minus Tcl arrays, square-bracket substitution, and noncomputable
+ # operations such as equality, comparisons, bit and Boolean operations,
+ # and ?:.
+
+ variable parser [grammar::aycock::parser {
+
+ target ::= expression {
+ lindex $_ 0
+ }
+
+ expression ::= expression addop term {
+ {*}$_
+ }
+ expression ::= term {
+ lindex $_ 0
+ }
+ addop ::= + {
+ lindex $_ 0
+ }
+ addop ::= - {
+ lindex $_ 0
+ }
+
+ term ::= term mulop factor {
+ {*}$_
+ }
+ term ::= factor {
+ lindex $_ 0
+ }
+ mulop ::= * {
+ lindex $_ 0
+ }
+ mulop ::= / {
+ lindex $_ 0
+ }
+
+ factor ::= addop factor {
+ switch -exact -- [lindex $_ 0] {
+ + {
+ set result [lindex $_ 1]
+ }
+ - {
+ set result [[lindex $_ 1] U-]
+ }
+ }
+ set result
+ }
+ factor ::= primary ** factor {
+ {*}$_
+ }
+ factor ::= primary {
+ lindex $_ 0
+ }
+
+ primary ::= {$} bareword {
+ uplevel [dict get $clientData caller] set [lindex $_ 1]
+ }
+ primary ::= number {
+ [dict get $clientData namespace]::V new [list [lindex $_ 0] 1]
+ }
+ primary ::= bareword ( ) {
+ [dict get $clientData namespace]::function::[lindex $_ 0]
+ }
+ primary ::= bareword ( arglist ) {
+ [dict get $clientData namespace]::function::[lindex $_ 0] \
+ {*}[lindex $_ 2]
+ }
+ primary ::= ( expression ) {
+ lindex $_ 1
+ }
+ arglist ::= expression {
+ set _
+ }
+ arglist ::= arglist , expression {
+ linsert [lindex $_ 0] end [lindex $_ 2]
+ }
+
+ }]
+}
+
+# math::exact::Lexer --
+#
+# Lexer for the arithmetic expressions that the 'math::exact' package
+# can evaluate.
+#
+# Results:
+# Returns a two element list. The first element is a list of the
+# lexical values of the tokens that were found in the expression;
+# the second is a list of the semantic values of the tokens. The
+# two sublists are the same length.
+
+proc math::exact::Lexer {expression} {
+ set start 0
+ set tokens {}
+ set values {}
+ while {$expression ne {}} {
+ if {[regexp {^\*\*(.*)} $expression -> rest]} {
+
+ # Exponentiation
+
+ lappend tokens **
+ lappend values **
+ } elseif {[regexp {^([-+/*$(),])(.*)} $expression -> token rest]} {
+
+ # Single-character operators
+
+ lappend tokens $token
+ lappend values $token
+ } elseif {[regexp {^([[:alpha:]][[:alnum:]_]*)(.*)} \
+ $expression -> token rest]} {
+
+ # Variable and function names
+
+ lappend tokens bareword
+ lappend values $token
+ } elseif {[regexp -nocase {^([[:digit:]]+)(.*)} $expression -> \
+ token rest] } {
+
+ # Numbers
+
+ lappend tokens number
+ lappend values $token
+
+ } elseif {[regexp {^[[:space:]]+(.*)} $expression -> rest]} {
+
+ # Whitespace
+
+ } else {
+
+ # Anything else is an error
+
+ return -code error \
+ -errorcode [list MATH EXACT EXPR INVCHAR \
+ [string index $expression 0]] \
+ [list invalid character [string index $expression 0]] \
+ }
+ set expression $rest
+ }
+ return [list $tokens $values]
+}
+
+# math::exact::K --
+#
+# K combinator. Returns its first argumetn
+#
+# Parameters:
+# a - Return value
+# b - Value to discard
+#
+# Results:
+# Returns the first argument
+
+proc math::exact::K {a b} {return $a}
+
+# math::exact::exactexpr --
+#
+# Evaluates an exact real expression.
+#
+# Parameters:
+# expr - Expression to evaluate. Variables in the expression are
+# assumed to be reals, which are represented as Tcl objects.
+#
+# Results:
+# Returns a Tcl object representing the expression's value.
+#
+# The returned object must have its refcount incremented with [ref] if
+# the caller retains a reference, and in general it is expected that a
+# user of a real will [ref] the object when storing it in a variable and
+# [unref] it again when the variable goes out of scope or is overwritten.
+
+proc math::exact::exactexpr {expr} {
+ variable parser
+ set result [$parser parse {*}[Lexer $expr] \
+ [dict create \
+ caller "#[expr {[info level] - 1}]" \
+ namespace [namespace current]]]
+}
+
+# Basic data types
+
+# A vector is a list {a b}. It can represent the rational number {a/b}
+
+# A matrix is a list of its columns {{a b} {c d}}. In addition to
+# the ordinary rules of linear algebra, it represents the linear
+# transform (ax+b)/(cx+d).
+
+# If x is presumed to lie in the interval [0, Inf) then this transform
+# applied to x will lie in the interval [b/d, a/c), so the matrix
+# {{a b} {c d}} can represent that interval. The interval [0,Inf)
+# can be represented by the identity matrix {{1 0} {0 1}}
+
+# Moreover, if x = {p/q} is a rational number, then
+# (ax+b)/(cx+d) = (a(p/q)+b)/(c(p/q)+d)
+# = ((ap+bq)/q)/(cp+dq)/q)
+# = (ap+bq)/(cp+dq)
+# which is the rational number represented by {{a c} {b d}} {p q}
+# using the conventional rule of vector-matrix multiplication.
+
+# Note that matrices used for this purpose are unique only up to scaling.
+# If (ax+b)/(cx+d) is a rational number, then (eax+eb)/(ecx+ed) represents
+# the same rational number. This means that matrix inversion may be replaced
+# by matrix reversion: for {{a b} {c d}}, simply form the list of cofactors
+# {{d -b} {-c a}}, without dividing by the determinant. The reverse of a matrix
+# is well defined even if the matrix is singular.
+
+# A tensor of the third degree is a list of its levels:
+# {{{a b} {c d}} {{e f} {g h}}}
+
+# math::exact::gcd --
+#
+# Greatest common divisor of a set of integers
+#
+# Parameters:
+# The integers whose gcd is to be found
+#
+# Results:
+# Returns the gcd
+
+proc math::exact::gcd {a args} {
+ foreach b $args {
+ if {$a > $b} {
+ set t $b; set b $a; set a $t
+ }
+ while {$b > 0} {
+ set t $b
+ set b [expr {$a % $b}]
+ set a $t
+ }
+ }
+ return $a
+}
+
+# math::exact::trans --
+#
+# Transposes a 2x2 matrix or a 2x2x2 tensor
+#
+# Parameters:
+# x - Object to transpose
+#
+# Results:
+# Returns the transpose
+
+proc math::exact::trans {x} {
+ lassign $x ab cd
+ lassign $ab a b
+ lassign $cd c d
+ tailcall list [list $a $c] [list $b $d]
+}
+
+# math::exact::determinant --
+#
+# Calculates the determinant of a 2x2 matrix
+#
+# Parameters:
+# x - Matrix
+#
+# Results:
+# Returns the determinant.
+
+proc math::exact::determinant {x} {
+ lassign $x ab cd
+ lassign $ab a b
+ lassign $cd c d
+ return [expr {$a*$d - $b*$c}]
+}
+
+# math::exact::reverse --
+#
+# Calculates the reverse of a 2x2 matrix, which is its inverse times
+# its determinant.
+#
+# Parameters:
+# x - Matrix
+#
+# Results:
+# Returns reverse[x].
+#
+# Notes:
+# The reverse is well defined even for singular matrices.
+
+proc math::exact::reverse {x} {
+ lassign $x ab cd
+ lassign $ab a b
+ lassign $cd c d
+ tailcall list [list $d [expr {-$b}]] [list [expr {-$c}] $a]
+}
+
+# math::exact::veven --
+#
+# Tests if both components of a 2-vector are even.
+#
+# Parameters:
+# x - Vector to test
+#
+# Results:
+# Returns 1 if both components are even, 0 otherwise.
+
+proc math::exact::veven {x} {
+ lassign $x a b
+ return [expr {($a % 2 == 0) && ($b % 2 == 0)}]
+}
+
+# math::exact::meven --
+#
+# Tests if all components of a 2x2 matrix are even.
+#
+# Parameters:
+# x - Matrix to test
+#
+# Results:
+# Returns 1 if all components are even, 0 otherwise.
+
+proc math::exact::meven {x} {
+ lassign $x a b
+ return [expr {[veven $a] && [veven $b]}]
+}
+
+# math::exact::teven --
+#
+# Tests if all components of a 2x2x2 tensor are even
+#
+# Parameters:
+# x - Tensor to test
+#
+# Results:
+# Returns 1 if all components are even, 0 otherwise
+
+proc math::exact::teven {x} {
+ lassign $x a b
+ return [expr {[meven $a] && [meven $b]}]
+}
+
+# math::exact::vhalf --
+#
+# Divides both components of a 2-vector by 2
+#
+# Parameters:
+# x - Vector to scale
+#
+# Results:
+# Returns the scaled vector
+
+proc math::exact::vhalf {x} {
+ lassign $x a b
+ tailcall list [expr {$a / 2}] [expr {$b / 2}]
+}
+
+# math::exact::mhalf --
+#
+# Divides all components of a 2x2 matrix by 2
+#
+# Parameters:
+# x - Matrix to scale
+#
+# Results:
+# Returns the scaled matrix
+
+proc math::exact::mhalf {x} {
+ lassign $x a b
+ tailcall list [vhalf $a] [vhalf $b]
+}
+
+# math::exact::thalf --
+#
+# Divides all components of a 2x2x2 tensor by 2
+#
+# Parameters:
+# x - Tensor to scale
+#
+# Results:
+# Returns the scaled tensor
+
+proc math::exact::thalf {x} {
+ lassign $x a b
+ tailcall list [mhalf $a] [mhalf $b]
+}
+
+# math::exact::vscale --
+#
+# Removes all common factors of 2 from the two components of a 2-vector
+#
+# Paramters:
+# x - Vector to scale
+#
+# Results:
+# Returns the scaled vector
+
+proc math::exact::vscale {x} {
+ while {[veven $x]} {
+ set x [vhalf $x]
+ }
+ return $x
+}
+
+# math::exact::mscale --
+#
+# Removes all common factors of 2 from the two components of a
+# 2x2 matrix
+#
+# Paramters:
+# x - Matrix to scale
+#
+# Results:
+# Returns the scaled matrix
+
+proc math::exact::mscale {x} {
+ while {[meven $x]} {
+ set x [mhalf $x]
+ }
+ return $x
+}
+
+# math::exact::tscale --
+#
+# Removes all common factors of 2 from the two components of a
+# 2x2x2 tensor
+#
+# Paramters:
+# x - Tensor to scale
+#
+# Results:
+# Returns the scaled tensor
+
+proc math::exact::tscale {x} {
+ while {[teven $x]} {
+ set x [thalf $x]
+ }
+ return $x
+}
+
+# math::exact::vreduce --
+#
+# Reduces a vector (i.e., a rational number) to lowest terms
+#
+# Parameters:
+# x - Vector to scale
+#
+# Results:
+# Returns the scaled vector
+
+proc math::exact::vreduce {x} {
+ lassign $x a b
+ set g [gcd $a $b]
+ tailcall list [expr {$a / $g}] [expr {$b / $g}]
+}
+
+# math::exact::mreduce --
+#
+# Removes all common factors from the two components of a
+# 2x2 matrix
+#
+# Paramters:
+# x - Matrix to scale
+#
+# Results:
+# Returns the scaled matrix
+#
+# This procedure suffices to reduce the matrix to lowest terms if the matrix
+# was constructed by pre- or post-multiplying a series of sign and digit
+# matrices.
+
+proc math::exact::mreduce {x} {
+ lassign $x ab cd
+ lassign $ab a b
+ lassign $cd c d
+ set g [gcd $a $b $c $d]
+ tailcall list \
+ [list [expr {$a / $g}] [expr {$b / $g}]] \
+ [list [expr {$c / $g}] [expr {$d / $g}]]
+}
+
+# math::exact::treduce --
+#
+# Removes all common factors from the components of a
+# 2x2x2 tensor
+#
+# Paramters:
+# x - Tensor to scale
+#
+# Results:
+# Returns the scaled tensor
+#
+# This procedure suffices to reduce a tensor to lowest terms if it was
+# constructed by absorbing a digit matrix into a tensor that was already
+# in lowest terms.
+
+proc math::exact::treduce {x} {
+ lassign $x abcd efgh
+ lassign $abcd ab cd
+ lassign $ab a b
+ lassign $cd c d
+ lassign $efgh ef gh
+ lassign $ef e f
+ lassign $gh g h
+ set G [gcd $a $b $c $d $e $f $g $h]
+ tailcall list \
+ [list \
+ [list [expr {$a / $G}] [expr {$b / $G}]] \
+ [list [expr {$c / $G}] [expr {$d / $G}]]] \
+ [list \
+ [list [expr {$e / $G}] [expr {$f / $G}]] \
+ [list [expr {$g / $G}] [expr {$h / $G}]]]
+}
+
+# math::exact::vadd --
+#
+# Adds two 2-vectors
+#
+# Parameters:
+# x - First vector
+# y - Second vector
+#
+# Results:
+# Returns the vector sum
+
+proc math::exact::vadd {x y} {
+ lmap p $x q $y {expr {$p + $q}}
+}
+
+# math::exact::madd --
+#
+# Adds two 2x2 matrices
+#
+# Parameters:
+# A - First matrix
+# B - Second matrix
+#
+# Results:
+# Returns the matrix sum
+
+proc math::exact::madd {A B} {
+ lmap x $A y $B {
+ lmap p $x q $y {expr {$p + $q}}
+ }
+}
+
+# math::exact::tadd --
+#
+# Adds two 2x2x2 tensors
+#
+# Parameters:
+# U - First tensor
+# V - Second tensor
+#
+# Results:
+# Returns the tensor sum
+
+proc math::exact::tadd {U V} {
+ lmap A $U B $V {
+ lmap x $A y $B {
+ lmap p $x q $y {expr {$p + $q}}
+ }
+ }
+}
+
+# math::exact::mdotv --
+#
+# 2x2 matrix times 2-vector
+#
+# Parameters;
+# A - Matrix
+# x - Vector
+#
+# Results:
+# Returns the product vector
+
+proc math::exact::mdotv {A x} {
+ lassign $A ab cd
+ lassign $ab a b
+ lassign $cd c d
+ lassign $x e f
+ tailcall list [expr {$a*$e + $c*$f}] [expr {$b*$e + $d*$f}]
+}
+
+# math::exact::mdotm --
+#
+# Product of two matrices
+#
+# Parameters:
+# A - Left matrix
+# B - Right matrix
+#
+# Results:
+# Returns the matrix product
+
+proc math::exact::mdotm {A B} {
+ lassign $B x y
+ tailcall list [mdotv $A $x] [mdotv $A $y]
+}
+
+# math::exact::mdott --
+#
+# Product of a matrix and a tensor
+#
+# Parameters:
+# A - Matrix
+# T - Tensor
+#
+# Results:
+# Returns the product tensor
+
+proc math::exact::mdott {A T} {
+ lassign $T B C
+ tailcall list [mdotm $A $B] [mdotm $A $C]
+}
+
+# math::exact::trightv --
+#
+# Right product of a tensor and a vector
+#
+# Parameters:
+# T - Tensor
+# v - Right-hand vector
+#
+# Results:
+# Returns the product matrix
+
+proc math::exact::trightv {T v} {
+ lassign $T m n
+ tailcall list [mdotv $m $v] [mdotv $n $v]
+}
+
+# math::exact::trightm --
+#
+# Right product of a tensor and a matrix
+#
+# Parameters:
+# T - Tensor
+# A - Right-hand matrix
+#
+# Results:
+# Returns the product tensor
+
+proc math::exact::trightm {T A} {
+ lassign $T m n
+ tailcall list [mdotm $m $A] [mdotm $n $A]
+}
+
+# math::exact::tleftv --
+#
+# Left product of a tensor and a vector
+#
+# Parameters:
+# T - Tensor
+# v - Left-hand vector
+#
+# Results:
+# Returns the product matrix
+
+proc math::exact::tleftv {T v} {
+ tailcall trightv [trans $T] $v
+}
+
+# math::exact::tleftm --
+#
+# Left product of a tensor and a matrix
+#
+# Parameters:
+# T - Tensor
+# A - Left-hand matrix
+#
+# Results:
+# Returns the product tensor
+
+proc math::exact::tleftm {T A} {
+ tailcall trans [trightm [trans $T] $A]
+}
+
+# math::exact::vsign --
+#
+# Computes the 'sign function' of a vector.
+#
+# Parameters:
+# v - Vector whose sign function is needed
+#
+# Results:
+# Returns the result of the sign function.
+#
+# a b sign
+# - - -1
+# - 0 -1
+# - + 0
+# 0 - -1
+# 0 0 0
+# 0 + 1
+# + - 0
+# + 0 1
+# + + 1
+#
+# If the quotient a/b is negative or indeterminate, the result is zero.
+# If the quotient a/b is zero, the result is the sign of b.
+# If the quotient a/b is positive, the result is the common sign of the
+# operands, which are known to be of like sign
+# If the quotient a/b is infinite, the result is the sign of a.
+
+proc math::exact::sign {v} {
+ lassign $v a b
+ if {$a < 0} {
+ if {$b <= 0} {
+ return -1
+ } else {
+ return 0
+ }
+ } elseif {$a == 0} {
+ if {$b < 0} {
+ return -1
+ } elseif {$b == 0} {
+ return 0
+ } else {
+ return 1
+ }
+ } else {
+ if {$b < 0} {
+ return 0
+ } else {
+ return 1
+ }
+ }
+}
+
+# math::exact::vrefines --
+#
+# Test if a vector refines.
+#
+# Parameters:
+# v - Vector to test
+#
+# Results:
+# 1 if the vector refines, 0 otherwise.
+
+proc math::exact::vrefines {v} {
+ return [expr {[sign $v] != 0}]
+}
+
+# math::exact::mrefines --
+#
+# Test whether a matrix refines
+#
+# Parameters:
+# A - Matrix to test
+#
+# Results:
+# 1 if the matrix refines, 0 otherwise.
+
+proc math::exact::mrefines {A} {
+ lassign $A v w
+ set a [sign $v]
+ set b [sign $w]
+ return [expr {$a == $b && $b != 0}]
+}
+
+# math::exact::trefines --
+#
+# Tests whether a tensor refines
+#
+# Parameters:
+# T - Tensor to test.
+#
+# Results:
+# 1 if the tensor refines, 0 otherwise.
+
+proc math::exact::trefines {T} {
+ lassign $T vw xy
+ lassign $vw v w
+ lassign $xy x y
+ set a [sign $v]
+ set b [sign $w]
+ set c [sign $x]
+ set d [sign $y]
+ return [expr {$a == $b && $b == $c && $c == $d && $d != 0}]
+}
+
+# math::exact::vlessv -
+#
+# Test whether one rational is less than another
+#
+# Parameters:
+# v, w - Two rational numbers
+#
+# Returns:
+# The result of the comparison.
+
+proc math::exact::vlessv {v w} {
+ expr {[determinant [list $v $w]] < 0}
+}
+
+# math::exact::mlessv -
+#
+# Tests whether a rational interval is less than a vector
+#
+# Parameters:
+# m - Matrix representing the interval
+# x - Rational to compare against
+#
+# Results:
+# Returns 1 if m < x, 0 otherwise
+
+proc math::exact::mlessv {m x} {
+ lassign $m v w
+ expr {[vlessv $v $x] && [vlessv $w $x]}
+}
+
+# math::exact::mlessm -
+#
+# Tests whether one rational interval is strictly less than another
+#
+# Parameters:
+# m - First interval
+# n - Second interval
+#
+# Results:
+# Returns 1 if m < n, 0 otherwise
+
+proc math::exact::mlessm {m n} {
+ lassign $n v w
+ expr {[mlessv $m $v] && [mlessv $m $w]}
+}
+
+# math::exact::mdisjointm -
+#
+# Tests whether two rational intervals are disjoint
+#
+# Parameters:
+# m - First interval
+# n - Second interval
+#
+# Results:
+# Returns 1 if the intervals are disjoint, 0 otherwise
+
+proc math::exact::mdisjointm {m n} {
+ expr {[mlessm $m $n] || [mlessm $n $m]}
+}
+
+# math::exact::mAsFloat
+#
+# Formats a matrix that represents a rational interval as a floating
+# point number, stopping as soon as a digit is not determined.
+#
+# Parameters:
+# m - Matrix to format
+#
+# Results:
+# Returns the floating point number in scientific notation, with no
+# digits to the left of the decimal point.
+
+proc math::exact::mAsFloat {m} {
+
+ # Special case: If a number is exact, the determinant is zero.
+
+ set d [determinant $m]
+ lassign [lindex $m 0] p q
+ if {$d == 0} {
+ if {$q < 0} {
+ set p [expr {-$p}]
+ set q [expr {-$q}]
+ }
+ if {$p == 0} {
+ if {$q == 0} {
+ return NaN
+ } else {
+ return 0
+ }
+ } elseif {$q == 0} {
+ return Inf
+ } elseif {$q == 1} {
+ return $p
+ } else {
+ set G [gcd $p $q]
+ return [expr {$p/$G}]/[expr {$q/$G}]
+ }
+ } else {
+ tailcall eFormat [scientificNotation $m]
+ }
+}
+
+# math::exact::scientificNotation --
+#
+# Takes a matrix representing a rational interval, and extracts as
+# many decimal digits as can be determined unambiguously
+#
+# Parameters:
+# m - Matrix to format
+#
+# Results:
+# Returns a list comprising the decimal exponent, followed by a series of
+# digits of the significand. The decimal point is to the left of the
+# leftmost digit of the significand.
+#
+# Returns the empty string if a number is entirely undetermined.
+
+proc math::exact::scientificNotation {m} {
+ set n 0
+ while {1} {
+ if {[vrefines [mdotv [reverse $m] {1 0}]]} {
+ return {}
+ } elseif {[mrefines [mdotm $math::exact::iszer $m]]} {
+ return [linsert [mantissa $m] 0 $n]
+ } else {
+ set m [mdotm {{1 0} {0 10}} $m]
+ incr n
+ }
+ }
+}
+
+# math::exact::mantissa --
+#
+# Given a matrix m that represents a rational interval whose
+# endpoints are in [0,1), formats as many digits of the represented
+# number as possible.
+#
+# Parameters:
+# m - Matrix to format
+#
+# Results:
+# Returns a list of digits
+
+proc math::exact::mantissa {m} {
+ set retval {}
+ set done 0
+ while {!$done} {
+ set done 1
+
+ # Brute force: try each digit in turn. This could no doubt be
+ # improved on.
+
+ for {set j -9} {$j <= 9} {incr j} {
+ set digitMatrix \
+ [list [list [expr {$j+1}] 10] [list [expr {$j-1}] 10]]
+ if {[mrefines [mdotm [reverse $digitMatrix] $m]]} {
+ lappend retval $j
+ set nextdigit [list {10 0} [list [expr {-$j}] 1]]
+ set m [mdotm $nextdigit $m]
+ set done 0
+ break
+ }
+ }
+ }
+ return $retval
+}
+
+# math::exact::eFormat --
+#
+# Formats a decimal exponent and significand in E format
+#
+# Parameters:
+# expAndDigits - List whose first element is the exponent and
+# whose remaining elements are the digits of the
+# significand.
+
+proc math::exact::eFormat {expAndDigits} {
+
+ # An empty sequence of digits is an indeterminate number
+
+ if {[llength $expAndDigits] < 2} {
+ return Undetermined
+ }
+ set significand [lassign $expAndDigits exponent]
+
+ # Accumulate the digits
+ set v 0
+ foreach digit $significand {
+ set v [expr {10 * $v + $digit}]
+ }
+
+ # Adjust the exponent if the significand has too few digits.
+
+ set l [llength $significand]
+ while {$l > 0 && abs($v) < 10**($l-1)} {
+ incr l -1
+ incr exponent -1
+ }
+ incr exponent -1
+
+ # Put in the sign
+
+ if {$v < 0} {
+ set result -
+ set v [expr {-$v}]
+ } else {
+ set result {}
+ }
+
+ # Put in the significand with the decimal point after the leading digit.
+
+ if {$v == 0} {
+ append result 0
+ } else {
+ append result [string index $v 0] . [string range $v 1 end]
+ }
+
+ # Put in the exponent
+
+ append result e $exponent
+
+ return $result
+}
+
+# math::exact::showRat --
+#
+# Formats an exact rational for printing in E format.
+#
+# Parameters:
+# v - Two-element list of numerator and denominator.
+#
+# Results:
+# Returns the quotient in E format. Nonzero/zero == Infinity,
+# 0/0 == NaN.
+
+proc math::exact::showRat {v} {
+ lassign $v p q
+ if {$p != 0 || $q != 0} {
+ return [format %e [expr {double($p)/double($q)}]]
+ } else {
+ return NaN
+ }
+}
+
+# math::exact::showInterval --
+#
+# Formats a rational interval for printing
+#
+# Parameters:
+# m - Matrix representing the interval
+#
+# Results:
+# Returns a string representing the interval in E format.
+
+proc math::exact::showInterval {m} {
+ lassign $m v w
+ return "\[[showRat $w] .. [showRat $v]\]"
+}
+
+# math::exact::showTensor --
+#
+# Formats a tensor for printing
+#
+# Parameters:
+# t - Tensor to print
+#
+# Results:
+# Returns a string containing the left and right matrices of the
+# tensor, each represented as an interval.
+
+proc math::exact::showTensor {t} {
+ lassign $t m n
+ return [list [showInterval $m] [showInterval $n]]
+}
+
+# math::exact::counted --
+#
+# Reference counted object
+
+oo::class create math::exact::counted {
+ variable refcount_
+
+ # Constructor builds an object with a zero refcount.
+ constructor {} {
+ if 0 {
+ puts {}
+ puts "construct: [self object] refcount now 0"
+ for {set i [info frame]} {$i > 0} {incr i -1} {
+ set frame [info frame $i]
+ if {[dict get $frame type] eq {source}} {
+ set line [dict get $frame line]
+ puts "\t[file tail [dict get $frame file]]:$line"
+ if {$line < 0} {
+ if {[dict exists $frame proc]} {
+ puts "\t\t[dict get $frame proc]"
+ }
+ puts "\t\t\[[dict get $frame cmd]\]"
+ }
+ } else {
+ puts $frame
+ }
+ }
+ }
+ incr refcount_
+ set refcount_ 0
+ }
+
+ # The 'ref' method adds a reference to this object, and returns this object
+ method ref {} {
+ if 0 {
+ puts {}
+ puts "ref: [self object] refcount now [expr {$refcount_ + 1}]"
+ if {$refcount_ == 0} {
+ puts "\t[my dump]"
+ }
+ for {set i [info frame]} {$i > 0} {incr i -1} {
+ set frame [info frame $i]
+ if {[dict get $frame type] eq {source}} {
+ set line [dict get $frame line]
+ puts "\t[file tail [dict get $frame file]]:$line"
+ if {$line < 0} {
+ if {[dict exists $frame proc]} {
+ puts "\t\t[dict get $frame proc]"
+ }
+ puts "\t\t\[[dict get $frame cmd]\]"
+ }
+ } else {
+ puts $frame
+ }
+ }
+ }
+ incr refcount_
+ return [self]
+ }
+
+ # The 'unref' method removes a reference from this object, and destroys
+ # this object if the refcount becomes nonpositive.
+ method unref {} {
+ if 0 {
+ puts {}
+ puts "unref: [self object] refcount now [expr {$refcount_ - 1}]"
+ for {set i [info frame]} {$i > 0} {incr i -1} {
+ set frame [info frame $i]
+ if {[dict get $frame type] eq {source}} {
+ set line [dict get $frame line]
+ puts "\t[file tail [dict get $frame file]]:$line"
+ if {$line < 0} {
+ if {[dict exists $frame proc]} {
+ puts "\t\t[dict get $frame proc]"
+ }
+ puts "\t\t\[[dict get $frame cmd]\]"
+ }
+ }
+ }
+ }
+
+ # Destroying this object can result in a long chain of object
+ # destruction and eventually a stack overflow. Instead of destroying
+ # immediately, list the objects to be destroyed in
+ # math::exact::deleteStack, and destroy them only from the outermost
+ # stack level that's running 'unref'.
+
+ if {[incr refcount_ -1] <= 0} {
+ variable ::math::exact::deleteStack
+
+ # Is this the outermost level?
+ set queueActive [expr {[info exists deleteStack]}]
+
+ # Schedule this object's destruction
+ lappend deleteStack [self object]
+ if {!$queueActive} {
+
+ # At outermost level, destroy all scheduled objects.
+ # Destroying one may schedule another.
+ while {[llength $deleteStack] != 0} {
+ set obj [lindex $deleteStack end]
+ set deleteStack \
+ [lreplace $deleteStack[set deleteStack {}] end end]
+ $obj destroy
+ }
+
+ # Once everything quiesces, delete the list.
+ unset deleteStack
+ }
+ }
+ }
+
+ # The 'refcount' method returns the reference count of this object for
+ # debugging.
+ method refcount {} {
+ return $refcount_
+ }
+
+ destructor {
+ }
+}
+
+# An expression is a vector, a matrix applied to an expression,
+# or a tensor applied to two expressions. The inner expressions
+# may be constructed lazily.
+
+oo::class create math::exact::Expression {
+ superclass math::exact::counted
+
+ # absorbed_, signAndMagnitude_, and leadingDigitAndRest_
+ # memoize the return values of the 'absorb', 'getSignAndMagnitude',
+ # and 'getLeadingDigitAndRest' methods.
+
+ variable absorbed_ signAndMagnitude_ leadingDigitAndRest_
+
+ # Constructor initializes refcount
+ constructor {} {
+ next
+ }
+
+ # Destructor releases memoized objects
+ destructor {
+ if {[info exists signAndMagnitude_]} {
+ [lindex $signAndMagnitude_ 1] unref
+ }
+ if {[info exists absorbed_]} {
+ $absorbed_ unref
+ }
+ if {[info exists leadingDigitAndRest_]} {
+ [lindex $leadingDigitAndRest_ 1] unref
+ }
+ next
+ }
+
+ # getSignAndMagnitude returns a two-element list:
+ # the sign matrix, which is one of ispos, isneg, isinf, and iszer,
+ # the magnitude, which is another exact real.
+ method getSignAndMagnitude {} {
+ if {![info exists signAndMagnitude_]} {
+ if {[my refinesM $::math::exact::ispos]} {
+ set signAndMagnitude_ \
+ [list $::math::exact::spos \
+ [[my applyM $::math::exact::ispos] ref]]
+ } elseif {[my refinesM $::math::exact::isneg]} {
+ set signAndMagnitude_ \
+ [list $::math::exact::sneg \
+ [[my applyM $::math::exact::isneg] ref]]
+ } elseif {[my refinesM $::math::exact::isinf]} {
+ set signAndMagnitude_ \
+ [list $::math::exact::sinf \
+ [[my applyM $::math::exact::isinf] ref]]
+ } elseif {[my refinesM $::math::exact::iszer]} {
+ set signAndMagnitude_ \
+ [list $::math::exact::szer \
+ [[my applyM $::math::exact::iszer] ref]]
+ } else {
+ set absorbed_ [my absorb]
+ set signAndMagnitude_ [$absorbed_ getSignAndMagnitude]
+ [lindex $signAndMagnitude_ 1] ref
+ }
+ }
+ return $signAndMagnitude_
+ }
+
+ # The 'getLeadingDigitAndRest' method accepts a flag for whether
+ # a digit must be extracted (1) or a rational number may be returned
+ # directly (0). It returns a two-element list: a digit matrix, which
+ # is one of $dpos, $dneg or $dzer, and an exact real representing
+ # the number by which the given digit matrix must be postmultiplied.
+ method getLeadingDigitAndRest {needDigit} {
+ if {![info exists leadingDigitAndRest_]} {
+ if {[my refinesM $::math::exact::idpos]} {
+ set leadingDigitAndRest_ \
+ [list $::math::exact::dpos \
+ [[my applyM $::math::exact::idpos] ref]]
+ } elseif {[my refinesM $::math::exact::idneg]} {
+ set leadingDigitAndRest_ \
+ [list $::math::exact::dneg \
+ [[my applyM $::math::exact::idneg] ref]]
+ } elseif {[my refinesM $::math::exact::idzer]} {
+ set leadingDigitAndRest_ \
+ [list $::math::exact::dzer \
+ [[my applyM $::math::exact::idzer] ref]]
+ } else {
+ set absorbed_ [my absorb]
+ set newval $absorbed_
+ $newval ref
+ set leadingDigitAndRest_ \
+ [$newval getLeadingDigitAndRest $needDigit]
+ if {[llength $leadingDigitAndRest_] >= 2} {
+ [lindex $leadingDigitAndRest_ 1] ref
+ }
+ $newval unref
+ }
+ }
+ return $leadingDigitAndRest_
+ }
+
+ # getInterval --
+ # Accumulates 'nDigits' digit matrices, and returns their product,
+ # which is a matrix representing the interval that the digits represent.
+ method getInterval {nDigits} {
+ lassign [my getSignAndMagnitude] interval e
+ $e ref
+ lassign [$e getLeadingDigitAndRest 1] ld f
+ set interval [math::exact::mdotm $interval $ld]
+ $f ref; $e unref; set e $f
+ set d $ld
+ while {[incr nDigits -1] > 0} {
+ lassign [$e getLeadingDigitAndRest 1] d f
+ set interval [math::exact::mdotm $interval $d]
+ $f ref; $e unref; set e $f
+ }
+ $e unref
+ return $interval
+ }
+
+ # asReal --
+ # Coerces an object from rational to real
+ #
+ # Parameters:
+ # None.
+ #
+ # Results:
+ # Returns this object
+ method asReal {} {self object}
+
+ # asFloat --
+ # Represents this number in E format, after accumulating 'relDigits'
+ # digit matrices.
+ method asFloat {relDigits} {
+ set v [[my asReal] ref]
+ set result [math::exact::mAsFloat [$v getInterval $relDigits]]
+ $v unref
+ return $result
+ }
+
+ # asPrint --
+ # Represents this number for printing. Represents rationals exactly,
+ # others after accumulating 'relDigits' digit matrices.
+ method asPrint {relDigits} {
+ tailcall math::exact::mAsFloat [my getInterval $relDigits]
+ }
+
+ # Derived classes are expected to implement the following methods:
+ # method dump {} {
+ # # Formats the object for debugging
+ # # Returns the formatted string
+ # }
+ method dump {} {
+ error "[info object class [self object]] does not implement the 'dump' method."
+ }
+
+ # method refinesM {m} {
+ # # Returns 1 if premultiplying by the matrix m refines this object
+ # # Returns 0 otherwise
+ # }
+ method refinesM {m} {
+ error "[info object class [self object]] does not implement the 'refinesM' method."
+ }
+
+ # method applyM {m} {
+ # # Premultiplies this object by the matrix m
+ # }
+ method applyM {m} {
+ error "[info object class [self object]] does not implement the 'applyM' method."
+ }
+
+ # method applyTLeft {t r} {
+ # # Computes the left product of the tensor t with this object, and
+ # # applies the result to the right operand r.
+ # # Returns a new exact real representing the product
+ # }
+ method applyTLeft {t r} {
+ error "[info object class [self object]] does not implement the 'applyTLeft' method."
+ }
+
+ # method applyTRight {t l} {
+ # # Computes the right product of the tensor t with this object, and
+ # # applies the result to the left operand l.
+ # # Returns a new exact real representing the product
+ # }
+ method applyTRight {t l} {
+ error "[info object class [self object]] does not implement the 'applyTRight' method."
+ }
+
+ # method absorb {} {
+ # # Absorbs the next subexpression or digit into this expression
+ # # Returns the result of absorption, which always represents a
+ # # smaller interval than this expression
+ # }
+ method absorb {} {
+ error "[info object class [self object]] does not implement the 'absorb' method."
+ }
+
+ # U- --
+ #
+ # Unary - applied to this object
+ #
+ # Results:
+ # Returns the negation.
+
+ method U- {} {
+ my ref
+ lassign [my getSignAndMagnitude] sA mA
+ set m [math::exact::mdotm {{-1 0} {0 1}} $sA]
+ set result [math::exact::Mstrict new $m $mA]
+ my unref
+ return $result
+ }; export U-
+
+ # + --
+ # Adds this object to another.
+ #
+ # Parameters:
+ # r - Right addend
+ #
+ # Results:
+ # Returns the sum
+ #
+ # Either object may be rational (an instance of V) or real (any other
+ # Expression).
+ #
+ # This method is a Consumer with respect to the current object and to r.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method + {r} {
+ return [$r E+ [self object]]
+ }; export +
+
+ # E+ --
+ # Adds two exact reals.
+ #
+ # Parameters:
+ # l - Left addend
+ #
+ # Results:
+ # Returns the sum.
+ #
+ # Neither object is an instance of V (that is, neither is a rational).
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method E+ {l} {
+ tailcall math::exact::+real $l [self object]
+ }; export E+
+
+ # V+ --
+ # Adds a rational and an exact real
+ #
+ # Parameters:
+ # l - Left addend
+ #
+ # Results:
+ # Returns the sum.
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method V+ {l} {
+ tailcall math::exact::+real $l [self object]
+ }; export V+
+
+ # - --
+ # Subtracts another object from this object
+ #
+ # Parameters:
+ # r - Subtrahend
+ #
+ # Results:
+ # Returns the difference
+ #
+ # Either object may be rational (an instance of V) or real (any other
+ # Expression).
+ #
+ # This method is a Consumer with respect to the current object and to r.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method - {r} {
+ return [$r E- [self object]]
+ }; export -
+
+ # E- --
+ # Subtracts this exact real from another
+ #
+ # Parameters:
+ # l - Minuend
+ #
+ # Results:
+ # Returns the difference
+ #
+ # Neither object is an instance of V (that is, neither is a rational).
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method E- {l} {
+ tailcall math::exact::-real $l [self object]
+ }; export E-
+
+ # V- --
+ # Subtracts this exact real from a rational
+ #
+ # Parameters:
+ # l - Minuend
+ #
+ # Results:
+ # Returns the difference
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method V- {l} {
+ tailcall math::exact::-real $l [self object]
+ }; export V-
+
+ # * --
+ # Multiplies this object by another.
+ #
+ # Parameters:
+ # r - Right argument to the multiplication
+ #
+ # Results:
+ # Returns the product
+ #
+ # Either object may be rational (an instance of V) or real (any other
+ # Expression).
+ #
+ # This method is a Consumer with respect to the current object and to r.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method * {r} {
+ return [$r E* [self object]]
+ }; export *
+
+ # E* --
+ # Multiplies two exact reals.
+ #
+ # Parameters:
+ # l - Left argument to the multiplication
+ #
+ # Results:
+ # Returns the product.
+ #
+ # Neither object is an instance of V (that is, neither is a rational).
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method E* {l} {
+ tailcall math::exact::*real $l [self object]
+ }; export E*
+
+ # V* --
+ # Multiplies a rational and an exact real
+ #
+ # Parameters:
+ # l - Left argument to the multiplication
+ #
+ # Results:
+ # Returns the product.
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method V* {l} {
+ tailcall math::exact::*real $l [self object]
+ }; export V*
+
+ # / --
+ # Divides this object by another.
+ #
+ # Parameters:
+ # r - Divisor
+ #
+ # Results:
+ # Returns the quotient
+ #
+ # Either object may be rational (an instance of V) or real (any other
+ # Expression).
+ #
+ # This method is a Consumer with respect to the current object and to r.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method / {r} {
+ return [$r E/ [self object]]
+ }; export /
+
+ # E/ --
+ # Divides two exact reals.
+ #
+ # Parameters:
+ # l - Dividend
+ #
+ # Results:
+ # Returns the quotient.
+ #
+ # Neither object is an instance of V (that is, neither is a rational).
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method E/ {l} {
+ tailcall math::exact::/real $l [self object]
+ }; export E/
+
+ # V/ --
+ # Divides a rational by an exact real
+ #
+ # Parameters:
+ # l - Dividend
+ #
+ # Results:
+ # Returns the product.
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method V/ {l} {
+ tailcall math::exact::/real $l [self object]
+ }; export V/
+
+ # ** -
+ # Raises an exact real to a power
+ #
+ # Parameters:
+ # r - Exponent
+ #
+ # Results:
+ # Returns the power.
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method ** {r} {
+ tailcall $r E** [self object]
+ }; export **
+
+ # E** -
+ # Raises an exact real to the power of an exact real
+ #
+ # Parameters:
+ # l - Base to exponentiate
+ #
+ # Results:
+ # Returns the power
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method E** {l} {
+ # This doesn't work as a tailcall, because this object could have
+ # been destroyed by the time we're trying to invoke the tailcall,
+ # and that will keep command names from resolving because the
+ # tailcall mechanism will try to find them in the destroyed namespace.
+ return [math::exact::function::exp \
+ [my * [math::exact::function::log $l]]]
+ }; export E**
+
+ # V** -
+ # Raises a rational to the power of an exact real
+ #
+ # Parameters:
+ # l - Base to exponentiate
+ #
+ # Results:
+ # Returns the power
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method V** {l} {
+ # This doesn't work as a tailcall, because this object could have
+ # been destroyed by the time we're trying to invoke the tailcall,
+ # and that will keep command names from resolving because the
+ # tailcall mechanism will try to find them in the destroyed namespace.
+ return [math::exact::function::exp \
+ [my * [math::exact::function::log $l]]]
+ }; export V**
+
+ # sqrt --
+ #
+ # Create an expression representing the square root of an exact
+ # real argument.
+ #
+ # Results:
+ # Returns the square root.
+ #
+ # This procedure is a Consumer with respect the the argument and a
+ # Constructor with respect to the result, returning a zero-reference
+ # result.
+
+ method sqrt {} {
+ variable ::math::exact::isneg
+ variable ::math::exact::idzer
+ variable ::math::exact::idneg
+ variable ::math::exact::idpos
+
+ # The algorithm is a modified Newton-Raphson from the Potts and
+ # Menissier-Morain papers. The algorithm for sqrt(x) converges
+ # rapidly only if x is close to 1, so we rescale to make sure that
+ # x is between 1/3 and 3. Specifically:
+ # - if x is known to be negative (that is, if $idneg refines it)
+ # then error.
+ # - if x is close to 1, $idzer refines it, and we can calculate the
+ # square root directly.
+ # - if x is less than 1, $idneg refines it, and we calculate sqrt(4*x)
+ # and multiply by 1/2.
+ # - if x is greater than 1, $idpos refines it, and we calculate
+ # sqrt(x/4) and multiply by 2.
+ # - if none of the above hold, we have insufficient information about
+ # the magnitude of x and perform a digit exchange.
+
+ my ref
+ if {[my refinesM $isneg]} {
+ # Negative argument is an error
+ return -code error -errorcode {MATH EXACT SQRTNEGATIVE} \
+ "sqrt of negative argument"
+ } elseif {[my refinesM $idzer]} {
+ # Argument close to 1
+ set res [::math::exact::SqrtWorker new [self object]]
+ } elseif {[my refinesM $idneg]} {
+ # Small argument - multiply by 4 and halve the square root
+ set y [[my applyM {{4 0} {0 1}}] ref]
+ set z [[$y sqrt] ref]
+ set res [$z applyM {{1 0} {0 2}}]
+ $z unref
+ $y unref
+ } elseif {[my refinesM $idpos]} {
+ # Large argument - divide by 4 and double the square root
+ set y [[my applyM {{1 0} {0 4}}] ref]
+ set z [[$y sqrt] ref]
+ set res [$z applyM {{2 0} {0 1}}]
+ $z unref
+ $y unref
+ } else {
+ # Unclassified argyment. Perform a digit exchange and try again.
+ set y [[my absorb] ref]
+ set res [$y sqrt]
+ $y unref
+ }
+ my unref
+ return $res
+ }
+}
+
+# math::exact::V --
+# Vector object
+#
+# A vector object represents a rational number. It is always strict; no
+# methods need to perform lazy evaluation.
+
+oo::class create math::exact::V {
+ superclass math::exact::Expression
+
+ # v_ is the vector represented.
+ variable v_
+
+ # Constructor accepts the vector as a two-element list {n d}
+ # where n is by convention the numerator and d the denominator.
+ # It is expected that either n or d is nonzero, and that gcd(n,d) == 0.
+ # It is also expected that the fraction will be in lowest terms.
+ constructor {v} {
+ next
+ set v_ $v
+ }
+
+ # Destructor need only update reference counts
+ destructor {
+ next
+ }
+
+ # If a rational is acceptable, getLeadingDigitAndRest may simply return
+ # this object.
+ method getLeadingDigitAndRest {needDigit} {
+ if {$needDigit} {
+ return [next $needDigit]
+ } else {
+ # Note that the result MUST NOT be memoized, as that would lead
+ # to a circular reference, breaking the refcount system.
+ return [self object]
+ }
+ }
+
+ # Print this object
+ method dump {} {
+ return "V($v_)"
+ }
+
+ # Test if the vector refines when premultiplied by a matrix
+ method refinesM {m} {
+ return [math::exact::vrefines [math::exact::mdotv $m $v_]]
+ }
+
+ # Apply a matrix to the vector.
+ # Precondition: v is in lowest terms
+
+ method applyM {m} {
+ set d [math::exact::determinant $m]
+ if {$d < 0} { set d [expr {-$d}] }
+ if {($d & ($d-1)) != 0} {
+ return [math::exact::V new \
+ [math::exact::vreduce [math::exact::mdotv $m $v_]]]
+ } else {
+ return [math::exact::V new \
+ [math::exact::vscale [math::exact::mdotv $m $v_]]]
+ }
+ }
+
+ # Left-multiply a tensor t by the vector, and apply the result to
+ # an expression 'r'
+ method applyTLeft {t r} {
+ set u [math::exact::mscale [math::exact::tleftv $t $v_]]
+ set det [math::exact::determinant $u]
+ if {$det < 0} { set det [expr {-$det}] }
+ if {($det & ($det-1)) == 0} {
+ # determinant is a power of 2
+ set res [$r applyM $u]
+ return $res
+ } else {
+ return [math::exact::Mstrict new $u $r]
+ }
+ }
+
+ # Right-multiply a tensor t by the vector, and apply the result
+ # to an expression 'l'
+ method applyTRight {t l} {
+ set u [math::exact::mscale [math::exact::trightv $t $v_]]
+ set det [math::exact::determinant $u]
+ if {$det < 0} { set det [expr {-$det}] }
+ if {($det & ($det-1)) == 0} {
+ # determinant is a power of 2
+ set res [$l applyM $u]
+ return $res
+ } else {
+ return [math::exact::Mstrict new $u $l]
+ }
+ }
+
+ # Get the vector components
+ method getV {} {
+ return $v_
+ }
+
+ # Get the (zero-width) interval that the vector represents.
+ method getInterval {nDigits} {
+ return [list $v_ $v_]
+ }
+
+ # Absorb more information
+ method absorb {} {
+ # Nothing should ever call this, because a vector's information is
+ # already complete.
+ error "cannot absorb anything into a vector"
+ }
+
+ # asReal --
+ # Coerces an object from rational to real
+ #
+ # Parameters:
+ # None.
+ #
+ # Results:
+ # Returns this object converted to an exact real.
+ method asReal {} {
+ my ref
+ lassign [my getSignAndMagnitude] s m
+ set result [math::exact::Mstrict new $s $m]
+ my unref
+ return $result
+ }
+
+ # U- --
+ #
+ # Unary - applied to this object
+ #
+ # Results:
+ # Returns the negation.
+
+ method U- {} {
+ my ref
+ lassign $v_ p q
+ set result [math::exact::V new [list [expr {-$p}] $q]]
+ my unref
+ return $result
+ }; export U-
+
+ # + --
+ # Adds a vector to another object
+ #
+ # Parameters:
+ # r - Right addend
+ #
+ # Results:
+ # Returns the sum
+ #
+ # The right-hand addend may be rational (an instance of V) or real
+ # (any other Expression).
+ #
+ # This method is a Consumer with respect to the current object and to r.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method + {r} {
+ return [$r V+ [self object]]
+ }; export +
+
+ # E+ --
+ # Adds an exact real and a vector
+ #
+ # Parameters:
+ # l - Left addend
+ #
+ # Results:
+ # Returns the sim.
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method E+ {l} {
+ tailcall math::exact::+real $l [self object]
+ }; export E+
+
+ # V+ --
+ # Adds two rationals
+ #
+ # Parameters:
+ # l - Rational multiplicand
+ #
+ # Results:
+ # Returns the product.
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+ method V+ {l} {
+ my ref
+ $l ref
+ lassign [$l getV] a b
+ lassign $v_ c d
+ $l unref
+ my unref
+ return [math::exact::V new \
+ [math::exact::vreduce \
+ [list [expr {$a*$d+$b*$c}] [expr {$b*$d}]]]]
+ }; export V+
+
+ # - --
+ # Subtracts another object from a vector
+ #
+ # Parameters:
+ # r - Subtrahend
+ #
+ # Results:
+ # Returns the difference
+ #
+ # The right-hand operand may be rational (an instance of V) or real
+ # (any other Expression).
+ #
+ # This method is a Consumer with respect to the current object and to r.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method - {r} {
+ return [$r V- [self object]]
+ }; export -
+
+ # E- --
+ # Subtracts this exact real from a rational
+ #
+ # Parameters:
+ # l - Left addend
+ #
+ # Results:
+ # Returns the difference.
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method E- {l} {
+ tailcall math::exact::-real $l [self object]
+ }; export E-
+
+ # V- --
+ # Subtracts this rational from another
+ #
+ # Parameters:
+ # l - Rational minuend
+ #
+ # Results:
+ # Returns the difference.
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+ method V- {l} {
+ my ref
+ $l ref
+ lassign [$l getV] a b
+ lassign $v_ c d
+ $l unref
+ my unref
+ return [math::exact::V new \
+ [math::exact::vreduce \
+ [list [expr {$a*$d-$b*$c}] [expr {$b*$d}]]]]
+ }; export V-
+
+ # * --
+ # Multiplies a rational by another object
+ #
+ # Parameters:
+ # r - Right-hand factor
+ #
+ # Results:
+ # Returns the difference
+ #
+ # The right-hand operand may be rational (an instance of V) or real
+ # (any other Expression).
+ #
+ # This method is a Consumer with respect to the current object and to r.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method * {r} {
+ return [$r V* [self object]]
+ }; export *
+
+ # E* --
+ # Multiplies an exact real and a rational
+ #
+ # Parameters:
+ # l - Multiplicand
+ #
+ # Results:
+ # Returns the product.
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method E* {l} {
+ tailcall math::exact::*real $l [self object]
+ }; export E*
+
+ # V* --
+ # Multiplies two rationals
+ #
+ # Parameters:
+ # l - Rational multiplicand
+ #
+ # Results:
+ # Returns the product.
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+ method V* {l} {
+ my ref
+ $l ref
+ lassign [$l getV] a b
+ lassign $v_ c d
+ $l unref
+ my unref
+ return [math::exact::V new \
+ [math::exact::vreduce \
+ [list [expr {$a*$c}] [expr {$b*$d}]]]]
+ }; export V*
+
+ # / --
+ # Divides this object by another.
+ #
+ # Parameters:
+ # r - Divisor
+ #
+ # Results:
+ # Returns the quotient
+ #
+ # Either object may be rational (an instance of V) or real (any other
+ # Expression).
+ #
+ # This method is a Consumer with respect to the current object and to r.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method / {r} {
+ return [$r V/ [self object]]
+ }; export /
+
+ # E/ --
+ # Divides an exact real and a rational
+ #
+ # Parameters:
+ # l - Dividend
+ #
+ # Results:
+ # Returns the quotient.
+ #
+ # The divisor is not a rationa.
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method E/ {l} {
+ tailcall math::exact::/real $l [self object]
+ }; export E/
+
+ # V/ --
+ # Divides two rationals
+ #
+ # Parameters:
+ # l - Dividend
+ #
+ # Results:
+ # Returns the quotient.
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+ method V/ {l} {
+ my ref
+ $l ref
+ lassign [$l getV] a b
+ lassign $v_ c d
+ set result [math::exact::V new \
+ [math::exact::vreduce \
+ [list [expr {$a*$d}] [expr {$b*$c}]]]]
+ $l unref
+ my unref
+ return $result
+ }; export V/
+
+ # ** -
+ # Raises a rational to a power
+ #
+ # Parameters:
+ # r - Exponent
+ #
+ # Results:
+ # Returns the power.
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method ** {r} {
+ tailcall $r V** [self object]
+ }; export **
+
+ # E** -
+ # Raises an exact real to a rational power
+ #
+ # Parameters:
+ # l - Base to exponentiate
+ #
+ # Results:
+ # Returns the power
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method E** {l} {
+
+ # Extract numerator and demominator of the exponent, and consume the
+ # exponent.
+ my ref
+ lassign $v_ c d
+ my unref
+
+ # Normalize the sign of the exponent
+ if {$d < 0} {
+ set c [expr {-$c}]
+ set d [expr {-$d}]
+ }
+
+ # Don't choke if somehow a 0/0 gets here.
+ if {$c == 0 && $d == 0} {
+ $l unref
+ return -code error -errorcode "MATH EXACT ZERODIVZERO" \
+ "zero divided by zero"
+ }
+
+ # Handle integer powers
+ if {$d == 1} {
+ return [math::exact::real**int $l $c]
+ }
+
+ # Other rational powers come here.
+ # We know that $d > 0, and we're not just doing
+ # exponentiation by an integer
+
+ return [math::exact::real**rat $l $c $d]
+ }; export E**
+
+ # V** -
+ # Raises a rational base to a rational power
+ #
+ # Parameters:
+ # l - Base to exponentiate
+ #
+ # Results:
+ # Returns the power
+ #
+ # This method is a Consumer with respect to the current object and to l.
+ # It is a Constructor with respect to its result, returning a zero-ref
+ # object.
+
+ method V** {l} {
+
+ # Extract the numerator and denominator of the base and consume
+ # the base.
+ $l ref
+ lassign [$l getV] a b
+ $l unref
+
+ # Extract numerator and demominator of the exponent, and consume the
+ # exponent.
+ my ref
+ lassign $v_ c d
+ my unref
+
+ # Normalize the signs of the arguments
+ if {$b < 0} {
+ set a [expr {-$a}]
+ set b [expr {-$b}]
+ }
+ if {$d < 0} {
+ set c [expr {-$c}]
+ set d [expr {-$d}]
+ }
+
+ # Don't choke if somehow a 0/0 gets here.
+ if {$a == 0 && $b == 0 || $c == 0 && $d == 0} {
+ return -code error -errorcode "MATH EXACT ZERODIVZERO" \
+ "zero divided by zero"
+ }
+
+ # b >= 0 and d >= 0
+
+ if {$a == 0} {
+ if {$c == 0} {
+ return -code error -errorcode "MATH EXACT ZEROPOWZERO" \
+ "zero to zero power"
+ } elseif {$d == 0} {
+ return -code error -errorcode "MATH EXACT ZEROPOWINF" \
+ "zero to infinite power"
+ } else {
+ return [math::exact::V new {0 1}]
+ }
+ }
+
+ # a != 0, b >= 0, d >= 0
+
+ if {$b == 0} {
+ if {$c == 0} {
+ return -code error -errorcode "MATH EXACT INFPOWZERO" \
+ "infinity to zero power"
+ } elseif {$c < 0} {
+ return [math::exact::V new {0 1}]
+ } else {
+ return [math::exact::V new {1 0}]
+ }
+ }
+
+ # a != 0, b > 0, d >= 0
+
+ if {$c == 0} {
+ return [math::exact::V new {1 1}]
+ }
+
+ # handle integer exponents
+
+ if {$d == 1} {
+ return [math::exact::rat**int $a $b $c]
+ }
+
+ # a != 0, b > 0, c != 0, d >= 0
+
+ return [math::exact::rat**rat $a $b $c $d]
+ }; export V**
+
+ # sqrt --
+ #
+ # Calculates the square root of this object
+ #
+ # Results:
+ # Returns the square root as an exact real.
+ #
+ # This method is a Consumer with respect to this object and a Constructor
+ # with respect to the result, returning a zero-ref object.
+ method sqrt {} {
+ my ref
+ if {([lindex $v_ 0] < 0) ^ ([lindex $v_ 1] < 0)} {
+ return -code error -errorCode "MATH EXACT SQRTNEGATIVE" \
+ {square root of negative argument}
+ }
+ set result [::math::exact::Sqrtrat new {*}$v_]
+ my unref
+ return $result
+ }
+
+}
+
+# math::exact::M --
+# Expression consisting of a matrix times another expression
+#
+# The matrix {a c} {b d} represents the homography (a*x + b) / (c*x + d).
+#
+# The inner expression may need to be evaluated lazily. Whether evaluation
+# is strict or lazy, the 'e' method will return the expression.
+
+oo::class create math::exact::M {
+ superclass math::exact::Expression
+
+ # m_ is the matrix; e_ the inner expression; absorbed_ a cache of the
+ # result of the 'absorb' method.
+ variable m_ e_ absorbed_
+
+ # constructor accepts the matrix only. The expression is managed in
+ # derived classes.
+ constructor {m} {
+ next
+ set m_ $m
+ }
+
+ # destructor deletes the memoized expression if one has been stored.
+ # The base class destructor handles cleaning up the result of 'absorb'
+ destructor {
+ if {[info exists e_]} {
+ $e_ unref
+ }
+ next
+ }
+
+ # Test if the matrix refines when premultiplied by another matrix n
+ method refinesM {n} {
+ return [math::exact::mrefines [math::exact::mdotm $n $m_]]
+ }
+
+ # Premultiply the matrix by another matrix n
+ method applyM {n} {
+ set d [math::exact::determinant $n]
+ if {$d < 0} {set d [expr {-$d}]}
+ if {($d & ($d-1)) != 0} {
+ return [math::exact::Mstrict new \
+ [math::exact::mreduce [math::exact::mdotm $n $m_]] \
+ [my e]]
+ } else {
+ return [math::exact::Mstrict new \
+ [math::exact::mscale [math::exact::mdotm $n $m_]] \
+ [my e]]
+ }
+ }
+
+ # Compute the left product of a tensor t with this matrix, and
+ # apply the resulting tensor to the expression 'r'.
+ method applyTLeft {t r} {
+ return [math::exact::Tstrict new \
+ [math::exact::tscale [math::exact::tleftm $t $m_]] \
+ 1 [my e] $r]
+ }
+
+ # Compute the right product of a tensor t with this matrix, and
+ # apply the resulting tensor to the expression 'l'.
+ method applyTRight {t l} {
+ return [math::exact::Tstrict new \
+ [math::exact::tscale [math::exact::trightm $t $m_]] \
+ 0 $l [my e]]
+ }
+
+ # Absorb a digit into this matrix.
+ method absorb {} {
+ if {![info exists absorbed_]} {
+ set absorbed_ [[[my e] applyM $m_] ref]
+ }
+ return $absorbed_
+ }
+
+ # Derived classes are expected to implement:
+ # method e {} {
+ # # Returns the expression to which this matrix is applied.
+ # # Optionally memoizes the result in $e_.
+ # }
+ method e {} {
+ error "[info object class [self object]] does not implement the 'e' method."
+ }
+}
+
+# math::exact::Mstrict --
+#
+# Expression representing the product of a matrix and another
+# expression.
+#
+# In this version of the class, the expression is known in advance -
+# evaluated strictly.
+
+oo::class create math::exact::Mstrict {
+ superclass math::exact::M
+
+ # m_ is the matrix.
+ # e_ is the expression
+ # absorbed_ caches the result of the 'absorb' method.
+ variable m_ e_ absorbed_
+
+ # Constructor accepts the matrix and the expression to which
+ # it applies.
+ constructor {m e} {
+ next $m
+ set e_ [$e ref]
+ }
+
+ # All the heavy lifting of destruction is performed in the base class.
+ destructor {
+ next
+ }
+
+ # The 'e' method returns the expression.
+ method e {} {
+ return $e_
+ }
+
+ # The 'dump' method formats this object for debugging.
+ method dump {} {
+ return "M($m_,[$e_ dump])"
+ }
+}
+
+# math::exact::T --
+# Expression representing a 2x2x2 tensor of the third order,
+# applied to two subexpressions.
+
+oo::class create math::exact::T {
+ superclass math::exact::Expression
+
+ # t_ - the tensor
+ # i_ A flag indicating whether the next 'absorb' should come from the
+ # left (0) or the right (1).
+ # l_ - the left subexpression
+ # r_ - the right subexpression
+ # absorbed_ - the result of an 'absorb' operation
+
+ variable t_ i_ l_ r_ absorbed_
+
+ # constructor accepts the tensor and the initial state for absorption
+ constructor {t i} {
+ next
+ set t_ $t
+ set i_ $i
+ }
+
+ # destructor removes cached items.
+ destructor {
+ if {[info exists l_]} {
+ $l_ unref
+ }
+ if {[info exists r_]} {
+ $r_ unref
+ }
+ next; # The base class will clean up absorbed_
+ }
+
+ # refinesM --
+ #
+ # Tests if this tensor refines when premultiplied by a matrix
+ #
+ # Parameters:
+ # m - matrix to test
+ #
+ # Results:
+ # Returns a Boolean indicator that is true if the product refines.
+
+ method refinesM {m} {
+ return [math::exact::trefines [math::exact::mdott $m $t_]]
+ }
+
+ # applyM --
+ #
+ # Left multiplies this tensor by a matrix
+ #
+ # Parameters:
+ # m - Matrix to multiply
+ #
+ # Results:
+ # Returns the product
+ #
+ # This operation has the side effect of making the product strict at
+ # the uppermost level, by calling [my l] [my r] to instantiate the
+ # subexpressions.
+
+ method applyM {m} {
+ set d [math::exact::determinant $m]
+ if {$d < 0} {set d [expr {-$d}]}
+ if {($d & ($d-1)) != 0} {
+ return [math::exact::Tstrict new \
+ [math::exact::treduce [math::exact::mdott $m $t_]] \
+ 0 [my l] [my r]]
+ } else {
+ return [math::exact::Tstrict new \
+ [math::exact::tscale [math::exact::mdott $m $t_]] \
+ 0 [my l] [my r]]
+ }
+ }
+
+ # absorb --
+ #
+ # Absorbs information from the subexpressions.
+ #
+ # Results:
+ # Returns a copy of the current object, with information from
+ # at least one subexpression absorbed so that more information is
+ # immediately available.
+
+ method absorb {} {
+ if {![info exists absorbed_]} {
+ if {[math::exact::trefines $t_]} {
+ lassign [math::exact::trans $t_] m n
+ set side [math::exact::mdisjointm $m $n]
+ } else {
+ set side $i_
+ }
+ if {$side} {
+ set absorbed_ [[[my r] applyTRight $t_ [my l]] ref]
+ } else {
+ set absorbed_ [[[my l] applyTLeft $t_ [my r]] ref]
+ }
+ }
+ return $absorbed_
+ }
+
+ # applyTRight --
+ #
+ # Right-multiplies a tensor by this expression
+ #
+ # Results:
+ # Returns 't' left-product l right-product $r_.
+
+ method applyTRight {t l} {
+ # This is the hard case of digit exchange. We have to
+ # get the leading digit from this tensor, absorbing as
+ # necessary, right-multiply it into the tensor $t, and
+ # compose the new object.
+ #
+ # Note that unless 'rest' is empty, 'ld' is a digit matrix,
+ # so we need to check only for powers of 2 when reducing to
+ # lowest terms
+ lassign [my getLeadingDigitAndRest 0] ld rest
+ if {$rest eq {}} {
+ set u [math::exact::mreduce [math::exact::trightv $t $ld]]
+ return [math::exact::Mstrict new $u $l]
+ } else {
+ set u [math::exact::tscale [math::exact::trightm $t $ld]]
+ return [math::exact::Tstrict new $u 0 $l $rest]
+ }
+ }
+
+ # applyTLeft --
+ #
+ # Left-multiplies a tensor by this expression
+ #
+ # Results:
+ # Returns 't' left-product $l_ right-product 'r'
+ method applyTLeft {t r} {
+ # This is the hard case of digit exchange. We have to
+ # get the leading digit from this tensor, absorbing as
+ # necessary, left-multiply it into the tensor $t, and
+ # compose the new object
+ #
+ # Note that unless 'rest' is empty, 'ld' is a digit matrix,
+ # so we need to check only for powers of 2 when reducing to
+ # lowest terms
+ lassign [my getLeadingDigitAndRest 0] ld rest
+ if {$rest eq {}} {
+ set u [math::exact::mreduce [math::exact::tleftv $t $ld]]
+ return [math::exact::Mstrict $u $r]
+ } else {
+ set u [math::exact::tscale [math::exact::tleftm $t $ld]]
+ return [math::exact::Tstrict new $u 1 $rest $r]
+ }
+ }
+
+ # Derived classes are expected to implement the following:
+ # l --
+ #
+ # Returns the left operand
+ method l {} {
+ error "[info object class [self object]] does not implement the 'l' method"
+ }
+
+ # r --
+ #
+ # Returns the right operand
+ method r {} {
+ error "[info object class [self object]] does not implement the 'r' method"
+ }
+
+}
+
+# math::exact::Tstrict --
+#
+# A strict tensor - one where the subexpressions are both known in
+# advance.
+
+oo::class create math::exact::Tstrict {
+ superclass math::exact::T
+
+ # t_ - the tensor
+ # i_ A flag indicating whether the next 'absorb' should come from the
+ # left (0) or the right (1).
+ # l_ - the left subexpression
+ # r_ - the right subexpression
+ # absorbed_ - the result of an 'absorb' operation
+
+ variable t_ i_ l_ r_ absorbed_
+
+ # constructor accepts the tensor, the absorption state, and the
+ # left and right operands.
+ constructor {t i l r} {
+ next $t $i
+ set l_ [$l ref]
+ set r_ [$r ref]
+ }
+
+ # base class handles all cleanup
+ destructor {
+ next
+ }
+
+ # l --
+ #
+ # Returns the left operand
+ method l {} {
+ return $l_
+ }
+
+ # r --
+ #
+ # Returns the right operand
+ method r {} {
+ return $r_
+ }
+
+ # dump --
+ #
+ # Formats this object for debugging
+ method dump {} {
+ return T($t_,$i_\;[$l_ dump],[$r_ dump])
+ }
+}
+
+# math::exact::opreal --
+#
+# Applies a bihomography (bilinear fractional transformation)
+# to two expressions.
+#
+# Parameters:
+# op - Tensor {{{a b} {c d}} {{e f} {g h}}} representing the operation
+# x - left operand
+# y - right operand
+#
+# Results:
+# Returns an expression that represents the form:
+# (axy + cx + ey + g) / (bxy + dx + fy + h)
+#
+# Notes:
+# Note that the four basic arithmetic operations are included here.
+# In addition, this procedure may be used to craft other useful
+# transformations. For example, (1 - u**2) / (1 + u**2)
+# could be constructed as [opreal {{{-1 1} {0 0}} {{0 0} {1 1}}} $u $u]
+
+proc math::exact::opreal {op x y {kludge {}}} {
+ # split x and y into sign and magnitude
+ $x ref; $y ref
+ lassign [$x getSignAndMagnitude] sx mx
+ lassign [$y getSignAndMagnitude] sy my
+ $mx ref; $my ref
+ $x unref; $y unref
+ set t [tleftm [trightm $op $sy] $sx]
+ set r [math::exact::Tstrict new $t 0 $mx $my]
+ $mx unref; $my unref
+ return $r
+}
+
+# math::exact::+real --
+# math::exact::-real --
+# math::exact::*real --
+# math::exact::/real --
+#
+# Sum, difference, product and quotient of exact reals
+#
+# Parameters:
+# x - First operand
+# y - Second operand
+#
+# Results:
+# Returns x+y, x-y, x*y or x/y as requested.
+
+proc math::exact::+real {a b} { variable tadd; return [opreal $tadd $a $b] }
+proc math::exact::-real {a b} { variable tsub; return [opreal $tsub $a $b] }
+proc math::exact::*real {a b} { variable tmul; return [opreal $tmul $a $b] }
+proc math::exact::/real {a b} { variable tdiv; return [opreal $tdiv $a $b] }
+
+# real --
+#
+# Coerce an argument to exact-real (possibly from rational)
+#
+# Parameters:
+# x - Argument to coerce.
+#
+# Results:
+# Returns the argument coerced to a real.
+#
+# This operation either does nothing and returns its argument, or is a
+# Consumer with respect to its argument and a Constructor with respect to
+# its result.
+
+proc math::exact::function::real {x} {
+ tailcall $x asReal
+}
+
+# SqrtWorker --
+#
+# Class to calculate the square root of a real.
+
+
+oo::class create math::exact::SqrtWorker {
+ superclass math::exact::T
+ variable l_ r_
+
+ # e - The expression whose square root should be calculated.
+ # e should be between close to 1 for good performance. The
+ # 'sqrtreal' procedure below handles the scaling.
+ constructor {e} {
+ next {{{1 0} {2 1}} {{1 2} {0 1}}} 0
+ set l_ [$e ref]
+ }
+ method l {} {
+ return $l_
+ }
+ method r {} {
+ if {![info exists r_]} {
+ set r_ [[math::exact::SqrtWorker new $l_] ref]
+ }
+ return $r_
+ }
+ method dump {} {
+ return "sqrt([$l_ dump])"
+ }
+}
+
+# sqrt --
+#
+# Returns the square root of a number
+#
+# Parameters:
+# x - Exact real number whose square root is needed.
+#
+# Results:
+# Returns the square root as an exact real.
+#
+# The number may be rational or real. There is a special optimization used
+# if the number is rational
+
+proc math::exact::function::sqrt {x} {
+ tailcall $x sqrt
+}
+
+# ExpWorker --
+#
+# Class that evaluates the exponential function for small exact reals
+
+oo::class create math::exact::ExpWorker {
+ superclass math::exact::T
+ variable t_ l_ r_ n_
+
+ # Constructor --
+ #
+ # Parameters:
+ # e - Argument whose exponential is to be computed. (What is
+ # actually passed in is S0'(x) = (1+x)/(1-x))
+ # n - Number of the convergent of the continued fraction
+ #
+ # This class is implemented by expanding the continued fraction
+ # as needed for precision. Each successive step becomes a new right
+ # subexpression of the tensor product.
+
+ constructor {e {n 0}} {
+ next [list \
+ [list \
+ [list [expr {2*$n + 2}] [expr {2*$n + 1}]] \
+ [list [expr {2*$n + 1}] [expr {2*$n}]]] \
+ [list \
+ [list [expr {2*$n}] [expr {2*$n + 1}]] \
+ [list [expr {2*$n + 1}] [expr {2*$n + 2}]]]] 0
+ set l_ [$e ref]
+ set n_ [expr {$n + 1}]
+ }
+
+ # l --
+ #
+ # Returns the left subexpression; that is, the argument to the
+ # exponential
+ method l {} {
+ return $l_
+ }
+
+ # r --
+ # Returns the right subexpresison - the next convergent, creating it
+ # if necessary
+ method r {} {
+ if {![info exists r_]} {
+ set r_ [[math::exact::ExpWorker new $l_ $n_] ref]
+ }
+ return $r_
+ }
+
+ # dump --
+ #
+ # Displays this object for debugging
+ method dump {} {
+ return ExpWorker([$l_ dump],[expr {$n_-1}])
+ }
+}
+
+# exp --
+#
+# Evaluates the exponential function of an exact real
+#
+# Parameters:
+# x - Quantity to be exponentiated
+#
+# Results:
+# Returns the exact real function value.
+#
+# This procedure is a Consumer with respect to its argument and a
+# Constructor with respect to its result, returning a zero-ref object.
+
+proc math::exact::function::exp {x} {
+ variable ::math::exact::iszer
+ variable ::math::exact::tmul
+
+ # The continued fraction converges only for arguments between -1 and 1.
+ # If $iszer refines the argument, then it is in the correct range and
+ # we launch ExpWorker to evaluate the continued fraction. If the argument
+ # is outside the range [-1/2..1/2], then we evaluate exp(x/2) and square
+ # the result. If neither of the above is true, then we perform a digit
+ # exchange to get more information about the magnitude of the argument.
+
+ $x ref
+ if {[$x refinesM $iszer]} {
+ # Argument's absolute value is small - evaluate the exponential
+ set y [$x applyM $iszer]
+ set result [ExpWorker new $y]
+ } elseif {[$x refinesM {{2 2} {-1 1}}]} {
+ # Argument's absolute value is large - evaluate exp(x/2)**2
+ set xover2 [$x applyM {{1 0} {0 2}}]
+ set expxover2 [exp $xover2]
+ set result [*real $expxover2 $expxover2]
+ } else {
+ # Argument's absolute value is uncharacterized - perform a digit
+ # exchange to get more information.
+ set result [exp [$x absorb]]
+ }
+ $x unref
+ return $result
+}
+
+# LogWorker --
+#
+# Helper class for evaluating logarithm of an exact real argument.
+#
+# The algorithm used is a continued fraction representation from Peter Potts's
+# paper. This worker evaluates the second and subsequent convergents. The
+# first convergent is in the 'log' procedure below, and follows a different
+# pattern from the rest of them.
+
+oo::class create math::exact::LogWorker {
+ superclass math::exact::T
+ variable t_ l_ r_ n_
+
+ # Constructor -
+ #
+ # Parameters:
+ # e - Argument whose log is to be extracted
+ # n - Number of the convergent.
+ constructor {e {n 1}} {
+ next [list \
+ [list \
+ [list $n 0] \
+ [list [expr {2*$n + 1}] [expr {$n+1}]]] \
+ [list \
+ [list [expr {$n + 1}] [expr {2*$n + 1}]] \
+ [list 0 $n]]] 0
+ set l_ [$e ref]
+ set n_ [expr {$n + 1}]
+ }
+
+ # l -
+ # Returns the argument whose log is to be extracted
+ method l {} {
+ return $l_
+ }
+
+ # r -
+ # Returns the next convergent, constructing it if necessary.
+ method r {} {
+ if {![info exists r_]} {
+ set r_ [[math::exact::LogWorker new $l_ $n_] ref]
+ }
+ return $r_
+ }
+
+ # dump -
+ # Dumps this object for debugging
+ method dump {} {
+ return LogWorker([$l_ dump],[expr {$n_-1}])
+ }
+}
+
+# log -
+#
+# Calculates the natural logarithm of an exact real argument.
+#
+# Parameters:
+# x - Quantity whose log is to be extracted.
+#
+# Results:
+# Returns the logarithm
+#
+# This procedure is a Consumer with respect to its argument and a Constructor
+# with respect to its result, returning a zero-ref object.
+
+proc math::exact::function::log {x} {
+ variable ::math::exact::ispos
+ variable ::math::exact::isneg
+ variable ::math::exact::idpos
+ variable ::math::exact::idneg
+ variable ::math::exact::log2
+
+ # If x is between 1/2 and 2, the continued fraction will converge. If
+ # y = LogWorker(x), then log(x) = (xy + x - y - 1)/(x + y), and the
+ # latter function is a bihomography that can be evaluated by 'opreal'
+ # directly.
+ #
+ # If x is negative, that's an error.
+ # If x > 1, idpos will refine it, and we compute log(x/2) + log(2)
+ # If x < 1, idneg will refine it, and we compute log(2x) - log(2)
+ # If none of the above can be proven, perform a digit exchange and
+ # try again.
+
+ $x ref
+ if {[$x refinesM {{2 -1} {-1 2}}]} {
+ # argument in bounds
+ set result [math::exact::opreal {{{1 0} {1 1}} {{-1 1} {-1 0}}} \
+ $x \
+ [LogWorker new $x]]
+ } elseif {[$x refinesM $isneg]} {
+ # domain error
+ return -code error -errorcode {MATH EXACT LOGNEGATIVE} \
+ "log of negative argument"
+ } elseif {[$x refinesM $idpos]} {
+ # large argument, reduce it and try again
+ set result [+real [function::log [$x applyM {{1 0} {0 2}}]] $log2]
+ } elseif {[$x refinesM $idneg]} {
+ # small argument, increase it and try again
+ set result [-real [function::log [$x applyM {{2 0} {0 1}}]] $log2]
+ } else {
+ # too little information, perform digit exchange.
+ set result [function::log [$x absorb]]
+ }
+ $x unref
+ return $result
+}
+
+# TanWorker --
+#
+# Auxiliary function for tangent of an exact real argument
+#
+# This class develops the second and subsequent convergents of the continued
+# fraction expansion in Potts's paper
+oo::class create math::exact::TanWorker {
+ superclass math::exact::T
+ variable t_ l_ r_ n_
+
+ # Constructor -
+ #
+ # Parameters:
+ # e - S0'(x) = (1+x)/(1-x), where we wish to evaluate tan(x).
+ # n - Ordinal position of the convergent
+ constructor {e {n 1}} {
+ next [list \
+ [list \
+ [list [expr {2*$n + 1}] [expr {2*$n + 3}]] \
+ [list [expr {2*$n - 1}] [expr {2*$n + 1}]]] \
+ [list \
+ [list [expr {2*$n + 1}] [expr {2*$n - 1}]] \
+ [list [expr {2*$n + 3}] [expr {2*$n + 1}]]]] 0
+ set l_ [$e ref]
+ set n_ [expr {$n + 1}]
+ }
+
+ # l -
+ # Returns the argument S0'(x)
+ method l {} {
+ return $l_
+ }
+
+ # r -
+ # Returns the next convergent, constructing it if necessary
+ method r {} {
+ if {![info exists r_]} {
+ set r_ [[math::exact::TanWorker new $l_ $n_] ref]
+ }
+ return $r_
+ }
+
+ # dump -
+ # Displays this object for debugging
+ method dump {} {
+ return TanWorker([$l_ dump],[expr {$n_-1}])
+ }
+}
+
+# tan --
+# Tangent of an exact real argument
+#
+# Parameters:
+# x - Quantity whose tangent is to be computed.
+#
+# Results:
+# Returns the tangent
+#
+# This procedure is a Consumer with respect to its argument and a Constructor
+# with respect to its result, returning a zero-ref object.
+
+proc math::exact::function::tan {x} {
+ variable ::math::exact::iszer
+
+ # If |x| < 1, then we use Potts's formula for the tangent.
+ # If |x| > 1/2, then we compute y = tan(x/2) and then use the
+ # trig identity tan(x) = 2*y/(1-y**2), recognizing that the latter
+ # expression can be expressed as a bihomography applied to y and itself,
+ # allowing opreal to do the job.
+ # If neither can be proven, we perform a digit exchange to get more
+ # information.
+ # tan((2*n+1)*pi/2), for n an integer, is a well-behaved pole.
+ # In particular, 1/tan(pi/2) will correctly return zero.
+
+ $x ref
+ if {[$x refinesM $iszer]} {
+ set xx [$x applyM $iszer]
+ set result [math::exact::Tstrict new {{{1 2} {1 0}} {{-1 0} {-1 2}}} 0 \
+ $xx [TanWorker new $xx]]
+ } elseif {[$x refinesM {{2 2} {-1 1}}]} {
+ set xover2 [$x applyM {{1 0} {0 2}}]
+ set tanxover2 [function::tan $xover2]
+ set result [opreal {{{0 -1} {1 0}} {{1 0} {0 1}}} $tanxover2 $tanxover2]
+ } else {
+ set result [function::tan [$x absorb]]
+ }
+ $x unref
+ return $result
+}
+
+# sin --
+# Sine of an exact real argument
+#
+# Parameters:
+# x - Quantity whose sine is to be computed.
+#
+# Results:
+# Returns the sine
+#
+# This procedure is a Consumer with respect to its argument and a Constructor
+# with respect to its result, returning a zero-ref object.
+
+proc math::exact::function::sin {x} {
+ $x ref
+ set tanxover2 [tan [$x applyM {{1 0} {0 2}}]]
+ $x unref
+ return [opreal {{{0 1} {1 0}} {{1 0} {0 1}}} $tanxover2 $tanxover2]
+}
+
+# cos --
+# Cosine of an exact real argument
+#
+# Parameters:
+# x - Quantity whose cosine is to be computed.
+#
+# Results:
+# Returns the cosine
+#
+# This procedure is a Consumer with respect to its argument and a Constructor
+# with respect to its result, returning a zero-ref object.
+
+proc math::exact::function::cos {x} {
+ $x ref
+ set tanxover2 [tan [$x applyM {{1 0} {0 2}}]]
+ $x unref
+ return [opreal {{{-1 1} {0 0}} {{0 0} {1 1}}} $tanxover2 $tanxover2]
+}
+
+# AtanWorker --
+#
+# Auxiliary function for arctangent of an exact real argument
+#
+# This class develops the second and subsequent convergents of the continued
+# fraction expansion in Potts's paper. The argument lies in [-1,1].
+
+oo::class create math::exact::AtanWorker {
+ superclass math::exact::T
+ variable t_ l_ r_ n_
+ # Constructor -
+ #
+ # Parameters:
+ # e - S0(x) = (x-1)/(x+1), where we wish to evaluate atan(x).
+ # n - Ordinal position of the convergent
+ constructor {e {n 1}} {
+ next [list \
+ [list \
+ [list [expr {2*$n + 1}] [expr {$n + 1}]] \
+ [list $n 0]] \
+ [list \
+ [list 0 $n] \
+ [list [expr {$n + 1}] [expr {2*$n + 1}]]]] 0
+ set l_ [$e ref]
+ set n_ [expr {$n + 1}]
+ }
+
+ # l -
+ # Returns the argument S0(x)
+ method l {} {
+ return $l_
+ }
+
+ # r -
+ # Returns the next convergent, constructing it if necessary
+ method r {} {
+ if {![info exists r_]} {
+ set r_ [[math::exact::AtanWorker new $l_ $n_] ref]
+ }
+ return $r_
+ }
+
+ # dump -
+ # Displays this object for debugging
+ method dump {} {
+ return AtanWorker([$l_ dump],[expr {$n_-1}])
+ }
+}
+
+# atanS0 -
+#
+# Evaluates the arctangent of S0(x) = (x-1)/(x+1)
+#
+# Parameters:
+# x - Exact real argumetn
+#
+# Results:
+# Returns atan((x-1)/(x+1))
+#
+# This function is a Consumer with respect to its argument and a Constructor
+# with respect to its result, returning a 0-reference object.
+
+proc math::exact::atanS0 {x} {
+ return [opreal {{{1 2} {1 0}} {{-1 0} {-1 2}}} $x [AtanWorker new $x]]
+}
+
+# atan -
+#
+# Arctangent of an exact real
+#
+# Parameters:
+# x - Exact real argument
+#
+# Results:
+# Returns atan(x)
+#
+# This function is a Consumer with respect to its argument and a Constructor
+# with respect to its result, returning a 0-reference object.
+#
+# atan(1/0) is undefined and may cause an infinite loop.
+
+proc math::exact::function::atan {x} {
+
+ # TODO - find p/q close to the real number x - can be done by
+ # getting a few digits - and do
+ # arctan(p/q + eps) = arctan(p/q) + arctan(q**2*eps/(p*q*eps+p**q+q**2))
+ # using [$eps applyM] to compute the argument of the second arctan
+
+ variable ::math::exact::szer
+ variable ::math::exact::spos
+ variable ::math::exact::sinf
+ variable ::math::exact::sneg
+ variable ::math::exact::pi
+
+ # Four cases, depending on which octant the arctangent lies in.
+
+ $x ref
+ lassign [$x getSignAndMagnitude] signum mag
+ $mag ref
+ $x unref
+ set aS0x [atanS0 $mag]
+ $mag unref
+ if {$signum eq $szer} {
+ # -1 < x < 1
+ return $aS0x
+ } elseif {$signum eq $spos} {
+ # x > 0
+ return [opreal {{{0 0} {4 0}} {{1 0} {0 4}}} $aS0x $pi]
+ } elseif {$signum eq $sinf} {
+ # x < -1 or x > 1
+ return [opreal {{{0 0} {2 0}} {{1 0} {0 2}}} $aS0x $pi]
+ } elseif {$signum eq $sneg} {
+ # x < 0
+ return [opreal {{{0 0} {4 0}} {{-1 0} {0 4}}} $aS0x $pi]
+ } else {
+ # can't happen
+ error "wrong sign: $signum"
+ }
+}
+
+# asinreal -
+#
+# Computes the arcsine of an exact real argument.
+#
+# The arcsine is computed from the arctangent by trigonometric identities
+#
+# This function is a Consumer with respect to its argument and a Constructor
+# with respect to its result, returning a 0-reference object.
+#
+# The function is defined only over the open interval (-1,1). Outside
+# that range INCLUDING AT THE ENDPOINTS, it may fail and give an infinite
+# loop or stack overflow.
+
+proc math::exact::asinreal {x} {
+ variable iszer
+ variable pi
+
+ # Potts's formula doesn't work here - it's singular at zero,
+ # and undefined over negative numbers. But some messing with the
+ # algebra gives us:
+ # asin(S0*x) = 2*atan(sqrt(x)) - pi/2
+ # = (4*atan(sqrt(x)) - pi) / 2
+ # which is continuous and computable over (-1..1)
+ $x ref
+ set y [$x applyM $iszer]
+ $x unref
+ return [opreal {{{0 0} {-1 0}} {{4 0} {0 2}}} \
+ $pi \
+ [function::atan [function::sqrt $y]]]
+}
+
+interp alias {} math::exact::function::asin {} math::exact::asinreal
+
+# acosreal -
+#
+# Computes the arccosine of an exact real argument.
+#
+# The arccosine is computed from the arctangent by trigonometric identities
+#
+# This function is a Consumer with respect to its argument and a Constructor
+# with respect to its result, returning a 0-reference object.
+#
+# The function is defined only over the open interval (-1,1). Outside
+# that range INCLUDING AT THE ENDPOINTS, it may fail and give an infinite
+# loop or stack overflow.
+
+proc math::exact::acosreal {x} {
+ variable iszer
+ variable pi
+ # Potts's formula doesn't work here - it's singular at zero,
+ # and undefined over negative numbers. But some messing with the
+ # algebra gives us:
+ # acos(S0*x) = pi - 2*atan(sqrt(x))
+ $x ref
+ set y [$x applyM $iszer]
+ $x unref
+ return [opreal {{{0 0} {1 0}} {{-2 0} {0 1}}} \
+ $pi \
+ [function::atan [function::sqrt $y]]]
+}
+
+interp alias {} math::exact::function::acos {} math::exact::acosreal
+
+# sinhreal, coshreal, tanhreal --
+#
+# Hyperbolic functions of exact real arguments
+#
+# Parameter:
+# x - Argument at which to evaluate the function
+#
+# Results:
+# Return sinh(x), cosh(x), tanh(x), respectively.
+#
+# These functions are all Consumers with respect to their arguments and
+# Constructors with respect to their results, returning zero-ref objects.
+#
+# The three functions are well defined over all the finite reals, but
+# are ill-behaved at infinity.
+
+proc math::exact::sinhreal {x} {
+ set expx [function::exp $x]
+ return [opreal {{{1 0} {0 1}} {{0 1} {-1 0}}} $expx $expx]
+}
+
+interp alias {} math::exact::function::sinh {} math::exact::sinhreal
+
+proc math::exact::coshreal {x} {
+ set expx [function::exp $x]
+ return [opreal {{{1 0} {0 1}} {{0 1} {1 0}}} $expx $expx]
+}
+
+interp alias {} math::exact::function::cosh {} math::exact::coshreal
+
+proc math::exact::tanhreal {x} {
+ set expx [function::exp $x]
+ return [opreal {{{1 1} {0 0}} {{0 0} {-1 1}}} $expx $expx]
+}
+
+interp alias {} math::exact::function::tanh {} math::exact::tanhreal
+
+# asinhreal, acoshreal, atanhreal --
+#
+# Inverse hyperbolic functions of exact real arguments
+#
+# Parameter:
+# x - Argument at which to evaluate the function
+#
+# Results:
+# Return asinh(x), acosh(x), atanh(x), respectively.
+#
+# These functions are all Consumers with respect to their arguments and
+# Constructors with respect to their results, returning zero-ref objects.
+#
+# asinh is defined over the entire real number line, with the exception
+# of the point at infinity. acosh is defined over x > 1 (NOT x=1, which
+# is singular). atanh is defined over (-1..1) (NOT the endpoints of the
+# interval.)
+
+proc math::exact::asinhreal {x} {
+ # domain (-Inf .. Inf)
+ # asinh(x) = log(x + sqrt(x**2 + 1))
+ $x ref
+ set retval [function::log \
+ [+real $x \
+ [function::sqrt \
+ [opreal {{{1 0} {0 0}} {{0 0} {1 1}}} $x $x]]]]
+ $x unref
+ return $retval
+}
+
+interp alias {} math::exact::function::asinh {} math::exact::asinhreal
+
+proc math::exact::acoshreal {x} {
+ # domain (1 .. Inf)
+ # asinh(x) = log(x + sqrt(x**2 - 1))
+ $x ref
+ set retval [function::log \
+ [+real $x \
+ [function::sqrt \
+ [opreal {{{1 0} {0 0}} {{0 0} {-1 1}}} $x $x]]]]
+ $x unref
+ return $retval
+}
+
+interp alias {} math::exact::function::acosh {} math::exact::acoshreal
+
+proc math::exact::atanhreal {x} {
+ # domain (-1 .. 1)
+ variable sinf
+ #atanh(x) = log(Sinf[x])/2
+
+ $x ref
+ set y [$x applyM $sinf]
+ $y ref
+ $x unref
+ set z [function::log $y]
+ $z ref
+ $y unref
+ set retval [$z applyM {{1 0} {0 2}}]
+ $z unref
+ return $retval
+}
+
+interp alias {} math::exact::function::atanh {} math::exact::atanhreal
+
+# EWorker --
+#
+# Evaluates the constant 'e' (the base of the natural logarithms
+#
+# This class is intended to be singleton. It returns 2.71828.... (the
+# base of the natural logarithms) as an exact real.
+
+oo::class create math::exact::EWorker {
+ superclass math::exact::M
+ variable m_ e_ n_
+
+ # Constructor accepts the number of the continuant.
+
+ constructor {{n 0}} {
+ set n_ [expr {$n + 1}]
+ next [list [list [expr {2*$n + 2}] [expr {2*$n + 1}]] \
+ [list [expr {2*$n + 1}] [expr {2*$n}]]]
+ }
+ destructor {
+ next
+ }
+
+ # e -- Returns the next continuant after this one.
+
+ method e {} {
+ if {![info exists e_]} {
+ set e_ [[math::exact::EWorker new $n_] ref]
+ }
+ return $e_
+ }
+
+ # Formats this object for debugging
+
+ method dump {} {
+ return M($m_,EWorker($n_))
+ }
+}
+
+# PiWorker --
+#
+# Auxiliary object used in evaluating pi.
+#
+# This class evaluates the second and subsequent continuants in
+# Ramanaujan's formula for sqrt(10005)/pi. The Potts paper presents
+# the algorithm, almost without commentary.
+
+oo::class create math::exact::PiWorker {
+ superclass math::exact::M
+ variable m_ e_ n_
+
+ # Constructor accepts the number of the continuant
+
+ constructor {{n 1}} {
+ set n_ [expr {$n + 1}]
+ set nsq [expr {$n * $n}]
+ set n4 [expr {$nsq * $nsq}]
+ set b [expr {(2*$n - 1) * (6*$n - 5) * (6*$n - 1)}]
+ set c [expr {$b * (545140134 * $n + 13591409)}]
+ set d [expr {$b * ($n + 1)}]
+ set e [expr {10939058860032000 * $n4}]
+ set p [list [expr {$e - $d - $c}] [expr {$e + $d + $c}]]
+ set q [list [expr {$e + $d - $c}] [expr {$e - $d + $c}]]
+ next [list $p $q]
+ }
+ destructor {
+ next
+ }
+
+ # e --
+ #
+ # Returns the next continuant after this one
+
+ method e {} {
+ if {![info exists e_]} {
+ set e_ [[math::exact::PiWorker new $n_] ref]
+ }
+ return $e_
+ }
+
+ # dump --
+ #
+ # Formats this object for debugging
+ method dump {} {
+ return M($m_,PiWorker($n_))
+ }
+}
+
+# Log2Worker --
+#
+# Auxiliary class for evaluating log(2).
+#
+# This object represents the constant (1-2*log(2))/(log(2)-1), the
+# product of the second, third, ... nth LFT's of the representation of log(2).
+
+oo::class create math::exact::Log2Worker {
+ superclass math::exact::M
+ variable m_ e_ n_
+
+ # Constructor accepts the number of the continuant
+ constructor {{n 1}} {
+ set n_ [expr {$n + 1}]
+ set a [expr {3*$n + 1}]
+ set b [expr {2*$n + 1}]
+ set c [expr {4*$n + 2}]
+ set d [expr {3*$n + 2}]
+ next [list [list $a $b] [list $c $d]]
+ }
+ destructor {
+ next
+ }
+
+ # e --
+ #
+ # Returns the next continuant after this one.
+ method e {} {
+ if {![info exists e_]} {
+ set e_ [[math::exact::Log2Worker new $n_] ref]
+ }
+ return $e_
+ }
+
+ # dump --
+ #
+ # Displays this object for debugging
+ method dump {} {
+ return M($m_,Log2Worker($n_))
+ }
+}
+
+# Sqrtrat --
+#
+# Class that evaluates the square root of a rational
+
+oo::class create math::exact::Sqrtrat {
+ superclass math::exact::M
+ variable m_ e_ a_ b_ c_
+
+ # Constructor accepts the numerator and denominator. The third argument
+ # is an intermediate result for the second and later continuants.
+ constructor {a b {c {}}} {
+ if {$c eq {}} {
+ set c [expr {$a - $b}]
+ }
+ set d [expr {2*($b-$a) + $c}]
+ if {$d >= 0} {
+ next $math::exact::dneg
+ set a_ [expr {4 * $a}]
+ set b_ $d
+ set c_ $c
+ } else {
+ next $math::exact::dpos
+ set a_ [expr {-$d}]
+ set b_ [expr {4 * $b}]
+ set c_ $c
+ }
+ }
+ destructor {
+ next
+ }
+
+ # e --
+ #
+ # Returns the next continuant after this one.
+ method e {} {
+ if {![info exists e_]} {
+ set e_ [[math::exact::Sqrtrat new $a_ $b_ $c_] ref]
+ }
+ return $e_
+ }
+
+ # dump --
+ # Formats this object for debugging.
+
+ method dump {} {
+ return "M($m_,Sqrtrat($a_,$b_,$c_))"
+ }
+}
+
+# math::exact::rat**int --
+#
+# Service procedure to raise a rational number to an integer power
+#
+# Parameters:
+# a - Numerator of the rational
+# b - Denominator of the rational
+# n - Power
+#
+# Preconditions:
+# n is not zero, a is not zero, b is positive.
+#
+# Results:
+# Returns the power
+#
+# This procedure is a Consumer with respect to its arguments and a
+# Constructor with respect to its result, returning a zero-ref object.
+
+proc math::exact::rat**int {a b n} {
+ if {$n < 0} {
+ return [V new [list [expr {$b**(-$n)}] [expr {$a**(-$n)}]]]
+ } elseif {$n > 0} {
+ return [V new [list [expr {$a**($n)}] [expr {$b**($n)}]]]
+ } else { ;# zero power shouldn't get here
+ return [V new {1 1}]
+ }
+}
+
+# math::exact::rat**rat --
+#
+# Service procedure to raise a rational number to a rational power
+#
+# Parameters:
+# a - Numerator of the base
+# b - Denominator of the base
+# m - Numerator of the exponent
+# n - Denominator of the exponent
+#
+# Results:
+# Returns the power as an exact real
+#
+# Preconditions:
+# a != 0, b > 0, m != 0, n > 0
+#
+# This procedure is a Constructor with respect to its result
+
+proc math::exact::rat**rat {a b m n} {
+
+ # It would be attractive to special case this, but the real mechanism
+ # works as well for the moment.
+
+ tailcall real**rat [V new [list $a $b]] $m $n
+}
+
+# PowWorker --
+#
+# Auxiliary class to compute
+# ((p/q)**n + b)**(m/n),
+# where 0<m<n are integers, p, q are integers, b is an exact real
+
+oo::class create math::exact::PowWorker {
+ superclass math::exact::T
+
+ variable t_ l_ r_ delta_
+
+ # Self-method: start
+ #
+ # Sets up to find z**(m/n) (1 <= m < n), with
+ # z = (p/q)**n + y for integers p and q.
+ #
+ # Parameters:
+ # p - numerator of the estimated nth root
+ # q - denominator of the estimated nth root
+ # y - residual of the quantity whose root is being extracted
+ # m - numerator of the exponent
+ # n - denominator of the exponent (1 <= m < n)
+ #
+ # Results:
+ # Returns the power, as an exact real.
+
+ self method start {p q y m n} {
+ set pm [expr {$p ** $m}]
+ set pnmm [expr {$p ** ($n-$m)}]
+ set pn [expr {$pm * $pnmm}]
+ set qm [expr {$q ** $m}]
+ set qnmm [expr {$q ** ($n-$m)}]
+ set qn [expr {$qm * $qnmm}]
+
+ set t0 \
+ [list \
+ [list \
+ [list [expr {$m * $qn}] [expr {$n*$pnmm*$qm}]] \
+ [list 0 [expr {($n-$m) * $qn}]]] \
+ [list \
+ [list [expr {2 * $n * $pn}] 0] \
+ [list [expr {2 * ($n-$m) * $pm * $qnmm}] 0]]]
+ set t1 \
+ [list \
+ [list \
+ [list [expr {$n * $qn}] [expr {2*$n * $pnmm*$qm}]] \
+ [list 0 [expr {$n * $qn}]]] \
+ [list \
+ [list [expr {4 * $n * $pn}] 0] \
+ [list [expr {2 * $n * $pm * $qnmm}] 0]]]
+
+ set tinit \
+ [list \
+ [list \
+ [list [expr {$m * $qn}] 0] \
+ [list 0 0]] \
+ [list \
+ [list [expr {$n * $pn}] [expr {$n * $pnmm * $qm}]] \
+ [list \
+ [expr {($n-$m) * $pm * $qnmm}] \
+ [expr {($n-$m) * $qn}]]]]
+ $y ref
+ set result [$y applyTLeft $tinit [my new $t0 $t1 $y]]
+ $y unref
+ return $result
+ }
+
+ # Constructor --
+ #
+ # Parameters:
+ # t0 - Tensor from the previous iteration
+ # delta - Increment to use
+ # y - Residual
+ #
+ # The constructor should not be called directly. Instead, the 'start'
+ # method should be called to initialize the iteration
+
+ constructor {t0 delta y} {
+ set t [math::exact::tadd $t0 $delta]
+ next $t 0
+ set l_ [$y ref]
+ set delta_ $delta
+ }
+
+ # l --
+ #
+ # Returns the left subexpression: that is, the 'y' parameter
+ method l {} {
+ return $l_
+ }
+
+ # r --
+ #
+ # Returns the right subexpression: that is, the next continuant,
+ # creating it if necessary
+ method r {} {
+ if {![info exists r_]} {
+ set r_ [[math::exact::PowWorker new $t_ $delta_ $l_] ref]
+ }
+ return $r_
+ }
+
+ method dump {} {
+ set res "PowWorker($t_,$delta_,[$l_ dump],"
+ if {[info exists r_]} {
+ append res [$r_ dump]
+ } else {
+ append res ...
+ }
+ append res ")"
+ return $res
+ }
+
+}
+
+# math::exact::real**int --
+#
+# Service procedure to raise a real number to an integer power.
+#
+# Parameters:
+# b - Number to exponentiate
+# e - Power to raise b to.
+#
+# Results:
+# Returns the power.
+#
+# This procedure is a Consumer with respect to its arguments and a
+# Constructor with respect to its result, returning a zero-ref object.
+
+proc math::exact::real**int {b e} {
+
+ # Handle a negative power by raising the reciprocal of the base to
+ # a positive power
+ if {$e < 0} {
+ set e [expr {-$e}]
+ set b [K [[$b ref] applyM {{0 1} {1 0}}] [$b unref]]
+ }
+
+ # Reduce using square-and-add
+ $b ref
+ set result [V new {1 1}]
+ while {$e != 0} {
+ if {$e & 1} {
+ set result [$b * $result]
+ set e [expr {$e & ~1}]
+ }
+ if {$e == 0} break
+ set b [K [[$b * $b] ref] [$b unref]]
+ set e [expr {$e>>1}]
+ }
+ $b unref
+ return $result
+}
+
+# math::exact::real**rat --
+#
+# Service procedure to raise a real number to a rational power.
+#
+# Parameters -
+#
+# b - The base to be exponentiated
+# m - The numerator of the power
+# n - The denominator of the power
+#
+# Preconditions:
+# n > 0
+#
+# Results:
+# Returns the power.
+#
+# This procedure is a Consumer with respect to its arguments and a
+# Constructor with respect to its result, returning a zero-ref object.
+
+proc math::exact::real**rat {b m n} {
+
+ variable isneg
+ variable ispos
+
+ # At this point we need to know the sign of b. Try to determine it.
+ # (This can be an infinite loop if b is zero or infinite)
+ while {1} {
+ if {[$b refinesM $ispos]} {
+ break
+ } elseif {[$b refinesM $isneg]} {
+ # negative number to rational power. The denominator must be
+ # odd.
+ if {$n % 2 == 0} {
+ return -code error -errorCode {MATH EXACT NEGATIVEPOWREAL} \
+ "negative number to real power"
+ } else {
+ set b [K [[$b ref] U-] [$b unref]]
+ tailcall [math::exact::real**rat $b $m $n] U-
+ }
+ } else {
+ # can't determine positive or negative yet
+ $b ref
+ set nextb [$b absorb]
+ set result [math::exact::real**rat $nextb $m $n]
+ $b unref
+ return $result
+ }
+ }
+
+ # Handle b(-m/n) by taking (1/b)(m/n)
+ if {$m < 0} {
+ set m [expr {-$m}]
+ set b [K [[$b ref] applyM {{0 1} {1 0}}] [$b unref]]
+ }
+
+ # Break m/n apart into integer and fractional parts
+ set i [expr {$m / $n}]
+ set m [expr {$m % $n}]
+
+ # Do the integer part
+ $b ref
+ set result [real**int $b $i]
+ if {$m == 0} {
+ # We really shouldn't get here if m/n is an integer, but don't choke
+ $b unref
+ return $result
+ }
+
+ # Come up with a rational approximation for b**(1/n)
+ # real: exp(log(b)/n)
+ set approx [[math::exact::function::exp \
+ [[math::exact::function::log $b] \
+ * [math::exact::V new [list 1 $n]]]] ref]
+ lassign [$approx getSignAndMagnitude] partial rest
+ $rest ref
+ $approx unref
+ while {1} {
+ lassign [$rest getLeadingDigitAndRest 0] digit y
+ $y ref
+ $rest unref
+ set partial [math::exact::mscale [math::exact::mdotm $partial $digit]]
+ set rest $y
+ lassign $partial pq rs
+ lassign $pq p q
+ lassign $rs r s
+ set qrn [expr {($q*$r)**$n}]
+ set t1 [expr {$qrn}]
+ set t2 [expr {2 * ($p*$s)**$n}]
+ set t3 [expr {4 * $qrn}]
+ if {$t1 < $t2 && $t2 < $t3} break
+ }
+ $y unref
+
+ # Get the residual
+
+ lassign [math::exact::vscale [list $r $s]] p q
+ set xn [math::exact::V new [list [expr {$p**$n}] [expr {$q**$n}]]]
+ set y [$b - $xn]; $b unref
+
+ # Launch a worker process to perform quasi-Newton iteration to refine
+ # the result
+
+ set retval [$result * [math::exact::PowWorker start $p $q $y $m $n]]
+ return $retval
+}
+
+# pi --
+#
+# Returns pi as an exact real
+
+proc math::exact::function::pi {} {
+ variable ::math::exact::pi
+ return $pi
+}
+
+# e --
+#
+# Returns e as an exact real
+
+proc math::exact::function::e {} {
+ variable ::math::exact::e
+ return $e
+}
+
+# math::exact::signum1 --
+#
+# Tests an argument's sign.
+#
+# Parameters:
+# x - Exact real number to test.
+#
+# Results:
+# Returns -1 if x < -1. Returns 1 if x > 1. May return -1, 0 or 1 if
+# -1 <= x <= 1.
+#
+# Equality of exact reals is not decidable, so a weaker version of comparison
+# testing is needed. This function provides the guts of such a thing. It
+# returns an approximation to the signum function that is exact for
+# |x| > 1, and arbitrary for |x| < 1.
+#
+# A typical use would be to replace a test p < q with a test that
+# looks like signum1((p-q) / epsilon) == -1. This test is decidable,
+# and becomes a test that is true if p < q - epsilon, false if p > q+epsilon,
+# and indeterminate if p lies within epsilon of q. This test is enough for
+# most checks for convergence or for selecting a branch of a function.
+#
+# This function is not decidable if it is not decidable whether x is finite.
+
+proc math::exact::signum1 {x} {
+ variable ispos
+ variable isneg
+ variable iszer
+ while {1} {
+ if {[$x refinesM $ispos]} {
+ return 1
+ } elseif {[$x refinesM $isneg]} {
+ return -1
+ } elseif {[$x refinesM $iszer]} {
+ return 0
+ } else {
+ set x [$x absorb]
+ }
+ }
+}
+
+# math::exact::abs1 -
+#
+# Test whether an exact real is 'small' in absolute value.
+#
+# Parameters:
+# x - Exact real number to test
+#
+# Results:
+# Returns 0 if |x| is 'close to zero', 1 if |x| is 'far from zero'
+# and either 0, or 1 if |x| is close to 1.
+#
+# This function is another useful comparator for convergence testing.
+# It returns a three-way indication:
+# |x| < 1/2 : 0
+# |x| > 1 : 1
+# 1/2 <= |x| <= 2 : May return -1, 0, 1
+#
+# This function is useful for convergence testing, where it is desired
+# to know whether a given value has an absolute value less than a given
+# tolerance.
+
+proc math::exact::abs1 {x} {
+ variable iszer
+ while 1 {
+ if {[$x refinesM $iszer]} {
+ return 0
+ } elseif {[$x refinesM {{2 1} {-2 1}}]} {
+ return 1
+ } else {
+ set x [$x absorb]
+ }
+ }
+}
+
+namespace eval math::exact {
+
+ # Constant vectors, matrices and tensors
+
+ ; # the identity matrix
+ variable identity {{ 1 0} { 0 1}}
+ ; # sign matrices for exact floating point
+ variable spos $identity
+ variable sinf {{ 1 -1} { 1 1}}
+ variable sneg {{ 0 1} {-1 0}}
+ variable szer {{ 1 1} {-1 1}}
+
+ ; # inverses of the sign matrices
+ variable ispos [reverse $spos]
+ variable isinf [reverse $sinf]
+ variable isneg [reverse $sneg]
+ variable iszer [reverse $szer]
+
+ ; # digit matrices for exact floating point
+ variable dneg {{ 1 1} { 0 2}}
+ variable dzer {{ 3 1} { 1 3}}
+ variable dpos {{ 2 0} { 1 1}}
+
+ ; # inverses of the digit matrices
+ variable idneg [reverse $dneg]
+ variable idzer [reverse $dzer]
+ variable idpos [reverse $dpos]
+
+ ; # aritmetic operators as tensors
+ variable tadd {{{ 0 0} { 1 0}} {{ 1 0} { 0 1}}}
+ variable tsub {{{ 0 0} { 1 0}} {{-1 0} { 0 1}}}
+ variable tmul {{{ 1 0} { 0 0}} {{ 0 0} { 0 1}}}
+ variable tdiv {{{ 0 0} { 1 0}} {{ 0 1} { 0 0}}}
+
+ proc init {} {
+
+ # Variables for fundamental constants e, pi, log2
+
+ variable e [[EWorker new] ref]
+
+ set worker \
+ [[math::exact::Mstrict new {{6795705 213440} {6795704 213440}} \
+ [math::exact::PiWorker new]] ref]
+ variable pi [[/real [function::sqrt [V new {10005 1}]] $worker] ref]
+ $worker unref
+
+ set worker [[Log2Worker new] ref]
+ variable log2 [[$worker applyM {{1 1} {1 2}}] ref]
+ $worker unref
+
+ }
+ init
+ rename init {}
+
+ namespace export exactexpr abs1 signum1
+}
+
+package provide math::exact 1.0
+
+#-----------------------------------------------------------------------
diff --git a/tcllib/modules/math/exact.test b/tcllib/modules/math/exact.test
new file mode 100644
index 0000000..9117dee
--- /dev/null
+++ b/tcllib/modules/math/exact.test
@@ -0,0 +1,2255 @@
+# exact.test --
+#
+# Test cases for the math::exact package
+#
+# Copyright (c) 2015 by Kevin B. Kenny
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+#-----------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.6
+testsNeedTcltest 2.3
+
+support {
+ use grammar_aycock/aycock-runtime.tcl grammar::aycock::runtime grammar::aycock
+ useKeep grammar_aycock/aycock-debug.tcl grammar::aycock::debug grammar::aycock
+ useKeep grammar_aycock/aycock-build.tcl grammar::aycock grammar::aycock
+}
+testing {
+ useLocal exact.tcl math::exact
+}
+
+package require Tcl 8.6
+package require grammar::aycock 1.0
+package require math::exact 1.0
+
+#-----------------------------------------------------------------------------
+
+namespace eval math::exact::test {
+
+ namespace import ::math::exact::exactexpr
+
+ proc signum {x} {expr {($x > 0) - ($x < 0)}}
+
+ proc leakBaseline {} {
+ variable leakBaseline
+ foreach o [info commands ::oo::Obj*] {
+ dict set leakBaseline $o {}
+ }
+ return
+ }
+
+ proc leakCheck {} {
+ variable leakBaseline
+ set trouble {}
+ set sep {}
+ foreach o [lsort -dictionary [info commands ::oo::Obj*]] {
+ if {![dict exists $leakBaseline $o]} {
+ if {[info object isa typeof $o math::exact::counted]} {
+ append trouble $sep "Leaked counted object " \
+ $o ": " [$o dump] \n
+ } else {
+ append trouble $sep "Leaked object " $o \n
+ }
+ }
+ }
+ if {$trouble ne {}} {
+ return -code error -errorcode {LEAKCHECK} $trouble
+ }
+ return
+ }
+
+ namespace import ::tcltest::test
+
+ test math::exact-1.0 {unit test gcd} {
+ math::exact::gcd 2
+ } 2
+ test math::exact-1.1 {unit test gcd} {
+ math::exact::gcd 2 0
+ } 2
+ test math::exact-1.2 {unit test gcd} {
+ math::exact::gcd 0 2
+ } 2
+ test math::exact-1.3 {unit test gcd} {
+ math::exact::gcd 2 3
+ } 1
+ test math::exact-1.4 {unit test gcd} {
+ math::exact::gcd 3 2
+ } 1
+ test math::exact-1.5 {unit test gcd} {
+ math::exact::gcd 21 12
+ } 3
+ test math::exact-1.6 {unit test gcd} {
+ math::exact::gcd 12 21
+ } 3
+ test math::exact-1.5 {unit test gcd} {
+ math::exact::gcd 21 12
+ } 3
+ test math::exact-1.6 {unit test gcd} {
+ math::exact::gcd 12 21
+ } 3
+ test math::exact-1.7 {unit test gcd} {
+ math::exact::gcd 108 66
+ } 6
+ test math::exact-1.8 {unit test gcd} {
+ math::exact::gcd 66 108
+ } 6
+ test math::exact-1.9 {unit test gcd} {
+ math::exact::gcd 66 108 88
+ } 2
+
+ test math::exact-2.0 {unit test transpose matrix} {
+ math::exact::trans {{0 1} {2 3}}
+ } {{0 2} {1 3}}
+ test math::exact-2.1 {unit test transpose 2x2x2} {
+ math::exact::trans {{{0 1} {2 3}} {{4 5} {6 7}}}
+ } {{{0 1} {4 5}} {{2 3} {6 7}}}
+
+ test math::exact-3.1 {unit test determinant} {
+ math::exact::determinant {{2 3} {5 7}}
+ } -1
+
+ test math::exact-4.1 {unit test reverse} {
+ math::exact::reverse {{2 3} {5 7}}
+ } {{7 -3} {-5 2}}
+
+ test math::exact-5.1 {unit test veven} {
+ math::exact::veven {2 4}
+ } 1
+ test math::exact-5.2 {unit test veven} {
+ math::exact::veven {2 3}
+ } 0
+
+ test math::exact-6.1 {unit test meven} {
+ math::exact::meven {{2 4} {6 8}}
+ } 1
+ test math::exact-6.2 {unit test meven} {
+ math::exact::meven {{2 3} {6 8}}
+ } 0
+
+ test math::exact-7.1 {unit test teven} {
+ math::exact::teven {{{2 4} {6 8}} {{10 12} {14 16}}}
+ } 1
+ test math::exact-7.2 {unit test teven} {
+ math::exact::teven {{{2 4} {6 8}} {{10 13} {14 16}}}
+ } 0
+
+ test math::exact-8.1 {unit test vhalf} {
+ math::exact::vhalf {6 8}
+ } {3 4}
+
+ test math::exact-9.1 {unit test mhalf} {
+ math::exact::mhalf {{6 8} {10 12}}
+ } {{3 4} {5 6}}
+
+ test math::exact-10.1 {unit test thalf} {
+ math::exact::thalf {{{6 8} {10 12}} {{14 16} {18 20}}}
+ } {{{3 4} {5 6}} {{7 8} {9 10}}}
+
+ test math::exact-11.1 {unit test sign} {
+ set trouble {}
+ set sep \n
+ for {set a -1} {$a <= 1} {incr a} {
+ for {set b -1} {$b <= 1} {incr b} {
+ if {$a ==0 && $b == 0} {
+ set sb 0
+ } elseif {$a == 0} {
+ set sb [signum $b]
+ } elseif {$b == 0} {
+ set sb [signum $a]
+ } elseif {$a/$b < 0} {
+ set sb 0
+ } else {
+ set sb [signum $a]
+ }
+ set is [math::exact::sign [list $a $b]]
+ if {$is != $sb} {
+ append trouble "sign(" $a "," $b ") is " $is \
+ ", should be " $sb "\n"
+ }
+ }
+ }
+ set trouble
+ } {}
+
+ test math::exact-12.1 {unit test vrefines} {
+ set trouble {}
+ set sep {}
+ for {set a -1} {$a <= 1} {incr a} {
+ for {set b -1} {$b <= 1} {incr b} {
+ if {$a ==0 && $b == 0} {
+ set sb 0
+ } elseif {$a == 0} {
+ set sb 1
+ } elseif {$b == 0} {
+ set sb 1
+ } elseif {$a/$b < 0} {
+ set sb 0
+ } else {
+ set sb 1
+ }
+ set is [math::exact::vrefines [list $a $b]]
+ if {$is != $sb} {
+ append trouble $sep "vrefines(" $a "," $b ") is " $is \
+ ", should be " $sb
+ set sep \n
+ }
+ }
+ }
+ set trouble
+ } {}
+
+ test math::exact-13.1 {unit test mrefines} {
+ math::exact::mrefines {{1 2} {3 4}}
+ } 1
+ test math::exact-13.2 {unit test mrefines} {
+ math::exact::mrefines {{1 2} {-3 -4}}
+ } 0
+ test math::exact-13.3 {unit test mrefines} {
+ math::exact::mrefines {{-1 -2} {-3 -4}}
+ } 1
+ test math::exact-13.4 {unit test mrefines} {
+ math::exact::mrefines {{-1 2} {-3 4}}
+ } 0
+
+ test math::exact-14.1 {unit test trefines} {
+ math::exact::trefines {{{1 2} {3 4}} {{5 6} {7 8}}}
+ } 1
+ test math::exact-14.2 {unit test trefines} {
+ math::exact::trefines {{{-1 -2} {-3 -4}} {{-5 -6} {-7 -8}}}
+ } 1
+ test math::exact-14.3 {unit test trefines} {
+ math::exact::trefines {{{-1 2} {-3 4}} {{-5 6} {-7 8}}}
+ } 0
+ test math::exact-14.4 {unit test trefines} {
+ math::exact::trefines {{{1 2} {3 4}} {{5 6}} {{-7 -8}}}
+ } 0
+ test math::exact-14.5 {unit test trefines} {
+ math::exact::trefines {{{1 2} {3 4}} {{-5 -6}} {{-7 -8}}}
+ } 0
+ test math::exact-14.6 {unit test trefines} {
+ math::exact::trefines {{{1 2} {-3 -4}} {{-5 -6}} {{-7 -8}}}
+ } 0
+
+ test math::exact-15.1 {unit test vlessv} {
+ set intervals {
+ {-1 0} {-2 1} {-1 1} {-1 2} {0 1} {2 4} {3 3} {14 7} {1 0}
+ }
+ set trouble {}
+ set sep {}
+ set i 0
+ foreach a $intervals {
+ set j 0
+ foreach b $intervals {
+ set is [math::exact::vlessv $a $b]
+ if {[lindex $a 1] == 0 && [lindex $b 1] == 0} {
+ set sb 0
+ } else {
+ set sb [expr {$i < $j}]
+ }
+ if {$is != $sb} {
+ append trouble $sep "vlessv(" $a ";" $b ") is " $is \
+ " should be " $sb
+ set sep \n
+ }
+ incr j
+ }
+ incr i
+ }
+ set trouble
+ } {}
+
+ test math::exact-16.1 {unit test mlessm - also tests mlessv} {
+ set intervals {
+ {-2 1} {-1 1} {-1 2} {0 1} {2 4} {3 3} {14 7} {1 0}
+ }
+ set trouble {}
+ set sep {}
+ set i 0
+ foreach a $intervals {
+ set j $i
+ foreach b [lrange $intervals $i end] {
+ set k 0
+ foreach c $intervals {
+ set l $k
+ foreach d [lrange $intervals $k end] {
+ if {[lindex $b 1] == 0 && [lindex $c 1] == 0} {
+ set sb 0
+ } else {
+ set sb [expr {$j < $k}]
+ }
+ set is [math::exact::mlessm [list $b $a] [list $d $c]]
+ if {$is != $sb} {
+ append trouble $sep "mlessm(" $a "," $b ";" \
+ $c "," $d ") is " $is \
+ " should be " $sb " -- " \
+ [list i $i j $j k $k l $k]
+ set sep \n
+ }
+ incr l
+ }
+ incr k
+ }
+ incr j
+ }
+ incr i
+ }
+ set trouble
+ } {}
+
+ test math::exact-17.1 {unit test vscale} {
+ math::exact::vscale {2 3}
+ } {2 3}
+ test math::exact-17.2 {unit test vscale} {
+ math::exact::vscale {4 6}
+ } {2 3}
+ test math::exact-17.1 {unit test vscale} {
+ math::exact::vscale {8 12}
+ } {2 3}
+
+ test math::exact-18.1 {unit test mscale} {
+ math::exact::mscale {{2 3} {4 5}}
+ } {{2 3} {4 5}}
+ test math::exact-18.2 {unit test mscale} {
+ math::exact::mscale {{4 6} {8 10}}
+ } {{2 3} {4 5}}
+ test math::exact-18.3 {unit test mscale} {
+ math::exact::mscale {{8 12} {16 20}}
+ } {{2 3} {4 5}}
+
+ test math::exact-19.1 {unit test tscale} {
+ math::exact::tscale {{{2 3} {4 5}} {{6 7} {8 9}}}
+ } {{{2 3} {4 5}} {{6 7} {8 9}}}
+ test math::exact-19.2 {unit test tscale} {
+ math::exact::tscale {{{4 6} {8 10}} {{12 14} {16 18}}}
+ } {{{2 3} {4 5}} {{6 7} {8 9}}}
+ test math::exact-10.3 {unit test tscale} {
+ math::exact::tscale {{{8 12} {16 20}} {{24 28} {32 36}}}
+ } {{{2 3} {4 5}} {{6 7} {8 9}}}
+
+ test math::exact-20.1 {unit test vreduce} {
+ math::exact::vreduce {2 3}
+ } {2 3}
+ test math::exact-20.2 {unit test vreduce} {
+ math::exact::vreduce {4 6}
+ } {2 3}
+ test math::exact-20.1 {unit test vreduce} {
+ math::exact::vreduce {8 12}
+ } {2 3}
+
+ test math::exact-21.1 {unit test mreduce} {
+ math::exact::mreduce {{2 3} {4 5}}
+ } {{2 3} {4 5}}
+ test math::exact-21.2 {unit test mreduce} {
+ math::exact::mreduce {{4 6} {8 10}}
+ } {{2 3} {4 5}}
+ test math::exact-21.3 {unit test mreduce} {
+ math::exact::mreduce {{8 12} {16 20}}
+ } {{2 3} {4 5}}
+
+ test math::exact-22.1 {unit test treduce} {
+ math::exact::treduce {{{2 3} {4 5}} {{6 7} {8 9}}}
+ } {{{2 3} {4 5}} {{6 7} {8 9}}}
+ test math::exact-22.2 {unit test treduce} {
+ math::exact::treduce {{{4 6} {8 10}} {{12 14} {16 18}}}
+ } {{{2 3} {4 5}} {{6 7} {8 9}}}
+ test math::exact-22.3 {unit test treduce} {
+ math::exact::treduce {{{8 12} {16 20}} {{24 28} {32 36}}}
+ } {{{2 3} {4 5}} {{6 7} {8 9}}}
+
+ test math::exact-23.1 {unit test mdotv} {
+ math::exact::mdotv {{2 3} {4 5}} {10 1}
+ } {24 35}
+
+ test math::exact-24.1 {unit test mdotm} {
+ math::exact::mdotm {{2 3} {4 5}} {{1000 10} {100 1}}
+ } {{2040 3050} {204 305}}
+
+ test math::exact-25.1 {unit test mdott} {
+ math::exact::mdott {{1000 10} {100 1}} {{{2 3} {4 5}} {{6 7} {8 9}}}
+ } {{{2300 23} {4500 45}} {{6700 67} {8900 89}}}
+
+ test math::exact-26.1 {unit test tleftv} {
+ math::exact::tleftv {{{2 3} {4 5}} {{6 7} {8 9}}} {10 1}
+ } {{26 37} {48 59}}
+
+ test math::exact-27.1 {unit test trightv} {
+ math::exact::trightv {{{2 3} {4 5}} {{6 7} {8 9}}} {10 1}
+ } {{24 35} {68 79}}
+
+ test math::exact-28.1 {unit test tleftm} {
+ math::exact::tleftm {{{2 3} {4 5}} {{6 7} {8 9}}} {{1000 10} {100 1}}
+ } {{{2060 3070} {4080 5090}} {{206 307} {408 509}}}
+
+ test math::exact-29.1 {unit test trightm} {
+ math::exact::trightm {{{2 3} {4 5}} {{6 7} {8 9}}} {{1000 10} {100 1}}
+ } {{{2040 3050} {204 305}} {{6080 7090} {608 709}}}
+
+ test math::exact-30.1 {unit test mdisjointm} {
+ set intervals {
+ {-2 1} {-1 1} {-1 2} {0 1} {2 4} {3 3} {14 7} {1 0}
+ }
+ set trouble {}
+ set sep {}
+ set i 0
+ foreach a $intervals {
+ set j $i
+ foreach b [lrange $intervals $i end] {
+ set k 0
+ foreach c $intervals {
+ set l $k
+ foreach d [lrange $intervals $k end] {
+ set sb [expr {$j < $k || $l < $i}]
+ set is [math::exact::mdisjointm \
+ [list $b $a] [list $d $c]]
+ if {$is != $sb} {
+ append trouble $sep "mdisjointm(" $a "," $b ";" \
+ $c "," $d ") is " $is \
+ " should be " $sb " -- " \
+ [list i $i j $j k $k l $k]
+ set sep \n
+ }
+ incr l
+ }
+ incr k
+ }
+ incr j
+ }
+ incr i
+ }
+ set trouble
+ } {}
+
+ test math::exact-31.0 {mAsFloat, rational} {
+ math::exact::mAsFloat {{1 3} {1 3}}
+ } 1/3
+
+ test math::exact-31.1 {mAsFloat, scientificNotation, mantissa, eFormat} {
+ set p 0
+ set q 1
+ set res {}
+ for {set i 0} {$i < 16} {incr i} {
+ set r [expr {$p + $q}]
+ if {$q * $q > $p * $r} {
+ set m [list [list $q $p] \
+ [list $r $q]]
+ } else {
+ set m [list [list $r $q] \
+ [list $q $p]]
+ }
+ lappend res [math::exact::mAsFloat $m]
+ set p $q
+ set q $r
+ }
+ set res
+ } [list \
+ Undetermined 1.e0 1.e0 1.6e0 1.6e0 1.6e0 1.62e0 1.61e0 1.61e0 \
+ 1.618e0 1.618e0 1.6180e0 1.6180e0 1.61803e0 1.61803e0 1.61803e0]
+
+ test math::exact-31.2 {mAsFloat, scientificNotation, mantissa, eFormat} {
+ set p 0
+ set q 1
+ set res {}
+ for {set i 0} {$i < 16} {incr i} {
+ set r [expr {$p + $q}]
+ if {$q * $q > $p * $r} {
+ set m [list [list [expr {1000*$q}] $p] \
+ [list [expr {1000*$r}] $q]]
+ } else {
+ set m [list [list [expr {1000*$r}] $q] \
+ [list [expr {1000*$q}] $p]]
+ }
+ lappend res [math::exact::mAsFloat $m]
+ set p $q
+ set q $r
+ }
+ set res
+ } [list \
+ Undetermined 1.e3 1.e3 1.6e3 1.6e3 1.6e3 1.62e3 1.61e3 1.61e3 \
+ 1.618e3 1.618e3 1.6180e3 1.6180e3 1.61803e3 1.61803e3 1.61803e3]
+
+ test math::exact-31.3 {mAsFloat, scientificNotation, mantissa, eFormat} {
+ set p 0
+ set q 1
+ set res {}
+ for {set i 0} {$i < 16} {incr i} {
+ set r [expr {$p + $q}]
+ if {$q * $q > $p * $r} {
+ set m [list [list $q [expr {1000*$p}]] \
+ [list $r [expr {1000*$q}]]]
+ } else {
+ set m [list [list $r [expr {1000*$q}]] \
+ [list $q [expr {1000*$p}]]]
+ }
+ lappend res [math::exact::mAsFloat $m]
+ set p $q
+ set q $r
+ }
+ set res
+ } [list \
+ Undetermined 1.e-3 1.e-3 1.6e-3 1.6e-3 \
+ 1.6e-3 1.62e-3 1.61e-3 1.61e-3 \
+ 1.618e-3 1.618e-3 1.6180e-3 1.6180e-3 \
+ 1.61803e-3 1.61803e-3 1.61803e-3]
+
+ test math::exact-31.4 {mAsFloat, scientificNotation, mantissa, eFormat} {
+ set p 0
+ set q 1
+ set res {}
+ for {set i 0} {$i < 16} {incr i} {
+ set r [expr {$p + $q}]
+ set mq [expr {-$q}]
+ set mr [expr {-$r}]
+ if {$q * $q > $p * $r} {
+ set m [list [list $mq $p] \
+ [list $mr $q]]
+ } else {
+ set m [list [list $mr $q] \
+ [list $mq $p]]
+ }
+ lappend res [math::exact::mAsFloat $m]
+ set p $q
+ set q $r
+ }
+ set res
+ } [list \
+ Undetermined -2.e0 -2.e0 -1.6e0 \
+ -1.7e0 -1.7e0 -1.62e0 -1.62e0 \
+ -1.62e0 -1.618e0 -1.618e0 -1.6180e0 \
+ -1.6181e0 -1.61803e0 -1.61804e0 -1.61804e0]
+
+ test math::exact-31.5 {mAsFloat, 0/0} {
+ math::exact::mAsFloat {{0 0} {0 0}}
+ } NaN
+
+ test math::exact-31.6 {mAsFloat, infinity} {
+ math::exact::mAsFloat {{1 0} {1 0}}
+ } Inf
+
+ test math::exact-31.7 {mAsFloat, zero} {
+ math::exact::mAsFloat {{0 1} {0 1}}
+ } 0
+
+ test math::exact-31.8 {mAsFloat, integer} {
+ math::exact::mAsFloat {{2 1} {2 1}}
+ } 2
+
+ test math::exact-31.9 {mAsFloat, reverse signs} {
+ list [math::exact::mAsFloat {{2 -1} {2 -1}}] \
+ [math::exact::mAsFloat {{-2 -1} {-2 -1}}]
+ } {-2 2}
+
+ test math::exact-40.1 {simple expr} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {1}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 1.0000000000000000e0}
+ }
+
+ test math::exact-40.2 {unary plus} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {+ 1}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 1.0000000000000000e0}
+ }
+
+ test math::exact-40.3 {unary minus} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {- 1}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {-1 -9.999999999999999e-1}
+ }
+
+ test math::exact-40.4 {product} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {2 * 3}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {6 6.000000000000000e0}
+ }
+
+ test math::exact-40.5 {quotient} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {2 / 3}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {2/3 6.666666666666666e-1}
+ }
+
+ test math::exact-40.6 {associativity of /} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {2 / 3 / 4}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1/6 1.6666666666666667e-1}
+ }
+
+ test math::exact-40.7 {associativity of */} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {2 / 3 * 4}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {8/3 2.6666666666666667e0}
+ }
+
+ test math::exact-40.8 {associativity of */} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {2 * 3 / 4}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {3/2 1.5000000000000000e0}
+ }
+
+ test math::exact-40.9 {sum} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {2 + 3}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {5 5.000000000000000e0}
+ }
+
+ test math::exact-40.10 {difference} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {2 - 3}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {-1 -9.999999999999999e-1}
+ }
+
+ test math::exact-40.11 {associativity of -} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {2 - 3 - 4}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {-5 -5.000000000000000e0}
+ }
+
+ test math::exact-40.12 {associativity of +-} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {2 - 3 + 4}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {3 3.0000000000000001e0}
+ }
+
+ test math::exact-40.13 {associativity of +-} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {2 + 3 - 4}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 1.0000000000000000e0}
+ }
+
+ test math::exact-40.14 {precedence of +*} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {3 + 5 * 7}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {38 3.800000000000000e1}
+ }
+
+ test math::exact-40.15 {precedence of +*} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {3 * 5 + 7}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {22 2.200000000000000e1}
+ }
+
+ test math::exact-40.16 {parentheses} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {(2 + 3) * 5}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {25 2.500000000000000e1}
+ }
+
+ test math::exact-40.17 {V + E} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {2 + real(-3/5)}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1.4000000000000000e0 1.4000000000000000e0}
+ }
+
+ test math::exact-40.18 {V - E} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {2 - real(3/5)}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1.4000000000000000e0 1.4000000000000000e0}
+ }
+
+ test math::exact-40.19 {E / E} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {real(3/5)/real(2/5)}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1.5000000000000000e0 1.5000000000000000e0}
+ }
+
+ test math::exact-40.20 {E + V} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {real(3/2) + (2/5)}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1.9000000000000000e0 1.9000000000000000e0}
+ }
+
+ test math::exact-40.21 {E - V} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {real(3/2) - (2/5)}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1.1000000000000000e0 1.1000000000000000e0}
+ }
+
+ test math::exact-40.22 {E * V} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {real(3/2) * (2/5)}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {6.0000000000000001e-1 6.0000000000000001e-1}
+ }
+
+ test math::exact-40.23 {E / V} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {real(3/2) / (5/2)}] ref]
+ set result [list [$v asPrint 57] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {6.0000000000000001e-1 6.0000000000000001e-1}
+ }
+
+ test math::exact-40.24 {lexical error} {
+ -setup leakBaseline
+ -body {
+ set result [list [catch {exactexpr {2 ! 1}} m] $m]
+ leakCheck
+ set result
+ }
+ -match glob
+ -result {1 {invalid character*}}
+ }
+
+ test math::exact-40.25 {syntax error} {
+ -setup leakBaseline
+ -body {
+ set result [list [catch {exactexpr {2 $ 1}} m] $m]
+ leakCheck
+ set result
+ }
+ -match glob
+ -result {1 {syntax error*}}
+ }
+
+ test math::exact-41.1 {square root} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sqrt(25/16)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ #leakCheck
+ set result
+ }
+ -result {1 1.2500000000000000e0}
+ }
+
+ test math::exact-41.2 {square root} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sqrt(2)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 1.4142135623730950e0}
+ }
+
+ test math::exact-41.3 {square root} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sqrt(2000000)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 1.4142135623731e3}
+ }
+
+ test math::exact-41.4 {square root} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sqrt(2 / 1000000)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 1.41421356237309e-3}
+ }
+
+ test math::exact-41.5 {square root} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sqrt(sqrt(1/81))}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 3.3333333333333333e-1}
+ }
+
+ test math::exact-41.6 {square root of negative rational} {
+ -setup {
+ leakBaseline
+ catch {unset v}
+ }
+ -body {
+ set v [[exactexpr {sqrt(-1)}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ unset v
+ set result
+ }
+ -cleanup {
+ if {[info exists v]} {$v unref}
+ }
+ -match glob
+ -returnCodes error
+ -result {*negative argument*}
+ }
+
+ test math::exact-41.7 {square root of negative real} {
+ -setup {
+ leakBaseline
+ catch {unset v}
+ }
+ -body {
+ set v [[exactexpr {sqrt(-sqrt(81))}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ unset v
+ set result
+ }
+ -cleanup {
+ if {[info exists v]} {$v unref}
+ }
+ -match glob
+ -returnCodes error
+ -result {*negative argument*}
+ }
+
+ test math::exact-41.8 {square root, cached result} {
+ -setup leakBaseline
+ -body {
+ set x [[exactexpr {sqrt(2)}] ref]
+ set y [[exactexpr {$x * $x}] ref]
+ $x unref
+ set result [list [$y asFloat 57] [$y asFloat 57]]
+ $y unref
+ leakCheck
+ set result
+ }
+ -result {2.0000000000000000e0 2.0000000000000000e0}
+ }
+
+ test math::exact-42.1 {exponential} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {exp(1)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 2.7182818284590452e0}
+ }
+
+ test math::exact-42.2 {exponential} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {exp(4)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 5.45981500331442e1}
+ }
+
+ test math::exact-42.3 {exponential} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {exp(0)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 1.0000000000000000e0}
+ }
+
+ test math::exact-43.1 {logarithm} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {log(1)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-43.2 {logarithm} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {log(2)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 6.931471805599453e-1}
+ }
+
+ test math::exact-43.3 {logarithm} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {log(1/2)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 -6.931471805599454e-1}
+ }
+
+ test math::exact-43.4 {logarithm} {
+ -setup {
+ # Consume digits from math::exact::log2 to avoid appearance of
+ # a leak in its cache
+ $math::exact::log2 asFloat 100
+ leakBaseline
+ }
+ -body {
+ set v [[exactexpr {log(4)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 1.3862943611198906e0}
+ }
+
+ test math::exact-43.5 {logarithm} {
+ -setup {
+ # Consume digits from math::exact::log2 to avoid appearance of
+ # a leak in its cache
+ $math::exact::log2 asFloat 100
+ leakBaseline
+ }
+ -body {
+ set v [[exactexpr {log(1/4)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 -1.3862943611198907e0}
+ }
+
+ test math::exact-43.6 {logarithm} {
+ -setup {
+ # Consume digits from math::exact::log2 to avoid appearance of
+ # a leak in its cache
+ $math::exact::log2 asFloat 100
+ leakBaseline
+ }
+ -body {
+ set v [[exactexpr {log(exp(10))}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 1.0000000000000000e1}
+ }
+
+ test math::exact-43.7 {logarithm} {
+ -setup {
+ # Consume digits from math::exact::log2 to avoid appearance of
+ # a leak in its cache
+ $math::exact::log2 asFloat 100
+ leakBaseline
+ }
+ -body {
+ set v [[exactexpr {log(exp(1/10))}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 1.0000000000000000e-1}
+ }
+
+ test math::exact-43.8 {logarithm of negative argument} {
+ -setup {
+ leakBaseline
+ catch {unset v}
+ }
+ -body {
+ set v [[exactexpr {log(-sqrt(81))}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ unset v
+ set result
+ }
+ -cleanup {
+ if {[info exists v]} {$v unref}
+ }
+ -match glob
+ -returnCodes error
+ -result {*negative argument*}
+ }
+
+ test math::exact-44.1 {pi} {
+ -setup {
+ # Consume digits from math::exact::pi to avoid appearance of
+ # a leak in its cache
+ $math::exact::pi asFloat 3000
+ leakBaseline
+ }
+ -body {
+ set v [[exactexpr {pi()}] ref]
+ set result [$v asFloat 3000]
+ $v unref
+ leakCheck
+ list [string range $result 0 4] \
+ [string first 999999 $result] \
+ [string range $result end-1 end]
+ }
+ -result {3.141 763 e0}
+ }
+
+ test math::exact-44.2 {Ramanujan constant} {
+ -setup {
+ # Consume digits from math::exact::pi to avoid appearance of
+ # a leak in its cache
+ $math::exact::pi asFloat 100
+ leakBaseline
+ }
+ -body {
+ set v [[exactexpr {exp(pi()*sqrt(163))}] ref]
+ set result [$v asFloat 160]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 2.625374126407687439999999999992e17
+ }
+
+
+ test math::exact-45.1 {tangent} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {tan(0)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-45.2 {tangent} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {tan(pi()/4)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 1.0000000000000000e0}
+ }
+
+ test math::exact-45.3 {tangent} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {tan(pi()/-4)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 -1.0000000000000000e0}
+ }
+
+ test math::exact-45.4 {tangent} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {tan(pi()/3)-sqrt(3)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-45.5 {tangent} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {tan(-pi()/3)+sqrt(3)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-45.6 {tangent} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {1/tan(pi()/2)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-45.7 {tangent} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {tan(pi()/2)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 Undetermined}
+ }
+
+ test math::exact-46.1 {sine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sin(0)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-46.2 {sine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sin(pi()/6)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 5.000000000000000e-1}
+ }
+
+ test math::exact-46.3 {sine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sin(-pi()/6)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 -5.000000000000000e-1}
+ }
+
+ test math::exact-46.4 {sine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sin(pi()/2)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 1.0000000000000000e0}
+ }
+
+ test math::exact-46.5 {sine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sin(-pi()/2)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 -1.0000000000000000e0}
+ }
+
+ test math::exact-46.6 {sine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sin(pi())}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-46.7 {sine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sin(-pi())}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-46.8 {sine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sin(13*pi()/6)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 5.000000000000000e-1}
+ }
+
+ test math::exact-46.9 {sine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sin(-13*pi()/6)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 -5.000000000000000e-1}
+ }
+
+ test math::exact-47.1 {cosine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {cos(0)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 9.999999999999999e-1}
+ }
+
+ test math::exact-47.2 {cosine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {cos(pi()/3)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 5.000000000000000e-1}
+ }
+
+ test math::exact-47.3 {cosine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {cos(-pi()/3)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 5.000000000000000e-1}
+ }
+
+ test math::exact-47.4 {cosine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {cos(pi()/2)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-47.5 {cosine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {cos(-pi()/2)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-47.6 {cosine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {cos(pi())}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 -1.0000000000000000e0}
+ }
+
+ test math::exact-47.7 {cosine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {cos(-pi())}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 -1.0000000000000000e0}
+ }
+
+ test math::exact-47.8 {cosine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {cos(7*pi()/3)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 5.000000000000000e-1}
+ }
+
+ test math::exact-47.9 {cosine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {cos(-7*pi()/3)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 5.000000000000000e-1}
+ }
+
+ test math::exact-45.1 {arctangent} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {atan(0)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-45.2 {arctangent} {
+ -setup leakBaseline
+ -body {
+ # Hack to get $szer as a sign matrix
+ set v [[exactexpr {atan(pi()-pi())}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-45.3 {arctangent} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {4*atan(1)-pi()}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-45.4 {arctangent} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {4*atan(-1)+pi()}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-45.5 {arctangent} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {atan(tan(157/100))}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 1.5700000000000000e0}
+ }
+
+ test math::exact-45.6 {arctangent, cached} {
+ -setup leakBaseline
+ -body {
+ set u [[exactexpr {atan(1)}] ref]
+ set v [[exactexpr {$u + $u + $u + $u}] ref]
+ $u unref
+ set result [$v asFloat 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 3.1415926535897933e0
+ }
+
+ test math::exact-46.1 {arcsine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {asin(0)}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-46.2 {arcsine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {asin(1/2)-pi()/6}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-46.3 {arcsine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {asin(-1/2)+pi()/6}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-47.1 {arccosine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {acos(0)-pi()/2}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-47.2 {arccosine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {acos(1/2)-pi()/3}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-47.3 {arccosine} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {acos(-1/2)-2*pi()/3}] ref]
+ set result [list [$v refcount] [$v asFloat 57]]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1 0e-18}
+ }
+
+ test math::exact-48.1 {hyperbolic functions} {
+ -setup leakBaseline
+ -body {
+ set result {}
+ set v [[exactexpr {sinh(0)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ set v [[exactexpr {cosh(0)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ set v [[exactexpr {tanh(0)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {0e-18 1.0000000000000000e0 0e-18}
+ }
+
+ test math::exact-48.2 {hyperbolic functions} {
+ -setup leakBaseline
+ -body {
+ set result {}
+ set v [[exactexpr {sinh(1)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ set v [[exactexpr {cosh(1)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ set v [[exactexpr {tanh(1)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1.1752011936438014e0 1.5430806348152437e0 7.615941559557649e-1}
+ }
+
+ test math::exact-48.3 {hyperbolic functions} {
+ -setup leakBaseline
+ -body {
+ set result {}
+ set v [[exactexpr {sinh(-1)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ set v [[exactexpr {cosh(-1)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ set v [[exactexpr {tanh(-1)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {-1.1752011936438015e0 1.5430806348152437e0 -7.615941559557649e-1}
+ }
+
+ test math::exact-49.1 {asinh} {
+ -setup leakBaseline
+ -body {
+ set result {}
+ set v [[exactexpr {asinh(-1)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ set v [[exactexpr {asinh(0)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ set v [[exactexpr {asinh(1)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {-8.813735870195431e-1 0e-18 8.813735870195430e-1}
+ }
+
+ test math::exact-50.1 {acosh} {
+ -setup leakBaseline
+ -body {
+ set result {}
+ set v [[exactexpr {acosh(3/2)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ set v [[exactexpr {acosh(2)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ set v [[exactexpr {acosh(3)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {9.624236501192069e-1 1.3169578969248167e0 1.7627471740390860e0}
+ }
+
+ test math::exact-51.1 {atanh} {
+ -setup leakBaseline
+ -body {
+ set result {}
+ set v [[exactexpr {atanh(-1/2)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ set v [[exactexpr {atanh(0)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ set v [[exactexpr {atanh(1/2)}] ref]
+ lappend result [$v asFloat 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {-5.4930614433405485e-1 0e-18 5.4930614433405485e-1}
+ }
+
+ test math::exact-52.1 {e} {
+ -setup {
+ # don't report cached digits of e as a leak
+ $math::exact::e asPrint 100;
+ leakBaseline
+ }
+ -body {
+ set v [[exactexpr {e()}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 2.7182818284590452e0
+ }
+
+ test math::exact-52.2 {e} {
+ -setup {
+ # don't report cached digits of e as a leak
+ $math::exact::e asPrint 100;
+ leakBaseline
+ }
+ -body {
+ set v [[exactexpr {log(e())}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 1.0000000000000000e0
+ }
+
+ test math::exact-52.2 {e} {
+ -setup {
+ # don't report cached digits of e as a leak
+ $math::exact::e asPrint 100;
+ leakBaseline
+ }
+ -body {
+ set v [[exactexpr {asinh((e() - 1/e()) / 2)}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 1.0000000000000000e0
+ }
+
+ test math::exact-53.1 {real**real} {
+ -setup {
+ # Consume digits from math::exact::e and math::exact::log2
+ # to avoid appearance of a leak in the cache
+ $math::exact::e asFloat 100
+ $math::exact::log2 asFloat 100
+ leakBaseline
+ }
+ -body {
+ set v [[exactexpr {e() ** log(2)}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 2.0000000000000000e0
+ }
+
+ test math::exact-53.2 {rational**real} {
+ -setup {
+ # Consume digits from math::exact::e
+ # to avoid appearance of a leak in the cache
+ $math::exact::e asFloat 100
+ leakBaseline
+ }
+ -body {
+ set v [[exactexpr {2 ** e()}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 6.580885991017921e0
+ }
+
+ test math::exact-53.3 {real**1} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sqrt(4) ** 1}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 2.0000000000000000e0
+ }
+
+ test math::exact-53.4 {real**-1} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sqrt(4) ** (-1)}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 5.000000000000000e-1
+ }
+
+ test math::exact-53.5 {real**0} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sqrt(4) ** 0}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 1
+ }
+
+ test math::exact-53.6 {real**+int} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sqrt(4)**2}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 4.000000000000000e0
+ }
+
+ test math::exact-53.7 {real**+int} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sqrt(4)**5}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 3.200000000000000e1
+ }
+
+ test math::exact-53.6 {real**-int} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sqrt(4)**-2}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 2.5000000000000000e-1
+ }
+
+ test math::exact-53.7 {real**+int} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sqrt(4)**-5}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 3.125000000000000e-2
+ }
+
+ test math::exact-53.8 {real**rational} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sqrt(64)**(10/3)}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 1.02400000000000e3
+ }
+
+ test math::exact-53.9 {real**rational} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {sqrt(64)**(1/-3)}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 5.000000000000000e-1
+ }
+
+ test math::exact-53.10 {real**integer, accidental} {
+ -setup leakBaseline
+ -body {
+ set v [[math::exact::real**rat [exactexpr {3}] 2 1] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 9
+ }
+
+ test math::exact-53.11 {zero to zero power} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {0**0}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -returnCodes error
+ -result "zero to zero power"
+ }
+
+ test math::exact-53.12 {zero to infinite power} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {0**(1/0)}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -returnCodes error
+ -result "zero to infinite power"
+ }
+
+ test math::exact-53.13 {zero to rational power} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {0**(1/2)}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 0
+ }
+
+ test math::exact-53.14 {infinity to zero power} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {(1/0)**0}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -returnCodes error
+ -result "infinity to zero power"
+ }
+
+ test math::exact-53.15 {infinity to negative power} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {(1/0)**-1}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 0
+ }
+
+ test math::exact-53.15 {infinity to positive power} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {(1/0)**1}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result Inf
+ }
+
+ test math::exact-53.16 {rational to zero power} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {(2/3)**0}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 1
+ }
+
+ test math::exact-53.17 {rational power of negative real argument} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {(-sqrt(64))**(1/3)}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result -2.0000000000000000e0
+ }
+
+ test math::exact-53.18 {rational power of argument near zero} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {log(exp(1/8))**(1/3)}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 5.000000000000000e-1
+ }
+
+ test math::exact-53.19 {negative real to real power} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {(-sqrt(4))**(1/2)}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -returnCodes error
+ -result "negative number to real power"
+ }
+
+ test math::exact-53.20 {rational to zero power} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {(2/3)**0}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 1
+ }
+
+ test math::exact-53.21 {rational to positive integer power} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {(2/3)**2}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 4/9
+ }
+
+ test math::exact-53.22 {rational to negative integer power} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {(2/3)**-2}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result 9/4
+ }
+
+ test math::exact-53.23 {rational to rational} {
+ -setup leakBaseline
+ -body {
+ set v [[exactexpr {(-8)**(1/3)}] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result -2.0000000000000000e0
+ }
+
+ test math::exact-53.24 {real to 0/0} {
+ -setup leakBaseline
+ -body {
+ set bad [[math::exact::V new {0 0}] ref]
+ set v [[exactexpr {sqrt(2)**$bad}] ref]
+ $bad unref
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -returnCodes error
+ -result {zero divided by zero}
+ }
+
+ test math::exact-53.24 {rational to 0/0} {
+ -setup leakBaseline
+ -body {
+ set bad [[math::exact::V new {0 0}] ref]
+ set v [[exactexpr {(1/2)**$bad}] ref]
+ $bad unref
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -returnCodes error
+ -result {zero divided by zero}
+ }
+
+ test math::exact-53.26 {unit test - rat**int (2/3)**0} {
+ -setup leakBaseline
+ -body {
+ set v [[math::exact::rat**int 2 3 0] ref]
+ set result [$v asPrint 57]
+ $v unref
+ leakCheck
+ set result
+ }
+ -result {1}
+ }
+
+ test math::exact-53.27 {rational powers - normalize base and exponent} {
+ -setup leakBaseline
+ -body {
+ set p [[math::exact::V new {-2 -1}] ref]
+ set q [[math::exact::V new {-3 -1}] ref]
+ set r [[exactexpr {$p ** $q}] ref]
+ $p unref
+ $q unref
+ set result [$r asPrint 57]
+ $r unref
+ leakCheck
+ set result
+ }
+ -result 8
+ }
+
+ test math::exact-54.1 {abs1, signum1} {
+ -setup leakBaseline
+ -body {
+ set p [[exactexpr {0}] ref]
+ set q [[exactexpr {2}] ref]
+ while 1 {
+ set t [[exactexpr {($q-$p) * 10**36}] ref]
+ set f [math::exact::abs1 $t]; $t unref
+ if {!$f} break
+ set x [[exactexpr {($p+$q)/2}] ref]
+ set resid [[exactexpr {$x*$x-2}] ref]
+ set t [[exactexpr {$resid * 10**36}] ref]
+ if {[math::exact::signum1 $t] > 0} {
+ $q unref; set q $x
+ } else {
+ $p unref; set p $x
+ }
+ $t unref; $resid unref
+ }
+ set result [$p asFloat 100]
+ $p unref
+ $q unref
+ leakCheck
+ set result
+ }
+ -result 1.41421356237309504880168872421e0
+ }
+
+ # following are demos that I don't know where to put, yet
+
+ if 0 {
+ set p 1
+ for {set i 0} {$i < 20} {incr i} {
+ set f [expr {sin(0.01 * $p* acos(-1))}]
+ set v [[exactexpr "sin($p * pi() / 100)"] ref]
+ set a [$v asPrint 57]
+ set r [expr {$f - $a}]
+ puts "i: $i p: $p float: $f exact: $a difference: $r"
+ $v unref
+ set p [expr {11 * $p}]
+ }
+ }
+
+ if 0 {
+ for {set x 100} {$x <= 12200} {incr x 100} {
+ set ex [[exactexpr $x] ref]
+ puts "x $x ex [$ex asPrint 57]"
+ set fa [expr {-(double($x)**-4)}]
+ set ea [[exactexpr {-($ex**-4)}] ref]
+ puts "fa $fa ea [$ea asPrint 57]"
+ set fb [expr {exp($fa)}]
+ set eb [[exactexpr {exp($ea)}] ref]
+ puts "fb $fb eb [$eb asPrint 120]"
+ set fc [expr {log($fb)}]
+ set ec [[exactexpr {log($eb)}] ref]
+ puts "fc $fc ec [$ec asPrint 120]"
+ catch {expr {(-$fc) ** -0.25}} ff
+ set ef [[exactexpr {(-$ec)**(-1/4)}] ref]
+ puts [format "kahan's function: %s %g" $ff [$ef asFloat 28]]
+ $ef unref
+ $ec unref
+ $eb unref
+ $ea unref
+ $ex unref
+ }
+ }
+
+ if 0 {
+ set x0 4.0
+ set x1 4.25
+ set ex0 [[exactexpr 4] ref]
+ set ex1 [[exactexpr 4+25/100] ref]
+ for {set i 1} {$i < 100} {incr i} {
+ set x2 [expr {108. - (815. - 1500. / $x0) / $x1}]
+ set x0 $x1
+ set x1 $x2
+ set ex2 [[exactexpr {108 - (815 - 1500 / $ex0) / $ex1}] ref]
+ $ex0 unref
+ set ex0 $ex1
+ set ex1 $ex2
+ puts "$i $x2 [$ex2 asFloat 57]"
+ }
+ $ex0 unref
+ $ex1 unref
+ }
+
+ testsuiteCleanup
+
+}
+
+#-----------------------------------------------------------------------------
+
+# End of test cases
+
+testsuiteCleanup
+
+# Exit if running this test standalone, to allow for Nagelfar coverage
+if {$::argv0 eq [info script]} {
+ exit
+}
+
+# Local Variables:
+# mode: tcl
+# End:
+
diff --git a/tcllib/modules/math/exponential.tcl b/tcllib/modules/math/exponential.tcl
new file mode 100755
index 0000000..b90952a
--- /dev/null
+++ b/tcllib/modules/math/exponential.tcl
@@ -0,0 +1,434 @@
+# exponential.tcl --
+# Compute exponential integrals (E1, En, Ei, li, Shi, Chi, Si, Ci)
+#
+
+namespace eval ::math::special {
+ variable pi 3.1415926
+ variable gamma 0.57721566490153286
+ variable halfpi [expr {$pi/2.0}]
+
+# Euler's digamma function for small integer arguments
+
+ variable psi {
+ NaN
+ -0.57721566490153286 0.42278433509846713 0.92278433509846713
+ 1.2561176684318005 1.5061176684318005 1.7061176684318005
+ 1.8727843350984672 2.0156414779556102 2.1406414779556102
+ 2.2517525890667214 2.3517525890667215 2.4426616799758123
+ 2.5259950133091458 2.6029180902322229 2.6743466616607945
+ 2.7410133283274614 2.8035133283274614 2.8623368577392259
+ 2.9178924132947812 2.9705239922421498 3.0205239922421496
+ 3.0681430398611971 3.1135975853157425 3.1570758461853079
+ 3.1987425128519744 3.2387425128519745 3.2772040513135128
+ 3.31424108835055 3.3499553740648356 3.3844381326855251
+ 3.4177714660188583 3.4500295305349873 3.4812795305349873
+ 3.5115825608380176 3.5409943255438998 3.5695657541153283
+ 3.597343531893106 3.6243705589201332 3.6506863483938172
+ 3.6763273740348428
+ }
+}
+
+# ComputeExponFG --
+# Compute the auxiliary functions f and g
+#
+# Arguments:
+# x Parameter of the integral (x>=0)
+# Result:
+# Approximate values for f and g
+# Note:
+# See Abramowitz and Stegun
+#
+proc ::math::special::ComputeExponFG {x} {
+ set x2 [expr {$x*$x}]
+ set fx [expr {($x2*$x2+7.241163*$x2+2.463936)/
+ ($x2*$x2+9.068580*$x2+7.157433)/$x}]
+ set gx [expr {($x2*$x2+7.547478*$x2+1.564072)/
+ ($x2*$x2+12.723684*$x2+15.723606)/$x2}]
+ list $fx $gx
+}
+
+
+# exponential_Ei --
+# Compute the exponential integral of the second kind, to relative
+# error eps
+# Arguments:
+# x Value of the argument
+# eps Relative error
+# Result:
+# Principal value of the integral exp(x)/x
+# from -infinity to x
+#
+proc ::math::special::exponential_Ei { x { eps 1.0e-10 } } {
+ variable gamma
+
+ if { ![string is double -strict $x] } {
+ return -code error "expected a floating point number but found \"$x\""
+ }
+ if { $x < 0.0 } {
+ return [expr { -[exponential_En 1 [expr { - $x }] $eps] }]
+ }
+ if { $x == 0.0 } {
+ set message "Argument to exponential_Ei must not be zero"
+ return -code error -errorcode [list ARITH DOMAIN $message] $message
+ }
+ if { $x >= -log($eps) } {
+ # evaluate Ei(x) as an asymptotic series; the series is formally
+ # divergent, but the leading terms give the desired value to
+ # enough precision.
+ set sum 0.
+ set term 1.
+ set k 1
+ while { 1 } {
+ set p $term
+ set term [expr { $term * ( $k / $x ) }]
+ if { $term < $eps } {
+ break
+ }
+ if { $term < $p } {
+ set sum [expr { $sum + $term }]
+ } else {
+ set sum [expr { $sum - $p }]
+ break
+ }
+ incr k
+ }
+ return [expr { exp($x) * ( 1.0 + $sum ) / $x }]
+ } elseif { $x >= 1e-18 } {
+ # evaluate Ei(x) as a power series
+ set sum 0.
+ set fact 1.
+ set pow $x
+ set n 1
+ while { 1 } {
+ set fact [expr { $fact * $n }]
+ set term [expr { $pow / $n / $fact }]
+ set sum [expr { $sum + $term }]
+ if { $term < $eps * $sum } break
+ set pow [expr { $x * $pow }]
+ incr n
+ }
+ return [expr { $sum + $gamma + log($x) }]
+ } else {
+ # Ei(x) for small x
+ return [expr { log($x) + $gamma }]
+ }
+}
+
+
+# exponential_En --
+# Compute the exponential integral of n-th order, to relative error
+# epsilon
+#
+# Arguments:
+# n Order of the integral (n>=1, integer)
+# x Parameter of the integral (x>0)
+# epsilon Relative error
+# Result:
+# Value of En(x) = integral from 0 to x of exp(-x)/x**n
+#
+proc ::math::special::exponential_En { n x { epsilon 1.0e-10 } } {
+ variable psi
+ variable gamma
+ if { ![string is integer -strict $n] || $n < 0 } {
+ return -code error "expected a non-negative integer but found \"$n\""
+ }
+ if { ![string is double -strict $x] } {
+ return -code error "expected a floating point number but found \"$x\""
+ }
+ if { $n == 0 } {
+ if { $x == 0.0 } {
+ return -code error "E0(0) is indeterminate"
+ }
+ return [expr { exp( -$x ) / $x }]
+ }
+ if { $n == 1 && $x < 0.0 } {
+ return [expr {- [exponential_Ei [expr { -$x }] $eps] }]
+ }
+ if { $x < 0.0 } {
+ return -code error "can't evaluate En(x) for negative x"
+ }
+ if { $x == 0.0 } {
+ return [expr { 1.0 / ( $n - 1 ) }]
+ }
+
+ if { $x > 1.0 } {
+ # evaluate En(x) as a continued fraction
+ set b [expr { $x + $n }]
+ set c 1.e308
+ set d [expr { 1.0 / $b }]
+ set h $d
+ set i 1
+ while { 1 } {
+ set a [expr { -$i * ( $n - 1 + $i ) }]
+ set b [expr { $b + 2.0 }]
+ set d [expr { 1.0 / ( $a * $d + $b ) }]
+ set c [expr { $b + $a / $c }]
+ set delta [expr { $c * $d }]
+ set h [expr { $h * $delta }]
+ if { abs( $delta - 1. ) < $epsilon } {
+ return [expr { $h * exp(-$x) }]
+ }
+ incr i
+ }
+ } else {
+ # evaluate En(x) as a series
+ if { $n == 1 } {
+ set a [expr { -log($x) - $gamma }]
+ } else {
+ set a [expr { 1.0 / ( $n - 1 ) }]
+ }
+ set f 1.0
+ set i 1
+ while { 1 } {
+ set f [expr { - $f * $x / $i }]
+ if { $i == $n - 1 } {
+ set term [expr { $f * ([lindex $psi $n] - log($x)) }]
+ } else {
+ set term [expr { $f / ( $n - 1 - $i ) }]
+ }
+ set a [expr { $a + $term }]
+ if { abs($term) < $epsilon * abs($a) } {
+ return $a
+ }
+ incr i
+ }
+ }
+}
+
+# exponential_E1 --
+# Compute the exponential integral
+#
+# Arguments:
+# x Parameter of the integral (x>0)
+# Result:
+# Value of E1(x) = integral from x to infinity of exp(-x)/x
+# Note:
+# This relies on a rational approximation (error ~ 2e-7 (x<1) or 5e-5 (x>1)
+#
+proc ::math::special::exponential_E1 {x} {
+ if { $x <= 0.0 } {
+ error "Domain error: x must be positive"
+ }
+
+ if { $x < 1.0 } {
+ return [expr {-log($x)+((((0.00107857*$x-0.00976004)*$x+0.05519968)*$x-0.24991055)*$x+0.99999193)*$x-0.57721566}]
+ } else {
+ set xexpe [expr {($x*$x+2.334733*$x+0.250621)/($x*$x+3.330657*$x+1.681534)}]
+ return [expr {$xexpe/($x*exp($x))}]
+ }
+}
+
+# exponential_li --
+# Compute the logarithmic integral
+# Arguments:
+# x Value of the argument
+# Result:
+# Value of the integral 1/ln(x) from 0 to x
+#
+proc ::math::special::exponential_li {x} {
+ if { $x < 0 } {
+ return -code error "Argument must be positive or zero"
+ } else {
+ if { $x == 0.0 } {
+ return 0.0
+ } else {
+ return [exponential_Ei [expr {log($x)}]]
+ }
+ }
+}
+
+# exponential_Shi --
+# Compute the hyperbolic sine integral
+# Arguments:
+# x Value of the argument
+# Result:
+# Value of the integral sinh(x)/x from 0 to x
+#
+proc ::math::special::exponential_Shi {x} {
+ if { $x < 0 } {
+ return -code error "Argument must be positive or zero"
+ } else {
+ if { $x == 0.0 } {
+ return 0.0
+ } else {
+ proc g {x} {
+ return [expr {sinh($x)/$x}]
+ }
+ return [lindex [::math::calculus::romberg g 0.0 $x] 0]
+ }
+ }
+}
+
+# exponential_Chi --
+# Compute the hyperbolic cosine integral
+# Arguments:
+# x Value of the argument
+# Result:
+# Value of the integral (cosh(x)-1)/x from 0 to x
+#
+proc ::math::special::exponential_Chi {x} {
+ variable gamma
+ if { $x < 0 } {
+ return -code error "Argument must be positive or zero"
+ } else {
+ if { $x == 0.0 } {
+ return 0.0
+ } else {
+ proc g {x} {
+ return [expr {(cosh($x)-1.0)/$x}]
+ }
+ set integral [lindex [::math::calculus::romberg g 0.0 $x] 0]
+ return [expr {$gamma+log($x)+$integral}]
+ }
+ }
+}
+
+# exponential_Si --
+# Compute the sine integral
+# Arguments:
+# x Value of the argument
+# Result:
+# Value of the integral sin(x)/x from 0 to x
+#
+proc ::math::special::exponential_Si {x} {
+ variable halfpi
+ if { $x < 0 } {
+ return -code error "Argument must be positive or zero"
+ } else {
+ if { $x == 0.0 } {
+ return 0.0
+ } else {
+ if { $x < 1.0 } {
+ proc g {x} {
+ return [expr {sin($x)/$x}]
+ }
+ return [lindex [::math::calculus::romberg g 0.0 $x] 0]
+ } else {
+ foreach {f g} [ComputeExponFG $x] {break}
+ return [expr {$halfpi-$f*cos($x)-$g*sin($x)}]
+ }
+ }
+ }
+}
+
+# exponential_Ci --
+# Compute the cosine integral
+# Arguments:
+# x Value of the argument
+# Result:
+# Value of the integral (cosh(x)-1)/x from 0 to x
+#
+proc ::math::special::exponential_Ci {x} {
+ variable gamma
+
+ if { $x < 0 } {
+ return -code error "Argument must be positive or zero"
+ } else {
+ if { $x == 0.0 } {
+ return 0.0
+ } else {
+ if { $x < 1.0 } {
+ proc g {x} {
+ return [expr {(cos($x)-1.0)/$x}]
+ }
+ set integral [lindex [::math::calculus::romberg g 0.0 $x] 0]
+ return [expr {$gamma+log($x)+$integral}]
+ } else {
+ foreach {f g} [ComputeExponFG $x] {break}
+ return [expr {$f*sin($x)-$g*cos($x)}]
+ }
+ }
+ }
+}
+
+# some tests --
+# Reproduce tables 5.1, 5.2 from Abramowitz & Stegun,
+
+if { [info exists ::argv0] && ![string compare $::argv0 [info script]] } {
+namespace eval ::math::special {
+for { set i 0.01 } { $i < 0.505 } { set i [expr { $i + 0.01 }] } {
+ set ei [exponential_Ei $i]
+ set e1 [expr { - [exponential_Ei [expr { - $i }]] }]
+ puts [format "%9.6f\t%.10g\t%.10g" $i \
+ [expr {($ei - log($i) - 0.57721566490153286)/$i} ] \
+ [expr {($e1 + log($i) + 0.57721566490153286) / $i }]]
+}
+puts {}
+for { set i 0.5 } { $i < 2.005 } { set i [expr { $i + 0.01 }] } {
+ set ei [exponential_Ei $i]
+ set e1 [expr { - [exponential_Ei [expr { - $i }]] }]
+ puts [format "%9.6f\t%.10g\t%.10g" $i $ei $e1]
+}
+puts {}
+for {} { $i < 10.05 } { set i [expr { $i + 0.1 }] } {
+ set ei [exponential_Ei $i]
+ set e1 [expr { - [exponential_Ei [expr { - $i }]] }]
+ puts [format "%9.6f\t%.10g\t%.10g" $i \
+ [expr { $i * exp(-$i) * $ei }] \
+ [expr { $i * exp($i) * $e1 }]]
+
+}
+puts {}
+for {set ooi 0.1} { $ooi > 0.0046 } { set ooi [expr { $ooi - 0.005 }] } {
+ set i [expr { 1.0 / $ooi }]
+ set ri [expr { round($i) }]
+ set ei [exponential_Ei $i]
+ set e1 [expr { - [exponential_Ei [expr { - $i }]] }]
+ puts [format "%9.6f\t%.10g\t%.10g\t%d" $i \
+ [expr { $i * exp(-$i) * $ei }] \
+ [expr { $i * exp($i) * $e1 }] \
+ $ri]
+}
+puts {}
+
+# Reproduce table 5.4 from Abramowitz and Stegun
+
+for { set x 0.00 } { $x < 0.505 } { set x [expr { $x + 0.01 }] } {
+ set line [format %4.2f $x]
+ if { $x == 0.00 } {
+ append line { } 1.0000000
+ } else {
+ append line { } [format %9.7f \
+ [expr { [exponential_En 2 $x] - $x * log($x) }]]
+ }
+ foreach n { 3 4 10 20 } {
+ append line { } [format %9.7f [exponential_En $n $x]]
+ }
+ puts $line
+}
+puts {}
+for { set x 0.50 } { $x < 2.005 } { set x [expr { $x + 0.01 }] } {
+ set line [format %4.2f $x]
+ foreach n { 2 3 4 10 20 } {
+ append line { } [format %9.7f [exponential_En $n $x]]
+ }
+ puts $line
+}
+puts {}
+
+for { set oox 0.5 } { $oox > 0.1025 } { set oox [expr { $oox - 0.05 }] } {
+ set line [format %4.2f $oox]
+ set x [expr { 1.0 / $oox }]
+ set rx [expr { round( $x ) }]
+ foreach n { 2 3 4 10 20 } {
+ set en [exponential_En $n [expr { 1.0 / $oox }]]
+ append line { } [format %9.7f [expr { ( $x + $n ) * exp($x) * $en }]]
+ }
+ append line { } [format %3d $rx]
+ puts $line
+}
+for { set oox 0.10 } { $oox > 0.005 } { set oox [expr { $oox - 0.01 }] } {
+ set line [format %4.2f $oox]
+ set x [expr { 1.0 / $oox }]
+ set rx [expr { round( $x ) }]
+ foreach n { 2 3 4 10 20 } {
+ set en [exponential_En $n $x]
+ append line { } [format %9.7f [expr { ( $x + $n ) * exp($x) * $en }]]
+ }
+ append line { } [format %3d $rx]
+ puts $line
+}
+puts {}
+catch {exponential_Ei 0.0} result; puts $result
+}
+}
diff --git a/tcllib/modules/math/fourier.man b/tcllib/modules/math/fourier.man
new file mode 100755
index 0000000..d5696dd
--- /dev/null
+++ b/tcllib/modules/math/fourier.man
@@ -0,0 +1,134 @@
+[manpage_begin math::fourier n 1.0.2]
+[keywords {complex numbers}]
+[keywords FFT]
+[keywords {Fourier transform}]
+[keywords mathematics]
+[moddesc {Tcl Math Library}]
+[titledesc {Discrete and fast fourier transforms}]
+[category Mathematics]
+[require Tcl 8.4]
+[require math::fourier 1.0.2]
+[description]
+[para]
+
+The [package math::fourier] package implements two versions of discrete
+Fourier transforms, the ordinary transform and the fast Fourier
+transform. It also provides a few simple filter procedures as an
+illustrations of how such filters can be implemented.
+
+[para]
+The purpose of this document is to describe the implemented procedures
+and provide some examples of their usage. As there is ample literature
+on the algorithms involved, we refer to relevant text books for more
+explanations. We also refer to the original Wiki page on the subject
+which describes some of the considerations behind the current
+implementation.
+
+[section "GENERAL INFORMATION"]
+The two top-level procedures defined are
+[list_begin itemized]
+[item]
+dft data-list
+[item]
+inverse_dft data-list
+[list_end]
+
+Both take a list of [emph "complex numbers"] and apply a Discrete Fourier
+Transform (DFT) or its inverse respectively to these lists of numbers.
+A "complex number" in this case is either (i) a pair (two element list) of
+numbers, interpreted as the real and imaginary parts of the complex number,
+or (ii) a single number, interpreted as the real part of a complex number
+whose imaginary part is zero. The return value is always in the
+first format. (The DFT generally produces complex results even if the
+input is purely real.) Applying first one and then the other of these
+procedures to a list of complex numbers will (modulo rounding errors
+due to floating point arithmetic) return the original list of numbers.
+
+[para]
+If the input length N is a power of two then these procedures will
+utilize the O(N log N) Fast Fourier Transform algorithm. If input
+length is not a power of two then the DFT will instead be computed
+using a the naive quadratic algorithm.
+
+[para]
+Some examples:
+[example {
+ % dft {1 2 3 4}
+ {10 0.0} {-2.0 2.0} {-2 0.0} {-2.0 -2.0}
+ % inverse_dft {{10 0.0} {-2.0 2.0} {-2 0.0} {-2.0 -2.0}}
+ {1.0 0.0} {2.0 0.0} {3.0 0.0} {4.0 0.0}
+ % dft {1 2 3 4 5}
+ {15.0 0.0} {-2.5 3.44095480118} {-2.5 0.812299240582} {-2.5 -0.812299240582} {-2.5 -3.44095480118}
+ % inverse_dft {{15.0 0.0} {-2.5 3.44095480118} {-2.5 0.812299240582} {-2.5 -0.812299240582} {-2.5 -3.44095480118}}
+ {1.0 0.0} {2.0 8.881784197e-17} {3.0 4.4408920985e-17} {4.0 4.4408920985e-17} {5.0 -8.881784197e-17}
+}]
+[para]
+In the last case, the imaginary parts <1e-16 would have been zero in exact
+arithmetic, but aren't here due to rounding errors.
+
+[para]
+Internally, the procedures use a flat list format where every even
+index element of a list is a real part and every odd index element
+is an imaginary part. This is reflected in the variable names by Re_
+and Im_ prefixes.
+
+[para]
+The package includes two simple filters. They have an analogue
+equivalent in a simple electronic circuit, a resistor and a capacitance
+in series. Using these filters requires the
+[package math::complexnumbers] package.
+
+[section "PROCEDURES"]
+The public Fourier transform procedures are:
+
+[list_begin definitions]
+
+[call [cmd ::math::fourier::dft] [arg in_data]]
+Determine the [emph "Fourier transform"] of the given list of complex
+numbers. The result is a list of complex numbers representing the
+(complex) amplitudes of the Fourier components.
+
+[list_begin arguments]
+[arg_def list in_data] List of data
+[list_end]
+[para]
+
+[call [cmd ::math::fourier::inverse_dft] [arg in_data]]
+Determine the [emph "inverse Fourier transform"] of the given list of
+complex numbers (interpreted as amplitudes). The result is a list of
+complex numbers representing the original (complex) data
+
+[list_begin arguments]
+[arg_def list in_data] List of data (amplitudes)
+[list_end]
+[para]
+
+[call [cmd ::math::fourier::lowpass] [arg cutoff] [arg in_data]]
+Filter the (complex) amplitudes so that high-frequency components
+are suppressed. The implemented filter is a first-order low-pass filter,
+the discrete equivalent of a simple electronic circuit with a resistor
+and a capacitance.
+
+[list_begin arguments]
+[arg_def float cutoff] Cut-off frequency
+[arg_def list in_data] List of data (amplitudes)
+[list_end]
+[para]
+
+[call [cmd ::math::fourier::highpass] [arg cutoff] [arg in_data]]
+Filter the (complex) amplitudes so that low-frequency components
+are suppressed. The implemented filter is a first-order low-pass filter,
+the discrete equivalent of a simple electronic circuit with a resistor
+and a capacitance.
+
+[list_begin arguments]
+[arg_def float cutoff] Cut-off frequency
+[arg_def list in_data] List of data (amplitudes)
+[list_end]
+[para]
+
+[list_end]
+
+[vset CATEGORY {math :: fourier}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/fourier.tcl b/tcllib/modules/math/fourier.tcl
new file mode 100755
index 0000000..bd455ad
--- /dev/null
+++ b/tcllib/modules/math/fourier.tcl
@@ -0,0 +1,376 @@
+# fourier.tcl --
+# Package for discrete (ordinary) and fast fourier transforms
+#
+# Author: Lars Hellstrom (...)
+#
+# The two top-level procedures defined are
+#
+# dft data-list
+# inverse_dft data-list
+#
+# which take a list of complex numbers and apply a Discrete Fourier
+# Transform (DFT) or its inverse respectively to these lists of numbers.
+# A "complex number" in this case is either (i) a pair (two element
+# list) of numbers, interpreted as the real and imaginary parts of the
+# complex number, or (ii) a single number, interpreted as the real
+# part of a complex number whose imaginary part is zero. The return
+# value is always in the first format. (The DFT generally produces
+# complex results even if the input is purely real.) Applying first
+# one and then the other of these procedures to a list of complex
+# numbers will (modulo rounding errors due to floating point
+# arithmetic) return the original list of numbers.
+#
+# If the input length N is a power of two then these procedures will
+# utilize the O(N log N) Fast Fourier Transform algorithm. If input
+# length is not a power of two then the DFT will instead be computed
+# using a the naive quadratic algorithm.
+#
+# Some examples:
+#
+# % dft {1 2 3 4}
+# {10 0.0} {-2.0 2.0} {-2 0.0} {-2.0 -2.0}
+# % inverse_dft {{10 0.0} {-2.0 2.0} {-2 0.0} {-2.0 -2.0}}
+# {1.0 0.0} {2.0 0.0} {3.0 0.0} {4.0 0.0}
+# % dft {1 2 3 4 5}
+# {15.0 0.0} {-2.5 3.44095480118} {-2.5 0.812299240582} {-2.5 -0.812299240582} {-2.5 -3.44095480118}
+# % inverse_dft {{15.0 0.0} {-2.5 3.44095480118} {-2.5 0.812299240582} {-2.5 -0.812299240582} {-2.5 -3.44095480118}}
+# {1.0 0.0} {2.0 8.881784197e-17} {3.0 4.4408920985e-17} {4.0 4.4408920985e-17} {5.0 -8.881784197e-17}
+ #
+# In the last case, the imaginary parts <1e-16 would have been zero in
+# exact arithmetic, but aren't here due to rounding errors.
+#
+# Internally, the procedures use a flat list format where every even
+# index element of a list is a real part and every odd index element is
+# an imaginary part. This is reflected in the variable names by Re_ and
+# Im_ prefixes.
+#
+
+namespace eval ::math::fourier {
+ #::math::constants pi
+
+ namespace export dft inverse_dft lowpass highpass
+}
+
+# dft --
+# Return the discrete fourier transform as a list of complex numbers
+#
+# Arguments:
+# in_data List of data (either real or complex)
+# Returns:
+# List of complex amplitudes for the Fourier components
+# Note:
+# The procedure uses an ordinary DFT if the number of data is
+# not a power of 2, otherwise it uses FFT.
+#
+proc ::math::fourier::dft {in_data} {
+ # First convert to internal format
+ set dataL [list]
+ set n 0
+ foreach datum $in_data {
+ if {[llength $datum] == 1} then {
+ lappend dataL $datum 0.0
+ } else {
+ lappend dataL [lindex $datum 0] [lindex $datum 1]
+ }
+ incr n
+ }
+
+ # Then compute a list of n'th roots of unity (explanation below)
+ set rootL [DFT_make_roots $n -1]
+
+ # Check if the input length is a power of two.
+ set p 1
+ while {$p < $n} {set p [expr {$p << 1}]}
+ # By construction, $p is a power of two. If $n==$p then $n is too.
+
+ # Finally compute the transform using Fast_DFT or Slow_DFT,
+ # and convert back to the input format.
+ set res [list]
+ foreach {Re Im} [
+ if {$p == $n} then {
+ Fast_DFT $dataL $rootL
+ } else {
+ Slow_DFT $dataL $rootL
+ }
+ ] {
+ lappend res [list $Re $Im]
+ }
+ return $res
+}
+
+# inverse_dft --
+# Invert the discrete fourier transform and return the restored data
+# as complex numbers
+#
+# Arguments:
+# in_data List of fourier coefficients (either real or complex)
+# Returns:
+# List of complex amplitudes for the Fourier components
+# Note:
+# The procedure uses an ordinary DFT if the number of data is
+# not a power of 2, otherwise it uses FFT.
+#
+proc ::math::fourier::inverse_dft {in_data} {
+ # First convert to internal format
+ set dataL [list]
+ set n 0
+ foreach datum $in_data {
+ if {[llength $datum] == 1} then {
+ lappend dataL $datum 0.0
+ } else {
+ lappend dataL [lindex $datum 0] [lindex $datum 1]
+ }
+ incr n
+ }
+
+ # Then compute a list of n'th roots of unity (explanation below)
+ set rootL [DFT_make_roots $n 1]
+
+ # Check if the input length is a power of two.
+ set p 1
+ while {$p < $n} {set p [expr {$p << 1}]}
+ # By construction, $p is a power of two. If $n==$p then $n is too.
+
+ # Finally compute the transform using Fast_DFT or Slow_DFT,
+ # divide by input data length to correct the amplitudes,
+ # and convert back to the input format.
+ set res [list]
+ foreach {Re Im} [
+ # $p is power of two. If $n==$p then $n is too.
+ if {$p == $n} then {
+ Fast_DFT $dataL $rootL
+ } else {
+ Slow_DFT $dataL $rootL
+ }
+ ] {
+ lappend res [list [expr {$Re/$n}] [expr {$Im/$n}]]
+ }
+ return $res
+}
+
+# DFT_make_roots --
+# Return a list of the complex roots of unity or of -1
+#
+# Arguments:
+# n Order of the roots
+# sign Whether to use 1 or -1 (for inverse transform)
+# Returns:
+# List of complex roots of unity or -1
+#
+proc ::math::fourier::DFT_make_roots {n sign} {
+ set res [list]
+ for {set k 0} {2*$k < $n} {incr k} {
+ set alpha [expr {2*3.1415926535897931*$sign*$k/$n}]
+ lappend res [expr {cos($alpha)}] [expr {sin($alpha)}]
+ }
+ return $res
+}
+
+# Fast_DFT --
+# Perform the fast Fourier transform
+#
+# Arguments:
+# dataL List of data
+# rootL Roots of unity or -1 to use in the transform
+# Returns:
+# List of complex numbers
+#
+proc ::math::fourier::Fast_DFT {dataL rootL} {
+ if {[llength $dataL] == 8} then {
+ foreach {Re_z0 Im_z0 Re_z1 Im_z1 Re_z2 Im_z2 Re_z3 Im_z3} $dataL {break}
+ if {[lindex $rootL 3] > 0} then {
+ return [list\
+ [expr {$Re_z0 + $Re_z1 + $Re_z2 + $Re_z3}] [expr {$Im_z0 + $Im_z1 + $Im_z2 + $Im_z3}]\
+ [expr {$Re_z0 - $Im_z1 - $Re_z2 + $Im_z3}] [expr {$Im_z0 + $Re_z1 - $Im_z2 - $Re_z3}]\
+ [expr {$Re_z0 - $Re_z1 + $Re_z2 - $Re_z3}] [expr {$Im_z0 - $Im_z1 + $Im_z2 - $Im_z3}]\
+ [expr {$Re_z0 + $Im_z1 - $Re_z2 - $Im_z3}] [expr {$Im_z0 - $Re_z1 - $Im_z2 + $Re_z3}]]
+ } else {
+ return [list\
+ [expr {$Re_z0 + $Re_z1 + $Re_z2 + $Re_z3}] [expr {$Im_z0 + $Im_z1 + $Im_z2 + $Im_z3}]\
+ [expr {$Re_z0 + $Im_z1 - $Re_z2 - $Im_z3}] [expr {$Im_z0 - $Re_z1 - $Im_z2 + $Re_z3}]\
+ [expr {$Re_z0 - $Re_z1 + $Re_z2 - $Re_z3}] [expr {$Im_z0 - $Im_z1 + $Im_z2 - $Im_z3}]\
+ [expr {$Re_z0 - $Im_z1 - $Re_z2 + $Im_z3}] [expr {$Im_z0 + $Re_z1 - $Im_z2 - $Re_z3}]]
+ }
+ } elseif {[llength $dataL] > 8} then {
+ set evenL [list]
+ set oddL [list]
+ foreach {Re_z0 Im_z0 Re_z1 Im_z1} $dataL {
+ lappend evenL $Re_z0 $Im_z0
+ lappend oddL $Re_z1 $Im_z1
+ }
+ set squarerootL [list]
+ foreach {Re_omega0 Im_omega0 Re_omega1 Im_omega1} $rootL {
+ lappend squarerootL $Re_omega0 $Im_omega0
+ }
+ set lowL [list]
+ set highL [list]
+ foreach\
+ {Re_y0 Im_y0} [Fast_DFT $evenL $squarerootL]\
+ {Re_y1 Im_y1} [Fast_DFT $oddL $squarerootL]\
+ {Re_omega Im_omega} $rootL {
+ set Re_y1t [expr {$Re_y1 * $Re_omega - $Im_y1 * $Im_omega}]
+ set Im_y1t [expr {$Im_y1 * $Re_omega + $Re_y1 * $Im_omega}]
+ lappend lowL [expr {$Re_y0 + $Re_y1t}] [expr {$Im_y0 + $Im_y1t}]
+ lappend highL [expr {$Re_y0 - $Re_y1t}] [expr {$Im_y0 - $Im_y1t}]
+ }
+ return [concat $lowL $highL]
+ } elseif {[llength $dataL] == 4} then {
+ foreach {Re_z0 Im_z0 Re_z1 Im_z1} $dataL {break}
+ return [list\
+ [expr {$Re_z0 + $Re_z1}] [expr {$Im_z0 + $Im_z1}]\
+ [expr {$Re_z0 - $Re_z1}] [expr {$Im_z0 - $Im_z1}]]
+ } else {
+ return $dataL
+ }
+}
+
+# Slow_DFT --
+# Perform the ordinary discrete (slow) Fourier transform
+#
+# Arguments:
+# dataL List of data
+# rootL Roots of unity or -1 to use in the transform
+# Returns:
+# List of complex numbers
+#
+proc ::math::fourier::Slow_DFT {dataL rootL} {
+ set n [expr {[llength $dataL] / 2}]
+
+ # The missing roots are computed by complex conjugating the given
+ # roots. If $n is even then -1 is also needed; it is inserted explicitly.
+ set k [llength $rootL]
+ if {$n % 2 == 0} then {
+ lappend rootL -1.0 0.0
+ }
+ for {incr k -2} {$k > 0} {incr k -2} {
+ lappend rootL [lindex $rootL $k]\
+ [expr {-[lindex $rootL [expr {$k+1}]]}]
+ }
+
+ # This is strictly following the naive formula.
+ # The product jk is kept as a separate counter variable.
+ set res [list]
+ for {set k 0} {$k < $n} {incr k} {
+ set Re_sum 0.0
+ set Im_sum 0.0
+ set jk 0
+ foreach {Re_z Im_z} $dataL {
+ set Re_omega [lindex $rootL [expr {2*$jk}]]
+ set Im_omega [lindex $rootL [expr {2*$jk+1}]]
+ set Re_sum [expr {$Re_sum +
+ $Re_z * $Re_omega - $Im_z * $Im_omega}]
+ set Im_sum [expr {$Im_sum +
+ $Im_z * $Re_omega + $Re_z * $Im_omega}]
+ incr jk $k
+ if {$jk >= $n} then {set jk [expr {$jk - $n}]}
+ }
+ lappend res $Re_sum $Im_sum
+ }
+ return $res
+}
+
+# lowpass --
+# Apply a low-pass filter to the Fourier transform
+#
+# Arguments:
+# cutoff Cut-off frequency
+# in_data Input transform (complex data)
+# Returns:
+# Filtered transform
+#
+proc ::math::fourier::lowpass {cutoff in_data} {
+ package require math::complexnumbers
+
+ set res [list]
+ set cutoff [list $cutoff 0.0]
+ set f 0.0
+ foreach a $in_data {
+ set an [::math::complexnumbers::/ $a \
+ [::math::complexnumbers::+ {1.0 0.0} \
+ [::math::complexnumbers::/ [list 0.0 $f] $cutoff]]]
+ lappend res $an
+ set f [expr {$f+1.0}]
+ }
+
+ return $res
+}
+
+# highpass --
+# Apply a high-pass filter to the Fourier transform
+#
+# Arguments:
+# cutoff Cut-off frequency
+# in_data Input transform (complex data)
+# Returns:
+# Filtered transform (high-pass)
+#
+proc ::math::fourier::highpass {cutoff in_data} {
+ package require math::complexnumbers
+
+ set res [list]
+ set cutoff [list $cutoff 0.0]
+ set f 0.0
+ foreach a $in_data {
+ set ff [::math::complexnumbers::/ [list 0.0 $f] $cutoff]
+ set an [::math::complexnumbers::/ $ff \
+ [::math::complexnumbers::+ {1.0 0.0} $ff]]
+ lappend res $an
+ set f [expr {$f+1.0}]
+ }
+
+ return $res
+}
+
+#
+# Announce the package
+#
+package provide math::fourier 1.0.2
+
+# test --
+#
+proc test_dft {points {real 0} {iterations 20}} {
+ set in_dataL [list]
+ for {set k 0} {$k < $points} {incr k} {
+ if {$real} then {
+ lappend in_dataL [expr {2*rand()-1}]
+ } else {
+ lappend in_dataL [list [expr {2*rand()-1}] [expr {2*rand()-1}]]
+ }
+ }
+ set time1 [time {
+ set conv_dataL [::math::fourier::dft $in_dataL]
+ } $iterations]
+ set time2 [time {
+ set out_dataL [::math::fourier::inverse_dft $conv_dataL]
+ } $iterations]
+ set err 0.0
+ foreach iz $in_dataL oz $out_dataL {
+ if {$real} then {
+ foreach {o1 o2} $oz {break}
+ set err [expr {$err + ($i-$o1)*($i-$o1) + $o2*$o2}]
+ } else {
+ foreach i $iz o $oz {
+ set err [expr {$err + ($i-$o)*($i-$o)}]
+ }
+ }
+ }
+ return [format "Forward: %s\nInverse: %s\nAverage error: %g"\
+ $time1 $time2 [expr {sqrt($err/$points)}]]
+}
+
+# Note:
+# Add simple filters
+
+if { 0 } {
+puts [::math::fourier::dft {1 2 3 4}]
+puts [::math::fourier::inverse_dft {{10 0.0} {-2.0 2.0} {-2 0.0} {-2.0 -2.0}}]
+puts [::math::fourier::dft {1 2 3 4 5}]
+puts [::math::fourier::inverse_dft {{15.0 0.0} {-2.5 3.44095480118} {-2.5 0.812299240582} {-2.5 -0.812299240582} {-2.5 -3.44095480118}}]
+puts [test_dft 10]
+puts [test_dft 16]
+puts [test_dft 100]
+puts [test_dft 128]
+
+puts [::math::fourier::dft {1 2 3 4}]
+puts [::math::fourier::lowpass 1.5 [::math::fourier::dft {1 2 3 4}]]
+}
diff --git a/tcllib/modules/math/fourier.test b/tcllib/modules/math/fourier.test
new file mode 100755
index 0000000..d43f1b9
--- /dev/null
+++ b/tcllib/modules/math/fourier.test
@@ -0,0 +1,135 @@
+# -*- tcl -*-
+# fourier.test --
+# Test cases for the Fourier transforms in the
+# ::math::fourier package
+#
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 2.1
+
+support {
+ useLocal math.tcl math
+}
+testing {
+ useLocal fourier.tcl math::fourier
+}
+
+# -------------------------------------------------------------------------
+
+namespace import ::math::fourier::*
+
+# -------------------------------------------------------------------------
+
+proc matchComplex {expected actual} {
+ set match 1
+ foreach a $actual e $expected {
+ foreach {are aim} $a break
+ foreach {ere eim} $e break
+ if {abs($are-$ere) > 0.1e-8 ||
+ abs($aim-$eim) > 0.1e-8} {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+
+customMatch numbers matchComplex
+
+# -------------------------------------------------------------------------
+
+test "dft-1.0" "Four numbers" \
+ -match numbers -body {
+ dft {1 2 3 4}
+} -result {{10 0.0} {-2.0 2.0} {-2 0.0} {-2.0 -2.0}}
+
+test "dft-1.1" "Five numbers" \
+ -match numbers -body {
+ dft {1 2 3 4 5}
+} -result {{15.0 0.0} {-2.5 3.44095480118} {-2.5 0.812299240582} {-2.5 -0.812299240582} {-2.5 -3.44095480118}}
+
+test "dft-1.2" "Four numbers - inverse" \
+ -match numbers -body {
+ inverse_dft {{10 0.0} {-2.0 2.0} {-2 0.0} {-2.0 -2.0}}
+} -result {{1.0 0.0} {2.0 0.0} {3.0 0.0} {4.0 0.0}}
+
+test "dft-1.3" "Five numbers - inverse" \
+ -match numbers -body {
+ inverse_dft {{15.0 0.0} {-2.5 3.44095480118} {-2.5 0.812299240582} {-2.5 -0.812299240582} {-2.5 -3.44095480118}}
+} -result {{1.0 0.0} {2.0 8.881784197e-17} {3.0 4.4408920985e-17} {4.0 4.4408920985e-17} {5.0 -8.881784197e-17}}
+
+# Testing to and from DFT
+#
+proc test_DFT {points {real 0} {iterations 20}} {
+ set in_dataL [list]
+ for {set k 0} {$k < $points} {incr k} {
+ if {$real} then {
+ lappend in_dataL [expr {2*rand()-1}]
+ } else {
+ lappend in_dataL [list [expr {2*rand()-1}] [expr {2*rand()-1}]]
+ }
+ }
+ set time1 [time {
+ set conv_dataL [dft $in_dataL]
+ } $iterations]
+ set time2 [time {
+ set out_dataL [inverse_dft $conv_dataL]
+ } $iterations]
+ set err 0.0
+ foreach iz $in_dataL oz $out_dataL {
+ if {$real} then {
+ foreach {o1 o2} $oz {break}
+ set err [expr {$err + ($i-$o1)*($i-$o1) + $o2*$o2}]
+ } else {
+ foreach i $iz o $oz {
+ set err [expr {$err + ($i-$o)*($i-$o)}]
+ }
+ }
+ }
+ return [list $time1 $time2 [expr {sqrt($err/$points)}]]
+}
+
+test "dft-2.1" "10 numbers - to and from" \
+ -body {
+ foreach {t1 t2 err} [test_DFT 10] break
+ set small_error [expr {$err < 1.0e-10}]
+} -result 1
+
+test "dft-2.2" "100 numbers - to and from" \
+ -body {
+ foreach {t1 t2 err} [test_DFT 100] break
+ set small_error [expr {$err < 1.0e-10}]
+} -result 1
+
+test "dft-2.3" "DFT versus FFT" \
+ -body {
+
+ foreach {dft1 dft2 err} [test_DFT 100] break
+ foreach {fft1 fft2 err} [test_DFT 128] break
+
+ set dft1 [lindex $dft1 0]
+ set dft2 [lindex $dft2 0]
+ set fft1 [lindex $fft1 0]
+ set fft2 [lindex $fft2 0]
+
+ # Expect a dramatic difference - at least factor 3!
+ set fft_used [expr {$dft1 > 3.0*$fft1 && $dft2 > 3.0*$fft2}]
+} -result 1
+
+test "dft-2.4" "1024 numbers - to and from" \
+ -body {
+ foreach {t1 t2 err} [test_DFT 1024 0 1] break
+ set small_error [expr {$err < 1.0e-10}]
+} -result 1
+
+
+# TODO: tests for lowpass and highpass filters
+
+# End of test cases
+testsuiteCleanup
diff --git a/tcllib/modules/math/fuzzy.eps.f90 b/tcllib/modules/math/fuzzy.eps.f90
new file mode 100755
index 0000000..79867e7
--- /dev/null
+++ b/tcllib/modules/math/fuzzy.eps.f90
@@ -0,0 +1,170 @@
+!**********************************************************************
+! ROUTINE: FUZZY FORTRAN OPERATORS
+! PURPOSE: Illustrate Hindmarsh's computation of EPS, and APL
+! tolerant comparisons, tolerant CEIL/FLOOR, and Tolerant
+! ROUND functions - implemented in Fortran.
+! PLATFORM: PC Windows Fortran, Compaq-Digital CVF 6.1a, AIX XLF90
+! TO RUN: Windows: DF EPS.F90
+! AIX: XLF90 eps.f -o eps.exe -qfloat=nomaf
+! CALLS: none
+! AUTHOR: H. D. Knoble <hdk@psu.edu> 22 September 1978
+! REVISIONS:
+!**********************************************************************
+!
+ DOUBLE PRECISION EPS,EPS3, X,Y,Z, D1MACH,TFLOOR,TCEIL,EPSF90
+ LOGICAL TEQ,TNE,TGT,TGE,TLT,TLE
+!---Following are Fuzzy Comparison (arithmetic statement) Functions.
+!
+ TEQ(X,Y)=DABS(X-Y).LE.DMAX1(DABS(X),DABS(Y))*EPS3
+ TNE(X,Y)=.NOT.TEQ(X,Y)
+ TGT(X,Y)=(X-Y).GT.DMAX1(DABS(X),DABS(Y))*EPS3
+ TLE(X,Y)=.NOT.TGT(X,Y)
+ TLT(X,Y)=TLE(X,Y).AND.TNE(X,Y)
+ TGE(X,Y)=TGT(X,Y).OR.TEQ(X,Y)
+!
+!---Compute EPS for this computer. EPS is the smallest real number on
+! this architecture such that 1+EPS>1 and 1-EPS<1.
+! EPSILON(X) is a Fortran 90 built-in Intrinsic function. They should
+! be identically equal.
+!
+ EPS=D1MACH(NULL)
+ EPSF90=EPSILON(X)
+ IF(EPS.NE.EPSF90) THEN
+ WRITE(*,2)'EPS=',EPS,' .NE. EPSF90=',EPSF90
+2 FORMAT(A,Z16,A,Z16)
+ ENDIF
+!---Accept a representation if exact, or one bit on either side.
+ EPS3=3.D0*EPS
+ WRITE(*,1) EPS,EPS, EPS3,EPS3
+1 FORMAT(' EPS=',D16.8,2X,Z16, ', EPS3=',D16.8,2X,Z16)
+!---Illustrate Fuzzy Comparisons using EPS3. Any other magnitudes will
+! behave similarly.
+ Z=1.D0
+ I=49
+ X=1.D0/I
+ Y=X*I
+ WRITE(*,*) 'X=1.D0/',I,', Y=X*',I,', Z=1.D0'
+ WRITE(*,*) 'Y=',Y,' Z=',Z
+ WRITE(*,3) X,Y,Z
+3 FORMAT(' X=',Z16,' Y=',Z16,' Z=',Z16)
+!---Floating-point Y is not identical (.EQ.) to floating-point Z.
+ IF(Y.EQ.Z) WRITE(*,*) 'Fuzzy Comparisons: Y=Z'
+ IF(Y.NE.Z) WRITE(*,*) 'Fuzzy Comparisons: Y<>Z'
+!---But Y is tolerantly (and algebraically) equal to Z.
+ IF(TEQ(Y,Z)) THEN
+ WRITE(*,*) 'but TEQ(Y,Z) is .TRUE.'
+ WRITE(*,*) 'That is, Y is computationally equal to Z.'
+ ENDIF
+ IF(TNE(Y,Z)) WRITE(*,*) 'and TNE(Y,Z) is .TRUE.'
+ WRITE(*,*) ' '
+!---Evaluate Fuzzy FLOOR and CEILing Function values using a Comparison
+! Tolerance, CT, of EPS3.
+ X=0.11D0
+ Y=((X*11.D0)-X)-0.1D0
+ YFLOOR=TFLOOR(Y,EPS3)
+ YCEIL=TCEIL(Y,EPS3)
+55 Z=1.D0
+ WRITE(*,*) 'X=0.11D0, Y=X*11.D0-X-0.1D0, Z=1.D0'
+ WRITE(*,*) 'X=',X,' Y=',Y,' Z=',Z
+ WRITE(*,3) X,Y,Z
+!---Floating-point Y is not identical (.EQ.) to floating-point Z.
+ IF(Y.EQ.Z) WRITE(*,*) 'Fuzzy FLOOR/CEIL: Y=Z'
+ IF(Y.NE.Z) WRITE(*,*) 'Fuzzy FLOOR/CEIL: Y<>Z'
+ IF(TFLOOR(Y,EPS3).EQ.TCEIL(Y,EPS3).AND.TFLOOR(Y,EPS3).EQ.Z) THEN
+!---But Tolerant Floor/Ceil of Y is identical (and algebraically equal)
+! to Z.
+ WRITE(*,*) 'but TFLOOR(Y,EPS3)=TCEIL(Y,EPS3)=Z.'
+ WRITE(*,*) 'That is, TFLOOR/TCEIL return exact whole numbers.'
+ ENDIF
+ STOP
+ END
+ DOUBLE PRECISION FUNCTION D1MACH (IDUM)
+ INTEGER IDUM
+!=======================================================================
+! This routine computes the unit roundoff of the machine in double
+! precision. This is defined as the smallest positive machine real
+! number, EPS, such that (1.0D0+EPS > 1.0D0) & (1.D0-EPS < 1.D0).
+! This computation of EPS is the work of Alan C. Hindmarsh.
+! For computation of Machine Parameters also see:
+! W. J. Cody, "MACHAR: A subroutine to dynamically determine machine
+! parameters, " TOMS 14, December, 1988; or
+! Alan C. Hindmarsh at http://www.netlib.org/lapack/util/dlamch.f
+! or Werner W. Schulz at http://www.ozemail.com.au/~milleraj/ .
+!
+! This routine appears to give bit-for-bit the same results as
+! the Intrinsic function EPSILON(x) for x single or double precision.
+! hdk - 25 August 1999.
+!-----------------------------------------------------------------------
+ DOUBLE PRECISION EPS, COMP
+! EPS = 1.0D0
+!10 EPS = EPS*0.5D0
+! COMP = 1.0D0 + EPS
+! IF (COMP .NE. 1.0D0) GO TO 10
+! D1MACH = EPS*2.0D0
+ EPS = 1.0D0
+ COMP = 2.0D0
+ DO WHILE ( COMP .NE. 1.0D0 )
+ EPS = EPS*0.5D0
+ COMP = 1.0D0 + EPS
+ ENDDO
+ D1MACH = EPS*2.0D0
+ RETURN
+ END
+ DOUBLE PRECISION FUNCTION TFLOOR(X,CT)
+!===========Tolerant FLOOR Function.
+!
+! C - is given as a double precision argument to be operated on.
+! it is assumed that X is represented with m mantissa bits.
+! CT - is given as a Comparison Tolerance such that
+! 0.lt.CT.le.3-Sqrt(5)/2. If the relative difference between
+! X and a whole number is less than CT, then TFLOOR is
+! returned as this whole number. By treating the
+! floating-point numbers as a finite ordered set note that
+! the heuristic eps=2.**(-(m-1)) and CT=3*eps causes
+! arguments of TFLOOR/TCEIL to be treated as whole numbers
+! if they are exactly whole numbers or are immediately
+! adjacent to whole number representations. Since EPS, the
+! "distance" between floating-point numbers on the unit
+! interval, and m, the number of bits in X's mantissa, exist
+! on every floating-point computer, TFLOOR/TCEIL are
+! consistently definable on every floating-point computer.
+!
+! For more information see the following references:
+! {1} P. E. Hagerty, "More on Fuzzy Floor and Ceiling," APL QUOTE
+! QUAD 8(4):20-24, June 1978. Note that TFLOOR=FL5 took five
+! years of refereed evolution (publication).
+!
+! {2} L. M. Breed, "Definitions for Fuzzy Floor and Ceiling", APL
+! QUOTE QUAD 8(3):16-23, March 1978.
+!
+! H. D. KNOBLE, Penn State University.
+!=====================================================================
+ DOUBLE PRECISION X,Q,RMAX,EPS5,CT,FLOOR,DINT
+!---------FLOOR(X) is the largest integer algegraically less than
+! or equal to X; that is, the unfuzzy Floor Function.
+ DINT(X)=X-DMOD(X,1.D0)
+ FLOOR(X)=DINT(X)-DMOD(2.D0+DSIGN(1.D0,X),3.D0)
+!---------Hagerty's FL5 Function follows...
+ Q=1.D0
+ IF(X.LT.0)Q=1.D0-CT
+ RMAX=Q/(2.D0-CT)
+ EPS5=CT/Q
+ TFLOOR=FLOOR(X+DMAX1(CT,DMIN1(RMAX,EPS5*DABS(1.D0+FLOOR(X)))))
+ IF(X.LE.0 .OR. (TFLOOR-X).LT.RMAX)RETURN
+ TFLOOR=TFLOOR-1.D0
+ RETURN
+ END
+ DOUBLE PRECISION FUNCTION TCEIL(X,CT)
+!==========Tolerant Ceiling Function.
+! See TFLOOR.
+ DOUBLE PRECISION X,CT,TFLOOR
+ TCEIL= -TFLOOR(-X,CT)
+ RETURN
+ END
+ DOUBLE PRECISION FUNCTION ROUND(X,CT)
+!=========Tolerant Round Function
+! See Knuth, Art of Computer Programming, Vol. 1, Problem 1.2.4-5.
+ DOUBLE PRECISION TFLOOR,X,CT
+ ROUND=TFLOOR(X+0.5D0,CT)
+ RETURN
+ END
diff --git a/tcllib/modules/math/fuzzy.man b/tcllib/modules/math/fuzzy.man
new file mode 100755
index 0000000..2cc0051
--- /dev/null
+++ b/tcllib/modules/math/fuzzy.man
@@ -0,0 +1,133 @@
+[manpage_begin math::fuzzy n 0.2]
+[keywords floating-point]
+[keywords math]
+[keywords rounding]
+[moddesc {Tcl Math Library}]
+[titledesc {Fuzzy comparison of floating-point numbers}]
+[category Mathematics]
+[require Tcl [opt 8.3]]
+[require math::fuzzy [opt 0.2]]
+[description]
+[para]
+The package Fuzzy is meant to solve common problems with floating-point
+numbers in a systematic way:
+
+[list_begin itemized]
+[item]
+Comparing two numbers that are "supposed" to be identical, like
+1.0 and 2.1/(1.2+0.9) is not guaranteed to give the
+intuitive result.
+
+[item]
+Rounding a number that is halfway two integer numbers can cause
+strange errors, like int(100.0*2.8) != 28 but 27
+[list_end]
+
+[para]
+The Fuzzy package is meant to help sorting out this type of problems
+by defining "fuzzy" comparison procedures for floating-point numbers.
+It does so by allowing for a small margin that is determined
+automatically - the margin is three times the "epsilon" value, that is
+three times the smallest number [emph eps] such that 1.0 and 1.0+$eps
+canbe distinguished. In Tcl, which uses double precision floating-point
+numbers, this is typically 1.1e-16.
+
+[section "PROCEDURES"]
+Effectively the package provides the following procedures:
+
+[list_begin definitions]
+[call [cmd ::math::fuzzy::teq] [arg value1] [arg value2]]
+Compares two floating-point numbers and returns 1 if their values
+fall within a small range. Otherwise it returns 0.
+
+[call [cmd ::math::fuzzy::tne] [arg value1] [arg value2]]
+Returns the negation, that is, if the difference is larger than
+the margin, it returns 1.
+
+[call [cmd ::math::fuzzy::tge] [arg value1] [arg value2]]
+Compares two floating-point numbers and returns 1 if their values
+either fall within a small range or if the first number is larger
+than the second. Otherwise it returns 0.
+
+[call [cmd ::math::fuzzy::tle] [arg value1] [arg value2]]
+Returns 1 if the two numbers are equal according to
+[lb]teq[rb] or if the first is smaller than the second.
+
+[call [cmd ::math::fuzzy::tlt] [arg value1] [arg value2]]
+Returns the opposite of [lb]tge[rb].
+
+[call [cmd ::math::fuzzy::tgt] [arg value1] [arg value2]]
+Returns the opposite of [lb]tle[rb].
+
+[call [cmd ::math::fuzzy::tfloor] [arg value]]
+Returns the integer number that is lower or equal
+to the given floating-point number, within a well-defined
+tolerance.
+[call [cmd ::math::fuzzy::tceil] [arg value]]
+Returns the integer number that is greater or equal to the given
+floating-point number, within a well-defined tolerance.
+
+[call [cmd ::math::fuzzy::tround] [arg value]]
+Rounds the floating-point number off.
+
+[call [cmd ::math::fuzzy::troundn] [arg value] [arg ndigits]]
+Rounds the floating-point number off to the
+specified number of decimals (Pro memorie).
+
+[list_end]
+
+Usage:
+[example_begin]
+if { [lb]teq $x $y[rb] } { puts "x == y" }
+if { [lb]tne $x $y[rb] } { puts "x != y" }
+if { [lb]tge $x $y[rb] } { puts "x >= y" }
+if { [lb]tgt $x $y[rb] } { puts "x > y" }
+if { [lb]tlt $x $y[rb] } { puts "x < y" }
+if { [lb]tle $x $y[rb] } { puts "x <= y" }
+
+set fx [lb]tfloor $x[rb]
+set fc [lb]tceil $x[rb]
+set rounded [lb]tround $x[rb]
+set roundn [lb]troundn $x $nodigits[rb]
+[example_end]
+
+[section {TEST CASES}]
+The problems that can occur with floating-point numbers are illustrated
+by the test cases in the file "fuzzy.test":
+[list_begin itemized]
+[item]
+Several test case use the ordinary comparisons, and they
+fail invariably to produce understandable results
+
+[item]
+One test case uses [lb]expr[rb] without braces ({ and }). It too
+fails.
+[list_end]
+
+The conclusion from this is that any expression should be surrounded by
+braces, because otherwise very awkward things can happen if you need
+accuracy. Furthermore, accuracy and understandable results are
+enhanced by using these "tolerant" or fuzzy comparisons.
+[para]
+Note that besides the Tcl-only package, there is also a C-based version.
+
+[section REFERENCES]
+Original implementation in Fortran by dr. H.D. Knoble (Penn State
+University).
+[para]
+P. E. Hagerty, "More on Fuzzy Floor and Ceiling,"
+
+APL QUOTE QUAD 8(4):20-24, June 1978. Note that TFLOOR=FL5 took five
+years of refereed evolution (publication).
+[para]
+L. M. Breed, "Definitions for Fuzzy Floor and Ceiling",
+
+APL QUOTE QUAD 8(3):16-23, March 1978.
+[para]
+D. Knuth, Art of Computer Programming,
+
+Vol. 1, Problem 1.2.4-5.
+
+[vset CATEGORY {math :: fuzzy}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/fuzzy.tcl b/tcllib/modules/math/fuzzy.tcl
new file mode 100755
index 0000000..5b017b5
--- /dev/null
+++ b/tcllib/modules/math/fuzzy.tcl
@@ -0,0 +1,173 @@
+# fuzzy.tcl --
+#
+# Script to define tolerant floating-point comparisons
+# (Tcl-only version)
+#
+# version 0.2: improved and extended, march 2002
+# version 0.2.1: fix bug #2933130, january 2010
+
+package provide math::fuzzy 0.2.1
+
+namespace eval ::math::fuzzy {
+ variable eps3 2.2e-16
+
+ namespace export teq tne tge tgt tle tlt tfloor tceil tround troundn
+
+# DetermineTolerance
+# Determine the epsilon value
+#
+# Arguments:
+# None
+#
+# Result:
+# None
+#
+# Side effects:
+# Sets variable eps3
+#
+proc DetermineTolerance { } {
+ variable eps3
+ set eps 1.0
+ while { [expr {1.0+$eps}] != 1.0 } {
+ set eps3 [expr 3.0*$eps]
+ set eps [expr 0.5*$eps]
+ }
+ #set check [expr {1.0+2.0*$eps}]
+ #puts "Eps3: $eps3 ($eps) ([expr {1.0-$check}] [expr 1.0-$check]"
+}
+
+# Absmax --
+# Return the absolute maximum of two numbers
+#
+# Arguments:
+# first First number
+# second Second number
+#
+# Result:
+# Maximum of the absolute values
+#
+proc Absmax { first second } {
+ return [expr {abs($first) > abs($second)? abs($first) : abs($second)}]
+}
+
+# teq, tne, tge, tgt, tle, tlt --
+# Compare two floating-point numbers and return the logical result
+#
+# Arguments:
+# first First number
+# second Second number
+#
+# Result:
+# 1 if the condition holds, 0 if not.
+#
+proc teq { first second } {
+ variable eps3
+ set scale [Absmax $first $second]
+ return [expr {abs($first-$second) <= $eps3 * $scale}]
+}
+
+proc tne { first second } {
+ variable eps3
+
+ return [expr {![teq $first $second]}]
+}
+
+proc tgt { first second } {
+ variable eps3
+ set scale [Absmax $first $second]
+ return [expr {($first-$second) > $eps3 * $scale}]
+}
+
+proc tle { first second } {
+ return [expr {![tgt $first $second]}]
+}
+
+proc tlt { first second } {
+ expr { [tle $first $second] && [tne $first $second] }
+}
+
+proc tge { first second } {
+ if { [tgt $first $second] } {
+ return 1
+ } else {
+ return [teq $first $second]
+ }
+}
+
+# tfloor --
+# Determine the "floor" of a number and return the result
+#
+# Arguments:
+# number Number in question
+#
+# Result:
+# Largest integer number that is tolerantly smaller than the given
+# value
+#
+proc tfloor { number } {
+ variable eps3
+
+ set q [expr {($number < 0.0)? (1.0-$eps3) : 1.0 }]
+ set rmax [expr {$q / (2.0 - $eps3)}]
+ set eps5 [expr {$eps3/$q}]
+ set vmin1 [expr {$eps5*abs(1.0+floor($number))}]
+ set vmin2 [expr {($rmax < $vmin1)? $rmax : $vmin1}]
+ set vmax [expr {($eps3 > $vmin2)? $eps3 : $vmin2}]
+ set result [expr {floor($number+$vmax)}]
+ if { $number <= 0.0 || ($result-$number) < $rmax } {
+ return $result
+ } else {
+ return [expr {$result-1.0}]
+ }
+}
+
+# tceil --
+# Determine the "ceil" of a number and return the result
+#
+# Arguments:
+# number Number in question
+#
+# Result:
+# Smallest integer number that is tolerantly greater than the given
+# value
+#
+proc tceil { number } {
+ expr {-[tfloor [expr {-$number}]]}
+}
+
+# tround --
+# Round off a number and return the result
+#
+# Arguments:
+# number Number in question
+#
+# Result:
+# Nearest integer number
+#
+proc tround { number } {
+ tfloor [expr {$number+0.5}]
+}
+
+# troundn --
+# Round off a number to a given precision and return the result
+#
+# Arguments:
+# number Number in question
+# ndec Number of decimals to keep
+#
+# Result:
+# Nearest number with given precision
+#
+proc troundn { number ndec } {
+ set scale [expr {pow(10.0,$ndec)}]
+ set rounded [tfloor [expr {$number*$scale+0.5}]]
+ expr {$rounded/$scale}
+}
+
+#
+# Determine the tolerance once and for all
+#
+DetermineTolerance
+rename DetermineTolerance {}
+
+} ;# End of namespace
diff --git a/tcllib/modules/math/fuzzy.test b/tcllib/modules/math/fuzzy.test
new file mode 100755
index 0000000..cd0e088
--- /dev/null
+++ b/tcllib/modules/math/fuzzy.test
@@ -0,0 +1,387 @@
+# -*- tcl -*-
+# fuzzy.test --
+#
+# Test suite for the math::fuzzy procs of tolerant comparisons
+# (Tcl-only version)
+#
+# version 0.2: improved and extended implementation, march 2002
+# version 0.2.1: added test for bug #2933130, january 2010
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+support {
+ useLocal math.tcl math
+}
+testing {
+ useLocal fuzzy.tcl math::fuzzy
+}
+
+# -------------------------------------------------------------------------
+
+namespace import ::math::fuzzy::*
+
+# -------------------------------------------------------------------------
+
+#
+# Test: tolerance has sane value
+#
+#test math-fuzzy-Tolerance-1.0 {Tolerance has acceptable value} {
+# expr {(1.0+0.5*$::math::fuzzy::eps3) != 1.0}
+#} 1
+#test math-fuzzy-Tolerance-1.1 {Tolerance has acceptable value} {
+# expr {(1.0-0.5*$::math::fuzzy::eps3) != 1.0}
+#} 1
+
+test math-fuzzy-Tolerance-1.0 {Tolerance has acceptable value} {
+ expr {(1.0+0.5*$::math::fuzzy::eps3) != 1.0}
+} 1
+
+test math-fuzzy-Tolerance-1.1 {Tolerance has acceptable value} {
+ expr {(1.0-0.5*$::math::fuzzy::eps3) != 1.0}
+} 1
+
+#
+# Note: Equal-1.* and NotEqual-1.* are complementary
+# GrEqual-1.* and Lower-1.* ditto
+# GrThan-1.* and LoEqual-1.* ditto
+#
+
+test math-fuzzy-Equal-1.0 {Compare two floats and see if they are equal} {
+ teq 1.0 1.001
+} 0
+test math-fuzzy-Equal-1.1 {Compare two floats and see if they are equal} {
+ teq 1.0 1.0001
+} 0
+test math-fuzzy-Equal-1.2 {Compare two floats and see if they are equal} {
+ teq 1.0 1.00000000000000001
+} 1
+test math-fuzzy-Equal-1.3 {Compare two floats and see if they are equal} {
+ teq 1.0 1.000000000000001
+} 0
+
+test math-fuzzy-NotEqual-1.0 {Compare two floats and see if they differ} {
+ tne 1.0 1.001
+} 1
+test math-fuzzy-NotEqual-1.1 {Compare two floats and see if they differ} {
+ tne 1.0 1.0001
+} 1
+test math-fuzzy-NotEqual-1.2 {Compare two floats and see if they differ} {
+ tne 1.0 1.00000000000000001
+} 0
+test math-fuzzy-NotEqual-1.3 {Compare two floats and see if they differ} {
+ tne 1.0 1.000000000000001
+} 1
+
+test math-fuzzy-GrEqual-1.0 {Compare two floats - check greater/equal} {
+ tge 1.0 1.001
+} 0
+test math-fuzzy-GrEqual-1.1 {Compare two floats - check greater/equal} {
+ tge 1.0 1.0001
+} 0
+test math-fuzzy-GrEqual-1.2 {Compare two floats - check greater/equal} {
+ tge 1.0 1.00000000000000001
+} 1
+test math-fuzzy-GrEqual-1.3 {Compare two floats - check greater/equal} {
+ tge 1.0 1.000000000000001
+} 0
+
+test math-fuzzy-Lower-1.0 {Compare two floats - check lower} {
+ tlt 1.0 1.001
+} 1
+test math-fuzzy-Lower-1.1 {Compare two floats - check lower} {
+ tlt 1.0 1.0001
+} 1
+test math-fuzzy-Lower-1.2 {Compare two floats - check lower} {
+ tlt 1.0 1.00000000000000001
+} 0
+test math-fuzzy-Lower-1.3 {Compare two floats - check lower} {
+ tlt 1.0 1.000000000000001
+} 1
+test math-fuzzy-Lower-1.4 {Compare two floats - check lower} {
+ # They can not both be true
+ expr {[tlt 1.1 1.0] && [tlt 1.0 1.1]}
+} 0
+
+test math-fuzzy-LoEqual-1.0 {Compare two floats - check lower/equal} {
+ tle 1.0 1.001
+} 1
+test math-fuzzy-LoEqual-1.1 {Compare two floats - check lower/equal} {
+ tle 1.0 1.0001
+} 1
+test math-fuzzy-LoEqual-1.2 {Compare two floats - check lower/equal} {
+ tle 1.0 1.00000000000000001
+} 1
+test math-fuzzy-LoEqual-1.3 {Compare two floats - check lower/equal} {
+ tle 1.0 1.000000000000001
+} 1
+
+test math-fuzzy-Greater-1.0 {Compare two floats - check greater} {
+ tgt 1.0 1.001
+} 0
+test math-fuzzy-Greater-1.1 {Compare two floats - check greater} {
+ tgt 1.0 1.0001
+} 0
+test math-fuzzy-Greater-1.2 {Compare two floats - check greater} {
+ tgt 1.0 1.00000000000000001
+} 0
+test math-fuzzy-Greater-1.3 {Compare two floats - check greater} {
+ tgt 1.0 1.000000000000001
+} 0
+
+#
+# Note: there is no possibility to print the results of the
+# naive comparison or floor/ceil?
+#
+# Note: no attention paid to tcl_precision!
+#
+test math-fuzzy-ManyCompares-1.0 {Compare results of calculations} {
+ set tol_eq 0
+ set tol_ne 0
+ set tol_ge 0
+ set tol_gt 0
+ set tol_le 0
+ set tol_lt 0
+
+ for { set i -1000 } { $i <= 1000 } { incr i } {
+ if { $i == 0 } continue
+
+ set x [expr {1.01/double($i)}]
+ set y [expr {(2.1*$x)*(double($i)/2.1)}]
+
+ if { [teq $y 1.01] } { incr tol_eq }
+ if { [tne $y 1.01] } { incr tol_ne }
+ if { [tge $y 1.01] } { incr tol_ge }
+ if { [tgt $y 1.01] } { incr tol_gt }
+ if { [tle $y 1.01] } { incr tol_le }
+ if { [tlt $y 1.01] } { incr tol_lt }
+ }
+ set result [list $tol_eq $tol_ne $tol_ge $tol_gt $tol_le $tol_lt]
+} {2000 0 2000 0 2000 0}
+
+test math-fuzzy-ManyCompares-1.1 {Compare fails due to missing braces at reduced precision} {
+ set tol_eq 0
+ set tol_ne 0
+ set tol_ge 0
+ set tol_gt 0
+ set tol_le 0
+ set tol_lt 0
+
+ #
+ # Force Tcl8.4 or earlier behaviour in expanding numbers
+ # Requires tcl_precision of 12!
+ #
+ set prec $::tcl_precision
+ set ::tcl_precision 12
+
+ for { set i -1000 } { $i <= 1000 } { incr i } {
+ if { $i == 0 } continue
+
+ #
+ # NOTE: The braces in the assignment for y are missing on purpose!
+ #
+ set x [expr {1.01/double($i)}]
+ set y [expr (2.1*$x)*(double($i)/2.1)]
+
+ if { [teq $y 1.01] } { incr tol_eq }
+ if { [tne $y 1.01] } { incr tol_ne }
+ if { [tge $y 1.01] } { incr tol_ge }
+ if { [tgt $y 1.01] } { incr tol_gt }
+ if { [tle $y 1.01] } { incr tol_le }
+ if { [tlt $y 1.01] } { incr tol_lt }
+ }
+ set result [list $tol_eq $tol_ne $tol_ge $tol_gt $tol_le $tol_lt]
+ set intended {2000 0 2000 0 2000 0}
+ set equal 1
+ foreach r $result i $intended {
+ if { $r != $i } {
+ set equal 0
+ }
+ }
+ set tcl_precision $prec
+ set equal
+} 0
+
+test math-fuzzy-ManyCompares-1.2 {Compare does not fail even with missing braces because of sufficient precision} {
+ set tol_eq 0
+ set tol_ne 0
+ set tol_ge 0
+ set tol_gt 0
+ set tol_le 0
+ set tol_lt 0
+
+ #
+ # Force sufficient precision if Tcl8.4 or earlier
+ #
+ set prec $::tcl_precision
+ if {![package vsatisfies [package provide Tcl] 8.5]} {
+ set ::tcl_precision 17
+ } else {
+ set ::tcl_precision 0
+ }
+
+ for { set i -1000 } { $i <= 1000 } { incr i } {
+ if { $i == 0 } continue
+
+ #
+ # NOTE: The braces in the assignment for y are missing on purpose!
+ #
+ set x [expr {1.01/double($i)}]
+ set y [expr (2.1*$x)*(double($i)/2.1)]
+
+ if { [teq $y 1.01] } { incr tol_eq }
+ if { [tne $y 1.01] } { incr tol_ne }
+ if { [tge $y 1.01] } { incr tol_ge }
+ if { [tgt $y 1.01] } { incr tol_gt }
+ if { [tle $y 1.01] } { incr tol_le }
+ if { [tlt $y 1.01] } { incr tol_lt }
+ }
+ set result [list $tol_eq $tol_ne $tol_ge $tol_gt $tol_le $tol_lt]
+ set intended {2000 0 2000 0 2000 0}
+ set equal 1
+ foreach r $result i $intended {
+ if { $r != $i } {
+ set equal 0
+ }
+ }
+ set tcl_precision $prec
+ set equal
+} 1
+
+test math-fuzzy-ManyCompares-1.3 {Compare fails due to naive comparison} {
+ set naiv_eq 0
+ set naiv_ne 0
+ set naiv_ge 0
+ set naiv_gt 0
+ set naiv_le 0
+ set naiv_lt 0
+
+ for { set i -1000 } { $i <= 1000 } { incr i } {
+ if { $i == 0 } continue
+
+ set x [expr {1.01/double($i)}]
+ set y [expr {(2.1*$x)*(double($i)/2.1)}]
+
+ if { $y == 1.01 } { incr naiv_eq }
+ if { $y != 1.01 } { incr naiv_ne }
+ if { $y >= 1.01 } { incr naiv_ge }
+ if { $y > 1.01 } { incr naiv_gt }
+ if { $y <= 1.01 } { incr naiv_le }
+ if { $y < 1.01 } { incr naiv_lt }
+ }
+ set result [list $naiv_eq $naiv_ne $naiv_ge $naiv_gt $naiv_le $naiv_lt]
+ set intended {2000 0 2000 0 2000 0}
+ set equal 1
+ foreach r $result i $intended {
+ if { $r != $i } {
+ set equal 0
+ }
+ }
+ set equal
+} 0
+
+test math-fuzzy-Floor-Ceil-1.0 {Check floor and ceil functions} {
+ set fc_eq 0
+ set fz_eq 0
+ set fz_ne 0
+
+ for { set i -1000 } { $i <= 1000 } { incr i } {
+
+ set x [expr {0.11*double($i)}]
+ set y [expr {(($x*11.0)-$x)-double($i)/10.0}]
+ set z [expr {double($i)}]
+
+ if { [tfloor $y] == $z } { incr fz_eq }
+ if { [tfloor $y] == [tceil $y] } { incr fc_eq }
+ }
+ set result [list $fc_eq $fz_eq]
+} {2001 2001}
+
+test math-fuzzy-Floor-Ceil-1.1 {Naive floor and ceil fail} {
+ set fc_eq 0
+ set fz_eq 0
+ set fz_ne 0
+
+ for { set i -1000 } { $i <= 1000 } { incr i } {
+
+ set x [expr {0.11*double($i)}]
+ set y [expr {(($x*11.0)-$x)-double($i)/10.0}]
+ set z [expr {double($i)}]
+
+ if { [expr {floor($y)}] == $z } { incr fz_eq }
+ if { [expr {floor($y)}] == [expr {ceil($y)}] } { incr fc_eq }
+ }
+ set result [list $fc_eq $fz_eq]
+ set intended {2001 2001}
+ set equal 1
+ foreach r $result i $intended {
+ if { $r != $i } {
+ set equal 0
+ }
+ }
+ set equal
+} 0
+
+test math-fuzzy-Roundoff-1.0 {Rounding off numbers} {
+
+ set result {}
+ foreach x {
+ 0.1 0.3 0.4999999 0.5000001 0.99999
+ -0.1 -0.3 -0.4999999 -0.5000001 -0.99999
+ } {
+ lappend result [tround $x]
+ }
+ set result
+} {0.0 0.0 0.0 1.0 1.0 0.0 0.0 0.0 -1.0 -1.0}
+
+test math-fuzzy-Roundoff-1.1 {Rounding off numbers naively - may fail} {
+ set result {}
+ foreach x {
+ 0.1 0.3 0.4999999 0.5000001 0.99999
+ -0.1 -0.3 -0.4999999 -0.5000001 -0.99999
+ } {
+ lappend result [expr {floor($x+0.5)}]
+ }
+ set result
+} {0.0 0.0 0.0 1.0 1.0 0.0 0.0 0.0 -1.0 -1.0}
+
+test math-fuzzy-Roundoff-2.1 {Rounding off numbers with one digit} {
+ set result {}
+ foreach x {
+ 0.11 0.32 0.4999999 0.5000001 0.99999
+ -0.11 -0.32 -0.4999999 -0.5000001 -0.99999
+ } {
+ lappend result [troundn $x 1]
+ }
+ set result
+} {0.1 0.3 0.5 0.5 1.0 -0.1 -0.3 -0.5 -0.5 -1.0}
+
+test math-fuzzy-Roundoff-2.2 {Rounding off numbers with two digits} {
+ set result {}
+ foreach x {
+ 0.11 0.32 0.4999999 0.5000001 0.99999
+ -0.11 -0.32 -0.4999999 -0.5000001 -0.99999
+ } {
+ lappend result [troundn $x 2]
+ }
+ set result
+} {0.11 0.32 0.5 0.5 1.0 -0.11 -0.32 -0.5 -0.5 -1.0}
+
+test math-fuzzy-Roundoff-2.3 {Rounding off numbers with three digits} {
+ set result {}
+ foreach x {
+ 0.1115 0.3210 0.4909999 0.5123401 0.99999
+ -0.1115 -0.3210 -0.4909999 -0.5123401 -0.99999
+ } {
+ lappend result [troundn $x 3]
+ }
+ set result
+} {0.112 0.321 0.491 0.512 1.0 -0.111 -0.321 -0.491 -0.512 -1.0}
+#
+# Hm, here we have a discrepancy: 0.112 and -0.111!
diff --git a/tcllib/modules/math/fuzzy.testscript b/tcllib/modules/math/fuzzy.testscript
new file mode 100755
index 0000000..a27f21f
--- /dev/null
+++ b/tcllib/modules/math/fuzzy.testscript
@@ -0,0 +1,21 @@
+# Rough tests for math::fuzzy procs
+# To do: convert to Tcltest
+
+package require math::fuzzy
+namespace import ::math::fuzzy::*
+
+puts "[teq 1.0 1.001] - expected: 0"
+puts "[teq 1.0 1.0000000000000000001] - expected: 1"
+puts "[tne 1.0 1.001] - expected: 1"
+puts "[tne 1.0 1.0000000000000000001] - expected: 0"
+puts "[tgt 1.0 1.001] - expected: 0"
+puts "[tgt 1.0 1.0000000000000000001] - expected: 0"
+
+set x 0.11
+set y [expr {(($x*11.0)-$x)-0.1}]
+set z 1.0
+puts "X: $x"
+puts "Y: $y"
+puts "Z: $z"
+puts "Floor: [tfloor $y] ([expr {floor($y)}])"
+puts "Ceil: [tceil $y] ([expr {ceil($y)}])"
diff --git a/tcllib/modules/math/geometry.tcl b/tcllib/modules/math/geometry.tcl
new file mode 100644
index 0000000..7e14fef
--- /dev/null
+++ b/tcllib/modules/math/geometry.tcl
@@ -0,0 +1,1265 @@
+# geometry.tcl --
+#
+# Collection of geometry functions.
+#
+# Copyright (c) 2001 by Ideogramic ApS and other parties.
+# Copyright (c) 2004 Arjen Markus
+# Copyright (c) 2010 Andreas Kupries
+# Copyright (c) 2010 Kevin Kenny
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: geometry.tcl,v 1.12 2010/05/24 21:44:16 andreas_kupries Exp $
+
+namespace eval ::math::geometry {}
+
+package require math
+
+###
+#
+# POINTS
+#
+# A point P consists of an x-coordinate, Px, and a y-coordinate, Py,
+# and both coordinates are floating point values.
+#
+# Points are usually denoted by A, B, C, P, or Q.
+#
+###
+#
+# LINES
+#
+# There are basically three types of lines:
+# line A line is defined by two points A and B as the
+# _infinite_ line going through these two points.
+# Often a line is given as a list of 4 coordinates
+# instead of 2 points.
+# line segment A line segment is defined by two points A and B
+# as the _finite_ that starts in A and ends in B.
+# Often a line segment is given as a list of 4
+# coordinates instead of 2 points.
+# polyline A polyline is a sequence of connected line segments.
+#
+# Please note that given a point P, the closest point on a line is given
+# by the projection of P onto the line. The closest point on a line segment
+# may be the projection, but it may also be one of the end points of the
+# line segment.
+#
+###
+#
+# DISTANCES
+#
+# The distances in this package are all floating point values.
+#
+###
+
+# Point constructor
+proc ::math::geometry::p {x y} {
+ return [list $x $y]
+}
+
+# Vector addition
+proc ::math::geometry::+ {pa pb} {
+ foreach {ax ay} $pa break
+ foreach {bx by} $pb break
+ return [list [expr {$ax + $bx}] [expr {$ay + $by}]]
+}
+
+# Vector difference
+proc ::math::geometry::- {pa pb} {
+ foreach {ax ay} $pa break
+ foreach {bx by} $pb break
+ return [list [expr {$ax - $bx}] [expr {$ay - $by}]]
+}
+
+# Distance between 2 points
+proc ::math::geometry::distance {pa pb} {
+ foreach {ax ay} $pa break
+ foreach {bx by} $pb break
+ return [expr {hypot($bx-$ax,$by-$ay)}]
+}
+
+# Length of a vector
+proc ::math::geometry::length {v} {
+ foreach {x y} $v break
+ return [expr {hypot($x,$y)}]
+}
+
+# Scaling a vector by a factor
+proc ::math::geometry::s* {factor p} {
+ foreach {x y} $p break
+ return [list [expr {$x * $factor}] [expr {$y * $factor}]]
+}
+
+# Unit vector into specific direction given by angle (degrees)
+proc ::math::geometry::direction {angle} {
+ variable torad
+ set x [expr { cos($angle * $torad)}]
+ set y [expr {- sin($angle * $torad)}]
+ return [list $x $y]
+}
+
+# Vertical vector of specified length.
+proc ::math::geometry::v {h} {
+ return [list 0 $h]
+}
+
+# Horizontal vector of specified length.
+proc ::math::geometry::h {w} {
+ return [list $w 0]
+}
+
+# Find point on a line between 2 points at a distance
+# distance 0 => a, distance 1 => b
+proc ::math::geometry::between {pa pb s} {
+ return [+ $pa [s* $s [- $pb $pa]]]
+}
+
+# Find direction octant the point (vector) lies in.
+proc ::math::geometry::octant {p} {
+ variable todeg
+ foreach {x y} $p break
+
+ set a [expr {(atan2(-$y,$x)*$todeg)}]
+ while {$a > 360} {set a [expr {$a - 360}]}
+ while {$a < -360} {set a [expr {$a + 360}]}
+ if {$a < 0} {set a [expr {360 + $a}]}
+
+ #puts "p ($x, $y) @ angle $a | [expr {atan2($y,$x)}] | [expr {atan2($y,$x)*$todeg}]"
+ # XXX : Add outer conditions to make a log2 tree of checks.
+
+ if {$a <= 157.5} {
+ if {$a <= 67.5} {
+ if {$a <= 22.5} { return east }
+ return northeast
+ }
+ if {$a <= 112.5} { return north }
+ return northwest
+ } else {
+ if {$a <= 247.5} {
+ if {$a <= 202.5} { return west }
+ return southwest
+ }
+ if {$a <= 337.5} {
+ if {$a <= 292.5} { return south }
+ return southeast
+ }
+ return east ; # a <= 360.0
+ }
+}
+
+# Return the NW and SE corners of the rectangle.
+proc ::math::geometry::nwse {rect} {
+ foreach {xnw ynw xse yse} $rect break
+ return [list [p $xnw $ynw] [p $xse $yse]]
+}
+
+# Construct rectangle from NW and SE corners.
+proc ::math::geometry::rect {pa pb} {
+ foreach {ax ay} $pa break
+ foreach {bx by} $pb break
+ return [list $ax $ay $bx $by]
+}
+
+proc ::math::geometry::conjx {p} {
+ foreach {x y} $p break
+ return [list [expr {- $x}] $y]
+}
+
+proc ::math::geometry::conjy {p} {
+ foreach {x y} $p break
+ return [list $x [expr {- $y}]]
+}
+
+proc ::math::geometry::x {p} {
+ foreach {x y} $p break
+ return $x
+}
+
+proc ::math::geometry::y {p} {
+ foreach {x y} $p break
+ return $y
+}
+
+# ::math::geometry::calculateDistanceToLine
+#
+# Calculate the distance between a point and a line.
+#
+# Arguments:
+# P a point
+# line a line
+#
+# Results:
+# dist the smallest distance between P and the line
+#
+# Examples:
+# - calculateDistanceToLine {5 10} {0 0 10 10}
+# Result: 3.53553390593
+# - calculateDistanceToLine {-10 0} {0 0 10 10}
+# Result: 7.07106781187
+#
+proc ::math::geometry::calculateDistanceToLine {P line} {
+ # solution based on FAQ 1.02 on comp.graphics.algorithms
+ # L = sqrt( (Bx-Ax)^2 + (By-Ay)^2 )
+ # (Ay-Cy)(Bx-Ax)-(Ax-Cx)(By-Ay)
+ # s = -----------------------------
+ # L^2
+ # dist = |s|*L
+ #
+ # =>
+ #
+ # | (Ay-Cy)(Bx-Ax)-(Ax-Cx)(By-Ay) |
+ # dist = ---------------------------------
+ # L
+ set Ax [lindex $line 0]
+ set Ay [lindex $line 1]
+ set Bx [lindex $line 2]
+ set By [lindex $line 3]
+ set Cx [lindex $P 0]
+ set Cy [lindex $P 1]
+ if {$Ax==$Bx && $Ay==$By} {
+ return [lengthOfPolyline [concat $P [lrange $line 0 1]]]
+ } else {
+ set L [expr {sqrt(pow($Bx-$Ax,2) + pow($By-$Ay,2))}]
+ return [expr {abs(($Ay-$Cy)*($Bx-$Ax)-($Ax-$Cx)*($By-$Ay)) / $L}]
+ }
+}
+
+# ::math::geometry::findClosestPointOnLine
+#
+# Return the point on a line which is closest to a given point.
+#
+# Arguments:
+# P a point
+# line a line
+#
+# Results:
+# Q the point on the line that has the smallest
+# distance to P
+#
+# Examples:
+# - findClosestPointOnLine {5 10} {0 0 10 10}
+# Result: 7.5 7.5
+# - findClosestPointOnLine {-10 0} {0 0 10 10}
+# Result: -5.0 -5.0
+#
+proc ::math::geometry::findClosestPointOnLine {P line} {
+ return [lindex [findClosestPointOnLineImpl $P $line] 0]
+}
+
+# ::math::geometry::findClosestPointOnLineImpl
+#
+# PRIVATE FUNCTION USED BY OTHER FUNCTIONS.
+# Find the point on a line that is closest to a given point.
+#
+# Arguments:
+# P a point
+# line a line defined by points A and B
+#
+# Results:
+# Q the point on the line that has the smallest
+# distance to P
+# r r has the following meaning:
+# r=0 P = A
+# r=1 P = B
+# r<0 P is on the backward extension of AB
+# r>1 P is on the forward extension of AB
+# 0<r<1 P is interior to AB
+#
+proc ::math::geometry::findClosestPointOnLineImpl {P line} {
+ # solution based on FAQ 1.02 on comp.graphics.algorithms
+ # L = sqrt( (Bx-Ax)^2 + (By-Ay)^2 )
+ # (Cx-Ax)(Bx-Ax) + (Cy-Ay)(By-Ay)
+ # r = -------------------------------
+ # L^2
+ # Px = Ax + r(Bx-Ax)
+ # Py = Ay + r(By-Ay)
+ set Ax [lindex $line 0]
+ set Ay [lindex $line 1]
+ set Bx [lindex $line 2]
+ set By [lindex $line 3]
+ set Cx [lindex $P 0]
+ set Cy [lindex $P 1]
+ if {$Ax==$Bx && $Ay==$By} {
+ return [list [list $Ax $Ay] 0]
+ } else {
+ set L [expr {sqrt(pow($Bx-$Ax,2) + pow($By-$Ay,2))}]
+ set r [expr {(($Cx-$Ax)*($Bx-$Ax) + ($Cy-$Ay)*($By-$Ay))/pow($L,2)}]
+ set Px [expr {$Ax + $r*($Bx-$Ax)}]
+ set Py [expr {$Ay + $r*($By-$Ay)}]
+ return [list [list $Px $Py] $r]
+ }
+}
+
+# ::math::geometry::calculateDistanceToLineSegment
+#
+# Calculate the distance between a point and a line segment.
+#
+# Arguments:
+# P a point
+# linesegment a line segment
+#
+# Results:
+# dist the smallest distance between P and any point
+# on the line segment
+#
+# Examples:
+# - calculateDistanceToLineSegment {5 10} {0 0 10 10}
+# Result: 3.53553390593
+# - calculateDistanceToLineSegment {-10 0} {0 0 10 10}
+# Result: 10.0
+#
+proc ::math::geometry::calculateDistanceToLineSegment {P linesegment} {
+ set result [calculateDistanceToLineSegmentImpl $P $linesegment]
+ set distToLine [lindex $result 0]
+ set r [lindex $result 1]
+ if {$r<0} {
+ return [lengthOfPolyline [concat $P [lrange $linesegment 0 1]]]
+ } elseif {$r>1} {
+ return [lengthOfPolyline [concat $P [lrange $linesegment 2 3]]]
+ } else {
+ return $distToLine
+ }
+}
+
+# ::math::geometry::calculateDistanceToLineSegmentImpl
+#
+# PRIVATE FUNCTION USED BY OTHER FUNCTIONS.
+# Find the distance between a point and a line.
+#
+# Arguments:
+# P a point
+# linesegment a line segment A->B
+#
+# Results:
+# dist the smallest distance between P and the line
+# r r has the following meaning:
+# r=0 P = A
+# r=1 P = B
+# r<0 P is on the backward extension of AB
+# r>1 P is on the forward extension of AB
+# 0<r<1 P is interior to AB
+#
+proc ::math::geometry::calculateDistanceToLineSegmentImpl {P linesegment} {
+ # solution based on FAQ 1.02 on comp.graphics.algorithms
+ # L = sqrt( (Bx-Ax)^2 + (By-Ay)^2 )
+ # (Ay-Cy)(Bx-Ax)-(Ax-Cx)(By-Ay)
+ # s = -----------------------------
+ # L^2
+ # (Cx-Ax)(Bx-Ax) + (Cy-Ay)(By-Ay)
+ # r = -------------------------------
+ # L^2
+ # dist = |s|*L
+ #
+ # =>
+ #
+ # | (Ay-Cy)(Bx-Ax)-(Ax-Cx)(By-Ay) |
+ # dist = ---------------------------------
+ # L
+ set Ax [lindex $linesegment 0]
+ set Ay [lindex $linesegment 1]
+ set Bx [lindex $linesegment 2]
+ set By [lindex $linesegment 3]
+ set Cx [lindex $P 0]
+ set Cy [lindex $P 1]
+ if {$Ax==$Bx && $Ay==$By} {
+ return [list [lengthOfPolyline [concat $P [lrange $linesegment 0 1]]] 0]
+ } else {
+ set L [expr {sqrt(pow($Bx-$Ax,2) + pow($By-$Ay,2))}]
+ set r [expr {(($Cx-$Ax)*($Bx-$Ax) + ($Cy-$Ay)*($By-$Ay))/pow($L,2)}]
+ return [list [expr {abs(($Ay-$Cy)*($Bx-$Ax)-($Ax-$Cx)*($By-$Ay)) / $L}] $r]
+ }
+}
+
+# ::math::geometry::findClosestPointOnLineSegment
+#
+# Return the point on a line segment which is closest to a given point.
+#
+# Arguments:
+# P a point
+# linesegment a line segment
+#
+# Results:
+# Q the point on the line segment that has the
+# smallest distance to P
+#
+# Examples:
+# - findClosestPointOnLineSegment {5 10} {0 0 10 10}
+# Result: 7.5 7.5
+# - findClosestPointOnLineSegment {-10 0} {0 0 10 10}
+# Result: 0 0
+#
+proc ::math::geometry::findClosestPointOnLineSegment {P linesegment} {
+ set result [findClosestPointOnLineImpl $P $linesegment]
+ set Q [lindex $result 0]
+ set r [lindex $result 1]
+ if {$r<0} {
+ return [lrange $linesegment 0 1]
+ } elseif {$r>1} {
+ return [lrange $linesegment 2 3]
+ } else {
+ return $Q
+ }
+
+}
+
+# ::math::geometry::calculateDistanceToPolyline
+#
+# Calculate the distance between a point and a polyline.
+#
+# Arguments:
+# P a point
+# polyline a polyline
+#
+# Results:
+# dist the smallest distance between P and any point
+# on the polyline
+#
+# Examples:
+# - calculateDistanceToPolyline {10 10} {0 0 10 5 20 0}
+# Result: 5.0
+# - calculateDistanceToPolyline {5 10} {0 0 10 5 20 0}
+# Result: 6.7082039325
+#
+proc ::math::geometry::calculateDistanceToPolyline {P polyline} {
+ set minDist "none"
+ foreach {Ax Ay} [lrange $polyline 0 end-2] {Bx By} [lrange $polyline 2 end] {
+ set dist [calculateDistanceToLineSegment $P [list $Ax $Ay $Bx $By]]
+ if {$minDist=="none" || $dist < $minDist} {
+ set minDist $dist
+ }
+ }
+ return $minDist
+}
+
+# ::math::geometry::calculateDistanceToPolygon
+#
+# Calculate the distance between a point and a polygon.
+#
+# Arguments:
+# P a point
+# polygon a polygon
+#
+# Results:
+# dist the smallest distance between P and any point
+# on the polygon
+#
+# Note:
+# The polygon does not need to be closed - this is taken
+# care of in the procedure.
+#
+proc ::math::geometry::calculateDistanceToPolygon {P polygon} {
+ return [::math::geometry::calculateDistanceToPolyline $P [ClosedPolygon $polygon]]
+}
+
+# ::math::geometry::findClosestPointOnPolyline
+#
+# Return the point on a polyline which is closest to a given point.
+#
+# Arguments:
+# P a point
+# polyline a polyline
+#
+# Results:
+# Q the point on the polyline that has the smallest
+# distance to P
+#
+# Examples:
+# - findClosestPointOnPolyline {10 10} {0 0 10 5 20 0}
+# Result: 10 5
+# - findClosestPointOnPolyline {5 10} {0 0 10 5 20 0}
+# Result: 8.0 4.0
+#
+proc ::math::geometry::findClosestPointOnPolyline {P polyline} {
+ set closestPoint "none"
+ foreach {Ax Ay} [lrange $polyline 0 end-2] {Bx By} [lrange $polyline 2 end] {
+ set Q [findClosestPointOnLineSegment $P [list $Ax $Ay $Bx $By]]
+ set dist [lengthOfPolyline [concat $P $Q]]
+ if {$closestPoint=="none" || $dist<$closestDistance} {
+ set closestPoint $Q
+ set closestDistance $dist
+ }
+ }
+ return $closestPoint
+}
+
+
+
+
+
+
+# ::math::geometry::lengthOfPolyline
+#
+# Find the length of a polyline, i.e., the sum of the
+# lengths of the individual line segments.
+#
+# Arguments:
+# polyline a polyline
+#
+# Results:
+# length the length of the polyline
+#
+# Examples:
+# - lengthOfPolyline {0 0 5 0 5 10}
+# Result: 15.0
+#
+proc ::math::geometry::lengthOfPolyline {polyline} {
+ set length 0
+ foreach {x1 y1} [lrange $polyline 0 end-2] {x2 y2} [lrange $polyline 2 end] {
+ set length [expr {$length + sqrt(pow($x1-$x2,2) + pow($y1-$y2,2))}]
+ #set length [expr {$length + sqrt(($x1-$x2)*($x1-$x2) + ($y1-$y2)*($y1-$y2))}]
+ }
+ return $length
+}
+
+
+
+
+# ::math::geometry::movePointInDirection
+#
+# Move a point in a given direction.
+#
+# Arguments:
+# P the starting point
+# direction the direction from P
+# The direction is in 360-degrees going counter-clockwise,
+# with "straight right" being 0 degrees
+# dist the distance from P
+#
+# Results:
+# Q the point which is found by starting in P and going
+# in the given direction, until the distance between
+# P and Q is dist
+#
+# Examples:
+# - movePointInDirection {0 0} 45.0 10
+# Result: 7.07106781187 7.07106781187
+#
+proc ::math::geometry::movePointInDirection {P direction dist} {
+ set x [lindex $P 0]
+ set y [lindex $P 1]
+ set pi [expr {4*atan(1)}]
+ set xt [expr {$x + $dist*cos(($direction*$pi)/180)}]
+ set yt [expr {$y + $dist*sin(($direction*$pi)/180)}]
+ return [list $xt $yt]
+}
+
+
+# ::math::geometry::angle
+#
+# Calculates angle from the horizon (0,0)->(1,0) to a line.
+#
+# Arguments:
+# line a line defined by two points A and B
+#
+# Results:
+# angle the angle between the line (0,0)->(1,0) and (Ax,Ay)->(Bx,By).
+# Angle is in 360-degrees going counter-clockwise
+#
+# Examples:
+# - angle {10 10 15 13}
+# Result: 30.9637565321
+#
+proc ::math::geometry::angle {line} {
+ set x1 [lindex $line 0]
+ set y1 [lindex $line 1]
+ set x2 [lindex $line 2]
+ set y2 [lindex $line 3]
+ # - handle vertical lines
+ if {$x1==$x2} {if {$y1<$y2} {return 90} else {return 270}}
+ # - handle other lines
+ set a [expr {atan(abs((1.0*$y1-$y2)/(1.0*$x1-$x2)))}] ; # a is between 0 and pi/2
+ set pi [expr {4*atan(1)}]
+ if {$y1<=$y2} {
+ # line is going upwards
+ if {$x1<$x2} {set b $a} else {set b [expr {$pi-$a}]}
+ } else {
+ # line is going downwards
+ if {$x1<$x2} {set b [expr {2*$pi-$a}]} else {set b [expr {$pi+$a}]}
+ }
+ return [expr {$b/$pi*180}] ; # convert b to degrees
+}
+
+
+
+
+###
+#
+# Intersection procedures
+#
+###
+
+# ::math::geometry::lineSegmentsIntersect
+#
+# Checks whether two line segments intersect.
+#
+# Arguments:
+# linesegment1 the first line segment
+# linesegment2 the second line segment
+#
+# Results:
+# dointersect a boolean saying whether the line segments intersect
+# (i.e., have any points in common)
+#
+# Examples:
+# - lineSegmentsIntersect {0 0 10 10} {0 10 10 0}
+# Result: 1
+# - lineSegmentsIntersect {0 0 10 10} {20 20 20 30}
+# Result: 0
+# - lineSegmentsIntersect {0 0 10 10} {10 10 15 15}
+# Result: 1
+#
+proc ::math::geometry::lineSegmentsIntersect {linesegment1 linesegment2} {
+ # Algorithm based on Sedgewick.
+ set l1x1 [lindex $linesegment1 0]
+ set l1y1 [lindex $linesegment1 1]
+ set l1x2 [lindex $linesegment1 2]
+ set l1y2 [lindex $linesegment1 3]
+ set l2x1 [lindex $linesegment2 0]
+ set l2y1 [lindex $linesegment2 1]
+ set l2x2 [lindex $linesegment2 2]
+ set l2y2 [lindex $linesegment2 3]
+
+ #
+ # First check the distance between the endpoints
+ #
+ set margin 1.0e-7
+ if { [calculateDistanceToLineSegment [lrange $linesegment1 0 1] $linesegment2] < $margin } {
+ return 1
+ }
+ if { [calculateDistanceToLineSegment [lrange $linesegment1 2 3] $linesegment2] < $margin } {
+ return 1
+ }
+ if { [calculateDistanceToLineSegment [lrange $linesegment2 0 1] $linesegment1] < $margin } {
+ return 1
+ }
+ if { [calculateDistanceToLineSegment [lrange $linesegment2 2 3] $linesegment1] < $margin } {
+ return 1
+ }
+
+ return [expr {([ccw [list $l1x1 $l1y1] [list $l1x2 $l1y2] [list $l2x1 $l2y1]]\
+ *[ccw [list $l1x1 $l1y1] [list $l1x2 $l1y2] [list $l2x2 $l2y2]] <= 0) \
+ && ([ccw [list $l2x1 $l2y1] [list $l2x2 $l2y2] [list $l1x1 $l1y1]]\
+ *[ccw [list $l2x1 $l2y1] [list $l2x2 $l2y2] [list $l1x2 $l1y2]] <= 0)}]
+}
+
+# ::math::geometry::findLineSegmentIntersection
+#
+# Returns the intersection point of two line segments.
+# Note: may also return "coincident" and "none".
+#
+# Arguments:
+# linesegment1 the first line segment
+# linesegment2 the second line segment
+#
+# Results:
+# P the intersection point of linesegment1 and linesegment2.
+# If linesegment1 and linesegment2 have an infinite number
+# of points in common, the procedure returns "coincident".
+# If there are no intersection points, the procedure
+# returns "none".
+#
+# Examples:
+# - findLineSegmentIntersection {0 0 10 10} {0 10 10 0}
+# Result: 5.0 5.0
+# - findLineSegmentIntersection {0 0 10 10} {20 20 20 30}
+# Result: none
+# - findLineSegmentIntersection {0 0 10 10} {10 10 15 15}
+# Result: 10.0 10.0
+# - findLineSegmentIntersection {0 0 10 10} {5 5 15 15}
+# Result: coincident
+#
+proc ::math::geometry::findLineSegmentIntersection {linesegment1 linesegment2} {
+ if {[lineSegmentsIntersect $linesegment1 $linesegment2]} {
+ set lineintersect [findLineIntersection $linesegment1 $linesegment2]
+ switch -- $lineintersect {
+
+ "coincident" {
+ # lines are coincident
+ set l1x1 [lindex $linesegment1 0]
+ set l1y1 [lindex $linesegment1 1]
+ set l1x2 [lindex $linesegment1 2]
+ set l1y2 [lindex $linesegment1 3]
+ set l2x1 [lindex $linesegment2 0]
+ set l2y1 [lindex $linesegment2 1]
+ set l2x2 [lindex $linesegment2 2]
+ set l2y2 [lindex $linesegment2 3]
+ # check if the line SEGMENTS overlap
+ # (NOT enough to check if the x-intervals overlap (vertical lines!))
+ set overlapx [intervalsOverlap $l1x1 $l1x2 $l2x1 $l2x2 0]
+ set overlapy [intervalsOverlap $l1y1 $l1y2 $l2y1 $l2y2 0]
+ if {$overlapx && $overlapy} {
+ return "coincident"
+ } else {
+ return "none"
+ }
+ }
+
+ "none" {
+ # should never happen, because we call "lineSegmentsIntersect" first
+ puts stderr "::math::geometry::findLineSegmentIntersection: suddenly no intersection?"
+ return "none"
+ }
+
+ default {
+ # lineintersect = the intersection point
+ return $lineintersect
+ }
+ }
+ } else {
+ return "none"
+ }
+}
+
+# ::math::geometry::findLineIntersection {line1 line2}
+#
+# Returns the intersection point of two lines.
+# Note: may also return "coincident" and "none".
+#
+# Arguments:
+# line1 the first line
+# line2 the second line
+#
+# Results:
+# P the intersection point of line1 and line2.
+# If line1 and line2 have an infinite number of points
+# in common, the procedure returns "coincident".
+# If there are no intersection points, the procedure
+# returns "none".
+#
+# Examples:
+# - findLineIntersection {0 0 10 10} {0 10 10 0}
+# Result: 5.0 5.0
+# - findLineIntersection {0 0 10 10} {20 20 20 30}
+# Result: 20.0 20.0
+# - findLineIntersection {0 0 10 10} {10 10 15 15}
+# Result: coincident
+# - findLineIntersection {0 0 10 10} {5 5 15 15}
+# Result: coincident
+# - findLineIntersection {0 0 10 10} {0 1 10 11}
+# Result: none
+#
+proc ::math::geometry::findLineIntersection {line1 line2} {
+
+ # References:
+ # http://wiki.tcl.tk/12070 (Kevin Kenny)
+ # http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/
+
+ set l1x1 [lindex $line1 0]
+ set l1y1 [lindex $line1 1]
+ set l1x2 [lindex $line1 2]
+ set l1y2 [lindex $line1 3]
+
+ set l2x1 [lindex $line2 0]
+ set l2y1 [lindex $line2 1]
+ set l2x2 [lindex $line2 2]
+ set l2y2 [lindex $line2 3]
+
+ set d [expr {($l2y2 - $l2y1) * ($l1x2 - $l1x1) -
+ ($l2x2 - $l2x1) * ($l1y2 - $l1y1)}]
+ set na [expr {($l2x2 - $l2x1) * ($l1y1 - $l2y1) -
+ ($l2y2 - $l2y1) * ($l1x1 - $l2x1)}]
+
+ # http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/
+ if {$d == 0} {
+ if {$na == 0} {
+ return "coincident"
+ } else {
+ return "none"
+ }
+ }
+ set r [list \
+ [expr {$l1x1 + $na * ($l1x2 - $l1x1) / $d}] \
+ [expr {$l1y1 + $na * ($l1y2 - $l1y1) / $d}]]
+ return $r
+}
+
+
+# ::math::geometry::polylinesIntersect
+#
+# Checks whether two polylines intersect.
+#
+# Arguments;
+# polyline1 the first polyline
+# polyline2 the second polyline
+#
+# Results:
+# dointersect a boolean saying whether the polylines intersect
+#
+# Examples:
+# - polylinesIntersect {0 0 10 10 10 20} {0 10 10 0}
+# Result: 1
+# - polylinesIntersect {0 0 10 10 10 20} {5 4 10 4}
+# Result: 0
+#
+proc ::math::geometry::polylinesIntersect {polyline1 polyline2} {
+ return [polylinesBoundingIntersect $polyline1 $polyline2 0]
+}
+
+# ::math::geometry::polylinesBoundingIntersect
+#
+# Check whether two polylines intersect, but reduce
+# the correctness of the result to the given granularity.
+# Use this for faster, but weaker, intersection checking.
+#
+# How it works:
+# Each polyline is split into a number of smaller polylines,
+# consisting of granularity points each. If a pair of those smaller
+# lines' bounding boxes intersect, then this procedure returns 1,
+# otherwise it returns 0.
+#
+# Arguments:
+# polyline1 the first polyline
+# polyline2 the second polyline
+# granularity the number of points in each part-polyline
+# granularity<=1 means full correctness
+#
+# Results:
+# dointersect a boolean saying whether the polylines intersect
+#
+# Examples:
+# - polylinesBoundingIntersect {0 0 10 10 10 20} {0 10 10 0} 2
+# Result: 1
+# - polylinesBoundingIntersect {0 0 10 10 10 20} {5 4 10 4} 2
+# Result: 1
+#
+proc ::math::geometry::polylinesBoundingIntersect {polyline1 polyline2 granularity} {
+ if {$granularity<=1} {
+ # Use perfect intersect
+ # => first pin down where an intersection point may be, and then
+ # call MultilinesIntersectPerfect on those parts
+ set granularity 10 ; # optimal search granularity?
+ set perfectmatch 1
+ } else {
+ set perfectmatch 0
+ }
+
+ # split the lines into parts consisting of $granularity points
+ set polyline1parts {}
+ for {set i 0} {$i<[llength $polyline1]} {incr i [expr {2*$granularity-2}]} {
+ lappend polyline1parts [lrange $polyline1 $i [expr {$i+2*$granularity-1}]]
+ }
+ set polyline2parts {}
+ for {set i 0} {$i<[llength $polyline2]} {incr i [expr {2*$granularity-2}]} {
+ lappend polyline2parts [lrange $polyline2 $i [expr {$i+2*$granularity-1}]]
+ }
+
+ # do any of the parts overlap?
+ foreach part1 $polyline1parts {
+ foreach part2 $polyline2parts {
+ set part1bbox [bbox $part1]
+ set part2bbox [bbox $part2]
+ if {[rectanglesOverlap [lrange $part1bbox 0 1] [lrange $part1bbox 2 3] \
+ [lrange $part2bbox 0 1] [lrange $part2bbox 2 3] 0]} {
+ # the lines' bounding boxes intersect
+ if {$perfectmatch} {
+ foreach {l1x1 l1y1} [lrange $part1 0 end-2] {l1x2 l1y2} [lrange $part1 2 end] {
+ foreach {l2x1 l2y1} [lrange $part2 0 end-2] {l2x2 l2y2} [lrange $part2 2 end] {
+ if {[lineSegmentsIntersect [list $l1x1 $l1y1 $l1x2 $l1y2] \
+ [list $l2x1 $l2y1 $l2x2 $l2y2]]} {
+ # two line segments overlap
+ return 1
+ }
+ }
+ }
+ return 0
+ } else {
+ return 1
+ }
+ }
+ }
+ }
+ return 0
+}
+
+# ::math::geometry::ccw
+#
+# PRIVATE FUNCTION USED BY OTHER FUNCTIONS.
+# Returns whether traversing from A to B to C is CounterClockWise
+# Algorithm by Sedgewick.
+#
+# Arguments:
+# A first point
+# B second point
+# C third point
+#
+# Reeults:
+# ccw a boolean saying whether traversing from A to B to C
+# is CounterClockWise
+#
+proc ::math::geometry::ccw {A B C} {
+ set Ax [lindex $A 0]
+ set Ay [lindex $A 1]
+ set Bx [lindex $B 0]
+ set By [lindex $B 1]
+ set Cx [lindex $C 0]
+ set Cy [lindex $C 1]
+ set dx1 [expr {$Bx - $Ax}]
+ set dy1 [expr {$By - $Ay}]
+ set dx2 [expr {$Cx - $Ax}]
+ set dy2 [expr {$Cy - $Ay}]
+ if {$dx1*$dy2 > $dy1*$dx2} {return 1}
+ if {$dx1*$dy2 < $dy1*$dx2} {return -1}
+ if {($dx1*$dx2 < 0) || ($dy1*$dy2 < 0)} {return -1}
+ if {($dx1*$dx1 + $dy1*$dy1) < ($dx2*$dx2+$dy2*$dy2)} {return 1}
+ return 0
+}
+
+
+
+
+
+
+
+###
+#
+# Overlap procedures
+#
+###
+
+# ::math::geometry::intervalsOverlap
+#
+# Check whether two intervals overlap.
+# Examples:
+# - (2,4) and (5,3) overlap with strict=0 and strict=1
+# - (2,4) and (1,2) overlap with strict=0 but not with strict=1
+#
+# Arguments:
+# y1,y2 the first interval
+# y3,y4 the second interval
+# strict choosing strict or non-strict interpretation
+#
+# Results:
+# dooverlap a boolean saying whether the intervals overlap
+#
+# Examples:
+# - intervalsOverlap 2 4 4 6 1
+# Result: 0
+# - intervalsOverlap 2 4 4 6 0
+# Result: 1
+# - intervalsOverlap 4 2 3 5 0
+# Result: 1
+#
+proc ::math::geometry::intervalsOverlap {y1 y2 y3 y4 strict} {
+ if {$y1>$y2} {
+ set temp $y1
+ set y1 $y2
+ set y2 $temp
+ }
+ if {$y3>$y4} {
+ set temp $y3
+ set y3 $y4
+ set y4 $temp
+ }
+ if {$strict} {
+ return [expr {$y2>$y3 && $y4>$y1}]
+ } else {
+ return [expr {$y2>=$y3 && $y4>=$y1}]
+ }
+}
+
+# ::math::geometry::rectanglesOverlap
+#
+# Check whether two rectangles overlap (see also intervalsOverlap).
+#
+# Arguments:
+# P1 upper-left corner of the first rectangle
+# P2 lower-right corner of the first rectangle
+# Q1 upper-left corner of the second rectangle
+# Q2 lower-right corner of the second rectangle
+# strict choosing strict or non-strict interpretation
+#
+# Results:
+# dooverlap a boolean saying whether the rectangles overlap
+#
+# Examples:
+# - rectanglesOverlap {0 10} {10 0} {10 10} {20 0} 1
+# Result: 0
+# - rectanglesOverlap {0 10} {10 0} {10 10} {20 0} 0
+# Result: 1
+#
+proc ::math::geometry::rectanglesOverlap {P1 P2 Q1 Q2 strict} {
+ set b1x1 [lindex $P1 0]
+ set b1y1 [lindex $P1 1]
+ set b1x2 [lindex $P2 0]
+ set b1y2 [lindex $P2 1]
+ set b2x1 [lindex $Q1 0]
+ set b2y1 [lindex $Q1 1]
+ set b2x2 [lindex $Q2 0]
+ set b2y2 [lindex $Q2 1]
+ # ensure b1x1<=b1x2 etc.
+ if {$b1x1 > $b1x2} {
+ set temp $b1x1
+ set b1x1 $b1x2
+ set b1x2 $temp
+ }
+ if {$b1y1 > $b1y2} {
+ set temp $b1y1
+ set b1y1 $b1y2
+ set b1y2 $temp
+ }
+ if {$b2x1 > $b2x2} {
+ set temp $b2x1
+ set b2x1 $b2x2
+ set b2x2 $temp
+ }
+ if {$b2y1 > $b2y2} {
+ set temp $b2y1
+ set b2y1 $b2y2
+ set b2y2 $temp
+ }
+ # Check if the boxes intersect
+ # (From: Cormen, Leiserson, and Rivests' "Algorithms", page 889)
+ if {$strict} {
+ return [expr {($b1x2>$b2x1) && ($b2x2>$b1x1) \
+ && ($b1y2>$b2y1) && ($b2y2>$b1y1)}]
+ } else {
+ return [expr {($b1x2>=$b2x1) && ($b2x2>=$b1x1) \
+ && ($b1y2>=$b2y1) && ($b2y2>=$b1y1)}]
+ }
+}
+
+
+
+# ::math::geometry::bbox
+#
+# Calculate the bounding box of a polyline.
+#
+# Arguments:
+# polyline a polyline
+#
+# Results:
+# x1,y1,x2,y2 four coordinates where (x1,y1) is the upper-left corner
+# of the bounding box, and (x2,y2) is the lower-right corner
+#
+# Examples:
+# - bbox {0 10 4 1 6 23 -12 5}
+# Result: -12 1 6 23
+#
+proc ::math::geometry::bbox {polyline} {
+ set minX [lindex $polyline 0]
+ set maxX $minX
+ set minY [lindex $polyline 1]
+ set maxY $minY
+ foreach {x y} $polyline {
+ if {$x < $minX} {set minX $x}
+ if {$x > $maxX} {set maxX $x}
+ if {$y < $minY} {set minY $y}
+ if {$y > $maxY} {set maxY $y}
+ }
+ return [list $minX $minY $maxX $maxY]
+}
+
+# ::math::geometry::ClosedPolygon
+#
+# Return a closed polygon - used internally
+#
+# Arguments:
+# polygon a polygon
+#
+# Results:
+# closedpolygon a polygon whose first and last vertices
+# coincide
+#
+proc ::math::geometry::ClosedPolygon {polygon} {
+
+ if { [lindex $polygon 0] != [lindex $polygon end-1] ||
+ [lindex $polygon 1] != [lindex $polygon end] } {
+
+ return [concat $polygon [lrange $polygon 0 1]]
+
+ } else {
+
+ return $polygon
+ }
+}
+
+
+# ::math::geometry::pointInsidePolygon
+#
+# Determine if a point is completely inside a polygon. If the point
+# touches the polygon, then the point is not complete inside the
+# polygon.
+#
+# Arguments:
+# P a point
+# polygon a polygon
+#
+# Results:
+# isinside a boolean saying whether the point is
+# completely inside the polygon or not
+#
+# Examples:
+# - pointInsidePolygon {5 5} {4 4 4 6 6 6 6 4}
+# Result: 1
+# - pointInsidePolygon {5 5} {6 6 6 7 7 7}
+# Result: 0
+#
+proc ::math::geometry::pointInsidePolygon {P polygon} {
+ # check if P is on one of the polygon's sides (if so, P is not
+ # inside the polygon)
+ set closedPolygon [ClosedPolygon $polygon]
+
+ foreach {x1 y1} [lrange $closedPolygon 0 end-2] {x2 y2} [lrange $closedPolygon 2 end] {
+ if {[calculateDistanceToLineSegment $P [list $x1 $y1 $x2 $y2]]<0.0000001} {
+ return 0
+ }
+ }
+
+ # Algorithm
+ #
+ # Consider a straight line going from P to a point far away from both
+ # P and the polygon (in particular outside the polygon).
+ # - If the line intersects with 0 of the polygon's sides, then
+ # P must be outside the polygon.
+ # - If the line intersects with 1 of the polygon's sides, then
+ # P must be inside the polygon (since the other end of the line
+ # is outside the polygon).
+ # - If the line intersects with 2 of the polygon's sides, then
+ # the line must pass into one polygon area and out of it again,
+ # and hence P is outside the polygon.
+ # - In general: if the line intersects with the polygon's sides an odd
+ # number of times, then P is inside the polygon. Note: we also have
+ # to check whether the line crosses one of the polygon's
+ # bend points for the same reason.
+
+ # get point far away and define the line
+ set polygonBbox [bbox $polygon]
+
+ set pointFarAway [list \
+ [expr {[lindex $polygonBbox 0]-[lindex $polygonBbox 2]}] \
+ [expr {[lindex $polygonBbox 1]-0.1*[lindex $polygonBbox 3]}]]
+
+ set infinityLine [concat $pointFarAway $P]
+
+ # calculate number of intersections
+ set noOfIntersections 0
+ # 1. count intersections between the line and the polygon's sides
+ foreach {x1 y1} [lrange $closedPolygon 0 end-2] {x2 y2} [lrange $closedPolygon 2 end] {
+ if {[lineSegmentsIntersect $infinityLine [list $x1 $y1 $x2 $y2]]} {
+ incr noOfIntersections
+ }
+ }
+ # 2. count intersections between the line and the polygon's points
+ foreach {x1 y1} $closedPolygon {
+ if {[calculateDistanceToLineSegment [list $x1 $y1] $infinityLine]<0.0000001} {
+ incr noOfIntersections
+ }
+ }
+ return [expr {$noOfIntersections % 2}]
+}
+
+
+# ::math::geometry::rectangleInsidePolygon
+#
+# Determine if a rectangle is completely inside a polygon. If polygon
+# touches the rectangle, then the rectangle is not complete inside the
+# polygon.
+#
+# Arguments:
+# P1 upper-left corner of the rectangle
+# P2 lower-right corner of the rectangle
+# polygon a polygon
+#
+# Results:
+# isinside a boolean saying whether the rectangle is
+# completely inside the polygon or not
+#
+# Examples:
+# - rectangleInsidePolygon {0 10} {10 0} {-10 -10 0 11 11 11 11 0}
+# Result: 1
+# - rectangleInsidePolygon {0 0} {0 0} {-16 14 5 -16 -16 -25 -21 16 -19 24}
+# Result: 1
+# - rectangleInsidePolygon {0 0} {0 0} {2 2 2 4 4 4 4 2}
+# Result: 0
+#
+proc ::math::geometry::rectangleInsidePolygon {P1 P2 polygon} {
+ # get coordinates of rectangle
+ set bx1 [lindex $P1 0]
+ set by1 [lindex $P1 1]
+ set bx2 [lindex $P2 0]
+ set by2 [lindex $P2 1]
+
+ # if rectangle does not overlap with the bbox of polygon, then the
+ # rectangle cannot be inside the polygon (this is a quick way to
+ # get an answer in many cases)
+ set polygonBbox [bbox $polygon]
+ set polygonP1x [lindex $polygonBbox 0]
+ set polygonP1y [lindex $polygonBbox 1]
+ set polygonP2x [lindex $polygonBbox 2]
+ set polygonP2y [lindex $polygonBbox 3]
+ if {![rectanglesOverlap [list $bx1 $by1] [list $bx2 $by2] \
+ [list $polygonP1x $polygonP1y] [list $polygonP2x $polygonP2y] 0]} {
+ return 0
+ }
+
+ # 1. if one of the points of the polygon is inside the rectangle,
+ # then the rectangle cannot be inside the polygon
+ foreach {x y} $polygon {
+ if {$bx1<$x && $x<$bx2 && $by1<$y && $y<$by2} {
+ return 0
+ }
+ }
+
+ # 2. if one of the line segments of the polygon intersect with the
+ # rectangle, then the rectangle cannot be inside the polygon
+ set rectanglePolyline [list $bx1 $by1 $bx2 $by1 $bx2 $by2 $bx1 $by2 $bx1 $by1]
+ set closedPolygon [ClosedPolygon $polygon]
+ if {[polylinesIntersect $closedPolygon $rectanglePolyline]} {
+ return 0
+ }
+
+ # at this point we know that:
+ # 1. the polygon has no points inside the rectangle
+ # 2. the polygon's sides don't intersect with the rectangle
+ # therefore:
+ # either the rectangle is (completely) inside the polygon, or
+ # the rectangle is (completely) outside the polygon
+
+ # final test: if one of the points on the rectangle is inside the
+ # polygon, then the whole rectangle must be inside the rectangle
+ return [pointInsidePolygon [list $bx1 $by1] $polygon]
+}
+
+
+# ::math::geometry::areaPolygon
+#
+# Determine the area enclosed by a (non-complex) polygon
+#
+# Arguments:
+# polygon a polygon
+#
+# Results:
+# area the area enclosed by the polygon
+#
+# Examples:
+# - areaPolygon {-10 -10 10 -10 10 10 -10 10}
+# Result: 400
+#
+proc ::math::geometry::areaPolygon {polygon} {
+
+ foreach {a1 a2 b1 b2} $polygon {break}
+
+ set area 0.0
+ foreach {c1 c2} [lrange $polygon 4 end] {
+ set area [expr {$area + $b1*$c2 - $b2*$c1}]
+ set b1 $c1
+ set b2 $c2
+ }
+ expr {0.5*abs($area)}
+}
+
+# # ## ### ##### #############
+
+namespace eval ::math::geometry {
+ variable pi [expr { 4 * atan(1) }]
+ variable torad [expr { (4 * atan(1)) / 180.0 }]
+ variable todeg [expr { 180.0 / (4 * atan(1)) }]
+
+ namespace export \
+ + - s* direction v h p between distance length \
+ nwse rect octant findLineSegmentIntersection \
+ findLineIntersection bbox x y conjx conjy
+}
+
+package provide math::geometry 1.1.3
diff --git a/tcllib/modules/math/geometry.test b/tcllib/modules/math/geometry.test
new file mode 100644
index 0000000..8fbfec9
--- /dev/null
+++ b/tcllib/modules/math/geometry.test
@@ -0,0 +1,520 @@
+# -*- tcl -*-
+# Tests for geometry library.
+#
+# Copyright (c) 2001 by Ideogramic ApS and other parties.
+# All rights reserved.
+#
+# RCS: @(#) $Id: geometry.test,v 1.13 2010/04/06 17:02:25 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+support {
+ useLocal math.tcl math
+}
+testing {
+ useLocal geometry.tcl math::geometry
+}
+
+# -------------------------------------------------------------------------
+
+proc withFourDecimals {args} {
+ set res {}
+ foreach arg $args {lappend res [expr (round(10000*$arg))/10000.0]}
+ return $res
+}
+
+# -------------------------------------------------------------------------
+
+###
+# calculateDistanceToLine
+###
+test geometry-1.1 {geometry::calculateDistanceToLine, simple} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLine {6 4} {1 1 7 1}]
+} 3.0
+test geometry-1.2 {geometry::calculateDistanceToLine, on line segment} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLine {3 2} {1 1 5 3}]
+} 0.0
+test geometry-1.3 {geometry::calculateDistanceToLine, on first end} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLine {1 1} {1 1 7 1}]
+} 0.0
+test geometry-1.4 {geometry::calculateDistanceToLine, on second end} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLine {7 1} {1 1 7 1}]
+} 0.0
+test geometry-1.5 {geometry::calculateDistanceToLine, not on line segment, between line segment ends} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLine {3 1} {1 1 7 3}]
+} 0.6325
+test geometry-1.6 {geometry::calculateDistanceToLine, not on infinite line, beyond first line segment end} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLine {0 -2} {1 1 7 3}]
+} 2.5298
+test geometry-1.7 {geometry::calculateDistanceToLine, not on infinite line, beyond second line segment end} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLine {10 2} {1 1 7 3}]
+} 1.8974
+test geometry-1.8 {geometry::calculateDistanceToLine, on infinite line, beyond first line segment end} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLine {-1 0} {1 1 5 3}]
+} 0.0
+test geometry-1.9 {geometry::calculateDistanceToLine, on infinite line, beyond second line segment end} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLine {9 5} {1 1 5 3}]
+} 0.0
+
+
+###
+# calculateDistanceToLineSegment
+###
+test geometry-2.1 {geometry::calculateDistanceToLineSegment, simple} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {6 4} {1 1 7 1}]
+} 3.0
+test geometry-2.2 {geometry::calculateDistanceToLineSegment, on linesegment} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {3 2} {1 1 5 3}]
+} 0.0
+test geometry-2.3 {geometry::calculateDistanceToLineSegment, on first end} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {1 1} {1 1 7 1}]
+} 0.0
+test geometry-2.4 {geometry::calculateDistanceToLineSegment, on second end} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {7 1} {1 1 7 1}]
+} 0.0
+test geometry-2.5 {geometry::calculateDistanceToLineSegment, not on linesegment, between linesegment ends} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {3 1} {1 1 7 3}]
+} 0.6325
+test geometry-2.6 {geometry::calculateDistanceToLineSegment, not on infinite line, beyond first line segment end} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {0 -2} {1 1 7 3}]
+} 3.1623
+test geometry-2.7 {geometry::calculateDistanceToLineSegment, not on infinite line, beyond second line segment end} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {10 2} {1 1 7 3}]
+} 3.1623
+test geometry-2.8 {geometry::calculateDistanceToLineSegment, on infinite line, beyond first line segment end} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {-1 0} {1 1 5 3}]
+} 2.2361
+test geometry-2.9 {geometry::calculateDistanceToLineSegment, on infinite line, beyond second line segment end} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToLineSegment {9 5} {1 1 5 3}]
+} 4.4721
+
+
+###
+# findClosestPointOnLine
+###
+test geometry-3.1 {geometry::findClosestPointOnLine, between end points} {
+ eval withFourDecimals [::math::geometry::findClosestPointOnLine {5 10} {0 0 10 10}]
+} {7.5 7.5}
+test geometry-3.2 {geometry::findClosestPointOnLine, before first point} {
+ eval withFourDecimals [::math::geometry::findClosestPointOnLine {-10 0} {0 0 10 10}]
+} {-5.0 -5.0}
+
+
+###
+# findClosestPointOnLineSegment
+###
+
+
+###
+# findClosestPointOnPolyline
+###
+test geometry-5.1 {geometry::findClosestPointOnPolyline, one linesegment} {
+ eval withFourDecimals [::math::geometry::findClosestPointOnPolyline {6 4} {1 1 7 1}]
+} {6.0 1.0}
+test geometry-5.2 {geometry::findClosestPointOnPolyline, two linesegments} {
+ eval withFourDecimals [::math::geometry::findClosestPointOnPolyline {5 5} {1 1 1 5 14 10}]
+} {4.4845 6.3402}
+test geometry-5.3 {geometry::findClosestPointOnPolyline, point lies on a linesegment} {
+ eval withFourDecimals [::math::geometry::findClosestPointOnPolyline {5 5} {1 1 8 8}]
+} {5.0 5.0}
+
+
+###
+# calculateDistanceToPolyline
+###
+test geometry-6.1 {geometry::calculateDistanceToPolyline, one line segment} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {6 4} {4 6 1 2}]
+} 2.8
+test geometry-6.2 {geometry::calculateDistanceToPolyline, two line segments} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {6 9} {4 6 1 2 4 12}]
+} 2.7777
+test geometry-6.3 {geometry::calculateDistanceToPolyline, three line segments} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {6 4} {4 6 1 2 10 8 12 4}]
+} 1.1094
+test geometry-6.4 {geometry::calculateDistanceToPolyline, on first point} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {4 6} {4 6 1 2 5 1}]
+} 0.0
+test geometry-6.5 {geometry::calculateDistanceToPolyline, on second point} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {1 2} {4 6 1 2 5 1}]
+} 0.0
+test geometry-6.6 {geometry::calculateDistanceToPolyline, on third point} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {5 1} {4 6 1 2 5 1}]
+} 0.0
+test geometry-6.7 {geometry::calculateDistanceToPolyline, on first line segment} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {2 2} {4 6 1 0 5 4}]
+} 0.0
+test geometry-6.8 {geometry::calculateDistanceToPolyline, on second line segment} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToPolyline {3 2} {4 6 1 0 5 4}]
+} 0.0
+
+
+###
+# lineSegmentsIntersect
+###
+test geometry-7.1 {geometry::lineSegmentsIntersect, } {
+ ::math::geometry::lineSegmentsIntersect {0 0 10 10} {0 10 10 0}
+} 1
+
+
+
+###
+# polylinesIntersect
+###
+test geometry-8.1 {geometry::polylinesIntersect, } {
+ ::math::geometry::polylinesIntersect {0 0 0 2 10 10} {0 10 2 10 10 0}
+} 1
+
+
+
+
+###
+# findLineIntersection
+###
+test geometry-9.1 {geometry::findLineIntersection, first line vertical} {
+ eval withFourDecimals [::math::geometry::findLineIntersection {7 8 7 28} {3 14 17 21}]
+} {7.0 16.0}
+test geometry-9.2 {geometry::findLineIntersection, second line vertical} {
+ eval withFourDecimals [::math::geometry::findLineIntersection {3 14 17 21} {7 8 7 28}]
+} {7.0 16.0}
+test geometry-9.3 {geometry::findLineIntersection, both lines vertical - coincident} {
+ ::math::geometry::findLineIntersection {7 8 7 28} {7 14 7 21}
+} "coincident"
+test geometry-9.4 {geometry::findLineIntersection, both lines vertical - no intersection} {
+ ::math::geometry::findLineIntersection {7 8 7 28} {8 14 8 21}
+} "none"
+test geometry-9.5 {geometry::findLineIntersection, first line horizontal} {
+ eval withFourDecimals [::math::geometry::findLineIntersection {2 3 10 3} {4 5 7 2}]
+} {6.0 3.0}
+test geometry-9.6 {geometry::findLineIntersection, second line horizontal} {
+ eval withFourDecimals [::math::geometry::findLineIntersection {4 5 7 2} {2 3 10 3}]
+} {6.0 3.0}
+test geometry-9.7 {geometry::findLineIntersection, both lines horizontal - coincident} {
+ ::math::geometry::findLineIntersection {8 7 28 7} {14 7 21 7}
+} "coincident"
+test geometry-9.8 {geometry::findLineIntersection, both lines horizontal - no intersection} {
+ ::math::geometry::findLineIntersection {8 7 28 7} {14 8 21 8}
+} "none"
+test geometry-9.9 {geometry::findLineIntersection, both lines skaeve - with intersection} {
+ eval withFourDecimals [::math::geometry::findLineIntersection {3 2 9 4} {4 5 7 2}]
+} {6.0 3.0}
+test geometry-9.10 {geometry::findLineIntersection, both lines skaeve - coincident} {
+ ::math::geometry::findLineIntersection {3 2 9 4} {6 3 12 5}
+} "coincident"
+test geometry-9.11 {geometry::findLineIntersection, both lines skaeve - no intersection} {
+ ::math::geometry::findLineIntersection {3 2 9 4} {3 12 9 14}
+} "none"
+
+test geometry-9.12 {geometry::findLineIntersection, vertical} {
+ eval withFourDecimals [::math::geometry::findLineIntersection {110.0 130.0 110.0 30.0} {180.0 200.0 280.0 200.0}]
+} {110.0 200.0}
+
+test geometry-9.13 {geometry::findLineIntersection, vertical, ints} {
+ eval withFourDecimals [::math::geometry::findLineIntersection {110 130 110 30} {180 200 280 200}]
+} {110.0 200.0}
+
+test geometry-9.14 {geometry::findLineIntersection, very near vertical, flipped direction} {
+ # This test checks the numerical stability of the algorithm
+ eval withFourDecimals [::math::geometry::findLineIntersection {110.0 130.0 109.99999999999999 230.0} {180.0 200.0 280.0 200.0}]
+} {110.0 200.0}
+
+test geometry-9.15 {geometry::findLineIntersection, vertical, flipped direction} {
+ eval withFourDecimals [::math::geometry::findLineIntersection {110 130 110 230} {180 200 280 200}]
+} {110.0 200.0}
+
+
+
+
+###
+# findLineSegmentIntersection
+###
+test geometry-10.1 {geometry::findLineSegmentIntersection, both lines vertical - no overlap} {
+ ::math::geometry::findLineSegmentIntersection {1 1 1 2} {1 3 1 4}
+} "none"
+test geometry-10.2 {geometry::findLineSegmentIntersection, both lines vertical - with overlap} {
+ ::math::geometry::findLineSegmentIntersection {1 1 1 2} {1 1.5 1 19}
+} "coincident"
+test geometry-10.3 {geometry::findLineSegmentIntersection, both lines skaeve - with intersection} {
+ eval withFourDecimals [::math::geometry::findLineSegmentIntersection {3 2 9 4} {4 5 7 2}]
+} {6.0 3.0}
+test geometry-10.4 {geometry::findLineSegmentIntersection, both lines skaeve - coincident} {
+ ::math::geometry::findLineSegmentIntersection {3 2 9 4} {6 3 12 5}
+} "coincident"
+test geometry-10.5 {geometry::findLineSegmentIntersection, both lines skaeve - parallel but not coincident} {
+ ::math::geometry::findLineSegmentIntersection {3 2 6 3} {9 4 12 5}
+} "none"
+test geometry-10.6 {geometry::findLineSegmentIntersection, both lines skaeve - no intersection} {
+ ::math::geometry::findLineSegmentIntersection {3 2 9 4} {4 5 5 4}
+} "none"
+
+
+###
+# movePointInDirection
+###
+test geometry-11.1 {geometry::movePointInDirection, going up} {
+ eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 90 1]
+} {0.0 1.0}
+test geometry-11.2 {geometry::movePointInDirection, going up 2} {
+ eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 90 5.7]
+} {0.0 5.7}
+test geometry-11.3 {geometry::movePointInDirection, going down} {
+ eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 270 5.7]
+} {0.0 -5.7}
+test geometry-11.4 {geometry::movePointInDirection, going left} {
+ eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 180 5.7]
+} {-5.7 0.0}
+test geometry-11.5 {geometry::movePointInDirection, going right} {
+ eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 0 5.7]
+} {5.7 0.0}
+test geometry-11.6 {geometry::movePointInDirection, going up and right} {
+ eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 45 5.7]
+} {4.0305 4.0305}
+test geometry-11.7 {geometry::movePointInDirection, going up and left} {
+ eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 135 5.7]
+} {-4.0305 4.0305}
+test geometry-11.8 {geometry::movePointInDirection, (3,4,5)-triangle} {
+ set pi [expr 4*atan(1)]
+ set angleInRadians [expr asin(0.6)]
+ set angleInDegrees [expr $angleInRadians/$pi*180]
+ eval withFourDecimals [::math::geometry::movePointInDirection {0 0} $angleInDegrees 5]
+} {4.0 3.0}
+test geometry-11.9 {geometry::movePointInDirection, going up and left from (3,6)} {
+ eval withFourDecimals [::math::geometry::movePointInDirection {3 6} 135 5.7]
+} {-1.0305 10.0305}
+test geometry-11.10 {geometry::movePointInDirection, negative angle} {
+ eval withFourDecimals [::math::geometry::movePointInDirection {0 0} -90 5.7]
+} {0.0 -5.7}
+test geometry-11.11 {geometry::movePointInDirection, negative angle 2} {
+ eval withFourDecimals [::math::geometry::movePointInDirection {0 0} -135 5.7]
+} {-4.0305 -4.0305}
+test geometry-11.12 {geometry::movePointInDirection, big angle (>360)} {
+ eval withFourDecimals [::math::geometry::movePointInDirection {0 0} 450 5.7]
+} {0.0 5.7}
+
+
+###
+# Angle
+###
+test geometry-12.1 {geometry::angle, going right} {
+ withFourDecimals [::math::geometry::angle {0 0 10 0}]
+} 0.0
+test geometry-12.2 {geometry::angle, going up} {
+ withFourDecimals [::math::geometry::angle {0 0 0 10}]
+} 90.0
+test geometry-12.3 {geometry::angle, going left} {
+ withFourDecimals [::math::geometry::angle {0 0 -10 0}]
+} 180.0
+test geometry-12.4 {geometry::angle, going down} {
+ withFourDecimals [::math::geometry::angle {0 0 0 -10}]
+} 270.0
+test geometry-12.5 {geometry::angle, going up and right} {
+ withFourDecimals [::math::geometry::angle {0 0 10 10}]
+} 45.0
+test geometry-12.6 {geometry::angle, going up and left} {
+ withFourDecimals [::math::geometry::angle {0 0 -10 10}]
+} 135.0
+test geometry-12.7 {geometry::angle, going down and left} {
+ withFourDecimals [::math::geometry::angle {0 0 -10 -10}]
+} 225.0
+test geometry-12.8 {geometry::angle, going down and right} {
+ withFourDecimals [::math::geometry::angle {0 0 10 -10}]
+} 315.0
+test geometry-12.9 {geometry::angle, going up and right from (3,6)} {
+ withFourDecimals [::math::geometry::angle {3 6 10 9}]
+} 23.1986
+
+
+###
+# intervalsOverlap
+###
+test geometry-13.1 {geometry::intervalsOverlap, strict, overlap} {
+ math::geometry::intervalsOverlap 2 4 3 6 1
+} 1
+test geometry-13.2 {geometry::intervalsOverlap, strict, no overlap} {
+ math::geometry::intervalsOverlap 2 4 4 6 1
+} 0
+test geometry-13.3 {geometry::intervalsOverlap, not strict, overlap} {
+ math::geometry::intervalsOverlap 2 4 3 6 0
+} 1
+test geometry-13.4 {geometry::intervalsOverlap, not strict, no overlap} {
+ math::geometry::intervalsOverlap 2 4 5 6 0
+} 0
+test geometry-13.5 {geometry::intervalsOverlap, first interval wrong order} {
+ math::geometry::intervalsOverlap 4 2 3 5 0
+} 1
+test geometry-13.6 {geometry::intervalsOverlap, second interval wrong order} {
+ math::geometry::intervalsOverlap 2 4 5 3 0
+} 1
+test geometry-13.7 {geometry::intervalsOverlap, both interval wrong order} {
+ math::geometry::intervalsOverlap 4 2 5 3 0
+} 1
+
+
+###
+# rectanglesOverlap
+###
+test geometry-14.1 {geometry::rectanglesOverlap, strict, overlap} {
+ math::geometry::rectanglesOverlap {0 10} {10 0} {5 10} {20 0} 1
+} 1
+test geometry-14.2 {geometry::rectanglesOverlap, strict, no overlap} {
+ math::geometry::rectanglesOverlap {0 10} {10 0} {10 10} {20 0} 1
+} 0
+test geometry-14.3 {geometry::rectanglesOverlap, not strict, overlap} {
+ math::geometry::rectanglesOverlap {0 10} {10 0} {5 10} {20 0} 0
+} 1
+test geometry-14.4 {geometry::rectanglesOverlap, not strict, no overlap} {
+ math::geometry::rectanglesOverlap {0 10} {10 0} {12 10} {20 0} 0
+} 0
+
+
+###
+# pointInsidePolygon
+###
+test geometry-15.1 {geometry::pointInsidePolygon, simple inside} {
+ math::geometry::pointInsidePolygon {5 5} {4 4 4 6 6 6 6 4}
+} 1
+test geometry-15.2 {geometry::pointInsidePolygon, simple not inside} {
+ math::geometry::pointInsidePolygon {5 5} {6 6 6 7 7 7}
+} 0
+test geometry-15.3 {geometry::pointInsidePolygon, point on polygon's sides} {
+ math::geometry::pointInsidePolygon {5 5} {5 4 5 6 7 7}
+} 0
+test geometry-15.4 {geometry::pointInsidePolygon, point identical with one of polygon's points} {
+ math::geometry::pointInsidePolygon {5 5} {5 4 5 5 7 7}
+} 0
+test geometry-15.5 {geometry::pointInsidePolygon, point not in polygon's bbox} {
+ math::geometry::pointInsidePolygon {5 5} {8 8 8 9 9 9 9 8}
+} 0
+test geometry-15.6 {geometry::pointInsidePolygon, hour-glass with center on point} {
+ math::geometry::pointInsidePolygon {5 5} {4 4 6 6 6 4 4 6}
+} 0
+test geometry-15.7 {geometry::pointInsidePolygon, hour-glass with point inside one of the areas} {
+ math::geometry::pointInsidePolygon {5 5} {3 2 5 11 3 11 11 6}
+} 1
+test geometry-15.8 {geometry::pointInsidePolygon, hour-glass with point on left side} {
+ math::geometry::pointInsidePolygon {5 5} {4 1 8 8 6 8 8 1}
+} 0
+test geometry-15.9 {geometry::pointInsidePolygon, hour-glass with point on right side} {
+ math::geometry::pointInsidePolygon {5 5} {2 4 6 9 2 9 5 4}
+} 0
+test geometry-15.10 {geometry::pointInsidePolygon, infinityLine crosses point instead of line segment} {
+ math::geometry::pointInsidePolygon {5 5} {4 4 4 7 7 7 7 4}
+} 1
+test geometry-15.11 {geometry::pointInsidePolygon, polygon already closed} {
+ math::geometry::pointInsidePolygon {5 5} {4 4 4 6 6 6 6 4 4 4}
+} 1
+test geometry-15.12 {geometry::pointInsidePolygon, polygon with zero-length side} {
+ math::geometry::pointInsidePolygon {5 5} {4 4 4 6 6 6 6 6 6 4}
+} 1
+test geometry-15.13 {geometry::pointInsidePolygon, edge case polygon/point, ticket c1ca34ead3} {
+ math::geometry::pointInsidePolygon {3.0 -1.5} {2.0 2.0 -2.0 2.0 -2.0 -2.0 2.0 -2.0}
+} 0
+
+
+###
+# rectangleInsidePolygon
+###
+test geometry-16.1 {geometry::rectangleInsidePolygon, simple} {
+ math::geometry::rectangleInsidePolygon {0 10} {10 0} {-10 -10 0 11 11 11 11 0}
+} 1
+test geometry-16.2 {geometry::rectangleInsidePolygon, rectangle and polygon identical} {
+ math::geometry::rectangleInsidePolygon {5 5} {7 7} {5 5 5 7 7 7 7 5}
+} 0
+test geometry-16.3 {geometry::rectangleInsidePolygon, bboxes don't overlap} {
+ math::geometry::rectangleInsidePolygon {5 5} {7 7} {8 8 8 9 9 9 9 8}
+} 0
+test geometry-16.4 {geometry::rectangleInsidePolygon, polygon point is inside the rectangle} {
+ math::geometry::rectangleInsidePolygon {5 5} {7 7} {4 4 4 8 6 6}
+} 0
+test geometry-16.5 {geometry::rectangleInsidePolygon, hour-glass with center inside rectangle} {
+ math::geometry::rectangleInsidePolygon {5 5} {7 7} {5 3 7 9 5 9 7 3}
+} 0
+test geometry-16.6 {geometry::rectangleInsidePolygon, hour-glass with rectangle inside one of the areas} {
+ math::geometry::rectangleInsidePolygon {5 5} {7 7} {3 2 5 11 3 11 11 6}
+} 1
+test geometry-16.7 {geometry::rectangleInsidePolygon, hour-glass with rectangle on left side} {
+ math::geometry::rectangleInsidePolygon {5 5} {6 6} {4 1 8 8 6 8 8 1}
+} 0
+test geometry-16.8 {geometry::rectangleInsidePolygon, hour-glass with rectangle on right side} {
+ math::geometry::rectangleInsidePolygon {5 5} {6 6} {2 4 6 9 2 9 5 4}
+} 0
+test geometry-16.9 {geometry::rectangleInsidePolygon, infinityLine crosses point instead of line segment} {
+ math::geometry::rectangleInsidePolygon {5 5} {6 6} {4 4 4 7 7 7 7 4}
+} 1
+
+###
+###
+
+test geometry-17.0 {point constructor} {
+ math::geometry::p 1 4
+} {1 4}
+
+test geometry-17.1 {vector addition} {
+ math::geometry::+ {1 4} {5 3}
+} {6 7}
+
+test geometry-17.2 {vector difference} {
+ math::geometry::- {6 7} {5 3}
+} {1 4}
+
+test geometry-17.3 {vector distance} {
+ withFourDecimals [math::geometry::distance {6 7} {5 3}]
+} 4.1231
+
+test geometry-17.4 {vector length} {
+ withFourDecimals [math::geometry::length {1 1}]
+} 1.4142
+
+test geometry-17.5 {vector scale} {
+ math::geometry::s* 5 {1 1}
+} {5 5}
+
+test geometry-17.6 {vector direction} {
+ eval withFourDecimals [math::geometry::direction 0]
+} {1.0 0.0}
+
+test geometry-17.7 {vector direction} {
+ eval withFourDecimals [math::geometry::direction 90]
+} {0.0 -1.0}
+
+test geometry-17.8 {vector vertical} {
+ math::geometry::v 90
+} {0 90}
+
+test geometry-17.9 {vector horizontal} {
+ math::geometry::h 90
+} {90 0}
+
+test geometry-17.10 {point between} {
+ math::geometry::between {0 0} {4 4} 0
+} {0 0}
+
+test geometry-17.11 {point between} {
+ math::geometry::between {0 0} {4 4} 1
+} {4 4}
+
+test geometry-17.12 {point between} {
+ math::geometry::between {0 0} {4 4} 0.5
+} {2.0 2.0}
+
+test geometry-17.13 {octant} {
+ math::geometry::octant {-10 -12}
+} northwest
+
+
+###
+# calculateDistanceToPolygon
+###
+test geometry-18.1 {geometry::calculateDistanceToPolygon, non-closed polygon, point on polygon} {
+ eval withFourDecimals [::math::geometry::calculateDistanceToPolygon {2.0 0.5} {2.0 2.0 -2.0 2.0 -2.0 -2.0 2.0 -2.0}]
+} 0.0
+
+
+###
+testsuiteCleanup
diff --git a/tcllib/modules/math/interpolate.man b/tcllib/modules/math/interpolate.man
new file mode 100755
index 0000000..f104e5d
--- /dev/null
+++ b/tcllib/modules/math/interpolate.man
@@ -0,0 +1,299 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin math::interpolate n 1.1]
+[keywords interpolation]
+[keywords math]
+[keywords {spatial interpolation}]
+[copyright {2004 Arjen Markus <arjenmarkus@users.sourceforge.net>}]
+[copyright {2004 Kevn B. Kenny <kennykb@users.sourceforge.net>}]
+[moddesc {Tcl Math Library}]
+[titledesc {Interpolation routines}]
+[category Mathematics]
+[require Tcl [opt 8.4]]
+[require struct]
+[require math::interpolate [opt 1.1]]
+
+[description]
+[para]
+This package implements several interpolation algorithms:
+
+[list_begin itemized]
+[item]
+Interpolation into a table (one or two independent variables), this is useful
+for example, if the data are static, like with tables of statistical functions.
+
+[item]
+Linear interpolation into a given set of data (organised as (x,y) pairs).
+
+[item]
+Lagrange interpolation. This is mainly of theoretical interest, because there is
+no guarantee about error bounds. One possible use: if you need a line or
+a parabola through given points (it will calculate the values, but not return
+the coefficients).
+[para]
+A variation is Neville's method which has better behaviour and error
+bounds.
+
+[item]
+Spatial interpolation using a straightforward distance-weight method. This procedure
+allows any number of spatial dimensions and any number of dependent variables.
+
+[item]
+Interpolation in one dimension using cubic splines.
+
+[list_end]
+
+[para]
+This document describes the procedures and explains their usage.
+
+[section "INCOMPATIBILITY WITH VERSION 1.0.3"]
+
+The interpretation of the tables in the [cmd ::math::interpolate::interpolate-1d-table] command
+has been changed to be compatible with the interpretation for 2D interpolation in
+the [cmd ::math::interpolate::interpolate-table] command. As a consequence this version is
+incompatible with the previous versions of the command (1.0.x).
+
+[section "PROCEDURES"]
+
+The interpolation package defines the following public procedures:
+
+[list_begin definitions]
+
+[call [cmd ::math::interpolate::defineTable] [arg name] [arg colnames] [arg values]]
+
+Define a table with one or two independent variables (the distinction is implicit in
+the data). The procedure returns the name of the table - this name is used whenever you
+want to interpolate the values. [emph Note:] this procedure is a convenient wrapper for the
+struct::matrix procedure. Therefore you can access the data at any location in your program.
+
+[list_begin arguments]
+[arg_def string name in] Name of the table to be created
+
+[arg_def list colnames in] List of column names
+
+[arg_def list values in] List of values (the number of elements should be a
+multiple of the number of columns. See [sectref EXAMPLES] for more information on the
+interpretation of the data.
+
+[para]
+The values must be sorted with respect to the independent variable(s).
+
+[list_end]
+[para]
+
+[call [cmd ::math::interpolate::interp-1d-table] [arg name] [arg xval]]
+
+Interpolate into the one-dimensional table "name" and return a list of values, one for
+each dependent column.
+
+[list_begin arguments]
+[arg_def string name in] Name of an existing table
+
+[arg_def float xval in] Value of the independent [emph row] variable
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::interpolate::interp-table] [arg name] [arg xval] [arg yval]]
+
+Interpolate into the two-dimensional table "name" and return the interpolated value.
+
+[list_begin arguments]
+[arg_def string name in] Name of an existing table
+
+[arg_def float xval in] Value of the independent [emph row] variable
+
+[arg_def float yval in] Value of the independent [emph column] variable
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::interpolate::interp-linear] [arg xyvalues] [arg xval]]
+
+Interpolate linearly into the list of x,y pairs and return the interpolated value.
+
+[list_begin arguments]
+
+[arg_def list xyvalues in] List of pairs of (x,y) values, sorted to increasing x.
+They are used as the breakpoints of a piecewise linear function.
+
+[arg_def float xval in] Value of the independent variable for which the value of y
+must be computed.
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::interpolate::interp-lagrange] [arg xyvalues] [arg xval]]
+
+Use the list of x,y pairs to construct the unique polynomial of lowest degree
+that passes through all points and return the interpolated value.
+
+[list_begin arguments]
+
+[arg_def list xyvalues in] List of pairs of (x,y) values
+
+[arg_def float xval in] Value of the independent variable for which the value of y
+must be computed.
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::interpolate::prepare-cubic-splines] [arg xcoord] [arg ycoord]]
+
+Returns a list of coefficients for the second routine
+[emph interp-cubic-splines] to actually interpolate.
+
+[list_begin arguments]
+[arg_def list xcoord] List of x-coordinates for the value of the
+function to be interpolated is known. The coordinates must be strictly
+ascending. At least three points are required.
+
+[arg_def list ycoord] List of y-coordinates (the values of the
+function at the given x-coordinates).
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::interpolate::interp-cubic-splines] [arg coeffs] [arg x]]
+
+Returns the interpolated value at coordinate x. The coefficients are
+computed by the procedure [emph prepare-cubic-splines].
+
+[list_begin arguments]
+[arg_def list coeffs] List of coefficients as returned by
+prepare-cubic-splines
+
+[arg_def float x] x-coordinate at which to estimate the function. Must
+be between the first and last x-coordinate for which values were given.
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::interpolate::interp-spatial] [arg xyvalues] [arg coord]]
+
+Use a straightforward interpolation method with weights as function of the
+inverse distance to interpolate in 2D and N-dimensional space
+
+[para]
+The list xyvalues is a list of lists:
+[example {
+ { {x1 y1 z1 {v11 v12 v13 v14}}
+ {x2 y2 z2 {v21 v22 v23 v24}}
+ ...
+ }
+}]
+The last element of each inner list is either a single number or a list in itself.
+In the latter case the return value is a list with the same number of elements.
+
+[para]
+The method is influenced by the search radius and the power of the inverse distance
+
+[list_begin arguments]
+[arg_def list xyvalues in] List of lists, each sublist being a list of coordinates and
+of dependent values.
+
+[arg_def list coord in] List of coordinates for which the values must be calculated
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::interpolate::interp-spatial-params] [arg max_search] [arg power]]
+
+Set the parameters for spatial interpolation
+
+[list_begin arguments]
+[arg_def float max_search in] Search radius (data points further than this are ignored)
+
+[arg_def integer power in] Power for the distance (either 1 or 2; defaults to 2)
+
+[list_end]
+
+[call [cmd ::math::interpolate::neville] [arg xlist] [arg ylist] [arg x]]
+
+Interpolates between the tabulated values of a function
+whose abscissae are [arg xlist]
+and whose ordinates are [arg ylist] to produce an estimate for the value
+of the function at [arg x]. The result is a two-element list; the first
+element is the function's estimated value, and the second is an estimate
+of the absolute error of the result. Neville's algorithm for polynomial
+interpolation is used. Note that a large table of values will use an
+interpolating polynomial of high degree, which is likely to result in
+numerical instabilities; one is better off using only a few tabulated
+values near the desired abscissa.
+
+[list_end]
+
+[section EXAMPLES]
+
+[emph "Example of using one-dimensional tables:"]
+[para]
+Suppose you have several tabulated functions of one variable:
+[example {
+ x y1 y2
+ 0.0 0.0 0.0
+ 1.0 1.0 1.0
+ 2.0 4.0 8.0
+ 3.0 9.0 27.0
+ 4.0 16.0 64.0
+}]
+Then to estimate the values at 0.5, 1.5, 2.5 and 3.5, you can use:
+[example {
+ set table [::math::interpolate::defineTable table1 \
+ {x y1 y2} { - 1 2
+ 0.0 0.0 0.0
+ 1.0 1.0 1.0
+ 2.0 4.0 8.0
+ 3.0 9.0 27.0
+ 4.0 16.0 64.0}]
+ foreach x {0.5 1.5 2.5 3.5} {
+ puts "$x: [::math::interpolate::interp-1d-table $table $x]"
+ }
+}]
+For one-dimensional tables the first row is not used. For two-dimensional
+tables, the first row represents the values for the second independent variable.
+[para]
+
+[emph "Example of using the cubic splines:"]
+[para]
+Suppose the following values are given:
+[example {
+ x y
+ 0.1 1.0
+ 0.3 2.1
+ 0.4 2.2
+ 0.8 4.11
+ 1.0 4.12
+}]
+Then to estimate the values at 0.1, 0.2, 0.3, ... 1.0, you can use:
+[example {
+ set coeffs [::math::interpolate::prepare-cubic-splines \
+ {0.1 0.3 0.4 0.8 1.0} \
+ {1.0 2.1 2.2 4.11 4.12}]
+ foreach x {0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0} {
+ puts "$x: [::math::interpolate::interp-cubic-splines $coeffs $x]"
+ }
+}]
+to get the following output:
+[example {
+0.1: 1.0
+0.2: 1.68044117647
+0.3: 2.1
+0.4: 2.2
+0.5: 3.11221507353
+0.6: 4.25242647059
+0.7: 5.41804227941
+0.8: 4.11
+0.9: 3.95675857843
+1.0: 4.12
+}]
+As you can see, the values at the abscissae are reproduced perfectly.
+
+[vset CATEGORY {math :: interpolate}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/interpolate.tcl b/tcllib/modules/math/interpolate.tcl
new file mode 100755
index 0000000..871c012
--- /dev/null
+++ b/tcllib/modules/math/interpolate.tcl
@@ -0,0 +1,667 @@
+# interpolate.tcl --
+#
+# Package for interpolation methods (one- and two-dimensional)
+#
+# Remarks:
+# None of the methods deal gracefully with missing values
+#
+# To do:
+# Add B-splines as methods
+# For spatial interpolation in two dimensions also quadrant method?
+# Method for destroying a table
+# Proper documentation
+# Proper test cases
+#
+# version 0.1: initial implementation, january 2003
+# version 0.2: added linear and Lagrange interpolation, straightforward
+# spatial interpolation, april 2004
+# version 0.3: added Neville algorithm.
+# version 1.0: added cubic splines, september 2004
+#
+# Copyright (c) 2004 by Arjen Markus. All rights reserved.
+# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: interpolate.tcl,v 1.10 2009/10/22 18:19:52 arjenmarkus Exp $
+#
+#----------------------------------------------------------------------
+
+package require Tcl 8.4
+package require struct::matrix
+
+# ::math::interpolate --
+# Namespace holding the procedures and variables
+#
+
+namespace eval ::math::interpolate {
+ variable search_radius {}
+ variable inv_dist_pow 2
+
+ namespace export interp-1d-table interp-table interp-linear \
+ interp-lagrange
+ namespace export neville
+}
+
+# defineTable --
+# Define a two-dimensional table of data
+#
+# Arguments:
+# name Name of the table to be created
+# cols Names of the columns (for convenience and for counting)
+# values List of values to fill the table with (must be sorted
+# w.r.t. first column or first column and first row)
+#
+# Results:
+# Name of the new command
+#
+# Side effects:
+# Creates a new command, which is used in subsequent calls
+#
+proc ::math::interpolate::defineTable { name cols values } {
+
+ set table ::math::interpolate::__$name
+ ::struct::matrix $table
+
+ $table add columns [llength $cols]
+ $table add row
+ $table set row 0 $cols
+
+ set row 1
+ set first 0
+ set nocols [llength $cols]
+ set novals [llength $values]
+ while { $first < $novals } {
+ set last [expr {$first+$nocols-1}]
+ $table add row
+ $table set row $row [lrange $values $first $last]
+
+ incr first $nocols
+ incr row
+ }
+
+ return $table
+}
+
+# inter-1d-table --
+# Interpolate in a one-dimensional table
+# (first column is independent variable, all others dependent)
+#
+# Arguments:
+# table Name of the table
+# xval Value of the independent variable
+#
+# Results:
+# List of interpolated values, including the x-variable
+#
+proc ::math::interpolate::interp-1d-table { table xval } {
+
+ #
+ # Search for the records that enclose the x-value
+ #
+ set xvalues [lrange [$table get column 0] 2 end]
+
+ foreach {row row2} [FindEnclosingEntries $xval $xvalues] break
+ incr row
+ incr row2
+
+ set prev_values [$table get row $row]
+ set next_values [$table get row $row2]
+
+ set xprev [lindex $prev_values 0]
+ set xnext [lindex $next_values 0]
+
+ if { $row == $row2 } {
+ return [concat $xval [lrange $prev_values 1 end]]
+ } else {
+ set wprev [expr {($xnext-$xval)/($xnext-$xprev)}]
+ set wnext [expr {1.0-$wprev}]
+ set results {}
+ foreach vprev $prev_values vnext $next_values {
+ set vint [expr {$vprev*$wprev+$vnext*$wnext}]
+ lappend results $vint
+ }
+ return $results
+ }
+}
+
+# interp-table --
+# Interpolate in a two-dimensional table
+# (first column and first row are independent variables)
+#
+# Arguments:
+# table Name of the table
+# xval Value of the independent row-variable
+# yval Value of the independent column-variable
+#
+# Results:
+# Interpolated value
+#
+# Note:
+# Use bilinear interpolation
+#
+proc ::math::interpolate::interp-table { table xval yval } {
+
+ #
+ # Search for the records that enclose the x-value
+ #
+ set xvalues [lrange [$table get column 0] 2 end]
+
+ foreach {row row2} [FindEnclosingEntries $xval $xvalues] break
+ incr row
+ incr row2
+
+ #
+ # Search for the columns that enclose the y-value
+ #
+ set yvalues [lrange [$table get row 1] 1 end]
+
+ foreach {col col2} [FindEnclosingEntries $yval $yvalues] break
+
+ set yvalues [concat "." $yvalues] ;# Prepend a dummy column!
+
+ set prev_values [$table get row $row]
+ set next_values [$table get row $row2]
+
+ set x1 [lindex $prev_values 0]
+ set x2 [lindex $next_values 0]
+ set y1 [lindex $yvalues $col]
+ set y2 [lindex $yvalues $col2]
+
+ set v11 [lindex $prev_values $col]
+ set v12 [lindex $prev_values $col2]
+ set v21 [lindex $next_values $col]
+ set v22 [lindex $next_values $col2]
+
+ #
+ # value = v0 + a*(x-x1) + b*(y-y1) + c*(x-x1)*(y-y1)
+ # if x == x1 and y == y1: value = v11
+ # if x == x1 and y == y2: value = v12
+ # if x == x2 and y == y1: value = v21
+ # if x == x2 and y == y2: value = v22
+ #
+ set a 0.0
+ if { $x1 != $x2 } {
+ set a [expr {($v21-$v11)/($x2-$x1)}]
+ }
+ set b 0.0
+ if { $y1 != $y2 } {
+ set b [expr {($v12-$v11)/($y2-$y1)}]
+ }
+ set c 0.0
+ if { $x1 != $x2 && $y1 != $y2 } {
+ set c [expr {($v11+$v22-$v12-$v21)/($x2-$x1)/($y2-$y1)}]
+ }
+
+ set result \
+ [expr {$v11+$a*($xval-$x1)+$b*($yval-$y1)+$c*($xval-$x1)*($yval-$y1)}]
+
+ return $result
+}
+
+# FindEnclosingEntries --
+# Search within a sorted list
+#
+# Arguments:
+# val Value to be searched
+# values List of values to be examined
+#
+# Results:
+# Returns a list of the previous and next indices
+#
+proc FindEnclosingEntries { val values } {
+ set found 0
+ set row2 1
+ foreach v $values {
+ if { $val <= $v } {
+ set row [expr {$row2-1}]
+ set found 1
+ break
+ }
+ incr row2
+ }
+
+ #
+ # Border cases: extrapolation needed
+ #
+ if { ! $found } {
+ incr row2 -1
+ set row $row2
+ }
+ if { $row == 0 } {
+ set row $row2
+ }
+
+ return [list $row $row2]
+}
+
+# interp-linear --
+# Use linear interpolation
+#
+# Arguments:
+# xyvalues List of x/y values to be interpolated
+# xval x-value for which a value is sought
+#
+# Results:
+# Estimated value at $xval
+#
+# Note:
+# The list xyvalues must be sorted w.r.t. the x-value
+#
+proc ::math::interpolate::interp-linear { xyvalues xval } {
+ #
+ # Border cases first
+ #
+ if { [lindex $xyvalues 0] > $xval } {
+ return [lindex $xyvalues 1]
+ }
+ if { [lindex $xyvalues end-1] < $xval } {
+ return [lindex $xyvalues end]
+ }
+
+ #
+ # The ordinary case
+ #
+ set idxx -2
+ set idxy -1
+ foreach { x y } $xyvalues {
+ if { $xval < $x } {
+ break
+ }
+ incr idxx 2
+ incr idxy 2
+ }
+
+ set x2 [lindex $xyvalues $idxx]
+ set y2 [lindex $xyvalues $idxy]
+
+ if { $x2 != $x } {
+ set yval [expr {$y+($y2-$y)*($xval-$x)/($x2-$x)}]
+ } else {
+ set yval $y
+ }
+ return $yval
+}
+
+# interp-lagrange --
+# Use the Lagrange interpolation method
+#
+# Arguments:
+# xyvalues List of x/y values to be interpolated
+# xval x-value for which a value is sought
+#
+# Results:
+# Estimated value at $xval
+#
+# Note:
+# The list xyvalues must be sorted w.r.t. the x-value
+# Furthermore the Lagrange method is not a very practical
+# method, as potentially the errors are unbounded
+#
+proc ::math::interpolate::interp-lagrange { xyvalues xval } {
+ #
+ # Border case: xval equals one of the "nodes"
+ #
+ foreach { x y } $xyvalues {
+ if { $x == $xval } {
+ return $y
+ }
+ }
+
+ #
+ # Ordinary case
+ #
+ set nonodes2 [llength $xyvalues]
+
+ set yval 0.0
+
+ for { set i 0 } { $i < $nonodes2 } { incr i 2 } {
+ set idxn 0
+ set xn [lindex $xyvalues $i]
+ set yn [lindex $xyvalues [expr {$i+1}]]
+
+ foreach { x y } $xyvalues {
+ if { $idxn != $i } {
+ set yn [expr {$yn*($x-$xval)/($x-$xn)}]
+ }
+ incr idxn 2
+ }
+
+ set yval [expr {$yval+$yn}]
+ }
+
+ return $yval
+}
+
+# interp-spatial --
+# Use a straightforward interpolation method with weights as
+# function of the inverse distance to interpolate in 2D and N-D
+# space
+#
+# Arguments:
+# xyvalues List of coordinates and values at these coordinates
+# coord List of coordinates for which a value is sought
+#
+# Results:
+# Estimated value(s) at $coord
+#
+# Note:
+# The list xyvalues is a list of lists:
+# { {x1 y1 z1 {v11 v12 v13 v14}
+# {x2 y2 z2 {v21 v22 v23 v24}
+# ...
+# }
+# The last element of each inner list is either a single number
+# or a list in itself. In the latter case the return value is
+# a list with the same number of elements.
+#
+# The method is influenced by the search radius and the
+# power of the inverse distance
+#
+proc ::math::interpolate::interp-spatial { xyvalues coord } {
+ variable search_radius
+ variable inv_dist_pow
+
+ set result {}
+ foreach v [lindex [lindex $xyvalues 0] end] {
+ lappend result 0.0
+ }
+
+ set total_weight 0.0
+
+ if { $search_radius != {} } {
+ set max_radius2 [expr {$search_radius*$search_radius}]
+ } else {
+ set max_radius2 {}
+ }
+
+ foreach point $xyvalues {
+ set dist 0.0
+ foreach c [lrange $point 0 end-1] cc $coord {
+ set dist [expr {$dist+($c-$cc)*($c-$cc)}]
+ }
+
+ #
+ # Take care of coincident points
+ #
+ if { $dist == 0.0 } {
+ return [lindex $point end]
+ }
+
+ #
+ # The general case
+ #
+ if { $max_radius2 == {} || $dist <= $max_radius2 } {
+ if { $inv_dist_pow == 1 } {
+ set dist [expr {sqrt($dist)}]
+ }
+ set total_weight [expr {$total_weight+1.0/$dist}]
+
+ set idx 0
+ foreach v [lindex $point end] r $result {
+ lset result $idx [expr {$r+$v/$dist}]
+ incr idx
+ }
+ }
+ }
+
+ if { $total_weight == 0.0 } {
+ set idx 0
+ foreach r $result {
+ lset result $idx {}
+ incr idx
+ }
+ } else {
+ set idx 0
+ foreach r $result {
+ lset result $idx [expr {$r/$total_weight}]
+ incr idx
+ }
+ }
+
+ return $result
+}
+
+# interp-spatial-params --
+# Set the parameters for spatial interpolation
+#
+# Arguments:
+# max_search Search radius (if none: use {} or "")
+# power Power for the inverse distance (1 or 2, defaults to 2)
+#
+# Results:
+# None
+#
+proc ::math::interpolate::interp-spatial-params { max_search {power 2} } {
+ variable search_radius
+ variable inv_dist_pow
+
+ set search_radius $max_search
+ if { $power == 1 } {
+ set inv_dist_pow 1
+ } else {
+ set inv_dist_pow 2
+ }
+}
+
+#----------------------------------------------------------------------
+#
+# neville --
+#
+# Interpolate a function between tabulated points using Neville's
+# algorithm.
+#
+# Parameters:
+# xtable - Table of abscissae.
+# ytable - Table of ordinates. Must be a list of the same
+# length as 'xtable.'
+# x - Abscissa for which the function value is desired.
+#
+# Results:
+# Returns a two-element list. The first element is the
+# requested ordinate. The second element is a rough estimate
+# of the absolute error, that is, the magnitude of the first
+# neglected term of a power series.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc ::math::interpolate::neville { xtable ytable x } {
+
+ set n [llength $xtable]
+
+ # Initialization. Set c and d to the ordinates, and set ns to the
+ # index of the nearest abscissa. Set y to the zero-order approximation
+ # of the nearest ordinate, and dif to the difference between x
+ # and the nearest tabulated abscissa.
+
+ set c [list]
+ set d [list]
+ set i 0
+ set ns 0
+ set dif [expr { abs( $x - [lindex $xtable 0] ) }]
+ set y [lindex $ytable 0]
+ foreach xi $xtable yi $ytable {
+ set dift [expr { abs ( $x - $xi ) }]
+ if { $dift < $dif } {
+ set ns $i
+ set y $yi
+ set dif $dift
+ }
+ lappend c $yi
+ lappend d $yi
+ incr i
+ }
+
+ # Compute successively higher-degree approximations to the fit
+ # function by using the recurrence:
+ # d_m[i] = ( c_{m-1}[i+1] - d{m-1}[i] ) * (x[i+m]-x) /
+ # (x[i] - x[i+m])
+ # c_m[i] = ( c_{m-1}[i+1] - d{m-1}[i] ) * (x[i]-x) /
+ # (x[i] - x[i+m])
+
+ for { set m 1 } { $m < $n } { incr m } {
+ for { set i 0 } { $i < $n - $m } { set i $ip1 } {
+ set ip1 [expr { $i + 1 }]
+ set ipm [expr { $i + $m }]
+ set ho [expr { [lindex $xtable $i] - $x }]
+ set hp [expr { [lindex $xtable $ipm] - $x }]
+ set w [expr { [lindex $c $ip1] - [lindex $d $i] }]
+ set q [expr { $w / ( $ho - $hp ) }]
+ lset d $i [expr { $hp * $q }]
+ lset c $i [expr { $ho * $q }]
+ }
+
+ # Take the straighest path possible through the tableau of c
+ # and d approximations back to the tabulated value
+ if { 2 * $ns < $n - $m } {
+ set dy [lindex $c $ns]
+ } else {
+ incr ns -1
+ set dy [lindex $d $ns]
+ }
+ set y [expr { $y + $dy }]
+ }
+
+ # Return the approximation and the highest-order correction term.
+
+ return [list $y [expr { abs($dy) }]]
+}
+
+# prepare-cubic-splines --
+# Prepare interpolation based on cubic splines
+#
+# Arguments:
+# xcoord The x-coordinates
+# ycoord Y-values for these x-coordinates
+# Result:
+# Intermediate parameters describing the spline function,
+# to be used in the second step, interp-cubic-splines.
+# Note:
+# Implicitly it is assumed that the function decribed by xcoord
+# and ycoord has a second derivative 0 at the end points.
+# To minimise the work if more than one value is needed, the
+# algorithm is divided in two steps
+# (Derived from the routine SPLINT in Davis and Rabinowitz:
+# Methods for Numerical Integration, AP, 1984)
+#
+proc ::math::interpolate::prepare-cubic-splines {xcoord ycoord} {
+
+ if { [llength $xcoord] < 3 } {
+ return -code error "At least three points are required"
+ }
+ if { [llength $xcoord] != [llength $ycoord] } {
+ return -code error "Equal number of x and y values required"
+ }
+
+ set m2 [expr {[llength $xcoord]-1}]
+
+ set s 0.0
+ set h {}
+ set c {}
+ for { set i 0 } { $i < $m2 } { incr i } {
+ set ip1 [expr {$i+1}]
+ set h1 [expr {[lindex $xcoord $ip1]-[lindex $xcoord $i]}]
+ lappend h $h1
+ if { $h1 <= 0.0 } {
+ return -code error "X values must be strictly ascending"
+ }
+ set r [expr {([lindex $ycoord $ip1]-[lindex $ycoord $i])/$h1}]
+ lappend c [expr {$r-$s}]
+ set s $r
+ }
+ set s 0.0
+ set r 0.0
+ set t {--}
+ lset c 0 0.0
+
+ for { set i 1 } { $i < $m2 } { incr i } {
+ set ip1 [expr {$i+1}]
+ set im1 [expr {$i-1}]
+ set y2 [expr {[lindex $c $i]+$r*[lindex $c $im1]}]
+ set t1 [expr {2.0*([lindex $xcoord $im1]-[lindex $xcoord $ip1])-$r*$s}]
+ set s [lindex $h $i]
+ set r [expr {$s/$t1}]
+ lset c $i $y2
+ lappend t $t1
+ }
+ lappend c 0.0
+
+ for { set j 1 } { $j < $m2 } { incr j } {
+ set i [expr {$m2-$j}]
+ set ip1 [expr {$i+1}]
+ set h1 [lindex $h $i]
+ set yp1 [lindex $c $ip1]
+ set y1 [lindex $c $i]
+ set t1 [lindex $t $i]
+ lset c $i [expr {($h1*$yp1-$y1)/$t1}]
+ }
+
+ set b {}
+ set d {}
+ for { set i 0 } { $i < $m2 } { incr i } {
+ set ip1 [expr {$i+1}]
+ set s [lindex $h $i]
+ set yp1 [lindex $c $ip1]
+ set y1 [lindex $c $i]
+ set r [expr {$yp1-$y1}]
+ lappend d [expr {$r/$s}]
+ set y1 [expr {3.0*$y1}]
+ lset c $i $y1
+ lappend b [expr {([lindex $ycoord $ip1]-[lindex $ycoord $i])/$s
+ -($y1+$r)*$s}]
+ }
+
+ lappend d 0.0
+ lappend b 0.0
+
+ return [list $d $c $b $ycoord $xcoord]
+}
+
+# interp-cubic-splines --
+# Interpolate based on cubic splines
+#
+# Arguments:
+# coeffs Coefficients resulting from the preparation step
+# x The x-coordinate for which to estimate the value
+# Result:
+# Interpolated value at x
+#
+proc ::math::interpolate::interp-cubic-splines {coeffs x} {
+ foreach {dcoef ccoef bcoef acoef xcoord} $coeffs {break}
+
+ #
+ # Check the bounds - no extrapolation
+ #
+ if { $x < [lindex $xcoord 0] } {error "X value too small"}
+ if { $x > [lindex $xcoord end] } {error "X value too large"}
+
+ #
+ # Which interval?
+ #
+ set idx -1
+ foreach xv $xcoord {
+ if { $xv > $x } {
+ break
+ }
+ incr idx
+ }
+
+ set a [lindex $acoef $idx]
+ set b [lindex $bcoef $idx]
+ set c [lindex $ccoef $idx]
+ set d [lindex $dcoef $idx]
+ set dx [expr {$x-[lindex $xcoord $idx]}]
+
+ return [expr {(($d*$dx+$c)*$dx+$b)*$dx+$a}]
+}
+
+
+
+#
+# Announce our presence
+#
+package provide math::interpolate 1.1
diff --git a/tcllib/modules/math/interpolate.test b/tcllib/modules/math/interpolate.test
new file mode 100755
index 0000000..e91db58
--- /dev/null
+++ b/tcllib/modules/math/interpolate.test
@@ -0,0 +1,346 @@
+# -*- tcl -*-
+# interpolate.test --
+# Test cases for the ::math::interpolate package
+#
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.1
+
+support {
+ use struct/matrix.tcl struct::matrix
+ useLocal math.tcl math
+}
+testing {
+ useLocal interpolate.tcl math::interpolate
+}
+
+# -------------------------------------------------------------------------
+
+#
+# Minimisation via steepest-descent
+#
+proc matchNumbers {expected actual} {
+ set match 1
+ foreach a $actual e $expected {
+ if {$e != 0.0} {
+ if {abs($a-$e) > 0.5e-4*abs($a+$e)} {
+ set match 0
+ break
+ }
+ } else {
+ if {abs($a-$e) > 1.0e-5} {
+ set match 0
+ break
+ }
+ }
+ }
+ return $match
+}
+
+customMatch numbers matchNumbers
+
+# -------------------------------------------------------------------------
+
+#
+# Test cases: interpolation in tables
+#
+# Add a dummy row to the table - ticket b25b826973edcbb5b3a95f6c284214925a1d5e67
+# This makes it possible to use the same table in both 1D and 2D interpolations
+#
+set t [::math::interpolate::defineTable table1 \
+ { x v1 v2 v3 } \
+ { - 1 2 3
+ 0 0 10 1
+ 1 1 9 4
+ 2 2 8 9
+ 5 5 5 25
+ 7 7 3 49
+ 10 10 0 100 }]
+
+test "Interpolate-1.1" "Interpolate in a one-dimensional table" \
+ -match numbers -body {
+ set result {}
+ foreach x { -1.0 0.0 3.0 5.0 9.9 11.0 } {
+ set result [concat $result \
+ [::math::interpolate::interp-1d-table $t $x]]
+ }
+ set result
+} -result {
+ -1 0 10 1
+ 0 0 10 1
+ 3 3 7 14.333333
+ 5 5 5 25
+ 9.9 9.9 0.1 98.3
+ 11 10 0 100 }
+
+
+# value = x+y
+set t2 [::math::interpolate::defineTable table2 \
+ { x y1 y2 y3 } \
+ { - 0 3 10
+ 1 1 4 11
+ 2 2 5 12
+ 5 5 8 15
+ 7 7 10 17
+ 10 10 13 20 }]
+
+test "Interpolate-1.2" "Interpolate in a two-dimensional table" \
+ -match numbers -body {
+ set result {}
+ foreach y { -1.0 0.0 3.0 5.0 9.9 11.0 } {
+ foreach x { -1.0 0.0 3.0 5.0 9.9 11.0 } {
+ set result [concat $result \
+ $x $y [::math::interpolate::interp-table $t2 $x $y]]
+ }
+ }
+ set result
+} -result {
+ -1.0 -1.0 1.0
+ 0.0 -1.0 1.0
+ 3.0 -1.0 3.0
+ 5.0 -1.0 5.0
+ 9.9 -1.0 9.9
+ 11.0 -1.0 10.0
+ -1.0 0.0 1.0
+ 0.0 0.0 1.0
+ 3.0 0.0 3.0
+ 5.0 0.0 5.0
+ 9.9 0.0 9.9
+ 11.0 0.0 10.0
+ -1.0 3.0 4.0
+ 0.0 3.0 4.0
+ 3.0 3.0 6.0
+ 5.0 3.0 8.0
+ 9.9 3.0 12.9
+ 11.0 3.0 13.0
+ -1.0 5.0 6.0
+ 0.0 5.0 6.0
+ 3.0 5.0 8.0
+ 5.0 5.0 10.0
+ 9.9 5.0 14.9
+ 11.0 5.0 15.0
+ -1.0 9.9 10.9
+ 0.0 9.9 10.9
+ 3.0 9.9 12.9
+ 5.0 9.9 14.9
+ 9.9 9.9 19.8
+ 11.0 9.9 19.9
+ -1.0 11.0 11.0
+ 0.0 11.0 11.0
+ 3.0 11.0 13.0
+ 5.0 11.0 15.0
+ 9.9 11.0 19.9
+ 11.0 11.0 20.0
+}
+
+# linear interpolation: y = x + 1 and y = 2*x, x<5, or 20-2*x, x>5
+
+test "Interpolate-2.1" "Linear interpolation - 1" \
+ -match numbers -body {
+ set result {}
+
+ set xyvalues { 0.0 1.0 10.0 11.0 }
+ foreach x { 0.0 4.0 7.0 10.0 101.0 } {
+ lappend result [::math::interpolate::interp-linear $xyvalues $x]
+ }
+ set result
+} -result { 1.0 5.0 8.0 11.0 11.0 }
+
+test "Interpolate-2.2" "Linear interpolation - 2" \
+ -match numbers -body {
+ set result {}
+ set xyvalues { 0.0 0.0 5.0 10.0 10.0 0.0 }
+ foreach x { 0.0 4.0 7.0 10.0 11.0 } {
+ lappend result [::math::interpolate::interp-linear $xyvalues $x]
+ }
+ set result
+} -result { 0.0 8.0 6.0 0.0 0.0 }
+
+# Lagrange interpolation: y = x + 1
+test "Interpolate-3.1" "Lagrange interpolation - 1" \
+ -match numbers -body {
+ set result {}
+ set xyvalues { 0.0 1.0 10.0 11.0 }
+ foreach x { 0.0 4.0 7.0 10.0 101.0 } {
+ lappend result [::math::interpolate::interp-lagrange $xyvalues $x]
+ }
+ set result
+} -result { 1.0 5.0 8.0 11.0 102.0 }
+
+
+#Lagrange interpolation (2) - expected: y=10-2*(x-5)**2/5
+test "Interpolate-3.2" "Lagrange interpolation - 2" \
+ -match numbers -body {
+ set result {}
+ set xyvalues { 0.0 0.0 5.0 10.0 10.0 0.0 }
+ foreach x { 0.0 4.0 7.0 10.0 11.0 } {
+ lappend result [::math::interpolate::interp-lagrange $xyvalues $x]
+ }
+ set result
+} -result { 0.0 9.6 8.4 0.0 -4.4 }
+
+# Spatial interpolation
+test "Interpolate-4.1" "Spatial interpolation - 1" \
+ -match numbers -body {
+ set result {}
+ set xyzvalues { {-1.0 0.0 -2.0 }
+ { 1.0 0.0 2.0 } }
+ foreach coord { {0.0 0.0} {0.0 1.0} {3.0 0.0} {100.0 0.0} } {
+ lappend result [::math::interpolate::interp-spatial $xyzvalues $coord]
+ }
+ set result
+} -result { 0.0 0.0 1.2 0.039996 }
+
+test "Interpolate-4.2" "Spatial interpolation - 2" \
+ -match numbers -body {
+ set result {}
+
+ set xyzvalues { {-1.0 0.0 { -2.0 1.0 } }
+ { 1.0 0.0 { 2.0 -1.0 } } }
+ foreach coord { {0.0 0.0} {0.0 1.0} {3.0 0.0} {100.0 0.0} } {
+ set result [concat $result \
+ [::math::interpolate::interp-spatial $xyzvalues $coord]]
+ }
+ set result
+} -result { 0.0 0.0
+ 0.0 0.0
+ 1.2 -0.6
+ 0.039996 -0.019998 }
+
+test "Interpolate-4.3" "Spatial interpolation - 3 - coincident points" \
+ -match numbers -body {
+ set result {}
+
+ set xyzvalues { {-1.0 0.0 { -2.0 1.0 } }
+ { 1.0 0.0 { 2.0 -1.0 } } }
+ set coord {-1.0 0.0}
+ set result [::math::interpolate::interp-spatial $xyzvalues $coord]
+
+ set result
+} -result { -2.0 1.0 }
+
+#
+# Test TODO: parameters for spatial interpolation
+#
+
+test interpolate-5.1 "neville algorithm" \
+ -body {
+ set problems {}
+ namespace import ::math::interpolate::neville
+ set xtable [list 0. 30. 45. 60. 90. 120. 135. 150. 180.]
+ set ytable [list 0. 0.5 [expr sqrt(0.5)] [expr sqrt(0.75)] 1. \
+ [expr sqrt(0.75)] [expr sqrt(0.5)] 0.5 0.]
+ for { set x -15 } { $x <= 195 } { incr x } {
+ foreach { y error } [neville $xtable $ytable $x] break
+ set diff [expr { abs( $y - sin( $x*3.1415926535897932/180. ) ) }]
+ if { $error > 3.e-4 || ( $diff > $error && $diff > 1.e-8 ) } {
+ append problems \n "interpolating for sine of " $x " degrees" \
+ \n "value was " $y " +/- " $error \
+ \n "actual error was " $diff
+ }
+ }
+ set problems
+ } \
+ -result {}
+
+proc matchNumbers {expected actual} {
+ set match 1
+ foreach a $actual e $expected {
+ if {abs($a-$e) > 0.1e-6} {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+
+customMatch numbers matchNumbers
+
+test "cubic-splines-1.0" "Interpolate linear function" \
+ -match numbers -body {
+ set xcoord {1 2 3 4 5}
+ set ycoord {1 2 3 4 5}
+ set coeffs [::math::interpolate::prepare-cubic-splines $xcoord $ycoord]
+ set yvalues {}
+ foreach x {1.5 2.5 3.5 4.5} {
+ lappend yvalues [::math::interpolate::interp-cubic-splines $coeffs $x]
+ }
+ set yvalues
+} -result {1.5 2.5 3.5 4.5}
+
+test "cubic-splines-1.1" "Interpolate quadratic function" \
+ -match numbers -body {
+ set xcoord {1 2 3 4 5}
+ set ycoord {1 4 9 16 25}
+ set coeffs [::math::interpolate::prepare-cubic-splines $xcoord $ycoord]
+ set yvalues {}
+ foreach x $xcoord {
+ lappend yvalues [::math::interpolate::interp-cubic-splines $coeffs $x]
+ }
+ set yvalues
+} -result {1 4 9 16 25}
+
+test "cubic-splines-1.2" "Interpolate arbitrary function" \
+ -match numbers -body {
+ set coeffs [::math::interpolate::prepare-cubic-splines \
+ {0.1 0.3 0.4 0.8 1.0} \
+ {1.0 2.1 2.2 4.11 4.12}]
+ set yvalues {}
+ foreach x {0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0} {
+ lappend yvalues [::math::interpolate::interp-cubic-splines $coeffs $x]
+ }
+ set yvalues
+} -result {1.0 1.6804411764705884 2.1 2.2 2.5380974264705882
+ 3.1041911764705885 3.695689338235294 4.11 4.2099448529411765 4.12}
+
+test "cubic-splines-2.1" "Too few data" \
+-match glob -body {
+ set xcoord {1 2}
+ set ycoord {1 4}
+ set coeffs [::math::interpolate::prepare-cubic-splines $xcoord $ycoord]
+} -result "At least *" -returnCodes error
+
+test "cubic-splines-2.2" "Unequal lengths" \
+-match glob -body {
+ set xcoord {1 2 4 5}
+ set ycoord {1 4 5 5 6}
+ set coeffs [::math::interpolate::prepare-cubic-splines $xcoord $ycoord]
+} -result "Equal number *" -returnCodes error
+
+test "cubic-splines-2.3" "Not-ascending x-coordinates" \
+-match glob -body {
+ set xcoord {1 2 1.5}
+ set ycoord {1 4 5}
+ set coeffs [::math::interpolate::prepare-cubic-splines $xcoord $ycoord]
+} -result "* ascending" -returnCodes error
+
+test "cubic-splines-2.4" "X too small" \
+-match glob -body {
+ set xcoord {1 2 3}
+ set ycoord {1 4 5}
+ set coeffs [::math::interpolate::prepare-cubic-splines $xcoord $ycoord]
+ set yvalue [::math::interpolate::interp-cubic-splines $coeffs -1]
+} -result "* too small" -returnCodes error
+
+test "cubic-splines-2.5" "X too large" \
+-match glob -body {
+ set xcoord {1 2 3}
+ set ycoord {1 4 5}
+ set coeffs [::math::interpolate::prepare-cubic-splines $xcoord $ycoord]
+ set yvalue [::math::interpolate::interp-cubic-splines $coeffs 6]
+} -result "* too large" -returnCodes error
+
+
+
+# -------------------------------------------------------------------------
+testsuiteCleanup
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tcllib/modules/math/kruskal.tcl b/tcllib/modules/math/kruskal.tcl
new file mode 100755
index 0000000..a08083b
--- /dev/null
+++ b/tcllib/modules/math/kruskal.tcl
@@ -0,0 +1,154 @@
+# kruskal.tcl --
+# Procedures related to ranking and the Kruskal-Wallis test
+#
+
+# test-Kruskal-Wallis --
+# Perform a one-way analysis of variance according
+# to Kruskal-Wallis
+#
+# Arguments:
+# confidence Confidence level (between 0 and 1)
+# args Two or more lists of data
+#
+# Result:
+# 0 if the medians of the groups differ, 1 if they
+# are the same (accept the null hypothesis)
+#
+proc ::math::statistics::test-Kruskal-Wallis {confidence args} {
+
+ foreach {H p} [eval analyse-Kruskal-Wallis $args] {break}
+
+ expr {$p < 1.0 - $confidence}
+}
+
+# analyse-Kruskal-Wallis --
+# Perform a one-way analysis of variance according
+# to Kruskal-Wallis and return the details
+#
+# Arguments:
+# args Two or more lists of data
+#
+# Result:
+# Kruskal-Wallis statistic H and the probability p
+# that this value occurs if the
+#
+proc ::math::statistics::analyse-Kruskal-Wallis {args} {
+
+ set setCount [llength $args]
+
+ #
+ # Rank the data with respect to the whole set
+ #
+ set rankList [eval group-rank $args]
+
+ set length [llength $rankList]
+
+ #
+ # Re-establish original sets of values, but using the ranks
+ #
+ foreach item $rankList {
+ lappend rankValues([lindex $item 0]) [lindex $item 2]
+ }
+
+ #
+ # Now compute H
+ #
+ set H 0
+ for {set i 0} {$i < $setCount} {incr i} {
+ set total [expr [join $rankValues($i) +]]
+ set count [llength $rankValues($i)]
+ set H [expr {$H + pow($total,2)/double($count)}]
+ }
+ set H [expr {$H*(12.0/($length*($length + 1))) - (3*($length + 1))}]
+ incr setCount -1
+ set p [expr {1 - [::math::statistics::cdf-chisquare $setCount $H]}]
+ return [list $H $p]
+}
+
+# group-rank --
+# Rank groups of data with respect to the whole set
+#
+# Arguments:
+# args Two or more lists of data
+#
+# Result:
+# List of ranking data: for each data item, the group-ID,
+# the value and the rank (may be a fraction, in case of ties)
+#
+proc ::math::statistics::group-rank {args} {
+
+ set index 0
+ set rankList [list]
+ set setCount [llength $args]
+ #
+ # Read lists of values
+ #
+ foreach item $args {
+ set values($index) [lindex $args $index]
+ #
+ # Prepare ranking with rank=0
+ #
+ foreach value $values($index) {
+ lappend rankList [list $index $value 0]
+ }
+ incr index 1
+ }
+ #
+ # Sort the values
+ #
+ set rankList [lsort -real -index 1 $rankList]
+ #
+ # Assign the ranks (disregarding ties)
+ #
+ set length [llength $rankList]
+ for {set i 0} {$i < $length} {incr i} {
+ lset rankList $i 2 [expr {$i + 1}]
+ }
+ #
+ # Value of the previous list element
+ #
+ set prevValue {}
+
+ #
+ # List of indices of list elements having the same value (ties)
+ #
+ set equalIndex [list]
+
+ #
+ # Test for ties and re-assign mean ranks for tied values
+ #
+ for {set i 0} {$i < $length} {incr i} {
+ set value [lindex $rankList $i 1]
+ if {($value != $prevValue) && ($i > 0) && ([llength $equalIndex] > 0)} {
+ #
+ # We are still missing the first tied value
+ #
+ set j [lindex $equalIndex 0]
+ incr j -1
+ set equalIndex [linsert $equalIndex 0 $j]
+
+ #
+ # Re-assign rank as mean rank of tied values
+ #
+ set firstRank [lindex $rankList [lindex $equalIndex 0] 2]
+ set lastRank [lindex $rankList [lindex $equalIndex end] 2]
+ set newRank [expr {($firstRank+$lastRank)/2.0}]
+ foreach j $equalIndex {
+ lset rankList $j 2 $newRank
+ }
+
+ #
+ # Clear list of equal elements
+ #
+ set equalIndex [list]
+ } elseif {$value == $prevValue} {
+ #
+ # Remember index of equal value element
+ #
+ lappend equalIndex $i
+ }
+ set prevValue $value
+ }
+
+ return $rankList
+}
diff --git a/tcllib/modules/math/linalg.man b/tcllib/modules/math/linalg.man
new file mode 100755
index 0000000..6bbe49b
--- /dev/null
+++ b/tcllib/modules/math/linalg.man
@@ -0,0 +1,968 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset VERSION 1.1.5]
+[manpage_begin math::linearalgebra n [vset VERSION]]
+[keywords {least squares}]
+[keywords {linear algebra}]
+[keywords {linear equations}]
+[keywords math]
+[keywords matrices]
+[keywords matrix]
+[keywords vectors]
+[copyright {2004-2008 Arjen Markus <arjenmarkus@users.sourceforge.net>}]
+[copyright {2004 Ed Hume <http://www.hume.com/contact.us.htm>}]
+[copyright {2008 Michael Buadin <relaxkmike@users.sourceforge.net>}]
+[moddesc {Tcl Math Library}]
+[titledesc {Linear Algebra}]
+[category Mathematics]
+[require Tcl [opt 8.4]]
+[require math::linearalgebra [opt [vset VERSION]]]
+[description]
+[para]
+This package offers both low-level procedures and high-level algorithms
+to deal with linear algebra problems:
+
+[list_begin itemized]
+[item]
+robust solution of linear equations or least squares problems
+[item]
+determining eigenvectors and eigenvalues of symmetric matrices
+[item]
+various decompositions of general matrices or matrices of a specific
+form
+[item]
+(limited) support for matrices in band storage, a common type of sparse
+matrices
+[list_end]
+
+It arose as a re-implementation of Hume's LA package and the desire to
+offer low-level procedures as found in the well-known BLAS library.
+Matrices are implemented as lists of lists rather linear lists with
+reserved elements, as in the original LA package, as it was found that
+such an implementation is actually faster.
+
+[para]
+It is advisable, however, to use the procedures that are offered, such
+as [emph setrow] and [emph getrow], rather than rely on this
+representation explicitly: that way it is to switch to a possibly even
+faster compiled implementation that supports the same API.
+
+[para]
+[emph Note:] When using this package in combination with Tk, there may
+be a naming conflict, as both this package and Tk define a command
+[emph scale]. See the [sectref "NAMING CONFLICT"] section below.
+
+[section "PROCEDURES"]
+
+The package defines the following public procedures (several exist as
+specialised procedures, see below):
+
+[para]
+[emph "Constructing matrices and vectors"]
+
+[list_begin definitions]
+
+[call [cmd ::math::linearalgebra::mkVector] [arg ndim] [arg value]]
+
+Create a vector with ndim elements, each with the value [emph value].
+
+[list_begin arguments]
+[arg_def integer ndim] Dimension of the vector (number of components)
+[arg_def double value] Uniform value to be used (default: 0.0)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::mkUnitVector] [arg ndim] [arg ndir]]
+
+Create a unit vector in [emph ndim]-dimensional space, along the
+[emph ndir]-th direction.
+
+[list_begin arguments]
+[arg_def integer ndim] Dimension of the vector (number of components)
+[arg_def integer ndir] Direction (0, ..., ndim-1)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::mkMatrix] [arg nrows] [arg ncols] [arg value]]
+
+Create a matrix with [emph nrows] rows and [emph ncols] columns. All
+elements have the value [emph value].
+
+[list_begin arguments]
+[arg_def integer nrows] Number of rows
+[arg_def integer ncols] Number of columns
+[arg_def double value] Uniform value to be used (default: 0.0)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::getrow] [arg matrix] [arg row] [opt imin] [opt imax]]
+
+Returns a single row of a matrix as a list
+
+[list_begin arguments]
+[arg_def list matrix] Matrix in question
+[arg_def integer row] Index of the row to return
+[arg_def integer imin] Minimum index of the column (default: 0)
+[arg_def integer imax] Maximum index of the column (default: ncols-1)
+
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::setrow] [arg matrix] [arg row] [arg newvalues] [opt imin] [opt imax]]
+
+Set a single row of a matrix to new values (this list must have the same
+number of elements as the number of [emph columns] in the matrix)
+
+[list_begin arguments]
+[arg_def list matrix] [emph name] of the matrix in question
+[arg_def integer row] Index of the row to update
+[arg_def list newvalues] List of new values for the row
+[arg_def integer imin] Minimum index of the column (default: 0)
+[arg_def integer imax] Maximum index of the column (default: ncols-1)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::getcol] [arg matrix] [arg col] [opt imin] [opt imax]]
+
+Returns a single column of a matrix as a list
+
+[list_begin arguments]
+[arg_def list matrix] Matrix in question
+[arg_def integer col] Index of the column to return
+[arg_def integer imin] Minimum index of the row (default: 0)
+[arg_def integer imax] Maximum index of the row (default: nrows-1)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::setcol] [arg matrix] [arg col] [arg newvalues] [opt imin] [opt imax]]
+
+Set a single column of a matrix to new values (this list must have
+the same number of elements as the number of [emph rows] in the matrix)
+
+[list_begin arguments]
+[arg_def list matrix] [emph name] of the matrix in question
+[arg_def integer col] Index of the column to update
+[arg_def list newvalues] List of new values for the column
+[arg_def integer imin] Minimum index of the row (default: 0)
+[arg_def integer imax] Maximum index of the row (default: nrows-1)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::getelem] [arg matrix] [arg row] [arg col]]
+
+Returns a single element of a matrix/vector
+
+[list_begin arguments]
+[arg_def list matrix] Matrix or vector in question
+[arg_def integer row] Row of the element
+[arg_def integer col] Column of the element (not present for vectors)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::setelem] [arg matrix] [arg row] [opt col] [arg newvalue]]
+
+Set a single element of a matrix (or vector) to a new value
+
+[list_begin arguments]
+[arg_def list matrix] [emph name] of the matrix in question
+[arg_def integer row] Row of the element
+[arg_def integer col] Column of the element (not present for vectors)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::swaprows] [arg matrix] [arg irow1] [arg irow2] [opt imin] [opt imax]]
+
+Swap two rows in a matrix completely or only a selected part
+
+[list_begin arguments]
+[arg_def list matrix] [emph name] of the matrix in question
+[arg_def integer irow1] Index of first row
+[arg_def integer irow2] Index of second row
+[arg_def integer imin] Minimum column index (default: 0)
+[arg_def integer imin] Maximum column index (default: ncols-1)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::swapcols] [arg matrix] [arg icol1] [arg icol2] [opt imin] [opt imax]]
+
+Swap two columns in a matrix completely or only a selected part
+
+[list_begin arguments]
+[arg_def list matrix] [emph name] of the matrix in question
+[arg_def integer irow1] Index of first column
+[arg_def integer irow2] Index of second column
+[arg_def integer imin] Minimum row index (default: 0)
+[arg_def integer imin] Maximum row index (default: nrows-1)
+[list_end]
+
+[list_end]
+
+[para]
+[emph "Querying matrices and vectors"]
+
+[list_begin definitions]
+
+[call [cmd ::math::linearalgebra::show] [arg obj] [opt format] [opt rowsep] [opt colsep]]
+
+Return a string representing the vector or matrix, for easy printing.
+(There is currently no way to print fixed sets of columns)
+
+[list_begin arguments]
+[arg_def list obj] Matrix or vector in question
+[arg_def string format] Format for printing the numbers (default: %6.4f)
+[arg_def string rowsep] String to use for separating rows (default: newline)
+[arg_def string colsep] String to use for separating columns (default: space)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::dim] [arg obj]]
+
+Returns the number of dimensions for the object (either 0 for a scalar,
+1 for a vector and 2 for a matrix)
+
+[list_begin arguments]
+[arg_def any obj] Scalar, vector, or matrix
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::shape] [arg obj]]
+
+Returns the number of elements in each dimension for the object (either
+an empty list for a scalar, a single number for a vector and a list of
+the number of rows and columns for a matrix)
+
+[list_begin arguments]
+[arg_def any obj] Scalar, vector, or matrix
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::conforming] [arg type] [arg obj1] [arg obj2]]
+
+Checks if two objects (vector or matrix) have conforming shapes, that is
+if they can be applied in an operation like addition or matrix
+multiplication.
+
+[list_begin arguments]
+
+[arg_def string type] Type of check:
+[list_begin itemized]
+[item]
+"shape" - the two objects have the same shape (for all element-wise
+operations)
+[item]
+"rows" - the two objects have the same number of rows (for use as A and
+b in a system of linear equations [emph "Ax = b"]
+[item]
+"matmul" - the first object has the same number of columns as the number
+of rows of the second object. Useful for matrix-matrix or matrix-vector
+multiplication.
+[list_end]
+
+[arg_def list obj1] First vector or matrix (left operand)
+[arg_def list obj2] Second vector or matrix (right operand)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::symmetric] [arg matrix] [opt eps]]
+
+Checks if the given (square) matrix is symmetric. The argument eps
+is the tolerance.
+
+[list_begin arguments]
+[arg_def list matrix] Matrix to be inspected
+[arg_def float eps] Tolerance for determining approximate equality
+(defaults to 1.0e-8)
+[list_end]
+
+[list_end]
+
+[para]
+[emph "Basic operations"]
+
+[list_begin definitions]
+
+[call [cmd ::math::linearalgebra::norm] [arg vector] [arg type]]
+
+Returns the norm of the given vector. The type argument can be: 1,
+2, inf or max, respectively the sum of absolute values, the ordinary
+Euclidean norm or the max norm.
+
+[list_begin arguments]
+[arg_def list vector] Vector, list of coefficients
+[arg_def string type] Type of norm (default: 2, the Euclidean norm)
+[list_end]
+
+[call [cmd ::math::linearalgebra::norm_one] [arg vector]]
+
+Returns the L1 norm of the given vector, the sum of absolute values
+
+[list_begin arguments]
+[arg_def list vector] Vector, list of coefficients
+[list_end]
+
+[call [cmd ::math::linearalgebra::norm_two] [arg vector]]
+
+Returns the L2 norm of the given vector, the ordinary Euclidean norm
+
+[list_begin arguments]
+[arg_def list vector] Vector, list of coefficients
+[list_end]
+
+[call [cmd ::math::linearalgebra::norm_max] [arg vector] [opt index]]
+
+Returns the Linf norm of the given vector, the maximum absolute
+coefficient
+
+[list_begin arguments]
+[arg_def list vector] Vector, list of coefficients
+[arg_def integer index] (optional) if non zero, returns a list made of the maximum
+value and the index where that maximum was found.
+if zero, returns the maximum value.
+
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::normMatrix] [arg matrix] [arg type]]
+
+Returns the norm of the given matrix. The type argument can be: 1,
+2, inf or max, respectively the sum of absolute values, the ordinary
+Euclidean norm or the max norm.
+
+[list_begin arguments]
+[arg_def list matrix] Matrix, list of row vectors
+[arg_def string type] Type of norm (default: 2, the Euclidean norm)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::dotproduct] [arg vect1] [arg vect2]]
+
+Determine the inproduct or dot product of two vectors. These must have
+the same shape (number of dimensions)
+
+[list_begin arguments]
+[arg_def list vect1] First vector, list of coefficients
+[arg_def list vect2] Second vector, list of coefficients
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::unitLengthVector] [arg vector]]
+
+Return a vector in the same direction with length 1.
+
+[list_begin arguments]
+[arg_def list vector] Vector to be normalized
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::normalizeStat] [arg mv]]
+
+Normalize the matrix or vector in a statistical sense: the mean of the
+elements of the columns of the result is zero and the standard deviation
+is 1.
+
+[list_begin arguments]
+[arg_def list mv] Vector or matrix to be normalized in the above sense
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::axpy] [arg scale] [arg mv1] [arg mv2]]
+
+Return a vector or matrix that results from a "daxpy" operation, that
+is: compute a*x+y (a a scalar and x and y both vectors or matrices of
+the same shape) and return the result.
+[para]
+Specialised variants are: axpy_vect and axpy_mat (slightly faster,
+but no check on the arguments)
+
+[list_begin arguments]
+[arg_def double scale] The scale factor for the first vector/matrix (a)
+[arg_def list mv1] First vector or matrix (x)
+[arg_def list mv2] Second vector or matrix (y)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::add] [arg mv1] [arg mv2]]
+
+Return a vector or matrix that is the sum of the two arguments (x+y)
+[para]
+Specialised variants are: add_vect and add_mat (slightly faster,
+but no check on the arguments)
+
+[list_begin arguments]
+[arg_def list mv1] First vector or matrix (x)
+[arg_def list mv2] Second vector or matrix (y)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::sub] [arg mv1] [arg mv2]]
+
+Return a vector or matrix that is the difference of the two arguments
+(x-y)
+[para]
+Specialised variants are: sub_vect and sub_mat (slightly faster,
+but no check on the arguments)
+
+[list_begin arguments]
+[arg_def list mv1] First vector or matrix (x)
+[arg_def list mv2] Second vector or matrix (y)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::scale] [arg scale] [arg mv]]
+
+Scale a vector or matrix and return the result, that is: compute a*x.
+[para]
+Specialised variants are: scale_vect and scale_mat (slightly faster,
+but no check on the arguments)
+
+[list_begin arguments]
+[arg_def double scale] The scale factor for the vector/matrix (a)
+[arg_def list mv] Vector or matrix (x)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::rotate] [arg c] [arg s] [arg vect1] [arg vect2]]
+
+Apply a planar rotation to two vectors and return the result as a list
+of two vectors: c*x-s*y and s*x+c*y. In algorithms you can often easily
+determine the cosine and sine of the angle, so it is more efficient to
+pass that information directly.
+
+[list_begin arguments]
+[arg_def double c] The cosine of the angle
+[arg_def double s] The sine of the angle
+[arg_def list vect1] First vector (x)
+[arg_def list vect2] Seocnd vector (x)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::transpose] [arg matrix]]
+
+Transpose a matrix
+
+[list_begin arguments]
+[arg_def list matrix] Matrix to be transposed
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::matmul] [arg mv1] [arg mv2]]
+
+Multiply a vector/matrix with another vector/matrix. The result is
+a matrix, if both x and y are matrices or both are vectors, in
+which case the "outer product" is computed. If one is a vector and the
+other is a matrix, then the result is a vector.
+
+[list_begin arguments]
+[arg_def list mv1] First vector/matrix (x)
+[arg_def list mv2] Second vector/matrix (y)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::angle] [arg vect1] [arg vect2]]
+
+Compute the angle between two vectors (in radians)
+
+[list_begin arguments]
+[arg_def list vect1] First vector
+[arg_def list vect2] Second vector
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::crossproduct] [arg vect1] [arg vect2]]
+
+Compute the cross product of two (three-dimensional) vectors
+
+[list_begin arguments]
+[arg_def list vect1] First vector
+[arg_def list vect2] Second vector
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::matmul] [arg mv1] [arg mv2]]
+
+Multiply a vector/matrix with another vector/matrix. The result is
+a matrix, if both x and y are matrices or both are vectors, in
+which case the "outer product" is computed. If one is a vector and the
+other is a matrix, then the result is a vector.
+
+[list_begin arguments]
+[arg_def list mv1] First vector/matrix (x)
+[arg_def list mv2] Second vector/matrix (y)
+[list_end]
+
+[list_end]
+
+[para]
+[emph "Common matrices and test matrices"]
+
+[list_begin definitions]
+
+[call [cmd ::math::linearalgebra::mkIdentity] [arg size]]
+
+Create an identity matrix of dimension [emph size].
+
+[list_begin arguments]
+[arg_def integer size] Dimension of the matrix
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::mkDiagonal] [arg diag]]
+
+Create a diagonal matrix whose diagonal elements are the elements of the
+vector [emph diag].
+
+[list_begin arguments]
+[arg_def list diag] Vector whose elements are used for the diagonal
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::mkRandom] [arg size]]
+
+Create a square matrix whose elements are uniformly distributed random
+numbers between 0 and 1 of dimension [emph size].
+
+[list_begin arguments]
+[arg_def integer size] Dimension of the matrix
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::mkTriangular] [arg size] [opt uplo] [opt value]]
+
+Create a triangular matrix with non-zero elements in the upper or lower
+part, depending on argument [emph uplo].
+
+[list_begin arguments]
+[arg_def integer size] Dimension of the matrix
+[arg_def string uplo] Fill the upper (U) or lower part (L)
+[arg_def double value] Value to fill the matrix with
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::mkHilbert] [arg size]]
+
+Create a Hilbert matrix of dimension [emph size].
+Hilbert matrices are very ill-conditioned with respect to
+eigenvalue/eigenvector problems. Therefore they
+are good candidates for testing the accuracy
+of algorithms and implementations.
+
+[list_begin arguments]
+[arg_def integer size] Dimension of the matrix
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::mkDingdong] [arg size]]
+
+Create a "dingdong" matrix of dimension [emph size].
+Dingdong matrices are imprecisely represented,
+but have the property of being very stable in
+such algorithms as Gauss elimination.
+
+[list_begin arguments]
+[arg_def integer size] Dimension of the matrix
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::mkOnes] [arg size]]
+
+Create a square matrix of dimension [emph size] whose entries are all 1.
+
+[list_begin arguments]
+[arg_def integer size] Dimension of the matrix
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::mkMoler] [arg size]]
+
+Create a Moler matrix of size [emph size]. (Moler matrices have
+a very simple Choleski decomposition. It has one small eigenvalue
+and it can easily upset elimination methods for systems of linear
+equations.)
+
+[list_begin arguments]
+[arg_def integer size] Dimension of the matrix
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::mkFrank] [arg size]]
+
+Create a Frank matrix of size [emph size]. (Frank matrices are
+fairly well-behaved matrices)
+
+[list_begin arguments]
+[arg_def integer size] Dimension of the matrix
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::mkBorder] [arg size]]
+
+Create a bordered matrix of size [emph size]. (Bordered matrices have
+a very low rank and can upset certain specialised algorithms.)
+
+[list_begin arguments]
+[arg_def integer size] Dimension of the matrix
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::mkWilkinsonW+] [arg size]]
+
+Create a Wilkinson W+ of size [emph size]. This kind of matrix
+has pairs of eigenvalues that are very close together. Usually
+the order (size) is odd.
+
+[list_begin arguments]
+[arg_def integer size] Dimension of the matrix
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::mkWilkinsonW-] [arg size]]
+
+Create a Wilkinson W- of size [emph size]. This kind of matrix
+has pairs of eigenvalues with opposite signs, when the order (size)
+is odd.
+
+[list_begin arguments]
+[arg_def integer size] Dimension of the matrix
+[list_end]
+
+[list_end]
+
+[para]
+[emph "Common algorithms"]
+
+[list_begin definitions]
+
+[call [cmd ::math::linearalgebra::solveGauss] [arg matrix] [arg bvect]]
+
+Solve a system of linear equations (Ax=b) using Gauss elimination.
+Returns the solution (x) as a vector or matrix of the same shape as
+bvect.
+
+[list_begin arguments]
+[arg_def list matrix] Square matrix (matrix A)
+[arg_def list bvect] Vector or matrix whose columns are the individual
+b-vectors
+[list_end]
+
+[call [cmd ::math::linearalgebra::solvePGauss] [arg matrix] [arg bvect]]
+
+Solve a system of linear equations (Ax=b) using Gauss elimination with
+partial pivoting. Returns the solution (x) as a vector or matrix of the
+same shape as bvect.
+
+[list_begin arguments]
+[arg_def list matrix] Square matrix (matrix A)
+[arg_def list bvect] Vector or matrix whose columns are the individual
+b-vectors
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::solveTriangular] [arg matrix] [arg bvect] [opt uplo]]
+
+Solve a system of linear equations (Ax=b) by backward substitution. The
+matrix is supposed to be upper-triangular.
+
+[list_begin arguments]
+[arg_def list matrix] Lower or upper-triangular matrix (matrix A)
+[arg_def list bvect] Vector or matrix whose columns are the individual
+b-vectors
+[arg_def string uplo] Indicates whether the matrix is lower-triangular
+(L) or upper-triangular (U). Defaults to "U".
+[list_end]
+
+[call [cmd ::math::linearalgebra::solveGaussBand] [arg matrix] [arg bvect]]
+
+Solve a system of linear equations (Ax=b) using Gauss elimination,
+where the matrix is stored as a band matrix ([emph cf.] [sectref STORAGE]).
+Returns the solution (x) as a vector or matrix of the same shape as
+bvect.
+
+[list_begin arguments]
+[arg_def list matrix] Square matrix (matrix A; in band form)
+[arg_def list bvect] Vector or matrix whose columns are the individual
+b-vectors
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::solveTriangularBand] [arg matrix] [arg bvect]]
+
+Solve a system of linear equations (Ax=b) by backward substitution. The
+matrix is supposed to be upper-triangular and stored in band form.
+
+[list_begin arguments]
+[arg_def list matrix] Upper-triangular matrix (matrix A)
+[arg_def list bvect] Vector or matrix whose columns are the individual
+b-vectors
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::determineSVD] [arg A] [arg eps]]
+
+Determines the Singular Value Decomposition of a matrix: A = U S Vtrans.
+Returns a list with the matrix U, the vector of singular values S and
+the matrix V.
+
+[list_begin arguments]
+[arg_def list A] Matrix to be decomposed
+[arg_def float eps] Tolerance (defaults to 2.3e-16)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::eigenvectorsSVD] [arg A] [arg eps]]
+
+Determines the eigenvectors and eigenvalues of a real
+[emph symmetric] matrix, using SVD. Returns a list with the matrix of
+normalized eigenvectors and their eigenvalues.
+
+[list_begin arguments]
+[arg_def list A] Matrix whose eigenvalues must be determined
+[arg_def float eps] Tolerance (defaults to 2.3e-16)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::leastSquaresSVD] [arg A] [arg y] [arg qmin] [arg eps]]
+
+Determines the solution to a least-sqaures problem Ax ~ y via singular
+value decomposition. The result is the vector x.
+
+[para]
+Note that if you add a column of 1s to the matrix, then this column will
+represent a constant like in: y = a*x1 + b*x2 + c. To force the
+intercept to be zero, simply leave it out.
+
+[list_begin arguments]
+[arg_def list A] Matrix of independent variables
+[arg_def list y] List of observed values
+[arg_def float qmin] Minimum singular value to be considered (defaults to 0.0)
+[arg_def float eps] Tolerance (defaults to 2.3e-16)
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::choleski] [arg matrix]]
+
+Determine the Choleski decomposition of a symmetric positive
+semidefinite matrix (this condition is not checked!). The result
+is the lower-triangular matrix L such that L Lt = matrix.
+
+[list_begin arguments]
+[arg_def list matrix] Matrix to be decomposed
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::orthonormalizeColumns] [arg matrix]]
+
+Use the modified Gram-Schmidt method to orthogonalize and normalize
+the [emph columns] of the given matrix and return the result.
+
+[list_begin arguments]
+[arg_def list matrix] Matrix whose columns must be orthonormalized
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::orthonormalizeRows] [arg matrix]]
+
+Use the modified Gram-Schmidt method to orthogonalize and normalize
+the [emph rows] of the given matrix and return the result.
+
+[list_begin arguments]
+[arg_def list matrix] Matrix whose rows must be orthonormalized
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::dger] [arg matrix] [arg alpha] [arg x] [arg y] [opt scope]]
+
+Perform the rank 1 operation A + alpha*x*y' inline (that is: the matrix A is adjusted).
+For convenience the new matrix is also returned as the result.
+
+[list_begin arguments]
+[arg_def list matrix] Matrix whose rows must be adjusted
+[arg_def double alpha] Scale factor
+[arg_def list x] A column vector
+[arg_def list y] A column vector
+[arg_def list scope] If not provided, the operation is performed on all rows/columns of A
+if provided, it is expected to be the list {imin imax jmin jmax}
+where:
+[list_begin itemized]
+[item] [term imin] Minimum row index
+[item] [term imax] Maximum row index
+[item] [term jmin] Minimum column index
+[item] [term jmax] Maximum column index
+[list_end]
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::dgetrf] [arg matrix]]
+
+Computes an LU factorization of a general matrix, using partial,
+pivoting with row interchanges. Returns the permutation vector.
+[para]
+The factorization has the form
+[example {
+ P * A = L * U
+}]
+where P is a permutation matrix, L is lower triangular with unit
+diagonal elements, and U is upper triangular.
+Returns the permutation vector, as a list of length n-1.
+The last entry of the permutation is not stored, since it is
+implicitely known, with value n (the last row is not swapped
+with any other row).
+At index #i of the permutation is stored the index of the row #j
+which is swapped with row #i at step #i. That means that each
+index of the permutation gives the permutation at each step, not the
+cumulated permutation matrix, which is the product of permutations.
+
+[list_begin arguments]
+[arg_def list matrix] On entry, the matrix to be factored.
+On exit, the factors L and U from the factorization
+P*A = L*U; the unit diagonal elements of L are not stored.
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::det] [arg matrix]]
+
+Returns the determinant of the given matrix, based on PA=LU
+decomposition, i.e. Gauss partial pivotal.
+
+[list_begin arguments]
+[arg_def list matrix] Square matrix (matrix A)
+[arg_def list ipiv] The pivots (optionnal).
+If the pivots are not provided, a PA=LU decomposition
+is performed.
+If the pivots are provided, we assume that it
+contains the pivots and that the matrix A contains the
+L and U factors, as provided by dgterf.
+b-vectors
+[list_end]
+
+[para]
+[call [cmd ::math::linearalgebra::largesteigen] [arg matrix] [arg tolerance] [arg maxiter]]
+
+Returns a list made of the largest eigenvalue (in magnitude)
+and associated eigenvector.
+Uses iterative Power Method as provided as algorithm #7.3.3 of Golub & Van Loan.
+This algorithm is used here for a dense matrix (but is usually
+used for sparse matrices).
+
+[list_begin arguments]
+[arg_def list matrix] Square matrix (matrix A)
+[arg_def double tolerance] The relative tolerance of the eigenvalue (default:1.e-8).
+[arg_def integer maxiter] The maximum number of iterations (default:10).
+[list_end]
+
+[list_end]
+
+[para]
+[emph "Compability with the LA package"]
+
+Two procedures are provided for compatibility with Hume's LA package:
+
+[list_begin definitions]
+
+[call [cmd ::math::linearalgebra::to_LA] [arg mv]]
+
+Transforms a vector or matrix into the format used by the original LA
+package.
+
+[list_begin arguments]
+[arg_def list mv] Matrix or vector
+[list_end]
+
+[call [cmd ::math::linearalgebra::from_LA] [arg mv]]
+
+Transforms a vector or matrix from the format used by the original LA
+package into the format used by the present implementation.
+
+[list_begin arguments]
+[arg_def list mv] Matrix or vector as used by the LA package
+[list_end]
+
+[list_end]
+
+[para]
+
+[section "STORAGE"]
+
+While most procedures assume that the matrices are given in full form,
+the procedures [emph solveGaussBand] and [emph solveTriangularBand]
+assume that the matrices are stored as [emph "band matrices"]. This
+common type of "sparse" matrices is related to ordinary matrices as
+follows:
+
+[list_begin itemized]
+[item]
+"A" is a full-size matrix with N rows and M columns.
+[item]
+"B" is a band matrix, with m upper and lower diagonals and n rows.
+[item]
+"B" can be stored in an ordinary matrix of (2m+1) columns (one for
+each off-diagonal and the main diagonal) and n rows.
+[item]
+Element i,j (i = -m,...,m; j =1,...,n) of "B" corresponds to element
+k,j of "A" where k = M+i-1 and M is at least (!) n, the number of rows
+in "B".
+[item]
+To set element (i,j) of matrix "B" use:
+[example {
+ setelem B $j [expr {$N+$i-1}] $value
+}]
+[list_end]
+(There is no convenience procedure for this yet)
+
+[section "REMARKS ON THE IMPLEMENTATION"]
+
+There is a difference between the original LA package by Hume and the
+current implementation. Whereas the LA package uses a linear list, the
+current package uses lists of lists to represent matrices. It turns out
+that with this representation, the algorithms are faster and easier to
+implement.
+
+[para]
+The LA package was used as a model and in fact the implementation of,
+for instance, the SVD algorithm was taken from that package. The set of
+procedures was expanded using ideas from the well-known BLAS library and
+some algorithms were updated from the second edition of J.C. Nash's
+book, Compact Numerical Methods for Computers, (Adam Hilger, 1990) that
+inspired the LA package.
+
+[para]
+Two procedures are provided to make the transition between the two
+implementations easier: [emph to_LA] and [emph from_LA]. They are
+described above.
+
+[section TODO]
+
+Odds and ends: the following algorithms have not been implemented yet:
+[list_begin itemized]
+
+[item]
+determineQR
+
+[item]
+certainlyPositive, diagonallyDominant
+[list_end]
+
+[section "NAMING CONFLICT"]
+If you load this package in a Tk-enabled shell like wish, then the
+command
+[example {namespace import ::math::linearalgebra}]
+results in an error
+message about "scale". This is due to the fact that Tk defines all
+its commands in the global namespace. The solution is to import
+the linear algebra commands in a namespace that is not the global one:
+[example {
+package require math::linearalgebra
+namespace eval compute {
+ namespace import ::math::linearalgebra::*
+ ... use the linear algebra version of scale ...
+}
+}]
+To use Tk's scale command in that same namespace you can rename it:
+[example {
+namespace eval compute {
+ rename ::scale scaleTk
+ scaleTk .scale ...
+}
+}]
+
+[vset CATEGORY {math :: linearalgebra}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/linalg.tcl b/tcllib/modules/math/linalg.tcl
new file mode 100755
index 0000000..98347ac
--- /dev/null
+++ b/tcllib/modules/math/linalg.tcl
@@ -0,0 +1,2288 @@
+# linalg.tcl --
+# Linear algebra package, based partly on Hume's LA package,
+# partly on experiments with various representations of
+# matrices. Also the functionality of the BLAS library has
+# been taken into account.
+#
+# General information:
+# - The package provides both a high-level general interface and
+# a lower-level specific interface for various LA functions
+# and tasks.
+# - The general procedures perform some checks and then call
+# the various specific procedures. The general procedures are
+# aimed at robustness and ease of use.
+# - The specific procedures do not check anything, they are
+# designed for speed. Failure to comply to the interface
+# requirements will presumably lead to [expr] errors.
+# - Vectors are represented as lists, matrices as lists of
+# lists, where the rows are the innermost lists:
+#
+# / a11 a12 a13 \
+# | a21 a22 a23 | == { {a11 a12 a13} {a21 a22 a23} {a31 a32 a33} }
+# \ a31 a32 a33 /
+#
+
+package require Tcl 8.4
+
+namespace eval ::math::linearalgebra {
+ # Define the namespace
+ namespace export dim shape conforming symmetric
+ namespace export norm norm_one norm_two norm_max normMatrix
+ namespace export dotproduct unitLengthVector normalizeStat
+ namespace export axpy axpy_vect axpy_mat crossproduct
+ namespace export add add_vect add_mat
+ namespace export sub sub_vect sub_mat
+ namespace export scale scale_vect scale_mat matmul transpose
+ namespace export rotate angle choleski
+ namespace export getrow getcol getelem setrow setcol setelem
+ namespace export mkVector mkMatrix mkIdentity mkDiagonal
+ namespace export mkHilbert mkDingdong mkBorder mkFrank
+ namespace export mkMoler mkWilkinsonW+ mkWilkinsonW-
+ namespace export solveGauss solveTriangular
+ namespace export solveGaussBand solveTriangularBand
+ namespace export solvePGauss
+ namespace export determineSVD eigenvectorsSVD
+ namespace export leastSquaresSVD
+ namespace export orthonormalizeColumns orthonormalizeRows
+ namespace export show to_LA from_LA
+ namespace export swaprows swapcols
+ namespace export dger dgetrf mkRandom mkTriangular
+ namespace export det largesteigen
+}
+
+# dim --
+# Return the dimension of an object (scalar, vector or matrix)
+# Arguments:
+# obj Object like a scalar, vector or matrix
+# Result:
+# Dimension: 0 for a scalar, 1 for a vector, 2 for a matrix
+#
+proc ::math::linearalgebra::dim { obj } {
+ set shape [shape $obj]
+ if { $shape != 1 } {
+ return [llength [shape $obj]]
+ } else {
+ return 0
+ }
+}
+
+# shape --
+# Return the shape of an object (scalar, vector or matrix)
+# Arguments:
+# obj Object like a scalar, vector or matrix
+# Result:
+# List of the sizes: 1 for a scalar, number of components
+# for a vector, number of rows and columns for a matrix
+#
+proc ::math::linearalgebra::shape { obj } {
+ set result [llength $obj]
+ if { [llength [lindex $obj 0]] <= 1 } {
+ return $result
+ } else {
+ lappend result [llength [lindex $obj 0]]
+ }
+ return $result
+}
+
+# show --
+# Return a string representing the vector or matrix,
+# for easy printing
+# Arguments:
+# obj Object like a scalar, vector or matrix
+# format Format to be used (defaults to %6.4f)
+# rowsep Separator for rows (defaults to \n)
+# colsep Separator for columns (defaults to " ")
+# Result:
+# String representing the vector or matrix
+#
+proc ::math::linearalgebra::show { obj {format %6.4f} {rowsep \n} {colsep " "} } {
+ set result ""
+ if { [llength [lindex $obj 0]] == 1 } {
+ foreach v $obj {
+ append result "[format $format $v]$rowsep"
+ }
+ } else {
+ foreach row $obj {
+ foreach v $row {
+ append result "[format $format $v]$colsep"
+ }
+ append result $rowsep
+ }
+ }
+ return $result
+}
+
+# conforming --
+# Determine if two objects (vector or matrix) are conforming
+# in shape, rows or for a matrix multiplication
+# Arguments:
+# type Type of conforming: shape, rows or matmul
+# obj1 First object (vector or matrix)
+# obj2 Second object (vector or matrix)
+# Result:
+# 1 if they conform, 0 if not
+#
+proc ::math::linearalgebra::conforming { type obj1 obj2 } {
+ set shape1 [shape $obj1]
+ set shape2 [shape $obj2]
+ set result 0
+ if { $type == "shape" } {
+ set result [expr {[lindex $shape1 0] == [lindex $shape2 0] &&
+ [lindex $shape1 1] == [lindex $shape2 1]}]
+ }
+ if { $type == "rows" } {
+ set result [expr {[lindex $shape1 0] == [lindex $shape2 0]}]
+ }
+ if { $type == "matmul" } {
+ set result [expr {[lindex $shape1 1] == [lindex $shape2 0]}]
+ }
+ return $result
+}
+
+# crossproduct --
+# Return the "cross product" of two 3D vectors
+# Arguments:
+# vect1 First vector
+# vect2 Second vector
+# Result:
+# Cross product
+#
+proc ::math::linearalgebra::crossproduct { vect1 vect2 } {
+
+ if { [llength $vect1] == 3 && [llength $vect2] == 3 } {
+ foreach {v11 v12 v13} $vect1 {v21 v22 v23} $vect2 {break}
+ return [list \
+ [expr {$v12*$v23 - $v13*$v22}] \
+ [expr {$v13*$v21 - $v11*$v23}] \
+ [expr {$v11*$v22 - $v12*$v21}] ]
+ } else {
+ return -code error "Cross-product only defined for 3D vectors"
+ }
+}
+
+# angle --
+# Return the "angle" between two vectors (in radians)
+# Arguments:
+# vect1 First vector
+# vect2 Second vector
+# Result:
+# Angle between the two vectors
+#
+proc ::math::linearalgebra::angle { vect1 vect2 } {
+
+ set dp [dotproduct $vect1 $vect2]
+ set n1 [norm_two $vect1]
+ set n2 [norm_two $vect2]
+
+ if { $n1 == 0.0 || $n2 == 0.0 } {
+ return -code error "Angle not defined for null vector"
+ }
+
+ return [expr {acos($dp/$n1/$n2)}]
+}
+
+
+# norm --
+# Compute the (1-, 2- or Inf-) norm of a vector
+# Arguments:
+# vector Vector (list of numbers)
+# type Either 1, 2 or max/inf to indicate the type of
+# norm (default: 2, the euclidean norm)
+# Result:
+# The (1-, 2- or Inf-) norm of a vector
+# Level-1 BLAS :
+# if type = 1, corresponds to DASUM
+# if type = 2, corresponds to DNRM2
+#
+proc ::math::linearalgebra::norm { vector {type 2} } {
+ if { $type == 2 } {
+ return [norm_two $vector]
+ }
+ if { $type == 1 } {
+ return [norm_one $vector]
+ }
+ if { $type == "max" || $type == "inf" } {
+ return [norm_max $vector]
+ }
+ return -code error "Unknown norm: $type"
+}
+
+# norm_one --
+# Compute the 1-norm of a vector
+# Arguments:
+# vector Vector
+# Result:
+# The 1-norm of a vector
+#
+proc ::math::linearalgebra::norm_one { vector } {
+ set sum 0.0
+ foreach c $vector {
+ set sum [expr {$sum+abs($c)}]
+ }
+ return $sum
+}
+
+# norm_two --
+# Compute the 2-norm of a vector (euclidean norm)
+# Arguments:
+# vector Vector
+# Result:
+# The 2-norm of a vector
+# Note:
+# Rely on the function hypot() to make this robust
+# against overflow and underflow
+#
+proc ::math::linearalgebra::norm_two { vector } {
+ set sum 0.0
+ foreach c $vector {
+ set sum [expr {hypot($c,$sum)}]
+ }
+ return $sum
+}
+
+# norm_max --
+# Compute the inf-norm of a vector (maximum of its components)
+# Arguments:
+# vector Vector
+# index, optional if non zero, returns a list made of the maximum
+# value and the index where that maximum was found.
+# if zero, returns the maximum value.
+# Result:
+# The inf-norm of a vector
+# Level-1 BLAS :
+# if index!=0, corresponds to IDAMAX
+#
+proc ::math::linearalgebra::norm_max { vector {index 0}} {
+ set max [lindex $vector 0]
+ set imax 0
+ set i 0
+ foreach c $vector {
+ if {[expr {abs($c)>$max}]} then {
+ set imax $i
+ set max [expr {abs($c)}]
+ }
+ incr i
+ }
+ if {$index == 0} then {
+ set result $max
+ } else {
+ set result [list $max $imax]
+ }
+ return $result
+}
+
+# normMatrix --
+# Compute the (1-, 2- or Inf-) norm of a matrix
+# Arguments:
+# matrix Matrix (list of row vectors)
+# type Either 1, 2 or max/inf to indicate the type of
+# norm (default: 2, the euclidean norm)
+# Result:
+# The (1-, 2- or Inf-) norm of the matrix
+#
+proc ::math::linearalgebra::normMatrix { matrix {type 2} } {
+ set v {}
+
+ foreach row $matrix {
+ lappend v [norm $row $type]
+ }
+
+ return [norm $v $type]
+}
+
+# symmetric --
+# Determine if the matrix is symmetric or not
+# Arguments:
+# matrix Matrix (list of row vectors)
+# eps Tolerance (defaults to 1.0e-8)
+# Result:
+# 1 if symmetric (within the tolerance), 0 if not
+#
+proc ::math::linearalgebra::symmetric { matrix {eps 1.0e-8} } {
+ set shape [shape $matrix]
+ if { [lindex $shape 0] != [lindex $shape 1] } {
+ return 0
+ }
+
+ set norm_org [normMatrix $matrix]
+ set norm_asymm [normMatrix [sub $matrix [transpose $matrix]]]
+
+ if { $norm_asymm <= $eps*$norm_org } {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# dotproduct --
+# Compute the dot product of two vectors
+# Arguments:
+# vect1 First vector
+# vect2 Second vector
+# Result:
+# The dot product of the two vectors
+# Level-1 BLAS : corresponds to DDOT
+#
+proc ::math::linearalgebra::dotproduct { vect1 vect2 } {
+ if { [llength $vect1] != [llength $vect2] } {
+ return -code error "Vectors must be of equal length"
+ }
+ set sum 0.0
+ foreach c1 $vect1 c2 $vect2 {
+ set sum [expr {$sum + $c1*$c2}]
+ }
+ return $sum
+}
+
+# unitLengthVector --
+# Normalize a vector so that a length 1 results and return the new vector
+# Arguments:
+# vector Vector to be normalized
+# Result:
+# A vector of length 1
+#
+proc ::math::linearalgebra::unitLengthVector { vector } {
+ set scale [norm_two $vector]
+ if { $scale == 0.0 } {
+ return -code error "Can not normalize a null-vector"
+ }
+ return [scale [expr {1.0/$scale}] $vector]
+}
+
+# normalizeStat --
+# Normalize a matrix or vector in a statistical sense and return the result
+# Arguments:
+# mv Matrix or vector to be normalized
+# Result:
+# A matrix or vector whose columns are normalised to have a mean of
+# 0 and a standard deviation of 1.
+#
+proc ::math::linearalgebra::normalizeStat { mv } {
+
+ if { [llength [lindex $mv 0]] > 1 } {
+ set result {}
+ foreach vector [transpose $mv] {
+ lappend result [NormalizeStat_vect $vector]
+ }
+ return [transpose $result]
+ } else {
+ return [NormalizeStat_vect $mv]
+ }
+}
+
+# NormalizeStat_vect --
+# Normalize a vector in a statistical sense and return the result
+# Arguments:
+# v Vector to be normalized
+# Result:
+# A vector whose elements are normalised to have a mean of
+# 0 and a standard deviation of 1. If all coefficients are equal,
+# a null-vector is returned.
+#
+proc ::math::linearalgebra::NormalizeStat_vect { v } {
+ if { [llength $v] <= 1 } {
+ return -code error "Vector can not be normalised - too few coefficients"
+ }
+
+ set sum 0.0
+ set sum2 0.0
+ set count 0.0
+ foreach c $v {
+ set sum [expr {$sum + $c}]
+ set sum2 [expr {$sum2 + $c*$c}]
+ set count [expr {$count + 1.0}]
+ }
+ set corr [expr {$sum/$count}]
+ set factor [expr {($sum2-$sum*$sum/$count)/($count-1)}]
+ if { $factor > 0.0 } {
+ set factor [expr {1.0/sqrt($factor)}]
+ } else {
+ set factor 0.0
+ }
+ set result {}
+ foreach c $v {
+ lappend result [expr {$factor*($c-$corr)}]
+ }
+ return $result
+}
+
+# axpy --
+# Compute the sum of a scaled vector/matrix and another
+# vector/matrix: a*x + y
+# Arguments:
+# scale Scale factor (a) for the first vector/matrix
+# mv1 First vector/matrix (x)
+# mv2 Second vector/matrix (y)
+# Result:
+# The result of a*x+y
+# Level-1 BLAS : if mv1 is a vector, corresponds to DAXPY
+#
+proc ::math::linearalgebra::axpy { scale mv1 mv2 } {
+ if { [llength [lindex $mv1 0]] > 1 } {
+ return [axpy_mat $scale $mv1 $mv2]
+ } else {
+ return [axpy_vect $scale $mv1 $mv2]
+ }
+}
+
+# axpy_vect --
+# Compute the sum of a scaled vector and another vector: a*x + y
+# Arguments:
+# scale Scale factor (a) for the first vector
+# vect1 First vector (x)
+# vect2 Second vector (y)
+# Result:
+# The result of a*x+y
+# Level-1 BLAS : corresponds to DAXPY
+#
+proc ::math::linearalgebra::axpy_vect { scale vect1 vect2 } {
+ set result {}
+
+ foreach c1 $vect1 c2 $vect2 {
+ lappend result [expr {$scale*$c1+$c2}]
+ }
+ return $result
+}
+
+# axpy_mat --
+# Compute the sum of a scaled matrix and another matrix: a*x + y
+# Arguments:
+# scale Scale factor (a) for the first matrix
+# mat1 First matrix (x)
+# mat2 Second matrix (y)
+# Result:
+# The result of a*x+y
+#
+proc ::math::linearalgebra::axpy_mat { scale mat1 mat2 } {
+ set result {}
+ foreach row1 $mat1 row2 $mat2 {
+ lappend result [axpy_vect $scale $row1 $row2]
+ }
+ return $result
+}
+
+# add --
+# Compute the sum of two vectors/matrices
+# Arguments:
+# mv1 First vector/matrix (x)
+# mv2 Second vector/matrix (y)
+# Result:
+# The result of x+y
+#
+proc ::math::linearalgebra::add { mv1 mv2 } {
+ if { [llength [lindex $mv1 0]] > 1 } {
+ return [add_mat $mv1 $mv2]
+ } else {
+ return [add_vect $mv1 $mv2]
+ }
+}
+
+# add_vect --
+# Compute the sum of two vectors
+# Arguments:
+# vect1 First vector (x)
+# vect2 Second vector (y)
+# Result:
+# The result of x+y
+#
+proc ::math::linearalgebra::add_vect { vect1 vect2 } {
+ set result {}
+ foreach c1 $vect1 c2 $vect2 {
+ lappend result [expr {$c1+$c2}]
+ }
+ return $result
+}
+
+# add_mat --
+# Compute the sum of two matrices
+# Arguments:
+# mat1 First matrix (x)
+# mat2 Second matrix (y)
+# Result:
+# The result of x+y
+#
+proc ::math::linearalgebra::add_mat { mat1 mat2 } {
+ set result {}
+ foreach row1 $mat1 row2 $mat2 {
+ lappend result [add_vect $row1 $row2]
+ }
+ return $result
+}
+
+# sub --
+# Compute the difference of two vectors/matrices
+# Arguments:
+# mv1 First vector/matrix (x)
+# mv2 Second vector/matrix (y)
+# Result:
+# The result of x-y
+#
+proc ::math::linearalgebra::sub { mv1 mv2 } {
+ if { [llength [lindex $mv1 0]] > 0 } {
+ return [sub_mat $mv1 $mv2]
+ } else {
+ return [sub_vect $mv1 $mv2]
+ }
+}
+
+# sub_vect --
+# Compute the difference of two vectors
+# Arguments:
+# vect1 First vector (x)
+# vect2 Second vector (y)
+# Result:
+# The result of x-y
+#
+proc ::math::linearalgebra::sub_vect { vect1 vect2 } {
+ set result {}
+ foreach c1 $vect1 c2 $vect2 {
+ lappend result [expr {$c1-$c2}]
+ }
+ return $result
+}
+
+# sub_mat --
+# Compute the difference of two matrices
+# Arguments:
+# mat1 First matrix (x)
+# mat2 Second matrix (y)
+# Result:
+# The result of x-y
+#
+proc ::math::linearalgebra::sub_mat { mat1 mat2 } {
+ set result {}
+ foreach row1 $mat1 row2 $mat2 {
+ lappend result [sub_vect $row1 $row2]
+ }
+ return $result
+}
+
+# scale --
+# Scale a vector or a matrix
+# Arguments:
+# scale Scale factor (scalar; a)
+# mv Vector/matrix (x)
+# Result:
+# The result of a*x
+# Level-1 BLAS : if mv is a vector, corresponds to DSCAL
+#
+proc ::math::linearalgebra::scale { scale mv } {
+ if { [llength [lindex $mv 0]] > 1 } {
+ return [scale_mat $scale $mv]
+ } else {
+ return [scale_vect $scale $mv]
+ }
+}
+
+# scale_vect --
+# Scale a vector
+# Arguments:
+# scale Scale factor to apply (a)
+# vect Vector to be scaled (x)
+# Result:
+# The result of a*x
+# Level-1 BLAS : corresponds to DSCAL
+#
+proc ::math::linearalgebra::scale_vect { scale vect } {
+ set result {}
+ foreach c $vect {
+ lappend result [expr {$scale*$c}]
+ }
+ return $result
+}
+
+# scale_mat --
+# Scale a matrix
+# Arguments:
+# scale Scale factor to apply
+# mat Matrix to be scaled
+# Result:
+# The result of x+y
+#
+proc ::math::linearalgebra::scale_mat { scale mat } {
+ set result {}
+ foreach row $mat {
+ lappend result [scale_vect $scale $row]
+ }
+ return $result
+}
+
+# rotate --
+# Apply a planar rotation to two vectors
+# Arguments:
+# c Cosine of the angle
+# s Sine of the angle
+# vect1 First vector (x)
+# vect2 Second vector (y)
+# Result:
+# A list of two elements: c*x-s*y and s*x+c*y
+#
+proc ::math::linearalgebra::rotate { c s vect1 vect2 } {
+ set result1 {}
+ set result2 {}
+ foreach v1 $vect1 v2 $vect2 {
+ lappend result1 [expr {$c*$v1-$s*$v2}]
+ lappend result2 [expr {$s*$v1+$c*$v2}]
+ }
+ return [list $result1 $result2]
+}
+
+# transpose --
+# Transpose a matrix
+# Arguments:
+# matrix Matrix to be transposed
+# Result:
+# The transposed matrix
+# Note:
+# The second transpose implementation is faster on large
+# matrices (100x100 say), there is no significant difference
+# on small ones (10x10 say).
+#
+#
+proc ::math::linearalgebra::transpose_old { matrix } {
+ set row {}
+ set transpose {}
+ foreach c [lindex $matrix 0] {
+ lappend row 0.0
+ }
+ foreach r $matrix {
+ lappend transpose $row
+ }
+
+ set nr 0
+ foreach r $matrix {
+ set nc 0
+ foreach c $r {
+ lset transpose $nc $nr $c
+ incr nc
+ }
+ incr nr
+ }
+ return $transpose
+}
+
+proc ::math::linearalgebra::transpose { matrix } {
+ set transpose {}
+ set c 0
+ foreach col [lindex $matrix 0] {
+ set newrow {}
+ foreach row $matrix {
+ lappend newrow [lindex $row $c]
+ }
+ lappend transpose $newrow
+ incr c
+ }
+ return $transpose
+}
+
+# MorV --
+# Identify if the object is a row/column vector or a matrix
+# Arguments:
+# obj Object to be examined
+# Result:
+# The letter R, C or M depending on the shape
+# (just to make it all work fine: S for scalar)
+# Note:
+# Private procedure to fix a bug in matmul
+#
+proc ::math::linearalgebra::MorV { obj } {
+ if { [llength $obj] > 1 } {
+ if { [llength [lindex $obj 0]] > 1 } {
+ return "M"
+ } else {
+ return "C"
+ }
+ } else {
+ if { [llength [lindex $obj 0]] > 1 } {
+ return "R"
+ } else {
+ return "S"
+ }
+ }
+}
+
+# matmul --
+# Multiply a vector/matrix with another vector/matrix
+# Arguments:
+# mv1 First vector/matrix (x)
+# mv2 Second vector/matrix (y)
+# Result:
+# The result of x*y
+#
+proc ::math::linearalgebra::matmul_org { mv1 mv2 } {
+ if { [llength [lindex $mv1 0]] > 1 } {
+ if { [llength [lindex $mv2 0]] > 1 } {
+ return [matmul_mm $mv1 $mv2]
+ } else {
+ return [matmul_mv $mv1 $mv2]
+ }
+ } else {
+ if { [llength [lindex $mv2 0]] > 1 } {
+ return [matmul_vm $mv1 $mv2]
+ } else {
+ return [matmul_vv $mv1 $mv2]
+ }
+ }
+}
+
+proc ::math::linearalgebra::matmul { mv1 mv2 } {
+ switch -exact -- "[MorV $mv1][MorV $mv2]" {
+ "MM" {
+ return [matmul_mm $mv1 $mv2]
+ }
+ "MC" {
+ return [matmul_mv $mv1 $mv2]
+ }
+ "MR" {
+ return -code error "Can not multiply a matrix with a row vector - wrong order"
+ }
+ "RM" {
+ return [matmul_vm [transpose $mv1] $mv2]
+ }
+ "RC" {
+ return [dotproduct [transpose $mv1] $mv2]
+ }
+ "RR" {
+ return -code error "Can not multiply a matrix with a row vector - wrong order"
+ }
+ "CM" {
+ return [transpose [matmul_vm $mv1 $mv2]]
+ }
+ "CR" {
+ return [matmul_vv $mv1 [transpose $mv2]]
+ }
+ "CC" {
+ return [matmul_vv $mv1 $mv2]
+ }
+ "SS" {
+ return [expr {$mv1 * $mv2}]
+ }
+ default {
+ return -code error "Can not use a scalar object"
+ }
+ }
+}
+
+# matmul_mv --
+# Multiply a matrix and a column vector
+# Arguments:
+# matrix Matrix (applied left: A)
+# vector Vector (interpreted as column vector: x)
+# Result:
+# The vector A*x
+# Level-2 BLAS : corresponds to DTRMV
+#
+proc ::math::linearalgebra::matmul_mv { matrix vector } {
+ set newvect {}
+ foreach row $matrix {
+ set sum 0.0
+ foreach v $vector c $row {
+ set sum [expr {$sum+$v*$c}]
+ }
+ lappend newvect $sum
+ }
+ return $newvect
+}
+
+# matmul_vm --
+# Multiply a row vector with a matrix
+# Arguments:
+# vector Vector (interpreted as row vector: x)
+# matrix Matrix (applied right: A)
+# Result:
+# The vector xtrans*A = Atrans*x
+#
+proc ::math::linearalgebra::matmul_vm { vector matrix } {
+ return [transpose [matmul_mv [transpose $matrix] $vector]]
+}
+
+# matmul_vv --
+# Multiply two vectors to obtain a matrix
+# Arguments:
+# vect1 First vector (column vector, x)
+# vect2 Second vector (row vector, y)
+# Result:
+# The "outer product" x*ytrans
+#
+proc ::math::linearalgebra::matmul_vv { vect1 vect2 } {
+ set newmat {}
+ foreach v1 $vect1 {
+ set newrow {}
+ foreach v2 $vect2 {
+ lappend newrow [expr {$v1*$v2}]
+ }
+ lappend newmat $newrow
+ }
+ return $newmat
+}
+
+# matmul_mm --
+# Multiply two matrices
+# Arguments:
+# mat1 First matrix (A)
+# mat2 Second matrix (B)
+# Result:
+# The matrix product A*B
+# Note:
+# By transposing matrix B we can access the columns
+# as rows - much easier and quicker, as they are
+# the elements of the outermost list.
+# Level-3 BLAS :
+# corresponds to DGEMM (alpha op(A) op(B) + beta C) when alpha=1, op(X)=X and beta=0
+# corresponds to DTRMM (alpha op(A) B) when alpha = 1, op(X)=X
+#
+proc ::math::linearalgebra::matmul_mm { mat1 mat2 } {
+ set newmat {}
+ set tmat [transpose $mat2]
+ foreach row1 $mat1 {
+ set newrow {}
+ foreach row2 $tmat {
+ lappend newrow [dotproduct $row1 $row2]
+ }
+ lappend newmat $newrow
+ }
+ return $newmat
+}
+
+# mkVector --
+# Make a vector of a given size
+# Arguments:
+# ndim Dimension of the vector
+# value Default value for all elements (default: 0.0)
+# Result:
+# A list with ndim elements, representing a vector
+#
+proc ::math::linearalgebra::mkVector { ndim {value 0.0} } {
+ set result {}
+
+ while { $ndim > 0 } {
+ lappend result $value
+ incr ndim -1
+ }
+ return $result
+}
+
+# mkUnitVector --
+# Make a unit vector in a given direction
+# Arguments:
+# ndim Dimension of the vector
+# dir The direction (0, ... ndim-1)
+# Result:
+# A list with ndim elements, representing a unit vector
+#
+proc ::math::linearalgebra::mkUnitVector { ndim dir } {
+
+ if { $dir < 0 || $dir >= $ndim } {
+ return -code error "Invalid direction for unit vector - $dir"
+ } else {
+ set result [mkVector $ndim]
+ lset result $dir 1.0
+ }
+ return $result
+}
+
+# mkMatrix --
+# Make a matrix of a given size
+# Arguments:
+# nrows Number of rows
+# ncols Number of columns
+# value Default value for all elements (default: 0.0)
+# Result:
+# A nested list, representing an nrows x ncols matrix
+#
+proc ::math::linearalgebra::mkMatrix { nrows ncols {value 0.0} } {
+ set result {}
+
+ while { $nrows > 0 } {
+ lappend result [mkVector $ncols $value]
+ incr nrows -1
+ }
+ return $result
+}
+
+# mkIdent --
+# Make an identity matrix of a given size
+# Arguments:
+# size Number of rows/columns
+# Result:
+# A nested list, representing an size x size identity matrix
+#
+proc ::math::linearalgebra::mkIdentity { size } {
+ set result [mkMatrix $size $size 0.0]
+
+ while { $size > 0 } {
+ incr size -1
+ lset result $size $size 1.0
+ }
+ return $result
+}
+
+# mkDiagonal --
+# Make a diagonal matrix of a given size
+# Arguments:
+# diag List of values to appear on the diagonal
+#
+# Result:
+# A nested list, representing a diagonal matrix
+#
+proc ::math::linearalgebra::mkDiagonal { diag } {
+ set size [llength $diag]
+ set result [mkMatrix $size $size 0.0]
+
+ while { $size > 0 } {
+ incr size -1
+ lset result $size $size [lindex $diag $size]
+ }
+ return $result
+}
+
+# mkHilbert --
+# Make a Hilbert matrix of a given size
+# Arguments:
+# size Size of the matrix
+# Result:
+# A nested list, representing a Hilbert matrix
+# Notes:
+# Hilbert matrices are very ill-conditioned wrt
+# eigenvalue/eigenvector problems. Therefore they
+# are good candidates for testing the accuracy
+# of algorithms and implementations.
+#
+proc ::math::linearalgebra::mkHilbert { size } {
+ set result {}
+ for { set j 0 } { $j < $size } { incr j } {
+ set row {}
+ for { set i 0 } { $i < $size } { incr i } {
+ lappend row [expr {1.0/($i+$j+1.0)}]
+ }
+ lappend result $row
+ }
+ return $result
+}
+
+# mkDingdong --
+# Make a Dingdong matrix of a given size
+# Arguments:
+# size Size of the matrix
+# Result:
+# A nested list, representing a Dingdong matrix
+# Notes:
+# Dingdong matrices are imprecisely represented,
+# but have the property of being very stable in
+# such algorithms as Gauss elimination.
+#
+proc ::math::linearalgebra::mkDingdong { size } {
+ set result {}
+ for { set j 0 } { $j < $size } { incr j } {
+ set row {}
+ for { set i 0 } { $i < $size } { incr i } {
+ lappend row [expr {0.5/($size-$i-$j-0.5)}]
+ }
+ lappend result $row
+ }
+ return $result
+}
+
+# mkOnes --
+# Make a square matrix consisting of ones
+# Arguments:
+# size Number of rows/columns
+# Result:
+# A nested list, representing a size x size matrix,
+# filled with 1.0
+#
+proc ::math::linearalgebra::mkOnes { size } {
+ return [mkMatrix $size $size 1.0]
+}
+
+# mkMoler --
+# Make a Moler matrix
+# Arguments:
+# size Size of the matrix
+# Result:
+# A nested list, representing a Moler matrix
+# Notes:
+# Moler matrices have a very simple Choleski
+# decomposition. It has one small eigenvalue
+# and it can easily upset elimination methods
+# for systems of linear equations
+#
+proc ::math::linearalgebra::mkMoler { size } {
+ set result {}
+ for { set j 0 } { $j < $size } { incr j } {
+ set row {}
+ for { set i 0 } { $i < $size } { incr i } {
+ if { $i == $j } {
+ lappend row [expr {$i+1}]
+ } else {
+ lappend row [expr {($i>$j?$j:$i)-1.0}]
+ }
+ }
+ lappend result $row
+ }
+ return $result
+}
+
+# mkFrank --
+# Make a Frank matrix
+# Arguments:
+# size Size of the matrix
+# Result:
+# A nested list, representing a Frank matrix
+#
+proc ::math::linearalgebra::mkFrank { size } {
+ set result {}
+ for { set j 0 } { $j < $size } { incr j } {
+ set row {}
+ for { set i 0 } { $i < $size } { incr i } {
+ lappend row [expr {($i>$j?$j:$i)-2.0}]
+ }
+ lappend result $row
+ }
+ return $result
+}
+
+# mkBorder --
+# Make a bordered matrix
+# Arguments:
+# size Size of the matrix
+# Result:
+# A nested list, representing a bordered matrix
+# Note:
+# This matrix has size-2 eigenvalues at 1.
+#
+proc ::math::linearalgebra::mkBorder { size } {
+ set result {}
+ for { set j 0 } { $j < $size } { incr j } {
+ set row {}
+ for { set i 0 } { $i < $size } { incr i } {
+ set entry 0.0
+ if { $i == $j } {
+ set entry 1.0
+ } elseif { $j != $size-1 && $i == $size-1 } {
+ set entry [expr {pow(2.0,-$j)}]
+ } elseif { $i != $size-1 && $j == $size-1 } {
+ set entry [expr {pow(2.0,-$i)}]
+ } else {
+ set entry 0.0
+ }
+ lappend row $entry
+ }
+ lappend result $row
+ }
+ return $result
+}
+
+# mkWilkinsonW+ --
+# Make a Wilkinson W+ matrix
+# Arguments:
+# size Size of the matrix
+# Result:
+# A nested list, representing a Wilkinson W+ matrix
+# Note:
+# This kind of matrix has pairs of eigenvalues that
+# are very close together. Usually the order is odd.
+#
+proc ::math::linearalgebra::mkWilkinsonW+ { size } {
+ set result {}
+ for { set j 0 } { $j < $size } { incr j } {
+ set row {}
+ for { set i 0 } { $i < $size } { incr i } {
+ if { $i == $j } {
+ # int(n/2) + 1 - min(i,n-i+1)
+ set min [expr {(($i+1)>$size-($i+1)+1? $size-($i+1)+1 : ($i+1))}]
+ set entry [expr {int($size/2) + 1 - $min}]
+ } elseif { $i == $j+1 || $i+1 == $j } {
+ set entry 1
+ } else {
+ set entry 0.0
+ }
+ lappend row $entry
+ }
+ lappend result $row
+ }
+ return $result
+}
+
+# mkWilkinsonW- --
+# Make a Wilkinson W- matrix
+# Arguments:
+# size Size of the matrix
+# Result:
+# A nested list, representing a Wilkinson W- matrix
+# Note:
+# This kind of matrix has pairs of eigenvalues with
+# opposite signs (if the order is odd).
+#
+proc ::math::linearalgebra::mkWilkinsonW- { size } {
+ set result {}
+ for { set j 0 } { $j < $size } { incr j } {
+ set row {}
+ for { set i 0 } { $i < $size } { incr i } {
+ if { $i == $j } {
+ set entry [expr {int($size/2) + 1 - ($i+1)}]
+ } elseif { $i == $j+1 || $i+1 == $j } {
+ set entry 1
+ } else {
+ set entry 0.0
+ }
+ lappend row $entry
+ }
+ lappend result $row
+ }
+ return $result
+}
+# mkRandom --
+# Make a square matrix consisting of random numbers
+# Arguments:
+# size Number of rows/columns
+# Result:
+# A nested list, representing a size x size matrix,
+# filled with random numbers
+#
+proc ::math::linearalgebra::mkRandom { size } {
+ set result {}
+ for { set j 0 } { $j < $size } { incr j } {
+ set row {}
+ for { set i 0 } { $i < $size } { incr i } {
+ lappend row [expr {rand()}]
+ }
+ lappend result $row
+ }
+ return $result
+}
+# mkTriangular --
+# Make a triangular matrix consisting of a constant
+# Arguments:
+# size Number of rows/columns
+# uplo U if the matrix is upper triangular (default), L if the
+# matrix is lower triangular.
+# value Default value for all elements (default: 0.0)
+# Result:
+# A nested list, representing a size x size matrix,
+# filled with random numbers
+#
+proc ::math::linearalgebra::mkTriangular { size {uplo "U"} {value 1.0}} {
+ switch -- $uplo {
+ "U" {
+ set result {}
+ for { set j 0 } { $j < $size } { incr j } {
+ set row {}
+ for { set i 0 } { $i < $size } { incr i } {
+ if {$i<$j} then {
+ lappend row 0.
+ } else {
+ lappend row $value
+ }
+ }
+ lappend result $row
+ }
+ }
+ "L" {
+ set result {}
+ for { set j 0 } { $j < $size } { incr j } {
+ set row {}
+ for { set i 0 } { $i < $size } { incr i } {
+ if {$i>$j} then {
+ lappend row 0.
+ } else {
+ lappend row $value
+ }
+ }
+ lappend result $row
+ }
+ }
+ default {
+ error "Unknown value for parameter uplo : $uplo"
+ }
+ }
+ return $result
+}
+
+# getrow --
+# Get the specified row from a matrix
+# Arguments:
+# matrix Matrix in question
+# row Index of the row
+# imin Minimum index of the column (default 0)
+# imax Maximum index of the column (default ncols-1)
+#
+# Result:
+# A list with the values on the requested row
+#
+proc ::math::linearalgebra::getrow { matrix row {imin 0} {imax ""}} {
+ if {$imax==""} then {
+ foreach {nrows ncols} [shape $matrix] {break}
+ if {$ncols==""} then {
+ # the matrix is a vector
+ set imax 0
+ } else {
+ set imax [expr {$ncols - 1}]
+ }
+ }
+ set row [lindex $matrix $row]
+ return [lrange $row $imin $imax]
+}
+
+# setrow --
+# Set the specified row in a matrix
+# Arguments:
+# matrix _Name_ of matrix in question
+# row Index of the row
+# newvalues New values for the row
+# imin Minimum column index (default 0)
+# imax Maximum column index (default ncols-1)
+#
+# Result:
+# Updated matrix
+# Side effect:
+# The matrix is updated
+#
+proc ::math::linearalgebra::setrow { matrix row newvalues {imin 0} {imax ""}} {
+ upvar $matrix mat
+ if {$imax==""} then {
+ foreach {nrows ncols} [shape $mat] {break}
+ if {$ncols==""} then {
+ # the matrix is a vector
+ set imax 0
+ } else {
+ set imax [expr {$ncols - 1}]
+ }
+ }
+ set icol $imin
+ foreach value $newvalues {
+ lset mat $row $icol $value
+ incr icol
+ if {$icol>$imax} then {
+ break
+ }
+ }
+ return $mat
+}
+
+# getcol --
+# Get the specified column from a matrix
+# Arguments:
+# matrix Matrix in question
+# col Index of the column
+# imin Minimum row index (default 0)
+# imax Minimum row index (default nrows-1)
+#
+# Result:
+# A list with the values on the requested column
+#
+proc ::math::linearalgebra::getcol { matrix col {imin 0} {imax ""}} {
+ if {$imax==""} then {
+ set nrows [llength $matrix]
+ set imax [expr {$nrows - 1}]
+ }
+ set result {}
+ set iline 0
+ foreach row $matrix {
+ if {$iline>=$imin && $iline<=$imax} then {
+ lappend result [lindex $row $col]
+ }
+ incr iline
+ }
+ return $result
+}
+
+# setcol --
+# Set the specified column in a matrix
+# Arguments:
+# matrix _Name_ of matrix in question
+# col Index of the column
+# newvalues New values for the column
+# imin Minimum row index (default 0)
+# imax Minimum row index (default nrows-1)
+#
+# Result:
+# Updated matrix
+# Side effect:
+# The matrix is updated
+#
+proc ::math::linearalgebra::setcol { matrix col newvalues {imin 0} {imax ""}} {
+ upvar $matrix mat
+ if {$imax==""} then {
+ set nrows [llength $mat]
+ set imax [expr {$nrows - 1}]
+ }
+ set index 0
+ for { set i $imin } { $i <= $imax } { incr i } {
+ lset mat $i $col [lindex $newvalues $index]
+ incr index
+ }
+ return $mat
+}
+
+# getelem --
+# Get the specified element (row,column) from a matrix/vector
+# Arguments:
+# matrix Matrix in question
+# row Index of the row
+# col Index of the column (not present for vectors)
+#
+# Result:
+# The matrix element (row,column)
+#
+proc ::math::linearalgebra::getelem { matrix row {col {}} } {
+ if { $col != {} } {
+ lindex $matrix $row $col
+ } else {
+ lindex $matrix $row
+ }
+}
+
+# setelem --
+# Set the specified element (row,column) in a matrix or vector
+# Arguments:
+# matrix _Name_ of matrix/vector in question
+# row Index of the row
+# col Index of the column/new value
+# newvalue New value for the element (not present for vectors)
+#
+# Result:
+# Updated matrix
+# Side effect:
+# The matrix is updated
+#
+proc ::math::linearalgebra::setelem { matrix row col {newvalue {}} } {
+ upvar $matrix mat
+ if { $newvalue != {} } {
+ lset mat $row $col $newvalue
+ } else {
+ lset mat $row $col
+ }
+ return $mat
+}
+# swaprows --
+# Swap two rows of a matrix
+# Arguments:
+# matrix Matrix defining the coefficients
+# irow1 Index of first row
+# irow2 Index of second row
+# imin Minimum column index (default 0)
+# imax Maximum column index (default ncols-1)
+#
+# Result:
+# The matrix with the two rows swaped.
+#
+proc ::math::linearalgebra::swaprows { matrix irow1 irow2 {imin 0} {imax ""}} {
+ upvar $matrix mat
+ #swaprows1 mat $irow1 $irow2 $imin $imax
+ swaprows2 mat $irow1 $irow2 $imin $imax
+}
+proc ::math::linearalgebra::swaprows1 { matrix irow1 irow2 {imin 0} {imax ""}} {
+ upvar $matrix mat
+ if {$imax==""} then {
+ foreach {nrows ncols} [shape $mat] {break}
+ if {$ncols==""} then {
+ # the matrix is a vector
+ set imax 0
+ } else {
+ set imax [expr {$ncols - 1}]
+ }
+ }
+ set row1 [getrow $mat $irow1 $imin $imax]
+ set row2 [getrow $mat $irow2 $imin $imax]
+ setrow mat $irow1 $row2 $imin $imax
+ setrow mat $irow2 $row1 $imin $imax
+ return $mat
+}
+proc ::math::linearalgebra::swaprows2 { matrix irow1 irow2 {imin 0} {imax ""}} {
+ upvar $matrix mat
+ if {$imax==""} then {
+ foreach {nrows ncols} [shape $mat] {break}
+ if {$ncols==""} then {
+ # the matrix is a vector
+ set imax 0
+ } else {
+ set imax [expr {$ncols - 1}]
+ }
+ }
+ set row1 [lrange [lindex $mat $irow1] $imin $imax]
+ set row2 [lrange [lindex $mat $irow2] $imin $imax]
+ setrow mat $irow1 $row2 $imin $imax
+ setrow mat $irow2 $row1 $imin $imax
+ return $mat
+}
+# swapcols --
+# Swap two cols of a matrix
+# Arguments:
+# matrix Matrix defining the coefficients
+# icol1 Index of first column
+# icol2 Index of second column
+# imin Minimum row index (default 0)
+# imax Minimum row index (default nrows-1)
+#
+# Result:
+# The matrix with the two columns swaped.
+#
+proc ::math::linearalgebra::swapcols { matrix icol1 icol2 {imin 0} {imax ""}} {
+ upvar $matrix mat
+ if {$imax==""} then {
+ set nrows [llength $mat]
+ set imax [expr {$nrows - 1}]
+ }
+ set col1 [getcol $mat $icol1 $imin $imax]
+ set col2 [getcol $mat $icol2 $imin $imax]
+ setcol mat $icol1 $col2 $imin $imax
+ setcol mat $icol2 $col1 $imin $imax
+ return $mat
+}
+
+# solveGauss --
+# Solve a system of linear equations using Gauss elimination
+# Arguments:
+# matrix Matrix defining the coefficients
+# bvect Right-hand side (may be several columns)
+#
+# Result:
+# Solution of the system or an error in case of singularity
+# LAPACK : corresponds to DGETRS, without row interchanges
+#
+proc ::math::linearalgebra::solveGauss { matrix bvect } {
+ set norows [llength $matrix]
+ set nocols $norows
+
+ for { set i 0 } { $i < $nocols } { incr i } {
+ set sweep_row [getrow $matrix $i]
+ set bvect_sweep [getrow $bvect $i]
+ # No pivoting yet
+ set sweep_fact [expr {double([lindex $sweep_row $i])}]
+ for { set j [expr {$i+1}] } { $j < $norows } { incr j } {
+ set current_row [getrow $matrix $j]
+ set bvect_current [getrow $bvect $j]
+ set factor [expr {-[lindex $current_row $i]/$sweep_fact}]
+
+ lset matrix $j [axpy_vect $factor $sweep_row $current_row]
+ lset bvect $j [axpy_vect $factor $bvect_sweep $bvect_current]
+ }
+ }
+
+ return [solveTriangular $matrix $bvect]
+}
+# solvePGauss --
+# Solve a system of linear equations using Gauss elimination
+# with partial pivoting
+# Arguments:
+# matrix Matrix defining the coefficients
+# bvect Right-hand side (may be several columns)
+#
+# Result:
+# Solution of the system or an error in case of singularity
+# LAPACK : corresponds to DGETRS
+#
+proc ::math::linearalgebra::solvePGauss { matrix bvect } {
+
+ set ipiv [dgetrf matrix]
+ set norows [llength $matrix]
+ set nm1 [expr {$norows - 1}]
+
+ # Perform all permutations on b
+ for { set k 0 } { $k < $nm1 } { incr k } {
+ # Swap b(k) and b(mu) with mu = P(k)
+ set tmp [lindex $bvect $k]
+ set mu [lindex $ipiv $k]
+ setrow bvect $k [lindex $bvect $mu]
+ setrow bvect $mu $tmp
+ }
+
+ # Perform forward substitution
+ for { set k 0 } { $k < $nm1 } { incr k } {
+ set bk [lindex $bvect $k]
+ # Substitution
+ for { set iline [expr {$k+1}] } { $iline < $norows } { incr iline } {
+ set aik [lindex $matrix $iline $k]
+ set maik [expr {-1. * $aik}]
+ set bi [lindex $bvect $iline]
+ setrow bvect $iline [axpy $maik $bk $bi]
+ }
+ }
+
+ # Perform backward substitution
+ return [solveTriangular $matrix $bvect]
+}
+
+# solveTriangular --
+# Solve a system of linear equations where the matrix is
+# upper-triangular
+# Arguments:
+# matrix Matrix defining the coefficients
+# bvect Right-hand side (may be several columns)
+# uplo U if the matrix is upper triangular (default), L if the
+# matrix is lower triangular.
+#
+# Result:
+# Solution of the system or an error in case of singularity
+# LAPACK : corresponds to DTPTRS, but in the current command, the matrix
+# is in regular format (unpacked).
+#
+proc ::math::linearalgebra::solveTriangular { matrix bvect {uplo "U"}} {
+ set norows [llength $matrix]
+ set nocols $norows
+
+ switch -- $uplo {
+ "U" {
+ for { set i [expr {$norows-1}] } { $i >= 0 } { incr i -1 } {
+ set sweep_row [getrow $matrix $i]
+ set bvect_sweep [getrow $bvect $i]
+ set sweep_fact [expr {double([lindex $sweep_row $i])}]
+ set norm_fact [expr {1.0/$sweep_fact}]
+
+ lset bvect $i [scale $norm_fact $bvect_sweep]
+
+ for { set j [expr {$i-1}] } { $j >= 0 } { incr j -1 } {
+ set current_row [getrow $matrix $j]
+ set bvect_current [getrow $bvect $j]
+ set factor [expr {-[lindex $current_row $i]/$sweep_fact}]
+
+ lset bvect $j [axpy_vect $factor $bvect_sweep $bvect_current]
+ }
+ }
+ }
+ "L" {
+ for { set i 0 } { $i < $norows } { incr i } {
+ set sweep_row [getrow $matrix $i]
+ set bvect_sweep [getrow $bvect $i]
+ set sweep_fact [expr {double([lindex $sweep_row $i])}]
+ set norm_fact [expr {1.0/$sweep_fact}]
+
+ lset bvect $i [scale $norm_fact $bvect_sweep]
+
+ for { set j 0 } { $j < $i } { incr j } {
+ set bvect_current [getrow $bvect $i]
+ set bvect_sweep [getrow $bvect $j]
+ set factor [lindex $sweep_row $j]
+ set factor [expr { -1. * $factor * $norm_fact }]
+ lset bvect $i [axpy_vect $factor $bvect_sweep $bvect_current]
+ }
+ }
+ }
+ default {
+ error "Unknown value for parameter uplo : $uplo"
+ }
+ }
+ return $bvect
+}
+
+# solveGaussBand --
+# Solve a system of linear equations using Gauss elimination,
+# where the matrix is stored as a band matrix.
+# Arguments:
+# matrix Matrix defining the coefficients (in band form)
+# bvect Right-hand side (may be several columns)
+#
+# Result:
+# Solution of the system or an error in case of singularity
+#
+proc ::math::linearalgebra::solveGaussBand { matrix bvect } {
+ set norows [llength $matrix]
+ set nocols $norows
+ set nodiags [llength [lindex $matrix 0]]
+ set lowdiags [expr {($nodiags-1)/2}]
+
+ for { set i 0 } { $i < $nocols } { incr i } {
+ set sweep_row [getrow $matrix $i]
+ set bvect_sweep [getrow $bvect $i]
+
+ set sweep_fact [lindex $sweep_row [expr {$lowdiags-$i}]]
+
+ for { set j [expr {$i+1}] } { $j <= $lowdiags } { incr j } {
+ set sweep_row [concat [lrange $sweep_row 1 end] 0.0]
+ set current_row [getrow $matrix $j]
+ set bvect_current [getrow $bvect $j]
+ set factor [expr {-[lindex $current_row $i]/$sweep_fact}]
+
+ lset matrix $j [axpy_vect $factor $sweep_row $current_row]
+ lset bvect $j [axpy_vect $factor $bvect_sweep $bvect_current]
+ }
+ }
+
+ return [solveTriangularBand $matrix $bvect]
+}
+
+# solveTriangularBand --
+# Solve a system of linear equations where the matrix is
+# upper-triangular (stored as a band matrix)
+# Arguments:
+# matrix Matrix defining the coefficients (in band form)
+# bvect Right-hand side (may be several columns)
+#
+# Result:
+# Solution of the system or an error in case of singularity
+#
+proc ::math::linearalgebra::solveTriangularBand { matrix bvect } {
+ set norows [llength $matrix]
+ set nocols $norows
+ set nodiags [llength [lindex $matrix 0]]
+ set uppdiags [expr {($nodiags-1)/2}]
+ set middle [expr {($nodiags-1)/2}]
+
+ for { set i [expr {$norows-1}] } { $i >= 0 } { incr i -1 } {
+ set sweep_row [getrow $matrix $i]
+ set bvect_sweep [getrow $bvect $i]
+ set sweep_fact [lindex $sweep_row $middle]
+ set norm_fact [expr {1.0/$sweep_fact}]
+
+ lset bvect $i [scale $norm_fact $bvect_sweep]
+
+ for { set j [expr {$i-1}] } { $j >= $i-$middle && $j >= 0 } \
+ { incr j -1 } {
+ set current_row [getrow $matrix $j]
+ set bvect_current [getrow $bvect $j]
+ set k [expr {$i-$middle}]
+ set factor [expr {-[lindex $current_row $k]/$sweep_fact}]
+
+ lset bvect $j [axpy_vect $factor $bvect_sweep $bvect_current]
+ }
+ }
+
+ return $bvect
+}
+
+# determineSVD --
+# Determine the singular value decomposition of a matrix
+# Arguments:
+# A Matrix to be examined
+# epsilon Tolerance for the procedure (defaults to 2.3e-16)
+#
+# Result:
+# List of the three elements U, S and V, where:
+# U, V orthogonal matrices, S a diagonal matrix (here a vector)
+# such that A = USVt
+# Note:
+# This is taken directly from Hume's LA package, and adjusted
+# to fit the different matrix format. Also changes are applied
+# that can be found in the second edition of Nash's book
+# "Compact numerical methods for computers"
+#
+# To be done: transpose the algorithm so that we can work
+# on rows, rather than columns
+#
+proc ::math::linearalgebra::determineSVD { A {epsilon 2.3e-16} } {
+ foreach {m n} [shape $A] {break}
+ set tolerance [expr {$epsilon * $epsilon* $m * $n}]
+ set V [mkIdentity $n]
+
+ #
+ # Top of the iteration
+ #
+ set count 1
+ for {set isweep 0} {$isweep < 30 && $count > 0} {incr isweep} {
+ set count [expr {$n*($n-1)/2}] ;# count of rotations in a sweep
+ for {set j 0} {$j < [expr {$n-1}]} {incr j} {
+ for {set k [expr {$j+1}]} {$k < $n} {incr k} {
+ set p [set q [set r 0.0]]
+ for {set i 0} {$i < $m} {incr i} {
+ set Aij [lindex $A $i $j]
+ set Aik [lindex $A $i $k]
+ set p [expr {$p + $Aij*$Aik}]
+ set q [expr {$q + $Aij*$Aij}]
+ set r [expr {$r + $Aik*$Aik}]
+ }
+ if { $q < $r } {
+ set c 0.0
+ set s 1.0
+ } elseif { $q * $r == 0.0 } {
+ # Underflow of small elements
+ incr count -1
+ continue
+ } elseif { ($p*$p)/($q*$r) < $tolerance } {
+ # Cols j,k are orthogonal
+ incr count -1
+ continue
+ } else {
+ set q [expr {$q-$r}]
+ set v [expr {sqrt(4.0*$p*$p + $q*$q)}]
+ set c [expr {sqrt(($v+$q)/(2.0*$v))}]
+ set s [expr {-$p/($v*$c)}]
+ # s == sine of rotation angle, c == cosine
+ # Note: -s in comparison with original LA!
+ }
+ #
+ # Rotation of A
+ #
+ set colj [getcol $A $j]
+ set colk [getcol $A $k]
+ foreach {colj colk} [rotate $c $s $colj $colk] {break}
+ setcol A $j $colj
+ setcol A $k $colk
+ #
+ # Rotation of V
+ #
+ set colj [getcol $V $j]
+ set colk [getcol $V $k]
+ foreach {colj colk} [rotate $c $s $colj $colk] {break}
+ setcol V $j $colj
+ setcol V $k $colk
+ } ;#k
+ } ;# j
+ #puts "pass=$isweep skipped rotations=$count"
+ } ;# isweep
+
+ set S {}
+ for {set j 0} {$j < $n} {incr j} {
+ set q [norm_two [getcol $A $j]]
+ lappend S $q
+ if { $q >= $tolerance } {
+ set newcol [scale [expr {1.0/$q}] [getcol $A $j]]
+ setcol A $j $newcol
+ }
+ } ;# j
+
+ #
+ # Prepare the output
+ #
+ set U $A
+
+ if { $m < $n } {
+ set U {}
+ incr m -1
+ foreach row $A {
+ lappend U [lrange $row 0 $m]
+ }
+ #puts $U
+ }
+ return [list $U $S $V]
+}
+
+# eigenvectorsSVD --
+# Determine the eigenvectors and eigenvalues of a real
+# symmetric matrix via the SVD
+# Arguments:
+# A Matrix to be examined
+# eps Tolerance for the procedure (defaults to 2.3e-16)
+#
+# Result:
+# List of the matrix of eigenvectors and the vector of corresponding
+# eigenvalues
+# Note:
+# This is taken directly from Hume's LA package, and adjusted
+# to fit the different matrix format. Also changes are applied
+# that can be found in the second edition of Nash's book
+# "Compact numerical methods for computers"
+#
+proc ::math::linearalgebra::eigenvectorsSVD { A {eps 2.3e-16} } {
+ foreach {m n} [shape $A] {break}
+ if { $m != $n } {
+ return -code error "Expected a square matrix"
+ }
+
+ #
+ # Determine the shift h so that the matrix A+hI is positive
+ # definite (the Gershgorin region)
+ #
+ set h {}
+ set i 0
+ foreach row $A {
+ set aii [lindex $row $i]
+ set sum [expr {$aii + abs($aii) - [norm_one $row]}]
+ incr i
+
+ if { $h == {} || $sum < $h } {
+ set h $sum
+ }
+ }
+ if { $h <= $eps } {
+ set h [expr {$h - sqrt($eps)}]
+ # try to make smallest eigenvalue positive and not too small
+ set A [sub $A [scale_mat $h [mkIdentity $m]]]
+ } else {
+ set h 0.0
+ }
+
+ #
+ # Determine the SVD decomposition: this holds the
+ # eigenvectors and eigenvalues
+ #
+ foreach {U S V} [determineSVD $A $eps] {break}
+
+ #
+ # Rescale and flip signs if all negative or zero
+ #
+ for {set j 0} {$j < $n} {incr j} {
+ set s 0.0
+ set notpositive 0
+ for {set i 0} {$i < $n} {incr i} {
+ set Uij [lindex $U $i $j]
+ if { $Uij <= 0.0 } {
+ incr notpositive
+ }
+ set s [expr {$s + $Uij*$Uij}]
+ }
+ set s [expr {sqrt($s)}]
+ if { $notpositive == $n } {
+ set sf [expr {-$s}]
+ } else {
+ set sf $s
+ }
+ set colv [getcol $U $j]
+ setcol U $j [scale_vect [expr {1.0/$sf}] $colv]
+ }
+ for {set j 0} {$j < $n} {incr j} {
+ lset S $j [expr {[lindex $S $j] + $h}]
+ }
+ return [list $U $S]
+}
+
+# leastSquaresSVD --
+# Determine the solution to the least-squares problem Ax ~ y
+# via the singular value decomposition
+# Arguments:
+# A Matrix to be examined
+# y Dependent variable
+# qmin Minimum singular value to be considered (defaults to 0)
+# epsilon Tolerance for the procedure (defaults to 2.3e-16)
+#
+# Result:
+# Vector x as the solution of the least-squares problem
+#
+proc ::math::linearalgebra::leastSquaresSVD { A y {qmin 0.0} {epsilon 2.3e-16} } {
+
+ foreach {m n} [shape $A] {break}
+ foreach {U S V} [determineSVD $A $epsilon] {break}
+
+ set tol [expr {$epsilon * $epsilon * $n * $n}]
+ #
+ # form Utrans*y into g
+ #
+ set g {}
+ for {set j 0} {$j < $n} {incr j} {
+ set s 0.0
+ for {set i 0} {$i < $m} {incr i} {
+ set Uij [lindex $U $i $j]
+ set yi [lindex $y $i]
+ set s [expr {$s + $Uij*$yi}]
+ }
+ lappend g $s ;# g[j] = $s
+ }
+
+ #
+ # form VS+g = VS+Utrans*g
+ #
+ set x {}
+ for {set j 0} {$j < $n} {incr j} {
+ set s 0.0
+ for {set i 0} {$i < $n} {incr i} {
+ set zi [lindex $S $i]
+ if { $zi > $qmin } {
+ set Vji [lindex $V $j $i]
+ set gi [lindex $g $i]
+ set s [expr {$s + $Vji*$gi/$zi}]
+ }
+ }
+ lappend x $s
+ }
+ return $x
+}
+
+# choleski --
+# Determine the Choleski decomposition of a symmetric,
+# positive-semidefinite matrix (this condition is not checked!)
+#
+# Arguments:
+# matrix Matrix to be treated
+#
+# Result:
+# Lower-triangular matrix (L) representing the Choleski decomposition:
+# L Lt = matrix
+#
+proc ::math::linearalgebra::choleski { matrix } {
+ foreach {rows cols} [shape $matrix] {break}
+
+ set result $matrix
+
+ for { set j 0 } { $j < $cols } { incr j } {
+ if { $j > 0 } {
+ for { set i $j } { $i < $cols } { incr i } {
+ set sum [lindex $result $i $j]
+ for { set k 0 } { $k <= $j-1 } { incr k } {
+ set Aki [lindex $result $i $k]
+ set Akj [lindex $result $j $k]
+ set sum [expr {$sum-$Aki*$Akj}]
+ }
+ lset result $i $j $sum
+ }
+ }
+
+ #
+ # Take care of a singular matrix
+ #
+ if { [lindex $result $j $j] <= 0.0 } {
+ lset result $j $j 0.0
+ }
+
+ #
+ # Scale the column
+ #
+ set s [expr {sqrt([lindex $result $j $j])}]
+ for { set i 0 } { $i < $cols } { incr i } {
+ if { $i >= $j } {
+ if { $s == 0.0 } {
+ lset result $i $j 0.0
+ } else {
+ lset result $i $j [expr {[lindex $result $i $j]/$s}]
+ }
+ } else {
+ lset result $i $j 0.0
+ }
+ }
+ }
+
+ return $result
+}
+
+# orthonormalizeColumns --
+# Orthonormalize the columns of a matrix, using the modified
+# Gram-Schmidt method
+# Arguments:
+# matrix Matrix to be treated
+#
+# Result:
+# Matrix with pairwise orthogonal columns, each having length 1
+#
+proc ::math::linearalgebra::orthonormalizeColumns { matrix } {
+ transpose [orthonormalizeRows [transpose $matrix]]
+}
+
+# orthonormalizeRows --
+# Orthonormalize the rows of a matrix, using the modified
+# Gram-Schmidt method
+# Arguments:
+# matrix Matrix to be treated
+#
+# Result:
+# Matrix with pairwise orthogonal rows, each having length 1
+#
+proc ::math::linearalgebra::orthonormalizeRows { matrix } {
+ set result $matrix
+ set rowno 0
+ foreach r $matrix {
+ set newrow [unitLengthVector [getrow $result $rowno]]
+ setrow result $rowno $newrow
+ incr rowno
+ set rowno2 $rowno
+
+ #
+ # Update the matrix immediately: this is numerically
+ # more stable
+ #
+ foreach nextrow [lrange $result $rowno end] {
+ set factor [dotproduct $newrow $nextrow]
+ set nextrow [sub_vect $nextrow [scale_vect $factor $newrow]]
+ setrow result $rowno2 $nextrow
+ incr rowno2
+ }
+ }
+ return $result
+}
+
+# dger --
+# Performs the rank 1 operation alpha*x*y' + A
+# Arguments:
+# matrix name of the matrix to process (the matrix must be square)
+# alpha a real value
+# x a vector
+# y a vector
+# scope if not provided, the operation is performed on all rows/columns of A
+# if provided, it is expected to be the list [list imin imax jmin jmax]
+# where :
+# imin Minimum row index
+# imax Maximum row index
+# jmin Minimum column index
+# jmax Maximum column index
+#
+# Result:
+# Updated matrix
+# Level-3 BLAS : corresponds to DGER
+#
+proc ::math::linearalgebra::dger { matrix alpha x y {scope ""}} {
+ upvar $matrix mat
+ set nrows [llength $mat]
+ set ncols $nrows
+ if {$scope==""} then {
+ set imin 0
+ set imax [expr {$nrows - 1}]
+ set jmin 0
+ set jmax [expr {$ncols - 1}]
+ } else {
+ foreach {imin imax jmin jmax} $scope {break}
+ }
+ set xy [matmul $x $y]
+ set alphaxy [scale $alpha $xy]
+ for { set iline $imin } { $iline <= $imax } { incr iline } {
+ set ilineshift [expr {$iline - $imin}]
+ set matiline [lindex $mat $iline]
+ set alphailine [lindex $alphaxy $ilineshift]
+ for { set icol $jmin } { $icol <= $jmax } { incr icol } {
+ set icolshift [expr {$icol - $jmin}]
+ set aij [lindex $matiline $icol]
+ set shift [lindex $alphailine $icolshift]
+ setelem mat $iline $icol [expr {$aij + $shift}]
+ }
+ }
+ return $mat
+}
+# dgetrf --
+# Computes an LU factorization of a general matrix, using partial,
+# pivoting with row interchanges.
+#
+# Arguments:
+# matrix On entry, the matrix to be factored.
+# On exit, the factors L and U from the factorization
+# P*A = L*U; the unit diagonal elements of L are not stored.
+#
+# Result:
+# Returns the permutation vector, as a list of length n-1.
+# The last entry of the permutation is not stored, since it is
+# implicitely known, with value n (the last row is not swapped
+# with any other row).
+# At index #i of the permutation is stored the index of the row #j
+# which is swapped with row #i at step #i. That means that each
+# index of the permutation gives the permutation at each step, not the
+# cumulated permutation matrix, which is the product of permutations.
+# The factorization has the form
+# P * A = L * U
+# where P is a permutation matrix, L is lower triangular with unit
+# diagonal elements, and U is upper triangular.
+#
+# LAPACK : corresponds to DGETRF
+#
+proc ::math::linearalgebra::dgetrf { matrix } {
+ upvar $matrix mat
+ set norows [llength $mat]
+ set nocols $norows
+
+ # Initialize permutation
+ set nm1 [expr {$norows - 1}]
+ set ipiv {}
+ # Perform Gauss transforms
+ for { set k 0 } { $k < $nm1 } { incr k } {
+ # Search pivot in column n, from lines k to n
+ set column [getcol $mat $k $k $nm1]
+ foreach {abspivot murel} [norm_max $column 1] {break}
+ # Shift mu, because max returns with respect to the column (k:n,k)
+ set mu [expr {$murel + $k}]
+ # Swap lines k and mu from columns 1 to n
+ swaprows mat $k $mu
+ set akk [lindex $mat $k $k]
+ # Store permutation
+ lappend ipiv $mu
+ # Store pivots for lines k+1 to n in columns k+1 to n
+ set kp1 [expr {$k+1}]
+ set akp1 [getcol $mat $k $kp1 $nm1]
+ set mult [expr {1. / double($akk)}]
+ set akp1 [scale $mult $akp1]
+ setcol mat $k $akp1 $kp1 $nm1
+ # Perform transform for lines k+1 to n
+ set akp1k [getcol $mat $k $kp1 $nm1]
+ set akkp1 [lrange [lindex $mat $k] $kp1 $nm1]
+ set scope [list $kp1 $nm1 $kp1 $nm1]
+ dger mat -1. $akp1k $akkp1 $scope
+ }
+ return $ipiv
+}
+
+# det --
+# Returns the determinant of the given matrix, based on PA=LU
+# decomposition (i.e. dgetrf).
+#
+# Arguments:
+# matrix The matrix values.
+# ipiv The pivots (optionnal).
+# If the pivots are not provided, a PA=LU decomposition
+# is performed.
+# If the pivots are provided, we assume that it
+# contains the pivots and that the matrix A contains the
+# L and U factors, as provided by dgterf.
+#
+# Result:
+# Returns the determinant
+#
+proc ::math::linearalgebra::det { matrix {ipiv ""}} {
+ if { $ipiv == "" } then {
+ set ipiv [dgetrf matrix]
+ }
+ set det 1.0
+ set norows [llength $matrix]
+ set i 0
+ foreach row $matrix {
+ set uu [lindex $row $i]
+ set det [expr {$det * $uu}]
+ if { $i < $norows - 1 } then {
+ set ii [lindex $ipiv $i]
+ if { $ii!=$i } then {
+ set det [expr {-1.0 * $det}]
+ }
+ }
+ incr i
+ }
+ return $det
+}
+
+# largesteigen --
+# Returns a list made of the largest eigenvalue (in magnitude)
+# and associated eigenvector.
+# Uses Power Method.
+#
+# Arguments:
+# matrix The matrix values.
+# tolerance The relative tolerance of the eigenvalue.
+# maxiter The maximum number of iterations
+#
+# Result:
+# Returns a list of two items, where the first item
+# is the eigenvalue and the second is the eigenvector.
+# Note
+# This is algorithm #7.3.3 of Golub & Van Loan.
+#
+proc ::math::linearalgebra::largesteigen { matrix {tolerance 1.e-8} {maxiter 10}} {
+ set norows [llength $matrix]
+ set q [mkVector $norows 1.0]
+ set lambda 1.0
+ for { set k 0 } { $k < $maxiter } { incr k } {
+ set z [matmul $matrix $q]
+ set zn [norm $z]
+ if { $zn == 0.0 } then {
+ return -code error "Cannot continue power method : matrix is singular"
+ }
+ set s [expr {1.0 / $zn}]
+ set q [scale $s $z]
+ set prod [matmul $matrix $q]
+ set lambda_old $lambda
+ set lambda [dotproduct $q $prod]
+ if { abs($lambda - $lambda_old) < $tolerance * abs($lambda_old) } then {
+ break
+ }
+ }
+ return [list $lambda $q]
+}
+
+# to_LA --
+# Convert a matrix or vector to the LA format
+# Arguments:
+# mv Matrix or vector to be converted
+#
+# Result:
+# List according to LA conventions
+#
+proc ::math::linearalgebra::to_LA { mv } {
+ foreach {rows cols} [shape $mv] {
+ if { $cols == {} } {
+ set cols 0
+ }
+ }
+
+ set result [list 2 $rows $cols]
+ foreach row $mv {
+ set result [concat $result $row]
+ }
+ return $result
+}
+
+# from_LA --
+# Convert a matrix or vector from the LA format
+# Arguments:
+# mv Matrix or vector to be converted
+#
+# Result:
+# List according to current conventions
+#
+proc ::math::linearalgebra::from_LA { mv } {
+ foreach {rows cols} [lrange $mv 1 2] {break}
+
+ if { $cols != 0 } {
+ set result {}
+ set elem2 2
+ for { set i 0 } { $i < $rows } { incr i } {
+ set elem1 [expr {$elem2+1}]
+ incr elem2 $cols
+ lappend result [lrange $mv $elem1 $elem2]
+ }
+ } else {
+ set result [lrange $mv 3 end]
+ }
+
+ return $result
+}
+
+#
+# Announce the package's presence
+#
+package provide math::linearalgebra 1.1.5
+
+if { 0 } {
+Te doen:
+behoorlijke testen!
+matmul
+solveGauss_band
+join_col, join_row
+kleinste-kwadraten met SVD en met Gauss
+PCA
+}
+
+if { 0 } {
+ set matrix {{1.0 2.0 -1.0}
+ {3.0 1.1 0.5}
+ {1.0 -2.0 3.0}}
+ set bvect {{1.0 2.0 -1.0}
+ {3.0 1.1 0.5}
+ {1.0 -2.0 3.0}}
+ puts [join [::math::linearalgebra::solveGauss $matrix $bvect] \n]
+ set bvect {{4.0 2.0}
+ {12.0 1.2}
+ {4.0 -2.0}}
+ puts [join [::math::linearalgebra::solveGauss $matrix $bvect] \n]
+}
+
+if { 0 } {
+
+ set vect1 {1.0 2.0}
+ set vect2 {3.0 4.0}
+ ::math::linearalgebra::axpy_vect 1.0 $vect1 $vect2
+ ::math::linearalgebra::add_vect $vect1 $vect2
+ puts [time {::math::linearalgebra::axpy_vect 1.0 $vect1 $vect2} 50000]
+ puts [time {::math::linearalgebra::axpy_vect 2.0 $vect1 $vect2} 50000]
+ puts [time {::math::linearalgebra::axpy_vect 1.0 $vect1 $vect2} 50000]
+ puts [time {::math::linearalgebra::axpy_vect 1.1 $vect1 $vect2} 50000]
+ puts [time {::math::linearalgebra::add_vect $vect1 $vect2} 50000]
+}
+
+if { 0 } {
+ set M {{1 2} {2 1}}
+ puts "[::math::linearalgebra::determineSVD $M]"
+}
+if { 0 } {
+ set M {{1 2} {2 1}}
+ puts "[::math::linearalgebra::normMatrix $M]"
+}
+if { 0 } {
+ set M {{1.3 2.3} {2.123 1}}
+ puts "[::math::linearalgebra::show $M]"
+ set M {{1.3 2.3 45 3.} {2.123 1 5.6 0.01}}
+ puts "[::math::linearalgebra::show $M]"
+ puts "[::math::linearalgebra::show $M %12.4f]"
+}
+if { 0 } {
+ set M {{1 0 0}
+ {1 1 0}
+ {1 1 1}}
+ puts [::math::linearalgebra::orthonormalizeRows $M]
+}
+if { 0 } {
+ set M [::math::linearalgebra::mkMoler 5]
+ puts [::math::linearalgebra::choleski $M]
+}
+if { 0 } {
+ set M [::math::linearalgebra::mkRandom 20]
+ set b [::math::linearalgebra::mkVector 20]
+ puts "Gauss A = LU"
+ puts [time {::math::linearalgebra::solveGauss $M $b} 5]
+ puts "Gauss PA = LU"
+ puts [time {::math::linearalgebra::solvePGauss $M $b} 5]
+ # Gauss A = LU
+ # 7607.4 microseconds per iteration
+ # Gauss PA = LU
+ # 17428.4 microseconds per iteration
+}
diff --git a/tcllib/modules/math/linalg.test b/tcllib/modules/math/linalg.test
new file mode 100755
index 0000000..7bd9b90
--- /dev/null
+++ b/tcllib/modules/math/linalg.test
@@ -0,0 +1,855 @@
+# -*- tcl -*-
+# linalg.test --
+# Tests for the linear algebra package
+#
+# NOTE:
+# Comparison by numbers, not strings, needed!
+#
+# TODO:
+# Tests for:
+# - show, angle
+# - solveGaussBand, solveTriangularBand
+# - mkHilbert and so on
+# - matmul
+
+# -------------------------------------------------------------------------
+
+set regular 1
+
+if {$regular==1} then {
+ source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+ testsNeedTcl 8.4
+ testsNeedTcltest 2.1
+
+ support {
+ useLocal math.tcl math
+ }
+ testing {
+ useLocal linalg.tcl math::linearalgebra
+ }
+
+} else {
+ package require tcltest
+ tcltest::configure -verbose {start body error pass}
+ #tcltest::configure -match largesteigen-*
+ namespace import tcltest::test
+ namespace import tcltest::customMatch
+ set basedir [file normalize [file dirname [info script]]]
+ set ::auto_path [linsert $::auto_path 0 $basedir]
+ package require -exact math::linearalgebra 1.1.3
+}
+# -------------------------------------------------------------------------
+
+namespace import -force ::math::linearalgebra::*
+
+set prec $::tcl_precision
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ set ::tcl_precision 17
+} else {
+ set ::tcl_precision 0
+}
+
+#
+# Returns 1 if the expected value is close to the actual value,
+# that is their relative difference is small with respect to the
+# given epsilon.
+# If the expected value is zero, use an absolute error instead.
+#
+proc areClose {expected actual epsilon} {
+ if {$actual=="" && $expected!=""} then {
+ return 0
+ }
+ if {$actual!="" && $expected==""} then {
+ return 0
+ }
+ set match 1
+ if { [llength [lindex $expected 0]] > 1 } {
+ foreach a $actual e $expected {
+ set match [matchNumbers $e $a]
+ if { $match == 0 } {
+ break
+ }
+ }
+ } else {
+
+ foreach a $actual e $expected {
+ if {[string is double $a]==0 || [string is double $e]==0} then {
+ return 0
+ }
+ if {$e!=0.0} then {
+ set shift [expr {abs($a-$e)/abs($e)}]
+ } else {
+ set shift [expr {abs($a-$e)}]
+ }
+ #puts "a=$a, e=$e, shift = $shift"
+ if {$shift > $epsilon} {
+ set match 0
+ break
+ }
+ }
+ }
+ return $match
+}
+#
+# Matching procedure - flatten the lists
+#
+proc matchNumbers {expected actual} {
+ if {$actual=="" && $expected!=""} then {
+ return 0
+ }
+ if {$actual!="" && $expected==""} then {
+ return 0
+ }
+ set match 1
+ if { [llength [lindex $expected 0]] > 1 } {
+ foreach a $actual e $expected {
+ set match [matchNumbers $e $a]
+ if { $match == 0 } {
+ break
+ }
+ }
+ } else {
+
+ foreach a $actual e $expected {
+ if {[string is double $a]==0 || [string is double $e]==0} then {
+ return 0
+ }
+ if {abs($a-$e) > 0.1e-6} {
+ set match 0
+ break
+ }
+ }
+ }
+ return $match
+}
+
+customMatch numbers matchNumbers
+
+test dimshape-1.0 "dimension of scalar" -body {
+ dim 1
+} -result 0
+
+test dimshape-1.1 "dimension of vector" -body {
+ dim {1 2 3}
+} -result 1
+
+test dimshape-1.2 "dimension of matrix" -body {
+ dim { {1 2 3} {4 5 6} }
+} -result 2
+
+test dimshape-2.0 "shape of scalar" -body {
+ shape 1
+} -result {1}
+
+test dimshape-2.1 "shape of vector" -body {
+ shape {1 2 3}
+} -result 3
+
+test dimshape-2.2 "shape of matrix" -body {
+ shape { {1 2 3} {4 5 6} }
+} -result {2 3}
+
+test symmetric-1.0 "non-symmetric matrix" -body {
+ symmetric { {1 2 3} {4 5 6} {7 8 9}}
+} -result 0
+
+test symmetric-1.1 "symmetric matrix" -body {
+ symmetric { {1 2 3} {2 1 4} {3 4 1}}
+} -result 1
+
+test symmetric-1.2 "non-square matrix" -body {
+ symmetric { {1 2 3} {2 1 4}}
+} -result 0
+
+test norm-1.0 "one-norm - 5 components" -match numbers -body {
+ norm {1 2 3 0 -1} 1
+} -result 7.0
+
+test norm-1.1 "one-norm - 2 components" -match numbers -body {
+ norm {1 -1} 1
+} -result 2.0
+
+test norm-1.2 "two-norm - 5 components" -match numbers -body {
+ norm {1 2 3 0 -1} 2
+} -result [expr {sqrt(15)}]
+
+test norm-1.3 "two-norm - 2 components" -match numbers -body {
+ norm {1 -1} 2
+} -result [expr {sqrt(2)}]
+
+test norm-1.4 "two-norm - no underflow" -match numbers -body {
+ norm {3.0e-140 -4.0e-140} 2
+} -result 5.0e-140
+
+test norm-1.5 "two-norm - no overflow" -match numbers -body {
+ norm {3.0e140 -4.0e140} 2
+} -result 5.0e140
+
+test norm-1.6 "max-norm - 5 components" -match numbers -body {
+ norm {1 2 3 0 -4} max
+} -result 4
+
+test norm-1.7 "max-norm - 2 components" -match numbers -body {
+ norm {1 -1} max
+} -result 1
+
+test norm-2.0 "matrix-norm - 2x2 - max" -match numbers -body {
+ normMatrix {{1 -1} {1 1}} max
+} -result 1
+
+test norm-2.1 "matrix-norm - 2x2 - 1" -match numbers -body {
+ normMatrix {{1 -1} {1 1}} 1
+} -result 4
+
+test norm-2.2 "matrix-norm - 2x2 - 2" -match numbers -body {
+ normMatrix {{1 -1} {1 1}} 2
+} -result 2
+
+test norm-3.0 "statistical normalisation - vector" -match numbers -body {
+ normalizeStat {1 0 0 0}
+} -result {1.5 -0.5 -0.5 -0.5}
+
+test norm-3.1 "statistical normalisation - matrix" -match numbers -body {
+ normalizeStat {{1 0 0 0} {0 0 0 1} {0 1 1 0} {0 0 0 0}}
+} -result {{ 1.5 -0.5 -0.5 -0.5}
+ {-0.5 -0.5 -0.5 1.5}
+ {-0.5 1.5 1.5 -0.5}
+ {-0.5 -0.5 -0.5 -0.5}}
+
+test dotproduct-1.0" "dot-product - 2 components" -match numbers -body {
+ dotproduct {1 -1} {1 -1}
+} -result 2.0
+
+test dotproduct-1.1" "dot-product - 5 components" -match numbers -body {
+ dotproduct {1 2 3 4 5} {5 4 3 2 1}
+} -result [expr {5.0+8+9+8+5}]
+
+test unitlength-1.0" "unitlength - 2 components" -match numbers -body {
+ unitLengthVector {3 4}
+} -result {0.6 0.8}
+
+test unitlength-1.1" "unitlength - 4 components" -match numbers -body {
+ unitLengthVector {1 1 1 1}
+} -result {0.5 0.5 0.5 0.5}
+
+test axpy-1.0 "axpy - vectors" -body {
+ axpy 2 {1 -1} {2 -2}
+} -result {4 -4}
+
+test axpy-1.1 "axpy - matrices" -body {
+ axpy 2 { {1 -1} {2 -2} {3 4} {-3 4} } \
+ { {5 -5} {5 -5} {6 6} {-6 6} }
+} -result {{7 -7} {9 -9} {12 14} {-12 14}}
+
+test add-1.0 "add - vectors" -body {
+ add {1 -1} {2 -2}
+} -result {3 -3}
+
+test add-1.1 "add - matrices" -body {
+ add { {1 -1} {2 -2} {3 4} {-3 4} } \
+ { {5 -5} {5 -5} {6 6} {-6 6} }
+} -result {{6 -6} {7 -7} {9 10} {-9 10}}
+
+test sub-1.0 "sub - vectors" -body {
+ sub {1 -1} {2 -2}
+} -result {-1 1}
+
+test sub-1.1 "sub - matrices" -body {
+ sub { {1 -1} {2 -2} {3 4} {-3 4} } \
+ { {5 -5} {5 -5} {6 6} {-6 6} }
+} -result {{-4 4} {-3 3} {-3 -2} {3 -2}}
+
+test scale-1.0 "scale - vectors" -body {
+ scale 3 {2 -2}
+} -result {6 -6}
+
+test scale-1.1 "scale - matrices" -body {
+ scale 3 { {5 -5} {5 -5} {6 6} {-6 6} }
+} -result {{15 -15} {15 -15} {18 18} {-18 18}}
+
+test make-1.0 "mkVector - create a null vector" -body {
+ mkVector 3
+} -result {0.0 0.0 0.0}
+
+test make-1.1 "mkVector - create a vector with values 1" -body {
+ mkVector 3 1.0
+} -result {1.0 1.0 1.0}
+
+test make-2.0 "mkMatrix - create a matrix with 3 rows, 2 columns" -body {
+ mkMatrix 3 2 2.0
+} -result {{2.0 2.0} {2.0 2.0} {2.0 2.0}}
+
+test make-2.1 "mkMatrix - create a matrix with 2 rows, 3 columns" -body {
+ mkMatrix 2 3 1.0
+} -result {{1.0 1.0 1.0} {1.0 1.0 1.0}}
+
+test make-3.0 "mkIdentity - create an identity matrix 2x2" -body {
+ mkIdentity 2
+} -result {{1.0 0.0} {0.0 1.0}}
+
+test make-3.1 "mkIdentity - create an identity matrix 3x3" -body {
+ mkIdentity 3
+} -result {{1.0 0.0 0.0} {0.0 1.0 0.0} {0.0 0.0 1.0}}
+
+test make-4.0 "mkDiagonal - create a diagonal matrix 2x2" -body {
+ mkDiagonal {2.0 3.0}
+} -result {{2.0 0.0} {0.0 3.0}}
+
+test make-4.1 "mkDiagonal - create a diagonal matrix 3x3" -body {
+ mkDiagonal {2.0 3.0 4.0}
+} -result {{2.0 0.0 0.0} {0.0 3.0 0.0} {0.0 0.0 4.0}}
+
+test getset-1.0 "getrow - get first row from a matrix" -body {
+ getrow {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} 0
+} -result {1 2 3}
+
+test getset-1.1 "getrow - get last row from a matrix" -body {
+ getrow {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} 3
+} -result {10 11 12}
+
+test getset-1.1b "getrow - get row of a vector" -body {
+ getrow {1 2 3} 1
+} -result {2}
+test getset-1.1c "getrow - get row #1, for columns #2 to #3" -body {
+ getrow {{1 2 3 4 5 6} {7 8 9 10 11 12} {13 14 15 16 17 18}} 1 2 3
+} -result {9 10}
+
+test getset-1.2 "getcol - get first column from a matrix" -body {
+ getcol {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} 0
+} -result {1 4 7 10}
+
+test getset-1.3 "getcol - get last column from a matrix" -body {
+ getcol {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} 2
+} -result {3 6 9 12}
+test getset-1.4 "getcol - get column #1 from lines #2 to #3" -body {
+ getcol {{1 2 3} {4 5 6} {7 8 9} {10 11 12} {13 14 15}} 1 2 3
+} -result {8 11}
+
+test getset-2.0 "setrow - set first row in a matrix" -body {
+ set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12}}
+ setrow M 0 {3 2 1}
+} -result {{3 2 1} {4 5 6} {7 8 9} {10 11 12}}
+
+test getset-2.1 "setrow - set last row in a matrix" -body {
+ set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12}}
+ setrow M 3 {3 2 1}
+} -result {{1 2 3} {4 5 6} {7 8 9} {3 2 1}}
+
+test getset-2.1b "setrow - set row #1 from column #2 to column #3" -body {
+ set M {{1 2 3 4 5} {6 7 8 9 10} {11 12 13 14 15}}
+ setrow M 1 {99 100} 2 3
+} -result {{1 2 3 4 5} {6 7 99 100 10} {11 12 13 14 15}}
+
+test getset-2.2 "setcol - set first column in a matrix" -body {
+ set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12}}
+ setcol M 0 {3 2 1 0}
+} -result {{3 2 3} {2 5 6} {1 8 9} {0 11 12}}
+
+test getset-2.3 "setcol - set last column in a matrix" -body {
+ set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12}}
+ setcol M 2 {3 2 1 0}
+} -result {{1 2 3} {4 5 2} {7 8 1} {10 11 0}}
+
+test getset-2.4 "setcol - set column #1 from lines #2 to #3" -body {
+ set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12} {13 14 15}}
+ setcol M 1 {99 100} 2 3
+} -result {{1 2 3} {4 5 6} {7 99 9} {10 100 12} {13 14 15}}
+
+test getset-3.0 "getelem - get element (0,0) in a matrix" -body {
+ getelem {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} 0 0
+} -result 1
+
+test getset-3.1 "getelem - set element (1,2) in a matrix" -body {
+ getelem {{1 2 3} {4 5 6} {7 8 9} {10 11 12}} 1 2
+} -result 6
+
+test getset-3.2 "setelem - set element (0,0) in a matrix" -body {
+ set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12}}
+ setelem M 0 0 100
+} -result {{100 2 3} {4 5 6} {7 8 9} {10 11 12}}
+
+test getset-3.3 "setelem - set element (1,2) in a matrix" -body {
+ set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12}}
+ setelem M 1 2 100
+} -result {{1 2 3} {4 5 100} {7 8 9} {10 11 12}}
+
+test getset-4.0 "getelem - get element 1 from a vector" -body {
+ set V {1 2 3}
+ getelem $V 1
+} -result 2
+
+test getset-4.1 "setelem - set element 1 in a vector" -body {
+ set V {1 2 3}
+ setelem V 1 4
+} -result {1 4 3}
+
+test swaprows-1 "swap two rows of a matrix" -body {
+ set M {{1 2 3} {4 5 6} {7 8 9} {10 11 12}}
+ swaprows M 1 2
+} -result {{1 2 3} {7 8 9} {4 5 6} {10 11 12}}
+
+test swaprows-2 "swap rows #1 and #2 from columns #2 to #3" -body {
+ set M {{1 2 3 4 5} {6 7 8 9 10} {11 12 13 14 15} {16 17 18 19 20}}
+ swaprows M 1 2 2 3
+} -result {{1 2 3 4 5} {6 7 13 14 10} {11 12 8 9 15} {16 17 18 19 20}}
+
+test swapcols-1 "swap two columns of a matrix" -body {
+ set M {{1 2 3 4 5} {6 7 8 9 10} {11 12 13 14 15} {16 17 18 19 20}}
+ swapcols M 1 2
+} -result {{1 3 2 4 5} {6 8 7 9 10} {11 13 12 14 15} {16 18 17 19 20}}
+
+test swapcols-2 "swap columns #1 and #2 from lines #1 to #2" -body {
+ set M {{1 2 3 4 5} {6 7 8 9 10} {11 12 13 14 15} {16 17 18 19 20}}
+ swapcols M 1 2 1 2
+} -result {{1 2 3 4 5} {6 8 7 9 10} {11 13 12 14 15} {16 17 18 19 20}}
+
+test rotate-1.0 "rotate - over 90 degrees" -body {
+ set v1 {1 2 3}
+ set v2 {4 5 6}
+ rotate 0 1 $v1 $v2
+} -result {{-4 -5 -6} {1 2 3}}
+
+test rotate-1.1 "rotate - over 180 degrees" -body {
+ set v1 {1 2 3 4 5 6}
+ set v2 {7 8 9 10 11 12}
+ rotate -1 0 $v1 $v2
+} -result {{-1 -2 -3 -4 -5 -6} {-7 -8 -9 -10 -11 -12}}
+
+test matmul-1.0 "multiply matrix - vector" -match numbers -body {
+ set v1 {1 2 3}
+ set m {{0 0 1} {0 5 0} {-1 0 0}}
+ matmul $m $v1
+} -result {3 10 -1}
+
+test matmul-1.1 "multiply vector - matrix" -match numbers -body {
+ set v1 {{1 2 3}} ;# Row vector
+ set m {{0 0 1} {0 5 0} {-1 0 0}}
+ matmul $v1 $m
+} -result {{-3 10 1}}
+
+test matmul-1.2 "multiply matrix - matrix" -match numbers -body {
+ set m1 {{0 0 1} {0 5 0} {-1 0 0}}
+ set m2 {{0 0 1} {1 5 1} {-1 0 0}}
+ matmul $m1 $m2
+} -result {{-1 0 0} {5 25 5} {0 0 -1}}
+
+test matmul-1.3 "multiply vector - vector" -match numbers -body {
+ set v1 {1 2 3}
+ set v2 {4 5 6}
+ matmul $v1 $v2
+} -result {{4 5 6} {8 10 12} {12 15 18}}
+
+test matmul-1.4 "multiply row vector - column vector" -match numbers -body {
+ set v1 [transpose {1 2 3}]
+ set v2 {4 5 6}
+ matmul $v1 $v2
+} -result 32
+
+test matmul-1.5 "multiply column vector - row vector" -match numbers -body {
+ set v1 {1 2 3}
+ set v2 [transpose {4 5 6}]
+ matmul $v1 $v2
+} -result {{4 5 6} {8 10 12} {12 15 18}}
+
+test matmul-1.6 "multiply scalar - scalar" -match numbers -body {
+ set v1 {1}
+ set v2 {1}
+ matmul $v1 $v2
+} -result {1}
+
+test solve-1.1 "solveGauss - 2x2 matrix" -match numbers -body {
+ set b {{2 3} {-2 3}}
+ set M {{2 3} {-2 3}}
+ solveGauss $M $b
+} -result {{1 0} {0 1}}
+
+test solve-1.2 "solveGauss - 3x3 matrix" -match numbers -body {
+ set b {{2 3 4} {-2 3 4} {1 1 1}}
+ set M {{2 3 4} {-2 3 4} {1 1 1}}
+ solveGauss $M $b
+} -result {{1 0 0} {0 1 0} {0 0 1}}
+
+test solve-1.3 "solveGauss - 3x3 matrix - less trivial" -match numbers -body {
+ set b {{6 -3 6} {2 -3 2} {2 -1 2}}
+ set M {{2 3 4} {-2 3 4} {1 1 1}}
+ solveGauss $M $b
+} -result {{1 0 1} {0 -1 0} {1 0 1}}
+#
+# MB
+#
+test solve-1.4 "solveGauss - 3x3 matrix - but better pivots may be found" -match numbers -body {
+ set b {{67 67} {4 4} {6 6}}
+ set M {{3 17 10} {2 4 -2} {6 18 -12}}
+ solveGauss $M $b
+} -result {{1 1} {2 2} {3 3}}
+
+test solve-1.5 "solveGauss - Hilbert matrix" -match numbers -body {
+ set expected [mkVector 10 1.0]
+ set M [mkHilbert 10]
+ # b is expected as a list of colums
+ set b [mkMatrix 10 1]
+ setcol b 0 [matmul $M $expected]
+ set computed [solveGauss $M $b]
+ set diff [sub $computed $expected]
+ set norm [normMatrix $diff max]
+ # Computed norm : 0.00043691152972824554
+ set result [expr {$norm<1.e-3}]
+} -result {1}
+
+test solvepgauss-1.6 "solveGauss - 2x2 difficult matrix with necessary permutations" -match numbers -body {
+ set M {{1.e-8 1} {1 1}}
+ set b [list [expr {1.+1.e-8}] 2.]
+ set computed [solveGauss $M $b]
+ set expected {1. 1.}
+ set diff [sub $computed $expected]
+ set norm [norm $diff max]
+ # Computed norm : 5.0247592753294157e-09
+ set result [expr {$norm<1.e-8}]
+} -result {1}
+
+test solvepgauss-1 "solvePGauss - 3x3 matrix with two permutations" -match numbers -body {
+ set b {{67} {4} {6}}
+ set M {{3 17 10} {2 4 -2} {6 18 -12}}
+ solvePGauss $M $b
+} -result {{1} {2} {3}}
+
+test solvepgauss-2 "solvePGauss - 3x3 matrix" -match numbers -body {
+ set b {{6 -3 6} {2 -3 2} {2 -1 2}}
+ set M {{2 3 4} {-2 3 4} {1 1 1}}
+ solvePGauss $M $b
+} -result {{1 0 1} {0 -1 0} {1 0 1}}
+
+test solvepgauss-3 "solvePGauss - 10x10 Hilbert matrix" -match numbers -body {
+ set expected [mkVector 10 1.0]
+ set M [mkHilbert 10]
+ # b is expected as a list of colums
+ set b [mkMatrix 10 1]
+ setcol b 0 [matmul $M $expected]
+ set computed [solvePGauss $M $b]
+ set diff [sub $computed $expected]
+ set norm [normMatrix $diff max]
+ # Computed norm : 0.00031339500191851499
+ set result [expr {$norm<1.e-3}]
+} -result {1}
+
+test solvepgauss-4 "solvePGauss - 2x2 difficult matrix with necessary permutations" -match numbers -body {
+ set M {{1.e-8 1} {1 1}}
+ set b [list [expr {1.+1.e-8}] 2.]
+ set computed [solvePGauss $M $b]
+ set expected {1. 1.}
+ set diff [sub $computed $expected]
+ set norm [norm $diff max]
+ # Computed norm : 0.
+ set result [expr {$norm<1.e-15}]
+} -result {1}
+
+
+test orthon-1.0 "orthonormalize columns - 3x3" -match numbers -body {
+ set M {{1 1 1}
+ {0 1 1}
+ {0 0 1}}
+ orthonormalizeColumns $M
+} -result {{1 0 0}
+ {0 1 0}
+ {0 0 1}}
+
+test orthon-1.1 "orthonormalize rows - 3x3" -match numbers -body {
+ set M {{1 0 0}
+ {1 1 0}
+ {1 1 1}}
+ orthonormalizeRows $M
+} -result {{1 0 0}
+ {0 1 0}
+ {0 0 1}}
+
+test orthon-1.2 "orthonormalize rows - 3x4" -match numbers -body {
+ set M {{1 0 0 0}
+ {1 1 0 0}
+ {1 1 1 0}}
+ orthonormalizeRows $M
+} -result {{1 0 0 0}
+ {0 1 0 0}
+ {0 0 1 0}}
+
+#
+# The results from the original LA package have been used
+# as a benchmark:
+#
+#
+test svd-1.0 "singular value decomposition - 2x2" -match numbers -body {
+ set M {{1.0 2.0} {2.0 1.0}}
+ determineSVD $M
+} -result {
+{{0.70710678118654757 0.70710678118654746}
+ {0.70710678118654746 -0.70710678118654757}}
+ {3.0 1.0}
+{{0.70710678118654757 -0.70710678118654746}
+ {0.70710678118654746 0.70710678118654757}}
+}
+
+test svd-1.1 "singular value decomposition - 10x10" -match numbers -body {
+ set M [mkDingdong 10]
+ show [lindex [determineSVD $M] 1] %6.4f
+} -result {1.5708 1.5708 1.5708 1.5708 1.5708 1.5707 1.5695 1.5521 1.3935 0.6505}
+
+
+
+
+test LA-1.0 "to_LA - vector" -match numbers -body {
+ set vector {1 2 3}
+ to_LA $vector
+} -result {2 3 0 1 2 3}
+
+test LA-1.1 "to_LA - matrix" -match numbers -body {
+ set matrix {{1 2 3} {4 5 6} {7 8 9} {10 11 12}}
+ to_LA $matrix
+} -result {2 4 3 1 2 3 4 5 6 7 8 9 10 11 12}
+
+test LA-2.0 "from_LA - vector" -match numbers -body {
+ set vector {2 3 0 1 2 3}
+ from_LA $vector
+} -result {1 2 3}
+
+test LA-2.1 "from_LA - matrix" -match numbers -body {
+ set matrix {2 4 3 1 2 3 4 5 6 7 8 9 10 11 12}
+ from_LA $matrix
+} -result {{1 2 3} {4 5 6} {7 8 9} {10 11 12}}
+
+test choleski-1.0 "choleski decomposition of Moler matrix" -match numbers -body {
+ set matrix [mkMoler 5]
+ choleski $matrix
+} -result {{1 0 0 0 0} {-1 1 0 0 0} {-1 -1 1 0 0} {-1 -1 -1 1 0} {-1 -1 -1 -1 1}}
+
+test leastsquares-1.0 "Least-squares solution" -match numbers -body {
+ #
+ # Known relation: z = 1.0 + x + 0.1*y
+ # Model this as: z = z0 + x + 0.1*y
+ # (The column of 1s allows us to use a non-zero intercept)
+ #
+ # z0 x y z
+ set Ab { { 1 1.0 1.0} 2.1
+ { 1 2.0 1.0} 3.1
+ { 1 2.0 2.0} 3.2
+ { 1 4.0 2.0} 5.2
+ { 1 4.0 22.0} 7.2
+ { 1 5.0 -2.0} 5.8 }
+
+ set A {}
+ set b {}
+ foreach {Ar br} $Ab {
+ lappend A $Ar
+ lappend b $br
+ }
+ set x [::math::linearalgebra::leastSquaresSVD $A $b]
+} -result {1.0 1.0 0.1}
+
+
+test eigenvectors-1.0 "Eigenvectors solution" -match numbers -body {
+ #
+ # Matrix:
+ # /2 1\
+ # \1 2/
+ # has eigenvalues 3 and 1 with eigenvectors:
+ # / 1\ /1\
+ # \-1/ and \1/
+ # (so include a factor 1/sqrt(2) in the answer)
+ #
+ set A { {2 1}
+ {1 2} } ;# Note: integer coefficients!
+
+ ::math::linearalgebra::eigenvectorsSVD $A
+} -cleanup {
+ unset A
+} -result {{{0.7071068 -0.7071068} {0.7071068 0.7071068}} {3.0 1.0}}
+
+test eigenvectors-1.1-tkt7f082f8667 {Eigenvector signs} -setup {
+ # Test case derived from the example code found in ticket [7f082f8667].
+ set A {
+ {2.7563361585555084 0.02600440980933252 0.0}
+ {0.02600440980933252 2.785766824118953 0.0}
+ {0.0 0.0 -5.542102982674461}
+ }
+} -body {
+ lindex [::math::linearalgebra::eigenvectorsSVD $A] 1
+} -cleanup {
+ unset A
+} -match numbers -result {2.80093075418638 2.7411722284880806 -5.542102982674461}
+
+
+test mkHilbert-1.0 "Hilbert matrix" -match numbers -body {
+ set computed [mkHilbert 3]
+ set expected {{1.0 0.5 0.333333333333} {0.5 0.333333333333 0.25} {0.333333333333 0.25 0.2}}
+ set diff [sub $computed $expected]
+ set norm [normMatrix $diff max]
+ set result [expr {$norm<1.e-10}]
+} -result {1}
+
+test dger-1 "dger" -match numbers -body {
+ set M {{1 2 3} {4 5 6} {7 8 9}}
+ set x {1 2 3}
+ set y {4 5 6}
+ set alpha -1.
+ dger M $alpha $x $y
+} -result {{-3 -3 -3} {-4 -5 -6} {-5 -7 -9}}
+
+test dger-2 "dger" -match numbers -body {
+ set M {{1 2 3 4 5} {6 7 8 9 10} {11 12 13 14 15} {16 17 18 19 20}}
+ set x {1 2 3}
+ set y {4 5 6}
+ set alpha -1.
+ set imin 1
+ set imax 3
+ set jmin 2
+ set jmax 4
+ set scope [list $imin $imax $jmin $jmax]
+ dger M $alpha $x $y $scope
+} -result {{1 2 3 4 5} {6 7 4 4 4} {11 12 5 4 3} {16 17 6 4 2}}
+
+test dgetrf-1 "dgetrf" -body {
+ set M {{3 17 10} {2 4 -2} {6 18 -12}}
+ set ipiv [dgetrf M]
+ # Check matrix
+ set expectedmat {{6 18 -12} {0.5 8.0 16.0} {0.33333333333333331 -0.25 6.0}}
+ set diff [sub $M $expectedmat]
+ set norm [normMatrix $diff max]
+ set expectation1 [expr {$norm<1.e-10}]
+ # Check pivots
+ set expectedpivots {2 2}
+ set diff [sub $ipiv $expectedpivots]
+ set norm [normMatrix $diff max]
+ set expectation2 [expr {$norm<1.e-10}]
+ set result [list $expectation1 $expectation2]
+} -result {1 1}
+
+test solvetriangular-1 "upper triangular matrix" -match numbers -body {
+ set M {{3 17 10} {0 4 -2} {0 0 -12}}
+ set b {{67 30} {2 2} {-36 -12}}
+ set computed [solveTriangular $M $b]
+} -result {{1 1} {2 1} {3 1}}
+
+test solvetriangular-2 "lower triangular matrix" -match numbers -body {
+ set M {{3 0 0} {2 4 0} {6 18 -12}}
+ set b {{3 3} {10 6} {6 12}}
+ set computed [solveTriangular $M $b "L"]
+} -result {{1 1} {2 1} {3 1}}
+
+test solvetriangular-3 "lower triangular random matrix" -match numbers -body {
+ set M [mkTriangular 10 "L" 1.]
+ set xexpected [mkVector 10 1.]
+ set b [matmul $M $xexpected]
+ set computed [solveTriangular $M $b "L"]
+} -result {1 1 1 1 1 1 1 1 1 1}
+
+test solvetriangular-4 "upper triangular random matrix" -match numbers -body {
+ set M [mkTriangular 10 "U" 1.]
+ set xexpected [mkVector 10 1.]
+ set b [matmul $M $xexpected]
+ set computed [solveTriangular $M $b "U"]
+} -result {1 1 1 1 1 1 1 1 1 1}
+
+
+test mkTriangular-1 "make triangular matrix" -match numbers -body {
+ mkTriangular 3
+} -result {{1.0 1.0 1.0} {0. 1.0 1.0} {0. 0. 1.0}}
+
+test mkTriangular-2 "make triangular matrix" -match numbers -body {
+ mkTriangular 3 "L" 2.
+} -result {{2. 0. 0.} {2. 2. 0.} {2. 2. 2.}}
+
+test mkBorder "make border matrix" -match numbers -body {
+ mkBorder 5
+} -result {
+{1.0 0.0 0.0 0.0 1.0}
+{0.0 1.0 0.0 0.0 0.5}
+{0.0 0.0 1.0 0.0 0.25}
+{0.0 0.0 0.0 1.0 0.125}
+{1.0 0.5 0.25 0.125 1.0}}
+
+test mkWilkinsonW- "make Wilkinson W- matrix" -match numbers -body {
+ mkWilkinsonW- 5
+} -result {
+{2.0 1.0 0.0 0.0 0.0}
+{1.0 1.0 1.0 0.0 0.0}
+{0.0 1.0 0.0 1.0 0.0}
+{0.0 0.0 1.0 -1.0 1.0}
+{0.0 0.0 0.0 1.0 -2.0}}
+
+test mkWilkinsonW+ "make Wilkinson W+ matrix" -match numbers -body {
+ mkWilkinsonW+ 7
+} -result {
+{3.0 1.0 0.0 0.0 0.0 0.0 0.0}
+{1.0 2.0 1.0 0.0 0.0 0.0 0.0}
+{0.0 1.0 1.0 1.0 0.0 0.0 0.0}
+{0.0 0.0 1.0 0.0 1.0 0.0 0.0}
+{0.0 0.0 0.0 1.0 1.0 1.0 0.0}
+{0.0 0.0 0.0 0.0 1.0 2.0 1.0}
+{0.0 0.0 0.0 0.0 0.0 1.0 3.0}}
+
+test det-1 "determinant" -match numbers -body {
+ set a [mkBorder 5]
+ set det [det $a]
+} -result {-0.328125}
+
+test det-2 "determinant" -match numbers -body {
+ set a [mkWilkinsonW+ 5]
+ set det [det $a]
+} -result {-4.0}
+test det-3 "determinant" -match numbers -body {
+ set a [mkWilkinsonW- 5]
+ set det [det $a]
+} -result {0.0}
+test det-4 "determinant with pre-computed decomposition" -match numbers -body {
+ set a [mkWilkinsonW- 5]
+ set ipiv [dgetrf a]
+ set det [det $a $ipiv]
+} -result {0.0}
+
+#set ::tcl_precision 17
+test largesteigen-1 "power method" -body {
+ set a {{-261 209 -49}
+ {-530 422 -98}
+ {-800 631 -144}}
+ set pm [largesteigen $a 1.e-8 200]
+ set eigval [lindex $pm 0]
+ set eigvec [lindex $pm 1]
+ set res {}
+ set expected {-0.2672612419124256177838 -0.5345224838248414656050 -0.8017837257372776305075}
+ lappend res -eigvec [areClose $expected $eigvec 1.e-8]
+ lappend res -eigval [areClose 10.0 $eigval 1.e-8]
+} -result {-eigvec 1 -eigval 1}
+test largesteigen-2 "power method" -body {
+ set a {{-261 209 -49}
+ {-530 422 -98}
+ {-800 631 -144}}
+ set pm [largesteigen $a]
+ set eigval [lindex $pm 0]
+ set eigvec [lindex $pm 1]
+ set res {}
+ set expected {-0.2672612419124256177838 -0.5345224838248414656050 -0.8017837257372776305075}
+ lappend res -eigvec [areClose $expected $eigvec 1.e-5]
+ lappend res -eigval [areClose 10.0 $eigval 1.e-5]
+} -result {-eigvec 1 -eigval 1}
+test largesteigen-3 "power method" -body {
+ set a {{0.0 0.0 0.0}
+ {0.0 0.0 0.0}
+ {0.0 0.0 0.0}}
+ catch {
+ set pm [largesteigen $a]
+ } errmsg
+ set errmsg
+} -result {Cannot continue power method : matrix is singular}
+
+# Additional tests: procedures by Federico Ferri
+#source ferri/ferri.test
+
+set ::tcl_precision $prec
+
+if {$regular==1} then {
+ testsuiteCleanup
+} else {
+ tcltest::cleanupTests
+}
+
diff --git a/tcllib/modules/math/liststat.tcl b/tcllib/modules/math/liststat.tcl
new file mode 100755
index 0000000..d7b2e14
--- /dev/null
+++ b/tcllib/modules/math/liststat.tcl
@@ -0,0 +1,95 @@
+# liststat.tcl --
+#
+# Set of operations on lists, meant for the statistics package
+#
+# version 0.1: initial implementation, january 2003
+
+namespace eval ::math::statistics {}
+
+# filter --
+# Filter a list based on whether an expression is true for
+# an element or not
+#
+# Arguments:
+# varname Name of the variable that represents the data in the
+# expression
+# data List to be filtered
+# expression (Logical) expression that is to be evaluated
+#
+# Result:
+# List of those elements for which the expression is true
+# TODO:
+# Substitute local variables in caller
+#
+proc ::math::statistics::filter { varname data expression } {
+ upvar $varname _x_
+ set result {}
+ set _x_ \$_x_
+ set expression [uplevel subst -nocommands [list $expression]]
+ foreach _x_ $data {
+ # FRINK: nocheck
+ if $expression {
+
+ lappend result $_x_
+ }
+ }
+ return $result
+}
+
+# map --
+# Map the elements of a list according to an expression
+#
+# Arguments:
+# varname Name of the variable that represents the data in the
+# expression
+# data List whose elements must be transformed (mapped)
+# expression Expression that is evaluated with $varname an
+# element in the list
+#
+# Result:
+# List of transformed elements
+#
+proc ::math::statistics::map { varname data expression } {
+ upvar $varname _x_
+ set result {}
+ set _x_ \$_x_
+ set expression [uplevel subst -nocommands [list $expression]]
+ foreach _x_ $data {
+ # FRINK: nocheck
+ lappend result [expr $expression]
+ }
+ return $result
+}
+
+# samplescount --
+# Count the elements in each sublist and return a list of counts
+#
+# Arguments:
+# varname Name of the variable that represents the data in the
+# expression
+# list List of lists
+# expression Expression in that is evaluated with $varname an
+# element in the sublist (defaults to "true")
+#
+# Result:
+# List of transformed elements
+#
+proc ::math::statistics::samplescount { varname list {expression 1} } {
+ upvar $varname _x_
+ set result {}
+ set _x_ \$_x_
+ set expression [uplevel subst -nocommands [list $expression]]
+ foreach data $list {
+ set number 0
+ foreach _x_ $data {
+ # FRINK: nocheck
+ if $expression {
+ incr number
+ }
+ }
+ lappend result $number
+ }
+ return $result
+}
+
+# End of list procedures
diff --git a/tcllib/modules/math/machineparameters.man b/tcllib/modules/math/machineparameters.man
new file mode 100755
index 0000000..1deb093
--- /dev/null
+++ b/tcllib/modules/math/machineparameters.man
@@ -0,0 +1,190 @@
+[comment {-*- tclrep -*- doctools manpage}]
+[manpage_begin tclrep/machineparameters n 1.0]
+[copyright {2008 Michael Baudin <michael.baudin@sourceforge.net>}]
+[moddesc tclrep]
+[require snit]
+[require math::machineparameters 0.1]
+
+[titledesc {Compute double precision machine parameters.}]
+
+[description]
+
+The [emph math::machineparameters] package
+is the Tcl equivalent of the DLAMCH LAPACK function.
+In floating point systems, a floating point number is represented
+by
+[example {
+x = +/- d1 d2 ... dt basis^e
+}]
+where digits satisfy
+[example {
+0 <= di <= basis - 1, i = 1, t
+}]
+with the convention :
+[list_begin itemized]
+[item] t is the size of the mantissa
+[item] basis is the basis (the "radix")
+[list_end]
+
+[para]
+
+ The [method compute] method computes all machine parameters.
+ Then, the [method get] method can be used to get each
+ parameter.
+ The [method print] method prints a report on standard output.
+
+[section EXAMPLE]
+
+In the following example, one compute the parameters of a desktop
+under Linux with the following Tcl 8.4.19 properties :
+
+[example {
+% parray tcl_platform
+tcl_platform(byteOrder) = littleEndian
+tcl_platform(machine) = i686
+tcl_platform(os) = Linux
+tcl_platform(osVersion) = 2.6.24-19-generic
+tcl_platform(platform) = unix
+tcl_platform(tip,268) = 1
+tcl_platform(tip,280) = 1
+tcl_platform(user) = <username>
+tcl_platform(wordSize) = 4
+}]
+
+ The following example creates a machineparameters object,
+ computes the properties and displays it.
+
+[example {
+ set pp [machineparameters create %AUTO%]
+ $pp compute
+ $pp print
+ $pp destroy
+}]
+
+ This prints out :
+
+[example {
+ Machine parameters
+ Epsilon : 1.11022302463e-16
+ Beta : 2
+ Rounding : proper
+ Mantissa : 53
+ Maximum exponent : 1024
+ Minimum exponent : -1021
+ Overflow threshold : 8.98846567431e+307
+ Underflow threshold : 2.22507385851e-308
+}]
+
+ That compares well with the results produced by Lapack 3.1.1 :
+
+[example {
+ Epsilon = 1.11022302462515654E-016
+ Safe minimum = 2.22507385850720138E-308
+ Base = 2.0000000000000000
+ Precision = 2.22044604925031308E-016
+ Number of digits in mantissa = 53.000000000000000
+ Rounding mode = 1.00000000000000000
+ Minimum exponent = -1021.0000000000000
+ Underflow threshold = 2.22507385850720138E-308
+ Largest exponent = 1024.0000000000000
+ Overflow threshold = 1.79769313486231571E+308
+ Reciprocal of safe minimum = 4.49423283715578977E+307
+}]
+
+ The following example creates a machineparameters object,
+ computes the properties and gets the epsilon for
+ the machine.
+
+[example {
+ set pp [machineparameters create %AUTO%]
+ $pp compute
+ set eps [$pp get -epsilon]
+ $pp destroy
+}]
+
+[section REFERENCES]
+
+[list_begin itemized]
+[item] "Algorithms to Reveal Properties of Floating-Point Arithmetic", Michael A. Malcolm, Stanford University, Communications of the ACM, Volume 15 , Issue 11 (November 1972), Pages: 949 - 951
+[item] "More on Algorithms that Reveal Properties of Floating, Point Arithmetic Units", W. Morven Gentleman, University of Waterloo, Scott B. Marovich, Purdue University, Communications of the ACM, Volume 17 , Issue 5 (May 1974), Pages: 276 - 277
+[list_end]
+
+[section {CLASS API}]
+
+[list_begin definitions]
+
+[call [cmd machineparameters] create [arg objectname] [opt [arg options]...]]
+
+The command creates a new machineparameters object and returns the fully
+qualified name of the object command as its result.
+
+[list_begin options]
+
+[opt_def -verbose [arg verbose]]
+
+Set this option to 1 to enable verbose logging.
+This option is mainly for debug purposes.
+The default value of [arg verbose] is 0.
+
+[list_end]
+
+[list_end]
+
+[section {OBJECT API}]
+
+[list_begin definitions]
+
+[call [arg objectname] [method configure] [opt [arg options]...]]
+
+The command configure the options of the object [arg objectname]. The options
+are the same as the static method [method create].
+
+[call [arg objectname] [method cget] [arg opt]]
+
+Returns the value of the option which name is [arg opt]. The options
+are the same as the method [method create] and [method configure].
+
+[call [arg objectname] [method destroy]]
+
+Destroys the object [arg objectname].
+
+[call [arg objectname] [method compute]]
+
+Computes the machine parameters.
+
+[call [arg objectname] [method get] [arg key]]
+
+Returns the value corresponding with given key.
+The following is the list of available keys.
+[list_begin itemized]
+[item] -epsilon : smallest value so that 1+epsilon>1 is false
+[item] -rounding : The rounding mode used on the machine.
+The rounding occurs when more than t digits would be required to
+represent the number.
+Two modes can be determined with the current system :
+"chop" means than only t digits are kept, no matter the value of the number
+"proper" means that another rounding mode is used, be it "round to nearest",
+"round up", "round down".
+[item] -basis : the basis of the floating-point representation.
+The basis is usually 2, i.e. binary representation (for example IEEE 754 machines),
+but some machines (like HP calculators for example) uses 10, or 16, etc...
+[item] -mantissa : the number of bits in the mantissa
+[item] -exponentmax : the largest positive exponent before overflow occurs
+[item] -exponentmin : the largest negative exponent before (gradual) underflow occurs
+[item] -vmax : largest positive value before overflow occurs
+[item] -vmin : largest negative value before (gradual) underflow occurs
+[list_end]
+
+[call [arg objectname] [method tostring]]
+
+Return a report for machine parameters.
+
+[call [arg objectname] [method print]]
+
+Print machine parameters on standard output.
+
+[list_end]
+
+[vset CATEGORY math]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/machineparameters.tcl b/tcllib/modules/math/machineparameters.tcl
new file mode 100755
index 0000000..97cdb92
--- /dev/null
+++ b/tcllib/modules/math/machineparameters.tcl
@@ -0,0 +1,377 @@
+# machineparameters.tcl --
+# Compute double precision machine parameters.
+#
+# Description
+# This the Tcl equivalent of the DLAMCH LAPCK function.
+# In floating point systems, a floating point number is represented
+# by
+# x = +/- d1 d2 ... dt basis^e
+# where digits satisfy
+# 0 <= di <= basis - 1, i = 1, t
+# with the convention :
+# - t is the size of the mantissa
+# - basis is the basis (the "radix")
+#
+# References
+#
+# "Algorithms to Reveal Properties of Floating-Point Arithmetic"
+# Michael A. Malcolm
+# Stanford University
+# Communications of the ACM
+# Volume 15 , Issue 11 (November 1972)
+# Pages: 949 - 951
+#
+# "More on Algorithms that Reveal Properties of Floating
+# Point Arithmetic Units"
+# W. Morven Gentleman, University of Waterloo
+# Scott B. Marovich, Purdue University
+# Communications of the ACM
+# Volume 17 , Issue 5 (May 1974)
+# Pages: 276 - 277
+#
+# Example
+#
+# In the following example, one compute the parameters of a desktop
+# under Linux with the following Tcl 8.4.19 properties :
+#
+#% parray tcl_platform
+#tcl_platform(byteOrder) = littleEndian
+#tcl_platform(machine) = i686
+#tcl_platform(os) = Linux
+#tcl_platform(osVersion) = 2.6.24-19-generic
+#tcl_platform(platform) = unix
+#tcl_platform(tip,268) = 1
+#tcl_platform(tip,280) = 1
+#tcl_platform(user) = <username>
+#tcl_platform(wordSize) = 4
+#
+# The following example creates a machineparameters object,
+# computes the properties and displays it.
+#
+# set pp [machineparameters create %AUTO%]
+# $pp compute
+# $pp print
+# $pp destroy
+#
+# This prints out :
+#
+# Machine parameters
+# Epsilon : 1.11022302463e-16
+# Beta : 2
+# Rounding : proper
+# Mantissa : 53
+# Maximum exponent : 1024
+# Minimum exponent : -1021
+# Overflow threshold : 8.98846567431e+307
+# Underflow threshold : 2.22507385851e-308
+#
+# That compares well with the results produced by Lapack 3.1.1 :
+#
+# Epsilon = 1.11022302462515654E-016
+# Safe minimum = 2.22507385850720138E-308
+# Base = 2.0000000000000000
+# Precision = 2.22044604925031308E-016
+# Number of digits in mantissa = 53.000000000000000
+# Rounding mode = 1.00000000000000000
+# Minimum exponent = -1021.0000000000000
+# Underflow threshold = 2.22507385850720138E-308
+# Largest exponent = 1024.0000000000000
+# Overflow threshold = 1.79769313486231571E+308
+# Reciprocal of safe minimum = 4.49423283715578977E+307
+#
+# Copyright 2008 Michael Baudin
+#
+package require snit
+package provide math::machineparameters 0.1
+
+snit::type machineparameters {
+ # Epsilon is the smallest value so that 1+epsilon>1 is false
+ variable epsilon 0
+ # basis is the basis of the floating-point representation.
+ # basis is usually 2, i.e. binary representation (for example IEEE 754 machines),
+ # but some machines (like HP calculators for example) uses 10, or 16, etc...
+ variable basis 0
+ # The rounding mode used on the machine.
+ # The rounding occurs when more than t digits would be required to
+ # represent the number.
+ # Two modes can be determined with the current system :
+ # "chop" means than only t digits are kept, no matter the value of the number
+ # "proper" means that another rounding mode is used, be it "round to nearest",
+ # "round up", "round down".
+ variable rounding ""
+ # the size of the mantissa
+ variable mantissa 0
+ # The first non-integer is A = 2^m with m is the
+ # smallest positive integer so that fl(A+1)=A
+ variable firstnoninteger 0
+ # Maximum number of iterations in loops
+ option -maxiteration 10000
+ # Set to 1 to enable verbose logging
+ option -verbose -default 0
+ # The largest positive exponent before overflow occurs
+ variable exponentmax 0
+ # The largest negative exponent before (gradual) underflow occurs
+ variable exponentmin 0
+ # Largest positive value before overflow occurs
+ variable vmax
+ # Largest negative value before (gradual) underflow occurs
+ variable vmin
+ #
+ # compute --
+ # Computes the machine parameters.
+ #
+ method compute {} {
+ $self log "compute"
+ $self computeepsilon
+ $self computefirstnoninteger
+ $self computebasis
+ $self computerounding
+ $self computemantissa
+ $self computeemax
+ $self computeemin
+ return ""
+ }
+ #
+ # computeepsilon --
+ # Find epsilon the minimum value for which 1.0 + epsilon > 1.0
+ #
+ method computeepsilon {} {
+ $self log "computeepsilon"
+ set factor 2.
+ set epsilon 0.5
+ for {set i 0} {$i<$options(-maxiteration)} {incr i} {
+ $self log "$i/$options(-maxiteration) : $epsilon"
+ set epsilon [expr {$epsilon / $factor}]
+ set inequality [expr {1.0+$epsilon>1.0}]
+ if {$inequality==0} then {
+ break
+ }
+ }
+ $self log "epsilon : $epsilon (after $i loops)"
+ return ""
+ }
+ #
+ # computefirstnoninteger --
+ # Compute the first positive non-integer real.
+ # It is the smallest a such that (a+1)-a is different from 1
+ #
+ method computefirstnoninteger {} {
+ $self log "computefirstnoninteger"
+ set firstnoninteger 2.
+ for {set i 0} {$i < $options(-maxiteration)} {incr i} {
+ $self log "$i/$options(-maxiteration) : $firstnoninteger"
+ set firstnoninteger [expr {2.*$firstnoninteger}]
+ set one [expr {($firstnoninteger+1.)-$firstnoninteger}]
+ if {$one!=1.} then {
+ break
+ }
+ }
+ $self log "Found firstnoninteger : $firstnoninteger"
+ return ""
+ }
+ #
+ # computebasis --
+ # Compute the basis (basis)
+ #
+ method computebasis {} {
+ $self log "computebasis"
+ #
+ # Compute b where b is the smallest real so that fl(a+b)> a,
+ # where a is the first non integer.
+ # Note :
+ # With floating point numbers, a+1==a !
+ # b is denoted by "B" in Malcolm's algorithm
+ #
+ set b 1
+ for {set i 0} {$i < $options(-maxiteration)} {incr i} {
+ $self log "$i/$options(-maxiteration) : $b"
+ set basis [expr {int(($firstnoninteger+$b)-$firstnoninteger)}]
+ if {$basis!=0.} then {
+ break
+ }
+ incr b
+ }
+ $self log "Found basis : $basis"
+ return ""
+ }
+ #
+ # computerounding --
+ # Compute the rounding mode.
+ # Note:
+ # This corresponds to DLAMCH implementation (DLAMC1 exactly).
+ #
+ method computerounding {} {
+ $self log "computerounding"
+ # Now determine whether rounding or chopping occurs, by adding a
+ # bit less than beta/2 and a bit more than beta/2 to a (=firstnoninteger).
+ set F [expr {$basis/2.0 - $basis/100.0}]
+ set C [expr {$F + $firstnoninteger}]
+ if {$C==$firstnoninteger} then {
+ set rounding "proper"
+ } else {
+ set rounding "chop"
+ }
+ set F [expr {$basis/2.0 + $basis/100.0}]
+ set C [expr {$F + $firstnoninteger}]
+ if {$rounding=="proper" && $C==$firstnoninteger} then {
+ set rounding "chop"
+ }
+ $self log "Found rounding : $rounding"
+ return ""
+ }
+ #
+ # computemantissa --
+ # Compute the mantissa size
+ #
+ method computemantissa {} {
+ $self log "computemantissa"
+ set a 1.
+ set mantissa 0
+ for {set i 0} {$i < $options(-maxiteration)} {incr i} {
+ incr mantissa
+ $self log "$i/$options(-maxiteration) : $mantissa"
+ set a [expr {$a * double($basis)}]
+ set one [expr {($a+1)-$a}]
+ if {$one!=1.} then {
+ break
+ }
+ }
+ $self log "Found mantissa : $mantissa"
+ return ""
+ }
+ #
+ # computeemax --
+ # Compute the maximum exponent before overflow
+ #
+ method computeemax {} {
+ $self log "computeemax"
+ set vmax 1.
+ set exponentmax 1
+ for {set i 0} {$i < $options(-maxiteration)} {incr i} {
+ $self log "Iteration #$i , exponentmax = $exponentmax, vmax = $vmax"
+ incr exponentmax
+ # Condition #1 : no exception is generated
+ set errflag [catch {
+ set new [expr {$vmax * $basis}]
+ }]
+ if {$errflag!=0} then {
+ break
+ }
+ # Condition #2 : one can recover the original number
+ if {$new / $basis != $vmax} then {
+ break
+ }
+ set vmax $new
+ }
+ incr exponentmax -1
+ $self log "Exponent maximum : $exponentmax"
+ $self log "Value maximum : $vmax"
+ return ""
+ }
+ #
+ # computeemin --
+ # Compute the minimum exponent before underflow
+ #
+ method computeemin {} {
+ $self log "computeemin"
+ set vmin 1.
+ set exponentmin 1
+ for {set i 0} {$i < $options(-maxiteration)} {incr i} {
+ $self log "Iteration #$i , exponentmin = $exponentmin, vmin = $vmin"
+ incr exponentmin -1
+ # Condition #1 : no exception is generated
+ set errflag [catch {
+ set new [expr {$vmin / $basis}]
+ }]
+ if {$errflag!=0} then {
+ break
+ }
+ # Condition #2 : one can recover the original number
+ if {$new * $basis != $vmin} then {
+ break
+ }
+ set vmin $new
+ }
+ incr exponentmin +1
+ # See in DMALCH.f, DLAMC2 relative to IEEE machines.
+ # TODO : what happens on non-IEEE machine ?
+ set exponentmin [expr {$exponentmin - 1 + $mantissa}]
+ set vmin [expr {$vmin * pow($basis,$mantissa-1)}]
+ $self log "Exponent minimum : $exponentmin"
+ $self log "Value minimum : $vmin"
+ return ""
+ }
+ #
+ # log --
+ # Puts the given message on standard output.
+ #
+ method log {msg} {
+ if {$options(-verbose)==1} then {
+ puts "(mp) $msg"
+ }
+ return ""
+ }
+ #
+ # get --
+ # Return value for key
+ #
+ method get {key} {
+ $self log "get $key"
+ switch -- $key {
+ -epsilon {
+ set result $epsilon
+ }
+ -rounding {
+ set result $rounding
+ }
+ -basis {
+ set result $basis
+ }
+ -mantissa {
+ set result $mantissa
+ }
+ -exponentmax {
+ set result $exponentmax
+ }
+ -exponentmin {
+ set result $exponentmin
+ }
+ -vmax {
+ set result $vmax
+ }
+ -vmin {
+ set result $vmin
+ }
+ default {
+ error "Unknown key $key"
+ }
+ }
+ return $result
+ }
+ #
+ # print --
+ # Print machine parameters on standard output
+ #
+ method print {} {
+ set str [$self tostring]
+ puts "$str"
+ return ""
+ }
+ #
+ # tostring --
+ # Return a report for machine parameters
+ #
+ method tostring {} {
+ set str ""
+ append str "Machine parameters\n"
+ append str "Epsilon : $epsilon\n"
+ append str "Basis : $basis\n"
+ append str "Rounding : $rounding\n"
+ append str "Mantissa : $mantissa\n"
+ append str "Maximum exponent before overflow : $exponentmax\n"
+ append str "Minimum exponent before underflow : $exponentmin\n"
+ append str "Overflow threshold : $vmax\n"
+ append str "Underflow threshold : $vmin\n"
+ return $str
+ }
+}
diff --git a/tcllib/modules/math/machineparameters.test b/tcllib/modules/math/machineparameters.test
new file mode 100755
index 0000000..a361b43
--- /dev/null
+++ b/tcllib/modules/math/machineparameters.test
@@ -0,0 +1,40 @@
+# machineparameters.test --
+# Unit tests for machineparameters.tcl
+#
+#
+# Copyright 2008 Michael Baudin
+#
+#
+# Startup unit tests
+#
+package require tcltest
+tcltest::configure -verbose {start body error pass}
+set basedir [file dirname [info script]]
+lappend ::auto_path $basedir
+package require math::machineparameters
+#
+# Check all parameters are there
+#
+tcltest::test checkall {check epsilon, rounding mode} {
+ set pp [machineparameters create %AUTO%]
+ $pp configure -verbose 0
+ $pp compute
+ set epsilon [$pp get -epsilon]
+ set rounding [$pp get -rounding]
+ set basis [$pp get -basis]
+ set mantissa [$pp get -mantissa]
+ set emax [$pp get -exponentmax]
+ #$pp print
+ $pp destroy
+ set res {}
+ # The following property on epsilon must hold false (yes : epsilon is THAT small !)
+ lappend res [expr {1.0+$epsilon>1.0}]
+ lappend res [expr {$rounding!=""}]
+ lappend res [expr {$basis> 1}]
+ lappend res [expr {$mantissa> 1}]
+} {0 1 1 1}
+#
+# Shutdown tests
+#
+tcltest::cleanupTests
+
diff --git a/tcllib/modules/math/math.man b/tcllib/modules/math/math.man
new file mode 100644
index 0000000..b49f304
--- /dev/null
+++ b/tcllib/modules/math/math.man
@@ -0,0 +1,126 @@
+[manpage_begin math n 1.2.5]
+[keywords math]
+[keywords statistics]
+[comment {-*- tcl -*- doctools manpage}]
+[moddesc {Tcl Math Library}]
+[titledesc {Tcl Math Library}]
+[category Mathematics]
+[require Tcl 8.2]
+[require math [opt 1.2.5]]
+[description]
+[para]
+
+The [package math] package provides utility math functions.
+[para]
+Besides a set of basic commands, available via the package [emph math],
+there are more specialised packages:
+
+[list_begin itemized]
+[item]
+[package math::bigfloat] - Arbitrary-precision floating-point
+arithmetic
+[item]
+[package math::bignum] - Arbitrary-precision integer arithmetic
+[item]
+[package math::calculus::romberg] - Robust integration methods for
+functions of one variable, using Romberg integration
+[item]
+[package math::calculus] - Integration of functions, solving ordinary
+differential equations
+[item]
+[package math::combinatorics] - Procedures for various combinatorial
+functions (for instance the Gamma function and "k out of n")
+[item]
+[package math::complexnumbers] - Complex number arithmetic
+[item]
+[package math::constants] - A set of well-known mathematical
+constants, such as Pi, E, and the golden ratio
+[item]
+[package math::fourier] - Discrete Fourier transforms
+[item]
+[package math::fuzzy] - Fuzzy comparisons of floating-point numbers
+[item]
+[package math::geometry] - 2D geometrical computations
+[item]
+[package math::interpolate] - Various interpolation methods
+[item]
+[package math::linearalgebra] - Linear algebra package
+[item]
+[package math::optimize] - Optimization methods
+[item]
+[package math::polynomials] - Polynomial arithmetic (includes families
+of classical polynomials)
+[item]
+[package math::rationalfunctions] - Arithmetic of rational functions
+[item]
+[package math::roman] - Manipulation (including arithmetic) of Roman
+numerals
+[item]
+[package math::special] - Approximations of special functions from
+mathematical physics
+[item]
+[package math::statistics] - Statistical operations and tests
+[list_end]
+
+[section "BASIC COMMANDS"]
+
+[list_begin definitions]
+
+[call [cmd ::math::cov] [arg value] [arg value] [opt [arg {value ...}]]]
+
+Return the coefficient of variation expressed as percent of two or
+more numeric values.
+
+[call [cmd ::math::integrate] [arg {list of xy value pairs}]]
+
+Return the area under a "curve" defined by a set of x,y pairs and the
+error bound as a list.
+
+[call [cmd ::math::fibonacci] [arg n]]
+
+Return the [arg n]'th Fibonacci number.
+
+[call [cmd ::math::max] [arg value] [opt [arg {value ...}]]]
+
+Return the maximum of one or more numeric values.
+
+[call [cmd ::math::mean] [arg value] [opt [arg {value ...}]]]
+
+Return the mean, or "average" of one or more numeric values.
+
+[call [cmd ::math::min] [arg value] [opt [arg {value ...}]]]
+
+Return the minimum of one or more numeric values.
+
+[call [cmd ::math::product] [arg value] [opt [arg {value ...}]]]
+
+Return the product of one or more numeric values.
+
+[call [cmd ::math::random] [opt [arg value1]] [opt [arg value2]]]
+
+Return a random number. If no arguments are given, the number is a
+floating point value between 0 and 1. If one argument is given, the
+number is an integer value between 0 and [arg value1]. If two
+arguments are given, the number is an integer value between
+
+[arg value1] and [arg value2].
+
+[call [cmd ::math::sigma] [arg value] [arg value] [opt [arg {value ...}]]]
+
+Return the population standard deviation of two or more numeric
+values.
+
+[call [cmd ::math::stats] [arg value] [arg value] [opt [arg {value ...}]]]
+
+Return the mean, standard deviation, and coefficient of variation (as
+percent) as a list.
+
+[call [cmd ::math::sum] [arg value] [opt [arg {value ...}]]]
+
+Return the sum of one or more numeric values.
+
+[list_end]
+
+[vset CATEGORY math]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/math.tcl b/tcllib/modules/math/math.tcl
new file mode 100644
index 0000000..aa173e0
--- /dev/null
+++ b/tcllib/modules/math/math.tcl
@@ -0,0 +1,44 @@
+# math.tcl --
+#
+# Main 'package provide' script for the package 'math'.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2002 by Kevin B. Kenny. All rights reserved.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tcl 8.2 ;# uses [lindex $l end-$integer]
+
+# @mdgen OWNER: tclIndex
+# @mdgen OWNER: misc.tcl
+# @mdgen OWNER: combinatorics.tcl
+
+namespace eval ::math {
+ # misc.tcl
+
+ namespace export cov fibonacci integrate
+ namespace export max mean min
+ namespace export product random sigma
+ namespace export stats sum
+ namespace export expectDouble expectInteger
+
+ # combinatorics.tcl
+
+ namespace export ln_Gamma factorial choose
+ namespace export Beta
+
+ # Set up for auto-loading
+
+ if { ![interp issafe {}]} {
+ variable home [file join [pwd] [file dirname [info script]]]
+ if {[lsearch -exact $::auto_path $home] == -1} {
+ lappend ::auto_path $home
+ }
+ } else {
+ source [file join [file dirname [info script]] misc.tcl]
+ source [file join [file dirname [info script]] combinatorics.tcl]
+ }
+
+ package provide [namespace tail [namespace current]] 1.2.5
+}
diff --git a/tcllib/modules/math/math.test b/tcllib/modules/math/math.test
new file mode 100644
index 0000000..a170cd2
--- /dev/null
+++ b/tcllib/modules/math/math.test
@@ -0,0 +1,279 @@
+# Tests for math library. -*- tcl -*-
+#
+# 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) 1998-2000 by Ajuba Solutions.
+# All rights reserved.
+#
+# RCS: @(#) $Id: math.test,v 1.22 2009/12/04 17:37:47 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal math.tcl math
+}
+
+# -------------------------------------------------------------------------
+#
+# Create and register (in that order!) custom matching procedures
+#
+proc matchTolerant { expected actual } {
+ set match 1
+ foreach a $actual e $expected {
+ if { abs($e-$a)>0.0001*abs($e) &&
+ abs($e-$a)>0.0001*abs($a) } {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+# tcltest 2.0-ism, we rely here only on 1.0 features
+#customMatch tolerant matchTolerant
+
+
+test math-1.1 {math::min, wrong num args} {
+ catch {math::min} msg
+ set msg
+} [tcltest::wrongNumArgs math::min {val args} 0]
+test math-1.2 {simple math::min} {
+ math::min 1
+} 1
+test math-1.3 {simple math::min} {
+ math::min 2 1
+} 1
+test math-1.4 {math::min} {
+ math::min 2 1 0
+} 0
+test math-1.5 {math::min with negative numbers} {
+ math::min 2 1 0 -10
+} -10
+test math-1.6 {math::min with floating point numbers} {
+ math::min 2 1 0 -10 -10.5
+} -10.5
+
+test math-2.1 {math::max, wrong num args} {
+ catch {math::max} msg
+ set msg
+} [tcltest::wrongNumArgs math::max {val args} 0]
+test math-2.2 {simple math::max} {
+ math::max 1
+} 1
+test math-2.3 {simple math::max} {
+ math::max 2 1
+} 2
+test math-2.4 {math::max} {
+ math::max 0 2 1 0
+} 2
+test math-2.5 {math::max with negative numbers} {
+ math::max 2 1 0 -10
+} 2
+test math-2.6 {math::max with floating point numbers} {
+ math::max 2 1 0 -10 10.5
+} 10.5
+
+test math-3.1 {math::mean, wrong num args} {
+ catch {math::mean} msg
+ set msg
+} [tcltest::wrongNumArgs math::mean {val args} 0]
+test math-3.2 {simple math::mean} {
+ math::mean 1
+} 1.0
+test math-3.3 {simple math::mean} {
+ math::mean 2 1
+} 1.5
+test math-3.4 {math::mean} {
+ math::mean 0 2 1 0
+} 0.75
+test math-3.5 {math::mean with negative numbers} {
+ math::mean 2 1 0 -11
+} -2.0
+test math-3.6 {math::mean with floating point numbers} {
+ matchTolerant 0.7 [math::mean 2 1 0 -10 10.5]
+} 1
+
+test math-4.1 {math::sum, wrong num args} {
+ catch {math::sum} msg
+ set msg
+} [tcltest::wrongNumArgs math::sum {val args} 0]
+test math-4.2 {math::sum} {
+ math::sum 1
+} 1
+test math-4.3 {math::sum} {
+ math::sum 1 2 3
+} 6
+test math-4.4 {math::sum} {
+ matchTolerant 1.6 [math::sum 0.1 0.2 0.3 1]
+} 1
+test math-4.5 {math::sum} {
+ math::sum -1 1
+} 0
+
+test math-5.1 {math::product, wrong num args} {
+ catch {math::product} msg
+ set msg
+} [tcltest::wrongNumArgs math::product {val args} 0]
+test math-5.2 {simple math::product} {
+ math::product 1
+} 1
+test math-5.3 {simple math::product} {
+ math::product 0 1 2 3 4 5 6 7
+} 0
+test math-5.4 {math::product} {
+ math::product 1 2 3 4 5
+} 120
+test math-5.5 {math::product with negative numbers} {
+ math::product 2 -10
+} -20
+test math-5.6 {math::product with floating point numbers} {
+ math::product 2 0.5
+} 1.0
+
+test math-6.1 {math::sigma, wrong num args} {
+ catch {math::sigma} msg
+ set msg
+} [tcltest::wrongNumArgs math::sigma {val1 val2 args} 0]
+test math-6.2 {simple math::sigma} {
+ catch {math::sigma 1} msg
+ set msg
+} [tcltest::wrongNumArgs math::sigma {val1 val2 args} 1]
+test math-6.3 {simple math::sigma} {
+ expr round([ math::sigma 100 120 ])
+} 14
+test math-6.4 {math::sigma} {
+ expr round([ math::sigma 100 110 100 100 ])
+} 5
+test math-6.5 {math::sigma with negative numbers} {
+ math::sigma 100 100 100 -100
+} 100.0
+test math-6.6 {math::sigma with floating point numbers} {
+ math::sigma 100 110 100 100.0
+} 5.0
+
+test math-7.1 {math::cov, wrong num args} {
+ catch {math::cov} msg
+ set msg
+} [tcltest::wrongNumArgs math::cov {val1 val2 args} 0]
+test math-7.2 {simple math::cov} {
+ catch {math::cov 1} msg
+ set msg
+} [tcltest::wrongNumArgs math::cov {val1 val2 args} 1]
+test math-7.3 {simple math::cov} {
+ math::cov 2 1
+} 100.0
+
+test math-7.4 {math::cov} {
+ if {![catch {
+ math::cov 0 2 1 0
+ } msg]} {
+ if { [string equal $msg Infinity] || [string equal $msg Inf] } {
+ set result ok
+ } else {
+ set result "result of cov was [list $msg],\
+ should be Infinity"
+ }
+ } else {
+ if { [string equal [lrange $::errorCode 0 1] {ARITH DOMAIN}] } {
+ set result ok
+ } else {
+ set result "error from cov was [list $::errorCode],\
+ should be {ARITH DOMAIN *}"
+ }
+ }
+ set result
+} ok
+test math-7.5 {math::cov with negative numbers} {
+ math::cov 100 100 100 -100
+} 200.0
+test math-7.6 {math::cov with floating point numbers} {
+ string range [ math::cov 100 110 100 100.0 ] 0 0
+} 4
+test math-7.7 {math::cov with zero mean} {
+ # Throw an error
+ catch {
+ math::cov 1 1 -2
+ } msg
+} 1
+
+test math-8.1 {math::stats, wrong num of args} {
+ catch { math::stats } msg
+ set msg
+} [tcltest::wrongNumArgs math::stats {val1 val2 args} 0]
+test math-8.2 {math::stats, wrong num of args} {
+ catch { math::stats 100 } msg
+ set msg
+} [tcltest::wrongNumArgs math::stats {val1 val2 args} 1]
+test math-8.3 { simple math::stats } {
+ foreach {a b c} [ math::stats 100 100 100 110 ] { break }
+ set a [ expr round($a) ]
+ set b [ expr round($b) ]
+ set c [ expr round($c) ]
+ list $a $b $c
+} {102 5 5}
+
+test math-9.1 { math::integrate, insufficient data points } {
+ catch { math::integrate {1 10 2 20 3 30 4 40} } msg
+ set msg
+} "at least 5 x,y pairs must be given"
+test math-9.2 { simple math::integrate } {
+ math::integrate {1 10 2 20 3 30 4 40 5 50 6 60 7 70 8 80 9 90 10 100}
+} {500.0 0.5}
+
+test math-10.1 { math::random } {
+ set result [expr round(srand(12345) * 1000)]
+ for {set i 0} {$i < 10} {incr i} {
+ lappend result [expr round([::math::random] * 1000)]
+ }
+ set result
+} {97 834 948 36 12 51 766 585 914 784 333}
+test math-10.2 { math::random value } {
+ set result {}
+ expr {srand(12345)}
+ for {set i 0} {$i < 10} {incr i} {
+ lappend result [::math::random 10]
+ }
+ set result
+} {8 9 0 0 0 7 5 9 7 3}
+test math-10.3 { math::random value value } {
+ set result {}
+ expr {srand(12345)}
+ for {set i 0} {$i < 10} {incr i} {
+ lappend result [::math::random 5 15]
+ }
+ set result
+} {13 14 5 5 5 12 10 14 12 8}
+test math-10.4 {math::random} {
+ list [catch {::math::random foo bar baz} msg] $msg
+} [list 1 "wrong # args: should be \"::math::random ?value1? ?value2?\""]
+
+test math-11.1 {math::fibonacci} {
+ set result {}
+ for {set i 0} {$i < 15} {incr i} {
+ lappend result [::math::fibonacci $i]
+ }
+ set result
+} [list 0 1 1 2 3 5 8 13 21 34 55 89 144 233 377]
+
+test math-12.1 {Safe Interpreter} {
+ ::safe::interpCreate safeInterp
+ #interp alias safeInterp puts {} puts
+
+ set result [interp eval safeInterp {
+ package require math
+ set result [math::cov 100 100 100 -100]
+ }]
+
+ interp delete safeInterp
+ set result
+} 200.0
+
+testsuiteCleanup
diff --git a/tcllib/modules/math/math_geometry.man b/tcllib/modules/math/math_geometry.man
new file mode 100644
index 0000000..65a2b81
--- /dev/null
+++ b/tcllib/modules/math/math_geometry.man
@@ -0,0 +1,456 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin math::geometry n 1.1.3]
+[keywords angle]
+[keywords distance]
+[keywords line]
+[keywords math]
+[keywords {plane geometry}]
+[keywords point]
+[copyright {2001 by Ideogramic ApS and other parties}]
+[copyright {2004 by Arjen Markus}]
+[copyright {2010 by Andreas Kupries}]
+[copyright {2010 by Kevin Kenny}]
+[moddesc {Tcl Math Library}]
+[titledesc {Geometrical computations}]
+[category Mathematics]
+[require Tcl [opt 8.3]]
+[require math::geometry [opt 1.1.3]]
+
+[description]
+[para]
+The [package math::geometry] package is a collection of functions for
+computations and manipulations on two-dimensional geometrical objects,
+such as points, lines and polygons.
+
+[para]
+The geometrical objects are implemented as plain lists of coordinates.
+For instance a line is defined by a list of four numbers, the x- and
+y-coordinate of a first point and the x- and y-coordinates of a second
+point on the line.
+
+[para]
+The various types of object are recognised by the number of coordinate
+pairs and the context in which they are used: a list of four elements
+can be regarded as an infinite line, a finite line segment but also
+as a polyline of one segment and a point set of two points.
+
+[para]
+Currently the following types of objects are distinguished:
+[list_begin itemized]
+[item]
+[emph point] - a list of two coordinates representing the x- and
+y-coordinates respectively.
+
+[item]
+[emph line] - a list of four coordinates, interpreted as the x- and
+y-coordinates of two distinct points on the line.
+
+[item]
+[emph "line segment"] - a list of four coordinates, interpreted as the
+x- and y-coordinates of the first and the last points on the line
+segment.
+
+[item]
+[emph "polyline"] - a list of an even number of coordinates,
+interpreted as the x- and y-coordinates of an ordered set of points.
+
+[item]
+[emph "polygon"] - like a polyline, but the implicit assumption is that
+the polyline is closed (if the first and last points do not coincide,
+the missing segment is automatically added).
+
+[item]
+[emph "point set"] - again a list of an even number of coordinates, but
+the points are regarded without any ordering.
+
+[list_end]
+
+[section "PROCEDURES"]
+
+The package defines the following public procedures:
+
+[list_begin definitions]
+
+[call [cmd ::math::geometry::+] [arg point1] [arg point2]]
+
+Compute the sum of the two vectors given as points and return it.
+The result is a vector as well.
+
+[call [cmd ::math::geometry::-] [arg point1] [arg point2]]
+
+Compute the difference (point1 - point2) of the two vectors
+given as points and return it. The result is a vector as well.
+
+[call [cmd ::math::geometry::p] [arg x] [arg y]]
+
+Construct a point from its coordinates and return it as the
+result of the command.
+
+[call [cmd ::math::geometry::distance] [arg point1] [arg point2]]
+
+Compute the distance between the two points and return it as the
+result of the command. This is in essence the same as
+
+[example {
+ math::geometry::length [math::geomtry::- point1 point2]
+}]
+
+[call [cmd ::math::geometry::length] [arg point]]
+
+Compute the length of the vector and return it as the
+result of the command.
+
+[call [cmd ::math::geometry::s*] [arg factor] [arg point]]
+
+Scale the vector by the factor and return it as the
+result of the command. This is a vector as well.
+
+[call [cmd ::math::geometry::direction] [arg angle]]
+
+Given the angle in degrees this command computes and returns
+the unit vector pointing into this direction. The vector for
+angle == 0 points to the right (up), and for angle == 90 up (north).
+
+[call [cmd ::math::geometry::h] [arg length]]
+
+Returns a horizontal vector on the X-axis of the specified length.
+Positive lengths point to the right (east).
+
+[call [cmd ::math::geometry::v] [arg length]]
+
+Returns a vertical vector on the Y-axis of the specified length.
+Positive lengths point down (south).
+
+[call [cmd ::math::geometry::between] [arg point1] [arg point2] [arg s]]
+
+Compute the point which is at relative distance [arg s] between the two
+points and return it as the result of the command. A relative distance of
+[const 0] returns [arg point1], the distance [const 1] returns [arg point2].
+Distances < 0 or > 1 extrapolate along the line between the two point.
+
+[call [cmd ::math::geometry::octant] [arg point]]
+
+Compute the octant of the circle the point is in and return it as the result
+of the command. The possible results are
+
+[list_begin enum]
+[enum] east
+[enum] northeast
+[enum] north
+[enum] northwest
+[enum] west
+[enum] southwest
+[enum] south
+[enum] southeast
+[list_end]
+
+Each octant is the arc of the circle +/- 22.5 degrees from the cardinal direction
+the octant is named for.
+
+[call [cmd ::math::geometry::rect] [arg nw] [arg se]]
+
+Construct a rectangle from its northwest and southeast corners and return
+it as the result of the command.
+
+[call [cmd ::math::geometry::nwse] [arg rect]]
+
+Extract the northwest and southeast corners of the rectangle and return
+them as the result of the command (a 2-element list containing the
+points, in the named order).
+
+[call [cmd ::math::geometry::angle] [arg line]]
+
+Calculate the angle from the positive x-axis to a given line
+(in two dimensions only).
+
+[list_begin arguments]
+[arg_def list line] Coordinates of the line
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::calculateDistanceToLine] [arg P] [arg line]]
+
+Calculate the distance of point P to the (infinite) line and return the
+result
+
+[list_begin arguments]
+[arg_def list P] List of two numbers, the coordinates of the point
+
+[arg_def list line] List of four numbers, the coordinates of two points
+on the line
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::calculateDistanceToLineSegment] [arg P] [arg linesegment]]
+
+Calculate the distance of point P to the (finite) line segment and
+return the result.
+
+[list_begin arguments]
+[arg_def list P] List of two numbers, the coordinates of the point
+
+[arg_def list linesegment] List of four numbers, the coordinates of the
+first and last points of the line segment
+[list_end]
+
+[para]
+
+[para]
+
+[call [cmd ::math::geometry::calculateDistanceToPolyline] [arg P] [arg polyline]]
+
+Calculate the distance of point P to the polyline and
+return the result. Note that a polyline needs not to be closed.
+
+[list_begin arguments]
+[arg_def list P] List of two numbers, the coordinates of the point
+
+[arg_def list polyline] List of numbers, the coordinates of the
+vertices of the polyline
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::calculateDistanceToPolygon] [arg P] [arg polygon]]
+
+Calculate the distance of point P to the polygon and
+return the result. If the list of coordinates is not closed (first and last
+points differ), it is automatically closed.
+
+[list_begin arguments]
+[arg_def list P] List of two numbers, the coordinates of the point
+
+[arg_def list polygon] List of numbers, the coordinates of the
+vertices of the polygon
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::findClosestPointOnLine] [arg P] [arg line]]
+
+Return the point on a line which is closest to a given point.
+
+[list_begin arguments]
+[arg_def list P] List of two numbers, the coordinates of the point
+
+[arg_def list line] List of four numbers, the coordinates of two points
+on the line
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::findClosestPointOnLineSegment] [arg P] [arg linesegment]]
+
+Return the point on a [emph "line segment"] which is closest to a given
+point.
+
+[list_begin arguments]
+[arg_def list P] List of two numbers, the coordinates of the point
+
+[arg_def list linesegment] List of four numbers, the first and last
+points on the line segment
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::findClosestPointOnPolyline] [arg P] [arg polyline]]
+
+Return the point on a [emph "polyline"] which is closest to a given
+point.
+
+[list_begin arguments]
+[arg_def list P] List of two numbers, the coordinates of the point
+
+[arg_def list polyline] List of numbers, the vertices of the polyline
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::lengthOfPolyline] [arg polyline]]
+
+Return the length of the [emph "polyline"] (note: it not regarded as a
+polygon)
+
+[list_begin arguments]
+[arg_def list polyline] List of numbers, the vertices of the polyline
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::movePointInDirection] [arg P] [arg direction] [arg dist]]
+
+Move a point over a given distance in a given direction and return the
+new coordinates (in two dimensions only).
+
+[list_begin arguments]
+[arg_def list P] Coordinates of the point to be moved
+[arg_def double direction] Direction (in degrees; 0 is to the right, 90
+upwards)
+[arg_def list dist] Distance over which to move the point
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::lineSegmentsIntersect] [arg linesegment1] [arg linesegment2]]
+
+Check if two line segments intersect or coincide. Returns 1 if that is
+the case, 0 otherwise (in two dimensions only). If an endpoint of one segment lies on
+the other segment (or is very close to the segment), they are considered to intersect
+
+[list_begin arguments]
+[arg_def list linesegment1] First line segment
+[arg_def list linesegment2] Second line segment
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::findLineSegmentIntersection] [arg linesegment1] [arg linesegment2]]
+
+Find the intersection point of two line segments. Return the coordinates
+or the keywords "coincident" or "none" if the line segments coincide or
+have no points in common (in two dimensions only).
+
+[list_begin arguments]
+[arg_def list linesegment1] First line segment
+[arg_def list linesegment2] Second line segment
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::findLineIntersection] [arg line1] [arg line2]]
+
+Find the intersection point of two (infinite) lines. Return the coordinates
+or the keywords "coincident" or "none" if the lines coincide or
+have no points in common (in two dimensions only).
+
+[list_begin arguments]
+[arg_def list line1] First line
+[arg_def list line2] Second line
+[list_end]
+
+See section [sectref References] for details on the algorithm and math behind it.
+
+[para]
+
+[call [cmd ::math::geometry::polylinesIntersect] [arg polyline1] [arg polyline2]]
+
+Check if two polylines intersect or not (in two dimensions only).
+
+[list_begin arguments]
+[arg_def list polyline1] First polyline
+[arg_def list polyline2] Second polyline
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::polylinesBoundingIntersect] [arg polyline1] [arg polyline2] [arg granularity]]
+
+Check whether two polylines intersect, but reduce
+the correctness of the result to the given granularity.
+Use this for faster, but weaker, intersection checking.
+[para]
+How it works:
+[para]
+Each polyline is split into a number of smaller polylines,
+consisting of granularity points each. If a pair of those smaller
+lines' bounding boxes intersect, then this procedure returns 1,
+otherwise it returns 0.
+
+[list_begin arguments]
+[arg_def list polyline1] First polyline
+[arg_def list polyline2] Second polyline
+[arg_def int granularity] Number of points in each part (<=1 means check
+every edge)
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::intervalsOverlap] [arg y1] [arg y2] [arg y3] [arg y4] [arg strict]]
+
+Check if two intervals overlap.
+
+[list_begin arguments]
+[arg_def double y1,y2] Begin and end of first interval
+[arg_def double y3,y4] Begin and end of second interval
+[arg_def logical strict] Check for strict or non-strict overlap
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::rectanglesOverlap] [arg P1] [arg P2] [arg Q1] [arg Q2] [arg strict]]
+
+Check if two rectangles overlap.
+
+[list_begin arguments]
+[arg_def list P1] upper-left corner of the first rectangle
+[arg_def list P2] lower-right corner of the first rectangle
+[arg_def list Q1] upper-left corner of the second rectangle
+[arg_def list Q2] lower-right corner of the second rectangle
+[arg_def list strict] choosing strict or non-strict interpretation
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::bbox] [arg polyline]]
+
+Calculate the bounding box of a polyline. Returns a list of four
+coordinates: the upper-left and the lower-right corner of the box.
+
+[list_begin arguments]
+[arg_def list polyline] The polyline to be examined
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::pointInsidePolygon] [arg P] [arg polyline]]
+
+Determine if a point is completely inside a polygon. If the point
+touches the polygon, then the point is not completely inside the
+polygon.
+
+[list_begin arguments]
+[arg_def list P] Coordinates of the point
+[arg_def list polyline] The polyline to be examined
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::rectangleInsidePolygon] [arg P1] [arg P2] [arg polyline]]
+
+Determine if a rectangle is completely inside a polygon. If polygon
+touches the rectangle, then the rectangle is not complete inside the
+polygon.
+
+[list_begin arguments]
+[arg_def list P1] Upper-left corner of the rectangle
+[arg_def list P2] Lower-right corner of the rectangle
+[para]
+[arg_def list polygon] The polygon in question
+[list_end]
+
+[para]
+
+[call [cmd ::math::geometry::areaPolygon] [arg polygon]]
+
+Calculate the area of a polygon.
+
+[list_begin arguments]
+[arg_def list polygon] The polygon in question
+[list_end]
+
+[list_end]
+
+[section References]
+
+[list_begin enumerated]
+[enum] [uri http:/wiki.tcl.tk/12070 {Polygon Intersection}]
+[enum] [uri http://en.wikipedia.org/wiki/Line-line_intersection]
+[enum] [uri http://local.wasp.uwa.edu.au/~pbourke/geometry/lineline2d/]
+[list_end]
+
+[vset CATEGORY {math :: geometry}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/misc.tcl b/tcllib/modules/math/misc.tcl
new file mode 100644
index 0000000..a1db91c
--- /dev/null
+++ b/tcllib/modules/math/misc.tcl
@@ -0,0 +1,385 @@
+# math.tcl --
+#
+# Collection of math functions.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: misc.tcl,v 1.6 2005/10/10 14:02:47 arjenmarkus Exp $
+
+package require Tcl 8.2 ;# uses [lindex $l end-$integer]
+namespace eval ::math {
+}
+
+# ::math::cov --
+#
+# Return the coefficient of variation of three or more values
+#
+# Arguments:
+# val1 first value
+# val2 second value
+# args other values
+#
+# Results:
+# cov coefficient of variation expressed as percent value
+
+proc ::math::cov {val1 val2 args} {
+ set sum [ expr { $val1+$val2 } ]
+ set N [ expr { [ llength $args ] + 2 } ]
+ foreach val $args {
+ set sum [ expr { $sum+$val } ]
+ }
+ set mean [ expr { $sum/$N } ]
+ set sigma_sq 0
+ foreach val [ concat $val1 $val2 $args ] {
+ set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
+ }
+ set sigma_sq [ expr { $sigma_sq/($N-1) } ]
+ set sigma [ expr { sqrt($sigma_sq) } ]
+ if { $mean != 0.0 } {
+ set cov [ expr { ($sigma/$mean)*100 } ]
+ } else {
+ return -code error -errorinfo "Cov undefined for data with zero mean" -errorcode {ARITH DOMAIN}
+ }
+ set cov
+}
+
+# ::math::fibonacci --
+#
+# Return the n'th fibonacci number.
+#
+# Arguments:
+# n The index in the sequence to compute.
+#
+# Results:
+# fib The n'th fibonacci number.
+
+proc ::math::fibonacci {n} {
+ if { $n == 0 } {
+ return 0
+ } else {
+ set prev0 0
+ set prev1 1
+ for {set i 1} {$i < $n} {incr i} {
+ set tmp $prev1
+ incr prev1 $prev0
+ set prev0 $tmp
+ }
+ return $prev1
+ }
+}
+
+# ::math::integrate --
+#
+# calculate the area under a curve defined by a set of (x,y) data pairs.
+# the x data must increase monotonically throughout the data set for the
+# calculation to be meaningful, therefore the monotonic condition is
+# tested, and an error is thrown if the x value is found to be
+# decreasing.
+#
+# Arguments:
+# xy_pairs list of x y pairs (eg, 0 0 10 10 20 20 ...); at least 5
+# data pairs are required, and if the number of data
+# pairs is even, a padding value of (x0, 0) will be
+# added.
+#
+# Results:
+# result A two-element list consisting of the area and error
+# bound (calculation is "Simpson's rule")
+
+proc ::math::integrate { xy_pairs } {
+
+ set length [ llength $xy_pairs ]
+
+ if { $length < 10 } {
+ return -code error "at least 5 x,y pairs must be given"
+ }
+
+ ;## are we dealing with x,y pairs?
+ if { [ expr {$length % 2} ] } {
+ return -code error "unmatched xy pair in input"
+ }
+
+ ;## are there an even number of pairs? Augment.
+ if { ! [ expr {$length % 4} ] } {
+ set xy_pairs [ concat [ lindex $xy_pairs 0 ] 0 $xy_pairs ]
+ }
+ set x0 [ lindex $xy_pairs 0 ]
+ set x1 [ lindex $xy_pairs 2 ]
+ set xn [ lindex $xy_pairs end-1 ]
+ set xnminus1 [ lindex $xy_pairs end-3 ]
+
+ if { $x1 < $x0 } {
+ return -code error "monotonicity broken by x1"
+ }
+
+ if { $xn < $xnminus1 } {
+ return -code error "monotonicity broken by xn"
+ }
+
+ ;## handle the assymetrical elements 0, n, and n-1.
+ set sum [ expr {[ lindex $xy_pairs 1 ] + [ lindex $xy_pairs end ]} ]
+ set sum [ expr {$sum + (4*[ lindex $xy_pairs end-2 ])} ]
+
+ set data [ lrange $xy_pairs 2 end-4 ]
+
+ set xmax $x1
+ set i 1
+ foreach {x1 y1 x2 y2} $data {
+ incr i
+ if { $x1 < $xmax } {
+ return -code error "monotonicity broken by x$i"
+ }
+ set xmax $x1
+ incr i
+ if { $x2 < $xmax } {
+ return -code error "monotonicity broken by x$i"
+ }
+ set xmax $x2
+ set sum [ expr {$sum + (4*$y1) + (2*$y2)} ]
+ }
+
+ if { $xmax > $xnminus1 } {
+ return -code error "monotonicity broken by xn-1"
+ }
+
+ set h [ expr { ( $xn - $x0 ) / $i } ]
+ set area [ expr { ( $h / 3.0 ) * $sum } ]
+ set err_bound [ expr { ( ( $xn - $x0 ) / 180.0 ) * pow($h,4) * $xn } ]
+ return [ list $area $err_bound ]
+}
+
+# ::math::max --
+#
+# Return the maximum of two or more values
+#
+# Arguments:
+# val first value
+# args other values
+#
+# Results:
+# max maximum value
+
+proc ::math::max {val args} {
+ set max $val
+ foreach val $args {
+ if { $val > $max } {
+ set max $val
+ }
+ }
+ set max
+}
+
+# ::math::mean --
+#
+# Return the mean of two or more values
+#
+# Arguments:
+# val first value
+# args other values
+#
+# Results:
+# mean arithmetic mean value
+
+proc ::math::mean {val args} {
+ set sum $val
+ set N [ expr { [ llength $args ] + 1 } ]
+ foreach val $args {
+ set sum [ expr { $sum + $val } ]
+ }
+ set mean [expr { double($sum) / $N }]
+}
+
+# ::math::min --
+#
+# Return the minimum of two or more values
+#
+# Arguments:
+# val first value
+# args other values
+#
+# Results:
+# min minimum value
+
+proc ::math::min {val args} {
+ set min $val
+ foreach val $args {
+ if { $val < $min } {
+ set min $val
+ }
+ }
+ set min
+}
+
+# ::math::product --
+#
+# Return the product of one or more values
+#
+# Arguments:
+# val first value
+# args other values
+#
+# Results:
+# prod product of multiplying all values in the list
+
+proc ::math::product {val args} {
+ set prod $val
+ foreach val $args {
+ set prod [ expr { $prod*$val } ]
+ }
+ set prod
+}
+
+# ::math::random --
+#
+# Return a random number in a given range.
+#
+# Arguments:
+# args optional arguments that specify the range within which to
+# choose a number:
+# (null) choose a number between 0 and 1
+# val choose a number between 0 and val
+# val1 val2 choose a number between val1 and val2
+#
+# Results:
+# num a random number in the range.
+
+proc ::math::random {args} {
+ set num [expr {rand()}]
+ if { [llength $args] == 0 } {
+ return $num
+ } elseif { [llength $args] == 1 } {
+ return [expr {int($num * [lindex $args 0])}]
+ } elseif { [llength $args] == 2 } {
+ foreach {lower upper} $args break
+ set range [expr {$upper - $lower}]
+ return [expr {int($num * $range) + $lower}]
+ } else {
+ set fn [lindex [info level 0] 0]
+ error "wrong # args: should be \"$fn ?value1? ?value2?\""
+ }
+}
+
+# ::math::sigma --
+#
+# Return the standard deviation of three or more values
+#
+# Arguments:
+# val1 first value
+# val2 second value
+# args other values
+#
+# Results:
+# sigma population standard deviation value
+
+proc ::math::sigma {val1 val2 args} {
+ set sum [ expr { $val1+$val2 } ]
+ set N [ expr { [ llength $args ] + 2 } ]
+ foreach val $args {
+ set sum [ expr { $sum+$val } ]
+ }
+ set mean [ expr { $sum/$N } ]
+ set sigma_sq 0
+ foreach val [ concat $val1 $val2 $args ] {
+ set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
+ }
+ set sigma_sq [ expr { $sigma_sq/($N-1) } ]
+ set sigma [ expr { sqrt($sigma_sq) } ]
+ set sigma
+}
+
+# ::math::stats --
+#
+# Return the mean, standard deviation, and coefficient of variation as
+# percent, as a list.
+#
+# Arguments:
+# val1 first value
+# val2 first value
+# args all other values
+#
+# Results:
+# {mean stddev coefvar}
+
+proc ::math::stats {val1 val2 args} {
+ set sum [ expr { $val1+$val2 } ]
+ set N [ expr { [ llength $args ] + 2 } ]
+ foreach val $args {
+ set sum [ expr { $sum+$val } ]
+ }
+ set mean [ expr { $sum/$N } ]
+ set sigma_sq 0
+ foreach val [ concat $val1 $val2 $args ] {
+ set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
+ }
+ set sigma_sq [ expr { $sigma_sq/($N-1) } ]
+ set sigma [ expr { sqrt($sigma_sq) } ]
+ set cov [ expr { ($sigma/$mean)*100 } ]
+ return [ list $mean $sigma $cov ]
+}
+
+# ::math::sum --
+#
+# Return the sum of one or more values
+#
+# Arguments:
+# val first value
+# args all other values
+#
+# Results:
+# sum arithmetic sum of all values in args
+
+proc ::math::sum {val args} {
+ set sum $val
+ foreach val $args {
+ set sum [ expr { $sum+$val } ]
+ }
+ set sum
+}
+
+#----------------------------------------------------------------------
+#
+# ::math::expectDouble --
+#
+# Format an error message that an argument was expected to be
+# double and wasn't
+#
+# Parameters:
+# arg -- Misformatted argument
+#
+# Results:
+# Returns an appropriate error message
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc ::math::expectDouble { arg } {
+ return [format "expected a floating-point number but found \"%.50s\"" $arg]
+}
+
+#----------------------------------------------------------------------
+#
+# ::math::expectInteger --
+#
+# Format an error message that an argument was expected to be
+# integer and wasn't
+#
+# Parameters:
+# arg -- Misformatted argument
+#
+# Results:
+# Returns an appropriate error message
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc ::math::expectInteger { arg } {
+ return [format "expected an integer but found \"%.50s\"" $arg]
+}
+
diff --git a/tcllib/modules/math/mvlinreg.tcl b/tcllib/modules/math/mvlinreg.tcl
new file mode 100755
index 0000000..ba84743
--- /dev/null
+++ b/tcllib/modules/math/mvlinreg.tcl
@@ -0,0 +1,261 @@
+# mvreglin.tcl --
+# Addition to the statistics package
+# Copyright 2007 Eric Kemp-Benedict
+# Released under the BSD license under any terms
+# that allow it to be compatible with tcllib
+
+package require math::linearalgebra 1.0
+
+# ::math::statistics --
+# This file adds:
+# mvlinreg = Multivariate Linear Regression
+#
+namespace eval ::math::statistics {
+ variable epsilon 1.0e-7
+
+ namespace export tstat mv-wls mv-ols
+
+ namespace import -force \
+ ::math::linearalgebra::mkMatrix \
+ ::math::linearalgebra::mkVector \
+ ::math::linearalgebra::mkIdentity \
+ ::math::linearalgebra::mkDiagonal \
+ ::math::linearalgebra::getrow \
+ ::math::linearalgebra::setrow \
+ ::math::linearalgebra::getcol \
+ ::math::linearalgebra::setcol \
+ ::math::linearalgebra::getelem \
+ ::math::linearalgebra::setelem \
+ ::math::linearalgebra::dotproduct \
+ ::math::linearalgebra::matmul \
+ ::math::linearalgebra::add \
+ ::math::linearalgebra::sub \
+ ::math::linearalgebra::solveGauss \
+ ::math::linearalgebra::transpose
+}
+
+# tstats --
+# Returns inverse of the single-tailed t distribution
+# given number of degrees of freedom & confidence
+#
+# Arguments:
+# n Number of degrees of freedom
+# alpha Confidence level (defaults to 0.05)
+#
+# Result:
+# Inverse of the t-distribution
+#
+# Note:
+# Iterates until result is within epsilon of the target.
+# It is possible that the iteration does not converge
+#
+proc ::math::statistics::tstat {n {alpha 0.05}} {
+ variable epsilon
+ variable tvals
+
+ if [info exists tvals($n:$alpha)] {
+ return $tvals($n:$alpha)
+ }
+
+ set deltat [expr {100 * $epsilon}]
+ # For one-tailed distribution,
+ set ptarg [expr {1.000 - $alpha/2.0}]
+ set maxiter 100
+
+ # Initial value for t
+ set t 2.0
+
+ set niter 0
+ while {abs([::math::statistics::cdf-students-t $n $t] - $ptarg) > $epsilon} {
+ set pstar [::math::statistics::cdf-students-t $n $t]
+ set pl [::math::statistics::cdf-students-t $n [expr {$t - $deltat}]]
+ set ph [::math::statistics::cdf-students-t $n [expr {$t + $deltat}]]
+
+ set t [expr {$t + 2.0 * $deltat * ($ptarg - $pstar)/($ph - $pl)}]
+
+ incr niter
+ if {$niter == $maxiter} {
+ return -code error "::math::statistics::tstat: Did not converge after $niter iterations"
+ }
+ }
+
+ # Cache the result to shorten the call in future
+ set tvals($n:$alpha) $t
+
+ return $t
+}
+
+# mv-wls --
+# Weighted Least Squares
+#
+# Arguments:
+# data Alternating list of weights and observations
+#
+# Result:
+# List containing:
+# * R-squared
+# * Adjusted R-squared
+# * Coefficients of x's in fit
+# * Standard errors of the coefficients
+# * 95% confidence bounds for coefficients
+#
+# Note:
+# The observations are lists starting with the dependent variable y
+# and then the values of the independent variables (x1, x2, ...):
+#
+# mv-wls [list w [list y x's] w [list y x's] ...]
+#
+proc ::math::statistics::mv-wls {data} {
+
+ # Fill the matrices of x & y values, and weights
+ # For n points, k coefficients
+
+ # The number of points is equal to half the arguments (n weights, n points)
+ set n [expr {[llength $data]/2}]
+
+ set firstloop true
+ # Sum up all y values to take an average
+ set ysum 0
+ # Add up the weights
+ set wtsum 0
+ # Count over rows (points) as you go
+ set point 0
+ foreach {wt pt} $data {
+
+ # Check inputs
+ if {[string is double $wt] == 0} {
+ return -code error "::math::statistics::mv-wls: Weight \"$wt\" is not a number"
+ return {}
+ }
+
+ ## -- Check dimensions, initialize
+ if $firstloop {
+ # k = num of vals in pt = 1 + number of x's (because of constant)
+ set k [llength $pt]
+ if {$n <= [expr {$k + 1}]} {
+ return -code error "::math::statistics::mv-wls: Too few degrees of freedom: $k variables but only $n points"
+ return {}
+ }
+ set X [mkMatrix $n $k]
+ set y [mkVector $n]
+ set I_x [mkIdentity $k]
+ set I_y [mkIdentity $n]
+
+ set firstloop false
+
+ } else {
+ # Have to have same number of x's for all points
+ if {$k != [llength $pt]} {
+ return -code error "::math::statistics::mv-wls: Point \"$pt\" has wrong number of values (expected $k)"
+ # Clean up
+ return {}
+ }
+ }
+
+ ## -- Extract values from set of points
+ # Make a list of y values
+ set yval [expr {double([lindex $pt 0])}]
+ setelem y $point $yval
+ set ysum [expr {$ysum + $wt * $yval}]
+ set wtsum [expr {$wtsum + $wt}]
+ # Add x-values to the x-matrix
+ set xrow [lrange $pt 1 end]
+ # Add the constant (value = 1.0)
+ lappend xrow 1.0
+ setrow X $point $xrow
+ # Create list of weights & square root of weights
+ lappend w [expr {double($wt)}]
+ lappend sqrtw [expr {sqrt(double($wt))}]
+
+ incr point
+
+ }
+
+ set ymean [expr {double($ysum)/$wtsum}]
+ set W [mkDiagonal $w]
+ set sqrtW [mkDiagonal $sqrtw]
+
+ # Calculate sum os square differences for x's
+ for {set r 0} {$r < $k} {incr r} {
+ set xsqrsum 0.0
+ set xmeansum 0.0
+ # Calculate sum of squared differences as: sum(x^2) - (sum x)^2/n
+ for {set t 0} {$t < $n} {incr t} {
+ set xval [getelem $X $t $r]
+ set xmeansum [expr {$xmeansum + double($xval)}]
+ set xsqrsum [expr {$xsqrsum + double($xval * $xval)}]
+ }
+ lappend xsqr [expr {$xsqrsum - $xmeansum * $xmeansum/$n}]
+ }
+
+ ## -- Set up the X'WX matrix
+ set XtW [matmul [::math::linearalgebra::transpose $X] $W]
+ set XtWX [matmul $XtW $X]
+
+ # Invert
+ set M [solveGauss $XtWX $I_x]
+
+ set beta [matmul $M [matmul $XtW $y]]
+
+ ### -- Residuals & R-squared
+ # 1) Generate list of diagonals of the hat matrix
+ set H [matmul $X [matmul $M $XtW]]
+ for {set i 0} {$i < $n} {incr i} {
+ lappend h_ii [getelem $H $i $i]
+ }
+
+ set R [matmul $sqrtW [matmul [sub $I_y $H] $y]]
+ set yhat [matmul $H $y]
+
+ # 2) Generate list of residuals, sum of squared residuals, r-squared
+ set sstot 0.0
+ set ssreg 0.0
+ # Note: Relying on representation of Vector as a list for y, yhat
+ foreach yval $y wt $w yhatval $yhat {
+ set sstot [expr {$sstot + $wt * ($yval - $ymean) * ($yval - $ymean)}]
+ set ssreg [expr {$ssreg + $wt * ($yhatval - $ymean) * ($yhatval - $ymean)}]
+ }
+ set r2 [expr {double($ssreg)/$sstot}]
+ set adjr2 [expr {1.0 - (1.0 - $r2) * ($n - 1)/($n - $k)}]
+ set sumsqresid [dotproduct $R $R]
+ set s2 [expr {double($sumsqresid) / double($n - $k)}]
+
+ ### -- Confidence intervals for coefficients
+ set tvalue [tstat [expr {$n - $k}]]
+ for {set i 0} {$i < $k} {incr i} {
+ set stderr [expr {sqrt($s2 * [getelem $M $i $i])}]
+ set mid [lindex $beta $i]
+ lappend stderrs $stderr
+ lappend confinterval [list [expr {$mid - $tvalue * $stderr}] [expr {$mid + $tvalue * $stderr}]]
+ }
+
+ return [list $r2 $adjr2 $beta $stderrs $confinterval]
+}
+
+# mv-ols --
+# Ordinary Least Squares
+#
+# Arguments:
+# data List of observations, list of lists
+#
+# Result:
+# List containing:
+# * R-squared
+# * Adjusted R-squared
+# * Coefficients of x's in fit
+# * Standard errors of the coefficients
+# * 95% confidence bounds for coefficients
+#
+# Note:
+# The observations are lists starting with the dependent variable y
+# and then the values of the independent variables (x1, x2, ...):
+#
+# mv-ols [list y x's] [list y x's] ...
+#
+proc ::math::statistics::mv-ols {data} {
+ set newdata {}
+ foreach pt $data {
+ lappend newdata 1 $pt
+ }
+ return [mv-wls $newdata]
+}
diff --git a/tcllib/modules/math/numtheory.dtx b/tcllib/modules/math/numtheory.dtx
new file mode 100755
index 0000000..61497f3
--- /dev/null
+++ b/tcllib/modules/math/numtheory.dtx
@@ -0,0 +1,952 @@
+%
+% \iffalse
+%
+%<*pkg>
+%% Copyright (c) 2010 by Lars Hellstrom. All rights reserved.
+%% See the file "license.terms" for information on usage and redistribution
+%% of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+%</pkg>
+%<*driver>
+\documentclass{tclldoc}
+\usepackage{amsmath,amsfonts}
+\usepackage{url}
+\newcommand{\Tcl}{\Tcllogo}
+\begin{document}
+\DocInput{numtheory.dtx}
+\end{document}
+%</driver>
+% \fi
+%
+% \title{Number theory package}
+% \author{Lars Hellstr\"om}
+% \date{30 May 2010}
+% \maketitle
+%
+% \begin{abstract}
+% This package provides a command to test whether an integer is a
+% prime, but may in time come to house also other number-theoretic
+% operations.
+% \end{abstract}
+%
+% \tableofcontents
+%
+% \section*{Preliminaries}
+%
+% \begin{tcl}
+%<*pkg>
+package require Tcl 8.5
+% \end{tcl}
+% \Tcl~8.4 is seriously broken with respect to arithmetic overflow,
+% so we require 8.5. There are (as yet) no explicit 8.5-isms in the
+% code, however.
+% \begin{tcl}
+package provide math::numtheory 1.0
+namespace eval ::math::numtheory {
+ namespace export isprime
+}
+%</pkg>
+% \end{tcl}
+% \setnamespace{math::numtheory}
+%
+% \Tcl lib has its own test file boilerplate.
+% \begin{tcl}
+%<*test>
+source [file join\
+ [file dirname [file dirname [file join [pwd] [info script]]]]\
+ devtools testutilities.tcl]
+testsNeedTcl 8.5
+testsNeedTcltest 2
+testing {useLocal numtheory.tcl math::numtheory}
+%</test>
+% \end{tcl}
+%
+% And the same is true for the manpage.
+% \begin{tcl}
+%<*man>
+[manpage_begin math::numtheory n 1.0]
+[copyright "2010 Lars Hellstr\u00F6m\
+ <Lars dot Hellstrom at residenset dot net>"]
+[moddesc {Tcl Math Library}]
+[titledesc {Number Theory}]
+[category Mathematics]
+[require Tcl [opt 8.5]]
+[require math::numtheory [opt 1.0]]
+
+[description]
+[para]
+This package is for collecting various number-theoretic operations,
+though at the moment it only provides that of testing whether an
+integer is a prime.
+
+[list_begin definitions]
+%</man>
+% \end{tcl}
+%
+%
+% \section{Primes}
+%
+% The first (and so far only) operation provided is |isprime|, which
+% tests if an integer is a prime.
+% \begin{tcl}
+%<*man>
+[call [cmd math::numtheory::isprime] [arg N] [
+ opt "[arg option] [arg value] ..."
+]]
+ The [cmd isprime] command tests whether the integer [arg N] is a
+ prime, returning a boolean true value for prime [arg N] and a
+ boolean false value for non-prime [arg N]. The formal definition of
+ 'prime' used is the conventional, that the number being tested is
+ greater than 1 and only has trivial divisors.
+ [para]
+
+ To be precise, the return value is one of [const 0] (if [arg N] is
+ definitely not a prime), [const 1] (if [arg N] is definitely a
+ prime), and [const on] (if [arg N] is probably prime); the latter
+ two are both boolean true values. The case that an integer may be
+ classified as "probably prime" arises because the Miller-Rabin
+ algorithm used in the test implementation is basically probabilistic,
+ and may if we are unlucky fail to detect that a number is in fact
+ composite. Options may be used to select the risk of such
+ "false positives" in the test. [const 1] is returned for "small"
+ [arg N] (which currently means [arg N] < 118670087467), where it is
+ known that no false positives are possible.
+ [para]
+
+ The only option currently defined is:
+ [list_begin options]
+ [opt_def -randommr [arg repetitions]]
+ which controls how many times the Miller-Rabin test should be
+ repeated with randomly chosen bases. Each repetition reduces the
+ probability of a false positive by a factor at least 4. The
+ default for [arg repetitions] is 4.
+ [list_end]
+ Unknown options are silently ignored.
+
+%</man>
+% \end{tcl}
+%
+%
+% \subsection{Trial division}
+%
+% As most books on primes will tell you, practical primality
+% testing algorithms typically start with trial division by a list
+% of small known primes to weed out the low hanging fruit. This is
+% also an opportunity to handle special cases that might arise for
+% very low numbers (e.g.\ $2$ is a prime despite being even).
+%
+% \begin{proc}{prime_trialdivision}
+% This procedure is meant to be called as
+% \begin{quote}
+% |prime_trialdivision| \word{$n$}
+% \end{quote}
+% from \emph{within} a procedure that returns |1| if $n$ is a prime
+% and |0| if it is not. It does not return anything particular, but
+% \emph{it causes its caller to return provided} it is able to
+% decide what its result should be. This means one can slap it in
+% as the first line of a primality checker procedure, and then on
+% lines two and forth worry only about the nontrivial cases.
+% \begin{tcl}
+%<*pkg>
+proc ::math::numtheory::prime_trialdivision {n} {
+ if {$n<2} then {return -code return 0}
+% \end{tcl}
+% Integers less than $2$ aren't primes.\footnote{
+% Well, at least as one usually defines the term for integers.
+% When considering the concept of prime in more general rings,
+% one may have to settle with accepting all associates of primes
+% as primes as well.
+% } This saves us many worries by excluding negative numbers from
+% further considerations.
+% \begin{tcl}
+ if {$n<4} then {return -code return 1}
+% \end{tcl}
+% Everything else below \(2^2 = 4\) (i.e., $2$ and $3$) are primes.
+% \begin{tcl}
+ if {$n%2 == 0} then {return -code return 0}
+% \end{tcl}
+% Remaining even numbers are then composite.
+% \begin{tcl}
+ if {$n<9} then {return -code return 1}
+% \end{tcl}
+% Now everything left below \(3^2 = 9\) (i.e., $5$ and $7$) are
+% primes. Having decided those, we can now do trial division with
+% $3$, $5$, and $7$ in one go.
+% \begin{tcl}
+ if {$n%3 == 0} then {return -code return 0}
+ if {$n%5 == 0} then {return -code return 0}
+ if {$n%7 == 0} then {return -code return 0}
+% \end{tcl}
+% Any numbers less that \(11^2 = 121\) not yet eliminated are
+% primes; above that we know nothing.
+% \begin{tcl}
+ if {$n<121} then {return -code return 1}
+}
+%</pkg>
+% \end{tcl}
+% This procedure could be extended with more primes, pushing the
+% limit of what can be decided further up, but the returns are
+% diminishing, so we might be better off with a different method
+% for testing primality. No analysis of where the cut-off point
+% lies have been conducted (i.e., $7$ as last prime for trial
+% division was picked arbitrarily), but note that the optimum
+% probably depends on what distribution the input values will have.
+%
+% \begin{tcl}
+%<*test>
+test prime_trialdivision-1 "Trial division of 1" -body {
+ ::math::numtheory::prime_trialdivision 1
+} -returnCodes 2 -result 0
+test prime_trialdivision-2 "Trial division of 2" -body {
+ ::math::numtheory::prime_trialdivision 2
+} -returnCodes 2 -result 1
+test prime_trialdivision-3 "Trial division of 6" -body {
+ ::math::numtheory::prime_trialdivision 6
+} -returnCodes 2 -result 0
+test prime_trialdivision-4 "Trial division of 7" -body {
+ ::math::numtheory::prime_trialdivision 7
+} -returnCodes 2 -result 1
+test prime_trialdivision-5 "Trial division of 101" -body {
+ ::math::numtheory::prime_trialdivision 101
+} -returnCodes 2 -result 1
+test prime_trialdivision-6 "Trial division of 105" -body {
+ ::math::numtheory::prime_trialdivision 105
+} -returnCodes 2 -result 0
+% \end{tcl}
+% Note that extending the number of primes for trial division is
+% likely to change the results in the following two tests ($121$
+% is composite, $127$ is prime).
+% \begin{tcl}
+test prime_trialdivision-7 "Trial division of 121" -body {
+ ::math::numtheory::prime_trialdivision 121
+} -returnCodes 0 -result ""
+test prime_trialdivision-8 "Trial division of 127" -body {
+ ::math::numtheory::prime_trialdivision 127
+} -returnCodes 0 -result ""
+%</test>
+% \end{tcl}
+% \end{proc}
+%
+%
+% \subsection{Pseudoprimality tests}
+%
+% After trial division, the next thing tried is usually to test the
+% claim of Fermat's little theorem: if $n$ is a prime, then \(a^{n-1}
+% \equiv 1 \pmod{n}\) for all integers $a$ that are not multiples of
+% $n$, in particular those \(0 < a < n\); one picks such an $a$ (more
+% or less at random) and computes $a^{n-1} \bmod n$. Numbers that
+% pass are said to be \emph{(Fermat) pseudoprimes (to base $a$)}.
+% Most composite numbers quickly fail this test.
+% (One particular class that fails are the powers of primes, since
+% the group of invertible elements in $\mathbb{Z}_n$ for \(n = p^{k+1}\)
+% is cyclic\footnote{
+% The easiest way to see that it is cyclic is probably to exhibit
+% an element of order $(p -\nobreak 1) p^k$. A good start is to
+% pick a primitive root $a$ of $\mathbb{Z}_p$ and compute its order
+% modulo $p^{k+1}$; this has to be a number on the form $(p
+% -\nobreak 1) p^r$. If \(r=k\) then $a$ is a primitive root and we're
+% done, otherwise $(p +\nobreak 1) a$ will be a primitive root
+% because $p+1$ can be shown to have order $p^k$ modulo $n$ and the
+% least common multiple of $(p -\nobreak 1) p^r$ and $p^k$ is
+% $(p -\nobreak 1) p^k$. To exhibit the order of $p+1$, one may
+% use induction on $k$ to show that \( (1 +\nobreak p)^N \equiv 1
+% \pmod{p^{k+1}}\) implies \(p^k \mid N\); in \((1 +\nobreak p)^N =
+% \sum_{i=0}^N \binom{N}{i} p^i\), the induction hypothesis implies
+% all terms with \(i>1\) vanish modulo $p^{k+1}$, leaving just
+% \(1+Np \equiv 1 \pmod{p^{k+1}}\).
+% } of order $(p -\nobreak 1) p^k$ rather than order $p^{k+1}-1$.
+% Therefore it is only to bases $a$ of order dividing $p-1$ (i.e., a
+% total of $p-1$ out of $p^{k+1}-1$) that prime powers are
+% pseudoprimes. The chances of picking one of these are generally
+% rather slim.)
+%
+% Unfortunately, there are also numbers (the so-called \emph{Carmichael
+% numbers}) which are pseudoprimes to every base $a$ they are coprime
+% with. While the above trial division by $2$, $3$, $5$, and $7$ would
+% already have eliminated all Carmichael numbers below \(29341 = 13
+% \cdot 37 \cdot 61\), their existence means that there is a
+% population of nonprimes which a Fermat pseudoprimality test is very
+% likely to mistake for primes; this would usually not be acceptable.
+%
+% \begin{proc}{Miller--Rabin}
+% The Miller--Rabin test is a slight variation on the Fermat test,
+% where the computation of $a^{n-1} \bmod n$ is structured so that
+% additional consequences of $n$ being a prime can be tested.
+% Rabin~\cite{Rabin}
+% proved that any composite $n$ will for this test be revealed as
+% such by at least $3/4$ of all bases $a$, thus making it a valid
+% probabilistic test. (Miller~\cite{Miller} had first designed it as
+% a deterministic polynomial algorithm, but in that case the proof
+% that it works relies on the generalised Riemann hypothesis.)
+%
+% Given natural numbers $s$ and $d$ such that \(n-1 = 2^s d\), the
+% computation of $a^{n-1}$ is organised as $(a^d)^{2^s}$, where the
+% $s$ part is conveniently performed by squaring $s$ times. This is
+% of little consequence when $n$ is not a pseudoprime since one
+% will simply arrive at some \(a^{n-1} \not\equiv 1 \pmod{n}\), but
+% in the case that $n$ is a pseudoprime these repeated squarings will
+% exhibit some $x$ such that \(x^2 \equiv 1 \pmod{n}\), and this
+% makes it possible to test another property $n$ must have if it is
+% prime, namely that such an \(x \equiv \pm 1 \pmod{n}\).
+%
+% That implication is of course well known for real (and complex)
+% numbers, but even though what we're dealing with here is rather
+% residue classes modulo an integer, the proof that it holds is
+% basically the same. If $n$ is a prime, then the residue class
+% ring $\mathbb{Z}_n$ is a field, and hence the ring
+% $\mathbb{Z}_n[x]$ of polynomials over that field is a Unique
+% Factorisation Domain. As it happens, \(x^2 \equiv 1 \pmod{n}\) is
+% a polynomial equation, and $x^2-1$ has the known factorisation
+% \((x -\nobreak 1) (x +\nobreak 1)\). Since factorisations are
+% unique, and any zero $a$ of $x^2-1$ would give rise to a factor
+% $x-a$, it follows that \(x^2 \equiv 1 \pmod{n}\) implies \(x
+% \equiv 1 \pmod{n}\) or \(x \equiv -1 \pmod{n}\), as claimed.
+% But this assumes $n$ is a prime.
+%
+% If instead \(n = pq\) where \(p,q > 2\) are coprime, then there
+% will be additional solutions to \(x^2 \equiv 1 \pmod{n}\).
+% For example, if \(x \equiv 1 \pmod{p}\) and \(x \equiv -1
+% \pmod{q}\) (and such $x$ exist by the Chinese Remainder Theorem),
+% then \(x^2 \equiv 1 \pmod{p}\) and \(x^2 \equiv 1 \pmod{q}\),
+% from which follows \(x^2 \equiv 1 \pmod{pq}\), but \(x \not\equiv
+% 1 \pmod{n}\) since \(x-1 \equiv -2 \not\equiv 0 \pmod{q}\), and
+% \(x \not\equiv -1 \pmod{n}\) since \(x+1 \equiv 2 \not\equiv 0
+% \pmod{p}\). The same argument applies when \(x \equiv -1 \pmod{p}\)
+% and \(x \equiv 1 \pmod{q}\), and in general, if $n$ has $k$
+% distinct odd prime factors then one may construct $2^k$ distinct
+% solutions \(0<x<n\) to \(x^2 \equiv 1 \pmod{n}\). It is thus not
+% too hard to imagine that a ``random'' $a^d$ squaring to $1$
+% modulo $n$ will be one of the nonstandard square roots of~$1$
+% when $n$ is not a prime, even if the above is not a proof that
+% at least $3/4$ of all $a$ are witnesses to the compositeness
+% of~$n$.
+%
+% Getting down to the implementation, the actual procedure has the
+% call syntax
+% \begin{quote}
+% |Miller--Rabin| \word{n} \word{s} \word{d} \word{a}
+% \end{quote}
+% where all arguments should be integers such that \(n-1 = d2^s\),
+% \(d,s \geq 1\), and \(0 < a < n\). The procedure computes
+% $(a^d)^{2^s} \mod n$, and if in the course of doing this the
+% Miller--Rabin test detects that $n$ is composite then this procedure
+% will return |1|, otherwise it returns |0|.
+%
+% The first part of the procedure merely computes \(x = a^d \bmod n\),
+% using exponentiation by squaring. $x$, $a$, and $d$ are modified in
+% the loop, but $xa^d \bmod n$ would be an invariant quantity.
+% Correctness presumes the initial \(d \geq 1\).
+% \begin{tcl}
+%<*pkg>
+proc ::math::numtheory::Miller--Rabin {n s d a} {
+ set x 1
+ while {$d>1} {
+ if {$d & 1} then {set x [expr {$x*$a % $n}]}
+ set a [expr {$a*$a % $n}]
+ set d [expr {$d >> 1}]
+ }
+ set x [expr {$x*$a % $n}]
+% \end{tcl}
+% The second part will $s-1$ times square $x$, while checking each
+% value for being \(\equiv \pm 1 \pmod{n}\). For most part, $-1$
+% means everything is OK (any subsequent square would only
+% yield~$1$) whereas $1$ arrived at without a previous $-1$ signals
+% that $n$ cannot be prime. The only exception to the latter is
+% that $1$ before the first squaring (already \(a^d \equiv 1
+% \pmod{n}\)) is OK as well.
+% \begin{tcl}
+ if {$x == 1} then {return 0}
+ for {} {$s>1} {incr s -1} {
+ if {$x == $n-1} then {return 0}
+ set x [expr {$x*$x % $n}]
+ if {$x == 1} then {return 1}
+ }
+% \end{tcl}
+% There is no need to square $x$ the $s$th time, because if at this
+% point \(x \not\equiv -1 \pmod{n}\) then $n$ cannot be a prime; if
+% \(x^2 \not\equiv 1 \pmod{n}\) it would fail to be a pseudoprime
+% and if \(x^2 \equiv 1 \pmod{n}\) then $x$ would be a nonstandard
+% square root of $1 \pmod{n}$, but it is not necessary to find out
+% which of these cases is at hand.
+% \begin{tcl}
+ return [expr {$x != $n-1}]
+}
+%</pkg>
+% \end{tcl}
+%
+% As for testing, the minimal allowed value of $n$ is $3$, which
+% is a prime.
+% \begin{tcl}
+%<*test>
+test Miller--Rabin-1.1 "Miller--Rabin 3" -body {
+ list [::math::numtheory::Miller--Rabin 3 1 1 1]\
+ [::math::numtheory::Miller--Rabin 3 1 1 2]
+} -result {0 0}
+% \end{tcl}
+% To exercise the first part of the procedure, one may consider the
+% case \(s=1\) and \(d = 2^2+2^0 = 5\), i.e., \(n=11\). Here, \(2^5
+% \equiv -1 \pmod{11}\) whereas \(4^5 \equiv 1^5 \equiv 1
+% \pmod{11}\). A bug on the lines of not using the right factors in
+% the computation of $a^d$ would most likely end up with something
+% different here.
+% \begin{tcl}
+test Miller--Rabin-1.2 "Miller--Rabin 11" -body {
+ list [::math::numtheory::Miller--Rabin 11 1 5 1]\
+ [::math::numtheory::Miller--Rabin 11 1 5 2]\
+ [::math::numtheory::Miller--Rabin 11 1 5 4]
+} -result {0 0 0}
+% \end{tcl}
+% $27$ will on the other hand be exposed as composite by most bases,
+% but $1$ and $-1$ do not spot it. It is known from the argument
+% about prime powers above that at least one of $2$ and \(8 = (3
+% +\nobreak 1) \cdot 2\) is a primitive root of $1$ in
+% $\mathbb{Z}_{27}$; it turns out to be $2$.
+% \begin{tcl}
+test Miller--Rabin-1.3 "Miller--Rabin 27" -body {
+ list [::math::numtheory::Miller--Rabin 27 1 13 1]\
+ [::math::numtheory::Miller--Rabin 27 1 13 2]\
+ [::math::numtheory::Miller--Rabin 27 1 13 3]\
+ [::math::numtheory::Miller--Rabin 27 1 13 4]\
+ [::math::numtheory::Miller--Rabin 27 1 13 8]\
+ [::math::numtheory::Miller--Rabin 27 1 13 26]
+} -result {0 1 1 1 1 0}
+% \end{tcl}
+% Taking \(n = 65 = 1 + 2^6 = 5 \cdot 13\) instead focuses on the
+% second part of the procedure. By carefully choosing the base, it
+% is possible to force the result to come from:
+% \begin{tcl}
+test Miller--Rabin-1.4 "Miller--Rabin 65" -body {
+% \end{tcl}
+% The first |return|
+% \begin{tcl}
+ list [::math::numtheory::Miller--Rabin 65 6 1 1]\
+% \end{tcl}
+% the second |return|, first iteration
+% \begin{tcl}
+ [::math::numtheory::Miller--Rabin 65 6 1 64]\
+% \end{tcl}
+% the third |return|, first iteration---\(14 \equiv 1 \pmod{13}\)
+% but \(14 \equiv -1 \pmod{5}\)
+% \begin{tcl}
+ [::math::numtheory::Miller--Rabin 65 6 1 14]\
+% \end{tcl}
+% the second |return|, second iteration
+% \begin{tcl}
+ [::math::numtheory::Miller--Rabin 65 6 1 8]\
+% \end{tcl}
+% the third |return|, second iteration---\(27 \equiv 1 \pmod{13}\)
+% but \(27^2 \equiv 2^2 \equiv -1 \pmod{5}\)
+% \begin{tcl}
+ [::math::numtheory::Miller--Rabin 65 6 1 27]\
+% \end{tcl}
+% the final |return|
+% \begin{tcl}
+ [::math::numtheory::Miller--Rabin 65 6 1 2]
+} -result {0 0 1 0 1 1}
+% \end{tcl}
+% There does however not seem to be any \(n=65\) choice of $a$ which
+% would get a |0| out of the final |return|.
+%
+% An $n$ which allows fully exercising the second part of the
+% procedure is \(17 \cdot 257 = 4369\), for which \(s=4\)
+% and \(d=273\). In order to have \(x^{2^{s-1}} \equiv -1
+% \pmod{n}\), it is necessary to have \(x^8 \equiv -1\) modulo both
+% $17$ and $257$, which is possible since the invertible elements
+% of $\mathbb{Z}_{17}$ form a cyclic group of order $16$ and the
+% invertible elements of $\mathbb{Z}_{257}$ form a cyclic group of
+% order $256$. Modulo $17$, an element of order $16$ is $3$,
+% whereas modulo $257$, an element of order $16$ is $2$.
+%
+% There is an extra complication in that what the caller can
+% specify is not the $x$ to be repeatedly squared, but the $a$
+% which satisfies \(x \equiv a^d \pmod{n}\). Since \(d=273\) is
+% odd, raising something to that power is an invertible operation
+% modulo both $17$ and $257$, but it is necessary to figure out
+% what the inverse is. Since \(273 \equiv 1 \pmod{16}\), it turns
+% out that \(a^d \equiv a \pmod{17}\), and \(x=3\) becomes \(a=3\).
+% From \(273 \equiv 17 \pmod{256}\), it instead follows that \(x
+% \equiv a^d \pmod{257}\) is equivalent to \(a \equiv x^e
+% \pmod{257}\), where \(17e \equiv 1 \pmod{256}\). This has the
+% solution \(e = 241\), so the $a$ which makes \(x=2\) is \(a
+% = 2^{241} \bmod 257\). However, since \(x=2\) was picked on
+% account of having order $16$, hence \(2^{16} \equiv 1
+% \pmod{257}\), and \(241 \equiv 1 \pmod{16}\), it again turns out
+% that \(x=2\) becomes \(a=2\).
+%
+% For \(a = 2\), one may observe that \(a^{2^1} \equiv 4
+% \pmod{257}\), \(a^{2^2} \equiv 16 \pmod{257}\), \(a^{2^3} \equiv
+% -1 \pmod{257}\), and \(a^{2^4} \equiv 1 \pmod{257}\). For
+% \(a=3\), one may observe that \(a^{2^1} \equiv 9 \pmod{17}\),
+% \(a^{2^2} \equiv 13 \pmod{17}\), \(a^{2^3} \equiv -1 \pmod{17}\),
+% and \(a^{2^4} \equiv 1 \pmod{17}\). For solving simultaneous
+% equivalences, it is furthermore useful to observe that \(2057
+% \equiv 1 \pmod{257}\) and \(2057 \equiv 0 \pmod{17}\) whereas
+% \(2313 \equiv 1 \pmod{17}\) and \(2313 \equiv 0 \pmod{257}\).
+% \begin{tcl}
+test Miller--Rabin-1.5 "Miller--Rabin 17*257" -body {
+% \end{tcl}
+% In order to end up at the first |return|, it is necessary to take
+% \(a \equiv 1 \pmod{17}\) and \(a \equiv 1 \pmod{257}\); the
+% solution \(a=1\) is pretty obvious.
+% \begin{tcl}
+ list [::math::numtheory::Miller--Rabin 4369 4 273 1]\
+% \end{tcl}
+% In order to end up at the second |return| of the first iteration,
+% it is necessary to take \(a \equiv -1 \pmod{17}\) and
+% \(a \equiv -1 \pmod{257}\); the solution \(a \equiv -1 \pmod{n}\)
+% is again pretty obvious.
+% \begin{tcl}
+ [::math::numtheory::Miller--Rabin 4369 4 273 4368]\
+% \end{tcl}
+% Hitting the third |return| at the first iteration can be achieved
+% with \(a \equiv -1 \pmod{17}\) and \(a \equiv 1 \pmod{257}\);
+% now a solution is \(a \equiv 2057 - 2313 \equiv 4113 \pmod{n}\).
+% \begin{tcl}
+ [::math::numtheory::Miller--Rabin 4369 4 273 4113]\
+% \end{tcl}
+% Hitting the second |return| at the second iteration happens if
+% \(a^2 \equiv -1\) modulo both prime factors, i.e., for \(a \equiv
+% 16 \pmod{257}\) and \(a \equiv 13 \pmod{17}\). This has the
+% solution \(a \equiv 16 \cdot 2057 + 13 \cdot 2313 \equiv 1815
+% \pmod{n}\).
+% \begin{tcl}
+ [::math::numtheory::Miller--Rabin 4369 4 273 1815]\
+% \end{tcl}
+% To hit the third |return| at the second iteration, one may keep
+% \(a \equiv 16 \pmod{257}\) but take \(a \equiv 1 \pmod{17}\). This
+% has the solution \(a \equiv 16 \cdot 2057 + 1 \cdot 2313 \equiv 273
+% \pmod{n}\).
+% \begin{tcl}
+ [::math::numtheory::Miller--Rabin 4369 4 273 273]\
+% \end{tcl}
+% Hitting the second |return| at the third and final iteration happens
+% if \(a^4 \equiv -1\) modulo both prime factors, i.e., for \(a \equiv
+% 4 \pmod{257}\) and \(a \equiv 9 \pmod{17}\). This has the
+% solution \(a \equiv 4 \cdot 2057 + 9 \cdot 2313 \equiv 2831
+% \pmod{n}\).
+% \begin{tcl}
+ [::math::numtheory::Miller--Rabin 4369 4 273 2831]\
+% \end{tcl}
+% And as before, to hit the third |return| at the third and final
+% iteration one may keep the above \(a \equiv 9 \pmod{17}\) but
+% change the other to \(a \equiv 1 \pmod{257}\). This has the
+% solution \(a \equiv 1 \cdot 2057 + 9 \cdot 2313 \equiv 1029
+% \pmod{n}\).
+% \begin{tcl}
+ [::math::numtheory::Miller--Rabin 4369 4 273 1029]\
+% \end{tcl}
+% To get a |0| out of the fourth |return|, one takes \(a \equiv
+% 2 \pmod{257}\) and \(a \equiv 3 \pmod{17}\); this means \(a \equiv
+% 2 \cdot 2057 + 3 \cdot 2313 \equiv 2315 \pmod{n}\).
+% \begin{tcl}
+ [::math::numtheory::Miller--Rabin 4369 4 273 2315]\
+% \end{tcl}
+% Finally, to get a |1| out of the fourth |return|, one may take
+% \(a \equiv 1 \pmod{257}\) and \(a \equiv 3 \pmod{17}\); this means
+% \(a \equiv 1 \cdot 2057 + 3 \cdot 2313 \equiv 258 \pmod{n}\).
+% \begin{tcl}
+ [::math::numtheory::Miller--Rabin 4369 4 273 258]
+} -result {0 0 1 0 1 0 1 0 1}
+% \end{tcl}
+% It would have been desirable from a testing point of view to also
+% find a value of $a$ that would make \(a^{n-1} \equiv -1
+% \pmod{n}\), since such an $a$ would catch an implementation error
+% of running the squaring loop one step too far, but that does not
+% seem possible; picking \(n=pq\) such that both $p-1$ and $q-1$
+% are divisible by some power of $2$ implies that $n-1$ is
+% divisible by the same power of $2$.
+% \end{proc}
+%
+% A different kind of test is to verify some exceptional numbers and
+% boundaries that the |isprime| procedure relies on. First, $1373653$
+% appears prime when \(a=2\) or \(a=3\), but \(a=5\) is a witness to
+% its compositeness.
+% \begin{tcl}
+test Miller--Rabin-2.1 "Miller--Rabin 1373653" -body {
+ list\
+ [::math::numtheory::Miller--Rabin 1373653 2 343413 2]\
+ [::math::numtheory::Miller--Rabin 1373653 2 343413 3]\
+ [::math::numtheory::Miller--Rabin 1373653 2 343413 5]
+} -result {0 0 1}
+% \end{tcl}
+% $25326001$ is looking like a prime also to \(a=5\), but \(a=7\)
+% exposes it.
+% \begin{tcl}
+test Miller--Rabin-2.2 "Miller--Rabin 25326001" -body {
+ list\
+ [::math::numtheory::Miller--Rabin 25326001 4 1582875 2]\
+ [::math::numtheory::Miller--Rabin 25326001 4 1582875 3]\
+ [::math::numtheory::Miller--Rabin 25326001 4 1582875 5]\
+ [::math::numtheory::Miller--Rabin 25326001 4 1582875 7]
+} -result {0 0 0 1}
+% \end{tcl}
+% $3215031751$ is a tricky composite that isn't exposed even by
+% \(a=7\), but \(a=11\) will see through it.
+% \begin{tcl}
+test Miller--Rabin-2.3 "Miller--Rabin 3215031751" -body {
+ list\
+ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 2]\
+ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 3]\
+ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 5]\
+ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 7]\
+ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 11]
+} -result {0 0 0 0 1}
+% \end{tcl}
+% Otherwise the lowest composite that these four will fail for is
+% $118670087467$.
+% \begin{tcl}
+test Miller--Rabin-2.4 "Miller--Rabin 118670087467" -body {
+ list\
+ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 2]\
+ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 3]\
+ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 5]\
+ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 7]\
+ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 11]
+} -result {0 0 0 0 1}
+%</test>
+% \end{tcl}
+%
+%
+% \subsection{Putting it all together}
+%
+% \begin{proc}{isprime}
+% The user level command for testing primality of an integer $n$ is
+% |isprime|. It has the call syntax
+% \begin{quote}
+% |math::numtheory::isprime| \word{n}
+% \begin{regblock}[\regstar]\word{option}
+% \word{value}\end{regblock}
+% \end{quote}
+% where the options may be used to influence the exact algorithm
+% being used. The call returns
+% \begin{description}
+% \item[0] if $n$ is found to be composite,
+% \item[1] if $n$ is found to be prime, and
+% \item[on] if $n$ is probably prime.
+% \end{description}
+% The reason there might be \emph{some} uncertainty is that the
+% primality test used is basically a probabilistic test for
+% compositeness---it may fail to find a witness for the
+% compositeness of a composite number $n$, even if the probability
+% of doing so is fairly low---and to be honest with the user, the
+% outcomes of ``definitely prime'' and ``probably prime'' return
+% different results. Since |on| is true when used as a boolean, you
+% usually need not worry about this fine detail. Also, for \(n <
+% 10^{11}\) (actually a little more) the primality test is
+% deterministic, so you only encounter the ``probably prime''
+% result for fairly high $n$.
+%
+% At present, the only option that is implemented is |-randommr|,
+% which controls how many rounds (by default 4) of the |Miller--Rabin|
+% test with random bases are run before returing |on|. Other options
+% are silently ignored.
+%
+% \begin{tcl}
+%<*pkg>
+proc ::math::numtheory::isprime {n args} {
+ prime_trialdivision $n
+% \end{tcl}
+% Implementation-wise, |isprime| begins with |prime_trialdivision|,
+% but relies on the Miller--Rabin test after that. To that end, it
+% must compute $s$ and $d$ such that \(n = d 2^s + 1\); while this
+% is fairly quick, it's nice not having to do it more than once,
+% which is why this step wasn't made part of the |Miller--Rabin|
+% procedure.
+% \begin{tcl}
+ set d [expr {$n-1}]; set s 0
+ while {($d&1) == 0} {
+ incr s
+ set d [expr {$d>>1}]
+ }
+% \end{tcl}
+% The deterministic sequence of Miller--Rabin tests combines
+% information from \cite{PSW80,Jaeschke}, but most of these
+% numbers may also be found on Wikipedia~\cite{Wikipedia}.
+% \begin{tcl}
+ if {[Miller--Rabin $n $s $d 2]} then {return 0}
+ if {$n < 2047} then {return 1}
+ if {[Miller--Rabin $n $s $d 3]} then {return 0}
+ if {$n < 1373653} then {return 1}
+ if {[Miller--Rabin $n $s $d 5]} then {return 0}
+ if {$n < 25326001} then {return 1}
+ if {[Miller--Rabin $n $s $d 7] || $n==3215031751} then {return 0}
+ if {$n < 118670087467} then {return 1}
+% \end{tcl}
+% \(3215031751 = 151 \cdot 751 \cdot 28351\) is a Carmichael
+% number~\cite[p.\,1022]{PSW80}.
+%
+% Having exhausted this list of limits below which |Miller--Rabin|
+% for \(a=2,3,5,7\) detects all composite numbers, we now have to
+% resort to picking bases at random and hoping we find one which
+% would reveal a composite $n$. In the future, one might want to
+% add the possibility of using a deterministic test (such as the
+% AKR~\cite{CL84} or AKS~\cite{AKS04} test) here instead.
+%
+% \begin{tcl}
+ array set O {-randommr 4}
+ array set O $args
+ for {set i $O(-randommr)} {$i >= 1} {incr i -1} {
+ if {[Miller--Rabin $n $s $d [expr {(
+% \end{tcl}
+%
+% The probabilistic sequence of Miller--Rabin tests employs
+% \Tcl's built-in pseudorandom number generator |rand()| for
+% choosing bases, as this does not seem to be an application that
+% requires high quality randomness. It may however be observed
+% that since by now \(n > 10^{11}\), the space of possible bases $a$
+% is always several times larger than the state space of |rand()|,
+% so there may be a point in tweaking the PRNG to avoid some less
+% useful values of $a$.
+%
+% It is a trivial observation that the intermediate $x$ values
+% computed by |Miller--Rabin| for \(a=a_1a_2\) are simply the
+% products of the corresponding values computed for \(a=a_1\) and
+% \(a=a_2\) respectively---hence chances are that if no
+% compositeness was detected for \(a=a_1\) or \(a=a_2\) then it
+% won't be detected for \(a=a_1a_2\) either. There is a slight
+% chance that something interesting could happen if \(a_1^{d2^k}
+% \equiv -1 \equiv a_2^{d2^k} \pmod{n}\) for some \(k>0\), since in
+% that case \((a_1a_2)^{d2^k} \equiv 1 \pmod{n}\) whereas no direct
+% conclusion can be reached about $(a_1a_2)^{d2^{k-1}}$, but this
+% seems a rather special case (and cannot even occur if \(n
+% \equiv 3 \pmod{4}\) since in that case \(s=1\)), so it seems
+% natural to prefer $a$ that are primes. Generating only prime $a$
+% would be much work, but avoiding numbers divisible by $2$ or $3$
+% is feasible.
+%
+% First turn |rand()| back into the integer it internally is, and
+% adjust it to be from $0$ and up.
+% \begin{tcl}
+ (round(rand()*0x100000000)-1)
+% \end{tcl}
+% Then multiply by $3$ and set the last bit. This has the effect
+% that the range of the PRNG is now $\{1,3,7,9,13,15,\dotsb,
+% 6n +\nobreak 1, 6n +\nobreak 3, \dotsb \}$.
+% \begin{tcl}
+ *3 | 1)
+% \end{tcl}
+% Finally add $10$ so that we get $11$, $13$, $17$, $19$, \dots
+% \begin{tcl}
+ + 10
+ }]]} then {return 0}
+ }
+% \end{tcl}
+% That ends the |for| loop for |Miller--Rabin| with random bases.
+% At this point, since the number in question passed the requested
+% number of Miller--Rabin rounds, it is proclaimed to be ``probably
+% prime''.
+% \begin{tcl}
+ return on
+}
+%</pkg>
+% \end{tcl}
+%
+% Tests of |isprime| would mostly be asking ``is $n$ a prime'' for
+% various interesting $n$. Several values of $n$ should be the same
+% as the previous tests:
+% \begin{tcl}
+%<*test>
+test isprime-1.1 "1 is not prime" -body {
+ ::math::numtheory::isprime 1
+} -result 0
+test isprime-1.2 "0 is not prime" -body {
+ ::math::numtheory::isprime 0
+} -result 0
+test isprime-1.3 "-2 is not prime" -body {
+ ::math::numtheory::isprime -2
+} -result 0
+test isprime-1.4 "2 is prime" -body {
+ ::math::numtheory::isprime 2
+} -result 1
+test isprime-1.5 "6 is not prime" -body {
+ ::math::numtheory::isprime 6
+} -result 0
+test isprime-1.6 "7 is prime" -body {
+ ::math::numtheory::isprime 7
+} -result 1
+test isprime-1.7 "101 is prime" -body {
+ ::math::numtheory::isprime 101
+} -result 1
+test isprime-1.8 "105 is not prime" -body {
+ ::math::numtheory::isprime 105
+} -result 0
+test isprime-1.9 "121 is not prime" -body {
+ ::math::numtheory::isprime 121
+} -result 0
+test isprime-1.10 "127 is prime" -body {
+ ::math::numtheory::isprime 127
+} -result 1
+test isprime-1.11 "4369 is not prime" -body {
+ ::math::numtheory::isprime 4369
+} -result 0
+test isprime-1.12 "1373653 is not prime" -body {
+ ::math::numtheory::isprime 1373653
+} -result 0
+test isprime-1.13 "25326001 is not prime" -body {
+ ::math::numtheory::isprime 25326001
+} -result 0
+test isprime-1.14 "3215031751 is not prime" -body {
+ ::math::numtheory::isprime 3215031751
+} -result 0
+% \end{tcl}
+% To get consistent results for large non-primes, it is necessary
+% to reduce the number of random rounds and\slash or reset the PRNG.
+% \begin{tcl}
+test isprime-1.15 "118670087467 may appear prime, but isn't" -body {
+ expr srand(1)
+ list\
+ [::math::numtheory::isprime 118670087467 -randommr 0]\
+ [::math::numtheory::isprime 118670087467 -randommr 1]
+} -result {on 0}
+% \end{tcl}
+% However, a few new can be added. On~\cite[p.\,925]{Jaeschke} we
+% can read that \(p=22 \mkern1mu 754 \mkern1mu 930 \mkern1mu 352
+% \mkern1mu 733\) is a prime, and $p (3p -\nobreak 2)\) is a
+% composite number that looks prime to |Miller--Rabin| for all
+% \(a \in \{2,3,5,7,11,13,17,19,23,29\}\).
+% \begin{tcl}
+test isprime-1.16 "Jaeschke psi_10" -body {
+ expr srand(1)
+ set p 22754930352733
+ set n [expr {$p * (3*$p-2)}]
+ list\
+ [::math::numtheory::isprime $p -randommr 25]\
+ [::math::numtheory::isprime $n -randommr 0]\
+ [::math::numtheory::isprime $n -randommr 1]
+} -result {on on 0}
+% \end{tcl}
+% On the same page it is stated that \(p=137 \mkern1mu 716 \mkern1mu
+% 125 \mkern1mu 329 \mkern1mu 053\) is a prime such that
+% $p (3p -\nobreak 2)\) is a composite number that looks prime to
+% |Miller--Rabin| for all \(a \in
+% \{2,3,5,7,11,13,17,19,23,29,31\}\).
+% \begin{tcl}
+test isprime-1.17 "Jaeschke psi_11" -body {
+ expr srand(1)
+ set p 137716125329053
+ set n [expr {$p * (3*$p-2)}]
+ list\
+ [::math::numtheory::isprime $p -randommr 25]\
+ [::math::numtheory::isprime $n -randommr 0]\
+ [::math::numtheory::isprime $n -randommr 1]\
+ [::math::numtheory::isprime $n -randommr 2]
+} -result {on on on 0}
+% \end{tcl}
+% RFC~2409~\cite{RFC2409} lists a number of primes (and primitive
+% generators of their respective multiplicative groups). The
+% smallest of these is defined as \(p = 2^{768} - 2^{704} - 1 +
+% 2^{64} \cdot \left( [2^{638} \pi] + 149686 \right)\) (where the
+% brackets probably denote rounding to the nearest integer), but
+% since high precision (roughly $200$ decimal digits would be
+% required) values of \(\pi = 3.14159\dots\) are a bit awkward to
+% get hold of, we might as well use the stated hexadecimal digit
+% expansion for~$p$. It might also be a good idea to verify that
+% this is given with most significant digit first.
+% \begin{tcl}
+test isprime-1.18 "OAKLEY group 1 prime" -body {
+ set digits [join {
+ FFFFFFFF FFFFFFFF C90FDAA2 2168C234 C4C6628B 80DC1CD1
+ 29024E08 8A67CC74 020BBEA6 3B139B22 514A0879 8E3404DD
+ EF9519B3 CD3A431B 302B0A6D F25F1437 4FE1356D 6D51C245
+ E485B576 625E7EC6 F44C42E9 A63A3620 FFFFFFFF FFFFFFFF
+ } ""]
+ expr srand(1)
+ list\
+ [::math::numtheory::isprime 0x$digits]\
+ [::math::numtheory::isprime 0x[string reverse $digits]]
+} -result {on 0}
+% \end{tcl}
+%
+% A quite different thing to test is that the tweaked PRNG really
+% produces only \(a \equiv 1,5 \pmod{6}\).
+% \begin{tcl}
+test isprime-2.0 "PRNG tweak" -setup {
+ namespace eval ::math::numtheory {
+ rename Miller--Rabin _orig_Miller--Rabin
+ proc Miller--Rabin {n s d a} {
+ expr {$a>7 && $a%6!=1 && $a%6!=5}
+ }
+ }
+} -body {
+ ::math::numtheory::isprime 118670087467 -randommr 500
+} -result on -cleanup {
+ namespace eval ::math::numtheory {
+ rename Miller--Rabin ""
+ rename _orig_Miller--Rabin Miller--Rabin
+ }
+}
+%</test>
+% \end{tcl}
+% \end{proc}
+%
+%
+% \section*{Closings}
+%
+% \begin{tcl}
+%<*man>
+[list_end]
+
+[keywords {number theory} prime]
+[manpage_end]
+%</man>
+% \end{tcl}
+%
+% \begin{tcl}
+%<test>testsuiteCleanup
+% \end{tcl}
+%
+%
+% \begin{thebibliography}{9}
+%
+% \bibitem{AKS04}
+% Manindra Agrawal, Neeraj Kayal, and Nitin Saxena:
+% PRIMES is in P,
+% \textit{Annals of Mathematics} \textbf{160} (2004), no. 2,
+% 781--793.
+%
+% \bibitem{CL84}
+% Henri Cohen and Hendrik W. Lenstra, Jr.:
+% Primality testing and Jacobi sums,
+% \textit{Mathematics of Computation} \textbf{42} (165) (1984),
+% 297--330.
+% \texttt{doi:10.2307/2007581}
+%
+% \bibitem{RFC2409}
+% Dan Harkins and Dave Carrel.
+% \textit{The Internet Key Exchange (IKE)},
+% \textbf{RFC 2409} (1998).
+%
+% \bibitem{Jaeschke}
+% Gerhard Jaeschke: On strong pseudoprimes to several bases,
+% \textit{Mathematics of Computation} \textbf{61} (204), 1993,
+% 915--926.
+% \texttt{doi:\,10.2307/2153262}
+%
+% \bibitem{Miller}
+% Gary L. Miller:
+% Riemann's Hypothesis and Tests for Primality,
+% \textit{Journal of Computer and System Sciences} \textbf{13} (3)
+% (1976), 300--317. \texttt{doi:10.1145/800116.803773}
+%
+% \bibitem{PSW80}
+% C.~Pomerance, J.~L.~Selfridge, and S.~S.~Wagstaff~Jr.:
+% The pseudoprimes to $25 \cdot 10^9$,
+% \textit{Mathematics of Computation} \textbf{35} (151), 1980,
+% 1003--1026.
+% \texttt{doi: 10.2307/2006210}
+%
+% \bibitem{Rabin}
+% Michael O. Rabin:
+% Probabilistic algorithm for testing primality,
+% \textit{Journal of Number Theory} \textbf{12} (1) (1980),
+% 128--138. \texttt{doi:10.1016/0022-314X(80)90084-0}
+%
+% \bibitem{Wikipedia}
+% Wikipedia contributors:
+% Miller--Rabin primality test,
+% \textit{Wikipedia, The Free Encyclopedia}, 2010.
+% Online, accessed 10 September 2010,
+% \url{http://en.wikipedia.org/w/index.php?title=Miller%E2%80%93Rabin_primality_test&oldid=383901104}
+%
+% \end{thebibliography}
+%
+\endinput
diff --git a/tcllib/modules/math/numtheory.man b/tcllib/modules/math/numtheory.man
new file mode 100644
index 0000000..ad35161
--- /dev/null
+++ b/tcllib/modules/math/numtheory.man
@@ -0,0 +1,56 @@
+[manpage_begin math::numtheory n 1.0]
+[keywords {number theory}]
+[keywords prime]
+[copyright "2010 Lars Hellstr\u00F6m\
+ <Lars dot Hellstrom at residenset dot net>"]
+[moddesc {Tcl Math Library}]
+[titledesc {Number Theory}]
+[category Mathematics]
+[require Tcl [opt 8.5]]
+[require math::numtheory [opt 1.0]]
+
+[description]
+[para]
+This package is for collecting various number-theoretic operations,
+though at the moment it only provides that of testing whether an
+integer is a prime.
+
+[list_begin definitions]
+[call [cmd math::numtheory::isprime] [arg N] [
+ opt "[arg option] [arg value] ..."
+]]
+ The [cmd isprime] command tests whether the integer [arg N] is a
+ prime, returning a boolean true value for prime [arg N] and a
+ boolean false value for non-prime [arg N]. The formal definition of
+ 'prime' used is the conventional, that the number being tested is
+ greater than 1 and only has trivial divisors.
+ [para]
+
+ To be precise, the return value is one of [const 0] (if [arg N] is
+ definitely not a prime), [const 1] (if [arg N] is definitely a
+ prime), and [const on] (if [arg N] is probably prime); the latter
+ two are both boolean true values. The case that an integer may be
+ classified as "probably prime" arises because the Miller-Rabin
+ algorithm used in the test implementation is basically probabilistic,
+ and may if we are unlucky fail to detect that a number is in fact
+ composite. Options may be used to select the risk of such
+ "false positives" in the test. [const 1] is returned for "small"
+ [arg N] (which currently means [arg N] < 118670087467), where it is
+ known that no false positives are possible.
+ [para]
+
+ The only option currently defined is:
+ [list_begin options]
+ [opt_def -randommr [arg repetitions]]
+ which controls how many times the Miller-Rabin test should be
+ repeated with randomly chosen bases. Each repetition reduces the
+ probability of a false positive by a factor at least 4. The
+ default for [arg repetitions] is 4.
+ [list_end]
+ Unknown options are silently ignored.
+
+[list_end]
+
+[vset CATEGORY {math :: numtheory}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/numtheory.stitch b/tcllib/modules/math/numtheory.stitch
new file mode 100644
index 0000000..0318154
--- /dev/null
+++ b/tcllib/modules/math/numtheory.stitch
@@ -0,0 +1,17 @@
+# -*- tcl -*-
+# Stitch definition for docstrip files, used by SAK.
+
+input numtheory.dtx
+
+options -metaprefix \# -preamble {In other words:
+**************************************
+* This Source is not the True Source *
+**************************************
+the true source is the file from which this one was generated.
+}
+
+stitch numtheory.tcl pkg
+stitch numtheory.test test
+
+options -nopreamble -nopostamble
+stitch numtheory.man man
diff --git a/tcllib/modules/math/numtheory.tcl b/tcllib/modules/math/numtheory.tcl
new file mode 100644
index 0000000..e426705
--- /dev/null
+++ b/tcllib/modules/math/numtheory.tcl
@@ -0,0 +1,78 @@
+##
+## This is the file `numtheory.tcl',
+## generated with the SAK utility
+## (sak docstrip/regen).
+##
+## The original source files were:
+##
+## numtheory.dtx (with options: `pkg')
+##
+## In other words:
+## **************************************
+## * This Source is not the True Source *
+## **************************************
+## the true source is the file from which this one was generated.
+##
+# Copyright (c) 2010 by Lars Hellstrom. All rights reserved.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+package require Tcl 8.5
+package provide math::numtheory 1.0
+namespace eval ::math::numtheory {
+ namespace export isprime
+}
+proc ::math::numtheory::prime_trialdivision {n} {
+ if {$n<2} then {return -code return 0}
+ if {$n<4} then {return -code return 1}
+ if {$n%2 == 0} then {return -code return 0}
+ if {$n<9} then {return -code return 1}
+ if {$n%3 == 0} then {return -code return 0}
+ if {$n%5 == 0} then {return -code return 0}
+ if {$n%7 == 0} then {return -code return 0}
+ if {$n<121} then {return -code return 1}
+}
+proc ::math::numtheory::Miller--Rabin {n s d a} {
+ set x 1
+ while {$d>1} {
+ if {$d & 1} then {set x [expr {$x*$a % $n}]}
+ set a [expr {$a*$a % $n}]
+ set d [expr {$d >> 1}]
+ }
+ set x [expr {$x*$a % $n}]
+ if {$x == 1} then {return 0}
+ for {} {$s>1} {incr s -1} {
+ if {$x == $n-1} then {return 0}
+ set x [expr {$x*$x % $n}]
+ if {$x == 1} then {return 1}
+ }
+ return [expr {$x != $n-1}]
+}
+proc ::math::numtheory::isprime {n args} {
+ prime_trialdivision $n
+ set d [expr {$n-1}]; set s 0
+ while {($d&1) == 0} {
+ incr s
+ set d [expr {$d>>1}]
+ }
+ if {[Miller--Rabin $n $s $d 2]} then {return 0}
+ if {$n < 2047} then {return 1}
+ if {[Miller--Rabin $n $s $d 3]} then {return 0}
+ if {$n < 1373653} then {return 1}
+ if {[Miller--Rabin $n $s $d 5]} then {return 0}
+ if {$n < 25326001} then {return 1}
+ if {[Miller--Rabin $n $s $d 7] || $n==3215031751} then {return 0}
+ if {$n < 118670087467} then {return 1}
+ array set O {-randommr 4}
+ array set O $args
+ for {set i $O(-randommr)} {$i >= 1} {incr i -1} {
+ if {[Miller--Rabin $n $s $d [expr {(
+ (round(rand()*0x100000000)-1)
+ *3 | 1)
+ + 10
+ }]]} then {return 0}
+ }
+ return on
+}
+##
+##
+## End of file `numtheory.tcl'. \ No newline at end of file
diff --git a/tcllib/modules/math/numtheory.test b/tcllib/modules/math/numtheory.test
new file mode 100644
index 0000000..fa6364a
--- /dev/null
+++ b/tcllib/modules/math/numtheory.test
@@ -0,0 +1,208 @@
+##
+## This is the file `numtheory.test',
+## generated with the SAK utility
+## (sak docstrip/regen).
+##
+## The original source files were:
+##
+## numtheory.dtx (with options: `test')
+##
+## In other words:
+## **************************************
+## * This Source is not the True Source *
+## **************************************
+## the true source is the file from which this one was generated.
+##
+source [file join\
+ [file dirname [file dirname [file join [pwd] [info script]]]]\
+ devtools testutilities.tcl]
+testsNeedTcl 8.5
+testsNeedTcltest 2
+testing {useLocal numtheory.tcl math::numtheory}
+test prime_trialdivision-1 "Trial division of 1" -body {
+ ::math::numtheory::prime_trialdivision 1
+} -returnCodes 2 -result 0
+test prime_trialdivision-2 "Trial division of 2" -body {
+ ::math::numtheory::prime_trialdivision 2
+} -returnCodes 2 -result 1
+test prime_trialdivision-3 "Trial division of 6" -body {
+ ::math::numtheory::prime_trialdivision 6
+} -returnCodes 2 -result 0
+test prime_trialdivision-4 "Trial division of 7" -body {
+ ::math::numtheory::prime_trialdivision 7
+} -returnCodes 2 -result 1
+test prime_trialdivision-5 "Trial division of 101" -body {
+ ::math::numtheory::prime_trialdivision 101
+} -returnCodes 2 -result 1
+test prime_trialdivision-6 "Trial division of 105" -body {
+ ::math::numtheory::prime_trialdivision 105
+} -returnCodes 2 -result 0
+test prime_trialdivision-7 "Trial division of 121" -body {
+ ::math::numtheory::prime_trialdivision 121
+} -returnCodes 0 -result ""
+test prime_trialdivision-8 "Trial division of 127" -body {
+ ::math::numtheory::prime_trialdivision 127
+} -returnCodes 0 -result ""
+test Miller--Rabin-1.1 "Miller--Rabin 3" -body {
+ list [::math::numtheory::Miller--Rabin 3 1 1 1]\
+ [::math::numtheory::Miller--Rabin 3 1 1 2]
+} -result {0 0}
+test Miller--Rabin-1.2 "Miller--Rabin 11" -body {
+ list [::math::numtheory::Miller--Rabin 11 1 5 1]\
+ [::math::numtheory::Miller--Rabin 11 1 5 2]\
+ [::math::numtheory::Miller--Rabin 11 1 5 4]
+} -result {0 0 0}
+test Miller--Rabin-1.3 "Miller--Rabin 27" -body {
+ list [::math::numtheory::Miller--Rabin 27 1 13 1]\
+ [::math::numtheory::Miller--Rabin 27 1 13 2]\
+ [::math::numtheory::Miller--Rabin 27 1 13 3]\
+ [::math::numtheory::Miller--Rabin 27 1 13 4]\
+ [::math::numtheory::Miller--Rabin 27 1 13 8]\
+ [::math::numtheory::Miller--Rabin 27 1 13 26]
+} -result {0 1 1 1 1 0}
+test Miller--Rabin-1.4 "Miller--Rabin 65" -body {
+ list [::math::numtheory::Miller--Rabin 65 6 1 1]\
+ [::math::numtheory::Miller--Rabin 65 6 1 64]\
+ [::math::numtheory::Miller--Rabin 65 6 1 14]\
+ [::math::numtheory::Miller--Rabin 65 6 1 8]\
+ [::math::numtheory::Miller--Rabin 65 6 1 27]\
+ [::math::numtheory::Miller--Rabin 65 6 1 2]
+} -result {0 0 1 0 1 1}
+test Miller--Rabin-1.5 "Miller--Rabin 17*257" -body {
+ list [::math::numtheory::Miller--Rabin 4369 4 273 1]\
+ [::math::numtheory::Miller--Rabin 4369 4 273 4368]\
+ [::math::numtheory::Miller--Rabin 4369 4 273 4113]\
+ [::math::numtheory::Miller--Rabin 4369 4 273 1815]\
+ [::math::numtheory::Miller--Rabin 4369 4 273 273]\
+ [::math::numtheory::Miller--Rabin 4369 4 273 2831]\
+ [::math::numtheory::Miller--Rabin 4369 4 273 1029]\
+ [::math::numtheory::Miller--Rabin 4369 4 273 2315]\
+ [::math::numtheory::Miller--Rabin 4369 4 273 258]
+} -result {0 0 1 0 1 0 1 0 1}
+test Miller--Rabin-2.1 "Miller--Rabin 1373653" -body {
+ list\
+ [::math::numtheory::Miller--Rabin 1373653 2 343413 2]\
+ [::math::numtheory::Miller--Rabin 1373653 2 343413 3]\
+ [::math::numtheory::Miller--Rabin 1373653 2 343413 5]
+} -result {0 0 1}
+test Miller--Rabin-2.2 "Miller--Rabin 25326001" -body {
+ list\
+ [::math::numtheory::Miller--Rabin 25326001 4 1582875 2]\
+ [::math::numtheory::Miller--Rabin 25326001 4 1582875 3]\
+ [::math::numtheory::Miller--Rabin 25326001 4 1582875 5]\
+ [::math::numtheory::Miller--Rabin 25326001 4 1582875 7]
+} -result {0 0 0 1}
+test Miller--Rabin-2.3 "Miller--Rabin 3215031751" -body {
+ list\
+ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 2]\
+ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 3]\
+ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 5]\
+ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 7]\
+ [::math::numtheory::Miller--Rabin 3215031751 1 1607515875 11]
+} -result {0 0 0 0 1}
+test Miller--Rabin-2.4 "Miller--Rabin 118670087467" -body {
+ list\
+ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 2]\
+ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 3]\
+ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 5]\
+ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 7]\
+ [::math::numtheory::Miller--Rabin 118670087467 1 59335043733 11]
+} -result {0 0 0 0 1}
+test isprime-1.1 "1 is not prime" -body {
+ ::math::numtheory::isprime 1
+} -result 0
+test isprime-1.2 "0 is not prime" -body {
+ ::math::numtheory::isprime 0
+} -result 0
+test isprime-1.3 "-2 is not prime" -body {
+ ::math::numtheory::isprime -2
+} -result 0
+test isprime-1.4 "2 is prime" -body {
+ ::math::numtheory::isprime 2
+} -result 1
+test isprime-1.5 "6 is not prime" -body {
+ ::math::numtheory::isprime 6
+} -result 0
+test isprime-1.6 "7 is prime" -body {
+ ::math::numtheory::isprime 7
+} -result 1
+test isprime-1.7 "101 is prime" -body {
+ ::math::numtheory::isprime 101
+} -result 1
+test isprime-1.8 "105 is not prime" -body {
+ ::math::numtheory::isprime 105
+} -result 0
+test isprime-1.9 "121 is not prime" -body {
+ ::math::numtheory::isprime 121
+} -result 0
+test isprime-1.10 "127 is prime" -body {
+ ::math::numtheory::isprime 127
+} -result 1
+test isprime-1.11 "4369 is not prime" -body {
+ ::math::numtheory::isprime 4369
+} -result 0
+test isprime-1.12 "1373653 is not prime" -body {
+ ::math::numtheory::isprime 1373653
+} -result 0
+test isprime-1.13 "25326001 is not prime" -body {
+ ::math::numtheory::isprime 25326001
+} -result 0
+test isprime-1.14 "3215031751 is not prime" -body {
+ ::math::numtheory::isprime 3215031751
+} -result 0
+test isprime-1.15 "118670087467 may appear prime, but isn't" -body {
+ expr srand(1)
+ list\
+ [::math::numtheory::isprime 118670087467 -randommr 0]\
+ [::math::numtheory::isprime 118670087467 -randommr 1]
+} -result {on 0}
+test isprime-1.16 "Jaeschke psi_10" -body {
+ expr srand(1)
+ set p 22754930352733
+ set n [expr {$p * (3*$p-2)}]
+ list\
+ [::math::numtheory::isprime $p -randommr 25]\
+ [::math::numtheory::isprime $n -randommr 0]\
+ [::math::numtheory::isprime $n -randommr 1]
+} -result {on on 0}
+test isprime-1.17 "Jaeschke psi_11" -body {
+ expr srand(1)
+ set p 137716125329053
+ set n [expr {$p * (3*$p-2)}]
+ list\
+ [::math::numtheory::isprime $p -randommr 25]\
+ [::math::numtheory::isprime $n -randommr 0]\
+ [::math::numtheory::isprime $n -randommr 1]\
+ [::math::numtheory::isprime $n -randommr 2]
+} -result {on on on 0}
+test isprime-1.18 "OAKLEY group 1 prime" -body {
+ set digits [join {
+ FFFFFFFF FFFFFFFF C90FDAA2 2168C234 C4C6628B 80DC1CD1
+ 29024E08 8A67CC74 020BBEA6 3B139B22 514A0879 8E3404DD
+ EF9519B3 CD3A431B 302B0A6D F25F1437 4FE1356D 6D51C245
+ E485B576 625E7EC6 F44C42E9 A63A3620 FFFFFFFF FFFFFFFF
+ } ""]
+ expr srand(1)
+ list\
+ [::math::numtheory::isprime 0x$digits]\
+ [::math::numtheory::isprime 0x[string reverse $digits]]
+} -result {on 0}
+test isprime-2.0 "PRNG tweak" -setup {
+ namespace eval ::math::numtheory {
+ rename Miller--Rabin _orig_Miller--Rabin
+ proc Miller--Rabin {n s d a} {
+ expr {$a>7 && $a%6!=1 && $a%6!=5}
+ }
+ }
+} -body {
+ ::math::numtheory::isprime 118670087467 -randommr 500
+} -result on -cleanup {
+ namespace eval ::math::numtheory {
+ rename Miller--Rabin ""
+ rename _orig_Miller--Rabin Miller--Rabin
+ }
+}
+testsuiteCleanup
+##
+##
+## End of file `numtheory.test'. \ No newline at end of file
diff --git a/tcllib/modules/math/optimize.man b/tcllib/modules/math/optimize.man
new file mode 100755
index 0000000..304cd0e
--- /dev/null
+++ b/tcllib/modules/math/optimize.man
@@ -0,0 +1,325 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin math::optimize n 1.0]
+[keywords {linear program}]
+[keywords math]
+[keywords maximum]
+[keywords minimum]
+[keywords optimization]
+[copyright {2004 Arjen Markus <arjenmarkus@users.sourceforge.net>}]
+[copyright {2004,2005 Kevn B. Kenny <kennykb@users.sourceforge.net>}]
+[moddesc {Tcl Math Library}]
+[titledesc {Optimisation routines}]
+[category Mathematics]
+[require Tcl 8.4]
+[require math::optimize [opt 1.0]]
+[description]
+[para]
+This package implements several optimisation algorithms:
+
+[list_begin itemized]
+[item]
+Minimize or maximize a function over a given interval
+
+[item]
+Solve a linear program (maximize a linear function subject to linear
+constraints)
+
+[item]
+Minimize a function of several variables given an initial guess for the
+location of the minimum.
+
+[list_end]
+
+[para]
+The package is fully implemented in Tcl. No particular attention has
+been paid to the accuracy of the calculations. Instead, the
+algorithms have been used in a straightforward manner.
+[para]
+This document describes the procedures and explains their usage.
+
+[section "PROCEDURES"]
+[para]
+This package defines the following public procedures:
+[list_begin definitions]
+
+[call [cmd ::math::optimize::minimum] [arg begin] [arg end] [arg func] [arg maxerr]]
+Minimize the given (continuous) function by examining the values in the
+given interval. The procedure determines the values at both ends and in the
+centre of the interval and then constructs a new interval of 1/2 length
+that includes the minimum. No guarantee is made that the [emph global]
+minimum is found.
+[para]
+The procedure returns the "x" value for which the function is minimal.
+[para]
+[emph {This procedure has been deprecated - use min_bound_1d instead}]
+[para]
+[arg begin] - Start of the interval
+[para]
+[arg end] - End of the interval
+[para]
+[arg func] - Name of the function to be minimized (a procedure taking
+one argument).
+[para]
+[arg maxerr] - Maximum relative error (defaults to 1.0e-4)
+
+[call [cmd ::math::optimize::maximum] [arg begin] [arg end] [arg func] [arg maxerr]]
+Maximize the given (continuous) function by examining the values in the
+given interval. The procedure determines the values at both ends and in the
+centre of the interval and then constructs a new interval of 1/2 length
+that includes the maximum. No guarantee is made that the [emph global]
+maximum is found.
+[para]
+The procedure returns the "x" value for which the function is maximal.
+[para]
+[emph {This procedure has been deprecated - use max_bound_1d instead}]
+[para]
+[arg begin] - Start of the interval
+[para]
+[arg end] - End of the interval
+[para]
+[arg func] - Name of the function to be maximized (a procedure taking
+one argument).
+[para]
+[arg maxerr] - Maximum relative error (defaults to 1.0e-4)
+
+[call [cmd ::math::optimize::min_bound_1d] [arg func] [arg begin] [arg end] [opt "[option -relerror] [arg reltol]"] [opt "[option -abserror] [arg abstol]"] [opt "[option -maxiter] [arg maxiter]"] [opt "[option -trace] [arg traceflag]"]]
+
+Miminizes a function of one variable in the given interval. The procedure
+uses Brent's method of parabolic interpolation, protected by golden-section
+subdivisions if the interpolation is not converging. No guarantee is made
+that a [emph global] minimum is found. The function to evaluate, [arg func],
+must be a single Tcl command; it will be evaluated with an abscissa appended
+as the last argument.
+[para]
+[arg x1] and [arg x2] are the two bounds of
+the interval in which the minimum is to be found. They need not be in
+increasing order.
+[para]
+[arg reltol], if specified, is the desired upper bound
+on the relative error of the result; default is 1.0e-7. The given value
+should never be smaller than the square root of the machine's floating point
+precision, or else convergence is not guaranteed. [arg abstol], if specified,
+is the desired upper bound on the absolute error of the result; default
+is 1.0e-10. Caution must be used with small values of [arg abstol] to
+avoid overflow/underflow conditions; if the minimum is expected to lie
+about a small but non-zero abscissa, you consider either shifting the
+function or changing its length scale.
+[para]
+[arg maxiter] may be used to constrain the number of function evaluations
+to be performed; default is 100. If the command evaluates the function
+more than [arg maxiter] times, it returns an error to the caller.
+[para]
+[arg traceFlag] is a Boolean value. If true, it causes the command to
+print a message on the standard output giving the abscissa and ordinate
+at each function evaluation, together with an indication of what type
+of interpolation was chosen. Default is 0 (no trace).
+
+[call [cmd ::math::optimize::min_unbound_1d] [arg func] [arg begin] [arg end] [opt "[option -relerror] [arg reltol]"] [opt "[option -abserror] [arg abstol]"] [opt "[option -maxiter] [arg maxiter]"] [opt "[option -trace] [arg traceflag]"]]
+
+Miminizes a function of one variable over the entire real number line.
+The procedure uses parabolic extrapolation combined with golden-section
+dilatation to search for a region where a minimum exists, followed by
+Brent's method of parabolic interpolation, protected by golden-section
+subdivisions if the interpolation is not converging. No guarantee is made
+that a [emph global] minimum is found. The function to evaluate, [arg func],
+must be a single Tcl command; it will be evaluated with an abscissa appended
+as the last argument.
+[para]
+[arg x1] and [arg x2] are two initial guesses at where the minimum
+may lie. [arg x1] is the starting point for the minimization, and
+the difference between [arg x2] and [arg x1] is used as a hint at the
+characteristic length scale of the problem.
+[para]
+[arg reltol], if specified, is the desired upper bound
+on the relative error of the result; default is 1.0e-7. The given value
+should never be smaller than the square root of the machine's floating point
+precision, or else convergence is not guaranteed. [arg abstol], if specified,
+is the desired upper bound on the absolute error of the result; default
+is 1.0e-10. Caution must be used with small values of [arg abstol] to
+avoid overflow/underflow conditions; if the minimum is expected to lie
+about a small but non-zero abscissa, you consider either shifting the
+function or changing its length scale.
+[para]
+[arg maxiter] may be used to constrain the number of function evaluations
+to be performed; default is 100. If the command evaluates the function
+more than [arg maxiter] times, it returns an error to the caller.
+[para]
+[arg traceFlag] is a Boolean value. If true, it causes the command to
+print a message on the standard output giving the abscissa and ordinate
+at each function evaluation, together with an indication of what type
+of interpolation was chosen. Default is 0 (no trace).
+
+[call [cmd ::math::optimize::solveLinearProgram] [arg objective] [arg constraints]]
+Solve a [emph "linear program"] in standard form using a straightforward
+implementation of the Simplex algorithm. (In the explanation below: The
+linear program has N constraints and M variables).
+[para]
+The procedure returns a list of M values, the values for which the
+objective function is maximal or a single keyword if the linear program
+is not feasible or unbounded (either "unfeasible" or "unbounded")
+[para]
+[arg objective] - The M coefficients of the objective function
+[para]
+[arg constraints] - Matrix of coefficients plus maximum values that
+implement the linear constraints. It is expected to be a list of N lists
+of M+1 numbers each, M coefficients and the maximum value.
+
+[call [cmd ::math::optimize::linearProgramMaximum] [arg objective] [arg result]]
+Convenience function to return the maximum for the solution found by the
+solveLinearProgram procedure.
+[para]
+[arg objective] - The M coefficients of the objective function
+[para]
+[arg result] - The result as returned by solveLinearProgram
+
+[call [cmd ::math::optimize::nelderMead] [arg objective] [arg xVector] [opt "[option -scale] [arg xScaleVector]"] [opt "[option -ftol] [arg epsilon]"] [opt "[option -maxiter] [arg count]"] [opt "[opt -trace] [arg flag]"]]
+
+Minimizes, in unconstrained fashion, a function of several variable over all
+of space. The function to evaluate, [arg objective], must be a single Tcl
+command. To it will be appended as many elements as appear in the initial guess at
+the location of the minimum, passed in as a Tcl list, [arg xVector].
+[para]
+[arg xScaleVector] is an initial guess at the problem scale; the first
+function evaluations will be made by varying the co-ordinates in [arg xVector]
+by the amounts in [arg xScaleVector]. If [arg xScaleVector] is not supplied,
+the co-ordinates will be varied by a factor of 1.0001 (if the co-ordinate
+is non-zero) or by a constant 0.0001 (if the co-ordinate is zero).
+[para]
+[arg epsilon] is the desired relative error in the value of the function
+evaluated at the minimum. The default is 1.0e-7, which usually gives three
+significant digits of accuracy in the values of the x's.
+[para]pp
+[arg count] is a limit on the number of trips through the main loop of
+the optimizer. The number of function evaluations may be several times
+this number. If the optimizer fails to find a minimum to within [arg ftol]
+in [arg maxiter] iterations, it returns its current best guess and an
+error status. Default is to allow 500 iterations.
+[para]
+[arg flag] is a flag that, if true, causes a line to be written to the
+standard output for each evaluation of the objective function, giving
+the arguments presented to the function and the value returned. Default is
+false.
+
+[para]
+The [cmd nelderMead] procedure returns a list of alternating keywords and
+values suitable for use with [cmd {array set}]. The meaning of the keywords is:
+
+[para]
+[arg x] is the approximate location of the minimum.
+[para]
+[arg y] is the value of the function at [arg x].
+[para]
+[arg yvec] is a vector of the best N+1 function values achieved, where
+N is the dimension of [arg x]
+[para]
+[arg vertices] is a list of vectors giving the function arguments
+corresponding to the values in [arg yvec].
+[para]
+[arg nIter] is the number of iterations required to achieve convergence or
+fail.
+[para]
+[arg status] is 'ok' if the operation succeeded, or 'too-many-iterations'
+if the maximum iteration count was exceeded.
+[para]
+[cmd nelderMead] minimizes the given function using the downhill
+simplex method of Nelder and Mead. This method is quite slow - much
+faster methods for minimization are known - but has the advantage of being
+extremely robust in the face of problems where the minimum lies in
+a valley of complex topology.
+[para]
+[cmd nelderMead] can occasionally find itself "stuck" at a point where
+it can make no further progress; it is recommended that the caller
+run it at least a second time, passing as the initial guess the
+result found by the previous call. The second run is usually very
+fast.
+[para]
+[cmd nelderMead] can be used in some cases for constrained optimization.
+To do this, add a large value to the objective function if the parameters
+are outside the feasible region. To work effectively in this mode,
+[cmd nelderMead] requires that the initial guess be feasible and
+usually requires that the feasible region be convex.
+[list_end]
+
+[section NOTES]
+[para]
+Several of the above procedures take the [emph names] of procedures as
+arguments. To avoid problems with the [emph visibility] of these
+procedures, the fully-qualified name of these procedures is determined
+inside the optimize routines. For the user this has only one
+consequence: the named procedure must be visible in the calling
+procedure. For instance:
+[example {
+ namespace eval ::mySpace {
+ namespace export calcfunc
+ proc calcfunc { x } { return $x }
+ }
+ #
+ # Use a fully-qualified name
+ #
+ namespace eval ::myCalc {
+ puts [min_bound_1d ::myCalc::calcfunc $begin $end]
+ }
+ #
+ # Import the name
+ #
+ namespace eval ::myCalc {
+ namespace import ::mySpace::calcfunc
+ puts [min_bound_1d calcfunc $begin $end]
+ }
+}]
+
+The simple procedures [emph minimum] and [emph maximum] have been
+deprecated: the alternatives are much more flexible, robust and
+require less function evaluations.
+
+[section EXAMPLES]
+[para]
+Let us take a few simple examples:
+[para]
+Determine the maximum of f(x) = x^3 exp(-3x), on the interval (0,10):
+[example {
+proc efunc { x } { expr {$x*$x*$x * exp(-3.0*$x)} }
+puts "Maximum at: [::math::optimize::max_bound_1d efunc 0.0 10.0]"
+}]
+[para]
+The maximum allowed error determines the number of steps taken (with
+each step in the iteration the interval is reduced with a factor 1/2).
+Hence, a maximum error of 0.0001 is achieved in approximately 14 steps.
+[para]
+An example of a [emph "linear program"] is:
+[para]
+Optimise the expression 3x+2y, where:
+[example {
+ x >= 0 and y >= 0 (implicit constraints, part of the
+ definition of linear programs)
+
+ x + y <= 1 (constraints specific to the problem)
+ 2x + 5y <= 10
+}]
+[para]
+This problem can be solved as follows:
+[example {
+
+ set solution [::math::optimize::solveLinearProgram \
+ { 3.0 2.0 } \
+ { { 1.0 1.0 1.0 }
+ { 2.0 5.0 10.0 } } ]
+}]
+[para]
+Note, that a constraint like:
+[example {
+ x + y >= 1
+}]
+can be turned into standard form using:
+[example {
+ -x -y <= -1
+}]
+
+[para]
+The theory of linear programming is the subject of many a text book and
+the Simplex algorithm that is implemented here is the best-known
+method to solve this type of problems, but it is not the only one.
+
+[vset CATEGORY {math :: optimize}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/optimize.tcl b/tcllib/modules/math/optimize.tcl
new file mode 100755
index 0000000..b5ddafe
--- /dev/null
+++ b/tcllib/modules/math/optimize.tcl
@@ -0,0 +1,1319 @@
+#----------------------------------------------------------------------
+#
+# math/optimize.tcl --
+#
+# This file contains functions for optimization of a function
+# or expression.
+#
+# Copyright (c) 2004, by Arjen Markus.
+# Copyright (c) 2004, 2005 by Kevin B. Kenny. All rights reserved.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: optimize.tcl,v 1.12 2011/01/18 07:49:53 arjenmarkus Exp $
+#
+#----------------------------------------------------------------------
+
+package require Tcl 8.4
+
+# math::optimize --
+# Namespace for the commands
+#
+namespace eval ::math::optimize {
+ namespace export minimum maximum solveLinearProgram linearProgramMaximum
+ namespace export min_bound_1d min_unbound_1d
+
+ # Possible extension: minimumExpr, maximumExpr
+}
+
+# minimum --
+# Minimize a given function over a given interval
+#
+# Arguments:
+# begin Start of the interval
+# end End of the interval
+# func Name of the function to be minimized (takes one
+# argument)
+# maxerr Maximum relative error (defaults to 1.0e-4)
+# Return value:
+# Computed value for which the function is minimal
+# Notes:
+# The function needs not to be differentiable, but it is supposed
+# to be continuous. There is no provision for sub-intervals where
+# the function is constant (this might happen when the maximum
+# error is very small, < 1.0e-15)
+#
+# Warning:
+# This procedure is deprecated - use min_bound_1d instead
+#
+proc ::math::optimize::minimum { begin end func {maxerr 1.0e-4} } {
+
+ set nosteps [expr {3+int(-log($maxerr)/log(2.0))}]
+ set delta [expr {0.5*($end-$begin)*$maxerr}]
+
+ for { set step 0 } { $step < $nosteps } { incr step } {
+ set x1 [expr {($end+$begin)/2.0}]
+ set x2 [expr {$x1+$delta}]
+
+ set fx1 [uplevel 1 $func $x1]
+ set fx2 [uplevel 1 $func $x2]
+
+ if {$fx1 < $fx2} {
+ set end $x1
+ } else {
+ set begin $x1
+ }
+ }
+ return $x1
+}
+
+# maximum --
+# Maximize a given function over a given interval
+#
+# Arguments:
+# begin Start of the interval
+# end End of the interval
+# func Name of the function to be maximized (takes one
+# argument)
+# maxerr Maximum relative error (defaults to 1.0e-4)
+# Return value:
+# Computed value for which the function is maximal
+# Notes:
+# The function needs not to be differentiable, but it is supposed
+# to be continuous. There is no provision for sub-intervals where
+# the function is constant (this might happen when the maximum
+# error is very small, < 1.0e-15)
+#
+# Warning:
+# This procedure is deprecated - use max_bound_1d instead
+#
+proc ::math::optimize::maximum { begin end func {maxerr 1.0e-4} } {
+
+ set nosteps [expr {3+int(-log($maxerr)/log(2.0))}]
+ set delta [expr {0.5*($end-$begin)*$maxerr}]
+
+ for { set step 0 } { $step < $nosteps } { incr step } {
+ set x1 [expr {($end+$begin)/2.0}]
+ set x2 [expr {$x1+$delta}]
+
+ set fx1 [uplevel 1 $func $x1]
+ set fx2 [uplevel 1 $func $x2]
+
+ if {$fx1 > $fx2} {
+ set end $x1
+ } else {
+ set begin $x1
+ }
+ }
+ return $x1
+}
+
+#----------------------------------------------------------------------
+#
+# min_bound_1d --
+#
+# Find a local minimum of a function between two given
+# abscissae. Derivative of f is not required.
+#
+# Usage:
+# min_bound_1d f x1 x2 ?-option value?,,,
+#
+# Parameters:
+# f - Function to minimize. Must be expressed as a Tcl
+# command, to which will be appended the value at which
+# to evaluate the function.
+# x1 - Lower bound of the interval in which to search for a
+# minimum
+# x2 - Upper bound of the interval in which to search for a minimum
+#
+# Options:
+# -relerror value
+# Gives the tolerance desired for the returned
+# abscissa. Default is 1.0e-7. Should never be less
+# than the square root of the machine precision.
+# -maxiter n
+# Constrains minimize_bound_1d to evaluate the function
+# no more than n times. Default is 100. If convergence
+# is not achieved after the specified number of iterations,
+# an error is thrown.
+# -guess value
+# Gives a point between x1 and x2 that is an initial guess
+# for the minimum. f(guess) must be at most f(x1) or
+# f(x2).
+# -fguess value
+# Gives the value of the ordinate at the value of '-guess'
+# if known. Default is to evaluate the function
+# -abserror value
+# Gives the desired absolute error for the returned
+# abscissa. Default is 1.0e-10.
+# -trace boolean
+# A true value causes a trace to the standard output
+# of the function evaluations. Default is 0.
+#
+# Results:
+# Returns a two-element list comprising the abscissa at which
+# the function reaches a local minimum within the interval,
+# and the value of the function at that point.
+#
+# Side effects:
+# Whatever side effects arise from evaluating the given function.
+#
+#----------------------------------------------------------------------
+
+proc ::math::optimize::min_bound_1d { f x1 x2 args } {
+
+ set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]]
+
+ set phim1 0.6180339887498949
+ set twomphi 0.3819660112501051
+
+ array set params {
+ -relerror 1.0e-7
+ -abserror 1.0e-10
+ -maxiter 100
+ -trace 0
+ -fguess {}
+ }
+ set params(-guess) [expr { $phim1 * $x1 + $twomphi * $x2 }]
+
+ if { ( [llength $args] % 2 ) != 0 } {
+ return -code error -errorcode [list min_bound_1d wrongNumArgs] \
+ "wrong \# args, should be\
+ \"[lreplace [info level 0] 1 end f x1 x2 ?-option value?...]\""
+ }
+ foreach { key value } $args {
+ if { ![info exists params($key)] } {
+ return -code error -errorcode [list min_bound_1d badoption $key] \
+ "unknown option \"$key\",\
+ should be -abserror,\
+ -fguess, -guess, -initial, -maxiter, -relerror,\
+ or -trace"
+ }
+ set params($key) $value
+ }
+
+ # a and b presumably bracket the minimum of the function. Make sure
+ # they're in ascending order.
+
+ if { $x1 < $x2 } {
+ set a $x1; set b $x2
+ } else {
+ set b $x1; set a $x2
+ }
+
+ set x $params(-guess); # Best abscissa found so far
+ set w $x; # Second best abscissa found so far
+ set v $x; # Most recent earlier value of w
+
+ set e 0.0; # Distance moved on the step before
+ # last.
+
+ # Evaluate the function at the initial guess
+
+ if { $params(-fguess) ne {} } {
+ set fx $params(-fguess)
+ } else {
+ set s $f; lappend s $x; set fx [eval $s]
+ if { $params(-trace) } {
+ puts stdout "f($x) = $fx (initialisation)"
+ }
+ }
+ set fw $fx
+ set fv $fx
+
+ for { set iter 0 } { $iter < $params(-maxiter) } { incr iter } {
+
+ # Find the midpoint of the current interval
+
+ set xm [expr { 0.5 * ( $a + $b ) }]
+
+ # Compute the current tolerance for x, and twice its value
+
+ set tol [expr { $params(-relerror) * abs($x) + $params(-abserror) }]
+ set tol2 [expr { $tol + $tol }]
+ if { abs( $x - $xm ) <= $tol2 - 0.5 * ($b - $a) } {
+ return [list $x $fx]
+ }
+ set golden 1
+ if { abs($e) > $tol } {
+
+ # Use parabolic interpolation to find a minimum determined
+ # by the evaluations at x, v, and w. The size of the step
+ # to take will be $p/$q.
+
+ set r [expr { ( $x - $w ) * ( $fx - $fv ) }]
+ set q [expr { ( $x - $v ) * ( $fx - $fw ) }]
+ set p [expr { ( $x - $v ) * $q - ( $x - $w ) * $r }]
+ set q [expr { 2. * ( $q - $r ) }]
+ if { $q > 0 } {
+ set p [expr { - $p }]
+ } else {
+ set q [expr { - $q }]
+ }
+ set olde $e
+ set e $d
+
+ # Test if parabolic interpolation results in less than half
+ # the movement of the step two steps ago.
+
+ if { abs($p) < abs( .5 * $q * $olde )
+ && $p > $q * ( $a - $x )
+ && $p < $q * ( $b - $x ) } {
+
+ set d [expr { $p / $q }]
+ set u [expr { $x + $d }]
+ if { ( $u - $a ) < $tol2 || ( $b - $u ) < $tol2 } {
+ if { $xm-$x < 0 } {
+ set d [expr { - $tol }]
+ } else {
+ set d $tol
+ }
+ }
+ set golden 0
+ }
+ }
+
+ # If parabolic interpolation didn't come up with an acceptable
+ # result, use Golden Section instead.
+
+ if { $golden } {
+ if { $x >= $xm } {
+ set e [expr { $a - $x }]
+ } else {
+ set e [expr { $b - $x }]
+ }
+ set d [expr { $twomphi * $e }]
+ }
+
+ # At this point, d is the size of the step to take. Make sure
+ # that it's at least $tol.
+
+ if { abs($d) >= $tol } {
+ set u [expr { $x + $d }]
+ } elseif { $d < 0 } {
+ set u [expr { $x - $tol }]
+ } else {
+ set u [expr { $x + $tol }]
+ }
+
+ # Evaluate the function
+
+ set s $f; lappend s $u; set fu [eval $s]
+ if { $params(-trace) } {
+ if { $golden } {
+ puts stdout "f($u)=$fu (golden section)"
+ } else {
+ puts stdout "f($u)=$fu (parabolic interpolation)"
+ }
+ }
+
+ if { $fu <= $fx } {
+ # We've the best abscissa so far.
+
+ if { $u >= $x } {
+ set a $x
+ } else {
+ set b $x
+ }
+ set v $w
+ set fv $fw
+ set w $x
+ set fw $fx
+ set x $u
+ set fx $fu
+ } else {
+
+ if { $u < $x } {
+ set a $u
+ } else {
+ set b $u
+ }
+ if { $fu <= $fw || $w == $x } {
+ # We've the second-best abscissa so far
+ set v $w
+ set fv $fw
+ set w $u
+ set fw $fu
+ } elseif { $fu <= $fv || $v == $x || $v == $w } {
+ # We've the third-best so far
+ set v $u
+ set fv $fu
+ }
+ }
+ }
+
+ return -code error -errorcode [list min_bound_1d noconverge $iter] \
+ "[lindex [info level 0] 0] failed to converge after $iter steps."
+
+}
+
+#----------------------------------------------------------------------
+#
+# brackmin --
+#
+# Find a place along the number line where a given function has
+# a local minimum.
+#
+# Usage:
+# brackmin f x1 x2 ?trace?
+#
+# Parameters:
+# f - Function to minimize
+# x1 - Abscissa thought to be near the minimum
+# x2 - Additional abscissa thought to be near the minimum
+# trace - Boolean variable that, if true,
+# causes 'brackmin' to print a trace of its function
+# evaluations to the standard output. Default is 0.
+#
+# Results:
+# Returns a three element list {x1 y1 x2 y2 x3 y3} where
+# y1=f(x1), y2=f(x2), y3=f(x3). x2 lies between x1 and x3, and
+# y1>y2, y3>y2, proving that there is a local minimum somewhere
+# in the interval (x1,x3).
+#
+# Side effects:
+# Whatever effects the evaluation of f has.
+#
+#----------------------------------------------------------------------
+
+proc ::math::optimize::brackmin { f x1 x2 {trace 0} } {
+
+ set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]]
+
+ set phi 1.6180339887498949
+ set epsilon 1.0e-20
+ set limit 50.
+
+ # Choose a and b so that f(a) < f(b)
+
+ set cmd $f; lappend cmd $x1; set fx1 [eval $cmd]
+ if { $trace } {
+ puts "f($x1) = $fx1 (initialisation)"
+ }
+ set cmd $f; lappend cmd $x2; set fx2 [eval $cmd]
+ if { $trace } {
+ puts "f($x2) = $fx2 (initialisation)"
+ }
+ if { $fx1 > $fx2 } {
+ set a $x1; set fa $fx1
+ set b $x2; set fb $fx2
+ } else {
+ set a $x2; set fa $fx2
+ set b $x1; set fb $fx1
+ }
+
+ # Choose a c in the downhill direction
+
+ set c [expr { $b + $phi * ($b - $a) }]
+ set cmd $f; lappend cmd $c; set fc [eval $cmd]
+ if { $trace } {
+ puts "f($c) = $fc (initial dilatation by phi)"
+ }
+
+ while { $fb >= $fc } {
+
+ # Try to do parabolic extrapolation to the minimum
+
+ set r [expr { ($b - $a) * ($fb - $fc) }]
+ set q [expr { ($b - $c) * ($fb - $fa) }]
+ if { abs( $q - $r ) > $epsilon } {
+ set denom [expr { $q - $r }]
+ } elseif { $q > $r } {
+ set denom $epsilon
+ } else {
+ set denom -$epsilon
+ }
+ set u [expr { $b - ( (($b - $c) * $q - ($b - $a) * $r)
+ / (2. * $denom) ) }]
+ set ulimit [expr { $b + $limit * ( $c - $b ) }]
+
+ # Test the extrapolated abscissa
+
+ if { ($b - $u) * ($u - $c) > 0 } {
+
+ # u lies between b and c. Try to interpolate
+
+ set cmd $f; lappend cmd $u; set fu [eval $cmd]
+ if { $trace } {
+ puts "f($u) = $fu (parabolic interpolation)"
+ }
+
+ if { $fu < $fc } {
+
+ # fb > fu and fc > fu, so there is a minimum between b and c
+ # with u as a starting guess.
+
+ return [list $b $fb $u $fu $c $fc]
+
+ }
+
+ if { $fu > $fb } {
+
+ # fb < fu, fb < fa, and u cannot lie between a and b
+ # (because it lies between a and c). There is a minimum
+ # somewhere between a and u, with b a starting guess.
+
+ return [list $a $fa $b $fb $u $fu]
+
+ }
+
+ # Parabolic interpolation was useless. Expand the
+ # distance by a factor of phi and try again.
+
+ set u [expr { $c + $phi * ($c - $b) }]
+ set cmd $f; lappend cmd $u; set fu [eval $cmd]
+ if { $trace } {
+ puts "f($u) = $fu (parabolic interpolation failed)"
+ }
+
+
+ } elseif { ( $c - $u ) * ( $u - $ulimit ) > 0 } {
+
+ # u lies between $c and $ulimit.
+
+ set cmd $f; lappend cmd $u; set fu [eval $cmd]
+ if { $trace } {
+ puts "f($u) = $fu (parabolic extrapolation)"
+ }
+
+ if { $fu > $fc } {
+
+ # minimum lies between b and u, with c an initial guess.
+
+ return [list $b $fb $c $fc $u $fu]
+
+ }
+
+ # function is still decreasing fa > fb > fc > fu. Take
+ # another factor-of-phi step.
+
+ set b $c; set fb $fc
+ set c $u; set fc $fu
+ set u [expr { $c + $phi * ( $c - $b ) }]
+ set cmd $f; lappend cmd $u; set fu [eval $cmd]
+ if { $trace } {
+ puts "f($u) = $fu (parabolic extrapolation ok)"
+ }
+
+ } elseif { ($u - $ulimit) * ( $ulimit - $c ) >= 0 } {
+
+ # u went past ulimit. Pull in to ulimit and evaluate there.
+
+ set u $ulimit
+ set cmd $f; lappend cmd $u; set fu [eval $cmd]
+ if { $trace } {
+ puts "f($u) = $fu (limited step)"
+ }
+
+ } else {
+
+ # parabolic extrapolation gave a useless value.
+
+ set u [expr { $c + $phi * ( $c - $b ) }]
+ set cmd $f; lappend cmd $u; set fu [eval $cmd]
+ if { $trace } {
+ puts "f($u) = $fu (parabolic extrapolation failed)"
+ }
+
+ }
+
+ set a $b; set fa $fb
+ set b $c; set fb $fc
+ set c $u; set fc $fu
+ }
+
+ return [list $a $fa $b $fb $c $fc]
+}
+
+#----------------------------------------------------------------------
+#
+# min_unbound_1d --
+#
+# Minimize a function of one variable, unconstrained, derivatives
+# not required.
+#
+# Usage:
+# min_bound_1d f x1 x2 ?-option value?,,,
+#
+# Parameters:
+# f - Function to minimize. Must be expressed as a Tcl
+# command, to which will be appended the value at which
+# to evaluate the function.
+# x1 - Initial guess at the minimum
+# x2 - Second initial guess at the minimum, used to set the
+# initial length scale for the search.
+#
+# Options:
+# -relerror value
+# Gives the tolerance desired for the returned
+# abscissa. Default is 1.0e-7. Should never be less
+# than the square root of the machine precision.
+# -maxiter n
+# Constrains min_bound_1d to evaluate the function
+# no more than n times. Default is 100. If convergence
+# is not achieved after the specified number of iterations,
+# an error is thrown.
+# -abserror value
+# Gives the desired absolute error for the returned
+# abscissa. Default is 1.0e-10.
+# -trace boolean
+# A true value causes a trace to the standard output
+# of the function evaluations. Default is 0.
+#
+#----------------------------------------------------------------------
+
+proc ::math::optimize::min_unbound_1d { f x1 x2 args } {
+
+ set f [lreplace $f 0 0 [uplevel 1 [list namespace which [lindex $f 0]]]]
+
+ array set params {
+ -relerror 1.0e-7
+ -abserror 1.0e-10
+ -maxiter 100
+ -trace 0
+ }
+ if { ( [llength $args] % 2 ) != 0 } {
+ return -code error -errorcode [list min_unbound_1d wrongNumArgs] \
+ "wrong \# args, should be\
+ \"[lreplace [info level 0] 1 end \
+ f x1 x2 ?-option value?...]\""
+ }
+ foreach { key value } $args {
+ if { ![info exists params($key)] } {
+ return -code error -errorcode [list min_unbound_1d badoption $key] \
+ "unknown option \"$key\",\
+ should be -trace"
+ }
+ set params($key) $value
+ }
+ foreach { a fa b fb c fc } [brackmin $f $x1 $x2 $params(-trace)] {
+ break
+ }
+ return [eval [linsert [array get params] 0 \
+ min_bound_1d $f $a $c -guess $b -fguess $fb]]
+}
+
+#----------------------------------------------------------------------
+#
+# nelderMead --
+#
+# Attempt to minimize/maximize a function using the downhill
+# simplex method of Nelder and Mead.
+#
+# Usage:
+# nelderMead f x ?-keyword value?
+#
+# Parameters:
+# f - The function to minimize. The function must be an incomplete
+# Tcl command, to which will be appended N parameters.
+# x - The starting guess for the minimum; a vector of N parameters
+# to be passed to the function f.
+#
+# Options:
+# -scale xscale
+# Initial guess as to the problem scale. If '-scale' is
+# supplied, then the parameters will be varied by the
+# specified amounts. The '-scale' parameter must of the
+# same dimension as the 'x' vector, and all elements must
+# be nonzero. Default is 0.0001 times the 'x' vector,
+# or 0.0001 for zero elements in the 'x' vector.
+#
+# -ftol epsilon
+# Requested tolerance in the function value; nelderMead
+# returns if N+1 consecutive iterates all differ by less
+# than the -ftol value. Default is 1.0e-7
+#
+# -maxiter N
+# Maximum number of iterations to attempt. Default is
+# 500.
+#
+# -trace flag
+# If '-trace 1' is supplied, nelderMead writes a record
+# of function evaluations to the standard output as it
+# goes. Default is 0.
+#
+#----------------------------------------------------------------------
+
+proc ::math::optimize::nelderMead { f startx args } {
+ array set params {
+ -ftol 1.e-7
+ -maxiter 500
+ -scale {}
+ -trace 0
+ }
+
+ # Check arguments
+
+ if { ( [llength $args] % 2 ) != 0 } {
+ return -code error -errorcode [list nelderMead wrongNumArgs] \
+ "wrong \# args, should be\
+ \"[lreplace [info level 0] 1 end \
+ f x1 x2 ?-option value?...]\""
+ }
+ foreach { key value } $args {
+ if { ![info exists params($key)] } {
+ return -code error -errorcode [list nelderMead badoption $key] \
+ "unknown option \"$key\",\
+ should be -ftol, -maxiter, -scale or -trace"
+ }
+ set params($key) $value
+ }
+
+ # Construct the initial simplex
+
+ set vertices [list $startx]
+ if { [llength $params(-scale)] == 0 } {
+ set i 0
+ foreach x0 $startx {
+ if { $x0 == 0 } {
+ set x1 0.0001
+ } else {
+ set x1 [expr {1.0001 * $x0}]
+ }
+ lappend vertices [lreplace $startx $i $i $x1]
+ incr i
+ }
+ } elseif { [llength $params(-scale)] != [llength $startx] } {
+ return -code error -errorcode [list nelderMead badOption -scale] \
+ "-scale vector must be of same size as starting x vector"
+ } else {
+ set i 0
+ foreach x0 $startx s $params(-scale) {
+ lappend vertices [lreplace $startx $i $i [expr { $x0 + $s }]]
+ incr i
+ }
+ }
+
+ # Evaluate at the initial points
+
+ set n [llength $startx]
+ foreach x $vertices {
+ set cmd $f
+ foreach xx $x {
+ lappend cmd $xx
+ }
+ set y [uplevel 1 $cmd]
+ if {$params(-trace)} {
+ puts "nelderMead: evaluating initial point: x=[list $x] y=$y"
+ }
+ lappend yvec $y
+ }
+
+
+ # Loop adjusting the simplex in the 'vertices' array.
+
+ set nIter 0
+ while { 1 } {
+
+ # Find the highest, next highest, and lowest value in y,
+ # and save the indices.
+
+ set iBot 0
+ set yBot [lindex $yvec 0]
+ set iTop -1
+ set yTop [lindex $yvec 0]
+ set iNext -1
+ set i 0
+ foreach y $yvec {
+ if { $y <= $yBot } {
+ set yBot $y
+ set iBot $i
+ }
+ if { $iTop < 0 || $y >= $yTop } {
+ set iNext $iTop
+ set yNext $yTop
+ set iTop $i
+ set yTop $y
+ } elseif { $iNext < 0 || $y >= $yNext } {
+ set iNext $i
+ set yNext $y
+ }
+ incr i
+ }
+
+ # Return if the relative error is within an acceptable range
+
+ set rerror [expr { 2. * abs( $yTop - $yBot )
+ / ( abs( $yTop ) + abs( $yBot ) + $params(-ftol) ) }]
+ if { $rerror < $params(-ftol) } {
+ set status ok
+ break
+ }
+
+ # Count iterations
+
+ if { [incr nIter] > $params(-maxiter) } {
+ set status too-many-iterations
+ break
+ }
+ incr nIter
+
+ # Find the centroid of the face opposite the vertex that
+ # maximizes the function value.
+
+ set centroid {}
+ for { set i 0 } { $i < $n } { incr i } {
+ lappend centroid 0.0
+ }
+ set i 0
+ foreach v $vertices {
+ if { $i != $iTop } {
+ set newCentroid {}
+ foreach x0 $centroid x1 $v {
+ lappend newCentroid [expr { $x0 + $x1 }]
+ }
+ set centroid $newCentroid
+ }
+ incr i
+ }
+ set newCentroid {}
+ foreach x $centroid {
+ lappend newCentroid [expr { $x / $n }]
+ }
+ set centroid $newCentroid
+
+ # The first trial point is a reflection of the high point
+ # around the centroid
+
+ set trial {}
+ foreach x0 [lindex $vertices $iTop] x1 $centroid {
+ lappend trial [expr {$x1 + ($x1 - $x0)}]
+ }
+ set cmd $f
+ foreach xx $trial {
+ lappend cmd $xx
+ }
+ set yTrial [uplevel 1 $cmd]
+ if { $params(-trace) } {
+ puts "nelderMead: trying reflection: x=[list $trial] y=$yTrial"
+ }
+
+ # If that reflection yields a new minimum, replace the high point,
+ # and additionally try dilating in the same direction.
+
+ if { $yTrial < $yBot } {
+ set trial2 {}
+ foreach x0 $centroid x1 $trial {
+ lappend trial2 [expr { $x1 + ($x1 - $x0) }]
+ }
+ set cmd $f
+ foreach xx $trial2 {
+ lappend cmd $xx
+ }
+ set yTrial2 [uplevel 1 $cmd]
+ if { $params(-trace) } {
+ puts "nelderMead: trying dilated reflection:\
+ x=[list $trial2] y=$y"
+ }
+ if { $yTrial2 < $yBot } {
+
+ # Additional dilation yields a new minimum
+
+ lset vertices $iTop $trial2
+ lset yvec $iTop $yTrial2
+ } else {
+
+ # Additional dilation failed, but we can still use
+ # the first trial point.
+
+ lset vertices $iTop $trial
+ lset yvec $iTop $yTrial
+
+ }
+ } elseif { $yTrial < $yNext } {
+
+ # The reflected point isn't a new minimum, but it's
+ # better than the second-highest. Replace the old high
+ # point and try again.
+
+ lset vertices $iTop $trial
+ lset yvec $iTop $yTrial
+
+ } else {
+
+ # The reflected point is worse than the second-highest point.
+ # If it's better than the highest, keep it... but in any case,
+ # we want to try contracting the simplex, because a further
+ # reflection will simply bring us back to the starting point.
+
+ if { $yTrial < $yTop } {
+ lset vertices $iTop $trial
+ lset yvec $iTop $yTrial
+ set yTop $yTrial
+ }
+ set trial {}
+ foreach x0 [lindex $vertices $iTop] x1 $centroid {
+ lappend trial [expr { ( $x0 + $x1 ) / 2. }]
+ }
+ set cmd $f
+ foreach xx $trial {
+ lappend cmd $xx
+ }
+ set yTrial [uplevel 1 $cmd]
+ if { $params(-trace) } {
+ puts "nelderMead: contracting from high point:\
+ x=[list $trial] y=$y"
+ }
+ if { $yTrial < $yTop } {
+
+ # Contraction gave an improvement, so continue with
+ # the smaller simplex
+
+ lset vertices $iTop $trial
+ lset yvec $iTop $yTrial
+
+ } else {
+
+ # Contraction gave no improvement either; we seem to
+ # be in a valley of peculiar topology. Contract the
+ # simplex about the low point and try again.
+
+ set newVertices {}
+ set newYvec {}
+ set i 0
+ foreach v $vertices y $yvec {
+ if { $i == $iBot } {
+ lappend newVertices $v
+ lappend newYvec $y
+ } else {
+ set newv {}
+ foreach x0 $v x1 [lindex $vertices $iBot] {
+ lappend newv [expr { ($x0 + $x1) / 2. }]
+ }
+ lappend newVertices $newv
+ set cmd $f
+ foreach xx $newv {
+ lappend cmd $xx
+ }
+ lappend newYvec [uplevel 1 $cmd]
+ if { $params(-trace) } {
+ puts "nelderMead: contracting about low point:\
+ x=[list $newv] y=$y"
+ }
+ }
+ incr i
+ }
+ set vertices $newVertices
+ set yvec $newYvec
+ }
+
+ }
+
+ }
+ return [list y $yBot x [lindex $vertices $iBot] vertices $vertices yvec $yvec nIter $nIter status $status]
+
+}
+
+# solveLinearProgram
+# Solve a linear program in standard form
+#
+# Arguments:
+# objective Vector defining the objective function
+# constraints Matrix of constraints (as a list of lists)
+#
+# Return value:
+# Computed values for the coordinates or "unbounded" or "infeasible"
+#
+proc ::math::optimize::solveLinearProgram { objective constraints } {
+ #
+ # Check the arguments first and then put them in a more convenient
+ # form
+ #
+
+ foreach {nconst nvars matrix} \
+ [SimplexPrepareMatrix $objective $constraints] {break}
+
+ set solution [SimplexSolve $nconst nvars $matrix]
+
+ if { [llength $solution] > 1 } {
+ return [lrange $solution 0 [expr {$nvars-1}]]
+ } else {
+ return $solution
+ }
+}
+
+# linearProgramMaximum --
+# Compute the value attained at the optimum
+#
+# Arguments:
+# objective The coefficients of the objective function
+# result The coordinate values as obtained by solving the program
+#
+# Return value:
+# Value at the maximum point
+#
+proc ::math::optimize::linearProgramMaximum {objective result} {
+
+ set value 0.0
+
+ foreach coeff $objective coord $result {
+ set value [expr {$value+$coeff*$coord}]
+ }
+
+ return $value
+}
+
+# SimplexPrintMatrix
+# Debugging routine: print the matrix in easy to read form
+#
+# Arguments:
+# matrix Matrix to be printed
+#
+# Return value:
+# None
+#
+# Note:
+# The tableau should be transposed ...
+#
+proc ::math::optimize::SimplexPrintMatrix {matrix} {
+ puts "\nBasis:\t[join [lindex $matrix 0] \t]"
+ foreach col [lrange $matrix 1 end] {
+ puts " \t[join $col \t]"
+ }
+}
+
+# SimplexPrepareMatrix
+# Prepare the standard tableau from all program data
+#
+# Arguments:
+# objective Vector defining the objective function
+# constraints Matrix of constraints (as a list of lists)
+#
+# Return value:
+# List of values as a standard tableau and two values
+# for the sizes
+#
+proc ::math::optimize::SimplexPrepareMatrix {objective constraints} {
+
+ #
+ # Check the arguments first
+ #
+ set nconst [llength $constraints]
+ set ncols {}
+ foreach row $constraints {
+ if { $ncols == {} } {
+ set ncols [llength $row]
+ } else {
+ if { $ncols != [llength $row] } {
+ return -code error -errorcode ARGS "Incorrectly formed constraints matrix"
+ }
+ }
+ }
+
+ set nvars [expr {$ncols-1}]
+
+ if { [llength $objective] != $nvars } {
+ return -code error -errorcode ARGS "Incorrect length for objective vector"
+ }
+
+ #
+ # Set up the tableau:
+ # Easiest manipulations if we store the columns first
+ # So:
+ # - First column is the list of variable indices in the basis
+ # - Second column is the list of maximum values
+ # - "nvars" columns that follow: the coefficients for the actual
+ # variables
+ # - last "nconst" columns: the slack variables
+ #
+ set matrix [list]
+ set lastrow [concat $objective [list 0.0]]
+
+ set newcol [list]
+ for {set idx 0} {$idx < $nconst} {incr idx} {
+ lappend newcol [expr {$nvars+$idx}]
+ }
+ lappend newcol "?"
+ lappend matrix $newcol
+
+ set zvector [list]
+ foreach row $constraints {
+ lappend zvector [lindex $row end]
+ }
+ lappend zvector 0.0
+ lappend matrix $zvector
+
+ for {set idx 0} {$idx < $nvars} {incr idx} {
+ set newcol [list]
+ foreach row $constraints {
+ lappend newcol [expr {double([lindex $row $idx])}]
+ }
+ lappend newcol [expr {-double([lindex $lastrow $idx])}]
+ lappend matrix $newcol
+ }
+
+ #
+ # Add the columns for the slack variables
+ #
+ set zeros {}
+ for {set idx 0} {$idx <= $nconst} {incr idx} {
+ lappend zeros 0.0
+ }
+ for {set idx 0} {$idx < $nconst} {incr idx} {
+ lappend matrix [lreplace $zeros $idx $idx 1.0]
+ }
+
+ return [list $nconst $nvars $matrix]
+}
+
+# SimplexSolve --
+# Solve the given linear program using the simplex method
+#
+# Arguments:
+# nconst Number of constraints
+# nvars Number of actual variables
+# tableau Standard tableau (as a list of columns)
+#
+# Return value:
+# List of values for the actual variables
+#
+proc ::math::optimize::SimplexSolve {nconst nvars tableau} {
+ set end 0
+ while { !$end } {
+
+ #
+ # Find the new variable to put in the basis
+ #
+ set nextcol [SimplexFindNextColumn $tableau]
+ if { $nextcol == -1 } {
+ set end 1
+ continue
+ }
+
+ #
+ # Now determine which one should leave
+ # TODO: is a lack of a proper row indeed an
+ # indication of the infeasibility?
+ #
+ set nextrow [SimplexFindNextRow $tableau $nextcol]
+ if { $nextrow == -1 } {
+ return "unbounded"
+ }
+
+ #
+ # Make the vector for sweeping through the tableau
+ #
+ set vector [SimplexMakeVector $tableau $nextcol $nextrow]
+
+ #
+ # Sweep through the tableau
+ #
+ set tableau [SimplexNewTableau $tableau $nextcol $nextrow $vector]
+ }
+
+ #
+ # Now we can return the result
+ #
+ SimplexResult $tableau
+}
+
+# SimplexResult --
+# Reconstruct the result vector
+#
+# Arguments:
+# tableau Standard tableau (as a list of columns)
+#
+# Return value:
+# Vector of values representing the maximum point
+#
+proc ::math::optimize::SimplexResult {tableau} {
+ set result {}
+
+ set firstcol [lindex $tableau 0]
+ set secondcol [lindex $tableau 1]
+ set result {}
+
+ set nvars [expr {[llength $tableau]-2}]
+ for {set i 0} {$i < $nvars } { incr i } {
+ lappend result 0.0
+ }
+
+ set idx 0
+ foreach col [lrange $firstcol 0 end-1] {
+ set value [lindex $secondcol $idx]
+ if { $value >= 0.0 } {
+ set result [lreplace $result $col $col [lindex $secondcol $idx]]
+ incr idx
+ } else {
+ # If a negative component, then the problem was not feasible
+ return "infeasible"
+ }
+ }
+
+ return $result
+}
+
+# SimplexFindNextColumn --
+# Find the next column - the one with the largest negative
+# coefficient
+#
+# Arguments:
+# tableau Standard tableau (as a list of columns)
+#
+# Return value:
+# Index of the column
+#
+proc ::math::optimize::SimplexFindNextColumn {tableau} {
+ set idx 0
+ set minidx -1
+ set mincoeff 0.0
+
+ foreach col [lrange $tableau 2 end] {
+ set coeff [lindex $col end]
+ if { $coeff < 0.0 } {
+ if { $coeff < $mincoeff } {
+ set minidx $idx
+ set mincoeff $coeff
+ }
+ }
+ incr idx
+ }
+
+ return $minidx
+}
+
+# SimplexFindNextRow --
+# Find the next row - the one with the largest negative
+# coefficient
+#
+# Arguments:
+# tableau Standard tableau (as a list of columns)
+# nextcol Index of the variable that will replace this one
+#
+# Return value:
+# Index of the row
+#
+proc ::math::optimize::SimplexFindNextRow {tableau nextcol} {
+ set idx 0
+ set minidx -1
+ set mincoeff {}
+
+ set bvalues [lrange [lindex $tableau 1] 0 end-1]
+ set yvalues [lrange [lindex $tableau [expr {2+$nextcol}]] 0 end-1]
+
+ foreach rowcoeff $bvalues divcoeff $yvalues {
+ if { $divcoeff > 0.0 } {
+ set coeff [expr {$rowcoeff/$divcoeff}]
+
+ if { $mincoeff == {} || $coeff < $mincoeff } {
+ set minidx $idx
+ set mincoeff $coeff
+ }
+ }
+ incr idx
+ }
+
+ return $minidx
+}
+
+# SimplexMakeVector --
+# Make the "sweep" vector
+#
+# Arguments:
+# tableau Standard tableau (as a list of columns)
+# nextcol Index of the variable that will replace this one
+# nextrow Index of the variable in the base that will be replaced
+#
+# Return value:
+# Vector to be used to update the coefficients of the tableau
+#
+proc ::math::optimize::SimplexMakeVector {tableau nextcol nextrow} {
+
+ set idx 0
+ set vector {}
+ set column [lindex $tableau [expr {2+$nextcol}]]
+ set divcoeff [lindex $column $nextrow]
+
+ foreach colcoeff $column {
+ if { $idx != $nextrow } {
+ set coeff [expr {-$colcoeff/$divcoeff}]
+ } else {
+ set coeff [expr {1.0/$divcoeff-1.0}]
+ }
+ lappend vector $coeff
+ incr idx
+ }
+
+ return $vector
+}
+
+# SimplexNewTableau --
+# Sweep through the tableau and create the new one
+#
+# Arguments:
+# tableau Standard tableau (as a list of columns)
+# nextcol Index of the variable that will replace this one
+# nextrow Index of the variable in the base that will be replaced
+# vector Vector to sweep with
+#
+# Return value:
+# New tableau
+#
+proc ::math::optimize::SimplexNewTableau {tableau nextcol nextrow vector} {
+
+ #
+ # The first column: replace the nextrow-th element
+ # The second column: replace the value at the nextrow-th element
+ # For all the others: the same receipe
+ #
+ set firstcol [lreplace [lindex $tableau 0] $nextrow $nextrow $nextcol]
+ set newtableau [list $firstcol]
+
+ #
+ # The rest of the matrix
+ #
+ foreach column [lrange $tableau 1 end] {
+ set yval [lindex $column $nextrow]
+ set newcol {}
+ foreach c $column vcoeff $vector {
+ set newval [expr {$c+$yval*$vcoeff}]
+ lappend newcol $newval
+ }
+ lappend newtableau $newcol
+ }
+
+ return $newtableau
+}
+
+# Now we can announce our presence
+package provide math::optimize 1.0.1
+
+if { ![info exists ::argv0] || [string compare $::argv0 [info script]] } {
+ return
+}
+
+namespace import math::optimize::min_bound_1d
+namespace import math::optimize::maximum
+namespace import math::optimize::nelderMead
+
+proc f {x y} {
+ set xx [expr { $x - 3.1415926535897932 / 2. }]
+ set v1 [expr { 0.3 * exp( -$xx*$xx / 2. ) }]
+ set d [expr { 10. * $y - sin(9. * $x) }]
+ set v2 [expr { exp(-10.*$d*$d)}]
+ set rv [expr { -$v1 - $v2 }]
+ return $rv
+}
+
+proc g {a b} {
+ set x1 [expr {0.1 - $a + $b}]
+ set x2 [expr {$a + $b - 1.}]
+ set x3 [expr {3.-8.*$a+8.*$a*$a-8.*$b+8.*$b*$b}]
+ set x4 [expr {$a/10. + $b/10. + $x1*$x1/3. + $x2*$x2 - $x2 * exp(1-$x3*$x3)}]
+ return $x4
+}
+
+set prec $::tcl_precision
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ set ::tcl_precision 17
+} else {
+ set ::tcl_precision 0
+}
+
+puts "f"
+puts [math::optimize::nelderMead f {1. 0.} -scale {0.1 0.01} -trace 1]
+puts "g"
+puts [math::optimize::nelderMead g {0. 0.} -scale {1. 1.} -trace 1]
+
+set ::tcl_precision $prec
diff --git a/tcllib/modules/math/optimize.test b/tcllib/modules/math/optimize.test
new file mode 100755
index 0000000..95827ae
--- /dev/null
+++ b/tcllib/modules/math/optimize.test
@@ -0,0 +1,634 @@
+# -*- tcl -*-
+# Tests for 1-d optimisation functions in math library -*- tcl -*-
+#
+# This file contains a collection of tests for one or more of the Tcllib
+# procedures. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# $Id: optimize.test,v 1.17 2011/01/18 07:49:53 arjenmarkus Exp $
+#
+# Copyright (c) 2004 by Arjen Markus
+# Copyright (c) 2004, 2005 by Kevin B. Kenny
+# All rights reserved.
+#
+# Note:
+# By evaluating the tests in a different namespace than global,
+# we assure that the namespace issue (Bug #...) is checked.
+#
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2.1
+
+support {
+ useLocal math.tcl math
+}
+testing {
+ useLocal optimize.tcl math::optimize
+}
+
+# -------------------------------------------------------------------------
+
+namespace eval optimizetest {
+
+namespace import ::math::optimize::*
+
+set old_precision $::tcl_precision
+if {![package vsatisfies [package present Tcl] 8.5]} {
+ set ::tcl_precision 17
+} else {
+ set ::tcl_precision 0
+}
+
+#
+# Simple test functions
+#
+proc const_func { x } {
+ return 1.0
+}
+proc ffunc { x } {
+ expr {$x*(1.0-$x*$x)}
+}
+proc minfunc { x } {
+ expr {-$x*(1.0-$x*$x)}
+}
+proc absfunc { x } {
+ expr {abs($x*(1.0-$x*$x))}
+}
+
+proc within_range { result min max } {
+ #puts "Within range? $result $min $max"
+ #puts "[expr {2.0*abs($result-$min)/abs($max+$min)}]"
+ if { $result >= $min && $result <= $max } {
+ set ok 1
+ } else {
+ set ok 0
+ }
+ return $ok
+}
+
+#
+# Test the minimum procedure
+#
+# Note about the uneven and even functions:
+# the initial interval is chosen symmetrical, so that the
+# three function values are equal.
+#
+test optimize-1.1 "Minimum of constant function" {
+ set result [minimum -1.0 1.0 ::optimizetest::const_func]
+ within_range $result -1.0 1.0
+} 1
+
+test optimize-1.2 "Minimum of odd function, case 1" {
+ set result [minimum -1.0 1.0 ::optimizetest::ffunc]
+ set xmin [expr {-sqrt(1.0/3.0)-0.0001}]
+ set xmax [expr {-sqrt(1.0/3.0)+0.0001}]
+ within_range $result $xmin $xmax
+} 1
+
+test optimize-1.3 "Minimum of odd function, asymmetric interval" {
+ set result [minimum -0.8 1.2 ::optimizetest::ffunc]
+ set xmin [expr {-sqrt(1.0/3.0)-0.0001}]
+ set xmax [expr {-sqrt(1.0/3.0)+0.0001}]
+ within_range $result $xmin $xmax
+} 1
+
+test optimize-1.4 "Minimum of odd function, case 2" {
+ set result [minimum -1.0 1.0 ::optimizetest::minfunc]
+ set xmin [expr {sqrt(1.0/3.0)-0.0001}]
+ set xmax [expr {sqrt(1.0/3.0)+0.0001}]
+ within_range $result $xmin $xmax
+} 1
+
+test optimize-1.5 "Minimum of even function" {
+ set result [minimum -1.0 1.0 ::optimizetest::absfunc]
+ set xmin -0.0001
+ set xmax 0.0001
+ within_range $result $xmin $xmax
+} 1
+
+#
+# Test the maximum procedure
+#
+# Note about the uneven and even functions:
+# the initial interval is chosen symmetrical, so that the
+# three function values are equal.
+#
+test optimize-2.1 "Maximum of constant function" {
+ set result [maximum -1.0 1.0 ::optimizetest::const_func]
+ within_range $result -1.0 1.0
+} 1
+
+test optimize-2.2 "Maximum of odd function, case 1" {
+ set result [maximum -1.0 1.0 ::optimizetest::ffunc]
+ set xmin [expr {sqrt(1.0/3.0)-0.0001}]
+ set xmax [expr {sqrt(1.0/3.0)+0.0001}]
+ within_range $result $xmin $xmax
+} 1
+
+test optimize-2.3 "Maximum of odd function, case 2" {
+ set result [maximum -1.0 1.0 ::optimizetest::minfunc]
+ set xmin [expr {-sqrt(1.0/3.0)-0.0001}]
+ set xmax [expr {-sqrt(1.0/3.0)+0.0001}]
+ within_range $result $xmin $xmax
+} 1
+
+#
+# Either of the two maxima will do
+#
+test optimize-2.4 "Maximum of even function" {
+ set result [maximum -1.0 1.0 ::optimizetest::absfunc]
+ set xmin [expr {-sqrt(1.0/3.0)-0.0001}]
+ set xmax [expr {-sqrt(1.0/3.0)+0.0001}]
+ set ok [within_range $result $xmin $xmax]
+ set xmin [expr {sqrt(1.0/3.0)-0.0001}]
+ set xmax [expr {sqrt(1.0/3.0)+0.0001}]
+ incr ok [within_range $result $xmin $xmax]
+} 1
+
+
+# Custom match procedure for approximate results
+
+proc withinEpsilon { shouldBe is } {
+ expr { [string is double $is]
+ && abs( $is - $shouldBe ) < 1.e-07 * abs($shouldBe) }
+}
+
+::tcltest::customMatch withinEpsilon [namespace code withinEpsilon]
+
+test linmin-1.1 {find minimum of a parabola - constrained} \
+ -setup {
+ proc f x { expr { ($x + 3.) * ($x - 1.) } }
+ } \
+ -body {
+ foreach {x y} [min_bound_1d f 10. -10.] break
+ set x
+ } \
+ -cleanup {
+ rename f {}
+ } \
+ -result -1. \
+ -match withinEpsilon
+
+test linmin-1.2 {find minimum of cosine} \
+ -setup {
+ proc f x { expr { cos($x) } }
+ } \
+ -body {
+ foreach { x y } [min_bound_1d f 0. 6.28318] break
+ set x
+ } \
+ -cleanup {
+ rename f {}
+ } \
+ -result 3.1415926535897932 \
+ -match withinEpsilon
+
+test linmin-1.3 {find minimum of a bell-shaped function} \
+ -setup {
+ proc f x {
+ set t [expr { $x - 3. }]
+ return [expr { -exp ( -$t * $t / 2 ) }]
+ }
+ } \
+ -body {
+ foreach { x y } [min_bound_1d f 0 30.] break
+ set x
+ } \
+ -cleanup {
+ rename f {}
+ } \
+ -result 3. \
+ -match withinEpsilon
+
+test linmin-1.4 {function where parabolic extrapolation never works} \
+ -setup {
+ proc f x { expr { -1. / ( 0.01 + abs( $x - 5.) ) } }
+ } \
+ -body {
+ foreach {x y} [min_bound_1d f 0 20.] break
+ set x
+ } \
+ -cleanup {
+ rename f {}
+ } \
+ -result 5. \
+ -match withinEpsilon
+
+test linmin-2.1 {wrong \# args} \
+ -body {
+ min_bound_1d f
+ } \
+ -returnCodes 1 \
+ -result [tcltest::wrongNumArgs min_bound_1d {f x1 x2 args} 1]
+
+test linmin-2.2 {wrong \# args} \
+ -body {
+ min_bound_1d f 0 1 -bad
+ } \
+ -returnCodes 1 \
+ -result "wrong # args, should be \"min_bound_1d f x1 x2 ?-option value?...\""
+
+test linmin-2.3 {bad arg} \
+ -body {
+ min_bound_1d f 0 1 -bad option
+ } \
+ -returnCodes 1 \
+ -result "unknown option \"-bad\", should be -abserror,\
+ -fguess, -guess, -initial,\
+ -maxiter, -relerror, or -trace"
+
+test linmin-2.4 {iteration limit} \
+ -setup {
+ proc f x { expr { -1. / ( 0.01 + abs( $x - 5.) ) } }
+ } \
+ -body {
+ min_bound_1d f 20. 0 -maxiter 10
+ } \
+ -cleanup {
+ rename f {}
+ } \
+ -returnCodes 1 \
+ -result "min_bound_1d failed to converge after \\d* steps" \
+ -match regexp
+
+test linmin-3.1 {minimise cos(x), unbounded} \
+ -setup {
+ proc f x { expr { cos($x) } }
+ } -body {
+ foreach { x y } [min_unbound_1d f 3. 3.01] break
+ set x
+ } \
+ -cleanup {
+ rename f {}
+ } \
+ -result 3.1415926535897932 \
+ -match withinEpsilon
+
+test linmin-3.2 {minimise cos(x), unbounded, too eager} \
+ -setup {
+ proc f x { expr { cos($x) } }
+ } -body {
+ foreach { x y } [min_unbound_1d f 0.1 0.15] break
+ set x
+ } \
+ -cleanup {
+ rename f {}
+ } \
+ -result [expr { 3. * 3.1415926535897932 }] \
+ -match withinEpsilon
+
+test linmin-3.3 {near underflow in parabolic extrapolation} \
+ -setup {
+ proc f x {
+ expr { ( 1.12712e-22 * $x * $x * $x - 1e-15 ) * $x + 1e-15 }
+ }
+ } \
+ -body {
+ foreach { x y } [min_unbound_1d f 1. 0.] break
+ set x
+ } \
+ -cleanup {
+ rename f {}
+ } \
+ -result 130.41372 \
+ -match withinEpsilon
+
+test linmin-3.4 {near underflow in parabolic extrapolation} \
+ -setup {
+ proc f x {
+ expr { ( ( 1e-30 * $x * $x - 1.12712e-22 )
+ * $x * $x * $x - 1e-15 )
+ * $x + 1e-15 }
+ }
+ } \
+ -body {
+ foreach { x y } [min_unbound_1d f 1. 0. -relerror 1e-08] break
+ set x
+ } \
+ -cleanup {
+ rename f {}
+ } \
+ -result 8668.4248 \
+ -match withinEpsilon
+
+test linmin-3.5 {parabolic interpolation finds a minimum - case 1} \
+ -setup {
+ proc f x {
+ expr { ( ( ( 1e-5 * $x - 2.69672 )
+ * $x + 10.0902 )
+ * $x - 8.39345 )
+ * $x + 1. }
+ }
+ } \
+ -body {
+ foreach { x y } [min_unbound_1d f 1. 0. -relerror 1e-08] break
+ set x
+ } \
+ -cleanup {
+ rename f {}
+ } \
+ -result 0.527450252 \
+ -match withinEpsilon
+
+test linmin-3.6 {parabolic interpolation finds a minimum - case 2} \
+ -setup {
+ proc f x {
+ expr { ( ( 0.125669 * $x * $x - 0.982687 )
+ * $x - 0.142982 )
+ * $x + 1 }
+ }
+ } \
+ -body {
+ foreach { x y } [min_unbound_1d f 1. 0. -relerror 1e-08] break
+ set x
+ } \
+ -cleanup {
+ rename f {}
+ } \
+ -result 2.0127451 \
+ -match withinEpsilon
+
+test linmin-3.7 {parabolic interpolation is useless} \
+ -setup {
+ proc f x {
+ expr { ( ( ( 1e-5 * $x - 6.79171 )
+ * $x + 24.8107 )
+ * $x - 19.019 )
+ * $x + 1. }
+ }
+ } \
+ -body {
+ foreach { x y } [min_unbound_1d f 1 0 -relerror 1e-8] break
+ set x
+ } \
+ -cleanup {
+ rename f {}
+ } \
+ -result 509375.81 \
+ -match withinEpsilon
+
+test linmin-4.1 {wrong \# args} \
+ -body {
+ min_unbound_1d f
+ } \
+ -returnCodes 1 \
+ -result [tcltest::wrongNumArgs min_unbound_1d {f x1 x2 args} 1]
+
+test linmin-4.2 {wrong \# args} \
+ -body {
+ min_unbound_1d f 0 1 -bad
+ } \
+ -returnCodes 1 \
+ -result "wrong # args, should be \"min_unbound_1d f x1 x2 ?-option value?...\""
+
+test linmin-4.3 {bad arg} \
+ -body {
+ min_unbound_1d f 0 1 -bad option
+ } \
+ -returnCodes 1 \
+ -result "unknown option \"-bad\", should be -trace"
+
+#
+# Test the solveLinearProgram procedure
+#
+
+set ::symm_constraints {
+ { 1.0 2.0 1.0 }
+ { 2.0 1.0 1.0 } }
+
+test linprog-1.0 "Symmetric constraints, case 1" \
+ -body {
+ set result [solveLinearProgram {1.0 1.0} $::symm_constraints]
+ set ok 1
+ if { ! [within_range [lindex $result 0] 0.333300 0.333360] ||
+ ! [within_range [lindex $result 1] 0.333300 0.333360] } {
+ set ok 0
+ }
+ set ok
+ } \
+ -result 1
+
+test linprog-1.1 "Symmetric constraints, case 2" \
+ -body {
+ set result [solveLinearProgram {1.0 0.0} $::symm_constraints]
+ set ok 1
+ if { ! [within_range [lindex $result 0] 0.49900 0.50100] ||
+ ! [within_range [lindex $result 1] -0.00100 0.00100] } {
+ set ok 0
+ }
+ set ok
+ } \
+ -result 1
+
+test linprog-1.2 "Symmetric constraints, case 3" \
+ -body {
+ set result [solveLinearProgram {0.0 1.0} $::symm_constraints]
+ set ok 1
+ if { ! [within_range [lindex $result 1] 0.499900 0.500100] ||
+ ! [within_range [lindex $result 0] -0.000100 0.000100] } {
+ set ok 0
+ }
+ set ok
+ } \
+ -result 1
+
+test linprog-1.3 "Symmetric constraints, case 4" \
+ -body {
+ set result [solveLinearProgram {3.0 4.0} $::symm_constraints]
+ set ok 1
+ if { ! [within_range [lindex $result 0] 0.333300 0.333360] ||
+ ! [within_range [lindex $result 1] 0.333300 0.333360] } {
+ set ok 0
+ }
+ set ok
+ } \
+ -result 1
+
+test linprog-2.1 "Unbounded program 1" \
+ -body {
+ set result [solveLinearProgram {3.0 4.0} {{1.0 -2.0 1.0} {-2.0 1.0 1.0}} ]
+ } \
+ -result "unbounded"
+
+test linprog-2.2 "Unbounded program 2" \
+ -body {
+ set result [::math::optimize::solveLinearProgram {2.0 1.0} {{3.0 0.0 6.0} {1.0 0.0 2.0}}]
+ } \
+ -result "unbounded"
+
+test linprog-2.3 "Infeasible program" \
+ -body {
+ set result [::math::optimize::solveLinearProgram {2.0 1.0} {{3.0 1.0 6.0} {1.0 -1.0 2.0} {0.0 1.0 -3.0}}]
+ } \
+ -result "infeasible"
+
+test linprog-2.4 "Degenerate program" \
+ -body {
+ # Solution: {1.0 3.0}
+ set result [::math::optimize::solveLinearProgram {2.0 1.0} {{3.0 1.0 6.0} {1.0 -1.0 2.0} {0.0 1.0 3.0}}]
+ set ok 1
+ if { ! [within_range [lindex $result 0] 0.99999 1.00001] ||
+ ! [within_range [lindex $result 1] 2.99999 3.00001] } {
+ set ok 0
+ }
+ set ok
+
+ } \
+ -result 1
+
+test linprog-3.1 "Simple 3D program" \
+ -body {
+ set result [solveLinearProgram \
+ {1.0 1.0 1.0} \
+ {{1.0 1.0 2.0 1.0}
+ {1.0 2.0 1.0 1.0}
+ {2.0 1.0 1.0 1.0}}]
+ set ok 1
+ if { ! [within_range [lindex $result 0] 0.249900 0.250100] ||
+ ! [within_range [lindex $result 1] 0.249900 0.250100] ||
+ ! [within_range [lindex $result 2] 0.249900 0.250100] } {
+ set ok 0
+ }
+ set ok
+ } \
+ -result 1
+
+test nelderMead-1.1 "Nelder-Mead - wrong \# args" \
+ -body {
+ ::math::optimize::nelderMead f {0.0 0.0} -bogus
+ } \
+ -returnCodes error \
+ -match glob \
+ -result "wrong \# args*"
+test nelderMead-1.2 "Nelder-Mead - bad param" \
+ -body {
+ ::math::optimize::nelderMead f {0.0 0.0} -bogus 1
+ } \
+ -returnCodes error \
+ -match glob \
+ -result {unknown option "-bogus"*}
+test nelderMead-1.3 "Nelder-Mead - bad size of scale" \
+ -body {
+ ::math::optimize::nelderMead f {0.0 0.0} -scale {0 0 0}
+ } \
+ -returnCodes error \
+ -result {-scale vector must be of same size as starting x vector}
+
+# Easy case - minimize in a paraboloid
+
+test nelderMead-2.1 "Nelder-Mead - easy" \
+ -setup {
+ proc f {x y} {
+ expr {($x-3.)*($x-3.) + ($y-2.)*($y-2.) + 1.}
+ }
+ } \
+ -body {
+ array set dd [::math::optimize::nelderMead f {1. 1.}]
+ foreach {x y} $dd(x) break
+ expr { abs($x-3.) < 0.001 && abs($y-2.) < 0.001 }
+ } \
+ -cleanup {
+ rename f {}; unset dd
+ } \
+ -result 1
+
+test nelderMead-2.2 "Nelder-Mead - easy" \
+ -setup {
+ proc f {x y} {
+ expr {($x-3.)*($x-3.) + ($y-2.)*($y-2.) + 1.}
+ }
+ } \
+ -body {
+ array set dd [::math::optimize::nelderMead f {0. 0.}]
+ foreach {x y} $dd(x) break
+ expr { abs($x-3.) < 0.001 && abs($y-2.) < 0.001 }
+ } \
+ -cleanup {
+ rename f {}; unset dd
+ } \
+ -result 1
+
+# Slalom down a sinuous valley - exercises most of the code
+
+test nelderMead-2.3 "Nelder-Mead - sinuous valley" \
+ -setup {
+ set pi 3.1415926535897932
+ proc f {x y} {
+ set xx [expr { $x - 3.1415926535897932 / 2. }]
+ set v1 [expr { 0.3 * exp( -$xx*$xx / 2. ) }]
+ set d [expr { 10. * $y - sin(9. * $x) }]
+ set v2 [expr { exp(-10.*$d*$d)}]
+ set rv [expr { -$v1 - $v2 }]
+ return $rv
+ }
+ } \
+ -body {
+ array set dd [::math::optimize::nelderMead f {1. 0.} -scale {0.1 0.01}]
+ foreach {x y} $dd(x) break
+ expr { abs($x-$pi/2) < 0.001 && abs($y-0.1) < 0.001 }
+ } \
+ -cleanup {rename f {}; unset dd} \
+ -result 1
+
+# Exercise the difficult case where the simplex has to contract about the
+# low point because all else has failed.
+
+test nelderMead-2.4 "Nelder-Mead - simplex contracts about the minimum" \
+ -setup {
+ proc g {a b} {
+ set x1 [expr {0.1 - $a + $b}]
+ set x2 [expr {$a + $b - 1.}]
+ set x3 [expr {3.-8.*$a+8.*$a*$a-8.*$b+8.*$b*$b}]
+ set x4 [expr {$a/10. + $b/10. + $x1*$x1/3. + $x2*$x2
+ - $x2 * exp(1-$x3*$x3)}]
+ return $x4
+ }
+ } \
+ -body {
+ array set dd [::math::optimize::nelderMead g {0. 0.} \
+ -scale {1. 1.} -ftol 1e-10]
+ foreach {x y} $dd(x) break
+ expr { abs($x-0.774561) < 0.00005 && abs($y-0.755644) < 0.00005 }
+ } \
+ -cleanup {
+ rename g {}; unset dd
+ } \
+ -result 1
+
+# Make sure the method deals gracefully with a "valley"
+# (Ticket UUID: 3193459)
+
+test nelderMead-2.5 "Nelder-Mead - indeterminate minimum (valley)" \
+ -setup {
+ proc h {a b} {
+ return [expr {abs($a-$b)}]
+ }
+ } \
+ -body {
+ array set dd [::math::optimize::nelderMead h {1. 1.}]
+ foreach {x y} $dd(x) break
+ expr { abs($x-1.) < 0.00005 && abs($y-1.) < 0.00005 }
+ } \
+ -cleanup {
+ rename h {}; unset dd
+ } \
+ -result 1
+
+testsuiteCleanup
+
+# Restore precision
+set ::tcl_precision $old_precision
+
+# Local Variables:
+# mode: tcl
+# End:
+
+} ;# End of optimizetest namespace
+
+
diff --git a/tcllib/modules/math/pdf_stat.tcl b/tcllib/modules/math/pdf_stat.tcl
new file mode 100755
index 0000000..4e16e9d
--- /dev/null
+++ b/tcllib/modules/math/pdf_stat.tcl
@@ -0,0 +1,2010 @@
+# pdf_stat.tcl --
+#
+# Collection of procedures for evaluating probability and
+# cumulative density functions
+# Part of "math::statistics"
+#
+# january 2008: added procedures by Eric Kemp Benedict for
+# Gamma, Poisson and t-distributed variables.
+# Replacing some older versions.
+#
+
+# ::math::statistics --
+# Namespace holding the procedures and variables
+#
+namespace eval ::math::statistics {
+
+ namespace export pdf-normal pdf-uniform pdf-lognormal \
+ pdf-exponential \
+ cdf-normal cdf-uniform cdf-lognormal \
+ cdf-exponential \
+ cdf-students-t \
+ random-normal random-uniform random-lognormal \
+ random-exponential \
+ histogram-uniform \
+ pdf-gamma pdf-poisson pdf-chisquare pdf-students-t pdf-beta \
+ pdf-weibull pdf-gumbel pdf-pareto pdf-cauchy \
+ cdf-gamma cdf-poisson cdf-chisquare cdf-beta \
+ cdf-weibull cdf-gumbel cdf-pareto cdf-cauchy \
+ random-gamma random-poisson random-chisquare random-students-t random-beta \
+ random-weibull random-gumbel random-pareto random-cauchy \
+ incompleteGamma incompleteBeta \
+ estimate-pareto empirical-distribution
+
+ variable cdf_normal_prob {}
+ variable cdf_normal_x {}
+ variable cdf_toms322_cached {}
+ variable initialised_cdf 0
+ variable twopi [expr {2.0*acos(-1.0)}]
+ variable pi [expr {acos(-1.0)}]
+}
+
+
+# pdf-normal --
+# Return the probabilities belonging to a normal distribution
+#
+# Arguments:
+# mean Mean of the distribution
+# stdev Standard deviation
+# x Value for which the probability must be determined
+#
+# Result:
+# Probability of value x under the given distribution
+#
+proc ::math::statistics::pdf-normal { mean stdev x } {
+ variable NEGSTDEV
+ variable factorNormalPdf
+
+ if { $stdev <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $NEGSTDEV $NEGSTDEV
+ }
+
+ set xn [expr {($x-$mean)/$stdev}]
+ set prob [expr {exp(-$xn*$xn/2.0)/$stdev/$factorNormalPdf}]
+
+ return $prob
+}
+
+# pdf-lognormal --
+# Return the probabilities belonging to a log-normal distribution
+#
+# Arguments:
+# mean Mean of the distribution
+# stdev Standard deviation
+# x Value for which the probability must be determined
+#
+# Result:
+# Probability of value x under the given distribution
+#
+proc ::math::statistics::pdf-lognormal { mean stdev x } {
+ variable NEGSTDEV
+ variable factorNormalPdf
+
+ if { $stdev <= 0.0 || $mean <= 0.0 } {
+ return -code error -errorcode ARG \
+ -errorinfo "Standard deviation and mean must be positive" \
+ "Standard deviation and mean must be positive"
+ }
+
+ set sigma [expr {sqrt(log(1.0 + $stdev /double($mean*$mean)))}]
+ set mu [expr {log($mean) - 0.5 * $sigma * $sigma}]
+
+ set xn [expr {(log($x)-$mu)/$sigma}]
+ set prob [expr {exp(-$xn*$xn/2.0)/$sigma/$factorNormalPdf}]
+
+ return $prob
+}
+
+
+# pdf-uniform --
+# Return the probabilities belonging to a uniform distribution
+# (parameters as minimum/maximum)
+#
+# Arguments:
+# pmin Minimum of the distribution
+# pmax Maximum of the distribution
+# x Value for which the probability must be determined
+#
+# Result:
+# Probability of value x under the given distribution
+#
+proc ::math::statistics::pdf-uniform { pmin pmax x } {
+
+ if { $pmin >= $pmax } {
+ return -code error -errorcode ARG \
+ -errorinfo "Wrong order or zero range" \
+ "Wrong order or zero range"
+ }
+
+ set prob [expr {1.0/($pmax-$pmin)}]
+
+ if { $x < $pmin || $x > $pmax } { return 0.0 }
+
+ return $prob
+}
+
+
+# pdf-exponential --
+# Return the probabilities belonging to an exponential
+# distribution
+#
+# Arguments:
+# mean Mean of the distribution
+# x Value for which the probability must be determined
+#
+# Result:
+# Probability of value x under the given distribution
+#
+proc ::math::statistics::pdf-exponential { mean x } {
+ variable NEGSTDEV
+ variable OUTOFRANGE
+
+ if { $mean <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $OUTOFRANGE \
+ "$OUTOFRANGE: mean must be positive"
+ }
+
+ if { $x < 0.0 } { return 0.0 }
+ if { $x > 700.0*$mean } { return 0.0 }
+
+ set prob [expr {exp(-$x/double($mean))/$mean}]
+
+ return $prob
+}
+
+
+# cdf-normal --
+# Return the cumulative probability belonging to a normal distribution
+#
+# Arguments:
+# mean Mean of the distribution
+# stdev Standard deviation
+# x Value for which the probability must be determined
+#
+# Result:
+# Cumulative probability of value x under the given distribution
+#
+proc ::math::statistics::cdf-normal { mean stdev x } {
+ variable NEGSTDEV
+
+ if { $stdev <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $NEGSTDEV $NEGSTDEV
+ }
+
+ set xn [expr {($x-double($mean))/$stdev}]
+ set prob1 [Cdf-toms322 1 5000 [expr {$xn*$xn}]]
+ if { $xn > 0.0 } {
+ set prob [expr {0.5+0.5*$prob1}]
+ } else {
+ set prob [expr {0.5-0.5*$prob1}]
+ }
+
+ return $prob
+}
+
+
+# cdf-lognormal --
+# Return the cumulative probability belonging to a log-normal distribution
+#
+# Arguments:
+# mean Mean of the distribution
+# stdev Standard deviation
+# x Value for which the probability must be determined
+#
+# Result:
+# Probability of value x under the given distribution
+#
+proc ::math::statistics::cdf-lognormal { mean stdev x } {
+ variable NEGSTDEV
+
+ if { $stdev <= 0.0 || $mean <= 0.0 } {
+ return -code error -errorcode ARG \
+ -errorinfo "Standard deviation and mean must be positive" \
+ "Standard deviation and mean must be positive"
+ }
+
+ set sigma [expr {sqrt(log(1.0 + $stdev /double($mean*$mean)))}]
+ set mu [expr {log($mean) - 0.5 * $sigma * $sigma}]
+
+ set xn [expr {(log($x)-$mu)/$sigma}]
+ set prob1 [Cdf-toms322 1 5000 [expr {$xn*$xn}]]
+ if { $xn > 0.0 } {
+ set prob [expr {0.5+0.5*$prob1}]
+ } else {
+ set prob [expr {0.5-0.5*$prob1}]
+ }
+
+ return $prob
+}
+
+
+# cdf-students-t --
+# Return the cumulative probability belonging to the
+# Student's t distribution
+#
+# Arguments:
+# degrees Number of degrees of freedom
+# x Value for which the probability must be determined
+#
+# Result:
+# Cumulative probability of value x under the given distribution
+#
+proc ::math::statistics::cdf-students-t { degrees x } {
+
+ if { $degrees <= 0 } {
+ return -code error -errorcode ARG -errorinfo \
+ "Number of degrees of freedom must be positive" \
+ "Number of degrees of freedom must be positive"
+ }
+
+ set prob1 [Cdf-toms322 1 $degrees [expr {$x*$x}]]
+ set prob [expr {0.5+0.5*$prob1}]
+
+ return $prob
+}
+
+
+# cdf-uniform --
+# Return the cumulative probabilities belonging to a uniform
+# distribution (parameters as minimum/maximum)
+#
+# Arguments:
+# pmin Minimum of the distribution
+# pmax Maximum of the distribution
+# x Value for which the probability must be determined
+#
+# Result:
+# Cumulative probability of value x under the given distribution
+#
+proc ::math::statistics::cdf-uniform { pmin pmax x } {
+
+ if { $pmin >= $pmax } {
+ return -code error -errorcode ARG \
+ -errorinfo "Wrong order or zero range" \
+ }
+
+ set prob [expr {($x-$pmin)/double($pmax-$pmin)}]
+
+ if { $x < $pmin } { return 0.0 }
+ if { $x > $pmax } { return 1.0 }
+
+ return $prob
+}
+
+
+# cdf-exponential --
+# Return the cumulative probabilities belonging to an exponential
+# distribution
+#
+# Arguments:
+# mean Mean of the distribution
+# x Value for which the probability must be determined
+#
+# Result:
+# Cumulative probability of value x under the given distribution
+#
+proc ::math::statistics::cdf-exponential { mean x } {
+ variable NEGSTDEV
+ variable OUTOFRANGE
+
+ if { $mean <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $OUTOFRANGE \
+ "$OUTOFRANGE: mean must be positive"
+ }
+
+ if { $x < 0.0 } { return 0.0 }
+ if { $x > 30.0*$mean } { return 1.0 }
+
+ set prob [expr {1.0-exp(-$x/double($mean))}]
+
+ return $prob
+}
+
+
+# Inverse-cdf-uniform --
+# Return the argument belonging to the cumulative probability
+# for a uniform distribution (parameters as minimum/maximum)
+#
+# Arguments:
+# pmin Minimum of the distribution
+# pmax Maximum of the distribution
+# prob Cumulative probability for which the "x" value must be
+# determined
+#
+# Result:
+# X value that gives the cumulative probability under the
+# given distribution
+#
+proc ::math::statistics::Inverse-cdf-uniform { pmin pmax prob } {
+
+ if {0} {
+ if { $pmin >= $pmax } {
+ return -code error -errorcode ARG \
+ -errorinfo "Wrong order or zero range" \
+ "Wrong order or zero range"
+ }
+ }
+
+ set x [expr {$pmin+$prob*($pmax-$pmin)}]
+
+ if { $x < $pmin } { return $pmin }
+ if { $x > $pmax } { return $pmax }
+
+ return $x
+}
+
+
+# Inverse-cdf-exponential --
+# Return the argument belonging to the cumulative probability
+# for an exponential distribution
+#
+# Arguments:
+# mean Mean of the distribution
+# prob Cumulative probability for which the "x" value must be
+# determined
+#
+# Result:
+# X value that gives the cumulative probability under the
+# given distribution
+#
+proc ::math::statistics::Inverse-cdf-exponential { mean prob } {
+
+ if {0} {
+ if { $mean <= 0.0 } {
+ return -code error -errorcode ARG \
+ -errorinfo "Mean must be positive" \
+ "Mean must be positive"
+ }
+ }
+
+ set x [expr {-$mean*log(1.0-$prob)}]
+
+ return $x
+}
+
+
+# Inverse-cdf-normal --
+# Return the argument belonging to the cumulative probability
+# for a normal distribution
+#
+# Arguments:
+# mean Mean of the distribution
+# stdev Standard deviation of the distribution
+# prob Cumulative probability for which the "x" value must be
+# determined
+#
+# Result:
+# X value that gives the cumulative probability under the
+# given distribution
+#
+proc ::math::statistics::Inverse-cdf-normal { mean stdev prob } {
+ variable cdf_normal_prob
+ variable cdf_normal_x
+
+ variable initialised_cdf
+ if { $initialised_cdf == 0 } {
+ Initialise-cdf-normal
+ }
+
+ # Look for the proper probability level first,
+ # then interpolate
+ #
+ # Note: the numerical data are connected to the length of
+ # the lists - see Initialise-cdf-normal
+ #
+ set size 32
+ set idx 64
+ for { set i 0 } { $i <= 7 } { incr i } {
+ set upper [lindex $cdf_normal_prob $idx]
+ if { $prob > $upper } {
+ set idx [expr {$idx+$size}]
+ } else {
+ set idx [expr {$idx-$size}]
+ }
+ set size [expr {$size/2}]
+ }
+ #
+ # We have found a value that is close to the one we need,
+ # now find the enclosing interval
+ #
+ if { $upper < $prob } {
+ incr idx
+ }
+ set p1 [lindex $cdf_normal_prob [expr {$idx-1}]]
+ set p2 [lindex $cdf_normal_prob $idx]
+ set x1 [lindex $cdf_normal_x [expr {$idx-1}]]
+ set x2 [lindex $cdf_normal_x $idx ]
+
+ set x [expr {$x1+($x2-$x1)*($prob-$p1)/double($p2-$p1)}]
+
+ return [expr {$mean+$stdev*$x}]
+}
+
+
+# Initialise-cdf-normal --
+# Initialise the private data for the normal cdf
+#
+# Arguments:
+# None
+# Result:
+# None
+# Side effect:
+# Variable cdf_normal_prob and cdf_normal_x are filled
+# so that we can use these as a look-up table
+#
+proc ::math::statistics::Initialise-cdf-normal { } {
+ variable cdf_normal_prob
+ variable cdf_normal_x
+
+ variable initialised_cdf
+ set initialised_cdf 1
+
+ set dx [expr {10.0/128.0}]
+
+ set cdf_normal_prob 0.5
+ set cdf_normal_x 0.0
+ for { set i 1 } { $i <= 64 } { incr i } {
+ set x [expr {$i*$dx}]
+ if { $x != 0.0 } {
+ set prob [Cdf-toms322 1 5000 [expr {$x*$x}]]
+ } else {
+ set prob 0.0
+ }
+
+ set cdf_normal_x [concat [expr {-$x}] $cdf_normal_x $x]
+ set cdf_normal_prob \
+ [concat [expr {0.5-0.5*$prob}] $cdf_normal_prob \
+ [expr {0.5+0.5*$prob}]]
+ }
+}
+
+
+# random-uniform --
+# Return a list of random numbers satisfying a uniform
+# distribution (parameters as minimum/maximum)
+#
+# Arguments:
+# pmin Minimum of the distribution
+# pmax Maximum of the distribution
+# number Number of values to generate
+#
+# Result:
+# List of random numbers
+#
+proc ::math::statistics::random-uniform { pmin pmax number } {
+
+ if { $pmin >= $pmax } {
+ return -code error -errorcode ARG \
+ -errorinfo "Wrong order or zero range" \
+ "Wrong order or zero range"
+ }
+
+ set result {}
+ for { set i 0 } {$i < $number } { incr i } {
+ lappend result [Inverse-cdf-uniform $pmin $pmax [expr {rand()}]]
+ }
+
+ return $result
+}
+
+
+# random-exponential --
+# Return a list of random numbers satisfying an exponential
+# distribution
+#
+# Arguments:
+# mean Mean of the distribution
+# number Number of values to generate
+#
+# Result:
+# List of random numbers
+#
+proc ::math::statistics::random-exponential { mean number } {
+
+ if { $mean <= 0.0 } {
+ return -code error -errorcode ARG \
+ -errorinfo "Mean must be positive" \
+ "Mean must be positive"
+ }
+
+ set result {}
+ for { set i 0 } {$i < $number } { incr i } {
+ lappend result [Inverse-cdf-exponential $mean [expr {rand()}]]
+ }
+
+ return $result
+}
+
+
+# random-normal --
+# Return a list of random numbers satisfying a normal
+# distribution
+#
+# Arguments:
+# mean Mean of the distribution
+# stdev Standard deviation of the distribution
+# number Number of values to generate
+#
+# Result:
+# List of random numbers
+#
+# Note:
+# This version uses the Box-Muller transformation,
+# a quick and robust method for generating normally-
+# distributed numbers.
+#
+proc ::math::statistics::random-normal { mean stdev number } {
+ variable twopi
+
+ if { $stdev <= 0.0 } {
+ return -code error -errorcode ARG \
+ -errorinfo "Standard deviation must be positive" \
+ "Standard deviation must be positive"
+ }
+
+# set result {}
+# for { set i 0 } {$i < $number } { incr i } {
+# lappend result [Inverse-cdf-normal $mean $stdev [expr {rand()}]]
+# }
+
+ set result {}
+
+ for { set i 0 } {$i < $number } { incr i 2 } {
+ set angle [expr {$twopi * rand()}]
+ set rad [expr {sqrt(-2.0*log(rand()))}]
+ set xrand [expr {$rad * cos($angle)}]
+ set yrand [expr {$rad * sin($angle)}]
+ lappend result [expr {$mean + $stdev * $xrand}]
+ if { $i < $number-1 } {
+ lappend result [expr {$mean + $stdev * $yrand}]
+ }
+ }
+
+ return $result
+}
+
+
+
+# random-lognormal --
+# Return a list of random numbers satisfying a log-normal
+# distribution
+#
+# Arguments:
+# mean Mean of the distribution
+# stdev Standard deviation of the distribution
+# number Number of values to generate
+#
+# Result:
+# List of random numbers
+#
+# Note:
+# This version uses the Box-Muller transformation,
+# a quick and robust method for generating normally-
+# distributed numbers.
+#
+proc ::math::statistics::random-lognormal { mean stdev number } {
+ variable twopi
+
+ if { $stdev <= 0.0 || $mean <= 0.0 } {
+ return -code error -errorcode ARG \
+ -errorinfo "Standard deviation and mean must be positive" \
+ "Standard deviation and mean must be positive"
+ }
+
+ set sigma [expr {sqrt(log(1.0 + $stdev /double($mean*$mean)))}]
+ set mu [expr {log($mean) - 0.5 * $sigma * $sigma}]
+
+# set result {}
+# for { set i 0 } {$i < $number } { incr i } {
+# lappend result [Inverse-cdf-normal $mean $stdev [expr {rand()}]]
+# }
+
+ #puts "Random-lognormal: $mu -- $sigma"
+
+ set result {}
+
+ for { set i 0 } {$i < $number } { incr i 2 } {
+ set angle [expr {$twopi * rand()}]
+ set rad [expr {sqrt(-2.0*log(rand()))}]
+ set xrand [expr {$rad * cos($angle)}]
+ set yrand [expr {$rad * sin($angle)}]
+ lappend result [expr {exp($mu + $sigma * $xrand)}]
+ if { $i < $number-1 } {
+ lappend result [expr {exp($mu + $sigma * $yrand)}]
+ }
+ }
+
+ return $result
+}
+
+# Cdf-toms322 --
+# Calculate the cumulative density function for several distributions
+# according to TOMS322
+#
+# Arguments:
+# m First number of degrees of freedom
+# n Second number of degrees of freedom
+# x Value for which the cdf must be calculated
+#
+# Result:
+# Cumulatve density at x - details depend on distribution
+#
+# Notes:
+# F-ratios:
+# m - degrees of freedom for numerator
+# n - degrees of freedom for denominator
+# x - F-ratio
+# Student's t (two-tailed):
+# m - 1
+# n - degrees of freedom
+# x - square of t
+# Normal deviate (two-tailed):
+# m - 1
+# n - 5000
+# x - square of deviate
+# Chi-square:
+# m - degrees of freedom
+# n - 5000
+# x - chi-square/m
+# The original code can be found at <http://www.netlib.org>
+#
+proc ::math::statistics::Cdf-toms322 { m n x } {
+ if { $x == 0.0 } {
+ return 0.0
+ }
+ set m [expr {$m < 300? int($m) : 300}]
+ set n [expr {$n < 5000? int($n) : 5000}]
+ if { $m < 1 || $n < 1 } {
+ return -code error -errorcode ARG \
+ -errorinfo "Arguments m anf n must be greater/equal 1"
+ }
+
+ set a [expr {2*($m/2)-$m+2}]
+ set b [expr {2*($n/2)-$n+2}]
+ set w [expr {$x*double($m)/double($n)}]
+ set z [expr {1.0/(1.0+$w)}]
+
+ if { $a == 1 } {
+ if { $b == 1 } {
+ set p [expr {sqrt($w)}]
+ set y 0.3183098862
+ set d [expr {$y*$z/$p}]
+ set p [expr {2.0*$y*atan($p)}]
+ } else {
+ set p [expr {sqrt($w*$z)}]
+ set d [expr {$p*$z/(2.0*$w)}]
+ }
+ } else {
+ if { $b == 1 } {
+ set p [expr {sqrt($z)}]
+ set d [expr {$z*$p/2.0}]
+ set p [expr {1.0-$p}]
+ } else {
+ set d [expr {$z*$z}]
+ set p [expr {$z*$w}]
+ }
+ }
+
+ set y [expr {2.0*$w/$z}]
+
+ if { $a == 1 } {
+ for { set j [expr {$b+2}] } { $j <= $n } { incr j 2 } {
+ set d [expr {(1.0+double($a)/double($j-2)) * $d*$z}]
+ set p [expr {$p+$d*$y/double($j-1)}]
+ }
+ } else {
+ set power [expr {($n-1)/2}]
+ set zk [expr {pow($z,$power)}]
+ set d [expr {($d*$zk*$n)/$b}]
+ set p [expr {$p*$zk + $w*$z * ($zk-1.0)/($z-1.0)}]
+ }
+
+ set y [expr {$w*$z}]
+ set z [expr {2.0/$z}]
+ set b [expr {$n-2}]
+
+ for { set i [expr {$a+2}] } { $i <= $m } { incr i 2 } {
+ set j [expr {$i+$b}]
+ set d [expr {$y*$d*double($j)/double($i-2)}]
+ set p [expr {$p-$z*$d/double($j)}]
+ }
+ set prob $p
+ if { $prob < 0.0 } { set prob 0.0 }
+ if { $prob > 1.0 } { set prob 1.0 }
+
+ return $prob
+}
+
+
+# Inverse-cdf-toms322 --
+# Return the argument belonging to the cumulative probability
+# for an F, chi-square or t distribution
+#
+# Arguments:
+# m First number of degrees of freedom
+# n Second number of degrees of freedom
+# prob Cumulative probability for which the "x" value must be
+# determined
+#
+# Result:
+# X value that gives the cumulative probability under the
+# given distribution
+#
+# Note:
+# See the procedure Cdf-toms322 for more details
+#
+proc ::math::statistics::Inverse-cdf-toms322 { m n prob } {
+ variable cdf_toms322_cached
+ variable OUTOFRANGE
+
+ if { $prob <= 0 || $prob >= 1 } {
+ return -code error -errorcode $OUTOFRANGE $OUTOFRANGE
+ }
+
+ # Is the combination in cache? Then we can simply rely
+ # on that
+ #
+ foreach {m1 n1 prob1 x1} $cdf_toms322_cached {
+ if { $m1 == $m && $n1 == $n && $prob1 == $prob } {
+ return $x1
+ }
+ }
+
+ #
+ # Otherwise first find a value of x for which Cdf(x) exceeds prob
+ #
+ set x1 1.0
+ set dx1 1.0
+ while { [Cdf-toms322 $m $n $x1] < $prob } {
+ set x1 [expr {$x1+$dx1}]
+ set dx1 [expr {2.0*$dx1}]
+ }
+
+ #
+ # Now, look closer
+ #
+ while { $dx1 > 0.0001 } {
+ set p1 [Cdf-toms322 $m $n $x1]
+ if { $p1 > $prob } {
+ set x1 [expr {$x1-$dx1}]
+ } else {
+ set x1 [expr {$x1+$dx1}]
+ }
+ set dx1 [expr {$dx1/2.0}]
+ }
+
+ #
+ # Cache the result
+ #
+ set last end
+ if { [llength $cdf_toms322_cached] > 27 } {
+ set last 26
+ }
+ set cdf_toms322_cached \
+ [concat [list $m $n $prob $x1] [lrange $cdf_toms322_cached 0 $last]]
+
+ return $x1
+}
+
+
+# HistogramMake --
+# Distribute the "observations" according to the cdf
+#
+# Arguments:
+# cdf-values Values for the cdf (relative number of observations)
+# number Total number of "observations" in the histogram
+#
+# Result:
+# List of numbers, distributed over the buckets
+#
+proc ::math::statistics::HistogramMake { cdf-values number } {
+
+ set assigned 0
+ set result {}
+ set residue 0.0
+ foreach cdfv $cdf-values {
+ set sum [expr {$number*($cdfv + $residue)}]
+ set bucket [expr {int($sum)}]
+ set residue [expr {$sum-$bucket}]
+ set assigned [expr {$assigned-$bucket}]
+ lappend result $bucket
+ }
+ set remaining [expr {$number-$assigned}]
+ if { $remaining > 0 } {
+ lappend result $remaining
+ } else {
+ lappend result 0
+ }
+
+ return $result
+}
+
+
+# histogram-uniform --
+# Return the expected histogram for a uniform distribution
+#
+# Arguments:
+# min Minimum the distribution
+# max Maximum the distribution
+# limits upper limits for the histogram buckets
+# number Total number of "observations" in the histogram
+#
+# Result:
+# List of expected number of observations
+#
+proc ::math::statistics::histogram-uniform { min max limits number } {
+ if { $min >= $max } {
+ return -code error -errorcode ARG \
+ -errorinfo "Wrong order or zero range" \
+ "Wrong order or zero range"
+ }
+
+ set cdf_result {}
+ foreach limit $limits {
+ lappend cdf_result [cdf-uniform $min $max $limit]
+ }
+
+ return [HistogramMake $cdf_result $number]
+}
+
+
+# incompleteGamma --
+# Evaluate the incomplete Gamma function Gamma(p,x)
+#
+# Arguments:
+# x X-value
+# p Parameter
+#
+# Result:
+# Value of Gamma(p,x)
+#
+# Note:
+# Implementation by Eric K. Benedict (2007)
+# Adapted from Fortran code in the Royal Statistical Society's StatLib
+# library (http://lib.stat.cmu.edu/apstat/), algorithm AS 32 (with
+# some modifications from AS 239)
+#
+# Calculate normalized incomplete gamma function
+#
+# 1 / x p-1
+# P(p,x) = -------- | dt exp(-t) * t
+# Gamma(p) / 0
+#
+# Tested some values against R's pgamma function
+#
+proc ::math::statistics::incompleteGamma {x p {tol 1.0e-9}} {
+ set overflow 1.0e37
+
+ if {$x < 0} {
+ return -code error -errorcode ARG -errorinfo "x must be positive"
+ }
+ if {$p <= 0} {
+ return -code error -errorcode ARG -errorinfo "p must be greater than or equal to zero"
+ }
+
+ # If x is zero, incGamma is zero
+ if {$x == 0.0} {
+ return 0.0
+ }
+
+ # Use normal approx is p > 1000
+ if {$p > 1000} {
+ set pn1 [expr {3.0 * sqrt($p) * (pow(1.0 * $x/$p, 1.0/3.0) + 1.0/(9.0 * $p) - 1.0)}]
+ # pnorm is not robust enough for this calculation (overflows); cdf-normal could also be used
+ return [::math::statistics::pnorm_quicker $pn1]
+ }
+
+ # If x is extremely large compared to a (and now know p < 1000), then return 1.0
+ if {$x > 1.e8} {
+ return 1.0
+ }
+
+ set factor [expr {exp($p * log($x) -$x - [::math::ln_Gamma $p])}]
+
+ # Use series expansion (first option) or continued fraction
+ if {$x <= 1.0 || $x < $p} {
+ set gin 1.0
+ set term 1.0
+ set rn $p
+ while {1} {
+ set rn [expr {$rn + 1.0}]
+ set term [expr {1.0 * $term * $x/$rn}]
+ set gin [expr {$gin + $term}]
+ if {$term < $tol} {
+ set gin [expr {1.0 * $gin * $factor/$p}]
+ break
+ }
+ }
+ } else {
+ set a [expr {1.0 - $p}]
+ set b [expr {$a + $x + 1.0}]
+ set term 0.0
+ set pn1 1.0
+ set pn2 $x
+ set pn3 [expr {$x + 1.0}]
+ set pn4 [expr {$x * $b}]
+ set gin [expr {1.0 * $pn3/$pn4}]
+ while {1} {
+ set a [expr {$a + 1.0}]
+ set b [expr {$b + 2.0}]
+ set term [expr {$term + 1.0}]
+ set an [expr {$a * $term}]
+ set pn5 [expr {$b * $pn3 - $an * $pn1}]
+ set pn6 [expr {$b * $pn4 - $an * $pn2}]
+ if {$pn6 != 0.0} {
+ set rn [expr {1.0 * $pn5/$pn6}]
+ set dif [expr {abs($gin - $rn)}]
+ if {$dif <= $tol && $dif <= $tol * $rn} {
+ break
+ }
+ set gin $rn
+ }
+ set pn1 $pn3
+ set pn2 $pn4
+ set pn3 $pn5
+ set pn4 $pn6
+ # Too big? Rescale
+ if {abs($pn5) >= $overflow} {
+ set pn1 [expr {$pn1 / $overflow}]
+ set pn2 [expr {$pn2 / $overflow}]
+ set pn3 [expr {$pn3 / $overflow}]
+ set pn4 [expr {$pn4 / $overflow}]
+ }
+ }
+ set gin [expr {1.0 - $factor * $gin}]
+ }
+
+ return $gin
+
+}
+
+
+# pdf-gamma --
+# Return the probabilities belonging to a gamma distribution
+#
+# Arguments:
+# alpha Shape parameter
+# beta Rate parameter
+# x Value of variate
+#
+# Result:
+# Probability density of the given value of x to occur
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2007
+#
+# This uses the following parameterization for the gamma:
+# GammaDist(x) = beta * (beta * x)^(alpha-1) e^(-beta * x) / GammaFunc(alpha)
+# Here, alpha is the shape parameter, and beta is the rate parameter
+# Alternatively, a "scale parameter" theta = 1/beta is sometimes used
+#
+proc ::math::statistics::pdf-gamma { alpha beta x } {
+
+ if {$beta < 0} {
+ return -code error -errorcode ARG -errorinfo "Rate parameter 'beta' must be positive"
+ }
+ if {$x < 0.0} {
+ return 0.0
+ }
+
+ set prod [expr {1.0 * $x * $beta}]
+ set Galpha [expr {exp([::math::ln_Gamma $alpha])}]
+
+ expr {(1.0 * $beta/$Galpha) * pow($prod, ($alpha - 1.0)) * exp(-$prod)}
+}
+
+
+# pdf-poisson --
+# Return the probabilities belonging to a Poisson
+# distribution
+#
+# Arguments:
+# mu Mean of the distribution
+# k Number of occurrences
+#
+# Result:
+# Probability of k occurrences under the given distribution
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2007
+#
+proc ::math::statistics::pdf-poisson { mu k } {
+ set intk [expr {int($k)}]
+ expr {exp(-$mu + floor($k) * log($mu) - [::math::ln_Gamma [incr intk]])}
+}
+
+
+# pdf-chisquare --
+# Return the probabilities belonging to a chi square distribution
+#
+# Arguments:
+# df Degree of freedom
+# x Value of variate
+#
+# Result:
+# Probability density of the given value of x to occur
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2007
+#
+proc ::math::statistics::pdf-chisquare { df x } {
+
+ if {$df <= 0} {
+ return -code error -errorcode ARG -errorinfo "Degrees of freedom must be positive"
+ }
+
+ return [pdf-gamma [expr {0.5*$df}] 0.5 $x]
+}
+
+
+# pdf-students-t --
+# Return the probabilities belonging to a Student's t distribution
+#
+# Arguments:
+# degrees Degree of freedom
+# x Value of variate
+#
+# Result:
+# Probability density of the given value of x to occur
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2007
+#
+proc ::math::statistics::pdf-students-t { degrees x } {
+ variable pi
+
+ if {$degrees <= 0} {
+ return -code error -errorcode ARG -errorinfo "Degrees of freedom must be positive"
+ }
+
+ set nplus1over2 [expr {0.5 * ($degrees + 1)}]
+ set f1 [expr {exp([::math::ln_Gamma $nplus1over2] - \
+ [::math::ln_Gamma [expr {$nplus1over2 - 0.5}]])}]
+ set f2 [expr {1.0/sqrt($degrees * $pi)}]
+
+ expr {$f1 * $f2 * pow(1.0 + $x * $x/double($degrees), -$nplus1over2)}
+
+}
+
+
+# pdf-beta --
+# Return the probabilities belonging to a Beta distribution
+#
+# Arguments:
+# a First parameter of the Beta distribution
+# b Second parameter of the Beta distribution
+# x Value of variate
+#
+# Result:
+# Probability density of the given value of x to occur
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2008
+#
+proc ::math::statistics::pdf-beta { a b x } {
+ if {$x < 0.0 || $x > 1.0} {
+ return -code error "Value out of range in Beta density: x = $x, not in \[0, 1\]"
+ }
+ if {$a <= 0.0} {
+ return -code error "Value out of range in Beta density: a = $a, must be > 0"
+ }
+ if {$b <= 0.0} {
+ return -code error "Value out of range in Beta density: b = $b, must be > 0"
+ }
+ #
+ # Corner cases ... need to check these!
+ #
+ if {$x == 0.0} {
+ return [expr {$a > 1.0? 0.0 : Inf}]
+ }
+ if {$x == 1.0} {
+ return [expr {$b > 1.0? 0.0 : Inf}]
+ }
+ set aplusb [expr {$a + $b}]
+ set term1 [expr {[::math::ln_Gamma $aplusb]- [::math::ln_Gamma $a] - [::math::ln_Gamma $b]}]
+ set term2 [expr {($a - 1.0) * log($x) + ($b - 1.0) * log(1.0 - $x)}]
+
+ set term [expr {$term1 + $term2}]
+ if { $term > -200.0 } {
+ return [expr {exp($term)}]
+ } else {
+ return 0.0
+ }
+}
+
+
+# incompleteBeta --
+# Evaluate the incomplete Beta integral
+#
+# Arguments:
+# a First parameter of the Beta integral
+# b Second parameter of the Beta integral
+# x Integration limit
+# tol (Optional) error tolerance (defaults to 1.0e-9)
+#
+# Result:
+# Probability density of the given value of x to occur
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2008
+#
+proc ::math::statistics::incompleteBeta {a b x {tol 1.0e-9}} {
+ if {$x < 0.0 || $x > 1.0} {
+ return -code error "Value out of range in incomplete Beta function: x = $x, not in \[0, 1\]"
+ }
+ if {$a <= 0.0} {
+ return -code error "Value out of range in incomplete Beta function: a = $a, must be > 0"
+ }
+ if {$b <= 0.0} {
+ return -code error "Value out of range in incomplete Beta function: b = $b, must be > 0"
+ }
+
+ if {$x < $tol} {
+ return 0.0
+ }
+ if {$x > 1.0 - $tol} {
+ return 1.0
+ }
+
+ # Rearrange if necessary to get continued fraction to behave
+ if {$x < 0.5} {
+ return [beta_cont_frac $a $b $x $tol]
+ } else {
+ set z [beta_cont_frac $b $a [expr {1.0 - $x}] $tol]
+ return [expr {1.0 - $z}]
+ }
+}
+
+
+# beta_cont_frac --
+# Evaluate the incomplete Beta integral via a continued fraction
+#
+# Arguments:
+# a First parameter of the Beta integral
+# b Second parameter of the Beta integral
+# x Integration limit
+# tol (Optional) error tolerance (defaults to 1.0e-9)
+#
+# Result:
+# Probability density of the given value of x to occur
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2008
+#
+# Continued fraction for Ix(a,b)
+# Abramowitz & Stegun 26.5.9
+#
+proc ::math::statistics::beta_cont_frac {a b x {tol 1.0e-9}} {
+ set max_iter 512
+
+ set aplusb [expr {$a + $b}]
+ set amin1 [expr {$a - 1}]
+ set lnGapb [::math::ln_Gamma $aplusb]
+ set term1 [expr {$lnGapb- [::math::ln_Gamma $a] - [::math::ln_Gamma $b]}]
+ set term2 [expr {$a * log($x) + ($b - 1.0) * log(1.0 - $x)}]
+ set pref [expr {exp($term1 + $term2)/$a}]
+
+ set z [expr {$x / (1.0 - $x)}]
+
+ set v 1.0
+ set h_1 1.0
+ set h_2 0.0
+ set k_1 1.0
+ set k_2 1.0
+
+ for {set m 1} {$m < $max_iter} {incr m} {
+ set f1 [expr {$amin1 + 2 * $m}]
+ set e2m [expr {-$z * double(($amin1 + $m) * ($b - $m))/ \
+ double(($f1 - 1) * $f1)}]
+ set e2mp1 [expr {$z * double($m * ($aplusb - 1 + $m)) / \
+ double($f1 * ($f1 + 1))}]
+ set h_2m [expr {$h_1 + $e2m * $h_2}]
+ set k_2m [expr {$k_1 + $e2m * $k_2}]
+
+ set h_2 $h_2m
+ set k_2 $k_2m
+
+ set h_1 [expr {$h_2m + $e2mp1 * $h_1}]
+ set k_1 [expr {$k_2m + $e2mp1 * $k_1}]
+
+ set vprime [expr {$h_1/$k_1}]
+
+ if {abs($v - $vprime) < $tol} {
+ break
+ }
+
+ set v $vprime
+
+ }
+
+ if {$m == $max_iter} {
+ return -code error "beta_cont_frac: Exceeded maximum number of iterations"
+ }
+
+ set retval [expr {$pref * $v}]
+
+ # Because of imprecision in underlying Tcl calculations, may fall out of bounds
+ if {$retval < 0.0} {
+ set retval 0.0
+ } elseif {$retval > 1.0} {
+ set retval 1.0
+ }
+
+ return $retval
+}
+
+
+# pdf-weibull --
+# Return the probabilities belonging to a Weibull distribution
+#
+# Arguments:
+# scale Scale parameter of the Weibull distribution
+# shape Shape parameter of the Weibull distribution
+# x Value of variate
+#
+# Result:
+# Probability density of the given value of x to occur
+#
+# Note:
+# "-$x ** $shape" is evaluated as "(-$x)**$shape", hence use a division
+#
+proc ::math::statistics::pdf-weibull { scale shape x } {
+ variable OUTOFRANGE
+
+ if { $x < 0 } {
+ return 0.0
+ }
+ if { $scale <= 0.0 || $shape <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE
+ }
+ set x [expr {$x / double($scale)}]
+ return [expr {$shape/double($scale) * pow($x,($shape-1.0)) / exp(pow($x,$shape))}]
+}
+
+
+# pdf-gumbel --
+# Return the probabilities belonging to a Gumbel distribution
+#
+# Arguments:
+# location Location parameter of the Gumbel distribution
+# scale Scale parameter of the Gumbel distribution
+# x Value of variate
+#
+# Result:
+# Probability density of the given value of x to occur
+#
+proc ::math::statistics::pdf-gumbel { location scale x } {
+ variable OUTOFRANGE
+
+ if { $scale <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE
+ }
+ set x [expr {($x - $location) / double($scale)}]
+ return [expr {exp(-$x - exp(-$x)) / $scale}]
+}
+
+
+# pdf-pareto --
+# Return the probabilities belonging to a Pareto distribution
+#
+# Arguments:
+# scale Scale parameter of the Pareto distribution
+# shape Shape parameter of the Pareto distribution
+# x Value of variate
+#
+# Result:
+# Probability density of the given value of x to occur
+#
+proc ::math::statistics::pdf-pareto { scale shape x } {
+ variable OUTOFRANGE
+
+ if { $x <= $scale } {
+ return 0.0
+ }
+ if { $scale <= 0.0 || $shape <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE
+ }
+ set x [expr {$x / double($scale)}]
+ return [expr {$shape / double($scale) / pow($x,($shape + 1.0))}]
+}
+
+
+# pdf-cauchy --
+# Return the probabilities belonging to a Cauchy distribution
+#
+# Arguments:
+# location Location parameter of the Cauchy distribution
+# scale Scale parameter of the Cauchy distribution
+# x Value of variate
+#
+# Result:
+# Probability density of the given value of x to occur
+#
+# Note:
+# The Cauchy distribution does not have finite higher-order moments
+#
+proc ::math::statistics::pdf-cauchy { location scale x } {
+ variable OUTOFRANGE
+ variable pi
+
+ if { $scale <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE
+ }
+ set x [expr {($x - $location) / double($scale)}]
+ return [expr {1.0 / $pi / $scale / (1.0 +$x*$x)}]
+}
+
+
+# cdf-gamma --
+# Return the cumulative probabilities belonging to a gamma distribution
+#
+# Arguments:
+# alpha Shape parameter
+# beta Rate parameter
+# x Value of variate
+#
+# Result:
+# Cumulative probability of the given value of x to occur
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2007
+#
+proc ::math::statistics::cdf-gamma { alpha beta x } {
+ if { $x <= 0 } {
+ return 0.0
+ }
+ incompleteGamma [expr {$beta * $x}] $alpha
+}
+
+
+# cdf-poisson --
+# Return the cumulative probabilities belonging to a Poisson
+# distribution
+#
+# Arguments:
+# mu Mean of the distribution
+# x Number of occurrences
+#
+# Result:
+# Probability of k occurrences under the given distribution
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2007
+#
+proc ::math::statistics::cdf-poisson { mu x } {
+ return [expr {1.0 - [incompleteGamma $mu [expr {floor($x) + 1}]]}]
+}
+
+
+# cdf-chisquare --
+# Return the cumulative probabilities belonging to a chi square distribution
+#
+# Arguments:
+# df Degree of freedom
+# x Value of variate
+#
+# Result:
+# Cumulative probability of the given value of x to occur
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2007
+#
+proc ::math::statistics::cdf-chisquare { df x } {
+
+ if {$df <= 0} {
+ return -code error -errorcode ARG -errorinfo "Degrees of freedom must be positive"
+ }
+
+ return [cdf-gamma [expr {0.5*$df}] 0.5 $x]
+}
+
+
+# cdf-beta --
+# Return the cumulative probabilities belonging to a Beta distribution
+#
+# Arguments:
+# a First parameter of the Beta distribution
+# b Second parameter of the Beta distribution
+# x Value of variate
+#
+# Result:
+# Cumulative probability of the given value of x to occur
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2008
+#
+proc ::math::statistics::cdf-beta { a b x } {
+ incompleteBeta $a $b $x
+}
+
+
+# cdf-weibull --
+# Return the cumulative probabilities belonging to a Weibull distribution
+#
+# Arguments:
+# scale Scale parameter of the Weibull distribution
+# shape Shape parameter of the Weibull distribution
+# x Value of variate
+#
+# Result:
+# Cumulative probability of the given value of x to occur
+#
+proc ::math::statistics::cdf-weibull { scale shape x } {
+ variable OUTOFRANGE
+
+ if { $x <= 0 } {
+ return 0.0
+ }
+ if { $scale <= 0.0 || $shape <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE
+ }
+ set x [expr {$x / double($scale)}]
+ return [expr {1.0 - 1.0 / exp(pow($x,$shape))}]
+}
+
+
+# cdf-gumbel --
+# Return the cumulative probabilities belonging to a Gumbel distribution
+#
+# Arguments:
+# location Location parameter of the Gumbel distribution
+# scale Scale parameter of the Gumbel distribution
+# x Value of variate
+#
+# Result:
+# Cumulative probability of the given value of x to occur
+#
+proc ::math::statistics::cdf-gumbel { location scale x } {
+ variable OUTOFRANGE
+
+ if { $scale <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE
+ }
+ set x [expr {($x - $location) / double($scale)}]
+ return [expr {exp( -exp(-$x) )}]
+}
+
+
+# cdf-pareto --
+# Return the cumulative probabilities belonging to a Pareto distribution
+#
+# Arguments:
+# scale Scale parameter of the Pareto distribution
+# shape Shape parameter of the Pareto distribution
+# x Value of variate
+#
+# Result:
+# Cumulative probability density of the given value of x to occur
+#
+proc ::math::statistics::cdf-pareto { scale shape x } {
+ variable OUTOFRANGE
+
+ if { $x <= $scale } {
+ return 0.0
+ }
+ if { $scale <= 0.0 || $shape <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE
+ }
+ set x [expr {$x / double($scale)}]
+ return [expr {1.0 - 1.0 / pow($x,$shape)}]
+}
+
+
+# cdf-cauchy --
+# Return the cumulative probabilities belonging to a Cauchy distribution
+#
+# Arguments:
+# location Scale parameter of the Cauchy distribution
+# scale Shape parameter of the Cauchy distribution
+# x Value of variate
+#
+# Result:
+# Cumulative probability density of the given value of x to occur
+#
+proc ::math::statistics::cdf-cauchy { location scale x } {
+ variable OUTOFRANGE
+ variable pi
+
+ if { $scale <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE
+ }
+ set x [expr {($x - $location) / double($scale)}]
+ return [expr {0.5 + atan($x) / $pi}]
+}
+
+
+# random-gamma --
+# Generate a list of gamma-distributed deviates
+#
+# Arguments:
+# alpha Shape parameter
+# beta Rate parameter
+# number Number of values to return
+#
+# Result:
+# List of random values
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2007
+# Generate a list of gamma-distributed random deviates
+# Use Cheng's envelope rejection method, as documented in:
+# Dagpunar, J.S. 2007
+# "Simulation and Monte Carlo: With Applications in Finance and MCMC"
+#
+proc ::math::statistics::random-gamma {alpha beta number} {
+ if {$alpha <= 1} {
+ set lambda $alpha
+ } else {
+ set lambda [expr {sqrt(2.0 * $alpha - 1.0)}]
+ }
+ set retval {}
+ for {set i 0} {$i < $number} {incr i} {
+ while {1} {
+ # Two rands: one for deviate, one for acceptance/rejection
+ set r1 [expr {rand()}]
+ set r2 [expr {rand()}]
+ # Calculate deviate from enveloping proposal distribution (a Lorenz distribution)
+ set lnxovera [expr {(1.0/$lambda) * (log(1.0 - $r1) - log($r1))}]
+ if {![catch {expr {$alpha * exp($lnxovera)}} x]} {
+ # Apply acceptance criterion
+ if {log(4.0*$r1*$r1*$r2) < ($alpha - $lambda) * $lnxovera + $alpha - $x} {
+ break
+ }
+ }
+ }
+ lappend retval [expr {1.0 * $x/$beta}]
+ }
+
+ return $retval
+}
+
+
+# random-poisson --
+# Generate a list of Poisson-distributed deviates
+#
+# Arguments:
+# mu Mean value
+# number Number of deviates to return
+#
+# Result:
+# List of random values
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2007
+#
+proc ::math::statistics::random-poisson {mu number} {
+ if {$mu < 20} {
+ return [Randp_invert $mu $number]
+ } else {
+ return [Randp_PTRS $mu $number]
+ }
+}
+
+
+# random-chisquare --
+# Return a list of random numbers according to a chi square distribution
+#
+# Arguments:
+# df Degree of freedom
+# number Number of values to return
+#
+# Result:
+# List of random numbers
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2007
+#
+proc ::math::statistics::random-chisquare { df number } {
+
+ if {$df <= 0} {
+ return -code error -errorcode ARG -errorinfo "Degrees of freedom must be positive"
+ }
+
+ return [random-gamma [expr {0.5*$df}] 0.5 $number]
+}
+
+
+# random-students-t --
+# Return a list of random numbers according to a chi square distribution
+#
+# Arguments:
+# degrees Degree of freedom
+# number Number of values to return
+#
+# Result:
+# List of random numbers
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2007
+#
+# Use method from Appendix 4.3 in Dagpunar, J.S.,
+# "Simulation and Monte Carlo: With Applications in Finance and MCMC"
+#
+proc ::math::statistics::random-students-t { degrees number } {
+ variable pi
+
+ if {$degrees < 1} {
+ return -code error -errorcode ARG -errorinfo "Degrees of freedom must be at least 1"
+ }
+
+ set dd [expr {double($degrees)}]
+ set k [expr {2.0/($dd - 1.0)}]
+
+ for {set i 0} {$i < $number} {incr i} {
+ set r1 [expr {rand()}]
+ if {$degrees > 1} {
+ set r2 [expr {rand()}]
+ set c [expr {cos(2.0 * $pi * $r2)}]
+ lappend retval [expr {sqrt($dd/ \
+ (1.0/(1.0 - pow($r1, $k)) \
+ - $c * $c)) * $c}]
+ } else {
+ lappend retval [expr {tan(0.5 * $pi * ($r1 + $r1 - 1))}]
+ }
+ }
+ set retval
+}
+
+
+# random-beta --
+# Return a list of random numbers according to a Beta distribution
+#
+# Arguments:
+# a First parameter of the Beta distribution
+# b Second parameter of the Beta distribution
+# number Number of values to return
+#
+# Result:
+# Cumulative probability of the given value of x to occur
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2008
+#
+# Use trick from J.S. Dagpunar, "Simulation and
+# Monte Carlo: With Applications in Finance
+# and MCMC", Section 4.5
+#
+proc ::math::statistics::random-beta { a b number } {
+ set retval {}
+ foreach w [random-gamma $a 1.0 $number] y [random-gamma $b 1.0 $number] {
+ lappend retval [expr {$w / ($w + $y)}]
+ }
+ return $retval
+}
+
+
+# Random_invert --
+# Generate a list of Poisson-distributed deviates - method 1
+#
+# Arguments:
+# mu Mean value
+# number Number of deviates to return
+#
+# Result:
+# List of random values
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2007
+#
+# Generate a poisson-distributed random deviate
+# Use algorithm in section 4.9 of Dagpunar, J.S,
+# "Simulation and Monte Carlo: With Applications
+# in Finance and MCMC", pub. 2007 by Wiley
+# This inverts the cdf using a "chop-down" search
+# to avoid storing an extra intermediate value.
+# It is only good for small mu.
+#
+proc ::math::statistics::Randp_invert {mu number} {
+ set W0 [expr {exp(-$mu)}]
+
+ set retval {}
+
+ for {set i 0} {$i < $number} {incr i} {
+ set W $W0
+ set R [expr {rand()}]
+ set X 0
+
+ while {$R > $W} {
+ set R [expr {$R - $W}]
+ incr X
+ set W [expr {$W * $mu/double($X)}]
+ }
+
+ lappend retval $X
+ }
+
+ return $retval
+}
+
+
+# Random_PTRS --
+# Generate a list of Poisson-distributed deviates - method 2
+#
+# Arguments:
+# mu Mean value
+# number Number of deviates to return
+#
+# Result:
+# List of random values
+#
+# Note:
+# Implemented by Eric Kemp-Benedict, 2007
+# Generate a poisson-distributed random deviate
+# Use the transformed rejection method with
+# squeeze of Hoermann:
+# Wolfgang Hoermann, "The Transformed Rejection Method
+# for Generating Poisson Random Variables,"
+# Preprint #2, Dept of Applied Statistics and
+# Data Processing, Wirtshcaftsuniversitaet Wien,
+# http://statistik.wu-wien.ac.at/
+# This method works for mu >= 10.
+#
+proc ::math::statistics::Randp_PTRS {mu number} {
+ set smu [expr {sqrt($mu)}]
+ set b [expr {0.931 + 2.53 * $smu}]
+ set a [expr {-0.059 + 0.02483 * $b}]
+ set vr [expr {0.9277 - 3.6224/($b - 2.0)}]
+ set invalpha [expr {1.1239 + 1.1328/($b - 3.4)}]
+ set lnmu [expr {log($mu)}]
+
+ set retval {}
+ for {set i 0} {$i < $number} {incr i} {
+ while 1 {
+ set U [expr {rand() - 0.5}]
+ set V [expr {rand()}]
+
+ set us [expr {0.5 - abs($U)}]
+ set k [expr {int(floor((2.0 * $a/$us + $b) * $U + $mu + 0.43))}]
+
+ if {$us >= 0.07 && $V <= $vr} {
+ break
+ }
+
+ if {$k < 0} {
+ continue
+ }
+
+ if {$us < 0.013 && $V > $us} {
+ continue
+ }
+
+ set kp1 [expr {$k+1}]
+ if {log($V * $invalpha / ($a/($us * $us) + $b)) <= -$mu + $k * $lnmu - [::math::ln_Gamma $kp1]} {
+ break
+ }
+ }
+
+ lappend retval $k
+ }
+ return $retval
+}
+
+
+# random-weibull --
+# Generate a list of Weibull distributed deviates
+#
+# Arguments:
+# scale Scale parameter of the Weibull distribution
+# shape Shape parameter of the Weibull distribution
+# number Number of values to return
+#
+# Result:
+# List of random values
+#
+proc ::math::statistics::random-weibull { scale shape number } {
+ variable OUTOFRANGE
+
+ if { $scale <= 0.0 || $shape <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE
+ }
+ set rshape [expr {1.0/$shape}]
+ set retval {}
+ for {set i 0} {$i < $number} {incr i} {
+ lappend retval [expr {$scale * pow( (-log(rand())),$rshape)}]
+ }
+ return $retval
+}
+
+
+# random-gumbel --
+# Generate a list of Weibull distributed deviates
+#
+# Arguments:
+# location Location parameter of the Gumbel distribution
+# scale Scale parameter of the Gumbel distribution
+# number Number of values to return
+#
+# Result:
+# List of random values
+#
+proc ::math::statistics::random-gumbel { location scale number } {
+ variable OUTOFRANGE
+
+ if { $scale <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE
+ }
+ set retval {}
+ for {set i 0} {$i < $number} {incr i} {
+ lappend retval [expr {$location - $scale * log(-log(rand()))}]
+ }
+ return $retval
+}
+
+
+# random-pareto --
+# Generate a list of Pareto distributed deviates
+#
+# Arguments:
+# scale Scale parameter of the Pareto distribution
+# shape Shape parameter of the Pareto distribution
+# number Number of values to return
+#
+# Result:
+# List of random values
+#
+proc ::math::statistics::random-pareto { scale shape number } {
+ variable OUTOFRANGE
+
+ if { $scale <= 0.0 || $shape <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE
+ }
+ set rshape [expr {1.0/$shape}]
+ set retval {}
+ for {set i 0} {$i < $number} {incr i} {
+ lappend retval [expr {$scale / pow(rand(),$rshape)}]
+ }
+ return $retval
+}
+
+
+# random-cauchy --
+# Generate a list of Cauchy distributed deviates
+#
+# Arguments:
+# location Location parameter of the Cauchy distribution
+# scale Shape parameter of the Cauchy distribution
+# number Number of values to return
+#
+# Result:
+# List of random values
+#
+proc ::math::statistics::random-cauchy { location scale number } {
+ variable OUTOFRANGE
+ variable pi
+
+ if { $scale <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $OUTOFRANGE $OUTOFRANGE
+ }
+ set retval {}
+ for {set i 0} {$i < $number} {incr i} {
+ lappend retval [expr {$location + $scale * tan( $pi * (rand() - 0.5))}]
+ }
+ return $retval
+}
+
+
+# estimate-pareto --
+# Estimate the parameters of a Pareto distribution
+#
+# Arguments:
+# values Values that are supposed to be distributed according to Pareto
+#
+# Result:
+# Estimates of the scale and shape parameters as well as the standard error
+# for the shape parameter.
+#
+proc ::math::statistics::estimate-pareto { values } {
+ variable OUTOFRANGE
+ variable TOOFEWDATA
+
+ set nvalues {}
+ set negative 0
+
+ foreach v $values {
+ if { $v != {} } {
+ lappend nvalues $v
+ if { $v <= 0.0 } {
+ set negative 1
+ }
+ }
+ }
+ if { [llength $nvalues] == 0 } {
+ return -code error -errorcode ARG -errorinfo $TOOFEWDATA $TOOFEWDATA
+ }
+ if { $negative } {
+ return -code error -errorcode ARG -errorinfo "One or more negative or zero values" $OUTOFRANGE
+ }
+
+ #
+ # Scale parameter
+ #
+ set scale [min $nvalues]
+
+ #
+ # Shape parameter
+ #
+ set n [llength $nvalues]
+ set sum 0.0
+ foreach v $nvalues {
+ set sum [expr {$sum + log($v) - log($scale)}]
+ }
+ set shape [expr {$n / $sum}]
+
+ return [list $scale $shape [expr {$shape/sqrt($n)}]]
+}
+
+
+# empirical-distribution --
+# Determine the empirical distribution
+#
+# Arguments:
+# values Values that are to be examined
+#
+# Result:
+# List of sorted values and their empirical probability
+#
+# Note:
+# The value of "a" is adopted from the corresponding Wikipedia page,
+# which in turn adopted it from the R "stats" package (qqnorm function)
+#
+proc ::math::statistics::empirical-distribution { values } {
+ variable TOOFEWDATA
+
+ set n [llength $values]
+
+ if { $n < 5 } {
+ return -code error -errorcode ARG -errorinfo $TOOFEWDATA $TOOFEWDATA
+ }
+
+ set a 0.375
+ if { $n > 10 } {
+ set a 0.5
+ }
+
+ set distribution {}
+ set idx 1
+ foreach x [lsort -real -increasing $values] {
+ if { $x != {} } {
+ set p [expr {($idx - $a) / ($n + 1 - 2.0 * $a)}]
+
+ lappend distribution $x $p
+ incr idx
+ }
+ }
+
+ return $distribution
+}
+
+
+#
+# Simple numerical tests
+#
+if { [info exists ::argv0] && ([file tail [info script]] == [file tail $::argv0]) } {
+
+ #
+ # Apparent accuracy: at least one digit more than the ones in the
+ # given numbers
+ #
+ puts "Normal distribution - two-tailed"
+ foreach z {4.417 3.891 3.291 2.576 2.241 1.960 1.645 1.150 0.674
+ 0.319 0.126 0.063 0.0125} \
+ pexp {1.e-5 1.e-4 1.e-3 1.e-2 0.025 0.050 0.100 0.250 0.500
+ 0.750 0.900 0.950 0.990 } {
+ set prob [::math::statistics::Cdf-toms322 1 5000 [expr {$z*$z}]]
+ puts "$z - $pexp - [expr {1.0-$prob}]"
+ }
+
+ puts "Normal distribution (inverted; one-tailed)"
+ foreach p {0.001 0.01 0.1 0.25 0.5 0.75 0.9 0.99 0.999} {
+ puts "$p - [::math::statistics::Inverse-cdf-normal 0.0 1.0 $p]"
+ }
+ puts "Normal random variables"
+ set rndvars [::math::statistics::random-normal 1.0 2.0 20]
+ puts $rndvars
+ puts "Normal uniform variables"
+ set rndvars [::math::statistics::random-uniform 1.0 2.0 20]
+ puts $rndvars
+ puts "Normal exponential variables"
+ set rndvars [::math::statistics::random-exponential 2.0 20]
+ puts $rndvars
+}
diff --git a/tcllib/modules/math/pkgIndex.tcl b/tcllib/modules/math/pkgIndex.tcl
new file mode 100644
index 0000000..fb9b3c3
--- /dev/null
+++ b/tcllib/modules/math/pkgIndex.tcl
@@ -0,0 +1,33 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded math 1.2.5 [list source [file join $dir math.tcl]]
+package ifneeded math::geometry 1.1.3 [list source [file join $dir geometry.tcl]]
+package ifneeded math::fuzzy 0.2.1 [list source [file join $dir fuzzy.tcl]]
+package ifneeded math::complexnumbers 1.0.2 [list source [file join $dir qcomplex.tcl]]
+package ifneeded math::special 0.3.0 [list source [file join $dir special.tcl]]
+package ifneeded math::constants 1.0.2 [list source [file join $dir constants.tcl]]
+package ifneeded math::polynomials 1.0.1 [list source [file join $dir polynomials.tcl]]
+package ifneeded math::rationalfunctions 1.0.1 [list source [file join $dir rational_funcs.tcl]]
+package ifneeded math::fourier 1.0.2 [list source [file join $dir fourier.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.3]} {return}
+package ifneeded math::roman 1.0 [list source [file join $dir romannumerals.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+# statistics depends on linearalgebra (for multi-variate linear regression).
+package ifneeded math::statistics 1.0 [list source [file join $dir statistics.tcl]]
+package ifneeded math::optimize 1.0.1 [list source [file join $dir optimize.tcl]]
+package ifneeded math::calculus 0.8.1 [list source [file join $dir calculus.tcl]]
+package ifneeded math::interpolate 1.1 [list source [file join $dir interpolate.tcl]]
+package ifneeded math::linearalgebra 1.1.5 [list source [file join $dir linalg.tcl]]
+package ifneeded math::bignum 3.1.1 [list source [file join $dir bignum.tcl]]
+package ifneeded math::bigfloat 1.2.2 [list source [file join $dir bigfloat.tcl]]
+package ifneeded math::machineparameters 0.1 [list source [file join $dir machineparameters.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+package ifneeded math::calculus::symdiff 1.0.1 [list source [file join $dir symdiff.tcl]]
+package ifneeded math::bigfloat 2.0.2 [list source [file join $dir bigfloat2.tcl]]
+package ifneeded math::numtheory 1.0 [list source [file join $dir numtheory.tcl]]
+package ifneeded math::decimal 1.0.3 [list source [file join $dir decimal.tcl]]
+
+if {![package vsatisfies [package require Tcl] 8.6]} {return}
+package ifneeded math::exact 1.0 [list source [file join $dir exact.tcl]]
diff --git a/tcllib/modules/math/plotstat.tcl b/tcllib/modules/math/plotstat.tcl
new file mode 100755
index 0000000..1c38fcb
--- /dev/null
+++ b/tcllib/modules/math/plotstat.tcl
@@ -0,0 +1,312 @@
+# plotstat.tcl --
+#
+# Set of very simple drawing routines, belonging to the statistics
+# package
+#
+# version 0.1: initial implementation, january 2003
+
+namespace eval ::math::statistics {}
+
+# plot-scale
+# Set the scale for a plot in the given canvas
+#
+# Arguments:
+# canvas Canvas widget to use
+# xmin Minimum x value
+# xmax Maximum x value
+# ymin Minimum y value
+# ymax Maximum y value
+#
+# Result:
+# None
+#
+# Side effect:
+# Array elements set
+#
+proc ::math::statistics::plot-scale { canvas xmin xmax ymin ymax } {
+ variable plot
+
+ if { $xmin == $xmax } { set xmax [expr {1.1*$xmin+1.0}] }
+ if { $ymin == $ymax } { set ymax [expr {1.1*$ymin+1.0}] }
+
+ set plot($canvas,xmin) $xmin
+ set plot($canvas,xmax) $xmax
+ set plot($canvas,ymin) $ymin
+ set plot($canvas,ymax) $ymax
+
+ set cwidth [$canvas cget -width]
+ set cheight [$canvas cget -height]
+ set cx 20
+ set cy 20
+ set cx2 [expr {$cwidth-$cx}]
+ set cy2 [expr {$cheight-$cy}]
+
+ set plot($canvas,cx) $cx
+ set plot($canvas,cy) $cy
+
+ set plot($canvas,dx) [expr {($cwidth-2*$cx)/double($xmax-$xmin)}]
+ set plot($canvas,dy) [expr {($cheight-2*$cy)/double($ymax-$ymin)}]
+ set plot($canvas,cx2) $cx2
+ set plot($canvas,cy2) $cy2
+
+ $canvas create line $cx $cy $cx $cy2 $cx2 $cy2 -tag axes
+}
+
+# plot-xydata
+# Create a simple XY plot in the given canvas (collection of dots)
+#
+# Arguments:
+# canvas Canvas widget to use
+# xdata Series of independent data
+# ydata Series of dependent data
+# tag Tag to give to the plotted data (defaults to xyplot)
+#
+# Result:
+# None
+#
+# Side effect:
+# Simple xy graph in the canvas
+#
+# Note:
+# The tag can be used to manipulate the xy graph
+#
+proc ::math::statistics::plot-xydata { canvas xdata ydata {tag xyplot} } {
+ PlotXY $canvas points $tag $xdata $ydata
+}
+
+# plot-xyline
+# Create a simple XY plot in the given canvas (continuous line)
+#
+# Arguments:
+# canvas Canvas widget to use
+# xdata Series of independent data
+# ydata Series of dependent data
+# tag Tag to give to the plotted data (defaults to xyplot)
+#
+# Result:
+# None
+#
+# Side effect:
+# Simple xy graph in the canvas
+#
+# Note:
+# The tag can be used to manipulate the xy graph
+#
+proc ::math::statistics::plot-xyline { canvas xdata ydata {tag xyplot} } {
+ PlotXY $canvas line $tag $xdata $ydata
+}
+
+# plot-tdata
+# Create a simple XY plot in the given canvas (the index in the list
+# is the horizontal coordinate; points)
+#
+# Arguments:
+# canvas Canvas widget to use
+# tdata Series of dependent data
+# tag Tag to give to the plotted data (defaults to xyplot)
+#
+# Result:
+# None
+#
+# Side effect:
+# Simple xy graph in the canvas
+#
+# Note:
+# The tag can be used to manipulate the xy graph
+#
+proc ::math::statistics::plot-tdata { canvas tdata {tag xyplot} } {
+ PlotXY $canvas points $tag {} $tdata
+}
+
+# plot-tline
+# Create a simple XY plot in the given canvas (the index in the list
+# is the horizontal coordinate; line)
+#
+# Arguments:
+# canvas Canvas widget to use
+# tdata Series of dependent data
+# tag Tag to give to the plotted data (defaults to xyplot)
+#
+# Result:
+# None
+#
+# Side effect:
+# Simple xy graph in the canvas
+#
+# Note:
+# The tag can be used to manipulate the xy graph
+#
+proc ::math::statistics::plot-tline { canvas tdata {tag xyplot} } {
+ PlotXY $canvas line $tag {} $tdata
+}
+
+# PlotXY
+# Create a simple XY plot (points or lines) in the given canvas
+#
+# Arguments:
+# canvas Canvas widget to use
+# type Type: points or line
+# tag Tag to give to the plotted data
+# xdata Series of independent data (if empty: index used instead)
+# ydata Series of dependent data
+#
+# Result:
+# None
+#
+# Side effect:
+# Simple xy graph in the canvas
+#
+# Note:
+# This is the actual routine
+#
+proc ::math::statistics::PlotXY { canvas type tag xdata ydata } {
+ variable plot
+
+ if { ![info exists plot($canvas,xmin)] } {
+ return -code error -errorcode "No scaling given for canvas $canvas"
+ }
+
+ set xmin $plot($canvas,xmin)
+ set xmax $plot($canvas,xmax)
+ set ymin $plot($canvas,ymin)
+ set ymax $plot($canvas,ymax)
+ set dx $plot($canvas,dx)
+ set dy $plot($canvas,dy)
+ set cx $plot($canvas,cx)
+ set cy $plot($canvas,cy)
+ set cx2 $plot($canvas,cx2)
+ set cy2 $plot($canvas,cy2)
+
+ set plotpoints [expr {$type == "points"}]
+ set xpresent [expr {[llength $xdata] > 0}]
+ set idx 0
+ set coords {}
+
+ foreach y $ydata {
+ if { $xpresent } {
+ set x [lindex $xdata $idx]
+ } else {
+ set x $idx
+ }
+ incr idx
+
+ if { $x == {} } continue
+ if { $y == {} } continue
+ if { $x > $xmax } continue
+ if { $x < $xmin } continue
+ if { $y > $ymax } continue
+ if { $y < $ymin } continue
+
+ if { $plotpoints } {
+ set xc [expr {$cx+$dx*($x-$xmin)-2}]
+ set yc [expr {$cy2-$dy*($y-$ymin)-2}]
+ set xc2 [expr {$xc+4}]
+ set yc2 [expr {$yc+4}]
+ $canvas create oval $xc $yc $xc2 $yc2 -tag $tag -fill black
+ } else {
+ set xc [expr {$cx+$dx*($x-$xmin)}]
+ set yc [expr {$cy2-$dy*($y-$ymin)}]
+ lappend coords $xc $yc
+ }
+ }
+
+ if { ! $plotpoints } {
+ $canvas create line $coords -tag $tag
+ }
+}
+
+# plot-histogram
+# Create a simple histogram in the given canvas
+#
+# Arguments:
+# canvas Canvas widget to use
+# counts Series of bucket counts
+# limits Series of upper limits for the buckets
+# tag Tag to give to the plotted data (defaults to xyplot)
+#
+# Result:
+# None
+#
+# Side effect:
+# Simple histogram in the canvas
+#
+# Note:
+# The number of limits determines how many bars are drawn,
+# the number of counts that is expected is one larger. The
+# lower and upper limits of the first and last bucket are
+# taken to be equal to the scale's extremes
+#
+proc ::math::statistics::plot-histogram { canvas counts limits {tag xyplot} } {
+ variable plot
+
+ if { ![info exists plot($canvas,xmin)] } {
+ return -code error -errorcode DATA "No scaling given for canvas $canvas"
+ }
+
+ if { ([llength $counts]-[llength $limits]) != 1 } {
+ return -code error -errorcode ARG \
+ "Number of counts does not correspond to number of limits"
+ }
+
+ set xmin $plot($canvas,xmin)
+ set xmax $plot($canvas,xmax)
+ set ymin $plot($canvas,ymin)
+ set ymax $plot($canvas,ymax)
+ set dx $plot($canvas,dx)
+ set dy $plot($canvas,dy)
+ set cx $plot($canvas,cx)
+ set cy $plot($canvas,cy)
+ set cx2 $plot($canvas,cx2)
+ set cy2 $plot($canvas,cy2)
+
+ #
+ # Construct a sufficiently long list of x-coordinates
+ #
+ set xdata [concat $xmin $limits $xmax]
+
+ set idx 0
+ foreach x $xdata y $counts {
+ incr idx
+
+ if { $y == {} } continue
+
+ set x1 $x
+ if { $x < $xmin } { set x1 $xmin }
+ if { $x > $xmax } { set x1 $xmax }
+
+ if { $y > $ymax } { set y $ymax }
+ if { $y < $ymin } { set y $ymin }
+
+ set x2 [lindex $xdata $idx]
+ if { $x2 < $xmin } { set x2 $xmin }
+ if { $x2 > $xmax } { set x2 $xmax }
+
+ set xc [expr {$cx+$dx*($x1-$xmin)}]
+ set xc2 [expr {$cx+$dx*($x2-$xmin)}]
+ set yc [expr {$cy2-$dy*($y-$ymin)}]
+ set yc2 $cy2
+
+ $canvas create rectangle $xc $yc $xc2 $yc2 -tag $tag -fill blue
+ }
+}
+
+#
+# Simple test code
+#
+if { [info exists ::argv0] && ([file tail [info script]] == [file tail $::argv0]) } {
+
+ set xdata {1 2 3 4 5 10 20 6 7 8 1 3 4 5 6 7}
+ set ydata {2 3 4 5 6 10 20 7 8 1 3 4 5 6 7 1}
+
+ canvas .c
+ canvas .c2
+ pack .c .c2 -side top -fill both
+ ::math::statistics::plot-scale .c 0 10 0 10
+ ::math::statistics::plot-scale .c2 0 20 0 10
+
+ ::math::statistics::plot-xydata .c $xdata $ydata
+ ::math::statistics::plot-xyline .c $xdata $ydata
+ ::math::statistics::plot-histogram .c2 {1 3 2 0.1 4 2} {-1 3 10 11 23}
+ ::math::statistics::plot-tdata .c2 $xdata
+ ::math::statistics::plot-tline .c2 $xdata
+}
diff --git a/tcllib/modules/math/polynomials.man b/tcllib/modules/math/polynomials.man
new file mode 100755
index 0000000..ede9a3c
--- /dev/null
+++ b/tcllib/modules/math/polynomials.man
@@ -0,0 +1,219 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin math::polynomials n 1.0.1]
+[keywords math]
+[keywords {polynomial functions}]
+[copyright {2004 Arjen Markus <arjenmarkus@users.sourceforge.net>}]
+[moddesc {Tcl Math Library}]
+[titledesc {Polynomial functions}]
+[category Mathematics]
+[require Tcl [opt 8.3]]
+[require math::polynomials [opt 1.0.1]]
+
+[description]
+[para]
+This package deals with polynomial functions of one variable:
+
+[list_begin itemized]
+[item]
+the basic arithmetic operations are extended to polynomials
+[item]
+computing the derivatives and primitives of these functions
+[item]
+evaluation through a general procedure or via specific procedures)
+[list_end]
+
+[section "PROCEDURES"]
+
+The package defines the following public procedures:
+
+[list_begin definitions]
+
+[call [cmd ::math::polynomials::polynomial] [arg coeffs]]
+
+Return an (encoded) list that defines the polynomial. A polynomial
+[example {
+ f(x) = a + b.x + c.x**2 + d.x**3
+}]
+can be defined via:
+[example {
+ set f [::math::polynomials::polynomial [list $a $b $c $d]
+}]
+
+[list_begin arguments]
+[arg_def list coeffs] Coefficients of the polynomial (in ascending
+order)
+[list_end]
+
+[para]
+
+[call [cmd ::math::polynomials::polynCmd] [arg coeffs]]
+
+Create a new procedure that evaluates the polynomial. The name of the
+polynomial is automatically generated. Useful if you need to evualuate
+the polynomial many times, as the procedure consists of a single
+[lb]expr[rb] command.
+
+[list_begin arguments]
+[arg_def list coeffs] Coefficients of the polynomial (in ascending
+order) or the polynomial definition returned by the [emph polynomial]
+command.
+[list_end]
+
+[para]
+
+[call [cmd ::math::polynomials::evalPolyn] [arg polynomial] [arg x]]
+
+Evaluate the polynomial at x.
+
+[list_begin arguments]
+[arg_def list polynomial] The polynomial's definition (as returned by
+the polynomial command).
+order)
+
+[arg_def float x] The coordinate at which to evaluate the polynomial
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::polynomials::addPolyn] [arg polyn1] [arg polyn2]]
+
+Return a new polynomial which is the sum of the two others.
+
+[list_begin arguments]
+[arg_def list polyn1] The first polynomial operand
+
+[arg_def list polyn2] The second polynomial operand
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::polynomials::subPolyn] [arg polyn1] [arg polyn2]]
+
+Return a new polynomial which is the difference of the two others.
+
+[list_begin arguments]
+[arg_def list polyn1] The first polynomial operand
+
+[arg_def list polyn2] The second polynomial operand
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::polynomials::multPolyn] [arg polyn1] [arg polyn2]]
+
+Return a new polynomial which is the product of the two others. If one
+of the arguments is a scalar value, the other polynomial is simply
+scaled.
+
+[list_begin arguments]
+[arg_def list polyn1] The first polynomial operand or a scalar
+
+[arg_def list polyn2] The second polynomial operand or a scalar
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::polynomials::divPolyn] [arg polyn1] [arg polyn2]]
+
+Divide the first polynomial by the second polynomial and return the
+result. The remainder is dropped
+
+[list_begin arguments]
+[arg_def list polyn1] The first polynomial operand
+
+[arg_def list polyn2] The second polynomial operand
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::polynomials::remainderPolyn] [arg polyn1] [arg polyn2]]
+
+Divide the first polynomial by the second polynomial and return the
+remainder.
+
+[list_begin arguments]
+[arg_def list polyn1] The first polynomial operand
+
+[arg_def list polyn2] The second polynomial operand
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::polynomials::derivPolyn] [arg polyn]]
+
+Differentiate the polynomial and return the result.
+
+[list_begin arguments]
+[arg_def list polyn] The polynomial to be differentiated
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::polynomials::primitivePolyn] [arg polyn]]
+
+Integrate the polynomial and return the result. The integration
+constant is set to zero.
+
+[list_begin arguments]
+[arg_def list polyn] The polynomial to be integrated
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::polynomials::degreePolyn] [arg polyn]]
+
+Return the degree of the polynomial.
+
+[list_begin arguments]
+[arg_def list polyn] The polynomial to be examined
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::polynomials::coeffPolyn] [arg polyn] [arg index]]
+
+Return the coefficient of the term of the index'th degree of the
+polynomial.
+
+[list_begin arguments]
+[arg_def list polyn] The polynomial to be examined
+[arg_def int index] The degree of the term
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::polynomials::allCoeffsPolyn] [arg polyn]]
+
+Return the coefficients of the polynomial (in ascending order).
+
+[list_begin arguments]
+[arg_def list polyn] The polynomial in question
+
+[list_end]
+
+[list_end]
+
+[section "REMARKS ON THE IMPLEMENTATION"]
+
+The implementation for evaluating the polynomials at some point uses
+Horn's rule, which guarantees numerical stability and a minimum of
+arithmetic operations.
+
+To recognise that a polynomial definition is indeed a correct
+definition, it consists of a list of two elements: the keyword
+"POLYNOMIAL" and the list of coefficients in descending order. The
+latter makes it easier to implement Horner's rule.
+
+[vset CATEGORY {math :: polynomials}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/polynomials.tcl b/tcllib/modules/math/polynomials.tcl
new file mode 100755
index 0000000..928d3c8
--- /dev/null
+++ b/tcllib/modules/math/polynomials.tcl
@@ -0,0 +1,560 @@
+# polynomials.tcl --
+# Implement procedures to deal with polynomial functions
+#
+namespace eval ::math::polynomials {
+ variable count 0 ;# Count the number of specific commands
+ namespace eval v {}
+
+ namespace export polynomial polynCmd evalPolyn \
+ degreePolyn coeffPolyn allCoeffsPolyn \
+ derivPolyn primitivePolyn \
+ addPolyn subPolyn multPolyn \
+ divPolyn remainderPolyn
+}
+
+
+# polynomial --
+# Return a polynomial definition
+#
+# Arguments:
+# coeffs The coefficients of the polynomial
+# Result:
+# Polynomial definition
+#
+proc ::math::polynomials::polynomial {coeffs} {
+
+ set rev_coeffs {}
+ set degree -1
+ set index 0
+ foreach coeff $coeffs {
+ if { ! [string is double -strict $coeff] } {
+ return -code error "Coefficients must be real numbers"
+ }
+ set rev_coeffs [concat $coeff $rev_coeffs]
+ if { $coeff != 0.0 } {
+ set degree $index
+ }
+ incr index
+ }
+
+ #
+ # The leading coefficient must be non-zero
+ #
+ return [list POLYNOMIAL [lrange $rev_coeffs end-$degree end]]
+}
+
+# polynCmd --
+# Return a procedure that implements a polynomial evaluation
+#
+# Arguments:
+# coeffs The coefficients of the polynomial (or a definition)
+# Result:
+# New procedure
+#
+proc ::math::polynomials::polynCmd {coeffs} {
+ variable count
+
+ if { [lindex $coeffs 0] == "POLYNOMIAL" } {
+ set coeffs [allCoeffsPolyn $coeffs]
+ }
+
+ set degree [expr {[llength $coeffs]-1}]
+ set body "expr \{[join $coeffs +\$x*(][string repeat ) $degree]\}"
+
+ incr count
+ set name "::math::polynomials::v::POLYN$count"
+ proc $name {x} $body
+ return $name
+}
+
+# evalPolyn --
+# Evaluate a polynomial at a given coordinate
+#
+# Arguments:
+# polyn Polynomial definition
+# x Coordinate
+# Result:
+# Value at x
+#
+proc ::math::polynomials::evalPolyn {polyn x} {
+ if { [lindex $polyn 0] != "POLYNOMIAL" } {
+ return -code error "Not a polynomial"
+ }
+ if { ! [string is double $x] } {
+ return -code error "Coordinate must be a real number"
+ }
+
+ set result 0.0
+ foreach c [lindex $polyn 1] {
+ set result [expr {$result*$x+$c}]
+ }
+ return $result
+}
+
+# degreePolyn --
+# Return the degree of the polynomial
+#
+# Arguments:
+# polyn Polynomial definition
+# Result:
+# The degree
+#
+proc ::math::polynomials::degreePolyn {polyn} {
+ if { [lindex $polyn 0] != "POLYNOMIAL" } {
+ return -code error "Not a polynomial"
+ }
+ return [expr {[llength [lindex $polyn 1]]-1}]
+}
+
+# coeffPolyn --
+# Return the coefficient of the index'th degree of the polynomial
+#
+# Arguments:
+# polyn Polynomial definition
+# index Degree for which to return the coefficient
+# Result:
+# The coefficient of degree "index"
+#
+proc ::math::polynomials::coeffPolyn {polyn index} {
+ if { [lindex $polyn 0] != "POLYNOMIAL" } {
+ return -code error "Not a polynomial"
+ }
+ set coeffs [lindex $polyn 1]
+ if { $index < 0 || $index > [llength $coeffs] } {
+ return -code error "Index must be between 0 and [llength $coeffs]"
+ }
+ return [lindex $coeffs end-$index]
+}
+
+# allCoeffsPolyn --
+# Return the coefficients of the polynomial
+#
+# Arguments:
+# polyn Polynomial definition
+# Result:
+# The coefficients in ascending order
+#
+proc ::math::polynomials::allCoeffsPolyn {polyn} {
+ if { [lindex $polyn 0] != "POLYNOMIAL" } {
+ return -code error "Not a polynomial"
+ }
+ set rev_coeffs [lindex $polyn 1]
+ set coeffs {}
+ foreach c $rev_coeffs {
+ set coeffs [concat $c $coeffs]
+ }
+ return $coeffs
+}
+
+# derivPolyn --
+# Return the derivative of the polynomial
+#
+# Arguments:
+# polyn Polynomial definition
+# Result:
+# The new polynomial
+#
+proc ::math::polynomials::derivPolyn {polyn} {
+ if { [lindex $polyn 0] != "POLYNOMIAL" } {
+ return -code error "Not a polynomial"
+ }
+ set coeffs [lindex $polyn 1]
+ set new_coeffs {}
+ set idx [degreePolyn $polyn]
+ foreach c [lrange $coeffs 0 end-1] {
+ lappend new_coeffs [expr {$idx*$c}]
+ incr idx -1
+ }
+ return [list POLYNOMIAL $new_coeffs]
+}
+
+# primitivePolyn --
+# Return the primitive of the polynomial
+#
+# Arguments:
+# polyn Polynomial definition
+# Result:
+# The new polynomial
+#
+proc ::math::polynomials::primitivePolyn {polyn} {
+ if { [lindex $polyn 0] != "POLYNOMIAL" } {
+ return -code error "Not a polynomial"
+ }
+ set coeffs [lindex $polyn 1]
+ set new_coeffs {}
+ set idx [llength $coeffs]
+ foreach c [lrange $coeffs 0 end] {
+ lappend new_coeffs [expr {$c/double($idx)}]
+ incr idx -1
+ }
+ return [list POLYNOMIAL [concat $new_coeffs 0.0]]
+}
+
+# addPolyn --
+# Add two polynomials and return the result
+#
+# Arguments:
+# polyn1 First polynomial or a scalar
+# polyn2 Second polynomial or a scalar
+# Result:
+# The sum of the two polynomials
+# Note:
+# Make sure that the first coefficient is not zero
+#
+proc ::math::polynomials::addPolyn {polyn1 polyn2} {
+ if { [llength $polyn1] == 1 && [string is double -strict $polyn1] } {
+ set polyn1 [polynomial $polyn1]
+ }
+ if { [llength $polyn2] == 1 && [string is double -strict $polyn2] } {
+ set polyn2 [polynomial $polyn2]
+ }
+ if { [lindex $polyn1 0] != "POLYNOMIAL" ||
+ [lindex $polyn2 0] != "POLYNOMIAL" } {
+ return -code error "Both arguments must be polynomials or a real number"
+ }
+ set coeffs1 [lindex $polyn1 1]
+ set coeffs2 [lindex $polyn2 1]
+
+ set extra1 [expr {[llength $coeffs2]-[llength $coeffs1]}]
+ while { $extra1 > 0 } {
+ set coeffs1 [concat 0.0 $coeffs1]
+ incr extra1 -1
+ }
+
+ set extra2 [expr {[llength $coeffs1]-[llength $coeffs2]}]
+ while { $extra2 > 0 } {
+ set coeffs2 [concat 0.0 $coeffs2]
+ incr extra2 -1
+ }
+
+ set new_coeffs {}
+ foreach c1 $coeffs1 c2 $coeffs2 {
+ lappend new_coeffs [expr {$c1+$c2}]
+ }
+ while { [lindex $new_coeffs 0] == 0.0 } {
+ set new_coeffs [lrange $new_coeffs 1 end]
+ }
+ return [list POLYNOMIAL $new_coeffs]
+}
+
+# subPolyn --
+# Subtract two polynomials and return the result
+#
+# Arguments:
+# polyn1 First polynomial or a scalar
+# polyn2 Second polynomial or a scalar
+# Result:
+# The difference of the two polynomials
+# Note:
+# Make sure that the first coefficient is not zero
+#
+proc ::math::polynomials::subPolyn {polyn1 polyn2} {
+ if { [llength $polyn1] == 1 && [string is double -strict $polyn1] } {
+ set polyn1 [polynomial $polyn1]
+ }
+ if { [llength $polyn2] == 1 && [string is double -strict $polyn2] } {
+ set polyn2 [polynomial $polyn2]
+ }
+ if { [lindex $polyn1 0] != "POLYNOMIAL" ||
+ [lindex $polyn2 0] != "POLYNOMIAL" } {
+ return -code error "Both arguments must be polynomials or a real number"
+ }
+ set coeffs1 [lindex $polyn1 1]
+ set coeffs2 [lindex $polyn2 1]
+
+ set extra1 [expr {[llength $coeffs2]-[llength $coeffs1]}]
+ while { $extra1 > 0 } {
+ set coeffs1 [concat 0.0 $coeffs1]
+ incr extra1 -1
+ }
+
+ set extra2 [expr {[llength $coeffs1]-[llength $coeffs2]}]
+ while { $extra2 > 0 } {
+ set coeffs2 [concat 0.0 $coeffs2]
+ incr extra2 -1
+ }
+
+ set new_coeffs {}
+ foreach c1 $coeffs1 c2 $coeffs2 {
+ lappend new_coeffs [expr {$c1-$c2}]
+ }
+ while { [lindex $new_coeffs 0] == 0.0 } {
+ set new_coeffs [lrange $new_coeffs 1 end]
+ }
+ return [list POLYNOMIAL $new_coeffs]
+}
+
+# multPolyn --
+# Multiply two polynomials and return the result
+#
+# Arguments:
+# polyn1 First polynomial or a scalar
+# polyn2 Second polynomial or a scalar
+# Result:
+# The difference of the two polynomials
+# Note:
+# Make sure that the first coefficient is not zero
+#
+proc ::math::polynomials::multPolyn {polyn1 polyn2} {
+ if { [llength $polyn1] == 1 && [string is double -strict $polyn1] } {
+ set polyn1 [polynomial $polyn1]
+ }
+ if { [llength $polyn2] == 1 && [string is double -strict $polyn2] } {
+ set polyn2 [polynomial $polyn2]
+ }
+ if { [lindex $polyn1 0] != "POLYNOMIAL" ||
+ [lindex $polyn2 0] != "POLYNOMIAL" } {
+ return -code error "Both arguments must be polynomials or a real number"
+ }
+
+ set coeffs1 [lindex $polyn1 1]
+ set coeffs2 [lindex $polyn2 1]
+
+ #
+ # Take care of the null polynomial
+ #
+ if { $coeffs1 == {} || $coeffs2 == {} } {
+ return [polynomial {}]
+ }
+
+ set zeros {}
+ foreach c $coeffs1 {
+ lappend zeros 0.0
+ }
+
+ set new_coeffs [lrange $zeros 1 end]
+ foreach c $coeffs2 {
+ lappend new_coeffs 0.0
+ }
+
+ set idx 0
+ foreach c $coeffs1 {
+ set term_coeffs {}
+ foreach c2 $coeffs2 {
+ lappend term_coeffs [expr {$c*$c2}]
+ }
+ set term_coeffs [concat [lrange $zeros 0 [expr {$idx-1}]] \
+ $term_coeffs \
+ [lrange $zeros [expr {$idx+1}] end]]
+
+ set sum_coeffs {}
+ foreach t $term_coeffs n $new_coeffs {
+ lappend sum_coeffs [expr {$t+$n}]
+ }
+ set new_coeffs $sum_coeffs
+ incr idx
+ }
+
+ return [list POLYNOMIAL $new_coeffs]
+}
+
+# divPolyn --
+# Divide two polynomials and return the quotient
+#
+# Arguments:
+# polyn1 First polynomial or a scalar
+# polyn2 Second polynomial or a scalar
+# Result:
+# The difference of the two polynomials
+# Note:
+# Make sure that the first coefficient is not zero
+#
+proc ::math::polynomials::divPolyn {polyn1 polyn2} {
+ if { [llength $polyn1] == 1 && [string is double -strict $polyn1] } {
+ set polyn1 [polynomial $polyn1]
+ }
+ if { [llength $polyn2] == 1 && [string is double -strict $polyn2] } {
+ set polyn2 [polynomial $polyn2]
+ }
+ if { [lindex $polyn1 0] != "POLYNOMIAL" ||
+ [lindex $polyn2 0] != "POLYNOMIAL" } {
+ return -code error "Both arguments must be polynomials or a real number"
+ }
+
+ set coeffs1 [lindex $polyn1 1]
+ set coeffs2 [lindex $polyn2 1]
+
+ #
+ # Take care of the null polynomial
+ #
+ if { $coeffs1 == {} } {
+ return [polynomial {}]
+ }
+ if { $coeffs2 == {} } {
+ return -code error "Denominator can not be zero"
+ }
+
+ foreach {quotient remainder} [DivRemPolyn $polyn1 $polyn2] {break}
+ return $quotient
+}
+
+# remainderPolyn --
+# Divide two polynomials and return the remainder
+#
+# Arguments:
+# polyn1 First polynomial or a scalar
+# polyn2 Second polynomial or a scalar
+# Result:
+# The difference of the two polynomials
+# Note:
+# Make sure that the first coefficient is not zero
+#
+proc ::math::polynomials::remainderPolyn {polyn1 polyn2} {
+ if { [llength $polyn1] == 1 && [string is double -strict $polyn1] } {
+ set polyn1 [polynomial $polyn1]
+ }
+ if { [llength $polyn2] == 1 && [string is double -strict $polyn2] } {
+ set polyn2 [polynomial $polyn2]
+ }
+ if { [lindex $polyn1 0] != "POLYNOMIAL" ||
+ [lindex $polyn2 0] != "POLYNOMIAL" } {
+ return -code error "Both arguments must be polynomials or a real number"
+ }
+
+ set coeffs1 [lindex $polyn1 1]
+ set coeffs2 [lindex $polyn2 1]
+
+ #
+ # Take care of the null polynomial
+ #
+ if { $coeffs1 == {} } {
+ return [polynomial {}]
+ }
+ if { $coeffs2 == {} } {
+ return -code error "Denominator can not be zero"
+ }
+
+ foreach {quotient remainder} [DivRemPolyn $polyn1 $polyn2] {break}
+ return $remainder
+}
+
+# DivRemPolyn --
+# Divide two polynomials and return the quotient and remainder
+#
+# Arguments:
+# polyn1 First polynomial or a scalar
+# polyn2 Second polynomial or a scalar
+# Result:
+# The difference of the two polynomials
+# Note:
+# Make sure that the first coefficient is not zero
+#
+proc ::math::polynomials::DivRemPolyn {polyn1 polyn2} {
+
+ set coeffs1 [lindex $polyn1 1]
+ set coeffs2 [lindex $polyn2 1]
+
+ set steps [expr { [degreePolyn $polyn1] - [degreePolyn $polyn2] + 1 }]
+
+ #
+ # Special case: polynomial 1 has lower degree than polynomial 2
+ #
+ if { $steps <= 0 } {
+ return [list [polynomial 0.0] $polyn1]
+ } else {
+ set extra_coeffs {}
+ for { set i 1 } { $i < $steps } { incr i } {
+ lappend extra_coeffs 0.0
+ }
+ lappend extra_coeffs 1.0
+ }
+
+ set c2 [lindex $coeffs2 0]
+ set quot_coeffs {}
+
+ for { set i 0 } { $i < $steps } { incr i } {
+ set c1 [lindex $coeffs1 0]
+ set factor [expr {$c1/$c2}]
+
+ set fpolyn [multPolyn $polyn2 \
+ [polynomial [lrange $extra_coeffs $i end]]]
+
+ set newpol [subPolyn $polyn1 [multPolyn $fpolyn $factor]]
+
+ #
+ # Due to rounding errors, a very small, parasitical
+ # term may still exist. Remove it
+ #
+ if { [degreePolyn $newpol] == [degreePolyn $polyn1] } {
+ set new_coeffs [lrange [allCoeffsPolyn $newpol] 0 end-1]
+ set newpol [polynomial $new_coeffs]
+ }
+ set polyn1 $newpol
+ set coeffs1 [lindex $polyn1 1]
+ set quot_coeffs [concat $factor $quot_coeffs]
+ }
+ set quotient [polynomial $quot_coeffs]
+
+ return [list $quotient $polyn1]
+}
+
+#
+# Announce our presence
+#
+package provide math::polynomials 1.0.1
+
+# some tests --
+#
+if { 0 } {
+set prec $::tcl_precision
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ set ::tcl_precision 17
+} else {
+ set ::tcl_precision 0
+}
+
+set f1 [::math::polynomials::polynomial {1 2 3}]
+set f2 [::math::polynomials::polynomial {1 2 3 0}]
+set f3 [::math::polynomials::polynomial {0 0 0 0}]
+set f4 [::math::polynomials::polynomial {5 7}]
+set cmdf1 [::math::polynomials::polynCmd {1 2 3}]
+
+foreach x {0 1 2 3 4 5} {
+ puts "[::math::polynomials::evalPolyn $f1 $x] -- \
+[expr {1.0+2.0*$x+3.0*$x*$x}] -- \
+[$cmdf1 $x] -- [::math::polynomials::evalPolyn $f3 $x]"
+}
+
+puts "Degree: [::math::polynomials::degreePolyn $f1] (expected: 2)"
+puts "Degree: [::math::polynomials::degreePolyn $f2] (expected: 2)"
+foreach d {0 1 2} {
+ puts "Coefficient $d = [::math::polynomials::coeffPolyn $f2 $d]"
+}
+puts "All coefficients = [::math::polynomials::allCoeffsPolyn $f2]"
+
+puts "Derivative = [::math::polynomials::derivPolyn $f1]"
+puts "Primitive = [::math::polynomials::primitivePolyn $f1]"
+
+puts "Add: [::math::polynomials::addPolyn $f1 $f4]"
+puts "Add: [::math::polynomials::addPolyn $f4 $f1]"
+puts "Subtract: [::math::polynomials::subPolyn $f1 $f4]"
+puts "Multiply: [::math::polynomials::multPolyn $f1 $f4]"
+
+set f1 [::math::polynomials::polynomial {1 2 3}]
+set f2 [::math::polynomials::polynomial {0 1}]
+
+puts "Divide: [::math::polynomials::divPolyn $f1 $f2]"
+puts "Remainder: [::math::polynomials::remainderPolyn $f1 $f2]"
+
+set f1 [::math::polynomials::polynomial {1 2 3}]
+set f2 [::math::polynomials::polynomial {1 1}]
+
+puts "Divide: [::math::polynomials::divPolyn $f1 $f2]"
+puts "Remainder: [::math::polynomials::remainderPolyn $f1 $f2]"
+
+set f1 [::math::polynomials::polynomial {1 2 3}]
+set f2 [::math::polynomials::polynomial {0 1}]
+set f3 [::math::polynomials::divPolyn $f2 $f1]
+set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+puts "Coefficients: $coeffs"
+set f3 [::math::polynomials::divPolyn $f1 $f2]
+set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+puts "Coefficients: $coeffs"
+set f1 [::math::polynomials::polynomial {1 2 3}]
+set f2 [::math::polynomials::polynomial {0}]
+set f3 [::math::polynomials::divPolyn $f2 $f1]
+set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+puts "Coefficients: $coeffs"
+
+set ::tcl_precision $prec
+}
diff --git a/tcllib/modules/math/polynomials.test b/tcllib/modules/math/polynomials.test
new file mode 100755
index 0000000..7484fcb
--- /dev/null
+++ b/tcllib/modules/math/polynomials.test
@@ -0,0 +1,260 @@
+# -*- tcl -*-
+# polynomials.test --
+# Test cases for the ::math::polynomials package
+#
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.3
+testsNeedTcltest 2.1
+
+support {
+ useLocal math.tcl math
+}
+testing {
+ useLocal polynomials.tcl math::polynomials
+}
+
+# -------------------------------------------------------------------------
+
+proc matchNumbers {expected actual} {
+ set match 1
+ foreach a $actual e $expected {
+ if {abs($a-$e) > 0.1e-6} {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+
+customMatch numbers matchNumbers
+
+# -------------------------------------------------------------------------
+
+test "Polynomial-1.0" "Create polynomial (degree 3)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3 4}]
+ set result [lindex $f1 1]
+} -result {4 3 2 1}
+
+test "Polynomials-1.1" "Create polynomial (degree 3, leading zeros)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3 4 0 0 0}]
+ set result [lindex $f1 1]
+} -result {4 3 2 1}
+
+test "Polynomials-1.2" "Create polynomial (invalid coefficients)" \
+ -match glob -body {
+ set f1 [::math::polynomials::polynomial {A B C}]
+} -result "Coefficients *" -returnCodes 1
+
+test "Polynomials-1.3" "Create polynomial command" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynCmd {1 2 3 4 0 0 0}]
+ set result {}
+ foreach x {0 1 2 3} {
+ lappend result [$f1 $x]
+ }
+ set result
+} -result {1 10 49 142}
+
+test "Polynomials-1.4" "Evaluate polynomial" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3 4 0 0 0}]
+ set result {}
+ foreach x {0 1 2 3} {
+ lappend result [::math::polynomials::evalPolyn $f1 $x]
+ }
+ set result
+} -result {1 10 49 142}
+
+test "Polynomials-1.5" "Evaluate null polynomial" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {0 0 0}]
+ set result {}
+ foreach x {0 1 2 3} {
+ lappend result [::math::polynomials::evalPolyn $f1 $x]
+ }
+ set result
+} -result {0 0 0 0}
+
+test "Polynomials-2.1" "Query polynomial properties - degree" \
+ -match exact -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set result [::math::polynomials::degreePolyn $f1]
+} -result 2
+
+test "Polynomials-2.2" "Query polynomial properties - degree (2 again)" \
+ -match exact -body {
+ set f1 [::math::polynomials::polynomial {1 2 3 0 0 0}]
+ set result [::math::polynomials::degreePolyn $f1]
+} -result 2
+
+test "Polynomials-2.3" "Query polynomial properties - degree (null)" \
+ -match exact -body {
+ set f1 [::math::polynomials::polynomial {0 0 0}]
+ set result [::math::polynomials::degreePolyn $f1]
+} -result -1
+
+test "Polynomials-2.4" "Query polynomial properties - leading coeff" \
+ -match exact -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set idx [::math::polynomials::degreePolyn $f1]
+ set coeff [::math::polynomials::coeffPolyn $f1 $idx]
+} -result 3
+
+test "Polynomials-2.5" "Query polynomial properties - all coeffs" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f1]
+} -result {1 2 3}
+
+test "Polynomials-3.1" "Derivatives and primitives - derivative" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f2 [::math::polynomials::derivPolyn $f1]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f2]
+} -result {2 6}
+
+test "Polynomials-3.2" "Derivatives and primitives - primitive" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 4 9}]
+ set f2 [::math::polynomials::primitivePolyn $f1]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f2]
+} -result {0 1 2 3}
+
+test "Polynomials-4.1" "Arithmetical operations - add (1)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f2 [::math::polynomials::polynomial {1 2}]
+ set f3 [::math::polynomials::addPolyn $f1 $f2]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result {2 4 3}
+
+test "Polynomials-4.2" "Arithmetical operations - add (2)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f2 [::math::polynomials::polynomial {1 2}]
+ set f3 [::math::polynomials::addPolyn $f2 $f1]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result {2 4 3}
+
+test "Polynomials-4.3" "Arithmetical operations - subtract (1)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f2 [::math::polynomials::polynomial {1 2}]
+ set f3 [::math::polynomials::subPolyn $f1 $f2]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result {0 0 3}
+
+test "Polynomials-4.4" "Arithmetical operations - subtract (2)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f2 [::math::polynomials::polynomial {1 2}]
+ set f3 [::math::polynomials::subPolyn $f2 $f1]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result {0 0 -3}
+
+test "Polynomials-4.5" "Arithmetical operations - multiply (1)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f2 [::math::polynomials::polynomial {1 2}]
+ set f3 [::math::polynomials::multPolyn $f1 $f2]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result {1 4 7 6}
+
+test "Polynomials-4.6" "Arithmetical operations - multiply (2)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f2 [::math::polynomials::polynomial {1 2}]
+ set f3 [::math::polynomials::multPolyn $f2 $f1]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result {1 4 7 6}
+
+test "Polynomials-4.7" "Arithmetical operations - multiply (3)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f3 [::math::polynomials::multPolyn $f1 2.0]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result {2 4 6}
+
+test "Polynomials-4.8" "Arithmetical operations - multiply (4)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f3 [::math::polynomials::multPolyn 2.0 $f1]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result {2 4 6}
+
+test "Polynomials-4.9" "Arithmetical operations - divide (1)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f2 [::math::polynomials::polynomial {0 1}]
+ set f3 [::math::polynomials::divPolyn $f1 $f2]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result {2 3}
+
+test "Polynomials-4.10" "Arithmetical operations - divide (2)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f3 [::math::polynomials::divPolyn $f1 2.0]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result {0.5 1 1.5}
+
+test "Polynomials-4.11" "Arithmetical operations - divide (3)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f2 [::math::polynomials::polynomial {0 1}]
+ set f3 [::math::polynomials::divPolyn $f2 $f1]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result {}
+
+test "Polynomials-4.12" "Arithmetical operations - divide (4)" \
+ -match glob -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f2 [::math::polynomials::polynomial {0}]
+ set f3 [::math::polynomials::divPolyn $f1 $f2]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result "Denominator*" -returnCodes 1
+
+test "Polynomials-4.13" "Arithmetical operations - remainder (1)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f2 [::math::polynomials::polynomial {0 1}]
+ set f3 [::math::polynomials::remainderPolyn $f1 $f2]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result {1}
+
+test "Polynomials-4.14" "Arithmetical operations - remainder (2)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f3 [::math::polynomials::remainderPolyn $f1 2.0]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result {}
+
+test "Polynomials-4.15" "Arithmetical operations - remainder (3)" \
+ -match numbers -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f2 [::math::polynomials::polynomial {0 1}]
+ set f3 [::math::polynomials::remainderPolyn $f2 $f1]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result {0 1}
+
+test "Polynomials-4.16" "Arithmetical operations - remainder (4)" \
+ -match glob -body {
+ set f1 [::math::polynomials::polynomial {1 2 3}]
+ set f2 [::math::polynomials::polynomial {0}]
+ set f3 [::math::polynomials::remainderPolyn $f1 $f2]
+ set coeffs [::math::polynomials::allCoeffsPolyn $f3]
+} -result "Denominator*" -returnCodes 1
+
+
+
+
+
+# End of test cases
+testsuiteCleanup
diff --git a/tcllib/modules/math/qcomplex.man b/tcllib/modules/math/qcomplex.man
new file mode 100755
index 0000000..f7ce939
--- /dev/null
+++ b/tcllib/modules/math/qcomplex.man
@@ -0,0 +1,302 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin math::complexnumbers n 1.0.2]
+[keywords {complex numbers}]
+[keywords math]
+[copyright {2004 Arjen Markus <arjenmarkus@users.sourceforge.net>}]
+[moddesc {Tcl Math Library}]
+[titledesc {Straightforward complex number package}]
+[category Mathematics]
+[require Tcl 8.3]
+[require math::complexnumbers [opt 1.0.2]]
+
+[description]
+[para]
+
+The mathematical module [emph complexnumbers] provides a straightforward
+implementation of complex numbers in pure Tcl. The philosophy is that
+the user knows he or she is dealing with complex numbers in an abstract
+way and wants as high a performance as can be had within the limitations
+of an interpreted language.
+
+[para]
+
+Therefore the procedures defined in this package assume that the
+arguments are valid (representations of) "complex numbers", that is,
+lists of two numbers defining the real and imaginary part of a
+complex number (though this is a mere detail: rely on the
+[emph complex] command to construct a valid number.)
+
+[para]
+
+Most procedures implement the basic arithmetic operations or elementary
+functions whereas several others convert to and from different
+representations:
+
+[para]
+[example {
+ set z [complex 0 1]
+ puts "z = [tostring $z]"
+ puts "z**2 = [* $z $z]
+}]
+
+would result in:
+[example {
+ z = i
+ z**2 = -1
+}]
+
+[section "AVAILABLE PROCEDURES"]
+
+The package implements all or most basic operations and elementary
+functions.
+
+[para]
+
+[emph {The arithmetic operations are:}]
+
+[list_begin definitions]
+
+[call [cmd ::math::complexnumbers::+] [arg z1] [arg z2]]
+
+Add the two arguments and return the resulting complex number
+
+[list_begin arguments]
+[arg_def complex z1 in]
+First argument in the summation
+
+[arg_def complex z2 in]
+Second argument in the summation
+
+[list_end]
+[para]
+
+[call [cmd ::math::complexnumbers::-] [arg z1] [arg z2]]
+
+Subtract the second argument from the first and return the
+resulting complex number. If there is only one argument, the
+opposite of z1 is returned (i.e. -z1)
+
+[list_begin arguments]
+[arg_def complex z1 in]
+First argument in the subtraction
+
+[arg_def complex z2 in]
+Second argument in the subtraction (optional)
+
+[list_end]
+[para]
+
+[call [cmd ::math::complexnumbers::*] [arg z1] [arg z2]]
+
+Multiply the two arguments and return the resulting complex number
+
+[list_begin arguments]
+[arg_def complex z1 in]
+First argument in the multiplication
+
+[arg_def complex z2 in]
+Second argument in the multiplication
+
+[list_end]
+[para]
+
+[call [cmd ::math::complexnumbers::/] [arg z1] [arg z2]]
+
+Divide the first argument by the second and return the resulting complex
+number
+
+[list_begin arguments]
+[arg_def complex z1 in]
+First argument (numerator) in the division
+
+[arg_def complex z2 in]
+Second argument (denominator) in the division
+
+[list_end]
+[para]
+
+[call [cmd ::math::complexnumbers::conj] [arg z1]]
+
+Return the conjugate of the given complex number
+
+[list_begin arguments]
+[arg_def complex z1 in]
+Complex number in question
+
+[list_end]
+[para]
+
+[list_end]
+
+[para]
+[emph {Conversion/inquiry procedures:}]
+
+[list_begin definitions]
+
+[call [cmd ::math::complexnumbers::real] [arg z1]]
+
+Return the real part of the given complex number
+
+[list_begin arguments]
+[arg_def complex z1 in]
+Complex number in question
+
+[list_end]
+[para]
+
+[call [cmd ::math::complexnumbers::imag] [arg z1]]
+
+Return the imaginary part of the given complex number
+
+[list_begin arguments]
+[arg_def complex z1 in]
+Complex number in question
+
+[list_end]
+[para]
+
+[call [cmd ::math::complexnumbers::mod] [arg z1]]
+
+Return the modulus of the given complex number
+
+[list_begin arguments]
+[arg_def complex z1 in]
+Complex number in question
+
+[list_end]
+[para]
+
+[call [cmd ::math::complexnumbers::arg] [arg z1]]
+
+Return the argument ("angle" in radians) of the given complex number
+
+[list_begin arguments]
+[arg_def complex z1 in]
+Complex number in question
+
+[list_end]
+[para]
+
+[call [cmd ::math::complexnumbers::complex] [arg real] [arg imag]]
+
+Construct the complex number "real + imag*i" and return it
+
+[list_begin arguments]
+[arg_def float real in]
+The real part of the new complex number
+
+[arg_def float imag in]
+The imaginary part of the new complex number
+
+[list_end]
+[para]
+
+[call [cmd ::math::complexnumbers::tostring] [arg z1]]
+
+Convert the complex number to the form "real + imag*i" and return the
+string
+
+[list_begin arguments]
+[arg_def float complex in]
+The complex number to be converted
+
+[list_end]
+[para]
+
+[list_end]
+
+[para]
+[emph {Elementary functions:}]
+
+[list_begin definitions]
+
+[call [cmd ::math::complexnumbers::exp] [arg z1]]
+
+Calculate the exponential for the given complex argument and return the
+result
+
+[list_begin arguments]
+[arg_def complex z1 in]
+The complex argument for the function
+
+[list_end]
+[para]
+
+[call [cmd ::math::complexnumbers::sin] [arg z1]]
+
+Calculate the sine function for the given complex argument and return
+the result
+
+[list_begin arguments]
+[arg_def complex z1 in]
+The complex argument for the function
+
+[list_end]
+[para]
+
+[call [cmd ::math::complexnumbers::cos] [arg z1]]
+
+Calculate the cosine function for the given complex argument and return
+the result
+
+[list_begin arguments]
+[arg_def complex z1 in]
+The complex argument for the function
+
+[list_end]
+[para]
+
+[call [cmd ::math::complexnumbers::tan] [arg z1]]
+
+Calculate the tangent function for the given complex argument and
+return the result
+
+[list_begin arguments]
+[arg_def complex z1 in]
+The complex argument for the function
+
+[list_end]
+[para]
+
+[call [cmd ::math::complexnumbers::log] [arg z1]]
+
+Calculate the (principle value of the) logarithm for the given complex
+argument and return the result
+
+[list_begin arguments]
+[arg_def complex z1 in]
+The complex argument for the function
+
+[list_end]
+[para]
+
+[call [cmd ::math::complexnumbers::sqrt] [arg z1]]
+
+Calculate the (principle value of the) square root for the given complex
+argument and return the result
+
+[list_begin arguments]
+[arg_def complex z1 in]
+The complex argument for the function
+
+[list_end]
+[para]
+
+[call [cmd ::math::complexnumbers::pow] [arg z1] [arg z2]]
+
+Calculate "z1 to the power of z2" and return the result
+
+[list_begin arguments]
+[arg_def complex z1 in]
+The complex number to be raised to a power
+
+[arg_def complex z2 in]
+The complex power to be used
+
+[list_end]
+
+[list_end]
+
+[vset CATEGORY {math :: complexnumbers}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/qcomplex.tcl b/tcllib/modules/math/qcomplex.tcl
new file mode 100755
index 0000000..ac3cbf7
--- /dev/null
+++ b/tcllib/modules/math/qcomplex.tcl
@@ -0,0 +1,178 @@
+# qcomplex.tcl --
+# Small module for dealing with complex numbers
+# The design goal was to make the operations as fast
+# as possible, not to offer a nice interface. So:
+# - complex numbers are represented as lists of two elements
+# - there is hardly any error checking, all arguments are assumed
+# to be complex numbers already (with a few obvious exceptions)
+# Missing:
+# the inverse trigonometric functions and the hyperbolic functions
+#
+
+namespace eval ::math::complexnumbers {
+ namespace export + - / * conj exp sin cos tan real imag mod arg log pow sqrt tostring
+}
+
+# complex --
+# Create a new complex number
+# Arguments:
+# real The real part
+# imag The imaginary part
+# Result:
+# New complex number
+#
+proc ::math::complexnumbers::complex {real imag} {
+ return [list $real $imag]
+}
+
+# binary operations --
+# Implement the basic binary operations
+# Arguments:
+# z1 First argument
+# z2 Second argument
+# Result:
+# New complex number
+#
+proc ::math::complexnumbers::+ {z1 z2} {
+ set result {}
+ foreach c $z1 d $z2 {
+ lappend result [expr {$c+$d}]
+ }
+ return $result
+}
+proc ::math::complexnumbers::- {z1 {z2 {}}} {
+ if { $z2 == {} } {
+ set z2 $z1
+ set z1 {0.0 0.0}
+ }
+ set result {}
+ foreach c $z1 d $z2 {
+ lappend result [expr {$c-$d}]
+ }
+ return $result
+}
+proc ::math::complexnumbers::* {z1 z2} {
+ set result {}
+ foreach {c1 d1} $z1 {break}
+ foreach {c2 d2} $z2 {break}
+
+ return [list [expr {$c1*$c2-$d1*$d2}] [expr {$c1*$d2+$c2*$d1}]]
+}
+proc ::math::complexnumbers::/ {z1 z2} {
+ set result {}
+ foreach {c1 d1} $z1 {break}
+ foreach {c2 d2} $z2 {break}
+
+ set denom [expr {$c2*$c2+$d2*$d2}]
+ return [list [expr {($c1*$c2+$d1*$d2)/$denom}] \
+ [expr {(-$c1*$d2+$c2*$d1)/$denom}]]
+}
+
+# unary operations --
+# Implement the basic unary operations
+# Arguments:
+# z1 Argument
+# Result:
+# New complex number
+#
+proc ::math::complexnumbers::conj {z1} {
+ foreach {c d} $z1 {break}
+ return [list $c [expr {-$d}]]
+}
+proc ::math::complexnumbers::real {z1} {
+ foreach {c d} $z1 {break}
+ return $c
+}
+proc ::math::complexnumbers::imag {z1} {
+ foreach {c d} $z1 {break}
+ return $d
+}
+proc ::math::complexnumbers::mod {z1} {
+ foreach {c d} $z1 {break}
+ return [expr {hypot($c,$d)}]
+}
+proc ::math::complexnumbers::arg {z1} {
+ foreach {c d} $z1 {break}
+ if { $c != 0.0 || $d != 0.0 } {
+ return [expr {atan2($d,$c)}]
+ } else {
+ return 0.0
+ }
+}
+
+# elementary functions --
+# Implement the elementary functions
+# Arguments:
+# z1 Argument
+# z2 Second argument (if any)
+# Result:
+# New complex number
+#
+proc ::math::complexnumbers::exp {z1} {
+ foreach {c d} $z1 {break}
+ return [list [expr {exp($c)*cos($d)}] [expr {exp($c)*sin($d)}]]
+}
+proc ::math::complexnumbers::cos {z1} {
+ foreach {c d} $z1 {break}
+ return [list [expr {cos($c)*cosh($d)}] [expr {-sin($c)*sinh($d)}]]
+}
+proc ::math::complexnumbers::sin {z1} {
+ foreach {c d} $z1 {break}
+ return [list [expr {sin($c)*cosh($d)}] [expr {cos($c)*sinh($d)}]]
+}
+proc ::math::complexnumbers::tan {z1} {
+ return [/ [sin $z1] [cos $z1]]
+}
+proc ::math::complexnumbers::log {z1} {
+ return [list [expr {log([mod $z1])}] [arg $z1]]
+}
+proc ::math::complexnumbers::sqrt {z1} {
+ set argz [expr {0.5*[arg $z1]}]
+ set modz [expr {sqrt([mod $z1])}]
+ return [list [expr {$modz*cos($argz)}] [expr {$modz*sin($argz)}]]
+}
+proc ::math::complexnumbers::pow {z1 z2} {
+ return [exp [* [log $z1] $z2]]
+}
+# transformational functions --
+# Implement transformational functions
+# Arguments:
+# z1 Argument
+# Result:
+# String like 1+i
+#
+proc ::math::complexnumbers::tostring {z1} {
+ foreach {c d} $z1 {break}
+ if { $d == 0.0 } {
+ return "$c"
+ } else {
+ if { $c == 0.0 } {
+ if { $d == 1.0 } {
+ return "i"
+ } elseif { $d == -1.0 } {
+ return "-i"
+ } else {
+ return "${d}i"
+ }
+ } else {
+ if { $d > 0.0 } {
+ if { $d == 1.0 } {
+ return "$c+i"
+ } else {
+ return "$c+${d}i"
+ }
+ } else {
+ if { $d == -1.0 } {
+ return "$c-i"
+ } else {
+ return "$c${d}i"
+ }
+ }
+ }
+ }
+}
+
+#
+# Announce our presence
+#
+package provide math::complexnumbers 1.0.2
diff --git a/tcllib/modules/math/qcomplex.test b/tcllib/modules/math/qcomplex.test
new file mode 100755
index 0000000..394c44f
--- /dev/null
+++ b/tcllib/modules/math/qcomplex.test
@@ -0,0 +1,250 @@
+# -*- tcl -*-
+# Tests for complex number functions in math library -*- tcl -*-
+#
+# This file contains a collection of tests for one or more of the Tcllib
+# procedures. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# $Id: qcomplex.test,v 1.10 2006/10/09 21:41:41 andreas_kupries Exp $
+#
+# Copyright (c) 2004 by Arjen Markus
+# All rights reserved.
+#
+# Note:
+# By evaluating the tests in a different namespace than global,
+# we assure that the namespace issue (Bug #...) is checked.
+#
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 2.1
+
+support {
+ useLocal math.tcl math
+}
+testing {
+ useLocal qcomplex.tcl math::complexnumbers
+}
+
+# -------------------------------------------------------------------------
+
+namespace import -force ::math::complexnumbers::*
+
+proc matchNumbers { expected actual } {
+ set match 1
+ foreach a $actual e $expected {
+ if { abs($a-$e) > 1.0e-10 } {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+
+customMatch numbers matchNumbers
+
+# -------------------------------------------------------------------------
+
+#
+# Test cases: arithmetical operations
+#
+test "Complex-1.1" "Arithmetic - add 1" -match numbers -body {
+ set a [complex 1 0]
+ set b [complex 0 1]
+ set c [+ $a $b]
+} -result [complex 1 1]
+
+test "Complex-1.2" "Arithmetic - add 2" -match numbers -body {
+ set a [complex 1.1 -1.1]
+ set b [complex 1.1 1.1]
+ set c [+ $a $b]
+} -result [complex 2.2 0]
+
+test "Complex-1.3" "Arithmetic - subtract 1" -match numbers -body {
+ set a [complex 1 0]
+ set b [complex 0 1]
+ set c [- $a $b]
+} -result [complex 1 -1]
+
+test "Complex-1.4" "Arithmetic - subtract 2" -match numbers -body {
+ set a [complex 1.1 -1.1]
+ set b [complex 1.1 1.1]
+ set c [- $a $b]
+} -result [complex 0 -2.2]
+
+test "Complex-1.5" "Arithmetic - multiply 1" -match numbers -body {
+ set a [complex 1 -1]
+ set b [complex 0 1]
+ set c [* $a $b]
+} -result [complex 1 1]
+
+test "Complex-1.6" "Arithmetic - multiply 2" -match numbers -body {
+ set a [complex 0 1]
+ set b [complex 0 1]
+ set c [* $a $b]
+} -result [complex -1 0]
+
+test "Complex-1.7" "Arithmetic - divide 1" -match numbers -body {
+ set a [complex 1.1 1]
+ set b [complex 1.1 1]
+ set c [/ $a $b]
+} -result [complex 1 0]
+
+test "Complex-1.8" "Arithmetic - divide 2" -match numbers -body {
+ set a [complex 1 1]
+ set b [complex 0 1]
+ set c [/ $a $b]
+} -result [complex 1 -1]
+
+test "Complex-1.9" "Arithmetic - conjugate 1" -match numbers -body {
+ set a [complex 0 1]
+ set c [conj $a]
+} -result [complex 0 -1]
+
+test "Complex-1.10" "Arithmetic - conjugate 2" -match numbers -body {
+ set a [complex 1 0]
+ set c [conj $a]
+} -result [complex 1 0]
+
+test "Complex-2.1" "Conversion - real 1" -match numbers -body {
+ set a [complex 1 2]
+ set c [real $a]
+} -result 1
+
+test "Complex-2.2" "Conversion - real 2" -match numbers -body {
+ set a [complex 0 2]
+ set c [real $a]
+} -result 0
+
+test "Complex-2.3" "Conversion - imag 1" -match numbers -body {
+ set a [complex 1 2]
+ set c [imag $a]
+} -result 2
+
+test "Complex-2.4" "Conversion - imag 2" -match numbers -body {
+ set a [complex 0 2]
+ set c [imag $a]
+} -result 2
+
+test "Complex-2.5" "Conversion - mod 1" -match numbers -body {
+ set a [complex 0 1]
+ set c [mod $a]
+} -result 1
+
+test "Complex-2.6" "Conversion - mod 2" -match numbers -body {
+ set a [complex 3 4]
+ set c [mod $a]
+} -result 5
+
+test "Complex-2.7" "Conversion - arg 1" -match numbers -body {
+ set a [complex 0 1]
+ set c [arg $a]
+} -result [expr {2.0*atan(1.0)}]
+
+test "Complex-2.8" "Conversion - arg 2" -match numbers -body {
+ set a [complex 1 1]
+ set c [arg $a]
+} -result [expr {atan(1.0)}]
+
+test "Complex-2.9" "Conversion - tostring" -body {
+ set c "[tostring [complex 1 0]] "
+ append c "[tostring [complex 0 1]] "
+ append c "[tostring [complex 1 1]] "
+ append c "[tostring [complex 1 -1]] "
+ append c "[tostring [complex 0 -1]] "
+ append c "[tostring [complex 2 -3]] "
+} -result "1 i 1+i 1-i -i 2-3i "
+
+test "Complex-3.1" "Elementary - exp 1" -match numbers -body {
+ set a [complex 1 0]
+ set c [exp $a]
+} -result [complex [expr {exp(1.0)}] 0.0]
+
+test "Complex-3.2" "Elementary - exp 2" -match numbers -body {
+ set a [complex 0 1]
+ set c [exp $a]
+} -result [complex [expr {cos(1.0)}] [expr {sin(1.0)}]]
+
+test "Complex-3.3" "Elementary - sin 1" -match numbers -body {
+ set a [complex 1 0]
+ set c [sin $a]
+} -result [complex [expr {sin(1.0)}] 0.0]
+
+test "Complex-3.4" "Elementary - sin 2" -match numbers -body {
+ set a [complex 0 1]
+ set c [sin $a]
+ #
+ # Calculate from the (complex) definition
+ #
+ set d1 [exp [complex -1 0]]
+ set d2 [exp [complex 1 0]]
+ set e [/ [- $d1 $d2] [complex 0 2]]
+ set diff [- $c $e]
+} -result [complex 0 0]
+
+test "Complex-3.5" "Elementary - cos 1" -match numbers -body {
+ set a [complex 1 0]
+ set c [cos $a]
+} -result [complex [expr {cos(1.0)}] 0.0]
+
+test "Complex-3.6" "Elementary - cos 2" -match numbers -body {
+ set a [complex 0 1]
+ set c [cos $a]
+ set d1 [exp [complex -1 0]]
+ set d2 [exp [complex 1 0]]
+ set e [/ [+ $d1 $d2] [complex 2 0]]
+ set diff [- $c $e]
+} -result [complex 0 0]
+
+test "Complex-3.7" "Elementary - tan 1" -match numbers -body {
+ set a [complex 1 0]
+ set c [tan $a]
+} -result [complex [expr {tan(1.0)}] 0]
+
+test "Complex-3.8" "Elementary - tan 2" -match numbers -body {
+ set a [complex 0 1]
+ set c [tan $a]
+ set d1 [sin $a]
+ set d2 [cos $a]
+ set e [/ $d1 $d2]
+ set diff [- $c $e]
+} -result [complex 0 0]
+
+test "Complex-3.9" "Elementary - log 1" -match numbers -body {
+ set a [complex 1 0]
+ set c [log $a]
+} -result [complex 0 0]
+
+test "Complex-3.10" "Elementary - log 2" -match numbers -body {
+ set a [complex 0 1]
+ set c [log $a]
+} -result [complex 0 [expr {2.0*atan(1.0)}]]
+
+test "Complex-3.11" "Elementary - sqrt 1" -match numbers -body {
+ set a [complex -1 0]
+ set c [sqrt $a]
+} -result [complex 0 1]
+
+test "Complex-3.12" "Elementary - sqrt 2" -match numbers -body {
+ set a [complex 0 4]
+ set c [sqrt $a]
+} -result [complex [expr {sqrt(2)}] [expr {sqrt(2)}]]
+
+test "Complex-3.13" "Elementary - pow 1" -match numbers -body {
+ set a [complex -1 0]
+ set b [complex 0.5 0]
+ set c [pow $a $b]
+} -result [complex 0 1]
+
+test "Complex-3.14" "Elementary - pow 2" -match numbers -body {
+ set a [complex [expr {exp(1.0)}] 0]
+ set b [complex 0 [expr {4.0*atan(1.0)}]]
+ set c [pow $a $b]
+} -result [complex -1 0]
+
+testsuiteCleanup
diff --git a/tcllib/modules/math/rational_funcs.man b/tcllib/modules/math/rational_funcs.man
new file mode 100755
index 0000000..d647709
--- /dev/null
+++ b/tcllib/modules/math/rational_funcs.man
@@ -0,0 +1,186 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin math::rationalfunctions n 1.0.1]
+[keywords math]
+[keywords {rational functions}]
+[copyright {2005 Arjen Markus <arjenmarkus@users.sourceforge.net>}]
+[moddesc {Math}]
+[titledesc {Polynomial functions}]
+[category Mathematics]
+[require Tcl [opt 8.4]]
+[require math::rationalfunctions [opt 1.0.1]]
+
+[description]
+[para]
+This package deals with rational functions of one variable:
+
+[list_begin itemized]
+[item]
+the basic arithmetic operations are extended to rational functions
+[item]
+computing the derivatives of these functions
+[item]
+evaluation through a general procedure or via specific procedures)
+[list_end]
+
+[section "PROCEDURES"]
+
+The package defines the following public procedures:
+
+[list_begin definitions]
+
+[call [cmd ::math::rationalfunctions::rationalFunction] [arg num] [arg den]]
+
+Return an (encoded) list that defines the rational function. A
+rational function
+[example {
+ 1 + x^3
+ f(x) = ------------
+ 1 + 2x + x^2
+}]
+can be defined via:
+[example {
+ set f [::math::rationalfunctions::rationalFunction [list 1 0 0 1] \
+ [list 1 2 1]]
+}]
+
+[list_begin arguments]
+[arg_def list num] Coefficients of the numerator of the rational
+function (in ascending order)
+[para]
+[arg_def list den] Coefficients of the denominator of the rational
+function (in ascending order)
+[list_end]
+
+[para]
+
+[call [cmd ::math::rationalfunctions::ratioCmd] [arg num] [arg den]]
+
+Create a new procedure that evaluates the rational function. The name of the
+function is automatically generated. Useful if you need to evaluate
+the function many times, as the procedure consists of a single
+[lb]expr[rb] command.
+
+[list_begin arguments]
+[arg_def list num] Coefficients of the numerator of the rational
+function (in ascending order)
+[para]
+[arg_def list den] Coefficients of the denominator of the rational
+function (in ascending order)
+[list_end]
+
+[para]
+
+[call [cmd ::math::rationalfunctions::evalRatio] [arg rational] [arg x]]
+
+Evaluate the rational function at x.
+
+[list_begin arguments]
+[arg_def list rational] The rational function's definition (as returned
+by the rationalFunction command).
+order)
+
+[arg_def float x] The coordinate at which to evaluate the function
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::rationalfunctions::addRatio] [arg ratio1] [arg ratio2]]
+
+Return a new rational function which is the sum of the two others.
+
+[list_begin arguments]
+[arg_def list ratio1] The first rational function operand
+
+[arg_def list ratio2] The second rational function operand
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::rationalfunctions::subRatio] [arg ratio1] [arg ratio2]]
+
+Return a new rational function which is the difference of the two
+others.
+
+[list_begin arguments]
+[arg_def list ratio1] The first rational function operand
+
+[arg_def list ratio2] The second rational function operand
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::rationalfunctions::multRatio] [arg ratio1] [arg ratio2]]
+
+Return a new rational function which is the product of the two others.
+If one of the arguments is a scalar value, the other rational function is
+simply scaled.
+
+[list_begin arguments]
+[arg_def list ratio1] The first rational function operand or a scalar
+
+[arg_def list ratio2] The second rational function operand or a scalar
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::rationalfunctions::divRatio] [arg ratio1] [arg ratio2]]
+
+Divide the first rational function by the second rational function and
+return the result. The remainder is dropped
+
+[list_begin arguments]
+[arg_def list ratio1] The first rational function operand
+
+[arg_def list ratio2] The second rational function operand
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::rationalfunctions::derivPolyn] [arg ratio]]
+
+Differentiate the rational function and return the result.
+
+[list_begin arguments]
+[arg_def list ratio] The rational function to be differentiated
+
+[list_end]
+
+[para]
+
+[call [cmd ::math::rationalfunctions::coeffsNumerator] [arg ratio]]
+
+Return the coefficients of the numerator of the rational function.
+
+[list_begin arguments]
+[arg_def list ratio] The rational function to be examined
+[list_end]
+
+[para]
+
+[call [cmd ::math::rationalfunctions::coeffsDenominator] [arg ratio]]
+
+Return the coefficients of the denominator of the rational
+function.
+
+[list_begin arguments]
+[arg_def list ratio] The rational function to be examined
+[list_end]
+
+[para]
+
+[list_end]
+
+[section "REMARKS ON THE IMPLEMENTATION"]
+
+The implementation of the rational functions relies on the
+math::polynomials package. For further remarks see the documentation on
+that package.
+
+[vset CATEGORY {math :: rationalfunctions}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/rational_funcs.tcl b/tcllib/modules/math/rational_funcs.tcl
new file mode 100755
index 0000000..2dae397
--- /dev/null
+++ b/tcllib/modules/math/rational_funcs.tcl
@@ -0,0 +1,364 @@
+# rational_funcs.tcl --
+# Implement procedures to deal with rational functions
+#
+
+package require math::polynomials
+
+namespace eval ::math::rationalfunctions {
+ variable count 0 ;# Count the number of specific commands
+ namespace eval v {}
+
+ namespace export rationalFunction ratioCmd evalRatio \
+ coeffsNumerator coeffsDenominator \
+ derivRatio \
+ addRatio subRatio multRatio \
+ divRatio
+
+ namespace import ::math::polynomials::*
+}
+
+
+# rationalFunction --
+# Return a rational function definition
+#
+# Arguments:
+# num The coefficients of the numerator
+# den The coefficients of the denominator
+# Result:
+# Rational function definition
+#
+proc ::math::rationalfunctions::rationalFunction {num den} {
+
+ foreach coeffs [list $num $den] {
+ foreach coeff $coeffs {
+ if { ! [string is double -strict $coeff] } {
+ return -code error "Coefficients must be real numbers"
+ }
+ }
+ }
+
+ #
+ # The leading coefficient must be non-zero
+ #
+ return [list RATIONAL_FUNCTION [polynomial $num] [polynomial $den]]
+}
+
+# ratioCmd --
+# Return a procedure that implements a rational function evaluation
+#
+# Arguments:
+# num The coefficients of the numerator
+# den The coefficients of the denominator
+# Result:
+# New procedure
+#
+proc ::math::rationalfunctions::ratioCmd {num {den {}}} {
+ variable count
+
+ if { [llength $den] == 0 } {
+ if { [lindex $num 0] == "RATIONAL_FUNCTION" } {
+ set den [lindex $num 2]
+ set num [lindex $num 1]
+ }
+ }
+
+ set degree1 [expr {[llength $num]-1}]
+ set degree2 [expr {[llength $num]-1}]
+ set body "expr \{([join $num +\$x*(][string repeat ) $degree1])/\
+(double([join $den +\$x*(][string repeat ) $degree2])\}"
+
+ incr count
+ set name "::math::rationalfunctions::v::RATIO$count"
+ proc $name {x} $body
+ return $name
+}
+
+# evalRatio --
+# Evaluate a rational function at a given coordinate
+#
+# Arguments:
+# ratio Rational function definition
+# x Coordinate
+# Result:
+# Value at x
+#
+proc ::math::rationalfunctions::evalRatio {ratio x} {
+ if { [lindex $ratio 0] != "RATIONAL_FUNCTION" } {
+ return -code error "Not a rational function"
+ }
+ if { ! [string is double $x] } {
+ return -code error "Coordinate must be a real number"
+ }
+
+ set num 0.0
+ foreach c [lindex [lindex $ratio 1] 1] {
+ set num [expr {$num*$x+$c}]
+ }
+
+ set den 0.0
+ foreach c [lindex [lindex $ratio 2] 1] {
+ set den [expr {$den*$x+$c}]
+ }
+ return [expr {$num/double($den)}]
+}
+
+# coeffsNumerator --
+# Return the coefficients of the numerator
+#
+# Arguments:
+# ratio Rational function definition
+# Result:
+# The coefficients in ascending order
+#
+proc ::math::rationalfunctions::coeffsNumerator {ratio} {
+ if { [lindex $ratio 0] != "RATIONAL_FUNCTION" } {
+ return -code error "Not a rational function"
+ }
+ set polyn [lindex $ratio 1]
+ return [allCoeffsPolyn $polyn]
+}
+
+# coeffsDenominator --
+# Return the coefficients of the denominator
+#
+# Arguments:
+# ratio Rational function definition
+# Result:
+# The coefficients in ascending order
+#
+proc ::math::rationalfunctions::coeffsDenominator {ratio} {
+ if { [lindex $ratio 0] != "RATIONAL_FUNCTION" } {
+ return -code error "Not a rational function"
+ }
+ set polyn [lindex $ratio 2]
+ return [allCoeffsPolyn $polyn]
+}
+
+# derivRatio --
+# Return the derivative of the rational function
+#
+# Arguments:
+# polyn Polynomial definition
+# Result:
+# The new polynomial
+#
+proc ::math::rationalfunctions::derivRatio {ratio} {
+ if { [lindex $ratio 0] != "RATIONAL_FUNCTION" } {
+ return -code error "Not a rational function"
+ }
+ set num_polyn [lindex $ratio 1]
+ set den_polyn [lindex $ratio 2]
+ set num_deriv [derivPolyn $num_polyn]
+ set den_deriv [derivPolyn $den_polyn]
+ set num [subPolyn [multPolyn $num_deriv $den_polyn] \
+ [multPolyn $den_deriv $num_polyn] ]
+ set den [multPolyn $den_polyn $den_polyn]
+
+ return [list RATIONAL_FUNCTION $num $den]
+}
+
+# addRatio --
+# Add two rational functions and return the result
+#
+# Arguments:
+# ratio1 First rational function or a scalar
+# ratio2 Second rational function or a scalar
+# Result:
+# The sum of the two functions
+# Note:
+# TODO: Check for the same denominator
+#
+proc ::math::rationalfunctions::addRatio {ratio1 ratio2} {
+ if { [llength $ratio1] == 1 && [string is double -strict $ratio1] } {
+ set polyn1 [rationalFunction $ratio1 1.0]
+ }
+ if { [llength $ratio2] == 1 && [string is double -strict $ratio2] } {
+ set ratio2 [rationalFunction $ratio1 1.0]
+ }
+ if { [lindex $ratio1 0] != "RATIONAL_FUNCTION" ||
+ [lindex $ratio2 0] != "RATIONAL_FUNCTION" } {
+ return -code error "Both arguments must be rational functions or a real number"
+ }
+
+ set num1 [lindex $ratio1 1]
+ set den1 [lindex $ratio1 2]
+ set num2 [lindex $ratio2 1]
+ set den2 [lindex $ratio2 2]
+
+ set newnum [addPolyn [multPolyn $num1 $den2] \
+ [multPolyn $num2 $den1] ]
+
+ set newden [multPolyn $den1 $den2]
+
+ return [list RATIONAL_FUNCTION $newnum $newden]
+}
+
+# subRatio --
+# Subtract two rational functions and return the result
+#
+# Arguments:
+# ratio1 First rational function or a scalar
+# ratio2 Second rational function or a scalar
+# Result:
+# The difference of the two functions
+# Note:
+# TODO: Check for the same denominator
+#
+proc ::math::rationalfunctions::subRatio {ratio1 ratio2} {
+ if { [llength $ratio1] == 1 && [string is double -strict $ratio1] } {
+ set polyn1 [rationalFunction $ratio1 1.0]
+ }
+ if { [llength $ratio2] == 1 && [string is double -strict $ratio2] } {
+ set ratio2 [rationalFunction $ratio1 1.0]
+ }
+ if { [lindex $ratio1 0] != "RATIONAL_FUNCTION" ||
+ [lindex $ratio2 0] != "RATIONAL_FUNCTION" } {
+ return -code error "Both arguments must be rational functions or a real number"
+ }
+
+ set num1 [lindex $ratio1 1]
+ set den1 [lindex $ratio1 2]
+ set num2 [lindex $ratio2 1]
+ set den2 [lindex $ratio2 2]
+
+ set newnum [subPolyn [multPolyn $num1 $den2] \
+ [multPolyn $num2 $den1] ]
+
+ set newden [multPolyn $den1 $den2]
+
+ return [list RATIONAL_FUNCTION $newnum $newden]
+}
+
+# multRatio --
+# Multiply two rational functions and return the result
+#
+# Arguments:
+# ratio1 First rational function or a scalar
+# ratio2 Second rational function or a scalar
+# Result:
+# The product of the two functions
+# Note:
+# TODO: Check for the same denominator
+#
+proc ::math::rationalfunctions::multRatio {ratio1 ratio2} {
+ if { [llength $ratio1] == 1 && [string is double -strict $ratio1] } {
+ set polyn1 [rationalFunction $ratio1 1.0]
+ }
+ if { [llength $ratio2] == 1 && [string is double -strict $ratio2] } {
+ set ratio2 [rationalFunction $ratio1 1.0]
+ }
+ if { [lindex $ratio1 0] != "RATIONAL_FUNCTION" ||
+ [lindex $ratio2 0] != "RATIONAL_FUNCTION" } {
+ return -code error "Both arguments must be rational functions or a real number"
+ }
+
+ set num1 [lindex $ratio1 1]
+ set den1 [lindex $ratio1 2]
+ set num2 [lindex $ratio2 1]
+ set den2 [lindex $ratio2 2]
+
+ set newnum [multPolyn $num1 $num2]
+ set newden [multPolyn $den1 $den2]
+
+ return [list RATIONAL_FUNCTION $newnum $newden]
+}
+
+# divRatio --
+# Divide two rational functions and return the result
+#
+# Arguments:
+# ratio1 First rational function or a scalar
+# ratio2 Second rational function or a scalar
+# Result:
+# The quotient of the two functions
+# Note:
+# TODO: Check for the same denominator
+#
+proc ::math::rationalfunctions::divRatio {ratio1 ratio2} {
+ if { [llength $ratio1] == 1 && [string is double -strict $ratio1] } {
+ set polyn1 [rationalFunction $ratio1 1.0]
+ }
+ if { [llength $ratio2] == 1 && [string is double -strict $ratio2] } {
+ set ratio2 [rationalFunction $ratio1 1.0]
+ }
+ if { [lindex $ratio1 0] != "RATIONAL_FUNCTION" ||
+ [lindex $ratio2 0] != "RATIONAL_FUNCTION" } {
+ return -code error "Both arguments must be rational functions or a real number"
+ }
+
+ set num1 [lindex $ratio1 1]
+ set den1 [lindex $ratio1 2]
+ set num2 [lindex $ratio2 1]
+ set den2 [lindex $ratio2 2]
+
+ set newnum [multPolyn $num1 $den2]
+ set newden [multPolyn $num2 $den1]
+
+ return [list RATIONAL_FUNCTION $newnum $newden]
+}
+
+#
+# Announce our presence
+#
+package provide math::rationalfunctions 1.0.1
+
+# some tests --
+#
+if { 0 } {
+set prec $::tcl_precision
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ set ::tcl_precision 17
+} else {
+ set ::tcl_precision 0
+}
+
+
+set f1 [::math::rationalfunctions::rationalFunction {1 2 3} {1 4}]
+set f2 [::math::rationalfunctions::rationalFunction {1 2 3 0} {1 4}]
+set f3 [::math::rationalfunctions::rationalFunction {0 0 0 0} {1}]
+set f4 [::math::rationalfunctions::rationalFunction {5 7} {1}]
+set cmdf1 [::math::rationalfunctions::ratioCmd {1 2 3} {1 4}]
+
+foreach x {0 1 2 3 4 5} {
+ puts "[::math::rationalfunctions::evalRatio $f1 $x] -- \
+[expr {(1.0+2.0*$x+3.0*$x*$x)/double(1.0+4.0*$x)}] -- \
+[$cmdf1 $x] -- [::math::rationalfunctions::evalRatio $f3 $x]"
+}
+
+puts "All coefficients = [::math::rationalfunctions::coeffsNumerator $f2]"
+puts " [::math::rationalfunctions::coeffsDenominator $f2]"
+
+puts "Derivative = [::math::rationalfunctions::derivRatio $f1]"
+
+puts "Add: [::math::rationalfunctions::addRatio $f1 $f4]"
+puts "Add: [::math::rationalfunctions::addRatio $f4 $f1]"
+puts "Subtract: [::math::rationalfunctions::subRatio $f1 $f4]"
+puts "Multiply: [::math::rationalfunctions::multRatio $f1 $f4]"
+
+set f1 [::math::rationalfunctions::rationalFunction {1 2 3} 1]
+set f2 [::math::rationalfunctions::rationalFunction {0 1} 1]
+
+puts "Divide: [::math::rationalfunctions::divRatio $f1 $f2]"
+
+set f1 [::math::rationalfunctions::rationalFunction {1 2 3} 1]
+set f2 [::math::rationalfunctions::rationalFunction {1 1} {1 2}]
+
+puts "Divide: [::math::rationalfunctions::divRatio $f1 $f2]"
+
+set f1 [::math::rationalfunctions::rationalFunction {1 2 3} 1]
+set f2 [::math::rationalfunctions::rationalFunction {0 1} {0 0 1}]
+set f3 [::math::rationalfunctions::divRatio $f2 $f1]
+set coeffs [::math::rationalfunctions::coeffsNumerator $f3]
+puts "Coefficients: $coeffs"
+set f3 [::math::rationalfunctions::divRatio $f1 $f2]
+set coeffs [::math::rationalfunctions::coeffsNumerator $f3]
+puts "Coefficients: $coeffs"
+set f1 [::math::rationalfunctions::rationalFunction {1 2 3} {1 2}]
+set f2 [::math::rationalfunctions::rationalFunction {0} {1}]
+set f3 [::math::rationalfunctions::divRatio $f2 $f1]
+set coeffs [::math::rationalfunctions::coeffsNumerator $f3]
+puts "Coefficients: $coeffs"
+puts "Eval null function: [::math::rationalfunctions::evalRatio $f2 1]"
+
+set ::tcl_precision $prec
+}
diff --git a/tcllib/modules/math/roman.man b/tcllib/modules/math/roman.man
new file mode 100755
index 0000000..e8c6dc3
--- /dev/null
+++ b/tcllib/modules/math/roman.man
@@ -0,0 +1,51 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin math::roman "" 1.0]
+[keywords conversion]
+[keywords integer]
+[keywords {roman numeral}]
+[copyright {2005 Kenneth Green <kenneth.green@gmail.com>}]
+[moddesc {Tcl Math Library}]
+[titledesc {Tools for creating and manipulating roman numerals}]
+[category Mathematics]
+[require Tcl 8.3]
+[require math::roman [opt 1.0]]
+[description]
+ [para]
+ [cmd ::math::roman] is a pure-Tcl library for converting between integers
+ and roman numerals. It also provides utility functions for sorting and performing
+ arithmetic on roman numerals.
+ [para]
+ This code was originally harvested from the Tcler's wiki at
+ http://wiki.tcl.tk/1823 and as such is free for any use for
+ any purpose. Many thanks to the ingeneous folk who devised
+ these clever routines and generously contributed them to the
+ Tcl community.
+ [para]
+ While written and tested under Tcl 8.3, I expect this library
+ will work under all 8.x versions of Tcl.
+
+[section {COMMANDS}]
+ [list_begin definitions]
+
+ [call [cmd ::math::roman::toroman] [arg i]]
+ Convert an integer to roman numerals. The result is always in
+ upper case. The value zero is converted to an empty string.
+
+ [call [cmd ::math::roman::tointeger] [arg r]]
+ Convert a roman numeral into an integer.
+
+ [call [cmd ::math::roman::sort] [arg list]]
+ Sort a list of roman numerals from smallest to largest.
+
+ [call [cmd ::math::roman::expr] [arg args]]
+ Evaluate an expression where the operands are all roman numerals.
+
+ [list_end]
+
+Of these commands both [emph toroman] and [emph tointeger] are exported
+for easier use. The other two are not, as they could interfer or be
+confused with existing Tcl commands.
+
+[vset CATEGORY {math :: roman}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/roman.test b/tcllib/modules/math/roman.test
new file mode 100755
index 0000000..2fd3459
--- /dev/null
+++ b/tcllib/modules/math/roman.test
@@ -0,0 +1,223 @@
+# -*- tcl -*-
+#---------------------------------------------------------------------
+# TITLE:
+# romannumeral
+#
+# AUTHOR:
+# Kenneth Green, 28 Sep 2005
+#
+# DESCRIPTION:
+# tcltest test cases for romannumeral.tcl
+
+# Note:
+# Assumes Tcl 8.3
+# The tests assume tcltest 2.2
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.3
+testsNeedTcltest 2.2
+
+support {
+ useLocal math.tcl math
+}
+testing {
+ useLocal romannumerals.tcl math::roman
+}
+
+#=====================================================================
+# S u p p o r t F u n c t i o n s
+#=====================================================================
+
+#---------------------------------------------------------------------
+# cleanup --
+#
+# cleanup before each test
+#---------------------------------------------------------------------
+
+proc cleanup {} {
+ global errorInfo
+
+}
+
+#=====================================================================
+# I n i t i a l i s a t i o n
+#=====================================================================
+
+::tcltest::testConstraint tk [info exists tk_version]
+
+#=====================================================================
+# T e s t C a s e s
+#=====================================================================
+
+#-----------------------------------------------------------------------
+# toroman
+
+test ToRoman-1.1 {good input} -constraints {
+} -setup {
+ cleanup
+} -body {
+ list [catch { list \
+ [::math::roman::toroman 0] \
+ [::math::roman::toroman 1] \
+ [::math::roman::toroman 2] \
+ [::math::roman::toroman 3] \
+ [::math::roman::toroman 4] \
+ [::math::roman::toroman 5] \
+ [::math::roman::toroman 6] \
+ [::math::roman::toroman 7] \
+ [::math::roman::toroman 8] \
+ [::math::roman::toroman 9] \
+ [::math::roman::toroman 10] \
+ [::math::roman::toroman 13] \
+ [::math::roman::toroman 100] \
+ [::math::roman::toroman 250] \
+ [::math::roman::toroman 333] \
+ [::math::roman::toroman 1001] \
+ [::math::roman::toroman 1963] \
+ } errMsg] [set errMsg]
+} -cleanup {
+ cleanup
+} -result {0 {{} I II III IV V VI VII VIII IX X XIII C CCL CCCXXXIII MI MCMLXIII}}
+
+#-----------------------------------------------------------------------
+# tointeger
+
+test ToInteger-2.1 {good input} -constraints {
+} -setup {
+ cleanup
+} -body {
+ list [catch { list \
+ [::math::roman::tointeger ""] \
+ [::math::roman::tointeger I] \
+ [::math::roman::tointeger ii] \
+ [::math::roman::tointeger IiI] \
+ [::math::roman::tointeger iv] \
+ [::math::roman::tointeger V] \
+ [::math::roman::tointeger vI] \
+ [::math::roman::tointeger vIi] \
+ [::math::roman::tointeger ViiI] \
+ [::math::roman::tointeger ix] \
+ [::math::roman::tointeger X] \
+ [::math::roman::tointeger XiII] \
+ [::math::roman::tointeger C] \
+ [::math::roman::tointeger CCD] \
+ [::math::roman::tointeger CCCXXXIII] \
+ [::math::roman::tointeger MI] \
+ [::math::roman::tointeger MCMXXXVI] \
+ } errMsg] [set errMsg]
+} -cleanup {
+ cleanup
+} -result {0 {0 1 2 3 4 5 6 7 8 9 10 13 100 500 333 1001 1936}}
+
+#-----------------------------------------------------------------------
+# combined
+
+test Combined-3.1 {good input} -constraints {
+} -setup {
+ cleanup
+} -body {
+ list [catch {
+ for { set i 0 } { $i < 11666 } { incr i } {
+ set r [::math::roman::toroman $i]
+ set j [::math::roman::tointeger $r]
+ if { $i != $j } {
+ error "Mismatch i ($i) -> r ($r) -> j ($j)"
+ }
+ }
+ } errMsg] [set errMsg]
+} -cleanup {
+ cleanup
+} -result {0 {}}
+
+#-----------------------------------------------------------------------
+# sort
+
+test Sort-4.1 {good input} -constraints {
+} -setup {
+ cleanup
+} -body {
+ list [catch {
+ set l {X III IV I V}
+ ::math::roman::sort $l \
+ } errMsg] [set errMsg]
+} -cleanup {
+ cleanup
+} -result {0 {I III IV V X}}
+
+#-----------------------------------------------------------------------
+# expr
+
+test Expr-5.1 {plus} -constraints {
+} -setup {
+ cleanup
+} -body {
+ list [catch {
+ set x 23
+ set xr [::math::roman::toroman $x]
+ set y 77
+ set yr [::math::roman::toroman $y]
+ set xr+yr [::math::roman::expr $xr + $yr]
+ expr [::math::roman::tointeger ${xr+yr}] == [expr $x + $y]
+ } errMsg] [set errMsg]
+} -cleanup {
+ cleanup
+} -result {0 1}
+
+test Expr-5.2 {minus} -constraints {
+} -setup {
+ cleanup
+} -body {
+ list [catch {
+ set x 23
+ set xr [::math::roman::toroman $x]
+ set y 77
+ set yr [::math::roman::toroman $y]
+ set yr-xr [::math::roman::expr $yr - $xr]
+ expr [::math::roman::tointeger ${yr-xr}] == [expr $y - $x]
+ } errMsg] [set errMsg]
+} -cleanup {
+ cleanup
+} -result {0 1}
+
+test Expr-5.3 {times} -constraints {
+} -setup {
+ cleanup
+} -body {
+ list [catch {
+ set x 23
+ set xr [::math::roman::toroman $x]
+ set y 77
+ set yr [::math::roman::toroman $y]
+ set xr*yr [::math::roman::expr $xr * $yr]
+ expr $x * $y
+ expr [::math::roman::tointeger ${xr*yr}] == [expr $x * $y]
+ } errMsg] [set errMsg]
+} -cleanup {
+ cleanup
+} -result {0 1}
+
+test Expr-5.4 {divide} -constraints {
+} -setup {
+ cleanup
+} -body {
+ list [catch {
+ set x 23
+ set xr [::math::roman::toroman $x]
+ set y 77
+ set yr [::math::roman::toroman $y]
+ set yr/xr [::math::roman::expr $yr / $xr]
+ expr [::math::roman::tointeger ${yr/xr}] == [expr $y / $x]
+ } errMsg] [set errMsg]
+} -cleanup {
+ cleanup
+} -result {0 1}
+
+#---------------------------------------------------------------------
+# Clean up
+cleanup
+testsuiteCleanup
diff --git a/tcllib/modules/math/romannumerals.tcl b/tcllib/modules/math/romannumerals.tcl
new file mode 100755
index 0000000..a67d259
--- /dev/null
+++ b/tcllib/modules/math/romannumerals.tcl
@@ -0,0 +1,164 @@
+#==========================================================================
+# Roman Numeral Utility Functions
+#==========================================================================
+# Description
+#
+# A set of utility routines for handling and manipulating
+# roman numerals.
+#-------------------------------------------------------------------------
+# Copyright/License
+#
+# This code was originally harvested from the Tcler's
+# wiki at http://wiki.tcl.tk/1823 and as such is free
+# for any use for any purpose.
+#-------------------------------------------------------------------------
+# Modification history
+#
+# 27 Sep 2005 Kenneth Green
+# Original version derived from wiki code
+#-------------------------------------------------------------------------
+
+package provide math::roman 1.0
+
+#==========================================================================
+# Namespace
+#==========================================================================
+namespace eval ::math::roman {
+ namespace export tointeger toroman
+
+ # We dont export 'sort' or 'expr' to prevent collision
+ # with existing commands. These functions are less likely to be
+ # commonly used and have to be accessed as fully-scoped names.
+
+ # romanvalues - array that maps roman letters to integer values.
+ #
+ variable romanvalues
+
+ # i2r - list of integer-roman tuples
+ variable i2r {1000 M 900 CM 500 D 400 CD 100 C 90 XC 50 L 40 XL 10 X 9 IX 5 V 4 IV 1 I}
+
+ # sortkey - list of patterns to supporting sorting of roman numerals
+ variable sortkey {IX VIIII L Y XC YXXXX C Z D {\^} ZM {\^ZZZZ} M _}
+ variable rsortkey {_ M {\^ZZZZ} ZM {\^} D Z C YXXXX XC Y L VIIII IX}
+
+ # Initialise array variables
+ array set romanvalues {M 1000 D 500 C 100 L 50 X 10 V 5 I 1}
+}
+
+#==========================================================================
+# Public Functions
+#==========================================================================
+
+#----------------------------------------------------------
+# Roman numerals sorted
+#
+proc ::math::roman::sort list {
+ variable sortkey
+ variable rsortkey
+
+ foreach {from to} $sortkey {
+ regsub -all $from $list $to list
+ }
+ set list [lsort $list]
+ foreach {from to} $rsortkey {
+ regsub -all $from $list $to list
+ }
+ return $list
+}
+
+#----------------------------------------------------------
+# Roman numerals from integer
+#
+proc ::math::roman::toroman {i} {
+ variable i2r
+
+ set res ""
+ foreach {value roman} $i2r {
+ while {$i>=$value} {
+ append res $roman
+ incr i -$value
+ }
+ }
+ return $res
+}
+
+#----------------------------------------------------------
+# Roman numerals parsed into integer:
+#
+proc ::math::roman::tointeger {s} {
+ variable romanvalues
+
+ set last 99999
+ set res 0
+ foreach i [split [string toupper $s] ""] {
+ if { [catch {set val $romanvalues($i)}] } {
+ return -code error "roman::tointeger - un-Roman digit $i in $s"
+ }
+ incr res $val
+ if { $val > $last } {
+ incr res [::expr -2*$last]
+ }
+ set last $val
+ }
+ return $res
+}
+
+#----------------------------------------------------------
+# Roman numeral arithmetic
+#
+proc ::math::roman::expr args {
+
+ if { [string first \$ $args] >= 0 } {
+ set args [uplevel subst $args]
+ }
+
+ regsub -all {[^IVXLCDM]} $args { & } args
+ foreach i $args {
+ catch {set i [tointeger $i]}
+ lappend res $i
+ }
+ return [toroman [::expr $res]]
+}
+
+#==========================================================
+# Developer test code
+#
+if { 0 } {
+
+ puts "Basic int-to-roman-to-int conversion test"
+ for { set i 0 } {$i < 50} {incr i} {
+ set r [::math::roman::toroman $i]
+ set j [::math::roman::tointeger $r]
+ puts [format "%5d %-15s %s" $i $r $j]
+ if { $i != $j } {
+ error "Invalid conversion: $i -> $r -> $j"
+ }
+ }
+
+ puts ""
+ puts "roman arithmetic test"
+ set x 23
+ set xr [::math::roman::toroman $x]
+ set y 77
+ set yr [::math::roman::toroman $y]
+ set xr+yr [::math::roman::expr $xr + $yr]
+ set yr-xr [::math::roman::expr $yr - $xr]
+ set xr*yr [::math::roman::expr $xr * $yr]
+ set yr/xr [::math::roman::expr $yr / $xr]
+ set yr/xr2 [::math::roman::expr {$yr / $xr}]
+ puts "$x + $y\t\t= [expr $x + $y]"
+ puts "$x * $y\t\t= [expr $x * $y]"
+ puts "$y - $x\t\t= [expr $y - $x]"
+ puts "$y / $x\t\t= [expr $y / $x]"
+ puts "$xr + $yr\t= ${xr+yr} = [::math::roman::tointeger ${xr+yr}]"
+ puts "$xr * $yr\t= ${xr*yr} = [::math::roman::tointeger ${xr*yr}]"
+ puts "$yr - $xr\t= ${yr-xr} = [::math::roman::tointeger ${yr-xr}]"
+ puts "$yr / $xr\t= ${yr/xr} = [::math::roman::tointeger ${yr/xr}]"
+ puts "$yr / $xr\t= ${yr/xr2} = [::math::roman::tointeger ${yr/xr2}]"
+
+ puts ""
+ puts "roman sorting test"
+ set l {X III IV I V}
+ puts "IN : $l"
+ puts "OUT: [::math::roman::sort $l]"
+}
diff --git a/tcllib/modules/math/romberg.man b/tcllib/modules/math/romberg.man
new file mode 100755
index 0000000..9d1f1e9
--- /dev/null
+++ b/tcllib/modules/math/romberg.man
@@ -0,0 +1,340 @@
+[manpage_begin math::calculus::romberg n 0.6]
+[see_also math::calculus]
+[see_also math::interpolate]
+[copyright "2004 Kevin B. Kenny <kennykb@acm.org>. All rights\
+reserved. Redistribution permitted under the terms of the Open\
+Publication License <http://www.opencontent.org/openpub/>"]
+[moddesc {Tcl Math Library}]
+[titledesc {Romberg integration}]
+[category Mathematics]
+[require Tcl 8.2]
+[require math::calculus 0.6]
+[description]
+[para]
+The [cmd romberg] procedures in the [cmd math::calculus] package
+perform numerical integration of a function of one variable. They
+are intended to be of "production quality" in that they are robust,
+precise, and reasonably efficient in terms of the number of function
+evaluations.
+[section "PROCEDURES"]
+
+The following procedures are available for Romberg integration:
+
+[list_begin definitions]
+[call [cmd ::math::calculus::romberg] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]]
+
+Integrates an analytic function over a given interval.
+
+[call [cmd ::math::calculus::romberg_infinity] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]]
+
+Integrates an analytic function over a half-infinite interval.
+
+[call [cmd ::math::calculus::romberg_sqrtSingLower] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]]
+
+Integrates a function that is expected to be analytic over an interval
+except for the presence of an inverse square root singularity at the
+lower limit.
+
+[call [cmd ::math::calculus::romberg_sqrtSingUpper] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]]
+
+Integrates a function that is expected to be analytic over an interval
+except for the presence of an inverse square root singularity at the
+upper limit.
+
+[call [cmd ::math::calculus::romberg_powerLawLower] [arg gamma] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]]
+
+Integrates a function that is expected to be analytic over an interval
+except for the presence of a power law singularity at the
+lower limit.
+
+[call [cmd ::math::calculus::romberg_powerLawUpper] [arg gamma] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]]
+
+Integrates a function that is expected to be analytic over an interval
+except for the presence of a power law singularity at the
+upper limit.
+
+[call [cmd ::math::calculus::romberg_expLower] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]]
+
+Integrates an exponentially growing function; the lower limit of the
+region of integration may be arbitrarily large and negative.
+
+[call [cmd ::math::calculus::romberg_expUpper] [arg f] [arg a] [arg b] [opt [arg "-option value"]...]]
+
+Integrates an exponentially decaying function; the upper limit of the
+region of integration may be arbitrarily large.
+
+[list_end]
+
+[section PARAMETERS]
+
+[list_begin definitions]
+
+[def [arg f]]
+
+Function to integrate. Must be expressed as a single Tcl command,
+to which will be appended a single argument, specifically, the
+abscissa at which the function is to be evaluated. The first word
+of the command will be processed with [cmd "namespace which"] in the
+caller's scope prior to any evaluation. Given this processing, the
+command may local to the calling namespace rather than needing to be
+global.
+
+[def [arg a]]
+
+Lower limit of the region of integration.
+
+[def [arg b]]
+
+Upper limit of the region of integration. For the
+[cmd romberg_sqrtSingLower], [cmd romberg_sqrtSingUpper],
+[cmd romberg_powerLawLower], [cmd romberg_powerLawUpper],
+[cmd romberg_expLower], and [cmd romberg_expUpper] procedures,
+the lower limit must be strictly less than the upper. For
+the other procedures, the limits may appear in either order.
+
+[def [arg gamma]]
+
+Power to use for a power law singularity; see section
+[sectref "IMPROPER INTEGRALS"] for details.
+
+[list_end]
+
+[section OPTIONS]
+
+[list_begin definitions]
+
+[def "[option -abserror] [arg epsilon]"]
+
+Requests that the integration machinery proceed at most until
+the estimated absolute error of the integral is less than
+[arg epsilon]. The error may be seriously over- or underestimated
+if the function (or any of its derivatives) contains singularities;
+see section [sectref "IMPROPER INTEGRALS"] for details. Default
+is 1.0e-08.
+
+[def "[option -relerror] [arg epsilon]"]
+
+Requests that the integration machinery proceed at most until
+the estimated relative error of the integral is less than
+[arg epsilon]. The error may be seriously over- or underestimated
+if the function (or any of its derivatives) contains singularities;
+see section [sectref "IMPROPER INTEGRALS"] for details. Default is
+1.0e-06.
+
+[def "[option -maxiter] [arg m]"]
+
+Requests that integration terminate after at most [arg n] triplings of
+the number of evaluations performed. In other words, given [arg n]
+for [option -maxiter], the integration machinery will make at most
+3**[arg n] evaluations of the function. Default is 14, corresponding
+to a limit approximately 4.8 million evaluations. (Well-behaved
+functions will seldom require more than a few hundred evaluations.)
+
+[def "[option -degree] [arg d]"]
+
+Requests that an extrapolating polynomial of degree [arg d] be used
+in Romberg integration; see section [sectref "DESCRIPTION"] for
+details. Default is 4. Can be at most [arg m]-1.
+
+[list_end]
+
+[section DESCRIPTION]
+
+The [cmd romberg] procedure performs Romberg integration using
+the modified midpoint rule. Romberg integration is an iterative
+process. At the first step, the function is evaluated at the
+midpoint of the region of integration, and the value is multiplied by
+the width of the interval for the coarsest possible estimate.
+At the second step, the interval is divided into three parts,
+and the function is evaluated at the midpoint of each part; the
+sum of the values is multiplied by three. At the third step,
+nine parts are used, at the fourth twenty-seven, and so on,
+tripling the number of subdivisions at each step.
+
+[para]
+
+Once the interval has been divided at least [arg d] times,
+a polynomial is fitted to the integrals estimated in the last
+[arg d]+1 divisions. The integrals are considered to be a
+function of the square of the width of the subintervals
+(any good numerical analysis text will discuss this process
+under "Romberg integration"). The polynomial is extrapolated
+to a step size of zero, computing a value for the integral and
+an estimate of the error.
+
+[para]
+
+This process will be well-behaved only if the function is analytic
+over the region of integration; there may be removable singularities
+at either end of the region provided that the limit of the function
+(and of all its derivatives) exists as the ends are approached.
+Thus, [cmd romberg] may be used to integrate a function like
+f(x)=sin(x)/x over an interval beginning or ending at zero.
+
+[para]
+
+Note that [cmd romberg] will either fail to converge or else return
+incorrect error estimates if the function, or any of its derivatives,
+has a singularity anywhere in the region of integration (except for
+the case mentioned above). Care must be used, therefore, in
+integrating a function like 1/(1-x**2) to avoid the places
+where the derivative is singular.
+
+[section "IMPROPER INTEGRALS"]
+
+Romberg integration is also useful for integrating functions over
+half-infinite intervals or functions that have singularities.
+The trick is to make a change of variable to eliminate the
+singularity, and to put the singularity at one end or the other
+of the region of integration. The [cmd math::calculus] package
+supplies a number of [cmd romberg] procedures to deal with the
+commoner cases.
+
+[list_begin definitions]
+
+[def [cmd romberg_infinity]]
+
+Integrates a function over a half-infinite interval; either
+[arg a] or [arg b] may be infinite. [arg a] and [arg b] must be
+of the same sign; if you need to integrate across the axis,
+say, from a negative value to positive infinity,
+use [cmd romberg] to integrate from the negative
+value to a small positive value, and then [cmd romberg_infinity]
+to integrate from the positive value to positive infinity. The
+[cmd romberg_infinity] procedure works by making the change of
+variable u=1/x, so that the integral from a to b of f(x) is
+evaluated as the integral from 1/a to 1/b of f(1/u)/u**2.
+
+[def "[cmd romberg_powerLawLower] and [cmd romberg_powerLawUpper]"]
+
+Integrate a function that has an integrable power law singularity
+at either the lower or upper bound of the region of integration
+(or has a derivative with a power law singularity there).
+These procedures take a first parameter, [arg gamma], which gives
+the power law. The function or its first derivative are presumed to diverge as
+(x-[arg a])**(-[arg gamma]) or ([arg b]-x)**(-[arg gamma]). [arg gamma]
+must be greater than zero and less than 1.
+
+[para]
+
+These procedures are useful not only in integrating functions
+that go to infinity at one end of the region of integration, but
+also functions whose derivatives do not exist at the end of
+the region. For instance, integrating f(x)=pow(x,0.25) with the
+origin as one end of the region will result in the [cmd romberg]
+procedure greatly underestimating the error in the integral.
+The problem can be fixed by observing that the first derivative
+of f(x), f'(x)=x**(-3/4)/4, goes to infinity at the origin. Integrating
+using [cmd romberg_powerLawLower] with [arg gamma] set to 0.75
+gives much more orderly convergence.
+
+[para]
+
+These procedures operate by making the change of variable
+u=(x-a)**(1-gamma) ([cmd romberg_powerLawLower]) or
+u=(b-x)**(1-gamma) ([cmd romberg_powerLawUpper]).
+
+[para]
+
+To summarize the meaning of gamma:
+
+[list_begin itemized]
+[item]
+If f(x) ~ x**(-a) (0 < a < 1), use gamma = a
+[item]
+If f'(x) ~ x**(-b) (0 < b < 1), use gamma = b
+[list_end]
+
+[def "[cmd romberg_sqrtSingLower] and [cmd romberg_sqrtSingUpper]"]
+
+These procedures behave identically to [cmd romberg_powerLawLower] and
+[cmd romberg_powerLawUpper] for the common case of [arg gamma]=0.5;
+that is, they integrate a function with an inverse square root
+singularity at one end of the interval. They have a simpler
+implementation involving square roots rather than arbitrary powers.
+
+[def "[cmd romberg_expLower] and [cmd romberg_expUpper]"]
+
+These procedures are for integrating a function that grows or
+decreases exponentially over a half-infinite interval.
+[cmd romberg_expLower] handles exponentially growing functions, and
+allows the lower limit of integration to be an arbitrarily large
+negative number. [cmd romberg_expUpper] handles exponentially
+decaying functions and allows the upper limit of integration to
+be an arbitrary large positive number. The functions make the
+change of variable u=exp(-x) and u=exp(x) respectively.
+
+[list_end]
+
+[section "OTHER CHANGES OF VARIABLE"]
+
+If you need an improper integral other than the ones listed here,
+a change of variable can be written in very few lines of Tcl.
+Because the Tcl coding that does it is somewhat arcane,
+we offer a worked example here.
+
+[para]
+
+Let's say that the function that we want to integrate is
+f(x)=exp(x)/sqrt(1-x*x) (not a very natural
+function, but a good example), and we want to integrate
+it over the interval (-1,1). The denominator falls to zero
+at both ends of the interval. We wish to make a change of variable
+from x to u
+so that dx/sqrt(1-x**2) maps to du. Choosing x=sin(u), we can
+find that dx=cos(u)*du, and sqrt(1-x**2)=cos(u). The integral
+from a to b of f(x) is the integral from asin(a) to asin(b)
+of f(sin(u))*cos(u).
+
+[para]
+
+We can make a function [cmd g] that accepts an arbitrary function
+[cmd f] and the parameter u, and computes this new integrand.
+
+[example {
+proc g { f u } {
+ set x [expr { sin($u) }]
+ set cmd $f; lappend cmd $x; set y [eval $cmd]
+ return [expr { $y / cos($u) }]
+}
+}]
+
+Now integrating [cmd f] from [arg a] to [arg b] is the same
+as integrating [cmd g] from [arg asin(a)] to [arg asin(b)].
+It's a little tricky to get [cmd f] consistently evaluated in
+the caller's scope; the following procedure does it.
+
+[example {
+proc romberg_sine { f a b args } {
+ set f [lreplace $f 0 0\
+ [uplevel 1 [list namespace which [lindex $f 0]]]]
+ set f [list g $f]
+ return [eval [linsert $args 0\
+ romberg $f\
+ [expr { asin($a) }] [expr { asin($b) }]]]
+}
+}]
+
+This [cmd romberg_sine] procedure will do any function with
+sqrt(1-x*x) in the denominator. Our sample function is
+f(x)=exp(x)/sqrt(1-x*x):
+
+[example {
+proc f { x } {
+ expr { exp($x) / sqrt( 1. - $x*$x ) }
+}
+}]
+
+Integrating it is a matter of applying [cmd romberg_sine]
+as we would any of the other [cmd romberg] procedures:
+
+[example {
+foreach { value error } [romberg_sine f -1.0 1.0] break
+puts [format "integral is %.6g +/- %.6g" $value $error]
+
+integral is 3.97746 +/- 2.3557e-010
+}]
+
+[vset CATEGORY {math :: calculus}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/special.man b/tcllib/modules/math/special.man
new file mode 100755
index 0000000..908c1ce
--- /dev/null
+++ b/tcllib/modules/math/special.man
@@ -0,0 +1,472 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin math::special n 0.3]
+[keywords {Bessel functions}]
+[keywords {error function}]
+[keywords math]
+[keywords {special functions}]
+[copyright {2004 Arjen Markus <arjenmarkus@users.sourceforge.net>}]
+[moddesc {Tcl Math Library}]
+[titledesc {Special mathematical functions}]
+[category Mathematics]
+[require Tcl [opt 8.3]]
+[require math::special [opt 0.3]]
+
+[description]
+[para]
+This package implements several so-called special functions, like
+the Gamma function, the Bessel functions and such.
+
+[para]
+Each function is implemented by a procedure that bears its name (well,
+in close approximation):
+
+[list_begin itemized]
+[item]
+J0 for the zeroth-order Bessel function of the first kind
+
+[item]
+J1 for the first-order Bessel function of the first kind
+
+[item]
+Jn for the nth-order Bessel function of the first kind
+
+[item]
+J1/2 for the half-order Bessel function of the first kind
+
+[item]
+J-1/2 for the minus-half-order Bessel function of the first kind
+
+[item]
+I_n for the modified Bessel function of the first kind of order n
+
+[item]
+Gamma for the Gamma function, erf and erfc for the error function and
+the complementary error function
+
+[item]
+fresnel_C and fresnel_S for the Fresnel integrals
+
+[item]
+elliptic_K and elliptic_E (complete elliptic integrals)
+
+[item]
+exponent_Ei and other functions related to the so-called exponential
+integrals
+
+[item]
+legendre, hermite: some of the classical orthogonal polynomials.
+
+[list_end]
+
+[section OVERVIEW]
+
+In the following table several characteristics of the functions in this
+package are summarized: the domain for the argument, the values for the
+parameters and error bounds.
+
+[example {
+Family | Function | Domain x | Parameter | Error bound
+-------------+-------------+-------------+-------------+--------------
+Bessel | J0, J1, | all of R | n = integer | < 1.0e-8
+ | Jn | | | (|x|<20, n<20)
+Bessel | J1/2, J-1/2,| x > 0 | n = integer | exact
+Bessel | I_n | all of R | n = integer | < 1.0e-6
+ | | | |
+Elliptic | cn | 0 <= x <= 1 | -- | < 1.0e-10
+functions | dn | 0 <= x <= 1 | -- | < 1.0e-10
+ | sn | 0 <= x <= 1 | -- | < 1.0e-10
+Elliptic | K | 0 <= x < 1 | -- | < 1.0e-6
+integrals | E | 0 <= x < 1 | -- | < 1.0e-6
+ | | | |
+Error | erf | | -- |
+functions | erfc | | |
+ | | | |
+Inverse | invnorm | 0 < x < 1 | -- | < 1.2e-9
+normal | | | |
+distribution | | | |
+ | | | |
+Exponential | Ei | x != 0 | -- | < 1.0e-10 (relative)
+integrals | En | x > 0 | -- | as Ei
+ | li | x > 0 | -- | as Ei
+ | Chi | x > 0 | -- | < 1.0e-8
+ | Shi | x > 0 | -- | < 1.0e-8
+ | Ci | x > 0 | -- | < 2.0e-4
+ | Si | x > 0 | -- | < 2.0e-4
+ | | | |
+Fresnel | C | all of R | -- | < 2.0e-3
+integrals | S | all of R | -- | < 2.0e-3
+ | | | |
+general | Beta | (see Gamma) | -- | < 1.0e-9
+ | Gamma | x != 0,-1, | -- | < 1.0e-9
+ | | -2, ... | |
+ | sinc | all of R | -- | exact
+ | | | |
+orthogonal | Legendre | all of R | n = 0,1,... | exact
+polynomials | Chebyshev | all of R | n = 0,1,... | exact
+ | Laguerre | all of R | n = 0,1,... | exact
+ | | | alpha el. R |
+ | Hermite | all of R | n = 0,1,... | exact
+}]
+
+[emph Note:] Some of the error bounds are estimated, as no
+"formal" bounds were available with the implemented approximation
+method, others hold for the auxiliary functions used for estimating
+the primary functions.
+
+[para]
+The following well-known functions are currently missing from the package:
+[list_begin itemized]
+[item]
+Bessel functions of the second kind (Y_n, K_n)
+[item]
+Bessel functions of arbitrary order (and hence the Airy functions)
+[item]
+Chebyshev polynomials of the second kind (U_n)
+[item]
+The digamma function (psi)
+[item]
+The incomplete gamma and beta functions
+[list_end]
+
+[section "PROCEDURES"]
+
+The package defines the following public procedures:
+
+[list_begin definitions]
+
+[call [cmd ::math::special::Beta] [arg x] [arg y]]
+
+Compute the Beta function for arguments "x" and "y"
+
+[list_begin arguments]
+[arg_def float x] First argument for the Beta function
+
+[arg_def float y] Second argument for the Beta function
+[list_end]
+
+[para]
+
+[call [cmd ::math::special::Gamma] [arg x]]
+
+Compute the Gamma function for argument "x"
+
+[list_begin arguments]
+[arg_def float x] Argument for the Gamma function
+[list_end]
+
+[para]
+
+[call [cmd ::math::special::erf] [arg x]]
+
+Compute the error function for argument "x"
+
+[list_begin arguments]
+[arg_def float x] Argument for the error function
+[list_end]
+
+[para]
+
+[call [cmd ::math::special::erfc] [arg x]]
+
+Compute the complementary error function for argument "x"
+
+[list_begin arguments]
+[arg_def float x] Argument for the complementary error function
+[list_end]
+
+[para]
+
+[call [cmd ::math::special::invnorm] [arg p]]
+
+Compute the inverse of the normal distribution function for argument "p"
+
+[list_begin arguments]
+[arg_def float p] Argument for the inverse normal distribution function
+(p must be greater than 0 and lower than 1)
+[list_end]
+
+[para]
+
+[call [cmd ::math::special::J0] [arg x]]
+
+Compute the zeroth-order Bessel function of the first kind for the
+argument "x"
+
+[list_begin arguments]
+[arg_def float x] Argument for the Bessel function
+[list_end]
+
+[call [cmd ::math::special::J1] [arg x]]
+
+Compute the first-order Bessel function of the first kind for the
+argument "x"
+
+[list_begin arguments]
+[arg_def float x] Argument for the Bessel function
+[list_end]
+
+[call [cmd ::math::special::Jn] [arg n] [arg x]]
+
+Compute the nth-order Bessel function of the first kind for the
+argument "x"
+
+[list_begin arguments]
+[arg_def integer n] Order of the Bessel function
+[arg_def float x] Argument for the Bessel function
+[list_end]
+
+[call [cmd ::math::special::J1/2] [arg x]]
+
+Compute the half-order Bessel function of the first kind for the
+argument "x"
+
+[list_begin arguments]
+[arg_def float x] Argument for the Bessel function
+[list_end]
+
+[call [cmd ::math::special::J-1/2] [arg x]]
+
+Compute the minus-half-order Bessel function of the first kind for the
+argument "x"
+
+[list_begin arguments]
+[arg_def float x] Argument for the Bessel function
+[list_end]
+
+[call [cmd ::math::special::I_n] [arg x]]
+
+Compute the modified Bessel function of the first kind of order n for
+the argument "x"
+
+[list_begin arguments]
+[arg_def int x] Positive integer order of the function
+[arg_def float x] Argument for the function
+[list_end]
+
+[call [cmd ::math::special::cn] [arg u] [arg k]]
+
+Compute the elliptic function [emph cn] for the argument "u" and
+parameter "k".
+
+[list_begin arguments]
+[arg_def float u] Argument for the function
+[arg_def float k] Parameter
+[list_end]
+
+[call [cmd ::math::special::dn] [arg u] [arg k]]
+
+Compute the elliptic function [emph dn] for the argument "u" and
+parameter "k".
+
+[list_begin arguments]
+[arg_def float u] Argument for the function
+[arg_def float k] Parameter
+[list_end]
+
+[call [cmd ::math::special::sn] [arg u] [arg k]]
+
+Compute the elliptic function [emph sn] for the argument "u" and
+parameter "k".
+
+[list_begin arguments]
+[arg_def float u] Argument for the function
+[arg_def float k] Parameter
+[list_end]
+
+[call [cmd ::math::special::elliptic_K] [arg k]]
+
+Compute the complete elliptic integral of the first kind
+for the argument "k"
+
+[list_begin arguments]
+[arg_def float k] Argument for the function
+[list_end]
+
+[call [cmd ::math::special::elliptic_E] [arg k]]
+
+Compute the complete elliptic integral of the second kind
+for the argument "k"
+
+[list_begin arguments]
+[arg_def float k] Argument for the function
+[list_end]
+
+[call [cmd ::math::special::exponential_Ei] [arg x]]
+
+Compute the exponential integral of the second kind
+for the argument "x"
+
+[list_begin arguments]
+[arg_def float x] Argument for the function (x != 0)
+[list_end]
+
+[call [cmd ::math::special::exponential_En] [arg n] [arg x]]
+
+Compute the exponential integral of the first kind
+for the argument "x" and order n
+
+[list_begin arguments]
+[arg_def int n] Order of the integral (n >= 0)
+[arg_def float x] Argument for the function (x >= 0)
+[list_end]
+
+[call [cmd ::math::special::exponential_li] [arg x]]
+
+Compute the logarithmic integral for the argument "x"
+
+[list_begin arguments]
+[arg_def float x] Argument for the function (x > 0)
+[list_end]
+
+[call [cmd ::math::special::exponential_Ci] [arg x]]
+
+Compute the cosine integral for the argument "x"
+
+[list_begin arguments]
+[arg_def float x] Argument for the function (x > 0)
+[list_end]
+
+[call [cmd ::math::special::exponential_Si] [arg x]]
+
+Compute the sine integral for the argument "x"
+
+[list_begin arguments]
+[arg_def float x] Argument for the function (x > 0)
+[list_end]
+
+[call [cmd ::math::special::exponential_Chi] [arg x]]
+
+Compute the hyperbolic cosine integral for the argument "x"
+
+[list_begin arguments]
+[arg_def float x] Argument for the function (x > 0)
+[list_end]
+
+[call [cmd ::math::special::exponential_Shi] [arg x]]
+
+Compute the hyperbolic sine integral for the argument "x"
+
+[list_begin arguments]
+[arg_def float x] Argument for the function (x > 0)
+[list_end]
+
+[call [cmd ::math::special::fresnel_C] [arg x]]
+
+Compute the Fresnel cosine integral for real argument x
+
+[list_begin arguments]
+[arg_def float x] Argument for the function
+[list_end]
+
+[call [cmd ::math::special::fresnel_S] [arg x]]
+
+Compute the Fresnel sine integral for real argument x
+
+[list_begin arguments]
+[arg_def float x] Argument for the function
+[list_end]
+
+[call [cmd ::math::special::sinc] [arg x]]
+
+Compute the sinc function for real argument x
+
+[list_begin arguments]
+[arg_def float x] Argument for the function
+[list_end]
+
+[call [cmd ::math::special::legendre] [arg n]]
+
+Return the Legendre polynomial of degree n
+(see [sectref "THE ORTHOGONAL POLYNOMIALS"])
+
+[list_begin arguments]
+[arg_def int n] Degree of the polynomial
+[list_end]
+
+[para]
+
+[call [cmd ::math::special::chebyshev] [arg n]]
+
+Return the Chebyshev polynomial of degree n (of the first kind)
+
+[list_begin arguments]
+[arg_def int n] Degree of the polynomial
+[list_end]
+
+[para]
+
+[call [cmd ::math::special::laguerre] [arg alpha] [arg n]]
+
+Return the Laguerre polynomial of degree n with parameter alpha
+
+[list_begin arguments]
+[arg_def float alpha] Parameter of the Laguerre polynomial
+[arg_def int n] Degree of the polynomial
+[list_end]
+
+[para]
+
+[call [cmd ::math::special::hermite] [arg n]]
+
+Return the Hermite polynomial of degree n
+
+[list_begin arguments]
+[arg_def int n] Degree of the polynomial
+[list_end]
+
+[para]
+
+[list_end]
+
+[section "THE ORTHOGONAL POLYNOMIALS"]
+
+For dealing with the classical families of orthogonal polynomials, the
+package relies on the [emph math::polynomials] package. To evaluate the
+polynomial at some coordinate, use the [emph evalPolyn] command:
+[example {
+ set leg2 [::math::special::legendre 2]
+ puts "Value at x=$x: [::math::polynomials::evalPolyn $leg2 $x]"
+}]
+
+[para]
+The return value from the [emph legendre] and other commands is actually
+the definition of the corresponding polynomial as used in that package.
+
+[section "REMARKS ON THE IMPLEMENTATION"]
+
+It should be noted, that the actual implementation of J0 and J1 depends
+on straightforward Gaussian quadrature formulas. The (absolute) accuracy
+of the results is of the order 1.0e-4 or better. The main reason to
+implement them like that was that it was fast to do (the formulas are
+simple) and the computations are fast too.
+
+[para]
+The implementation of J1/2 does not suffer from this: this function can
+be expressed exactly in terms of elementary functions.
+
+[para]
+The functions J0 and J1 are the ones you will encounter most frequently
+in practice.
+
+[para]
+The computation of I_n is based on Miller's algorithm for computing the
+minimal function from recurrence relations.
+
+[para]
+The computation of the Gamma and Beta functions relies on the
+combinatorics package, whereas that of the error functions relies on the
+statistics package.
+
+[para]
+The computation of the complete elliptic integrals uses the AGM
+algorithm.
+
+[para]
+Much information about these functions can be found in:
+[para]
+Abramowitz and Stegun: [emph "Handbook of Mathematical Functions"]
+(Dover, ISBN 486-61272-4)
+
+[vset CATEGORY {math :: special}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/special.tcl b/tcllib/modules/math/special.tcl
new file mode 100755
index 0000000..637a3bc
--- /dev/null
+++ b/tcllib/modules/math/special.tcl
@@ -0,0 +1,301 @@
+# special.tcl --
+# Provide well-known special mathematical functions
+#
+# This file contains a collection of tests for one or more of the Tcllib
+# procedures. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 2004 by Arjen Markus. All rights reserved.
+#
+# RCS: @(#) $Id: special.tcl,v 1.13 2008/08/13 07:28:47 arjenmarkus Exp $
+#
+package require math
+package require math::constants
+package require math::statistics
+
+# namespace special
+# Create a convenient namespace for the "special" mathematical functions
+#
+namespace eval ::math::special {
+ #
+ # Define a number of common mathematical constants
+ #
+ ::math::constants::constants pi
+ variable halfpi [expr {$pi/2.0}]
+
+ #
+ # Functions defined in other math submodules
+ #
+ if { [info commands Beta] == {} } {
+ namespace import ::math::Beta
+ namespace import ::math::ln_Gamma
+ }
+
+ #
+ # Export the various functions
+ #
+ namespace export Beta ln_Gamma Gamma erf erfc fresnel_C fresnel_S sinc invnorm
+}
+
+# Gamma --
+# The Gamma function - synonym for "factorial"
+#
+proc ::math::special::Gamma {x} {
+ if { [catch { expr {exp( [ln_Gamma $x] )} } result] } {
+ return -code error -errorcode $::errorCode $result
+ }
+ return $result
+}
+
+# erf --
+# The error function
+# Arguments:
+# x The value for which the function must be evaluated
+# Result:
+# erf(x)
+# Note:
+# The algoritm used is due to George Marsaglia
+# See: http://www.velocityreviews.com/forums/t317358-erf-function-in-c.html
+# I did not want to copy and convert the even more accurate but
+# rather lengthy algorithm used by lcc-win32/Sun
+#
+proc ::math::special::erf {x} {
+ set x [expr {$x*sqrt(2.0)}]
+
+ if { $x > 10.0 } { return 1.0 }
+ if { $x < -10.0 } { return -1.0 }
+
+ set a 1.2533141373155
+ set b -1.0
+ set pwr 1.0
+ set t 0.0
+ set z 0.0
+
+ set s [expr {$a+$b*$x}]
+
+ set i 2
+ while { $s != $t } {
+ set a [expr {($a+$z*$b)/double($i)}]
+ set b [expr {($b+$z*$a)/double($i+1)}]
+ set pwr [expr {$pwr*$x*$x}]
+ set t $s
+ set s [expr {$s+$pwr*($a+$x*$b)}]
+
+ incr i 2
+ }
+
+ return [expr {1.0-2.0*$s*exp(-0.5*$x*$x-0.9189385332046727418)}]
+}
+
+
+
+# erfc --
+# The complement of the error function
+# Arguments:
+# x The value for which the function must be evaluated
+# Result:
+# erfc(x) = 1.0-erf(x)
+#
+proc ::math::special::erfc {x} {
+ set x [expr {$x*sqrt(2.0)}]
+
+ if { $x > 10.0 } { return 0.0 }
+ if { $x < -10.0 } { return 0.0 }
+
+ set a 1.2533141373155
+ set b -1.0
+ set pwr 1.0
+ set t 0.0
+ set z 0.0
+
+ set s [expr {$a+$b*$x}]
+
+ set i 2
+ while { $s != $t } {
+ set a [expr {($a+$z*$b)/double($i)}]
+ set b [expr {($b+$z*$a)/double($i+1)}]
+ set pwr [expr {$pwr*$x*$x}]
+ set t $s
+ set s [expr {$s+$pwr*($a+$x*$b)}]
+
+ incr i 2
+ }
+
+ return [expr {2.0*$s*exp(-0.5*$x*$x-0.9189385332046727418)}]
+}
+
+
+# ComputeFG --
+# Compute the auxiliary functions f and g
+#
+# Arguments:
+# x Parameter of the integral (x>=0)
+# Result:
+# Approximate values for f and g
+# Note:
+# See Abramowitz and Stegun. The accuracy is 2.0e-3.
+#
+proc ::math::special::ComputeFG {x} {
+ list [expr {(1.0+0.926*$x)/(2.0+1.792*$x+3.104*$x*$x)}] \
+ [expr {1.0/(2.0+4.142*$x+3.492*$x*$x+6.670*$x*$x*$x)}]
+}
+
+# fresnel_C --
+# Compute the Fresnel cosine integral
+#
+# Arguments:
+# x Parameter of the integral (x>=0)
+# Result:
+# Value of C(x) = integral from 0 to x of cos(0.5*pi*x^2)
+# Note:
+# This relies on a rational approximation of the two auxiliary functions f and g
+#
+proc ::math::special::fresnel_C {x} {
+ variable halfpi
+ if { $x < 0.0 } {
+ error "Domain error: x must be non-negative"
+ }
+
+ if { $x == 0.0 } {
+ return 0.0
+ }
+
+ foreach {f g} [ComputeFG $x] {break}
+
+ set xarg [expr {$halfpi*$x*$x}]
+
+ return [expr {0.5+$f*sin($xarg)-$g*cos($xarg)}]
+}
+
+# fresnel_S --
+# Compute the Fresnel sine integral
+#
+# Arguments:
+# x Parameter of the integral (x>=0)
+# Result:
+# Value of S(x) = integral from 0 to x of sin(0.5*pi*x^2)
+# Note:
+# This relies on a rational approximation of the two auxiliary functions f and g
+#
+proc ::math::special::fresnel_S {x} {
+ variable halfpi
+ if { $x < 0.0 } {
+ error "Domain error: x must be non-negative"
+ }
+
+ if { $x == 0.0 } {
+ return 0.0
+ }
+
+ foreach {f g} [ComputeFG $x] {break}
+
+ set xarg [expr {$halfpi*$x*$x}]
+
+ return [expr {0.5-$f*cos($xarg)-$g*sin($xarg)}]
+}
+
+# sinc --
+# Compute the sinc function
+# Arguments:
+# x Value of the argument
+# Result:
+# sin(x)/x
+#
+proc ::math::special::sinc {x} {
+ if { $x == 0.0 } {
+ return 1.0
+ } else {
+ return [expr {sin($x)/$x}]
+ }
+}
+
+# invnorm --
+# Compute the inverse of the cumulative normal distribution
+#
+# Arguments:
+# p Value of erf(x) for x must be found
+#
+# Returns:
+# Value of x
+#
+# Notes:
+# Implementation in Tcl by Christian Gollwitzer
+# Uses rational approximation from
+# http://home.online.no/~pjacklam/notes/invnorm/#Pseudo_code_for_rational_approximation
+# relative precision 1.2*10^-9 in the full range
+#
+proc ::math::special::invnorm {p} {
+ # inverse normal distribution
+ # rational approximation from
+ # http://home.online.no/~pjacklam/notes/invnorm/#Pseudo_code_for_rational_approximation
+ # precision 1.2*10^-9
+
+ if {$p<=0 || $p>=1} {
+ return -code error "Domain error (invnorm)"
+ }
+ # Coefficients in rational approximations.
+ set a1 -3.969683028665376e+01
+ set a2 2.209460984245205e+02
+ set a3 -2.759285104469687e+02
+ set a4 1.383577518672690e+02
+ set a5 -3.066479806614716e+01
+ set a6 2.506628277459239e+00
+
+ set b1 -5.447609879822406e+01
+ set b2 1.615858368580409e+02
+ set b3 -1.556989798598866e+02
+ set b4 6.680131188771972e+01
+ set b5 -1.328068155288572e+01
+
+ set c1 -7.784894002430293e-03
+ set c2 -3.223964580411365e-01
+ set c3 -2.400758277161838e+00
+ set c4 -2.549732539343734e+00
+ set c5 4.374664141464968e+00
+ set c6 2.938163982698783e+00
+
+ set d1 7.784695709041462e-03
+ set d2 3.224671290700398e-01
+ set d3 2.445134137142996e+00
+ set d4 3.754408661907416e+00
+
+ # Define break-points.
+
+ set p_low 0.02425
+ set p_high [expr {1-$p_low}]
+
+ # Rational approximation for lower region.
+
+ if {$p < $p_low} {
+ set q [expr {sqrt(-2*log($p))}]
+ set x [expr {((((($c1*$q+$c2)*$q+$c3)*$q+$c4)*$q+$c5)*$q+$c6) / \
+ (((($d1*$q+$d2)*$q+$d3)*$q+$d4)*$q+1)}]
+ return $x
+ }
+
+ # Rational approximation for central region.
+
+ if {$p <= $p_high} {
+ set q [expr {$p - 0.5}]
+ set r [expr {$q*$q}]
+ set x [expr {((((($a1*$r+$a2)*$r+$a3)*$r+$a4)*$r+$a5)*$r+$a6)*$q / \
+ ((((($b1*$r+$b2)*$r+$b3)*$r+$b4)*$r+$b5)*$r+1)}]
+ return $x
+ }
+
+ # Rational approximation for upper region.
+
+ set q [expr {sqrt(-2*log(1-$p))}]
+ set x [expr {-((((($c1*$q+$c2)*$q+$c3)*$q+$c4)*$q+$c5)*$q+$c6) /
+ (((($d1*$q+$d2)*$q+$d3)*$q+$d4)*$q+1)}]
+ return $x
+}
+
+# Bessel functions and elliptic integrals --
+#
+source [file join [file dirname [info script]] "bessel.tcl"]
+source [file join [file dirname [info script]] "classic_polyns.tcl"]
+source [file join [file dirname [info script]] "elliptic.tcl"]
+source [file join [file dirname [info script]] "exponential.tcl"]
+
+package provide math::special 0.3.0
diff --git a/tcllib/modules/math/special.test b/tcllib/modules/math/special.test
new file mode 100755
index 0000000..c778935
--- /dev/null
+++ b/tcllib/modules/math/special.test
@@ -0,0 +1,132 @@
+# -*- tcl -*-
+# Tests for special functions in math library -*- tcl -*-
+#
+# This file contains a collection of tests for one or more of the Tcllib
+# procedures. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# $Id: special.test,v 1.13 2007/08/21 17:33:00 andreas_kupries Exp $
+#
+# Copyright (c) 2004 by Arjen Markus
+# All rights reserved.
+#
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4;# statistics,linalg!
+testsNeedTcltest 2.1
+
+support {
+ useLocal math.tcl math
+ useLocal constants.tcl math::constants
+ useLocal linalg.tcl math::linearalgebra
+ useLocal statistics.tcl math::statistics
+ useLocal polynomials.tcl math::polynomials
+}
+testing {
+ useLocal special.tcl math::special
+}
+
+# -------------------------------------------------------------------------
+
+#
+# Expect an accuracy of at least four decimals
+#
+proc matchNumbers {expected actual} {
+ set match 1
+ foreach a $actual e $expected {
+ if {abs($a-$e) > 1.0e-4} {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+
+#
+# Expect an accuracy of some three decimals (Fresnel)
+#
+proc matchFresnel {expected actual} {
+ set match 1
+ foreach a $actual e $expected {
+ if {abs($a-$e) > 2.0e-3} {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+
+customMatch numbers matchNumbers
+customMatch numbers-fresnel matchFresnel
+
+test "Erf-1.0" "Values of the error function" \
+ -match numbers -body {
+ set result {}
+ foreach x {0.0 0.1 0.2 0.5 1.0 2.0 -0.1 -0.2 -0.5 -1.0 -2.0} {
+ lappend result [::math::special::erf $x]
+ }
+ set result
+} -result {0.0 0.1124629 0.2227026 0.5204999 0.8427008 0.9953227
+ -0.1124629 -0.2227026 -0.5204999 -0.8427008 -0.9953227}
+
+proc make_erfc {erf_values} {
+ set result {}
+ foreach v $erf_values {
+ lappend result [expr {1.0-$v}]
+ }
+ return $result
+}
+
+test "Erf-1.1" "Values of the complementary error function" \
+ -match numbers -body {
+ set result {}
+ foreach x {0.0 0.1 0.2 0.5 1.0 2.0 -0.1 -0.2 -0.5 -1.0 -2.0} {
+ lappend result [::math::special::erfc $x]
+ }
+ set result
+} -result [make_erfc {0.0 0.1124629 0.2227026 0.5204999 0.8427008 0.9953227
+ -0.1124629 -0.2227026 -0.5204999 -0.8427008 -0.9953227}]
+
+
+test "Fresnel-1.0" "Values of the Fresnel C intergral" \
+ -match numbers-fresnel -body {
+ set result {}
+ foreach x {0.0 0.1 0.2 0.5 1.0 1.5 2.0 3.0 4.0 5.0} {
+ lappend result [::math::special::fresnel_C $x]
+ }
+ set result
+} -result {0.0 0.09999 0.19992 0.49234 0.77989 0.44526
+ 0.48825 0.60572 0.49842 0.56363}
+
+test "Fresnel-1.1" "Values of the Fresnel S intergral" \
+ -match numbers-fresnel -body {
+ set result {}
+ foreach x {0.0 0.1 0.2 0.5 1.0 1.5 2.0 3.0 4.0 5.0} {
+ lappend result [::math::special::fresnel_S $x]
+ }
+ set result
+} -result {0.0 0.00052 0.00419 0.06473 0.43826 0.69750
+ 0.34342 0.49631 0.42052 0.49919}
+
+test "invnorm-1.0" "Values of the inverse normal distribution" \
+ -match numbers -body {
+ set result {}
+ foreach p {0.001 0.01 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 0.99 0.999} {
+ lappend result [::math::special::invnorm $p]
+ }
+ set result
+} -result {-3.090232304709404 -2.326347874388028 -1.2815515641401563 -0.8416212327266185 -0.5244005132792953 -0.2533471028599986
+ 0.0 0.2533471028599986 0.5244005132792952 0.8416212327266186 1.2815515641401563 2.326347874388028 3.090232304709404}
+
+test "sinc-1.0" "Values of the sinc function" \
+ -match numbers -body {
+ set result [::math::special::sinc 0.0]
+} -result 1.0
+
+# End of test cases
+testsuiteCleanup
diff --git a/tcllib/modules/math/stat_kernel.tcl b/tcllib/modules/math/stat_kernel.tcl
new file mode 100644
index 0000000..1d1f219
--- /dev/null
+++ b/tcllib/modules/math/stat_kernel.tcl
@@ -0,0 +1,217 @@
+# stat_kernel.tcl --
+#
+# Part of the statistics package for basic statistical analysis
+# Based on http://en.wikipedia.org/wiki/Kernel_(statistics) and
+# http://en.wikipedia.org/wiki/Kernel_density_estimation
+#
+# version 0.1: initial implementation, january 2014
+
+# kernel-density --
+# Estimate the probability density using the kernel density
+# estimation method
+#
+# Arguments:
+# data List of univariate data
+# args List of options in the form of keyword-value pairs:
+# -weights weights: per data point the weight
+# -bandwidth value: bandwidth to be used for the estimation
+# -number value: number of bins to be returned
+# -interval {begin end}: begin and end of the interval for
+# which the density is returned
+# -kernel function: kernel to be used (gaussian, cosine,
+# epanechnikov, uniform, triangular, biweight,
+# logistic)
+# For all options more or less sensible defaults are
+# provided.
+#
+# Result:
+# A list of the bin centres, a list of the corresponding density
+# estimates and a list containing several computational parameters:
+# begin and end of the interval, mean, standard deviation and bandwidth
+#
+# Note:
+# The conditions for the kernel function are fairly weak:
+# - It should integrate to 1
+# - It should be symmetric around 0
+#
+# As for the implementation in Tcl: it should be reachable in the
+# ::math::statistics namespace. As a consequence, you can define
+# your own kernel function too. Hence there is no check.
+#
+proc ::math::statistics::kernel-density {data args} {
+
+ #
+ # Determine the basic statistics
+ #
+ set basicStats [BasicStats all $data]
+
+ set mean [lindex $basicStats 0]
+ set ndata [lindex $basicStats 3]
+ set stdev [lindex $basicStats 4]
+
+ if { $ndata < 1 } {
+ return -code error -errorcode ARG -errorinfo "Too few actual data"
+ }
+
+ #
+ # Get the options (providing defaults as needed)
+ #
+ set opt(-weights) {}
+ set opt(-number) 100
+ set opt(-kernel) gaussian
+
+ #
+ # The default bandwidth is set via a simple expression, which
+ # is supposed to be optimal for the Gaussian kernel.
+ # Perhaps a more sophisticated method should be provided as well
+ #
+ set opt(-bandwidth) [expr {1.06 * $stdev / pow($ndata,0.2)}]
+
+ #
+ # The default interval is derived from the mean and the
+ # standard deviation
+ #
+ set opt(-interval) [list [expr {$mean - 3.0 * $stdev}] [expr {$mean + 3.0 * $stdev}]]
+
+ #
+ # Retrieve the given options from $args
+ #
+ if { [llength $args] % 2 != 0 } {
+ return -code error -errorcode ARG -errorinfo "The options must all have a value"
+ }
+ array set opt $args
+
+ #
+ # Elementary checks
+ #
+ if { $opt(-bandwidth) <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo "The bandwidth must be positive: $opt(-bandwidth)"
+ }
+
+ if { $opt(-number) <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo "The number of bins must be positive: $opt(-number)"
+ }
+
+ if { [lindex $opt(-interval) 0] == [lindex $opt(-interval) 1] } {
+ return -code error -errorcode ARG -errorinfo "The interval has length zero: $opt(-interval)"
+ }
+
+ if { [llength [info proc $opt(-kernel)]] == 0 } {
+ return -code error -errorcode ARG -errorinfo "Unknown kernel function: $opt(-kernel)"
+ }
+
+ #
+ # Construct the weights
+ #
+ if { [llength $opt(-weights)] > 0 } {
+ if { [llength $data] != [llength $opt(-weights)] } {
+ return -code error -errorcode ARG -errorinfo "The list of weights must match the data"
+ }
+
+ set sum 0.0
+ foreach d $data w $opt(-weights) {
+ if { $d != {} } {
+ set sum [expr {$sum + $w}]
+ }
+ }
+ set scale [expr {1.0/$sum/$ndata}]
+
+ set weight {}
+ foreach w $opt(-weights) {
+ if { $d != {} } {
+ lappend weight [expr {$w / $scale}]
+ } else {
+ lappend weight {}
+ }
+ }
+ } else {
+ set weight [lrepeat [llength $data] [expr {1.0/$ndata}]] ;# Note: missing values have weight zero
+ }
+
+ #
+ # Construct the centres of the bins
+ #
+ set xbegin [lindex $opt(-interval) 0]
+ set xend [lindex $opt(-interval) 1]
+ set dx [expr {($xend - $xbegin) / double($opt(-number))}]
+ set xb [expr {$xbegin + 0.5 * $dx}]
+ set xvalue {}
+ for {set i 0} {$i < $opt(-number)} {incr i} {
+ lappend xvalue [expr {$xb + $i * $dx}]
+ }
+
+ #
+ # Construct the density function
+ #
+ set density {}
+ set scale [expr {1.0/$opt(-bandwidth)}]
+ foreach x $xvalue {
+ set sum 0.0
+ foreach d $data w $weight {
+ if { $d != {} } {
+ set kvalue [$opt(-kernel) [expr {$scale * ($x-$d)}]]
+ set sum [expr {$sum + $w * $kvalue}]
+ }
+ }
+ lappend density [expr {$sum * $scale}]
+ }
+
+ #
+ # Return the result
+ #
+ return [list $xvalue $density [list $xbegin $xend $mean $stdev $opt(-bandwidth)]]
+}
+
+# gaussian, uniform, triangular, epanechnikov, biweight, cosine, logistic --
+# The Gaussian kernel
+#
+# Arguments:
+# x (Scaled) argument
+#
+# Result:
+# Value of the kernel
+#
+# Note:
+# The standard deviation is 1.
+#
+proc ::math::statistics::gaussian {x} {
+ return [expr {exp(-0.5*$x*$x) / sqrt(2.0*acos(-1.0))}]
+}
+proc ::math::statistics::uniform {x} {
+ if { abs($x) <= 1.0 } {
+ return 0.5
+ } else {
+ return 0.0
+ }
+}
+proc ::math::statistics::triangular {x} {
+ if { abs($x) < 1.0 } {
+ return [expr {1.0 - abs($x)}]
+ } else {
+ return 0.0
+ }
+}
+proc ::math::statistics::epanechnikov {x} {
+ if { abs($x) < 1.0 } {
+ return [expr {0.75 * (1.0 - abs($x)*abs($x))}]
+ } else {
+ return 0.0
+ }
+}
+proc ::math::statistics::biweight {x} {
+ if { abs($x) < 1.0 } {
+ return [expr {0.9375 * pow((1.0 - abs($x)*abs($x)),2)}]
+ } else {
+ return 0.0
+ }
+}
+proc ::math::statistics::cosine {x} {
+ if { abs($x) < 1.0 } {
+ return [expr {0.25 * acos(-1.0) * cos(0.5 * acos(-1.0) * $x)}]
+ } else {
+ return 0.0
+ }
+}
+proc ::math::statistics::logistic {x} {
+ return [expr {1.0 / (exp($x) + 2.0 + exp(-$x))}]
+}
diff --git a/tcllib/modules/math/statistics.man b/tcllib/modules/math/statistics.man
new file mode 100755
index 0000000..433e61d
--- /dev/null
+++ b/tcllib/modules/math/statistics.man
@@ -0,0 +1,1504 @@
+[vset VERSION 1]
+[manpage_begin math::statistics n [vset VERSION]]
+[keywords {data analysis}]
+[keywords mathematics]
+[keywords statistics]
+[moddesc {Tcl Math Library}]
+[titledesc {Basic statistical functions and procedures}]
+[category Mathematics]
+[require Tcl 8.4]
+[require math::statistics [vset VERSION]]
+[description]
+[para]
+
+The [package math::statistics] package contains functions and procedures for
+basic statistical data analysis, such as:
+
+[list_begin itemized]
+[item]
+Descriptive statistical parameters (mean, minimum, maximum, standard
+deviation)
+
+[item]
+Estimates of the distribution in the form of histograms and quantiles
+
+[item]
+Basic testing of hypotheses
+
+[item]
+Probability and cumulative density functions
+
+[list_end]
+It is meant to help in developing data analysis applications or doing
+ad hoc data analysis, it is not in itself a full application, nor is it
+intended to rival with full (non-)commercial statistical packages.
+
+[para]
+The purpose of this document is to describe the implemented procedures
+and provide some examples of their usage. As there is ample literature
+on the algorithms involved, we refer to relevant text books for more
+explanations.
+
+The package contains a fairly large number of public procedures. They
+can be distinguished in three sets: general procedures, procedures
+that deal with specific statistical distributions, list procedures to
+select or transform data and simple plotting procedures (these require
+Tk).
+
+[emph Note:] The data that need to be analyzed are always contained in a
+simple list. Missing values are represented as empty list elements.
+
+[section "GENERAL PROCEDURES"]
+The general statistical procedures are:
+
+[list_begin definitions]
+
+[call [cmd ::math::statistics::mean] [arg data]]
+Determine the [term mean] value of the given list of data.
+
+[list_begin arguments]
+[arg_def list data] - List of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::min] [arg data]]
+Determine the [term minimum] value of the given list of data.
+
+[list_begin arguments]
+[arg_def list data] - List of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::max] [arg data]]
+Determine the [term maximum] value of the given list of data.
+
+[list_begin arguments]
+[arg_def list data] - List of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::number] [arg data]]
+Determine the [term number] of non-missing data in the given list
+
+[list_begin arguments]
+[arg_def list data] - List of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::stdev] [arg data]]
+Determine the [term "sample standard deviation"] of the data in the
+given list
+
+[list_begin arguments]
+[arg_def list data] - List of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::var] [arg data]]
+Determine the [term "sample variance"] of the data in the given list
+
+[list_begin arguments]
+[arg_def list data] - List of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::pstdev] [arg data]]
+Determine the [term "population standard deviation"] of the data
+in the given list
+
+[list_begin arguments]
+[arg_def list data] - List of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::pvar] [arg data]]
+Determine the [term "population variance"] of the data in the
+given list
+
+[list_begin arguments]
+[arg_def list data] - List of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::median] [arg data]]
+Determine the [term median] of the data in the given list
+(Note that this requires sorting the data, which may be a
+costly operation)
+
+[list_begin arguments]
+[arg_def list data] - List of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::basic-stats] [arg data]]
+Determine a list of all the descriptive parameters: mean, minimum,
+maximum, number of data, sample standard deviation, sample variance,
+population standard deviation and population variance.
+[para]
+(This routine is called whenever either or all of the basic statistical
+parameters are required. Hence all calculations are done and the
+relevant values are returned.)
+
+[list_begin arguments]
+[arg_def list data] - List of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::histogram] [arg limits] [arg values] [opt weights]]
+Determine histogram information for the given list of data. Returns a
+list consisting of the number of values that fall into each interval.
+(The first interval consists of all values lower than the first limit,
+the last interval consists of all values greater than the last limit.
+There is one more interval than there are limits.)
+[para]
+Optionally, you can use weights to influence the histogram.
+
+[list_begin arguments]
+[arg_def list limits] - List of upper limits (in ascending order) for the
+intervals of the histogram.
+[arg_def list values] - List of data
+[arg_def list weights] - List of weights, one weight per value
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::histogram-alt] [arg limits] [arg values] [opt weights]]
+Alternative implementation of the histogram procedure: the open end of the intervals
+is at the lower bound instead of the upper bound.
+
+[list_begin arguments]
+[arg_def list limits] - List of upper limits (in ascending order) for the
+intervals of the histogram.
+[arg_def list values] - List of data
+[arg_def list weights] - List of weights, one weight per value
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::corr] [arg data1] [arg data2]]
+Determine the correlation coefficient between two sets of data.
+
+[list_begin arguments]
+[arg_def list data1] - First list of data
+[arg_def list data2] - Second list of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::interval-mean-stdev] [arg data] [arg confidence]]
+Return the interval containing the mean value and one
+containing the standard deviation with a certain
+level of confidence (assuming a normal distribution)
+
+[list_begin arguments]
+[arg_def list data] - List of raw data values (small sample)
+[arg_def float confidence] - Confidence level (0.95 or 0.99 for instance)
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::t-test-mean] [arg data] [arg est_mean] \
+[arg est_stdev] [arg alpha]]
+Test whether the mean value of a sample is in accordance with the
+estimated normal distribution with a certain probability.
+Returns 1 if the test succeeds or 0 if the mean is unlikely to fit
+the given distribution.
+
+[list_begin arguments]
+[arg_def list data] - List of raw data values (small sample)
+[arg_def float est_mean] - Estimated mean of the distribution
+[arg_def float est_stdev] - Estimated stdev of the distribution
+[arg_def float alpha] - Probability level (0.95 or 0.99 for instance)
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::test-normal] [arg data] [arg significance]]
+Test whether the given data follow a normal distribution
+with a certain level of significance.
+Returns 1 if the data are normally distributed within the level of
+significance, returns 0 if not. The underlying test is the Lilliefors
+test. Smaller values of the significance mean a stricter testing.
+
+[list_begin arguments]
+[arg_def list data] - List of raw data values
+[arg_def float significance] - Significance level (one of 0.01, 0.05, 0.10, 0.15 or 0.20). For compatibility
+reasons the values "1-significance", 0.80, 0.85, 0.90, 0.95 or 0.99 are also accepted.
+[list_end]
+[para]
+Compatibility issue: the original implementation and documentation used the term "confidence" and used a value
+1-significance (see ticket 2812473fff). This has been corrected as of version 0.9.3.
+
+[call [cmd ::math::statistics::lillieforsFit] [arg data]]
+Returns the goodness of fit to a normal distribution according to
+Lilliefors. The higher the number, the more likely the data are indeed
+normally distributed. The test requires at least [emph five] data
+points.
+
+[list_begin arguments]
+[arg_def list data] - List of raw data values
+[list_end]
+[para]
+
+
+[call [cmd ::math::statistics::test-Duckworth] [arg list1] [arg list2] [arg significance]]
+Determine if two data sets have the same median according to the Tukey-Duckworth test.
+The procedure returns 0 if the medians are unequal, 1 if they are equal, -1 if the test can not
+be conducted (the smallest value must be in a different set than the greatest value).
+#
+# Arguments:
+# list1 Values in the first data set
+# list2 Values in the second data set
+# significance Significance level (either 0.05, 0.01 or 0.001)
+#
+# Returns:
+
+Test whether the given data follow a normal distribution
+with a certain level of significance.
+Returns 1 if the data are normally distributed within the level of
+significance, returns 0 if not. The underlying test is the Lilliefors
+test. Smaller values of the significance mean a stricter testing.
+
+[list_begin arguments]
+[arg_def list list1] - First list of data
+[arg_def list list2] - Second list of data
+[arg_def float significance] - Significance level (either 0.05, 0.01 or 0.001)
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::quantiles] [arg data] [arg confidence]]
+Return the quantiles for a given set of data
+[list_begin arguments]
+[para]
+[arg_def list data] - List of raw data values
+[para]
+[arg_def float confidence] - Confidence level (0.95 or 0.99 for instance) or a list of confidence levels.
+[para]
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::quantiles] [arg limits] [arg counts] [arg confidence]]
+Return the quantiles based on histogram information (alternative to the
+call with two arguments)
+[list_begin arguments]
+[arg_def list limits] - List of upper limits from histogram
+[arg_def list counts] - List of counts for for each interval in histogram
+[arg_def float confidence] - Confidence level (0.95 or 0.99 for instance) or a list of confidence levels.
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::autocorr] [arg data]]
+Return the autocorrelation function as a list of values (assuming
+equidistance between samples, about 1/2 of the number of raw data)
+[para]
+The correlation is determined in such a way that the first value is
+always 1 and all others are equal to or smaller than 1. The number of
+values involved will diminish as the "time" (the index in the list of
+returned values) increases
+[list_begin arguments]
+[arg_def list data] - Raw data for which the autocorrelation must be determined
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::crosscorr] [arg data1] [arg data2]]
+Return the cross-correlation function as a list of values (assuming
+equidistance between samples, about 1/2 of the number of raw data)
+[para]
+The correlation is determined in such a way that the values can never
+exceed 1 in magnitude. The number of values involved will diminish
+as the "time" (the index in the list of returned values) increases.
+[list_begin arguments]
+[arg_def list data1] - First list of data
+[arg_def list data2] - Second list of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::mean-histogram-limits] [arg mean] \
+[arg stdev] [arg number]]
+Determine reasonable limits based on mean and standard deviation
+for a histogram
+Convenience function - the result is suitable for the histogram function.
+
+[list_begin arguments]
+[arg_def float mean] - Mean of the data
+[arg_def float stdev] - Standard deviation
+[arg_def int number] - Number of limits to generate (defaults to 8)
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::minmax-histogram-limits] [arg min] \
+[arg max] [arg number]]
+Determine reasonable limits based on a minimum and maximum for a histogram
+[para]
+Convenience function - the result is suitable for the histogram function.
+[list_begin arguments]
+[arg_def float min] - Expected minimum
+[arg_def float max] - Expected maximum
+[arg_def int number] - Number of limits to generate (defaults to 8)
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::linear-model] [arg xdata] \
+[arg ydata] [arg intercept]]
+Determine the coefficients for a linear regression between
+two series of data (the model: Y = A + B*X). Returns a list of
+parameters describing the fit
+
+[list_begin arguments]
+[arg_def list xdata] - List of independent data
+[arg_def list ydata] - List of dependent data to be fitted
+[arg_def boolean intercept] - (Optional) compute the intercept (1, default) or fit
+to a line through the origin (0)
+[para]
+The result consists of the following list:
+[list_begin itemized]
+[item]
+(Estimate of) Intercept A
+[item]
+(Estimate of) Slope B
+[item]
+Standard deviation of Y relative to fit
+[item]
+Correlation coefficient R2
+[item]
+Number of degrees of freedom df
+[item]
+Standard error of the intercept A
+[item]
+Significance level of A
+[item]
+Standard error of the slope B
+[item]
+Significance level of B
+[list_end]
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::linear-residuals] [arg xdata] [arg ydata] \
+[arg intercept]]
+Determine the difference between actual data and predicted from
+the linear model.
+[para]
+Returns a list of the differences between the actual data and the
+predicted values.
+[list_begin arguments]
+[arg_def list xdata] - List of independent data
+[arg_def list ydata] - List of dependent data to be fitted
+[arg_def boolean intercept] - (Optional) compute the intercept (1, default) or fit
+to a line through the origin (0)
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::test-2x2] [arg n11] [arg n21] [arg n12] [arg n22]]
+Determine if two set of samples, each from a binomial distribution,
+differ significantly or not (implying a different parameter).
+[para]
+Returns the "chi-square" value, which can be used to the determine the
+significance.
+[list_begin arguments]
+[arg_def int n11] - Number of outcomes with the first value from the first sample.
+[arg_def int n21] - Number of outcomes with the first value from the second sample.
+[arg_def int n12] - Number of outcomes with the second value from the first sample.
+[arg_def int n22] - Number of outcomes with the second value from the second sample.
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::print-2x2] [arg n11] [arg n21] [arg n12] [arg n22]]
+Determine if two set of samples, each from a binomial distribution,
+differ significantly or not (implying a different parameter).
+[para]
+Returns a short report, useful in an interactive session.
+[list_begin arguments]
+[arg_def int n11] - Number of outcomes with the first value from the first sample.
+[arg_def int n21] - Number of outcomes with the first value from the second sample.
+[arg_def int n12] - Number of outcomes with the second value from the first sample.
+[arg_def int n22] - Number of outcomes with the second value from the second sample.
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::control-xbar] [arg data] [opt nsamples]]
+Determine the control limits for an xbar chart. The number of data
+in each subsample defaults to 4. At least 20 subsamples are required.
+[para]
+Returns the mean, the lower limit, the upper limit and the number of
+data per subsample.
+
+[list_begin arguments]
+[arg_def list data] - List of observed data
+[arg_def int nsamples] - Number of data per subsample
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::control-Rchart] [arg data] [opt nsamples]]
+Determine the control limits for an R chart. The number of data
+in each subsample (nsamples) defaults to 4. At least 20 subsamples are required.
+[para]
+Returns the mean range, the lower limit, the upper limit and the number
+of data per subsample.
+
+[list_begin arguments]
+[arg_def list data] - List of observed data
+[arg_def int nsamples] - Number of data per subsample
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::test-xbar] [arg control] [arg data]]
+Determine if the data exceed the control limits for the xbar chart.
+[para]
+Returns a list of subsamples (their indices) that indeed violate the
+limits.
+
+[list_begin arguments]
+[arg_def list control] - Control limits as returned by the "control-xbar" procedure
+[arg_def list data] - List of observed data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::test-Rchart] [arg control] [arg data]]
+Determine if the data exceed the control limits for the R chart.
+[para]
+Returns a list of subsamples (their indices) that indeed violate the
+limits.
+[list_begin arguments]
+[arg_def list control] - Control limits as returned by the "control-Rchart" procedure
+[arg_def list data] - List of observed data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::test-Kruskal-Wallis] [arg confidence] [arg args]]
+Check if the population medians of two or more groups are equal with a
+given confidence level, using the Kruskal-Wallis test.
+
+[list_begin arguments]
+[arg_def float confidence] - Confidence level to be used (0-1)
+[arg_def list args] - Two or more lists of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::analyse-Kruskal-Wallis] [arg args]]
+Compute the statistical parameters for the Kruskal-Wallis test.
+Returns the Kruskal-Wallis statistic and the probability that that
+value would occur assuming the medians of the populations are
+equal.
+
+[list_begin arguments]
+[arg_def list args] - Two or more lists of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::group-rank] [arg args]]
+Rank the groups of data with respect to the complete set.
+Returns a list consisting of the group ID, the value and the rank
+(possibly a rational number, in case of ties) for each data item.
+
+[list_begin arguments]
+[arg_def list args] - Two or more lists of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::test-Wilcoxon] [arg sample_a] [arg sample_b]]
+Compute the Wilcoxon test statistic to determine if two samples have the
+same median or not. (The statistic can be regarded as standard normal, if the
+sample sizes are both larger than 10. Returns the value of this statistic.
+
+[list_begin arguments]
+[arg_def list sample_a] - List of data comprising the first sample
+[arg_def list sample_b] - List of data comprising the second sample
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::spearman-rank] [arg sample_a] [arg sample_b]]
+Return the Spearman rank correlation as an alternative to the ordinary (Pearson's) correlation
+coefficient. The two samples should have the same number of data.
+
+[list_begin arguments]
+[arg_def list sample_a] - First list of data
+[arg_def list sample_b] - Second list of data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::spearman-rank-extended] [arg sample_a] [arg sample_b]]
+Return the Spearman rank correlation as an alternative to the ordinary (Pearson's) correlation
+coefficient as well as additional data. The two samples should have the same number of data.
+The procedure returns the correlation coefficient, the number of data pairs used and the
+z-score, an approximately standard normal statistic, indicating the significance of the correlation.
+
+[list_begin arguments]
+[arg_def list sample_a] - First list of data
+[arg_def list sample_b] - Second list of data
+[list_end]
+
+[call [cmd ::math::statistics::kernel-density] [arg data] opt [arg "-option value"] ...]]
+Return the density function based on kernel density estimation. The procedure is controlled by
+a small set of options, each of which is given a reasonable default.
+[para]
+The return value consists of three lists: the centres of the bins, the associated probability
+density and a list of computational parameters (begin and end of the interval, mean and standard
+deviation and the used bandwidth). The computational parameters can be used for further analysis.
+
+[list_begin arguments]
+[arg_def list data] - The data to be examined
+[arg_def list args] - Option-value pairs:
+[list_begin definitions]
+[def "[option -weights] [arg weights]"] Per data point the weight (default: 1 for all data)
+[def "[option -bandwidth] [arg value]"] Bandwidth to be used for the estimation (default: determined from standard deviation)
+[def "[option -number] [arg value]"] Number of bins to be returned (default: 100)
+[def "[option -interval] [arg "{begin end}"]"] Begin and end of the interval for
+which the density is returned (default: mean +/- 3*standard deviation)
+[def "[option -kernel] [arg function]"] Kernel to be used (One of: gaussian, cosine,
+epanechnikov, uniform, triangular, biweight, logistic; default: gaussian)
+[list_end]
+[list_end]
+
+[list_end]
+
+[section "MULTIVARIATE LINEAR REGRESSION"]
+
+Besides the linear regression with a single independent variable, the
+statistics package provides two procedures for doing ordinary
+least squares (OLS) and weighted least squares (WLS) linear regression
+with several variables. They were written by Eric Kemp-Benedict.
+
+[para]
+In addition to these two, it provides a procedure (tstat)
+for calculating the value of the t-statistic for the specified number of
+degrees of freedom that is required to demonstrate a given level of
+significance.
+
+[para]
+Note: These procedures depend on the math::linearalgebra package.
+
+[para]
+[emph "Description of the procedures"]
+
+[list_begin definitions]
+[call [cmd ::math::statistics::tstat] [arg dof] [opt alpha]]
+Returns the value of the t-distribution t* satisfying
+
+[example {
+ P(t*) = 1 - alpha/2
+ P(-t*) = alpha/2
+}]
+for the number of degrees of freedom dof.
+[para]
+Given a sample of normally-distributed data x, with an
+estimate xbar for the mean and sbar for the standard deviation,
+the alpha confidence interval for the estimate of the mean can
+be calculated as
+[example {
+ ( xbar - t* sbar , xbar + t* sbar)
+}]
+The return values from this procedure can be compared to
+an estimated t-statistic to determine whether the estimated
+value of a parameter is significantly different from zero at
+the given confidence level.
+
+[list_begin arguments]
+[arg_def int dof]
+Number of degrees of freedom
+
+[arg_def float alpha]
+Confidence level of the t-distribution. Defaults to 0.05.
+
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::mv-wls] [arg wt1] [arg weights_and_values]]
+Carries out a weighted least squares linear regression for
+the data points provided, with weights assigned to each point.
+
+[para]
+The linear model is of the form
+
+[example {
+ y = b0 + b1 * x1 + b2 * x2 ... + bN * xN + error
+}]
+and each point satisfies
+[example {
+ yi = b0 + b1 * xi1 + b2 * xi2 + ... + bN * xiN + Residual_i
+}]
+[para]
+The procedure returns a list with the following elements:
+[list_begin itemized]
+[item]
+The r-squared statistic
+[item]
+The adjusted r-squared statistic
+[item]
+A list containing the estimated coefficients b1, ... bN, b0
+(The constant b0 comes last in the list.)
+[item]
+A list containing the standard errors of the coefficients
+[item]
+A list containing the 95% confidence bounds of the coefficients,
+with each set of bounds returned as a list with two values
+[list_end]
+
+Arguments:
+[list_begin arguments]
+[arg_def list weights_and_values]
+A list consisting of: the weight for the first observation, the data
+for the first observation (as a sublist), the weight for the second
+observation (as a sublist) and so on. The sublists of data are organised
+as lists of the value of the dependent variable y and the independent
+variables x1, x2 to xN.
+
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::mv-ols] [arg values]]
+Carries out an ordinary least squares linear regression for
+the data points provided.
+
+[para]
+This procedure simply calls ::mvlinreg::wls with the weights
+set to 1.0, and returns the same information.
+
+[list_end]
+
+[emph "Example of the use:"]
+[example {
+# Store the value of the unicode value for the "+/-" character
+set pm "\u00B1"
+
+# Provide some data
+set data {{ -.67 14.18 60.03 -7.5 }
+ { 36.97 15.52 34.24 14.61 }
+ {-29.57 21.85 83.36 -7. }
+ {-16.9 11.79 51.67 -6.56 }
+ { 14.09 16.24 36.97 -12.84}
+ { 31.52 20.93 45.99 -25.4 }
+ { 24.05 20.69 50.27 17.27}
+ { 22.23 16.91 45.07 -4.3 }
+ { 40.79 20.49 38.92 -.73 }
+ {-10.35 17.24 58.77 18.78}}
+
+# Call the ols routine
+set results [::math::statistics::mv-ols $data]
+
+# Pretty-print the results
+puts "R-squared: [lindex $results 0]"
+puts "Adj R-squared: [lindex $results 1]"
+puts "Coefficients $pm s.e. -- \[95% confidence interval\]:"
+foreach val [lindex $results 2] se [lindex $results 3] bounds [lindex $results 4] {
+ set lb [lindex $bounds 0]
+ set ub [lindex $bounds 1]
+ puts " $val $pm $se -- \[$lb to $ub\]"
+}
+}]
+
+[section "STATISTICAL DISTRIBUTIONS"]
+In the literature a large number of probability distributions can be
+found. The statistics package supports:
+[list_begin itemized]
+[item]
+The normal or Gaussian distribution as well as the log-normal distribution
+[item]
+The uniform distribution - equal probability for all data within a given
+interval
+[item]
+The exponential distribution - useful as a model for certain
+extreme-value distributions.
+[item]
+The gamma distribution - based on the incomplete Gamma integral
+[item]
+The beta distribution
+[item]
+The chi-square distribution
+[item]
+The student's T distribution
+[item]
+The Poisson distribution
+[item]
+The Pareto distribution
+[item]
+The Gumbel distribution
+[item]
+The Weibull distribution
+[item]
+The Cauchy distribution
+[item]
+PM - binomial,F.
+[list_end]
+
+In principle for each distribution one has procedures for:
+[list_begin itemized]
+[item]
+The probability density (pdf-*)
+[item]
+The cumulative density (cdf-*)
+[item]
+Quantiles for the given distribution (quantiles-*)
+[item]
+Histograms for the given distribution (histogram-*)
+[item]
+List of random values with the given distribution (random-*)
+[list_end]
+
+The following procedures have been implemented:
+
+[list_begin definitions]
+
+[call [cmd ::math::statistics::pdf-normal] [arg mean] [arg stdev] [arg value]]
+Return the probability of a given value for a normal distribution with
+given mean and standard deviation.
+
+[list_begin arguments]
+[arg_def float mean] - Mean value of the distribution
+[arg_def float stdev] - Standard deviation of the distribution
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::pdf-lognormal] [arg mean] [arg stdev] [arg value]]
+Return the probability of a given value for a log-normal distribution with
+given mean and standard deviation.
+
+[list_begin arguments]
+[arg_def float mean] - Mean value of the distribution
+[arg_def float stdev] - Standard deviation of the distribution
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::pdf-exponential] [arg mean] [arg value]]
+Return the probability of a given value for an exponential
+distribution with given mean.
+
+[list_begin arguments]
+[arg_def float mean] - Mean value of the distribution
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::pdf-uniform] [arg xmin] [arg xmax] [arg value]]
+Return the probability of a given value for a uniform
+distribution with given extremes.
+
+[list_begin arguments]
+[arg_def float xmin] - Minimum value of the distribution
+[arg_def float xmin] - Maximum value of the distribution
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::pdf-gamma] [arg alpha] [arg beta] [arg value]]
+Return the probability of a given value for a Gamma
+distribution with given shape and rate parameters
+
+[list_begin arguments]
+[arg_def float alpha] - Shape parameter
+[arg_def float beta] - Rate parameter
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::pdf-poisson] [arg mu] [arg k]]
+Return the probability of a given number of occurrences in the same
+interval (k) for a Poisson distribution with given mean (mu)
+
+[list_begin arguments]
+[arg_def float mu] - Mean number of occurrences
+[arg_def int k] - Number of occurences
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::pdf-chisquare] [arg df] [arg value]]
+Return the probability of a given value for a chi square
+distribution with given degrees of freedom
+
+[list_begin arguments]
+[arg_def float df] - Degrees of freedom
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::pdf-student-t] [arg df] [arg value]]
+Return the probability of a given value for a Student's t
+distribution with given degrees of freedom
+
+[list_begin arguments]
+[arg_def float df] - Degrees of freedom
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::pdf-gamma] [arg a] [arg b] [arg value]]
+Return the probability of a given value for a Gamma
+distribution with given shape and rate parameters
+
+[list_begin arguments]
+[arg_def float a] - Shape parameter
+[arg_def float b] - Rate parameter
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::pdf-beta] [arg a] [arg b] [arg value]]
+Return the probability of a given value for a Beta
+distribution with given shape parameters
+
+[list_begin arguments]
+[arg_def float a] - First shape parameter
+[arg_def float b] - Second shape parameter
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::pdf-weibull] [arg scale] [arg shape] [arg value]]
+Return the probability of a given value for a Weibull
+distribution with given scale and shape parameters
+
+[list_begin arguments]
+[arg_def float location] - Scale parameter
+[arg_def float scale] - Shape parameter
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::pdf-gumbel] [arg location] [arg scale] [arg value]]
+Return the probability of a given value for a Gumbel
+distribution with given location and shape parameters
+
+[list_begin arguments]
+[arg_def float location] - Location parameter
+[arg_def float scale] - Shape parameter
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::pdf-pareto] [arg scale] [arg shape] [arg value]]
+Return the probability of a given value for a Pareto
+distribution with given scale and shape parameters
+
+[list_begin arguments]
+[arg_def float scale] - Scale parameter
+[arg_def float shape] - Shape parameter
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::pdf-cauchy] [arg location] [arg scale] [arg value]]
+Return the probability of a given value for a Cauchy
+distribution with given location and shape parameters. Note that the Cauchy distribution
+has no finite higher-order moments.
+
+[list_begin arguments]
+[arg_def float location] - Location parameter
+[arg_def float scale] - Shape parameter
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::cdf-normal] [arg mean] [arg stdev] [arg value]]
+Return the cumulative probability of a given value for a normal
+distribution with given mean and standard deviation, that is the
+probability for values up to the given one.
+
+[list_begin arguments]
+[arg_def float mean] - Mean value of the distribution
+[arg_def float stdev] - Standard deviation of the distribution
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::cdf-lognormal] [arg mean] [arg stdev] [arg value]]
+Return the cumulative probability of a given value for a log-normal
+distribution with given mean and standard deviation, that is the
+probability for values up to the given one.
+
+[list_begin arguments]
+[arg_def float mean] - Mean value of the distribution
+[arg_def float stdev] - Standard deviation of the distribution
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::cdf-exponential] [arg mean] [arg value]]
+Return the cumulative probability of a given value for an exponential
+distribution with given mean.
+
+[list_begin arguments]
+[arg_def float mean] - Mean value of the distribution
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::cdf-uniform] [arg xmin] [arg xmax] [arg value]]
+Return the cumulative probability of a given value for a uniform
+distribution with given extremes.
+
+[list_begin arguments]
+[arg_def float xmin] - Minimum value of the distribution
+[arg_def float xmin] - Maximum value of the distribution
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::cdf-students-t] [arg degrees] [arg value]]
+Return the cumulative probability of a given value for a Student's t
+distribution with given number of degrees.
+[list_begin arguments]
+[arg_def int degrees] - Number of degrees of freedom
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::cdf-gamma] [arg alpha] [arg beta] [arg value]]
+Return the cumulative probability of a given value for a Gamma
+distribution with given shape and rate parameters.
+
+[list_begin arguments]
+[arg_def float alpha] - Shape parameter
+[arg_def float beta] - Rate parameter
+[arg_def float value] - Value for which the cumulative probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::cdf-poisson] [arg mu] [arg k]]
+Return the cumulative probability of a given number of occurrences in
+the same interval (k) for a Poisson distribution with given mean (mu).
+
+[list_begin arguments]
+[arg_def float mu] - Mean number of occurrences
+[arg_def int k] - Number of occurences
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::cdf-beta] [arg a] [arg b] [arg value]]
+Return the cumulative probability of a given value for a Beta
+distribution with given shape parameters
+
+[list_begin arguments]
+[arg_def float a] - First shape parameter
+[arg_def float b] - Second shape parameter
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::cdf-weibull] [arg scale] [arg shape] [arg value]]
+Return the cumulative probability of a given value for a Weibull
+distribution with given scale and shape parameters.
+
+[list_begin arguments]
+[arg_def float scale] - Scale parameter
+[arg_def float shape] - Shape parameter
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::cdf-gumbel] [arg location] [arg scale] [arg value]]
+Return the cumulative probability of a given value for a Gumbel
+distribution with given location and scale parameters.
+
+[list_begin arguments]
+[arg_def float location] - Location parameter
+[arg_def float scale] - Scale parameter
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::cdf-pareto] [arg scale] [arg shape] [arg value]]
+Return the cumulative probability of a given value for a Pareto
+distribution with given scale and shape parameters
+
+[list_begin arguments]
+[arg_def float scale] - Scale parameter
+[arg_def float shape] - Shape parameter
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::cdf-cauchy] [arg location] [arg scale] [arg value]]
+Return the cumulative probability of a given value for a Cauchy
+distribution with given location and scale parameters.
+
+[list_begin arguments]
+[arg_def float location] - Location parameter
+[arg_def float scale] - Scale parameter
+[arg_def float value] - Value for which the probability is required
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::empirical-distribution] [arg values]]
+Return a list of values and their empirical probability. The values are sorted in increasing order.
+(The implementation follows the description at the corresponding Wikipedia page)
+
+[list_begin arguments]
+[arg_def list values] - List of data to be examined
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::random-normal] [arg mean] [arg stdev] [arg number]]
+Return a list of "number" random values satisfying a normal
+distribution with given mean and standard deviation.
+[list_begin arguments]
+[arg_def float mean] - Mean value of the distribution
+[arg_def float stdev] - Standard deviation of the distribution
+[arg_def int number] - Number of values to be returned
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::random-lognormal] [arg mean] [arg stdev] [arg number]]
+Return a list of "number" random values satisfying a log-normal
+distribution with given mean and standard deviation.
+[list_begin arguments]
+[arg_def float mean] - Mean value of the distribution
+[arg_def float stdev] - Standard deviation of the distribution
+[arg_def int number] - Number of values to be returned
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::random-exponential] [arg mean] [arg number]]
+Return a list of "number" random values satisfying an exponential
+distribution with given mean.
+[list_begin arguments]
+[arg_def float mean] - Mean value of the distribution
+[arg_def int number] - Number of values to be returned
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::random-uniform] [arg xmin] [arg xmax] [arg number]]
+Return a list of "number" random values satisfying a uniform
+distribution with given extremes.
+
+[list_begin arguments]
+[arg_def float xmin] - Minimum value of the distribution
+[arg_def float xmax] - Maximum value of the distribution
+[arg_def int number] - Number of values to be returned
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::random-gamma] [arg alpha] [arg beta] [arg number]]
+Return a list of "number" random values satisfying
+a Gamma distribution with given shape and rate parameters.
+
+[list_begin arguments]
+[arg_def float alpha] - Shape parameter
+[arg_def float beta] - Rate parameter
+[arg_def int number] - Number of values to be returned
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::random-poisson] [arg mu] [arg number]]
+Return a list of "number" random values satisfying
+a Poisson distribution with given mean.
+
+[list_begin arguments]
+[arg_def float mu] - Mean of the distribution
+[arg_def int number] - Number of values to be returned
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::random-chisquare] [arg df] [arg number]]
+Return a list of "number" random values satisfying
+a chi square distribution with given degrees of freedom.
+
+[list_begin arguments]
+[arg_def float df] - Degrees of freedom
+[arg_def int number] - Number of values to be returned
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::random-student-t] [arg df] [arg number]]
+Return a list of "number" random values satisfying
+a Student's t distribution with given degrees of freedom.
+
+[list_begin arguments]
+[arg_def float df] - Degrees of freedom
+[arg_def int number] - Number of values to be returned
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::random-beta] [arg a] [arg b] [arg number]]
+Return a list of "number" random values satisfying
+a Beta distribution with given shape parameters.
+
+[list_begin arguments]
+[arg_def float a] - First shape parameter
+[arg_def float b] - Second shape parameter
+[arg_def int number] - Number of values to be returned
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::random-weibull] [arg scale] [arg shape] [arg number]]
+Return a list of "number" random values satisfying
+a Weibull distribution with given scale and shape parameters.
+
+[list_begin arguments]
+[arg_def float scale] - Scale parameter
+[arg_def float shape] - Shape parameter
+[arg_def int number] - Number of values to be returned
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::random-gumbel] [arg location] [arg scale] [arg number]]
+Return a list of "number" random values satisfying
+a Gumbel distribution with given location and scale parameters.
+
+[list_begin arguments]
+[arg_def float location] - Location parameter
+[arg_def float scale] - Scale parameter
+[arg_def int number] - Number of values to be returned
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::random-pareto] [arg scale] [arg shape] [arg number]]
+Return a list of "number" random values satisfying
+a Pareto distribution with given scale and shape parameters.
+
+[list_begin arguments]
+[arg_def float scale] - Scale parameter
+[arg_def float shape] - Shape parameter
+[arg_def int number] - Number of values to be returned
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::random-cauchy] [arg location] [arg scale] [arg number]]
+Return a list of "number" random values satisfying
+a Cauchy distribution with given location and scale parameters.
+
+[list_begin arguments]
+[arg_def float location] - Location parameter
+[arg_def float scale] - Scale parameter
+[arg_def int number] - Number of values to be returned
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::histogram-uniform] [arg xmin] [arg xmax] [arg limits] [arg number]]
+Return the expected histogram for a uniform distribution.
+
+[list_begin arguments]
+[arg_def float xmin] - Minimum value of the distribution
+[arg_def float xmax] - Maximum value of the distribution
+[arg_def list limits] - Upper limits for the buckets in the histogram
+[arg_def int number] - Total number of "observations" in the histogram
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::incompleteGamma] [arg x] [arg p] [opt tol]]
+Evaluate the incomplete Gamma integral
+
+[example {
+ 1 / x p-1
+ P(p,x) = -------- | dt exp(-t) * t
+ Gamma(p) / 0
+}]
+
+[list_begin arguments]
+[arg_def float x] - Value of x (limit of the integral)
+[arg_def float p] - Value of p in the integrand
+[arg_def float tol] - Required tolerance (default: 1.0e-9)
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::incompleteBeta] [arg a] [arg b] [arg x] [opt tol]]
+Evaluate the incomplete Beta integral
+
+[list_begin arguments]
+[arg_def float a] - First shape parameter
+[arg_def float b] - Second shape parameter
+[arg_def float x] - Value of x (limit of the integral)
+[arg_def float tol] - Required tolerance (default: 1.0e-9)
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::estimate-pareto] [arg values]]
+Estimate the parameters for the Pareto distribution that comes closest to the given values.
+Returns the estimated scale and shape parameters, as well as the standard error for the shape parameter.
+
+[list_begin arguments]
+[arg_def list values] - List of values, assumed to be distributed according to a Pareto distribution
+[list_end]
+[para]
+
+[list_end]
+TO DO: more function descriptions to be added
+
+[section "DATA MANIPULATION"]
+The data manipulation procedures act on lists or lists of lists:
+
+[list_begin definitions]
+
+[call [cmd ::math::statistics::filter] [arg varname] [arg data] [arg expression]]
+Return a list consisting of the data for which the logical
+expression is true (this command works analogously to the command [cmd foreach]).
+
+[list_begin arguments]
+[arg_def string varname] - Name of the variable used in the expression
+[arg_def list data] - List of data
+[arg_def string expression] - Logical expression using the variable name
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::map] [arg varname] [arg data] [arg expression]]
+Return a list consisting of the data that are transformed via the
+expression.
+
+[list_begin arguments]
+[arg_def string varname] - Name of the variable used in the expression
+[arg_def list data] - List of data
+[arg_def string expression] - Expression to be used to transform (map) the data
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::samplescount] [arg varname] [arg list] [arg expression]]
+Return a list consisting of the [term counts] of all data in the
+sublists of the "list" argument for which the expression is true.
+
+[list_begin arguments]
+[arg_def string varname] - Name of the variable used in the expression
+[arg_def list data] - List of sublists, each containing the data
+[arg_def string expression] - Logical expression to test the data (defaults to
+"true").
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::subdivide]]
+Routine [emph PM] - not implemented yet
+[para]
+
+[list_end]
+
+[section "PLOT PROCEDURES"]
+The following simple plotting procedures are available:
+[list_begin definitions]
+
+[call [cmd ::math::statistics::plot-scale] [arg canvas] \
+[arg xmin] [arg xmax] [arg ymin] [arg ymax]]
+Set the scale for a plot in the given canvas. All plot routines expect
+this function to be called first. There is no automatic scaling
+provided.
+
+[list_begin arguments]
+[arg_def widget canvas] - Canvas widget to use
+[arg_def float xmin] - Minimum x value
+[arg_def float xmax] - Maximum x value
+[arg_def float ymin] - Minimum y value
+[arg_def float ymax] - Maximum y value
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::plot-xydata] [arg canvas] \
+[arg xdata] [arg ydata] [arg tag]]
+Create a simple XY plot in the given canvas - the data are
+shown as a collection of dots. The tag can be used to manipulate the
+appearance.
+
+[list_begin arguments]
+[arg_def widget canvas] - Canvas widget to use
+[arg_def float xdata] - Series of independent data
+[arg_def float ydata] - Series of dependent data
+[arg_def string tag] - Tag to give to the plotted data (defaults to xyplot)
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::plot-xyline] [arg canvas] \
+[arg xdata] [arg ydata] [arg tag]]
+Create a simple XY plot in the given canvas - the data are
+shown as a line through the data points. The tag can be used to
+manipulate the appearance.
+[list_begin arguments]
+[arg_def widget canvas] - Canvas widget to use
+[arg_def list xdata] - Series of independent data
+[arg_def list ydata] - Series of dependent data
+[arg_def string tag] - Tag to give to the plotted data (defaults to xyplot)
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::plot-tdata] [arg canvas] \
+[arg tdata] [arg tag]]
+Create a simple XY plot in the given canvas - the data are
+shown as a collection of dots. The horizontal coordinate is equal to the
+index. The tag can be used to manipulate the appearance.
+This type of presentation is suitable for autocorrelation functions for
+instance or for inspecting the time-dependent behaviour.
+[list_begin arguments]
+[arg_def widget canvas] - Canvas widget to use
+[arg_def list tdata] - Series of dependent data
+[arg_def string tag] - Tag to give to the plotted data (defaults to xyplot)
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::plot-tline] [arg canvas] \
+[arg tdata] [arg tag]]
+Create a simple XY plot in the given canvas - the data are
+shown as a line. See plot-tdata for an explanation.
+
+[list_begin arguments]
+[arg_def widget canvas] - Canvas widget to use
+[arg_def list tdata] - Series of dependent data
+[arg_def string tag] - Tag to give to the plotted data (defaults to xyplot)
+[list_end]
+[para]
+
+[call [cmd ::math::statistics::plot-histogram] [arg canvas] \
+[arg counts] [arg limits] [arg tag]]
+Create a simple histogram in the given canvas
+
+[list_begin arguments]
+[arg_def widget canvas] - Canvas widget to use
+[arg_def list counts] - Series of bucket counts
+[arg_def list limits] - Series of upper limits for the buckets
+[arg_def string tag] - Tag to give to the plotted data (defaults to xyplot)
+[list_end]
+[para]
+
+[list_end]
+
+[section {THINGS TO DO}]
+The following procedures are yet to be implemented:
+[list_begin itemized]
+[item]
+F-test-stdev
+[item]
+interval-mean-stdev
+[item]
+histogram-normal
+[item]
+histogram-exponential
+[item]
+test-histogram
+[item]
+test-corr
+[item]
+quantiles-*
+[item]
+fourier-coeffs
+[item]
+fourier-residuals
+[item]
+onepar-function-fit
+[item]
+onepar-function-residuals
+[item]
+plot-linear-model
+[item]
+subdivide
+[list_end]
+
+[section EXAMPLES]
+The code below is a small example of how you can examine a set of
+data:
+[para]
+[example_begin]
+
+# Simple example:
+# - Generate data (as a cheap way of getting some)
+# - Perform statistical analysis to describe the data
+#
+package require math::statistics
+
+#
+# Two auxiliary procs
+#
+proc pause {time} {
+ set wait 0
+ after [lb]expr {$time*1000}[rb] {set ::wait 1}
+ vwait wait
+}
+
+proc print-histogram {counts limits} {
+ foreach count $counts limit $limits {
+ if { $limit != {} } {
+ puts [lb]format "<%12.4g\t%d" $limit $count[rb]
+ set prev_limit $limit
+ } else {
+ puts [lb]format ">%12.4g\t%d" $prev_limit $count[rb]
+ }
+ }
+}
+
+#
+# Our source of arbitrary data
+#
+proc generateData { data1 data2 } {
+ upvar 1 $data1 _data1
+ upvar 1 $data2 _data2
+
+ set d1 0.0
+ set d2 0.0
+ for { set i 0 } { $i < 100 } { incr i } {
+ set d1 [lb]expr {10.0-2.0*cos(2.0*3.1415926*$i/24.0)+3.5*rand()}[rb]
+ set d2 [lb]expr {0.7*$d2+0.3*$d1+0.7*rand()}[rb]
+ lappend _data1 $d1
+ lappend _data2 $d2
+ }
+ return {}
+}
+
+#
+# The analysis session
+#
+package require Tk
+console show
+canvas .plot1
+canvas .plot2
+pack .plot1 .plot2 -fill both -side top
+
+generateData data1 data2
+
+puts "Basic statistics:"
+set b1 [lb]::math::statistics::basic-stats $data1[rb]
+set b2 [lb]::math::statistics::basic-stats $data2[rb]
+foreach label {mean min max number stdev var} v1 $b1 v2 $b2 {
+ puts "$label\t$v1\t$v2"
+}
+puts "Plot the data as function of \"time\" and against each other"
+::math::statistics::plot-scale .plot1 0 100 0 20
+::math::statistics::plot-scale .plot2 0 20 0 20
+::math::statistics::plot-tline .plot1 $data1
+::math::statistics::plot-tline .plot1 $data2
+::math::statistics::plot-xydata .plot2 $data1 $data2
+
+puts "Correlation coefficient:"
+puts [lb]::math::statistics::corr $data1 $data2]
+
+pause 2
+puts "Plot histograms"
+.plot2 delete all
+::math::statistics::plot-scale .plot2 0 20 0 100
+set limits [lb]::math::statistics::minmax-histogram-limits 7 16[rb]
+set histogram_data [lb]::math::statistics::histogram $limits $data1[rb]
+::math::statistics::plot-histogram .plot2 $histogram_data $limits
+
+puts "First series:"
+print-histogram $histogram_data $limits
+
+pause 2
+set limits [lb]::math::statistics::minmax-histogram-limits 0 15 10[rb]
+set histogram_data [lb]::math::statistics::histogram $limits $data2[rb]
+::math::statistics::plot-histogram .plot2 $histogram_data $limits d2
+.plot2 itemconfigure d2 -fill red
+
+puts "Second series:"
+print-histogram $histogram_data $limits
+
+puts "Autocorrelation function:"
+set autoc [lb]::math::statistics::autocorr $data1[rb]
+puts [lb]::math::statistics::map $autoc {[lb]format "%.2f" $x]}[rb]
+puts "Cross-correlation function:"
+set crossc [lb]::math::statistics::crosscorr $data1 $data2[rb]
+puts [lb]::math::statistics::map $crossc {[lb]format "%.2f" $x[rb]}[rb]
+
+::math::statistics::plot-scale .plot1 0 100 -1 4
+::math::statistics::plot-tline .plot1 $autoc "autoc"
+::math::statistics::plot-tline .plot1 $crossc "crossc"
+.plot1 itemconfigure autoc -fill green
+.plot1 itemconfigure crossc -fill yellow
+
+puts "Quantiles: 0.1, 0.2, 0.5, 0.8, 0.9"
+puts "First: [lb]::math::statistics::quantiles $data1 {0.1 0.2 0.5 0.8 0.9}[rb]"
+puts "Second: [lb]::math::statistics::quantiles $data2 {0.1 0.2 0.5 0.8 0.9}[rb]"
+
+[example_end]
+If you run this example, then the following should be clear:
+[list_begin itemized]
+[item]
+There is a strong correlation between two time series, as displayed by
+the raw data and especially by the correlation functions.
+[item]
+Both time series show a significant periodic component
+[item]
+The histograms are not very useful in identifying the nature of the time
+series - they do not show the periodic nature.
+[list_end]
+
+[vset CATEGORY {math :: statistics}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/statistics.tcl b/tcllib/modules/math/statistics.tcl
new file mode 100755
index 0000000..46fb014
--- /dev/null
+++ b/tcllib/modules/math/statistics.tcl
@@ -0,0 +1,1634 @@
+# statistics.tcl --
+#
+# Package for basic statistical analysis
+#
+# version 0.1: initial implementation, january 2003
+# version 0.1.1: added linear regres
+# version 0.1.2: border case in stdev taken care of
+# version 0.1.3: moved initialisation of CDF to first call, november 2004
+# version 0.3: added test for normality (as implemented by Torsten Reincke), march 2006
+# (also fixed an error in the export list)
+# version 0.4: added the multivariate linear regression procedures by
+# Eric Kemp-Benedict, february 2007
+# version 0.5: added the population standard deviation and variance,
+# as suggested by Dimitrios Zachariadis
+# version 0.6: added pdf and cdf procedures for various distributions
+# (provided by Eric Kemp-Benedict)
+# version 0.7: added Kruskal-Wallis test (by Torsten Berg)
+# version 0.8: added Wilcoxon test and Spearman rank correlation
+# version 0.9: added kernel density estimation
+# version 0.9.3: added histogram-alt, corrected test-normal
+
+package require Tcl 8.4
+package provide math::statistics 1.0
+package require math
+
+if {![llength [info commands ::lrepeat]]} {
+ # Forward portability, emulate lrepeat
+ proc ::lrepeat {n args} {
+ if {$n < 1} {
+ return -code error "must have a count of at least 1"
+ }
+ set res {}
+ while {$n} {
+ foreach x $args { lappend res $x }
+ incr n -1
+ }
+ return $res
+ }
+}
+
+# ::math::statistics --
+# Namespace holding the procedures and variables
+#
+
+namespace eval ::math::statistics {
+ #
+ # Safer: change to short procedures
+ #
+ namespace export mean min max number var stdev pvar pstdev basic-stats corr \
+ histogram histogram-alt interval-mean-stdev t-test-mean quantiles \
+ test-normal lillieforsFit \
+ autocorr crosscorr filter map samplescount median \
+ test-2x2 print-2x2 control-xbar test_xbar \
+ control-Rchart test-Rchart \
+ test-Kruskal-Wallis analyse-Kruskal-Wallis group-rank \
+ test-Wilcoxon spearman-rank spearman-rank-extended \
+ test-Duckworth
+ #
+ # Error messages
+ #
+ variable NEGSTDEV {Zero or negative standard deviation}
+ variable TOOFEWDATA {Too few or invalid data}
+ variable OUTOFRANGE {Argument out of range}
+
+ #
+ # Coefficients involved
+ #
+ variable factorNormalPdf
+ set factorNormalPdf [expr {sqrt(8.0*atan(1.0))}]
+
+ # xbar/R-charts:
+ # Data from:
+ # Peter W.M. John:
+ # Statistical methods in engineering and quality assurance
+ # Wiley and Sons, 1990
+ #
+ variable control_factors {
+ A2 {1.880 1.093 0.729 0.577 0.483 0.419 0.419}
+ D3 {0.0 0.0 0.0 0.0 0.0 0.076 0.076}
+ D4 {3.267 2.574 2.282 2.114 2.004 1.924 1.924}
+ }
+}
+
+# mean, min, max, number, var, stdev, pvar, pstdev --
+# Return the mean (minimum, maximum) value of a list of numbers
+# or number of non-missing values
+#
+# Arguments:
+# type Type of value to be returned
+# values List of values to be examined
+#
+# Results:
+# Value that was required
+#
+#
+namespace eval ::math::statistics {
+ foreach type {mean min max number stdev var pstdev pvar} {
+ proc $type { values } "BasicStats $type \$values"
+ }
+ proc basic-stats { values } "BasicStats all \$values"
+}
+
+# BasicStats --
+# Return the one or all of the basic statistical properties
+#
+# Arguments:
+# type Type of value to be returned
+# values List of values to be examined
+#
+# Results:
+# Value that was required
+#
+proc ::math::statistics::BasicStats { type values } {
+ variable TOOFEWDATA
+
+ if { [lsearch {all mean min max number stdev var pstdev pvar} $type] < 0 } {
+ return -code error \
+ -errorcode ARG -errorinfo [list unknown type of statistic -- $type] \
+ [list unknown type of statistic -- $type]
+ }
+
+ set min {}
+ set max {}
+ set mean {}
+ set stdev {}
+ set var {}
+
+ set sum 0.0
+ set sumsq 0.0
+ set number 0
+ set first {}
+
+ foreach value $values {
+ if { $value == {} } {
+ continue
+ }
+ set value [expr {double($value)}]
+
+ if { $first == {} } {
+ set first $value
+ }
+
+ incr number
+ set sum [expr {$sum+$value}]
+ set sumsq [expr {$sumsq+($value-$first)*($value-$first)}]
+
+ if { $min == {} || $value < $min } {
+ set min $value
+ }
+ if { $max == {} || $value > $max } {
+ set max $value
+ }
+ }
+
+ if { $number > 0 } {
+ set mean [expr {$sum/$number}]
+ } else {
+ return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA
+ }
+
+ if { $number > 1 } {
+ set var [expr {($sumsq-($mean-$first)*($sum-$number*$first))/double($number-1)}]
+ #
+ # Take care of a rare situation: uniform data might
+ # cause a tiny negative difference
+ #
+ if { $var < 0.0 } {
+ set var 0.0
+ }
+ set stdev [expr {sqrt($var)}]
+ }
+ set pvar [expr {($sumsq-($mean-$first)*($sum-$number*$first))/double($number)}]
+ #
+ # Take care of a rare situation: uniform data might
+ # cause a tiny negative difference
+ #
+ if { $pvar < 0.0 } {
+ set pvar 0.0
+ }
+ set pstdev [expr {sqrt($pvar)}]
+
+ set all [list $mean $min $max $number $stdev $var $pstdev $pvar]
+
+ #
+ # Return the appropriate value
+ #
+ set $type
+}
+
+# histogram --
+# Return histogram information from a list of numbers
+#
+# Arguments:
+# limits Upper limits for the buckets (in increasing order)
+# values List of values to be examined
+# weights List of weights, one per value (optional)
+#
+# Results:
+# List of number of values in each bucket (length is one more than
+# the number of limits)
+#
+#
+proc ::math::statistics::histogram { limits values {weights {}} } {
+
+ if { [llength $limits] < 1 } {
+ return -code error -errorcode ARG -errorinfo {No limits given} {No limits given}
+ }
+ if { [llength $weights] > 0 && [llength $values] != [llength $weights] } {
+ return -code error -errorcode ARG -errorinfo {Number of weights be equal to number of values} {Weights and values differ in length}
+ }
+
+ set limits [lsort -real -increasing $limits]
+
+ for { set index 0 } { $index <= [llength $limits] } { incr index } {
+ set buckets($index) 0
+ }
+
+ set last [llength $limits]
+
+ # Will do integer arithmetic if unset
+ if {$weights eq ""} {
+ set weights [lrepeat [llength $values] 1]
+ }
+
+ foreach value $values weight $weights {
+ if { $value == {} } {
+ continue
+ }
+
+ set index 0
+ set found 0
+ foreach limit $limits {
+ if { $value <= $limit } {
+ set found 1
+ set buckets($index) [expr $buckets($index)+$weight]
+ break
+ }
+ incr index
+ }
+
+ if { $found == 0 } {
+ set buckets($last) [expr $buckets($last)+$weight]
+ }
+ }
+
+ set result {}
+ for { set index 0 } { $index <= $last } { incr index } {
+ lappend result $buckets($index)
+ }
+
+ return $result
+}
+
+# histogram-alt --
+# Return histogram information from a list of numbers -
+# intervals are open-ended at the lower bound instead of at the upper bound
+#
+# Arguments:
+# limits Upper limits for the buckets (in increasing order)
+# values List of values to be examined
+# weights List of weights, one per value (optional)
+#
+# Results:
+# List of number of values in each bucket (length is one more than
+# the number of limits)
+#
+#
+proc ::math::statistics::histogram-alt { limits values {weights {}} } {
+
+ if { [llength $limits] < 1 } {
+ return -code error -errorcode ARG -errorinfo {No limits given} {No limits given}
+ }
+ if { [llength $weights] > 0 && [llength $values] != [llength $weights] } {
+ return -code error -errorcode ARG -errorinfo {Number of weights be equal to number of values} {Weights and values differ in length}
+ }
+
+ set limits [lsort -real -increasing $limits]
+
+ for { set index 0 } { $index <= [llength $limits] } { incr index } {
+ set buckets($index) 0
+ }
+
+ set last [llength $limits]
+
+ # Will do integer arithmetic if unset
+ if {$weights eq ""} {
+ set weights [lrepeat [llength $values] 1]
+ }
+
+ foreach value $values weight $weights {
+ if { $value == {} } {
+ continue
+ }
+
+ set index 0
+ set found 0
+ foreach limit $limits {
+ if { $value < $limit } {
+ set found 1
+ set buckets($index) [expr $buckets($index)+$weight]
+ break
+ }
+ incr index
+ }
+
+ if { $found == 0 } {
+ set buckets($last) [expr $buckets($last)+$weight]
+ }
+ }
+
+ set result {}
+ for { set index 0 } { $index <= $last } { incr index } {
+ lappend result $buckets($index)
+ }
+
+ return $result
+}
+
+# corr --
+# Return the correlation coefficient of two sets of data
+#
+# Arguments:
+# data1 List with the first set of data
+# data2 List with the second set of data
+#
+# Result:
+# Correlation coefficient of the two
+#
+proc ::math::statistics::corr { data1 data2 } {
+ variable TOOFEWDATA
+
+ set number 0
+ set sum1 0.0
+ set sum2 0.0
+ set sumsq1 0.0
+ set sumsq2 0.0
+ set sumprod 0.0
+
+ foreach value1 $data1 value2 $data2 {
+ if { $value1 == {} || $value2 == {} } {
+ continue
+ }
+ set value1 [expr {double($value1)}]
+ set value2 [expr {double($value2)}]
+
+ set sum1 [expr {$sum1+$value1}]
+ set sum2 [expr {$sum2+$value2}]
+ set sumsq1 [expr {$sumsq1+$value1*$value1}]
+ set sumsq2 [expr {$sumsq2+$value2*$value2}]
+ set sumprod [expr {$sumprod+$value1*$value2}]
+ incr number
+ }
+ if { $number > 0 } {
+ set numerator [expr {$number*$sumprod-$sum1*$sum2}]
+ set denom1 [expr {sqrt($number*$sumsq1-$sum1*$sum1)}]
+ set denom2 [expr {sqrt($number*$sumsq2-$sum2*$sum2)}]
+ if { $denom1 != 0.0 && $denom2 != 0.0 } {
+ set corr_coeff [expr {$numerator/$denom1/$denom2}]
+ } elseif { $denom1 != 0.0 || $denom2 != 0.0 } {
+ set corr_coeff 0.0 ;# Uniform against non-uniform
+ } else {
+ set corr_coeff 1.0 ;# Both uniform
+ }
+
+ } else {
+ return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA
+ }
+ return $corr_coeff
+}
+
+# lillieforsFit --
+# Calculate the goodness of fit according to Lilliefors
+# (goodness of fit to a normal distribution)
+#
+# Arguments:
+# values List of values to be tested for normality
+#
+# Result:
+# Value of the statistic D
+#
+proc ::math::statistics::lillieforsFit {values} {
+ #
+ # calculate the goodness of fit according to Lilliefors
+ # (goodness of fit to a normal distribution)
+ #
+ # values -> list of values to be tested for normality
+ # (these values are sampled counts)
+ #
+
+ # calculate standard deviation and mean of the sample:
+ set n [llength $values]
+ if { $n < 5 } {
+ return -code error "Insufficient number of data (at least five required)"
+ }
+ set sd [stdev $values]
+ set mean [mean $values]
+
+ # sort the sample for further processing:
+ set values [lsort -real $values]
+
+ # standardize the sample data (Z-scores):
+ foreach x $values {
+ lappend stdData [expr {($x - $mean)/double($sd)}]
+ }
+
+ # compute the value of the distribution function at every sampled point:
+ foreach x $stdData {
+ lappend expData [pnorm $x]
+ }
+
+ # compute D+:
+ set i 0
+ foreach x $expData {
+ incr i
+ lappend dplus [expr {$i/double($n)-$x}]
+ }
+ set dplus [lindex [lsort -real $dplus] end]
+
+ # compute D-:
+ set i 0
+ foreach x $expData {
+ incr i
+ lappend dminus [expr {$x-($i-1)/double($n)}]
+ }
+ set dminus [lindex [lsort -real $dminus] end]
+
+ # Calculate the test statistic D
+ # by finding the maximal vertical difference
+ # between the sample and the expectation:
+ #
+ set D [expr {$dplus > $dminus ? $dplus : $dminus}]
+
+ # We now use the modified statistic Z,
+ # because D is only reliable
+ # if the p-value is smaller than 0.1
+ return [expr {$D * (sqrt($n) - 0.01 + 0.831/sqrt($n))}]
+}
+
+# pnorm --
+# Calculate the cumulative distribution function (cdf)
+# for the standard normal distribution like in the statistical
+# software 'R' (mean=0 and sd=1)
+#
+# Arguments:
+# x Value fro which the cdf should be calculated
+#
+# Result:
+# Value of the statistic D
+#
+proc ::math::statistics::pnorm {x} {
+ #
+ # cumulative distribution function (cdf)
+ # for the standard normal distribution like in the statistical software 'R'
+ # (mean=0 and sd=1)
+ #
+ # x -> value for which the cdf should be calculated
+ #
+ set sum [expr {double($x)}]
+ set oldSum 0.0
+ set i 1
+ set denom 1.0
+ while {$sum != $oldSum} {
+ set oldSum $sum
+ incr i 2
+ set denom [expr {$denom*$i}]
+ #puts "$i - $denom"
+ set sum [expr {$oldSum + pow($x,$i)/$denom}]
+ }
+ return [expr {0.5 + $sum * exp(-0.5 * $x*$x - 0.91893853320467274178)}]
+}
+
+# pnorm_quicker --
+# Calculate the cumulative distribution function (cdf)
+# for the standard normal distribution - quicker alternative
+# (less accurate)
+#
+# Arguments:
+# x Value for which the cdf should be calculated
+#
+# Result:
+# Value of the statistic D
+#
+proc ::math::statistics::pnorm_quicker {x} {
+
+ set n [expr {abs($x)}]
+ set n [expr {1.0 + $n*(0.04986735 + $n*(0.02114101 + $n*(0.00327763 \
+ + $n*(0.0000380036 + $n*(0.0000488906 + $n*0.000005383)))))}]
+ set n [expr {1.0/pow($n,16)}]
+ #
+ if {$x >= 0} {
+ return [expr {1 - $n/2.0}]
+ } else {
+ return [expr {$n/2.0}]
+ }
+}
+
+# test-normal --
+# Test for normality (using method Lilliefors)
+#
+# Arguments:
+# data Values that need to be tested
+# significance Level at which the discrepancy from normality is tested
+#
+# Result:
+# 1 if the Lilliefors statistic D is larger than the critical level
+#
+# Note:
+# There was a mistake in the implementation before 0.9.3: confidence (wrong word)
+# instead of significance. To keep compatibility with earlier versions, both
+# significance and 1-significance are accepted.
+#
+proc ::math::statistics::test-normal {data significance} {
+ set D [lillieforsFit $data]
+
+ if { $significance > 0.5 } {
+ set significance [expr {1.0-$significance}] ;# Convert the erroneous levels pre 0.9.3
+ }
+
+ set Dcrit --
+ if { abs($significance-0.20) < 0.0001 } {
+ set Dcrit 0.741
+ }
+ if { abs($significance-0.15) < 0.0001 } {
+ set Dcrit 0.775
+ }
+ if { abs($significance-0.10) < 0.0001 } {
+ set Dcrit 0.819
+ }
+ if { abs($significance-0.05) < 0.0001 } {
+ set Dcrit 0.895
+ }
+ if { abs($significance-0.01) < 0.0001 } {
+ set Dcrit 1.035
+ }
+ if { $Dcrit != "--" } {
+ return [expr {$D > $Dcrit ? 1 : 0 }]
+ } else {
+ return -code error "Significancce level must be one of: 0.20, 0.15, 0.10, 0.05 or 0.01"
+ }
+}
+
+# t-test-mean --
+# Test whether the mean value of a sample is in accordance with the
+# estimated normal distribution with a certain probability
+# (Student's t test)
+#
+# Arguments:
+# data List of raw data values (small sample)
+# est_mean Estimated mean of the distribution
+# est_stdev Estimated stdev of the distribution
+# alpha Probability level (0.95 or 0.99 for instance)
+#
+# Result:
+# 1 if the test is positive, 0 otherwise. If there are too few data,
+# returns an empty string
+#
+proc ::math::statistics::t-test-mean { data est_mean est_stdev alpha } {
+ variable NEGSTDEV
+ variable TOOFEWDATA
+
+ if { $est_stdev <= 0.0 } {
+ return -code error -errorcode ARG -errorinfo $NEGSTDEV $NEGSTDEV
+ }
+
+ set allstats [BasicStats all $data]
+
+ set alpha2 [expr {(1.0+$alpha)/2.0}]
+
+ set sample_mean [lindex $allstats 0]
+ set sample_number [lindex $allstats 3]
+
+ if { $sample_number > 1 } {
+ set tzero [expr {abs($sample_mean-$est_mean)/$est_stdev * \
+ sqrt($sample_number-1)}]
+ set degrees [expr {$sample_number-1}]
+ set prob [cdf-students-t $degrees $tzero]
+
+ return [expr {$prob<$alpha2}]
+
+ } else {
+ return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA
+ }
+}
+
+# interval-mean-stdev --
+# Return the interval containing the mean value and one
+# containing the standard deviation with a certain
+# level of confidence (assuming a normal distribution)
+#
+# Arguments:
+# data List of raw data values
+# confidence Confidence level (0.95 or 0.99 for instance)
+#
+# Result:
+# List having the following elements: lower and upper bounds of
+# mean, lower and upper bounds of stdev
+#
+#
+proc ::math::statistics::interval-mean-stdev { data confidence } {
+ variable TOOFEWDATA
+
+ set allstats [BasicStats all $data]
+
+ set conf2 [expr {(1.0+$confidence)/2.0}]
+ set mean [lindex $allstats 0]
+ set number [lindex $allstats 3]
+ set stdev [lindex $allstats 4]
+
+ if { $number > 1 } {
+ set degrees [expr {$number-1}]
+ set student_t [expr {sqrt([Inverse-cdf-toms322 1 $degrees $conf2])}]
+ set mean_lower [expr {$mean-$student_t*$stdev/sqrt($number)}]
+ set mean_upper [expr {$mean+$student_t*$stdev/sqrt($number)}]
+ set stdev_lower {}
+ set stdev_upper {}
+ return [list $mean_lower $mean_upper $stdev_lower $stdev_upper]
+ } else {
+ return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA
+ }
+}
+
+# quantiles --
+# Return the quantiles for a given set of data or histogram
+#
+# Arguments:
+# (two arguments)
+# data List of raw data values
+# confidence Confidence level (0.95 or 0.99 for instance)
+# (three arguments)
+# limits List of upper limits from histogram
+# counts List of counts for for each interval in histogram
+# confidence Confidence level (0.95 or 0.99 for instance)
+#
+# Result:
+# List of quantiles
+#
+proc ::math::statistics::quantiles { arg1 arg2 {arg3 {}} } {
+ variable TOOFEWDATA
+
+ if { [catch {
+ if { $arg3 == {} } {
+ set result \
+ [::math::statistics::QuantilesRawData $arg1 $arg2]
+ } else {
+ set result \
+ [::math::statistics::QuantilesHistogram $arg1 $arg2 $arg3]
+ }
+ } msg] } {
+ return -code error -errorcode $msg $msg
+ }
+ return $result
+}
+
+# QuantilesRawData --
+# Return the quantiles based on raw data
+#
+# Arguments:
+# data List of raw data values
+# confidence Confidence level (0.95 or 0.99 for instance)
+#
+# Result:
+# List of quantiles
+#
+proc ::math::statistics::QuantilesRawData { data confidence } {
+ variable TOOFEWDATA
+ variable OUTOFRANGE
+
+ if { [llength $confidence] <= 0 } {
+ return -code error -errorcode ARG "$TOOFEWDATA - quantiles"
+ }
+
+ if { [llength $data] <= 0 } {
+ return -code error -errorcode ARG "$TOOFEWDATA - raw data"
+ }
+
+ foreach cond $confidence {
+ if { $cond <= 0.0 || $cond >= 1.0 } {
+ return -code error -errorcode ARG "$OUTOFRANGE - quantiles"
+ }
+ }
+
+ #
+ # Sort the data first
+ #
+ set sorted_data [lsort -real -increasing $data]
+
+ #
+ # Determine the list element lower or equal to the quantile
+ # and return the corresponding value
+ #
+ set result {}
+ set number_data [llength $sorted_data]
+ foreach cond $confidence {
+ set elem [expr {round($number_data*$cond)-1}]
+ if { $elem < 0 } {
+ set elem 0
+ }
+ lappend result [lindex $sorted_data $elem]
+ }
+
+ return $result
+}
+
+# QuantilesHistogram --
+# Return the quantiles based on histogram information only
+#
+# Arguments:
+# limits Upper limits for histogram intervals
+# counts Counts for each interval
+# confidence Confidence level (0.95 or 0.99 for instance)
+#
+# Result:
+# List of quantiles
+#
+proc ::math::statistics::QuantilesHistogram { limits counts confidence } {
+ variable TOOFEWDATA
+ variable OUTOFRANGE
+
+ if { [llength $confidence] <= 0 } {
+ return -code error -errorcode ARG "$TOOFEWDATA - quantiles"
+ }
+
+ if { [llength $confidence] <= 0 } {
+ return -code error -errorcode ARG "$TOOFEWDATA - histogram limits"
+ }
+
+ if { [llength $counts] <= [llength $limits] } {
+ return -code error -errorcode ARG "$TOOFEWDATA - histogram counts"
+ }
+
+ foreach cond $confidence {
+ if { $cond <= 0.0 || $cond >= 1.0 } {
+ return -code error -errorcode ARG "$OUTOFRANGE - quantiles"
+ }
+ }
+
+ #
+ # Accumulate the histogram counts first
+ #
+ set sum 0
+ set accumulated_counts {}
+ foreach count $counts {
+ set sum [expr {$sum+$count}]
+ lappend accumulated_counts $sum
+ }
+ set total_counts $sum
+
+ #
+ # Determine the list element lower or equal to the quantile
+ # and return the corresponding value (use interpolation if
+ # possible)
+ #
+ set result {}
+ foreach cond $confidence {
+ set found 0
+ set bound [expr {round($total_counts*$cond)}]
+ set lower_limit {}
+ set lower_count 0
+ foreach acc_count $accumulated_counts limit $limits {
+ if { $acc_count >= $bound } {
+ set found 1
+ break
+ }
+ set lower_limit $limit
+ set lower_count $acc_count
+ }
+
+ if { $lower_limit == {} || $limit == {} || $found == 0 } {
+ set quant $limit
+ if { $limit == {} } {
+ set quant $lower_limit
+ }
+ } else {
+ set quant [expr {$limit+($lower_limit-$limit) *
+ ($acc_count-$bound)/($acc_count-$lower_count)}]
+ }
+ lappend result $quant
+ }
+
+ return $result
+}
+
+# autocorr --
+# Return the autocorrelation function (assuming equidistance between
+# samples)
+#
+# Arguments:
+# data Raw data for which the autocorrelation must be determined
+#
+# Result:
+# List of autocorrelation values (about 1/2 the number of raw data)
+#
+proc ::math::statistics::autocorr { data } {
+ variable TOOFEWDATA
+
+ if { [llength $data] <= 1 } {
+ return -code error -errorcode ARG "$TOOFEWDATA"
+ }
+
+ return [crosscorr $data $data]
+}
+
+# crosscorr --
+# Return the cross-correlation function (assuming equidistance
+# between samples)
+#
+# Arguments:
+# data1 First set of raw data
+# data2 Second set of raw data
+#
+# Result:
+# List of cross-correlation values (about 1/2 the number of raw data)
+#
+# Note:
+# The number of data pairs is not kept constant - because tests
+# showed rather awkward results when it was kept constant.
+#
+proc ::math::statistics::crosscorr { data1 data2 } {
+ variable TOOFEWDATA
+
+ if { [llength $data1] <= 1 || [llength $data2] <= 1 } {
+ return -code error -errorcode ARG "$TOOFEWDATA"
+ }
+
+ #
+ # First determine the number of data pairs
+ #
+ set number1 [llength $data1]
+ set number2 [llength $data2]
+
+ set basic_stat1 [basic-stats $data1]
+ set basic_stat2 [basic-stats $data2]
+ set vmean1 [lindex $basic_stat1 0]
+ set vmean2 [lindex $basic_stat2 0]
+ set vvar1 [lindex $basic_stat1 end]
+ set vvar2 [lindex $basic_stat2 end]
+
+ set number_pairs $number1
+ if { $number1 > $number2 } {
+ set number_pairs $number2
+ }
+ set number_values $number_pairs
+ set number_delays [expr {$number_values/2.0}]
+
+ set scale [expr {sqrt($vvar1*$vvar2)}]
+
+ set result {}
+ for { set delay 0 } { $delay < $number_delays } { incr delay } {
+ set sumcross 0.0
+ set no_cross 0
+ for { set idx 0 } { $idx < $number_values } { incr idx } {
+ set value1 [lindex $data1 $idx]
+ set value2 [lindex $data2 [expr {$idx+$delay}]]
+ if { $value1 != {} && $value2 != {} } {
+ set sumcross \
+ [expr {$sumcross+($value1-$vmean1)*($value2-$vmean2)}]
+ incr no_cross
+ }
+ }
+ lappend result [expr {$sumcross/($no_cross*$scale)}]
+
+ incr number_values -1
+ }
+
+ return $result
+}
+
+# mean-histogram-limits
+# Determine reasonable limits based on mean and standard deviation
+# for a histogram
+#
+# Arguments:
+# mean Mean of the data
+# stdev Standard deviation
+# number Number of limits to generate (defaults to 8)
+#
+# Result:
+# List of limits
+#
+proc ::math::statistics::mean-histogram-limits { mean stdev {number 8} } {
+ variable NEGSTDEV
+
+ if { $stdev <= 0.0 } {
+ return -code error -errorcode ARG "$NEGSTDEV"
+ }
+ if { $number < 1 } {
+ return -code error -errorcode ARG "Number of limits must be positive"
+ }
+
+ #
+ # Always: between mean-3.0*stdev and mean+3.0*stdev
+ # number = 2: -0.25, 0.25
+ # number = 3: -0.25, 0, 0.25
+ # number = 4: -1, -0.25, 0.25, 1
+ # number = 5: -1, -0.25, 0, 0.25, 1
+ # number = 6: -2, -1, -0.25, 0.25, 1, 2
+ # number = 7: -2, -1, -0.25, 0, 0.25, 1, 2
+ # number = 8: -3, -2, -1, -0.25, 0.25, 1, 2, 3
+ #
+ switch -- $number {
+ "1" { set limits {0.0} }
+ "2" { set limits {-0.25 0.25} }
+ "3" { set limits {-0.25 0.0 0.25} }
+ "4" { set limits {-1.0 -0.25 0.25 1.0} }
+ "5" { set limits {-1.0 -0.25 0.0 0.25 1.0} }
+ "6" { set limits {-2.0 -1.0 -0.25 0.25 1.0 2.0} }
+ "7" { set limits {-2.0 -1.0 -0.25 0.0 0.25 1.0 2.0} }
+ "8" { set limits {-3.0 -2.0 -1.0 -0.25 0.25 1.0 2.0 3.0} }
+ "9" { set limits {-3.0 -2.0 -1.0 -0.25 0.0 0.25 1.0 2.0 3.0} }
+ default {
+ set dlim [expr {6.0/double($number-1)}]
+ for {set i 0} {$i <$number} {incr i} {
+ lappend limits [expr {$dlim*($i-($number-1)/2.0)}]
+ }
+ }
+ }
+
+ set result {}
+ foreach limit $limits {
+ lappend result [expr {$mean+$limit*$stdev}]
+ }
+
+ return $result
+}
+
+# minmax-histogram-limits
+# Determine reasonable limits based on minimum and maximum bounds
+# for a histogram
+#
+# Arguments:
+# min Estimated minimum
+# max Estimated maximum
+# number Number of limits to generate (defaults to 8)
+#
+# Result:
+# List of limits
+#
+proc ::math::statistics::minmax-histogram-limits { min max {number 8} } {
+ variable NEGSTDEV
+
+ if { $number < 1 } {
+ return -code error -errorcode ARG "Number of limits must be positive"
+ }
+ if { $min >= $max } {
+ return -code error -errorcode ARG "Minimum must be lower than maximum"
+ }
+
+ set result {}
+ set dlim [expr {($max-$min)/double($number-1)}]
+ for {set i 0} {$i <$number} {incr i} {
+ lappend result [expr {$min+$dlim*$i}]
+ }
+
+ return $result
+}
+
+# linear-model
+# Determine the coefficients for a linear regression between
+# two series of data (the model: Y = A + B*X)
+#
+# Arguments:
+# xdata Series of independent (X) data
+# ydata Series of dependent (Y) data
+# intercept Whether to use an intercept or not (optional)
+#
+# Result:
+# List of the following items:
+# - (Estimate of) Intercept A
+# - (Estimate of) Slope B
+# - Standard deviation of Y relative to fit
+# - Correlation coefficient R2
+# - Number of degrees of freedom df
+# - Standard error of the intercept A
+# - Significance level of A
+# - Standard error of the slope B
+# - Significance level of B
+#
+#
+proc ::math::statistics::linear-model { xdata ydata {intercept 1} } {
+ variable TOOFEWDATA
+
+ if { [llength $xdata] < 3 } {
+ return -code error -errorcode ARG "$TOOFEWDATA: not enough independent data"
+ }
+ if { [llength $ydata] < 3 } {
+ return -code error -errorcode ARG "$TOOFEWDATA: not enough dependent data"
+ }
+ if { [llength $xdata] != [llength $ydata] } {
+ return -code error -errorcode ARG "$TOOFEWDATA: number of dependent data differs from number of independent data"
+ }
+
+ set sumx 0.0
+ set sumy 0.0
+ set sumx2 0.0
+ set sumy2 0.0
+ set sumxy 0.0
+ set df 0
+ foreach x $xdata y $ydata {
+ if { $x != "" && $y != "" } {
+ set sumx [expr {$sumx+$x}]
+ set sumy [expr {$sumy+$y}]
+ set sumx2 [expr {$sumx2+$x*$x}]
+ set sumy2 [expr {$sumy2+$y*$y}]
+ set sumxy [expr {$sumxy+$x*$y}]
+ incr df
+ }
+ }
+
+ if { $df <= 2 } {
+ return -code error -errorcode ARG "$TOOFEWDATA: too few valid data"
+ }
+ if { $sumx2 == 0.0 } {
+ return -code error -errorcode ARG "$TOOFEWDATA: independent values are all the same"
+ }
+
+ #
+ # Calculate the intermediate quantities
+ #
+ set sx [expr {$sumx2-$sumx*$sumx/$df}]
+ set sy [expr {$sumy2-$sumy*$sumy/$df}]
+ set sxy [expr {$sumxy-$sumx*$sumy/$df}]
+
+ #
+ # Calculate the coefficients
+ #
+ if { $intercept } {
+ set B [expr {$sxy/$sx}]
+ set A [expr {($sumy-$B*$sumx)/$df}]
+ } else {
+ set B [expr {$sumxy/$sumx2}]
+ set A 0.0
+ }
+
+ #
+ # Calculate the error estimates
+ #
+ set stdevY 0.0
+ set varY 0.0
+
+ if { $intercept } {
+ set ve [expr {$sy-$B*$sxy}]
+ if { $ve >= 0.0 } {
+ set varY [expr {$ve/($df-2)}]
+ }
+ } else {
+ set ve [expr {$sumy2-$B*$sumxy}]
+ if { $ve >= 0.0 } {
+ set varY [expr {$ve/($df-1)}]
+ }
+ }
+ set seY [expr {sqrt($varY)}]
+
+ if { $intercept } {
+ set R2 [expr {$sxy*$sxy/($sx*$sy)}]
+ set seA [expr {$seY*sqrt(1.0/$df+$sumx*$sumx/($sx*$df*$df))}]
+ set seB [expr {sqrt($varY/$sx)}]
+ set tA {}
+ set tB {}
+ if { $seA != 0.0 } {
+ set tA [expr {$A/$seA*sqrt($df-2)}]
+ }
+ if { $seB != 0.0 } {
+ set tB [expr {$B/$seB*sqrt($df-2)}]
+ }
+ } else {
+ set R2 [expr {$sumxy*$sumxy/($sumx2*$sumy2)}]
+ set seA {}
+ set tA {}
+ set tB {}
+ set seB [expr {sqrt($varY/$sumx2)}]
+ if { $seB != 0.0 } {
+ set tB [expr {$B/$seB*sqrt($df-1)}]
+ }
+ }
+
+ #
+ # Return the list of parameters
+ #
+ return [list $A $B $seY $R2 $df $seA $tA $seB $tB]
+}
+
+# linear-residuals
+# Determine the difference between actual data and predicted from
+# the linear model
+#
+# Arguments:
+# xdata Series of independent (X) data
+# ydata Series of dependent (Y) data
+# intercept Whether to use an intercept or not (optional)
+#
+# Result:
+# List of differences
+#
+proc ::math::statistics::linear-residuals { xdata ydata {intercept 1} } {
+ variable TOOFEWDATA
+
+ if { [llength $xdata] < 3 } {
+ return -code error -errorcode ARG "$TOOFEWDATA: no independent data"
+ }
+ if { [llength $ydata] < 3 } {
+ return -code error -errorcode ARG "$TOOFEWDATA: no dependent data"
+ }
+ if { [llength $xdata] != [llength $ydata] } {
+ return -code error -errorcode ARG "$TOOFEWDATA: number of dependent data differs from number of independent data"
+ }
+
+ foreach {A B} [linear-model $xdata $ydata $intercept] {break}
+
+ set result {}
+ foreach x $xdata y $ydata {
+ set residue [expr {$y-$A-$B*$x}]
+ lappend result $residue
+ }
+ return $result
+}
+
+# median
+# Determine the median from a list of data
+#
+# Arguments:
+# data (Unsorted) list of data
+#
+# Result:
+# Median (either the middle value or the mean of two values in the
+# middle)
+#
+# Note:
+# Adapted from the Wiki page "Stats", code provided by JPS
+#
+proc ::math::statistics::median { data } {
+ set org_data $data
+ set data {}
+ foreach value $org_data {
+ if { $value != {} } {
+ lappend data $value
+ }
+ }
+ set len [llength $data]
+
+ set data [lsort -real $data]
+ if { $len % 2 } {
+ lindex $data [expr {($len-1)/2}]
+ } else {
+ expr {([lindex $data [expr {($len / 2) - 1}]] \
+ + [lindex $data [expr {$len / 2}]]) / 2.0}
+ }
+}
+
+# test-2x2 --
+# Compute the chi-square statistic for a 2x2 table
+#
+# Arguments:
+# a Element upper-left
+# b Element upper-right
+# c Element lower-left
+# d Element lower-right
+# Return value:
+# Chi-square
+# Note:
+# There is only one degree of freedom - this is important
+# when comparing the value to the tabulated values
+# of chi-square
+#
+proc ::math::statistics::test-2x2 { a b c d } {
+ set ab [expr {$a+$b}]
+ set ac [expr {$a+$c}]
+ set bd [expr {$b+$d}]
+ set cd [expr {$c+$d}]
+ set N [expr {$a+$b+$c+$d}]
+ set det [expr {$a*$d-$b*$c}]
+ set result [expr {double($N*$det*$det)/double($ab*$cd*$ac*$bd)}]
+}
+
+# print-2x2 --
+# Print a 2x2 table
+#
+# Arguments:
+# a Element upper-left
+# b Element upper-right
+# c Element lower-left
+# d Element lower-right
+# Return value:
+# Printed version with marginals
+#
+proc ::math::statistics::print-2x2 { a b c d } {
+ set ab [expr {$a+$b}]
+ set ac [expr {$a+$c}]
+ set bd [expr {$b+$d}]
+ set cd [expr {$c+$d}]
+ set N [expr {$a+$b+$c+$d}]
+ set chisq [test-2x2 $a $b $c $d]
+
+ set line [string repeat - 10]
+ set result [format "%10d%10d | %10d\n" $a $b $ab]
+ append result [format "%10d%10d | %10d\n" $c $d $cd]
+ append result [format "%10s%10s + %10s\n" $line $line $line]
+ append result [format "%10d%10d | %10d\n" $ac $bd $N]
+ append result "Chisquare = $chisq\n"
+ append result "Difference is significant?\n"
+ append result " at 95%: [expr {$chisq<3.84146? "no":"yes"}]\n"
+ append result " at 99%: [expr {$chisq<6.63490? "no":"yes"}]"
+}
+
+# control-xbar --
+# Determine the control lines for an x-bar chart
+#
+# Arguments:
+# data List of observed values (at least 20*nsamples)
+# nsamples Number of data per subsamples (default: 4)
+# Return value:
+# List of: mean, lower limit, upper limit, number of data per
+# subsample. Can be used in the test-xbar procedure
+#
+proc ::math::statistics::control-xbar { data {nsamples 4} } {
+ variable TOOFEWDATA
+ variable control_factors
+
+ #
+ # Check the number of data
+ #
+ if { $nsamples <= 1 } {
+ return -code error -errorcode DATA -errorinfo $OUTOFRANGE \
+ "Number of data per subsample must be at least 2"
+ }
+ if { [llength $data] < 20*$nsamples } {
+ return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA
+ }
+
+ set nogroups [expr {[llength $data]/$nsamples}]
+ set mrange 0.0
+ set xmeans 0.0
+ for { set i 0 } { $i < $nogroups } { incr i } {
+ set subsample [lrange $data [expr {$i*$nsamples}] [expr {$i*$nsamples+$nsamples-1}]]
+
+ set xmean 0.0
+ set xmin [lindex $subsample 0]
+ set xmax $xmin
+ foreach d $subsample {
+ set xmean [expr {$xmean+$d}]
+ set xmin [expr {$xmin<$d? $xmin : $d}]
+ set xmax [expr {$xmax>$d? $xmax : $d}]
+ }
+ set xmean [expr {$xmean/double($nsamples)}]
+
+ set xmeans [expr {$xmeans+$xmean}]
+ set mrange [expr {$mrange+($xmax-$xmin)}]
+ }
+
+ #
+ # Determine the control lines
+ #
+ set xmeans [expr {$xmeans/double($nogroups)}]
+ set mrange [expr {$mrange/double($nogroups)}]
+ set A2 [lindex [lindex $control_factors 1] $nsamples]
+ if { $A2 == "" } { set A2 [lindex [lindex $control_factors 1] end] }
+
+ return [list $xmeans [expr {$xmeans-$A2*$mrange}] \
+ [expr {$xmeans+$A2*$mrange}] $nsamples]
+}
+
+# test-xbar --
+# Determine if any data points lie outside the x-bar control limits
+#
+# Arguments:
+# control List returned by control-xbar with control data
+# data List of observed values
+# Return value:
+# Indices of any subsamples that violate the control limits
+#
+proc ::math::statistics::test-xbar { control data } {
+ foreach {xmean xlower xupper nsamples} $control {break}
+
+ if { [llength $data] < 1 } {
+ return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA
+ }
+
+ set nogroups [expr {[llength $data]/$nsamples}]
+ if { $nogroups <= 0 } {
+ set nogroup 1
+ set nsamples [llength $data]
+ }
+
+ set result {}
+
+ for { set i 0 } { $i < $nogroups } { incr i } {
+ set subsample [lrange $data [expr {$i*$nsamples}] [expr {$i*$nsamples+$nsamples-1}]]
+
+ set xmean 0.0
+ foreach d $subsample {
+ set xmean [expr {$xmean+$d}]
+ }
+ set xmean [expr {$xmean/double($nsamples)}]
+
+ if { $xmean < $xlower } { lappend result $i }
+ if { $xmean > $xupper } { lappend result $i }
+ }
+
+ return $result
+}
+
+# control-Rchart --
+# Determine the control lines for an R chart
+#
+# Arguments:
+# data List of observed values (at least 20*nsamples)
+# nsamples Number of data per subsamples (default: 4)
+# Return value:
+# List of: mean range, lower limit, upper limit, number of data per
+# subsample. Can be used in the test-Rchart procedure
+#
+proc ::math::statistics::control-Rchart { data {nsamples 4} } {
+ variable TOOFEWDATA
+ variable control_factors
+
+ #
+ # Check the number of data
+ #
+ if { $nsamples <= 1 } {
+ return -code error -errorcode DATA -errorinfo $OUTOFRANGE \
+ "Number of data per subsample must be at least 2"
+ }
+ if { [llength $data] < 20*$nsamples } {
+ return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA
+ }
+
+ set nogroups [expr {[llength $data]/$nsamples}]
+ set mrange 0.0
+ for { set i 0 } { $i < $nogroups } { incr i } {
+ set subsample [lrange $data [expr {$i*$nsamples}] [expr {$i*$nsamples+$nsamples-1}]]
+
+ set xmin [lindex $subsample 0]
+ set xmax $xmin
+ foreach d $subsample {
+ set xmin [expr {$xmin<$d? $xmin : $d}]
+ set xmax [expr {$xmax>$d? $xmax : $d}]
+ }
+ set mrange [expr {$mrange+($xmax-$xmin)}]
+ }
+
+ #
+ # Determine the control lines
+ #
+ set mrange [expr {$mrange/double($nogroups)}]
+ set D3 [lindex [lindex $control_factors 3] $nsamples]
+ set D4 [lindex [lindex $control_factors 5] $nsamples]
+ if { $D3 == "" } { set D3 [lindex [lindex $control_factors 3] end] }
+ if { $D4 == "" } { set D4 [lindex [lindex $control_factors 5] end] }
+
+ return [list $mrange [expr {$D3*$mrange}] \
+ [expr {$D4*$mrange}] $nsamples]
+}
+
+# test-Rchart --
+# Determine if any data points lie outside the R-chart control limits
+#
+# Arguments:
+# control List returned by control-xbar with control data
+# data List of observed values
+# Return value:
+# Indices of any subsamples that violate the control limits
+#
+proc ::math::statistics::test-Rchart { control data } {
+ foreach {rmean rlower rupper nsamples} $control {break}
+
+ #
+ # Check the number of data
+ #
+ if { [llength $data] < 1 } {
+ return -code error -errorcode DATA -errorinfo $TOOFEWDATA $TOOFEWDATA
+ }
+
+ set nogroups [expr {[llength $data]/$nsamples}]
+
+ set result {}
+ for { set i 0 } { $i < $nogroups } { incr i } {
+ set subsample [lrange $data [expr {$i*$nsamples}] [expr {$i*$nsamples+$nsamples-1}]]
+
+ set xmin [lindex $subsample 0]
+ set xmax $xmin
+ foreach d $subsample {
+ set xmin [expr {$xmin<$d? $xmin : $d}]
+ set xmax [expr {$xmax>$d? $xmax : $d}]
+ }
+ set range [expr {$xmax-$xmin}]
+
+ if { $range < $rlower } { lappend result $i }
+ if { $range > $rupper } { lappend result $i }
+ }
+
+ return $result
+}
+
+# test-Duckworth --
+# Determine if two data sets have the same median according to the Tukey-Duckworth test
+#
+# Arguments:
+# list1 Values in the first data set
+# list2 Values in the second data set
+# significance Significance level (either 0.05, 0.01 or 0.001)
+#
+# Returns:
+# 0 if the medians are unequal, 1 if they are equal, -1 if the test can not
+# be conducted (the smallest value must be in a different set than the greatest value)
+#
+proc ::math::statistics::test-Duckworth {list1 list2 significance} {
+ set sorted1 [lsort -real $list1]
+ set sorted2 [lsort -real -decreasing $list2]
+
+ set lowest1 [lindex $sorted1 0]
+ set lowest2 [lindex $sorted2 end]
+ set greatest1 [lindex $sorted1 end]
+ set greatest2 [lindex $sorted2 0]
+
+ if { $lowest1 <= $lowest2 && $greatest1 >= $greatest2 } {
+ return -1
+ }
+ if { $lowest1 >= $lowest2 && $greatest1 <= $greatest2 } {
+ return -1
+ }
+
+ #
+ # Determine how many elements of set 1 are lower than the lowest of set 2
+ # Ditto for the number of elements of set 2 greater than the greatest of set 1
+ # (Or vice versa)
+ #
+ if { $lowest1 < $lowest2 } {
+ set lowest $lowest2
+ set greatest $greatest1
+ } else {
+ set lowest $lowest1
+ set greatest $greatest2
+ set sorted1 [lsort -real $list2]
+ set sorted2 [lsort -real -decreasing $list1]
+ #lassign [list $sorted1 $sorted2] sorted2 sorted1
+ }
+
+ set count1 0
+ set count2 0
+ foreach v1 $sorted1 {
+ if { $v1 >= $lowest } {
+ break
+ }
+ incr count1
+ }
+ foreach v2 $sorted2 {
+ if { $v2 <= $greatest } {
+ break
+ }
+ incr count2
+ }
+
+ #
+ # Determine the statistic D, possibly with correction
+ #
+ set n1 [llength $list1]
+ set n2 [llength $list2]
+
+ set correction 0
+ if { 3 + 4*$n1/3 <= $n2 && $n2 <= 2*$n1 } {
+ set correction -1
+ }
+ if { 3 + 4*$n2/3 <= $n1 && $n1 <= 2*$n2 } {
+ set correction -1
+ }
+
+ set D [expr {$count1 + $count2 + $correction}]
+
+ switch -- [string trim $significance 0] {
+ ".05" {
+ return [expr {$D >= 7? 0 : 1}]
+ }
+ ".01" {
+ return [expr {$D >= 10? 0 : 1}]
+ }
+ ".001" {
+ return [expr {$D >= 13? 0 : 1}]
+ }
+ default {
+ return -code error "Significance level must be 0.05, 0.01 or 0.001"
+ }
+ }
+}
+
+
+#
+# Load the auxiliary scripts
+#
+source [file join [file dirname [info script]] pdf_stat.tcl]
+source [file join [file dirname [info script]] plotstat.tcl]
+source [file join [file dirname [info script]] liststat.tcl]
+source [file join [file dirname [info script]] mvlinreg.tcl]
+source [file join [file dirname [info script]] kruskal.tcl]
+source [file join [file dirname [info script]] wilcoxon.tcl]
+source [file join [file dirname [info script]] stat_kernel.tcl]
+
+#
+# Define the tables
+#
+namespace eval ::math::statistics {
+ variable student_t_table
+
+ # set student_t_table [::math::interpolation::defineTable student_t
+ # {X 80% 90% 95% 98% 99%}
+ # {X 0.80 0.90 0.95 0.98 0.99
+ # 1 3.078 6.314 12.706 31.821 63.657
+ # 2 1.886 2.920 4.303 6.965 9.925
+ # 3 1.638 2.353 3.182 4.541 5.841
+ # 5 1.476 2.015 2.571 3.365 4.032
+ # 10 1.372 1.812 2.228 2.764 3.169
+ # 15 1.341 1.753 2.131 2.602 2.947
+ # 20 1.325 1.725 2.086 2.528 2.845
+ # 30 1.310 1.697 2.042 2.457 2.750
+ # 60 1.296 1.671 2.000 2.390 2.660
+ # 1.0e9 1.282 1.645 1.960 2.326 2.576 }]
+
+ # PM
+ #set chi_squared_table [::math::interpolation::defineTable chi_square
+ # ...
+}
+
+#
+# Simple test code
+#
+if { [info exists ::argv0] && ([file tail [info script]] == [file tail $::argv0]) } {
+
+ console show
+ puts [interp aliases]
+
+ set values {1 1 1 1 {}}
+ puts [::math::statistics::basic-stats $values]
+ set values {1 2 3 4}
+ puts [::math::statistics::basic-stats $values]
+ set values {1 -1 1 -2}
+ puts [::math::statistics::basic-stats $values]
+ puts [::math::statistics::mean $values]
+ puts [::math::statistics::min $values]
+ puts [::math::statistics::max $values]
+ puts [::math::statistics::number $values]
+ puts [::math::statistics::stdev $values]
+ puts [::math::statistics::var $values]
+
+ set novals 100
+ #set maxvals 100001
+ set maxvals 1001
+ while { $novals < $maxvals } {
+ set values {}
+ for { set i 0 } { $i < $novals } { incr i } {
+ lappend values [expr {rand()}]
+ }
+ puts [::math::statistics::basic-stats $values]
+ puts [::math::statistics::histogram {0.0 0.2 0.4 0.6 0.8 1.0} $values]
+ set novals [expr {$novals*10}]
+ }
+
+ puts "Normal distribution:"
+ puts "X=0: [::math::statistics::pdf-normal 0.0 1.0 0.0]"
+ puts "X=1: [::math::statistics::pdf-normal 0.0 1.0 1.0]"
+ puts "X=-1: [::math::statistics::pdf-normal 0.0 1.0 -1.0]"
+
+ set data1 {0.0 1.0 3.0 4.0 100.0 -23.0}
+ set data2 {1.0 2.0 4.0 5.0 101.0 -22.0}
+ set data3 {0.0 2.0 6.0 8.0 200.0 -46.0}
+ set data4 {2.0 6.0 8.0 200.0 -46.0 1.0}
+ set data5 {100.0 99.0 90.0 93.0 5.0 123.0}
+ puts "Correlation data1 and data1: [::math::statistics::corr $data1 $data1]"
+ puts "Correlation data1 and data2: [::math::statistics::corr $data1 $data2]"
+ puts "Correlation data1 and data3: [::math::statistics::corr $data1 $data3]"
+ puts "Correlation data1 and data4: [::math::statistics::corr $data1 $data4]"
+ puts "Correlation data1 and data5: [::math::statistics::corr $data1 $data5]"
+
+ # set data {1.0 2.0 2.3 4.0 3.4 1.2 0.6 5.6}
+ # puts [::math::statistics::basicStats $data]
+ # puts [::math::statistics::interval-mean-stdev $data 0.90]
+ # puts [::math::statistics::interval-mean-stdev $data 0.95]
+ # puts [::math::statistics::interval-mean-stdev $data 0.99]
+
+ # puts "\nTest mean values:"
+ # puts [::math::statistics::test-mean $data 2.0 0.1 0.90]
+ # puts [::math::statistics::test-mean $data 2.0 0.5 0.90]
+ # puts [::math::statistics::test-mean $data 2.0 1.0 0.90]
+ # puts [::math::statistics::test-mean $data 2.0 2.0 0.90]
+
+ set rc [catch {
+ set m [::math::statistics::mean {}]
+ } msg ] ; # {}
+ puts "Result: $rc $msg"
+
+ puts "\nTest quantiles:"
+ set data {1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0}
+ set quantiles {0.11 0.21 0.51 0.91 0.99}
+ set limits {2.1 4.1 6.1 8.1}
+ puts [::math::statistics::quantiles $data $quantiles]
+
+ set histogram [::math::statistics::histogram $limits $data]
+ puts [::math::statistics::quantiles $limits $histogram $quantiles]
+
+ puts "\nTest autocorrelation:"
+ set data {1.0 -1.0 1.0 -1.0 1.0 -1.0 1.0 -1.0 1.0}
+ puts [::math::statistics::autocorr $data]
+ set data {1.0 -1.1 2.0 -0.6 3.0 -4.0 0.5 0.9 -1.0}
+ puts [::math::statistics::autocorr $data]
+
+ puts "\nTest histogram limits:"
+ puts [::math::statistics::mean-histogram-limits 1.0 1.0]
+ puts [::math::statistics::mean-histogram-limits 1.0 1.0 4]
+ puts [::math::statistics::minmax-histogram-limits 1.0 10.0 10]
+
+}
+
+#
+# Test xbar/R-chart procedures
+#
+if { 0 } {
+ set data {}
+ for { set i 0 } { $i < 500 } { incr i } {
+ lappend data [expr {rand()}]
+ }
+ set limits [::math::statistics::control-xbar $data]
+ puts $limits
+
+ puts "Outliers? [::math::statistics::test-xbar $limits $data]"
+
+ set newdata {1.0 1.0 1.0 1.0 0.5 0.5 0.5 0.5 10.0 10.0 10.0 10.0}
+ puts "Outliers? [::math::statistics::test-xbar $limits $newdata] -- 0 2"
+
+ set limits [::math::statistics::control-Rchart $data]
+ puts $limits
+
+ puts "Outliers? [::math::statistics::test-Rchart $limits $data]"
+
+ set newdata {0.0 1.0 2.0 1.0 0.4 0.5 0.6 0.5 10.0 0.0 10.0 10.0}
+ puts "Outliers? [::math::statistics::test-Rchart $limits $newdata] -- 0 2"
+}
+
diff --git a/tcllib/modules/math/statistics.test b/tcllib/modules/math/statistics.test
new file mode 100755
index 0000000..11a8ba2
--- /dev/null
+++ b/tcllib/modules/math/statistics.test
@@ -0,0 +1,1043 @@
+# -*- tcl -*-
+# statistics.test --
+# Test cases for the ::math::statistics package
+#
+# Note:
+# The tests assume tcltest 2.1, in order to compare
+# floating-point results
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4;# statistics,linalg!
+testsNeedTcltest 2.1
+
+support {
+ useLocal math.tcl math
+ useLocal linalg.tcl math::linearalgebra
+}
+testing {
+ useLocal statistics.tcl math::statistics
+}
+
+# -------------------------------------------------------------------------
+
+set ::data_uniform [list 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0]
+set ::data_missing [list 1.0 1.0 1.0 {} 1.0 {} {} 1.0 1.0 1.0 1.0 1.0 1.0]
+set ::data_linear [list 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0]
+set ::data_empty [list {} {} {}]
+set ::data_missing2 [list 1.0 2.0 3.0 {} 4.0 5.0 6.0 7.0 8.0 9.0 10.0]
+
+#
+# Create and register (in that order!) custom matching procedures
+#
+proc matchTolerant { expected actual } {
+ set match 1
+ foreach a $actual e $expected {
+ if { abs($e-$a)>0.0001*abs($e) &&
+ abs($e-$a)>0.0001*abs($a) } {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+proc matchTolerant2 { expected actual } {
+ set match 1
+ foreach a $actual e $expected {
+ if { abs($e-$a)>0.025*abs($e) &&
+ abs($e-$a)>0.025*abs($a) } {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+proc matchAlmostZero { expected actual } {
+ set match 1
+ foreach a $actual {
+ if { abs($a)>1.0e-6 } {
+ set match 0
+ break
+ }
+ }
+ return $match
+}
+customMatch tolerant matchTolerant
+customMatch tolerant2 matchTolerant2
+customMatch almostzero matchAlmostZero
+
+#
+# Test cases
+#
+test "BasicStats-1.0" "Basic statistics - uniform data" -match tolerant -body {
+ set all_data [::math::statistics::BasicStats all $::data_uniform]
+} -result [list 1.0 1.0 1.0 [llength $::data_uniform] 0.0 0.0 0.0 0.0]
+
+test "BasicStats-1.1" "Basic statistics - empty data" -match glob -body {
+ catch {
+ set all_data [::math::statistics::BasicStats all $::data_empty]
+ } msg
+ set msg
+} -result "Too*"
+
+#
+# Result must be the same as for 1.0! Hence ::data_empty and ::data_uniform
+#
+test "BasicStats-1.2" "Basic statistics - missing data" -match tolerant -body {
+ set all_data [::math::statistics::BasicStats all $::data_missing]
+} -result [list 1.0 1.0 1.0 [llength $::data_uniform] 0.0 0.0 0.0 0.0]
+
+test "BasicStats-1.3" "Basic statistics - linear data - mean" -match tolerant -body {
+ set value [::math::statistics::mean $::data_linear]
+} -result 5.5
+
+test "BasicStats-1.4" "Basic statistics - linear data - min" -match tolerant -body {
+ set value [::math::statistics::min $::data_linear]
+} -result 1.0
+
+test "BasicStats-1.5" "Basic statistics - linear data - max" -match tolerant -body {
+ set value [::math::statistics::max $::data_linear]
+} -result 10.0
+
+test "BasicStats-1.6" "Basic statistics - linear data - number" -match tolerant -body {
+ set value [::math::statistics::number $::data_linear]
+} -result 10
+
+test "BasicStats-1.7" "Basic statistics - missing data - number" -match tolerant -body {
+ set value [::math::statistics::number $::data_missing2]
+} -result 10
+
+test "BasicStats-1.8" "Basic statistics - missing data - stdev" -match almostzero -body {
+ set value1 [::math::statistics::stdev $::data_linear]
+ set value2 [::math::statistics::stdev $::data_missing2]
+ expr {abs($value1-$value2)}
+} -result 0.001 ;# Zero is impossible
+
+test "BasicStats-1.9" "Basic statistics - missing data - var" -match almostzero -body {
+ set value1 [::math::statistics::stdev $::data_linear]
+ set value2 [::math::statistics::var $::data_missing2]
+ expr {$value1*$value1-$value2}
+} -result 0.001 ;# Zero is impossible
+
+test "BasicStats-1.10" "Basic statistics - missing data - pstdev" -match almostzero -body {
+ set value1 [::math::statistics::pstdev $::data_linear]
+ set value2 [::math::statistics::pstdev $::data_missing2]
+ expr {abs($value1-$value2)}
+} -result 0.001 ;# Zero is impossible
+
+test "BasicStats-1.11" "Basic statistics - missing data - pvar" -match almostzero -body {
+ set value1 [::math::statistics::pstdev $::data_linear]
+ set value2 [::math::statistics::pvar $::data_missing2]
+ expr {$value1*$value1-$value2}
+} -result 0.001 ;# Zero is impossible
+
+#
+# This test was added because the calculation of the standard deviation
+# could fail with uniform data (the difference of two almost equal
+# values became a small negative number)
+#
+# Further extension: more stable computation if the values are very
+# close together. Due to this change the variance should be independent
+# of the mean, however large (up to a point)
+#
+test "BasicStats-2.1" "Basic statistics - uniform data caused sqrt domain error" -body {
+ set values [list]
+ set count 0
+ for { set i 0 } { $i < 20 } { incr i } {
+ lappend values 0.6
+ set value2 [::math::statistics::mean $values]
+ incr count
+ }
+ set count
+} -result 20 ;# We can finish the loop
+
+test "BasicStats-2.2" "Basic statistics - large almost identical values" -match glob -body {
+ catch {
+ set data [list 100001 100002 100003 100004]
+ set result_large [::math::statistics::BasicStats all $data]
+
+ set data [list 1 2 3 4]
+ set result_small [::math::statistics::BasicStats all $data]
+
+ matchTolerant [lrange $result_small 3 end] [lrange $result_large 3 end]
+ } msg
+ set msg
+} -result 1
+
+#
+# Histograms
+#
+test "Histogram-1.0" "Histogram - uniform data" -match glob -body {
+ set values [::math::statistics::histogram {0 2} $::data_uniform]
+} -result [list 0 [llength $::data_uniform] 0]
+
+test "Histogram-1.1" "Histogram - missing data" -match glob -body {
+ set values [::math::statistics::histogram {0 2} $::data_missing]
+} -result [list 0 [::math::statistics::number $::data_missing] 0]
+
+test "Histogram-1.2" "Histogram - linear data" -match glob -body {
+ set values [::math::statistics::histogram {1.5 4.5 9.5} $::data_linear]
+} -result {1 3 5 1}
+
+test "Histogram-1.3" "Histogram - linear data 2" -match glob -body {
+ set values [::math::statistics::histogram {1.5 2.5 10.5} $::data_linear]
+} -result {1 1 8 0}
+
+#
+# Adding two dummy values should not influence the histogram (ticket 05d055c2f5)
+#
+test "Histogram-1.4" "Histogram - linear data 2 with weights" -match glob -body {
+ set values [::math::statistics::histogram {1.5 2.5 10.5} [concat $::data_linear 0.0 0.0] \
+ [concat [lrepeat [llength $::data_linear] 1] 0 0]]
+} -result {1 1 8 0}
+
+test "Histogram-1.5" "Histogram - linear data 2 with weights" -match glob -body {
+ set values [::math::statistics::histogram {1.5 2.5} [concat $::data_linear 0.0 0.0] \
+ [concat [lrepeat [llength $::data_linear] 1] 0 0]]
+} -result {1 1 8}
+
+#
+# Alternative definition of the intervals (ticket 1502400fff)
+# Note the difference in the expected bin sizes for the two
+#
+test "Histogram-2.1" "Histogram - alternative interval bounds" -match glob -body {
+ set values [concat [::math::statistics::histogram-alt {5.0 7.0} $::data_linear] \
+ [::math::statistics::histogram {5.0 7.0} $::data_linear]]
+} -result {4 2 4 5 2 3}
+
+#
+# Quantiles
+# Bug #1272910: related to rounding 0.5 - use different levels instead
+# because another bug was fixed, return to the original
+# levels again
+#
+test "Quantiles-1.0" "Quantiles - raw data" -match tolerant -body {
+ set values [::math::statistics::quantiles $::data_linear {0.25 0.55 0.95}]
+} -result {3.0 6.0 10.0}
+
+test "Quantiles-1.1" "Quantiles - histogram" -match tolerant -body {
+ set limits {1.0 2.0 3.0 4.0}
+ set data_hist {0 10 20 10 0}
+ set values [::math::statistics::quantiles $limits $data_hist {0.25 0.5 0.9}]
+} -result {2.0 2.5 3.6}
+
+#
+# Generate histogram limits
+#
+
+test "Limits-1.0" "Limits - based on mean/stdev" -match tolerant -body {
+ set values [::math::statistics::mean-histogram-limits 1.0 1.0 4]
+} -result {0.0 0.75 1.25 2.0}
+
+test "Limits-1.1" "Limits - based on mean/stdev" -match tolerant -body {
+ set values [::math::statistics::mean-histogram-limits 1.0 1.0 9]
+} -result {-2.0 -1.0 0.0 0.75 1.0 1.25 2.0 3.0 4.0}
+
+test "Limits-1.2" "Limits - based on mean/stdev" -match tolerant -body {
+ set values [::math::statistics::mean-histogram-limits 0.0 1.0 11]
+} -result {-3.0 -2.4 -1.8 -1.2 -0.6 0.0 0.6 1.2 1.8 2.4 3.0}
+
+test "Limits-2.0" "Limits - based on min/max" -match tolerant -body {
+ set values [::math::statistics::minmax-histogram-limits -2.0 2.0 9]
+} -result {-2.0 -1.5 -1.0 -0.5 0.0 0.5 1.0 1.5 2.0}
+
+test "Limits-2.1" "Limits - based on min/max" -match tolerant -body {
+ set values [::math::statistics::minmax-histogram-limits -2.0 2.0 2]
+} -result {-2.0 2.0}
+
+#
+# To do: design test cases for the following functions:
+# - t-test-mean
+# - estimate-mean-stdev
+# - autocorr
+# - crosscorr
+# - linear-model
+# - linear-residuals
+# - pdf-*
+# - cdf-*
+# - random-*
+# - histogram-*
+#
+# Crude test cases for Student's t test
+#
+test "Students-t-test-1.0" "Student's t - same sample" -match glob -body {
+ set sample [::math::statistics::random-normal 0.0 1.0 40]
+ set mean 0.0
+ set stdev 1.0
+ set confidence 0.95
+
+ set result [::math::statistics::t-test-mean $sample $mean $stdev $confidence]
+} -result 1
+
+test "Students-t-test-1.1" "Student's t - different sample" -match glob -body {
+ set sample [::math::statistics::random-normal 0.0 1.0 40]
+ set mean 10.0
+ set stdev 1.0
+ set confidence 0.95
+
+ set result [::math::statistics::t-test-mean $sample $mean $stdev $confidence]
+} -result 0
+
+test "Students-t-test-1.2" "Student's t - small sample" -match glob -body {
+ set sample [::math::statistics::random-normal 0.0 1.0 2]
+ set mean 2.0
+ set stdev 1.0
+ set confidence 0.90
+
+ set result [::math::statistics::t-test-mean $sample $mean $stdev $confidence]
+} -result 1
+
+#
+# Test private procedures
+#
+test "Cdf-toms322-1.0" "TOMS322 - erf(x)" -match tolerant2 -body {
+ set result {}
+ foreach z {4.417 3.891 3.291 2.576 2.241 1.960 1.645 1.150 0.674
+ 0.319 0.126 0.063 0.0125} {
+ set prob [::math::statistics::Cdf-toms322 1 5000 [expr {$z*$z}]]
+ lappend result [expr {1.0-$prob}]
+ }
+ set result
+} -result {1.e-5 1.e-4 1.e-3 1.e-2 0.025 0.050 0.100 0.250 0.500
+ 0.750 0.900 0.950 0.990 }
+
+test "Cdf-toms322-2.0" "TOMS322 - inverse erf(x)" -match tolerant2 -body {
+ set result {}
+ foreach p {0.5120 0.5948 0.7019 0.7996 0.8997 0.9505 0.9901 0.9980 } {
+ set z [::math::statistics::Inverse-cdf-normal 0.0 1.0 $p]
+ lappend result $z
+ }
+ set result
+} -result {0.03 0.24 0.53 0.84 1.28 1.65 2.33 2.88 }
+
+#
+# Correlation coefficients
+#
+test "Correlation-1.0" "Correlation - linear data" -match tolerant -body {
+ set corr [::math::statistics::corr $::data_linear $::data_linear]
+} -result 1.0
+test "Correlation-1.1" "Correlation - linear/uniform" -match almostzero -body {
+ set corr [::math::statistics::corr $::data_linear $::data_uniform]
+} -result 0.0
+
+#
+# Test list procedures
+#
+proc matchListElements { expected actual } {
+ if { [llength $expected] != [llength $actual] } {
+ return 0
+ } else {
+ set match 1
+ foreach a $actual e $expected {
+ if { $a != $e } {
+ set match 0
+ break
+ }
+ }
+ }
+ return $match
+}
+customMatch matchList matchListElements
+
+set ::data_list {1 2 3 4 5 6 7 8 9 10}
+set ::data_pairs {{1 2} {3 4} {5 6} {7 8} {9 10}}
+
+test "Filter-1.0" "True filter" -match matchList -body {
+ set data [::math::statistics::filter x $::data_list 1]
+} -result $::data_list
+
+test "Filter-1.1" "False filter" -match matchList -body {
+ set data [::math::statistics::filter x $::data_list 0]
+} -result {}
+
+test "Filter-1.2" "Even filter" -match matchList -body {
+ set data [::math::statistics::filter x $::data_list {$x%2==0}]
+} -result {2 4 6 8 10}
+
+test "Filter-2.1" "filter with parameter" -match matchList -body {
+ set param 3.0
+ set data [::math::statistics::filter x $::data_list {$x > $param}]
+} -result {4 5 6 7 8 9 10}
+
+test "Map-1.0" "Identity map" -match matchList -body {
+ set data [::math::statistics::map x $::data_list {$x}]
+} -result $::data_list
+
+test "Map-1.1" "Is-even map" -match matchList -body {
+ set data [::math::statistics::map x $::data_list {$x%2==0}]
+} -result {0 1 0 1 0 1 0 1 0 1}
+
+test "Map-1.2" "Double map" -match matchList -body {
+ set data [::math::statistics::map x $::data_list {$x*2}]
+} -result {2 4 6 8 10 12 14 16 18 20}
+
+test "Map-2.1" "map with parameter" -match matchList -body {
+ set param 3.0
+ set data [::math::statistics::map x $::data_list {$x + $param}]
+} -result {4.0 5.0 6.0 7.0 8.0 9.0 10.0 11.0 12.0 13.0}
+
+test "Samplescount-1.0" "Single sublist" -match matchList -body {
+ set data [::math::statistics::samplescount x [list $::data_list]]
+} -result {10}
+
+test "Samplescount-1.1" "List of singleton sublist" -match matchList -body {
+ set data [::math::statistics::samplescount x $::data_list]
+} -result {1 1 1 1 1 1 1 1 1 1}
+
+test "Samplescount-1.2" "Pairs sublist" -match matchList -body {
+ set data [::math::statistics::samplescount x $::data_pairs]
+} -result {2 2 2 2 2}
+
+test "Samplescount-1.3" "Select uneven sublist" -match matchList -body {
+ set data [::math::statistics::samplescount x $::data_pairs {$x%2}]
+} -result {1 1 1 1 1}
+
+test "Samplescount-2.1" "Count with parameter" -match matchList -body {
+ set param 3.0
+ set data [::math::statistics::samplescount x $::data_pairs {$x>$param}]
+} -result {0 1 2 2 2}
+
+test "Median-1.1" "Median - odd number of data" -body {
+ set data {1.0 3.0 2.0}
+ set median [::math::statistics::median $data]
+} -result 2.0
+
+test "Median-1.2" "Median - even number of data" -body {
+ set data {1.0 3.0 2.0 1.0}
+ set median [::math::statistics::median $data]
+} -result 1.5
+
+test "Median-1.3" "Median - missing data" -body {
+ set data {1.0 {} 3.0 2.0 1.0 {}}
+ set median [::math::statistics::median $data]
+} -result 1.5
+
+test "test-2x2-1.0" "Test 2x2" -match tolerant -body {
+ set data [::math::statistics::test-2x2 170 94 30 6]
+} -result 5.1136364
+
+test "test-xbar-1.0" "Test xbar procedure" -match exact -body {
+ set data {}
+ for { set i 0 } { $i < 500 } { incr i } {
+ lappend data [expr {rand()}]
+ }
+ set limits [::math::statistics::control-xbar $data]
+ set newdata {1.0 1.0 1.0 1.0 0.5 0.5 0.5 0.5 10.0 10.0 10.0 10.0}
+ set result [::math::statistics::test-xbar $limits $newdata]
+} -result {0 2}
+
+test "test-Rchart-1.0" "Test Rchart procedure" -match exact -body {
+ set data {}
+ for { set i 0 } { $i < 500 } { incr i } {
+ lappend data [expr {rand()}]
+ }
+ set limits [::math::statistics::control-Rchart $data]
+ set newdata {0.0 1.0 2.0 1.0 0.4 0.5 0.6 0.5 10.0 0.0 10.0 10.0}
+ set result [::math::statistics::test-Rchart $limits $newdata]
+} -result {0 2}
+
+#
+# Testing for normal distribution
+#
+test "Testnormal-1.0" "Determine normality statistic for birth weight data" -match tolerant -body {
+ ::math::statistics::lillieforsFit {72 112 111 107 119 92 126 80 81 84 115
+ 118 128 128 123 116 125 126 122 126 127 86
+ 142 132 87 123 133 106 103 118 114 94}
+} -result 0.82827415657
+
+test "Testnormal-1.0" "Test birthweight data for normality - 20% significance" -match exact -body {
+ ::math::statistics::test-normal {72 112 111 107 119 92 126 80 81 84 115
+ 118 128 128 123 116 125 126 122 126 127 86
+ 142 132 87 123 133 106 103 118 114 94} 0.20
+} -result 1
+
+test "Testnormal-1.0" "Test birthweight data for normality - 5% significance" -match exact -body {
+ ::math::statistics::test-normal {72 112 111 107 119 92 126 80 81 84 115
+ 118 128 128 123 116 125 126 122 126 127 86
+ 142 132 87 123 133 106 103 118 114 94} 0.05
+} -result 0
+
+test "Test-Duckworth-1.0" "Test Tukey-Duckworth - 5% significance" -match exact -body {
+ set list1 {10 2 3 4 6}
+ set list2 {12 3 4 6}
+
+ ::math::statistics::test-Duckworth $list1 $list2 0.05
+} -result 1
+
+test "Test-Duckworth-1.1" "Test Tukey-Duckworth - symmetry" -match exact -body {
+ set list1 {1 2 3 4 5 6 7 8 9 10}
+ set list2 {6 7 8 9 10 11 12 13 14 15 16 17}
+
+ set result [list [::math::statistics::test-Duckworth $list1 $list2 0.05] \
+ [::math::statistics::test-Duckworth $list2 $list1 0.05]]
+} -result {0 0}
+
+test "Test-Duckworth-1.2" "Test Tukey-Duckworth - applicability" -match exact -body {
+ set list1 {2 3 4 6 20}
+ set list2 {12 3 4 6}
+
+ ::math::statistics::test-Duckworth $list1 $list2 0.05
+} -result -1
+
+#
+# Testing multivariate linear regression
+#
+# Provide some data
+test "Testmultivar-1.0" "Ordinary multivariate regression - three independent variables" \
+ -match tolerant -body {
+ set data {
+ { -.67 14.18 60.03 -7.5}
+ { 36.97 15.52 34.24 14.61}
+ {-29.57 21.85 83.36 -7.}
+ {-16.9 11.79 51.67 -6.56}
+ { 14.09 16.24 36.97 -12.84}
+ { 31.52 20.93 45.99 -25.4}
+ { 24.05 20.69 50.27 17.27}
+ { 22.23 16.91 45.07 -4.3}
+ { 40.79 20.49 38.92 -.73}
+ {-10.35 17.24 58.77 18.78}}
+
+ # Call the ols routine
+ set results [::math::statistics::mv-ols $data]
+
+ # Flatten the result (so that we can use the tolerant comparison method)
+ eval concat [eval concat $results]
+} -result {0.887239767929 0.830859651893
+3.33854942057 -1.58346976987 0.0362328113288 32.571621244
+1.03305463908 0.237943867401 0.234143883673 19.4700016828
+0.810755783819 5.86634305732
+-2.16569743834 -1.00124210139 -0.536696631937 0.609162254594
+-15.0697565684 80.2129990564}
+
+#
+# pdf/cdf tests - transformed from the contributions by Eric K. Benedict
+# Cf. the examples.
+#
+# Note: cases with integer numbers test if divisions are done in floating-point or not
+#
+
+test "uniform-distribution-1.0" "Test pdf-uniform" -match tolerant -body {
+ set x [list \
+ [::math::statistics::pdf-uniform 0 10 5] \
+ [::math::statistics::pdf-uniform 0.0 1.0 0.5] \
+ [::math::statistics::pdf-uniform -10.0 1.0 -4.5] \
+ [::math::statistics::pdf-uniform -2.0 2.0 1.0]]
+} -result {0.1 1.0 0.0909090909 0.25}
+
+test "uniform-distribution-1.1" "Test cdf-uniform" -match tolerant -body {
+ set x [list \
+ [::math::statistics::cdf-uniform 0 10 5] \
+ [::math::statistics::cdf-uniform 0.0 1.0 0.5] \
+ [::math::statistics::cdf-uniform -10.0 1.0 -4.5] \
+ [::math::statistics::cdf-uniform -2.0 2.0 1.0]]
+} -result {0.5 0.5 0.5 0.75}
+
+test "exponential-distribution-1.0" "Test pdf-exponential" -match tolerant -body {
+ set x [list \
+ [::math::statistics::pdf-exponential 2 1] \
+ [::math::statistics::pdf-exponential 1.0 1.0] \
+ [::math::statistics::pdf-exponential 2.0 2.0] \
+ [::math::statistics::pdf-exponential 2.0 1.0]]
+} -result {0.3032653298563167 0.36787944117144233 0.18393972058572117 0.3032653298563167}
+
+test "exponential-distribution-1.1" "Test cdf-exponential" -match tolerant -body {
+ set x [list \
+ [::math::statistics::cdf-exponential 2 1] \
+ [::math::statistics::cdf-exponential 1.0 1.0] \
+ [::math::statistics::cdf-exponential 2.0 2.0] \
+ [::math::statistics::cdf-exponential 2.0 1.0]]
+} -result {0.3934693402873666 0.6321205588285577 0.6321205588285577 0.3934693402873666}
+
+test "normal-distribution-1.0" "Test pdf-normal" -match tolerant -body {
+ set x [list \
+ [::math::statistics::pdf-normal 0 1 1] \
+ [::math::statistics::pdf-normal 0.0 1.0 1.0] \
+ [::math::statistics::pdf-normal 2.0 2.0 4.0] \
+ [::math::statistics::pdf-normal -2.0 2.0 0.0] \
+ [::math::statistics::pdf-normal 2.0 2.0 3.0]]
+} -result {0.24197072451914337 0.24197072451914337 0.12098536225957168 0.12098536225957168 0.17603266338214976}
+
+test "normal-distribution-1.1" "Test cdf-normal" -match tolerant -body {
+ set x [list \
+ [::math::statistics::cdf-normal 0 1 1] \
+ [::math::statistics::cdf-normal 0.0 1.0 1.0] \
+ [::math::statistics::cdf-normal 2.0 2.0 4.0] \
+ [::math::statistics::cdf-normal -2.0 2.0 0.0] \
+ [::math::statistics::cdf-normal 2.0 2.0 3.0]]
+} -result {0.8413205502059895 0.8413205502059895 0.8413205502059895 0.8413205502059895 0.691451459572962}
+
+test "lognormal-distribution-1.0" "Test pdf-lognormal" -match tolerant -body {
+ foreach {mu sigma mean stdev} {0.0 1.0 mean1 stdev1 2.0 2.0 mean2 stdev2 -2.0 2.0 mean3 stdev3} {
+ set m [expr {exp($mu + $sigma*$sigma/2.0)}]
+ set $mean $m
+ set $stdev [expr {(exp($sigma*$sigma) - 1.0) * $m*$m}]
+ }
+
+ set x [list \
+ [::math::statistics::pdf-lognormal $mean1 $stdev1 [expr {exp(1.0)}]] \
+ [::math::statistics::pdf-lognormal $mean2 $stdev2 [expr {exp(4.0)}]] \
+ [::math::statistics::pdf-lognormal $mean3 $stdev3 [expr {exp(0.0)}]] \
+ [::math::statistics::pdf-lognormal $mean2 $stdev2 [expr {exp(3.0)}]]]
+} -result {0.24197072451914337 0.12098536225957168 0.12098536225957168 0.17603266338214976}
+
+test "lognormal-distribution-1.1" "Test cdf-lognormal" -match tolerant -body {
+ foreach {mu sigma mean stdev} {0.0 1.0 mean1 stdev1 2.0 2.0 mean2 stdev2 -2.0 2.0 mean3 stdev3} {
+ set m [expr {exp($mu + $sigma*$sigma/2.0)}]
+ set $mean $m
+ set $stdev [expr {(exp($sigma*$sigma) - 1.0) * $m*$m}]
+ }
+
+ set x [list \
+ [::math::statistics::cdf-lognormal $mean1 $stdev1 [expr {exp(1.0)}]] \
+ [::math::statistics::cdf-lognormal $mean2 $stdev2 [expr {exp(4.0)}]] \
+ [::math::statistics::cdf-lognormal $mean3 $stdev3 [expr {exp(0.0)}]] \
+ [::math::statistics::cdf-lognormal $mean2 $stdev2 [expr {exp(3.0)}]]]
+} -result {0.8413205502059895 0.8413205502059895 0.8413205502059895 0.691451459572962}
+
+test "gamma-distribution-1.0" "Test pdf-gamma" -match tolerant -body {
+ set x [list \
+ [::math::statistics::pdf-gamma 1.5 2.7 3.0] \
+ [::math::statistics::pdf-gamma 7.5 0.2 30.0] \
+ [::math::statistics::pdf-gamma 15.0 1.2 2.0]]
+} -result {0.00263194027271168 0.0302770403110644 2.62677891379834e-07}
+
+test "gamma-distribution-1.1" "Test cdf-gamma" -match tolerant -body {
+ set x [list \
+ [::math::statistics::cdf-gamma 1.9 0.45 2.5] \
+ [::math::statistics::cdf-gamma 45.0 2.2 32.7]]
+} -result {0.340299345090375 0.999731419881902}
+
+test "poisson-distribution-1.0" "Test pdf-poisson" -match tolerant -body {
+ set x [list \
+ [::math::statistics::pdf-poisson 100 130] \
+ [::math::statistics::pdf-poisson 27.2 37] \
+ [::math::statistics::pdf-poisson 7.3 11.2]]
+} -result {0.000575252683815462 0.0134122817590761 0.0530940708960824}
+
+test "poisson-distribution-1.1" "Test cdf-poisson" -match tolerant -body {
+ set x [list \
+ [::math::statistics::cdf-poisson 4 7] \
+ [::math::statistics::cdf-poisson 80 70] \
+ [::math::statistics::cdf-poisson 4.9 6.2]]
+} -result {0.948866384207153 0.14338996716003 0.77665467292263}
+
+test "chisquare-distribution-1.0" "Test pdf-chisquare" -match tolerant -body {
+ set x [list \
+ [::math::statistics::pdf-chisquare 3 1.75] \
+ [::math::statistics::pdf-chisquare 10 2.9] \
+ [::math::statistics::pdf-chisquare 4 17.45] \
+ [::math::statistics::pdf-chisquare 2.5 1.8]]
+} -result {0.219999360547348 0.0216024880121444 0.000708787557977144 0.218446210041615}
+
+test "chisquare-distribution-1.1" "Test cdf-chisquare" -match tolerant -body {
+ set x [list \
+ [::math::statistics::cdf-chisquare 2 3.5] \
+ [::math::statistics::cdf-chisquare 5 2.2] \
+ [::math::statistics::cdf-chisquare 5 100] \
+ [::math::statistics::cdf-chisquare 3.9 4.2] \
+ [::math::statistics::cdf-chisquare 1 2.0] \
+ [::math::statistics::cdf-chisquare 3 -2.0]]
+} -result {0.826226056549555 0.179164030785504 1.0 0.634682741547709 0.842700792949715 0.0}
+
+test "students-t-distribution-1.0" "Test pdf-students-t" -match tolerant -body {
+ set x [list \
+ [::math::statistics::pdf-students-t 1 0.1] \
+ [::math::statistics::pdf-students-t 0.5 0.1] \
+ [::math::statistics::pdf-students-t 4 3.2] \
+ [::math::statistics::pdf-students-t 3 2.0] \
+ [::math::statistics::pdf-students-t 3 7.5]]
+} -result {0.315158303152268 0.265700672177405 0.0156821741652879 0.0675096606638929 0.000942291548015668}
+
+test "beta-distribution-1.0" "Test pdf-beta" -match tolerant -body {
+ set x [list \
+ [::math::statistics::pdf-beta 1.3 2.4 0.2] \
+ [::math::statistics::pdf-beta 1 1 0.5] \
+ [::math::statistics::pdf-beta 3.7 0.9 0.0] \
+ [::math::statistics::pdf-beta 1.8 4.2 1.0] \
+ [::math::statistics::pdf-beta 320 400 0.4] \
+ [::math::statistics::pdf-beta 500 1 0.2] \
+ [::math::statistics::pdf-beta 1000 1000 0.50]]
+} -result {1.68903180472449 1.0 0.0 0.0 1.18192376783860 0.0 35.6780222917086}
+
+test "beta-distribution-1.1" "Test cdf-beta" -match tolerant -body {
+ set x [list \
+ [::math::statistics::cdf-beta 2.1 3.0 0.2] \
+ [::math::statistics::cdf-beta 4.2 17.3 0.5] \
+ [::math::statistics::cdf-beta 500 375 0.7] \
+ [::math::statistics::cdf-beta 250 760 0.2] \
+ [::math::statistics::cdf-beta 43.2 19.7 0.6] \
+ [::math::statistics::cdf-beta 500 640 0.3] \
+ [::math::statistics::cdf-beta 400 640 0.3] \
+ [::math::statistics::cdf-beta 0.1 30 0.1] \
+ [::math::statistics::cdf-beta 0.01 0.03 0.9] \
+ [::math::statistics::cdf-beta 2 3 0.9999] \
+ [::math::statistics::cdf-beta 249.9999 759.99999 0.2] \
+ [::math::statistics::cdf-beta 1000 1000 0.4] \
+ [::math::statistics::cdf-beta 1000 1000 0.499] \
+ [::math::statistics::cdf-beta 1000 1000 0.5] \
+ [::math::statistics::cdf-beta 1000 1000 0.7] \
+ [::math::statistics::cdf-beta 2 3 0.6]]
+} -result {0.16220409275804 0.998630771123192 1.0 0.000125234318666948 0.0728881294218269
+ 2.99872547567313e-23 3.07056696205524e-09 0.998641008671625 0.765865005703006
+ 0.999999999996 0.000125237075575121 8.23161135486914e-20 0.464369443974288
+ 0.5 1.0 0.8208}
+
+#
+# TODO: chose the tests with _integer_ arguments more carefully
+#
+test "gumbel-distribution-1.0" "Test pdf-gumbel" -match tolerant -body {
+ set x [list \
+ [::math::statistics::pdf-gumbel 1.0 1.0 0.0] \
+ [::math::statistics::pdf-gumbel 1.0 1.0 0.1] \
+ [::math::statistics::pdf-gumbel 1.0 1.0 0.2] \
+ [::math::statistics::pdf-gumbel 1.0 1.0 1.0] \
+ [::math::statistics::pdf-gumbel 1.0 1.0 2.0] \
+ [::math::statistics::pdf-gumbel 1.0 1.0 5.0] \
+ [::math::statistics::pdf-gumbel 0.1 2.0 0.0] \
+ [::math::statistics::pdf-gumbel 0.1 2.0 1.0] \
+ [::math::statistics::pdf-gumbel 0.1 2.0 2.0] \
+ [::math::statistics::pdf-gumbel 0.1 2.0 5.0] \
+ [::math::statistics::pdf-gumbel 1 1 5 ] ]
+} -result {0.179374 0.210219 0.240378 0.367879 0.254646 0.017983 0.183706 0.168507 0.131350 0.039580 0.017983}
+
+test "gumbel-distribution-1.1" "Test cdf-gumbel" -match tolerant -body {
+ set x [list \
+ [::math::statistics::cdf-gumbel 1.0 1.0 0.0] \
+ [::math::statistics::cdf-gumbel 1.0 1.0 0.2] \
+ [::math::statistics::cdf-gumbel 1.0 1.0 1.0] \
+ [::math::statistics::cdf-gumbel 1.0 1.0 2.0] \
+ [::math::statistics::cdf-gumbel 0.1 2.0 0.0] \
+ [::math::statistics::cdf-gumbel 0.1 2.0 1.0] \
+ [::math::statistics::cdf-gumbel 0.1 2.0 2.0] \
+ [::math::statistics::cdf-gumbel 1 1 2 ] ]
+} -result {0.065988 0.108009 0.367879 0.692201 0.349493 0.528544 0.679266 0.692201}
+
+test "weibull-distribution-1.0" "Test pdf-weibull" -match tolerant -body {
+ set x [list \
+ [::math::statistics::pdf-weibull 1.0 1.0 -1.0] \
+ [::math::statistics::pdf-weibull 1.0 1.0 0.0] \
+ [::math::statistics::pdf-weibull 1.0 1.0 0.1] \
+ [::math::statistics::pdf-weibull 1.0 1.0 0.2] \
+ [::math::statistics::pdf-weibull 1.0 1.0 1.0] \
+ [::math::statistics::pdf-weibull 1.0 1.0 2.0] \
+ [::math::statistics::pdf-weibull 1.0 1.0 5.0] \
+ [::math::statistics::pdf-weibull 2.0 2.0 0.0] \
+ [::math::statistics::pdf-weibull 2.0 2.0 1.0] \
+ [::math::statistics::pdf-weibull 2.0 2.0 2.0] \
+ [::math::statistics::pdf-weibull 2.0 2.0 5.0] ]
+} -result {0 1.0 0.904837 0.818730 0.367879 0.135335 0.006738 0 0.389400 0.367879 0.004826}
+
+test "weibull-distribution-1.1" "Test cdf-weibull" -match tolerant -body {
+ set x [list \
+ [::math::statistics::cdf-weibull 1.0 1.0 -1.0] \
+ [::math::statistics::cdf-weibull 1.0 1.0 0.0] \
+ [::math::statistics::cdf-weibull 1.0 1.0 0.2] \
+ [::math::statistics::cdf-weibull 1.0 1.0 1.0] \
+ [::math::statistics::cdf-weibull 1.0 1.0 2.0] \
+ [::math::statistics::cdf-weibull 2.0 2.0 0.0] \
+ [::math::statistics::cdf-weibull 2.0 2.0 1.0] \
+ [::math::statistics::cdf-weibull 2.0 2.0 2.0] \
+ [::math::statistics::cdf-weibull 2 2 2 ] ]
+} -result {0 0 0.181269 0.632106 0.864665 0 0.221199 0.632121 0.632121}
+
+test "pareto-distribution-1.0" "Test pdf-pareto" -match tolerant -body {
+ set x [list \
+ [::math::statistics::pdf-pareto 1.0 1.0 0.0] \
+ [::math::statistics::pdf-pareto 1.0 1.0 1.1] \
+ [::math::statistics::pdf-pareto 1.0 1.0 1.2] \
+ [::math::statistics::pdf-pareto 1.0 1.0 2.0] \
+ [::math::statistics::pdf-pareto 1.0 1.0 3.0] \
+ [::math::statistics::pdf-pareto 1.0 1.0 5.0] \
+ [::math::statistics::pdf-pareto 2.0 2.0 2.1] \
+ [::math::statistics::pdf-pareto 2.0 2.0 3.0] \
+ [::math::statistics::pdf-pareto 2.0 2.0 5.0] \
+ [::math::statistics::pdf-pareto 2.0 2.0 10.0] ]
+} -result {0 0.826446 0.694444 0.25 0.111111 0.04 0.863838 0.296296 0.064 0.008}
+
+test "pareto-distribution-1.1" "Test cdf-pareto" -match tolerant -body {
+ set x [list \
+ [::math::statistics::cdf-pareto 1.0 1.0 0.0] \
+ [::math::statistics::cdf-pareto 1.0 1.0 1.1] \
+ [::math::statistics::cdf-pareto 1.0 1.0 1.2] \
+ [::math::statistics::cdf-pareto 1.0 1.0 2.0] \
+ [::math::statistics::cdf-pareto 1.0 1.0 3.0] \
+ [::math::statistics::cdf-pareto 2.0 2.0 2.1] \
+ [::math::statistics::cdf-pareto 2.0 2.0 3.0] \
+ [::math::statistics::cdf-pareto 2.0 2.0 5.0] \
+ [::math::statistics::cdf-pareto 2 2 3 ] ]
+} -result {0 0.090909 0.1666667 0.5 0.666667 0.092971 0.555556 0.84 0.555556}
+
+test "cauchy-distribution-1.0" "Test pdf-cauchy" -match tolerant -body {
+ set x [list \
+ [::math::statistics::pdf-cauchy 1.0 1.0 0.0] \
+ [::math::statistics::pdf-cauchy 2.0 1.0 1.0] \
+ [::math::statistics::pdf-cauchy 1.0 2.0 2.0] \
+ [::math::statistics::pdf-cauchy 2.0 2.0 2.0] ]
+} -result {0.1591555 0.1591555 0.1273240 0.1591550}
+
+test "cauchy-distribution-1.1" "Test cdf-cauchy" -match tolerant -body {
+ set x [list \
+ [::math::statistics::cdf-cauchy 1.0 1.0 0.0] \
+ [::math::statistics::cdf-cauchy 2.0 1.0 1.0] \
+ [::math::statistics::cdf-cauchy 1.0 2.0 2.0] \
+ [::math::statistics::cdf-cauchy 2.0 2.0 2.0] ]
+} -result {0.25 0.25 0.6475836 0.5}
+
+test "empirical-distribution-1.0" "Test empirical-distribution" -match tolerant -body {
+ set x {10 4 3 2 5 6 7}
+ set distribution [::math::statistics::empirical-distribution $x]
+} -result {2 0.086207 3 0.224138 4 0.36207 5 0.5 6 0.637910 7 0.775862 10 0.913793}
+
+#
+# Crude tests for the random number generators
+# Mainly to verify that there are no obvious errors
+#
+# To verify that the values are scaled properly, use a fixed seed
+#
+set ::rseed 1000000
+
+test "random-numbers-1.0" "Test random-uniform" -body {
+ expr {srand($::rseed)}
+
+ set rnumbers [::math::statistics::random-uniform 0 10 100]
+
+ set inrange 1
+ foreach r $rnumbers {
+ if { $r < 0.0 || $r > 10.0 } {
+ set inrange 0
+ break
+ }
+ }
+
+ expr {srand($::rseed)}
+ set scaled 1
+ set rnumbers2 [::math::statistics::random-uniform 0 20 100]
+ foreach r1 $rnumbers r2 $rnumbers2 {
+ set scale [expr {$r2 / $r1}]
+ if { abs($scale - 2.0) > 0.00001 } {
+ set scaled 0
+ }
+ }
+ expr {srand($::rseed)}
+ set shifted 1
+ set rnumbers3 [::math::statistics::random-uniform 10 20 100]
+ foreach r1 $rnumbers r3 $rnumbers3 {
+ set shift [expr {$r3 - $r1}]
+ if { abs($shift - 10.0) > 0.00001 } {
+ set shifted 0
+ }
+ }
+
+ set result [list $inrange [llength $rnumbers] $scaled $shifted]
+} -result {1 100 1 1}
+
+test "random-numbers-1.1" "Test random-exponential" -body {
+ expr {srand($::rseed)}
+ set rnumbers [::math::statistics::random-exponential 1 100]
+
+ set inrange 1
+ foreach r $rnumbers {
+ if { $r < 0.0 } {
+ set inrange 0
+ break
+ }
+ }
+
+ expr {srand($::rseed)}
+ set scaled 1
+ set rnumbers2 [::math::statistics::random-exponential 2 100]
+ foreach r1 $rnumbers r2 $rnumbers2 {
+ set scale [expr {$r2 / $r1}]
+ if { abs($scale - 2.0) > 0.00001 } {
+ set scaled 0
+ }
+ }
+ set result [list $inrange [llength $rnumbers] $scaled]
+} -result {1 100 1}
+
+test "random-numbers-1.2" "Test random-normal" -body {
+ set rnumbers [::math::statistics::random-normal 0 1 100]
+ set result [llength $rnumbers]
+} -result 100
+
+test "random-numbers-1.3" "Test random-gamma" -body {
+ set rnumbers [::math::statistics::random-gamma 1.5 2.7 100]
+ set result [llength $rnumbers]
+} -result 100
+
+test "random-numbers-1.4" "Test random-poisson" -body {
+ set rnumbers [::math::statistics::random-poisson 2.5 100]
+ set result [llength $rnumbers]
+} -result 100
+
+test "random-numbers-1.5" "Test random-chisquare" -body {
+ set rnumbers [::math::statistics::random-chisquare 3 100]
+ set result [llength $rnumbers]
+} -result 100
+
+test "random-numbers-1.6" "Test random-students-t" -body {
+ set rnumbers [::math::statistics::random-students-t 3 100]
+ set result [llength $rnumbers]
+} -result 100
+
+test "random-numbers-1.7" "Test random-beta" -body {
+ set rnumbers [::math::statistics::random-beta 1.3 2.4 100]
+ set result 1
+ foreach r $rnumbers {
+ if { $r < 0.0 || $r > 1.0 } {
+ result 0
+ break
+ }
+ }
+ lappend result [llength $rnumbers]
+} -result {1 100}
+
+test "random-numbers-1.8" "Test random-gumbel" -body {
+ set rnumbers [::math::statistics::random-gumbel 1.0 3.0 100]
+ set result [llength $rnumbers]
+} -result 100
+
+test "random-numbers-1.9" "Test random-weibull" -body {
+ set rnumbers [::math::statistics::random-weibull 1.0 3.0 100]
+ set result [llength $rnumbers]
+} -result 100
+
+test "random-numbers-1.10" "Test random-pareto" -body {
+ set rnumbers [::math::statistics::random-pareto 1.0 3.0 100]
+ set result 1
+ foreach r $rnumbers {
+ if { $r < 1.0 } {
+ result 0
+ break
+ }
+ }
+ lappend result [llength $rnumbers]
+} -result {1 100}
+
+test "random-numbers-1.11" "Test random-lognormal" -body {
+ set rnumbers [::math::statistics::random-lognormal 1 1 100]
+ set result [llength $rnumbers]
+} -result 100
+
+test "random-numbers-1.11" "Test random-cauchy" -body {
+ set rnumbers [::math::statistics::random-cauchy 0 1 100]
+ set result [llength $rnumbers]
+} -result 100
+
+test "random-numbers-2.1" "Test estimate-pareto" -match tolerant -body {
+ expr {srand($::rseed)}
+ set rnumbers [::math::statistics::random-pareto 1.0 3.0 100]
+ set result [::math::statistics::estimate-pareto $rnumbers]
+} -result {1.000519 3.668162 0.3668162}
+
+test "kruskal-wallis-1.0" "Test analysis Kruskal-Wallis" -match tolerant -body {
+ ::math::statistics::analyse-Kruskal-Wallis {6.4 6.8 7.2 8.3 8.4 9.1 9.4 9.7} {2.5 3.7 4.9 5.4 5.9 8.1 8.2} {1.3 4.1 4.9 5.2 5.5 8.2}
+} -result {9.83627087199 0.00731275323967}
+test "kruskal-wallis-1.1" "Test test Kruskal-Wallis" -match tolerant -body {
+ ::math::statistics::test-Kruskal-Wallis 0.95 {6.4 6.8 7.2 8.3 8.4 9.1 9.4 9.7} {2.5 3.7 4.9 5.4 5.9 8.1 8.2} {1.3 4.1 4.9 5.2 5.5 8.2}
+} -result 1
+
+# Data from Statistical methods in Engineering and Quality Assurance by Peter W.M. John
+test "wilcoxon-1.0" "Test test Wilcoxon" -match tolerant -body {
+ ::math::statistics::test-Wilcoxon {71.1 68.3 74.8 72.1 71.2 70.4 73.6 66.3 72.7 74.1 70.1 68.5} \
+ {73.3 70.9 74.6 72.1 72.8 74.2 74.7 69.2 75.5 75.8 70.0 72.1}
+} -result -1.67431578065
+
+# Data from the Wikipedia page on Spearman's rank correlation coefficient
+test "spearman-rank-1.0" "Test Spearman rank correlation" -match tolerant -body {
+ ::math::statistics::spearman-rank {106 86 100 101 99 103 97 113 112 110} \
+ { 7 0 27 50 28 29 20 12 6 17}
+} -result -0.175757575758
+
+test "spearman-rank-extended-1.0" "Test extended Spearman rank correlation procedure" -match tolerant -body {
+ ::math::statistics::spearman-rank-extended {106 86 100 101 99 103 97 113 112 110} \
+ { 7 0 27 50 28 29 20 12 6 17}
+} -result {-0.175757575758 10 -0.456397284}
+
+#
+# Note: for the uniform and the logistic kernel the sum deviates more from 1 than for the others.
+# For the logistic kernel this is because the density function is very widespread. For the
+# uniform kernel the reason is not quite clear. Hence the margin per kernel.
+#
+test "kernel-density-1.0" "Test various kernel functions" -body {
+ set data {1 2 3 4 5 6 7 8 9 10}
+
+ set roughlyOne {}
+
+ foreach kernel {gaussian uniform triangular epanechnikov biweight cosine logistic} \
+ margin {0.01 0.02 0.01 0.01 0.01 0.01 0.05 } {
+ set result [::math::statistics::kernel-density $data -kernel $kernel]
+
+ set sum 0.0
+ set xbegin [lindex $result 2 0]
+ set xend [lindex $result 2 1]
+ set number [llength [lindex $result 0]]
+ set dx [expr {($xend-$xbegin) / $number}]
+
+ #
+ # Integral should be roughly one
+ #
+ set sum 0.0
+ foreach v [lindex $result 1] {
+ set sum [expr {$sum + $dx * $v}]
+ }
+
+ lappend roughlyOne [expr {abs($sum-1.0) < $margin}]
+ }
+
+ return $roughlyOne
+} -result {1 1 1 1 1 1 1}
+
+test "kernel-density-1.1" "Test various options - just that they have effect" -body {
+ set subResults {}
+
+ set data {1 2 3 4 5 6 7 8 9 10}
+
+ set result [::math::statistics::kernel-density $data -number 20]
+ lappend subResults [llength [lindex $result 0]] ;# Number of bins
+ lappend subResults [llength [lindex $result 1]] ;# Number of density values
+
+ set result [::math::statistics::kernel-density $data -interval {0 20}]
+ lappend subResults [lindex $result 2 0] ;# Beginning of interval
+ lappend subResults [lindex $result 2 1] ;# End of interval
+ lappend subResults [expr {[lindex $result 0 0] > [lindex $result 2 0]}] ;# First bin -- beginning of interval
+ lappend subResults [expr {[lindex $result 0 0] < [lindex $result 2 1]}] ;# First bin -- end of interval
+ lappend subResults [expr {[lindex $result 0 end] > [lindex $result 2 0]}] ;# Last bin -- beginning of interval
+ lappend subResults [expr {[lindex $result 0 end] < [lindex $result 2 1]}] ;# Last bin -- end of interval
+
+ set result [::math::statistics::kernel-density $data -bandwidth 2]
+ lappend subResults [lindex $result 2 end] ;# Bandwidth
+
+ return $subResults
+} -result {20 20 0 20 1 1 1 1 2}
+
+test "kernel-density-1.2" "Dealing with missing values" -body {
+ set subResults {}
+
+ set data {1 2 3 4 {} 6 7 8 9 10}
+
+ set result [::math::statistics::kernel-density $data]
+
+ set sum 0.0
+ set xbegin [lindex $result 2 0]
+ set xend [lindex $result 2 1]
+ set number [llength [lindex $result 0]]
+ set dx [expr {($xend-$xbegin) / $number}]
+
+ #
+ # Integral should be roughly one
+ #
+ set sum 0.0
+ foreach v [lindex $result 1] {
+ set sum [expr {$sum + $dx * $v}]
+ }
+
+ return [expr {abs($sum-1.0) < 0.01}]
+} -result 1
+
+# End of test cases
+testsuiteCleanup
diff --git a/tcllib/modules/math/symdiff.man b/tcllib/modules/math/symdiff.man
new file mode 100644
index 0000000..7cc06fd
--- /dev/null
+++ b/tcllib/modules/math/symdiff.man
@@ -0,0 +1,72 @@
+[vset VERSION 1.0.1]
+[manpage_begin math::calculus::symdiff n [vset VERSION]]
+[see_also math::calculus]
+[see_also math::interpolate]
+[copyright "2010 by Kevin B. Kenny <kennykb@acm.org>
+Redistribution permitted under the terms of the Open\
+Publication License <http://www.opencontent.org/openpub/>"]
+[moddesc "Symbolic differentiation for Tcl"]
+[titledesc "Symbolic differentiation for Tcl"]
+[require Tcl 8.5]
+[require grammar::aycock 1.0]
+[require math::calculus::symdiff [vset VERSION]]
+[description]
+[para]
+The [cmd math::calculus::symdiff] package provides a symbolic differentiation
+facility for Tcl math expressions. It is useful for providing derivatives
+to packages that either require the Jacobian of a set of functions or else
+are more efficient or stable when the Jacobian is provided.
+[section "Procedures"]
+The [cmd math::calculus::symdiff] package exports the two procedures:
+[list_begin definitions]
+[call [cmd math::calculus::symdiff::symdiff] [arg expression] [arg variable]]
+Differentiates the given [arg expression] with respect to the specified
+[arg variable]. (See [sectref "Expressions"] below for a discussion of the
+subset of Tcl math expressions that are acceptable to
+[cmd math::calculus::symdiff].)
+The result is a Tcl expression that evaluates the derivative. Returns an
+error if [arg expression] is not a well-formed expression or is not
+differentiable.
+[call [cmd math::calculus::jacobian] [arg variableDict]]
+Computes the Jacobian of a system of equations.
+The system is given by the dictionary [arg variableDict], whose keys
+are the names of variables in the system, and whose values are Tcl expressions
+giving the values of those variables. (See [sectref "Expressions"] below
+for a discussion of the subset of Tcl math expressions that are acceptable
+to [cmd math::calculus::symdiff]. The result is a list of lists:
+the i'th element of the j'th sublist is the partial derivative of
+the i'th variable with respect to the j'th variable. Returns an error if
+any of the expressions cannot be differentiated, or if [arg variableDict]
+is not a well-formed dictionary.
+[list_end]
+[section "Expressions"]
+The [cmd math::calculus::symdiff] package accepts only a small subset of the expressions
+that are acceptable to Tcl commands such as [cmd expr] or [cmd if].
+Specifically, the only constructs accepted are:
+[list_begin itemized]
+[item]Floating-point constants such as [const 5] or [const 3.14159e+00].
+[item]References to Tcl variable using $-substitution. The variable names
+must consist of alphanumerics and underscores: the [const \$\{...\}] notation
+is not accepted.
+[item]Parentheses.
+[item]The [const +], [const -], [const *], [const /]. and [const **]
+operators.
+[item]Calls to the functions [cmd acos], [cmd asin], [cmd atan],
+[cmd atan2], [cmd cos], [cmd cosh], [cmd exp], [cmd hypot], [cmd log],
+[cmd log10], [cmd pow], [cmd sin], [cmd sinh]. [cmd sqrt], [cmd tan],
+and [cmd tanh].
+[list_end]
+Command substitution, backslash substitution, and argument expansion are
+not accepted.
+[section "Examples"]
+[example {
+math::calculus::symdiff::symdiff {($a*$x+$b)*($c*$x+$d)} x
+==> (($c * (($a * $x) + $b)) + ($a * (($c * $x) + $d)))
+math::calculus::symdiff::jacobian {x {$a * $x + $b * $y}
+ y {$c * $x + $d * $y}}
+==> {{$a} {$b}} {{$c} {$d}}
+}]
+
+[vset CATEGORY {math :: calculus}]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/math/symdiff.tcl b/tcllib/modules/math/symdiff.tcl
new file mode 100644
index 0000000..79eeb54
--- /dev/null
+++ b/tcllib/modules/math/symdiff.tcl
@@ -0,0 +1,1229 @@
+# symdiff.tcl --
+#
+# Symbolic differentiation package for Tcl
+#
+# This package implements a command, "math::calculus::symdiff::symdiff",
+# which accepts a Tcl expression and a variable name, and if the expression
+# is readily differentiable, returns a Tcl expression that evaluates the
+# derivative.
+#
+# Copyright (c) 2005, 2010 by Kevin B. Kenny. All rights reserved.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: symdiff.tcl,v 1.2 2011/01/13 02:49:53 andreas_kupries Exp $
+
+
+# This package requires the 'tclparser' from http://tclpro.sf.net/
+# to analyze the expressions presented to it.
+
+package require Tcl 8.4
+package require grammar::aycock 1.0
+package provide math::calculus::symdiff 1.0.1
+
+namespace eval math {}
+namespace eval math::calculus {}
+namespace eval math::calculus::symdiff {
+ namespace export jacobian symdiff
+ namespace eval differentiate {}
+}
+
+# math::calculus::symdiff::jacobian --
+#
+# Differentiate a set of expressions with respect to a set of
+# model variables
+#
+# Parameters:
+# model -- A list of alternating {variable name} {expr}
+#
+# Results:
+# Returns a list of lists. The ith sublist is the gradient vector
+# of the ith expr in the model; that is, the jth element of
+# the ith sublist is the derivative of the ith expr with respect
+# to the jth variable.
+#
+# Returns an error if any expression cannot be differentiated with
+# respect to any of the elements of the list, or if the list has
+# no elements or an odd number of elements.
+
+proc math::calculus::symdiff::jacobian {list} {
+ set l [llength $list]
+ if {$l == 0 || $l%2 != 0} {
+ return -code error "list of variables and expressions must have an odd number of elements"
+ }
+ set J {}
+ foreach {- expr} $list {
+ set gradient {}
+ foreach {var -} $list {
+ lappend gradient [symdiff $expr $var]
+ }
+ lappend J $gradient
+ }
+ return $J
+}
+
+# math::calculus::symdiff::symdiff --
+#
+# Differentiate an expression with respect to a variable.
+#
+# Parameters:
+# expr -- expression to differentiate (Must be a Tcl expression,
+# without command substitution.)
+# var -- Name of the variable to differentiate the expression
+# with respect to.
+#
+# Results:
+# Returns a Tcl expression that evaluates the derivative.
+
+proc math::calculus::symdiff::symdiff {expr var} {
+ variable parser
+ set parsetree [$parser parse {*}[Lexer $expr] [namespace current]]
+ return [ToInfix [differentiate::MakeDeriv $parsetree $var]]
+}
+
+# math::calculus::symdiff::Parser --
+#
+# Parser for the mathematical expressions that this package can
+# differentiate.
+
+namespace eval math::calculus::symdiff {
+ variable parser [grammar::aycock::parser {
+ expression ::= expression addop term {
+ set result [${clientData}::MakeOperator [lindex $_ 1]]
+ lappend result [lindex $_ 0] [lindex $_ 2]
+ }
+ expression ::= term {
+ lindex $_ 0
+ }
+
+ addop ::= + {
+ lindex $_ 0
+ }
+ addop ::= - {
+ lindex $_ 0
+ }
+
+ term ::= term mulop factor {
+ set result [${clientData}::MakeOperator [lindex $_ 1]]
+ lappend result [lindex $_ 0] [lindex $_ 2]
+ }
+ term ::= factor {
+ lindex $_ 0
+ }
+ mulop ::= * {
+ lindex $_ 0
+ }
+ mulop ::= / {
+ lindex $_ 0
+ }
+
+ factor ::= addop factor {
+ set result [${clientData}::MakeOperator [lindex $_ 0]]
+ lappend result [lindex $_ 1]
+ }
+ factor ::= expon {
+ lindex $_ 0
+ }
+
+ expon ::= primary ** expon {
+ set result [${clientData}::MakeOperator [lindex $_ 1]]
+ lappend result [lindex $_ 0] [lindex $_ 2]
+ }
+ expon ::= primary {
+ lindex $_ 0
+ }
+
+ primary ::= {$} bareword {
+ ${clientData}::MakeVariable [lindex $_ 1]
+ }
+ primary ::= number {
+ ${clientData}::MakeConstant [lindex $_ 0]
+ }
+ primary ::= bareword ( arglist ) {
+ set result [${clientData}::MakeOperator [lindex $_ 0]]
+ lappend result {*}[lindex $_ 2]
+ }
+ primary ::= ( expression ) {
+ lindex $_ 1
+ }
+
+ arglist ::= expression {
+ set _
+ }
+ arglist ::= arglist , expression {
+ linsert [lindex $_ 0] end [lindex $_ 2]
+ }
+ }]
+}
+
+# math::calculus::symdiff::Lexer --
+#
+# Lexer for the arithmetic expressions that the 'symdiff' package
+# can differentiate.
+#
+# Results:
+# Returns a two element list. The first element is a list of the
+# lexical values of the tokens that were found in the expression;
+# the second is a list of the semantic values of the tokens. The
+# two sublists are the same length.
+
+proc math::calculus::symdiff::Lexer {expression} {
+ set start 0
+ set tokens {}
+ set values {}
+ while {$expression ne {}} {
+ if {[regexp {^\*\*(.*)} $expression -> rest]} {
+
+ # Exponentiation
+
+ lappend tokens **
+ lappend values **
+ } elseif {[regexp {^([-+/*$(),])(.*)} $expression -> token rest]} {
+
+ # Single-character operators
+
+ lappend tokens $token
+ lappend values $token
+ } elseif {[regexp {^([[:alpha:]][[:alnum:]_]*)(.*)} \
+ $expression -> token rest]} {
+
+ # Variable and function names
+
+ lappend tokens bareword
+ lappend values $token
+ } elseif {[regexp -nocase -expanded {
+ ^((?:
+ (?: [[:digit:]]+ (?:[.][[:digit:]]*)? )
+ | (?: [.][[:digit:]]+ ) )
+ (?: e [-+]? [[:digit:]]+ )? )
+ (.*)
+ }\
+ $expression -> token rest]} {
+
+ # Numbers
+
+ lappend tokens number
+ lappend values $token
+ } elseif {[regexp {^[[:space:]]+(.*)} $expression -> rest]} {
+
+ # Whitespace
+
+ } else {
+
+ # Anything else is an error
+
+ return -code error \
+ -errorcode [list MATH SYMDIFF INVCHAR \
+ [string index $expression 0]] \
+ [list invalid character [string index $expression 0]] \
+ }
+ set expression $rest
+ }
+ return [list $tokens $values]
+}
+
+# math::calculus::symdiff::ToInfix --
+#
+# Converts a parse tree to infix notation.
+#
+# Parameters:
+# tree - Parse tree to convert
+#
+# Results:
+# Returns the parse tree as a Tcl expression.
+
+proc math::calculus::symdiff::ToInfix {tree} {
+ set a [lindex $tree 0]
+ set kind [lindex $a 0]
+ switch -exact $kind {
+ constant -
+ text {
+ set result [lindex $tree 1]
+ }
+ var {
+ set result \$[lindex $tree 1]
+ }
+ operator {
+ set name [lindex $a 1]
+ if {([string is alnum $name] && $name ne {eq} && $name ne {ne})
+ || [llength $tree] == 2} {
+ set result $name
+ append result \(
+ set sep ""
+ foreach arg [lrange $tree 1 end] {
+ append result $sep [ToInfix $arg]
+ set sep ", "
+ }
+ append result \)
+ } elseif {[llength $tree] == 3} {
+ set result \(
+ append result [ToInfix [lindex $tree 1]]
+ append result " " $name " "
+ append result [ToInfix [lindex $tree 2]]
+ append result \)
+ } else {
+ error "symdiff encountered a malformed parse, can't happen"
+ }
+ }
+ default {
+ error "symdiff can't synthesize a $kind expression"
+ }
+ }
+ return $result
+}
+
+# math::calculus::symdiff::differentiate::MakeDeriv --
+#
+# Differentiates a Tcl expression represented as a parse tree.
+#
+# Parameters:
+# tree -- Parse tree from MakeParseTreeForExpr
+# var -- Variable to differentiate with respect to
+#
+# Results:
+# Returns the parse tree of the derivative.
+
+proc math::calculus::symdiff::differentiate::MakeDeriv {tree var} {
+ return [eval [linsert $tree 1 $var]]
+}
+
+# math::calculus::symdiff::differentiate::ChainRule --
+#
+# Applies the Chain Rule to evaluate the derivative of a unary
+# function.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# derivMaker -- Command prefix for differentiating the function.
+# u -- Function argument.
+#
+# Results:
+# Returns a parse tree representing the derivative of f($u).
+#
+# ChainRule differentiates $u with respect to $var by calling MakeDeriv,
+# makes the derivative of f($u) with respect to $u by calling derivMaker
+# passing $u as a parameter, and then returns a parse tree representing
+# the product of the results.
+
+proc math::calculus::symdiff::differentiate::ChainRule {var derivMaker u} {
+ lappend derivMaker $u
+ set result [MakeProd [MakeDeriv $u $var] [eval $derivMaker]]
+}
+
+# math::calculus::symdiff::differentiate::constant --
+#
+# Differentiate a constant.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to - unused
+# constant -- Constant expression to differentiate - ignored
+#
+# Results:
+# Returns a parse tree of the derivative, which is, of course, the
+# constant zero.
+
+proc math::calculus::symdiff::differentiate::constant {var constant} {
+ return [MakeConstant 0.0]
+}
+
+# math::calculus::symdiff::differentiate::var --
+#
+# Differentiate a variable expression.
+#
+# Parameters:
+# var - Variable with which to differentiate.
+# exprVar - Expression being differentiated, which is a single
+# variable.
+#
+# Results:
+# Returns a parse tree of the derivative.
+#
+# The derivative is the constant unity if the variables are the same
+# and the constant zero if they are different.
+
+proc math::calculus::symdiff::differentiate::var {var exprVar} {
+ if {$exprVar eq $var} {
+ return [MakeConstant 1.0]
+ } else {
+ return [MakeConstant 0.0]
+ }
+}
+
+# math::calculus::symdiff::differentiate::operator + --
+#
+# Forms the derivative of a sum.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# args -- One or two arguments giving augend and addend. If only
+# one argument is supplied, this is unary +.
+#
+# Results:
+# Returns a parse tree representing the derivative.
+#
+# Of course, the derivative of a sum is the sum of the derivatives.
+
+proc {math::calculus::symdiff::differentiate::operator +} {var args} {
+ if {[llength $args] == 1} {
+ set u [lindex $args 0]
+ set result [eval [linsert $u 1 $var]]
+ } elseif {[llength $args] == 2} {
+ foreach {u v} $args break
+ set du [eval [linsert $u 1 $var]]
+ set dv [eval [linsert $v 1 $var]]
+ set result [MakeSum $du $dv]
+ } else {
+ error "symdiff encountered a malformed parse, can't happen"
+ }
+ return $result
+}
+
+# math::calculus::symdiff::differentiate::operator - --
+#
+# Forms the derivative of a difference.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# args -- One or two arguments giving minuend and subtrahend. If only
+# one argument is supplied, this is unary -.
+#
+# Results:
+# Returns a parse tree representing the derivative.
+#
+# Of course, the derivative of a sum is the sum of the derivatives.
+
+proc {math::calculus::symdiff::differentiate::operator -} {var args} {
+ if {[llength $args] == 1} {
+ set u [lindex $args 0]
+ set du [eval [linsert $u 1 $var]]
+ set result [MakeUnaryMinus $du]
+ } elseif {[llength $args] == 2} {
+ foreach {u v} $args break
+ set du [eval [linsert $u 1 $var]]
+ set dv [eval [linsert $v 1 $var]]
+ set result [MakeDifference $du $dv]
+ } else {
+ error "symdiff encounered a malformed parse, can't happen"
+ }
+ return $result
+}
+
+# math::calculus::symdiff::differentiate::operator * --
+#
+# Forms the derivative of a product.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# u, v -- Multiplicand and multiplier.
+#
+# Results:
+# Returns a parse tree representing the derivative.
+#
+# The familiar freshman calculus product rule.
+
+proc {math::calculus::symdiff::differentiate::operator *} {var u v} {
+ set du [eval [linsert $u 1 $var]]
+ set dv [eval [linsert $v 1 $var]]
+ set result [MakeSum [MakeProd $dv $u] [MakeProd $du $v]]
+ return $result
+}
+
+# math::calculus::symdiff::differentiate::operator / --
+#
+# Forms the derivative of a quotient.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# u, v -- Dividend and divisor.
+#
+# Results:
+# Returns a parse tree representing the derivative.
+#
+# The familiar freshman calculus quotient rule.
+
+proc {math::calculus::symdiff::differentiate::operator /} {var u v} {
+ set du [eval [linsert $u 1 $var]]
+ set dv [eval [linsert $v 1 $var]]
+ set result [MakeQuotient \
+ [MakeDifference \
+ $du \
+ [MakeQuotient \
+ [MakeProd $dv $u] \
+ $v]] \
+ $v]
+ return $result
+}
+
+# math::calculus::symdiff::differentiate::operator acos --
+#
+# Differentiates the 'acos' function.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# u -- Argument to the acos() function.
+#
+# Results:
+# Returns a parse tree of the derivative.
+#
+# Applies the Chain Rule: D(acos(u))=-D(u)/sqrt(1 - u*u)
+# (Might it be better to factor 1-u*u into (1+u)(1-u)? Less likely to be
+# catastrophic cancellation if u is near 1?)
+
+proc {math::calculus::symdiff::differentiate::operator acos} {var u} {
+ set du [eval [linsert $u 1 $var]]
+ set result [MakeQuotient [MakeUnaryMinus $du] \
+ [MakeFunCall sqrt \
+ [MakeDifference [MakeConstant 1.0] \
+ [MakeProd $u $u]]]]
+ return $result
+}
+
+# math::calculus::symdiff::differentiate::operator asin --
+#
+# Differentiates the 'asin' function.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# u -- Argument to the asin() function.
+#
+# Results:
+# Returns a parse tree of the derivative.
+#
+# Applies the Chain Rule: D(asin(u))=D(u)/sqrt(1 - u*u)
+# (Might it be better to factor 1-u*u into (1+u)(1-u)? Less likely to be
+# catastrophic cancellation if u is near 1?)
+
+proc {math::calculus::symdiff::differentiate::operator asin} {var u} {
+ set du [eval [linsert $u 1 $var]]
+ set result [MakeQuotient $du \
+ [MakeFunCall sqrt \
+ [MakeDifference [MakeConstant 1.0] \
+ [MakeProd $u $u]]]]
+ return $result
+}
+
+# math::calculus::symdiff::differentiate::operator atan --
+#
+# Differentiates the 'atan' function.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# u -- Argument to the atan() function.
+#
+# Results:
+# Returns a parse tree of the derivative.
+#
+# Applies the Chain Rule: D(atan(u))=D(u)/(1 + $u*$u)
+
+proc {math::calculus::symdiff::differentiate::operator atan} {var u} {
+ set du [eval [linsert $u 1 $var]]
+ set result [MakeQuotient $du \
+ [MakeSum [MakeConstant 1.0] \
+ [MakeProd $u $u]]]
+}
+
+# math::calculus::symdiff::differentiate::operator atan2 --
+#
+# Differentiates the 'atan2' function.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# f, g -- Arguments to the atan() function.
+#
+# Results:
+# Returns a parse tree of the derivative.
+#
+# Applies the Chain and Quotient Rules:
+# D(atan2(f, g)) = (D(f)*g - D(g)*f)/(f*f + g*g)
+
+proc {math::calculus::symdiff::differentiate::operator atan2} {var f g} {
+ set df [eval [linsert $f 1 $var]]
+ set dg [eval [linsert $g 1 $var]]
+ return [MakeQuotient \
+ [MakeDifference \
+ [MakeProd $df $g] \
+ [MakeProd $f $dg]] \
+ [MakeSum \
+ [MakeProd $f $f] \
+ [MakeProd $g $g]]]
+}
+
+# math::calculus::symdiff::differentiate::operator cos --
+#
+# Differentiates the 'cos' function.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# u -- Argument to the cos() function.
+#
+# Results:
+# Returns a parse tree of the derivative.
+#
+# Applies the Chain Rule: D(cos(u))=-sin(u)*D(u)
+
+proc {math::calculus::symdiff::differentiate::operator cos} {var u} {
+ return [ChainRule $var MakeMinusSin $u]
+}
+proc math::calculus::symdiff::differentiate::MakeMinusSin {operand} {
+ return [MakeUnaryMinus [MakeFunCall sin $operand]]
+}
+
+# math::calculus::symdiff::differentiate::operator cosh --
+#
+# Differentiates the 'cosh' function.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# u -- Argument to the cosh() function.
+#
+# Results:
+# Returns a parse tree of the derivative.
+#
+# Applies the Chain Rule: D(cosh(u))=sinh(u)*D(u)
+
+proc {math::calculus::symdiff::differentiate::operator cosh} {var u} {
+ set result [ChainRule $var [list MakeFunCall sinh] $u]
+ return $result
+}
+
+# math::calculus::symdiff::differentiate::operator exp --
+#
+# Differentiate the exponential function
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# u -- Argument of the exponential function.
+#
+# Results:
+# Returns a parse tree of the derivative.
+#
+# Uses the Chain Rule D(exp(u)) = exp(u)*D(u).
+
+proc {math::calculus::symdiff::differentiate::operator exp} {var u} {
+ set result [ChainRule $var [list MakeFunCall exp] $u]
+ return $result
+}
+
+# math::calculus::symdiff::differentiate::operator hypot --
+#
+# Differentiate the 'hypot' function
+#
+# Parameters:
+# var - Variable to differentiate with respect to.
+# f, g - Arguments to the 'hypot' function
+#
+# Results:
+# Returns a parse tree of the derivative
+#
+# Uses a number of algebraic simplifications to arrive at:
+# D(hypot(f,g)) = (f*D(f)+g*D(g))/hypot(f,g)
+
+proc {math::calculus::symdiff::differentiate::operator hypot} {var f g} {
+ set df [eval [linsert $f 1 $var]]
+ set dg [eval [linsert $g 1 $var]]
+ return [MakeQuotient \
+ [MakeSum \
+ [MakeProd $df $f] \
+ [MakeProd $dg $g]] \
+ [MakeFunCall hypot $f $g]]
+}
+
+# math::calculus::symdiff::differentiate::operator log --
+#
+# Differentiates a logarithm.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# u -- Argument to the log() function.
+#
+# Results:
+# Returns a parse tree of the derivative.
+#
+# D(log(u))==D(u)/u
+
+proc {math::calculus::symdiff::differentiate::operator log} {var u} {
+ set du [eval [linsert $u 1 $var]]
+ set result [MakeQuotient $du $u]
+ return $result
+}
+
+# math::calculus::symdiff::differentiate::operator log10 --
+#
+# Differentiates a common logarithm.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# u -- Argument to the log10() function.
+#
+# Results:
+# Returns a parse tree of the derivative.
+#
+# D(log(u))==D(u)/(u * log(10))
+
+proc {math::calculus::symdiff::differentiate::operator log10} {var u} {
+ set du [eval [linsert $u 1 $var]]
+ set result [MakeQuotient $du \
+ [MakeProd [MakeConstant [expr log(10.)]] $u]]
+ return $result
+}
+
+# math::calculus::symdiff::differentiate::operator ** --
+#
+# Differentiate an exponential.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to
+# f, g -- Base and exponent
+#
+# Results:
+# Returns the parse tree of the derivative.
+#
+# Handles the special case where g is constant as
+# D(f**g) == g*f**(g-1)*D(f)
+# Otherwise, uses the general power formula
+# D(f**g) == (f**g) * (((D(f)*g)/f) + (D(g)*log(f)))
+
+proc {math::calculus::symdiff::differentiate::operator **} {var f g} {
+ set df [eval [linsert $f 1 $var]]
+ if {[IsConstant $g]} {
+ set gm1 [MakeConstant [expr {[ConstantValue $g] - 1}]]
+ set result [MakeProd $df [MakeProd $g [MakePower $f $gm1]]]
+
+ } else {
+ set dg [eval [linsert $g 1 $var]]
+ set result [MakeProd [MakePower $f $g] \
+ [MakeSum \
+ [MakeQuotient [MakeProd $df $g] $f] \
+ [MakeProd $dg [MakeFunCall log $f]]]]
+ }
+ return $result
+}
+interp alias {} {math::calculus::symdiff::differentiate::operator pow} \
+ {} {math::calculus::symdiff::differentiate::operator **}
+
+# math::calculus::symdiff::differentiate::operator sin --
+#
+# Differentiates the 'sin' function.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# u -- Argument to the sin() function.
+#
+# Results:
+# Returns a parse tree of the derivative.
+#
+# Applies the Chain Rule: D(sin(u))=cos(u)*D(u)
+
+proc {math::calculus::symdiff::differentiate::operator sin} {var u} {
+ set result [ChainRule $var [list MakeFunCall cos] $u]
+ return $result
+}
+
+# math::calculus::symdiff::differentiate::operator sinh --
+#
+# Differentiates the 'sinh' function.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# u -- Argument to the sinh() function.
+#
+# Results:
+# Returns a parse tree of the derivative.
+#
+# Applies the Chain Rule: D(sin(u))=cosh(u)*D(u)
+
+proc {math::calculus::symdiff::differentiate::operator sinh} {var u} {
+ set result [ChainRule $var [list MakeFunCall cosh] $u]
+ return $result
+}
+
+# math::calculus::symdiff::differentiate::operator sqrt --
+#
+# Differentiate the 'sqrt' function.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to
+# u -- Parameter of 'sqrt' as a parse tree.
+#
+# Results:
+# Returns a parse tree representing the derivative.
+#
+# D(sqrt(u))==D(u)/(2*sqrt(u))
+
+proc {math::calculus::symdiff::differentiate::operator sqrt} {var u} {
+ set du [eval [linsert $u 1 $var]]
+ set result [MakeQuotient $du [MakeProd [MakeConstant 2.0] \
+ [MakeFunCall sqrt $u]]]
+ return $result
+}
+
+# math::calculus::symdiff::differentiate::operator tan --
+#
+# Differentiates the 'tan' function.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# u -- Argument to the tan() function.
+#
+# Results:
+# Returns a parse tree of the derivative.
+#
+# Applies the Chain Rule: D(tan(u))=D(u)/(cos(u)*cos(u))
+
+proc {math::calculus::symdiff::differentiate::operator tan} {var u} {
+ set du [eval [linsert $u 1 $var]]
+ set cosu [MakeFunCall cos $u]
+ return [MakeQuotient $du [MakeProd $cosu $cosu]]
+}
+
+# math::calculus::symdiff::differentiate::operator tanh --
+#
+# Differentiates the 'tanh' function.
+#
+# Parameters:
+# var -- Variable to differentiate with respect to.
+# u -- Argument to the tanh() function.
+#
+# Results:
+# Returns a parse tree of the derivative.
+#
+# Applies the Chain Rule: D(tanh(u))=D(u)/(cosh(u)*cosh(u))
+
+proc {math::calculus::symdiff::differentiate::operator tanh} {var u} {
+ set du [eval [linsert $u 1 $var]]
+ set coshu [MakeFunCall cosh $u]
+ return [MakeQuotient $du [MakeProd $coshu $coshu]]
+}
+
+# math::calculus::symdiff::MakeFunCall --
+#
+# Makes a parse tree for a function call
+#
+# Parameters:
+# fun -- Name of the function to call
+# args -- Arguments to the function, expressed as parse trees
+#
+# Results:
+# Returns a parse tree for the result of calling the function.
+#
+# Performs the peephole optimization of replacing a function with
+# constant parameters with its value.
+
+proc math::calculus::symdiff::MakeFunCall {fun args} {
+ set constant 1
+ set exp $fun
+ append exp \(
+ set sep ""
+ foreach a $args {
+ if {[IsConstant $a]} {
+ append exp $sep [ConstantValue $a]
+ set sep ","
+ } else {
+ set constant 0
+ break
+ }
+ }
+ if {$constant} {
+ append exp \)
+ return [MakeConstant [expr $exp]]
+ }
+ set result [MakeOperator $fun]
+ foreach arg $args {
+ lappend result $arg
+ }
+ return $result
+}
+
+# math::calculus::symdiff::MakeSum --
+#
+# Makes the parse tree for a sum.
+#
+# Parameters:
+# left, right -- Parse trees for augend and addend
+#
+# Results:
+# Returns the parse tree for the sum.
+#
+# Performs the following peephole optimizations:
+# (1) a + (-b) = a - b
+# (2) (-a) + b = b - a
+# (3) 0 + a = a
+# (4) a + 0 = a
+# (5) The sum of two constants may be reduced to a constant
+
+proc math::calculus::symdiff::MakeSum {left right} {
+ if {[IsUnaryMinus $right]} {
+ return [MakeDifference $left [UnaryMinusArg $right]]
+ }
+ if {[IsUnaryMinus $left]} {
+ return [MakeDifference $right [UnaryMinusArg $left]]
+ }
+ if {[IsConstant $left]} {
+ set v [ConstantValue $left]
+ if {$v == 0} {
+ return $right
+ } elseif {[IsConstant $right]} {
+ return [MakeConstant [expr {[ConstantValue $left]
+ + [ConstantValue $right]}]]
+ }
+ } elseif {[IsConstant $right]} {
+ set v [ConstantValue $right]
+ if {$v == 0} {
+ return $left
+ }
+ }
+ set result [MakeOperator +]
+ lappend result $left $right
+ return $result
+}
+
+# math::calculus::symdiff::MakeDifference --
+#
+# Makes the parse tree for a difference
+#
+# Parameters:
+# left, right -- Minuend and subtrahend, expressed as parse trees
+#
+# Results:
+# Returns a parse tree expressing the difference
+#
+# Performs the following peephole optimizations:
+# (1) a - (-b) = a + b
+# (2) -a - b = -(a + b)
+# (3) 0 - b = -b
+# (4) a - 0 = a
+# (5) The difference of any two constants can be reduced to a constant.
+
+proc math::calculus::symdiff::MakeDifference {left right} {
+ if {[IsUnaryMinus $right]} {
+ return [MakeSum $left [UnaryMinusArg $right]]
+ }
+ if {[IsUnaryMinus $left]} {
+ return [MakeUnaryMinus [MakeSum [UnaryMinusArg $left] $right]]
+ }
+ if {[IsConstant $left]} {
+ set v [ConstantValue $left]
+ if {$v == 0} {
+ return [MakeUnaryMinus $right]
+ } elseif {[IsConstant $right]} {
+ return [MakeConstant [expr {[ConstantValue $left]
+ - [ConstantValue $right]}]]
+ }
+ } elseif {[IsConstant $right]} {
+ set v [ConstantValue $right]
+ if {$v == 0} {
+ return $left
+ }
+ }
+ set result [MakeOperator -]
+ lappend result $left $right
+ return $result
+}
+
+# math::calculus::symdiff::MakeProd --
+#
+# Constructs the parse tree for a product, left*right.
+#
+# Parameters:
+# left, right - Multiplicand and multiplier
+#
+# Results:
+# Returns the parse tree for the result.
+#
+# Performs the following peephole optimizations.
+# (1) If either operand is a unary minus, it is hoisted out of the
+# expression.
+# (2) If either operand is the constant 0, the result is the constant 0
+# (3) If either operand is the constant 1, the result is the other operand.
+# (4) If either operand is the constant -1, the result is unary minus
+# applied to the other operand
+# (5) If both operands are constant, the result is a constant containing
+# their product.
+
+proc math::calculus::symdiff::MakeProd {left right} {
+ if {[IsUnaryMinus $left]} {
+ return [MakeUnaryMinus [MakeProd [UnaryMinusArg $left] $right]]
+ }
+ if {[IsUnaryMinus $right]} {
+ return [MakeUnaryMinus [MakeProd $left [UnaryMinusArg $right]]]
+ }
+ if {[IsConstant $left]} {
+ set v [ConstantValue $left]
+ if {$v == 0} {
+ return [MakeConstant 0.0]
+ } elseif {$v == 1} {
+ return $right
+ } elseif {$v == -1} {
+ return [MakeUnaryMinus $right]
+ } elseif {[IsConstant $right]} {
+ return [MakeConstant [expr {[ConstantValue $left]
+ * [ConstantValue $right]}]]
+ }
+ } elseif {[IsConstant $right]} {
+ set v [ConstantValue $right]
+ if {$v == 0} {
+ return [MakeConstant 0.0]
+ } elseif {$v == 1} {
+ return $left
+ } elseif {$v == -1} {
+ return [MakeUnaryMinus $left]
+ }
+ }
+ set result [MakeOperator *]
+ lappend result $left $right
+ return $result
+}
+
+# math::calculus::symdiff::MakeQuotient --
+#
+# Makes a parse tree for a quotient, n/d
+#
+# Parameters:
+# n, d - Parse trees for numerator and denominator
+#
+# Results:
+# Returns the parse tree for the quotient.
+#
+# Performs peephole optimizations:
+# (1) If either operand is a unary minus, it is hoisted out.
+# (2) If the numerator is the constant 0, the result is the constant 0.
+# (3) If the demominator is the constant 1, the result is the numerator
+# (4) If the denominator is the constant -1, the result is the unary
+# negation of the numerator.
+# (5) If both numerator and denominator are constant, the result is
+# a constant representing their quotient.
+
+proc math::calculus::symdiff::MakeQuotient {n d} {
+ if {[IsUnaryMinus $n]} {
+ return [MakeUnaryMinus [MakeQuotient [UnaryMinusArg $n] $d]]
+ }
+ if {[IsUnaryMinus $d]} {
+ return [MakeUnaryMinus [MakeQuotient $n [UnaryMinusArg $d]]]
+ }
+ if {[IsConstant $n]} {
+ set v [ConstantValue $n]
+ if {$v == 0} {
+ return [MakeConstant 0.0]
+ } elseif {[IsConstant $d]} {
+ return [MakeConstant [expr {[ConstantValue $n]
+ * [ConstantValue $d]}]]
+ }
+ } elseif {[IsConstant $d]} {
+ set v [ConstantValue $d]
+ if {$v == 0} {
+ return -code error "requested expression will result in division by zero at run time"
+ } elseif {$v == 1} {
+ return $n
+ } elseif {$v == -1} {
+ return [MakeUnaryMinus $n]
+ }
+ }
+ set result [MakeOperator /]
+ lappend result $n $d
+ return $result
+}
+
+# math::calculus::symdiff::MakePower --
+#
+# Make a parse tree for an exponentiation operation
+#
+# Parameters:
+# a -- Base, expressed as a parse tree
+# b -- Exponent, expressed as a parse tree
+#
+# Results:
+# Returns a parse tree for the expression
+#
+# Performs peephole optimizations:
+# (1) The constant zero raised to any non-zero power is 0
+# (2) The constant 1 raised to any power is 1
+# (3) Any non-zero quantity raised to the zero power is 1
+# (4) Any non-zero quantity raised to the first power is the base itself.
+# (5) MakeFunCall will optimize any other case of a constant raised
+# to a constant power.
+
+proc math::calculus::symdiff::MakePower {a b} {
+ if {[IsConstant $a]} {
+ if {[ConstantValue $a] == 0} {
+ if {[IsConstant $b] && [ConstantValue $b] == 0} {
+ error "requested expression will result in zero to zero power at run time"
+ }
+ return [MakeConstant 0.0]
+ } elseif {[ConstantValue $a] == 1} {
+ return [MakeConstant 1.0]
+ }
+ }
+ if {[IsConstant $b]} {
+ if {[ConstantValue $b] == 0} {
+ return [MakeConstant 1.0]
+ } elseif {[ConstantValue $b] == 1} {
+ return $a
+ }
+ }
+ return [MakeFunCall pow $a $b]
+}
+
+# math::calculus::symdiff::MakeUnaryMinus --
+#
+# Makes the parse tree for a unary negation.
+#
+# Parameters:
+# operand -- Parse tree for the operand
+#
+# Results:
+# Returns the parse tree for the expression
+#
+# Performs the following peephole optimizations:
+# (1) -(-$a) = $a
+# (2) The unary negation of a constant is another constant
+
+proc math::calculus::symdiff::MakeUnaryMinus {operand} {
+ if {[IsUnaryMinus $operand]} {
+ return [UnaryMinusArg $operand]
+ }
+ if {[IsConstant $operand]} {
+ return [MakeConstant [expr {-[ConstantValue $operand]}]]
+ } else {
+ return [list [list operator -] $operand]
+ }
+}
+
+# math::calculus::symdiff::IsUnaryMinus --
+#
+# Determines whether a parse tree represents a unary negation
+#
+# Parameters:
+# x - Parse tree to examine
+#
+# Results:
+# Returns 1 if the parse tree represents a unary minus, 0 otherwise
+
+proc math::calculus::symdiff::IsUnaryMinus {x} {
+ return [expr {[llength $x] == 2
+ && [lindex $x 0] eq [list operator -]}]
+}
+
+# math::calculus::symdiff::UnaryMinusArg --
+#
+# Extracts the argument from a unary negation.
+#
+# Parameters:
+# x - Parse tree to examine, known to represent a unary negation
+#
+# Results:
+# Returns a parse tree representing the operand.
+
+proc math::calculus::symdiff::UnaryMinusArg {x} {
+ return [lindex $x 1]
+}
+
+# math::calculus::symdiff::MakeOperator --
+#
+# Makes a partial parse tree for an operator
+#
+# Parameters:
+# op -- Name of the operator
+#
+# Results:
+# Returns the resulting parse tree.
+#
+# The caller may use [lappend] to place any needed operands
+
+proc math::calculus::symdiff::MakeOperator {op} {
+ if {$op eq {?}} {
+ return -code error "symdiff can't differentiate the ternary ?: operator"
+ } elseif {[namespace which [list differentiate::operator $op]] ne {}} {
+ return [list [list operator $op]]
+ } elseif {[string is alnum $op] && ($op ni {eq ne in ni})} {
+ return -code error "symdiff can't differentiate the \"$op\" function"
+ } else {
+ return -code error "symdiff can't differentiate the \"$op\" operator"
+ }
+}
+
+# math::calculus::symdiff::MakeVariable --
+#
+# Makes a partial parse tree for a single variable
+#
+# Parameters:
+# name -- Name of the variable
+#
+# Results:
+# Returns a partial parse tree giving the variable
+
+proc math::calculus::symdiff::MakeVariable {name} {
+ return [list var $name]
+}
+
+# math::calculus::symdiff::MakeConstant --
+#
+# Make the parse tree for a constant.
+#
+# Parameters:
+# value -- The constant's value
+#
+# Results:
+# Returns a parse tree.
+
+proc math::calculus::symdiff::MakeConstant {value} {
+ return [list constant $value]
+}
+
+# math::calculus::symdiff::IsConstant --
+#
+# Test if an expression represented by a parse tree is a constant.
+#
+# Parameters:
+# Item - Parse tree to test
+#
+# Results:
+# Returns 1 for a constant, 0 for anything else
+
+proc math::calculus::symdiff::IsConstant {item} {
+ return [expr {[lindex $item 0] eq {constant}}]
+}
+
+# math::calculus::symdiff::ConstantValue --
+#
+# Recovers a constant value from the parse tree representing a constant
+# expression.
+#
+# Parameters:
+# item -- Parse tree known to be a constant.
+#
+# Results:
+# Returns the constant value.
+
+proc math::calculus::symdiff::ConstantValue {item} {
+ return [lindex $item 1]
+}
+
+# Define the parse tree fabrication routines in the 'differentiate'
+# namespace as well as the 'symdiff' namespace, without exporting them
+# from the package.
+
+interp alias {} math::calculus::symdiff::differentiate::IsConstant \
+ {} math::calculus::symdiff::IsConstant
+interp alias {} math::calculus::symdiff::differentiate::ConstantValue \
+ {} math::calculus::symdiff::ConstantValue
+interp alias {} math::calculus::symdiff::differentiate::MakeConstant \
+ {} math::calculus::symdiff::MakeConstant
+interp alias {} math::calculus::symdiff::differentiate::MakeDifference \
+ {} math::calculus::symdiff::MakeDifference
+interp alias {} math::calculus::symdiff::differentiate::MakeFunCall \
+ {} math::calculus::symdiff::MakeFunCall
+interp alias {} math::calculus::symdiff::differentiate::MakePower \
+ {} math::calculus::symdiff::MakePower
+interp alias {} math::calculus::symdiff::differentiate::MakeProd \
+ {} math::calculus::symdiff::MakeProd
+interp alias {} math::calculus::symdiff::differentiate::MakeQuotient \
+ {} math::calculus::symdiff::MakeQuotient
+interp alias {} math::calculus::symdiff::differentiate::MakeSum \
+ {} math::calculus::symdiff::MakeSum
+interp alias {} math::calculus::symdiff::differentiate::MakeUnaryMinus \
+ {} math::calculus::symdiff::MakeUnaryMinus
+interp alias {} math::calculus::symdiff::differentiate::MakeVariable \
+ {} math::calculus::symdiff::MakeVariable
+interp alias {} math::calculus::symdiff::differentiate::ExtractExpression \
+ {} math::calculus::symdiff::ExtractExpression
diff --git a/tcllib/modules/math/symdiff.test b/tcllib/modules/math/symdiff.test
new file mode 100644
index 0000000..bf35cb8
--- /dev/null
+++ b/tcllib/modules/math/symdiff.test
@@ -0,0 +1,458 @@
+# symdiff.test --
+#
+# Test cases for the 'symdiff' package
+#
+# This file contains a collection of tests for one or more of the Tcllib
+# procedures. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 2005 by Kevin B. Kenny
+# All rights reserved.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: symdiff.test,v 1.2 2011/01/13 02:49:53 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.1
+
+support {
+ use grammar_aycock/aycock-runtime.tcl grammar::aycock::runtime grammar::aycock
+ useKeep grammar_aycock/aycock-debug.tcl grammar::aycock::debug grammar::aycock
+ useKeep grammar_aycock/aycock-build.tcl grammar::aycock grammar::aycock
+}
+testing {
+ useLocal symdiff.tcl math::calculus::symdiff
+}
+
+# -------------------------------------------------------------------------
+
+namespace eval ::math::calculus::symdiff::test {
+
+namespace import ::tcltest::test
+namespace import ::tcltest::cleanupTests
+namespace import ::math::calculus::symdiff::*
+
+set prec $::tcl_precision
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ set ::tcl_precision 17
+} else {
+ set ::tcl_precision 0
+}
+
+test symdiff-1.1 {derivative of a constant} {
+ symdiff {1.0} a
+} 0.0
+
+test symdiff-2.1 {derivative of a variable} {
+ symdiff {$a} a
+} 1.0
+
+test symdiff-2.2 {derivative of a variable} {
+ symdiff {$b} a
+} 0.0
+
+test symdiff-3.1 {derivative of a sum, easy cases} {
+ symdiff {1.0 + 1.0} a
+} 0.0
+
+test symdiff-3.2 {derivative of a sum, easy cases} {
+ symdiff {1.0 + $a} a
+} 1.0
+
+test symdiff-3.3 {derivative of a sum, easy cases} {
+ symdiff {$a + 1.0} a
+} 1.0
+
+test symdiff-3.4 {derivative of a sum, easy cases} {
+ symdiff {$a + $a} a
+} 2.0
+
+test symdiff-3.5 {derivative of a sum, easy cases} {
+ symdiff {$a + $b} a
+} 1.0
+
+test symdiff-3.6 {derivative of a sum, easy cases} {
+ symdiff {$a + $a + $a} a
+} 3.0
+
+test symdiff-4.1 {derivative of a difference, easy cases} {
+ -body {
+ symdiff {1.0 - 1.0} a
+ }
+ -match regexp
+ -result {[-+]?0.0}
+}
+
+test symdiff-4.2 {derivative of a difference, easy cases} {
+ symdiff {1.0 - $a} a
+} -1.0
+
+test symdiff-4.3 {derivative of a difference, easy cases} {
+ symdiff {$a - 1.0} a
+} 1.0
+
+test symdiff-4.4 {derivative of a difference, easy cases} {
+ symdiff {$a - $a} a
+} 0.0
+
+test symdiff-4.5 {derivative of a difference, easy cases} {
+ symdiff {$a + $b} a
+} 1.0
+
+test symdiff-4.6 {derivative of a difference, easy cases} {
+ symdiff {$a + $a - $a} a
+} 1.0
+
+test symdiff-5.1 {derivative of a product, easy cases} {
+ symdiff {1.0 * 1.0} a
+} 0.0
+
+test symdiff-5.2 {derivative of a product, easy cases} {
+ symdiff {3.0 * $a} a
+} 3.0
+
+test symdiff-5.3 {derivative of a product, easy cases} {
+ symdiff {$a * 3.0} a
+} 3.0
+
+test symdiff-5.4 {derivative of a product, easy cases} {
+ symdiff {$a * $a} a
+} {($a + $a)}
+
+test symdiff-5.5 {derivative of a product, easy cases} {
+ symdiff {$a * $b} a
+} {$b}
+
+test symdiff-5.6 {derivative of a product, easy cases} {
+ symdiff {($a + $b) * ($a + $b)} a
+} {(($a + $b) + ($a + $b))}
+
+test symdiff-5.7 {derivative of a linear function} {
+ symdiff {$a*$x + $b} x
+} {$a}
+
+test symdiff-6.1 {derivative of a sum} {
+ symdiff {($a*$x+$b)+($c*$x+$d)} x
+} {($a + $c)}
+
+test symdiff-7.1 {derivative of a difference} {
+ symdiff {($a*$x+$b)-($c*$x+$d)} x
+} {($a - $c)}
+
+test symdiff-8.1 {derivative of a product} {
+ symdiff {($a*$x+$b)*($c*$x+$d)} x
+} {(($c * (($a * $x) + $b)) + ($a * (($c * $x) + $d)))}
+
+test symdiff-9.1 {derivative of a quotient} {
+ symdiff {$x/1.0} x
+} 1.0
+
+test symdiff-9.2 {derivative of a quotient} {
+ symdiff {$x/-1.0} x
+} -1.0
+
+test symdiff-9.3 {derivative of a quotient} {
+ symdiff {1.0/$x} x
+} {-(((1.0 / $x) / $x))}
+
+test symdiff-9.4 {derivative of a quotient} {
+ symdiff {($a*$x+$b)/($c*$x+$d)} x
+} {(($a - (($c * (($a * $x) + $b)) / (($c * $x) + $d))) / (($c * $x) + $d))}
+
+test symdiff-10.1 {derivative of an exponent} {
+ symdiff {pow($a*$x+$b,3.5)} x
+} {($a * (3.5 * pow((($a * $x) + $b), 2.5)))}
+
+test symdiff-10.2 {derivative of an exponent, slightly harder case} {
+ -body {
+ symdiff {pow(10.0,$x)} x
+ }
+ -match regexp
+ -result {\(pow\(10.0, \$x\) \* 2.30258509299404(?:59|6)\)}
+}
+
+test symdiff-10.3 {derivative of an exponent, awkward case} {
+ symdiff {pow($a*$x+$b,$c*$x+$d)} x
+} {(pow((($a * $x) + $b), (($c * $x) + $d)) * ((($a * (($c * $x) + $d)) / (($a * $x) + $b)) + ($c * log((($a * $x) + $b)))))}
+
+test symdiff-11.1 {derivative of a unary negation} {
+ symdiff {-($a*$x + $b)} x
+} {-($a)}
+
+test symdiff-11.2 {derivative of a unary plus} {
+ symdiff {+($a*$x + $b)} x
+} {$a}
+
+test symdiff-12.1 {derivative of acos} {
+ symdiff {acos($x)} x
+} {(-1.0 / sqrt((1.0 - ($x * $x))))}
+
+test symdiff-12.2 {derivative of acos} {
+ symdiff {acos($a*$x+$b)} x
+} {-(($a / sqrt((1.0 - ((($a * $x) + $b) * (($a * $x) + $b))))))}
+
+test symdiff-13.1 {derivative of acos} {
+ symdiff {asin($x)} x
+} {(1.0 / sqrt((1.0 - ($x * $x))))}
+
+test symdiff-13.2 {derivative of asin} {
+ symdiff {asin($a*$x+$b)} x
+} {($a / sqrt((1.0 - ((($a * $x) + $b) * (($a * $x) + $b)))))}
+
+test symdiff-14.1 {derivative of atan} {
+ symdiff {atan($x)} x
+} {(1.0 / (1.0 + ($x * $x)))}
+
+test symdiff-14.2 {derivative of atan} {
+ symdiff {atan($a*$x+$b)} x
+} {($a / (1.0 + ((($a * $x) + $b) * (($a * $x) + $b))))}
+
+test symdiff-15.1 {derivative of atan2} {
+ symdiff {atan2($x,1.0)} x
+} {(1.0 / (($x * $x) + 1.0))}
+
+test symdiff-15.2 {derivative of atan2} {
+ symdiff {atan2(1.0,$x)} x
+} {(-1.0 / (1.0 + ($x * $x)))}
+
+test symdiff-15.3 {derivative of atan2} {
+ symdiff {atan2($x,$y)} x
+} {($y / (($x * $x) + ($y * $y)))}
+
+test symdiff-15.4 {derivative of atan2} {
+ symdiff {atan2($y,$x)} x
+} {-(($y / (($y * $y) + ($x * $x))))}
+
+test symdiff-15.5 {derivative of atan2} {
+ symdiff {atan2($a*$x+$b,$c*$x+$d)} x
+} {((($a * (($c * $x) + $d)) - ((($a * $x) + $b) * $c)) / (((($a * $x) + $b) * (($a * $x) + $b)) + ((($c * $x) + $d) * (($c * $x) + $d))))}
+
+test symdiff-16.1 {derivative of cos} {
+ symdiff {cos($x)} x
+} {-(sin($x))}
+
+test symdiff-16.2 {derivative of cos} {
+ symdiff {cos($a*$x + $b)} x
+} {-(($a * sin((($a * $x) + $b))))}
+
+test symdiff-17.1 {derivative of cosh} {
+ symdiff {cosh($x)} x
+} {sinh($x)}
+
+test symdiff-17.2 {derivative of cosh} {
+ symdiff {cosh($a*$x + $b)} x
+} {($a * sinh((($a * $x) + $b)))}
+
+test symdiff-18.1 {derivative of exp} {
+ symdiff {exp($x)} x
+} {exp($x)}
+
+test symdiff-18.2 {derivative of exp} {
+ symdiff {exp($a*$x+$b)} x
+} {($a * exp((($a * $x) + $b)))}
+
+test symdiff-19.1 {derivative of hypot} {
+ symdiff {hypot(0.0,$a)} a
+} {($a / hypot(0.0, $a))}
+
+test symdiff-19.2 {derivative of hypot} {
+ symdiff {hypot($b,$a)} a
+} {($a / hypot($b, $a))}
+
+test symdiff-19.3 {derivative of hypot} {
+ symdiff {hypot($a*$x+$b,$c*$x+$d)} x
+} {((($a * (($a * $x) + $b)) + ($c * (($c * $x) + $d))) / hypot((($a * $x) + $b), (($c * $x) + $d)))}
+
+test symdiff-20.1 {derivative of log} {
+ symdiff {log($x)} x
+} {(1.0 / $x)}
+
+test symdiff-20.2 {derivative of log} {
+ symdiff {log($a*$x+$b)} x
+} {($a / (($a * $x) + $b))}
+
+test symdiff-21.1 {derivative of log10} {
+ -body {
+ symdiff {log10($x)} x
+ }
+ -match regexp
+ -result {\(1.0 / \(2.30258509299404(?:59|6) \* \$x\)\)}
+}
+
+test symdiff-21.2 {derivative of log10} {
+ -body {
+ symdiff {log10($a * $x + $b)} x
+ }
+ -match regexp
+ -result {\(\$a / \(2.30258509299404(?:59|6) \* \(\(\$a \* \$x\) \+ \$b\)\)\)}
+}
+
+test symdiff-22.1 {derivative of sin} {
+ symdiff {sin($x)} x
+} {cos($x)}
+
+test symdiff-22.2 {derivative of sin} {
+ symdiff {sin($a*$x+$b)} x
+} {($a * cos((($a * $x) + $b)))}
+
+test symdiff-22.1 {derivative of sinh} {
+ symdiff {sinh($x)} x
+} {cosh($x)}
+
+test symdiff-22.2 {derivative of sinh} {
+ symdiff {sinh($a*$x+$b)} x
+} {($a * cosh((($a * $x) + $b)))}
+
+test symdiff-23.1 {derivative of sqrt} {
+ symdiff {sqrt($x)} x
+} {(1.0 / (2.0 * sqrt($x)))}
+
+test symdiff-23.2 {derivative of sqrt} {
+ symdiff {sqrt($a*$x+$b)} x
+} {($a / (2.0 * sqrt((($a * $x) + $b))))}
+
+test symdiff-24.1 {derivative of tan} {
+ symdiff {tan($x)} x
+} {(1.0 / (cos($x) * cos($x)))}
+
+test symdiff-24.2 {derivative of tan} {
+ symdiff {tan($a*$x+$b)} x
+} {($a / (cos((($a * $x) + $b)) * cos((($a * $x) + $b))))}
+
+test symdiff-24.1 {derivative of tanh} {
+ symdiff {tanh($x)} x
+} {(1.0 / (cosh($x) * cosh($x)))}
+
+test symdiff-24.2 {derivative of tanh} {
+ symdiff {tanh($a*$x+$b)} x
+} {($a / (cosh((($a * $x) + $b)) * cosh((($a * $x) + $b))))}
+
+test symdiff-25.1 {error handling} {
+ -body {
+ symdiff {[foo $x]} x
+ }
+ -match glob
+ -returnCodes error
+ -result {invalid character*}
+}
+
+test symdiff-25.2 {error handling} {
+ -body {
+ symdiff {$x(1)} x
+ }
+ -match glob
+ -returnCodes error
+ -result {syntax error*}
+}
+
+test symdiff-25.3 {error handling} {
+ -body {
+ symdiff {$a & $b} a
+ }
+ -match glob
+ -returnCodes error
+ -result {invalid character*}
+}
+
+test symdiff-25.4 {error handling} {
+ list [catch {symdiff {int($a)} a} result] $result
+} {1 {symdiff can't differentiate the "int" function}}
+
+test symdiff-25.5 {error handling} {
+ -body {
+ symdiff {$a ? $b : $c} a
+ }
+ -returnCodes error
+ -match glob
+ -result {invalid character*}
+}
+
+test symdiff-26.1 {unary minus optimization} {
+ symdiff {$a * $x + -$b * $x} x
+} {($a - $b)}
+
+test symdiff-26.2 {unary minus optimization} {
+ symdiff {-$a * $x - $b * $x} x
+} {-(($a + $b))}
+
+test symdiff-26.3 {unary minus optimization} {
+ symdiff {$a * $x - -$b * $x} x
+} {($a + $b)}
+
+test symdiff-26.4 {unary minus optimization} {
+ symdiff {-$a * $x * $b} x
+} {-(($a * $b))}
+
+test symdiff-26.5 {unary minus optimization} {
+ symdiff {$a * $x * -$b} x
+} {-(($a * $b))}
+
+test symdiff-26.6 {unary minus optimization} {
+ symdiff {---($a*$x+$b)} x
+} {-($a)}
+
+test symdiff-26.7 {unary minus optimization} {
+ symdiff {-$x * $x} x
+} {-(($x + $x))}
+
+test symdiff-27.1 {power optimizations} {
+ symdiff {pow($x,1)} x
+} 1.0
+
+test symdiff-27.2 {power optimizations} {
+ symdiff {pow($x,2.0)} x
+} {(2.0 * $x)}
+
+test symdiff-28.1 {quotient optimization} {
+ symdiff {($x * $x) / 1.0} x
+} {($x + $x)}
+
+test symdiff-28.2 {quotient optimization} {
+ symdiff {($x * $x) / -1.0} x
+} {-(($x + $x))}
+
+test symdiff-28.3 {quotient optimization - error case} {
+ list [catch {symdiff {($x * $x) / 0.0} x} result] $result
+} {1 {requested expression will result in division by zero at run time}}
+
+test symdiff-29.1 {product optimization} {
+ symdiff {(2. * $x) * 3.0} x
+} 6.0
+
+test symdiff-29.2 {product optimization} {
+ symdiff {($a * $x) * -1.0} x
+} {-($a)}
+
+test symdiff-30.0 {illustration of Newton's method - find a root of sin(x)-0.5 near 0.5} {
+ proc root {expr var guess} {
+ upvar 1 $var v
+ set deriv [symdiff $expr $var]
+ set v $guess
+ set updateExpr [list expr "\$$var - ($expr) / ($deriv)"]
+ for { set i 0 } { $i < 4 } { incr i } {
+ set v [uplevel 1 $updateExpr]
+ }
+ return $v
+ }
+ set r [root {sin($x)-0.5} x 0.5]
+ expr {sin($r)}
+} 0.5
+
+# End of test cases
+set ::tcl_precision $prec
+cleanupTests
+}
+
+namespace delete ::math::calculus::symdiff::test
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tcllib/modules/math/tclIndex b/tcllib/modules/math/tclIndex
new file mode 100644
index 0000000..49f0bd1
--- /dev/null
+++ b/tcllib/modules/math/tclIndex
@@ -0,0 +1,26 @@
+# Tcl autoload index file, version 2.0
+# This file is generated by the "auto_mkindex" command
+# and sourced to set up indexing information for one or
+# more commands. Typically each line is a command that
+# sets an element in the auto_index array, where the
+# element name is the name of a command and the value is
+# a script that loads the command.
+
+set auto_index(::math::cov) [list source [file join $dir misc.tcl]]
+set auto_index(::math::fibonacci) [list source [file join $dir misc.tcl]]
+set auto_index(::math::integrate) [list source [file join $dir misc.tcl]]
+set auto_index(::math::max) [list source [file join $dir misc.tcl]]
+set auto_index(::math::mean) [list source [file join $dir misc.tcl]]
+set auto_index(::math::min) [list source [file join $dir misc.tcl]]
+set auto_index(::math::product) [list source [file join $dir misc.tcl]]
+set auto_index(::math::random) [list source [file join $dir misc.tcl]]
+set auto_index(::math::sigma) [list source [file join $dir misc.tcl]]
+set auto_index(::math::stats) [list source [file join $dir misc.tcl]]
+set auto_index(::math::sum) [list source [file join $dir misc.tcl]]
+set auto_index(::math::expectDouble) [list source [file join $dir misc.tcl]]
+set auto_index(::math::InitializeFactorial) [list source [file join $dir combinatorics.tcl]]
+set auto_index(::math::InitializePascal) [list source [file join $dir combinatorics.tcl]]
+set auto_index(::math::ln_Gamma) [list source [file join $dir combinatorics.tcl]]
+set auto_index(::math::factorial) [list source [file join $dir combinatorics.tcl]]
+set auto_index(::math::choose) [list source [file join $dir combinatorics.tcl]]
+set auto_index(::math::Beta) [list source [file join $dir combinatorics.tcl]]
diff --git a/tcllib/modules/math/wilcoxon.tcl b/tcllib/modules/math/wilcoxon.tcl
new file mode 100755
index 0000000..deab070
--- /dev/null
+++ b/tcllib/modules/math/wilcoxon.tcl
@@ -0,0 +1,228 @@
+# statistics_new.tcl --
+# Implementation of the Wilcoxon test: test if the medians
+# of two samples are the same
+#
+
+# test-Wilcoxon
+# Compute the statistic that indicates if the medians of two
+# samples are the same
+#
+# Arguments:
+# sample_a List of values in the first sample
+# sample_b List of values in the second sample
+#
+# Result:
+# Statistic for the test (if both samples have 10 or more
+# values, the statistic behaves as a standard normal variable)
+#
+proc ::math::statistics::test-Wilcoxon {sample_a sample_b} {
+
+ #
+ # Construct the sorted list for both
+ #
+ set sorted {}
+ set count_a 0
+ set count_b 0
+ foreach sample {sample_a sample_b} code {0 1} count {count_a count_b} {
+ foreach v [set $sample] {
+ if { $v ne {} } {
+ incr $count
+ lappend sorted [list $v $code]
+ }
+ }
+ }
+
+ set raw_sorted [lsort -index 0 -real $sorted]
+
+ #
+ # Resolve the ties (TODO)
+ # - Make sure the previous value is never equal to the first
+ # - Take care of the last part of the sorted samples
+ #
+ set previous [expr {0.5*[lindex $raw_sorted 0 0] - 1.0}]
+
+ set sorted $raw_sorted
+ set rank 0
+ set sum_ranks 0
+ set count 0
+ set first 0
+ set index 0
+ foreach v [concat $raw_sorted {{} -1}] {
+ set sum_ranks [expr {$sum_ranks + $rank}]
+ incr count
+ set current [lindex $v 0]
+ if { $current != $previous } {
+ set new_rank [expr {$sum_ranks / $count}]
+
+ if { $index > [llength $raw_sorted] } {
+ set index [llength $raw_sorted]
+ }
+
+ for {set elem $first} {$elem < $index} {incr elem} {
+ lset sorted $elem 0 $new_rank
+ }
+
+ set previous $current
+ set first $index
+ set count 0
+ set sum_ranks 0
+ }
+
+ incr index
+ incr rank
+ }
+
+ #
+ # Sum the ranks for the first sample and determine
+ # the statistic
+ #
+ if { $count_a < 2 || $count_b < 2 } {
+ return -code error \
+ -errorcode DATA -errorinfo {Too few data in one or both samples}
+ }
+
+ set sum 0
+ foreach v $sorted {
+ if { [lindex $v 1] == 0 } {
+ set rank [lindex $v 0]
+ set sum [expr {$sum + $rank}]
+ }
+ }
+
+ set expected [expr {$count_a * ($count_a + $count_b + 1)/2.0}]
+ set stdev [expr {sqrt($count_b * $expected/6.0)}]
+ set statistic [expr {($sum-$expected)/$stdev}]
+
+ return $statistic
+}
+
+# SpearmanRankData --
+# Auxiliary procedure to rank the data
+#
+# Arguments:
+# sample Series of data to be ranked
+#
+# Returns:
+# Ranks of the data
+#
+proc ::math::statistics::SpearmanRankData {sample} {
+
+ set counted_sample {}
+ set count 0
+ foreach v $sample {
+ if { $v ne {} } {
+ incr count
+ lappend counted_sample [list $v 0 $count]
+ }
+ }
+
+ set raw_sorted [lsort -index 0 -real $counted_sample]
+
+ #
+ # Resolve the ties (TODO)
+ # - Make sure the previous value is never equal to the first
+ # - Take care of the last part of the sorted samples
+ #
+ set previous [expr {0.5*[lindex $raw_sorted 0 0] - 1.0}]
+
+ set sorted $raw_sorted
+ set rank 0
+ set sum_ranks 0
+ set count 0
+ set first 0
+ set index 0
+ foreach v [concat $raw_sorted {{} -1}] {
+ set sum_ranks [expr {$sum_ranks + $rank}]
+ incr count
+ set current [lindex $v 0]
+ if { $current != $previous } {
+ set new_rank [expr {$sum_ranks / $count}]
+
+ if { $index > [llength $raw_sorted] } {
+ set index [llength $raw_sorted]
+ }
+
+ for {set elem $first} {$elem < $index} {incr elem} {
+ lset sorted $elem 1 $new_rank
+ }
+
+ set previous $current
+ set first $index
+ set count 0
+ set sum_ranks 0
+ }
+
+ incr index
+ incr rank
+ }
+
+ #
+ # Return the ranks of the data in the original order
+ #
+ set ranks {}
+ foreach values [lsort -index 2 -integer $sorted] {
+ lappend ranks [lindex $values 1]
+ }
+
+ return $ranks
+}
+
+# spearman-rank-extended --
+# Compute the Spearman's rank correlation coefficient and
+# associated parameters
+#
+# Arguments:
+# sample_a List of values in the first sample
+# sample_b List of values in the second sample
+#
+# Result:
+# List of:
+# - Rank correlation coefficient
+# - Number of data
+# - z-score to test the null hyothesis
+#
+proc ::math::statistics::spearman-rank-extended {sample_a sample_b} {
+
+ #
+ # Filter out missing data
+ #
+ if { [llength $sample_a] != [llength $sample_b] } {
+ return -code error \
+ -errorcode DATA -errorinfo {The two samples should have the same number of data}
+ }
+
+ set new_sample_a {}
+ set new_sample_b {}
+ foreach a $sample_a b $sample_b {
+ if { $a != {} && $b != {} } {
+ lappend new_sample_a $a
+ lappend new_sample_b $b
+ }
+ }
+
+ #
+ # Construct the ranks
+ #
+ set rank_a [SpearmanRankData $new_sample_a]
+ set rank_b [SpearmanRankData $new_sample_b]
+
+ set rcorr [corr $rank_a $rank_b]
+ set number [llength $new_sample_a]
+ set zscore [expr {sqrt(($number-3)/1.06) * 0.5 * log((1.0+$rcorr)/(1.0-$rcorr))}]
+
+ return [list $rcorr $number $zscore]
+}
+
+# spearman-rank --
+# Compute the Spearman's rank correlation coefficient
+#
+# Arguments:
+# sample_a List of values in the first sample
+# sample_b List of values in the second sample
+#
+# Result:
+# Rank correlation coefficient
+#
+proc ::math::statistics::spearman-rank {sample_a sample_b} {
+ return [lindex [spearman-rank-extended $sample_a $sample_b] 0]
+}
diff --git a/tcllib/modules/md4/ChangeLog b/tcllib/modules/md4/ChangeLog
new file mode 100644
index 0000000..7c8c606
--- /dev/null
+++ b/tcllib/modules/md4/ChangeLog
@@ -0,0 +1,209 @@
+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-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 ========================
+ *
+
+2009-05-06 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md4c.tcl: Fixed a leak in the critcl implemented due to
+ mismanaged reference counting.
+
+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 ========================
+ *
+
+2008-04-29 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md4.tcl: Clean up variables after intialization.
+ * pkgIndex.tcl: Bumped to 1.0.5
+
+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>
+
+ * md4.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-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * md4.man: Bumped version to 1.0.4
+ * md4.tcl:
+ * pkgIndex.tcl:
+
+2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md4.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md4.test: Hooked into the new common test support code.
+
+2005-10-24 Andreas Kupries <andreask@activestate.com>
+
+ * md4.bench: New file. Basic benchmarks for MD4 hashes.
+
+2005-10-17 Andreas Kupries <andreask@activestate.com>
+
+ * md4.tcl: Trivial comment typo fix.
+
+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>
+
+ * md4c.tcl: Fix to permit compilation with msvc
+ * md4.h:
+
+2005-02-24 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md4.tcl: Arranged to run all available implementations in
+ * md4.test: the tests.
+
+2005-02-23 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * pkgIndex.tcl: Incremented version to 1.0.3
+ * md4.tcl: Rationalized the accelerator package handling.
+ * md4.test: Added cryptkit as a potential accelerator.
+ * md4.man: Added mention of the accelerators.
+
+2005-02-17 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md4.tcl: Fixed the tests to use both critcl and pure-Tcl
+ * md4.test: if the critcl version is available.
+
+ * md4.tcl: Made hashing cope with data that begins with a
+ * md4.test: hyphen and made the '--' end-of-options marker
+ * md4.man: optional. Incremented version.
+ * pkgIndex.tcl:
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md4.tcl: Updated version number to sync with 1.6.1
+ * md4.man: release.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md4.tcl: Rel. engineering. Updated version number
+ * md4.man: of md4 to reflect its changes, to 1.0.2.
+ * pkgIndex.tcl:
+
+2004-02-18 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md4.tcl: Streamlined the rotate-left function and fixed a rare
+ bug that occurs if the hash result produces a hypen as the first
+ character and we are using Trf's hex function.
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-05-08 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md4.tcl: Remove frink warnings to quieten sak validate.
+
+2003-05-07 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md4.tcl: Changed the method MD4Final uses to produce the binary
+ result to avoid problems on 64bit architectures.
+ * md4.c: Removed the c_src subdirectory and moved all files
+ * md4.h: into the md4 module directory. We want to keep the
+ * md4c.tcl: source tree as flat as possible.
+ * md4.tcl, md4.man, pkgIndex.tcl: Hiked version to 1.0.1
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-30 Pat Thoyts <Patrick.Thoyts@renishaw.com>
+
+ * md4.man: Added documentation for the hmac command and for the
+ programming interface to the MD4 algorithm.
+ * md4c.tcl: Fixed md5c attribution.
+
+2003-04-18 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md4c.tcl: Added critcl-based C implementation md4c.
+ * md4.tcl: Enable use of md4c if available.
+ * md4.test: Report the implmentation (C or pure-tcl)
+ * c_src/md4.h: The md4 implementation from RFC1320
+ * c_src/md4.c:
+
+2003-04-18 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md4.test: Added a series of tests to check all lengths of input
+ up to over 2 MD4 block lengths.
+ * md4_check.c: Included the C code used to generate the new test
+ results from the OpenSSL MD4 implementation.
+
+2003-04-16 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md4.tcl: Implemented chunked reading from file or
+ channel, added -file and -channel options to md4.
+ Implemented hmac command with -key option.
+ Provide MD4Init, MD4Update, MD4Final as per C-usage to permit use
+ on streaming data.
+
+2003-04-15 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md4.test:
+ * md4.tcl:
+ * md4.man:
+ * ChangeLog: Initial versions.
+
diff --git a/tcllib/modules/md4/md4.bench b/tcllib/modules/md4/md4.bench
new file mode 100644
index 0000000..f9a31e8
--- /dev/null
+++ b/tcllib/modules/md4/md4.bench
@@ -0,0 +1,46 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'md4' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+set moddir [file dirname [file dirname [info script]]]
+lappend auto_path $moddir
+
+package forget md4
+catch {namespace delete ::md4}
+source [file join [file dirname [info script]] md4.tcl]
+
+set key "01234567abcdefgh01234567abcdefgh01234567abcdefgh01234567abcdefgh=="
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+foreach n {1 10 100 1000 10000} {
+ bench -desc "MD4 md4_ $n" -pre {
+ set str [string repeat " " $n]
+ } -body {
+ md4::md4 $str
+ }
+
+ bench -desc "MD4 hmac $n" -pre {
+ set str [string repeat " " $n]
+ } -body {
+ md4::hmac -key $key $str
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/md4/md4.c b/tcllib/modules/md4/md4.c
new file mode 100644
index 0000000..c9b49c2
--- /dev/null
+++ b/tcllib/modules/md4/md4.c
@@ -0,0 +1,301 @@
+/* MD4C.C - RSA Data Security, Inc., MD4 message-digest algorithm
+ */
+
+/* Copyright (C) 1990-2, RSA Data Security, Inc. All rights reserved.
+
+ License to copy and use this software is granted provided that it
+ is identified as the "RSA Data Security, Inc. MD4 Message-Digest
+ Algorithm" in all material mentioning or referencing this software
+ or this function.
+
+ License is also granted to make and use derivative works provided
+ that such works are identified as "derived from the RSA Data
+ Security, Inc. MD4 Message-Digest Algorithm" in all material
+ mentioning or referencing the derived work.
+
+ RSA Data Security, Inc. makes no representations concerning either
+ the merchantability of this software or the suitability of this
+ software for any particular purpose. It is provided "as is"
+ without express or implied warranty of any kind.
+
+ These notices must be retained in any copies of any part of this
+ documentation and/or software.
+ */
+
+#include "md4.h"
+
+/* Constants for MD4Transform routine.
+ */
+#define S11 3
+#define S12 7
+#define S13 11
+#define S14 19
+#define S21 3
+#define S22 5
+#define S23 9
+#define S24 13
+#define S31 3
+#define S32 9
+#define S33 11
+#define S34 15
+
+static void MD4Transform PROTO_LIST ((UINT4 [4], unsigned char [64]));
+static void Encode PROTO_LIST
+ ((unsigned char *, UINT4 *, unsigned int));
+static void Decode PROTO_LIST
+ ((UINT4 *, unsigned char *, unsigned int));
+static void MD4_memcpy PROTO_LIST ((POINTER, POINTER, unsigned int));
+static void MD4_memset PROTO_LIST ((POINTER, int, unsigned int));
+
+static unsigned char PADDING[64] = {
+ 0x80, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
+};
+
+/* F, G and H are basic MD4 functions.
+ */
+#define F(x, y, z) (((x) & (y)) | ((~x) & (z)))
+#define G(x, y, z) (((x) & (y)) | ((x) & (z)) | ((y) & (z)))
+#define H(x, y, z) ((x) ^ (y) ^ (z))
+
+/* ROTATE_LEFT rotates x left n bits.
+ */
+#define ROTATE_LEFT(x, n) (((x) << (n)) | ((x) >> (32-(n))))
+
+/* FF, GG and HH are transformations for rounds 1, 2 and 3 */
+/* Rotation is separate from addition to prevent recomputation */
+
+#define FF(a, b, c, d, x, s) { \
+ (a) += F ((b), (c), (d)) + (x); \
+ (a) = ROTATE_LEFT ((a), (s)); \
+ }
+#define GG(a, b, c, d, x, s) { \
+ (a) += G ((b), (c), (d)) + (x) + (UINT4)0x5a827999; \
+ (a) = ROTATE_LEFT ((a), (s)); \
+ }
+#define HH(a, b, c, d, x, s) { \
+ (a) += H ((b), (c), (d)) + (x) + (UINT4)0x6ed9eba1; \
+ (a) = ROTATE_LEFT ((a), (s)); \
+ }
+
+/* MD4 initialization. Begins an MD4 operation, writing a new context.
+ */
+void MD4Init (context)
+MD4_CTX *context; /* context */
+{
+ context->count[0] = context->count[1] = 0;
+
+ /* Load magic initialization constants.
+ */
+ context->state[0] = 0x67452301;
+ context->state[1] = 0xefcdab89;
+ context->state[2] = 0x98badcfe;
+ context->state[3] = 0x10325476;
+}
+
+/* MD4 block update operation. Continues an MD4 message-digest
+ operation, processing another message block, and updating the
+ context.
+ */
+void MD4Update (context, input, inputLen)
+MD4_CTX *context; /* context */
+unsigned char *input; /* input block */
+unsigned int inputLen; /* length of input block */
+{
+ unsigned int i, index, partLen;
+
+ /* Compute number of bytes mod 64 */
+ index = (unsigned int)((context->count[0] >> 3) & 0x3F);
+ /* Update number of bits */
+ if ((context->count[0] += ((UINT4)inputLen << 3))
+ < ((UINT4)inputLen << 3))
+ context->count[1]++;
+ context->count[1] += ((UINT4)inputLen >> 29);
+
+ partLen = 64 - index;
+
+ /* Transform as many times as possible.
+ */
+ if (inputLen >= partLen) {
+ MD4_memcpy
+ ((POINTER)&context->buffer[index], (POINTER)input, partLen);
+ MD4Transform (context->state, context->buffer);
+
+ for (i = partLen; i + 63 < inputLen; i += 64)
+ MD4Transform (context->state, &input[i]);
+
+ index = 0;
+ }
+ else
+ i = 0;
+
+ /* Buffer remaining input */
+ MD4_memcpy
+ ((POINTER)&context->buffer[index], (POINTER)&input[i],
+ inputLen-i);
+}
+
+/* MD4 finalization. Ends an MD4 message-digest operation, writing the
+ the message digest and zeroizing the context.
+ */
+void MD4Final (digest, context)
+unsigned char digest[16]; /* message digest */
+MD4_CTX *context; /* context */
+{
+ unsigned char bits[8];
+ unsigned int index, padLen;
+
+ /* Save number of bits */
+ Encode (bits, context->count, 8);
+
+ /* Pad out to 56 mod 64.
+ */
+ index = (unsigned int)((context->count[0] >> 3) & 0x3f);
+ padLen = (index < 56) ? (56 - index) : (120 - index);
+ MD4Update (context, PADDING, padLen);
+
+ /* Append length (before padding) */
+ MD4Update (context, bits, 8);
+ /* Store state in digest */
+ Encode (digest, context->state, 16);
+
+ /* Zeroize sensitive information.
+ */
+ MD4_memset ((POINTER)context, 0, sizeof (*context));
+}
+
+/* MD4 basic transformation. Transforms state based on block.
+ */
+static void MD4Transform (state, block)
+UINT4 state[4];
+unsigned char block[64];
+{
+ UINT4 a = state[0], b = state[1], c = state[2], d = state[3], x[16];
+
+ Decode (x, block, 64);
+
+ /* Round 1 */
+ FF (a, b, c, d, x[ 0], S11); /* 1 */
+ FF (d, a, b, c, x[ 1], S12); /* 2 */
+ FF (c, d, a, b, x[ 2], S13); /* 3 */
+ FF (b, c, d, a, x[ 3], S14); /* 4 */
+ FF (a, b, c, d, x[ 4], S11); /* 5 */
+ FF (d, a, b, c, x[ 5], S12); /* 6 */
+ FF (c, d, a, b, x[ 6], S13); /* 7 */
+ FF (b, c, d, a, x[ 7], S14); /* 8 */
+ FF (a, b, c, d, x[ 8], S11); /* 9 */
+ FF (d, a, b, c, x[ 9], S12); /* 10 */
+ FF (c, d, a, b, x[10], S13); /* 11 */
+ FF (b, c, d, a, x[11], S14); /* 12 */
+ FF (a, b, c, d, x[12], S11); /* 13 */
+ FF (d, a, b, c, x[13], S12); /* 14 */
+ FF (c, d, a, b, x[14], S13); /* 15 */
+ FF (b, c, d, a, x[15], S14); /* 16 */
+
+ /* Round 2 */
+ GG (a, b, c, d, x[ 0], S21); /* 17 */
+ GG (d, a, b, c, x[ 4], S22); /* 18 */
+ GG (c, d, a, b, x[ 8], S23); /* 19 */
+ GG (b, c, d, a, x[12], S24); /* 20 */
+ GG (a, b, c, d, x[ 1], S21); /* 21 */
+ GG (d, a, b, c, x[ 5], S22); /* 22 */
+ GG (c, d, a, b, x[ 9], S23); /* 23 */
+ GG (b, c, d, a, x[13], S24); /* 24 */
+ GG (a, b, c, d, x[ 2], S21); /* 25 */
+ GG (d, a, b, c, x[ 6], S22); /* 26 */
+ GG (c, d, a, b, x[10], S23); /* 27 */
+ GG (b, c, d, a, x[14], S24); /* 28 */
+ GG (a, b, c, d, x[ 3], S21); /* 29 */
+ GG (d, a, b, c, x[ 7], S22); /* 30 */
+ GG (c, d, a, b, x[11], S23); /* 31 */
+ GG (b, c, d, a, x[15], S24); /* 32 */
+
+ /* Round 3 */
+ HH (a, b, c, d, x[ 0], S31); /* 33 */
+ HH (d, a, b, c, x[ 8], S32); /* 34 */
+ HH (c, d, a, b, x[ 4], S33); /* 35 */
+ HH (b, c, d, a, x[12], S34); /* 36 */
+ HH (a, b, c, d, x[ 2], S31); /* 37 */
+ HH (d, a, b, c, x[10], S32); /* 38 */
+ HH (c, d, a, b, x[ 6], S33); /* 39 */
+ HH (b, c, d, a, x[14], S34); /* 40 */
+ HH (a, b, c, d, x[ 1], S31); /* 41 */
+ HH (d, a, b, c, x[ 9], S32); /* 42 */
+ HH (c, d, a, b, x[ 5], S33); /* 43 */
+ HH (b, c, d, a, x[13], S34); /* 44 */
+ HH (a, b, c, d, x[ 3], S31); /* 45 */
+ HH (d, a, b, c, x[11], S32); /* 46 */
+ HH (c, d, a, b, x[ 7], S33); /* 47 */
+ HH (b, c, d, a, x[15], S34); /* 48 */
+
+ state[0] += a;
+ state[1] += b;
+ state[2] += c;
+ state[3] += d;
+
+ /* Zeroize sensitive information.
+ */
+ MD4_memset ((POINTER)x, 0, sizeof (x));
+}
+
+/* Encodes input (UINT4) into output (unsigned char). Assumes len is
+ a multiple of 4.
+ */
+static void Encode (output, input, len)
+unsigned char *output;
+UINT4 *input;
+unsigned int len;
+{
+ unsigned int i, j;
+
+ for (i = 0, j = 0; j < len; i++, j += 4) {
+ output[j] = (unsigned char)(input[i] & 0xff);
+ output[j+1] = (unsigned char)((input[i] >> 8) & 0xff);
+ output[j+2] = (unsigned char)((input[i] >> 16) & 0xff);
+ output[j+3] = (unsigned char)((input[i] >> 24) & 0xff);
+ }
+}
+
+/* Decodes input (unsigned char) into output (UINT4). Assumes len is
+ a multiple of 4.
+ */
+static void Decode (output, input, len)
+
+UINT4 *output;
+unsigned char *input;
+unsigned int len;
+{
+ unsigned int i, j;
+
+ for (i = 0, j = 0; j < len; i++, j += 4)
+ output[i] = ((UINT4)input[j]) | (((UINT4)input[j+1]) << 8) |
+ (((UINT4)input[j+2]) << 16) | (((UINT4)input[j+3]) << 24);
+}
+
+/* Note: Replace "for loop" with standard memcpy if possible.
+ */
+static void MD4_memcpy (output, input, len)
+POINTER output;
+POINTER input;
+unsigned int len;
+{
+ unsigned int i;
+
+ for (i = 0; i < len; i++)
+ output[i] = input[i];
+}
+
+/* Note: Replace "for loop" with standard memset if possible.
+ */
+static void MD4_memset (output, value, len)
+POINTER output;
+int value;
+unsigned int len;
+{
+ unsigned int i;
+
+ for (i = 0; i < len; i++)
+ ((char *)output)[i] = (char)value;
+}
+
diff --git a/tcllib/modules/md4/md4.h b/tcllib/modules/md4/md4.h
new file mode 100644
index 0000000..22e0f93
--- /dev/null
+++ b/tcllib/modules/md4/md4.h
@@ -0,0 +1,79 @@
+/* MD4.H - header file for MD4C.C
+ */
+
+/* Copyright (C) 1991-2, RSA Data Security, Inc. Created 1991. All
+ rights reserved.
+
+ License to copy and use this software is granted provided that it
+ is identified as the "RSA Data Security, Inc. MD4 Message-Digest
+ Algorithm" in all material mentioning or referencing this software
+ or this function.
+
+ License is also granted to make and use derivative works provided
+ that such works are identified as "derived from the RSA Data
+ Security, Inc. MD4 Message-Digest Algorithm" in all material
+ mentioning or referencing the derived work.
+
+ RSA Data Security, Inc. makes no representations concerning either
+ the merchantability of this software or the suitability of this
+ software for any particular purpose. It is provided "as is"
+ without express or implied warranty of any kind.
+
+ These notices must be retained in any copies of any part of this
+ documentation and/or software.
+ */
+
+#ifndef md4_h_INCLUDE
+#define md4_h_INCLUDE
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* PROTOTYPES should be set to one if and only if the compiler supports
+ function argument prototyping.
+ The following makes PROTOTYPES default to 0 if it has not already
+ been defined with C compiler flags.
+ */
+#ifndef PROTOTYPES
+#define PROTOTYPES 1
+#endif
+
+
+/* POINTER defines a generic pointer type */
+typedef unsigned char *POINTER;
+
+/* UINT2 defines a two byte word */
+typedef unsigned short int UINT2;
+
+/* UINT4 defines a four byte word */
+typedef unsigned int UINT4;
+
+/* PROTO_LIST is defined depending on how PROTOTYPES is defined above.
+ If using PROTOTYPES, then PROTO_LIST returns the list, otherwise it
+ returns an empty list.
+ */
+
+#if PROTOTYPES
+#define PROTO_LIST(list) list
+#else
+#define PROTO_LIST(list) ()
+#endif
+
+/* MD4 context. */
+typedef struct {
+ UINT4 state[4]; /* state (ABCD) */
+ UINT4 count[2]; /* number of bits, modulo 2^64 (lsb first) */
+ unsigned char buffer[64]; /* input buffer */
+} MD4_CTX;
+
+void MD4Init PROTO_LIST ((MD4_CTX *));
+void MD4Update PROTO_LIST
+ ((MD4_CTX *, unsigned char *, unsigned int));
+void MD4Final PROTO_LIST ((unsigned char [16], MD4_CTX *));
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* _md4_h_INCLUDE */
diff --git a/tcllib/modules/md4/md4.man b/tcllib/modules/md4/md4.man
new file mode 100644
index 0000000..0427ba8
--- /dev/null
+++ b/tcllib/modules/md4/md4.man
@@ -0,0 +1,168 @@
+[vset VERSION 1.0.6]
+[manpage_begin md4 n [vset VERSION]]
+[see_also md5]
+[see_also sha1]
+[keywords hashing]
+[keywords md4]
+[keywords message-digest]
+[keywords {rfc 1320}]
+[keywords {rfc 1321}]
+[keywords {rfc 2104}]
+[keywords security]
+[moddesc {MD4 Message-Digest Algorithm}]
+[copyright {2003, Pat Thoyts <patthoyts@users.sourceforge.net>}]
+[titledesc {MD4 Message-Digest Algorithm}]
+[category {Hashes, checksums, and encryption}]
+[require Tcl 8.2]
+[require md4 [opt [vset VERSION]]]
+[description]
+[para]
+
+This package is an implementation in Tcl of the MD4 message-digest
+algorithm as described in RFC 1320 (1) and (2). This algorithm takes
+an arbitrary quantity of data and generates a 128-bit message digest
+from the input. The MD4 algorithm is faster but potentially weaker than
+the related MD5 algorithm (3).
+
+[para]
+
+If you have [package critcl] and have built the [package tcllibc] package
+then the implementation of the hashing function will be performed by compiled
+code. Alternatively if [package cryptkit] is available this will be
+used. If no accelerator package can be found then the pure-tcl
+implementation is used. The programming interface remains the same in
+all cases.
+
+[section {COMMANDS}]
+
+[list_begin definitions]
+
+[call [cmd "::md4::md4"] \
+ [opt "[arg -hex]"] \
+ [lb] [arg "-channel channel"] | \
+ [arg "-file filename"] | [arg "string"] [rb]]
+
+Calculate the MD4 digest of the data given in string. This is returned
+as a binary string by default. Giving the [arg "-hex"] option will
+return a hexadecimal encoded version of the digest.
+
+[para]
+
+The data to be hashed can be specified either as a string argument to
+the md4 command, or as a filename or a pre-opened channel. If the
+[arg "-filename"] argument is given then the file is opened, the data read
+and hashed and the file is closed. If the [arg "-channel"] argument is
+given then data is read from the channel until the end of file. The
+channel is not closed.
+
+[para]
+
+Only one of [arg "-file"], [arg "-channel"] or [arg "string"] should be given.
+
+[call [cmd "::md4::hmac"] \
+ [opt "[arg -hex]"] \
+ [arg "-key key"] \
+ [lb] [arg "-channel channel"] | \
+ [arg "-file filename"] | [arg "string"] [rb]]
+
+Calculate an Hashed Message Authentication digest (HMAC) using the MD4
+digest algorithm. HMACs are described in RFC 2104 (4) and provide an MD4
+digest that includes a key. All options other than [arg -key] are as
+for the [cmd "::md4::md4"] command.
+
+[list_end]
+
+[section {PROGRAMMING INTERFACE}]
+
+For the programmer, the MD4 hash can be viewed as a bucket into which
+one pours data. When you have finished, you extract a value that is
+derived from the data that was poured into the bucket. The programming
+interface to the MD4 hash operates on a token (equivalent to the
+bucket). You call [cmd MD4Init] to obtain a token and then call
+[cmd MD4Update] as many times as required to add data to the hash. To
+release any resources and obtain the hash value, you then call
+[cmd MD4Final]. An equivalent set of functions gives you a keyed digest (HMAC).
+
+[list_begin definitions]
+
+[call [cmd "::md4::MD4Init"]]
+
+Begins a new MD4 hash. Returns a token ID that must be used for the
+remaining functions.
+
+[call [cmd "::md4::MD4Update"] [arg "token"] [arg "data"]]
+
+Add data to the hash identified by token. Calling
+[emph {MD4Update $token "abcd"}] is equivalent to calling
+[emph {MD4Update $token "ab"}] followed by
+[emph {MD4Update $token "cb"}]. See [sectref {EXAMPLES}].
+
+[call [cmd "::md4::MD4Final"] [arg "token"]]
+
+Returns the hash value and releases any resources held by this
+token. Once this command completes the token will be invalid. The
+result is a binary string of 16 bytes representing the 128 bit MD4
+digest value.
+
+[call [cmd "::md4::HMACInit"] [arg "key"]]
+
+This is equivalent to the [cmd "::md4::MD4Init"] command except that
+it requires the key that will be included in the HMAC.
+
+[call [cmd "::md4::HMACUpdate"] [arg "token"] [arg "data"]]
+[call [cmd "::md4::HMACFinal"] [arg "token"]]
+
+These commands are identical to the MD4 equivalent commands.
+
+[list_end]
+
+[section {EXAMPLES}]
+
+[example {
+% md4::md4 -hex "Tcl does MD4"
+858da9b31f57648a032230447bd15f25
+}]
+
+[example {
+% md4::hmac -hex -key Sekret "Tcl does MD4"
+c324088e5752872689caedf2a0464758
+}]
+
+[example {
+% set tok [md4::MD4Init]
+::md4::1
+% md4::MD4Update $tok "Tcl "
+% md4::MD4Update $tok "does "
+% md4::MD4Update $tok "MD4"
+% md4::Hex [md4::MD4Final $tok]
+858da9b31f57648a032230447bd15f25
+}]
+
+[section {REFERENCES}]
+
+[list_begin enumerated]
+
+[enum]
+ Rivest, R., "The MD4 Message Digest Algorithm", RFC 1320, MIT,
+ April 1992. ([uri http://www.rfc-editor.org/rfc/rfc1320.txt])
+
+[enum]
+ Rivest, R., "The MD4 message digest algorithm", in A.J. Menezes
+ and S.A. Vanstone, editors, Advances in Cryptology - CRYPTO '90
+ Proceedings, pages 303-311, Springer-Verlag, 1991.
+
+[enum]
+ Rivest, R., "The MD5 Message-Digest Algorithm", RFC 1321, MIT and
+ RSA Data Security, Inc, April 1992.
+ ([uri http://www.rfc-editor.org/rfc/rfc1321.txt])
+
+[enum]
+ Krawczyk, H., Bellare, M. and Canetti, R. "HMAC: Keyed-Hashing for
+ Message Authentication", RFC 2104, February 1997.
+ ([uri http://www.rfc-editor.org/rfc/rfc2104.txt])
+
+[list_end]
+
+[vset CATEGORY md4]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/md4/md4.tcl b/tcllib/modules/md4/md4.tcl
new file mode 100644
index 0000000..3138d57
--- /dev/null
+++ b/tcllib/modules/md4/md4.tcl
@@ -0,0 +1,571 @@
+# md4.tcl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# This is a Tcl-only implementation of the MD4 hash algorithm as described in
+# RFC 1320 ( http://www.ietf.org/rfc/rfc1320.txt )
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.2; # tcl minimum version
+catch {package require md4c 1.0}; # tcllib critcl alternative
+
+# @mdgen EXCLUDE: md4c.tcl
+
+namespace eval ::md4 {
+ variable accel
+ array set accel {critcl 0 cryptkit 0}
+
+ namespace export md4 hmac MD4Init MD4Update MD4Final
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 0
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# MD4Init - create and initialize an MD4 state variable. This will be
+# cleaned up when we call MD4Final
+#
+proc ::md4::MD4Init {} {
+ variable uid
+ variable accel
+ set token [namespace current]::[incr uid]
+ upvar #0 $token state
+
+ # RFC1320:3.3 - Initialize MD4 state structure
+ array set state \
+ [list \
+ A [expr {0x67452301}] \
+ B [expr {0xefcdab89}] \
+ C [expr {0x98badcfe}] \
+ D [expr {0x10325476}] \
+ n 0 i "" ]
+ if {$accel(cryptkit)} {
+ cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_MD4
+ }
+ return $token
+}
+
+proc ::md4::MD4Update {token data} {
+ variable accel
+ upvar #0 $token state
+
+ if {$accel(critcl)} {
+ if {[info exists state(md4c)]} {
+ set state(md4c) [md4c $data $state(md4c)]
+ } else {
+ set state(md4c) [md4c $data]
+ }
+ return
+ } elseif {[info exists state(ckctx)]} {
+ if {[string length $data] > 0} {
+ cryptkit::cryptEncrypt $state(ckctx) $data
+ }
+ return
+ }
+
+ # Update the state values
+ incr state(n) [string length $data]
+ append state(i) $data
+
+ # Calculate the hash for any complete blocks
+ set len [string length $state(i)]
+ for {set n 0} {($n + 64) <= $len} {} {
+ MD4Hash $token [string range $state(i) $n [incr n 64]]
+ }
+
+ # Adjust the state for the blocks completed.
+ set state(i) [string range $state(i) $n end]
+ return
+}
+
+proc ::md4::MD4Final {token} {
+ upvar #0 $token state
+
+ if {[info exists state(md4c)]} {
+ set r $state(md4c)
+ unset state
+ return $r
+ } elseif {[info exists state(ckctx)]} {
+ cryptkit::cryptEncrypt $state(ckctx) ""
+ cryptkit::cryptGetAttributeString $state(ckctx) \
+ CRYPT_CTXINFO_HASHVALUE r 16
+ cryptkit::cryptDestroyContext $state(ckctx)
+ # If nothing was hashed, we get no r variable set!
+ if {[info exists r]} {
+ unset state
+ return $r
+ }
+ }
+
+ # RFC1320:3.1 - Padding
+ #
+ set len [string length $state(i)]
+ set pad [expr {56 - ($len % 64)}]
+ if {$len % 64 > 56} {
+ incr pad 64
+ }
+ if {$pad == 0} {
+ incr pad 64
+ }
+ append state(i) [binary format a$pad \x80]
+
+ # RFC1320:3.2 - Append length in bits as little-endian wide int.
+ append state(i) [binary format ii [expr {8 * $state(n)}] 0]
+
+ # Calculate the hash for the remaining block.
+ set len [string length $state(i)]
+ for {set n 0} {($n + 64) <= $len} {} {
+ MD4Hash $token [string range $state(i) $n [incr n 64]]
+ }
+
+ # RFC1320:3.5 - Output
+ set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)]
+ unset state
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# HMAC Hashed Message Authentication (RFC 2104)
+#
+# hmac = H(K xor opad, H(K xor ipad, text))
+#
+proc ::md4::HMACInit {K} {
+
+ # Key K is adjusted to be 64 bytes long. If K is larger, then use
+ # the MD4 digest of K and pad this instead.
+ set len [string length $K]
+ if {$len > 64} {
+ set tok [MD4Init]
+ MD4Update $tok $K
+ set K [MD4Final $tok]
+ set len [string length $K]
+ }
+ set pad [expr {64 - $len}]
+ append K [string repeat \0 $pad]
+
+ # Cacluate the padding buffers.
+ set Ki {}
+ set Ko {}
+ binary scan $K i16 Ks
+ foreach k $Ks {
+ append Ki [binary format i [expr {$k ^ 0x36363636}]]
+ append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]]
+ }
+
+ set tok [MD4Init]
+ MD4Update $tok $Ki; # initialize with the inner pad
+
+ # preserve the Ko value for the final stage.
+ # FRINK: nocheck
+ set [subst $tok](Ko) $Ko
+
+ return $tok
+}
+
+proc ::md4::HMACUpdate {token data} {
+ MD4Update $token $data
+ return
+}
+
+proc ::md4::HMACFinal {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set tok [MD4Init]; # init the outer hashing function
+ MD4Update $tok $state(Ko); # prepare with the outer pad.
+ MD4Update $tok [MD4Final $token]; # hash the inner result
+ return [MD4Final $tok]
+}
+
+# -------------------------------------------------------------------------
+
+set ::md4::MD4Hash_body {
+ variable $token
+ upvar 0 $token state
+
+ # RFC1320:3.4 - Process Message in 16-Word Blocks
+ binary scan $msg i* blocks
+ foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks {
+ set A $state(A)
+ set B $state(B)
+ set C $state(C)
+ set D $state(D)
+
+ # Round 1
+ # Let [abcd k s] denote the operation
+ # a = (a + F(b,c,d) + X[k]) <<< s.
+ # Do the following 16 operations.
+ # [ABCD 0 3] [DABC 1 7] [CDAB 2 11] [BCDA 3 19]
+ set A [expr {($A + [F $B $C $D] + $X0) <<< 3}]
+ set D [expr {($D + [F $A $B $C] + $X1) <<< 7}]
+ set C [expr {($C + [F $D $A $B] + $X2) <<< 11}]
+ set B [expr {($B + [F $C $D $A] + $X3) <<< 19}]
+ # [ABCD 4 3] [DABC 5 7] [CDAB 6 11] [BCDA 7 19]
+ set A [expr {($A + [F $B $C $D] + $X4) <<< 3}]
+ set D [expr {($D + [F $A $B $C] + $X5) <<< 7}]
+ set C [expr {($C + [F $D $A $B] + $X6) <<< 11}]
+ set B [expr {($B + [F $C $D $A] + $X7) <<< 19}]
+ # [ABCD 8 3] [DABC 9 7] [CDAB 10 11] [BCDA 11 19]
+ set A [expr {($A + [F $B $C $D] + $X8) <<< 3}]
+ set D [expr {($D + [F $A $B $C] + $X9) <<< 7}]
+ set C [expr {($C + [F $D $A $B] + $X10) <<< 11}]
+ set B [expr {($B + [F $C $D $A] + $X11) <<< 19}]
+ # [ABCD 12 3] [DABC 13 7] [CDAB 14 11] [BCDA 15 19]
+ set A [expr {($A + [F $B $C $D] + $X12) <<< 3}]
+ set D [expr {($D + [F $A $B $C] + $X13) <<< 7}]
+ set C [expr {($C + [F $D $A $B] + $X14) <<< 11}]
+ set B [expr {($B + [F $C $D $A] + $X15) <<< 19}]
+
+ # Round 2.
+ # Let [abcd k s] denote the operation
+ # a = (a + G(b,c,d) + X[k] + 5A827999) <<< s
+ # Do the following 16 operations.
+ # [ABCD 0 3] [DABC 4 5] [CDAB 8 9] [BCDA 12 13]
+ set A [expr {($A + [G $B $C $D] + $X0 + 0x5a827999) <<< 3}]
+ set D [expr {($D + [G $A $B $C] + $X4 + 0x5a827999) <<< 5}]
+ set C [expr {($C + [G $D $A $B] + $X8 + 0x5a827999) <<< 9}]
+ set B [expr {($B + [G $C $D $A] + $X12 + 0x5a827999) <<< 13}]
+ # [ABCD 1 3] [DABC 5 5] [CDAB 9 9] [BCDA 13 13]
+ set A [expr {($A + [G $B $C $D] + $X1 + 0x5a827999) <<< 3}]
+ set D [expr {($D + [G $A $B $C] + $X5 + 0x5a827999) <<< 5}]
+ set C [expr {($C + [G $D $A $B] + $X9 + 0x5a827999) <<< 9}]
+ set B [expr {($B + [G $C $D $A] + $X13 + 0x5a827999) <<< 13}]
+ # [ABCD 2 3] [DABC 6 5] [CDAB 10 9] [BCDA 14 13]
+ set A [expr {($A + [G $B $C $D] + $X2 + 0x5a827999) <<< 3}]
+ set D [expr {($D + [G $A $B $C] + $X6 + 0x5a827999) <<< 5}]
+ set C [expr {($C + [G $D $A $B] + $X10 + 0x5a827999) <<< 9}]
+ set B [expr {($B + [G $C $D $A] + $X14 + 0x5a827999) <<< 13}]
+ # [ABCD 3 3] [DABC 7 5] [CDAB 11 9] [BCDA 15 13]
+ set A [expr {($A + [G $B $C $D] + $X3 + 0x5a827999) <<< 3}]
+ set D [expr {($D + [G $A $B $C] + $X7 + 0x5a827999) <<< 5}]
+ set C [expr {($C + [G $D $A $B] + $X11 + 0x5a827999) <<< 9}]
+ set B [expr {($B + [G $C $D $A] + $X15 + 0x5a827999) <<< 13}]
+
+ # Round 3.
+ # Let [abcd k s] denote the operation
+ # a = (a + H(b,c,d) + X[k] + 6ED9EBA1) <<< s.
+ # Do the following 16 operations.
+ # [ABCD 0 3] [DABC 8 9] [CDAB 4 11] [BCDA 12 15]
+ set A [expr {($A + [H $B $C $D] + $X0 + 0x6ed9eba1) <<< 3}]
+ set D [expr {($D + [H $A $B $C] + $X8 + 0x6ed9eba1) <<< 9}]
+ set C [expr {($C + [H $D $A $B] + $X4 + 0x6ed9eba1) <<< 11}]
+ set B [expr {($B + [H $C $D $A] + $X12 + 0x6ed9eba1) <<< 15}]
+ # [ABCD 2 3] [DABC 10 9] [CDAB 6 11] [BCDA 14 15]
+ set A [expr {($A + [H $B $C $D] + $X2 + 0x6ed9eba1) <<< 3}]
+ set D [expr {($D + [H $A $B $C] + $X10 + 0x6ed9eba1) <<< 9}]
+ set C [expr {($C + [H $D $A $B] + $X6 + 0x6ed9eba1) <<< 11}]
+ set B [expr {($B + [H $C $D $A] + $X14 + 0x6ed9eba1) <<< 15}]
+ # [ABCD 1 3] [DABC 9 9] [CDAB 5 11] [BCDA 13 15]
+ set A [expr {($A + [H $B $C $D] + $X1 + 0x6ed9eba1) <<< 3}]
+ set D [expr {($D + [H $A $B $C] + $X9 + 0x6ed9eba1) <<< 9}]
+ set C [expr {($C + [H $D $A $B] + $X5 + 0x6ed9eba1) <<< 11}]
+ set B [expr {($B + [H $C $D $A] + $X13 + 0x6ed9eba1) <<< 15}]
+ # [ABCD 3 3] [DABC 11 9] [CDAB 7 11] [BCDA 15 15]
+ set A [expr {($A + [H $B $C $D] + $X3 + 0x6ed9eba1) <<< 3}]
+ set D [expr {($D + [H $A $B $C] + $X11 + 0x6ed9eba1) <<< 9}]
+ set C [expr {($C + [H $D $A $B] + $X7 + 0x6ed9eba1) <<< 11}]
+ set B [expr {($B + [H $C $D $A] + $X15 + 0x6ed9eba1) <<< 15}]
+
+ # Then perform the following additions. (That is, increment each
+ # of the four registers by the value it had before this block
+ # was started.)
+ incr state(A) $A
+ incr state(B) $B
+ incr state(C) $C
+ incr state(D) $D
+ }
+
+ return
+}
+
+proc ::md4::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}}
+proc ::md4::bytes {v} {
+ #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v]
+ format %c%c%c%c \
+ [expr {0xFF & $v}] \
+ [expr {(0xFF00 & $v) >> 8}] \
+ [expr {(0xFF0000 & $v) >> 16}] \
+ [expr {((0xFF000000 & $v) >> 24) & 0xFF}]
+}
+
+# 32bit rotate-left
+proc ::md4::<<< {v n} {
+ return [expr {((($v << $n) \
+ | (($v >> (32 - $n)) \
+ & (0x7FFFFFFF >> (31 - $n))))) \
+ & 0xFFFFFFFF}]
+}
+
+# Convert our <<< pseudo-operator into a procedure call.
+regsub -all -line \
+ {\[expr {(.*) <<< (\d+)}\]} \
+ $::md4::MD4Hash_body \
+ {[<<< [expr {\1}] \2]} \
+ ::md4::MD4Hash_body
+
+# RFC1320:3.4 - function F
+proc ::md4::F {X Y Z} {
+ return [expr {($X & $Y) | ((~$X) & $Z)}]
+}
+
+# Inline the F function
+regsub -all -line \
+ {\[F (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+ $::md4::MD4Hash_body \
+ {( (\1 \& \2) | ((~\1) \& \3) )} \
+ ::md4::MD4Hash_body
+
+# RFC1320:3.4 - function G
+proc ::md4::G {X Y Z} {
+ return [expr {($X & $Y) | ($X & $Z) | ($Y & $Z)}]
+}
+
+# Inline the G function
+regsub -all -line \
+ {\[G (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+ $::md4::MD4Hash_body \
+ {((\1 \& \2) | (\1 \& \3) | (\2 \& \3))} \
+ ::md4::MD4Hash_body
+
+# RFC1320:3.4 - function H
+proc ::md4::H {X Y Z} {
+ return [expr {$X ^ $Y ^ $Z}]
+}
+
+# Inline the H function
+regsub -all -line \
+ {\[H (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+ $::md4::MD4Hash_body \
+ {(\1 ^ \2 ^ \3)} \
+ ::md4::MD4Hash_body
+
+# Define the MD4 hashing procedure with inline functions.
+proc ::md4::MD4Hash {token msg} $::md4::MD4Hash_body
+unset ::md4::MD4Hash_body
+
+# -------------------------------------------------------------------------
+
+if {[package provide Trf] != {}} {
+ interp alias {} ::md4::Hex {} ::hex -mode encode --
+} else {
+ proc ::md4::Hex {data} {
+ binary scan $data H* result
+ return [string toupper $result]
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# 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 ::md4::LoadAccelerator {name} {
+ variable accel
+ set r 0
+ switch -exact -- $name {
+ critcl {
+ if {![catch {package require tcllibc}]
+ || ![catch {package require md4c}]} {
+ set r [expr {[info commands ::md4::md4c] != {}}]
+ }
+ }
+ cryptkit {
+ if {![catch {package require cryptkit}]} {
+ set r [expr {![catch {cryptkit::cryptInit}]}]
+ }
+ }
+ #trf {
+ # if {![catch {package require Trf}]} {
+ # set r [expr {![catch {::md4 aa} msg]}]
+ # }
+ #}
+ default {
+ return -code error "invalid accelerator package:\
+ must be one of [join [array names accel] {, }]"
+ }
+ }
+ set accel($name) $r
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::md4::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# fileevent handler for chunked file hashing.
+#
+proc ::md4::Chunk {token channel {chunksize 4096}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {[eof $channel]} {
+ fileevent $channel readable {}
+ set state(reading) 0
+ }
+
+ MD4Update $token [read $channel $chunksize]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::md4::md4 {args} {
+ array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -hex { set opts(-hex) 1 }
+ -file* { set opts(-filename) [Pop args 1] }
+ -channel { set opts(-channel) [Pop args 1] }
+ -chunksize { set opts(-chunksize) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0 } { Pop args; break }
+ set err [join [lsort [array names opts]] ", "]
+ return -code error "bad option $option:\
+ must be one of $err"
+ }
+ }
+ Pop args
+ }
+
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args:\
+ should be \"md4 ?-hex? -filename file | string\""
+ }
+ set tok [MD4Init]
+ MD4Update $tok [lindex $args 0]
+ set r [MD4Final $tok]
+
+ } else {
+
+ set tok [MD4Init]
+ # FRINK: nocheck
+ set [subst $tok](reading) 1
+ fileevent $opts(-channel) readable \
+ [list [namespace origin Chunk] \
+ $tok $opts(-channel) $opts(-chunksize)]
+ vwait [subst $tok](reading)
+ set r [MD4Final $tok]
+
+ # If we opened the channel - we should close it too.
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+ }
+
+ if {$opts(-hex)} {
+ set r [Hex $r]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::md4::hmac {args} {
+ array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -key { set opts(-key) [Pop args 1] }
+ -hex { set opts(-hex) 1 }
+ -file* { set opts(-filename) [Pop args 1] }
+ -channel { set opts(-channel) [Pop args 1] }
+ -chunksize { set opts(-chunksize) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0 } { Pop args; break }
+ set err [join [lsort [array names opts]] ", "]
+ return -code error "bad option $option:\
+ must be one of $err"
+ }
+ }
+ Pop args
+ }
+
+ if {![info exists opts(-key)]} {
+ return -code error "wrong # args:\
+ should be \"hmac ?-hex? -key key -filename file | string\""
+ }
+
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args:\
+ should be \"hmac ?-hex? -key key -filename file | string\""
+ }
+ set tok [HMACInit $opts(-key)]
+ HMACUpdate $tok [lindex $args 0]
+ set r [HMACFinal $tok]
+
+ } else {
+
+ set tok [HMACInit $opts(-key)]
+ # FRINK: nocheck
+ set [subst $tok](reading) 1
+ fileevent $opts(-channel) readable \
+ [list [namespace origin Chunk] \
+ $tok $opts(-channel) $opts(-chunksize)]
+ vwait [subst $tok](reading)
+ set r [HMACFinal $tok]
+
+ # If we opened the channel - we should close it too.
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+ }
+
+ if {$opts(-hex)} {
+ set r [Hex $r]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::md4 {
+ variable e {}
+ foreach e {critcl cryptkit} { if {[LoadAccelerator $e]} { break } }
+ unset e
+}
+
+package provide md4 1.0.6
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
+
+
diff --git a/tcllib/modules/md4/md4.test b/tcllib/modules/md4/md4.test
new file mode 100644
index 0000000..f11ec7c
--- /dev/null
+++ b/tcllib/modules/md4/md4.test
@@ -0,0 +1,290 @@
+# md4.test - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# $Id: md4.test,v 1.15 2006/10/09 21:41:41 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal md4.tcl md4
+}
+
+# -------------------------------------------------------------------------
+
+if {[::md4::LoadAccelerator critcl]} {
+ puts "> using critcl"
+}
+if {[::md4::LoadAccelerator cryptkit]} {
+ puts "> using cryptkit"
+}
+puts "> pure Tcl"
+
+# -------------------------------------------------------------------------
+# Handle multiple implementation testing
+#
+
+array set preserve [array get ::md4::accel]
+
+proc implementations {} {
+ variable ::md4::accel
+ foreach {a v} [array get accel] {if {$v} {lappend r $a}}
+ lappend r tcl; set r
+}
+
+proc select_implementation {impl} {
+ variable ::md4::accel
+ foreach e [array names accel] { set accel($e) 0 }
+ if {[string compare "tcl" $impl] != 0} {
+ set accel($impl) 1
+ }
+}
+
+proc reset_implementation {} {
+ variable ::md4::accel
+ array set accel [array get ::preserve]
+}
+
+# -------------------------------------------------------------------------
+
+# The RFC 1320 test vectors
+#
+set vectors {
+ 1 {} {31D6CFE0D16AE931B73C59D7E0C089C0}
+ 2 {a} {BDE52CB31DE33E46245E05FBDBD6FB24}
+ 3 {abc} {A448017AAF21D8525FC10AE87AA6729D}
+ 4 {message digest} {D9130A8164549FE818874806E1C7014B}
+ 5 {abcdefghijklmnopqrstuvwxyz} {D79E1C308AA5BBCDEEA8ED63DF412DA9}
+ 6 {ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789}
+ {043F8582F241DB351CE627E153E7F0E4}
+ 7 {12345678901234567890123456789012345678901234567890123456789012345678901234567890}
+ {E33B4DDC9C38F2199C3E7B164FCC0536}
+}
+
+foreach impl [implementations] {
+ select_implementation $impl
+ foreach {n txt dgst} $vectors {
+ test md4-$impl-1.$n "md4 RFC test strings ($impl impl)" {
+ list [catch {::md4::md4 -hex $txt} r] $r
+ } [list 0 $dgst]
+ }
+ reset_implementation
+}
+
+# Block length checks
+# these values are generated from the OpenSSL library implementation
+# by md4_check.c
+#
+set vectors {
+ 0 31D6CFE0D16AE931B73C59D7E0C089C0
+ 1 BDE52CB31DE33E46245E05FBDBD6FB24
+ 2 0DE97E6BACB92B24D7578FFB8D58F51E
+ 3 918D7099B77C7A06634C62CCAF5EBAC7
+ 4 30FDB877509C742C0EF3D63DDBEC5146
+ 5 54485D61C2BF8519C3997D2C17D41B43
+ 6 9135D5535D445A5ADC299D227D3BDBFB
+ 7 EB393983D7223A7271398DA9CD13F13C
+ 8 23008F046FC579F2D373339EC07F1EF1
+ 9 A38217D543726545E70685379586F249
+ 10 55AEE4317CF6626378BDD590E1A10009
+ 11 528BCA944A4FC5F156765B0C415A0AEA
+ 12 8F919C346C23B06B46C872BE5F80D919
+ 13 EB50153829A34A8DE50ECCEEC7D44BAE
+ 14 0AF8EB203F383DCF6A9D888DE443572F
+ 15 C531CB0A83667B164886E6C1538AD95E
+ 16 877A3D1769C7FA80A74E7BD9D7602EF3
+ 17 DF84F880A964489D9832AF34FA58E591
+ 18 80E3D8A01982AA1E14994E453D33DD26
+ 19 F2F147FB12388BECE57ECA1DCC5ED53F
+ 20 1D9DB7A8B873E64A5C62727EDF6D4BBD
+ 21 CBBE5C1D394BB0B081E960FEF4E7CA15
+ 22 0641E7CD13C7FA26F6DA39E83CD31252
+ 23 76D25193130828ACCF4D771ACB1E51E3
+ 24 AB434803006332AB606B8C9D284579C9
+ 25 EA31D4CD2D48469501E09C62DA35FDBD
+ 26 9A374B8B9DD4D3D02AC55036236E7A4D
+ 27 CC678CD190CBD158E2A111A6A8E6EB4B
+ 28 DD3D0C638699B8DB7D4776A7BF415394
+ 29 AD4914D6703EC452117852FE99D45E83
+ 30 D4450595903614027BA328EEFA0EA601
+ 31 B439B841FD3BECFF4E2DAC49D19ED7CF
+ 32 7DFEF9B2EB78B2367246C381C8856478
+ 33 B3F634CC931234DEDF1E51B0015914F9
+ 34 C9EE7F5964094201EE080B572EF135E0
+ 35 E02F85B1A7838B905E90E279F27FEBC8
+ 36 1254586BFD14E030CE4086FA961CE782
+ 37 E93B0EBE0FE3C688419FAF37511C8F5B
+ 38 D6D79128936F4B32D01E395AECF29D82
+ 39 7A0AC9F4F25A7C47AFA9AA7DF30D3221
+ 40 2F195C997AADA83926FE22847CD3B37C
+ 41 09354A0A378CFDA1FF95A8885D38C4A8
+ 42 C2256534BFEAE9FA1EE7E86187BB965A
+ 43 FE8F4AE6501CA2898981F60DA8C7F6AE
+ 44 46140F97EFBD88928FF112F5367B526A
+ 45 9D403D371C315FF969BAADD8623BC8B3
+ 46 068D234494F92F646BA378BF505F8C47
+ 47 AF7C0BBED49C6211F1FF4B1739E7AC27
+ 48 14D946CC28AC58F8C5F210A06C1C6F25
+ 49 EB8702358201CDACE81AAA2DB0C6584E
+ 50 FB2A7C151E17EC3DF8502062D86135E3
+ 51 2D52D26552CBC27CB68EB829E35DD24D
+ 52 38AB80B7C2B45B568488244ADF334410
+ 53 BD3ED6F7A3A4DD4705360984A18577E5
+ 54 10993F670D6D785F3E87BC46E8DA89DC
+ 55 C889C81DD86C4D2E025778944EA02881
+ 56 D5F9A9E9257077A5F08B0B92F348B0AD
+ 57 872097E6F78E3B53F890459D03BC6FB7
+ 58 277F5F559A60C0AF69EFDA466786FB30
+ 59 A70AE7F83D838CCE274D7491AA915028
+ 60 8C6B85BECAB240CA5DB17955C4D39782
+ 61 672A99BA40462771641359DCC4CB1DDD
+ 62 5AE7B0C20144BC35483E8D7C16297658
+ 63 7EA3DA77432D44C323671097D1348FC8
+ 64 52F5076FABD22680234A3FA9F9DC5732
+ 65 330E377BF231F3CACFECC2C182FE7E5B
+ 66 095BA42E17C00F9336F807D8BDAE72A5
+ 67 B714FE2E2D4EBC2D801A481FFAE39FA9
+ 68 769051239BB45773C87C19F35071178A
+ 69 49311D7BB7CC3C078F932E873D7769D2
+ 70 DF01FC1E5DD0BFC600DB67201C977EFC
+ 71 09751A7E990FB1D82C0A1293E5F5B3CC
+ 72 040E619A227C013B5201A9796246D4AE
+ 73 3470CE6363ED22E5496F138AA7108416
+ 74 26A8C2B51DC60D23597CCA9025119030
+ 75 E82ACDF62A2512470B9580B53DF18A2B
+ 76 C5B92B27DA91D2267C23446ECB6A912C
+ 77 CDE8AF463FF6018AE7B99AC9DE24EA36
+ 78 A883A850600DF1EEF28C573E034E7D18
+ 79 A7CCE750192AC057036F1B4C5A2605C8
+ 80 721A93B051049C47487B06A59ACC7D64
+ 81 F28AA8607F27E972E483638794C1C5FF
+ 82 577AB2592E92823D26788493457AFB35
+ 83 157BB5E384BBFD04719CBB1EACBAC84B
+ 84 66385A9301518DD05B0F565F08A600EA
+ 85 0B87DD13CDF6541F400FABE41FA5BA78
+ 86 A6446864A8BF8D07D57D96DD908EA956
+ 87 6979B8ECFE581790AC7CD990E8E0736E
+ 88 F0E85BD3BA0E224FDC2306C256CD5F3A
+ 89 60FA15155478D3C8A76E5ABBDB77CFBE
+ 90 FCFF0A17BD61381B77355CEF66808308
+ 91 828C52051A9693A1B54BE9352268955D
+ 92 53A6B8D4DD7D0770A5F6DC9874E7B88C
+ 93 00F8653F803627B70EF2E7E1654576C0
+ 94 14A4D10648330012FE672B650C196021
+ 95 A6A0B64C05FCD2E57D8CBBC59A1A00B7
+ 96 DDC02B8E0A315BA8EE08851668A081A9
+ 97 4067061356FA1E283EC5F3610E7EACF0
+ 98 717D2EF3060CA3208DECAE86F9BDCFD9
+ 99 7B625DF18DC2FFF7F5244A4C50915893
+ 100 A2A3C7C3EE6088BAD252BFBBAE229BB6
+ 101 547401415A107A8147D3BAB71991BE0E
+ 102 E1C162A95EBE24D4A78DA81FAA6A451B
+ 103 2A3D6778231DC7EF4AB0D96DB648D128
+ 104 89E6CF2B88C9328A4C348A731D317D25
+ 105 CF71FEC4631DB55308AD80186B8DCF37
+ 106 343CA55FC783302EF9A0B33757E5EF19
+ 107 AAD33B8FF079A18D6425470D011B4D31
+ 108 357C138B5498B531CB174127FCF14A0F
+ 109 73B22BE5DBAD1D26BD9071AFEBC35856
+ 110 74101D5E7A9321DAD687B4C2AC7E7551
+ 111 69DAEFFB60DD1DCFC8A0DDF5ED4DEA4F
+ 112 CCBF3DFA0FAC8C6E5C2504CF15777E71
+ 113 6EE2AD0A2A06E975C2FA8887333DE734
+ 114 8A7DEFD65211A52A20CBD989BCB079D7
+ 115 650A6088C41B5951EF46B09F8A8F7A16
+ 116 F731ACBD40496A63FD33C72BFF4ADC4C
+ 117 64279E932B0A6CF7FBEBC12969AD85F9
+ 118 5257D42AE36DCFC8418FA40600696E16
+ 119 E65DD227CCEF97FA1D34D70189120F76
+ 120 B03DDBD470B47C013E0C7AB2DDD763DB
+ 121 E5601AA6994470F918405D745EDE163C
+ 122 6BAF506A6E6A525E9EF9BBF7E6B4F45B
+ 123 D312F30D9FFF78E5404F8EAC3F0B665F
+ 124 A7A1C6286070E9A7AFA4831D2BF7BAFD
+ 125 941B80ACD86C9D9C3F27380591507DED
+ 126 85C05A6BB4B2CF906813652C68686361
+ 127 9733B046AD770B4E093B35DE4E09E828
+ 128 CB4A20A561558E29460190C91DCED59F
+ 129 2ADCD303C29F93A3EE33A560ECE91CD2
+ 130 52B8CE960BB64E4EC2B579D4047B175E
+ 131 6EF49AAA109B8120004FFCC801218CAF
+ 132 370ED97ADF490F75693CD5FC73A8E3E0
+ 133 54DE78D79AD53DA4CE46F945160B591F
+ 134 0D9014C7B4A9EDB3D594056E78D25B9D
+ 135 4AE5F06E7A0AB2B7142583873ACFCCFD
+ 136 C4CA41E447A27ECEE443370B002B6459
+ 137 9A64358C2602DA3F21D2E79B21E94BF1
+ 138 5761A624A7BDEDAD64E543BC73213E64
+ 139 D301A78CB6959F11E81BD7A3C6BF5BB3
+ 140 5D726C762665398737C34803095E91F3
+ 141 DB62B01151A01D5E4A00D87F2A48B98A
+ 142 C310B6E1016ECB9F5A5C5A4B89F17A76
+ 143 33C7D6E29F904B27272E75144BE07D18
+ 144 835048E983D82FB0FA151BB8B6FA636E
+ 145 B9FF2575260E2AD08557EEBA52B27CDD
+ 146 BCCCBCFEAB174BDDB81CC74DD97984F6
+ 147 9B98A75EDED6B5AF8C449B75A74C30B3
+ 148 5F9F642231152DD8CD5CAA9B5FC59B5D
+ 149 84D82189C5458F8647D338FD62EF1667
+}
+
+foreach impl [implementations] {
+ select_implementation $impl
+ foreach {n hash} $vectors {
+ test md4-$impl-2.$n "md4 block size checks: length $n ($impl)" {
+ list [catch {
+ ::md4::md4 -hex [string repeat a $n]
+ } msg] $msg
+ } [list 0 $hash]
+ }
+ reset_implementation
+}
+
+# -------------------------------------------------------------------------
+
+test md4-3.1 {Check hashing data that begins with hyphen} {
+ list [catch {::md4::md4 -hex -hello} msg] $msg
+} {0 2366A71EF5007E097635894C39E6D649}
+
+test md4-3.2 {Check hashing data that begins with hyphen} {
+ list [catch {::md4::md4 -hex -- -hello} msg] $msg
+} {0 2366A71EF5007E097635894C39E6D649}
+
+test md4-3.3 {Check hashing data that begins with hyphen} {
+ list [catch {::md4::md4 -hex --} msg] $msg
+} {0 4C0C5CD6347599F2A7FB4B8135E8BC54}
+
+test md4-3.4 {Check hashing data that begins with hyphen} {
+ list [catch {::md4::md4 -hex -- --} msg] $msg
+} {0 4C0C5CD6347599F2A7FB4B8135E8BC54}
+
+
+test md4-4.1 {Check hmac data that begins with hyphen} {
+ list [catch {::md4::hmac -hex -key "" -hello} msg] $msg
+} {0 5B3C613872A7EF6B027E108649E586E9}
+
+test md4-4.2 {Check hmac data that begins with hyphen} {
+ list [catch {::md4::hmac -hex -key "" -- -hello} msg] $msg
+} {0 5B3C613872A7EF6B027E108649E586E9}
+
+test md4-4.3 {Check hmac data that begins with hyphen} {
+ list [catch {::md4::hmac -hex -key "" --} msg] $msg
+} {0 8CE99298976A960211A6D3FB2EAC8B2D}
+
+test md4-4.4 {Check hmac data that begins with hyphen} {
+ list [catch {::md4::hmac -hex -key "" -- --} msg] $msg
+} {0 8CE99298976A960211A6D3FB2EAC8B2D}
+
+
+testsuiteCleanup
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/md4/md4_check.c b/tcllib/modules/md4/md4_check.c
new file mode 100644
index 0000000..fc24269
--- /dev/null
+++ b/tcllib/modules/md4/md4_check.c
@@ -0,0 +1,62 @@
+/* md4_check.c Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+ *
+ * Generate test data to permit comparison of the tcl implementation of MD4
+ * against the OpenSSL library implementation.
+ *
+ * usage: md4_check
+ *
+ * $Id: md4_check.c,v 1.2 2004/01/15 06:36:13 andreas_kupries Exp $
+ */
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <openssl/md4.h>
+
+static const char rcsid[] =
+"$Id: md4_check.c,v 1.2 2004/01/15 06:36:13 andreas_kupries Exp $";
+
+void
+md4(const char *buf, size_t len, unsigned char *res)
+{
+ MD4_CTX ctx;
+ MD4_Init(&ctx);
+ MD4_Update(&ctx, buf, len);
+ MD4_Final(res, &ctx);
+}
+
+void
+dump(unsigned char *data, size_t len)
+{
+ char buf[80], *p;
+ size_t cn, n;
+
+ for (cn = 0, p = buf; cn < len; cn++, p += 2) {
+ n = sprintf(p, "%02X", data[cn]);
+ }
+ puts(buf);
+}
+
+int
+main(int argc, char *argv[])
+{
+ size_t cn;
+ char buf[256];
+ unsigned char r[16];
+
+ memset(buf, 'a', 256);
+
+ for (cn = 0; cn < 150; cn++) {
+ md4(buf, cn, r);
+ printf("%7d ", cn);
+ dump(r, 16);
+ }
+ return 0;
+}
+
+/*
+ * Local variables:
+ * mode: c
+ * indent-tabs-mode: nil
+ * End:
+ */
diff --git a/tcllib/modules/md4/md4c.tcl b/tcllib/modules/md4/md4c.tcl
new file mode 100644
index 0000000..fa89b61
--- /dev/null
+++ b/tcllib/modules/md4/md4c.tcl
@@ -0,0 +1,120 @@
+# md4c.tcl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# This provides a C implementation of MD4 using the sample code from RFC1320
+# and wrapping this up in a Tcl package.
+#
+# The tcl interface code is based upon the md5c code from critcl by JCW.
+#
+# INSTALLATION
+# ------------
+# This package uses critcl (http://wiki.tcl.tk/critcl). To build do:
+# critcl -libdir <your-tcl-lib-dir> -pkg md4c md4c
+#
+# $Id: md4c.tcl,v 1.6 2009/05/06 22:57:50 patthoyts Exp $
+
+package require critcl
+# @sak notprovided md4c
+package provide md4c 1.1.0
+
+critcl::cheaders md4.h
+critcl::csources md4.c
+
+namespace eval ::md4 {
+
+ critcl::ccode {
+ #include <string.h>
+ #include "md4.h"
+
+ /*
+ * define a Tcl object type for the MD4 state
+ */
+ static Tcl_ObjType md4_type;
+
+ static void md4_free_rep(Tcl_Obj *obj)
+ {
+ MD4_CTX *ctx = (MD4_CTX *)obj->internalRep.otherValuePtr;
+ Tcl_Free((char *)ctx);
+ }
+
+ static void md4_dup_rep(Tcl_Obj *obj, Tcl_Obj *dup)
+ {
+ MD4_CTX *ctx = (MD4_CTX *)obj->internalRep.otherValuePtr;
+ dup->internalRep.otherValuePtr = (MD4_CTX *)Tcl_Alloc(sizeof(MD4_CTX));
+ memcpy(dup->internalRep.otherValuePtr, ctx, sizeof(MD4_CTX));
+ dup->typePtr = &md4_type;
+ }
+
+ static void md4_string_rep(Tcl_Obj* obj)
+ {
+ unsigned char buf[16];
+ Tcl_Obj* temp;
+ char* str;
+ MD4_CTX *dup = (MD4_CTX *)obj->internalRep.otherValuePtr;
+
+ MD4Final(buf, dup);
+
+ /* convert via a byte array to properly handle null bytes */
+ temp = Tcl_NewByteArrayObj(buf, sizeof buf);
+ Tcl_IncrRefCount(temp);
+
+ str = Tcl_GetStringFromObj(temp, &obj->length);
+ obj->bytes = Tcl_Alloc(obj->length + 1);
+ memcpy(obj->bytes, str, obj->length + 1);
+
+ Tcl_DecrRefCount(temp);
+ }
+
+ static int md4_from_any(Tcl_Interp* interp, Tcl_Obj* obj)
+ {
+ /* assert(0); */
+ return TCL_ERROR;
+ }
+
+ static Tcl_ObjType md4_type = {
+ "md4c", md4_free_rep, md4_dup_rep, md4_string_rep, md4_from_any
+ };
+
+ }
+
+ critcl::ccommand md4c {dummy interp objc objv} {
+ MD4_CTX *ctx;
+ unsigned char *data;
+ int size;
+ Tcl_Obj *obj;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "data ?context?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 3) {
+ if (objv[2]->typePtr != &md4_type
+ && md4_from_any(interp, objv[2]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ obj = objv[2];
+ if (Tcl_IsShared(obj)) {
+ obj = Tcl_DuplicateObj(obj);
+ }
+ } else {
+ ctx = (MD4_CTX *)Tcl_Alloc(sizeof(MD4_CTX));
+ MD4Init(ctx);
+ obj = Tcl_NewObj();
+ Tcl_InvalidateStringRep(obj);
+ obj->internalRep.otherValuePtr = ctx;
+ obj->typePtr = &md4_type;
+ }
+
+ ctx = (MD4_CTX *)obj->internalRep.otherValuePtr;
+ data = Tcl_GetByteArrayFromObj(objv[1], &size);
+ MD4Update(ctx, data, size);
+ Tcl_SetObjResult(interp, obj);
+
+ return TCL_OK;
+ }
+}
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/md4/pkgIndex.tcl b/tcllib/modules/md4/pkgIndex.tcl
new file mode 100644
index 0000000..dbbe004
--- /dev/null
+++ b/tcllib/modules/md4/pkgIndex.tcl
@@ -0,0 +1,3 @@
+# This package has been tested with tcl 8.2.3 and above.
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded md4 1.0.6 [list source [file join $dir md4.tcl]]
diff --git a/tcllib/modules/md5/ChangeLog b/tcllib/modules/md5/ChangeLog
new file mode 100644
index 0000000..c19a9c6
--- /dev/null
+++ b/tcllib/modules/md5/ChangeLog
@@ -0,0 +1,308 @@
+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-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 ========================
+ *
+
+2009-05-06 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5c.tcl: The md5c command was leaking a Tcl_Obj on each call
+ due to having one too many ref counts. Also use Tcl_Alloc rather
+ than malloc.
+
+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 ========================
+ *
+
+2008-07-04 Andreas Kupries <andreask@activestate.com>
+
+ * md5.man: Fixed creative writing problem reported by
+ * md5x.tcl: Julian Noble <juliannoble@users.sourceforge.net>,
+ * pkgIndex.tcl: as [Bug 2010798]. Bumped version to 2.0.7.
+
+2008-04-29 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5x.tcl: Clean up the MD5Hash_body once the proc defined.
+
+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>
+
+ * md5.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-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * md5.man: Bumped version to 2.0.5
+ * md5x.tcl:
+ * pkgIndex.tcl:
+
+2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5x.test: Fixed usage of duplicate test names.
+
+2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5.test: More boilerplate simplified via use of test support.
+ * md5x.test:
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5.test: Hooked into the new common test support code.
+ * md5x.test:
+
+2005-10-24 Andreas Kupries <andreask@activestate.com>
+
+ * md5v1.bench: New file. Basic benchmarks for MD5 hashes.
+ * md5v2.bench:
+
+2005-10-17 Andreas Kupries <andreask@activestate.com>
+
+ * md5x.tcl: Trivial comment typo fix.
+
+2005-10-17 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5x.tcl: Performance fix for tcl8.5 integers.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-02-24 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5.tcl: Arranged to run all available implementations in
+ * md5.test: the tests.
+
+2005-02-23 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * pkgIndex.tcl: Incremented version to 2.0.4
+ * md5x.tcl: Rationalised the handling of accelerator packages and
+ * md5x.test: added support for use of cryptkit. Updated the man
+ * md5.man: page to note the available accelerators.
+
+2005-02-20 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5x.test: Added the RFC 2202 HMAC-MD5 test vectors.
+
+2005-02-17 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5x.tcl: Avoid raising an error if the string to be hashed
+ * pkgIndex.tcl: begins with a hyphen. Use '--' as an _optional_
+ * md5.mac: end-of-args marker.
+ * md5x.test: Added tests.
+
+2004-12-02 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5x.tcl: Replaced use of memchan null channel with the systems
+ NUL device (NUL or /dev/null). This avoids problems with clashing
+ names when memchan gets included.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-07-01 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5x.tcl: Try and fix up the use of Trf with Memchan for the
+ new-style md5 package. Needs fixed recent versions of both
+ packages.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5x.tcl: Updated version number to sync with 1.6.1
+ * md5.man: release.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5x.tcl: Rel. engineering. Updated version number
+ * md5.man: of md5 v2 to reflect its changes, to 2.0.1.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5x.tcl: Rel. engineering. Updated version number
+ * md5.man: of md5 v2 to reflect its changes, to 2.0.1.
+ * pkgIndex.tcl:
+
+2004-02-18 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5x.tcl: Added -- to end options if using Trf's hex in case the
+ hash begins with a - character (possible). Streamlined the <<<
+ proc.
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5x.test: Heh. What a surprise. The testsuite uses a command to
+ generate the proper error message based on the version of Tcl,
+ and what does md5 v2 ? It generates its own messages, and they
+ are always in 8.4+ format. Hnn. Fixed the testsuite.
+
+2003-07-27 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5.man: Updated the manual page for md5 2.0
+
+2003-07-26 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5c.tcl: Brought in the critcl implementation of MD5
+ * md5.c: originally by Jean-Claude Wippler <jcw@equi4.com>
+ * md5.h: with code from RFC 1321.
+
+ * md5x.tcl: Version 2 md5 module. This is based upon the MD4 module
+ * md5x.test: code and permits incremental updates into the hash.
+ This version will use the critcl code if available.
+
+ === VERSION INCOMPATABILITY ===
+
+ md5 1 returns data as a hex representation.
+ md5 2 returns the data as a binary representation. If you want the
+ hex rep, provide the -hex option to the md5 command.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * md5.tcl:
+ * md5.man:
+ * pkgIndex.tcl: Set version of the package to to 1.4.3.
+
+2003-02-05 David N. Welton <davidw@dedasys.com>
+
+ * md5.tcl (::md5::time): Used lindex instead of regexp to fish the
+ number out of 'time' results. Not really a performance win here,
+ but it's good style.
+
+2003-01-06 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5.tcl: Handle cases where Trf is available but the md5 command
+ is not callable (like missing crypt.dll or libmd5crypt).
+
+2002-03-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5.man: Fixed formatting errors in the doctools manpage.
+
+2002-02-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Version up to 1.4.2 to differentiate development from the
+ version in the tcllib 1.2 release.
+
+ * md5.tcl: Adding -- to hex/md5 commands to prevent
+ misinterpretation of data if starting with -.
+
+2001-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5.n:
+ * md5.tcl:
+ * pkgIndex.tcl: Version up to 1.4.1
+
+2001-08-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5.test: Fixed broken error messages for 8.4. Using
+ [tcltest::getErrorMessage] now to get the correct message for
+ all versions of the core. Bug [440046] reported by Larry Virden.
+
+2001-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5.tcl: Frink 2.2 run, fixed dubious code.
+
+2001-07-03 Miguel Sofer <mig@utdt.edu>
+
+ * md5.tcl: some more inlining, 10% faster
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5.tcl: Fixed dubious code reported by frink.
+
+2001-06-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5.n: Fixed nroff trouble.
+
+2001-06-02 Miguel Sofer <mig@utdt.edu>
+
+ * md5.tcl: modified the pure Tcl code to run almost 5 times
+ faster, by inlining (via regsub) function calls and using local
+ variables instead of arrays.
+
+ Bumped version number to 1.4
+
+2001-04-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5.test: Added tests of "md5::hmac". This allows us to test the
+ two different implementations against each other.
+
+ Note: The test file will now print which of the two variants
+ (pure Tcl vs. Trf based) is active and under test.
+
+ * md5.tcl: Added code to create a soft dependency on Trf. In other
+ words, if Trf is present it will be loaded and used to speed up
+ operations. Without Trf the original code in pure Tcl will be
+ used. Note that the presence of Trf allows us to optimize the
+ command "md5::hmac" too.
+
+2001-04-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module, 'md5'. The code Don Libes's <libes@nist.gov>
+ md5pure, extended with a soft dependency on Trf to allow higher
+ speed if the environment is right.
diff --git a/tcllib/modules/md5/md5.c b/tcllib/modules/md5/md5.c
new file mode 100644
index 0000000..0a8cafe
--- /dev/null
+++ b/tcllib/modules/md5/md5.c
@@ -0,0 +1,293 @@
+/*
+ ***********************************************************************
+ ** md5.c -- the source code for MD5 routines **
+ ** RSA Data Security, Inc. MD5 Message-Digest Algorithm **
+ ** Created: 2/17/90 RLR **
+ ** Revised: 1/91 SRD,AJ,BSK,JT Reference C Version **
+ ***********************************************************************
+ */
+
+/*
+ * Edited 7 May 93 by CP to change the interface to match that
+ * of the MD5 routines in RSAREF. Due to this alteration, this
+ * code is "derived from the RSA Data Security, Inc. MD5 Message-
+ * Digest Algorithm". (See below.)
+ */
+
+/*
+ ***********************************************************************
+ ** Copyright (C) 1990, RSA Data Security, Inc. All rights reserved. **
+ ** **
+ ** License to copy and use this software is granted provided that **
+ ** it is identified as the "RSA Data Security, Inc. MD5 Message- **
+ ** Digest Algorithm" in all material mentioning or referencing this **
+ ** software or this function. **
+ ** **
+ ** License is also granted to make and use derivative works **
+ ** provided that such works are identified as "derived from the RSA **
+ ** Data Security, Inc. MD5 Message-Digest Algorithm" in all **
+ ** material mentioning or referencing the derived work. **
+ ** **
+ ** RSA Data Security, Inc. makes no representations concerning **
+ ** either the merchantability of this software or the suitability **
+ ** of this software for any particular purpose. It is provided "as **
+ ** is" without express or implied warranty of any kind. **
+ ** **
+ ** These notices must be retained in any copies of any part of this **
+ ** documentation and/or software. **
+ ***********************************************************************
+ */
+
+#include "md5.h"
+
+/*
+ ***********************************************************************
+ ** Message-digest routines: **
+ ** To form the message digest for a message M **
+ ** (1) Initialize a context buffer mdContext using MD5Init **
+ ** (2) Call MD5Update on mdContext and M **
+ ** (3) Call MD5Final on mdContext **
+ ** The message digest is now in the bugffer passed to MD5Final **
+ ***********************************************************************
+ */
+
+static unsigned char PADDING[64] = {
+ 0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00
+};
+
+/* F, G, H and I are basic MD5 functions */
+#define F(x, y, z) (((x) & (y)) | ((~x) & (z)))
+#define G(x, y, z) (((x) & (z)) | ((y) & (~z)))
+#define H(x, y, z) ((x) ^ (y) ^ (z))
+#define I(x, y, z) ((y) ^ ((x) | (~z)))
+
+/* ROTATE_LEFT rotates x left n bits */
+#define ROTATE_LEFT(x, n) (((x) << (n)) | ((x) >> (32-(n))))
+
+/* FF, GG, HH, and II transformations for rounds 1, 2, 3, and 4 */
+/* Rotation is separate from addition to prevent recomputation */
+#define FF(a, b, c, d, x, s, ac) \
+ {(a) += F ((b), (c), (d)) + (x) + (UINT4)(ac); \
+ (a) = ROTATE_LEFT ((a), (s)); \
+ (a) += (b); \
+ }
+#define GG(a, b, c, d, x, s, ac) \
+ {(a) += G ((b), (c), (d)) + (x) + (UINT4)(ac); \
+ (a) = ROTATE_LEFT ((a), (s)); \
+ (a) += (b); \
+ }
+#define HH(a, b, c, d, x, s, ac) \
+ {(a) += H ((b), (c), (d)) + (x) + (UINT4)(ac); \
+ (a) = ROTATE_LEFT ((a), (s)); \
+ (a) += (b); \
+ }
+#define II(a, b, c, d, x, s, ac) \
+ {(a) += I ((b), (c), (d)) + (x) + (UINT4)(ac); \
+ (a) = ROTATE_LEFT ((a), (s)); \
+ (a) += (b); \
+ }
+
+/* The routine MD5Init initializes the message-digest context
+ mdContext. All fields are set to zero.
+ */
+void MD5Init (mdContext)
+MD5_CTX *mdContext;
+{
+ mdContext->i[0] = mdContext->i[1] = (UINT4)0;
+
+ /* Load magic initialization constants.
+ */
+ mdContext->buf[0] = (UINT4)0x67452301L;
+ mdContext->buf[1] = (UINT4)0xefcdab89L;
+ mdContext->buf[2] = (UINT4)0x98badcfeL;
+ mdContext->buf[3] = (UINT4)0x10325476L;
+}
+
+/* The routine MD5Update updates the message-digest context to
+ account for the presence of each of the characters inBuf[0..inLen-1]
+ in the message whose digest is being computed.
+ */
+void MD5Update (mdContext, inBuf, inLen)
+register MD5_CTX *mdContext; unsigned char *inBuf;
+ unsigned int inLen;
+{
+ register int i, ii;
+ int mdi;
+ UINT4 in[16];
+
+ /* compute number of bytes mod 64 */
+ mdi = (int)((mdContext->i[0] >> 3) & 0x3F);
+
+ /* update number of bits */
+ if ((mdContext->i[0] + ((UINT4)inLen << 3)) < mdContext->i[0])
+ mdContext->i[1]++;
+ mdContext->i[0] += ((UINT4)inLen << 3);
+ mdContext->i[1] += ((UINT4)inLen >> 29);
+
+ while (inLen--) {
+ /* add new character to buffer, increment mdi */
+ mdContext->in[mdi++] = *inBuf++;
+
+ /* transform if necessary */
+ if (mdi == 0x40) {
+ for (i = 0, ii = 0; i < 16; i++, ii += 4)
+ in[i] = (((UINT4)mdContext->in[ii+3]) << 24) |
+ (((UINT4)mdContext->in[ii+2]) << 16) |
+ (((UINT4)mdContext->in[ii+1]) << 8) |
+ ((UINT4)mdContext->in[ii]);
+ Transform (mdContext->buf, in);
+ mdi = 0;
+ }
+ }
+}
+
+/* The routine MD5Final terminates the message-digest computation and
+ ends with the desired message digest in mdContext->digest[0...15].
+ */
+void MD5Final (digest, mdContext)
+unsigned char digest[16]; MD5_CTX *mdContext;
+{
+ UINT4 in[16];
+ int mdi;
+ unsigned int i, ii;
+ unsigned int padLen;
+
+ /* save number of bits */
+ in[14] = mdContext->i[0];
+ in[15] = mdContext->i[1];
+
+ /* compute number of bytes mod 64 */
+ mdi = (int)((mdContext->i[0] >> 3) & 0x3F);
+
+ /* pad out to 56 mod 64 */
+ padLen = (mdi < 56) ? (56 - mdi) : (120 - mdi);
+ MD5Update (mdContext, PADDING, padLen);
+
+ /* append length in bits and transform */
+ for (i = 0, ii = 0; i < 14; i++, ii += 4)
+ in[i] = (((UINT4)mdContext->in[ii+3]) << 24) |
+ (((UINT4)mdContext->in[ii+2]) << 16) |
+ (((UINT4)mdContext->in[ii+1]) << 8) |
+ ((UINT4)mdContext->in[ii]);
+ Transform (mdContext->buf, in);
+
+ /* store buffer in digest */
+ for (i = 0, ii = 0; i < 4; i++, ii += 4) {
+ digest[ii] = (unsigned char) (mdContext->buf[i] & 0xFF);
+ digest[ii+1] = (unsigned char)((mdContext->buf[i] >> 8) & 0xFF);
+ digest[ii+2] = (unsigned char)((mdContext->buf[i] >> 16) & 0xFF);
+ digest[ii+3] = (unsigned char)((mdContext->buf[i] >> 24) & 0xFF);
+ }
+}
+
+/* Basic MD5 step. Transforms buf based on in. Note that if the Mysterious
+ Constants are arranged backwards in little-endian order and decrypted with
+ the DES they produce OCCULT MESSAGES!
+ */
+void Transform(buf, in)
+register UINT4 *buf;
+register UINT4 *in;
+{
+ register UINT4 a = buf[0], b = buf[1], c = buf[2], d = buf[3];
+
+ /* Round 1 */
+#define S11 7
+#define S12 12
+#define S13 17
+#define S14 22
+ FF ( a, b, c, d, in[ 0], S11, 0xD76AA478L); /* 1 */
+ FF ( d, a, b, c, in[ 1], S12, 0xE8C7B756L); /* 2 */
+ FF ( c, d, a, b, in[ 2], S13, 0x242070DBL); /* 3 */
+ FF ( b, c, d, a, in[ 3], S14, 0xC1BDCEEEL); /* 4 */
+ FF ( a, b, c, d, in[ 4], S11, 0xF57C0FAFL); /* 5 */
+ FF ( d, a, b, c, in[ 5], S12, 0x4787C62AL); /* 6 */
+ FF ( c, d, a, b, in[ 6], S13, 0xA8304613L); /* 7 */
+ FF ( b, c, d, a, in[ 7], S14, 0xFD469501L); /* 8 */
+ FF ( a, b, c, d, in[ 8], S11, 0x698098D8L); /* 9 */
+ FF ( d, a, b, c, in[ 9], S12, 0x8B44F7AFL); /* 10 */
+ FF ( c, d, a, b, in[10], S13, 0xFFFF5BB1L); /* 11 */
+ FF ( b, c, d, a, in[11], S14, 0x895CD7BEL); /* 12 */
+ FF ( a, b, c, d, in[12], S11, 0x6B901122L); /* 13 */
+ FF ( d, a, b, c, in[13], S12, 0xFD987193L); /* 14 */
+ FF ( c, d, a, b, in[14], S13, 0xA679438EL); /* 15 */
+ FF ( b, c, d, a, in[15], S14, 0x49B40821L); /* 16 */
+
+ /* Round 2 */
+#define S21 5
+#define S22 9
+#define S23 14
+#define S24 20
+ GG ( a, b, c, d, in[ 1], S21, 0xF61E2562L); /* 17 */
+ GG ( d, a, b, c, in[ 6], S22, 0xC040B340L); /* 18 */
+ GG ( c, d, a, b, in[11], S23, 0x265E5A51L); /* 19 */
+ GG ( b, c, d, a, in[ 0], S24, 0xE9B6C7AAL); /* 20 */
+ GG ( a, b, c, d, in[ 5], S21, 0xD62F105DL); /* 21 */
+ GG ( d, a, b, c, in[10], S22, 0x02441453L); /* 22 */
+ GG ( c, d, a, b, in[15], S23, 0xD8A1E681L); /* 23 */
+ GG ( b, c, d, a, in[ 4], S24, 0xE7D3FBC8L); /* 24 */
+ GG ( a, b, c, d, in[ 9], S21, 0x21E1CDE6L); /* 25 */
+ GG ( d, a, b, c, in[14], S22, 0xC33707D6L); /* 26 */
+ GG ( c, d, a, b, in[ 3], S23, 0xF4D50D87L); /* 27 */
+ GG ( b, c, d, a, in[ 8], S24, 0x455A14EDL); /* 28 */
+ GG ( a, b, c, d, in[13], S21, 0xA9E3E905L); /* 29 */
+ GG ( d, a, b, c, in[ 2], S22, 0xFCEFA3F8L); /* 30 */
+ GG ( c, d, a, b, in[ 7], S23, 0x676F02D9L); /* 31 */
+ GG ( b, c, d, a, in[12], S24, 0x8D2A4C8AL); /* 32 */
+
+ /* Round 3 */
+#define S31 4
+#define S32 11
+#define S33 16
+#define S34 23
+ HH ( a, b, c, d, in[ 5], S31, 0xFFFA3942L); /* 33 */
+ HH ( d, a, b, c, in[ 8], S32, 0x8771F681L); /* 34 */
+ HH ( c, d, a, b, in[11], S33, 0x6D9D6122L); /* 35 */
+ HH ( b, c, d, a, in[14], S34, 0xFDE5380CL); /* 36 */
+ HH ( a, b, c, d, in[ 1], S31, 0xA4BEEA44L); /* 37 */
+ HH ( d, a, b, c, in[ 4], S32, 0x4BDECFA9L); /* 38 */
+ HH ( c, d, a, b, in[ 7], S33, 0xF6BB4B60L); /* 39 */
+ HH ( b, c, d, a, in[10], S34, 0xBEBFBC70L); /* 40 */
+ HH ( a, b, c, d, in[13], S31, 0x289B7EC6L); /* 41 */
+ HH ( d, a, b, c, in[ 0], S32, 0xEAA127FAL); /* 42 */
+ HH ( c, d, a, b, in[ 3], S33, 0xD4EF3085L); /* 43 */
+ HH ( b, c, d, a, in[ 6], S34, 0x04881D05L); /* 44 */
+ HH ( a, b, c, d, in[ 9], S31, 0xD9D4D039L); /* 45 */
+ HH ( d, a, b, c, in[12], S32, 0xE6DB99E5L); /* 46 */
+ HH ( c, d, a, b, in[15], S33, 0x1FA27CF8L); /* 47 */
+ HH ( b, c, d, a, in[ 2], S34, 0xC4AC5665L); /* 48 */
+
+ /* Round 4 */
+#define S41 6
+#define S42 10
+#define S43 15
+#define S44 21
+ II ( a, b, c, d, in[ 0], S41, 0xF4292244L); /* 49 */
+ II ( d, a, b, c, in[ 7], S42, 0x432AFF97L); /* 50 */
+ II ( c, d, a, b, in[14], S43, 0xAB9423A7L); /* 51 */
+ II ( b, c, d, a, in[ 5], S44, 0xFC93A039L); /* 52 */
+ II ( a, b, c, d, in[12], S41, 0x655B59C3L); /* 53 */
+ II ( d, a, b, c, in[ 3], S42, 0x8F0CCC92L); /* 54 */
+ II ( c, d, a, b, in[10], S43, 0xFFEFF47DL); /* 55 */
+ II ( b, c, d, a, in[ 1], S44, 0x85845DD1L); /* 56 */
+ II ( a, b, c, d, in[ 8], S41, 0x6FA87E4FL); /* 57 */
+ II ( d, a, b, c, in[15], S42, 0xFE2CE6E0L); /* 58 */
+ II ( c, d, a, b, in[ 6], S43, 0xA3014314L); /* 59 */
+ II ( b, c, d, a, in[13], S44, 0x4E0811A1L); /* 60 */
+ II ( a, b, c, d, in[ 4], S41, 0xF7537E82L); /* 61 */
+ II ( d, a, b, c, in[11], S42, 0xBD3AF235L); /* 62 */
+ II ( c, d, a, b, in[ 2], S43, 0x2AD7D2BBL); /* 63 */
+ II ( b, c, d, a, in[ 9], S44, 0xEB86D391L); /* 64 */
+
+ buf[0] += a;
+ buf[1] += b;
+ buf[2] += c;
+ buf[3] += d;
+}
+
diff --git a/tcllib/modules/md5/md5.h b/tcllib/modules/md5/md5.h
new file mode 100644
index 0000000..5e116a5
--- /dev/null
+++ b/tcllib/modules/md5/md5.h
@@ -0,0 +1,66 @@
+#ifndef MD5_H
+#define MD5_H
+
+/*
+ ***********************************************************************
+ ** md5.h -- header file for implementation of MD5 **
+ ** RSA Data Security, Inc. MD5 Message-Digest Algorithm **
+ ** Created: 2/17/90 RLR **
+ ** Revised: 12/27/90 SRD,AJ,BSK,JT Reference C version **
+ ** Revised (for MD5): RLR 4/27/91 **
+ ** -- G modified to have y&~z instead of y&z **
+ ** -- FF, GG, HH modified to add in last register done **
+ ** -- Access pattern: round 2 works mod 5, round 3 works mod 3 **
+ ** -- distinct additive constant for each step **
+ ** -- round 4 added, working mod 7 **
+ ***********************************************************************
+ */
+
+/*
+ * Edited 7 May 93 by CP to change the interface to match that
+ * of the MD5 routines in RSAREF. Due to this alteration, this
+ * code is "derived from the RSA Data Security, Inc. MD5 Message-
+ * Digest Algorithm". (See below.) Also added argument names
+ * to the prototypes.
+ */
+
+/*
+ ***********************************************************************
+ ** Copyright (C) 1990, RSA Data Security, Inc. All rights reserved. **
+ ** **
+ ** License to copy and use this software is granted provided that **
+ ** it is identified as the "RSA Data Security, Inc. MD5 Message- **
+ ** Digest Algorithm" in all material mentioning or referencing this **
+ ** software or this function. **
+ ** **
+ ** License is also granted to make and use derivative works **
+ ** provided that such works are identified as "derived from the RSA **
+ ** Data Security, Inc. MD5 Message-Digest Algorithm" in all **
+ ** material mentioning or referencing the derived work. **
+ ** **
+ ** RSA Data Security, Inc. makes no representations concerning **
+ ** either the merchantability of this software or the suitability **
+ ** of this software for any particular purpose. It is provided "as **
+ ** is" without express or implied warranty of any kind. **
+ ** **
+ ** These notices must be retained in any copies of any part of this **
+ ** documentation and/or software. **
+ ***********************************************************************
+ */
+
+/* typedef a 32-bit type */
+typedef unsigned int UINT4;
+
+/* Data structure for MD5 (Message-Digest) computation */
+typedef struct {
+ UINT4 buf[4]; /* scratch buffer */
+ UINT4 i[2]; /* number of _bits_ handled mod 2^64 */
+ unsigned char in[64]; /* input buffer */
+} MD5_CTX;
+
+void MD5Init (MD5_CTX *mdContext);
+void MD5Update (MD5_CTX *mdContext, unsigned char *buf, unsigned int len);
+void MD5Final (unsigned char digest[16], MD5_CTX *mdContext);
+void Transform (UINT4 *buf, UINT4 *in);
+
+#endif
diff --git a/tcllib/modules/md5/md5.man b/tcllib/modules/md5/md5.man
new file mode 100644
index 0000000..327aaa4
--- /dev/null
+++ b/tcllib/modules/md5/md5.man
@@ -0,0 +1,174 @@
+[manpage_begin md5 n 2.0.7]
+[see_also md4]
+[see_also sha1]
+[keywords hashing]
+[keywords md5]
+[keywords message-digest]
+[keywords {rfc 1320}]
+[keywords {rfc 1321}]
+[keywords {rfc 2104}]
+[keywords security]
+[moddesc {MD5 Message-Digest Algorithm}]
+[copyright {2003, Pat Thoyts <patthoyts@users.sourceforge.net>}]
+[titledesc {MD5 Message-Digest Algorithm}]
+[category {Hashes, checksums, and encryption}]
+[require Tcl 8.2]
+[require md5 [opt 2.0.7]]
+[description]
+[para]
+
+This package is an implementation in Tcl of the MD5 message-digest
+algorithm as described in RFC 1321 (1). This algorithm takes
+an arbitrary quantity of data and generates a 128-bit message digest
+from the input. The MD5 algorithm is related to the MD4 algorithm (2)
+but has been strengthened against certain types of potential
+attack. MD5 should be used in preference to MD4 for new applications.
+
+[para]
+
+If you have [package critcl] and have built the [package tcllibc]
+package then the implementation of the hashing function will be
+performed by compiled code. Alternatively if you have either
+[package cryptkit] or [package Trf] then either of these can be used to
+accelerate the digest computation. If no suitable compiled package is
+available then the pure-Tcl implementation wil be used. The
+programming interface remains the same in all cases.
+
+[para]
+
+[emph "Note"] the previous version of this package always returned a
+hex encoded string. This has been changed to simplify the programming
+interface and to make this version more compatible with other
+implementations. To obtain the previous usage, either explicitly
+specify package version 1 or use the [arg "-hex"] option to the
+[cmd "md5"] command.
+
+[section {COMMANDS}]
+
+[list_begin definitions]
+
+[call [cmd "::md5::md5"] \
+ [opt "[arg -hex]"] \
+ [lb] [arg "-channel channel"] | \
+ [arg "-file filename"] | [arg "string"] [rb]]
+
+Calculate the MD5 digest of the data given in string. This is returned
+as a binary string by default. Giving the [arg "-hex"] option will
+return a hexadecimal encoded version of the digest.
+
+[para]
+
+The data to be hashed can be specified either as a string argument to
+the [cmd "md5"] command, or as a filename or a pre-opened channel. If the
+[arg "-filename"] argument is given then the file is opened, the data read
+and hashed and the file is closed. If the [arg "-channel"] argument is
+given then data is read from the channel until the end of file. The
+channel is not closed.
+
+[para]
+
+Only one of [arg "-file"], [arg "-channel"] or [arg "string"] should be given.
+
+[call [cmd "::md5::hmac"] \
+ [opt "[arg -hex]"] \
+ [arg "-key key"] \
+ [lb] [arg "-channel channel"] | \
+ [arg "-file filename"] | [arg "string"] [rb]]
+
+Calculate an Hashed Message Authentication digest (HMAC) using the MD5
+digest algorithm. HMACs are described in RFC 2104 (3) and provide an MD5
+digest that includes a key. All options other than [arg -key] are as
+for the [cmd "::md5::md5"] command.
+
+[list_end]
+
+[section {PROGRAMMING INTERFACE}]
+
+For the programmer, the MD5 hash can be viewed as a bucket into which
+one pours data. When you have finished, you extract a value that is
+derived from the data that was poured into the bucket. The programming
+interface to the MD5 hash operates on a token (equivalent to the
+bucket). You call [cmd "MD5Init"] to obtain a token and then call
+[cmd "MD5Update"] as many times as required to add data to the hash. To
+release any resources and obtain the hash value, you then call
+[cmd "MD5Final"]. An equivalent set of functions gives you a keyed digest
+(HMAC).
+
+[list_begin definitions]
+
+[call [cmd "::md5::MD5Init"]]
+
+Begins a new MD5 hash. Returns a token ID that must be used for the
+remaining functions.
+
+[call [cmd "::md5::MD5Update"] [arg "token"] [arg "data"]]
+
+Add data to the hash identified by token. Calling
+[emph {MD5Update $token "abcd"}] is equivalent to calling
+[emph {MD5Update $token "ab"}] followed by
+[emph {MD5Update $token "cb"}]. See [sectref {EXAMPLES}].
+
+[call [cmd "::md5::MD5Final"] [arg "token"]]
+
+Returns the hash value and releases any resources held by this
+token. Once this command completes the token will be invalid. The
+result is a binary string of 16 bytes representing the 128 bit MD5
+digest value.
+
+[call [cmd "::md5::HMACInit"] [arg "key"]]
+
+This is equivalent to the [cmd "::md5::MD5Init"] command except that
+it requires the key that will be included in the HMAC.
+
+[call [cmd "::md5::HMACUpdate"] [arg "token"] [arg "data"]]
+[call [cmd "::md5::HMACFinal"] [arg "token"]]
+
+These commands are identical to the MD5 equivalent commands.
+
+[list_end]
+
+[section {EXAMPLES}]
+
+[example {
+% md5::md5 -hex "Tcl does MD5"
+8AAC1EE01E20BB347104FABB90310433
+}]
+
+[example {
+% md5::hmac -hex -key Sekret "Tcl does MD5"
+35BBA244FD56D3EDF5F3C47474DACB5D
+}]
+
+[example {
+% set tok [md5::MD5Init]
+::md5::1
+% md5::MD5Update $tok "Tcl "
+% md5::MD5Update $tok "does "
+% md5::MD5Update $tok "MD5"
+% md5::Hex [md5::MD5Final $tok]
+8AAC1EE01E20BB347104FABB90310433
+}]
+
+[section {REFERENCES}]
+
+[list_begin enumerated]
+
+[enum]
+ Rivest, R., "The MD5 Message-Digest Algorithm", RFC 1321, MIT and
+ RSA Data Security, Inc, April 1992.
+ ([uri http://www.rfc-editor.org/rfc/rfc1321.txt])
+
+[enum]
+ Rivest, R., "The MD4 Message Digest Algorithm", RFC 1320, MIT,
+ April 1992. ([uri http://www.rfc-editor.org/rfc/rfc1320.txt])
+
+[enum]
+ Krawczyk, H., Bellare, M. and Canetti, R. "HMAC: Keyed-Hashing for
+ Message Authentication", RFC 2104, February 1997.
+ ([uri http://www.rfc-editor.org/rfc/rfc2104.txt])
+
+[list_end]
+
+[vset CATEGORY md5]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/md5/md5.tcl b/tcllib/modules/md5/md5.tcl
new file mode 100644
index 0000000..418c782
--- /dev/null
+++ b/tcllib/modules/md5/md5.tcl
@@ -0,0 +1,454 @@
+##################################################
+#
+# md5.tcl - MD5 in Tcl
+# Author: Don Libes <libes@nist.gov>, July 1999
+# Version 1.2.0
+#
+# MD5 defined by RFC 1321, "The MD5 Message-Digest Algorithm"
+# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
+#
+# Most of the comments below come right out of RFC 1321; That's why
+# they have such peculiar numbers. In addition, I have retained
+# original syntax, bugs in documentation (yes, really), etc. from the
+# RFC. All remaining bugs are mine.
+#
+# HMAC implementation by D. J. Hagberg <dhagberg@millibits.com> and
+# is based on C code in RFC 2104.
+#
+# For more info, see: http://expect.nist.gov/md5pure
+#
+# - Don
+#
+# Modified by Miguel Sofer to use inlines and simple variables
+##################################################
+
+# @mdgen EXCLUDE: md5c.tcl
+
+package require Tcl 8.2
+namespace eval ::md5 {
+}
+
+if {![catch {package require Trf 2.0}] && ![catch {::md5 -- test}]} {
+ # Trf is available, so implement the functionality provided here
+ # in terms of calls to Trf for speed.
+
+ proc ::md5::md5 {msg} {
+ string tolower [::hex -mode encode -- [::md5 -- $msg]]
+ }
+
+ # hmac: hash for message authentication
+
+ # MD5 of Trf and MD5 as defined by this package have slightly
+ # different results. Trf returns the digest in binary, here we get
+ # it as hex-string. In the computation of the HMAC the latter
+ # requires back conversion into binary in some places. With Trf we
+ # can use omit these.
+
+ proc ::md5::hmac {key text} {
+ # if key is longer than 64 bytes, reset it to MD5(key). If shorter,
+ # pad it out with null (\x00) chars.
+ set keyLen [string length $key]
+ if {$keyLen > 64} {
+ #old: set key [binary format H32 [md5 $key]]
+ set key [::md5 -- $key]
+ set keyLen [string length $key]
+ }
+
+ # ensure the key is padded out to 64 chars with nulls.
+ set padLen [expr {64 - $keyLen}]
+ append key [binary format "a$padLen" {}]
+
+ # Split apart the key into a list of 16 little-endian words
+ binary scan $key i16 blocks
+
+ # XOR key with ipad and opad values
+ set k_ipad {}
+ set k_opad {}
+ foreach i $blocks {
+ append k_ipad [binary format i [expr {$i ^ 0x36363636}]]
+ append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]]
+ }
+
+ # Perform inner md5, appending its results to the outer key
+ append k_ipad $text
+ #old: append k_opad [binary format H* [md5 $k_ipad]]
+ append k_opad [::md5 -- $k_ipad]
+
+ # Perform outer md5
+ #old: md5 $k_opad
+ string tolower [::hex -mode encode -- [::md5 -- $k_opad]]
+ }
+
+} else {
+ # Without Trf use the all-tcl implementation by Don Libes.
+
+ # T will be inlined after the definition of md5body
+
+ # test md5
+ #
+ # This proc is not necessary during runtime and may be omitted if you
+ # are simply inserting this file into a production program.
+ #
+ proc ::md5::test {} {
+ foreach {msg expected} {
+ ""
+ "d41d8cd98f00b204e9800998ecf8427e"
+ "a"
+ "0cc175b9c0f1b6a831c399e269772661"
+ "abc"
+ "900150983cd24fb0d6963f7d28e17f72"
+ "message digest"
+ "f96b697d7cb7938d525a2f31aaf161d0"
+ "abcdefghijklmnopqrstuvwxyz"
+ "c3fcd3d76192e4007dfb496cca67e13b"
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+ "d174ab98d277d9f5a5611c2c9f419d9f"
+ "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "57edf4a22be3c955ac49da2e2107b67a"
+ } {
+ puts "testing: md5 \"$msg\""
+ set computed [md5 $msg]
+ puts "expected: $expected"
+ puts "computed: $computed"
+ if {0 != [string compare $computed $expected]} {
+ puts "FAILED"
+ } else {
+ puts "SUCCEEDED"
+ }
+ }
+ }
+
+ # time md5
+ #
+ # This proc is not necessary during runtime and may be omitted if you
+ # are simply inserting this file into a production program.
+ #
+ proc ::md5::time {} {
+ foreach len {10 50 100 500 1000 5000 10000} {
+ set time [::time {md5 [format %$len.0s ""]} 100]
+ set msec [lindex $time 0]
+ puts "input length $len: [expr {$msec/1000}] milliseconds per interation"
+ }
+ }
+
+ #
+ # We just define the body of md5pure::md5 here; later we
+ # regsub to inline a few function calls for speed
+ #
+
+ set ::md5::md5body {
+
+ #
+ # 3.1 Step 1. Append Padding Bits
+ #
+
+ set msgLen [string length $msg]
+
+ set padLen [expr {56 - $msgLen%64}]
+ if {$msgLen % 64 > 56} {
+ incr padLen 64
+ }
+
+ # pad even if no padding required
+ if {$padLen == 0} {
+ incr padLen 64
+ }
+
+ # append single 1b followed by 0b's
+ append msg [binary format "a$padLen" \200]
+
+ #
+ # 3.2 Step 2. Append Length
+ #
+
+ # RFC doesn't say whether to use little- or big-endian
+ # code demonstrates little-endian
+ # This step limits our input to size 2^32b or 2^24B
+ append msg [binary format "i1i1" [expr {8*$msgLen}] 0]
+
+ #
+ # 3.3 Step 3. Initialize MD Buffer
+ #
+
+ set A [expr 0x67452301]
+ set B [expr 0xefcdab89]
+ set C [expr 0x98badcfe]
+ set D [expr 0x10325476]
+
+ #
+ # 3.4 Step 4. Process Message in 16-Word Blocks
+ #
+
+ # process each 16-word block
+ # RFC doesn't say whether to use little- or big-endian
+ # code says little-endian
+ binary scan $msg i* blocks
+
+ # loop over the message taking 16 blocks at a time
+
+ foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks {
+
+ # Save A as AA, B as BB, C as CC, and D as DD.
+ set AA $A
+ set BB $B
+ set CC $C
+ set DD $D
+
+ # Round 1.
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s).
+ # [ABCD 0 7 1] [DABC 1 12 2] [CDAB 2 17 3] [BCDA 3 22 4]
+ set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X0 + $T01}] 7]}]
+ set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X1 + $T02}] 12]}]
+ set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X2 + $T03}] 17]}]
+ set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X3 + $T04}] 22]}]
+ # [ABCD 4 7 5] [DABC 5 12 6] [CDAB 6 17 7] [BCDA 7 22 8]
+ set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X4 + $T05}] 7]}]
+ set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X5 + $T06}] 12]}]
+ set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X6 + $T07}] 17]}]
+ set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X7 + $T08}] 22]}]
+ # [ABCD 8 7 9] [DABC 9 12 10] [CDAB 10 17 11] [BCDA 11 22 12]
+ set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X8 + $T09}] 7]}]
+ set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X9 + $T10}] 12]}]
+ set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X10 + $T11}] 17]}]
+ set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X11 + $T12}] 22]}]
+ # [ABCD 12 7 13] [DABC 13 12 14] [CDAB 14 17 15] [BCDA 15 22 16]
+ set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X12 + $T13}] 7]}]
+ set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X13 + $T14}] 12]}]
+ set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X14 + $T15}] 17]}]
+ set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X15 + $T16}] 22]}]
+
+ # Round 2.
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + G(b,c,d) + X[k] + T[i]) <<< s).
+ # Do the following 16 operations.
+ # [ABCD 1 5 17] [DABC 6 9 18] [CDAB 11 14 19] [BCDA 0 20 20]
+ set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X1 + $T17}] 5]}]
+ set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X6 + $T18}] 9]}]
+ set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X11 + $T19}] 14]}]
+ set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X0 + $T20}] 20]}]
+ # [ABCD 5 5 21] [DABC 10 9 22] [CDAB 15 14 23] [BCDA 4 20 24]
+ set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X5 + $T21}] 5]}]
+ set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X10 + $T22}] 9]}]
+ set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X15 + $T23}] 14]}]
+ set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X4 + $T24}] 20]}]
+ # [ABCD 9 5 25] [DABC 14 9 26] [CDAB 3 14 27] [BCDA 8 20 28]
+ set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X9 + $T25}] 5]}]
+ set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X14 + $T26}] 9]}]
+ set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X3 + $T27}] 14]}]
+ set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X8 + $T28}] 20]}]
+ # [ABCD 13 5 29] [DABC 2 9 30] [CDAB 7 14 31] [BCDA 12 20 32]
+ set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X13 + $T29}] 5]}]
+ set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X2 + $T30}] 9]}]
+ set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X7 + $T31}] 14]}]
+ set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X12 + $T32}] 20]}]
+
+ # Round 3.
+ # Let [abcd k s t] [sic] denote the operation
+ # a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s).
+ # Do the following 16 operations.
+ # [ABCD 5 4 33] [DABC 8 11 34] [CDAB 11 16 35] [BCDA 14 23 36]
+ set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X5 + $T33}] 4]}]
+ set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X8 + $T34}] 11]}]
+ set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X11 + $T35}] 16]}]
+ set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X14 + $T36}] 23]}]
+ # [ABCD 1 4 37] [DABC 4 11 38] [CDAB 7 16 39] [BCDA 10 23 40]
+ set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X1 + $T37}] 4]}]
+ set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X4 + $T38}] 11]}]
+ set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X7 + $T39}] 16]}]
+ set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X10 + $T40}] 23]}]
+ # [ABCD 13 4 41] [DABC 0 11 42] [CDAB 3 16 43] [BCDA 6 23 44]
+ set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X13 + $T41}] 4]}]
+ set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X0 + $T42}] 11]}]
+ set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X3 + $T43}] 16]}]
+ set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X6 + $T44}] 23]}]
+ # [ABCD 9 4 45] [DABC 12 11 46] [CDAB 15 16 47] [BCDA 2 23 48]
+ set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X9 + $T45}] 4]}]
+ set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X12 + $T46}] 11]}]
+ set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X15 + $T47}] 16]}]
+ set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X2 + $T48}] 23]}]
+
+ # Round 4.
+ # Let [abcd k s t] [sic] denote the operation
+ # a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s).
+ # Do the following 16 operations.
+ # [ABCD 0 6 49] [DABC 7 10 50] [CDAB 14 15 51] [BCDA 5 21 52]
+ set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X0 + $T49}] 6]}]
+ set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X7 + $T50}] 10]}]
+ set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X14 + $T51}] 15]}]
+ set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X5 + $T52}] 21]}]
+ # [ABCD 12 6 53] [DABC 3 10 54] [CDAB 10 15 55] [BCDA 1 21 56]
+ set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X12 + $T53}] 6]}]
+ set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X3 + $T54}] 10]}]
+ set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X10 + $T55}] 15]}]
+ set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X1 + $T56}] 21]}]
+ # [ABCD 8 6 57] [DABC 15 10 58] [CDAB 6 15 59] [BCDA 13 21 60]
+ set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X8 + $T57}] 6]}]
+ set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X15 + $T58}] 10]}]
+ set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X6 + $T59}] 15]}]
+ set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X13 + $T60}] 21]}]
+ # [ABCD 4 6 61] [DABC 11 10 62] [CDAB 2 15 63] [BCDA 9 21 64]
+ set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X4 + $T61}] 6]}]
+ set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X11 + $T62}] 10]}]
+ set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X2 + $T63}] 15]}]
+ set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X9 + $T64}] 21]}]
+
+ # Then perform the following additions. (That is increment each
+ # of the four registers by the value it had before this block
+ # was started.)
+ incr A $AA
+ incr B $BB
+ incr C $CC
+ incr D $DD
+ }
+ # 3.5 Step 5. Output
+
+ # ... begin with the low-order byte of A, and end with the high-order byte
+ # of D.
+
+ return [bytes $A][bytes $B][bytes $C][bytes $D]
+ }
+
+ #
+ # Here we inline/regsub the functions F, G, H, I and <<<
+ #
+
+ namespace eval ::md5 {
+ #proc md5pure::F {x y z} {expr {(($x & $y) | ((~$x) & $z))}}
+ regsub -all -- {\[ *F +(\$.) +(\$.) +(\$.) *\]} $md5body {((\1 \& \2) | ((~\1) \& \3))} md5body
+
+ #proc md5pure::G {x y z} {expr {(($x & $z) | ($y & (~$z)))}}
+ regsub -all -- {\[ *G +(\$.) +(\$.) +(\$.) *\]} $md5body {((\1 \& \3) | (\2 \& (~\3)))} md5body
+
+ #proc md5pure::H {x y z} {expr {$x ^ $y ^ $z}}
+ regsub -all -- {\[ *H +(\$.) +(\$.) +(\$.) *\]} $md5body {(\1 ^ \2 ^ \3)} md5body
+
+ #proc md5pure::I {x y z} {expr {$y ^ ($x | (~$z))}}
+ regsub -all -- {\[ *I +(\$.) +(\$.) +(\$.) *\]} $md5body {(\2 ^ (\1 | (~\3)))} md5body
+
+ # bitwise left-rotate
+ if {0} {
+ proc md5pure::<<< {x i} {
+ # This works by bitwise-ORing together right piece and left
+ # piece so that the (original) right piece becomes the left
+ # piece and vice versa.
+ #
+ # The (original) right piece is a simple left shift.
+ # The (original) left piece should be a simple right shift
+ # but Tcl does sign extension on right shifts so we
+ # shift it 1 bit, mask off the sign, and finally shift
+ # it the rest of the way.
+
+ # expr {($x << $i) | ((($x >> 1) & 0x7fffffff) >> (31-$i))}
+
+ #
+ # New version, faster when inlining
+ # We replace inline (computing at compile time):
+ # R$i -> (32 - $i)
+ # S$i -> (0x7fffffff >> (31-$i))
+ #
+
+ expr { ($x << $i) | (($x >> [set R$i]) & [set S$i])}
+ }
+ }
+ # inline <<<
+ regsub -all -- {\[ *<<< +\[ *expr +({[^\}]*})\] +([0-9]+) *\]} $md5body {(([set x [expr \1]] << \2) | (($x >> R\2) \& S\2))} md5body
+
+ # now replace the R and S
+ set map {}
+ foreach i {
+ 7 12 17 22
+ 5 9 14 20
+ 4 11 16 23
+ 6 10 15 21
+ } {
+ lappend map R$i [expr {32 - $i}] S$i [expr {0x7fffffff >> (31-$i)}]
+ }
+
+ # inline the values of T
+ foreach \
+ tName {
+ T01 T02 T03 T04 T05 T06 T07 T08 T09 T10
+ T11 T12 T13 T14 T15 T16 T17 T18 T19 T20
+ T21 T22 T23 T24 T25 T26 T27 T28 T29 T30
+ T31 T32 T33 T34 T35 T36 T37 T38 T39 T40
+ T41 T42 T43 T44 T45 T46 T47 T48 T49 T50
+ T51 T52 T53 T54 T55 T56 T57 T58 T59 T60
+ T61 T62 T63 T64 } \
+ tVal {
+ 0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee
+ 0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501
+ 0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be
+ 0x6b901122 0xfd987193 0xa679438e 0x49b40821
+
+ 0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa
+ 0xd62f105d 0x2441453 0xd8a1e681 0xe7d3fbc8
+ 0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed
+ 0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a
+
+ 0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c
+ 0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70
+ 0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05
+ 0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665
+
+ 0xf4292244 0x432aff97 0xab9423a7 0xfc93a039
+ 0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1
+ 0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1
+ 0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391
+ } {
+ lappend map \$$tName $tVal
+ }
+ set md5body [string map $map $md5body]
+
+
+ # Finally, define the proc
+ proc md5 {msg} $md5body
+
+ # unset auxiliary variables
+ unset md5body tName tVal map
+ }
+
+ proc ::md5::byte0 {i} {expr {0xff & $i}}
+ proc ::md5::byte1 {i} {expr {(0xff00 & $i) >> 8}}
+ proc ::md5::byte2 {i} {expr {(0xff0000 & $i) >> 16}}
+ proc ::md5::byte3 {i} {expr {((0xff000000 & $i) >> 24) & 0xff}}
+
+ proc ::md5::bytes {i} {
+ format %0.2x%0.2x%0.2x%0.2x [byte0 $i] [byte1 $i] [byte2 $i] [byte3 $i]
+ }
+
+ # hmac: hash for message authentication
+ proc ::md5::hmac {key text} {
+ # if key is longer than 64 bytes, reset it to MD5(key). If shorter,
+ # pad it out with null (\x00) chars.
+ set keyLen [string length $key]
+ if {$keyLen > 64} {
+ set key [binary format H32 [md5 $key]]
+ set keyLen [string length $key]
+ }
+
+ # ensure the key is padded out to 64 chars with nulls.
+ set padLen [expr {64 - $keyLen}]
+ append key [binary format "a$padLen" {}]
+
+ # Split apart the key into a list of 16 little-endian words
+ binary scan $key i16 blocks
+
+ # XOR key with ipad and opad values
+ set k_ipad {}
+ set k_opad {}
+ foreach i $blocks {
+ append k_ipad [binary format i [expr {$i ^ 0x36363636}]]
+ append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]]
+ }
+
+ # Perform inner md5, appending its results to the outer key
+ append k_ipad $text
+ append k_opad [binary format H* [md5 $k_ipad]]
+
+ # Perform outer md5
+ md5 $k_opad
+ }
+}
+
+package provide md5 1.4.4
diff --git a/tcllib/modules/md5/md5.test b/tcllib/modules/md5/md5.test
new file mode 100644
index 0000000..a1791ec
--- /dev/null
+++ b/tcllib/modules/md5/md5.test
@@ -0,0 +1,90 @@
+# -*- tcl -*-
+# md5.test: tests for the md5 commands
+#
+# 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) 2001 by ActiveState Tool Corp.
+# All rights reserved.
+#
+# RCS: @(#) $Id: md5.test,v 1.11 2006/10/09 21:41:41 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal md5.tcl md5
+}
+
+# -------------------------------------------------------------------------
+
+if {[catch {package present Trf}] || [catch {::md5 -- test}]} {
+ puts "> pure Tcl"
+} else {
+ puts "> Trf based"
+}
+
+# -------------------------------------------------------------------------
+
+test md5-1.0 {md5} {
+ catch {::md5::md5} result
+ set result
+} [tcltest::wrongNumArgs "::md5::md5" "msg" 0]
+
+test md5-1.1 {md5} {
+ catch {::md5::hmac} result
+ set result
+} [tcltest::wrongNumArgs "::md5::hmac" "key text" 0]
+
+test md5-1.2 {md5} {
+ catch {::md5::hmac key} result
+ set result
+} [tcltest::wrongNumArgs "::md5::hmac" "key text" 1]
+
+
+foreach {n msg expected} {
+ 1 ""
+ "d41d8cd98f00b204e9800998ecf8427e"
+ 2 "a"
+ "0cc175b9c0f1b6a831c399e269772661"
+ 3 "abc"
+ "900150983cd24fb0d6963f7d28e17f72"
+ 4 "message digest"
+ "f96b697d7cb7938d525a2f31aaf161d0"
+ 5 "abcdefghijklmnopqrstuvwxyz"
+ "c3fcd3d76192e4007dfb496cca67e13b"
+ 6 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+ "d174ab98d277d9f5a5611c2c9f419d9f"
+ 7 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "57edf4a22be3c955ac49da2e2107b67a"
+} {
+ test md5-2.$n {md5} {
+ ::md5::md5 $msg
+ } $expected ; # {}
+}
+
+foreach {n key text expected} {
+ 1 "" "" "74e6f7298a9c2d168935f58c001bad88"
+ 2 "foo" "hello" "ef2ac8901530db30aa56929adfe5e13b"
+ 3 "bar" "world" "dfc05594b019ed51535922a1295446e8"
+ 4 "key" "text" "d0ca6177c61c975fd2f8c07d8c6528c6"
+ 5 "md5" "hmac" "d189f362daf86a5c8e14ba4aba91b260"
+ 6 "hmac" "md5" "480343cf0f2d5931ec4923e81059fb84"
+ 7 "md5" "md5" "92c5fb986e345f21f181047ab939ec77"
+ 8 "hmac" "hmac" "08abbe58a55219789e3eede153808a56"
+ 9 "01234567abcdefgh01234567abcdefgh01234567abcdefgh01234567abcdefgh==" "hello world"
+ "cf0237466f9b3c773858a1892b474c9e"
+} {
+ test md5-3.$n {hmac} {
+ ::md5::hmac $key $text
+ } $expected ; # {}
+}
+
+testsuiteCleanup
diff --git a/tcllib/modules/md5/md5c.tcl b/tcllib/modules/md5/md5c.tcl
new file mode 100644
index 0000000..240f29a
--- /dev/null
+++ b/tcllib/modules/md5/md5c.tcl
@@ -0,0 +1,148 @@
+# md5c.tcl -
+#
+# Wrapper for RSA's Message Digest in C
+#
+# Written by Jean-Claude Wippler <jcw@equi4.com>
+#
+# $Id: md5c.tcl,v 1.5 2009/05/06 22:46:10 patthoyts Exp $
+
+package require critcl; # needs critcl
+# @sak notprovided md5c
+package provide md5c 0.12; #
+
+critcl::cheaders md5.h; # The RSA header file
+critcl::csources md5.c; # The RSA MD5 implementation.
+
+namespace eval ::md5 {
+
+ critcl::ccode {
+ #include <string.h>
+ #include "md5.h"
+ #include <assert.h>
+
+ static
+ Tcl_ObjType md5_type; /* fast internal access representation */
+
+ static void
+ md5_free_rep(Tcl_Obj *obj)
+ {
+ MD5_CTX *mp = (MD5_CTX *) obj->internalRep.otherValuePtr;
+ Tcl_Free((char*)mp);
+ }
+
+ static void
+ md5_dup_rep(Tcl_Obj *obj, Tcl_Obj *dup)
+ {
+ MD5_CTX *mp = (MD5_CTX *) obj->internalRep.otherValuePtr;
+ dup->internalRep.otherValuePtr = Tcl_Alloc(sizeof *mp);
+ memcpy(dup->internalRep.otherValuePtr, mp, sizeof *mp);
+ dup->typePtr = &md5_type;
+ }
+
+ static void
+ md5_string_rep(Tcl_Obj *obj)
+ {
+ unsigned char buf[16];
+ Tcl_Obj *temp;
+ char *str;
+ MD5_CTX dup = *(MD5_CTX *) obj->internalRep.otherValuePtr;
+
+ MD5Final(buf, &dup);
+
+ /* convert via a byte array to properly handle null bytes */
+ temp = Tcl_NewByteArrayObj(buf, sizeof buf);
+ Tcl_IncrRefCount(temp);
+
+ str = Tcl_GetStringFromObj(temp, &obj->length);
+ obj->bytes = Tcl_Alloc(obj->length + 1);
+ memcpy(obj->bytes, str, obj->length + 1);
+
+ Tcl_DecrRefCount(temp);
+ }
+
+ static int
+ md5_from_any(Tcl_Interp* ip, Tcl_Obj* obj)
+ {
+ assert(0);
+ return TCL_ERROR;
+ }
+
+ static
+ Tcl_ObjType md5_type = {
+ "md5c", md5_free_rep, md5_dup_rep, md5_string_rep, md5_from_any
+ };
+ }
+
+ critcl::ccommand md5c {dummy ip objc objv} {
+ MD5_CTX *mp;
+ unsigned char *data;
+ int size;
+ Tcl_Obj *obj;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(ip, 1, objv, "data ?context?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 3) {
+ if (objv[2]->typePtr != &md5_type && md5_from_any(ip, objv[2]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ obj = objv[2];
+ if (Tcl_IsShared(obj)) {
+ obj = Tcl_DuplicateObj(obj);
+ }
+ } else {
+ mp = (MD5_CTX *)Tcl_Alloc(sizeof *mp);
+ MD5Init(mp);
+ obj = Tcl_NewObj();
+ Tcl_InvalidateStringRep(obj);
+ obj->internalRep.otherValuePtr = mp;
+ obj->typePtr = &md5_type;
+ }
+
+ mp = (MD5_CTX *) obj->internalRep.otherValuePtr;
+ data = Tcl_GetByteArrayFromObj(objv[1], &size);
+ MD5Update(mp, data, size);
+ Tcl_SetObjResult(ip, obj);
+
+ return TCL_OK;
+ }
+}
+
+if {[info exists pkgtest] && $pkgtest} {
+
+ proc md5c_try {} {
+ foreach {msg expected} {
+ ""
+ "d41d8cd98f00b204e9800998ecf8427e"
+ "a"
+ "0cc175b9c0f1b6a831c399e269772661"
+ "abc"
+ "900150983cd24fb0d6963f7d28e17f72"
+ "message digest"
+ "f96b697d7cb7938d525a2f31aaf161d0"
+ "abcdefghijklmnopqrstuvwxyz"
+ "c3fcd3d76192e4007dfb496cca67e13b"
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+ "d174ab98d277d9f5a5611c2c9f419d9f"
+ "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "57edf4a22be3c955ac49da2e2107b67a"
+ } {
+ puts "testing: ::md5::md5c \"$msg\""
+ binary scan [::md5::md5c $msg] H* computed
+ puts "computed: $computed"
+ if {0 != [string compare $computed $expected]} {
+ puts "expected: $expected"
+ puts "FAILED"
+ }
+ }
+
+ foreach len {10 50 100 500 1000 5000 10000} {
+ set blanks [format %$len.0s ""]
+ puts "input length $len: [time {md5c $blanks} 1000]"
+ }
+ }
+
+ md5c_try
+}
diff --git a/tcllib/modules/md5/md5v1.bench b/tcllib/modules/md5/md5v1.bench
new file mode 100644
index 0000000..b0402f5
--- /dev/null
+++ b/tcllib/modules/md5/md5v1.bench
@@ -0,0 +1,47 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'md5' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+## Here we are testing version 1.
+
+set moddir [file dirname [file dirname [info script]]]
+lappend auto_path $moddir
+
+package forget md5
+catch {namespace delete ::md5}
+source [file join [file dirname [info script]] md5.tcl]
+
+set key "01234567abcdefgh01234567abcdefgh01234567abcdefgh01234567abcdefgh=="
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+foreach n {1 10 100 1000 10000} {
+ bench -desc "MD5 md5_ v1 $n" -pre {
+ set str [string repeat " " $n]
+ } -body {
+ md5::md5 $str
+ }
+
+ bench -desc "MD5 hmac v1 $n" -pre {
+ set str [string repeat " " $n]
+ } -body {
+ md5::hmac $key $str
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/md5/md5v2.bench b/tcllib/modules/md5/md5v2.bench
new file mode 100644
index 0000000..e9af056
--- /dev/null
+++ b/tcllib/modules/md5/md5v2.bench
@@ -0,0 +1,47 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'md5' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+## Here we are testing version 2.
+
+set moddir [file dirname [file dirname [info script]]]
+lappend auto_path $moddir
+
+package forget md5
+catch {namespace delete ::md5}
+source [file join [file dirname [info script]] md5x.tcl]
+
+set key "01234567abcdefgh01234567abcdefgh01234567abcdefgh01234567abcdefgh=="
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+foreach n {1 10 100 1000 10000} {
+ bench -desc "MD5 md5_ v2 $n" -pre {
+ set str [string repeat " " $n]
+ } -body {
+ md5::md5 $str
+ }
+
+ bench -desc "MD5 hmac v2 $n" -pre {
+ set str [string repeat " " $n]
+ } -body {
+ md5::hmac -key $key -- $str
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/md5/md5x.tcl b/tcllib/modules/md5/md5x.tcl
new file mode 100644
index 0000000..85cb7aa
--- /dev/null
+++ b/tcllib/modules/md5/md5x.tcl
@@ -0,0 +1,713 @@
+# md5.tcl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# MD5 defined by RFC 1321, "The MD5 Message-Digest Algorithm"
+# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
+#
+# This is an implementation of MD5 based upon the example code given in
+# RFC 1321 and upon the tcllib MD4 implementation and taking some ideas
+# from the earlier tcllib md5 version by Don Libes.
+#
+# This implementation permits incremental updating of the hash and
+# provides support for external compiled implementations either using
+# critcl (md5c) or Trf.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.2; # tcl minimum version
+
+namespace eval ::md5 {
+ variable accel
+ array set accel {critcl 0 cryptkit 0 trf 0}
+
+ namespace export md5 hmac MD5Init MD5Update MD5Final
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 0
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# MD5Init --
+#
+# Create and initialize an MD5 state variable. This will be
+# cleaned up when we call MD5Final
+#
+proc ::md5::MD5Init {} {
+ variable accel
+ variable uid
+ set token [namespace current]::[incr uid]
+ upvar #0 $token state
+
+ # RFC1321:3.3 - Initialize MD5 state structure
+ array set state \
+ [list \
+ A [expr {0x67452301}] \
+ B [expr {0xefcdab89}] \
+ C [expr {0x98badcfe}] \
+ D [expr {0x10325476}] \
+ n 0 i "" ]
+ if {$accel(cryptkit)} {
+ cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_MD5
+ } elseif {$accel(trf)} {
+ set s {}
+ switch -exact -- $::tcl_platform(platform) {
+ windows { set s [open NUL w] }
+ unix { set s [open /dev/null w] }
+ }
+ if {$s != {}} {
+ fconfigure $s -translation binary -buffering none
+ ::md5 -attach $s -mode write \
+ -read-type variable \
+ -read-destination [subst $token](trfread) \
+ -write-type variable \
+ -write-destination [subst $token](trfwrite)
+ array set state [list trfread 0 trfwrite 0 trf $s]
+ }
+ }
+ return $token
+}
+
+# MD5Update --
+#
+# This is called to add more data into the hash. You may call this
+# as many times as you require. Note that passing in "ABC" is equivalent
+# to passing these letters in as separate calls -- hence this proc
+# permits hashing of chunked data
+#
+# If we have a C-based implementation available, then we will use
+# it here in preference to the pure-Tcl implementation.
+#
+proc ::md5::MD5Update {token data} {
+ variable accel
+ upvar #0 $token state
+
+ if {$accel(critcl)} {
+ if {[info exists state(md5c)]} {
+ set state(md5c) [md5c $data $state(md5c)]
+ } else {
+ set state(md5c) [md5c $data]
+ }
+ return
+ } elseif {[info exists state(ckctx)]} {
+ if {[string length $data] > 0} {
+ cryptkit::cryptEncrypt $state(ckctx) $data
+ }
+ return
+ } elseif {[info exists state(trf)]} {
+ puts -nonewline $state(trf) $data
+ return
+ }
+
+ # Update the state values
+ incr state(n) [string length $data]
+ append state(i) $data
+
+ # Calculate the hash for any complete blocks
+ set len [string length $state(i)]
+ for {set n 0} {($n + 64) <= $len} {} {
+ MD5Hash $token [string range $state(i) $n [incr n 64]]
+ }
+
+ # Adjust the state for the blocks completed.
+ set state(i) [string range $state(i) $n end]
+ return
+}
+
+# MD5Final --
+#
+# This procedure is used to close the current hash and returns the
+# hash data. Once this procedure has been called the hash context
+# is freed and cannot be used again.
+#
+# Note that the output is 128 bits represented as binary data.
+#
+proc ::md5::MD5Final {token} {
+ upvar #0 $token state
+
+ # Check for either of the C-compiled versions.
+ if {[info exists state(md5c)]} {
+ set r $state(md5c)
+ unset state
+ return $r
+ } elseif {[info exists state(ckctx)]} {
+ cryptkit::cryptEncrypt $state(ckctx) ""
+ cryptkit::cryptGetAttributeString $state(ckctx) \
+ CRYPT_CTXINFO_HASHVALUE r 16
+ cryptkit::cryptDestroyContext $state(ckctx)
+ # If nothing was hashed, we get no r variable set!
+ if {[info exists r]} {
+ unset state
+ return $r
+ }
+ } elseif {[info exists state(trf)]} {
+ close $state(trf)
+ set r $state(trfwrite)
+ unset state
+ return $r
+ }
+
+ # RFC1321:3.1 - Padding
+ #
+ set len [string length $state(i)]
+ set pad [expr {56 - ($len % 64)}]
+ if {$len % 64 > 56} {
+ incr pad 64
+ }
+ if {$pad == 0} {
+ incr pad 64
+ }
+ append state(i) [binary format a$pad \x80]
+
+ # RFC1321:3.2 - Append length in bits as little-endian wide int.
+ append state(i) [binary format ii [expr {8 * $state(n)}] 0]
+
+ # Calculate the hash for the remaining block.
+ set len [string length $state(i)]
+ for {set n 0} {($n + 64) <= $len} {} {
+ MD5Hash $token [string range $state(i) $n [incr n 64]]
+ }
+
+ # RFC1321:3.5 - Output
+ set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)]
+ unset state
+ return $r
+}
+
+# -------------------------------------------------------------------------
+# HMAC Hashed Message Authentication (RFC 2104)
+#
+# hmac = H(K xor opad, H(K xor ipad, text))
+#
+
+# HMACInit --
+#
+# This is equivalent to the MD5Init procedure except that a key is
+# added into the algorithm
+#
+proc ::md5::HMACInit {K} {
+
+ # Key K is adjusted to be 64 bytes long. If K is larger, then use
+ # the MD5 digest of K and pad this instead.
+ set len [string length $K]
+ if {$len > 64} {
+ set tok [MD5Init]
+ MD5Update $tok $K
+ set K [MD5Final $tok]
+ set len [string length $K]
+ }
+ set pad [expr {64 - $len}]
+ append K [string repeat \0 $pad]
+
+ # Cacluate the padding buffers.
+ set Ki {}
+ set Ko {}
+ binary scan $K i16 Ks
+ foreach k $Ks {
+ append Ki [binary format i [expr {$k ^ 0x36363636}]]
+ append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]]
+ }
+
+ set tok [MD5Init]
+ MD5Update $tok $Ki; # initialize with the inner pad
+
+ # preserve the Ko value for the final stage.
+ # FRINK: nocheck
+ set [subst $tok](Ko) $Ko
+
+ return $tok
+}
+
+# HMACUpdate --
+#
+# Identical to calling MD5Update
+#
+proc ::md5::HMACUpdate {token data} {
+ MD5Update $token $data
+ return
+}
+
+# HMACFinal --
+#
+# This is equivalent to the MD5Final procedure. The hash context is
+# closed and the binary representation of the hash result is returned.
+#
+proc ::md5::HMACFinal {token} {
+ upvar #0 $token state
+
+ set tok [MD5Init]; # init the outer hashing function
+ MD5Update $tok $state(Ko); # prepare with the outer pad.
+ MD5Update $tok [MD5Final $token]; # hash the inner result
+ return [MD5Final $tok]
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# This is the core MD5 algorithm. It is a lot like the MD4 algorithm but
+# includes an extra round and a set of constant modifiers throughout.
+#
+# Note:
+# This function body is substituted later on to inline some of the
+# procedures and to make is a bit more comprehensible.
+#
+set ::md5::MD5Hash_body {
+ variable $token
+ upvar 0 $token state
+
+ # RFC1321:3.4 - Process Message in 16-Word Blocks
+ binary scan $msg i* blocks
+ foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks {
+ set A $state(A)
+ set B $state(B)
+ set C $state(C)
+ set D $state(D)
+
+ # Round 1
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s).
+ # Do the following 16 operations.
+ # [ABCD 0 7 1] [DABC 1 12 2] [CDAB 2 17 3] [BCDA 3 22 4]
+ set A [expr {$B + (($A + [F $B $C $D] + $X0 + $T01) <<< 7)}]
+ set D [expr {$A + (($D + [F $A $B $C] + $X1 + $T02) <<< 12)}]
+ set C [expr {$D + (($C + [F $D $A $B] + $X2 + $T03) <<< 17)}]
+ set B [expr {$C + (($B + [F $C $D $A] + $X3 + $T04) <<< 22)}]
+ # [ABCD 4 7 5] [DABC 5 12 6] [CDAB 6 17 7] [BCDA 7 22 8]
+ set A [expr {$B + (($A + [F $B $C $D] + $X4 + $T05) <<< 7)}]
+ set D [expr {$A + (($D + [F $A $B $C] + $X5 + $T06) <<< 12)}]
+ set C [expr {$D + (($C + [F $D $A $B] + $X6 + $T07) <<< 17)}]
+ set B [expr {$C + (($B + [F $C $D $A] + $X7 + $T08) <<< 22)}]
+ # [ABCD 8 7 9] [DABC 9 12 10] [CDAB 10 17 11] [BCDA 11 22 12]
+ set A [expr {$B + (($A + [F $B $C $D] + $X8 + $T09) <<< 7)}]
+ set D [expr {$A + (($D + [F $A $B $C] + $X9 + $T10) <<< 12)}]
+ set C [expr {$D + (($C + [F $D $A $B] + $X10 + $T11) <<< 17)}]
+ set B [expr {$C + (($B + [F $C $D $A] + $X11 + $T12) <<< 22)}]
+ # [ABCD 12 7 13] [DABC 13 12 14] [CDAB 14 17 15] [BCDA 15 22 16]
+ set A [expr {$B + (($A + [F $B $C $D] + $X12 + $T13) <<< 7)}]
+ set D [expr {$A + (($D + [F $A $B $C] + $X13 + $T14) <<< 12)}]
+ set C [expr {$D + (($C + [F $D $A $B] + $X14 + $T15) <<< 17)}]
+ set B [expr {$C + (($B + [F $C $D $A] + $X15 + $T16) <<< 22)}]
+
+ # Round 2.
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + G(b,c,d) + X[k] + Ti) <<< s)
+ # Do the following 16 operations.
+ # [ABCD 1 5 17] [DABC 6 9 18] [CDAB 11 14 19] [BCDA 0 20 20]
+ set A [expr {$B + (($A + [G $B $C $D] + $X1 + $T17) <<< 5)}]
+ set D [expr {$A + (($D + [G $A $B $C] + $X6 + $T18) <<< 9)}]
+ set C [expr {$D + (($C + [G $D $A $B] + $X11 + $T19) <<< 14)}]
+ set B [expr {$C + (($B + [G $C $D $A] + $X0 + $T20) <<< 20)}]
+ # [ABCD 5 5 21] [DABC 10 9 22] [CDAB 15 14 23] [BCDA 4 20 24]
+ set A [expr {$B + (($A + [G $B $C $D] + $X5 + $T21) <<< 5)}]
+ set D [expr {$A + (($D + [G $A $B $C] + $X10 + $T22) <<< 9)}]
+ set C [expr {$D + (($C + [G $D $A $B] + $X15 + $T23) <<< 14)}]
+ set B [expr {$C + (($B + [G $C $D $A] + $X4 + $T24) <<< 20)}]
+ # [ABCD 9 5 25] [DABC 14 9 26] [CDAB 3 14 27] [BCDA 8 20 28]
+ set A [expr {$B + (($A + [G $B $C $D] + $X9 + $T25) <<< 5)}]
+ set D [expr {$A + (($D + [G $A $B $C] + $X14 + $T26) <<< 9)}]
+ set C [expr {$D + (($C + [G $D $A $B] + $X3 + $T27) <<< 14)}]
+ set B [expr {$C + (($B + [G $C $D $A] + $X8 + $T28) <<< 20)}]
+ # [ABCD 13 5 29] [DABC 2 9 30] [CDAB 7 14 31] [BCDA 12 20 32]
+ set A [expr {$B + (($A + [G $B $C $D] + $X13 + $T29) <<< 5)}]
+ set D [expr {$A + (($D + [G $A $B $C] + $X2 + $T30) <<< 9)}]
+ set C [expr {$D + (($C + [G $D $A $B] + $X7 + $T31) <<< 14)}]
+ set B [expr {$C + (($B + [G $C $D $A] + $X12 + $T32) <<< 20)}]
+
+ # Round 3.
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s)
+ # Do the following 16 operations.
+ # [ABCD 5 4 33] [DABC 8 11 34] [CDAB 11 16 35] [BCDA 14 23 36]
+ set A [expr {$B + (($A + [H $B $C $D] + $X5 + $T33) <<< 4)}]
+ set D [expr {$A + (($D + [H $A $B $C] + $X8 + $T34) <<< 11)}]
+ set C [expr {$D + (($C + [H $D $A $B] + $X11 + $T35) <<< 16)}]
+ set B [expr {$C + (($B + [H $C $D $A] + $X14 + $T36) <<< 23)}]
+ # [ABCD 1 4 37] [DABC 4 11 38] [CDAB 7 16 39] [BCDA 10 23 40]
+ set A [expr {$B + (($A + [H $B $C $D] + $X1 + $T37) <<< 4)}]
+ set D [expr {$A + (($D + [H $A $B $C] + $X4 + $T38) <<< 11)}]
+ set C [expr {$D + (($C + [H $D $A $B] + $X7 + $T39) <<< 16)}]
+ set B [expr {$C + (($B + [H $C $D $A] + $X10 + $T40) <<< 23)}]
+ # [ABCD 13 4 41] [DABC 0 11 42] [CDAB 3 16 43] [BCDA 6 23 44]
+ set A [expr {$B + (($A + [H $B $C $D] + $X13 + $T41) <<< 4)}]
+ set D [expr {$A + (($D + [H $A $B $C] + $X0 + $T42) <<< 11)}]
+ set C [expr {$D + (($C + [H $D $A $B] + $X3 + $T43) <<< 16)}]
+ set B [expr {$C + (($B + [H $C $D $A] + $X6 + $T44) <<< 23)}]
+ # [ABCD 9 4 45] [DABC 12 11 46] [CDAB 15 16 47] [BCDA 2 23 48]
+ set A [expr {$B + (($A + [H $B $C $D] + $X9 + $T45) <<< 4)}]
+ set D [expr {$A + (($D + [H $A $B $C] + $X12 + $T46) <<< 11)}]
+ set C [expr {$D + (($C + [H $D $A $B] + $X15 + $T47) <<< 16)}]
+ set B [expr {$C + (($B + [H $C $D $A] + $X2 + $T48) <<< 23)}]
+
+ # Round 4.
+ # Let [abcd k s i] denote the operation
+ # a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s)
+ # Do the following 16 operations.
+ # [ABCD 0 6 49] [DABC 7 10 50] [CDAB 14 15 51] [BCDA 5 21 52]
+ set A [expr {$B + (($A + [I $B $C $D] + $X0 + $T49) <<< 6)}]
+ set D [expr {$A + (($D + [I $A $B $C] + $X7 + $T50) <<< 10)}]
+ set C [expr {$D + (($C + [I $D $A $B] + $X14 + $T51) <<< 15)}]
+ set B [expr {$C + (($B + [I $C $D $A] + $X5 + $T52) <<< 21)}]
+ # [ABCD 12 6 53] [DABC 3 10 54] [CDAB 10 15 55] [BCDA 1 21 56]
+ set A [expr {$B + (($A + [I $B $C $D] + $X12 + $T53) <<< 6)}]
+ set D [expr {$A + (($D + [I $A $B $C] + $X3 + $T54) <<< 10)}]
+ set C [expr {$D + (($C + [I $D $A $B] + $X10 + $T55) <<< 15)}]
+ set B [expr {$C + (($B + [I $C $D $A] + $X1 + $T56) <<< 21)}]
+ # [ABCD 8 6 57] [DABC 15 10 58] [CDAB 6 15 59] [BCDA 13 21 60]
+ set A [expr {$B + (($A + [I $B $C $D] + $X8 + $T57) <<< 6)}]
+ set D [expr {$A + (($D + [I $A $B $C] + $X15 + $T58) <<< 10)}]
+ set C [expr {$D + (($C + [I $D $A $B] + $X6 + $T59) <<< 15)}]
+ set B [expr {$C + (($B + [I $C $D $A] + $X13 + $T60) <<< 21)}]
+ # [ABCD 4 6 61] [DABC 11 10 62] [CDAB 2 15 63] [BCDA 9 21 64]
+ set A [expr {$B + (($A + [I $B $C $D] + $X4 + $T61) <<< 6)}]
+ set D [expr {$A + (($D + [I $A $B $C] + $X11 + $T62) <<< 10)}]
+ set C [expr {$D + (($C + [I $D $A $B] + $X2 + $T63) <<< 15)}]
+ set B [expr {$C + (($B + [I $C $D $A] + $X9 + $T64) <<< 21)}]
+
+ # Then perform the following additions. (That is, increment each
+ # of the four registers by the value it had before this block
+ # was started.)
+ incr state(A) $A
+ incr state(B) $B
+ incr state(C) $C
+ incr state(D) $D
+ }
+
+ return
+}
+
+proc ::md5::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}}
+proc ::md5::bytes {v} {
+ #format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v]
+ format %c%c%c%c \
+ [expr {0xFF & $v}] \
+ [expr {(0xFF00 & $v) >> 8}] \
+ [expr {(0xFF0000 & $v) >> 16}] \
+ [expr {((0xFF000000 & $v) >> 24) & 0xFF}]
+}
+
+# 32bit rotate-left
+proc ::md5::<<< {v n} {
+ return [expr {((($v << $n) \
+ | (($v >> (32 - $n)) \
+ & (0x7FFFFFFF >> (31 - $n))))) \
+ & 0xFFFFFFFF}]
+}
+
+# Convert our <<< pseudo-operator into a procedure call.
+regsub -all -line \
+ {\[expr {(\$[ABCD]) \+ \(\((.*)\)\s+<<<\s+(\d+)\)}\]} \
+ $::md5::MD5Hash_body \
+ {[expr {int(\1 + [<<< [expr {\2}] \3])}]} \
+ ::md5::MD5Hash_body
+
+# RFC1321:3.4 - function F
+proc ::md5::F {X Y Z} {
+ return [expr {($X & $Y) | ((~$X) & $Z)}]
+}
+
+# Inline the F function
+regsub -all -line \
+ {\[F (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+ $::md5::MD5Hash_body \
+ {( (\1 \& \2) | ((~\1) \& \3) )} \
+ ::md5::MD5Hash_body
+
+# RFC1321:3.4 - function G
+proc ::md5::G {X Y Z} {
+ return [expr {(($X & $Z) | ($Y & (~$Z)))}]
+}
+
+# Inline the G function
+regsub -all -line \
+ {\[G (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+ $::md5::MD5Hash_body \
+ {(((\1 \& \3) | (\2 \& (~\3))))} \
+ ::md5::MD5Hash_body
+
+# RFC1321:3.4 - function H
+proc ::md5::H {X Y Z} {
+ return [expr {$X ^ $Y ^ $Z}]
+}
+
+# Inline the H function
+regsub -all -line \
+ {\[H (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+ $::md5::MD5Hash_body \
+ {(\1 ^ \2 ^ \3)} \
+ ::md5::MD5Hash_body
+
+# RFC1321:3.4 - function I
+proc ::md5::I {X Y Z} {
+ return [expr {$Y ^ ($X | (~$Z))}]
+}
+
+# Inline the I function
+regsub -all -line \
+ {\[I (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \
+ $::md5::MD5Hash_body \
+ {(\2 ^ (\1 | (~\3)))} \
+ ::md5::MD5Hash_body
+
+
+# RFC 1321:3.4 step 4: inline the set of constant modifiers.
+namespace eval md5 {
+ foreach tName {
+ T01 T02 T03 T04 T05 T06 T07 T08 T09 T10
+ T11 T12 T13 T14 T15 T16 T17 T18 T19 T20
+ T21 T22 T23 T24 T25 T26 T27 T28 T29 T30
+ T31 T32 T33 T34 T35 T36 T37 T38 T39 T40
+ T41 T42 T43 T44 T45 T46 T47 T48 T49 T50
+ T51 T52 T53 T54 T55 T56 T57 T58 T59 T60
+ T61 T62 T63 T64
+ } tVal {
+ 0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee
+ 0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501
+ 0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be
+ 0x6b901122 0xfd987193 0xa679438e 0x49b40821
+
+ 0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa
+ 0xd62f105d 0x2441453 0xd8a1e681 0xe7d3fbc8
+ 0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed
+ 0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a
+
+ 0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c
+ 0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70
+ 0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05
+ 0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665
+
+ 0xf4292244 0x432aff97 0xab9423a7 0xfc93a039
+ 0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1
+ 0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1
+ 0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391
+ } {
+ lappend map \$$tName $tVal
+ }
+ set ::md5::MD5Hash_body [string map $map $::md5::MD5Hash_body]
+ unset map tName tVal
+}
+
+# Define the MD5 hashing procedure with inline functions.
+proc ::md5::MD5Hash {token msg} $::md5::MD5Hash_body
+unset ::md5::MD5Hash_body
+
+# -------------------------------------------------------------------------
+
+if {[package provide Trf] != {}} {
+ interp alias {} ::md5::Hex {} ::hex -mode encode --
+} else {
+ proc ::md5::Hex {data} {
+ binary scan $data H* result
+ return [string toupper $result]
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# 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 ::md5::LoadAccelerator {name} {
+ variable accel
+ set r 0
+ switch -exact -- $name {
+ critcl {
+ if {![catch {package require tcllibc}]
+ || ![catch {package require md5c}]} {
+ set r [expr {[info commands ::md5::md5c] != {}}]
+ }
+ }
+ cryptkit {
+ if {![catch {package require cryptkit}]} {
+ set r [expr {![catch {cryptkit::cryptInit}]}]
+ }
+ }
+ trf {
+ if {![catch {package require Trf}]} {
+ set r [expr {![catch {::md5 aa} msg]}]
+ }
+ }
+ default {
+ return -code error "invalid accelerator package:\
+ must be one of [join [array names accel] {, }]"
+ }
+ }
+ set accel($name) $r
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::md5::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# fileevent handler for chunked file hashing.
+#
+proc ::md5::Chunk {token channel {chunksize 4096}} {
+ upvar #0 $token state
+
+ if {[eof $channel]} {
+ fileevent $channel readable {}
+ set state(reading) 0
+ }
+
+ MD5Update $token [read $channel $chunksize]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::md5::md5 {args} {
+ array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -hex { set opts(-hex) 1 }
+ -file* { set opts(-filename) [Pop args 1] }
+ -channel { set opts(-channel) [Pop args 1] }
+ -chunksize { set opts(-chunksize) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0} { Pop args; break }
+ set err [join [lsort [array names opts]] ", "]
+ return -code error "bad option $option:\
+ must be one of $err\nlen: [llength $args]"
+ }
+ }
+ Pop args
+ }
+
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args:\
+ should be \"md5 ?-hex? -filename file | string\""
+ }
+ set tok [MD5Init]
+ MD5Update $tok [lindex $args 0]
+ set r [MD5Final $tok]
+
+ } else {
+
+ set tok [MD5Init]
+ # FRINK: nocheck
+ set [subst $tok](reading) 1
+ fileevent $opts(-channel) readable \
+ [list [namespace origin Chunk] \
+ $tok $opts(-channel) $opts(-chunksize)]
+ vwait [subst $tok](reading)
+ set r [MD5Final $tok]
+
+ # If we opened the channel - we should close it too.
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+ }
+
+ if {$opts(-hex)} {
+ set r [Hex $r]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::md5::hmac {args} {
+ array set opts {-hex 0 -filename {} -channel {} -chunksize 4096}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -key { set opts(-key) [Pop args 1] }
+ -hex { set opts(-hex) 1 }
+ -file* { set opts(-filename) [Pop args 1] }
+ -channel { set opts(-channel) [Pop args 1] }
+ -chunksize { set opts(-chunksize) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0} { Pop args; break }
+ set err [join [lsort [array names opts]] ", "]
+ return -code error "bad option $option:\
+ must be one of $err"
+ }
+ }
+ Pop args
+ }
+
+ if {![info exists opts(-key)]} {
+ return -code error "wrong # args:\
+ should be \"hmac ?-hex? -key key -filename file | string\""
+ }
+
+ if {$opts(-filename) != {}} {
+ set opts(-channel) [open $opts(-filename) r]
+ fconfigure $opts(-channel) -translation binary
+ }
+
+ if {$opts(-channel) == {}} {
+
+ if {[llength $args] != 1} {
+ return -code error "wrong # args:\
+ should be \"hmac ?-hex? -key key -filename file | string\""
+ }
+ set tok [HMACInit $opts(-key)]
+ HMACUpdate $tok [lindex $args 0]
+ set r [HMACFinal $tok]
+
+ } else {
+
+ set tok [HMACInit $opts(-key)]
+ # FRINK: nocheck
+ set [subst $tok](reading) 1
+ fileevent $opts(-channel) readable \
+ [list [namespace origin Chunk] \
+ $tok $opts(-channel) $opts(-chunksize)]
+ vwait [subst $tok](reading)
+ set r [HMACFinal $tok]
+
+ # If we opened the channel - we should close it too.
+ if {$opts(-filename) != {}} {
+ close $opts(-channel)
+ }
+ }
+
+ if {$opts(-hex)} {
+ set r [Hex $r]
+ }
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::md5 {
+ variable e
+ foreach e {critcl cryptkit trf} { if {[LoadAccelerator $e]} { break } }
+ unset e
+}
+
+package provide md5 2.0.7
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
+
+
diff --git a/tcllib/modules/md5/md5x.test b/tcllib/modules/md5/md5x.test
new file mode 100644
index 0000000..b9aca39
--- /dev/null
+++ b/tcllib/modules/md5/md5x.test
@@ -0,0 +1,216 @@
+# -*- tcl -*-
+# md5.test: tests for the md5 commands
+#
+# 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) 2001 by ActiveState Tool Corp.
+# All rights reserved.
+#
+# RCS: @(#) $Id: md5x.test,v 1.17 2008/04/08 00:33:07 patthoyts Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal md5x.tcl md5
+}
+
+# -------------------------------------------------------------------------
+
+if {[::md5::LoadAccelerator critcl]} {
+ puts "> critcl based"
+}
+if {[::md5::LoadAccelerator cryptkit]} {
+ puts "> cryptkit based"
+}
+if {[::md5::LoadAccelerator trf]} {
+ puts "> Trf based"
+}
+puts "> pure Tcl"
+
+# -------------------------------------------------------------------------
+# Handle multiple implementation testing
+#
+
+array set preserve [array get ::md5::accel]
+
+proc implementations {} {
+ variable ::md5::accel
+ foreach {a v} [array get accel] {if {$v} {lappend r $a}}
+ lappend r tcl; set r
+}
+
+proc select_implementation {impl} {
+ variable ::md5::accel
+ foreach e [array names accel] { set accel($e) 0 }
+ if {[string compare "tcl" $impl] != 0} {
+ set accel($impl) 1
+ }
+}
+
+proc reset_implementation {} {
+ variable ::md5::accel
+ array set accel [array get ::preserve]
+}
+
+# -------------------------------------------------------------------------
+
+test md5-v2-1.0 {md5} {
+ catch {::md5::md5} result
+ set result
+} {wrong # args: should be "md5 ?-hex? -filename file | string"}
+# [tcltest::wrongNumArgs "md5" "?-hex? -filename file | string" 0]
+
+test md5-v2-1.1 {md5} {
+ catch {::md5::hmac} result
+ set result
+} {wrong # args: should be "hmac ?-hex? -key key -filename file | string"}
+# [tcltest::wrongNumArgs "hmac" "?-hex? -key key -filename file | string" 0]
+
+test md5-v2-1.2 {md5} {
+ catch {::md5::hmac key} result
+ set result
+} {wrong # args: should be "hmac ?-hex? -key key -filename file | string"}
+# [tcltest::wrongNumArgs "hmac" "?-hex? -key key -filename file | string" 1]
+
+
+set tests {
+ 1 ""
+ "D41D8CD98F00B204E9800998ECF8427E"
+ 2 "a"
+ "0CC175B9C0F1B6A831C399E269772661"
+ 3 "abc"
+ "900150983CD24FB0D6963F7D28E17F72"
+ 4 "message digest"
+ "F96B697D7CB7938D525A2F31AAF161D0"
+ 5 "abcdefghijklmnopqrstuvwxyz"
+ "C3FCD3D76192E4007DFB496CCA67E13B"
+ 6 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+ "D174AB98D277D9F5A5611C2C9F419D9F"
+ 7 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+ "57EDF4A22BE3C955AC49DA2E2107B67A"
+ 8 "a\$apr1\$a" "020C3DD6931F7E94ECC99A1F4E4C53E2"
+}
+foreach impl [implementations] {
+ select_implementation $impl
+ foreach {n msg expected} $tests {
+ test md5-v2-$impl-2.$n "md5 ($impl impl)" {
+ list [catch {::md5::md5 -hex -- $msg} msg] $msg
+ } [list 0 $expected]
+ }
+ reset_implementation
+}
+
+set vectors {
+ 1 "" "" "74E6F7298A9C2D168935F58C001BAD88"
+ 2 "\x01" "" "DFA55EFBE6ED07FA2E056E57E949930A"
+ 3 "foo" "hello" "EF2AC8901530DB30AA56929ADFE5E13B"
+ 4 "bar" "world" "DFC05594B019ED51535922A1295446E8"
+ 5 "key" "text" "D0CA6177C61C975FD2F8C07D8C6528C6"
+ 6 "md5" "hmac" "D189F362DAF86A5C8E14BA4ABA91B260"
+ 7 "hmac" "md5" "480343CF0F2D5931EC4923E81059FB84"
+ 8 "md5" "md5" "92C5FB986E345F21F181047AB939EC77"
+ 9 "hmac" "hmac" "08ABBE58A55219789E3EEDE153808A56"
+ 10 "01234567abcdefgh01234567abcdefgh01234567abcdefgh01234567abcdefgh==" "hello world"
+ "CF0237466F9B3C773858A1892B474C9E"
+ 11 "-" "a" "E3BA60E98ED812A68AEB04A8FF57AC8E"
+ 12 "a" "-" "A9DD01C469578DCD4220600667DF6FFB"
+}
+
+foreach impl [implementations] {
+ select_implementation $impl
+ foreach {n key text expected} $vectors {
+ test md5-v2-$impl-3.$n "hmac ($impl impl)" {
+ list [catch {::md5::hmac -hex -key $key -- $text} msg] $msg
+ } [list 0 $expected]
+ }
+ reset_implementation
+}
+
+# -------------------------------------------------------------------------
+# RFC 2202 has a set of test vectors for HMAC-MD5 and HMAC-SHA1.
+# This is those test vectors...
+# -------------------------------------------------------------------------
+
+set vectors \
+ [list \
+ 1 [string repeat \x0b 16] "Hi There" \
+ 9294727A3638BB1C13F48EF8158BFC9D \
+ 2 "Jefe" "what do ya want for nothing?" \
+ 750C783E6AB0B503EAA86E310A5DB738 \
+ 3 [string repeat \xaa 16] [string repeat \xdd 50] \
+ 56BE34521D144C88DBB8C733F0E8B3F6 \
+ 4 \
+ [binary format H* 0102030405060708090a0b0c0d0e0f10111213141516171819]\
+ [string repeat \xcd 50] \
+ 697EAF0ACA3A3AEA3A75164746FFAA79 \
+ 5 [string repeat \x0c 16] "Test With Truncation" \
+ 56461EF2342EDC00F9BAB995690EFD4C \
+ 6 [string repeat \xaa 80] \
+ "Test Using Larger Than Block-Size Key - Hash Key First" \
+ 6B1AB7FE4BD7BF8F0B62E6CE61B9D0CD \
+ 7 [string repeat \xaa 80] \
+ "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" \
+ 6F630FAD67CDA0EE1FB1F562DB3AA53E \
+ ]
+
+foreach impl [implementations] {
+ select_implementation $impl
+ foreach {n key msg hash} $vectors {
+ test md5-v2-$impl-4.$n "RFC2202 test vectors for HMAC-MD5 ($impl)" {
+ ::md5::hmac -hex -key $key -- $msg
+ } $hash
+ }
+}
+
+# -------------------------------------------------------------------------
+
+test md5-v2-6.1 {Check hashing data that begins with hyphen} {
+ list [catch {::md5::md5 -hex -hello} msg] $msg
+} {0 110CD19610AD6247F30263C882670CC1}
+
+test md5-v2-6.2 {Check hashing data that begins with hyphen} {
+ list [catch {::md5::md5 -hex -- -hello} msg] $msg
+} {0 110CD19610AD6247F30263C882670CC1}
+
+test md5-v2-6.3 {Check hashing data that begins with hyphen} {
+ list [catch {::md5::md5 -hex --} msg] $msg
+} {0 CFAB1BA8C67C7C838DB98D666F02A132}
+
+test md5-v2-6.4 {Check hashing data that begins with hyphen} {
+ list [catch {::md5::md5 -hex -- --} msg] $msg
+} {0 CFAB1BA8C67C7C838DB98D666F02A132}
+
+test md5-v2-7.1 {Check hmac data that begins with hyphen} {
+ list [catch {::md5::hmac -hex -key "" -hello} msg] $msg
+} {0 6C39C49DA482D110B72B72F24E082E0F}
+
+test md5-v2-7.2 {Check hmac data that begins with hyphen} {
+ list [catch {::md5::hmac -hex -key "" -- -hello} msg] $msg
+} {0 6C39C49DA482D110B72B72F24E082E0F}
+
+test md5-v2-7.3 {Check hmac data that begins with hyphen} {
+ list [catch {::md5::hmac -hex -key "" --} msg] $msg
+} {0 8EB61D377088779210AD82659AECD631}
+
+test md5-v2-7.4 {Check hmac data that begins with hyphen} {
+ list [catch {::md5::hmac -hex -key "" -- --} msg] $msg
+} {0 8EB61D377088779210AD82659AECD631}
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/md5/pkgIndex.tcl b/tcllib/modules/md5/pkgIndex.tcl
new file mode 100644
index 0000000..64096ec
--- /dev/null
+++ b/tcllib/modules/md5/pkgIndex.tcl
@@ -0,0 +1,3 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded md5 2.0.7 [list source [file join $dir md5x.tcl]]
+package ifneeded md5 1.4.4 [list source [file join $dir md5.tcl]]
diff --git a/tcllib/modules/md5crypt/ChangeLog b/tcllib/modules/md5crypt/ChangeLog
new file mode 100644
index 0000000..ea070bd
--- /dev/null
+++ b/tcllib/modules/md5crypt/ChangeLog
@@ -0,0 +1,130 @@
+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-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 ========================
+ *
+
+2009-05-07 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5cryptc.tcl: Fixed poor idiom setting interp result.
+
+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 ========================
+ *
+
+2008-01-26 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5crypt.tcl: Implemented FR #1824212 from Aaron Faupell to
+ * md5crypt.man: provide a salt command for use when generating
+ * pkgIndex.tcl: passwords.
+
+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>
+
+ * md5crypt.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-09-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5crypt.test: The critcl implementation of md5crypt generates
+ different error messages when called with the wrong number of
+ arguments. Updated the tests to take this into account.
+
+2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5crypt.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5crypt.test: Hooked into the new common test support code.
+
+2005-10-24 Andreas Kupries <andreask@activestate.com>
+
+ * md5crypt.bench: New file. Basic benchmarks for MD5 password
+ hashes.
+
+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>
+
+ * md5cryptc.tcl: Fix for building with msvc.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * md5crypt.test: Testsuite fixed. Had to account that error
+ messages can dependent on the version of the Tcl core.
+
+2003-07-26 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5crypt.tcl: Provided implementation of the Apache
+ * md5cryptc.tcl: variation of md5crypt - as used in the
+ * md5crypt.test: Apache2 htpasswd program.
+
+ * md5crypt.man: Added a manual page.
+
+2003-07-26 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * md5crypt.tcl: Initial version of a pure-Tcl and
+ * md5crypt.test: critcl-enhanced implementation of
+ * md5cryptc.tcl: the BSD MD5-crypt algorithm.
+ * pkgIndex.tcl:
+ * ChangeLog:
diff --git a/tcllib/modules/md5crypt/md5crypt.bench b/tcllib/modules/md5crypt/md5crypt.bench
new file mode 100644
index 0000000..6135395
--- /dev/null
+++ b/tcllib/modules/md5crypt/md5crypt.bench
@@ -0,0 +1,46 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'md5' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+set moddir [file dirname [file dirname [info script]]]
+lappend auto_path $moddir
+
+package forget md5
+catch {namespace delete ::md5}
+source [file join [file dirname [file dirname [info script]]] md5 md5x.tcl]
+
+package forget md5crypt
+catch {namespace delete ::md5crypt}
+source [file join [file dirname [info script]] md5crypt.tcl]
+
+set key aaaaaaaaa
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+foreach n {1 10 100 1000 10000} {
+ # Extremely expensive. Limit #iterations to keep total runtime acceptable.
+
+ bench -desc "MD5Crypt $n" -pre {
+ set str [string repeat " " $n]
+ } -body {
+ md5crypt::md5crypt $key $str
+ } -iters 10
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/md5crypt/md5crypt.man b/tcllib/modules/md5crypt/md5crypt.man
new file mode 100644
index 0000000..c7b46f9
--- /dev/null
+++ b/tcllib/modules/md5crypt/md5crypt.man
@@ -0,0 +1,85 @@
+[manpage_begin md5crypt n 1.1.0]
+[see_also md5]
+[keywords hashing]
+[keywords md5]
+[keywords md5crypt]
+[keywords message-digest]
+[keywords security]
+[moddesc {MD5-based password encryption}]
+[copyright {2003, Pat Thoyts <patthoyts@users.sourceforge.net>}]
+[titledesc {MD5-based password encryption}]
+[category {Hashes, checksums, and encryption}]
+[require Tcl 8.2]
+[require md5 2.0]
+[require md5crypt [opt 1.1.0]]
+[description]
+[para]
+
+This package provides an implementation of the MD5-crypt password
+encryption algorithm as pioneered by FreeBSD and currently in use as a
+replacement for the unix crypt(3) function in many modern
+systems. An implementation of the closely related Apache MD5-crypt is
+also available.
+
+The output of these commands are compatible with the BSD and OpenSSL
+implementation of md5crypt and the Apache 2 htpasswd program.
+
+[section {COMMANDS}]
+
+[list_begin definitions]
+
+[call [cmd "::md5crypt::md5crypt"] \
+ [arg "password"] \
+ [arg "salt"]]
+
+Generate a BSD compatible md5-encoded password hash from the plaintext
+password and a random salt (see SALT).
+
+[call [cmd "::md5crypt::aprcrypt"] \
+ [arg "password"] \
+ [arg "salt"]]
+
+Generate an Apache compatible md5-encoded password hash from the plaintext
+password and a random salt (see SALT).
+
+[call [cmd "::md5crypt::salt"] [opt [arg "length"]]]
+
+Generate a random salt string suitable for use with the [cmd md5crypt] and
+[cmd aprcrypt] commands.
+
+[list_end]
+
+[section {SALT}]
+
+The salt passed to either of the encryption schemes implemented here
+is checked to see if it begins with the encryption scheme magic string
+(either "$1$" for MD5-crypt or "$apr1$" for Apache crypt). If so, this
+is removed. The remaining characters up to the next $ and up to a
+maximum of 8 characters are then used as the salt. The salt text
+should probably be restricted the set of ASCII alphanumeric characters
+plus "./" (dot and forward-slash) - this is to preserve maximum
+compatability with the unix password file format.
+[para]
+If a password is being generated rather than checked from a password
+file then the [cmd salt] command may be used to generate a random salt.
+
+[section {EXAMPLES}]
+
+[example {
+% md5crypt::md5crypt password 01234567
+$1$01234567$b5lh2mHyD2PdJjFfALlEz1
+}]
+
+[example {
+% md5crypt::aprcrypt password 01234567
+$apr1$01234567$IXBaQywhAhc0d75ZbaSDp/
+}]
+
+[example {
+% md5crypt::md5crypt password [md5crypt::salt]
+$1$dFmvyRmO$T.V3OmzqeEf3hqJp2WFcb.
+}]
+
+[vset CATEGORY md5crypt]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/md5crypt/md5crypt.tcl b/tcllib/modules/md5crypt/md5crypt.tcl
new file mode 100644
index 0000000..47d9a0a
--- /dev/null
+++ b/tcllib/modules/md5crypt/md5crypt.tcl
@@ -0,0 +1,152 @@
+# md5crypt.tcl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# This file provides a pure tcl implementation of the BSD MD5 crypt algorithm.
+# The implementation is based upon the OpenBSD code which is in turn based upon
+# the original code by Poul-Henning Kamp.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# @mdgen EXCLUDE: md5cryptc.tcl
+
+package require Tcl 8.2; # tcl minimum version
+package require md5 2; # tcllib 1.5
+
+# Try and load a compiled extension to help.
+if {[catch {package require tcllibc}]} {
+ catch {package require md5cryptc}
+}
+
+namespace eval md5crypt {
+ variable itoa64 \
+ {./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz}
+
+ namespace import -force ::md5::MD5Init ::md5::MD5Update ::md5::MD5Final
+ namespace export md5crypt
+}
+
+proc ::md5crypt::to64_tcl {v n} {
+ variable itoa64
+ for {} {$n > 0} {incr n -1} {
+ set i [expr {$v & 0x3f}]
+ append s [string index $itoa64 $i]
+ set v [expr {($v >> 6) & 0x3FFFFFFF}]
+ }
+ return $s
+}
+
+# ::md5crypt::salt --
+# Generate a salt string suitable for use with the md5crypt command.
+proc ::md5crypt::salt {{len 8}} {
+ variable itoa64
+ set salt ""
+ for {set n 0} {$n < $len} {incr n} {
+ append salt [string index $itoa64 [expr {int(rand() * 64)}]]
+ }
+ return $salt
+}
+
+proc ::md5crypt::md5crypt_tcl {magic pw salt} {
+ set sp 0
+
+ set start 0
+ if {[string match "${magic}*" $salt]} {
+ set start [string length $magic]
+ }
+ set end [string first $ $salt $start]
+ if {$end < 0} {set end [string length $salt]} else {incr end -1}
+ if {$end - $start > 7} {set end [expr {$start + 7}]}
+ set salt [string range $salt $start $end]
+
+ set ctx [MD5Init]
+ MD5Update $ctx $pw
+ MD5Update $ctx $magic
+ MD5Update $ctx $salt
+
+ set ctx2 [MD5Init]
+ MD5Update $ctx2 $pw
+ MD5Update $ctx2 $salt
+ MD5Update $ctx2 $pw
+ set H2 [MD5Final $ctx2]
+
+ for {set pl [string length $pw]} {$pl > 0} {incr pl -16} {
+ set tl [expr {($pl > 16 ? 16 : $pl) - 1}]
+ MD5Update $ctx [string range $H2 0 $tl]
+ }
+
+ for {set i [string length $pw]} {$i != 0} {set i [expr {$i >> 1}]} {
+ if {$i & 1} {
+ set c \0
+ } else {
+ set c [string index $pw 0]
+ }
+ MD5Update $ctx $c
+ }
+
+ set result "${magic}${salt}\$"
+
+ set H [MD5Final $ctx]
+
+ for {set i 0} {$i < 1000} {incr i} {
+ set ctx [MD5Init]
+ if {$i & 1} {
+ MD5Update $ctx $pw
+ } else {
+ MD5Update $ctx $H
+ }
+ if {$i % 3} {
+ MD5Update $ctx $salt
+ }
+ if {$i % 7} {
+ MD5Update $ctx $pw
+ }
+ if {$i & 1} {
+ MD5Update $ctx $H
+ } else {
+ MD5Update $ctx $pw
+ }
+ set H [MD5Final $ctx]
+ }
+
+ binary scan $H c* Vs
+ foreach v $Vs {lappend V [expr {$v & 0xFF}]}
+ set l [expr {([lindex $V 0] << 16) | ([lindex $V 6] << 8) | [lindex $V 12]}]
+ append result [to64 $l 4]
+ set l [expr {([lindex $V 1] << 16) | ([lindex $V 7] << 8) | [lindex $V 13]}]
+ append result [to64 $l 4]
+ set l [expr {([lindex $V 2] << 16) | ([lindex $V 8] << 8) | [lindex $V 14]}]
+ append result [to64 $l 4]
+ set l [expr {([lindex $V 3] << 16) | ([lindex $V 9] << 8) | [lindex $V 15]}]
+ append result [to64 $l 4]
+ set l [expr {([lindex $V 4] << 16) | ([lindex $V 10] << 8) | [lindex $V 5]}]
+ append result [to64 $l 4]
+ set l [expr {[lindex $V 11]}]
+ append result [to64 $l 2]
+
+ return $result
+}
+
+if {[info commands ::md5crypt::to64_c] == {}} {
+ interp alias {} ::md5crypt::to64 {} ::md5crypt::to64_tcl
+} else {
+ interp alias {} ::md5crypt::to64 {} ::md5crypt::to64_c
+}
+
+if {[info commands ::md5crypt::md5crypt_c] == {}} {
+ interp alias {} ::md5crypt::md5crypt {} ::md5crypt::md5crypt_tcl {$1$}
+ interp alias {} ::md5crypt::aprcrypt {} ::md5crypt::md5crypt_tcl {$apr1$}
+} else {
+ interp alias {} ::md5crypt::md5crypt {} ::md5crypt::md5crypt_c {$1$}
+ interp alias {} ::md5crypt::aprcrypt {} ::md5crypt::md5crypt_c {$apr1$}
+}
+
+# -------------------------------------------------------------------------
+
+package provide md5crypt 1.1.0
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/md5crypt/md5crypt.test b/tcllib/modules/md5crypt/md5crypt.test
new file mode 100644
index 0000000..5ae8aca
--- /dev/null
+++ b/tcllib/modules/md5crypt/md5crypt.test
@@ -0,0 +1,152 @@
+# -*- tcl -*-
+# md5crypt.test: tests for the md5crypt commands
+#
+# This file contains a collection of tests for one or more of the Tcllib
+# commands. Sourcing this file into Tcl runs the tests and generates
+# output for errors. No output means no errors were found.
+#
+# Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# RCS: @(#) $Id: md5crypt.test,v 1.9 2006/10/09 21:41:41 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal md5crypt.tcl md5crypt
+}
+
+# -------------------------------------------------------------------------
+# Setup any constraints
+
+# Set this true if we have the critcl version.
+
+::tcltest::testConstraint md5crypt_c \
+ [llength [info commands ::md5crypt::md5crypt_c]]
+
+# -------------------------------------------------------------------------
+
+if {[llength [info commands ::md5crypt::md5crypt_c]]} {
+ puts "> critcl based"
+ set impl critcl
+} else {
+ puts "> pure Tcl"
+ set impl tcl
+}
+
+# -------------------------------------------------------------------------
+# Now the package specific tests....
+# -------------------------------------------------------------------------
+# A procedure and a C command generate different error messages.
+
+test md5crypt-1.0 {md5crypt basic usage} {
+ catch {::md5crypt::md5crypt} result
+ if {$impl == "critcl"} {
+ set expected {wrong # args: should be "::md5crypt::md5crypt_c magic pw salt"}
+ } else {
+ set expected [tcltest::wrongNumArgs {*} {pw salt} 0]
+ }
+ string match $expected $result
+} 1
+
+test md5crypt-1.1 {md5crypt basic usage} {
+ catch {::md5crypt::md5crypt pw} result
+ if {$impl == "critcl"} {
+ set expected {wrong # args: should be "::md5crypt::md5crypt_c magic pw salt"}
+ } else {
+ set expected [tcltest::wrongNumArgs {*} {pw salt} 1]
+ }
+ string match $expected $result
+} 1
+
+test md5crypt-1.2 {md5crypt basic usage} {
+ catch {::md5crypt::md5crypt pw salt other} result
+ if {$impl == "critcl"} {
+ set expected {wrong # args: should be "::md5crypt::md5crypt_c magic pw salt"}
+ } else {
+ set expected [tcltest::tooManyArgs {*} {pw salt}]
+ }
+ string match $expected $result
+} 1
+
+# -------------------------------------------------------------------------
+
+foreach {n salt passwd expected} {
+ 1 {} a {$1$$Ij31LCAysPM23KuPlm1wA/}
+ 2 {a} a {$1$a$44cUw6Nm5bX0muHWNIwub0}
+ 3 {aa} a {$1$aa$aM/8fu5RTEKSCJWsk9qH.0}
+ 4 {aaa} a {$1$aaa$SCk4CXyogLtcfwl2VqfSF0}
+ 5 {aaaa} a {$1$aaaa$tjZedp/Ch2UpwkJdEKLPm.}
+ 6 {aaaaa} a {$1$aaaaa$iVkHUcCwuXWk4NaYTbyUa/}
+ 7 {aaaaaa} a {$1$aaaaaa$MUMWPbGfzrHFCNm7ZHg31.}
+ 8 {aaaaaaa} a {$1$aaaaaaa$4OzJTk7W1gmppy.1Lu4nr.}
+ 9 {aaaaaaaa} a {$1$aaaaaaaa$S270EsVIz5M8Y9/k4SSEf.}
+ 10 {aaaaaaaaa} a {$1$aaaaaaaa$S270EsVIz5M8Y9/k4SSEf.}
+ 12 {a$aaaaaaa} a {$1$a$44cUw6Nm5bX0muHWNIwub0}
+ 13 {$1$a$junk} a {$1$a$44cUw6Nm5bX0muHWNIwub0}
+} {
+ test md5passwd-2.${n} [list md5crypt salt check \"$salt\"] {
+ ::md5crypt::md5crypt $passwd $salt
+ } $expected
+
+ # If the C code is loaded, then we have tested that so now check the
+ # pure-tcl implementation as well.
+ test md5passwd-3.${n}_tcl [list md5crypt salt check \"$salt\"] \
+ {md5crypt_c} {
+ ::md5crypt::md5crypt_tcl {$1$} $passwd $salt
+ } $expected
+}
+
+# -------------------------------------------------------------------------
+
+foreach {n salt passwd expected} [list \
+ 1 {a} {} {$1$a$8CfZSfErbeskipdhZHtvu.} \
+ 2 {a} {a} {$1$a$44cUw6Nm5bX0muHWNIwub0} \
+ 3 {a} [string repeat a 100] {$1$a$vTAcWEblAgdUlX6KBz0NM.} \
+ 4 {a} [string repeat a 200] {$1$a$kC.K4D6mvUznpkjWJK8Tm0} \
+ 5 {a} [string repeat a 400] {$1$a$nBvNVTsAryOnHlW7L/gzf/} \
+ 6 {a} [string repeat a 1000] {$1$a$yhNnTV4IKHbl8oEB/eJaj0} \
+] {
+ test md5passwd-4.${n} {md5crypt check passwd} {
+ ::md5crypt::md5crypt $passwd $salt
+ } $expected
+
+ # If the C code is loaded, then we have tested that so now check the
+ # pure-tcl implementation as well.
+ test md5passwd-5.${n}_tcl {md5crypt (pure-Tcl) check passwd} {md5crypt_c} {
+ ::md5crypt::md5crypt_tcl {$1$} $passwd $salt
+ } $expected
+}
+
+# -------------------------------------------------------------------------
+
+foreach {n salt passwd expected} [list \
+ 1 {883.....} {a} {$apr1$883.....$wCU4E7Fv9tHAzFEm5D.mp/} \
+ 2 {XA3.....} {a} {$apr1$XA3.....$kp5j/oX/OCrpKdKhmUqTu1} \
+] {
+ test md5passwd-6.${n} {aprcrypt check passwd} {
+ ::md5crypt::aprcrypt $passwd $salt
+ } $expected
+
+ # If the C code is loaded, then we have tested that so now check the
+ # pure-tcl implementation as well.
+ test md5passwd-7.${n}_tcl {aprcrypt (pure-Tcl) check passwd} {md5crypt_c} {
+ ::md5crypt::md5crypt_tcl {$apr1$} $passwd $salt
+ } $expected
+}
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End: \ No newline at end of file
diff --git a/tcllib/modules/md5crypt/md5cryptc.tcl b/tcllib/modules/md5crypt/md5cryptc.tcl
new file mode 100644
index 0000000..e1facd8
--- /dev/null
+++ b/tcllib/modules/md5crypt/md5cryptc.tcl
@@ -0,0 +1,174 @@
+# md5cryptc.tcl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# This is a critcl-based wrapper to provide a Tcl implementation of the md5crypt
+# function. The C code here is based upon the OpenBSD source, which is in turn
+# derived from the original implementation by Poul-Henning Kamp
+#
+# The original C source license reads:
+#/*
+# * ----------------------------------------------------------------------------
+# * "THE BEER-WARE LICENSE" (Revision 42):
+# * <phk@login.dknet.dk> wrote this file. As long as you retain this notice you
+# * can do whatever you want with this stuff. If we meet some day, and you think
+# * this stuff is worth it, you can buy me a beer in return. Poul-Henning Kamp
+# * ----------------------------------------------------------------------------
+# */
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+
+package require critcl
+# @sak notprovided md5cryptc
+package provide md5cryptc 1.0
+
+critcl::cheaders ../md5/md5.h
+#critcl::csources ../md5/md5.c
+
+namespace eval ::md5crypt {
+ critcl::ccode {
+#include <string.h>
+#include "md5.h"
+#ifdef _MSC_VER
+#define snprintf _snprintf
+#endif
+ static unsigned char itoa64[] =
+ "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
+
+ static void to64(char *s, unsigned int v, int n)
+ {
+ while (--n >= 0) {
+ *s++ = itoa64[v&0x3f];
+ v >>= 6;
+ }
+ }
+
+ static void dump(const char *s, unsigned int len)
+ {
+ unsigned int i;
+ for (i = 0; i < len; i++)
+ printf("%02X", s[i]&0xFF);
+ putchar('\n');
+ }
+
+ static char * md5crypt(const char *pw,
+ const char *salt,
+ const char *magic)
+ {
+ static char passwd[120], *p;
+ static const unsigned char *sp,*ep;
+ unsigned char final[16];
+ int sl,pl,i;
+ MD5_CTX ctx,ctx1;
+ unsigned long l;
+
+ /* Refine the Salt first */
+ sp = (const unsigned char *)salt;
+
+ /* If it starts with the magic string, then skip that */
+ if(!strncmp((const char *)sp,(const char *)magic,strlen((const char *)magic)))
+ sp += strlen((const char *)magic);
+
+ /* It stops at the first '$', max 8 chars */
+ for(ep=sp;*ep && *ep != '$' && ep < (sp+8);ep++)
+ continue;
+
+ /* get the length of the true salt */
+ sl = ep - sp;
+
+ MD5Init(&ctx);
+
+ /* The password first, since that is what is most unknown */
+ MD5Update(&ctx,(unsigned char *)pw,strlen(pw));
+
+ /* Then our magic string */
+ MD5Update(&ctx,(unsigned char *)magic,strlen((const char *)magic));
+
+ /* Then the raw salt */
+ MD5Update(&ctx,(unsigned char*)sp,sl);
+
+ /* Then just as many characters of the MD5(pw,salt,pw) */
+ MD5Init(&ctx1);
+ MD5Update(&ctx1,(unsigned char *)pw,strlen(pw));
+ MD5Update(&ctx1,(unsigned char *)sp,sl);
+ MD5Update(&ctx1,(unsigned char *)pw,strlen(pw));
+ MD5Final(final,&ctx1);
+
+ for(pl = strlen(pw); pl > 0; pl -= 16) {
+ int tl = pl > 16 ? 16 : pl;
+ MD5Update(&ctx,final,pl>16 ? 16 : pl);
+ }
+
+ /* Don't leave anything around in vm they could use. */
+ memset(final,0,sizeof final);
+
+ /* Then something really weird... */
+ for (i = strlen(pw); i ; i >>= 1) {
+ if(i&1)
+ MD5Update(&ctx, final, 1);
+ else
+ MD5Update(&ctx, (unsigned char *)pw, 1);
+ }
+
+ /* Now make the output string */
+ snprintf(passwd, sizeof(passwd), "%s%.*s$", (char *)magic,
+ sl, (const char *)sp);
+
+ MD5Final(final,&ctx);
+
+ /*
+ * and now, just to make sure things don't run too fast
+ * On a 60 Mhz Pentium this takes 34 msec, so you would
+ * need 30 seconds to build a 1000 entry dictionary...
+ */
+ for(i=0;i<1000;i++) {
+ MD5Init(&ctx1);
+ if(i & 1)
+ MD5Update(&ctx1,(unsigned char *)pw,strlen(pw));
+ else
+ MD5Update(&ctx1,final,16);
+
+ if(i % 3)
+ MD5Update(&ctx1,(unsigned char *)sp,sl);
+
+ if(i % 7)
+ MD5Update(&ctx1,(unsigned char *)pw,strlen(pw));
+
+ if(i & 1)
+ MD5Update(&ctx1,final,16);
+ else
+ MD5Update(&ctx1,(unsigned char *)pw,strlen(pw));
+ MD5Final(final,&ctx1);
+ }
+
+ p = passwd + strlen(passwd);
+
+ l = (final[ 0]<<16) | (final[ 6]<<8) | final[12]; to64(p,l,4); p += 4;
+ l = (final[ 1]<<16) | (final[ 7]<<8) | final[13]; to64(p,l,4); p += 4;
+ l = (final[ 2]<<16) | (final[ 8]<<8) | final[14]; to64(p,l,4); p += 4;
+ l = (final[ 3]<<16) | (final[ 9]<<8) | final[15]; to64(p,l,4); p += 4;
+ l = (final[ 4]<<16) | (final[10]<<8) | final[ 5]; to64(p,l,4); p += 4;
+ l = final[11] ; to64(p,l,2); p += 2;
+ *p = '\0';
+
+ /* Don't leave anything around in vm they could use. */
+ memset(final,0,sizeof final);
+
+ return passwd;
+ }
+ }
+ critcl::cproc to64_c {Tcl_Interp* interp int v int n} ok {
+ char s[5];
+ to64(s, (unsigned int)v, n);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(s, n));
+ return TCL_OK;
+ }
+
+ critcl::cproc md5crypt_c {Tcl_Interp* interp char* magic char* pw char* salt} ok {
+ char* s = md5crypt(pw, salt, magic);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(s, strlen(s)));
+ return TCL_OK;
+ }
+}
diff --git a/tcllib/modules/md5crypt/pkgIndex.tcl b/tcllib/modules/md5crypt/pkgIndex.tcl
new file mode 100644
index 0000000..487ff9d
--- /dev/null
+++ b/tcllib/modules/md5crypt/pkgIndex.tcl
@@ -0,0 +1,3 @@
+# package index for md5crypt
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded md5crypt 1.1.0 [list source [file join $dir md5crypt.tcl]]
diff --git a/tcllib/modules/mime/ChangeLog b/tcllib/modules/mime/ChangeLog
new file mode 100644
index 0000000..85f13c6
--- /dev/null
+++ b/tcllib/modules/mime/ChangeLog
@@ -0,0 +1,796 @@
+2014-01-08 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Last commit forgot to update the package index,
+ causing a mismatch. Fixed, likewise the Tcl requirement.
+
+2013-11-22 Andreas Kupries <andreask@activestate.com>
+
+ * mime.tcl: (PoorYorick): general cleanup. use expr operators like
+ * mime.test: eq instead of string commands. (AK Notes): Version
+ bumped to 1.6, requirement bumped to Tcl 8.5. (AK) Updated
+ testsuite and doc Tcl requirements. Fixed the creative writing
+ problem of the initialization code, present before PY cleanup.
+
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2013-01-09 Andreas Kupries <andreask@activestate.com>
+
+ * mime.tcl (::mime::buildmessage): [Bug 3565267]: Handle
+ * mime.man: possibility of 'errorCode' not set. Version
+ * pkgIndex.tcl: bumped to 1.5.6.
+
+2012-08-02 Andreas Kupries <andreask@activestate.com>
+
+ * mime.man: [Bug 3354014]: Fixed typo in option name. -parts is
+ correct. (Note the trailing 's').
+
+2012-02-23 Andreas Kupries <andreask@activestate.com>
+
+ * mime.test: [Bug 3483716]: Added testcase, supplied by Christian
+ Nassau. Thank you.
+
+2012-02-22 Andreas Kupries <andreask@activestate.com>
+
+ * mime.tcl: [Bug 3483716]: Accepted patch by Christian Nassau
+ * pkgIndex.tcl: <cnassau@users.sourceforge.net> to handle (decode)
+ the content transfer encodings base64 and quoted-printable. Bumped
+ version to 1.5.5.
+
+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 ========================
+ *
+
+2011-01-20 Andreas Kupries <andreask@activestate.com>
+
+ * smtp.man: [ActiveState 89180]: Added documentation about the
+ soft-dependencies required for SMTP authentication, i.e. SASL.
+
+2010-07-06 Andreas Kupries <andreask@activestate.com>
+
+ * smtp.man: [Bug 3011581]: Accepted tweak to the documentation of
+ the -header option proposed by <rich123@users.sf.net> to make
+ the syntax clearer.
+
+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 ========================
+ *
+
+2008-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * smtp.tcl: Bumped version to 1.5.4, for the change made on
+ * smtp.man: 2007-10-08 by Pat. Was a bugfix, should have bumped
+ * pkgInsdex.tcl: the version at that time.
+
+2008-05-23 Andreas Kupries <andreask@activestate.com>
+
+ * mime.tcl (::mime::parsepart): [SF Tcllib Bug 1961881]. Accepted
+ * mime.man: patch, and extended. Now handling malformed input
+ * mime.test: without having to throw an eror, and without going
+ * pkgIndex.tcl: into an infinite loop. See also [Bug 631314], and
+ Changelog entries 2003-06-06, 2003-06-25. The testcases
+ mime-3.{7,8} are not redundant, but significantly different. 3.7
+ actually has a terminating boundary, but misses the starting
+ one, causing non-recognition of any terminating one. Bumped the
+ version to 1.5.4.
+
+2007-11-05 Andreas Kupries <andreask@activestate.com>
+
+ * mime.tcl (::mime::parsepart): Fixed [SF Tcllib Bug 1825092],
+ * mime.test: as reported by Max Strobel
+ * pkgIndex.tcl: <mstrhh@users.sourceforge.net>. The code parsing
+ * mime.man: multiparts assumed that eol sequences are always two
+ characters (cr+lf), this however may not be the case. This
+ caused the parser to miscount the last line in a part and
+ wrongly remove its last character from the part. Extended the
+ testsuite, and bumped the version to 1.5.3.
+
+2007-10-08 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * mime.tcl: bug #1658061: reset errorInfo after catches known
+ * smtp.tcl: to fail to avoid confusion.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.tcl (::mime::word_encode): Unbreak the unconditional
+ line-breaking performed by some of the base64 encoders we use.
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.man: Fixed all warnings due to use of now deprecated
+ * smtp.man: commands. Added a section about how to give feedback.
+
+2007-01-25 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * smtp.tcl: Expose -client option to enable user to supply the
+ * smtp.man: string used for the HELO/EHLO challenge.
+ Closes FR #1614860.
+
+2007-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.tcl (word_encode): Ensured the return of the empty string
+ when given the empty string.
+
+2006-11-06 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * smtp.tcl: bug #827436 - ensure data section is terminated with
+ CRLF.CRLF on the non Trf code path.
+
+2006-10-25 Andreas Kupries <andreask@activestate.com>
+
+ * mime.tcl: Applied patch for [SF Tcllib Bug 763731], fixing
+ * mime.man: word_encode's problem with creating words which are
+ * pkgIndex.tcl: too long. Version now is 1.5.2
+
+2006-10-24 Andreas Kupries <andreask@activestate.com>
+
+ * mime.tcl (::mime::qp_encode): Moved the code for chopping off a
+ superfluous newline into the branch actually adding it. The
+ unconditional chop caused it to lose the last character if the
+ branch was not taken. This bug was apparently introduced by the
+ patch for [SF Tcllib RFE 503336], added 2002-01-16, by
+ myself. Reported by Gustaf Neumann <neumann@wu-wien.ac.at>, with
+ a patch.
+
+2006-10-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.test: Rewritten to use new features for handling the
+ environment.
+
+2006-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.test: Updated the three tests affected by the bugfix (see
+ 2006-10-02 entry).
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-10-02 Andreas Kupries <andreask@activestate.com>
+
+ * mime.tcl: Fixed both ::mime::copymessageaux and
+ * mime.man: ::mime::buildmessageaux to not generate too many
+ * pkgIndex.tcl: CRLF's at the end of bodies.
+ See [SF Tcllib Bug 1213527, and [SF Tcllib Patch 1254934].
+ Bumped version to 1.5.1.
+
+2006-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * mime.man: Bumped version to 1.5
+ * mime.tcl:
+ * pkgIndex.tcl:
+
+2006-01-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.test: Fixed handling of "env".
+
+2006-01-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.test: Fixed use of duplicate test names.
+
+2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.test: Hooked into the new common test support code.
+
+2006-01-10 Andreas Kupries <andreask@activestate.com>
+
+ * performance.tcl: Removed the unstructured benchmarks.
+ * mime.bench: New file, contains structured benchmarks for the
+ module. This fixes [SF Tcllib Bug 1373935].
+
+2006-01-10 Andreas Kupries <andreask@activestate.com>
+
+ * mime.tcl: Ensured that all accesses to the variable 'major'
+ operate on a global variable. Fix for [SF Tcllib Bug 1394840],
+ reported by George Orwell <orwellian@users.sourceforge.net>.
+
+2005-11-06 Benjamin Riefenstahl <b.riefenstahl@turtle-trading.net>
+
+ * mime.tcl (parsedatetime): Add support for timezones with format
+ +NNNN or -NNNN. Add support for property "clock".
+ * mime.test (mime-9.x): Add testing of parsedatetime.=20
+
+2005-11-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.tcl: Applied patch by Benjamin Riefenstahl fixing bugs in
+ his patch for [SF Tcllib Bug 1276561], see 2005-10-04 entry.
+
+ * (MONTHS_SHORT, MONTHS_LONG): Add a dummy entry at index 0.
+ * (parsedatetime): For month index, use "%m" + scan instead of
+ wrong "%e".
+
+2005-10-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-10-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: Synchronized version numbers to the
+ * smtp.man: implementation.
+
+2005-10-07 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * smtp.tcl: Use the SASL module for authentication. Checked this
+ against sendmail+cyrussasl and Microsoft SMTPd (for NTLM).
+
+2005-10-04 Andreas Kupries <andreask@activestate.com>
+
+ * mime.tcl: Applied patch for [SF Tcllib Bug 1276561] by Benjamin
+ Riefenstahl. Fixes the handling of date/times, removing
+ dependencies on the current locale.
+
+2005-09-05 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * smtp.tcl (::smtp::auth_CRAM-MD5): Fix for bug #1242629 - qmail
+ doesn't like a multi-line response.
+
+2005-03-08 Andreas Kupries <andreask@activestate.com>
+
+ * mime.tcl (::mime::copymessageaux): Removed usage of the command
+ 'unstack'. Its presence is a bug ever since revision 1.3 (March
+ 9, 2000) of mime.tcl, when the converters (base64,
+ quoted-printable) started to be used in immediate mode instead
+ of attaching them to the output channel. This also means that we
+ do not need the fallback implementation anymore either.
+
+ Many thanks to Roy Terry <royterry@earthlink.net> for keeping up
+ the nagging about [SF Tcllib Bug 754920] which demonstrated the
+ problem.
+
+ What happened is that the unpaired 'unstack' removes the outer
+ .-transformation and a second call may close the channel. If
+ that happens any further access to the channel errors out, and
+ the mail server gets and transfers an incomplete mail message.
+ It is a 'may' and not a 'will' because it seems that sometimes
+ the channel has a refcount > 0 and then 'unstack' does
+ nothing. This part made the reproduction difficult. It was
+ originally suspected to be a problem in Trf itself, but is
+ actually a problem in how it is used by mime.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-08-04 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * smtp.tcl: Do not try to authenticate if no username is
+ supplied.
+
+2004-07-08 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * smtp.man: Added mention of DIGEST-MD5 support and put some
+ RFC references in.
+
+2004-07-06 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * smtp.tcl: Cleaned up some hardcoded settings left from
+ development. (oops).
+
+2004-07-02 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * smtp.tcl: Added SASL mechanism DIGEST-MD5 authentication
+ support. Also redid md5 package version abstraction.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * smtp.tcl: Updated smtp to version 1.4, to reflect the
+ * smtp.man: extensions made to it (Authentication). This
+ * pkgIndex.tcl: also distinguishes the main line version from the
+ one in the 1.6 branch.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.tcl: Downgraded mime to version 1.3.6, and removed the
+ * mime.man: -decode extension from the API. This branch is for
+ * pkgIndex.tcl: bugfixes only.
+
+2004-05-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * smtp.tcl: Fixed [SF Tcllib Bug 954328]. Same bug in different
+ guise. This package exclusively required md5 v2. This clashed
+ with mime's requirement of v1. Now package smtp also adapts at
+ runtime to whatever version of package md5 has been loaded.
+
+ * mime.test:
+ * mime.tcl: Fixed [SF Tcllib Bug 954328]. The package mime now
+ adapts at runtime to whatever version of package md5 has been
+ loaded.
+
+2004-05-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * smtp.tcl (::smtp::wdata): Fixed [SF Tcllib Bug 951568]. Added
+ handlers for the query/* commands from Trf. Also changed the
+ default to sliently pass all unknowns in the future.
+
+2004-05-10 Andreas Kupries <andreask@activestate.com>
+
+ * mime.tcl (copymessageaux): Applied the patch for [SF Tcllib Bug
+ 893516] on behalf of Marshall Rose. The problem was found by
+ Todd Copeland <todd.copeland@pervasive.com>, he provided the
+ patch as well.
+
+2004-05-04 Andreas Kupries <andreask@activestate.com>
+
+ * mime.man:
+ * mime.test:
+ * mime.tcl: Applied [SF Tcllib Patch 763712]. This extends the
+ functionality of mime::getbody with decoding of the mime part
+ based on the specified charset into the regular utf8
+ form. Testsuite was updated and extended as well. Thanks to
+ Matthew Walker <gunzel@users.sourceforge.net> for the
+ work. Updated the documentation for mime on my own. Bumped
+ version to 1.4.
+
+ * mime:test:
+ * mime.tcl: Applied [SF Tcllib Patch 758742], adding many more
+ MIME types for encodings to the knowledge-base of the
+ package. Thanks to Matthew Walker <gunzel@users.sourceforge.net>
+ for the work, and Mikhail Teterin <kot@users.sourceforge.net>
+ for prodding. Bumped version to 1.3.5.
+
+ * mime.test:
+ * mime.tcl (copymessageaux): Fixed [SF Tcllib Bug 620852]. Added
+ '-nonewline' to the puts statements which wrote out the chunks
+ read from the file associated with the mime part, converted or
+ not. As the data was [read] we had no business of adding eol's
+ during writing as well. Thanks to Jasper Taylor
+ <jaspert@users.sourceforge.net> for the report, and his
+ patience. Added a test for this as well, using files of similar
+ size as originally provided.
+
+2004-03-18 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * smtp.tcl: Added support for RFC 2554 - SMTP Authentication. This
+ included support for the SASL mechanisms CRAM-MD5 and PLAIN and
+ the Microsoft LOGIN mechanism. This has been tested against
+ Microsoft Exchange servers and Sendmail 8.12.
+ Added support for RFC 1870, the SIZE extension.
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.test: Fixed access to files, was not done with
+ tcltest::testDirectory, causing them to be inaccessible
+ for 8.4+. The result in mime-2.2 was also dependent on the exact
+ order of keys retrieved from the array of parameters. Rewritten
+ to take this into account.
+
+2004-01-30 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * smtp.tcl: Better handling of failure in TLS setup. Added a
+ policy command to control TLS policy on failure.
+
+2004-01-29 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * smtp.tcl: Added support for the STARTTLS extension (RFC 3207).
+ This may also support old versions that report a TLS option in
+ reply to EHLO, but these are not tested.
+
+2003-11-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.tcl (word_decode): Fixed [SF Tcllib Bug 764702], accepted
+ the patch coming with the bugreport (both by Reinhard Speyerer
+ <rspsf@users.sourceforge.net>). Command is now able to decode
+ data in encoded utf-8.
+
+ * mime.test: Added test for the bug above.
+
+2003-11-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * smtp.tcl (smtp::hear): Integrated fix for [Bug 836442]. Limiting
+ seconds to 600 to prevent integer wraparound when setting up a
+ timer event. Bug reported (and fix provided) by Andreas Otto,
+ and accepted by Marshall Rose.
+
+2003-06-25 David N. Welton <davidw@dedasys.com>
+
+ * mime.tcl (::mime::parsedatetime): Use string map instead of
+ regsub - it's faster.
+
+ * mime.test: Added tests which operate on the bad files below.
+
+ * badmail2.txt: Added second piece of mail for testing. If they
+ turn out to be redundant, we can erase one.
+
+ * badmail1.txt: Added mail for testing that triggers bug 631314.
+
+2003-06-06 Andreas Kupries <andreask@activestate.com>
+
+ * mime.tcl (::mime::word_decode): Accept lower-case encoding
+ specifiers. [Bug 732512]. Reported by Matthew Walker
+ <gunzel@users.sourceforge.net>, plus patch. Patch accepted by
+ Marshall Rose.
+
+ * mime.test: Two more tests checking the acceptance of lower-case
+ encoding specifiers.
+
+ * mime.tcl (::mime::parsepart): Reactivated error command, revert
+ to error on malformed mime input, instead of infinite
+ looping. [Bug 631314] reported by David Welton.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-05-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.tcl: Applied patch for SF Tcllib bug #731759, as submitted
+ * mime.test: by Matthew Walker <gunzel@users.sourceforge.net> and
+ accepted by Marshall Rose <mrose@users.sourceforge.net>.
+ Update of the testsuite on my own.
+
+2003-04-25 Andreas Kupries <andreask@activestate.com>
+
+ * mime.man: Added a section for known bugs, and recorded 447037 as
+ such.
+
+2003-04-10 Andreas Kupries <andreask@activestate.com>
+
+ * smtp.tcl:
+ * mime.tcl:
+ * mime.man:
+ * csmtp.man:
+ * pkgIndex.tcl: Fixed bug #614591. Set version of the package to
+ to 1.3.3. Fixed equivalent of bug #648679.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.man: More semantic markup, less visual one.
+ * smtp.man:
+
+2003-01-06 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * mime.tcl (md5): Fix for bug # 630381. Use tcllib md5 to handle
+ Trf transparency.
+
+2002-10-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.man: Changed -parse to -part in description of
+ "::mime::initialize". Thanks to "Gerald W. Lester"
+ <gerald.lester@cox.net> for finding this.
+
+2002-09-16 David N. Welton <davidw@dedasys.com>
+
+ * smtp.man: Added example from http://mini.net/tcl/1256.
+
+2002-09-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.test: Extended field_decode tests with the examples from
+ RFC 2047.
+
+ * mime.tcl: Integrated new implementation of 'field_decode'
+ provided by Don Libes <don@libes.com>. This rewrite correctly
+ decodes all seven examples of RFC 2047. The old version decoded
+ only one correctly.
+
+2002-08-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.tcl: Accepted patch in SF FR #595240, provided by Marshall
+ T. Rose <mrose@users.sourceforge.net>. The patch makes the code
+ more robust with respect to a common mime encoding error.
+
+ * tcllib/examples/mime: Added an example application making use of
+ mime and smtp packages. Mbot is a highly-specialized filter for
+ personal messages. Again this is code provided to us by Marshall
+ T. Rose.
+
+ * smtp.tcl: Followup patch to patch SF #557520/2. A line of code
+ initializing the options from the state was missing in one
+ command, causing problems with the usage of -maxsecs. This was
+ noted on c.l.t., by Acacio Cruz. The followup patch was provided
+ by Todd Coram.
+
+2002-07-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * smtp.tcl: Applied patch SF #557520/2 (== SF #558132) supplied by
+ Todd Coram <tcoram@users.sourceforge.net>on behalf of Marshall
+ Rose <mrose@users.sourceforge.net>. This patch dispenses with
+ the automatic calculation of a timeout value and goes with a
+ user-supplied value (new option -maxsecs) instead. Default for
+ this option is 120 secs. This fixes bug SF #557040.
+
+ * performance.tcl: New file. Script supplied by Pascal Scheffers
+ (see below) to test the performance of the mime package.
+
+ * mime.tcl: Applied patch SF #585455 supplied by Pascal Scheffers
+ <pascalscheffers@users.sourceforge.net> on behalf of Marshall
+ Rose <mrose@users.sourceforge.net>. This patch speeds up MIME
+ processing by using [split \n] and list ops to iterate over the
+ lines in the mail instead of using [string range] for doing it
+ incrementally, copying unprocessed data down again and again.
+
+2002-06-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.tcl: Fixed bug SF #548832. Report and patch by Michael
+ A. Cleverly <cleverly@users.sourceforge.net>.
+
+2002-05-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * smtp.tcl (smtp::initialize): Fixed SF bug #561416. The reporter
+ is unknown and provided the fix too. Fix approved by Marshall
+ Rose <mrose@users.sourceforge.net>.
+
+2002-05-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.tcl: Accepted patch for SF bug #553784, by Don Porter
+ <dgp@users.sourceforge.net>.
+
+ * smtp.tcl: Applied patch for SF bug #539952, on behalf of
+ Marshall Rose <mrose@users.sourceforge.net>. The part of the
+ patch regarding "mime.tcl" was already in the CVS, as part of
+ the fix for SF #477088, see 2001-11-01.
+
+2002-04-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * smtp.tcl: Applied patch for SF bug #547336 on behalf of Marshall
+ Rose <mrose@users.sourceforge.net>. Bug was reported by Don
+ Porter <dgp@users.sourceforge.net>. This removes the duplicate
+ [package require Trf] we had before.
+
+2002-04-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.man: Added doctools manpage.
+ * smtp.man: Added doctools manpage.
+
+2002-04-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * smtp.tcl: Accepted patch by Simon Scott
+ <sjscott@users.sourceforge.net>, with slight modification. Fixes
+ bug #533025.
+
+2002-02-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.tcl: Accepted patch for bug #519623 by Rolf Ade
+ <rolf@pointsman.de>.
+
+2002-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Version set to 1.3.2 to differentiate the development code from
+ the 1.2 release containing 1.3.1.
+
+ * mime.n: Applied patch 511692 provided by Larry Virden
+ <lvirden@users.sourceforge.net> fixing a formatting problem.
+
+2002-01-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bumped version to 1.3.1
+
+2002-01-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * smtp.tcl: Fixed bug #499242. Extended the non-trf branch of
+ smtp::wtextaux to detect and transform bare LF's into proper
+ CR/LF sequences.
+
+2002-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.tcl (qp_encode): Implemented FR #503336, added
+ 'no_softbreak' flag to qp_encode. Default value is false, giving
+ the original behaviour. If set the encoded data is not broken
+ into multiple lines, even if longer than 72 characters.
+
+2001-11-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.n: Clarified documentation for 'parseaddress' in the wake
+ of bug #479174 as this is the command which actually handles the
+ value of option -recipients mentionend below.
+
+ * smtp.n: Fixed bug #479144, clarified contents of value for
+ -recipients. Bug reported by Darren New
+ <dnew@users.sourceforge.net>.
+
+2001-11-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * smtp.tcl: Fixed bug #472009. Changes in the handling of
+ script-level transformations cause the system to try to
+ initialize the read side of the 'smtp::wdata'
+ transformation. This fails. Added a dummy create/read branch to
+ the switch. Reported by 'nobody/anonymous', but possibly Andreas
+ Otto (deduced from the specified example).
+
+ * mime.tcl: Added informaton about 7bit, 8bit, and binary encoding
+ to the places where it is missing. This fixes SF item
+ #477088. Bug was reported by Oliver Bienert
+ <obienert@users.sourceforge.net>.
+
+2001-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * mime.n:
+ * mime.tcl:
+ * smtp.n:
+ * smtp.tcl:
+ * pkgIndex.tcl: Version up to 1.3
+
+2001-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Added manpages for smtp and mime packages.
+
+2001-08-01 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * mime.tcl: made package require 8.3 and sped up qp_encode and
+ qp_decode.
+
+2001-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * smtp.tcl:
+ * mime.tcl: Frink 2.2 run, fixed dubious code.
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * smtp.tcl:
+ * mime.tcl: Fixed dubious code reported by frink and procheck.
+
+2001-01-30 Eric Melski <ericm@interwoven.com>
+
+ * mime.tcl: Applied patch from Peter MacDonald to correct problem
+ with mime::initialize failing when mailers neglect to include
+ the trailing boundary marker.
+
+2000-09-20 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * smtp.tcl
+ * mime.tcl: namespaced the procs that are created to replace
+ the Trf functions when Trf isn't available. This way they
+ are not created in the global namespace, and there isn't any
+ risk that they will collide with other global functions.
+
+2000-09-04 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * README.xml
+ * README.txt
+ * README.html
+ * mime.tcl: Added proc header comment blocks to all procedures.
+ Some are better than others, and they were written based on a
+ quick analysis of the code and the documentation in the README
+ file. They should be updated as they change or are found to be
+ inaccurate.
+
+2000-09-01 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * mime.tcl
+ * mime.test: Integrated a patch from Laurent Riesterer
+ (riesterer@celar.fr). This patch added three new procedures
+ (mime::word_encode, mime::word_decode, and mime::field_decode)
+ The patch also adds support for word encoded items as defined
+ in RFC 2047. Fixed a bug in the quoted printable encode function
+ mime::qp_encode
+
+2000-08-15 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * mime.tcl
+ * smtp.tcl: Made fixes so that smtp::sendmessage and
+ mime::buildmessage work properly. Fixed a bug where
+ the "." at the start of a line was not being replaced
+ by a ".." This was fine in base64 or in the default
+ quoted printable, but was clearly broken in 8-bit or
+ 7-bit encodings.
+
+2000-08-11 Eric Melski <ericm@ajubasolutions.com>
+
+ * README.xml:
+ * README.html:
+ * README.txtl: Clarified information about soft-dependancy on Trf.
+
+2000-08-03 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * README.txt
+ * README.xml
+ * README.html
+ * mime/smtp.tcl: Added a '-ports' option to smtp::sendmessage.
+ The '-ports' option takes a list that should mirror the list of
+ SMTP servers specified with the '-servers' flag. Documented the
+ mime::reversemapencodings, mime::mapencodings, and
+ smtp::buildmessage functions
+
+ * mime/mime.tcl: Added mime::mapencoding and
+ mime::reversemapencoding functions to map tcl encodings
+ to their charset types, and back again.
+
+ * mime/pkgIndex.tcl: Bumped the revision number from 1.1 to 1.2
+
+2000-06-21 Sandeep Tamhankar <sandeep@scriptics.com>
+
+ * mime/smtp.tcl: Undid the #5693 fix. It turns out there are
+ situations where this is the desired behavior. The basic idea is
+ that the -recipients value is used in the SMTP envelope, and
+ should not be mixed with message headers. Basically, they're two
+ totally different things. I commented all the code and cleaned up
+ some of the areas where side effects were being used unnecessarily
+ and making the code hard to read.
+
+2000-05-24 Sandeep Tamhankar <sandeep@scriptics.com>
+
+ * mime/smtp.tcl: Fixed bug 5693, where the "To:" header wasn't
+ being sent with an e-mail when using the -recipients flag of
+ smtp::sendmessage. Also, if -recipients was combined with -header
+ "To ..." or -header "Cc ...", it would send the message only to
+ -recipients (which is documented) but it would leave the Cc and To
+ headers, which are wrong. This is also fixed.
+
+2000-05-23 Sandeep Tamhankar <sandeep@scriptics.com>
+
+ * mime/mime.tcl
+ * mime/mime.test: Fixed bugs 5521 and 5659, where qp_encode and
+ qp_decode had numerous bugs. See #5659 for details.
+
+2000-05-22 Sandeep Tamhankar <sandeep@scriptics.com>
+
+ * mime/smtp.tcl: Fixed a bug where if the requested mail server
+ didn't exist (i.e. the host didn't have an SMTP server running),
+ smtp::sendmessage would continue executing until a horrific crash
+ at a later point. I added the check and proper error reporting.
+
+2000-05-06 Sandeep Tamhankar <sandeep@scriptics.com>
+
+ * mime/smtp.tcl: Fixed bug 5383, where smtp wouldn't work because
+ it had a dependency on Trf. I've patched the code, and it seems
+ to work fine now.
+
+2000-04-25 Sandeep Tamhankar <sandeep@scriptics.com>
+
+ * modules/mime/mime.test: Added a somewhat rudimentary test suite
+ for TclMIME. Found what I believe is a minor bug in the package,
+ but decided not to fix it (and just let the relevant test fail)
+ until I can discuss it with Brent.
+
+2000-03-07 Brent Welch <welch@scriptics.com>
+
+ * modules/mime/mime.tcl: Modified this to have a soft dependency on
+ the Trf package. If it is available then the encoding and decoding
+ of MIME base64 and quoted-printable will run faster.
+ Also added mime::buildmessage that creates the structured MIME message
+ in a string and returns that - much like mime::copymessage that
+ copies the message to a channel.
diff --git a/tcllib/modules/mime/README.html b/tcllib/modules/mime/README.html
new file mode 100644
index 0000000..16aa020
--- /dev/null
+++ b/tcllib/modules/mime/README.html
@@ -0,0 +1,880 @@
+<html><head><title>The README file: Tcl MIME</title>
+<meta http-equiv="Expires" content="Wed, 23 Feb 2000 04:36:30 +0000">
+<STYLE type='text/css'>
+ .title { color: #990000; font-size: 22px; line-height: 22px; font-weight: bold; text-align: right;
+ font-family: helvetica, arial, sans-serif }
+ .filename { color: #666666; font-size: 18px; line-height: 28px; font-weight: bold; text-align: right;
+ font-family: helvetica, arial, sans-serif }
+ p.copyright { color: #000000; font-size: 10px;
+ font-family: verdana, charcoal, helvetica, arial, sans-serif }
+ p { margin-left: 2em; margin-right: 2em; }
+ ol { margin-left: 2em; margin-right: 2em; }
+ ul.text { margin-left: 2em; margin-right: 2em; }
+ pre { margin-left: 3em; color: #333333 }
+ ul.toc { color: #000000; line-height: 16px;
+ font-family: verdana, charcoal, helvetica, arial, sans-serif }
+ H3 { color: #333333; font-size: 16px; line-height: 16px; font-family: helvetica, arial, sans-serif }
+ H4 { color: #000000; font-size: 14px; font-family: helvetica, arial, sans-serif }
+ TD.header { color: #ffffff; font-size: 10px; font-family: arial, helvetica, san-serif; valign: top }
+ TD.author-text { color: #000000; font-size: 10px;
+ font-family: verdana, charcoal, helvetica, arial, sans-serif }
+ TD.author { color: #000000; font-weight: bold; margin-left: 4em; font-size: 10px; font-family: verdana, charcoal, helvetica, arial, sans-serif }
+ A:link { color: #990000; font-size: 10px; text-transform: uppercase; font-weight: bold;
+ font-family: MS Sans Serif, verdana, charcoal, helvetica, arial, sans-serif }
+ A:visited { color: #333333; font-weight: bold; font-size: 10px; text-transform: uppercase;
+ font-family: MS Sans Serif, verdana, charcoal, helvetica, arial, sans-serif }
+ A:name { color: #333333; font-weight: bold; font-size: 10px; text-transform: uppercase;
+ font-family: MS Sans Serif, verdana, charcoal, helvetica, arial, sans-serif }
+ .link2 { color:#ffffff; font-weight: bold; text-decoration: none;
+ font-family: monaco, charcoal, geneva, MS Sans Serif, helvetica, monotype, verdana, sans-serif;
+ font-size: 9px }
+ .RFC { color:#666666; font-weight: bold; text-decoration: none;
+ font-family: monaco, charcoal, geneva, MS Sans Serif, helvetica, monotype, verdana, sans-serif;
+ font-size: 9px }
+ .hotText { color:#ffffff; font-weight: normal; text-decoration: none;
+ font-family: charcoal, monaco, geneva, MS Sans Serif, helvetica, monotype, verdana, sans-serif;
+ font-size: 9px }
+</style>
+</head>
+<body bgcolor="#ffffff"alink="#000000" vlink="#666666" link="#990000">
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<table width="66%" border="0" cellpadding="0" cellspacing="0"><tr><td><table width="100%" border="0" cellpadding="2" cellspacing="1">
+<tr valign="top"><td width="33%" bgcolor="#666666" class="header">The README file</td><td width="33%" bgcolor="#666666" class="header">M.T. Rose</td></tr>
+<tr valign="top"><td width="33%" bgcolor="#666666" class="header">&nbsp;</td><td width="33%" bgcolor="#666666" class="header">Dover Beach Consulting, Inc.</td></tr>
+<tr valign="top"><td width="33%" bgcolor="#666666" class="header">&nbsp;</td><td width="33%" bgcolor="#666666" class="header">February 22, 2000</td></tr>
+</table></td></tr></table>
+<div align="right"><font face="monaco, MS Sans Serif" color="#990000" size="+3"><b><br><span class="title">Tcl MIME</span></b></font></div>
+<font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<h3>Abstract</h3>
+
+<p>
+Tcl MIME generates and parses MIME body parts.
+</p>
+<a name="toc"><br><hr size="1" shade="0"></a>
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<h3>Table of Contents</h3>
+<ul compact class="toc">
+<b><a href="#anchor1">1.</a>&nbsp;
+SYNOPSIS<br></b>
+<b><a href="#anchor2">1.1</a>&nbsp;
+Requirements<br></b>
+<b><a href="#anchor3">1.2</a>&nbsp;
+Copyrights<br></b>
+<b><a href="#anchor4">2.</a>&nbsp;
+SYNTAX<br></b>
+<b><a href="#anchor5">3.</a>&nbsp;
+SEMANTICS<br></b>
+<b><a href="#mime_initialize">3.1</a>&nbsp;
+mime::initialize<br></b>
+<b><a href="#mime_finalize">3.2</a>&nbsp;
+mime::finalize<br></b>
+<b><a href="#mime_getproperty">3.3</a>&nbsp;
+mime::getproperty<br></b>
+<b><a href="#mime_getheader">3.4</a>&nbsp;
+mime::getheader<br></b>
+<b><a href="#mime_setheader">3.5</a>&nbsp;
+mime::setheader<br></b>
+<b><a href="#mime_getbody">3.6</a>&nbsp;
+mime::getbody<br></b>
+<b><a href="#mime_copymessage">3.7</a>&nbsp;
+mime::copymessage<br></b>
+<b><a href="#mime_buildmessage">3.7</a>&nbsp;
+mime::buildmessage<br></b>
+<b><a href="#smtp_sendmessage">3.8</a>&nbsp;
+smtp::sendmessage<br></b>
+<b><a href="#mime_parseaddress">3.9</a>&nbsp;
+mime::parseaddress<br></b>
+<b><a href="#mime_parsedatetime">3.10</a>&nbsp;
+mime::parsedatetime<br></b>
+<b><a href="#mime_mapencoding">3.10</a>&nbsp;
+mime::mapencoding<br></b>
+<b><a href="#mime_reversemapencoding">3.10</a>&nbsp;
+mime::reversemapencoding<br></b>
+
+<b><a href="#anchor6">4.</a>&nbsp;
+EXAMPLES<br></b>
+<b><a href="#rfc.references">&#167;</a>&nbsp;
+References<br></b>
+<b><a href="#rfc.authors">&#167;</a>&nbsp;
+Author's Address<br></b>
+<b><a href="#anchor7">A.</a>&nbsp;
+TODO List<br></b>
+<b><a href="#anchor8">B.</a>&nbsp;
+Acknowledgements<br></b>
+</ul>
+<br clear="all">
+
+<a name="anchor1"><br><hr size="1" shade="0"></a>
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<h3>1.&nbsp;SYNOPSIS</h3>
+</font><pre>
+ package provide mime 1.2
+ package provide smtp 1.2
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+Tcl MIME is an implementation of a Tcl package that generates and
+parses <a href="#RFC2045">MIME</a>[1] body parts.
+</p>
+
+<p>
+Each MIME part consists of a header
+(zero or more key/value pairs),
+an empty line,
+and a structured body.
+A MIME part is either a "leaf" or has (zero or more) subordinates.
+</p>
+
+<p>
+MIME defines four keys that may appear in the headers:
+
+<blockquote class="text"><dl>
+
+<dt> Content-Type:</dt>
+<dd>
+describes the data contained in the body
+("the content");
+</dd>
+
+<dt> Content-Transfer-Encoding:</dt>
+<dd>
+describes how the content is
+encoded for transmission in an ASCII stream;
+</dd>
+
+<dt> Content-Description:</dt>
+<dd>
+a textual description of the
+content; and,
+</dd>
+
+<dt> Content-ID:</dt>
+<dd>
+a globally-unique identifier for the
+content.
+</dd>
+
+</dl></blockquote>
+
+</p>
+
+<p>
+Consult <a href="#RFC2046">[2]</a> for a list of standard content types.
+Further,
+consult <a href="#RFC822">[3]</a> for a list of several other header keys
+(e.g., "To", "cc", etc.)
+</p>
+
+<p>
+A simple example might be:
+</p>
+</font><pre>
+ Date: Sun, 04 July 1999 10:38:25 -0600
+ From: Marshall Rose &lt;mrose@dbc.mtview.ca.us>
+ To: Andreas Kupries &lt;a.kupries@westend.com>
+ cc: dnew@messagemedia.com (Darren New)
+ MIME-Version: 1.0
+ Content-Type: text/plain; charset="us-ascii"
+ Content-Description: a simple example
+ Content-ID: &lt;4294407315.931384918.1@dbc.mtview.ca.us>
+
+ Here is the body. In this case, simply plain text.
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+In addition to an implementation of the mime package,
+Tcl MIME includes an implementation of the smtp package.
+</p>
+
+<h4><a name="anchor2">1.1</a>&nbsp;Requirements</h4>
+
+<p>
+This package requires:
+
+<ul class="text">
+
+<li>
+<a href="http://www.scriptics.com/software/8.1.html">Tcl/Tk version 8.0.3</a>
+or later
+</li>
+</ul>
+</p>
+<p>
+In addition, this package requires one of the following:
+
+<ul class="text">
+<li>
+<a href="http://www.oche.de/~akupries/soft/trf/">Trf version 2.0p5</a> or later
+</li>
+<li>
+<a href="http://dev.ajubasolutions.com/software/tcllib/">base 64
+version 2.0</a> or later (included with tcllib)
+</li>
+</ul>
+</p>
+<p>
+If it is available, Trf will be used to provide better performance;
+if not, Tcl-only equivalent functions, based on the base64 package, are used.
+</p>
+
+<h4><a name="anchor3">1.2</a>&nbsp;Copyrights</h4>
+
+<p>
+(c) 1999-2000 Marshall T. Rose
+</p>
+
+<p>
+Hold harmless the author, and any lawful use is allowed.
+</p>
+
+<a name="anchor4"><br><hr size="1" shade="0"></a>
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<h3>2.&nbsp;SYNTAX</h3>
+
+<p>
+<a href="#mime_initialize">mime::initialize</a>
+returns a token.
+Parameters:
+</p>
+</font><pre> ?-canonical type/subtype
+ ?-param {key value}?...
+ ?-encoding value?
+ ?-header {key value}?... ?
+ (-file name | -string value | -parts {token1 ... tokenN})
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+<a href="#mime_finalize">mime::finalize</a> returns
+an empty string.
+Parameters:
+</p>
+</font><pre> token ?-subordinates "all" | "dynamic" | "none"?
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+<a href="#mime_getproperty">mime::getproperty</a>
+returns a string or a list of strings.
+Parameters:
+</p>
+</font><pre> token ?property | -names?
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+<a href="#mime_getheader">mime::getheader</a> returns
+a list of strings.
+Parameters:
+</p>
+</font><pre> token ?key | -names?
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+<a href="#mime_setheader">mime::setheader</a> returns
+a list of strings.
+Parameters:
+</p>
+</font><pre> token key value ?-mode "write" | "append" | "delete"?
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+<a href="#mime_getbody">mime::getbody</a> returns a string.
+Parameters:
+</p>
+</font><pre> ?-command callback ?-blocksize octets? ?
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+<a href="#mime_copymessage">mime::copymessage</a>
+returns an empty string.
+Parameters:
+</p>
+</font><pre> token channel
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+<a href="#mime_buildmessage">mime::buildmessage</a>
+returns a string.
+Parameters:
+</p>
+</font><pre> token
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+<a href="#smtp_sendmessage">smtp::sendmessage</a>
+returns a list.
+Parameters:
+</p>
+</font><pre> token ?-servers list? ?-ports list?
+ ?-queue boolean? ?-atleastone boolean?
+ ?-originator string? ?-recipients string?
+ ?-header {key value}?...
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+<a href="#mime_parseaddress">mime::parseaddress</a>
+returns a list of serialized arrays.
+Parameters:
+</p>
+</font><pre> string
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+<a href="#mime_parsedatetime">mime::parsedatetime</a>
+returns a string.
+Parameters:
+</p>
+</font><pre> [string | -now] property
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+<a href="#mime_mapencoding">mime::mapencoding</a>
+returns a string.
+Parameters:
+</p>
+</font><pre> encoding_name
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+<a href="#mime_reversemapencoding">mime::reversemapencoding</a>
+returns a string.
+Parameters:
+</p>
+</font><pre> mime_charset
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<a name="anchor5"><br><hr size="1" shade="0"></a>
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<h3>3.&nbsp;SEMANTICS</h3>
+
+<h4><a name="mime_initialize">3.1</a>&nbsp;mime::initialize</h4>
+
+<p>
+mime::initialize creates a MIME part:
+
+<ul class="text">
+
+<li>
+If the -canonical option is present,
+then the body is in canonical (raw) form and is found by consulting
+either the -file, -string, or -part option.
+<br>
+<br>
+
+In addition,
+both the -param and -header options may occur zero or more times to
+specify "Content-Type" parameters (e.g., "charset")
+and header keyword/values (e.g., "Content-Disposition"),
+respectively.
+<br>
+<br>
+
+Also, -encoding, if present,
+specifies the "Content-Transfer-Encoding" when copying the body.
+</li>
+
+<li>
+If the -canonical option is not present,
+then the MIME part contained in either the -file or the -string option
+is parsed,
+dynamically generating subordinates as appropriate.
+</li>
+
+</ul>
+
+</p>
+
+<h4><a name="mime_finalize">3.2</a>&nbsp;mime::finalize</h4>
+
+<p>
+mime::finalize destroys a MIME part.
+</p>
+
+<p>
+If the -subordinates option is present,
+it specifies which subordinates should also be destroyed.
+The default value is "dynamic".
+</p>
+
+<h4><a name="mime_getproperty">3.3</a>&nbsp;mime::getproperty</h4>
+
+<p>
+mime::getproperty returns the properties of a MIME part.
+</p>
+
+<p>
+The properties are:
+</p>
+</font><pre>
+ property value
+ ======== =====
+ content the type/subtype describing the content
+ encoding the "Content-Transfer-Encoding"
+ params a list of "Content-Type" parameters
+ parts a list of tokens for the part's subordinates
+ size the approximate size of the content (unencoded)
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+The "parts" property is present only if the MIME part has
+subordinates.
+</p>
+
+<p>
+If mime::getproperty is invoked with the name of a specific property,
+then the corresponding value is returned;
+instead,
+if -names is specified,
+a list of all properties is returned;
+otherwise,
+a serialized array of properties and values is returned.
+</p>
+
+<h4><a name="mime_getheader">3.4</a>&nbsp;mime::getheader</h4>
+
+<p>
+mime::getheader returns the header of a MIME part.
+</p>
+
+<p>
+A header consists of zero or more key/value pairs.
+Each value is a list containing one or more strings.
+</p>
+
+<p>
+If mime::getheader is invoked with the name of a specific key,
+then a list containing the corresponding value(s) is returned;
+instead,
+if -names is specified,
+a list of all keys is returned;
+otherwise,
+a serialized array of keys and values is returned.
+Note that when a key is specified (e.g., "Subject"),
+the list returned usually contains exactly one string;
+however,
+some keys (e.g., "Received") often occur more than once in the header,
+accordingly the list returned usually contains more than one string.
+</p>
+
+<h4><a name="mime_setheader">3.5</a>&nbsp;mime::setheader</h4>
+
+<p>
+mime::setheader writes, appends to, or deletes the value associated
+with a key in the header.
+</p>
+
+<p>
+The value for -mode is one of:
+
+<blockquote class="text"><dl>
+
+<dt> write:</dt>
+<dd>
+ the key/value is either created or
+overwritten (the default);
+</dd>
+
+<dt> append:</dt>
+<dd>
+ a new value is appended for the key
+(creating it as necessary); or,
+</dd>
+
+<dt> delete:</dt>
+<dd>
+ all values associated with the key are removed
+(the "value" parameter is ignored).
+</dd>
+
+</dl></blockquote>
+
+</p>
+
+<p>
+Regardless,
+mime::setheader returns the previous value associated with the key.
+</p>
+
+<h4><a name="mime_getbody">3.6</a>&nbsp;mime::getbody</h4>
+
+<p>
+mime::getbody returns the body of a leaf MIME part in canonical form.
+</p>
+
+<p>
+If the -command option is present,
+then it is repeatedly invoked with a fragment of the body as this:
+</p>
+</font><pre>
+ uplevel #0 $callback [list "data" $fragment]
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+(The -blocksize option,
+if present,
+specifies the maximum size of each fragment passed to the
+callback.)
+</p>
+
+<p>
+When the end of the body is reached,
+the callback is invoked as:
+</p>
+</font><pre>
+ uplevel #0 $callback "end"
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+Alternatively,
+if an error occurs,
+the callback is invoked as:
+</p>
+</font><pre>
+ uplevel #0 $callback [list "error" reason]
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+Regardless,
+the return value of the final invocation of the callback is propagated
+upwards by mime::getbody.
+</p>
+
+<p>
+If the -command option is absent,
+then the return value of mime::getbody is a string containing the MIME
+part's entire body.
+</p>
+
+<h4><a name="mime_copymessage">3.7</a>&nbsp;mime::copymessage</h4>
+
+<p>
+mime::copymessage copies the MIME part to the specified channel.
+</p>
+
+<p>
+mime::copymessage operates synchronously,
+and uses fileevent to allow asynchronous operations to proceed
+independently.
+</p>
+
+<h4><a name="mime_buildmessage">3.7</a>&nbsp;mime::buildmessage</h4>
+
+<p>
+mime::buildmessage returns the MIME part as a string. It is similar
+to mime::copymessage, only it returns the data as a return string
+instead of writing to a channel.
+</p>
+
+
+<h4><a name="smtp_sendmessage">3.8</a>&nbsp;smtp::sendmessage</h4>
+
+<p>
+smtp::sendmessage sends a MIME part to an SMTP server.
+(Note that this procedure is in the "smtp" package,
+not the "mime" package.)
+</p>
+
+<p>
+The options are:
+
+<blockquote class="text"><dl>
+
+<dt> -servers:</dt>
+<dd>
+a list of SMTP servers
+(the default is "localhost");
+</dd>
+
+<dt> -ports:</dt>
+<dd>
+a list of SMTP ports
+(the default is 25);
+</dd>
+
+<dt> -queue:</dt>
+<dd>
+indicates that the SMTP server should be
+asked to queue the message for later processing;
+</dd>
+
+<dt> -atleastone:</dt>
+<dd>
+indicates that the SMTP server must find
+at least one recipient acceptable for the message to be sent;
+</dd>
+
+<dt> -originator:</dt>
+<dd>
+a string containing an 822-style address
+specification
+(if present the header isn't examined for an originator address);
+</dd>
+
+<dt> -recipients:</dt>
+<dd>
+a string containing one or more 822-style
+address specifications
+(if present the header isn't examined for recipient addresses); and,
+</dd>
+
+<dt> -header:</dt>
+<dd>
+a keyword/value pairing
+(may occur zero or more times).
+</dd>
+
+</dl></blockquote>
+
+</p>
+
+<p>
+If the -originator option is not present,
+the originator address is taken from "From" (or "Resent-From");
+similarly,
+if the -recipients option is not present,
+recipient addresses are taken from "To", "cc", and "Bcc" (or
+"Resent-To", and so on).
+Note that the header key/values supplied by the "-header" option
+(not those present in the MIME part)
+are consulted.
+Regardless,
+header key/values are added to the outgoing message as necessary to
+ensure that a valid 822-style message is sent.
+</p>
+
+<p>
+smtp::sendmessage returns a list indicating which recipients were
+unacceptable to the SMTP server.
+Each element of the list is another list,
+containing the address, an SMTP error code, and a textual diagnostic.
+Depending on the -atleastone option and the intended recipients,,
+a non-empty list may still indicate that the message was accepted by
+the server.
+</p>
+
+<h4><a name="mime_parseaddress">3.9</a>&nbsp;mime::parseaddress</h4>
+
+<p>
+mime::parseaddr takes a string containing one or more 822-style
+address specifications and returns a list of serialized arrays,
+one element for each address specified in the argument.
+</p>
+
+<p>
+Each serialized array contains these properties:
+</p>
+</font><pre>
+ property value
+ ======== =====
+ address local@domain
+ comment 822-style comment
+ domain the domain part (rhs)
+ error non-empty on a parse error
+ group this address begins a group
+ friendly user-friendly rendering
+ local the local part (lhs)
+ memberP this address belongs to a group
+ phrase the phrase part
+ proper 822-style address specification
+ route 822-style route specification (obsolete)
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<p>
+Note that one or more of these properties may be empty.
+</p>
+
+<h4><a name="mime_parsedatetime">3.10</a>&nbsp;mime::parsedatetime</h4>
+
+<p>
+mime::parsedatetime takes a string containing an 822-style
+date-time specification and returns the specified property.
+</p>
+
+<p>
+The list of properties and their ranges are:
+</p>
+</font><pre>
+ property range
+ ======== =====
+ hour 0 .. 23
+ lmonth January, February, ..., December
+ lweekday Sunday, Monday, ... Saturday
+ mday 1 .. 31
+ min 0 .. 59
+ mon 1 .. 12
+ month Jan, Feb, ..., Dec
+ proper 822-style date-time specification
+ rclock elapsed seconds between then and now
+ sec 0 .. 59
+ wday 0 .. 6 (Sun .. Mon)
+ weekday Sun, Mon, ..., Sat
+ yday 1 .. 366
+ year 1900 ...
+ zone -720 .. 720 (minutes east of GMT)
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+
+<h4><a name="mime_mapencoding">3.10</a>&nbsp;mime::mapencoding</h4>
+
+<p>
+mime::mapencoding takes a string containing the name of a
+tcl encoding (see [encoding names]) and returns the MIME
+charset name for that encoding (or "" if the charset name
+is unknown).
+</p>
+
+<h4><a name="mime_reversemapencoding">3.10</a>&nbsp;mime::reversemapencoding</h4>
+
+<p>
+mime::reversemapencoding takes a string containing the name of a
+MIME charset tcl encoding (see [encoding names]) and returns the MIME
+charset name for that encoding (or "" if no known tcl encoding maps to
+the mime charset type).
+</p>
+
+<a name="anchor6"><br><hr size="1" shade="0"></a>
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<h3>4.&nbsp;EXAMPLES</h3>
+</font><pre>
+package require mime 1.0
+package require smtp 1.0
+
+
+# create an image
+
+set imageT [mime::initialize -canonical image/gif \
+ -file logo.gif]
+
+
+# parse a message
+
+set messageT [mime::initialize -file example.msg]
+
+
+# recursively traverse a message looking for primary recipients
+
+proc traverse {token} {
+ set result ""
+
+# depth-first search
+ if {![catch { mime::getproperty $token parts } parts]} {
+ foreach part $parts {
+ set result [concat $result [traverse $part]]
+ }
+ }
+
+# one value for each line occuring in the header
+ foreach value [mime::getheader $token To] {
+ foreach addr [mime::parseaddress $value] {
+ catch { unset aprops }
+ array set aprops $addr
+ lappend result $aprops(address)
+ }
+ }
+
+ return $result
+}
+
+
+# create a multipart containing both, and a timestamp
+
+set multiT [mime::initialize -canonical multipart/mixed
+ -parts [list $imageT $messageT]]
+
+
+
+
+# send it to some friends
+
+smtp::sendmessage $multiT \
+ -header [list From "Marshall Rose &lt;mrose@dbc.mtview.ca.us>"] \
+ -header [list To "Andreas Kupries &lt;a.kupries@westend.com>"] \
+ -header [list cc "dnew@messagemedia.com (Darren New)"] \
+ -header [list Subject "test message..."]
+
+
+# clean everything up
+
+mime::finalize $multiT -subordinates all
+</pre><font face="verdana, helvetica, arial, sans-serif" size="2">
+<a name="rfc.references"><br><hr size="1" shade="0"></a>
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<h3>
+References</h3>
+<table width="99%" border="0">
+<tr><td class="author-text" valign="top"><b><a name="RFC2045">[1]</a></b></td>
+<td class="author-text"><a href="mailto:ned@innosoft.com">Freed, N.</a> and <a href="mailto:nsb@messagemedia.com">N.S. Borenstein</a>, "<a href="http://info.internet.isi.edu/in-notes/rfc/files/rfc2045.txt">Multipurpose Internet Mail Extensions (MIME)
+Part One: Format of Internet Message Bodies</a>", RFC 2045, November 1996.</td></tr>
+<tr><td class="author-text" valign="top"><b><a name="RFC2046">[2]</a></b></td>
+<td class="author-text"><a href="mailto:ned@innosoft.com">Freed, N.</a> and <a href="mailto:nsb@messagemedia.com">N.S. Borenstein</a>, "<a href="http://info.internet.isi.edu/in-notes/rfc/files/rfc2046.txt">Multipurpose Internet Mail Extensions (MIME)
+Part Two: Media Types</a>", RFC 2046, November 1995.</td></tr>
+<tr><td class="author-text" valign="top"><b><a name="RFC822">[3]</a></b></td>
+<td class="author-text"><a href="mailto:DCrocker@UDel-Relay">Crocker, D.</a>, "<a href="http://info.internet.isi.edu/in-notes/rfc/files/rfc822.txt">Standard for the format of ARPA Internet Text Messages</a>", RFC 822, STD 11, August 1982.</td></tr>
+</table>
+
+<a name="rfc.authors"><br><hr size="1" shade="0"></a>
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<h3>Author's Address</h3>
+<table width="99%" border="0" cellpadding="0" cellspacing="0">
+<tr><td class="author-text">&nbsp;</td>
+<td class="author-text">Marshall T. Rose</td></tr>
+<tr><td class="author-text">&nbsp;</td>
+<td class="author-text">Dover Beach Consulting, Inc.</td></tr>
+<tr><td class="author-text">&nbsp;</td>
+<td class="author-text">POB 255268</td></tr>
+<tr><td class="author-text">&nbsp;</td>
+<td class="author-text">Sacramento, CA 95865-5268</td></tr>
+<tr><td class="author-text">&nbsp;</td>
+<td class="author-text">US</td></tr>
+<tr><td class="author" align="right">Phone:&nbsp;</td>
+<td class="author-text">+1 916 483 8878</td></tr>
+<tr><td class="author" align="right">Fax:&nbsp;</td>
+<td class="author-text">+1 916 483 8848</td></tr>
+<tr><td class="author" align="right">EMail:&nbsp;</td>
+<td class="author-text"><a href="mailto:mrose@dbc.mtview.ca.us">mrose@dbc.mtview.ca.us</a></td></tr>
+</table>
+
+<a name="anchor7"><br><hr size="1" shade="0"></a>
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<h3>Appendix A.&nbsp;TODO List</h3>
+
+<p>
+
+<blockquote class="text"><dl>
+
+<dt>mime::initialize</dt>
+<dd>
+
+<ul class="text">
+
+<li>
+well-defined errorCode values
+</li>
+
+<li>
+catch nested errors when processing a multipart
+</li>
+
+</ul>
+
+</dd>
+
+</dl></blockquote>
+
+</p>
+
+<a name="anchor8"><br><hr size="1" shade="0"></a>
+<table border="0" cellpadding="0" cellspacing="2" width="30" height="15" align="right"><tr><td bgcolor="#990000" align="center" width="30" height="15"><a href="#toc" CLASS="link2"><font face="monaco, MS Sans Serif" color="#ffffff" size="1"><b>&nbsp;TOC&nbsp;</b></font></a><br></td></tr></table>
+<h3>Appendix B.&nbsp;Acknowledgements</h3>
+
+<p>
+This package is influenced by the safe-tcl package
+(Borenstein and Rose, circa 1993),
+and also by <a href="mailto:dnew@messagemedia.com">Darren New</a>'s
+unpublished package of 1999.
+</p>
+
+<p>
+This package makes use of
+<a href="mailto:a.kupries@westend.com">Andreas Kupries</a>'s
+excellent Trf package.
+</p>
+</font></body></html>
diff --git a/tcllib/modules/mime/README.txt b/tcllib/modules/mime/README.txt
new file mode 100644
index 0000000..25d2694
--- /dev/null
+++ b/tcllib/modules/mime/README.txt
@@ -0,0 +1,804 @@
+
+
+The README file M.T. Rose
+ Dover Beach Consulting, Inc.
+ February 22, 2000
+
+
+ Tcl MIME
+
+
+Abstract
+
+ Tcl MIME generates and parses MIME body parts.
+
+Table of Contents
+
+ 1. SYNOPSIS . . . . . . . . . . . . . . . . . . . . . . . . . . 2
+ 1.1 Requirements . . . . . . . . . . . . . . . . . . . . . . . . 3
+ 1.2 Copyrights . . . . . . . . . . . . . . . . . . . . . . . . . 3
+ 2. SYNTAX . . . . . . . . . . . . . . . . . . . . . . . . . . . 4
+ 3. SEMANTICS . . . . . . . . . . . . . . . . . . . . . . . . . 5
+ 3.1 mime::initialize . . . . . . . . . . . . . . . . . . . . . . 5
+ 3.2 mime::finalize . . . . . . . . . . . . . . . . . . . . . . . 5
+ 3.3 mime::getproperty . . . . . . . . . . . . . . . . . . . . . 5
+ 3.4 mime::getheader . . . . . . . . . . . . . . . . . . . . . . 6
+ 3.5 mime::setheader . . . . . . . . . . . . . . . . . . . . . . 6
+ 3.6 mime::getbody . . . . . . . . . . . . . . . . . . . . . . . 6
+ 3.7 mime::copymessage . . . . . . . . . . . . . . . . . . . . . 7
+ 3.8 mime::buildmessage . . . . . . . . . . . . . . . . . . . . . 7
+ 3.9 smtp::sendmessage . . . . . . . . . . . . . . . . . . . . . 7
+ 3.10 mime::parseaddress . . . . . . . . . . . . . . . . . . . . . 8
+ 3.11 mime::parsedatetime . . . . . . . . . . . . . . . . . . . . 9
+ 3.12 mime::mapencoding . . . . . . . . . . . . . . . . . . . . . 9
+ 3.13 mime::reversemapencoding . . . . . . . . . . . . . . . . . . 9
+
+ 4. EXAMPLES . . . . . . . . . . . . . . . . . . . . . . . . . . 10
+ References . . . . . . . . . . . . . . . . . . . . . . . . . 12
+ Author's Address . . . . . . . . . . . . . . . . . . . . . . 12
+ A. TODO List . . . . . . . . . . . . . . . . . . . . . . . . . 13
+ B. Acknowledgements . . . . . . . . . . . . . . . . . . . . . . 14
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Rose [Page 1]
+
+README Tcl MIME February 2000
+
+
+1. SYNOPSIS
+
+ package provide mime 1.2
+ package provide smtp 1.2
+
+ Tcl MIME is an implementation of a Tcl package that generates and
+ parses MIME[1] body parts.
+
+ Each MIME part consists of a header (zero or more key/value pairs),
+ an empty line, and a structured body. A MIME part is either a "leaf"
+ or has (zero or more) subordinates.
+
+ MIME defines four keys that may appear in the headers:
+
+ Content-Type: describes the data contained in the body ("the
+ content");
+
+ Content-Transfer-Encoding: describes how the content is encoded
+ for transmission in an ASCII stream;
+
+ Content-Description: a textual description of the content; and,
+
+ Content-ID: a globally-unique identifier for the content.
+
+ Consult [2] for a list of standard content types. Further, consult
+ [3] for a list of several other header keys (e.g., "To", "cc", etc.)
+
+ A simple example might be:
+
+ Date: Sun, 04 July 1999 10:38:25 -0600
+ From: Marshall Rose <mrose@dbc.mtview.ca.us>
+ To: Andreas Kupries <a.kupries@westend.com>
+ cc: dnew@messagemedia.com (Darren New)
+ MIME-Version: 1.0
+ Content-Type: text/plain; charset="us-ascii"
+ Content-Description: a simple example
+ Content-ID: <4294407315.931384918.1@dbc.mtview.ca.us>
+
+ Here is the body. In this case, simply plain text.
+
+ In addition to an implementation of the mime package, Tcl MIME
+ includes an implementation of the smtp package.
+
+
+
+
+
+
+
+
+
+Rose [Page 2]
+
+README Tcl MIME February 2000
+
+
+1.1 Requirements
+
+ This package requires:
+
+ o Tcl/Tk version 8.0.3[4] or later
+
+ In addition, this package requires one of the following:
+
+ o Trf version 2.0p5[5] or later
+
+ o base64 version 2.0 or later (included with tcllib)
+
+ If it is available, Trf will be used to provide better performance;
+ if not, Tcl-only equivalent functions, based on the base64 package,
+ are used.
+
+1.2 Copyrights
+
+ (c) 1999-2000 Marshall T. Rose
+
+ Hold harmless the author, and any lawful use is allowed.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Rose [Page 3]
+
+README Tcl MIME February 2000
+
+
+2. SYNTAX
+
+ mime::initialize (Section 3.1) returns a token. Parameters:
+ ?-canonical type/subtype
+ ?-param {key value}?...
+ ?-encoding value?
+ ?-header {key value}?... ?
+ (-file name | -string value | -parts {token1 ... tokenN})
+
+ mime::finalize (Section 3.2) returns an empty string. Parameters:
+ token ?-subordinates "all" | "dynamic" | "none"?
+
+ mime::getproperty (Section 3.3) returns a string or a list of
+ strings. Parameters:
+ token ?property | -names?
+
+ mime::getheader (Section 3.4) returns a list of strings. Parameters:
+ token ?key | -names?
+
+ mime::setheader (Section 3.5) returns a list of strings. Parameters:
+ token key value ?-mode "write" | "append" | "delete"?
+
+ mime::getbody (Section 3.6) returns a string. Parameters:
+ ?-command callback ?-blocksize octets? ?
+
+ mime::copymessage (Section 3.7) returns an empty string. Parameters:
+ token channel
+
+ mime::buildmessage (Section 3.7) returns a string. Parameters:
+ token
+
+ smtp::sendmessage (Section 3.8) returns a list. Parameters:
+ token ?-servers list? ?-ports list?
+ ?-queue boolean? ?-atleastone boolean?
+ ?-originator string? ?-recipients string?
+ ?-header {key value}?...
+
+ mime::parseaddress (Section 3.9) returns a list of serialized
+ arrays. Parameters:
+ string
+
+ mime::parsedatetime (Section 3.10) returns a string. Parameters:
+ [string | -now] property
+
+ mime::mapencoding (Section 3.10) returns a string. Parameters:
+ encoding_name
+
+ mime::reversemapencoding (Section 3.10) returns a string. Parameters:
+ charset_type
+
+
+
+Rose [Page 4]
+
+README Tcl MIME February 2000
+
+
+3. SEMANTICS
+
+3.1 mime::initialize
+
+ mime::initialize creates a MIME part:
+
+ o If the -canonical option is present, then the body is in
+ canonical (raw) form and is found by consulting either the -file,
+ -string, or -part option.
+
+ In addition, both the -param and -header options may occur zero
+ or more times to specify "Content-Type" parameters (e.g.,
+ "charset") and header keyword/values (e.g.,
+ "Content-Disposition"), respectively.
+
+ Also, -encoding, if present, specifies the
+ "Content-Transfer-Encoding" when copying the body.
+
+ o If the -canonical option is not present, then the MIME part
+ contained in either the -file or the -string option is parsed,
+ dynamically generating subordinates as appropriate.
+
+3.2 mime::finalize
+
+ mime::finalize destroys a MIME part.
+
+ If the -subordinates option is present, it specifies which
+ subordinates should also be destroyed. The default value is
+ "dynamic".
+
+3.3 mime::getproperty
+
+ mime::getproperty returns the properties of a MIME part.
+
+ The properties are:
+
+ property value
+ ======== =====
+ content the type/subtype describing the content
+ encoding the "Content-Transfer-Encoding"
+ params a list of "Content-Type" parameters
+ parts a list of tokens for the part's subordinates
+ size the approximate size of the content (unencoded)
+
+ The "parts" property is present only if the MIME part has
+ subordinates.
+
+ If mime::getproperty is invoked with the name of a specific
+ property, then the corresponding value is returned; instead, if
+
+
+Rose [Page 5]
+
+README Tcl MIME February 2000
+
+
+ -names is specified, a list of all properties is returned;
+ otherwise, a serialized array of properties and values is returned.
+
+3.4 mime::getheader
+
+ mime::getheader returns the header of a MIME part.
+
+ A header consists of zero or more key/value pairs. Each value is a
+ list containing one or more strings.
+
+ If mime::getheader is invoked with the name of a specific key, then
+ a list containing the corresponding value(s) is returned; instead,
+ if -names is specified, a list of all keys is returned; otherwise, a
+ serialized array of keys and values is returned. Note that when a
+ key is specified (e.g., "Subject"), the list returned usually
+ contains exactly one string; however, some keys (e.g., "Received")
+ often occur more than once in the header, accordingly the list
+ returned usually contains more than one string.
+
+3.5 mime::setheader
+
+ mime::setheader writes, appends to, or deletes the value associated
+ with a key in the header.
+
+ The value for -mode is one of:
+
+ write: the key/value is either created or overwritten (the
+ default);
+
+ append: a new value is appended for the key (creating it as
+ necessary); or,
+
+ delete: all values associated with the key are removed (the
+ "value" parameter is ignored).
+
+ Regardless, mime::setheader returns the previous value associated
+ with the key.
+
+3.6 mime::getbody
+
+ mime::getbody returns the body of a leaf MIME part in canonical form.
+
+ If the -command option is present, then it is repeatedly invoked
+ with a fragment of the body as this:
+
+ uplevel #0 $callback [list "data" $fragment]
+
+ (The -blocksize option, if present, specifies the maximum size of
+ each fragment passed to the callback.)
+
+
+Rose [Page 6]
+
+README Tcl MIME February 2000
+
+
+ When the end of the body is reached, the callback is invoked as:
+
+ uplevel #0 $callback "end"
+
+ Alternatively, if an error occurs, the callback is invoked as:
+
+ uplevel #0 $callback [list "error" reason]
+
+ Regardless, the return value of the final invocation of the callback
+ is propagated upwards by mime::getbody.
+
+ If the -command option is absent, then the return value of
+ mime::getbody is a string containing the MIME part's entire body.
+
+3.7 mime::copymessage
+
+ mime::copymessage copies the MIME part to the specified channel.
+
+ mime::copymessage operates synchronously, and uses fileevent to
+ allow asynchronous operations to proceed independently.
+
+3.7 mime::buildmessage
+
+ mime::buildmessage returns the MIME part as a string. It is similar
+ to mime::copymessage, only it returns the data as a return string
+ instead of writing to a channel.
+
+3.8 smtp::sendmessage
+
+ smtp::sendmessage sends a MIME part to an SMTP server. (Note that
+ this procedure is in the "smtp" package, not the "mime" package.)
+
+ The options are:
+
+ -servers: a list of SMTP servers (the default is "localhost");
+
+ -ports: a list of SMTP ports (the default is 25)
+
+ -queue: indicates that the SMTP server should be asked to queue
+ the message for later processing;
+
+ -atleastone: indicates that the SMTP server must find at least
+ one recipient acceptable for the message to be sent;
+
+ -originator: a string containing an 822-style address
+ specification (if present the header isn't examined for an
+ originator address);
+
+ -recipients: a string containing one or more 822-style address
+ specifications (if present the header isn't examined for
+ recipient addresses); and,
+
+ -header: a keyword/value pairing (may occur zero or more times).
+
+ If the -originator option is not present, the originator address is
+ taken from "From" (or "Resent-From"); similarly, if the -recipients
+ option is not present, recipient addresses are taken from "To",
+
+
+Rose [Page 7]
+
+README Tcl MIME February 2000
+
+
+ "cc", and "Bcc" (or "Resent-To", and so on). Note that the header
+ key/values supplied by the "-header" option (not those present in
+ the MIME part) are consulted. Regardless, header key/values are
+ added to the outgoing message as necessary to ensure that a valid
+ 822-style message is sent.
+
+ smtp::sendmessage returns a list indicating which recipients were
+ unacceptable to the SMTP server. Each element of the list is another
+ list, containing the address, an SMTP error code, and a textual
+ diagnostic. Depending on the -atleastone option and the intended
+ recipients,, a non-empty list may still indicate that the message
+ was accepted by the server.
+
+3.9 mime::parseaddress
+
+ mime::parseaddr takes a string containing one or more 822-style
+ address specifications and returns a list of serialized arrays, one
+ element for each address specified in the argument.
+
+ Each serialized array contains these properties:
+
+ property value
+ ======== =====
+ address local@domain
+ comment 822-style comment
+ domain the domain part (rhs)
+ error non-empty on a parse error
+ group this address begins a group
+ friendly user-friendly rendering
+ local the local part (lhs)
+ memberP this address belongs to a group
+ phrase the phrase part
+ proper 822-style address specification
+ route 822-style route specification (obsolete)
+
+ Note that one or more of these properties may be empty.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Rose [Page 8]
+
+README Tcl MIME February 2000
+
+
+3.10 mime::parsedatetime
+
+ mime::parsedatetime takes a string containing an 822-style date-time
+ specification and returns the specified property.
+
+ The list of properties and their ranges are:
+
+ property range
+ ======== =====
+ hour 0 .. 23
+ lmonth January, February, ..., December
+ lweekday Sunday, Monday, ... Saturday
+ mday 1 .. 31
+ min 0 .. 59
+ mon 1 .. 12
+ month Jan, Feb, ..., Dec
+ proper 822-style date-time specification
+ rclock elapsed seconds between then and now
+ sec 0 .. 59
+ wday 0 .. 6 (Sun .. Mon)
+ weekday Sun, Mon, ..., Sat
+ yday 1 .. 366
+ year 1900 ...
+ zone -720 .. 720 (minutes east of GMT)
+
+3.10 mime::mapencoding
+
+ mime::mapencodings maps tcl encodings onto the proper names for their
+ MIME charset type. This is only done for encodings whose charset types
+ were known. The remaining encodings return "" for now.
+
+3.10 mime::reversemapencoding
+
+ mime::reversemapencoding maps MIME charset types onto tcl encoding names.
+ Those that are unknown return "".
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Rose [Page 9]
+
+README Tcl MIME February 2000
+
+
+4. EXAMPLES
+
+ package require mime 1.0
+ package require smtp 1.0
+
+
+ # create an image
+
+ set imageT [mime::initialize -canonical image/gif \
+ -file logo.gif]
+
+
+ # parse a message
+
+ set messageT [mime::initialize -file example.msg]
+
+
+ # recursively traverse a message looking for primary recipients
+
+ proc traverse {token} {
+ set result ""
+
+ # depth-first search
+ if {![catch { mime::getproperty $token parts } parts]} {
+ foreach part $parts {
+ set result [concat $result [traverse $part]]
+ }
+ }
+
+ # one value for each line occuring in the header
+ foreach value [mime::getheader $token To] {
+ foreach addr [mime::parseaddress $value] {
+ catch { unset aprops }
+ array set aprops $addr
+ lappend result $aprops(address)
+ }
+ }
+
+ return $result
+ }
+
+
+ # create a multipart containing both, and a timestamp
+
+ set multiT [mime::initialize -canonical multipart/mixed
+ -parts [list $imageT $messageT]]
+
+
+
+
+
+Rose [Page 10]
+
+README Tcl MIME February 2000
+
+
+ # send it to some friends
+
+ smtp::sendmessage $multiT \
+ -header [list From "Marshall Rose <mrose@dbc.mtview.ca.us>"] \
+ -header [list To "Andreas Kupries <a.kupries@westend.com>"] \
+ -header [list cc "dnew@messagemedia.com (Darren New)"] \
+ -header [list Subject "test message..."]
+
+
+ # clean everything up
+
+ mime::finalize $multiT -subordinates all
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Rose [Page 11]
+
+README Tcl MIME February 2000
+
+
+References
+
+ [1] Freed, N. and N.S. Borenstein, "Multipurpose Internet Mail
+ Extensions (MIME) Part One: Format of Internet Message Bodies",
+ RFC 2045, November 1996.
+
+ [2] Freed, N. and N.S. Borenstein, "Multipurpose Internet Mail
+ Extensions (MIME) Part Two: Media Types", RFC 2046, November
+ 1995.
+
+ [3] Crocker, D., "Standard for the format of ARPA Internet Text
+ Messages", RFC 822, STD 11, August 1982.
+
+ [4] http://www.scriptics.com/software/8.1.html
+
+ [5] http://www.oche.de/~akupries/soft/trf/
+
+ [6] mailto:dnew@messagemedia.com
+
+ [7] mailto:a.kupries@westend.com
+
+
+Author's Address
+
+ Marshall T. Rose
+ Dover Beach Consulting, Inc.
+ POB 255268
+ Sacramento, CA 95865-5268
+ US
+
+ Phone: +1 916 483 8878
+ Fax: +1 916 483 8848
+ EMail: mrose@dbc.mtview.ca.us
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Rose [Page 12]
+
+README Tcl MIME February 2000
+
+
+Appendix A. TODO List
+
+ mime::initialize
+
+ * well-defined errorCode values
+
+ * catch nested errors when processing a multipart
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Rose [Page 13]
+
+README Tcl MIME February 2000
+
+
+Appendix B. Acknowledgements
+
+ This package is influenced by the safe-tcl package (Borenstein and
+ Rose, circa 1993), and also by Darren New[6]'s unpublished package
+ of 1999.
+
+ This package makes use of Andreas Kupries[7]'s excellent Trf package.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+Rose [Page 14]
+
diff --git a/tcllib/modules/mime/README.xml b/tcllib/modules/mime/README.xml
new file mode 100644
index 0000000..ed30a89
--- /dev/null
+++ b/tcllib/modules/mime/README.xml
@@ -0,0 +1,660 @@
+<?xml version="1.0"?>
+<!DOCTYPE rfc SYSTEM "rfc2629.dtd">
+
+<?rfc compact="no"?>
+<?rfc toc="yes"?>
+<?rfc private="The README file"?>
+<?rfc header="README"?>
+
+<rfc>
+<front>
+<title>Tcl MIME</title>
+
+<author initials="M.T." surname="Rose" fullname="Marshall T. Rose">
+<organization>Dover Beach Consulting, Inc.</organization>
+<address>
+<postal>
+<street>POB 255268</street>
+<city>Sacramento</city> <region>CA</region> <code>95865-5268</code>
+<country>US</country>
+</postal>
+<phone>+1 916 483 8878</phone>
+<facsimile>+1 916 483 8848</facsimile>
+<email>mrose@dbc.mtview.ca.us</email>
+</address>
+</author>
+
+<date month="February" year="2000" />
+
+<abstract><t>Tcl MIME generates and parses MIME body parts.</t></abstract>
+</front>
+
+<middle>
+
+<section title="SYNOPSIS">
+<figure><artwork><![CDATA[
+ package provide mime 1.2
+ package provide smtp 1.2
+]]></artwork></figure>
+
+<t>Tcl MIME is an implementation of a Tcl package that generates and
+parses <xref target="RFC2045">MIME</xref> body parts.</t>
+
+<t>Each MIME part consists of a header
+(zero or more key/value pairs),
+an empty line,
+and a structured body.
+A MIME part is either a "leaf" or has (zero or more) subordinates.</t>
+
+<t>MIME defines four keys that may appear in the headers:
+<list style="hanging">
+<t hangText=" Content-Type:">describes the data contained in the body
+("the content");</t>
+
+<t hangText=" Content-Transfer-Encoding:">describes how the content is
+encoded for transmission in an ASCII stream;</t>
+
+<t hangText=" Content-Description:">a textual description of the
+content; and,</t>
+
+<t hangText=" Content-ID:">a globally-unique identifier for the
+content.</t>
+</list></t>
+
+<t>Consult <xref target="RFC2046" /> for a list of standard content types.
+Further,
+consult <xref target="RFC822" /> for a list of several other header keys
+(e.g., "To", "cc", etc.)</t>
+
+<figure>
+<preamble>A simple example might be:</preamble>
+<artwork><![CDATA[
+ Date: Sun, 04 July 1999 10:38:25 -0600
+ From: Marshall Rose <mrose@dbc.mtview.ca.us>
+ To: Andreas Kupries <a.kupries@westend.com>
+ cc: dnew@messagemedia.com (Darren New)
+ MIME-Version: 1.0
+ Content-Type: text/plain; charset="us-ascii"
+ Content-Description: a simple example
+ Content-ID: <4294407315.931384918.1@dbc.mtview.ca.us>
+
+ Here is the body. In this case, simply plain text.
+]]></artwork>
+</figure>
+
+<t>In addition to an implementation of the mime package,
+Tcl MIME includes an implementation of the smtp package.</t>
+
+<vspace blankLines="1000" />
+
+<section title="Requirements">
+<t>This package requires:
+<list style="symbols">
+<t><eref target="http://www.scriptics.com/software/8.1.html">Tcl/Tk version 8.0.3</eref>
+</list>
+or later</t>
+<t>In addition, this package requires one of the following:</t>
+<list style="symbols">
+<t><eref target="http://www.oche.de/~akupries/soft/trf/">Trf version 2.0p5</eref>
+or later</t>
+<t><eref target="http://dev.ajubasolutions.com/software/tcllib/">base 64 version 2.0</eref> or later (included with tcllib)</t>
+</list></t>
+<t>If it is available, Trf will be used to provide better performance;
+if not, Tcl-only equivalent functions, based on the base64 package,
+are used.</t>
+</section>
+
+<section title="Copyrights">
+<t>(c) 1999-2000 Marshall T. Rose</t>
+
+<t>Hold harmless the author, and any lawful use is allowed.</t>
+</section>
+</section>
+
+<section title="SYNTAX">
+<figure>
+<preamble><xref target="mime_initialize">mime::initialize</xref>
+returns a token.
+Parameters:</preamble>
+<artwork><![CDATA[ ?-canonical type/subtype
+ ?-param {key value}?...
+ ?-encoding value?
+ ?-header {key value}?... ?
+ (-file name | -string value | -parts {token1 ... tokenN})
+]]></artwork>
+</figure>
+
+<figure>
+<preamble><xref target="mime_finalize">mime::finalize</xref> returns
+an empty string.
+Parameters:</preamble>
+<artwork><![CDATA[ token ?-subordinates "all" | "dynamic" | "none"?
+]]></artwork>
+</figure>
+
+<figure>
+<preamble><xref target="mime_getproperty">mime::getproperty</xref>
+returns a string or a list of strings.
+Parameters:</preamble>
+<artwork><![CDATA[ token ?property | -names?
+]]></artwork>
+</figure>
+
+<figure>
+<preamble><xref target="mime_getheader">mime::getheader</xref> returns
+a list of strings.
+Parameters:</preamble>
+<artwork><![CDATA[ token ?key | -names?
+]]></artwork>
+</figure>
+
+<figure>
+<preamble><xref target="mime_setheader">mime::setheader</xref> returns
+a list of strings.
+Parameters:</preamble>
+<artwork><![CDATA[ token key value ?-mode "write" | "append" | "delete"?
+]]></artwork>
+</figure>
+
+<figure>
+<preamble><xref target="mime_getbody">mime::getbody</xref> returns a string.
+Parameters:</preamble>
+<artwork><![CDATA[ ?-command callback ?-blocksize octets? ?
+]]></artwork>
+</figure>
+
+<figure>
+<preamble><xref target="mime_copymessage">mime::copymessage</xref>
+returns an empty string.
+Parameters:</preamble>
+<artwork><![CDATA[ token channel
+]]></artwork>
+</figure>
+
+<figure>
+<preamble><xref target="mime_buildmessage">mime::buildmessage</xref>
+returns an empty string.
+Parameters:</preamble>
+<artwork><![CDATA[ token
+]]></artwork>
+</figure>
+
+<figure>
+<preamble><xref target="smtp_sendmessage">smtp::sendmessage</xref>
+returns a list.
+Parameters:</preamble>
+<artwork><![CDATA[ token ?-servers list? ?-ports list?
+ ?-queue boolean? ?-atleastone boolean?
+ ?-originator string? ?-recipients string?
+ ?-header {key value}?...
+]]></artwork>
+</figure>
+
+<figure>
+<preamble><xref target="mime_parseaddress">mime::parseaddress</xref>
+returns a list of serialized arrays.
+Parameters:</preamble>
+<artwork><![CDATA[ string
+]]></artwork>
+</figure>
+
+<figure>
+<preamble><xref target="mime_parsedatetime">mime::parsedatetime</xref>
+returns a string.
+Parameters:</preamble>
+<artwork><![CDATA[ [string | -now] property
+]]></artwork>
+</figure>
+
+<figure>
+<preamble><xref target="mime_mapencoding">mime::mapencoding</xref>
+returns a string.
+Parameters:</preamble>
+<artwork><![CDATA[ encoding_name
+]]></artwork>
+</figure>
+
+<figure>
+<preamble><xref target="mime_reversemapencoding">mime::reversemapencoding</xref>
+returns a string.
+Parameters:</preamble>
+<artwork><![CDATA[ content_type
+]]></artwork>
+</figure>
+
+</section>
+
+<section title="SEMANTICS">
+
+<section anchor="mime_initialize" title="mime::initialize">
+<t>mime::initialize creates a MIME part:
+<list style="symbols">
+<t>If the -canonical option is present,
+then the body is in canonical (raw) form and is found by consulting
+either the -file, -string, or -part option.
+<vspace blankLines="1" />
+In addition,
+both the -param and -header options may occur zero or more times to
+specify "Content-Type" parameters (e.g., "charset")
+and header keyword/values (e.g., "Content-Disposition"),
+respectively.
+<vspace blankLines="1" />
+Also, -encoding, if present,
+specifies the "Content-Transfer-Encoding" when copying the body.</t>
+
+<t>If the -canonical option is not present,
+then the MIME part contained in either the -file or the -string option
+is parsed,
+dynamically generating subordinates as appropriate.</t>
+</list></t>
+</section>
+
+<section anchor="mime_finalize" title="mime::finalize">
+<t>mime::finalize destroys a MIME part.</t>
+
+<t>If the -subordinates option is present,
+it specifies which subordinates should also be destroyed.
+The default value is "dynamic".</t>
+</section>
+
+<section anchor="mime_getproperty" title="mime::getproperty">
+<t>mime::getproperty returns the properties of a MIME part.</t>
+
+<figure>
+<preamble>The properties are:</preamble>
+<artwork><![CDATA[
+ property value
+ ======== =====
+ content the type/subtype describing the content
+ encoding the "Content-Transfer-Encoding"
+ params a list of "Content-Type" parameters
+ parts a list of tokens for the part's subordinates
+ size the approximate size of the content (unencoded)
+]]></artwork>
+<postamble>The "parts" property is present only if the MIME part has
+subordinates.</postamble>
+</figure>
+
+<t>If mime::getproperty is invoked with the name of a specific property,
+then the corresponding value is returned;
+instead,
+if -names is specified,
+a list of all properties is returned;
+otherwise,
+a serialized array of properties and values is returned.</t>
+</section>
+
+<section anchor="mime_getheader" title="mime::getheader">
+<t>mime::getheader returns the header of a MIME part.</t>
+
+<t>A header consists of zero or more key/value pairs.
+Each value is a list containing one or more strings.</t>
+
+<t>If mime::getheader is invoked with the name of a specific key,
+then a list containing the corresponding value(s) is returned;
+instead,
+if -names is specified,
+a list of all keys is returned;
+otherwise,
+a serialized array of keys and values is returned.
+Note that when a key is specified (e.g., "Subject"),
+the list returned usually contains exactly one string;
+however,
+some keys (e.g., "Received") often occur more than once in the header,
+accordingly the list returned usually contains more than one string.</t>
+</section>
+
+<section anchor="mime_setheader" title="mime::setheader">
+<t>mime::setheader writes, appends to, or deletes the value associated
+with a key in the header.</t>
+
+<t>The value for -mode is one of:
+<list style="hanging">
+<t hangText=" write:"> the key/value is either created or
+overwritten (the default);</t>
+
+<t hangText=" append:"> a new value is appended for the key
+(creating it as necessary); or,</t>
+
+<t hangText=" delete:"> all values associated with the key are removed
+(the "value" parameter is ignored).</t>
+</list></t>
+
+<t>Regardless,
+mime::setheader returns the previous value associated with the key.</t>
+</section>
+
+<section anchor="mime_getbody" title="mime::getbody">
+<t>mime::getbody returns the body of a leaf MIME part in canonical form.</t>
+
+<figure>
+<preamble>If the -command option is present,
+then it is repeatedly invoked with a fragment of the body as this:</preamble>
+<artwork><![CDATA[
+ uplevel #0 $callback [list "data" $fragment]
+]]></artwork>
+<postamble>(The -blocksize option,
+if present,
+specifies the maximum size of each fragment passed to the
+callback.)</postamble>
+</figure>
+
+<figure>
+<preamble>When the end of the body is reached,
+the callback is invoked as:</preamble>
+<artwork><![CDATA[
+ uplevel #0 $callback "end"
+]]></artwork>
+</figure>
+
+<figure>
+<preamble>Alternatively,
+if an error occurs,
+the callback is invoked as:</preamble>
+<artwork><![CDATA[
+ uplevel #0 $callback [list "error" reason]
+]]></artwork>
+</figure>
+
+<t>Regardless,
+the return value of the final invocation of the callback is propagated
+upwards by mime::getbody.</t>
+
+<t>If the -command option is absent,
+then the return value of mime::getbody is a string containing the MIME
+part's entire body.</t>
+</section>
+
+<section anchor="mime_copymessage" title="mime::copymessage">
+<t>mime::copymessage copies the MIME part to the specified channel.</t>
+
+<t>mime::copymessage operates synchronously,
+and uses fileevent to allow asynchronous operations to proceed
+independently.</t>
+</section>
+
+<section anchor="mime_buildmessage" title="mime::buildmessage">
+<t>mime::buildmessage returns the MIME part as a string. It is similar
+to mime::copymessage, only it returns the data as a return string
+instead of writing to a channel.</t>
+</section>
+
+<section anchor="smtp_sendmessage" title="smtp::sendmessage">
+<t>smtp::sendmessage sends a MIME part to an SMTP server.
+(Note that this procedure is in the "smtp" package,
+not the "mime" package.)</t>
+
+<t>The options are:
+<list style="hanging">
+<t hangText=" -servers:">a list of SMTP servers
+(the default is "localhost");</t>
+
+<t hangText=" -ports:">a list of SMTP ports
+(the default is 25);</t>
+
+<t hangText=" -queue:">indicates that the SMTP server should be
+asked to queue the message for later processing;</t>
+
+<t hangText=" -atleastone:">indicates that the SMTP server must find
+at least one recipient acceptable for the message to be sent;</t>
+
+<t hangText=" -originator:">a string containing an 822-style address
+specification
+(if present the header isn't examined for an originator address);</t>
+
+<t hangText=" -recipients:">a string containing one or more 822-style
+address specifications
+(if present the header isn't examined for recipient addresses); and,</t>
+
+<t hangText=" -header:">a keyword/value pairing
+(may occur zero or more times).</t>
+</list></t>
+
+<t>If the -originator option is not present,
+the originator address is taken from "From" (or "Resent-From");
+similarly,
+if the -recipients option is not present,
+recipient addresses are taken from "To", "cc", and "Bcc" (or
+"Resent-To", and so on).
+Note that the header key/values supplied by the "-header" option
+(not those present in the MIME part)
+are consulted.
+Regardless,
+header key/values are added to the outgoing message as necessary to
+ensure that a valid 822-style message is sent.</t>
+
+<t>smtp::sendmessage returns a list indicating which recipients were
+unacceptable to the SMTP server.
+Each element of the list is another list,
+containing the address, an SMTP error code, and a textual diagnostic.
+Depending on the -atleastone option and the intended recipients,,
+a non-empty list may still indicate that the message was accepted by
+the server.</t>
+</section>
+
+<section anchor="mime_parseaddress" title="mime::parseaddress">
+<t>mime::parseaddr takes a string containing one or more 822-style
+address specifications and returns a list of serialized arrays,
+one element for each address specified in the argument.</t>
+
+<figure>
+<preamble>Each serialized array contains these properties:</preamble>
+<artwork><![CDATA[
+ property value
+ ======== =====
+ address local@domain
+ comment 822-style comment
+ domain the domain part (rhs)
+ error non-empty on a parse error
+ group this address begins a group
+ friendly user-friendly rendering
+ local the local part (lhs)
+ memberP this address belongs to a group
+ phrase the phrase part
+ proper 822-style address specification
+ route 822-style route specification (obsolete)
+]]></artwork>
+<postamble>Note that one or more of these properties may be empty.</postamble>
+</figure>
+</section>
+
+<vspace blankLines="10000" />
+
+<section anchor="mime_parsedatetime" title="mime::parsedatetime">
+<t>mime::parsedatetime takes a string containing an 822-style
+date-time specification and returns the specified property.</t>
+
+<figure>
+<preamble>The list of properties and their ranges are:</preamble>
+<artwork><![CDATA[
+ property range
+ ======== =====
+ hour 0 .. 23
+ lmonth January, February, ..., December
+ lweekday Sunday, Monday, ... Saturday
+ mday 1 .. 31
+ min 0 .. 59
+ mon 1 .. 12
+ month Jan, Feb, ..., Dec
+ proper 822-style date-time specification
+ rclock elapsed seconds between then and now
+ sec 0 .. 59
+ wday 0 .. 6 (Sun .. Mon)
+ weekday Sun, Mon, ..., Sat
+ yday 1 .. 366
+ year 1900 ...
+ zone -720 .. 720 (minutes east of GMT)
+]]></artwork>
+</figure>
+</section>
+
+<section anchor="mime_mapencoding" title="mime::mapencoding">
+<t>mime::mapencoding maps tcl encodings onto the proper names for their
+MIME charset type. This is only done for encodings whose charset types
+were known. The remaining encodings return "" for now.</t>
+</section>
+
+<section anchor="mime_reversemapencoding" title="mime::reversemapencoding">
+<t>mime::reversemapencoding maps MIME charset types onto tcl encoding names.
+Those that are unknown return "".</t>
+</section>
+
+</section>
+
+<section title="EXAMPLES">
+<figure>
+<artwork><![CDATA[
+package require mime 1.0
+package require smtp 1.0
+
+
+# create an image
+
+set imageT [mime::initialize -canonical image/gif \
+ -file logo.gif]
+
+
+# parse a message
+
+set messageT [mime::initialize -file example.msg]
+
+
+# recursively traverse a message looking for primary recipients
+
+proc traverse {token} {
+ set result ""
+
+# depth-first search
+ if {![catch { mime::getproperty $token parts } parts]} {
+ foreach part $parts {
+ set result [concat $result [traverse $part]]
+ }
+ }
+
+# one value for each line occuring in the header
+ foreach value [mime::getheader $token To] {
+ foreach addr [mime::parseaddress $value] {
+ catch { unset aprops }
+ array set aprops $addr
+ lappend result $aprops(address)
+ }
+ }
+
+ return $result
+}
+
+
+# create a multipart containing both, and a timestamp
+
+set multiT [mime::initialize -canonical multipart/mixed
+ -parts [list $imageT $messageT]]
+
+
+
+
+# send it to some friends
+
+smtp::sendmessage $multiT \
+ -header [list From "Marshall Rose <mrose@dbc.mtview.ca.us>"] \
+ -header [list To "Andreas Kupries <a.kupries@westend.com>"] \
+ -header [list cc "dnew@messagemedia.com (Darren New)"] \
+ -header [list Subject "test message..."]
+
+
+# clean everything up
+
+mime::finalize $multiT -subordinates all
+]]></artwork>
+</figure>
+</section>
+
+</middle>
+
+<back>
+<references>
+<reference anchor="RFC2045">
+<front>
+<title>Multipurpose Internet Mail Extensions (MIME)
+Part One: Format of Internet Message Bodies</title>
+<author initials="N." surname="Freed" fullname="Ned Freed">
+<organization>Innosoft International, Inc.</organization>
+<address>
+<email>ned@innosoft.com</email>
+</address>
+</author>
+<author initials="N.S." surname="Borenstein"
+ fullname="Nathaniel S. Borenstein">
+<organization>First Virtual Holdings, Incorporated</organization>
+<address>
+<email>nsb@messagemedia.com</email>
+</address>
+</author>
+<date month="November" year="1996"/>
+</front>
+<seriesInfo name="RFC" value="2045" />
+</reference>
+
+<reference anchor="RFC2046">
+<front>
+<title>Multipurpose Internet Mail Extensions (MIME)
+Part Two: Media Types</title>
+<author initials="N." surname="Freed" fullname="Ned Freed">
+<organization>Innosoft International, Inc.</organization>
+<address>
+<email>ned@innosoft.com</email>
+</address>
+</author>
+<author initials="N.S." surname="Borenstein"
+ fullname="Nathaniel S. Borenstein">
+<organization>First Virtual Holdings, Incorporated</organization>
+<address>
+<email>nsb@messagemedia.com</email>
+</address>
+</author>
+<date month="November" year="1995"/>
+</front>
+<seriesInfo name="RFC" value="2046" />
+</reference>
+
+<reference anchor="RFC822">
+<front>
+<title>Standard for the format of ARPA Internet Text Messages</title>
+<author initials="D." surname="Crocker" fullname="Dave Crocker">
+<organization abbrev="UDEL">University of Delaware</organization>
+<address>
+<email>DCrocker@UDel-Relay</email>
+</address>
+</author>
+<date month="August" year="1982"/>
+</front>
+<seriesInfo name="RFC" value="822" />
+<seriesInfo name="STD" value="11" />
+</reference>
+
+</references>
+
+<section title="TODO List">
+<t><list style="hanging">
+<t hangText="mime::initialize">
+<list style="symbols">
+<t>well-defined errorCode values</t>
+
+<t>catch nested errors when processing a multipart</t>
+</list></t>
+
+</list></t>
+</section>
+
+<section title="Acknowledgements">
+<t>This package is influenced by the safe-tcl package
+(Borenstein and Rose, circa 1993),
+and also by <eref target="mailto:dnew@messagemedia.com">Darren New</eref>'s
+unpublished package of 1999.</t>
+
+<t>This package makes use of
+<eref target="mailto:a.kupries@westend.com">Andreas Kupries</eref>'s
+excellent Trf package.</t>
+</section>
+
+</back>
+</rfc>
diff --git a/tcllib/modules/mime/badmail1.txt b/tcllib/modules/mime/badmail1.txt
new file mode 100644
index 0000000..6713acb
--- /dev/null
+++ b/tcllib/modules/mime/badmail1.txt
@@ -0,0 +1,10 @@
+Date: Tue, 10 Jun 2003 10:32:05 +0200
+Message-Id: <200306100832.h5A8W5S16670@hmif.hellmann.pol.pl>
+From: Magnus Fisch <magnus.fisch@giant-polska.com.pl>
+Subject: Meeting tomorrow
+MIME-Version: 1.0
+Content-Type: multipart/mixed; boundary="----------CSFNU9QKPGZL79"
+Bcc:
+
+------------CSFNU9QKPGZL79--
+
diff --git a/tcllib/modules/mime/badmail2.txt b/tcllib/modules/mime/badmail2.txt
new file mode 100644
index 0000000..7bd863e
--- /dev/null
+++ b/tcllib/modules/mime/badmail2.txt
@@ -0,0 +1,31 @@
+From: "Kelsey " <irnmh5828ooem@yahoo.com>
+To: "gdylgzCsurvd1lw" <davidw@dedasys.com>
+Date: Fri, 28 Feb 2003 03:12:35 -0500
+Subject: no subject gdylgzCsurvd1lw
+MIME-Version: 1.0
+Content-Type: multipart/related;
+ boundary="----=_NextPart_000_0000_2CBA2CBA.150C56D2"
+X-Spam-Rating: daedalus.apache.org 1.6.2 0/1000/N
+X-Spam-Rating: icarus.apache.org 1.6.2 0/1000/N
+Lines: 19
+Xref: localhost private-mail:14167
+
+------=_NextPart_000_0000_2CBA2CBA.150C56D2
+Content-Type: text/html;
+Content-Transfer-Encoding: base64
+
+PCEtLTE1MTQ3LS0+PGJvZHk+DQpJdCdzIG1lIEplPCEtLTI5MDY0LS0+bm5pZmVyLDxicj4g
+SSBqdXN0IHdhbjwhLS0xOTE0OS0tPnRlZCB0byBzZW5kIHlvdSB0aGF0IHBpYyB5b3UgYXNr
+ZTwhLS0xNTAxMC0tPmQgZm9yIHRoZSBvdDwhLS0yNjUxMi0tPmhlcg0KZGF5LiA8YnI+IDxh
+IGhyZWY9Imh0dHA6Ly93d3cuaG90aG9zdC5iei9hYmMvamVubmlmZXIvP1JJRD1jaW5nd2Yi
+PkNsaTwhLS0yNzE1My0tPmNrDQpIPCEtLTI2NjcwLS0+ZXJlIHRvIGNhdDwhLS03NDg5LS0+
+Y2ggbWUgb24gbXkgd2ViPCEtLTI0ODExLS0+Y2FtICYgc2VlIG1vcmUgcGljcyBvZiBtZS48
+L2E+IDxicj48YnI+DQo8YSBocmVmPSJodHRwOi8vd3d3LmhvdGhvc3QuYnovYWJjL2plbm5p
+ZmVyLz9SSUQ9Y2luZ3dmIj48aW1nIHNyYz0iaHR0cDovLzIwNy40NC4xODMuMjU0L2FiYy9q
+ZW5uaWZlci93b29ob28uanBnIiBib3JkZXI9IjAiPjwvYT4NCjxicj48YnI+PGk+LSB4bzwh
+LS0yMzQwMi0tPnhvIEplbm5pZmVyPC9pPjwvcD48YnI+PGJyPjxicj48YnI+PGJyPjxicj48
+YnI+PGJyPjxicj48YnI+PGJyPjxicj48YnI+PGJyPjxicj48YnI+PGJyPjxicj48YnI+PGJy
+Pjxicj48YnI+PGJyPjxicj48YnI+PGJyPjxicj48YnI+PGJyPjxicj48YnI+DQo8L2JvZHk+
+
+
+
diff --git a/tcllib/modules/mime/mime.bench b/tcllib/modules/mime/mime.bench
new file mode 100644
index 0000000..99c204e
--- /dev/null
+++ b/tcllib/modules/mime/mime.bench
@@ -0,0 +1,59 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'mime' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.2 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.2]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+package forget mime
+catch {namespace delete ::mime}
+source [file join [file dirname [info script]] mime.tcl]
+
+proc construct_item_with_attachment size {
+ set message_token [mime::initialize -canonical text/plain \
+ -string "This is a first part."]
+ set attachment_body [string repeat abcd\n [expr {$size / 5}]]
+ set attachment_token [mime::initialize \
+ -canonical application/octet-stream \
+ -string $attachment_body]
+ set multi_token [mime::initialize -canonical multipart/mixed \
+ -parts [list $message_token $attachment_token]]
+
+ set packaged [mime::buildmessage $multi_token]
+ mime::finalize $multi_token
+ return $packaged
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+foreach sz {
+ 1000
+ 10000
+ 50000
+ 100000
+ 200000
+ 400000
+ 800000
+ 1000000
+ 1500000
+ 2500000
+ 5000000
+} {
+ bench -desc "MIME initialize/finalize $sz" -pre {
+ set item [construct_item_with_attachment $sz]
+ } -body {
+ mime::finalize [mime::initialize -string $item]
+ } -iter 1
+}
diff --git a/tcllib/modules/mime/mime.man b/tcllib/modules/mime/mime.man
new file mode 100644
index 0000000..fc3755b
--- /dev/null
+++ b/tcllib/modules/mime/mime.man
@@ -0,0 +1,405 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin mime n 1.6]
+[see_also ftp]
+[see_also http]
+[see_also pop3]
+[see_also smtp]
+[keywords email]
+[keywords internet]
+[keywords mail]
+[keywords mime]
+[keywords net]
+[keywords {rfc 821}]
+[keywords {rfc 822}]
+[keywords {rfc 2045}]
+[keywords {rfc 2046}]
+[keywords {rfc 2049}]
+[keywords smtp]
+[copyright {1999-2000 Marshall T. Rose}]
+[moddesc {Mime}]
+[titledesc {Manipulation of MIME body parts}]
+[category {Text processing}]
+[require Tcl 8.5]
+[require mime [opt 1.6]]
+[description]
+[para]
+
+The [package mime] library package provides the commands to create and
+manipulate MIME body parts.
+
+[list_begin definitions]
+
+[call [cmd ::mime::initialize] [opt "[option -canonical] [arg type/subtype] [opt "[option -param] \{[arg {key value}]\}..."] [opt "[option -encoding] [arg value]"] [opt "[option -header] \{[arg {key value}]\}..."]"] "([option -file] [arg name] | [option -string] [arg value] | [option -parts] \{[arg token1] ... [arg tokenN]\})"]
+
+This command creates a MIME part and returns a token representing it.
+
+[list_begin itemized]
+
+[item]
+
+If the [option -canonical] option is present, then the body is in
+canonical (raw) form and is found by consulting either the
+
+[option -file], [option -string], or [option -parts] option.
+
+[para]
+
+In addition, both the [option -param] and [option -header] options may
+occur zero or more times to specify [const Content-Type] parameters
+(e.g., [const charset]) and header keyword/values (e.g.,
+
+[const Content-Disposition]), respectively.
+
+[para]
+
+Also, [option -encoding], if present, specifies the
+
+[const Content-Transfer-Encoding] when copying the body.
+
+[item]
+
+If the [option -canonical] option is not present, then the MIME part
+contained in either the [option -file] or the [option -string] option
+is parsed, dynamically generating subordinates as appropriate.
+
+[list_end]
+
+[call [cmd ::mime::finalize] [arg token] [opt "[option -subordinates] [const all] | [const dynamic] | [const none]"]]
+
+This command destroys the MIME part represented by [arg token]. It
+returns an empty string.
+
+[para]
+
+If the [option -subordinates] option is present, it specifies which
+subordinates should also be destroyed. The default value is
+
+[const dynamic], destroying all subordinates which were created by
+[cmd ::mime::initialize] together with the containing body part.
+
+[call [cmd ::mime::getproperty] [arg token] [opt "[arg property] | [option -names]"]]
+
+This command returns a string or a list of strings containing the
+properties of a MIME part. If the command is invoked with the name of
+a specific property, then the corresponding value is returned;
+instead, if [option -names] is specified, a list of all properties is
+returned; otherwise, a serialized array of properties and values is
+returned.
+
+[para]
+The possible properties are:
+
+[list_begin definitions]
+
+[def [const content]]
+
+The type/subtype describing the content
+
+[def [const encoding]]
+
+The "Content-Transfer-Encoding"
+
+[def [const params]]
+
+A list of "Content-Type" parameters
+
+[def [const parts]]
+
+A list of tokens for the part's subordinates. This property is
+present only if the MIME part has subordinates.
+
+[def [const size]]
+
+The approximate size of the content (unencoded)
+
+[list_end]
+
+[call [cmd ::mime::getheader] [arg token] [opt "[arg key] | [option -names]"]]
+
+This command returns the header of a MIME part, as a list of strings.
+
+[para]
+
+A header consists of zero or more key/value pairs. Each value is a
+list containing one or more strings.
+
+[para]
+
+If this command is invoked with the name of a specific [arg key], then
+a list containing the corresponding value(s) is returned; instead, if
+-names is specified, a list of all keys is returned; otherwise, a
+serialized array of keys and values is returned. Note that when a key
+is specified (e.g., "Subject"), the list returned usually contains
+exactly one string; however, some keys (e.g., "Received") often occur
+more than once in the header, accordingly the list returned usually
+contains more than one string.
+
+[call [cmd ::mime::setheader] [arg token] [arg {key value}] [opt "[option -mode] [const write] | [const append] | [const delete]"]]
+
+This command writes, appends to, or deletes the [arg value] associated
+with a [arg key] in the header. It returns a list of strings
+containing the previous value associated with the key.
+
+[para]
+
+The value for [option -mode] is one of:
+
+[list_begin definitions]
+
+[def [const write]]
+
+The [arg key]/[arg value] is either created or overwritten (the default).
+
+[def [const append]]
+
+A new [arg value] is appended for the [arg key] (creating it as necessary).
+
+[def [const delete]]
+
+All values associated with the key are removed (the [arg value]
+parameter is ignored).
+
+[list_end]
+
+[call [cmd ::mime::getbody] [arg token] [opt [option -decode]] [opt "[option -command] [arg callback] [opt "[option -blocksize] [arg octets]"]"]]
+
+This command returns a string containing the body of the leaf MIME
+part represented by [arg token] in canonical form.
+
+[para]
+
+If the [option -command] option is present, then it is repeatedly
+invoked with a fragment of the body as this:
+
+[example {
+ uplevel #0 $callback [list "data" $fragment]
+}]
+
+[para]
+
+(The [option -blocksize] option, if present, specifies the maximum
+size of each fragment passed to the callback.)
+
+[para]
+
+When the end of the body is reached, the callback is invoked as:
+
+[example {
+ uplevel #0 $callback "end"
+}]
+
+[para]
+
+Alternatively, if an error occurs, the callback is invoked as:
+
+[example {
+ uplevel #0 $callback [list "error" reason]
+}]
+
+[para]
+
+Regardless, the return value of the final invocation of the callback
+is propagated upwards by [cmd ::mime::getbody].
+
+[para]
+
+If the [option -command] option is absent, then the return value of
+[cmd ::mime::getbody] is a string containing the MIME part's entire
+body.
+
+[para]
+
+If the option [option -decode] is absent the return value computed
+above is returned as is. This means that it will be in the charset
+specified for the token and not the usual utf-8.
+
+If the option [option -decode] is present however the command will use
+the charset information associated with the token to convert the
+string from its encoding into utf-8 before returning it.
+
+[call [cmd ::mime::copymessage] [arg token] [arg channel]]
+
+This command copies the MIME represented by [arg token] part to the
+specified [arg channel]. The command operates synchronously, and uses
+fileevent to allow asynchronous operations to proceed
+independently. It returns an empty string.
+
+[call [cmd ::mime::buildmessage] [arg token]]
+
+This command returns the MIME part represented by [arg token] as a
+string. It is similar to [cmd ::mime::copymessage], only it returns
+the data as a return string instead of writing to a channel.
+
+[call [cmd ::mime::parseaddress] [arg string]]
+
+This command takes a string containing one or more 822-style address
+specifications and returns a list of serialized arrays, one element
+for each address specified in the argument. If the string contains
+more than one address they will be separated by commas.
+
+[para]
+
+Each serialized array contains the properties below. Note that one or
+more of these properties may be empty.
+
+[list_begin definitions]
+
+[def [const address]]
+
+local@domain
+
+[def [const comment]]
+
+822-style comment
+
+[def [const domain]]
+
+the domain part (rhs)
+
+[def [const error]]
+
+non-empty on a parse error
+
+[def [const group]]
+
+this address begins a group
+
+[def [const friendly]]
+
+user-friendly rendering
+
+[def [const local]]
+
+the local part (lhs)
+
+[def [const memberP]]
+
+this address belongs to a group
+
+[def [const phrase]]
+
+the phrase part
+
+[def [const proper]]
+
+822-style address specification
+
+[def [const route]]
+
+822-style route specification (obsolete)
+
+[list_end]
+
+[call [cmd ::mime::parsedatetime] ([arg string] | [option -now]) [arg property]]
+
+This command takes a string containing an 822-style date-time
+specification and returns the specified property as a serialized
+array.
+
+[para]
+
+The list of properties and their ranges are:
+
+[list_begin definitions]
+
+[def [const hour]]
+
+0 .. 23
+
+[def [const lmonth]]
+
+January, February, ..., December
+
+[def [const lweekday]]
+
+Sunday, Monday, ... Saturday
+
+[def [const mday]]
+
+1 .. 31
+
+[def [const min]]
+
+0 .. 59
+
+[def [const mon]]
+
+1 .. 12
+
+[def [const month]]
+
+Jan, Feb, ..., Dec
+
+[def [const proper]]
+
+822-style date-time specification
+
+[def [const rclock]]
+
+elapsed seconds between then and now
+
+[def [const sec]]
+
+0 .. 59
+
+[def [const wday]]
+
+0 .. 6 (Sun .. Mon)
+
+[def [const weekday]]
+
+Sun, Mon, ..., Sat
+
+[def [const yday]]
+
+1 .. 366
+
+[def [const year]]
+
+1900 ...
+
+[def [const zone]]
+
+-720 .. 720 (minutes east of GMT)
+
+[list_end]
+
+[call [cmd ::mime::mapencoding] [arg encoding_name]]
+
+This commansd maps tcl encodings onto the proper names for their MIME
+charset type. This is only done for encodings whose charset types
+were known. The remaining encodings return "" for now.
+
+[call [cmd ::mime::reversemapencoding] [arg charset_type]]
+
+This command maps MIME charset types onto tcl encoding names. Those
+that are unknown return "".
+
+[list_end]
+
+[section {KNOWN BUGS}]
+
+[list_begin definitions]
+[def {Tcllib Bug #447037}]
+
+This problem affects only people which are using Tcl and Mime on a
+64-bit system. The currently recommended fix for this problem is to
+upgrade to Tcl version 8.4. This version has extended 64 bit support
+and the bug does not appear anymore.
+
+[para]
+
+The problem could have been generally solved by requiring the use of
+Tcl 8.4 for this package. We decided against this solution as it would
+force a large number of unaffected users to upgrade their Tcl
+interpreter for no reason.
+
+[para]
+
+See [uri {/tktview?name=447037} {Ticket 447037}] for additional information.
+
+[list_end]
+
+[vset CATEGORY mime]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/mime/mime.tcl b/tcllib/modules/mime/mime.tcl
new file mode 100644
index 0000000..35423fd
--- /dev/null
+++ b/tcllib/modules/mime/mime.tcl
@@ -0,0 +1,4010 @@
+# mime.tcl - MIME body parts
+#
+# (c) 1999-2000 Marshall T. Rose
+# (c) 2000 Brent Welch
+# (c) 2000 Sandeep Tamhankar
+# (c) 2000 Dan Kuchler
+# (c) 2000-2001 Eric Melski
+# (c) 2001 Jeff Hobbs
+# (c) 2001-2008 Andreas Kupries
+# (c) 2002-2003 David Welton
+# (c) 2003-2008 Pat Thoyts
+# (c) 2005 Benjamin Riefenstahl
+# (c) 2013 PoorYorick
+#
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's
+# unpublished package of 1999.
+#
+
+# new string features and inline scan are used, requiring 8.3.
+package require Tcl 8.5
+
+package provide mime 1.6
+
+if {[catch {package require Trf 2.0}]} {
+
+ # Fall-back to tcl-based procedures of base64 and quoted-printable encoders
+ # Warning!
+ # These are a fragile emulations of the more general calling sequence
+ # that appears to work with this code here.
+
+ package require base64 2.0
+ set ::major [lindex [split [package require md5] .] 0]
+
+ # Create these commands in the mime namespace so that they
+ # won't collide with things at the global namespace level
+
+ namespace eval ::mime {
+ proc base64 {-mode what -- chunk} {
+ return [base64::$what $chunk]
+ }
+ proc quoted-printable {-mode what -- chunk} {
+ return [mime::qp_$what $chunk]
+ }
+
+ if {$::major < 2} {
+ # md5 v1, result is hex string ready for use.
+ proc md5 {-- string} {
+ return [md5::md5 $string]
+ }
+ } else {
+ # md5 v2, need option to get hex string
+ proc md5 {-- string} {
+ return [md5::md5 -hex $string]
+ }
+ }
+ }
+
+ unset ::major
+}
+
+#
+# state variables:
+#
+# canonicalP: input is in its canonical form
+# content: type/subtype
+# params: seralized array of key/value pairs (keys are lower-case)
+# encoding: transfer encoding
+# version: MIME-version
+# header: serialized array of key/value pairs (keys are lower-case)
+# lowerL: list of header keys, lower-case
+# mixedL: list of header keys, mixed-case
+# value: either "file", "parts", or "string"
+#
+# file: input file
+# fd: cached file-descriptor, typically for root
+# root: token for top-level part, for (distant) subordinates
+# offset: number of octets from beginning of file/string
+# count: length in octets of (encoded) content
+#
+# parts: list of bodies (tokens)
+#
+# string: input string
+#
+# cid: last child-id assigned
+#
+
+
+namespace eval ::mime {
+ variable mime
+ array set mime {uid 0 cid 0}
+
+ # RFC 822 lexemes
+ variable addrtokenL
+ lappend addrtokenL \; , < > : . ( ) @ \" \[ ] \\
+ variable addrlexemeL {
+ LX_SEMICOLON LX_COMMA
+ LX_LBRACKET LX_RBRACKET
+ LX_COLON LX_DOT
+ LX_LPAREN LX_RPAREN
+ LX_ATSIGN LX_QUOTE
+ LX_LSQUARE LX_RSQUARE
+ LX_QUOTE
+ }
+
+ # RFC 2045 lexemes
+ variable typetokenL
+ lappend typetokenL \; , < > : ? ( ) @ \" \[ \] = / \\
+ variable typelexemeL {
+ LX_SEMICOLON LX_COMMA
+ LX_LBRACKET LX_RBRACKET
+ LX_COLON LX_QUESTION
+ LX_LPAREN LX_RPAREN
+ LX_ATSIGN LX_QUOTE
+ LX_LSQUARE LX_RSQUARE
+ LX_EQUALS LX_SOLIDUS
+ LX_QUOTE
+ }
+
+ variable encList {
+ ascii US-ASCII
+ big5 Big5
+ cp1250 Windows-1250
+ cp1251 Windows-1251
+ cp1252 Windows-1252
+ cp1253 Windows-1253
+ cp1254 Windows-1254
+ cp1255 Windows-1255
+ cp1256 Windows-1256
+ cp1257 Windows-1257
+ cp1258 Windows-1258
+ cp437 IBM437
+ cp737 {}
+ cp775 IBM775
+ cp850 IBM850
+ cp852 IBM852
+ cp855 IBM855
+ cp857 IBM857
+ cp860 IBM860
+ cp861 IBM861
+ cp862 IBM862
+ cp863 IBM863
+ cp864 IBM864
+ cp865 IBM865
+ cp866 IBM866
+ cp869 IBM869
+ cp874 {}
+ cp932 {}
+ cp936 GBK
+ cp949 {}
+ cp950 {}
+ dingbats {}
+ ebcdic {}
+ euc-cn EUC-CN
+ euc-jp EUC-JP
+ euc-kr EUC-KR
+ gb12345 GB12345
+ gb1988 GB1988
+ gb2312 GB2312
+ iso2022 ISO-2022
+ iso2022-jp ISO-2022-JP
+ iso2022-kr ISO-2022-KR
+ iso8859-1 ISO-8859-1
+ iso8859-2 ISO-8859-2
+ iso8859-3 ISO-8859-3
+ iso8859-4 ISO-8859-4
+ iso8859-5 ISO-8859-5
+ iso8859-6 ISO-8859-6
+ iso8859-7 ISO-8859-7
+ iso8859-8 ISO-8859-8
+ iso8859-9 ISO-8859-9
+ iso8859-10 ISO-8859-10
+ iso8859-13 ISO-8859-13
+ iso8859-14 ISO-8859-14
+ iso8859-15 ISO-8859-15
+ iso8859-16 ISO-8859-16
+ jis0201 JIS_X0201
+ jis0208 JIS_C6226-1983
+ jis0212 JIS_X0212-1990
+ koi8-r KOI8-R
+ koi8-u KOI8-U
+ ksc5601 KS_C_5601-1987
+ macCentEuro {}
+ macCroatian {}
+ macCyrillic {}
+ macDingbats {}
+ macGreek {}
+ macIceland {}
+ macJapan {}
+ macRoman {}
+ macRomania {}
+ macThai {}
+ macTurkish {}
+ macUkraine {}
+ shiftjis Shift_JIS
+ symbol {}
+ tis-620 TIS-620
+ unicode {}
+ utf-8 UTF-8
+ }
+
+ variable encodings
+ array set encodings $encList
+ variable reversemap
+ # Initialized at the bottom of the file
+
+ variable encAliasList {
+ ascii ANSI_X3.4-1968
+ ascii iso-ir-6
+ ascii ANSI_X3.4-1986
+ ascii ISO_646.irv:1991
+ ascii ASCII
+ ascii ISO646-US
+ ascii us
+ ascii IBM367
+ ascii cp367
+ cp437 cp437
+ cp437 437
+ cp775 cp775
+ cp850 cp850
+ cp850 850
+ cp852 cp852
+ cp852 852
+ cp855 cp855
+ cp855 855
+ cp857 cp857
+ cp857 857
+ cp860 cp860
+ cp860 860
+ cp861 cp861
+ cp861 861
+ cp861 cp-is
+ cp862 cp862
+ cp862 862
+ cp863 cp863
+ cp863 863
+ cp864 cp864
+ cp865 cp865
+ cp865 865
+ cp866 cp866
+ cp866 866
+ cp869 cp869
+ cp869 869
+ cp869 cp-gr
+ cp936 CP936
+ cp936 MS936
+ cp936 Windows-936
+ iso8859-1 ISO_8859-1:1987
+ iso8859-1 iso-ir-100
+ iso8859-1 ISO_8859-1
+ iso8859-1 latin1
+ iso8859-1 l1
+ iso8859-1 IBM819
+ iso8859-1 CP819
+ iso8859-2 ISO_8859-2:1987
+ iso8859-2 iso-ir-101
+ iso8859-2 ISO_8859-2
+ iso8859-2 latin2
+ iso8859-2 l2
+ iso8859-3 ISO_8859-3:1988
+ iso8859-3 iso-ir-109
+ iso8859-3 ISO_8859-3
+ iso8859-3 latin3
+ iso8859-3 l3
+ iso8859-4 ISO_8859-4:1988
+ iso8859-4 iso-ir-110
+ iso8859-4 ISO_8859-4
+ iso8859-4 latin4
+ iso8859-4 l4
+ iso8859-5 ISO_8859-5:1988
+ iso8859-5 iso-ir-144
+ iso8859-5 ISO_8859-5
+ iso8859-5 cyrillic
+ iso8859-6 ISO_8859-6:1987
+ iso8859-6 iso-ir-127
+ iso8859-6 ISO_8859-6
+ iso8859-6 ECMA-114
+ iso8859-6 ASMO-708
+ iso8859-6 arabic
+ iso8859-7 ISO_8859-7:1987
+ iso8859-7 iso-ir-126
+ iso8859-7 ISO_8859-7
+ iso8859-7 ELOT_928
+ iso8859-7 ECMA-118
+ iso8859-7 greek
+ iso8859-7 greek8
+ iso8859-8 ISO_8859-8:1988
+ iso8859-8 iso-ir-138
+ iso8859-8 ISO_8859-8
+ iso8859-8 hebrew
+ iso8859-9 ISO_8859-9:1989
+ iso8859-9 iso-ir-148
+ iso8859-9 ISO_8859-9
+ iso8859-9 latin5
+ iso8859-9 l5
+ iso8859-10 iso-ir-157
+ iso8859-10 l6
+ iso8859-10 ISO_8859-10:1992
+ iso8859-10 latin6
+ iso8859-14 iso-ir-199
+ iso8859-14 ISO_8859-14:1998
+ iso8859-14 ISO_8859-14
+ iso8859-14 latin8
+ iso8859-14 iso-celtic
+ iso8859-14 l8
+ iso8859-15 ISO_8859-15
+ iso8859-15 Latin-9
+ iso8859-16 iso-ir-226
+ iso8859-16 ISO_8859-16:2001
+ iso8859-16 ISO_8859-16
+ iso8859-16 latin10
+ iso8859-16 l10
+ jis0201 X0201
+ jis0208 iso-ir-87
+ jis0208 x0208
+ jis0208 JIS_X0208-1983
+ jis0212 x0212
+ jis0212 iso-ir-159
+ ksc5601 iso-ir-149
+ ksc5601 KS_C_5601-1989
+ ksc5601 KSC5601
+ ksc5601 korean
+ shiftjis MS_Kanji
+ utf-8 UTF8
+ }
+
+ namespace export initialize finalize getproperty \
+ getheader setheader \
+ getbody \
+ copymessage \
+ mapencoding \
+ reversemapencoding \
+ parseaddress \
+ parsedatetime \
+ uniqueID
+}
+
+# ::mime::initialize --
+#
+# Creates a MIME part, and returnes the MIME token for that part.
+#
+# Arguments:
+# args Args can be any one of the following:
+# ?-canonical type/subtype
+# ?-param {key value}?...
+# ?-encoding value?
+# ?-header {key value}?... ?
+# (-file name | -string value | -parts {token1 ... tokenN})
+#
+# If the -canonical option is present, then the body is in
+# canonical (raw) form and is found by consulting either the -file,
+# -string, or -parts option.
+#
+# In addition, both the -param and -header options may occur zero
+# or more times to specify "Content-Type" parameters (e.g.,
+# "charset") and header keyword/values (e.g.,
+# "Content-Disposition"), respectively.
+#
+# Also, -encoding, if present, specifies the
+# "Content-Transfer-Encoding" when copying the body.
+#
+# If the -canonical option is not present, then the MIME part
+# contained in either the -file or the -string option is parsed,
+# dynamically generating subordinates as appropriate.
+#
+# Results:
+# An initialized mime token.
+
+proc ::mime::initialize args {
+ global errorCode errorInfo
+
+ variable mime
+
+ set token [namespace current]::[incr mime(uid)]
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {[catch {{*}[list mime::initializeaux $token {*}$args]} result eopts]} {
+ catch {mime::finalize $token -subordinates dynamic}
+ return -options $eopts $result
+ }
+ return $token
+}
+
+# ::mime::initializeaux --
+#
+# Configures the MIME token created in mime::initialize based on
+# the arguments that mime::initialize supports.
+#
+# Arguments:
+# token The MIME token to configure.
+# args Args can be any one of the following:
+# ?-canonical type/subtype
+# ?-param {key value}?...
+# ?-encoding value?
+# ?-header {key value}?... ?
+# (-file name | -string value | -parts {token1 ... tokenN})
+#
+# Results:
+# Either configures the mime token, or throws an error.
+
+proc ::mime::initializeaux {token args} {
+ global errorCode errorInfo
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set params [set state(params) {}]
+ set state(encoding) {}
+ set state(version) 1.0
+
+ set state(header) {}
+ set state(lowerL) {}
+ set state(mixedL) {}
+
+ set state(cid) 0
+
+ set argc [llength $args]
+ for {set argx 0} {$argx < $argc} {incr argx} {
+ set option [lindex $args $argx]
+ if {[incr argx] >= $argc} {
+ error "missing argument to $option"
+ }
+ set value [lindex $args $argx]
+
+ switch -- $option {
+ -canonical {
+ set state(content) [string tolower $value]
+ }
+
+ -param {
+ if {[llength $value] != 2} {
+ error "-param expects a key and a value, not $value"
+ }
+ set lower [string tolower [set mixed [lindex $value 0]]]
+ if {[info exists params($lower)]} {
+ error "the $mixed parameter may be specified at most once"
+ }
+
+ set params($lower) [lindex $value 1]
+ set state(params) [array get params]
+ }
+
+ -encoding {
+ switch -- [set state(encoding) [string tolower $value]] {
+ 7bit - 8bit - binary - quoted-printable - base64 {
+ }
+
+ default {
+ error "unknown value for -encoding $state(encoding)"
+ }
+ }
+ }
+
+ -header {
+ if {[llength $value] != 2} {
+ error "-header expects a key and a value, not $value"
+ }
+ set lower [string tolower [set mixed [lindex $value 0]]]
+ if {$lower eq "content-type"} {
+ error "use -canonical instead of -header $value"
+ }
+ if {$lower eq "content-transfer-encoding"} {
+ error "use -encoding instead of -header $value"
+ }
+ if {$lower in {content-md5 mime-version}} {
+ error "don't go there..."
+ }
+ if {$lower ni $state(lowerL)} {
+ lappend state(lowerL) $lower
+ lappend state(mixedL) $mixed
+ }
+
+ array set header $state(header)
+ lappend header($lower) [lindex $value 1]
+ set state(header) [array get header]
+ }
+
+ -file {
+ set state(file) $value
+ }
+
+ -parts {
+ set state(parts) $value
+ }
+
+ -string {
+ set state(string) $value
+
+ set state(lines) [split $value \n]
+ set state(lines.count) [llength $state(lines)]
+ set state(lines.current) 0
+ }
+
+ -root {
+ # the following are internal options
+
+ set state(root) $value
+ }
+
+ -offset {
+ set state(offset) $value
+ }
+
+ -count {
+ set state(count) $value
+ }
+
+ -lineslist {
+ set state(lines) $value
+ set state(lines.count) [llength $state(lines)]
+ set state(lines.current) 0
+ #state(string) is needed, but will be built when required
+ set state(string) {}
+ }
+
+ default {
+ error "unknown option $option"
+ }
+ }
+ }
+
+ #We only want one of -file, -parts or -string:
+ set valueN 0
+ foreach value {file parts string} {
+ if {[info exists state($value)]} {
+ set state(value) $value
+ incr valueN
+ }
+ }
+ if {$valueN != 1 && ![info exists state(lines)]} {
+ error "specify exactly one of -file, -parts, or -string"
+ }
+
+ if {[set state(canonicalP) [info exists state(content)]]} {
+ switch -- $state(value) {
+ file {
+ set state(offset) 0
+ }
+
+ parts {
+ switch -glob -- $state(content) {
+ text/*
+ -
+ image/*
+ -
+ audio/*
+ -
+ video/* {
+ error "-canonical $state(content) and -parts do not mix"
+ }
+
+ default {
+ if {$state(encoding) ne {}} {
+ error "-encoding and -parts do not mix"
+ }
+ }
+ }
+ }
+ default {# Go ahead}
+ }
+
+ if {[lsearch -exact $state(lowerL) content-id] < 0} {
+ lappend state(lowerL) content-id
+ lappend state(mixedL) Content-ID
+
+ array set header $state(header)
+ lappend header(content-id) [uniqueID]
+ set state(header) [array get header]
+ }
+
+ set state(version) 1.0
+
+ return
+ }
+
+ if {$state(params) ne {}} {
+ error "-param requires -canonical"
+ }
+ if {$state(encoding) ne {}} {
+ error "-encoding requires -canonical"
+ }
+ if {$state(header) ne {}} {
+ error "-header requires -canonical"
+ }
+ if {[info exists state(parts)]} {
+ error "-parts requires -canonical"
+ }
+
+ if {[set fileP [info exists state(file)]]} {
+ if {[set openP [info exists state(root)]]} {
+ # FRINK: nocheck
+ variable $state(root)
+ upvar 0 $state(root) root
+
+ set state(fd) $root(fd)
+ } else {
+ set state(root) $token
+ set state(fd) [open $state(file) RDONLY]
+ set state(offset) 0
+ seek $state(fd) 0 end
+ set state(count) [tell $state(fd)]
+
+ fconfigure $state(fd) -translation binary
+ }
+ }
+
+ set code [catch {mime::parsepart $token} result]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ if {$fileP} {
+ if {!$openP} {
+ unset state(root)
+ catch {close $state(fd)}
+ }
+ unset state(fd)
+ }
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+}
+
+# ::mime::parsepart --
+#
+# Parses the MIME headers and attempts to break up the message
+# into its various parts, creating a MIME token for each part.
+#
+# Arguments:
+# token The MIME token to parse.
+#
+# Results:
+# Throws an error if it has problems parsing the MIME token,
+# otherwise it just sets up the appropriate variables.
+
+proc ::mime::parsepart {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {[set fileP [info exists state(file)]]} {
+ seek $state(fd) [set pos $state(offset)] start
+ set last [expr {$state(offset) + $state(count) - 1}]
+ } else {
+ set string $state(string)
+ }
+
+ set vline {}
+ while 1 {
+ set blankP 0
+ if {$fileP} {
+ if {($pos > $last) || ([set x [gets $state(fd) line]] <= 0)} {
+ set blankP 1
+ } else {
+ incr pos [expr {$x + 1}]
+ }
+ } else {
+
+ if {$state(lines.current) >= $state(lines.count)} {
+ set blankP 1
+ set line {}
+ } else {
+ set line [lindex $state(lines) $state(lines.current)]
+ incr state(lines.current)
+ set x [string length $line]
+ if {$x == 0} {set blankP 1}
+ }
+
+ }
+
+ if {(!$blankP) && ([string last \r $line] == {$x - 1})} {
+ set line [string range $line 0 [expr {$x - 2}]]
+ if {$x == 1} {
+ set blankP 1
+ }
+ }
+
+ if {(!$blankP) && (([
+ string first { } $line] == 0) || ([
+ string first \t $line] == 0))} {
+ append vline \n $line
+ continue
+ }
+
+ if {$vline eq {}} {
+ if {$blankP} {
+ break
+ }
+
+ set vline $line
+ continue
+ }
+
+ if {([set x [string first : $vline]] <= 0) \
+ || ([set mixed [ string trimright [
+ string range $vline 0 [expr {$x - 1}]]
+ ]] eq {})
+ } {
+ error "improper line in header: $vline"
+ }
+ set value [string trim [string range $vline [expr {$x + 1}] end]]
+ switch -- [set lower [string tolower $mixed]] {
+ content-type {
+ if {[info exists state(content)]} {
+ error "multiple Content-Type fields starting with $vline"
+ }
+
+ if {![catch {set x [parsetype $token $value]}]} {
+ set state(content) [lindex $x 0]
+ set state(params) [lindex $x 1]
+ }
+ }
+
+ content-md5 {
+ }
+
+ content-transfer-encoding {
+ if {($state(encoding) ne {}) \
+ && ($state(encoding) ne [
+ string tolower $value])} {
+ error "multiple Content-Transfer-Encoding fields starting with $vline"
+ }
+
+ set state(encoding) [string tolower $value]
+ }
+
+ mime-version {
+ set state(version) $value
+ }
+
+ default {
+ if {[lsearch -exact $state(lowerL) $lower] < 0} {
+ lappend state(lowerL) $lower
+ lappend state(mixedL) $mixed
+ }
+
+ array set header $state(header)
+ lappend header($lower) $value
+ set state(header) [array get header]
+ }
+ }
+
+ if {$blankP} {
+ break
+ }
+ set vline $line
+ }
+
+ if {![info exists state(content)]} {
+ set state(content) text/plain
+ set state(params) [list charset us-ascii]
+ }
+
+ if {![string match multipart/* $state(content)]} {
+ if {$fileP} {
+ set x [tell $state(fd)]
+ incr state(count) [expr {$state(offset) - $x}]
+ set state(offset) $x
+ } else {
+ # rebuild string, this is cheap and needed by other functions
+ set state(string) [join [
+ lrange $state(lines) $state(lines.current) end] \n]
+ }
+
+ if {[string match message/* $state(content)]} {
+ # FRINK: nocheck
+ variable [set child $token-[incr state(cid)]]
+
+ set state(value) parts
+ set state(parts) $child
+ if {$fileP} {
+ mime::initializeaux $child \
+ -file $state(file) -root $state(root) \
+ -offset $state(offset) -count $state(count)
+ } else {
+ if {[info exists state(encoding)]} {
+ set strng [join [
+ lrange $state(lines) $state(lines.current) end] \n]
+ switch -- $state(encoding) {
+ base64 -
+ quoted-printable {
+ set strng [$state(encoding) -mode decode -- $strng]
+ }
+ default {}
+ }
+ mime::initializeaux $child -string $strng
+ } else {
+ mime::initializeaux $child -lineslist [
+ lrange $state(lines) $state(lines.current) end]
+ }
+ }
+ }
+
+ return
+ }
+
+ set state(value) parts
+
+ set boundary {}
+ foreach {k v} $state(params) {
+ if {$k eq "boundary"} {
+ set boundary $v
+ break
+ }
+ }
+ if {$boundary eq {}} {
+ error "boundary parameter is missing in $state(content)"
+ }
+ if {[string trim $boundary] eq {}} {
+ error "boundary parameter is empty in $state(content)"
+ }
+
+ if {$fileP} {
+ set pos [tell $state(fd)]
+ # This variable is like 'start', for the reasons laid out
+ # below, in the other branch of this conditional.
+ set initialpos $pos
+ } else {
+ # This variable is like 'start', a list of lines in the
+ # part. This record is made even before we find a starting
+ # boundary and used if we run into the terminating boundary
+ # before a starting boundary was found. In that case the lines
+ # before the terminator as recorded by tracelines are seen as
+ # the part, or at least we attempt to parse them as a
+ # part. See the forceoctet and nochild flags later. We cannot
+ # use 'start' as that records lines only after the starting
+ # boundary was found.
+ set tracelines [list]
+ }
+
+ set inP 0
+ set moreP 1
+ set forceoctet 0
+ while {$moreP} {
+ if {$fileP} {
+ if {$pos > $last} {
+ # We have run over the end of the part per the outer
+ # information without finding a terminating boundary.
+ # We now fake the boundary and force the parser to
+ # give any new part coming of this a mime-type of
+ # application/octet-stream regardless of header
+ # information.
+ set line "--$boundary--"
+ set x [string length $line]
+ set forceoctet 1
+ } else {
+ if {[set x [gets $state(fd) line]] < 0} {
+ error "end-of-file encountered while parsing $state(content)"
+ }
+ }
+ incr pos [expr {$x + 1}]
+ } else {
+ if {$state(lines.current) >= $state(lines.count)} {
+ error "end-of-string encountered while parsing $state(content)"
+ } else {
+ set line [lindex $state(lines) $state(lines.current)]
+ incr state(lines.current)
+ set x [string length $line]
+ }
+ set x [string length $line]
+ }
+ if {[string last \r $line] == $x - 1} {
+ set line [string range $line 0 [expr {$x - 2}]]
+ set crlf 2
+ } else {
+ set crlf 1
+ }
+
+ if {[string first --$boundary $line] != 0} {
+ if {$inP && !$fileP} {
+ lappend start $line
+ }
+ continue
+ } else {
+ lappend tracelines $line
+ }
+
+ if {!$inP} {
+ # Haven't seen the starting boundary yet. Check if the
+ # current line contains this starting boundary.
+
+ if {$line eq "--$boundary"} {
+ # Yes. Switch parser state to now search for the
+ # terminating boundary of the part and record where
+ # the part begins (or initialize the recorder for the
+ # lines in the part).
+ set inP 1
+ if {$fileP} {
+ set start $pos
+ } else {
+ set start [list]
+ }
+ continue
+ } elseif {$line eq "--$boundary--"} {
+ # We just saw a terminating boundary before we ever
+ # saw the starting boundary of a part. This forces us
+ # to stop parsing, we do this by forcing the parser
+ # into an accepting state. We will try to create a
+ # child part based on faked start position or recorded
+ # lines, or, if that fails, let the current part have
+ # no children.
+
+ # As an example note the test case mime-3.7 and the
+ # referenced file "badmail1.txt".
+
+ set inP 1
+ if {$fileP} {
+ set start $initialpos
+ } else {
+ set start $tracelines
+ }
+ set forceoctet 1
+ # Fall through. This brings to the creation of the new
+ # part instead of searching further and possible
+ # running over the end.
+ } else {
+ continue
+ }
+ }
+
+ # Looking for the end of the current part. We accept both a
+ # terminating boundary and the starting boundary of the next
+ # part as the end of the current part.
+
+ if {[set moreP [string compare $line --$boundary--]] \
+ && $line ne "--$boundary"} {
+ # The current part has not ended, so we record the line
+ # if we are inside a part and doing string parsing.
+ if {$inP && !$fileP} {
+ lappend start $line
+ }
+ continue
+ }
+
+ # The current part has ended. We now determine the exact
+ # boundaries, create a mime part object for it and recursively
+ # parse it deeper as part of that action.
+
+ # FRINK: nocheck
+ variable [set child $token-[incr state(cid)]]
+
+ lappend state(parts) $child
+
+ set nochild 0
+ if {$fileP} {
+ if {[set count [expr {$pos - ($start + $x + $crlf + 1)}]] < 0} {
+ set count 0
+ }
+ if {$forceoctet} {
+ set ::errorInfo {}
+ if {[catch {
+ mime::initializeaux $child \
+ -file $state(file) -root $state(root) \
+ -offset $start -count $count
+ }]} {
+ set nochild 1
+ set state(parts) [lrange $state(parts) 0 end-1]
+ } } else {
+ mime::initializeaux $child \
+ -file $state(file) -root $state(root) \
+ -offset $start -count $count
+ }
+ seek $state(fd) [set start $pos] start
+ } else {
+ if {$forceoctet} {
+ if {[catch {
+ mime::initializeaux $child -lineslist $start
+ }]} {
+ set nochild 1
+ set state(parts) [lrange $state(parts) 0 end-1]
+ }
+ } else {
+ mime::initializeaux $child -lineslist $start
+ }
+ set start {}
+ }
+ if {$forceoctet && !$nochild} {
+ variable $child
+ upvar 0 $child childstate
+ set childstate(content) application/octet-stream
+ }
+ set forceoctet 0
+ }
+}
+
+# ::mime::parsetype --
+#
+# Parses the string passed in and identifies the content-type and
+# params strings.
+#
+# Arguments:
+# token The MIME token to parse.
+# string The content-type string that should be parsed.
+#
+# Results:
+# Returns the content and params for the string as a two element
+# tcl list.
+
+proc ::mime::parsetype {token string} {
+ global errorCode errorInfo
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ variable typetokenL
+ variable typelexemeL
+
+ set state(input) $string
+ set state(buffer) {}
+ set state(lastC) LX_END
+ set state(comment) {}
+ set state(tokenL) $typetokenL
+ set state(lexemeL) $typelexemeL
+
+ set code [catch {mime::parsetypeaux $token $string} result]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ unset state(input) \
+ state(buffer) \
+ state(lastC) \
+ state(comment) \
+ state(tokenL) \
+ state(lexemeL)
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+}
+
+# ::mime::parsetypeaux --
+#
+# A helper function for mime::parsetype. Parses the specified
+# string looking for the content type and params.
+#
+# Arguments:
+# token The MIME token to parse.
+# string The content-type string that should be parsed.
+#
+# Results:
+# Returns the content and params for the string as a two element
+# tcl list.
+
+proc ::mime::parsetypeaux {token string} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {[parselexeme $token] ne "LX_ATOM"} {
+ error [format "expecting type (found %s)" $state(buffer)]
+ }
+ set type [string tolower $state(buffer)]
+
+ switch -- [parselexeme $token] {
+ LX_SOLIDUS {
+ }
+
+ LX_END {
+ if {$type ne "message"} {
+ error "expecting type/subtype (found $type)"
+ }
+
+ return [list message/rfc822 {}]
+ }
+
+ default {
+ error [format "expecting \"/\" (found %s)" $state(buffer)]
+ }
+ }
+
+ if {[parselexeme $token] ne "LX_ATOM"} {
+ error [format "expecting subtype (found %s)" $state(buffer)]
+ }
+ append type [string tolower /$state(buffer)]
+
+ array set params {}
+ while {1} {
+ switch -- [parselexeme $token] {
+ LX_END {
+ return [list $type [array get params]]
+ }
+
+ LX_SEMICOLON {
+ }
+
+ default {
+ error [format "expecting \";\" (found %s)" $state(buffer)]
+ }
+ }
+
+ switch -- [parselexeme $token] {
+ LX_END {
+ return [list $type [array get params]]
+ }
+
+ LX_ATOM {
+ }
+
+ default {
+ error [format "expecting attribute (found %s)" $state(buffer)]
+ }
+ }
+
+ set attribute [string tolower $state(buffer)]
+
+ if {[parselexeme $token] ne "LX_EQUALS"} {
+ error [format "expecting \"=\" (found %s)" $state(buffer)]
+ }
+
+ switch -- [parselexeme $token] {
+ LX_ATOM {
+ }
+
+ LX_QSTRING {
+ set state(buffer) [
+ string range $state(buffer) 1 [
+ expr {[string length $state(buffer)] - 2}]]
+ }
+
+ default {
+ error [format "expecting value (found %s)" $state(buffer)]
+ }
+ }
+ set params($attribute) $state(buffer)
+ }
+}
+
+# ::mime::finalize --
+#
+# mime::finalize destroys a MIME part.
+#
+# If the -subordinates option is present, it specifies which
+# subordinates should also be destroyed. The default value is
+# "dynamic".
+#
+# Arguments:
+# token The MIME token to parse.
+# args Args can be optionally be of the following form:
+# ?-subordinates "all" | "dynamic" | "none"?
+#
+# Results:
+# Returns an empty string.
+
+proc ::mime::finalize {token args} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set options [list -subordinates dynamic]
+ array set options $args
+
+ switch -- $options(-subordinates) {
+ all {
+ #TODO: this code path is untested
+ if {$state(value) eq "parts"} {
+ foreach part $state(parts) {
+ eval [linsert $args 0 mime::finalize $part]
+ }
+ }
+ }
+
+ dynamic {
+ for {set cid $state(cid)} {$cid > 0} {incr cid -1} {
+ eval [linsert $args 0 mime::finalize $token-$cid]
+ }
+ }
+
+ none {
+ }
+
+ default {
+ error "unknown value for -subordinates $options(-subordinates)"
+ }
+ }
+
+ foreach name [array names state] {
+ unset state($name)
+ }
+ # FRINK: nocheck
+ unset $token
+}
+
+# ::mime::getproperty --
+#
+# mime::getproperty returns the properties of a MIME part.
+#
+# The properties are:
+#
+# property value
+# ======== =====
+# content the type/subtype describing the content
+# encoding the "Content-Transfer-Encoding"
+# params a list of "Content-Type" parameters
+# parts a list of tokens for the part's subordinates
+# size the approximate size of the content (unencoded)
+#
+# The "parts" property is present only if the MIME part has
+# subordinates.
+#
+# If mime::getproperty is invoked with the name of a specific
+# property, then the corresponding value is returned; instead, if
+# -names is specified, a list of all properties is returned;
+# otherwise, a serialized array of properties and values is returned.
+#
+# Arguments:
+# token The MIME token to parse.
+# property One of 'content', 'encoding', 'params', 'parts', and
+# 'size'. Defaults to returning a serialized array of
+# properties and values.
+#
+# Results:
+# Returns the properties of a MIME part
+
+proc ::mime::getproperty {token {property {}}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ switch -- $property {
+ {} {
+ array set properties [list content $state(content) \
+ encoding $state(encoding) \
+ params $state(params) \
+ size [getsize $token]]
+ if {[info exists state(parts)]} {
+ set properties(parts) $state(parts)
+ }
+
+ return [array get properties]
+ }
+
+ -names {
+ set names [list content encoding params]
+ if {[info exists state(parts)]} {
+ lappend names parts
+ }
+
+ return $names
+ }
+
+ content
+ -
+ encoding
+ -
+ params {
+ return $state($property)
+ }
+
+ parts {
+ if {![info exists state(parts)]} {
+ error "MIME part is a leaf"
+ }
+
+ return $state(parts)
+ }
+
+ size {
+ return [getsize $token]
+ }
+
+ default {
+ error "unknown property $property"
+ }
+ }
+}
+
+# ::mime::getsize --
+#
+# Determine the size (in bytes) of a MIME part/token
+#
+# Arguments:
+# token The MIME token to parse.
+#
+# Results:
+# Returns the size in bytes of the MIME token.
+
+proc ::mime::getsize {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ switch -- $state(value)/$state(canonicalP) {
+ file/0 {
+ set size $state(count)
+ }
+
+ file/1 {
+ return [file size $state(file)]
+ }
+
+ parts/0
+ -
+ parts/1 {
+ set size 0
+ foreach part $state(parts) {
+ incr size [getsize $part]
+ }
+
+ return $size
+ }
+
+ string/0 {
+ set size [string length $state(string)]
+ }
+
+ string/1 {
+ return [string length $state(string)]
+ }
+ default {
+ error "Unknown combination \"$state(value)/$state(canonicalP)\""
+ }
+ }
+
+ if {$state(encoding) eq "base64"} {
+ set size [expr {($size * 3 + 2) / 4}]
+ }
+
+ return $size
+}
+
+# ::mime::getheader --
+#
+# mime::getheader returns the header of a MIME part.
+#
+# A header consists of zero or more key/value pairs. Each value is a
+# list containing one or more strings.
+#
+# If mime::getheader is invoked with the name of a specific key, then
+# a list containing the corresponding value(s) is returned; instead,
+# if -names is specified, a list of all keys is returned; otherwise, a
+# serialized array of keys and values is returned. Note that when a
+# key is specified (e.g., "Subject"), the list returned usually
+# contains exactly one string; however, some keys (e.g., "Received")
+# often occur more than once in the header, accordingly the list
+# returned usually contains more than one string.
+#
+# Arguments:
+# token The MIME token to parse.
+# key Either a key or '-names'. If it is '-names' a list
+# of all keys is returned.
+#
+# Results:
+# Returns the header of a MIME part.
+
+proc ::mime::getheader {token {key {}}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set header $state(header)
+ switch -- $key {
+ {} {
+ set result {}
+ foreach lower $state(lowerL) mixed $state(mixedL) {
+ lappend result $mixed $header($lower)
+ }
+ return $result
+ }
+
+ -names {
+ return $state(mixedL)
+ }
+
+ default {
+ set lower [string tolower [set mixed $key]]
+
+ if {![info exists header($lower)]} {
+ error "key $mixed not in header"
+ }
+ return $header($lower)
+ }
+ }
+}
+
+# ::mime::setheader --
+#
+# mime::setheader writes, appends to, or deletes the value associated
+# with a key in the header.
+#
+# The value for -mode is one of:
+#
+# write: the key/value is either created or overwritten (the
+# default);
+#
+# append: a new value is appended for the key (creating it as
+# necessary); or,
+#
+# delete: all values associated with the key are removed (the
+# "value" parameter is ignored).
+#
+# Regardless, mime::setheader returns the previous value associated
+# with the key.
+#
+# Arguments:
+# token The MIME token to parse.
+# key The name of the key whose value should be set.
+# value The value for the header key to be set to.
+# args An optional argument of the form:
+# ?-mode "write" | "append" | "delete"?
+#
+# Results:
+# Returns previous value associated with the specified key.
+
+proc ::mime::setheader {token key value args} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set options [list -mode write]
+ array set options $args
+
+ switch -- [set lower [string tolower $key]] {
+ content-md5
+ -
+ content-type
+ -
+ content-transfer-encoding
+ -
+ mime-version {
+ error "key $key may not be set"
+ }
+ default {# Skip key}
+ }
+
+ array set header $state(header)
+ if {[set x [lsearch -exact $state(lowerL) $lower]] < 0} {
+ #TODO: this code path is not tested
+ if {$options(-mode) eq "delete"} {
+ error "key $key not in header"
+ }
+
+ lappend state(lowerL) $lower
+ lappend state(mixedL) $key
+
+ set result {}
+ } else {
+ set result $header($lower)
+ }
+ switch -- $options(-mode) {
+ append {
+ lappend header($lower) $value
+ }
+
+ delete {
+ unset header($lower)
+ set state(lowerL) [lreplace $state(lowerL) $x $x]
+ set state(mixedL) [lreplace $state(mixedL) $x $x]
+ }
+
+ write {
+ set header($lower) [list $value]
+ }
+
+ default {
+ error "unknown value for -mode $options(-mode)"
+ }
+ }
+
+ set state(header) [array get header]
+
+ return $result
+}
+
+# ::mime::getbody --
+#
+# mime::getbody returns the body of a leaf MIME part in canonical form.
+#
+# If the -command option is present, then it is repeatedly invoked
+# with a fragment of the body as this:
+#
+# uplevel #0 $callback [list "data" $fragment]
+#
+# (The -blocksize option, if present, specifies the maximum size of
+# each fragment passed to the callback.)
+# When the end of the body is reached, the callback is invoked as:
+#
+# uplevel #0 $callback "end"
+#
+# Alternatively, if an error occurs, the callback is invoked as:
+#
+# uplevel #0 $callback [list "error" reason]
+#
+# Regardless, the return value of the final invocation of the callback
+# is propagated upwards by mime::getbody.
+#
+# If the -command option is absent, then the return value of
+# mime::getbody is a string containing the MIME part's entire body.
+#
+# Arguments:
+# token The MIME token to parse.
+# args Optional arguments of the form:
+# ?-decode? ?-command callback ?-blocksize octets? ?
+#
+# Results:
+# Returns a string containing the MIME part's entire body, or
+# if '-command' is specified, the return value of the command
+# is returned.
+
+proc ::mime::getbody {token args} {
+ global errorCode errorInfo
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set decode 0
+ if {[set pos [lsearch -exact $args -decode]] >= 0} {
+ set decode 1
+ set args [lreplace $args $pos $pos]
+ }
+
+ array set options [list -command [
+ list mime::getbodyaux $token] -blocksize 4096]
+ array set options $args
+ if {$options(-blocksize) < 1} {
+ error "-blocksize expects a positive integer, not $options(-blocksize)"
+ }
+
+ set code 0
+ set ecode {}
+ set einfo {}
+
+ switch -- $state(value)/$state(canonicalP) {
+ file/0 {
+ set fd [open $state(file) RDONLY]
+
+ set code [catch {
+ fconfigure $fd -translation binary
+ seek $fd [set pos $state(offset)] start
+ set last [expr {$state(offset) + $state(count) - 1}]
+
+ set fragment {}
+ while {$pos <= $last} {
+ if {[set cc [
+ expr {($last - $pos) + 1}]] > $options(-blocksize)} {
+ set cc $options(-blocksize)
+ }
+ incr pos [set len [
+ string length [set chunk [read $fd $cc]]]]
+ switch -exact -- $state(encoding) {
+ base64
+ -
+ quoted-printable {
+ if {([set x [string last \n $chunk]] > 0) \
+ && ($x + 1 != $len)} {
+ set chunk [string range $chunk 0 $x]
+ seek $fd [incr pos [expr {($x + 1) - $len}]] start
+ }
+ set chunk [
+ $state(encoding) -mode decode -- $chunk]
+ }
+ 7bit - 8bit - binary - {} {
+ # Bugfix for [#477088]
+ # Go ahead, leave chunk alone
+ }
+ default {
+ error "Can't handle content encoding \"$state(encoding)\""
+ }
+ }
+ append fragment $chunk
+
+ set cc [expr {$options(-blocksize) - 1}]
+ while {[string length $fragment] > $options(-blocksize)} {
+ uplevel #0 $options(-command) [
+ list data [string range $fragment 0 $cc]]
+
+ set fragment [
+ string range $fragment $options(-blocksize) end]
+ }
+ }
+ if {[string length $fragment] > 0} {
+ uplevel #0 $options(-command) [list data $fragment]
+ }
+ } result]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ catch {close $fd}
+ }
+
+ file/1 {
+ set fd [open $state(file) RDONLY]
+
+ set code [catch {
+ fconfigure $fd -translation binary
+
+ while {[string length [
+ set fragment [read $fd $options(-blocksize)]]] > 0} {
+ uplevel #0 $options(-command) [list data $fragment]
+ }
+ } result]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ catch {close $fd}
+ }
+
+ parts/0
+ -
+ parts/1 {
+ error "MIME part isn't a leaf"
+ }
+
+ string/0
+ -
+ string/1 {
+ switch -- $state(encoding)/$state(canonicalP) {
+ base64/0
+ -
+ quoted-printable/0 {
+ set fragment [
+ $state(encoding) -mode decode -- $state(string)]
+ }
+
+ default {
+ # Not a bugfix for [#477088], but clarification
+ # This handles no-encoding, 7bit, 8bit, and binary.
+ set fragment $state(string)
+ }
+ }
+
+ set code [catch {
+ set cc [expr {$options(-blocksize) -1}]
+ while {[string length $fragment] > $options(-blocksize)} {
+ uplevel #0 $options(-command) [
+ list data [string range $fragment 0 $cc]]
+
+ set fragment [
+ string range $fragment $options(-blocksize) end]
+ }
+ if {[string length $fragment] > 0} {
+ uplevel #0 $options(-command) [list data $fragment]
+ }
+ } result]
+ set ecode $errorCode
+ set einfo $errorInfo
+ }
+ default {
+ error "Unknown combination \"$state(value)/$state(canonicalP)\""
+ }
+ }
+
+ set code [catch {
+ if {$code} {
+ uplevel #0 $options(-command) [list error $result]
+ } else {
+ uplevel #0 $options(-command) [list end]
+ }
+ } result]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ if {$code} {
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+ }
+
+ if {$decode} {
+ array set params [mime::getproperty $token params]
+
+ if {[info exists params(charset)]} {
+ set charset $params(charset)
+ } else {
+ set charset US-ASCII
+ }
+
+ set enc [reversemapencoding $charset]
+ if {$enc ne {}} {
+ set result [::encoding convertfrom $enc $result]
+ } else {
+ return -code error "-decode failed: can't reversemap charset $charset"
+ }
+ }
+
+ return $result
+}
+
+# ::mime::getbodyaux --
+#
+# Builds up the body of the message, fragment by fragment. When
+# the entire message has been retrieved, it is returned.
+#
+# Arguments:
+# token The MIME token to parse.
+# reason One of 'data', 'end', or 'error'.
+# fragment The section of data data fragment to extract a
+# string from.
+#
+# Results:
+# Returns nothing, except when called with the 'end' argument
+# in which case it returns a string that contains all of the
+# data that 'getbodyaux' has been called with. Will throw an
+# error if it is called with the reason of 'error'.
+
+proc ::mime::getbodyaux {token reason {fragment {}}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ switch $reason {
+ data {
+ append state(getbody) $fragment
+ return {}
+ }
+
+ end {
+ if {[info exists state(getbody)]} {
+ set result $state(getbody)
+ unset state(getbody)
+ } else {
+ set result {}
+ }
+
+ return $result
+ }
+
+ error {
+ catch {unset state(getbody)}
+ error $reason
+ }
+
+ default {
+ error "Unknown reason \"$reason\""
+ }
+ }
+}
+
+# ::mime::copymessage --
+#
+# mime::copymessage copies the MIME part to the specified channel.
+#
+# mime::copymessage operates synchronously, and uses fileevent to
+# allow asynchronous operations to proceed independently.
+#
+# Arguments:
+# token The MIME token to parse.
+# channel The channel to copy the message to.
+#
+# Results:
+# Returns nothing unless an error is thrown while the message
+# is being written to the channel.
+
+proc ::mime::copymessage {token channel} {
+ global errorCode errorInfo
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set openP [info exists state(fd)]
+
+ set code [catch {mime::copymessageaux $token $channel} result]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ if {(!$openP) && ([info exists state(fd)])} {
+ if {![info exists state(root)]} {
+ catch {close $state(fd)}
+ }
+ unset state(fd)
+ }
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+}
+
+# ::mime::copymessageaux --
+#
+# mime::copymessageaux copies the MIME part to the specified channel.
+#
+# Arguments:
+# token The MIME token to parse.
+# channel The channel to copy the message to.
+#
+# Results:
+# Returns nothing unless an error is thrown while the message
+# is being written to the channel.
+
+proc ::mime::copymessageaux {token channel} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set header $state(header)
+
+ if {$state(version) ne {}} {
+ puts $channel "MIME-Version: $state(version)"
+ }
+ foreach lower $state(lowerL) mixed $state(mixedL) {
+ foreach value $header($lower) {
+ puts $channel "$mixed: $value"
+ }
+ }
+ if {(!$state(canonicalP)) \
+ && ([set encoding $state(encoding)] ne {})} {
+ puts $channel "Content-Transfer-Encoding: $encoding"
+ }
+
+ puts -nonewline $channel "Content-Type: $state(content)"
+ set boundary {}
+ foreach {k v} $state(params) {
+ if {$k eq "boundary"} {
+ set boundary $v
+ }
+
+ puts -nonewline $channel ";\n $k=\"$v\""
+ }
+
+ set converter {}
+ set encoding {}
+ if {$state(value) ne "parts"} {
+ puts $channel {}
+
+ if {$state(canonicalP)} {
+ if {[set encoding $state(encoding)] eq {}} {
+ set encoding [encoding $token]
+ }
+ if {$encoding ne {}} {
+ puts $channel "Content-Transfer-Encoding: $encoding"
+ }
+ switch -- $encoding {
+ base64
+ -
+ quoted-printable {
+ set converter $encoding
+ }
+ 7bit - 8bit - binary - {} {
+ # Bugfix for [#477088], also [#539952]
+ # Go ahead
+ }
+ default {
+ error "Can't handle content encoding \"$encoding\""
+ }
+ }
+ }
+ } elseif {([string match multipart/* $state(content)]) \
+ && ($boundary eq {})} {
+ # we're doing everything in one pass...
+ set key [clock seconds]$token[info hostname][array get state]
+ set seqno 8
+ while {[incr seqno -1] >= 0} {
+ set key [md5 -- $key]
+ }
+ set boundary "----- =_[string trim [base64 -mode encode -- $key]]"
+
+ puts $channel ";\n boundary=\"$boundary\""
+ } else {
+ puts $channel {}
+ }
+
+ if {[info exists state(error)]} {
+ unset state(error)
+ }
+
+ switch -- $state(value) {
+ file {
+ set closeP 1
+ if {[info exists state(root)]} {
+ # FRINK: nocheck
+ variable $state(root)
+ upvar 0 $state(root) root
+
+ if {[info exists root(fd)]} {
+ set fd $root(fd)
+ set closeP 0
+ } else {
+ set fd [set state(fd) [open $state(file) RDONLY]]
+ }
+ set size $state(count)
+ } else {
+ set fd [set state(fd) [open $state(file) RDONLY]]
+ # read until eof
+ set size -1
+ }
+ seek $fd $state(offset) start
+ if {$closeP} {
+ fconfigure $fd -translation binary
+ }
+
+ puts $channel {}
+
+ while {($size != 0) && (![eof $fd])} {
+ if {$size < 0 || $size > 32766} {
+ set X [read $fd 32766]
+ } else {
+ set X [read $fd $size]
+ }
+ if {$size > 0} {
+ set size [expr {$size - [string length $X]}]
+ }
+ if {$converter eq {}} {
+ puts -nonewline $channel $X
+ } else {
+ puts -nonewline $channel [$converter -mode encode -- $X]
+ }
+ }
+
+ if {$closeP} {
+ catch {close $state(fd)}
+ unset state(fd)
+ }
+ }
+
+ parts {
+ if {(![info exists state(root)]) \
+ && ([info exists state(file)])} {
+ set state(fd) [open $state(file) RDONLY]
+ fconfigure $state(fd) -translation binary
+ }
+
+ switch -glob -- $state(content) {
+ message/* {
+ puts $channel {}
+ foreach part $state(parts) {
+ mime::copymessage $part $channel
+ break
+ }
+ }
+
+ default {
+ # Note RFC 2046: See buildmessageaux for details.
+
+ foreach part $state(parts) {
+ puts $channel \n--$boundary
+ mime::copymessage $part $channel
+ }
+ puts $channel \n--$boundary--
+ }
+ }
+
+ if {[info exists state(fd)]} {
+ catch {close $state(fd)}
+ unset state(fd)
+ }
+ }
+
+ string {
+ if {[catch {fconfigure $channel -buffersize} blocksize]} {
+ set blocksize 4096
+ } elseif {$blocksize < 512} {
+ set blocksize 512
+ }
+ set blocksize [expr {($blocksize / 4) * 3}]
+
+ # [893516]
+ fconfigure $channel -buffersize $blocksize
+
+ puts $channel {}
+
+ #TODO: tests don't cover these paths
+ if {$converter eq {}} {
+ puts -nonewline $channel $state(string)
+ } else {
+ puts -nonewline $channel [$converter -mode encode -- $state(string)]
+ }
+ }
+ default {
+ error "Unknown value \"$state(value)\""
+ }
+ }
+
+ flush $channel
+
+ if {[info exists state(error)]} {
+ error $state(error)
+ }
+}
+
+# ::mime::buildmessage --
+#
+# The following is a clone of the copymessage code to build up the
+# result in memory, and, unfortunately, without using a memory channel.
+# I considered parameterizing the "puts" calls in copy message, but
+# the need for this procedure may go away, so I'm living with it for
+# the moment.
+#
+# Arguments:
+# token The MIME token to parse.
+#
+# Results:
+# Returns the message that has been built up in memory.
+
+proc ::mime::buildmessage {token} {
+ global errorCode errorInfo
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set openP [info exists state(fd)]
+
+ set code [catch {mime::buildmessageaux $token} result]
+ if {![info exists errorCode]} {
+ set ecode {}
+ } else {
+ set ecode $errorCode
+ }
+ set einfo $errorInfo
+
+ if {(!$openP) && ([info exists state(fd)])} {
+ if {![info exists state(root)]} {
+ catch {close $state(fd)}
+ }
+ unset state(fd)
+ }
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+}
+
+# ::mime::buildmessageaux --
+#
+# The following is a clone of the copymessageaux code to build up the
+# result in memory, and, unfortunately, without using a memory channel.
+# I considered parameterizing the "puts" calls in copy message, but
+# the need for this procedure may go away, so I'm living with it for
+# the moment.
+#
+# Arguments:
+# token The MIME token to parse.
+#
+# Results:
+# Returns the message that has been built up in memory.
+
+proc ::mime::buildmessageaux {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set header $state(header)
+
+ set result {}
+ if {$state(version) ne {}} {
+ append result "MIME-Version: $state(version)\r\n"
+ }
+ foreach lower $state(lowerL) mixed $state(mixedL) {
+ foreach value $header($lower) {
+ append result "$mixed: $value\r\n"
+ }
+ }
+ if {(!$state(canonicalP)) \
+ && ([set encoding $state(encoding)] ne {})} {
+ append result "Content-Transfer-Encoding: $encoding\r\n"
+ }
+
+ append result "Content-Type: $state(content)"
+ set boundary {}
+ foreach {k v} $state(params) {
+ if {$k eq "boundary"} {
+ set boundary $v
+ }
+
+ append result ";\r\n $k=\"$v\""
+ }
+
+ set converter {}
+ set encoding {}
+ if {$state(value) ne "parts"} {
+ #TODO: the path is not covered by tests
+ append result \r\n
+
+ if {$state(canonicalP)} {
+ if {[set encoding $state(encoding)] eq {}} {
+ set encoding [encoding $token]
+ }
+ if {$encoding ne {}} {
+ append result "Content-Transfer-Encoding: $encoding\r\n"
+ }
+ switch -- $encoding {
+ base64
+ -
+ quoted-printable {
+ set converter $encoding
+ }
+ 7bit - 8bit - binary - {} {
+ # Bugfix for [#477088]
+ # Go ahead
+ }
+ default {
+ error "Can't handle content encoding \"$encoding\""
+ }
+ }
+ }
+ } elseif {([string match multipart/* $state(content)]) \
+ && ($boundary eq {})} {
+ # we're doing everything in one pass...
+ set key [clock seconds]$token[info hostname][array get state]
+ set seqno 8
+ while {[incr seqno -1] >= 0} {
+ set key [md5 -- $key]
+ }
+ set boundary "----- =_[string trim [base64 -mode encode -- $key]]"
+
+ append result ";\r\n boundary=\"$boundary\"\r\n"
+ } else {
+ append result \r\n
+ }
+
+ if {[info exists state(error)]} {
+ unset state(error)
+ }
+
+ switch -- $state(value) {
+ file {
+ set closeP 1
+ if {[info exists state(root)]} {
+ # FRINK: nocheck
+ variable $state(root)
+ upvar 0 $state(root) root
+
+ if {[info exists root(fd)]} {
+ set fd $root(fd)
+ set closeP 0
+ } else {
+ set fd [set state(fd) [open $state(file) RDONLY]]
+ }
+ set size $state(count)
+ } else {
+ set fd [set state(fd) [open $state(file) RDONLY]]
+ set size -1 ;# Read until EOF
+ }
+ seek $fd $state(offset) start
+ if {$closeP} {
+ fconfigure $fd -translation binary
+ }
+
+ append result \r\n
+
+ while {($size != 0) && (![eof $fd])} {
+ if {$size < 0 || $size > 32766} {
+ set X [read $fd 32766]
+ } else {
+ set X [read $fd $size]
+ }
+ if {$size > 0} {
+ set size [expr {$size - [string length $X]}]
+ }
+ if {$converter ne {}} {
+ append result [$converter -mode encode -- $X]
+ } else {
+ append result $X
+ }
+ }
+
+ if {$closeP} {
+ catch {close $state(fd)}
+ unset state(fd)
+ }
+ }
+
+ parts {
+ if {(![info exists state(root)]) \
+ && ([info exists state(file)])} {
+ set state(fd) [open $state(file) RDONLY]
+ fconfigure $state(fd) -translation binary
+ }
+
+ switch -glob -- $state(content) {
+ message/* {
+ append result "\r\n"
+ foreach part $state(parts) {
+ append result [buildmessage $part]
+ break
+ }
+ }
+
+ default {
+ # Note RFC 2046:
+ #
+ # The boundary delimiter MUST occur at the
+ # beginning of a line, i.e., following a CRLF, and
+ # the initial CRLF is considered to be attached to
+ # the boundary delimiter line rather than part of
+ # the preceding part.
+ #
+ # - The above means that the CRLF before $boundary
+ # is needed per the RFC, and the parts must not
+ # have a closing CRLF of their own. See Tcllib bug
+ # 1213527, and patch 1254934 for the problems when
+ # both file/string brnaches added CRLF after the
+ # body parts.
+
+ foreach part $state(parts) {
+ append result "\r\n--$boundary\r\n"
+ append result [buildmessage $part]
+ }
+ append result "\r\n--$boundary--\r\n"
+ }
+ }
+
+ if {[info exists state(fd)]} {
+ catch {close $state(fd)}
+ unset state(fd)
+ }
+ }
+
+ string {
+ append result "\r\n"
+
+ if {$converter ne {}} {
+ append result [$converter -mode encode -- $state(string)]
+ } else {
+ append result $state(string)
+ }
+ }
+ default {
+ error "Unknown value \"$state(value)\""
+ }
+ }
+
+ if {[info exists state(error)]} {
+ error $state(error)
+ }
+ return $result
+}
+
+# ::mime::encoding --
+#
+# Determines how a token is encoded.
+#
+# Arguments:
+# token The MIME token to parse.
+#
+# Results:
+# Returns the encoding of the message (the null string, base64,
+# or quoted-printable).
+
+proc ::mime::encoding {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ switch -glob -- $state(content) {
+ audio/*
+ -
+ image/*
+ -
+ video/* {
+ return base64
+ }
+
+ message/*
+ -
+ multipart/* {
+ return {}
+ }
+ default {# Skip}
+ }
+
+ set asciiP 1
+ set lineP 1
+ switch -- $state(value) {
+ file {
+ set fd [open $state(file) RDONLY]
+ fconfigure $fd -translation binary
+
+ while {[gets $fd line] >= 0} {
+ if {$asciiP} {
+ set asciiP [encodingasciiP $line]
+ }
+ if {$lineP} {
+ set lineP [encodinglineP $line]
+ }
+ if {(!$asciiP) && (!$lineP)} {
+ break
+ }
+ }
+
+ catch {close $fd}
+ }
+
+ parts {
+ return {}
+ }
+
+ string {
+ foreach line [split $state(string) "\n"] {
+ if {$asciiP} {
+ set asciiP [encodingasciiP $line]
+ }
+ if {$lineP} {
+ set lineP [encodinglineP $line]
+ }
+ if {(!$asciiP) && (!$lineP)} {
+ break
+ }
+ }
+ }
+ default {
+ error "Unknown value \"$state(value)\""
+ }
+ }
+
+ switch -glob -- $state(content) {
+ text/* {
+ if {!$asciiP} {
+ #TODO: this path is not covered by tests
+ foreach {k v} $state(params) {
+ if {$k eq "charset"} {
+ set v [string tolower $v]
+ if {($v ne "us-ascii") \
+ && (![string match {iso-8859-[1-8]} $v])} {
+ return base64
+ }
+
+ break
+ }
+ }
+ }
+
+ if {!$lineP} {
+ return quoted-printable
+ }
+ }
+
+
+ default {
+ if {(!$asciiP) || (!$lineP)} {
+ return base64
+ }
+ }
+ }
+
+ return {}
+}
+
+# ::mime::encodingasciiP --
+#
+# Checks if a string is a pure ascii string, or if it has a non-standard
+# form.
+#
+# Arguments:
+# line The line to check.
+#
+# Results:
+# Returns 1 if \r only occurs at the end of lines, and if all
+# characters in the line are between the ASCII codes of 32 and 126.
+
+proc ::mime::encodingasciiP {line} {
+ foreach c [split $line {}] {
+ switch -- $c {
+ { } - \t - \r - \n {
+ }
+
+ default {
+ binary scan $c c c
+ if {($c < 32) || ($c > 126)} {
+ return 0
+ }
+ }
+ }
+ }
+ if {([set r [string first \r $line]] < 0) \
+ || ($r == {[string length $line] - 1})} {
+ return 1
+ }
+
+ return 0
+}
+
+# ::mime::encodinglineP --
+#
+# Checks if a string is a line is valid to be processed.
+#
+# Arguments:
+# line The line to check.
+#
+# Results:
+# Returns 1 the line is less than 76 characters long, the line
+# contains more characters than just whitespace, the line does
+# not start with a '.', and the line does not start with 'From '.
+
+proc ::mime::encodinglineP {line} {
+ if {([string length $line] > 76) \
+ || ($line ne [string trimright $line]) \
+ || ([string first . $line] == 0) \
+ || ([string first {From } $line] == 0)} {
+ return 0
+ }
+
+ return 1
+}
+
+# ::mime::fcopy --
+#
+# Appears to be unused.
+#
+# Arguments:
+#
+# Results:
+#
+
+proc ::mime::fcopy {token count {error {}}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {$error ne {}} {
+ set state(error) $error
+ }
+ set state(doneP) 1
+}
+
+# ::mime::scopy --
+#
+# Copy a portion of the contents of a mime token to a channel.
+#
+# Arguments:
+# token The token containing the data to copy.
+# channel The channel to write the data to.
+# offset The location in the string to start copying
+# from.
+# len The amount of data to write.
+# blocksize The block size for the write operation.
+#
+# Results:
+# The specified portion of the string in the mime token is
+# copied to the specified channel.
+
+proc ::mime::scopy {token channel offset len blocksize} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {$len <= 0} {
+ set state(doneP) 1
+ fileevent $channel writable {}
+ return
+ }
+
+ if {[set cc $len] > $blocksize} {
+ set cc $blocksize
+ }
+
+ if {[catch {
+ puts -nonewline $channel [
+ string range $state(string) $offset [expr {$offset + $cc - 1}]]
+ fileevent $channel writable [
+ list mime::scopy $token $channel [
+ incr offset $cc] [incr len -$cc] $blocksize]
+ } result]} {
+
+ set state(error) $result
+ set state(doneP) 1
+ fileevent $channel writable {}
+ }
+ return
+}
+
+# ::mime::qp_encode --
+#
+# Tcl version of quote-printable encode
+#
+# Arguments:
+# string The string to quote.
+# encoded_word Boolean value to determine whether or not encoded words
+# (RFC 2047) should be handled or not. (optional)
+#
+# Results:
+# The properly quoted string is returned.
+
+proc ::mime::qp_encode {string {encoded_word 0} {no_softbreak 0}} {
+ # 8.1+ improved string manipulation routines used.
+ # Replace outlying characters, characters that would normally
+ # be munged by EBCDIC gateways, and special Tcl characters "[\]{}
+ # with =xx sequence
+
+ regsub -all -- \
+ {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF]} \
+ $string {[format =%02X [scan "\\&" %c]]} string
+
+ # Replace the format commands with their result
+
+ set string [subst -novariables $string]
+
+ # soft/hard newlines and other
+ # Funky cases for SMTP compatibility
+ set mapChars [
+ list " \n" =20\n \t\n =09\n \n\.\n \=2E\n "\nFrom " "\n=46rom "]
+ if {$encoded_word} {
+ # Special processing for encoded words (RFC 2047)
+ lappend mapChars { } _
+ }
+ set string [string map $mapChars $string]
+
+ # Break long lines - ugh
+
+ # Implementation of FR #503336
+ if {$no_softbreak} {
+ set result $string
+ } else {
+ set result {}
+ foreach line [split $string \n] {
+ while {[string length $line] > 72} {
+ set chunk [string range $line 0 72]
+ if {[regexp -- (=|=.)$ $chunk dummy end]} {
+
+ # Don't break in the middle of a code
+
+ set len [expr {72 - [string length $end]}]
+ set chunk [string range $line 0 $len]
+ incr len
+ set line [string range $line $len end]
+ } else {
+ set line [string range $line 73 end]
+ }
+ append result $chunk=\n
+ }
+ append result $line\n
+ }
+
+ # Trim off last \n, since the above code has the side-effect
+ # of adding an extra \n to the encoded string and return the
+ # result.
+ set result [string range $result 0 end-1]
+ }
+
+ # If the string ends in space or tab, replace with =xx
+
+ set lastChar [string index $result end]
+ if {$lastChar eq { }} {
+ set result [string replace $result end end =20]
+ } elseif {$lastChar eq "\t"} {
+ set result [string replace $result end end =09]
+ }
+
+ return $result
+}
+
+# ::mime::qp_decode --
+#
+# Tcl version of quote-printable decode
+#
+# Arguments:
+# string The quoted-prinatble string to decode.
+# encoded_word Boolean value to determine whether or not encoded words
+# (RFC 2047) should be handled or not. (optional)
+#
+# Results:
+# The decoded string is returned.
+
+proc ::mime::qp_decode {string {encoded_word 0}} {
+ # 8.1+ improved string manipulation routines used.
+ # Special processing for encoded words (RFC 2047)
+
+ if {$encoded_word} {
+ # _ == \x20, even if SPACE occupies a different code position
+ set string [string map [list _ \u0020] $string]
+ }
+
+ # smash the white-space at the ends of lines since that must've been
+ # generated by an MUA.
+
+ regsub -all -- {[ \t]+\n} $string \n string
+ set string [string trimright $string " \t"]
+
+ # Protect the backslash for later subst and
+ # smash soft newlines, has to occur after white-space smash
+ # and any encoded word modification.
+
+ #TODO: codepath not tested
+ set string [string map [list \\ {\\} =\n {}] $string]
+
+ # Decode specials
+
+ regsub -all -nocase {=([a-f0-9][a-f0-9])} $string {\\u00\1} string
+
+ # process \u unicode mapped chars
+
+ return [subst -novariables -nocommands $string]
+}
+
+# ::mime::parseaddress --
+#
+# This was originally written circa 1982 in C. we're still using it
+# because it recognizes virtually every buggy address syntax ever
+# generated!
+#
+# mime::parseaddress takes a string containing one or more 822-style
+# address specifications and returns a list of serialized arrays, one
+# element for each address specified in the argument.
+#
+# Each serialized array contains these properties:
+#
+# property value
+# ======== =====
+# address local@domain
+# comment 822-style comment
+# domain the domain part (rhs)
+# error non-empty on a parse error
+# group this address begins a group
+# friendly user-friendly rendering
+# local the local part (lhs)
+# memberP this address belongs to a group
+# phrase the phrase part
+# proper 822-style address specification
+# route 822-style route specification (obsolete)
+#
+# Note that one or more of these properties may be empty.
+#
+# Arguments:
+# string The address string to parse
+#
+# Results:
+# Returns a list of serialized arrays, one element for each address
+# specified in the argument.
+
+proc ::mime::parseaddress {string} {
+ global errorCode errorInfo
+
+ variable mime
+
+ set token [namespace current]::[incr mime(uid)]
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set code [catch {mime::parseaddressaux $token $string} result]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ foreach name [array names state] {
+ unset state($name)
+ }
+ # FRINK: nocheck
+ catch {unset $token}
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+}
+
+# ::mime::parseaddressaux --
+#
+# This was originally written circa 1982 in C. we're still using it
+# because it recognizes virtually every buggy address syntax ever
+# generated!
+#
+# mime::parseaddressaux does the actually parsing for mime::parseaddress
+#
+# Each serialized array contains these properties:
+#
+# property value
+# ======== =====
+# address local@domain
+# comment 822-style comment
+# domain the domain part (rhs)
+# error non-empty on a parse error
+# group this address begins a group
+# friendly user-friendly rendering
+# local the local part (lhs)
+# memberP this address belongs to a group
+# phrase the phrase part
+# proper 822-style address specification
+# route 822-style route specification (obsolete)
+#
+# Note that one or more of these properties may be empty.
+#
+# Arguments:
+# token The MIME token to work from.
+# string The address string to parse
+#
+# Results:
+# Returns a list of serialized arrays, one element for each address
+# specified in the argument.
+
+proc ::mime::parseaddressaux {token string} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ variable addrtokenL
+ variable addrlexemeL
+
+ set state(input) $string
+ set state(glevel) 0
+ set state(buffer) {}
+ set state(lastC) LX_END
+ set state(tokenL) $addrtokenL
+ set state(lexemeL) $addrlexemeL
+
+ set result {}
+ while {[addr_next $token]} {
+ if {[set tail $state(domain)] ne {}} {
+ set tail @$state(domain)
+ } else {
+ set tail @[info hostname]
+ }
+ if {[set address $state(local)] ne {}} {
+ #TODO: this path is not covered by tests
+ append address $tail
+ }
+
+ if {$state(phrase) ne {}} {
+ #TODO: this path is not covered by tests
+ set state(phrase) [string trim $state(phrase) \"]
+ foreach t $state(tokenL) {
+ if {[string first $t $state(phrase)] >= 0} {
+ #TODO: is this quoting robust enough?
+ set state(phrase) \"$state(phrase)\"
+ break
+ }
+ }
+
+ set proper "$state(phrase) <$address>"
+ } else {
+ set proper $address
+ }
+
+ if {[set friendly $state(phrase)] eq {}} {
+ #TODO: this path is not covered by tests
+ if {[set note $state(comment)] ne {}} {
+ if {[string first ( $note] == 0} {
+ set note [string trimleft [string range $note 1 end]]
+ }
+ if {[string last ) $note] \
+ == [set len [expr {[string length $note] - 1}]]} {
+ set note [string range $note 0 [expr {$len - 1}]]
+ }
+ set friendly $note
+ }
+
+ if {($friendly eq {}) \
+ && ([set mbox $state(local)] ne {})} {
+ #TODO: this path is not covered by tests
+ set mbox [string trim $mbox \"]
+
+ if {[string first / $mbox] != 0} {
+ set friendly $mbox
+ } elseif {[set friendly [addr_x400 $mbox PN]] ne {}} {
+ } elseif {([set friendly [addr_x400 $mbox S]] ne {}) \
+ && ([set g [addr_x400 $mbox G]] ne {})} {
+ set friendly "$g $friendly"
+ }
+
+ if {$friendly eq {}} {
+ set friendly $mbox
+ }
+ }
+ }
+ set friendly [string trim $friendly \"]
+
+ lappend result [list address $address \
+ comment $state(comment) \
+ domain $state(domain) \
+ error $state(error) \
+ friendly $friendly \
+ group $state(group) \
+ local $state(local) \
+ memberP $state(memberP) \
+ phrase $state(phrase) \
+ proper $proper \
+ route $state(route)]
+
+ }
+
+ unset state(input) \
+ state(glevel) \
+ state(buffer) \
+ state(lastC) \
+ state(tokenL) \
+ state(lexemeL)
+
+ return $result
+}
+
+# ::mime::addr_next --
+#
+# Locate the next address in a mime token.
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns 1 if there is another address, and 0 if there is not.
+
+proc ::mime::addr_next {token} {
+ global errorCode errorInfo
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+ set nocomplain [package vsatisfies [package provide Tcl] 8.4]
+ foreach prop {comment domain error group local memberP phrase route} {
+ if {$nocomplain} {
+ unset -nocomplain state($prop)
+ } else {
+ if {[catch {unset state($prop)}]} {set ::errorInfo {}}
+ }
+ }
+
+ switch -- [set code [catch {mime::addr_specification $token} result]] {
+ 0 {
+ if {!$result} {
+ return 0
+ }
+
+ switch -- $state(lastC) {
+ LX_COMMA
+ -
+ LX_END {
+ }
+ default {
+ # catch trailing comments...
+ set lookahead $state(input)
+ mime::parselexeme $token
+ set state(input) $lookahead
+ }
+ }
+ }
+
+ 7 {
+ set state(error) $result
+
+ while {1} {
+ switch -- $state(lastC) {
+ LX_COMMA
+ -
+ LX_END {
+ break
+ }
+
+ default {
+ mime::parselexeme $token
+ }
+ }
+ }
+ }
+
+ default {
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+ }
+ }
+
+ foreach prop {comment domain error group local memberP phrase route} {
+ if {![info exists state($prop)]} {
+ set state($prop) {}
+ }
+ }
+
+ return 1
+}
+
+# ::mime::addr_specification --
+#
+# Uses lookahead parsing to determine whether there is another
+# valid e-mail address or not. Throws errors if unrecognized
+# or invalid e-mail address syntax is used.
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns 1 if there is another address, and 0 if there is not.
+
+proc ::mime::addr_specification {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set lookahead $state(input)
+ switch -- [parselexeme $token] {
+ LX_ATOM
+ -
+ LX_QSTRING {
+ set state(phrase) $state(buffer)
+ }
+
+ LX_SEMICOLON {
+ if {[incr state(glevel) -1] < 0} {
+ return -code 7 "extraneous semi-colon"
+ }
+
+ catch {unset state(comment)}
+ return [addr_specification $token]
+ }
+
+ LX_COMMA {
+ catch {unset state(comment)}
+ return [addr_specification $token]
+ }
+
+ LX_END {
+ return 0
+ }
+
+ LX_LBRACKET {
+ return [addr_routeaddr $token]
+ }
+
+ LX_ATSIGN {
+ set state(input) $lookahead
+ return [addr_routeaddr $token 0]
+ }
+
+ default {
+ return -code 7 \
+ [format "unexpected character at beginning (found %s)" \
+ $state(buffer)]
+ }
+ }
+
+ switch -- [parselexeme $token] {
+ LX_ATOM
+ -
+ LX_QSTRING {
+ append state(phrase) " " $state(buffer)
+
+ return [addr_phrase $token]
+ }
+
+ LX_LBRACKET {
+ return [addr_routeaddr $token]
+ }
+
+ LX_COLON {
+ return [addr_group $token]
+ }
+
+ LX_DOT {
+ set state(local) "$state(phrase)$state(buffer)"
+ unset state(phrase)
+ mime::addr_routeaddr $token 0
+ mime::addr_end $token
+ }
+
+ LX_ATSIGN {
+ set state(memberP) $state(glevel)
+ set state(local) $state(phrase)
+ unset state(phrase)
+ mime::addr_domain $token
+ mime::addr_end $token
+ }
+
+ LX_SEMICOLON
+ -
+ LX_COMMA
+ -
+ LX_END {
+ set state(memberP) $state(glevel)
+ if {($state(lastC) eq "LX_SEMICOLON") \
+ && ([incr state(glevel) -1] < 0)} {
+ #TODO: this path is not covered by tests
+ return -code 7 "extraneous semi-colon"
+ }
+
+ set state(local) $state(phrase)
+ unset state(phrase)
+ }
+
+ default {
+ return -code 7 [
+ format "expecting mailbox (found %s)" $state(buffer)]
+ }
+ }
+
+ return 1
+}
+
+# ::mime::addr_routeaddr --
+#
+# Parses the domain portion of an e-mail address. Finds the '@'
+# sign and then calls mime::addr_route to verify the domain.
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns 1 if there is another address, and 0 if there is not.
+
+proc ::mime::addr_routeaddr {token {checkP 1}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set lookahead $state(input)
+ if {[parselexeme $token] eq "LX_ATSIGN"} {
+ #TODO: this path is not covered by tests
+ mime::addr_route $token
+ } else {
+ set state(input) $lookahead
+ }
+
+ mime::addr_local $token
+
+ switch -- $state(lastC) {
+ LX_ATSIGN {
+ mime::addr_domain $token
+ }
+
+ LX_SEMICOLON
+ -
+ LX_RBRACKET
+ -
+ LX_COMMA
+ -
+ LX_END {
+ }
+
+ default {
+ return -code 7 [
+ format "expecting at-sign after local-part (found %s)" \
+ $state(buffer)]
+ }
+ }
+
+ if {($checkP) && ($state(lastC) ne "LX_RBRACKET")} {
+ return -code 7 [
+ format "expecting right-bracket (found %s)" $state(buffer)]
+ }
+
+ return 1
+}
+
+# ::mime::addr_route --
+#
+# Attempts to parse the portion of the e-mail address after the @.
+# Tries to verify that the domain definition has a valid form.
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns nothing if successful, and throws an error if invalid
+# syntax is found.
+
+proc ::mime::addr_route {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set state(route) @
+
+ while {1} {
+ switch -- [parselexeme $token] {
+ LX_ATOM
+ -
+ LX_DLITERAL {
+ append state(route) $state(buffer)
+ }
+
+ default {
+ return -code 7 \
+ [format "expecting sub-route in route-part (found %s)" \
+ $state(buffer)]
+ }
+ }
+
+ switch -- [parselexeme $token] {
+ LX_COMMA {
+ append state(route) $state(buffer)
+ while {1} {
+ switch -- [parselexeme $token] {
+ LX_COMMA {
+ }
+
+ LX_ATSIGN {
+ append state(route) $state(buffer)
+ break
+ }
+
+ default {
+ return -code 7 \
+ [format "expecting at-sign in route (found %s)" \
+ $state(buffer)]
+ }
+ }
+ }
+ }
+
+ LX_ATSIGN
+ -
+ LX_DOT {
+ append state(route) $state(buffer)
+ }
+
+ LX_COLON {
+ append state(route) $state(buffer)
+ return
+ }
+
+ default {
+ return -code 7 \
+ [format "expecting colon to terminate route (found %s)" \
+ $state(buffer)]
+ }
+ }
+ }
+}
+
+# ::mime::addr_domain --
+#
+# Attempts to parse the portion of the e-mail address after the @.
+# Tries to verify that the domain definition has a valid form.
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns nothing if successful, and throws an error if invalid
+# syntax is found.
+
+proc ::mime::addr_domain {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ while {1} {
+ switch -- [parselexeme $token] {
+ LX_ATOM
+ -
+ LX_DLITERAL {
+ append state(domain) $state(buffer)
+ }
+
+ default {
+ return -code 7 \
+ [format "expecting sub-domain in domain-part (found %s)" \
+ $state(buffer)]
+ }
+ }
+
+ switch -- [parselexeme $token] {
+ LX_DOT {
+ append state(domain) $state(buffer)
+ }
+
+ LX_ATSIGN {
+ append state(local) % $state(domain)
+ unset state(domain)
+ }
+
+ default {
+ return
+ }
+ }
+ }
+}
+
+# ::mime::addr_local --
+#
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns nothing if successful, and throws an error if invalid
+# syntax is found.
+
+proc ::mime::addr_local {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set state(memberP) $state(glevel)
+
+ while {1} {
+ switch -- [parselexeme $token] {
+ LX_ATOM
+ -
+ LX_QSTRING {
+ append state(local) $state(buffer)
+ }
+
+ default {
+ return -code 7 \
+ [format "expecting mailbox in local-part (found %s)" \
+ $state(buffer)]
+ }
+ }
+
+ switch -- [parselexeme $token] {
+ LX_DOT {
+ append state(local) $state(buffer)
+ }
+
+ default {
+ return
+ }
+ }
+ }
+}
+
+# ::mime::addr_phrase --
+#
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns nothing if successful, and throws an error if invalid
+# syntax is found.
+
+
+proc ::mime::addr_phrase {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ while {1} {
+ switch -- [parselexeme $token] {
+ LX_ATOM
+ -
+ LX_QSTRING {
+ append state(phrase) " " $state(buffer)
+ }
+
+ default {
+ break
+ }
+ }
+ }
+
+ switch -- $state(lastC) {
+ LX_LBRACKET {
+ return [addr_routeaddr $token]
+ }
+
+ LX_COLON {
+ return [addr_group $token]
+ }
+
+ LX_DOT {
+ append state(phrase) $state(buffer)
+ return [addr_phrase $token]
+ }
+
+ default {
+ return -code 7 \
+ [format "found phrase instead of mailbox (%s%s)" \
+ $state(phrase) $state(buffer)]
+ }
+ }
+}
+
+# ::mime::addr_group --
+#
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns nothing if successful, and throws an error if invalid
+# syntax is found.
+
+proc ::mime::addr_group {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {[incr state(glevel)] > 1} {
+ return -code 7 [format "nested groups not allowed (found %s)" \
+ $state(phrase)]
+ }
+
+ set state(group) $state(phrase)
+ unset state(phrase)
+
+ set lookahead $state(input)
+ while {1} {
+ switch -- [parselexeme $token] {
+ LX_SEMICOLON
+ -
+ LX_END {
+ set state(glevel) 0
+ return 1
+ }
+
+ LX_COMMA {
+ }
+
+ default {
+ set state(input) $lookahead
+ return [addr_specification $token]
+ }
+ }
+ }
+}
+
+# ::mime::addr_end --
+#
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns nothing if successful, and throws an error if invalid
+# syntax is found.
+
+proc ::mime::addr_end {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ switch -- $state(lastC) {
+ LX_SEMICOLON {
+ if {[incr state(glevel) -1] < 0} {
+ return -code 7 "extraneous semi-colon"
+ }
+ }
+
+ LX_COMMA
+ -
+ LX_END {
+ }
+
+ default {
+ return -code 7 [format "junk after local@domain (found %s)" \
+ $state(buffer)]
+ }
+ }
+}
+
+# ::mime::addr_x400 --
+#
+#
+# Arguments:
+# token The MIME token to work from.
+#
+# Results:
+# Returns nothing if successful, and throws an error if invalid
+# syntax is found.
+
+proc ::mime::addr_x400 {mbox key} {
+ if {[set x [string first /$key= [string toupper $mbox]]] < 0} {
+ return {}
+ }
+ set mbox [string range $mbox [expr {$x + [string length $key] + 2}] end]
+
+ if {[set x [string first / $mbox]] > 0} {
+ set mbox [string range $mbox 0 [expr {$x - 1}]]
+ }
+
+ return [string trim $mbox \"]
+}
+
+# ::mime::parsedatetime --
+#
+# Fortunately the clock command in the Tcl 8.x core does all the heavy
+# lifting for us (except for timezone calculations).
+#
+# mime::parsedatetime takes a string containing an 822-style date-time
+# specification and returns the specified property.
+#
+# The list of properties and their ranges are:
+#
+# property range
+# ======== =====
+# clock raw result of "clock scan"
+# hour 0 .. 23
+# lmonth January, February, ..., December
+# lweekday Sunday, Monday, ... Saturday
+# mday 1 .. 31
+# min 0 .. 59
+# mon 1 .. 12
+# month Jan, Feb, ..., Dec
+# proper 822-style date-time specification
+# rclock elapsed seconds between then and now
+# sec 0 .. 59
+# wday 0 .. 6 (Sun .. Mon)
+# weekday Sun, Mon, ..., Sat
+# yday 1 .. 366
+# year 1900 ...
+# zone -720 .. 720 (minutes east of GMT)
+#
+# Arguments:
+# value Either a 822-style date-time specification or '-now'
+# if the current date/time should be used.
+# property The property (from the list above) to return
+#
+# Results:
+# Returns the string value of the 'property' for the date/time that was
+# specified in 'value'.
+
+namespace eval ::mime {
+ variable WDAYS_SHORT [list Sun Mon Tue Wed Thu Fri Sat]
+ variable WDAYS_LONG [list Sunday Monday Tuesday Wednesday Thursday \
+ Friday Saturday]
+
+ # Counting months starts at 1, so just insert a dummy element
+ # at index 0.
+ variable MONTHS_SHORT [list {} \
+ Jan Feb Mar Apr May Jun \
+ Jul Aug Sep Oct Nov Dec]
+ variable MONTHS_LONG [list {} \
+ January February March April May June July \
+ August Sepember October November December]
+}
+proc ::mime::parsedatetime {value property} {
+ if {$value eq "-now"} {
+ set clock [clock seconds]
+ } elseif {[regexp {^(.*) ([+-])([0-9][0-9])([0-9][0-9])$} $value \
+ -> value zone_sign zone_hour zone_min]} {
+ set clock [clock scan $value -gmt 1]
+ if {[info exists zone_min]} {
+ set zone_min [scan $zone_min %d]
+ set zone_hour [scan $zone_hour %d]
+ set zone [expr {60 * ($zone_min + 60 * $zone_hour)}]
+ if {$zone_sign eq "+"} {
+ set zone -$zone
+ }
+ incr clock $zone
+ }
+ } else {
+ set clock [clock scan $value]
+ }
+
+ switch -- $property {
+ clock {
+ return $clock
+ }
+
+ hour {
+ set value [clock format $clock -format %H]
+ }
+
+ lmonth {
+ variable MONTHS_LONG
+ return [lindex $MONTHS_LONG \
+ [scan [clock format $clock -format %m] %d]]
+ }
+
+ lweekday {
+ variable WDAYS_LONG
+ return [lindex $WDAYS_LONG [clock format $clock -format %w]]
+ }
+
+ mday {
+ set value [clock format $clock -format %d]
+ }
+
+ min {
+ set value [clock format $clock -format %M]
+ }
+
+ mon {
+ set value [clock format $clock -format %m]
+ }
+
+ month {
+ variable MONTHS_SHORT
+ return [lindex $MONTHS_SHORT \
+ [scan [clock format $clock -format %m] %d]]
+ }
+
+ proper {
+ set gmt [clock format $clock -format "%Y-%m-%d %H:%M:%S" \
+ -gmt true]
+ if {[set diff [expr {($clock-[clock scan $gmt]) / 60}]] < 0} {
+ set s -
+ set diff [expr {-($diff)}]
+ } else {
+ set s +
+ }
+ set zone [format %s%02d%02d $s [
+ expr {$diff / 60}] [expr {$diff % 60}]]
+
+ variable WDAYS_SHORT
+ set wday [lindex $WDAYS_SHORT [clock format $clock -format %w]]
+ variable MONTHS_SHORT
+ set mon [lindex $MONTHS_SHORT \
+ [scan [clock format $clock -format %m] %d]]
+
+ return [clock format $clock \
+ -format "$wday, %d $mon %Y %H:%M:%S $zone"]
+ }
+
+ rclock {
+ #TODO: these paths are not covered by tests
+ if {$value eq "-now"} {
+ return 0
+ } else {
+ return [expr {[clock seconds] - $clock}]
+ }
+ }
+
+ sec {
+ set value [clock format $clock -format %S]
+ }
+
+ wday {
+ return [clock format $clock -format %w]
+ }
+
+ weekday {
+ variable WDAYS_SHORT
+ return [lindex $WDAYS_SHORT [clock format $clock -format %w]]
+ }
+
+ yday {
+ set value [clock format $clock -format %j]
+ }
+
+ year {
+ set value [clock format $clock -format %Y]
+ }
+
+ zone {
+ set value [string trim [string map [list \t { }] $value]]
+ if {[set x [string last { } $value]] < 0} {
+ return 0
+ }
+ set value [string range $value [expr {$x + 1}] end]
+ switch -- [set s [string index $value 0]] {
+ + - - {
+ if {$s eq "+"} {
+ #TODO: This path is not covered by tests
+ set s {}
+ }
+ set value [string trim [string range $value 1 end]]
+ if {([string length $value] != 4) \
+ || ([scan $value %2d%2d h m] != 2) \
+ || ($h > 12) \
+ || ($m > 59) \
+ || (($h == 12) && ($m > 0))} {
+ error "malformed timezone-specification: $value"
+ }
+ set value $s[expr {$h * 60 + $m}]
+ }
+
+ default {
+ set value [string toupper $value]
+ set z1 [list UT GMT EST EDT CST CDT MST MDT PST PDT]
+ set z2 [list 0 0 -5 -4 -6 -5 -7 -6 -8 -7]
+ if {[set x [lsearch -exact $z1 $value]] < 0} {
+ error "unrecognized timezone-mnemonic: $value"
+ }
+ set value [expr {[lindex $z2 $x] * 60}]
+ }
+ }
+ }
+
+ date2gmt
+ -
+ date2local
+ -
+ dst
+ -
+ sday
+ -
+ szone
+ -
+ tzone
+ -
+ default {
+ error "unknown property $property"
+ }
+ }
+
+ if {[set value [string trimleft $value 0]] eq {}} {
+ #TODO: this path is not covered by tests
+ set value 0
+ }
+ return $value
+}
+
+# ::mime::uniqueID --
+#
+# Used to generate a 'globally unique identifier' for the content-id.
+# The id is built from the pid, the current time, the hostname, and
+# a counter that is incremented each time a message is sent.
+#
+# Arguments:
+#
+# Results:
+# Returns the a string that contains the globally unique identifier
+# that should be used for the Content-ID of an e-mail message.
+
+proc ::mime::uniqueID {} {
+ variable mime
+
+ return "<[pid].[clock seconds].[incr mime(cid)]@[info hostname]>"
+}
+
+# ::mime::parselexeme --
+#
+# Used to implement a lookahead parser.
+#
+# Arguments:
+# token The MIME token to operate on.
+#
+# Results:
+# Returns the next token found by the parser.
+
+proc ::mime::parselexeme {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set state(input) [string trimleft $state(input)]
+
+ set state(buffer) {}
+ if {$state(input) eq {}} {
+ set state(buffer) end-of-input
+ return [set state(lastC) LX_END]
+ }
+
+ set c [string index $state(input) 0]
+ set state(input) [string range $state(input) 1 end]
+
+ if {$c eq "("} {
+ set noteP 0
+ set quoteP 0
+
+ while 1 {
+ append state(buffer) $c
+
+ #TODO: some of these paths are not covered by tests
+ switch -- $c/$quoteP {
+ (/0 {
+ incr noteP
+ }
+
+ \\/0 {
+ set quoteP 1
+ }
+
+ )/0 {
+ if {[incr noteP -1] < 1} {
+ if {[info exists state(comment)]} {
+ append state(comment) { }
+ }
+ append state(comment) $state(buffer)
+
+ return [parselexeme $token]
+ }
+ }
+
+ default {
+ set quoteP 0
+ }
+ }
+
+ if {[set c [string index $state(input) 0]] eq {}} {
+ set state(buffer) "end-of-input during comment"
+ return [set state(lastC) LX_ERR]
+ }
+ set state(input) [string range $state(input) 1 end]
+ }
+ }
+
+ if {$c eq "\""} {
+ set firstP 1
+ set quoteP 0
+
+ while 1 {
+ append state(buffer) $c
+
+ switch -- $c/$quoteP {
+ "\\/0" {
+ set quoteP 1
+ }
+
+ "\"/0" {
+ if {!$firstP} {
+ return [set state(lastC) LX_QSTRING]
+ }
+ set firstP 0
+ }
+
+ default {
+ set quoteP 0
+ }
+ }
+
+ if {[set c [string index $state(input) 0]] eq {}} {
+ set state(buffer) "end-of-input during quoted-string"
+ return [set state(lastC) LX_ERR]
+ }
+ set state(input) [string range $state(input) 1 end]
+ }
+ }
+
+ if {$c eq {[}} {
+ set quoteP 0
+
+ while 1 {
+ append state(buffer) $c
+
+ switch -- $c/$quoteP {
+ \\/0 {
+ set quoteP 1
+ }
+
+ ]/0 {
+ return [set state(lastC) LX_DLITERAL]
+ }
+
+ default {
+ set quoteP 0
+ }
+ }
+
+ if {[set c [string index $state(input) 0]] eq {}} {
+ set state(buffer) "end-of-input during domain-literal"
+ return [set state(lastC) LX_ERR]
+ }
+ set state(input) [string range $state(input) 1 end]
+ }
+ }
+
+ if {[set x [lsearch -exact $state(tokenL) $c]] >= 0} {
+ append state(buffer) $c
+
+ return [set state(lastC) [lindex $state(lexemeL) $x]]
+ }
+
+ while {1} {
+ append state(buffer) $c
+
+ switch -- [set c [string index $state(input) 0]] {
+ {} - " " - "\t" - "\n" {
+ break
+ }
+
+ default {
+ if {[lsearch -exact $state(tokenL) $c] >= 0} {
+ break
+ }
+ }
+ }
+
+ set state(input) [string range $state(input) 1 end]
+ }
+
+ return [set state(lastC) LX_ATOM]
+}
+
+# ::mime::mapencoding --
+#
+# mime::mapencodings maps tcl encodings onto the proper names for their
+# MIME charset type. This is only done for encodings whose charset types
+# were known. The remaining encodings return {} for now.
+#
+# Arguments:
+# enc The tcl encoding to map.
+#
+# Results:
+# Returns the MIME charset type for the specified tcl encoding, or {}
+# if none is known.
+
+proc ::mime::mapencoding {enc} {
+
+ variable encodings
+
+ if {[info exists encodings($enc)]} {
+ return $encodings($enc)
+ }
+ return {}
+}
+
+# ::mime::reversemapencoding --
+#
+# mime::reversemapencodings maps MIME charset types onto tcl encoding names.
+# Those that are unknown return {}.
+#
+# Arguments:
+# mimeType The MIME charset to convert into a tcl encoding type.
+#
+# Results:
+# Returns the tcl encoding name for the specified mime charset, or {}
+# if none is known.
+
+proc ::mime::reversemapencoding {mimeType} {
+
+ variable reversemap
+
+ set lmimeType [string tolower $mimeType]
+ if {[info exists reversemap($lmimeType)]} {
+ return $reversemap($lmimeType)
+ }
+ return {}
+}
+
+# ::mime::word_encode --
+#
+# Word encodes strings as per RFC 2047.
+#
+# Arguments:
+# charset The character set to encode the message to.
+# method The encoding method (base64 or quoted-printable).
+# string The string to encode.
+# ?-charset_encoded 0 or 1 Whether the data is already encoded
+# in the specified charset (default 1)
+# ?-maxlength maxlength The maximum length of each encoded
+# word to return (default 66)
+#
+# Results:
+# Returns a word encoded string.
+
+proc ::mime::word_encode {charset method string {args}} {
+
+ variable encodings
+
+ if {![info exists encodings($charset)]} {
+ error "unknown charset '$charset'"
+ }
+
+ if {$encodings($charset) eq {}} {
+ error "invalid charset '$charset'"
+ }
+
+ if {$method ne "base64" && $method ne "quoted-printable"} {
+ error "unknown method '$method', must be base64 or quoted-printable"
+ }
+
+ # default to encoded and a length that won't make the Subject header to long
+ array set options [list -charset_encoded 1 -maxlength 66]
+ array set options $args
+
+ if {$options(-charset_encoded)} {
+ set unencoded_string [::encoding convertfrom $charset $string]
+ } else {
+ set unencoded_string $string
+ }
+
+ set string_length [string length $unencoded_string]
+
+ if {!$string_length} {
+ return {}
+ }
+
+ set string_bytelength [string bytelength $unencoded_string]
+
+ # the 7 is for =?, ?Q?, ?= delimiters of the encoded word
+ set maxlength [expr {$options(-maxlength) - [string length $encodings($charset)] - 7}]
+ switch -exact -- $method {
+ base64 {
+ if {$maxlength < 4} {
+ error "maxlength $options(-maxlength) too short for chosen charset and encoding"
+ }
+ set count 0
+ set maxlength [expr {($maxlength / 4) * 3}]
+ while {$count < $string_length} {
+ set length 0
+ set enc_string {}
+ while {($length < $maxlength) && ($count < $string_length)} {
+ set char [string range $unencoded_string $count $count]
+ set enc_char [::encoding convertto $charset $char]
+ if {($length + [string length $enc_char]) > $maxlength} {
+ set length $maxlength
+ } else {
+ append enc_string $enc_char
+ incr count
+ incr length [string length $enc_char]
+ }
+ }
+ set encoded_word [string map [
+ list \n {}] [base64 -mode encode -- $enc_string]]
+ append result "=?$encodings($charset)?B?$encoded_word?=\n "
+ }
+ # Trim off last "\n ", since the above code has the side-effect
+ # of adding an extra "\n " to the encoded string.
+
+ set result [string range $result 0 end-2]
+ }
+ quoted-printable {
+ if {$maxlength < 1} {
+ error "maxlength $options(-maxlength) too short for chosen charset and encoding"
+ }
+ set count 0
+ while {$count < $string_length} {
+ set length 0
+ set encoded_word {}
+ while {($length < $maxlength) && ($count < $string_length)} {
+ set char [string range $unencoded_string $count $count]
+ set enc_char [::encoding convertto $charset $char]
+ set qp_enc_char [qp_encode $enc_char 1]
+ set qp_enc_char_length [string length $qp_enc_char]
+ if {$qp_enc_char_length > $maxlength} {
+ error "maxlength $options(-maxlength) too short for chosen charset and encoding"
+ }
+ if {($length + [
+ string length $qp_enc_char]) > $maxlength} {
+
+ set length $maxlength
+ } else {
+ append encoded_word $qp_enc_char
+ incr count
+ incr length [string length $qp_enc_char]
+ }
+ }
+ append result "=?$encodings($charset)?Q?$encoded_word?=\n "
+ }
+ # Trim off last "\n ", since the above code has the side-effect
+ # of adding an extra "\n " to the encoded string.
+
+ set result [string range $result 0 end-2]
+ }
+ {} {
+ # Go ahead
+ }
+ default {
+ error "Can't handle content encoding \"$method\""
+ }
+ }
+ return $result
+}
+
+# ::mime::word_decode --
+#
+# Word decodes strings that have been word encoded as per RFC 2047.
+#
+# Arguments:
+# encoded The word encoded string to decode.
+#
+# Results:
+# Returns the string that has been decoded from the encoded message.
+
+proc ::mime::word_decode {encoded} {
+
+ variable reversemap
+
+ if {[regexp -- {=\?([^?]+)\?(.)\?([^?]*)\?=} $encoded \
+ - charset method string] != 1} {
+ error "malformed word-encoded expression '$encoded'"
+ }
+
+ set enc [reversemapencoding $charset]
+ if {$enc eq {}} {
+ error "unknown charset '$charset'"
+ }
+
+ switch -exact -- $method {
+ b -
+ B {
+ set method base64
+ }
+ q -
+ Q {
+ set method quoted-printable
+ }
+ default {
+ error "unknown method '$method', must be B or Q"
+ }
+ }
+
+ switch -exact -- $method {
+ base64 {
+ set result [base64 -mode decode -- $string]
+ }
+ quoted-printable {
+ set result [qp_decode $string 1]
+ }
+ {} {
+ # Go ahead
+ }
+ default {
+ error "Can't handle content encoding \"$method\""
+ }
+ }
+
+ return [list $enc $method $result]
+}
+
+# ::mime::field_decode --
+#
+# Word decodes strings that have been word encoded as per RFC 2047
+# and converts the string from the original encoding/charset to UTF.
+#
+# Arguments:
+# field The string to decode
+#
+# Results:
+# Returns the decoded string in UTF.
+
+proc ::mime::field_decode {field} {
+ # ::mime::field_decode is broken. Here's a new version.
+ # This code is in the public domain. Don Libes <don@libes.com>
+
+ # Step through a field for mime-encoded words, building a new
+ # version with unencoded equivalents.
+
+ # Sorry about the grotesque regexp. Most of it is sensible. One
+ # notable fudge: the final $ is needed because of an apparent bug
+ # in the regexp engine where the preceding .* otherwise becomes
+ # non-greedy - perhaps because of the earlier ".*?", sigh.
+
+ while {[regexp {(.*?)(=\?(?:[^?]+)\?(?:.)\?(?:[^?]*)\?=)(.*)$} $field ignore prefix encoded field]} {
+ # don't allow whitespace between encoded words per RFC 2047
+ if {{} != $prefix} {
+ if {![string is space $prefix]} {
+ append result $prefix
+ }
+ }
+
+ set decoded [word_decode $encoded]
+ foreach {charset - string} $decoded break
+
+ append result [::encoding convertfrom $charset $string]
+ }
+ append result $field
+ return $result
+}
+
+## One-Shot Initialization
+
+::apply {{} {
+ variable encList
+ variable encAliasList
+ variable reversemap
+
+ foreach {enc mimeType} $encList {
+ if {$mimeType eq {}} continue
+ set reversemap([string tolower $mimeType]) $enc
+ }
+
+ foreach {enc mimeType} $encAliasList {
+ set reversemap([string tolower $mimeType]) $enc
+ }
+
+ # Drop the helper variables
+ unset encList encAliasList
+
+} ::mime}
diff --git a/tcllib/modules/mime/mime.test b/tcllib/modules/mime/mime.test
new file mode 100755
index 0000000..71e84d2
--- /dev/null
+++ b/tcllib/modules/mime/mime.test
@@ -0,0 +1,609 @@
+# mime.test - Test suite for TclMIME -*- tcl -*-
+#
+# 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) 2000 by Ajuba Solutions
+# All rights reserved.
+#
+# RCS: @(#) $Id: mime.test,v 1.31 2012/02/23 17:35:17 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 1.0
+
+support {
+ # This code loads md5x, i.e. md5 v2. Proper testing should do one
+ # run using md5 v1, aka md5.tcl as well.
+ use md5/md5x.tcl md5
+}
+testing {
+ useLocal mime.tcl mime
+}
+
+# -------------------------------------------------------------------------
+
+namespace import mime::*
+
+# -------------------------------------------------------------------------
+
+test mime-1.1 {initialize with no args} {
+ catch {initialize} res
+ subst $res
+} {specify exactly one of -file, -parts, or -string}
+
+test mime-2.1 {Generate a MIME message} {
+ set tok [initialize -canonical "Text/plain" -string "jack and jill"]
+ set msg [mime::buildmessage $tok]
+ # The generated message is predictable except for the Content-ID
+ regexp "MIME-Version: 1.0\r
+Content-ID: \[^\n]+\r
+Content-Type: text/plain\r
+\r
+jack and jill" $msg
+} 1
+
+test mime-2.2 {Generate a multi-part MIME message} {
+ set tok1 [initialize -canonical "Text/plain" -string "jack and jill"]
+ set tok2 [initialize -canonical "Text/plain" -string "james"]
+ set bigTok [mime::initialize -canonical Multipart/MyType \
+ -param [list MyParam foo] \
+ -param [list boundary bndry] \
+ -header [list Content-Description "Test Multipart"] \
+ -parts [list $tok1 $tok2]]
+ set msg [mime::buildmessage $bigTok]
+ # The generated message is predictable except for the Content-ID
+ list [regexp "MIME-Version: 1.0\r
+Content-Description: Test Multipart\r
+Content-ID: \[^\n]+\r
+Content-Type: multipart/mytype;\r
+ \[^\n]+;\r
+ \[^\n]+\r
+\r
+--bndry\r
+MIME-Version: 1.0\r
+Content-ID: \[^\n]+\r
+Content-Type: text/plain\r
+\r
+jack and jill\r
+--bndry\r
+MIME-Version: 1.0\r
+Content-ID: \[^\n]+\r
+Content-Type: text/plain\r
+\r
+james\r
+--bndry--\r
+" $msg] [regexp "boundary=\"bndry\"" $msg] [regexp "myparam=\"foo\"" $msg]
+} {1 1 1}
+
+test mime-3.1 {Parse a MIME message} {
+ set msg {MIME-Version: 1.0
+Content-Type: Text/plain
+
+I'm the message.}
+ set tok [mime::initialize -string $msg]
+ mime::getbody $tok
+} "I'm the message."
+
+test mime-3.2 {Parse a multi-part MIME message} {
+ set msg {MIME-Version: 1.0
+Content-Type: Multipart/foo; boundary="bar"
+
+--bar
+MIME-Version: 1.0
+Content-Type: Text/plain
+
+part1
+--bar
+MIME-Version: 1.0
+Content-Type: Text/plain
+
+part2
+--bar
+MIME-Version: 1.0
+Content-Type: Text/plain
+
+part3
+--bar--
+}
+
+ set tok [mime::initialize -string $msg]
+ set partToks [mime::getproperty $tok parts]
+
+ set res ""
+ foreach childTok $partToks {
+ lappend res [mime::getbody $childTok]
+ }
+ set res
+} {part1 part2 part3}
+
+test mime-3.3 {Try to parse a totally invalid message} {
+ catch {mime::initialize -string "blah"} err0
+ set err0
+} {improper line in header: blah}
+
+test mime-3.4 {Try to parse a MIME message with an invalid version} {
+ set msg1 {MIME-Version: 2.0
+Content-Type: text/plain
+
+msg1}
+
+ set tok [mime::initialize -string $msg1]
+ catch {mime::getbody $tok} err1
+ catch {mime::buildmessage $tok} err1a
+ list $err1 $err1a
+} "msg1 {MIME-Version: 2.0\r
+Content-Type: text/plain\r
+\r
+msg1}"
+
+test mime-3.5 {Try to parse a MIME message with no newline between headers and data} {
+ set msg2 {MIME-Version: 1.0
+Content-Type: foobar
+data without newline}
+
+ catch {mime::initialize -string $msg2} err2
+ set err2
+} {improper line in header: data without newline}
+
+test mime-3.6 {Try to parse a MIME message with no MIME version and generate a new message from it} {
+
+ # No MIME version
+ set msg3 {Content-Type: text/plain
+
+foo}
+
+ set tok [mime::initialize -string $msg3]
+ catch {mime::getbody $tok} err3
+ catch {mime::buildmessage $tok} err3a
+ list $err3 $err3a
+} "foo {MIME-Version: 1.0\r
+Content-Type: text/plain\r
+\r
+foo}"
+
+test mime-3.7 {Test mime with a bad email [SF Bug 631314 ]} {
+ set tok [mime::initialize -file \
+ [file join $tcltest::testsDirectory badmail1.txt]]
+
+ set res {}
+ set ctok [lindex [mime::getproperty $tok parts] 0]
+ lappend res [dictsort [mime::getproperty $tok]]
+ lappend res [dictsort [mime::getproperty $ctok]]
+ mime::finalize $tok
+ string map [list $ctok CHILD] $res
+} {{content multipart/mixed encoding {} params {boundary ----------CSFNU9QKPGZL79} parts CHILD size 0} {content application/octet-stream encoding {} params {charset us-ascii} size 0}}
+
+test mime-3.8 {Test mime with another bad email [SF Bug 631314 ]} {
+ set tok [mime::initialize -file \
+ [file join $tcltest::testsDirectory badmail2.txt]]
+ set res {}
+ set ctok [lindex [mime::getproperty $tok parts] 0]
+ lappend res [dictsort [mime::getproperty $tok]]
+ lappend res [dictsort [mime::getproperty $ctok]]
+ mime::finalize $tok
+ string map [list $ctok CHILD] $res
+} {{content multipart/related encoding {} params {boundary ----=_NextPart_000_0000_2CBA2CBA.150C56D2} parts CHILD size 659} {content application/octet-stream encoding base64 params {} size 659}}
+
+test mime-3.9 {Parse a MIME message with a charset encoded body and use getbody -decode to get it back} {
+ set msg {MIME-Version: 1.0
+Content-Type: text/plain; charset=ISO-8859-1
+
+Fran\xE7ois
+}
+ set tok [mime::initialize -string $msg]
+ mime::getbody $tok -decode
+} {Fran\xE7ois
+}
+
+test mime-3.10 {Parse a MIME message with a charset encoded body and use getbody -decode to get it back (example from encoding man page)} {
+ set msg {MIME-Version: 1.0
+Content-Type: text/plain; charset=EUC-JP
+Content-Transfer-Encoding: quoted-printable
+
+=A4=CF}
+ set tok [mime::initialize -string $msg]
+ mime::getbody $tok -decode
+} "\u306F"
+
+test mime-3.11 {Parse a MIME message without a charset encoded body and use getbody -decode to get it back} {
+ set msg {MIME-Version: 1.0
+Content-Type: text/plain
+Content-Transfer-Encoding: quoted-printable
+
+A plain text message.}
+ set tok [mime::initialize -string $msg]
+ mime::getbody $tok -decode
+} "A plain text message."
+
+test mime-3.12 {Parse a MIME message with a charset encoded body in an unrecognised charset and use getbody -decode to attempt to get it back} {
+ set msg {MIME-Version: 1.0
+Content-Type: text/plain; charset=SCRIBBLE
+Content-Transfer-Encoding: quoted-printable
+
+This is a message in the scribble charset that tcl does not recognise.}
+ set tok [mime::initialize -string $msg]
+ catch {mime::getbody $tok -decode} errmsg
+ set errmsg
+} "-decode failed: can't reversemap charset SCRIBBLE"
+
+test mime-3.13 {Parse a MIME message with a charset encoded body in an unrecognised charset but don't use -decode so we get it back raw} {
+ set msg {MIME-Version: 1.0
+Content-Type: text/plain; charset=SCRIBBLE
+Content-Transfer-Encoding: quoted-printable
+
+This is a message in the scribble charset that tcl does not recognise.}
+ set tok [mime::initialize -string $msg]
+ mime::getbody $tok
+} "This is a message in the scribble charset that tcl does not recognise."
+
+test mime-4.1 {Test qp_encode with a > 76 character string containing special chars.} {
+ set str1 "foo!\"\t barbaz \$ ` \{ # jack and jill went up a hill to fetch a pail of water. Jack fell down and said !\"\#\$@\[\\\]^`\{\|\}\~ \nJill said, \"Oh my\""
+ mime::qp_encode $str1
+} "foo=21=22\t barbaz =24 =60 =7B =23 jack and jill went up a hill to fetch a=\n pail of water. Jack fell down and said =21=22=23=24=40=5B=5C=5D=5E=60=7B=\n=7C=7D=7E =20\nJill said, =22Oh my=22"
+
+test mime-4.2 {Check that encode/decode yields original string} {
+ set str1 "foo!\"\t barbaz \$ ` \{ # jack and jill went up a hill to fetch a pail of water. Jack fell down and said !\"\#\$@\[\\\]^`\{\|\}\~ \nJill said, \"Oh my\" "
+ set enc [mime::qp_encode $str1]
+ set dec [mime::qp_decode $enc]
+ string equal $dec $str1
+} {1}
+
+test mime-4.3 {mime::decode data that might come from an MUA} {
+ set enc "I'm the =22 message =\nwith some new lines= \n but with some extra space, too. "
+ mime::qp_decode $enc
+} "I'm the \" message with some new lines but with some extra space, too."
+
+test mime-4.4 {Test qp_encode with non-US_ASCCI characters.} {
+ set str1 "Test de caractres accentus : et quelques contrles \"\[|\]()\""
+ mime::qp_encode $str1
+} "Test de caract=E8res accentu=E9s : =E2 =EE =E9 =E7 et quelques contr=F4le=\ns =22=5B=7C=5D()=22"
+
+
+test mime-4.5 {Test qp_encode with softbreak} {
+ set str1 [string repeat abc 40]
+ mime::qp_encode $str1
+} "abcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabca=
+bcabcabcabcabcabcabcabcabcabcabcabcabcabcabcabc"
+
+test mime-4.6 {Test qp_encode with softbreak} {
+ set str1 [string repeat abc 40]
+ mime::qp_encode $str1 0 1
+} [string repeat abc 40]
+
+
+
+
+test mime-5.1 {Test word_encode with quoted-printable method} {
+ mime::word_encode iso8859-1 quoted-printable "Test de contrle effectu"
+} "=?ISO-8859-1?Q?Test_de_contr=F4le_effectu=E9?="
+
+test mime-5.2 {Test word_encode with base64 method} {
+ mime::word_encode iso8859-1 base64 "Test de contrle effectu"
+} "=?ISO-8859-1?B?VGVzdCBkZSBjb250cvRsZSBlZmZlY3R16Q==?="
+
+test mime-5.3 {Test encode+decode with quoted-printable method} {
+ set enc [mime::word_encode iso8859-1 quoted-printable "Test de contrle effectu"]
+ mime::word_decode $enc
+} {iso8859-1 quoted-printable {Test de contrle effectu}}
+
+test mime-5.4 {Test encode+decode with base64 method} {
+ set enc [mime::word_encode iso8859-1 base64 "Test de contrle effectu"]
+ mime::word_decode $enc
+} {iso8859-1 base64 {Test de contrle effectu}}
+
+test mime-5.5 {Test decode with lowercase quoted-printable method} {
+ mime::word_decode "=?ISO-8859-1?q?Test_lowercase_q?="
+} {iso8859-1 quoted-printable {Test lowercase q}}
+
+test mime-5.6 {Test decode with lowercase base64 method} {
+ mime::word_decode "=?ISO-8859-1?b?VGVzdCBsb3dlcmNhc2UgYg==?="
+} {iso8859-1 base64 {Test lowercase b}}
+
+test mime-5.7 {Test word_encode with quoted-printable method across encoded word boundaries} {
+ mime::word_encode iso8859-1 quoted-printable "Test de contrle effectu" -maxlength 31
+} "=?ISO-8859-1?Q?Test_de_contr?=
+ =?ISO-8859-1?Q?=F4le_effectu?=
+ =?ISO-8859-1?Q?=E9?="
+
+test mime-5.8 {Test word_encode with quoted-printable method across encoded word boundaries} {
+ mime::word_encode iso8859-1 quoted-printable "Test de contrle effectu" -maxlength 32
+} "=?ISO-8859-1?Q?Test_de_contr?=
+ =?ISO-8859-1?Q?=F4le_effectu?=
+ =?ISO-8859-1?Q?=E9?="
+
+test mime-5.9 {Test word_encode with quoted-printable method and multibyte character} {
+ mime::word_encode euc-jp quoted-printable "Following me is a multibyte character \xA4\xCF"
+} "=?EUC-JP?Q?Following_me_is_a_multibyte_character_=A4=CF?="
+
+set n 10
+while {$n < 14} {
+ test mime-5.$n {Test word_encode with quoted-printable method and multibyte character across encoded word boundary} {
+ mime::word_encode euc-jp quoted-printable "Following me is a multibyte character \xA4\xCF" -maxlength [expr 42 + $n]
+ } "=?EUC-JP?Q?Following_me_is_a_multibyte_character_?=
+ =?EUC-JP?Q?=A4=CF?="
+ incr n
+}
+
+test mime-5.14 {Test word_encode with quoted-printable method and multibyte character (triple)} {
+ mime::word_encode utf-8 quoted-printable "Here is a triple byte encoded character \xE3\x81\xAF"
+} "=?UTF-8?Q?Here_is_a_triple_byte_encoded_character_=E3=81=AF?="
+
+set n 15
+while {$n < 23} {
+ test mime-5.$n {Test word_encode with quoted-printable method and triple byte character across encoded word boundary} {
+ mime::word_encode utf-8 quoted-printable "Here is a triple byte encoded character \xE3\x81\xAF" -maxlength [expr 38 + $n]
+ } "=?UTF-8?Q?Here_is_a_triple_byte_encoded_character_?=
+ =?UTF-8?Q?=E3=81=AF?="
+ incr n
+}
+
+while {$n < 25} {
+ test mime-5.$n {Test word_encode with quoted-printable method and triple byte character across encoded word boundary} {
+ mime::word_encode utf-8 quoted-printable "Here is a triple byte encoded character \xE3\x81\xAF" -maxlength [expr 38 + $n]
+ } "=?UTF-8?Q?Here_is_a_triple_byte_encoded_character_=E3=81=AF?="
+ incr n
+}
+
+while {$n < 29} {
+ test mime-5.$n {Test word_encode with base64 method across encoded word boundaries} {
+ mime::word_encode euc-jp base64 "There is a multibyte character \xA4\xCF" -maxlength [expr 28 + $n]
+ } "=?EUC-JP?B?VGhlcmUgaXMgYSBtdWx0aWJ5dGUgY2hhcmFjdGVy?=
+ =?EUC-JP?B?IKTP?="
+ incr n
+}
+
+while {$n < 33} {
+ test mime-5.$n {Test word_encode with base64 method and triple byte character across encoded word boundary} {
+ mime::word_encode utf-8 base64 "Here is a multibyte character \xE3\x81\xAF" -maxlength [expr 23 + $n]
+ } "=?UTF-8?B?SGVyZSBpcyBhIG11bHRpYnl0ZSBjaGFyYWN0ZXIg?=
+ =?UTF-8?B?44Gv?="
+ incr n
+}
+
+test mime-5.33 {Test word_encode with quoted-printable method and -maxlength set to same length as will the result} {
+ mime::word_encode iso8859-1 quoted-printable "123" -maxlength 20
+} "=?ISO-8859-1?Q?123?="
+
+test mime-5.34 {Test word_encode with base64 method and -maxlength set to same length as will the result} {
+ mime::word_encode iso8859-1 base64 "123" -maxlength 21
+} "=?ISO-8859-1?B?MTIz?="
+
+test mime-5.35 {Test word_encode with quoted-printable method and non charset encoded string} {
+ mime::word_encode utf-8 quoted-printable "\u306F" -charset_encoded 0
+} "=?UTF-8?Q?=E3=81=AF?="
+
+test mime-5.36 {Test word_encode with base64 method and non charset encoded string} {
+ mime::word_encode utf-8 base64 "\u306F" -charset_encoded 0
+} "=?UTF-8?B?44Gv?="
+
+test mime-5.36 {Test word_encode with base64 method and one byte} {
+ mime::word_encode iso8859-1 base64 "a"
+} "=?ISO-8859-1?B?YQ==?="
+
+test mime-5.37 {Test word_encode with base64 method and two bytes} {
+ mime::word_encode euc-jp base64 "\xA4\xCF"
+} "=?EUC-JP?B?pM8=?="
+
+test mime-5.38 {Test word_encode with unknown charset} {
+ catch {mime::word_encode scribble quoted-printable "scribble is an unknown charset"} errmsg
+ set errmsg
+} "unknown charset 'scribble'"
+
+test mime-5.39 {Test word_encode with invalid charset} {
+ catch {mime::word_encode unicode quoted-printable "unicode is not a valid charset"} errmsg
+ set errmsg
+} "invalid charset 'unicode'"
+
+test mime-5.40 {Test word_encode with invalid method} {
+ catch {mime::word_encode iso8859-1 tea-leaf "tea-leaf is not a valid method"} errmsg
+ set errmsg
+} "unknown method 'tea-leaf', must be base64 or quoted-printable"
+
+test mime-5.41 {Test word_encode with maxlength to short for method quoted-printable} {
+ catch {mime::word_encode iso8859-1 quoted-printable "1" -maxlength 17} errmsg
+ set errmsg
+} "maxlength 17 too short for chosen charset and encoding"
+
+test mime-5.42 {Test word_encode with maxlength on the limit for quoted_printable and an unquoted character} {
+ catch {mime::word_encode iso8859-1 quoted-printable "_" -maxlength 18} errmsg
+ set errmsg
+} "=?ISO-8859-1?Q?_?="
+
+test mime-5.43 {Test word_encode with maxlength to short for method quoted_printable and a character to be quoted} {
+ catch {mime::word_encode iso8859-1 quoted-printable "=" -maxlength 18} errmsg
+ set errmsg
+} "maxlength 18 too short for chosen charset and encoding"
+
+
+test mime-5.44 {Test word_encode with maxlength to short for method quoted-printable and multibyte character} {
+ catch {mime::word_encode euc-jp quoted-printable "\xA4\xCF" -maxlength 17} errmsg
+ set errmsg
+} "maxlength 17 too short for chosen charset and encoding"
+
+test mime-5.45 {Test word_encode with maxlength to short for method base64} {
+ catch {mime::word_encode iso8859-1 base64 "1" -maxlength 20} errmsg
+ set errmsg
+} "maxlength 20 too short for chosen charset and encoding"
+
+test mime-6.1 {Test field_decode (from RFC 2047, part 8)} {
+ mime::field_decode {=?US-ASCII?Q?Keith_Moore?= <moore@cs.utk.edu>}
+} {Keith Moore <moore@cs.utk.edu>}
+
+test mime-6.2 {Test field_decode (from RFC 2047, part 8)} {
+ mime::field_decode {=?ISO-8859-1?Q?Patrik_F=E4ltstr=F6m?= <paf@nada.kth.se>}
+} {Patrik Fltstrm <paf@nada.kth.se>}
+
+test mime-6.3 {Test field_decode (from RFC 2047, part 8)} {
+ mime::field_decode {=?ISO-8859-1?B?SWYgeW91IGNhbiByZWFkIHRoaXMgeW8=?=
+ =?ISO-8859-2?B?dSB1bmRlcnN0YW5kIHRoZSBleGFtcGxlLg==?=}
+} {If you can read this you understand the example.}
+
+foreach {n encoded expected} {
+ 4 "(=?ISO-8859-1?Q?a?=)"
+ "(a)"
+ 5 "(=?ISO-8859-1?Q?a?= b)"
+ "(a b)"
+ 6 "(=?ISO-8859-1?Q?a?= =?ISO-8859-1?Q?b?=)"
+ "(ab)"
+ 7 "(=?ISO-8859-1?Q?a?= =?ISO-8859-1?Q?b?=)"
+ "(ab)"
+ 8 "(=?ISO-8859-1?Q?a?=
+ =?ISO-8859-1?Q?b?=)"
+ "(ab)"
+ 9 "(=?ISO-8859-1?Q?a_b?=)"
+ "(a b)"
+ 10 "(=?ISO-8859-1?Q?a?= =?ISO-8859-2?Q?_b?=)"
+ "(a b)"
+ 11 "(=?ISO-8859-1?Q?a?=x=?ISO-8859-2?Q?_b?=)"
+ "(ax b)"
+ 12 "a b c"
+ "a b c"
+ 13 ""
+ ""
+} {
+ test mime-6.$n {Test field_decode (from RFC 2047, part 8)} {
+ mime::field_decode $encoded
+ } $expected ; # {}
+}
+
+foreach {bug n encoded expected} {
+ 764702 1 "(=?utf-8?Q?H=C3=BCrz?=)" "(Hrz)"
+} {
+ test mime-7.$n "Test field_decode (from SF Tcllib bug $bug)" {
+ mime::field_decode $encoded
+ } $expected ; # {}
+}
+
+test mime-8.1 {Test reversemapencoding+mapencoding with preferred name} {
+ set charset [mime::reversemapencoding "US-ASCII"]
+ mime::mapencoding $charset
+} {US-ASCII}
+
+test mime-8.2 {Test reversemapencoding+mapencoding with alias} {
+ set charset [mime::reversemapencoding "UTF8"]
+ mime::mapencoding $charset
+} {UTF-8}
+
+
+test mime-9.0 {Test chunk handling of copymessage and helpers} {
+ set in [makeFile [set data [string repeat [string repeat "123456789 " 10]\n 350]] input.txt]
+ set mi [makeFile {} mime.txt]
+
+ set token [mime::initialize -canonical text/plain -file $in]
+
+ set f [open $mi w]
+ fconfigure $f -translation binary
+ mime::copymessage $token $f
+ close $f
+
+ set token [mime::initialize -file $mi]
+ set newdata [mime::getbody $token]
+ set res [string compare $data $newdata]
+
+ removeFile input.txt
+ removeFile mime.txt
+ unset data newdata token f in mi
+ set res
+} 0
+
+set ::env(TZ) "UTC0"
+set epoch [clock scan 2000-01-01]
+foreach {n stamp date} {
+ 1 86340 {Sat, 01 Jan 2000 23:59:00 +0000}
+ 2 5176620 {Tue, 29 Feb 2000 21:57:00 +0000}
+ 3 31610520 {Sun, 31 Dec 2000 20:42:00 +0000}
+ 4 31708740 {Mon, 01 Jan 2001 23:59:00 +0000}
+ 5 68248620 {Thu, 28 Feb 2002 21:57:00 +0000}
+ 6 126218520 {Wed, 31 Dec 2003 20:42:00 +0000}
+} {
+ test mime-10.$n "Test formatting dates (RFC 822)" {
+ # To verify that clock scan gets the expected value.
+ set stamp_test [expr {[mime::parsedatetime $date clock] - $epoch}]
+ # Parse and re-format should get us the original.
+ set parsed_test [mime::parsedatetime $date proper]
+ list $stamp_test $parsed_test
+ } [list $stamp $date]
+}
+
+
+test mime-11.0 {Bug 1825092} {
+ set in [makeFile {From sw@fooooooooo.de Sat Oct 20 17:58:49 2007
+Return-Path: <sw@fooooooooo.de>
+Message-ID: <17849372.3849122@fooooooooo.de>
+From: Somwhere <sw@fooooooooo.de>
+MIME-Version: 1.0
+To: Here <h@fooooooooo.de>
+Subject: test
+Content-Type: multipart/mixed;
+ boundary="------------090305080603000703000106"
+
+This is a multi-part message in MIME format.
+--------------090305080603000703000106
+Content-Type: text/plain; charset=ISO-8859-15
+Content-Transfer-Encoding: 8bit
+
+XXX
+
+--------------090305080603000703000106
+Content-Disposition: attachment;
+ filename="a0036.dss"
+Content-Transfer-Encoding: base64
+Content-Type: application/octet-stream;
+ name="a0036.dss"
+
+BGRzcwEAAQABAAAAYQAAAAAAAAAAAAAAAAAAACQAAAD+//7/+/8wNzA2MTYwODE1MjQwNzA2
+AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAZ
+--------------090305080603000703000106--
+} mail_part]
+ set token [mime::initialize -file $in]
+ set allparts [mime::getproperty $token parts]
+ set attachment [lindex $allparts 1]
+
+ set out [makeFile {} mail_att]
+ set ofh [open $out w]
+ fconfigure $ofh -translation binary
+ mime::copymessage $attachment $ofh
+ close $ofh
+
+ set data [viewFile $out]
+ file delete $in $out
+ set data
+} {MIME-Version: 1.0
+Content-Disposition: attachment;
+ filename="a0036.dss"
+Content-Transfer-Encoding: base64
+Content-Type: application/octet-stream;
+ name="a0036.dss"
+
+BGRzcwEAAQABAAAAYQAAAAAAAAAAAAAAAAAAACQAAAD+//7/+/8wNzA2MTYwODE1MjQwNzA2
+AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAZ}
+
+# -------------------------------------------------------------------------
+
+test mime-12.0 {Bug 3483716} {
+ set token [mime::initialize -string {Content-Type: message/delivery-status; name="deliverystatus.txt"
+Content-Disposition: attachment; filename="deliverystatus.txt"; size=138;
+creation-date="Thu, 02 Feb 2012 13:50:05 GMT";
+modification-date="Thu, 02 Feb 2012 13:50:05 GMT"
+Content-Description: deliverystatus.txt
+Content-Transfer-Encoding: base64
+
+T3JpZ2luYWwtUmVjaXBpZW50OiA8L2ZheD1ibHViYkBndW1taS5ib290PgpBY3Rpb246IGZhaWxl
+ZApEaWFnbm9zdGljLUNvZGU6IHNtdHA7IDU1MCAjNS4xLjAgQWRkcmVzcyByZWplY3RlZC4KUmVt
+b3RlLU1UQTogNTMuMjQuMjgyLjE1MA==
+}]
+ set parts [mime::getproperty $token parts]
+ mime::getheader [lindex $parts end] Remote-MTA
+} 53.24.282.150
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/mime/pkgIndex.tcl b/tcllib/modules/mime/pkgIndex.tcl
new file mode 100644
index 0000000..973efdc
--- /dev/null
+++ b/tcllib/modules/mime/pkgIndex.tcl
@@ -0,0 +1,4 @@
+if {![package vsatisfies [package provide Tcl] 8.3]} {return}
+package ifneeded smtp 1.4.5 [list source [file join $dir smtp.tcl]]
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+package ifneeded mime 1.6 [list source [file join $dir mime.tcl]]
diff --git a/tcllib/modules/mime/rfc2629.dtd b/tcllib/modules/mime/rfc2629.dtd
new file mode 100644
index 0000000..9ae39b3
--- /dev/null
+++ b/tcllib/modules/mime/rfc2629.dtd
@@ -0,0 +1,209 @@
+<!--
+ DTD for the RFC document series, draft of 99-01-30
+ -->
+
+
+<!--
+ Contents
+
+ DTD data types
+
+ The top-level
+
+ Front matter
+
+ The Body
+
+ Back matter
+ -->
+
+
+<!--
+ DTD data types:
+
+ entity description
+ ====== ===============================================
+ NUMBER [0-9]+
+ NUMBERS a comma-separated list of NUMBER
+
+ DAY the day of the month, e.g., "1"
+ MONTH the month of the year, e.g., "January"
+ YEAR a four-digit year, e.g., "1999"
+
+ URI e.g., "http://invisible.net/"
+
+ ATEXT/CTEXT printable ASCII text (no line-terminators)
+
+ TEXT character data
+ -->
+
+
+<!ENTITY % NUMBER "CDATA">
+<!ENTITY % NUMBERS "CDATA">
+
+<!ENTITY % DAY "CDATA">
+<!ENTITY % MONTH "CDATA">
+<!ENTITY % YEAR "CDATA">
+
+<!ENTITY % URI "CDATA">
+
+<!ENTITY % ATEXT "CDATA">
+<!ENTITY % CTEXT "#PCDATA">
+
+<!ENTITY % TEXT "#PCDATA">
+
+<!ENTITY rfc.number "XXXX">
+
+
+<!--
+ The top-level
+ -->
+
+
+<!--
+ attributes for the "rfc" element are supplied by the RFC
+ editor. when preparing drafts, authors should leave them blank.
+
+ the "seriesNo" attribute is used if the category is, e.g., BCP.
+ -->
+<!ELEMENT rfc (front,middle,back?)>
+<!ATTLIST rfc
+ number %NUMBER; #IMPLIED
+ obsoletes %NUMBERS; ""
+ updates %NUMBERS; ""
+ category (std|bcp|info|exp|historic)
+ "info"
+ seriesNo %NUMBER; #IMPLIED
+ ipr (full2026|noDerivativeWorks2026|none)
+ #IMPLIED
+ docName %ATEXT; #IMPLIED>
+
+<!--
+ Front matter
+ -->
+
+
+<!ELEMENT front (title,author+,date,area*,workgroup*,keyword*,
+ abstract?,note*)>
+
+<!-- the "abbrev" attribute is used for headers, etc. -->
+<!ELEMENT title (%CTEXT;)>
+<!ATTLIST title
+ abbrev %ATEXT; #IMPLIED>
+
+<!ELEMENT author (organization,address?)>
+<!ATTLIST author
+ initials %ATEXT; #IMPLIED
+ surname %ATEXT; #IMPLIED
+ fullname %ATEXT; #IMPLIED>
+
+<!ELEMENT organization
+ (%CTEXT;)>
+<!ATTLIST organization
+ abbrev %ATEXT; #IMPLIED>
+
+<!ELEMENT address (postal?,phone?,facsimile?,email?,uri?)>
+
+<!-- at most one of each the city, region, code, and country
+ elements may be present -->
+<!ELEMENT postal (street+,(city|region|code|country)*)>
+<!ELEMENT street (%CTEXT;)>
+<!ELEMENT city (%CTEXT;)>
+<!ELEMENT region (%CTEXT;)>
+<!ELEMENT code (%CTEXT;)>
+<!ELEMENT country (%CTEXT;)>
+<!ELEMENT phone (%CTEXT;)>
+<!ELEMENT facsimile (%CTEXT;)>
+<!ELEMENT email (%CTEXT;)>
+<!ELEMENT uri (%CTEXT;)>
+
+<!ELEMENT date EMPTY>
+<!ATTLIST date
+ day %DAY; #IMPLIED
+ month %MONTH; #REQUIRED
+ year %YEAR; #REQUIRED>
+
+<!-- meta-data... -->
+<!ELEMENT area (%CTEXT;)>
+<!ELEMENT workgroup (%CTEXT;)>
+<!ELEMENT keyword (%CTEXT;)>
+
+<!ELEMENT abstract (t)+>
+<!ELEMENT note (t)+>
+<!ATTLIST note
+ title %ATEXT; #REQUIRED>
+
+
+<!--
+ The body
+ -->
+
+
+<!ELEMENT middle (section)+>
+
+<!ELEMENT section (t|figure|section)*>
+<!ATTLIST section
+ anchor ID #IMPLIED
+ title %ATEXT; #REQUIRED>
+
+<!ELEMENT t (%TEXT;|list|figure|xref|eref|iref|vspace)*>
+<!ATTLIST t
+ hangText %ATEXT; #IMPLIED>
+
+<!-- the value of the style attribute is inherited from the closest
+ parent -->
+<!ELEMENT list (t+)>
+<!ATTLIST list
+ style (numbers|symbols|hanging|empty)
+ "empty">
+
+<!ELEMENT xref (%CTEXT;)>
+<!ATTLIST xref
+ target IDREF #REQUIRED
+ pageno (true|false) "false">
+
+<!ELEMENT eref (%CTEXT;)>
+<!ATTLIST eref
+ target %URI; #REQUIRED>
+
+<!ELEMENT iref EMPTY>
+<!ATTLIST iref
+ item %ATEXT; #REQUIRED
+ subitem %ATEXT; "">
+
+<!ELEMENT vspace EMPTY>
+<!ATTLIST vspace
+ blankLines %NUMBER; "0">
+
+<!ELEMENT figure (preamble?,artwork,postamble?)>
+<!ATTLIST figure
+ anchor ID #IMPLIED
+ title %ATEXT; "">
+
+<!ELEMENT preamble (%TEXT;|xref|eref|iref)*>
+<!ELEMENT artwork (%TEXT;)*>
+<!ATTLIST artwork
+ xml:space (default|preserve) "preserve"
+ name %ATEXT; ""
+ type %ATEXT; "">
+
+<!ELEMENT postamble (%TEXT;|xref|eref|iref)*>
+
+
+<!--
+ Back matter
+ -->
+
+
+<!-- sections, if present, are appendices -->
+<!ELEMENT back (references?,section*)>
+
+<!ELEMENT references (reference+)>
+<!ELEMENT reference (front,seriesInfo*)>
+<!ATTLIST reference
+ anchor ID #IMPLIED
+ target %URI; #IMPLIED>
+<!ELEMENT seriesInfo EMPTY>
+<!ATTLIST seriesInfo
+ name %ATEXT; #REQUIRED
+ value %ATEXT; #REQUIRED>
diff --git a/tcllib/modules/mime/smtp.man b/tcllib/modules/mime/smtp.man
new file mode 100644
index 0000000..4e5a00b
--- /dev/null
+++ b/tcllib/modules/mime/smtp.man
@@ -0,0 +1,190 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin smtp n 1.4.5]
+[see_also ftp]
+[see_also http]
+[see_also mime]
+[see_also pop3]
+[copyright {1999-2000 Marshall T. Rose and others}]
+[moddesc {smtp client}]
+[titledesc {Client-side tcl implementation of the smtp protocol}]
+[category Networking]
+[require Tcl]
+[require mime [opt 1.5.4]]
+[require smtp [opt 1.4.5]]
+[description]
+[para]
+
+The [package smtp] library package provides the client side of the
+Simple Mail Transfer Protocol (SMTP) (1) (2).
+
+[list_begin definitions]
+
+[call [cmd ::smtp::sendmessage] [arg token] [arg option]...]
+
+This command sends the MIME part (see package [package mime])
+represented by [arg token] to an SMTP server. [arg options] is a list
+of options and their associated values. The recognized options are:
+
+[list_begin definitions]
+
+[def [option -servers]]
+
+A list of SMTP servers. The default is [const localhost].
+
+[def [option -ports]]
+
+A list of SMTP ports. The default is [const 25].
+
+[def [option -client]]
+
+The name to use as our hostname when connecting to the server. By
+default this is either localhost if one of the servers is localhost,
+or is set to the string returned by [cmd "info hostname"].
+
+[def [option -queue]]
+
+Indicates that the SMTP server should be asked to queue the message
+for later processing. A boolean value.
+
+[def [option -atleastone]]
+
+Indicates that the SMTP server must find at least one recipient
+acceptable for the message to be sent. A boolean value.
+
+[def [option -originator]]
+
+A string containing an 822-style address specification. If present the
+header isn't examined for an originator address.
+
+[def [option -recipients]]
+
+A string containing one or more 822-style address specifications. If
+present the header isn't examined for recipient addresses). If the
+string contains more than one address they will be separated by
+commas.
+
+[def [option -header]]
+
+A list containing two elements, an smtp header and its associated
+value (the -header option may occur zero or more times).
+
+[def [option -usetls]]
+
+This package supports the RFC 3207 TLS extension (3) by default provided the
+tls package is available. You can turn this off with this boolean option.
+
+[def [option -tlspolicy]]
+
+This option lets you specify a command to be called if an error occurs
+during TLS setup. The command is called with the SMTP code and diagnostic
+message appended. The command should return 'secure' or 'insecure' where
+insecure will cause the package to continue on the unencrypted channel.
+Returning 'secure' will cause the socket to be closed and the next server
+in the [option -servers] list to be tried.
+
+[def [option -username]]
+[def [option -password]]
+
+If your SMTP server requires authentication (RFC 2554 (4)) before
+accepting mail you can use [option -username] and [option -password]
+to provide your authentication details to the server. Currently this
+package supports DIGEST-MD5, CRAM-MD5, LOGIN and PLAIN authentication
+methods. The most secure method will be tried first and each method
+tried in turn until we are either authorized or we run out of
+methods. Note that if the server permits a TLS connection, then the
+authorization will occur after we begin using the secure channel.
+
+[para]
+Please also read the section on [sectref Authentication], it details
+the necessary prequisites, i.e. packages needed to support these
+options and authentication.
+
+[list_end]
+[para]
+
+If the [option -originator] option is not present, the originator
+address is taken from [const From] (or [const Resent-From]);
+similarly, if the [option -recipients] option is not present,
+recipient addresses are taken from [const To], [const cc], and
+[const Bcc] (or [const Resent-To], and so on). Note that the header
+key/values supplied by the [option -header] option (not those present
+in the MIME part) are consulted. Regardless, header key/values are
+added to the outgoing message as necessary to ensure that a valid
+822-style message is sent.
+
+[para]
+
+The command returns a list indicating which recipients were
+unacceptable to the SMTP server. Each element of the list is another
+list, containing the address, an SMTP error code, and a textual
+diagnostic. Depending on the [option -atleastone] option and the
+intended recipients, a non-empty list may still indicate that the
+message was accepted by the server.
+
+[list_end]
+
+[section Authentication]
+
+Beware. SMTP authentication uses [package SASL]. I.e. if the user
+has to authenticate a connection, i.e. use the options [option -user]
+and [option -password] (see above) it is necessary to have the
+[package sasl] package available so that [package smtp] can load it.
+
+[para]
+
+This is a soft dependency because not everybody requires authentication,
+and [package sasl] depends on a lot of the cryptographic (secure) hashes,
+i.e. all of [package md5], [package otp], [package md4], [package sha1],
+and [package ripemd160].
+
+[section EXAMPLE]
+
+[example {
+proc send_simple_message {recipient email_server subject body} {
+ package require smtp
+ package require mime
+
+ set token [mime::initialize -canonical text/plain \\
+ -string $body]
+ mime::setheader $token Subject $subject
+ smtp::sendmessage $token \\
+ -recipients $recipient -servers $email_server
+ mime::finalize $token
+}
+
+send_simple_message someone@somewhere.com localhost \\
+ "This is the subject." "This is the message."
+}]
+
+[include ../common-text/tls-security-notes.inc]
+
+[section {REFERENCES}]
+
+[list_begin enumerated]
+
+[enum]
+ Jonathan B. Postel, "SIMPLE MAIL TRANSFER PROTOCOL", RFC 821, August 1982.
+ ([uri http://www.rfc-editor.org/rfc/rfc821.txt])
+
+[enum]
+ J. Klensin, "Simple Mail Transfer Protocol", RFC 2821, April 2001.
+ ([uri http://www.rfc-editor.org/rfc/rfc2821.txt])
+
+[enum]
+ P. Hoffman, "SMTP Service Extension for Secure SMTP over Transport
+ Layer Security", RFC 3207, February 2002.
+ ([uri http://www.rfc-editor.org/rfc/rfc3207.txt])
+
+[enum]
+ J. Myers, "SMTP Service Extension for Authentication",
+ RFC 2554, March 1999.
+ ([uri http://www.rfc-editor.org/rfc/rfc2554.txt])
+
+[list_end]
+
+[vset CATEGORY smtp]
+[include ../doctools2base/include/feedback.inc]
+
+[keywords mail mail email smtp mime tls \
+ {rfc 821} {rfc 822} {rfc 2821} {rfc 3207} {rfc 2554} internet net]
+[manpage_end]
diff --git a/tcllib/modules/mime/smtp.tcl b/tcllib/modules/mime/smtp.tcl
new file mode 100644
index 0000000..9e160e1
--- /dev/null
+++ b/tcllib/modules/mime/smtp.tcl
@@ -0,0 +1,1508 @@
+# smtp.tcl - SMTP client
+#
+# Copyright (c) 1999-2000 Marshall T. Rose
+# Copyright (c) 2003-2006 Pat Thoyts
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+package require Tcl 8.3
+package require mime 1.4.1
+
+catch {
+ package require SASL 1.0; # tcllib 1.8
+ package require SASL::NTLM 1.0; # tcllib 1.8
+}
+
+#
+# state variables:
+#
+# sd: socket to server
+# afterID: afterID associated with ::smtp::timer
+# options: array of user-supplied options
+# readable: semaphore for vwait
+# addrs: number of recipients negotiated
+# error: error during read
+# line: response read from server
+# crP: just put a \r in the data
+# nlP: just put a \n in the data
+# size: number of octets sent in DATA
+#
+
+namespace eval ::smtp {
+ variable trf 1
+ variable smtp
+ array set smtp { uid 0 }
+
+ namespace export sendmessage
+}
+
+if {[catch {package require Trf 2.0}]} {
+ # Trf is not available, but we can live without it as long as the
+ # transform and unstack procs are defined.
+
+ # Warning!
+ # This is a fragile emulation of the more general calling sequence
+ # that appears to work with this code here.
+
+ proc transform {args} {
+ upvar state mystate
+ set mystate(size) 1
+ }
+ proc unstack {channel} {
+ # do nothing
+ return
+ }
+ set ::smtp::trf 0
+}
+
+
+# ::smtp::sendmessage --
+#
+# Sends a mime object (containing a message) to some recipients
+#
+# Arguments:
+# part The MIME object containing the message to send
+# args A list of arguments specifying various options for sending the
+# message:
+# -atleastone A boolean specifying whether or not to send the
+# message at all if any of the recipients are
+# invalid. A value of false (as defined by
+# ::smtp::boolean) means that ALL recipients must be
+# valid in order to send the message. A value of
+# true means that as long as at least one recipient
+# is valid, the message will be sent.
+# -debug A boolean specifying whether or not debugging is
+# on. If debugging is enabled, status messages are
+# printed to stderr while trying to send mail.
+# -queue A boolean specifying whether or not the message
+# being sent should be queued for later delivery.
+# -header A single RFC 822 header key and value (as a list),
+# used to specify to whom to send the message
+# (To, Cc, Bcc), the "From", etc.
+# -originator The originator of the message (equivalent to
+# specifying a From header).
+# -recipients A string containing recipient e-mail addresses.
+# NOTE: This option overrides any recipient addresses
+# specified with -header.
+# -servers A list of mail servers that could process the
+# request.
+# -ports A list of SMTP ports to use for each SMTP server
+# specified
+# -client The string to use as our host name for EHLO or HELO
+# This defaults to 'localhost' or [info hostname]
+# -maxsecs Maximum number of seconds to allow the SMTP server
+# to accept the message. If not specified, the default
+# is 120 seconds.
+# -usetls A boolean flag. If the server supports it and we
+# have the package, use TLS to secure the connection.
+# -tlspolicy A command to call if the TLS negotiation fails for
+# some reason. Return 'insecure' to continue with
+# normal SMTP or 'secure' to close the connection and
+# try another server.
+# -username These are needed if your SMTP server requires
+# -password authentication.
+#
+# Results:
+# Message is sent. On success, return "". On failure, throw an
+# exception with an error code and error message.
+
+proc ::smtp::sendmessage {part args} {
+ global errorCode errorInfo
+
+ # Here are the meanings of the following boolean variables:
+ # aloP -- value of -atleastone option above.
+ # debugP -- value of -debug option above.
+ # origP -- 1 if -originator option was specified, 0 otherwise.
+ # queueP -- value of -queue option above.
+
+ set aloP 0
+ set debugP 0
+ set origP 0
+ set queueP 0
+ set maxsecs 120
+ set originator ""
+ set recipients ""
+ set servers [list localhost]
+ set client "" ;# default is set after options processing
+ set ports [list 25]
+ set tlsP 1
+ set tlspolicy {}
+ set username {}
+ set password {}
+
+ array set header ""
+
+ # lowerL will contain the list of header keys (converted to lower case)
+ # specified with various -header options. mixedL is the mixed-case version
+ # of the list.
+ set lowerL ""
+ set mixedL ""
+
+ # Parse options (args).
+
+ if {[expr {[llength $args]%2}]} {
+ # Some option didn't get a value.
+ error "Each option must have a value! Invalid option list: $args"
+ }
+
+ foreach {option value} $args {
+ switch -- $option {
+ -atleastone {set aloP [boolean $value]}
+ -debug {set debugP [boolean $value]}
+ -queue {set queueP [boolean $value]}
+ -usetls {set tlsP [boolean $value]}
+ -tlspolicy {set tlspolicy $value}
+ -maxsecs {set maxsecs [expr {$value < 0 ? 0 : $value}]}
+ -header {
+ if {[llength $value] != 2} {
+ error "-header expects a key and a value, not $value"
+ }
+ set mixed [lindex $value 0]
+ set lower [string tolower $mixed]
+ set disallowedHdrList \
+ [list content-type \
+ content-transfer-encoding \
+ content-md5 \
+ mime-version]
+ if {[lsearch -exact $disallowedHdrList $lower] > -1} {
+ error "Content-Type, Content-Transfer-Encoding,\
+ Content-MD5, and MIME-Version cannot be user-specified."
+ }
+ if {[lsearch -exact $lowerL $lower] < 0} {
+ lappend lowerL $lower
+ lappend mixedL $mixed
+ }
+
+ lappend header($lower) [lindex $value 1]
+ }
+
+ -originator {
+ set originator $value
+ if {$originator == ""} {
+ set origP 1
+ }
+ }
+
+ -recipients {
+ set recipients $value
+ }
+
+ -servers {
+ set servers $value
+ }
+
+ -client {
+ set client $value
+ }
+
+ -ports {
+ set ports $value
+ }
+
+ -username { set username $value }
+ -password { set password $value }
+
+ default {
+ error "unknown option $option"
+ }
+ }
+ }
+
+ if {[lsearch -glob $lowerL resent-*] >= 0} {
+ set prefixL resent-
+ set prefixM Resent-
+ } else {
+ set prefixL ""
+ set prefixM ""
+ }
+
+ # Set a bunch of variables whose value will be the real header to be used
+ # in the outbound message (with proper case and prefix).
+
+ foreach mixed {From Sender To cc Dcc Bcc Date Message-ID} {
+ set lower [string tolower $mixed]
+ # FRINK: nocheck
+ set ${lower}L $prefixL$lower
+ # FRINK: nocheck
+ set ${lower}M $prefixM$mixed
+ }
+
+ if {$origP} {
+ # -originator was specified with "", so SMTP sender should be marked "".
+ set sender ""
+ } else {
+ # -originator was specified with a value, OR -originator wasn't
+ # specified at all.
+
+ # If no -originator was provided, get the originator from the "From"
+ # header. If there was no "From" header get it from the username
+ # executing the script.
+
+ set who "-originator"
+ if {$originator == ""} {
+ if {![info exists header($fromL)]} {
+ set originator $::tcl_platform(user)
+ } else {
+ set originator [join $header($fromL) ,]
+
+ # Indicate that we're using the From header for the originator.
+
+ set who $fromM
+ }
+ }
+
+ # If there's no "From" header, create a From header with the value
+ # of -originator as the value.
+
+ if {[lsearch -exact $lowerL $fromL] < 0} {
+ lappend lowerL $fromL
+ lappend mixedL $fromM
+ lappend header($fromL) $originator
+ }
+
+ # ::mime::parseaddress returns a list whose elements are huge key-value
+ # lists with info about the addresses. In this case, we only want one
+ # originator, so we want the length of the main list to be 1.
+
+ set addrs [::mime::parseaddress $originator]
+ if {[llength $addrs] > 1} {
+ error "too many mailboxes in $who: $originator"
+ }
+ array set aprops {error "invalid address \"$from\""}
+ array set aprops [lindex $addrs 0]
+ if {$aprops(error) != ""} {
+ error "error in $who: $aprops(error)"
+ }
+
+ # sender = validated originator or the value of the From header.
+
+ set sender $aprops(address)
+
+ # If no Sender header has been specified and From is different from
+ # originator, then set the sender header to the From. Otherwise, don't
+ # specify a Sender header.
+ set from [join $header($fromL) ,]
+ if {[lsearch -exact $lowerL $senderL] < 0 && \
+ [string compare $originator $from]} {
+ if {[info exists aprops]} {
+ unset aprops
+ }
+ array set aprops {error "invalid address \"$from\""}
+ array set aprops [lindex [::mime::parseaddress $from] 0]
+ if {$aprops(error) != ""} {
+ error "error in $fromM: $aprops(error)"
+ }
+ if {[string compare $aprops(address) $sender]} {
+ lappend lowerL $senderL
+ lappend mixedL $senderM
+ lappend header($senderL) $aprops(address)
+ }
+ }
+ }
+
+ # We're done parsing the arguments.
+
+ if {$recipients != ""} {
+ set who -recipients
+ } elseif {![info exists header($toL)]} {
+ error "need -header \"$toM ...\""
+ } else {
+ set recipients [join $header($toL) ,]
+ # Add Cc values to recipients list
+ set who $toM
+ if {[info exists header($ccL)]} {
+ append recipients ,[join $header($ccL) ,]
+ append who /$ccM
+ }
+
+ set dccInd [lsearch -exact $lowerL $dccL]
+ if {$dccInd >= 0} {
+ # Add Dcc values to recipients list, and get rid of Dcc header
+ # since we don't want to output that.
+ append recipients ,[join $header($dccL) ,]
+ append who /$dccM
+
+ unset header($dccL)
+ set lowerL [lreplace $lowerL $dccInd $dccInd]
+ set mixedL [lreplace $mixedL $dccInd $dccInd]
+ }
+ }
+
+ set brecipients ""
+ set bccInd [lsearch -exact $lowerL $bccL]
+ if {$bccInd >= 0} {
+ set bccP 1
+
+ # Build valid bcc list and remove bcc element of header array (so that
+ # bcc info won't be sent with mail).
+ foreach addr [::mime::parseaddress [join $header($bccL) ,]] {
+ if {[info exists aprops]} {
+ unset aprops
+ }
+ array set aprops {error "invalid address \"$from\""}
+ array set aprops $addr
+ if {$aprops(error) != ""} {
+ error "error in $bccM: $aprops(error)"
+ }
+ lappend brecipients $aprops(address)
+ }
+
+ unset header($bccL)
+ set lowerL [lreplace $lowerL $bccInd $bccInd]
+ set mixedL [lreplace $mixedL $bccInd $bccInd]
+ } else {
+ set bccP 0
+ }
+
+ # If there are no To headers, add "" to bcc list. WHY??
+ if {[lsearch -exact $lowerL $toL] < 0} {
+ lappend lowerL $bccL
+ lappend mixedL $bccM
+ lappend header($bccL) ""
+ }
+
+ # Construct valid recipients list from recipients list.
+
+ set vrecipients ""
+ foreach addr [::mime::parseaddress $recipients] {
+ if {[info exists aprops]} {
+ unset aprops
+ }
+ array set aprops {error "invalid address \"$from\""}
+ array set aprops $addr
+ if {$aprops(error) != ""} {
+ error "error in $who: $aprops(error)"
+ }
+ lappend vrecipients $aprops(address)
+ }
+
+ # If there's no date header, get the date from the mime message. Same for
+ # the message-id.
+
+ if {([lsearch -exact $lowerL $dateL] < 0) \
+ && ([catch { ::mime::getheader $part $dateL }])} {
+ lappend lowerL $dateL
+ lappend mixedL $dateM
+ lappend header($dateL) [::mime::parsedatetime -now proper]
+ }
+
+ if {([lsearch -exact $lowerL ${message-idL}] < 0) \
+ && ([catch { ::mime::getheader $part ${message-idL} }])} {
+ lappend lowerL ${message-idL}
+ lappend mixedL ${message-idM}
+ lappend header(${message-idL}) [::mime::uniqueID]
+
+ }
+
+ # Get all the headers from the MIME object and save them so that they can
+ # later be restored.
+ set savedH [::mime::getheader $part]
+
+ # Take all the headers defined earlier and add them to the MIME message.
+ foreach lower $lowerL mixed $mixedL {
+ foreach value $header($lower) {
+ ::mime::setheader $part $mixed $value -mode append
+ }
+ }
+
+ if {[string length $client] < 1} {
+ if {![string compare $servers localhost]} {
+ set client localhost
+ } else {
+ set client [info hostname]
+ }
+ }
+
+ # Create smtp token, which essentially means begin talking to the SMTP
+ # server.
+ set token [initialize -debug $debugP -client $client \
+ -maxsecs $maxsecs -usetls $tlsP \
+ -multiple $bccP -queue $queueP \
+ -servers $servers -ports $ports \
+ -tlspolicy $tlspolicy \
+ -username $username -password $password]
+
+ if {![string match "::smtp::*" $token]} {
+ # An error occurred and $token contains the error info
+ array set respArr $token
+ return -code error $respArr(diagnostic)
+ }
+
+ set code [catch { sendmessageaux $token $part \
+ $sender $vrecipients $aloP } \
+ result]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ # Send the message to bcc recipients as a MIME attachment.
+
+ if {($code == 0) && ($bccP)} {
+ set inner [::mime::initialize -canonical message/rfc822 \
+ -header [list Content-Description \
+ "Original Message"] \
+ -parts [list $part]]
+
+ set subject "\[$bccM\]"
+ if {[info exists header(subject)]} {
+ append subject " " [lindex $header(subject) 0]
+ }
+
+ set outer [::mime::initialize \
+ -canonical multipart/digest \
+ -header [list From $originator] \
+ -header [list Bcc ""] \
+ -header [list Date \
+ [::mime::parsedatetime -now proper]] \
+ -header [list Subject $subject] \
+ -header [list Message-ID [::mime::uniqueID]] \
+ -header [list Content-Description \
+ "Blind Carbon Copy"] \
+ -parts [list $inner]]
+
+
+ set code [catch { sendmessageaux $token $outer \
+ $sender $brecipients \
+ $aloP } result2]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ if {$code == 0} {
+ set result [concat $result $result2]
+ } else {
+ set result $result2
+ }
+
+ catch { ::mime::finalize $inner -subordinates none }
+ catch { ::mime::finalize $outer -subordinates none }
+ }
+
+ # Determine if there was any error in prior operations and set errorcodes
+ # and error messages appropriately.
+
+ switch -- $code {
+ 0 {
+ set status orderly
+ }
+
+ 7 {
+ set code 1
+ array set response $result
+ set result "$response(code): $response(diagnostic)"
+ set status abort
+ }
+
+ default {
+ set status abort
+ }
+ }
+
+ # Destroy SMTP token 'cause we're done with it.
+
+ catch { finalize $token -close $status }
+
+ # Restore provided MIME object to original state (without the SMTP headers).
+
+ foreach key [::mime::getheader $part -names] {
+ mime::setheader $part $key "" -mode delete
+ }
+ foreach {key values} $savedH {
+ foreach value $values {
+ ::mime::setheader $part $key $value -mode append
+ }
+ }
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+}
+
+# ::smtp::sendmessageaux --
+#
+# Sends a mime object (containing a message) to some recipients using an
+# existing SMTP token.
+#
+# Arguments:
+# token SMTP token that has an open connection to the SMTP server.
+# part The MIME object containing the message to send.
+# originator The e-mail address of the entity sending the message,
+# usually the From clause.
+# recipients List of e-mail addresses to whom message will be sent.
+# aloP Boolean "atleastone" setting; see the -atleastone option
+# in ::smtp::sendmessage for details.
+#
+# Results:
+# Message is sent. On success, return "". On failure, throw an
+# exception with an error code and error message.
+
+proc ::smtp::sendmessageaux {token part originator recipients aloP} {
+ global errorCode errorInfo
+
+ winit $token $part $originator
+
+ set goodP 0
+ set badP 0
+ set oops ""
+ foreach recipient $recipients {
+ set code [catch { waddr $token $recipient } result]
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ switch -- $code {
+ 0 {
+ incr goodP
+ }
+
+ 7 {
+ incr badP
+
+ array set response $result
+ lappend oops [list $recipient $response(code) \
+ $response(diagnostic)]
+ }
+
+ default {
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+ }
+ }
+ }
+
+ if {($goodP) && ((!$badP) || ($aloP))} {
+ wtext $token $part
+ } else {
+ catch { talk $token 300 RSET }
+ }
+
+ return $oops
+}
+
+# ::smtp::initialize --
+#
+# Create an SMTP token and open a connection to the SMTP server.
+#
+# Arguments:
+# args A list of arguments specifying various options for sending the
+# message:
+# -debug A boolean specifying whether or not debugging is
+# on. If debugging is enabled, status messages are
+# printed to stderr while trying to send mail.
+# -client Either localhost or the name of the local host.
+# -multiple Multiple messages will be sent using this token.
+# -queue A boolean specifying whether or not the message
+# being sent should be queued for later delivery.
+# -servers A list of mail servers that could process the
+# request.
+# -ports A list of ports on mail servers that could process
+# the request (one port per server-- defaults to 25).
+# -usetls A boolean to indicate we will use TLS if possible.
+# -tlspolicy Command called if TLS setup fails.
+# -username These provide the authentication information
+# -password to be used if needed by the SMTP server.
+#
+# Results:
+# On success, return an smtp token. On failure, throw
+# an exception with an error code and error message.
+
+proc ::smtp::initialize {args} {
+ global errorCode errorInfo
+
+ variable smtp
+
+ set token [namespace current]::[incr smtp(uid)]
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set state [list afterID "" options "" readable 0]
+ array set options [list -debug 0 -client localhost -multiple 1 \
+ -maxsecs 120 -queue 0 -servers localhost \
+ -ports 25 -usetls 1 -tlspolicy {} \
+ -username {} -password {}]
+ array set options $args
+ set state(options) [array get options]
+
+ # Iterate through servers until one accepts a connection (and responds
+ # nicely).
+
+ set index 0
+ foreach server $options(-servers) {
+ set state(readable) 0
+ if {[llength $options(-ports)] >= $index} {
+ set port [lindex $options(-ports) $index]
+ } else {
+ set port 25
+ }
+ if {$options(-debug)} {
+ puts stderr "Trying $server..."
+ flush stderr
+ }
+
+ if {[info exists state(sd)]} {
+ unset state(sd)
+ }
+
+ if {[set code [catch {
+ set state(sd) [socket -async $server $port]
+ fconfigure $state(sd) -blocking off -translation binary
+ fileevent $state(sd) readable [list ::smtp::readable $token]
+ } result]]} {
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ catch { close $state(sd) }
+ continue
+ }
+
+ if {[set code [catch { hear $token 600 } result]]} {
+ array set response [list code 400 diagnostic $result]
+ } else {
+ array set response $result
+ }
+ set ecode $errorCode
+ set einfo $errorInfo
+ switch -- $response(code) {
+ 220 {
+ }
+
+ 421 - default {
+ # 421 - Temporary problem on server
+ catch {close $state(sd)}
+ continue
+ }
+ }
+
+ set r [initialize_ehlo $token]
+ if {$r != {}} {
+ return $r
+ }
+ incr index
+ }
+
+ # None of the servers accepted our connection, so close everything up and
+ # return an error.
+ finalize $token -close drop
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+}
+
+# If we cannot load the tls package, ignore the error
+proc ::smtp::load_tls {} {
+ set r [catch {package require tls}]
+ if {$r} {set ::errorInfo ""}
+ return $r
+}
+
+proc ::smtp::initialize_ehlo {token} {
+ global errorCode errorInfo
+ upvar einfo einfo
+ upvar ecode ecode
+ upvar code code
+
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+ array set options $state(options)
+
+ # Try enhanced SMTP first.
+
+ if {[set code [catch {smtp::talk $token 300 "EHLO $options(-client)"} \
+ result]]} {
+ array set response [list code 400 diagnostic $result args ""]
+ } else {
+ array set response $result
+ }
+ set ecode $errorCode
+ set einfo $errorInfo
+ if {(500 <= $response(code)) && ($response(code) <= 599)} {
+ if {[set code [catch { talk $token 300 \
+ "HELO $options(-client)" } \
+ result]]} {
+ array set response [list code 400 diagnostic $result args ""]
+ } else {
+ array set response $result
+ }
+ set ecode $errorCode
+ set einfo $errorInfo
+ }
+
+ if {$response(code) == 250} {
+ # Successful response to HELO or EHLO command, so set up queuing
+ # and whatnot and return the token.
+
+ set state(esmtp) $response(args)
+
+ if {(!$options(-multiple)) \
+ && ([lsearch $response(args) ONEX] >= 0)} {
+ catch {smtp::talk $token 300 ONEX}
+ }
+ if {($options(-queue)) \
+ && ([lsearch $response(args) XQUE] >= 0)} {
+ catch {smtp::talk $token 300 QUED}
+ }
+
+ # Support STARTTLS extension.
+ # The state(tls) item is used to see if we have already tried this.
+ if {($options(-usetls)) && ![info exists state(tls)] \
+ && (([lsearch $response(args) STARTTLS] >= 0)
+ || ([lsearch $response(args) TLS] >= 0))} {
+ if {![load_tls]} {
+ set state(tls) 0
+ if {![catch {smtp::talk $token 300 STARTTLS} resp]} {
+ array set starttls $resp
+ if {$starttls(code) == 220} {
+ fileevent $state(sd) readable {}
+ catch {
+ ::tls::import $state(sd)
+ catch {::tls::handshake $state(sd)} msg
+ set state(tls) 1
+ }
+ fileevent $state(sd) readable \
+ [list ::smtp::readable $token]
+ return [initialize_ehlo $token]
+ } else {
+ # Call a TLS client policy proc here
+ # returns secure close and try another server.
+ # returns insecure continue on current socket
+ set policy insecure
+ if {$options(-tlspolicy) != {}} {
+ catch {
+ eval $options(-tlspolicy) \
+ [list $starttls(code)] \
+ [list $starttls(diagnostic)]
+ } policy
+ }
+ if {$policy != "insecure"} {
+ set code error
+ set ecode $starttls(code)
+ set einfo $starttls(diagnostic)
+ catch {close $state(sd)}
+ return {}
+ }
+ }
+ }
+ }
+ }
+
+ # If we have not already tried and the server supports it and we
+ # have a username -- lets try to authenticate.
+ #
+ if {![info exists state(auth)]
+ && [llength [package provide SASL]] != 0
+ && [set andx [lsearch -glob $response(args) "AUTH*"]] >= 0
+ && [string length $options(-username)] > 0 } {
+
+ # May be AUTH mech or AUTH=mech
+ # We want to use the strongest mechanism that has been offered
+ # and that we support. If we cannot find a mechanism that
+ # succeeds, we will go ahead and try to carry on unauthenticated.
+ # This may still work else we'll get an unauthorised error later.
+
+ set mechs [string range [lindex $response(args) $andx] 5 end]
+ foreach mech [SASL::mechanisms] {
+ if {[lsearch -exact $mechs $mech] == -1} { continue }
+ if {[catch {
+ Authenticate $token $mech
+ } msg]} {
+ if {$options(-debug)} {
+ puts stderr "AUTH $mech failed: $msg "
+ flush stderr
+ }
+ }
+ if {[info exists state(auth)] && $state(auth)} {
+ if {$state(auth) == 1} {
+ break
+ } else {
+ # After successful AUTH we are supposed to redo
+ # our connection for mechanisms that setup a new
+ # security layer -- these should set state(auth)
+ # greater than 1
+ fileevent $state(sd) readable \
+ [list ::smtp::readable $token]
+ return [initialize_ehlo $token]
+ }
+ }
+ }
+ }
+
+ return $token
+ } else {
+ # Bad response; close the connection and hope the next server
+ # is happier.
+ catch {close $state(sd)}
+ }
+ return {}
+}
+
+proc ::smtp::SASLCallback {token context command args} {
+ upvar #0 $token state
+ upvar #0 $context ctx
+ array set options $state(options)
+ switch -exact -- $command {
+ login { return "" }
+ username { return $options(-username) }
+ password { return $options(-password) }
+ hostname { return [info host] }
+ realm {
+ if {[string equal $ctx(mech) "NTLM"] \
+ && [info exists ::env(USERDOMAIN)]} {
+ return $::env(USERDOMAIN)
+ } else {
+ return ""
+ }
+ }
+ default {
+ return -code error "error: unsupported SASL information requested"
+ }
+ }
+}
+
+proc ::smtp::Authenticate {token mechanism} {
+ upvar 0 $token state
+ package require base64
+ set ctx [SASL::new -mechanism $mechanism \
+ -callback [list [namespace origin SASLCallback] $token]]
+
+ set state(auth) 0
+ set result [smtp::talk $token 300 "AUTH $mechanism"]
+ array set response $result
+
+ while {$response(code) == 334} {
+ # The NTLM initial response is not base64 encoded so handle it.
+ if {[catch {base64::decode $response(diagnostic)} challenge]} {
+ set challenge $response(diagnostic)
+ }
+ SASL::step $ctx $challenge
+ set result [smtp::talk $token 300 \
+ [base64::encode -maxlen 0 [SASL::response $ctx]]]
+ array set response $result
+ }
+
+ if {$response(code) == 235} {
+ set state(auth) 1
+ return $result
+ } else {
+ return -code 7 $result
+ }
+}
+
+# ::smtp::finalize --
+#
+# Deletes an SMTP token by closing the connection to the SMTP server,
+# cleanup up various state.
+#
+# Arguments:
+# token SMTP token that has an open connection to the SMTP server.
+# args Optional arguments, where the only useful option is -close,
+# whose valid values are the following:
+# orderly Normal successful completion. Close connection and
+# clear state variables.
+# abort A connection exists to the SMTP server, but it's in
+# a weird state and needs to be reset before being
+# closed. Then clear state variables.
+# drop No connection exists, so we just need to clean up
+# state variables.
+#
+# Results:
+# SMTP connection is closed and state variables are cleared. If there's
+# an error while attempting to close the connection to the SMTP server,
+# throw an exception with the error code and error message.
+
+proc ::smtp::finalize {token args} {
+ global errorCode errorInfo
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set options [list -close orderly]
+ array set options $args
+
+ switch -- $options(-close) {
+ orderly {
+ set code [catch { talk $token 120 QUIT } result]
+ }
+
+ abort {
+ set code [catch {
+ talk $token 0 RSET
+ talk $token 0 QUIT
+ } result]
+ }
+
+ drop {
+ set code 0
+ set result ""
+ }
+
+ default {
+ error "unknown value for -close $options(-close)"
+ }
+ }
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ catch { close $state(sd) }
+
+ if {$state(afterID) != ""} {
+ catch { after cancel $state(afterID) }
+ }
+
+ foreach name [array names state] {
+ unset state($name)
+ }
+ # FRINK: nocheck
+ unset $token
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+}
+
+# ::smtp::winit --
+#
+# Send originator info to SMTP server. This occurs after HELO/EHLO
+# command has completed successfully (in ::smtp::initialize). This function
+# is called by ::smtp::sendmessageaux.
+#
+# Arguments:
+# token SMTP token that has an open connection to the SMTP server.
+# part MIME token for the message to be sent. May be used for
+# handling some SMTP extensions.
+# originator The e-mail address of the entity sending the message,
+# usually the From clause.
+# mode SMTP command specifying the mode of communication. Default
+# value is MAIL.
+#
+# Results:
+# Originator info is sent and SMTP server's response is returned. If an
+# error occurs, throw an exception.
+
+proc ::smtp::winit {token part originator {mode MAIL}} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {[lsearch -exact [list MAIL SEND SOML SAML] $mode] < 0} {
+ error "unknown origination mode $mode"
+ }
+
+ set from "$mode FROM:<$originator>"
+
+ # RFC 1870 - SMTP Service Extension for Message Size Declaration
+ if {[info exists state(esmtp)]
+ && [lsearch -glob $state(esmtp) "SIZE*"] != -1} {
+ catch {
+ set size [string length [mime::buildmessage $part]]
+ append from " SIZE=$size"
+ }
+ }
+
+ array set response [set result [talk $token 600 $from]]
+
+ if {$response(code) == 250} {
+ set state(addrs) 0
+ return $result
+ } else {
+ return -code 7 $result
+ }
+}
+
+# ::smtp::waddr --
+#
+# Send recipient info to SMTP server. This occurs after originator info
+# is sent (in ::smtp::winit). This function is called by
+# ::smtp::sendmessageaux.
+#
+# Arguments:
+# token SMTP token that has an open connection to the SMTP server.
+# recipient One of the recipients to whom the message should be
+# delivered.
+#
+# Results:
+# Recipient info is sent and SMTP server's response is returned. If an
+# error occurs, throw an exception.
+
+proc ::smtp::waddr {token recipient} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ set result [talk $token 3600 "RCPT TO:<$recipient>"]
+ array set response $result
+
+ switch -- $response(code) {
+ 250 - 251 {
+ incr state(addrs)
+ return $result
+ }
+
+ default {
+ return -code 7 $result
+ }
+ }
+}
+
+# ::smtp::wtext --
+#
+# Send message to SMTP server. This occurs after recipient info
+# is sent (in ::smtp::winit). This function is called by
+# ::smtp::sendmessageaux.
+#
+# Arguments:
+# token SMTP token that has an open connection to the SMTP server.
+# part The MIME object containing the message to send.
+#
+# Results:
+# MIME message is sent and SMTP server's response is returned. If an
+# error occurs, throw an exception.
+
+proc ::smtp::wtext {token part} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+ array set options $state(options)
+
+ set result [talk $token 300 DATA]
+ array set response $result
+ if {$response(code) != 354} {
+ return -code 7 $result
+ }
+
+ if {[catch { wtextaux $token $part } result]} {
+ catch { puts -nonewline $state(sd) "\r\n.\r\n" ; flush $state(sd) }
+ return -code 7 [list code 400 diagnostic $result]
+ }
+
+ set secs $options(-maxsecs)
+
+ set result [talk $token $secs .]
+ array set response $result
+ switch -- $response(code) {
+ 250 - 251 {
+ return $result
+ }
+
+ default {
+ return -code 7 $result
+ }
+ }
+}
+
+# ::smtp::wtextaux --
+#
+# Helper function that coordinates writing the MIME message to the socket.
+# In particular, it stacks the channel leading to the SMTP server, sets up
+# some file events, sends the message, unstacks the channel, resets the
+# file events to their original state, and returns.
+#
+# Arguments:
+# token SMTP token that has an open connection to the SMTP server.
+# part The MIME object containing the message to send.
+#
+# Results:
+# Message is sent. If anything goes wrong, throw an exception.
+
+proc ::smtp::wtextaux {token part} {
+ global errorCode errorInfo
+
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ # Workaround a bug with stacking channels on top of TLS.
+ # FRINK: nocheck
+ set trf [set [namespace current]::trf]
+ if {[info exists state(tls)] && $state(tls)} {
+ set trf 0
+ }
+
+ flush $state(sd)
+ fileevent $state(sd) readable ""
+ if {$trf} {
+ transform -attach $state(sd) -command [list ::smtp::wdata $token]
+ } else {
+ set state(size) 1
+ }
+ fileevent $state(sd) readable [list ::smtp::readable $token]
+
+ # If trf is not available, get the contents of the message,
+ # replace all '.'s that start their own line with '..'s, and
+ # then write the mime body out to the filehandle. Do not forget to
+ # deal with bare LF's here too (SF bug #499242).
+
+ if {$trf} {
+ set code [catch { ::mime::copymessage $part $state(sd) } result]
+ } else {
+ set code [catch { ::mime::buildmessage $part } result]
+ if {$code == 0} {
+ # Detect and transform bare LF's into proper CR/LF
+ # sequences.
+
+ while {[regsub -all -- {([^\r])\n} $result "\\1\r\n" result]} {}
+ regsub -all -- {\n\.} $result "\n.." result
+
+ # Fix for bug #827436 - mail data must end with CRLF.CRLF
+ if {[string compare [string index $result end] "\n"] != 0} {
+ append result "\r\n"
+ }
+ set state(size) [string length $result]
+ puts -nonewline $state(sd) $result
+ set result ""
+ }
+ }
+ set ecode $errorCode
+ set einfo $errorInfo
+
+ flush $state(sd)
+ fileevent $state(sd) readable ""
+ if {$trf} {
+ unstack $state(sd)
+ }
+ fileevent $state(sd) readable [list ::smtp::readable $token]
+
+ return -code $code -errorinfo $einfo -errorcode $ecode $result
+}
+
+# ::smtp::wdata --
+#
+# This is the custom transform using Trf to do CR/LF translation. If Trf
+# is not installed on the system, then this function never gets called and
+# no translation occurs.
+#
+# Arguments:
+# token SMTP token that has an open connection to the SMTP server.
+# command Trf provided command for manipulating socket data.
+# buffer Data to be converted.
+#
+# Results:
+# buffer is translated, and state(size) is set. If Trf is not installed
+# on the system, the transform proc defined at the top of this file sets
+# state(size) to 1. state(size) is used later to determine a timeout
+# value.
+
+proc ::smtp::wdata {token command buffer} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ switch -- $command {
+ create/write -
+ clear/write -
+ delete/write {
+ set state(crP) 0
+ set state(nlP) 1
+ set state(size) 0
+ }
+
+ write {
+ set result ""
+
+ foreach c [split $buffer ""] {
+ switch -- $c {
+ "." {
+ if {$state(nlP)} {
+ append result .
+ }
+ set state(crP) 0
+ set state(nlP) 0
+ }
+
+ "\r" {
+ set state(crP) 1
+ set state(nlP) 0
+ }
+
+ "\n" {
+ if {!$state(crP)} {
+ append result "\r"
+ }
+ set state(crP) 0
+ set state(nlP) 1
+ }
+
+ default {
+ set state(crP) 0
+ set state(nlP) 0
+ }
+ }
+
+ append result $c
+ }
+
+ incr state(size) [string length $result]
+ return $result
+ }
+
+ flush/write {
+ set result ""
+
+ if {!$state(nlP)} {
+ if {!$state(crP)} {
+ append result "\r"
+ }
+ append result "\n"
+ }
+
+ incr state(size) [string length $result]
+ return $result
+ }
+
+ create/read -
+ delete/read {
+ # Bugfix for [#539952]
+ }
+
+ query/ratio {
+ # Indicator for unseekable channel,
+ # for versions of Trf which ask for
+ # this.
+ return {0 0}
+ }
+ query/maxRead {
+ # No limits on reading bytes from the channel below, for
+ # versions of Trf which ask for this information
+ return -1
+ }
+
+ default {
+ # Silently pass all unknown commands.
+ #error "Unknown command \"$command\""
+ }
+ }
+
+ return ""
+}
+
+# ::smtp::talk --
+#
+# Sends an SMTP command to a server
+#
+# Arguments:
+# token SMTP token that has an open connection to the SMTP server.
+# secs Timeout after which command should be aborted.
+# command Command to send to SMTP server.
+#
+# Results:
+# command is sent and response is returned. If anything goes wrong, throw
+# an exception.
+
+proc ::smtp::talk {token secs command} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set options $state(options)
+
+ if {$options(-debug)} {
+ puts stderr "--> $command (wait upto $secs seconds)"
+ flush stderr
+ }
+
+ if {[catch { puts -nonewline $state(sd) "$command\r\n"
+ flush $state(sd) } result]} {
+ return [list code 400 diagnostic $result]
+ }
+
+ if {$secs == 0} {
+ return ""
+ }
+
+ return [hear $token $secs]
+}
+
+# ::smtp::hear --
+#
+# Listens for SMTP server's response to some prior command.
+#
+# Arguments:
+# token SMTP token that has an open connection to the SMTP server.
+# secs Timeout after which we should stop waiting for a response.
+#
+# Results:
+# Response is returned.
+
+proc ::smtp::hear {token secs} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set options $state(options)
+
+ array set response [list args ""]
+
+ set firstP 1
+ while {1} {
+ if {$secs >= 0} {
+ ## SF [ 836442 ] timeout with large data
+ ## correction, aotto 031105 -
+ if {$secs > 600} {set secs 600}
+ set state(afterID) [after [expr {$secs*1000}] \
+ [list ::smtp::timer $token]]
+ }
+
+ if {!$state(readable)} {
+ vwait ${token}(readable)
+ }
+
+ # Wait until socket is readable.
+ if {$state(readable) != -1} {
+ catch { after cancel $state(afterID) }
+ set state(afterID) ""
+ }
+
+ if {$state(readable) < 0} {
+ array set response [list code 400 diagnostic $state(error)]
+ break
+ }
+ set state(readable) 0
+
+ if {$options(-debug)} {
+ puts stderr "<-- $state(line)"
+ flush stderr
+ }
+
+ if {[string length $state(line)] < 3} {
+ array set response \
+ [list code 500 \
+ diagnostic "response too short: $state(line)"]
+ break
+ }
+
+ if {$firstP} {
+ set firstP 0
+
+ if {[scan [string range $state(line) 0 2] %d response(code)] \
+ != 1} {
+ array set response \
+ [list code 500 \
+ diagnostic "unrecognizable code: $state(line)"]
+ break
+ }
+
+ set response(diagnostic) \
+ [string trim [string range $state(line) 4 end]]
+ } else {
+ lappend response(args) \
+ [string trim [string range $state(line) 4 end]]
+ }
+
+ # When status message line ends in -, it means the message is complete.
+
+ if {[string compare [string index $state(line) 3] -]} {
+ break
+ }
+ }
+
+ return [array get response]
+}
+
+# ::smtp::readable --
+#
+# Reads a line of data from SMTP server when the socket is readable. This
+# is the callback of "fileevent readable".
+#
+# Arguments:
+# token SMTP token that has an open connection to the SMTP server.
+#
+# Results:
+# state(line) contains the line of data and state(readable) is reset.
+# state(readable) gets the following values:
+# -3 if there's a premature eof,
+# -2 if reading from socket fails.
+# 1 if reading from socket was successful
+
+proc ::smtp::readable {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ if {[catch { array set options $state(options) }]} {
+ return
+ }
+
+ set state(line) ""
+ if {[catch { gets $state(sd) state(line) } result]} {
+ set state(readable) -2
+ set state(error) $result
+ } elseif {$result == -1} {
+ if {[eof $state(sd)]} {
+ set state(readable) -3
+ set state(error) "premature end-of-file from server"
+ }
+ } else {
+ # If the line ends in \r, remove the \r.
+ if {![string compare [string index $state(line) end] "\r"]} {
+ set state(line) [string range $state(line) 0 end-1]
+ }
+ set state(readable) 1
+ }
+
+ if {$state(readable) < 0} {
+ if {$options(-debug)} {
+ puts stderr " ... $state(error) ..."
+ flush stderr
+ }
+
+ catch { fileevent $state(sd) readable "" }
+ }
+}
+
+# ::smtp::timer --
+#
+# Handles timeout condition on any communication with the SMTP server.
+#
+# Arguments:
+# token SMTP token that has an open connection to the SMTP server.
+#
+# Results:
+# Sets state(readable) to -1 and state(error) to an error message.
+
+proc ::smtp::timer {token} {
+ # FRINK: nocheck
+ variable $token
+ upvar 0 $token state
+
+ array set options $state(options)
+
+ set state(afterID) ""
+ set state(readable) -1
+ set state(error) "read from server timed out"
+
+ if {$options(-debug)} {
+ puts stderr " ... $state(error) ..."
+ flush stderr
+ }
+}
+
+# ::smtp::boolean --
+#
+# Helper function for unifying boolean values to 1 and 0.
+#
+# Arguments:
+# value Some kind of value that represents true or false (i.e. 0, 1,
+# false, true, no, yes, off, on).
+#
+# Results:
+# Return 1 if the value is true, 0 if false. If the input value is not
+# one of the above, throw an exception.
+
+proc ::smtp::boolean {value} {
+ switch -- [string tolower $value] {
+ 0 - false - no - off {
+ return 0
+ }
+
+ 1 - true - yes - on {
+ return 1
+ }
+
+ default {
+ error "unknown boolean value: $value"
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+package provide smtp 1.4.5
+
+# -------------------------------------------------------------------------
+# Local variables:
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/multiplexer/ChangeLog b/tcllib/modules/multiplexer/ChangeLog
new file mode 100644
index 0000000..f83a537
--- /dev/null
+++ b/tcllib/modules/multiplexer/ChangeLog
@@ -0,0 +1,136 @@
+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-11-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * multiplexer.test: Re-merged the split test, and modified to
+ accept both possible results. 8.6 can return an ipv4 address
+ as well, depending on the OS configuration.
+
+2011-11-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * multiplexer.test: Split a test with core version dependent
+ results into two, one per possible result.
+
+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>
+
+ * multiplexer.man: Fixed all warnings due to use of now deprecated
+ commands. Added a section about how to give feedback.
+
+2006-10-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * multiplexer.test: Accept anything matching 127.*.*.* as
+ ip-address for localhost.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * multiplexer.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * multiplexer.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 ========================
+ *
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * multiplexer.man: This package is can be used with Tcl
+ * pkgIndex.tcl: 8.2. Documented as such.
+
+ * multiplexer.test: One test uses the 8.3'ism 'file
+ channels'. Added constraint and skipping it when under Tcl
+ 8.2. Changed initialization code to ensure that the local
+ multiplexer package is loaded, and not an installed one.
+
+2003-05-20 Andreas Kupries <andreask@activestate.com>
+
+ * multiplexer.man: Cleaned up the documentation of the three hooks
+ which can be set per multiplexer instance (access, data, exit).
+
+ * multiplexer.tcl: Made sendtoorigin a true boolean flag, instead
+ of just 0/1.
+
+2003-05-19 David N. Welton <davidw@dedasys.com>
+
+ * multiplexer.tcl (NewClient): Added access denied debug message
+ for accessfilter.
+
+ * multiplexer.man: Minor cleanups.
+
+ * multiplexer.test: Added several tests.
+
+ * multiplexer.tcl: Adding updated multiplexer to tcllib. It is
+ now possible to run multiple multiplexer instances, and it uses
+ the logger package for logging.
+
+ * multiplexer.man: New file, still needs cleaning up. Content
+ taken from old multiplexer.n.
+
+ * multiplexer.test: Added a few initial tests. Working on more.
diff --git a/tcllib/modules/multiplexer/multiplexer.man b/tcllib/modules/multiplexer/multiplexer.man
new file mode 100644
index 0000000..d47e822
--- /dev/null
+++ b/tcllib/modules/multiplexer/multiplexer.man
@@ -0,0 +1,130 @@
+[comment {-*- tcl -*- doctools manpage}]
+[comment { $Id: multiplexer.man,v 1.11 2009/01/29 06:16:20 andreas_kupries Exp $ }]
+[manpage_begin multiplexer n 0.2]
+[keywords chat]
+[keywords multiplexer]
+[moddesc {One-to-many communication with sockets.}]
+[titledesc {One-to-many communication with sockets.}]
+[category {Programming tools}]
+[require Tcl 8.2]
+[require logger]
+[require multiplexer [opt 0.2]]
+[description]
+
+The [package multiplexer] package provides a generic system for one-to-many
+communication utilizing sockets. For example, think of a chat system
+where one user sends a message which is then broadcast to all the
+other connected users.
+
+[para]
+
+It is possible to have different multiplexers running concurrently.
+
+[list_begin definitions]
+
+[call [cmd ::multiplexer::create]]
+
+The [cmd create] command creates a new multiplexer 'instance'. For
+example:
+
+[example {set mp [::multiplexer::create]}]
+
+This instance can then be manipulated like so: [example {${mp}::Init 35100}]
+
+[call [cmd \${multiplexer_instance}::Init] [arg port]]
+
+This starts the multiplexer listening on the specified port.
+
+[call [cmd \${multiplexer_instance}::Config] [arg key] [arg value]]
+
+Use [cmd Config] to configure the multiplexer instance. Configuration
+options currently include:
+
+[list_begin options]
+
+[opt_def sendtoorigin]
+
+A boolean flag. If [const true], the sender will receive a copy of the
+sent message. Defaults to [const false].
+
+[opt_def debuglevel]
+
+Sets the debug level to use for the multiplexer instance, according to
+those specified by the [package logger] package (debug, info, notice,
+warn, error, critical).
+
+[list_end]
+
+[call [cmd \${multiplexer_instance}::AddFilter] [arg cmdprefix]]
+
+Command to add a filter for data that passes through the multiplexer
+instance.
+
+The registered [arg cmdprefix] is called when data arrives at a
+multiplexer instance. If there is more than one filter command
+registered at the instance they will be called in the order of
+registristation, and each filter will get the result of the preceding
+filter as its argument. The first filter gets the incoming data as its
+argument. The result returned by the last filter is the data which
+will be broadcast to all clients of the multiplexer instance.
+
+The command prefix is called as
+
+[list_begin definitions]
+[call [cmd cmdprefix] [arg data] [arg chan] [arg clientaddress] [arg clientport]]
+
+Takes the incoming [arg data], modifies it, and returns that as its
+result. The last three arguments contain information about the client
+which sent the data to filter: The channel connecting us to the
+client, its ip-address, and its ip-port.
+
+[list_end]
+
+[call [cmd \${multiplexer_instance}::AddAccessFilter] [arg cmdprefix]]
+
+Command to add an access filter.
+
+The registered [arg cmdprefix] is called when a new client socket
+tries to connect to the multixer instance. If there is more than one
+access filter command registered at the instance they will be called
+in the order of registristation. If any of the called commands returns
+[const -1] the access to the multiplexer instance is denied and the
+client channel is closed immediately. Any other result grants the
+client access to the multiplexer instance.
+
+The command prefix is called as
+
+[list_begin definitions]
+[call [cmd cmdprefix] [arg chan] [arg clientaddress] [arg clientport]]
+
+The arguments contain information about the client which tries to
+connected to the instance: The channel connecting us to the client,
+its ip-address, and its ip-port.
+
+[list_end]
+
+[call [cmd \${multiplexer_instance}::AddExitFilter] [arg cmdprefix]]
+
+Adds filter to be run when client socket generates an EOF condition.
+
+The registered [arg cmdprefix] is called when a client socket of the
+multixer signals EOF. If there is more than one exit filter command
+registered at the instance they will be called in the order of
+registristation. Errors thrown by an exit filter are ignored, but
+logged. Any result returned by an exit filter is ignored.
+
+The command prefix is called as
+
+[list_begin definitions]
+[call [cmd cmdprefix] [arg chan] [arg clientaddress] [arg clientport]]
+
+The arguments contain information about the client which signaled the
+EOF: The channel connecting us to the client, its ip-address, and its
+ip-port.
+
+[list_end]
+[list_end]
+
+[vset CATEGORY multiplexer]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/multiplexer/multiplexer.tcl b/tcllib/modules/multiplexer/multiplexer.tcl
new file mode 100644
index 0000000..e5dfe4b
--- /dev/null
+++ b/tcllib/modules/multiplexer/multiplexer.tcl
@@ -0,0 +1,291 @@
+# multiplexer.tcl -- one-to-many comunication with sockets
+#
+# Implementation of a one-to-many multiplexer in Tcl utilizing
+# sockets.
+
+# Copyright (c) 2001-2003 by David N. Welton <davidw@dedasys.com>
+
+# This file may be distributed under the same terms as Tcl.
+
+# $Id: multiplexer.tcl,v 1.4 2004/01/15 06:36:13 andreas_kupries Exp $
+
+package provide multiplexer 0.2
+package require logger
+
+namespace eval ::multiplexer {
+ variable Unique 0
+}
+
+proc ::multiplexer::create {} {
+ variable Unique
+ set ns ::multiplexer::mp$Unique
+
+ namespace eval $ns {
+ # Use the namespace as the logger name.
+ set log [logger::init [string trimleft [namespace current] ::]]
+ # list of connected clients
+ array set clients {}
+
+ # filters to run at access (socket accept) time
+ set accessfilters {}
+
+ # filters to run on data
+ set filters {}
+
+ # hook to run at exit time
+ set exitfilters {}
+
+ # config options
+ array set config {}
+ set config(sendtoorigin) 0
+ set config(debuglevel) warn
+ ${log}::disable $config(debuglevel)
+ ${log}::enable $config(debuglevel)
+
+ # AddAccessFilter --
+ #
+ # Command to add an access filter that will be called like so:
+ #
+ # AccessFilter chan clientaddress clientport
+ #
+ # Arguments:
+ #
+ # function: proc to filter access to the multiplexer. Takes chan,
+ # clientaddress and clientport arguments. Returns 0 on success, -1 on
+ # failure.
+
+ proc AddAccessFilter { function } {
+ variable accessfilters
+ lappend accessfilters $function
+ }
+
+ # AddFilter --
+
+ # Command to add a filter for data that passes through the
+ # multiplexer. The filter proc is called like this:
+
+ # Filter data chan clientaddress clientport
+
+ # Arguments:
+
+ # function: proc to filter data that arrives to the
+ # multiplexer.
+ # Takes data, chan, clientaddress, and clientport arguments. Returns
+ # filtered version of data.
+
+ proc AddFilter { function } {
+ variable filters
+ lappend filters $function
+ }
+
+ # AddExitFilter --
+
+ # Adds filter to be run when client socket generates an EOF condition.
+ # ExitFilter functions look like the following:
+
+ # ExitFilter chan clientaddress clientport
+
+ # Arguments:
+
+ # function: hook to be run when clients exit by generating an EOF.
+ # Takes chan, clientaddress and clientport arguments, and returns
+ # nothing.
+
+ proc AddExitFilter { function } {
+ variable exitfilters
+ lappend exitfilters $function
+ }
+
+ # DelClient --
+
+ # Deletes a client from the client list, and runs exit filters.
+
+ # Arguments:
+
+ # chan: channel that is closed.
+
+ # client: address of client
+
+ # clientport: port number of client.
+
+ proc DelClient { chan client clientport } {
+ variable clients
+ variable exitfilters
+ variable config
+ variable log
+ foreach ef $exitfilters {
+ catch {
+ $ef $chan $client $clientport
+ } err
+ ${log}::debug "Error in DelClient: $err"
+ }
+ unset clients($chan)
+ close $chan
+ }
+
+
+ # MultiPlex --
+
+ # Multiplex data
+
+ # Arguments:
+
+ # data - data to multiplex
+
+ proc MultiPlex { data {chan ""} } {
+ variable clients
+ variable config
+ variable log
+
+ foreach c [array names clients] {
+ if { $config(sendtoorigin) } {
+ puts -nonewline $c "$data"
+ } else {
+ if { $chan != $c } {
+ ${log}::debug "Sending '$data' to $c"
+ puts -nonewline $c "$data"
+ }
+ }
+ }
+ }
+
+
+ # GetData --
+
+ # Get data from clients, filter it, redistribute it.
+
+ # Arguments:
+
+ # chan: open channel
+
+ # client: client address
+
+ # clientport: port number of client
+
+ proc GetData { chan client clientport } {
+ variable filters
+ variable clients
+ variable config
+ variable log
+ if { ! [eof $chan] } {
+ set data [read $chan]
+ # gets $chan data
+ ${log}::debug "Tcl chan $chan from host $client and port $clientport sends: $data"
+ # do data filters
+ foreach f $filters {
+ catch {
+ set data [$f $data $chan $client $clientport]
+ } err
+ ${log}::debug "GetData filter: $err"
+ }
+ set chans [array names clients]
+ MultiPlex $data $chan
+ } else {
+ ${log}::debug "Deleting client $chan from host $client and port $clientport."
+ DelClient $chan $client $clientport
+ }
+ }
+
+ # NewClient --
+
+ # Sets up newly created connection after running access filters
+
+ # Arguments:
+
+ # chan: open channel
+
+ # client: client address
+
+ # clientport: port number of client
+
+ proc NewClient { chan client clientport } {
+ variable clients
+ variable config
+ variable accessfilters
+ variable log
+ # run through access filters
+ foreach af $accessfilters {
+ if { [$af $chan $client $clientport] == -1 } {
+ ${log}::debug "Access denied to $chan $client $clientport"
+ close $chan
+ return
+ }
+ }
+ set clients($chan) $client
+
+ # We want to read data and immediately send it out again.
+ fconfigure $chan -blocking 0
+ fconfigure $chan -buffering none
+ fconfigure $chan -translation binary
+ fileevent $chan readable [list [namespace current]::GetData $chan $client $clientport]
+ ${log}::debug "Tcl channel $chan is host $client and port $clientport."
+ }
+
+ # Config --
+ #
+ # Configure global options, which currently include the
+ # following:
+ #
+ # sendtoorigin: if 1, resend the data to all clients, including the
+ # sender. Defaults to 0
+ #
+ # debuglevel: a debug level understood by logger.
+ #
+ # Arguments:
+ #
+ # key: name of option to configure
+ #
+ # value: value for option.
+
+ proc Config { key value } {
+ variable config
+ variable log
+ if { $key == "debuglevel" } {
+ ${log}::disable $config(debuglevel)
+ ${log}::enable $value
+ }
+ set config($key) $value
+ }
+
+ # Init --
+ #
+ # Start the server
+ #
+ # Arguments:
+ #
+ # port: port to listen on.
+
+ proc Init { port } {
+ variable serversock
+ set serversock [socket -server [namespace current]::NewClient $port]
+ }
+
+ # destroy --
+ #
+ # Destroy multiplexer instance. It is important to do
+ # this, to free the resources used.
+ #
+ # Side Effects:
+ # Deletes namespace associated with multiplexer
+ # instance.
+
+
+ proc destroy { } {
+ variable serversock
+ foreach c [array names clients] {
+ catch { close $c }
+ }
+ catch {
+ close $serversock
+ }
+ namespace delete [namespace current]
+ }
+
+ }
+ incr Unique
+ return $ns
+}
+
+namespace eval multiplexer {
+ namespace export create destroy
+}
diff --git a/tcllib/modules/multiplexer/multiplexer.test b/tcllib/modules/multiplexer/multiplexer.test
new file mode 100644
index 0000000..775aa97
--- /dev/null
+++ b/tcllib/modules/multiplexer/multiplexer.test
@@ -0,0 +1,218 @@
+# -*- tcl -*-
+# Tests for the multiplexer facility.
+#
+# Sourcing this file into Tcl runs the tests and generates output for
+# errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com>.
+#
+# $Id: multiplexer.test,v 1.11 2011/11/14 18:49:27 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal multiplexer.tcl multiplexer
+}
+
+# -------------------------------------------------------------------------
+
+test multiplexer-1.0 {create multiplexer} {
+ set mp [multiplexer::create]
+ set ns [namespace children ::multiplexer]
+ ${mp}::destroy
+ set ns
+} {::multiplexer::mp0}
+
+test multiplexer-1.1 {destroy multiplexer} {
+ set mp [multiplexer::create]
+ ${mp}::destroy
+ namespace children multiplexer
+} {}
+
+test multiplexer-2.1 {start multiplexer} {
+ set mp [multiplexer::create]
+ ${mp}::Init 37465
+ set res ""
+ if { [catch {
+ set sk [socket localhost 37465]
+ } err] } { set res $err }
+ ${mp}::destroy
+ set res
+} {}
+
+test multiplexer-2.2 {start & destroy multiplexer} {tcl8.3plus} {
+ set mp [multiplexer::create]
+ set startchans [lsort [file channels]]
+ ${mp}::Init 37465
+
+ set sk [socket localhost 37465]
+ catch { close $sk }
+
+ ${mp}::destroy
+ set chans [lsort [file channels]]
+ string compare $chans $startchans
+} {0}
+
+
+
+proc Get {chan} {
+ gets $chan line
+ if { [info exists ::forever] } {
+ incr ::forever
+ } else {
+ set ::forever 1
+ }
+}
+
+test multiplexer-3.1 {send multiplexer - line buffered} {
+ set ::forever 0
+ set mp [multiplexer::create]
+ ${mp}::Init 37465
+ set sk1 [socket localhost 37465]
+ set sk2 [socket localhost 37465]
+ set sk3 [socket localhost 37465]
+ fileevent $sk2 readable [list Get $sk2]
+ fileevent $sk3 readable [list Get $sk3]
+
+ fconfigure $sk1 -buffering line
+ fconfigure $sk2 -buffering line
+ fconfigure $sk3 -buffering line
+
+ update
+ puts $sk1 "Multiplexer test message 3.1"
+ # Each socket should receive a copy of the above message, so we
+ # have to vwait's.
+ vwait ::forever
+ vwait ::forever
+ ${mp}::destroy
+ set ::forever
+} {2}
+
+proc Get2 {chan} {
+ set line [read -nonewline $chan]
+ if { [info exists ::forever] } {
+ incr ::forever
+ } else {
+ set ::forever 1
+ }
+}
+
+test multiplexer-3.2 {send multiplexer - not buffered} {
+ set ::forever 0
+ set mp [multiplexer::create]
+ ${mp}::Init 37465
+ set sk1 [socket localhost 37465]
+ set sk2 [socket localhost 37465]
+ set sk3 [socket localhost 37465]
+ fileevent $sk2 readable [list Get2 $sk2]
+ fileevent $sk3 readable [list Get2 $sk3]
+
+ fconfigure $sk1 -buffering none
+ fconfigure $sk2 -buffering none -blocking 0
+ fconfigure $sk3 -buffering none -blocking 0
+
+ update
+ puts -nonewline $sk1 "Multiplexer test message 3.2"
+ # Each socket should receive a copy of the above message, so we
+ # have to vwait's.
+ vwait ::forever
+ vwait ::forever
+ ${mp}::destroy
+ set ::forever
+} {2}
+
+
+proc TestFilter {data chan clientaddress clientport} {
+ #puts "$data $chan $clientaddress $clientport"
+ return "Filtered data: $data"
+}
+
+proc Get3 {chan} {
+ gets $chan line
+ set ::forever $line
+}
+
+test multiplexer-4.1 {add filter} {
+ set ::forever 0
+ set mp [multiplexer::create]
+ ${mp}::Init 37465
+ ${mp}::AddFilter TestFilter
+ set sk1 [socket localhost 37465]
+ set sk2 [socket localhost 37465]
+ fileevent $sk2 readable [list Get3 $sk2]
+
+ fconfigure $sk1 -buffering line
+ fconfigure $sk2 -buffering line
+
+ update
+ puts $sk1 "Multiplexer test message 4.1"
+ # Each socket should receive a copy of the above message, so we
+ # have to vwait's.
+ vwait ::forever
+ ${mp}::destroy
+ set ::forever
+} {Filtered data: Multiplexer test message 4.1}
+
+proc TestAccessFilter {chan clientaddress clientport} {
+ lappend ::forever $clientaddress
+ return 0
+}
+
+test multiplexer-5.1 {add access filter} {
+ set ::forever {}
+ set mp [multiplexer::create]
+ ${mp}::Init 37465
+ ${mp}::AddAccessFilter TestAccessFilter
+ update
+ set sk1 [socket localhost 37465]
+ set sk2 [socket localhost 37465]
+
+ vwait ::forever
+ vwait ::forever
+ ${mp}::destroy
+
+ expr {
+ [string match {127.*.*.* 127.*.*.*} $::forever] ||
+ [string equal {::1 ::1} $::forever]
+ }
+} 1
+
+proc DenyAccessFilter {chan clientaddress clientport} {
+ return -1
+}
+
+test multiplexer-5.2 {add access filter which denies access} {
+ set ::forever {}
+ set mp [multiplexer::create]
+ ${mp}::Init 37465
+ ${mp}::AddAccessFilter DenyAccessFilter
+ set sk1 [socket localhost 37465]
+ after idle {
+ update
+ fconfigure $sk1 -buffering none
+ if { [catch {
+ puts $sk1 "boom"
+ after 200 ;# delay to overcome nagle - see ticket [ced089d5fe]
+ puts $sk1 "tish"
+ } err] } {
+ set ::forever "socket blocked"
+ } else {
+ set ::forever "socket not blocked"
+ }
+ }
+ vwait ::forever
+ ${mp}::destroy
+ set forever
+} {socket blocked}
+
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/multiplexer/pkgIndex.tcl b/tcllib/modules/multiplexer/pkgIndex.tcl
new file mode 100644
index 0000000..51f2ad4
--- /dev/null
+++ b/tcllib/modules/multiplexer/pkgIndex.tcl
@@ -0,0 +1,12 @@
+# 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.2] } { return }
+package ifneeded multiplexer 0.2 [list source [file join $dir multiplexer.tcl]]
diff --git a/tcllib/modules/namespacex/ChangeLog b/tcllib/modules/namespacex/ChangeLog
new file mode 100644
index 0000000..2b30586
--- /dev/null
+++ b/tcllib/modules/namespacex/ChangeLog
@@ -0,0 +1,34 @@
+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-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2011-01-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * namespacex.test: Fixed test setup, 8.5 required, not 8.2.
+
+2010-05-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * namespacex.tcl: Fixed typos in docs, and left-over bug.
+ * namespacex.man: Bumped version to 0.1.
+ * pkgIndex.tcl:
+
+2010-05-28 Andreas Kupries <andreask@activestate.com>
+
+ * namespacex.test: New module and package holding a number of
+ * namespacex.tcl: utility commands for working with namespaces.
+ * namespacex.man:
+ * pkgIndex.tcl:
diff --git a/tcllib/modules/namespacex/namespacex.man b/tcllib/modules/namespacex/namespacex.man
new file mode 100644
index 0000000..6c930a7
--- /dev/null
+++ b/tcllib/modules/namespacex/namespacex.man
@@ -0,0 +1,73 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin namespacex n 0.1]
+[keywords {extended namespace}]
+[keywords info]
+[keywords {namespace unknown}]
+[keywords {namespace utilities}]
+[keywords {state (de)serialization}]
+[keywords {unknown hooking}]
+[keywords utilities]
+[copyright {200? Neil Madden (http://wiki.tcl.tk/12790)}]
+[copyright {200? Various (http://wiki.tcl.tk/1489)}]
+[copyright {2010 Documentation, Andreas Kupries}]
+[moddesc {Namespace utility commands}]
+[titledesc {Namespace utility commands}]
+[require Tcl 8.5]
+[require namespacex [opt 0.1]]
+[description]
+
+This package provides a number of utility commands for working with
+namespaces.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd {::namespacex hook add}] [opt [arg namespace]] [arg cmdprefix]]
+[call [cmd {::namespacex hook proc}] [opt [arg namespace]] [arg arguments] [arg body]]
+[call [cmd {::namespacex hook on}] [opt [arg namespace]] [arg guardcmdprefix] [arg actioncmdprefix]]
+[call [cmd {::namespacex hook next}] [arg arg]...]
+
+[call [cmd {::namespacex info allchildren}] [arg namespace]]
+
+This command returns a list containing the names of all child
+namespaces in the specified [arg namespace] and its children. The
+names are all fully qualified.
+
+[call [cmd {::namespacex info allvars}] [arg namespace]]
+
+This command returns a list containing the names of all variables in
+the specified [arg namespace] and its children. The names are all
+relative to [arg namespace], and [emph not] fully qualified.
+
+[call [cmd {::namespacex info vars}] [arg namespace] [opt [arg pattern]]]
+
+This command returns a list containing the names of all variables in
+the specified [arg namespace].
+
+[call [cmd {::namespacex state get}] [arg namespace]]
+
+This command returns a dictionary holding the names and values of all
+variables in the specified [arg namespace] and its child namespaces.
+
+[para]
+Note that the names are all relative to [arg namespace],
+and [emph not] fully qualified.
+
+[call [cmd {::namespacex state set}] [arg namespace] [arg dict]]
+
+This command takes a dictionary holding the names and values for a set
+of variables and replaces the current state of the specified
+[arg namespace] and its child namespaces with this state.
+
+The result of the command is the empty string.
+
+[call [cmd {::namespacex state drop}] [arg namespace]]
+
+This command unsets all variables in the specified [arg namespace] and
+its child namespaces.
+
+The result of the command is the empty string.
+
+[list_end]
+[manpage_end]
diff --git a/tcllib/modules/namespacex/namespacex.tcl b/tcllib/modules/namespacex/namespacex.tcl
new file mode 100644
index 0000000..b072119
--- /dev/null
+++ b/tcllib/modules/namespacex/namespacex.tcl
@@ -0,0 +1,254 @@
+## -*- tcl -*-
+## (C) 2010 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+## 'unknown hook' code -- Derived from http://wiki.tcl.tk/12790 (Neil Madden).
+## 'var/state' code -- Derived from http://wiki.tcl.tk/1489 (various).
+## BSD Licensed
+# # ## ### ##### ######## ############# ######################
+
+# namespacex hook - Easy extensibility of 'namespace unknown'.
+# namespacex info - Get all variables/children, direct and indirect
+# namespacex state - Save/restore the variable-based state of namespaces.
+
+# # ## ### ##### ######## ############# ######################
+## Requisites
+
+package require Tcl 8.5 ; # namespace ensembles, {*}
+
+namespace eval ::namespacex {
+ namespace export add hook info state
+ namespace ensemble create
+
+ namespace eval hook {
+ namespace export add proc on next
+ namespace ensemble create
+
+ # add - hook a command prefix into the chain of unknown handlers for a
+ # namespace. The prefix will be run with whatever args there are, so
+ # it should use 'args' to accomodate? to everything.
+
+ # on - ditto for separate guard and action command prefixes.
+ # If the guard fails it chains via next, otherwise the
+ # action runs. The action can asume that the guard checked for proper
+ # number of arguments, maybe even types. Whatever fits.
+
+ # proc - like add, but an unamed procedure, with arguments and
+ # body. Not much use, except maybe to handle the exact way
+ # of chaining on your own (next can take a rewritten
+ # command, the 'on' compositor makes no use of that.
+
+ # Both 'proc' and 'on' are based on 'add'.
+ }
+
+ namespace eval info {
+ namespace export allvars allchildren vars
+ namespace ensemble create
+ }
+
+ namespace eval state {
+ namespace export drop set get
+ namespace ensemble create
+ }
+}
+
+# # ## ### ##### ######## ############# ######################
+## Implementation :: Hooks - Visible API
+
+# # ## ### ##### ######## ############# ######################
+## (1) Core: Register a command prefix to be run by
+## namespace unknown of a namespace FOO.
+## FOO defaults to the current namespace.
+##
+## The prefixes are executed in reverse order of registrations,
+## i.e. the prefix registered last is executed first. The next
+## is run if and only if the current prefix forced this via
+## '::namespacex::hook::next'. IOW the chain is managed cooperatively.
+
+proc ::namespacex::hook::add {args} {
+ # syntax: ?namespace? cmdprefix
+
+ if {[llength $args] > 2} {
+ return -code error "wrong\#args, should be \"?namespace? cmdprefix\""
+ } elseif {[llength $args] == 2} {
+ lassign $args namespace cmdprefix
+ } else { # [llength $args] == 1
+ lassign $args cmdprefix
+ set namespace [uplevel 1 { namespace current }]
+ }
+
+ #puts UH|ADD|for|$namespace|
+ #puts UH|ADD|old|<<[Get $namespace]>>
+ #puts UH|ADD|cmd|<<$cmdprefix>>
+
+ Set $namespace [namespace code [list Handle $cmdprefix [Get $namespace]]]
+ return
+}
+
+proc ::namespacex::hook::proc {args} {
+ # syntax: ?namespace? arguments body
+
+ set procNamespace [uplevel 1 { namespace current }]
+
+ if {([llength $args] < 2) ||
+ ([llength $args] > 3)} {
+ return -code error "wrong\#args, should be \"?namespace? arguments body\""
+ } elseif {[llength $args] == 3} {
+ lassign $args namespace arguments body
+ } else { # [llength $args] == 2
+ lassign $args arguments body
+ set namespace $procNamespace
+ }
+
+ add $namespace [list ::apply [list $arguments $body $procNamespace]]
+ return
+}
+
+proc ::namespacex::hook::on {args} {
+ # syntax: ?namespace? guardcmd actioncmd
+
+ if {([llength $args] < 2) ||
+ ([llength $args] > 3)} {
+ return -code error "wrong\#args, should be \"?namespace? guard action\""
+ } elseif {[llength $args] == 3} {
+ lassign $args namespace guard action
+ } else { # [llength $args] == 2
+ lassign $args guard action
+ set namespace [uplevel 1 { namespace current }]
+ }
+
+ add $namespace [list ::apply [list {guard action args} {
+ if {![{*}$guard {*}$args]} {
+ # This is what requires '[ns current]' as context.
+ next
+ }
+ return [{*}$action {*}$args]
+ } [namespace current]] $guard $action]
+ return
+}
+
+proc ::namespacex::hook::next {args} {
+ #puts UH|NEXT|$args|
+ return -code continue -level 2 $args
+}
+
+# # ## ### ##### ######## ############# ######################
+## Implementation :: Hooks - Internal Helpers.
+## Get and set the unknown handler for a specified namespace.
+
+# Generic handler with the user's handler and previous handler as
+# arguments. The latter is an invokation of the internal handler
+# again, with its own arguments. In this way 'Handle' forms the spine
+# of the chain of handlers, running them and handling 'next' to
+# traverse the chain. From a data structure perspective we have deeply
+# nested list here, which is recursed into as the chain is traversed.
+
+proc ::namespacex::hook::Get {ns} {
+ return [namespace eval $ns { namespace unknown }]
+}
+
+proc ::namespacex::hook::Set {ns handler} {
+ #puts UH|SET|$ns|<<$handler>>
+
+ namespace eval $ns [list namespace unknown $handler]
+ return
+}
+
+proc ::namespacex::hook::Handle {handler old args} {
+ #puts UH|HDL|$handler|||old|$old||args||$args|
+
+ set rc [catch {
+ uplevel 1 $handler $args
+ } result]
+
+ #puts UH|HDL|rc=$rc|result=$result|
+
+ if {$rc == 4} {
+ # continue - invoke next handler
+
+ if {$old eq {}} {
+ # no next handler available - stop
+ #puts UH|HDL|STOP
+ return -code error "invalid command name \"[lindex $args 0]\""
+ }
+
+ if {![llength $result]} {
+ uplevel 1 $old $args
+ } else {
+ uplevel 1 $old $result
+ }
+ } else {
+ return -code $rc $result
+ }
+}
+
+# # ## ### ##### ######## ############# ######################
+## Implementation :: Info - Visible API
+
+proc ::namespacex::info::allvars {ns} {
+ if {![string match {::*} $ns]} { set ns ::$ns }
+ ::set result [::info vars ${ns}::*]
+ foreach cns [allchildren $ns] {
+ lappend result {*}[::info vars ${cns}::*]
+ }
+ return [Strip $ns $result]
+}
+
+proc ::namespacex::info::allchildren {ns} {
+ if {![string match {::*} $ns]} { set ns ::$ns }
+ ::set result [list]
+ foreach cns [::namespace children $ns] {
+ lappend result {*}[allchildren $cns]
+ lappend result $cns
+ }
+ return $result
+}
+
+proc ::namespacex::info::vars {ns {pattern *}} {
+ return [Strip $ns [::info vars ${ns}::$pattern]]
+}
+
+proc ::namespacex::info::Strip {ns itemlist} {
+ set n [string length $ns]
+ if {![string match {::*} $ns]} {
+ incr n 4
+ } else {
+ incr n 2
+ }
+
+ set result {}
+ foreach i $itemlist {
+ lappend result [string range $i $n end]
+ }
+ return $result
+}
+
+# # ## ### ##### ######## ############# ######################
+## Implementation :: State - Visible API
+
+proc ::namespacex::state::drop {ns} {
+ if {![string match {::*} $ns]} { ::set ns ::$ns }
+ namespace eval $ns [list ::unset {*}[::namespacex info allvars $ns]]
+ return
+}
+
+proc ::namespacex::state::get {ns} {
+ if {![string match {::*} $ns]} { ::set ns ::$ns }
+ ::set result {}
+ foreach v [::namespacex info allvars $ns] {
+ namespace upvar $ns $v value
+ lappend result $v $value
+ }
+ return $result
+}
+
+proc ::namespacex::state::set {ns state} {
+ if {![string match {::*} $ns]} { ::set ns ::$ns }
+ # Inlined 'state drop'.
+ namespace eval $ns [list ::unset {*}[::namespacex info allvars $ns]]
+ namespace eval $ns [list variable {*}$state]
+ return
+}
+
+# # ## ### ##### ######## ############# ######################
+## Ready
+
+package provide namespacex 0.1
diff --git a/tcllib/modules/namespacex/namespacex.test b/tcllib/modules/namespacex/namespacex.test
new file mode 100644
index 0000000..f541118
--- /dev/null
+++ b/tcllib/modules/namespacex/namespacex.test
@@ -0,0 +1,351 @@
+# namespacex.test - Copyright (c) 2010 Andreas Kupries
+# $Id: namespacex.test,v 1.2 2011/01/13 02:39:26 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+testing {
+ useLocal namespacex.tcl namespacex
+}
+
+# -------------------------------------------------------------------------
+
+proc ns_setup {} {
+ namespace eval ::X {
+ namespace eval A {}
+ namespace eval B {
+ namespace eval D {}
+ }
+ namespace eval C {}
+ }
+}
+
+proc ns2_setup {} {
+ namespace eval ::X {
+ variable vXa 1
+ variable vXb aleph
+ namespace eval B {
+ variable vB 3
+ }
+ }
+}
+
+proc ns3_setup {} {
+ namespace eval ::X {
+ namespace eval B {
+ variable vB mjolnir
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+
+test namespacex-info-allchildren-1.0 {namespacex info allchildren, wrong\#args} -body {
+ namespacex info allchildren
+} -returnCodes error -result {wrong # args: should be "namespacex info allchildren ns"}
+
+test namespacex-info-allchildren-1.1 {namespacex info allchildren, wrong\#args} -body {
+ namespacex info allchildren N X
+} -returnCodes error -result {wrong # args: should be "namespacex info allchildren ns"}
+
+test namespacex-info-allchildren-2.0.0 {namespacex info allchildren} -setup {
+ ns_setup
+} -body {
+ lsort -dict [namespacex info allchildren ::X]
+} -cleanup {
+ namespace delete ::X
+} -result {::X::A ::X::B ::X::B::D ::X::C}
+
+test namespacex-info-allchildren-2.0.1 {namespacex info allchildren} -setup {
+ ns_setup
+} -body {
+ lsort -dict [namespacex info allchildren X]
+} -cleanup {
+ namespace delete ::X
+} -result {::X::A ::X::B ::X::B::D ::X::C}
+
+# -------------------------------------------------------------------------
+
+test namespacex-info-vars-1.0 {namespacex info vars, wrong\#args} -body {
+ namespacex info vars
+} -returnCodes error -result {wrong # args: should be "namespacex info vars ns ?pattern?"}
+
+test namespacex-info-vars-1.1 {namespacex info vars, wrong\#args} -body {
+ namespacex info vars N P X
+} -returnCodes error -result {wrong # args: should be "namespacex info vars ns ?pattern?"}
+
+test namespacex-info-vars-2.0 {namespacex info vars} -setup {
+ ns2_setup
+} -body {
+ lsort -dict [namespacex info vars ::X]
+} -cleanup {
+ namespace delete ::X
+} -result {vXa vXb}
+
+test namespacex-info-vars-2.1 {namespacex info vars} -setup {
+ namespace eval ::X {}
+} -body {
+ lsort -dict [namespacex info vars ::X]
+} -cleanup {
+ namespace delete ::X
+} -result {}
+
+test namespacex-info-vars-2.2 {namespacex info vars} -setup {
+ ns3_setup
+} -body {
+ lsort -dict [namespacex info vars ::X]
+} -cleanup {
+ namespace delete ::X
+} -result {}
+
+# -------------------------------------------------------------------------
+
+test namespacex-info-allvars-1.0 {namespacex info allvars, wrong\#args} -body {
+ namespacex info allvars
+} -returnCodes error -result {wrong # args: should be "namespacex info allvars ns"}
+
+test namespacex-info-allvars-1.1 {namespacex info allvars, wrong\#args} -body {
+ namespacex info allvars N X
+} -returnCodes error -result {wrong # args: should be "namespacex info allvars ns"}
+
+test namespacex-info-allvars-2.0.0 {namespacex info allvars} -setup {
+ ns2_setup
+} -body {
+ lsort -dict [namespacex info allvars ::X]
+} -cleanup {
+ namespace delete ::X
+} -result {B::vB vXa vXb}
+
+test namespacex-info-allvars-2.0.1 {namespacex info allvars} -setup {
+ ns2_setup
+} -body {
+ lsort -dict [namespacex info allvars X]
+} -cleanup {
+ namespace delete ::X
+} -result {B::vB vXa vXb}
+
+test namespacex-info-allvars-2.1.0 {namespacex info allvars} -setup {
+ namespace eval ::X {}
+} -body {
+ lsort -dict [namespacex info allvars ::X]
+} -cleanup {
+ namespace delete ::X
+} -result {}
+
+test namespacex-info-allvars-2.1.1 {namespacex info allvars} -setup {
+ namespace eval ::X {}
+} -body {
+ lsort -dict [namespacex info allvars X]
+} -cleanup {
+ namespace delete ::X
+} -result {}
+
+test namespacex-info-allvars-2.2.0 {namespacex info allvars} -setup {
+ ns3_setup
+} -body {
+ lsort -dict [namespacex info allvars ::X]
+} -cleanup {
+ namespace delete ::X
+} -result {B::vB}
+
+test namespacex-info-allvars-2.2.1 {namespacex info allvars} -setup {
+ ns3_setup
+} -body {
+ lsort -dict [namespacex info allvars X]
+} -cleanup {
+ namespace delete ::X
+} -result {B::vB}
+
+# -------------------------------------------------------------------------
+
+test namespacex-state-get-1.0 {namespacex state get, wrong\#args} -body {
+ namespacex state get
+} -returnCodes error -result {wrong # args: should be "namespacex state get ns"}
+
+test namespacex-state-get-1.1 {namespacex state get, wrong\#args} -body {
+ namespacex state get N X
+} -returnCodes error -result {wrong # args: should be "namespacex state get ns"}
+
+test namespacex-state-get-2.0.0 {namespacex state get} -setup {
+ ns2_setup
+} -body {
+ dictsort [namespacex state get ::X]
+} -cleanup {
+ namespace delete ::X
+} -result {B::vB 3 vXa 1 vXb aleph}
+
+test namespacex-state-get-2.0.1 {namespacex state get} -setup {
+ ns2_setup
+} -body {
+ dictsort [namespacex state get X]
+} -cleanup {
+ namespace delete ::X
+} -result {B::vB 3 vXa 1 vXb aleph}
+
+test namespacex-state-get-2.1.0 {namespacex state get} -setup {
+ namespace eval ::X {}
+} -body {
+ dictsort [namespacex state get ::X]
+} -cleanup {
+ namespace delete ::X
+} -result {}
+
+test namespacex-state-get-2.1.1 {namespacex state get} -setup {
+ namespace eval ::X {}
+} -body {
+ dictsort [namespacex state get X]
+} -cleanup {
+ namespace delete ::X
+} -result {}
+
+test namespacex-state-get-2.2.0 {namespacex state get} -setup {
+ ns3_setup
+} -body {
+ dictsort [namespacex state get ::X]
+} -cleanup {
+ namespace delete ::X
+} -result {B::vB mjolnir}
+
+test namespacex-state-get-2.2.1 {namespacex state get} -setup {
+ ns3_setup
+} -body {
+ dictsort [namespacex state get X]
+} -cleanup {
+ namespace delete ::X
+} -result {B::vB mjolnir}
+
+# -------------------------------------------------------------------------
+
+test namespacex-state-drop-1.0 {namespacex state drop, wrong\#args} -body {
+ namespacex state drop
+} -returnCodes error -result {wrong # args: should be "namespacex state drop ns"}
+
+test namespacex-state-drop-1.1 {namespacex state drop, wrong\#args} -body {
+ namespacex state drop N X
+} -returnCodes error -result {wrong # args: should be "namespacex state drop ns"}
+
+test namespacex-state-drop-2.0.0 {namespacex state drop} -setup {
+ ns2_setup
+} -body {
+ namespacex state drop ::X
+ dictsort [namespacex state get ::X]
+} -cleanup {
+ namespace delete ::X
+} -result {}
+
+test namespacex-state-drop-2.0.1 {namespacex state drop} -setup {
+ ns2_setup
+} -body {
+ namespacex state drop X
+ dictsort [namespacex state get X]
+} -cleanup {
+ namespace delete ::X
+} -result {}
+
+test namespacex-state-drop-2.1.0 {namespacex state drop} -setup {
+ namespace eval ::X {}
+} -body {
+ namespacex state drop X
+ dictsort [namespacex state get ::X]
+} -cleanup {
+ namespace delete ::X
+} -result {}
+
+test namespacex-state-drop-2.1.1 {namespacex state drop} -setup {
+ namespace eval ::X {}
+} -body {
+ namespacex state drop X
+ dictsort [namespacex state get X]
+} -cleanup {
+ namespace delete ::X
+} -result {}
+
+test namespacex-state-drop-2.2.0 {namespacex state drop} -setup {
+ ns3_setup
+} -body {
+ namespacex state drop X
+ dictsort [namespacex state get ::X]
+} -cleanup {
+ namespace delete ::X
+} -result {}
+
+test namespacex-state-drop-2.2.1 {namespacex state drop} -setup {
+ ns3_setup
+} -body {
+ namespacex state drop X
+ dictsort [namespacex state get X]
+} -cleanup {
+ namespace delete ::X
+} -result {}
+
+# -------------------------------------------------------------------------
+
+test namespacex-state-set-1.0 {namespacex state set, wrong\#args} -body {
+ namespacex state set
+} -returnCodes error -result {wrong # args: should be "namespacex state set ns state"}
+
+test namespacex-state-set-1.1 {namespacex state set, wrong\#args} -body {
+ namespacex state set N
+} -returnCodes error -result {wrong # args: should be "namespacex state set ns state"}
+
+test namespacex-state-set-1.2 {namespacex state set, wrong\#args} -body {
+ namespacex state set N S X
+} -returnCodes error -result {wrong # args: should be "namespacex state set ns state"}
+
+test namespacex-state-set-2.0.0 {namespacex state set} -setup {
+ ns2_setup
+ set ST [namespacex state get ::X]
+ ns3_setup
+} -body {
+ namespacex state set ::X $ST
+ dictsort [namespacex state get ::X]
+} -cleanup {
+ namespace delete ::X
+} -result {B::vB 3 vXa 1 vXb aleph}
+
+test namespacex-state-set-2.0.1 {namespacex state set} -setup {
+ ns2_setup
+ set ST [namespacex state get ::X]
+ ns3_setup
+} -body {
+ namespacex state set X $ST
+ dictsort [namespacex state get X]
+} -cleanup {
+ namespace delete ::X
+} -result {B::vB 3 vXa 1 vXb aleph}
+
+test namespacex-state-set-2.1.0 {namespacex state set} -setup {
+ ns3_setup
+ set ST [namespacex state get ::X]
+ ns2_setup
+} -body {
+ namespacex state set ::X $ST
+ dictsort [namespacex state get ::X]
+} -cleanup {
+ namespace delete ::X
+} -result {B::vB mjolnir}
+
+test namespacex-state-set-2.1.1 {namespacex state set} -setup {
+ ns3_setup
+ set ST [namespacex state get ::X]
+ ns2_setup
+} -body {
+ namespacex state set X $ST
+ dictsort [namespacex state get X]
+} -cleanup {
+ namespace delete ::X
+} -result {B::vB mjolnir}
+
+# -------------------------------------------------------------------------
+testsuiteCleanup
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/namespacex/pkgIndex.tcl b/tcllib/modules/namespacex/pkgIndex.tcl
new file mode 100644
index 0000000..2680d85
--- /dev/null
+++ b/tcllib/modules/namespacex/pkgIndex.tcl
@@ -0,0 +1,5 @@
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ # PRAGMA: returnok
+ return
+}
+package ifneeded namespacex 0.1 [list source [file join $dir namespacex.tcl]]
diff --git a/tcllib/modules/ncgi/ChangeLog b/tcllib/modules/ncgi/ChangeLog
new file mode 100644
index 0000000..ea5c63a
--- /dev/null
+++ b/tcllib/modules/ncgi/ChangeLog
@@ -0,0 +1,373 @@
+2013-02-08 Andreas Kupries <andreask@activestate.com>
+
+ * ncgi.tcl (::ncgi::DecodeHex): [Bug 3603593]: Fixed bad scoping
+ * ncgi.man: of DecodeHex, now in the ncgi namespace instead of
+ * pkgIndex.tcl: polluting the global. Bumped version to 1.4.2.
+
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2013-01-30 Andreas Kupries <andreask@activestate.com>
+
+ * ncgi.man: [Bug 3601995]: Accepted [decode] changes by
+ * ncgi.tcl: <quantifier@users.sourceforge.net>. Fixed both missing
+ * ncgi.test: acceptance of various ut-8 sequences, and missing
+ * pkgIndex.tcl: rejection of bad sequences. Test cases
+ added. Bumped to version 1.4.1.
+
+2012-05-03 Andreas Kupries <andreask@activestate.com>
+
+ * ncgi.tcl: Applied Richard Hipp's patch to extend handling of
+ * pkgIndex.tcl: utf characters in [decode]. Extended testsuite.
+ * ncgi.man: Used the opportunity to bump the minimum required
+ * ncgi.test: Tcl runtime up to 8.4. Bumped package version up
+ to 1.4 to reflect this latter change.
+
+2012-03-30 Andreas Kupries <andreask@activestate.com>
+
+ * ncgi.tcl: [Bug 3513149]: Removed superfluous closing
+ * pkgIndex.tcl: bracket. Bumped version to 1.3.3.
+ * ncgi.man:
+
+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 ========================
+ *
+
+2008-04-23 Andreas Kupries <andreask@activestate.com>
+
+ * ncgi.tcl (::ncgi::exists): Fixed documentation in code
+ * ncgi.man: and outside, the result was specified wrongly.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-22 Andreas Kupries <andreask@activestate.com>
+
+ * ncgi.man: Tweaked the formatting of the newly committed example
+ a bit.
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.man: Fixed all warnings due to use of now deprecated
+ commands. Added a section about how to give feedback.
+
+2006-10-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.test: Rewritten to use new features for handling the
+ environment.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.test: Fixed ncgi dependencies in the scripts executed by
+ sub-shells.
+
+2006-09-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.test: Added 'exit' to the scripts executed in sub-shells,
+ to make them usable with 'wish'-type shells as well. Fixed
+ 8.4ism in testsuite of 8.2+ package.
+
+2006-07-02 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ncgi.tcl: Applied patch from [SF Tcllib Bug 532774] to
+ speed up parsing of large values using string functions
+ instead of regexp.
+
+2006-07-02 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * ncgi.tcl: Fixed [SF Tcllib Bug 547274]. We could further
+ enhance the value parsing in case a parameter is specified.
+
+2006-01-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.test: Fixed use and cleanup of temp. files. Also fixed
+ warning about changes to the env array.
+
+2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.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-09-30 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Applied fix for [SF Tcllib Bug 756939], and
+ * ncgi.tcl: accepted [SF Tcllib RFE 842066]. Added new
+ * ncgi.man: commands 'ncgi::names' and 'ncgi::exists'.
+ * ncgi.test: Extended the documentation and testsuite. Bumped
+ version to 1.3
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-04 Brent Welch <welch@panasas.com>
+
+ * ngci.tcl: Added text/xml to the list of types allowed by
+ ncgi::nvlist. This is to support URL fetches in tclhttpd from
+ active X objects that specify their inputs in "xml".
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.tcl: The variable '_tmpfiles' was used in conjunction with
+ * ncgi.test: some 8.4'isms. The package is certified for Tcl 8.2.
+ Replaced the offending constructs with equivalents
+ acceptable to the lesser cores. Spelling fixes in the
+ * formdata.txt: tests, and supporting data file.
+
+2003-07-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.man: Trival spelling fix.
+
+2003-06-16 Andreas Kupries <andreask@activestate.com>
+
+ * ncgi.test:
+ * ncgi.tcl (importFile): Got a rewritten version from Steve
+ Cassidy which fixes some bugs. We now also have tests for
+ 'importFile'. See tcllib patch 611595 for the original code.
+
+2003-05-09 Andreas Kupries <andreask@activestate.com>
+
+ * ncgi.tcl (import_file): Brace [expr].
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-05-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.test: Fixed all the tests which use a sub-process. The
+ auto_path was not propagated, causing the sub-process to require
+ an installed tcllib for correct operation (i.e. to find the
+ other packages ncgi depends on, like fileutil). also changed the
+ test prolog to match the other testsuites.
+
+2003-04-25 Andreas Kupries <andreask@activestate.com>
+
+ * ncgi.tcl (::ncgi::query): Added code to handle binary data in
+ query/upload correctly.
+
+2003-04-23 Andreas Kupries <andreask@activestate.com>
+
+ * ncgi.man:
+ * ncgi.tcl: Added command [importFile] from tcllib patch
+ 611595. The command [tempfile] was relocated into fileutil
+ instead.
+
+2003-04-10 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl:
+ * ncgi.man:
+ * ncgi.tcl: Fixed bug #614591. Set version of the package to to
+ 1.2.2. Also fixed equivalnet of bug #648679.
+
+2003-02-05 David N. Welton <davidw@dedasys.com>
+
+ * ncgi.tcl: Use string match instead of regexp.
+
+2002-08-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.tcl: Updated 'info exist' to 'info exists'.
+
+2002-08-15 David N. Welton <davidw@dedasys.com>
+
+ * ncgi.tcl (ncgi::setValueList): Fix [ 593254 ] ncgi::SetValue bug
+ - SetValue now works correctly with multipart values with spaces
+ in them.
+
+2002-08-09 David N. Welton <davidw@dedasys.com>
+
+ * ncgi.test: Added two new tests for setValue.
+
+ * ncgi.tcl (ncgi::multipart): Fix [ 564279 ] ncgi::multipart bug -
+ commented out offending 'puts' statements.
+
+2002-04-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.man: Added doctools manpage.
+
+2002-01-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bumped version to 1.2.1
+
+2001-10-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.tcl (ncgi::redirect): Fixed bug #464560 reported by Ed
+ Rolfe <erolfe@users.sourceforge.net>. The proposed fix is not
+ used as it does not pass the testsuite. We check for the
+ existence of "env(REQUEST_URI)" instead, again, and use the
+ appropriate alternate information if it does not exist.
+
+2001-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.n:
+ * ncgi.test:
+ * ncgi.tcl:
+ * pkgIndex.tcl: Version up to 1.2
+
+2001-09-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.tcl: Restricted export list to public API.
+ [456255]. Patch by Hemang Lavana
+ <hemanglavana@users.sourceforge.net>
+
+2001-09-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.tcl: Added missing [global env]. Bug [458023].
+
+2001-08-01 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * ncgi.tcl: made require Tcl 8.1+, sped up encode and decode.
+
+2001-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.tcl: Frink 2.2 run, fixed dubious code.
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ncgi.tcl: Fixed dubious code reported by frink.
+
+2001-06-15 Melissa Chawla <melissachawla@yahoo.com>
+
+ * ncgi.tcl: Applied George Wu's patch (gwu@acm.org) to the
+ multipart function. It failed to process binary data correctly
+ because it replaced all "\r\n" sequences with "\n".
+
+2000-07-31 Brent Welch <welch@scriptics.com>
+
+ * ncgi.tcl: Added ncgi::setValue, ncgi::setValueList,
+ ncgi::setDefaultValue, ncgi::setDefaultValueList to push values
+ back into the CGI environment.
+
+2000-05-26 Melissa Chawla <hershey@scriptics.com>
+
+ * ncgi.tcl: fixed bug 5727 where Netscape prepends an extra \n to
+ post data sent via HTTPS. Urlencoded post does not include
+ preceding or trailing whitespace, so to be safe, we trim
+ whitespace off the post data before parsing the attributes.
+
+2000-05-15 Brent Welch <welch@scriptics.com>
+
+ * ncgi.tcl: Changed ncgi::redirect so it grabs the server name
+ from REQUEST_URI before using the SERVER_NAME value. This is so
+ the server name matches the previous page better. Otherwise a
+ transition from "www" to "www.scriptics.com" can trigger
+ Basic Authentication challenges.
+
+2000-05-02 Brent Welch <welch@scriptics.com>
+
+ * ncgi/ncgi.tcl:
+ Moved the '+' decoding from nvlist down into ncgi::decode.
+ Changed ncgi::value to strip out the structure associated with
+ multipart/form-data values. Use ncgi::valueList to get the
+ structured value.
+
+2000-05-02 Sandeep Tamhankar <sandeep@scriptics.com>
+
+ * ncgi.tcl: Changed ncgi::parseMimeValue such that a key-value
+ pair like name="" would turn into the list {name {}} instead of
+ {name {""}}.
+
+2000-04-26 Brent Welch <welch@scriptics.com>
+
+ * ncgi.tcl, ncgi.test: changed names to get capitalization
+ right: setCookie, valueList, importAll, urlStub
+
+2000-04-17 Brent Welch <welch@scriptics.com>
+
+ * ncgi.tcl: Fixed ncgi::reset with no query data. Fixed
+ ncgi::multipart because it usually gets \r\n data.
+
+2000-04-14 Brent Welch <welch@scriptics.com>
+
+ * ncgi.tcl: Changed ncgi::list to ncgi::nvlist (for "name value
+ list") becauase of the inevitable conflict with the global list
+ command. Added ncgi::importall to import a set of cgi variables.
+ Added multipart/form-data parsing. Added ncgi::cookie and
+ ncgi::setcookie.
+
+2000-03-20 Eric Melski <ericm@scriptics.com>
+
+ * ncgi.test: Fixed tests that created files with "source ncgi.tcl"
+ in them to use full path for sourcing, so that tests could be run
+ from any directory. [Bug: 4393]
+
+2000-03-15 Brent Welch <welch@scriptics.com>
+
+ * ncgi.tcl: added ncgi::reset so the ncgi package can be used inside
+ TclHttpd
+
+ * ncgi.test: added ncgi::reset tests, renumbered everything, and
+ switch most tests to use ncgi::reset
+
+2000-03-10 Eric Melski <ericm@scriptics.com>
+
+ * pkgIndex.tcl: Added package index file.
+
+ * ncgi.test: Added code to add source dir to auto_path, so that
+ tests could be run on uninstalled package. Added call to
+ tcltest::cleanupTests.
+
+
diff --git a/tcllib/modules/ncgi/formdata.txt b/tcllib/modules/ncgi/formdata.txt
new file mode 100644
index 0000000..a1db029
--- /dev/null
+++ b/tcllib/modules/ncgi/formdata.txt
@@ -0,0 +1,24 @@
+Content-Type: multipart/form-data; boundary="---------------------------17661509020136"
+
+-----------------------------17661509020136
+Content-Disposition: form-data; name="field1"
+
+value
+-----------------------------17661509020136
+Content-Disposition: form-data; name="field2"
+
+another value
+-----------------------------17661509020136
+Content-Disposition: form-data; name="the_file_name"; filename="C:\Program Files\Netscape\Communicator\Program\nareadme.htm"
+Content-Type: text/html
+
+
+<center><h1>
+ Netscape Address Book Sync for Palm Pilot
+ User Guide
+</h1></center>
+
+
+
+-----------------------------17661509020136--
+
diff --git a/tcllib/modules/ncgi/ncgi.man b/tcllib/modules/ncgi/ncgi.man
new file mode 100644
index 0000000..e7e2eaa
--- /dev/null
+++ b/tcllib/modules/ncgi/ncgi.man
@@ -0,0 +1,313 @@
+[vset VERSION 1.4.3]
+[manpage_begin ncgi n [vset VERSION]]
+[see_also html]
+[keywords CGI]
+[keywords cookie]
+[keywords form]
+[keywords html]
+[comment {-*- tcl -*- doctools manpage}]
+[moddesc {CGI Support}]
+[titledesc {Procedures to manipulate CGI values.}]
+[category {CGI programming}]
+[require Tcl 8.4]
+[require ncgi [opt [vset VERSION]]]
+[description]
+[para]
+
+The [package ncgi] package provides commands that manipulate CGI
+values. These are values that come from Web forms and are processed
+either by CGI scripts or web pages with embedded Tcl code. Use the
+[package ncgi] package to query these values, set and get cookies, and
+encode and decode www-url-encoded values.
+
+[para]
+
+In the simplest case, a CGI script first calls [cmd ::ncgi::parse] and
+then calls [cmd ::ncgi::value] to get different form values. If a CGI
+value is repeated, you should use [cmd ::ncgi::valueList] to get back
+the complete list of values.
+
+[para]
+
+An alternative to [cmd ::ncgi::parse] is [cmd ::ncgi::input], which
+has semantics similar to Don Libes' [cmd cgi_input] procedure.
+
+[cmd ::ncgi::input] restricts repeated CGI values to have names that
+end with "List". In this case, [cmd ::ncgi::value] will return the
+complete list of values, and [cmd ::ncgi::input] will raise errors if
+it find repeated form elements without the right name.
+
+[para]
+
+The [cmd ::ncgi::reset] procedure can be used in test suites and Web
+servers to initialize the source of the CGI values. Otherwise the
+values are read in from the CGI environment.
+
+[para]
+
+The complete set of procedures is described below.
+
+[list_begin definitions]
+
+[call [cmd ::ncgi::cookie] [arg cookie]]
+
+Return a list of values for [arg cookie], if any. It is possible that
+more than one cookie with the same name can be present, so this
+procedure returns a list.
+
+[call [cmd ::ncgi::decode] [arg str]]
+
+Decode strings in www-url-encoding, which represents special
+characters with a %xx sequence, where xx is the character code in hex.
+
+[call [cmd ::ncgi::empty] [arg name]]
+
+Returns 1 if the CGI variable [arg name] is not present or has the
+empty string as its value.
+
+[call [cmd ::ncgi::exists] [arg name]]
+
+The return value is a boolean. It returns [const 0] if the CGI
+variable [arg name] is not present, and [const 1] otherwise.
+
+[call [cmd ::ncgi::encode] [arg string]]
+
+Encode [arg string] into www-url-encoded format.
+
+[call [cmd ::ncgi::header] [opt [arg type]] [arg args]]
+
+Output the CGI header to standard output. This emits a Content-Type:
+header and additional headers based on [arg args], which is a list of
+header names and header values. The [arg type] defaults to
+"text/html".
+
+[call [cmd ::ncgi::import] [arg cginame] [opt [arg tclname]]]
+
+This creates a variable in the current scope with the value of the CGI
+variable [arg cginame]. The name of the variable is [arg tclname], or
+[arg cginame] if [arg tclname] is empty (default).
+
+[call [cmd ::ncgi::importAll] [arg args]]
+
+This imports several CGI variables as Tcl variables. If [arg args] is
+empty, then every CGI value is imported. Otherwise each CGI variable
+listed in [arg args] is imported.
+
+[call [cmd ::ncgi::importFile] [arg cmd] [arg cginame] [opt [arg filename]]]
+
+This provides information about an uploaded file from a form input
+field of type [const file] with name [arg cginame]. [arg cmd] can be
+one of [option -server] [option -client], [option -type] or
+[option -data].
+
+[list_begin definitions]
+
+[def "[option -client] [arg cginame]"]
+
+returns the filename as sent by the client.
+
+[def "[option -type] [arg cginame]"]
+
+returns the mime type of the uploaded file.
+
+[def "[option -data] [arg cginame]"]
+
+returns the contents of the file.
+
+[def "[option -server] [arg cginame] [arg filename]"]
+
+writes the file contents to a local temporary file (or [arg filename]
+if supplied) and returns the name of the file. The caller is
+responsible for deleting this file after use.
+
+[list_end]
+
+[call [cmd ::ncgi::input] [opt [arg fakeinput]] [opt [arg fakecookie]]]
+
+This reads and decodes the CGI values from the environment. It
+restricts repeated form values to have a trailing "List" in their
+name. The CGI values are obtained later with the [cmd ::ncgi::value]
+procedure.
+
+[call [cmd ::ncgi::multipart] [arg {type query}]]
+
+This procedure parses a multipart/form-data [arg query]. This is used
+by [cmd ::ncgi::nvlist] and not normally called directly. It returns
+an alternating list of names and structured values. Each structure
+value is in turn a list of two elements. The first element is
+meta-data from the multipart/form-data structure. The second element
+is the form value. If you use [cmd ::ncgi::value] you just get the
+form value. If you use [cmd ::ncgi::valueList] you get the structured
+value with meta data and the value.
+
+[para]
+
+The [arg type] is the whole Content-Type, including the parameters
+like [arg boundary]. This returns a list of names and values that
+describe the multipart data. The values are a nested list structure
+that has some descriptive information first, and the actual form value
+second. The descriptive information is list of header names and
+values that describe the content.
+
+[call [cmd ::ncgi::nvlist]]
+
+This returns all the query data as a name, value list. In the case of
+multipart/form-data, the values are structured as described in
+
+[cmd ::ncgi::multipart].
+
+[call [cmd ::ncgi::names]]
+
+This returns all names found in the query data, as a list.
+
+[cmd ::ncgi::multipart].
+
+[call [cmd ::ncgi::parse]]
+
+This reads and decodes the CGI values from the environment. The CGI
+values are obtained later with the [cmd ::ncgi::value] procedure. IF
+a CGI value is repeated, then you should use [cmd ::ncgi::valueList]
+to get the complete list of values.
+
+[call [cmd ::ncgi::parseMimeValue] [arg value]]
+
+This decodes the Content-Type and other MIME headers that have the
+form of "primary value; param=val; p2=v2" It returns a list, where the
+first element is the primary value, and the second element is a list
+of parameter names and values.
+
+[call [cmd ::ncgi::query]]
+
+This returns the raw query data.
+
+[call [cmd ::ncgi::redirect] [arg url]]
+
+Generate a response that causes a 302 redirect by the Web server. The
+[arg url] is the new URL that is the target of the redirect. The URL
+will be qualified with the current server and current directory, if
+necessary, to convert it into a full URL.
+
+[call [cmd ::ncgi::reset] [arg {query type}]]
+
+Set the query data and Content-Type for the current CGI session. This
+is used by the test suite and by Web servers to initialize the ncgi
+module so it does not try to read standard input or use environment
+variables to get its data. If neither [arg query] or [arg type] are
+specified, then the [package ncgi] module will look in the standard
+CGI environment for its data.
+
+[call [cmd ::ncgi::setCookie] [arg args]]
+
+Set a cookie value that will be returned as part of the reply. This
+must be done before [cmd ::ncgi::header] or [cmd ::ncgi::redirect] is
+called in order for the cookie to be returned properly. The
+
+[arg args] are a set of flags and values:
+
+[list_begin definitions]
+
+[def "[option -name] [arg name]"]
+[def "[option -value] [arg value]"]
+[def "[option -expires] [arg date]"]
+[def "[option -path] [arg {path restriction}]"]
+[def "[option -domain] [arg {domain restriction}]"]
+[list_end]
+
+[call [cmd ::ncgi::setDefaultValue] [arg {key defvalue}]]
+
+Set a CGI value if it does not already exists. This affects future
+calls to [cmd ::ncgi::value] (but not future calls to
+
+[cmd ::ncgi::nvlist]). If the CGI value already is present, then this
+procedure has no side effects.
+
+[call [cmd ::ncgi::setDefaultValueList] [arg {key defvaluelist}]]
+
+Like [cmd ::ncgi::setDefaultValue] except that the value already has
+list structure to represent multiple checkboxes or a multi-selection.
+
+[call [cmd ::ncgi::setValue] [arg {key value}]]
+
+Set a CGI value, overriding whatever was present in the CGI
+environment already. This affects future calls to [cmd ::ncgi::value]
+(but not future calls to [cmd ::ncgi::nvlist]).
+
+[call [cmd ::ncgi::setValueList] [arg {key valuelist}]]
+
+Like [cmd ::ncgi::setValue] except that the value already has list
+structure to represent multiple checkboxes or a multi-selection.
+
+[call [cmd ::ncgi::type]]
+
+Returns the Content-Type of the current CGI values.
+
+[call [cmd ::ncgi::urlStub] [opt [arg url]]]
+
+Returns the current URL, but without the protocol, server, and port.
+If [arg url] is specified, then it defines the URL for the current
+session. That value will be returned by future calls to
+
+[cmd ::ncgi::urlStub]
+
+[call [cmd ::ncgi::value] [arg key] [opt [arg default]]]
+
+Return the CGI value identified by [arg key]. If the CGI value is not
+present, then the [arg default] value is returned instead. This value
+defaults to the empty string.
+
+[para]
+
+If the form value [arg key] is repeated, then there are two cases: if
+[cmd ::ncgi::parse] was called, then [cmd ::ncgi::value] only returns
+the first value associated with [arg key]. If [cmd ::ncgi::input] was
+called, then [cmd ::ncgi::value] returns a Tcl list value and
+
+[arg key] must end in "List" (e.g., "skuList"). In the case of
+multipart/form-data, this procedure just returns the value of the form
+element. If you want the meta-data associated with each form value,
+then use [cmd ::ncgi::valueList].
+
+[call [cmd ::ncgi::valueList] [arg key] [opt [arg default]]]
+
+Like [cmd ::ncgi::value], but this always returns a list of values
+(even if there is only one value). In the case of
+multipart/form-data, this procedure returns a list of two elements.
+The first element is meta-data in the form of a parameter, value list.
+The second element is the form value.
+
+[list_end]
+
+[section EXAMPLES]
+
+Uploading a file
+[example {
+HTML:
+<html>
+<form action="/cgi-bin/upload.cgi" method="POST" enctype="multipart/form-data">
+Path: <input type="file" name="filedata"><br>
+Name: <input type="text" name="filedesc"><br>
+<input type="submit">
+</form>
+</html>
+
+TCL: upload.cgi
+#!/usr/local/bin/tclsh
+
+::ncgi::parse
+set filedata [::ncgi::value filedata]
+set filedesc [::ncgi::value filedesc]
+
+puts "<html> File uploaded at <a href=\"/images/$filedesc\">$filedesc</a> </html>"
+
+set filename /www/images/$filedesc
+
+set fh [open $filename w]
+puts -nonewline $fh $filedata
+close $fh
+}]
+
+[para]
+
+[vset CATEGORY ncgi]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/ncgi/ncgi.tcl b/tcllib/modules/ncgi/ncgi.tcl
new file mode 100644
index 0000000..70a96c1
--- /dev/null
+++ b/tcllib/modules/ncgi/ncgi.tcl
@@ -0,0 +1,1120 @@
+# ncgi.tcl
+#
+# Basic support for CGI programs
+#
+# Copyright (c) 2000 Ajuba Solutions.
+# Copyright (c) 2012 Richard Hipp, Andreas Kupries
+# Copyright (c) 2013-2014 Andreas Kupries
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+
+# Please note that Don Libes' has a "cgi.tcl" that implements version 1.0
+# of the cgi package. That implementation provides a bunch of cgi_ procedures
+# (it doesn't use the ::cgi:: namespace) and has a wealth of procedures for
+# generating HTML. In contract, the package provided here is primarly
+# concerned with processing input to CGI programs. I have tried to mirror his
+# API's where possible. So, ncgi::input is equivalent to cgi_input, and so
+# on. There are also some different APIs for accessing values (ncgi::list,
+# ncgi::parse and ncgi::value come to mind)
+
+# Note, I use the term "query data" to refer to the data that is passed in
+# to a CGI program. Typically this comes from a Form in an HTML browser.
+# The query data is composed of names and values, and the names can be
+# repeated. The names and values are encoded, and this module takes care
+# of decoding them.
+
+# We use newer string routines
+package require Tcl 8.4
+package require fileutil ; # Required by importFile.
+package require uri
+
+package provide ncgi 1.4.3
+
+namespace eval ::ncgi {
+
+ # "query" holds the raw query (i.e., form) data
+ # This is treated as a cache, too, so you can call ncgi::query more than
+ # once
+
+ variable query
+
+ # This is the content-type which affects how the query is parsed
+
+ variable contenttype
+
+ # value is an array of parsed query data. Each array element is a list
+ # of values, and the array index is the form element name.
+ # See the differences among ncgi::parse, ncgi::input, ncgi::value
+ # and ncgi::valuelist for the various approaches to handling these values.
+
+ variable value
+
+ # This lists the names that appear in the query data
+
+ variable varlist
+
+ # This holds the URL coresponding to the current request
+ # This does not include the server name.
+
+ variable urlStub
+
+ # This flags compatibility with Don Libes cgi.tcl when dealing with
+ # form values that appear more than once. This bit gets flipped when
+ # you use the ncgi::input procedure to parse inputs.
+
+ variable listRestrict 0
+
+ # This is the set of cookies that are pending for output
+
+ variable cookieOutput
+
+ # Support for x-www-urlencoded character mapping
+ # The spec says: "non-alphanumeric characters are replaced by '%HH'"
+
+ variable i
+ variable c
+ variable map
+
+ for {set i 1} {$i <= 256} {incr i} {
+ set c [format %c $i]
+ if {![string match \[a-zA-Z0-9\] $c]} {
+ set map($c) %[format %.2X $i]
+ }
+ }
+
+ # These are handled specially
+ array set map {
+ " " + \n %0D%0A
+ }
+
+ # Map of transient files
+
+ variable _tmpfiles
+ array set _tmpfiles {}
+
+ # I don't like importing, but this makes everything show up in
+ # pkgIndex.tcl
+
+ namespace export reset urlStub query type decode encode
+ namespace export nvlist parse input value valueList names
+ namespace export setValue setValueList setDefaultValue setDefaultValueList
+ namespace export empty import importAll importFile redirect header
+ namespace export parseMimeValue multipart cookie setCookie
+}
+
+# ::ncgi::reset
+#
+# This resets the state of the CGI input processor. This is primarily
+# used for tests, although it is also designed so that TclHttpd can
+# call this with the current query data
+# so the ncgi package can be shared among TclHttpd and CGI scripts.
+#
+# DO NOT CALL this in a standard cgi environment if you have not
+# yet processed the query data, which will not be used after a
+# call to ncgi::reset is made. Instead, just call ncgi::parse
+#
+# Arguments:
+# newquery The query data to be used instead of external CGI.
+# newtype The raw content type.
+#
+# Side Effects:
+# Resets the cached query data and wipes any environment variables
+# associated with CGI inputs (like QUERY_STRING)
+
+proc ::ncgi::reset {args} {
+ global env
+ variable _tmpfiles
+ variable query
+ variable contenttype
+ variable cookieOutput
+
+ # array unset _tmpfiles -- Not a Tcl 8.2 idiom
+ unset _tmpfiles ; array set _tmpfiles {}
+
+ set cookieOutput {}
+ if {[llength $args] == 0} {
+
+ # We use and test args here so we can detect the
+ # difference between empty query data and a full reset.
+
+ if {[info exists query]} {
+ unset query
+ }
+ if {[info exists contenttype]} {
+ unset contenttype
+ }
+ } else {
+ set query [lindex $args 0]
+ set contenttype [lindex $args 1]
+ }
+}
+
+# ::ncgi::urlStub
+#
+# Set or return the URL associated with the current page.
+# This is for use by TclHttpd to override the default value
+# that otherwise comes from the CGI environment
+#
+# Arguments:
+# url (option) The url of the page, not counting the server name.
+# If not specified, the current urlStub is returned
+#
+# Side Effects:
+# May affects future calls to ncgi::urlStub
+
+proc ::ncgi::urlStub {{url {}}} {
+ global env
+ variable urlStub
+ if {[string length $url]} {
+ set urlStub $url
+ return ""
+ } elseif {[info exists urlStub]} {
+ return $urlStub
+ } elseif {[info exists env(SCRIPT_NAME)]} {
+ set urlStub $env(SCRIPT_NAME)
+ return $urlStub
+ } else {
+ return ""
+ }
+}
+
+# ::ncgi::query
+#
+# This reads the query data from the appropriate location, which depends
+# on if it is a POST or GET request.
+#
+# Arguments:
+# none
+#
+# Results:
+# The raw query data.
+
+proc ::ncgi::query {} {
+ global env
+ variable query
+
+ if {[info exists query]} {
+ # This ensures you can call ncgi::query more than once,
+ # and that you can use it with ncgi::reset
+ return $query
+ }
+
+ set query ""
+ if {[info exists env(REQUEST_METHOD)]} {
+ if {$env(REQUEST_METHOD) == "GET"} {
+ if {[info exists env(QUERY_STRING)]} {
+ set query $env(QUERY_STRING)
+ }
+ } elseif {$env(REQUEST_METHOD) == "POST"} {
+ if {[info exists env(CONTENT_LENGTH)] &&
+ [string length $env(CONTENT_LENGTH)] != 0} {
+ ## added by Steve Cassidy to try to fix binary file upload
+ fconfigure stdin -translation binary -encoding binary
+ set query [read stdin $env(CONTENT_LENGTH)]
+ }
+ }
+ }
+ return $query
+}
+
+# ::ncgi::type
+#
+# This returns the content type of the query data.
+#
+# Arguments:
+# none
+#
+# Results:
+# The content type of the query data.
+
+proc ::ncgi::type {} {
+ global env
+ variable contenttype
+
+ if {![info exists contenttype]} {
+ if {[info exists env(CONTENT_TYPE)]} {
+ set contenttype $env(CONTENT_TYPE)
+ } else {
+ return ""
+ }
+ }
+ return $contenttype
+}
+
+# ::ncgi::decode
+#
+# This decodes data in www-url-encoded format.
+#
+# Arguments:
+# An encoded value
+#
+# Results:
+# The decoded value
+
+if {[package vsatisfies [package present Tcl] 8.6]} {
+ # 8.6+, use 'binary decode hex'
+ proc ::ncgi::DecodeHex {hex} {
+ return [binary decode hex $hex]
+ }
+} else {
+ # 8.4+. More complex way of handling the hex conversion.
+ proc ::ncgi::DecodeHex {hex} {
+ return [binary format H* $hex]
+ }
+}
+
+proc ::ncgi::decode {str} {
+ # rewrite "+" back to space
+ # protect \ from quoting another '\'
+ set str [string map [list + { } "\\" "\\\\" \[ \\\[ \] \\\]] $str]
+
+ # prepare to process all %-escapes
+ regsub -all -- {%([Ee][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])} \
+ $str {[encoding convertfrom utf-8 [DecodeHex \1\2\3]]} str
+ regsub -all -- {%([CDcd][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])} \
+ $str {[encoding convertfrom utf-8 [DecodeHex \1\2]]} str
+ regsub -all -- {%([0-7][A-Fa-f0-9])} $str {\\u00\1} str
+
+ # process \u unicode mapped chars
+ return [subst -novar $str]
+}
+
+# ::ncgi::encode
+#
+# This encodes data in www-url-encoded format.
+#
+# Arguments:
+# A string
+#
+# Results:
+# The encoded value
+
+proc ::ncgi::encode {string} {
+ variable map
+
+ # 1 leave alphanumerics characters alone
+ # 2 Convert every other character to an array lookup
+ # 3 Escape constructs that are "special" to the tcl parser
+ # 4 "subst" the result, doing all the array substitutions
+
+ regsub -all -- \[^a-zA-Z0-9\] $string {$map(&)} string
+ # This quotes cases like $map([) or $map($) => $map(\[) ...
+ regsub -all -- {[][{})\\]\)} $string {\\&} string
+ return [subst -nocommand $string]
+}
+
+# ::ncgi::names
+#
+# This parses the query data and returns a list of the names found therein.
+#
+# Note: If you use ncgi::setValue or ncgi::setDefaultValue, this
+# names procedure doesn't see the effect of that.
+#
+# Arguments:
+# none
+#
+# Results:
+# A list of names
+
+proc ::ncgi::names {} {
+ array set names {}
+ foreach {name val} [nvlist] {
+ if {![string equal $name "anonymous"]} {
+ set names($name) 1
+ }
+ }
+ return [array names names]
+}
+
+# ::ncgi::nvlist
+#
+# This parses the query data and returns it as a name, value list
+#
+# Note: If you use ncgi::setValue or ncgi::setDefaultValue, this
+# nvlist procedure doesn't see the effect of that.
+#
+# Arguments:
+# none
+#
+# Results:
+# An alternating list of names and values
+
+proc ::ncgi::nvlist {} {
+ set query [query]
+ set type [type]
+ switch -glob -- $type {
+ "" -
+ text/xml* -
+ application/x-www-form-urlencoded* -
+ application/x-www-urlencoded* {
+ set result {}
+
+ # Any whitespace at the beginning or end of urlencoded data is not
+ # considered to be part of that data, so we trim it off. One special
+ # case in which post data is preceded by a \n occurs when posting
+ # with HTTPS in Netscape.
+
+ foreach {x} [split [string trim $query] &] {
+ # Turns out you might not get an = sign,
+ # especially with <isindex> forms.
+
+ set pos [string first = $x]
+ set len [string length $x]
+
+ if { $pos>=0 } {
+ if { $pos == 0 } { # if the = is at the beginning ...
+ if { $len>1 } {
+ # ... and there is something to the right ...
+ set varname anonymous
+ set val [string range $x 1 end]
+ } else {
+ # ... otherwise, all we have is an =
+ set varname anonymous
+ set val ""
+ }
+ } elseif { $pos==[expr {$len-1}] } {
+ # if the = is at the end ...
+ set varname [string range $x 0 [expr {$pos-1}]]
+ set val ""
+ } else {
+ set varname [string range $x 0 [expr {$pos-1}]]
+ set val [string range $x [expr {$pos+1}] end]
+ }
+ } else { # no = was found ...
+ set varname anonymous
+ set val $x
+ }
+ lappend result [decode $varname] [decode $val]
+ }
+ return $result
+ }
+ multipart/* {
+ return [multipart $type $query]
+ }
+ default {
+ return -code error "Unknown Content-Type: $type"
+ }
+ }
+}
+
+# ::ncgi::parse
+#
+# The parses the query data and stores it into an array for later retrieval.
+# You should use the ncgi::value or ncgi::valueList procedures to get those
+# values, or you are allowed to access the ncgi::value array directly.
+#
+# Note - all values have a level of list structure associated with them
+# to allow for multiple values for a given form element (e.g., a checkbox)
+#
+# Arguments:
+# none
+#
+# Results:
+# A list of names of the query values
+
+proc ::ncgi::parse {} {
+ variable value
+ variable listRestrict 0
+ variable varlist {}
+ if {[info exists value]} {
+ unset value
+ }
+ foreach {name val} [nvlist] {
+ if {![info exists value($name)]} {
+ lappend varlist $name
+ }
+ lappend value($name) $val
+ }
+ return $varlist
+}
+
+# ::ncgi::input
+#
+# Like ncgi::parse, but with Don Libes cgi.tcl semantics.
+# Form elements must have a trailing "List" in their name to be
+# listified, otherwise this raises errors if an element appears twice.
+#
+# Arguments:
+# fakeinput See ncgi::reset
+# fakecookie The raw cookie string to use when testing.
+#
+# Results:
+# The list of element names in the form
+
+proc ::ncgi::input {{fakeinput {}} {fakecookie {}}} {
+ variable value
+ variable varlist {}
+ variable listRestrict 1
+ if {[info exists value]} {
+ unset value
+ }
+ if {[string length $fakeinput]} {
+ ncgi::reset $fakeinput
+ }
+ foreach {name val} [nvlist] {
+ set exists [info exists value($name)]
+ if {!$exists} {
+ lappend varlist $name
+ }
+ if {[string match "*List" $name]} {
+ # Accumulate a list of values for this name
+ lappend value($name) $val
+ } elseif {$exists} {
+ error "Multiple definitions of $name encountered in input.\
+ If you're trying to do this intentionally (such as with select),\
+ the variable must have a \"List\" suffix."
+ } else {
+ # Capture value with no list structure
+ set value($name) $val
+ }
+ }
+ return $varlist
+}
+
+# ::ncgi::value
+#
+# Return the value of a named query element, or the empty string if
+# it was not not specified. This only returns the first value of
+# associated with the name. If you want them all (like all values
+# of a checkbox), use ncgi::valueList
+#
+# Arguments:
+# key The name of the query element
+# default The value to return if the value is not present
+#
+# Results:
+# The first value of the named element, or the default
+
+proc ::ncgi::value {key {default {}}} {
+ variable value
+ variable listRestrict
+ variable contenttype
+ if {[info exists value($key)]} {
+ if {$listRestrict} {
+
+ # ::ncgi::input was called, and it already figured out if the
+ # user wants list structure or not.
+
+ set val $value($key)
+ } else {
+
+ # Undo the level of list structure done by ncgi::parse
+
+ set val [lindex $value($key) 0]
+ }
+ if {[string match multipart/* [type]]} {
+
+ # Drop the meta-data information associated with each part
+
+ set val [lindex $val 1]
+ }
+ return $val
+ } else {
+ return $default
+ }
+}
+
+# ::ncgi::valueList
+#
+# Return all the values of a named query element as a list, or
+# the empty list if it was not not specified. This always returns
+# lists - if you do not want the extra level of listification, use
+# ncgi::value instead.
+#
+# Arguments:
+# key The name of the query element
+#
+# Results:
+# The first value of the named element, or ""
+
+proc ::ncgi::valueList {key {default {}}} {
+ variable value
+ if {[info exists value($key)]} {
+ return $value($key)
+ } else {
+ return $default
+ }
+}
+
+# ::ncgi::setValue
+#
+# Jam a new value into the CGI environment. This is handy for preliminary
+# processing that does data validation and cleanup.
+#
+# Arguments:
+# key The name of the query element
+# value This is a single value, and this procedure wraps it up in a list
+# for compatibility with the ncgi::value array usage. If you
+# want a list of values, use ngci::setValueList
+#
+#
+# Side Effects:
+# Alters the ncgi::value and possibly the ncgi::valueList variables
+
+proc ::ncgi::setValue {key value} {
+ variable listRestrict
+ if {$listRestrict} {
+ ncgi::setValueList $key $value
+ } else {
+ ncgi::setValueList $key [list $value]
+ }
+}
+
+# ::ncgi::setValueList
+#
+# Jam a list of new values into the CGI environment.
+#
+# Arguments:
+# key The name of the query element
+# valuelist This is a list of values, e.g., for checkbox or multiple
+# selections sets.
+#
+# Side Effects:
+# Alters the ncgi::value and possibly the ncgi::valueList variables
+
+proc ::ncgi::setValueList {key valuelist} {
+ variable value
+ variable varlist
+ if {![info exists value($key)]} {
+ lappend varlist $key
+ }
+
+ # This if statement is a workaround for another hack in
+ # ::ncgi::value that treats multipart form data
+ # differently.
+ if {[string match multipart/* [type]]} {
+ set value($key) [list [list {} [join $valuelist]]]
+ } else {
+ set value($key) $valuelist
+ }
+ return ""
+}
+
+# ::ncgi::setDefaultValue
+#
+# Set a new value into the CGI environment if there is not already one there.
+#
+# Arguments:
+# key The name of the query element
+# value This is a single value, and this procedure wraps it up in a list
+# for compatibility with the ncgi::value array usage.
+#
+#
+# Side Effects:
+# Alters the ncgi::value and possibly the ncgi::valueList variables
+
+proc ::ncgi::setDefaultValue {key value} {
+ ncgi::setDefaultValueList $key [list $value]
+}
+
+# ::ncgi::setDefaultValueList
+#
+# Jam a list of new values into the CGI environment if the CGI value
+# is not already defined.
+#
+# Arguments:
+# key The name of the query element
+# valuelist This is a list of values, e.g., for checkbox or multiple
+# selections sets.
+#
+# Side Effects:
+# Alters the ncgi::value and possibly the ncgi::valueList variables
+
+proc ::ncgi::setDefaultValueList {key valuelist} {
+ variable value
+ if {![info exists value($key)]} {
+ ncgi::setValueList $key $valuelist
+ return ""
+ } else {
+ return ""
+ }
+}
+
+# ::ncgi::exists --
+#
+# Return false if the CGI variable doesn't exist.
+#
+# Arguments:
+# name Name of the CGI variable
+#
+# Results:
+# 0 if the variable doesn't exist
+
+proc ::ncgi::exists {var} {
+ variable value
+ return [info exists value($var)]
+}
+
+# ::ncgi::empty --
+#
+# Return true if the CGI variable doesn't exist or is an empty string
+#
+# Arguments:
+# name Name of the CGI variable
+#
+# Results:
+# 1 if the variable doesn't exist or has the empty value
+
+proc ::ncgi::empty {name} {
+ return [expr {[string length [string trim [value $name]]] == 0}]
+}
+
+# ::ncgi::import
+#
+# Map a CGI input into a Tcl variable. This creates a Tcl variable in
+# the callers scope that has the value of the CGI input. An alternate
+# name for the Tcl variable can be specified.
+#
+# Arguments:
+# cginame The name of the form element
+# tclname If present, an alternate name for the Tcl variable,
+# otherwise it is the same as the form element name
+
+proc ::ncgi::import {cginame {tclname {}}} {
+ if {[string length $tclname]} {
+ upvar 1 $tclname var
+ } else {
+ upvar 1 $cginame var
+ }
+ set var [value $cginame]
+}
+
+# ::ncgi::importAll
+#
+# Map a CGI input into a Tcl variable. This creates a Tcl variable in
+# the callers scope for every CGI value, or just for those named values.
+#
+# Arguments:
+# args A list of form element names. If this is empty,
+# then all form value are imported.
+
+proc ::ncgi::importAll {args} {
+ variable varlist
+ if {[llength $args] == 0} {
+ set args $varlist
+ }
+ foreach cginame $args {
+ upvar 1 $cginame var
+ set var [value $cginame]
+ }
+}
+
+# ::ncgi::redirect
+#
+# Generate a redirect by returning a header that has a Location: field.
+# If the URL is not absolute, this automatically qualifies it to
+# the current server
+#
+# Arguments:
+# url The url to which to redirect
+#
+# Side Effects:
+# Outputs a redirect header
+
+proc ::ncgi::redirect {url} {
+ global env
+
+ if {![regexp -- {^[^:]+://} $url]} {
+
+ # The url is relative (no protocol/server spec in it), so
+ # here we create a canonical URL.
+
+ # request_uri The current URL used when dealing with relative URLs.
+ # proto http or https
+ # server The server, which we are careful to match with the
+ # current one in base Basic Authentication is being used.
+ # port This is set if it is not the default port.
+
+ if {[info exists env(REQUEST_URI)]} {
+ # Not all servers have the leading protocol spec
+ #regsub -- {^https?://[^/]*/} $env(REQUEST_URI) / request_uri
+ array set u [uri::split $env(REQUEST_URI)]
+ set request_uri /$u(path)
+ unset u
+ } elseif {[info exists env(SCRIPT_NAME)]} {
+ set request_uri $env(SCRIPT_NAME)
+ } else {
+ set request_uri /
+ }
+
+ set port ""
+ if {[info exists env(HTTPS)] && $env(HTTPS) == "on"} {
+ set proto https
+ if {$env(SERVER_PORT) != 443} {
+ set port :$env(SERVER_PORT)
+ }
+ } else {
+ set proto http
+ if {$env(SERVER_PORT) != 80} {
+ set port :$env(SERVER_PORT)
+ }
+ }
+ # Pick the server from REQUEST_URI so it matches the current
+ # URL. Otherwise use SERVER_NAME. These could be different, e.g.,
+ # "pop.scriptics.com" vs. "pop"
+
+ if {[info exists env(REQUEST_URI)]} {
+ # Not all servers have the leading protocol spec
+ if {![regexp -- {^https?://([^/:]*)} $env(REQUEST_URI) x server]} {
+ set server $env(SERVER_NAME)
+ }
+ } else {
+ set server $env(SERVER_NAME)
+ }
+ if {[string match /* $url]} {
+ set url $proto://$server$port$url
+ } else {
+ regexp -- {^(.*/)[^/]*$} $request_uri match dirname
+ set url $proto://$server$port$dirname$url
+ }
+ }
+ ncgi::header text/html Location $url
+ puts "Please go to <a href=\"$url\">$url</a>"
+}
+
+# ncgi:header
+#
+# Output the Content-Type header.
+#
+# Arguments:
+# type The MIME content type
+# args Additional name, value pairs to specifiy output headers
+#
+# Side Effects:
+# Outputs a normal header
+
+proc ::ncgi::header {{type text/html} args} {
+ variable cookieOutput
+ puts "Content-Type: $type"
+ foreach {n v} $args {
+ puts "$n: $v"
+ }
+ if {[info exists cookieOutput]} {
+ foreach line $cookieOutput {
+ puts "Set-Cookie: $line"
+ }
+ }
+ puts ""
+ flush stdout
+}
+
+# ::ncgi::parseMimeValue
+#
+# Parse a MIME header value, which has the form
+# value; param=value; param2="value2"; param3='value3'
+#
+# Arguments:
+# value The mime header value. This does not include the mime
+# header field name, but everything after it.
+#
+# Results:
+# A two-element list, the first is the primary value,
+# the second is in turn a name-value list corresponding to the
+# parameters. Given the above example, the return value is
+# {
+# value
+# {param value param2 value param3 value3}
+# }
+
+proc ::ncgi::parseMimeValue {value} {
+ set parts [split $value \;]
+ set results [list [string trim [lindex $parts 0]]]
+ set paramList [list]
+ foreach sub [lrange $parts 1 end] {
+ if {[regexp -- {([^=]+)=(.+)} $sub match key val]} {
+ set key [string trim [string tolower $key]]
+ set val [string trim $val]
+ # Allow single as well as double quotes
+ if {[regexp -- {^["']} $val quote]} { ;# need a " for balance
+ if {[regexp -- ^${quote}(\[^$quote\]*)$quote $val x val2]} {
+ # Trim quotes and any extra crap after close quote
+ set val $val2
+ }
+ }
+ lappend paramList $key $val
+ }
+ }
+ if {[llength $paramList]} {
+ lappend results $paramList
+ }
+ return $results
+}
+
+# ::ncgi::multipart
+#
+# This parses multipart form data.
+# Based on work by Steve Ball for TclHttpd, but re-written to use
+# string first with an offset to iterate through the data instead
+# of using a regsub/subst combo.
+#
+# Arguments:
+# type The Content-Type, because we need boundary options
+# query The raw multipart query data
+#
+# Results:
+# An alternating list of names and values
+# In this case, the value is a two element list:
+# headers, which in turn is a list names and values
+# content, which is the main value of the element
+# The header name/value pairs come primarily from the MIME headers
+# like Content-Type that appear in each part. However, the
+# Content-Disposition header is handled specially. It has several
+# parameters like "name" and "filename" that are important, so they
+# are promoted to to the same level as Content-Type. Otherwise,
+# if a header like Content-Type has parameters, they appear as a list
+# after the primary value of the header. For example, if the
+# part has these two headers:
+#
+# Content-Disposition: form-data; name="Foo"; filename="/a/b/C.txt"
+# Content-Type: text/html; charset="iso-8859-1"; mumble='extra'
+#
+# Then the header list will have this structure:
+# {
+# content-disposition form-data
+# name Foo
+# filename /a/b/C.txt
+# content-type {text/html {charset iso-8859-1 mumble extra}}
+# }
+# Note that the header names are mapped to all lowercase. You can
+# use "array set" on the header list to easily find things like the
+# filename or content-type. You should always use [lindex $value 0]
+# to account for values that have parameters, like the content-type
+# example above. Finally, not that if the value has a second element,
+# which are the parameters, you can "array set" that as well.
+#
+proc ::ncgi::multipart {type query} {
+
+ set parsedType [parseMimeValue $type]
+ if {![string match multipart/* [lindex $parsedType 0]]} {
+ return -code error "Not a multipart Content-Type: [lindex $parsedType 0]"
+ }
+ array set options [lindex $parsedType 1]
+ if {![info exists options(boundary)]} {
+ return -code error "No boundary given for multipart document"
+ }
+ set boundary $options(boundary)
+
+ # The query data is typically read in binary mode, which preserves
+ # the \r\n sequence from a Windows-based browser.
+ # Also, binary data may contain \r\n sequences.
+
+ if {[string match "*$boundary\r\n*" $query]} {
+ set lineDelim "\r\n"
+ # puts "DELIM"
+ } else {
+ set lineDelim "\n"
+ # puts "NO"
+ }
+
+ # Iterate over the boundary string and chop into parts
+
+ set len [string length $query]
+ # [string length $lineDelim]+2 is for "$lineDelim--"
+ set blen [expr {[string length $lineDelim] + 2 + \
+ [string length $boundary]}]
+ set first 1
+ set results [list]
+ set offset 0
+
+ # Ensuring the query data starts
+ # with a newline makes the string first test simpler
+ if {[string first $lineDelim $query 0]!=0} {
+ set query $lineDelim$query
+ }
+ while {[set offset [string first $lineDelim--$boundary $query $offset]] \
+ >= 0} {
+ if {!$first} {
+ lappend results $formName [list $headers \
+ [string range $query $off2 [expr {$offset -1}]]]
+ } else {
+ set first 0
+ }
+ incr offset $blen
+
+ # Check for the ending boundary, which is signaled by --$boundary--
+
+ if {[string equal "--" \
+ [string range $query $offset [expr {$offset + 1}]]]} {
+ break
+ }
+
+ # Split headers out from content
+ # The headers become a nested list structure:
+ # {header-name {
+ # value {
+ # paramname paramvalue ... }
+ # }
+ # }
+
+ set off2 [string first "$lineDelim$lineDelim" $query $offset]
+ set headers [list]
+ set formName ""
+ foreach line [split [string range $query $offset $off2] $lineDelim] {
+ if {[regexp -- {([^: ]+):(.*)$} $line x hdrname value]} {
+ set hdrname [string tolower $hdrname]
+ set valueList [parseMimeValue $value]
+ if {[string equal $hdrname "content-disposition"]} {
+
+ # Promote Conent-Disposition parameters up to headers,
+ # and look for the "name" that identifies the form element
+
+ lappend headers $hdrname [lindex $valueList 0]
+ foreach {n v} [lindex $valueList 1] {
+ lappend headers $n $v
+ if {[string equal $n "name"]} {
+ set formName $v
+ }
+ }
+ } else {
+ lappend headers $hdrname $valueList
+ }
+ }
+ }
+
+ if {$off2 > 0} {
+ # +[string length "$lineDelim$lineDelim"] for the
+ # $lineDelim$lineDelim
+ incr off2 [string length "$lineDelim$lineDelim"]
+ set offset $off2
+ } else {
+ break
+ }
+ }
+ return $results
+}
+
+# ::ncgi::importFile --
+#
+# get information about a file upload field
+#
+# Arguments:
+# cmd one of '-server' '-client' '-type' '-data'
+# var cgi variable name for the file field
+# filename filename to write to for -server
+# Results:
+# -server returns the name of the file on the server: side effect
+# is that the file gets stored on the server and the
+# script is responsible for deleting/moving the file
+# -client returns the name of the file sent from the client
+# -type returns the mime type of the file
+# -data returns the contents of the file
+
+proc ::ncgi::importFile {cmd var {filename {}}} {
+
+ set vlist [valueList $var]
+
+ array set fileinfo [lindex [lindex $vlist 0] 0]
+ set contents [lindex [lindex $vlist 0] 1]
+
+ switch -exact -- $cmd {
+ -server {
+ ## take care not to write it out more than once
+ variable _tmpfiles
+ if {![info exists _tmpfiles($var)]} {
+ if {$filename != {}} {
+ ## use supplied filename
+ set _tmpfiles($var) $filename
+ } else {
+ ## create a tmp file
+ set _tmpfiles($var) [::fileutil::tempfile ncgi]
+ }
+
+ # write out the data only if it's not been done already
+ if {[catch {open $_tmpfiles($var) w} h]} {
+ error "Can't open temporary file in ncgi::importFile ($h)"
+ }
+
+ fconfigure $h -translation binary -encoding binary
+ puts -nonewline $h $contents
+ close $h
+ }
+ return $_tmpfiles($var)
+ }
+ -client {
+ if {![info exists fileinfo(filename)]} {return {}}
+ return $fileinfo(filename)
+ }
+ -type {
+ if {![info exists fileinfo(content-type)]} {return {}}
+ return $fileinfo(content-type)
+ }
+ -data {
+ return $contents
+ }
+ default {
+ error "Unknown subcommand to ncgi::import_file: $cmd"
+ }
+ }
+}
+
+
+# ::ncgi::cookie
+#
+# Return a *list* of cookie values, if present, else ""
+# It is possible for multiple cookies with the same key
+# to be present, so we return a list.
+#
+# Arguments:
+# cookie The name of the cookie (the key)
+#
+# Results:
+# A list of values for the cookie
+
+proc ::ncgi::cookie {cookie} {
+ global env
+ set result ""
+ if {[info exists env(HTTP_COOKIE)]} {
+ foreach pair [split $env(HTTP_COOKIE) \;] {
+ foreach {key value} [split [string trim $pair] =] { break ;# lassign }
+ if {[string compare $cookie $key] == 0} {
+ lappend result $value
+ }
+ }
+ }
+ return $result
+}
+
+# ::ncgi::setCookie
+#
+# Set a return cookie. You must call this before you call
+# ncgi::header or ncgi::redirect
+#
+# Arguments:
+# args Name value pairs, where the names are:
+# -name Cookie name
+# -value Cookie value
+# -path Path restriction
+# -domain domain restriction
+# -expires Time restriction
+#
+# Side Effects:
+# Formats and stores the Set-Cookie header for the reply.
+
+proc ::ncgi::setCookie {args} {
+ variable cookieOutput
+ array set opt $args
+ set line "$opt(-name)=$opt(-value) ;"
+ foreach extra {path domain} {
+ if {[info exists opt(-$extra)]} {
+ append line " $extra=$opt(-$extra) ;"
+ }
+ }
+ if {[info exists opt(-expires)]} {
+ switch -glob -- $opt(-expires) {
+ *GMT {
+ set expires $opt(-expires)
+ }
+ default {
+ set expires [clock format [clock scan $opt(-expires)] \
+ -format "%A, %d-%b-%Y %H:%M:%S GMT" -gmt 1]
+ }
+ }
+ append line " expires=$expires ;"
+ }
+ if {[info exists opt(-secure)]} {
+ append line " secure "
+ }
+ lappend cookieOutput $line
+}
diff --git a/tcllib/modules/ncgi/ncgi.test b/tcllib/modules/ncgi/ncgi.test
new file mode 100644
index 0000000..5089a24
--- /dev/null
+++ b/tcllib/modules/ncgi/ncgi.test
@@ -0,0 +1,854 @@
+# -*- tcl -*-
+# Tests for the cgi 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) 1998-2000 by Ajuba Solutions
+#
+# RCS: @(#) $Id: ncgi.test,v 1.28 2012/05/03 17:56:07 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 2
+
+testing {
+ useLocal ncgi.tcl ncgi
+}
+
+# -------------------------------------------------------------------------
+
+set sub_ap $auto_path
+lappend sub_ap $::tcltest::testsDirectory
+set ncgiFile [localPath ncgi.tcl]
+set futlFile [tcllibPath fileutil/fileutil.tcl]
+set cmdlFile [tcllibPath cmdline/cmdline.tcl]
+
+# -------------------------------------------------------------------------
+
+test ncgi-1.1 {ncgi::reset} {
+ ncgi::reset
+ list [info exist ncgi::query] [info exist ncgi::contenttype]
+} {0 0}
+
+test ncgi-1.2 {ncgi::reset} {
+ ncgi::reset query=reset
+ list $ncgi::query $ncgi::contenttype
+} {query=reset {}}
+
+test ncgi-1.3 {ncgi::reset} {
+ ncgi::reset query=reset text/plain
+ list $ncgi::query $ncgi::contenttype
+} {query=reset text/plain}
+
+test ncgi-2.1 {ncgi::query fake query data} {
+ ncgi::reset "fake=query"
+ ncgi::query
+ set ncgi::query
+} "fake=query"
+
+test ncgi-2.2 {ncgi::query GET} {
+ ncgi::reset
+ set env(REQUEST_METHOD) GET
+ set env(QUERY_STRING) name=value
+ ncgi::query
+ set ncgi::query
+} "name=value"
+
+test ncgi-2.3 {ncgi::query HEAD} {
+ ncgi::reset
+ set env(REQUEST_METHOD) HEAD
+ catch {unset env(QUERY_STRING)}
+ ncgi::query
+ set ncgi::query
+} ""
+
+test ncgi-2.4 {ncgi::query POST} {
+ ncgi::reset
+ catch {unset env(QUERY_STRING)}
+ set env(REQUEST_METHOD) POST
+ set env(CONTENT_LENGTH) 10
+ makeFile [format {
+ set auto_path {%s}
+ source {%s}
+ source {%s}
+ source {%s}
+ ncgi::query
+ puts $ncgi::query
+ exit
+ } $sub_ap $cmdlFile $futlFile $ncgiFile] test1 ; # {}
+ set f [open "|[list $::tcltest::tcltest test1]" r+]
+ puts $f "name=value"
+ flush $f
+ gets $f line
+ close $f
+ removeFile test1
+ set line
+} "name=value"
+
+test ncgi-2.5 {ncgi::test} {
+ ncgi::reset
+ set env(CONTENT_TYPE) text/html
+ ncgi::type
+} text/html
+
+test ncgi-2.6 {ncgi::test} {
+ ncgi::reset foo=bar text/plain
+ set env(CONTENT_TYPE) text/html
+ ncgi::type
+} text/plain
+
+test ncgi-3.1 {ncgi::decode} {
+ ncgi::decode abcdef0123
+} abcdef0123
+
+test ncgi-3.2 {ncgi::decode} {
+ ncgi::decode {[abc]def$0123\x}
+} {[abc]def$0123\x}
+
+test ncgi-3.3 {ncgi::decode} {
+ ncgi::decode {[a%25c]def$01%7E3\x%3D}
+} {[a%c]def$01~3\x=}
+
+test ncgi-3.4 {ncgi::decode} {
+ ncgi::decode {hello+world}
+} {hello world}
+
+test ncgi-3.5 {ncgi::decode} {
+ ncgi::decode {aik%C5%ABloa}
+} "aik\u016Bloa" ; # u+macron
+
+test ncgi-3.6 {ncgi::decode} {
+ ncgi::decode {paran%C3%A1}
+} "paran\u00E1" ; # a+acute
+
+test ncgi-3.7 {ncgi::decode, bug 3601995} {
+ ncgi::decode {%C4%85}
+} "\u0105" ; # a+ogonek
+
+test ncgi-3.8 {ncgi::decode, bug 3601995} {
+ ncgi::decode {%E2%80%A0}
+} "\u2020" ; # dagger
+
+test ncgi-3.9 {ncgi::decode, bug 3601995} {
+ ncgi::decode {%E2%A0%90}
+} "\u2810" ; # a braille pattern
+
+test ncgi-3.10 {ncgi::decode, bug 3601995} {
+ ncgi::decode {%E2%B1}
+} "%E2%B1" ; # missing byte trailing %A0, do not accept/decode, pass through.
+
+test ncgi-4.1 {ncgi::encode} {
+ ncgi::encode abcdef0123
+} abcdef0123
+
+test ncgi-4.2 {ncgi::encode} {
+ ncgi::encode "\[abc\]def\$0123\\x"
+} {%5Babc%5Ddef%240123%5Cx}
+
+test ncgi-4.3 {ncgi::encode} {
+ ncgi::encode {hello world}
+} {hello+world}
+
+test ncgi-4.4 {ncgi::encode} {
+ ncgi::encode "hello\nworld\r\tbar"
+} {hello%0D%0Aworld%0D%09bar}
+
+test ncgi-5.1 {ncgi::nvlist} {
+ ncgi::reset "name=hello+world&name2=%7ewelch"
+ ncgi::nvlist
+} {name {hello world} name2 ~welch}
+
+test ncgi-5.2 {ncgi::nvlist} {
+ ncgi::reset "name=&name2" application/x-www-urlencoded
+ ncgi::nvlist
+} {name {} anonymous name2}
+
+test ncgi-5.3 {ncgi::nvlist} {
+ ncgi::reset "name=&name2" application/x-www-form-urlencoded
+ ncgi::nvlist
+} {name {} anonymous name2}
+
+test ncgi-5.4 {ncgi::nvlist} {
+ ncgi::reset "name=&name2" application/xyzzy
+ set code [catch ncgi::nvlist err]
+ list $code $err
+} {1 {Unknown Content-Type: application/xyzzy}}
+
+# multipart tests at the end because I'm too lazy to renumber the tests
+
+test ncgi-6.1 {ncgi::parse, anonymous values} {
+ ncgi::reset "name=&name2"
+ ncgi::parse
+} {name anonymous}
+
+test ncgi-6.2 {ncgi::parse, no list restrictions} {
+ ncgi::reset "name=value&name=value2"
+ ncgi::parse
+} {name}
+
+test ncgi-7.1 {ncgi::input} {
+ ncgi::reset
+ catch {unset env(REQUEST_METHOD)}
+ ncgi::input "name=value&name2=value2"
+} {name name2}
+
+test ncgi-7.2 {ncgi::input} {
+ ncgi::reset "nameList=value1+stuff&nameList=value2+more"
+ ncgi::input
+ set ncgi::value(nameList)
+} {{value1 stuff} {value2 more}}
+
+test ncgi-7.3 {ncgi::input} {
+ ncgi::reset "name=value&name=value2"
+ catch {ncgi::input} err
+ set err
+} {Multiple definitions of name encountered in input. If you're trying to do this intentionally (such as with select), the variable must have a "List" suffix.}
+
+test ncgi-8.1 {ncgi::value} {
+ ncgi::reset "nameList=val+ue&nameList=value2"
+ ncgi::input
+ ncgi::value nameList
+} {{val ue} value2}
+
+test ncgi-8.2 {ncgi::value} {
+ ncgi::reset "name=val+ue&name=value2"
+ ncgi::parse
+ ncgi::value name
+} {val ue}
+
+test ncgi-8.3 {ncgi::value} {
+ ncgi::reset "name=val+ue&name=value2"
+ ncgi::parse
+ ncgi::value noname
+} {}
+
+test ncgi-9.1 {ncgi::valueList} {
+ ncgi::reset "name=val+ue&name=value2"
+ ncgi::parse
+ ncgi::valueList name
+} {{val ue} value2}
+
+test ncgi-9.2 {ncgi::valueList} {
+ ncgi::reset "name=val+ue&name=value2"
+ ncgi::parse
+ ncgi::valueList noname
+} {}
+
+test ncgi-10.1 {ncgi::import} {
+ ncgi::reset "nameList=val+ue&nameList=value2"
+ ncgi::input
+ ncgi::import nameList
+ set nameList
+} {{val ue} value2}
+
+test ncgi-10.2 {ncgi::import} {
+ ncgi::reset "nameList=val+ue&nameList=value2"
+ ncgi::input
+ ncgi::import nameList myx
+ set myx
+} {{val ue} value2}
+
+test ncgi-10.3 {ncgi::import} {
+ ncgi::reset "nameList=val+ue&nameList=value2"
+ ncgi::input
+ ncgi::import noname
+ set noname
+} {}
+
+test ncgi-10.4 {ncgi::importAll} {
+ ncgi::reset "name1=val+ue&name2=value2"
+ catch {unset name1}
+ catch {unset name2}
+ ncgi::parse
+ ncgi::importAll
+ list $name1 $name2
+} {{val ue} value2}
+
+test ncgi-10.5 {ncgi::importAll} {
+ ncgi::reset "name1=val+ue&name2=value2"
+ catch {unset name1}
+ catch {unset name2}
+ catch {unset name3}
+ ncgi::parse
+ ncgi::importAll name2 name3
+ list [info exist name1] $name2 $name3
+} {0 value2 {}}
+
+set URL http://www.tcltk.com/index.html
+test ncgi-11.1 {ncgi::redirect} {
+ set env(REQUEST_URI) http://www.scriptics.com/cgi-bin/test.cgi
+ set env(REQUEST_METHOD) GET
+ set env(QUERY_STRING) {}
+ set env(SERVER_NAME) www.scriptics.com
+ set env(SERVER_PORT) 80
+ makeFile [format {
+ set auto_path {%s}
+ if {[catch {
+ source %s
+ source %s
+ source %s
+ ncgi::redirect %s
+ } err]} {
+ puts $err
+ }
+ exit
+ } $sub_ap $cmdlFile $futlFile $ncgiFile $URL] test1
+ set f [open "|[list $::tcltest::tcltest test1]" r+]
+ set res [read $f]
+ close $f
+ removeFile test1
+ set res
+} "Content-Type: text/html\nLocation: $URL\n\nPlease go to <a href=\"$URL\">$URL</a>\n"
+
+set URL /elsewhere/foo.html
+set URL2 http://www/elsewhere/foo.html
+test ncgi-11.2 {ncgi::redirect} {
+ set env(REQUEST_URI) http://www/cgi-bin/test.cgi
+ set env(REQUEST_METHOD) GET
+ set env(QUERY_STRING) {}
+ set env(SERVER_NAME) www.scriptics.com
+ set env(SERVER_PORT) 80
+ makeFile [format {
+ set auto_path {%s}
+ if {[catch {
+ source %s
+ source %s
+ source %s
+ ncgi::setCookie -name CookieName -value 12345
+ ncgi::redirect %s
+ } err]} {
+ puts $err
+ }
+ exit
+ } $sub_ap $cmdlFile $futlFile $ncgiFile $URL] test1
+ set f [open "|[list $::tcltest::tcltest test1]" r+]
+ set res [read $f]
+ close $f
+ removeFile test1
+ set res
+} "Content-Type: text/html\nLocation: $URL2\nSet-Cookie: CookieName=12345 ;\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n"
+
+set URL foo.html
+set URL2 http://www.scriptics.com/cgi-bin/foo.html
+test ncgi-11.3 {ncgi::redirect} {
+ set env(REQUEST_URI) http://www.scriptics.com/cgi-bin/test.cgi
+ set env(REQUEST_METHOD) GET
+ set env(QUERY_STRING) {}
+ set env(SERVER_NAME) www.scriptics.com
+ set env(SERVER_PORT) 80
+ makeFile [format {
+ set auto_path {%s}
+ if {[catch {
+ source %s
+ source %s
+ source %s
+ ncgi::redirect %s
+ } err]} {
+ puts $err
+ }
+ exit
+ } $sub_ap $cmdlFile $futlFile $ncgiFile $URL] test1
+ set f [open "|[list $::tcltest::tcltest test1]" r+]
+ set res [read $f]
+ close $f
+ removeFile test1
+ set res
+} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n"
+
+set URL foo.html
+set URL2 http://www.scriptics.com/cgi-bin/foo.html
+test ncgi-11.4 {ncgi::redirect} {
+ set env(REQUEST_URI) /cgi-bin/test.cgi
+ set env(REQUEST_METHOD) GET
+ set env(QUERY_STRING) {}
+ set env(SERVER_NAME) www.scriptics.com
+ set env(SERVER_PORT) 80
+ makeFile [format {
+ set auto_path {%s}
+ if {[catch {
+ source %s
+ source %s
+ source %s
+ ncgi::redirect %s
+ } err]} {
+ puts $err
+ }
+ exit
+ } $sub_ap $cmdlFile $futlFile $ncgiFile $URL] test1
+ set f [open "|[list $::tcltest::tcltest test1]" r+]
+ set res [read $f]
+ close $f
+ removeFile test1
+ set res
+} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n"
+
+set URL foo.html
+set URL2 http://www.scriptics.com:8000/cgi-bin/foo.html
+test ncgi-11.5 {ncgi::redirect} {
+ set env(REQUEST_URI) /cgi-bin/test.cgi
+ set env(REQUEST_METHOD) GET
+ set env(QUERY_STRING) {}
+ set env(SERVER_NAME) www.scriptics.com
+ set env(SERVER_PORT) 8000
+ makeFile [format {
+ set auto_path {%s}
+ if {[catch {
+ source %s
+ source %s
+ source %s
+ ncgi::redirect %s
+ } err]} {
+ puts $err
+ }
+ exit
+ } $sub_ap $cmdlFile $futlFile $ncgiFile $URL] test1
+ set f [open "|[list $::tcltest::tcltest test1]" r+]
+ set res [read $f]
+ close $f
+ removeFile test1
+ set res
+} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n"
+
+set URL foo.html
+set URL2 https://www.scriptics.com/cgi-bin/foo.html
+test ncgi-11.6 {ncgi::redirect} {
+ set env(REQUEST_URI) /cgi-bin/test.cgi
+ set env(REQUEST_METHOD) GET
+ set env(QUERY_STRING) {}
+ set env(SERVER_NAME) www.scriptics.com
+ set env(SERVER_PORT) 443
+ set env(HTTPS) "on"
+ makeFile [format {
+ set auto_path {%s}
+ if {[catch {
+ source %s
+ source %s
+ source %s
+ ncgi::redirect %s
+ } err]} {
+ puts $err
+ }
+ exit
+ } $sub_ap $cmdlFile $futlFile $ncgiFile $URL] test1
+ set f [open "|[list $::tcltest::tcltest test1]" r+]
+ set res [read $f]
+ close $f
+ removeFile test1
+ set res
+} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n"
+
+set URL login.tcl
+set URL2 https://foo.com/cgi-bin/login.tcl
+test ncgi-11.7 {ncgi::redirect} {
+ set env(REQUEST_URI) https://foo.com/cgi-bin/view.tcl?path=/a/b/c
+ set env(REQUEST_METHOD) GET
+ set env(QUERY_STRING) {}
+ set env(SERVER_NAME) foo.com
+ set env(SERVER_PORT) 443
+ set env(HTTPS) "on"
+ makeFile [format {
+ set auto_path {%s}
+ if {[catch {
+ source %s
+ source %s
+ source %s
+ ncgi::redirect %s
+ } err]} {
+ puts $err
+ }
+ exit
+ } $sub_ap $cmdlFile $futlFile $ncgiFile $URL] test1
+ set f [open "|[list $::tcltest::tcltest test1]" r+]
+ set res [read $f]
+ close $f
+ removeFile test1
+ set res
+} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n"
+
+
+test ncgi-12.1 {ncgi::header} {
+ makeFile [format {
+ set auto_path {%s}
+ if {[catch {
+ source %s
+ source %s
+ source %s
+ ncgi::header
+ } err]} {
+ puts $err
+ }
+ exit
+ } $sub_ap $cmdlFile $futlFile $ncgiFile] test1
+ set f [open "|[list $::tcltest::tcltest test1]" r+]
+ set res [read $f]
+ close $f
+ removeFile test1
+ set res
+} "Content-Type: text/html\n\n"
+
+test ncgi-12.2 {ncgi::header} {
+ makeFile [format {
+ set auto_path {%s}
+ if {[catch {
+ source %s
+ source %s
+ source %s
+ ncgi::header text/plain
+ } err]} {
+ puts $err
+ }
+ exit
+ } $sub_ap $cmdlFile $futlFile $ncgiFile] test1
+ set f [open "|[list $::tcltest::tcltest test1]" r+]
+ set res [read $f]
+ close $f
+ removeFile test1
+ set res
+} "Content-Type: text/plain\n\n"
+
+test ncgi-12.3 {ncgi::header} {
+ makeFile [format {
+ set auto_path {%s}
+ if {[catch {
+ source %s
+ source %s
+ source %s
+ ncgi::header text/html X-Comment "This is a test"
+ } err]} {
+ puts $err
+ }
+ exit
+ } $sub_ap $cmdlFile $futlFile $ncgiFile] test1
+ set f [open "|[list $::tcltest::tcltest test1]" r+]
+ set res [read $f]
+ close $f
+ removeFile test1
+ set res
+} "Content-Type: text/html\nX-Comment: This is a test\n\n"
+
+test ncgi-12.4 {ncgi::header} {
+ makeFile [format {
+ set auto_path {%s}
+ if {[catch {
+ source %s
+ source %s
+ source %s
+ ncgi::setCookie -name Name -value {The+Value}
+ ncgi::header
+ } err]} {
+ puts $err
+ }
+ exit
+ } $sub_ap $cmdlFile $futlFile $ncgiFile] test1
+ set f [open "|[list $::tcltest::tcltest test1]" r+]
+ set res [read $f]
+ close $f
+ removeFile test1
+ set res
+} "Content-Type: text/html\nSet-Cookie: Name=The+Value ;\n\n"
+
+test ncgi-13.1 {ncgi::parseMimeValue} {
+ ncgi::parseMimeValue text/html
+} text/html
+
+test ncgi-13.2 {ncgi::parseMimeValue} {
+ ncgi::parseMimeValue "text/html; charset=iso-8859-1"
+} {text/html {charset iso-8859-1}}
+
+test ncgi-13.3 {ncgi::parseMimeValue} {
+ ncgi::parseMimeValue "text/html; charset='iso-8859-1'"
+} {text/html {charset iso-8859-1}}
+
+test ncgi-13.4 {ncgi::parseMimeValue} {
+ ncgi::parseMimeValue "text/html; charset=\"iso-8859-1\""
+} {text/html {charset iso-8859-1}}
+
+test ncgi-13.5 {ncgi::parseMimeValue} {
+ ncgi::parseMimeValue "text/html; charset=\"iso-8859-1\"; ignored"
+} {text/html {charset iso-8859-1}}
+
+test ncgi-13.6 {ncgi::parseMimeValue} {
+ ncgi::parseMimeValue "text/html; charset=\"iso-8859-1\"morecrap"
+} {text/html {charset iso-8859-1}}
+
+
+test ncgi-14.1 {ncgi::multipart} {
+ catch {ncgi::multipart "application/x-www-urlencoded" name=val+ue} err
+ set err
+} {Not a multipart Content-Type: application/x-www-urlencoded}
+
+test ncgi-14.2 {ncgi::multipart} {
+ catch {ncgi::multipart "multipart/form-data" {}} err
+ set err
+} {No boundary given for multipart document}
+
+test ncgi-14.3 {ncgi::multipart} {
+ set in [open [file join [file dirname [info script]] formdata.txt]]
+ set X [read $in]
+ close $in
+
+ foreach line [split $X \n] {
+ if {[string length $line] == 0} {
+ break
+ }
+ if {[regexp {^Content-Type: (.*)$} $line x type]} {
+ break
+ }
+ }
+ regsub ".*?\n\n" $X {} X
+
+ ncgi::reset $X $type
+ ncgi::multipart $type $X
+} {field1 {{content-disposition form-data name field1} value} field2 {{content-disposition form-data name field2} {another value}} the_file_name {{content-disposition form-data name the_file_name filename {C:\Program Files\Netscape\Communicator\Program\nareadme.htm} content-type text/html} {
+<center><h1>
+ Netscape Address Book Sync for Palm Pilot
+ User Guide
+</h1></center>
+
+
+}}}
+
+test ncgi-14.4 {ncgi::multipart} {
+ set in [open [file join [file dirname [info script]] formdata.txt]]
+ set X [read $in]
+ close $in
+
+ foreach line [split $X \n] {
+ if {[string length $line] == 0} {
+ break
+ }
+ if {[regexp {^Content-Type: (.*)$} $line x type]} {
+ break
+ }
+ }
+ regsub ".*?\n\n" $X {} X
+
+ ncgi::reset $X $type
+ ncgi::parse
+ list [ncgi::value field1] [ncgi::value field2] [ncgi::value the_file_name]
+} {value {another value} {
+<center><h1>
+ Netscape Address Book Sync for Palm Pilot
+ User Guide
+</h1></center>
+
+
+}}
+
+
+test ncgi-14.6 {ncgi::multipart setValue} {
+ set in [open [file join [file dirname [info script]] formdata.txt]]
+ set X [read $in]
+ close $in
+
+ foreach line [split $X \n] {
+ if {[string length $line] == 0} {
+ break
+ }
+ if {[regexp {^Content-Type: (.*)$} $line x type]} {
+ break
+ }
+ }
+ regsub ".*?\n\n" $X {} X
+
+ ncgi::reset $X $type
+ ncgi::parse
+ ncgi::setValue userval1 foo
+ ncgi::setValue userval2 "a b"
+ list [ncgi::value field1] [ncgi::value field2] [ncgi::value userval1] [ncgi::value userval2] [ncgi::value the_file_name]
+} {value {another value} foo {a b} {
+<center><h1>
+ Netscape Address Book Sync for Palm Pilot
+ User Guide
+</h1></center>
+
+
+}}
+
+test ncgi-15.1 {ncgi::setValue} {
+ ncgi::reset "nameList=val+ue&nameList=value2"
+ ncgi::input
+ ncgi::setValue foo 1
+ ncgi::setValue bar "a b"
+ list [ncgi::value nameList] [ncgi::value foo] [ncgi::value bar]
+} {{{val ue} value2} 1 {a b}}
+
+
+
+
+## ------------ tests for binary content and file upload ----------------
+
+## some utility procedures to generate content
+
+set form_boundary {17661509020136}
+
+proc genformcontent_type {} {
+ global form_boundary
+ return "multipart/form-data; boundary=\"$form_boundary\""
+}
+
+proc genformdata {bcontent} {
+
+ global form_boundary
+
+ proc genformdatapart {name cd value} {
+ global form_boundary
+ return "--$form_boundary\nContent-Disposition: form-data; name=\"$name\"$cd\n\n$value\n"
+ }
+
+ set a [genformdatapart field1 "" {value}]
+ set b [genformdatapart field2 "" {another value}]
+ set c [genformdatapart the_file_name "; filename=\"C:\\Program Files\\Netscape\\Communicator\\Program\\nareadme.htm\"\nContent-Type: text/html" $bcontent]
+
+ return "$a$b$c--$form_boundary--\n"
+}
+
+set binary_content "\r
+\r
+<center><h1>\r
+ Netscape Address Book Sync for Palm Pilot\r
+ User Guide\r
+</h1></center>\r
+\r
+"
+
+test ncgi-14.5 {ncgi::multipart--check binary file} {
+
+ global binary_content
+
+ set X [genformdata $binary_content]
+
+ ncgi::reset $X [genformcontent_type]
+ ncgi::parse
+ set content [ncgi::value the_file_name]
+ list [ncgi::value field1] [ncgi::value field2] $content
+} [list value {another value} $binary_content]
+
+
+test ncgi-16.1 {ncgi::importFile} {
+
+ global binary_content
+
+ set X [genformdata $binary_content]
+
+ ncgi::reset $X [genformcontent_type]
+ ncgi::parse
+
+ ncgi::importFile -client the_file_name
+
+} "C:\\Program Files\\Netscape\\Communicator\\Program\\nareadme.htm"
+
+test ncgi-16.2 {ncgi::importFile - content type} {
+
+ global binary_content
+
+ set X [genformdata $binary_content]
+
+ ncgi::reset $X [genformcontent_type]
+ ncgi::parse
+
+ ncgi::importFile -type the_file_name
+
+} text/html
+
+
+test ncgi-16.3 {ncgi::importFile -- file contents} {
+
+ global binary_content
+
+ set X [genformdata $binary_content]
+
+ ncgi::reset $X [genformcontent_type]
+ ncgi::parse
+
+ ncgi::importFile -data the_file_name
+
+} $binary_content
+
+test ncgi-16.4 {ncgi::importFile -- save file} {
+
+ global binary_content
+
+ set X [genformdata $binary_content]
+
+ ncgi::reset $X [genformcontent_type]
+ ncgi::parse
+
+ set localfile [ncgi::importFile -server the_file_name]
+
+ # get the contents of the local file to verify
+ set in [open $localfile]
+ fconfigure $in -translation binary
+ set content [read $in]
+ close $in
+ file delete $localfile
+ set content
+
+} $binary_content
+
+test ncgi-16.5 {ncgi::importFile -- save file, given name} {
+
+ global binary_content
+
+ set X [genformdata $binary_content]
+
+ ncgi::reset $X [genformcontent_type]
+ ncgi::parse
+
+ set localfile [ncgi::importFile -server the_file_name fofo]
+
+ # get the contents of the local file to verify
+ set in [open $localfile]
+ fconfigure $in -translation binary
+ set content [read $in]
+ close $in
+ file delete $localfile
+ set content
+
+} $binary_content
+
+
+test ncgi-16.6 {ncgi::importFile -- bad input} {
+
+ set X "bad multipart data"
+
+ ncgi::reset $X [genformcontent_type]
+ ncgi::parse
+
+ ncgi::importFile -client the_file_name
+
+} {}
+
+
+test ncgi-17.1 {ncgi::names} {
+ ncgi::reset "name=hello+world&name2=%7ewelch"
+ ncgi::names
+} {name name2}
+
+test ncgi-17.2 {ncgi::names} {
+ ncgi::reset "name=&name2" application/x-www-urlencoded
+ ncgi::names
+} {name}
+
+test ncgi-17.3 {ncgi::names} {
+ ncgi::reset "name=&name2" application/x-www-form-urlencoded
+ ncgi::names
+} {name}
+
+test ncgi-17.4 {ncgi::names} {
+ ncgi::reset "name=&name2" application/xyzzy
+ set code [catch ncgi::names err]
+ list $code $err
+} {1 {Unknown Content-Type: application/xyzzy}}
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/ncgi/pkgIndex.tcl b/tcllib/modules/ncgi/pkgIndex.tcl
new file mode 100644
index 0000000..0b4506a
--- /dev/null
+++ b/tcllib/modules/ncgi/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded ncgi 1.4.3 [list source [file join $dir ncgi.tcl]]
diff --git a/tcllib/modules/nettool/available_ports.tcl b/tcllib/modules/nettool/available_ports.tcl
new file mode 100644
index 0000000..6497cc5
--- /dev/null
+++ b/tcllib/modules/nettool/available_ports.tcl
@@ -0,0 +1,759 @@
+###
+# topic: 868a79cedf28924191fd86aa85f6dd1d
+###
+namespace eval ::nettool {
+ set blocks {}
+}
+
+lappend ::nettool::blocks 1028 1028
+lappend ::nettool::blocks 1067 1068
+lappend ::nettool::blocks 1109 1109
+lappend ::nettool::blocks 1138 1138
+lappend ::nettool::blocks 1313 1313
+lappend ::nettool::blocks 1382 1382
+lappend ::nettool::blocks 1385 1385
+lappend ::nettool::blocks 1416 1416
+lappend ::nettool::blocks 1454 1454
+lappend ::nettool::blocks 1461 1461
+lappend ::nettool::blocks 1464 1464
+lappend ::nettool::blocks 1486 1486
+lappend ::nettool::blocks 1491 1491
+lappend ::nettool::blocks 1493 1493
+lappend ::nettool::blocks 1528 1528
+lappend ::nettool::blocks 1556 1556
+lappend ::nettool::blocks 1587 1587
+lappend ::nettool::blocks 1651 1651
+lappend ::nettool::blocks 1783 1783
+lappend ::nettool::blocks 1895 1895
+lappend ::nettool::blocks 2083 2083
+lappend ::nettool::blocks 2194 2196
+lappend ::nettool::blocks 2222 2222
+lappend ::nettool::blocks 2259 2259
+lappend ::nettool::blocks 2340 2340
+lappend ::nettool::blocks 2346 2349
+lappend ::nettool::blocks 2369 2369
+lappend ::nettool::blocks 2377 2378
+lappend ::nettool::blocks 2395 2395
+lappend ::nettool::blocks 2426 2426
+lappend ::nettool::blocks 2446 2446
+lappend ::nettool::blocks 2528 2528
+lappend ::nettool::blocks 2640 2640
+lappend ::nettool::blocks 2654 2654
+lappend ::nettool::blocks 2682 2682
+lappend ::nettool::blocks 2693 2693
+lappend ::nettool::blocks 2794 2794
+lappend ::nettool::blocks 2825 2825
+lappend ::nettool::blocks 2873 2873
+lappend ::nettool::blocks 2916 2917
+lappend ::nettool::blocks 2925 2925
+lappend ::nettool::blocks 3014 3014
+lappend ::nettool::blocks 3016 3019
+lappend ::nettool::blocks 3024 3024
+lappend ::nettool::blocks 3027 3029
+lappend ::nettool::blocks 3050 3050
+lappend ::nettool::blocks 3080 3080
+lappend ::nettool::blocks 3092 3092
+lappend ::nettool::blocks 3126 3126
+lappend ::nettool::blocks 3300 3301
+lappend ::nettool::blocks 3396 3396
+lappend ::nettool::blocks 3403 3404
+lappend ::nettool::blocks 3546 3546
+lappend ::nettool::blocks 3693 3694
+lappend ::nettool::blocks 3876 3876
+lappend ::nettool::blocks 3900 3900
+lappend ::nettool::blocks 3938 3938
+lappend ::nettool::blocks 3970 3970
+lappend ::nettool::blocks 3986 3986
+lappend ::nettool::blocks 3994 3994
+lappend ::nettool::blocks 4000 4000
+lappend ::nettool::blocks 4048 4048
+lappend ::nettool::blocks 4060 4060
+lappend ::nettool::blocks 4065 4065
+lappend ::nettool::blocks 4120 4120
+lappend ::nettool::blocks 4132 4133
+lappend ::nettool::blocks 4140 4140
+lappend ::nettool::blocks 4144 4144
+lappend ::nettool::blocks 4151 4152
+lappend ::nettool::blocks 4184 4184
+lappend ::nettool::blocks 4194 4198
+lappend ::nettool::blocks 4315 4315
+lappend ::nettool::blocks 4317 4319
+lappend ::nettool::blocks 4332 4332
+lappend ::nettool::blocks 4334 4339
+lappend ::nettool::blocks 4363 4367
+lappend ::nettool::blocks 4370 4370
+lappend ::nettool::blocks 4380 4388
+lappend ::nettool::blocks 4397 4399
+lappend ::nettool::blocks 4412 4424
+lappend ::nettool::blocks 4434 4440
+lappend ::nettool::blocks 4459 4483
+lappend ::nettool::blocks 4489 4499
+lappend ::nettool::blocks 4501 4501
+lappend ::nettool::blocks 4503 4533
+lappend ::nettool::blocks 4539 4544
+lappend ::nettool::blocks 4560 4562
+lappend ::nettool::blocks 4564 4565
+lappend ::nettool::blocks 4569 4569
+lappend ::nettool::blocks 4571 4589
+lappend ::nettool::blocks 4606 4657
+lappend ::nettool::blocks 4693 4699
+lappend ::nettool::blocks 4705 4724
+lappend ::nettool::blocks 4734 4736
+lappend ::nettool::blocks 4746 4746
+lappend ::nettool::blocks 4748 4748
+lappend ::nettool::blocks 4754 4783
+lappend ::nettool::blocks 4792 4799
+lappend ::nettool::blocks 4805 4826
+lappend ::nettool::blocks 4828 4836
+lappend ::nettool::blocks 4846 4846
+lappend ::nettool::blocks 4852 4866
+lappend ::nettool::blocks 4872 4875
+lappend ::nettool::blocks 4886 4893
+lappend ::nettool::blocks 4895 4898
+lappend ::nettool::blocks 4903 4911
+lappend ::nettool::blocks 4916 4935
+lappend ::nettool::blocks 4938 4939
+lappend ::nettool::blocks 4943 4948
+lappend ::nettool::blocks 4954 4968
+lappend ::nettool::blocks 4971 4983
+lappend ::nettool::blocks 4992 4998
+lappend ::nettool::blocks 5016 5019
+lappend ::nettool::blocks 5033 5041
+lappend ::nettool::blocks 5076 5077
+lappend ::nettool::blocks 5088 5089
+lappend ::nettool::blocks 5095 5098
+lappend ::nettool::blocks 5107 5110
+lappend ::nettool::blocks 5113 5113
+lappend ::nettool::blocks 5118 5119
+lappend ::nettool::blocks 5121 5132
+lappend ::nettool::blocks 5138 5145
+lappend ::nettool::blocks 5147 5149
+lappend ::nettool::blocks 5151 5151
+lappend ::nettool::blocks 5158 5160
+lappend ::nettool::blocks 5165 5165
+lappend ::nettool::blocks 5169 5171
+lappend ::nettool::blocks 5173 5189
+lappend ::nettool::blocks 5197 5199
+lappend ::nettool::blocks 5204 5208
+lappend ::nettool::blocks 5210 5214
+lappend ::nettool::blocks 5216 5220
+lappend ::nettool::blocks 5238 5244
+lappend ::nettool::blocks 5254 5263
+lappend ::nettool::blocks 5266 5268
+lappend ::nettool::blocks 5273 5279
+lappend ::nettool::blocks 5283 5297
+lappend ::nettool::blocks 5311 5311
+lappend ::nettool::blocks 5316 5316
+lappend ::nettool::blocks 5319 5319
+lappend ::nettool::blocks 5322 5342
+lappend ::nettool::blocks 5345 5348
+lappend ::nettool::blocks 5365 5396
+lappend ::nettool::blocks 5438 5442
+lappend ::nettool::blocks 5444 5444
+lappend ::nettool::blocks 5446 5452
+lappend ::nettool::blocks 5457 5460
+lappend ::nettool::blocks 5466 5499
+lappend ::nettool::blocks 5507 5552
+lappend ::nettool::blocks 5558 5565
+lappend ::nettool::blocks 5570 5572
+lappend ::nettool::blocks 5576 5578
+lappend ::nettool::blocks 5587 5596
+lappend ::nettool::blocks 5606 5617
+lappend ::nettool::blocks 5619 5626
+lappend ::nettool::blocks 5640 5645
+lappend ::nettool::blocks 5647 5669
+lappend ::nettool::blocks 5685 5686
+lappend ::nettool::blocks 5690 5692
+lappend ::nettool::blocks 5694 5695
+lappend ::nettool::blocks 5697 5712
+lappend ::nettool::blocks 5731 5740
+lappend ::nettool::blocks 5749 5749
+lappend ::nettool::blocks 5751 5754
+lappend ::nettool::blocks 5756 5756
+lappend ::nettool::blocks 5758 5765
+lappend ::nettool::blocks 5772 5776
+lappend ::nettool::blocks 5778 5779
+lappend ::nettool::blocks 5788 5792
+lappend ::nettool::blocks 5795 5812
+lappend ::nettool::blocks 5815 5840
+lappend ::nettool::blocks 5843 5858
+lappend ::nettool::blocks 5860 5862
+lappend ::nettool::blocks 5864 5867
+lappend ::nettool::blocks 5869 5882
+lappend ::nettool::blocks 5884 5899
+lappend ::nettool::blocks 5901 5909
+lappend ::nettool::blocks 5914 5962
+lappend ::nettool::blocks 5964 5967
+lappend ::nettool::blocks 5970 5983
+lappend ::nettool::blocks 5993 5998
+lappend ::nettool::blocks 6067 6067
+lappend ::nettool::blocks 6078 6080
+lappend ::nettool::blocks 6089 6098
+lappend ::nettool::blocks 6119 6120
+lappend ::nettool::blocks 6125 6129
+lappend ::nettool::blocks 6131 6132
+lappend ::nettool::blocks 6134 6139
+lappend ::nettool::blocks 6150 6158
+lappend ::nettool::blocks 6164 6199
+lappend ::nettool::blocks 6202 6221
+lappend ::nettool::blocks 6223 6240
+lappend ::nettool::blocks 6245 6250
+lappend ::nettool::blocks 6254 6266
+lappend ::nettool::blocks 6270 6299
+lappend ::nettool::blocks 6301 6305
+lappend ::nettool::blocks 6307 6314
+lappend ::nettool::blocks 6318 6319
+lappend ::nettool::blocks 6323 6323
+lappend ::nettool::blocks 6327 6342
+lappend ::nettool::blocks 6345 6345
+lappend ::nettool::blocks 6348 6349
+lappend ::nettool::blocks 6351 6354
+lappend ::nettool::blocks 6356 6359
+lappend ::nettool::blocks 6361 6362
+lappend ::nettool::blocks 6364 6369
+lappend ::nettool::blocks 6371 6381
+lappend ::nettool::blocks 6383 6388
+lappend ::nettool::blocks 6391 6399
+lappend ::nettool::blocks 6411 6416
+lappend ::nettool::blocks 6422 6431
+lappend ::nettool::blocks 6433 6441
+lappend ::nettool::blocks 6444 6445
+lappend ::nettool::blocks 6447 6454
+lappend ::nettool::blocks 6457 6470
+lappend ::nettool::blocks 6472 6479
+lappend ::nettool::blocks 6490 6499
+lappend ::nettool::blocks 6501 6508
+lappend ::nettool::blocks 6512 6512
+lappend ::nettool::blocks 6516 6542
+lappend ::nettool::blocks 6545 6546
+lappend ::nettool::blocks 6552 6557
+lappend ::nettool::blocks 6559 6565
+lappend ::nettool::blocks 6569 6578
+lappend ::nettool::blocks 6584 6599
+lappend ::nettool::blocks 6603 6618
+lappend ::nettool::blocks 6629 6631
+lappend ::nettool::blocks 6635 6639
+lappend ::nettool::blocks 6641 6652
+lappend ::nettool::blocks 6654 6654
+lappend ::nettool::blocks 6658 6664
+lappend ::nettool::blocks 6672 6677
+lappend ::nettool::blocks 6680 6686
+lappend ::nettool::blocks 6690 6695
+lappend ::nettool::blocks 6698 6700
+lappend ::nettool::blocks 6707 6713
+lappend ::nettool::blocks 6717 6766
+lappend ::nettool::blocks 6772 6776
+lappend ::nettool::blocks 6779 6783
+lappend ::nettool::blocks 6792 6800
+lappend ::nettool::blocks 6802 6816
+lappend ::nettool::blocks 6818 6830
+lappend ::nettool::blocks 6832 6840
+lappend ::nettool::blocks 6843 6849
+lappend ::nettool::blocks 6851 6867
+lappend ::nettool::blocks 6869 6887
+lappend ::nettool::blocks 6889 6900
+lappend ::nettool::blocks 6902 6934
+lappend ::nettool::blocks 6937 6945
+lappend ::nettool::blocks 6947 6950
+lappend ::nettool::blocks 6952 6960
+lappend ::nettool::blocks 6967 6968
+lappend ::nettool::blocks 6971 6996
+lappend ::nettool::blocks 7016 7017
+lappend ::nettool::blocks 7026 7029
+lappend ::nettool::blocks 7032 7039
+lappend ::nettool::blocks 7041 7069
+lappend ::nettool::blocks 7072 7072
+lappend ::nettool::blocks 7074 7079
+lappend ::nettool::blocks 7081 7094
+lappend ::nettool::blocks 7096 7098
+lappend ::nettool::blocks 7102 7106
+lappend ::nettool::blocks 7108 7120
+lappend ::nettool::blocks 7122 7127
+lappend ::nettool::blocks 7130 7160
+lappend ::nettool::blocks 7175 7180
+lappend ::nettool::blocks 7182 7199
+lappend ::nettool::blocks 7202 7226
+lappend ::nettool::blocks 7230 7234
+lappend ::nettool::blocks 7238 7261
+lappend ::nettool::blocks 7263 7271
+lappend ::nettool::blocks 7284 7299
+lappend ::nettool::blocks 7360 7364
+lappend ::nettool::blocks 7366 7390
+lappend ::nettool::blocks 7396 7396
+lappend ::nettool::blocks 7398 7399
+lappend ::nettool::blocks 7403 7409
+lappend ::nettool::blocks 7412 7420
+lappend ::nettool::blocks 7422 7425
+lappend ::nettool::blocks 7432 7436
+lappend ::nettool::blocks 7438 7442
+lappend ::nettool::blocks 7444 7470
+lappend ::nettool::blocks 7472 7472
+lappend ::nettool::blocks 7475 7490
+lappend ::nettool::blocks 7492 7499
+lappend ::nettool::blocks 7502 7507
+lappend ::nettool::blocks 7512 7541
+lappend ::nettool::blocks 7551 7559
+lappend ::nettool::blocks 7561 7562
+lappend ::nettool::blocks 7564 7565
+lappend ::nettool::blocks 7567 7568
+lappend ::nettool::blocks 7571 7573
+lappend ::nettool::blocks 7575 7587
+lappend ::nettool::blocks 7589 7623
+lappend ::nettool::blocks 7625 7625
+lappend ::nettool::blocks 7632 7632
+lappend ::nettool::blocks 7634 7647
+lappend ::nettool::blocks 7649 7671
+lappend ::nettool::blocks 7678 7679
+lappend ::nettool::blocks 7681 7688
+lappend ::nettool::blocks 7690 7696
+lappend ::nettool::blocks 7698 7699
+lappend ::nettool::blocks 7701 7706
+lappend ::nettool::blocks 7709 7719
+lappend ::nettool::blocks 7721 7723
+lappend ::nettool::blocks 7728 7733
+lappend ::nettool::blocks 7735 7737
+lappend ::nettool::blocks 7739 7740
+lappend ::nettool::blocks 7745 7746
+lappend ::nettool::blocks 7748 7776
+lappend ::nettool::blocks 7780 7780
+lappend ::nettool::blocks 7782 7785
+lappend ::nettool::blocks 7788 7788
+lappend ::nettool::blocks 7790 7793
+lappend ::nettool::blocks 7795 7796
+lappend ::nettool::blocks 7803 7809
+lappend ::nettool::blocks 7811 7844
+lappend ::nettool::blocks 7848 7868
+lappend ::nettool::blocks 7873 7877
+lappend ::nettool::blocks 7879 7879
+lappend ::nettool::blocks 7881 7886
+lappend ::nettool::blocks 7888 7899
+lappend ::nettool::blocks 7904 7912
+lappend ::nettool::blocks 7914 7931
+lappend ::nettool::blocks 7934 7961
+lappend ::nettool::blocks 7963 7966
+lappend ::nettool::blocks 7968 7978
+lappend ::nettool::blocks 7983 7996
+lappend ::nettool::blocks 8004 8004
+lappend ::nettool::blocks 8006 8007
+lappend ::nettool::blocks 8009 8018
+lappend ::nettool::blocks 8023 8024
+lappend ::nettool::blocks 8027 8031
+lappend ::nettool::blocks 8035 8039
+lappend ::nettool::blocks 8041 8041
+lappend ::nettool::blocks 8045 8050
+lappend ::nettool::blocks 8061 8065
+lappend ::nettool::blocks 8067 8073
+lappend ::nettool::blocks 8075 8079
+lappend ::nettool::blocks 8084 8085
+lappend ::nettool::blocks 8089 8090
+lappend ::nettool::blocks 8092 8096
+lappend ::nettool::blocks 8098 8099
+lappend ::nettool::blocks 8103 8114
+lappend ::nettool::blocks 8119 8120
+lappend ::nettool::blocks 8123 8127
+lappend ::nettool::blocks 8133 8139
+lappend ::nettool::blocks 8141 8147
+lappend ::nettool::blocks 8150 8152
+lappend ::nettool::blocks 8154 8159
+lappend ::nettool::blocks 8163 8180
+lappend ::nettool::blocks 8185 8190
+lappend ::nettool::blocks 8193 8193
+lappend ::nettool::blocks 8196 8198
+lappend ::nettool::blocks 8203 8203
+lappend ::nettool::blocks 8209 8229
+lappend ::nettool::blocks 8231 8242
+lappend ::nettool::blocks 8244 8275
+lappend ::nettool::blocks 8277 8279
+lappend ::nettool::blocks 8281 8291
+lappend ::nettool::blocks 8295 8299
+lappend ::nettool::blocks 8302 8312
+lappend ::nettool::blocks 8314 8319
+lappend ::nettool::blocks 8322 8350
+lappend ::nettool::blocks 8352 8375
+lappend ::nettool::blocks 8381 8382
+lappend ::nettool::blocks 8384 8399
+lappend ::nettool::blocks 8406 8414
+lappend ::nettool::blocks 8418 8441
+lappend ::nettool::blocks 8446 8449
+lappend ::nettool::blocks 8451 8456
+lappend ::nettool::blocks 8458 8469
+lappend ::nettool::blocks 8475 8499
+lappend ::nettool::blocks 8503 8553
+lappend ::nettool::blocks 8556 8566
+lappend ::nettool::blocks 8568 8599
+lappend ::nettool::blocks 8601 8608
+lappend ::nettool::blocks 8616 8664
+lappend ::nettool::blocks 8667 8674
+lappend ::nettool::blocks 8676 8685
+lappend ::nettool::blocks 8687 8687
+lappend ::nettool::blocks 8689 8698
+lappend ::nettool::blocks 8700 8710
+lappend ::nettool::blocks 8712 8731
+lappend ::nettool::blocks 8734 8749
+lappend ::nettool::blocks 8751 8762
+lappend ::nettool::blocks 8767 8769
+lappend ::nettool::blocks 8771 8777
+lappend ::nettool::blocks 8779 8785
+lappend ::nettool::blocks 8788 8792
+lappend ::nettool::blocks 8794 8799
+lappend ::nettool::blocks 8801 8803
+lappend ::nettool::blocks 8805 8872
+lappend ::nettool::blocks 8874 8879
+lappend ::nettool::blocks 8882 8882
+lappend ::nettool::blocks 8884 8887
+lappend ::nettool::blocks 8895 8898
+lappend ::nettool::blocks 8902 8909
+lappend ::nettool::blocks 8914 8936
+lappend ::nettool::blocks 8938 8952
+lappend ::nettool::blocks 8955 8988
+lappend ::nettool::blocks 8992 8997
+lappend ::nettool::blocks 9003 9006
+lappend ::nettool::blocks 9011 9019
+lappend ::nettool::blocks 9027 9049
+lappend ::nettool::blocks 9052 9079
+lappend ::nettool::blocks 9081 9081
+lappend ::nettool::blocks 9094 9099
+lappend ::nettool::blocks 9108 9118
+lappend ::nettool::blocks 9120 9121
+lappend ::nettool::blocks 9124 9130
+lappend ::nettool::blocks 9132 9159
+lappend ::nettool::blocks 9165 9190
+lappend ::nettool::blocks 9192 9199
+lappend ::nettool::blocks 9218 9221
+lappend ::nettool::blocks 9223 9254
+lappend ::nettool::blocks 9256 9276
+lappend ::nettool::blocks 9288 9291
+lappend ::nettool::blocks 9296 9299
+lappend ::nettool::blocks 9301 9305
+lappend ::nettool::blocks 9307 9311
+lappend ::nettool::blocks 9313 9317
+lappend ::nettool::blocks 9319 9320
+lappend ::nettool::blocks 9322 9342
+lappend ::nettool::blocks 9345 9345
+lappend ::nettool::blocks 9347 9373
+lappend ::nettool::blocks 9375 9379
+lappend ::nettool::blocks 9381 9386
+lappend ::nettool::blocks 9391 9395
+lappend ::nettool::blocks 9398 9399
+lappend ::nettool::blocks 9403 9417
+lappend ::nettool::blocks 9419 9442
+lappend ::nettool::blocks 9446 9449
+lappend ::nettool::blocks 9451 9499
+lappend ::nettool::blocks 9501 9521
+lappend ::nettool::blocks 9523 9534
+lappend ::nettool::blocks 9537 9554
+lappend ::nettool::blocks 9556 9591
+lappend ::nettool::blocks 9601 9611
+lappend ::nettool::blocks 9613 9613
+lappend ::nettool::blocks 9615 9615
+lappend ::nettool::blocks 9619 9627
+lappend ::nettool::blocks 9633 9639
+lappend ::nettool::blocks 9641 9665
+lappend ::nettool::blocks 9669 9693
+lappend ::nettool::blocks 9696 9699
+lappend ::nettool::blocks 9701 9746
+lappend ::nettool::blocks 9748 9749
+lappend ::nettool::blocks 9751 9752
+lappend ::nettool::blocks 9754 9761
+lappend ::nettool::blocks 9763 9799
+lappend ::nettool::blocks 9803 9874
+lappend ::nettool::blocks 9877 9877
+lappend ::nettool::blocks 9879 9887
+lappend ::nettool::blocks 9890 9897
+lappend ::nettool::blocks 9904 9908
+lappend ::nettool::blocks 9910 9910
+lappend ::nettool::blocks 9912 9924
+lappend ::nettool::blocks 9926 9949
+lappend ::nettool::blocks 9957 9965
+lappend ::nettool::blocks 9967 9977
+lappend ::nettool::blocks 9979 9986
+lappend ::nettool::blocks 9989 9989
+lappend ::nettool::blocks 10003 10003
+lappend ::nettool::blocks 10011 10022
+lappend ::nettool::blocks 10024 10049
+lappend ::nettool::blocks 10052 10054
+lappend ::nettool::blocks 10056 10079
+lappend ::nettool::blocks 10082 10099
+lappend ::nettool::blocks 10105 10106
+lappend ::nettool::blocks 10108 10109
+lappend ::nettool::blocks 10112 10112
+lappend ::nettool::blocks 10118 10127
+lappend ::nettool::blocks 10130 10159
+lappend ::nettool::blocks 10163 10199
+lappend ::nettool::blocks 10202 10251
+lappend ::nettool::blocks 10253 10259
+lappend ::nettool::blocks 10261 10287
+lappend ::nettool::blocks 10289 10320
+lappend ::nettool::blocks 10322 10438
+lappend ::nettool::blocks 10440 10499
+lappend ::nettool::blocks 10501 10539
+lappend ::nettool::blocks 10545 10630
+lappend ::nettool::blocks 10632 10799
+lappend ::nettool::blocks 10801 10804
+lappend ::nettool::blocks 10806 10808
+lappend ::nettool::blocks 10811 10859
+lappend ::nettool::blocks 10861 10879
+lappend ::nettool::blocks 10881 10989
+lappend ::nettool::blocks 10991 10999
+lappend ::nettool::blocks 11002 11094
+lappend ::nettool::blocks 11096 11102
+lappend ::nettool::blocks 11107 11107
+lappend ::nettool::blocks 11113 11160
+lappend ::nettool::blocks 11166 11170
+lappend ::nettool::blocks 11176 11200
+lappend ::nettool::blocks 11203 11207
+lappend ::nettool::blocks 11209 11210
+lappend ::nettool::blocks 11212 11318
+lappend ::nettool::blocks 11322 11366
+lappend ::nettool::blocks 11368 11370
+lappend ::nettool::blocks 11372 11429
+lappend ::nettool::blocks 11431 11488
+lappend ::nettool::blocks 11490 11599
+lappend ::nettool::blocks 11601 11622
+lappend ::nettool::blocks 11624 11719
+lappend ::nettool::blocks 11721 11722
+lappend ::nettool::blocks 11724 11750
+lappend ::nettool::blocks 11752 11795
+lappend ::nettool::blocks 11797 11875
+lappend ::nettool::blocks 11878 11966
+lappend ::nettool::blocks 11968 11996
+lappend ::nettool::blocks 12011 12011
+lappend ::nettool::blocks 12014 12108
+lappend ::nettool::blocks 12110 12120
+lappend ::nettool::blocks 12122 12167
+lappend ::nettool::blocks 12169 12171
+lappend ::nettool::blocks 12173 12299
+lappend ::nettool::blocks 12301 12301
+lappend ::nettool::blocks 12303 12320
+lappend ::nettool::blocks 12323 12344
+lappend ::nettool::blocks 12346 12752
+lappend ::nettool::blocks 12754 12864
+lappend ::nettool::blocks 12866 13159
+lappend ::nettool::blocks 13161 13215
+lappend ::nettool::blocks 13219 13222
+lappend ::nettool::blocks 13225 13399
+lappend ::nettool::blocks 13401 13719
+lappend ::nettool::blocks 13723 13723
+lappend ::nettool::blocks 13725 13781
+lappend ::nettool::blocks 13784 13784
+lappend ::nettool::blocks 13787 13817
+lappend ::nettool::blocks 13824 13893
+lappend ::nettool::blocks 13895 13928
+lappend ::nettool::blocks 13931 13999
+lappend ::nettool::blocks 14003 14032
+lappend ::nettool::blocks 14035 14140
+lappend ::nettool::blocks 14143 14144
+lappend ::nettool::blocks 14146 14148
+lappend ::nettool::blocks 14151 14153
+lappend ::nettool::blocks 14155 14249
+lappend ::nettool::blocks 14251 14413
+lappend ::nettool::blocks 14415 14935
+lappend ::nettool::blocks 14938 14999
+lappend ::nettool::blocks 15001 15001
+lappend ::nettool::blocks 15003 15117
+lappend ::nettool::blocks 15119 15344
+lappend ::nettool::blocks 15346 15362
+lappend ::nettool::blocks 15364 15554
+lappend ::nettool::blocks 15556 15659
+lappend ::nettool::blocks 15661 15739
+lappend ::nettool::blocks 15741 15997
+lappend ::nettool::blocks 16004 16019
+lappend ::nettool::blocks 16022 16160
+lappend ::nettool::blocks 16163 16308
+lappend ::nettool::blocks 16312 16359
+lappend ::nettool::blocks 16362 16366
+lappend ::nettool::blocks 16369 16383
+lappend ::nettool::blocks 16385 16618
+lappend ::nettool::blocks 16620 16664
+lappend ::nettool::blocks 16667 16899
+lappend ::nettool::blocks 16901 16949
+lappend ::nettool::blocks 16951 16990
+lappend ::nettool::blocks 16996 17006
+lappend ::nettool::blocks 17008 17183
+lappend ::nettool::blocks 17186 17218
+lappend ::nettool::blocks 17223 17233
+lappend ::nettool::blocks 17236 17499
+lappend ::nettool::blocks 17501 17554
+lappend ::nettool::blocks 17556 17728
+lappend ::nettool::blocks 17730 17753
+lappend ::nettool::blocks 17757 17776
+lappend ::nettool::blocks 17778 17999
+lappend ::nettool::blocks 18001 18103
+lappend ::nettool::blocks 18105 18135
+lappend ::nettool::blocks 18137 18180
+lappend ::nettool::blocks 18188 18240
+lappend ::nettool::blocks 18244 18261
+lappend ::nettool::blocks 18263 18462
+lappend ::nettool::blocks 18464 18633
+lappend ::nettool::blocks 18636 18768
+lappend ::nettool::blocks 18770 18880
+lappend ::nettool::blocks 18882 18887
+lappend ::nettool::blocks 18889 18999
+lappend ::nettool::blocks 19001 19006
+lappend ::nettool::blocks 19008 19019
+lappend ::nettool::blocks 19021 19190
+lappend ::nettool::blocks 19192 19193
+lappend ::nettool::blocks 19195 19282
+lappend ::nettool::blocks 19284 19314
+lappend ::nettool::blocks 19316 19397
+lappend ::nettool::blocks 19399 19409
+lappend ::nettool::blocks 19413 19538
+lappend ::nettool::blocks 19542 19787
+lappend ::nettool::blocks 19789 19997
+lappend ::nettool::blocks 20004 20004
+lappend ::nettool::blocks 20006 20011
+lappend ::nettool::blocks 20015 20045
+lappend ::nettool::blocks 20047 20047
+lappend ::nettool::blocks 20050 20166
+lappend ::nettool::blocks 20168 20201
+lappend ::nettool::blocks 20203 20221
+lappend ::nettool::blocks 20223 20479
+lappend ::nettool::blocks 20481 20669
+lappend ::nettool::blocks 20671 20998
+lappend ::nettool::blocks 21001 21009
+lappend ::nettool::blocks 21011 21552
+lappend ::nettool::blocks 21555 21589
+lappend ::nettool::blocks 21591 21799
+lappend ::nettool::blocks 21801 21844
+lappend ::nettool::blocks 21850 21999
+lappend ::nettool::blocks 22006 22124
+lappend ::nettool::blocks 22126 22127
+lappend ::nettool::blocks 22129 22221
+lappend ::nettool::blocks 22223 22272
+lappend ::nettool::blocks 22274 22304
+lappend ::nettool::blocks 22306 22342
+lappend ::nettool::blocks 22344 22346
+lappend ::nettool::blocks 22348 22349
+lappend ::nettool::blocks 22352 22536
+lappend ::nettool::blocks 22538 22554
+lappend ::nettool::blocks 22556 22762
+lappend ::nettool::blocks 22764 22799
+lappend ::nettool::blocks 22801 22950
+lappend ::nettool::blocks 22952 22999
+lappend ::nettool::blocks 23006 23052
+lappend ::nettool::blocks 23054 23271
+lappend ::nettool::blocks 23273 23332
+lappend ::nettool::blocks 23334 23399
+lappend ::nettool::blocks 23403 23455
+lappend ::nettool::blocks 23458 23545
+lappend ::nettool::blocks 23547 23999
+lappend ::nettool::blocks 24007 24241
+lappend ::nettool::blocks 24243 24248
+lappend ::nettool::blocks 24250 24320
+lappend ::nettool::blocks 24323 24464
+lappend ::nettool::blocks 24466 24553
+lappend ::nettool::blocks 24555 24576
+lappend ::nettool::blocks 24578 24675
+lappend ::nettool::blocks 24679 24679
+lappend ::nettool::blocks 24681 24753
+lappend ::nettool::blocks 24755 24849
+lappend ::nettool::blocks 24851 24921
+lappend ::nettool::blocks 24923 24999
+lappend ::nettool::blocks 25010 25470
+lappend ::nettool::blocks 25472 25575
+lappend ::nettool::blocks 25577 25603
+lappend ::nettool::blocks 25605 25792
+lappend ::nettool::blocks 25794 25899
+lappend ::nettool::blocks 25904 25953
+lappend ::nettool::blocks 25956 25999
+lappend ::nettool::blocks 26001 26132
+lappend ::nettool::blocks 26134 26207
+lappend ::nettool::blocks 26209 26259
+lappend ::nettool::blocks 26264 26485
+lappend ::nettool::blocks 26488 26488
+lappend ::nettool::blocks 26490 26999
+lappend ::nettool::blocks 27010 27344
+lappend ::nettool::blocks 27346 27441
+lappend ::nettool::blocks 27443 27503
+lappend ::nettool::blocks 27505 27781
+lappend ::nettool::blocks 27783 27875
+lappend ::nettool::blocks 27877 27998
+lappend ::nettool::blocks 28002 28118
+lappend ::nettool::blocks 28120 28199
+lappend ::nettool::blocks 28201 28239
+lappend ::nettool::blocks 28241 29117
+lappend ::nettool::blocks 29119 29166
+lappend ::nettool::blocks 29170 29998
+lappend ::nettool::blocks 30005 30259
+lappend ::nettool::blocks 30261 30831
+lappend ::nettool::blocks 30833 30998
+lappend ::nettool::blocks 31000 31019
+lappend ::nettool::blocks 31021 31028
+lappend ::nettool::blocks 31030 31399
+lappend ::nettool::blocks 31401 31415
+lappend ::nettool::blocks 31417 31456
+lappend ::nettool::blocks 31458 31619
+lappend ::nettool::blocks 31621 31684
+lappend ::nettool::blocks 31686 31764
+lappend ::nettool::blocks 31766 32033
+lappend ::nettool::blocks 32035 32248
+lappend ::nettool::blocks 32250 32482
+lappend ::nettool::blocks 32484 32634
+lappend ::nettool::blocks 32637 32766
+lappend ::nettool::blocks 32778 32800
+lappend ::nettool::blocks 32802 32810
+lappend ::nettool::blocks 32812 32895
+lappend ::nettool::blocks 32897 33122
+lappend ::nettool::blocks 33124 33330
+lappend ::nettool::blocks 33332 33332
+lappend ::nettool::blocks 33335 33433
+lappend ::nettool::blocks 33435 33655
+lappend ::nettool::blocks 33657 34248
+lappend ::nettool::blocks 34250 34377
+lappend ::nettool::blocks 34380 34566
+lappend ::nettool::blocks 34568 34961
+lappend ::nettool::blocks 34965 34979
+lappend ::nettool::blocks 34981 34999
+lappend ::nettool::blocks 35007 35353
+lappend ::nettool::blocks 35358 36000
+lappend ::nettool::blocks 36002 36411
+lappend ::nettool::blocks 36413 36421
+lappend ::nettool::blocks 36423 36442
+lappend ::nettool::blocks 36445 36523
+lappend ::nettool::blocks 36525 36601
+lappend ::nettool::blocks 36603 36699
+lappend ::nettool::blocks 36701 36864
+lappend ::nettool::blocks 36866 37474
+lappend ::nettool::blocks 37476 37482
+lappend ::nettool::blocks 37484 37653
+lappend ::nettool::blocks 37655 37999
+lappend ::nettool::blocks 38002 38200
+lappend ::nettool::blocks 38204 38799
+lappend ::nettool::blocks 38801 38864
+lappend ::nettool::blocks 38866 39680
+lappend ::nettool::blocks 39682 39999
+lappend ::nettool::blocks 40001 40403
+lappend ::nettool::blocks 40405 40840
+lappend ::nettool::blocks 40844 40852
+lappend ::nettool::blocks 40854 41110
+lappend ::nettool::blocks 41112 41120
+lappend ::nettool::blocks 41122 41793
+lappend ::nettool::blocks 41798 42507
+lappend ::nettool::blocks 42511 42999
+lappend ::nettool::blocks 43001 44320
+lappend ::nettool::blocks 44323 44443
+lappend ::nettool::blocks 44445 44543
+lappend ::nettool::blocks 44545 44552
+lappend ::nettool::blocks 44554 44599
+lappend ::nettool::blocks 44601 44899
+lappend ::nettool::blocks 44901 44999
+lappend ::nettool::blocks 45002 45044
+lappend ::nettool::blocks 45046 45053
+lappend ::nettool::blocks 45055 45677
+lappend ::nettool::blocks 45679 45823
+lappend ::nettool::blocks 45826 45965
+lappend ::nettool::blocks 45967 46997
+lappend ::nettool::blocks 47002 47099
+lappend ::nettool::blocks 47101 47556
+lappend ::nettool::blocks 47558 47623
+lappend ::nettool::blocks 47625 47805
+lappend ::nettool::blocks 47807 47807
+lappend ::nettool::blocks 47810 47999
+lappend ::nettool::blocks 48006 48048
+lappend ::nettool::blocks 48051 48127
+lappend ::nettool::blocks 48130 48555
+lappend ::nettool::blocks 48557 48618
+lappend ::nettool::blocks 48620 48652
+lappend ::nettool::blocks 48654 48999
+lappend ::nettool::blocks 49001 65535
+
diff --git a/tcllib/modules/nettool/generic.tcl b/tcllib/modules/nettool/generic.tcl
new file mode 100644
index 0000000..5949b76
--- /dev/null
+++ b/tcllib/modules/nettool/generic.tcl
@@ -0,0 +1,98 @@
+::namespace eval ::nettool {}
+
+###
+# topic: 825cd25953c2cc896a96006b7f454e00
+# title: Return pairings of MAC numbers to IP addresses on the local network
+###
+proc ::nettool::arp_table {} {}
+
+###
+# topic: 92ebbfa155883ad41c37d3f843392be4
+# title: Return list of broadcast addresses for local networks
+###
+proc ::nettool::broadcast_list {} {
+ return 127.0.0.1
+}
+
+###
+# topic: 15d9bc96ec6ce31d4c8f99a425a9c02c
+# description: Return Processor utilization
+###
+proc ::nettool::busy {} {}
+
+###
+# topic: 187cfa1827097c5cdf1c40c656cedfcc
+# description: Return time since booted
+###
+proc ::nettool::cpuinfo {} {}
+
+###
+# topic: 58295f2544f43827e855d09dc3ee625a
+###
+proc ::nettool::diskless_client {} {
+ return 0
+}
+
+###
+# topic: 57fdc331bc60c7bf2bd3f3214e9a906f
+###
+proc ::nettool::hwaddr_to_ipaddr {hwaddr args} {}
+
+###
+# topic: dd2e2c0810cea69909399808f2a68949
+# title: Return a list of unique hardware ids
+###
+proc ::nettool::hwid_list {} {
+ set result {}
+ foreach mac [::nettool::mac_list] {
+ lappend result 0x[string map {: {}} $mac]
+ }
+ if {[llength $result]} {
+ return $result
+ }
+ return 0x010203040506
+}
+
+###
+# topic: 4b87d977492bd10802bfc0327cd07ac2
+# title: Return list of network interfaces
+###
+proc ::nettool::if_list {} {}
+
+###
+# topic: d2932eb0ea8cc9f6a865c1ab7cdd4572
+# description:
+# Called on package load to build any static
+# structures to cache data that would be time
+# consuming to call on the fly
+###
+proc ::nettool::init {} {}
+
+###
+# topic: 417672d3f31b80d749588365af88baf6
+# title: Return list of ip addresses for this computer (primary first)
+###
+proc ::nettool::ip_list {} {}
+
+###
+# topic: ac9d6815d47f60d45930f0c8c8ae8f16
+# title: Return list of mac numbers for this computer (primary first)
+###
+proc ::nettool::mac_list {} {}
+
+###
+# topic: c42343f20e3afd2884a5dd1c219e4415
+###
+proc ::nettool::platform {} {
+ variable platform
+ return $platform
+}
+
+proc ::nettool::user_data_root {appname} {
+ return [file join $::env(HOME) .$appname]
+}
+
+###
+# Provide empty implementations
+###
+
diff --git a/tcllib/modules/nettool/locateport.tcl b/tcllib/modules/nettool/locateport.tcl
new file mode 100644
index 0000000..96a3638
--- /dev/null
+++ b/tcllib/modules/nettool/locateport.tcl
@@ -0,0 +1,75 @@
+::namespace eval ::nettool {}
+
+###
+# topic: fc6f8b9587dd5524f143f9df4be4755b63eb6cd5
+###
+proc ::nettool::allocate_port startingport {
+ foreach {start end} $::nettool::blocks {
+ if { $end <= $startingport } continue
+ if { $start > $startingport } {
+ set i $start
+ } else {
+ set i $startingport
+ }
+ for {} {$i <= $end} {incr i} {
+ if {[string is true -strict [get ::nettool::used_ports($i)]]} continue
+ if {[catch {socket -server NOOP $i} chan]} continue
+ close $chan
+ set ::nettool::used_ports($i) 1
+ return $i
+ }
+ }
+ error "Could not locate a port"
+}
+
+###
+# topic: 3286fdbd0a3fdebbb26414475754bcf3dea67b0f
+###
+proc ::nettool::claim_port {port {protocol tcp}} {
+ set ::nettool::used_ports($port) 1
+}
+
+###
+# topic: 1d1f8a65a9aef8765c9b4f2b0ee0ebaf42e99d46
+###
+proc ::nettool::find_port startingport {
+ foreach {start end} $::nettool::blocks {
+ if { $end <= $startingport } continue
+ if { $start > $startingport } {
+ set i $start
+ } else {
+ set i $startingport
+ }
+ for {} {$i <= $end} {incr i} {
+ if {[string is true -strict [get ::nettool::used_ports($i)]]} continue
+ return $i
+ }
+ }
+ error "Could not locate a port"
+}
+
+###
+# topic: ded1c51260e009effb1f77044f8d0dec3d030b91
+###
+proc ::nettool::port_busy port {
+ ###
+ # Check our private list of used ports
+ ###
+ if {[string is true -strict [get ::nettool::used_ports($port)]]} {
+ return 1
+ }
+ foreach {start end} $::nettool::blocks {
+ if { $port >= $start && $port <= $end } {
+ return 0
+ }
+ }
+ return 1
+}
+
+###
+# topic: b5407b084aa09f9efa4f58a337af6186418fddf2
+###
+proc ::nettool::release_port {port {protocol tcp}} {
+ set ::nettool::used_ports($port) 0
+}
+
diff --git a/tcllib/modules/nettool/nettool.man b/tcllib/modules/nettool/nettool.man
new file mode 100644
index 0000000..61492e5
--- /dev/null
+++ b/tcllib/modules/nettool/nettool.man
@@ -0,0 +1,143 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset PACKAGE_VERSION 0.5.1]
+[manpage_begin nettool n [vset PACKAGE_VERSION]]
+[keywords {nettool}]
+[keywords {odie}]
+[copyright {2015 Sean Woods <yoda@etoyoc.com>}]
+[moddesc {nettool}]
+[titledesc {Tools for networked applications}]
+[category System]
+[require Tcl 8.5]
+[require nettool [opt [vset PACKAGE_VERSION]]]
+[require twapi 3.1]
+[require ip 0.1]
+[require platform 0.1]
+[description]
+[para]
+
+The [package nettool] package consists of a Pure-tcl set of tools
+to perform common network functions that would normally require
+different packages or calls to exec, in a standard Tcl interface.
+
+At present nettool has reference implementations for the following operating
+systems: Windows, MacOSX, and Linux (debian).
+
+[section Commands]
+[list_begin definitions]
+
+[call [cmd ::cat] [arg filename]]
+
+Dump the contents of a file as a result.
+
+[call [cmd ::nettool::allocate_port] [arg startingport]]
+
+Attempt to allocate [arg startingport], or, if busy, advance the port
+number sequentially until a free port is found, and claim that port.
+
+This command uses a built-in database of known ports to avoid returning a
+port which is in common use. (For example: http (80))
+
+[call [cmd ::nettool::arp_table]]
+
+Dump the contents of this computer's Address Resolution Protocol (ARP) table.
+The result will be a Tcl formatted list: [arg macid] [arg ipaddrlist] ...
+
+[call [cmd ::nettool::broadcast_list]]
+
+Returns a list of broadcast addresses (suitable for UDP multicast)
+that this computer is associated with.
+
+[call [cmd ::nettool::claim_port] [arg port] [opt [arg protocol]]]
+
+Mark [arg port] as busy, optionally as either [const tcp] (default) or [const udp].
+
+[call [cmd ::nettool::cpuinfo] [arg args]]
+
+If no arguments are given, return a key/value list describing the
+CPU of the present machine. Included in the matrix is info on the number
+of cores/processors that are available for parallel tasking, installed physical
+RAM, and processor family.
+[para]
+The exact contents are platform specific.
+[para]
+For Linux, information is drawn from /proc/cpuinfo and /proc/meminfo.
+[para]
+For MacOSX, information is drawn from sysctl
+[para]
+For Windows, information is draw from TWAPI.
+[para]
+If arguments are given, the result with be a key/value list limited to the
+fields requested.
+[para]
+Canonical fields for all platforms:
+[list_begin definitions][comment {-- cpuinfofields}]
+[def cpus] Count of CPUs/cores/execution units
+[def speed] Clock speed of processor(s) in Mhz
+[def memory] Installed RAM (in MB)
+[def vendor] Manufacturer
+[list_end]
+
+[call [cmd ::nettool::find_port] [arg startingport]]
+
+Return [arg startingport] if it is available, or the next free port after
+[arg startingport]. Note: Unlike [cmd ::nettool::allocate_port], this
+command does not claim the port.
+[para]
+This command uses a built-in database of known ports to avoid returning a
+port which is in common use. (For example: http (80))
+
+[call [cmd ::nettool::hwid_list]]
+
+Return a list of hardware specific identifiers from this computer. The source
+and content will vary by platform.
+[para]
+For MacOSX, the motherboard serial number and macids for all network devices is returned.
+[para]
+For Windows, the volume serial number of C and macids for all network devices is returned.
+[para]
+For Linux, macids for all network devices is returned.
+
+[call [cmd ::nettool::ip_list]]
+
+Return a list of IP addresses associated with this computer.
+
+[call [cmd ::nettool::mac_list]]
+
+Return a list of MACIDs for the network cards attached to this machine. The MACID of the
+primary network card is returned first.
+
+[call [cmd ::nettool::network_list]]
+
+Return a list of networks associated with this computer. Networks are formated with
+[cmd ip::nativeToPrefix].
+
+[call [cmd ::nettool::port_busy] [arg port]]
+
+Return true if [arg port] is claimed, false otherwise.
+
+[call [cmd ::nettool::release_port] [arg port] [opt [arg protocol]]]
+
+Mark [arg port] as not busy, optionally as either [const tcp] (default) or [const udp].
+
+[call [cmd ::nettool::status]]
+
+Return a key/value list describing the status of the computer. The output
+is designed to be comparable to the output of [cmd top] for all platforms.
+[para]
+Common fields include:
+[list_begin definitions][comment {-- statusfields}]
+[def load] Processes per processing unit
+[def memory_total] Total physical RAM (MB)
+[def memory_free] Total physical RAM unused (MB)
+[list_end]
+
+[call [cmd ::nettool::user_data_root] [arg appname]]
+
+Return a fully qualified path to a folder where [arg appname] should store it's data.
+The path is not created, only computed, by this command.
+
+[list_end]
+[para]
+[vset CATEGORY odie]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/nettool/nettool.tcl b/tcllib/modules/nettool/nettool.tcl
new file mode 100644
index 0000000..5e006d1
--- /dev/null
+++ b/tcllib/modules/nettool/nettool.tcl
@@ -0,0 +1,72 @@
+# @mdgen OWNER: generic.tcl
+# @mdgen OWNER: available_ports.tcl
+# @mdgen OWNER: locateport.tcl
+# @mdgen OWNER: platform_unix_linux.tcl
+# @mdgen OWNER: platform_unix_macosx.tcl
+# @mdgen OWNER: platform_unix.tcl
+# @mdgen OWNER: platform_windows.tcl
+
+
+package require platform
+# Uses the "ip" package from tcllib
+package require ip
+
+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 commands ::get] eq {}} {
+ proc ::get varname {
+ upvar 1 $varname var
+ if {[info exists var]} {
+ return [set var]
+ }
+ return {}
+ }
+}
+if {[info commands ::cat] eq {}} {
+ proc ::cat filename {
+ set fin [open $filename r]
+ set dat [read $fin]
+ close $fin
+ return $dat
+ }
+}
+
+
+set here [file dirname [file normalize [info script]]]
+
+::namespace eval ::nettool {}
+
+set genus [lindex [split [::platform::generic] -] 0]
+dict set ::nettool::platform tcl_os $::tcl_platform(os)
+dict set ::nettool::platform odie_class $::tcl_platform(platform)
+dict set ::nettool::platform odie_genus $genus
+dict set ::nettool::platform odie_target [::platform::generic]
+dict set ::nettool::platform odie_species [::platform::identify]
+
+source [file join $here generic.tcl]
+source [file join $here available_ports.tcl]
+source [file join $here locateport.tcl]
+
+set platfile [file join $here platform_$::tcl_platform(platform).tcl]
+if {[file exists $platfile]} {
+ source $platfile
+}
+set genfile [file join $here platform_$::tcl_platform(platform)_$genus.tcl]
+if {[file exists $genfile]} {
+ source $genfile
+}
+
+::nettool::init
+package provide nettool 0.5.1
+
diff --git a/tcllib/modules/nettool/nettool.test b/tcllib/modules/nettool/nettool.test
new file mode 100644
index 0000000..384bb2e
--- /dev/null
+++ b/tcllib/modules/nettool/nettool.test
@@ -0,0 +1,101 @@
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+package require tcltest
+testsNeedTcl 8.5
+testsNeedTcltest 1.0
+
+testing {
+ useLocal nettool.tcl nettool
+}
+
+# Test known busy ports
+foreach port {
+ 80
+ 3020
+ 21
+ 7794
+} {
+ ::tcltest::test port-busy-$port \
+ "Test that port busy returns true for known port $port" \
+ [list ::nettool::port_busy $port] 1
+}
+
+# Test known free ports
+# And test the full range at 7790-7792 to ensure there
+# are now edge cases at the start and end of a range
+foreach port {
+ 1028
+ 2446
+ 7790 7791 7792 7792
+} {
+ ::tcltest::test port-free-$port \
+ "Test that port busy returns false for known port $port" \
+ [list ::nettool::port_busy $port] 0
+}
+
+# Test that "next" for block 7790 return 7790
+::tcltest::test port-find-0001 \
+ "Test that port find returns the first port in unclaimed block starting at 7790" \
+ [list ::nettool::find_port 7790] 7790
+
+foreach {port nextport comment} {
+ 7790 7791 {Start of block}
+ 7791 7792 {...}
+ 7792 7793 {End of block}
+ 7793 7795 {Start of new block}
+} {
+ ::nettool::claim_port $port
+ ::tcltest::test port-claim-0001 \
+ "Test that port busy returns true after $port is claimed" \
+ [list ::nettool::port_busy $port] 1
+
+ # Test that claiming a port makes it busy
+ ::tcltest::test port-find-0002 \
+ "Test that port find returns the next port in unclaimed block starting at $port following claim" \
+ [list ::nettool::find_port $port] $nextport
+
+}
+
+set port 7790
+::nettool::claim_port $port
+::tcltest::test port-claim-0002 \
+ "Test that port busy returns true after $port is claimed" \
+ [list ::nettool::port_busy $port] 1
+::nettool::release_port $port
+::tcltest::test port-claim-0003 \
+ "Test that port busy returns false after $port is release" \
+ [list ::nettool::port_busy $port] 0
+
+# Test that claiming a port makes it busy
+::tcltest::test port-find-0004 \
+ "Test that port find returns the next port in released block starting at $port following claim" \
+ [list ::nettool::find_port 7790] 7790
+
+foreach {port nextport comment} {
+ 7790 7791 {Start of block}
+ 7791 7792 {...}
+ 7792 7793 {End of block}
+ 7793 7795 {Start of new block}
+} {
+ ::nettool::release_port $port
+}
+
+# Test that claiming a port makes it busy
+::tcltest::test port-allocate-0004 \
+ "Test allocate port returns the address of an unclaimed spot and claims it" \
+ [list ::nettool::allocate_port 7790] 7790
+
+::tcltest::test port-allocate-0005 \
+ "Test allocate port returns the next address of an claimed spot and claims it" \
+ [list ::nettool::allocate_port 7790] 7791
+
+::tcltest::test port-allocate-0006 \
+ "Test allocate port returns the next address of an claimed spot and claims it" \
+ [list ::nettool::allocate_port 7790] 7792
+
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/nettool/pkgIndex.tcl b/tcllib/modules/nettool/pkgIndex.tcl
new file mode 100644
index 0000000..675c35c
--- /dev/null
+++ b/tcllib/modules/nettool/pkgIndex.tcl
@@ -0,0 +1,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 nettool 0.5.1 [list source [file join $dir nettool.tcl]]
diff --git a/tcllib/modules/nettool/platform_unix.tcl b/tcllib/modules/nettool/platform_unix.tcl
new file mode 100644
index 0000000..e7807bb
--- /dev/null
+++ b/tcllib/modules/nettool/platform_unix.tcl
@@ -0,0 +1,23 @@
+###
+# Generic answers that can be answered on most if not all unix platforms
+###
+
+::namespace eval ::nettool {}
+
+###
+# topic: 825cd25953c2cc896a96006b7f454e00
+# title: Return pairings of MAC numbers to IP addresses on the local network
+# description: Under unix, we call the arp command for arp table resolution
+###
+proc ::nettool::arp_table {} {
+ set result {}
+ set dat [exec arp -a]
+ foreach line [split $dat \n] {
+ set host [lindex $line 0]
+ set ip [lindex $line 1]
+ set macid [lindex $line 3]
+ lappend result $macid [string range $ip 1 end-1]
+ }
+ return $result
+}
+
diff --git a/tcllib/modules/nettool/platform_unix_linux.tcl b/tcllib/modules/nettool/platform_unix_linux.tcl
new file mode 100644
index 0000000..ef143f6
--- /dev/null
+++ b/tcllib/modules/nettool/platform_unix_linux.tcl
@@ -0,0 +1,224 @@
+::namespace eval ::nettool {}
+
+###
+# topic: 92ebbfa155883ad41c37d3f843392be4
+# title: Return list of broadcast addresses for local networks
+###
+proc ::nettool::broadcast_list {} {
+ set result {}
+ lappend result 127.0.0.1
+ foreach {iface info} [dump] {
+ if {[dict exists $info ipv4 Bcast:]} {
+ lappend result [dict get $info ipv4 Bcast:]
+ }
+ }
+ return [lsort -unique -dictionary $result]
+}
+
+###
+# topic: 187cfa1827097c5cdf1c40c656cedfcc
+# description: Return time since booted
+###
+proc ::nettool::cpuinfo args {
+ variable cpuinfo
+ if {![info exists cpuinfo]} {
+ set cpuinfo {}
+ set dat [cat /proc/meminfo]
+ foreach line [split $dat \n] {
+ switch [lindex $line 0] {
+ MemTotal: {
+ # Normalize to MB
+ dict set cpuinfo memory [lindex $line 1]/1024
+ }
+ }
+ }
+ set cpus 0
+ set dat [cat /proc/cpuinfo]
+ foreach line [split $dat \n] {
+ set idx [string first : $line]
+ set field [string trim [string range $line 0 $idx-1]]
+ set value [string trim [string range $line $idx+1 end]]
+ switch $field {
+ processor {
+ incr cpus
+ }
+ {cpu family} {
+ dict set cpuinfo family $value
+ }
+ model {
+ dict set cpuinfo model $value
+ }
+ stepping {
+ dict set cpuinfo stepping $value
+ }
+ vendor_id {
+ dict set cpuinfo vendor $value
+ }
+ {model name} {
+ dict set cpuinfo brand $value
+ }
+ {cpu MHz} {
+ dict set cpuinfo speed $value
+ }
+ flags {
+ dict set cpuinfo features $value
+ }
+ }
+ }
+ dict set cpuinfo cpus $cpus
+ }
+ if {$args eq "<list>"} {
+ return [dict keys $cpuinfo]
+ }
+ if {[llength $args]==0} {
+ return $cpuinfo
+ }
+ if {[llength $args]==1} {
+ return [dict get $cpuinfo [lindex $args 0]]
+ }
+ set result {}
+ foreach item $args {
+ if {[dict exists $cpuinfo $item]} {
+ dict set result $item [dict get $cpuinfo $item]
+ } else {
+ dict set result $item {}
+ }
+ }
+ return $result
+}
+
+###
+# topic: aa8eda4fb59296a1a34d8d600ca54e28
+# description: Dump interfaces
+###
+proc ::nettool::dump {} {
+ set data [exec ifconfig]
+ set iface {}
+ set result {}
+ foreach line [split $data \n] {
+ if {[string index $line 0] in {" " "\t"} } {
+ # Indented line appends the prior iface
+ switch [lindex $line 0] {
+ inet {
+ foreach tuple [lrange $line 1 end] {
+ set idx [string first : $tuple]
+ set field [string trim [string range $tuple 0 $idx]]
+ set value [string trim [string range $tuple $idx+1 end]]
+ dict set result $iface ipv4 [string trim $field] [string trim $value]
+ }
+ }
+ inet6 {
+ dict set result $iface ipv6 addr: [lindex $line 2]
+ foreach tuple [lrange $line 3 end] {
+ set idx [string first : $tuple]
+ set field [string trim [string range $tuple 0 $idx]]
+ set value [string trim [string range $tuple $idx+1 end]]
+ dict set result $iface ipv6 [string trim $field] [string trim $value]
+ }
+ }
+ }
+ } else {
+ # Non-intended line - new iface
+ set iface [lindex $line 0]
+ set idx [lsearch $line HWaddr]
+ if {$idx >= 0 } {
+ dict set result $iface ether: [lindex $line $idx+1]
+ }
+ }
+ }
+ return $result
+}
+
+###
+# topic: 417672d3f31b80d749588365af88baf6
+# title: Return list of ip addresses for this computer (primary first)
+###
+proc ::nettool::ip_list {} {
+ set result {}
+ foreach {iface info} [dump] {
+ if {[dict exists $info ipv4 addr:]} {
+ lappend result [dict get $info ipv4 addr:]
+ }
+ }
+ ldelete result 127.0.0.1
+ return $result
+}
+
+###
+# topic: ac9d6815d47f60d45930f0c8c8ae8f16
+# title: Return list of mac numbers for this computer (primary first)
+###
+proc ::nettool::mac_list {} {
+ set result {}
+ foreach {iface info} [dump] {
+ if {[dict exists $info ether:]} {
+ lappend result [dict get $info ether:]
+ }
+ }
+ return $result
+}
+
+###
+# topic: a43b6f42141820e0ba1094840d0f6fc0
+###
+proc ::nettool::network_list {} {
+ foreach {iface info} [dump] {
+ if {![dict exists $info ipv4 addr:]} continue
+ if {![dict exists $info ipv4 Mask:]} continue
+ #set mask [::ip::maskToInt $netmask]
+ set addr [dict get $info ipv4 addr:]
+ set mask [dict get $info ipv4 Mask:]
+ set addri [::ip::toInteger $addr]
+ lappend result [ip::nativeToPrefix [list [expr {$addri & $mask}] $mask] -ipv4]
+ }
+ return $result
+}
+
+###
+# topic: e7db1ae1b5b98a1bb4384f0a4fe81f42
+###
+proc ::nettool::status {} {
+ set result {}
+ set dat [cat /proc/loadavg]
+ dict set result load_average [lrange $dat 0 2]
+ set cpus [cpuinfo cpus].0
+ dict set result load [expr {[lindex $dat 0]/$cpus}]
+
+ set processes [split [lindex $dat 3] /]
+ dict set result processes_running [lindex $processes 0]
+ dict set result processes_total [lindex $processes 1]
+
+ set dat [cat /proc/meminfo]
+ foreach line [split $dat \n] {
+ switch [lindex $line 0] {
+ MemTotal: {
+ # Normalize to MB
+ dict set result memory_total [expr {[lindex $line 1]/1024}]
+ }
+ MemFree: {
+ # Normalize to MB
+ dict set result memory_free [expr {[lindex $line 1]/1024}]
+ }
+ }
+ }
+ return $result
+}
+
+###
+# topic: 59bf977ad7287b4d90346fad639aed34
+###
+proc ::nettool::uptime_report {} {
+ set result {}
+ set dat [split [exec uptime] ,]
+ puts $dat
+ dict set result time [lindex [lindex $dat 0] 0]
+ dict set result uptime [lrange [lindex $dat 0] 1 end]
+ dict set result users [lindex [lindex $dat 2] 0]
+ dict set result load_1_minute [lindex [lindex $dat 3] end]
+ dict set result load_5_minute [lindex [lindex $dat 4] end]
+ dict set result load_15_minute [lindex [lindex $dat 5] end]
+ return $result
+}
+
+unset -nocomplain ::nettool::cpuinfo
+
diff --git a/tcllib/modules/nettool/platform_unix_macosx.tcl b/tcllib/modules/nettool/platform_unix_macosx.tcl
new file mode 100644
index 0000000..6854c03
--- /dev/null
+++ b/tcllib/modules/nettool/platform_unix_macosx.tcl
@@ -0,0 +1,232 @@
+::namespace eval ::nettool {}
+
+###
+# topic: 825cd25953c2cc896a96006b7f454e00
+# title: Return pairings of MAC numbers to IP addresses on the local network
+# description: Under macosx, we call the arp command for arp table resolution
+###
+proc ::nettool::arp_table {} {
+ set result {}
+ set dat [exec arp -a]
+ foreach line [split $dat \n] {
+ set host [lindex $line 0]
+ set ip [lindex $line 1]
+ set macid [lindex $line 3]
+ lappend result $macid [string range $ip 1 end-1]
+ }
+ return $result
+}
+
+###
+# topic: 92ebbfa155883ad41c37d3f843392be4
+# title: Return list of broadcast addresses for local networks
+###
+proc ::nettool::broadcast_list {} {
+ set result {}
+ lappend result 127.0.0.1
+ foreach {iface info} [dump] {
+ if {[dict exists $info broadcast:]} {
+ lappend result [dict get $info broadcast:]
+ }
+ }
+ return [lsort -unique -dictionary $result]
+}
+
+###
+# topic: 187cfa1827097c5cdf1c40c656cedfcc
+# description: Return time since booted
+###
+proc ::nettool::cpuinfo args {
+ variable cpuinfo
+ if {![info exists cpuinfo]} {
+ set cpuinfo {}
+ dict set cpuinfo machine [exec sysctl -n hw.machine]
+ dict set cpuinfo cpus [exec sysctl -n hw.ncpu]
+ # Normalize to MB
+ dict set cpuinfo memory [expr {[exec sysctl -n hw.memsize] / 1048576}]
+
+ dict set cpuinfo vendor [exec sysctl -n machdep.cpu.vendor]
+ dict set cpuinfo brand [exec sysctl -n machdep.cpu.brand_string]
+
+ dict set cpuinfo model [exec sysctl -n machdep.cpu.model]
+ dict set cpuinfo speed [expr {[exec sysctl -n hw.cpufrequency]/1000000}]
+
+ dict set cpuinfo family [exec sysctl -n machdep.cpu.family]
+ dict set cpuinfo stepping [exec sysctl -n machdep.cpu.stepping]
+ dict set cpuinfo features [exec sysctl -n machdep.cpu.features]
+ dict set cpuinfo diskless []
+ }
+ if {$args eq "<list>"} {
+ return [dict keys $cpuinfo]
+ }
+ if {[llength $args]==0} {
+ return $cpuinfo
+ }
+ if {[llength $args]==1} {
+ return [dict get $cpuinfo [lindex $args 0]]
+ }
+ set result {}
+ foreach item $args {
+ if {[dict exists $cpuinfo $item]} {
+ dict set result $item [dict get $cpuinfo $item]
+ } else {
+ dict set result $item {}
+ }
+ }
+ return $result
+}
+
+###
+# topic: aa8eda4fb59296a1a34d8d600ca54e28
+# description: Dump interfaces
+###
+proc ::nettool::dump {} {
+ set data [exec ifconfig]
+ set iface {}
+ set result {}
+ foreach line [split $data \n] {
+ if {[string index $line 0] in {" " "\t"} } {
+ # Indented line appends the prior iface
+ foreach {field value} $line {
+ dict set result $iface [string trimright $field :]: $value
+ }
+ } else {
+ # Non-intended line - new iface
+ set iface [lindex $line 0]
+ }
+ }
+ return $result
+}
+
+###
+# topic: dd2e2c0810cea69909399808f2a68949
+# title: Return a list of unique hardware addresses
+###
+proc ::nettool::hwid_list {} {
+ variable cached_data
+ set result {}
+ if {![info exists cached_data]} {
+ if {[catch {exec system_profiler SPHardwareDataType} hwlist]} {
+ set cached_data {}
+ } else {
+ set cached_data $hwlist
+
+ }
+ }
+ set serial {}
+ set hwuuid {}
+ set result {}
+ catch {
+ foreach line [split $cached_data \n] {
+ if { [lindex $line 0] == "Serial" && [lindex $line 1] == "Number" } {
+ set serial [lindex $line end]
+ }
+ if { [lindex $line 0] == "Hardware" && [lindex $line 1] == "UUID:" } {
+ set hwuuid [lindex $line end]
+ }
+ }
+ }
+ if { $hwuuid != {} } {
+ lappend result 0x[string map {- {}} $hwuuid]
+ }
+ # Blank serial number?
+ if { $serial != {} } {
+ set sn [binary scan $serial H* hash]
+ lappend result 0x$hash
+ }
+ if {[llength $result]} {
+ return $result
+ }
+ foreach mac [::nettool::mac_list] {
+ lappend result 0x[string map {: {}} $mac]
+ }
+ if {[llength $result]} {
+ return $result
+ }
+ return 0x010203040506
+}
+
+###
+# topic: d2932eb0ea8cc9f6a865c1ab7cdd4572
+# description:
+# Called on package load to build any static
+# structures to cache data that would be time
+# consuming to call on the fly
+###
+proc ::nettool::init {} {
+ unset -nocomplain [namespace current]::cpuinfo
+
+}
+
+###
+# topic: 417672d3f31b80d749588365af88baf6
+# title: Return list of ip addresses for this computer (primary first)
+###
+proc ::nettool::ip_list {} {
+ set result {}
+ foreach {iface info} [dump] {
+ if {[dict exists $info inet:]} {
+ lappend result [dict get $info inet:]
+ }
+ }
+ ldelete result 127.0.0.1
+ return $result
+}
+
+###
+# topic: ac9d6815d47f60d45930f0c8c8ae8f16
+# title: Return list of mac numbers for this computer (primary first)
+###
+proc ::nettool::mac_list {} {
+ set result {}
+ foreach {iface info} [dump] {
+ if {[dict exists $info ether:]} {
+ lappend result [dict get $info ether:]
+ }
+ }
+ return $result
+}
+
+###
+# topic: a43b6f42141820e0ba1094840d0f6fc0
+###
+proc ::nettool::network_list {} {
+ foreach {iface info} [dump] {
+ if {![dict exists $info inet:]} continue
+ if {![dict exists $info netmask:]} continue
+ #set mask [::ip::maskToInt $netmask]
+ set addr [dict get $info inet:]
+ set mask [dict get $info netmask:]
+ set addri [::ip::toInteger $addr]
+ lappend result [ip::nativeToPrefix [list [expr {$addri & $mask}] $mask] -ipv4]
+ }
+ return $result
+}
+
+###
+# topic: e7db1ae1b5b98a1bb4384f0a4fe81f42
+###
+proc ::nettool::status {} {
+ set result {}
+ set loaddat [lindex [exec sysctl -n vm.loadavg] 0]
+ set cpus [cpuinfo cpus]
+ dict set result cpus $cpus
+ dict set result load [expr {[lindex $loaddat 0]*100.0/$cpus}]
+ dict set result load_average_1 [lindex $loaddat 0]
+ dict set result load_average_5 [lindex $loaddat 1]
+ dict set result load_average_15 [lindex $loaddat 2]
+
+ set total [exec sysctl -n hw.memsize]
+ dict set result memory_total [expr {$total / 1048576}]
+ set used 0
+ foreach {amt} [exec sysctl -n machdep.memmap] {
+ incr used $amt
+ }
+ dict set result memory_free [expr {($total - $used) / 1048576}]
+
+ return $result
+}
+
+proc ::nettool::user_data_root {appname} {
+ return [file join $::env(HOME) Library {Application Support} $appname]
+}
diff --git a/tcllib/modules/nettool/platform_windows.tcl b/tcllib/modules/nettool/platform_windows.tcl
new file mode 100644
index 0000000..78d9aa7
--- /dev/null
+++ b/tcllib/modules/nettool/platform_windows.tcl
@@ -0,0 +1,135 @@
+package require twapi
+
+::namespace eval ::nettool {}
+
+###
+# topic: 825cd25953c2cc896a96006b7f454e00
+# title: Return pairings of MAC numbers to IP addresses on the local network
+# description: Under macosx, we call the arp command for arp table resolution
+###
+proc ::nettool::arp_table {} {
+ set result {}
+ catch {
+ foreach element [::twapi::get_arp_table] {
+ foreach {ifidx macid ipaddr type} {
+ lappend result [string map {- :} $macid] $ipaddr
+ }
+ }
+ }
+ return $result
+}
+
+###
+# topic: 92ebbfa155883ad41c37d3f843392be4
+# title: Return list of broadcast addresses for local networks
+###
+proc ::nettool::broadcast_list {} {
+ set result {}
+ lappend result 127.0.0.1
+ foreach iface [::twapi::get_netif_indices] {
+ set dat [::twapi::GetIpAddrTable $iface]
+ foreach element $dat {
+ foreach {addr ifindx netmask broadcast reamsize} $element break;
+ lappend result [::ip::broadcastAddress $addr/$netmask]
+ }
+ }
+ return [lsort -unique -dictionary $result]
+}
+
+###
+# topic: 57fdc331bc60c7bf2bd3f3214e9a906f
+###
+proc ::nettool::hwaddr_to_ipaddr args {
+ return [::twapi::hwaddr_to_ipaddr {*}$args]
+}
+
+###
+# topic: dd2e2c0810cea69909399808f2a68949
+# title: Return a list of unique hardware ids
+###
+proc ::nettool::hwid_list {} {
+ # Use the serial number on the hard drive
+ catch {exec {*}[auto_execok vol] c:} voldat
+ set num [lindex [lindex [split $voldat \n] end] end]
+ return 0x[string map {- {}} $num]
+}
+
+###
+# topic: 4b87d977492bd10802bfc0327cd07ac2
+# title: Return list of network interfaces
+###
+proc ::nettool::if_list {} {
+ return [::twapi::get_netif_indices]
+}
+
+###
+# topic: 417672d3f31b80d749588365af88baf6
+# title: Return list of ip addresses for this computer (primary first)
+###
+set body {}
+if {[::twapi::get_ip_addresses] ne {}} {
+ set body {
+ set result [::twapi::get_ip_addresses]
+ ldelete result 127.0.0.1
+ return $result
+}
+} elseif {[info commands ::twapi::get_system_ipaddrs] ne {}} {
+# They changed commands names on me...
+ set body {
+ set result [::twapi::get_system_ipaddrs]
+ ldelete result 127.0.0.1
+ return $result
+}
+}
+proc ::nettool::ip_list {} $body
+###
+# topic: ac9d6815d47f60d45930f0c8c8ae8f16
+# title: Return list of mac numbers for this computer (primary first)
+###
+proc ::nettool::mac_list {} {
+
+ set result {}
+ foreach iface [::twapi::get_netif_indices] {
+ foreach {field value} [::twapi::get_netif_info $iface -physicaladdress] {
+ if { $value eq {} } continue
+ lappend result [string map {- :} $value]
+ }
+ }
+ return $result
+}
+
+###
+# topic: a43b6f42141820e0ba1094840d0f6fc0
+###
+proc ::nettool::network_list {} {
+ set result {}
+ foreach iface [::twapi::get_netif_indices] {
+ set dat [::twapi::GetIpAddrTable $iface]
+ foreach element $dat {
+ foreach {addr ifindx netmask broadcast reamsize} $element break;
+ set mask [::ip::maskToInt $netmask]
+ set addri [::ip::toInteger $addr]
+ lappend result [ip::nativeToPrefix [list [expr {$addri & $mask}] $netmask] -ipv4]
+ }
+ }
+ return [lsort -unique $result]
+}
+
+proc ::nettool::status {} {
+ set result {}
+ #dict set result load [::twapi::]
+ set cpus [::twapi::get_processor_count]
+ set usage 0
+ for {set p 0} {$p < $cpus} {incr p} {
+ set pu [lindex [::twapi::get_processor_info $p -processorutilization] 1]
+ set usage [expr {$usage+$pu}]
+ }
+ dict set result cpus $cpus
+ dict set result load [expr {$usage/$cpus}]
+ dict set result uptime [::twapi::get_system_uptime]
+}
+
+proc ::nettool::user_data_root {appname} {
+ return [file join $::env(APPDATA) $appname]
+}
+package provide nettool::platform::windows 0.2
diff --git a/tcllib/modules/nettool/scripts/build_services.tcl b/tcllib/modules/nettool/scripts/build_services.tcl
new file mode 100644
index 0000000..d0fcb88
--- /dev/null
+++ b/tcllib/modules/nettool/scripts/build_services.tcl
@@ -0,0 +1,83 @@
+###
+# topic: 65dfea29d424543cdfc0e1cbf9f90295ef6214cb
+# description:
+# This script digests the raw data from
+# http://www.iana.org/assignments/service-names-port-numbers/service-names-port-numbers.csv
+# And produces a summary
+###
+proc ::record {service port type usage} {
+ if { $port eq {} } return
+ if {$service eq {} && $type in {tcp udp {}} && $usage != "Reserved"} {
+ ladd ::available_port($port) {*}$type
+ return
+ }
+ unset -nocomplain ::available_port($port)
+ lappend ::busy_port($port) $type $usage
+ #puts [list busy $service $port $type $usage]
+}
+
+for {set x 0} {$x < 65536} {incr x} {
+ set ::available_port($x) {}
+}
+package require dicttool
+package require csv
+set fin [open [lindex $argv 0] r]
+set headers [gets $fin]
+set thisline {}
+while {[gets $fin line]>=0} {
+ append thisline \n$line
+ if {![csv::iscomplete $line]} continue
+ set lline [csv::split $line]
+ if [catch {
+ set service [lindex $lline 0]
+ set port [lindex $lline 1]
+ set type [lindex $lline 2]
+ set usage [lindex $lline 3]
+
+ }] continue
+ if {![string is integer -strict $port]} {
+ set startport [lindex [split $port -] 0]
+ set endport [lindex [split $port -] 1]
+ if {[string is integer -strict $startport] && [string is integer -strict $endport]} {
+ for {set i $startport} {$i<=$endport} {incr i} {
+ record $service $i $type $usage
+ }
+ continue
+ }
+
+ }
+
+ record $service $port $type $usage
+}
+close $fin
+
+set fout [open available_ports.tcl w]
+puts $fout {
+package provide nettool::available_ports 0.1
+namespace eval ::nettool {
+ set blocks {}
+}
+}
+set startport 0
+set endport 0
+foreach {port avail} [lsort -integer -stride 2 [array get available_port]] {
+ # Don't bother with ports below 1024
+ # Most operating systems won't let us access them anyway
+ if {$port < 1024 } continue
+ if { $endport == ($port-1) } {
+ set endport $port
+ continue
+ }
+ if {$startport} {
+ puts $fout [list lappend ::nettool::blocks $startport $endport]
+ }
+ set startport $port
+ set endport $port
+}
+if { $startport } {
+ puts $fout [list lappend ::nettool::blocks $startport $endport]
+}
+close $fout
+
+exit
+
diff --git a/tcllib/modules/nettool/service-names-port-numbers.csv b/tcllib/modules/nettool/service-names-port-numbers.csv
new file mode 100644
index 0000000..4fc53fd
--- /dev/null
+++ b/tcllib/modules/nettool/service-names-port-numbers.csv
@@ -0,0 +1,14396 @@
+Service Name,Port Number,Transport Protocol,Description,Assignee,Contact,Registration Date,Modification Date,Reference,Service Code,Known Unauthorized Uses,Assignment Notes
+,0,tcp,Reserved,[Jon_Postel],[Jon_Postel],,,,,,
+,0,udp,Reserved,[Jon_Postel],[Jon_Postel],,,,,,
+tcpmux,1,tcp,TCP Port Service Multiplexer,[Mark_Lottor],[Mark_Lottor],,,,,,
+tcpmux,1,udp,TCP Port Service Multiplexer,[Mark_Lottor],[Mark_Lottor],,,,,,
+compressnet,2,tcp,Management Utility,,,,,,,,
+compressnet,2,udp,Management Utility,,,,,,,,
+compressnet,3,tcp,Compression Process,[Bernie_Volz],[Bernie_Volz],,,,,,
+compressnet,3,udp,Compression Process,[Bernie_Volz],[Bernie_Volz],,,,,,
+,4,tcp,Unassigned,,,,,,,,
+,4,udp,Unassigned,,,,,,,,
+rje,5,tcp,Remote Job Entry,[Jon_Postel],[Jon_Postel],,,,,,
+rje,5,udp,Remote Job Entry,[Jon_Postel],[Jon_Postel],,,,,,
+,6,tcp,Unassigned,,,,,,,,
+,6,udp,Unassigned,,,,,,,,
+echo,7,tcp,Echo,[Jon_Postel],[Jon_Postel],,,,,,
+echo,7,udp,Echo,[Jon_Postel],[Jon_Postel],,,,,,
+,8,tcp,Unassigned,,,,,,,,
+,8,udp,Unassigned,,,,,,,,
+discard,9,tcp,Discard,[Jon_Postel],[Jon_Postel],,,,,,
+discard,9,udp,Discard,[Jon_Postel],[Jon_Postel],,,,,,
+discard,9,sctp,Discard,[Randall_Stewart],[Randall_Stewart],,,[RFC4960],,,
+discard,9,dccp,Discard,[Eddie_Kohler],[Eddie_Kohler],,,[RFC4340],1145656131,,
+,10,tcp,Unassigned,,,,,,,,
+,10,udp,Unassigned,,,,,,,,
+systat,11,tcp,Active Users,[Jon_Postel],[Jon_Postel],,,,,,
+systat,11,udp,Active Users,[Jon_Postel],[Jon_Postel],,,,,,
+,12,tcp,Unassigned,,,,,,,,
+,12,udp,Unassigned,,,,,,,,
+daytime,13,tcp,Daytime,[Jon_Postel],[Jon_Postel],,,[RFC867],,,
+daytime,13,udp,Daytime,[Jon_Postel],[Jon_Postel],,,[RFC867],,,
+,14,tcp,Unassigned,,,,,,,,
+,14,udp,Unassigned,,,,,,,,
+,15,tcp,Unassigned [was netstat],,,,,,,,
+,15,udp,Unassigned,,,,,,,,
+,16,tcp,Unassigned,,,,,,,,
+,16,udp,Unassigned,,,,,,,,
+qotd,17,tcp,Quote of the Day,[Jon_Postel],[Jon_Postel],,,,,,
+qotd,17,udp,Quote of the Day,[Jon_Postel],[Jon_Postel],,,,,,
+msp,18,tcp,Message Send Protocol (historic),[Rina_Nethaniel],[Rina_Nethaniel],,,,,,
+msp,18,udp,Message Send Protocol (historic),[Rina_Nethaniel],[Rina_Nethaniel],,,,,,
+chargen,19,tcp,Character Generator,,,,,,,,
+chargen,19,udp,Character Generator,,,,,,,,
+ftp-data,20,tcp,File Transfer [Default Data],[Jon_Postel],[Jon_Postel],,,,,,
+ftp-data,20,udp,File Transfer [Default Data],[Jon_Postel],[Jon_Postel],,,,,,
+ftp-data,20,sctp,FTP,[Randall_Stewart],[Randall_Stewart],,,[RFC4960],,,
+ftp,21,tcp,File Transfer [Control],[Jon_Postel],[Jon_Postel],,,[RFC959],,,Defined TXT keys: u=<username> p=<password> path=<path>
+ftp,21,udp,File Transfer [Control],[Jon_Postel],[Jon_Postel],,,[RFC959],,,Defined TXT keys: u=<username> p=<password> path=<path>
+ftp,21,sctp,FTP,[Randall_Stewart],[Randall_Stewart],,,[RFC4960],,,Defined TXT keys: u=<username> p=<password> path=<path>
+ssh,22,tcp,The Secure Shell (SSH) Protocol,,,,,[RFC4251],,,Defined TXT keys: u=<username> p=<password>
+ssh,22,udp,The Secure Shell (SSH) Protocol,,,,,[RFC4251],,,Defined TXT keys: u=<username> p=<password>
+ssh,22,sctp,SSH,[Randall_Stewart],[Randall_Stewart],,,[RFC4960],,,Defined TXT keys: u=<username> p=<password>
+telnet,23,tcp,Telnet,[Jon_Postel],[Jon_Postel],,,[RFC854],,,Defined TXT keys: u=<username> p=<password>
+telnet,23,udp,Telnet,[Jon_Postel],[Jon_Postel],,,[RFC854],,,Defined TXT keys: u=<username> p=<password>
+,24,tcp,any private mail system,[Rick_Adams],[Rick_Adams],,,,,,
+,24,udp,any private mail system,[Rick_Adams],[Rick_Adams],,,,,,
+smtp,25,tcp,Simple Mail Transfer,[Jon_Postel],[Jon_Postel],,,,,,
+smtp,25,udp,Simple Mail Transfer,[Jon_Postel],[Jon_Postel],,,,,,
+,26,tcp,Unassigned,,,,,,,,
+,26,udp,Unassigned,,,,,,,,
+nsw-fe,27,tcp,NSW User System FE,[Robert_Thomas],[Robert_Thomas],,,,,,
+nsw-fe,27,udp,NSW User System FE,[Robert_Thomas],[Robert_Thomas],,,,,,
+,28,tcp,Unassigned,,,,,,,,
+,28,udp,Unassigned,,,,,,,,
+msg-icp,29,tcp,MSG ICP,[Robert_Thomas],[Robert_Thomas],,,,,,
+msg-icp,29,udp,MSG ICP,[Robert_Thomas],[Robert_Thomas],,,,,,
+,30,tcp,Unassigned,,,,,,,,
+,30,udp,Unassigned,,,,,,,,
+msg-auth,31,tcp,MSG Authentication,[Robert_Thomas],[Robert_Thomas],,,,,,
+msg-auth,31,udp,MSG Authentication,[Robert_Thomas],[Robert_Thomas],,,,,,
+,32,tcp,Unassigned,,,,,,,,
+,32,udp,Unassigned,,,,,,,,
+dsp,33,tcp,Display Support Protocol,[Ed_Cain],[Ed_Cain],,,,,,
+dsp,33,udp,Display Support Protocol,[Ed_Cain],[Ed_Cain],,,,,,
+,34,tcp,Unassigned,,,,,,,,
+,34,udp,Unassigned,,,,,,,,
+,35,tcp,any private printer server,[Jon_Postel],[Jon_Postel],,,,,,
+,35,udp,any private printer server,[Jon_Postel],[Jon_Postel],,,,,,
+,36,tcp,Unassigned,,,,,,,,
+,36,udp,Unassigned,,,,,,,,
+time,37,tcp,Time,[Jon_Postel],[Jon_Postel],,,,,,
+time,37,udp,Time,[Jon_Postel],[Jon_Postel],,,,,,
+rap,38,tcp,Route Access Protocol,[Robert_Ullmann],[Robert_Ullmann],,,,,,
+rap,38,udp,Route Access Protocol,[Robert_Ullmann],[Robert_Ullmann],,,,,,
+rlp,39,tcp,Resource Location Protocol,[Mike_Accetta],[Mike_Accetta],,,,,,
+rlp,39,udp,Resource Location Protocol,[Mike_Accetta],[Mike_Accetta],,,,,,
+,40,tcp,Unassigned,,,,,,,,
+,40,udp,Unassigned,,,,,,,,
+graphics,41,tcp,Graphics,,,,,,,,
+graphics,41,udp,Graphics,,,,,,,,
+name,42,tcp,Host Name Server,,,,,,,,
+name,42,udp,Host Name Server,,,,,,,,
+nameserver,42,tcp,Host Name Server,,,,,,,,
+nameserver,42,udp,Host Name Server,,,,,,,,
+nicname,43,tcp,Who Is,,,,,,,,
+nicname,43,udp,Who Is,,,,,,,,
+mpm-flags,44,tcp,MPM FLAGS Protocol,,,,,,,,
+mpm-flags,44,udp,MPM FLAGS Protocol,,,,,,,,
+mpm,45,tcp,Message Processing Module [recv],,,,,,,,
+mpm,45,udp,Message Processing Module [recv],,,,,,,,
+mpm-snd,46,tcp,MPM [default send],[Jon_Postel],[Jon_Postel],,,,,,
+mpm-snd,46,udp,MPM [default send],[Jon_Postel],[Jon_Postel],,,,,,
+ni-ftp,47,tcp,NI FTP,[Steve_Kille],[Steve_Kille],,,,,,
+ni-ftp,47,udp,NI FTP,[Steve_Kille],[Steve_Kille],,,,,,
+auditd,48,tcp,Digital Audit Daemon,[Larry_Scott],[Larry_Scott],,,,,,
+auditd,48,udp,Digital Audit Daemon,[Larry_Scott],[Larry_Scott],,,,,,
+tacacs,49,tcp,Login Host Protocol (TACACS),[Pieter_Ditmars],[Pieter_Ditmars],,,,,,
+tacacs,49,udp,Login Host Protocol (TACACS),[Pieter_Ditmars],[Pieter_Ditmars],,,,,,
+re-mail-ck,50,tcp,Remote Mail Checking Protocol,[Steve_Dorner],[Steve_Dorner],,,,,,
+re-mail-ck,50,udp,Remote Mail Checking Protocol,[Steve_Dorner],[Steve_Dorner],,,,,,
+,51,,Reserved,,,,2013-05-24,,,,This entry is being removed on 2013-05-24.
+xns-time,52,tcp,XNS Time Protocol,[Susie_Armstrong],[Susie_Armstrong],,,,,,
+xns-time,52,udp,XNS Time Protocol,[Susie_Armstrong],[Susie_Armstrong],,,,,,
+domain,53,tcp,Domain Name Server,[Paul_Mockapetris],[Paul_Mockapetris],,,,,,
+domain,53,udp,Domain Name Server,[Paul_Mockapetris],[Paul_Mockapetris],,,,,,
+xns-ch,54,tcp,XNS Clearinghouse,[Susie_Armstrong],[Susie_Armstrong],,,,,,
+xns-ch,54,udp,XNS Clearinghouse,[Susie_Armstrong],[Susie_Armstrong],,,,,,
+isi-gl,55,tcp,ISI Graphics Language,,,,,,,,
+isi-gl,55,udp,ISI Graphics Language,,,,,,,,
+xns-auth,56,tcp,XNS Authentication,[Susie_Armstrong],[Susie_Armstrong],,,,,,
+xns-auth,56,udp,XNS Authentication,[Susie_Armstrong],[Susie_Armstrong],,,,,,
+,57,tcp,any private terminal access,[Jon_Postel],[Jon_Postel],,,,,,
+,57,udp,any private terminal access,[Jon_Postel],[Jon_Postel],,,,,,
+xns-mail,58,tcp,XNS Mail,[Susie_Armstrong],[Susie_Armstrong],,,,,,
+xns-mail,58,udp,XNS Mail,[Susie_Armstrong],[Susie_Armstrong],,,,,,
+,59,tcp,any private file service,[Jon_Postel],[Jon_Postel],,,,,,
+,59,udp,any private file service,[Jon_Postel],[Jon_Postel],,,,,,
+,60,tcp,Unassigned,,,,,,,,
+,60,udp,Unassigned,,,,,,,,
+ni-mail,61,tcp,NI MAIL,[Steve_Kille],[Steve_Kille],,,,,,
+ni-mail,61,udp,NI MAIL,[Steve_Kille],[Steve_Kille],,,,,,
+acas,62,tcp,ACA Services,[E_Wald],[E_Wald],,,,,,
+acas,62,udp,ACA Services,[E_Wald],[E_Wald],,,,,,
+whoispp,63,tcp,"whois++
+IANA assigned this well-formed service name as a replacement for ""whois++"".",[Rickard_Schoultz],[Rickard_Schoultz],,,,,,
+whois++,63,tcp,whois++,[Rickard_Schoultz],[Rickard_Schoultz],,,,,,"This entry is an alias to ""whoispp"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+whoispp,63,udp,"whois++
+IANA assigned this well-formed service name as a replacement for ""whois++"".",[Rickard_Schoultz],[Rickard_Schoultz],,,,,,
+whois++,63,udp,whois++,[Rickard_Schoultz],[Rickard_Schoultz],,,,,,"This entry is an alias to ""whoispp"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+covia,64,tcp,Communications Integrator (CI),[Dan_Smith],[Dan_Smith],,,,,,
+covia,64,udp,Communications Integrator (CI),[Dan_Smith],[Dan_Smith],,,,,,
+tacacs-ds,65,tcp,TACACS-Database Service,[Kathy_Huber],[Kathy_Huber],,,,,,
+tacacs-ds,65,udp,TACACS-Database Service,[Kathy_Huber],[Kathy_Huber],,,,,,
+sql-net,66,tcp,"Oracle SQL*NET
+IANA assigned this well-formed service name as a replacement for ""sql*net"".",[Jack_Haverty],[Jack_Haverty],,,,,,
+sql*net,66,tcp,Oracle SQL*NET,[Jack_Haverty],[Jack_Haverty],,,,,,"This entry is an alias to ""sql-net"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+sql-net,66,udp,"Oracle SQL*NET
+IANA assigned this well-formed service name as a replacement for ""sql*net"".",[Jack_Haverty],[Jack_Haverty],,,,,,
+sql*net,66,udp,Oracle SQL*NET,[Jack_Haverty],[Jack_Haverty],,,,,,"This entry is an alias to ""sql-net"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+bootps,67,tcp,Bootstrap Protocol Server,[Bill_Croft],[Bill_Croft],,,[RFC951],,,Defined TXT keys: None
+bootps,67,udp,Bootstrap Protocol Server,,,,,,,,
+bootpc,68,tcp,Bootstrap Protocol Client,[Bill_Croft],[Bill_Croft],,,,,,
+bootpc,68,udp,Bootstrap Protocol Client,[Bill_Croft],[Bill_Croft],,,,,,
+tftp,69,tcp,Trivial File Transfer,[David_Clark],[David_Clark],,,,,,
+tftp,69,udp,Trivial File Transfer,[David_Clark],[David_Clark],,,,,,
+gopher,70,tcp,Gopher,[Mark_McCahill],[Mark_McCahill],,,,,,
+gopher,70,udp,Gopher,[Mark_McCahill],[Mark_McCahill],,,,,,
+netrjs-1,71,tcp,Remote Job Service,,,,,,,,
+netrjs-1,71,udp,Remote Job Service,,,,,,,,
+netrjs-2,72,tcp,Remote Job Service,,,,,,,,
+netrjs-2,72,udp,Remote Job Service,,,,,,,,
+netrjs-3,73,tcp,Remote Job Service,,,,,,,,
+netrjs-3,73,udp,Remote Job Service,,,,,,,,
+netrjs-4,74,tcp,Remote Job Service,[Bob_Braden],[Bob_Braden],,,,,,
+netrjs-4,74,udp,Remote Job Service,[Bob_Braden],[Bob_Braden],,,,,,
+,75,tcp,any private dial out service,[Jon_Postel],[Jon_Postel],,,,,,
+,75,udp,any private dial out service,[Jon_Postel],[Jon_Postel],,,,,,
+deos,76,tcp,Distributed External Object Store,[Robert_Ullmann],[Robert_Ullmann],,,,,,
+deos,76,udp,Distributed External Object Store,[Robert_Ullmann],[Robert_Ullmann],,,,,,
+,77,tcp,any private RJE service,[Jon_Postel],[Jon_Postel],,,,,,
+,77,udp,any private RJE service,[Jon_Postel],[Jon_Postel],,,,,,
+vettcp,78,tcp,vettcp,[Christopher_Leong],[Christopher_Leong],,,,,,
+vettcp,78,udp,vettcp,[Christopher_Leong],[Christopher_Leong],,,,,,
+finger,79,tcp,Finger,[David_Zimmerman],[David_Zimmerman],,,,,Unauthorized use by some mail users (see [RFC4146] for details),
+finger,79,udp,Finger,[David_Zimmerman],[David_Zimmerman],,,,,Unauthorized use by some mail users (see [RFC4146] for details),
+http,80,tcp,World Wide Web HTTP,,,,,,,,Defined TXT keys: u=<username> p=<password> path=<path to document>
+http,80,udp,World Wide Web HTTP,,,,,,,,Defined TXT keys: u=<username> p=<password> path=<path to document>
+www,80,tcp,World Wide Web HTTP,,,,,,,,"This is a duplicate of the ""http"" service and should not be used for discovery purposes."
+www,80,udp,World Wide Web HTTP,,,,,,,,"This is a duplicate of the ""http"" service and should not be used for discovery purposes."
+www-http,80,tcp,World Wide Web HTTP,[Tim_Berners_Lee],[Tim_Berners_Lee],,,,,,"This is a duplicate of the ""http"" service and should not be used for discovery purposes.
+ u=<username> p=<password> path=<path to document>
+ (see txtrecords.html#http)
+ Known Subtypes: _printer
+ NOTE: The meaning of this service type, though called just ""http"", actually
+ denotes something more precise than just ""any data transported using HTTP"".
+ The DNS-SD service type ""http"" should only be used to advertise content that:
+ * is served over HTTP,
+ * can be displayed by ""typical"" web browser client software, and
+ * is intented primarily to be viewed by a human user.
+ Of course, the definition of ""typical web browser"" is subjective, and may
+ change over time, but for practical purposes the DNS-SD service type ""http""
+ can be understood as meaning ""human-readable HTML content served over HTTP"".
+ In some cases other widely-supported content types may also be appropriate,
+ such as plain text over HTTP, or JPEG image over HTTP.
+ Content types not intented primarily for viewing by a human user, or not
+ widely-supported in web browsing clients, should not be advertised as
+ DNS-SD service type ""http"", even if they do happen to be transported over HTTP.
+ Such types should be advertised as their own logical service type with their
+ own DNS-SD service type, for example, XUL (XML User Interface Language)
+ transported over HTTP is advertised explicitly as DNS-SD service type ""xul-http""."
+www-http,80,udp,World Wide Web HTTP,[Tim_Berners_Lee],[Tim_Berners_Lee],,,,,,"This is a duplicate of the ""http"" service and should not be used for discovery purposes.
+ u=<username> p=<password> path=<path to document>
+ (see txtrecords.html#http)
+ Known Subtypes: _printer
+ NOTE: The meaning of this service type, though called just ""http"", actually
+ denotes something more precise than just ""any data transported using HTTP"".
+ The DNS-SD service type ""http"" should only be used to advertise content that:
+ * is served over HTTP,
+ * can be displayed by ""typical"" web browser client software, and
+ * is intented primarily to be viewed by a human user.
+ Of course, the definition of ""typical web browser"" is subjective, and may
+ change over time, but for practical purposes the DNS-SD service type ""http""
+ can be understood as meaning ""human-readable HTML content served over HTTP"".
+ In some cases other widely-supported content types may also be appropriate,
+ such as plain text over HTTP, or JPEG image over HTTP.
+ Content types not intented primarily for viewing by a human user, or not
+ widely-supported in web browsing clients, should not be advertised as
+ DNS-SD service type ""http"", even if they do happen to be transported over HTTP.
+ Such types should be advertised as their own logical service type with their
+ own DNS-SD service type, for example, XUL (XML User Interface Language)
+ transported over HTTP is advertised explicitly as DNS-SD service type ""xul-http""."
+http,80,sctp,HTTP,[Randall_Stewart],[Randall_Stewart],,,[RFC4960],,,Defined TXT keys: u=<username> p=<password> path=<path to document>
+,81,,Unassigned,,,,2007-09-06,,,,
+xfer,82,tcp,XFER Utility,[Thomas_M_Smith],[Thomas_M_Smith],,,,,,
+xfer,82,udp,XFER Utility,[Thomas_M_Smith],[Thomas_M_Smith],,,,,,
+mit-ml-dev,83,tcp,MIT ML Device,[David_Reed],[David_Reed],,,,,,
+mit-ml-dev,83,udp,MIT ML Device,[David_Reed],[David_Reed],,,,,,
+ctf,84,tcp,Common Trace Facility,[Hugh_Thomas],[Hugh_Thomas],,,,,,
+ctf,84,udp,Common Trace Facility,[Hugh_Thomas],[Hugh_Thomas],,,,,,
+mit-ml-dev,85,tcp,MIT ML Device,[David_Reed],[David_Reed],,,,,,
+mit-ml-dev,85,udp,MIT ML Device,[David_Reed],[David_Reed],,,,,,
+mfcobol,86,tcp,Micro Focus Cobol,[Simon_Edwards],[Simon_Edwards],,,,,,
+mfcobol,86,udp,Micro Focus Cobol,[Simon_Edwards],[Simon_Edwards],,,,,,
+,87,tcp,any private terminal link,[Jon_Postel],[Jon_Postel],,,,,,
+,87,udp,any private terminal link,[Jon_Postel],[Jon_Postel],,,,,,
+kerberos,88,tcp,Kerberos,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,,
+kerberos,88,udp,Kerberos,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,,
+su-mit-tg,89,tcp,SU/MIT Telnet Gateway,[Mark_Crispin],[Mark_Crispin],,,,,,
+su-mit-tg,89,udp,SU/MIT Telnet Gateway,[Mark_Crispin],[Mark_Crispin],,,,,,
+dnsix,90,tcp,DNSIX Securit Attribute Token Map,[Charles_Watt],[Charles_Watt],,,,,PORT 90 also being used unofficially by Pointcast,
+dnsix,90,udp,DNSIX Securit Attribute Token Map,[Charles_Watt],[Charles_Watt],,,,,PORT 90 also being used unofficially by Pointcast,
+mit-dov,91,tcp,MIT Dover Spooler,[Eliot_Moss],[Eliot_Moss],,,,,,
+mit-dov,91,udp,MIT Dover Spooler,[Eliot_Moss],[Eliot_Moss],,,,,,
+npp,92,tcp,Network Printing Protocol,[Louis_Mamakos],[Louis_Mamakos],,,,,,
+npp,92,udp,Network Printing Protocol,[Louis_Mamakos],[Louis_Mamakos],,,,,,
+dcp,93,tcp,Device Control Protocol,[Daniel_Tappan],[Daniel_Tappan],,,,,,
+dcp,93,udp,Device Control Protocol,[Daniel_Tappan],[Daniel_Tappan],,,,,,
+objcall,94,tcp,Tivoli Object Dispatcher,[Tom_Bereiter],[Tom_Bereiter],,,,,,
+objcall,94,udp,Tivoli Object Dispatcher,[Tom_Bereiter],[Tom_Bereiter],,,,,,
+supdup,95,tcp,SUPDUP,[Mark_Crispin],[Mark_Crispin],,,,,,
+supdup,95,udp,SUPDUP,[Mark_Crispin],[Mark_Crispin],,,,,,
+dixie,96,tcp,DIXIE Protocol Specification,[Tim_Howes],[Tim_Howes],,,,,,
+dixie,96,udp,DIXIE Protocol Specification,[Tim_Howes],[Tim_Howes],,,,,,
+swift-rvf,97,tcp,Swift Remote Virtural File Protocol,[Maurice_R_Turcotte],[Maurice_R_Turcotte],,,,,,
+swift-rvf,97,udp,Swift Remote Virtural File Protocol,[Maurice_R_Turcotte],[Maurice_R_Turcotte],,,,,,
+tacnews,98,tcp,TAC News,[Jon_Postel],[Jon_Postel],,,,,,
+tacnews,98,udp,TAC News,[Jon_Postel],[Jon_Postel],,,,,,
+metagram,99,tcp,Metagram Relay,[Geoff_Goodfellow],[Geoff_Goodfellow],,,,,,
+metagram,99,udp,Metagram Relay,[Geoff_Goodfellow],[Geoff_Goodfellow],,,,,,
+,100,,Unassigned,,,,2012-03-21,,,Known Unauthorized Use on 100,
+hostname,101,tcp,NIC Host Name Server,[Jon_Postel],[Jon_Postel],,,,,,
+hostname,101,udp,NIC Host Name Server,[Jon_Postel],[Jon_Postel],,,,,,
+iso-tsap,102,tcp,ISO-TSAP Class 0,[Marshall_Rose],[Marshall_Rose],,,,,,
+iso-tsap,102,udp,ISO-TSAP Class 0,[Marshall_Rose],[Marshall_Rose],,,,,,
+gppitnp,103,tcp,Genesis Point-to-Point Trans Net,,,,,,,,
+gppitnp,103,udp,Genesis Point-to-Point Trans Net,,,,,,,,
+acr-nema,104,tcp,ACR-NEMA Digital Imag. & Comm. 300,[Patrick_McNamee],[Patrick_McNamee],,,,,,
+acr-nema,104,udp,ACR-NEMA Digital Imag. & Comm. 300,[Patrick_McNamee],[Patrick_McNamee],,,,,,
+cso,105,tcp,CCSO name server protocol,[Martin_Hamilton],[Martin_Hamilton],,,,,,
+cso,105,udp,CCSO name server protocol,[Martin_Hamilton],[Martin_Hamilton],,,,,,
+csnet-ns,105,tcp,Mailbox Name Nameserver,[Marvin_Solomon],[Marvin_Solomon],,,,,,
+csnet-ns,105,udp,Mailbox Name Nameserver,[Marvin_Solomon],[Marvin_Solomon],,,,,,
+3com-tsmux,106,tcp,3COM-TSMUX,[Jeremy_Siegel],[Jeremy_Siegel],,,,,Known Unauthorized Use on 106,
+3com-tsmux,106,udp,3COM-TSMUX,[Jeremy_Siegel],[Jeremy_Siegel],,,,,Known Unauthorized Use on 106,
+rtelnet,107,tcp,Remote Telnet Service,[Jon_Postel],[Jon_Postel],,,,,,
+rtelnet,107,udp,Remote Telnet Service,[Jon_Postel],[Jon_Postel],,,,,,
+snagas,108,tcp,SNA Gateway Access Server,[Kevin_Murphy],[Kevin_Murphy],,,,,,
+snagas,108,udp,SNA Gateway Access Server,[Kevin_Murphy],[Kevin_Murphy],,,,,,
+pop2,109,tcp,Post Office Protocol - Version 2,[Joyce_K_Reynolds],[Joyce_K_Reynolds],,,,,,
+pop2,109,udp,Post Office Protocol - Version 2,[Joyce_K_Reynolds],[Joyce_K_Reynolds],,,,,,
+pop3,110,tcp,Post Office Protocol - Version 3,[Marshall_Rose],[Marshall_Rose],,,,,,
+pop3,110,udp,Post Office Protocol - Version 3,[Marshall_Rose],[Marshall_Rose],,,,,,
+sunrpc,111,tcp,SUN Remote Procedure Call,[Chuck_McManis],[Chuck_McManis],,,,,,
+sunrpc,111,udp,SUN Remote Procedure Call,[Chuck_McManis],[Chuck_McManis],,,,,,
+mcidas,112,tcp,McIDAS Data Transmission Protocol,[Glenn_Davis],[Glenn_Davis],,,,,,
+mcidas,112,udp,McIDAS Data Transmission Protocol,[Glenn_Davis],[Glenn_Davis],,,,,,
+ident,113,tcp,,,,,,,,,
+auth,113,tcp,Authentication Service,[Mike_St_Johns],[Mike_St_Johns],,,,,,
+auth,113,udp,Authentication Service,[Mike_St_Johns],[Mike_St_Johns],,,,,,
+,114,,unassigned,,,,,,,,Deprecated June 2004
+sftp,115,tcp,Simple File Transfer Protocol,[Mark_Lottor],[Mark_Lottor],,,,,,
+sftp,115,udp,Simple File Transfer Protocol,[Mark_Lottor],[Mark_Lottor],,,,,,
+ansanotify,116,tcp,ANSA REX Notify,[Nicola_J_Howarth],[Nicola_J_Howarth],,,,,,
+ansanotify,116,udp,ANSA REX Notify,[Nicola_J_Howarth],[Nicola_J_Howarth],,,,,,
+uucp-path,117,tcp,UUCP Path Service,,,,,,,,
+uucp-path,117,udp,UUCP Path Service,,,,,,,,
+sqlserv,118,tcp,SQL Services,[Larry_Barnes],[Larry_Barnes],,,,,,
+sqlserv,118,udp,SQL Services,[Larry_Barnes],[Larry_Barnes],,,,,,
+nntp,119,tcp,Network News Transfer Protocol,[Phil_Lapsley],[Phil_Lapsley],,,,,,
+nntp,119,udp,Network News Transfer Protocol,[Phil_Lapsley],[Phil_Lapsley],,,,,,
+cfdptkt,120,tcp,CFDPTKT,[John_Ioannidis],[John_Ioannidis],,,,,,
+cfdptkt,120,udp,CFDPTKT,[John_Ioannidis],[John_Ioannidis],,,,,,
+erpc,121,tcp,Encore Expedited Remote Pro.Call,[Jack_ONeil],[Jack_ONeil],,,,,,
+erpc,121,udp,Encore Expedited Remote Pro.Call,[Jack_ONeil],[Jack_ONeil],,,,,,
+smakynet,122,tcp,SMAKYNET,[Pierre_Arnaud],[Pierre_Arnaud],,,,,,
+smakynet,122,udp,SMAKYNET,[Pierre_Arnaud],[Pierre_Arnaud],,,,,,
+ntp,123,tcp,Network Time Protocol,[Dave_Mills],[Dave_Mills],,,[RFC5905],,,
+ntp,123,udp,Network Time Protocol,[Dave_Mills],[Dave_Mills],,,[RFC5905],,,
+ansatrader,124,tcp,ANSA REX Trader,[Nicola_J_Howarth],[Nicola_J_Howarth],,,,,,
+ansatrader,124,udp,ANSA REX Trader,[Nicola_J_Howarth],[Nicola_J_Howarth],,,,,,
+locus-map,125,tcp,Locus PC-Interface Net Map Ser,[Eric_Peterson],[Eric_Peterson],,,,,,
+locus-map,125,udp,Locus PC-Interface Net Map Ser,[Eric_Peterson],[Eric_Peterson],,,,,,
+nxedit,126,tcp,NXEdit,[Don_Payette],[Don_Payette],,,,,,"Port 126 Previously assigned to application below
+unitary 126/tcp Unisys Unitary Login
+unitary 126/udp Unisys Unitary Login
+<feil&kronos.nisd.cam.unisys.com>
+Port 126 Previously assigned to application above"
+nxedit,126,udp,NXEdit,[Don_Payette],[Don_Payette],,,,,,"Port 126 Previously assigned to application below
+unitary 126/tcp Unisys Unitary Login
+unitary 126/udp Unisys Unitary Login
+<feil&kronos.nisd.cam.unisys.com>
+Port 126 Previously assigned to application above"
+locus-con,127,tcp,Locus PC-Interface Conn Server,[Eric_Peterson],[Eric_Peterson],,,,,,
+locus-con,127,udp,Locus PC-Interface Conn Server,[Eric_Peterson],[Eric_Peterson],,,,,,
+gss-xlicen,128,tcp,GSS X License Verification,[John_Light],[John_Light],,,,,,
+gss-xlicen,128,udp,GSS X License Verification,[John_Light],[John_Light],,,,,,
+pwdgen,129,tcp,Password Generator Protocol,[Frank_J_Wacho],[Frank_J_Wacho],,,,,,
+pwdgen,129,udp,Password Generator Protocol,[Frank_J_Wacho],[Frank_J_Wacho],,,,,,
+cisco-fna,130,tcp,cisco FNATIVE,,,,,,,,
+cisco-fna,130,udp,cisco FNATIVE,,,,,,,,
+cisco-tna,131,tcp,cisco TNATIVE,,,,,,,,
+cisco-tna,131,udp,cisco TNATIVE,,,,,,,,
+cisco-sys,132,tcp,cisco SYSMAINT,,,,,,,,
+cisco-sys,132,udp,cisco SYSMAINT,,,,,,,,
+statsrv,133,tcp,Statistics Service,[Dave_Mills_2],[Dave_Mills_2],,,,,,
+statsrv,133,udp,Statistics Service,[Dave_Mills_2],[Dave_Mills_2],,,,,,
+ingres-net,134,tcp,INGRES-NET Service,[Mike_Berrow],[Mike_Berrow],,,,,,
+ingres-net,134,udp,INGRES-NET Service,[Mike_Berrow],[Mike_Berrow],,,,,,
+epmap,135,tcp,DCE endpoint resolution,[Joe_Pato],[Joe_Pato],,,,,,
+epmap,135,udp,DCE endpoint resolution,[Joe_Pato],[Joe_Pato],,,,,,
+profile,136,tcp,PROFILE Naming System,[Larry_Peterson],[Larry_Peterson],,,,,,
+profile,136,udp,PROFILE Naming System,[Larry_Peterson],[Larry_Peterson],,,,,,
+netbios-ns,137,tcp,NETBIOS Name Service,,,,,,,,
+netbios-ns,137,udp,NETBIOS Name Service,,,,,,,,
+netbios-dgm,138,tcp,NETBIOS Datagram Service,,,,,,,,
+netbios-dgm,138,udp,NETBIOS Datagram Service,,,,,,,,
+netbios-ssn,139,tcp,NETBIOS Session Service,[Jon_Postel],[Jon_Postel],,,,,,
+netbios-ssn,139,udp,NETBIOS Session Service,[Jon_Postel],[Jon_Postel],,,,,,
+emfis-data,140,tcp,EMFIS Data Service,,,,,,,,
+emfis-data,140,udp,EMFIS Data Service,,,,,,,,
+emfis-cntl,141,tcp,EMFIS Control Service,[Gerd_Beling],[Gerd_Beling],,,,,,
+emfis-cntl,141,udp,EMFIS Control Service,[Gerd_Beling],[Gerd_Beling],,,,,,
+bl-idm,142,tcp,Britton-Lee IDM,[Susie_Snitzer],[Susie_Snitzer],,,,,,
+bl-idm,142,udp,Britton-Lee IDM,[Susie_Snitzer],[Susie_Snitzer],,,,,,
+imap,143,tcp,Internet Message Access Protocol,[Mark_Crispin_2],[Mark_Crispin_2],,,,,,
+imap,143,udp,Internet Message Access Protocol,[Mark_Crispin_2],[Mark_Crispin_2],,,,,,
+uma,144,tcp,Universal Management Architecture,[Jay_Whitney],[Jay_Whitney],,,,,,
+uma,144,udp,Universal Management Architecture,[Jay_Whitney],[Jay_Whitney],,,,,,
+uaac,145,tcp,UAAC Protocol,[David_A_Gomberg],[David_A_Gomberg],,,,,,
+uaac,145,udp,UAAC Protocol,[David_A_Gomberg],[David_A_Gomberg],,,,,,
+iso-tp0,146,tcp,ISO-IP0,,,,,,,,
+iso-tp0,146,udp,ISO-IP0,,,,,,,,
+iso-ip,147,tcp,ISO-IP,[Marshall_Rose],[Marshall_Rose],,,,,,
+iso-ip,147,udp,ISO-IP,[Marshall_Rose],[Marshall_Rose],,,,,,
+jargon,148,tcp,Jargon,[Bill_Weinman],[Bill_Weinman],,,,,,
+jargon,148,udp,Jargon,[Bill_Weinman],[Bill_Weinman],,,,,,
+aed-512,149,tcp,AED 512 Emulation Service,[Albert_G_Broscius],[Albert_G_Broscius],,,,,,
+aed-512,149,udp,AED 512 Emulation Service,[Albert_G_Broscius],[Albert_G_Broscius],,,,,,
+sql-net,150,tcp,SQL-NET,[Martin_Picard],[Martin_Picard],,,,,,
+sql-net,150,udp,SQL-NET,[Martin_Picard],[Martin_Picard],,,,,,
+hems,151,tcp,HEMS,,,,,,,,
+hems,151,udp,HEMS,,,,,,,,
+bftp,152,tcp,Background File Transfer Program,[Annette_DeSchon],[Annette_DeSchon],,,,,,
+bftp,152,udp,Background File Transfer Program,[Annette_DeSchon],[Annette_DeSchon],,,,,,
+sgmp,153,tcp,SGMP,[Marty_Schoffstahl],[Marty_Schoffstahl],,,,,,
+sgmp,153,udp,SGMP,[Marty_Schoffstahl],[Marty_Schoffstahl],,,,,,
+netsc-prod,154,tcp,NETSC,,,,,,,,
+netsc-prod,154,udp,NETSC,,,,,,,,
+netsc-dev,155,tcp,NETSC,[Sergio_Heker],[Sergio_Heker],,,,,,
+netsc-dev,155,udp,NETSC,[Sergio_Heker],[Sergio_Heker],,,,,,
+sqlsrv,156,tcp,SQL Service,[Craig_Rogers],[Craig_Rogers],,,,,,
+sqlsrv,156,udp,SQL Service,[Craig_Rogers],[Craig_Rogers],,,,,,
+knet-cmp,157,tcp,KNET/VM Command/Message Protocol,[Gary_S_Malkin],[Gary_S_Malkin],,,,,,
+knet-cmp,157,udp,KNET/VM Command/Message Protocol,[Gary_S_Malkin],[Gary_S_Malkin],,,,,,
+pcmail-srv,158,tcp,PCMail Server,[Mark_L_Lambert],[Mark_L_Lambert],,,,,,
+pcmail-srv,158,udp,PCMail Server,[Mark_L_Lambert],[Mark_L_Lambert],,,,,,
+nss-routing,159,tcp,NSS-Routing,[Yakov_Rekhter],[Yakov_Rekhter],,,,,,
+nss-routing,159,udp,NSS-Routing,[Yakov_Rekhter],[Yakov_Rekhter],,,,,,
+sgmp-traps,160,tcp,SGMP-TRAPS,[Marty_Schoffstahl],[Marty_Schoffstahl],,,,,,
+sgmp-traps,160,udp,SGMP-TRAPS,[Marty_Schoffstahl],[Marty_Schoffstahl],,,,,,
+snmp,161,tcp,SNMP,,,,,,,,
+snmp,161,udp,SNMP,,,,,,,,
+snmptrap,162,tcp,SNMPTRAP,[Marshall_Rose],[Marshall_Rose],,,,,,
+snmptrap,162,udp,SNMPTRAP,[Marshall_Rose],[Marshall_Rose],,,,,,
+cmip-man,163,tcp,CMIP/TCP Manager,,,,,,,,
+cmip-man,163,udp,CMIP/TCP Manager,,,,,,,,
+cmip-agent,164,tcp,CMIP/TCP Agent,[Amatzia_Ben_Artzi],[Amatzia_Ben_Artzi],,,,,,
+cmip-agent,164,udp,CMIP/TCP Agent,[Amatzia_Ben_Artzi],[Amatzia_Ben_Artzi],,,,,,
+xns-courier,165,tcp,Xerox,[Susie_Armstrong_2],[Susie_Armstrong_2],,,,,,
+xns-courier,165,udp,Xerox,[Susie_Armstrong_2],[Susie_Armstrong_2],,,,,,
+s-net,166,tcp,Sirius Systems,[Brian_Lloyd],[Brian_Lloyd],,,,,,
+s-net,166,udp,Sirius Systems,[Brian_Lloyd],[Brian_Lloyd],,,,,,
+namp,167,tcp,NAMP,[Marty_Schoffstahl],[Marty_Schoffstahl],,,,,,
+namp,167,udp,NAMP,[Marty_Schoffstahl],[Marty_Schoffstahl],,,,,,
+rsvd,168,tcp,RSVD,[Alan_Sandell],[Alan_Sandell],,2008-05-01,,,,
+rsvd,168,udp,RSVD,[Alan_Sandell],[Alan_Sandell],,2008-05-01,,,,
+send,169,tcp,SEND,[William_Oldwin],[William_Oldwin],,2013-06-17,,,,
+send,169,udp,SEND,[William_Oldwin],[William_Oldwin],,2013-06-17,,,,
+print-srv,170,tcp,Network PostScript,[Brian_Reid],[Brian_Reid],,,,,,
+print-srv,170,udp,Network PostScript,[Brian_Reid],[Brian_Reid],,,,,,
+multiplex,171,tcp,Network Innovations Multiplex,,,,,,,,
+multiplex,171,udp,Network Innovations Multiplex,,,,,,,,
+cl-1,172,tcp,"Network Innovations CL/1
+IANA assigned this well-formed service name as a replacement for ""cl/1"".",[Kevin_DeVault],[Kevin_DeVault],,,,,,
+cl/1,172,tcp,Network Innovations CL/1,[Kevin_DeVault],[Kevin_DeVault],,,,,,"This entry is an alias to ""cl-1"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+cl-1,172,udp,"Network Innovations CL/1
+IANA assigned this well-formed service name as a replacement for ""cl/1"".",[Kevin_DeVault],[Kevin_DeVault],,,,,,
+cl/1,172,udp,Network Innovations CL/1,[Kevin_DeVault],[Kevin_DeVault],,,,,,"This entry is an alias to ""cl-1"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+xyplex-mux,173,tcp,Xyplex,[Bob_Stewart],[Bob_Stewart],,,,,,
+xyplex-mux,173,udp,Xyplex,[Bob_Stewart],[Bob_Stewart],,,,,,
+mailq,174,tcp,MAILQ,[Rayan_Zachariassen],[Rayan_Zachariassen],,,,,,
+mailq,174,udp,MAILQ,[Rayan_Zachariassen],[Rayan_Zachariassen],,,,,,
+vmnet,175,tcp,VMNET,[Christopher_Tengi],[Christopher_Tengi],,,,,,
+vmnet,175,udp,VMNET,[Christopher_Tengi],[Christopher_Tengi],,,,,,
+genrad-mux,176,tcp,GENRAD-MUX,[Ron_Thornton],[Ron_Thornton],,,,,,
+genrad-mux,176,udp,GENRAD-MUX,[Ron_Thornton],[Ron_Thornton],,,,,,
+xdmcp,177,tcp,X Display Manager Control Protocol,[Robert_W_Scheifler],[Robert_W_Scheifler],,,,,,
+xdmcp,177,udp,X Display Manager Control Protocol,[Robert_W_Scheifler],[Robert_W_Scheifler],,,,,,
+nextstep,178,tcp,NextStep Window Server,[Leo_Hourvitz],[Leo_Hourvitz],,,,,,
+nextstep,178,udp,NextStep Window Server,[Leo_Hourvitz],[Leo_Hourvitz],,,,,,
+bgp,179,tcp,Border Gateway Protocol,[Kirk_Lougheed],[Kirk_Lougheed],,,,,,
+bgp,179,udp,Border Gateway Protocol,[Kirk_Lougheed],[Kirk_Lougheed],,,,,,
+bgp,179,sctp,BGP,[Randall_Stewart],[Randall_Stewart],,,[RFC4960],,,
+ris,180,tcp,Intergraph,[Dave_Buehmann],[Dave_Buehmann],,,,,,
+ris,180,udp,Intergraph,[Dave_Buehmann],[Dave_Buehmann],,,,,,
+unify,181,tcp,Unify,[Daegis_Inc],[Chris_Anderson],,2012-07-31,,,,
+unify,181,udp,Unify,[Daegis_Inc],[Chris_Anderson],,2012-07-31,,,,
+audit,182,tcp,Unisys Audit SITP,[Gil_Greenbaum],[Gil_Greenbaum],,,,,,
+audit,182,udp,Unisys Audit SITP,[Gil_Greenbaum],[Gil_Greenbaum],,,,,,
+ocbinder,183,tcp,OCBinder,,,,,,,,
+ocbinder,183,udp,OCBinder,,,,,,,,
+ocserver,184,tcp,OCServer,[Jerrilynn_Okamura],[Jerrilynn_Okamura],,,,,,
+ocserver,184,udp,OCServer,[Jerrilynn_Okamura],[Jerrilynn_Okamura],,,,,,
+remote-kis,185,tcp,Remote-KIS,,,,,,,,
+remote-kis,185,udp,Remote-KIS,,,,,,,,
+kis,186,tcp,KIS Protocol,[Ralph_Droms],[Ralph_Droms],,,,,,
+kis,186,udp,KIS Protocol,[Ralph_Droms],[Ralph_Droms],,,,,,
+aci,187,tcp,Application Communication Interface,[Rick_Carlos],[Rick_Carlos],,,,,,
+aci,187,udp,Application Communication Interface,[Rick_Carlos],[Rick_Carlos],,,,,,
+mumps,188,tcp,Plus Five's MUMPS,[Hokey_Stenn],[Hokey_Stenn],,,,,,
+mumps,188,udp,Plus Five's MUMPS,[Hokey_Stenn],[Hokey_Stenn],,,,,,
+qft,189,tcp,Queued File Transport,[Wayne_Schroeder],[Wayne_Schroeder],,,,,,
+qft,189,udp,Queued File Transport,[Wayne_Schroeder],[Wayne_Schroeder],,,,,,
+gacp,190,tcp,Gateway Access Control Protocol,[C_Philip_Wood],[C_Philip_Wood],,,,,,
+gacp,190,udp,Gateway Access Control Protocol,[C_Philip_Wood],[C_Philip_Wood],,,,,,
+prospero,191,tcp,Prospero Directory Service,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,,
+prospero,191,udp,Prospero Directory Service,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,,
+osu-nms,192,tcp,OSU Network Monitoring System,[Doug_Karl],[Doug_Karl],,,,,,
+osu-nms,192,udp,OSU Network Monitoring System,[Doug_Karl],[Doug_Karl],,,,,,
+srmp,193,tcp,Spider Remote Monitoring Protocol,[Ted_J_Socolofsky],[Ted_J_Socolofsky],,,,,,
+srmp,193,udp,Spider Remote Monitoring Protocol,[Ted_J_Socolofsky],[Ted_J_Socolofsky],,,,,,
+irc,194,tcp,Internet Relay Chat Protocol,[Jarkko_Oikarinen],[Jarkko_Oikarinen],,,,,,
+irc,194,udp,Internet Relay Chat Protocol,[Jarkko_Oikarinen],[Jarkko_Oikarinen],,,,,,
+dn6-nlm-aud,195,tcp,DNSIX Network Level Module Audit,,,,,,,,
+dn6-nlm-aud,195,udp,DNSIX Network Level Module Audit,,,,,,,,
+dn6-smm-red,196,tcp,DNSIX Session Mgt Module Audit Redir,[Lawrence_Lebahn],[Lawrence_Lebahn],,,,,,
+dn6-smm-red,196,udp,DNSIX Session Mgt Module Audit Redir,[Lawrence_Lebahn],[Lawrence_Lebahn],,,,,,
+dls,197,tcp,Directory Location Service,,,,,,,,
+dls,197,udp,Directory Location Service,,,,,,,,
+dls-mon,198,tcp,Directory Location Service Monitor,[Scott_Bellew],[Scott_Bellew],,,,,,
+dls-mon,198,udp,Directory Location Service Monitor,[Scott_Bellew],[Scott_Bellew],,,,,,
+smux,199,tcp,SMUX,[Marshall_Rose],[Marshall_Rose],,,,,,
+smux,199,udp,SMUX,[Marshall_Rose],[Marshall_Rose],,,,,,
+src,200,tcp,IBM System Resource Controller,[Gerald_McBrearty],[Gerald_McBrearty],,,,,,
+src,200,udp,IBM System Resource Controller,[Gerald_McBrearty],[Gerald_McBrearty],,,,,,
+at-rtmp,201,tcp,AppleTalk Routing Maintenance,,,,,,,,
+at-rtmp,201,udp,AppleTalk Routing Maintenance,,,,,,,,
+at-nbp,202,tcp,AppleTalk Name Binding,,,,,,,,
+at-nbp,202,udp,AppleTalk Name Binding,,,,,,,,
+at-3,203,tcp,AppleTalk Unused,,,,,,,,
+at-3,203,udp,AppleTalk Unused,,,,,,,,
+at-echo,204,tcp,AppleTalk Echo,,,,,,,,
+at-echo,204,udp,AppleTalk Echo,,,,,,,,
+at-5,205,tcp,AppleTalk Unused,,,,,,,,
+at-5,205,udp,AppleTalk Unused,,,,,,,,
+at-zis,206,tcp,AppleTalk Zone Information,,,,,,,,
+at-zis,206,udp,AppleTalk Zone Information,,,,,,,,
+at-7,207,tcp,AppleTalk Unused,,,,,,,,
+at-7,207,udp,AppleTalk Unused,,,,,,,,
+at-8,208,tcp,AppleTalk Unused,[Rob_Chandhok],[Rob_Chandhok],,,,,,
+at-8,208,udp,AppleTalk Unused,[Rob_Chandhok],[Rob_Chandhok],,,,,,
+qmtp,209,tcp,The Quick Mail Transfer Protocol,[Dan_Bernstein],[Dan_Bernstein],,,,,,
+qmtp,209,udp,The Quick Mail Transfer Protocol,[Dan_Bernstein],[Dan_Bernstein],,,,,,
+z39-50,210,tcp,"ANSI Z39.50
+IANA assigned this well-formed service name as a replacement for ""z39.50"".",[Mark_H_Needleman],[Mark_H_Needleman],,,,,,
+z39.50,210,tcp,ANSI Z39.50,[Mark_H_Needleman],[Mark_H_Needleman],,,,,,"This entry is an alias to ""z39-50"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+z39-50,210,udp,"ANSI Z39.50
+IANA assigned this well-formed service name as a replacement for ""z39.50"".",[Mark_H_Needleman],[Mark_H_Needleman],,,,,,
+z39.50,210,udp,ANSI Z39.50,[Mark_H_Needleman],[Mark_H_Needleman],,,,,,"This entry is an alias to ""z39-50"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+914c-g,211,tcp,"Texas Instruments 914C/G Terminal
+IANA assigned this well-formed service name as a replacement for ""914c/g"".",[Bill_Harrell],[Bill_Harrell],,,,,,
+914c/g,211,tcp,Texas Instruments 914C/G Terminal,[Bill_Harrell],[Bill_Harrell],,,,,,"This entry is an alias to ""914c-g"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+914c-g,211,udp,"Texas Instruments 914C/G Terminal
+IANA assigned this well-formed service name as a replacement for ""914c/g"".",[Bill_Harrell],[Bill_Harrell],,,,,,
+914c/g,211,udp,Texas Instruments 914C/G Terminal,[Bill_Harrell],[Bill_Harrell],,,,,,"This entry is an alias to ""914c-g"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+anet,212,tcp,ATEXSSTR,[Jim_Taylor],[Jim_Taylor],,,,,,
+anet,212,udp,ATEXSSTR,[Jim_Taylor],[Jim_Taylor],,,,,,
+ipx,213,tcp,IPX,[Don_Provan],[Don_Provan],,,,,,
+ipx,213,udp,IPX,[Don_Provan],[Don_Provan],,,,,,
+vmpwscs,214,tcp,VM PWSCS,[Dan_Shia],[Dan_Shia],,,,,,
+vmpwscs,214,udp,VM PWSCS,[Dan_Shia],[Dan_Shia],,,,,,
+softpc,215,tcp,Insignia Solutions,[Martyn_Thomas],[Martyn_Thomas],,,,,,
+softpc,215,udp,Insignia Solutions,[Martyn_Thomas],[Martyn_Thomas],,,,,,
+CAIlic,216,tcp,Computer Associates Int'l License Server,[Chuck_Spitz],[Chuck_Spitz],,,,,,
+CAIlic,216,udp,Computer Associates Int'l License Server,[Chuck_Spitz],[Chuck_Spitz],,,,,,
+dbase,217,tcp,dBASE Unix,[Don_Gibson],[Don_Gibson],,,,,,
+dbase,217,udp,dBASE Unix,[Don_Gibson],[Don_Gibson],,,,,,
+mpp,218,tcp,Netix Message Posting Protocol,[Shannon_Yeh],[Shannon_Yeh],,,,,,
+mpp,218,udp,Netix Message Posting Protocol,[Shannon_Yeh],[Shannon_Yeh],,,,,,
+uarps,219,tcp,Unisys ARPs,[Ashok_Marwaha],[Ashok_Marwaha],,,,,,
+uarps,219,udp,Unisys ARPs,[Ashok_Marwaha],[Ashok_Marwaha],,,,,,
+imap3,220,tcp,Interactive Mail Access Protocol v3,[James_Rice],[James_Rice],,,,,,
+imap3,220,udp,Interactive Mail Access Protocol v3,[James_Rice],[James_Rice],,,,,,
+fln-spx,221,tcp,Berkeley rlogind with SPX auth,,,,,,,,
+fln-spx,221,udp,Berkeley rlogind with SPX auth,,,,,,,,
+rsh-spx,222,tcp,Berkeley rshd with SPX auth,,,,,,,,
+rsh-spx,222,udp,Berkeley rshd with SPX auth,,,,,,,,
+cdc,223,tcp,Certificate Distribution Center,[Kannan_Alagappan],[Kannan_Alagappan],,,,,,
+cdc,223,udp,Certificate Distribution Center,[Kannan_Alagappan],[Kannan_Alagappan],,,,,,
+masqdialer,224,tcp,masqdialer,[Charles_Wright],[Charles_Wright],,,,,,"Possible Conflict of Port 222 with ""Masqdialer"""
+masqdialer,224,udp,masqdialer,[Charles_Wright],[Charles_Wright],,,,,,"Possible Conflict of Port 222 with ""Masqdialer"""
+,225-241,,Reserved,[Jon_Postel],[Jon_Postel],,,,,,
+direct,242,tcp,Direct,[Herb_Sutter],[Herb_Sutter],,,,,,
+direct,242,udp,Direct,[Herb_Sutter],[Herb_Sutter],,,,,,
+sur-meas,243,tcp,Survey Measurement,[Dave_Clark],[Dave_Clark],,,,,,
+sur-meas,243,udp,Survey Measurement,[Dave_Clark],[Dave_Clark],,,,,,
+inbusiness,244,tcp,inbusiness,[Derrick_Hisatake],[Derrick_Hisatake],,,,,,
+inbusiness,244,udp,inbusiness,[Derrick_Hisatake],[Derrick_Hisatake],,,,,,
+link,245,tcp,LINK,,,,,,,,
+link,245,udp,LINK,,,,,,,,
+dsp3270,246,tcp,Display Systems Protocol,[Weldon_J_Showalter],[Weldon_J_Showalter],,,,,,
+dsp3270,246,udp,Display Systems Protocol,[Weldon_J_Showalter],[Weldon_J_Showalter],,,,,,
+subntbcst-tftp,247,tcp,"SUBNTBCST_TFTP
+IANA assigned this well-formed service name as a replacement for ""subntbcst_tftp"".",[John_Fake],[John_Fake],,,,,,
+subntbcst_tftp,247,tcp,SUBNTBCST_TFTP,[John_Fake],[John_Fake],,,,,,"This entry is an alias to ""subntbcst-tftp"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+subntbcst-tftp,247,udp,"SUBNTBCST_TFTP
+IANA assigned this well-formed service name as a replacement for ""subntbcst_tftp"".",[John_Fake],[John_Fake],,,,,,
+subntbcst_tftp,247,udp,SUBNTBCST_TFTP,[John_Fake],[John_Fake],,,,,,"This entry is an alias to ""subntbcst-tftp"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+bhfhs,248,tcp,bhfhs,[John_Kelly],[John_Kelly],,,,,,
+bhfhs,248,udp,bhfhs,[John_Kelly],[John_Kelly],,,,,,
+,249-255,,Reserved,[Jon_Postel],[Jon_Postel],,,,,,
+rap,256,tcp,RAP,[J_S_Greenfield],[J_S_Greenfield],,,,,,
+rap,256,udp,RAP,[J_S_Greenfield],[J_S_Greenfield],,,,,,
+set,257,tcp,Secure Electronic Transaction,[Donald_Eastlake],[Donald_Eastlake],,,,,,
+set,257,udp,Secure Electronic Transaction,[Donald_Eastlake],[Donald_Eastlake],,,,,,
+,258,,Unassigned,,,,2006-09-13,,,,
+esro-gen,259,tcp,Efficient Short Remote Operations,[Mohsen_Banan],[Mohsen_Banan],,,,,,
+esro-gen,259,udp,Efficient Short Remote Operations,[Mohsen_Banan],[Mohsen_Banan],,,,,,
+openport,260,tcp,Openport,[John_Marland],[John_Marland],,,,,,
+openport,260,udp,Openport,[John_Marland],[John_Marland],,,,,,
+nsiiops,261,tcp,IIOP Name Service over TLS/SSL,[Jeff_Stewart],[Jeff_Stewart],,,,,,
+nsiiops,261,udp,IIOP Name Service over TLS/SSL,[Jeff_Stewart],[Jeff_Stewart],,,,,,
+arcisdms,262,tcp,Arcisdms,[Russell_Crook],[Russell_Crook],,,,,,
+arcisdms,262,udp,Arcisdms,[Russell_Crook],[Russell_Crook],,,,,,
+hdap,263,tcp,HDAP,[Troy_Gau],[Troy_Gau],,,,,,
+hdap,263,udp,HDAP,[Troy_Gau],[Troy_Gau],,,,,,
+bgmp,264,tcp,BGMP,[Dave_Thaler],[Dave_Thaler],,,,,,
+bgmp,264,udp,BGMP,[Dave_Thaler],[Dave_Thaler],,,,,,
+x-bone-ctl,265,tcp,X-Bone CTL,[Joe_Touch],[Joe_Touch],,,,,,
+x-bone-ctl,265,udp,X-Bone CTL,[Joe_Touch],[Joe_Touch],,,,,,
+sst,266,tcp,SCSI on ST,[Donald_D_Woelz],[Donald_D_Woelz],,,,,,
+sst,266,udp,SCSI on ST,[Donald_D_Woelz],[Donald_D_Woelz],,,,,,
+td-service,267,tcp,Tobit David Service Layer,,,,,,,,
+td-service,267,udp,Tobit David Service Layer,,,,,,,,
+td-replica,268,tcp,Tobit David Replica,[Franz_Josef_Leuders],[Franz_Josef_Leuders],,,,,,
+td-replica,268,udp,Tobit David Replica,[Franz_Josef_Leuders],[Franz_Josef_Leuders],,,,,,
+manet,269,tcp,MANET Protocols,,,,,[RFC5498],,,
+manet,269,udp,MANET Protocols,,,,,[RFC5498],,,
+,270,tcp,Reserved,,,,,,,,
+gist,270,udp,Q-mode encapsulation for GIST messages,,,,,[RFC5971],,,
+pt-tls,271,tcp,IETF Network Endpoint Assessment (NEA) Posture Transport Protocol over TLS (PT-TLS),[IESG],[IETF_Chair],2012-07-31,,[RFC6876],,,
+,271,udp,Reserved,,,,,,,,
+,272-279,,Unassigned,,,,,,,,
+http-mgmt,280,tcp,http-mgmt,[Adrian_Pell],[Adrian_Pell],,,,,,
+http-mgmt,280,udp,http-mgmt,[Adrian_Pell],[Adrian_Pell],,,,,,
+personal-link,281,tcp,Personal Link,[Dan_Cummings],[Dan_Cummings],,,,,,
+personal-link,281,udp,Personal Link,[Dan_Cummings],[Dan_Cummings],,,,,,
+cableport-ax,282,tcp,Cable Port A/X,[Craig_Langfahl],[Craig_Langfahl],,,,,,
+cableport-ax,282,udp,Cable Port A/X,[Craig_Langfahl],[Craig_Langfahl],,,,,,
+rescap,283,tcp,rescap,[Paul_Hoffman],[Paul_Hoffman],,,,,,
+rescap,283,udp,rescap,[Paul_Hoffman],[Paul_Hoffman],,,,,,
+corerjd,284,tcp,corerjd,[Chris_Thornhill],[Chris_Thornhill],,,,,,
+corerjd,284,udp,corerjd,[Chris_Thornhill],[Chris_Thornhill],,,,,,
+,285,,Unassigned,,,,,,,,
+fxp,286,tcp,FXP Communication,[James_Darnall],[James_Darnall],,,,,,
+fxp,286,udp,FXP Communication,[James_Darnall],[James_Darnall],,,,,,
+k-block,287,tcp,K-BLOCK,[Simon_P_Jackson],[Simon_P_Jackson],,,,,,
+k-block,287,udp,K-BLOCK,[Simon_P_Jackson],[Simon_P_Jackson],,,,,,
+,288-307,,Unassigned,,,,,,,,
+novastorbakcup,308,tcp,Novastor Backup,[Brian_Dickman],[Brian_Dickman],,,,,,
+novastorbakcup,308,udp,Novastor Backup,[Brian_Dickman],[Brian_Dickman],,,,,,
+entrusttime,309,tcp,EntrustTime,[Peter_Whittaker],[Peter_Whittaker],,,,,,
+entrusttime,309,udp,EntrustTime,[Peter_Whittaker],[Peter_Whittaker],,,,,,
+bhmds,310,tcp,bhmds,[John_Kelly],[John_Kelly],,,,,,
+bhmds,310,udp,bhmds,[John_Kelly],[John_Kelly],,,,,,
+asip-webadmin,311,tcp,AppleShare IP WebAdmin,[Ann_Huang],[Ann_Huang],,,,,,
+asip-webadmin,311,udp,AppleShare IP WebAdmin,[Ann_Huang],[Ann_Huang],,,,,,
+vslmp,312,tcp,VSLMP,[Gerben_Wierda],[Gerben_Wierda],,,,,,
+vslmp,312,udp,VSLMP,[Gerben_Wierda],[Gerben_Wierda],,,,,,
+magenta-logic,313,tcp,Magenta Logic,[Karl_Rousseau],[Karl_Rousseau],,,,,,
+magenta-logic,313,udp,Magenta Logic,[Karl_Rousseau],[Karl_Rousseau],,,,,,
+opalis-robot,314,tcp,Opalis Robot,[Laurent_Domenech],[Laurent_Domenech],,,,,,
+opalis-robot,314,udp,Opalis Robot,[Laurent_Domenech],[Laurent_Domenech],,,,,,
+dpsi,315,tcp,DPSI,[Tony_Scamurra],[Tony_Scamurra],,,,,,
+dpsi,315,udp,DPSI,[Tony_Scamurra],[Tony_Scamurra],,,,,,
+decauth,316,tcp,decAuth,[Michael_Agishtein],[Michael_Agishtein],,,,,,
+decauth,316,udp,decAuth,[Michael_Agishtein],[Michael_Agishtein],,,,,,
+zannet,317,tcp,Zannet,[Zan_Oliphant],[Zan_Oliphant],,,,,,
+zannet,317,udp,Zannet,[Zan_Oliphant],[Zan_Oliphant],,,,,,
+pkix-timestamp,318,tcp,PKIX TimeStamp,[Robert_Zuccherato],[Robert_Zuccherato],,,,,,
+pkix-timestamp,318,udp,PKIX TimeStamp,[Robert_Zuccherato],[Robert_Zuccherato],,,,,,
+ptp-event,319,tcp,PTP Event,[Kang_Lee],[Kang_Lee],2010-07-27,,,,,
+ptp-event,319,udp,PTP Event,[Kang_Lee],[Kang_Lee],2010-07-27,,,,,
+ptp-general,320,tcp,PTP General,[Kang_Lee],[Kang_Lee],2010-07-27,,,,,
+ptp-general,320,udp,PTP General,[Kang_Lee],[Kang_Lee],2010-07-27,,,,,
+pip,321,tcp,PIP,[Gordon_Mohr],[Gordon_Mohr],,,,,,
+pip,321,udp,PIP,[Gordon_Mohr],[Gordon_Mohr],,,,,,
+rtsps,322,tcp,RTSPS,[Anders_Klemets],[Anders_Klemets],,,,,,
+rtsps,322,udp,RTSPS,[Anders_Klemets],[Anders_Klemets],,,,,,
+rpki-rtr,323,tcp,Resource PKI to Router Protocol,[IESG],[IETF_Chair],,,[RFC6810],,,
+,323,udp,Reserved,,,,,,,,
+rpki-rtr-tls,324,tcp,Resource PKI to Router Protocol over TLS,[IESG],[IETF_Chair],,,[RFC6810],,,
+,324,udp,Reserved,,,,,,,,
+,325-332,,Unassigned,,,,,,,,
+texar,333,tcp,Texar Security Port,[Eugen_Bacic],[Eugen_Bacic],,,,,,
+texar,333,udp,Texar Security Port,[Eugen_Bacic],[Eugen_Bacic],,,,,,
+,334-343,,Unassigned,,,,,,,,
+pdap,344,tcp,Prospero Data Access Protocol,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,,
+pdap,344,udp,Prospero Data Access Protocol,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,,
+pawserv,345,tcp,Perf Analysis Workbench,,,,,,,,
+pawserv,345,udp,Perf Analysis Workbench,,,,,,,,
+zserv,346,tcp,Zebra server,,,,,,,,
+zserv,346,udp,Zebra server,,,,,,,,
+fatserv,347,tcp,Fatmen Server,,,,,,,,
+fatserv,347,udp,Fatmen Server,,,,,,,,
+csi-sgwp,348,tcp,Cabletron Management Protocol,,,,,,,,
+csi-sgwp,348,udp,Cabletron Management Protocol,,,,,,,,
+mftp,349,tcp,mftp,[Dave_Feinleib],[Dave_Feinleib],,,,,,
+mftp,349,udp,mftp,[Dave_Feinleib],[Dave_Feinleib],,,,,,
+matip-type-a,350,tcp,MATIP Type A,[Alain_Robert],[Alain_Robert],,,[RFC2351],,,
+matip-type-a,350,udp,MATIP Type A,[Alain_Robert],[Alain_Robert],,,[RFC2351],,,
+matip-type-b,351,tcp,MATIP Type B,[Alain_Robert],[Alain_Robert],,,[RFC2351],,,
+matip-type-b,351,udp,MATIP Type B,[Alain_Robert],[Alain_Robert],,,[RFC2351],,,
+bhoetty,351,tcp,bhoetty,[John_Kelly],[John_Kelly],,,,,,"This entry records an unassigned but widespread use
+(added 5/21/97)"
+bhoetty,351,udp,bhoetty,[John_Kelly],[John_Kelly],,,,,,"This entry records an unassigned but widespread use
+(added 5/21/97)"
+dtag-ste-sb,352,tcp,DTAG,[Ruediger_Wald],[Ruediger_Wald],,,,,,(assigned long ago)
+dtag-ste-sb,352,udp,DTAG,[Ruediger_Wald],[Ruediger_Wald],,,,,,(assigned long ago)
+bhoedap4,352,tcp,bhoedap4,[John_Kelly],[John_Kelly],,,,,,"This entry records an unassigned but widespread use
+(added 5/21/97)"
+bhoedap4,352,udp,bhoedap4,[John_Kelly],[John_Kelly],,,,,,"This entry records an unassigned but widespread use
+(added 5/21/97)"
+ndsauth,353,tcp,NDSAUTH,[Jayakumar_Ramalingam],[Jayakumar_Ramalingam],,,,,,
+ndsauth,353,udp,NDSAUTH,[Jayakumar_Ramalingam],[Jayakumar_Ramalingam],,,,,,
+bh611,354,tcp,bh611,[John_Kelly],[John_Kelly],,,,,,
+bh611,354,udp,bh611,[John_Kelly],[John_Kelly],,,,,,
+datex-asn,355,tcp,DATEX-ASN,[Kenneth_Vaughn],[Kenneth_Vaughn],,,,,,
+datex-asn,355,udp,DATEX-ASN,[Kenneth_Vaughn],[Kenneth_Vaughn],,,,,,
+cloanto-net-1,356,tcp,Cloanto Net 1,[Michael_Battilana],[Michael_Battilana],2010-04-30,,,,,
+cloanto-net-1,356,udp,Cloanto Net 1,[Michael_Battilana],[Michael_Battilana],2010-04-30,,,,,
+bhevent,357,tcp,bhevent,[John_Kelly],[John_Kelly],,,,,,
+bhevent,357,udp,bhevent,[John_Kelly],[John_Kelly],,,,,,
+shrinkwrap,358,tcp,Shrinkwrap,[Bill_Simpson],[Bill_Simpson],,,,,,
+shrinkwrap,358,udp,Shrinkwrap,[Bill_Simpson],[Bill_Simpson],,,,,,
+nsrmp,359,tcp,Network Security Risk Management Protocol,[Eric_Jacksch],[Eric_Jacksch],,,,,,
+nsrmp,359,udp,Network Security Risk Management Protocol,[Eric_Jacksch],[Eric_Jacksch],,,,,,
+scoi2odialog,360,tcp,scoi2odialog,[Keith_Petley],[Keith_Petley],,,,,,
+scoi2odialog,360,udp,scoi2odialog,[Keith_Petley],[Keith_Petley],,,,,,
+semantix,361,tcp,Semantix,[Semantix],[Semantix],,,,,,
+semantix,361,udp,Semantix,[Semantix],[Semantix],,,,,,
+srssend,362,tcp,SRS Send,[Curt_Mayer],[Curt_Mayer],,,,,,
+srssend,362,udp,SRS Send,[Curt_Mayer],[Curt_Mayer],,,,,,
+rsvp-tunnel,363,tcp,"RSVP Tunnel
+IANA assigned this well-formed service name as a replacement for ""rsvp_tunnel"".",[Andreas_Terzis],[Andreas_Terzis],,,,,,
+rsvp_tunnel,363,tcp,RSVP Tunnel,[Andreas_Terzis],[Andreas_Terzis],,,,,,"This entry is an alias to ""rsvp-tunnel"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+rsvp-tunnel,363,udp,"RSVP Tunnel
+IANA assigned this well-formed service name as a replacement for ""rsvp_tunnel"".",[Andreas_Terzis],[Andreas_Terzis],,,,,,
+rsvp_tunnel,363,udp,RSVP Tunnel,[Andreas_Terzis],[Andreas_Terzis],,,,,,"This entry is an alias to ""rsvp-tunnel"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+aurora-cmgr,364,tcp,Aurora CMGR,[Philip_Budne],[Philip_Budne],,,,,,
+aurora-cmgr,364,udp,Aurora CMGR,[Philip_Budne],[Philip_Budne],,,,,,
+dtk,365,tcp,DTK,[Fred_Cohen],[Fred_Cohen],,,,,,
+dtk,365,udp,DTK,[Fred_Cohen],[Fred_Cohen],,,,,,
+odmr,366,tcp,ODMR,[Randall_Gellens],[Randall_Gellens],,,,,,
+odmr,366,udp,ODMR,[Randall_Gellens],[Randall_Gellens],,,,,,
+mortgageware,367,tcp,MortgageWare,[Ole_Hellevik],[Ole_Hellevik],,,,,,
+mortgageware,367,udp,MortgageWare,[Ole_Hellevik],[Ole_Hellevik],,,,,,
+qbikgdp,368,tcp,QbikGDP,[Adrien_de_Croy],[Adrien_de_Croy],,,,,,
+qbikgdp,368,udp,QbikGDP,[Adrien_de_Croy],[Adrien_de_Croy],,,,,,
+rpc2portmap,369,tcp,rpc2portmap,,,,,,,,
+rpc2portmap,369,udp,rpc2portmap,,,,,,,,
+codaauth2,370,tcp,codaauth2,[Robert_Watson],[Robert_Watson],,,,,,
+codaauth2,370,udp,codaauth2,[Robert_Watson],[Robert_Watson],,,,,,
+clearcase,371,tcp,Clearcase,[Dave_LeBlang],[Dave_LeBlang],,,,,,
+clearcase,371,udp,Clearcase,[Dave_LeBlang],[Dave_LeBlang],,,,,,
+ulistproc,372,tcp,ListProcessor,[Anastasios_Kotsikona],[Anastasios_Kotsikona],,,,,,
+ulistproc,372,udp,ListProcessor,[Anastasios_Kotsikona],[Anastasios_Kotsikona],,,,,,
+legent-1,373,tcp,Legent Corporation,,,,,,,,
+legent-1,373,udp,Legent Corporation,,,,,,,,
+legent-2,374,tcp,Legent Corporation,[Keith_Boyce],[Keith_Boyce],,,,,,
+legent-2,374,udp,Legent Corporation,[Keith_Boyce],[Keith_Boyce],,,,,,
+hassle,375,tcp,Hassle,[Reinhard_Doelz],[Reinhard_Doelz],,,,,,
+hassle,375,udp,Hassle,[Reinhard_Doelz],[Reinhard_Doelz],,,,,,
+nip,376,tcp,Amiga Envoy Network Inquiry Proto,[Heinz_Wrobel],[Heinz_Wrobel],,,,,,
+nip,376,udp,Amiga Envoy Network Inquiry Proto,[Heinz_Wrobel],[Heinz_Wrobel],,,,,,
+tnETOS,377,tcp,NEC Corporation,,,,,,,,
+tnETOS,377,udp,NEC Corporation,,,,,,,,
+dsETOS,378,tcp,NEC Corporation,[Tomoo_Fujita],[Tomoo_Fujita],,,,,,
+dsETOS,378,udp,NEC Corporation,[Tomoo_Fujita],[Tomoo_Fujita],,,,,,
+is99c,379,tcp,TIA/EIA/IS-99 modem client,,,,,,,,
+is99c,379,udp,TIA/EIA/IS-99 modem client,,,,,,,,
+is99s,380,tcp,TIA/EIA/IS-99 modem server,[Frank_Quick],[Frank_Quick],,,,,,
+is99s,380,udp,TIA/EIA/IS-99 modem server,[Frank_Quick],[Frank_Quick],,,,,,
+hp-collector,381,tcp,hp performance data collector,,,,,,,,
+hp-collector,381,udp,hp performance data collector,,,,,,,,
+hp-managed-node,382,tcp,hp performance data managed node,,,,,,,,
+hp-managed-node,382,udp,hp performance data managed node,,,,,,,,
+hp-alarm-mgr,383,tcp,hp performance data alarm manager,[Frank_Blakely],[Frank_Blakely],,,,,,
+hp-alarm-mgr,383,udp,hp performance data alarm manager,[Frank_Blakely],[Frank_Blakely],,,,,,
+arns,384,tcp,A Remote Network Server System,[David_Hornsby],[David_Hornsby],,,,,,
+arns,384,udp,A Remote Network Server System,[David_Hornsby],[David_Hornsby],,,,,,
+ibm-app,385,tcp,IBM Application,[Lisa_Tomita],[Lisa_Tomita],,,,,,
+ibm-app,385,udp,IBM Application,[Lisa_Tomita],[Lisa_Tomita],,,,,,
+asa,386,tcp,ASA Message Router Object Def.,[Steve_Laitinen],[Steve_Laitinen],,,,,,
+asa,386,udp,ASA Message Router Object Def.,[Steve_Laitinen],[Steve_Laitinen],,,,,,
+aurp,387,tcp,Appletalk Update-Based Routing Pro.,[Chris_Ranch],[Chris_Ranch],,,,,,
+aurp,387,udp,Appletalk Update-Based Routing Pro.,[Chris_Ranch],[Chris_Ranch],,,,,,
+unidata-ldm,388,tcp,Unidata LDM,[University_Corporation_for_Atmospheric_Research2],[Steven_Emmerson2],,2012-05-18,,,,
+unidata-ldm,388,udp,Unidata LDM,[University_Corporation_for_Atmospheric_Research2],[Steven_Emmerson2],,2012-05-18,,,,
+ldap,389,tcp,Lightweight Directory Access Protocol,[Tim_Howes],[Tim_Howes],,,,,,
+ldap,389,udp,Lightweight Directory Access Protocol,[Tim_Howes],[Tim_Howes],,,,,,
+uis,390,tcp,UIS,[Ed_Barron],[Ed_Barron],,,,,,
+uis,390,udp,UIS,[Ed_Barron],[Ed_Barron],,,,,,
+synotics-relay,391,tcp,SynOptics SNMP Relay Port,,,,,,,,
+synotics-relay,391,udp,SynOptics SNMP Relay Port,,,,,,,,
+synotics-broker,392,tcp,SynOptics Port Broker Port,[Illan_Raab],[Illan_Raab],,,,,,
+synotics-broker,392,udp,SynOptics Port Broker Port,[Illan_Raab],[Illan_Raab],,,,,,
+meta5,393,tcp,Meta5,[Jim_Kanzler],[Jim_Kanzler],,,,,,
+meta5,393,udp,Meta5,[Jim_Kanzler],[Jim_Kanzler],,,,,,
+embl-ndt,394,tcp,EMBL Nucleic Data Transfer,[Peter_Gad],[Peter_Gad],,,,,,
+embl-ndt,394,udp,EMBL Nucleic Data Transfer,[Peter_Gad],[Peter_Gad],,,,,,
+netcp,395,tcp,NetScout Control Protocol,[Ashwani_Singhal],[Ashwani_Singhal],2010-04-07,,,,,
+netcp,395,udp,NetScout Control Protocol,[Ashwani_Singhal],[Ashwani_Singhal],2010-04-07,,,,,
+netware-ip,396,tcp,Novell Netware over IP,,,,,,,,
+netware-ip,396,udp,Novell Netware over IP,,,,,,,,
+mptn,397,tcp,Multi Protocol Trans. Net.,[Soumitra_Sarkar],[Soumitra_Sarkar],,,,,,
+mptn,397,udp,Multi Protocol Trans. Net.,[Soumitra_Sarkar],[Soumitra_Sarkar],,,,,,
+kryptolan,398,tcp,Kryptolan,[Peter_de_Laval],[Peter_de_Laval],,,,,,
+kryptolan,398,udp,Kryptolan,[Peter_de_Laval],[Peter_de_Laval],,,,,,
+iso-tsap-c2,399,tcp,ISO Transport Class 2 Non-Control over TCP,[Yanick_Pouffary],[Yanick_Pouffary],,,,,,
+iso-tsap-c2,399,udp,ISO Transport Class 2 Non-Control over UDP,[Yanick_Pouffary],[Yanick_Pouffary],,,,,,
+osb-sd,400,tcp,Oracle Secure Backup,[Joseph_Dziedzic],[Joseph_Dziedzic],2008-06-06,,,,,Formerly was Workstation Solutions
+osb-sd,400,udp,Oracle Secure Backup,[Joseph_Dziedzic],[Joseph_Dziedzic],2008-06-06,,,,,Formerly was Workstation Solutions
+ups,401,tcp,Uninterruptible Power Supply,[Charles_Bennett],[Charles_Bennett],2008-08-29,,,,,
+ups,401,udp,Uninterruptible Power Supply,[Charles_Bennett],[Charles_Bennett],2008-08-29,,,,,
+genie,402,tcp,Genie Protocol,[Mark_Hankin],[Mark_Hankin],,,,,,
+genie,402,udp,Genie Protocol,[Mark_Hankin],[Mark_Hankin],,,,,,
+decap,403,tcp,decap,,,,,,,,
+decap,403,udp,decap,,,,,,,,
+nced,404,tcp,nced,,,,,,,,
+nced,404,udp,nced,,,,,,,,
+ncld,405,tcp,ncld,[Richard_Jones],[Richard_Jones],,,,,,
+ncld,405,udp,ncld,[Richard_Jones],[Richard_Jones],,,,,,
+imsp,406,tcp,Interactive Mail Support Protocol,[John_Myers],[John_Myers],,,,,,
+imsp,406,udp,Interactive Mail Support Protocol,[John_Myers],[John_Myers],,,,,,
+timbuktu,407,tcp,Timbuktu,[Marc_Epard],[Marc_Epard],,,,,,
+timbuktu,407,udp,Timbuktu,[Marc_Epard],[Marc_Epard],,,,,,
+prm-sm,408,tcp,Prospero Resource Manager Sys. Man.,,,,,,,,
+prm-sm,408,udp,Prospero Resource Manager Sys. Man.,,,,,,,,
+prm-nm,409,tcp,Prospero Resource Manager Node Man.,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,,
+prm-nm,409,udp,Prospero Resource Manager Node Man.,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,,
+decladebug,410,tcp,DECLadebug Remote Debug Protocol,[Hewlett_Packard],[Hewlett_Packard],,,,,,
+decladebug,410,udp,DECLadebug Remote Debug Protocol,[Hewlett_Packard],[Hewlett_Packard],,,,,,
+rmt,411,tcp,Remote MT Protocol,[Peter_Eriksson],[Peter_Eriksson],,,,,,
+rmt,411,udp,Remote MT Protocol,[Peter_Eriksson],[Peter_Eriksson],,,,,,
+synoptics-trap,412,tcp,Trap Convention Port,[Illan_Raab],[Illan_Raab],,,,,,
+synoptics-trap,412,udp,Trap Convention Port,[Illan_Raab],[Illan_Raab],,,,,,
+smsp,413,tcp,Storage Management Services Protocol,[Murthy_Srinivas],[Murthy_Srinivas],,,,,,
+smsp,413,udp,Storage Management Services Protocol,[Murthy_Srinivas],[Murthy_Srinivas],,,,,,
+infoseek,414,tcp,InfoSeek,[Steve_Kirsch],[Steve_Kirsch],,,,,,
+infoseek,414,udp,InfoSeek,[Steve_Kirsch],[Steve_Kirsch],,,,,,
+bnet,415,tcp,BNet,[Jim_Mertz],[Jim_Mertz],,,,,,
+bnet,415,udp,BNet,[Jim_Mertz],[Jim_Mertz],,,,,,
+silverplatter,416,tcp,Silverplatter,[Peter_Ciuffetti],[Peter_Ciuffetti],,,,,,
+silverplatter,416,udp,Silverplatter,[Peter_Ciuffetti],[Peter_Ciuffetti],,,,,,
+onmux,417,tcp,Onmux,[Stephen_Hanna],[Stephen_Hanna],,,,,,
+onmux,417,udp,Onmux,[Stephen_Hanna],[Stephen_Hanna],,,,,,
+hyper-g,418,tcp,Hyper-G,[Frank_Kappe],[Frank_Kappe],,,,,,
+hyper-g,418,udp,Hyper-G,[Frank_Kappe],[Frank_Kappe],,,,,,
+ariel1,419,tcp,Ariel 1,[Joel_Karafin],[Joel_Karafin],,,,,,
+ariel1,419,udp,Ariel 1,[Joel_Karafin],[Joel_Karafin],,,,,,
+smpte,420,tcp,SMPTE,[Si_Becker],[Si_Becker],,,,,,
+smpte,420,udp,SMPTE,[Si_Becker],[Si_Becker],,,,,,
+ariel2,421,tcp,Ariel 2,,,,,,,,
+ariel2,421,udp,Ariel 2,,,,,,,,
+ariel3,422,tcp,Ariel 3,[Joel_Karafin],[Joel_Karafin],,,,,,
+ariel3,422,udp,Ariel 3,[Joel_Karafin],[Joel_Karafin],,,,,,
+opc-job-start,423,tcp,IBM Operations Planning and Control Start,,,,,,,,
+opc-job-start,423,udp,IBM Operations Planning and Control Start,,,,,,,,
+opc-job-track,424,tcp,IBM Operations Planning and Control Track,[Conny_Larsson],[Conny_Larsson],,,,,,
+opc-job-track,424,udp,IBM Operations Planning and Control Track,[Conny_Larsson],[Conny_Larsson],,,,,,
+icad-el,425,tcp,ICAD,[Larry_Stone],[Larry_Stone],,,,,,
+icad-el,425,udp,ICAD,[Larry_Stone],[Larry_Stone],,,,,,
+smartsdp,426,tcp,smartsdp,[Marie_Pierre_Belange],[Marie_Pierre_Belange],,,,,,
+smartsdp,426,udp,smartsdp,[Marie_Pierre_Belange],[Marie_Pierre_Belange],,,,,,
+svrloc,427,tcp,Server Location,[Veizades],[Veizades],,,,,,
+svrloc,427,udp,Server Location,[Veizades],[Veizades],,,,,,
+ocs-cmu,428,tcp,"OCS_CMU
+IANA assigned this well-formed service name as a replacement for ""ocs_cmu"".",,,,,,,,
+ocs_cmu,428,tcp,OCS_CMU,,,,,,,,"This entry is an alias to ""ocs-cmu"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+ocs-cmu,428,udp,"OCS_CMU
+IANA assigned this well-formed service name as a replacement for ""ocs_cmu"".",,,,,,,,
+ocs_cmu,428,udp,OCS_CMU,,,,,,,,"This entry is an alias to ""ocs-cmu"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+ocs-amu,429,tcp,"OCS_AMU
+IANA assigned this well-formed service name as a replacement for ""ocs_amu"".",[Florence_Wyman],[Florence_Wyman],,,,,,
+ocs_amu,429,tcp,OCS_AMU,[Florence_Wyman],[Florence_Wyman],,,,,,"This entry is an alias to ""ocs-amu"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+ocs-amu,429,udp,"OCS_AMU
+IANA assigned this well-formed service name as a replacement for ""ocs_amu"".",[Florence_Wyman],[Florence_Wyman],,,,,,
+ocs_amu,429,udp,OCS_AMU,[Florence_Wyman],[Florence_Wyman],,,,,,"This entry is an alias to ""ocs-amu"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+utmpsd,430,tcp,UTMPSD,,,,,,,,
+utmpsd,430,udp,UTMPSD,,,,,,,,
+utmpcd,431,tcp,UTMPCD,,,,,,,,
+utmpcd,431,udp,UTMPCD,,,,,,,,
+iasd,432,tcp,IASD,[Nir_Baroz],[Nir_Baroz],,,,,,
+iasd,432,udp,IASD,[Nir_Baroz],[Nir_Baroz],,,,,,
+nnsp,433,tcp,NNSP,[Rob_Robertson],[Rob_Robertson],,,,,,
+nnsp,433,udp,NNSP,[Rob_Robertson],[Rob_Robertson],,,,,,
+mobileip-agent,434,tcp,MobileIP-Agent,,,,,,,,
+mobileip-agent,434,udp,MobileIP-Agent,,,,,,,,
+mobilip-mn,435,tcp,MobilIP-MN,[Kannan_Alagappan_2],[Kannan_Alagappan_2],,,,,,
+mobilip-mn,435,udp,MobilIP-MN,[Kannan_Alagappan_2],[Kannan_Alagappan_2],,,,,,
+dna-cml,436,tcp,DNA-CML,[Dan_Flowers],[Dan_Flowers],,,,,,
+dna-cml,436,udp,DNA-CML,[Dan_Flowers],[Dan_Flowers],,,,,,
+comscm,437,tcp,comscm,[Jim_Teague],[Jim_Teague],,,,,,
+comscm,437,udp,comscm,[Jim_Teague],[Jim_Teague],,,,,,
+dsfgw,438,tcp,dsfgw,[Andy_McKeen],[Andy_McKeen],,,,,,
+dsfgw,438,udp,dsfgw,[Andy_McKeen],[Andy_McKeen],,,,,,
+dasp,439,tcp,dasp,[Thomas_Obermair],[Thomas_Obermair],,,,,,
+dasp,439,udp,dasp,[Thomas_Obermair],[Thomas_Obermair],,,,,,
+sgcp,440,tcp,sgcp,[Marshall_Rose],[Marshall_Rose],,,,,,
+sgcp,440,udp,sgcp,[Marshall_Rose],[Marshall_Rose],,,,,,
+decvms-sysmgt,441,tcp,decvms-sysmgt,[Lee_Barton],[Lee_Barton],,,,,,
+decvms-sysmgt,441,udp,decvms-sysmgt,[Lee_Barton],[Lee_Barton],,,,,,
+cvc-hostd,442,tcp,"cvc_hostd
+IANA assigned this well-formed service name as a replacement for ""cvc_hostd"".",[Bill_Davidson],[Bill_Davidson],,,,,,
+cvc_hostd,442,tcp,cvc_hostd,[Bill_Davidson],[Bill_Davidson],,,,,,"This entry is an alias to ""cvc-hostd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+cvc-hostd,442,udp,"cvc_hostd
+IANA assigned this well-formed service name as a replacement for ""cvc_hostd"".",[Bill_Davidson],[Bill_Davidson],,,,,,
+cvc_hostd,442,udp,cvc_hostd,[Bill_Davidson],[Bill_Davidson],,,,,,"This entry is an alias to ""cvc-hostd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+https,443,tcp,http protocol over TLS/SSL,[Kipp_E_B_Hickman],[Kipp_E_B_Hickman],,,,,,
+https,443,udp,http protocol over TLS/SSL,[Kipp_E_B_Hickman],[Kipp_E_B_Hickman],,,,,,
+https,443,sctp,HTTPS,[Randall_Stewart],[Randall_Stewart],,,[RFC4960],,,
+snpp,444,tcp,Simple Network Paging Protocol,,,,,[RFC1568],,,
+snpp,444,udp,Simple Network Paging Protocol,,,,,[RFC1568],,,
+microsoft-ds,445,tcp,Microsoft-DS,[Pradeep_Bahl],[Pradeep_Bahl],,,,,,
+microsoft-ds,445,udp,Microsoft-DS,[Pradeep_Bahl],[Pradeep_Bahl],,,,,,
+ddm-rdb,446,tcp,DDM-Remote Relational Database Access,,,,,,,,
+ddm-rdb,446,udp,DDM-Remote Relational Database Access,,,,,,,,
+ddm-dfm,447,tcp,DDM-Distributed File Management,[Steven_Ritland],[Steven_Ritland],,,,,,
+ddm-dfm,447,udp,DDM-Distributed File Management,[Steven_Ritland],[Steven_Ritland],,,,,,
+ddm-ssl,448,tcp,DDM-Remote DB Access Using Secure Sockets,[Steven_Ritland],[Steven_Ritland],,,,,,
+ddm-ssl,448,udp,DDM-Remote DB Access Using Secure Sockets,[Steven_Ritland],[Steven_Ritland],,,,,,
+as-servermap,449,tcp,AS Server Mapper,[Barbara_Foss],[Barbara_Foss],,,,,,
+as-servermap,449,udp,AS Server Mapper,[Barbara_Foss],[Barbara_Foss],,,,,,
+tserver,450,tcp,Computer Supported Telecomunication Applications,[Harvey_S_Schultz],[Harvey_S_Schultz],,,,,,
+tserver,450,udp,Computer Supported Telecomunication Applications,[Harvey_S_Schultz],[Harvey_S_Schultz],,,,,,
+sfs-smp-net,451,tcp,Cray Network Semaphore server,,,,,,,,
+sfs-smp-net,451,udp,Cray Network Semaphore server,,,,,,,,
+sfs-config,452,tcp,Cray SFS config server,[Walter_Poxon],[Walter_Poxon],,,,,,
+sfs-config,452,udp,Cray SFS config server,[Walter_Poxon],[Walter_Poxon],,,,,,
+creativeserver,453,tcp,CreativeServer,,,,,,,,
+creativeserver,453,udp,CreativeServer,,,,,,,,
+contentserver,454,tcp,ContentServer,,,,,,,,
+contentserver,454,udp,ContentServer,,,,,,,,
+creativepartnr,455,tcp,CreativePartnr,[Jesus_Ortiz],[Jesus_Ortiz],,,,,,
+creativepartnr,455,udp,CreativePartnr,[Jesus_Ortiz],[Jesus_Ortiz],,,,,,
+macon-tcp,456,tcp,macon-tcp,[Yoshinobu_Inoue],[Yoshinobu_Inoue],,,,,,
+macon-udp,456,udp,macon-udp,[Yoshinobu_Inoue],[Yoshinobu_Inoue],,,,,,
+scohelp,457,tcp,scohelp,[Faith_Zack],[Faith_Zack],,,,,,
+scohelp,457,udp,scohelp,[Faith_Zack],[Faith_Zack],,,,,,
+appleqtc,458,tcp,apple quick time,[Murali_Ranganathan],[Murali_Ranganathan],,,,,,
+appleqtc,458,udp,apple quick time,[Murali_Ranganathan],[Murali_Ranganathan],,,,,,
+ampr-rcmd,459,tcp,ampr-rcmd,[Rob_Janssen],[Rob_Janssen],,,,,,
+ampr-rcmd,459,udp,ampr-rcmd,[Rob_Janssen],[Rob_Janssen],,,,,,
+skronk,460,tcp,skronk,[Henry_Strickland],[Henry_Strickland],,,,,,
+skronk,460,udp,skronk,[Henry_Strickland],[Henry_Strickland],,,,,,
+datasurfsrv,461,tcp,DataRampSrv,,,,,,,,
+datasurfsrv,461,udp,DataRampSrv,,,,,,,,
+datasurfsrvsec,462,tcp,DataRampSrvSec,[Diane_Downie],[Diane_Downie],,,,,,
+datasurfsrvsec,462,udp,DataRampSrvSec,[Diane_Downie],[Diane_Downie],,,,,,
+alpes,463,tcp,alpes,[Alain_Durand],[Alain_Durand],,,,,,
+alpes,463,udp,alpes,[Alain_Durand],[Alain_Durand],,,,,,
+kpasswd,464,tcp,kpasswd,[Theodore_Ts_o],[Theodore_Ts_o],,,,,,
+kpasswd,464,udp,kpasswd,[Theodore_Ts_o],[Theodore_Ts_o],,,,,,
+urd,465,tcp,URL Rendesvous Directory for SSM,[Toerless_Eckert],[Toerless_Eckert],,,,,,
+igmpv3lite,465,udp,IGMP over UDP for SSM,[Toerless_Eckert],[Toerless_Eckert],,,,,,
+digital-vrc,466,tcp,digital-vrc,[Peter_Higginson],[Peter_Higginson],,,,,,
+digital-vrc,466,udp,digital-vrc,[Peter_Higginson],[Peter_Higginson],,,,,,
+mylex-mapd,467,tcp,mylex-mapd,[Gary_Lewis],[Gary_Lewis],,,,,,
+mylex-mapd,467,udp,mylex-mapd,[Gary_Lewis],[Gary_Lewis],,,,,,
+photuris,468,tcp,proturis,[Bill_Simpson_2],[Bill_Simpson_2],,,,,,
+photuris,468,udp,proturis,[Bill_Simpson_2],[Bill_Simpson_2],,,,,,
+rcp,469,tcp,Radio Control Protocol,[Jim_Jennings],[Jim_Jennings],,,,,,
+rcp,469,udp,Radio Control Protocol,[Jim_Jennings],[Jim_Jennings],,,,,,
+scx-proxy,470,tcp,scx-proxy,[Scott_Narveson],[Scott_Narveson],,,,,,
+scx-proxy,470,udp,scx-proxy,[Scott_Narveson],[Scott_Narveson],,,,,,
+mondex,471,tcp,Mondex,[Bill_Reding],[Bill_Reding],,,,,,
+mondex,471,udp,Mondex,[Bill_Reding],[Bill_Reding],,,,,,
+ljk-login,472,tcp,ljk-login,[LJK],[LJK],,,,,,
+ljk-login,472,udp,ljk-login,[LJK],[LJK],,,,,,
+hybrid-pop,473,tcp,hybrid-pop,[Rami_Rubin],[Rami_Rubin],,,,,,
+hybrid-pop,473,udp,hybrid-pop,[Rami_Rubin],[Rami_Rubin],,,,,,
+tn-tl-w1,474,tcp,tn-tl-w1,,,,,,,,
+tn-tl-w2,474,udp,tn-tl-w2,[Ed_Kress],[Ed_Kress],,,,,,
+tcpnethaspsrv,475,tcp,tcpnethaspsrv,[Michael_Zunke],[Michael_Zunke],2010-07-23,,,,,
+tcpnethaspsrv,475,udp,tcpnethaspsrv,[Michael_Zunke],[Michael_Zunke],2010-07-23,,,,,
+tn-tl-fd1,476,tcp,tn-tl-fd1,[Ed_Kress],[Ed_Kress],,,,,,
+tn-tl-fd1,476,udp,tn-tl-fd1,[Ed_Kress],[Ed_Kress],,,,,,
+ss7ns,477,tcp,ss7ns,[Jean_Michel_URSCH],[Jean_Michel_URSCH],,,,,,
+ss7ns,477,udp,ss7ns,[Jean_Michel_URSCH],[Jean_Michel_URSCH],,,,,,
+spsc,478,tcp,spsc,[Mike_Rieker],[Mike_Rieker],,,,,,
+spsc,478,udp,spsc,[Mike_Rieker],[Mike_Rieker],,,,,,
+iafserver,479,tcp,iafserver,,,,,,,,
+iafserver,479,udp,iafserver,,,,,,,,
+iafdbase,480,tcp,iafdbase,[Rick_Yazwinski],[Rick_Yazwinski],,,,,,
+iafdbase,480,udp,iafdbase,[Rick_Yazwinski],[Rick_Yazwinski],,,,,,
+ph,481,tcp,Ph service,[Roland_Hedberg],[Roland_Hedberg],,,,,,
+ph,481,udp,Ph service,[Roland_Hedberg],[Roland_Hedberg],,,,,,
+bgs-nsi,482,tcp,bgs-nsi,[Jon_Saperia],[Jon_Saperia],,,,,,
+bgs-nsi,482,udp,bgs-nsi,[Jon_Saperia],[Jon_Saperia],,,,,,
+ulpnet,483,tcp,ulpnet,[Kevin_Mooney],[Kevin_Mooney],,,,,,
+ulpnet,483,udp,ulpnet,[Kevin_Mooney],[Kevin_Mooney],,,,,,
+integra-sme,484,tcp,Integra Software Management Environment,[Randall_Dow],[Randall_Dow],,,,,,
+integra-sme,484,udp,Integra Software Management Environment,[Randall_Dow],[Randall_Dow],,,,,,
+powerburst,485,tcp,Air Soft Power Burst,[gary],[gary],,,,,,
+powerburst,485,udp,Air Soft Power Burst,[gary],[gary],,,,,,
+avian,486,tcp,avian,[Robert_Ullmann_2],[Robert_Ullmann_2],,,,,,
+avian,486,udp,avian,[Robert_Ullmann_2],[Robert_Ullmann_2],,,,,,
+saft,487,tcp,saft Simple Asynchronous File Transfer,[Ulli_Horlacher],[Ulli_Horlacher],,,,,,
+saft,487,udp,saft Simple Asynchronous File Transfer,[Ulli_Horlacher],[Ulli_Horlacher],,,,,,
+gss-http,488,tcp,gss-http,[Doug_Rosenthal],[Doug_Rosenthal],,,,,,
+gss-http,488,udp,gss-http,[Doug_Rosenthal],[Doug_Rosenthal],,,,,,
+nest-protocol,489,tcp,nest-protocol,[Gilles_Gameiro],[Gilles_Gameiro],,,,,,
+nest-protocol,489,udp,nest-protocol,[Gilles_Gameiro],[Gilles_Gameiro],,,,,,
+micom-pfs,490,tcp,micom-pfs,[David_Misunas],[David_Misunas],,,,,,
+micom-pfs,490,udp,micom-pfs,[David_Misunas],[David_Misunas],,,,,,
+go-login,491,tcp,go-login,[Troy_Morrison],[Troy_Morrison],,,,,,
+go-login,491,udp,go-login,[Troy_Morrison],[Troy_Morrison],,,,,,
+ticf-1,492,tcp,Transport Independent Convergence for FNA,,,,,,,,
+ticf-1,492,udp,Transport Independent Convergence for FNA,,,,,,,,
+ticf-2,493,tcp,Transport Independent Convergence for FNA,[Mamoru_Ito],[Mamoru_Ito],,,,,,
+ticf-2,493,udp,Transport Independent Convergence for FNA,[Mamoru_Ito],[Mamoru_Ito],,,,,,
+pov-ray,494,tcp,POV-Ray,[POV_Team_Co_ordinato],[POV_Team_Co_ordinato],,,,,,
+pov-ray,494,udp,POV-Ray,[POV_Team_Co_ordinato],[POV_Team_Co_ordinato],,,,,,
+intecourier,495,tcp,intecourier,[Steve_Favor],[Steve_Favor],,,,,,
+intecourier,495,udp,intecourier,[Steve_Favor],[Steve_Favor],,,,,,
+pim-rp-disc,496,tcp,PIM-RP-DISC,[Dino_Farinacci],[Dino_Farinacci],,,,,,
+pim-rp-disc,496,udp,PIM-RP-DISC,[Dino_Farinacci],[Dino_Farinacci],,,,,,
+retrospect,497,tcp,Retrospect backup and restore service,[Retrospect_Inc],[JG_Heithcock],,2012-02-02,,,,
+retrospect,497,udp,Retrospect backup and restore service,[Retrospect_Inc],[JG_Heithcock],,2012-02-02,,,,
+siam,498,tcp,siam,[Philippe_Gilbert],[Philippe_Gilbert],,,,,,
+siam,498,udp,siam,[Philippe_Gilbert],[Philippe_Gilbert],,,,,,
+iso-ill,499,tcp,ISO ILL Protocol,[Mark_H_Needleman],[Mark_H_Needleman],,,,,,
+iso-ill,499,udp,ISO ILL Protocol,[Mark_H_Needleman],[Mark_H_Needleman],,,,,,
+isakmp,500,tcp,isakmp,[Mark_Schertler],[Mark_Schertler],,,,,,
+isakmp,500,udp,isakmp,[Mark_Schertler],[Mark_Schertler],,,,,,
+stmf,501,tcp,STMF,[Alan_Ungar],[Alan_Ungar],,,,,,
+stmf,501,udp,STMF,[Alan_Ungar],[Alan_Ungar],,,,,,
+mbap,502,tcp,Modbus Application Protocol,[modbus.org],[Dennis_Dube],,2014-06-10,,,,
+mbap,502,udp,Modbus Application Protocol,[modbus.org],[Dennis_Dube],,2014-06-10,,,,
+intrinsa,503,tcp,Intrinsa,[Robert_Ford],[Robert_Ford],,,,,,
+intrinsa,503,udp,Intrinsa,[Robert_Ford],[Robert_Ford],,,,,,
+citadel,504,tcp,citadel,[Art_Cancro],[Art_Cancro],,,,,,
+citadel,504,udp,citadel,[Art_Cancro],[Art_Cancro],,,,,,
+mailbox-lm,505,tcp,mailbox-lm,[Beverly_Moody],[Beverly_Moody],,,,,,
+mailbox-lm,505,udp,mailbox-lm,[Beverly_Moody],[Beverly_Moody],,,,,,
+ohimsrv,506,tcp,ohimsrv,[Scott_Powell],[Scott_Powell],,,,,,
+ohimsrv,506,udp,ohimsrv,[Scott_Powell],[Scott_Powell],,,,,,
+crs,507,tcp,crs,[Brad_Wright],[Brad_Wright],,,,,,
+crs,507,udp,crs,[Brad_Wright],[Brad_Wright],,,,,,
+xvttp,508,tcp,xvttp,[Keith_J_Alphonso],[Keith_J_Alphonso],,,,,,
+xvttp,508,udp,xvttp,[Keith_J_Alphonso],[Keith_J_Alphonso],,,,,,
+snare,509,tcp,snare,[Dennis_Batchelder],[Dennis_Batchelder],,,,,,
+snare,509,udp,snare,[Dennis_Batchelder],[Dennis_Batchelder],,,,,,
+fcp,510,tcp,FirstClass Protocol,[Mike_Marshburn],[Mike_Marshburn],,,,,,
+fcp,510,udp,FirstClass Protocol,[Mike_Marshburn],[Mike_Marshburn],,,,,,
+passgo,511,tcp,PassGo,[John_Rainford],[John_Rainford],,,,,,
+passgo,511,udp,PassGo,[John_Rainford],[John_Rainford],,,,,,
+exec,512,tcp,remote process execution; authentication performed using passwords and UNIX login names,,,,,,,,
+comsat,512,udp,,,,,,,,,
+biff,512,udp,used by mail system to notify users of new mail received; currently receives messages only from processes on the same machine,,,,,,,,
+login,513,tcp,"remote login a la telnet; automatic authentication performed based on priviledged port numbers and distributed data bases which identify ""authentication domains""",,,,,,,,
+who,513,udp,maintains data bases showing who's logged in to machines on a local net and the load average of the machine,,,,,,,,
+shell,514,tcp,"cmd like exec, but automatic authentication is performed as for login server",,,,,,,,
+syslog,514,udp,,,,,,,,,
+printer,515,tcp,spooler,,,,,,,,
+printer,515,udp,spooler,,,,,,,,
+videotex,516,tcp,videotex,[Daniel_Mavrakis],[Daniel_Mavrakis],,,,,,
+videotex,516,udp,videotex,[Daniel_Mavrakis],[Daniel_Mavrakis],,,,,,
+talk,517,tcp,"like tenex link, but across machine - unfortunately, doesn't use link protocol (this is actually just a rendezvous port from which a tcp connection is established)",,,,,,,,
+talk,517,udp,"like tenex link, but across machine - unfortunately, doesn't use link protocol (this is actually just a rendezvous port from which a tcp connection is established)",,,,,,,,
+ntalk,518,tcp,,,,,,,,,
+ntalk,518,udp,,,,,,,,,
+utime,519,tcp,unixtime,,,,,,,,
+utime,519,udp,unixtime,,,,,,,,
+efs,520,tcp,extended file name server,,,,,,,,
+router,520,udp,local routing process (on site); uses variant of Xerox NS routing information protocol - RIP,,,,,,,,
+ripng,521,tcp,ripng,[Robert_E_Minnear],[Robert_E_Minnear],,,,,,
+ripng,521,udp,ripng,[Robert_E_Minnear],[Robert_E_Minnear],,,,,,
+ulp,522,tcp,ULP,[Max_Morris],[Max_Morris],,,,,,
+ulp,522,udp,ULP,[Max_Morris],[Max_Morris],,,,,,
+ibm-db2,523,tcp,IBM-DB2,[Juliana_Hsu],[Juliana_Hsu],,,,,,
+ibm-db2,523,udp,IBM-DB2,[Juliana_Hsu],[Juliana_Hsu],,,,,,
+ncp,524,tcp,NCP,[Don_Provan_2],[Don_Provan_2],,,,,,
+ncp,524,udp,NCP,[Don_Provan_2],[Don_Provan_2],,,,,,
+timed,525,tcp,timeserver,,,,,,,,
+timed,525,udp,timeserver,,,,,,,,
+tempo,526,tcp,newdate,,,,,,,,
+tempo,526,udp,newdate,,,,,,,,
+stx,527,tcp,Stock IXChange,[Fraxion_Software],[Ferdi_Ladeira],,2012-03-21,,,,
+stx,527,udp,Stock IXChange,[Fraxion_Software],[Ferdi_Ladeira],,2012-03-21,,,,
+custix,528,tcp,Customer IXChange,[Fraxion_Software],[Ferdi_Ladeira],,2012-03-21,,,,
+custix,528,udp,Customer IXChange,[Fraxion_Software],[Ferdi_Ladeira],,2012-03-21,,,,
+irc-serv,529,tcp,IRC-SERV,[Brian_Tackett],[Brian_Tackett],,,,,,
+irc-serv,529,udp,IRC-SERV,[Brian_Tackett],[Brian_Tackett],,,,,,
+courier,530,tcp,rpc,,,,,,,,
+courier,530,udp,rpc,,,,,,,,
+conference,531,tcp,chat,,,,,,,,
+conference,531,udp,chat,,,,,,,,
+netnews,532,tcp,readnews,,,,,,,,
+netnews,532,udp,readnews,,,,,,,,
+netwall,533,tcp,for emergency broadcasts,[Andreas_Heidemann],[Andreas_Heidemann],,,,,,
+netwall,533,udp,for emergency broadcasts,[Andreas_Heidemann],[Andreas_Heidemann],,,,,,
+windream,534,tcp,windream Admin,[Uwe_Honermann],[Uwe_Honermann],,,,,,
+windream,534,udp,windream Admin,[Uwe_Honermann],[Uwe_Honermann],,,,,,
+iiop,535,tcp,iiop,[Jeff_M_Michaud],[Jeff_M_Michaud],,,,,,
+iiop,535,udp,iiop,[Jeff_M_Michaud],[Jeff_M_Michaud],,,,,,
+opalis-rdv,536,tcp,opalis-rdv,[Laurent_Domenech],[Laurent_Domenech],,,,,,
+opalis-rdv,536,udp,opalis-rdv,[Laurent_Domenech],[Laurent_Domenech],,,,,,
+nmsp,537,tcp,Networked Media Streaming Protocol,[Paul_Santinelli_Jr],[Paul_Santinelli_Jr],,,,,,
+nmsp,537,udp,Networked Media Streaming Protocol,[Paul_Santinelli_Jr],[Paul_Santinelli_Jr],,,,,,
+gdomap,538,tcp,gdomap,[Richard_Frith_Macdon],[Richard_Frith_Macdon],,,,,,
+gdomap,538,udp,gdomap,[Richard_Frith_Macdon],[Richard_Frith_Macdon],,,,,,
+apertus-ldp,539,tcp,Apertus Technologies Load Determination,,,,,,,,
+apertus-ldp,539,udp,Apertus Technologies Load Determination,,,,,,,,
+uucp,540,tcp,uucpd,,,,,,,,
+uucp,540,udp,uucpd,,,,,,,,
+uucp-rlogin,541,tcp,uucp-rlogin,[Stuart_Lynne],[Stuart_Lynne],,,,,,
+uucp-rlogin,541,udp,uucp-rlogin,[Stuart_Lynne],[Stuart_Lynne],,,,,,
+commerce,542,tcp,commerce,[Randy_Epstein],[Randy_Epstein],,,,,,
+commerce,542,udp,commerce,[Randy_Epstein],[Randy_Epstein],,,,,,
+klogin,543,tcp,,,,,,,,,
+klogin,543,udp,,,,,,,,,
+kshell,544,tcp,krcmd,,,,,,,,
+kshell,544,udp,krcmd,,,,,,,,
+appleqtcsrvr,545,tcp,appleqtcsrvr,[Murali_Ranganathan],[Murali_Ranganathan],,,,,,
+appleqtcsrvr,545,udp,appleqtcsrvr,[Murali_Ranganathan],[Murali_Ranganathan],,,,,,
+dhcpv6-client,546,tcp,DHCPv6 Client,,,,,,,,
+dhcpv6-client,546,udp,DHCPv6 Client,,,,,,,,
+dhcpv6-server,547,tcp,DHCPv6 Server,[Jim_Bound],[Jim_Bound],,,,,,
+dhcpv6-server,547,udp,DHCPv6 Server,[Jim_Bound],[Jim_Bound],,,,,,
+afpovertcp,548,tcp,AFP over TCP,[Leland_Wallace],[Leland_Wallace],,,,,,Defined TXT keys: u=<username> p=<password> path=<path>
+afpovertcp,548,udp,AFP over TCP,[Leland_Wallace],[Leland_Wallace],,,,,,Defined TXT keys: u=<username> p=<password> path=<path>
+idfp,549,tcp,IDFP,[Ramana_Kovi],[Ramana_Kovi],,,,,,
+idfp,549,udp,IDFP,[Ramana_Kovi],[Ramana_Kovi],,,,,,
+new-rwho,550,tcp,new-who,,,,,[n/a],,,
+new-rwho,550,udp,new-who,,,,,[n/a],,,
+cybercash,551,tcp,cybercash,[Donald_E_Eastlake],[Donald_E_Eastlake],,,[RFC1898],,,
+cybercash,551,udp,cybercash,[Donald_E_Eastlake],[Donald_E_Eastlake],,,[RFC1898],,,
+devshr-nts,552,tcp,DeviceShare,[Benjamin_Rosenberg],[Benjamin_Rosenberg],,,,,,
+devshr-nts,552,udp,DeviceShare,[Benjamin_Rosenberg],[Benjamin_Rosenberg],,,,,,
+pirp,553,tcp,pirp,[D_J_Bernstein],[D_J_Bernstein],,,,,,
+pirp,553,udp,pirp,[D_J_Bernstein],[D_J_Bernstein],,,,,,
+rtsp,554,tcp,Real Time Streaming Protocol (RTSP),[Rob_Lanphier],[Rob_Lanphier],,,,,,
+rtsp,554,udp,Real Time Streaming Protocol (RTSP),[Rob_Lanphier],[Rob_Lanphier],,,,,,
+dsf,555,tcp,,,,,,,,,
+dsf,555,udp,,,,,,,,,
+remotefs,556,tcp,rfs server,,,,,,,,
+remotefs,556,udp,rfs server,,,,,,,,
+openvms-sysipc,557,tcp,openvms-sysipc,[Alan_Potter],[Alan_Potter],,,,,,
+openvms-sysipc,557,udp,openvms-sysipc,[Alan_Potter],[Alan_Potter],,,,,,
+sdnskmp,558,tcp,SDNSKMP,,,,,,,,
+sdnskmp,558,udp,SDNSKMP,,,,,,,,
+teedtap,559,tcp,TEEDTAP,[Charlie_Limoges],[Charlie_Limoges],,,,,,
+teedtap,559,udp,TEEDTAP,[Charlie_Limoges],[Charlie_Limoges],,,,,,
+rmonitor,560,tcp,rmonitord,,,,,,,,
+rmonitor,560,udp,rmonitord,,,,,,,,
+monitor,561,tcp,,,,,,,,,
+monitor,561,udp,,,,,,,,,
+chshell,562,tcp,chcmd,,,,,,,,
+chshell,562,udp,chcmd,,,,,,,,
+nntps,563,tcp,nntp protocol over TLS/SSL (was snntp),[Kipp_E_B_Hickman_2],[Kipp_E_B_Hickman_2],,,,,,
+nntps,563,udp,nntp protocol over TLS/SSL (was snntp),[Kipp_E_B_Hickman_2],[Kipp_E_B_Hickman_2],,,,,,
+9pfs,564,tcp,plan 9 file service,,,,,,,,
+9pfs,564,udp,plan 9 file service,,,,,,,,
+whoami,565,tcp,whoami,,,,,,,,
+whoami,565,udp,whoami,,,,,,,,
+streettalk,566,tcp,streettalk,,,,,,,,
+streettalk,566,udp,streettalk,,,,,,,,
+banyan-rpc,567,tcp,banyan-rpc,[Tom_Lemaire],[Tom_Lemaire],,,,,,
+banyan-rpc,567,udp,banyan-rpc,[Tom_Lemaire],[Tom_Lemaire],,,,,,
+ms-shuttle,568,tcp,microsoft shuttle,[Rudolph_Balaz],[Rudolph_Balaz],,,,,,
+ms-shuttle,568,udp,microsoft shuttle,[Rudolph_Balaz],[Rudolph_Balaz],,,,,,
+ms-rome,569,tcp,microsoft rome,[Rudolph_Balaz],[Rudolph_Balaz],,,,,,
+ms-rome,569,udp,microsoft rome,[Rudolph_Balaz],[Rudolph_Balaz],,,,,,
+meter,570,tcp,demon,,,,,,,,
+meter,570,udp,demon,,,,,,,,
+meter,571,tcp,udemon,,,,,,,,
+meter,571,udp,udemon,,,,,,,,
+sonar,572,tcp,sonar,[Keith_Moore],[Keith_Moore],,,,,,
+sonar,572,udp,sonar,[Keith_Moore],[Keith_Moore],,,,,,
+banyan-vip,573,tcp,banyan-vip,[Denis_Leclerc],[Denis_Leclerc],,,,,,
+banyan-vip,573,udp,banyan-vip,[Denis_Leclerc],[Denis_Leclerc],,,,,,
+ftp-agent,574,tcp,FTP Software Agent System,[Michael_S_Greenberg],[Michael_S_Greenberg],,,,,,
+ftp-agent,574,udp,FTP Software Agent System,[Michael_S_Greenberg],[Michael_S_Greenberg],,,,,,
+vemmi,575,tcp,VEMMI,[Daniel_Mavrakis_2],[Daniel_Mavrakis_2],,,,,,
+vemmi,575,udp,VEMMI,[Daniel_Mavrakis_2],[Daniel_Mavrakis_2],,,,,,
+ipcd,576,tcp,ipcd,,,,,,,,
+ipcd,576,udp,ipcd,,,,,,,,
+vnas,577,tcp,vnas,,,,,,,,
+vnas,577,udp,vnas,,,,,,,,
+ipdd,578,tcp,ipdd,[Jay_Farhat],[Jay_Farhat],,,,,,
+ipdd,578,udp,ipdd,[Jay_Farhat],[Jay_Farhat],,,,,,
+decbsrv,579,tcp,decbsrv,[Rudi_Martin],[Rudi_Martin],,,,,,
+decbsrv,579,udp,decbsrv,[Rudi_Martin],[Rudi_Martin],,,,,,
+sntp-heartbeat,580,tcp,SNTP HEARTBEAT,[Louis_Mamakos_2],[Louis_Mamakos_2],,,,,,
+sntp-heartbeat,580,udp,SNTP HEARTBEAT,[Louis_Mamakos_2],[Louis_Mamakos_2],,,,,,
+bdp,581,tcp,Bundle Discovery Protocol,[Gary_Malkin],[Gary_Malkin],,,,,,
+bdp,581,udp,Bundle Discovery Protocol,[Gary_Malkin],[Gary_Malkin],,,,,,
+scc-security,582,tcp,SCC Security,[Prashant_Dholakia],[Prashant_Dholakia],,,,,,
+scc-security,582,udp,SCC Security,[Prashant_Dholakia],[Prashant_Dholakia],,,,,,
+philips-vc,583,tcp,Philips Video-Conferencing,[Janna_Chang],[Janna_Chang],,,,,,
+philips-vc,583,udp,Philips Video-Conferencing,[Janna_Chang],[Janna_Chang],,,,,,
+keyserver,584,tcp,Key Server,[Gary_Howland],[Gary_Howland],,,,,,
+keyserver,584,udp,Key Server,[Gary_Howland],[Gary_Howland],,,,,,
+,585,,De-registered,,,,2006-04-25,,,,"Use of 585 is not recommended, use 993 instead"
+password-chg,586,tcp,Password Change,,,,,,,,
+password-chg,586,udp,Password Change,,,,,,,,
+submission,587,tcp,Message Submission,,,,2011-11-17,[RFC6409],,,
+submission,587,udp,Message Submission,,,,2011-11-17,[RFC6409],,,
+cal,588,tcp,CAL,[Myron_Hattig],[Myron_Hattig],,,,,,
+cal,588,udp,CAL,[Myron_Hattig],[Myron_Hattig],,,,,,
+eyelink,589,tcp,EyeLink,[Dave_Stampe],[Dave_Stampe],,,,,,
+eyelink,589,udp,EyeLink,[Dave_Stampe],[Dave_Stampe],,,,,,
+tns-cml,590,tcp,TNS CML,[Jerome_Albin],[Jerome_Albin],,,,,,
+tns-cml,590,udp,TNS CML,[Jerome_Albin],[Jerome_Albin],,,,,,
+http-alt,591,tcp,"FileMaker, Inc. - HTTP Alternate (see Port 80)",[Clay_Maeckel],[Clay_Maeckel],,,,,,
+http-alt,591,udp,"FileMaker, Inc. - HTTP Alternate (see Port 80)",[Clay_Maeckel],[Clay_Maeckel],,,,,,
+eudora-set,592,tcp,Eudora Set,[Randall_Gellens],[Randall_Gellens],,,,,,
+eudora-set,592,udp,Eudora Set,[Randall_Gellens],[Randall_Gellens],,,,,,
+http-rpc-epmap,593,tcp,HTTP RPC Ep Map,[Edward_Reus],[Edward_Reus],,,,,,
+http-rpc-epmap,593,udp,HTTP RPC Ep Map,[Edward_Reus],[Edward_Reus],,,,,,
+tpip,594,tcp,TPIP,[Brad_Spear],[Brad_Spear],,,,,,
+tpip,594,udp,TPIP,[Brad_Spear],[Brad_Spear],,,,,,
+cab-protocol,595,tcp,CAB Protocol,[Winston_Hetherington],[Winston_Hetherington],,,,,,
+cab-protocol,595,udp,CAB Protocol,[Winston_Hetherington],[Winston_Hetherington],,,,,,
+smsd,596,tcp,SMSD,[Wayne_Barlow],[Wayne_Barlow],,,,,,
+smsd,596,udp,SMSD,[Wayne_Barlow],[Wayne_Barlow],,,,,,
+ptcnameservice,597,tcp,PTC Name Service,[Yuri_Machkasov],[Yuri_Machkasov],,,,,,
+ptcnameservice,597,udp,PTC Name Service,[Yuri_Machkasov],[Yuri_Machkasov],,,,,,
+sco-websrvrmg3,598,tcp,SCO Web Server Manager 3,[Simon_Baldwin],[Simon_Baldwin],,,,,,
+sco-websrvrmg3,598,udp,SCO Web Server Manager 3,[Simon_Baldwin],[Simon_Baldwin],,,,,,
+acp,599,tcp,Aeolon Core Protocol,[Michael_Alyn_Miller],[Michael_Alyn_Miller],,,,,,
+acp,599,udp,Aeolon Core Protocol,[Michael_Alyn_Miller],[Michael_Alyn_Miller],,,,,,
+ipcserver,600,tcp,Sun IPC server,[Bill_Schiefelbein],[Bill_Schiefelbein],,,,,,
+ipcserver,600,udp,Sun IPC server,[Bill_Schiefelbein],[Bill_Schiefelbein],,,,,,
+syslog-conn,601,tcp,Reliable Syslog Service,,,,,[RFC3195],,,
+syslog-conn,601,udp,Reliable Syslog Service,,,,,[RFC3195],,,
+xmlrpc-beep,602,tcp,XML-RPC over BEEP,,,,,[RFC3529],,,
+xmlrpc-beep,602,udp,XML-RPC over BEEP,,,,,[RFC3529],,,
+idxp,603,tcp,IDXP,,,,,[RFC4767],,,
+idxp,603,udp,IDXP,,,,,[RFC4767],,,
+tunnel,604,tcp,TUNNEL,,,,,[RFC3620],,,
+tunnel,604,udp,TUNNEL,,,,,[RFC3620],,,
+soap-beep,605,tcp,SOAP over BEEP,,,,,[RFC4227],,,
+soap-beep,605,udp,SOAP over BEEP,,,,,[RFC4227],,,
+urm,606,tcp,Cray Unified Resource Manager,,,,,,,,
+urm,606,udp,Cray Unified Resource Manager,,,,,,,,
+nqs,607,tcp,nqs,[Bill_Schiefelbein],[Bill_Schiefelbein],,,,,,
+nqs,607,udp,nqs,[Bill_Schiefelbein],[Bill_Schiefelbein],,,,,,
+sift-uft,608,tcp,Sender-Initiated/Unsolicited File Transfer,[Rick_Troth],[Rick_Troth],,,,,,
+sift-uft,608,udp,Sender-Initiated/Unsolicited File Transfer,[Rick_Troth],[Rick_Troth],,,,,,
+npmp-trap,609,tcp,npmp-trap,,,,,,,,
+npmp-trap,609,udp,npmp-trap,,,,,,,,
+npmp-local,610,tcp,npmp-local,,,,,,,,
+npmp-local,610,udp,npmp-local,,,,,,,,
+npmp-gui,611,tcp,npmp-gui,[John_Barnes],[John_Barnes],,,,,,
+npmp-gui,611,udp,npmp-gui,[John_Barnes],[John_Barnes],,,,,,
+hmmp-ind,612,tcp,HMMP Indication,,,,,,,,
+hmmp-ind,612,udp,HMMP Indication,,,,,,,,
+hmmp-op,613,tcp,HMMP Operation,[Andrew_Sinclair],[Andrew_Sinclair],,,,,,
+hmmp-op,613,udp,HMMP Operation,[Andrew_Sinclair],[Andrew_Sinclair],,,,,,
+sshell,614,tcp,SSLshell,[Simon_J_Gerraty],[Simon_J_Gerraty],,,,,,
+sshell,614,udp,SSLshell,[Simon_J_Gerraty],[Simon_J_Gerraty],,,,,,
+sco-inetmgr,615,tcp,Internet Configuration Manager,,,,,,,,
+sco-inetmgr,615,udp,Internet Configuration Manager,,,,,,,,
+sco-sysmgr,616,tcp,SCO System Administration Server,,,,,,,,
+sco-sysmgr,616,udp,SCO System Administration Server,,,,,,,,
+sco-dtmgr,617,tcp,SCO Desktop Administration Server,[Christopher_Durham],[Christopher_Durham],,,,,,
+sco-dtmgr,617,udp,SCO Desktop Administration Server,[Christopher_Durham],[Christopher_Durham],,,,,,
+dei-icda,618,tcp,DEI-ICDA,[David_Turner],[David_Turner],,,,,,
+dei-icda,618,udp,DEI-ICDA,[David_Turner],[David_Turner],,,,,,
+compaq-evm,619,tcp,Compaq EVM,[Jem_Treadwell],[Jem_Treadwell],,,,,,
+compaq-evm,619,udp,Compaq EVM,[Jem_Treadwell],[Jem_Treadwell],,,,,,
+sco-websrvrmgr,620,tcp,SCO WebServer Manager,[Christopher_Durham],[Christopher_Durham],,,,,,
+sco-websrvrmgr,620,udp,SCO WebServer Manager,[Christopher_Durham],[Christopher_Durham],,,,,,
+escp-ip,621,tcp,ESCP,[Lai_Zit_Seng],[Lai_Zit_Seng],,,,,,
+escp-ip,621,udp,ESCP,[Lai_Zit_Seng],[Lai_Zit_Seng],,,,,,
+collaborator,622,tcp,Collaborator,[Johnson_Davis],[Johnson_Davis],,,,,,
+collaborator,622,udp,Collaborator,[Johnson_Davis],[Johnson_Davis],,,,,,
+oob-ws-http,623,tcp,DMTF out-of-band web services management protocol,[Jim_Davis],[Jim_Davis],2007-06,,,,,
+asf-rmcp,623,udp,ASF Remote Management and Control Protocol,[Carl_First],[Carl_First],,,,,,
+cryptoadmin,624,tcp,Crypto Admin,[Tony_Walker],[Tony_Walker],,,,,,
+cryptoadmin,624,udp,Crypto Admin,[Tony_Walker],[Tony_Walker],,,,,,
+dec-dlm,625,tcp,"DEC DLM
+IANA assigned this well-formed service name as a replacement for ""dec_dlm"".",[Rudi_Martin_2],[Rudi_Martin_2],,,,,,
+dec_dlm,625,tcp,DEC DLM,[Rudi_Martin_2],[Rudi_Martin_2],,,,,,"This entry is an alias to ""dec-dlm"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+dec-dlm,625,udp,"DEC DLM
+IANA assigned this well-formed service name as a replacement for ""dec_dlm"".",[Rudi_Martin_2],[Rudi_Martin_2],,,,,,
+dec_dlm,625,udp,DEC DLM,[Rudi_Martin_2],[Rudi_Martin_2],,,,,,"This entry is an alias to ""dec-dlm"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+asia,626,tcp,ASIA,[Michael_Dasenbrock],[Michael_Dasenbrock],,,,,,
+asia,626,udp,ASIA,[Michael_Dasenbrock],[Michael_Dasenbrock],,,,,,
+passgo-tivoli,627,tcp,PassGo Tivoli,[John_Rainford_2],[John_Rainford_2],,,,,,
+passgo-tivoli,627,udp,PassGo Tivoli,[John_Rainford_2],[John_Rainford_2],,,,,,
+qmqp,628,tcp,QMQP,[Dan_Bernstein_2],[Dan_Bernstein_2],,,,,,
+qmqp,628,udp,QMQP,[Dan_Bernstein_2],[Dan_Bernstein_2],,,,,,
+3com-amp3,629,tcp,3Com AMP3,[Prakash_Banthia],[Prakash_Banthia],,,,,,
+3com-amp3,629,udp,3Com AMP3,[Prakash_Banthia],[Prakash_Banthia],,,,,,
+rda,630,tcp,RDA,[John_Hadjioannou],[John_Hadjioannou],,,,,,
+rda,630,udp,RDA,[John_Hadjioannou],[John_Hadjioannou],,,,,,
+ipp,631,tcp,IPP (Internet Printing Protocol),[Carl_Uno_Manros],[Carl_Uno_Manros],,,,,,Defined TXT keys: See BonjourPrinting.pdf.
+ipp,631,udp,IPP (Internet Printing Protocol),[Carl_Uno_Manros],[Carl_Uno_Manros],,,,,,Defined TXT keys: See BonjourPrinting.pdf.
+bmpp,632,tcp,bmpp,[Troy_Rollo],[Troy_Rollo],,,,,,
+bmpp,632,udp,bmpp,[Troy_Rollo],[Troy_Rollo],,,,,,
+servstat,633,tcp,Service Status update (Sterling Software),[Greg_Rose],[Greg_Rose],,,,,,
+servstat,633,udp,Service Status update (Sterling Software),[Greg_Rose],[Greg_Rose],,,,,,
+ginad,634,tcp,ginad,[Mark_Crother],[Mark_Crother],,,,,,
+ginad,634,udp,ginad,[Mark_Crother],[Mark_Crother],,,,,,
+rlzdbase,635,tcp,RLZ DBase,[Michael_Ginn],[Michael_Ginn],,,,,,
+rlzdbase,635,udp,RLZ DBase,[Michael_Ginn],[Michael_Ginn],,,,,,
+ldaps,636,tcp,ldap protocol over TLS/SSL (was sldap),[Pat_Richard],[Pat_Richard],,,,,,
+ldaps,636,udp,ldap protocol over TLS/SSL (was sldap),[Pat_Richard],[Pat_Richard],,,,,,
+lanserver,637,tcp,lanserver,[Chris_Larsson],[Chris_Larsson],,,,,,
+lanserver,637,udp,lanserver,[Chris_Larsson],[Chris_Larsson],,,,,,
+mcns-sec,638,tcp,mcns-sec,[Kaz_Ozawa],[Kaz_Ozawa],,,,,,
+mcns-sec,638,udp,mcns-sec,[Kaz_Ozawa],[Kaz_Ozawa],,,,,,
+msdp,639,tcp,MSDP,[Dino_Farinacci],[Dino_Farinacci],,,,,,
+msdp,639,udp,MSDP,[Dino_Farinacci],[Dino_Farinacci],,,,,,
+entrust-sps,640,tcp,entrust-sps,[Marek_Buchler],[Marek_Buchler],,,,,,
+entrust-sps,640,udp,entrust-sps,[Marek_Buchler],[Marek_Buchler],,,,,,
+repcmd,641,tcp,repcmd,[Scott_Dale],[Scott_Dale],,,,,,
+repcmd,641,udp,repcmd,[Scott_Dale],[Scott_Dale],,,,,,
+esro-emsdp,642,tcp,ESRO-EMSDP V1.3,[Mohsen_Banan_2],[Mohsen_Banan_2],,,,,,
+esro-emsdp,642,udp,ESRO-EMSDP V1.3,[Mohsen_Banan_2],[Mohsen_Banan_2],,,,,,
+sanity,643,tcp,SANity,[Peter_Viscarola],[Peter_Viscarola],,,,,,
+sanity,643,udp,SANity,[Peter_Viscarola],[Peter_Viscarola],,,,,,
+dwr,644,tcp,dwr,[Bill_Fenner],[Bill_Fenner],,,,,,
+dwr,644,udp,dwr,[Bill_Fenner],[Bill_Fenner],,,,,,
+pssc,645,tcp,PSSC,[Egon_Meier_Engelen],[Egon_Meier_Engelen],,,,,,
+pssc,645,udp,PSSC,[Egon_Meier_Engelen],[Egon_Meier_Engelen],,,,,,
+ldp,646,tcp,LDP,[Bob_Thomas],[Bob_Thomas],,,,,,
+ldp,646,udp,LDP,[Bob_Thomas],[Bob_Thomas],,,,,,
+dhcp-failover,647,tcp,DHCP Failover,[Bernard_Volz],[Bernard_Volz],,,,,,
+dhcp-failover,647,udp,DHCP Failover,[Bernard_Volz],[Bernard_Volz],,,,,,
+rrp,648,tcp,Registry Registrar Protocol (RRP),[Scott_Hollenbeck],[Scott_Hollenbeck],,,,,,
+rrp,648,udp,Registry Registrar Protocol (RRP),[Scott_Hollenbeck],[Scott_Hollenbeck],,,,,,
+cadview-3d,649,tcp,Cadview-3d - streaming 3d models over the internet,[David_Cooper],[David_Cooper],,,,,,
+cadview-3d,649,udp,Cadview-3d - streaming 3d models over the internet,[David_Cooper],[David_Cooper],,,,,,
+obex,650,tcp,OBEX,[Jeff_Garbers],[Jeff_Garbers],,,,,,
+obex,650,udp,OBEX,[Jeff_Garbers],[Jeff_Garbers],,,,,,
+ieee-mms,651,tcp,IEEE MMS,[Curtis_Anderson],[Curtis_Anderson],,,,,,
+ieee-mms,651,udp,IEEE MMS,[Curtis_Anderson],[Curtis_Anderson],,,,,,
+hello-port,652,tcp,HELLO_PORT,[Patrick_Cipiere],[Patrick_Cipiere],,,,,,
+hello-port,652,udp,HELLO_PORT,[Patrick_Cipiere],[Patrick_Cipiere],,,,,,
+repscmd,653,tcp,RepCmd,[Scott_Dale_2],[Scott_Dale_2],,,,,,
+repscmd,653,udp,RepCmd,[Scott_Dale_2],[Scott_Dale_2],,,,,,
+aodv,654,tcp,AODV,[Charles_Perkins],[Charles_Perkins],,,,,,
+aodv,654,udp,AODV,[Charles_Perkins],[Charles_Perkins],,,,,,
+tinc,655,tcp,TINC,[Ivo_Timmermans],[Ivo_Timmermans],,,,,,
+tinc,655,udp,TINC,[Ivo_Timmermans],[Ivo_Timmermans],,,,,,
+spmp,656,tcp,SPMP,[Jakob_Kaivo],[Jakob_Kaivo],,,,,,
+spmp,656,udp,SPMP,[Jakob_Kaivo],[Jakob_Kaivo],,,,,,
+rmc,657,tcp,RMC,[Michael_Schmidt],[Michael_Schmidt],,,,,,
+rmc,657,udp,RMC,[Michael_Schmidt],[Michael_Schmidt],,,,,,
+tenfold,658,tcp,TenFold,[Louis_Olszyk],[Louis_Olszyk],,,,,,
+tenfold,658,udp,TenFold,[Louis_Olszyk],[Louis_Olszyk],,,,,,
+,659,,Removed,,,,2001-06-06,,,,
+mac-srvr-admin,660,tcp,MacOS Server Admin,[Forest_Hill],[Forest_Hill],,,,,,
+mac-srvr-admin,660,udp,MacOS Server Admin,[Forest_Hill],[Forest_Hill],,,,,,
+hap,661,tcp,HAP,[Igor_Plotnikov],[Igor_Plotnikov],,,,,,
+hap,661,udp,HAP,[Igor_Plotnikov],[Igor_Plotnikov],,,,,,
+pftp,662,tcp,PFTP,[Ben_Schluricke],[Ben_Schluricke],,,,,,
+pftp,662,udp,PFTP,[Ben_Schluricke],[Ben_Schluricke],,,,,,
+purenoise,663,tcp,PureNoise,[Sam_Osa],[Sam_Osa],,,,,,
+purenoise,663,udp,PureNoise,[Sam_Osa],[Sam_Osa],,,,,,
+oob-ws-https,664,tcp,DMTF out-of-band secure web services management protocol,[Jim_Davis],[Jim_Davis],2007-06,,,,,
+asf-secure-rmcp,664,udp,ASF Secure Remote Management and Control Protocol,[Carl_First],[Carl_First],,,,,,
+sun-dr,665,tcp,Sun DR,[Harinder_Bhasin],[Harinder_Bhasin],,,,,,
+sun-dr,665,udp,Sun DR,[Harinder_Bhasin],[Harinder_Bhasin],,,,,,
+mdqs,666,tcp,,,,,,,,,
+mdqs,666,udp,,,,,,,,,
+doom,666,tcp,doom Id Software,[ddt],[ddt],,,,,,
+doom,666,udp,doom Id Software,[ddt],[ddt],,,,,,
+disclose,667,tcp,campaign contribution disclosures - SDR Technologies,[Jim_Dixon],[Jim_Dixon],,,,,,
+disclose,667,udp,campaign contribution disclosures - SDR Technologies,[Jim_Dixon],[Jim_Dixon],,,,,,
+mecomm,668,tcp,MeComm,,,,,,,,
+mecomm,668,udp,MeComm,,,,,,,,
+meregister,669,tcp,MeRegister,[Armin_Sawusch],[Armin_Sawusch],,,,,,
+meregister,669,udp,MeRegister,[Armin_Sawusch],[Armin_Sawusch],,,,,,
+vacdsm-sws,670,tcp,VACDSM-SWS,,,,,,,,
+vacdsm-sws,670,udp,VACDSM-SWS,,,,,,,,
+vacdsm-app,671,tcp,VACDSM-APP,,,,,,,,
+vacdsm-app,671,udp,VACDSM-APP,,,,,,,,
+vpps-qua,672,tcp,VPPS-QUA,,,,,,,,
+vpps-qua,672,udp,VPPS-QUA,,,,,,,,
+cimplex,673,tcp,CIMPLEX,[Ulysses_G_Smith_Jr],[Ulysses_G_Smith_Jr],,,,,,
+cimplex,673,udp,CIMPLEX,[Ulysses_G_Smith_Jr],[Ulysses_G_Smith_Jr],,,,,,
+acap,674,tcp,ACAP,[Chris_Newman],[Chris_Newman],,2010-10-15,,,,
+acap,674,udp,ACAP,[Chris_Newman],[Chris_Newman],,2010-10-15,,,,
+dctp,675,tcp,DCTP,[Andre_Kramer],[Andre_Kramer],,,,,,
+dctp,675,udp,DCTP,[Andre_Kramer],[Andre_Kramer],,,,,,
+vpps-via,676,tcp,VPPS Via,[Ulysses_G_Smith_Jr],[Ulysses_G_Smith_Jr],,,,,,
+vpps-via,676,udp,VPPS Via,[Ulysses_G_Smith_Jr],[Ulysses_G_Smith_Jr],,,,,,
+vpp,677,tcp,Virtual Presence Protocol,[Klaus_Wolf],[Klaus_Wolf],,,,,,
+vpp,677,udp,Virtual Presence Protocol,[Klaus_Wolf],[Klaus_Wolf],,,,,,
+ggf-ncp,678,tcp,GNU Generation Foundation NCP,[Noah_Paul],[Noah_Paul],,,,,,
+ggf-ncp,678,udp,GNU Generation Foundation NCP,[Noah_Paul],[Noah_Paul],,,,,,
+mrm,679,tcp,MRM,[Liming_Wei],[Liming_Wei],,,,,,
+mrm,679,udp,MRM,[Liming_Wei],[Liming_Wei],,,,,,
+entrust-aaas,680,tcp,entrust-aaas,,,,,,,,
+entrust-aaas,680,udp,entrust-aaas,,,,,,,,
+entrust-aams,681,tcp,entrust-aams,[Adrian_Mancini],[Adrian_Mancini],,,,,,
+entrust-aams,681,udp,entrust-aams,[Adrian_Mancini],[Adrian_Mancini],,,,,,
+xfr,682,tcp,XFR,[Noah_Paul_2],[Noah_Paul_2],,,,,,
+xfr,682,udp,XFR,[Noah_Paul_2],[Noah_Paul_2],,,,,,
+corba-iiop,683,tcp,CORBA IIOP,,,,,,,,
+corba-iiop,683,udp,CORBA IIOP,,,,,,,,
+corba-iiop-ssl,684,tcp,CORBA IIOP SSL,[Andrew_Watson],[Andrew_Watson],,,,,,
+corba-iiop-ssl,684,udp,CORBA IIOP SSL,[Andrew_Watson],[Andrew_Watson],,,,,,
+mdc-portmapper,685,tcp,MDC Port Mapper,[Noah_Paul],[Noah_Paul],,,,,,
+mdc-portmapper,685,udp,MDC Port Mapper,[Noah_Paul],[Noah_Paul],,,,,,
+hcp-wismar,686,tcp,Hardware Control Protocol Wismar,[David_Merchant],[David_Merchant],,,,,,
+hcp-wismar,686,udp,Hardware Control Protocol Wismar,[David_Merchant],[David_Merchant],,,,,,
+asipregistry,687,tcp,asipregistry,[Erik_Sea],[Erik_Sea],,,,,,
+asipregistry,687,udp,asipregistry,[Erik_Sea],[Erik_Sea],,,,,,
+realm-rusd,688,tcp,ApplianceWare managment protocol,[Stacy_Kenworthy],[Stacy_Kenworthy],,,,,,
+realm-rusd,688,udp,ApplianceWare managment protocol,[Stacy_Kenworthy],[Stacy_Kenworthy],,,,,,
+nmap,689,tcp,NMAP,[Peter_Dennis_Bartok],[Peter_Dennis_Bartok],,,,,,
+nmap,689,udp,NMAP,[Peter_Dennis_Bartok],[Peter_Dennis_Bartok],,,,,,
+vatp,690,tcp,Velazquez Application Transfer Protocol,[Velneo],[Velneo],,,,,,
+vatp,690,udp,Velazquez Application Transfer Protocol,[Velneo],[Velneo],,,,,,
+msexch-routing,691,tcp,MS Exchange Routing,[David_Lemson],[David_Lemson],,,,,,
+msexch-routing,691,udp,MS Exchange Routing,[David_Lemson],[David_Lemson],,,,,,
+hyperwave-isp,692,tcp,Hyperwave-ISP,[Gerald_Mesaric],[Gerald_Mesaric],,,,,,
+hyperwave-isp,692,udp,Hyperwave-ISP,[Gerald_Mesaric],[Gerald_Mesaric],,,,,,
+connendp,693,tcp,almanid Connection Endpoint,[Ronny_Bremer],[Ronny_Bremer],,,,,,
+connendp,693,udp,almanid Connection Endpoint,[Ronny_Bremer],[Ronny_Bremer],,,,,,
+ha-cluster,694,tcp,ha-cluster,[Alan_Robertson],[Alan_Robertson],,,,,,
+ha-cluster,694,udp,ha-cluster,[Alan_Robertson],[Alan_Robertson],,,,,,
+ieee-mms-ssl,695,tcp,IEEE-MMS-SSL,[Curtis_Anderson_2],[Curtis_Anderson_2],,,,,,
+ieee-mms-ssl,695,udp,IEEE-MMS-SSL,[Curtis_Anderson_2],[Curtis_Anderson_2],,,,,,
+rushd,696,tcp,RUSHD,[Greg_Ercolano],[Greg_Ercolano],,,,,,
+rushd,696,udp,RUSHD,[Greg_Ercolano],[Greg_Ercolano],,,,,,
+uuidgen,697,tcp,UUIDGEN,[James_Falkner],[James_Falkner],,,,,,
+uuidgen,697,udp,UUIDGEN,[James_Falkner],[James_Falkner],,,,,,
+olsr,698,tcp,OLSR,[Thomas_Clausen],[Thomas_Clausen],,,,,,
+olsr,698,udp,OLSR,[Thomas_Clausen],[Thomas_Clausen],,,,,,
+accessnetwork,699,tcp,Access Network,[Yingchun_Xu],[Yingchun_Xu],,,,,,
+accessnetwork,699,udp,Access Network,[Yingchun_Xu],[Yingchun_Xu],,,,,,
+epp,700,tcp,Extensible Provisioning Protocol,,,,,[RFC5734],,,
+epp,700,udp,Extensible Provisioning Protocol,,,,,[RFC5734],,,
+lmp,701,tcp,Link Management Protocol (LMP),,,,,[RFC4204],,,
+lmp,701,udp,Link Management Protocol (LMP),,,,,[RFC4204],,,
+iris-beep,702,tcp,IRIS over BEEP,,,,,[RFC3983],,,
+iris-beep,702,udp,IRIS over BEEP,,,,,[RFC3983],,,
+,703,,Unassigned,,,,,,,,
+elcsd,704,tcp,errlog copy/server daemon,,,,,,,,
+elcsd,704,udp,errlog copy/server daemon,,,,,,,,
+agentx,705,tcp,AgentX,[Bob_Natale],[Bob_Natale],,,,,,
+agentx,705,udp,AgentX,[Bob_Natale],[Bob_Natale],,,,,,
+silc,706,tcp,SILC,[Pekka_Riikonen],[Pekka_Riikonen],,,,,,
+silc,706,udp,SILC,[Pekka_Riikonen],[Pekka_Riikonen],,,,,,
+borland-dsj,707,tcp,Borland DSJ,[Gerg_Cole],[Gerg_Cole],,,,,,
+borland-dsj,707,udp,Borland DSJ,[Gerg_Cole],[Gerg_Cole],,,,,,
+,708,,Unassigned,,,,,,,,
+entrust-kmsh,709,tcp,Entrust Key Management Service Handler,,,,,,,,
+entrust-kmsh,709,udp,Entrust Key Management Service Handler,,,,,,,,
+entrust-ash,710,tcp,Entrust Administration Service Handler,[Peter_Whittaker],[Peter_Whittaker],,,,,,
+entrust-ash,710,udp,Entrust Administration Service Handler,[Peter_Whittaker],[Peter_Whittaker],,,,,,
+cisco-tdp,711,tcp,Cisco TDP,[Bruce_Davie],[Bruce_Davie],,,,,,
+cisco-tdp,711,udp,Cisco TDP,[Bruce_Davie],[Bruce_Davie],,,,,,
+tbrpf,712,tcp,TBRPF,,,,,[RFC3684],,,
+tbrpf,712,udp,TBRPF,,,,,[RFC3684],,,
+iris-xpc,713,tcp,IRIS over XPC,,,,,,,,
+iris-xpc,713,udp,IRIS over XPC,,,,,,,,
+iris-xpcs,714,tcp,IRIS over XPCS,,,,,[RFC4992],,,
+iris-xpcs,714,udp,IRIS over XPCS,,,,,[RFC4992],,,
+iris-lwz,715,tcp,IRIS-LWZ,,,,,[RFC4993],,,
+iris-lwz,715,udp,IRIS-LWZ,,,,,[RFC4993],,,
+pana,716,udp,PANA Messages,,,,,[RFC5191],,,
+,717-728,,Unassigned,,,,,,,,
+netviewdm1,729,tcp,IBM NetView DM/6000 Server/Client,,,,,,,,
+netviewdm1,729,udp,IBM NetView DM/6000 Server/Client,,,,,,,,
+netviewdm2,730,tcp,IBM NetView DM/6000 send/tcp,,,,,,,,
+netviewdm2,730,udp,IBM NetView DM/6000 send/tcp,,,,,,,,
+netviewdm3,731,tcp,IBM NetView DM/6000 receive/tcp,[Philippe_Binet],[Philippe_Binet],,,,,,
+netviewdm3,731,udp,IBM NetView DM/6000 receive/tcp,[Philippe_Binet],[Philippe_Binet],,,,,,
+,732-740,,Unassigned,,,,,,,,
+netgw,741,tcp,netGW,[Oliver_Korfmacher],[Oliver_Korfmacher],,,,,,
+netgw,741,udp,netGW,[Oliver_Korfmacher],[Oliver_Korfmacher],,,,,,
+netrcs,742,tcp,Network based Rev. Cont. Sys.,[Gordon_C_Galligher],[Gordon_C_Galligher],,,,,,
+netrcs,742,udp,Network based Rev. Cont. Sys.,[Gordon_C_Galligher],[Gordon_C_Galligher],,,,,,
+,743,,Unassigned,,,,,,,,
+flexlm,744,tcp,Flexible License Manager,[Matt_Christiano],[Matt_Christiano],,,,,,
+flexlm,744,udp,Flexible License Manager,[Matt_Christiano],[Matt_Christiano],,,,,,
+,745-746,,Unassigned,,,,,,,,
+fujitsu-dev,747,tcp,Fujitsu Device Control,,,,,,,,
+fujitsu-dev,747,udp,Fujitsu Device Control,,,,,,,,
+ris-cm,748,tcp,Russell Info Sci Calendar Manager,,,,,,,,
+ris-cm,748,udp,Russell Info Sci Calendar Manager,,,,,,,,
+kerberos-adm,749,tcp,kerberos administration,,,,,,,,
+kerberos-adm,749,udp,kerberos administration,,,,,,,,
+rfile,750,tcp,,,,,,,,,
+loadav,750,udp,,,,,,,,,
+kerberos-iv,750,udp,kerberos version iv,[Martin_Hamilton],[Martin_Hamilton],,,,,,
+pump,751,tcp,,,,,,,,,
+pump,751,udp,,,,,,,,,
+qrh,752,tcp,,,,,,,,,
+qrh,752,udp,,,,,,,,,
+rrh,753,tcp,,,,,,,,,
+rrh,753,udp,,,,,,,,,
+tell,754,tcp,send,[Josyula_R_Rao],[Josyula_R_Rao],,,,,,
+tell,754,udp,send,[Josyula_R_Rao],[Josyula_R_Rao],,,,,,
+,755-756,,Unassigned,,,,,,,,
+nlogin,758,tcp,,,,,,,,,
+nlogin,758,udp,,,,,,,,,
+con,759,tcp,,,,,,,,,
+con,759,udp,,,,,,,,,
+ns,760,tcp,,,,,,,,,
+ns,760,udp,,,,,,,,,
+rxe,761,tcp,,,,,,,,,
+rxe,761,udp,,,,,,,,,
+quotad,762,tcp,,,,,,,,,
+quotad,762,udp,,,,,,,,,
+cycleserv,763,tcp,,,,,,,,,
+cycleserv,763,udp,,,,,,,,,
+omserv,764,tcp,,,,,,,,,
+omserv,764,udp,,,,,,,,,
+webster,765,tcp,,[Josyula_R_Rao],[Josyula_R_Rao],,,,,,
+webster,765,udp,,[Josyula_R_Rao],[Josyula_R_Rao],,,,,,
+,766,,Unassigned,,,,,,,,
+phonebook,767,tcp,phone,[Josyula_R_Rao],[Josyula_R_Rao],,,,,,
+phonebook,767,udp,phone,[Josyula_R_Rao],[Josyula_R_Rao],,,,,,
+,768,,Unassigned,,,,,,,,
+vid,769,tcp,,,,,,,,,
+vid,769,udp,,,,,,,,,
+cadlock,770,tcp,,,,,,,,,
+cadlock,770,udp,,,,,,,,,
+rtip,771,tcp,,,,,,,,,
+rtip,771,udp,,,,,,,,,
+cycleserv2,772,tcp,,,,,,,,,
+cycleserv2,772,udp,,,,,,,,,
+submit,773,tcp,,,,,,,,,
+notify,773,udp,,,,,,,,,
+rpasswd,774,tcp,,,,,,,,,
+acmaint-dbd,774,udp,"IANA assigned this well-formed service name as a replacement for ""acmaint_dbd"".",,,,,,,,
+acmaint_dbd,774,udp,,,,,,,,,"This entry is an alias to ""acmaint-dbd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+entomb,775,tcp,,,,,,,,,
+acmaint-transd,775,udp,"IANA assigned this well-formed service name as a replacement for ""acmaint_transd"".",,,,,,,,
+acmaint_transd,775,udp,,,,,,,,,"This entry is an alias to ""acmaint-transd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+wpages,776,tcp,,[Josyula_R_Rao],[Josyula_R_Rao],,,,,,
+wpages,776,udp,,[Josyula_R_Rao],[Josyula_R_Rao],,,,,,
+multiling-http,777,tcp,Multiling HTTP,[Alejandro_Bonet],[Alejandro_Bonet],,,,,,
+multiling-http,777,udp,Multiling HTTP,[Alejandro_Bonet],[Alejandro_Bonet],,,,,,
+,778-779,,Unassigned,,,,,,,,
+wpgs,780,tcp,,[Josyula_R_Rao],[Josyula_R_Rao],,,,,,
+wpgs,780,udp,,[Josyula_R_Rao],[Josyula_R_Rao],,,,,,
+,781-785,,Unassigned,,,,,,,,
+,786,,Unassigned,,,,2002-05-08,,,,
+,787,,Unassigned,,,,2002-10-08,,,,
+,788-799,,Unassigned,,,,,,,Unauthorized Use Known on port 796,
+mdbs-daemon,800,tcp,"IANA assigned this well-formed service name as a replacement for ""mdbs_daemon"".",,,,,,,,
+mdbs_daemon,800,tcp,,,,,,,,,"This entry is an alias to ""mdbs-daemon"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+mdbs-daemon,800,udp,"IANA assigned this well-formed service name as a replacement for ""mdbs_daemon"".",,,,,,,,
+mdbs_daemon,800,udp,,,,,,,,,"This entry is an alias to ""mdbs-daemon"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+device,801,tcp,,,,,,,,,
+device,801,udp,,,,,,,,,
+mbap-s,802,tcp,Modbus Application Protocol Secure,[modbus.org],[Dennis_Dube],2014-06-10,,,,,
+mbap-s,802,udp,Modbus Application Protocol Secure,[modbus.org],[Dennis_Dube],2014-06-10,,,,,
+,803-809,,Unassigned,,,,,,,,
+fcp-udp,810,tcp,FCP,[Paul_Whittemore],[Paul_Whittemore],,,,,,
+fcp-udp,810,udp,FCP Datagram,[Paul_Whittemore],[Paul_Whittemore],,,,,,
+,811-827,,Unassigned,,,,,,,,
+itm-mcell-s,828,tcp,itm-mcell-s,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+itm-mcell-s,828,udp,itm-mcell-s,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+pkix-3-ca-ra,829,tcp,PKIX-3 CA/RA,[Carlisle_Adams],[Carlisle_Adams],,,,,,
+pkix-3-ca-ra,829,udp,PKIX-3 CA/RA,[Carlisle_Adams],[Carlisle_Adams],,,,,,
+netconf-ssh,830,tcp,NETCONF over SSH,,,,,[RFC6242],,,
+netconf-ssh,830,udp,NETCONF over SSH,,,,,[RFC6242],,,
+netconf-beep,831,tcp,NETCONF over BEEP,,,,,[RFC4744],,,
+netconf-beep,831,udp,NETCONF over BEEP,,,,,[RFC4744],,,
+netconfsoaphttp,832,tcp,NETCONF for SOAP over HTTPS,,,,,[RFC4743],,,
+netconfsoaphttp,832,udp,NETCONF for SOAP over HTTPS,,,,,[RFC4743],,,
+netconfsoapbeep,833,tcp,NETCONF for SOAP over BEEP,,,,,[RFC4743],,,
+netconfsoapbeep,833,udp,NETCONF for SOAP over BEEP,,,,,[RFC4743],,,
+,834-846,,Unassigned,,,,,,,,
+dhcp-failover2,847,tcp,dhcp-failover 2,[Bernard_Volz],[Bernard_Volz],,,,,,
+dhcp-failover2,847,udp,dhcp-failover 2,[Bernard_Volz],[Bernard_Volz],,,,,,
+gdoi,848,tcp,GDOI,,,,,[RFC3547],,,
+gdoi,848,udp,GDOI,,,,,[RFC3547],,,
+,849-859,,Unassigned,,,,,,,,
+iscsi,860,tcp,iSCSI,[IESG],[IETF_Chair],,2013-08-27,[RFC7143],,,
+iscsi,860,udp,iSCSI,[IESG],[IETF_Chair],,2013-08-27,[RFC7143],,,
+owamp-control,861,tcp,OWAMP-Control,,,,,[RFC4656],,,
+owamp-control,861,udp,OWAMP-Control,,,,,[RFC4656],,,
+twamp-control,862,tcp,Two-way Active Measurement Protocol (TWAMP) Control,,,,,[RFC5357],,,
+twamp-control,862,udp,Two-way Active Measurement Protocol (TWAMP) Control,,,,,[RFC5357],,,
+,863-872,,Unassigned,,,,,,,,
+rsync,873,tcp,rsync,[Andrew_Tridgell],[Andrew_Tridgell],,,,,,
+rsync,873,udp,rsync,[Andrew_Tridgell],[Andrew_Tridgell],,,,,,
+,874-885,,Unassigned,,,,,,,,
+iclcnet-locate,886,tcp,ICL coNETion locate server,[Bob_Lyon],[Bob_Lyon],,,,,,
+iclcnet-locate,886,udp,ICL coNETion locate server,[Bob_Lyon],[Bob_Lyon],,,,,,
+iclcnet-svinfo,887,tcp,"ICL coNETion server info
+IANA assigned this well-formed service name as a replacement for ""iclcnet_svinfo"".",[Bob_Lyon],[Bob_Lyon],,,,,,
+iclcnet_svinfo,887,tcp,ICL coNETion server info,[Bob_Lyon],[Bob_Lyon],,,,,,"This entry is an alias to ""iclcnet-svinfo"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+iclcnet-svinfo,887,udp,"ICL coNETion server info
+IANA assigned this well-formed service name as a replacement for ""iclcnet_svinfo"".",[Bob_Lyon],[Bob_Lyon],,,,,,
+iclcnet_svinfo,887,udp,ICL coNETion server info,[Bob_Lyon],[Bob_Lyon],,,,,,"This entry is an alias to ""iclcnet-svinfo"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+accessbuilder,888,tcp,AccessBuilder,[Steve_Sweeney],[Steve_Sweeney],,,,,,
+accessbuilder,888,udp,AccessBuilder,[Steve_Sweeney],[Steve_Sweeney],,,,,,
+cddbp,888,tcp,CD Database Protocol,[Steve_Scherf],[Steve_Scherf],,,,,,This entry records an unassigned but widespread use
+,889-899,,Unassigned,,,,,,,,
+omginitialrefs,900,tcp,OMG Initial Refs,[Christian_Callsen],[Christian_Callsen],,,,,,
+omginitialrefs,900,udp,OMG Initial Refs,[Christian_Callsen],[Christian_Callsen],,,,,,
+smpnameres,901,tcp,SMPNAMERES,[Leif_Ekblad],[Leif_Ekblad],,,,,,
+smpnameres,901,udp,SMPNAMERES,[Leif_Ekblad],[Leif_Ekblad],,,,,,
+ideafarm-door,902,tcp,self documenting Telnet Door,,,,,,,,
+ideafarm-door,902,udp,self documenting Door: send 0x00 for info,,,,,,,,
+ideafarm-panic,903,tcp,self documenting Telnet Panic Door,[Wo_o_Ideafarm],[Wo_o_Ideafarm],,,,,,
+ideafarm-panic,903,udp,self documenting Panic Door: send 0x00 for info,[Wo_o_Ideafarm],[Wo_o_Ideafarm],,,,,,
+,904-909,,Unassigned,,,,,,,,
+kink,910,tcp,Kerberized Internet Negotiation of Keys (KINK),,,,,[RFC4430],,,
+kink,910,udp,Kerberized Internet Negotiation of Keys (KINK),,,,,[RFC4430],,,
+xact-backup,911,tcp,xact-backup,[Bill_Carroll],[Bill_Carroll],,,,,,
+xact-backup,911,udp,xact-backup,[Bill_Carroll],[Bill_Carroll],,,,,,
+apex-mesh,912,tcp,APEX relay-relay service,,,,,,,,
+apex-mesh,912,udp,APEX relay-relay service,,,,,,,,
+apex-edge,913,tcp,APEX endpoint-relay service,,,,,[RFC3340],,,
+apex-edge,913,udp,APEX endpoint-relay service,,,,,[RFC3340],,,
+,914-988,,Unassigned,,,,,,,,
+ftps-data,989,tcp,"ftp protocol, data, over TLS/SSL",,,,,,,,
+ftps-data,989,udp,"ftp protocol, data, over TLS/SSL",,,,,,,,
+ftps,990,tcp,"ftp protocol, control, over TLS/SSL",[Christopher_Allen],[Christopher_Allen],,,,,,
+ftps,990,udp,"ftp protocol, control, over TLS/SSL",[Christopher_Allen],[Christopher_Allen],,,,,,
+nas,991,tcp,Netnews Administration System,[Vera_Heinau][Heiko_Schlichting],[Vera_Heinau][Heiko_Schlichting],,,,,,
+nas,991,udp,Netnews Administration System,[Vera_Heinau][Heiko_Schlichting],[Vera_Heinau][Heiko_Schlichting],,,,,,
+telnets,992,tcp,telnet protocol over TLS/SSL,,,,,,,,
+telnets,992,udp,telnet protocol over TLS/SSL,,,,,,,,
+imaps,993,tcp,imap4 protocol over TLS/SSL,,,,,,,,
+imaps,993,udp,imap4 protocol over TLS/SSL,,,,,,,,
+,994,tcp,Reserved,,,,2011-08-31,,,,(previous contact was[Christopher_Allen])
+,994,udp,Reserved,,,,,,,,
+pop3s,995,tcp,pop3 protocol over TLS/SSL (was spop3),[Gordon_Mangione],[Gordon_Mangione],,,,,,
+pop3s,995,udp,pop3 protocol over TLS/SSL (was spop3),[Gordon_Mangione],[Gordon_Mangione],,,,,,
+vsinet,996,tcp,vsinet,[Rob_Juergens],[Rob_Juergens],,,,,,
+vsinet,996,udp,vsinet,[Rob_Juergens],[Rob_Juergens],,,,,,
+maitrd,997,tcp,,,,,,,,,
+maitrd,997,udp,,,,,,,,,
+busboy,998,tcp,,,,,,,,,
+puparp,998,udp,,,,,,,,,
+garcon,999,tcp,,,,,,,,,
+applix,999,udp,Applix ac,,,,,,,,
+puprouter,999,tcp,,,,,,,,,
+puprouter,999,udp,,,,,,,,,
+cadlock2,1000,tcp,,,,,,,,,
+cadlock2,1000,udp,,,,,,,,,
+,1001-1009,,Unassigned,,,,,,,,
+,1008,udp,Possibly used by Sun Solaris????,,,,,,,,
+surf,1010,tcp,surf,[Joseph_Geer],[Joseph_Geer],,,,,,
+surf,1010,udp,surf,[Joseph_Geer],[Joseph_Geer],,,,,,
+,1011-1020,,Reserved,,,,,,,,
+exp1,1021,tcp,RFC3692-style Experiment 1,[IESG],[IETF_Chair],,,[1][RFC4727][RFC6335],,,
+exp1,1021,udp,RFC3692-style Experiment 1,[IESG],[IETF_Chair],,,[1][RFC4727][RFC6335],,,
+exp1,1021,sctp,RFC3692-style Experiment 1,[IESG],[IETF_Chair],,,[1][RFC4727][RFC6335],,,
+exp1,1021,dccp,RFC3692-style Experiment 1,[IESG],[IETF_Chair],,,[1][RFC4727][RFC6335],,,
+exp2,1022,tcp,RFC3692-style Experiment 2,[IESG],[IETF_Chair],,,[1][RFC4727][RFC6335],,,
+exp2,1022,udp,RFC3692-style Experiment 2,[IESG],[IETF_Chair],,,[1][RFC4727][RFC6335],,,
+exp2,1022,sctp,RFC3692-style Experiment 2,[IESG],[IETF_Chair],,,[1][RFC4727][RFC6335],,,
+exp2,1022,dccp,RFC3692-style Experiment 2,[IESG],[IETF_Chair],,,[1][RFC4727][RFC6335],,,
+,1023,tcp,Reserved,[IANA],[IANA],,,,,,
+,1023,udp,Reserved,[IANA],[IANA],,,,,,
+,1024,tcp,Reserved,[IANA],[IANA],,,,,,
+,1024,udp,Reserved,[IANA],[IANA],,,,,,
+blackjack,1025,tcp,network blackjack,,,,,,,,
+blackjack,1025,udp,network blackjack,,,,,,,,
+cap,1026,tcp,Calendar Access Protocol,[Doug_Royer],[Doug_Royer],2010-12-09,,,,,
+cap,1026,udp,Calendar Access Protocol,[Doug_Royer],[Doug_Royer],2010-12-09,,,,,
+6a44,1027,udp,IPv6 Behind NAT44 CPEs,[IESG],[IETF_Chair],2012-08-02,,[RFC6751],,,
+,1027,tcp,Reserved,,,,,,,,
+,1028,,Deprecated,,,,2004-02,,,,
+solid-mux,1029,tcp,Solid Mux Server,[Anders_Borg],[Anders_Borg],2004-11,,,,,
+solid-mux,1029,udp,Solid Mux Server,[Anders_Borg],[Anders_Borg],2004-11,,,,,
+,1030,,Reserved,,,,2013-05-24,,,,This entry is being removed on 2013-05-24.
+,1031,,Reserved,,,,2013-05-24,,,,This entry is being removed on 2013-05-24.
+,1032,,Reserved,,,,2013-05-24,,,,This entry is being removed on 2013-05-24.
+netinfo-local,1033,tcp,local netinfo port,[Marc_Majka],[Marc_Majka],2002-08,,,,,
+netinfo-local,1033,udp,local netinfo port,[Marc_Majka],[Marc_Majka],2002-08,,,,,
+activesync,1034,tcp,ActiveSync Notifications,[Sandra_Vargas],[Sandra_Vargas],2003-03,,,,,
+activesync,1034,udp,ActiveSync Notifications,[Sandra_Vargas],[Sandra_Vargas],2003-03,,,,,
+mxxrlogin,1035,tcp,MX-XR RPC,[Arnold_E_Mauer],[Arnold_E_Mauer],2003-04,,,,,
+mxxrlogin,1035,udp,MX-XR RPC,[Arnold_E_Mauer],[Arnold_E_Mauer],2003-04,,,,,
+nsstp,1036,tcp,Nebula Secure Segment Transfer Protocol,[Steve_Ravida],[Steve_Ravida],,,,,,
+nsstp,1036,udp,Nebula Secure Segment Transfer Protocol,[Steve_Ravida],[Steve_Ravida],,,,,,
+ams,1037,tcp,AMS,[Ronald_R_Ohmer],[Ronald_R_Ohmer],2004-02,,,,,
+ams,1037,udp,AMS,[Ronald_R_Ohmer],[Ronald_R_Ohmer],2004-02,,,,,
+mtqp,1038,tcp,Message Tracking Query Protocol,,,,,[RFC3887],,,
+mtqp,1038,udp,Message Tracking Query Protocol,,,,,[RFC3887],,,
+sbl,1039,tcp,Streamlined Blackhole,[Jonathan_A_Zdziaras],[Jonathan_A_Zdziaras],2004-11,,,,,
+sbl,1039,udp,Streamlined Blackhole,[Jonathan_A_Zdziaras],[Jonathan_A_Zdziaras],2004-11,,,,,
+netarx,1040,tcp,Netarx Netcare,[Sandy_Kronenberg],[Sandy_Kronenberg],2008-04-03,,,,,
+netarx,1040,udp,Netarx Netcare,[Sandy_Kronenberg],[Sandy_Kronenberg],2008-04-03,,,,,
+danf-ak2,1041,tcp,AK2 Product,[Karl_Palsson],[Karl_Palsson],2004-11,,,,,
+danf-ak2,1041,udp,AK2 Product,[Karl_Palsson],[Karl_Palsson],2004-11,,,,,
+afrog,1042,tcp,Subnet Roaming,[Michael_Chapman],[Michael_Chapman],2004-11,,,,,
+afrog,1042,udp,Subnet Roaming,[Michael_Chapman],[Michael_Chapman],2004-11,,,,,
+boinc-client,1043,tcp,BOINC Client Control,[David_Anderson],[David_Anderson],2004-11,,,,,
+boinc-client,1043,udp,BOINC Client Control,[David_Anderson],[David_Anderson],2004-11,,,,,
+dcutility,1044,tcp,Dev Consortium Utility,[Chris_Ryland],[Chris_Ryland],2004-11,,,,,
+dcutility,1044,udp,Dev Consortium Utility,[Chris_Ryland],[Chris_Ryland],2004-11,,,,,
+fpitp,1045,tcp,Fingerprint Image Transfer Protocol,[Steven_Fields],[Steven_Fields],2002-02,,,,,
+fpitp,1045,udp,Fingerprint Image Transfer Protocol,[Steven_Fields],[Steven_Fields],2002-02,,,,,
+wfremotertm,1046,tcp,WebFilter Remote Monitor,[Tim_Morgan],[Tim_Morgan],2004-11,,,,,
+wfremotertm,1046,udp,WebFilter Remote Monitor,[Tim_Morgan],[Tim_Morgan],2004-11,,,,,
+neod1,1047,tcp,Sun's NEO Object Request Broker,,,,,,,,
+neod1,1047,udp,Sun's NEO Object Request Broker,,,,,,,,
+neod2,1048,tcp,Sun's NEO Object Request Broker,[Rohit_Garg],[Rohit_Garg],,,,,,
+neod2,1048,udp,Sun's NEO Object Request Broker,[Rohit_Garg],[Rohit_Garg],,,,,,
+td-postman,1049,tcp,Tobit David Postman VPMN,[Franz_Josef_Leuders],[Franz_Josef_Leuders],,,,,,
+td-postman,1049,udp,Tobit David Postman VPMN,[Franz_Josef_Leuders],[Franz_Josef_Leuders],,,,,,
+cma,1050,tcp,CORBA Management Agent,[Ramy_Zaarour],[Ramy_Zaarour],,,,,,
+cma,1050,udp,CORBA Management Agent,[Ramy_Zaarour],[Ramy_Zaarour],,,,,,
+optima-vnet,1051,tcp,Optima VNET,[Ralf_Doewich],[Ralf_Doewich],,,,,,
+optima-vnet,1051,udp,Optima VNET,[Ralf_Doewich],[Ralf_Doewich],,,,,,
+ddt,1052,tcp,Dynamic DNS Tools,[Remi_Lefebvre],[Remi_Lefebvre],,,,,,
+ddt,1052,udp,Dynamic DNS Tools,[Remi_Lefebvre],[Remi_Lefebvre],,,,,,
+remote-as,1053,tcp,Remote Assistant (RA),[Roman_Kriis],[Roman_Kriis],,,,,Unauthorized Use Known on port 1053,
+remote-as,1053,udp,Remote Assistant (RA),[Roman_Kriis],[Roman_Kriis],,,,,,
+brvread,1054,tcp,BRVREAD,[A_Boninn],[A_Boninn],,,,,,
+brvread,1054,udp,BRVREAD,[A_Boninn],[A_Boninn],,,,,,
+ansyslmd,1055,tcp,ANSYS - License Manager,[Suzanne_Lorrin],[Suzanne_Lorrin],,,,,,
+ansyslmd,1055,udp,ANSYS - License Manager,[Suzanne_Lorrin],[Suzanne_Lorrin],,,,,,
+vfo,1056,tcp,VFO,[Anthony_Gonzalez],[Anthony_Gonzalez],,,,,,
+vfo,1056,udp,VFO,[Anthony_Gonzalez],[Anthony_Gonzalez],,,,,,
+startron,1057,tcp,STARTRON,[Markus_Sabadello],[Markus_Sabadello],,,,,,
+startron,1057,udp,STARTRON,[Markus_Sabadello],[Markus_Sabadello],,,,,,
+nim,1058,tcp,nim,,,,,,,,
+nim,1058,udp,nim,,,,,,,,
+nimreg,1059,tcp,nimreg,[Robert_Gordon],[Robert_Gordon],,,,,,
+nimreg,1059,udp,nimreg,[Robert_Gordon],[Robert_Gordon],,,,,,
+polestar,1060,tcp,POLESTAR,[Masakuni_Okada],[Masakuni_Okada],,,,,,
+polestar,1060,udp,POLESTAR,[Masakuni_Okada],[Masakuni_Okada],,,,,,
+kiosk,1061,tcp,KIOSK,[Ken_Ksiazek],[Ken_Ksiazek],,,,,,
+kiosk,1061,udp,KIOSK,[Ken_Ksiazek],[Ken_Ksiazek],,,,,,
+veracity,1062,tcp,Veracity,[Ross_Williams],[Ross_Williams],,,,,,
+veracity,1062,udp,Veracity,[Ross_Williams],[Ross_Williams],,,,,,
+kyoceranetdev,1063,tcp,KyoceraNetDev,[Shigenaka_Kanemitsu],[Shigenaka_Kanemitsu],,,,,,
+kyoceranetdev,1063,udp,KyoceraNetDev,[Shigenaka_Kanemitsu],[Shigenaka_Kanemitsu],,,,,,
+jstel,1064,tcp,JSTEL,[Duane_Kiser],[Duane_Kiser],,,,,,
+jstel,1064,udp,JSTEL,[Duane_Kiser],[Duane_Kiser],,,,,,
+syscomlan,1065,tcp,SYSCOMLAN,[Alexandre_Lechenne],[Alexandre_Lechenne],2008-12-10,,,,,
+syscomlan,1065,udp,SYSCOMLAN,[Alexandre_Lechenne],[Alexandre_Lechenne],2008-12-10,,,,,
+fpo-fns,1066,tcp,FPO-FNS,[Jens_Klose],[Jens_Klose],,,,,,
+fpo-fns,1066,udp,FPO-FNS,[Jens_Klose],[Jens_Klose],,,,,,
+instl-boots,1067,tcp,"Installation Bootstrap Proto. Serv.
+IANA assigned this well-formed service name as a replacement for ""instl_boots"".",,,,,,,,
+instl_boots,1067,tcp,Installation Bootstrap Proto. Serv.,,,,,,,,"This entry is an alias to ""instl-boots"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+instl-boots,1067,udp,"Installation Bootstrap Proto. Serv.
+IANA assigned this well-formed service name as a replacement for ""instl_boots"".",,,,,,,,
+instl_boots,1067,udp,Installation Bootstrap Proto. Serv.,,,,,,,,"This entry is an alias to ""instl-boots"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+instl-bootc,1068,tcp,"Installation Bootstrap Proto. Cli.
+IANA assigned this well-formed service name as a replacement for ""instl_bootc"".",[David_Arko],[David_Arko],,,,,,
+instl_bootc,1068,tcp,Installation Bootstrap Proto. Cli.,[David_Arko],[David_Arko],,,,,,"This entry is an alias to ""instl-bootc"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+instl-bootc,1068,udp,"Installation Bootstrap Proto. Cli.
+IANA assigned this well-formed service name as a replacement for ""instl_bootc"".",[David_Arko],[David_Arko],,,,,,
+instl_bootc,1068,udp,Installation Bootstrap Proto. Cli.,[David_Arko],[David_Arko],,,,,,"This entry is an alias to ""instl-bootc"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+cognex-insight,1069,tcp,COGNEX-INSIGHT,[Steve_Olson],[Steve_Olson],,,,,,
+cognex-insight,1069,udp,COGNEX-INSIGHT,[Steve_Olson],[Steve_Olson],,,,,,
+gmrupdateserv,1070,tcp,GMRUpdateSERV,[Steve_Kellogg],[Steve_Kellogg],,,,,,
+gmrupdateserv,1070,udp,GMRUpdateSERV,[Steve_Kellogg],[Steve_Kellogg],,,,,,
+bsquare-voip,1071,tcp,BSQUARE-VOIP,[Yen_Lee],[Yen_Lee],,,,,,
+bsquare-voip,1071,udp,BSQUARE-VOIP,[Yen_Lee],[Yen_Lee],,,,,,
+cardax,1072,tcp,CARDAX,[Charles_Oram],[Charles_Oram],,,,,,
+cardax,1072,udp,CARDAX,[Charles_Oram],[Charles_Oram],,,,,,
+bridgecontrol,1073,tcp,Bridge Control,[Andy_Heron],[Andy_Heron],,,,,,
+bridgecontrol,1073,udp,Bridge Control,[Andy_Heron],[Andy_Heron],,,,,,
+warmspotMgmt,1074,tcp,Warmspot Management Protocol,[Robert_C_Henningsga],[Robert_C_Henningsga],,,,,,
+warmspotMgmt,1074,udp,Warmspot Management Protocol,[Robert_C_Henningsga],[Robert_C_Henningsga],,,,,,
+rdrmshc,1075,tcp,RDRMSHC,[Ericko_Shimada],[Ericko_Shimada],,,,,,
+rdrmshc,1075,udp,RDRMSHC,[Ericko_Shimada],[Ericko_Shimada],,,,,,
+dab-sti-c,1076,tcp,DAB STI-C,[World_DAB],[World_DAB],,,,,,
+dab-sti-c,1076,udp,DAB STI-C,[World_DAB],[World_DAB],,,,,,
+imgames,1077,tcp,IMGames,[Jean_A_Ames],[Jean_A_Ames],,,,,,
+imgames,1077,udp,IMGames,[Jean_A_Ames],[Jean_A_Ames],,,,,,
+avocent-proxy,1078,tcp,Avocent Proxy Protocol,[Steven_W_Clark],[Steven_W_Clark],,,,,,
+avocent-proxy,1078,udp,Avocent Proxy Protocol,[Steven_W_Clark],[Steven_W_Clark],,,,,,
+asprovatalk,1079,tcp,ASPROVATalk,[Chiew_Farn_Chung],[Chiew_Farn_Chung],,,,,,
+asprovatalk,1079,udp,ASPROVATalk,[Chiew_Farn_Chung],[Chiew_Farn_Chung],,,,,,
+socks,1080,tcp,Socks,[Ying_Da_Lee],[Ying_Da_Lee],,,,,,
+socks,1080,udp,Socks,[Ying_Da_Lee],[Ying_Da_Lee],,,,,,
+pvuniwien,1081,tcp,PVUNIWIEN,[Peter_Lipp],[Peter_Lipp],,,,,,
+pvuniwien,1081,udp,PVUNIWIEN,[Peter_Lipp],[Peter_Lipp],,,,,,
+amt-esd-prot,1082,tcp,AMT-ESD-PROT,[AMTEC_S_p_A],[AMTEC_S_p_A],,,,,,
+amt-esd-prot,1082,udp,AMT-ESD-PROT,[AMTEC_S_p_A],[AMTEC_S_p_A],,,,,,
+ansoft-lm-1,1083,tcp,Anasoft License Manager,,,,,,,,
+ansoft-lm-1,1083,udp,Anasoft License Manager,,,,,,,,
+ansoft-lm-2,1084,tcp,Anasoft License Manager,,,,,,,,
+ansoft-lm-2,1084,udp,Anasoft License Manager,,,,,,,,
+webobjects,1085,tcp,Web Objects,[Andy_Belk],[Andy_Belk],,,,,,
+webobjects,1085,udp,Web Objects,[Andy_Belk],[Andy_Belk],,,,,,
+cplscrambler-lg,1086,tcp,CPL Scrambler Logging,,,,,,,,
+cplscrambler-lg,1086,udp,CPL Scrambler Logging,,,,,,,,
+cplscrambler-in,1087,tcp,CPL Scrambler Internal,,,,,,,,
+cplscrambler-in,1087,udp,CPL Scrambler Internal,,,,,,,,
+cplscrambler-al,1088,tcp,CPL Scrambler Alarm Log,[Richard_Corn],[Richard_Corn],,,,,,
+cplscrambler-al,1088,udp,CPL Scrambler Alarm Log,[Richard_Corn],[Richard_Corn],,,,,,
+ff-annunc,1089,tcp,FF Annunciation,,,,,,,,
+ff-annunc,1089,udp,FF Annunciation,,,,,,,,
+ff-fms,1090,tcp,FF Fieldbus Message Specification,,,,,,,,
+ff-fms,1090,udp,FF Fieldbus Message Specification,,,,,,,,
+ff-sm,1091,tcp,FF System Management,[Fieldbus_Foundation],[Fieldbus_Foundation],,,,,,
+ff-sm,1091,udp,FF System Management,[Fieldbus_Foundation],[Fieldbus_Foundation],,,,,,
+obrpd,1092,tcp,Open Business Reporting Protocol,[William_Randolph_Roy],[William_Randolph_Roy],,,,,,
+obrpd,1092,udp,Open Business Reporting Protocol,[William_Randolph_Roy],[William_Randolph_Roy],,,,,,
+proofd,1093,tcp,PROOFD,,,,,,,,
+proofd,1093,udp,PROOFD,,,,,,,,
+rootd,1094,tcp,ROOTD,[Fons_Rademakers],[Fons_Rademakers],,,,,,
+rootd,1094,udp,ROOTD,[Fons_Rademakers],[Fons_Rademakers],,,,,,
+nicelink,1095,tcp,NICELink,[Jordi_Lisbona],[Jordi_Lisbona],,,,,,
+nicelink,1095,udp,NICELink,[Jordi_Lisbona],[Jordi_Lisbona],,,,,,
+cnrprotocol,1096,tcp,Common Name Resolution Protocol,[Michael_Mealling],[Michael_Mealling],,,,,,
+cnrprotocol,1096,udp,Common Name Resolution Protocol,[Michael_Mealling],[Michael_Mealling],,,,,,
+sunclustermgr,1097,tcp,Sun Cluster Manager,[Ashit_Patel],[Ashit_Patel],,,,,,
+sunclustermgr,1097,udp,Sun Cluster Manager,[Ashit_Patel],[Ashit_Patel],,,,,,
+rmiactivation,1098,tcp,RMI Activation,,,,,,,,
+rmiactivation,1098,udp,RMI Activation,,,,,,,,
+rmiregistry,1099,tcp,RMI Registry,[Mark_Hodapp],[Mark_Hodapp],,,,,,
+rmiregistry,1099,udp,RMI Registry,[Mark_Hodapp],[Mark_Hodapp],,,,,,
+mctp,1100,tcp,MCTP,[Vitaly_Revsin],[Vitaly_Revsin],,,,,,
+mctp,1100,udp,MCTP,[Vitaly_Revsin],[Vitaly_Revsin],,,,,,
+pt2-discover,1101,tcp,PT2-DISCOVER,[Ralph_Kammerlander],[Ralph_Kammerlander],,,,,,
+pt2-discover,1101,udp,PT2-DISCOVER,[Ralph_Kammerlander],[Ralph_Kammerlander],,,,,,
+adobeserver-1,1102,tcp,ADOBE SERVER 1,,,,,,,,
+adobeserver-1,1102,udp,ADOBE SERVER 1,,,,,,,,
+adobeserver-2,1103,tcp,ADOBE SERVER 2,[Frank_Soetebeer],[Frank_Soetebeer],,,,,,
+adobeserver-2,1103,udp,ADOBE SERVER 2,[Frank_Soetebeer],[Frank_Soetebeer],,,,,,
+xrl,1104,tcp,XRL,[Patrick_Robinson],[Patrick_Robinson],,,,,,
+xrl,1104,udp,XRL,[Patrick_Robinson],[Patrick_Robinson],,,,,,
+ftranhc,1105,tcp,FTRANHC,[Eriko_Shimada],[Eriko_Shimada],,,,,,
+ftranhc,1105,udp,FTRANHC,[Eriko_Shimada],[Eriko_Shimada],,,,,,
+isoipsigport-1,1106,tcp,ISOIPSIGPORT-1,,,,,,,,
+isoipsigport-1,1106,udp,ISOIPSIGPORT-1,,,,,,,,
+isoipsigport-2,1107,tcp,ISOIPSIGPORT-2,[Peter_Egli],[Peter_Egli],,,,,,
+isoipsigport-2,1107,udp,ISOIPSIGPORT-2,[Peter_Egli],[Peter_Egli],,,,,,
+ratio-adp,1108,tcp,ratio-adp,[Oliver_Thulke],[Oliver_Thulke],,,,,,
+ratio-adp,1108,udp,ratio-adp,[Oliver_Thulke],[Oliver_Thulke],,,,,,
+,1109,,Reserved - IANA,,,,,,,,
+webadmstart,1110,tcp,Start web admin server,,,,,,,,
+nfsd-keepalive,1110,udp,Client status info,[Beth_Crespo],[Beth_Crespo],,,,,,
+lmsocialserver,1111,tcp,LM Social Server,[Ron_Lussier],[Ron_Lussier],,,,,,
+lmsocialserver,1111,udp,LM Social Server,[Ron_Lussier],[Ron_Lussier],,,,,,
+icp,1112,tcp,Intelligent Communication Protocol,[Mark_H_David],[Mark_H_David],,,,,,
+icp,1112,udp,Intelligent Communication Protocol,[Mark_H_David],[Mark_H_David],,,,,,
+ltp-deepspace,1113,tcp,Licklider Transmission Protocol,,,,,[RFC5326],,,
+ltp-deepspace,1113,udp,Licklider Transmission Protocol,,,,2014-02-21,[RFC5326][RFC7122],,,
+ltp-deepspace,1113,dccp,Licklider Transmission Protocol,,,2013-11-12,2014-02-21,[RFC7122],7107696,,
+mini-sql,1114,tcp,Mini SQL,[David_Hughes],[David_Hughes],,,,,,
+mini-sql,1114,udp,Mini SQL,[David_Hughes],[David_Hughes],,,,,,
+ardus-trns,1115,tcp,ARDUS Transfer,,,,,,,,
+ardus-trns,1115,udp,ARDUS Transfer,,,,,,,,
+ardus-cntl,1116,tcp,ARDUS Control,,,,,,,,
+ardus-cntl,1116,udp,ARDUS Control,,,,,,,,
+ardus-mtrns,1117,tcp,ARDUS Multicast Transfer,[Shinya_Abe],[Shinya_Abe],,,,,,
+ardus-mtrns,1117,udp,ARDUS Multicast Transfer,[Shinya_Abe],[Shinya_Abe],,,,,,
+sacred,1118,tcp,SACRED,,,,,[RFC3767],,,
+sacred,1118,udp,SACRED,,,,,[RFC3767],,,
+bnetgame,1119,tcp,Battle.net Chat/Game Protocol,,,,,,,,
+bnetgame,1119,udp,Battle.net Chat/Game Protocol,,,,,,,,
+bnetfile,1120,tcp,Battle.net File Transfer Protocol,[Domain_Tech],[Domain_Tech],2005-04,,,,,
+bnetfile,1120,udp,Battle.net File Transfer Protocol,[Domain_Tech],[Domain_Tech],2005-04,,,,,
+rmpp,1121,tcp,Datalode RMPP,[Dave_Ruedger],[Dave_Ruedger],2003-11,,,,,
+rmpp,1121,udp,Datalode RMPP,[Dave_Ruedger],[Dave_Ruedger],2003-11,,,,,
+availant-mgr,1122,tcp,availant-mgr,[Steven_Pelletier],[Steven_Pelletier],,,,,,
+availant-mgr,1122,udp,availant-mgr,[Steven_Pelletier],[Steven_Pelletier],,,,,,
+murray,1123,tcp,Murray,[Stu_Mark],[Stu_Mark],,,,,,
+murray,1123,udp,Murray,[Stu_Mark],[Stu_Mark],,,,,,
+hpvmmcontrol,1124,tcp,HP VMM Control,,,,,,,,
+hpvmmcontrol,1124,udp,HP VMM Control,,,,,,,,
+hpvmmagent,1125,tcp,HP VMM Agent,,,,,,,,
+hpvmmagent,1125,udp,HP VMM Agent,,,,,,,,
+hpvmmdata,1126,tcp,HP VMM Agent,[John_Morton],[John_Morton],2004-11,,,,,
+hpvmmdata,1126,udp,HP VMM Agent,[John_Morton],[John_Morton],2004-11,,,,,
+kwdb-commn,1127,tcp,KWDB Remote Communication,[Lal_Samuel_Varghese],[Lal_Samuel_Varghese],2005-08,,,,,
+kwdb-commn,1127,udp,KWDB Remote Communication,[Lal_Samuel_Varghese],[Lal_Samuel_Varghese],2005-08,,,,,
+saphostctrl,1128,tcp,SAPHostControl over SOAP/HTTP,,,,,,,,
+saphostctrl,1128,udp,SAPHostControl over SOAP/HTTP,,,,,,,,
+saphostctrls,1129,tcp,SAPHostControl over SOAP/HTTPS,[Muscarella_Fabrizio],[Muscarella_Fabrizio],2006-04,,,,,
+saphostctrls,1129,udp,SAPHostControl over SOAP/HTTPS,[Muscarella_Fabrizio],[Muscarella_Fabrizio],2006-04,,,,,
+casp,1130,tcp,CAC App Service Protocol,,,,,,,,
+casp,1130,udp,CAC App Service Protocol,,,,,,,,
+caspssl,1131,tcp,CAC App Service Protocol Encripted,[Enrique_Corujo],[Enrique_Corujo],2006-02,,,,,
+caspssl,1131,udp,CAC App Service Protocol Encripted,[Enrique_Corujo],[Enrique_Corujo],2006-02,,,,,
+kvm-via-ip,1132,tcp,KVM-via-IP Management Service,[Ian_Miller],[Ian_Miller],2006-03,,,,,
+kvm-via-ip,1132,udp,KVM-via-IP Management Service,[Ian_Miller],[Ian_Miller],2006-03,,,,,
+dfn,1133,tcp,Data Flow Network,[Dmitry_Obuvalin],[Dmitry_Obuvalin],2006-02,,,,,
+dfn,1133,udp,Data Flow Network,[Dmitry_Obuvalin],[Dmitry_Obuvalin],2006-02,,,,,
+aplx,1134,tcp,MicroAPL APLX,[Richard_Nabavi],[Richard_Nabavi],2006-02,,,,,
+aplx,1134,udp,MicroAPL APLX,[Richard_Nabavi],[Richard_Nabavi],2006-02,,,,,
+omnivision,1135,tcp,OmniVision Communication Service,[Serge_Vacquier],[Serge_Vacquier],2006-02,,,,,
+omnivision,1135,udp,OmniVision Communication Service,[Serge_Vacquier],[Serge_Vacquier],2006-02,,,,,
+hhb-gateway,1136,tcp,HHB Gateway Control,[Richard_Harwell],[Richard_Harwell],2006-02,,,,,
+hhb-gateway,1136,udp,HHB Gateway Control,[Richard_Harwell],[Richard_Harwell],2006-02,,,,,
+trim,1137,tcp,TRIM Workgroup Service,[Siva_Poobalasingam],[Siva_Poobalasingam],2006-03,,,,,
+trim,1137,udp,TRIM Workgroup Service,[Siva_Poobalasingam],[Siva_Poobalasingam],2006-03,,,,,
+encrypted-admin,1138,tcp,"encrypted admin requests
+IANA assigned this well-formed service name as a replacement for ""encrypted_admin"".",[Michael_Elizarov],[Michael_Elizarov],2007-01,,,,,
+encrypted_admin,1138,tcp,encrypted admin requests,[Michael_Elizarov],[Michael_Elizarov],2007-01,,,,,"This entry is an alias to ""encrypted-admin"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+encrypted-admin,1138,udp,"encrypted admin requests
+IANA assigned this well-formed service name as a replacement for ""encrypted_admin"".",[Michael_Elizarov],[Michael_Elizarov],2007-01,,,,,
+encrypted_admin,1138,udp,encrypted admin requests,[Michael_Elizarov],[Michael_Elizarov],2007-01,,,,,"This entry is an alias to ""encrypted-admin"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+evm,1139,tcp,Enterprise Virtual Manager,[Thomas_Hennessy],[Thomas_Hennessy],2007-10-04,,,,,
+evm,1139,udp,Enterprise Virtual Manager,[Thomas_Hennessy],[Thomas_Hennessy],2007-10-04,,,,,
+autonoc,1140,tcp,AutoNOC Network Operations Protocol,[Kyle_Lussier],[Kyle_Lussier],2005-12,,,,,
+autonoc,1140,udp,AutoNOC Network Operations Protocol,[Kyle_Lussier],[Kyle_Lussier],2005-12,,,,,
+mxomss,1141,tcp,User Message Service,[Chaoyi_Lang],[Chaoyi_Lang],2006-01,,,,,
+mxomss,1141,udp,User Message Service,[Chaoyi_Lang],[Chaoyi_Lang],2006-01,,,,,
+edtools,1142,tcp,User Discovery Service,[Lee_Dolson],[Lee_Dolson],2006-01,,,,,
+edtools,1142,udp,User Discovery Service,[Lee_Dolson],[Lee_Dolson],2006-01,,,,,
+imyx,1143,tcp,Infomatryx Exchange,[David_Walling],[David_Walling],2006-03,,,,,
+imyx,1143,udp,Infomatryx Exchange,[David_Walling],[David_Walling],2006-03,,,,,
+fuscript,1144,tcp,Fusion Script,[Peter_Loveday],[Peter_Loveday],2006-01,,,,,
+fuscript,1144,udp,Fusion Script,[Peter_Loveday],[Peter_Loveday],2006-01,,,,,
+x9-icue,1145,tcp,X9 iCue Show Control,[Brandon_Potter],[Brandon_Potter],2006-01,,,,,
+x9-icue,1145,udp,X9 iCue Show Control,[Brandon_Potter],[Brandon_Potter],2006-01,,,,,
+audit-transfer,1146,tcp,audit transfer,[Mark_Wahl],[Mark_Wahl],2005-11,,,,,
+audit-transfer,1146,udp,audit transfer,[Mark_Wahl],[Mark_Wahl],2005-11,,,,,
+capioverlan,1147,tcp,CAPIoverLAN,[Diego_Friedel],[Diego_Friedel],2005-11,,,,,
+capioverlan,1147,udp,CAPIoverLAN,[Diego_Friedel],[Diego_Friedel],2005-11,,,,,
+elfiq-repl,1148,tcp,Elfiq Replication Service,[Frederick_Parent],[Frederick_Parent],2005-11,,,,,
+elfiq-repl,1148,udp,Elfiq Replication Service,[Frederick_Parent],[Frederick_Parent],2005-11,,,,,
+bvtsonar,1149,tcp,BlueView Sonar Service,[Teledyne_BlueView_Inc],[Cat_Zimmermann],2005-11,2012-09-19,,,,
+bvtsonar,1149,udp,BlueView Sonar Service,[Teledyne_BlueView_Inc],[Cat_Zimmermann],2005-11,2012-09-19,,,,
+blaze,1150,tcp,Blaze File Server,[Curt_Schimmel],[Curt_Schimmel],2005-11,,,,,
+blaze,1150,udp,Blaze File Server,[Curt_Schimmel],[Curt_Schimmel],2005-11,,,,,
+unizensus,1151,tcp,Unizensus Login Server,[Dirk_Materlik],[Dirk_Materlik],2005-11,,,,,
+unizensus,1151,udp,Unizensus Login Server,[Dirk_Materlik],[Dirk_Materlik],2005-11,,,,,
+winpoplanmess,1152,tcp,Winpopup LAN Messenger,[Vitali_Fomine],[Vitali_Fomine],2005-11,,,,,
+winpoplanmess,1152,udp,Winpopup LAN Messenger,[Vitali_Fomine],[Vitali_Fomine],2005-11,,,,,
+c1222-acse,1153,tcp,ANSI C12.22 Port,,,,,[RFC6142],,,
+c1222-acse,1153,udp,ANSI C12.22 Port,,,,,[RFC6142],,,
+resacommunity,1154,tcp,Community Service,[Stephane_MONS],[Stephane_MONS],2005-09,,,,,
+resacommunity,1154,udp,Community Service,[Stephane_MONS],[Stephane_MONS],2005-09,,,,,
+nfa,1155,tcp,Network File Access,[James_Powell],[James_Powell],,,,,,
+nfa,1155,udp,Network File Access,[James_Powell],[James_Powell],,,,,,
+iascontrol-oms,1156,tcp,iasControl OMS,[Todd_Guay],[Todd_Guay],2004-11,,,,,
+iascontrol-oms,1156,udp,iasControl OMS,[Todd_Guay],[Todd_Guay],2004-11,,,,,
+iascontrol,1157,tcp,Oracle iASControl,[Todd_Guay],[Todd_Guay],2004-11,,,,,
+iascontrol,1157,udp,Oracle iASControl,[Todd_Guay],[Todd_Guay],2004-11,,,,,
+dbcontrol-oms,1158,tcp,dbControl OMS,[Todd_Guay],[Todd_Guay],2004-11,,,,,
+dbcontrol-oms,1158,udp,dbControl OMS,[Todd_Guay],[Todd_Guay],2004-11,,,,,
+oracle-oms,1159,tcp,Oracle OMS,[Todd_Guay],[Todd_Guay],2004-11,,,,,
+oracle-oms,1159,udp,Oracle OMS,[Todd_Guay],[Todd_Guay],2004-11,,,,,
+olsv,1160,tcp,DB Lite Mult-User Server,[Philip_Stephenson],[Philip_Stephenson],2005-08,,,,,
+olsv,1160,udp,DB Lite Mult-User Server,[Philip_Stephenson],[Philip_Stephenson],2005-08,,,,,
+health-polling,1161,tcp,Health Polling,,,,,,,,
+health-polling,1161,udp,Health Polling,,,,,,,,
+health-trap,1162,tcp,Health Trap,,,,,,,,
+health-trap,1162,udp,Health Trap,,,,,,,,
+sddp,1163,tcp,SmartDialer Data Protocol,[Lee_Griffiths],[Lee_Griffiths],2004-11,,,,,
+sddp,1163,udp,SmartDialer Data Protocol,[Lee_Griffiths],[Lee_Griffiths],2004-11,,,,,
+qsm-proxy,1164,tcp,QSM Proxy Service,[Norm_Lunde],[Norm_Lunde],2004-11,,,,,
+qsm-proxy,1164,udp,QSM Proxy Service,[Norm_Lunde],[Norm_Lunde],2004-11,,,,,
+qsm-gui,1165,tcp,QSM GUI Service,[Norm_Lunde],[Norm_Lunde],2004-11,,,,,
+qsm-gui,1165,udp,QSM GUI Service,[Norm_Lunde],[Norm_Lunde],2004-11,,,,,
+qsm-remote,1166,tcp,QSM RemoteExec,[Norm_Lunde],[Norm_Lunde],2004-11,,,,,
+qsm-remote,1166,udp,QSM RemoteExec,[Norm_Lunde],[Norm_Lunde],2004-11,,,,,
+cisco-ipsla,1167,tcp,Cisco IP SLAs Control Protocol,[Emmanuel_Tychon],[Emmanuel_Tychon],2006-03,,,,,
+cisco-ipsla,1167,udp,Cisco IP SLAs Control Protocol,[Emmanuel_Tychon],[Emmanuel_Tychon],2006-03,,,,,
+cisco-ipsla,1167,sctp,Cisco IP SLAs Control Protocol,[Emmanuel_Tychon],[Emmanuel_Tychon],2006-03,,,,,
+vchat,1168,tcp,VChat Conference Service,[Andreas_Wetzel],[Andreas_Wetzel],2002-09,,,,,
+vchat,1168,udp,VChat Conference Service,[Andreas_Wetzel],[Andreas_Wetzel],2002-09,,,,,
+tripwire,1169,tcp,TRIPWIRE,[Ed_Metcalf][Albert_Holt],[Ed_Metcalf][Albert_Holt],,,,,,
+tripwire,1169,udp,TRIPWIRE,[Ed_Metcalf][Albert_Holt],[Ed_Metcalf][Albert_Holt],,,,,,
+atc-lm,1170,tcp,AT+C License Manager,[Peter_Schafer],[Peter_Schafer],2004-02,,,,,
+atc-lm,1170,udp,AT+C License Manager,[Peter_Schafer],[Peter_Schafer],2004-02,,,,,
+atc-appserver,1171,tcp,AT+C FmiApplicationServer,[Peter_Schafer],[Peter_Schafer],2004-02,,,,,
+atc-appserver,1171,udp,AT+C FmiApplicationServer,[Peter_Schafer],[Peter_Schafer],2004-02,,,,,
+dnap,1172,tcp,DNA Protocol,[David_McLaughlin],[David_McLaughlin],2004-11,,,,,
+dnap,1172,udp,DNA Protocol,[David_McLaughlin],[David_McLaughlin],2004-11,,,,,
+d-cinema-rrp,1173,tcp,D-Cinema Request-Response,[Robert_Baldwin],[Robert_Baldwin],2004-11,,,,,
+d-cinema-rrp,1173,udp,D-Cinema Request-Response,[Robert_Baldwin],[Robert_Baldwin],2004-11,,,,,
+fnet-remote-ui,1174,tcp,FlashNet Remote Admin,[Terry_Smyth],[Terry_Smyth],2004-11,,,,,
+fnet-remote-ui,1174,udp,FlashNet Remote Admin,[Terry_Smyth],[Terry_Smyth],2004-11,,,,,
+dossier,1175,tcp,Dossier Server,[Rob_Minerick],[Rob_Minerick],2004-11,,,,,
+dossier,1175,udp,Dossier Server,[Rob_Minerick],[Rob_Minerick],2004-11,,,,,
+indigo-server,1176,tcp,Indigo Home Server,[Matt_Bendiksen],[Matt_Bendiksen],2004-11,,,,,
+indigo-server,1176,udp,Indigo Home Server,[Matt_Bendiksen],[Matt_Bendiksen],2004-11,,,,,
+dkmessenger,1177,tcp,DKMessenger Protocol,[Douglas_Kadlecek],[Douglas_Kadlecek],2004-11,,,,,
+dkmessenger,1177,udp,DKMessenger Protocol,[Douglas_Kadlecek],[Douglas_Kadlecek],2004-11,,,,,
+sgi-storman,1178,tcp,SGI Storage Manager,[Greg_Banks],[Greg_Banks],2004-11,,,,,
+sgi-storman,1178,udp,SGI Storage Manager,[Greg_Banks],[Greg_Banks],2004-11,,,,,
+b2n,1179,tcp,Backup To Neighbor,[Thomas_Fok],[Thomas_Fok],2004-11,,,,,
+b2n,1179,udp,Backup To Neighbor,[Thomas_Fok],[Thomas_Fok],2004-11,,,,,
+mc-client,1180,tcp,Millicent Client Proxy,[Steve_Glassman],[Steve_Glassman],,,,,,
+mc-client,1180,udp,Millicent Client Proxy,[Steve_Glassman],[Steve_Glassman],,,,,,
+3comnetman,1181,tcp,3Com Net Management,[Peter_White],[Peter_White],2004-11,,,,,
+3comnetman,1181,udp,3Com Net Management,[Peter_White],[Peter_White],2004-11,,,,,
+accelenet,1182,tcp,AcceleNet Control,,,,,,,,
+accelenet-data,1182,udp,AcceleNet Data,[Peter_Lepeska],[Peter_Lepeska],2010-09-10,,,,,
+llsurfup-http,1183,tcp,LL Surfup HTTP,,,,,,,,
+llsurfup-http,1183,udp,LL Surfup HTTP,,,,,,,,
+llsurfup-https,1184,tcp,LL Surfup HTTPS,[Katy_Lynn_McCullough],[Katy_Lynn_McCullough],,,,,,
+llsurfup-https,1184,udp,LL Surfup HTTPS,[Katy_Lynn_McCullough],[Katy_Lynn_McCullough],,,,,,
+catchpole,1185,tcp,Catchpole port,[Christian_Catchpole],[Christian_Catchpole],2002-03,,,,,
+catchpole,1185,udp,Catchpole port,[Christian_Catchpole],[Christian_Catchpole],2002-03,,,,,
+mysql-cluster,1186,tcp,MySQL Cluster Manager,[Arjen_Lentz],[Arjen_Lentz],2004-11,,,,,
+mysql-cluster,1186,udp,MySQL Cluster Manager,[Arjen_Lentz],[Arjen_Lentz],2004-11,,,,,
+alias,1187,tcp,Alias Service,[Paul_Tokarchuk],[Paul_Tokarchuk],2004-11,,,,,
+alias,1187,udp,Alias Service,[Paul_Tokarchuk],[Paul_Tokarchuk],2004-11,,,,,
+hp-webadmin,1188,tcp,HP Web Admin,[Lance_Kind],[Lance_Kind],,,,,,
+hp-webadmin,1188,udp,HP Web Admin,[Lance_Kind],[Lance_Kind],,,,,,
+unet,1189,tcp,Unet Connection,[Anthony_Stahler],[Anthony_Stahler],2004-11,,,,,
+unet,1189,udp,Unet Connection,[Anthony_Stahler],[Anthony_Stahler],2004-11,,,,,
+commlinx-avl,1190,tcp,CommLinx GPS / AVL System,[Peter_Johnson],[Peter_Johnson],2004-11,,,,,
+commlinx-avl,1190,udp,CommLinx GPS / AVL System,[Peter_Johnson],[Peter_Johnson],2004-11,,,,,
+gpfs,1191,tcp,General Parallel File System,[Dave_Craft],[Dave_Craft],2004-11,,,,,
+gpfs,1191,udp,General Parallel File System,[Dave_Craft],[Dave_Craft],2004-11,,,,,
+caids-sensor,1192,tcp,caids sensors channel,[Gregory_Hostettler],[Gregory_Hostettler],2004-11,,,,,
+caids-sensor,1192,udp,caids sensors channel,[Gregory_Hostettler],[Gregory_Hostettler],2004-11,,,,,
+fiveacross,1193,tcp,Five Across Server,[Glenn_Reid],[Glenn_Reid],2004-11,,,,,
+fiveacross,1193,udp,Five Across Server,[Glenn_Reid],[Glenn_Reid],2004-11,,,,,
+openvpn,1194,tcp,OpenVPN,[James_Yonan],[James_Yonan],2004-11,,,,,
+openvpn,1194,udp,OpenVPN,[James_Yonan],[James_Yonan],2004-11,,,,,
+rsf-1,1195,tcp,RSF-1 clustering,[Dave_Hines],[Dave_Hines],2004-11,,,,,
+rsf-1,1195,udp,RSF-1 clustering,[Dave_Hines],[Dave_Hines],2004-11,,,,,
+netmagic,1196,tcp,Network Magic,[Nick_Holt],[Nick_Holt],2005-08,,,,,
+netmagic,1196,udp,Network Magic,[Nick_Holt],[Nick_Holt],2005-08,,,,,
+carrius-rshell,1197,tcp,Carrius Remote Access,[Gerry_Dubois],[Gerry_Dubois],2005-08,,,,,
+carrius-rshell,1197,udp,Carrius Remote Access,[Gerry_Dubois],[Gerry_Dubois],2005-08,,,,,
+cajo-discovery,1198,tcp,cajo reference discovery,[John_Catherino],[John_Catherino],2005-08,,,,,
+cajo-discovery,1198,udp,cajo reference discovery,[John_Catherino],[John_Catherino],2005-08,,,,,
+dmidi,1199,tcp,DMIDI,[Phil_Kerr],[Phil_Kerr],2002-02,,,,,
+dmidi,1199,udp,DMIDI,[Phil_Kerr],[Phil_Kerr],2002-02,,,,,
+scol,1200,tcp,SCOL,[Cryo_Networks],[Cryo_Networks],,,,,,
+scol,1200,udp,SCOL,[Cryo_Networks],[Cryo_Networks],,,,,,
+nucleus-sand,1201,tcp,Nucleus Sand Database Server,[James_Marsh],[James_Marsh],,,,,,
+nucleus-sand,1201,udp,Nucleus Sand Database Server,[James_Marsh],[James_Marsh],,,,,,
+caiccipc,1202,tcp,caiccipc,[Vince_Re],[Vince_Re],,,,,,
+caiccipc,1202,udp,caiccipc,[Vince_Re],[Vince_Re],,,,,,
+ssslic-mgr,1203,tcp,License Validation,,,,,,,,
+ssslic-mgr,1203,udp,License Validation,,,,,,,,
+ssslog-mgr,1204,tcp,Log Request Listener,[Eric_Bruno],[Eric_Bruno],,,,,,
+ssslog-mgr,1204,udp,Log Request Listener,[Eric_Bruno],[Eric_Bruno],,,,,,
+accord-mgc,1205,tcp,Accord-MGC,[Roni_Even],[Roni_Even],,,,,,
+accord-mgc,1205,udp,Accord-MGC,[Roni_Even],[Roni_Even],,,,,,
+anthony-data,1206,tcp,Anthony Data,[Paul_Dollemore],[Paul_Dollemore],,,,,,
+anthony-data,1206,udp,Anthony Data,[Paul_Dollemore],[Paul_Dollemore],,,,,,
+metasage,1207,tcp,MetaSage,[Peter_Anvelt],[Peter_Anvelt],,,,,,
+metasage,1207,udp,MetaSage,[Peter_Anvelt],[Peter_Anvelt],,,,,,
+seagull-ais,1208,tcp,SEAGULL AIS,[Lee_Breisacher],[Lee_Breisacher],,,,,,
+seagull-ais,1208,udp,SEAGULL AIS,[Lee_Breisacher],[Lee_Breisacher],,,,,,
+ipcd3,1209,tcp,IPCD3,[Mark_Ciskey],[Mark_Ciskey],,,,,,
+ipcd3,1209,udp,IPCD3,[Mark_Ciskey],[Mark_Ciskey],,,,,,
+eoss,1210,tcp,EOSS,[Robert_Armes],[Robert_Armes],,,,,,
+eoss,1210,udp,EOSS,[Robert_Armes],[Robert_Armes],,,,,,
+groove-dpp,1211,tcp,Groove DPP,[Ken_Moore],[Ken_Moore],,,,,,
+groove-dpp,1211,udp,Groove DPP,[Ken_Moore],[Ken_Moore],,,,,,
+lupa,1212,tcp,lupa,[Barney_Wolff],[Barney_Wolff],,,,,,
+lupa,1212,udp,lupa,[Barney_Wolff],[Barney_Wolff],,,,,,
+mpc-lifenet,1213,tcp,Medtronic/Physio-Control LIFENET,[Physio-Control_Inc],[Kevin_Drew],,2014-02-14,,,,
+mpc-lifenet,1213,udp,Medtronic/Physio-Control LIFENET,[Physio-Control_Inc],[Kevin_Drew],,2014-02-14,,,,
+kazaa,1214,tcp,KAZAA,[Ahti_Heinla],[Ahti_Heinla],,,,,,
+kazaa,1214,udp,KAZAA,[Ahti_Heinla],[Ahti_Heinla],,,,,,
+scanstat-1,1215,tcp,scanSTAT 1.0,[William_Scheding],[William_Scheding],,,,,,
+scanstat-1,1215,udp,scanSTAT 1.0,[William_Scheding],[William_Scheding],,,,,,
+etebac5,1216,tcp,ETEBAC 5,[Jean_Louis_Barbut],[Jean_Louis_Barbut],,,,,,
+etebac5,1216,udp,ETEBAC 5,[Jean_Louis_Barbut],[Jean_Louis_Barbut],,,,,,
+hpss-ndapi,1217,tcp,HPSS NonDCE Gateway,[Michael_Gleicher],[Michael_Gleicher],,,,,,
+hpss-ndapi,1217,udp,HPSS NonDCE Gateway,[Michael_Gleicher],[Michael_Gleicher],,,,,,
+aeroflight-ads,1218,tcp,AeroFlight-ADs,,,,,,,,
+aeroflight-ads,1218,udp,AeroFlight-ADs,,,,,,,,
+aeroflight-ret,1219,tcp,AeroFlight-Ret,[Eric_Johnson],[Eric_Johnson],,,,,,
+aeroflight-ret,1219,udp,AeroFlight-Ret,[Eric_Johnson],[Eric_Johnson],,,,,,
+qt-serveradmin,1220,tcp,QT SERVER ADMIN,[Chris_LeCroy],[Chris_LeCroy],,,,,,
+qt-serveradmin,1220,udp,QT SERVER ADMIN,[Chris_LeCroy],[Chris_LeCroy],,,,,,
+sweetware-apps,1221,tcp,SweetWARE Apps,[David_Dunetz],[David_Dunetz],,,,,,
+sweetware-apps,1221,udp,SweetWARE Apps,[David_Dunetz],[David_Dunetz],,,,,,
+nerv,1222,tcp,SNI R&D network,[Martin_Freiss],[Martin_Freiss],,,,,,
+nerv,1222,udp,SNI R&D network,[Martin_Freiss],[Martin_Freiss],,,,,,
+tgp,1223,tcp,TrulyGlobal Protocol,[Gur_Kimchi],[Gur_Kimchi],2008-05-20,,,,,
+tgp,1223,udp,TrulyGlobal Protocol,[Gur_Kimchi],[Gur_Kimchi],2008-05-20,,,,,
+vpnz,1224,tcp,VPNz,[Tom_Strack],[Tom_Strack],,,,,,
+vpnz,1224,udp,VPNz,[Tom_Strack],[Tom_Strack],,,,,,
+slinkysearch,1225,tcp,SLINKYSEARCH,[Desmond_Chan],[Desmond_Chan],,,,,,
+slinkysearch,1225,udp,SLINKYSEARCH,[Desmond_Chan],[Desmond_Chan],,,,,,
+stgxfws,1226,tcp,STGXFWS,[Tetsuya_Shioda],[Tetsuya_Shioda],,,,,,
+stgxfws,1226,udp,STGXFWS,[Tetsuya_Shioda],[Tetsuya_Shioda],,,,,,
+dns2go,1227,tcp,DNS2Go,[Mike_Courterier],[Mike_Courterier],,,,,,
+dns2go,1227,udp,DNS2Go,[Mike_Courterier],[Mike_Courterier],,,,,,
+florence,1228,tcp,FLORENCE,[Brian_Trammell],[Brian_Trammell],,,,,,
+florence,1228,udp,FLORENCE,[Brian_Trammell],[Brian_Trammell],,,,,,
+zented,1229,tcp,ZENworks Tiered Electronic Distribution,[Ty_Ellis],[Ty_Ellis],,,,,,
+zented,1229,udp,ZENworks Tiered Electronic Distribution,[Ty_Ellis],[Ty_Ellis],,,,,,
+periscope,1230,tcp,Periscope,[Kevin_Madden],[Kevin_Madden],,,,,,
+periscope,1230,udp,Periscope,[Kevin_Madden],[Kevin_Madden],,,,,,
+menandmice-lpm,1231,tcp,menandmice-lpm,[Sigfus_Magnusson],[Sigfus_Magnusson],,,,,,
+menandmice-lpm,1231,udp,menandmice-lpm,[Sigfus_Magnusson],[Sigfus_Magnusson],,,,,,
+first-defense,1232,tcp,Remote systems monitoring,[Nexum],[Michael_Fread],2012-09-21,,,,,Microsoft (unoffically) using 1232
+first-defense,1232,udp,Remote systems monitoring,[Nexum],[Michael_Fread],2012-09-21,,,,,Microsoft (unoffically) using 1232
+univ-appserver,1233,tcp,Universal App Server,[Tim_Sent],[Tim_Sent],,,,,,
+univ-appserver,1233,udp,Universal App Server,[Tim_Sent],[Tim_Sent],,,,,,
+search-agent,1234,tcp,Infoseek Search Agent,[Jackie_Wu],[Jackie_Wu],,,,,,
+search-agent,1234,udp,Infoseek Search Agent,[Jackie_Wu],[Jackie_Wu],,,,,,
+mosaicsyssvc1,1235,tcp,mosaicsyssvc1,[Brian_Matthews],[Brian_Matthews],,,,,,
+mosaicsyssvc1,1235,udp,mosaicsyssvc1,[Brian_Matthews],[Brian_Matthews],,,,,,
+bvcontrol,1236,tcp,bvcontrol,[Daniel_J_Walsh],[Daniel_J_Walsh],,,,,,
+bvcontrol,1236,udp,bvcontrol,[Daniel_J_Walsh],[Daniel_J_Walsh],,,,,,
+tsdos390,1237,tcp,tsdos390,[Ben_Pracht],[Ben_Pracht],,,,,,
+tsdos390,1237,udp,tsdos390,[Ben_Pracht],[Ben_Pracht],,,,,,
+hacl-qs,1238,tcp,hacl-qs,[Farid_Faez],[Farid_Faez],,,,,,
+hacl-qs,1238,udp,hacl-qs,[Farid_Faez],[Farid_Faez],,,,,,
+nmsd,1239,tcp,NMSD,[Yuri_Machkasov],[Yuri_Machkasov],,,,,,
+nmsd,1239,udp,NMSD,[Yuri_Machkasov],[Yuri_Machkasov],,,,,,
+instantia,1240,tcp,Instantia,[Ruth_Slater],[Ruth_Slater],,,,,,
+instantia,1240,udp,Instantia,[Ruth_Slater],[Ruth_Slater],,,,,,
+nessus,1241,tcp,nessus,[Jordan_Hrycaj],[Jordan_Hrycaj],,,,,,
+nessus,1241,udp,nessus,[Jordan_Hrycaj],[Jordan_Hrycaj],,,,,,
+nmasoverip,1242,tcp,NMAS over IP,[Hal_Henderson],[Hal_Henderson],,,,,,
+nmasoverip,1242,udp,NMAS over IP,[Hal_Henderson],[Hal_Henderson],,,,,,
+serialgateway,1243,tcp,SerialGateway,[Stephen_LaValley],[Stephen_LaValley],,,,,,
+serialgateway,1243,udp,SerialGateway,[Stephen_LaValley],[Stephen_LaValley],,,,,,
+isbconference1,1244,tcp,isbconference1,,,,,,,,
+isbconference1,1244,udp,isbconference1,,,,,,,,
+isbconference2,1245,tcp,isbconference2,[Arnold_Dittmann],[Arnold_Dittmann],,,,,,
+isbconference2,1245,udp,isbconference2,[Arnold_Dittmann],[Arnold_Dittmann],,,,,,
+payrouter,1246,tcp,payrouter,[David_Wilson],[David_Wilson],,,,,,
+payrouter,1246,udp,payrouter,[David_Wilson],[David_Wilson],,,,,,
+visionpyramid,1247,tcp,VisionPyramid,[Gavin_Hutchinson],[Gavin_Hutchinson],,,,,,
+visionpyramid,1247,udp,VisionPyramid,[Gavin_Hutchinson],[Gavin_Hutchinson],,,,,,
+hermes,1248,tcp,hermes,,,,,,,,
+hermes,1248,udp,hermes,,,,,,,,
+mesavistaco,1249,tcp,Mesa Vista Co,[Rick_LaBanca],[Rick_LaBanca],,,,,,
+mesavistaco,1249,udp,Mesa Vista Co,[Rick_LaBanca],[Rick_LaBanca],,,,,,
+swldy-sias,1250,tcp,swldy-sias,[Peter_E_Williams],[Peter_E_Williams],,,,,,
+swldy-sias,1250,udp,swldy-sias,[Peter_E_Williams],[Peter_E_Williams],,,,,,
+servergraph,1251,tcp,servergraph,[Lindsay_Morris],[Lindsay_Morris],,,,,,
+servergraph,1251,udp,servergraph,[Lindsay_Morris],[Lindsay_Morris],,,,,,
+bspne-pcc,1252,tcp,bspne-pcc,,,,,,,,
+bspne-pcc,1252,udp,bspne-pcc,,,,,,,,
+q55-pcc,1253,tcp,q55-pcc,[Prem_Tirilok],[Prem_Tirilok],,,,,,
+q55-pcc,1253,udp,q55-pcc,[Prem_Tirilok],[Prem_Tirilok],,,,,,
+de-noc,1254,tcp,de-noc,,,,,,,,
+de-noc,1254,udp,de-noc,,,,,,,,
+de-cache-query,1255,tcp,de-cache-query,,,,,,,,
+de-cache-query,1255,udp,de-cache-query,,,,,,,,
+de-server,1256,tcp,de-server,[Jeff_Burdette],[Jeff_Burdette],,,,,,
+de-server,1256,udp,de-server,[Jeff_Burdette],[Jeff_Burdette],,,,,,
+shockwave2,1257,tcp,Shockwave 2,[Dave_Simmons],[Dave_Simmons],,,,,,
+shockwave2,1257,udp,Shockwave 2,[Dave_Simmons],[Dave_Simmons],,,,,,
+opennl,1258,tcp,Open Network Library,,,,,,,,
+opennl,1258,udp,Open Network Library,,,,,,,,
+opennl-voice,1259,tcp,Open Network Library Voice,[Phil_Frisbie],[Phil_Frisbie],,,,,,
+opennl-voice,1259,udp,Open Network Library Voice,[Phil_Frisbie],[Phil_Frisbie],,,,,,
+ibm-ssd,1260,tcp,ibm-ssd,[Barry_Whyte],[Barry_Whyte],,,,,,
+ibm-ssd,1260,udp,ibm-ssd,[Barry_Whyte],[Barry_Whyte],,,,,,
+mpshrsv,1261,tcp,mpshrsv,[Makoto_Ikeyama],[Makoto_Ikeyama],,,,,,
+mpshrsv,1261,udp,mpshrsv,[Makoto_Ikeyama],[Makoto_Ikeyama],,,,,,
+qnts-orb,1262,tcp,QNTS-ORB,[Raghurama_Bhat],[Raghurama_Bhat],,,,,,
+qnts-orb,1262,udp,QNTS-ORB,[Raghurama_Bhat],[Raghurama_Bhat],,,,,,
+dka,1263,tcp,dka,[Chris_Griffin],[Chris_Griffin],,,,,,
+dka,1263,udp,dka,[Chris_Griffin],[Chris_Griffin],,,,,,
+prat,1264,tcp,PRAT,[Keith_Wood],[Keith_Wood],,,,,,
+prat,1264,udp,PRAT,[Keith_Wood],[Keith_Wood],,,,,,
+dssiapi,1265,tcp,DSSIAPI,[Jim_Turner],[Jim_Turner],,,,,,
+dssiapi,1265,udp,DSSIAPI,[Jim_Turner],[Jim_Turner],,,,,,
+dellpwrappks,1266,tcp,DELLPWRAPPKS,[David_Troeger],[David_Troeger],,,,,,
+dellpwrappks,1266,udp,DELLPWRAPPKS,[David_Troeger],[David_Troeger],,,,,,
+epc,1267,tcp,eTrust Policy Compliance,[Aaron_Stein],[Aaron_Stein],,,,,,
+epc,1267,udp,eTrust Policy Compliance,[Aaron_Stein],[Aaron_Stein],,,,,,
+propel-msgsys,1268,tcp,PROPEL-MSGSYS,[Bert_Van_der_Linden],[Bert_Van_der_Linden],,,,,,
+propel-msgsys,1268,udp,PROPEL-MSGSYS,[Bert_Van_der_Linden],[Bert_Van_der_Linden],,,,,,
+watilapp,1269,tcp,WATiLaPP,[Frederic_Weymann],[Frederic_Weymann],,,,,,
+watilapp,1269,udp,WATiLaPP,[Frederic_Weymann],[Frederic_Weymann],,,,,,
+opsmgr,1270,tcp,Microsoft Operations Manager,[Ashvin_Sanghvi],[Ashvin_Sanghvi],,,,,,
+opsmgr,1270,udp,Microsoft Operations Manager,[Ashvin_Sanghvi],[Ashvin_Sanghvi],,,,,,
+excw,1271,tcp,eXcW,[Norm_Freedman],[Norm_Freedman],,,,,,
+excw,1271,udp,eXcW,[Norm_Freedman],[Norm_Freedman],,,,,,
+cspmlockmgr,1272,tcp,CSPMLockMgr,[Ibtsam_Mahfouz],[Ibtsam_Mahfouz],,,,,,
+cspmlockmgr,1272,udp,CSPMLockMgr,[Ibtsam_Mahfouz],[Ibtsam_Mahfouz],,,,,,
+emc-gateway,1273,tcp,EMC-Gateway,[Rene_Fontaine],[Rene_Fontaine],,,,,,
+emc-gateway,1273,udp,EMC-Gateway,[Rene_Fontaine],[Rene_Fontaine],,,,,,
+t1distproc,1274,tcp,t1distproc,[Julian_Biddle],[Julian_Biddle],,,,,,
+t1distproc,1274,udp,t1distproc,[Julian_Biddle],[Julian_Biddle],,,,,,
+ivcollector,1275,tcp,ivcollector,,,,,,,,
+ivcollector,1275,udp,ivcollector,,,,,,,,
+,1276,tcp,Reserved,,,,2014-05-23,,,,This entry has been removed on 2014-05-23.
+,1276,udp,Reserved,,,,2014-05-23,,,,This entry has been removed on 2014-05-23.
+miva-mqs,1277,tcp,mqs,[Miva_Corporation],[Miva_Corporation],,,,,,
+miva-mqs,1277,udp,mqs,[Miva_Corporation],[Miva_Corporation],,,,,,
+dellwebadmin-1,1278,tcp,Dell Web Admin 1,,,,,,,,
+dellwebadmin-1,1278,udp,Dell Web Admin 1,,,,,,,,
+dellwebadmin-2,1279,tcp,Dell Web Admin 2,[Bridget_Navoda],[Bridget_Navoda],,,,,,
+dellwebadmin-2,1279,udp,Dell Web Admin 2,[Bridget_Navoda],[Bridget_Navoda],,,,,,
+pictrography,1280,tcp,Pictrography,[Takashi_Hoshino],[Takashi_Hoshino],,,,,,
+pictrography,1280,udp,Pictrography,[Takashi_Hoshino],[Takashi_Hoshino],,,,,,
+healthd,1281,tcp,healthd,[James_E_Housley],[James_E_Housley],,,,,,
+healthd,1281,udp,healthd,[James_E_Housley],[James_E_Housley],,,,,,
+emperion,1282,tcp,Emperion,[Claus_Thor_Barth],[Claus_Thor_Barth],,,,,,
+emperion,1282,udp,Emperion,[Claus_Thor_Barth],[Claus_Thor_Barth],,,,,,
+productinfo,1283,tcp,Product Information,,,,,,,,
+productinfo,1283,udp,Product Information,,,,,,,,
+iee-qfx,1284,tcp,IEE-QFX,[Mehrdad_Ashtiani],[Mehrdad_Ashtiani],2009-10-19,,,,,
+iee-qfx,1284,udp,IEE-QFX,[Mehrdad_Ashtiani],[Mehrdad_Ashtiani],2009-10-19,,,,,
+neoiface,1285,tcp,neoiface,[Jason_McManus],[Jason_McManus],,,,,,
+neoiface,1285,udp,neoiface,[Jason_McManus],[Jason_McManus],,,,,,
+netuitive,1286,tcp,netuitive,[JF_Huard],[JF_Huard],,,,,,
+netuitive,1286,udp,netuitive,[JF_Huard],[JF_Huard],,,,,,
+routematch,1287,tcp,RouteMatch Com,[Jeff_Jones],[Jeff_Jones],2005-11,,,,,
+routematch,1287,udp,RouteMatch Com,[Jeff_Jones],[Jeff_Jones],2005-11,,,,,
+navbuddy,1288,tcp,NavBuddy,[Eric_Hackman],[Eric_Hackman],,,,,,
+navbuddy,1288,udp,NavBuddy,[Eric_Hackman],[Eric_Hackman],,,,,,
+jwalkserver,1289,tcp,JWalkServer,,,,,,,,
+jwalkserver,1289,udp,JWalkServer,,,,,,,,
+winjaserver,1290,tcp,WinJaServer,,,,,,,,
+winjaserver,1290,udp,WinJaServer,,,,,,,,
+seagulllms,1291,tcp,SEAGULLLMS,[Lee_Breisacher],[Lee_Breisacher],,,,,,
+seagulllms,1291,udp,SEAGULLLMS,[Lee_Breisacher],[Lee_Breisacher],,,,,,
+dsdn,1292,tcp,dsdn,[Stanislaw_Skowronek],[Stanislaw_Skowronek],,,,,,
+dsdn,1292,udp,dsdn,[Stanislaw_Skowronek],[Stanislaw_Skowronek],,,,,,
+pkt-krb-ipsec,1293,tcp,PKT-KRB-IPSec,[Nancy_Davoust],[Nancy_Davoust],,,,,,
+pkt-krb-ipsec,1293,udp,PKT-KRB-IPSec,[Nancy_Davoust],[Nancy_Davoust],,,,,,
+cmmdriver,1294,tcp,CMMdriver,[Lutz_Karras],[Lutz_Karras],,,,,,
+cmmdriver,1294,udp,CMMdriver,[Lutz_Karras],[Lutz_Karras],,,,,,
+ehtp,1295,tcp,End-by-Hop Transmission Protocol,[Alexander_Bogdanov],[Alexander_Bogdanov],,,,,,
+ehtp,1295,udp,End-by-Hop Transmission Protocol,[Alexander_Bogdanov],[Alexander_Bogdanov],,,,,,
+dproxy,1296,tcp,dproxy,,,,,,,,
+dproxy,1296,udp,dproxy,,,,,,,,
+sdproxy,1297,tcp,sdproxy,[Raimond_Diederik],[Raimond_Diederik],,,,,,
+sdproxy,1297,udp,sdproxy,[Raimond_Diederik],[Raimond_Diederik],,,,,,
+lpcp,1298,tcp,lpcp,[Christian_Stredicke],[Christian_Stredicke],,,,,,
+lpcp,1298,udp,lpcp,[Christian_Stredicke],[Christian_Stredicke],,,,,,
+hp-sci,1299,tcp,hp-sci,[Kim_Scott],[Kim_Scott],,,,,,
+hp-sci,1299,udp,hp-sci,[Kim_Scott],[Kim_Scott],,,,,,
+h323hostcallsc,1300,tcp,H.323 Secure Call Control Signalling,[ITU-T],[ITU-T_TSB],,2013-01-31,,,,
+h323hostcallsc,1300,udp,H.323 Secure Call Control Signalling,[ITU-T],[ITU-T_TSB],,2013-01-31,,,,
+ci3-software-1,1301,tcp,CI3-Software-1,,,,,,,,
+ci3-software-1,1301,udp,CI3-Software-1,,,,,,,,
+ci3-software-2,1302,tcp,CI3-Software-2,[Kelli_Watson],[Kelli_Watson],,,,,,
+ci3-software-2,1302,udp,CI3-Software-2,[Kelli_Watson],[Kelli_Watson],,,,,,
+sftsrv,1303,tcp,sftsrv,[Robert_Frazier],[Robert_Frazier],,,,,,
+sftsrv,1303,udp,sftsrv,[Robert_Frazier],[Robert_Frazier],,,,,,
+boomerang,1304,tcp,Boomerang,[Bruce_Lueckenhoff],[Bruce_Lueckenhoff],,,,,,
+boomerang,1304,udp,Boomerang,[Bruce_Lueckenhoff],[Bruce_Lueckenhoff],,,,,,
+pe-mike,1305,tcp,pe-mike,[Stephen_Hemminger],[Stephen_Hemminger],,,,,,
+pe-mike,1305,udp,pe-mike,[Stephen_Hemminger],[Stephen_Hemminger],,,,,,
+re-conn-proto,1306,tcp,RE-Conn-Proto,[Sandeep_Singhal],[Sandeep_Singhal],,,,,,
+re-conn-proto,1306,udp,RE-Conn-Proto,[Sandeep_Singhal],[Sandeep_Singhal],,,,,,
+pacmand,1307,tcp,Pacmand,[Edward_T_O_Shea],[Edward_T_O_Shea],,,,,,
+pacmand,1307,udp,Pacmand,[Edward_T_O_Shea],[Edward_T_O_Shea],,,,,,
+odsi,1308,tcp,Optical Domain Service Interconnect (ODSI),[K_Arvind],[K_Arvind],,,,,,
+odsi,1308,udp,Optical Domain Service Interconnect (ODSI),[K_Arvind],[K_Arvind],,,,,,
+jtag-server,1309,tcp,JTAG server,[Andrew_Draper],[Andrew_Draper],,,,,,
+jtag-server,1309,udp,JTAG server,[Andrew_Draper],[Andrew_Draper],,,,,,
+husky,1310,tcp,Husky,[Mark_Zang],[Mark_Zang],,,,,,
+husky,1310,udp,Husky,[Mark_Zang],[Mark_Zang],,,,,,
+rxmon,1311,tcp,RxMon,[Javier_Jiminez],[Javier_Jiminez],,,,,,
+rxmon,1311,udp,RxMon,[Javier_Jiminez],[Javier_Jiminez],,,,,,
+sti-envision,1312,tcp,STI Envision,[Don_Stedman],[Don_Stedman],,,,,,
+sti-envision,1312,udp,STI Envision,[Don_Stedman],[Don_Stedman],,,,,,
+bmc-patroldb,1313,tcp,"BMC_PATROLDB
+IANA assigned this well-formed service name as a replacement for ""bmc_patroldb"".",[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmc_patroldb,1313,tcp,BMC_PATROLDB,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,"This entry is an alias to ""bmc-patroldb"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+bmc-patroldb,1313,udp,"BMC_PATROLDB
+IANA assigned this well-formed service name as a replacement for ""bmc_patroldb"".",[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmc_patroldb,1313,udp,BMC_PATROLDB,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,"This entry is an alias to ""bmc-patroldb"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+pdps,1314,tcp,Photoscript Distributed Printing System,[Les_Klein],[Les_Klein],,,,,,
+pdps,1314,udp,Photoscript Distributed Printing System,[Les_Klein],[Les_Klein],,,,,,
+els,1315,tcp,"E.L.S., Event Listener Service",[Jim_Cleppe],[Jim_Cleppe],,,,,,
+els,1315,udp,"E.L.S., Event Listener Service",[Jim_Cleppe],[Jim_Cleppe],,,,,,
+exbit-escp,1316,tcp,Exbit-ESCP,[Morten_Christensen],[Morten_Christensen],,,,,,
+exbit-escp,1316,udp,Exbit-ESCP,[Morten_Christensen],[Morten_Christensen],,,,,,
+vrts-ipcserver,1317,tcp,vrts-ipcserver,[Bruce_Hestand],[Bruce_Hestand],,,,,,
+vrts-ipcserver,1317,udp,vrts-ipcserver,[Bruce_Hestand],[Bruce_Hestand],,,,,,
+krb5gatekeeper,1318,tcp,krb5gatekeeper,[Patrick_Moore],[Patrick_Moore],,,,,,
+krb5gatekeeper,1318,udp,krb5gatekeeper,[Patrick_Moore],[Patrick_Moore],,,,,,
+amx-icsp,1319,tcp,AMX-ICSP,[Jeff_Burch],[Jeff_Burch],,,,,,
+amx-icsp,1319,udp,AMX-ICSP,[Jeff_Burch],[Jeff_Burch],,,,,,
+amx-axbnet,1320,tcp,AMX-AXBNET,[Jeff_Burch],[Jeff_Burch],,,,,,
+amx-axbnet,1320,udp,AMX-AXBNET,[Jeff_Burch],[Jeff_Burch],,,,,,
+pip,1321,tcp,PIP,[Gordon_Mohr],[Gordon_Mohr],,,,,,
+pip,1321,udp,PIP,[Gordon_Mohr],[Gordon_Mohr],,,,,,
+novation,1322,tcp,Novation,[Alan_Dano],[Alan_Dano],,,,,,
+novation,1322,udp,Novation,[Alan_Dano],[Alan_Dano],,,,,,
+brcd,1323,tcp,brcd,[Todd_Picquelle],[Todd_Picquelle],,,,,,
+brcd,1323,udp,brcd,[Todd_Picquelle],[Todd_Picquelle],,,,,,
+delta-mcp,1324,tcp,delta-mcp,[Quinton_Tormanen],[Quinton_Tormanen],,,,,,
+delta-mcp,1324,udp,delta-mcp,[Quinton_Tormanen],[Quinton_Tormanen],,,,,,
+dx-instrument,1325,tcp,DX-Instrument,[Walt_Modic],[Walt_Modic],,,,,,
+dx-instrument,1325,udp,DX-Instrument,[Walt_Modic],[Walt_Modic],,,,,,
+wimsic,1326,tcp,WIMSIC,[James_Brown],[James_Brown],,,,,,
+wimsic,1326,udp,WIMSIC,[James_Brown],[James_Brown],,,,,,
+ultrex,1327,tcp,Ultrex,[Tim_Walsh],[Tim_Walsh],,,,,,
+ultrex,1327,udp,Ultrex,[Tim_Walsh],[Tim_Walsh],,,,,,
+ewall,1328,tcp,EWALL,[Jeff_Busma],[Jeff_Busma],,,,,,
+ewall,1328,udp,EWALL,[Jeff_Busma],[Jeff_Busma],,,,,,
+netdb-export,1329,tcp,netdb-export,[Konstantinos_Kostis],[Konstantinos_Kostis],,,,,,
+netdb-export,1329,udp,netdb-export,[Konstantinos_Kostis],[Konstantinos_Kostis],,,,,,
+streetperfect,1330,tcp,StreetPerfect,[Michael_R_Young],[Michael_R_Young],,,,,,
+streetperfect,1330,udp,StreetPerfect,[Michael_R_Young],[Michael_R_Young],,,,,,
+intersan,1331,tcp,intersan,[Barry_H_Feild],[Barry_H_Feild],,,,,,
+intersan,1331,udp,intersan,[Barry_H_Feild],[Barry_H_Feild],,,,,,
+pcia-rxp-b,1332,tcp,PCIA RXP-B,[James_Dabbs],[James_Dabbs],,,,,,
+pcia-rxp-b,1332,udp,PCIA RXP-B,[James_Dabbs],[James_Dabbs],,,,,,
+passwrd-policy,1333,tcp,Password Policy,[Tonio_Pirotta],[Tonio_Pirotta],,,,,,
+passwrd-policy,1333,udp,Password Policy,[Tonio_Pirotta],[Tonio_Pirotta],,,,,,
+writesrv,1334,tcp,writesrv,[Marvin_Toungate],[Marvin_Toungate],,,,,,
+writesrv,1334,udp,writesrv,[Marvin_Toungate],[Marvin_Toungate],,,,,,
+digital-notary,1335,tcp,Digital Notary Protocol,[Wes_Doonan],[Wes_Doonan],,,,,,
+digital-notary,1335,udp,Digital Notary Protocol,[Wes_Doonan],[Wes_Doonan],,,,,,
+ischat,1336,tcp,Instant Service Chat,[Mike_Clise],[Mike_Clise],,,,,,
+ischat,1336,udp,Instant Service Chat,[Mike_Clise],[Mike_Clise],,,,,,
+menandmice-dns,1337,tcp,menandmice DNS,[Sigfus_Magnusson],[Sigfus_Magnusson],,,,,,
+menandmice-dns,1337,udp,menandmice DNS,[Sigfus_Magnusson],[Sigfus_Magnusson],,,,,,
+wmc-log-svc,1338,tcp,WMC-log-svr,[Scott_Anderson],[Scott_Anderson],,,,,,
+wmc-log-svc,1338,udp,WMC-log-svr,[Scott_Anderson],[Scott_Anderson],,,,,,
+kjtsiteserver,1339,tcp,kjtsiteserver,[Jason_Aubain],[Jason_Aubain],,,,,,
+kjtsiteserver,1339,udp,kjtsiteserver,[Jason_Aubain],[Jason_Aubain],,,,,,
+naap,1340,tcp,NAAP,[Henry_Haverinen],[Henry_Haverinen],,,,,,
+naap,1340,udp,NAAP,[Henry_Haverinen],[Henry_Haverinen],,,,,,
+qubes,1341,tcp,QuBES,[Eric_Grange],[Eric_Grange],,,,,,
+qubes,1341,udp,QuBES,[Eric_Grange],[Eric_Grange],,,,,,
+esbroker,1342,tcp,ESBroker,[Alexander_Medvinsky],[Alexander_Medvinsky],,,,,,
+esbroker,1342,udp,ESBroker,[Alexander_Medvinsky],[Alexander_Medvinsky],,,,,,
+re101,1343,tcp,re101,[Doriano_Blengino],[Doriano_Blengino],,,,,,
+re101,1343,udp,re101,[Doriano_Blengino],[Doriano_Blengino],,,,,,
+icap,1344,tcp,ICAP,[Jeremy_Elson],[Jeremy_Elson],,,,,,
+icap,1344,udp,ICAP,[Jeremy_Elson],[Jeremy_Elson],,,,,,
+vpjp,1345,tcp,VPJP,[Michael_Collins],[Michael_Collins],,,,,,
+vpjp,1345,udp,VPJP,[Michael_Collins],[Michael_Collins],,,,,,
+alta-ana-lm,1346,tcp,Alta Analytics License Manager,,,,,,,,
+alta-ana-lm,1346,udp,Alta Analytics License Manager,,,,,,,,
+bbn-mmc,1347,tcp,multi media conferencing,,,,,,,,
+bbn-mmc,1347,udp,multi media conferencing,,,,,,,,
+bbn-mmx,1348,tcp,multi media conferencing,,,,,,,,
+bbn-mmx,1348,udp,multi media conferencing,,,,,,,,
+sbook,1349,tcp,Registration Network Protocol,,,,,,,,
+sbook,1349,udp,Registration Network Protocol,,,,,,,,
+editbench,1350,tcp,Registration Network Protocol,[Simson_L_Garfinkel],[Simson_L_Garfinkel],,,,,,
+editbench,1350,udp,Registration Network Protocol,[Simson_L_Garfinkel],[Simson_L_Garfinkel],,,,,,
+equationbuilder,1351,tcp,Digital Tool Works (MIT),[Terrence_J_Talbot],[Terrence_J_Talbot],,,,,,
+equationbuilder,1351,udp,Digital Tool Works (MIT),[Terrence_J_Talbot],[Terrence_J_Talbot],,,,,,
+lotusnote,1352,tcp,Lotus Note,[Greg_Pflaum],[Greg_Pflaum],1992-07,,,,,
+lotusnote,1352,udp,Lotus Note,[Greg_Pflaum],[Greg_Pflaum],1992-07,,,,,
+relief,1353,tcp,Relief Consulting,[John_Feiler],[John_Feiler],,,,,,
+relief,1353,udp,Relief Consulting,[John_Feiler],[John_Feiler],,,,,,
+XSIP-network,1354,tcp,Five Across XSIP Network,[Glenn_Reid],[Glenn_Reid],,,,,,
+XSIP-network,1354,udp,Five Across XSIP Network,[Glenn_Reid],[Glenn_Reid],,,,,,
+intuitive-edge,1355,tcp,Intuitive Edge,[Montgomery_Zukowski],[Montgomery_Zukowski],,,,,,
+intuitive-edge,1355,udp,Intuitive Edge,[Montgomery_Zukowski],[Montgomery_Zukowski],,,,,,
+cuillamartin,1356,tcp,CuillaMartin Company,,,,,,,,
+cuillamartin,1356,udp,CuillaMartin Company,,,,,,,,
+pegboard,1357,tcp,Electronic PegBoard,[Chris_Cuilla],[Chris_Cuilla],,,,,,
+pegboard,1357,udp,Electronic PegBoard,[Chris_Cuilla],[Chris_Cuilla],,,,,,
+connlcli,1358,tcp,CONNLCLI,,,,,,,,
+connlcli,1358,udp,CONNLCLI,,,,,,,,
+ftsrv,1359,tcp,FTSRV,[Ines_Homem_de_Melo],[Ines_Homem_de_Melo],,,,,,
+ftsrv,1359,udp,FTSRV,[Ines_Homem_de_Melo],[Ines_Homem_de_Melo],,,,,,
+mimer,1360,tcp,MIMER,[Per_Schroeder],[Per_Schroeder],,,,,,
+mimer,1360,udp,MIMER,[Per_Schroeder],[Per_Schroeder],,,,,,
+linx,1361,tcp,LinX,[Steffen_Schilke],[Steffen_Schilke],,,,,,
+linx,1361,udp,LinX,[Steffen_Schilke],[Steffen_Schilke],,,,,,
+timeflies,1362,tcp,TimeFlies,[Doug_Kent],[Doug_Kent],,,,,,
+timeflies,1362,udp,TimeFlies,[Doug_Kent],[Doug_Kent],,,,,,
+ndm-requester,1363,tcp,Network DataMover Requester,,,,,,,,
+ndm-requester,1363,udp,Network DataMover Requester,,,,,,,,
+ndm-server,1364,tcp,Network DataMover Server,[Toshio_Watanabe],[Toshio_Watanabe],,,,,,
+ndm-server,1364,udp,Network DataMover Server,[Toshio_Watanabe],[Toshio_Watanabe],,,,,,
+adapt-sna,1365,tcp,Network Software Associates,[Jeffery_Chiao],[Jeffery_Chiao],,,,,,
+adapt-sna,1365,udp,Network Software Associates,[Jeffery_Chiao],[Jeffery_Chiao],,,,,,
+netware-csp,1366,tcp,Novell NetWare Comm Service Platform,[Laurie_Lindsey],[Laurie_Lindsey],,,,,,
+netware-csp,1366,udp,Novell NetWare Comm Service Platform,[Laurie_Lindsey],[Laurie_Lindsey],,,,,,
+dcs,1367,tcp,DCS,[Stefan_Siebert],[Stefan_Siebert],,,,,,
+dcs,1367,udp,DCS,[Stefan_Siebert],[Stefan_Siebert],,,,,,
+screencast,1368,tcp,ScreenCast,[Bill_Tschumy],[Bill_Tschumy],,,,,,
+screencast,1368,udp,ScreenCast,[Bill_Tschumy],[Bill_Tschumy],,,,,,
+gv-us,1369,tcp,GlobalView to Unix Shell,,,,,,,,
+gv-us,1369,udp,GlobalView to Unix Shell,,,,,,,,
+us-gv,1370,tcp,Unix Shell to GlobalView,[Makoto_Mita],[Makoto_Mita],,,,,,
+us-gv,1370,udp,Unix Shell to GlobalView,[Makoto_Mita],[Makoto_Mita],,,,,,
+fc-cli,1371,tcp,Fujitsu Config Protocol,,,,,,,,
+fc-cli,1371,udp,Fujitsu Config Protocol,,,,,,,,
+fc-ser,1372,tcp,Fujitsu Config Protocol,[Ryuichi_Horie],[Ryuichi_Horie],,,,,,
+fc-ser,1372,udp,Fujitsu Config Protocol,[Ryuichi_Horie],[Ryuichi_Horie],,,,,,
+chromagrafx,1373,tcp,Chromagrafx,[Mike_Barthelemy],[Mike_Barthelemy],,,,,,
+chromagrafx,1373,udp,Chromagrafx,[Mike_Barthelemy],[Mike_Barthelemy],,,,,,
+molly,1374,tcp,EPI Software Systems,[Jim_Vlcek],[Jim_Vlcek],,,,,,
+molly,1374,udp,EPI Software Systems,[Jim_Vlcek],[Jim_Vlcek],,,,,,
+bytex,1375,tcp,Bytex,[Mary_Ann_Burt],[Mary_Ann_Burt],,,,,,
+bytex,1375,udp,Bytex,[Mary_Ann_Burt],[Mary_Ann_Burt],,,,,,
+ibm-pps,1376,tcp,IBM Person to Person Software,[Simon_Phipps],[Simon_Phipps],,,,,,
+ibm-pps,1376,udp,IBM Person to Person Software,[Simon_Phipps],[Simon_Phipps],,,,,,
+cichlid,1377,tcp,Cichlid License Manager,[Andy_Burgess],[Andy_Burgess],,,,,,
+cichlid,1377,udp,Cichlid License Manager,[Andy_Burgess],[Andy_Burgess],,,,,,
+elan,1378,tcp,Elan License Manager,[Ken_Greer],[Ken_Greer],,,,,,
+elan,1378,udp,Elan License Manager,[Ken_Greer],[Ken_Greer],,,,,,
+dbreporter,1379,tcp,Integrity Solutions,[Tim_Dawson],[Tim_Dawson],,,,,,
+dbreporter,1379,udp,Integrity Solutions,[Tim_Dawson],[Tim_Dawson],,,,,,
+telesis-licman,1380,tcp,Telesis Network License Manager,[Karl_Schendel_Jr],[Karl_Schendel_Jr],,,,,,
+telesis-licman,1380,udp,Telesis Network License Manager,[Karl_Schendel_Jr],[Karl_Schendel_Jr],,,,,,
+apple-licman,1381,tcp,Apple Network License Manager,[Earl_Wallace],[Earl_Wallace],,,,,,
+apple-licman,1381,udp,Apple Network License Manager,[Earl_Wallace],[Earl_Wallace],,,,,,
+udt-os,1382,tcp,"udt_os
+IANA assigned this well-formed service name as a replacement for ""udt_os"".",,,,,,,,
+udt_os,1382,tcp,udt_os,,,,,,,,"This entry is an alias to ""udt-os"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+udt-os,1382,udp,"udt_os
+IANA assigned this well-formed service name as a replacement for ""udt_os"".",,,,,,,,
+udt_os,1382,udp,udt_os,,,,,,,,"This entry is an alias to ""udt-os"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+gwha,1383,tcp,GW Hannaway Network License Manager,[J_Gabriel_Foster],[J_Gabriel_Foster],,,,,,
+gwha,1383,udp,GW Hannaway Network License Manager,[J_Gabriel_Foster],[J_Gabriel_Foster],,,,,,
+os-licman,1384,tcp,Objective Solutions License Manager,[Donald_Cornwell],[Donald_Cornwell],,,,,,
+os-licman,1384,udp,Objective Solutions License Manager,[Donald_Cornwell],[Donald_Cornwell],,,,,,
+atex-elmd,1385,tcp,"Atex Publishing License Manager
+IANA assigned this well-formed service name as a replacement for ""atex_elmd"".",[Brett_Sorenson],[Brett_Sorenson],,,,,,
+atex_elmd,1385,tcp,Atex Publishing License Manager,[Brett_Sorenson],[Brett_Sorenson],,,,,,"This entry is an alias to ""atex-elmd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+atex-elmd,1385,udp,"Atex Publishing License Manager
+IANA assigned this well-formed service name as a replacement for ""atex_elmd"".",[Brett_Sorenson],[Brett_Sorenson],,,,,,
+atex_elmd,1385,udp,Atex Publishing License Manager,[Brett_Sorenson],[Brett_Sorenson],,,,,,"This entry is an alias to ""atex-elmd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+checksum,1386,tcp,CheckSum License Manager,[Andreas_Glocker],[Andreas_Glocker],,,,,,
+checksum,1386,udp,CheckSum License Manager,[Andreas_Glocker],[Andreas_Glocker],,,,,,
+cadsi-lm,1387,tcp,Computer Aided Design Software Inc LM,[Sulistio_Muljadi],[Sulistio_Muljadi],,,,,,
+cadsi-lm,1387,udp,Computer Aided Design Software Inc LM,[Sulistio_Muljadi],[Sulistio_Muljadi],,,,,,
+objective-dbc,1388,tcp,Objective Solutions DataBase Cache,[Donald_Cornwell_2],[Donald_Cornwell_2],,,,,,
+objective-dbc,1388,udp,Objective Solutions DataBase Cache,[Donald_Cornwell_2],[Donald_Cornwell_2],,,,,,
+iclpv-dm,1389,tcp,Document Manager,,,,,,,,
+iclpv-dm,1389,udp,Document Manager,,,,,,,,
+iclpv-sc,1390,tcp,Storage Controller,,,,,,,,
+iclpv-sc,1390,udp,Storage Controller,,,,,,,,
+iclpv-sas,1391,tcp,Storage Access Server,,,,,,,,
+iclpv-sas,1391,udp,Storage Access Server,,,,,,,,
+iclpv-pm,1392,tcp,Print Manager,,,,,,,,
+iclpv-pm,1392,udp,Print Manager,,,,,,,,
+iclpv-nls,1393,tcp,Network Log Server,,,,,,,,
+iclpv-nls,1393,udp,Network Log Server,,,,,,,,
+iclpv-nlc,1394,tcp,Network Log Client,,,,,,,,
+iclpv-nlc,1394,udp,Network Log Client,,,,,,,,
+iclpv-wsm,1395,tcp,PC Workstation Manager software,[A_P_Hobson],[A_P_Hobson],,,,,,
+iclpv-wsm,1395,udp,PC Workstation Manager software,[A_P_Hobson],[A_P_Hobson],,,,,,
+dvl-activemail,1396,tcp,DVL Active Mail,,,,,,,,
+dvl-activemail,1396,udp,DVL Active Mail,,,,,,,,
+audio-activmail,1397,tcp,Audio Active Mail,,,,,,,,
+audio-activmail,1397,udp,Audio Active Mail,,,,,,,,
+video-activmail,1398,tcp,Video Active Mail,[Avshalom_Houri],[Avshalom_Houri],,,,,,
+video-activmail,1398,udp,Video Active Mail,[Avshalom_Houri],[Avshalom_Houri],,,,,,
+cadkey-licman,1399,tcp,Cadkey License Manager,,,,,,,,
+cadkey-licman,1399,udp,Cadkey License Manager,,,,,,,,
+cadkey-tablet,1400,tcp,Cadkey Tablet Daemon,[Joe_McCollough],[Joe_McCollough],,,,,,
+cadkey-tablet,1400,udp,Cadkey Tablet Daemon,[Joe_McCollough],[Joe_McCollough],,,,,,
+goldleaf-licman,1401,tcp,Goldleaf License Manager,[John_Fox],[John_Fox],,,,,,
+goldleaf-licman,1401,udp,Goldleaf License Manager,[John_Fox],[John_Fox],,,,,,
+prm-sm-np,1402,tcp,Prospero Resource Manager,,,,,,,,
+prm-sm-np,1402,udp,Prospero Resource Manager,,,,,,,,
+prm-nm-np,1403,tcp,Prospero Resource Manager,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,,
+prm-nm-np,1403,udp,Prospero Resource Manager,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,,
+igi-lm,1404,tcp,Infinite Graphics License Manager,,,,,,,,
+igi-lm,1404,udp,Infinite Graphics License Manager,,,,,,,,
+ibm-res,1405,tcp,IBM Remote Execution Starter,,,,,,,,
+ibm-res,1405,udp,IBM Remote Execution Starter,,,,,,,,
+netlabs-lm,1406,tcp,NetLabs License Manager,,,,,,,,
+netlabs-lm,1406,udp,NetLabs License Manager,,,,,,,,
+dbsa-lm,1407,tcp,DBSA License Manager,[Scott_Shattuck],[Scott_Shattuck],,,,,,
+dbsa-lm,1407,udp,DBSA License Manager,[Scott_Shattuck],[Scott_Shattuck],,,,,,
+sophia-lm,1408,tcp,Sophia License Manager,[Eric_Brown],[Eric_Brown],,,,,,
+sophia-lm,1408,udp,Sophia License Manager,[Eric_Brown],[Eric_Brown],,,,,,
+here-lm,1409,tcp,Here License Manager,[David_Ison],[David_Ison],,,,,,
+here-lm,1409,udp,Here License Manager,[David_Ison],[David_Ison],,,,,,
+hiq,1410,tcp,HiQ License Manager,[Rick_Pugh],[Rick_Pugh],,,,,,
+hiq,1410,udp,HiQ License Manager,[Rick_Pugh],[Rick_Pugh],,,,,,
+af,1411,tcp,AudioFile,[Jim_Gettys],[Jim_Gettys],,,,,,
+af,1411,udp,AudioFile,[Jim_Gettys],[Jim_Gettys],,,,,,
+innosys,1412,tcp,InnoSys,,,,,,,,
+innosys,1412,udp,InnoSys,,,,,,,,
+innosys-acl,1413,tcp,Innosys-ACL,[Eric_Welch],[Eric_Welch],,,,,,
+innosys-acl,1413,udp,Innosys-ACL,[Eric_Welch],[Eric_Welch],,,,,,
+ibm-mqseries,1414,tcp,IBM MQSeries,[Roger_Meli],[Roger_Meli],,,,,,
+ibm-mqseries,1414,udp,IBM MQSeries,[Roger_Meli],[Roger_Meli],,,,,,
+dbstar,1415,tcp,DBStar,[Jeffrey_Millman],[Jeffrey_Millman],,,,,,
+dbstar,1415,udp,DBStar,[Jeffrey_Millman],[Jeffrey_Millman],,,,,,
+novell-lu6-2,1416,tcp,"Novell LU6.2
+IANA assigned this well-formed service name as a replacement for ""novell-lu6.2"".",[Peter_Liu],[Peter_Liu],,,,,,
+novell-lu6.2,1416,tcp,Novell LU6.2,[Peter_Liu],[Peter_Liu],,,,,,"This entry is an alias to ""novell-lu6-2"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+novell-lu6-2,1416,udp,"Novell LU6.2
+IANA assigned this well-formed service name as a replacement for ""novell-lu6.2"".",[Peter_Liu],[Peter_Liu],,,,,,
+novell-lu6.2,1416,udp,Novell LU6.2,[Peter_Liu],[Peter_Liu],,,,,,"This entry is an alias to ""novell-lu6-2"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+timbuktu-srv1,1417,tcp,Timbuktu Service 1 Port,,,,,,,,
+timbuktu-srv1,1417,udp,Timbuktu Service 1 Port,,,,,,,,
+timbuktu-srv2,1418,tcp,Timbuktu Service 2 Port,,,,,,,,
+timbuktu-srv2,1418,udp,Timbuktu Service 2 Port,,,,,,,,
+timbuktu-srv3,1419,tcp,Timbuktu Service 3 Port,,,,,,,,
+timbuktu-srv3,1419,udp,Timbuktu Service 3 Port,,,,,,,,
+timbuktu-srv4,1420,tcp,Timbuktu Service 4 Port,[Marc_Epard],[Marc_Epard],,,,,,
+timbuktu-srv4,1420,udp,Timbuktu Service 4 Port,[Marc_Epard],[Marc_Epard],,,,,,
+gandalf-lm,1421,tcp,Gandalf License Manager,[gilmer],[gilmer],,,,,,
+gandalf-lm,1421,udp,Gandalf License Manager,[gilmer],[gilmer],,,,,,
+autodesk-lm,1422,tcp,Autodesk License Manager,[David_Ko],[David_Ko],,,,,,
+autodesk-lm,1422,udp,Autodesk License Manager,[David_Ko],[David_Ko],,,,,,
+essbase,1423,tcp,Essbase Arbor Software,,,,,,,,
+essbase,1423,udp,Essbase Arbor Software,,,,,,,,
+hybrid,1424,tcp,Hybrid Encryption Protocol,[Howard_Hart],[Howard_Hart],,,,,,
+hybrid,1424,udp,Hybrid Encryption Protocol,[Howard_Hart],[Howard_Hart],,,,,,
+zion-lm,1425,tcp,Zion Software License Manager,[David_Ferrero],[David_Ferrero],,,,,,
+zion-lm,1425,udp,Zion Software License Manager,[David_Ferrero],[David_Ferrero],,,,,,
+sais,1426,tcp,Satellite-data Acquisition System 1,[Bill_Taylor],[Bill_Taylor],,,,,,
+sais,1426,udp,Satellite-data Acquisition System 1,[Bill_Taylor],[Bill_Taylor],,,,,,
+mloadd,1427,tcp,mloadd monitoring tool,[Bob_Braden_2],[Bob_Braden_2],,,,,,
+mloadd,1427,udp,mloadd monitoring tool,[Bob_Braden_2],[Bob_Braden_2],,,,,,
+informatik-lm,1428,tcp,Informatik License Manager,[Harald_Schlangmann],[Harald_Schlangmann],,,,,,
+informatik-lm,1428,udp,Informatik License Manager,[Harald_Schlangmann],[Harald_Schlangmann],,,,,,
+nms,1429,tcp,Hypercom NMS,,,,,,,,
+nms,1429,udp,Hypercom NMS,,,,,,,,
+tpdu,1430,tcp,Hypercom TPDU,[Noor_Chowdhury],[Noor_Chowdhury],,,,,,
+tpdu,1430,udp,Hypercom TPDU,[Noor_Chowdhury],[Noor_Chowdhury],,,,,,
+rgtp,1431,tcp,Reverse Gossip Transport,[Ian_Jackson],[Ian_Jackson],,,,,,
+rgtp,1431,udp,Reverse Gossip Transport,[Ian_Jackson],[Ian_Jackson],,,,,,
+blueberry-lm,1432,tcp,Blueberry Software License Manager,[Steve_Beigel],[Steve_Beigel],,,,,,
+blueberry-lm,1432,udp,Blueberry Software License Manager,[Steve_Beigel],[Steve_Beigel],,,,,,
+ms-sql-s,1433,tcp,Microsoft-SQL-Server,,,,,,,,
+ms-sql-s,1433,udp,Microsoft-SQL-Server,,,,,,,,
+ms-sql-m,1434,tcp,Microsoft-SQL-Monitor,[Peter_Hussey],[Peter_Hussey],,,,,,
+ms-sql-m,1434,udp,Microsoft-SQL-Monitor,[Peter_Hussey],[Peter_Hussey],,,,,,
+ibm-cics,1435,tcp,IBM CICS,[Geoff_Meacock],[Geoff_Meacock],,,,,,
+ibm-cics,1435,udp,IBM CICS,[Geoff_Meacock],[Geoff_Meacock],,,,,,
+saism,1436,tcp,Satellite-data Acquisition System 2,[Bill_Taylor],[Bill_Taylor],,,,,,
+saism,1436,udp,Satellite-data Acquisition System 2,[Bill_Taylor],[Bill_Taylor],,,,,,
+tabula,1437,tcp,Tabula,[Marcelo_Einhorn],[Marcelo_Einhorn],,,,,,
+tabula,1437,udp,Tabula,[Marcelo_Einhorn],[Marcelo_Einhorn],,,,,,
+eicon-server,1438,tcp,Eicon Security Agent/Server,,,,,,,,
+eicon-server,1438,udp,Eicon Security Agent/Server,,,,,,,,
+eicon-x25,1439,tcp,Eicon X25/SNA Gateway,,,,,,,,
+eicon-x25,1439,udp,Eicon X25/SNA Gateway,,,,,,,,
+eicon-slp,1440,tcp,Eicon Service Location Protocol,[Pat_Calhoun],[Pat_Calhoun],,,,,,
+eicon-slp,1440,udp,Eicon Service Location Protocol,[Pat_Calhoun],[Pat_Calhoun],,,,,,
+cadis-1,1441,tcp,Cadis License Management,,,,,,,,
+cadis-1,1441,udp,Cadis License Management,,,,,,,,
+cadis-2,1442,tcp,Cadis License Management,[Todd_Wichers],[Todd_Wichers],,,,,,
+cadis-2,1442,udp,Cadis License Management,[Todd_Wichers],[Todd_Wichers],,,,,,
+ies-lm,1443,tcp,Integrated Engineering Software,[David_Tong],[David_Tong],,,,,,
+ies-lm,1443,udp,Integrated Engineering Software,[David_Tong],[David_Tong],,,,,,
+marcam-lm,1444,tcp,Marcam License Management,[Therese_Hunt],[Therese_Hunt],,,,,,
+marcam-lm,1444,udp,Marcam License Management,[Therese_Hunt],[Therese_Hunt],,,,,,
+proxima-lm,1445,tcp,Proxima License Manager,,,,,,,,
+proxima-lm,1445,udp,Proxima License Manager,,,,,,,,
+ora-lm,1446,tcp,Optical Research Associates License Manager,,,,,,,,
+ora-lm,1446,udp,Optical Research Associates License Manager,,,,,,,,
+apri-lm,1447,tcp,Applied Parallel Research LM,[Jim_Dillon],[Jim_Dillon],,,,,,
+apri-lm,1447,udp,Applied Parallel Research LM,[Jim_Dillon],[Jim_Dillon],,,,,,
+oc-lm,1448,tcp,OpenConnect License Manager,[Sue_Barnhill],[Sue_Barnhill],,,,,,
+oc-lm,1448,udp,OpenConnect License Manager,[Sue_Barnhill],[Sue_Barnhill],,,,,,
+peport,1449,tcp,PEport,[Qentin_Neill],[Qentin_Neill],,,,,,
+peport,1449,udp,PEport,[Qentin_Neill],[Qentin_Neill],,,,,,
+dwf,1450,tcp,Tandem Distributed Workbench Facility,[Mike_Bert],[Mike_Bert],,,,,,
+dwf,1450,udp,Tandem Distributed Workbench Facility,[Mike_Bert],[Mike_Bert],,,,,,
+infoman,1451,tcp,IBM Information Management,[Karen_Burns],[Karen_Burns],,,,,,
+infoman,1451,udp,IBM Information Management,[Karen_Burns],[Karen_Burns],,,,,,
+gtegsc-lm,1452,tcp,GTE Government Systems License Man,[Mike_Gregory],[Mike_Gregory],,,,,,
+gtegsc-lm,1452,udp,GTE Government Systems License Man,[Mike_Gregory],[Mike_Gregory],,,,,,
+genie-lm,1453,tcp,Genie License Manager,[Paul_Applegate],[Paul_Applegate],,,,,,
+genie-lm,1453,udp,Genie License Manager,[Paul_Applegate],[Paul_Applegate],,,,,,
+interhdl-elmd,1454,tcp,"interHDL License Manager
+IANA assigned this well-formed service name as a replacement for ""interhdl_elmd"".",[Eli_Sternheim],[Eli_Sternheim],,,,,,
+interhdl_elmd,1454,tcp,interHDL License Manager,[Eli_Sternheim],[Eli_Sternheim],,,,,,"This entry is an alias to ""interhdl-elmd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+interhdl-elmd,1454,udp,"interHDL License Manager
+IANA assigned this well-formed service name as a replacement for ""interhdl_elmd"".",[Eli_Sternheim],[Eli_Sternheim],,,,,,
+interhdl_elmd,1454,udp,interHDL License Manager,[Eli_Sternheim],[Eli_Sternheim],,,,,,"This entry is an alias to ""interhdl-elmd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+esl-lm,1455,tcp,ESL License Manager,[Abel_Chou],[Abel_Chou],,,,,,
+esl-lm,1455,udp,ESL License Manager,[Abel_Chou],[Abel_Chou],,,,,,
+dca,1456,tcp,DCA,[Jeff_Garbers_2],[Jeff_Garbers_2],,,,,,
+dca,1456,udp,DCA,[Jeff_Garbers_2],[Jeff_Garbers_2],,,,,,
+valisys-lm,1457,tcp,Valisys License Manager,[Leslie_Lincoln],[Leslie_Lincoln],,,,,,
+valisys-lm,1457,udp,Valisys License Manager,[Leslie_Lincoln],[Leslie_Lincoln],,,,,,
+nrcabq-lm,1458,tcp,Nichols Research Corp.,[Howard_Cole],[Howard_Cole],,,,,,
+nrcabq-lm,1458,udp,Nichols Research Corp.,[Howard_Cole],[Howard_Cole],,,,,,
+proshare1,1459,tcp,Proshare Notebook Application,,,,,,,,
+proshare1,1459,udp,Proshare Notebook Application,,,,,,,,
+proshare2,1460,tcp,Proshare Notebook Application,[Robin_Kar],[Robin_Kar],,,,,,
+proshare2,1460,udp,Proshare Notebook Application,[Robin_Kar],[Robin_Kar],,,,,,
+ibm-wrless-lan,1461,tcp,"IBM Wireless LAN
+IANA assigned this well-formed service name as a replacement for ""ibm_wrless_lan"".",[flanne],[flanne],,,,,,
+ibm_wrless_lan,1461,tcp,IBM Wireless LAN,[flanne],[flanne],,,,,,"This entry is an alias to ""ibm-wrless-lan"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+ibm-wrless-lan,1461,udp,"IBM Wireless LAN
+IANA assigned this well-formed service name as a replacement for ""ibm_wrless_lan"".",[flanne],[flanne],,,,,,
+ibm_wrless_lan,1461,udp,IBM Wireless LAN,[flanne],[flanne],,,,,,"This entry is an alias to ""ibm-wrless-lan"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+world-lm,1462,tcp,World License Manager,[Michael_S_Amirault],[Michael_S_Amirault],,,,,,
+world-lm,1462,udp,World License Manager,[Michael_S_Amirault],[Michael_S_Amirault],,,,,,
+nucleus,1463,tcp,Nucleus,[Venky_Nagar],[Venky_Nagar],,,,,,
+nucleus,1463,udp,Nucleus,[Venky_Nagar],[Venky_Nagar],,,,,,
+msl-lmd,1464,tcp,"MSL License Manager
+IANA assigned this well-formed service name as a replacement for ""msl_lmd"".",[Matt_Timmermans],[Matt_Timmermans],,,,,,
+msl_lmd,1464,tcp,MSL License Manager,[Matt_Timmermans],[Matt_Timmermans],,,,,,"This entry is an alias to ""msl-lmd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+msl-lmd,1464,udp,"MSL License Manager
+IANA assigned this well-formed service name as a replacement for ""msl_lmd"".",[Matt_Timmermans],[Matt_Timmermans],,,,,,
+msl_lmd,1464,udp,MSL License Manager,[Matt_Timmermans],[Matt_Timmermans],,,,,,"This entry is an alias to ""msl-lmd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+pipes,1465,tcp,Pipes Platform,[Mark_Farlin],[Mark_Farlin],,,,,,
+pipes,1465,udp,Pipes Platform,[Mark_Farlin],[Mark_Farlin],,,,,,
+oceansoft-lm,1466,tcp,Ocean Software License Manager,[Randy_Leonard],[Randy_Leonard],,,,,,
+oceansoft-lm,1466,udp,Ocean Software License Manager,[Randy_Leonard],[Randy_Leonard],,,,,,
+csdmbase,1467,tcp,CSDMBASE,,,,,,,,
+csdmbase,1467,udp,CSDMBASE,,,,,,,,
+csdm,1468,tcp,CSDM,[Robert_Stabl],[Robert_Stabl],,,,,,
+csdm,1468,udp,CSDM,[Robert_Stabl],[Robert_Stabl],,,,,,
+aal-lm,1469,tcp,Active Analysis Limited License Manager,[David_Snocken],[David_Snocken],,,,,,
+aal-lm,1469,udp,Active Analysis Limited License Manager,[David_Snocken],[David_Snocken],,,,,,
+uaiact,1470,tcp,Universal Analytics,[Mark_R_Ludwig],[Mark_R_Ludwig],,,,,,
+uaiact,1470,udp,Universal Analytics,[Mark_R_Ludwig],[Mark_R_Ludwig],,,,,,
+csdmbase,1471,tcp,csdmbase,,,,,,,,
+csdmbase,1471,udp,csdmbase,,,,,,,,
+csdm,1472,tcp,csdm,[Robert_Stabl],[Robert_Stabl],,,,,,
+csdm,1472,udp,csdm,[Robert_Stabl],[Robert_Stabl],,,,,,
+openmath,1473,tcp,OpenMath,[Garth_Mayville],[Garth_Mayville],,,,,,
+openmath,1473,udp,OpenMath,[Garth_Mayville],[Garth_Mayville],,,,,,
+telefinder,1474,tcp,Telefinder,[Jim_White],[Jim_White],,,,,,
+telefinder,1474,udp,Telefinder,[Jim_White],[Jim_White],,,,,,
+taligent-lm,1475,tcp,Taligent License Manager,[Mark_Sapsford],[Mark_Sapsford],,,,,,
+taligent-lm,1475,udp,Taligent License Manager,[Mark_Sapsford],[Mark_Sapsford],,,,,,
+clvm-cfg,1476,tcp,clvm-cfg,[Eric_Soderberg],[Eric_Soderberg],,,,,,
+clvm-cfg,1476,udp,clvm-cfg,[Eric_Soderberg],[Eric_Soderberg],,,,,,
+ms-sna-server,1477,tcp,ms-sna-server,,,,,,,,
+ms-sna-server,1477,udp,ms-sna-server,,,,,,,,
+ms-sna-base,1478,tcp,ms-sna-base,[Gordon_Mangione],[Gordon_Mangione],,,,,,
+ms-sna-base,1478,udp,ms-sna-base,[Gordon_Mangione],[Gordon_Mangione],,,,,,
+dberegister,1479,tcp,dberegister,[Brian_Griswold],[Brian_Griswold],,,,,,
+dberegister,1479,udp,dberegister,[Brian_Griswold],[Brian_Griswold],,,,,,
+pacerforum,1480,tcp,PacerForum,[Peter_Caswell],[Peter_Caswell],,,,,,
+pacerforum,1480,udp,PacerForum,[Peter_Caswell],[Peter_Caswell],,,,,,
+airs,1481,tcp,AIRS,[Bruce_Wilson],[Bruce_Wilson],,,,,,
+airs,1481,udp,AIRS,[Bruce_Wilson],[Bruce_Wilson],,,,,,
+miteksys-lm,1482,tcp,Miteksys License Manager,[Shane_McRoberts],[Shane_McRoberts],,,,,,
+miteksys-lm,1482,udp,Miteksys License Manager,[Shane_McRoberts],[Shane_McRoberts],,,,,,
+afs,1483,tcp,AFS License Manager,[Michael_R_Pizolato],[Michael_R_Pizolato],,,,,,
+afs,1483,udp,AFS License Manager,[Michael_R_Pizolato],[Michael_R_Pizolato],,,,,,
+confluent,1484,tcp,Confluent License Manager,[James_Greenfiel],[James_Greenfiel],,,,,,
+confluent,1484,udp,Confluent License Manager,[James_Greenfiel],[James_Greenfiel],,,,,,
+lansource,1485,tcp,LANSource,[Christopher_Wells],[Christopher_Wells],,,,,,
+lansource,1485,udp,LANSource,[Christopher_Wells],[Christopher_Wells],,,,,,
+nms-topo-serv,1486,tcp,"nms_topo_serv
+IANA assigned this well-formed service name as a replacement for ""nms_topo_serv"".",[Sylvia_Siu],[Sylvia_Siu],,,,,,
+nms_topo_serv,1486,tcp,nms_topo_serv,[Sylvia_Siu],[Sylvia_Siu],,,,,,"This entry is an alias to ""nms-topo-serv"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+nms-topo-serv,1486,udp,"nms_topo_serv
+IANA assigned this well-formed service name as a replacement for ""nms_topo_serv"".",[Sylvia_Siu],[Sylvia_Siu],,,,,,
+nms_topo_serv,1486,udp,nms_topo_serv,[Sylvia_Siu],[Sylvia_Siu],,,,,,"This entry is an alias to ""nms-topo-serv"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+localinfosrvr,1487,tcp,LocalInfoSrvr,[Brian_Matthews_2],[Brian_Matthews_2],,,,,,
+localinfosrvr,1487,udp,LocalInfoSrvr,[Brian_Matthews_2],[Brian_Matthews_2],,,,,,
+docstor,1488,tcp,DocStor,[Brian_Spears],[Brian_Spears],,,,,,
+docstor,1488,udp,DocStor,[Brian_Spears],[Brian_Spears],,,,,,
+dmdocbroker,1489,tcp,dmdocbroker,[Razmik_Abnous],[Razmik_Abnous],,,,,,
+dmdocbroker,1489,udp,dmdocbroker,[Razmik_Abnous],[Razmik_Abnous],,,,,,
+insitu-conf,1490,tcp,insitu-conf,[Paul_Blacknell],[Paul_Blacknell],,,,,,
+insitu-conf,1490,udp,insitu-conf,[Paul_Blacknell],[Paul_Blacknell],,,,,,
+,1491,,Unassigned,,,,2009-08-05,,,Unauthorized Use Known on port 1491,
+stone-design-1,1492,tcp,stone-design-1,[Andrew_Stone],[Andrew_Stone],,,,,,
+stone-design-1,1492,udp,stone-design-1,[Andrew_Stone],[Andrew_Stone],,,,,,
+netmap-lm,1493,tcp,"netmap_lm
+IANA assigned this well-formed service name as a replacement for ""netmap_lm"".",[Phillip_Magson],[Phillip_Magson],,,,,,
+netmap_lm,1493,tcp,netmap_lm,[Phillip_Magson],[Phillip_Magson],,,,,,"This entry is an alias to ""netmap-lm"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+netmap-lm,1493,udp,"netmap_lm
+IANA assigned this well-formed service name as a replacement for ""netmap_lm"".",[Phillip_Magson],[Phillip_Magson],,,,,,
+netmap_lm,1493,udp,netmap_lm,[Phillip_Magson],[Phillip_Magson],,,,,,"This entry is an alias to ""netmap-lm"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+ica,1494,tcp,ica,[John_Richardson],[John_Richardson],,,,,,
+ica,1494,udp,ica,[John_Richardson],[John_Richardson],,,,,,
+cvc,1495,tcp,cvc,[Bill_Davidson],[Bill_Davidson],,,,,,
+cvc,1495,udp,cvc,[Bill_Davidson],[Bill_Davidson],,,,,,
+liberty-lm,1496,tcp,liberty-lm,[Jim_Rogers],[Jim_Rogers],,,,,,
+liberty-lm,1496,udp,liberty-lm,[Jim_Rogers],[Jim_Rogers],,,,,,
+rfx-lm,1497,tcp,rfx-lm,[Bill_Bishop],[Bill_Bishop],,,,,,
+rfx-lm,1497,udp,rfx-lm,[Bill_Bishop],[Bill_Bishop],,,,,,
+sybase-sqlany,1498,tcp,Sybase SQL Any,[Dave_Neudoerffer],[Dave_Neudoerffer],,,,,,
+sybase-sqlany,1498,udp,Sybase SQL Any,[Dave_Neudoerffer],[Dave_Neudoerffer],,,,,,
+fhc,1499,tcp,Federico Heinz Consultora,[Federico_Heinz],[Federico_Heinz],,,,,,
+fhc,1499,udp,Federico Heinz Consultora,[Federico_Heinz],[Federico_Heinz],,,,,,
+vlsi-lm,1500,tcp,VLSI License Manager,[Shue_Lin_Kuo],[Shue_Lin_Kuo],,,,,,
+vlsi-lm,1500,udp,VLSI License Manager,[Shue_Lin_Kuo],[Shue_Lin_Kuo],,,,,,
+saiscm,1501,tcp,Satellite-data Acquisition System 3,[Bill_Taylor],[Bill_Taylor],,,,,,
+saiscm,1501,udp,Satellite-data Acquisition System 3,[Bill_Taylor],[Bill_Taylor],,,,,,
+shivadiscovery,1502,tcp,Shiva,[Jonathan_Wenocur],[Jonathan_Wenocur],,,,,,
+shivadiscovery,1502,udp,Shiva,[Jonathan_Wenocur],[Jonathan_Wenocur],,,,,,
+imtc-mcs,1503,tcp,Databeam,[Jim_Johnston],[Jim_Johnston],,,,,,
+imtc-mcs,1503,udp,Databeam,[Jim_Johnston],[Jim_Johnston],,,,,,
+evb-elm,1504,tcp,EVB Software Engineering License Manager,[B_G_Mahesh],[B_G_Mahesh],,,,,,
+evb-elm,1504,udp,EVB Software Engineering License Manager,[B_G_Mahesh],[B_G_Mahesh],,,,,,
+funkproxy,1505,tcp,"Funk Software, Inc.",[Robert_D_Vincent],[Robert_D_Vincent],,,,,,
+funkproxy,1505,udp,"Funk Software, Inc.",[Robert_D_Vincent],[Robert_D_Vincent],,,,,,
+utcd,1506,tcp,Universal Time daemon (utcd),[Walter_Poxon],[Walter_Poxon],,,,,,
+utcd,1506,udp,Universal Time daemon (utcd),[Walter_Poxon],[Walter_Poxon],,,,,,
+symplex,1507,tcp,symplex,[Mike_Turley],[Mike_Turley],,,,,,
+symplex,1507,udp,symplex,[Mike_Turley],[Mike_Turley],,,,,,
+diagmond,1508,tcp,diagmond,[Pete_Moscatelli],[Pete_Moscatelli],,,,,,
+diagmond,1508,udp,diagmond,[Pete_Moscatelli],[Pete_Moscatelli],,,,,,
+robcad-lm,1509,tcp,"Robcad, Ltd. License Manager",[Hindin_Joseph],[Hindin_Joseph],,,,,,
+robcad-lm,1509,udp,"Robcad, Ltd. License Manager",[Hindin_Joseph],[Hindin_Joseph],,,,,,
+mvx-lm,1510,tcp,Midland Valley Exploration Ltd. Lic. Man.,[Neil_Salter],[Neil_Salter],,,,,,
+mvx-lm,1510,udp,Midland Valley Exploration Ltd. Lic. Man.,[Neil_Salter],[Neil_Salter],,,,,,
+3l-l1,1511,tcp,3l-l1,[Ian_A_Young],[Ian_A_Young],,,,,,
+3l-l1,1511,udp,3l-l1,[Ian_A_Young],[Ian_A_Young],,,,,,
+wins,1512,tcp,Microsoft's Windows Internet Name Service,[Pradeep_Bahl],[Pradeep_Bahl],,,,,,
+wins,1512,udp,Microsoft's Windows Internet Name Service,[Pradeep_Bahl],[Pradeep_Bahl],,,,,,
+fujitsu-dtc,1513,tcp,"Fujitsu Systems Business of America, Inc",,,,,,,,
+fujitsu-dtc,1513,udp,"Fujitsu Systems Business of America, Inc",,,,,,,,
+fujitsu-dtcns,1514,tcp,"Fujitsu Systems Business of America, Inc",[Charles_A_Higgins],[Charles_A_Higgins],,,,,,
+fujitsu-dtcns,1514,udp,"Fujitsu Systems Business of America, Inc",[Charles_A_Higgins],[Charles_A_Higgins],,,,,,
+ifor-protocol,1515,tcp,ifor-protocol,[Dr_R_P_Alston],[Dr_R_P_Alston],,,,,,
+ifor-protocol,1515,udp,ifor-protocol,[Dr_R_P_Alston],[Dr_R_P_Alston],,,,,,
+vpad,1516,tcp,Virtual Places Audio data,,,,,,,,
+vpad,1516,udp,Virtual Places Audio data,,,,,,,,
+vpac,1517,tcp,Virtual Places Audio control,,,,,,,,
+vpac,1517,udp,Virtual Places Audio control,,,,,,,,
+vpvd,1518,tcp,Virtual Places Video data,,,,,,,,
+vpvd,1518,udp,Virtual Places Video data,,,,,,,,
+vpvc,1519,tcp,Virtual Places Video control,[Avshalom_Houri],[Avshalom_Houri],,,,,,
+vpvc,1519,udp,Virtual Places Video control,[Avshalom_Houri],[Avshalom_Houri],,,,,,
+atm-zip-office,1520,tcp,atm zip office,[Wilson_Kwan],[Wilson_Kwan],,,,,,
+atm-zip-office,1520,udp,atm zip office,[Wilson_Kwan],[Wilson_Kwan],,,,,,
+ncube-lm,1521,tcp,nCube License Manager,[Maxine_Yuen],[Maxine_Yuen],,,,,,
+ncube-lm,1521,udp,nCube License Manager,[Maxine_Yuen],[Maxine_Yuen],,,,,,
+ricardo-lm,1522,tcp,Ricardo North America License Manager,[Mike_Flemming],[Mike_Flemming],,,,,,
+ricardo-lm,1522,udp,Ricardo North America License Manager,[Mike_Flemming],[Mike_Flemming],,,,,,
+cichild-lm,1523,tcp,cichild,[Andy_Burgess],[Andy_Burgess],,,,,,
+cichild-lm,1523,udp,cichild,[Andy_Burgess],[Andy_Burgess],,,,,,
+ingreslock,1524,tcp,ingres,,,,,,,,
+ingreslock,1524,udp,ingres,,,,,,,,
+orasrv,1525,tcp,oracle,,,,,,,,
+orasrv,1525,udp,oracle,,,,,,,,
+prospero-np,1525,tcp,Prospero Directory Service non-priv,,,,,,,,
+prospero-np,1525,udp,Prospero Directory Service non-priv,,,,,,,,
+pdap-np,1526,tcp,Prospero Data Access Prot non-priv,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,,
+pdap-np,1526,udp,Prospero Data Access Prot non-priv,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,,
+tlisrv,1527,tcp,oracle,,,,,,,,
+tlisrv,1527,udp,oracle,,,,,,,,
+,1528,,Unassigned,,,,2007-10-04,,,,
+coauthor,1529,tcp,oracle,,,,,,,,
+coauthor,1529,udp,oracle,,,,,,,,
+rap-service,1530,tcp,rap-service,,,,,,,,
+rap-service,1530,udp,rap-service,,,,,,,,
+rap-listen,1531,tcp,rap-listen,[Phil_Servita],[Phil_Servita],,,,,,
+rap-listen,1531,udp,rap-listen,[Phil_Servita],[Phil_Servita],,,,,,
+miroconnect,1532,tcp,miroconnect,[Michael_Fischer_2],[Michael_Fischer_2],,,,,,
+miroconnect,1532,udp,miroconnect,[Michael_Fischer_2],[Michael_Fischer_2],,,,,,
+virtual-places,1533,tcp,Virtual Places Software,[Avshalom_Houri],[Avshalom_Houri],,,,,,
+virtual-places,1533,udp,Virtual Places Software,[Avshalom_Houri],[Avshalom_Houri],,,,,,
+micromuse-lm,1534,tcp,micromuse-lm,[Adam_Kerrison],[Adam_Kerrison],,,,,,
+micromuse-lm,1534,udp,micromuse-lm,[Adam_Kerrison],[Adam_Kerrison],,,,,,
+ampr-info,1535,tcp,ampr-info,,,,,,,,
+ampr-info,1535,udp,ampr-info,,,,,,,,
+ampr-inter,1536,tcp,ampr-inter,[Rob_Janssen],[Rob_Janssen],,,,,,
+ampr-inter,1536,udp,ampr-inter,[Rob_Janssen],[Rob_Janssen],,,,,,
+sdsc-lm,1537,tcp,isi-lm,[Len_Wanger],[Len_Wanger],,,,,,
+sdsc-lm,1537,udp,isi-lm,[Len_Wanger],[Len_Wanger],,,,,,
+3ds-lm,1538,tcp,3ds-lm,[Keith_Trummel],[Keith_Trummel],,,,,,
+3ds-lm,1538,udp,3ds-lm,[Keith_Trummel],[Keith_Trummel],,,,,,
+intellistor-lm,1539,tcp,Intellistor License Manager,[Ron_Vaughn],[Ron_Vaughn],,,,,,
+intellistor-lm,1539,udp,Intellistor License Manager,[Ron_Vaughn],[Ron_Vaughn],,,,,,
+rds,1540,tcp,rds,,,,,,,,
+rds,1540,udp,rds,,,,,,,,
+rds2,1541,tcp,rds2,[Sudhakar_Rajamannar],[Sudhakar_Rajamannar],,,,,,
+rds2,1541,udp,rds2,[Sudhakar_Rajamannar],[Sudhakar_Rajamannar],,,,,,
+gridgen-elmd,1542,tcp,gridgen-elmd,[John_R_Chawner],[John_R_Chawner],,,,,,
+gridgen-elmd,1542,udp,gridgen-elmd,[John_R_Chawner],[John_R_Chawner],,,,,,
+simba-cs,1543,tcp,simba-cs,[Betsy_Alexander],[Betsy_Alexander],,,,,,
+simba-cs,1543,udp,simba-cs,[Betsy_Alexander],[Betsy_Alexander],,,,,,
+aspeclmd,1544,tcp,aspeclmd,[V_Balaji],[V_Balaji],,,,,,
+aspeclmd,1544,udp,aspeclmd,[V_Balaji],[V_Balaji],,,,,,
+vistium-share,1545,tcp,vistium-share,[Allison_Carleton],[Allison_Carleton],,,,,,
+vistium-share,1545,udp,vistium-share,[Allison_Carleton],[Allison_Carleton],,,,,,
+abbaccuray,1546,tcp,abbaccuray,[John_Wendt],[John_Wendt],,,,,,
+abbaccuray,1546,udp,abbaccuray,[John_Wendt],[John_Wendt],,,,,,
+laplink,1547,tcp,laplink,[Michael_Crawford],[Michael_Crawford],,,,,,
+laplink,1547,udp,laplink,[Michael_Crawford],[Michael_Crawford],,,,,,
+axon-lm,1548,tcp,Axon License Manager,[Mark_Pearce],[Mark_Pearce],,,,,,
+axon-lm,1548,udp,Axon License Manager,[Mark_Pearce],[Mark_Pearce],,,,,,
+shivahose,1549,tcp,Shiva Hose,,,,,,,,
+shivasound,1549,udp,Shiva Sound,[Kin_Chan],[Kin_Chan],,,,,,
+3m-image-lm,1550,tcp,Image Storage license manager 3M Company,[J_C_Canessa],[J_C_Canessa],,,,,,
+3m-image-lm,1550,udp,Image Storage license manager 3M Company,[J_C_Canessa],[J_C_Canessa],,,,,,
+hecmtl-db,1551,tcp,HECMTL-DB,[Maxime_Belanger],[Maxime_Belanger],,,,,,
+hecmtl-db,1551,udp,HECMTL-DB,[Maxime_Belanger],[Maxime_Belanger],,,,,,
+pciarray,1552,tcp,pciarray,[Ron_Folk],[Ron_Folk],,,,,,
+pciarray,1552,udp,pciarray,[Ron_Folk],[Ron_Folk],,,,,,
+sna-cs,1553,tcp,sna-cs,[Tony_Sowter],[Tony_Sowter],,,,,,
+sna-cs,1553,udp,sna-cs,[Tony_Sowter],[Tony_Sowter],,,,,,
+caci-lm,1554,tcp,CACI Products Company License Manager,[Erik_Blume],[Erik_Blume],,,,,,
+caci-lm,1554,udp,CACI Products Company License Manager,[Erik_Blume],[Erik_Blume],,,,,,
+livelan,1555,tcp,livelan,[Kaynam_Hedayat],[Kaynam_Hedayat],,,,,,
+livelan,1555,udp,livelan,[Kaynam_Hedayat],[Kaynam_Hedayat],,,,,,
+veritas-pbx,1556,tcp,"VERITAS Private Branch Exchange
+IANA assigned this well-formed service name as a replacement for ""veritas_pbx"".",[Stefan_Winkel],[Stefan_Winkel],2004-04,,,,,
+veritas_pbx,1556,tcp,VERITAS Private Branch Exchange,[Stefan_Winkel],[Stefan_Winkel],2004-04,,,,,"This entry is an alias to ""veritas-pbx"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+veritas-pbx,1556,udp,"VERITAS Private Branch Exchange
+IANA assigned this well-formed service name as a replacement for ""veritas_pbx"".",[Stefan_Winkel],[Stefan_Winkel],2004-04,,,,,
+veritas_pbx,1556,udp,VERITAS Private Branch Exchange,[Stefan_Winkel],[Stefan_Winkel],2004-04,,,,,"This entry is an alias to ""veritas-pbx"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+arbortext-lm,1557,tcp,ArborText License Manager,[David_J_Wilson],[David_J_Wilson],,,,,,
+arbortext-lm,1557,udp,ArborText License Manager,[David_J_Wilson],[David_J_Wilson],,,,,,
+xingmpeg,1558,tcp,xingmpeg,[Howard_Gordon],[Howard_Gordon],,,,,,
+xingmpeg,1558,udp,xingmpeg,[Howard_Gordon],[Howard_Gordon],,,,,,
+web2host,1559,tcp,web2host,[Stephen_Johnson],[Stephen_Johnson],,,,,,
+web2host,1559,udp,web2host,[Stephen_Johnson],[Stephen_Johnson],,,,,,
+asci-val,1560,tcp,ASCI-RemoteSHADOW,[Benjamin_Rosenberg],[Benjamin_Rosenberg],,,,,,
+asci-val,1560,udp,ASCI-RemoteSHADOW,[Benjamin_Rosenberg],[Benjamin_Rosenberg],,,,,,
+facilityview,1561,tcp,facilityview,[Ed_Green],[Ed_Green],,,,,,
+facilityview,1561,udp,facilityview,[Ed_Green],[Ed_Green],,,,,,
+pconnectmgr,1562,tcp,pconnectmgr,[Bob_Kaiser],[Bob_Kaiser],,,,,,
+pconnectmgr,1562,udp,pconnectmgr,[Bob_Kaiser],[Bob_Kaiser],,,,,,
+cadabra-lm,1563,tcp,Cadabra License Manager,[Arthur_Castonguay],[Arthur_Castonguay],,,,,,
+cadabra-lm,1563,udp,Cadabra License Manager,[Arthur_Castonguay],[Arthur_Castonguay],,,,,,
+pay-per-view,1564,tcp,Pay-Per-View,[Brian_Tung],[Brian_Tung],,,,,,
+pay-per-view,1564,udp,Pay-Per-View,[Brian_Tung],[Brian_Tung],,,,,,
+winddlb,1565,tcp,WinDD,[Kelly_Sims],[Kelly_Sims],,,,,,
+winddlb,1565,udp,WinDD,[Kelly_Sims],[Kelly_Sims],,,,,,
+corelvideo,1566,tcp,CORELVIDEO,[Ming_Poon],[Ming_Poon],,,,,,
+corelvideo,1566,udp,CORELVIDEO,[Ming_Poon],[Ming_Poon],,,,,,
+jlicelmd,1567,tcp,jlicelmd,[Christian_Schormann],[Christian_Schormann],,,,,,
+jlicelmd,1567,udp,jlicelmd,[Christian_Schormann],[Christian_Schormann],,,,,,
+tsspmap,1568,tcp,tsspmap,[Paul_W_Nelson],[Paul_W_Nelson],,,,,,
+tsspmap,1568,udp,tsspmap,[Paul_W_Nelson],[Paul_W_Nelson],,,,,,
+ets,1569,tcp,ets,[Carstein_Seeberg],[Carstein_Seeberg],,,,,,
+ets,1569,udp,ets,[Carstein_Seeberg],[Carstein_Seeberg],,,,,,
+orbixd,1570,tcp,orbixd,[Bridget_Walsh],[Bridget_Walsh],,,,,,
+orbixd,1570,udp,orbixd,[Bridget_Walsh],[Bridget_Walsh],,,,,,
+rdb-dbs-disp,1571,tcp,Oracle Remote Data Base,[mackin],[mackin],,,,,,
+rdb-dbs-disp,1571,udp,Oracle Remote Data Base,[mackin],[mackin],,,,,,
+chip-lm,1572,tcp,Chipcom License Manager,,,,,,,,
+chip-lm,1572,udp,Chipcom License Manager,,,,,,,,
+itscomm-ns,1573,tcp,itscomm-ns,[Rich_Thompson],[Rich_Thompson],,,,,,
+itscomm-ns,1573,udp,itscomm-ns,[Rich_Thompson],[Rich_Thompson],,,,,,
+mvel-lm,1574,tcp,mvel-lm,[David_Bisset],[David_Bisset],,,,,,
+mvel-lm,1574,udp,mvel-lm,[David_Bisset],[David_Bisset],,,,,,
+oraclenames,1575,tcp,oraclenames,[P_V_Shivkumar],[P_V_Shivkumar],,,,,,
+oraclenames,1575,udp,oraclenames,[P_V_Shivkumar],[P_V_Shivkumar],,,,,,
+moldflow-lm,1576,tcp,Moldflow License Manager,[Lech_Laskowski],[Lech_Laskowski],,,,,,
+moldflow-lm,1576,udp,Moldflow License Manager,[Lech_Laskowski],[Lech_Laskowski],,,,,,
+hypercube-lm,1577,tcp,hypercube-lm,[Christopher_McLendon],[Christopher_McLendon],,,,,,
+hypercube-lm,1577,udp,hypercube-lm,[Christopher_McLendon],[Christopher_McLendon],,,,,,
+jacobus-lm,1578,tcp,Jacobus License Manager,[Tony_Cleveland],[Tony_Cleveland],,,,,,
+jacobus-lm,1578,udp,Jacobus License Manager,[Tony_Cleveland],[Tony_Cleveland],,,,,,
+ioc-sea-lm,1579,tcp,ioc-sea-lm,[Paul_Nelson],[Paul_Nelson],,,,,,
+ioc-sea-lm,1579,udp,ioc-sea-lm,[Paul_Nelson],[Paul_Nelson],,,,,,
+tn-tl-r1,1580,tcp,tn-tl-r1,,,,,,,,
+tn-tl-r2,1580,udp,tn-tl-r2,[Ed_Kress],[Ed_Kress],,,,,,
+mil-2045-47001,1581,tcp,MIL-2045-47001,[Eric_Whitehill],[Eric_Whitehill],,,,,,
+mil-2045-47001,1581,udp,MIL-2045-47001,[Eric_Whitehill],[Eric_Whitehill],,,,,,
+msims,1582,tcp,MSIMS,[Glenn_Olander],[Glenn_Olander],,,,,,
+msims,1582,udp,MSIMS,[Glenn_Olander],[Glenn_Olander],,,,,,
+simbaexpress,1583,tcp,simbaexpress,[Betsy_Alexander],[Betsy_Alexander],,,,,,
+simbaexpress,1583,udp,simbaexpress,[Betsy_Alexander],[Betsy_Alexander],,,,,,
+tn-tl-fd2,1584,tcp,tn-tl-fd2,[Ed_Kress],[Ed_Kress],,,,,,
+tn-tl-fd2,1584,udp,tn-tl-fd2,[Ed_Kress],[Ed_Kress],,,,,,
+intv,1585,tcp,intv,[Dermot_Tynand],[Dermot_Tynand],,,,,,
+intv,1585,udp,intv,[Dermot_Tynand],[Dermot_Tynand],,,,,,
+ibm-abtact,1586,tcp,ibm-abtact,[Sandeep_K_Singhal],[Sandeep_K_Singhal],,,,,,
+ibm-abtact,1586,udp,ibm-abtact,[Sandeep_K_Singhal],[Sandeep_K_Singhal],,,,,,
+pra-elmd,1587,tcp,"pra_elmd
+IANA assigned this well-formed service name as a replacement for ""pra_elmd"".",[Dennis_Mastin],[Dennis_Mastin],,,,,,
+pra_elmd,1587,tcp,pra_elmd,[Dennis_Mastin],[Dennis_Mastin],,,,,,"This entry is an alias to ""pra-elmd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+pra-elmd,1587,udp,"pra_elmd
+IANA assigned this well-formed service name as a replacement for ""pra_elmd"".",[Dennis_Mastin],[Dennis_Mastin],,,,,,
+pra_elmd,1587,udp,pra_elmd,[Dennis_Mastin],[Dennis_Mastin],,,,,,"This entry is an alias to ""pra-elmd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+triquest-lm,1588,tcp,triquest-lm,[Nand_Kumar],[Nand_Kumar],,,,,,
+triquest-lm,1588,udp,triquest-lm,[Nand_Kumar],[Nand_Kumar],,,,,,
+vqp,1589,tcp,VQP,[Keith_McCloghrie],[Keith_McCloghrie],,,,,,
+vqp,1589,udp,VQP,[Keith_McCloghrie],[Keith_McCloghrie],,,,,,
+gemini-lm,1590,tcp,gemini-lm,[Tony_Sawyer],[Tony_Sawyer],,,,,,
+gemini-lm,1590,udp,gemini-lm,[Tony_Sawyer],[Tony_Sawyer],,,,,,
+ncpm-pm,1591,tcp,ncpm-pm,[Ted_Power],[Ted_Power],,,,,,
+ncpm-pm,1591,udp,ncpm-pm,[Ted_Power],[Ted_Power],,,,,,
+commonspace,1592,tcp,commonspace,[Rob_Chandhok_2],[Rob_Chandhok_2],,,,,,
+commonspace,1592,udp,commonspace,[Rob_Chandhok_2],[Rob_Chandhok_2],,,,,,
+mainsoft-lm,1593,tcp,mainsoft-lm,[Anand_Gangadharan],[Anand_Gangadharan],,,,,,
+mainsoft-lm,1593,udp,mainsoft-lm,[Anand_Gangadharan],[Anand_Gangadharan],,,,,,
+sixtrak,1594,tcp,sixtrak,[Red_Lion_Controls],[Denis_Aull],,2014-09-22,,,,
+sixtrak,1594,udp,sixtrak,[Red_Lion_Controls],[Denis_Aull],,2014-09-22,,,,
+radio,1595,tcp,radio,,,,,,,,
+radio,1595,udp,radio,,,,,,,,
+radio-sm,1596,tcp,radio-sm,,,,,,,,
+radio-bc,1596,udp,radio-bc,[Ken_Chapman],[Ken_Chapman],,,,,,
+orbplus-iiop,1597,tcp,orbplus-iiop,[Robert_A_Kukura],[Robert_A_Kukura],,,,,,
+orbplus-iiop,1597,udp,orbplus-iiop,[Robert_A_Kukura],[Robert_A_Kukura],,,,,,
+picknfs,1598,tcp,picknfs,[John_Lombardo],[John_Lombardo],,,,,,
+picknfs,1598,udp,picknfs,[John_Lombardo],[John_Lombardo],,,,,,
+simbaservices,1599,tcp,simbaservices,[Betsy_Alexander],[Betsy_Alexander],,,,,,
+simbaservices,1599,udp,simbaservices,[Betsy_Alexander],[Betsy_Alexander],,,,,,
+issd,1600,tcp,issd,,,,,,,,
+issd,1600,udp,issd,,,,,,,,
+aas,1601,tcp,aas,[Bob_Beard],[Bob_Beard],,,,,,
+aas,1601,udp,aas,[Bob_Beard],[Bob_Beard],,,,,,
+inspect,1602,tcp,inspect,[Frank_O_Neill],[Frank_O_Neill],,,,,,
+inspect,1602,udp,inspect,[Frank_O_Neill],[Frank_O_Neill],,,,,,
+picodbc,1603,tcp,pickodbc,[John_Lombardo],[John_Lombardo],,,,,,
+picodbc,1603,udp,pickodbc,[John_Lombardo],[John_Lombardo],,,,,,
+icabrowser,1604,tcp,icabrowser,[Brad_Pedersen],[Brad_Pedersen],,,,,,
+icabrowser,1604,udp,icabrowser,[Brad_Pedersen],[Brad_Pedersen],,,,,,
+slp,1605,tcp,Salutation Manager (Salutation Protocol),,,,,,,,
+slp,1605,udp,Salutation Manager (Salutation Protocol),,,,,,,,
+slm-api,1606,tcp,Salutation Manager (SLM-API),[Tohru_Mori],[Tohru_Mori],,,,,,
+slm-api,1606,udp,Salutation Manager (SLM-API),[Tohru_Mori],[Tohru_Mori],,,,,,
+stt,1607,tcp,stt,[Ryan_Bolz],[Ryan_Bolz],,,,,,
+stt,1607,udp,stt,[Ryan_Bolz],[Ryan_Bolz],,,,,,
+smart-lm,1608,tcp,Smart Corp. License Manager,[Connie_Qiu],[Connie_Qiu],,,,,,
+smart-lm,1608,udp,Smart Corp. License Manager,[Connie_Qiu],[Connie_Qiu],,,,,,
+isysg-lm,1609,tcp,isysg-lm,[Adam_Curtin],[Adam_Curtin],,,,,,
+isysg-lm,1609,udp,isysg-lm,[Adam_Curtin],[Adam_Curtin],,,,,,
+taurus-wh,1610,tcp,taurus-wh,[Jeff_Moffatt],[Jeff_Moffatt],,,,,,
+taurus-wh,1610,udp,taurus-wh,[Jeff_Moffatt],[Jeff_Moffatt],,,,,,
+ill,1611,tcp,Inter Library Loan,[Niall_Murphy],[Niall_Murphy],,,,,,
+ill,1611,udp,Inter Library Loan,[Niall_Murphy],[Niall_Murphy],,,,,,
+netbill-trans,1612,tcp,NetBill Transaction Server,,,,,,,,
+netbill-trans,1612,udp,NetBill Transaction Server,,,,,,,,
+netbill-keyrep,1613,tcp,NetBill Key Repository,,,,,,,,
+netbill-keyrep,1613,udp,NetBill Key Repository,,,,,,,,
+netbill-cred,1614,tcp,NetBill Credential Server,,,,,,,,
+netbill-cred,1614,udp,NetBill Credential Server,,,,,,,,
+netbill-auth,1615,tcp,NetBill Authorization Server,,,,,,,,
+netbill-auth,1615,udp,NetBill Authorization Server,,,,,,,,
+netbill-prod,1616,tcp,NetBill Product Server,[Marvin_Sirbu],[Marvin_Sirbu],,,,,,
+netbill-prod,1616,udp,NetBill Product Server,[Marvin_Sirbu],[Marvin_Sirbu],,,,,,
+nimrod-agent,1617,tcp,Nimrod Inter-Agent Communication,[Charles_Lynn],[Charles_Lynn],,,,,,
+nimrod-agent,1617,udp,Nimrod Inter-Agent Communication,[Charles_Lynn],[Charles_Lynn],,,,,,
+skytelnet,1618,tcp,skytelnet,[Byron_Jones],[Byron_Jones],,,,,,
+skytelnet,1618,udp,skytelnet,[Byron_Jones],[Byron_Jones],,,,,,
+xs-openstorage,1619,tcp,xs-openstorage,[XuiS_Software_Ltd],[XuiS_Software_Ltd],,,,,,
+xs-openstorage,1619,udp,xs-openstorage,[XuiS_Software_Ltd],[XuiS_Software_Ltd],,,,,,
+faxportwinport,1620,tcp,faxportwinport,[Chris_Wells],[Chris_Wells],,,,,,
+faxportwinport,1620,udp,faxportwinport,[Chris_Wells],[Chris_Wells],,,,,,
+softdataphone,1621,tcp,softdataphone,[Dror_Gill],[Dror_Gill],,,,,,
+softdataphone,1621,udp,softdataphone,[Dror_Gill],[Dror_Gill],,,,,,
+ontime,1622,tcp,ontime,[Keith_Rhodes],[Keith_Rhodes],,,,,,
+ontime,1622,udp,ontime,[Keith_Rhodes],[Keith_Rhodes],,,,,,
+jaleosnd,1623,tcp,jaleosnd,[Christian_Schormann],[Christian_Schormann],,,,,,
+jaleosnd,1623,udp,jaleosnd,[Christian_Schormann],[Christian_Schormann],,,,,,
+udp-sr-port,1624,tcp,udp-sr-port,[Herb_Jensen],[Herb_Jensen],,,,,,
+udp-sr-port,1624,udp,udp-sr-port,[Herb_Jensen],[Herb_Jensen],,,,,,
+svs-omagent,1625,tcp,svs-omagent,[Alberto_Berlen],[Alberto_Berlen],,,,,,
+svs-omagent,1625,udp,svs-omagent,[Alberto_Berlen],[Alberto_Berlen],,,,,,
+shockwave,1626,tcp,Shockwave,[Sarah_Allen],[Sarah_Allen],,,,,,
+shockwave,1626,udp,Shockwave,[Sarah_Allen],[Sarah_Allen],,,,,,
+t128-gateway,1627,tcp,T.128 Gateway,[Phil_May],[Phil_May],,,,,,
+t128-gateway,1627,udp,T.128 Gateway,[Phil_May],[Phil_May],,,,,,
+lontalk-norm,1628,tcp,LonTalk normal,,,,,,,,
+lontalk-norm,1628,udp,LonTalk normal,,,,,,,,
+lontalk-urgnt,1629,tcp,LonTalk urgent,[Bob_Dolin],[Bob_Dolin],2008-04-10,,,,,
+lontalk-urgnt,1629,udp,LonTalk urgent,[Bob_Dolin],[Bob_Dolin],2008-04-10,,,,,
+oraclenet8cman,1630,tcp,Oracle Net8 Cman,[Tong_Ming_Lee],[Tong_Ming_Lee],,,,,,
+oraclenet8cman,1630,udp,Oracle Net8 Cman,[Tong_Ming_Lee],[Tong_Ming_Lee],,,,,,
+visitview,1631,tcp,Visit view,[Tom_Whittaker],[Tom_Whittaker],,,,,,
+visitview,1631,udp,Visit view,[Tom_Whittaker],[Tom_Whittaker],,,,,,
+pammratc,1632,tcp,PAMMRATC,,,,,,,,
+pammratc,1632,udp,PAMMRATC,,,,,,,,
+pammrpc,1633,tcp,PAMMRPC,[John_Britton],[John_Britton],,,,,,
+pammrpc,1633,udp,PAMMRPC,[John_Britton],[John_Britton],,,,,,
+loaprobe,1634,tcp,Log On America Probe,[James_Tavares],[James_Tavares],,,,,,
+loaprobe,1634,udp,Log On America Probe,[James_Tavares],[James_Tavares],,,,,,
+edb-server1,1635,tcp,EDB Server 1,[Carlos_Portela],[Carlos_Portela],,,,,,
+edb-server1,1635,udp,EDB Server 1,[Carlos_Portela],[Carlos_Portela],,,,,,
+isdc,1636,tcp,ISP shared public data control,,,,,,,,
+isdc,1636,udp,ISP shared public data control,,,,,,,,
+islc,1637,tcp,ISP shared local data control,,,,,,,,
+islc,1637,udp,ISP shared local data control,,,,,,,,
+ismc,1638,tcp,ISP shared management control,[Nick_Austin],[Nick_Austin],,,,,,
+ismc,1638,udp,ISP shared management control,[Nick_Austin],[Nick_Austin],,,,,,
+cert-initiator,1639,tcp,cert-initiator,,,,,,,,
+cert-initiator,1639,udp,cert-initiator,,,,,,,,
+cert-responder,1640,tcp,cert-responder,[Tom_Markson],[Tom_Markson],,,,,,
+cert-responder,1640,udp,cert-responder,[Tom_Markson],[Tom_Markson],,,,,,
+invision,1641,tcp,InVision,[Christopher_Davey],[Christopher_Davey],,,,,,
+invision,1641,udp,InVision,[Christopher_Davey],[Christopher_Davey],,,,,,
+isis-am,1642,tcp,isis-am,,,,,,,,
+isis-am,1642,udp,isis-am,,,,,,,,
+isis-ambc,1643,tcp,isis-ambc,[Ken_Chapman],[Ken_Chapman],,,,,,
+isis-ambc,1643,udp,isis-ambc,[Ken_Chapman],[Ken_Chapman],,,,,,
+saiseh,1644,tcp,Satellite-data Acquisition System 4,[Bill_Taylor],[Bill_Taylor],,,,,,
+saiseh,1644,udp,Satellite-data Acquisition System 4,[Bill_Taylor],[Bill_Taylor],,,,,,
+sightline,1645,tcp,SightLine,[admin],[admin],,,,,,
+sightline,1645,udp,SightLine,[admin],[admin],,,,,,
+sa-msg-port,1646,tcp,sa-msg-port,[Eric_Whitehill],[Eric_Whitehill],,,,,,
+sa-msg-port,1646,udp,sa-msg-port,[Eric_Whitehill],[Eric_Whitehill],,,,,,
+rsap,1647,tcp,rsap,[Holger_Reif],[Holger_Reif],,,,,,
+rsap,1647,udp,rsap,[Holger_Reif],[Holger_Reif],,,,,,
+concurrent-lm,1648,tcp,concurrent-lm,[Maggie_Brinsford],[Maggie_Brinsford],,,,,,
+concurrent-lm,1648,udp,concurrent-lm,[Maggie_Brinsford],[Maggie_Brinsford],,,,,,
+kermit,1649,tcp,kermit,[Frank_da_Cruz],[Frank_da_Cruz],,,,,,
+kermit,1649,udp,kermit,[Frank_da_Cruz],[Frank_da_Cruz],,,,,,
+nkd,1650,tcp,nkdn,,,,,,,,
+nkd,1650,udp,nkd,,,,,,,,
+shiva-confsrvr,1651,tcp,"shiva_confsrvr
+IANA assigned this well-formed service name as a replacement for ""shiva_confsrvr"".",[Mike_Horowitz],[Mike_Horowitz],,,,,,
+shiva_confsrvr,1651,tcp,shiva_confsrvr,[Mike_Horowitz],[Mike_Horowitz],,,,,,"This entry is an alias to ""shiva-confsrvr"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+shiva-confsrvr,1651,udp,"shiva_confsrvr
+IANA assigned this well-formed service name as a replacement for ""shiva_confsrvr"".",[Mike_Horowitz],[Mike_Horowitz],,,,,,
+shiva_confsrvr,1651,udp,shiva_confsrvr,[Mike_Horowitz],[Mike_Horowitz],,,,,,"This entry is an alias to ""shiva-confsrvr"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+xnmp,1652,tcp,xnmp,[Ali_Saleh],[Ali_Saleh],,,,,,
+xnmp,1652,udp,xnmp,[Ali_Saleh],[Ali_Saleh],,,,,,
+alphatech-lm,1653,tcp,alphatech-lm,[Joseph_Hauk],[Joseph_Hauk],,,,,,
+alphatech-lm,1653,udp,alphatech-lm,[Joseph_Hauk],[Joseph_Hauk],,,,,,
+stargatealerts,1654,tcp,stargatealerts,[Tim_Coppernoll],[Tim_Coppernoll],,,,,,
+stargatealerts,1654,udp,stargatealerts,[Tim_Coppernoll],[Tim_Coppernoll],,,,,,
+dec-mbadmin,1655,tcp,dec-mbadmin,,,,,,,,
+dec-mbadmin,1655,udp,dec-mbadmin,,,,,,,,
+dec-mbadmin-h,1656,tcp,dec-mbadmin-h,[Nick_Shipman],[Nick_Shipman],,,,,,
+dec-mbadmin-h,1656,udp,dec-mbadmin-h,[Nick_Shipman],[Nick_Shipman],,,,,,
+fujitsu-mmpdc,1657,tcp,fujitsu-mmpdc,[Katsumi_Oomuro],[Katsumi_Oomuro],,,,,,
+fujitsu-mmpdc,1657,udp,fujitsu-mmpdc,[Katsumi_Oomuro],[Katsumi_Oomuro],,,,,,
+sixnetudr,1658,tcp,sixnetudr,[Red_Lion_Controls],[Denis_Aull],,2014-05-21,,,,
+sixnetudr,1658,udp,sixnetudr,[Red_Lion_Controls],[Denis_Aull],,2014-05-21,,,,
+sg-lm,1659,tcp,Silicon Grail License Manager,[William_R_Bishop],[William_R_Bishop],,,,,,
+sg-lm,1659,udp,Silicon Grail License Manager,[William_R_Bishop],[William_R_Bishop],,,,,,
+skip-mc-gikreq,1660,tcp,skip-mc-gikreq,[Tom_Markson],[Tom_Markson],,,,,,
+skip-mc-gikreq,1660,udp,skip-mc-gikreq,[Tom_Markson],[Tom_Markson],,,,,,
+netview-aix-1,1661,tcp,netview-aix-1,,,,,,,,
+netview-aix-1,1661,udp,netview-aix-1,,,,,,,,
+netview-aix-2,1662,tcp,netview-aix-2,,,,,,,,
+netview-aix-2,1662,udp,netview-aix-2,,,,,,,,
+netview-aix-3,1663,tcp,netview-aix-3,,,,,,,,
+netview-aix-3,1663,udp,netview-aix-3,,,,,,,,
+netview-aix-4,1664,tcp,netview-aix-4,,,,,,,,
+netview-aix-4,1664,udp,netview-aix-4,,,,,,,,
+netview-aix-5,1665,tcp,netview-aix-5,,,,,,,,
+netview-aix-5,1665,udp,netview-aix-5,,,,,,,,
+netview-aix-6,1666,tcp,netview-aix-6,,,,,,,,
+netview-aix-6,1666,udp,netview-aix-6,,,,,,,,
+netview-aix-7,1667,tcp,netview-aix-7,,,,,,,,
+netview-aix-7,1667,udp,netview-aix-7,,,,,,,,
+netview-aix-8,1668,tcp,netview-aix-8,,,,,,,,
+netview-aix-8,1668,udp,netview-aix-8,,,,,,,,
+netview-aix-9,1669,tcp,netview-aix-9,,,,,,,,
+netview-aix-9,1669,udp,netview-aix-9,,,,,,,,
+netview-aix-10,1670,tcp,netview-aix-10,,,,,,,,
+netview-aix-10,1670,udp,netview-aix-10,,,,,,,,
+netview-aix-11,1671,tcp,netview-aix-11,,,,,,,,
+netview-aix-11,1671,udp,netview-aix-11,,,,,,,,
+netview-aix-12,1672,tcp,netview-aix-12,[Martha_Crisson],[Martha_Crisson],,,,,,
+netview-aix-12,1672,udp,netview-aix-12,[Martha_Crisson],[Martha_Crisson],,,,,,
+proshare-mc-1,1673,tcp,Intel Proshare Multicast,,,,,,,,
+proshare-mc-1,1673,udp,Intel Proshare Multicast,,,,,,,,
+proshare-mc-2,1674,tcp,Intel Proshare Multicast,[Mark_Lewis],[Mark_Lewis],,,,,,
+proshare-mc-2,1674,udp,Intel Proshare Multicast,[Mark_Lewis],[Mark_Lewis],,,,,,
+pdp,1675,tcp,Pacific Data Products,[Gary_Morton],[Gary_Morton],,,,,,
+pdp,1675,udp,Pacific Data Products,[Gary_Morton],[Gary_Morton],,,,,,
+netcomm1,1676,tcp,netcomm1,,,,,,,,
+netcomm2,1676,udp,netcomm2,[Bulent_Kasman],[Bulent_Kasman],,,,,,
+groupwise,1677,tcp,groupwise,[Brent_Bradshaw],[Brent_Bradshaw],,,,,,
+groupwise,1677,udp,groupwise,[Brent_Bradshaw],[Brent_Bradshaw],,,,,,
+prolink,1678,tcp,prolink,[Brian_Abramson],[Brian_Abramson],,,,,,
+prolink,1678,udp,prolink,[Brian_Abramson],[Brian_Abramson],,,,,,
+darcorp-lm,1679,tcp,darcorp-lm,[DARcorp],[DARcorp],,,,,,
+darcorp-lm,1679,udp,darcorp-lm,[DARcorp],[DARcorp],,,,,,
+microcom-sbp,1680,tcp,microcom-sbp,[Boris_B_Maiden],[Boris_B_Maiden],,,,,,
+microcom-sbp,1680,udp,microcom-sbp,[Boris_B_Maiden],[Boris_B_Maiden],,,,,,
+sd-elmd,1681,tcp,sd-elmd,[Bryan_Otey],[Bryan_Otey],,,,,,
+sd-elmd,1681,udp,sd-elmd,[Bryan_Otey],[Bryan_Otey],,,,,,
+lanyon-lantern,1682,tcp,lanyon-lantern,[Robin_Lewis],[Robin_Lewis],,,,,,
+lanyon-lantern,1682,udp,lanyon-lantern,[Robin_Lewis],[Robin_Lewis],,,,,,
+ncpm-hip,1683,tcp,ncpm-hip,[Ken_Hearn],[Ken_Hearn],,,,,,
+ncpm-hip,1683,udp,ncpm-hip,[Ken_Hearn],[Ken_Hearn],,,,,,
+snaresecure,1684,tcp,SnareSecure,[Marty_Batchelder],[Marty_Batchelder],,,,,,
+snaresecure,1684,udp,SnareSecure,[Marty_Batchelder],[Marty_Batchelder],,,,,,
+n2nremote,1685,tcp,n2nremote,[Kin_Chan_2],[Kin_Chan_2],,,,,,
+n2nremote,1685,udp,n2nremote,[Kin_Chan_2],[Kin_Chan_2],,,,,,
+cvmon,1686,tcp,cvmon,[Carol_Ann_Krug],[Carol_Ann_Krug],,,,,,
+cvmon,1686,udp,cvmon,[Carol_Ann_Krug],[Carol_Ann_Krug],,,,,,
+nsjtp-ctrl,1687,tcp,nsjtp-ctrl,,,,,,,,
+nsjtp-ctrl,1687,udp,nsjtp-ctrl,,,,,,,,
+nsjtp-data,1688,tcp,nsjtp-data,[Orazio_Granato],[Orazio_Granato],,,,,,
+nsjtp-data,1688,udp,nsjtp-data,[Orazio_Granato],[Orazio_Granato],,,,,,
+firefox,1689,tcp,firefox,[Mark_S_Edwards],[Mark_S_Edwards],,,,,,
+firefox,1689,udp,firefox,[Mark_S_Edwards],[Mark_S_Edwards],,,,,,
+ng-umds,1690,tcp,ng-umds,[Louis_E_Simard],[Louis_E_Simard],,,,,,
+ng-umds,1690,udp,ng-umds,[Louis_E_Simard],[Louis_E_Simard],,,,,,
+empire-empuma,1691,tcp,empire-empuma,[Bobby_Krupczak],[Bobby_Krupczak],,,,,,
+empire-empuma,1691,udp,empire-empuma,[Bobby_Krupczak],[Bobby_Krupczak],,,,,,
+sstsys-lm,1692,tcp,sstsys-lm,[Yih_Wu_Wang],[Yih_Wu_Wang],,,,,,
+sstsys-lm,1692,udp,sstsys-lm,[Yih_Wu_Wang],[Yih_Wu_Wang],,,,,,
+rrirtr,1693,tcp,rrirtr,,,,,,,,
+rrirtr,1693,udp,rrirtr,,,,,,,,
+rrimwm,1694,tcp,rrimwm,,,,,,,,
+rrimwm,1694,udp,rrimwm,,,,,,,,
+rrilwm,1695,tcp,rrilwm,,,,,,,,
+rrilwm,1695,udp,rrilwm,,,,,,,,
+rrifmm,1696,tcp,rrifmm,,,,,,,,
+rrifmm,1696,udp,rrifmm,,,,,,,,
+rrisat,1697,tcp,rrisat,[Allen_Briggs],[Allen_Briggs],,,,,,
+rrisat,1697,udp,rrisat,[Allen_Briggs],[Allen_Briggs],,,,,,
+rsvp-encap-1,1698,tcp,RSVP-ENCAPSULATION-1,,,,,,,,
+rsvp-encap-1,1698,udp,RSVP-ENCAPSULATION-1,,,,,,,,
+rsvp-encap-2,1699,tcp,RSVP-ENCAPSULATION-2,[Bob_Braden_2],[Bob_Braden_2],,,,,,
+rsvp-encap-2,1699,udp,RSVP-ENCAPSULATION-2,[Bob_Braden_2],[Bob_Braden_2],,,,,,
+mps-raft,1700,tcp,mps-raft,[Jason_Leupen],[Jason_Leupen],,,,,,
+mps-raft,1700,udp,mps-raft,[Jason_Leupen],[Jason_Leupen],,,,,,
+l2f,1701,tcp,l2f,,,,,,,,
+l2f,1701,udp,l2f,,,,,,,,
+l2tp,1701,tcp,l2tp,[Andy_Valencia],[Andy_Valencia],,,,,,
+l2tp,1701,udp,l2tp,[Andy_Valencia],[Andy_Valencia],,,,,,
+deskshare,1702,tcp,deskshare,[Sarah_Thompson],[Sarah_Thompson],,,,,,
+deskshare,1702,udp,deskshare,[Sarah_Thompson],[Sarah_Thompson],,,,,,
+hb-engine,1703,tcp,hb-engine,[Charles_C_L_Chou],[Charles_C_L_Chou],,,,,,
+hb-engine,1703,udp,hb-engine,[Charles_C_L_Chou],[Charles_C_L_Chou],,,,,,
+bcs-broker,1704,tcp,bcs-broker,[Andy_Warner],[Andy_Warner],,,,,,
+bcs-broker,1704,udp,bcs-broker,[Andy_Warner],[Andy_Warner],,,,,,
+slingshot,1705,tcp,slingshot,[Paul_Groarke],[Paul_Groarke],,,,,,
+slingshot,1705,udp,slingshot,[Paul_Groarke],[Paul_Groarke],,,,,,
+jetform,1706,tcp,jetform,[gdeinsta],[gdeinsta],,,,,,
+jetform,1706,udp,jetform,[gdeinsta],[gdeinsta],,,,,,
+vdmplay,1707,tcp,vdmplay,[David_Thielen],[David_Thielen],,,,,,
+vdmplay,1707,udp,vdmplay,[David_Thielen],[David_Thielen],,,,,,
+gat-lmd,1708,tcp,gat-lmd,[Igor_Zaoutine],[Igor_Zaoutine],,,,,,
+gat-lmd,1708,udp,gat-lmd,[Igor_Zaoutine],[Igor_Zaoutine],,,,,,
+centra,1709,tcp,centra,[Drew_Wolff],[Drew_Wolff],,,,,,
+centra,1709,udp,centra,[Drew_Wolff],[Drew_Wolff],,,,,,
+impera,1710,tcp,impera,[Stepehen_Campbell],[Stepehen_Campbell],,,,,,
+impera,1710,udp,impera,[Stepehen_Campbell],[Stepehen_Campbell],,,,,,
+pptconference,1711,tcp,pptconference,[John_Tafoya],[John_Tafoya],,,,,,
+pptconference,1711,udp,pptconference,[John_Tafoya],[John_Tafoya],,,,,,
+registrar,1712,tcp,resource monitoring service,[Ron_Lawson],[Ron_Lawson],,,,,,
+registrar,1712,udp,resource monitoring service,[Ron_Lawson],[Ron_Lawson],,,,,,
+conferencetalk,1713,tcp,ConferenceTalk,[George_Kajos],[George_Kajos],,,,,,
+conferencetalk,1713,udp,ConferenceTalk,[George_Kajos],[George_Kajos],,,,,,
+sesi-lm,1714,tcp,sesi-lm,,,,,,,,
+sesi-lm,1714,udp,sesi-lm,,,,,,,,
+houdini-lm,1715,tcp,houdini-lm,[Paul_Breslin],[Paul_Breslin],,,,,,
+houdini-lm,1715,udp,houdini-lm,[Paul_Breslin],[Paul_Breslin],,,,,,
+xmsg,1716,tcp,xmsg,[Mark_E_Fogle],[Mark_E_Fogle],,,,,,
+xmsg,1716,udp,xmsg,[Mark_E_Fogle],[Mark_E_Fogle],,,,,,
+fj-hdnet,1717,tcp,fj-hdnet,[Manabu_Makino],[Manabu_Makino],,,,,,
+fj-hdnet,1717,udp,fj-hdnet,[Manabu_Makino],[Manabu_Makino],,,,,,
+h323gatedisc,1718,tcp,H.323 Multicast Gatekeeper Discover,[ITU-T],[ITU-T_TSB],,2013-01-31,,,,
+h323gatedisc,1718,udp,H.323 Multicast Gatekeeper Discover,[ITU-T],[ITU-T_TSB],,2013-01-31,,,,
+h323gatestat,1719,tcp,H.323 Unicast Gatekeeper Signaling,[ITU-T],[ITU-T_TSB],,2013-01-31,,,,
+h323gatestat,1719,udp,H.323 Unicast Gatekeeper Signaling,[ITU-T],[ITU-T_TSB],,2013-01-31,,,,
+h323hostcall,1720,tcp,H.323 Call Control Signalling,[ITU-T],[ITU-T_TSB],,2013-01-31,,,,
+h323hostcall,1720,udp,H.323 Call Control Signalling,[ITU-T],[ITU-T_TSB],,2013-01-31,,,,
+h323hostcall,1720,sctp,H.323 Call Control,[ITU-T],,2014-07-30,,,,,
+caicci,1721,tcp,caicci,[Sylvia_Scheuren],[Sylvia_Scheuren],,,,,,
+caicci,1721,udp,caicci,[Sylvia_Scheuren],[Sylvia_Scheuren],,,,,,
+hks-lm,1722,tcp,HKS License Manager,[Michael_Wood],[Michael_Wood],,,,,,
+hks-lm,1722,udp,HKS License Manager,[Michael_Wood],[Michael_Wood],,,,,,
+pptp,1723,tcp,pptp,[Ken_Crocker],[Ken_Crocker],,,,,,
+pptp,1723,udp,pptp,[Ken_Crocker],[Ken_Crocker],,,,,,
+csbphonemaster,1724,tcp,csbphonemaster,[Hans_Peter_Heffels],[Hans_Peter_Heffels],,,,,,
+csbphonemaster,1724,udp,csbphonemaster,[Hans_Peter_Heffels],[Hans_Peter_Heffels],,,,,,
+iden-ralp,1725,tcp,iden-ralp,[Chris_Stanaway],[Chris_Stanaway],,,,,,
+iden-ralp,1725,udp,iden-ralp,[Chris_Stanaway],[Chris_Stanaway],,,,,,
+iberiagames,1726,tcp,IBERIAGAMES,[Jose_Luis],[Jose_Luis],,,,,,
+iberiagames,1726,udp,IBERIAGAMES,[Jose_Luis],[Jose_Luis],,,,,,
+winddx,1727,tcp,winddx,[Bill_Andrews],[Bill_Andrews],,,,,,
+winddx,1727,udp,winddx,[Bill_Andrews],[Bill_Andrews],,,,,,
+telindus,1728,tcp,TELINDUS,[Paul_Pyck],[Paul_Pyck],,,,,,
+telindus,1728,udp,TELINDUS,[Paul_Pyck],[Paul_Pyck],,,,,,
+citynl,1729,tcp,CityNL License Management,[CityDisc],[CityDisc],,,,,,
+citynl,1729,udp,CityNL License Management,[CityDisc],[CityDisc],,,,,,
+roketz,1730,tcp,roketz,[Ahti_Heinla],[Ahti_Heinla],,,,,,
+roketz,1730,udp,roketz,[Ahti_Heinla],[Ahti_Heinla],,,,,,
+msiccp,1731,tcp,MSICCP,[Max_Morris],[Max_Morris],,,,,,
+msiccp,1731,udp,MSICCP,[Max_Morris],[Max_Morris],,,,,,
+proxim,1732,tcp,proxim,[Srinivas_N_Mogalapa],[Srinivas_N_Mogalapa],,,,,,
+proxim,1732,udp,proxim,[Srinivas_N_Mogalapa],[Srinivas_N_Mogalapa],,,,,,
+siipat,1733,tcp,SIMS - SIIPAT Protocol for Alarm Transmission,[Steve_Ryckman],[Steve_Ryckman],,,,,,
+siipat,1733,udp,SIMS - SIIPAT Protocol for Alarm Transmission,[Steve_Ryckman],[Steve_Ryckman],,,,,,
+cambertx-lm,1734,tcp,Camber Corporation License Management,[Jeannie_Burleson],[Jeannie_Burleson],,,,,,
+cambertx-lm,1734,udp,Camber Corporation License Management,[Jeannie_Burleson],[Jeannie_Burleson],,,,,,
+privatechat,1735,tcp,PrivateChat,[Louis_E_Simard],[Louis_E_Simard],,,,,,
+privatechat,1735,udp,PrivateChat,[Louis_E_Simard],[Louis_E_Simard],,,,,,
+street-stream,1736,tcp,street-stream,[Glenn_Levitt],[Glenn_Levitt],,,,,,
+street-stream,1736,udp,street-stream,[Glenn_Levitt],[Glenn_Levitt],,,,,,
+ultimad,1737,tcp,ultimad,[Michael_Lanzetta],[Michael_Lanzetta],,,,,,
+ultimad,1737,udp,ultimad,[Michael_Lanzetta],[Michael_Lanzetta],,,,,,
+gamegen1,1738,tcp,GameGen1,[Glen_Pearson],[Glen_Pearson],,,,,,
+gamegen1,1738,udp,GameGen1,[Glen_Pearson],[Glen_Pearson],,,,,,
+webaccess,1739,tcp,webaccess,[Christian_Saether],[Christian_Saether],,,,,,
+webaccess,1739,udp,webaccess,[Christian_Saether],[Christian_Saether],,,,,,
+encore,1740,tcp,encore,[Stuart_Button],[Stuart_Button],,,,,,
+encore,1740,udp,encore,[Stuart_Button],[Stuart_Button],,,,,,
+cisco-net-mgmt,1741,tcp,cisco-net-mgmt,[John_McCormack],[John_McCormack],,,,,,
+cisco-net-mgmt,1741,udp,cisco-net-mgmt,[John_McCormack],[John_McCormack],,,,,,
+3Com-nsd,1742,tcp,3Com-nsd,[Nitza_Steinberg],[Nitza_Steinberg],,,,,,
+3Com-nsd,1742,udp,3Com-nsd,[Nitza_Steinberg],[Nitza_Steinberg],,,,,,
+cinegrfx-lm,1743,tcp,Cinema Graphics License Manager,[Rodney_Iwashina],[Rodney_Iwashina],,,,,,
+cinegrfx-lm,1743,udp,Cinema Graphics License Manager,[Rodney_Iwashina],[Rodney_Iwashina],,,,,,
+ncpm-ft,1744,tcp,ncpm-ft,[Ken_Hearn],[Ken_Hearn],,,,,,
+ncpm-ft,1744,udp,ncpm-ft,[Ken_Hearn],[Ken_Hearn],,,,,,
+remote-winsock,1745,tcp,remote-winsock,[Avi_Nathan],[Avi_Nathan],,,,,,
+remote-winsock,1745,udp,remote-winsock,[Avi_Nathan],[Avi_Nathan],,,,,,
+ftrapid-1,1746,tcp,ftrapid-1,,,,,,,,
+ftrapid-1,1746,udp,ftrapid-1,,,,,,,,
+ftrapid-2,1747,tcp,ftrapid-2,[Richard_J_Williams],[Richard_J_Williams],,,,,,
+ftrapid-2,1747,udp,ftrapid-2,[Richard_J_Williams],[Richard_J_Williams],,,,,,
+oracle-em1,1748,tcp,oracle-em1,[Bob_Purvy],[Bob_Purvy],,,,,,
+oracle-em1,1748,udp,oracle-em1,[Bob_Purvy],[Bob_Purvy],,,,,,
+aspen-services,1749,tcp,aspen-services,[Mark_B_Hurst],[Mark_B_Hurst],,,,,,
+aspen-services,1749,udp,aspen-services,[Mark_B_Hurst],[Mark_B_Hurst],,,,,,
+sslp,1750,tcp,Simple Socket Library's PortMaster,[Dr_Charles_E_Campb],[Dr_Charles_E_Campb],,,,,,
+sslp,1750,udp,Simple Socket Library's PortMaster,[Dr_Charles_E_Campb],[Dr_Charles_E_Campb],,,,,,
+swiftnet,1751,tcp,SwiftNet,[Terry_Lim],[Terry_Lim],,,,,,
+swiftnet,1751,udp,SwiftNet,[Terry_Lim],[Terry_Lim],,,,,,
+lofr-lm,1752,tcp,Leap of Faith Research License Manager,,,,,,,,
+lofr-lm,1752,udp,Leap of Faith Research License Manager,,,,,,,,
+predatar-comms,1753,tcp,Predatar Comms Service,[Silverstring_Ltd],[Ronnie_De_Giorgio],2011-09-15,,,,,
+,1753,udp,Reserved,,,,,,,,
+oracle-em2,1754,tcp,oracle-em2,[Bob_Purvy],[Bob_Purvy],,,,,,
+oracle-em2,1754,udp,oracle-em2,[Bob_Purvy],[Bob_Purvy],,,,,,
+ms-streaming,1755,tcp,ms-streaming,[Bret_O_Rourke],[Bret_O_Rourke],,,,,,
+ms-streaming,1755,udp,ms-streaming,[Bret_O_Rourke],[Bret_O_Rourke],,,,,,
+capfast-lmd,1756,tcp,capfast-lmd,[Chuck_Neal],[Chuck_Neal],,,,,,
+capfast-lmd,1756,udp,capfast-lmd,[Chuck_Neal],[Chuck_Neal],,,,,,
+cnhrp,1757,tcp,cnhrp,[William_Stoye],[William_Stoye],,,,,,
+cnhrp,1757,udp,cnhrp,[William_Stoye],[William_Stoye],,,,,,
+tftp-mcast,1758,tcp,tftp-mcast,[Tom_Emberson],[Tom_Emberson],,,,,,
+tftp-mcast,1758,udp,tftp-mcast,[Tom_Emberson],[Tom_Emberson],,,,,,
+spss-lm,1759,tcp,SPSS License Manager,[Tex_Hull],[Tex_Hull],,,,,,
+spss-lm,1759,udp,SPSS License Manager,[Tex_Hull],[Tex_Hull],,,,,,
+www-ldap-gw,1760,tcp,www-ldap-gw,[Nick_Emery],[Nick_Emery],,,,,,
+www-ldap-gw,1760,udp,www-ldap-gw,[Nick_Emery],[Nick_Emery],,,,,,
+cft-0,1761,tcp,cft-0,[Martine_Marchand],[Martine_Marchand],,,,,,
+cft-0,1761,udp,cft-0,[Martine_Marchand],[Martine_Marchand],,,,,,
+cft-1,1762,tcp,cft-1,[Martine_Marchand],[Martine_Marchand],,,,,,
+cft-1,1762,udp,cft-1,[Martine_Marchand],[Martine_Marchand],,,,,,
+cft-2,1763,tcp,cft-2,[Martine_Marchand],[Martine_Marchand],,,,,,
+cft-2,1763,udp,cft-2,[Martine_Marchand],[Martine_Marchand],,,,,,
+cft-3,1764,tcp,cft-3,[Martine_Marchand],[Martine_Marchand],,,,,,
+cft-3,1764,udp,cft-3,[Martine_Marchand],[Martine_Marchand],,,,,,
+cft-4,1765,tcp,cft-4,[Martine_Marchand],[Martine_Marchand],,,,,,
+cft-4,1765,udp,cft-4,[Martine_Marchand],[Martine_Marchand],,,,,,
+cft-5,1766,tcp,cft-5,[Martine_Marchand],[Martine_Marchand],,,,,,
+cft-5,1766,udp,cft-5,[Martine_Marchand],[Martine_Marchand],,,,,,
+cft-6,1767,tcp,cft-6,[Martine_Marchand],[Martine_Marchand],,,,,,
+cft-6,1767,udp,cft-6,[Martine_Marchand],[Martine_Marchand],,,,,,
+cft-7,1768,tcp,cft-7,[Martine_Marchand],[Martine_Marchand],,,,,,
+cft-7,1768,udp,cft-7,[Martine_Marchand],[Martine_Marchand],,,,,,
+bmc-net-adm,1769,tcp,bmc-net-adm,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmc-net-adm,1769,udp,bmc-net-adm,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmc-net-svc,1770,tcp,bmc-net-svc,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmc-net-svc,1770,udp,bmc-net-svc,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+vaultbase,1771,tcp,vaultbase,[Jose_A_Sesin],[Jose_A_Sesin],,,,,,
+vaultbase,1771,udp,vaultbase,[Jose_A_Sesin],[Jose_A_Sesin],,,,,,
+essweb-gw,1772,tcp,EssWeb Gateway,[Bob_Nattenberg],[Bob_Nattenberg],,,,,,
+essweb-gw,1772,udp,EssWeb Gateway,[Bob_Nattenberg],[Bob_Nattenberg],,,,,,
+kmscontrol,1773,tcp,KMSControl,[Roy_Chastain],[Roy_Chastain],,,,,,
+kmscontrol,1773,udp,KMSControl,[Roy_Chastain],[Roy_Chastain],,,,,,
+global-dtserv,1774,tcp,global-dtserv,[Nicholas_Davies],[Nicholas_Davies],,,,,,
+global-dtserv,1774,udp,global-dtserv,[Nicholas_Davies],[Nicholas_Davies],,,,,,
+vdab,1775,tcp,data interchange between visual processing containers,[MJA_Technology_LLC],[Mark_J._App],2014-04-23,,,,,
+,1775,udp,Reserved,,,,,,,,
+femis,1776,tcp,Federal Emergency Management Information System,[Larry_Gerhardstein],[Larry_Gerhardstein],,,,,,
+femis,1776,udp,Federal Emergency Management Information System,[Larry_Gerhardstein],[Larry_Gerhardstein],,,,,,
+powerguardian,1777,tcp,powerguardian,[Charles_Bennett],[Charles_Bennett],2008-08-29,,,,,
+powerguardian,1777,udp,powerguardian,[Charles_Bennett],[Charles_Bennett],2008-08-29,,,,,
+prodigy-intrnet,1778,tcp,prodigy-internet,[Bob_Dedrick],[Bob_Dedrick],,,,,,
+prodigy-intrnet,1778,udp,prodigy-internet,[Bob_Dedrick],[Bob_Dedrick],,,,,,
+pharmasoft,1779,tcp,pharmasoft,[Ola_Strandberg],[Ola_Strandberg],,,,,,
+pharmasoft,1779,udp,pharmasoft,[Ola_Strandberg],[Ola_Strandberg],,,,,,
+dpkeyserv,1780,tcp,dpkeyserv,[Yasunari_Gon_Yamasit],[Yasunari_Gon_Yamasit],,,,,,
+dpkeyserv,1780,udp,dpkeyserv,[Yasunari_Gon_Yamasit],[Yasunari_Gon_Yamasit],,,,,,
+answersoft-lm,1781,tcp,answersoft-lm,[James_A_Brewster],[James_A_Brewster],,,,,,
+answersoft-lm,1781,udp,answersoft-lm,[James_A_Brewster],[James_A_Brewster],,,,,,
+hp-hcip,1782,tcp,hp-hcip,[Allen_Baker],[Allen_Baker],,,,,,
+hp-hcip,1782,udp,hp-hcip,[Allen_Baker],[Allen_Baker],,,,,,
+,1783,,"Decomissioned Port 04/14/00, ms",[naonao],[naonao],,,,,,
+finle-lm,1784,tcp,Finle License Manager,[Dongling_Wang],[Dongling_Wang],,,,,,
+finle-lm,1784,udp,Finle License Manager,[Dongling_Wang],[Dongling_Wang],,,,,,
+windlm,1785,tcp,Wind River Systems License Manager,[Will_Dere],[Will_Dere],,,,,,
+windlm,1785,udp,Wind River Systems License Manager,[Will_Dere],[Will_Dere],,,,,,
+funk-logger,1786,tcp,funk-logger,,,,,,,,
+funk-logger,1786,udp,funk-logger,,,,,,,,
+funk-license,1787,tcp,funk-license,[Cimarron_Boozer][Eric_Wilde],[Cimarron_Boozer][Eric_Wilde],,,,,,
+funk-license,1787,udp,funk-license,[Cimarron_Boozer][Eric_Wilde],[Cimarron_Boozer][Eric_Wilde],,,,,,
+psmond,1788,tcp,psmond,[Will_Golson],[Will_Golson],,,,,,
+psmond,1788,udp,psmond,[Will_Golson],[Will_Golson],,,,,,
+hello,1789,tcp,hello,[D_J_Bernstein_2],[D_J_Bernstein_2],,,,,,
+hello,1789,udp,hello,[D_J_Bernstein_2],[D_J_Bernstein_2],,,,,,
+nmsp,1790,tcp,Narrative Media Streaming Protocol,[Paul_Santinelli_Jr],[Paul_Santinelli_Jr],,,,,,
+nmsp,1790,udp,Narrative Media Streaming Protocol,[Paul_Santinelli_Jr],[Paul_Santinelli_Jr],,,,,,
+ea1,1791,tcp,EA1,[Kirk_MacLean],[Kirk_MacLean],,,,,,
+ea1,1791,udp,EA1,[Kirk_MacLean],[Kirk_MacLean],,,,,,
+ibm-dt-2,1792,tcp,ibm-dt-2,[Sam_Borman],[Sam_Borman],,,,,,
+ibm-dt-2,1792,udp,ibm-dt-2,[Sam_Borman],[Sam_Borman],,,,,,
+rsc-robot,1793,tcp,rsc-robot,[Andrew_Jay_Schneider],[Andrew_Jay_Schneider],,,,,,
+rsc-robot,1793,udp,rsc-robot,[Andrew_Jay_Schneider],[Andrew_Jay_Schneider],,,,,,
+cera-bcm,1794,tcp,cera-bcm,[Leo_Moesgaard],[Leo_Moesgaard],,,,,,
+cera-bcm,1794,udp,cera-bcm,[Leo_Moesgaard],[Leo_Moesgaard],,,,,,
+dpi-proxy,1795,tcp,dpi-proxy,[Charles_Gordon],[Charles_Gordon],,,,,,
+dpi-proxy,1795,udp,dpi-proxy,[Charles_Gordon],[Charles_Gordon],,,,,,
+vocaltec-admin,1796,tcp,Vocaltec Server Administration,[Scott_Petrack],[Scott_Petrack],,,,,,
+vocaltec-admin,1796,udp,Vocaltec Server Administration,[Scott_Petrack],[Scott_Petrack],,,,,,
+uma,1797,tcp,UMA,[Martin_Kirk],[Martin_Kirk],,,,,,
+uma,1797,udp,UMA,[Martin_Kirk],[Martin_Kirk],,,,,,
+etp,1798,tcp,Event Transfer Protocol,[Mike_Wray],[Mike_Wray],,,,,,
+etp,1798,udp,Event Transfer Protocol,[Mike_Wray],[Mike_Wray],,,,,,
+netrisk,1799,tcp,NETRISK,[Kevin_Green],[Kevin_Green],,,,,,
+netrisk,1799,udp,NETRISK,[Kevin_Green],[Kevin_Green],,,,,,
+ansys-lm,1800,tcp,ANSYS-License manager,[Suzanne_Lorrin_2],[Suzanne_Lorrin_2],,,,,,
+ansys-lm,1800,udp,ANSYS-License manager,[Suzanne_Lorrin_2],[Suzanne_Lorrin_2],,,,,,
+msmq,1801,tcp,Microsoft Message Que,[Amnon_Horowitz],[Amnon_Horowitz],,,,,,
+msmq,1801,udp,Microsoft Message Que,[Amnon_Horowitz],[Amnon_Horowitz],,,,,,
+concomp1,1802,tcp,ConComp1,[Ed_Vincent],[Ed_Vincent],,,,,,
+concomp1,1802,udp,ConComp1,[Ed_Vincent],[Ed_Vincent],,,,,,
+hp-hcip-gwy,1803,tcp,HP-HCIP-GWY,[Allen_Baker],[Allen_Baker],,,,,,
+hp-hcip-gwy,1803,udp,HP-HCIP-GWY,[Allen_Baker],[Allen_Baker],,,,,,
+enl,1804,tcp,ENL,[Brian_Olson],[Brian_Olson],,,,,,
+enl,1804,udp,ENL,[Brian_Olson],[Brian_Olson],,,,,,
+enl-name,1805,tcp,ENL-Name,[Brian_Olson],[Brian_Olson],,,,,,
+enl-name,1805,udp,ENL-Name,[Brian_Olson],[Brian_Olson],,,,,,
+musiconline,1806,tcp,Musiconline,[Craig_Weeks],[Craig_Weeks],,,,,,
+musiconline,1806,udp,Musiconline,[Craig_Weeks],[Craig_Weeks],,,,,,
+fhsp,1807,tcp,Fujitsu Hot Standby Protocol,[Eiki_Iwata],[Eiki_Iwata],,,,,,
+fhsp,1807,udp,Fujitsu Hot Standby Protocol,[Eiki_Iwata],[Eiki_Iwata],,,,,,
+oracle-vp2,1808,tcp,Oracle-VP2,[Craig_Fowler],[Craig_Fowler],,,,,,
+oracle-vp2,1808,udp,Oracle-VP2,[Craig_Fowler],[Craig_Fowler],,,,,,
+oracle-vp1,1809,tcp,Oracle-VP1,[Craig_Fowler],[Craig_Fowler],,,,,,
+oracle-vp1,1809,udp,Oracle-VP1,[Craig_Fowler],[Craig_Fowler],,,,,,
+jerand-lm,1810,tcp,Jerand License Manager,[Robert_Monat],[Robert_Monat],,,,,,
+jerand-lm,1810,udp,Jerand License Manager,[Robert_Monat],[Robert_Monat],,,,,,
+scientia-sdb,1811,tcp,Scientia-SDB,[SYSTEMS_MANAGER],[SYSTEMS_MANAGER],,,,,,
+scientia-sdb,1811,udp,Scientia-SDB,[SYSTEMS_MANAGER],[SYSTEMS_MANAGER],,,,,,
+radius,1812,tcp,RADIUS,,,,,[RFC2865],,,
+radius,1812,udp,RADIUS,,,,,[RFC2865],,,
+radius-acct,1813,tcp,RADIUS Accounting,,,,,[RFC2866],,,
+radius-acct,1813,udp,RADIUS Accounting,,,,,[RFC2866],,,
+tdp-suite,1814,tcp,TDP Suite,[Rob_Lockhart],[Rob_Lockhart],,,,,,
+tdp-suite,1814,udp,TDP Suite,[Rob_Lockhart],[Rob_Lockhart],,,,,,
+mmpft,1815,tcp,MMPFT,[Ralf_Muckenhirn],[Ralf_Muckenhirn],,,,,,
+mmpft,1815,udp,MMPFT,[Ralf_Muckenhirn],[Ralf_Muckenhirn],,,,,,
+harp,1816,tcp,HARP,[Bjorn_Chambless],[Bjorn_Chambless],,,,,,
+harp,1816,udp,HARP,[Bjorn_Chambless],[Bjorn_Chambless],,,,,,
+rkb-oscs,1817,tcp,RKB-OSCS,[Robert_Kevin_Breton],[Robert_Kevin_Breton],,,,,,
+rkb-oscs,1817,udp,RKB-OSCS,[Robert_Kevin_Breton],[Robert_Kevin_Breton],,,,,,
+etftp,1818,tcp,Enhanced Trivial File Transfer Protocol,[William_Polites],[William_Polites],,,,,,
+etftp,1818,udp,Enhanced Trivial File Transfer Protocol,[William_Polites],[William_Polites],,,,,,
+plato-lm,1819,tcp,Plato License Manager,[Mark_Morris],[Mark_Morris],,,,,,
+plato-lm,1819,udp,Plato License Manager,[Mark_Morris],[Mark_Morris],,,,,,
+mcagent,1820,tcp,mcagent,[Ryoichi_Shinohara],[Ryoichi_Shinohara],,,,,,
+mcagent,1820,udp,mcagent,[Ryoichi_Shinohara],[Ryoichi_Shinohara],,,,,,
+donnyworld,1821,tcp,donnyworld,[Don_Oliver],[Don_Oliver],,,,,,
+donnyworld,1821,udp,donnyworld,[Don_Oliver],[Don_Oliver],,,,,,
+es-elmd,1822,tcp,es-elmd,[David_Duncan],[David_Duncan],,,,,,
+es-elmd,1822,udp,es-elmd,[David_Duncan],[David_Duncan],,,,,,
+unisys-lm,1823,tcp,Unisys Natural Language License Manager,[Raymond_A_Diedrichs],[Raymond_A_Diedrichs],,,,,,
+unisys-lm,1823,udp,Unisys Natural Language License Manager,[Raymond_A_Diedrichs],[Raymond_A_Diedrichs],,,,,,
+metrics-pas,1824,tcp,metrics-pas,[Tom_Haapanen],[Tom_Haapanen],,,,,,
+metrics-pas,1824,udp,metrics-pas,[Tom_Haapanen],[Tom_Haapanen],,,,,,
+direcpc-video,1825,tcp,DirecPC Video,[Chris_Kerrigan],[Chris_Kerrigan],,,,,,
+direcpc-video,1825,udp,DirecPC Video,[Chris_Kerrigan],[Chris_Kerrigan],,,,,,
+ardt,1826,tcp,ARDT,[Mike_Goddard],[Mike_Goddard],,,,,,
+ardt,1826,udp,ARDT,[Mike_Goddard],[Mike_Goddard],,,,,,
+asi,1827,tcp,ASI,[Bob_Tournoux],[Bob_Tournoux],,,,,,
+asi,1827,udp,ASI,[Bob_Tournoux],[Bob_Tournoux],,,,,,
+itm-mcell-u,1828,tcp,itm-mcell-u,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+itm-mcell-u,1828,udp,itm-mcell-u,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+optika-emedia,1829,tcp,Optika eMedia,[Daryle_DeBalski],[Daryle_DeBalski],,,,,,
+optika-emedia,1829,udp,Optika eMedia,[Daryle_DeBalski],[Daryle_DeBalski],,,,,,
+net8-cman,1830,tcp,Oracle Net8 CMan Admin,[Shuvayu_Kanjilal],[Shuvayu_Kanjilal],,,,,,
+net8-cman,1830,udp,Oracle Net8 CMan Admin,[Shuvayu_Kanjilal],[Shuvayu_Kanjilal],,,,,,
+myrtle,1831,tcp,Myrtle,[Ron_Achin],[Ron_Achin],,,,,,
+myrtle,1831,udp,Myrtle,[Ron_Achin],[Ron_Achin],,,,,,
+tht-treasure,1832,tcp,ThoughtTreasure,[Erik_Mueller],[Erik_Mueller],,,,,,
+tht-treasure,1832,udp,ThoughtTreasure,[Erik_Mueller],[Erik_Mueller],,,,,,
+udpradio,1833,tcp,udpradio,[Guus_Sliepen],[Guus_Sliepen],,,,,,
+udpradio,1833,udp,udpradio,[Guus_Sliepen],[Guus_Sliepen],,,,,,
+ardusuni,1834,tcp,ARDUS Unicast,,,,,,,,
+ardusuni,1834,udp,ARDUS Unicast,,,,,,,,
+ardusmul,1835,tcp,ARDUS Multicast,[Toshikatsu_Ito],[Toshikatsu_Ito],,,,,,
+ardusmul,1835,udp,ARDUS Multicast,[Toshikatsu_Ito],[Toshikatsu_Ito],,,,,,
+ste-smsc,1836,tcp,ste-smsc,[Tom_Snauwaert],[Tom_Snauwaert],,,,,,
+ste-smsc,1836,udp,ste-smsc,[Tom_Snauwaert],[Tom_Snauwaert],,,,,,
+csoft1,1837,tcp,csoft1,[John_Coll],[John_Coll],,,,,,
+csoft1,1837,udp,csoft1,[John_Coll],[John_Coll],,,,,,
+talnet,1838,tcp,TALNET,[Aaron_Lav],[Aaron_Lav],,,,,,
+talnet,1838,udp,TALNET,[Aaron_Lav],[Aaron_Lav],,,,,,
+netopia-vo1,1839,tcp,netopia-vo1,,,,,,,,
+netopia-vo1,1839,udp,netopia-vo1,,,,,,,,
+netopia-vo2,1840,tcp,netopia-vo2,,,,,,,,
+netopia-vo2,1840,udp,netopia-vo2,,,,,,,,
+netopia-vo3,1841,tcp,netopia-vo3,,,,,,,,
+netopia-vo3,1841,udp,netopia-vo3,,,,,,,,
+netopia-vo4,1842,tcp,netopia-vo4,,,,,,,,
+netopia-vo4,1842,udp,netopia-vo4,,,,,,,,
+netopia-vo5,1843,tcp,netopia-vo5,[Marc_Epard],[Marc_Epard],,,,,,
+netopia-vo5,1843,udp,netopia-vo5,[Marc_Epard],[Marc_Epard],,,,,,
+direcpc-dll,1844,tcp,DirecPC-DLL,[Chris_Kerrigan],[Chris_Kerrigan],,,,,,
+direcpc-dll,1844,udp,DirecPC-DLL,[Chris_Kerrigan],[Chris_Kerrigan],,,,,,
+altalink,1845,tcp,altalink,[Alberto_Raydan],[Alberto_Raydan],,,,,,
+altalink,1845,udp,altalink,[Alberto_Raydan],[Alberto_Raydan],,,,,,
+tunstall-pnc,1846,tcp,Tunstall PNC,[Robert_M_Moore],[Robert_M_Moore],,,,,,
+tunstall-pnc,1846,udp,Tunstall PNC,[Robert_M_Moore],[Robert_M_Moore],,,,,,
+slp-notify,1847,tcp,SLP Notification,,,,,[RFC3082],,,
+slp-notify,1847,udp,SLP Notification,,,,,[RFC3082],,,
+fjdocdist,1848,tcp,fjdocdist,[Yuichi_Ohiwa],[Yuichi_Ohiwa],,,,,,
+fjdocdist,1848,udp,fjdocdist,[Yuichi_Ohiwa],[Yuichi_Ohiwa],,,,,,
+alpha-sms,1849,tcp,ALPHA-SMS,[Benjamin_Grimm],[Benjamin_Grimm],,,,,,
+alpha-sms,1849,udp,ALPHA-SMS,[Benjamin_Grimm],[Benjamin_Grimm],,,,,,
+gsi,1850,tcp,GSI,[William_Mullaney],[William_Mullaney],,,,,,
+gsi,1850,udp,GSI,[William_Mullaney],[William_Mullaney],,,,,,
+ctcd,1851,tcp,ctcd,[John_Ryan],[John_Ryan],,,,,,
+ctcd,1851,udp,ctcd,[John_Ryan],[John_Ryan],,,,,,
+virtual-time,1852,tcp,Virtual Time,[Angie_S_Morner],[Angie_S_Morner],,,,,,
+virtual-time,1852,udp,Virtual Time,[Angie_S_Morner],[Angie_S_Morner],,,,,,
+vids-avtp,1853,tcp,VIDS-AVTP,[Sascha_Kuemmel],[Sascha_Kuemmel],,,,,,
+vids-avtp,1853,udp,VIDS-AVTP,[Sascha_Kuemmel],[Sascha_Kuemmel],,,,,,
+buddy-draw,1854,tcp,Buddy Draw,[Marvin_Shin],[Marvin_Shin],,,,,,
+buddy-draw,1854,udp,Buddy Draw,[Marvin_Shin],[Marvin_Shin],,,,,,
+fiorano-rtrsvc,1855,tcp,Fiorano RtrSvc,,,,,,,,
+fiorano-rtrsvc,1855,udp,Fiorano RtrSvc,,,,,,,,
+fiorano-msgsvc,1856,tcp,Fiorano MsgSvc,[Albert_Holt_2],[Albert_Holt_2],,,,,,
+fiorano-msgsvc,1856,udp,Fiorano MsgSvc,[Albert_Holt_2],[Albert_Holt_2],,,,,,
+datacaptor,1857,tcp,DataCaptor,[Steven_M_Forrester],[Steven_M_Forrester],,,,,,
+datacaptor,1857,udp,DataCaptor,[Steven_M_Forrester],[Steven_M_Forrester],,,,,,
+privateark,1858,tcp,PrivateArk,[Ronen_Zoran],[Ronen_Zoran],,,,,,
+privateark,1858,udp,PrivateArk,[Ronen_Zoran],[Ronen_Zoran],,,,,,
+gammafetchsvr,1859,tcp,Gamma Fetcher Server,[Cnaan_Aviv],[Cnaan_Aviv],,,,,,
+gammafetchsvr,1859,udp,Gamma Fetcher Server,[Cnaan_Aviv],[Cnaan_Aviv],,,,,,
+sunscalar-svc,1860,tcp,SunSCALAR Services,[Sanjay_Radia],[Sanjay_Radia],,,,,,
+sunscalar-svc,1860,udp,SunSCALAR Services,[Sanjay_Radia],[Sanjay_Radia],,,,,,
+lecroy-vicp,1861,tcp,LeCroy VICP,[Anthony_Cake],[Anthony_Cake],,,,,,
+lecroy-vicp,1861,udp,LeCroy VICP,[Anthony_Cake],[Anthony_Cake],,,,,,
+mysql-cm-agent,1862,tcp,MySQL Cluster Manager Agent,[Andrew_Morgan],[Andrew_Morgan],2009-12-08,,,,,
+mysql-cm-agent,1862,udp,MySQL Cluster Manager Agent,[Andrew_Morgan],[Andrew_Morgan],2009-12-08,,,,,
+msnp,1863,tcp,MSNP,[William_Lai],[William_Lai],,,,,,
+msnp,1863,udp,MSNP,[William_Lai],[William_Lai],,,,,,
+paradym-31port,1864,tcp,Paradym 31 Port,[David_Wooden],[David_Wooden],,,,,,
+paradym-31port,1864,udp,Paradym 31 Port,[David_Wooden],[David_Wooden],,,,,,
+entp,1865,tcp,ENTP,[Seiko_Epson],[Seiko_Epson],,,,,,
+entp,1865,udp,ENTP,[Seiko_Epson],[Seiko_Epson],,,,,,
+swrmi,1866,tcp,swrmi,[Jun_Yoshii],[Jun_Yoshii],,,,,,
+swrmi,1866,udp,swrmi,[Jun_Yoshii],[Jun_Yoshii],,,,,,
+udrive,1867,tcp,UDRIVE,[Robby_Walker],[Robby_Walker],,,,,,
+udrive,1867,udp,UDRIVE,[Robby_Walker],[Robby_Walker],,,,,,
+viziblebrowser,1868,tcp,VizibleBrowser,[Jimmy_Talbot],[Jimmy_Talbot],,,,,,
+viziblebrowser,1868,udp,VizibleBrowser,[Jimmy_Talbot],[Jimmy_Talbot],,,,,,
+transact,1869,tcp,TransAct,[TransAct_Futures_Dev],[TransAct_Futures_Dev],,,,,,
+transact,1869,udp,TransAct,[TransAct_Futures_Dev],[TransAct_Futures_Dev],,,,,,
+sunscalar-dns,1870,tcp,SunSCALAR DNS Service,[Sanjay_Radia],[Sanjay_Radia],,,,,,
+sunscalar-dns,1870,udp,SunSCALAR DNS Service,[Sanjay_Radia],[Sanjay_Radia],,,,,,
+canocentral0,1871,tcp,Cano Central 0,,,,,,,,
+canocentral0,1871,udp,Cano Central 0,,,,,,,,
+canocentral1,1872,tcp,Cano Central 1,[Mark_McNamara],[Mark_McNamara],,,,,,
+canocentral1,1872,udp,Cano Central 1,[Mark_McNamara],[Mark_McNamara],,,,,,
+fjmpjps,1873,tcp,Fjmpjps,,,,,,,,
+fjmpjps,1873,udp,Fjmpjps,,,,,,,,
+fjswapsnp,1874,tcp,Fjswapsnp,[Y_Ohiwa],[Y_Ohiwa],,,,,,
+fjswapsnp,1874,udp,Fjswapsnp,[Y_Ohiwa],[Y_Ohiwa],,,,,,
+westell-stats,1875,tcp,westell stats,[Thomas_McCabe],[Thomas_McCabe],,,,,,
+westell-stats,1875,udp,westell stats,[Thomas_McCabe],[Thomas_McCabe],,,,,,
+ewcappsrv,1876,tcp,ewcappsrv,[Howard_Yin],[Howard_Yin],,,,,,
+ewcappsrv,1876,udp,ewcappsrv,[Howard_Yin],[Howard_Yin],,,,,,
+hp-webqosdb,1877,tcp,hp-webqosdb,[Kim_Scott],[Kim_Scott],,,,,,
+hp-webqosdb,1877,udp,hp-webqosdb,[Kim_Scott],[Kim_Scott],,,,,,
+drmsmc,1878,tcp,drmsmc,[Katsuhiko_Abe],[Katsuhiko_Abe],,,,,,
+drmsmc,1878,udp,drmsmc,[Katsuhiko_Abe],[Katsuhiko_Abe],,,,,,
+nettgain-nms,1879,tcp,NettGain NMS,[Dr_Yair_Shapira],[Dr_Yair_Shapira],,,,,,
+nettgain-nms,1879,udp,NettGain NMS,[Dr_Yair_Shapira],[Dr_Yair_Shapira],,,,,,
+vsat-control,1880,tcp,Gilat VSAT Control,[Yariv_Kaplan],[Yariv_Kaplan],,,,,,
+vsat-control,1880,udp,Gilat VSAT Control,[Yariv_Kaplan],[Yariv_Kaplan],,,,,,
+ibm-mqseries2,1881,tcp,IBM WebSphere MQ Everyplace,[Jane_Porter],[Jane_Porter],,,,,,
+ibm-mqseries2,1881,udp,IBM WebSphere MQ Everyplace,[Jane_Porter],[Jane_Porter],,,,,,
+ecsqdmn,1882,tcp,CA eTrust Common Services,[Paul_Wissmiller],[Paul_Wissmiller],,,,,,
+ecsqdmn,1882,udp,CA eTrust Common Services,[Paul_Wissmiller],[Paul_Wissmiller],,,,,,
+ibm-mqisdp,1883,tcp,IBM MQSeries SCADA,[Andy_Stanford_Clark],[Andy_Stanford_Clark],,,,,,
+ibm-mqisdp,1883,udp,IBM MQSeries SCADA,[Andy_Stanford_Clark],[Andy_Stanford_Clark],,,,,,
+idmaps,1884,tcp,Internet Distance Map Svc,[Sugih_Jamim],[Sugih_Jamim],,,,,,
+idmaps,1884,udp,Internet Distance Map Svc,[Sugih_Jamim],[Sugih_Jamim],,,,,,
+vrtstrapserver,1885,tcp,Veritas Trap Server,[Russell_Thrasher],[Russell_Thrasher],,,,,,
+vrtstrapserver,1885,udp,Veritas Trap Server,[Russell_Thrasher],[Russell_Thrasher],,,,,,
+leoip,1886,tcp,Leonardo over IP,[Dietmar_Finkler],[Dietmar_Finkler],,,,,,
+leoip,1886,udp,Leonardo over IP,[Dietmar_Finkler],[Dietmar_Finkler],,,,,,
+filex-lport,1887,tcp,FileX Listening Port,[Megan_Woods],[Megan_Woods],,,,,,
+filex-lport,1887,udp,FileX Listening Port,[Megan_Woods],[Megan_Woods],,,,,,
+ncconfig,1888,tcp,NC Config Port,[Simon_Parker],[Simon_Parker],,,,,,
+ncconfig,1888,udp,NC Config Port,[Simon_Parker],[Simon_Parker],,,,,,
+unify-adapter,1889,tcp,Unify Web Adapter Service,[Daegis_Inc],[Chris_Anderson],,2012-07-31,,,,
+unify-adapter,1889,udp,Unify Web Adapter Service,[Daegis_Inc],[Chris_Anderson],,2012-07-31,,,,
+wilkenlistener,1890,tcp,wilkenListener,[Wilken_GmbH],[Wilken_GmbH],,,,,,
+wilkenlistener,1890,udp,wilkenListener,[Wilken_GmbH],[Wilken_GmbH],,,,,,
+childkey-notif,1891,tcp,ChildKey Notification,,,,,,,,
+childkey-notif,1891,udp,ChildKey Notification,,,,,,,,
+childkey-ctrl,1892,tcp,ChildKey Control,[Ivan_Berardinelli],[Ivan_Berardinelli],,,,,,
+childkey-ctrl,1892,udp,ChildKey Control,[Ivan_Berardinelli],[Ivan_Berardinelli],,,,,,
+elad,1893,tcp,ELAD Protocol,[Franco_Milan],[Franco_Milan],,,,,,
+elad,1893,udp,ELAD Protocol,[Franco_Milan],[Franco_Milan],,,,,,
+o2server-port,1894,tcp,O2Server Port,[Tim_Howard],[Tim_Howard],,,,,,
+o2server-port,1894,udp,O2Server Port,[Tim_Howard],[Tim_Howard],,,,,,
+,1895,tcp,unassigned,,,,,,,,Microsoft (unoffically) using 1895
+,1895,udp,unassigned,,,,,,,,Microsoft (unoffically) using 1895
+b-novative-ls,1896,tcp,b-novative license server,[Matthias_Riese],[Matthias_Riese],,,,,,
+b-novative-ls,1896,udp,b-novative license server,[Matthias_Riese],[Matthias_Riese],,,,,,
+metaagent,1897,tcp,MetaAgent,[Marie_France_Dubreui],[Marie_France_Dubreui],,,,,,
+metaagent,1897,udp,MetaAgent,[Marie_France_Dubreui],[Marie_France_Dubreui],,,,,,
+cymtec-port,1898,tcp,Cymtec secure management,[Michael_Mester],[Michael_Mester],,,,,,
+cymtec-port,1898,udp,Cymtec secure management,[Michael_Mester],[Michael_Mester],,,,,,
+mc2studios,1899,tcp,MC2Studios,[Michael_Coon],[Michael_Coon],,,,,,
+mc2studios,1899,udp,MC2Studios,[Michael_Coon],[Michael_Coon],,,,,,
+ssdp,1900,tcp,SSDP,[UPnP_Forum],[UPnP_Forum],,,,,,
+ssdp,1900,udp,SSDP,[UPnP_Forum],[UPnP_Forum],,,,,,
+fjicl-tep-a,1901,tcp,Fujitsu ICL Terminal Emulator Program A,[Bob_Lyon],[Bob_Lyon],,,,,,
+fjicl-tep-a,1901,udp,Fujitsu ICL Terminal Emulator Program A,[Bob_Lyon],[Bob_Lyon],,,,,,
+fjicl-tep-b,1902,tcp,Fujitsu ICL Terminal Emulator Program B,[Bob_Lyon],[Bob_Lyon],,,,,,
+fjicl-tep-b,1902,udp,Fujitsu ICL Terminal Emulator Program B,[Bob_Lyon],[Bob_Lyon],,,,,,
+linkname,1903,tcp,Local Link Name Resolution,[Dan_Harrington],[Dan_Harrington],,,,,,
+linkname,1903,udp,Local Link Name Resolution,[Dan_Harrington],[Dan_Harrington],,,,,,
+fjicl-tep-c,1904,tcp,Fujitsu ICL Terminal Emulator Program C,[Bob_Lyon],[Bob_Lyon],,,,,,
+fjicl-tep-c,1904,udp,Fujitsu ICL Terminal Emulator Program C,[Bob_Lyon],[Bob_Lyon],,,,,,
+sugp,1905,tcp,Secure UP.Link Gateway Protocol,[Peter_King],[Peter_King],,,,,,
+sugp,1905,udp,Secure UP.Link Gateway Protocol,[Peter_King],[Peter_King],,,,,,
+tpmd,1906,tcp,TPortMapperReq,[Sheila_Devins],[Sheila_Devins],,,,,,
+tpmd,1906,udp,TPortMapperReq,[Sheila_Devins],[Sheila_Devins],,,,,,
+intrastar,1907,tcp,IntraSTAR,[Peter_Schoenberger],[Peter_Schoenberger],,,,,,
+intrastar,1907,udp,IntraSTAR,[Peter_Schoenberger],[Peter_Schoenberger],,,,,,
+dawn,1908,tcp,Dawn,[Michael_Crawford_2],[Michael_Crawford_2],,,,,,
+dawn,1908,udp,Dawn,[Michael_Crawford_2],[Michael_Crawford_2],,,,,,
+global-wlink,1909,tcp,Global World Link,[Nicholas_Davies],[Nicholas_Davies],,,,,,
+global-wlink,1909,udp,Global World Link,[Nicholas_Davies],[Nicholas_Davies],,,,,,
+ultrabac,1910,tcp,UltraBac Software communications port,[Paul_Bunn],[Paul_Bunn],,,,,,
+ultrabac,1910,udp,UltraBac Software communications port,[Paul_Bunn],[Paul_Bunn],,,,,,
+mtp,1911,tcp,Starlight Networks Multimedia Transport Protocol,[Bruce_Lieberman],[Bruce_Lieberman],,,,,,
+mtp,1911,udp,Starlight Networks Multimedia Transport Protocol,[Bruce_Lieberman],[Bruce_Lieberman],,,,,,
+rhp-iibp,1912,tcp,rhp-iibp,[George_Nachman][Tom_Lake],[George_Nachman][Tom_Lake],,,,,,
+rhp-iibp,1912,udp,rhp-iibp,[George_Nachman][Tom_Lake],[George_Nachman][Tom_Lake],,,,,,
+armadp,1913,tcp,armadp,[Kevin_Welton],[Kevin_Welton],,,,,,
+armadp,1913,udp,armadp,[Kevin_Welton],[Kevin_Welton],,,,,,
+elm-momentum,1914,tcp,Elm-Momentum,[Willie_Wu],[Willie_Wu],,,,,,
+elm-momentum,1914,udp,Elm-Momentum,[Willie_Wu],[Willie_Wu],,,,,,
+facelink,1915,tcp,FACELINK,[J_H_Hermans],[J_H_Hermans],,,,,,
+facelink,1915,udp,FACELINK,[J_H_Hermans],[J_H_Hermans],,,,,,
+persona,1916,tcp,Persoft Persona,[Tom_Spidell],[Tom_Spidell],,,,,,
+persona,1916,udp,Persoft Persona,[Tom_Spidell],[Tom_Spidell],,,,,,
+noagent,1917,tcp,nOAgent,[Martin_Bestmann],[Martin_Bestmann],,,,,,
+noagent,1917,udp,nOAgent,[Martin_Bestmann],[Martin_Bestmann],,,,,,
+can-nds,1918,tcp,IBM Tivole Directory Service - NDS,,,,,,,,
+can-nds,1918,udp,IBM Tivole Directory Service - NDS,,,,,,,,
+can-dch,1919,tcp,IBM Tivoli Directory Service - DCH,,,,,,,,
+can-dch,1919,udp,IBM Tivoli Directory Service - DCH,,,,,,,,
+can-ferret,1920,tcp,IBM Tivoli Directory Service - FERRET,[Nic_Catrambone],[Nic_Catrambone],,,,,,
+can-ferret,1920,udp,IBM Tivoli Directory Service - FERRET,[Nic_Catrambone],[Nic_Catrambone],,,,,,
+noadmin,1921,tcp,NoAdmin,[Martin_Bestmann],[Martin_Bestmann],,,,,,
+noadmin,1921,udp,NoAdmin,[Martin_Bestmann],[Martin_Bestmann],,,,,,
+tapestry,1922,tcp,Tapestry,[Ken_Oliver],[Ken_Oliver],,,,,,
+tapestry,1922,udp,Tapestry,[Ken_Oliver],[Ken_Oliver],,,,,,
+spice,1923,tcp,SPICE,[Nicholas_Chua],[Nicholas_Chua],,,,,,
+spice,1923,udp,SPICE,[Nicholas_Chua],[Nicholas_Chua],,,,,,
+xiip,1924,tcp,XIIP,[Alain_Robert_2],[Alain_Robert_2],,,,,,
+xiip,1924,udp,XIIP,[Alain_Robert_2],[Alain_Robert_2],,,,,,
+discovery-port,1925,tcp,Surrogate Discovery Port,[Keith_Thompson],[Keith_Thompson],,,,,,
+discovery-port,1925,udp,Surrogate Discovery Port,[Keith_Thompson],[Keith_Thompson],,,,,,
+egs,1926,tcp,Evolution Game Server,[Simon_Butcher],[Simon_Butcher],,,,,,
+egs,1926,udp,Evolution Game Server,[Simon_Butcher],[Simon_Butcher],,,,,,
+videte-cipc,1927,tcp,Videte CIPC Port,[Videte_IT],[Videte_IT],,,,,,
+videte-cipc,1927,udp,Videte CIPC Port,[Videte_IT],[Videte_IT],,,,,,
+emsd-port,1928,tcp,Expnd Maui Srvr Dscovr,[Edo_Yahav],[Edo_Yahav],,,,,,
+emsd-port,1928,udp,Expnd Maui Srvr Dscovr,[Edo_Yahav],[Edo_Yahav],,,,,,
+bandwiz-system,1929,tcp,Bandwiz System - Server,[Joseph_Weihs],[Joseph_Weihs],,,,,,
+bandwiz-system,1929,udp,Bandwiz System - Server,[Joseph_Weihs],[Joseph_Weihs],,,,,,
+driveappserver,1930,tcp,Drive AppServer,[Andrew_Johnson],[Andrew_Johnson],,,,,,
+driveappserver,1930,udp,Drive AppServer,[Andrew_Johnson],[Andrew_Johnson],,,,,,
+amdsched,1931,tcp,AMD SCHED,[Michael_Walsh],[Michael_Walsh],,,,,,
+amdsched,1931,udp,AMD SCHED,[Michael_Walsh],[Michael_Walsh],,,,,,
+ctt-broker,1932,tcp,CTT Broker,[Jens_Edlund],[Jens_Edlund],,,,,,
+ctt-broker,1932,udp,CTT Broker,[Jens_Edlund],[Jens_Edlund],,,,,,
+xmapi,1933,tcp,IBM LM MT Agent,,,,,,,,
+xmapi,1933,udp,IBM LM MT Agent,,,,,,,,
+xaapi,1934,tcp,IBM LM Appl Agent,[Helga_Wolin],[Helga_Wolin],,,,,,
+xaapi,1934,udp,IBM LM Appl Agent,[Helga_Wolin],[Helga_Wolin],,,,,,
+macromedia-fcs,1935,tcp,Macromedia Flash Communications Server MX,[Pritham_Shetty],[Pritham_Shetty],,,,,,
+macromedia-fcs,1935,udp,Macromedia Flash Communications server MX,[Pritham_Shetty],[Pritham_Shetty],,,,,,
+jetcmeserver,1936,tcp,JetCmeServer Server Port,,,,,,,,
+jetcmeserver,1936,udp,JetCmeServer Server Port,,,,,,,,
+jwserver,1937,tcp,JetVWay Server Port,,,,,,,,
+jwserver,1937,udp,JetVWay Server Port,,,,,,,,
+jwclient,1938,tcp,JetVWay Client Port,,,,,,,,
+jwclient,1938,udp,JetVWay Client Port,,,,,,,,
+jvserver,1939,tcp,JetVision Server Port,,,,,,,,
+jvserver,1939,udp,JetVision Server Port,,,,,,,,
+jvclient,1940,tcp,JetVision Client Port,[Stephen_Tsun],[Stephen_Tsun],,,,,,
+jvclient,1940,udp,JetVision Client Port,[Stephen_Tsun],[Stephen_Tsun],,,,,,
+dic-aida,1941,tcp,DIC-Aida,[Frans_S_C_Witte],[Frans_S_C_Witte],,,,,,
+dic-aida,1941,udp,DIC-Aida,[Frans_S_C_Witte],[Frans_S_C_Witte],,,,,,
+res,1942,tcp,Real Enterprise Service,[Bob_Janssen],[Bob_Janssen],,,,,,
+res,1942,udp,Real Enterprise Service,[Bob_Janssen],[Bob_Janssen],,,,,,
+beeyond-media,1943,tcp,Beeyond Media,[Bob_Deblier],[Bob_Deblier],,,,,,
+beeyond-media,1943,udp,Beeyond Media,[Bob_Deblier],[Bob_Deblier],,,,,,
+close-combat,1944,tcp,close-combat,[David_Hua],[David_Hua],,,,,,
+close-combat,1944,udp,close-combat,[David_Hua],[David_Hua],,,,,,
+dialogic-elmd,1945,tcp,dialogic-elmd,[Roger_Kay],[Roger_Kay],,,,,,
+dialogic-elmd,1945,udp,dialogic-elmd,[Roger_Kay],[Roger_Kay],,,,,,
+tekpls,1946,tcp,tekpls,[Brian_Abramson_2],[Brian_Abramson_2],,,,,,
+tekpls,1946,udp,tekpls,[Brian_Abramson_2],[Brian_Abramson_2],,,,,,
+sentinelsrm,1947,tcp,SentinelSRM,[Michael_Zunke_2],[Michael_Zunke_2],2010-07-23,,,,,
+sentinelsrm,1947,udp,SentinelSRM,[Michael_Zunke_2],[Michael_Zunke_2],2010-07-23,,,,,
+eye2eye,1948,tcp,eye2eye,[Trevor_Bell],[Trevor_Bell],,,,,,
+eye2eye,1948,udp,eye2eye,[Trevor_Bell],[Trevor_Bell],,,,,,
+ismaeasdaqlive,1949,tcp,ISMA Easdaq Live,[Stephen_Dunne],[Stephen_Dunne],,,,,,
+ismaeasdaqlive,1949,udp,ISMA Easdaq Live,[Stephen_Dunne],[Stephen_Dunne],,,,,,
+ismaeasdaqtest,1950,tcp,ISMA Easdaq Test,[Stephen_Dunne],[Stephen_Dunne],,,,,,
+ismaeasdaqtest,1950,udp,ISMA Easdaq Test,[Stephen_Dunne],[Stephen_Dunne],,,,,,
+bcs-lmserver,1951,tcp,bcs-lmserver,[Andy_Warner],[Andy_Warner],,,,,,
+bcs-lmserver,1951,udp,bcs-lmserver,[Andy_Warner],[Andy_Warner],,,,,,
+mpnjsc,1952,tcp,mpnjsc,[Takenori_Miyahara],[Takenori_Miyahara],,,,,,
+mpnjsc,1952,udp,mpnjsc,[Takenori_Miyahara],[Takenori_Miyahara],,,,,,
+rapidbase,1953,tcp,Rapid Base,[Antoni_Wolski],[Antoni_Wolski],,,,,,
+rapidbase,1953,udp,Rapid Base,[Antoni_Wolski],[Antoni_Wolski],,,,,,
+abr-api,1954,tcp,ABR-API (diskbridge),,,,,,,,
+abr-api,1954,udp,ABR-API (diskbridge),,,,,,,,
+abr-secure,1955,tcp,ABR-Secure Data (diskbridge),[Graham_Wooden],[Graham_Wooden],,,,,,
+abr-secure,1955,udp,ABR-Secure Data (diskbridge),[Graham_Wooden],[Graham_Wooden],,,,,,
+vrtl-vmf-ds,1956,tcp,Vertel VMF DS,[Alan_Akahoshi],[Alan_Akahoshi],,,,,,
+vrtl-vmf-ds,1956,udp,Vertel VMF DS,[Alan_Akahoshi],[Alan_Akahoshi],,,,,,
+unix-status,1957,tcp,unix-status,[Thomas_Erskine],[Thomas_Erskine],,,,,,
+unix-status,1957,udp,unix-status,[Thomas_Erskine],[Thomas_Erskine],,,,,,
+dxadmind,1958,tcp,CA Administration Daemon,[John_Birrell],[John_Birrell],,,,,,
+dxadmind,1958,udp,CA Administration Daemon,[John_Birrell],[John_Birrell],,,,,,
+simp-all,1959,tcp,SIMP Channel,[Tim_Hunnewell],[Tim_Hunnewell],,,,,,
+simp-all,1959,udp,SIMP Channel,[Tim_Hunnewell],[Tim_Hunnewell],,,,,,
+nasmanager,1960,tcp,Merit DAC NASmanager,[Richard_S_Conto],[Richard_S_Conto],,,,,,
+nasmanager,1960,udp,Merit DAC NASmanager,[Richard_S_Conto],[Richard_S_Conto],,,,,,
+bts-appserver,1961,tcp,BTS APPSERVER,[Carl_Obsorn],[Carl_Obsorn],,,,,,
+bts-appserver,1961,udp,BTS APPSERVER,[Carl_Obsorn],[Carl_Obsorn],,,,,,
+biap-mp,1962,tcp,BIAP-MP,[Louis_Slothouber],[Louis_Slothouber],,,,,,
+biap-mp,1962,udp,BIAP-MP,[Louis_Slothouber],[Louis_Slothouber],,,,,,
+webmachine,1963,tcp,WebMachine,[Tim_Jowers],[Tim_Jowers],,,,,,
+webmachine,1963,udp,WebMachine,[Tim_Jowers],[Tim_Jowers],,,,,,
+solid-e-engine,1964,tcp,SOLID E ENGINE,[Ari_Valtanen],[Ari_Valtanen],,,,,,
+solid-e-engine,1964,udp,SOLID E ENGINE,[Ari_Valtanen],[Ari_Valtanen],,,,,,
+tivoli-npm,1965,tcp,Tivoli NPM,[Ivana_Cuozzo],[Ivana_Cuozzo],,,,,,
+tivoli-npm,1965,udp,Tivoli NPM,[Ivana_Cuozzo],[Ivana_Cuozzo],,,,,,
+slush,1966,tcp,Slush,[Damien_Miller],[Damien_Miller],,,,,,
+slush,1966,udp,Slush,[Damien_Miller],[Damien_Miller],,,,,,
+sns-quote,1967,tcp,SNS Quote,[Robert_Ellman],[Robert_Ellman],,,,,,
+sns-quote,1967,udp,SNS Quote,[Robert_Ellman],[Robert_Ellman],,,,,,
+lipsinc,1968,tcp,LIPSinc,,,,,,,,
+lipsinc,1968,udp,LIPSinc,,,,,,,,
+lipsinc1,1969,tcp,LIPSinc 1,[Robert_Armington],[Robert_Armington],,,,,,
+lipsinc1,1969,udp,LIPSinc 1,[Robert_Armington],[Robert_Armington],,,,,,
+netop-rc,1970,tcp,NetOp Remote Control,,,,,,,,
+netop-rc,1970,udp,NetOp Remote Control,,,,,,,,
+netop-school,1971,tcp,NetOp School,[NetOp_Technical_Supp],[NetOp_Technical_Supp],,,,,,
+netop-school,1971,udp,NetOp School,[NetOp_Technical_Supp],[NetOp_Technical_Supp],,,,,,
+intersys-cache,1972,tcp,Cache,[Mark_Hanson],[Mark_Hanson],,,,,,
+intersys-cache,1972,udp,Cache,[Mark_Hanson],[Mark_Hanson],,,,,,
+dlsrap,1973,tcp,Data Link Switching Remote Access Protocol,[Steve_T_Chiang],[Steve_T_Chiang],,,,,,
+dlsrap,1973,udp,Data Link Switching Remote Access Protocol,[Steve_T_Chiang],[Steve_T_Chiang],,,,,,
+drp,1974,tcp,DRP,[Richard_Alan_Johnson],[Richard_Alan_Johnson],,,,,,
+drp,1974,udp,DRP,[Richard_Alan_Johnson],[Richard_Alan_Johnson],,,,,,
+tcoflashagent,1975,tcp,TCO Flash Agent,,,,,,,,
+tcoflashagent,1975,udp,TCO Flash Agent,,,,,,,,
+tcoregagent,1976,tcp,TCO Reg Agent,,,,,,,,
+tcoregagent,1976,udp,TCO Reg Agent,,,,,,,,
+tcoaddressbook,1977,tcp,TCO Address Book,[Allan_Panitch],[Allan_Panitch],,,,,,
+tcoaddressbook,1977,udp,TCO Address Book,[Allan_Panitch],[Allan_Panitch],,,,,,
+unisql,1978,tcp,UniSQL,,,,,,,,
+unisql,1978,udp,UniSQL,,,,,,,,
+unisql-java,1979,tcp,UniSQL Java,[Keith_Yarbrough],[Keith_Yarbrough],,,,,,
+unisql-java,1979,udp,UniSQL Java,[Keith_Yarbrough],[Keith_Yarbrough],,,,,,
+pearldoc-xact,1980,tcp,PearlDoc XACT,[Chris_Vertonghen],[Chris_Vertonghen],,,,,,
+pearldoc-xact,1980,udp,PearlDoc XACT,[Chris_Vertonghen],[Chris_Vertonghen],,,,,,
+p2pq,1981,tcp,p2pQ,[Warren_Alexander],[Warren_Alexander],,,,,,
+p2pq,1981,udp,p2pQ,[Warren_Alexander],[Warren_Alexander],,,,,,
+estamp,1982,tcp,Evidentiary Timestamp,[Todd_Glassey],[Todd_Glassey],,,,,,
+estamp,1982,udp,Evidentiary Timestamp,[Todd_Glassey],[Todd_Glassey],,,,,,
+lhtp,1983,tcp,Loophole Test Protocol,[Kade_Hansson],[Kade_Hansson],,,,,,
+lhtp,1983,udp,Loophole Test Protocol,[Kade_Hansson],[Kade_Hansson],,,,,,
+bb,1984,tcp,BB,[Sean_MacGuire],[Sean_MacGuire],,,,,,
+bb,1984,udp,BB,[Sean_MacGuire],[Sean_MacGuire],,,,,,
+hsrp,1985,tcp,Hot Standby Router Protocol,,,,,[RFC2281],,,
+hsrp,1985,udp,Hot Standby Router Protocol,,,,,[RFC2281],,,
+licensedaemon,1986,tcp,cisco license management,,,,,,,,
+licensedaemon,1986,udp,cisco license management,,,,,,,,
+tr-rsrb-p1,1987,tcp,cisco RSRB Priority 1 port,,,,,,,,
+tr-rsrb-p1,1987,udp,cisco RSRB Priority 1 port,,,,,,,,
+tr-rsrb-p2,1988,tcp,cisco RSRB Priority 2 port,,,,,,,,
+tr-rsrb-p2,1988,udp,cisco RSRB Priority 2 port,,,,,,,,
+tr-rsrb-p3,1989,tcp,cisco RSRB Priority 3 port,,,,,,,,
+tr-rsrb-p3,1989,udp,cisco RSRB Priority 3 port,,,,,,,,
+mshnet,1989,tcp,MHSnet system,[Bob_Kummerfeld],[Bob_Kummerfeld],,,,,,This entry records an unassigned but widespread use
+mshnet,1989,udp,MHSnet system,[Bob_Kummerfeld],[Bob_Kummerfeld],,,,,,This entry records an unassigned but widespread use
+stun-p1,1990,tcp,cisco STUN Priority 1 port,,,,,,,,
+stun-p1,1990,udp,cisco STUN Priority 1 port,,,,,,,,
+stun-p2,1991,tcp,cisco STUN Priority 2 port,,,,,,,,
+stun-p2,1991,udp,cisco STUN Priority 2 port,,,,,,,,
+stun-p3,1992,tcp,cisco STUN Priority 3 port,,,,,,,,
+stun-p3,1992,udp,cisco STUN Priority 3 port,,,,,,,,
+ipsendmsg,1992,tcp,IPsendmsg,[Bob_Kummerfeld],[Bob_Kummerfeld],,,,,,This entry records an unassigned but widespread use
+ipsendmsg,1992,udp,IPsendmsg,[Bob_Kummerfeld],[Bob_Kummerfeld],,,,,,This entry records an unassigned but widespread use
+snmp-tcp-port,1993,tcp,cisco SNMP TCP port,,,,,,,,
+snmp-tcp-port,1993,udp,cisco SNMP TCP port,,,,,,,,
+stun-port,1994,tcp,cisco serial tunnel port,,,,,,,,
+stun-port,1994,udp,cisco serial tunnel port,,,,,,,,
+perf-port,1995,tcp,cisco perf port,,,,,,,,
+perf-port,1995,udp,cisco perf port,,,,,,,,
+tr-rsrb-port,1996,tcp,cisco Remote SRB port,,,,,,,,
+tr-rsrb-port,1996,udp,cisco Remote SRB port,,,,,,,,
+gdp-port,1997,tcp,cisco Gateway Discovery Protocol,,,,,,,,
+gdp-port,1997,udp,cisco Gateway Discovery Protocol,,,,,,,,
+x25-svc-port,1998,tcp,cisco X.25 service (XOT),,,,,,,,
+x25-svc-port,1998,udp,cisco X.25 service (XOT),,,,,,,,
+tcp-id-port,1999,tcp,cisco identification port,,,,,,,,
+tcp-id-port,1999,udp,cisco identification port,,,,,,,,
+cisco-sccp,2000,tcp,Cisco SCCP,[Dan_Wing],[Dan_Wing],2003-11,,,,,
+cisco-sccp,2000,udp,Cisco SCCp,[Dan_Wing],[Dan_Wing],2003-11,,,,,
+dc,2001,tcp,,,,,,,,,
+wizard,2001,udp,curry,,,,,,,,
+globe,2002,tcp,,,,,,,,,
+globe,2002,udp,,,,,,,,,
+brutus,2003,tcp,Brutus Server,[Johannes_Skov_Frands],[Johannes_Skov_Frands],2008-02-28,,,,,
+brutus,2003,udp,Brutus Server,[Johannes_Skov_Frands],[Johannes_Skov_Frands],2008-02-28,,,,,
+mailbox,2004,tcp,,,,,,,,,
+emce,2004,udp,CCWS mm conf,,,,,,,,
+berknet,2005,tcp,,,,,,,,,
+oracle,2005,udp,,,,,,,,,
+invokator,2006,tcp,,,,,,,,,
+raid-cd,2006,udp,raid,,,,,,,,
+dectalk,2007,tcp,,,,,,,,,
+raid-am,2007,udp,,,,,,,,,
+conf,2008,tcp,,,,,,,,,
+terminaldb,2008,udp,,,,,,,,,
+news,2009,tcp,,,,,,,,,
+whosockami,2009,udp,,,,,,,,,
+search,2010,tcp,,,,,,,,,
+pipe-server,2010,udp,"IANA assigned this well-formed service name as a replacement for ""pipe_server"".",,,,,,,,
+pipe_server,2010,udp,,,,,,,,,"This entry is an alias to ""pipe-server"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+raid-cc,2011,tcp,raid,,,,,,,,
+servserv,2011,udp,,,,,,,,,
+ttyinfo,2012,tcp,,,,,,,,,
+raid-ac,2012,udp,,,,,,,,,
+raid-am,2013,tcp,,,,,,,,,
+raid-cd,2013,udp,,,,,,,,,
+troff,2014,tcp,,,,,,,,,
+raid-sf,2014,udp,,,,,,,,,
+cypress,2015,tcp,,,,,,,,,
+raid-cs,2015,udp,,,,,,,,,
+bootserver,2016,tcp,,,,,,,,,
+bootserver,2016,udp,,,,,,,,,
+cypress-stat,2017,tcp,,,,,,,,,
+bootclient,2017,udp,,,,,,,,,
+terminaldb,2018,tcp,,,,,,,,,
+rellpack,2018,udp,,,,,,,,,
+whosockami,2019,tcp,,,,,,,,,
+about,2019,udp,,,,,,,,,
+xinupageserver,2020,tcp,,,,,,,,,
+xinupageserver,2020,udp,,,,,,,,,
+servexec,2021,tcp,,,,,,,,,
+xinuexpansion1,2021,udp,,,,,,,,,
+down,2022,tcp,,,,,,,,,
+xinuexpansion2,2022,udp,,,,,,,,,
+xinuexpansion3,2023,tcp,,,,,,,,,
+xinuexpansion3,2023,udp,,,,,,,,,
+xinuexpansion4,2024,tcp,,,,,,,,,
+xinuexpansion4,2024,udp,,,,,,,,,
+ellpack,2025,tcp,,,,,,,,,
+xribs,2025,udp,,,,,,,,,
+scrabble,2026,tcp,,,,,,,,,
+scrabble,2026,udp,,,,,,,,,
+shadowserver,2027,tcp,,,,,,,,,
+shadowserver,2027,udp,,,,,,,,,
+submitserver,2028,tcp,,,,,,,,,
+submitserver,2028,udp,,,,,,,,,
+hsrpv6,2029,tcp,Hot Standby Router Protocol IPv6,[Ian_Wilson],[Ian_Wilson],2004-11,,,,,
+hsrpv6,2029,udp,Hot Standby Router Protocol IPv6,[Ian_Wilson],[Ian_Wilson],2004-11,,,,,
+device2,2030,tcp,,,,,,,,,
+device2,2030,udp,,,,,,,,,
+mobrien-chat,2031,tcp,mobrien-chat,[Mike_O_Brien],[Mike_O_Brien],2004-11,,,,,
+mobrien-chat,2031,udp,mobrien-chat,[Mike_O_Brien],[Mike_O_Brien],2004-11,,,,,
+blackboard,2032,tcp,,,,,,,,,
+blackboard,2032,udp,,,,,,,,,
+glogger,2033,tcp,,,,,,,,,
+glogger,2033,udp,,,,,,,,,
+scoremgr,2034,tcp,,,,,,,,,
+scoremgr,2034,udp,,,,,,,,,
+imsldoc,2035,tcp,,,,,,,,,
+imsldoc,2035,udp,,,,,,,,,
+e-dpnet,2036,tcp,Ethernet WS DP network,[Peter_Kaever],[Peter_Kaever],2005-08,,,,,
+e-dpnet,2036,udp,Ethernet WS DP network,[Peter_Kaever],[Peter_Kaever],2005-08,,,,,
+applus,2037,tcp,APplus Application Server,[Thomas_Boerkel],[Thomas_Boerkel],2008-06-06,,,,,Formerly was P2plus Application Server
+applus,2037,udp,APplus Application Server,[Thomas_Boerkel],[Thomas_Boerkel],2008-06-06,,,,,Formerly was P2plus Application Server
+objectmanager,2038,tcp,,,,,,,,,
+objectmanager,2038,udp,,,,,,,,,
+prizma,2039,tcp,Prizma Monitoring Service,[Dotan_Ofek],[Dotan_Ofek],2005-12,,,,,
+prizma,2039,udp,Prizma Monitoring Service,[Dotan_Ofek],[Dotan_Ofek],2005-12,,,,,
+lam,2040,tcp,,,,,,,,,
+lam,2040,udp,,,,,,,,,
+interbase,2041,tcp,,,,,,,,,
+interbase,2041,udp,,,,,,,,,
+isis,2042,tcp,isis,,,,,,,,
+isis,2042,udp,isis,,,,,,,,
+isis-bcast,2043,tcp,isis-bcast,[Ken_Chapman],[Ken_Chapman],,,,,,
+isis-bcast,2043,udp,isis-bcast,[Ken_Chapman],[Ken_Chapman],,,,,,
+rimsl,2044,tcp,,,,,,,,,
+rimsl,2044,udp,,,,,,,,,
+cdfunc,2045,tcp,,,,,,,,,
+cdfunc,2045,udp,,,,,,,,,
+sdfunc,2046,tcp,,,,,,,,,
+sdfunc,2046,udp,,,,,,,,,
+dls,2047,tcp,,,,,,,,,
+dls,2047,udp,,,,,,,,,
+dls-monitor,2048,tcp,,,,,,,,,
+dls-monitor,2048,udp,,,,,,,,,
+shilp,2049,tcp,,,,,,,,,<== NOTE Conflict on 2049 !
+shilp,2049,udp,,,,,,,,,<== NOTE Conflict on 2049 !
+nfs,2049,tcp,Network File System - Sun Microsystems,[Brent_Callaghan],[Brent_Callaghan],,,,,,Defined TXT keys: path=<path to mount point>
+nfs,2049,udp,Network File System - Sun Microsystems,[Brent_Callaghan],[Brent_Callaghan],,,,,,Defined TXT keys: path=<path to mount point>
+nfs,2049,sctp,Network File System,,,,,[RFC5665],,,Defined TXT keys: path=<path to mount point>
+av-emb-config,2050,tcp,Avaya EMB Config Port,[John_Yeager],[John_Yeager],,,,,,
+av-emb-config,2050,udp,Avaya EMB Config Port,[John_Yeager],[John_Yeager],,,,,,
+epnsdp,2051,tcp,EPNSDP,[Hiroyasu_Ogata],[Hiroyasu_Ogata],,,,,,
+epnsdp,2051,udp,EPNSDP,[Hiroyasu_Ogata],[Hiroyasu_Ogata],,,,,,
+clearvisn,2052,tcp,clearVisn Services Port,[Dave_Lyons],[Dave_Lyons],,,,,,
+clearvisn,2052,udp,clearVisn Services Port,[Dave_Lyons],[Dave_Lyons],,,,,,
+lot105-ds-upd,2053,tcp,Lot105 DSuper Updates,[Piers_Scannell],[Piers_Scannell],,,,,,
+lot105-ds-upd,2053,udp,Lot105 DSuper Updates,[Piers_Scannell],[Piers_Scannell],,,,,,
+weblogin,2054,tcp,Weblogin Port,[Diego_Saravia],[Diego_Saravia],,,,,,
+weblogin,2054,udp,Weblogin Port,[Diego_Saravia],[Diego_Saravia],,,,,,
+iop,2055,tcp,Iliad-Odyssey Protocol,[Bruce_Lueckenhoff],[Bruce_Lueckenhoff],,,,,,
+iop,2055,udp,Iliad-Odyssey Protocol,[Bruce_Lueckenhoff],[Bruce_Lueckenhoff],,,,,,
+omnisky,2056,tcp,OmniSky Port,[Oren_Hurvitz],[Oren_Hurvitz],,,,,,
+omnisky,2056,udp,OmniSky Port,[Oren_Hurvitz],[Oren_Hurvitz],,,,,,
+rich-cp,2057,tcp,Rich Content Protocol,[Ronen_Vainish],[Ronen_Vainish],,,,,,
+rich-cp,2057,udp,Rich Content Protocol,[Ronen_Vainish],[Ronen_Vainish],,,,,,
+newwavesearch,2058,tcp,NewWaveSearchables RMI,[Thomas_Kerkau],[Thomas_Kerkau],,,,,,
+newwavesearch,2058,udp,NewWaveSearchables RMI,[Thomas_Kerkau],[Thomas_Kerkau],,,,,,
+bmc-messaging,2059,tcp,BMC Messaging Service,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmc-messaging,2059,udp,BMC Messaging Service,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+teleniumdaemon,2060,tcp,Telenium Daemon IF,[Nick_Woronuk],[Nick_Woronuk],,,,,,
+teleniumdaemon,2060,udp,Telenium Daemon IF,[Nick_Woronuk],[Nick_Woronuk],,,,,,
+netmount,2061,tcp,NetMount,[Alex_Oberlander],[Alex_Oberlander],,,,,,
+netmount,2061,udp,NetMount,[Alex_Oberlander],[Alex_Oberlander],,,,,,
+icg-swp,2062,tcp,ICG SWP Port,,,,,,,,
+icg-swp,2062,udp,ICG SWP Port,,,,,,,,
+icg-bridge,2063,tcp,ICG Bridge Port,,,,,,,,
+icg-bridge,2063,udp,ICG Bridge Port,,,,,,,,
+icg-iprelay,2064,tcp,ICG IP Relay Port,[Steve_Quintana],[Steve_Quintana],,,,,,
+icg-iprelay,2064,udp,ICG IP Relay Port,[Steve_Quintana],[Steve_Quintana],,,,,,
+dlsrpn,2065,tcp,Data Link Switch Read Port Number,[Amir_Peless],[Amir_Peless],,,,,,
+dlsrpn,2065,udp,Data Link Switch Read Port Number,[Amir_Peless],[Amir_Peless],,,,,,
+aura,2066,tcp,AVM USB Remote Architecture,[Diego_Friedel],[Diego_Friedel],2006-03,,,,,
+aura,2066,udp,AVM USB Remote Architecture,[Diego_Friedel],[Diego_Friedel],2006-03,,,,,
+dlswpn,2067,tcp,Data Link Switch Write Port Number,[Amir_Peless],[Amir_Peless],,,,,,
+dlswpn,2067,udp,Data Link Switch Write Port Number,[Amir_Peless],[Amir_Peless],,,,,,
+avauthsrvprtcl,2068,tcp,Avocent AuthSrv Protocol,[Steven_W_Clark_2],[Steven_W_Clark_2],,,,,,
+avauthsrvprtcl,2068,udp,Avocent AuthSrv Protocol,[Steven_W_Clark_2],[Steven_W_Clark_2],,,,,,
+event-port,2069,tcp,HTTP Event Port,[Larry_Emlich],[Larry_Emlich],,,,,,
+event-port,2069,udp,HTTP Event Port,[Larry_Emlich],[Larry_Emlich],,,,,,
+ah-esp-encap,2070,tcp,AH and ESP Encapsulated in UDP packet,[Amy_Weaver],[Amy_Weaver],,,,,,
+ah-esp-encap,2070,udp,AH and ESP Encapsulated in UDP packet,[Amy_Weaver],[Amy_Weaver],,,,,,
+acp-port,2071,tcp,Axon Control Protocol,[Christiaan_Simons],[Christiaan_Simons],,,,,,
+acp-port,2071,udp,Axon Control Protocol,[Christiaan_Simons],[Christiaan_Simons],,,,,,
+msync,2072,tcp,GlobeCast mSync,[Piers_Scannell_2],[Piers_Scannell_2],,,,,,
+msync,2072,udp,GlobeCast mSync,[Piers_Scannell_2],[Piers_Scannell_2],,,,,,
+gxs-data-port,2073,tcp,DataReel Database Socket,[Douglas_M_Gaer],[Douglas_M_Gaer],,,,,,
+gxs-data-port,2073,udp,DataReel Database Socket,[Douglas_M_Gaer],[Douglas_M_Gaer],,,,,,
+vrtl-vmf-sa,2074,tcp,Vertel VMF SA,[Alan_Akahoshi],[Alan_Akahoshi],,,,,,
+vrtl-vmf-sa,2074,udp,Vertel VMF SA,[Alan_Akahoshi],[Alan_Akahoshi],,,,,,
+newlixengine,2075,tcp,Newlix ServerWare Engine,,,,,,,,
+newlixengine,2075,udp,Newlix ServerWare Engine,,,,,,,,
+newlixconfig,2076,tcp,Newlix JSPConfig,[Jean_Serge_Gagnon],[Jean_Serge_Gagnon],,,,,,
+newlixconfig,2076,udp,Newlix JSPConfig,[Jean_Serge_Gagnon],[Jean_Serge_Gagnon],,,,,,
+tsrmagt,2077,tcp,Old Tivoli Storage Manager,,,,,,,,
+tsrmagt,2077,udp,Old Tivoli Storage Manager,,,,,,,,
+tpcsrvr,2078,tcp,IBM Total Productivity Center Server,[Justin_R_Bendich],[Justin_R_Bendich],,,,,,
+tpcsrvr,2078,udp,IBM Total Productivity Center Server,[Justin_R_Bendich],[Justin_R_Bendich],,,,,,
+idware-router,2079,tcp,IDWARE Router Port,[Zdenek_Kolba],[Zdenek_Kolba],,,,,,
+idware-router,2079,udp,IDWARE Router Port,[Zdenek_Kolba],[Zdenek_Kolba],,,,,,
+autodesk-nlm,2080,tcp,Autodesk NLM (FLEXlm),[Greg_Suppes],[Greg_Suppes],,,,,,
+autodesk-nlm,2080,udp,Autodesk NLM (FLEXlm),[Greg_Suppes],[Greg_Suppes],,,,,,
+kme-trap-port,2081,tcp,KME PRINTER TRAP PORT,[Masakatsu_Matsuo],[Masakatsu_Matsuo],,,,,,
+kme-trap-port,2081,udp,KME PRINTER TRAP PORT,[Masakatsu_Matsuo],[Masakatsu_Matsuo],,,,,,
+infowave,2082,tcp,Infowave Mobility Server,[Kaz_Kylheku],[Kaz_Kylheku],,,,,,
+infowave,2082,udp,Infowave Mobility Server,[Kaz_Kylheku],[Kaz_Kylheku],,,,,,
+radsec,2083,tcp,Secure Radius Service,[IESG],[IETF_Chair],2005-05,,[RFC6614],,,"The TCP port 2083 was already
+ previously assigned by IANA for ""RadSec"", an early implementation
+ of RADIUS/TLS, prior to issuance of this RFC. This early
+ implementation can be configured to be compatible to RADIUS/TLS as
+ specified by the IETF. See [RFC6614],
+ Appendix A for details."
+radsec,2083,udp,Secure Radius Service,[IESG],[IETF_Chair],2005-05,2014-07-14,[RFC7360],,,"The UDP port 2083 was already previously assigned by IANA for
+ ""RadSec"", an early implementation of RADIUS/TLS, prior to issuance of this
+ RFC."
+sunclustergeo,2084,tcp,SunCluster Geographic,[Oracle_2],[Steve_McKinty],2005-11,2013-08-14,,,,
+sunclustergeo,2084,udp,SunCluster Geographic,[Oracle_2],[Steve_McKinty],2005-11,2013-08-14,,,,
+ada-cip,2085,tcp,ADA Control,[Eugene_Frenkel],[Eugene_Frenkel],2005-11,,,,,
+ada-cip,2085,udp,ADA Control,[Eugene_Frenkel],[Eugene_Frenkel],2005-11,,,,,
+gnunet,2086,tcp,GNUnet,[Christian_Grothoff],[Christian_Grothoff],2002-10,,,,,
+gnunet,2086,udp,GNUnet,[Christian_Grothoff],[Christian_Grothoff],2002-10,,,,,
+eli,2087,tcp,ELI - Event Logging Integration,[Maya_Zimerman],[Maya_Zimerman],,,,,,
+eli,2087,udp,ELI - Event Logging Integration,[Maya_Zimerman],[Maya_Zimerman],,,,,,
+ip-blf,2088,tcp,IP Busy Lamp Field,[Jeffrey_Szczepanski],[Jeffrey_Szczepanski],2005-02,,,,,
+ip-blf,2088,udp,IP Busy Lamp Field,[Jeffrey_Szczepanski],[Jeffrey_Szczepanski],2005-02,,,,,
+sep,2089,tcp,Security Encapsulation Protocol - SEP,[Maya_Zimerman],[Maya_Zimerman],,,,,,
+sep,2089,udp,Security Encapsulation Protocol - SEP,[Maya_Zimerman],[Maya_Zimerman],,,,,,
+lrp,2090,tcp,Load Report Protocol,[Amir_Peless],[Amir_Peless],,,,,,
+lrp,2090,udp,Load Report Protocol,[Amir_Peless],[Amir_Peless],,,,,,
+prp,2091,tcp,PRP,[Amir_Peless],[Amir_Peless],,,,,,
+prp,2091,udp,PRP,[Amir_Peless],[Amir_Peless],,,,,,
+descent3,2092,tcp,Descent 3,[Kevin_Bentley],[Kevin_Bentley],,,,,,
+descent3,2092,udp,Descent 3,[Kevin_Bentley],[Kevin_Bentley],,,,,,
+nbx-cc,2093,tcp,NBX CC,,,,,,,,
+nbx-cc,2093,udp,NBX CC,,,,,,,,
+nbx-au,2094,tcp,NBX AU,,,,,,,,
+nbx-au,2094,udp,NBX AU,,,,,,,,
+nbx-ser,2095,tcp,NBX SER,,,,,,,,
+nbx-ser,2095,udp,NBX SER,,,,,,,,
+nbx-dir,2096,tcp,NBX DIR,[Henry_Houh],[Henry_Houh],,,,,,
+nbx-dir,2096,udp,NBX DIR,[Henry_Houh],[Henry_Houh],,,,,,
+jetformpreview,2097,tcp,Jet Form Preview,[Zygmunt_Wiercioch],[Zygmunt_Wiercioch],,,,,,
+jetformpreview,2097,udp,Jet Form Preview,[Zygmunt_Wiercioch],[Zygmunt_Wiercioch],,,,,,
+dialog-port,2098,tcp,Dialog Port,[Joseph_Mathew],[Joseph_Mathew],,,,,,
+dialog-port,2098,udp,Dialog Port,[Joseph_Mathew],[Joseph_Mathew],,,,,,
+h2250-annex-g,2099,tcp,H.225.0 Annex G Signalling,[ITU-T],[ITU-T_TSB],,2013-01-31,,,,
+h2250-annex-g,2099,udp,H.225.0 Annex G Signalling,[ITU-T],[ITU-T_TSB],,2013-01-31,,,,
+amiganetfs,2100,tcp,Amiga Network Filesystem,[Rudi_Chiarito],[Rudi_Chiarito],,,,,,
+amiganetfs,2100,udp,Amiga Network Filesystem,[Rudi_Chiarito],[Rudi_Chiarito],,,,,,
+rtcm-sc104,2101,tcp,rtcm-sc104,[Wolfgang_Rupprecht],[Wolfgang_Rupprecht],,,,,,
+rtcm-sc104,2101,udp,rtcm-sc104,[Wolfgang_Rupprecht],[Wolfgang_Rupprecht],,,,,,
+zephyr-srv,2102,tcp,Zephyr server,,,,,,,,
+zephyr-srv,2102,udp,Zephyr server,,,,,,,,
+zephyr-clt,2103,tcp,Zephyr serv-hm connection,,,,,,,,
+zephyr-clt,2103,udp,Zephyr serv-hm connection,,,,,,,,
+zephyr-hm,2104,tcp,Zephyr hostmanager,[Greg_Hudson],[Greg_Hudson],,,,,,
+zephyr-hm,2104,udp,Zephyr hostmanager,[Greg_Hudson],[Greg_Hudson],,,,,,
+minipay,2105,tcp,MiniPay,[Amir_Herzberg],[Amir_Herzberg],,,,,,
+minipay,2105,udp,MiniPay,[Amir_Herzberg],[Amir_Herzberg],,,,,,
+mzap,2106,tcp,MZAP,[Dave_Thaler_2],[Dave_Thaler_2],,,,,,
+mzap,2106,udp,MZAP,[Dave_Thaler_2],[Dave_Thaler_2],,,,,,
+bintec-admin,2107,tcp,BinTec Admin,[Thomas_Schmidt],[Thomas_Schmidt],,,,,,
+bintec-admin,2107,udp,BinTec Admin,[Thomas_Schmidt],[Thomas_Schmidt],,,,,,
+comcam,2108,tcp,Comcam,[Don_Gilbreath],[Don_Gilbreath],,,,,,
+comcam,2108,udp,Comcam,[Don_Gilbreath],[Don_Gilbreath],,,,,,
+ergolight,2109,tcp,Ergolight,[Jindra_Ryvola],[Jindra_Ryvola],,,,,,
+ergolight,2109,udp,Ergolight,[Jindra_Ryvola],[Jindra_Ryvola],,,,,,
+umsp,2110,tcp,UMSP,[Alexander_Bogdanov_2],[Alexander_Bogdanov_2],,,,,,
+umsp,2110,udp,UMSP,[Alexander_Bogdanov_2],[Alexander_Bogdanov_2],,,,,,
+dsatp,2111,tcp,OPNET Dynamic Sampling Agent Transaction Protocol,[OPNET_Technologies_Inc],[Edward_Macomber],,2011-09-21,,,,
+dsatp,2111,udp,OPNET Dynamic Sampling Agent Transaction Protocol,[OPNET_Technologies_Inc],[Edward_Macomber],,2011-09-21,,,,
+idonix-metanet,2112,tcp,Idonix MetaNet,[Paul_Harrison],[Paul_Harrison],,,,,,
+idonix-metanet,2112,udp,Idonix MetaNet,[Paul_Harrison],[Paul_Harrison],,,,,,
+hsl-storm,2113,tcp,HSL StoRM,[Jost_Faganel],[Jost_Faganel],,,,,,
+hsl-storm,2113,udp,HSL StoRM,[Jost_Faganel],[Jost_Faganel],,,,,,
+newheights,2114,tcp,NEWHEIGHTS,[Michael_Levy],[Michael_Levy],,,,,,
+newheights,2114,udp,NEWHEIGHTS,[Michael_Levy],[Michael_Levy],,,,,,
+kdm,2115,tcp,Key Distribution Manager,[Mike_Little],[Mike_Little],,,,,,
+kdm,2115,udp,Key Distribution Manager,[Mike_Little],[Mike_Little],,,,,,
+ccowcmr,2116,tcp,CCOWCMR,[Mark_Morwood],[Mark_Morwood],,,,,,
+ccowcmr,2116,udp,CCOWCMR,[Mark_Morwood],[Mark_Morwood],,,,,,
+mentaclient,2117,tcp,MENTACLIENT,,,,,,,,
+mentaclient,2117,udp,MENTACLIENT,,,,,,,,
+mentaserver,2118,tcp,MENTASERVER,[Ilan_Shlosberg],[Ilan_Shlosberg],,,,,,
+mentaserver,2118,udp,MENTASERVER,[Ilan_Shlosberg],[Ilan_Shlosberg],,,,,,
+gsigatekeeper,2119,tcp,GSIGATEKEEPER,[Steve_Tuecke],[Steve_Tuecke],,,,,,
+gsigatekeeper,2119,udp,GSIGATEKEEPER,[Steve_Tuecke],[Steve_Tuecke],,,,,,
+qencp,2120,tcp,Quick Eagle Networks CP,[Santa_Dasu],[Santa_Dasu],,,,,,
+qencp,2120,udp,Quick Eagle Networks CP,[Santa_Dasu],[Santa_Dasu],,,,,,
+scientia-ssdb,2121,tcp,SCIENTIA-SSDB,[SYSTEMS_MANAGER],[SYSTEMS_MANAGER],,,,,,
+scientia-ssdb,2121,udp,SCIENTIA-SSDB,[SYSTEMS_MANAGER],[SYSTEMS_MANAGER],,,,,,
+caupc-remote,2122,tcp,CauPC Remote Control,[Environics_Oy],[Environics_Oy],,,,,,
+caupc-remote,2122,udp,CauPC Remote Control,[Environics_Oy],[Environics_Oy],,,,,,
+gtp-control,2123,tcp,GTP-Control Plane (3GPP),[Alessio_Casati],[Alessio_Casati],,,,,,
+gtp-control,2123,udp,GTP-Control Plane (3GPP),[Alessio_Casati],[Alessio_Casati],,,,,,
+elatelink,2124,tcp,ELATELINK,[Tim_Lawrence],[Tim_Lawrence],,,,,,
+elatelink,2124,udp,ELATELINK,[Tim_Lawrence],[Tim_Lawrence],,,,,,
+lockstep,2125,tcp,LOCKSTEP,[Karl_Forster],[Karl_Forster],,,,,,
+lockstep,2125,udp,LOCKSTEP,[Karl_Forster],[Karl_Forster],,,,,,
+pktcable-cops,2126,tcp,PktCable-COPS,[Glenn_Russell],[Glenn_Russell],,,,,,
+pktcable-cops,2126,udp,PktCable-COPS,[Glenn_Russell],[Glenn_Russell],,,,,,
+index-pc-wb,2127,tcp,INDEX-PC-WB,[James_David_Fisher],[James_David_Fisher],,,,,,
+index-pc-wb,2127,udp,INDEX-PC-WB,[James_David_Fisher],[James_David_Fisher],,,,,,
+net-steward,2128,tcp,Net Steward Control,[Martin_Norman],[Martin_Norman],,,,,,
+net-steward,2128,udp,Net Steward Control,[Martin_Norman],[Martin_Norman],,,,,,
+cs-live,2129,tcp,cs-live.com,[Matt_Lachance],[Matt_Lachance],,,,,,
+cs-live,2129,udp,cs-live.com,[Matt_Lachance],[Matt_Lachance],,,,,,
+xds,2130,tcp,XDS,[Peter_Zurich],[Peter_Zurich],,,,,,
+xds,2130,udp,XDS,[Peter_Zurich],[Peter_Zurich],,,,,,
+avantageb2b,2131,tcp,Avantageb2b,[Avi_Software],[Avi_Software],,,,,,
+avantageb2b,2131,udp,Avantageb2b,[Avi_Software],[Avi_Software],,,,,,
+solera-epmap,2132,tcp,SoleraTec End Point Map,[Mark_Armstrong],[Mark_Armstrong],,,,,,
+solera-epmap,2132,udp,SoleraTec End Point Map,[Mark_Armstrong],[Mark_Armstrong],,,,,,
+zymed-zpp,2133,tcp,ZYMED-ZPP,[Gregg_Welker],[Gregg_Welker],,,,,,
+zymed-zpp,2133,udp,ZYMED-ZPP,[Gregg_Welker],[Gregg_Welker],,,,,,
+avenue,2134,tcp,AVENUE,[Jason_Cater],[Jason_Cater],,,,,,
+avenue,2134,udp,AVENUE,[Jason_Cater],[Jason_Cater],,,,,,
+gris,2135,tcp,Grid Resource Information Server,[Steve_Tuecke],[Steve_Tuecke],,,,,,
+gris,2135,udp,Grid Resource Information Server,[Steve_Tuecke],[Steve_Tuecke],,,,,,
+appworxsrv,2136,tcp,APPWORXSRV,[Fred_McLain],[Fred_McLain],,,,,,
+appworxsrv,2136,udp,APPWORXSRV,[Fred_McLain],[Fred_McLain],,,,,,
+connect,2137,tcp,CONNECT,[Reid_Ligon],[Reid_Ligon],,,,,,
+connect,2137,udp,CONNECT,[Reid_Ligon],[Reid_Ligon],,,,,,
+unbind-cluster,2138,tcp,UNBIND-CLUSTER,[Francois_Harvey],[Francois_Harvey],,,,,,
+unbind-cluster,2138,udp,UNBIND-CLUSTER,[Francois_Harvey],[Francois_Harvey],,,,,,
+ias-auth,2139,tcp,IAS-AUTH,,,,,,,,
+ias-auth,2139,udp,IAS-AUTH,,,,,,,,
+ias-reg,2140,tcp,IAS-REG,,,,,,,,
+ias-reg,2140,udp,IAS-REG,,,,,,,,
+ias-admind,2141,tcp,IAS-ADMIND,[Baiju_V_Patel],[Baiju_V_Patel],,,,,,
+ias-admind,2141,udp,IAS-ADMIND,[Baiju_V_Patel],[Baiju_V_Patel],,,,,,
+tdmoip,2142,tcp,TDM OVER IP,,,,,[RFC5087],,,
+tdmoip,2142,udp,TDM OVER IP,,,,,[RFC5087],,,
+lv-jc,2143,tcp,Live Vault Job Control,,,,,,,,
+lv-jc,2143,udp,Live Vault Job Control,,,,,,,,
+lv-ffx,2144,tcp,Live Vault Fast Object Transfer,,,,,,,,
+lv-ffx,2144,udp,Live Vault Fast Object Transfer,,,,,,,,
+lv-pici,2145,tcp,Live Vault Remote Diagnostic Console Support,,,,,,,,
+lv-pici,2145,udp,Live Vault Remote Diagnostic Console Support,,,,,,,,
+lv-not,2146,tcp,Live Vault Admin Event Notification,,,,,,,,
+lv-not,2146,udp,Live Vault Admin Event Notification,,,,,,,,
+lv-auth,2147,tcp,Live Vault Authentication,[Ted_Hess],[Ted_Hess],,,,,,
+lv-auth,2147,udp,Live Vault Authentication,[Ted_Hess],[Ted_Hess],,,,,,
+veritas-ucl,2148,tcp,VERITAS UNIVERSAL COMMUNICATION LAYER,[Songlin_Ren],[Songlin_Ren],,,,,,
+veritas-ucl,2148,udp,VERITAS UNIVERSAL COMMUNICATION LAYER,[Songlin_Ren],[Songlin_Ren],,,,,,
+acptsys,2149,tcp,ACPTSYS,[Michael_Lekias],[Michael_Lekias],,,,,,
+acptsys,2149,udp,ACPTSYS,[Michael_Lekias],[Michael_Lekias],,,,,,
+dynamic3d,2150,tcp,DYNAMIC3D,[Tobias_Wegner],[Tobias_Wegner],,,,,,
+dynamic3d,2150,udp,DYNAMIC3D,[Tobias_Wegner],[Tobias_Wegner],,,,,,
+docent,2151,tcp,DOCENT,[Hali_Lindbloom],[Hali_Lindbloom],,,,,,
+docent,2151,udp,DOCENT,[Hali_Lindbloom],[Hali_Lindbloom],,,,,,
+gtp-user,2152,tcp,GTP-User Plane (3GPP),[Alessio_Casati],[Alessio_Casati],,,,,,
+gtp-user,2152,udp,GTP-User Plane (3GPP),[Alessio_Casati],[Alessio_Casati],,,,,,
+ctlptc,2153,tcp,Control Protocol,,,,,,,,
+ctlptc,2153,udp,Control Protocol,,,,,,,,
+stdptc,2154,tcp,Standard Protocol,,,,,,,,
+stdptc,2154,udp,Standard Protocol,,,,,,,,
+brdptc,2155,tcp,Bridge Protocol,[Hideki_Hatta],[Hideki_Hatta],2007-09-27,,,,,
+brdptc,2155,udp,Bridge Protocol,[Hideki_Hatta],[Hideki_Hatta],2007-09-27,,,,,
+trp,2156,tcp,Talari Reliable Protocol,[John_E_Dickey],[John_E_Dickey],2007-09-27,,,,,
+trp,2156,udp,Talari Reliable Protocol,[John_E_Dickey],[John_E_Dickey],2007-09-27,,,,,
+xnds,2157,tcp,Xerox Network Document Scan Protocol,[William_R_Lear],[William_R_Lear],2008-03-06,,,,,
+xnds,2157,udp,Xerox Network Document Scan Protocol,[William_R_Lear],[William_R_Lear],2008-03-06,,,,,
+touchnetplus,2158,tcp,TouchNetPlus Service,[Brian_Toothill],[Brian_Toothill],2008-03-06,,,,,
+touchnetplus,2158,udp,TouchNetPlus Service,[Brian_Toothill],[Brian_Toothill],2008-03-06,,,,,
+gdbremote,2159,tcp,GDB Remote Debug Port,[Nigel_Stephens],[Nigel_Stephens],,,,,,
+gdbremote,2159,udp,GDB Remote Debug Port,[Nigel_Stephens],[Nigel_Stephens],,,,,,
+apc-2160,2160,tcp,APC 2160,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-2160,2160,udp,APC 2160,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-2161,2161,tcp,APC 2161,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-2161,2161,udp,APC 2161,[American_Power_Conve],[American_Power_Conve],,,,,,
+navisphere,2162,tcp,Navisphere,,,,,,,,
+navisphere,2162,udp,Navisphere,,,,,,,,
+navisphere-sec,2163,tcp,Navisphere Secure,[Andreas_Bauer],[Andreas_Bauer],,,,,,
+navisphere-sec,2163,udp,Navisphere Secure,[Andreas_Bauer],[Andreas_Bauer],,,,,,
+ddns-v3,2164,tcp,Dynamic DNS Version 3,[Alan_Yates],[Alan_Yates],,,,,,
+ddns-v3,2164,udp,Dynamic DNS Version 3,[Alan_Yates],[Alan_Yates],,,,,,
+x-bone-api,2165,tcp,X-Bone API,[Joe_Touch],[Joe_Touch],,,,,,
+x-bone-api,2165,udp,X-Bone API,[Joe_Touch],[Joe_Touch],,,,,,
+iwserver,2166,tcp,iwserver,[Fred_Surr],[Fred_Surr],,,,,,
+iwserver,2166,udp,iwserver,[Fred_Surr],[Fred_Surr],,,,,,
+raw-serial,2167,tcp,Raw Async Serial Link,[Benjamin_Green],[Benjamin_Green],,,,,,
+raw-serial,2167,udp,Raw Async Serial Link,[Benjamin_Green],[Benjamin_Green],,,,,,
+easy-soft-mux,2168,tcp,easy-soft Multiplexer,[Norbert_Kintzler],[Norbert_Kintzler],2004-11,,,,,
+easy-soft-mux,2168,udp,easy-soft Multiplexer,[Norbert_Kintzler],[Norbert_Kintzler],2004-11,,,,,
+brain,2169,tcp,Backbone for Academic Information Notification (BRAIN),[Archishmat_Gore],[Archishmat_Gore],2004-11,,,,,
+brain,2169,udp,Backbone for Academic Information Notification (BRAIN),[Archishmat_Gore],[Archishmat_Gore],2004-11,,,,,
+eyetv,2170,tcp,EyeTV Server Port,[Elgato_Systems],[Elgato_Systems],2004-11,,,,,
+eyetv,2170,udp,EyeTV Server Port,[Elgato_Systems],[Elgato_Systems],2004-11,,,,,
+msfw-storage,2171,tcp,MS Firewall Storage,,,,,,,,
+msfw-storage,2171,udp,MS Firewall Storage,,,,,,,,
+msfw-s-storage,2172,tcp,MS Firewall SecureStorage,,,,,,,,
+msfw-s-storage,2172,udp,MS Firewall SecureStorage,,,,,,,,
+msfw-replica,2173,tcp,MS Firewall Replication,,,,,,,,
+msfw-replica,2173,udp,MS Firewall Replication,,,,,,,,
+msfw-array,2174,tcp,MS Firewall Intra Array,[Itai_Greenberg],[Itai_Greenberg],2004-11,,,,,
+msfw-array,2174,udp,MS Firewall Intra Array,[Itai_Greenberg],[Itai_Greenberg],2004-11,,,,,
+airsync,2175,tcp,Microsoft Desktop AirSync Protocol,,,,,,,,
+airsync,2175,udp,Microsoft Desktop AirSync Protocol,,,,,,,,
+rapi,2176,tcp,Microsoft ActiveSync Remote API,[Jon_Xu],[Jon_Xu],2005-08,,,,,
+rapi,2176,udp,Microsoft ActiveSync Remote API,[Jon_Xu],[Jon_Xu],2005-08,,,,,
+qwave,2177,tcp,qWAVE Bandwidth Estimate,[Gabe_Frost],[Gabe_Frost],2005-08,,,,,
+qwave,2177,udp,qWAVE Bandwidth Estimate,[Gabe_Frost],[Gabe_Frost],2005-08,,,,,
+bitspeer,2178,tcp,Peer Services for BITS,[Jeff_Roberts],[Jeff_Roberts],2005-11,,,,,
+bitspeer,2178,udp,Peer Services for BITS,[Jeff_Roberts],[Jeff_Roberts],2005-11,,,,,
+vmrdp,2179,tcp,Microsoft RDP for virtual machines,[Brian_Henry],[Brian_Henry],2007-03,,,,,
+vmrdp,2179,udp,Microsoft RDP for virtual machines,[Brian_Henry],[Brian_Henry],2007-03,,,,,
+mc-gt-srv,2180,tcp,Millicent Vendor Gateway Server,[Steve_Glassman],[Steve_Glassman],,,,,,
+mc-gt-srv,2180,udp,Millicent Vendor Gateway Server,[Steve_Glassman],[Steve_Glassman],,,,,,
+eforward,2181,tcp,eforward,[Greg_Pringle],[Greg_Pringle],,,,,,
+eforward,2181,udp,eforward,[Greg_Pringle],[Greg_Pringle],,,,,,
+cgn-stat,2182,tcp,CGN status,,,,,,,,
+cgn-stat,2182,udp,CGN status,,,,,,,,
+cgn-config,2183,tcp,Code Green configuration,[Chris_Michaelson],[Chris_Michaelson],2005-08,,,,,
+cgn-config,2183,udp,Code Green configuration,[Chris_Michaelson],[Chris_Michaelson],2005-08,,,,,
+nvd,2184,tcp,NVD User,[Yves_Gattegno],[Yves_Gattegno],2004-12,,,,,
+nvd,2184,udp,NVD User,[Yves_Gattegno],[Yves_Gattegno],2004-12,,,,,
+onbase-dds,2185,tcp,OnBase Distributed Disk Services,[Paul_Tam],[Paul_Tam],2004-12,,,,,
+onbase-dds,2185,udp,OnBase Distributed Disk Services,[Paul_Tam],[Paul_Tam],2004-12,,,,,
+gtaua,2186,tcp,Guy-Tek Automated Update Applications,[Daniel_Story],[Daniel_Story],2008-01-25,,,,,
+gtaua,2186,udp,Guy-Tek Automated Update Applications,[Daniel_Story],[Daniel_Story],2008-01-25,,,,,
+ssmc,2187,tcp,Sepehr System Management Control,,,,,,,,
+ssmd,2187,udp,Sepehr System Management Data,[Shahriar_Pourazin],[Shahriar_Pourazin],2008-12-02,,,,,
+radware-rpm,2188,tcp,Radware Resource Pool Manager,[Radware_LTD],[Samuel_Bercovici],2011-08-05,,,,,
+,2188,udp,Reserved,,,,,,,,
+radware-rpm-s,2189,tcp,Secure Radware Resource Pool Manager,[Radware_LTD],[Samuel_Bercovici],2011-08-05,,,,,
+,2189,udp,Reserved,,,,,,,,
+tivoconnect,2190,tcp,TiVoConnect Beacon,[Jeffrey_J_Peters],[Jeffrey_J_Peters],2002-08,,,,,
+tivoconnect,2190,udp,TiVoConnect Beacon,[Jeffrey_J_Peters],[Jeffrey_J_Peters],2002-08,,,,,
+tvbus,2191,tcp,TvBus Messaging,[Brian_W_Beach],[Brian_W_Beach],2003-01,,,,,
+tvbus,2191,udp,TvBus Messaging,[Brian_W_Beach],[Brian_W_Beach],2003-01,,,,,
+asdis,2192,tcp,ASDIS software management,[ASDIS_Support],[ASDIS_Support],2005-08,,,,,
+asdis,2192,udp,ASDIS software management,[ASDIS_Support],[ASDIS_Support],2005-08,,,,,
+drwcs,2193,tcp,Dr.Web Enterprise Management Service,[Eugeny_Gladkih],[Eugeny_Gladkih],2008-01-31,,,,,
+drwcs,2193,udp,Dr.Web Enterprise Management Service,[Eugeny_Gladkih],[Eugeny_Gladkih],2008-01-31,,,,,
+,2194-2196,,Unassigned,,,,,,,Unauthorized Use Known on ports 2194-2196,
+mnp-exchange,2197,tcp,MNP data exchange,[Peter_Pramberger],[Peter_Pramberger],2004-11,,,,,
+mnp-exchange,2197,udp,MNP data exchange,[Peter_Pramberger],[Peter_Pramberger],2004-11,,,,,
+onehome-remote,2198,tcp,OneHome Remote Access,,,,,,,,
+onehome-remote,2198,udp,OneHome Remote Access,,,,,,,,
+onehome-help,2199,tcp,OneHome Service Port,[Jim_Herman],[Jim_Herman],2005-08,,,,,
+onehome-help,2199,udp,OneHome Service Port,[Jim_Herman],[Jim_Herman],2005-08,,,,,
+ici,2200,tcp,ICI,[Brent_Hines],[Brent_Hines],,,,,,
+ici,2200,udp,ICI,[Brent_Hines],[Brent_Hines],,,,,,
+ats,2201,tcp,Advanced Training System Program,,,,,,,,
+ats,2201,udp,Advanced Training System Program,,,,,,,,
+imtc-map,2202,tcp,Int. Multimedia Teleconferencing Cosortium,[Pat_Galvin],[Pat_Galvin],,,,,,
+imtc-map,2202,udp,Int. Multimedia Teleconferencing Cosortium,[Pat_Galvin],[Pat_Galvin],,,,,,
+b2-runtime,2203,tcp,b2 Runtime Protocol,,,,,,,,
+b2-runtime,2203,udp,b2 Runtime Protocol,,,,,,,,
+b2-license,2204,tcp,b2 License Server,[Helge_Frank_Zimpel],[Helge_Frank_Zimpel],2006-01,,,,,
+b2-license,2204,udp,b2 License Server,[Helge_Frank_Zimpel],[Helge_Frank_Zimpel],2006-01,,,,,
+jps,2205,tcp,Java Presentation Server,[Leif_Jakob],[Leif_Jakob],2006-01,,,,,
+jps,2205,udp,Java Presentation Server,[Leif_Jakob],[Leif_Jakob],2006-01,,,,,
+hpocbus,2206,tcp,HP OpenCall bus,[Jerome_Forissier],[Jerome_Forissier],2005-12,,,,,
+hpocbus,2206,udp,HP OpenCall bus,[Jerome_Forissier],[Jerome_Forissier],2005-12,,,,,
+hpssd,2207,tcp,HP Status and Services,[Donald_Welch],[Donald_Welch],2006-05,,,,,
+hpssd,2207,udp,HP Status and Services,[Donald_Welch],[Donald_Welch],2006-05,,,,,
+hpiod,2208,tcp,HP I/O Backend,[David_Suffield],[David_Suffield],2006-05,,,,,
+hpiod,2208,udp,HP I/O Backend,[David_Suffield],[David_Suffield],2006-05,,,,,
+rimf-ps,2209,tcp,HP RIM for Files Portal Service,[Patty_Ho],[Patty_Ho],2007-05,,,,,
+rimf-ps,2209,udp,HP RIM for Files Portal Service,[Patty_Ho],[Patty_Ho],2007-05,,,,,
+noaaport,2210,tcp,NOAAPORT Broadcast Network,,,,,,,,
+noaaport,2210,udp,NOAAPORT Broadcast Network,,,,,,,,
+emwin,2211,tcp,EMWIN,[Antonio_Querubin],[Antonio_Querubin],2008-03-10,,,,,
+emwin,2211,udp,EMWIN,[Antonio_Querubin],[Antonio_Querubin],2008-03-10,,,,,
+leecoposserver,2212,tcp,LeeCO POS Server Service,[Patrick_Lee],[Patrick_Lee],2008-03-10,,,,,
+leecoposserver,2212,udp,LeeCO POS Server Service,[Patrick_Lee],[Patrick_Lee],2008-03-10,,,,,
+kali,2213,tcp,Kali,[Jay_Cotton],[Jay_Cotton],,,,,,
+kali,2213,udp,Kali,[Jay_Cotton],[Jay_Cotton],,,,,,
+rpi,2214,tcp,RDQ Protocol Interface,[Les_Mather],[Les_Mather],2005-12,,,,,
+rpi,2214,udp,RDQ Protocol Interface,[Les_Mather],[Les_Mather],2005-12,,,,,
+ipcore,2215,tcp,IPCore.co.za GPRS,[Administrator],[Administrator],2005-12,,,,,
+ipcore,2215,udp,IPCore.co.za GPRS,[Administrator],[Administrator],2005-12,,,,,
+vtu-comms,2216,tcp,VTU data service,[David_Barrass],[David_Barrass],2006-01,,,,,
+vtu-comms,2216,udp,VTU data service,[David_Barrass],[David_Barrass],2006-01,,,,,
+gotodevice,2217,tcp,GoToDevice Device Management,[John_Lisek],[John_Lisek],2006-01,,,,,
+gotodevice,2217,udp,GoToDevice Device Management,[John_Lisek],[John_Lisek],2006-01,,,,,
+bounzza,2218,tcp,Bounzza IRC Proxy,[Danko_Alexeyev],[Danko_Alexeyev],2006-02,,,,,
+bounzza,2218,udp,Bounzza IRC Proxy,[Danko_Alexeyev],[Danko_Alexeyev],2006-02,,,,,
+netiq-ncap,2219,tcp,NetIQ NCAP Protocol,[Roger_Huebner],[Roger_Huebner],2010-08-25,,,,,
+netiq-ncap,2219,udp,NetIQ NCAP Protocol,[Roger_Huebner],[Roger_Huebner],2010-08-25,,,,,
+netiq,2220,tcp,NetIQ End2End,[Michael_Sharpe],[Michael_Sharpe],2010-09-14,,,,,
+netiq,2220,udp,NetIQ End2End,[Michael_Sharpe],[Michael_Sharpe],2010-09-14,,,,,
+rockwell-csp1,2221,tcp,Rockwell CSP1,[Brian_Batke],[Brian_Batke],,,,,,
+rockwell-csp1,2221,udp,Rockwell CSP1,[Brian_Batke],[Brian_Batke],,,,,,
+EtherNet-IP-1,2222,tcp,"EtherNet/IP I/O
+IANA assigned this well-formed service name as a replacement for ""EtherNet/IP-1"".",[Brian_Batke_2],[Brian_Batke_2],,,,,,New contact added for port 2222 on 2008-02-01
+EtherNet/IP-1,2222,tcp,EtherNet/IP I/O,[Brian_Batke_2],[Brian_Batke_2],,,,,,"New contact added for port 2222 on 2008-02-01
+This entry is an alias to ""EtherNet-IP-1"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+EtherNet-IP-1,2222,udp,"EtherNet/IP I/O
+IANA assigned this well-formed service name as a replacement for ""EtherNet/IP-1"".",[Brian_Batke_2],[Brian_Batke_2],,,,,,New contact added for port 2222 on 2008-02-01
+EtherNet/IP-1,2222,udp,EtherNet/IP I/O,[Brian_Batke_2],[Brian_Batke_2],,,,,,"New contact added for port 2222 on 2008-02-01
+This entry is an alias to ""EtherNet-IP-1"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+rockwell-csp2,2223,tcp,Rockwell CSP2,[Brian_Batke],[Brian_Batke],,,,,,
+rockwell-csp2,2223,udp,Rockwell CSP2,[Brian_Batke],[Brian_Batke],,,,,,
+efi-mg,2224,tcp,Easy Flexible Internet/Multiplayer Games,[Thomas_Efer],[Thomas_Efer],2006-03,,,,,
+efi-mg,2224,udp,Easy Flexible Internet/Multiplayer Games,[Thomas_Efer],[Thomas_Efer],2006-03,,,,,
+rcip-itu,2225,tcp,Resource Connection Initiation Protocol,[ITU_TSB],[ITU_TSB],,,,,,
+,2225,udp,Reserved,,,,,,,,
+rcip-itu,2225,sctp,Resource Connection Initiation Protocol,[ITU_TSB],[ITU_TSB],,,,,,
+di-drm,2226,tcp,Digital Instinct DRM,,,,,,,,
+di-drm,2226,udp,Digital Instinct DRM,,,,,,,,
+di-msg,2227,tcp,DI Messaging Service,[Sean_Ni],[Sean_Ni],2006-02,,,,,
+di-msg,2227,udp,DI Messaging Service,[Sean_Ni],[Sean_Ni],2006-02,,,,,
+ehome-ms,2228,tcp,eHome Message Server,[Peter_Gabriel],[Peter_Gabriel],2006-01,,,,,
+ehome-ms,2228,udp,eHome Message Server,[Peter_Gabriel],[Peter_Gabriel],2006-01,,,,,
+datalens,2229,tcp,DataLens Service,[Christopher_Bidwell],[Christopher_Bidwell],2006-02,,,,,
+datalens,2229,udp,DataLens Service,[Christopher_Bidwell],[Christopher_Bidwell],2006-02,,,,,
+queueadm,2230,tcp,MetaSoft Job Queue Administration Service,[Ilya_Melamed],[Ilya_Melamed],2006-06,,,,,
+queueadm,2230,udp,MetaSoft Job Queue Administration Service,[Ilya_Melamed],[Ilya_Melamed],2006-06,,,,,
+wimaxasncp,2231,tcp,WiMAX ASN Control Plane Protocol,[Prakash_Iyer],[Prakash_Iyer],2006-06,,,,,
+wimaxasncp,2231,udp,WiMAX ASN Control Plane Protocol,[Prakash_Iyer],[Prakash_Iyer],2006-06,,,,,
+ivs-video,2232,tcp,IVS Video default,[Thierry_Turletti],[Thierry_Turletti],,,,,,
+ivs-video,2232,udp,IVS Video default,[Thierry_Turletti],[Thierry_Turletti],,,,,,
+infocrypt,2233,tcp,INFOCRYPT,[Erica_Liu],[Erica_Liu],,,,,,
+infocrypt,2233,udp,INFOCRYPT,[Erica_Liu],[Erica_Liu],,,,,,
+directplay,2234,tcp,DirectPlay,[Ajay_Jindal],[Ajay_Jindal],,,,,,
+directplay,2234,udp,DirectPlay,[Ajay_Jindal],[Ajay_Jindal],,,,,,
+sercomm-wlink,2235,tcp,Sercomm-WLink,[Melinda_Tsao],[Melinda_Tsao],,,,,,
+sercomm-wlink,2235,udp,Sercomm-WLink,[Melinda_Tsao],[Melinda_Tsao],,,,,,
+nani,2236,tcp,Nani,[Steve_Benoit],[Steve_Benoit],,,,,,
+nani,2236,udp,Nani,[Steve_Benoit],[Steve_Benoit],,,,,,
+optech-port1-lm,2237,tcp,Optech Port1 License Manager,[Gerard_Cannie],[Gerard_Cannie],,,,,,
+optech-port1-lm,2237,udp,Optech Port1 License Manager,[Gerard_Cannie],[Gerard_Cannie],,,,,,
+aviva-sna,2238,tcp,AVIVA SNA SERVER,[Vick_Keshishian],[Vick_Keshishian],,,,,,
+aviva-sna,2238,udp,AVIVA SNA SERVER,[Vick_Keshishian],[Vick_Keshishian],,,,,,
+imagequery,2239,tcp,Image Query,[Charles_Jacobs],[Charles_Jacobs],,,,,,
+imagequery,2239,udp,Image Query,[Charles_Jacobs],[Charles_Jacobs],,,,,,
+recipe,2240,tcp,RECIPe,[Charlie_Limoges],[Charlie_Limoges],1997-12-16,,,,,
+recipe,2240,udp,RECIPe,[Charlie_Limoges],[Charlie_Limoges],1997-12-16,,,,,
+ivsd,2241,tcp,IVS Daemon,[Thierry_Turletti],[Thierry_Turletti],,,,,,
+ivsd,2241,udp,IVS Daemon,[Thierry_Turletti],[Thierry_Turletti],,,,,,
+foliocorp,2242,tcp,Folio Remote Server,[Pat_Mcgowan],[Pat_Mcgowan],,,,,,
+foliocorp,2242,udp,Folio Remote Server,[Pat_Mcgowan],[Pat_Mcgowan],,,,,,
+magicom,2243,tcp,Magicom Protocol,[Yossi_Appleboum],[Yossi_Appleboum],,,,,,
+magicom,2243,udp,Magicom Protocol,[Yossi_Appleboum],[Yossi_Appleboum],,,,,,
+nmsserver,2244,tcp,NMS Server,[Dmitry_Krasnonosenki],[Dmitry_Krasnonosenki],,,,,,
+nmsserver,2244,udp,NMS Server,[Dmitry_Krasnonosenki],[Dmitry_Krasnonosenki],,,,,,
+hao,2245,tcp,HaO,[Panic_Ride],[Panic_Ride],,,,,,
+hao,2245,udp,HaO,[Panic_Ride],[Panic_Ride],,,,,,
+pc-mta-addrmap,2246,tcp,PacketCable MTA Addr Map,[Dave_Maxwell],[Dave_Maxwell],,,,,,
+pc-mta-addrmap,2246,udp,PacketCable MTA Addr Map,[Dave_Maxwell],[Dave_Maxwell],,,,,,
+antidotemgrsvr,2247,tcp,Antidote Deployment Manager Service,[Rod_Waltermann],[Rod_Waltermann],2006-02,,,,,
+antidotemgrsvr,2247,udp,Antidote Deployment Manager Service,[Rod_Waltermann],[Rod_Waltermann],2006-02,,,,,
+ums,2248,tcp,User Management Service,[Andrew_Crockford],[Andrew_Crockford],,,,,,
+ums,2248,udp,User Management Service,[Andrew_Crockford],[Andrew_Crockford],,,,,,
+rfmp,2249,tcp,RISO File Manager Protocol,[Shinji_Yamanaka],[Shinji_Yamanaka],,,,,,
+rfmp,2249,udp,RISO File Manager Protocol,[Shinji_Yamanaka],[Shinji_Yamanaka],,,,,,
+remote-collab,2250,tcp,remote-collab,[Richard_Walters],[Richard_Walters],,,,,,
+remote-collab,2250,udp,remote-collab,[Richard_Walters],[Richard_Walters],,,,,,
+dif-port,2251,tcp,Distributed Framework Port,[Sebastien_Lambla],[Sebastien_Lambla],,,,,,
+dif-port,2251,udp,Distributed Framework Port,[Sebastien_Lambla],[Sebastien_Lambla],,,,,,
+njenet-ssl,2252,tcp,NJENET using SSL,[Hans_U_Schmidt],[Hans_U_Schmidt],,,,,,
+njenet-ssl,2252,udp,NJENET using SSL,[Hans_U_Schmidt],[Hans_U_Schmidt],,,,,,
+dtv-chan-req,2253,tcp,DTV Channel Request,[Richard_Hodges],[Richard_Hodges],,,,,,
+dtv-chan-req,2253,udp,DTV Channel Request,[Richard_Hodges],[Richard_Hodges],,,,,,
+seispoc,2254,tcp,Seismic P.O.C. Port,[Robert_Reimiller],[Robert_Reimiller],,,,,,
+seispoc,2254,udp,Seismic P.O.C. Port,[Robert_Reimiller],[Robert_Reimiller],,,,,,
+vrtp,2255,tcp,VRTP - ViRtue Transfer Protocol,[Max_Fudim],[Max_Fudim],,,,,,
+vrtp,2255,udp,VRTP - ViRtue Transfer Protocol,[Max_Fudim],[Max_Fudim],,,,,,
+pcc-mfp,2256,tcp,PCC MFP,[Kunihiko_Morota],[Kunihiko_Morota],2005-08,,,,,
+pcc-mfp,2256,udp,PCC MFP,[Kunihiko_Morota],[Kunihiko_Morota],2005-08,,,,,
+simple-tx-rx,2257,tcp,simple text/file transfer,[Daniel_Kilsdonk],[Daniel_Kilsdonk],2006-08,,,,,
+simple-tx-rx,2257,udp,simple text/file transfer,[Daniel_Kilsdonk],[Daniel_Kilsdonk],2006-08,,,,,
+rcts,2258,tcp,Rotorcraft Communications Test System,[Terry_Eldridge],[Terry_Eldridge],2006-08,,,,,
+rcts,2258,udp,Rotorcraft Communications Test System,[Terry_Eldridge],[Terry_Eldridge],2006-08,,,,,
+,2259,,Unassigned,,,,2011-06-28,,,,
+apc-2260,2260,tcp,APC 2260,[American_Power_Conve],[American_Power_Conve],2002-02,,,,,
+apc-2260,2260,udp,APC 2260,[American_Power_Conve],[American_Power_Conve],2002-02,,,,,
+comotionmaster,2261,tcp,CoMotion Master Server,,,,,,,,
+comotionmaster,2261,udp,CoMotion Master Server,,,,,,,,
+comotionback,2262,tcp,CoMotion Backup Server,[Friedman_Wagner_Dobl],[Friedman_Wagner_Dobl],2005-09,,,,,
+comotionback,2262,udp,CoMotion Backup Server,[Friedman_Wagner_Dobl],[Friedman_Wagner_Dobl],2005-09,,,,,
+ecwcfg,2263,tcp,ECweb Configuration Service,[Anders_Hjelm],[Anders_Hjelm],2006-03,,,,,
+ecwcfg,2263,udp,ECweb Configuration Service,[Anders_Hjelm],[Anders_Hjelm],2006-03,,,,,
+apx500api-1,2264,tcp,Audio Precision Apx500 API Port 1,,,,,,,,
+apx500api-1,2264,udp,Audio Precision Apx500 API Port 1,,,,,,,,
+apx500api-2,2265,tcp,Audio Precision Apx500 API Port 2,[Robert_Wright],[Robert_Wright],,,,,,
+apx500api-2,2265,udp,Audio Precision Apx500 API Port 2,[Robert_Wright],[Robert_Wright],,,,,,
+mfserver,2266,tcp,M-Files Server,[Samppa_Lahtinen],[Samppa_Lahtinen],2004-06,,,,,
+mfserver,2266,udp,M-files Server,[Samppa_Lahtinen],[Samppa_Lahtinen],2004-06,,,,,
+ontobroker,2267,tcp,OntoBroker,[Dr_Michael_Erdmann],[Dr_Michael_Erdmann],2004-12,,,,,
+ontobroker,2267,udp,OntoBroker,[Dr_Michael_Erdmann],[Dr_Michael_Erdmann],2004-12,,,,,
+amt,2268,tcp,AMT,[Tom_Pusateri],[Tom_Pusateri],2004-12,,,,,
+amt,2268,udp,AMT,[Tom_Pusateri],[Tom_Pusateri],2004-12,,,,,
+mikey,2269,tcp,MIKEY,[Karl_Norrman],[Karl_Norrman],2004-12,,,,,
+mikey,2269,udp,MIKEY,[Karl_Norrman],[Karl_Norrman],2004-12,,,,,
+starschool,2270,tcp,starSchool,[Adam_Ernst],[Adam_Ernst],2004-12,,,,,
+starschool,2270,udp,starSchool,[Adam_Ernst],[Adam_Ernst],2004-12,,,,,
+mmcals,2271,tcp,Secure Meeting Maker Scheduling,,,,,,,,
+mmcals,2271,udp,Secure Meeting Maker Scheduling,,,,,,,,
+mmcal,2272,tcp,Meeting Maker Scheduling,[Andrew_H_Derbyshire],[Andrew_H_Derbyshire],2004-12,,,,,
+mmcal,2272,udp,Meeting Maker Scheduling,[Andrew_H_Derbyshire],[Andrew_H_Derbyshire],2004-12,,,,,
+mysql-im,2273,tcp,MySQL Instance Manager,[Petr_Chardin],[Petr_Chardin],2004-12,,,,,
+mysql-im,2273,udp,MySQL Instance Manager,[Petr_Chardin],[Petr_Chardin],2004-12,,,,,
+pcttunnell,2274,tcp,PCTTunneller,[ProControl_Technolog],[ProControl_Technolog],2004-12,,,,,
+pcttunnell,2274,udp,PCTTunneller,[ProControl_Technolog],[ProControl_Technolog],2004-12,,,,,
+ibridge-data,2275,tcp,iBridge Conferencing,,,,,,,,
+ibridge-data,2275,udp,iBridge Conferencing,,,,,,,,
+ibridge-mgmt,2276,tcp,iBridge Management,[Patrick_Fisher],[Patrick_Fisher],2004-12,,,,,
+ibridge-mgmt,2276,udp,iBridge Management,[Patrick_Fisher],[Patrick_Fisher],2004-12,,,,,
+bluectrlproxy,2277,tcp,Bt device control proxy,[Mark_de_Rooi],[Mark_de_Rooi],2004-12,,,,,
+bluectrlproxy,2277,udp,Bt device control proxy,[Mark_de_Rooi],[Mark_de_Rooi],2004-12,,,,,
+s3db,2278,tcp,Simple Stacked Sequences Database,[David_Brandon],[David_Brandon],2006-08,,,,,
+s3db,2278,udp,Simple Stacked Sequences Database,[David_Brandon],[David_Brandon],2006-08,,,,,
+xmquery,2279,tcp,xmquery,[Niels_Christiansen],[Niels_Christiansen],,,,,,
+xmquery,2279,udp,xmquery,[Niels_Christiansen],[Niels_Christiansen],,,,,,
+lnvpoller,2280,tcp,LNVPOLLER,,,,,,,,
+lnvpoller,2280,udp,LNVPOLLER,,,,,,,,
+lnvconsole,2281,tcp,LNVCONSOLE,,,,,,,,
+lnvconsole,2281,udp,LNVCONSOLE,,,,,,,,
+lnvalarm,2282,tcp,LNVALARM,,,,,,,,
+lnvalarm,2282,udp,LNVALARM,,,,,,,,
+lnvstatus,2283,tcp,LNVSTATUS,,,,,,,,
+lnvstatus,2283,udp,LNVSTATUS,,,,,,,,
+lnvmaps,2284,tcp,LNVMAPS,,,,,,,,
+lnvmaps,2284,udp,LNVMAPS,,,,,,,,
+lnvmailmon,2285,tcp,LNVMAILMON,[John_Payne],[John_Payne],,,,,,
+lnvmailmon,2285,udp,LNVMAILMON,[John_Payne],[John_Payne],,,,,,
+nas-metering,2286,tcp,NAS-Metering,[Steven_Sawkins],[Steven_Sawkins],,,,,,
+nas-metering,2286,udp,NAS-Metering,[Steven_Sawkins],[Steven_Sawkins],,,,,,
+dna,2287,tcp,DNA,[Tung_Nguyen],[Tung_Nguyen],,,,,,
+dna,2287,udp,DNA,[Tung_Nguyen],[Tung_Nguyen],,,,,,
+netml,2288,tcp,NETML,[Jochen_Hansmeyer],[Jochen_Hansmeyer],,,,,,
+netml,2288,udp,NETML,[Jochen_Hansmeyer],[Jochen_Hansmeyer],,,,,,
+dict-lookup,2289,tcp,Lookup dict server,[William_Fernando_Mat],[William_Fernando_Mat],2005-01,,,,,
+dict-lookup,2289,udp,Lookup dict server,[William_Fernando_Mat],[William_Fernando_Mat],2005-01,,,,,
+sonus-logging,2290,tcp,Sonus Logging Services,[Adwait_Sathe],[Adwait_Sathe],2005-08,,,,,
+sonus-logging,2290,udp,Sonus Logging Services,[Adwait_Sathe],[Adwait_Sathe],2005-08,,,,,
+eapsp,2291,tcp,EPSON Advanced Printer Share Protocol,[SEIKO_EPSON],[SEIKO_EPSON],2006-06,,,,,
+eapsp,2291,udp,EPSON Advanced Printer Share Protocol,[SEIKO_EPSON],[SEIKO_EPSON],2006-06,,,,,
+mib-streaming,2292,tcp,Sonus Element Management Services,[Linda_Lin],[Linda_Lin],2006-08,,,,,
+mib-streaming,2292,udp,Sonus Element Management Services,[Linda_Lin],[Linda_Lin],2006-08,,,,,
+npdbgmngr,2293,tcp,Network Platform Debug Manager,[Robert_Byrne],[Robert_Byrne],2006-09,,,,,
+npdbgmngr,2293,udp,Network Platform Debug Manager,[Robert_Byrne],[Robert_Byrne],2006-09,,,,,
+konshus-lm,2294,tcp,Konshus License Manager (FLEX),[Francois_Painchaud],[Francois_Painchaud],,,,,,
+konshus-lm,2294,udp,Konshus License Manager (FLEX),[Francois_Painchaud],[Francois_Painchaud],,,,,,
+advant-lm,2295,tcp,Advant License Manager,[Lars_Goran_Magnusson],[Lars_Goran_Magnusson],,,,,,
+advant-lm,2295,udp,Advant License Manager,[Lars_Goran_Magnusson],[Lars_Goran_Magnusson],,,,,,
+theta-lm,2296,tcp,Theta License Manager (Rainbow),[David_Thompson],[David_Thompson],,,,,,
+theta-lm,2296,udp,Theta License Manager (Rainbow),[David_Thompson],[David_Thompson],,,,,,
+d2k-datamover1,2297,tcp,D2K DataMover 1,,,,,,,,
+d2k-datamover1,2297,udp,D2K DataMover 1,,,,,,,,
+d2k-datamover2,2298,tcp,D2K DataMover 2,[Eric_Lan],[Eric_Lan],,,,,,
+d2k-datamover2,2298,udp,D2K DataMover 2,[Eric_Lan],[Eric_Lan],,,,,,
+pc-telecommute,2299,tcp,PC Telecommute,[John_Daniel_Bonamico],[John_Daniel_Bonamico],,,,,,
+pc-telecommute,2299,udp,PC Telecommute,[John_Daniel_Bonamico],[John_Daniel_Bonamico],,,,,,
+cvmmon,2300,tcp,CVMMON,[Roger_Kumpf],[Roger_Kumpf],,,,,,
+cvmmon,2300,udp,CVMMON,[Roger_Kumpf],[Roger_Kumpf],,,,,,
+cpq-wbem,2301,tcp,Compaq HTTP,[Scott_Shaffer],[Scott_Shaffer],,,,,,
+cpq-wbem,2301,udp,Compaq HTTP,[Scott_Shaffer],[Scott_Shaffer],,,,,,
+binderysupport,2302,tcp,Bindery Support,[Narasimha_Rao_N],[Narasimha_Rao_N],,,,,,
+binderysupport,2302,udp,Bindery Support,[Narasimha_Rao_N],[Narasimha_Rao_N],,,,,,
+proxy-gateway,2303,tcp,Proxy Gateway,[Paul_Funk],[Paul_Funk],,,,,,
+proxy-gateway,2303,udp,Proxy Gateway,[Paul_Funk],[Paul_Funk],,,,,,
+attachmate-uts,2304,tcp,Attachmate UTS,[George_Gianelos],[George_Gianelos],,,,,,
+attachmate-uts,2304,udp,Attachmate UTS,[George_Gianelos],[George_Gianelos],,,,,,
+mt-scaleserver,2305,tcp,MT ScaleServer,[Paul_Glaubitz],[Paul_Glaubitz],,,,,,
+mt-scaleserver,2305,udp,MT ScaleServer,[Paul_Glaubitz],[Paul_Glaubitz],,,,,,
+tappi-boxnet,2306,tcp,TAPPI BoxNet,[Richard_Spartz],[Richard_Spartz],,,,,,
+tappi-boxnet,2306,udp,TAPPI BoxNet,[Richard_Spartz],[Richard_Spartz],,,,,,
+pehelp,2307,tcp,pehelp,[Jens_Kilian],[Jens_Kilian],,,,,,
+pehelp,2307,udp,pehelp,[Jens_Kilian],[Jens_Kilian],,,,,,
+sdhelp,2308,tcp,sdhelp,[Annette_Klecha],[Annette_Klecha],,,,,,
+sdhelp,2308,udp,sdhelp,[Annette_Klecha],[Annette_Klecha],,,,,,
+sdserver,2309,tcp,SD Server,,,,,,,,
+sdserver,2309,udp,SD Server,,,,,,,,
+sdclient,2310,tcp,SD Client,[Jeurgen_Broesamle],[Jeurgen_Broesamle],,,,,,
+sdclient,2310,udp,SD Client,[Jeurgen_Broesamle],[Jeurgen_Broesamle],,,,,,
+messageservice,2311,tcp,Message Service,,,,,,,,
+messageservice,2311,udp,Message Service,,,,,,,,
+wanscaler,2312,tcp,WANScaler Communication Service,[Allen_Samuels],[Allen_Samuels],2006-11,,,,,
+wanscaler,2312,udp,WANScaler Communication Service,[Allen_Samuels],[Allen_Samuels],2006-11,,,,,
+iapp,2313,tcp,IAPP (Inter Access Point Protocol),[Henri_Moelard],[Henri_Moelard],,,,,,
+iapp,2313,udp,IAPP (Inter Access Point Protocol),[Henri_Moelard],[Henri_Moelard],,,,,,
+cr-websystems,2314,tcp,CR WebSystems,[Robin_Giese],[Robin_Giese],,,,,,
+cr-websystems,2314,udp,CR WebSystems,[Robin_Giese],[Robin_Giese],,,,,,
+precise-sft,2315,tcp,Precise Sft.,[Michael_Landwehr],[Michael_Landwehr],,,,,,
+precise-sft,2315,udp,Precise Sft.,[Michael_Landwehr],[Michael_Landwehr],,,,,,
+sent-lm,2316,tcp,SENT License Manager,[Pisharath_Krishnan],[Pisharath_Krishnan],,,,,,
+sent-lm,2316,udp,SENT License Manager,[Pisharath_Krishnan],[Pisharath_Krishnan],,,,,,
+attachmate-g32,2317,tcp,Attachmate G32,[Bryce_Bhatnagar],[Bryce_Bhatnagar],,,,,,
+attachmate-g32,2317,udp,Attachmate G32,[Bryce_Bhatnagar],[Bryce_Bhatnagar],,,,,,
+cadencecontrol,2318,tcp,Cadence Control,[Buck_Caldwell],[Buck_Caldwell],,,,,,
+cadencecontrol,2318,udp,Cadence Control,[Buck_Caldwell],[Buck_Caldwell],,,,,,
+infolibria,2319,tcp,InfoLibria,[Chris_Chiotasso],[Chris_Chiotasso],,,,,,
+infolibria,2319,udp,InfoLibria,[Chris_Chiotasso],[Chris_Chiotasso],,,,,,
+siebel-ns,2320,tcp,Siebel NS,[Gilberto_Arnaiz],[Gilberto_Arnaiz],,,,,,
+siebel-ns,2320,udp,Siebel NS,[Gilberto_Arnaiz],[Gilberto_Arnaiz],,,,,,
+rdlap,2321,tcp,RDLAP,[Robert_Wiebe],[Robert_Wiebe],,,,,,
+rdlap,2321,udp,RDLAP,[Robert_Wiebe],[Robert_Wiebe],,,,,,
+ofsd,2322,tcp,ofsd,,,,,,,,
+ofsd,2322,udp,ofsd,,,,,,,,
+3d-nfsd,2323,tcp,3d-nfsd,[Mike_Sherrill],[Mike_Sherrill],,,,,,
+3d-nfsd,2323,udp,3d-nfsd,[Mike_Sherrill],[Mike_Sherrill],,,,,,
+cosmocall,2324,tcp,Cosmocall,[Steve_Dellutri],[Steve_Dellutri],,,,,,
+cosmocall,2324,udp,Cosmocall,[Steve_Dellutri],[Steve_Dellutri],,,,,,
+ansysli,2325,tcp,ANSYS Licensing Interconnect,[Suzanne_Lorrin],[Suzanne_Lorrin],,,,,,Modified: 27 October 2008
+ansysli,2325,udp,ANSYS Licensing Interconnect,[Suzanne_Lorrin],[Suzanne_Lorrin],,,,,,Modified: 27 October 2008
+idcp,2326,tcp,IDCP,[Keisokugiken_Corp],[Keisokugiken_Corp],,,,,,
+idcp,2326,udp,IDCP,[Keisokugiken_Corp],[Keisokugiken_Corp],,,,,,
+xingcsm,2327,tcp,xingcsm,[Dave_Spencer],[Dave_Spencer],,,,,,
+xingcsm,2327,udp,xingcsm,[Dave_Spencer],[Dave_Spencer],,,,,,
+netrix-sftm,2328,tcp,Netrix SFTM,[Garrett_Herschleb],[Garrett_Herschleb],,,,,,
+netrix-sftm,2328,udp,Netrix SFTM,[Garrett_Herschleb],[Garrett_Herschleb],,,,,,
+nvd,2329,tcp,NVD,[Peter_Weyman],[Peter_Weyman],,,,,,
+nvd,2329,udp,NVD,[Peter_Weyman],[Peter_Weyman],,,,,,
+tscchat,2330,tcp,TSCCHAT,[Mike_Jackson],[Mike_Jackson],,,,,,
+tscchat,2330,udp,TSCCHAT,[Mike_Jackson],[Mike_Jackson],,,,,,
+agentview,2331,tcp,AGENTVIEW,[Ram_Iyer],[Ram_Iyer],,,,,,
+agentview,2331,udp,AGENTVIEW,[Ram_Iyer],[Ram_Iyer],,,,,,
+rcc-host,2332,tcp,RCC Host,[Martin_Shoemaker],[Martin_Shoemaker],,,,,,
+rcc-host,2332,udp,RCC Host,[Martin_Shoemaker],[Martin_Shoemaker],,,,,,
+snapp,2333,tcp,SNAPP,[Dan_Burrows],[Dan_Burrows],2009-09-25,,,,,
+snapp,2333,udp,SNAPP,[Dan_Burrows],[Dan_Burrows],2009-09-25,,,,,
+ace-client,2334,tcp,ACE Client Auth,,,,,,,,
+ace-client,2334,udp,ACE Client Auth,,,,,,,,
+ace-proxy,2335,tcp,ACE Proxy,[Riaz_Zolfonoon],[Riaz_Zolfonoon],,,,,,
+ace-proxy,2335,udp,ACE Proxy,[Riaz_Zolfonoon],[Riaz_Zolfonoon],,,,,,
+appleugcontrol,2336,tcp,Apple UG Control,[Gene_Tyacke],[Gene_Tyacke],,,,,,
+appleugcontrol,2336,udp,Apple UG Control,[Gene_Tyacke],[Gene_Tyacke],,,,,,
+ideesrv,2337,tcp,ideesrv,[Marazzi],[Marazzi],,,,,,
+ideesrv,2337,udp,ideesrv,[Marazzi],[Marazzi],,,,,,
+norton-lambert,2338,tcp,Norton Lambert,[Richard_de_Mornay],[Richard_de_Mornay],,,,,,
+norton-lambert,2338,udp,Norton Lambert,[Richard_de_Mornay],[Richard_de_Mornay],,,,,,
+3com-webview,2339,tcp,3Com WebView,[Jennifer_Grace],[Jennifer_Grace],,,,,,
+3com-webview,2339,udp,3Com WebView,[Jennifer_Grace],[Jennifer_Grace],,,,,,
+wrs-registry,2340,tcp,"WRS Registry
+IANA assigned this well-formed service name as a replacement for ""wrs_registry"".",[Christophe_Cleraux],[Christophe_Cleraux],,,,,,
+wrs_registry,2340,tcp,WRS Registry,[Christophe_Cleraux],[Christophe_Cleraux],,,,,,"This entry is an alias to ""wrs-registry"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+wrs-registry,2340,udp,"WRS Registry
+IANA assigned this well-formed service name as a replacement for ""wrs_registry"".",[Christophe_Cleraux],[Christophe_Cleraux],,,,,,
+wrs_registry,2340,udp,WRS Registry,[Christophe_Cleraux],[Christophe_Cleraux],,,,,,"This entry is an alias to ""wrs-registry"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+xiostatus,2341,tcp,XIO Status,[Randy_Maas],[Randy_Maas],,,,,,
+xiostatus,2341,udp,XIO Status,[Randy_Maas],[Randy_Maas],,,,,,
+manage-exec,2342,tcp,Seagate Manage Exec,[Jim_Flaherty],[Jim_Flaherty],,,,,,
+manage-exec,2342,udp,Seagate Manage Exec,[Jim_Flaherty],[Jim_Flaherty],,,,,,
+nati-logos,2343,tcp,nati logos,[James_Juhasz],[James_Juhasz],,,,,,
+nati-logos,2343,udp,nati logos,[James_Juhasz],[James_Juhasz],,,,,,
+fcmsys,2344,tcp,fcmsys,,,,,,,,
+fcmsys,2344,udp,fcmsys,,,,,,,,
+dbm,2345,tcp,dbm,[Dean_Robson],[Dean_Robson],,,,,,
+dbm,2345,udp,dbm,[Dean_Robson],[Dean_Robson],,,,,,
+redstorm-join,2346,tcp,"Game Connection Port
+IANA assigned this well-formed service name as a replacement for ""redstorm_join"".",,,,,,,,
+redstorm_join,2346,tcp,Game Connection Port,,,,,,,,"This entry is an alias to ""redstorm-join"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+redstorm-join,2346,udp,"Game Connection Port
+IANA assigned this well-formed service name as a replacement for ""redstorm_join"".",,,,,,,,
+redstorm_join,2346,udp,Game Connection Port,,,,,,,,"This entry is an alias to ""redstorm-join"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+redstorm-find,2347,tcp,"Game Announcement and Location
+IANA assigned this well-formed service name as a replacement for ""redstorm_find"".",,,,,,,,
+redstorm_find,2347,tcp,Game Announcement and Location,,,,,,,,"This entry is an alias to ""redstorm-find"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+redstorm-find,2347,udp,"Game Announcement and Location
+IANA assigned this well-formed service name as a replacement for ""redstorm_find"".",,,,,,,,
+redstorm_find,2347,udp,Game Announcement and Location,,,,,,,,"This entry is an alias to ""redstorm-find"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+redstorm-info,2348,tcp,"Information to query for game status
+IANA assigned this well-formed service name as a replacement for ""redstorm_info"".",,,,,,,,
+redstorm_info,2348,tcp,Information to query for game status,,,,,,,,"This entry is an alias to ""redstorm-info"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+redstorm-info,2348,udp,"Information to query for game status
+IANA assigned this well-formed service name as a replacement for ""redstorm_info"".",,,,,,,,
+redstorm_info,2348,udp,Information to query for game status,,,,,,,,"This entry is an alias to ""redstorm-info"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+redstorm-diag,2349,tcp,"Diagnostics Port
+IANA assigned this well-formed service name as a replacement for ""redstorm_diag"".",[David_Weinstein],[David_Weinstein],,,,,,
+redstorm_diag,2349,tcp,Diagnostics Port,[David_Weinstein],[David_Weinstein],,,,,,"This entry is an alias to ""redstorm-diag"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+redstorm-diag,2349,udp,"Diagnostics Port
+IANA assigned this well-formed service name as a replacement for ""redstorm_diag"".",[David_Weinstein],[David_Weinstein],,,,,,
+redstorm_diag,2349,udp,Diagnostics Port,[David_Weinstein],[David_Weinstein],,,,,,"This entry is an alias to ""redstorm-diag"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+psbserver,2350,tcp,Pharos Booking Server,,,,,,,,
+psbserver,2350,udp,Pharos Booking Server,,,,,,,,
+psrserver,2351,tcp,psrserver,,,,,,,,
+psrserver,2351,udp,psrserver,,,,,,,,
+pslserver,2352,tcp,pslserver,,,,,,,,
+pslserver,2352,udp,pslserver,,,,,,,,
+pspserver,2353,tcp,pspserver,,,,,,,,
+pspserver,2353,udp,pspserver,,,,,,,,
+psprserver,2354,tcp,psprserver,,,,,,,,
+psprserver,2354,udp,psprserver,,,,,,,,
+psdbserver,2355,tcp,psdbserver,[Paul_Reddy],[Paul_Reddy],,,,,,
+psdbserver,2355,udp,psdbserver,[Paul_Reddy],[Paul_Reddy],,,,,,
+gxtelmd,2356,tcp,GXT License Managemant,[Robert_Hodgson],[Robert_Hodgson],,,,,,
+gxtelmd,2356,udp,GXT License Managemant,[Robert_Hodgson],[Robert_Hodgson],,,,,,
+unihub-server,2357,tcp,UniHub Server,[Tim_Kenyon],[Tim_Kenyon],,,,,,
+unihub-server,2357,udp,UniHub Server,[Tim_Kenyon],[Tim_Kenyon],,,,,,
+futrix,2358,tcp,Futrix,[Peter_Frankenberg],[Peter_Frankenberg],,,,,,
+futrix,2358,udp,Futrix,[Peter_Frankenberg],[Peter_Frankenberg],,,,,,
+flukeserver,2359,tcp,FlukeServer,[Bill_Marbaker],[Bill_Marbaker],,,,,,
+flukeserver,2359,udp,FlukeServer,[Bill_Marbaker],[Bill_Marbaker],,,,,,
+nexstorindltd,2360,tcp,NexstorIndLtd,[NexStor_India_Limite],[NexStor_India_Limite],,,,,,
+nexstorindltd,2360,udp,NexstorIndLtd,[NexStor_India_Limite],[NexStor_India_Limite],,,,,,
+tl1,2361,tcp,TL1,[Charles_Scott_Robers],[Charles_Scott_Robers],,,,,,
+tl1,2361,udp,TL1,[Charles_Scott_Robers],[Charles_Scott_Robers],,,,,,
+digiman,2362,tcp,digiman,[Aaron_S_Kurland],[Aaron_S_Kurland],,,,,,
+digiman,2362,udp,digiman,[Aaron_S_Kurland],[Aaron_S_Kurland],,,,,,
+mediacntrlnfsd,2363,tcp,Media Central NFSD,[Shivakumar_S_Govind],[Shivakumar_S_Govind],,,,,,
+mediacntrlnfsd,2363,udp,Media Central NFSD,[Shivakumar_S_Govind],[Shivakumar_S_Govind],,,,,,
+oi-2000,2364,tcp,OI-2000,[Software_Horizons_In],[Software_Horizons_In],,,,,,
+oi-2000,2364,udp,OI-2000,[Software_Horizons_In],[Software_Horizons_In],,,,,,
+dbref,2365,tcp,dbref,[Yoshihiro_Yamazaki],[Yoshihiro_Yamazaki],,,,,,
+dbref,2365,udp,dbref,[Yoshihiro_Yamazaki],[Yoshihiro_Yamazaki],,,,,,
+qip-login,2366,tcp,qip-login,[Mike_Morgan],[Mike_Morgan],,,,,,
+qip-login,2366,udp,qip-login,[Mike_Morgan],[Mike_Morgan],,,,,,
+service-ctrl,2367,tcp,Service Control,[Humberto_Sanchez],[Humberto_Sanchez],,,,,,
+service-ctrl,2367,udp,Service Control,[Humberto_Sanchez],[Humberto_Sanchez],,,,,,
+opentable,2368,tcp,OpenTable,[Brett_Goldstein],[Brett_Goldstein],,,,,,
+opentable,2368,udp,OpenTable,[Brett_Goldstein],[Brett_Goldstein],,,,,,
+,2369,,Unassigned,,,,,,,,De-registered (28 March 2006)
+l3-hbmon,2370,tcp,L3-HBMon,[Dolores_Scott],[Dolores_Scott],,2014-04-09,,,,
+l3-hbmon,2370,udp,L3-HBMon,[Dolores_Scott],[Dolores_Scott],,2014-04-09,,,,
+hp-rda,2371,tcp,HP Remote Device Access,[Hewlett_Packard_3],[Michael_Spratte][Steve_Roscio],,2014-04-09,,,,
+,2371,udp,Reserved,,,,2014-04-09,,,,
+lanmessenger,2372,tcp,LanMessenger,[Garrett_Padera],[Garrett_Padera],2008-02-01,,,,,
+lanmessenger,2372,udp,LanMessenger,[Garrett_Padera],[Garrett_Padera],2008-02-01,,,,,
+remographlm,2373,tcp,Remograph License Manager,[Per_Fahlberg],[Per_Fahlberg],2009-01-21,,,,,
+,2373,udp,Reserved,,,,,,,,
+hydra,2374,tcp,Hydra RPC,[Jacob_Feisley],[Jacob_Feisley],2009-01-21,,,,,
+,2374,udp,Reserved,,,,,,,,
+docker,2375,tcp,Docker REST API (plain text),[DOCKER],[Christopher_Liljenstolpe],2014-04-17,,,,,
+,2375,udp,Reserved,,,,,,,,
+docker-s,2376,tcp,Docker REST API (ssl),[DOCKER],[Christopher_Liljenstolpe],2014-04-17,,,,,
+,2377-2378,,Unassigned,,,,,,,,
+etcd-client,2379,tcp,etcd client communication,[CoreOS],[Brian_Harrington],2014-07-09,,,,,
+,2379,udp,Reserved,,,,,,,,
+etcd-server,2380,tcp,etcd server to server communication,[CoreOS],[Brian_Harrington],2014-07-09,,,,,
+,2380,udp,Reserved,,,,,,,,
+compaq-https,2381,tcp,Compaq HTTPS,[Scott_Shaffer],[Scott_Shaffer],,,,,,
+compaq-https,2381,udp,Compaq HTTPS,[Scott_Shaffer],[Scott_Shaffer],,,,,,
+ms-olap3,2382,tcp,Microsoft OLAP,,,,,,,,
+ms-olap3,2382,udp,Microsoft OLAP,,,,,,,,
+ms-olap4,2383,tcp,Microsoft OLAP,[Mosha_Pasumansky],[Mosha_Pasumansky],,,,,,
+ms-olap4,2383,udp,Microsoft OLAP,[Mosha_Pasumansky],[Mosha_Pasumansky],,,,,,
+sd-request,2384,tcp,SD-REQUEST,,,,,,,,
+sd-capacity,2384,udp,SD-CAPACITY,[Jason_McManus_2],[Jason_McManus_2],,,,,,
+sd-data,2385,tcp,SD-DATA,[Jason_McManus_2],[Jason_McManus_2],,,,,,
+sd-data,2385,udp,SD-DATA,[Jason_McManus_2],[Jason_McManus_2],,,,,,
+virtualtape,2386,tcp,Virtual Tape,,,,,,,,
+virtualtape,2386,udp,Virtual Tape,,,,,,,,
+vsamredirector,2387,tcp,VSAM Redirector,[Ingo_Franzki],[Ingo_Franzki],,,,,,
+vsamredirector,2387,udp,VSAM Redirector,[Ingo_Franzki],[Ingo_Franzki],,,,,,
+mynahautostart,2388,tcp,MYNAH AutoStart,[Thomas_J_Klehr],[Thomas_J_Klehr],,,,,,
+mynahautostart,2388,udp,MYNAH AutoStart,[Thomas_J_Klehr],[Thomas_J_Klehr],,,,,,
+ovsessionmgr,2389,tcp,OpenView Session Mgr,[Eric_Pulsipher],[Eric_Pulsipher],,,,,,
+ovsessionmgr,2389,udp,OpenView Session Mgr,[Eric_Pulsipher],[Eric_Pulsipher],,,,,,
+rsmtp,2390,tcp,RSMTP,[Geoff_Collyer],[Geoff_Collyer],,,,,,
+rsmtp,2390,udp,RSMTP,[Geoff_Collyer],[Geoff_Collyer],,,,,,
+3com-net-mgmt,2391,tcp,3COM Net Management,[Prathibha_Nagvar],[Prathibha_Nagvar],,,,,,
+3com-net-mgmt,2391,udp,3COM Net Management,[Prathibha_Nagvar],[Prathibha_Nagvar],,,,,,
+tacticalauth,2392,tcp,Tactical Auth,[David_Yon],[David_Yon],,,,,,
+tacticalauth,2392,udp,Tactical Auth,[David_Yon],[David_Yon],,,,,,
+ms-olap1,2393,tcp,MS OLAP 1,,,,,,,,
+ms-olap1,2393,udp,MS OLAP 1,,,,,,,,
+ms-olap2,2394,tcp,MS OLAP 2,[Mosha_Pasumansky],[Mosha_Pasumansky],,,,,,
+ms-olap2,2394,udp,MS OLAP 2,[Mosha_Pasumansky],[Mosha_Pasumansky],,,,,,
+lan900-remote,2395,tcp,"LAN900 Remote
+IANA assigned this well-formed service name as a replacement for ""lan900_remote"".",[Tom_Quinlan],[Tom_Quinlan],,,,,,
+lan900_remote,2395,tcp,LAN900 Remote,[Tom_Quinlan],[Tom_Quinlan],,,,,,"This entry is an alias to ""lan900-remote"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+lan900-remote,2395,udp,"LAN900 Remote
+IANA assigned this well-formed service name as a replacement for ""lan900_remote"".",[Tom_Quinlan],[Tom_Quinlan],,,,,,
+lan900_remote,2395,udp,LAN900 Remote,[Tom_Quinlan],[Tom_Quinlan],,,,,,"This entry is an alias to ""lan900-remote"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+wusage,2396,tcp,Wusage,[Thomas_Boutell],[Thomas_Boutell],,,,,,
+wusage,2396,udp,Wusage,[Thomas_Boutell],[Thomas_Boutell],,,,,,
+ncl,2397,tcp,NCL,[Robert_Wiebe],[Robert_Wiebe],,,,,,
+ncl,2397,udp,NCL,[Robert_Wiebe],[Robert_Wiebe],,,,,,
+orbiter,2398,tcp,Orbiter,[David_Goldberg],[David_Goldberg],,,,,,
+orbiter,2398,udp,Orbiter,[David_Goldberg],[David_Goldberg],,,,,,
+fmpro-fdal,2399,tcp,"FileMaker, Inc. - Data Access Layer",[Clay_Maeckal],[Clay_Maeckal],,,,,,
+fmpro-fdal,2399,udp,"FileMaker, Inc. - Data Access Layer",[Clay_Maeckal],[Clay_Maeckal],,,,,,
+opequus-server,2400,tcp,OpEquus Server,[Gavin_Hutchinson_2],[Gavin_Hutchinson_2],,,,,,
+opequus-server,2400,udp,OpEquus Server,[Gavin_Hutchinson_2],[Gavin_Hutchinson_2],,,,,,
+cvspserver,2401,tcp,cvspserver,[Jim_Kingdon],[Jim_Kingdon],,,,,,
+cvspserver,2401,udp,cvspserver,[Jim_Kingdon],[Jim_Kingdon],,,,,,
+taskmaster2000,2402,tcp,TaskMaster 2000 Server,,,,,,,,
+taskmaster2000,2402,udp,TaskMaster 2000 Server,,,,,,,,
+taskmaster2000,2403,tcp,TaskMaster 2000 Web,[Ed_Odjaghian],[Ed_Odjaghian],,,,,,
+taskmaster2000,2403,udp,TaskMaster 2000 Web,[Ed_Odjaghian],[Ed_Odjaghian],,,,,,
+iec-104,2404,tcp,IEC 60870-5-104 process control over IP,[Walter_K_Eichelburg],[Walter_K_Eichelburg],,,,,,
+iec-104,2404,udp,IEC 60870-5-104 process control over IP,[Walter_K_Eichelburg],[Walter_K_Eichelburg],,,,,,
+trc-netpoll,2405,tcp,TRC Netpoll,[Bizhan_Ghavami],[Bizhan_Ghavami],,,,,,
+trc-netpoll,2405,udp,TRC Netpoll,[Bizhan_Ghavami],[Bizhan_Ghavami],,,,,,
+jediserver,2406,tcp,JediServer,[Paul_McEntire],[Paul_McEntire],,,,,,
+jediserver,2406,udp,JediServer,[Paul_McEntire],[Paul_McEntire],,,,,,
+orion,2407,tcp,Orion,[Matthew_Horoschun],[Matthew_Horoschun],,,,,,
+orion,2407,udp,Orion,[Matthew_Horoschun],[Matthew_Horoschun],,,,,,
+railgun-webaccl,2408,tcp,CloudFlare Railgun Web Acceleration Protocol,[CloudFlare],[John_Graham_Cumming],,2012-03-09,,,,
+,2408,udp,Reserved,,,,2012-03-09,,,,This entry is being removed on 2012-03-09.
+sns-protocol,2409,tcp,SNS Protocol,[Amir_Blich],[Amir_Blich],,,,,,
+sns-protocol,2409,udp,SNS Protocol,[Amir_Blich],[Amir_Blich],,,,,,
+vrts-registry,2410,tcp,VRTS Registry,[Pranay_Varma],[Pranay_Varma],,,,,,
+vrts-registry,2410,udp,VRTS Registry,[Pranay_Varma],[Pranay_Varma],,,,,,
+netwave-ap-mgmt,2411,tcp,Netwave AP Management,[Johnny_Zweig],[Johnny_Zweig],,,,,,
+netwave-ap-mgmt,2411,udp,Netwave AP Management,[Johnny_Zweig],[Johnny_Zweig],,,,,,
+cdn,2412,tcp,CDN,[Alan_Noble],[Alan_Noble],,,,,,
+cdn,2412,udp,CDN,[Alan_Noble],[Alan_Noble],,,,,,
+orion-rmi-reg,2413,tcp,orion-rmi-reg,[J_S_Greenfield_2],[J_S_Greenfield_2],,,,,,
+orion-rmi-reg,2413,udp,orion-rmi-reg,[J_S_Greenfield_2],[J_S_Greenfield_2],,,,,,
+beeyond,2414,tcp,Beeyond,[Bob_Deblier],[Bob_Deblier],,,,,,
+beeyond,2414,udp,Beeyond,[Bob_Deblier],[Bob_Deblier],,,,,,
+codima-rtp,2415,tcp,Codima Remote Transaction Protocol,[Sylvia_Ross],[Sylvia_Ross],,,,,,
+codima-rtp,2415,udp,Codima Remote Transaction Protocol,[Sylvia_Ross],[Sylvia_Ross],,,,,,
+rmtserver,2416,tcp,RMT Server,[Yvon_Marineau],[Yvon_Marineau],,,,,,
+rmtserver,2416,udp,RMT Server,[Yvon_Marineau],[Yvon_Marineau],,,,,,
+composit-server,2417,tcp,Composit Server,[Katsuaki_Naoi],[Katsuaki_Naoi],,,,,,
+composit-server,2417,udp,Composit Server,[Katsuaki_Naoi],[Katsuaki_Naoi],,,,,,
+cas,2418,tcp,cas,[Akiyoshi_Ochi],[Akiyoshi_Ochi],,,,,,
+cas,2418,udp,cas,[Akiyoshi_Ochi],[Akiyoshi_Ochi],,,,,,
+attachmate-s2s,2419,tcp,Attachmate S2S,[Chris_Rominski],[Chris_Rominski],,,,,,
+attachmate-s2s,2419,udp,Attachmate S2S,[Chris_Rominski],[Chris_Rominski],,,,,,
+dslremote-mgmt,2420,tcp,DSL Remote Management,[Westell],[Westell],,,,,,
+dslremote-mgmt,2420,udp,DSL Remote Management,[Westell],[Westell],,,,,,
+g-talk,2421,tcp,G-Talk,[Matt_Hammond],[Matt_Hammond],,,,,,
+g-talk,2421,udp,G-Talk,[Matt_Hammond],[Matt_Hammond],,,,,,
+crmsbits,2422,tcp,CRMSBITS,[Rod_Ward],[Rod_Ward],,,,,,
+crmsbits,2422,udp,CRMSBITS,[Rod_Ward],[Rod_Ward],,,,,,
+rnrp,2423,tcp,RNRP,[Per_Sahlqvist],[Per_Sahlqvist],,,,,,
+rnrp,2423,udp,RNRP,[Per_Sahlqvist],[Per_Sahlqvist],,,,,,
+kofax-svr,2424,tcp,KOFAX-SVR,[Steven_Kilby],[Steven_Kilby],2011-04-25,,,,,
+kofax-svr,2424,udp,KOFAX-SVR,[Steven_Kilby],[Steven_Kilby],2011-04-25,,,,,
+fjitsuappmgr,2425,tcp,Fujitsu App Manager,[Hiroyuki_Kawabuchi],[Hiroyuki_Kawabuchi],,,,,,
+fjitsuappmgr,2425,udp,Fujitsu App Manager,[Hiroyuki_Kawabuchi],[Hiroyuki_Kawabuchi],,,,,,
+,2426,,Unassigned,,,,2002-04-29,,,,
+mgcp-gateway,2427,tcp,Media Gateway Control Protocol Gateway,[Christian_Huitema],[Christian_Huitema],,,,,,
+mgcp-gateway,2427,udp,Media Gateway Control Protocol Gateway,[Christian_Huitema],[Christian_Huitema],,,,,,
+ott,2428,tcp,One Way Trip Time,[Greg_Troxel],[Greg_Troxel],,,,,,
+ott,2428,udp,One Way Trip Time,[Greg_Troxel],[Greg_Troxel],,,,,,
+ft-role,2429,tcp,FT-ROLE,[Doug_Boone],[Doug_Boone],,,,,,
+ft-role,2429,udp,FT-ROLE,[Doug_Boone],[Doug_Boone],,,,,,
+venus,2430,tcp,venus,,,,,,,,
+venus,2430,udp,venus,,,,,,,,
+venus-se,2431,tcp,venus-se,,,,,,,,
+venus-se,2431,udp,venus-se,,,,,,,,
+codasrv,2432,tcp,codasrv,,,,,,,,
+codasrv,2432,udp,codasrv,,,,,,,,
+codasrv-se,2433,tcp,codasrv-se,[Robert_Watson],[Robert_Watson],,,,,,
+codasrv-se,2433,udp,codasrv-se,[Robert_Watson],[Robert_Watson],,,,,,
+pxc-epmap,2434,tcp,pxc-epmap,[Jun_Nakamura],[Jun_Nakamura],,,,,,
+pxc-epmap,2434,udp,pxc-epmap,[Jun_Nakamura],[Jun_Nakamura],,,,,,
+optilogic,2435,tcp,OptiLogic,[Clark_Williams],[Clark_Williams],,,,,,
+optilogic,2435,udp,OptiLogic,[Clark_Williams],[Clark_Williams],,,,,,
+topx,2436,tcp,TOP/X,[Dragos_Pop],[Dragos_Pop],,,,,,
+topx,2436,udp,TOP/X,[Dragos_Pop],[Dragos_Pop],,,,,,
+unicontrol,2437,tcp,UniControl,[Ing_Markus_Huemer],[Ing_Markus_Huemer],,,,,,
+unicontrol,2437,udp,UniControl,[Ing_Markus_Huemer],[Ing_Markus_Huemer],,,,,,
+msp,2438,tcp,MSP,[Evan_Caves],[Evan_Caves],,,,,,
+msp,2438,udp,MSP,[Evan_Caves],[Evan_Caves],,,,,,
+sybasedbsynch,2439,tcp,SybaseDBSynch,[Dave_Neudoerffer],[Dave_Neudoerffer],,,,,,
+sybasedbsynch,2439,udp,SybaseDBSynch,[Dave_Neudoerffer],[Dave_Neudoerffer],,,,,,
+spearway,2440,tcp,Spearway Lockers,[Pierre_Frisch],[Pierre_Frisch],,,,,,
+spearway,2440,udp,Spearway Lockers,[Pierre_Frisch],[Pierre_Frisch],,,,,,
+pvsw-inet,2441,tcp,Pervasive I*net Data Server,[Chuck_Talk],[Chuck_Talk],,,,,,
+pvsw-inet,2441,udp,Pervasive I*net Data Server,[Chuck_Talk],[Chuck_Talk],,,,,,
+netangel,2442,tcp,Netangel,[Ladislav_Baranyay],[Ladislav_Baranyay],,,,,,
+netangel,2442,udp,Netangel,[Ladislav_Baranyay],[Ladislav_Baranyay],,,,,,
+powerclientcsf,2443,tcp,PowerClient Central Storage Facility,[Brian_Klassen],[Brian_Klassen],,,,,,
+powerclientcsf,2443,udp,PowerClient Central Storage Facility,[Brian_Klassen],[Brian_Klassen],,,,,,
+btpp2sectrans,2444,tcp,BT PP2 Sectrans,[Ian_Daniels],[Ian_Daniels],,,,,,
+btpp2sectrans,2444,udp,BT PP2 Sectrans,[Ian_Daniels],[Ian_Daniels],,,,,,
+dtn1,2445,tcp,DTN1,[Bob_Gaddie],[Bob_Gaddie],,,,,,
+dtn1,2445,udp,DTN1,[Bob_Gaddie],[Bob_Gaddie],,,,,,
+bues-service,2446,tcp,"bues_service
+IANA assigned this well-formed service name as a replacement for ""bues_service"".",[Leonhard_Diekmann],[Leonhard_Diekmann],,,,,,
+bues_service,2446,tcp,bues_service,[Leonhard_Diekmann],[Leonhard_Diekmann],,,,,,"This entry is an alias to ""bues-service"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+bues-service,2446,udp,"bues_service
+IANA assigned this well-formed service name as a replacement for ""bues_service"".",[Leonhard_Diekmann],[Leonhard_Diekmann],,,,,,
+bues_service,2446,udp,bues_service,[Leonhard_Diekmann],[Leonhard_Diekmann],,,,,,"This entry is an alias to ""bues-service"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+ovwdb,2447,tcp,OpenView NNM daemon,[Eric_Pulsipher_2],[Eric_Pulsipher_2],,,,,,
+ovwdb,2447,udp,OpenView NNM daemon,[Eric_Pulsipher_2],[Eric_Pulsipher_2],,,,,,
+hpppssvr,2448,tcp,hpppsvr,[Bridgette_Landers],[Bridgette_Landers],,,,,,
+hpppssvr,2448,udp,hpppsvr,[Bridgette_Landers],[Bridgette_Landers],,,,,,
+ratl,2449,tcp,RATL,[Paul_Greenfield],[Paul_Greenfield],,,,,,
+ratl,2449,udp,RATL,[Paul_Greenfield],[Paul_Greenfield],,,,,,
+netadmin,2450,tcp,netadmin,,,,,,,,
+netadmin,2450,udp,netadmin,,,,,,,,
+netchat,2451,tcp,netchat,[Julian_Mehnle],[Julian_Mehnle],,,,,,
+netchat,2451,udp,netchat,[Julian_Mehnle],[Julian_Mehnle],,,,,,
+snifferclient,2452,tcp,SnifferClient,[Amy_Weaver_2],[Amy_Weaver_2],,,,,,
+snifferclient,2452,udp,SnifferClient,[Amy_Weaver_2],[Amy_Weaver_2],,,,,,
+madge-ltd,2453,tcp,madge ltd,[Mark_Lyall],[Mark_Lyall],,,,,,
+madge-ltd,2453,udp,madge ltd,[Mark_Lyall],[Mark_Lyall],,,,,,
+indx-dds,2454,tcp,IndX-DDS,[Paul_Carmichael],[Paul_Carmichael],,,,,,
+indx-dds,2454,udp,IndX-DDS,[Paul_Carmichael],[Paul_Carmichael],,,,,,
+wago-io-system,2455,tcp,WAGO-IO-SYSTEM,[Jorg_Hoffmann],[Jorg_Hoffmann],,,,,,
+wago-io-system,2455,udp,WAGO-IO-SYSTEM,[Jorg_Hoffmann],[Jorg_Hoffmann],,,,,,
+altav-remmgt,2456,tcp,altav-remmgt,[Gary_M_Allen],[Gary_M_Allen],,,,,,
+altav-remmgt,2456,udp,altav-remmgt,[Gary_M_Allen],[Gary_M_Allen],,,,,,
+rapido-ip,2457,tcp,Rapido_IP,[Man_Shuen_Cheung],[Man_Shuen_Cheung],,,,,,
+rapido-ip,2457,udp,Rapido_IP,[Man_Shuen_Cheung],[Man_Shuen_Cheung],,,,,,
+griffin,2458,tcp,griffin,[Tom_Taylor],[Tom_Taylor],,,,,,
+griffin,2458,udp,griffin,[Tom_Taylor],[Tom_Taylor],,,,,,
+community,2459,tcp,Community,[David_Schwartz],[David_Schwartz],,,,,,
+community,2459,udp,Community,[David_Schwartz],[David_Schwartz],,,,,,
+ms-theater,2460,tcp,ms-theater,[Anton_Kucer],[Anton_Kucer],,,,,,
+ms-theater,2460,udp,ms-theater,[Anton_Kucer],[Anton_Kucer],,,,,,
+qadmifoper,2461,tcp,qadmifoper,,,,,,,,
+qadmifoper,2461,udp,qadmifoper,,,,,,,,
+qadmifevent,2462,tcp,qadmifevent,[Pekka_Takaranta],[Pekka_Takaranta],,,,,,
+qadmifevent,2462,udp,qadmifevent,[Pekka_Takaranta],[Pekka_Takaranta],,,,,,
+lsi-raid-mgmt,2463,tcp,LSI RAID Management,[NetApp],[MSW_architecture_team],,2014-07-18,,,,
+lsi-raid-mgmt,2463,udp,LSI RAID Management,[NetApp],[MSW_architecture_team],,2014-07-18,,,,
+direcpc-si,2464,tcp,DirecPC SI,[Doug_Dillon],[Doug_Dillon],,,,,,
+direcpc-si,2464,udp,DirecPC SI,[Doug_Dillon],[Doug_Dillon],,,,,,
+lbm,2465,tcp,Load Balance Management,,,,,,,,
+lbm,2465,udp,Load Balance Management,,,,,,,,
+lbf,2466,tcp,Load Balance Forwarding,[Kazuhiro_Koide],[Kazuhiro_Koide],,,,,,
+lbf,2466,udp,Load Balance Forwarding,[Kazuhiro_Koide],[Kazuhiro_Koide],,,,,,
+high-criteria,2467,tcp,High Criteria,[Konstantin_Iavid],[Konstantin_Iavid],,,,,,
+high-criteria,2467,udp,High Criteria,[Konstantin_Iavid],[Konstantin_Iavid],,,,,,
+qip-msgd,2468,tcp,qip_msgd,[Mike_Morgan],[Mike_Morgan],,,,,,
+qip-msgd,2468,udp,qip_msgd,[Mike_Morgan],[Mike_Morgan],,,,,,
+mti-tcs-comm,2469,tcp,MTI-TCS-COMM,[Mario_Bonin],[Mario_Bonin],,,,,,
+mti-tcs-comm,2469,udp,MTI-TCS-COMM,[Mario_Bonin],[Mario_Bonin],,,,,,
+taskman-port,2470,tcp,taskman port,[Boris_Panteleev],[Boris_Panteleev],,,,,,
+taskman-port,2470,udp,taskman port,[Boris_Panteleev],[Boris_Panteleev],,,,,,
+seaodbc,2471,tcp,SeaODBC,[Adrian_Hornby],[Adrian_Hornby],,,,,,
+seaodbc,2471,udp,SeaODBC,[Adrian_Hornby],[Adrian_Hornby],,,,,,
+c3,2472,tcp,C3,[Eckhard_Grieger],[Eckhard_Grieger],,,,,,
+c3,2472,udp,C3,[Eckhard_Grieger],[Eckhard_Grieger],,,,,,
+aker-cdp,2473,tcp,Aker-cdp,[Rodrigo_Ormonde],[Rodrigo_Ormonde],,,,,,
+aker-cdp,2473,udp,Aker-cdp,[Rodrigo_Ormonde],[Rodrigo_Ormonde],,,,,,
+vitalanalysis,2474,tcp,Vital Analysis,[Srinivas_Reddy],[Srinivas_Reddy],,,,,,
+vitalanalysis,2474,udp,Vital Analysis,[Srinivas_Reddy],[Srinivas_Reddy],,,,,,
+ace-server,2475,tcp,ACE Server,,,,,,,,
+ace-server,2475,udp,ACE Server,,,,,,,,
+ace-svr-prop,2476,tcp,ACE Server Propagation,,,,,,,,
+ace-svr-prop,2476,udp,ACE Server Propagation,,,,,,,,
+ssm-cvs,2477,tcp,SecurSight Certificate Valifation Service,,,,,,,,
+ssm-cvs,2477,udp,SecurSight Certificate Valifation Service,,,,,,,,
+ssm-cssps,2478,tcp,SecurSight Authentication Server (SSL),,,,,,,,
+ssm-cssps,2478,udp,SecurSight Authentication Server (SSL),,,,,,,,
+ssm-els,2479,tcp,SecurSight Event Logging Server (SSL),[John_Linn],[John_Linn],,,,,,
+ssm-els,2479,udp,SecurSight Event Logging Server (SSL),[John_Linn],[John_Linn],,,,,,
+powerexchange,2480,tcp,Informatica PowerExchange Listener,[Dale_Norman],[Dale_Norman],,,,,,
+powerexchange,2480,udp,Informatica PowerExchange Listener,[Dale_Norman],[Dale_Norman],,,,,,
+giop,2481,tcp,Oracle GIOP,,,,,,,,
+giop,2481,udp,Oracle GIOP,,,,,,,,
+giop-ssl,2482,tcp,Oracle GIOP SSL,,,,,,,,
+giop-ssl,2482,udp,Oracle GIOP SSL,,,,,,,,
+ttc,2483,tcp,Oracle TTC,,,,,,,,
+ttc,2483,udp,Oracle TTC,,,,,,,,
+ttc-ssl,2484,tcp,Oracle TTC SSL,[Chandar_Venkataraman],[Chandar_Venkataraman],,,,,,
+ttc-ssl,2484,udp,Oracle TTC SSL,[Chandar_Venkataraman],[Chandar_Venkataraman],,,,,,
+netobjects1,2485,tcp,Net Objects1,,,,,,,,
+netobjects1,2485,udp,Net Objects1,,,,,,,,
+netobjects2,2486,tcp,Net Objects2,[Francois_Granade],[Francois_Granade],,,,,,
+netobjects2,2486,udp,Net Objects2,[Francois_Granade],[Francois_Granade],,,,,,
+pns,2487,tcp,Policy Notice Service,[Akiyoshi_Ochi],[Akiyoshi_Ochi],,,,,,
+pns,2487,udp,Policy Notice Service,[Akiyoshi_Ochi],[Akiyoshi_Ochi],,,,,,
+moy-corp,2488,tcp,Moy Corporation,[Gang_Gong_Moy],[Gang_Gong_Moy],,,,,,
+moy-corp,2488,udp,Moy Corporation,[Gang_Gong_Moy],[Gang_Gong_Moy],,,,,,
+tsilb,2489,tcp,TSILB,[James_Irwin],[James_Irwin],,,,,,
+tsilb,2489,udp,TSILB,[James_Irwin],[James_Irwin],,,,,,
+qip-qdhcp,2490,tcp,qip_qdhcp,[Mike_Morgan],[Mike_Morgan],,,,,,
+qip-qdhcp,2490,udp,qip_qdhcp,[Mike_Morgan],[Mike_Morgan],,,,,,
+conclave-cpp,2491,tcp,Conclave CPP,[Larry_Lipstone],[Larry_Lipstone],,,,,,
+conclave-cpp,2491,udp,Conclave CPP,[Larry_Lipstone],[Larry_Lipstone],,,,,,
+groove,2492,tcp,GROOVE,[Ray_Ozzie],[Ray_Ozzie],,,,,,
+groove,2492,udp,GROOVE,[Ray_Ozzie],[Ray_Ozzie],,,,,,
+talarian-mqs,2493,tcp,Talarian MQS,[Jim_Stabile],[Jim_Stabile],,,,,,
+talarian-mqs,2493,udp,Talarian MQS,[Jim_Stabile],[Jim_Stabile],,,,,,
+bmc-ar,2494,tcp,BMC AR,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmc-ar,2494,udp,BMC AR,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+fast-rem-serv,2495,tcp,Fast Remote Services,[Scott_St_Clair],[Scott_St_Clair],,,,,,
+fast-rem-serv,2495,udp,Fast Remote Services,[Scott_St_Clair],[Scott_St_Clair],,,,,,
+dirgis,2496,tcp,DIRGIS,[Deutschland_Informat],[Deutschland_Informat],,,,,,
+dirgis,2496,udp,DIRGIS,[Deutschland_Informat],[Deutschland_Informat],,,,,,
+quaddb,2497,tcp,Quad DB,[Jeff_Rosenthal],[Jeff_Rosenthal],,,,,,
+quaddb,2497,udp,Quad DB,[Jeff_Rosenthal],[Jeff_Rosenthal],,,,,,
+odn-castraq,2498,tcp,ODN-CasTraq,[Richard_Hodges_2],[Richard_Hodges_2],,,,,,
+odn-castraq,2498,udp,ODN-CasTraq,[Richard_Hodges_2],[Richard_Hodges_2],,,,,,
+unicontrol,2499,tcp,UniControl,[Ing_Markus_Huemer],[Ing_Markus_Huemer],,,,,,
+unicontrol,2499,udp,UniControl,[Ing_Markus_Huemer],[Ing_Markus_Huemer],,,,,,
+rtsserv,2500,tcp,Resource Tracking system server,,,,,,,,
+rtsserv,2500,udp,Resource Tracking system server,,,,,,,,
+rtsclient,2501,tcp,Resource Tracking system client,[Aubrey_Turner],[Aubrey_Turner],,,,,,
+rtsclient,2501,udp,Resource Tracking system client,[Aubrey_Turner],[Aubrey_Turner],,,,,,
+kentrox-prot,2502,tcp,Kentrox Protocol,[Anil_Lakhwara],[Anil_Lakhwara],,,,,,
+kentrox-prot,2502,udp,Kentrox Protocol,[Anil_Lakhwara],[Anil_Lakhwara],,,,,,
+nms-dpnss,2503,tcp,NMS-DPNSS,[Jean_Christophe_Desi],[Jean_Christophe_Desi],,,,,,
+nms-dpnss,2503,udp,NMS-DPNSS,[Jean_Christophe_Desi],[Jean_Christophe_Desi],,,,,,
+wlbs,2504,tcp,WLBS,[William_Bain],[William_Bain],,,,,,
+wlbs,2504,udp,WLBS,[William_Bain],[William_Bain],,,,,,
+ppcontrol,2505,tcp,PowerPlay Control,[Max_Magliaro],[Max_Magliaro],2004-11,,,,,
+ppcontrol,2505,udp,PowerPlay Control,[Max_Magliaro],[Max_Magliaro],2004-11,,,,,
+jbroker,2506,tcp,jbroker,[Rohit_Garg_2],[Rohit_Garg_2],,,,,,
+jbroker,2506,udp,jbroker,[Rohit_Garg_2],[Rohit_Garg_2],,,,,,
+spock,2507,tcp,spock,[Jon_A_Christopher],[Jon_A_Christopher],,,,,,
+spock,2507,udp,spock,[Jon_A_Christopher],[Jon_A_Christopher],,,,,,
+jdatastore,2508,tcp,JDataStore,[Tod_Landis],[Tod_Landis],,,,,,
+jdatastore,2508,udp,JDataStore,[Tod_Landis],[Tod_Landis],,,,,,
+fjmpss,2509,tcp,fjmpss,[Makoto_Watanabe],[Makoto_Watanabe],,,,,,
+fjmpss,2509,udp,fjmpss,[Makoto_Watanabe],[Makoto_Watanabe],,,,,,
+fjappmgrbulk,2510,tcp,fjappmgrbulk,[Hiroyuki_Kawabuchi],[Hiroyuki_Kawabuchi],,,,,,
+fjappmgrbulk,2510,udp,fjappmgrbulk,[Hiroyuki_Kawabuchi],[Hiroyuki_Kawabuchi],,,,,,
+metastorm,2511,tcp,Metastorm,[Eric_Isom],[Eric_Isom],,,,,,
+metastorm,2511,udp,Metastorm,[Eric_Isom],[Eric_Isom],,,,,,
+citrixima,2512,tcp,Citrix IMA,,,,,,,,
+citrixima,2512,udp,Citrix IMA,,,,,,,,
+citrixadmin,2513,tcp,Citrix ADMIN,[Myk_Willis],[Myk_Willis],,,,,,
+citrixadmin,2513,udp,Citrix ADMIN,[Myk_Willis],[Myk_Willis],,,,,,
+facsys-ntp,2514,tcp,Facsys NTP,,,,,,,,
+facsys-ntp,2514,udp,Facsys NTP,,,,,,,,
+facsys-router,2515,tcp,Facsys Router,[Jeff_Hoffman],[Jeff_Hoffman],,,,,,
+facsys-router,2515,udp,Facsys Router,[Jeff_Hoffman],[Jeff_Hoffman],,,,,,
+maincontrol,2516,tcp,Main Control,[Nathan_Sadia],[Nathan_Sadia],,,,,,
+maincontrol,2516,udp,Main Control,[Nathan_Sadia],[Nathan_Sadia],,,,,,
+call-sig-trans,2517,tcp,H.323 Annex E Call Control Signalling Transport,[ITU-T],[ITU-T_TSB],,2013-01-31,,,,
+call-sig-trans,2517,udp,H.323 Annex E Call Control Signalling Transport,[ITU-T],[ITU-T_TSB],,2013-01-31,,,,
+willy,2518,tcp,Willy,[Carl_Johan_Wik],[Carl_Johan_Wik],,,,,,
+willy,2518,udp,Willy,[Carl_Johan_Wik],[Carl_Johan_Wik],,,,,,
+globmsgsvc,2519,tcp,globmsgsvc,[David_Wiltz],[David_Wiltz],,,,,,
+globmsgsvc,2519,udp,globmsgsvc,[David_Wiltz],[David_Wiltz],,,,,,
+pvsw,2520,tcp,Pervasive Listener,[Chuck_Talk],[Chuck_Talk],,,,,,
+pvsw,2520,udp,Pervasive Listener,[Chuck_Talk],[Chuck_Talk],,,,,,
+adaptecmgr,2521,tcp,Adaptec Manager,[Mark_Parenti],[Mark_Parenti],,,,,,
+adaptecmgr,2521,udp,Adaptec Manager,[Mark_Parenti],[Mark_Parenti],,,,,,
+windb,2522,tcp,WinDb,[Larry_Traylor],[Larry_Traylor],,,,,,
+windb,2522,udp,WinDb,[Larry_Traylor],[Larry_Traylor],,,,,,
+qke-llc-v3,2523,tcp,Qke LLC V.3,[Joerg_Niehoff],[Joerg_Niehoff],,,,,,
+qke-llc-v3,2523,udp,Qke LLC V.3,[Joerg_Niehoff],[Joerg_Niehoff],,,,,,
+optiwave-lm,2524,tcp,Optiwave License Management,[Slawomir_Krzesinski],[Slawomir_Krzesinski],,,,,,
+optiwave-lm,2524,udp,Optiwave License Management,[Slawomir_Krzesinski],[Slawomir_Krzesinski],,,,,,
+ms-v-worlds,2525,tcp,MS V-Worlds,[Pete_Wong],[Pete_Wong],,,,,,
+ms-v-worlds,2525,udp,MS V-Worlds,[Pete_Wong],[Pete_Wong],,,,,,
+ema-sent-lm,2526,tcp,EMA License Manager,[Thaddeus_Perala],[Thaddeus_Perala],,,,,,
+ema-sent-lm,2526,udp,EMA License Manager,[Thaddeus_Perala],[Thaddeus_Perala],,,,,,
+iqserver,2527,tcp,IQ Server,[Nick_Straguzzi],[Nick_Straguzzi],,,,,,
+iqserver,2527,udp,IQ Server,[Nick_Straguzzi],[Nick_Straguzzi],,,,,,
+ncr-ccl,2528,tcp,"NCR CCL
+IANA assigned this well-formed service name as a replacement for ""ncr_ccl"".",[Amitava_Dutta],[Amitava_Dutta],,,,,,
+ncr_ccl,2528,tcp,NCR CCL,[Amitava_Dutta],[Amitava_Dutta],,,,,,"This entry is an alias to ""ncr-ccl"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+ncr-ccl,2528,udp,"NCR CCL
+IANA assigned this well-formed service name as a replacement for ""ncr_ccl"".",[Amitava_Dutta],[Amitava_Dutta],,,,,,
+ncr_ccl,2528,udp,NCR CCL,[Amitava_Dutta],[Amitava_Dutta],,,,,,"This entry is an alias to ""ncr-ccl"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+utsftp,2529,tcp,UTS FTP,[David_Moore],[David_Moore],,,,,,
+utsftp,2529,udp,UTS FTP,[David_Moore],[David_Moore],,,,,,
+vrcommerce,2530,tcp,VR Commerce,[Yosi_Mass],[Yosi_Mass],,,,,,
+vrcommerce,2530,udp,VR Commerce,[Yosi_Mass],[Yosi_Mass],,,,,,
+ito-e-gui,2531,tcp,ITO-E GUI,[Michael_Haeuptle],[Michael_Haeuptle],,,,,,
+ito-e-gui,2531,udp,ITO-E GUI,[Michael_Haeuptle],[Michael_Haeuptle],,,,,,
+ovtopmd,2532,tcp,OVTOPMD,[Eric_Pulsipher],[Eric_Pulsipher],,,,,,
+ovtopmd,2532,udp,OVTOPMD,[Eric_Pulsipher],[Eric_Pulsipher],,,,,,
+snifferserver,2533,tcp,SnifferServer,[Amy_Weaver_3],[Amy_Weaver_3],,,,,,
+snifferserver,2533,udp,SnifferServer,[Amy_Weaver_3],[Amy_Weaver_3],,,,,,
+combox-web-acc,2534,tcp,Combox Web Access,[Yochai_Cohen],[Yochai_Cohen],,,,,,
+combox-web-acc,2534,udp,Combox Web Access,[Yochai_Cohen],[Yochai_Cohen],,,,,,
+madcap,2535,tcp,MADCAP,[Stephen_Hanna_2],[Stephen_Hanna_2],,,,,,
+madcap,2535,udp,MADCAP,[Stephen_Hanna_2],[Stephen_Hanna_2],,,,,,
+btpp2audctr1,2536,tcp,btpp2audctr1,[Ian_Daniels],[Ian_Daniels],,,,,,
+btpp2audctr1,2536,udp,btpp2audctr1,[Ian_Daniels],[Ian_Daniels],,,,,,
+upgrade,2537,tcp,Upgrade Protocol,[Breck_Auten],[Breck_Auten],,,,,,
+upgrade,2537,udp,Upgrade Protocol,[Breck_Auten],[Breck_Auten],,,,,,
+vnwk-prapi,2538,tcp,vnwk-prapi,[John_Hasselkus],[John_Hasselkus],,,,,,
+vnwk-prapi,2538,udp,vnwk-prapi,[John_Hasselkus],[John_Hasselkus],,,,,,
+vsiadmin,2539,tcp,VSI Admin,[Rob_Juergens],[Rob_Juergens],,,,,,
+vsiadmin,2539,udp,VSI Admin,[Rob_Juergens],[Rob_Juergens],,,,,,
+lonworks,2540,tcp,LonWorks,,,,,,,,
+lonworks,2540,udp,LonWorks,,,,,,,,
+lonworks2,2541,tcp,LonWorks2,[Gary_Bartlett],[Gary_Bartlett],,,,,,
+lonworks2,2541,udp,LonWorks2,[Gary_Bartlett],[Gary_Bartlett],,,,,,
+udrawgraph,2542,tcp,uDraw(Graph),[Bremen],[Bremen],,,,,,
+udrawgraph,2542,udp,uDraw(Graph),[Bremen],[Bremen],,,,,,
+reftek,2543,tcp,REFTEK,[Phil_Davidson],[Phil_Davidson],,,,,,
+reftek,2543,udp,REFTEK,[Phil_Davidson],[Phil_Davidson],,,,,,
+novell-zen,2544,tcp,Management Daemon Refresh,[Ty_Ellis],[Ty_Ellis],,,,,,
+novell-zen,2544,udp,Management Daemon Refresh,[Ty_Ellis],[Ty_Ellis],,,,,,
+sis-emt,2545,tcp,sis-emt,[Bill_Crawford],[Bill_Crawford],,,,,,
+sis-emt,2545,udp,sis-emt,[Bill_Crawford],[Bill_Crawford],,,,,,
+vytalvaultbrtp,2546,tcp,vytalvaultbrtp,,,,,,,,
+vytalvaultbrtp,2546,udp,vytalvaultbrtp,,,,,,,,
+vytalvaultvsmp,2547,tcp,vytalvaultvsmp,,,,,,,,
+vytalvaultvsmp,2547,udp,vytalvaultvsmp,,,,,,,,
+vytalvaultpipe,2548,tcp,vytalvaultpipe,[Tim_Boldt],[Tim_Boldt],,,,,,
+vytalvaultpipe,2548,udp,vytalvaultpipe,[Tim_Boldt],[Tim_Boldt],,,,,,
+ipass,2549,tcp,IPASS,[Michael_Fischer],[Michael_Fischer],,,,,,
+ipass,2549,udp,IPASS,[Michael_Fischer],[Michael_Fischer],,,,,,
+ads,2550,tcp,ADS,[Michael_O_Connor],[Michael_O_Connor],,,,,,
+ads,2550,udp,ADS,[Michael_O_Connor],[Michael_O_Connor],,,,,,
+isg-uda-server,2551,tcp,ISG UDA Server,[Dror_Harari],[Dror_Harari],,,,,,
+isg-uda-server,2551,udp,ISG UDA Server,[Dror_Harari],[Dror_Harari],,,,,,
+call-logging,2552,tcp,Call Logging,[Dean_Webb],[Dean_Webb],,,,,,
+call-logging,2552,udp,Call Logging,[Dean_Webb],[Dean_Webb],,,,,,
+efidiningport,2553,tcp,efidiningport,[Lynn_Carter],[Lynn_Carter],,,,,,
+efidiningport,2553,udp,efidiningport,[Lynn_Carter],[Lynn_Carter],,,,,,
+vcnet-link-v10,2554,tcp,VCnet-Link v10,[Csaba_Mate],[Csaba_Mate],,,,,,
+vcnet-link-v10,2554,udp,VCnet-Link v10,[Csaba_Mate],[Csaba_Mate],,,,,,
+compaq-wcp,2555,tcp,Compaq WCP,[Ferruccio_Barletta],[Ferruccio_Barletta],,,,,,
+compaq-wcp,2555,udp,Compaq WCP,[Ferruccio_Barletta],[Ferruccio_Barletta],,,,,,
+nicetec-nmsvc,2556,tcp,nicetec-nmsvc,,,,,,,,
+nicetec-nmsvc,2556,udp,nicetec-nmsvc,,,,,,,,
+nicetec-mgmt,2557,tcp,nicetec-mgmt,[Joerg_Paulus],[Joerg_Paulus],,,,,,
+nicetec-mgmt,2557,udp,nicetec-mgmt,[Joerg_Paulus],[Joerg_Paulus],,,,,,
+pclemultimedia,2558,tcp,PCLE Multi Media,[Jacob_Gsoedl],[Jacob_Gsoedl],,,,,,
+pclemultimedia,2558,udp,PCLE Multi Media,[Jacob_Gsoedl],[Jacob_Gsoedl],,,,,,
+lstp,2559,tcp,LSTP,[Waiki_Wright],[Waiki_Wright],,,,,,
+lstp,2559,udp,LSTP,[Waiki_Wright],[Waiki_Wright],,,,,,
+labrat,2560,tcp,labrat,[John_Harvey],[John_Harvey],,,,,,
+labrat,2560,udp,labrat,[John_Harvey],[John_Harvey],,,,,,
+mosaixcc,2561,tcp,MosaixCC,[Steven_Frare],[Steven_Frare],,,,,,
+mosaixcc,2561,udp,MosaixCC,[Steven_Frare],[Steven_Frare],,,,,,
+delibo,2562,tcp,Delibo,[NovaWiz_LTD],[NovaWiz_LTD],,,,,,
+delibo,2562,udp,Delibo,[NovaWiz_LTD],[NovaWiz_LTD],,,,,,
+cti-redwood,2563,tcp,CTI Redwood,[Songwon_Chi],[Songwon_Chi],,,,,,
+cti-redwood,2563,udp,CTI Redwood,[Songwon_Chi],[Songwon_Chi],,,,,,
+hp-3000-telnet,2564,tcp,HP 3000 NS/VT block mode telnet,,,,,,,,
+hp-3000-telnet,2564,udp,HP 3000 NS/VT block mode telnet,,,,,,,,
+coord-svr,2565,tcp,Coordinator Server,[Richard_Steiger],[Richard_Steiger],,,,,,
+coord-svr,2565,udp,Coordinator Server,[Richard_Steiger],[Richard_Steiger],,,,,,
+pcs-pcw,2566,tcp,pcs-pcw,[W_Jordan_Fitzhugh],[W_Jordan_Fitzhugh],,,,,,
+pcs-pcw,2566,udp,pcs-pcw,[W_Jordan_Fitzhugh],[W_Jordan_Fitzhugh],,,,,,
+clp,2567,tcp,Cisco Line Protocol,[Susan_Hinrichs],[Susan_Hinrichs],,,,,,
+clp,2567,udp,Cisco Line Protocol,[Susan_Hinrichs],[Susan_Hinrichs],,,,,,
+spamtrap,2568,tcp,SPAM TRAP,[Charles_Bennett],[Charles_Bennett],2008-08-29,,,,,
+spamtrap,2568,udp,SPAM TRAP,[Charles_Bennett],[Charles_Bennett],2008-08-29,,,,,
+sonuscallsig,2569,tcp,Sonus Call Signal,[Mark_Garti],[Mark_Garti],,,,,,
+sonuscallsig,2569,udp,Sonus Call Signal,[Mark_Garti],[Mark_Garti],,,,,,
+hs-port,2570,tcp,HS Port,[Uri_Doron],[Uri_Doron],,,,,,
+hs-port,2570,udp,HS Port,[Uri_Doron],[Uri_Doron],,,,,,
+cecsvc,2571,tcp,CECSVC,[Roger_Pao],[Roger_Pao],,,,,,
+cecsvc,2571,udp,CECSVC,[Roger_Pao],[Roger_Pao],,,,,,
+ibp,2572,tcp,IBP,[Jonathan_Downes],[Jonathan_Downes],,,,,,
+ibp,2572,udp,IBP,[Jonathan_Downes],[Jonathan_Downes],,,,,,
+trustestablish,2573,tcp,Trust Establish,[Yosi_Mass],[Yosi_Mass],,,,,,
+trustestablish,2573,udp,Trust Establish,[Yosi_Mass],[Yosi_Mass],,,,,,
+blockade-bpsp,2574,tcp,Blockade BPSP,[Blockade],[Blockade],,,,,,
+blockade-bpsp,2574,udp,Blockade BPSP,[Blockade],[Blockade],,,,,,
+hl7,2575,tcp,HL7,[Tim_Jacobs],[Tim_Jacobs],,,,,,
+hl7,2575,udp,HL7,[Tim_Jacobs],[Tim_Jacobs],,,,,,
+tclprodebugger,2576,tcp,TCL Pro Debugger,,,,,,,,
+tclprodebugger,2576,udp,TCL Pro Debugger,,,,,,,,
+scipticslsrvr,2577,tcp,Scriptics Lsrvr,[Brent_Welch],[Brent_Welch],,,,,,
+scipticslsrvr,2577,udp,Scriptics Lsrvr,[Brent_Welch],[Brent_Welch],,,,,,
+rvs-isdn-dcp,2578,tcp,RVS ISDN DCP,[Michael_Zirpel],[Michael_Zirpel],,,,,,
+rvs-isdn-dcp,2578,udp,RVS ISDN DCP,[Michael_Zirpel],[Michael_Zirpel],,,,,,
+mpfoncl,2579,tcp,mpfoncl,[Itaru_Kimura],[Itaru_Kimura],,,,,,
+mpfoncl,2579,udp,mpfoncl,[Itaru_Kimura],[Itaru_Kimura],,,,,,
+tributary,2580,tcp,Tributary,[Louis_Lu],[Louis_Lu],,,,,,
+tributary,2580,udp,Tributary,[Louis_Lu],[Louis_Lu],,,,,,
+argis-te,2581,tcp,ARGIS TE,,,,,,,,
+argis-te,2581,udp,ARGIS TE,,,,,,,,
+argis-ds,2582,tcp,ARGIS DS,[John_Legh_Page],[John_Legh_Page],,,,,,
+argis-ds,2582,udp,ARGIS DS,[John_Legh_Page],[John_Legh_Page],,,,,,
+mon,2583,tcp,MON,[Jim_Trocki],[Jim_Trocki],,,,,,
+mon,2583,udp,MON,[Jim_Trocki],[Jim_Trocki],,,,,,
+cyaserv,2584,tcp,cyaserv,[Morgan_Jones],[Morgan_Jones],,,,,,
+cyaserv,2584,udp,cyaserv,[Morgan_Jones],[Morgan_Jones],,,,,,
+netx-server,2585,tcp,NETX Server,,,,,,,,
+netx-server,2585,udp,NETX Server,,,,,,,,
+netx-agent,2586,tcp,NETX Agent,[Brett_Dolecheck],[Brett_Dolecheck],,,,,,
+netx-agent,2586,udp,NETX Agent,[Brett_Dolecheck],[Brett_Dolecheck],,,,,,
+masc,2587,tcp,MASC,[Pavlin_Ivanov_Radosl],[Pavlin_Ivanov_Radosl],,,,,,
+masc,2587,udp,MASC,[Pavlin_Ivanov_Radosl],[Pavlin_Ivanov_Radosl],,,,,,
+privilege,2588,tcp,Privilege,[Gil_Hecht],[Gil_Hecht],,,,,,
+privilege,2588,udp,Privilege,[Gil_Hecht],[Gil_Hecht],,,,,,
+quartus-tcl,2589,tcp,quartus tcl,[Subroto_Datta],[Subroto_Datta],,,,,,
+quartus-tcl,2589,udp,quartus tcl,[Subroto_Datta],[Subroto_Datta],,,,,,
+idotdist,2590,tcp,idotdist,[Jason_Hunter],[Jason_Hunter],,,,,,
+idotdist,2590,udp,idotdist,[Jason_Hunter],[Jason_Hunter],,,,,,
+maytagshuffle,2591,tcp,Maytag Shuffle,[Ken_Ksiazek],[Ken_Ksiazek],,,,,,
+maytagshuffle,2591,udp,Maytag Shuffle,[Ken_Ksiazek],[Ken_Ksiazek],,,,,,
+netrek,2592,tcp,netrek,[Al_Guetzlaff],[Al_Guetzlaff],,,,,,
+netrek,2592,udp,netrek,[Al_Guetzlaff],[Al_Guetzlaff],,,,,,
+mns-mail,2593,tcp,MNS Mail Notice Service,[Rumiko_Kikuta],[Rumiko_Kikuta],,,,,,
+mns-mail,2593,udp,MNS Mail Notice Service,[Rumiko_Kikuta],[Rumiko_Kikuta],,,,,,
+dts,2594,tcp,Data Base Server,[Andreas_Roene],[Andreas_Roene],,,,,,
+dts,2594,udp,Data Base Server,[Andreas_Roene],[Andreas_Roene],,,,,,
+worldfusion1,2595,tcp,World Fusion 1,,,,,,,,
+worldfusion1,2595,udp,World Fusion 1,,,,,,,,
+worldfusion2,2596,tcp,World Fusion 2,[World_Fusion],[World_Fusion],,,,,,
+worldfusion2,2596,udp,World Fusion 2,[World_Fusion],[World_Fusion],,,,,,
+homesteadglory,2597,tcp,Homestead Glory,[John_Tokash],[John_Tokash],,,,,,
+homesteadglory,2597,udp,Homestead Glory,[John_Tokash],[John_Tokash],,,,,,
+citriximaclient,2598,tcp,Citrix MA Client,[Myk_Willis],[Myk_Willis],,,,,,
+citriximaclient,2598,udp,Citrix MA Client,[Myk_Willis],[Myk_Willis],,,,,,
+snapd,2599,tcp,Snap Discovery,[Kevin_Osborn],[Kevin_Osborn],,,,,,
+snapd,2599,udp,Snap Discovery,[Kevin_Osborn],[Kevin_Osborn],,,,,,
+hpstgmgr,2600,tcp,HPSTGMGR,[Kevin_Collins],[Kevin_Collins],,,,,,
+hpstgmgr,2600,udp,HPSTGMGR,[Kevin_Collins],[Kevin_Collins],,,,,,
+discp-client,2601,tcp,discp client,,,,,,,,
+discp-client,2601,udp,discp client,,,,,,,,
+discp-server,2602,tcp,discp server,[Peter_White],[Peter_White],,,,,,
+discp-server,2602,udp,discp server,[Peter_White],[Peter_White],,,,,,
+servicemeter,2603,tcp,Service Meter,[Duncan_Hare],[Duncan_Hare],,,,,,
+servicemeter,2603,udp,Service Meter,[Duncan_Hare],[Duncan_Hare],,,,,,
+nsc-ccs,2604,tcp,NSC CCS,,,,,,,,
+nsc-ccs,2604,udp,NSC CCS,,,,,,,,
+nsc-posa,2605,tcp,NSC POSA,[Tom_Findley],[Tom_Findley],,,,,,
+nsc-posa,2605,udp,NSC POSA,[Tom_Findley],[Tom_Findley],,,,,,
+netmon,2606,tcp,Dell Netmon,,,,,,,,
+netmon,2606,udp,Dell Netmon,,,,,,,,
+connection,2607,tcp,Dell Connection,[Sudhir_Shetty],[Sudhir_Shetty],,,,,,
+connection,2607,udp,Dell Connection,[Sudhir_Shetty],[Sudhir_Shetty],,,,,,
+wag-service,2608,tcp,Wag Service,[Gilles_Bourquard],[Gilles_Bourquard],,,,,,
+wag-service,2608,udp,Wag Service,[Gilles_Bourquard],[Gilles_Bourquard],,,,,,
+system-monitor,2609,tcp,System Monitor,[Greg_Robson_Garth],[Greg_Robson_Garth],,,,,,
+system-monitor,2609,udp,System Monitor,[Greg_Robson_Garth],[Greg_Robson_Garth],,,,,,
+versa-tek,2610,tcp,VersaTek,[James_Kou],[James_Kou],,,,,,
+versa-tek,2610,udp,VersaTek,[James_Kou],[James_Kou],,,,,,
+lionhead,2611,tcp,LIONHEAD,[Tim_Rance],[Tim_Rance],,,,,,
+lionhead,2611,udp,LIONHEAD,[Tim_Rance],[Tim_Rance],,,,,,
+qpasa-agent,2612,tcp,Qpasa Agent,[Craig_Ching],[Craig_Ching],,,,,,
+qpasa-agent,2612,udp,Qpasa Agent,[Craig_Ching],[Craig_Ching],,,,,,
+smntubootstrap,2613,tcp,SMNTUBootstrap,[Matt_Cecile],[Matt_Cecile],,,,,,
+smntubootstrap,2613,udp,SMNTUBootstrap,[Matt_Cecile],[Matt_Cecile],,,,,,
+neveroffline,2614,tcp,Never Offline,[Dustin_Brand],[Dustin_Brand],,,,,,
+neveroffline,2614,udp,Never Offline,[Dustin_Brand],[Dustin_Brand],,,,,,
+firepower,2615,tcp,firepower,[Jason_Volk],[Jason_Volk],,,,,,
+firepower,2615,udp,firepower,[Jason_Volk],[Jason_Volk],,,,,,
+appswitch-emp,2616,tcp,appswitch-emp,[Ted_Ross],[Ted_Ross],,,,,,
+appswitch-emp,2616,udp,appswitch-emp,[Ted_Ross],[Ted_Ross],,,,,,
+cmadmin,2617,tcp,Clinical Context Managers,[Mark_Morwood],[Mark_Morwood],,,,,,
+cmadmin,2617,udp,Clinical Context Managers,[Mark_Morwood],[Mark_Morwood],,,,,,
+priority-e-com,2618,tcp,Priority E-Com,[Marcelo_Einhorn_2],[Marcelo_Einhorn_2],,,,,,
+priority-e-com,2618,udp,Priority E-Com,[Marcelo_Einhorn_2],[Marcelo_Einhorn_2],,,,,,
+bruce,2619,tcp,bruce,[Alec_Muffett],[Alec_Muffett],,,,,,
+bruce,2619,udp,bruce,[Alec_Muffett],[Alec_Muffett],,,,,,
+lpsrecommender,2620,tcp,LPSRecommender,[Pritham_Shetty_2],[Pritham_Shetty_2],,,,,,
+lpsrecommender,2620,udp,LPSRecommender,[Pritham_Shetty_2],[Pritham_Shetty_2],,,,,,
+miles-apart,2621,tcp,Miles Apart Jukebox Server,[Michael_Rathmann],[Michael_Rathmann],,,,,,
+miles-apart,2621,udp,Miles Apart Jukebox Server,[Michael_Rathmann],[Michael_Rathmann],,,,,,
+metricadbc,2622,tcp,MetricaDBC,[Russ_Olivant],[Russ_Olivant],,,,,,
+metricadbc,2622,udp,MetricaDBC,[Russ_Olivant],[Russ_Olivant],,,,,,
+lmdp,2623,tcp,LMDP,[Ken_Bailey],[Ken_Bailey],,,,,,
+lmdp,2623,udp,LMDP,[Ken_Bailey],[Ken_Bailey],,,,,,
+aria,2624,tcp,Aria,[Logan_Bruns],[Logan_Bruns],,,,,,
+aria,2624,udp,Aria,[Logan_Bruns],[Logan_Bruns],,,,,,
+blwnkl-port,2625,tcp,Blwnkl Port,[Weng_Chin_Yung],[Weng_Chin_Yung],,,,,,
+blwnkl-port,2625,udp,Blwnkl Port,[Weng_Chin_Yung],[Weng_Chin_Yung],,,,,,
+gbjd816,2626,tcp,gbjd816,[George_Balesta],[George_Balesta],,,,,,
+gbjd816,2626,udp,gbjd816,[George_Balesta],[George_Balesta],,,,,,
+moshebeeri,2627,tcp,Moshe Beeri,[Moshe_Beeri],[Moshe_Beeri],,,,,,
+moshebeeri,2627,udp,Moshe Beeri,[Moshe_Beeri],[Moshe_Beeri],,,,,,
+dict,2628,tcp,DICT,[Rik_Faith],[Rik_Faith],,,,,,
+dict,2628,udp,DICT,[Rik_Faith],[Rik_Faith],,,,,,
+sitaraserver,2629,tcp,Sitara Server,,,,,,,,
+sitaraserver,2629,udp,Sitara Server,,,,,,,,
+sitaramgmt,2630,tcp,Sitara Management,,,,,,,,
+sitaramgmt,2630,udp,Sitara Management,,,,,,,,
+sitaradir,2631,tcp,Sitara Dir,[Manickam_R_Sridhar],[Manickam_R_Sridhar],,,,,,
+sitaradir,2631,udp,Sitara Dir,[Manickam_R_Sridhar],[Manickam_R_Sridhar],,,,,,
+irdg-post,2632,tcp,IRdg Post,[IRdg],[IRdg],,,,,,
+irdg-post,2632,udp,IRdg Post,[IRdg],[IRdg],,,,,,
+interintelli,2633,tcp,InterIntelli,[Mike_Gagle],[Mike_Gagle],,,,,,
+interintelli,2633,udp,InterIntelli,[Mike_Gagle],[Mike_Gagle],,,,,,
+pk-electronics,2634,tcp,PK Electronics,[Seb_Ibis],[Seb_Ibis],,,,,,
+pk-electronics,2634,udp,PK Electronics,[Seb_Ibis],[Seb_Ibis],,,,,,
+backburner,2635,tcp,Back Burner,[Kevin_Teiskoetter],[Kevin_Teiskoetter],,,,,,
+backburner,2635,udp,Back Burner,[Kevin_Teiskoetter],[Kevin_Teiskoetter],,,,,,
+solve,2636,tcp,Solve,[Peter_Morrison],[Peter_Morrison],,,,,,
+solve,2636,udp,Solve,[Peter_Morrison],[Peter_Morrison],,,,,,
+imdocsvc,2637,tcp,Import Document Service,[Zia_Bhatti],[Zia_Bhatti],,,,,,
+imdocsvc,2637,udp,Import Document Service,[Zia_Bhatti],[Zia_Bhatti],,,,,,
+sybaseanywhere,2638,tcp,Sybase Anywhere,[Dave_Neudoerffer],[Dave_Neudoerffer],,,,,,
+sybaseanywhere,2638,udp,Sybase Anywhere,[Dave_Neudoerffer],[Dave_Neudoerffer],,,,,,
+aminet,2639,tcp,AMInet,[Alcorn_McBride_Inc],[Alcorn_McBride_Inc],,,,,,
+aminet,2639,udp,AMInet,[Alcorn_McBride_Inc],[Alcorn_McBride_Inc],,,,,,
+sai-sentlm,2640,tcp,"Sabbagh Associates Licence Manager
+IANA assigned this well-formed service name as a replacement for ""sai_sentlm"".",[Elias_Sabbagh],[Elias_Sabbagh],,,,,,
+sai_sentlm,2640,tcp,Sabbagh Associates Licence Manager,[Elias_Sabbagh],[Elias_Sabbagh],,,,,,"This entry is an alias to ""sai-sentlm"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+sai-sentlm,2640,udp,"Sabbagh Associates Licence Manager
+IANA assigned this well-formed service name as a replacement for ""sai_sentlm"".",[Elias_Sabbagh],[Elias_Sabbagh],,,,,,
+sai_sentlm,2640,udp,Sabbagh Associates Licence Manager,[Elias_Sabbagh],[Elias_Sabbagh],,,,,,"This entry is an alias to ""sai-sentlm"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+hdl-srv,2641,tcp,HDL Server,[David_Ely],[David_Ely],,,,,,
+hdl-srv,2641,udp,HDL Server,[David_Ely],[David_Ely],,,,,,
+tragic,2642,tcp,Tragic,[Stu_Mark],[Stu_Mark],,,,,,
+tragic,2642,udp,Tragic,[Stu_Mark],[Stu_Mark],,,,,,
+gte-samp,2643,tcp,GTE-SAMP,[Asher_Altman],[Asher_Altman],,,,,,
+gte-samp,2643,udp,GTE-SAMP,[Asher_Altman],[Asher_Altman],,,,,,
+travsoft-ipx-t,2644,tcp,Travsoft IPX Tunnel,[Jack_Wilson],[Jack_Wilson],,,,,,
+travsoft-ipx-t,2644,udp,Travsoft IPX Tunnel,[Jack_Wilson],[Jack_Wilson],,,,,,
+novell-ipx-cmd,2645,tcp,Novell IPX CMD,[Juan_Carlos_Luciani],[Juan_Carlos_Luciani],,,,,,
+novell-ipx-cmd,2645,udp,Novell IPX CMD,[Juan_Carlos_Luciani],[Juan_Carlos_Luciani],,,,,,
+and-lm,2646,tcp,AND License Manager,[Dick_van_der_Sijs],[Dick_van_der_Sijs],,,,,,
+and-lm,2646,udp,AND License Manager,[Dick_van_der_Sijs],[Dick_van_der_Sijs],,,,,,
+syncserver,2647,tcp,SyncServer,[Shawn_Casey],[Shawn_Casey],,,,,,
+syncserver,2647,udp,SyncServer,[Shawn_Casey],[Shawn_Casey],,,,,,
+upsnotifyprot,2648,tcp,Upsnotifyprot,[Mario_Leboute],[Mario_Leboute],,,,,,
+upsnotifyprot,2648,udp,Upsnotifyprot,[Mario_Leboute],[Mario_Leboute],,,,,,
+vpsipport,2649,tcp,VPSIPPORT,[Joon_Radley],[Joon_Radley],,,,,,
+vpsipport,2649,udp,VPSIPPORT,[Joon_Radley],[Joon_Radley],,,,,,
+eristwoguns,2650,tcp,eristwoguns,[Jason_Lockett][Melanie_Kacerek],[Jason_Lockett][Melanie_Kacerek],2008-12-16,,,,,
+eristwoguns,2650,udp,eristwoguns,[Jason_Lockett][Melanie_Kacerek],[Jason_Lockett][Melanie_Kacerek],2008-12-16,,,,,
+ebinsite,2651,tcp,EBInSite,[Lefteris_Kalamaras],[Lefteris_Kalamaras],,,,,,
+ebinsite,2651,udp,EBInSite,[Lefteris_Kalamaras],[Lefteris_Kalamaras],,,,,,
+interpathpanel,2652,tcp,InterPathPanel,[Stephen_Misel],[Stephen_Misel],,,,,,
+interpathpanel,2652,udp,InterPathPanel,[Stephen_Misel],[Stephen_Misel],,,,,,
+sonus,2653,tcp,Sonus,[Mark_Garti],[Mark_Garti],,,,,,
+sonus,2653,udp,Sonus,[Mark_Garti],[Mark_Garti],,,,,,
+corel-vncadmin,2654,tcp,"Corel VNC Admin
+IANA assigned this well-formed service name as a replacement for ""corel_vncadmin"".",[Oleg_Noskov],[Oleg_Noskov],,,,,,
+corel_vncadmin,2654,tcp,Corel VNC Admin,[Oleg_Noskov],[Oleg_Noskov],,,,,,"This entry is an alias to ""corel-vncadmin"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+corel-vncadmin,2654,udp,"Corel VNC Admin
+IANA assigned this well-formed service name as a replacement for ""corel_vncadmin"".",[Oleg_Noskov],[Oleg_Noskov],,,,,,
+corel_vncadmin,2654,udp,Corel VNC Admin,[Oleg_Noskov],[Oleg_Noskov],,,,,,"This entry is an alias to ""corel-vncadmin"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+unglue,2655,tcp,UNIX Nt Glue,[Peter_Santoro],[Peter_Santoro],,,,,,
+unglue,2655,udp,UNIX Nt Glue,[Peter_Santoro],[Peter_Santoro],,,,,,
+kana,2656,tcp,Kana,[Colin_Goldstein],[Colin_Goldstein],,,,,,
+kana,2656,udp,Kana,[Colin_Goldstein],[Colin_Goldstein],,,,,,
+sns-dispatcher,2657,tcp,SNS Dispatcher,,,,,,,,
+sns-dispatcher,2657,udp,SNS Dispatcher,,,,,,,,
+sns-admin,2658,tcp,SNS Admin,,,,,,,,
+sns-admin,2658,udp,SNS Admin,,,,,,,,
+sns-query,2659,tcp,SNS Query,[Mary_Holstege],[Mary_Holstege],,,,,,
+sns-query,2659,udp,SNS Query,[Mary_Holstege],[Mary_Holstege],,,,,,
+gcmonitor,2660,tcp,GC Monitor,[Gustavo_Rodriguez_Ri],[Gustavo_Rodriguez_Ri],,,,,,
+gcmonitor,2660,udp,GC Monitor,[Gustavo_Rodriguez_Ri],[Gustavo_Rodriguez_Ri],,,,,,
+olhost,2661,tcp,OLHOST,[Robert_Ripberger],[Robert_Ripberger],,,,,,
+olhost,2661,udp,OLHOST,[Robert_Ripberger],[Robert_Ripberger],,,,,,
+bintec-capi,2662,tcp,BinTec-CAPI,,,,,,,Unauthorized Use Known on port 2662,
+bintec-capi,2662,udp,BinTec-CAPI,,,,,,,Unauthorized Use Known on port 2662,
+bintec-tapi,2663,tcp,BinTec-TAPI,,,,,,,,
+bintec-tapi,2663,udp,BinTec-TAPI,,,,,,,,
+patrol-mq-gm,2664,tcp,Patrol for MQ GM,,,,,,,,
+patrol-mq-gm,2664,udp,Patrol for MQ GM,,,,,,,,
+patrol-mq-nm,2665,tcp,Patrol for MQ NM,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+patrol-mq-nm,2665,udp,Patrol for MQ NM,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+extensis,2666,tcp,extensis,[Milton_Sagen],[Milton_Sagen],,,,,,
+extensis,2666,udp,extensis,[Milton_Sagen],[Milton_Sagen],,,,,,
+alarm-clock-s,2667,tcp,Alarm Clock Server,,,,,,,,
+alarm-clock-s,2667,udp,Alarm Clock Server,,,,,,,,
+alarm-clock-c,2668,tcp,Alarm Clock Client,,,,,,,,
+alarm-clock-c,2668,udp,Alarm Clock Client,,,,,,,,
+toad,2669,tcp,TOAD,[Michael_Marking],[Michael_Marking],,,,,,
+toad,2669,udp,TOAD,[Michael_Marking],[Michael_Marking],,,,,,
+tve-announce,2670,tcp,TVE Announce,[Dean_Blackketter],[Dean_Blackketter],,,,,,
+tve-announce,2670,udp,TVE Announce,[Dean_Blackketter],[Dean_Blackketter],,,,,,
+newlixreg,2671,tcp,newlixreg,[Jean_Serge_Gagnon_2],[Jean_Serge_Gagnon_2],,,,,,
+newlixreg,2671,udp,newlixreg,[Jean_Serge_Gagnon_2],[Jean_Serge_Gagnon_2],,,,,,
+nhserver,2672,tcp,nhserver,[Adrian_Hornby],[Adrian_Hornby],,,,,,
+nhserver,2672,udp,nhserver,[Adrian_Hornby],[Adrian_Hornby],,,,,,
+firstcall42,2673,tcp,First Call 42,[Luke_Bowen],[Luke_Bowen],,,,,,
+firstcall42,2673,udp,First Call 42,[Luke_Bowen],[Luke_Bowen],,,,,,
+ewnn,2674,tcp,ewnn,[Yasunari_Yamashita],[Yasunari_Yamashita],,,,,,
+ewnn,2674,udp,ewnn,[Yasunari_Yamashita],[Yasunari_Yamashita],,,,,,
+ttc-etap,2675,tcp,TTC ETAP,[Daniel_Becker],[Daniel_Becker],,,,,,
+ttc-etap,2675,udp,TTC ETAP,[Daniel_Becker],[Daniel_Becker],,,,,,
+simslink,2676,tcp,SIMSLink,[Steve_Ryckman],[Steve_Ryckman],,,,,,
+simslink,2676,udp,SIMSLink,[Steve_Ryckman],[Steve_Ryckman],,,,,,
+gadgetgate1way,2677,tcp,Gadget Gate 1 Way,,,,,,,,
+gadgetgate1way,2677,udp,Gadget Gate 1 Way,,,,,,,,
+gadgetgate2way,2678,tcp,Gadget Gate 2 Way,[Matt_Rollins],[Matt_Rollins],,,,,,
+gadgetgate2way,2678,udp,Gadget Gate 2 Way,[Matt_Rollins],[Matt_Rollins],,,,,,
+syncserverssl,2679,tcp,Sync Server SSL,[Shawn_Casey],[Shawn_Casey],,,,,,
+syncserverssl,2679,udp,Sync Server SSL,[Shawn_Casey],[Shawn_Casey],,,,,,
+pxc-sapxom,2680,tcp,pxc-sapxom,[Hideki_Kiriyama],[Hideki_Kiriyama],,,,,,
+pxc-sapxom,2680,udp,pxc-sapxom,[Hideki_Kiriyama],[Hideki_Kiriyama],,,,,,
+mpnjsomb,2681,tcp,mpnjsomb,[Takenori_Miyahara],[Takenori_Miyahara],,,,,,
+mpnjsomb,2681,udp,mpnjsomb,[Takenori_Miyahara],[Takenori_Miyahara],,,,,,
+,2682,,Removed,,,,2002-04-30,,,,
+ncdloadbalance,2683,tcp,NCDLoadBalance,[Tim_Stevenson],[Tim_Stevenson],,,,,,
+ncdloadbalance,2683,udp,NCDLoadBalance,[Tim_Stevenson],[Tim_Stevenson],,,,,,
+mpnjsosv,2684,tcp,mpnjsosv,,,,,,,,
+mpnjsosv,2684,udp,mpnjsosv,,,,,,,,
+mpnjsocl,2685,tcp,mpnjsocl,,,,,,,,
+mpnjsocl,2685,udp,mpnjsocl,,,,,,,,
+mpnjsomg,2686,tcp,mpnjsomg,[Takenori_Miyahara],[Takenori_Miyahara],,,,,,
+mpnjsomg,2686,udp,mpnjsomg,[Takenori_Miyahara],[Takenori_Miyahara],,,,,,
+pq-lic-mgmt,2687,tcp,pq-lic-mgmt,[Bob_Sledge],[Bob_Sledge],,,,,,
+pq-lic-mgmt,2687,udp,pq-lic-mgmt,[Bob_Sledge],[Bob_Sledge],,,,,,
+md-cg-http,2688,tcp,md-cf-http,[Lyndon_Nerenberg],[Lyndon_Nerenberg],,,,,,
+md-cg-http,2688,udp,md-cf-http,[Lyndon_Nerenberg],[Lyndon_Nerenberg],,,,,,
+fastlynx,2689,tcp,FastLynx,[Dave_Sewell],[Dave_Sewell],,,,,,
+fastlynx,2689,udp,FastLynx,[Dave_Sewell],[Dave_Sewell],,,,,,
+hp-nnm-data,2690,tcp,HP NNM Embedded Database,[Chris_Das],[Chris_Das],,,,,,
+hp-nnm-data,2690,udp,HP NNM Embedded Database,[Chris_Das],[Chris_Das],,,,,,
+itinternet,2691,tcp,ITInternet ISM Server,[Ron_Ehli],[Ron_Ehli],,,,,,
+itinternet,2691,udp,ITInternet ISM Server,[Ron_Ehli],[Ron_Ehli],,,,,,
+admins-lms,2692,tcp,Admins LMS,[Dagfinn_Saether],[Dagfinn_Saether],,,,,,
+admins-lms,2692,udp,Admins LMS,[Dagfinn_Saether],[Dagfinn_Saether],,,,,,
+,2693,tcp,Unassigned,,,,,,,,(Removed 2004-2-6)
+,2693,udp,Unassigned,,,,,,,,(Removed 2004-2-6)
+pwrsevent,2694,tcp,pwrsevent,[Yoshinobu_Nakamura],[Yoshinobu_Nakamura],,,,,,
+pwrsevent,2694,udp,pwrsevent,[Yoshinobu_Nakamura],[Yoshinobu_Nakamura],,,,,,
+vspread,2695,tcp,VSPREAD,[Sumitake_kobayashi],[Sumitake_kobayashi],,,,,,
+vspread,2695,udp,VSPREAD,[Sumitake_kobayashi],[Sumitake_kobayashi],,,,,,
+unifyadmin,2696,tcp,Unify Admin,[Daegis_Inc],[Chris_Anderson],,2012-07-31,,,,
+unifyadmin,2696,udp,Unify Admin,[Daegis_Inc],[Chris_Anderson],,2012-07-31,,,,
+oce-snmp-trap,2697,tcp,Oce SNMP Trap Port,[Peter_Teeuwen],[Peter_Teeuwen],,,,,,
+oce-snmp-trap,2697,udp,Oce SNMP Trap Port,[Peter_Teeuwen],[Peter_Teeuwen],,,,,,
+mck-ivpip,2698,tcp,MCK-IVPIP,[Robert_Vincent],[Robert_Vincent],,,,,,
+mck-ivpip,2698,udp,MCK-IVPIP,[Robert_Vincent],[Robert_Vincent],,,,,,
+csoft-plusclnt,2699,tcp,Csoft Plus Client,[Nedelcho_Stanev],[Nedelcho_Stanev],,,,,,
+csoft-plusclnt,2699,udp,Csoft Plus Client,[Nedelcho_Stanev],[Nedelcho_Stanev],,,,,,
+tqdata,2700,tcp,tqdata,[Al_Guetzlaff],[Al_Guetzlaff],,,,,,
+tqdata,2700,udp,tqdata,[Al_Guetzlaff],[Al_Guetzlaff],,,,,,
+sms-rcinfo,2701,tcp,SMS RCINFO,,,,,,,,
+sms-rcinfo,2701,udp,SMS RCINFO,,,,,,,,
+sms-xfer,2702,tcp,SMS XFER,,,,,,,,
+sms-xfer,2702,udp,SMS XFER,,,,,,,,
+sms-chat,2703,tcp,SMS CHAT,,,,,,,,
+sms-chat,2703,udp,SMS CHAT,,,,,,,,
+sms-remctrl,2704,tcp,SMS REMCTRL,[Tom_Friend],[Tom_Friend],,,,,,
+sms-remctrl,2704,udp,SMS REMCTRL,[Tom_Friend],[Tom_Friend],,,,,,
+sds-admin,2705,tcp,SDS Admin,[Don_Traub],[Don_Traub],,,,,,
+sds-admin,2705,udp,SDS Admin,[Don_Traub],[Don_Traub],,,,,,
+ncdmirroring,2706,tcp,NCD Mirroring,[Tim_Stevenson],[Tim_Stevenson],,,,,,
+ncdmirroring,2706,udp,NCD Mirroring,[Tim_Stevenson],[Tim_Stevenson],,,,,,
+emcsymapiport,2707,tcp,EMCSYMAPIPORT,[Bruce_Ferjulian],[Bruce_Ferjulian],,,,,,
+emcsymapiport,2707,udp,EMCSYMAPIPORT,[Bruce_Ferjulian],[Bruce_Ferjulian],,,,,,
+banyan-net,2708,tcp,Banyan-Net,[R_Thirumurthy],[R_Thirumurthy],,,,,,
+banyan-net,2708,udp,Banyan-Net,[R_Thirumurthy],[R_Thirumurthy],,,,,,
+supermon,2709,tcp,Supermon,[Ron_Minnich],[Ron_Minnich],,,,,,
+supermon,2709,udp,Supermon,[Ron_Minnich],[Ron_Minnich],,,,,,
+sso-service,2710,tcp,SSO Service,,,,,,,,
+sso-service,2710,udp,SSO Service,,,,,,,,
+sso-control,2711,tcp,SSO Control,[Axel_Kern],[Axel_Kern],,,,,,
+sso-control,2711,udp,SSO Control,[Axel_Kern],[Axel_Kern],,,,,,
+aocp,2712,tcp,Axapta Object Communication Protocol,[Jakob_Steen_Hansen],[Jakob_Steen_Hansen],,,,,,
+aocp,2712,udp,Axapta Object Communication Protocol,[Jakob_Steen_Hansen],[Jakob_Steen_Hansen],,,,,,
+raventbs,2713,tcp,Raven Trinity Broker Service,,,,,,,,
+raventbs,2713,udp,Raven Trinity Broker Service,,,,,,,,
+raventdm,2714,tcp,Raven Trinity Data Mover,[Daniel_Sorlov],[Daniel_Sorlov],,,,,,
+raventdm,2714,udp,Raven Trinity Data Mover,[Daniel_Sorlov],[Daniel_Sorlov],,,,,,
+hpstgmgr2,2715,tcp,HPSTGMGR2,[Kevin_Collins_2],[Kevin_Collins_2],,,,,,
+hpstgmgr2,2715,udp,HPSTGMGR2,[Kevin_Collins_2],[Kevin_Collins_2],,,,,,
+inova-ip-disco,2716,tcp,Inova IP Disco,[Chris_Koeritz],[Chris_Koeritz],,,,,,
+inova-ip-disco,2716,udp,Inova IP Disco,[Chris_Koeritz],[Chris_Koeritz],,,,,,
+pn-requester,2717,tcp,PN REQUESTER,,,,,,,,
+pn-requester,2717,udp,PN REQUESTER,,,,,,,,
+pn-requester2,2718,tcp,PN REQUESTER 2,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+pn-requester2,2718,udp,PN REQUESTER 2,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+scan-change,2719,tcp,Scan & Change,[Alexander_Raji],[Alexander_Raji],,,,,,
+scan-change,2719,udp,Scan & Change,[Alexander_Raji],[Alexander_Raji],,,,,,
+wkars,2720,tcp,wkars,[Barry_Shelton],[Barry_Shelton],,,,,,
+wkars,2720,udp,wkars,[Barry_Shelton],[Barry_Shelton],,,,,,
+smart-diagnose,2721,tcp,Smart Diagnose,[Geoffry_Meek],[Geoffry_Meek],,,,,,
+smart-diagnose,2721,udp,Smart Diagnose,[Geoffry_Meek],[Geoffry_Meek],,,,,,
+proactivesrvr,2722,tcp,Proactive Server,[Dalit_Naor],[Dalit_Naor],,,,,,
+proactivesrvr,2722,udp,Proactive Server,[Dalit_Naor],[Dalit_Naor],,,,,,
+watchdog-nt,2723,tcp,WatchDog NT Protocol,[Glen_Sansoucie],[Glen_Sansoucie],,,,,,
+watchdog-nt,2723,udp,WatchDog NT Protocol,[Glen_Sansoucie],[Glen_Sansoucie],,,,,,
+qotps,2724,tcp,qotps,[Piotr_Parlewicz],[Piotr_Parlewicz],,,,,,
+qotps,2724,udp,qotps,[Piotr_Parlewicz],[Piotr_Parlewicz],,,,,,
+msolap-ptp2,2725,tcp,MSOLAP PTP2,[Cristian_Petculescu],[Cristian_Petculescu],,,,,,
+msolap-ptp2,2725,udp,MSOLAP PTP2,[Cristian_Petculescu],[Cristian_Petculescu],,,,,,
+tams,2726,tcp,TAMS,[David_Leinbach],[David_Leinbach],,,,,,
+tams,2726,udp,TAMS,[David_Leinbach],[David_Leinbach],,,,,,
+mgcp-callagent,2727,tcp,Media Gateway Control Protocol Call Agent,[Christian_Huitema],[Christian_Huitema],,,,,,
+mgcp-callagent,2727,udp,Media Gateway Control Protocol Call Agent,[Christian_Huitema],[Christian_Huitema],,,,,,
+sqdr,2728,tcp,SQDR,[Matthew_Orzen],[Matthew_Orzen],,,,,,
+sqdr,2728,udp,SQDR,[Matthew_Orzen],[Matthew_Orzen],,,,,,
+tcim-control,2729,tcp,TCIM Control,[Dean_Skelton],[Dean_Skelton],,,,,,
+tcim-control,2729,udp,TCIM Control,[Dean_Skelton],[Dean_Skelton],,,,,,
+nec-raidplus,2730,tcp,NEC RaidPlus,[Yusuke_Asai],[Yusuke_Asai],,,,,,
+nec-raidplus,2730,udp,NEC RaidPlus,[Yusuke_Asai],[Yusuke_Asai],,,,,,
+fyre-messanger,2731,tcp,Fyre Messanger,[Robert_Waters],[Robert_Waters],,,,,,
+fyre-messanger,2731,udp,Fyre Messagner,[Robert_Waters],[Robert_Waters],,,,,,
+g5m,2732,tcp,G5M,[Graham_Klyne],[Graham_Klyne],,,,,,
+g5m,2732,udp,G5M,[Graham_Klyne],[Graham_Klyne],,,,,,
+signet-ctf,2733,tcp,Signet CTF,[Greg_Broiles],[Greg_Broiles],,,,,,
+signet-ctf,2733,udp,Signet CTF,[Greg_Broiles],[Greg_Broiles],,,,,,
+ccs-software,2734,tcp,CCS Software,[Bertus_Jacobs],[Bertus_Jacobs],,,,,,
+ccs-software,2734,udp,CCS Software,[Bertus_Jacobs],[Bertus_Jacobs],,,,,,
+netiq-mc,2735,tcp,NetIQ Monitor Console,[Scott_Southard],[Scott_Southard],2010-08-25,,,,,
+netiq-mc,2735,udp,NetIQ Monitor Console,[Scott_Southard],[Scott_Southard],2010-08-25,,,,,
+radwiz-nms-srv,2736,tcp,RADWIZ NMS SRV,[Israel_Shainert],[Israel_Shainert],,,,,,
+radwiz-nms-srv,2736,udp,RADWIZ NMS SRV,[Israel_Shainert],[Israel_Shainert],,,,,,
+srp-feedback,2737,tcp,SRP Feedback,[Werner_Almesberger],[Werner_Almesberger],,,,,,
+srp-feedback,2737,udp,SRP Feedback,[Werner_Almesberger],[Werner_Almesberger],,,,,,
+ndl-tcp-ois-gw,2738,tcp,NDL TCP-OSI Gateway,[Martin_Norman],[Martin_Norman],,,,,,
+ndl-tcp-ois-gw,2738,udp,NDL TCP-OSI Gateway,[Martin_Norman],[Martin_Norman],,,,,,
+tn-timing,2739,tcp,TN Timing,[Paul_Roberts],[Paul_Roberts],,,,,,
+tn-timing,2739,udp,TN Timing,[Paul_Roberts],[Paul_Roberts],,,,,,
+alarm,2740,tcp,Alarm,[Uriy_Makasjuk],[Uriy_Makasjuk],,,,,,
+alarm,2740,udp,Alarm,[Uriy_Makasjuk],[Uriy_Makasjuk],,,,,,
+tsb,2741,tcp,TSB,,,,,,,,
+tsb,2741,udp,TSB,,,,,,,,
+tsb2,2742,tcp,TSB2,[Ashish_Chatterjee],[Ashish_Chatterjee],,,,,,
+tsb2,2742,udp,TSB2,[Ashish_Chatterjee],[Ashish_Chatterjee],,,,,,
+murx,2743,tcp,murx,[Thomas_Kuiper],[Thomas_Kuiper],,,,,,
+murx,2743,udp,murx,[Thomas_Kuiper],[Thomas_Kuiper],,,,,,
+honyaku,2744,tcp,honyaku,[Yasunari_Yamashita],[Yasunari_Yamashita],,,,,,
+honyaku,2744,udp,honyaku,[Yasunari_Yamashita],[Yasunari_Yamashita],,,,,,
+urbisnet,2745,tcp,URBISNET,[Urbis_Net_Ltd],[Urbis_Net_Ltd],,,,,,
+urbisnet,2745,udp,URBISNET,[Urbis_Net_Ltd],[Urbis_Net_Ltd],,,,,,
+cpudpencap,2746,tcp,CPUDPENCAP,[Tamir_Zegman],[Tamir_Zegman],,,,,,
+cpudpencap,2746,udp,CPUDPENCAP,[Tamir_Zegman],[Tamir_Zegman],,,,,,
+fjippol-swrly,2747,tcp,,,,,,,,,
+fjippol-swrly,2747,udp,,,,,,,,,
+fjippol-polsvr,2748,tcp,,,,,,,,,
+fjippol-polsvr,2748,udp,,,,,,,,,
+fjippol-cnsl,2749,tcp,,,,,,,,,
+fjippol-cnsl,2749,udp,,,,,,,,,
+fjippol-port1,2750,tcp,,,,,,,,,
+fjippol-port1,2750,udp,,,,,,,,,
+fjippol-port2,2751,tcp,,[Shoichi_Tachibana],[Shoichi_Tachibana],,,,,,
+fjippol-port2,2751,udp,,[Shoichi_Tachibana],[Shoichi_Tachibana],,,,,,
+rsisysaccess,2752,tcp,RSISYS ACCESS,[Christophe_Besant],[Christophe_Besant],,,,,,
+rsisysaccess,2752,udp,RSISYS ACCESS,[Christophe_Besant],[Christophe_Besant],,,,,,
+de-spot,2753,tcp,de-spot,[Sanjay_Parekh],[Sanjay_Parekh],,,,,,
+de-spot,2753,udp,de-spot,[Sanjay_Parekh],[Sanjay_Parekh],,,,,,
+apollo-cc,2754,tcp,APOLLO CC,[Brand_Communications],[Brand_Communications],,,,,,
+apollo-cc,2754,udp,APOLLO CC,[Brand_Communications],[Brand_Communications],,,,,,
+expresspay,2755,tcp,Express Pay,[Ben_Higgins],[Ben_Higgins],,,,,,
+expresspay,2755,udp,Express Pay,[Ben_Higgins],[Ben_Higgins],,,,,,
+simplement-tie,2756,tcp,simplement-tie,[Tzvika_Chumash],[Tzvika_Chumash],,,,,,
+simplement-tie,2756,udp,simplement-tie,[Tzvika_Chumash],[Tzvika_Chumash],,,,,,
+cnrp,2757,tcp,CNRP,[Jacob_Ulmert],[Jacob_Ulmert],,,,,,
+cnrp,2757,udp,CNRP,[Jacob_Ulmert],[Jacob_Ulmert],,,,,,
+apollo-status,2758,tcp,APOLLO Status,,,,,,,,
+apollo-status,2758,udp,APOLLO Status,,,,,,,,
+apollo-gms,2759,tcp,APOLLO GMS,[Simon_Hovell],[Simon_Hovell],,,,,,
+apollo-gms,2759,udp,APOLLO GMS,[Simon_Hovell],[Simon_Hovell],,,,,,
+sabams,2760,tcp,Saba MS,[Davoud_Maha],[Davoud_Maha],,,,,,
+sabams,2760,udp,Saba MS,[Davoud_Maha],[Davoud_Maha],,,,,,
+dicom-iscl,2761,tcp,DICOM ISCL,,,,,,,,
+dicom-iscl,2761,udp,DICOM ISCL,,,,,,,,
+dicom-tls,2762,tcp,DICOM TLS,[Lawrence_Tarbox],[Lawrence_Tarbox],,,,,,
+dicom-tls,2762,udp,DICOM TLS,[Lawrence_Tarbox],[Lawrence_Tarbox],,,,,,
+desktop-dna,2763,tcp,Desktop DNA,[Jon_Walker],[Jon_Walker],,,,,,
+desktop-dna,2763,udp,Desktop DNA,[Jon_Walker],[Jon_Walker],,,,,,
+data-insurance,2764,tcp,Data Insurance,[Brent_Irwin],[Brent_Irwin],,,,,,
+data-insurance,2764,udp,Data Insurance,[Brent_Irwin],[Brent_Irwin],,,,,,
+qip-audup,2765,tcp,qip-audup,[Mike_Morgan],[Mike_Morgan],,,,,,
+qip-audup,2765,udp,qip-audup,[Mike_Morgan],[Mike_Morgan],,,,,,
+compaq-scp,2766,tcp,Compaq SCP,[Ferruccio_Barletta],[Ferruccio_Barletta],,,,,,
+compaq-scp,2766,udp,Compaq SCP,[Ferruccio_Barletta],[Ferruccio_Barletta],,,,,,
+uadtc,2767,tcp,UADTC,,,,,,,,
+uadtc,2767,udp,UADTC,,,,,,,,
+uacs,2768,tcp,UACS,[Vishwas_Lele],[Vishwas_Lele],,,,,,
+uacs,2768,udp,UACS,[Vishwas_Lele],[Vishwas_Lele],,,,,,
+exce,2769,tcp,eXcE,[Norm_Freedman],[Norm_Freedman],,,,,,
+exce,2769,udp,eXcE,[Norm_Freedman],[Norm_Freedman],,,,,,
+veronica,2770,tcp,Veronica,[Jonas_Oberg],[Jonas_Oberg],,,,,,
+veronica,2770,udp,Veronica,[Jonas_Oberg],[Jonas_Oberg],,,,,,
+vergencecm,2771,tcp,Vergence CM,[Mark_Morwood],[Mark_Morwood],,,,,,
+vergencecm,2771,udp,Vergence CM,[Mark_Morwood],[Mark_Morwood],,,,,,
+auris,2772,tcp,auris,[Francisco_Saez_Aranc],[Francisco_Saez_Aranc],,,,,,
+auris,2772,udp,auris,[Francisco_Saez_Aranc],[Francisco_Saez_Aranc],,,,,,
+rbakcup1,2773,tcp,RBackup Remote Backup,,,,,,,,
+rbakcup1,2773,udp,RBackup Remote Backup,,,,,,,,
+rbakcup2,2774,tcp,RBackup Remote Backup,[Rob_Cosgrove],[Rob_Cosgrove],,,,,,
+rbakcup2,2774,udp,RBackup Remote Backup,[Rob_Cosgrove],[Rob_Cosgrove],,,,,,
+smpp,2775,tcp,SMPP,[Owen_Sullivan],[Owen_Sullivan],,,,,,
+smpp,2775,udp,SMPP,[Owen_Sullivan],[Owen_Sullivan],,,,,,
+ridgeway1,2776,tcp,Ridgeway Systems & Software,,,,,,,,
+ridgeway1,2776,udp,Ridgeway Systems & Software,,,,,,,,
+ridgeway2,2777,tcp,Ridgeway Systems & Software,[Steve_Read],[Steve_Read],,,,,,
+ridgeway2,2777,udp,Ridgeway Systems & Software,[Steve_Read],[Steve_Read],,,,,,
+gwen-sonya,2778,tcp,Gwen-Sonya,[Mark_Hurst],[Mark_Hurst],,,,,,
+gwen-sonya,2778,udp,Gwen-Sonya,[Mark_Hurst],[Mark_Hurst],,,,,,
+lbc-sync,2779,tcp,LBC Sync,,,,,,,,
+lbc-sync,2779,udp,LBC Sync,,,,,,,,
+lbc-control,2780,tcp,LBC Control,[Keiji_Michine],[Keiji_Michine],,,,,,
+lbc-control,2780,udp,LBC Control,[Keiji_Michine],[Keiji_Michine],,,,,,
+whosells,2781,tcp,whosells,[William_Randolph_Roy],[William_Randolph_Roy],,,,,,
+whosells,2781,udp,whosells,[William_Randolph_Roy],[William_Randolph_Roy],,,,,,
+everydayrc,2782,tcp,everydayrc,[Ahti_Heinla],[Ahti_Heinla],,,,,,
+everydayrc,2782,udp,everydayrc,[Ahti_Heinla],[Ahti_Heinla],,,,,,
+aises,2783,tcp,AISES,[Daniel_Grazioli],[Daniel_Grazioli],,,,,,
+aises,2783,udp,AISES,[Daniel_Grazioli],[Daniel_Grazioli],,,,,,
+www-dev,2784,tcp,world wide web - development,,,,,,,,
+www-dev,2784,udp,world wide web - development,,,,,,,,
+aic-np,2785,tcp,aic-np,[Brad_Parker],[Brad_Parker],,,,,,
+aic-np,2785,udp,aic-np,[Brad_Parker],[Brad_Parker],,,,,,
+aic-oncrpc,2786,tcp,aic-oncrpc - Destiny MCD database,[Brad_Parker],[Brad_Parker],,,,,,
+aic-oncrpc,2786,udp,aic-oncrpc - Destiny MCD database,[Brad_Parker],[Brad_Parker],,,,,,
+piccolo,2787,tcp,piccolo - Cornerstone Software,[Dave_Bellivea],[Dave_Bellivea],,,,,,
+piccolo,2787,udp,piccolo - Cornerstone Software,[Dave_Bellivea],[Dave_Bellivea],,,,,,
+fryeserv,2788,tcp,NetWare Loadable Module - Seagate Software,[Joseph_LoPilato],[Joseph_LoPilato],,,,,,
+fryeserv,2788,udp,NetWare Loadable Module - Seagate Software,[Joseph_LoPilato],[Joseph_LoPilato],,,,,,
+media-agent,2789,tcp,Media Agent,[Nitzan_Daube],[Nitzan_Daube],,,,,,
+media-agent,2789,udp,Media Agent,[Nitzan_Daube],[Nitzan_Daube],,,,,,
+plgproxy,2790,tcp,PLG Proxy,[Charlie_Hava],[Charlie_Hava],,,,,,
+plgproxy,2790,udp,PLG Proxy,[Charlie_Hava],[Charlie_Hava],,,,,,
+mtport-regist,2791,tcp,MT Port Registrator,[Maxim_Tseitlin],[Maxim_Tseitlin],,,,,,
+mtport-regist,2791,udp,MT Port Registrator,[Maxim_Tseitlin],[Maxim_Tseitlin],,,,,,
+f5-globalsite,2792,tcp,f5-globalsite,[Christian_Saether_2],[Christian_Saether_2],,,,,,
+f5-globalsite,2792,udp,f5-globalsite,[Christian_Saether_2],[Christian_Saether_2],,,,,,
+initlsmsad,2793,tcp,initlsmsad,[Kelly_Green],[Kelly_Green],,,,,,
+initlsmsad,2793,udp,initlsmsad,[Kelly_Green],[Kelly_Green],,,,,,
+,2794,,Unassigned,,,,2006-12-04,,,,
+livestats,2795,tcp,LiveStats,[Chris_Greene],[Chris_Greene],,,,,,
+livestats,2795,udp,LiveStats,[Chris_Greene],[Chris_Greene],,,,,,
+ac-tech,2796,tcp,ac-tech,[Chiming_Huang],[Chiming_Huang],,,,,,
+ac-tech,2796,udp,ac-tech,[Chiming_Huang],[Chiming_Huang],,,,,,
+esp-encap,2797,tcp,esp-encap,[Jorn_Sierwald],[Jorn_Sierwald],,,,,,
+esp-encap,2797,udp,esp-encap,[Jorn_Sierwald],[Jorn_Sierwald],,,,,,
+tmesis-upshot,2798,tcp,TMESIS-UPShot,[Brian_Schenkenberger],[Brian_Schenkenberger],,,,,,
+tmesis-upshot,2798,udp,TMESIS-UPShot,[Brian_Schenkenberger],[Brian_Schenkenberger],,,,,,
+icon-discover,2799,tcp,ICON Discover,[Alexander_Falk],[Alexander_Falk],,,,,,
+icon-discover,2799,udp,ICON Discover,[Alexander_Falk],[Alexander_Falk],,,,,,
+acc-raid,2800,tcp,ACC RAID,[Scott_St_Clair],[Scott_St_Clair],,,,,,
+acc-raid,2800,udp,ACC RAID,[Scott_St_Clair],[Scott_St_Clair],,,,,,
+igcp,2801,tcp,IGCP,[David_Hampson],[David_Hampson],,,,,,
+igcp,2801,udp,IGCP,[David_Hampson],[David_Hampson],,,,,,
+veritas-tcp1,2802,tcp,Veritas TCP1,,,,,,,,
+veritas-udp1,2802,udp,Veritas UDP1,[Russ_Thrasher],[Russ_Thrasher],,,,,,
+btprjctrl,2803,tcp,btprjctrl,[Huw_Thomas],[Huw_Thomas],,,,,,
+btprjctrl,2803,udp,btprjctrl,[Huw_Thomas],[Huw_Thomas],,,,,,
+dvr-esm,2804,tcp,March Networks Digital Video Recorders and Enterprise Service Manager products,[Paul_Streatch],[Paul_Streatch],2004-06,,,,,
+dvr-esm,2804,udp,March Networks Digital Video Recorders and Enterprise Service Manager products,[Paul_Streatch],[Paul_Streatch],2004-06,,,,,
+wta-wsp-s,2805,tcp,WTA WSP-S,[Sebastien_Bury],[Sebastien_Bury],,,,,,
+wta-wsp-s,2805,udp,WTA WSP-S,[Sebastien_Bury],[Sebastien_Bury],,,,,,
+cspuni,2806,tcp,cspuni,,,,,,,,
+cspuni,2806,udp,cspuni,,,,,,,,
+cspmulti,2807,tcp,cspmulti,[Terumasa_Yoneda],[Terumasa_Yoneda],,,,,,
+cspmulti,2807,udp,cspmulti,[Terumasa_Yoneda],[Terumasa_Yoneda],,,,,,
+j-lan-p,2808,tcp,J-LAN-P,[Takeshi_Sahara],[Takeshi_Sahara],,,,,,
+j-lan-p,2808,udp,J-LAN-P,[Takeshi_Sahara],[Takeshi_Sahara],,,,,,
+corbaloc,2809,tcp,CORBA LOC,[Ted_McFadden],[Ted_McFadden],,,,,,
+corbaloc,2809,udp,CORBA LOC,[Ted_McFadden],[Ted_McFadden],,,,,,
+netsteward,2810,tcp,Active Net Steward,[Keith_Morley],[Keith_Morley],,,,,,
+netsteward,2810,udp,Active Net Steward,[Keith_Morley],[Keith_Morley],,,,,,
+gsiftp,2811,tcp,GSI FTP,[Von_Welch],[Von_Welch],,,,,,
+gsiftp,2811,udp,GSI FTP,[Von_Welch],[Von_Welch],,,,,,
+atmtcp,2812,tcp,atmtcp,[Werner_Almesberger],[Werner_Almesberger],,,,,,
+atmtcp,2812,udp,atmtcp,[Werner_Almesberger],[Werner_Almesberger],,,,,,
+llm-pass,2813,tcp,llm-pass,,,,,,,,
+llm-pass,2813,udp,llm-pass,,,,,,,,
+llm-csv,2814,tcp,llm-csv,[Glen_Sansoucie_2],[Glen_Sansoucie_2],,,,,,
+llm-csv,2814,udp,llm-csv,[Glen_Sansoucie_2],[Glen_Sansoucie_2],,,,,,
+lbc-measure,2815,tcp,LBC Measurement,,,,,,,,
+lbc-measure,2815,udp,LBC Measurement,,,,,,,,
+lbc-watchdog,2816,tcp,LBC Watchdog,[Akiyoshi_Ochi],[Akiyoshi_Ochi],,,,,,
+lbc-watchdog,2816,udp,LBC Watchdog,[Akiyoshi_Ochi],[Akiyoshi_Ochi],,,,,,
+nmsigport,2817,tcp,NMSig Port,[Peter_Egli_2],[Peter_Egli_2],,,,,,
+nmsigport,2817,udp,NMSig Port,[Peter_Egli_2],[Peter_Egli_2],,,,,,
+rmlnk,2818,tcp,rmlnk,,,,,,,,
+rmlnk,2818,udp,rmlnk,,,,,,,,
+fc-faultnotify,2819,tcp,FC Fault Notification,[Dave_Watkins],[Dave_Watkins],,,,,,
+fc-faultnotify,2819,udp,FC Fault Notification,[Dave_Watkins],[Dave_Watkins],,,,,,
+univision,2820,tcp,UniVision,[Keith_Ansell],[Keith_Ansell],,,,,,
+univision,2820,udp,UniVision,[Keith_Ansell],[Keith_Ansell],,,,,,
+vrts-at-port,2821,tcp,VERITAS Authentication Service,[Stefan_Winkel],[Stefan_Winkel],,,,,,
+vrts-at-port,2821,udp,VERITAS Authentication Service,[Stefan_Winkel],[Stefan_Winkel],,,,,,
+ka0wuc,2822,tcp,ka0wuc,[Kit_Haskins],[Kit_Haskins],,,,,,
+ka0wuc,2822,udp,ka0wuc,[Kit_Haskins],[Kit_Haskins],,,,,,
+cqg-netlan,2823,tcp,CQG Net/LAN,,,,,,,,
+cqg-netlan,2823,udp,CQG Net/LAN,,,,,,,,
+cqg-netlan-1,2824,tcp,CQG Net/LAN 1,[Jeff_Wood],[Jeff_Wood],,,,,,
+cqg-netlan-1,2824,udp,CQG Net/Lan 1,[Jeff_Wood],[Jeff_Wood],,,,,,
+,2825,,(unassigned) Possibly assigned,,,,,,,,
+slc-systemlog,2826,tcp,slc systemlog,,,,,,,,
+slc-systemlog,2826,udp,slc systemlog,,,,,,,,
+slc-ctrlrloops,2827,tcp,slc ctrlrloops,[Erwin_Hogeweg],[Erwin_Hogeweg],,,,,,
+slc-ctrlrloops,2827,udp,slc ctrlrloops,[Erwin_Hogeweg],[Erwin_Hogeweg],,,,,,
+itm-lm,2828,tcp,ITM License Manager,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+itm-lm,2828,udp,ITM License Manager,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+silkp1,2829,tcp,silkp1,,,,,,,,
+silkp1,2829,udp,silkp1,,,,,,,,
+silkp2,2830,tcp,silkp2,,,,,,,,
+silkp2,2830,udp,silkp2,,,,,,,,
+silkp3,2831,tcp,silkp3,,,,,,,,
+silkp3,2831,udp,silkp3,,,,,,,,
+silkp4,2832,tcp,silkp4,[Erik_Skyten],[Erik_Skyten],,,,,,
+silkp4,2832,udp,silkp4,[Erik_Skyten],[Erik_Skyten],,,,,,
+glishd,2833,tcp,glishd,[Darrell_Schiebel],[Darrell_Schiebel],,,,,,
+glishd,2833,udp,glishd,[Darrell_Schiebel],[Darrell_Schiebel],,,,,,
+evtp,2834,tcp,EVTP,,,,,,,,
+evtp,2834,udp,EVTP,,,,,,,,
+evtp-data,2835,tcp,EVTP-DATA,[Eric_Bruno],[Eric_Bruno],,,,,,
+evtp-data,2835,udp,EVTP-DATA,[Eric_Bruno],[Eric_Bruno],,,,,,
+catalyst,2836,tcp,catalyst,[Garret_Tollkuhn],[Garret_Tollkuhn],,,,,,
+catalyst,2836,udp,catalyst,[Garret_Tollkuhn],[Garret_Tollkuhn],,,,,,
+repliweb,2837,tcp,Repliweb,[William_Orme],[William_Orme],,,,,,
+repliweb,2837,udp,Repliweb,[William_Orme],[William_Orme],,,,,,
+starbot,2838,tcp,Starbot,[Markus_Sabadello_2],[Markus_Sabadello_2],,,,,,
+starbot,2838,udp,Starbot,[Markus_Sabadello_2],[Markus_Sabadello_2],,,,,,
+nmsigport,2839,tcp,NMSigPort,[Peter_Egli_2],[Peter_Egli_2],,,,,,
+nmsigport,2839,udp,NMSigPort,[Peter_Egli_2],[Peter_Egli_2],,,,,,
+l3-exprt,2840,tcp,l3-exprt,,,,,,,,
+l3-exprt,2840,udp,l3-exprt,,,,,,,,
+l3-ranger,2841,tcp,l3-ranger,,,,,,,,
+l3-ranger,2841,udp,l3-ranger,,,,,,,,
+l3-hawk,2842,tcp,l3-hawk,[Dolores_Scott_2],[Dolores_Scott_2],,,,,,
+l3-hawk,2842,udp,l3-hawk,[Dolores_Scott_2],[Dolores_Scott_2],,,,,,
+pdnet,2843,tcp,PDnet,[Torsten_Scheffler],[Torsten_Scheffler],,,,,,
+pdnet,2843,udp,PDnet,[Torsten_Scheffler],[Torsten_Scheffler],,,,,,
+bpcp-poll,2844,tcp,BPCP POLL,,,,,,,,
+bpcp-poll,2844,udp,BPCP POLL,,,,,,,,
+bpcp-trap,2845,tcp,BPCP TRAP,[Steve_Van_Duser],[Steve_Van_Duser],,,,,,
+bpcp-trap,2845,udp,BPCP TRAP,[Steve_Van_Duser],[Steve_Van_Duser],,,,,,
+aimpp-hello,2846,tcp,AIMPP Hello,,,,,,,,
+aimpp-hello,2846,udp,AIMPP Hello,,,,,,,,
+aimpp-port-req,2847,tcp,AIMPP Port Req,[Brian_Martinicky],[Brian_Martinicky],,,,,,
+aimpp-port-req,2847,udp,AIMPP Port Req,[Brian_Martinicky],[Brian_Martinicky],,,,,,
+amt-blc-port,2848,tcp,AMT-BLC-PORT,[Sandra_Frulloni],[Sandra_Frulloni],,,,,,
+amt-blc-port,2848,udp,AMT-BLC-PORT,[Sandra_Frulloni],[Sandra_Frulloni],,,,,,
+fxp,2849,tcp,FXP,[Martin_Lichtin],[Martin_Lichtin],,,,,,
+fxp,2849,udp,FXP,[Martin_Lichtin],[Martin_Lichtin],,,,,,
+metaconsole,2850,tcp,MetaConsole,[Rakesh_Mahajan],[Rakesh_Mahajan],,,,,,
+metaconsole,2850,udp,MetaConsole,[Rakesh_Mahajan],[Rakesh_Mahajan],,,,,,
+webemshttp,2851,tcp,webemshttp,[Stephen_Tsun],[Stephen_Tsun],,,,,,
+webemshttp,2851,udp,webemshttp,[Stephen_Tsun],[Stephen_Tsun],,,,,,
+bears-01,2852,tcp,bears-01,[Bruce_McKinnon],[Bruce_McKinnon],,,,,,
+bears-01,2852,udp,bears-01,[Bruce_McKinnon],[Bruce_McKinnon],,,,,,
+ispipes,2853,tcp,ISPipes,[Rajesh_Nandyalam],[Rajesh_Nandyalam],,,,,,
+ispipes,2853,udp,ISPipes,[Rajesh_Nandyalam],[Rajesh_Nandyalam],,,,,,
+infomover,2854,tcp,InfoMover,[Carla_Caputo],[Carla_Caputo],,,,,,
+infomover,2854,udp,InfoMover,[Carla_Caputo],[Carla_Caputo],,,,,,
+msrp,2855,tcp,MSRP over TCP,,,,2014-04-09,[RFC4976],,,
+,2855,udp,Reserved,,,,2014-04-09,,,,
+cesdinv,2856,tcp,cesdinv,[Yoshiaki_Tokumoto],[Yoshiaki_Tokumoto],,,,,,
+cesdinv,2856,udp,cesdinv,[Yoshiaki_Tokumoto],[Yoshiaki_Tokumoto],,,,,,
+simctlp,2857,tcp,SimCtIP,[Christian_Zietz],[Christian_Zietz],,,,,,
+simctlp,2857,udp,SimCtIP,[Christian_Zietz],[Christian_Zietz],,,,,,
+ecnp,2858,tcp,ECNP,[Robert_Reimiller],[Robert_Reimiller],,,,,,
+ecnp,2858,udp,ECNP,[Robert_Reimiller],[Robert_Reimiller],,,,,,
+activememory,2859,tcp,Active Memory,[Joe_Graham],[Joe_Graham],,,,,,
+activememory,2859,udp,Active Memory,[Joe_Graham],[Joe_Graham],,,,,,
+dialpad-voice1,2860,tcp,Dialpad Voice 1,,,,,,,,
+dialpad-voice1,2860,udp,Dialpad Voice 1,,,,,,,,
+dialpad-voice2,2861,tcp,Dialpad Voice 2,[Wongyu_Cho],[Wongyu_Cho],,,,,,
+dialpad-voice2,2861,udp,Dialpad Voice 2,[Wongyu_Cho],[Wongyu_Cho],,,,,,
+ttg-protocol,2862,tcp,TTG Protocol,[Mark_Boler],[Mark_Boler],,,,,,
+ttg-protocol,2862,udp,TTG Protocol,[Mark_Boler],[Mark_Boler],,,,,,
+sonardata,2863,tcp,Sonar Data,[Ian_Higginbottom],[Ian_Higginbottom],,,,,,
+sonardata,2863,udp,Sonar Data,[Ian_Higginbottom],[Ian_Higginbottom],,,,,,
+astromed-main,2864,tcp,main 5001 cmd,[Chris_Tate],[Chris_Tate],,,,,,
+astromed-main,2864,udp,main 5001 cmd,[Chris_Tate],[Chris_Tate],,,,,,
+pit-vpn,2865,tcp,pit-vpn,[Norbert_Sendetzky],[Norbert_Sendetzky],,,,,,
+pit-vpn,2865,udp,pit-vpn,[Norbert_Sendetzky],[Norbert_Sendetzky],,,,,,
+iwlistener,2866,tcp,iwlistener,[Fred_Surr],[Fred_Surr],,,,,,
+iwlistener,2866,udp,iwlistener,[Fred_Surr],[Fred_Surr],,,,,,
+esps-portal,2867,tcp,esps-portal,[Nicholas_Stowfis],[Nicholas_Stowfis],,,,,,
+esps-portal,2867,udp,esps-portal,[Nicholas_Stowfis],[Nicholas_Stowfis],,,,,,
+npep-messaging,2868,tcp,Norman Proprietaqry Events Protocol,[Norman_Safeground_AS],[Kristian_A_Bognaes],,2014-01-15,,,,
+npep-messaging,2868,udp,Norman Proprietaqry Events Protocol,[Norman_Safeground_AS],[Kristian_A_Bognaes],,2014-01-15,,,,
+icslap,2869,tcp,ICSLAP,[Richard_Lamb],[Richard_Lamb],,,,,,
+icslap,2869,udp,ICSLAP,[Richard_Lamb],[Richard_Lamb],,,,,,
+daishi,2870,tcp,daishi,[Patrick_Chipman],[Patrick_Chipman],,,,,,
+daishi,2870,udp,daishi,[Patrick_Chipman],[Patrick_Chipman],,,,,,
+msi-selectplay,2871,tcp,MSI Select Play,[Paul_Fonte],[Paul_Fonte],,,,,,
+msi-selectplay,2871,udp,MSI Select Play,[Paul_Fonte],[Paul_Fonte],,,,,,
+radix,2872,tcp,RADIX,[Stein_Roger_Skaflott],[Stein_Roger_Skaflott],,2011-07-06,,,,
+radix,2872,udp,RADIX,[Stein_Roger_Skaflott],[Stein_Roger_Skaflott],,2011-07-06,,,,
+,2873,,Unassigned,,,,2003-07-23,,,,
+dxmessagebase1,2874,tcp,DX Message Base Transport Protocol,,,,,,,,
+dxmessagebase1,2874,udp,DX Message Base Transport Protocol,,,,,,,,
+dxmessagebase2,2875,tcp,DX Message Base Transport Protocol,[G_E_Ozz_Nixon_Jr],[G_E_Ozz_Nixon_Jr],2009-01-13,,,,,
+dxmessagebase2,2875,udp,DX Message Base Transport Protocol,[G_E_Ozz_Nixon_Jr],[G_E_Ozz_Nixon_Jr],2009-01-13,,,,,
+sps-tunnel,2876,tcp,SPS Tunnel,[Bill_McIntosh],[Bill_McIntosh],,,,,,
+sps-tunnel,2876,udp,SPS Tunnel,[Bill_McIntosh],[Bill_McIntosh],,,,,,
+bluelance,2877,tcp,BLUELANCE,[Michael_Padrezas],[Michael_Padrezas],,,,,,
+bluelance,2877,udp,BLUELANCE,[Michael_Padrezas],[Michael_Padrezas],,,,,,
+aap,2878,tcp,AAP,[Stephen_Hanna_2],[Stephen_Hanna_2],,,,,,
+aap,2878,udp,AAP,[Stephen_Hanna_2],[Stephen_Hanna_2],,,,,,
+ucentric-ds,2879,tcp,ucentric-ds,[Alex_Vasilevsky],[Alex_Vasilevsky],,,,,,
+ucentric-ds,2879,udp,ucentric-ds,[Alex_Vasilevsky],[Alex_Vasilevsky],,,,,,
+synapse,2880,tcp,Synapse Transport,[Ali_Fracyon],[Ali_Fracyon],,,,,,
+synapse,2880,udp,Synapse Transport,[Ali_Fracyon],[Ali_Fracyon],,,,,,
+ndsp,2881,tcp,NDSP,,,,,,,,
+ndsp,2881,udp,NDSP,,,,,,,,
+ndtp,2882,tcp,NDTP,,,,,,,,
+ndtp,2882,udp,NDTP,,,,,,,,
+ndnp,2883,tcp,NDNP,[Khelben_Blackstaff],[Khelben_Blackstaff],,,,,,
+ndnp,2883,udp,NDNP,[Khelben_Blackstaff],[Khelben_Blackstaff],,,,,,
+flashmsg,2884,tcp,Flash Msg,[Jeffrey_Zinkerman],[Jeffrey_Zinkerman],,,,,,
+flashmsg,2884,udp,Flash Msg,[Jeffrey_Zinkerman],[Jeffrey_Zinkerman],,,,,,
+topflow,2885,tcp,TopFlow,[Ted_Ross],[Ted_Ross],,,,,,
+topflow,2885,udp,TopFlow,[Ted_Ross],[Ted_Ross],,,,,,
+responselogic,2886,tcp,RESPONSELOGIC,[Bruce_Casey],[Bruce_Casey],,,,,,
+responselogic,2886,udp,RESPONSELOGIC,[Bruce_Casey],[Bruce_Casey],,,,,,
+aironetddp,2887,tcp,aironet,[Victor_Griswold],[Victor_Griswold],,,,,,
+aironetddp,2887,udp,aironet,[Victor_Griswold],[Victor_Griswold],,,,,,
+spcsdlobby,2888,tcp,SPCSDLOBBY,[Matthew_Williams],[Matthew_Williams],,,,,,
+spcsdlobby,2888,udp,SPCSDLOBBY,[Matthew_Williams],[Matthew_Williams],,,,,,
+rsom,2889,tcp,RSOM,[Justine_Higgins],[Justine_Higgins],,,,,,
+rsom,2889,udp,RSOM,[Justine_Higgins],[Justine_Higgins],,,,,,
+cspclmulti,2890,tcp,CSPCLMULTI,[Yoneda_Terumasa],[Yoneda_Terumasa],,,,,,
+cspclmulti,2890,udp,CSPCLMULTI,[Yoneda_Terumasa],[Yoneda_Terumasa],,,,,,
+cinegrfx-elmd,2891,tcp,CINEGRFX-ELMD License Manager,[Greg_Ercolano_2],[Greg_Ercolano_2],,,,,,
+cinegrfx-elmd,2891,udp,CINEGRFX-ELMD License Manager,[Greg_Ercolano_2],[Greg_Ercolano_2],,,,,,
+snifferdata,2892,tcp,SNIFFERDATA,[Jeff_Mangasarian],[Jeff_Mangasarian],,,,,,
+snifferdata,2892,udp,SNIFFERDATA,[Jeff_Mangasarian],[Jeff_Mangasarian],,,,,,
+vseconnector,2893,tcp,VSECONNECTOR,[Ingo_Franzki],[Ingo_Franzki],,,,,,
+vseconnector,2893,udp,VSECONNECTOR,[Ingo_Franzki],[Ingo_Franzki],,,,,,
+abacus-remote,2894,tcp,ABACUS-REMOTE,[Mike_Bello],[Mike_Bello],,,,,,
+abacus-remote,2894,udp,ABACUS-REMOTE,[Mike_Bello],[Mike_Bello],,,,,,
+natuslink,2895,tcp,NATUS LINK,[Jonathan_Mergy],[Jonathan_Mergy],,,,,,
+natuslink,2895,udp,NATUS LINK,[Jonathan_Mergy],[Jonathan_Mergy],,,,,,
+ecovisiong6-1,2896,tcp,ECOVISIONG6-1,[Henrik_Holst],[Henrik_Holst],,,,,,
+ecovisiong6-1,2896,udp,ECOVISIONG6-1,[Henrik_Holst],[Henrik_Holst],,,,,,
+citrix-rtmp,2897,tcp,Citrix RTMP,[Myk_Willis],[Myk_Willis],,,,,,
+citrix-rtmp,2897,udp,Citrix RTMP,[Myk_Willis],[Myk_Willis],,,,,,
+appliance-cfg,2898,tcp,APPLIANCE-CFG,[Gary_A_James],[Gary_A_James],,,,,,
+appliance-cfg,2898,udp,APPLIANCE-CFG,[Gary_A_James],[Gary_A_James],,,,,,
+powergemplus,2899,tcp,POWERGEMPLUS,[Koich_Nakamura],[Koich_Nakamura],,,,,,
+powergemplus,2899,udp,POWERGEMPLUS,[Koich_Nakamura],[Koich_Nakamura],,,,,,
+quicksuite,2900,tcp,QUICKSUITE,[William_Egge],[William_Egge],,,,,,
+quicksuite,2900,udp,QUICKSUITE,[William_Egge],[William_Egge],,,,,,
+allstorcns,2901,tcp,ALLSTORCNS,[Steve_Dobson],[Steve_Dobson],,,,,,
+allstorcns,2901,udp,ALLSTORCNS,[Steve_Dobson],[Steve_Dobson],,,,,,
+netaspi,2902,tcp,NET ASPI,[Johnson_Luo],[Johnson_Luo],,,,,,
+netaspi,2902,udp,NET ASPI,[Johnson_Luo],[Johnson_Luo],,,,,,
+suitcase,2903,tcp,SUITCASE,[Milton_E_Sagen],[Milton_E_Sagen],,,,,,
+suitcase,2903,udp,SUITCASE,[Milton_E_Sagen],[Milton_E_Sagen],,,,,,
+m2ua,2904,tcp,M2UA,[Lyndon_Ong],[Lyndon_Ong],,,,,,
+m2ua,2904,udp,M2UA,[Lyndon_Ong],[Lyndon_Ong],,,,,,
+m2ua,2904,sctp,M2UA,[Lyndon_Ong],[Lyndon_Ong],,,,,,
+m3ua,2905,tcp,M3UA,[Lyndon_Ong],[Lyndon_Ong],,,[RFC4666],,,
+,2905,udp,De-registered,,,2001-06-07,,,,,
+m3ua,2905,sctp,M3UA,[Lyndon_Ong],[Lyndon_Ong],,,[RFC4666],,,
+caller9,2906,tcp,CALLER9,[Shams_Naqi],[Shams_Naqi],,,,,,
+caller9,2906,udp,CALLER9,[Shams_Naqi],[Shams_Naqi],,,,,,
+webmethods-b2b,2907,tcp,WEBMETHODS B2B,[Joseph_Hines],[Joseph_Hines],,,,,,
+webmethods-b2b,2907,udp,WEBMETHODS B2B,[Joseph_Hines],[Joseph_Hines],,,,,,
+mao,2908,tcp,mao,[Marc_Baudoin],[Marc_Baudoin],,,,,,
+mao,2908,udp,mao,[Marc_Baudoin],[Marc_Baudoin],,,,,,
+funk-dialout,2909,tcp,Funk Dialout,[Cimarron_Boozer],[Cimarron_Boozer],,,,,,
+funk-dialout,2909,udp,Funk Dialout,[Cimarron_Boozer],[Cimarron_Boozer],,,,,,
+tdaccess,2910,tcp,TDAccess,[Tom_Haapanen],[Tom_Haapanen],,,,,,
+tdaccess,2910,udp,TDAccess,[Tom_Haapanen],[Tom_Haapanen],,,,,,
+blockade,2911,tcp,Blockade,[Blockade],[Blockade],,,,,,
+blockade,2911,udp,Blockade,[Blockade],[Blockade],,,,,,
+epicon,2912,tcp,Epicon,[Michael_Khalandovsky],[Michael_Khalandovsky],,,,,,
+epicon,2912,udp,Epicon,[Michael_Khalandovsky],[Michael_Khalandovsky],,,,,,
+boosterware,2913,tcp,Booster Ware,[Ido_Ben_David],[Ido_Ben_David],,,,,,
+boosterware,2913,udp,Booster Ware,[Ido_Ben_David],[Ido_Ben_David],,,,,,
+gamelobby,2914,tcp,Game Lobby,[Paul_Ford_Hutchinson],[Paul_Ford_Hutchinson],,,,,,
+gamelobby,2914,udp,Game Lobby,[Paul_Ford_Hutchinson],[Paul_Ford_Hutchinson],,,,,,
+tksocket,2915,tcp,TK Socket,[Dino_Ciano],[Dino_Ciano],2011-03-02,,,,,
+tksocket,2915,udp,TK Socket,[Dino_Ciano],[Dino_Ciano],2011-03-02,,,,,
+elvin-server,2916,tcp,"Elvin Server
+IANA assigned this well-formed service name as a replacement for ""elvin_server"".",,,,,,,,
+elvin_server,2916,tcp,Elvin Server,,,,,,,,"This entry is an alias to ""elvin-server"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+elvin-server,2916,udp,"Elvin Server
+IANA assigned this well-formed service name as a replacement for ""elvin_server"".",,,,,,,,
+elvin_server,2916,udp,Elvin Server,,,,,,,,"This entry is an alias to ""elvin-server"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+elvin-client,2917,tcp,"Elvin Client
+IANA assigned this well-formed service name as a replacement for ""elvin_client"".",[David_Arnold],[David_Arnold],,,,,,
+elvin_client,2917,tcp,Elvin Client,[David_Arnold],[David_Arnold],,,,,,"This entry is an alias to ""elvin-client"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+elvin-client,2917,udp,"Elvin Client
+IANA assigned this well-formed service name as a replacement for ""elvin_client"".",[David_Arnold],[David_Arnold],,,,,,
+elvin_client,2917,udp,Elvin Client,[David_Arnold],[David_Arnold],,,,,,"This entry is an alias to ""elvin-client"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+kastenchasepad,2918,tcp,Kasten Chase Pad,[Marc_Gauthier],[Marc_Gauthier],,,,,,
+kastenchasepad,2918,udp,Kasten Chase Pad,[Marc_Gauthier],[Marc_Gauthier],,,,,,
+roboer,2919,tcp,roboER,[Paul_Snook],[Paul_Snook],,,,,,
+roboer,2919,udp,roboER,[Paul_Snook],[Paul_Snook],,,,,,
+roboeda,2920,tcp,roboEDA,[Paul_Snook],[Paul_Snook],,,,,,
+roboeda,2920,udp,roboEDA,[Paul_Snook],[Paul_Snook],,,,,,
+cesdcdman,2921,tcp,CESD Contents Delivery Management,[Shinya_Abe],[Shinya_Abe],,,,,,
+cesdcdman,2921,udp,CESD Contents Delivery Management,[Shinya_Abe],[Shinya_Abe],,,,,,
+cesdcdtrn,2922,tcp,CESD Contents Delivery Data Transfer,[Shinya_Abe],[Shinya_Abe],,,,,,
+cesdcdtrn,2922,udp,CESD Contents Delivery Data Transfer,[Shinya_Abe],[Shinya_Abe],,,,,,
+wta-wsp-wtp-s,2923,tcp,WTA-WSP-WTP-S,[Sebastien_Bury],[Sebastien_Bury],,,,,,
+wta-wsp-wtp-s,2923,udp,WTA-WSP-WTP-S,[Sebastien_Bury],[Sebastien_Bury],,,,,,
+precise-vip,2924,tcp,PRECISE-VIP,[Michael_Landwehr],[Michael_Landwehr],,,,,,
+precise-vip,2924,udp,PRECISE-VIP,[Michael_Landwehr],[Michael_Landwehr],,,,,,
+,2925,,Unassigned (FRP-Released 12/7/00),,,,,,,,
+mobile-file-dl,2926,tcp,MOBILE-FILE-DL,[Mitsuji_Toda],[Mitsuji_Toda],,,,,,
+mobile-file-dl,2926,udp,MOBILE-FILE-DL,[Mitsuji_Toda],[Mitsuji_Toda],,,,,,
+unimobilectrl,2927,tcp,UNIMOBILECTRL,[Vikas],[Vikas],,,,,,
+unimobilectrl,2927,udp,UNIMOBILECTRL,[Vikas],[Vikas],,,,,,
+redstone-cpss,2928,tcp,REDSTONE-CPSS,[Jeff_Looman],[Jeff_Looman],,,,,,
+redstone-cpss,2928,udp,REDSTONE-CPSS,[Jeff_Looman],[Jeff_Looman],,,,,,
+amx-webadmin,2929,tcp,AMX-WEBADMIN,[Mike_Morris],[Mike_Morris],,,,,,
+amx-webadmin,2929,udp,AMX-WEBADMIN,[Mike_Morris],[Mike_Morris],,,,,,
+amx-weblinx,2930,tcp,AMX-WEBLINX,[Mike_Morris],[Mike_Morris],,,,,,
+amx-weblinx,2930,udp,AMX-WEBLINX,[Mike_Morris],[Mike_Morris],,,,,,
+circle-x,2931,tcp,Circle-X,[Norm_Freedman_2],[Norm_Freedman_2],,,,,,
+circle-x,2931,udp,Circle-X,[Norm_Freedman_2],[Norm_Freedman_2],,,,,,
+incp,2932,tcp,INCP,[Keith_Paulsen],[Keith_Paulsen],,,,,,
+incp,2932,udp,INCP,[Keith_Paulsen],[Keith_Paulsen],,,,,,
+4-tieropmgw,2933,tcp,4-TIER OPM GW,[Francois_Peloffy],[Francois_Peloffy],,,,,,
+4-tieropmgw,2933,udp,4-TIER OPM GW,[Francois_Peloffy],[Francois_Peloffy],,,,,,
+4-tieropmcli,2934,tcp,4-TIER OPM CLI,[Francois_Peloffy],[Francois_Peloffy],,,,,,
+4-tieropmcli,2934,udp,4-TIER OPM CLI,[Francois_Peloffy],[Francois_Peloffy],,,,,,
+qtp,2935,tcp,QTP,[Cameron_Young],[Cameron_Young],,,,,,
+qtp,2935,udp,QTP,[Cameron_Young],[Cameron_Young],,,,,,
+otpatch,2936,tcp,OTPatch,[Brett_Goldstein],[Brett_Goldstein],,,,,,
+otpatch,2936,udp,OTPatch,[Brett_Goldstein],[Brett_Goldstein],,,,,,
+pnaconsult-lm,2937,tcp,PNACONSULT-LM,[Theo_Nijssen],[Theo_Nijssen],,,,,,
+pnaconsult-lm,2937,udp,PNACONSULT-LM,[Theo_Nijssen],[Theo_Nijssen],,,,,,
+sm-pas-1,2938,tcp,SM-PAS-1,,,,,,,,
+sm-pas-1,2938,udp,SM-PAS-1,,,,,,,,
+sm-pas-2,2939,tcp,SM-PAS-2,,,,,,,,
+sm-pas-2,2939,udp,SM-PAS-2,,,,,,,,
+sm-pas-3,2940,tcp,SM-PAS-3,,,,,,,,
+sm-pas-3,2940,udp,SM-PAS-3,,,,,,,,
+sm-pas-4,2941,tcp,SM-PAS-4,,,,,,,,
+sm-pas-4,2941,udp,SM-PAS-4,,,,,,,,
+sm-pas-5,2942,tcp,SM-PAS-5,[Tom_Haapanen],[Tom_Haapanen],,,,,,
+sm-pas-5,2942,udp,SM-PAS-5,[Tom_Haapanen],[Tom_Haapanen],,,,,,
+ttnrepository,2943,tcp,TTNRepository,[Robert_Orr],[Robert_Orr],,,,,,
+ttnrepository,2943,udp,TTNRepository,[Robert_Orr],[Robert_Orr],,,,,,
+megaco-h248,2944,tcp,Megaco H-248,[Tom_Taylor_2],[Tom_Taylor_2],,,,,,
+megaco-h248,2944,udp,Megaco H-248,[Tom_Taylor_2],[Tom_Taylor_2],,,,,,
+megaco-h248,2944,sctp,Megaco-H.248 text,[Tom_Taylor_3],[Tom_Taylor_3],2006-09,,,,,
+h248-binary,2945,tcp,H248 Binary,[Tom_Taylor_2],[Tom_Taylor_2],,,,,,
+h248-binary,2945,udp,H248 Binary,[Tom_Taylor_2],[Tom_Taylor_2],,,,,,
+h248-binary,2945,sctp,Megaco/H.248 binary,[Tom_Taylor_3],[Tom_Taylor_3],2006-09,,,,,
+fjsvmpor,2946,tcp,FJSVmpor,[Naoki_Hayashi],[Naoki_Hayashi],,,,,,
+fjsvmpor,2946,udp,FJSVmpor,[Naoki_Hayashi],[Naoki_Hayashi],,,,,,
+gpsd,2947,tcp,GPS Daemon request/response protocol,[Eric_S_Raymond],[Eric_S_Raymond],,2010-04-19,,,,
+gpsd,2947,udp,GPS Daemon request/response protocol,[Eric_S_Raymond],[Eric_S_Raymond],,2010-04-19,,,,
+wap-push,2948,tcp,WAP PUSH,,,,,,,,
+wap-push,2948,udp,WAP PUSH,,,,,,,,
+wap-pushsecure,2949,tcp,WAP PUSH SECURE,[WAP_Forum],[WAP_Forum],,,,,,
+wap-pushsecure,2949,udp,WAP PUSH SECURE,[WAP_Forum],[WAP_Forum],,,,,,
+esip,2950,tcp,ESIP,[David_Stephenson],[David_Stephenson],,,,,,
+esip,2950,udp,ESIP,[David_Stephenson],[David_Stephenson],,,,,,
+ottp,2951,tcp,OTTP,[Brent_Foster],[Brent_Foster],,,,,,
+ottp,2951,udp,OTTP,[Brent_Foster],[Brent_Foster],,,,,,
+mpfwsas,2952,tcp,MPFWSAS,[Toru_Murai],[Toru_Murai],,,,,,
+mpfwsas,2952,udp,MPFWSAS,[Toru_Murai],[Toru_Murai],,,,,,
+ovalarmsrv,2953,tcp,OVALARMSRV,,,,,,,,
+ovalarmsrv,2953,udp,OVALARMSRV,,,,,,,,
+ovalarmsrv-cmd,2954,tcp,OVALARMSRV-CMD,[Eric_Pulsipher],[Eric_Pulsipher],,,,,,
+ovalarmsrv-cmd,2954,udp,OVALARMSRV-CMD,[Eric_Pulsipher],[Eric_Pulsipher],,,,,,
+csnotify,2955,tcp,CSNOTIFY,[Israel_Beniaminy],[Israel_Beniaminy],,,,,,
+csnotify,2955,udp,CSNOTIFY,[Israel_Beniaminy],[Israel_Beniaminy],,,,,,
+ovrimosdbman,2956,tcp,OVRIMOSDBMAN,[Dimitrios_Souflis],[Dimitrios_Souflis],,,,,,
+ovrimosdbman,2956,udp,OVRIMOSDBMAN,[Dimitrios_Souflis],[Dimitrios_Souflis],,,,,,
+jmact5,2957,tcp,JAMCT5,,,,,,,,
+jmact5,2957,udp,JAMCT5,,,,,,,,
+jmact6,2958,tcp,JAMCT6,,,,,,,,
+jmact6,2958,udp,JAMCT6,,,,,,,,
+rmopagt,2959,tcp,RMOPAGT,[Shuji_Okubo],[Shuji_Okubo],,,,,,
+rmopagt,2959,udp,RMOPAGT,[Shuji_Okubo],[Shuji_Okubo],,,,,,
+dfoxserver,2960,tcp,DFOXSERVER,[David_Holden],[David_Holden],,,,,,
+dfoxserver,2960,udp,DFOXSERVER,[David_Holden],[David_Holden],,,,,,
+boldsoft-lm,2961,tcp,BOLDSOFT-LM,[Fredrik_Haglund],[Fredrik_Haglund],,,,,,
+boldsoft-lm,2961,udp,BOLDSOFT-LM,[Fredrik_Haglund],[Fredrik_Haglund],,,,,,
+iph-policy-cli,2962,tcp,IPH-POLICY-CLI,,,,,,,,
+iph-policy-cli,2962,udp,IPH-POLICY-CLI,,,,,,,,
+iph-policy-adm,2963,tcp,IPH-POLICY-ADM,[Shai_Herzog],[Shai_Herzog],,,,,,
+iph-policy-adm,2963,udp,IPH-POLICY-ADM,[Shai_Herzog],[Shai_Herzog],,,,,,
+bullant-srap,2964,tcp,BULLANT SRAP,,,,,,,,
+bullant-srap,2964,udp,BULLANT SRAP,,,,,,,,
+bullant-rap,2965,tcp,BULLANT RAP,[Michael_Cahill],[Michael_Cahill],,,,,,
+bullant-rap,2965,udp,BULLANT RAP,[Michael_Cahill],[Michael_Cahill],,,,,,
+idp-infotrieve,2966,tcp,IDP-INFOTRIEVE,[Kevin_Bruckert],[Kevin_Bruckert],,,,,,
+idp-infotrieve,2966,udp,IDP-INFOTRIEVE,[Kevin_Bruckert],[Kevin_Bruckert],,,,,,
+ssc-agent,2967,tcp,SSC-AGENT,[George_Dzieciol],[George_Dzieciol],,,,,,
+ssc-agent,2967,udp,SSC-AGENT,[George_Dzieciol],[George_Dzieciol],,,,,,
+enpp,2968,tcp,ENPP,[Kazuhito_Gassho],[Kazuhito_Gassho],,,,,,
+enpp,2968,udp,ENPP,[Kazuhito_Gassho],[Kazuhito_Gassho],,,,,,
+essp,2969,tcp,ESSP,[Hitoshi_Ishida],[Hitoshi_Ishida],,,,,,
+essp,2969,udp,ESSP,[Hitoshi_Ishida],[Hitoshi_Ishida],,,,,,
+index-net,2970,tcp,INDEX-NET,[Chris_J_Wren],[Chris_J_Wren],,,,,,
+index-net,2970,udp,INDEX-NET,[Chris_J_Wren],[Chris_J_Wren],,,,,,
+netclip,2971,tcp,NetClip clipboard daemon,[Rudi_Chiarito],[Rudi_Chiarito],,,,,,
+netclip,2971,udp,NetClip clipboard daemon,[Rudi_Chiarito],[Rudi_Chiarito],,,,,,
+pmsm-webrctl,2972,tcp,PMSM Webrctl,[Markus_Michels],[Markus_Michels],,,,,,
+pmsm-webrctl,2972,udp,PMSM Webrctl,[Markus_Michels],[Markus_Michels],,,,,,
+svnetworks,2973,tcp,SV Networks,[Sylvia_Siu_2],[Sylvia_Siu_2],,,,,,
+svnetworks,2973,udp,SV Networks,[Sylvia_Siu_2],[Sylvia_Siu_2],,,,,,
+signal,2974,tcp,Signal,[Wyatt_Williams],[Wyatt_Williams],,,,,,
+signal,2974,udp,Signal,[Wyatt_Williams],[Wyatt_Williams],,,,,,
+fjmpcm,2975,tcp,Fujitsu Configuration Management Service,[Hiroki_Kawano],[Hiroki_Kawano],,,,,,
+fjmpcm,2975,udp,Fujitsu Configuration Management Service,[Hiroki_Kawano],[Hiroki_Kawano],,,,,,
+cns-srv-port,2976,tcp,CNS Server Port,[Ram_Golla],[Ram_Golla],,,,,,
+cns-srv-port,2976,udp,CNS Server Port,[Ram_Golla],[Ram_Golla],,,,,,
+ttc-etap-ns,2977,tcp,TTCs Enterprise Test Access Protocol - NS,,,,,,,,
+ttc-etap-ns,2977,udp,TTCs Enterprise Test Access Protocol - NS,,,,,,,,
+ttc-etap-ds,2978,tcp,TTCs Enterprise Test Access Protocol - DS,[Daniel_Becker_2],[Daniel_Becker_2],,,,,,
+ttc-etap-ds,2978,udp,TTCs Enterprise Test Access Protocol - DS,[Daniel_Becker_2],[Daniel_Becker_2],,,,,,
+h263-video,2979,tcp,H.263 Video Streaming,[Jauvane_C_de_Olivei],[Jauvane_C_de_Olivei],,,,,,
+h263-video,2979,udp,H.263 Video Streaming,[Jauvane_C_de_Olivei],[Jauvane_C_de_Olivei],,,,,,
+wimd,2980,tcp,Instant Messaging Service,[Kevin_Birch],[Kevin_Birch],,,,,,
+wimd,2980,udp,Instant Messaging Service,[Kevin_Birch],[Kevin_Birch],,,,,,
+mylxamport,2981,tcp,MYLXAMPORT,[Wei_Gao],[Wei_Gao],,,,,,
+mylxamport,2981,udp,MYLXAMPORT,[Wei_Gao],[Wei_Gao],,,,,,
+iwb-whiteboard,2982,tcp,IWB-WHITEBOARD,[David_W_Radcliffe],[David_W_Radcliffe],,,,,,
+iwb-whiteboard,2982,udp,IWB-WHITEBOARD,[David_W_Radcliffe],[David_W_Radcliffe],,,,,,
+netplan,2983,tcp,NETPLAN,[Thomas_Driemeyer],[Thomas_Driemeyer],,,,,,
+netplan,2983,udp,NETPLAN,[Thomas_Driemeyer],[Thomas_Driemeyer],,,,,,
+hpidsadmin,2984,tcp,HPIDSADMIN,,,,,,,,
+hpidsadmin,2984,udp,HPIDSADMIN,,,,,,,,
+hpidsagent,2985,tcp,HPIDSAGENT,[John_Trudeau],[John_Trudeau],,,,,,
+hpidsagent,2985,udp,HPIDSAGENT,[John_Trudeau],[John_Trudeau],,,,,,
+stonefalls,2986,tcp,STONEFALLS,[Scott_Grau],[Scott_Grau],,,,,,
+stonefalls,2986,udp,STONEFALLS,[Scott_Grau],[Scott_Grau],,,,,,
+identify,2987,tcp,identify,,,,,,,,
+identify,2987,udp,identify,,,,,,,,
+hippad,2988,tcp,HIPPA Reporting Protocol,[William_Randolph_Roy],[William_Randolph_Roy],,,,,,
+hippad,2988,udp,HIPPA Reporting Protocol,[William_Randolph_Roy],[William_Randolph_Roy],,,,,,
+zarkov,2989,tcp,ZARKOV Intelligent Agent Communication,[Robin_Felix],[Robin_Felix],,2014-02-17,,,,
+zarkov,2989,udp,ZARKOV Intelligent Agent Communication,[Robin_Felix],[Robin_Felix],,2014-02-17,,,,
+boscap,2990,tcp,BOSCAP,[Dirk_Hillbrecht],[Dirk_Hillbrecht],,,,,,
+boscap,2990,udp,BOSCAP,[Dirk_Hillbrecht],[Dirk_Hillbrecht],,,,,,
+wkstn-mon,2991,tcp,WKSTN-MON,[William_David],[William_David],,,,,,
+wkstn-mon,2991,udp,WKSTN-MON,[William_David],[William_David],,,,,,
+avenyo,2992,tcp,Avenyo Server,[Bodo_Rueskamp],[Bodo_Rueskamp],,,,,,
+avenyo,2992,udp,Avenyo Server,[Bodo_Rueskamp],[Bodo_Rueskamp],,,,,,
+veritas-vis1,2993,tcp,VERITAS VIS1,,,,,,,,
+veritas-vis1,2993,udp,VERITAS VIS1,,,,,,,,
+veritas-vis2,2994,tcp,VERITAS VIS2,[Dinkar_Chivaluri],[Dinkar_Chivaluri],,,,,,
+veritas-vis2,2994,udp,VERITAS VIS2,[Dinkar_Chivaluri],[Dinkar_Chivaluri],,,,,,
+idrs,2995,tcp,IDRS,[Jeff_Eaton],[Jeff_Eaton],,,,,,
+idrs,2995,udp,IDRS,[Jeff_Eaton],[Jeff_Eaton],,,,,,
+vsixml,2996,tcp,vsixml,[Rob_Juergens],[Rob_Juergens],,,,,,
+vsixml,2996,udp,vsixml,[Rob_Juergens],[Rob_Juergens],,,,,,
+rebol,2997,tcp,REBOL,[Holger_Kruse],[Holger_Kruse],,,,,,
+rebol,2997,udp,REBOL,[Holger_Kruse],[Holger_Kruse],,,,,,
+realsecure,2998,tcp,Real Secure,[Wes_Wilson],[Wes_Wilson],,,,,,
+realsecure,2998,udp,Real Secure,[Wes_Wilson],[Wes_Wilson],,,,,,
+remoteware-un,2999,tcp,RemoteWare Unassigned,[Tim_Farley],[Tim_Farley],,,,,,
+remoteware-un,2999,udp,RemoteWare Unassigned,[Tim_Farley],[Tim_Farley],,,,,,
+hbci,3000,tcp,HBCI,[Kurt_Haubner],[Kurt_Haubner],,,,,,
+hbci,3000,udp,HBCI,[Kurt_Haubner],[Kurt_Haubner],,,,,,
+remoteware-cl,3000,tcp,RemoteWare Client,[Tim_Farley],[Tim_Farley],,,,,,This entry records an unassigned but widespread use
+remoteware-cl,3000,udp,RemoteWare Client,[Tim_Farley],[Tim_Farley],,,,,,This entry records an unassigned but widespread use
+origo-native,3001,tcp,OrigoDB Server Native Interface,[Devrex_Labs],[Robert_Friberg],,2013-03-29,,,,"port 3001 previously ""Removed on 2006-05-25"""
+,3001,udp,Reserved,,,,2013-03-29,,,,"port 3001 previously ""Removed on 2006-05-25"""
+exlm-agent,3002,tcp,EXLM Agent,[Randy_Martin],[Randy_Martin],,,,,,
+exlm-agent,3002,udp,EXLM Agent,[Randy_Martin],[Randy_Martin],,,,,,
+remoteware-srv,3002,tcp,RemoteWare Server,[Tim_Farley],[Tim_Farley],,,,,,This entry records an unassigned but widespread use
+remoteware-srv,3002,udp,RemoteWare Server,[Tim_Farley],[Tim_Farley],,,,,,This entry records an unassigned but widespread use
+cgms,3003,tcp,CGMS,[Corey_Clinton],[Corey_Clinton],2011-02-02,,,,,
+cgms,3003,udp,CGMS,[Corey_Clinton],[Corey_Clinton],2011-02-02,,,,,
+csoftragent,3004,tcp,Csoft Agent,[Nedelcho_Stanev_2],[Nedelcho_Stanev_2],,,,,,
+csoftragent,3004,udp,Csoft Agent,[Nedelcho_Stanev_2],[Nedelcho_Stanev_2],,,,,,
+geniuslm,3005,tcp,Genius License Manager,[Jakob_Spies],[Jakob_Spies],,,,,,
+geniuslm,3005,udp,Genius License Manager,[Jakob_Spies],[Jakob_Spies],,,,,,
+ii-admin,3006,tcp,Instant Internet Admin,[Lewis_Donzis],[Lewis_Donzis],,,,,,
+ii-admin,3006,udp,Instant Internet Admin,[Lewis_Donzis],[Lewis_Donzis],,,,,,
+lotusmtap,3007,tcp,Lotus Mail Tracking Agent Protocol,[Ken_Lin],[Ken_Lin],,,,,,
+lotusmtap,3007,udp,Lotus Mail Tracking Agent Protocol,[Ken_Lin],[Ken_Lin],,,,,,
+midnight-tech,3008,tcp,Midnight Technologies,[Kyle_Unice],[Kyle_Unice],,,,,,
+midnight-tech,3008,udp,Midnight Technologies,[Kyle_Unice],[Kyle_Unice],,,,,,
+pxc-ntfy,3009,tcp,PXC-NTFY,[Takeshi_Nishizawa],[Takeshi_Nishizawa],,,,,,
+pxc-ntfy,3009,udp,PXC-NTFY,[Takeshi_Nishizawa],[Takeshi_Nishizawa],,,,,,
+gw,3010,tcp,Telerate Workstation,,,,,,,,
+ping-pong,3010,udp,Telerate Workstation,[Timo_Sivonen],[Timo_Sivonen],,,,,,
+trusted-web,3011,tcp,Trusted Web,,,,,,,,
+trusted-web,3011,udp,Trusted Web,,,,,,,,
+twsdss,3012,tcp,Trusted Web Client,[Alex_Duncan],[Alex_Duncan],,,,,,
+twsdss,3012,udp,Trusted Web Client,[Alex_Duncan],[Alex_Duncan],,,,,,
+gilatskysurfer,3013,tcp,Gilat Sky Surfer,[Yossi_Gal],[Yossi_Gal],,,,,,
+gilatskysurfer,3013,udp,Gilat Sky Surfer,[Yossi_Gal],[Yossi_Gal],,,,,,
+broker-service,3014,tcp,"Broker Service
+IANA assigned this well-formed service name as a replacement for ""broker_service"".",[Dale_Bethers],[Dale_Bethers],,,,,,
+broker_service,3014,tcp,Broker Service,[Dale_Bethers],[Dale_Bethers],,,,,,"This entry is an alias to ""broker-service"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+broker-service,3014,udp,"Broker Service
+IANA assigned this well-formed service name as a replacement for ""broker_service"".",[Dale_Bethers],[Dale_Bethers],,,,,,
+broker_service,3014,udp,Broker Service,[Dale_Bethers],[Dale_Bethers],,,,,,"This entry is an alias to ""broker-service"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+nati-dstp,3015,tcp,NATI DSTP,[Paul_Austin],[Paul_Austin],,,,,,
+nati-dstp,3015,udp,NATI DSTP,[Paul_Austin],[Paul_Austin],,,,,,
+notify-srvr,3016,tcp,"Notify Server
+IANA assigned this well-formed service name as a replacement for ""notify_srvr"".",[Hugo_Parra],[Hugo_Parra],,,,,,
+notify_srvr,3016,tcp,Notify Server,[Hugo_Parra],[Hugo_Parra],,,,,,"This entry is an alias to ""notify-srvr"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+notify-srvr,3016,udp,"Notify Server
+IANA assigned this well-formed service name as a replacement for ""notify_srvr"".",[Hugo_Parra],[Hugo_Parra],,,,,,
+notify_srvr,3016,udp,Notify Server,[Hugo_Parra],[Hugo_Parra],,,,,,"This entry is an alias to ""notify-srvr"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+event-listener,3017,tcp,"Event Listener
+IANA assigned this well-formed service name as a replacement for ""event_listener"".",[Ted_Tronson],[Ted_Tronson],,,,,,
+event_listener,3017,tcp,Event Listener,[Ted_Tronson],[Ted_Tronson],,,,,,"This entry is an alias to ""event-listener"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+event-listener,3017,udp,"Event Listener
+IANA assigned this well-formed service name as a replacement for ""event_listener"".",[Ted_Tronson],[Ted_Tronson],,,,,,
+event_listener,3017,udp,Event Listener,[Ted_Tronson],[Ted_Tronson],,,,,,"This entry is an alias to ""event-listener"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+srvc-registry,3018,tcp,"Service Registry
+IANA assigned this well-formed service name as a replacement for ""srvc_registry"".",[Mark_Killgore],[Mark_Killgore],,,,,,
+srvc_registry,3018,tcp,Service Registry,[Mark_Killgore],[Mark_Killgore],,,,,,"This entry is an alias to ""srvc-registry"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+srvc-registry,3018,udp,"Service Registry
+IANA assigned this well-formed service name as a replacement for ""srvc_registry"".",[Mark_Killgore],[Mark_Killgore],,,,,,
+srvc_registry,3018,udp,Service Registry,[Mark_Killgore],[Mark_Killgore],,,,,,"This entry is an alias to ""srvc-registry"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+resource-mgr,3019,tcp,"Resource Manager
+IANA assigned this well-formed service name as a replacement for ""resource_mgr"".",[Gary_Glover],[Gary_Glover],,,,,,
+resource_mgr,3019,tcp,Resource Manager,[Gary_Glover],[Gary_Glover],,,,,,"This entry is an alias to ""resource-mgr"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+resource-mgr,3019,udp,"Resource Manager
+IANA assigned this well-formed service name as a replacement for ""resource_mgr"".",[Gary_Glover],[Gary_Glover],,,,,,
+resource_mgr,3019,udp,Resource Manager,[Gary_Glover],[Gary_Glover],,,,,,"This entry is an alias to ""resource-mgr"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+cifs,3020,tcp,CIFS,[Paul_Leach],[Paul_Leach],,,,,,
+cifs,3020,udp,CIFS,[Paul_Leach],[Paul_Leach],,,,,,
+agriserver,3021,tcp,AGRI Server,[Frank_Neulichedl],[Frank_Neulichedl],,,,,,
+agriserver,3021,udp,AGRI Server,[Frank_Neulichedl],[Frank_Neulichedl],,,,,,
+csregagent,3022,tcp,CSREGAGENT,[Nedelcho_Stanev],[Nedelcho_Stanev],,,,,,
+csregagent,3022,udp,CSREGAGENT,[Nedelcho_Stanev],[Nedelcho_Stanev],,,,,,
+magicnotes,3023,tcp,magicnotes,[Karl_Edwall],[Karl_Edwall],,,,,,
+magicnotes,3023,udp,magicnotes,[Karl_Edwall],[Karl_Edwall],,,,,,
+nds-sso,3024,tcp,"NDS_SSO
+IANA assigned this well-formed service name as a replacement for ""nds_sso"".",[Mel_Oyler],[Mel_Oyler],,,,,,
+nds_sso,3024,tcp,NDS_SSO,[Mel_Oyler],[Mel_Oyler],,,,,,"This entry is an alias to ""nds-sso"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+nds-sso,3024,udp,"NDS_SSO
+IANA assigned this well-formed service name as a replacement for ""nds_sso"".",[Mel_Oyler],[Mel_Oyler],,,,,,
+nds_sso,3024,udp,NDS_SSO,[Mel_Oyler],[Mel_Oyler],,,,,,"This entry is an alias to ""nds-sso"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+arepa-raft,3025,tcp,Arepa Raft,[Stuart_Schaefer],[Stuart_Schaefer],,,,,,
+arepa-raft,3025,udp,Arepa Raft,[Stuart_Schaefer],[Stuart_Schaefer],,,,,,
+agri-gateway,3026,tcp,AGRI Gateway,[Agri_Datalog],[Agri_Datalog],,,,,,
+agri-gateway,3026,udp,AGRI Gateway,[Agri_Datalog],[Agri_Datalog],,,,,,
+LiebDevMgmt-C,3027,tcp,"LiebDevMgmt_C
+IANA assigned this well-formed service name as a replacement for ""LiebDevMgmt_C"".",,,,,,,,
+LiebDevMgmt_C,3027,tcp,LiebDevMgmt_C,,,,,,,,"This entry is an alias to ""LiebDevMgmt-C"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+LiebDevMgmt-C,3027,udp,"LiebDevMgmt_C
+IANA assigned this well-formed service name as a replacement for ""LiebDevMgmt_C"".",,,,,,,,
+LiebDevMgmt_C,3027,udp,LiebDevMgmt_C,,,,,,,,"This entry is an alias to ""LiebDevMgmt-C"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+LiebDevMgmt-DM,3028,tcp,"LiebDevMgmt_DM
+IANA assigned this well-formed service name as a replacement for ""LiebDevMgmt_DM"".",,,,,,,,
+LiebDevMgmt_DM,3028,tcp,LiebDevMgmt_DM,,,,,,,,"This entry is an alias to ""LiebDevMgmt-DM"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+LiebDevMgmt-DM,3028,udp,"LiebDevMgmt_DM
+IANA assigned this well-formed service name as a replacement for ""LiebDevMgmt_DM"".",,,,,,,,
+LiebDevMgmt_DM,3028,udp,LiebDevMgmt_DM,,,,,,,,"This entry is an alias to ""LiebDevMgmt-DM"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+LiebDevMgmt-A,3029,tcp,"LiebDevMgmt_A
+IANA assigned this well-formed service name as a replacement for ""LiebDevMgmt_A"".",[Mike_Velten],[Mike_Velten],,,,,,
+LiebDevMgmt_A,3029,tcp,LiebDevMgmt_A,[Mike_Velten],[Mike_Velten],,,,,,"This entry is an alias to ""LiebDevMgmt-A"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+LiebDevMgmt-A,3029,udp,"LiebDevMgmt_A
+IANA assigned this well-formed service name as a replacement for ""LiebDevMgmt_A"".",[Mike_Velten],[Mike_Velten],,,,,,
+LiebDevMgmt_A,3029,udp,LiebDevMgmt_A,[Mike_Velten],[Mike_Velten],,,,,,"This entry is an alias to ""LiebDevMgmt-A"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+arepa-cas,3030,tcp,Arepa Cas,[Stuart_Schaefer],[Stuart_Schaefer],,,,,,
+arepa-cas,3030,udp,Arepa Cas,[Stuart_Schaefer],[Stuart_Schaefer],,,,,,
+eppc,3031,tcp,Remote AppleEvents/PPC Toolbox,[Steve_Zellers],[Steve_Zellers],,,,,,
+eppc,3031,udp,Remote AppleEvents/PPC Toolbox,[Steve_Zellers],[Steve_Zellers],,,,,,
+redwood-chat,3032,tcp,Redwood Chat,[Songwon_Chi],[Songwon_Chi],,,,,,
+redwood-chat,3032,udp,Redwood Chat,[Songwon_Chi],[Songwon_Chi],,,,,,
+pdb,3033,tcp,PDB,[Don_Bowman],[Don_Bowman],,,,,,
+pdb,3033,udp,PDB,[Don_Bowman],[Don_Bowman],,,,,,
+osmosis-aeea,3034,tcp,Osmosis / Helix (R) AEEA Port,[Larry_Atkin],[Larry_Atkin],,,,,,
+osmosis-aeea,3034,udp,Osmosis / Helix (R) AEEA Port,[Larry_Atkin],[Larry_Atkin],,,,,,
+fjsv-gssagt,3035,tcp,FJSV gssagt,[Tomoji_Koike],[Tomoji_Koike],,,,,,
+fjsv-gssagt,3035,udp,FJSV gssagt,[Tomoji_Koike],[Tomoji_Koike],,,,,,
+hagel-dump,3036,tcp,Hagel DUMP,[Haim_Gelfenbeyn],[Haim_Gelfenbeyn],,,,,,
+hagel-dump,3036,udp,Hagel DUMP,[Haim_Gelfenbeyn],[Haim_Gelfenbeyn],,,,,,
+hp-san-mgmt,3037,tcp,HP SAN Mgmt,[Steve_Britt],[Steve_Britt],,,,,,
+hp-san-mgmt,3037,udp,HP SAN Mgmt,[Steve_Britt],[Steve_Britt],,,,,,
+santak-ups,3038,tcp,Santak UPS,[Tom_Liu],[Tom_Liu],,,,,,
+santak-ups,3038,udp,Santak UPS,[Tom_Liu],[Tom_Liu],,,,,,
+cogitate,3039,tcp,"Cogitate, Inc.",[Jim_Harlan],[Jim_Harlan],,,,,,
+cogitate,3039,udp,"Cogitate, Inc.",[Jim_Harlan],[Jim_Harlan],,,,,,
+tomato-springs,3040,tcp,Tomato Springs,[Jack_Waller_III],[Jack_Waller_III],,,,,,
+tomato-springs,3040,udp,Tomato Springs,[Jack_Waller_III],[Jack_Waller_III],,,,,,
+di-traceware,3041,tcp,di-traceware,[Carlos_Hung],[Carlos_Hung],,,,,,
+di-traceware,3041,udp,di-traceware,[Carlos_Hung],[Carlos_Hung],,,,,,
+journee,3042,tcp,journee,[Kevin_Calman],[Kevin_Calman],,,,,,
+journee,3042,udp,journee,[Kevin_Calman],[Kevin_Calman],,,,,,
+brp,3043,tcp,Broadcast Routing Protocol,[John_Border],[John_Border],,,,,,
+brp,3043,udp,Broadcast Routing Protocol,[John_Border],[John_Border],,,,,,
+epp,3044,tcp,EndPoint Protocol,[Stephen_Cipolli],[Stephen_Cipolli],,,,,,
+epp,3044,udp,EndPoint Protocol,[Stephen_Cipolli],[Stephen_Cipolli],,,,,,
+responsenet,3045,tcp,ResponseNet,[Chul_Yoon],[Chul_Yoon],,,,,,
+responsenet,3045,udp,ResponseNet,[Chul_Yoon],[Chul_Yoon],,,,,,
+di-ase,3046,tcp,di-ase,[Carlos_Hung],[Carlos_Hung],,,,,,
+di-ase,3046,udp,di-ase,[Carlos_Hung],[Carlos_Hung],,,,,,
+hlserver,3047,tcp,Fast Security HL Server,[Safenet_Inc.],[Michael_Zunke_3],,2014-07-02,,,,
+hlserver,3047,udp,Fast Security HL Server,[Safenet_Inc.],[Michael_Zunke_3],,2014-07-02,,,,
+pctrader,3048,tcp,Sierra Net PC Trader,[Chris_Hahn],[Chris_Hahn],,,,,,
+pctrader,3048,udp,Sierra Net PC Trader,[Chris_Hahn],[Chris_Hahn],,,,,,
+nsws,3049,tcp,NSWS,[Ray_Gwinn],[Ray_Gwinn],,,,,,
+nsws,3049,udp,NSWS,[Ray_Gwinn],[Ray_Gwinn],,,,,,
+gds-db,3050,tcp,"gds_db
+IANA assigned this well-formed service name as a replacement for ""gds_db"".",[Madhukar_N_Thakur],[Madhukar_N_Thakur],,,,,,
+gds_db,3050,tcp,gds_db,[Madhukar_N_Thakur],[Madhukar_N_Thakur],,,,,,"This entry is an alias to ""gds-db"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+gds-db,3050,udp,"gds_db
+IANA assigned this well-formed service name as a replacement for ""gds_db"".",[Madhukar_N_Thakur],[Madhukar_N_Thakur],,,,,,
+gds_db,3050,udp,gds_db,[Madhukar_N_Thakur],[Madhukar_N_Thakur],,,,,,"This entry is an alias to ""gds-db"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+galaxy-server,3051,tcp,Galaxy Server,[Michael_Andre],[Michael_Andre],,,,,,
+galaxy-server,3051,udp,Galaxy Server,[Michael_Andre],[Michael_Andre],,,,,,
+apc-3052,3052,tcp,APC 3052,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-3052,3052,udp,APC 3052,[American_Power_Conve],[American_Power_Conve],,,,,,
+dsom-server,3053,tcp,dsom-server,[Daniel_Sisk],[Daniel_Sisk],,,,,,
+dsom-server,3053,udp,dsom-server,[Daniel_Sisk],[Daniel_Sisk],,,,,,
+amt-cnf-prot,3054,tcp,AMT CNF PROT,[Marco_Marcucci],[Marco_Marcucci],,,,,,
+amt-cnf-prot,3054,udp,AMT CNF PROT,[Marco_Marcucci],[Marco_Marcucci],,,,,,
+policyserver,3055,tcp,Policy Server,[Mark_Garti],[Mark_Garti],,,,,,
+policyserver,3055,udp,Policy Server,[Mark_Garti],[Mark_Garti],,,,,,
+cdl-server,3056,tcp,CDL Server,[Paul_Roberts],[Paul_Roberts],,,,,,
+cdl-server,3056,udp,CDL Server,[Paul_Roberts],[Paul_Roberts],,,,,,
+goahead-fldup,3057,tcp,GoAhead FldUp,[Alan_Pickrell],[Alan_Pickrell],,,,,,
+goahead-fldup,3057,udp,GoAhead FldUp,[Alan_Pickrell],[Alan_Pickrell],,,,,,
+videobeans,3058,tcp,videobeans,[Hiroyuki_Takahashi],[Hiroyuki_Takahashi],,,,,,
+videobeans,3058,udp,videobeans,[Hiroyuki_Takahashi],[Hiroyuki_Takahashi],,,,,,
+qsoft,3059,tcp,qsoft,[James_Kunz],[James_Kunz],,,,,,
+qsoft,3059,udp,qsoft,[James_Kunz],[James_Kunz],,,,,,
+interserver,3060,tcp,interserver,[Madhukar_N_Thakur],[Madhukar_N_Thakur],,,,,Known Unauthorized Use on port 3060,
+interserver,3060,udp,interserver,[Madhukar_N_Thakur],[Madhukar_N_Thakur],,,,,Known Unauthorized Use on port 3060,
+cautcpd,3061,tcp,cautcpd,,,,,,,,
+cautcpd,3061,udp,cautcpd,,,,,,,,
+ncacn-ip-tcp,3062,tcp,ncacn-ip-tcp,,,,,,,,
+ncacn-ip-tcp,3062,udp,ncacn-ip-tcp,,,,,,,,
+ncadg-ip-udp,3063,tcp,ncadg-ip-udp,[Gabi_Kalmar],[Gabi_Kalmar],,,,,,
+ncadg-ip-udp,3063,udp,ncadg-ip-udp,[Gabi_Kalmar],[Gabi_Kalmar],,,,,,
+rprt,3064,tcp,Remote Port Redirector,[Robin_Johnston],[Robin_Johnston],,,,,,
+rprt,3064,udp,Remote Port Redirector,[Robin_Johnston],[Robin_Johnston],,,,,,
+slinterbase,3065,tcp,slinterbase,[Bie_Tie],[Bie_Tie],,,,,,
+slinterbase,3065,udp,slinterbase,[Bie_Tie],[Bie_Tie],,,,,,
+netattachsdmp,3066,tcp,NETATTACHSDMP,[Mike_Young],[Mike_Young],,,,,,
+netattachsdmp,3066,udp,NETATTACHSDMP,[Mike_Young],[Mike_Young],,,,,,
+fjhpjp,3067,tcp,FJHPJP,[Ryozo_Furutani],[Ryozo_Furutani],,,,,,
+fjhpjp,3067,udp,FJHPJP,[Ryozo_Furutani],[Ryozo_Furutani],,,,,,
+ls3bcast,3068,tcp,ls3 Broadcast,,,,,,,,
+ls3bcast,3068,udp,ls3 Broadcast,,,,,,,,
+ls3,3069,tcp,ls3,[Jim_Thompson],[Jim_Thompson],,,,,,
+ls3,3069,udp,ls3,[Jim_Thompson],[Jim_Thompson],,,,,,
+mgxswitch,3070,tcp,MGXSWITCH,[George_Walter],[George_Walter],,,,,,
+mgxswitch,3070,udp,MGXSWITCH,[George_Walter],[George_Walter],,,,,,
+csd-mgmt-port,3071,tcp,ContinuStor Manager Port,[NetApp],[MSW_architecture_team],,2014-07-18,,,,
+csd-mgmt-port,3071,udp,ContinuStor Manager Port,[NetApp],[MSW_architecture_team],,2014-07-18,,,,
+csd-monitor,3072,tcp,ContinuStor Monitor Port,[NetApp],[MSW_architecture_team],,2014-07-18,,,,
+csd-monitor,3072,udp,ContinuStor Monitor Port,[NetApp],[MSW_architecture_team],,2014-07-18,,,,
+vcrp,3073,tcp,Very simple chatroom prot,[Andreas_Wurf],[Andreas_Wurf],,,,,,
+vcrp,3073,udp,Very simple chatroom prot,[Andreas_Wurf],[Andreas_Wurf],,,,,,
+xbox,3074,tcp,Xbox game port,[Damon_Danieli],[Damon_Danieli],,,,,,
+xbox,3074,udp,Xbox game port,[Damon_Danieli],[Damon_Danieli],,,,,,
+orbix-locator,3075,tcp,Orbix 2000 Locator,,,,,,,,
+orbix-locator,3075,udp,Orbix 2000 Locator,,,,,,,,
+orbix-config,3076,tcp,Orbix 2000 Config,,,,,,,,
+orbix-config,3076,udp,Orbix 2000 Config,,,,,,,,
+orbix-loc-ssl,3077,tcp,Orbix 2000 Locator SSL,,,,,,,,
+orbix-loc-ssl,3077,udp,Orbix 2000 Locator SSL,,,,,,,,
+orbix-cfg-ssl,3078,tcp,Orbix 2000 Locator SSL,[Eric_Newcomer],[Eric_Newcomer],,,,,,
+orbix-cfg-ssl,3078,udp,Orbix 2000 Locator SSL,[Eric_Newcomer],[Eric_Newcomer],,,,,,
+lv-frontpanel,3079,tcp,LV Front Panel,[Darshan_Shah],[Darshan_Shah],,,,,,
+lv-frontpanel,3079,udp,LV Front Panel,[Darshan_Shah],[Darshan_Shah],,,,,,
+stm-pproc,3080,tcp,"stm_pproc
+IANA assigned this well-formed service name as a replacement for ""stm_pproc"".",[Paul_McGinnis],[Paul_McGinnis],,,,,,
+stm_pproc,3080,tcp,stm_pproc,[Paul_McGinnis],[Paul_McGinnis],,,,,,"This entry is an alias to ""stm-pproc"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+stm-pproc,3080,udp,"stm_pproc
+IANA assigned this well-formed service name as a replacement for ""stm_pproc"".",[Paul_McGinnis],[Paul_McGinnis],,,,,,
+stm_pproc,3080,udp,stm_pproc,[Paul_McGinnis],[Paul_McGinnis],,,,,,"This entry is an alias to ""stm-pproc"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+tl1-lv,3081,tcp,TL1-LV,,,,,,,,
+tl1-lv,3081,udp,TL1-LV,,,,,,,,
+tl1-raw,3082,tcp,TL1-RAW,,,,,,,,
+tl1-raw,3082,udp,TL1-RAW,,,,,,,,
+tl1-telnet,3083,tcp,TL1-TELNET,[SONET_Internetworkin],[SONET_Internetworkin],,,,,,
+tl1-telnet,3083,udp,TL1-TELNET,[SONET_Internetworkin],[SONET_Internetworkin],,,,,,
+itm-mccs,3084,tcp,ITM-MCCS,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+itm-mccs,3084,udp,ITM-MCCS,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+pcihreq,3085,tcp,PCIHReq,[Paul_Sanders],[Paul_Sanders],,,,,,
+pcihreq,3085,udp,PCIHReq,[Paul_Sanders],[Paul_Sanders],,,,,,
+jdl-dbkitchen,3086,tcp,JDL-DBKitchen,[Hideo_Wakabayashi],[Hideo_Wakabayashi],,,,,,
+jdl-dbkitchen,3086,udp,JDL-DBKitchen,[Hideo_Wakabayashi],[Hideo_Wakabayashi],,,,,,
+asoki-sma,3087,tcp,Asoki SMA,[Andrew_Mossberg],[Andrew_Mossberg],,,,,,
+asoki-sma,3087,udp,Asoki SMA,[Andrew_Mossberg],[Andrew_Mossberg],,,,,,
+xdtp,3088,tcp,eXtensible Data Transfer Protocol,[Michael_Shearson],[Michael_Shearson],,,,,,
+xdtp,3088,udp,eXtensible Data Transfer Protocol,[Michael_Shearson],[Michael_Shearson],,,,,,
+ptk-alink,3089,tcp,ParaTek Agent Linking,[Robert_Hodgson_2],[Robert_Hodgson_2],,,,,,
+ptk-alink,3089,udp,ParaTek Agent Linking,[Robert_Hodgson_2],[Robert_Hodgson_2],,,,,,
+stss,3090,tcp,Senforce Session Services,[Peter_Boucher],[Peter_Boucher],,,,,,
+stss,3090,udp,Senforce Session Services,[Peter_Boucher],[Peter_Boucher],,,,,,
+1ci-smcs,3091,tcp,1Ci Server Management,[Ralf_Bensmann],[Ralf_Bensmann],,,,,,
+1ci-smcs,3091,udp,1Ci Server Management,[Ralf_Bensmann],[Ralf_Bensmann],,,,,,
+,3092,,Unassigned,,,,2008-04-22,,,,
+rapidmq-center,3093,tcp,Jiiva RapidMQ Center,,,,,,,,
+rapidmq-center,3093,udp,Jiiva RapidMQ Center,,,,,,,,
+rapidmq-reg,3094,tcp,Jiiva RapidMQ Registry,[Mark_Ericksen],[Mark_Ericksen],,,,,,
+rapidmq-reg,3094,udp,Jiiva RapidMQ Registry,[Mark_Ericksen],[Mark_Ericksen],,,,,,
+panasas,3095,tcp,Panasas rendevous port,[Peter_Berger],[Peter_Berger],,,,,,
+panasas,3095,udp,Panasas rendevous port,[Peter_Berger],[Peter_Berger],,,,,,
+ndl-aps,3096,tcp,Active Print Server Port,[Martin_Norman],[Martin_Norman],,,,,,
+ndl-aps,3096,udp,Active Print Server Port,[Martin_Norman],[Martin_Norman],,,,,,
+,3097,tcp,Reserved,,,,,,,,
+,3097,udp,Reserved,,,,,,,,
+itu-bicc-stc,3097,sctp,ITU-T Q.1902.1/Q.2150.3,[Greg_Sidebottom],[Greg_Sidebottom],,,,,,
+umm-port,3098,tcp,Universal Message Manager,[Phil_Braham],[Phil_Braham],,,,,,
+umm-port,3098,udp,Universal Message Manager,[Phil_Braham],[Phil_Braham],,,,,,
+chmd,3099,tcp,CHIPSY Machine Daemon,[Trond_Borsting],[Trond_Borsting],,,,,,
+chmd,3099,udp,CHIPSY Machine Daemon,[Trond_Borsting],[Trond_Borsting],,,,,,
+opcon-xps,3100,tcp,OpCon/xps,[David_Bourland],[David_Bourland],,,,,,
+opcon-xps,3100,udp,OpCon/xps,[David_Bourland],[David_Bourland],,,,,,
+hp-pxpib,3101,tcp,HP PolicyXpert PIB Server,[Brian_O_Keefe],[Brian_O_Keefe],,,,,,
+hp-pxpib,3101,udp,HP PolicyXpert PIB Server,[Brian_O_Keefe],[Brian_O_Keefe],,,,,,
+slslavemon,3102,tcp,SoftlinK Slave Mon Port,[Moshe_Livne],[Moshe_Livne],,,,,,
+slslavemon,3102,udp,SoftlinK Slave Mon Port,[Moshe_Livne],[Moshe_Livne],,,,,,
+autocuesmi,3103,tcp,Autocue SMI Protocol,,,,,,,,
+autocuesmi,3103,udp,Autocue SMI Protocol,,,,,,,,
+autocuelog,3104,tcp,Autocue Logger Protocol,,,,,,,,
+autocuetime,3104,udp,Autocue Time Service,[Geoff_Back],[Geoff_Back],,,,,,
+cardbox,3105,tcp,Cardbox,,,,,,,,
+cardbox,3105,udp,Cardbox,,,,,,,,
+cardbox-http,3106,tcp,Cardbox HTTP,[Martin_Kochanski],[Martin_Kochanski],,,,,,
+cardbox-http,3106,udp,Cardbox HTTP,[Martin_Kochanski],[Martin_Kochanski],,,,,,
+business,3107,tcp,Business protocol,,,,,,,,
+business,3107,udp,Business protocol,,,,,,,,
+geolocate,3108,tcp,Geolocate protocol,,,,,,,,
+geolocate,3108,udp,Geolocate protocol,,,,,,,,
+personnel,3109,tcp,Personnel protocol,[William_Randolph_Roy],[William_Randolph_Roy],,,,,,
+personnel,3109,udp,Personnel protocol,[William_Randolph_Roy],[William_Randolph_Roy],,,,,,
+sim-control,3110,tcp,simulator control port,[Ian_Bell],[Ian_Bell],,,,,,
+sim-control,3110,udp,simulator control port,[Ian_Bell],[Ian_Bell],,,,,,
+wsynch,3111,tcp,Web Synchronous Services,[Valery_Fremaux],[Valery_Fremaux],,,,,,
+wsynch,3111,udp,Web Synchronous Services,[Valery_Fremaux],[Valery_Fremaux],,,,,,
+ksysguard,3112,tcp,KDE System Guard,[Chris_Schlaeger],[Chris_Schlaeger],,,,,,
+ksysguard,3112,udp,KDE System Guard,[Chris_Schlaeger],[Chris_Schlaeger],,,,,,
+cs-auth-svr,3113,tcp,CS-Authenticate Svr Port,[Cliff_Diamond][Andy_Georgiou],[Cliff_Diamond][Andy_Georgiou],,,,,,
+cs-auth-svr,3113,udp,CS-Authenticate Svr Port,[Cliff_Diamond][Andy_Georgiou],[Cliff_Diamond][Andy_Georgiou],,,,,,
+ccmad,3114,tcp,CCM AutoDiscover,[Ram_Sudama],[Ram_Sudama],,,,,,
+ccmad,3114,udp,CCM AutoDiscover,[Ram_Sudama],[Ram_Sudama],,,,,,
+mctet-master,3115,tcp,MCTET Master,,,,,,,,
+mctet-master,3115,udp,MCTET Master,,,,,,,,
+mctet-gateway,3116,tcp,MCTET Gateway,,,,,,,,
+mctet-gateway,3116,udp,MCTET Gateway,,,,,,,,
+mctet-jserv,3117,tcp,MCTET Jserv,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+mctet-jserv,3117,udp,MCTET Jserv,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+pkagent,3118,tcp,PKAgent,[Michael_Douglass],[Michael_Douglass],,,,,,
+pkagent,3118,udp,PKAgent,[Michael_Douglass],[Michael_Douglass],,,,,,
+d2000kernel,3119,tcp,D2000 Kernel Port,,,,,,,,
+d2000kernel,3119,udp,D2000 Kernel Port,,,,,,,,
+d2000webserver,3120,tcp,D2000 Webserver Port,[Tomas_Rajcan],[Tomas_Rajcan],,,,,,
+d2000webserver,3120,udp,D2000 Webserver Port,[Tomas_Rajcan],[Tomas_Rajcan],,,,,,
+pcmk-remote,3121,tcp,The pacemaker remote (pcmk-remote) service extends high availability functionality outside of the Linux cluster into remote nodes.,[David_Vossel],[Andrew_Beekhof],,2013-03-15,,,,"port 3121 previously noted ""Removed on 2003-09-17"""
+,3121,udp,Reserved,,,,2013-03-15,,,,"port 3121 previously noted ""Removed on 2003-09-17"""
+vtr-emulator,3122,tcp,MTI VTR Emulator port,[John_Mertus],[John_Mertus],,,,,,
+vtr-emulator,3122,udp,MTI VTR Emulator port,[John_Mertus],[John_Mertus],,,,,,
+edix,3123,tcp,EDI Translation Protocol,[William_Randolph_Roy],[William_Randolph_Roy],,,,,,
+edix,3123,udp,EDI Translation Protocol,[William_Randolph_Roy],[William_Randolph_Roy],,,,,,
+beacon-port,3124,tcp,Beacon Port,[James_Paul_Duncan],[James_Paul_Duncan],,,,,,
+beacon-port,3124,udp,Beacon Port,[James_Paul_Duncan],[James_Paul_Duncan],,,,,,
+a13-an,3125,tcp,A13-AN Interface,[Douglas_Knisely],[Douglas_Knisely],,,,,,
+a13-an,3125,udp,A13-AN Interface,[Douglas_Knisely],[Douglas_Knisely],,,,,,
+,3126,,Unassigned,,,,2007-10-04,,,,
+ctx-bridge,3127,tcp,CTX Bridge Port,[Alexander_Dubrovsky],[Alexander_Dubrovsky],,,,,,
+ctx-bridge,3127,udp,CTX Bridge Port,[Alexander_Dubrovsky],[Alexander_Dubrovsky],,,,,,
+ndl-aas,3128,tcp,Active API Server Port,[Martin_Norman],[Martin_Norman],,,,,,
+ndl-aas,3128,udp,Active API Server Port,[Martin_Norman],[Martin_Norman],,,,,,
+netport-id,3129,tcp,NetPort Discovery Port,[P_T_K_Farrar],[P_T_K_Farrar],,,,,,
+netport-id,3129,udp,NetPort Discovery Port,[P_T_K_Farrar],[P_T_K_Farrar],,,,,,
+icpv2,3130,tcp,ICPv2,[Duane_Wessels],[Duane_Wessels],,,,,,
+icpv2,3130,udp,ICPv2,[Duane_Wessels],[Duane_Wessels],,,,,,
+netbookmark,3131,tcp,Net Book Mark,[Yiftach_Ravid],[Yiftach_Ravid],,,,,Known Unauthorized Use on port 3131,
+netbookmark,3131,udp,Net Book Mark,[Yiftach_Ravid],[Yiftach_Ravid],,,,,Known Unauthorized Use on port 3131,
+ms-rule-engine,3132,tcp,Microsoft Business Rule Engine Update Service,[Anush_Kumar],[Anush_Kumar],,,,,,
+ms-rule-engine,3132,udp,Microsoft Business Rule Engine Update Service,[Anush_Kumar],[Anush_Kumar],,,,,,
+prism-deploy,3133,tcp,Prism Deploy User Port,[Joan_Linck],[Joan_Linck],,,,,,
+prism-deploy,3133,udp,Prism Deploy User Port,[Joan_Linck],[Joan_Linck],,,,,,
+ecp,3134,tcp,Extensible Code Protocol,[Jim_Trek][Mark_Bocko],[Jim_Trek][Mark_Bocko],,,,,,
+ecp,3134,udp,Extensible Code Protocol,[Jim_Trek][Mark_Bocko],[Jim_Trek][Mark_Bocko],,,,,,
+peerbook-port,3135,tcp,PeerBook Port,[John_Flowers],[John_Flowers],,,,,,
+peerbook-port,3135,udp,PeerBook Port,[John_Flowers],[John_Flowers],,,,,,
+grubd,3136,tcp,Grub Server Port,[Kord_Campbell],[Kord_Campbell],,,,,,
+grubd,3136,udp,Grub Server Port,[Kord_Campbell],[Kord_Campbell],,,,,,
+rtnt-1,3137,tcp,rtnt-1 data packets,,,,,,,,
+rtnt-1,3137,udp,rtnt-1 data packets,,,,,,,,
+rtnt-2,3138,tcp,rtnt-2 data packets,[Ron_Muellerschoen],[Ron_Muellerschoen],,,,,,
+rtnt-2,3138,udp,rtnt-2 data packets,[Ron_Muellerschoen],[Ron_Muellerschoen],,,,,,
+incognitorv,3139,tcp,Incognito Rendez-Vous,[Stephane_Bourque],[Stephane_Bourque],,,,,,
+incognitorv,3139,udp,Incognito Rendez-Vous,[Stephane_Bourque],[Stephane_Bourque],,,,,,
+ariliamulti,3140,tcp,Arilia Multiplexor,[Stephane_Bourque_2],[Stephane_Bourque_2],,,,,,
+ariliamulti,3140,udp,Arilia Multiplexor,[Stephane_Bourque_2],[Stephane_Bourque_2],,,,,,
+vmodem,3141,tcp,VMODEM,[Ray_Gwinn],[Ray_Gwinn],,,,,,
+vmodem,3141,udp,VMODEM,[Ray_Gwinn],[Ray_Gwinn],,,,,,
+rdc-wh-eos,3142,tcp,RDC WH EOS,[Udi_Nir],[Udi_Nir],,,,,,
+rdc-wh-eos,3142,udp,RDC WH EOS,[Udi_Nir],[Udi_Nir],,,,,,
+seaview,3143,tcp,Sea View,[Jim_Flaherty_2],[Jim_Flaherty_2],,,,,,
+seaview,3143,udp,Sea View,[Jim_Flaherty_2],[Jim_Flaherty_2],,,,,,
+tarantella,3144,tcp,Tarantella,[Roger_Binns],[Roger_Binns],,,,,,
+tarantella,3144,udp,Tarantella,[Roger_Binns],[Roger_Binns],,,,,,
+csi-lfap,3145,tcp,CSI-LFAP,[Paul_Amsden],[Paul_Amsden],,,,,Known UNAUTHORIZED USE: port 3145,
+csi-lfap,3145,udp,CSI-LFAP,[Paul_Amsden],[Paul_Amsden],,,,,Known UNAUTHORIZED USE: port 3145,
+bears-02,3146,tcp,bears-02,[Bruce_McKinnon_2],[Bruce_McKinnon_2],,,,,,
+bears-02,3146,udp,bears-02,[Bruce_McKinnon_2],[Bruce_McKinnon_2],,,,,,
+rfio,3147,tcp,RFIO,[Frederic_Hemmer],[Frederic_Hemmer],,,,,,
+rfio,3147,udp,RFIO,[Frederic_Hemmer],[Frederic_Hemmer],,,,,,
+nm-game-admin,3148,tcp,NetMike Game Administrator,,,,,,,,
+nm-game-admin,3148,udp,NetMike Game Administrator,,,,,,,,
+nm-game-server,3149,tcp,NetMike Game Server,,,,,,,,
+nm-game-server,3149,udp,NetMike Game Server,,,,,,,,
+nm-asses-admin,3150,tcp,NetMike Assessor Administrator,,,,,,,,
+nm-asses-admin,3150,udp,NetMike Assessor Administrator,,,,,,,,
+nm-assessor,3151,tcp,NetMike Assessor,[Andrew_Sharpe],[Andrew_Sharpe],,,,,,
+nm-assessor,3151,udp,NetMike Assessor,[Andrew_Sharpe],[Andrew_Sharpe],,,,,,
+feitianrockey,3152,tcp,FeiTian Port,[Huang_Yu],[Huang_Yu],,,,,,
+feitianrockey,3152,udp,FeiTian Port,[Huang_Yu],[Huang_Yu],,,,,,
+s8-client-port,3153,tcp,S8Cargo Client Port,[Jon_S_Kyle],[Jon_S_Kyle],,,,,,
+s8-client-port,3153,udp,S8Cargo Client Port,[Jon_S_Kyle],[Jon_S_Kyle],,,,,,
+ccmrmi,3154,tcp,ON RMI Registry,[Ram_Sudama],[Ram_Sudama],,,,,,
+ccmrmi,3154,udp,ON RMI Registry,[Ram_Sudama],[Ram_Sudama],,,,,,
+jpegmpeg,3155,tcp,JpegMpeg Port,[Richard_Bassous],[Richard_Bassous],,,,,,
+jpegmpeg,3155,udp,JpegMpeg Port,[Richard_Bassous],[Richard_Bassous],,,,,,
+indura,3156,tcp,Indura Collector,[Bruce_Kosbab],[Bruce_Kosbab],,,,,,
+indura,3156,udp,Indura Collector,[Bruce_Kosbab],[Bruce_Kosbab],,,,,,
+e3consultants,3157,tcp,CCC Listener Port,[Brian_Carnell],[Brian_Carnell],,,,,,
+e3consultants,3157,udp,CCC Listener Port,[Brian_Carnell],[Brian_Carnell],,,,,,
+stvp,3158,tcp,SmashTV Protocol,[Christian_Wolff],[Christian_Wolff],,,,,,
+stvp,3158,udp,SmashTV Protocol,[Christian_Wolff],[Christian_Wolff],,,,,,
+navegaweb-port,3159,tcp,NavegaWeb Tarification,[Miguel_Angel_Fernand],[Miguel_Angel_Fernand],,,,,,
+navegaweb-port,3159,udp,NavegaWeb Tarification,[Miguel_Angel_Fernand],[Miguel_Angel_Fernand],,,,,,
+tip-app-server,3160,tcp,TIP Application Server,[Olivier_Mascia],[Olivier_Mascia],,,,,,
+tip-app-server,3160,udp,TIP Application Server,[Olivier_Mascia],[Olivier_Mascia],,,,,,
+doc1lm,3161,tcp,DOC1 License Manager,[Greg_Goodson],[Greg_Goodson],,,,,,
+doc1lm,3161,udp,DOC1 License Manager,[Greg_Goodson],[Greg_Goodson],,,,,,
+sflm,3162,tcp,SFLM,[System_Administrator],[System_Administrator],,,,,,
+sflm,3162,udp,SFLM,[System_Administrator],[System_Administrator],,,,,,
+res-sap,3163,tcp,RES-SAP,[Bob_Janssen],[Bob_Janssen],,,,,,
+res-sap,3163,udp,RES-SAP,[Bob_Janssen],[Bob_Janssen],,,,,,
+imprs,3164,tcp,IMPRS,[Lars_Bohn],[Lars_Bohn],,,,,,
+imprs,3164,udp,IMPRS,[Lars_Bohn],[Lars_Bohn],,,,,,
+newgenpay,3165,tcp,Newgenpay Engine Service,[Ilan_Zisser],[Ilan_Zisser],,,,,,
+newgenpay,3165,udp,Newgenpay Engine Service,[Ilan_Zisser],[Ilan_Zisser],,,,,,
+sossecollector,3166,tcp,Quest Spotlight Out-Of-Process Collector,[Greg_Cottman],[Greg_Cottman],2008-10-23,,,,,
+sossecollector,3166,udp,Quest Spotlight Out-Of-Process Collector,[Greg_Cottman],[Greg_Cottman],2008-10-23,,,,,
+nowcontact,3167,tcp,Now Contact Public Server,,,,,,,,
+nowcontact,3167,udp,Now Contact Public Server,,,,,,,,
+poweronnud,3168,tcp,Now Up-to-Date Public Server,[John_Wallace],[John_Wallace],,,,,,
+poweronnud,3168,udp,Now Up-to-Date Public Server,[John_Wallace],[John_Wallace],,,,,,
+serverview-as,3169,tcp,SERVERVIEW-AS,,,,,,,,
+serverview-as,3169,udp,SERVERVIEW-AS,,,,,,,,
+serverview-asn,3170,tcp,SERVERVIEW-ASN,,,,,,,,
+serverview-asn,3170,udp,SERVERVIEW-ASN,,,,,,,,
+serverview-gf,3171,tcp,SERVERVIEW-GF,,,,,,,,
+serverview-gf,3171,udp,SERVERVIEW-GF,,,,,,,,
+serverview-rm,3172,tcp,SERVERVIEW-RM,,,,,,,,
+serverview-rm,3172,udp,SERVERVIEW-RM,,,,,,,,
+serverview-icc,3173,tcp,SERVERVIEW-ICC,[Detlef_Rothe],[Detlef_Rothe],2009-05-15,,,,,
+serverview-icc,3173,udp,SERVERVIEW-ICC,[Detlef_Rothe],[Detlef_Rothe],2009-05-15,,,,,
+armi-server,3174,tcp,ARMI Server,[Bobby_Martin],[Bobby_Martin],,,,,,
+armi-server,3174,udp,ARMI Server,[Bobby_Martin],[Bobby_Martin],,,,,,
+t1-e1-over-ip,3175,tcp,T1_E1_Over_IP,[Mark_Doyle],[Mark_Doyle],,,,,,
+t1-e1-over-ip,3175,udp,T1_E1_Over_IP,[Mark_Doyle],[Mark_Doyle],,,,,,
+ars-master,3176,tcp,ARS Master,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+ars-master,3176,udp,ARS Master,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+phonex-port,3177,tcp,Phonex Protocol,[Doug_Grover],[Doug_Grover],,,,,,
+phonex-port,3177,udp,Phonex Protocol,[Doug_Grover],[Doug_Grover],,,,,,
+radclientport,3178,tcp,Radiance UltraEdge Port,[Sri_Subramaniam],[Sri_Subramaniam],,,,,,
+radclientport,3178,udp,Radiance UltraEdge Port,[Sri_Subramaniam],[Sri_Subramaniam],,,,,,
+h2gf-w-2m,3179,tcp,H2GF W.2m Handover prot.,[Arne_Norefors],[Arne_Norefors],,,,,,
+h2gf-w-2m,3179,udp,H2GF W.2m Handover prot.,[Arne_Norefors],[Arne_Norefors],,,,,,
+mc-brk-srv,3180,tcp,Millicent Broker Server,[Steve_Glassman],[Steve_Glassman],,,,,,
+mc-brk-srv,3180,udp,Millicent Broker Server,[Steve_Glassman],[Steve_Glassman],,,,,,
+bmcpatrolagent,3181,tcp,BMC Patrol Agent,,,,,,,,
+bmcpatrolagent,3181,udp,BMC Patrol Agent,,,,,,,,
+bmcpatrolrnvu,3182,tcp,BMC Patrol Rendezvous,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmcpatrolrnvu,3182,udp,BMC Patrol Rendezvous,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+cops-tls,3183,tcp,COPS/TLS,[Mark_Stevens],[Mark_Stevens],,,,,,
+cops-tls,3183,udp,COPS/TLS,[Mark_Stevens],[Mark_Stevens],,,,,,
+apogeex-port,3184,tcp,ApogeeX Port,[Tom_Nys],[Tom_Nys],,,,,,
+apogeex-port,3184,udp,ApogeeX Port,[Tom_Nys],[Tom_Nys],,,,,,
+smpppd,3185,tcp,SuSE Meta PPPD,[Arvin_Schnell],[Arvin_Schnell],,,,,,
+smpppd,3185,udp,SuSE Meta PPPD,[Arvin_Schnell],[Arvin_Schnell],,,,,,
+iiw-port,3186,tcp,IIW Monitor User Port,[Corey_Burnett],[Corey_Burnett],,,,,,
+iiw-port,3186,udp,IIW Monitor User Port,[Corey_Burnett],[Corey_Burnett],,,,,,
+odi-port,3187,tcp,Open Design Listen Port,[Phivos_Aristides],[Phivos_Aristides],,,,,,
+odi-port,3187,udp,Open Design Listen Port,[Phivos_Aristides],[Phivos_Aristides],,,,,,
+brcm-comm-port,3188,tcp,Broadcom Port,[Thomas_L_Johnson],[Thomas_L_Johnson],,,,,,
+brcm-comm-port,3188,udp,Broadcom Port,[Thomas_L_Johnson],[Thomas_L_Johnson],,,,,,
+pcle-infex,3189,tcp,Pinnacle Sys InfEx Port,[Anthon_van_der_Neut],[Anthon_van_der_Neut],,,,,,
+pcle-infex,3189,udp,Pinnacle Sys InfEx Port,[Anthon_van_der_Neut],[Anthon_van_der_Neut],,,,,,
+csvr-proxy,3190,tcp,ConServR Proxy,,,,,,,,
+csvr-proxy,3190,udp,ConServR Proxy,,,,,,,,
+csvr-sslproxy,3191,tcp,ConServR SSL Proxy,[Mikhail_Kruk],[Mikhail_Kruk],,,,,,
+csvr-sslproxy,3191,udp,ConServR SSL Proxy,[Mikhail_Kruk],[Mikhail_Kruk],,,,,,
+firemonrcc,3192,tcp,FireMon Revision Control,[Michael_Bishop],[Michael_Bishop],,,,,,
+firemonrcc,3192,udp,FireMon Revision Control,[Michael_Bishop],[Michael_Bishop],,,,,,
+spandataport,3193,tcp,SpanDataPort,[Jesse_McKay],[Jesse_McKay],,,,,,
+spandataport,3193,udp,SpanDataPort,[Jesse_McKay],[Jesse_McKay],,,,,,
+magbind,3194,tcp,Rockstorm MAG protocol,[Jens_Nilsson],[Jens_Nilsson],,,,,,
+magbind,3194,udp,Rockstorm MAG protocol,[Jens_Nilsson],[Jens_Nilsson],,,,,,
+ncu-1,3195,tcp,Network Control Unit,,,,,,,,
+ncu-1,3195,udp,Network Control Unit,,,,,,,,
+ncu-2,3196,tcp,Network Control Unit,[Charlie_Hundre],[Charlie_Hundre],,,,,,
+ncu-2,3196,udp,Network Control Unit,[Charlie_Hundre],[Charlie_Hundre],,,,,,
+embrace-dp-s,3197,tcp,Embrace Device Protocol Server,,,,,,,,
+embrace-dp-s,3197,udp,Embrace Device Protocol Server,,,,,,,,
+embrace-dp-c,3198,tcp,Embrace Device Protocol Client,[Elliot_Schwartz],[Elliot_Schwartz],,,,,,
+embrace-dp-c,3198,udp,Embrace Device Protocol Client,[Elliot_Schwartz],[Elliot_Schwartz],,,,,,
+dmod-workspace,3199,tcp,DMOD WorkSpace,[Nick_Plante],[Nick_Plante],,,,,,
+dmod-workspace,3199,udp,DMOD WorkSpace,[Nick_Plante],[Nick_Plante],,,,,,
+tick-port,3200,tcp,Press-sense Tick Port,[Boris_Svetlitsky],[Boris_Svetlitsky],,,,,,
+tick-port,3200,udp,Press-sense Tick Port,[Boris_Svetlitsky],[Boris_Svetlitsky],,,,,,
+cpq-tasksmart,3201,tcp,CPQ-TaskSmart,[Jackie_Lau],[Jackie_Lau],,,,,,
+cpq-tasksmart,3201,udp,CPQ-TaskSmart,[Jackie_Lau],[Jackie_Lau],,,,,,
+intraintra,3202,tcp,IntraIntra,[Matthew_Asham],[Matthew_Asham],,,,,,
+intraintra,3202,udp,IntraIntra,[Matthew_Asham],[Matthew_Asham],,,,,,
+netwatcher-mon,3203,tcp,Network Watcher Monitor,,,,,,,,
+netwatcher-mon,3203,udp,Network Watcher Monitor,,,,,,,,
+netwatcher-db,3204,tcp,Network Watcher DB Access,[Hirokazu_Fujisawa],[Hirokazu_Fujisawa],,,,,,
+netwatcher-db,3204,udp,Network Watcher DB Access,[Hirokazu_Fujisawa],[Hirokazu_Fujisawa],,,,,,
+isns,3205,tcp,iSNS Server Port,,,,,[RFC4171],,,
+isns,3205,udp,iSNS Server Port,,,,,[RFC4171],,,
+ironmail,3206,tcp,IronMail POP Proxy,[Mike_Hudack],[Mike_Hudack],,,,,,
+ironmail,3206,udp,IronMail POP Proxy,[Mike_Hudack],[Mike_Hudack],,,,,,
+vx-auth-port,3207,tcp,Veritas Authentication Port,[Senthil_Ponnuswamy],[Senthil_Ponnuswamy],,,,,,
+vx-auth-port,3207,udp,Veritas Authentication Port,[Senthil_Ponnuswamy],[Senthil_Ponnuswamy],,,,,,
+pfu-prcallback,3208,tcp,PFU PR Callback,[Tetsuharu_Hanada],[Tetsuharu_Hanada],,,,,,
+pfu-prcallback,3208,udp,PFU PR Callback,[Tetsuharu_Hanada],[Tetsuharu_Hanada],,,,,,
+netwkpathengine,3209,tcp,HP OpenView Network Path Engine Server,[Anthony_Walker],[Anthony_Walker],,,,,,
+netwkpathengine,3209,udp,HP OpenView Network Path Engine Server,[Anthony_Walker],[Anthony_Walker],,,,,,
+flamenco-proxy,3210,tcp,Flamenco Networks Proxy,[Corey_Corrick],[Corey_Corrick],,,,,,
+flamenco-proxy,3210,udp,Flamenco Networks Proxy,[Corey_Corrick],[Corey_Corrick],,,,,,
+avsecuremgmt,3211,tcp,Avocent Secure Management,[Brian_S_Stewart],[Brian_S_Stewart],,,,,,
+avsecuremgmt,3211,udp,Avocent Secure Management,[Brian_S_Stewart],[Brian_S_Stewart],,,,,,
+surveyinst,3212,tcp,Survey Instrument,[Al_Amet],[Al_Amet],,,,,,
+surveyinst,3212,udp,Survey Instrument,[Al_Amet],[Al_Amet],,,,,,
+neon24x7,3213,tcp,NEON 24X7 Mission Control,[Tony_Lubrano],[Tony_Lubrano],,,,,,
+neon24x7,3213,udp,NEON 24X7 Mission Control,[Tony_Lubrano],[Tony_Lubrano],,,,,,
+jmq-daemon-1,3214,tcp,JMQ Daemon Port 1,,,,,,,,
+jmq-daemon-1,3214,udp,JMQ Daemon Port 1,,,,,,,,
+jmq-daemon-2,3215,tcp,JMQ Daemon Port 2,[Martin_West],[Martin_West],,,,,,
+jmq-daemon-2,3215,udp,JMQ Daemon Port 2,[Martin_West],[Martin_West],,,,,,
+ferrari-foam,3216,tcp,Ferrari electronic FOAM,[Johann_Deutinger],[Johann_Deutinger],,,,,,
+ferrari-foam,3216,udp,Ferrari electronic FOAM,[Johann_Deutinger],[Johann_Deutinger],,,,,,
+unite,3217,tcp,Unified IP & Telecom Environment,[Christer_Gunnarsson],[Christer_Gunnarsson],2009-03-26,,,,,
+unite,3217,udp,Unified IP & Telecom Environment,[Christer_Gunnarsson],[Christer_Gunnarsson],2009-03-26,,,,,
+smartpackets,3218,tcp,EMC SmartPackets,[Steve_Spataro],[Steve_Spataro],,,,,,
+smartpackets,3218,udp,EMC SmartPackets,[Steve_Spataro],[Steve_Spataro],,,,,,
+wms-messenger,3219,tcp,WMS Messenger,[Michael_Monasterio],[Michael_Monasterio],,,,,,
+wms-messenger,3219,udp,WMS Messenger,[Michael_Monasterio],[Michael_Monasterio],,,,,,
+xnm-ssl,3220,tcp,XML NM over SSL,,,,,,,,
+xnm-ssl,3220,udp,XML NM over SSL,,,,,,,,
+xnm-clear-text,3221,tcp,XML NM over TCP,[Mark_Trostler],[Mark_Trostler],,,,,,
+xnm-clear-text,3221,udp,XML NM over TCP,[Mark_Trostler],[Mark_Trostler],,,,,,
+glbp,3222,tcp,Gateway Load Balancing Pr,[Douglas_McLaggan],[Douglas_McLaggan],,,,,,
+glbp,3222,udp,Gateway Load Balancing Pr,[Douglas_McLaggan],[Douglas_McLaggan],,,,,,
+digivote,3223,tcp,DIGIVOTE (R) Vote-Server,[Christian_Treczoks],[Christian_Treczoks],,,,,,
+digivote,3223,udp,DIGIVOTE (R) Vote-Server,[Christian_Treczoks],[Christian_Treczoks],,,,,,
+aes-discovery,3224,tcp,AES Discovery Port,[Ken_Richard],[Ken_Richard],,,,,,
+aes-discovery,3224,udp,AES Discovery Port,[Ken_Richard],[Ken_Richard],,,,,,
+fcip-port,3225,tcp,FCIP,,,,,[RFC3821],,,
+fcip-port,3225,udp,FCIP,,,,,[RFC3821],,,
+isi-irp,3226,tcp,ISI Industry Software IRP,[Peter_Sandstrom],[Peter_Sandstrom],,,,,,
+isi-irp,3226,udp,ISI Industry Software IRP,[Peter_Sandstrom],[Peter_Sandstrom],,,,,,
+dwnmshttp,3227,tcp,DiamondWave NMS Server,,,,,,,,
+dwnmshttp,3227,udp,DiamondWave NMS Server,,,,,,,,
+dwmsgserver,3228,tcp,DiamondWave MSG Server,[Varma_Bhupatiraju],[Varma_Bhupatiraju],,,,,,
+dwmsgserver,3228,udp,DiamondWave MSG Server,[Varma_Bhupatiraju],[Varma_Bhupatiraju],,,,,,
+global-cd-port,3229,tcp,Global CD Port,[Vitaly_Revsin_2],[Vitaly_Revsin_2],,,,,,
+global-cd-port,3229,udp,Global CD Port,[Vitaly_Revsin_2],[Vitaly_Revsin_2],,,,,,
+sftdst-port,3230,tcp,Software Distributor Port,[Andrea_Lanza],[Andrea_Lanza],,2014-02-21,,,,
+sftdst-port,3230,udp,Software Distributor Port,[Andrea_Lanza],[Andrea_Lanza],,2014-02-21,,,,
+vidigo,3231,tcp,VidiGo communication (previous was: Delta Solutions Direct),[Peter_Ijkhout],[Peter_Ijkhout],,,,,,
+vidigo,3231,udp,VidiGo communication (previous was: Delta Solutions Direct),[Peter_Ijkhout],[Peter_Ijkhout],,,,,,
+mdtp,3232,tcp,MDT port,,,,2012-02-21,[RFC6513],,,
+mdtp,3232,udp,MDT port,,,,2012-02-21,[RFC6513],,,
+whisker,3233,tcp,WhiskerControl main port,[Rudolf_Cardinal],[Rudolf_Cardinal],2002-02,,,,,
+whisker,3233,udp,WhiskerControl main port,[Rudolf_Cardinal],[Rudolf_Cardinal],2002-02,,,,,
+alchemy,3234,tcp,Alchemy Server,[Mikhail_Belov],[Mikhail_Belov],2002-02,,,,,
+alchemy,3234,udp,Alchemy Server,[Mikhail_Belov],[Mikhail_Belov],2002-02,,,,,
+mdap-port,3235,tcp,MDAP port,[Johan_Deleu],[Johan_Deleu],2002-02,,,,,
+mdap-port,3235,udp,MDAP Port,[Johan_Deleu],[Johan_Deleu],2002-02,,,,,
+apparenet-ts,3236,tcp,appareNet Test Server,,,,,,,,
+apparenet-ts,3236,udp,appareNet Test Server,,,,,,,,
+apparenet-tps,3237,tcp,appareNet Test Packet Sequencer,,,,,,,,
+apparenet-tps,3237,udp,appareNet Test Packet Sequencer,,,,,,,,
+apparenet-as,3238,tcp,appareNet Analysis Server,,,,,,,,
+apparenet-as,3238,udp,appareNet Analysis Server,,,,,,,,
+apparenet-ui,3239,tcp,appareNet User Interface,[Fred_Klassen],[Fred_Klassen],2002-02,,,,,
+apparenet-ui,3239,udp,appareNet User Interface,[Fred_Klassen],[Fred_Klassen],2002-02,,,,,
+triomotion,3240,tcp,Trio Motion Control Port,[Tony_Matthews],[Tony_Matthews],2002-02,,,,,
+triomotion,3240,udp,Trio Motion Control Port,[Tony_Matthews],[Tony_Matthews],2002-02,,,,,
+sysorb,3241,tcp,SysOrb Monitoring Server,[Jakob_Oestergaard],[Jakob_Oestergaard],2002-02,,,,,
+sysorb,3241,udp,SysOrb Monitoring Server,[Jakob_Oestergaard],[Jakob_Oestergaard],2002-02,,,,,
+sdp-id-port,3242,tcp,Session Description ID,[Greg_Rose_2],[Greg_Rose_2],2002-02,,,,,
+sdp-id-port,3242,udp,Session Description ID,[Greg_Rose_2],[Greg_Rose_2],2002-02,,,,,
+timelot,3243,tcp,Timelot Port,[David_Ferguson],[David_Ferguson],2002-02,,,,,
+timelot,3243,udp,Timelot Port,[David_Ferguson],[David_Ferguson],2002-02,,,,,
+onesaf,3244,tcp,OneSAF,[Gene_McCulley],[Gene_McCulley],2002-02,,,,,
+onesaf,3244,udp,OneSAF,[Gene_McCulley],[Gene_McCulley],2002-02,,,,,
+vieo-fe,3245,tcp,VIEO Fabric Executive,[James_Cox],[James_Cox],2002-02,,,,,
+vieo-fe,3245,udp,VIEO Fabric Executive,[James_Cox],[James_Cox],2002-02,,,,,
+dvt-system,3246,tcp,DVT SYSTEM PORT,,,,,,,,
+dvt-system,3246,udp,DVT SYSTEM PORT,,,,,,,,
+dvt-data,3247,tcp,DVT DATA LINK,[Phillip_Heil],[Phillip_Heil],2002-02,,,,,
+dvt-data,3247,udp,DVT DATA LINK,[Phillip_Heil],[Phillip_Heil],2002-02,,,,,
+procos-lm,3248,tcp,PROCOS LM,[Torsten_Rendelmann],[Torsten_Rendelmann],,,,,,
+procos-lm,3248,udp,PROCOS LM,[Torsten_Rendelmann],[Torsten_Rendelmann],,,,,,
+ssp,3249,tcp,State Sync Protocol,[Stephane_Beaulieu],[Stephane_Beaulieu],2002-02,,,,,
+ssp,3249,udp,State Sync Protocol,[Stephane_Beaulieu],[Stephane_Beaulieu],2002-02,,,,,
+hicp,3250,tcp,HMS hicp port,[Joel_Palsson],[Joel_Palsson],2002-02,,,,,
+hicp,3250,udp,HMS hicp port,[Joel_Palsson],[Joel_Palsson],2002-02,,,,,
+sysscanner,3251,tcp,Sys Scanner,[Dick_Georges],[Dick_Georges],2002-02,,,,,
+sysscanner,3251,udp,Sys Scanner,[Dick_Georges],[Dick_Georges],2002-02,,,,,
+dhe,3252,tcp,DHE port,[Fabrizio_Massimo_Fer],[Fabrizio_Massimo_Fer],2002-02,,,,,
+dhe,3252,udp,DHE port,[Fabrizio_Massimo_Fer],[Fabrizio_Massimo_Fer],2002-02,,,,,
+pda-data,3253,tcp,PDA Data,,,,,,,,
+pda-data,3253,udp,PDA Data,,,,,,,,
+pda-sys,3254,tcp,PDA System,[Jian_Fan],[Jian_Fan],2002-02,,,,,
+pda-sys,3254,udp,PDA System,[Jian_Fan],[Jian_Fan],2002-02,,,,,
+semaphore,3255,tcp,Semaphore Connection Port,[Jay_Eckles],[Jay_Eckles],2002-02,,,,,
+semaphore,3255,udp,Semaphore Connection Port,[Jay_Eckles],[Jay_Eckles],2002-02,,,,,
+cpqrpm-agent,3256,tcp,Compaq RPM Agent Port,,,,,,,,
+cpqrpm-agent,3256,udp,Compaq RPM Agent Port,,,,,,,,
+cpqrpm-server,3257,tcp,Compaq RPM Server Port,[Royal_King],[Royal_King],2002-02,,,,,
+cpqrpm-server,3257,udp,Compaq RPM Server Port,[Royal_King],[Royal_King],2002-02,,,,,
+ivecon-port,3258,tcp,Ivecon Server Port,[Serguei_Tevs],[Serguei_Tevs],2002-02,,,,,
+ivecon-port,3258,udp,Ivecon Server Port,[Serguei_Tevs],[Serguei_Tevs],2002-02,,,,,
+epncdp2,3259,tcp,Epson Network Common Devi,[Oishi_Toshiaki],[Oishi_Toshiaki],2002-02,,,,,
+epncdp2,3259,udp,Epson Network Common Devi,[Oishi_Toshiaki],[Oishi_Toshiaki],2002-02,,,,,
+iscsi-target,3260,tcp,iSCSI port,[IESG],[IETF_Chair],,2013-08-27,[RFC7143],,,
+iscsi-target,3260,udp,iSCSI port,[IESG],[IETF_Chair],,2013-08-27,[RFC7143],,,
+winshadow,3261,tcp,winShadow,[Colin_Barry],[Colin_Barry],,,,,,
+winshadow,3261,udp,winShadow,[Colin_Barry],[Colin_Barry],,,,,,
+necp,3262,tcp,NECP,[Alberto_Cerpa],[Alberto_Cerpa],,,,,,
+necp,3262,udp,NECP,[Alberto_Cerpa],[Alberto_Cerpa],,,,,,
+ecolor-imager,3263,tcp,E-Color Enterprise Imager,[Tamara_Baker],[Tamara_Baker],,,,,,
+ecolor-imager,3263,udp,E-Color Enterprise Imager,[Tamara_Baker],[Tamara_Baker],,,,,,
+ccmail,3264,tcp,cc:mail/lotus,[brockman],[brockman],,,,,,
+ccmail,3264,udp,cc:mail/lotus,[brockman],[brockman],,,,,,
+altav-tunnel,3265,tcp,Altav Tunnel,[Gary_M_Allen],[Gary_M_Allen],,,,,,
+altav-tunnel,3265,udp,Altav Tunnel,[Gary_M_Allen],[Gary_M_Allen],,,,,,
+ns-cfg-server,3266,tcp,NS CFG Server,[Aivi_Lie],[Aivi_Lie],,,,,,
+ns-cfg-server,3266,udp,NS CFG Server,[Aivi_Lie],[Aivi_Lie],,,,,,
+ibm-dial-out,3267,tcp,IBM Dial Out,[Skip_Booth],[Skip_Booth],,,,,,
+ibm-dial-out,3267,udp,IBM Dial Out,[Skip_Booth],[Skip_Booth],,,,,,
+msft-gc,3268,tcp,Microsoft Global Catalog,,,,,,,,
+msft-gc,3268,udp,Microsoft Global Catalog,,,,,,,,
+msft-gc-ssl,3269,tcp,Microsoft Global Catalog with LDAP/SSL,[Asaf_Kashi],[Asaf_Kashi],,,,,,
+msft-gc-ssl,3269,udp,Microsoft Global Catalog with LDAP/SSL,[Asaf_Kashi],[Asaf_Kashi],,,,,,
+verismart,3270,tcp,Verismart,[Jay_Weber],[Jay_Weber],,,,,,
+verismart,3270,udp,Verismart,[Jay_Weber],[Jay_Weber],,,,,,
+csoft-prev,3271,tcp,CSoft Prev Port,[Nedelcho_Stanev_3],[Nedelcho_Stanev_3],,,,,,
+csoft-prev,3271,udp,CSoft Prev Port,[Nedelcho_Stanev_3],[Nedelcho_Stanev_3],,,,,,
+user-manager,3272,tcp,Fujitsu User Manager,[Yukihiko_Sakurai],[Yukihiko_Sakurai],,,,,,
+user-manager,3272,udp,Fujitsu User Manager,[Yukihiko_Sakurai],[Yukihiko_Sakurai],,,,,,
+sxmp,3273,tcp,Simple Extensible Multiplexed Protocol,[admin],[admin],,,,,,
+sxmp,3273,udp,Simple Extensible Multiplexed Protocol,[admin],[admin],,,,,,
+ordinox-server,3274,tcp,Ordinox Server,[Denis_Ducharme],[Denis_Ducharme],,,,,,
+ordinox-server,3274,udp,Ordinox Server,[Denis_Ducharme],[Denis_Ducharme],,,,,,
+samd,3275,tcp,SAMD,[Edgar_Circenis],[Edgar_Circenis],,,,,,
+samd,3275,udp,SAMD,[Edgar_Circenis],[Edgar_Circenis],,,,,,
+maxim-asics,3276,tcp,Maxim ASICs,[Dave_Inman],[Dave_Inman],,,,,,
+maxim-asics,3276,udp,Maxim ASICs,[Dave_Inman],[Dave_Inman],,,,,,
+awg-proxy,3277,tcp,AWG Proxy,[Alex_McDonald],[Alex_McDonald],,,,,,
+awg-proxy,3277,udp,AWG Proxy,[Alex_McDonald],[Alex_McDonald],,,,,,
+lkcmserver,3278,tcp,LKCM Server,[Javier_Jimenez],[Javier_Jimenez],,,,,,
+lkcmserver,3278,udp,LKCM Server,[Javier_Jimenez],[Javier_Jimenez],,,,,,
+admind,3279,tcp,admind,[Jeff_Haynes],[Jeff_Haynes],,,,,,
+admind,3279,udp,admind,[Jeff_Haynes],[Jeff_Haynes],,,,,,
+vs-server,3280,tcp,VS Server,[Scott_Godlew],[Scott_Godlew],,,,,,
+vs-server,3280,udp,VS Server,[Scott_Godlew],[Scott_Godlew],,,,,,
+sysopt,3281,tcp,SYSOPT,[Tony_Hoffman],[Tony_Hoffman],,,,,,
+sysopt,3281,udp,SYSOPT,[Tony_Hoffman],[Tony_Hoffman],,,,,,
+datusorb,3282,tcp,Datusorb,[Thomas_Martin],[Thomas_Martin],,,,,,
+datusorb,3282,udp,Datusorb,[Thomas_Martin],[Thomas_Martin],,,,,,
+Apple Remote Desktop (Net Assistant),3283,tcp,Net Assistant,[Michael_Stein],[Michael_Stein],,2011-11-09,,,,
+Apple Remote Desktop (Net Assistant),3283,udp,Net Assistant,[Michael_Stein],[Michael_Stein],,2011-11-09,,,,
+4talk,3284,tcp,4Talk,[Tony_Bushnell],[Tony_Bushnell],,,,,,
+4talk,3284,udp,4Talk,[Tony_Bushnell],[Tony_Bushnell],,,,,,
+plato,3285,tcp,Plato,[Jim_Battin],[Jim_Battin],,,,,,
+plato,3285,udp,Plato,[Jim_Battin],[Jim_Battin],,,,,,
+e-net,3286,tcp,E-Net,[Steven_Grigsby],[Steven_Grigsby],,,,,,
+e-net,3286,udp,E-Net,[Steven_Grigsby],[Steven_Grigsby],,,,,,
+directvdata,3287,tcp,DIRECTVDATA,[Michael_Friedman],[Michael_Friedman],,,,,,
+directvdata,3287,udp,DIRECTVDATA,[Michael_Friedman],[Michael_Friedman],,,,,,
+cops,3288,tcp,COPS,[Shai_Herzog],[Shai_Herzog],,,,,,
+cops,3288,udp,COPS,[Shai_Herzog],[Shai_Herzog],,,,,,
+enpc,3289,tcp,ENPC,[SEIKO_EPSON_2],[SEIKO_EPSON_2],,,,,,
+enpc,3289,udp,ENPC,[SEIKO_EPSON_2],[SEIKO_EPSON_2],,,,,,
+caps-lm,3290,tcp,CAPS LOGISTICS TOOLKIT - LM,[Joseph_Krebs],[Joseph_Krebs],,,,,,
+caps-lm,3290,udp,CAPS LOGISTICS TOOLKIT - LM,[Joseph_Krebs],[Joseph_Krebs],,,,,,
+sah-lm,3291,tcp,S A Holditch & Associates - LM,[Randy_Hudgens],[Randy_Hudgens],,,,,,
+sah-lm,3291,udp,S A Holditch & Associates - LM,[Randy_Hudgens],[Randy_Hudgens],,,,,,
+cart-o-rama,3292,tcp,Cart O Rama,[Phillip_Dillinger],[Phillip_Dillinger],,,,,,
+cart-o-rama,3292,udp,Cart O Rama,[Phillip_Dillinger],[Phillip_Dillinger],,,,,,
+fg-fps,3293,tcp,fg-fps,,,,,,,,
+fg-fps,3293,udp,fg-fps,,,,,,,,
+fg-gip,3294,tcp,fg-gip,[Jean_Marc_Frailong],[Jean_Marc_Frailong],,,,,,
+fg-gip,3294,udp,fg-gip,[Jean_Marc_Frailong],[Jean_Marc_Frailong],,,,,,
+dyniplookup,3295,tcp,Dynamic IP Lookup,[Eugene_Osovetsky],[Eugene_Osovetsky],,,,,,
+dyniplookup,3295,udp,Dynamic IP Lookup,[Eugene_Osovetsky],[Eugene_Osovetsky],,,,,,
+rib-slm,3296,tcp,Rib License Manager,[Kristean_Heisler],[Kristean_Heisler],,,,,,
+rib-slm,3296,udp,Rib License Manager,[Kristean_Heisler],[Kristean_Heisler],,,,,,
+cytel-lm,3297,tcp,Cytel License Manager,[Yogesh_P_Gajjar],[Yogesh_P_Gajjar],,,,,,
+cytel-lm,3297,udp,Cytel License Manager,[Yogesh_P_Gajjar],[Yogesh_P_Gajjar],,,,,,
+deskview,3298,tcp,DeskView,[Manfred_Randelzofer],[Manfred_Randelzofer],,,,,,
+deskview,3298,udp,DeskView,[Manfred_Randelzofer],[Manfred_Randelzofer],,,,,,
+pdrncs,3299,tcp,pdrncs,[Paul_Wissenbach],[Paul_Wissenbach],,,,,,
+pdrncs,3299,udp,pdrncs,[Paul_Wissenbach],[Paul_Wissenbach],,,,,,
+,3300-3301,,unassigned,,,,,,,Knwon Unauthorized Use on 3300-3301,
+mcs-fastmail,3302,tcp,MCS Fastmail,[Patti_Jo_Newsom],[Patti_Jo_Newsom],,,,,,
+mcs-fastmail,3302,udp,MCS Fastmail,[Patti_Jo_Newsom],[Patti_Jo_Newsom],,,,,,
+opsession-clnt,3303,tcp,OP Session Client,,,,,,,,
+opsession-clnt,3303,udp,OP Session Client,,,,,,,,
+opsession-srvr,3304,tcp,OP Session Server,[Amir_Blich],[Amir_Blich],,,,,,
+opsession-srvr,3304,udp,OP Session Server,[Amir_Blich],[Amir_Blich],,,,,,
+odette-ftp,3305,tcp,ODETTE-FTP,[David_Nash],[David_Nash],,,[RFC5024],,,
+odette-ftp,3305,udp,ODETTE-FTP,[David_Nash],[David_Nash],,,[RFC5024],,,
+mysql,3306,tcp,MySQL,[Monty],[Monty],,,,,,
+mysql,3306,udp,MySQL,[Monty],[Monty],,,,,,
+opsession-prxy,3307,tcp,OP Session Proxy,[Amir_Blich],[Amir_Blich],,,,,,
+opsession-prxy,3307,udp,OP Session Proxy,[Amir_Blich],[Amir_Blich],,,,,,
+tns-server,3308,tcp,TNS Server,,,,,,,,
+tns-server,3308,udp,TNS Server,,,,,,,,
+tns-adv,3309,tcp,TNS ADV,[Jerome_Albin],[Jerome_Albin],,,,,,
+tns-adv,3309,udp,TNS ADV,[Jerome_Albin],[Jerome_Albin],,,,,,
+dyna-access,3310,tcp,Dyna Access,[Dave_Belliveau],[Dave_Belliveau],,,,,,
+dyna-access,3310,udp,Dyna Access,[Dave_Belliveau],[Dave_Belliveau],,,,,,
+mcns-tel-ret,3311,tcp,MCNS Tel Ret,[Randall_Atkinson],[Randall_Atkinson],,,,,,
+mcns-tel-ret,3311,udp,MCNS Tel Ret,[Randall_Atkinson],[Randall_Atkinson],,,,,,
+appman-server,3312,tcp,Application Management Server,,,,,,,,
+appman-server,3312,udp,Application Management Server,,,,,,,,
+uorb,3313,tcp,Unify Object Broker,[Daegis_Inc],[Chris_Anderson],,2012-07-31,,,,
+uorb,3313,udp,Unify Object Broker,[Daegis_Inc],[Chris_Anderson],,2012-07-31,,,,
+uohost,3314,tcp,Unify Object Host,[Daegis_Inc],[Chris_Anderson],,2012-07-31,,,,
+uohost,3314,udp,Unify Object Host,[Daegis_Inc],[Chris_Anderson],,2012-07-31,,,,
+cdid,3315,tcp,CDID,[Andrew_Borisov],[Andrew_Borisov],,,,,,
+cdid,3315,udp,CDID,[Andrew_Borisov],[Andrew_Borisov],,,,,,
+aicc-cmi,3316,tcp,AICC/CMI,[William_McDonald],[William_McDonald],,,,,,
+aicc-cmi,3316,udp,AICC/CMI,[William_McDonald],[William_McDonald],,,,,,
+vsaiport,3317,tcp,VSAI PORT,[Rieko_Asai],[Rieko_Asai],,,,,,
+vsaiport,3317,udp,VSAI PORT,[Rieko_Asai],[Rieko_Asai],,,,,,
+ssrip,3318,tcp,Swith to Swith Routing Information Protocol,[Baba_Hidekazu],[Baba_Hidekazu],,,,,,
+ssrip,3318,udp,Swith to Swith Routing Information Protocol,[Baba_Hidekazu],[Baba_Hidekazu],,,,,,
+sdt-lmd,3319,tcp,SDT License Manager,[Salvo_Nassisi],[Salvo_Nassisi],,,,,,
+sdt-lmd,3319,udp,SDT License Manager,[Salvo_Nassisi],[Salvo_Nassisi],,,,,,
+officelink2000,3320,tcp,Office Link 2000,[Mike_Balch],[Mike_Balch],,,,,,
+officelink2000,3320,udp,Office Link 2000,[Mike_Balch],[Mike_Balch],,,,,,
+vnsstr,3321,tcp,VNSSTR,[Takeshi_Ohmura],[Takeshi_Ohmura],,,,,,
+vnsstr,3321,udp,VNSSTR,[Takeshi_Ohmura],[Takeshi_Ohmura],,,,,,
+active-net,3322-3325,,Active Networks,[Bob_Braden_2],[Bob_Braden_2],,,,,,
+sftu,3326,tcp,SFTU,[Eduardo_Rosenberg_de],[Eduardo_Rosenberg_de],,,,,,
+sftu,3326,udp,SFTU,[Eduardo_Rosenberg_de],[Eduardo_Rosenberg_de],,,,,,
+bbars,3327,tcp,BBARS,[Lou_Harris],[Lou_Harris],,,,,,
+bbars,3327,udp,BBARS,[Lou_Harris],[Lou_Harris],,,,,,
+egptlm,3328,tcp,Eaglepoint License Manager,[Dave_Benton],[Dave_Benton],,,,,,
+egptlm,3328,udp,Eaglepoint License Manager,[Dave_Benton],[Dave_Benton],,,,,,
+hp-device-disc,3329,tcp,HP Device Disc,[Shivaun_Albright],[Shivaun_Albright],,,,,,
+hp-device-disc,3329,udp,HP Device Disc,[Shivaun_Albright],[Shivaun_Albright],,,,,,
+mcs-calypsoicf,3330,tcp,MCS Calypso ICF,,,,,,,,
+mcs-calypsoicf,3330,udp,MCS Calypso ICF,,,,,,,,
+mcs-messaging,3331,tcp,MCS Messaging,,,,,,,,
+mcs-messaging,3331,udp,MCS Messaging,,,,,,,,
+mcs-mailsvr,3332,tcp,MCS Mail Server,[Patti_Jo_Newsom],[Patti_Jo_Newsom],,,,,,
+mcs-mailsvr,3332,udp,MCS Mail Server,[Patti_Jo_Newsom],[Patti_Jo_Newsom],,,,,,
+dec-notes,3333,tcp,DEC Notes,[Kim_Moraros],[Kim_Moraros],,,,,,
+dec-notes,3333,udp,DEC Notes,[Kim_Moraros],[Kim_Moraros],,,,,,
+directv-web,3334,tcp,Direct TV Webcasting,,,,,,,,
+directv-web,3334,udp,Direct TV Webcasting,,,,,,,,
+directv-soft,3335,tcp,Direct TV Software Updates,,,,,,,,
+directv-soft,3335,udp,Direct TV Software Updates,,,,,,,,
+directv-tick,3336,tcp,Direct TV Tickers,,,,,,,,
+directv-tick,3336,udp,Direct TV Tickers,,,,,,,,
+directv-catlg,3337,tcp,Direct TV Data Catalog,[Michael_Friedman],[Michael_Friedman],,,,,,
+directv-catlg,3337,udp,Direct TV Data Catalog,[Michael_Friedman],[Michael_Friedman],,,,,,
+anet-b,3338,tcp,OMF data b,,,,,,,,
+anet-b,3338,udp,OMF data b,,,,,,,,
+anet-l,3339,tcp,OMF data l,,,,,,,,
+anet-l,3339,udp,OMF data l,,,,,,,,
+anet-m,3340,tcp,OMF data m,,,,,,,,
+anet-m,3340,udp,OMF data m,,,,,,,,
+anet-h,3341,tcp,OMF data h,[Per_Sahlqvist],[Per_Sahlqvist],,,,,,
+anet-h,3341,udp,OMF data h,[Per_Sahlqvist],[Per_Sahlqvist],,,,,,
+webtie,3342,tcp,WebTIE,[Kevin_Frender],[Kevin_Frender],,,,,,
+webtie,3342,udp,WebTIE,[Kevin_Frender],[Kevin_Frender],,,,,,
+ms-cluster-net,3343,tcp,MS Cluster Net,[David_Dion],[David_Dion],2009-02-12,,,,,
+ms-cluster-net,3343,udp,MS Cluster Net,[David_Dion],[David_Dion],2009-02-12,,,,,
+bnt-manager,3344,tcp,BNT Manager,[Engineering_Dept],[Engineering_Dept],,,,,,
+bnt-manager,3344,udp,BNT Manager,[Engineering_Dept],[Engineering_Dept],,,,,,
+influence,3345,tcp,Influence,[Russ_Ferriday],[Russ_Ferriday],,,,,,
+influence,3345,udp,Influence,[Russ_Ferriday],[Russ_Ferriday],,,,,,
+trnsprntproxy,3346,tcp,Trnsprnt Proxy,[Grant_Kirby],[Grant_Kirby],,,,,,
+trnsprntproxy,3346,udp,Trnsprnt Proxy,[Grant_Kirby],[Grant_Kirby],,,,,,
+phoenix-rpc,3347,tcp,Phoenix RPC,[Ian_Anderson],[Ian_Anderson],,,,,,
+phoenix-rpc,3347,udp,Phoenix RPC,[Ian_Anderson],[Ian_Anderson],,,,,,
+pangolin-laser,3348,tcp,Pangolin Laser,[William_Benner],[William_Benner],,,,,,
+pangolin-laser,3348,udp,Pangolin Laser,[William_Benner],[William_Benner],,,,,,
+chevinservices,3349,tcp,Chevin Services,[Gus_McNaughton],[Gus_McNaughton],,,,,,
+chevinservices,3349,udp,Chevin Services,[Gus_McNaughton],[Gus_McNaughton],,,,,,
+findviatv,3350,tcp,FINDVIATV,[Oran_Davis],[Oran_Davis],,,,,,
+findviatv,3350,udp,FINDVIATV,[Oran_Davis],[Oran_Davis],,,,,,
+btrieve,3351,tcp,Btrieve port,,,,,,,,
+btrieve,3351,udp,Btrieve port,,,,,,,,
+ssql,3352,tcp,Scalable SQL,[Chuck_Talk],[Chuck_Talk],,,,,,
+ssql,3352,udp,Scalable SQL,[Chuck_Talk],[Chuck_Talk],,,,,,
+fatpipe,3353,tcp,FATPIPE,[Sanchaita_Datta],[Sanchaita_Datta],,,,,,
+fatpipe,3353,udp,FATPIPE,[Sanchaita_Datta],[Sanchaita_Datta],,,,,,
+suitjd,3354,tcp,SUITJD,[Todd_Moyer],[Todd_Moyer],,,,,,
+suitjd,3354,udp,SUITJD,[Todd_Moyer],[Todd_Moyer],,,,,,
+ordinox-dbase,3355,tcp,Ordinox Dbase,[Denis_Ducharme],[Denis_Ducharme],,,,,,
+ordinox-dbase,3355,udp,Ordinox Dbase,[Denis_Ducharme],[Denis_Ducharme],,,,,,
+upnotifyps,3356,tcp,UPNOTIFYPS,[Mark_Fox],[Mark_Fox],,,,,,
+upnotifyps,3356,udp,UPNOTIFYPS,[Mark_Fox],[Mark_Fox],,,,,,
+adtech-test,3357,tcp,Adtech Test IP,[Robin_Uyeshiro],[Robin_Uyeshiro],,,,,,
+adtech-test,3357,udp,Adtech Test IP,[Robin_Uyeshiro],[Robin_Uyeshiro],,,,,,
+mpsysrmsvr,3358,tcp,Mp Sys Rmsvr,[Hiroyuki_Kawabuchi],[Hiroyuki_Kawabuchi],,,,,,
+mpsysrmsvr,3358,udp,Mp Sys Rmsvr,[Hiroyuki_Kawabuchi],[Hiroyuki_Kawabuchi],,,,,,
+wg-netforce,3359,tcp,WG NetForce,[Lee_Wheat],[Lee_Wheat],,,,,,
+wg-netforce,3359,udp,WG NetForce,[Lee_Wheat],[Lee_Wheat],,,,,,
+kv-server,3360,tcp,KV Server,,,,,,,,
+kv-server,3360,udp,KV Server,,,,,,,,
+kv-agent,3361,tcp,KV Agent,[Thomas_Soranno],[Thomas_Soranno],,,,,,
+kv-agent,3361,udp,KV Agent,[Thomas_Soranno],[Thomas_Soranno],,,,,,
+dj-ilm,3362,tcp,DJ ILM,[Don_Tyson],[Don_Tyson],,,,,,
+dj-ilm,3362,udp,DJ ILM,[Don_Tyson],[Don_Tyson],,,,,,
+nati-vi-server,3363,tcp,NATI Vi Server,[Robert_Dye],[Robert_Dye],,,,,,
+nati-vi-server,3363,udp,NATI Vi Server,[Robert_Dye],[Robert_Dye],,,,,,
+creativeserver,3364,tcp,Creative Server,,,,,,,,
+creativeserver,3364,udp,Creative Server,,,,,,,,
+contentserver,3365,tcp,Content Server,,,,,,,,
+contentserver,3365,udp,Content Server,,,,,,,,
+creativepartnr,3366,tcp,Creative Partner,[Jesus_Ortiz_2],[Jesus_Ortiz_2],,,,,,
+creativepartnr,3366,udp,Creative Partner,[Jesus_Ortiz_2],[Jesus_Ortiz_2],,,,,,
+satvid-datalnk,3367-3371,,Satellite Video Data Link,[Scott_Engel],[Scott_Engel],,,,,,
+tip2,3372,tcp,TIP 2,[Keith_Evans],[Keith_Evans],,,,,,
+tip2,3372,udp,TIP 2,[Keith_Evans],[Keith_Evans],,,,,,
+lavenir-lm,3373,tcp,Lavenir License Manager,[Marius_Matioc],[Marius_Matioc],,,,,,
+lavenir-lm,3373,udp,Lavenir License Manager,[Marius_Matioc],[Marius_Matioc],,,,,,
+cluster-disc,3374,tcp,Cluster Disc,[Jeff_Hughes],[Jeff_Hughes],,,,,,
+cluster-disc,3374,udp,Cluster Disc,[Jeff_Hughes],[Jeff_Hughes],,,,,,
+vsnm-agent,3375,tcp,VSNM Agent,[Venkat_Rangan],[Venkat_Rangan],,,,,,
+vsnm-agent,3375,udp,VSNM Agent,[Venkat_Rangan],[Venkat_Rangan],,,,,,
+cdbroker,3376,tcp,CD Broker,[Moon_Ho_Chung],[Moon_Ho_Chung],,,,,,
+cdbroker,3376,udp,CD Broker,[Moon_Ho_Chung],[Moon_Ho_Chung],,,,,,
+cogsys-lm,3377,tcp,Cogsys Network License Manager,[Simon_Chinnick],[Simon_Chinnick],,,,,,
+cogsys-lm,3377,udp,Cogsys Network License Manager,[Simon_Chinnick],[Simon_Chinnick],,,,,,
+wsicopy,3378,tcp,WSICOPY,[James_Overby],[James_Overby],,,,,,
+wsicopy,3378,udp,WSICOPY,[James_Overby],[James_Overby],,,,,,
+socorfs,3379,tcp,SOCORFS,[Hugo_Charbonneau],[Hugo_Charbonneau],,,,,,
+socorfs,3379,udp,SOCORFS,[Hugo_Charbonneau],[Hugo_Charbonneau],,,,,,
+sns-channels,3380,tcp,SNS Channels,[Shekar_Pasumarthi],[Shekar_Pasumarthi],,,,,,
+sns-channels,3380,udp,SNS Channels,[Shekar_Pasumarthi],[Shekar_Pasumarthi],,,,,,
+geneous,3381,tcp,Geneous,[Nick_de_Smith],[Nick_de_Smith],,,,,,
+geneous,3381,udp,Geneous,[Nick_de_Smith],[Nick_de_Smith],,,,,,
+fujitsu-neat,3382,tcp,Fujitsu Network Enhanced Antitheft function,[Markku_Viima],[Markku_Viima],,,,,,
+fujitsu-neat,3382,udp,Fujitsu Network Enhanced Antitheft function,[Markku_Viima],[Markku_Viima],,,,,,
+esp-lm,3383,tcp,Enterprise Software Products License Manager,[George_Rudy],[George_Rudy],,,,,,
+esp-lm,3383,udp,Enterprise Software Products License Manager,[George_Rudy],[George_Rudy],,,,,,
+hp-clic,3384,tcp,Cluster Management Services,[Rajesh_Srinivasaragh],[Rajesh_Srinivasaragh],,,,,,
+hp-clic,3384,udp,Hardware Management,[Rajesh_Srinivasaragh],[Rajesh_Srinivasaragh],,,,,,
+qnxnetman,3385,tcp,qnxnetman,[Michael_Hunter],[Michael_Hunter],,,,,,
+qnxnetman,3385,udp,qnxnetman,[Michael_Hunter],[Michael_Hunter],,,,,,
+gprs-data,3386,tcp,GPRS Data,,,,,,,,
+gprs-sig,3386,udp,GPRS SIG,[Ansgar_Bergmann],[Ansgar_Bergmann],,,,,,
+backroomnet,3387,tcp,Back Room Net,[Clayton_Wilkinson],[Clayton_Wilkinson],,,,,,
+backroomnet,3387,udp,Back Room Net,[Clayton_Wilkinson],[Clayton_Wilkinson],,,,,,
+cbserver,3388,tcp,CB Server,[Allen_Wei],[Allen_Wei],,,,,,
+cbserver,3388,udp,CB Server,[Allen_Wei],[Allen_Wei],,,,,,
+ms-wbt-server,3389,tcp,MS WBT Server,[Ritu_Bahl],[Ritu_Bahl],,,,,,
+ms-wbt-server,3389,udp,MS WBT Server,[Ritu_Bahl],[Ritu_Bahl],,,,,,
+dsc,3390,tcp,Distributed Service Coordinator,[Charles_Honton],[Charles_Honton],,,,,,
+dsc,3390,udp,Distributed Service Coordinator,[Charles_Honton],[Charles_Honton],,,,,,
+savant,3391,tcp,SAVANT,[Andy_Bruce],[Andy_Bruce],,,,,,
+savant,3391,udp,SAVANT,[Andy_Bruce],[Andy_Bruce],,,,,,
+efi-lm,3392,tcp,EFI License Management,[Ross_E_Greinke],[Ross_E_Greinke],,,,,,
+efi-lm,3392,udp,EFI License Management,[Ross_E_Greinke],[Ross_E_Greinke],,,,,,
+d2k-tapestry1,3393,tcp,D2K Tapestry Client to Server,,,,,,,,
+d2k-tapestry1,3393,udp,D2K Tapestry Client to Server,,,,,,,,
+d2k-tapestry2,3394,tcp,D2K Tapestry Server to Server,[Eric_Lan],[Eric_Lan],,,,,,
+d2k-tapestry2,3394,udp,D2K Tapestry Server to Server,[Eric_Lan],[Eric_Lan],,,,,,
+dyna-lm,3395,tcp,Dyna License Manager (Elam),[Anjana_Iyer],[Anjana_Iyer],,,,,,
+dyna-lm,3395,udp,Dyna License Manager (Elam),[Anjana_Iyer],[Anjana_Iyer],,,,,,
+printer-agent,3396,tcp,"Printer Agent
+IANA assigned this well-formed service name as a replacement for ""printer_agent"".",[Devon_Taylor],[Devon_Taylor],,,,,,
+printer_agent,3396,tcp,Printer Agent,[Devon_Taylor],[Devon_Taylor],,,,,,"This entry is an alias to ""printer-agent"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+printer-agent,3396,udp,"Printer Agent
+IANA assigned this well-formed service name as a replacement for ""printer_agent"".",[Devon_Taylor],[Devon_Taylor],,,,,,
+printer_agent,3396,udp,Printer Agent,[Devon_Taylor],[Devon_Taylor],,,,,,"This entry is an alias to ""printer-agent"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+cloanto-lm,3397,tcp,Cloanto License Manager,[Takeo_Sato],[Takeo_Sato],2010-04-30,,,,,
+cloanto-lm,3397,udp,Cloanto License Manager,[Takeo_Sato],[Takeo_Sato],2010-04-30,,,,,
+mercantile,3398,tcp,Mercantile,[Erik_Kragh_Jensen],[Erik_Kragh_Jensen],,,,,,
+mercantile,3398,udp,Mercantile,[Erik_Kragh_Jensen],[Erik_Kragh_Jensen],,,,,,
+csms,3399,tcp,CSMS,,,,,,,,
+csms,3399,udp,CSMS,,,,,,,,
+csms2,3400,tcp,CSMS2,[Markus_Michels_2],[Markus_Michels_2],,,,,,
+csms2,3400,udp,CSMS2,[Markus_Michels_2],[Markus_Michels_2],,,,,,
+filecast,3401,tcp,filecast,[Eden_Sherry],[Eden_Sherry],,,,,,
+filecast,3401,udp,filecast,[Eden_Sherry],[Eden_Sherry],,,,,,
+fxaengine-net,3402,tcp,FXa Engine Network Port,[Lucas_Alonso],[Lucas_Alonso],2002-02,,,,,
+fxaengine-net,3402,udp,FXa Engine Network Port,[Lucas_Alonso],[Lucas_Alonso],2002-02,,,,,
+,3403,,De-registered,,,,2006-10-27,,,,
+,3404,,Removed,,,,2002-05-01,,,,
+nokia-ann-ch1,3405,tcp,Nokia Announcement ch 1,,,,,,,,
+nokia-ann-ch1,3405,udp,Nokia Announcement ch 1,,,,,,,,
+nokia-ann-ch2,3406,tcp,Nokia Announcement ch 2,[Morteza_Kalhour],[Morteza_Kalhour],2002-02,,,,,
+nokia-ann-ch2,3406,udp,Nokia Announcement ch 2,[Morteza_Kalhour],[Morteza_Kalhour],2002-02,,,,,
+ldap-admin,3407,tcp,LDAP admin server port,[Stephen_Tsun_2],[Stephen_Tsun_2],2002-02,,,,,
+ldap-admin,3407,udp,LDAP admin server port,[Stephen_Tsun_2],[Stephen_Tsun_2],2002-02,,,,,
+BESApi,3408,tcp,BES Api Port,[Colin_Griffiths],[Colin_Griffiths],2002-02,,,,,
+BESApi,3408,udp,BES Api Port,[Colin_Griffiths],[Colin_Griffiths],2002-02,,,,,
+networklens,3409,tcp,NetworkLens Event Port,,,,,,,,
+networklens,3409,udp,NetworkLens Event Port,,,,,,,,
+networklenss,3410,tcp,NetworkLens SSL Event,[Greg_Bailey],[Greg_Bailey],2002-02,,,,,
+networklenss,3410,udp,NetworkLens SSL Event,[Greg_Bailey],[Greg_Bailey],2002-02,,,,,
+biolink-auth,3411,tcp,BioLink Authenteon server,[BioLink_Support],[BioLink_Support],2002-02,,,,,
+biolink-auth,3411,udp,BioLink Authenteon server,[BioLink_Support],[BioLink_Support],2002-02,,,,,
+xmlblaster,3412,tcp,xmlBlaster,[Marcel_Ruff],[Marcel_Ruff],2002-02,,,,,
+xmlblaster,3412,udp,xmlBlaster,[Marcel_Ruff],[Marcel_Ruff],2002-02,,,,,
+svnet,3413,tcp,SpecView Networking,[Richard_Dickins],[Richard_Dickins],2002-02,,,,,
+svnet,3413,udp,SpecView Networking,[Richard_Dickins],[Richard_Dickins],2002-02,,,,,
+wip-port,3414,tcp,BroadCloud WIP Port,,,,,,,,
+wip-port,3414,udp,BroadCloud WIP Port,,,,,,,,
+bcinameservice,3415,tcp,BCI Name Service,[Dennis_Parker],[Dennis_Parker],2002-02,,,,,
+bcinameservice,3415,udp,BCI Name Service,[Dennis_Parker],[Dennis_Parker],2002-02,,,,,
+commandport,3416,tcp,AirMobile IS Command Port,[Mike_Klein],[Mike_Klein],2002-02,,,,,
+commandport,3416,udp,AirMobile IS Command Port,[Mike_Klein],[Mike_Klein],2002-02,,,,,
+csvr,3417,tcp,ConServR file translation,[Albert_Leung],[Albert_Leung],2002-02,,,,,
+csvr,3417,udp,ConServR file translation,[Albert_Leung],[Albert_Leung],2002-02,,,,,
+rnmap,3418,tcp,Remote nmap,[Tuomo_Makinen],[Tuomo_Makinen],2002-02,,,,,
+rnmap,3418,udp,Remote nmap,[Tuomo_Makinen],[Tuomo_Makinen],2002-02,,,,,
+softaudit,3419,tcp,Isogon SoftAudit,[Per_Hellberg],[Per_Hellberg],2002-02,,,,,
+softaudit,3419,udp,ISogon SoftAudit,[Per_Hellberg],[Per_Hellberg],2002-02,,,,,
+ifcp-port,3420,tcp,iFCP User Port,,,,,[RFC4172],,,
+ifcp-port,3420,udp,iFCP User Port,,,,,[RFC4172],,,
+bmap,3421,tcp,Bull Apprise portmapper,[Jeremy_Gilbert],[Jeremy_Gilbert],,,,,,
+bmap,3421,udp,Bull Apprise portmapper,[Jeremy_Gilbert],[Jeremy_Gilbert],,,,,,
+rusb-sys-port,3422,tcp,Remote USB System Port,[Steven_Klein],[Steven_Klein],2002-02,,,,,
+rusb-sys-port,3422,udp,Remote USB System Port,[Steven_Klein],[Steven_Klein],2002-02,,,,,
+xtrm,3423,tcp,xTrade Reliable Messaging,,,,,,,,
+xtrm,3423,udp,xTrade Reliable Messaging,,,,,,,,
+xtrms,3424,tcp,xTrade over TLS/SSL,[Mats_Nilsson],[Mats_Nilsson],2002-02,,,,,
+xtrms,3424,udp,xTrade over TLS/SSL,[Mats_Nilsson],[Mats_Nilsson],2002-02,,,,,
+agps-port,3425,tcp,AGPS Access Port,[Kristoffer_Nilsson],[Kristoffer_Nilsson],2002-02,,,,,
+agps-port,3425,udp,AGPS Access Port,[Kristoffer_Nilsson],[Kristoffer_Nilsson],2002-02,,,,,
+arkivio,3426,tcp,Arkivio Storage Protocol,[Bruce_Greenblatt],[Bruce_Greenblatt],2002-02,,,,,
+arkivio,3426,udp,Arkivio Storage Protocol,[Bruce_Greenblatt],[Bruce_Greenblatt],2002-02,,,,,
+websphere-snmp,3427,tcp,WebSphere SNMP,[Richard_Mills],[Richard_Mills],2002-02,,,,,
+websphere-snmp,3427,udp,WebSphere SNMP,[Richard_Mills],[Richard_Mills],2002-02,,,,,
+twcss,3428,tcp,2Wire CSS,[Wire_IANA_Contact],[Wire_IANA_Contact],2002-02,,,,,
+twcss,3428,udp,2Wire CSS,[Wire_IANA_Contact],[Wire_IANA_Contact],2002-02,,,,,
+gcsp,3429,tcp,GCSP user port,[Anirban_Majumder],[Anirban_Majumder],2002-03,,,,,
+gcsp,3429,udp,GCSP user port,[Anirban_Majumder],[Anirban_Majumder],2002-03,,,,,
+ssdispatch,3430,tcp,Scott Studios Dispatch,[Michael_Settles],[Michael_Settles],2002-03,,,,,
+ssdispatch,3430,udp,Scott Studios Dispatch,[Michael_Settles],[Michael_Settles],2002-03,,,,,
+ndl-als,3431,tcp,Active License Server Port,[Quentin_Brown],[Quentin_Brown],2002-03,,,,,
+ndl-als,3431,udp,Active License Server Port,[Quentin_Brown],[Quentin_Brown],2002-03,,,,,
+osdcp,3432,tcp,Secure Device Protocol,[Peter_Fernandez],[Peter_Fernandez],2002-03,,,,,
+osdcp,3432,udp,Secure Device Protocol,[Peter_Fernandez],[Peter_Fernandez],2002-03,,,,,
+opnet-smp,3433,tcp,OPNET Service Management Platform,[OPNET_Technologies_Inc],[Edward_Macomber],2002-03,2011-09-21,,,,
+opnet-smp,3433,udp,OPNET Service Management Platform,[OPNET_Technologies_Inc],[Edward_Macomber],2002-03,2011-09-21,,,,
+opencm,3434,tcp,OpenCM Server,[Jonathan_S_Shapiro],[Jonathan_S_Shapiro],2002-03,,,,,
+opencm,3434,udp,OpenCM Server,[Jonathan_S_Shapiro],[Jonathan_S_Shapiro],2002-03,,,,,
+pacom,3435,tcp,Pacom Security User Port,[Steve_Barton],[Steve_Barton],2002-03,,,,,
+pacom,3435,udp,Pacom Security User Port,[Steve_Barton],[Steve_Barton],2002-03,,,,,
+gc-config,3436,tcp,GuardControl Exchange Protocol,[Andreas_Schwarz],[Andreas_Schwarz],2002-03,,,,,
+gc-config,3436,udp,GuardControl Exchange Protocol,[Andreas_Schwarz],[Andreas_Schwarz],2002-03,,,,,
+autocueds,3437,tcp,Autocue Directory Service,[Geoff_Back],[Geoff_Back],2002-03,,,,,
+autocueds,3437,udp,Autocue Directory Service,[Geoff_Back],[Geoff_Back],2002-03,,,,,
+spiral-admin,3438,tcp,Spiralcraft Admin,[Michael_Toth],[Michael_Toth],2002-03,,,,,
+spiral-admin,3438,udp,Spiralcraft Admin,[Michael_Toth],[Michael_Toth],2002-03,,,,,
+hri-port,3439,tcp,HRI Interface Port,[John_Fayos],[John_Fayos],2002-03,,,,,
+hri-port,3439,udp,HRI Interface Port,[John_Fayos],[John_Fayos],2002-03,,,,,
+ans-console,3440,tcp,Net Steward Mgmt Console,[John_Richmond],[John_Richmond],2002-03,,,,,
+ans-console,3440,udp,Net Steward Mgmt Console,[John_Richmond],[John_Richmond],2002-03,,,,,
+connect-client,3441,tcp,OC Connect Client,,,,,,,,
+connect-client,3441,udp,OC Connect Client,,,,,,,,
+connect-server,3442,tcp,OC Connect Server,[Mike_Velten_2],[Mike_Velten_2],2002-03,,,,,
+connect-server,3442,udp,OC Connect Server,[Mike_Velten_2],[Mike_Velten_2],2002-03,,,,,
+ov-nnm-websrv,3443,tcp,OpenView Network Node Manager WEB Server,[Anthony_Walker],[Anthony_Walker],2002-03,,,,,
+ov-nnm-websrv,3443,udp,OpenView Network Node Manager WEB Server,[Anthony_Walker],[Anthony_Walker],2002-03,,,,,
+denali-server,3444,tcp,Denali Server,[Joe_Devlin],[Joe_Devlin],2002-03,,,,,
+denali-server,3444,udp,Denali Server,[Joe_Devlin],[Joe_Devlin],2002-03,,,,,
+monp,3445,tcp,Media Object Network,[Ron_Herardian],[Ron_Herardian],2002-03,,,,,
+monp,3445,udp,Media Object Network,[Ron_Herardian],[Ron_Herardian],2002-03,,,,,
+3comfaxrpc,3446,tcp,3Com FAX RPC port,[Christopher_Wells_2],[Christopher_Wells_2],2002-04,,,,,
+3comfaxrpc,3446,udp,3Com FAX RPC port,[Christopher_Wells_2],[Christopher_Wells_2],2002-04,,,,,
+directnet,3447,tcp,DirectNet IM System,[Gregory_Richards],[Gregory_Richards],2002-04,,,,,
+directnet,3447,udp,DirectNet IM System,[Gregory_Richards],[Gregory_Richards],2002-04,,,,,
+dnc-port,3448,tcp,Discovery and Net Config,[Chi_Chen],[Chi_Chen],2002-04,,,,,
+dnc-port,3448,udp,Discovery and Net Config,[Chi_Chen],[Chi_Chen],2002-04,,,,,
+hotu-chat,3449,tcp,HotU Chat,[Tim_Burgess],[Tim_Burgess],2002-04,,,,,
+hotu-chat,3449,udp,HotU Chat,[Tim_Burgess],[Tim_Burgess],2002-04,,,,,
+castorproxy,3450,tcp,CAStorProxy,[Raymond_J_Young],[Raymond_J_Young],2002-04,,,,,
+castorproxy,3450,udp,CAStorProxy,[Raymond_J_Young],[Raymond_J_Young],2002-04,,,,,
+asam,3451,tcp,ASAM Services,[Mike_Gossett],[Mike_Gossett],2002-04,,,,,
+asam,3451,udp,ASAM Services,[Mike_Gossett],[Mike_Gossett],2002-04,,,,,
+sabp-signal,3452,tcp,SABP-Signalling Protocol,[Brendan_McWilliams],[Brendan_McWilliams],2002-04,,,,,
+sabp-signal,3452,udp,SABP-Signalling Protocol,[Brendan_McWilliams],[Brendan_McWilliams],2002-04,,,,,
+pscupd,3453,tcp,PSC Update,[Datalogic_ADC_Inc],[Reid_B_Ligon],2001-11-10,2014-07-31,,,,
+pscupd,3453,udp,PSC Update,[Datalogic_ADC_Inc],[Reid_B_Ligon],2001-11-10,2014-07-31,,,,
+mira,3454,tcp,Apple Remote Access Protocol,[Mike_Alexander],[Mike_Alexander],,,,,,
+mira,3454,udp,Apple Remote Access Protocol,[Mike_Alexander],[Mike_Alexander],,,,,,
+prsvp,3455,tcp,RSVP Port,[Bob_Braden],[Bob_Braden],,,,,,
+prsvp,3455,udp,RSVP Port,[Bob_Braden],[Bob_Braden],,,,,,
+vat,3456,tcp,VAT default data,[Van_Jacobson],[Van_Jacobson],,,,,,
+vat,3456,udp,VAT default data,[Van_Jacobson],[Van_Jacobson],,,,,,
+vat-control,3457,tcp,VAT default control,[Van_Jacobson],[Van_Jacobson],,,,,,
+vat-control,3457,udp,VAT default control,[Van_Jacobson],[Van_Jacobson],,,,,,
+d3winosfi,3458,tcp,D3WinOSFI,[Brad_Hamilton],[Brad_Hamilton],,,,,,
+d3winosfi,3458,udp,D3WinOSFI,[Brad_Hamilton],[Brad_Hamilton],,,,,,
+integral,3459,tcp,TIP Integral,[Olivier_Mascia],[Olivier_Mascia],,,,,,
+integral,3459,udp,TIP Integral,[Olivier_Mascia],[Olivier_Mascia],,,,,,
+edm-manager,3460,tcp,EDM Manger,,,,,,,,
+edm-manager,3460,udp,EDM Manger,,,,,,,,
+edm-stager,3461,tcp,EDM Stager,,,,,,,,
+edm-stager,3461,udp,EDM Stager,,,,,,,,
+edm-std-notify,3462,tcp,EDM STD Notify,,,,,,,,
+edm-std-notify,3462,udp,EDM STD Notify,,,,,,,,
+edm-adm-notify,3463,tcp,EDM ADM Notify,,,,,,,,
+edm-adm-notify,3463,udp,EDM ADM Notify,,,,,,,,
+edm-mgr-sync,3464,tcp,EDM MGR Sync,,,,,,,,
+edm-mgr-sync,3464,udp,EDM MGR Sync,,,,,,,,
+edm-mgr-cntrl,3465,tcp,EDM MGR Cntrl,[Tom_Hennessy],[Tom_Hennessy],,,,,,
+edm-mgr-cntrl,3465,udp,EDM MGR Cntrl,[Tom_Hennessy],[Tom_Hennessy],,,,,,
+workflow,3466,tcp,WORKFLOW,[Robert_Hufsky],[Robert_Hufsky],,,,,,
+workflow,3466,udp,WORKFLOW,[Robert_Hufsky],[Robert_Hufsky],,,,,,
+rcst,3467,tcp,RCST,[Kit_Sturgeon],[Kit_Sturgeon],,,,,,
+rcst,3467,udp,RCST,[Kit_Sturgeon],[Kit_Sturgeon],,,,,,
+ttcmremotectrl,3468,tcp,TTCM Remote Controll,[Yossi_Cohen_Shahar],[Yossi_Cohen_Shahar],,,,,,
+ttcmremotectrl,3468,udp,TTCM Remote Controll,[Yossi_Cohen_Shahar],[Yossi_Cohen_Shahar],,,,,,
+pluribus,3469,tcp,Pluribus,[Mark_Miller],[Mark_Miller],,,,,,
+pluribus,3469,udp,Pluribus,[Mark_Miller],[Mark_Miller],,,,,,
+jt400,3470,tcp,jt400,,,,,,,,
+jt400,3470,udp,jt400,,,,,,,,
+jt400-ssl,3471,tcp,jt400-ssl,[Clifton_Nock],[Clifton_Nock],,,,,,
+jt400-ssl,3471,udp,jt400-ssl,[Clifton_Nock],[Clifton_Nock],,,,,,
+jaugsremotec-1,3472,tcp,JAUGS N-G Remotec 1,,,,,,,,
+jaugsremotec-1,3472,udp,JAUGS N-G Remotec 1,,,,,,,,
+jaugsremotec-2,3473,tcp,JAUGS N-G Remotec 2,[Steven_B_Cliff],[Steven_B_Cliff],2002-04,,,,,
+jaugsremotec-2,3473,udp,JAUGS N-G Remotec 2,[Steven_B_Cliff],[Steven_B_Cliff],2002-04,,,,,
+ttntspauto,3474,tcp,TSP Automation,[Arnie_Koster],[Arnie_Koster],2002-04,,,,,
+ttntspauto,3474,udp,TSP Automation,[Arnie_Koster],[Arnie_Koster],2002-04,,,,,
+genisar-port,3475,tcp,Genisar Comm Port,[Candace_Niccolson],[Candace_Niccolson],2002-04,,,,,
+genisar-port,3475,udp,Genisar Comm Port,[Candace_Niccolson],[Candace_Niccolson],2002-04,,,,,
+nppmp,3476,tcp,NVIDIA Mgmt Protocol,[Gilbert_Yeung],[Gilbert_Yeung],2002-04,,,,,
+nppmp,3476,udp,NVIDIA Mgmt Protocol,[Gilbert_Yeung],[Gilbert_Yeung],2002-04,,,,,
+ecomm,3477,tcp,eComm link port,[Thomas_Soerensen],[Thomas_Soerensen],2002-04,,,,,
+ecomm,3477,udp,eComm link port,[Thomas_Soerensen],[Thomas_Soerensen],2002-04,,,,,
+stun,3478,tcp,Session Traversal Utilities for NAT (STUN) port,,,,,[RFC5389],,,
+stun,3478,udp,Session Traversal Utilities for NAT (STUN) port,,,,,[RFC5389],,,
+turn,3478,tcp,TURN over TCP,,,,,[RFC5766],,,
+turn,3478,udp,TURN over UDP,,,,,[RFC5766],,,
+stun-behavior,3478,tcp,STUN Behavior Discovery over TCP,,,,,[RFC5780],,,
+stun-behavior,3478,udp,STUN Behavior Discovery over UDP,,,,,[RFC5780],,,
+twrpc,3479,tcp,2Wire RPC,[Wire_IANA_Contact],[Wire_IANA_Contact],2002-04,,,,,
+twrpc,3479,udp,2Wire RPC,[Wire_IANA_Contact],[Wire_IANA_Contact],2002-04,,,,,
+plethora,3480,tcp,Secure Virtual Workspace,[Tim_Simms],[Tim_Simms],2002-04,,,,,
+plethora,3480,udp,Secure Virtual Workspace,[Tim_Simms],[Tim_Simms],2002-04,,,,,
+cleanerliverc,3481,tcp,CleanerLive remote ctrl,[David_Mojdehi],[David_Mojdehi],2002-04,,,,,
+cleanerliverc,3481,udp,CleanerLive remote ctrl,[David_Mojdehi],[David_Mojdehi],2002-04,,,,,
+vulture,3482,tcp,Vulture Monitoring System,[Jason_Santos],[Jason_Santos],2002-04,,,,,
+vulture,3482,udp,Vulture Monitoring System,[Jason_Santos],[Jason_Santos],2002-04,,,,,
+slim-devices,3483,tcp,Slim Devices Protocol,[Sean_Adams],[Sean_Adams],2002-05,,,,,
+slim-devices,3483,udp,Slim Devices Protocol,[Sean_Adams],[Sean_Adams],2002-05,,,,,
+gbs-stp,3484,tcp,GBS SnapTalk Protocol,[Eric_Harris_Braun],[Eric_Harris_Braun],2002-05,,,,,
+gbs-stp,3484,udp,GBS SnapTalk Protocol,[Eric_Harris_Braun],[Eric_Harris_Braun],2002-05,,,,,
+celatalk,3485,tcp,CelaTalk,[Carl_Blundell],[Carl_Blundell],2002-05,,,,,
+celatalk,3485,udp,CelaTalk,[Carl_Blundell],[Carl_Blundell],2002-05,,,,,
+ifsf-hb-port,3486,tcp,IFSF Heartbeat Port,[IFSF_Secretary],[IFSF_Secretary],2002-05,,,,,
+ifsf-hb-port,3486,udp,IFSF Heartbeat Port,[IFSF_Secretary],[IFSF_Secretary],2002-05,,,,,
+ltctcp,3487,tcp,LISA TCP Transfer Channel,,,,,,,,
+ltcudp,3487,udp,LISA UDP Transfer Channel,[Pit_Vetterick],[Pit_Vetterick],2002-05,,,,,
+fs-rh-srv,3488,tcp,FS Remote Host Server,[Brian_Nickles],[Brian_Nickles],2002-05,,,,,
+fs-rh-srv,3488,udp,FS Remote Host Server,[Brian_Nickles],[Brian_Nickles],2002-05,,,,,
+dtp-dia,3489,tcp,DTP/DIA,[Alexei_V_Soloviev],[Alexei_V_Soloviev],2002-05,,,,,
+dtp-dia,3489,udp,DTP/DIA,[Alexei_V_Soloviev],[Alexei_V_Soloviev],2002-05,,,,,
+colubris,3490,tcp,Colubris Management Port,[Gilbert_Moineau],[Gilbert_Moineau],2002-05,,,,,
+colubris,3490,udp,Colubris Management Port,[Gilbert_Moineau],[Gilbert_Moineau],2002-05,,,,,
+swr-port,3491,tcp,SWR Port,[Ian_Manning],[Ian_Manning],2002-05,,,,,
+swr-port,3491,udp,SWR Port,[Ian_Manning],[Ian_Manning],2002-05,,,,,
+tvdumtray-port,3492,tcp,TVDUM Tray Port,[Peter_Boers],[Peter_Boers],2002-05,,,,,
+tvdumtray-port,3492,udp,TVDUM Tray Port,[Peter_Boers],[Peter_Boers],2002-05,,,,,
+nut,3493,tcp,Network UPS Tools,[Russell_Kroll],[Russell_Kroll],2002-05,,,,,
+nut,3493,udp,Network UPS Tools,[Russell_Kroll],[Russell_Kroll],2002-05,,,,,
+ibm3494,3494,tcp,IBM 3494,[Jeffrey_Pilch],[Jeffrey_Pilch],,,,,,
+ibm3494,3494,udp,IBM 3494,[Jeffrey_Pilch],[Jeffrey_Pilch],,,,,,
+seclayer-tcp,3495,tcp,securitylayer over tcp,,,,,,,,
+seclayer-tcp,3495,udp,securitylayer over tcp,,,,,,,,
+seclayer-tls,3496,tcp,securitylayer over tls,[Arno_Hollosi],[Arno_Hollosi],2002-03,,,,,
+seclayer-tls,3496,udp,securitylayer over tls,[Arno_Hollosi],[Arno_Hollosi],2002-03,,,,,
+ipether232port,3497,tcp,ipEther232Port,[Marcus_Leufgen],[Marcus_Leufgen],2002-05,,,,,
+ipether232port,3497,udp,ipEther232Port,[Marcus_Leufgen],[Marcus_Leufgen],2002-05,,,,,
+dashpas-port,3498,tcp,DASHPAS user port,[Albrecht_Mayer],[Albrecht_Mayer],2002-05,,,,,
+dashpas-port,3498,udp,DASHPAS user port,[Albrecht_Mayer],[Albrecht_Mayer],2002-05,,,,,
+sccip-media,3499,tcp,SccIP Media,[David_Yon_2],[David_Yon_2],2002-05,,,,,
+sccip-media,3499,udp,SccIP Media,[David_Yon_2],[David_Yon_2],2002-05,,,,,
+rtmp-port,3500,tcp,RTMP Port,[Miriam_Wohlgelernter],[Miriam_Wohlgelernter],,,,,,
+rtmp-port,3500,udp,RTMP Port,[Miriam_Wohlgelernter],[Miriam_Wohlgelernter],,,,,,
+isoft-p2p,3501,tcp,iSoft-P2P,[David_Walling_2],[David_Walling_2],,,,,,
+isoft-p2p,3501,udp,iSoft-P2P,[David_Walling_2],[David_Walling_2],,,,,,
+avinstalldisc,3502,tcp,Avocent Install Discovery,[Brian_S_Stewart_2],[Brian_S_Stewart_2],,,,,,
+avinstalldisc,3502,udp,Avocent Install Discovery,[Brian_S_Stewart_2],[Brian_S_Stewart_2],,,,,,
+lsp-ping,3503,tcp,MPLS LSP-echo Port,,,,,[RFC4379],,,
+lsp-ping,3503,udp,MPLS LSP-echo Port,,,,,[RFC4379],,,
+ironstorm,3504,tcp,IronStorm game server,[Arnaud_Clermonte],[Arnaud_Clermonte],,,,,,
+ironstorm,3504,udp,IronStorm game server,[Arnaud_Clermonte],[Arnaud_Clermonte],,,,,,
+ccmcomm,3505,tcp,CCM communications port,[Tom_Bougan],[Tom_Bougan],,,,,,
+ccmcomm,3505,udp,CCM communications port,[Tom_Bougan],[Tom_Bougan],,,,,,
+apc-3506,3506,tcp,APC 3506,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-3506,3506,udp,APC 3506,[American_Power_Conve],[American_Power_Conve],,,,,,
+nesh-broker,3507,tcp,Nesh Broker Port,[Jeremy_Maiden],[Jeremy_Maiden],,,,,,
+nesh-broker,3507,udp,Nesh Broker Port,[Jeremy_Maiden],[Jeremy_Maiden],,,,,,
+interactionweb,3508,tcp,Interaction Web,[Mike_Gagle_2],[Mike_Gagle_2],,,,,,
+interactionweb,3508,udp,Interaction Web,[Mike_Gagle_2],[Mike_Gagle_2],,,,,,
+vt-ssl,3509,tcp,Virtual Token SSL Port,[Libor_Sykora],[Libor_Sykora],2002-05,,,,,
+vt-ssl,3509,udp,Virtual Token SSL Port,[Libor_Sykora],[Libor_Sykora],2002-05,,,,,
+xss-port,3510,tcp,XSS Port,[Joe_Purcell],[Joe_Purcell],2002-05,,,,,
+xss-port,3510,udp,XSS Port,[Joe_Purcell],[Joe_Purcell],2002-05,,,,,
+webmail-2,3511,tcp,WebMail/2,[Dimitris_Michelinaki],[Dimitris_Michelinaki],2002-05,,,,,
+webmail-2,3511,udp,WebMail/2,[Dimitris_Michelinaki],[Dimitris_Michelinaki],2002-05,,,,,
+aztec,3512,tcp,Aztec Distribution Port,[Alan_Francis],[Alan_Francis],2002-05,,,,,
+aztec,3512,udp,Aztec Distribution Port,[Alan_Francis],[Alan_Francis],2002-05,,,,,
+arcpd,3513,tcp,Adaptec Remote Protocol,[Hardy_Doelfel],[Hardy_Doelfel],2002-05,,,,,
+arcpd,3513,udp,Adaptec Remote Protocol,[Hardy_Doelfel],[Hardy_Doelfel],2002-05,,,,,
+must-p2p,3514,tcp,MUST Peer to Peer,,,,,,,,
+must-p2p,3514,udp,MUST Peer to Peer,,,,,,,,
+must-backplane,3515,tcp,MUST Backplane,[Rick_Stefanik],[Rick_Stefanik],2002-05,,,,,
+must-backplane,3515,udp,MUST Backplane,[Rick_Stefanik],[Rick_Stefanik],2002-05,,,,,
+smartcard-port,3516,tcp,Smartcard Port,[Scott_Guthery],[Scott_Guthery],2002-05,,,,,
+smartcard-port,3516,udp,Smartcard Port,[Scott_Guthery],[Scott_Guthery],2002-05,,,,,
+802-11-iapp,3517,tcp,IEEE 802.11 WLANs WG IAPP,[Stuart_J_Kerry],[Stuart_J_Kerry],2002-05,,,,,
+802-11-iapp,3517,udp,IEEE 802.11 WLANs WG IAPP,[Stuart_J_Kerry],[Stuart_J_Kerry],2002-05,,,,,
+artifact-msg,3518,tcp,Artifact Message Server,[Ron_Capwell],[Ron_Capwell],2002-06,,,,,
+artifact-msg,3518,udp,Artifact Message Server,[Ron_Capwell],[Ron_Capwell],2002-06,,,,,
+nvmsgd,3519,tcp,Netvion Messenger Port,,,,,,,,
+galileo,3519,udp,Netvion Galileo Port,,,,,,,,
+galileolog,3520,tcp,Netvion Galileo Log Port,[Ray_Caruso],[Ray_Caruso],2002-06,,,,,
+galileolog,3520,udp,Netvion Galileo Log Port,[Ray_Caruso],[Ray_Caruso],2002-06,,,,,
+mc3ss,3521,tcp,Telequip Labs MC3SS,[Michael_Sparks],[Michael_Sparks],2002-06,,,,,
+mc3ss,3521,udp,Telequip Labs MC3SS,[Michael_Sparks],[Michael_Sparks],2002-06,,,,,
+nfs-domainroot,,tcp,"NFS service for the domain root, the root of an organization's published file namespace.",[IESG],[IETF_Chair],2012-04-24,,[RFC6641],,,Defined TXT keys: None
+nssocketport,3522,tcp,DO over NSSocketPort,[Douglas_Davidson],[Douglas_Davidson],2002-06,,,,,
+nssocketport,3522,udp,DO over NSSocketPort,[Douglas_Davidson],[Douglas_Davidson],2002-06,,,,,
+odeumservlink,3523,tcp,Odeum Serverlink,[Mads_Peter_Back],[Mads_Peter_Back],2002-06,,,,,
+odeumservlink,3523,udp,Odeum Serverlink,[Mads_Peter_Back],[Mads_Peter_Back],2002-06,,,,,
+ecmport,3524,tcp,ECM Server port,,,,,,,,
+ecmport,3524,udp,ECM Server port,,,,,,,,
+eisport,3525,tcp,EIS Server port,[Paul_Kraus],[Paul_Kraus],2002-06,,,,,
+eisport,3525,udp,EIS Server port,[Paul_Kraus],[Paul_Kraus],2002-06,,,,,
+starquiz-port,3526,tcp,starQuiz Port,[Adam_Ernst_2],[Adam_Ernst_2],2002-06,,,,,
+starquiz-port,3526,udp,starQuiz Port,[Adam_Ernst_2],[Adam_Ernst_2],2002-06,,,,,
+beserver-msg-q,3527,tcp,VERITAS Backup Exec Server,[Katherine_Wattwood],[Katherine_Wattwood],2002-06,,,,,
+beserver-msg-q,3527,udp,VERITAS Backup Exec Server,[Katherine_Wattwood],[Katherine_Wattwood],2002-06,,,,,
+jboss-iiop,3528,tcp,JBoss IIOP,,,,,,,,
+jboss-iiop,3528,udp,JBoss IIOP,,,,,,,,
+jboss-iiop-ssl,3529,tcp,JBoss IIOP/SSL,[Francisco_Reverbel],[Francisco_Reverbel],2002-06,,,,,
+jboss-iiop-ssl,3529,udp,JBoss IIOP/SSL,[Francisco_Reverbel],[Francisco_Reverbel],2002-06,,,,,
+gf,3530,tcp,Grid Friendly,[Daivd_P_Chassin],[Daivd_P_Chassin],2002-06,,,,,
+gf,3530,udp,Grid Friendly,[Daivd_P_Chassin],[Daivd_P_Chassin],2002-06,,,,,
+joltid,3531,tcp,Joltid,[Ahti_Heinla],[Ahti_Heinla],2002-06,,,,,
+joltid,3531,udp,Joltid,[Ahti_Heinla],[Ahti_Heinla],2002-06,,,,,
+raven-rmp,3532,tcp,Raven Remote Management Control,,,,,,,,
+raven-rmp,3532,udp,Raven Remote Management Control,,,,,,,,
+raven-rdp,3533,tcp,Raven Remote Management Data,[Daniel_Sorlov_2],[Daniel_Sorlov_2],2002-06,,,,,
+raven-rdp,3533,udp,Raven Remote Management Data,[Daniel_Sorlov_2],[Daniel_Sorlov_2],2002-06,,,,,
+urld-port,3534,tcp,URL Daemon Port,[Jim_Binkley],[Jim_Binkley],2002-06,,,,,
+urld-port,3534,udp,URL Daemon Port,[Jim_Binkley],[Jim_Binkley],2002-06,,,,,
+ms-la,3535,tcp,MS-LA,[Eric_Ledoux],[Eric_Ledoux],,,,,,
+ms-la,3535,udp,MS-LA,[Eric_Ledoux],[Eric_Ledoux],,,,,,
+snac,3536,tcp,SNAC,[Tatsuya_Igarashi],[Tatsuya_Igarashi],2002-07,,,,,
+snac,3536,udp,SNAC,[Tatsuya_Igarashi],[Tatsuya_Igarashi],2002-07,,,,,
+ni-visa-remote,3537,tcp,Remote NI-VISA port,[Sinnadurai_Dharshan],[Sinnadurai_Dharshan],2002-07,,,,,
+ni-visa-remote,3537,udp,Remote NI-VISA port,[Sinnadurai_Dharshan],[Sinnadurai_Dharshan],2002-07,,,,,
+ibm-diradm,3538,tcp,IBM Directory Server,,,,,,,,
+ibm-diradm,3538,udp,IBM Directory Server,,,,,,,,
+ibm-diradm-ssl,3539,tcp,IBM Directory Server SSL,[Mark_Cavage],[Mark_Cavage],2002-07,,,,,
+ibm-diradm-ssl,3539,udp,IBM Directory Server SSL,[Mark_Cavage],[Mark_Cavage],2002-07,,,,,
+pnrp-port,3540,tcp,PNRP User Port,[Igor_Kostic],[Igor_Kostic],2002-07,,,,,
+pnrp-port,3540,udp,PNRP User Port,[Igor_Kostic],[Igor_Kostic],2002-07,,,,,
+voispeed-port,3541,tcp,VoiSpeed Port,[Virgilio_Lattanzi],[Virgilio_Lattanzi],2002-07,,,,,
+voispeed-port,3541,udp,VoiSpeed Port,[Virgilio_Lattanzi],[Virgilio_Lattanzi],2002-07,,,,,
+hacl-monitor,3542,tcp,HA cluster monitor,[Jason_Ko],[Jason_Ko],2002-07,,,,,
+hacl-monitor,3542,udp,HA cluster monitor,[Jason_Ko],[Jason_Ko],2002-07,,,,,
+qftest-lookup,3543,tcp,qftest Lookup Port,[Gregor_Schmid],[Gregor_Schmid],2002-07,,,,,
+qftest-lookup,3543,udp,qftest Lookup Port,[Gregor_Schmid],[Gregor_Schmid],2002-07,,,,,
+teredo,3544,tcp,Teredo Port,,,,,[RFC4380],,,
+teredo,3544,udp,Teredo Port,,,,,[RFC4380],,,
+camac,3545,tcp,CAMAC equipment,[Eugene_Zhiganov],[Eugene_Zhiganov],2002-07,,,,,
+camac,3545,udp,CAMAC equipment,[Eugene_Zhiganov],[Eugene_Zhiganov],2002-07,,,,,
+,3546,,Unassigned,,,,2002-09,,,,
+symantec-sim,3547,tcp,Symantec SIM,[George_Dzieciol],[George_Dzieciol],2002-07,,,,,
+symantec-sim,3547,udp,Symantec SIM,[George_Dzieciol],[George_Dzieciol],2002-07,,,,,
+interworld,3548,tcp,Interworld,[John_Stephen],[John_Stephen],2002-07,,,,,
+interworld,3548,udp,Interworld,[John_Stephen],[John_Stephen],2002-07,,,,,
+tellumat-nms,3549,tcp,Tellumat MDR NMS,[Hennie_van_der_Merwe],[Hennie_van_der_Merwe],2002-07,,,,,
+tellumat-nms,3549,udp,Tellumat MDR NMS,[Hennie_van_der_Merwe],[Hennie_van_der_Merwe],2002-07,,,,,
+ssmpp,3550,tcp,Secure SMPP,[Cormac_Long],[Cormac_Long],2002-07,,,,,
+ssmpp,3550,udp,Secure SMPP,[Cormac_Long],[Cormac_Long],2002-07,,,,,
+apcupsd,3551,tcp,Apcupsd Information Port,[Riccardo_Facchetti],[Riccardo_Facchetti],2002-07,,,,,
+apcupsd,3551,udp,Apcupsd Information Port,[Riccardo_Facchetti],[Riccardo_Facchetti],2002-07,,,,,
+taserver,3552,tcp,TeamAgenda Server Port,[Dany_Ayotte],[Dany_Ayotte],2002-07,,,,,
+taserver,3552,udp,TeamAgenda Server Port,[Dany_Ayotte],[Dany_Ayotte],2002-07,,,,,
+rbr-discovery,3553,tcp,Red Box Recorder ADP,[Simon_Jolly],[Simon_Jolly],2002-07,,,,,
+rbr-discovery,3553,udp,Red Box Recorder ADP,[Simon_Jolly],[Simon_Jolly],2002-07,,,,,
+questnotify,3554,tcp,Quest Notification Server,[Rob_Griffin],[Rob_Griffin],2002-07,,,,,
+questnotify,3554,udp,Quest Notification Server,[Rob_Griffin],[Rob_Griffin],2002-07,,,,,
+razor,3555,tcp,Vipul's Razor,[Vipul_Ved_Prakash],[Vipul_Ved_Prakash],2002-07,,,,,
+razor,3555,udp,Vipul's Razor,[Vipul_Ved_Prakash],[Vipul_Ved_Prakash],2002-07,,,,,
+sky-transport,3556,tcp,Sky Transport Protocol,[Michael_Paddon],[Michael_Paddon],2002-07,,,,,
+sky-transport,3556,udp,Sky Transport Protocol,[Michael_Paddon],[Michael_Paddon],2002-07,,,,,
+personalos-001,3557,tcp,PersonalOS Comm Port,[Shane_Roberts],[Shane_Roberts],2002-07,,,,,
+personalos-001,3557,udp,PersonalOS Comm Port,[Shane_Roberts],[Shane_Roberts],2002-07,,,,,
+mcp-port,3558,tcp,MCP user port,[Professor_Paul_S_Wa],[Professor_Paul_S_Wa],2002-07,,,,,
+mcp-port,3558,udp,MCP user port,[Professor_Paul_S_Wa],[Professor_Paul_S_Wa],2002-07,,,,,
+cctv-port,3559,tcp,CCTV control port,[John_Skidmore],[John_Skidmore],2002-07,,,,,
+cctv-port,3559,udp,CCTV control port,[John_Skidmore],[John_Skidmore],2002-07,,,,,
+iniserve-port,3560,tcp,INIServe port,[Peter_Moylan],[Peter_Moylan],2002-08,,,,,
+iniserve-port,3560,udp,INIServe port,[Peter_Moylan],[Peter_Moylan],2002-08,,,,,
+bmc-onekey,3561,tcp,BMC-OneKey,[Portnoy_Boxman],[Portnoy_Boxman],2002-08,,,,,
+bmc-onekey,3561,udp,BMC-OneKey,[Portnoy_Boxman],[Portnoy_Boxman],2002-08,,,,,
+sdbproxy,3562,tcp,SDBProxy,[Eric_Grange],[Eric_Grange],2002-08,,,,,
+sdbproxy,3562,udp,SDBProxy,[Eric_Grange],[Eric_Grange],2002-08,,,,,
+watcomdebug,3563,tcp,Watcom Debug,[Dave_Neudoerffer],[Dave_Neudoerffer],,,,,,
+watcomdebug,3563,udp,Watcom Debug,[Dave_Neudoerffer],[Dave_Neudoerffer],,,,,,
+esimport,3564,tcp,Electromed SIM port,[Francois_Marchand],[Francois_Marchand],2002-08,,,,,
+esimport,3564,udp,Electromed SIM port,[Francois_Marchand],[Francois_Marchand],2002-08,,,,,
+m2pa,3565,tcp,M2PA,,,,,[RFC4165],,,
+,3565,udp,Reserved,,,,,,,,
+m2pa,3565,sctp,M2PA,,,,,[RFC4165],,,
+quest-data-hub,3566,tcp,Quest Data Hub,[Greg_Cottman_2],[Greg_Cottman_2],2010-10-18,,,,,
+,3566,udp,Reserved,,,,2010-10-18,,,,
+enc-eps,3567,tcp,EMIT protocol stack,[Panasonic_Intranet_Panasonic_North_America_PEWLA],[Bryant_Eastham],2002-08,2012-11-12,,,,
+enc-eps,3567,udp,EMIT protocol stack,[Panasonic_Intranet_Panasonic_North_America_PEWLA],[Bryant_Eastham],2002-08,2012-11-12,,,,
+enc-tunnel-sec,3568,tcp,EMIT secure tunnel,[Panasonic_Intranet_Panasonic_North_America_PEWLA],[Bryant_Eastham],2003-01,2012-11-12,,,,
+enc-tunnel-sec,3568,udp,EMIT secure tunnel,[Panasonic_Intranet_Panasonic_North_America_PEWLA],[Bryant_Eastham],2003-01,2012-11-12,,,,
+mbg-ctrl,3569,tcp,Meinberg Control Service,[Martin_Burnicki],[Martin_Burnicki],2002-08,,,,,
+mbg-ctrl,3569,udp,Meinberg Control Service,[Martin_Burnicki],[Martin_Burnicki],2002-08,,,,,
+mccwebsvr-port,3570,tcp,MCC Web Server Port,,,,,,,,
+mccwebsvr-port,3570,udp,MCC Web Server Port,,,,,,,,
+megardsvr-port,3571,tcp,MegaRAID Server Port,,,,,,,,
+megardsvr-port,3571,udp,MegaRAID Server Port,,,,,,,,
+megaregsvrport,3572,tcp,Registration Server Port,[Sreenivas_Bagalkote],[Sreenivas_Bagalkote],2002-08,,,,,
+megaregsvrport,3572,udp,Registration Server Port,[Sreenivas_Bagalkote],[Sreenivas_Bagalkote],2002-08,,,,,
+tag-ups-1,3573,tcp,Advantage Group UPS Suite,[James_Goddard],[James_Goddard],2002-08,,,,,
+tag-ups-1,3573,udp,Advantage Group UPS Suite,[James_Goddard],[James_Goddard],2002-08,,,,,
+dmaf-server,3574,tcp,DMAF Server,,,,,,,,
+dmaf-caster,3574,udp,DMAF Caster,[Ramakrishna_Nadendla],[Ramakrishna_Nadendla],2002-08,,,,,
+ccm-port,3575,tcp,Coalsere CCM Port,,,,,,,,
+ccm-port,3575,udp,Coalsere CCM Port,,,,,,,,
+cmc-port,3576,tcp,Coalsere CMC Port,[Chris_Hawkinson],[Chris_Hawkinson],2002-08,,,,,
+cmc-port,3576,udp,Coalsere CMC Port,[Chris_Hawkinson],[Chris_Hawkinson],2002-08,,,,,
+config-port,3577,tcp,Configuration Port,,,,,,,,
+config-port,3577,udp,Configuration Port,,,,,,,,
+data-port,3578,tcp,Data Port,[Anupam_Bharali],[Anupam_Bharali],2002-08,,,,,
+data-port,3578,udp,Data Port,[Anupam_Bharali],[Anupam_Bharali],2002-08,,,,,
+ttat3lb,3579,tcp,Tarantella Load Balancing,[Jim_Musgrave],[Jim_Musgrave],2002-08,,,,,
+ttat3lb,3579,udp,Tarantella Load Balancing,[Jim_Musgrave],[Jim_Musgrave],2002-08,,,,,
+nati-svrloc,3580,tcp,NATI-ServiceLocator,[Jason_Case],[Jason_Case],2002-08,,,,,
+nati-svrloc,3580,udp,NATI-ServiceLocator,[Jason_Case],[Jason_Case],2002-08,,,,,
+kfxaclicensing,3581,tcp,Ascent Capture Licensing,[Brad_Hamilton_2],[Brad_Hamilton_2],2002-08,,,,,
+kfxaclicensing,3581,udp,Ascent Capture Licensing,[Brad_Hamilton_2],[Brad_Hamilton_2],2002-08,,,,,
+press,3582,tcp,PEG PRESS Server,[Jim_DeLisle],[Jim_DeLisle],2002-08,,,,,
+press,3582,udp,PEG PRESS Server,[Jim_DeLisle],[Jim_DeLisle],2002-08,,,,,
+canex-watch,3583,tcp,CANEX Watch System,[Peter_Kollath],[Peter_Kollath],2002-08,,,,,
+canex-watch,3583,udp,CANEX Watch System,[Peter_Kollath],[Peter_Kollath],2002-08,,,,,
+u-dbap,3584,tcp,U-DBase Access Protocol,[Bodo_Rueskamp],[Bodo_Rueskamp],2002-08,,,,,
+u-dbap,3584,udp,U-DBase Access Protocol,[Bodo_Rueskamp],[Bodo_Rueskamp],2002-08,,,,,
+emprise-lls,3585,tcp,Emprise License Server,,,,,,,,
+emprise-lls,3585,udp,Emprise License Server,,,,,,,,
+emprise-lsc,3586,tcp,License Server Console,[James_J_Diaz],[James_J_Diaz],2002-08,,,,,
+emprise-lsc,3586,udp,License Server Console,[James_J_Diaz],[James_J_Diaz],2002-08,,,,,
+p2pgroup,3587,tcp,Peer to Peer Grouping,[Igor_Kostic],[Igor_Kostic],2002-08,,,,,
+p2pgroup,3587,udp,Peer to Peer Grouping,[Igor_Kostic],[Igor_Kostic],2002-08,,,,,
+sentinel,3588,tcp,Sentinel Server,[Ian_Gordon],[Ian_Gordon],2002-08,,,,,
+sentinel,3588,udp,Sentinel Server,[Ian_Gordon],[Ian_Gordon],2002-08,,,,,
+isomair,3589,tcp,isomair,[Richard_Fleming],[Richard_Fleming],2002-08,,,,,
+isomair,3589,udp,isomair,[Richard_Fleming],[Richard_Fleming],2002-08,,,,,
+wv-csp-sms,3590,tcp,WV CSP SMS Binding,[Matti_Salmi],[Matti_Salmi],2002-08,,,,,
+wv-csp-sms,3590,udp,WV CSP SMS Binding,[Matti_Salmi],[Matti_Salmi],2002-08,,,,,
+gtrack-server,3591,tcp,LOCANIS G-TRACK Server,,,,,,,,
+gtrack-server,3591,udp,LOCANIS G-TRACK Server,,,,,,,,
+gtrack-ne,3592,tcp,LOCANIS G-TRACK NE Port,[Juergen_Edelhaeuser],[Juergen_Edelhaeuser],2002-08,,,,,
+gtrack-ne,3592,udp,LOCANIS G-TRACK NE Port,[Juergen_Edelhaeuser],[Juergen_Edelhaeuser],2002-08,,,,,
+bpmd,3593,tcp,BP Model Debugger,[Keith_Fligg],[Keith_Fligg],2002-09,,,,,
+bpmd,3593,udp,BP Model Debugger,[Keith_Fligg],[Keith_Fligg],2002-09,,,,,
+mediaspace,3594,tcp,MediaSpace,,,,,,,,
+mediaspace,3594,udp,MediaSpace,,,,,,,,
+shareapp,3595,tcp,ShareApp,[Jeff_King],[Jeff_King],2002-09,,,,,
+shareapp,3595,udp,ShareApp,[Jeff_King],[Jeff_King],2002-09,,,,,
+iw-mmogame,3596,tcp,Illusion Wireless MMOG,[Jan_Vrsinsky],[Jan_Vrsinsky],2002-09,,,,,
+iw-mmogame,3596,udp,Illusion Wireless MMOG,[Jan_Vrsinsky],[Jan_Vrsinsky],2002-09,,,,,
+a14,3597,tcp,A14 (AN-to-SC/MM),,,,,,,,
+a14,3597,udp,A14 (AN-to-SC/MM),,,,,,,,
+a15,3598,tcp,A15 (AN-to-AN),[David_Ott],[David_Ott],2002-09,,,,,
+a15,3598,udp,A15 (AN-to-AN),[David_Ott],[David_Ott],2002-09,,,,,
+quasar-server,3599,tcp,Quasar Accounting Server,[Brad_Pepers],[Brad_Pepers],2002-09,,,,,
+quasar-server,3599,udp,Quasar Accounting Server,[Brad_Pepers],[Brad_Pepers],2002-09,,,,,
+trap-daemon,3600,tcp,text relay-answer,[John_Willis],[John_Willis],2002-09,,,,,
+trap-daemon,3600,udp,text relay-answer,[John_Willis],[John_Willis],2002-09,,,,,
+visinet-gui,3601,tcp,Visinet Gui,[Jeff_Douglass],[Jeff_Douglass],2002-09,,,,,
+visinet-gui,3601,udp,Visinet Gui,[Jeff_Douglass],[Jeff_Douglass],2002-09,,,,,
+infiniswitchcl,3602,tcp,InfiniSwitch Mgr Client,[Lee_VanTine],[Lee_VanTine],2002-09,,,,,
+infiniswitchcl,3602,udp,InfiniSwitch Mgr Client,[Lee_VanTine],[Lee_VanTine],2002-09,,,,,
+int-rcv-cntrl,3603,tcp,Integrated Rcvr Control,[Dave_Stone],[Dave_Stone],2002-09,,,,,
+int-rcv-cntrl,3603,udp,Integrated Rcvr Control,[Dave_Stone],[Dave_Stone],2002-09,,,,,
+bmc-jmx-port,3604,tcp,BMC JMX Port,[Portnoy_Boxman],[Portnoy_Boxman],2002-09,,,,,
+bmc-jmx-port,3604,udp,BMC JMX Port,[Portnoy_Boxman],[Portnoy_Boxman],2002-09,,,,,
+comcam-io,3605,tcp,ComCam IO Port,[Don_Gilbreath],[Don_Gilbreath],2002-09,,,,,
+comcam-io,3605,udp,ComCam IO Port,[Don_Gilbreath],[Don_Gilbreath],2002-09,,,,,
+splitlock,3606,tcp,Splitlock Server,[Andrew_Tune],[Andrew_Tune],2002-09,,,,,
+splitlock,3606,udp,Splitlock Server,[Andrew_Tune],[Andrew_Tune],2002-09,,,,,
+precise-i3,3607,tcp,Precise I3,[Tomer_Shain],[Tomer_Shain],2002-09,,,,,
+precise-i3,3607,udp,Precise I3,[Tomer_Shain],[Tomer_Shain],2002-09,,,,,
+trendchip-dcp,3608,tcp,Trendchip control protocol,[Ming_Jen_Chen],[Ming_Jen_Chen],2002-09,,,,,
+trendchip-dcp,3608,udp,Trendchip control protocol,[Ming_Jen_Chen],[Ming_Jen_Chen],2002-09,,,,,
+cpdi-pidas-cm,3609,tcp,CPDI PIDAS Connection Mon,[Tony_Splaver],[Tony_Splaver],2002-09,,,,,
+cpdi-pidas-cm,3609,udp,CPDI PIDAS Connection Mon,[Tony_Splaver],[Tony_Splaver],2002-09,,,,,
+echonet,3610,tcp,ECHONET,[Takeshi_Saito],[Takeshi_Saito],2002-09,,,,,
+echonet,3610,udp,ECHONET,[Takeshi_Saito],[Takeshi_Saito],2002-09,,,,,
+six-degrees,3611,tcp,Six Degrees Port,[Zach_Nies],[Zach_Nies],2002-09,,,,,
+six-degrees,3611,udp,Six Degrees Port,[Zach_Nies],[Zach_Nies],2002-09,,,,,
+hp-dataprotect,3612,tcp,HP Data Protector,[Hewlett_Packard_2],[Oliver_Breyel],2002-09,2013-02-07,,,,
+hp-dataprotect,3612,udp,HP Data Protector,[Hewlett_Packard_2],[Oliver_Breyel],2002-09,2013-02-07,,,,
+alaris-disc,3613,tcp,Alaris Device Discovery,[Chris_Dern],[Chris_Dern],2004-06,,,,,
+alaris-disc,3613,udp,Alaris Device Discovery,[Chris_Dern],[Chris_Dern],2004-06,,,,,
+sigma-port,3614,tcp,Satchwell Sigma,[Dave_Chapman],[Dave_Chapman],2011-06-06,,,,,
+sigma-port,3614,udp,Satchwell Sigma,[Dave_Chapman],[Dave_Chapman],2011-06-06,,,,,
+start-network,3615,tcp,Start Messaging Network,[Peter_Rocca],[Peter_Rocca],2002-10,,,,,
+start-network,3615,udp,Start Messaging Network,[Peter_Rocca],[Peter_Rocca],2002-10,,,,,
+cd3o-protocol,3616,tcp,cd3o Control Protocol,[Chris_Wilcox],[Chris_Wilcox],2002-10,,,,,
+cd3o-protocol,3616,udp,cd3o Control Protocol,[Chris_Wilcox],[Chris_Wilcox],2002-10,,,,,
+sharp-server,3617,tcp,ATI SHARP Logic Engine,[Bill_Reveile],[Bill_Reveile],,,,,,
+sharp-server,3617,udp,ATI SHARP Logic Engine,[Bill_Reveile],[Bill_Reveile],,,,,,
+aairnet-1,3618,tcp,AAIR-Network 1,,,,,,,,
+aairnet-1,3618,udp,AAIR-Network 1,,,,,,,,
+aairnet-2,3619,tcp,AAIR-Network 2,[James_Mealey],[James_Mealey],2002-10,,,,,
+aairnet-2,3619,udp,AAIR-Network 2,[James_Mealey],[James_Mealey],2002-10,,,,,
+ep-pcp,3620,tcp,EPSON Projector Control Port,,,,,,,,
+ep-pcp,3620,udp,EPSON Projector Control Port,,,,,,,,
+ep-nsp,3621,tcp,EPSON Network Screen Port,[SEIKO_EPSON_3],[SEIKO_EPSON_3],2002-10,,,,,
+ep-nsp,3621,udp,EPSON Network Screen Port,[SEIKO_EPSON_3],[SEIKO_EPSON_3],2002-10,,,,,
+ff-lr-port,3622,tcp,FF LAN Redundancy Port,[Fieldbus_Foundation],[Fieldbus_Foundation],2002-10,,,,,
+ff-lr-port,3622,udp,FF LAN Redundancy Port,[Fieldbus_Foundation],[Fieldbus_Foundation],2002-10,,,,,
+haipe-discover,3623,tcp,HAIPIS Dynamic Discovery,[Mike_Irani],[Mike_Irani],2002-10,,,,,
+haipe-discover,3623,udp,HAIPIS Dynamic Discovery,[Mike_Irani],[Mike_Irani],2002-10,,,,,
+dist-upgrade,3624,tcp,Distributed Upgrade Port,[Jason_Schoon],[Jason_Schoon],2002-10,,,,,
+dist-upgrade,3624,udp,Distributed Upgrade Port,[Jason_Schoon],[Jason_Schoon],2002-10,,,,,
+volley,3625,tcp,Volley,[David_Catmull],[David_Catmull],2002-10,,,,,
+volley,3625,udp,Volley,[David_Catmull],[David_Catmull],2002-10,,,,,
+bvcdaemon-port,3626,tcp,bvControl Daemon,[Ravi_Gokhale],[Ravi_Gokhale],2002-10,,,,,
+bvcdaemon-port,3626,udp,bvControl Daemon,[Ravi_Gokhale],[Ravi_Gokhale],2002-10,,,,,
+jamserverport,3627,tcp,Jam Server Port,[Art_Pope],[Art_Pope],2002-10,,,,,
+jamserverport,3627,udp,Jam Server Port,[Art_Pope],[Art_Pope],2002-10,,,,,
+ept-machine,3628,tcp,EPT Machine Interface,[Victor_H_Farrace],[Victor_H_Farrace],2002-10,,,,,
+ept-machine,3628,udp,EPT Machine Interface,[Victor_H_Farrace],[Victor_H_Farrace],2002-10,,,,,
+escvpnet,3629,tcp,ESC/VP.net,[Hiroyuki_Hashimoto],[Hiroyuki_Hashimoto],2002-10,,,,,
+escvpnet,3629,udp,ESC/VP.net,[Hiroyuki_Hashimoto],[Hiroyuki_Hashimoto],2002-10,,,,,
+cs-remote-db,3630,tcp,C&S Remote Database Port,,,,,,,,
+cs-remote-db,3630,udp,C&S Remote Database Port,,,,,,,,
+cs-services,3631,tcp,C&S Web Services Port,[Computer_Software_Gm],[Computer_Software_Gm],2002-10,,,,,
+cs-services,3631,udp,C&S Web Services Port,[Computer_Software_Gm],[Computer_Software_Gm],2002-10,,,,,
+distcc,3632,tcp,distributed compiler,[Martin_Pool],[Martin_Pool],2002-11,,,,,Defined TXT keys: None
+distcc,3632,udp,distributed compiler,[Martin_Pool],[Martin_Pool],2002-11,,,,,Defined TXT keys: None
+wacp,3633,tcp,Wyrnix AIS port,[Harry_T_Vennik],[Harry_T_Vennik],2002-11,,,,,
+wacp,3633,udp,Wyrnix AIS port,[Harry_T_Vennik],[Harry_T_Vennik],2002-11,,,,,
+hlibmgr,3634,tcp,hNTSP Library Manager,[Kenji_Tetsuyama],[Kenji_Tetsuyama],2002-11,,,,,
+hlibmgr,3634,udp,hNTSP Library Manager,[Kenji_Tetsuyama],[Kenji_Tetsuyama],2002-11,,,,,
+sdo,3635,tcp,Simple Distributed Objects,[Alexander_Philippou],[Alexander_Philippou],2002-11,,,,,
+sdo,3635,udp,Simple Distributed Objects,[Alexander_Philippou],[Alexander_Philippou],2002-11,,,,,
+servistaitsm,3636,tcp,SerVistaITSM,[Ralph_Campbell],[Ralph_Campbell],2002-11,,,,,
+servistaitsm,3636,udp,SerVistaITSM,[Ralph_Campbell],[Ralph_Campbell],2002-11,,,,,
+scservp,3637,tcp,Customer Service Port,[Jonathan_A_Zdziarsk],[Jonathan_A_Zdziarsk],2002-11,,,,,
+scservp,3637,udp,Customer Service Port,[Jonathan_A_Zdziarsk],[Jonathan_A_Zdziarsk],2002-11,,,,,
+ehp-backup,3638,tcp,EHP Backup Protocol,[Ed_Fair],[Ed_Fair],2002-11,,,,,
+ehp-backup,3638,udp,EHP Backup Protocol,[Ed_Fair],[Ed_Fair],2002-11,,,,,
+xap-ha,3639,tcp,Extensible Automation,[Mark_Harrison],[Mark_Harrison],2002-11,,,,,
+xap-ha,3639,udp,Extensible Automation,[Mark_Harrison],[Mark_Harrison],2002-11,,,,,
+netplay-port1,3640,tcp,Netplay Port 1,,,,,,,,
+netplay-port1,3640,udp,Netplay Port 1,,,,,,,,
+netplay-port2,3641,tcp,Netplay Port 2,[Predrag_Filipovic],[Predrag_Filipovic],2002-11,,,,,
+netplay-port2,3641,udp,Netplay Port 2,[Predrag_Filipovic],[Predrag_Filipovic],2002-11,,,,,
+juxml-port,3642,tcp,Juxml Replication port,[Colin_Reid],[Colin_Reid],2002-11,,,,,
+juxml-port,3642,udp,Juxml Replication port,[Colin_Reid],[Colin_Reid],2002-11,,,,,
+audiojuggler,3643,tcp,AudioJuggler,[Morten_Mertner],[Morten_Mertner],2002-11,,,,,
+audiojuggler,3643,udp,AudioJuggler,[Morten_Mertner],[Morten_Mertner],2002-11,,,,,
+ssowatch,3644,tcp,ssowatch,[Marie_France_Dubreui],[Marie_France_Dubreui],2002-11,,,,,
+ssowatch,3644,udp,ssowatch,[Marie_France_Dubreui],[Marie_France_Dubreui],2002-11,,,,,
+cyc,3645,tcp,Cyc,[Stephen_Reed],[Stephen_Reed],2003-01,,,,,
+cyc,3645,udp,Cyc,[Stephen_Reed],[Stephen_Reed],2003-01,,,,,
+xss-srv-port,3646,tcp,XSS Server Port,[Joe_Purcell],[Joe_Purcell],2003-01,,,,,
+xss-srv-port,3646,udp,XSS Server Port,[Joe_Purcell],[Joe_Purcell],2003-01,,,,,
+splitlock-gw,3647,tcp,Splitlock Gateway,[Andrew_Tune],[Andrew_Tune],2003-01,,,,,
+splitlock-gw,3647,udp,Splitlock Gateway,[Andrew_Tune],[Andrew_Tune],2003-01,,,,,
+fjcp,3648,tcp,Fujitsu Cooperation Port,[Kouji_Sugisawa],[Kouji_Sugisawa],2003-01,,,,,
+fjcp,3648,udp,Fujitsu Cooperation Port,[Kouji_Sugisawa],[Kouji_Sugisawa],2003-01,,,,,
+nmmp,3649,tcp,Nishioka Miyuki Msg Protocol,[TAKEDA_Hiroyuki],[TAKEDA_Hiroyuki],2003-01,,,,,
+nmmp,3649,udp,Nishioka Miyuki Msg Protocol,[TAKEDA_Hiroyuki],[TAKEDA_Hiroyuki],2003-01,,,,,
+prismiq-plugin,3650,tcp,PRISMIQ VOD plug-in,[Richard_Hodges_3],[Richard_Hodges_3],2003-01,,,,,
+prismiq-plugin,3650,udp,PRISMIQ VOD plug-in,[Richard_Hodges_3],[Richard_Hodges_3],2003-01,,,,,
+xrpc-registry,3651,tcp,XRPC Registry,[Slava_Monich],[Slava_Monich],2003-01,,,,,
+xrpc-registry,3651,udp,XRPC Registry,[Slava_Monich],[Slava_Monich],2003-01,,,,,
+vxcrnbuport,3652,tcp,VxCR NBU Default Port,[Boris_Star],[Boris_Star],2003-01,,,,,
+vxcrnbuport,3652,udp,VxCR NBU Default Port,[Boris_Star],[Boris_Star],2003-01,,,,,
+tsp,3653,tcp,Tunnel Setup Protocol,[Marc_Blanchet],[Marc_Blanchet],2003-01,,[RFC5572],,,
+tsp,3653,udp,Tunnel Setup Protocol,[Marc_Blanchet],[Marc_Blanchet],2003-01,,[RFC5572],,,
+vaprtm,3654,tcp,VAP RealTime Messenger,[Boris_Polevoy],[Boris_Polevoy],2003-01,,,,,
+vaprtm,3654,udp,VAP RealTime Messenger,[Boris_Polevoy],[Boris_Polevoy],2003-01,,,,,
+abatemgr,3655,tcp,ActiveBatch Exec Agent,,,,,,,,
+abatemgr,3655,udp,ActiveBatch Exec Agent,,,,,,,,
+abatjss,3656,tcp,ActiveBatch Job Scheduler,[Ben_Rosenberg],[Ben_Rosenberg],2003-01,,,,,
+abatjss,3656,udp,ActiveBatch Job Scheduler,[Ben_Rosenberg],[Ben_Rosenberg],2003-01,,,,,
+immedianet-bcn,3657,tcp,ImmediaNet Beacon,[Bill_Homan],[Bill_Homan],2003-01,,,,,
+immedianet-bcn,3657,udp,ImmediaNet Beacon,[Bill_Homan],[Bill_Homan],2003-01,,,,,
+ps-ams,3658,tcp,PlayStation AMS (Secure),[Edgar_Alan_Tu],[Edgar_Alan_Tu],2003-01,,,,,
+ps-ams,3658,udp,PlayStation AMS (Secure),[Edgar_Alan_Tu],[Edgar_Alan_Tu],2003-01,,,,,
+apple-sasl,3659,tcp,Apple SASL,[David_M_O_Rourke],[David_M_O_Rourke],2003-01,,,,,
+apple-sasl,3659,udp,Apple SASL,[David_M_O_Rourke],[David_M_O_Rourke],2003-01,,,,,
+can-nds-ssl,3660,tcp,IBM Tivoli Directory Service using SSL,,,,,,,,
+can-nds-ssl,3660,udp,IBM Tivoli Directory Service using SSL,,,,,,,,
+can-ferret-ssl,3661,tcp,IBM Tivoli Directory Service using SSL,[Nic_Catrambone],[Nic_Catrambone],2003-01,,,,,
+can-ferret-ssl,3661,udp,IBM Tivoli Directory Service using SSL,[Nic_Catrambone],[Nic_Catrambone],2003-01,,,,,
+pserver,3662,tcp,pserver,[Patrick_Furlong],[Patrick_Furlong],2003-01,,,,,
+pserver,3662,udp,pserver,[Patrick_Furlong],[Patrick_Furlong],2003-01,,,,,
+dtp,3663,tcp,DIRECWAY Tunnel Protocol,[John_Border],[John_Border],2003-01,,,,,
+dtp,3663,udp,DIRECWAY Tunnel Protocol,[John_Border],[John_Border],2003-01,,,,,
+ups-engine,3664,tcp,UPS Engine Port,,,,,,,,
+ups-engine,3664,udp,UPS Engine Port,,,,,,,,
+ent-engine,3665,tcp,Enterprise Engine Port,[Mike_Delgrosso],[Mike_Delgrosso],2003-01,,,,,
+ent-engine,3665,udp,Enterprise Engine Port,[Mike_Delgrosso],[Mike_Delgrosso],2003-01,,,,,
+eserver-pap,3666,tcp,IBM eServer PAP,[Dave_Gimpl],[Dave_Gimpl],2003-01,,,,,
+eserver-pap,3666,udp,IBM EServer PAP,[Dave_Gimpl],[Dave_Gimpl],2003-01,,,,,
+infoexch,3667,tcp,IBM Information Exchange,[Paul_Ford_Hutchinson],[Paul_Ford_Hutchinson],2003-01,,,,,
+infoexch,3667,udp,IBM Information Exchange,[Paul_Ford_Hutchinson],[Paul_Ford_Hutchinson],2003-01,,,,,
+dell-rm-port,3668,tcp,Dell Remote Management,[Bradley_Bransom],[Bradley_Bransom],2003-01,,,,,
+dell-rm-port,3668,udp,Dell Remote Management,[Bradley_Bransom],[Bradley_Bransom],2003-01,,,,,
+casanswmgmt,3669,tcp,CA SAN Switch Management,[Emre_Tunar],[Emre_Tunar],2003-01,,,,,
+casanswmgmt,3669,udp,CA SAN Switch Management,[Emre_Tunar],[Emre_Tunar],2003-01,,,,,
+smile,3670,tcp,SMILE TCP/UDP Interface,[Andre_Petras],[Andre_Petras],2003-01,,,,,
+smile,3670,udp,SMILE TCP/UDP Interface,[Andre_Petras],[Andre_Petras],2003-01,,,,,
+efcp,3671,tcp,e Field Control (EIBnet),[Marc_Goossens],[Marc_Goossens],2003-01,,,,,
+efcp,3671,udp,e Field Control (EIBnet),[Marc_Goossens],[Marc_Goossens],2003-01,,,,,
+lispworks-orb,3672,tcp,LispWorks ORB,[Lisp_Support],[Lisp_Support],,,,,,
+lispworks-orb,3672,udp,LispWorks ORB,[Lisp_Support],[Lisp_Support],,,,,,
+mediavault-gui,3673,tcp,Openview Media Vault GUI,[Stephen_Gold],[Stephen_Gold],2003-01,,,,,
+mediavault-gui,3673,udp,Openview Media Vault GUI,[Stephen_Gold],[Stephen_Gold],2003-01,,,,,
+wininstall-ipc,3674,tcp,WinINSTALL IPC Port,[Bill_Somerville],[Bill_Somerville],2008-08-13,,,,,
+wininstall-ipc,3674,udp,WinINSTALL IPC Port,[Bill_Somerville],[Bill_Somerville],2008-08-13,,,,,
+calltrax,3675,tcp,CallTrax Data Port,[Oliver_Bailey],[Oliver_Bailey],2003-01,,,,,
+calltrax,3675,udp,CallTrax Data Port,[Oliver_Bailey],[Oliver_Bailey],2003-01,,,,,
+va-pacbase,3676,tcp,VisualAge Pacbase server,[Dominique_Lelievre],[Dominique_Lelievre],2003-01,,,,,
+va-pacbase,3676,udp,VisualAge Pacbase server,[Dominique_Lelievre],[Dominique_Lelievre],2003-01,,,,,
+roverlog,3677,tcp,RoverLog IPC,[Tom_Mayo],[Tom_Mayo],2003-01,,,,,
+roverlog,3677,udp,RoverLog IPC,[Tom_Mayo],[Tom_Mayo],2003-01,,,,,
+ipr-dglt,3678,tcp,DataGuardianLT,[Bruce_Carlson],[Bruce_Carlson],2003-01,,,,,
+ipr-dglt,3678,udp,DataGuardianLT,[Bruce_Carlson],[Bruce_Carlson],2003-01,,,,,
+Escale (Newton Dock),3679,tcp,Newton Dock,[Paul_Guyot],[Paul_Guyot],,2011-11-09,,,,
+Escale (Newton Dock),3679,udp,Newton Dock,[Paul_Guyot],[Paul_Guyot],,2011-11-09,,,,
+npds-tracker,3680,tcp,NPDS Tracker,[Paul_Guyot],[Paul_Guyot],2003-01,,,,,
+npds-tracker,3680,udp,NPDS Tracker,[Paul_Guyot],[Paul_Guyot],2003-01,,,,,
+bts-x73,3681,tcp,BTS X73 Port,[Todd_Cooper],[Todd_Cooper],2003-01,,,,,
+bts-x73,3681,udp,BTS X73 Port,[Todd_Cooper],[Todd_Cooper],2003-01,,,,,
+cas-mapi,3682,tcp,EMC SmartPackets-MAPI,[Koen_Schoofs],[Koen_Schoofs],2003-01,,,,,
+cas-mapi,3682,udp,EMC SmartPackets-MAPI,[Koen_Schoofs],[Koen_Schoofs],2003-01,,,,,
+bmc-ea,3683,tcp,BMC EDV/EA,[Portnoy_Boxman],[Portnoy_Boxman],2003-01,,,,,
+bmc-ea,3683,udp,BMC EDV/EA,[Portnoy_Boxman],[Portnoy_Boxman],2003-01,,,,,
+faxstfx-port,3684,tcp,FAXstfX,[Alec_Carlson],[Alec_Carlson],2003-01,,,,,
+faxstfx-port,3684,udp,FAXstfX,[Alec_Carlson],[Alec_Carlson],2003-01,,,,,
+dsx-agent,3685,tcp,DS Expert Agent,[Jason_Lockett][Melanie_Kacerek],[Jason_Lockett][Melanie_Kacerek],2008-12-16,,,,,
+dsx-agent,3685,udp,DS Expert Agent,[Jason_Lockett][Melanie_Kacerek],[Jason_Lockett][Melanie_Kacerek],2008-12-16,,,,,
+tnmpv2,3686,tcp,Trivial Network Management,[Andrea_Premoli],[Andrea_Premoli],2003-01,,,,,
+tnmpv2,3686,udp,Trivial Network Management,[Andrea_Premoli],[Andrea_Premoli],2003-01,,,,,
+simple-push,3687,tcp,simple-push,,,,,,,,
+simple-push,3687,udp,simple-push,,,,,,,,
+simple-push-s,3688,tcp,simple-push Secure,[C_Enrique_Ortiz],[C_Enrique_Ortiz],2003-01,,,,,
+simple-push-s,3688,udp,simple-push Secure,[C_Enrique_Ortiz],[C_Enrique_Ortiz],2003-01,,,,,
+daap,3689,tcp,Digital Audio Access Protocol (iTunes),[Amandeep_Jawa],[Amandeep_Jawa],2003-01,,,,,"Defined TXT keys: txtvers, Version, iTSh Version, Machine ID, Database ID, Machine Name, Password"
+daap,3689,udp,Digital Audio Access Protocol (iTunes),[Amandeep_Jawa],[Amandeep_Jawa],2003-01,,,,,"Defined TXT keys: txtvers, Version, iTSh Version, Machine ID, Database ID, Machine Name, Password"
+svn,3690,tcp,Subversion,[Greg_Hudson_2],[Greg_Hudson_2],2003-01,,,,,
+svn,3690,udp,Subversion,[Greg_Hudson_2],[Greg_Hudson_2],2003-01,,,,,
+magaya-network,3691,tcp,Magaya Network Port,[Jesus_David_Rodrigue],[Jesus_David_Rodrigue],2003-02,,,,,
+magaya-network,3691,udp,Magaya Network Port,[Jesus_David_Rodrigue],[Jesus_David_Rodrigue],2003-02,,,,,
+intelsync,3692,tcp,Brimstone IntelSync,[Davey_Taylor],[Davey_Taylor],2003-02,,,,,
+intelsync,3692,udp,Brimstone IntelSync,[Davey_Taylor],[Davey_Taylor],2003-02,,,,,
+,3693-3694,,Unassigned,,,,2007-04-05,,,,
+bmc-data-coll,3695,tcp,BMC Data Collection,[Portnoy_Boxman],[Portnoy_Boxman],2003-02,,,,,
+bmc-data-coll,3695,udp,BMC Data Collection,[Portnoy_Boxman],[Portnoy_Boxman],2003-02,,,,,
+telnetcpcd,3696,tcp,Telnet Com Port Control,[Thomas_J_Pinkl],[Thomas_J_Pinkl],2003-02,,,,,
+telnetcpcd,3696,udp,Telnet Com Port Control,[Thomas_J_Pinkl],[Thomas_J_Pinkl],2003-02,,,,,
+nw-license,3697,tcp,NavisWorks License System,[Tim_Wiegand],[Tim_Wiegand],2003-02,,,,,
+nw-license,3697,udp,NavisWorks Licnese System,[Tim_Wiegand],[Tim_Wiegand],2003-02,,,,,
+sagectlpanel,3698,tcp,SAGECTLPANEL,[Mark_Gamble],[Mark_Gamble],2003-02,,,,,
+sagectlpanel,3698,udp,SAGECTLPANEL,[Mark_Gamble],[Mark_Gamble],2003-02,,,,,
+kpn-icw,3699,tcp,Internet Call Waiting,[B_J_Kortekaas],[B_J_Kortekaas],2003-02,,,,,
+kpn-icw,3699,udp,Internet Call Waiting,[B_J_Kortekaas],[B_J_Kortekaas],2003-02,,,,,
+lrs-paging,3700,tcp,LRS NetPage,[Geoffrey_Wossum],[Geoffrey_Wossum],2003-02,,,,,
+lrs-paging,3700,udp,LRS NetPage,[Geoffrey_Wossum],[Geoffrey_Wossum],2003-02,,,,,
+netcelera,3701,tcp,NetCelera,[Tarek_Nabhan],[Tarek_Nabhan],2003-02,,,,,
+netcelera,3701,udp,NetCelera,[Tarek_Nabhan],[Tarek_Nabhan],2003-02,,,,,
+ws-discovery,3702,tcp,Web Service Discovery,[Christian_Huitema_2],[Christian_Huitema_2],2003-02,,,,,
+ws-discovery,3702,udp,Web Service Discovery,[Christian_Huitema_2],[Christian_Huitema_2],2003-02,,,,,
+adobeserver-3,3703,tcp,Adobe Server 3,,,,,,,,
+adobeserver-3,3703,udp,Adobe Server 3,,,,,,,,
+adobeserver-4,3704,tcp,Adobe Server 4,[Frank_Soetebeer],[Frank_Soetebeer],2003-01,,,,,
+adobeserver-4,3704,udp,Adobe Server 4,[Frank_Soetebeer],[Frank_Soetebeer],2003-01,,,,,
+adobeserver-5,3705,tcp,Adobe Server 5,[Bernd_Paradies],[Bernd_Paradies],2008-01-14,,,,,
+adobeserver-5,3705,udp,Adobe Server 5,[Bernd_Paradies],[Bernd_Paradies],2008-01-14,,,,,
+rt-event,3706,tcp,Real-Time Event Port,,,,,,,,
+rt-event,3706,udp,Real-Time Event Port,,,,,,,,
+rt-event-s,3707,tcp,Real-Time Event Secure Port,[Terry_Gin],[Terry_Gin],2003-02,,,,,
+rt-event-s,3707,udp,Real-Time Event Secure Port,[Terry_Gin],[Terry_Gin],2003-02,,,,,
+sun-as-iiops,3708,tcp,Sun App Svr - Naming,[Abhijit_Kumar],[Abhijit_Kumar],2005-11,,,,,
+sun-as-iiops,3708,udp,Sun App Svr - Naming,[Abhijit_Kumar],[Abhijit_Kumar],2005-11,,,,,
+ca-idms,3709,tcp,CA-IDMS Server,[Dave_Ross],[Dave_Ross],,,,,,
+ca-idms,3709,udp,CA-IDMS Server,[Dave_Ross],[Dave_Ross],,,,,,
+portgate-auth,3710,tcp,PortGate Authentication,[Scott_Harris],[Scott_Harris],2003-02,,,,,
+portgate-auth,3710,udp,PortGate Authentication,[Scott_Harris],[Scott_Harris],2003-02,,,,,
+edb-server2,3711,tcp,EBD Server 2,[Carlos_Portela],[Carlos_Portela],2003-02,,,,,
+edb-server2,3711,udp,EBD Server 2,[Carlos_Portela],[Carlos_Portela],2003-02,,,,,
+sentinel-ent,3712,tcp,Sentinel Enterprise,[Ian_Gordon_2],[Ian_Gordon_2],2003-03,,,,,
+sentinel-ent,3712,udp,Sentinel Enterprise,[Ian_Gordon_2],[Ian_Gordon_2],2003-03,,,,,
+tftps,3713,tcp,TFTP over TLS,[Mark_mayernick],[Mark_mayernick],2003-03,,,,,
+tftps,3713,udp,TFTP over TLS,[Mark_mayernick],[Mark_mayernick],2003-03,,,,,
+delos-dms,3714,tcp,DELOS Direct Messaging,[Ekkehard_Morgenstern],[Ekkehard_Morgenstern],2003-03,,,,,
+delos-dms,3714,udp,DELOS Direct Messaging,[Ekkehard_Morgenstern],[Ekkehard_Morgenstern],2003-03,,,,,
+anoto-rendezv,3715,tcp,Anoto Rendezvous Port,[Ola_Sandstrom],[Ola_Sandstrom],2003-03,,,,,
+anoto-rendezv,3715,udp,Anoto Rendezvous Port,[Ola_Sandstrom],[Ola_Sandstrom],2003-03,,,,,
+wv-csp-sms-cir,3716,tcp,WV CSP SMS CIR Channel,,,,,,,,
+wv-csp-sms-cir,3716,udp,WV CSP SMS CIR Channel,,,,,,,,
+wv-csp-udp-cir,3717,tcp,WV CSP UDP/IP CIR Channel,[Jon_Ingi_Ingimundars],[Jon_Ingi_Ingimundars],2003-03,,,,,
+wv-csp-udp-cir,3717,udp,WV CSP UDP/IP CIR Channel,[Jon_Ingi_Ingimundars],[Jon_Ingi_Ingimundars],2003-03,,,,,
+opus-services,3718,tcp,OPUS Server Port,[Detlef_Stoever],[Detlef_Stoever],2003-03,,,,,
+opus-services,3718,udp,OPUS Server Port,[Detlef_Stoever],[Detlef_Stoever],2003-03,,,,,
+itelserverport,3719,tcp,iTel Server Port,[Mark_Hendricks],[Mark_Hendricks],2003-03,,,,,
+itelserverport,3719,udp,iTel Server Port,[Mark_Hendricks],[Mark_Hendricks],2003-03,,,,,
+ufastro-instr,3720,tcp,UF Astro. Instr. Services,[David_B_Hon],[David_B_Hon],2003-03,,,,,
+ufastro-instr,3720,udp,UF Astro. Instr. Services,[David_B_Hon],[David_B_Hon],2003-03,,,,,
+xsync,3721,tcp,Xsync,,,,,,,,
+xsync,3721,udp,Xsync,,,,,,,,
+xserveraid,3722,tcp,Xserve RAID,[Bob_Bradley],[Bob_Bradley],2003-03,,,,,
+xserveraid,3722,udp,Xserve RAID,[Bob_Bradley],[Bob_Bradley],2003-03,,,,,
+sychrond,3723,tcp,Sychron Service Daemon,[Robert_Marinelli],[Robert_Marinelli],2003-03,,,,,
+sychrond,3723,udp,Sychron Service Daemon,[Robert_Marinelli],[Robert_Marinelli],2003-03,,,,,
+blizwow,3724,tcp,World of Warcraft,[Domain_Tech],[Domain_Tech],2005-04,,,,,
+blizwow,3724,udp,World of Warcraft,[Domain_Tech],[Domain_Tech],2005-04,,,,,
+na-er-tip,3725,tcp,Netia NA-ER Port,[Jean_Pierre_Garcia],[Jean_Pierre_Garcia],2003-04,,,,,
+na-er-tip,3725,udp,Netia NA-ER Port,[Jean_Pierre_Garcia],[Jean_Pierre_Garcia],2003-04,,,,,
+array-manager,3726,tcp,Xyratex Array Manager,[David_A_Lethe],[David_A_Lethe],2003-04,,,,,
+array-manager,3726,udp,Xyartex Array Manager,[David_A_Lethe],[David_A_Lethe],2003-04,,,,,
+e-mdu,3727,tcp,Ericsson Mobile Data Unit,,,,,,,,
+e-mdu,3727,udp,Ericsson Mobile Data Unit,,,,,,,,
+e-woa,3728,tcp,Ericsson Web on Air,[Marco_Casole],[Marco_Casole],2003-04,,,,,
+e-woa,3728,udp,Ericsson Web on Air,[Marco_Casole],[Marco_Casole],2003-04,,,,,
+fksp-audit,3729,tcp,Fireking Audit Port,[Richard_Thurman],[Richard_Thurman],2003-04,,,,,
+fksp-audit,3729,udp,Fireking Audit Port,[Richard_Thurman],[Richard_Thurman],2003-04,,,,,
+client-ctrl,3730,tcp,Client Control,[Lawrence_W_Dunn],[Lawrence_W_Dunn],2003-04,,,,,
+client-ctrl,3730,udp,Client Control,[Lawrence_W_Dunn],[Lawrence_W_Dunn],2003-04,,,,,
+smap,3731,tcp,Service Manager,,,,,,,,
+smap,3731,udp,Service Manager,,,,,,,,
+m-wnn,3732,tcp,Mobile Wnn,[Yasunari_Yamashita],[Yasunari_Yamashita],2003-04,,,,,
+m-wnn,3732,udp,Mobile Wnn,[Yasunari_Yamashita],[Yasunari_Yamashita],2003-04,,,,,
+multip-msg,3733,tcp,Multipuesto Msg Port,[Felisa_Ares],[Felisa_Ares],2003-04,,,,,
+multip-msg,3733,udp,Multipuesto Msg Port,[Felisa_Ares],[Felisa_Ares],2003-04,,,,,
+synel-data,3734,tcp,Synel Data Collection Port,[David_Ashkenazi],[David_Ashkenazi],2003-04,,,,,
+synel-data,3734,udp,Synel Data Collection Port,[David_Ashkenazi],[David_Ashkenazi],2003-04,,,,,
+pwdis,3735,tcp,Password Distribution,[Robert_Erl],[Robert_Erl],2003-04,,,,,
+pwdis,3735,udp,Password Distribution,[Robert_Erl],[Robert_Erl],2003-04,,,,,
+rs-rmi,3736,tcp,RealSpace RMI,[Barry_McDarby],[Barry_McDarby],2003-04,,,,,
+rs-rmi,3736,udp,RealSpace RMI,[Barry_McDarby],[Barry_McDarby],2003-04,,,,,
+xpanel,3737,tcp,XPanel Daemon,[Lilian_Rudenco],[Lilian_Rudenco],2009-03-04,,,,,
+,3737,udp,Reserved,,,,,,,,
+versatalk,3738,tcp,versaTalk Server Port,[Dr_Kingsley_C_Nwos],[Dr_Kingsley_C_Nwos],2003-04,,,,,
+versatalk,3738,udp,versaTalk Server Port,[Dr_Kingsley_C_Nwos],[Dr_Kingsley_C_Nwos],2003-04,,,,,
+launchbird-lm,3739,tcp,Launchbird LicenseManager,[Tom_Hawkins],[Tom_Hawkins],2003-04,,,,,
+launchbird-lm,3739,udp,Launchbird LicenseManager,[Tom_Hawkins],[Tom_Hawkins],2003-04,,,,,
+heartbeat,3740,tcp,Heartbeat Protocol,[Jeroen_Massar],[Jeroen_Massar],2003-04,,,,,
+heartbeat,3740,udp,Heartbeat Protocol,[Jeroen_Massar],[Jeroen_Massar],2003-04,,,,,
+wysdma,3741,tcp,WysDM Agent,[Jim_McDonald],[Jim_McDonald],2003-04,,,,,
+wysdma,3741,udp,WysDM Agent,[Jim_McDonald],[Jim_McDonald],2003-04,,,,,
+cst-port,3742,tcp,CST - Configuration & Service Tracker,[Hai_Ou_Yang],[Hai_Ou_Yang],2003-04,,,,,
+cst-port,3742,udp,CST - Configuration & Service Tracker,[Hai_Ou_Yang],[Hai_Ou_Yang],2003-04,,,,,
+ipcs-command,3743,tcp,IP Control Systems Ltd.,[Paul_Anderson],[Paul_Anderson],2003-04,,,,,
+ipcs-command,3743,udp,IP Control Systems Ltd.,[Paul_Anderson],[Paul_Anderson],2003-04,,,,,
+sasg,3744,tcp,SASG,[Cristian_Petculescu_2],[Cristian_Petculescu_2],2003-04,,,,,
+sasg,3744,udp,SASG,[Cristian_Petculescu_2],[Cristian_Petculescu_2],2003-04,,,,,
+gw-call-port,3745,tcp,GWRTC Call Port,[Felisa_Ares],[Felisa_Ares],2003-04,,,,,
+gw-call-port,3745,udp,GWRTC Call Port,[Felisa_Ares],[Felisa_Ares],2003-04,,,,,
+linktest,3746,tcp,LXPRO.COM LinkTest,,,,,,,,
+linktest,3746,udp,LXPRO.COM LinkTest,,,,,,,,
+linktest-s,3747,tcp,LXPRO.COM LinkTest SSL,[Greg_Bailey],[Greg_Bailey],2003-04,,,,,
+linktest-s,3747,udp,LXPRO.COM LinkTest SSL,[Greg_Bailey],[Greg_Bailey],2003-04,,,,,
+webdata,3748,tcp,webData,[Michael_Whiteley],[Michael_Whiteley],2003-04,,,,,
+webdata,3748,udp,webData,[Michael_Whiteley],[Michael_Whiteley],2003-04,,,,,
+cimtrak,3749,tcp,CimTrak,[Robert_E_Johnson_II],[Robert_E_Johnson_II],2003-04,,,,,
+cimtrak,3749,udp,CimTrak,[Robert_E_Johnson_II],[Robert_E_Johnson_II],2003-04,,,,,
+cbos-ip-port,3750,tcp,CBOS/IP ncapsalation port,[Thomas_Dannemiller],[Thomas_Dannemiller],2003-04,,,,,
+cbos-ip-port,3750,udp,CBOS/IP ncapsalatoin port,[Thomas_Dannemiller],[Thomas_Dannemiller],2003-04,,,,,
+gprs-cube,3751,tcp,CommLinx GPRS Cube,[Peter_Johnson],[Peter_Johnson],2003-04,,,,,
+gprs-cube,3751,udp,CommLinx GPRS Cube,[Peter_Johnson],[Peter_Johnson],2003-04,,,,,
+vipremoteagent,3752,tcp,Vigil-IP RemoteAgent,[Bryan_Alvord],[Bryan_Alvord],2003-04,,,,,
+vipremoteagent,3752,udp,Vigil-IP RemoteAgent,[Bryan_Alvord],[Bryan_Alvord],2003-04,,,,,
+nattyserver,3753,tcp,NattyServer Port,[Akira_Saito],[Akira_Saito],2003-04,,,,,
+nattyserver,3753,udp,NattyServer Port,[Akira_Saito],[Akira_Saito],2003-04,,,,,
+timestenbroker,3754,tcp,TimesTen Broker Port,[David_Aspinwall],[David_Aspinwall],2003-04,,,,,
+timestenbroker,3754,udp,TimesTen Broker Port,[David_Aspinwall],[David_Aspinwall],2003-04,,,,,
+sas-remote-hlp,3755,tcp,SAS Remote Help Server,[Gary_T_Ciampa],[Gary_T_Ciampa],2003-04,,,,,
+sas-remote-hlp,3755,udp,SAS Remote Help Server,[Gary_T_Ciampa],[Gary_T_Ciampa],2003-04,,,,,
+canon-capt,3756,tcp,Canon CAPT Port,[Takashi_Okazawa],[Takashi_Okazawa],2003-04,,,,,
+canon-capt,3756,udp,Canon CAPT Port,[Takashi_Okazawa],[Takashi_Okazawa],2003-04,,,,,
+grf-port,3757,tcp,GRF Server Port,[Robert_Banfill],[Robert_Banfill],2003-04,,,,,
+grf-port,3757,udp,GRF Server Port,[Robert_Banfill],[Robert_Banfill],2003-04,,,,,
+apw-registry,3758,tcp,apw RMI registry,[Dan_Davis],[Dan_Davis],2003-04,,,,,
+apw-registry,3758,udp,apw RMI registry,[Dan_Davis],[Dan_Davis],2003-04,,,,,
+exapt-lmgr,3759,tcp,Exapt License Manager,[Christoph_Kukulies],[Christoph_Kukulies],2003-04,,,,,
+exapt-lmgr,3759,udp,Exapt License Manager,[Christoph_Kukulies],[Christoph_Kukulies],2003-04,,,,,
+adtempusclient,3760,tcp,adTempus Client,[Bill_Wingate],[Bill_Wingate],2003-05,,,,,
+adtempusclient,3760,udp,adTEmpus Client,[Bill_Wingate],[Bill_Wingate],2003-05,,,,,
+gsakmp,3761,tcp,gsakmp port,,,,,[RFC4535],,,
+gsakmp,3761,udp,gsakmp port,,,,,[RFC4535],,,
+gbs-smp,3762,tcp,GBS SnapMail Protocol,[Eric_Harris_Braun],[Eric_Harris_Braun],2003-06,,,,,
+gbs-smp,3762,udp,GBS SnapMail Protocol,[Eric_Harris_Braun],[Eric_Harris_Braun],2003-06,,,,,
+xo-wave,3763,tcp,XO Wave Control Port,[Bjorn_Dittmer_Roche],[Bjorn_Dittmer_Roche],2003-06,,,,,
+xo-wave,3763,udp,XO Wave Control Port,[Bjorn_Dittmer_Roche],[Bjorn_Dittmer_Roche],2003-06,,,,,
+mni-prot-rout,3764,tcp,MNI Protected Routing,[Tim_Behne],[Tim_Behne],2003-06,,,,,
+mni-prot-rout,3764,udp,MNI Protected Routing,[Tim_Behne],[Tim_Behne],2003-06,,,,,
+rtraceroute,3765,tcp,Remote Traceroute,[A_Blake_Cooper],[A_Blake_Cooper],2003-06,,,,,
+rtraceroute,3765,udp,Remote Traceroute,[A_Blake_Cooper],[A_Blake_Cooper],2003-06,,,,,
+sitewatch-s,3766,tcp,SSL e-watch sitewatch server,[e-Watch_Corporation],[John_M_Baird_2],2014-05-13,,,,,this port was previously updated on 2009-06-19
+,3766,udp,Reserved,,,,,,,,this port was previously updated on 2009-06-19
+listmgr-port,3767,tcp,ListMGR Port,[Takashi_Kubota],[Takashi_Kubota],2003-06,,,,,
+listmgr-port,3767,udp,ListMGR Port,[Takashi_Kubota],[Takashi_Kubota],2003-06,,,,,
+rblcheckd,3768,tcp,rblcheckd server daemon,[Sabri_Berisha],[Sabri_Berisha],2003-06,,,,,
+rblcheckd,3768,udp,rblcheckd server daemon,[Sabri_Berisha],[Sabri_Berisha],2003-06,,,,,
+haipe-otnk,3769,tcp,HAIPE Network Keying,[Mike_Irani_2],[Mike_Irani_2],2003-06,,,,,
+haipe-otnk,3769,udp,HAIPE Network Keying,[Mike_Irani_2],[Mike_Irani_2],2003-06,,,,,
+cindycollab,3770,tcp,Cinderella Collaboration,[Ulrich_Kortenkamp],[Ulrich_Kortenkamp],2003-06,,,,,
+cindycollab,3770,udp,Cinderella Collaboration,[Ulrich_Kortenkamp],[Ulrich_Kortenkamp],2003-06,,,,,
+paging-port,3771,tcp,RTP Paging Port,[Patrick_Ferriter],[Patrick_Ferriter],2003-06,,,,,
+paging-port,3771,udp,RTP Paging Port,[Patrick_Ferriter],[Patrick_Ferriter],2003-06,,,,,
+ctp,3772,tcp,Chantry Tunnel Protocol,[Inderpreet_Singh],[Inderpreet_Singh],2003-06,,,,,
+ctp,3772,udp,Chantry Tunnel Protocol,[Inderpreet_Singh],[Inderpreet_Singh],2003-06,,,,,
+ctdhercules,3773,tcp,ctdhercules,[Carl_Banzhof],[Carl_Banzhof],2003-06,,,,,
+ctdhercules,3773,udp,ctdhercules,[Carl_Banzhof],[Carl_Banzhof],2003-06,,,,,
+zicom,3774,tcp,ZICOM,[Sabu_Das],[Sabu_Das],2003-06,,,,,
+zicom,3774,udp,ZICOM,[Sabu_Das],[Sabu_Das],2003-06,,,,,
+ispmmgr,3775,tcp,ISPM Manager Port,[Eric_Anderson],[Eric_Anderson],2003-06,,,,,
+ispmmgr,3775,udp,ISPM Manager Port,[Eric_Anderson],[Eric_Anderson],2003-06,,,,,
+dvcprov-port,3776,tcp,Device Provisioning Port,[Rob_Lehew],[Rob_Lehew],2003-06,,,,,
+dvcprov-port,3776,udp,Device Provisioning Port,[Rob_Lehew],[Rob_Lehew],2003-06,,,,,
+jibe-eb,3777,tcp,Jibe EdgeBurst,[Chap_Tippin],[Chap_Tippin],2003-06,,,,,
+jibe-eb,3777,udp,Jibe EdgeBurst,[Chap_Tippin],[Chap_Tippin],2003-06,,,,,
+c-h-it-port,3778,tcp,Cutler-Hammer IT Port,[Thomas_Ruchti],[Thomas_Ruchti],2003-06,,,,,
+c-h-it-port,3778,udp,Cutler-Hammer IT Port,[Thomas_Ruchti],[Thomas_Ruchti],2003-06,,,,,
+cognima,3779,tcp,Cognima Replication,[Ralph_Greenwell],[Ralph_Greenwell],2003-06,,,,,
+cognima,3779,udp,Cognima Replication,[Ralph_Greenwell],[Ralph_Greenwell],2003-06,,,,,
+nnp,3780,tcp,Nuzzler Network Protocol,[Andreas_Schwarz_2],[Andreas_Schwarz_2],2003-06,,,,,
+nnp,3780,udp,Nuzzler Network Protocol,[Andreas_Schwarz_2],[Andreas_Schwarz_2],2003-06,,,,,
+abcvoice-port,3781,tcp,ABCvoice server port,[Carlos_Gonzalez_Roma],[Carlos_Gonzalez_Roma],2003-06,,,,,
+abcvoice-port,3781,udp,ABCvoice server port,[Carlos_Gonzalez_Roma],[Carlos_Gonzalez_Roma],2003-06,,,,,
+iso-tp0s,3782,tcp,Secure ISO TP0 port,[Herbert_Falk],[Herbert_Falk],2003-06,,,,,
+iso-tp0s,3782,udp,Secure ISO TP0 port,[Herbert_Falk],[Herbert_Falk],2003-06,,,,,
+bim-pem,3783,tcp,Impact Mgr./PEM Gateway,[Walter_G_Giroir],[Walter_G_Giroir],2003-07,,,,,
+bim-pem,3783,udp,Impact Mgr./PEM Gateway,[Walter_G_Giroir],[Walter_G_Giroir],2003-07,,,,,
+bfd-control,3784,tcp,BFD Control Protocol,,,,,[RFC5881],,,
+bfd-control,3784,udp,BFD Control Protocol,,,,,[RFC5881],,,
+bfd-echo,3785,tcp,BFD Echo Protocol,,,,,[RFC5881],,,
+bfd-echo,3785,udp,BFD Echo Protocol,,,,,[RFC5881],,,
+upstriggervsw,3786,tcp,VSW Upstrigger port,[Mark_Tim_Junghanns],[Mark_Tim_Junghanns],2003-07,,,,,
+upstriggervsw,3786,udp,VSW Upstrigger port,[Mark_Tim_Junghanns],[Mark_Tim_Junghanns],2003-07,,,,,
+fintrx,3787,tcp,Fintrx,[Peter_G_L_Potgiese],[Peter_G_L_Potgiese],2003-07,,,,,
+fintrx,3787,udp,Fintrx,[Peter_G_L_Potgiese],[Peter_G_L_Potgiese],2003-07,,,,,
+isrp-port,3788,tcp,SPACEWAY Routing port,[Vaibhav_Kumar],[Vaibhav_Kumar],2003-07,,,,,
+isrp-port,3788,udp,SPACEWAY Routing port,[Vaibhav_Kumar],[Vaibhav_Kumar],2003-07,,,,,
+remotedeploy,3789,tcp,RemoteDeploy Administration Port [July 2003],[Detlef_Rothe],[Detlef_Rothe],2009-05-15,,,,,
+remotedeploy,3789,udp,RemoteDeploy Administration Port [July 2003],[Detlef_Rothe],[Detlef_Rothe],2009-05-15,,,,,
+quickbooksrds,3790,tcp,QuickBooks RDS,[Almira],[Almira],2003-07,,,,,
+quickbooksrds,3790,udp,QuickBooks RDS,[Almira],[Almira],2003-07,,,,,
+tvnetworkvideo,3791,tcp,TV NetworkVideo Data port,[Kevin_Brunner],[Kevin_Brunner],2003-07,,,,,
+tvnetworkvideo,3791,udp,TV NetworkVideo Data port,[Kevin_Brunner],[Kevin_Brunner],2003-07,,,,,
+sitewatch,3792,tcp,e-Watch Corporation SiteWatch,[John_M_Baird],[John_M_Baird],2003-07,,,,,
+sitewatch,3792,udp,e-Watch Corporation SiteWatch,[John_M_Baird],[John_M_Baird],2003-07,,,,,
+dcsoftware,3793,tcp,DataCore Software,[Andre_Cato],[Andre_Cato],2003-07,,,,,
+dcsoftware,3793,udp,DataCore Software,[Andre_Cato],[Andre_Cato],2003-07,,,,,
+jaus,3794,tcp,JAUS Robots,[Steven_B_Cliff],[Steven_B_Cliff],2003-07,,,,,
+jaus,3794,udp,JAUS Robots,[Steven_B_Cliff],[Steven_B_Cliff],2003-07,,,,,
+myblast,3795,tcp,myBLAST Mekentosj port,[Alexander_Griekspoor],[Alexander_Griekspoor],2003-07,,,,,
+myblast,3795,udp,myBLAST Mekentosj port,[Alexander_Griekspoor],[Alexander_Griekspoor],2003-07,,,,,
+spw-dialer,3796,tcp,Spaceway Dialer,[Patrick_Fisher],[Patrick_Fisher],2003-07,,,,,
+spw-dialer,3796,udp,Spaceway Dialer,[Patrick_Fisher],[Patrick_Fisher],2003-07,,,,,
+idps,3797,tcp,idps,[Jean_Francois_Rabass],[Jean_Francois_Rabass],2003-07,,,,,
+idps,3797,udp,idps,[Jean_Francois_Rabass],[Jean_Francois_Rabass],2003-07,,,,,
+minilock,3798,tcp,Minilock,[Daniel_Julio_Reyes],[Daniel_Julio_Reyes],2003-08,,,,,
+minilock,3798,udp,Minilock,[Daniel_Julio_Reyes],[Daniel_Julio_Reyes],2003-08,,,,,
+radius-dynauth,3799,tcp,RADIUS Dynamic Authorization,,,,,[RFC3576],,,
+radius-dynauth,3799,udp,RADIUS Dynamic Authorization,,,,,[RFC3576],,,
+pwgpsi,3800,tcp,Print Services Interface,[Harry_Lewis],[Harry_Lewis],2003-05,,,,,
+pwgpsi,3800,udp,Print Services Interface,[Harry_Lewis],[Harry_Lewis],2003-05,,,,,
+ibm-mgr,3801,tcp,ibm manager service,[Tim_Hahn],[Tim_Hahn],2006-03,,,,,
+ibm-mgr,3801,udp,ibm manager service,[Tim_Hahn],[Tim_Hahn],2006-03,,,,,
+vhd,3802,tcp,VHD,[Chris_Duncombe],[Chris_Duncombe],,,,,,
+vhd,3802,udp,VHD,[Chris_Duncombe],[Chris_Duncombe],,,,,,
+soniqsync,3803,tcp,SoniqSync,[Ryan_Melville],[Ryan_Melville],2004-01,,,,,
+soniqsync,3803,udp,SoniqSync,[Ryan_Melville],[Ryan_Melville],2004-01,,,,,
+iqnet-port,3804,tcp,Harman IQNet Port,[Bruce_Vander_Werf],[Bruce_Vander_Werf],2004-02,,,,,
+iqnet-port,3804,udp,Harman IQNet Port,[Bruce_Vander_Werf],[Bruce_Vander_Werf],2004-02,,,,,
+tcpdataserver,3805,tcp,ThorGuard Server Port,[Joel_E_Steiger],[Joel_E_Steiger],2004-02,,,,,
+tcpdataserver,3805,udp,ThorGuard Server Port,[Joel_E_Steiger],[Joel_E_Steiger],2004-02,,,,,
+wsmlb,3806,tcp,Remote System Manager,[Thomas_Fiege],[Thomas_Fiege],2004-02,,,,,
+wsmlb,3806,udp,Remote System Manager,[Thomas_Fiege],[Thomas_Fiege],2004-02,,,,,
+spugna,3807,tcp,SpuGNA Communication Port,[Samuele_Sequi],[Samuele_Sequi],2004-02,,,,,
+spugna,3807,udp,SpuGNA Communication Port,[Samuele_Sequi],[Samuele_Sequi],2004-02,,,,,
+sun-as-iiops-ca,3808,tcp,Sun App Svr-IIOPClntAuth,[Abhijit_Kumar],[Abhijit_Kumar],2005-11,,,,,
+sun-as-iiops-ca,3808,udp,Sun App Svr-IIOPClntAuth,[Abhijit_Kumar],[Abhijit_Kumar],2005-11,,,,,
+apocd,3809,tcp,Java Desktop System Configuration Agent,[Geoff_Higgins],[Geoff_Higgins],2006-03,,,,,
+apocd,3809,udp,Java Desktop System Configuration Agent,[Geoff_Higgins],[Geoff_Higgins],2006-03,,,,,
+wlanauth,3810,tcp,WLAN AS server,[Bianling_Zhang],[Bianling_Zhang],2004-02,,,,,
+wlanauth,3810,udp,WLAN AS server,[Bianling_Zhang],[Bianling_Zhang],2004-02,,,,,
+amp,3811,tcp,AMP,[Northon_Rodrigues],[Northon_Rodrigues],2004-02,,,,,
+amp,3811,udp,AMP,[Northon_Rodrigues],[Northon_Rodrigues],2004-02,,,,,
+neto-wol-server,3812,tcp,netO WOL Server,[Martin_Bestmann_2],[Martin_Bestmann_2],2004-03,,,,,
+neto-wol-server,3812,udp,netO WOL Server,[Martin_Bestmann_2],[Martin_Bestmann_2],2004-03,,,,,
+rap-ip,3813,tcp,Rhapsody Interface Protocol,[Paul_Zander],[Paul_Zander],2004-03,,,,,
+rap-ip,3813,udp,Rhapsody Interface Protocol,[Paul_Zander],[Paul_Zander],2004-03,,,,,
+neto-dcs,3814,tcp,netO DCS,[Martin_Bestmann_2],[Martin_Bestmann_2],2004-03,,,,,
+neto-dcs,3814,udp,netO DCS,[Martin_Bestmann_2],[Martin_Bestmann_2],2004-03,,,,,
+lansurveyorxml,3815,tcp,LANsurveyor XML,[Michael_Swan],[Michael_Swan],2004-04,,,,,
+lansurveyorxml,3815,udp,LANsurveyor XML,[Michael_Swan],[Michael_Swan],2004-04,,,,,
+sunlps-http,3816,tcp,Sun Local Patch Server,[Barry_Greenberg],[Barry_Greenberg],2004-04,,,,,
+sunlps-http,3816,udp,Sun Local Patch Server,[Barry_Greenberg],[Barry_Greenberg],2004-04,,,,,
+tapeware,3817,tcp,Yosemite Tech Tapeware,[Luke_Dion],[Luke_Dion],2004-04,,,,,
+tapeware,3817,udp,Yosemite Tech Tapeware,[Luke_Dion],[Luke_Dion],2004-04,,,,,
+crinis-hb,3818,tcp,Crinis Heartbeat,[Eric_McMurry],[Eric_McMurry],2004-04,,,,,
+crinis-hb,3818,udp,Crinis Heartbeat,[Eric_McMurry],[Eric_McMurry],2004-04,,,,,
+epl-slp,3819,tcp,EPL Sequ Layer Protocol,[Hans_Weibel],[Hans_Weibel],2004-10,,,,,
+epl-slp,3819,udp,EPL Sequ Layer Protocol,[Hans_Weibel],[Hans_Weibel],2004-10,,,,,
+scp,3820,tcp,Siemens AuD SCP,[Johann_Arnold],[Johann_Arnold],2004-10,,,,,
+scp,3820,udp,Siemens AuD SCP,[Johann_Arnold],[Johann_Arnold],2004-10,,,,,
+pmcp,3821,tcp,ATSC PMCP Standard,[Graham_Jones],[Graham_Jones],2004-11,,,,,
+pmcp,3821,udp,ATSC PMCP Standard,[Graham_Jones],[Graham_Jones],2004-11,,,,,
+acp-discovery,3822,tcp,Compute Pool Discovery,,,,,,,,
+acp-discovery,3822,udp,Compute Pool Discovery,,,,,,,,
+acp-conduit,3823,tcp,Compute Pool Conduit,,,,,,,,
+acp-conduit,3823,udp,Compute Pool Conduit,,,,,,,,
+acp-policy,3824,tcp,Compute Pool Policy,[Andy_Belk_2],[Andy_Belk_2],2005-02,,,,,
+acp-policy,3824,udp,Compute Pool Policy,[Andy_Belk_2],[Andy_Belk_2],2005-02,,,,,
+ffserver,3825,tcp,Antera FlowFusion Process Simulation,[Armin_Liebchen],[Armin_Liebchen],2007-06,,,,,
+ffserver,3825,udp,Antera FlowFusion Process Simulation,[Armin_Liebchen],[Armin_Liebchen],2007-06,,,,,
+warmux,3826,tcp,WarMUX game server,[Christophe_Gisquet],[Christophe_Gisquet],,2011-05-26,,,,
+warmux,3826,udp,WarMUX game server,[Christophe_Gisquet],[Christophe_Gisquet],,2011-05-26,,,,
+netmpi,3827,tcp,Netadmin Systems MPI service,[G_Runfeldt],[G_Runfeldt],2007-07-10,,,,,
+netmpi,3827,udp,Netadmin Systems MPI service,[G_Runfeldt],[G_Runfeldt],2007-07-10,,,,,
+neteh,3828,tcp,Netadmin Systems Event Handler,,,,,,,,
+neteh,3828,udp,Netadmin Systems Event Handler,,,,,,,,
+neteh-ext,3829,tcp,Netadmin Systems Event Handler External,[Jonas_Krogell],[Jonas_Krogell],2007-07-10,,,,,
+neteh-ext,3829,udp,Netadmin Systems Event Handler External,[Jonas_Krogell],[Jonas_Krogell],2007-07-10,,,,,
+cernsysmgmtagt,3830,tcp,Cerner System Management Agent,[Mike_Craft],[Mike_Craft],2008-01-29,,,,,
+cernsysmgmtagt,3830,udp,Cerner System Management Agent,[Mike_Craft],[Mike_Craft],2008-01-29,,,,,
+dvapps,3831,tcp,Docsvault Application Service,[Ketul_Patel],[Ketul_Patel],2006-10,,,,,
+dvapps,3831,udp,Docsvault Application Service,[Ketul_Patel],[Ketul_Patel],2006-10,,,,,
+xxnetserver,3832,tcp,xxNETserver,[XXT_LLC],[Matt_Ferrari],2006-10,2012-07-12,,,,
+xxnetserver,3832,udp,xxNETserver,[XXT_LLC],[Matt_Ferrari],2006-10,2012-07-12,,,,
+aipn-auth,3833,tcp,AIPN LS Authentication,[Qiang_Zhang],[Qiang_Zhang],2006-10,,,,,
+aipn-auth,3833,udp,AIPN LS Authentication,[Qiang_Zhang],[Qiang_Zhang],2006-10,,,,,
+spectardata,3834,tcp,Spectar Data Stream Service,,,,,,,,
+spectardata,3834,udp,Spectar Data Stream Service,,,,,,,,
+spectardb,3835,tcp,Spectar Database Rights Service,[Jan_Rutger_Voorhorst],[Jan_Rutger_Voorhorst],2006-10,,,,,
+spectardb,3835,udp,Spectar Database Rights Service,[Jan_Rutger_Voorhorst],[Jan_Rutger_Voorhorst],2006-10,,,,,
+markem-dcp,3836,tcp,MARKEM NEXTGEN DCP,,,,,,,,
+markem-dcp,3836,udp,MARKEM NEXTGEN DCP,,,,,,,,
+mkm-discovery,3837,tcp,MARKEM Auto-Discovery,[Vadym_Kargin],[Vadym_Kargin],2005-08,,,,,
+mkm-discovery,3837,udp,MARKEM Auto-Discovery,[Vadym_Kargin],[Vadym_Kargin],2005-08,,,,,
+sos,3838,tcp,Scito Object Server,[Arno_Klaassen],[Arno_Klaassen],2003-11,,,,,
+sos,3838,udp,Scito Object Server,[Arno_Klaassen],[Arno_Klaassen],2003-11,,,,,
+amx-rms,3839,tcp,AMX Resource Management Suite,[Ron_Barber],[Ron_Barber],2003-11,,,,,
+amx-rms,3839,udp,AMX Resource Management Suite,[Ron_Barber],[Ron_Barber],2003-11,,,,,
+flirtmitmir,3840,tcp,www.FlirtMitMir.de,[Carsten_Falticska],[Carsten_Falticska],2003-11,,,,,
+flirtmitmir,3840,udp,www.FlirtMitMir.de,[Carsten_Falticska],[Carsten_Falticska],2003-11,,,,,
+shiprush-db-svr,3841,tcp,ShipRush Database Server,[Z-Firm_LLC],[Rafael_Zimberoff],2003-11,2014-08-22,,,,
+,3841,udp,Reserved,,,2003-11,2014-08-22,,,,
+nhci,3842,tcp,NHCI status port,[Eric_Welch_2],[Eric_Welch_2],2003-11,,,,,
+nhci,3842,udp,NHCI status port,[Eric_Welch_2],[Eric_Welch_2],2003-11,,,,,
+quest-agent,3843,tcp,Quest Common Agent,[Peter_Maher],[Peter_Maher],2003-11,,,,,
+quest-agent,3843,udp,Quest Common Agent,[Peter_Maher],[Peter_Maher],2003-11,,,,,
+rnm,3844,tcp,RNM,[sn_w_of_renegade_lab],[sn_w_of_renegade_lab],2003-11,,,,,
+rnm,3844,udp,RNM,[sn_w_of_renegade_lab],[sn_w_of_renegade_lab],2003-11,,,,,
+v-one-spp,3845,tcp,V-ONE Single Port Proxy,[Daniel_Becker_3],[Daniel_Becker_3],,,,,,
+v-one-spp,3845,udp,V-ONE Single Port Proxy,[Daniel_Becker_3],[Daniel_Becker_3],,,,,,
+an-pcp,3846,tcp,Astare Network PCP,[Tony_Gulino],[Tony_Gulino],2003-08,,,,,
+an-pcp,3846,udp,Astare Network PCP,[Tony_Gulino],[Tony_Gulino],2003-08,,,,,
+msfw-control,3847,tcp,MS Firewall Control,[Oren_Trutner],[Oren_Trutner],2003-08,,,,,
+msfw-control,3847,udp,MS Firewall Control,[Oren_Trutner],[Oren_Trutner],2003-08,,,,,
+item,3848,tcp,IT Environmental Monitor,[Keith_Wright],[Keith_Wright],2003-08,,,,,
+item,3848,udp,IT Environmental Monitor,[Keith_Wright],[Keith_Wright],2003-08,,,,,
+spw-dnspreload,3849,tcp,SPACEWAY DNS Preload,[Daniel_Friedman],[Daniel_Friedman],2003-08,,,,,
+spw-dnspreload,3849,udp,SPACEWAY DNS Prelaod,[Daniel_Friedman],[Daniel_Friedman],2003-08,,,,,
+qtms-bootstrap,3850,tcp,QTMS Bootstrap Protocol,[Phil_Willis],[Phil_Willis],2003-08,,,,,
+qtms-bootstrap,3850,udp,QTMS Bootstrap Protocol,[Phil_Willis],[Phil_Willis],2003-08,,,,,
+spectraport,3851,tcp,SpectraTalk Port,[Madhav_Karhade],[Madhav_Karhade],2003-08,,,,,
+spectraport,3851,udp,SpectraTalk Port,[Madhav_Karhade],[Madhav_Karhade],2003-08,,,,,
+sse-app-config,3852,tcp,SSE App Configuration,[Tim_Wilson],[Tim_Wilson],2003-08,,,,,
+sse-app-config,3852,udp,SSE App Configuration,[Tim_Wilson],[Tim_Wilson],2003-08,,,,,
+sscan,3853,tcp,SONY scanning protocol,[Takashi_Aihara],[Takashi_Aihara],2003-08,,,,,
+sscan,3853,udp,SONY scanning protocol,[Takashi_Aihara],[Takashi_Aihara],2003-08,,,,,
+stryker-com,3854,tcp,Stryker Comm Port,[Andrew_Schultz],[Andrew_Schultz],2003-08,,,,,
+stryker-com,3854,udp,Stryker Comm Port,[Andrew_Schultz],[Andrew_Schultz],2003-08,,,,,
+opentrac,3855,tcp,OpenTRAC,[Scott_Miller],[Scott_Miller],2003-08,,,,,
+opentrac,3855,udp,OpenTRAC,[Scott_Miller],[Scott_Miller],2003-08,,,,,
+informer,3856,tcp,INFORMER,[Filippo_Fadda],[Filippo_Fadda],2003-08,,,,,
+informer,3856,udp,INFORMER,[Filippo_Fadda],[Filippo_Fadda],2003-08,,,,,
+trap-port,3857,tcp,Trap Port,[Norm_Freedman],[Norm_Freedman],2003-08,,,,,
+trap-port,3857,udp,Trap Port,[Norm_Freedman],[Norm_Freedman],2003-08,,,,,
+trap-port-mom,3858,tcp,Trap Port MOM,[Norm_Freedman],[Norm_Freedman],2003-08,,,,,
+trap-port-mom,3858,udp,Trap Port MOM,[Norm_Freedman],[Norm_Freedman],2003-08,,,,,
+nav-port,3859,tcp,Navini Port,[Chris_Sanders],[Chris_Sanders],2003-08,,,,,
+nav-port,3859,udp,Navini Port,[Chris_Sanders],[Chris_Sanders],2003-08,,,,,
+sasp,3860,tcp,Server/Application State Protocol (SASP),[Alan_Bivens],[Alan_Bivens],2003-08,,,,,
+sasp,3860,udp,Server/Application State Protocol (SASP),[Alan_Bivens],[Alan_Bivens],2003-08,,,,,
+winshadow-hd,3861,tcp,winShadow Host Discovery,[Shu_Wei_Tan],[Shu_Wei_Tan],2003-03,,,,,
+winshadow-hd,3861,udp,winShadow Host Discovery,[Shu_Wei_Tan],[Shu_Wei_Tan],2003-03,,,,,
+giga-pocket,3862,tcp,GIGA-POCKET,[Yoshikazu_Watanabe],[Yoshikazu_Watanabe],,,,,,
+giga-pocket,3862,udp,GIGA-POCKET,[Yoshikazu_Watanabe],[Yoshikazu_Watanabe],,,,,,
+asap-tcp,3863,tcp,asap tcp port,,,,,,,,
+asap-udp,3863,udp,asap udp port,,,,,[RFC5352],,,
+asap-sctp,3863,sctp,asap sctp,,,,,[RFC5352],,,
+asap-tcp-tls,3864,tcp,asap/tls tcp port,,,,,[RFC5352],,,
+,3864,udp,Reserved,,,,,,,,This entry has been removed on 2006-06-23.
+asap-sctp-tls,3864,sctp,asap-sctp/tls,,,,,[RFC5352],,,
+xpl,3865,tcp,xpl automation protocol,[Ian_Lowe],[Ian_Lowe],2003-08,,,,,
+xpl,3865,udp,xpl automation protocol,[Ian_Lowe],[Ian_Lowe],2003-08,,,,,
+dzdaemon,3866,tcp,Sun SDViz DZDAEMON Port,[Kevin_Rushforth],[Kevin_Rushforth],2003-08,,,,,
+dzdaemon,3866,udp,Sun SDViz DZDAEMON Port,[Kevin_Rushforth],[Kevin_Rushforth],2003-08,,,,,
+dzoglserver,3867,tcp,Sun SDViz DZOGLSERVER Port,[Kevin_Rushforth],[Kevin_Rushforth],2003-08,,,,,
+dzoglserver,3867,udp,Sun SDViz DZOGLSERVER Port,[Kevin_Rushforth],[Kevin_Rushforth],2003-08,,,,,
+diameter,3868,tcp,DIAMETER,,,,,,,,
+,3868,udp,Reserved,,,,,,,,
+diameter,3868,sctp,DIAMETER,,,,,[RFC3588],,,
+ovsam-mgmt,3869,tcp,hp OVSAM MgmtServer Disco,[Mike_Pontillo],[Mike_Pontillo],2003-08,,,,,
+ovsam-mgmt,3869,udp,hp OVSAM MgmtServer Disco,[Mike_Pontillo],[Mike_Pontillo],2003-08,,,,,
+ovsam-d-agent,3870,tcp,hp OVSAM HostAgent Disco,[Mike_Pontillo],[Mike_Pontillo],2003-08,,,,,
+ovsam-d-agent,3870,udp,hp OVSAM HostAgent Disco,[Mike_Pontillo],[Mike_Pontillo],2003-08,,,,,
+avocent-adsap,3871,tcp,Avocent DS Authorization,[Eduardo_Fernandez],[Eduardo_Fernandez],2003-08,,,,,
+avocent-adsap,3871,udp,Avocent DS Authorization,[Eduardo_Fernandez],[Eduardo_Fernandez],2003-08,,,,,
+oem-agent,3872,tcp,OEM Agent,[Narain_Jagathesan],[Narain_Jagathesan],2003-11,,,,,
+oem-agent,3872,udp,OEM Agent,[Narain_Jagathesan],[Narain_Jagathesan],2003-11,,,,,
+fagordnc,3873,tcp,fagordnc,[Luis_Zugasti],[Luis_Zugasti],2003-11,,,,,
+fagordnc,3873,udp,fagordnc,[Luis_Zugasti],[Luis_Zugasti],2003-11,,,,,
+sixxsconfig,3874,tcp,SixXS Configuration,[Jeroen_Massar],[Jeroen_Massar],2003-11,,,,,
+sixxsconfig,3874,udp,SixXS Configuration,[Jeroen_Massar],[Jeroen_Massar],2003-11,,,,,
+pnbscada,3875,tcp,PNBSCADA,[Philip_N_Bergstress],[Philip_N_Bergstress],,,,,,
+pnbscada,3875,udp,PNBSCADA,[Philip_N_Bergstress],[Philip_N_Bergstress],,,,,,
+dl-agent,3876,tcp,"DirectoryLockdown Agent
+IANA assigned this well-formed service name as a replacement for ""dl_agent"".",[Jason_Lockett][Melanie_Kacerek],[Jason_Lockett][Melanie_Kacerek],2008-12-16,,,,,
+dl_agent,3876,tcp,DirectoryLockdown Agent,[Jason_Lockett][Melanie_Kacerek],[Jason_Lockett][Melanie_Kacerek],2008-12-16,,,,,"This entry is an alias to ""dl-agent"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+dl-agent,3876,udp,"DirectoryLockdown Agent
+IANA assigned this well-formed service name as a replacement for ""dl_agent"".",[Jason_Lockett][Melanie_Kacerek],[Jason_Lockett][Melanie_Kacerek],2008-12-16,,,,,
+dl_agent,3876,udp,DirectoryLockdown Agent,[Jason_Lockett][Melanie_Kacerek],[Jason_Lockett][Melanie_Kacerek],2008-12-16,,,,,"This entry is an alias to ""dl-agent"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+xmpcr-interface,3877,tcp,XMPCR Interface Port,[Christopher_Carlson],[Christopher_Carlson],2003-10,,,,,
+xmpcr-interface,3877,udp,XMPCR Interface Port,[Christopher_Carlson],[Christopher_Carlson],2003-10,,,,,
+fotogcad,3878,tcp,FotoG CAD interface,[Jason_Szabo],[Jason_Szabo],2003-10,,,,,
+fotogcad,3878,udp,FotoG CAD interface,[Jason_Szabo],[Jason_Szabo],2003-10,,,,,
+appss-lm,3879,tcp,appss license manager,[Peter_Krueger],[Peter_Krueger],2003-10,,,,,
+appss-lm,3879,udp,appss license manager,[Peter_Krueger],[Peter_Krueger],2003-10,,,,,
+igrs,3880,tcp,IGRS,[Huang_Jingnan],[Huang_Jingnan],2003-10,,,,,
+igrs,3880,udp,IGRS,[Huang_Jingnan],[Huang_Jingnan],2003-10,,,,,
+idac,3881,tcp,Data Acquisition and Control,[Chatziandreoglou_Chr],[Chatziandreoglou_Chr],2003-10,,,,,
+idac,3881,udp,Data Acquisition and Control,[Chatziandreoglou_Chr],[Chatziandreoglou_Chr],2003-10,,,,,
+msdts1,3882,tcp,DTS Service Port,[Sergei_Ivanov],[Sergei_Ivanov],2003-10,,,,,
+msdts1,3882,udp,DTS Service Port,[Sergei_Ivanov],[Sergei_Ivanov],2003-10,,,,,
+vrpn,3883,tcp,VR Peripheral Network,[Russell_M_Taylor_II],[Russell_M_Taylor_II],2003-10,,,,,
+vrpn,3883,udp,VR Peripheral Network,[Russell_M_Taylor_II],[Russell_M_Taylor_II],2003-10,,,,,
+softrack-meter,3884,tcp,SofTrack Metering,[John_T_McCann],[John_T_McCann],2003-10,,,,,
+softrack-meter,3884,udp,SofTrack Metering,[John_T_McCann],[John_T_McCann],2003-10,,,,,
+topflow-ssl,3885,tcp,TopFlow SSL,[Ken_Nelson],[Ken_Nelson],,,,,,
+topflow-ssl,3885,udp,TopFlow SSL,[Ken_Nelson],[Ken_Nelson],,,,,,
+nei-management,3886,tcp,NEI management port,[Kevin_Murphy_2],[Kevin_Murphy_2],2003-10,,,,,
+nei-management,3886,udp,NEI management port,[Kevin_Murphy_2],[Kevin_Murphy_2],2003-10,,,,,
+ciphire-data,3887,tcp,Ciphire Data Transport,[Lars_Eilebrecht],[Lars_Eilebrecht],2003-10,,,,,
+ciphire-data,3887,udp,Ciphire Data Transport,[Lars_Eilebrecht],[Lars_Eilebrecht],2003-10,,,,,
+ciphire-serv,3888,tcp,Ciphire Services,[Lars_Eilebrecht],[Lars_Eilebrecht],2003-10,,,,,
+ciphire-serv,3888,udp,Ciphire Services,[Lars_Eilebrecht],[Lars_Eilebrecht],2003-10,,,,,
+dandv-tester,3889,tcp,D and V Tester Control Port,[Voiko_Loukanov],[Voiko_Loukanov],2003-10,,,,,
+dandv-tester,3889,udp,D and V Tester Control Port,[Voiko_Loukanov],[Voiko_Loukanov],2003-10,,,,,
+ndsconnect,3890,tcp,Niche Data Server Connect,[Roland_Schneider],[Roland_Schneider],2003-10,,,,,
+ndsconnect,3890,udp,Niche Data Server Connect,[Roland_Schneider],[Roland_Schneider],2003-10,,,,,
+rtc-pm-port,3891,tcp,Oracle RTC-PM port,[PV_Shivkumar],[PV_Shivkumar],2003-10,,,,,
+rtc-pm-port,3891,udp,Oracle RTC-PM port,[PV_Shivkumar],[PV_Shivkumar],2003-10,,,,,
+pcc-image-port,3892,tcp,PCC-image-port,[Shiro_Tamoto],[Shiro_Tamoto],2003-10,,,,,
+pcc-image-port,3892,udp,PCC-image-port,[Shiro_Tamoto],[Shiro_Tamoto],2003-10,,,,,
+cgi-starapi,3893,tcp,CGI StarAPI Server,[Garry_Moore],[Garry_Moore],2003-10,,,,,
+cgi-starapi,3893,udp,CGI StarAPI Server,[Garry_Moore],[Garry_Moore],2003-10,,,,,
+syam-agent,3894,tcp,SyAM Agent Port,[Michael_Daniele],[Michael_Daniele],2003-10,,,,,
+syam-agent,3894,udp,SyAM Agent Port,[Michael_Daniele],[Michael_Daniele],2003-10,,,,,
+syam-smc,3895,tcp,SyAm SMC Service Port,[Michael_Daniele],[Michael_Daniele],2003-10,,,,,
+syam-smc,3895,udp,SyAm SMC Service Port,[Michael_Daniele],[Michael_Daniele],2003-10,,,,,
+sdo-tls,3896,tcp,Simple Distributed Objects over TLS,[Alexander_Philippou],[Alexander_Philippou],2003-10,,,,,
+sdo-tls,3896,udp,Simple Distributed Objects over TLS,[Alexander_Philippou],[Alexander_Philippou],2003-10,,,,,
+sdo-ssh,3897,tcp,Simple Distributed Objects over SSH,[Alexander_Philippou],[Alexander_Philippou],2003-10,,,,,
+sdo-ssh,3897,udp,Simple Distributed Objects over SSH,[Alexander_Philippou],[Alexander_Philippou],2003-10,,,,,
+senip,3898,tcp,"IAS, Inc. SmartEye NET Internet Protocol",[Matt_Nowicki],[Matt_Nowicki],2003-10,,,,,
+senip,3898,udp,"IAS, Inc. SmartEye NET Internet Protocol",[Matt_Nowicki],[Matt_Nowicki],2003-10,,,,,
+itv-control,3899,tcp,ITV Port,[Alex_Nicu],[Alex_Nicu],2003-10,,,,,
+itv-control,3899,udp,ITV Port,[Alex_Nicu],[Alex_Nicu],2003-10,,,,,
+udt-os,3900,tcp,"Unidata UDT OS
+IANA assigned this well-formed service name as a replacement for ""udt_os"".",[James_Powell],[James_Powell],,,,,,
+udt_os,3900,tcp,Unidata UDT OS,[James_Powell],[James_Powell],,,,,,"This entry is an alias to ""udt-os"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+udt-os,3900,udp,"Unidata UDT OS
+IANA assigned this well-formed service name as a replacement for ""udt_os"".",[James_Powell],[James_Powell],,,,,,
+udt_os,3900,udp,Unidata UDT OS,[James_Powell],[James_Powell],,,,,,"This entry is an alias to ""udt-os"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+nimsh,3901,tcp,NIM Service Handler,[Paul_B_Finley],[Paul_B_Finley],2003-10,,,,,
+nimsh,3901,udp,NIM Service Handler,[Paul_B_Finley],[Paul_B_Finley],2003-10,,,,,
+nimaux,3902,tcp,NIMsh Auxiliary Port,[Paul_B_Finley],[Paul_B_Finley],2003-10,,,,,
+nimaux,3902,udp,NIMsh Auxiliary Port,[Paul_B_Finley],[Paul_B_Finley],2003-10,,,,,
+charsetmgr,3903,tcp,CharsetMGR,[Tatsuya_Ueda],[Tatsuya_Ueda],2003-10,,,,,
+charsetmgr,3903,udp,CharsetMGR,[Tatsuya_Ueda],[Tatsuya_Ueda],2003-10,,,,,
+omnilink-port,3904,tcp,Arnet Omnilink Port,[Ronen_Shaul],[Ronen_Shaul],2003-10,,,,,
+omnilink-port,3904,udp,Arnet Omnilink Port,[Ronen_Shaul],[Ronen_Shaul],2003-10,,,,,
+mupdate,3905,tcp,Mailbox Update (MUPDATE) protocol,,,,,[RFC3656],,,
+mupdate,3905,udp,Mailbox Update (MUPDATE) protocol,,,,,[RFC3656],,,
+topovista-data,3906,tcp,TopoVista elevation data,[Gregg_Townsend],[Gregg_Townsend],2003-11,,,,,
+topovista-data,3906,udp,TopoVista elevation data,[Gregg_Townsend],[Gregg_Townsend],2003-11,,,,,
+imoguia-port,3907,tcp,Imoguia Port,[Emidio_Cunha],[Emidio_Cunha],2003-11,,,,,
+imoguia-port,3907,udp,Imoguia Port,[Emidio_Cunha],[Emidio_Cunha],2003-11,,,,,
+hppronetman,3908,tcp,HP Procurve NetManagement,[Devon_Dawson],[Devon_Dawson],2003-11,,,,,
+hppronetman,3908,udp,HP Procurve NetManagement,[Devon_Dawson],[Devon_Dawson],2003-11,,,,,
+surfcontrolcpa,3909,tcp,SurfControl CPA,[Hywel_Morgan],[Hywel_Morgan],2003-11,,,,,
+surfcontrolcpa,3909,udp,SurfControl CPA,[Hywel_Morgan],[Hywel_Morgan],2003-11,,,,,
+prnrequest,3910,tcp,Printer Request Port,[Brett_Green],[Brett_Green],2003-11,,,,,
+prnrequest,3910,udp,Printer Request Port,[Brett_Green],[Brett_Green],2003-11,,,,,
+prnstatus,3911,tcp,Printer Status Port,[Brett_Green],[Brett_Green],2003-11,,,,,
+prnstatus,3911,udp,Printer Status Port,[Brett_Green],[Brett_Green],2003-11,,,,,
+gbmt-stars,3912,tcp,Global Maintech Stars,[Harry_Goldschmitt],[Harry_Goldschmitt],2003-11,,,,,
+gbmt-stars,3912,udp,Global Maintech Stars,[Harry_Goldschmitt],[Harry_Goldschmitt],2003-11,,,,,
+listcrt-port,3913,tcp,ListCREATOR Port,[Tomokazu_Asai],[Tomokazu_Asai],2003-11,,,,,
+listcrt-port,3913,udp,ListCREATOR Port,[Tomokazu_Asai],[Tomokazu_Asai],2003-11,,,,,
+listcrt-port-2,3914,tcp,ListCREATOR Port 2,[Tomokazu_Asai],[Tomokazu_Asai],2003-11,,,,,
+listcrt-port-2,3914,udp,ListCREATOR Port 2,[Tomokazu_Asai],[Tomokazu_Asai],2003-11,,,,,
+agcat,3915,tcp,Auto-Graphics Cataloging,[Paul_Cope],[Paul_Cope],2003-11,,,,,
+agcat,3915,udp,Auto-Graphics Cataloging,[Paul_Cope],[Paul_Cope],2003-11,,,,,
+wysdmc,3916,tcp,WysDM Controller,[Jim_McDonald_2],[Jim_McDonald_2],2003-11,,,,,
+wysdmc,3916,udp,WysDM Controller,[Jim_McDonald_2],[Jim_McDonald_2],2003-11,,,,,
+aftmux,3917,tcp,AFT multiplex port,[Alfred_Schmidt],[Alfred_Schmidt],2003-11,,,,,
+aftmux,3917,udp,AFT multiples port,[Alfred_Schmidt],[Alfred_Schmidt],2003-11,,,,,
+pktcablemmcops,3918,tcp,PacketCableMultimediaCOPS,[Eric_Rosenfeld],[Eric_Rosenfeld],2003-11,,,,,
+pktcablemmcops,3918,udp,PacketCableMultimediaCOPS,[Eric_Rosenfeld],[Eric_Rosenfeld],2003-11,,,,,
+hyperip,3919,tcp,HyperIP,[Dave_Reiland],[Dave_Reiland],2003-11,,,,,
+hyperip,3919,udp,HyperIP,[Dave_Reiland],[Dave_Reiland],2003-11,,,,,
+exasoftport1,3920,tcp,Exasoft IP Port,[Alan_Malik],[Alan_Malik],2003-11,,,,,
+exasoftport1,3920,udp,Exasoft IP Port,[Alan_Malik],[Alan_Malik],2003-11,,,,,
+herodotus-net,3921,tcp,Herodotus Net,[Adam_Gawne_Cain],[Adam_Gawne_Cain],2003-11,,,,,
+herodotus-net,3921,udp,Herodotus Net,[Adam_Gawne_Cain],[Adam_Gawne_Cain],2003-11,,,,,
+sor-update,3922,tcp,Soronti Update Port,[Carleton_Watkins],[Carleton_Watkins],2003-11,,,,,
+sor-update,3922,udp,Soronti Update Port,[Carleton_Watkins],[Carleton_Watkins],2003-11,,,,,
+symb-sb-port,3923,tcp,Symbian Service Broker,[Ian_McDowall],[Ian_McDowall],2003-11,,,,,
+symb-sb-port,3923,udp,Symbian Service Broker,[Ian_McDowall],[Ian_McDowall],2003-11,,,,,
+mpl-gprs-port,3924,tcp,MPL_GPRS_PORT,[David_Barrass_2],[David_Barrass_2],2003-11,,,,,
+mpl-gprs-port,3924,udp,MPL_GPRS_Port,[David_Barrass_2],[David_Barrass_2],2003-11,,,,,
+zmp,3925,tcp,Zoran Media Port,[Gerard_Cerchio],[Gerard_Cerchio],2003-11,,,,,
+zmp,3925,udp,Zoran Media Port,[Gerard_Cerchio],[Gerard_Cerchio],2003-11,,,,,
+winport,3926,tcp,WINPort,[Alwin_Egger],[Alwin_Egger],2003-11,,,,,
+winport,3926,udp,WINPort,[Alwin_Egger],[Alwin_Egger],2003-11,,,,,
+natdataservice,3927,tcp,ScsTsr,[Ghanshyam_Patel],[Ghanshyam_Patel],2003-11,,,,,
+natdataservice,3927,udp,ScsTsr,[Ghanshyam_Patel],[Ghanshyam_Patel],2003-11,,,,,
+netboot-pxe,3928,tcp,PXE NetBoot Manager,[Markus_Treinen],[Markus_Treinen],2003-11,,,,,
+netboot-pxe,3928,udp,PXE NetBoot Manager,[Markus_Treinen],[Markus_Treinen],2003-11,,,,,
+smauth-port,3929,tcp,AMS Port,[Angelique_Dokos],[Angelique_Dokos],2003-11,,,,,
+smauth-port,3929,udp,AMS Port,[Angelique_Dokos],[Angelique_Dokos],2003-11,,,,,
+syam-webserver,3930,tcp,Syam Web Server Port,[Michael_Daniele],[Michael_Daniele],2003-11,,,,,
+syam-webserver,3930,udp,Syam Web Server Port,[Michael_Daniele],[Michael_Daniele],2003-11,,,,,
+msr-plugin-port,3931,tcp,MSR Plugin Port,[Ron_Steed],[Ron_Steed],2003-11,,,,,
+msr-plugin-port,3931,udp,MSR Plugin Port,[Ron_Steed],[Ron_Steed],2003-11,,,,,
+dyn-site,3932,tcp,Dynamic Site System,[Steve_Qi],[Steve_Qi],2003-11,,,,,
+dyn-site,3932,udp,Dynamic Site System,[Steve_Qi],[Steve_Qi],2003-11,,,,,
+plbserve-port,3933,tcp,PL/B App Server User Port,[Edward_R_Boedecker],[Edward_R_Boedecker],2003-11,,,,,
+plbserve-port,3933,udp,PL/B App Server User Port,[Edward_R_Boedecker],[Edward_R_Boedecker],2003-11,,,,,
+sunfm-port,3934,tcp,PL/B File Manager Port,[Edward_R_Boedecker],[Edward_R_Boedecker],2003-11,,,,,
+sunfm-port,3934,udp,PL/B File Manager Port,[Edward_R_Boedecker],[Edward_R_Boedecker],2003-11,,,,,
+sdp-portmapper,3935,tcp,SDP Port Mapper Protocol,[James_Pinkerton],[James_Pinkerton],2003-11,,,,,
+sdp-portmapper,3935,udp,SDP Port Mapper Protocol,[James_Pinkerton],[James_Pinkerton],2003-11,,,,,
+mailprox,3936,tcp,Mailprox,[Christof_Drescher],[Christof_Drescher],2003-11,,,,,
+mailprox,3936,udp,Mailprox,[Christof_Drescher],[Christof_Drescher],2003-11,,,,,
+dvbservdsc,3937,tcp,DVB Service Discovery,[Bert_van_Willigen][Peter_MacAvock],[Bert_van_Willigen][Peter_MacAvock],2003-11,,,,,
+dvbservdsc,3937,udp,DVB Service Discovery,[Bert_van_Willigen][Peter_MacAvock],[Bert_van_Willigen][Peter_MacAvock],2003-11,,,,,
+dbcontrol-agent,3938,tcp,"Oracle dbControl Agent po
+IANA assigned this well-formed service name as a replacement for ""dbcontrol_agent"".",[Todd_Guay],[Todd_Guay],2003-11,,,,,
+dbcontrol_agent,3938,tcp,Oracle dbControl Agent po,[Todd_Guay],[Todd_Guay],2003-11,,,,,"This entry is an alias to ""dbcontrol-agent"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+dbcontrol-agent,3938,udp,"Oracel dbControl Agent po
+IANA assigned this well-formed service name as a replacement for ""dbcontrol_agent"".",[Todd_Guay],[Todd_Guay],2003-11,,,,,
+dbcontrol_agent,3938,udp,Oracel dbControl Agent po,[Todd_Guay],[Todd_Guay],2003-11,,,,,"This entry is an alias to ""dbcontrol-agent"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+aamp,3939,tcp,Anti-virus Application Management Port,[In_sik_Choi],[In_sik_Choi],2002-02,,,,,
+aamp,3939,udp,Anti-virus Application Management Port,[In_sik_Choi],[In_sik_Choi],2002-02,,,,,
+xecp-node,3940,tcp,XeCP Node Service,[Brent_McCullough],[Brent_McCullough],2003-11,,,,,
+xecp-node,3940,udp,XeCP Node Service,[Brent_McCullough],[Brent_McCullough],2003-11,,,,,
+homeportal-web,3941,tcp,Home Portal Web Server,[Christian_Beaumont],[Christian_Beaumont],2003-11,,,,,
+homeportal-web,3941,udp,Home Portal Web Server,[Christian_Beaumont],[Christian_Beaumont],2003-11,,,,,
+srdp,3942,tcp,satellite distribution,[Simone_Molendini],[Simone_Molendini],2003-11,,,,,
+srdp,3942,udp,satellite distribution,[Simone_Molendini],[Simone_Molendini],2003-11,,,,,
+tig,3943,tcp,TetraNode Ip Gateway,[B_van_Klinken],[B_van_Klinken],2003-12,,,,,
+tig,3943,udp,TetraNode Ip Gateway,[B_van_Klinken],[B_van_Klinken],2003-12,,,,,
+sops,3944,tcp,S-Ops Management,[Stefan_Hochuli],[Stefan_Hochuli],2003-12,,,,,
+sops,3944,udp,S-Ops Management,[Stefan_Hochuli],[Stefan_Hochuli],2003-12,,,,,
+emcads,3945,tcp,EMCADS Server Port,[Lars_Struwe_Christen],[Lars_Struwe_Christen],2004-01,,,,,
+emcads,3945,udp,EMCADS Server Port,[Lars_Struwe_Christen],[Lars_Struwe_Christen],2004-01,,,,,
+backupedge,3946,tcp,BackupEDGE Server,[Frank_Liberato],[Frank_Liberato],2004-06,,,,,
+backupedge,3946,udp,BackupEDGE Server,[Frank_Liberato],[Frank_Liberato],2004-06,,,,,
+ccp,3947,tcp,"Connect and Control Protocol for Consumer, Commercial, and Industrial Electronic Devices",[Aaron_Myer],[Aaron_Myer],2004-06,,,,,
+ccp,3947,udp,"Connect and Control Protocol for Consumer, Commercial, and Industrial Electronic Devices",[Aaron_Myer],[Aaron_Myer],2004-06,,,,,
+apdap,3948,tcp,Anton Paar Device Administration Protocol,[Martin_Leitner],[Martin_Leitner],2004-06,,,,,
+apdap,3948,udp,Anton Paar Device Administration Protocol,[Martin_Leitner],[Martin_Leitner],2004-06,,,,,
+drip,3949,tcp,Dynamic Routing Information Protocol,[Dana_Blair],[Dana_Blair],2004-06,,,,,
+drip,3949,udp,Dynamic Routing Information Protocol,[Dana_Blair],[Dana_Blair],2004-06,,,,,
+namemunge,3950,tcp,Name Munging,[John_C_Klensin],[John_C_Klensin],2004-07,,,,,
+namemunge,3950,udp,Name Munging,[John_C_Klensin],[John_C_Klensin],2004-07,,,,,
+pwgippfax,3951,tcp,PWG IPP Facsimile,[Ira_McDonald],[Ira_McDonald],2004-08,,,,,
+pwgippfax,3951,udp,PWG IPP Facsimile,[Ira_McDonald],[Ira_McDonald],2004-08,,,,,
+i3-sessionmgr,3952,tcp,I3 Session Manager,[Mike_Gagle_2],[Mike_Gagle_2],2004-08,,,,,
+i3-sessionmgr,3952,udp,I3 Session Manager,[Mike_Gagle_2],[Mike_Gagle_2],2004-08,,,,,
+xmlink-connect,3953,tcp,Eydeas XMLink Connect,[David_Crewson],[David_Crewson],2004-09,,,,,
+xmlink-connect,3953,udp,Eydeas XMLink Connect,[David_Crewson],[David_Crewson],2004-09,,,,,
+adrep,3954,tcp,AD Replication RPC,[Robert_Ball],[Robert_Ball],2008-03-26,,,,,
+adrep,3954,udp,AD Replication RPC,[Robert_Ball],[Robert_Ball],2008-03-26,,,,,
+p2pcommunity,3955,tcp,p2pCommunity,[Tiago_Bittencourt_Si],[Tiago_Bittencourt_Si],2005-08,,,,,
+p2pcommunity,3955,udp,p2pCommunity,[Tiago_Bittencourt_Si],[Tiago_Bittencourt_Si],2005-08,,,,,
+gvcp,3956,tcp,GigE Vision Control,[Eric_Carey],[Eric_Carey],2005-08,,,,,
+gvcp,3956,udp,GigE Vision Control,[Eric_Carey],[Eric_Carey],2005-08,,,,,
+mqe-broker,3957,tcp,MQEnterprise Broker,,,,,,,,
+mqe-broker,3957,udp,MQEnterprise Broker,,,,,,,,
+mqe-agent,3958,tcp,MQEnterprise Agent,[Bob_Lauria],[Bob_Lauria],2005-08,,,,,
+mqe-agent,3958,udp,MQEnterprise Agent,[Bob_Lauria],[Bob_Lauria],2005-08,,,,,
+treehopper,3959,tcp,Tree Hopper Networking,[Gary_Whelan],[Gary_Whelan],2005-08,,,,,
+treehopper,3959,udp,Tree Hopper Networking,[Gary_Whelan],[Gary_Whelan],2005-08,,,,,
+bess,3960,tcp,Bess Peer Assessment,[Peter_Verdon],[Peter_Verdon],2005-08,,,,,
+bess,3960,udp,Bess Peer Assessment,[Peter_Verdon],[Peter_Verdon],2005-08,,,,,
+proaxess,3961,tcp,ProAxess Server,[Jonas_Ahlqvist],[Jonas_Ahlqvist],2005-08,,,,,
+proaxess,3961,udp,ProAxess Server,[Jonas_Ahlqvist],[Jonas_Ahlqvist],2005-08,,,,,
+sbi-agent,3962,tcp,SBI Agent Protocol,[Yossi_Appleboum_2],[Yossi_Appleboum_2],2005-08,,,,,
+sbi-agent,3962,udp,SBI Agent Protocol,[Yossi_Appleboum_2],[Yossi_Appleboum_2],2005-08,,,,,
+thrp,3963,tcp,Teran Hybrid Routing Protocol,[Spencer_Teran],[Spencer_Teran],2005-08,,,,,
+thrp,3963,udp,Teran Hybrid Routing Protocol,[Spencer_Teran],[Spencer_Teran],2005-08,,,,,
+sasggprs,3964,tcp,SASG GPRS,[Cristian_Petculescu_3],[Cristian_Petculescu_3],2005-08,,,,,
+sasggprs,3964,udp,SASG GPRS,[Cristian_Petculescu_3],[Cristian_Petculescu_3],2005-08,,,,,
+ati-ip-to-ncpe,3965,tcp,Avanti IP to NCPE API,[Steve_Meyer_Sr],[Steve_Meyer_Sr],2005-08,,,,,
+ati-ip-to-ncpe,3965,udp,Avanti IP to NCPE API,[Steve_Meyer_Sr],[Steve_Meyer_Sr],2005-08,,,,,
+bflckmgr,3966,tcp,BuildForge Lock Manager,[Joe_Senner],[Joe_Senner],2005-08,,,,,
+bflckmgr,3966,udp,BuildForge Lock Manager,[Joe_Senner],[Joe_Senner],2005-08,,,,,
+ppsms,3967,tcp,PPS Message Service,[Bart_Schaefer],[Bart_Schaefer],2005-08,,,,,
+ppsms,3967,udp,PPS Message Service,[Bart_Schaefer],[Bart_Schaefer],2005-08,,,,,
+ianywhere-dbns,3968,tcp,iAnywhere DBNS,[Graeme_Perrow],[Graeme_Perrow],2005-08,,,,,
+ianywhere-dbns,3968,udp,iAnywhere DBNS,[Graeme_Perrow],[Graeme_Perrow],2005-08,,,,,
+landmarks,3969,tcp,Landmark Messages,[Petri_Rauhala],[Petri_Rauhala],2005-08,,,,,
+landmarks,3969,udp,Landmark Messages,[Petri_Rauhala],[Petri_Rauhala],2005-08,,,,,
+lanrevagent,3970,tcp,LANrev Agent,[Martin_Bestmann_3],[Martin_Bestmann_3],,,,,,"Defined TXT keys:
+ txtvers
+ server=<main LANrev server for agent>
+ vers=<version of LANrev Agent>
+ build=<build number of LANrev Agent>
+ id=<agent identifier>"
+lanrevagent,3970,udp,LANrev Agent,[Martin_Bestmann_3],[Martin_Bestmann_3],,,,,,"Defined TXT keys:
+ txtvers
+ server=<main LANrev server for agent>
+ vers=<version of LANrev Agent>
+ build=<build number of LANrev Agent>
+ id=<agent identifier>"
+lanrevserver,3971,tcp,LANrev Server,[Martin_Bestmann_3],[Martin_Bestmann_3],2005-08,,,,,
+lanrevserver,3971,udp,LANrev Server,[Martin_Bestmann_3],[Martin_Bestmann_3],2005-08,,,,,
+iconp,3972,tcp,ict-control Protocol,[Roel_Harbers],[Roel_Harbers],2005-08,,,,,
+iconp,3972,udp,ict-control Protocol,[Roel_Harbers],[Roel_Harbers],2005-08,,,,,
+progistics,3973,tcp,ConnectShip Progistics,[Jeff_Skaistis],[Jeff_Skaistis],2005-08,,,,,
+progistics,3973,udp,ConnectShip Progistics,[Jeff_Skaistis],[Jeff_Skaistis],2005-08,,,,,
+citysearch,3974,tcp,Remote Applicant Tracking Service,[Marc_Castelluccio],[Marc_Castelluccio],2005-08,,,,,
+citysearch,3974,udp,Remote Applicant Tracking Service,[Marc_Castelluccio],[Marc_Castelluccio],2005-08,,,,,
+airshot,3975,tcp,Air Shot,[Shingo_Kimura],[Shingo_Kimura],2005-08,,,,,
+airshot,3975,udp,Air Shot,[Shingo_Kimura],[Shingo_Kimura],2005-08,,,,,
+opswagent,3976,tcp,Opsware Agent,,,,,,,,
+opswagent,3976,udp,Opsware Agent,,,,,,,,
+opswmanager,3977,tcp,Opsware Manager,[Dave_Jagoda],[Dave_Jagoda],2006-06,,,,,
+opswmanager,3977,udp,Opsware Manager,[Dave_Jagoda],[Dave_Jagoda],2006-06,,,,,
+secure-cfg-svr,3978,tcp,Secured Configuration Server,[Dr_Anupam_Bharali],[Dr_Anupam_Bharali],2006-06,,,,,
+secure-cfg-svr,3978,udp,Secured Configuration Server,[Dr_Anupam_Bharali],[Dr_Anupam_Bharali],2006-06,,,,,
+smwan,3979,tcp,Smith Micro Wide Area Network Service,[David_Sperling],[David_Sperling],2006-06,,,,,
+smwan,3979,udp,Smith Micro Wide Area Network Service,[David_Sperling],[David_Sperling],2006-06,,,,,
+acms,3980,tcp,Aircraft Cabin Management System,[Dustin_Zack],[Dustin_Zack],2006-06,,,,,
+acms,3980,udp,Aircraft Cabin Management System,[Dustin_Zack],[Dustin_Zack],2006-06,,,,,
+starfish,3981,tcp,Starfish System Admin,[Dan_Razzell],[Dan_Razzell],2006-06,,,,,
+starfish,3981,udp,Starfish System Admin,[Dan_Razzell],[Dan_Razzell],2006-06,,,,,
+eis,3982,tcp,ESRI Image Server,,,,,,,,
+eis,3982,udp,ESRI Image Server,,,,,,,,
+eisp,3983,tcp,ESRI Image Service,[Keith_Ryden],[Keith_Ryden],2006-07,,,,,
+eisp,3983,udp,ESRI Image Service,[Keith_Ryden],[Keith_Ryden],2006-07,,,,,
+mapper-nodemgr,3984,tcp,MAPPER network node manager,,,,,,,,
+mapper-nodemgr,3984,udp,MAPPER network node manager,,,,,,,,
+mapper-mapethd,3985,tcp,MAPPER TCP/IP server,,,,,,,,
+mapper-mapethd,3985,udp,MAPPER TCP/IP server,,,,,,,,
+mapper-ws-ethd,3986,tcp,"MAPPER workstation server
+IANA assigned this well-formed service name as a replacement for ""mapper-ws_ethd"".",[John_C_Horton],[John_C_Horton],,,,,,
+mapper-ws_ethd,3986,tcp,MAPPER workstation server,[John_C_Horton],[John_C_Horton],,,,,,"This entry is an alias to ""mapper-ws-ethd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+mapper-ws-ethd,3986,udp,"MAPPER workstation server
+IANA assigned this well-formed service name as a replacement for ""mapper-ws_ethd"".",[John_C_Horton],[John_C_Horton],,,,,,
+mapper-ws_ethd,3986,udp,MAPPER workstation server,[John_C_Horton],[John_C_Horton],,,,,,"This entry is an alias to ""mapper-ws-ethd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+centerline,3987,tcp,Centerline,[Mark_Simpson],[Mark_Simpson],,,,,,
+centerline,3987,udp,Centerline,[Mark_Simpson],[Mark_Simpson],,,,,,
+dcs-config,3988,tcp,DCS Configuration Port,[Ian_Cargill],[Ian_Cargill],2005-08,,,,,
+dcs-config,3988,udp,DCS Configuration Port,[Ian_Cargill],[Ian_Cargill],2005-08,,,,,
+bv-queryengine,3989,tcp,BindView-Query Engine,,,,,,,,
+bv-queryengine,3989,udp,BindView-Query Engine,,,,,,,,
+bv-is,3990,tcp,BindView-IS,,,,,,,,
+bv-is,3990,udp,BindView-IS,,,,,,,,
+bv-smcsrv,3991,tcp,BindView-SMCServer,,,,,,,,
+bv-smcsrv,3991,udp,BindView-SMCServer,,,,,,,,
+bv-ds,3992,tcp,BindView-DirectoryServer,,,,,,,,
+bv-ds,3992,udp,BindView-DirectoryServer,,,,,,,,
+bv-agent,3993,tcp,BindView-Agent,[David_A_Gayler],[David_A_Gayler],2005-08,,,,,
+bv-agent,3993,udp,BindView-Agent,[David_A_Gayler],[David_A_Gayler],2005-08,,,,,
+,3994,,Unassigned,,,,2008-04-24,,,,
+iss-mgmt-ssl,3995,tcp,ISS Management Svcs SSL,[Wes_Wilson],[Wes_Wilson],2003-10,,,,,
+iss-mgmt-ssl,3995,udp,ISS Management Svcs SSL,[Wes_Wilson],[Wes_Wilson],2003-10,,,,,
+abcsoftware,3996,tcp,abcsoftware-01,[Andrew_Zimmerman],[Andrew_Zimmerman],2004-06,,,,,
+abcsoftware,3996,udp,abcsoftware-01,[Andrew_Zimmerman],[Andrew_Zimmerman],2004-06,,,,,
+agentsease-db,3997,tcp,aes_db,[Colin_Hughes],[Colin_Hughes],2006-02,,,,,
+agentsease-db,3997,udp,aes_db,[Colin_Hughes],[Colin_Hughes],2006-02,,,,,
+dnx,3998,tcp,Distributed Nagios Executor Service,[John_Calcote],[John_Calcote],2007-11-06,,,,,
+dnx,3998,udp,Distributed Nagios Executor Service,[John_Calcote],[John_Calcote],2007-11-06,,,,,
+nvcnet,3999,tcp,Norman distributes scanning service,[Kristian_A_Bognaes],[Kristian_A_Bognaes],2007-11-06,,,,,
+nvcnet,3999,udp,Norman distributes scanning service,[Kristian_A_Bognaes],[Kristian_A_Bognaes],2007-11-06,,,,,
+terabase,4000,tcp,Terabase,[Thor_Olson],[Thor_Olson],,,,,,"Potential Conflict of ports
+PORT 4000 also used by ICQ <www.icq.com>"
+terabase,4000,udp,Terabase,[Thor_Olson],[Thor_Olson],,,,,,"Potential Conflict of ports
+PORT 4000 also used by ICQ <www.icq.com>"
+newoak,4001,tcp,NewOak,[Jim_Philippou],[Jim_Philippou],,,,,,
+newoak,4001,udp,NewOak,[Jim_Philippou],[Jim_Philippou],,,,,,
+pxc-spvr-ft,4002,tcp,pxc-spvr-ft,,,,,,,,
+pxc-spvr-ft,4002,udp,pxc-spvr-ft,,,,,,,,
+pxc-splr-ft,4003,tcp,pxc-splr-ft,,,,,,,,
+pxc-splr-ft,4003,udp,pxc-splr-ft,,,,,,,,
+pxc-roid,4004,tcp,pxc-roid,,,,,,,,
+pxc-roid,4004,udp,pxc-roid,,,,,,,,
+pxc-pin,4005,tcp,pxc-pin,,,,,,,,
+pxc-pin,4005,udp,pxc-pin,,,,,,,,
+pxc-spvr,4006,tcp,pxc-spvr,,,,,,,,
+pxc-spvr,4006,udp,pxc-spvr,,,,,,,,
+pxc-splr,4007,tcp,pxc-splr,[Dave_Nesbitt],[Dave_Nesbitt],,,,,,
+pxc-splr,4007,udp,pxc-splr,[Dave_Nesbitt],[Dave_Nesbitt],,,,,,
+netcheque,4008,tcp,NetCheque accounting,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,,
+netcheque,4008,udp,NetCheque accounting,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,,
+chimera-hwm,4009,tcp,Chimera HWM,[Ken_Anderson],[Ken_Anderson],,,,,,
+chimera-hwm,4009,udp,Chimera HWM,[Ken_Anderson],[Ken_Anderson],,,,,,
+samsung-unidex,4010,tcp,Samsung Unidex,[Konstantin_V_Vyazni],[Konstantin_V_Vyazni],,,,,,
+samsung-unidex,4010,udp,Samsung Unidex,[Konstantin_V_Vyazni],[Konstantin_V_Vyazni],,,,,,
+altserviceboot,4011,tcp,Alternate Service Boot,[Eric_Dittert],[Eric_Dittert],,,,,,
+altserviceboot,4011,udp,Alternate Service Boot,[Eric_Dittert],[Eric_Dittert],,,,,,
+pda-gate,4012,tcp,PDA Gate,[Masakuni_Okada],[Masakuni_Okada],,,,,,
+pda-gate,4012,udp,PDA Gate,[Masakuni_Okada],[Masakuni_Okada],,,,,,
+acl-manager,4013,tcp,ACL Manager,[Toru_Murai],[Toru_Murai],,,,,,
+acl-manager,4013,udp,ACL Manager,[Toru_Murai],[Toru_Murai],,,,,,
+taiclock,4014,tcp,TAICLOCK,[Dan_Bernstein_3],[Dan_Bernstein_3],,,,,,
+taiclock,4014,udp,TAICLOCK,[Dan_Bernstein_3],[Dan_Bernstein_3],,,,,,
+talarian-mcast1,4015,tcp,Talarian Mcast,,,,,,,,
+talarian-mcast1,4015,udp,Talarian Mcast,,,,,,,,
+talarian-mcast2,4016,tcp,Talarian Mcast,,,,,,,,
+talarian-mcast2,4016,udp,Talarian Mcast,,,,,,,,
+talarian-mcast3,4017,tcp,Talarian Mcast,,,,,,,,
+talarian-mcast3,4017,udp,Talarian Mcast,,,,,,,,
+talarian-mcast4,4018,tcp,Talarian Mcast,,,,,,,,
+talarian-mcast4,4018,udp,Talarian Mcast,,,,,,,,
+talarian-mcast5,4019,tcp,Talarian Mcast,[Geoff_Mendal],[Geoff_Mendal],,,,,,
+talarian-mcast5,4019,udp,Talarian Mcast,[Geoff_Mendal],[Geoff_Mendal],,,,,,
+trap,4020,tcp,TRAP Port,[Jeffrey_C_Byrd],[Jeffrey_C_Byrd],,,,,,
+trap,4020,udp,TRAP Port,[Jeffrey_C_Byrd],[Jeffrey_C_Byrd],,,,,,
+nexus-portal,4021,tcp,Nexus Portal,[Damian_Tarnawsky],[Damian_Tarnawsky],,,,,,
+nexus-portal,4021,udp,Nexus Portal,[Damian_Tarnawsky],[Damian_Tarnawsky],,,,,,
+dnox,4022,tcp,DNOX,[Leo_Rathnayake],[Leo_Rathnayake],,,,,,
+dnox,4022,udp,DNOX,[Leo_Rathnayake],[Leo_Rathnayake],,,,,,
+esnm-zoning,4023,tcp,ESNM Zoning Port,[Yong_Cai],[Yong_Cai],,,,,,
+esnm-zoning,4023,udp,ESNM Zoning Port,[Yong_Cai],[Yong_Cai],,,,,,
+tnp1-port,4024,tcp,TNP1 User Port,[Tony_Gibbs],[Tony_Gibbs],,,,,,
+tnp1-port,4024,udp,TNP1 User Port,[Tony_Gibbs],[Tony_Gibbs],,,,,,
+partimage,4025,tcp,Partition Image Port,[Franck_Ladurelle],[Franck_Ladurelle],,,,,,
+partimage,4025,udp,Partition Image Port,[Franck_Ladurelle],[Franck_Ladurelle],,,,,,
+as-debug,4026,tcp,Graphical Debug Server,[Steve_Halverson],[Steve_Halverson],,,,,,
+as-debug,4026,udp,Graphical Debug Server,[Steve_Halverson],[Steve_Halverson],,,,,,
+bxp,4027,tcp,bitxpress,[Morgan_Doyle],[Morgan_Doyle],,,,,,
+bxp,4027,udp,bitxpress,[Morgan_Doyle],[Morgan_Doyle],,,,,,
+dtserver-port,4028,tcp,DTServer Port,[Stephen_Aikins],[Stephen_Aikins],,,,,,
+dtserver-port,4028,udp,DTServer Port,[Stephen_Aikins],[Stephen_Aikins],,,,,,
+ip-qsig,4029,tcp,IP Q signaling protocol,[Toru_Tachibana],[Toru_Tachibana],,,,,,
+ip-qsig,4029,udp,IP Q signaling protocol,[Toru_Tachibana],[Toru_Tachibana],,,,,,
+jdmn-port,4030,tcp,Accell/JSP Daemon Port,[Daegis_Inc],[Chris_Anderson],,2012-07-12,,,,
+jdmn-port,4030,udp,Accell/JSP Daemon Port,[Daegis_Inc],[Chris_Anderson],,2012-07-12,,,,
+suucp,4031,tcp,UUCP over SSL,[Harald_Welte],[Harald_Welte],,,,,,
+suucp,4031,udp,UUCP over SSL,[Harald_Welte],[Harald_Welte],,,,,,
+vrts-auth-port,4032,tcp,VERITAS Authorization Service,[Stefan_Winkel],[Stefan_Winkel],,,,,,
+vrts-auth-port,4032,udp,VERITAS Authorization Service,[Stefan_Winkel],[Stefan_Winkel],,,,,,
+sanavigator,4033,tcp,SANavigator Peer Port,[Robert_J_Chansler],[Robert_J_Chansler],,,,,,
+sanavigator,4033,udp,SANavigator Peer Port,[Robert_J_Chansler],[Robert_J_Chansler],,,,,,
+ubxd,4034,tcp,Ubiquinox Daemon,[Kit_Smithers],[Kit_Smithers],,,,,,
+ubxd,4034,udp,Ubiquinox Daemon,[Kit_Smithers],[Kit_Smithers],,,,,,
+wap-push-http,4035,tcp,WAP Push OTA-HTTP port,,,,,,,,
+wap-push-http,4035,udp,WAP Push OTA-HTTP port,,,,,,,,
+wap-push-https,4036,tcp,WAP Push OTA-HTTP secure,[Matthieu_Lachance],[Matthieu_Lachance],,,,,,
+wap-push-https,4036,udp,WAP Push OTA-HTTP secure,[Matthieu_Lachance],[Matthieu_Lachance],,,,,,
+ravehd,4037,tcp,RaveHD network control,[Jason_Howard],[Jason_Howard],2006-01,,,,,
+ravehd,4037,udp,RaveHD network control,[Jason_Howard],[Jason_Howard],2006-01,,,,,
+fazzt-ptp,4038,tcp,Fazzt Point-To-Point,,,,,,,,
+fazzt-ptp,4038,udp,Fazzt Point-To-Point,,,,,,,,
+fazzt-admin,4039,tcp,Fazzt Administration,[Lewis_Wolfgang],[Lewis_Wolfgang],2006-05,,,,,
+fazzt-admin,4039,udp,Fazzt Administration,[Lewis_Wolfgang],[Lewis_Wolfgang],2006-05,,,,,
+yo-main,4040,tcp,Yo.net main service,[John_Tintor],[John_Tintor],,,,,,
+yo-main,4040,udp,Yo.net main service,[John_Tintor],[John_Tintor],,,,,,
+houston,4041,tcp,Rocketeer-Houston,[Johnny_C_Norris_II],[Johnny_C_Norris_II],,,,,,
+houston,4041,udp,Rocketeer-Houston,[Johnny_C_Norris_II],[Johnny_C_Norris_II],,,,,,
+ldxp,4042,tcp,LDXP,[Craig_Calef],[Craig_Calef],,,,,,
+ldxp,4042,udp,LDXP,[Craig_Calef],[Craig_Calef],,,,,,
+nirp,4043,tcp,Neighbour Identity Resolution,,,,,,,,
+nirp,4043,udp,Neighbour Identity Resolution,,,,,,,,
+ltp,4044,tcp,Location Tracking Protocol,,,,,,,,
+ltp,4044,udp,Location Tracking Protocol,,,,,,,,
+npp,4045,tcp,Network Paging Protocol,,,,,,,Known UNAUTHORIZED USE: Port 4045,
+npp,4045,udp,Network Paging Protocol,,,,,,,Known UNAUTHORIZED USE: Port 4045,
+acp-proto,4046,tcp,Accounting Protocol,,,,,,,,
+acp-proto,4046,udp,Accounting Protocol,,,,,,,,
+ctp-state,4047,tcp,Context Transfer Protocol,[Hesham_Soliman],[Hesham_Soliman],2005-11,,,,,
+ctp-state,4047,udp,Context Transfer Protocol,[Hesham_Soliman],[Hesham_Soliman],2005-11,,,,,
+,4048,,Unassigned,,,,2008-04-24,,,,
+wafs,4049,tcp,Wide Area File Services,[Yuval_Hager],[Yuval_Hager],2006-01,,,,,
+wafs,4049,udp,Wide Area File Services,[Yuval_Hager],[Yuval_Hager],2006-01,,,,,
+cisco-wafs,4050,tcp,Wide Area File Services,[Etai_Lev_Ran],[Etai_Lev_Ran],2005-02,,,,,
+cisco-wafs,4050,udp,Wide Area File Services,[Etai_Lev_Ran],[Etai_Lev_Ran],2005-02,,,,,
+cppdp,4051,tcp,Cisco Peer to Peer Distribution Protocol,[Susan_Sauter],[Susan_Sauter],2006-07,,,,,
+cppdp,4051,udp,Cisco Peer to Peer Distribution Protocol,[Susan_Sauter],[Susan_Sauter],2006-07,,,,,
+interact,4052,tcp,VoiceConnect Interact,[Jonathan_Custance],[Jonathan_Custance],2006-07,,,,,
+interact,4052,udp,VoiceConnect Interact,[Jonathan_Custance],[Jonathan_Custance],2006-07,,,,,
+ccu-comm-1,4053,tcp,CosmoCall Universe Communications Port 1,,,,,,,,
+ccu-comm-1,4053,udp,CosmoCall Universe Communications Port 1,,,,,,,,
+ccu-comm-2,4054,tcp,CosmoCall Universe Communications Port 2,,,,,,,,
+ccu-comm-2,4054,udp,CosmoCall Universe Communications Port 2,,,,,,,,
+ccu-comm-3,4055,tcp,CosmoCall Universe Communications Port 3,[Steve_Dellutri_2],[Steve_Dellutri_2],2006-07,,,,,
+ccu-comm-3,4055,udp,CosmoCall Universe Communications Port 3,[Steve_Dellutri_2],[Steve_Dellutri_2],2006-07,,,,,
+lms,4056,tcp,Location Message Service,[Sergey_Burnevsky],[Sergey_Burnevsky],2006-08,,,,,
+lms,4056,udp,Location Message Service,[Sergey_Burnevsky],[Sergey_Burnevsky],2006-08,,,,,
+wfm,4057,tcp,Servigistics WFM server,[Yuri_Machkasov_2],[Yuri_Machkasov_2],2006-08,,,,,
+wfm,4057,udp,Servigistics WFM server,[Yuri_Machkasov_2],[Yuri_Machkasov_2],2006-08,,,,,
+kingfisher,4058,tcp,Kingfisher protocol,[Vaughan_Wesson],[Vaughan_Wesson],2006-10,,,,,
+kingfisher,4058,udp,Kingfisher protocol,[Vaughan_Wesson],[Vaughan_Wesson],2006-10,,,,,
+dlms-cosem,4059,tcp,DLMS/COSEM,[Gyozo_Kmethy],[Gyozo_Kmethy],2006-11,,,,,
+dlms-cosem,4059,udp,DLMS/COSEM,[Gyozo_Kmethy],[Gyozo_Kmethy],2006-11,,,,,
+dsmeter-iatc,4060,tcp,"DSMETER Inter-Agent Transfer Channel
+IANA assigned this well-formed service name as a replacement for ""dsmeter_iatc"".",[John_McCann],[John_McCann],2006-12,,,,,
+dsmeter_iatc,4060,tcp,DSMETER Inter-Agent Transfer Channel,[John_McCann],[John_McCann],2006-12,,,,,"This entry is an alias to ""dsmeter-iatc"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+dsmeter-iatc,4060,udp,"DSMETER Inter-Agent Transfer Channel
+IANA assigned this well-formed service name as a replacement for ""dsmeter_iatc"".",[John_McCann],[John_McCann],2006-12,,,,,
+dsmeter_iatc,4060,udp,DSMETER Inter-Agent Transfer Channel,[John_McCann],[John_McCann],2006-12,,,,,"This entry is an alias to ""dsmeter-iatc"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+ice-location,4061,tcp,Ice Location Service (TCP),,,,,,,,
+ice-location,4061,udp,Ice Location Service (TCP),,,,,,,,
+ice-slocation,4062,tcp,Ice Location Service (SSL),,,,,,,,
+ice-slocation,4062,udp,Ice Location Service (SSL),,,,,,,,
+ice-router,4063,tcp,Ice Firewall Traversal Service (TCP),,,,,,,,
+ice-router,4063,udp,Ice Firewall Traversal Service (TCP),,,,,,,,
+ice-srouter,4064,tcp,Ice Firewall Traversal Service (SSL),[Bernard_Normier],[Bernard_Normier],2006-12,,,,,
+ice-srouter,4064,udp,Ice Firewall Traversal Service (SSL),[Bernard_Normier],[Bernard_Normier],2006-12,,,,,
+avanti-cdp,4065,tcp,"Avanti Common Data
+IANA assigned this well-formed service name as a replacement for ""avanti_cdp"".",[Steve_Meyer_Sr],[Steve_Meyer_Sr],2007-02,,,,,
+avanti_cdp,4065,tcp,Avanti Common Data,[Steve_Meyer_Sr],[Steve_Meyer_Sr],2007-02,,,,,"This entry is an alias to ""avanti-cdp"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+avanti-cdp,4065,udp,"Avanti Common Data
+IANA assigned this well-formed service name as a replacement for ""avanti_cdp"".",[Steve_Meyer_Sr],[Steve_Meyer_Sr],2007-02,,,,,
+avanti_cdp,4065,udp,Avanti Common Data,[Steve_Meyer_Sr],[Steve_Meyer_Sr],2007-02,,,,,"This entry is an alias to ""avanti-cdp"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+pmas,4066,tcp,Performance Measurement and Analysis,[Zenon_Fortuna],[Zenon_Fortuna],2007-02,,,,,
+pmas,4066,udp,Performance Measurement and Analysis,[Zenon_Fortuna],[Zenon_Fortuna],2007-02,,,,,
+idp,4067,tcp,Information Distribution Protocol,[Michaela_Vanderveen],[Michaela_Vanderveen],2007-02,,,,,
+idp,4067,udp,Information Distribution Protocol,[Michaela_Vanderveen],[Michaela_Vanderveen],2007-02,,,,,
+ipfltbcst,4068,tcp,IP Fleet Broadcast,[Trung_Huu_Tran],[Trung_Huu_Tran],2007-03,,,,,
+ipfltbcst,4068,udp,IP Fleet Broadcast,[Trung_Huu_Tran],[Trung_Huu_Tran],2007-03,,,,,
+minger,4069,tcp,Minger Email Address Validation Service,[Arvel_Hathcock],[Arvel_Hathcock],2007-03,,,,,
+minger,4069,udp,Minger Email Address Validation Service,[Arvel_Hathcock],[Arvel_Hathcock],2007-03,,,,,
+tripe,4070,tcp,Trivial IP Encryption (TrIPE),[Mark_Wooding],[Mark_Wooding],2007-07-10,,,,,
+tripe,4070,udp,Trivial IP Encryption (TrIPE),[Mark_Wooding],[Mark_Wooding],2007-07-10,,,,,
+aibkup,4071,tcp,Automatically Incremental Backup,[Volker_Wiegand],[Volker_Wiegand],2007-07-10,,,,,
+aibkup,4071,udp,Automatically Incremental Backup,[Volker_Wiegand],[Volker_Wiegand],2007-07-10,,,,,
+zieto-sock,4072,tcp,Zieto Socket Communications,[Malcolm_McLean],[Malcolm_McLean],2007-07-19,,,,,
+zieto-sock,4072,udp,Zieto Socket Communications,[Malcolm_McLean],[Malcolm_McLean],2007-07-19,,,,,
+iRAPP,4073,tcp,iRAPP Server Protocol,[Vladimir_Bickov],[Vladimir_Bickov],2007-08-20,,,,,
+iRAPP,4073,udp,iRAPP Server Protocol,[Vladimir_Bickov],[Vladimir_Bickov],2007-08-20,,,,,
+cequint-cityid,4074,tcp,Cequint City ID UI trigger,[Phill_Goeckler],[Phill_Goeckler],2007-08-20,,,,,
+cequint-cityid,4074,udp,Cequint City ID UI trigger,[Phill_Goeckler],[Phill_Goeckler],2007-08-20,,,,,
+perimlan,4075,tcp,ISC Alarm Message Service,[Bernie_Malkowski],[Bernie_Malkowski],2007-08-20,,,,,
+perimlan,4075,udp,ISC Alarm Message Service,[Bernie_Malkowski],[Bernie_Malkowski],2007-08-20,,,,,
+seraph,4076,tcp,Seraph DCS,[Jason_Spence],[Jason_Spence],2008-01-22,,,,,
+seraph,4076,udp,Seraph DCS,[Jason_Spence],[Jason_Spence],2008-01-22,,,,,
+,4077,tcp,Reserved,,,,,,,,
+ascomalarm,4077,udp,Ascom IP Alarming,[Ascom_Austria_GmbH],[Ascom_Austria_GmbH],2008-05-01,,,,,
+cssp,4078,tcp,Coordinated Security Service Protocol,[Michael_McDaniels],[Michael_McDaniels],2008-05-01,,,,,
+,4078,udp,Reserved,,,,,,,,
+santools,4079,tcp,SANtools Diagnostic Server,[David_A_Lethe_2],[David_A_Lethe_2],2008-05-01,,,,,
+santools,4079,udp,SANtools Diagnostic Server,[David_A_Lethe_2],[David_A_Lethe_2],2008-05-01,,,,,
+lorica-in,4080,tcp,Lorica inside facing,,,,,,,,
+lorica-in,4080,udp,Lorica inside facing,,,,,,,,
+lorica-in-sec,4081,tcp,Lorica inside facing (SSL),,,,,,,,
+lorica-in-sec,4081,udp,Lorica inside facing (SSL),,,,,,,,
+lorica-out,4082,tcp,Lorica outside facing,,,,,,,,
+lorica-out,4082,udp,Lorica outside facing,,,,,,,,
+lorica-out-sec,4083,tcp,Lorica outside facing (SSL),[Johannes_Skov_Frands],[Johannes_Skov_Frands],2008-02-28,,,,,
+lorica-out-sec,4083,udp,Lorica outside facing (SSL),[Johannes_Skov_Frands],[Johannes_Skov_Frands],2008-02-28,,,,,
+,4084,tcp,Reserved,,,,,,,,
+fortisphere-vm,4084,udp,Fortisphere VM Service,[Daniel_Becker_4],[Daniel_Becker_4],2008-06-03,,,,,
+ezmessagesrv,4085,tcp,EZNews Newsroom Message Service,[Gerald_R_Jensen],[Gerald_R_Jensen],2008-06-05,,,,,
+,4085,udp,Reserved,,,,,,,,
+,4086,tcp,Reserved,,,,,,,,
+ftsync,4086,udp,Firewall/NAT state table synchronization,[Heiner_Erne],[Heiner_Erne],2008-06-06,,,,,
+applusservice,4087,tcp,APplus Service,[Thomas_Boerkel],[Thomas_Boerkel],2008-06-05,,,,,
+,4087,udp,Reserved,,,,,,,,
+npsp,4088,tcp,Noah Printing Service Protocol,[Hiromi_Ohara],[Hiromi_Ohara],2008-06-18,,,,,
+,4088,udp,Reserved,,,,,,,,
+opencore,4089,tcp,OpenCORE Remote Control Service,[Pim_van_Riezen],[Pim_van_Riezen],2006-07,,,,,
+opencore,4089,udp,OpenCORE Remote Control Service,[Pim_van_Riezen],[Pim_van_Riezen],2006-07,,,,,
+omasgport,4090,tcp,OMA BCAST Service Guide,[Mark_Lipford],[Mark_Lipford],2006-07,,,,,
+omasgport,4090,udp,OMA BCAST Service Guide,[Mark_Lipford],[Mark_Lipford],2006-07,,,,,
+ewinstaller,4091,tcp,EminentWare Installer,,,,,,,,
+ewinstaller,4091,udp,EminentWare Installer,,,,,,,,
+ewdgs,4092,tcp,EminentWare DGS,[David_A_Gayler_2],[David_A_Gayler_2],2006-07,,,,,
+ewdgs,4092,udp,EminentWare DGS,[David_A_Gayler_2],[David_A_Gayler_2],2006-07,,,,,
+pvxpluscs,4093,tcp,Pvx Plus CS Host,[Michael_King],[Michael_King],2006-07,,,,,
+pvxpluscs,4093,udp,Pvx Plus CS Host,[Michael_King],[Michael_King],2006-07,,,,,
+sysrqd,4094,tcp,sysrq daemon,[Julien_Danjou],[Julien_Danjou],2006-07,,,,,
+sysrqd,4094,udp,sysrq daemon,[Julien_Danjou],[Julien_Danjou],2006-07,,,,,
+xtgui,4095,tcp,xtgui information service,[Jim_Robanske],[Jim_Robanske],2006-05,,,,,
+xtgui,4095,udp,xtgui information service,[Jim_Robanske],[Jim_Robanske],2006-05,,,,,
+bre,4096,tcp,BRE (Bridge Relay Element),[Stephen_Egbert],[Stephen_Egbert],,,,,,
+bre,4096,udp,BRE (Bridge Relay Element),[Stephen_Egbert],[Stephen_Egbert],,,,,,
+patrolview,4097,tcp,Patrol View,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+patrolview,4097,udp,Patrol View,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+drmsfsd,4098,tcp,drmsfsd,[Masao_Iwai],[Masao_Iwai],,,,,,
+drmsfsd,4098,udp,drmsfsd,[Masao_Iwai],[Masao_Iwai],,,,,,
+dpcp,4099,tcp,DPCP,[John_Croft],[John_Croft],,,,,,
+dpcp,4099,udp,DPCP,[John_Croft],[John_Croft],,,,,,
+igo-incognito,4100,tcp,IGo Incognito Data Port,[Paul_Reddy_2],[Paul_Reddy_2],2002-02,,,,,
+igo-incognito,4100,udp,IGo Incognito Data Port,[Paul_Reddy_2],[Paul_Reddy_2],2002-02,,,,,
+brlp-0,4101,tcp,Braille protocol,,,,,,,,
+brlp-0,4101,udp,Braille protocol,,,,,,,,
+brlp-1,4102,tcp,Braille protocol,,,,,,,,
+brlp-1,4102,udp,Braille protocol,,,,,,,,
+brlp-2,4103,tcp,Braille protocol,,,,,,,,
+brlp-2,4103,udp,Braille protocol,,,,,,,,
+brlp-3,4104,tcp,Braille protocol,[Sebastien_Hinderer],[Sebastien_Hinderer],2006-03,,,,,
+brlp-3,4104,udp,Braille protocol,[Sebastien_Hinderer],[Sebastien_Hinderer],2006-03,,,,,
+shofar,4105,tcp,Shofar,[ShofarNexus],[John_Kozlowski],2006-07,2012-02-20,,,,
+shofar,4105,udp,Shofar,[ShofarNexus],[John_Kozlowski],2006-07,2012-02-20,,,,
+synchronite,4106,tcp,Synchronite,[James_Figgins],[James_Figgins],2006-07,,,,,
+synchronite,4106,udp,Synchronite,[James_Figgins],[James_Figgins],2006-07,,,,,
+j-ac,4107,tcp,JDL Accounting LAN Service,[Takashi_Sahara],[Takashi_Sahara],2006-09,,,,,
+j-ac,4107,udp,JDL Accounting LAN Service,[Takashi_Sahara],[Takashi_Sahara],2006-09,,,,,
+accel,4108,tcp,ACCEL,[Masahiro_Koiwai],[Masahiro_Koiwai],2006-10,,,,,
+accel,4108,udp,ACCEL,[Masahiro_Koiwai],[Masahiro_Koiwai],2006-10,,,,,
+izm,4109,tcp,Instantiated Zero-control Messaging,[David_Miller],[David_Miller],2007-02,,,,,
+izm,4109,udp,Instantiated Zero-control Messaging,[David_Miller],[David_Miller],2007-02,,,,,
+g2tag,4110,tcp,G2 RFID Tag Telemetry Data,[David_Goodall],[David_Goodall],2007-02,,,,,
+g2tag,4110,udp,G2 RFID Tag Telemetry Data,[David_Goodall],[David_Goodall],2007-02,,,,,
+xgrid,4111,tcp,Xgrid,[David_Kramer],[David_Kramer],2004-11,,,,,
+xgrid,4111,udp,Xgrid,[David_Kramer],[David_Kramer],2004-11,,,,,
+apple-vpns-rp,4112,tcp,Apple VPN Server Reporting Protocol,[Christophe_Allie],[Christophe_Allie],2006-08,,,,,
+apple-vpns-rp,4112,udp,Apple VPN Server Reporting Protocol,[Christophe_Allie],[Christophe_Allie],2006-08,,,,,
+aipn-reg,4113,tcp,AIPN LS Registration,[Qiang_Zhang_2],[Qiang_Zhang_2],2006-10,,,,,
+aipn-reg,4113,udp,AIPN LS Registration,[Qiang_Zhang_2],[Qiang_Zhang_2],2006-10,,,,,
+jomamqmonitor,4114,tcp,JomaMQMonitor,[Marcel_Hofstetter],[Marcel_Hofstetter],2003-01,,,,,
+jomamqmonitor,4114,udp,JomaMQMonitor,[Marcel_Hofstetter],[Marcel_Hofstetter],2003-01,,,,,
+cds,4115,tcp,CDS Transfer Agent,[Neil_Coggins],[Neil_Coggins],2006-07,,,,,
+cds,4115,udp,CDS Transfer Agent,[Neil_Coggins],[Neil_Coggins],2006-07,,,,,
+smartcard-tls,4116,tcp,smartcard-TLS,[Ilan_Mahalal],[Ilan_Mahalal],2006-04,,,,,
+smartcard-tls,4116,udp,smartcard-TLS,[Ilan_Mahalal],[Ilan_Mahalal],2006-04,,,,,
+hillrserv,4117,tcp,Hillr Connection Manager,[Freddy_A_Ayuso_Hens],[Freddy_A_Ayuso_Hens],2008-05-22,,,,,
+hillrserv,4117,udp,Hillr Connection Manager,[Freddy_A_Ayuso_Hens],[Freddy_A_Ayuso_Hens],2008-05-22,,,,,
+netscript,4118,tcp,Netadmin Systems NETscript service,[Goran_Runfeldt],[Goran_Runfeldt],2006-12,,,,,
+netscript,4118,udp,Netadmin Systems NETscript service,[Goran_Runfeldt],[Goran_Runfeldt],2006-12,,,,,
+assuria-slm,4119,tcp,Assuria Log Manager,[Nick_Connor],[Nick_Connor],2006-12,,,,,
+assuria-slm,4119,udp,Assuria Log Manager,[Nick_Connor],[Nick_Connor],2006-12,,,,,
+,4120,,Unassigned,,,,2007-02-01,,,,
+e-builder,4121,tcp,e-Builder Application Communication,[James_Caza],[James_Caza],2006-12,,,,,
+e-builder,4121,udp,e-Builder Application Communication,[James_Caza],[James_Caza],2006-12,,,,,
+fprams,4122,tcp,Fiber Patrol Alarm Service,[Zhizhong_Zhuang],[Zhizhong_Zhuang],2006-12,,,,,
+fprams,4122,udp,Fiber Patrol Alarm Service,[Zhizhong_Zhuang],[Zhizhong_Zhuang],2006-12,,,,,
+z-wave,4123,tcp,Z-Wave Protocol,[Sigma_Designs_Inc_2],[Anders_Brandt][Mary_Miller],2007-02,2012-11-08,,,,
+z-wave,4123,udp,Z-Wave Protocol,[Sigma_Designs_Inc_2],[Anders_Brandt][Mary_Miller],2007-02,2012-11-08,,,,
+tigv2,4124,tcp,Rohill TetraNode Ip Gateway v2,[Bert_Bouwers],[Bert_Bouwers],2007-05,,,,,
+tigv2,4124,udp,Rohill TetraNode Ip Gateway v2,[Bert_Bouwers],[Bert_Bouwers],2007-05,,,,,
+opsview-envoy,4125,tcp,Opsview Envoy,[Ton_Voon],[Ton_Voon],2008-09-26,,,,,
+opsview-envoy,4125,udp,Opsview Envoy,[Ton_Voon],[Ton_Voon],2008-09-26,,,,,
+ddrepl,4126,tcp,Data Domain Replication Service,[Pratik_Wadher],[Pratik_Wadher],2007-05,,,,,
+ddrepl,4126,udp,Data Domain Replication Service,[Pratik_Wadher],[Pratik_Wadher],2007-05,,,,,
+unikeypro,4127,tcp,NetUniKeyServer,[Raymond_Chaw],[Raymond_Chaw],2007-05,,,,,
+unikeypro,4127,udp,NetUniKeyServer,[Raymond_Chaw],[Raymond_Chaw],2007-05,,,,,
+nufw,4128,tcp,NuFW decision delegation protocol,,,,,,,,
+nufw,4128,udp,NuFW decision delegation protocol,,,,,,,,
+nuauth,4129,tcp,NuFW authentication protocol,[Eric_Leblond],[Eric_Leblond],2007-06,,,,,
+nuauth,4129,udp,NuFW authentication protocol,[Eric_Leblond],[Eric_Leblond],2007-06,,,,,
+fronet,4130,tcp,FRONET message protocol,[Christer_Nygren],[Christer_Nygren],2007-08-07,,,,,
+fronet,4130,udp,FRONET message protocol,[Christer_Nygren],[Christer_Nygren],2007-08-07,,,,,
+stars,4131,tcp,Global Maintech Stars,[Harry_Goldschmitt_2],[Harry_Goldschmitt_2],2007-06,,,,,
+stars,4131,udp,Global Maintech Stars,[Harry_Goldschmitt_2],[Harry_Goldschmitt_2],2007-06,,,,,
+nuts-dem,4132,tcp,"NUTS Daemon
+IANA assigned this well-formed service name as a replacement for ""nuts_dem"".",,,,,,,,
+nuts_dem,4132,tcp,NUTS Daemon,,,,,,,,"This entry is an alias to ""nuts-dem"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+nuts-dem,4132,udp,"NUTS Daemon
+IANA assigned this well-formed service name as a replacement for ""nuts_dem"".",,,,,,,,
+nuts_dem,4132,udp,NUTS Daemon,,,,,,,,"This entry is an alias to ""nuts-dem"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+nuts-bootp,4133,tcp,"NUTS Bootp Server
+IANA assigned this well-formed service name as a replacement for ""nuts_bootp"".",[Martin_Freiss_2],[Martin_Freiss_2],,,,,,
+nuts_bootp,4133,tcp,NUTS Bootp Server,[Martin_Freiss_2],[Martin_Freiss_2],,,,,,"This entry is an alias to ""nuts-bootp"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+nuts-bootp,4133,udp,"NUTS Bootp Server
+IANA assigned this well-formed service name as a replacement for ""nuts_bootp"".",[Martin_Freiss_2],[Martin_Freiss_2],,,,,,
+nuts_bootp,4133,udp,NUTS Bootp Server,[Martin_Freiss_2],[Martin_Freiss_2],,,,,,"This entry is an alias to ""nuts-bootp"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+nifty-hmi,4134,tcp,NIFTY-Serve HMI protocol,[Ryuichi_Suzuki],[Ryuichi_Suzuki],,,,,,
+nifty-hmi,4134,udp,NIFTY-Serve HMI protocol,[Ryuichi_Suzuki],[Ryuichi_Suzuki],,,,,,
+cl-db-attach,4135,tcp,Classic Line Database Server Attach,,,,,,,,
+cl-db-attach,4135,udp,Classic Line Database Server Attach,,,,,,,,
+cl-db-request,4136,tcp,Classic Line Database Server Request,,,,,,,,
+cl-db-request,4136,udp,Classic Line Database Server Request,,,,,,,,
+cl-db-remote,4137,tcp,Classic Line Database Server Remote,[Arno_Kirmeir],[Arno_Kirmeir],2007-01,,,,,
+cl-db-remote,4137,udp,Classic Line Database Server Remote,[Arno_Kirmeir],[Arno_Kirmeir],2007-01,,,,,
+nettest,4138,tcp,nettest,[David_Borman],[David_Borman],2003-03,,,,,
+nettest,4138,udp,nettest,[David_Borman],[David_Borman],2003-03,,,,,
+thrtx,4139,tcp,Imperfect Networks Server,[Dinkar_Chivaluri_2],[Dinkar_Chivaluri_2],2006-02,,,,,
+thrtx,4139,udp,Imperfect Networks Server,[Dinkar_Chivaluri_2],[Dinkar_Chivaluri_2],2006-02,,,,,
+cedros-fds,4140,tcp,"Cedros Fraud Detection System
+IANA assigned this well-formed service name as a replacement for ""cedros_fds"".",[Markus_Michels_3],[Markus_Michels_3],2006-10,,,,,
+cedros_fds,4140,tcp,Cedros Fraud Detection System,[Markus_Michels_3],[Markus_Michels_3],2006-10,,,,,"This entry is an alias to ""cedros-fds"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+cedros-fds,4140,udp,"Cedros Fraud Detection System
+IANA assigned this well-formed service name as a replacement for ""cedros_fds"".",[Markus_Michels_3],[Markus_Michels_3],2006-10,,,,,
+cedros_fds,4140,udp,Cedros Fraud Detection System,[Markus_Michels_3],[Markus_Michels_3],2006-10,,,,,"This entry is an alias to ""cedros-fds"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+oirtgsvc,4141,tcp,Workflow Server,,,,,,,,
+oirtgsvc,4141,udp,Workflow Server,,,,,,,,
+oidocsvc,4142,tcp,Document Server,,,,,,,,
+oidocsvc,4142,udp,Document Server,,,,,,,,
+oidsr,4143,tcp,Document Replication,[Norman_Brie],[Norman_Brie],,,,,,
+oidsr,4143,udp,Document Replication,[Norman_Brie],[Norman_Brie],,,,,,
+,4144,,Unassigned,,,,,,,,Compuserve (unoffically) is using port 4144
+vvr-control,4145,tcp,VVR Control,[Ming_Xu],[Ming_Xu],,,,,,
+vvr-control,4145,udp,VVR Control,[Ming_Xu],[Ming_Xu],,,,,,
+tgcconnect,4146,tcp,TGCConnect Beacon,[Brian_Becker],[Brian_Becker],2006-10,,,,,
+tgcconnect,4146,udp,TGCConnect Beacon,[Brian_Becker],[Brian_Becker],2006-10,,,,,
+vrxpservman,4147,tcp,Multum Service Manager,[Scott_Mager],[Scott_Mager],2006-10,,,,,
+vrxpservman,4147,udp,Multum Service Manager,[Scott_Mager],[Scott_Mager],2006-10,,,,,
+hhb-handheld,4148,tcp,HHB Handheld Client,[Steven_G_Loughner],[Steven_G_Loughner],2007-03,,,,,
+hhb-handheld,4148,udp,HHB Handheld Client,[Steven_G_Loughner],[Steven_G_Loughner],2007-03,,,,,
+agslb,4149,tcp,A10 GSLB Service,[John_Chiong],[John_Chiong],2007-07-02,,,,,
+agslb,4149,udp,A10 GSLB Service,[John_Chiong],[John_Chiong],2007-07-02,,,,,
+PowerAlert-nsa,4150,tcp,PowerAlert Network Shutdown Agent,[Mike_Delgrosso_2],[Mike_Delgrosso_2],2007-07-02,,,,,
+PowerAlert-nsa,4150,udp,PowerAlert Network Shutdown Agent,[Mike_Delgrosso_2],[Mike_Delgrosso_2],2007-07-02,,,,,
+menandmice-noh,4151,tcp,"Men & Mice Remote Control
+IANA assigned this well-formed service name as a replacement for ""menandmice_noh"".",[Eggert_Thorlacius],[Eggert_Thorlacius],2007-08-30,,,,,
+menandmice_noh,4151,tcp,Men & Mice Remote Control,[Eggert_Thorlacius],[Eggert_Thorlacius],2007-08-30,,,,,"This entry is an alias to ""menandmice-noh"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+menandmice-noh,4151,udp,"Men & Mice Remote Control
+IANA assigned this well-formed service name as a replacement for ""menandmice_noh"".",[Eggert_Thorlacius],[Eggert_Thorlacius],2007-08-30,,,,,
+menandmice_noh,4151,udp,Men & Mice Remote Control,[Eggert_Thorlacius],[Eggert_Thorlacius],2007-08-30,,,,,"This entry is an alias to ""menandmice-noh"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+idig-mux,4152,tcp,"iDigTech Multiplex
+IANA assigned this well-formed service name as a replacement for ""idig_mux"".",[Robin_Findley],[Robin_Findley],2007-05,,,,,
+idig_mux,4152,tcp,iDigTech Multiplex,[Robin_Findley],[Robin_Findley],2007-05,,,,,"This entry is an alias to ""idig-mux"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+idig-mux,4152,udp,"iDigTech Multiplex
+IANA assigned this well-formed service name as a replacement for ""idig_mux"".",[Robin_Findley],[Robin_Findley],2007-05,,,,,
+idig_mux,4152,udp,iDigTech Multiplex,[Robin_Findley],[Robin_Findley],2007-05,,,,,"This entry is an alias to ""idig-mux"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+mbl-battd,4153,tcp,MBL Remote Battery Monitoring,[Claudio_Procida],[Claudio_Procida],2007-05,,,,,
+mbl-battd,4153,udp,MBL Remote Battery Monitoring,[Claudio_Procida],[Claudio_Procida],2007-05,,,,,
+atlinks,4154,tcp,atlinks device discovery,[Scott_Griepentrog],[Scott_Griepentrog],2002-10,,,,,
+atlinks,4154,udp,atlinks device discovery,[Scott_Griepentrog],[Scott_Griepentrog],2002-10,,,,,
+bzr,4155,tcp,Bazaar version control system,[Martin_Pool_2],[Martin_Pool_2],2007-02,,,,,
+bzr,4155,udp,Bazaar version control system,[Martin_Pool_2],[Martin_Pool_2],2007-02,,,,,
+stat-results,4156,tcp,STAT Results,,,,,,,,
+stat-results,4156,udp,STAT Results,,,,,,,,
+stat-scanner,4157,tcp,STAT Scanner Control,,,,,,,,
+stat-scanner,4157,udp,STAT Scanner Control,,,,,,,,
+stat-cc,4158,tcp,STAT Command Center,[Darwin_Ammala],[Darwin_Ammala],2007-03,,,,,
+stat-cc,4158,udp,STAT Command Center,[Darwin_Ammala],[Darwin_Ammala],2007-03,,,,,
+nss,4159,tcp,Network Security Service,[Dave_Wierbowski],[Dave_Wierbowski],2006-08,,,,,
+nss,4159,udp,Network Security Service,[Dave_Wierbowski],[Dave_Wierbowski],2006-08,,,,,
+jini-discovery,4160,tcp,Jini Discovery,[Mark_Hodapp],[Mark_Hodapp],,,,,,
+jini-discovery,4160,udp,Jini Discovery,[Mark_Hodapp],[Mark_Hodapp],,,,,,
+omscontact,4161,tcp,OMS Contact,,,,,,,,
+omscontact,4161,udp,OMS Contact,,,,,,,,
+omstopology,4162,tcp,OMS Topology,[David_Page],[David_Page],2005-08,,,,,
+omstopology,4162,udp,OMS Topology,[David_Page],[David_Page],2005-08,,,,,
+silverpeakpeer,4163,tcp,Silver Peak Peer Protocol,[Damon_Ennis],[Damon_Ennis],2007-03,,,,,
+silverpeakpeer,4163,udp,Silver Peak Peer Protocol,[Damon_Ennis],[Damon_Ennis],2007-03,,,,,
+silverpeakcomm,4164,tcp,Silver Peak Communication Protocol,[Damon_Ennis],[Damon_Ennis],2007-03,,,,,
+silverpeakcomm,4164,udp,Silver Peak Communication Protocol,[Damon_Ennis],[Damon_Ennis],2007-03,,,,,
+altcp,4165,tcp,ArcLink over Ethernet,[Dmitry_Brant],[Dmitry_Brant],2007-03,,,,,
+altcp,4165,udp,ArcLink over Ethernet,[Dmitry_Brant],[Dmitry_Brant],2007-03,,,,,
+joost,4166,tcp,Joost Peer to Peer Protocol,[Colm_MacCarthaigh],[Colm_MacCarthaigh],2007-04,,,,,
+joost,4166,udp,Joost Peer to Peer Protocol,[Colm_MacCarthaigh],[Colm_MacCarthaigh],2007-04,,,,,
+ddgn,4167,tcp,DeskDirect Global Network,[Laurie_Charlwood],[Laurie_Charlwood],2007-08-22,,,,,
+ddgn,4167,udp,DeskDirect Global Network,[Laurie_Charlwood],[Laurie_Charlwood],2007-08-22,,,,,
+pslicser,4168,tcp,PrintSoft License Server,[David_Weisgerber],[David_Weisgerber],2007-09-27,,,,,
+pslicser,4168,udp,PrintSoft License Server,[David_Weisgerber],[David_Weisgerber],2007-09-27,,,,,
+iadt,4169,tcp,Automation Drive Interface Transport,[Paul_Suhler],[Paul_Suhler],2008-02-15,,,,,
+iadt-disc,4169,udp,Internet ADT Discovery Protocol,[Paul_A_Suhler],[Paul_A_Suhler],2009-02-06,,,,,
+d-cinema-csp,4170,tcp,SMPTE Content Synchonization Protocol,[Michael_Karagosian],[Michael_Karagosian],2008-09-04,,,,,
+,4170,udp,Reserved,,,,,,,,
+ml-svnet,4171,tcp,Maxlogic Supervisor Communication,[Taha_Paksu],[Taha_Paksu],2009-12-21,,,,,
+,4171,udp,Reserved,,,,,,,,
+pcoip,4172,tcp,PC over IP,[Teradici],[Jeff_Dillabough],2009-12-23,2012-03-06,,,,
+pcoip,4172,udp,PC over IP,[Teradici],[Jeff_Dillabough],2009-12-23,2012-03-06,,,,
+,4173,tcp,Reserved,,,,,,,,
+mma-discovery,4173,udp,MMA Device Discovery,[MIDI_Manufacturers_Assoc_Inc],[Tom_White],2011-11-14,,,,,
+smcluster,4174,tcp,StorMagic Cluster Services,[Chris_Farey],[Chris_Farey],2011-03-09,,,,,
+sm-disc,4174,udp,StorMagic Discovery,[StorMagic_Ltd],[Chris_Farey],2011-12-16,,,,,
+bccp,4175,tcp,Brocade Cluster Communication Protocol,[Norival_Figueira],[Norival_Figueira],2010-04-07,,,,,
+,4175,udp,Reserved,,,,,,,,
+tl-ipcproxy,4176,tcp,Translattice Cluster IPC Proxy,[Michael_Lyle],[Michael_Lyle],2009-11-03,,,,,
+,4176,udp,Reserved,,,,,,,,
+wello,4177,tcp,Wello P2P pubsub service,[Christian_Westbrook],[Christian_Westbrook],2007-11-15,,,,,
+wello,4177,udp,Wello P2P pubsub service,[Christian_Westbrook],[Christian_Westbrook],2007-11-15,,,,,
+storman,4178,tcp,StorMan,[Werner_Guertler],[Werner_Guertler],2009-05-11,,,,,
+storman,4178,udp,StorMan,[Werner_Guertler],[Werner_Guertler],2009-05-11,,,,,
+MaxumSP,4179,tcp,Maxum Services,[Greg_Stine],[Greg_Stine],2007-07-05,,,,,
+MaxumSP,4179,udp,Maxum Services,[Greg_Stine],[Greg_Stine],2007-07-05,,,,,
+httpx,4180,tcp,HTTPX,[Paul_McGough],[Paul_McGough],2007-02,,,,,
+httpx,4180,udp,HTTPX,[Paul_McGough],[Paul_McGough],2007-02,,,,,
+macbak,4181,tcp,MacBak,[Wes_Peters],[Wes_Peters],2007-04,,,,,
+macbak,4181,udp,MacBak,[Wes_Peters],[Wes_Peters],2007-04,,,,,
+pcptcpservice,4182,tcp,Production Company Pro TCP Service,[Ben_McNeill],[Ben_McNeill],2007-05,,,,,
+pcptcpservice,4182,udp,Production Company Pro TCP Service,[Ben_McNeill],[Ben_McNeill],2007-05,,,,,
+gmmp,4183,tcp,General Metaverse Messaging Protocol,[Gareth_Nelson],[Gareth_Nelson],2007-06,,,,,
+gmmp,4183,udp,General Metaverse Messaging Protocol,[Gareth_Nelson],[Gareth_Nelson],2007-06,,,,,
+universe-suite,4184,tcp,"UNIVERSE SUITE MESSAGE SERVICE
+IANA assigned this well-formed service name as a replacement for ""universe_suite"".",[Gary_ANDREWS],[Gary_ANDREWS],2008-01-07,,,,,
+universe_suite,4184,tcp,UNIVERSE SUITE MESSAGE SERVICE,[Gary_ANDREWS],[Gary_ANDREWS],2008-01-07,,,,,"This entry is an alias to ""universe-suite"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+universe-suite,4184,udp,"UNIVERSE SUITE MESSAGE SERVICE
+IANA assigned this well-formed service name as a replacement for ""universe_suite"".",[Gary_ANDREWS],[Gary_ANDREWS],2008-01-07,,,,,
+universe_suite,4184,udp,UNIVERSE SUITE MESSAGE SERVICE,[Gary_ANDREWS],[Gary_ANDREWS],2008-01-07,,,,,"This entry is an alias to ""universe-suite"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+wcpp,4185,tcp,Woven Control Plane Protocol,[Christopher_LILJENST],[Christopher_LILJENST],2008-04-14,,,,,
+wcpp,4185,udp,Woven Control Plane Protocol,[Christopher_LILJENST],[Christopher_LILJENST],2008-04-14,,,,,
+boxbackupstore,4186,tcp,Box Backup Store Service,[Chris_Wilson],[Chris_Wilson],2008-09-11,,,,,
+,4186,udp,Reserved,,,,,,,,
+csc-proxy,4187,tcp,"Cascade Proxy
+IANA assigned this well-formed service name as a replacement for ""csc_proxy"".",[Matt_Craighead],[Matt_Craighead],2008-09-11,,,,,
+csc_proxy,4187,tcp,Cascade Proxy,[Matt_Craighead],[Matt_Craighead],2008-09-11,,,,,"This entry is an alias to ""csc-proxy"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+,4187,udp,Reserved,,,,,,,,
+vatata,4188,tcp,Vatata Peer to Peer Protocol,[Song_Jian],[Song_Jian],2008-09-15,,,,,
+vatata,4188,udp,Vatata Peer to Peer Protocol,[Song_Jian],[Song_Jian],2008-09-15,,,,,
+pcep,4189,tcp,Path Computation Element Communication Protocol,,,,,,,,
+,4189,udp,Reserved,,,,,[RFC5440],,,
+sieve,4190,tcp,ManageSieve Protocol,,,,,,,,
+,4190,udp,Reserved,,,,,[RFC5804],,,
+,4191,tcp,Reserved,,,,,,,,
+dsmipv6,4191,udp,Dual Stack MIPv6 NAT Traversal,,,,,[RFC5555],,,
+azeti,4192,tcp,Azeti Agent Service,[Uwe_Holz],[Uwe_Holz],2009-11-09,,,,,
+azeti-bd,4192,udp,azeti blinddate,[Michael_Werski],[Michael_Werski],2010-02-18,,,,,
+pvxplusio,4193,tcp,PxPlus remote file srvr,[Mike_King],[Mike_King],2009-11-09,,,,,
+,4193,udp,Reserved,,,,,,,,
+,4194-4198,,Unassigned,,,,,,,,
+eims-admin,4199,tcp,EIMS ADMIN,[Glenn_Anderson],[Glenn_Anderson],,,,,,
+eims-admin,4199,udp,EIMS ADMIN,[Glenn_Anderson],[Glenn_Anderson],,,,,,
+vrml-multi-use,4200-4299,,VRML Multi User Systems,[Mitra],[Mitra],,,,,,
+corelccam,4300,tcp,Corel CCam,[Jason_Aiken],[Jason_Aiken],,,,,,
+corelccam,4300,udp,Corel CCam,[Jason_Aiken],[Jason_Aiken],,,,,,
+d-data,4301,tcp,Diagnostic Data,,,,,,,,
+d-data,4301,udp,Diagnostic Data,,,,,,,,
+d-data-control,4302,tcp,Diagnostic Data Control,[Jon_March],[Jon_March],2006-09,,,,,
+d-data-control,4302,udp,Diagnostic Data Control,[Jon_March],[Jon_March],2006-09,,,,,
+srcp,4303,tcp,Simple Railroad Command Protocol,[Matthias_Trute],[Matthias_Trute],2007-01,,,,,
+srcp,4303,udp,Simple Railroad Command Protocol,[Matthias_Trute],[Matthias_Trute],2007-01,,,,,
+owserver,4304,tcp,One-Wire Filesystem Server,[Paul_Alfille],[Paul_Alfille],2007-01,,,,,Defined TXT keys: txtvers
+owserver,4304,udp,One-Wire Filesystem Server,[Paul_Alfille],[Paul_Alfille],2007-01,,,,,Defined TXT keys: txtvers
+batman,4305,tcp,better approach to mobile ad-hoc networking,[Simon_Wunderlich],[Simon_Wunderlich],2007-08-30,,,,,
+batman,4305,udp,better approach to mobile ad-hoc networking,[Simon_Wunderlich],[Simon_Wunderlich],2007-08-30,,,,,
+pinghgl,4306,tcp,Hellgate London,[David_Berk],[David_Berk],2007-08-30,,,,,
+pinghgl,4306,udp,Hellgate London,[David_Berk],[David_Berk],2007-08-30,,,,,
+visicron-vs,4307,tcp,Visicron Videoconference Service,[Alexey_Vlaskin],[Alexey_Vlaskin],2007-10-22,,,,,
+visicron-vs,4307,udp,Visicron Videoconference Service,[Alexey_Vlaskin],[Alexey_Vlaskin],2007-10-22,,,,,
+compx-lockview,4308,tcp,CompX-LockView,[John_Payson],[John_Payson],2007-10-22,,,,,
+compx-lockview,4308,udp,CompX-LockView,[John_Payson],[John_Payson],2007-10-22,,,,,
+dserver,4309,tcp,Exsequi Appliance Discovery,[Angelo_Masci],[Angelo_Masci],2007-01,,,,,
+dserver,4309,udp,Exsequi Appliance Discovery,[Angelo_Masci],[Angelo_Masci],2007-01,,,,,
+mirrtex,4310,tcp,Mir-RT exchange service,[Sylvain_Robert],[Sylvain_Robert],2008-02-14,,,,,
+mirrtex,4310,udp,Mir-RT exchange service,[Sylvain_Robert],[Sylvain_Robert],2008-02-14,,,,,
+p6ssmc,4311,tcp,P6R Secure Server Management Console,[Jim_Susoy],[Jim_Susoy],2010-01-21,,,,,
+,4311,udp,Reserved,,,,,,,,
+pscl-mgt,4312,tcp,Parascale Membership Manager,[John_Muth],[John_Muth],2010-01-21,,,,,
+,4312,udp,Reserved,,,,,,,,
+perrla,4313,tcp,PERRLA User Services,[Cliff_Batson],[Cliff_Batson],2010-01-21,,,,,
+,4313,udp,Reserved,,,,,,,,
+choiceview-agt,4314,tcp,ChoiceView Agent,[Radish_Systems],[Richard_A_Davis],2013-03-28,,,,,
+,4314,udp,Reserved,,,,,,,,
+,4315,,Unassigned,,,,,,,Unauthorized Use Known on port 4315,
+choiceview-clt,4316,tcp,ChoiceView Client,[Radish_Systems],[Richard_A_Davis],2013-03-28,,,,,
+,4316,udp,Reserved,,,,,,,,
+,4317-4319,,Unassigned,,,,,,,,
+fdt-rcatp,4320,tcp,FDT Remote Categorization Protocol,[Russell_P_Holsclaw],[Russell_P_Holsclaw],2006-03,,,,,
+fdt-rcatp,4320,udp,FDT Remote Categorization Protocol,[Russell_P_Holsclaw],[Russell_P_Holsclaw],2006-03,,,,,
+rwhois,4321,tcp,Remote Who Is,[Mark_Kosters],[Mark_Kosters],,,[RFC2167],,,
+rwhois,4321,udp,Remote Who Is,[Mark_Kosters],[Mark_Kosters],,,[RFC2167],,,
+trim-event,4322,tcp,TRIM Event Service,,,,,,,,
+trim-event,4322,udp,TRIM Event Service,,,,,,,,
+trim-ice,4323,tcp,TRIM ICE Service,[Siva_Poobalasingam_2],[Siva_Poobalasingam_2],2007-02,,,,,
+trim-ice,4323,udp,TRIM ICE Service,[Siva_Poobalasingam_2],[Siva_Poobalasingam_2],2007-02,,,,,
+balour,4324,tcp,Balour Game Server,[Konstantin_Schauweck],[Konstantin_Schauweck],2007-02,,,,,
+balour,4324,udp,Balour Game Server,[Konstantin_Schauweck],[Konstantin_Schauweck],2007-02,,,,,
+geognosisman,4325,tcp,Cadcorp GeognoSIS Manager Service,,,,,,,,
+geognosisman,4325,udp,Cadcorp GeognoSIS Manager Service,,,,,,,,
+geognosis,4326,tcp,Cadcorp GeognoSIS Service,[Martin_Daly],[Martin_Daly],2006-11,,,,,
+geognosis,4326,udp,Cadcorp GeognoSIS Service,[Martin_Daly],[Martin_Daly],2006-11,,,,,
+jaxer-web,4327,tcp,Jaxer Web Protocol,[Uri_Sarid],[Uri_Sarid],2008-01-07,,,,,
+jaxer-web,4327,udp,Jaxer Web Protocol,[Uri_Sarid],[Uri_Sarid],2008-01-07,,,,,
+jaxer-manager,4328,tcp,Jaxer Manager Command Protocol,[Uri_Sarid],[Uri_Sarid],2008-01-22,,,,,
+jaxer-manager,4328,udp,Jaxer Manager Command Protocol,[Uri_Sarid],[Uri_Sarid],2008-01-22,,,,,
+publiqare-sync,4329,tcp,PubliQare Distributed Environment Synchronisation Engine,[Tom_Maaswinkel],[Tom_Maaswinkel],2011-02-07,,,,,
+,4329,udp,Reserved,,,,,,,,
+dey-sapi,4330,tcp,DEY Storage Administration REST API,[DEY_Storage_Systems_Inc],[Garrett_D_Amore],2013-03-01,,,,,
+,4330,udp,Reserved,,,,,,,,
+ktickets-rest,4331,tcp,ktickets REST API for event management and ticketing systems (embedded POS devices),[KeyTicket_Solutions],[MANG_Ioan-Alexandru],2014-04-04,,,,,
+,4331,udp,Reserved,,,,,,,,
+,4332,,Unassigned,,,,,,,,
+ahsp,4333,tcp,ArrowHead Service Protocol (AHSP),[QuantuMatriX_Technologies],[Matthew_Schultz],2014-04-10,,,,,
+ahsp,4333,udp,ArrowHead Service Protocol (AHSP),[QuantuMatriX_Technologies],[Matthew_Schultz],2014-04-10,,,,,
+ahsp,4333,sctp,ArrowHead Service Protocol (AHSP),[QuantuMatriX_Technologies],[Matthew_Schultz],2014-04-10,,,,,
+,4334-4339,,Unassigned,,,,,,,,
+gaia,4340,tcp,Gaia Connector Protocol,[Philippe_Detournay],[Philippe_Detournay],2007-11-12,,,,,
+gaia,4340,udp,Gaia Connector Protocol,[Philippe_Detournay],[Philippe_Detournay],2007-11-12,,,,,
+lisp-data,4341,tcp,LISP Data Packets,[Dino_Farinacci],[Dino_Farinacci],2007-11-12,,,,,
+lisp-data,4341,udp,LISP Data Packets,[IESG],[IETF_Chair],2007-11-12,2012-04-26,[RFC6830],,,
+lisp-cons,4342,tcp,LISP-CONS Control,,,,,,,,
+lisp-control,4342,udp,LISP Control Packets,[IESG],[IETF_Chair],2007-05,2012-04-26,[RFC6830],,,
+unicall,4343,tcp,UNICALL,[James_Powell_2],[James_Powell_2],,,,,,
+unicall,4343,udp,UNICALL,[James_Powell_2],[James_Powell_2],,,,,,
+vinainstall,4344,tcp,VinaInstall,[Jay_Slupesky],[Jay_Slupesky],,,,,,
+vinainstall,4344,udp,VinaInstall,[Jay_Slupesky],[Jay_Slupesky],,,,,,
+m4-network-as,4345,tcp,Macro 4 Network AS,[Paul_Wren],[Paul_Wren],,,,,,
+m4-network-as,4345,udp,Macro 4 Network AS,[Paul_Wren],[Paul_Wren],,,,,,
+elanlm,4346,tcp,ELAN LM,[Paul_Ballew],[Paul_Ballew],,,,,,
+elanlm,4346,udp,ELAN LM,[Paul_Ballew],[Paul_Ballew],,,,,,
+lansurveyor,4347,tcp,LAN Surveyor,[Michael_Swan],[Michael_Swan],,,,,,
+lansurveyor,4347,udp,LAN Surveyor,[Michael_Swan],[Michael_Swan],,,,,,
+itose,4348,tcp,ITOSE,[Michael_Haeuptle],[Michael_Haeuptle],,,,,,
+itose,4348,udp,ITOSE,[Michael_Haeuptle],[Michael_Haeuptle],,,,,,
+fsportmap,4349,tcp,File System Port Map,[Ron_Minnich_2],[Ron_Minnich_2],,,,,,
+fsportmap,4349,udp,File System Port Map,[Ron_Minnich_2],[Ron_Minnich_2],,,,,,
+net-device,4350,tcp,Net Device,[Glenn_Peterson],[Glenn_Peterson],,,,,,
+net-device,4350,udp,Net Device,[Glenn_Peterson],[Glenn_Peterson],,,,,,
+plcy-net-svcs,4351,tcp,PLCY Net Services,[J_J_Ekstrom],[J_J_Ekstrom],,,,,,
+plcy-net-svcs,4351,udp,PLCY Net Services,[J_J_Ekstrom],[J_J_Ekstrom],,,,,,
+pjlink,4352,tcp,Projector Link,[Mitsuo_Kodama],[Mitsuo_Kodama],2005-06,,,,,
+pjlink,4352,udp,Projector Link,[Mitsuo_Kodama],[Mitsuo_Kodama],2005-06,,,,,
+f5-iquery,4353,tcp,F5 iQuery,[Tom_Kee],[Tom_Kee],,,,,,
+f5-iquery,4353,udp,F5 iQuery,[Tom_Kee],[Tom_Kee],,,,,,
+qsnet-trans,4354,tcp,QSNet Transmitter,,,,,,,,
+qsnet-trans,4354,udp,QSNet Transmitter,,,,,,,,
+qsnet-workst,4355,tcp,QSNet Workstation,,,,,,,,
+qsnet-workst,4355,udp,QSNet Workstation,,,,,,,,
+qsnet-assist,4356,tcp,QSNet Assistant,,,,,,,,
+qsnet-assist,4356,udp,QSNet Assistant,,,,,,,,
+qsnet-cond,4357,tcp,QSNet Conductor,,,,,,,,
+qsnet-cond,4357,udp,QSNet Conductor,,,,,,,,
+qsnet-nucl,4358,tcp,QSNet Nucleus,[Neer_Kleinman],[Neer_Kleinman],,,,,,
+qsnet-nucl,4358,udp,QSNet Nucleus,[Neer_Kleinman],[Neer_Kleinman],,,,,,
+omabcastltkm,4359,tcp,OMA BCAST Long-Term Key Messages,[Frank_Hartung],[Frank_Hartung],2007-09-07,,,,,
+omabcastltkm,4359,udp,OMA BCAST Long-Term Key Messages,[Frank_Hartung],[Frank_Hartung],2007-09-07,,,,,
+matrix-vnet,4360,tcp,"Matrix VNet Communication Protocol
+IANA assigned this well-formed service name as a replacement for ""matrix_vnet"".",[Rehan_Mahmood],[Rehan_Mahmood],2009-03-18,,,,,
+matrix_vnet,4360,tcp,Matrix VNet Communication Protocol,[Rehan_Mahmood],[Rehan_Mahmood],2009-03-18,,,,,"This entry is an alias to ""matrix-vnet"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+,4360,udp,Reserved,,,,,,,,
+,4361,tcp,Reserved,,,,,,,,
+nacnl,4361,udp,NavCom Discovery and Control Port,[Yilei_Jia],[Yilei_Jia],2009-03-18,,,,,
+,4362,tcp,Reserved,,,,,,,,
+afore-vdp-disc,4362,udp,AFORE vNode Discovery protocol,[Michael_Richardson],[Michael_Richardson],2011-02-08,,,,,
+,4363-4367,,Unassigned,,,,,,,,
+wxbrief,4368,tcp,WeatherBrief Direct,[Kim_Alan_Waggoner],[Kim_Alan_Waggoner],2006-11,,,,,
+wxbrief,4368,udp,WeatherBrief Direct,[Kim_Alan_Waggoner],[Kim_Alan_Waggoner],2006-11,,,,,
+epmd,4369,tcp,Erlang Port Mapper Daemon,[Erlang],[Erlang],,,,,,
+epmd,4369,udp,Erlang Port Mapper Daemon,[Erlang],[Erlang],,,,,,
+elpro-tunnel,4370,tcp,"ELPRO V2 Protocol Tunnel
+IANA assigned this well-formed service name as a replacement for ""elpro_tunnel"".",[Harry_Courtice],[Harry_Courtice],2008-04-14,,,,,
+elpro_tunnel,4370,tcp,ELPRO V2 Protocol Tunnel,[Harry_Courtice],[Harry_Courtice],2008-04-14,,,,,"This entry is an alias to ""elpro-tunnel"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+elpro-tunnel,4370,udp,"ELPRO V2 Protocol Tunnel
+IANA assigned this well-formed service name as a replacement for ""elpro_tunnel"".",[Harry_Courtice],[Harry_Courtice],2008-04-14,,,,,
+elpro_tunnel,4370,udp,ELPRO V2 Protocol Tunnel,[Harry_Courtice],[Harry_Courtice],2008-04-14,,,,,"This entry is an alias to ""elpro-tunnel"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+l2c-control,4371,tcp,LAN2CAN Control,[Phil_Tolson],[Phil_Tolson],2008-07-07,,,,,Modified: 21 January 2010
+l2c-disc,4371,udp,LAN2CAN Discovery,[Phil_Tolson],[Phil_Tolson],2010-01-21,,,,,
+l2c-data,4372,tcp,LAN2CAN Data,[Phil_Tolson],[Phil_Tolson],2008-07-07,,,,,Modified: 21 January 2010
+l2c-data,4372,udp,LAN2CAN Data,[Phil_Tolson],[Phil_Tolson],2010-01-21,,,,,
+remctl,4373,tcp,Remote Authenticated Command Service,[Russ_Allbery],[Russ_Allbery],2007-08-30,,,,,
+remctl,4373,udp,Remote Authenticated Command Service,[Russ_Allbery],[Russ_Allbery],2007-08-30,,,,,
+psi-ptt,4374,tcp,PSI Push-to-Talk Protocol,[Frank_B],[Frank_B],2008-07-17,,,,,
+,4374,udp,Reserved,,,,,,,,
+tolteces,4375,tcp,Toltec EasyShare,[Joon_Radley_2],[Joon_Radley_2],2008-10-21,,,,,
+tolteces,4375,udp,Toltec EasyShare,[Joon_Radley_2],[Joon_Radley_2],2008-10-21,,,,,
+bip,4376,tcp,BioAPI Interworking,[Jean_Paul_Lemaire],[Jean_Paul_Lemaire],2007-07-05,,,,,
+bip,4376,udp,BioAPI Interworking,[Jean_Paul_Lemaire],[Jean_Paul_Lemaire],2007-07-05,,,,,
+cp-spxsvr,4377,tcp,Cambridge Pixel SPx Server,,,,,,,,
+cp-spxsvr,4377,udp,Cambridge Pixel SPx Server,,,,,,,,
+cp-spxdpy,4378,tcp,Cambridge Pixel SPx Display,[Richard_Warren],[Richard_Warren],2007-07-05,,,,,
+cp-spxdpy,4378,udp,Cambridge Pixel SPx Display,[Richard_Warren],[Richard_Warren],2007-07-05,,,,,
+ctdb,4379,tcp,CTDB,[Ronnie_Sahlberg],[Ronnie_Sahlberg],2007-07-05,,,,,
+ctdb,4379,udp,CTDB,[Ronnie_Sahlberg],[Ronnie_Sahlberg],2007-07-05,,,,,
+,4380-4388,,Unassigned,,,,,,,,
+xandros-cms,4389,tcp,Xandros Community Management Service,[Stephen_M_Webb],[Stephen_M_Webb],2007-05,,,,,
+xandros-cms,4389,udp,Xandros Community Management Service,[Stephen_M_Webb],[Stephen_M_Webb],2007-05,,,,,
+wiegand,4390,tcp,Physical Access Control,[Scott_Guthery_2],[Scott_Guthery_2],2008-08-25,,,,,
+wiegand,4390,udp,Physical Access Control,[Scott_Guthery_2],[Scott_Guthery_2],2008-08-25,,,,,
+apwi-imserver,4391,tcp,American Printware IMServer Protocol,[Lech_Lakomy],[Lech_Lakomy],2009-02-12,,,,,
+,4391,udp,Reserved,,,,,,,,
+apwi-rxserver,4392,tcp,American Printware RXServer Protocol,[Lech_Lakomy],[Lech_Lakomy],2009-02-12,,,,,
+,4392,udp,Reserved,,,,,,,,
+apwi-rxspooler,4393,tcp,American Printware RXSpooler Protocol,[Lech_Lakomy],[Lech_Lakomy],2009-02-12,,,,,
+,4393,udp,Reserved,,,,,,,,
+,4394,tcp,Reserved,,,,,,,,
+apwi-disc,4394,udp,American Printware Discovery,[Lech_Lakomy],[Lech_Lakomy],2009-02-12,,,,,
+omnivisionesx,4395,tcp,OmniVision communication for Virtual environments,[Vacquier_Serge],[Vacquier_Serge],2009-02-12,,,,,
+omnivisionesx,4395,udp,OmniVision communication for Virtual environments,[Vacquier_Serge],[Vacquier_Serge],2009-02-12,,,,,
+fly,4396,tcp,Fly Object Space,[Nigel_Warren],[Nigel_Warren],2009-02-12,,,,,
+,4396,udp,Reserved,,,,,,,,
+,4397-4399,,Unassigned,,,,,,,,
+ds-srv,4400,tcp,ASIGRA Services,[David_Farajun],[David_Farajun],2004-11,,,,,
+ds-srv,4400,udp,ASIGRA Services,[David_Farajun],[David_Farajun],2004-11,,,,,
+ds-srvr,4401,tcp,ASIGRA Televaulting DS-System Service,,,,,,,,
+ds-srvr,4401,udp,ASIGRA Televaulting DS-System Service,,,,,,,,
+ds-clnt,4402,tcp,ASIGRA Televaulting DS-Client Service,,,,,,,,
+ds-clnt,4402,udp,ASIGRA Televaulting DS-Client Service,,,,,,,,
+ds-user,4403,tcp,ASIGRA Televaulting DS-Client Monitoring/Management,,,,,,,,
+ds-user,4403,udp,ASIGRA Televaulting DS-Client Monitoring/Management,,,,,,,,
+ds-admin,4404,tcp,ASIGRA Televaulting DS-System Monitoring/Management,,,,,,,,
+ds-admin,4404,udp,ASIGRA Televaulting DS-System Monitoring/Management,,,,,,,,
+ds-mail,4405,tcp,ASIGRA Televaulting Message Level Restore service,,,,,,,,
+ds-mail,4405,udp,ASIGRA Televaulting Message Level Restore service,,,,,,,,
+ds-slp,4406,tcp,ASIGRA Televaulting DS-Sleeper Service,[Andrei_Litvinn],[Andrei_Litvinn],2005-01,,,,,
+ds-slp,4406,udp,ASIGRA Televaulting DS-Sleeper Service,[Andrei_Litvinn],[Andrei_Litvinn],2005-01,,,,,
+nacagent,4407,tcp,Network Access Control Agent,[ITGroup],[ITGroup],2008-06-30,,,,,
+,4407,udp,Reserved,,,,,,,,
+slscc,4408,tcp,SLS Technology Control Centre,[Steven_Sweeting],[Steven_Sweeting],2008-01-28,,,,,
+,4408,udp,Reserved,,,,,,,,
+netcabinet-com,4409,tcp,Net-Cabinet comunication,[Ian_Manning_2],[Ian_Manning_2],2009-12-16,,,,,
+,4409,udp,Reserved,,,,,,,,
+itwo-server,4410,tcp,RIB iTWO Application Server,[Kristean_Heisler_2],[Kristean_Heisler_2],2009-12-16,,,,,
+,4410,udp,Reserved,,,,,,,,
+found,4411,tcp,Found Messaging Protocol,[Found_Software],[John_Mitchell],2012-04-11,,,,,"Defined TXT keys: id, key"
+,4411,udp,Reserved,,,,,,,,
+,4412-4424,,Unassigned,,,,,,,,
+netrockey6,4425,tcp,NetROCKEY6 SMART Plus Service,[Feitian_Technologies],[Feitian_Technologies],2010-09-15,,,,,
+netrockey6,4425,udp,NetROCKEY6 SMART Plus Service,[Feitian_Technologies],[Feitian_Technologies],2010-09-15,,,,,
+beacon-port-2,4426,tcp,SMARTS Beacon Port,[Eyal_Yardeni],[Eyal_Yardeni],2003-11,,,,,
+beacon-port-2,4426,udp,SMARTS Beacon Port,[Eyal_Yardeni],[Eyal_Yardeni],2003-11,,,,,
+drizzle,4427,tcp,Drizzle database server,[Elliot_Murphy],[Elliot_Murphy],2008-07-09,,,,,
+,4427,udp,Reserved,,,,,,,,
+omviserver,4428,tcp,OMV-Investigation Server-Client,[Serge_Vacquier],[Serge_Vacquier],2009-05-20,,,,,
+,4428,udp,Reserved,,,,,,,,
+omviagent,4429,tcp,OMV Investigation Agent-Server,[Serge_Vacquier],[Serge_Vacquier],2009-05-20,,,,,
+,4429,udp,Reserved,,,,,,,,
+rsqlserver,4430,tcp,REAL SQL Server,[Marco_Bambini],[Marco_Bambini],2008-08-28,,,,,
+rsqlserver,4430,udp,REAL SQL Server,[Marco_Bambini],[Marco_Bambini],2008-08-28,,,,,
+wspipe,4431,tcp,adWISE Pipe,[Heikki_E],[Heikki_E],2009-06-18,,,,,
+,4431,udp,Reserved,,,,,,,,
+l-acoustics,4432,tcp,L-ACOUSTICS management,[L-ACOUSTICS],[Christophe_Pignon],2012-08-13,,,,,
+l-acoustics,4432,udp,L-ACOUSTICS management,[L-ACOUSTICS],[Christophe_Pignon],2012-08-13,,,,,
+vop,4433,tcp,Versile Object Protocol,[Versile_AS],[Tore_Skaug],2012-02-01,,,,,
+,4433,udp,Reserved,,,,,,,,
+,4434-4440,,Unassigned,,,,,,,,
+,4441,tcp,Reserved,,,,,,,,
+netblox,4441,udp,Netblox Protocol,[Brian_S_Locke],[Brian_S_Locke],2008-07-10,,,,,
+saris,4442,tcp,Saris,,,,,,,,
+saris,4442,udp,Saris,,,,,,,,
+pharos,4443,tcp,Pharos,[TeleConsult],[TeleConsult],,,,,Known Unauthorized Use on port 4443,
+pharos,4443,udp,Pharos,[TeleConsult],[TeleConsult],,,,,Known Unauthorized Use on port 4443,
+krb524,4444,tcp,KRB524,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,"krb524 assigned the port, nv used it without an assignment",
+krb524,4444,udp,KRB524,[B_Clifford_Neuman],[B_Clifford_Neuman],,,,,"krb524 assigned the port, nv used it without an assignment",
+nv-video,4444,tcp,NV Video default,[Ron_Frederick],[Ron_Frederick],,,,,"krb524 assigned the port, nv used it without an assignment",
+nv-video,4444,udp,NV Video default,[Ron_Frederick],[Ron_Frederick],,,,,"krb524 assigned the port, nv used it without an assignment",
+upnotifyp,4445,tcp,UPNOTIFYP,[Mark_Fox],[Mark_Fox],,,,,,
+upnotifyp,4445,udp,UPNOTIFYP,[Mark_Fox],[Mark_Fox],,,,,,
+n1-fwp,4446,tcp,N1-FWP,,,,,,,,
+n1-fwp,4446,udp,N1-FWP,,,,,,,,
+n1-rmgmt,4447,tcp,N1-RMGMT,[Lori_Tassin],[Lori_Tassin],,,,,,
+n1-rmgmt,4447,udp,N1-RMGMT,[Lori_Tassin],[Lori_Tassin],,,,,,
+asc-slmd,4448,tcp,ASC Licence Manager,[Casper_Stoel],[Casper_Stoel],,,,,,
+asc-slmd,4448,udp,ASC Licence Manager,[Casper_Stoel],[Casper_Stoel],,,,,,
+privatewire,4449,tcp,PrivateWire,[Uri_Resnitzky],[Uri_Resnitzky],,,,,,
+privatewire,4449,udp,PrivateWire,[Uri_Resnitzky],[Uri_Resnitzky],,,,,,
+camp,4450,tcp,Common ASCII Messaging Protocol,[Control_Technology_Inc],[Clint_Eskew],,2011-10-28,,,,
+camp,4450,udp,Common ASCII Messaging Protocol,[Control_Technology_Inc],[Clint_Eskew],,2011-10-28,,,,
+ctisystemmsg,4451,tcp,CTI System Msg,[Control_Technology_Inc],[Clint_Eskew],,2011-10-28,,,,
+ctisystemmsg,4451,udp,CTI System Msg,[Control_Technology_Inc],[Clint_Eskew],,2011-10-28,,,,
+ctiprogramload,4452,tcp,CTI Program Load,[Control_Technology_Inc],[Clint_Eskew],,2011-10-28,,,,
+ctiprogramload,4452,udp,CTI Program Load,[Control_Technology_Inc],[Clint_Eskew],,2011-10-28,,,,
+nssalertmgr,4453,tcp,NSS Alert Manager,,,,,,,,
+nssalertmgr,4453,udp,NSS Alert Manager,,,,,,,,
+nssagentmgr,4454,tcp,NSS Agent Manager,[Jim_Hill],[Jim_Hill],,,,,,
+nssagentmgr,4454,udp,NSS Agent Manager,[Jim_Hill],[Jim_Hill],,,,,,
+prchat-user,4455,tcp,PR Chat User,,,,,,,,
+prchat-user,4455,udp,PR Chat User,,,,,,,,
+prchat-server,4456,tcp,PR Chat Server,,,,,,,,
+prchat-server,4456,udp,PR Chat Server,,,,,,,,
+prRegister,4457,tcp,PR Register,[Donny_Gilor],[Donny_Gilor],,,,,,
+prRegister,4457,udp,PR Register,[Donny_Gilor],[Donny_Gilor],,,,,,
+mcp,4458,tcp,Matrix Configuration Protocol,[Tim_DeBaillie],[Tim_DeBaillie],2006-12,,,,,
+mcp,4458,udp,Matrix Configuration Protocol,[Tim_DeBaillie],[Tim_DeBaillie],2006-12,,,,,
+,4459-4483,,Unassigned,,,,,,,,
+hpssmgmt,4484,tcp,hpssmgmt service,[David_Straw],[David_Straw],2005-11,,,,,
+hpssmgmt,4484,udp,hpssmgmt service,[David_Straw],[David_Straw],2005-11,,,,,
+assyst-dr,4485,tcp,Assyst Data Repository Service,[Albert_Cester],[Albert_Cester],2008-08-26,,,,,
+,4485,udp,Reserved,,,,,,,,
+icms,4486,tcp,Integrated Client Message Service,[Resource_Allocation],[Resource_Allocation],2010-09-27,,,,,
+icms,4486,udp,Integrated Client Message Service,[Resource_Allocation],[Resource_Allocation],2010-09-27,,,,,
+prex-tcp,4487,tcp,Protocol for Remote Execution over TCP,[Daniel_Ruppert],[Daniel_Ruppert],2010-09-16,,,,,
+,4487,udp,Reserved,,,,,,,,
+awacs-ice,4488,tcp,Apple Wide Area Connectivity Service ICE Bootstrap,[Rory_McGuire],[Rory_McGuire],2010-09-24,,,,,
+awacs-ice,4488,udp,Apple Wide Area Connectivity Service ICE Bootstrap,[Rory_McGuire],[Rory_McGuire],2010-09-24,,,,,
+,4489-4499,,Unassigned,,,,,,,Known UNAUTHORIZED USE: Ports 4490 and 4491,
+ipsec-nat-t,4500,tcp,IPsec NAT-Traversal,,,,,[RFC3947],,,
+ipsec-nat-t,4500,udp,IPsec NAT-Traversal,,,,,[RFC3947],,,
+,4501,,Unassigned,[IANA],[IANA],,,,,,De-registered 08 June 2001
+a25-fap-fgw,4502,sctp,A25 (FAP-FGW),[ThreeGPP2],[Zhiming_Li],2012-01-11,,,,,
+,4503-4533,,Unassigned,,,,,,,,
+,4534,tcp,Reserved,,,,,,,,
+armagetronad,4534,udp,Armagetron Advanced Game Server,[Manuel_Moos],[Yann_Kaiser],2012-11-02,,,,,
+ehs,4535,tcp,Event Heap Server,,,,,,,,
+ehs,4535,udp,Event Heap Server,,,,,,,,
+ehs-ssl,4536,tcp,Event Heap Server SSL,[Brad_Johanson],[Brad_Johanson],2005-08,,,,,
+ehs-ssl,4536,udp,Event Heap Server SSL,[Brad_Johanson],[Brad_Johanson],2005-08,,,,,
+wssauthsvc,4537,tcp,WSS Security Service,[Mark_Tirschwell],[Mark_Tirschwell],2006-01,,,,,
+wssauthsvc,4537,udp,WSS Security Service,[Mark_Tirschwell],[Mark_Tirschwell],2006-01,,,,,
+swx-gate,4538,tcp,Software Data Exchange Gateway,[Julien_VALIENTE],[Julien_VALIENTE],2006-05,,,,,
+swx-gate,4538,udp,Software Data Exchange Gateway,[Julien_VALIENTE],[Julien_VALIENTE],2006-05,,,,,
+,4539-4544,,Unassigned,,,,,,,,
+worldscores,4545,tcp,WorldScores,[Steve_Davis],[Steve_Davis],,,,,,
+worldscores,4545,udp,WorldScores,[Steve_Davis],[Steve_Davis],,,,,,
+sf-lm,4546,tcp,SF License Manager (Sentinel),[Thomas_Koell],[Thomas_Koell],,,,,,
+sf-lm,4546,udp,SF License Manager (Sentinel),[Thomas_Koell],[Thomas_Koell],,,,,,
+lanner-lm,4547,tcp,Lanner License Manager,[Les_Enstone],[Les_Enstone],,,,,,
+lanner-lm,4547,udp,Lanner License Manager,[Les_Enstone],[Les_Enstone],,,,,,
+synchromesh,4548,tcp,Synchromesh,[Tom_Hawkins_2],[Tom_Hawkins_2],2006-02,,,,,
+synchromesh,4548,udp,Synchromesh,[Tom_Hawkins_2],[Tom_Hawkins_2],2006-02,,,,,
+aegate,4549,tcp,Aegate PMR Service,[Nick_Warrington],[Nick_Warrington],2006-03,,,,,
+aegate,4549,udp,Aegate PMR Service,[Nick_Warrington],[Nick_Warrington],2006-03,,,,,
+gds-adppiw-db,4550,tcp,Perman I Interbase Server,[Leo_Lesage],[Leo_Lesage],2006-04,,,,,
+gds-adppiw-db,4550,udp,Perman I Interbase Server,[Leo_Lesage],[Leo_Lesage],2006-04,,,,,
+ieee-mih,4551,tcp,MIH Services,,,,,[RFC5677],,,
+ieee-mih,4551,udp,MIH Services,,,,,[RFC5677],,,
+menandmice-mon,4552,tcp,Men and Mice Monitoring,[Carsten_Strotmann],[Carsten_Strotmann],2009-05-20,,,,,
+menandmice-mon,4552,udp,Men and Mice Monitoring,[Carsten_Strotmann],[Carsten_Strotmann],2009-05-20,,,,,
+icshostsvc,4553,tcp,ICS host services,[Gordan_Vosicki],[Gordan_Vosicki],2009-09-23,,,,,
+,4553,udp,Reserved,,,,,,,,
+msfrs,4554,tcp,MS FRS Replication,[Kev_George],[Kev_George],2006-09,,,,,
+msfrs,4554,udp,MS FRS Replication,[Kev_George],[Kev_George],2006-09,,,,,
+rsip,4555,tcp,RSIP Port,,,,,[RFC3103],,,
+rsip,4555,udp,RSIP Port,,,,,[RFC3103],,,
+dtn-bundle,4556,tcp,DTN Bundle TCP CL Protocol,[Simon_Perreault],[Simon_Perreault],,2014-03-12,[RFC7242],,,
+dtn-bundle,4556,udp,DTN Bundle UDP CL Protocol,,,2006-11,2014-02-21,[RFC7122],,,
+dtn-bundle,4556,dccp,DTN Bundle DCCP CL Protocol,,,2013-11-12,2014-02-21,[RFC7122],1685351985,,
+,4557,tcp,Reserved,,,,,,,,
+mtcevrunqss,4557,udp,Marathon everRun Quorum Service Server,[David_Schwartz_2],[David_Schwartz_2],2009-06-18,,,,,
+,4558,tcp,Reserved,,,,,,,,
+mtcevrunqman,4558,udp,Marathon everRun Quorum Service Manager,[David_Schwartz_2],[David_Schwartz_2],2009-06-18,,,,,
+hylafax,4559,tcp,HylaFAX,[Lee_Howard],[Lee_Howard],2002-03,,,,,
+hylafax,4559,udp,HylaFAX,[Lee_Howard],[Lee_Howard],2002-03,,,,,
+,4560-4562,,Unassigned,,,,,,,,
+amahi-anywhere,4563,tcp,Amahi Anywhere,[Amahi],[Carlos_Puchol],2014-02-27,,,,,
+,4563,udp,Reserved,,,,,,,,
+,4564-4565,,Unassigned,,,,,,,,
+kwtc,4566,tcp,Kids Watch Time Control Service,[Larry_Zarou],[Larry_Zarou],2006-10,,,,,
+kwtc,4566,udp,Kids Watch Time Control Service,[Larry_Zarou],[Larry_Zarou],2006-10,,,,,
+tram,4567,tcp,TRAM,[Joe_Wesley],[Joe_Wesley],,,,,,
+tram,4567,udp,TRAM,[Joe_Wesley],[Joe_Wesley],,,,,,
+bmc-reporting,4568,tcp,BMC Reporting,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmc-reporting,4568,udp,BMC Reporting,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+iax,4569,tcp,Inter-Asterisk eXchange,[Benjamin_Kowarsch],[Benjamin_Kowarsch],,,[RFC5456],,,"Defined TXT keys:
+ auth plaintext | md5 | rsakeys
+ userid alphanumeric, additionally '_', '+', '-'
+ secret any printable ASCII characters
+ domain any DNS domain name or IP address
+ extension alphanumeric, additionally '*', '#', '_', '+', '-'
+ context alphanumeric, additionally '_', '+', '-'
+ trunk yes | no | 0 | 1
+ welcome alphanumeric, additionally '*', '#', '_', '+', '-'
+ voicemail alphanumeric, additionally '*', '#', '_', '+', '-'
+ reception alphanumeric, additionally '*', '#', '_', '+', '-'
+ echotest alphanumeric, additionally '*', '#', '_', '+', '-'
+ ivrtest alphanumeric, additionally '*', '#', '_', '+', '-'
+All of these TXT record keys are optional, they may be omitted.
+Further keys may be added in the future."
+iax,4569,udp,Inter-Asterisk eXchange,[Benjamin_Kowarsch],[Benjamin_Kowarsch],,,[RFC5456],,,"Defined TXT keys:
+ auth plaintext | md5 | rsakeys
+ userid alphanumeric, additionally '_', '+', '-'
+ secret any printable ASCII characters
+ domain any DNS domain name or IP address
+ extension alphanumeric, additionally '*', '#', '_', '+', '-'
+ context alphanumeric, additionally '_', '+', '-'
+ trunk yes | no | 0 | 1
+ welcome alphanumeric, additionally '*', '#', '_', '+', '-'
+ voicemail alphanumeric, additionally '*', '#', '_', '+', '-'
+ reception alphanumeric, additionally '*', '#', '_', '+', '-'
+ echotest alphanumeric, additionally '*', '#', '_', '+', '-'
+ ivrtest alphanumeric, additionally '*', '#', '_', '+', '-'
+All of these TXT record keys are optional, they may be omitted.
+Further keys may be added in the future."
+deploymentmap,4570,tcp,Service to distribute and update within a site deployment information for Oracle Communications Suite,[Oracle_3],[Dan_Newman],2013-09-20,,,,,
+,4570,udp,Reserved,,,,,,,,
+,4571-4589,,Unassigned,,,,,,,,
+rid,4590,tcp,RID over HTTP/TLS,[IESG],[IETF_Chair],,,[RFC6546],,,
+,4590,udp,Reserved,,,,,,,,
+l3t-at-an,4591,tcp,HRPD L3T (AT-AN),[Avi_Lior],[Avi_Lior],2009-02-27,,,,,
+l3t-at-an,4591,udp,HRPD L3T (AT-AN),[Avi_Lior],[Avi_Lior],2009-02-27,,,,,
+,4592,tcp,Reserved,,,,,,,,
+hrpd-ith-at-an,4592,udp,HRPD-ITH (AT-AN),[David_Ott],[David_Ott],2008-06-05,,,,,
+ipt-anri-anri,4593,tcp,IPT (ANRI-ANRI),,,,,,,,
+ipt-anri-anri,4593,udp,IPT (ANRI-ANRI),,,,,,,,
+ias-session,4594,tcp,IAS-Session (ANRI-ANRI),,,,,,,,
+ias-session,4594,udp,IAS-Session (ANRI-ANRI),,,,,,,,
+ias-paging,4595,tcp,IAS-Paging (ANRI-ANRI),,,,,,,,
+ias-paging,4595,udp,IAS-Paging (ANRI-ANRI),,,,,,,,
+ias-neighbor,4596,tcp,IAS-Neighbor (ANRI-ANRI),[David_Ott],[David_Ott],2007-07-31,,,,,
+ias-neighbor,4596,udp,IAS-Neighbor (ANRI-ANRI),[David_Ott],[David_Ott],2007-07-31,,,,,
+a21-an-1xbs,4597,tcp,A21 (AN-1xBS),[David_Ott],[David_Ott],2006-02,,,,,
+a21-an-1xbs,4597,udp,A21 (AN-1xBS),[David_Ott],[David_Ott],2006-02,,,,,
+a16-an-an,4598,tcp,A16 (AN-AN),[David_Ott],[David_Ott],2005-12,,,,,
+a16-an-an,4598,udp,A16 (AN-AN),[David_Ott],[David_Ott],2005-12,,,,,
+a17-an-an,4599,tcp,A17 (AN-AN),[David_Ott],[David_Ott],2006-02,,,,,
+a17-an-an,4599,udp,A17 (AN-AN),[David_Ott],[David_Ott],2006-02,,,,,
+piranha1,4600,tcp,Piranha1,,,,,,,,
+piranha1,4600,udp,Piranha1,,,,,,,,
+piranha2,4601,tcp,Piranha2,[Primark_Corporation],[Primark_Corporation],,,,,,
+piranha2,4601,udp,Piranha2,[Primark_Corporation],[Primark_Corporation],,,,,,
+mtsserver,4602,tcp,EAX MTS Server,[Pedro_A_Rodriguez],[Pedro_A_Rodriguez],2008-08-06,,,,,
+,4602,udp,Reserved,,,,,,,,
+menandmice-upg,4603,tcp,Men & Mice Upgrade Agent,[Eggert_Thorlacius_2],[Eggert_Thorlacius_2],2010-01-27,,,,,
+,4603,udp,Reserved,,,,,,,,
+irp,4604,tcp,Identity Registration Protocol,[Sixscape_Communications_Pte_Ltd],[Lawrence_E._Hughes],2014-03-17,2014-08-26,,,,
+,4604,udp,Reserved,,,,,,,,
+sixchat,4605,tcp,Direct End to End Secure Chat Protocol,[Sixscape_Communications_Pte_Ltd],[Lawrence_E._Hughes],2014-09-11,,,,,
+,4605,udp,Reserved,,,,,,,,
+,4606-4657,,Unassigned,,,,,,,,
+playsta2-app,4658,tcp,PlayStation2 App Port,,,,,,,,
+playsta2-app,4658,udp,PlayStation2 App Port,,,,,,,,
+playsta2-lob,4659,tcp,PlayStation2 Lobby Port,[Noam_Rimon],[Noam_Rimon],2004-12,,,,,
+playsta2-lob,4659,udp,PlayStation2 Lobby Port,[Noam_Rimon],[Noam_Rimon],2004-12,,,,,
+smaclmgr,4660,tcp,smaclmgr,[Hiromi_Taki],[Hiromi_Taki],,,,,,
+smaclmgr,4660,udp,smaclmgr,[Hiromi_Taki],[Hiromi_Taki],,,,,,
+kar2ouche,4661,tcp,Kar2ouche Peer location service,[Andy_Krouwel],[Andy_Krouwel],,,,,,
+kar2ouche,4661,udp,Kar2ouche Peer location service,[Andy_Krouwel],[Andy_Krouwel],,,,,,
+oms,4662,tcp,OrbitNet Message Service,[Roy_Davies],[Roy_Davies],2005-08,,,,,
+oms,4662,udp,OrbitNet Message Service,[Roy_Davies],[Roy_Davies],2005-08,,,,,
+noteit,4663,tcp,Note It! Message Service,[Pedro_Alpedrinha],[Pedro_Alpedrinha],2006-02,,,,,
+noteit,4663,udp,Note It! Message Service,[Pedro_Alpedrinha],[Pedro_Alpedrinha],2006-02,,,,,
+ems,4664,tcp,Rimage Messaging Server,[David_V_Raskin],[David_V_Raskin],2006-02,,,,,
+ems,4664,udp,Rimage Messaging Server,[David_V_Raskin],[David_V_Raskin],2006-02,,,,,
+contclientms,4665,tcp,Container Client Message Service,[Bruce_Thompson],[Bruce_Thompson],2006-02,,,,,
+contclientms,4665,udp,Container Client Message Service,[Bruce_Thompson],[Bruce_Thompson],2006-02,,,,,
+eportcomm,4666,tcp,E-Port Message Service,,,,,,,,
+eportcomm,4666,udp,E-Port Message Service,,,,,,,,
+mmacomm,4667,tcp,MMA Comm Services,,,,,,,,
+mmacomm,4667,udp,MMA Comm Services,,,,,,,,
+mmaeds,4668,tcp,MMA EDS Service,[Robert_Shaffer],[Robert_Shaffer],2006-02,,,,,
+mmaeds,4668,udp,MMA EDS Service,[Robert_Shaffer],[Robert_Shaffer],2006-02,,,,,
+eportcommdata,4669,tcp,E-Port Data Service,[Robert_Shaffer],[Robert_Shaffer],2006-02,,,,,
+eportcommdata,4669,udp,E-Port Data Service,[Robert_Shaffer],[Robert_Shaffer],2006-02,,,,,
+light,4670,tcp,Light packets transfer protocol,[Adam_Golovenko],[Adam_Golovenko],2006-10,,,,,
+light,4670,udp,Light packets transfer protocol,[Adam_Golovenko],[Adam_Golovenko],2006-10,,,,,
+acter,4671,tcp,Bull RSF action server,[Christian_Caudrelier],[Christian_Caudrelier],2006-02,,,,,
+acter,4671,udp,Bull RSF action server,[Christian_Caudrelier],[Christian_Caudrelier],2006-02,,,,,
+rfa,4672,tcp,remote file access server,,,,,,,,
+rfa,4672,udp,remote file access server,,,,,,,,
+cxws,4673,tcp,CXWS Operations,[Phil_Abercrombie],[Phil_Abercrombie],2005-08,,,,,
+cxws,4673,udp,CXWS Operations,[Phil_Abercrombie],[Phil_Abercrombie],2005-08,,,,,
+appiq-mgmt,4674,tcp,AppIQ Agent Management,[Phil_Abercrombie],[Phil_Abercrombie],2005-08,,,,,
+appiq-mgmt,4674,udp,AppIQ Agent Management,[Phil_Abercrombie],[Phil_Abercrombie],2005-08,,,,,
+dhct-status,4675,tcp,BIAP Device Status,,,,,,,,
+dhct-status,4675,udp,BIAP Device Status,,,,,,,,
+dhct-alerts,4676,tcp,BIAP Generic Alert,[Louis_Slothouber],[Louis_Slothouber],2005-08,,,,,
+dhct-alerts,4676,udp,BIAP Generic Alert,[Louis_Slothouber],[Louis_Slothouber],2005-08,,,,,
+bcs,4677,tcp,Business Continuity Servi,[Siew_Sim],[Siew_Sim],2005-08,,,,,
+bcs,4677,udp,Business Continuity Servi,[Siew_Sim],[Siew_Sim],2005-08,,,,,
+traversal,4678,tcp,boundary traversal,[Kevin_Lu],[Kevin_Lu],2005-08,,,,,
+traversal,4678,udp,boundary traversal,[Kevin_Lu],[Kevin_Lu],2005-08,,,,,
+mgesupervision,4679,tcp,MGE UPS Supervision,,,,,,,,
+mgesupervision,4679,udp,MGE UPS Supervision,,,,,,,,
+mgemanagement,4680,tcp,MGE UPS Management,[Lecuivre_J],[Lecuivre_J],2005-08,,,,,
+mgemanagement,4680,udp,MGE UPS Management,[Lecuivre_J],[Lecuivre_J],2005-08,,,,,
+parliant,4681,tcp,Parliant Telephony System,[Colin_Henein],[Colin_Henein],2005-08,,,,,
+parliant,4681,udp,Parliant Telephony System,[Colin_Henein],[Colin_Henein],2005-08,,,,,
+finisar,4682,tcp,finisar,[Christina_Mercier],[Christina_Mercier],2005-08,,,,,
+finisar,4682,udp,finisar,[Christina_Mercier],[Christina_Mercier],2005-08,,,,,
+spike,4683,tcp,Spike Clipboard Service,[Scott_Herscher],[Scott_Herscher],2005-08,,,,,
+spike,4683,udp,Spike Clipboard Service,[Scott_Herscher],[Scott_Herscher],2005-08,,,,,
+rfid-rp1,4684,tcp,RFID Reader Protocol 1.0,[Michael_Mealling_2],[Michael_Mealling_2],2005-08,,,,,
+rfid-rp1,4684,udp,RFID Reader Protocol 1.0,[Michael_Mealling_2],[Michael_Mealling_2],2005-08,,,,,
+autopac,4685,tcp,Autopac Protocol,[Peter_Hallenbeck],[Peter_Hallenbeck],2005-08,,,,,
+autopac,4685,udp,Autopac Protocol,[Peter_Hallenbeck],[Peter_Hallenbeck],2005-08,,,,,
+msp-os,4686,tcp,Manina Service Protocol,[Markus_Nix],[Markus_Nix],2005-08,,,,,
+msp-os,4686,udp,Manina Service Protocol,[Markus_Nix],[Markus_Nix],2005-08,,,,,
+nst,4687,tcp,Network Scanner Tool FTP,[Mala_Bhat],[Mala_Bhat],2005-08,,,,,
+nst,4687,udp,Network Scanner Tool FTP,[Mala_Bhat],[Mala_Bhat],2005-08,,,,,
+mobile-p2p,4688,tcp,Mobile P2P Service,[Hanz_Hager],[Hanz_Hager],2008-12-04,,,,,
+mobile-p2p,4688,udp,Mobile P2P Service,[Hanz_Hager],[Hanz_Hager],2008-12-04,,,,,
+altovacentral,4689,tcp,Altova DatabaseCentral,[Altova],[Altova],2005-08,,,,,
+altovacentral,4689,udp,Altova DatabaseCentral,[Altova],[Altova],2005-08,,,,,
+prelude,4690,tcp,Prelude IDS message proto,[Yoann_Vandoorselaere],[Yoann_Vandoorselaere],2005-08,,,,,
+prelude,4690,udp,Prelude IDS message proto,[Yoann_Vandoorselaere],[Yoann_Vandoorselaere],2005-08,,,,,
+mtn,4691,tcp,monotone Netsync Protocol,[Thomas_Keller],[Thomas_Keller],2010-12-22,,,,,
+mtn,4691,udp,monotone Netsync Protocol,[Thomas_Keller],[Thomas_Keller],2010-12-22,,,,,
+conspiracy,4692,tcp,Conspiracy messaging,[Jens_Edlund],[Jens_Edlund],2005-08,,,,,
+conspiracy,4692,udp,Conspiracy messaging,[Jens_Edlund],[Jens_Edlund],2005-08,,,,,
+,4693-4699,,Unassigned,,,,,,,,
+netxms-agent,4700,tcp,NetXMS Agent,,,,,,,,
+netxms-agent,4700,udp,NetXMS Agent,,,,,,,,
+netxms-mgmt,4701,tcp,NetXMS Management,,,,,,,,
+netxms-mgmt,4701,udp,NetXMS Management,,,,,,,,
+netxms-sync,4702,tcp,NetXMS Server Synchronization,[Victor_Kirhenshtein],[Victor_Kirhenshtein],2006-07,,,,,
+netxms-sync,4702,udp,NetXMS Server Synchronization,[Victor_Kirhenshtein],[Victor_Kirhenshtein],2006-07,,,,,
+npqes-test,4703,tcp,Network Performance Quality Evaluation System Test Service,[Zhengli],[Zhengli],2010-06-28,,,,,
+,4703,udp,Reserved,,,,,,,,
+assuria-ins,4704,tcp,Assuria Insider,[Nick_Connor],[Nick_Connor],2010-06-30,,,,,
+,4704,udp,Reserved,,,,,,,,
+,4705-4724,,Unassigned,,,,,,,,
+truckstar,4725,tcp,TruckStar Service,[Brian_Toothill],[Brian_Toothill],2010-10-15,,,,,
+truckstar,4725,udp,TruckStar Service,[Brian_Toothill],[Brian_Toothill],2010-10-15,,,,,
+,4726,tcp,Reserved,,,,,,,,
+a26-fap-fgw,4726,udp,A26 (FAP-FGW),[David_Ott],[David_Ott],2010-10-15,,,,,
+fcis,4727,tcp,F-Link Client Information Service,,,,,,,,
+fcis-disc,4727,udp,F-Link Client Information Service Discovery,[Makoto_Zukawa],[Makoto_Zukawa],2010-10-15,,,,,
+capmux,4728,tcp,CA Port Multiplexer,[Nigel_Groves],[Nigel_Groves],2006-06,,,,,
+capmux,4728,udp,CA Port Multiplexer,[Nigel_Groves],[Nigel_Groves],2006-06,,,,,
+,4729,tcp,Reserved,,,,,,,,
+gsmtap,4729,udp,GSM Interface Tap,[Harald_Welte],[Harald_Welte],2009-01-16,,,,,
+gearman,4730,tcp,Gearman Job Queue System,[Eric_Day],[Eric_Day],2009-01-16,,,,,
+gearman,4730,udp,Gearman Job Queue System,[Eric_Day],[Eric_Day],2009-01-16,,,,,
+remcap,4731,tcp,Remote Capture Protocol,[Marc_Donner],[Marc_Donner],2009-01-16,,,,,
+,4731,udp,Reserved,,,,,,,,
+,4732,tcp,Reserved,,,,,,,,
+ohmtrigger,4732,udp,OHM server trigger,[Franck_Lefevre],[Franck_Lefevre],2009-11-18,,,,,
+resorcs,4733,tcp,RES Orchestration Catalog Services,[Bob_Janssen_2],[Bob_Janssen_2],2009-11-18,,,,,
+,4733,udp,Reserved,,,,,,,,
+,4734-4736,,Unassigned,,,,,,,,
+ipdr-sp,4737,tcp,IPDR/SP,[Ken_Sarno],[Ken_Sarno],2005-08,,,,,
+ipdr-sp,4737,udp,IPDR/SP,[Ken_Sarno],[Ken_Sarno],2005-08,,,,,
+solera-lpn,4738,tcp,SoleraTec Locator,[Mark_Armstrong],[Mark_Armstrong],2005-12,,,,,
+solera-lpn,4738,udp,SoleraTec Locator,[Mark_Armstrong],[Mark_Armstrong],2005-12,,,,,
+ipfix,4739,tcp,IP Flow Info Export,[Nevil_Brownlee],[Nevil_Brownlee],2005-08,,,,,
+ipfix,4739,udp,IP Flow Info Export,[Nevil_Brownlee],[Nevil_Brownlee],2005-08,,,,,
+ipfix,4739,sctp,IP Flow Info Export,[Nevil_Brownlee],[Nevil_Brownlee],2006-01,,,,,
+ipfixs,4740,tcp,ipfix protocol over TLS,[Nevil_Brownlee],[Nevil_Brownlee],2006-10,,,,,
+ipfixs,4740,sctp,ipfix protocol over DTLS,[Nevil_Brownlee],[Nevil_Brownlee],2006-10,,,,,
+ipfixs,4740,udp,ipfix protocol over DTLS,[Nevil_Brownlee],[Nevil_Brownlee],2006-10,,,,,
+lumimgrd,4741,tcp,Luminizer Manager,[George_Hwa],[George_Hwa],2007-03,,,,,
+lumimgrd,4741,udp,Luminizer Manager,[George_Hwa],[George_Hwa],2007-03,,,,,
+sicct,4742,tcp,SICCT,,,,,,,,
+sicct-sdp,4742,udp,SICCT Service Discovery Protocol,[TeleTrusT_Deutschlan],[TeleTrusT_Deutschlan],2006-04,,,,,
+openhpid,4743,tcp,openhpi HPI service,[Thomas_Kanngieser],[Thomas_Kanngieser],2006-01,,,,,
+openhpid,4743,udp,openhpi HPI service,[Thomas_Kanngieser],[Thomas_Kanngieser],2006-01,,,,,
+ifsp,4744,tcp,Internet File Synchronization Protocol,[Alex_White],[Alex_White],2007-09-12,,,,,
+ifsp,4744,udp,Internet File Synchronization Protocol,[Alex_White],[Alex_White],2007-09-12,,,,,
+fmp,4745,tcp,Funambol Mobile Push,[Andrea_Gazzaniga],[Andrea_Gazzaniga],2007-01,,,,,
+fmp,4745,udp,Funambol Mobile Push,[Andrea_Gazzaniga],[Andrea_Gazzaniga],2007-01,,,,,
+,4746,,Unassigned,,,,,,,,
+buschtrommel,4747,udp,peer-to-peer file exchange protocol,[None],[Tobias_Sturm],2013-01-14,,,,,
+,4747,tcp,Reserved,,,,,,,,
+,4748-4748,,Unassigned,,,,,,,,
+profilemac,4749,tcp,Profile for Mac,[David_Sinclair],[David_Sinclair],2006-05,,,,,
+profilemac,4749,udp,Profile for Mac,[David_Sinclair],[David_Sinclair],2006-05,,,,,
+ssad,4750,tcp,Simple Service Auto Discovery,[Dr_Horst_Herb],[Dr_Horst_Herb],2005-12,,,,,
+ssad,4750,udp,Simple Service Auto Discovery,[Dr_Horst_Herb],[Dr_Horst_Herb],2005-12,,,,,
+spocp,4751,tcp,Simple Policy Control Protocol,[Roland_Hedberg_2],[Roland_Hedberg_2],2005-08,,,,,
+spocp,4751,udp,Simple Policy Control Protocol,[Roland_Hedberg_2],[Roland_Hedberg_2],2005-08,,,,,
+snap,4752,tcp,Simple Network Audio Protocol,[Dameon_Wagner],[Dameon_Wagner],2002-02,,,,,
+snap,4752,udp,Simple Network Audio Protocol,[Dameon_Wagner],[Dameon_Wagner],2002-02,,,,,
+simon,4753,tcp,Simple Invocation of Methods Over Network (SIMON),[Alexander_Christian],[Alexander_Christian],2012-04-19,,,,,
+simon-disc,4753,udp,Simple Invocation of Methods Over Network (SIMON) Discovery,[Alexander_Christian],[Alexander_Christian],2012-04-19,,,,,
+,4754-4783,,Unassigned,,,,,,,,
+bfd-multi-ctl,4784,tcp,BFD Multihop Control,[Dave_Katz][Dave_Ward],[Dave_Katz][Dave_Ward],2006-02,,,,,
+bfd-multi-ctl,4784,udp,BFD Multihop Control,[Dave_Katz][Dave_Ward],[Dave_Katz][Dave_Ward],2006-02,,,,,
+,4785,tcp,Reserved,,,,,,,,
+cncp,4785,udp,Cisco Nexus Control Protocol,[Joseph_Swaminathan],[Joseph_Swaminathan],2009-04-01,,,,,
+smart-install,4786,tcp,Smart Install Service,[Amit_Nigam],[Amit_Nigam],2009-08-24,,,,,
+,4786,udp,Reserved,,,,,,,,
+sia-ctrl-plane,4787,tcp,Service Insertion Architecture (SIA) Control-Plane,[Shree_Murthy],[Shree_Murthy],2009-10-29,,,,,
+,4787,udp,Reserved,,,,,,,,
+xmcp,4788,tcp,eXtensible Messaging Client Protocol,[Cisco],[Glenn_Matthews],2011-05-23,2011-10-25,,,,"Defined TXT keys: txtvers=1 (as described in the draft)
+ protovers=<comma-separated list of major/minor versions supported>
+(examples: ""protovers=1.0"" ""protovers=1.1,2.0"""
+,4788,udp,Reserved,,,,,,,,
+vxlan,4789,udp,Virtual eXtensible Local Area Network (VXLAN),[Lawrence_Kreeger],[Lawrence_Kreeger],2013-04-19,2014-06-17,[RFC7348],,,
+,4789,tcp,Reserved,,,,,,,,
+vxlan-gpe,4790,udp,Generic Protocol Extension for Virtual eXtensible Local Area Network (VXLAN),[Lawrence_Kreeger],[Lawrence_Kreeger],2014-08-26,,,,,
+,4790,tcp,Reserved,,,,,,,,
+roce,4791,udp,IP Routable RocE,[InfiniBand_Trade_Association],[Diego_Crupnicoff],2014-10-17,,,,,
+,4791,tcp,Reserved,,,,,,,,
+,4792-4799,,Unassigned,,,,,,,,
+iims,4800,tcp,Icona Instant Messenging System,,,,,,,,
+iims,4800,udp,Icona Instant Messenging System,,,,,,,,
+iwec,4801,tcp,Icona Web Embedded Chat,,,,,,,,
+iwec,4801,udp,Icona Web Embedded Chat,,,,,,,,
+ilss,4802,tcp,Icona License System Server,[Paul_Stephen_Borlie],[Paul_Stephen_Borlie],,,,,,
+ilss,4802,udp,Icona License System Server,[Paul_Stephen_Borlie],[Paul_Stephen_Borlie],,,,,,
+notateit,4803,tcp,Notateit Messaging,,,,,,,,
+notateit-disc,4803,udp,Notateit Messaging Discovery,[Ean_Black],[Ean_Black],2009-04-08,,,,,
+,4804,tcp,Reserved,,,,,,,,
+aja-ntv4-disc,4804,udp,AJA ntv4 Video System Discovery,[Mike_Bernadett],[Mike_Bernadett],2010-06-03,,,,,
+,4805-4826,,Unassigned,,,,,,,,
+htcp,4827,tcp,HTCP,[Paul_Vixie],[Paul_Vixie],,,,,,
+htcp,4827,udp,HTCP,[Paul_Vixie],[Paul_Vixie],,,,,,
+,4828-4836,,Unassigned,,,,,,,,
+varadero-0,4837,tcp,Varadero-0,,,,,,,,
+varadero-0,4837,udp,Varadero-0,,,,,,,,
+varadero-1,4838,tcp,Varadero-1,,,,,,,,
+varadero-1,4838,udp,Varadero-1,,,,,,,,
+varadero-2,4839,tcp,Varadero-2,[Carlos_Arteaga],[Carlos_Arteaga],,,,,,
+varadero-2,4839,udp,Varadero-2,[Carlos_Arteaga],[Carlos_Arteaga],,,,,,
+opcua-tcp,4840,tcp,OPC UA TCP Protocol,,,,,,,,
+opcua-udp,4840,udp,OPC UA TCP Protocol,[Randy_Armstrong],[Randy_Armstrong],2006-09,,,,,
+quosa,4841,tcp,QUOSA Virtual Library Service,[Uri_Blank],[Uri_Blank],2006-09,,,,,
+quosa,4841,udp,QUOSA Virtual Library Service,[Uri_Blank],[Uri_Blank],2006-09,,,,,
+gw-asv,4842,tcp,nCode ICE-flow Library AppServer,[Ross_Swithenbank],[Ross_Swithenbank],2006-09,,,,,
+gw-asv,4842,udp,nCode ICE-flow Library AppServer,[Ross_Swithenbank],[Ross_Swithenbank],2006-09,,,,,
+opcua-tls,4843,tcp,OPC UA TCP Protocol over TLS/SSL,[Randy_Armstrong],[Randy_Armstrong],2006-09,,,,,
+opcua-tls,4843,udp,OPC UA TCP Protocol over TLS/SSL,[Randy_Armstrong],[Randy_Armstrong],2006-09,,,,,
+gw-log,4844,tcp,nCode ICE-flow Library LogServer,[Ross_Swithenbank],[Ross_Swithenbank],2006-09,,,,,
+gw-log,4844,udp,nCode ICE-flow Library LogServer,[Ross_Swithenbank],[Ross_Swithenbank],2006-09,,,,,
+wcr-remlib,4845,tcp,WordCruncher Remote Library Service,[Jason_Dzubak],[Jason_Dzubak],2008-03-17,,,,,
+wcr-remlib,4845,udp,WordCruncher Remote Library Service,[Jason_Dzubak],[Jason_Dzubak],2008-03-17,,,,,
+contamac-icm,4846,tcp,"Contamac ICM Service
+IANA assigned this well-formed service name as a replacement for ""contamac_icm"".",[Abdullah_Obeid],[Abdullah_Obeid],2008-03-20,,,,,
+contamac_icm,4846,tcp,Contamac ICM Service,[Abdullah_Obeid],[Abdullah_Obeid],2008-03-20,,,,,"This entry is an alias to ""contamac-icm"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+contamac-icm,4846,udp,"Contamac ICM Service
+IANA assigned this well-formed service name as a replacement for ""contamac_icm"".",[Abdullah_Obeid],[Abdullah_Obeid],2008-03-20,,,,,
+contamac_icm,4846,udp,Contamac ICM Service,[Abdullah_Obeid],[Abdullah_Obeid],2008-03-20,,,,,"This entry is an alias to ""contamac-icm"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+wfc,4847,tcp,Web Fresh Communication,[Jonathan_Bastnagel],[Jonathan_Bastnagel],2007-09-17,,,,,
+wfc,4847,udp,Web Fresh Communication,[Jonathan_Bastnagel],[Jonathan_Bastnagel],2007-09-17,,,,,
+appserv-http,4848,tcp,App Server - Admin HTTP,,,,,,,,
+appserv-http,4848,udp,App Server - Admin HTTP,,,,,,,,
+appserv-https,4849,tcp,App Server - Admin HTTPS,[Sreeram_Duvvuru],[Sreeram_Duvvuru],2002-04,,,,,
+appserv-https,4849,udp,App Server - Admin HTTPS,[Sreeram_Duvvuru],[Sreeram_Duvvuru],2002-04,,,,,
+sun-as-nodeagt,4850,tcp,Sun App Server - NA,[Kedar_Mhaswade],[Kedar_Mhaswade],2004-11,,,,,
+sun-as-nodeagt,4850,udp,Sun App Server - NA,[Kedar_Mhaswade],[Kedar_Mhaswade],2004-11,,,,,
+derby-repli,4851,tcp,Apache Derby Replication,[Jorgen_Loland],[Jorgen_Loland],2008-02-27,,,,,
+derby-repli,4851,udp,Apache Derby Replication,[Jorgen_Loland],[Jorgen_Loland],2008-02-27,,,,,
+,4852-4866,,Unassigned,,,,,,,,
+unify-debug,4867,tcp,Unify Debugger,[Daegis_Inc],[Chris_Anderson],2006-05,2012-07-31,,,,
+unify-debug,4867,udp,Unify Debugger,[Daegis_Inc],[Chris_Anderson],2006-05,2012-07-31,,,,
+phrelay,4868,tcp,Photon Relay,,,,,,,,
+phrelay,4868,udp,Photon Relay,,,,,,,,
+phrelaydbg,4869,tcp,Photon Relay Debug,[Michael_Hunter],[Michael_Hunter],,,,,,
+phrelaydbg,4869,udp,Photon Relay Debug,[Michael_Hunter],[Michael_Hunter],,,,,,
+cc-tracking,4870,tcp,Citcom Tracking Service,[Wolfgang_Weidner],[Wolfgang_Weidner],2005-12,,,,,
+cc-tracking,4870,udp,Citcom Tracking Service,[Wolfgang_Weidner],[Wolfgang_Weidner],2005-12,,,,,
+wired,4871,tcp,Wired,[Axel_Andersson],[Axel_Andersson],2006-02,,,,,
+wired,4871,udp,Wired,[Axel_Andersson],[Axel_Andersson],2006-02,,,,,
+,4872-4875,,Unassigned,,,,,,,,
+tritium-can,4876,tcp,Tritium CAN Bus Bridge Service,[James_Kennedy],[James_Kennedy],2011-02-15,,,,,
+tritium-can,4876,udp,Tritium CAN Bus Bridge Service,[James_Kennedy],[James_Kennedy],2011-02-15,,,,,
+lmcs,4877,tcp,Lighting Management Control System,[Timothy_Parry],[Timothy_Parry],2011-02-15,,,,,
+lmcs,4877,udp,Lighting Management Control System,[Timothy_Parry],[Timothy_Parry],2011-02-15,,,,,
+,4878,tcp,Reserved,,,,,,,,
+inst-discovery,4878,udp,Agilent Instrument Discovery,[Charles_F_Steele],[Charles_F_Steele],2011-02-15,,,,,
+wsdl-event,4879,tcp,WSDL Event Receiver,[Charles_F_Steele],[Charles_F_Steele],2011-02-15,,,,,
+,4879,udp,Reserved,,,,,,,,
+hislip,4880,tcp,IVI High-Speed LAN Instrument Protocol,[Joe_Mueller],[Joe_Mueller],2010-01-11,,,,,
+,4880,udp,Reserved,,,,,,,,
+,4881,tcp,Reserved,,,,,,,,
+socp-t,4881,udp,SOCP Time Synchronization Protocol,[Joe_Haver],[Joe_Haver],2010-05-28,,,,,
+,4882,tcp,Reserved,,,,,,,,
+socp-c,4882,udp,SOCP Control Protocol,[Joe_Haver],[Joe_Haver],2010-05-28,,,,,
+wmlserver,4883,tcp,Meier-Phelps License Server,[William_Phelps],[William_Phelps],2010-03-22,,,,,
+,4883,udp,Reserved,,,,,,,,
+hivestor,4884,tcp,HiveStor Distributed File System,[Nicholas_Young],[Nicholas_Young],2008-07-10,,,,,
+hivestor,4884,udp,HiveStor Distributed File System,[Nicholas_Young],[Nicholas_Young],2008-07-10,,,,,
+abbs,4885,tcp,ABBS,[Ryan_Rubley],[Ryan_Rubley],,,,,,
+abbs,4885,udp,ABBS,[Ryan_Rubley],[Ryan_Rubley],,,,,,
+,4886-4893,,Unassigned,,,,,,,,
+lyskom,4894,tcp,LysKOM Protocol A,[Per_Cederqvist],[Per_Cederqvist],,,,,,
+lyskom,4894,udp,LysKOM Protocol A,[Per_Cederqvist],[Per_Cederqvist],,,,,,
+,4895-4898,,Unassigned,,,,,,,,
+radmin-port,4899,tcp,RAdmin Port,[Dmitri_Znosko],[Dmitri_Znosko],2003-03,,,,,
+radmin-port,4899,udp,RAdmin Port,[Dmitri_Znosko],[Dmitri_Znosko],2003-03,,,,,
+hfcs,4900,tcp,HFSQL Client/Server Database Engine,[PC_SOFT],[Jerome_AERTS_2],2006-03-02,2014-02-02,,,,
+hfcs,4900,udp,HFSQL Client/Server Database Engine,[PC_SOFT],[Jerome_AERTS_2],2006-03-02,2014-02-02,,,,
+flr-agent,4901,tcp,"FileLocator Remote Search Agent
+IANA assigned this well-formed service name as a replacement for ""flr_agent"".",[David_Vest],[David_Vest],2008-11-19,,,,,
+flr_agent,4901,tcp,FileLocator Remote Search Agent,[David_Vest],[David_Vest],2008-11-19,,,,,"This entry is an alias to ""flr-agent"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+,4901,udp,Reserved,,,,,,,,
+magiccontrol,4902,tcp,magicCONROL RF and Data Interface,[Andreas_Spalenski],[Andreas_Spalenski],2008-11-24,,,,,
+,4902,udp,Reserved,,,,,,,,
+,4903-4911,,Unassigned,,,,,,,,
+lutap,4912,tcp,Technicolor LUT Access Protocol,[Markus_Loeffler],[Markus_Loeffler],2009-02-17,,,,,
+,4912,udp,Reserved,,,,,,,,
+lutcp,4913,tcp,LUTher Control Protocol,[Markus_Loeffler],[Markus_Loeffler],2007-07-03,,,,,
+bones,4914,tcp,Bones Remote Control,[Andreas_Foedrowitz],[Andreas_Foedrowitz],2008-06-18,,,,,
+bones,4914,udp,Bones Remote Control,[Andreas_Foedrowitz],[Andreas_Foedrowitz],2008-06-18,,,,,
+frcs,4915,tcp,Fibics Remote Control Service,[Ken_Lagarec],[Ken_Lagarec],2009-04-17,,,,,
+,4915,udp,Reserved,,,,,,,,
+,4916-4935,,Unassigned,,,,,,,,
+an-signaling,4936,udp,Signal protocol port for autonomic networking,[Cisco_systems_3],[Toerless_Eckert_2],2014-06-06,,,,,
+,4936,tcp,Reserved,,,,,,,,
+,4937,tcp,Reserved,,,,,,,,
+atsc-mh-ssc,4937,udp,ATSC-M/H Service Signaling Channel,[Jerry_Whitaker],[Jerry_Whitaker],2008-10-27,,,,,
+,4938-4939,,Unassigned,,,,,,,,
+eq-office-4940,4940,tcp,Equitrac Office,,,,,,,,
+eq-office-4940,4940,udp,Equitrac Office,,,,,,,,
+eq-office-4941,4941,tcp,Equitrac Office,,,,,,,,
+eq-office-4941,4941,udp,Equitrac Office,,,,,,,,
+eq-office-4942,4942,tcp,Equitrac Office,[Tom_Haapanen_2],[Tom_Haapanen_2],2007-07-11,,,,,
+eq-office-4942,4942,udp,Equitrac Office,[Tom_Haapanen_2],[Tom_Haapanen_2],2007-07-11,,,,,
+,4943-4948,,Unassigned,,,,,,,,
+munin,4949,tcp,Munin Graphing Framework,[Jimmy_Olsen],[Jimmy_Olsen],2010-12-24,,,,,
+munin,4949,udp,Munin Graphing Framework,[Jimmy_Olsen],[Jimmy_Olsen],2010-12-24,,,,,
+sybasesrvmon,4950,tcp,Sybase Server Monitor,[Chris_Irie],[Chris_Irie],2008-03-26,,,,,
+sybasesrvmon,4950,udp,Sybase Server Monitor,[Chris_Irie],[Chris_Irie],2008-03-26,,,,,
+pwgwims,4951,tcp,PWG WIMS,[Ira_McDonald],[Ira_McDonald],2005-12,,,,,
+pwgwims,4951,udp,PWG WIMS,[Ira_McDonald],[Ira_McDonald],2005-12,,,,,
+sagxtsds,4952,tcp,SAG Directory Server,[Michael_Chirila],[Michael_Chirila],2006-01,,,,,
+sagxtsds,4952,udp,SAG Directory Server,[Michael_Chirila],[Michael_Chirila],2006-01,,,,,
+dbsyncarbiter,4953,tcp,Synchronization Arbiter,[Dave_Neudoerffer_2],[Dave_Neudoerffer_2],2009-11-18,,,,,
+,4953,udp,Reserved,,,,,,,,
+,4954-4968,,Unassigned,,,,,,,Known UNAUTHORIZED USE: port 4967,
+ccss-qmm,4969,tcp,CCSS QMessageMonitor,,,,,,,,
+ccss-qmm,4969,udp,CCSS QMessageMonitor,,,,,,,,
+ccss-qsm,4970,tcp,CCSS QSystemMonitor,[David_Young],[David_Young],2006-01,,,,,
+ccss-qsm,4970,udp,CCSS QSystemMonitor,[David_Young],[David_Young],2006-01,,,,,
+,4971-4982,,Unassigned,,,,,,,,
+,4983,,Unassigned,,,,2005-12-22,,,,
+webyast,4984,tcp,WebYast,[Federico_Lucifredi],[Federico_Lucifredi],2009-09-25,,,,,
+,4984,udp,Reserved,,,,,,,,
+gerhcs,4985,tcp,GER HC Standard,[Roger_Ward],[Roger_Ward],2009-09-25,,,,,
+,4985,udp,Reserved,,,,,,,,
+mrip,4986,tcp,Model Railway Interface Program,[Howard_Amos],[Howard_Amos],2006-04,,,,,
+mrip,4986,udp,Model Railway Interface Program,[Howard_Amos],[Howard_Amos],2006-04,,,,,
+smar-se-port1,4987,tcp,SMAR Ethernet Port 1,,,,,,,,
+smar-se-port1,4987,udp,SMAR Ethernet Port 1,,,,,,,,
+smar-se-port2,4988,tcp,SMAR Ethernet Port 2,[Delcio_Prizon],[Delcio_Prizon],,,,,,
+smar-se-port2,4988,udp,SMAR Ethernet Port 2,[Delcio_Prizon],[Delcio_Prizon],,,,,,
+parallel,4989,tcp,Parallel for GAUSS (tm),[Matthew_Ford],[Matthew_Ford],2003-03,,,,,
+parallel,4989,udp,Parallel for GAUSS (tm),[Matthew_Ford],[Matthew_Ford],2003-03,,,,,
+busycal,4990,tcp,BusySync Calendar Synch. Protocol,[David_Riggle],[David_Riggle],2008-01-07,,,,,Defined TXT keys: Proprietary
+busycal,4990,udp,BusySync Calendar Synch. Protocol,[David_Riggle],[David_Riggle],2008-01-07,,,,,Defined TXT keys: Proprietary
+vrt,4991,tcp,VITA Radio Transport,[Sam_Bretheim],[Sam_Bretheim],2009-01-08,,,,,
+vrt,4991,udp,VITA Radio Transport,[Sam_Bretheim],[Sam_Bretheim],2009-01-08,,,,,
+,4992-4998,,Unassigned,,,,,,,,
+hfcs-manager,4999,tcp,HFSQL Client/Server Database Engine Manager,[PC_SOFT],[Jerome_AERTS_2],2006-03-02,2014-02-02,,,,
+hfcs-manager,4999,udp,HFSQL Client/Server Database Engine Manager,[PC_SOFT],[Jerome_AERTS_2],2006-03-02,2014-02-02,,,,
+commplex-main,5000,tcp,,,,,,,,,
+commplex-main,5000,udp,,,,,,,,,
+commplex-link,5001,tcp,,,,,,,,,
+commplex-link,5001,udp,,,,,,,,,
+rfe,5002,tcp,radio free ethernet,,,,,,,,
+rfe,5002,udp,radio free ethernet,,,,,,,,
+fmpro-internal,5003,tcp,"FileMaker, Inc. - Proprietary transport",[Clay_Maeckel],[Clay_Maeckel],,,,,,
+fmpro-internal,5003,udp,"FileMaker, Inc. - Proprietary name binding",[Clay_Maeckel],[Clay_Maeckel],,,,,,
+avt-profile-1,5004,tcp,RTP media data,,,,,[RFC3551][RFC4571],,,
+avt-profile-1,5004,udp,RTP media data,,,,,[RFC3551],,,
+avt-profile-1,5004,dccp,RTP media data,,,,,[RFC3551][RFC5762],,,
+avt-profile-2,5005,tcp,RTP control protocol,,,,,[RFC3551][RFC4571],,,
+avt-profile-2,5005,udp,RTP control protocol,,,,,[RFC3551],,,
+avt-profile-2,5005,dccp,RTP control protocol,,,,,[RFC3551][RFC5762],,,
+wsm-server,5006,tcp,wsm server,[Adam_Berk],[Adam_Berk],,,,,,
+wsm-server,5006,udp,wsm server,[Adam_Berk],[Adam_Berk],,,,,,
+wsm-server-ssl,5007,tcp,wsm server ssl,[Adam_Berk],[Adam_Berk],,,,,,
+wsm-server-ssl,5007,udp,wsm server ssl,[Adam_Berk],[Adam_Berk],,,,,,
+synapsis-edge,5008,tcp,Synapsis EDGE,[Paul_Schilling],[Paul_Schilling],,,,,,
+synapsis-edge,5008,udp,Synapsis EDGE,[Paul_Schilling],[Paul_Schilling],,,,,,
+winfs,5009,tcp,Microsoft Windows Filesystem,[Simon_Skaria],[Simon_Skaria],2006-01,,,,,
+winfs,5009,udp,Microsoft Windows Filesystem,[Simon_Skaria],[Simon_Skaria],2006-01,,,,,
+telelpathstart,5010,tcp,TelepathStart,[Helmuth_Breitenfelln],[Helmuth_Breitenfelln],,,,,,
+telelpathstart,5010,udp,TelepathStart,[Helmuth_Breitenfelln],[Helmuth_Breitenfelln],,,,,,
+telelpathattack,5011,tcp,TelepathAttack,[Helmuth_Breitenfelln],[Helmuth_Breitenfelln],,,,,,
+telelpathattack,5011,udp,TelepathAttack,[Helmuth_Breitenfelln],[Helmuth_Breitenfelln],,,,,,
+nsp,5012,tcp,NetOnTap Service,[Kim_Hancock],[Kim_Hancock],2007-10-24,,,,,
+nsp,5012,udp,NetOnTap Service,[Kim_Hancock],[Kim_Hancock],2007-10-24,,,,,
+fmpro-v6,5013,tcp,"FileMaker, Inc. - Proprietary transport",[Alex_Chen],[Alex_Chen],2007-08-01,,,,,
+fmpro-v6,5013,udp,"FileMaker, Inc. - Proprietary transport",[Alex_Chen],[Alex_Chen],2007-08-01,,,,,
+,5014,tcp,Reserved,,,,,,,,
+onpsocket,5014,udp,Overlay Network Protocol,[Roger_Matthias],[Roger_Matthias],2009-08-24,,,,,
+fmwp,5015,tcp,"FileMaker, Inc. - Web publishing",[Alex_Chen],[Alex_Chen],2009-11-25,,,,,
+,5015,udp,Reserved,,,,,,,,
+,5016-5019,,Unassigned,,,,,,,,
+zenginkyo-1,5020,tcp,zenginkyo-1,[Masashi_Suzaki],[Masashi_Suzaki],,,,,,
+zenginkyo-1,5020,udp,zenginkyo-1,[Masashi_Suzaki],[Masashi_Suzaki],,,,,,
+zenginkyo-2,5021,tcp,zenginkyo-2,[Masashi_Suzaki],[Masashi_Suzaki],,,,,,
+zenginkyo-2,5021,udp,zenginkyo-2,[Masashi_Suzaki],[Masashi_Suzaki],,,,,,
+mice,5022,tcp,mice server,[Alan_Clifford],[Alan_Clifford],,,,,,
+mice,5022,udp,mice server,[Alan_Clifford],[Alan_Clifford],,,,,,
+htuilsrv,5023,tcp,Htuil Server for PLD2,[Dennis_Reinhardt],[Dennis_Reinhardt],,,,,,
+htuilsrv,5023,udp,Htuil Server for PLD2,[Dennis_Reinhardt],[Dennis_Reinhardt],,,,,,
+scpi-telnet,5024,tcp,SCPI-TELNET,[Ryan_Columbus],[Ryan_Columbus],2002-10,,,,,
+scpi-telnet,5024,udp,SCPI-TELNET,[Ryan_Columbus],[Ryan_Columbus],2002-10,,,,,
+scpi-raw,5025,tcp,SCPI-RAW,[Ryan_Columbus],[Ryan_Columbus],2002-10,,,,,
+scpi-raw,5025,udp,SCPI-RAW,[Ryan_Columbus],[Ryan_Columbus],2002-10,,,,,
+strexec-d,5026,tcp,Storix I/O daemon (data),[Anthony_Johnson],[Anthony_Johnson],2005-08,,,,,
+strexec-d,5026,udp,Storix I/O daemon (data),[Anthony_Johnson],[Anthony_Johnson],2005-08,,,,,
+strexec-s,5027,tcp,Storix I/O daemon (stat),[Anthony_Johnson],[Anthony_Johnson],2005-08,,,,,
+strexec-s,5027,udp,Storix I/O daemon (stat),[Anthony_Johnson],[Anthony_Johnson],2005-08,,,,,
+qvr,5028,tcp,Quiqum Virtual Relais,[Philipp_Marcel_Albre],[Philipp_Marcel_Albre],2009-07-06,,,,,
+,5028,udp,Reserved,,,,,,,,
+infobright,5029,tcp,Infobright Database Server,[Mark_Windrim],[Mark_Windrim],2009-07-23,,,,,
+infobright,5029,udp,Infobright Database Server,[Mark_Windrim],[Mark_Windrim],2009-07-23,,,,,
+surfpass,5030,tcp,SurfPass,[Olivier_Guezenec],[Olivier_Guezenec],2006-12,,,,,
+surfpass,5030,udp,SurfPass,[Olivier_Guezenec],[Olivier_Guezenec],2006-12,,,,,
+,5031,tcp,Reserved,,,,,,,,
+dmp,5031,udp,Direct Message Protocol,[Gjermund_Wallenius],[Gjermund_Wallenius],2009-09-30,,,,,
+signacert-agent,5032,tcp,SignaCert Enterprise Trust Server Agent,[Harris_Corporation],[Daniel_R_Somerfield],2011-08-05,,,,,
+,5032,udp,Reserved,,,,,,,,
+,5033-5041,,Unassigned,,,,,,,,
+asnaacceler8db,5042,tcp,asnaacceler8db,[Walter_Goodwin],[Walter_Goodwin],,,,,,
+asnaacceler8db,5042,udp,asnaacceler8db,[Walter_Goodwin],[Walter_Goodwin],,,,,,
+swxadmin,5043,tcp,ShopWorX Administration,[Don_W_Fitzpatrick],[Don_W_Fitzpatrick],2005-08,,,,,
+swxadmin,5043,udp,ShopWorX Administration,[Don_W_Fitzpatrick],[Don_W_Fitzpatrick],2005-08,,,,,
+lxi-evntsvc,5044,tcp,LXI Event Service,[Nick_Barendt],[Nick_Barendt],2005-08,,,,,
+lxi-evntsvc,5044,udp,LXI Event Service,[Nick_Barendt],[Nick_Barendt],2005-08,,,,,
+osp,5045,tcp,Open Settlement Protocol,[Dmitry_Isakbayev],[Dmitry_Isakbayev],2010-03-05,,,,,
+,5045,udp,Reserved,,,,,,,,
+,5046,tcp,Reserved,,,,,,,,
+vpm-udp,5046,udp,Vishay PM UDP Service,[Ashley_Clarke],[Ashley_Clarke],2010-06-17,,,,,
+,5047,tcp,Reserved,,,,,,,,
+iscape,5047,udp,iSCAPE Data Broadcasting,[Roland_van_der_Veen],[Roland_van_der_Veen],2010-06-17,,,,,
+texai,5048,tcp,Texai Message Service,[Stephen_Reed_2],[Stephen_Reed_2],2010-06-17,,,,,
+,5048,udp,Reserved,,,,,,,,
+ivocalize,5049,tcp,iVocalize Web Conference,[Bryan_Vergato],[Bryan_Vergato],2006-05,,,,,
+ivocalize,5049,udp,iVocalize Web Conference,[Bryan_Vergato],[Bryan_Vergato],2006-05,,,,,
+mmcc,5050,tcp,multimedia conference control tool,[Steve_Casner],[Steve_Casner],,,,,,
+mmcc,5050,udp,multimedia conference control tool,[Steve_Casner],[Steve_Casner],,,,,,
+ita-agent,5051,tcp,ITA Agent,[Don_Merrell],[Don_Merrell],,,,,,
+ita-agent,5051,udp,ITA Agent,[Don_Merrell],[Don_Merrell],,,,,,
+ita-manager,5052,tcp,ITA Manager,[Don_Merrell],[Don_Merrell],,,,,,
+ita-manager,5052,udp,ITA Manager,[Don_Merrell],[Don_Merrell],,,,,,
+rlm,5053,tcp,RLM License Server,[Matt_Christiano_2],[Matt_Christiano_2],2008-07-28,,,,,
+rlm-disc,5053,udp,RLM Discovery Server,[Reprise_Software_Inc],[Matt_Christiano_3],2012-11-06,,,,,
+rlm-admin,5054,tcp,RLM administrative interface,[Matt_Christiano_2],[Matt_Christiano_2],2008-07-28,,,,,
+,5054,udp,Reserved,,,,,,,,
+unot,5055,tcp,UNOT,[Gordon_Mohr_2],[Gordon_Mohr_2],,,,,,
+unot,5055,udp,UNOT,[Gordon_Mohr_2],[Gordon_Mohr_2],,,,,,
+intecom-ps1,5056,tcp,Intecom Pointspan 1,[David_Meermans],[David_Meermans],,,,,,
+intecom-ps1,5056,udp,Intecom Pointspan 1,[David_Meermans],[David_Meermans],,,,,,
+intecom-ps2,5057,tcp,Intecom Pointspan 2,[David_Meermans],[David_Meermans],,,,,,
+intecom-ps2,5057,udp,Intecom Pointspan 2,[David_Meermans],[David_Meermans],,,,,,
+,5058,tcp,Reserved,,,,,,,,
+locus-disc,5058,udp,Locus Discovery,[Alan_King],[Alan_King],2009-08-13,,,,,
+sds,5059,tcp,SIP Directory Services,[Arthur_Wilton],[Arthur_Wilton],2006-03,,,,,
+sds,5059,udp,SIP Directory Services,[Arthur_Wilton],[Arthur_Wilton],2006-03,,,,,
+sip,5060,tcp,SIP,,,,2014-04-09,[RFC3263],,,
+sip,5060,udp,SIP,,,,2014-04-09,[RFC3263],,,
+sip,5060,sctp,SIP,,,,,[RFC4168],,,
+sips,5061,tcp,SIP-TLS,,,,2014-04-09,[RFC3263],,,
+sips,5061,udp,SIP-TLS,,,,2014-04-09,[RFC3263],,,
+sips,5061,sctp,SIP-TLS,,,,,[RFC4168],,,
+na-localise,5062,tcp,Localisation access,[Jean_Pierre_Garcia_2],[Jean_Pierre_Garcia_2],2009-10-28,,,,,
+na-localise,5062,udp,Localisation access,[Jean_Pierre_Garcia_2],[Jean_Pierre_Garcia_2],2009-10-28,,,,,
+csrpc,5063,tcp,centrify secure RPC,[Paul_Moore],[Paul_Moore],2009-10-28,,,,,
+,5063,udp,Reserved,,,,,,,,
+ca-1,5064,tcp,Channel Access 1,[Jeffrey_Hill],[Jeffrey_Hill],2002-08,,,,,
+ca-1,5064,udp,Channel Access 1,[Jeffrey_Hill],[Jeffrey_Hill],2002-08,,,,,
+ca-2,5065,tcp,Channel Access 2,[Jeffrey_Hill],[Jeffrey_Hill],2002-08,,,,,
+ca-2,5065,udp,Channel Access 2,[Jeffrey_Hill],[Jeffrey_Hill],2002-08,,,,,
+stanag-5066,5066,tcp,STANAG-5066-SUBNET-INTF,[Donald_G_Kallgren],[Donald_G_Kallgren],,,,,,
+stanag-5066,5066,udp,STANAG-5066-SUBNET-INTF,[Donald_G_Kallgren],[Donald_G_Kallgren],,,,,,
+authentx,5067,tcp,Authentx Service,[Alberto_Fernandez],[Alberto_Fernandez],2006-01,,,,,
+authentx,5067,udp,Authentx Service,[Alberto_Fernandez],[Alberto_Fernandez],2006-01,,,,,
+bitforestsrv,5068,tcp,Bitforest Data Service,[Ville_Pekka_Vahteala],[Ville_Pekka_Vahteala],2008-06-05,,,,,
+,5068,udp,Reserved,,,,,,,,
+i-net-2000-npr,5069,tcp,I/Net 2000-NPR,[Chris_Megede],[Chris_Megede],,,,,,
+i-net-2000-npr,5069,udp,I/Net 2000-NPR,[Chris_Megede],[Chris_Megede],,,,,,
+vtsas,5070,tcp,VersaTrans Server Agent Service,[Christopher_Miller],[Christopher_Miller],2006-02,,,,,
+vtsas,5070,udp,VersaTrans Server Agent Service,[Christopher_Miller],[Christopher_Miller],2006-02,,,,,
+powerschool,5071,tcp,PowerSchool,[Greg_Porter],[Greg_Porter],,,,,,
+powerschool,5071,udp,PowerSchool,[Greg_Porter],[Greg_Porter],,,,,,
+ayiya,5072,tcp,Anything In Anything,[Jeroen_Massar],[Jeroen_Massar],2005-08,,,,,
+ayiya,5072,udp,Anything In Anything,[Jeroen_Massar],[Jeroen_Massar],2005-08,,,,,
+tag-pm,5073,tcp,Advantage Group Port Mgr,[James_Goddard],[James_Goddard],2005-08,,,,,
+tag-pm,5073,udp,Advantage Group Port Mgr,[James_Goddard],[James_Goddard],2005-08,,,,,
+alesquery,5074,tcp,ALES Query,[Tim_Maloney],[Tim_Maloney],2005-08,,,,,
+alesquery,5074,udp,ALES Query,[Tim_Maloney],[Tim_Maloney],2005-08,,,,,
+pvaccess,5075,tcp,Experimental Physics and Industrial Control System,[Matej_Sekoranja],[Matej_Sekoranja],2012-03-23,,,,,
+,5075,udp,Reserved,,,,,,,,
+,5076-5077,,Unassigned,,,,,,,,
+pixelpusher,5078,udp,PixelPusher pixel data,[heroicrobotics.com],[Jasmine_Strong],2014-06-24,,,,,
+,5078,tcp,Reserved,,,,,,,,
+,5079,tcp,Reserved,,,,,,,,
+cp-spxrpts,5079,udp,Cambridge Pixel SPx Reports,[Richard_Warren],[Richard_Warren],2008-09-17,,,,,
+onscreen,5080,tcp,OnScreen Data Collection Service,[Christopher_Miller_2],[Christopher_Miller_2],2008-01-14,,,,,
+onscreen,5080,udp,OnScreen Data Collection Service,[Christopher_Miller_2],[Christopher_Miller_2],2008-01-14,,,,,
+sdl-ets,5081,tcp,SDL - Ent Trans Server,[Marc_Morin],[Marc_Morin],2002-04,,,,,
+sdl-ets,5081,udp,SDL - Ent Trans Server,[Marc_Morin],[Marc_Morin],2002-04,,,,,
+qcp,5082,tcp,Qpur Communication Protocol,[Joachim_Kluemper],[Joachim_Kluemper],2008-03-19,,,,,
+qcp,5082,udp,Qpur Communication Protocol,[Joachim_Kluemper],[Joachim_Kluemper],2008-03-19,,,,,
+qfp,5083,tcp,Qpur File Protocol,[Joachim_Kluemper],[Joachim_Kluemper],2008-03-19,,,,,
+qfp,5083,udp,Qpur File Protocol,[Joachim_Kluemper],[Joachim_Kluemper],2008-03-19,,,,,
+llrp,5084,tcp,EPCglobal Low-Level Reader Protocol,[Margaret_Wasserman][Paul_Dietrich],[Margaret_Wasserman][Paul_Dietrich],2006-11,,,,,Defined TXT keys: None. RFID reader Low Level Reader Protocol
+llrp,5084,udp,EPCglobal Low-Level Reader Protocol,[Margaret_Wasserman][Paul_Dietrich],[Margaret_Wasserman][Paul_Dietrich],2006-11,,,,,Defined TXT keys: None. RFID reader Low Level Reader Protocol
+encrypted-llrp,5085,tcp,EPCglobal Encrypted LLRP,[Margaret_Wasserman],[Margaret_Wasserman],2006-11,,,,,
+encrypted-llrp,5085,udp,EPCglobal Encrypted LLRP,[Margaret_Wasserman],[Margaret_Wasserman],2006-11,,,,,
+aprigo-cs,5086,tcp,Aprigo Collection Service,[Ron_Zalkind],[Ron_Zalkind],2010-05-28,,,,,
+,5086,udp,Reserved,,,,,,,,
+biotic,5087,tcp,BIOTIC - Binary Internet of Things Interoperable Communication,[Clayster_Laboratorios_Chile_S.A.],[Peter_Waher],2014-06-16,,,,,
+,5087,udp,Reserved,,,,,,,,
+,5088-5089,,Unassigned,,,,,,,,
+car,5090,sctp,Candidate AR,,,,,,,,
+cxtp,5091,sctp,Context Transfer Protocol,,,2005-07,,[RFC4065],,,
+,5092,tcp,Reserved,,,,,,,,
+magpie,5092,udp,Magpie Binary,[Phil_Maker],[Phil_Maker],2008-06-18,,,,,
+sentinel-lm,5093,tcp,Sentinel LM,[Derick_Snyder],[Derick_Snyder],,,,,,
+sentinel-lm,5093,udp,Sentinel LM,[Derick_Snyder],[Derick_Snyder],,,,,,
+hart-ip,5094,tcp,HART-IP,[Wally_Pratt_Jr],[Wally_Pratt_Jr],2010-03-02,,,,,
+hart-ip,5094,udp,HART-IP,[Wally_Pratt_Jr],[Wally_Pratt_Jr],2010-03-02,,,,,
+,5095-5098,,Unassigned,,,,,,,,
+sentlm-srv2srv,5099,tcp,SentLM Srv2Srv,[Derick_Snyder],[Derick_Snyder],,,,,,
+sentlm-srv2srv,5099,udp,SentLM Srv2Srv,[Derick_Snyder],[Derick_Snyder],,,,,,
+socalia,5100,tcp,Socalia service mux,[Alberto_Raydan_2],[Alberto_Raydan_2],2005-08,,,,,
+socalia,5100,udp,Socalia service mux,[Alberto_Raydan_2],[Alberto_Raydan_2],2005-08,,,,,
+talarian-tcp,5101,tcp,Talarian_TCP,[Leo_Martins],[Leo_Martins],,,,,,
+talarian-udp,5101,udp,Talarian_UDP,[Leo_Martins],[Leo_Martins],,,,,,
+oms-nonsecure,5102,tcp,Oracle OMS non-secure,[Todd_Guay],[Todd_Guay],2005-08,,,,,
+oms-nonsecure,5102,udp,Oracle OMS non-secure,[Todd_Guay],[Todd_Guay],2005-08,,,,,
+actifio-c2c,5103,tcp,Actifio C2C,[Ravi_Kollipara],[Ravi_Kollipara],2010-06-18,,,,,
+,5103,udp,Reserved,,,,,,,,
+,5104,tcp,Reserved,,,,,,,,
+tinymessage,5104,udp,TinyMessage,[Josip_Medved],[Josip_Medved],2010-10-20,,,,,
+,5105,tcp,Reserved,,,,,,,,
+hughes-ap,5105,udp,Hughes Association Protocol,[Varun_Santosh],[Varun_Santosh],2010-10-20,,,,,
+actifioudsagent,5106,tcp,Actifio UDS Agent,[Actifio],[Madhav_Mutalik],2014-06-05,,,,,
+,5106,udp,Reserved,,,,,,,,
+,5107-5110,,Unassigned,,,,,,,,
+taep-as-svc,5111,tcp,TAEP AS service,[Liu_Changchun],[Liu_Changchun],2008-11-05,,,,,
+taep-as-svc,5111,udp,TAEP AS service,[Liu_Changchun],[Liu_Changchun],2008-11-05,,,,,
+pm-cmdsvr,5112,tcp,PeerMe Msg Cmd Service,[Marcos_Della],[Marcos_Della],2005-08,,,,,
+pm-cmdsvr,5112,udp,PeerMe Msg Cmd Service,[Marcos_Della],[Marcos_Della],2005-08,,,,,
+,5113,,Unassigned,,,2010-11-09,,,,,
+ev-services,5114,tcp,Enterprise Vault Services,[Richard_Jones_2],[Richard_Jones_2],2009-05-26,,,,,
+,5114,udp,Reserved,,,,,,,,
+autobuild,5115,tcp,Symantec Autobuild Service,[David_Warden],[David_Warden],2008-11-17,,,,,
+,5115,udp,Reserved,,,,,,,,
+,5116,tcp,Reserved,,,,,,,,
+emb-proj-cmd,5116,udp,EPSON Projecter Image Transfer,[SEIKO_EPSON_4],[SEIKO_EPSON_4],2008-11-17,,,,,
+gradecam,5117,tcp,GradeCam Image Processing,[Robert_Porter],[Robert_Porter],2009-09-24,,,,,
+,5117,udp,Reserved,,,,,,,,
+,5118-5119,,Unassigned,,,,,,,,
+barracuda-bbs,5120,tcp,Barracuda Backup Protocol,[Barracuda_Networks],[Andrew_Blyler],2013-04-05,,,,,
+barracuda-bbs,5120,udp,Barracuda Backup Protocol,[Barracuda_Networks],[Andrew_Blyler],2013-04-05,,,,,
+,5121-5132,,Unassigned,,,,,,,,
+nbt-pc,5133,tcp,Policy Commander,[Emily_Harris],[Emily_Harris],2004-11,,,,,
+nbt-pc,5133,udp,Policy Commander,[Emily_Harris],[Emily_Harris],2004-11,,,,,
+ppactivation,5134,tcp,PP ActivationServer,[Ian_Bradley],[Ian_Bradley],2009-10-14,,,,,
+,5134,udp,Reserved,,,,,,,,
+erp-scale,5135,tcp,ERP-Scale,[Ian_Bradley],[Ian_Bradley],2009-10-14,,,,,"Defined TXT keys:
+ RFC=<RFC destination and status>
+ Device=<Scale device and status>"
+,5135,udp,Reserved,,,,,,,,
+,5136,tcp,Reserved,,,,,,,,
+minotaur-sa,5136,udp,Minotaur SA,[Kenneth_Flynn],[Kenneth_Flynn],2009-10-14,,,,,
+ctsd,5137,tcp,MyCTS server port,[Jilles_Oldenbeuving],[Jilles_Oldenbeuving],2002-06,,,,,
+ctsd,5137,udp,MyCTS server port,[Jilles_Oldenbeuving],[Jilles_Oldenbeuving],2002-06,,,,,
+,5138-5144,,Unassigned,,,,,,,,
+rmonitor-secure,5145,tcp,"RMONITOR SECURE
+IANA assigned this well-formed service name as a replacement for ""rmonitor_secure"".",[Kory_Hamzeh],[Kory_Hamzeh],,,,,,
+rmonitor_secure,5145,tcp,RMONITOR SECURE,[Kory_Hamzeh],[Kory_Hamzeh],,,,,,"This entry is an alias to ""rmonitor-secure"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+rmonitor-secure,5145,udp,"RMONITOR SECURE
+IANA assigned this well-formed service name as a replacement for ""rmonitor_secure"".",[Kory_Hamzeh],[Kory_Hamzeh],,,,,,
+rmonitor_secure,5145,udp,RMONITOR SECURE,[Kory_Hamzeh],[Kory_Hamzeh],,,,,,"This entry is an alias to ""rmonitor-secure"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+social-alarm,5146,tcp,Social Alarm Service,[Shaun_Byrne],[Shaun_Byrne],2009-08-18,,,,,
+,5146,udp,Reserved,,,,,,,,
+,5147-5149,,Unassigned,,,,,,,,
+atmp,5150,tcp,Ascend Tunnel Management Protocol,[Kory_Hamzeh],[Kory_Hamzeh],,,,,,
+atmp,5150,udp,Ascend Tunnel Management Protocol,[Kory_Hamzeh],[Kory_Hamzeh],,,,,,
+esri-sde,5151,tcp,"ESRI SDE Instance
+ IANA assigned this well-formed service name as a replacement for ""esri_sde"".",[Peter_Aronson],[Peter_Aronson],,,,,Unauthorized Use Known on ports 5151 and 5152,
+esri_sde,5151,tcp,ESRI SDE Instance,[Peter_Aronson],[Peter_Aronson],,,,,,"This entry is an alias to ""esri-sde"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+esri-sde,5151,udp,"ESRI SDE Remote Start
+ IANA assigned this well-formed service name as a replacement for ""esri_sde"".",[Peter_Aronson],[Peter_Aronson],,,,,Unauthorized Use Known on ports 5151 and 5152,
+esri_sde,5151,udp,ESRI SDE Remote Start,[Peter_Aronson],[Peter_Aronson],,,,,,"This entry is an alias to ""esri-sde"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+sde-discovery,5152,tcp,ESRI SDE Instance Discovery,[Peter_Aronson],[Peter_Aronson],,,,,Unauthorized Use Known on ports 5151 and 5152,
+sde-discovery,5152,udp,ESRI SDE Instance Discovery,[Peter_Aronson],[Peter_Aronson],,,,,Unauthorized Use Known on ports 5151 and 5152,
+toruxserver,5153,tcp,ToruX Game Server,[Josse_van_Dobben_de],[Josse_van_Dobben_de],2009-07-01,,,,,
+,5153,udp,Reserved,,,,,,,,
+bzflag,5154,tcp,BZFlag game server,[Tim_Riker],[Tim_Riker],2003-07,,,,,
+bzflag,5154,udp,BZFlag game server,[Tim_Riker],[Tim_Riker],2003-07,,,,,
+asctrl-agent,5155,tcp,Oracle asControl Agent,[Todd_Guay],[Todd_Guay],2005-08,,,,,
+asctrl-agent,5155,udp,Oracle asControl Agent,[Todd_Guay],[Todd_Guay],2005-08,,,,,
+rugameonline,5156,tcp,Russian Online Game,[Andrey_Mohov],[Andrey_Mohov],2010-08-17,,,,,
+,5156,udp,Reserved,,,,,,,,
+mediat,5157,tcp,Mediat Remote Object Exchange,[Oliver_Anan],[Oliver_Anan],2010-09-02,,,,,
+,5157,udp,Reserved,,,,,,,,
+,5158-5160,,Unassigned,,,,,,,,
+snmpssh,5161,tcp,SNMP over SSH Transport Model,,,,,[RFC5592],,,
+,5161,udp,Reserved,,,,,,,,
+snmpssh-trap,5162,tcp,SNMP Notification over SSH Transport Model,,,,,[RFC5592],,Known Unauthorized Use on port 5162,
+,5162,udp,Reserved,,,,,,,Known Unauthorized Use on port 5162,
+sbackup,5163,tcp,Shadow Backup,[Glenn_Allen],[Glenn_Allen],2009-08-05,,,,,
+,5163,udp,Reserved,,,,,,,,
+vpa,5164,tcp,Virtual Protocol Adapter,[Douglas_Goodall],[Douglas_Goodall],2009-08-05,,,,,
+vpa-disc,5164,udp,Virtual Protocol Adapter Discovery,[Douglas_Goodall],[Douglas_Goodall],2009-08-05,,,,,
+ife-icorp,5165,tcp,"ife_1corp
+IANA assigned this well-formed service name as a replacement for ""ife_icorp"".",[Paul_Annala],[Paul_Annala],,,,,,
+ife_icorp,5165,tcp,ife_1corp,[Paul_Annala],[Paul_Annala],,,,,,"This entry is an alias to ""ife-icorp"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+ife-icorp,5165,udp,"ife_1corp
+IANA assigned this well-formed service name as a replacement for ""ife_icorp"".",[Paul_Annala],[Paul_Annala],,,,,,
+ife_icorp,5165,udp,ife_1corp,[Paul_Annala],[Paul_Annala],,,,,,"This entry is an alias to ""ife-icorp"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+winpcs,5166,tcp,WinPCS Service Connection,[Complan_Network_AS],[Complan_Network_AS],2006-02,,,,,
+winpcs,5166,udp,WinPCS Service Connection,[Complan_Network_AS],[Complan_Network_AS],2006-02,,,,,
+scte104,5167,tcp,SCTE104 Connection,[Thomas_Russell],[Thomas_Russell],2005-05,,,,,
+scte104,5167,udp,SCTE104 Connection,[Thomas_Russell],[Thomas_Russell],2005-05,,,,,
+scte30,5168,tcp,SCTE30 Connection,[Thomas_Russell],[Thomas_Russell],2005-05,,,,,
+scte30,5168,udp,SCTE30 Connection,[Thomas_Russell],[Thomas_Russell],2005-05,,,,,
+,5169-5171,,Unassigned,,,,,,,,
+pcoip-mgmt,5172,tcp,PC over IP Endpoint Management,[Teradici_2],[Paul_Helter],2014-04-28,,,,,
+,5172,udp,Reserved,,,,,,,,
+,5173-5189,,Unassigned,,,,,,,,
+aol,5190,tcp,America-Online,[Marty_Lyons],[Marty_Lyons],,,,,,
+aol,5190,udp,America-Online,[Marty_Lyons],[Marty_Lyons],,,,,,
+aol-1,5191,tcp,AmericaOnline1,[Bruce_Mackey],[Bruce_Mackey],,,,,,
+aol-1,5191,udp,AmericaOnline1,[Bruce_Mackey],[Bruce_Mackey],,,,,,
+aol-2,5192,tcp,AmericaOnline2,[Bruce_Mackey],[Bruce_Mackey],,,,,,
+aol-2,5192,udp,AmericaOnline2,[Bruce_Mackey],[Bruce_Mackey],,,,,,
+aol-3,5193,tcp,AmericaOnline3,[Bruce_Mackey],[Bruce_Mackey],,,,,,
+aol-3,5193,udp,AmericaOnline3,[Bruce_Mackey],[Bruce_Mackey],,,,,,
+cpscomm,5194,tcp,CipherPoint Config Service,[CipherPoint],[CipherPoint],2010-03-03,,,,,
+,5194,udp,Reserved,,,,,,,,
+ampl-lic,5195,tcp,The protocol is used by a license server and client programs to control use of program licenses that float to networked machines,[AMPL_Optimization],[David_M_Gay],2012-05-25,,,,,
+,5195,udp,Reserved,,,,,,,,
+ampl-tableproxy,5196,tcp,"The protocol is used by two programs that exchange ""table"" data used in the AMPL modeling language",[AMPL_Optimization],[David_M_Gay],2012-05-25,,,,,
+,5196,udp,Reserved,,,,,,,,
+,5197-5199,,Unassigned,,,,,,,,
+targus-getdata,5200,tcp,TARGUS GetData,[John_Keaveney],[John_Keaveney],,,,,,
+targus-getdata,5200,udp,TARGUS GetData,[John_Keaveney],[John_Keaveney],,,,,,
+targus-getdata1,5201,tcp,TARGUS GetData 1,[John_Keaveney],[John_Keaveney],,,,,,
+targus-getdata1,5201,udp,TARGUS GetData 1,[John_Keaveney],[John_Keaveney],,,,,,
+targus-getdata2,5202,tcp,TARGUS GetData 2,[John_Keaveney],[John_Keaveney],,,,,,
+targus-getdata2,5202,udp,TARGUS GetData 2,[John_Keaveney],[John_Keaveney],,,,,,
+targus-getdata3,5203,tcp,TARGUS GetData 3,[John_Keaveney],[John_Keaveney],,,,,,
+targus-getdata3,5203,udp,TARGUS GetData 3,[John_Keaveney],[John_Keaveney],,,,,,
+,5204-5208,,Unassigned,,,,,,,,
+nomad,5209,tcp,Nomad Device Video Transfer,[Morega_System],[Ashraf_Tahir],2012-08-20,,,,,
+,5209,udp,Reserved,,,,,,,,
+,5210-5214,,Unassigned,,,,,,,,
+noteza,5215,tcp,NOTEZA Data Safety Service,[CNS_a.s.],[Pavel_Mendl_2],2014-06-12,,,,,
+,5215,udp,Reserved,,,,,,,,
+noteza,5215,sctp,NOTEZA Data Safety Service,[CNS_a.s.],[Pavel_Mendl_2],2014-06-12,,,,,
+,5216-5220,,Unassigned,,,,,,,,
+3exmp,5221,tcp,3eTI Extensible Management Protocol for OAMP,[Bill_Rettig],[Bill_Rettig],2010-05-19,,,,,
+,5221,udp,Reserved,,,,,,,,
+xmpp-client,5222,tcp,XMPP Client Connection,,,,,[RFC6120],,,
+,5222,udp,Reserved,,,,,,,,
+hpvirtgrp,5223,tcp,HP Virtual Machine Group Management,[John_Williams],[John_Williams],2007-06,,,,,
+hpvirtgrp,5223,udp,HP Virtual Machine Group Management,[John_Williams],[John_Williams],2007-06,,,,,
+hpvirtctrl,5224,tcp,HP Virtual Machine Console Operations,[John_Williams],[John_Williams],2007-06,,,,,
+hpvirtctrl,5224,udp,HP Virtual Machine Console Operations,[John_Williams],[John_Williams],2007-06,,,,,
+hp-server,5225,tcp,HP Server,[Brett_Green_2],[Brett_Green_2],,,,,,
+hp-server,5225,udp,HP Server,[Brett_Green_2],[Brett_Green_2],,,,,,
+hp-status,5226,tcp,HP Status,[Brett_Green_2],[Brett_Green_2],,,,,,
+hp-status,5226,udp,HP Status,[Brett_Green_2],[Brett_Green_2],,,,,,
+perfd,5227,tcp,HP System Performance Metric Service,[Chris_Bertin],[Chris_Bertin],2009-05-19,,,,,
+perfd,5227,udp,HP System Performance Metric Service,[Chris_Bertin],[Chris_Bertin],2009-05-19,,,,,
+hpvroom,5228,tcp,HP Virtual Room Service,[Scott_Levin],[Scott_Levin],2009-03-19,,,,,
+,5228,udp,Reserved,,,,,,,,
+jaxflow,5229,tcp,Netflow/IPFIX/sFlow Collector and Forwarder Management,[JaxMP],[Stephen_Hull],2014-08-15,,,,,
+,5229,udp,Reserved,,,,,,,,
+jaxflow-data,5230,tcp,JaxMP RealFlow application and protocol data,[JaxMP],[Stephen_Hull],2014-08-15,,,,,
+,5230,udp,Reserved,,,,,,,,
+crusecontrol,5231,tcp,Remote Control of Scan Software for Cruse Scanners,[Cruse_Spezialmaschinen_GmbH],[Christof_J._Reetz_2],2014-08-15,,,,,
+,5231,udp,Reserved,,,,,,,,
+csedaemon,5232,tcp,Cruse Scanning System Service,[Christof_J_Reetz],[Christof_J_Reetz],2011-03-09,,,,,
+,5232,udp,Reserved,,,,,,,,
+enfs,5233,tcp,Etinnae Network File Service,[Chris_Peel],[Chris_Peel],2011-03-09,,,,,
+,5233,udp,Reserved,,,,,,,,
+eenet,5234,tcp,EEnet communications,[Helmut_Giritzer],[Helmut_Giritzer],2005-11,,,,,
+eenet,5234,udp,EEnet communications,[Helmut_Giritzer],[Helmut_Giritzer],2005-11,,,,,
+galaxy-network,5235,tcp,Galaxy Network Service,[Michael_Andre_2],[Michael_Andre_2],2007-10-04,,,,,
+galaxy-network,5235,udp,Galaxy Network Service,[Michael_Andre_2],[Michael_Andre_2],2007-10-04,,,,,
+padl2sim,5236,tcp,,,,,,,,,
+padl2sim,5236,udp,,,,,,,,,
+mnet-discovery,5237,tcp,m-net discovery,[Andy_Crick],[Andy_Crick],2007-11-13,,,,,
+mnet-discovery,5237,udp,m-net discovery,[Andy_Crick],[Andy_Crick],2007-11-13,,,,,
+,5238-5244,,Unassigned,,,,,,,,
+downtools,5245,tcp,DownTools Control Protocol,[Jarrod_Sayers],[Jarrod_Sayers],2009-04-07,,,,,
+downtools-disc,5245,udp,DownTools Discovery Protocol,[Jarrod_Sayers],[Jarrod_Sayers],2009-04-07,,,,,
+,5246,tcp,Reserved,,,,,,,,
+capwap-control,5246,udp,CAPWAP Control Protocol,,,,,[RFC5415],,,
+,5247,tcp,Reserved,,,,,,,,
+capwap-data,5247,udp,CAPWAP Data Protocol,,,,,[RFC5415],,,
+caacws,5248,tcp,CA Access Control Web Service,[Gabriel_Kalmar],[Gabriel_Kalmar],2008-03-06,,,,,
+caacws,5248,udp,CA Access Control Web Service,[Gabriel_Kalmar],[Gabriel_Kalmar],2008-03-06,,,,,
+caaclang2,5249,tcp,CA AC Lang Service,[Gabriel_Kalmar],[Gabriel_Kalmar],2008-02-19,,,,,
+caaclang2,5249,udp,CA AC Lang Service,[Gabriel_Kalmar],[Gabriel_Kalmar],2008-02-19,,,,,
+soagateway,5250,tcp,soaGateway,[Greg_Bodine],[Greg_Bodine],2002-02,,,,,
+soagateway,5250,udp,soaGateway,[Greg_Bodine],[Greg_Bodine],2002-02,,,,,
+caevms,5251,tcp,CA eTrust VM Service,[Kevin_Bond],[Kevin_Bond],2004-11,,,,,
+caevms,5251,udp,CA eTrust VM Service,[Kevin_Bond],[Kevin_Bond],2004-11,,,,,
+movaz-ssc,5252,tcp,Movaz SSC,[Lou_Berger],[Lou_Berger],2004-11,,,,,
+movaz-ssc,5252,udp,Movaz SSC,[Lou_Berger],[Lou_Berger],2004-11,,,,,
+kpdp,5253,tcp,Kohler Power Device Protocol,[Bill_Gross],[Bill_Gross],2010-11-01,,,,,
+,5253,udp,Reserved,,,,,,,,
+,5254-5263,,Unassigned,,,,,,,,
+3com-njack-1,5264,tcp,3Com Network Jack Port 1,[Abhay_Rajaram],[Abhay_Rajaram],2003-03,,,,,
+3com-njack-1,5264,udp,3Com Network Jack Port 1,[Abhay_Rajaram],[Abhay_Rajaram],2003-03,,,,,
+3com-njack-2,5265,tcp,3Com Network Jack Port 2,[Abhay_Rajaram],[Abhay_Rajaram],2003-03,,,,,
+3com-njack-2,5265,udp,3Com Network Jack Port 2,[Abhay_Rajaram],[Abhay_Rajaram],2003-03,,,,,
+,5266-5268,,Unassigned,,,,,,,,
+xmpp-server,5269,tcp,XMPP Server Connection,,,,,[RFC6120],,,
+,5269,udp,Reserved,,,,,,,,
+cartographerxmp,5270,tcp,Cartographer XMP,[Bobby_Krupczak_2],[Bobby_Krupczak_2],2008-04-03,2011-08-31,,,,
+cartographerxmp,5270,udp,Cartographer XMP,[Bobby_Krupczak_2],[Bobby_Krupczak_2],2008-04-03,2011-08-31,,,,
+cuelink,5271,tcp,StageSoft CueLink messaging,[Todd_Pichler],[Todd_Pichler],2010-03-26,,,,,
+cuelink-disc,5271,udp,StageSoft CueLink discovery,[Todd_Pichler],[Todd_Pichler],2010-03-26,,,,,
+pk,5272,tcp,PK,[Patrick_Kara],[Patrick_Kara],,,,,,
+pk,5272,udp,PK,[Patrick_Kara],[Patrick_Kara],,,,,,
+,5273-5279,,Unassigned,,,,,,,,
+xmpp-bosh,5280,tcp,Bidirectional-streams Over Synchronous HTTP (BOSH),[Peter_Saint_Andre],[Peter_Saint_Andre],2009-11-25,,,,,
+,5280,udp,Reserved,,,,,,,,
+undo-lm,5281,tcp,Undo License Manager,[Julian_Smith],[Julian_Smith],2010-04-19,,,,,
+,5281,udp,Reserved,,,,,,,,
+transmit-port,5282,tcp,Marimba Transmitter Port,[Johan_Eriksson],[Johan_Eriksson],2002-04,,,,,
+transmit-port,5282,udp,Marimba Transmitter Port,[Johan_Eriksson],[Johan_Eriksson],2002-04,,,,,
+,5283-5297,,Unassigned,,,,,,,,
+presence,5298,tcp,XMPP Link-Local Messaging,[Eric_St_Onge],[Eric_St_Onge],2008-01-14,,,,,Defined TXT keys: See http://www.xmpp.org/registrar/linklocal.html
+presence,5298,udp,XMPP Link-Local Messaging,[Eric_St_Onge],[Eric_St_Onge],2008-01-14,,,,,Defined TXT keys: See http://www.xmpp.org/registrar/linklocal.html
+nlg-data,5299,tcp,NLG Data Service,[Andy_Shellam],[Andy_Shellam],2008-02-19,,,,,
+nlg-data,5299,udp,NLG Data Service,[Andy_Shellam],[Andy_Shellam],2008-02-19,,,,,
+hacl-hb,5300,tcp,HA cluster heartbeat,[Eric_Soderberg_2][Edward_Yim],[Eric_Soderberg_2][Edward_Yim],,,,,,
+hacl-hb,5300,udp,HA cluster heartbeat,[Eric_Soderberg_2][Edward_Yim],[Eric_Soderberg_2][Edward_Yim],,,,,,
+hacl-gs,5301,tcp,HA cluster general services,[Eric_Soderberg_2][Edward_Yim],[Eric_Soderberg_2][Edward_Yim],,,,,,
+hacl-gs,5301,udp,HA cluster general services,[Eric_Soderberg_2][Edward_Yim],[Eric_Soderberg_2][Edward_Yim],,,,,,
+hacl-cfg,5302,tcp,HA cluster configuration,[Eric_Soderberg_2][Edward_Yim],[Eric_Soderberg_2][Edward_Yim],,,,,,
+hacl-cfg,5302,udp,HA cluster configuration,[Eric_Soderberg_2][Edward_Yim],[Eric_Soderberg_2][Edward_Yim],,,,,,
+hacl-probe,5303,tcp,HA cluster probing,[Eric_Soderberg_2][Edward_Yim],[Eric_Soderberg_2][Edward_Yim],,,,,,
+hacl-probe,5303,udp,HA cluster probing,[Eric_Soderberg_2][Edward_Yim],[Eric_Soderberg_2][Edward_Yim],,,,,,
+hacl-local,5304,tcp,HA Cluster Commands,[Eric_Soderberg_2][Edward_Yim],[Eric_Soderberg_2][Edward_Yim],,,,,,
+hacl-local,5304,udp,HA Cluster Commands,[Eric_Soderberg_2][Edward_Yim],[Eric_Soderberg_2][Edward_Yim],,,,,,
+hacl-test,5305,tcp,HA Cluster Test,[Eric_Soderberg_2][Edward_Yim],[Eric_Soderberg_2][Edward_Yim],,,,,,
+hacl-test,5305,udp,HA Cluster Test,[Eric_Soderberg_2][Edward_Yim],[Eric_Soderberg_2][Edward_Yim],,,,,,
+sun-mc-grp,5306,tcp,Sun MC Group,[Michael_DeMoney],[Michael_DeMoney],,,,,,
+sun-mc-grp,5306,udp,Sun MC Group,[Michael_DeMoney],[Michael_DeMoney],,,,,,
+sco-aip,5307,tcp,SCO AIP,[Barrie_Cooper],[Barrie_Cooper],,,,,,
+sco-aip,5307,udp,SCO AIP,[Barrie_Cooper],[Barrie_Cooper],,,,,,
+cfengine,5308,tcp,CFengine,[Mark_Burgess],[Mark_Burgess],,,,,,
+cfengine,5308,udp,CFengine,[Mark_Burgess],[Mark_Burgess],,,,,,
+jprinter,5309,tcp,J Printer,[Ken_Blackwell],[Ken_Blackwell],,,,,,
+jprinter,5309,udp,J Printer,[Ken_Blackwell],[Ken_Blackwell],,,,,,
+outlaws,5310,tcp,Outlaws,[Richard_Fife],[Richard_Fife],,,,,,
+outlaws,5310,udp,Outlaws,[Richard_Fife],[Richard_Fife],,,,,,
+,5311,,Unassigned,,,2004-05-07,,,,,
+permabit-cs,5312,tcp,Permabit Client-Server,[Jered_Floyd],[Jered_Floyd],2004-06,,,,,
+permabit-cs,5312,udp,Permabit Client-Server,[Jered_Floyd],[Jered_Floyd],2004-06,,,,,
+rrdp,5313,tcp,Real-time & Reliable Data,[Ted_Hoshi],[Ted_Hoshi],2004-06,,,,,
+rrdp,5313,udp,Real-time & Reliable Data,[Ted_Hoshi],[Ted_Hoshi],2004-06,,,,,
+opalis-rbt-ipc,5314,tcp,opalis-rbt-ipc,[Laurent_Domenech],[Laurent_Domenech],,,,,,
+opalis-rbt-ipc,5314,udp,opalis-rbt-ipc,[Laurent_Domenech],[Laurent_Domenech],,,,,,
+hacl-poll,5315,tcp,HA Cluster UDP Polling,[Hoa_Nguyen],[Hoa_Nguyen],,,,,,
+hacl-poll,5315,udp,HA Cluster UDP Polling,[Hoa_Nguyen],[Hoa_Nguyen],,,,,,
+hpbladems,5316,tcp,HPBladeSystem Monitor Service,[Alan_Minchew],[Alan_Minchew],2011-05-23,2011-05-16,,,,
+,5316,udp,Unassigned,,,2011-05-16,,,,,
+hpdevms,5317,tcp,HP Device Monitor Service,[Alan_Minchew],[Alan_Minchew],2011-05-16,,,,,
+,5317,udp,Reserved,,,,,,,,
+pkix-cmc,5318,tcp,PKIX Certificate Management using CMS (CMC),[IESG],[IETF_Chair],,,[RFC6402],,,
+,5318,udp,Reserved,,,,,,,,
+,5319,,Unassigned,,,,,,,,
+bsfserver-zn,5320,tcp,Webservices-based Zn interface of BSF,[Bert_Paul],[Bert_Paul],2008-05-01,,,,,
+,5320,udp,Reserved,,,,,,,,
+bsfsvr-zn-ssl,5321,tcp,Webservices-based Zn interface of BSF over SSL,[Bert_Paul],[Bert_Paul],2008-07-03,,,,,
+,5321,udp,Reserved,,,,,,,,
+,5322-5342,,Unassigned,,,,,,,,
+kfserver,5343,tcp,Sculptor Database Server,[Keith_Ashman],[Keith_Ashman],2005-12,,,,,
+kfserver,5343,udp,Sculptor Database Server,[Keith_Ashman],[Keith_Ashman],2005-12,,,,,
+xkotodrcp,5344,tcp,xkoto DRCP,[Jeff_Heisz],[Jeff_Heisz],2006-02,,,,,
+xkotodrcp,5344,udp,xkoto DRCP,[Jeff_Heisz],[Jeff_Heisz],2006-02,,,,,
+,5345-5348,,Unassigned,,,,,,,,
+stuns,5349,tcp,STUN over TLS,,,,,[RFC5389],,,
+stuns,5349,udp,STUN over DTLS,[IESG],[IETF_Chair],,2014-07-03,[RFC7350],,,This service name was initially created by [RFC5389].
+turns,5349,tcp,TURN over TLS,,,,,[RFC5766],,,
+turns,5349,udp,TURN over DTLS,[IESG],[IETF_Chair],,2014-07-03,[RFC7350],,,This service name was initially created by [RFC5766].
+stun-behaviors,5349,tcp,STUN Behavior Discovery over TLS,,,,,[RFC5780],,,
+stun-behaviors,5349,udp,Reserved for a future enhancement of STUN-BEHAVIOR,,,,,[RFC5780],,,
+,5350,tcp,Reserved,,,,,,,,
+pcp-multicast,5350,udp,Port Control Protocol Multicast,[IESG],[IETF_Chair],,,[RFC6887],,,
+,5351,tcp,Reserved,,,,,,,,
+pcp,5351,udp,Port Control Protocol,[IESG],[IETF_Chair],,,[RFC6887],,,
+dns-llq,5352,tcp,DNS Long-Lived Queries,[Kiren_Sekar],[Kiren_Sekar],2005-08,,,,,
+dns-llq,5352,udp,DNS Long-Lived Queries,[Kiren_Sekar],[Kiren_Sekar],2005-08,,,,,
+mdns,5353,tcp,Multicast DNS,[IESG],[IETF_Chair],,,[RFC6762],,,
+mdns,5353,udp,Multicast DNS,[IESG],[IETF_Chair],,,[RFC6762],,,
+mdnsresponder,5354,tcp,Multicast DNS Responder IPC,[Stuart_Cheshire_3],[Stuart_Cheshire_3],2004-06,,,,,
+mdnsresponder,5354,udp,Multicast DNS Responder IPC,[Stuart_Cheshire_3],[Stuart_Cheshire_3],2004-06,,,,,
+llmnr,5355,tcp,LLMNR,[Bernard_Aboba],[Bernard_Aboba],2004-06,,,,,
+llmnr,5355,udp,LLMNR,[Bernard_Aboba],[Bernard_Aboba],2004-06,,,,,
+ms-smlbiz,5356,tcp,Microsoft Small Business,[Gopikrishna_Sandra],[Gopikrishna_Sandra],2005-02,,,,,
+ms-smlbiz,5356,udp,Microsoft Small Business,[Gopikrishna_Sandra],[Gopikrishna_Sandra],2005-02,,,,,
+wsdapi,5357,tcp,Web Services for Devices,[Henry_Rawas],[Henry_Rawas],2005-08,,,,,
+wsdapi,5357,udp,Web Services for Devices,[Henry_Rawas],[Henry_Rawas],2005-08,,,,,
+wsdapi-s,5358,tcp,WS for Devices Secured,[Henry_Rawas],[Henry_Rawas],2005-08,,,,,
+wsdapi-s,5358,udp,WS for Devices Secured,[Henry_Rawas],[Henry_Rawas],2005-08,,,,,
+ms-alerter,5359,tcp,Microsoft Alerter,[Marc_McClure],[Marc_McClure],2007-08-07,,,,,
+ms-alerter,5359,udp,Microsoft Alerter,[Marc_McClure],[Marc_McClure],2007-08-07,,,,,
+ms-sideshow,5360,tcp,Protocol for Windows SideShow,[Dan_Polivy],[Dan_Polivy],2008-03-12,,,,,
+ms-sideshow,5360,udp,Protocol for Windows SideShow,[Dan_Polivy],[Dan_Polivy],2008-03-12,,,,,
+ms-s-sideshow,5361,tcp,Secure Protocol for Windows SideShow,[Dan_Polivy],[Dan_Polivy],2008-03-12,,,,,
+ms-s-sideshow,5361,udp,Secure Protocol for Windows SideShow,[Dan_Polivy],[Dan_Polivy],2008-03-12,,,,,
+serverwsd2,5362,tcp,Microsoft Windows Server WSD2 Service,[Erhan_Soyer_Osman],[Erhan_Soyer_Osman],2008-03-26,,,,,
+serverwsd2,5362,udp,Microsoft Windows Server WSD2 Service,[Erhan_Soyer_Osman],[Erhan_Soyer_Osman],2008-03-26,,,,,
+net-projection,5363,tcp,Windows Network Projection,[Rob_Williams],[Rob_Williams],2009-02-17,,,,,
+net-projection,5363,udp,Windows Network Projection,[Rob_Williams],[Rob_Williams],2009-02-17,,,,,
+kdnet,5364,udp,Microsoft Kernel Debugger,[Microsoft_Corporation_4],[Joe_Ballantyne],2013-06-16,,,,,
+,5364,tcp,Reserved,,,,,,,,
+,5365-5396,,Unassigned,,,,,,,,
+stresstester,5397,tcp,StressTester(tm) Injector,[Graham_Parsons],[Graham_Parsons],2005-08,,,,,
+stresstester,5397,udp,StressTester(tm) Injector,[Graham_Parsons],[Graham_Parsons],2005-08,,,,,
+elektron-admin,5398,tcp,Elektron Administration,[Chris_Hawk],[Chris_Hawk],2005-08,,,,,
+elektron-admin,5398,udp,Elektron Administration,[Chris_Hawk],[Chris_Hawk],2005-08,,,,,
+securitychase,5399,tcp,SecurityChase,[Daisuke_Shinomiya],[Daisuke_Shinomiya],2005-08,,,,,
+securitychase,5399,udp,SecurityChase,[Daisuke_Shinomiya],[Daisuke_Shinomiya],2005-08,,,,,
+excerpt,5400,tcp,Excerpt Search,[John_Hinsdale],[John_Hinsdale],,,,,,
+excerpt,5400,udp,Excerpt Search,[John_Hinsdale],[John_Hinsdale],,,,,,
+excerpts,5401,tcp,Excerpt Search Secure,[John_Hinsdale],[John_Hinsdale],,,,,,
+excerpts,5401,udp,Excerpt Search Secure,[John_Hinsdale],[John_Hinsdale],,,,,,
+mftp,5402,tcp,OmniCast MFTP,[Steve_Bannister],[Steve_Bannister],,,,,,
+mftp,5402,udp,OmniCast MFTP,[Steve_Bannister],[Steve_Bannister],,,,,,
+hpoms-ci-lstn,5403,tcp,HPOMS-CI-LSTN,[Harold_Froehling],[Harold_Froehling],,,,,,
+hpoms-ci-lstn,5403,udp,HPOMS-CI-LSTN,[Harold_Froehling],[Harold_Froehling],,,,,,
+hpoms-dps-lstn,5404,tcp,HPOMS-DPS-LSTN,[Harold_Froehling],[Harold_Froehling],,,,,,
+hpoms-dps-lstn,5404,udp,HPOMS-DPS-LSTN,[Harold_Froehling],[Harold_Froehling],,,,,,
+netsupport,5405,tcp,NetSupport,[Paul_Sanders_2],[Paul_Sanders_2],,,,,,
+netsupport,5405,udp,NetSupport,[Paul_Sanders_2],[Paul_Sanders_2],,,,,,
+systemics-sox,5406,tcp,Systemics Sox,[Gary_Howland],[Gary_Howland],,,,,,
+systemics-sox,5406,udp,Systemics Sox,[Gary_Howland],[Gary_Howland],,,,,,
+foresyte-clear,5407,tcp,Foresyte-Clear,[Jorge_Aldana],[Jorge_Aldana],,,,,,
+foresyte-clear,5407,udp,Foresyte-Clear,[Jorge_Aldana],[Jorge_Aldana],,,,,,
+foresyte-sec,5408,tcp,Foresyte-Sec,[Jorge_Aldana],[Jorge_Aldana],,,,,,
+foresyte-sec,5408,udp,Foresyte-Sec,[Jorge_Aldana],[Jorge_Aldana],,,,,,
+salient-dtasrv,5409,tcp,Salient Data Server,[Richard_Farnham],[Richard_Farnham],,,,,,
+salient-dtasrv,5409,udp,Salient Data Server,[Richard_Farnham],[Richard_Farnham],,,,,,
+salient-usrmgr,5410,tcp,Salient User Manager,[Richard_Farnham],[Richard_Farnham],,,,,,
+salient-usrmgr,5410,udp,Salient User Manager,[Richard_Farnham],[Richard_Farnham],,,,,,
+actnet,5411,tcp,ActNet,[Simon_Robillard],[Simon_Robillard],,,,,,
+actnet,5411,udp,ActNet,[Simon_Robillard],[Simon_Robillard],,,,,,
+continuus,5412,tcp,Continuus,[Steven_Holtsberg],[Steven_Holtsberg],,,,,,
+continuus,5412,udp,Continuus,[Steven_Holtsberg],[Steven_Holtsberg],,,,,,
+wwiotalk,5413,tcp,WWIOTALK,[Roger_Knobbe],[Roger_Knobbe],,,,,,
+wwiotalk,5413,udp,WWIOTALK,[Roger_Knobbe],[Roger_Knobbe],,,,,,
+statusd,5414,tcp,StatusD,[Stephen_Misel_2],[Stephen_Misel_2],,,,,,
+statusd,5414,udp,StatusD,[Stephen_Misel_2],[Stephen_Misel_2],,,,,,
+ns-server,5415,tcp,NS Server,[Jeffrey_Chiao],[Jeffrey_Chiao],,,,,,
+ns-server,5415,udp,NS Server,[Jeffrey_Chiao],[Jeffrey_Chiao],,,,,,
+sns-gateway,5416,tcp,SNS Gateway,[Mary_Holstage],[Mary_Holstage],,,,,,
+sns-gateway,5416,udp,SNS Gateway,[Mary_Holstage],[Mary_Holstage],,,,,,
+sns-agent,5417,tcp,SNS Agent,[Mary_Holstage],[Mary_Holstage],,,,,,
+sns-agent,5417,udp,SNS Agent,[Mary_Holstage],[Mary_Holstage],,,,,,
+mcntp,5418,tcp,MCNTP,[Heiko_Rupp],[Heiko_Rupp],,,,,,
+mcntp,5418,udp,MCNTP,[Heiko_Rupp],[Heiko_Rupp],,,,,,
+dj-ice,5419,tcp,DJ-ICE,[Don_Tyson_2],[Don_Tyson_2],,,,,,
+dj-ice,5419,udp,DJ-ICE,[Don_Tyson_2],[Don_Tyson_2],,,,,,
+cylink-c,5420,tcp,Cylink-C,[John_Jobe],[John_Jobe],,,,,,
+cylink-c,5420,udp,Cylink-C,[John_Jobe],[John_Jobe],,,,,,
+netsupport2,5421,tcp,Net Support 2,[Paul_Sanders],[Paul_Sanders],,,,,,
+netsupport2,5421,udp,Net Support 2,[Paul_Sanders],[Paul_Sanders],,,,,,
+salient-mux,5422,tcp,Salient MUX,[Richard_Farnham],[Richard_Farnham],,,,,,
+salient-mux,5422,udp,Salient MUX,[Richard_Farnham],[Richard_Farnham],,,,,,
+virtualuser,5423,tcp,VIRTUALUSER,[Chad_Williams],[Chad_Williams],,,,,,
+virtualuser,5423,udp,VIRTUALUSER,[Chad_Williams],[Chad_Williams],,,,,,
+beyond-remote,5424,tcp,Beyond Remote,[Michael_Berg],[Michael_Berg],2004-11,,,,,
+beyond-remote,5424,udp,Beyond Remote,[Michael_Berg],[Michael_Berg],2004-11,,,,,
+br-channel,5425,tcp,Beyond Remote Command Channel,[Michael_Berg],[Michael_Berg],2005-08,,,,,
+br-channel,5425,udp,Beyond Remote Command Channel,[Michael_Berg],[Michael_Berg],2005-08,,,,,
+devbasic,5426,tcp,DEVBASIC,[Curtis_Smith],[Curtis_Smith],,,,,,
+devbasic,5426,udp,DEVBASIC,[Curtis_Smith],[Curtis_Smith],,,,,,
+sco-peer-tta,5427,tcp,SCO-PEER-TTA,[Andrew_Shire],[Andrew_Shire],,,,,,
+sco-peer-tta,5427,udp,SCO-PEER-TTA,[Andrew_Shire],[Andrew_Shire],,,,,,
+telaconsole,5428,tcp,TELACONSOLE,[Joseph_M_Newcomer],[Joseph_M_Newcomer],,,,,,
+telaconsole,5428,udp,TELACONSOLE,[Joseph_M_Newcomer],[Joseph_M_Newcomer],,,,,,
+base,5429,tcp,Billing and Accounting System Exchange,[Odo_Maletzki],[Odo_Maletzki],,,,,,
+base,5429,udp,Billing and Accounting System Exchange,[Odo_Maletzki],[Odo_Maletzki],,,,,,
+radec-corp,5430,tcp,RADEC CORP,[David_Chell],[David_Chell],,,,,,
+radec-corp,5430,udp,RADEC CORP,[David_Chell],[David_Chell],,,,,,
+park-agent,5431,tcp,PARK AGENT,[John_Clifford],[John_Clifford],,,,,,
+park-agent,5431,udp,PARK AGENT,[John_Clifford],[John_Clifford],,,,,,
+postgresql,5432,tcp,PostgreSQL Database,[Tom_Lane],[Tom_Lane],,,,,,
+postgresql,5432,udp,PostgreSQL Database,[Tom_Lane],[Tom_Lane],,,,,,
+pyrrho,5433,tcp,Pyrrho DBMS,[Malcolm_Crowe],[Malcolm_Crowe],2005-11,,,,,
+pyrrho,5433,udp,Pyrrho DBMS,[Malcolm_Crowe],[Malcolm_Crowe],2005-11,,,,,
+sgi-arrayd,5434,tcp,SGI Array Services Daemon,[Karl_Feind],[Karl_Feind],2005-10,,,,,
+sgi-arrayd,5434,udp,SGI Array Services Daemon,[Karl_Feind],[Karl_Feind],2005-10,,,,,
+sceanics,5435,tcp,SCEANICS situation and action notification,[Richard_Olsen],[Richard_Olsen],,,,,,
+sceanics,5435,udp,SCEANICS situation and action notification,[Richard_Olsen],[Richard_Olsen],,,,,,
+,5436,tcp,Reserved,,,,,,,,
+pmip6-cntl,5436,udp,pmip6-cntl,,,,,[RFC5844],,,
+,5437,tcp,Reserved,,,,,,,,
+pmip6-data,5437,udp,pmip6-data,,,,,[RFC5844],,,
+,5438-5442,,Unassigned,,,,,,,,
+spss,5443,tcp,Pearson HTTPS,[Pearson],[Pearson],2008-01-17,,,,,
+spss,5443,udp,Pearson HTTPS,[Pearson],[Pearson],2008-01-17,,,,,
+,5444,,Unassigned,,,,,,,Known UNAUTHORIZED USE: Port 5444,
+smbdirect,5445,tcp,Server Message Block over Remote Direct Memory Access,[Microsoft_Corporation_2],[Tom_Talpey],2012-03-15,,,,,
+,5445,udp,Reserved,,,,,,,,
+smbdirect,5445,sctp,Server Message Block over Remote Direct Memory Access,[Microsoft_Corporation_2],[Tom_Talpey],2012-03-15,,,,,
+,5446-5452,,Unassigned,,,,,,,,
+surebox,5453,tcp,SureBox,[Emin_BORU],[Emin_BORU],2004-11,,,,,
+surebox,5453,udp,SureBox,[Emin_BORU],[Emin_BORU],2004-11,,,,,
+apc-5454,5454,tcp,APC 5454,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-5454,5454,udp,APC 5454,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-5455,5455,tcp,APC 5455,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-5455,5455,udp,APC 5455,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-5456,5456,tcp,APC 5456,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-5456,5456,udp,APC 5456,[American_Power_Conve],[American_Power_Conve],,,,,,
+,5457-5460,,Unassigned,,,,,,,,
+silkmeter,5461,tcp,SILKMETER,[Klaus_Fellner],[Klaus_Fellner],,,,,,
+silkmeter,5461,udp,SILKMETER,[Klaus_Fellner],[Klaus_Fellner],,,,,,
+ttl-publisher,5462,tcp,TTL Publisher,[Peter_Jacobs],[Peter_Jacobs],,,,,,
+ttl-publisher,5462,udp,TTL Publisher,[Peter_Jacobs],[Peter_Jacobs],,,,,,
+ttlpriceproxy,5463,tcp,TTL Price Proxy,[Peter_Jacobs],[Peter_Jacobs],,,,,,
+ttlpriceproxy,5463,udp,TTL Price Proxy,[Peter_Jacobs],[Peter_Jacobs],,,,,,
+quailnet,5464,tcp,Quail Networks Object Broker,[Craig_N_Bissell],[Craig_N_Bissell],2006-04,,,,,
+quailnet,5464,udp,Quail Networks Object Broker,[Craig_N_Bissell],[Craig_N_Bissell],2006-04,,,,,
+netops-broker,5465,tcp,NETOPS-BROKER,[John_R_Deuel],[John_R_Deuel],,,,,,
+netops-broker,5465,udp,NETOPS-BROKER,[John_R_Deuel],[John_R_Deuel],,,,,,
+,5466-5499,,Unassigned,,,,,,,,
+fcp-addr-srvr1,5500,tcp,fcp-addr-srvr1,[Ken_Wittmer],[Ken_Wittmer],,,,,,
+fcp-addr-srvr1,5500,udp,fcp-addr-srvr1,[Ken_Wittmer],[Ken_Wittmer],,,,,,
+fcp-addr-srvr2,5501,tcp,fcp-addr-srvr2,[Ken_Wittmer],[Ken_Wittmer],,,,,,
+fcp-addr-srvr2,5501,udp,fcp-addr-srvr2,[Ken_Wittmer],[Ken_Wittmer],,,,,,
+fcp-srvr-inst1,5502,tcp,fcp-srvr-inst1,[Ken_Wittmer],[Ken_Wittmer],,,,,,
+fcp-srvr-inst1,5502,udp,fcp-srvr-inst1,[Ken_Wittmer],[Ken_Wittmer],,,,,,
+fcp-srvr-inst2,5503,tcp,fcp-srvr-inst2,[Ken_Wittmer],[Ken_Wittmer],,,,,,
+fcp-srvr-inst2,5503,udp,fcp-srvr-inst2,[Ken_Wittmer],[Ken_Wittmer],,,,,,
+fcp-cics-gw1,5504,tcp,fcp-cics-gw1,[Ken_Wittmer],[Ken_Wittmer],,,,,,
+fcp-cics-gw1,5504,udp,fcp-cics-gw1,[Ken_Wittmer],[Ken_Wittmer],,,,,,
+checkoutdb,5505,tcp,Checkout Database,[Dirk_Stoop],[Dirk_Stoop],2007-04,,,,,
+checkoutdb,5505,udp,Checkout Database,[Dirk_Stoop],[Dirk_Stoop],2007-04,,,,,
+amc,5506,tcp,Amcom Mobile Connect,[Aaron_Fracht_Monroe],[Aaron_Fracht_Monroe],2010-06-03,,,,,
+amc,5506,udp,Amcom Mobile Connect,[Aaron_Fracht_Monroe],[Aaron_Fracht_Monroe],2010-06-03,,,,,
+,5507-5552,,Unassigned,,,,,,,,
+sgi-eventmond,5553,tcp,SGI Eventmond Port,[Andrei_Vilkotski],[Andrei_Vilkotski],2003-06,,,,,
+sgi-eventmond,5553,udp,SGI Eventmond Port,[Andrei_Vilkotski],[Andrei_Vilkotski],2003-06,,,,,
+sgi-esphttp,5554,tcp,SGI ESP HTTP,[Vladimir_Legalov],[Vladimir_Legalov],,,,,,
+sgi-esphttp,5554,udp,SGI ESP HTTP,[Vladimir_Legalov],[Vladimir_Legalov],,,,,,
+personal-agent,5555,tcp,Personal Agent,[Jackie_Wu],[Jackie_Wu],,,,,Known UNAUTHORIZED USEs on port 5555,
+personal-agent,5555,udp,Personal Agent,[Jackie_Wu],[Jackie_Wu],,,,,Known UNAUTHORIZED USEs on port 5555,
+freeciv,5556,tcp,Freeciv gameplay,[Reinier_Post_and_Pau],[Reinier_Post_and_Pau],2006-01,,,,Known Unauthorized Use on port 5556,
+freeciv,5556,udp,Freeciv gameplay,[Reinier_Post_and_Pau],[Reinier_Post_and_Pau],2006-01,,,,Known Unauthorized Use on port 5556,
+farenet,5557,tcp,Sandlab FARENET,[Kay_T_Labinsky],[Kay_T_Labinsky],2010-05-03,,,,,
+,5557,udp,Reserved,,,,,,,,
+,5558-5565,,Unassigned,,,,,,,,
+westec-connect,5566,tcp,Westec Connect,[Jon_Bolen],[Jon_Bolen],2009-03-18,,,,,
+,5566,udp,Reserved,,,,,,,,
+enc-eps-mc-sec,5567,tcp,EMIT protocol stack multicast/secure transport,[Panasonic_Intranet_Panasonic_North_America_PEWLA],[Bryant_Eastham],2004-11,2012-11-12,,,,
+enc-eps-mc-sec,5567,udp,EMIT protocol stack multicast/secure transport,[Panasonic_Intranet_Panasonic_North_America_PEWLA],[Bryant_Eastham],2004-11,2012-11-12,,,,
+sdt,5568,tcp,Session Data Transport Multicast,[Daniel_W_Antonuk],[Daniel_W_Antonuk],2006-05,,,,,
+sdt,5568,udp,Session Data Transport Multicast,[Daniel_W_Antonuk],[Daniel_W_Antonuk],2006-05,,,,,
+rdmnet-ctrl,5569,tcp,"PLASA E1.33, Remote Device Management (RDM) controller status notifications",[PLASA],[Simon_Newton],2012-06-01,,,,,
+rdmnet-device,5569,udp,"PLASA E1.33, Remote Device Management (RDM) messages",[PLASA],[Simon_Newton],2012-06-01,,,,,
+,5570-5572,,Unassigned,,,,,,,Known UNAUTHORIZED USE on Port 5570,
+sdmmp,5573,tcp,SAS Domain Management Messaging Protocol,[Ron_Zuckerman],[Ron_Zuckerman],2007-08-30,,,,,
+sdmmp,5573,udp,SAS Domain Management Messaging Protocol,[Ron_Zuckerman],[Ron_Zuckerman],2007-08-30,,,,,
+lsi-bobcat,5574,tcp,SAS IO Forwarding,[Mandar_Joshi],[Mandar_Joshi],2009-02-09,,,,,
+,5574,udp,Reserved,,,,,,,,
+ora-oap,5575,tcp,Oracle Access Protocol,[Peter_Povinec],[Peter_Povinec],2010-04-13,,,,,
+,5575,udp,Reserved,,,,,,,,
+,5576-5578,,Unassigned,,,,,,,,
+fdtracks,5579,tcp,FleetDisplay Tracking Service,[Henrik_Woffinden],[Henrik_Woffinden],2008-09-22,,,,,
+,5579,udp,Reserved,,,,,,,,
+tmosms0,5580,tcp,T-Mobile SMS Protocol Message 0,[Ezinne_Oji],[Ezinne_Oji],2006-06,,,,,
+tmosms0,5580,udp,T-Mobile SMS Protocol Message 0,[Ezinne_Oji],[Ezinne_Oji],2006-06,,,,,
+tmosms1,5581,tcp,T-Mobile SMS Protocol Message 1,[Ezinne_Oji],[Ezinne_Oji],2006-06,,,,,
+tmosms1,5581,udp,T-Mobile SMS Protocol Message 1,[Ezinne_Oji],[Ezinne_Oji],2006-06,,,,,
+fac-restore,5582,tcp,T-Mobile SMS Protocol Message 3,[Jessica_Yan],[Jessica_Yan],2008-02-19,,,,,
+fac-restore,5582,udp,T-Mobile SMS Protocol Message 3,[Jessica_Yan],[Jessica_Yan],2008-02-19,,,,,
+tmo-icon-sync,5583,tcp,T-Mobile SMS Protocol Message 2,[Donghwan_Lim],[Donghwan_Lim],2008-01-22,,,,,
+tmo-icon-sync,5583,udp,T-Mobile SMS Protocol Message 2,[Donghwan_Lim],[Donghwan_Lim],2008-01-22,,,,,
+bis-web,5584,tcp,BeInSync-Web,[Adi_Ruppin],[Adi_Ruppin],2005-08,,,,,
+bis-web,5584,udp,BeInSync-Web,[Adi_Ruppin],[Adi_Ruppin],2005-08,,,,,
+bis-sync,5585,tcp,BeInSync-sync,[Adi_Ruppin],[Adi_Ruppin],2005-08,,,,,
+bis-sync,5585,udp,BeInSync-sync,[Adi_Ruppin],[Adi_Ruppin],2005-08,,,,,
+att-mt-sms,5586,tcp,Planning to send mobile terminated SMS to the specific port so that the SMS is not visible to the client,[ATT],[Dhillesh_Sigilipelli],2014-08-21,,,,,
+,5586,udp,Reserved,,,,,,,,
+,5587-5596,,Unassigned,,,,,,,,
+ininmessaging,5597,tcp,inin secure messaging,[Mike_Gagle_2],[Mike_Gagle_2],2006-05,,,,,
+ininmessaging,5597,udp,inin secure messaging,[Mike_Gagle_2],[Mike_Gagle_2],2006-05,,,,,
+mctfeed,5598,tcp,MCT Market Data Feed,[Stephane_Touizer],[Stephane_Touizer],2006-05,,,,,
+mctfeed,5598,udp,MCT Market Data Feed,[Stephane_Touizer],[Stephane_Touizer],2006-05,,,,,
+esinstall,5599,tcp,Enterprise Security Remote Install,[Kimberly_Gibbs],[Kimberly_Gibbs],,,,,,
+esinstall,5599,udp,Enterprise Security Remote Install,[Kimberly_Gibbs],[Kimberly_Gibbs],,,,,,
+esmmanager,5600,tcp,Enterprise Security Manager,[Kimberly_Gibbs],[Kimberly_Gibbs],,,,,,
+esmmanager,5600,udp,Enterprise Security Manager,[Kimberly_Gibbs],[Kimberly_Gibbs],,,,,,
+esmagent,5601,tcp,Enterprise Security Agent,[Kimberly_Gibbs],[Kimberly_Gibbs],,,,,,
+esmagent,5601,udp,Enterprise Security Agent,[Kimberly_Gibbs],[Kimberly_Gibbs],,,,,,
+a1-msc,5602,tcp,A1-MSC,[Mike_Dolan],[Mike_Dolan],,,,,,
+a1-msc,5602,udp,A1-MSC,[Mike_Dolan],[Mike_Dolan],,,,,,
+a1-bs,5603,tcp,A1-BS,[Mike_Dolan],[Mike_Dolan],,,,,,
+a1-bs,5603,udp,A1-BS,[Mike_Dolan],[Mike_Dolan],,,,,,
+a3-sdunode,5604,tcp,A3-SDUNode,[Mike_Dolan],[Mike_Dolan],,,,,,
+a3-sdunode,5604,udp,A3-SDUNode,[Mike_Dolan],[Mike_Dolan],,,,,,
+a4-sdunode,5605,tcp,A4-SDUNode,[Mike_Dolan],[Mike_Dolan],,,,,,
+a4-sdunode,5605,udp,A4-SDUNode,[Mike_Dolan],[Mike_Dolan],,,,,,
+,5606-5617,,Unassigned,,,,,,,,
+efr,5618,tcp,Fiscal Registering Protocol,[efsta],[Alois_Reisinger],2013-08-13,,,,,
+,5618,udp,Reserved,,,,,,,,
+,5619-5626,,Unassigned,,,,,,,,
+ninaf,5627,tcp,Node Initiated Network Association Forma,[Thomas_Scholl],[Thomas_Scholl],2006-03,,,,,
+ninaf,5627,udp,Node Initiated Network Association Forma,[Thomas_Scholl],[Thomas_Scholl],2006-03,,,,,
+htrust,5628,tcp,HTrust API,[Karl_Olafsson],[Karl_Olafsson],2008-10-24,,,,,
+htrust,5628,udp,HTrust API,[Karl_Olafsson],[Karl_Olafsson],2008-10-24,,,,,
+symantec-sfdb,5629,tcp,Symantec Storage Foundation for Database,[Quang_Thoi],[Quang_Thoi],2006-11,,,,,
+symantec-sfdb,5629,udp,Symantec Storage Foundation for Database,[Quang_Thoi],[Quang_Thoi],2006-11,,,,,
+precise-comm,5630,tcp,PreciseCommunication,[Alon_Tamir],[Alon_Tamir],2006-04,,,,,
+precise-comm,5630,udp,PreciseCommunication,[Alon_Tamir],[Alon_Tamir],2006-04,,,,,
+pcanywheredata,5631,tcp,pcANYWHEREdata,[Jon_Rosarky],[Jon_Rosarky],,,,,,
+pcanywheredata,5631,udp,pcANYWHEREdata,[Jon_Rosarky],[Jon_Rosarky],,,,,,
+pcanywherestat,5632,tcp,pcANYWHEREstat,[Jon_Rosarky],[Jon_Rosarky],,,,,,
+pcanywherestat,5632,udp,pcANYWHEREstat,[Jon_Rosarky],[Jon_Rosarky],,,,,,
+beorl,5633,tcp,BE Operations Request Listener,[Chirag_Desai],[Chirag_Desai],2006-02,,,,,
+beorl,5633,udp,BE Operations Request Listener,[Chirag_Desai],[Chirag_Desai],2006-02,,,,,
+xprtld,5634,tcp,SF Message Service,[VR_Satish],[VR_Satish],2007-08-16,,,,,
+xprtld,5634,udp,SF Message Service,[VR_Satish],[VR_Satish],2007-08-16,,,,,
+sfmsso,5635,tcp,SFM Authentication Subsystem,[De_Chih_Chien],[De_Chih_Chien],2008-09-15,,,,,
+,5635,udp,Reserved,,,,,,,,
+sfm-db-server,5636,tcp,SFMdb - SFM DB server,[De_Chih_Chien],[De_Chih_Chien],2008-10-06,,,,,
+,5636,udp,Reserved,,,,,,,,
+cssc,5637,tcp,Symantec CSSC,[Amol_P_Tambe],[Amol_P_Tambe],2011-02-02,,,,,
+,5637,udp,Reserved,,,,,,,,
+flcrs,5638,tcp,Symantec Fingerprint Lookup and Container Reference Service,[Symantec_Corp],[Neel_A_Bhatt],2012-01-03,,,,,
+,5638,udp,Reserved,,,,,,,,
+ics,5639,tcp,Symantec Integrity Checking Service,[Symantec_Corp2],[Danzhou_Liu],2012-05-07,,,,,
+,5639,udp,Reserved,,,,,,,,
+,5640-5645,,Unassigned,,,,,,,,
+vfmobile,5646,tcp,Ventureforth Mobile,[Ventureforth_Inc],[Blakely_Snyder],2011-11-03,,,,,
+,5646,udp,Reserved,,,,,,,,
+,5647-5669,,Unassigned,,,,,,,Known UNAUTHORIZED USE: Port 5666,
+filemq,5670,tcp,ZeroMQ file publish-subscribe protocol,[Pieter_Hintjens2],[Pieter_Hintjens2],2012-11-01,2013-02-25,,,,
+zre-disc,5670,udp,Local area discovery and messaging over ZeroMQ,[Pieter_Hintjens_3],[Pieter_Hintjens_3],2012-12-17,,,,,
+amqps,5671,tcp,amqp protocol over TLS/SSL,[Ted_Ross_2],[Ted_Ross_2],2008-03-26,,,,,
+amqps,5671,udp,amqp protocol over TLS/SSL,[Ted_Ross_2],[Ted_Ross_2],2008-03-26,,,,,
+amqp,5672,tcp,AMQP,[Pieter_Hintjens],[Pieter_Hintjens],2006-01,,,,,
+amqp,5672,udp,AMQP,[Pieter_Hintjens],[Pieter_Hintjens],2006-01,,,,,
+amqp,5672,sctp,AMQP,[Martin_Sustrik],[Martin_Sustrik],2007-03,,,,,
+jms,5673,tcp,JACL Message Server,[Stuart_Allen],[Stuart_Allen],2002-02,,,,,
+jms,5673,udp,JACL Message Server,[Stuart_Allen],[Stuart_Allen],2002-02,,,,,
+hyperscsi-port,5674,tcp,HyperSCSI Port,[Data_Storage_Institu],[Data_Storage_Institu],2002-02,,,,,
+hyperscsi-port,5674,udp,HyperSCSI Port,[Data_Storage_Institu],[Data_Storage_Institu],2002-02,,,,,
+v5ua,5675,tcp,V5UA application port,,,,,[RFC3807],,,
+v5ua,5675,udp,V5UA application port,,,,,[RFC3807],,,
+v5ua,5675,sctp,V5UA application port,,,,,[RFC3807],,,
+raadmin,5676,tcp,RA Administration,[Sergei_Zjaikin],[Sergei_Zjaikin],2002-02,,,,,
+raadmin,5676,udp,RA Administration,[Sergei_Zjaikin],[Sergei_Zjaikin],2002-02,,,,,
+questdb2-lnchr,5677,tcp,Quest Central DB2 Launchr,[Robert_M_Mackowiak],[Robert_M_Mackowiak],2002-02,,,,,
+questdb2-lnchr,5677,udp,Quest Central DB2 Launchr,[Robert_M_Mackowiak],[Robert_M_Mackowiak],2002-02,,,,,
+rrac,5678,tcp,Remote Replication Agent Connection,,,,,,,,
+rrac,5678,udp,Remote Replication Agent Connection,,,,,,,,
+dccm,5679,tcp,Direct Cable Connect Manager,[Mark_Miller_2],[Mark_Miller_2],,,,,,
+dccm,5679,udp,Direct Cable Connect Manager,[Mark_Miller_2],[Mark_Miller_2],,,,,,
+auriga-router,5680,tcp,Auriga Router Service,[Vincent_Gaudeul],[Vincent_Gaudeul],2006-02,,,,,
+auriga-router,5680,udp,Auriga Router Service,[Vincent_Gaudeul],[Vincent_Gaudeul],2006-02,,,,,
+ncxcp,5681,tcp,Net-coneX Control Protocol,[Ryan_Werber],[Ryan_Werber],2006-06,,,,,
+ncxcp,5681,udp,Net-coneX Control Protocol,[Ryan_Werber],[Ryan_Werber],2006-06,,,,,
+,5682,tcp,Reserved,,,,,,,,
+brightcore,5682,udp,BrightCore control & data transfer exchange,[Marko_Bjelac],[Marko_Bjelac],2010-06-10,,,,,
+,5683,tcp,Reserved,,,,,,,,
+coap,5683,udp,Constrained Application Protocol,[IESG],[IETF_Chair],2011-06-13,2013-07-25,[RFC7252],,,
+,5684,tcp,Reserved,,,,,,,,
+coaps,5684,udp,DTLS-secured CoAP,[IESG],[IETF_Chair],2013-07-25,,[RFC7252],,,
+,5685-5686,,Unassigned,,,,,,,,
+gog-multiplayer,5687,udp,GOG multiplayer game protocol,[GOG.com],[Michal_Gruchala],2014-07-31,2014-10-09,,,,
+,5687,tcp,Reserved,,,,,,,,
+ggz,5688,tcp,GGZ Gaming Zone,[Josef_Spillner],[Josef_Spillner],2003-01,,,,,
+ggz,5688,udp,GGZ Gaming Zone,[Josef_Spillner],[Josef_Spillner],2003-01,,,,,
+qmvideo,5689,tcp,QM video network management protocol,[Jamie_Lokier],[Jamie_Lokier],2006-05,,,,,
+qmvideo,5689,udp,QM video network management protocol,[Jamie_Lokier],[Jamie_Lokier],2006-05,,,,,
+,5690-5692,,Unassigned,,,,,,,,
+rbsystem,5693,tcp,Robert Bosch Data Transfer,[Robert_Bosch_GmbH],[Klaus_Warth],2011-08-01,2012-07-17,,,,
+,5693,udp,Reserved,,,,,,,,
+,5694-5695,,Unassigned,,,,,,,,
+kmip,5696,tcp,Key Management Interoperability Protocol,[OASIS_KMIP_Technical_Committee],[Robin_Cover],2011-07-25,,,,,
+,5696,udp,Reserved,,,,,,,,
+,5697-5712,,Unassigned,,,,,,,,
+proshareaudio,5713,tcp,proshare conf audio,[gunner],[gunner],,,,,,
+proshareaudio,5713,udp,proshare conf audio,[gunner],[gunner],,,,,,
+prosharevideo,5714,tcp,proshare conf video,[gunner],[gunner],,,,,,
+prosharevideo,5714,udp,proshare conf video,[gunner],[gunner],,,,,,
+prosharedata,5715,tcp,proshare conf data,[gunner],[gunner],,,,,,
+prosharedata,5715,udp,proshare conf data,[gunner],[gunner],,,,,,
+prosharerequest,5716,tcp,proshare conf request,[gunner],[gunner],,,,,,
+prosharerequest,5716,udp,proshare conf request,[gunner],[gunner],,,,,,
+prosharenotify,5717,tcp,proshare conf notify,[gunner],[gunner],,,,,,
+prosharenotify,5717,udp,proshare conf notify,,,,,,,,
+dpm,5718,tcp,DPM Communication Server,[Sundar_Srinivasan][Vinay_Badami],[Sundar_Srinivasan][Vinay_Badami],,,,,,
+dpm,5718,udp,DPM Communication Server,[Sundar_Srinivasan][Vinay_Badami],[Sundar_Srinivasan][Vinay_Badami],,,,,,
+dpm-agent,5719,tcp,DPM Agent Coordinator,[Sundar_Srinivasan][Vinay_Badami],[Sundar_Srinivasan][Vinay_Badami],2006-05,,,,,
+dpm-agent,5719,udp,DPM Agent Coordinator,[Sundar_Srinivasan][Vinay_Badami],[Sundar_Srinivasan][Vinay_Badami],2006-05,,,,,
+ms-licensing,5720,tcp,MS-Licensing,[Thomas_Lindeman],[Thomas_Lindeman],2002-11,,,,,
+ms-licensing,5720,udp,MS-Licensing,[Thomas_Lindeman],[Thomas_Lindeman],2002-11,,,,,
+dtpt,5721,tcp,Desktop Passthru Service,[Dan_Leising],[Dan_Leising],2005-01,,,,,
+dtpt,5721,udp,Desktop Passthru Service,[Dan_Leising],[Dan_Leising],2005-01,,,,,
+msdfsr,5722,tcp,Microsoft DFS Replication Service,[Guhan_Suriyanarayana],[Guhan_Suriyanarayana],2006-03,,,,,
+msdfsr,5722,udp,Microsoft DFS Replication Service,[Guhan_Suriyanarayana],[Guhan_Suriyanarayana],2006-03,,,,,
+omhs,5723,tcp,Operations Manager - Health Service,[Gerardo_Dilillo],[Gerardo_Dilillo],2006-08,,,,,
+omhs,5723,udp,Operations Manager - Health Service,[Gerardo_Dilillo],[Gerardo_Dilillo],2006-08,,,,,
+omsdk,5724,tcp,Operations Manager - SDK Service,[Gerardo_Dilillo],[Gerardo_Dilillo],2006-08,,,,,
+omsdk,5724,udp,Operations Manager - SDK Service,[Gerardo_Dilillo],[Gerardo_Dilillo],2006-08,,,,,
+ms-ilm,5725,tcp,Microsoft Identity Lifecycle Manager,[Rob_Ward],[Rob_Ward],,,,,,
+,5725,udp,Reserved,,,2008-05-02,,,,,
+ms-ilm-sts,5726,tcp,Microsoft Lifecycle Manager Secure Token Service,[Rob_Ward],[Rob_Ward],,,,,,
+,5726,udp,Reserved,,,2008-05-02,,,,,
+asgenf,5727,tcp,ASG Event Notification Framework,[Arman_Bedonian],[Arman_Bedonian],2009-07-15,,,,,
+,5727,udp,Reserved,,,,,,,,
+io-dist-data,5728,tcp,Dist. I/O Comm. Service Data and Control,[Harish_Kuttan],[Harish_Kuttan],2010-03-22,,,,,
+io-dist-group,5728,udp,Dist. I/O Comm. Service Group Membership,[Harish_Kuttan],[Harish_Kuttan],2010-03-22,,,,,
+openmail,5729,tcp,Openmail User Agent Layer,[OpenMail_Encyclopedi][Don_Loughry],[OpenMail_Encyclopedi][Don_Loughry],,,,,,
+openmail,5729,udp,Openmail User Agent Layer,[OpenMail_Encyclopedi][Don_Loughry],[OpenMail_Encyclopedi][Don_Loughry],,,,,,
+unieng,5730,tcp,Steltor's calendar access,[Bernard_Desruisseaux],[Bernard_Desruisseaux],,,,,,
+unieng,5730,udp,Steltor's calendar access,[Bernard_Desruisseaux],[Bernard_Desruisseaux],,,,,,
+,5731-5740,,Unassigned,,,,,,,,
+ida-discover1,5741,tcp,IDA Discover Port 1,[MPITech_Support],[MPITech_Support],,,,,,
+ida-discover1,5741,udp,IDA Discover Port 1,[MPITech_Support],[MPITech_Support],,,,,,
+ida-discover2,5742,tcp,IDA Discover Port 2,[MPITech_Support],[MPITech_Support],,,,,,
+ida-discover2,5742,udp,IDA Discover Port 2,[MPITech_Support],[MPITech_Support],,,,,,
+watchdoc-pod,5743,tcp,Watchdoc NetPOD Protocol,[Christophe_Chevalier],[Christophe_Chevalier],2005-08,,,,,
+watchdoc-pod,5743,udp,Watchdoc NetPOD Protocol,[Christophe_Chevalier],[Christophe_Chevalier],2005-08,,,,,
+watchdoc,5744,tcp,Watchdoc Server,[Christophe_Chevalier],[Christophe_Chevalier],2004-11,,,,,
+watchdoc,5744,udp,Watchdoc Server,[Christophe_Chevalier],[Christophe_Chevalier],2004-11,,,,,
+fcopy-server,5745,tcp,fcopy-server,[Moshe_Leibovitch],[Moshe_Leibovitch],,,,,,
+fcopy-server,5745,udp,fcopy-server,[Moshe_Leibovitch],[Moshe_Leibovitch],,,,,,
+fcopys-server,5746,tcp,fcopys-server,[Moshe_Leibovitch],[Moshe_Leibovitch],,,,,,
+fcopys-server,5746,udp,fcopys-server,[Moshe_Leibovitch],[Moshe_Leibovitch],,,,,,
+tunatic,5747,tcp,Wildbits Tunatic,[Sylvain_Demongeot],[Sylvain_Demongeot],2005-08,,,,,
+tunatic,5747,udp,Wildbits Tunatic,[Sylvain_Demongeot],[Sylvain_Demongeot],2005-08,,,,,
+tunalyzer,5748,tcp,Wildbits Tunalyzer,[Sylvain_Demongeot],[Sylvain_Demongeot],2005-08,,,,,
+tunalyzer,5748,udp,Wildbits Tunalyzer,[Sylvain_Demongeot],[Sylvain_Demongeot],2005-08,,,,,
+,5749,,Unassigned,,,,,,,,
+rscd,5750,tcp,Bladelogic Agent Service,[Brian_Trevor],[Brian_Trevor],2008-10-24,,,,,
+rscd,5750,udp,Bladelogic Agent Service,[Brian_Trevor],[Brian_Trevor],2008-10-24,,,,,
+,5751-5754,,Unassigned,,,,,,,,
+openmailg,5755,tcp,OpenMail Desk Gateway server,[OpenMail_Encyclopedi][Don_Loughry],[OpenMail_Encyclopedi][Don_Loughry],,,,,,
+openmailg,5755,udp,OpenMail Desk Gateway server,[OpenMail_Encyclopedi][Don_Loughry],[OpenMail_Encyclopedi][Don_Loughry],,,,,,
+,5756,,Unassigned,,,,,,,,
+x500ms,5757,tcp,OpenMail X.500 Directory Server,[OpenMail_Encyclopedi][Don_Loughry],[OpenMail_Encyclopedi][Don_Loughry],,,,,,
+x500ms,5757,udp,OpenMail X.500 Directory Server,[OpenMail_Encyclopedi][Don_Loughry],[OpenMail_Encyclopedi][Don_Loughry],,,,,,
+,5758-5765,,Unassigned,,,,,,,,
+openmailns,5766,tcp,OpenMail NewMail Server,[OpenMail_Encyclopedi][Don_Loughry],[OpenMail_Encyclopedi][Don_Loughry],,,,,,
+openmailns,5766,udp,OpenMail NewMail Server,[OpenMail_Encyclopedi][Don_Loughry],[OpenMail_Encyclopedi][Don_Loughry],,,,,,
+s-openmail,5767,tcp,OpenMail Suer Agent Layer (Secure),[OpenMail_Encyclopedi][Don_Loughry],[OpenMail_Encyclopedi][Don_Loughry],,,,,,
+s-openmail,5767,udp,OpenMail Suer Agent Layer (Secure),[OpenMail_Encyclopedi][Don_Loughry],[OpenMail_Encyclopedi][Don_Loughry],,,,,,
+openmailpxy,5768,tcp,OpenMail CMTS Server,[OpenMail_Encyclopedi][Don_Loughry],[OpenMail_Encyclopedi][Don_Loughry],,,,,,
+openmailpxy,5768,udp,OpenMail CMTS Server,[OpenMail_Encyclopedi][Don_Loughry],[OpenMail_Encyclopedi][Don_Loughry],,,,,,
+spramsca,5769,tcp,x509solutions Internal CA,[Brendan_Fay],[Brendan_Fay],2006-02,,,,,
+spramsca,5769,udp,x509solutions Internal CA,[Brendan_Fay],[Brendan_Fay],2006-02,,,,,
+spramsd,5770,tcp,x509solutions Secure Data,[Brendan_Fay],[Brendan_Fay],2006-02,,,,,
+spramsd,5770,udp,x509solutions Secure Data,[Brendan_Fay],[Brendan_Fay],2006-02,,,,,
+netagent,5771,tcp,NetAgent,[Bradley_Birnbaum],[Bradley_Birnbaum],,,,,,
+netagent,5771,udp,NetAgent,[Bradley_Birnbaum],[Bradley_Birnbaum],,,,,,
+,5772-5776,,Unassigned,,,,,,,,
+dali-port,5777,tcp,DALI Port,[Wayne_Morrow][Michael_Melio],[Wayne_Morrow][Michael_Melio],2003-10,,,,,
+dali-port,5777,udp,DALI Port,[Wayne_Morrow][Michael_Melio],[Wayne_Morrow][Michael_Melio],2003-10,,,,,
+,5778-5779,,Unassigned,,,,,,,,
+vts-rpc,5780,tcp,Visual Tag System RPC,[Graham_Bloice],[Graham_Bloice],2009-09-17,,,,,
+,5780,udp,Reserved,,,,,,,,
+3par-evts,5781,tcp,3PAR Event Reporting Service,[Sushil_Thomas],[Sushil_Thomas],2008-03-10,,,,,
+3par-evts,5781,udp,3PAR Event Reporting Service,[Sushil_Thomas],[Sushil_Thomas],2008-03-10,,,,,
+3par-mgmt,5782,tcp,3PAR Management Service,[Don_Marselle],[Don_Marselle],2008-04-09,,,,,
+3par-mgmt,5782,udp,3PAR Management Service,[Don_Marselle],[Don_Marselle],2008-04-09,,,,,
+3par-mgmt-ssl,5783,tcp,3PAR Management Service with SSL,[Don_Marselle],[Don_Marselle],2008-03-19,,,,,
+3par-mgmt-ssl,5783,udp,3PAR Management Service with SSL,[Don_Marselle],[Don_Marselle],2008-03-19,,,,,
+,5784,tcp,Reserved,,,,,,,,
+ibar,5784,udp,Cisco Interbox Application Redundancy,[Cullen_Jennings],[Cullen_Jennings],2010-02-03,,,,,
+3par-rcopy,5785,tcp,3PAR Inform Remote Copy,[Don_Marselle],[Don_Marselle],2010-02-03,,,,,
+3par-rcopy,5785,udp,3PAR Inform Remote Copy,[Don_Marselle],[Don_Marselle],2008-04-09,,,,,
+,5786,tcp,Reserved,,,,,,,,
+cisco-redu,5786,udp,redundancy notification,[Ming_Zhang],[Ming_Zhang],2010-02-04,,,,,
+,5787,tcp,Reserved,,,,,,,,
+waascluster,5787,udp,Cisco WAAS Cluster Protocol,[Winston_Chou],[Winston_Chou],2011-02-08,,,,,
+,5788-5792,,Unassigned,,,,,,,,
+xtreamx,5793,tcp,XtreamX Supervised Peer message,[Ahmad_Tajuddin_Samsu],[Ahmad_Tajuddin_Samsu],2007-02,,,,,
+xtreamx,5793,udp,XtreamX Supervised Peer message,[Ahmad_Tajuddin_Samsu],[Ahmad_Tajuddin_Samsu],2007-02,,,,,
+,5794,tcp,Reserved,,,,,,,,
+spdp,5794,udp,Simple Peered Discovery Protocol,[Dave_Lindquist],[Dave_Lindquist],2010-05-27,,,,,
+,5795-5812,,Unassigned,,,,,,,,
+icmpd,5813,tcp,ICMPD,[Shane_O_Donnell],[Shane_O_Donnell],,,,,,
+icmpd,5813,udp,ICMPD,[Shane_O_Donnell],[Shane_O_Donnell],,,,,,
+spt-automation,5814,tcp,Support Automation,[Joshua_Hawkins],[Joshua_Hawkins],2003-11,,,,,
+spt-automation,5814,udp,Support Automation,[Joshua_Hawkins],[Joshua_Hawkins],2003-11,,,,,
+,5815-5840,,Unassigned,,,,,,,,
+shiprush-d-ch,5841,tcp,Z-firm ShipRush interface for web access and bidirectional data,[Z-Firm_LLC],[Rafael_Zimberoff],2014-08-22,,,,,
+,5841,udp,Reserved,,,,,,,,
+reversion,5842,tcp,Reversion Backup/Restore,[Cameo_Systems_Inc],[Craig_Nelson],2011-09-26,,,,,
+,5842,udp,Reserved,,,,,,,,
+,5843-5858,,Unassigned,,,,,,,,
+wherehoo,5859,tcp,WHEREHOO,[Jim_Youll],[Jim_Youll],,,,,,
+wherehoo,5859,udp,WHEREHOO,[Jim_Youll],[Jim_Youll],,,,,,
+,5860-5862,,Unassigned,,,,,,,,
+ppsuitemsg,5863,tcp,PlanetPress Suite Messeng,[Yannick_Fortin],[Yannick_Fortin],2006-02,,,,,
+ppsuitemsg,5863,udp,PlanetPress Suite Messeng,[Yannick_Fortin],[Yannick_Fortin],2006-02,,,,,
+,5864-5867,,Unassigned,,,,,,,,
+diameters,5868,tcp,Diameter over TLS/TCP,[IESG],[IETF_Chair],,,[RFC6733],,,
+,5868,udp,Reserved,,,,,,,,
+diameters,5868,sctp,Diameter over DTLS/SCTP,[IESG],[IETF_Chair],,,[RFC6733],,,
+,5869-5882,,Unassigned,,,,,,,,
+jute,5883,tcp,Javascript Unit Test Environment,[Mark_Ethan_Trostler],[Mark_Ethan_Trostler],2011-11-23,,,,,
+,5884-5899,,Unassigned,,,,,,,,
+rfb,5900,tcp,Remote Framebuffer,[Tristan_Richardson],[Tristan_Richardson],2006-03,,[RFC6143],,,
+rfb,5900,udp,Remote Framebuffer,[Tristan_Richardson],[Tristan_Richardson],2006-03,,[RFC6143],,,
+,5901-5909,,Unassigned,,,,,,,,
+cm,5910,tcp,Context Management,[Eivan_Cerasi],[Eivan_Cerasi],2008-10-10,,,,,
+cm,5910,udp,Context Management,[Eivan_Cerasi],[Eivan_Cerasi],2008-10-10,,,,,
+cm,5910,sctp,Context Management,[Justin_Yu],[Justin_Yu],2011-05-19,,,,,
+cpdlc,5911,tcp,Controller Pilot Data Link Communication,[Eivan_Cerasi],[Eivan_Cerasi],2008-10-10,,,,,
+cpdlc,5911,udp,Controller Pilot Data Link Communication,[Eivan_Cerasi],[Eivan_Cerasi],2008-10-10,,,,,
+cpdlc,5911,sctp,Controller Pilot Data Link Communication,[Justin_Yu],[Justin_Yu],2011-05-18,,,,,
+fis,5912,tcp,Flight Information Services,[Eivan_Cerasi],[Eivan_Cerasi],2008-10-10,,,,,
+fis,5912,udp,Flight Information Services,[Eivan_Cerasi],[Eivan_Cerasi],2008-10-10,,,,,
+fis,5912,sctp,Flight Information Services,[Justin_Yu],[Justin_Yu],2011-05-25,,,,,
+ads-c,5913,tcp,Automatic Dependent Surveillance,[Eivan_Cerasi],[Eivan_Cerasi],2008-10-10,,,,,
+ads-c,5913,udp,Automatic Dependent Surveillance,[Eivan_Cerasi],[Eivan_Cerasi],2008-10-10,,,,,
+ads-c,5913,sctp,Automatic Dependent Surveillance,[Justin_Yu],[Justin_Yu],2011-05-25,,,,,
+,5914-5962,,Unassigned,,,,,,,,
+indy,5963,tcp,Indy Application Server,[Bjorn_Lantz],[Bjorn_Lantz],2004-11,,,,,
+indy,5963,udp,Indy Application Server,[Bjorn_Lantz],[Bjorn_Lantz],2004-11,,,,,
+,5964-5967,,Unassigned,,,,,,,,
+mppolicy-v5,5968,tcp,mppolicy-v5,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+mppolicy-v5,5968,udp,mppolicy-v5,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+mppolicy-mgr,5969,tcp,mppolicy-mgr,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+mppolicy-mgr,5969,udp,mppolicy-mgr,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+,5970-5983,,Unassigned,,,,,,,,
+couchdb,5984,tcp,CouchDB,[Noah_Slater],[Noah_Slater],2007-11-27,,,,,
+couchdb,5984,udp,CouchDB,[Noah_Slater],[Noah_Slater],2007-11-27,,,,,
+wsman,5985,tcp,WBEM WS-Management HTTP,[Jim_Davis],[Jim_Davis],2006-11,,,,,
+wsman,5985,udp,WBEM WS-Management HTTP,[Jim_Davis],[Jim_Davis],2006-11,,,,,
+wsmans,5986,tcp,WBEM WS-Management HTTP over TLS/SSL,[Jim_Davis],[Jim_Davis],2006-11,,,,,
+wsmans,5986,udp,WBEM WS-Management HTTP over TLS/SSL,[Jim_Davis],[Jim_Davis],2006-11,,,,,
+wbem-rmi,5987,tcp,WBEM RMI,[Jim_Davis],[Jim_Davis],,,,,,
+wbem-rmi,5987,udp,WBEM RMI,[Jim_Davis],[Jim_Davis],,,,,,
+wbem-http,5988,tcp,WBEM CIM-XML (HTTP),[Jim_Davis],[Jim_Davis],,,,,,
+wbem-http,5988,udp,WBEM CIM-XML (HTTP),[Jim_Davis],[Jim_Davis],,,,,,
+wbem-https,5989,tcp,WBEM CIM-XML (HTTPS),[Jim_Davis],[Jim_Davis],,,,,,
+wbem-https,5989,udp,WBEM CIM-XML (HTTPS),[Jim_Davis],[Jim_Davis],,,,,,
+wbem-exp-https,5990,tcp,WBEM Export HTTPS,[Denise_Eckstein],[Denise_Eckstein],2004-11,,,,,
+wbem-exp-https,5990,udp,WBEM Export HTTPS,[Denise_Eckstein],[Denise_Eckstein],2004-11,,,,,
+nuxsl,5991,tcp,NUXSL,[Kai_Kretschmann],[Kai_Kretschmann],2002-03,,,,,
+nuxsl,5991,udp,NUXSL,[Kai_Kretschmann],[Kai_Kretschmann],2002-03,,,,,
+consul-insight,5992,tcp,Consul InSight Security,[Arthur_Hillenaar],[Arthur_Hillenaar],2006-01,,,,,
+consul-insight,5992,udp,Consul InSight Security,[Arthur_Hillenaar],[Arthur_Hillenaar],2006-01,,,,,
+,5993-5998,,Unassigned,,,,,,,,
+cvsup,5999,tcp,CVSup,[Randall_Atkinson_2],[Randall_Atkinson_2],,,,,,
+cvsup,5999,udp,CVSup,[Randall_Atkinson_2],[Randall_Atkinson_2],,,,,,
+x11,6000-6063,tcp,X Window System,[Stephen_Gildea],[Stephen_Gildea],,,,,Known Unauthorized Use on port 6003,
+x11,6000-6063,udp,X Window System,[Stephen_Gildea],[Stephen_Gildea],,,,,Known Unauthorized Use on port 6003,
+ndl-ahp-svc,6064,tcp,NDL-AHP-SVC,[John_Richmond_2],[John_Richmond_2],,,,,,
+ndl-ahp-svc,6064,udp,NDL-AHP-SVC,[John_Richmond_2],[John_Richmond_2],,,,,,
+winpharaoh,6065,tcp,WinPharaoh,[Basil_Lee],[Basil_Lee],,,,,,
+winpharaoh,6065,udp,WinPharaoh,[Basil_Lee],[Basil_Lee],,,,,,
+ewctsp,6066,tcp,EWCTSP,[Mark_Bailon],[Mark_Bailon],,,,,,
+ewctsp,6066,udp,EWCTSP,[Mark_Bailon],[Mark_Bailon],,,,,,
+,6067,,Unassigned,,,,2007-07-17,,,,
+gsmp-ancp,6068,tcp,GSMP/ANCP,[Avri_Doria],[Avri_Doria],,,[RFC6320],,,
+,6068,udp,Reserved,,,,,,,,
+trip,6069,tcp,TRIP,[Hussein_F_Salama],[Hussein_F_Salama],,,,,,
+trip,6069,udp,TRIP,[Hussein_F_Salama],[Hussein_F_Salama],,,,,,
+messageasap,6070,tcp,Messageasap,[Murray_Freeman],[Murray_Freeman],,,,,,
+messageasap,6070,udp,Messageasap,[Murray_Freeman],[Murray_Freeman],,,,,,
+ssdtp,6071,tcp,SSDTP,[Michael_Shearson_2],[Michael_Shearson_2],,,,,,
+ssdtp,6071,udp,SSDTP,[Michael_Shearson_2],[Michael_Shearson_2],,,,,,
+diagnose-proc,6072,tcp,DIAGNOSE-PROC,[Allan_Miller],[Allan_Miller],,,,,,
+diagnose-proc,6072,udp,DIAGNOSE-PROC,[Allan_Miller],[Allan_Miller],,,,,,
+directplay8,6073,tcp,DirectPlay8,[John_Kane],[John_Kane],,,,,,
+directplay8,6073,udp,DirectPlay8,[John_Kane],[John_Kane],,,,,,
+max,6074,tcp,Microsoft Max,[Jay_Beavers],[Jay_Beavers],2006-02,,,,,
+max,6074,udp,Microsoft Max,[Jay_Beavers],[Jay_Beavers],2006-02,,,,,
+dpm-acm,6075,tcp,Microsoft DPM Access Control Manager,[Prabu_Ambravaneswara],[Prabu_Ambravaneswara],2009-10-29,,,,,
+,6075,udp,Reserved,,,,,,,,
+msft-dpm-cert,6076,tcp,Microsoft DPM WCF Certificates,[Microsoft_Corporation],[Prateek_Sharma],2011-08-04,,,,,
+,6076,udp,Reserved,,,,,,,,
+iconstructsrv,6077,tcp,iConstruct Server,[iConstruct_Aus_Pty_Ltd],[Afshin_Jafari],2012-12-21,,,,,
+,6077,udp,Reserved,,,,,,,,
+,6078-6080,,Unassigned,,,,,,,,
+geneve,6081,udp,Generic Network Virtualization Encapsulation (Geneve),[Jesse_Gross],[Jesse_Gross],2014-03-27,,[draft-gross-geneve-00],,,
+,6081,tcp,Reserved,,,,,,,,
+,6082,tcp,Reserved,,,,,,,,
+p25cai,6082,udp,APCO Project 25 Common Air Interface - UDP encapsulation,[APCO_Project],[APCO_Project],2011-05-13,,,,,
+,6083,tcp,Reserved,,,,,,,,
+miami-bcast,6083,udp,telecomsoftware miami broadcast,[Peter_Steiner],[Peter_Steiner],2011-02-22,,,,,
+reload-config,6084,tcp,Peer to Peer Infrastructure Configuration,[IESG],[IETF_Chair],2009-01-29,2013-03-26,[RFC6940],,,
+,6084,udp,Reserved,,,,,,,,
+konspire2b,6085,tcp,konspire2b p2p network,[Jason_Rohrer],[Jason_Rohrer],2002-10,,,,,
+konspire2b,6085,udp,konspire2b p2p network,[Jason_Rohrer],[Jason_Rohrer],2002-10,,,,,
+pdtp,6086,tcp,PDTP P2P,[Tony_Arcieri],[Tony_Arcieri],2006-03,,,,,
+pdtp,6086,udp,PDTP P2P,[Tony_Arcieri],[Tony_Arcieri],2006-03,,,,,
+ldss,6087,tcp,Local Download Sharing Service,[Clifford_Heath],[Clifford_Heath],2006-05,,,,,
+ldss,6087,udp,Local Download Sharing Service,[Clifford_Heath],[Clifford_Heath],2006-05,,,,,
+doglms,6088,tcp,SuperDog License Manager,[SafeNet],[Rob_Tao],2012-07-26,,,,,
+doglms-notify,6088,udp,SuperDog License Manager Notifier,[SafeNet],[Rob_Tao],2012-07-26,,,,,
+,6089-6098,,Unassigned,,,,,,,,
+raxa-mgmt,6099,tcp,RAXA Management,[Sukanta_Ganguly],[Sukanta_Ganguly],,,,,,
+,6099,udp,Reserved,,,,,,,,
+synchronet-db,6100,tcp,SynchroNet-db,[Arne_Haugland],[Arne_Haugland],,,,,Known Unauthorized Use on port 6100,
+synchronet-db,6100,udp,SynchroNet-db,[Arne_Haugland],[Arne_Haugland],,,,,Known Unauthorized Use on port 6100,
+synchronet-rtc,6101,tcp,SynchroNet-rtc,[Arne_Haugland],[Arne_Haugland],,,,,,
+synchronet-rtc,6101,udp,SynchroNet-rtc,[Arne_Haugland],[Arne_Haugland],,,,,,
+synchronet-upd,6102,tcp,SynchroNet-upd,[Arne_Haugland],[Arne_Haugland],,,,,,
+synchronet-upd,6102,udp,SynchroNet-upd,[Arne_Haugland],[Arne_Haugland],,,,,,
+rets,6103,tcp,RETS,[Bruce_Toback],[Bruce_Toback],,,,,,
+rets,6103,udp,RETS,[Bruce_Toback],[Bruce_Toback],,,,,,
+dbdb,6104,tcp,DBDB,[Aaron_Brick],[Aaron_Brick],,,,,,
+dbdb,6104,udp,DBDB,[Aaron_Brick],[Aaron_Brick],,,,,,
+primaserver,6105,tcp,Prima Server,[Prima_Designs_System],[Prima_Designs_System],,,,,,
+primaserver,6105,udp,Prima Server,[Prima_Designs_System],[Prima_Designs_System],,,,,,
+mpsserver,6106,tcp,MPS Server,[Prima_Designs_System],[Prima_Designs_System],,,,,,
+mpsserver,6106,udp,MPS Server,[Prima_Designs_System],[Prima_Designs_System],,,,,,
+etc-control,6107,tcp,ETC Control,[Steve_Polishinski],[Steve_Polishinski],,,,,,
+etc-control,6107,udp,ETC Control,[Steve_Polishinski],[Steve_Polishinski],,,,,,
+sercomm-scadmin,6108,tcp,Sercomm-SCAdmin,[Melinda_Tsao_2],[Melinda_Tsao_2],,,,,,
+sercomm-scadmin,6108,udp,Sercomm-SCAdmin,[Melinda_Tsao_2],[Melinda_Tsao_2],,,,,,
+globecast-id,6109,tcp,GLOBECAST-ID,[Piers_Scannell_2],[Piers_Scannell_2],,,,,,
+globecast-id,6109,udp,GLOBECAST-ID,[Piers_Scannell_2],[Piers_Scannell_2],,,,,,
+softcm,6110,tcp,HP SoftBench CM,[Scott_A_Kramer],[Scott_A_Kramer],,,,,,
+softcm,6110,udp,HP SoftBench CM,[Scott_A_Kramer],[Scott_A_Kramer],,,,,,
+spc,6111,tcp,HP SoftBench Sub-Process Control,[Scott_A_Kramer],[Scott_A_Kramer],,,,,,
+spc,6111,udp,HP SoftBench Sub-Process Control,[Scott_A_Kramer],[Scott_A_Kramer],,,,,,
+dtspcd,6112,tcp,Desk-Top Sub-Process Control Daemon,[Doug_Royer],[Doug_Royer],2010-12-08,,,,,
+dtspcd,6112,udp,Desk-Top Sub-Process Control Daemon,[Doug_Royer],[Doug_Royer],2010-12-08,,,,,
+dayliteserver,6113,tcp,Daylite Server,[Brent_Gulanowski],[Brent_Gulanowski],2009-08-26,,,,,
+,6113,udp,Reserved,,,,,,,,
+wrspice,6114,tcp,WRspice IPC Service,[Stephen_R_Whiteley],[Stephen_R_Whiteley],2010-10-07,,,,,
+,6114,udp,Reserved,,,,,,,,
+xic,6115,tcp,Xic IPC Service,[Stephen_R_Whiteley],[Stephen_R_Whiteley],2010-10-07,,,,,
+,6115,udp,Reserved,,,,,,,,
+xtlserv,6116,tcp,XicTools License Manager Service,[Stephen_R_Whiteley],[Stephen_R_Whiteley],2010-10-07,,,,,
+,6116,udp,Reserved,,,,,,,,
+daylitetouch,6117,tcp,Daylite Touch Sync,[Brent_Gulanowski],[Brent_Gulanowski],2009-08-26,,,,,
+,6117,udp,Reserved,,,,,,,,
+tipc,6118,udp,Transparent Inter Process Communication,[Ericsson],[Erik_Hugne],2012-09-05,,,,,
+,6118,tcp,Reserved,,,,,,,,
+,6119-6120,,Unassigned,,,,,,,,
+spdy,6121,tcp,SPDY for a faster web,[Matthew_Lloyd],[Matthew_Lloyd],2010-04-26,,,,,
+,6121,udp,Reserved,,,,,,,,
+bex-webadmin,6122,tcp,Backup Express Web Server,[Chi_Shih_Chang],[Chi_Shih_Chang],2008-03-19,,,,,
+bex-webadmin,6122,udp,Backup Express Web Server,[Chi_Shih_Chang],[Chi_Shih_Chang],2008-03-19,,,,,
+backup-express,6123,tcp,Backup Express,[Chi_Shih_Chang],[Chi_Shih_Chang],2008-03-19,,,,,
+backup-express,6123,udp,Backup Express,[Chi_Shih_Chang],[Chi_Shih_Chang],2008-03-19,,,,,
+pnbs,6124,tcp,Phlexible Network Backup Service,[William_R_Lear_2],[William_R_Lear_2],2008-10-23,,,,,
+pnbs,6124,udp,Phlexible Network Backup Service,[William_R_Lear_2],[William_R_Lear_2],2008-10-23,,,,,
+,6125-6129,,Unassigned,,,,,,,,
+damewaremobgtwy,6130,tcp,The DameWare Mobile Gateway Service,[SolarWinds],[David_Gayler],2013-05-29,,,,,
+,6130,udp,Reserved,,,,,,,,
+,6131-6132,,Unassigned,,,,,,,,
+nbt-wol,6133,tcp,New Boundary Tech WOL,[Elizabeth_Zilen],[Elizabeth_Zilen],2004-11,,,,,
+nbt-wol,6133,udp,New Boundary Tech WOL,[Elizabeth_Zilen],[Elizabeth_Zilen],2004-11,,,,,
+,6134-6139,,Unassigned,,,,,,,,
+pulsonixnls,6140,tcp,Pulsonix Network License Service,[David_Manns],[David_Manns],2008-02-28,,,,,
+pulsonixnls,6140,udp,Pulsonix Network License Service,[David_Manns],[David_Manns],2008-02-28,,,,,
+meta-corp,6141,tcp,Meta Corporation License Manager,[Osamu_Masuda],[Osamu_Masuda],,,,,,
+meta-corp,6141,udp,Meta Corporation License Manager,[Osamu_Masuda],[Osamu_Masuda],,,,,,
+aspentec-lm,6142,tcp,Aspen Technology License Manager,[Kevin_Massey],[Kevin_Massey],,,,,,
+aspentec-lm,6142,udp,Aspen Technology License Manager,[Kevin_Massey],[Kevin_Massey],,,,,,
+watershed-lm,6143,tcp,Watershed License Manager,[David_Ferrero],[David_Ferrero],,,,,,
+watershed-lm,6143,udp,Watershed License Manager,[David_Ferrero],[David_Ferrero],,,,,,
+statsci1-lm,6144,tcp,StatSci License Manager - 1,[Scott_Blachowicz],[Scott_Blachowicz],,,,,,
+statsci1-lm,6144,udp,StatSci License Manager - 1,[Scott_Blachowicz],[Scott_Blachowicz],,,,,,
+statsci2-lm,6145,tcp,StatSci License Manager - 2,[Scott_Blachowicz],[Scott_Blachowicz],,,,,,
+statsci2-lm,6145,udp,StatSci License Manager - 2,[Scott_Blachowicz],[Scott_Blachowicz],,,,,,
+lonewolf-lm,6146,tcp,Lone Wolf Systems License Manager,[Dan_Klein],[Dan_Klein],,,,,,
+lonewolf-lm,6146,udp,Lone Wolf Systems License Manager,[Dan_Klein],[Dan_Klein],,,,,,
+montage-lm,6147,tcp,Montage License Manager,[Michael_Ubell],[Michael_Ubell],,,,,,
+montage-lm,6147,udp,Montage License Manager,[Michael_Ubell],[Michael_Ubell],,,,,,
+ricardo-lm,6148,tcp,Ricardo North America License Manager,[M_Flemming],[M_Flemming],,,,,,
+ricardo-lm,6148,udp,Ricardo North America License Manager,[M_Flemming],[M_Flemming],,,,,,
+tal-pod,6149,tcp,tal-pod,[Steven_Loomis],[Steven_Loomis],,,,,,
+tal-pod,6149,udp,tal-pod,[Steven_Loomis],[Steven_Loomis],,,,,,
+,6150-6158,,Unassigned,,,,,,,,
+efb-aci,6159,tcp,EFB Application Control Interface,[Jonathan_Schaaf],[Jonathan_Schaaf],2010-02-10,,,,,
+,6159,udp,Reserved,,,,,,,,
+ecmp,6160,tcp,Emerson Extensible Control and Management Protocol,[Bryce_Beeston],[Bryce_Beeston],2011-06-23,,,,,
+ecmp-data,6160,udp,Emerson Extensible Control and Management Protocol Data,[Bryce_Beeston],[Bryce_Beeston],2011-06-23,,,,,
+patrol-ism,6161,tcp,PATROL Internet Srv Mgr,[Portnoy_Boxman],[Portnoy_Boxman],2005-01,,,,,
+patrol-ism,6161,udp,PATROL Internet Srv Mgr,[Portnoy_Boxman],[Portnoy_Boxman],2005-01,,,,,
+patrol-coll,6162,tcp,PATROL Collector,[Portnoy_Boxman],[Portnoy_Boxman],2005-01,,,,,
+patrol-coll,6162,udp,PATROL Collector,[Portnoy_Boxman],[Portnoy_Boxman],2005-01,,,,,
+pscribe,6163,tcp,Precision Scribe Cnx Port,[Robert_W_Hodges],[Robert_W_Hodges],2005-01,,,,,
+pscribe,6163,udp,Precision Scribe Cnx Port,[Robert_W_Hodges],[Robert_W_Hodges],2005-01,,,,,
+,6164-6199,,Unassigned,,,,,,,,
+lm-x,6200,tcp,LM-X License Manager by X-Formation,[Henrik_Goldman],[Henrik_Goldman],2006-10,,,,Known Unauthorized Use on port 6200,
+lm-x,6200,udp,LM-X License Manager by X-Formation,[Henrik_Goldman],[Henrik_Goldman],2006-10,,,,Known Unauthorized Use on port 6200,
+,6201,tcp,Reserved,,,,,,,,
+thermo-calc,6201,udp,Management of service nodes in a processing grid for thermodynamic calculations,[Thermo-Calc_Software],[Thomas_Revesz],2012-06-28,,,,,
+,6202-6221,,Unassigned,,,,,,,,
+radmind,6222,tcp,Radmind Access Protocol,[Patrick_M_McNeal],[Patrick_M_McNeal],2006-03,,,,,
+radmind,6222,udp,Radmind Access Protocol,[Patrick_M_McNeal],[Patrick_M_McNeal],2006-03,,,,,
+,6223-6240,,Unassigned,,,,,,,,
+jeol-nsdtp-1,6241,tcp,JEOL Network Services Data Transport Protocol 1,[Kevin_Wellwood],[Kevin_Wellwood],2008-04-17,,,,,
+jeol-nsddp-1,6241,udp,JEOL Network Services Dynamic Discovery Protocol 1,[Kevin_Wellwood],[Kevin_Wellwood],2008-04-17,,,,,
+jeol-nsdtp-2,6242,tcp,JEOL Network Services Data Transport Protocol 2,[Kevin_Wellwood],[Kevin_Wellwood],2008-04-17,,,,,
+jeol-nsddp-2,6242,udp,JEOL Network Services Dynamic Discovery Protocol 2,[Kevin_Wellwood],[Kevin_Wellwood],2008-04-17,,,,,
+jeol-nsdtp-3,6243,tcp,JEOL Network Services Data Transport Protocol 3,[Kevin_Wellwood],[Kevin_Wellwood],2008-04-17,,,,,
+jeol-nsddp-3,6243,udp,JEOL Network Services Dynamic Discovery Protocol 3,[Kevin_Wellwood],[Kevin_Wellwood],2008-04-17,,,,,
+jeol-nsdtp-4,6244,tcp,JEOL Network Services Data Transport Protocol 4,[Kevin_Wellwood],[Kevin_Wellwood],2008-04-17,,,,,
+jeol-nsddp-4,6244,udp,JEOL Network Services Dynamic Discovery Protocol 4,[Kevin_Wellwood],[Kevin_Wellwood],2008-04-17,,,,,
+,6245-6250,,Unassigned,,,,,,,,
+tl1-raw-ssl,6251,tcp,TL1 Raw Over SSL/TLS,[Jim_Humphreys],[Jim_Humphreys],2008-01-29,,,,,
+tl1-raw-ssl,6251,udp,TL1 Raw Over SSL/TLS,[Jim_Humphreys],[Jim_Humphreys],2008-01-29,,,,,
+tl1-ssh,6252,tcp,TL1 over SSH,[Jim_Humphreys],[Jim_Humphreys],2008-01-25,,,,,
+tl1-ssh,6252,udp,TL1 over SSH,[Jim_Humphreys],[Jim_Humphreys],2008-01-25,,,,,
+crip,6253,tcp,CRIP,[Mike_Rodbell],[Mike_Rodbell],,,,,,
+crip,6253,udp,CRIP,[Mike_Rodbell],[Mike_Rodbell],,,,,,
+,6254-6266,,Unassigned,,,,,,,,
+gld,6267,tcp,GridLAB-D User Interface,[David_Chassin],[David_Chassin],2010-12-10,,,,,
+,6267,udp,Reserved,,,,,,,,
+grid,6268,tcp,Grid Authentication,[Jason_Hamilton],[Jason_Hamilton],2006-06,,,,,
+grid,6268,udp,Grid Authentication,[Jason_Hamilton],[Jason_Hamilton],2006-06,,,,,
+grid-alt,6269,tcp,Grid Authentication Alt,[Jason_Hamilton],[Jason_Hamilton],2006-06,,,,,
+grid-alt,6269,udp,Grid Authentication Alt,[Jason_Hamilton],[Jason_Hamilton],2006-06,,,,,
+,6270-6299,,Unassigned,,,,,,,,
+bmc-grx,6300,tcp,BMC GRX,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmc-grx,6300,udp,BMC GRX,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmc-ctd-ldap,6301,tcp,"BMC CONTROL-D LDAP SERVER
+IANA assigned this well-formed service name as a replacement for ""bmc_ctd_ldap"".",[Portnoy_Boxman_2],[Portnoy_Boxman_2],2006-09,,,,,
+bmc_ctd_ldap,6301,tcp,BMC CONTROL-D LDAP SERVER,[Portnoy_Boxman_2],[Portnoy_Boxman_2],2006-09,,,,,"This entry is an alias to ""bmc-ctd-ldap"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+bmc-ctd-ldap,6301,udp,"BMC CONTROL-D LDAP SERVER
+IANA assigned this well-formed service name as a replacement for ""bmc_ctd_ldap"".",[Portnoy_Boxman_2],[Portnoy_Boxman_2],2006-09,,,,,
+bmc_ctd_ldap,6301,udp,BMC CONTROL-D LDAP SERVER,[Portnoy_Boxman_2],[Portnoy_Boxman_2],2006-09,,,,,"This entry is an alias to ""bmc-ctd-ldap"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+,6302-6305,,Unassigned,,,,,,,,
+ufmp,6306,tcp,Unified Fabric Management Protocol,[Albert_Berlovitch],[Albert_Berlovitch],2009-12-17,,,,,
+ufmp,6306,udp,Unified Fabric Management Protocol,[Albert_Berlovitch],[Albert_Berlovitch],2009-12-17,,,,,
+,6307-6314,,Unassigned,,,,,,,,
+scup,6315,tcp,Sensor Control Unit Protocol,[Sven_Kopacz],[Sven_Kopacz],2010-09-01,,,,,
+scup-disc,6315,udp,Sensor Control Unit Protocol Discovery Protocol,[Sven_Kopacz],[Sven_Kopacz],2010-09-01,,,,,
+abb-escp,6316,tcp,Ethernet Sensor Communications Protocol,[Jaime_Antolin],[Jaime_Antolin],2008-09-25,,,,,
+abb-escp,6316,udp,Ethernet Sensor Communications Protocol,[Jaime_Antolin],[Jaime_Antolin],2008-09-25,,,,,
+nav-data-cmd,6317,tcp,Navtech Radar Sensor Data Command,[Navtech_Radar_Ltd],[Guy_Avery],2013-02-20,,,,,
+nav-data,6317,udp,Navtech Radar Sensor Data,[Navtech_Radar_Ltd],[Guy_Avery],2013-02-20,,,,,
+,6318-6319,,Unassigned,,,,,,,,
+repsvc,6320,tcp,Double-Take Replication Service,[James_Wilkinson],[James_Wilkinson],2006-04,,,,,
+repsvc,6320,udp,Double-Take Replication Service,[James_Wilkinson],[James_Wilkinson],2006-04,,,,,
+emp-server1,6321,tcp,Empress Software Connectivity Server 1,[Srdjan_Holovac],[Srdjan_Holovac],,,,,,
+emp-server1,6321,udp,Empress Software Connectivity Server 1,[Srdjan_Holovac],[Srdjan_Holovac],,,,,,
+emp-server2,6322,tcp,Empress Software Connectivity Server 2,[Srdjan_Holovac],[Srdjan_Holovac],,,,,,
+emp-server2,6322,udp,Empress Software Connectivity Server 2,[Srdjan_Holovac],[Srdjan_Holovac],,,,,,
+,6323,,Unassigned,,,,,,,,
+hrd-ncs,6324,tcp,HR Device Network Configuration Service,[Hall_Research],[Vishal_Dharmadhikari],2011-11-29,,,,,
+hrd-ns-disc,6324,udp,HR Device Network service,[Hall_Research],[Vishal_Dharmadhikari],2011-11-29,,,,,
+dt-mgmtsvc,6325,tcp,Double-Take Management Service,[Vision_Solutions],[James_Wilkinson2],2012-06-06,,,,,
+,6325,udp,Reserved,,,,,,,,
+dt-vra,6326,tcp,Double-Take Virtual Recovery Assistant,[Vision_Solutions],[James_Wilkinson2],2012-10-08,,,,,
+,6326,udp,Reserved,,,,,,,,
+,6327-6342,,Unassigned,,,,,,,,
+sflow,6343,tcp,sFlow traffic monitoring,[Peter_Phaal],[Peter_Phaal],2003-06,,,,,
+sflow,6343,udp,sFlow traffic monitoring,[Peter_Phaal],[Peter_Phaal],2003-06,,,,,
+streletz,6344,tcp,Argus-Spectr security and fire-prevention systems service,[Argus_Spectr],[Kirill_Marinushkin],2013-10-25,,,,,
+,6344,udp,Reserved,,,,,,,,
+,6345-6345,,Unassigned,,,,,,,,
+gnutella-svc,6346,tcp,gnutella-svc,[Serguei_Osokine],[Serguei_Osokine],,,,,,
+gnutella-svc,6346,udp,gnutella-svc,[Serguei_Osokine],[Serguei_Osokine],,,,,,
+gnutella-rtr,6347,tcp,gnutella-rtr,[Serguei_Osokine],[Serguei_Osokine],,,,,,
+gnutella-rtr,6347,udp,gnutella-rtr,[Serguei_Osokine],[Serguei_Osokine],,,,,,
+,6348-6349,,Unassigned,,,,,,,,
+adap,6350,tcp,App Discovery and Access Protocol,[Thomas_Kjoernes],[Thomas_Kjoernes],2010-06-22,,,,,
+adap,6350,udp,App Discovery and Access Protocol,[Thomas_Kjoernes],[Thomas_Kjoernes],2010-06-22,,,,,
+,6351-6354,,Unassigned,,,,,,,,
+pmcs,6355,tcp,PMCS applications,[Pavel_Mendl],[Pavel_Mendl],2007-03,,,,,
+pmcs,6355,udp,PMCS applications,[Pavel_Mendl],[Pavel_Mendl],2007-03,,,,,
+,6356-6359,,Unassigned,,,,,,,,
+metaedit-mu,6360,tcp,MetaEdit+ Multi-User,[Steven_Kelly],[Steven_Kelly],2007-11-12,,,,,
+metaedit-mu,6360,udp,MetaEdit+ Multi-User,[Steven_Kelly],[Steven_Kelly],2007-11-12,,,,,
+,6361-6362,,Unassigned,,,,,,,,
+ndn,6363,udp,Named Data Networking,[Regents_of_the_University_of_California],[Jeff_Burke],2013-10-30,,,,,
+,6363,tcp,Reserved,,,,,,,,
+,6364-6369,,Unassigned,,,,,,,,
+metaedit-se,6370,tcp,MetaEdit+ Server Administration,[Steven_Kelly],[Steven_Kelly],2007-11-12,,,,,
+metaedit-se,6370,udp,MetaEdit+ Server Administration,[Steven_Kelly],[Steven_Kelly],2007-11-12,,,,,
+,6371-6381,,Unassigned,,,,,,,,
+metatude-mds,6382,tcp,Metatude Dialogue Server,[Menno_Zweistra],[Menno_Zweistra],,,,,,
+metatude-mds,6382,udp,Metatude Dialogue Server,[Menno_Zweistra],[Menno_Zweistra],,,,,,
+,6383-6388,,Unassigned,,,,,,,,
+clariion-evr01,6389,tcp,clariion-evr01,[Dave_DesRoches],[Dave_DesRoches],,,,,,
+clariion-evr01,6389,udp,clariion-evr01,[Dave_DesRoches],[Dave_DesRoches],,,,,,
+metaedit-ws,6390,tcp,MetaEdit+ WebService API,[Steven_Kelly],[Steven_Kelly],2007-11-12,,,,,
+metaedit-ws,6390,udp,MetaEdit+ WebService API,[Steven_Kelly],[Steven_Kelly],2007-11-12,,,,,
+,6391-6399,,Unassigned,,,,,,,,
+boe-cms,6400,,Business Objects CMS contact port,[Wade_Richards],[Wade_Richards],2008-05-05,,,,,
+boe-was,6401,,boe-was,[Wade_Richards],[Wade_Richards],2008-05-05,,,,,
+boe-eventsrv,6402,,boe-eventsrv,[Wade_Richards],[Wade_Richards],2008-05-05,,,,,
+boe-cachesvr,6403,,boe-cachesvr,[Wade_Richards],[Wade_Richards],2008-05-05,,,,,
+boe-filesvr,6404,,Business Objects Enterprise internal server,[Wade_Richards],[Wade_Richards],2008-05-05,,,,,
+boe-pagesvr,6405,,Business Objects Enterprise internal server,[Wade_Richards],[Wade_Richards],2008-05-05,,,,,
+boe-processsvr,6406,,Business Objects Enterprise internal server,[Wade_Richards],[Wade_Richards],2008-05-05,,,,,
+boe-resssvr1,6407,,Business Objects Enterprise internal server,[Wade_Richards],[Wade_Richards],2008-05-05,,,,,
+boe-resssvr2,6408,,Business Objects Enterprise internal server,[Wade_Richards],[Wade_Richards],2008-05-05,,,,,
+boe-resssvr3,6409,,Business Objects Enterprise internal server,[Wade_Richards],[Wade_Richards],2008-05-05,,,,,
+boe-resssvr4,6410,,Business Objects Enterprise internal server,[Wade_Richards],[Wade_Richards],2008-05-05,,,,,
+,6411-6416,,Unassigned,,,,,,,,
+faxcomservice,6417,tcp,Faxcom Message Service,[Albert_Leung],[Albert_Leung],2006-04,,,,,
+faxcomservice,6417,udp,Faxcom Message Service,[Albert_Leung],[Albert_Leung],2006-04,,,,,
+syserverremote,6418,tcp,SYserver remote commands,[David_Ashkenazi],[David_Ashkenazi],2010-03-23,,,,,
+,6418,udp,Reserved,,,,,,,,
+svdrp,6419,tcp,Simple VDR Protocol,[Klaus_Schmidinger],[Klaus_Schmidinger],2010-03-31,,,,,
+,6419,udp,Reserved,,,,,,,,
+nim-vdrshell,6420,tcp,NIM_VDRShell,[Rik_Ditter],[Rik_Ditter],2006-02,,,,,
+nim-vdrshell,6420,udp,NIM_VDRShell,[Rik_Ditter],[Rik_Ditter],2006-02,,,,,
+nim-wan,6421,tcp,NIM_WAN,[Rik_Ditter],[Rik_Ditter],2006-02,,,,,
+nim-wan,6421,udp,NIM_WAN,[Rik_Ditter],[Rik_Ditter],2006-02,,,,,
+,6422-6431,,Unassigned,,,,,,,,
+pgbouncer,6432,tcp,PgBouncer,[Marko_Kreen],[Marko_Kreen],2009-02-13,,,,,
+,6432,udp,Reserved,,,,,,,,
+,6433-6441,,Unassigned,,,,,,,,
+tarp,6442,tcp,Transitory Application Request Protocol,[Chris_Peel_2],[Chris_Peel_2],2014-05-16,,,,,
+,6442,udp,Reserved,,,,,,,,
+sun-sr-https,6443,tcp,Service Registry Default HTTPS Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+sun-sr-https,6443,udp,Service Registry Default HTTPS Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+sge-qmaster,6444,tcp,"Grid Engine Qmaster Service
+IANA assigned this well-formed service name as a replacement for ""sge_qmaster"".",[Andreas_Haas],[Andreas_Haas],2006-08,,,,,
+sge_qmaster,6444,tcp,Grid Engine Qmaster Service,[Andreas_Haas],[Andreas_Haas],2006-08,,,,,"This entry is an alias to ""sge-qmaster"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+sge-qmaster,6444,udp,"Grid Engine Qmaster Service
+IANA assigned this well-formed service name as a replacement for ""sge_qmaster"".",[Andreas_Haas],[Andreas_Haas],2006-08,,,,,
+sge_qmaster,6444,udp,Grid Engine Qmaster Service,[Andreas_Haas],[Andreas_Haas],2006-08,,,,,"This entry is an alias to ""sge-qmaster"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+sge-execd,6445,tcp,"Grid Engine Execution Service
+IANA assigned this well-formed service name as a replacement for ""sge_execd"".",[Andreas_Haas],[Andreas_Haas],2006-08,,,,,
+sge_execd,6445,tcp,Grid Engine Execution Service,[Andreas_Haas],[Andreas_Haas],2006-08,,,,,"This entry is an alias to ""sge-execd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+sge-execd,6445,udp,"Grid Engine Execution Service
+IANA assigned this well-formed service name as a replacement for ""sge_execd"".",[Andreas_Haas],[Andreas_Haas],2006-08,,,,,
+sge_execd,6445,udp,Grid Engine Execution Service,[Andreas_Haas],[Andreas_Haas],2006-08,,,,,"This entry is an alias to ""sge-execd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+mysql-proxy,6446,tcp,MySQL Proxy,[Kay_Roepke],[Kay_Roepke],2009-04-22,,,,,
+mysql-proxy,6446,udp,MySQL Proxy,[Kay_Roepke],[Kay_Roepke],2009-04-22,,,,,
+,6447-6454,,Unassigned,,,,,,,,
+skip-cert-recv,6455,tcp,SKIP Certificate Receive,[Tom_Markson],[Tom_Markson],,,,,,
+skip-cert-recv,6455,udp,SKIP Certificate Receive,[Tom_Markson],[Tom_Markson],,,,,,
+skip-cert-send,6456,tcp,SKIP Certificate Send,[Tom_Markson],[Tom_Markson],,,,,,
+skip-cert-send,6456,udp,SKIP Certificate Send,[Tom_Markson],[Tom_Markson],,,,,,
+,6457-6470,,Unassigned,,,,,,,,
+lvision-lm,6471,tcp,LVision License Manager,[Brian_McKinnon],[Brian_McKinnon],,,,,,
+lvision-lm,6471,udp,LVision License Manager,[Brian_McKinnon],[Brian_McKinnon],,,,,,
+,6472-6479,,Unassigned,,,,,,,,
+sun-sr-http,6480,tcp,Service Registry Default HTTP Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+sun-sr-http,6480,udp,Service Registry Default HTTP Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+servicetags,6481,tcp,Service Tags,[Peter_Schow],[Peter_Schow],2007-01,,,,,
+servicetags,6481,udp,Service Tags,[Peter_Schow],[Peter_Schow],2007-01,,,,,
+ldoms-mgmt,6482,tcp,Logical Domains Management Interface,[Eric_Sharakan],[Eric_Sharakan],2008-02-14,,,,,
+ldoms-mgmt,6482,udp,Logical Domains Management Interface,[Eric_Sharakan],[Eric_Sharakan],2008-02-14,,,,,
+SunVTS-RMI,6483,tcp,SunVTS RMI,[Sumit_Arora],[Sumit_Arora],2007-06,,,,,
+SunVTS-RMI,6483,udp,SunVTS RMI,[Sumit_Arora],[Sumit_Arora],2007-06,,,,,
+sun-sr-jms,6484,tcp,Service Registry Default JMS Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+sun-sr-jms,6484,udp,Service Registry Default JMS Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+sun-sr-iiop,6485,tcp,Service Registry Default IIOP Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+sun-sr-iiop,6485,udp,Service Registry Default IIOP Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+sun-sr-iiops,6486,tcp,Service Registry Default IIOPS Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+sun-sr-iiops,6486,udp,Service Registry Default IIOPS Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+sun-sr-iiop-aut,6487,tcp,Service Registry Default IIOPAuth Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+sun-sr-iiop-aut,6487,udp,Service Registry Default IIOPAuth Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+sun-sr-jmx,6488,tcp,Service Registry Default JMX Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+sun-sr-jmx,6488,udp,Service Registry Default JMX Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+sun-sr-admin,6489,tcp,Service Registry Default Admin Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+sun-sr-admin,6489,udp,Service Registry Default Admin Domain,[Paul_Sterk],[Paul_Sterk],2006-03,,,,,
+,6490-6499,,Unassigned,,,,,,,,
+boks,6500,tcp,BoKS Master,[Magnus_Nystrom],[Magnus_Nystrom],,,,,,
+boks,6500,udp,BoKS Master,[Magnus_Nystrom],[Magnus_Nystrom],,,,,,
+boks-servc,6501,tcp,"BoKS Servc
+IANA assigned this well-formed service name as a replacement for ""boks_servc"".",[Magnus_Nystrom],[Magnus_Nystrom],,,,,Known Unauthorized Use on port 6501,
+boks_servc,6501,tcp,BoKS Servc,[Magnus_Nystrom],[Magnus_Nystrom],,,,,Known Unauthorized Use on port 6501,"This entry is an alias to ""boks-servc"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+boks-servc,6501,udp,"BoKS Servc
+IANA assigned this well-formed service name as a replacement for ""boks_servc"".",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,
+boks_servc,6501,udp,BoKS Servc,[Magnus_Nystrom],[Magnus_Nystrom],,,,,,"This entry is an alias to ""boks-servc"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+boks-servm,6502,tcp,"BoKS Servm
+IANA assigned this well-formed service name as a replacement for ""boks_servm"".",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,
+boks_servm,6502,tcp,BoKS Servm,[Magnus_Nystrom],[Magnus_Nystrom],,,,,,"This entry is an alias to ""boks-servm"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+boks-servm,6502,udp,"BoKS Servm
+IANA assigned this well-formed service name as a replacement for ""boks_servm"".",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,
+boks_servm,6502,udp,BoKS Servm,[Magnus_Nystrom],[Magnus_Nystrom],,,,,,"This entry is an alias to ""boks-servm"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+boks-clntd,6503,tcp,"BoKS Clntd
+IANA assigned this well-formed service name as a replacement for ""boks_clntd"".",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,
+boks_clntd,6503,tcp,BoKS Clntd,[Magnus_Nystrom],[Magnus_Nystrom],,,,,,"This entry is an alias to ""boks-clntd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+boks-clntd,6503,udp,"BoKS Clntd
+IANA assigned this well-formed service name as a replacement for ""boks_clntd"".",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,
+boks_clntd,6503,udp,BoKS Clntd,[Magnus_Nystrom],[Magnus_Nystrom],,,,,,"This entry is an alias to ""boks-clntd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+,6504,,Unassigned,,,,,,,,
+badm-priv,6505,tcp,"BoKS Admin Private Port
+IANA assigned this well-formed service name as a replacement for ""badm_priv"".",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,
+badm_priv,6505,tcp,BoKS Admin Private Port,[Magnus_Nystrom],[Magnus_Nystrom],,,,,,"This entry is an alias to ""badm-priv"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+badm-priv,6505,udp,"BoKS Admin Private Port
+IANA assigned this well-formed service name as a replacement for ""badm_priv"".",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,
+badm_priv,6505,udp,BoKS Admin Private Port,[Magnus_Nystrom],[Magnus_Nystrom],,,,,,"This entry is an alias to ""badm-priv"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+badm-pub,6506,tcp,"BoKS Admin Public Port
+IANA assigned this well-formed service name as a replacement for ""badm_pub"".",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,
+badm_pub,6506,tcp,BoKS Admin Public Port,[Magnus_Nystrom],[Magnus_Nystrom],,,,,,"This entry is an alias to ""badm-pub"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+badm-pub,6506,udp,"BoKS Admin Public Port
+IANA assigned this well-formed service name as a replacement for ""badm_pub"".",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,
+badm_pub,6506,udp,BoKS Admin Public Port,[Magnus_Nystrom],[Magnus_Nystrom],,,,,,"This entry is an alias to ""badm-pub"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+bdir-priv,6507,tcp,"BoKS Dir Server, Private Port
+IANA assigned this well-formed service name as a replacement for ""bdir_priv"".",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,
+bdir_priv,6507,tcp,"BoKS Dir Server, Private Port",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,"This entry is an alias to ""bdir-priv"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+bdir-priv,6507,udp,"BoKS Dir Server, Private Port
+IANA assigned this well-formed service name as a replacement for ""bdir_priv"".",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,
+bdir_priv,6507,udp,"BoKS Dir Server, Private Port",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,"This entry is an alias to ""bdir-priv"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+bdir-pub,6508,tcp,"BoKS Dir Server, Public Port
+IANA assigned this well-formed service name as a replacement for ""bdir_pub"".",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,
+bdir_pub,6508,tcp,"BoKS Dir Server, Public Port",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,"This entry is an alias to ""bdir-pub"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+bdir-pub,6508,udp,"BoKS Dir Server, Public Port
+IANA assigned this well-formed service name as a replacement for ""bdir_pub"".",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,
+bdir_pub,6508,udp,"BoKS Dir Server, Public Port",[Magnus_Nystrom],[Magnus_Nystrom],,,,,,"This entry is an alias to ""bdir-pub"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+mgcs-mfp-port,6509,tcp,MGCS-MFP Port,[Minoru_Ozaki],[Minoru_Ozaki],,,,,,
+mgcs-mfp-port,6509,udp,MGCS-MFP Port,[Minoru_Ozaki],[Minoru_Ozaki],,,,,,
+mcer-port,6510,tcp,MCER Port,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+mcer-port,6510,udp,MCER Port,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+,6511,tcp,Reserved,,,,,,,,
+dccp-udp,6511,udp,Datagram Congestion Control Protocol Encapsulation for NAT Traversal,[IESG],[IETF_Chair],,,[RFC6773],,,
+,6512-6512,,Unassigned,,,,,,,,
+netconf-tls,6513,tcp,NETCONF over TLS,,,,,[RFC5539],,,
+,6513,udp,Reserved,,,,,,,,
+syslog-tls,6514,tcp,Syslog over TLS,,,,,[RFC5425],,,
+syslog-tls,6514,udp,syslog over DTLS,,,,,[RFC6012],,,
+syslog-tls,6514,dccp,syslog over DTLS,,,,,[RFC6012],,,
+elipse-rec,6515,tcp,Elipse RPC Protocol,[F_Englert],[F_Englert],2007-09-17,,,,,
+elipse-rec,6515,udp,Elipse RPC Protocol,[F_Englert],[F_Englert],2007-09-17,,,,,
+,6516-6542,,Unassigned,,,,,,,,
+lds-distrib,6543,tcp,lds_distrib,[Jack_Baker],[Jack_Baker],2003-06,,,,,
+lds-distrib,6543,udp,lds_distrib,[Jack_Baker],[Jack_Baker],2003-06,,,,,
+lds-dump,6544,tcp,LDS Dump Service,[Jack_Baker],[Jack_Baker],2006-02,,,,,
+lds-dump,6544,udp,LDS Dump Service,[Jack_Baker],[Jack_Baker],2006-02,,,,,
+,6545-6546,,Unassigned,,,,,,,,
+apc-6547,6547,tcp,APC 6547,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-6547,6547,udp,APC 6547,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-6548,6548,tcp,APC 6548,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-6548,6548,udp,APC 6548,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-6549,6549,tcp,APC 6549,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-6549,6549,udp,APC 6549,[American_Power_Conve],[American_Power_Conve],,,,,,
+fg-sysupdate,6550,tcp,fg-sysupdate,[Mark_Beyer],[Mark_Beyer],,,,,,
+fg-sysupdate,6550,udp,fg-sysupdate,[Mark_Beyer],[Mark_Beyer],,,,,,
+sum,6551,tcp,Software Update Manager,[Jan_Dirven],[Jan_Dirven],2007-12-13,,,,,
+sum,6551,udp,Software Update Manager,[Jan_Dirven],[Jan_Dirven],2007-12-13,,,,,
+,6552-6557,,Unassigned,,,,,,,,
+xdsxdm,6558,tcp,,[Brian_Tackett],[Brian_Tackett],,,,,,possible contact
+xdsxdm,6558,udp,,[Brian_Tackett],[Brian_Tackett],,,,,,possible contact
+,6559-6565,,Unassigned,,,,,,,,
+sane-port,6566,tcp,SANE Control Port,[Henning_Meier_Geinit],[Henning_Meier_Geinit],2002-10,,,,,
+sane-port,6566,udp,SANE Control Port,[Henning_Meier_Geinit],[Henning_Meier_Geinit],2002-10,,,,,
+,6567,,Reserved,,,2007-01,2011-08-26,,,,This entry has been removed on 2011-08-26.
+canit-store,6568,tcp,"CanIt Storage Manager
+IANA assigned this well-formed service name as a replacement for ""canit_store"".",[David_F_Skoll],[David_F_Skoll],2009-04-22,,,,,
+canit_store,6568,tcp,CanIt Storage Manager,[David_F_Skoll],[David_F_Skoll],2009-04-22,,,,,"This entry is an alias to ""canit-store"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+rp-reputation,6568,udp,Roaring Penguin IP Address Reputation Collection,[David_F_Skoll],[David_F_Skoll],2010-02-05,,,,,
+,6569-6578,,Unassigned,,,,,,,,
+affiliate,6579,tcp,Affiliate,[David_Catmull],[David_Catmull],2006-01,,,,,
+affiliate,6579,udp,Affiliate,[David_Catmull],[David_Catmull],2006-01,,,,,
+parsec-master,6580,tcp,Parsec Masterserver,[Andreas_Varga],[Andreas_Varga],,,,,,
+parsec-master,6580,udp,Parsec Masterserver,[Andreas_Varga],[Andreas_Varga],,,,,,
+parsec-peer,6581,tcp,Parsec Peer-to-Peer,[Andreas_Varga],[Andreas_Varga],,,,,,
+parsec-peer,6581,udp,Parsec Peer-to-Peer,[Andreas_Varga],[Andreas_Varga],,,,,,
+parsec-game,6582,tcp,Parsec Gameserver,[Andreas_Varga],[Andreas_Varga],,,,,,
+parsec-game,6582,udp,Parsec Gameserver,[Andreas_Varga],[Andreas_Varga],,,,,,
+joaJewelSuite,6583,tcp,JOA Jewel Suite,[Bob_Rundle],[Bob_Rundle],2005-11,,,,,
+joaJewelSuite,6583,udp,JOA Jewel Suite,[Bob_Rundle],[Bob_Rundle],2005-11,,,,,
+,6584-6587,,Unassigned,,,,,,,,
+,6588,,Unassigned,,,,,,,Unofficial use of port 6588 by AnalogX and Microsoft,
+,6589-6599,,Unassigned,,,,,,,,
+mshvlm,6600,tcp,Microsoft Hyper-V Live Migration,[Rajesh_D],[Rajesh_D],2009-02-03,,,,,
+,6600,udp,Reserved,,,,,,,,
+mstmg-sstp,6601,tcp,Microsoft Threat Management Gateway SSTP,[Ori_Yosefi],[Ori_Yosefi],2009-05-04,,,,,
+,6601,udp,Reserved,,,,,,,,
+wsscomfrmwk,6602,tcp,Windows WSS Communication Framework,[Rong_Yu],[Rong_Yu],2010-08-10,,,,,
+,6602,udp,Reserved,,,,,,,,
+,6603-6618,,Unassigned,,,,,,,,
+odette-ftps,6619,tcp,ODETTE-FTP over TLS/SSL,[Ieuan_Friend],[Ieuan_Friend],2006-03,,[RFC5024],,,
+odette-ftps,6619,udp,ODETTE-FTP over TLS/SSL,[Ieuan_Friend],[Ieuan_Friend],2006-03,,[RFC5024],,,
+kftp-data,6620,tcp,Kerberos V5 FTP Data,[Robert_J_Scott],[Robert_J_Scott],2005-08,,,,,
+kftp-data,6620,udp,Kerberos V5 FTP Data,[Robert_J_Scott],[Robert_J_Scott],2005-08,,,,,
+kftp,6621,tcp,Kerberos V5 FTP Control,[Robert_J_Scott],[Robert_J_Scott],2005-08,,,,,
+kftp,6621,udp,Kerberos V5 FTP Control,[Robert_J_Scott],[Robert_J_Scott],2005-08,,,,,
+mcftp,6622,tcp,Multicast FTP,[Bruce_Lueckenhoff_2],[Bruce_Lueckenhoff_2],2006-02,,,,,
+mcftp,6622,udp,Multicast FTP,[Bruce_Lueckenhoff_2],[Bruce_Lueckenhoff_2],2006-02,,,,,
+ktelnet,6623,tcp,Kerberos V5 Telnet,[Robert_J_Scott],[Robert_J_Scott],2005-08,,,,,
+ktelnet,6623,udp,Kerberos V5 Telnet,[Robert_J_Scott],[Robert_J_Scott],2005-08,,,,,
+datascaler-db,6624,tcp,DataScaler database,[Vasu_Murthy],[Vasu_Murthy],2010-02-08,,,,,
+,6624,udp,Reserved,,,,,,,,
+datascaler-ctl,6625,tcp,DataScaler control,[Vasu_Murthy],[Vasu_Murthy],2010-02-08,,,,,
+,6625,udp,Reserved,,,,,,,,
+wago-service,6626,tcp,WAGO Service and Update,[Wolfgang_Adler],[Wolfgang_Adler],2006-04,,,,,
+wago-service,6626,udp,WAGO Service and Update,[Wolfgang_Adler],[Wolfgang_Adler],2006-04,,,,,
+nexgen,6627,tcp,Allied Electronics NeXGen,[Lou_Seitchik],[Lou_Seitchik],2005-08,,,,,
+nexgen,6627,udp,Allied Electronics NeXGen,[Lou_Seitchik],[Lou_Seitchik],2005-08,,,,,
+afesc-mc,6628,tcp,AFE Stock Channel M/C,[K_K_Ho],[K_K_Ho],2004-04,,,,,
+afesc-mc,6628,udp,AFE Stock Channel M/C,[K_K_Ho],[K_K_Ho],2004-04,,,,,
+,6629-6630,,Unassigned,,,,,,,,
+,6631,,Unassigned,,,2004-05-28,,,,,
+mxodbc-connect,6632,tcp,eGenix mxODBC Connect,[Marc_Andre_Lemburg],[Marc_Andre_Lemburg],2009-11-13,,,,Unauthorized Use Known on port 6632,
+,6632,udp,Reserved,,,,,,,,
+,6633,tcp,Reserved,,,,,,,,
+cisco-vpath-tun,6633,udp,Cisco vPath Services Overlay,[Cisco2],[Surendra_Kumar],2012-06-11,,,,,
+mpls-pm,6634,udp,MPLS Performance Measurement out-of-band response,[Cisco_Systems_2],[Sagar_Soni],2014-02-20,,,,,
+,6634,tcp,Reserved,,,,,,,,
+,6635-6639,,Unassigned,,,,,,,,
+ovsdb,6640,tcp,Open vSwitch Database protocol,[Bruce_Davie_2],[Bruce_Davie_2],2013-07-31,,[RFC7047],,,
+,6640,udp,Reserved,,,,,,,,
+,6641-6652,,Unassigned,,,,,,,,
+openflow,6653,tcp,OpenFlow,[Open_Networking_Foundation],[Puneet_Agarwal],2013-07-18,,,,,
+openflow,6653,udp,OpenFlow,[Open_Networking_Foundation],[Puneet_Agarwal],2013-07-18,,,,,
+,6654,,Unassigned,,,,,,,,
+pcs-sf-ui-man,6655,tcp,PC SOFT - Software factory UI/manager,[Jerome_AERTS],[Jerome_AERTS],2010-11-30,,,,,
+,6655,udp,Reserved,,,,,,,,
+emgmsg,6656,tcp,Emergency Message Control Service,[Gerry_Gorman],[Gerry_Gorman],2010-12-06,,,,,
+,6656,udp,Reserved,,,,,,,,
+,6657,tcp,Reserved,,,,,,,,
+palcom-disc,6657,udp,PalCom Discovery,[Boris_Magnusson],[Boris_Magnusson],2010-12-06,,,,,
+,6658-6664,,Unassigned,,,,,,,Unauthorized Use Known on Port 6659,
+ircu,6665-6669,tcp,IRCU,[Brian_Tackett],[Brian_Tackett],,,,,,
+,6665-6669,udp,Reserved,,,,,,,,
+vocaltec-gold,6670,tcp,Vocaltec Global Online Directory,[Scott_Petrack],[Scott_Petrack],,,,,,
+vocaltec-gold,6670,udp,Vocaltec Global Online Directory,[Scott_Petrack],[Scott_Petrack],,,,,,
+p4p-portal,6671,tcp,P4P Portal Service,[Chris_Griffiths],[Chris_Griffiths],2008-07-28,,,,,
+p4p-portal,6671,udp,P4P Portal Service,[Chris_Griffiths],[Chris_Griffiths],2008-07-28,,,,,
+vision-server,6672,tcp,"vision_server
+IANA assigned this well-formed service name as a replacement for ""vision_server"".",[Chris_Kramer],[Chris_Kramer],,,,,,
+vision_server,6672,tcp,vision_server,[Chris_Kramer],[Chris_Kramer],,,,,,"This entry is an alias to ""vision-server"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+vision-server,6672,udp,"vision_server
+IANA assigned this well-formed service name as a replacement for ""vision_server"".",[Chris_Kramer],[Chris_Kramer],,,,,,
+vision_server,6672,udp,vision_server,[Chris_Kramer],[Chris_Kramer],,,,,,"This entry is an alias to ""vision-server"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+vision-elmd,6673,tcp,"vision_elmd
+IANA assigned this well-formed service name as a replacement for ""vision_elmd"".",[Chris_Kramer],[Chris_Kramer],,,,,,
+vision_elmd,6673,tcp,vision_elmd,[Chris_Kramer],[Chris_Kramer],,,,,,"This entry is an alias to ""vision-elmd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+vision-elmd,6673,udp,"vision_elmd
+IANA assigned this well-formed service name as a replacement for ""vision_elmd"".",[Chris_Kramer],[Chris_Kramer],,,,,,
+vision_elmd,6673,udp,vision_elmd,[Chris_Kramer],[Chris_Kramer],,,,,,"This entry is an alias to ""vision-elmd"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+,6674-6677,,Unassigned,,,,,,,,
+vfbp,6678,tcp,Viscount Freedom Bridge Protocol,[Chris_MacDonald],[Chris_MacDonald],2011-03-16,,,,,
+vfbp-disc,6678,udp,Viscount Freedom Bridge Discovery,[Chris_MacDonald],[Chris_MacDonald],2011-03-16,,,,,
+osaut,6679,tcp,Osorno Automation,[Peter_Hombach],[Peter_Hombach],2011-03-16,,,,,
+osaut,6679,udp,Osorno Automation,[Peter_Hombach],[Peter_Hombach],2011-03-16,,,,,
+,6680-6686,,Unassigned,,,,,,,,
+clever-ctrace,6687,tcp,CleverView for cTrace Message Service,[David_Cheng],[David_Cheng],2010-02-01,,,,,
+,6687,udp,Reserved,,,,,,,,
+clever-tcpip,6688,tcp,CleverView for TCP/IP Message Service,[David_Cheng],[David_Cheng],2009-10-13,,,,,
+,6688,udp,Reserved,,,,,,,,
+tsa,6689,tcp,Tofino Security Appliance,[Scott_Howard],[Scott_Howard],2009-10-13,,,,,
+tsa,6689,udp,Tofino Security Appliance,[Scott_Howard],[Scott_Howard],2009-10-13,,,,,
+,6690-6695,,Unassigned,,,,,,,,
+,6696,tcp,Reserved,,,,,,,,
+babel,6696,udp,Babel Routing Protocol,,,,2011-08-15,[RFC6126],,,
+ircs-u,6697,tcp,Internet Relay Chat via TLS/SSL,,,2014-02-11,,[RFC7194],,,
+,6697,udp,Reserved,,,2014-02-11,,,,,
+,6698-6699,,Unassigned,,,,,,,,
+,6700,,Unassigned,,,2010-01-26,,,,,
+kti-icad-srvr,6701,tcp,KTI/ICAD Nameserver,[Stanley_Knutson],[Stanley_Knutson],,,,,,
+kti-icad-srvr,6701,udp,KTI/ICAD Nameserver,[Stanley_Knutson],[Stanley_Knutson],,,,,,
+,6701,sctp,Unassigned,,,,2010-01-26,,,,
+e-design-net,6702,tcp,e-Design network,[Janos_Lerch],[Janos_Lerch],2006-02,,,,,
+e-design-net,6702,udp,e-Design network,[Janos_Lerch],[Janos_Lerch],2006-02,,,,,
+,6702,sctp,Unassigned,,,,2010-01-26,,,,
+e-design-web,6703,tcp,e-Design web,[Janos_Lerch],[Janos_Lerch],2006-02,,,,,
+e-design-web,6703,udp,e-Design web,[Janos_Lerch],[Janos_Lerch],2006-02,,,,,
+,6704,udp,Reserved,,,,,,,,
+,6704,tcp,Reserved,,,,,,,,
+frc-hp,6704,sctp,ForCES HP (High Priority) channel,,,,,[RFC5811],,,
+,6705,udp,Reserved,,,,,,,,
+,6705,tcp,Reserved,,,,,,,,
+frc-mp,6705,sctp,ForCES MP (Medium Priority) channel,,,,,[RFC5811],,,
+,6706,udp,Reserved,,,,,,,,
+,6706,tcp,Reserved,,,,,,,,
+frc-lp,6706,sctp,ForCES LP (Low priority) channel,,,,,[RFC5811],,,
+,6707-6713,,Unassigned,,,,,,,,
+ibprotocol,6714,tcp,Internet Backplane Protocol,[Alessandro_Bassi],[Alessandro_Bassi],,,,,,
+ibprotocol,6714,udp,Internet Backplane Protocol,[Alessandro_Bassi],[Alessandro_Bassi],,,,,,
+fibotrader-com,6715,tcp,Fibotrader Communications,[Robert_Wetzold],[Robert_Wetzold],2006-01,,,,,
+fibotrader-com,6715,udp,Fibotrader Communications,[Robert_Wetzold],[Robert_Wetzold],2006-01,,,,,
+printercare-cc,6716,tcp,PrinterCare cloud service,[E-FISH_sp._z.o.o.],[Tomasz_Krakowiak],2014-07-07,,,,,
+,6716,udp,Reserved,,,,,,,,
+,6717-6766,,Unassigned,,,,,,,,
+bmc-perf-agent,6767,tcp,BMC PERFORM AGENT,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmc-perf-agent,6767,udp,BMC PERFORM AGENT,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmc-perf-mgrd,6768,tcp,BMC PERFORM MGRD,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmc-perf-mgrd,6768,udp,BMC PERFORM MGRD,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+adi-gxp-srvprt,6769,tcp,ADInstruments GxP Server,[Mathew_Pitchforth],[Mathew_Pitchforth],2005-08,,,,,
+adi-gxp-srvprt,6769,udp,ADInstruments GxP Server,[Mathew_Pitchforth],[Mathew_Pitchforth],2005-08,,,,,
+plysrv-http,6770,tcp,PolyServe http,[Mike_Spitzer],[Mike_Spitzer],2005-08,,,,,
+plysrv-http,6770,udp,PolyServe http,[Mike_Spitzer],[Mike_Spitzer],2005-08,,,,,
+plysrv-https,6771,tcp,PolyServe https,[Mike_Spitzer],[Mike_Spitzer],2005-08,,,,,
+plysrv-https,6771,udp,PolyServe https,[Mike_Spitzer],[Mike_Spitzer],2005-08,,,,,
+,6772-6776,,Unassigned,,,,,,,,
+ntz-tracker,6777,tcp,netTsunami Tracker,[Tomahawk_Holdings],[Sagara_Wijetunga],2013-05-01,,,,,
+,6777,udp,Reserved,,,,,,,,
+ntz-p2p-storage,6778,tcp,netTsunami p2p storage system,[Tomahawk_Holdings],[Sagara_Wijetunga],2013-05-01,,,,,
+,6778,udp,Reserved,,,,,,,,
+,6779-6783,,Unassigned,,,,,,,,
+,6784,tcp,Reserved,,,,,,,,
+bfd-lag,6784,udp,Bidirectional Forwarding Detection (BFD) on Link Aggregation Group (LAG) Interfaces,[IESG],[BFD_Chairs],2012-11-08,2014-01-09,[RFC7130],,,
+dgpf-exchg,6785,tcp,DGPF Individual Exchange,[Thomas_Weise],[Thomas_Weise],2006-04,,,,,
+dgpf-exchg,6785,udp,DGPF Individual Exchange,[Thomas_Weise],[Thomas_Weise],2006-04,,,,,
+smc-jmx,6786,tcp,Sun Java Web Console JMX,[Bill_Edwards],[Bill_Edwards],2005-08,,,,,
+smc-jmx,6786,udp,Sun Java Web Console JMX,[Bill_Edwards],[Bill_Edwards],2005-08,,,,,
+smc-admin,6787,tcp,Sun Web Console Admin,[Bill_Edwards],[Bill_Edwards],2005-08,,,,,
+smc-admin,6787,udp,Sun Web Console Admin,[Bill_Edwards],[Bill_Edwards],2005-08,,,,,
+smc-http,6788,tcp,SMC-HTTP,[Ratnadeep_Bhattachar],[Ratnadeep_Bhattachar],2002-11,,,,,
+smc-http,6788,udp,SMC-HTTP,[Ratnadeep_Bhattachar],[Ratnadeep_Bhattachar],2002-11,,,,,
+smc-https,6789,tcp,SMC-HTTPS,[Ratnadeep_Bhattachar],[Ratnadeep_Bhattachar],2002-08,,,,,
+smc-https,6789,udp,SMC-HTTPS,[Ratnadeep_Bhattachar],[Ratnadeep_Bhattachar],2002-08,,,,,
+hnmp,6790,tcp,HNMP,[Jude_George],[Jude_George],,,,,,
+hnmp,6790,udp,HNMP,[Jude_George],[Jude_George],,,,,,
+hnm,6791,tcp,Halcyon Network Manager,[Richard_Harriss],[Richard_Harriss],2005-05,,,,,
+hnm,6791,udp,Halcyon Network Manager,[Richard_Harriss],[Richard_Harriss],2005-05,,,,,
+,6792-6800,,Unassigned,,,,,,,,
+acnet,6801,tcp,ACNET Control System Protocol,[Rich_Neswold],[Rich_Neswold],2007-02,,,,,
+acnet,6801,udp,ACNET Control System Protocol,[Rich_Neswold],[Rich_Neswold],2007-02,,,,,
+,6802-6816,,Unassigned,,,,,,,,
+pentbox-sim,6817,tcp,PenTBox Secure IM Protocol,[Alberto_Ortega_Llama],[Alberto_Ortega_Llama],2009-11-04,,,,,
+,6817,udp,Reserved,,,,,,,,
+,6818-6830,,Unassigned,,,,,,,,
+ambit-lm,6831,tcp,ambit-lm,[Don_Hejna],[Don_Hejna],,,,,,
+ambit-lm,6831,udp,ambit-lm,[Don_Hejna],[Don_Hejna],,,,,,
+,6832-6840,,Unassigned,,,,,,,,
+netmo-default,6841,tcp,Netmo Default,[Urs_Bertschinger],[Urs_Bertschinger],,,,,,
+netmo-default,6841,udp,Netmo Default,[Urs_Bertschinger],[Urs_Bertschinger],,,,,,
+netmo-http,6842,tcp,Netmo HTTP,[Urs_Bertschinger],[Urs_Bertschinger],,,,,,
+netmo-http,6842,udp,Netmo HTTP,[Urs_Bertschinger],[Urs_Bertschinger],,,,,,
+,6843-6849,,Unassigned,,,,,,,,
+iccrushmore,6850,tcp,ICCRUSHMORE,[Dave_Hubbard],[Dave_Hubbard],,,,,,
+iccrushmore,6850,udp,ICCRUSHMORE,[Dave_Hubbard],[Dave_Hubbard],,,,,,
+,6851-6867,,Unassigned,,,,,,,,
+acctopus-cc,6868,tcp,Acctopus Command Channel,[Stefan_Auweiler],[Stefan_Auweiler],2009-11-16,,,,,
+acctopus-st,6868,udp,Acctopus Status,[Stefan_Auweiler],[Stefan_Auweiler],2009-11-16,,,,,
+,6869-6887,,Unassigned,,,,,,,,
+muse,6888,tcp,MUSE,[Muse_Communications],[Muse_Communications],,,,,,
+muse,6888,udp,MUSE,[Muse_Communications],[Muse_Communications],,,,,,
+,6889-6900,,Unassigned,,,,,,,,
+jetstream,6901,tcp,Novell Jetstream messaging protocol,[Anil_Tyagi],[Anil_Tyagi],2010-06-11,,,,,
+,6901,udp,Reserved,,,,,,,,
+,6902-6934,,Unassigned,,,,,,,,
+ethoscan,6935,tcp,EthoScan Service,[Marty_Campbell],[Marty_Campbell],2011-06-10,,,,,
+ethoscan,6935,udp,EthoScan Service,[Marty_Campbell],[Marty_Campbell],2011-06-10,,,,,
+xsmsvc,6936,tcp,XenSource Management Service,[Roger_Klorese],[Roger_Klorese],2006-06,,,,,
+xsmsvc,6936,udp,XenSource Management Service,[Roger_Klorese],[Roger_Klorese],2006-06,,,,,
+,6937-6945,,Unassigned,,,,,,,,
+bioserver,6946,tcp,Biometrics Server,[ISHII_AKIO],[ISHII_AKIO],2006-01,,,,,
+bioserver,6946,udp,Biometrics Server,[ISHII_AKIO],[ISHII_AKIO],2006-01,,,,,
+,6947-6950,,Unassigned,,,,,,,,
+otlp,6951,tcp,OTLP,[Brent_Foster],[Brent_Foster],2006-04,,,,,
+otlp,6951,udp,OTLP,[Brent_Foster],[Brent_Foster],2006-04,,,,,
+,6952-6960,,Unassigned,,,,,,,,
+jmact3,6961,tcp,JMACT3,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+jmact3,6961,udp,JMACT3,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+jmevt2,6962,tcp,jmevt2,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+jmevt2,6962,udp,jmevt2,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+swismgr1,6963,tcp,swismgr1,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+swismgr1,6963,udp,swismgr1,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+swismgr2,6964,tcp,swismgr2,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+swismgr2,6964,udp,swismgr2,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+swistrap,6965,tcp,swistrap,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+swistrap,6965,udp,swistrap,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+swispol,6966,tcp,swispol,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+swispol,6966,udp,swispol,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+,6967-6968,,Unassigned,,,,,,,,
+acmsoda,6969,tcp,acmsoda,[Daniel_Simms],[Daniel_Simms],,,,,,
+acmsoda,6969,udp,acmsoda,[Daniel_Simms],[Daniel_Simms],,,,,,
+conductor,6970,tcp,Conductor test coordination protocol,[George_Neville-Neil],[George_Neville-Neil],2014-09-18,,,,,
+,6970,udp,Reserved,,,,,,,,
+conductor-mpx,6970,sctp,conductor for multiplex,[George_Neville-Neil],[George_Neville-Neil],2014-07-29,,,,,
+,6971-6996,,Unassigned,,,,,,,,
+MobilitySrv,6997,tcp,Mobility XE Protocol,[Joseph_T_Savarese],[Joseph_T_Savarese],2007-06,,,,,
+MobilitySrv,6997,udp,Mobility XE Protocol,[Joseph_T_Savarese],[Joseph_T_Savarese],2007-06,,,,,
+iatp-highpri,6998,tcp,IATP-highPri,[John_Murphy],[John_Murphy],,,,,,
+iatp-highpri,6998,udp,IATP-highPri,[John_Murphy],[John_Murphy],,,,,,
+iatp-normalpri,6999,tcp,IATP-normalPri,[John_Murphy],[John_Murphy],,,,,,
+iatp-normalpri,6999,udp,IATP-normalPri,[John_Murphy],[John_Murphy],,,,,,
+afs3-fileserver,7000,tcp,file server itself,,,,,,,,
+afs3-fileserver,7000,udp,file server itself,,,,,,,,
+afs3-callback,7001,tcp,callbacks to cache managers,,,,,,,Known Unauthorized Use on port 7001,
+afs3-callback,7001,udp,callbacks to cache managers,,,,,,,Known Unauthorized Use on port 7001,
+afs3-prserver,7002,tcp,users & groups database,,,,,,,Known Unauthorized Use on port 7002,
+afs3-prserver,7002,udp,users & groups database,,,,,,,Known Unauthorized Use on port 7002,
+afs3-vlserver,7003,tcp,volume location database,,,,,,,,
+afs3-vlserver,7003,udp,volume location database,,,,,,,,
+afs3-kaserver,7004,tcp,AFS/Kerberos authentication service,,,,,,,,
+afs3-kaserver,7004,udp,AFS/Kerberos authentication service,,,,,,,,
+afs3-volser,7005,tcp,volume managment server,,,,,,,Known Unauthorized Use on port 7005,
+afs3-volser,7005,udp,volume managment server,,,,,,,Known Unauthorized Use on port 7005,
+afs3-errors,7006,tcp,error interpretation service,,,,,,,,
+afs3-errors,7006,udp,error interpretation service,,,,,,,,
+afs3-bos,7007,tcp,basic overseer process,,,,,,,,
+afs3-bos,7007,udp,basic overseer process,,,,,,,,
+afs3-update,7008,tcp,server-to-server updater,,,,,,,,
+afs3-update,7008,udp,server-to-server updater,,,,,,,,
+afs3-rmtsys,7009,tcp,remote cache manager service,,,,,,,,
+afs3-rmtsys,7009,udp,remote cache manager service,,,,,,,,
+ups-onlinet,7010,tcp,onlinet uninterruptable power supplies,[Jim_Thompson],[Jim_Thompson],,,,,,
+ups-onlinet,7010,udp,onlinet uninterruptable power supplies,[Jim_Thompson],[Jim_Thompson],,,,,,
+talon-disc,7011,tcp,Talon Discovery Port,[Jim_Thompson],[Jim_Thompson],,,,,Known Unauthorized Use on 7011,
+talon-disc,7011,udp,Talon Discovery Port,[Jim_Thompson],[Jim_Thompson],,,,,Known Unauthorized Use on 7011,
+talon-engine,7012,tcp,Talon Engine,[Jim_Thompson],[Jim_Thompson],,,,,Known Unauthorized Use on 7011,
+talon-engine,7012,udp,Talon Engine,[Jim_Thompson],[Jim_Thompson],,,,,Known Unauthorized Use on 7011,
+microtalon-dis,7013,tcp,Microtalon Discovery,[Jim_Thompson],[Jim_Thompson],,,,,,
+microtalon-dis,7013,udp,Microtalon Discovery,[Jim_Thompson],[Jim_Thompson],,,,,,
+microtalon-com,7014,tcp,Microtalon Communications,[Jim_Thompson],[Jim_Thompson],,,,,,
+microtalon-com,7014,udp,Microtalon Communications,[Jim_Thompson],[Jim_Thompson],,,,,,
+talon-webserver,7015,tcp,Talon Webserver,[Jim_Thompson],[Jim_Thompson],,,,,,
+talon-webserver,7015,udp,Talon Webserver,[Jim_Thompson],[Jim_Thompson],,,,,,
+,7016-7017,,Unassigned,,,,,,,,
+fisa-svc,7018,tcp,FISA Service,[FAUCONNET_Ingenierie],[FAUCONNET_Ingenierie],2011-05-19,,,,,
+,7018,udp,Reserved,,,,,,,,
+doceri-ctl,7019,tcp,doceri drawing service control,[Paul_Brown],[Paul_Brown],2011-04-27,,,,,
+doceri-view,7019,udp,doceri drawing service screen view,[Paul_Brown],[Paul_Brown],2011-04-27,,,,,
+dpserve,7020,tcp,DP Serve,[Allan_Stanley],[Allan_Stanley],,,,,,
+dpserve,7020,udp,DP Serve,[Allan_Stanley],[Allan_Stanley],,,,,,
+dpserveadmin,7021,tcp,DP Serve Admin,[Allan_Stanley],[Allan_Stanley],,,,,,
+dpserveadmin,7021,udp,DP Serve Admin,[Allan_Stanley],[Allan_Stanley],,,,,,
+ctdp,7022,tcp,CT Discovery Protocol,[James_Kirkwood],[James_Kirkwood],2005-06,,,,,
+ctdp,7022,udp,CT Discovery Protocol,[James_Kirkwood],[James_Kirkwood],2005-06,,,,,
+ct2nmcs,7023,tcp,Comtech T2 NMCS,[Bryan_Wilcutt],[Bryan_Wilcutt],2005-06,,,,,
+ct2nmcs,7023,udp,Comtech T2 NMCS,[Bryan_Wilcutt],[Bryan_Wilcutt],2005-06,,,,,
+vmsvc,7024,tcp,Vormetric service,[Tom_Boyle],[Tom_Boyle],2005-06,,,,,
+vmsvc,7024,udp,Vormetric service,[Tom_Boyle],[Tom_Boyle],2005-06,,,,,
+vmsvc-2,7025,tcp,Vormetric Service II,[Tom_Boyle],[Tom_Boyle],2005-06,,,,,
+vmsvc-2,7025,udp,Vormetric Service II,[Tom_Boyle],[Tom_Boyle],2005-06,,,,,
+,7026-7029,,Unassigned,,,,,,,,
+op-probe,7030,tcp,ObjectPlanet probe,[Bjorn_Jarle_Kvande],[Bjorn_Jarle_Kvande],2002-04,,,,,
+op-probe,7030,udp,ObjectPlanet probe,[Bjorn_Jarle_Kvande],[Bjorn_Jarle_Kvande],2002-04,,,,,
+iposplanet,7031,tcp,IPOSPLANET retailing multi devices protocol,[Fabrice_Paget],[Fabrice_Paget],2012-10-23,,,,,
+,7031,udp,Reserved,,,,,,,,
+,7032-7039,,Unassigned,,,,,,,,
+,7040,tcp,Reserved,,,,,,,,
+quest-disc,7040,udp,Quest application level network service discovery,[Quest_Software],[Henrik_Johnson],2012-04-09,,,,,
+,7041-7069,,Unassigned,,,,,,,,
+arcp,7070,tcp,ARCP,[Jude_George],[Jude_George],,,,,,
+arcp,7070,udp,ARCP,[Jude_George],[Jude_George],,,,,,
+iwg1,7071,tcp,IWGADTS Aircraft Housekeeping Message,[Don_Sullivan],[Don_Sullivan],2010-02-16,,,,,
+iwg1,7071,udp,IWGADTS Aircraft Housekeeping Message,[Don_Sullivan],[Don_Sullivan],2010-02-16,,,,,
+,7072,,Unassigned,,,,,,,,
+martalk,7073,tcp,MarTalk protocol,[Mahr_GmbH_Göttingen],[Kevin_Bube],2013-09-02,,,,,
+,7073,udp,Reserved,,,,,,,,
+,7074-7079,,Unassigned,,,,,,,,
+empowerid,7080,tcp,EmpowerID Communication,[Matthew_Whited],[Matthew_Whited],2008-01-16,,,,,
+empowerid,7080,udp,EmpowerID Communication,[Matthew_Whited],[Matthew_Whited],2008-01-16,,,,,
+,7081-7094,,Unassigned,,,,,,,,
+jdp-disc,7095,udp,Java Discovery Protocol,[OpenJDK],[Florian_Weimer],2013-03-12,,,,,
+,7095,tcp,Reserved,,,,,,,,
+,7096-7098,,Unassigned,,,,,,,,
+lazy-ptop,7099,tcp,lazy-ptop,[Guy_Keren],[Guy_Keren],,,,,,
+lazy-ptop,7099,udp,lazy-ptop,[Guy_Keren],[Guy_Keren],,,,,,
+font-service,7100,tcp,X Font Service,[Stephen_Gildea],[Stephen_Gildea],,,,,,
+font-service,7100,udp,X Font Service,[Stephen_Gildea],[Stephen_Gildea],,,,,,
+elcn,7101,tcp,Embedded Light Control Network,[Michael_Scarito],[Michael_Scarito],2007-02,,,,,
+elcn,7101,udp,Embedded Light Control Network,[Michael_Scarito],[Michael_Scarito],2007-02,,,,,
+,7102-7106,,Unassigned,,,,,,,,
+,7107,tcp,Reserved,,,,,,,,
+aes-x170,7107,udp,AES-X170,[Richard_Foss],[Richard_Foss],2011-02-10,,,,,
+,7108-7120,,Unassigned,,,,,,,,
+virprot-lm,7121,tcp,Virtual Prototypes License Manager,[Victor_Galis],[Victor_Galis],,,,,,
+virprot-lm,7121,udp,Virtual Prototypes License Manager,[Victor_Galis],[Victor_Galis],,,,,,
+,7122-7127,,Unassigned,,,,,,,,
+scenidm,7128,tcp,intelligent data manager,[Paul_Ignatius],[Paul_Ignatius],2006-03,,,,,
+scenidm,7128,udp,intelligent data manager,[Paul_Ignatius],[Paul_Ignatius],2006-03,,,,,
+scenccs,7129,tcp,Catalog Content Search,[Anil_Sharma],[Anil_Sharma],2006-04,,,,,
+scenccs,7129,udp,Catalog Content Search,[Anil_Sharma],[Anil_Sharma],2006-04,,,,,
+,7130-7160,,Unassigned,,,,,,,,
+cabsm-comm,7161,tcp,CA BSM Comm,[Chun_Ho_Chang],[Chun_Ho_Chang],2004-11,,,,,
+cabsm-comm,7161,udp,CA BSM Comm,[Chun_Ho_Chang],[Chun_Ho_Chang],2004-11,,,,,
+caistoragemgr,7162,tcp,CA Storage Manager,[Emre_Tunar],[Emre_Tunar],2004-11,,,,,
+caistoragemgr,7162,udp,CA Storage Manager,[Emre_Tunar],[Emre_Tunar],2004-11,,,,,
+cacsambroker,7163,tcp,CA Connection Broker,[David_Roberts],[David_Roberts],2005-05,,,,,
+cacsambroker,7163,udp,CA Connection Broker,[David_Roberts],[David_Roberts],2005-05,,,,,
+fsr,7164,tcp,File System Repository Agent,[Micha_Ben_Efraim],[Micha_Ben_Efraim],2007-07-19,,,,,
+fsr,7164,udp,File System Repository Agent,[Micha_Ben_Efraim],[Micha_Ben_Efraim],2007-07-19,,,,,
+doc-server,7165,tcp,Document WCF Server,[Micha_Ben_Efraim],[Micha_Ben_Efraim],2008-01-07,,,,,
+doc-server,7165,udp,Document WCF Server,[Micha_Ben_Efraim],[Micha_Ben_Efraim],2008-01-07,,,,,
+aruba-server,7166,tcp,Aruba eDiscovery Server,[Micha_Ben_Efraim],[Micha_Ben_Efraim],2008-01-07,,,,,
+aruba-server,7166,udp,Aruba eDiscovery Server,[Micha_Ben_Efraim],[Micha_Ben_Efraim],2008-01-07,,,,,
+casrmagent,7167,tcp,CA SRM Agent,[Venkata_Krishna],[Venkata_Krishna],2010-02-24,,,,,
+,7167,udp,Reserved,,,,,,,,
+cnckadserver,7168,tcp,cncKadServer DB & Inventory Services,[Micha_Ben_Efraim_2],[Micha_Ben_Efraim_2],2011-01-31,,,,,
+,7168,udp,Reserved,,,,,,,,
+ccag-pib,7169,tcp,Consequor Consulting Process Integration Bridge,[Frank_Goenninger],[Frank_Goenninger],2010-02-22,,,,,
+ccag-pib,7169,udp,Consequor Consulting Process Integration Bridge,[Frank_Goenninger],[Frank_Goenninger],2010-02-22,,,,,
+nsrp,7170,tcp,Adaptive Name/Service Resolution,[Geoff_Back_2],[Geoff_Back_2],2010-02-01,,,,,
+nsrp,7170,udp,Adaptive Name/Service Resolution,[Geoff_Back_2],[Geoff_Back_2],2010-02-01,,,,,
+drm-production,7171,tcp,Discovery and Retention Mgt Production,[Micha_Ben_Efraim_3],[Micha_Ben_Efraim_3],2010-02-18,,,,,
+drm-production,7171,udp,Discovery and Retention Mgt Production,[Micha_Ben_Efraim_3],[Micha_Ben_Efraim_3],2010-02-18,,,,,
+metalbend,7172,tcp,Port used for MetalBend programmable interface,[Micha_Ben_Efraim_4],[Micha_Ben_Efraim_4],2012-11-27,,,,,
+,7172,udp,Reserved,,,,,,,,
+zsecure,7173,tcp,zSecure Server,[Hans_Schoone],[Hans_Schoone],2010-10-01,,,,,
+,7173,udp,Reserved,,,,,,,,
+clutild,7174,tcp,Clutild,[Cheryl_Stoutenburg],[Cheryl_Stoutenburg],,,,,,
+clutild,7174,udp,Clutild,[Cheryl_Stoutenburg],[Cheryl_Stoutenburg],,,,,,
+,7175-7180,,Unassigned,,,,,,,,
+janus-disc,7181,udp,Janus Guidewire Enterprise Discovery Service Bus,[Guidewire_Software_Inc],[Luca_Debiasi],2014-02-06,,,,,
+,7181,tcp,Reserved,,,,,,,,
+,7182-7199,,Unassigned,,,,,,,,
+fodms,7200,tcp,FODMS FLIP,[David_Anthony],[David_Anthony],,,,,,
+fodms,7200,udp,FODMS FLIP,[David_Anthony],[David_Anthony],,,,,,
+dlip,7201,tcp,DLIP,[Albert_Manfredi],[Albert_Manfredi],,,,,,
+dlip,7201,udp,DLIP,[Albert_Manfredi],[Albert_Manfredi],,,,,,
+,7202-7226,,Unassigned,,,,,,,,
+ramp,7227,tcp,Registry A & M Protocol,[John_Havard],[John_Havard],2003-11,,,,,
+ramp,7227,udp,Registry A $ M Protocol,[John_Havard],[John_Havard],2003-11,,,,,
+citrixupp,7228,tcp,Citrix Universal Printing Port,[Gary_Barton],[Gary_Barton],2011-02-24,,,,,
+,7228,udp,Reserved,,,,,,,,
+citrixuppg,7229,tcp,Citrix UPP Gateway,[Gary_Barton],[Gary_Barton],2011-02-24,,,,,
+,7229,udp,Reserved,,,,,,,,
+,7230-7234,,Unassigned,,,,,,,,
+aspcoordination,7235,udp,ASP Coordination Protocol,[Wi-Fi_Alliance_2],[Mick_Conley],2013-12-31,,,,,
+,7235,tcp,Reserved,,,,,,,,
+display,7236,tcp,Wi-Fi Alliance Wi-Fi Display Protocol,[Wi-Fi_Alliance],[Thomas_Sciorilli],2012-04-09,,,,,Defined TXT keys: _display.tcp. Display Protocol
+,7236,udp,Reserved,,,,,,,,
+pads,7237,tcp,PADS (Public Area Display System) Server,[Willie_Jan_Bons],[Willie_Jan_Bons],2011-03-10,,,,,
+,7237,udp,Reserved,,,,,,,,
+,7238-7261,,Unassigned,,,,,,,,
+cnap,7262,tcp,Calypso Network Access Protocol,[Scott_Halberg],[Scott_Halberg],2009-06-02,,,,,
+cnap,7262,udp,Calypso Network Access Protocol,[Scott_Halberg],[Scott_Halberg],2009-06-02,,,,,
+,7263-7271,,Unassigned,,,,,,,,
+watchme-7272,7272,tcp,WatchMe Monitoring 7272,[Oliver_Heinz],[Oliver_Heinz],2005-08,,,,,
+watchme-7272,7272,udp,WatchMe Monitoring 7272,[Oliver_Heinz],[Oliver_Heinz],2005-08,,,,,
+oma-rlp,7273,tcp,OMA Roaming Location,[Larry_A_Young],[Larry_A_Young],2005-08,,,,,
+oma-rlp,7273,udp,OMA Roaming Location,[Larry_A_Young],[Larry_A_Young],2005-08,,,,,
+oma-rlp-s,7274,tcp,OMA Roaming Location SEC,[Larry_A_Young],[Larry_A_Young],2005-08,,,,,
+oma-rlp-s,7274,udp,OMA Roaming Location SEC,[Larry_A_Young],[Larry_A_Young],2005-08,,,,,
+oma-ulp,7275,tcp,OMA UserPlane Location,[Larry_A_Young_2],[Larry_A_Young_2],2006-02,,,,,
+oma-ulp,7275,udp,OMA UserPlane Location,[Larry_A_Young_2],[Larry_A_Young_2],2006-02,,,,,
+oma-ilp,7276,tcp,OMA Internal Location Protocol,[Khiem_Tran],[Khiem_Tran],2007-11-06,,,,,
+oma-ilp,7276,udp,OMA Internal Location Protocol,[Khiem_Tran],[Khiem_Tran],2007-11-06,,,,,
+oma-ilp-s,7277,tcp,OMA Internal Location Secure Protocol,[Khiem_Tran],[Khiem_Tran],2007-11-06,,,,,
+oma-ilp-s,7277,udp,OMA Internal Location Secure Protocol,[Khiem_Tran],[Khiem_Tran],2007-11-06,,,,,
+oma-dcdocbs,7278,tcp,OMA Dynamic Content Delivery over CBS,[Avi_Primo],[Avi_Primo],2008-01-29,,,,,
+oma-dcdocbs,7278,udp,OMA Dynamic Content Delivery over CBS,[Avi_Primo],[Avi_Primo],2008-01-29,,,,,
+ctxlic,7279,tcp,Citrix Licensing,[Marc_Binstock],[Marc_Binstock],2008-01-29,,,,,
+ctxlic,7279,udp,Citrix Licensing,[Marc_Binstock],[Marc_Binstock],2008-01-29,,,,,
+itactionserver1,7280,tcp,ITACTIONSERVER 1,[Brian_Taylor],[Brian_Taylor],,,,,,
+itactionserver1,7280,udp,ITACTIONSERVER 1,[Brian_Taylor],[Brian_Taylor],,,,,,
+itactionserver2,7281,tcp,ITACTIONSERVER 2,[Brian_Taylor],[Brian_Taylor],,,,,,
+itactionserver2,7281,udp,ITACTIONSERVER 2,[Brian_Taylor],[Brian_Taylor],,,,,,
+mzca-action,7282,tcp,eventACTION/ussACTION (MZCA) server,[Gord_Tomlin],[Gord_Tomlin],2009-01-30,,,,,
+mzca-alert,7282,udp,eventACTION/ussACTION (MZCA) alert,[Gord_Tomlin],[Gord_Tomlin],2010-01-21,,,,,
+genstat,7283,tcp,General Statistics Rendezvous Protocol,[VSN_International_Ltd],[Sean_D_Sollé],2011-09-28,,,,,
+,7283,udp,Reserved,,,,,,,,
+,7284-7299,,Unassigned,,,,,,,,
+swx,7300-7359,,The Swiss Exchange,[Edgar_Blum],[Edgar_Blum],,,,,,
+,7360-7364,,Unassigned,,,,2006-02-06,,,,
+lcm-server,7365,tcp,LifeKeeper Communications,[James_Bottomley],[James_Bottomley],2006-02,,,,,
+lcm-server,7365,udp,LifeKeeper Communications,[James_Bottomley],[James_Bottomley],2006-02,,,,,
+,7366-7390,,Unassigned,,,,2006-02-06,,,,
+mindfilesys,7391,tcp,mind-file system server,[Dave_Porter],[Dave_Porter],,,,,,
+mindfilesys,7391,udp,mind-file system server,[Dave_Porter],[Dave_Porter],,,,,,
+mrssrendezvous,7392,tcp,mrss-rendezvous server,[Dave_Porter],[Dave_Porter],,,,,,
+mrssrendezvous,7392,udp,mrss-rendezvous server,[Dave_Porter],[Dave_Porter],,,,,,
+nfoldman,7393,tcp,nFoldMan Remote Publish,[Richard_McDonald],[Richard_McDonald],2006-01,,,,,
+nfoldman,7393,udp,nFoldMan Remote Publish,[Richard_McDonald],[Richard_McDonald],2006-01,,,,,
+fse,7394,tcp,File system export of backup images,[Weibao_Wu],[Weibao_Wu],2006-04,,,,,
+fse,7394,udp,File system export of backup images,[Weibao_Wu],[Weibao_Wu],2006-04,,,,,
+winqedit,7395,tcp,winqedit,[David_Greer],[David_Greer],,,,,,
+winqedit,7395,udp,winqedit,[David_Greer],[David_Greer],,,,,,
+,7396,,Unassigned,,,,,,,,
+hexarc,7397,tcp,Hexarc Command Language,[George_Moromisato],[George_Moromisato],2004-11,,,,,
+hexarc,7397,udp,Hexarc Command Language,[George_Moromisato],[George_Moromisato],2004-11,,,,,
+,7398-7399,,Unassigned,,,,,,,,
+rtps-discovery,7400,tcp,RTPS Discovery,[Gerardo_Pardo_Castel],[Gerardo_Pardo_Castel],2005-10,,,,,
+rtps-discovery,7400,udp,RTPS Discovery,[Gerardo_Pardo_Castel],[Gerardo_Pardo_Castel],2005-10,,,,,
+rtps-dd-ut,7401,tcp,RTPS Data-Distribution User-Traffic,[Gerardo_Pardo_Castel],[Gerardo_Pardo_Castel],2005-10,,,,,
+rtps-dd-ut,7401,udp,RTPS Data-Distribution User-Traffic,[Gerardo_Pardo_Castel],[Gerardo_Pardo_Castel],2005-10,,,,,
+rtps-dd-mt,7402,tcp,RTPS Data-Distribution Meta-Traffic,[Gerardo_Pardo_Castel],[Gerardo_Pardo_Castel],2005-10,,,,,
+rtps-dd-mt,7402,udp,RTPS Data-Distribution Meta-Traffic,[Gerardo_Pardo_Castel],[Gerardo_Pardo_Castel],2005-10,,,,,
+,7403-7409,,Unassigned,,,,,,,,
+ionixnetmon,7410,tcp,Ionix Network Monitor,[Maxime_Deputter],[Maxime_Deputter],2006-04,,,,,
+ionixnetmon,7410,udp,Ionix Network Monitor,[Maxime_Deputter],[Maxime_Deputter],2006-04,,,,,
+daqstream,7411,tcp,Streaming of measurement data,[Hottinger_Baldwin_Messtechnik_GmbH],[Stephan_Gatzka],2013-03-15,,,,,
+daqstream,7411,udp,Streaming of measurement data,[Hottinger_Baldwin_Messtechnik_GmbH],[Stephan_Gatzka],2013-03-15,,,,,
+,7412-7420,,Unassigned,,,,,,,,
+mtportmon,7421,tcp,Matisse Port Monitor,[Didier_Cabannes],[Didier_Cabannes],2004-11,,,,,
+mtportmon,7421,udp,Matisse Port Monitor,[Didier_Cabannes],[Didier_Cabannes],2004-11,,,,,
+,7422-7425,,Unassigned,,,,,,,,
+pmdmgr,7426,tcp,OpenView DM Postmaster Manager,[Dave_Lamb],[Dave_Lamb],,,,,,
+pmdmgr,7426,udp,OpenView DM Postmaster Manager,[Dave_Lamb],[Dave_Lamb],,,,,,
+oveadmgr,7427,tcp,OpenView DM Event Agent Manager,[Dave_Lamb],[Dave_Lamb],,,,,,
+oveadmgr,7427,udp,OpenView DM Event Agent Manager,[Dave_Lamb],[Dave_Lamb],,,,,,
+ovladmgr,7428,tcp,OpenView DM Log Agent Manager,[Dave_Lamb],[Dave_Lamb],,,,,,
+ovladmgr,7428,udp,OpenView DM Log Agent Manager,[Dave_Lamb],[Dave_Lamb],,,,,,
+opi-sock,7429,tcp,OpenView DM rqt communication,[Dave_Lamb],[Dave_Lamb],,,,,,
+opi-sock,7429,udp,OpenView DM rqt communication,[Dave_Lamb],[Dave_Lamb],,,,,,
+xmpv7,7430,tcp,OpenView DM xmpv7 api pipe,[Dave_Lamb],[Dave_Lamb],,,,,,
+xmpv7,7430,udp,OpenView DM xmpv7 api pipe,[Dave_Lamb],[Dave_Lamb],,,,,,
+pmd,7431,tcp,OpenView DM ovc/xmpv3 api pipe,[Dave_Lamb],[Dave_Lamb],,,,,,
+pmd,7431,udp,OpenView DM ovc/xmpv3 api pipe,[Dave_Lamb],[Dave_Lamb],,,,,,
+,7432-7436,,Unassigned,,,,,,,,
+faximum,7437,tcp,Faximum,[George_Pajari],[George_Pajari],,,,,,
+faximum,7437,udp,Faximum,[George_Pajari],[George_Pajari],,,,,,
+,7438-7442,,Unassigned,,,,,,,,
+oracleas-https,7443,tcp,Oracle Application Server HTTPS,[David_McMarlin],[David_McMarlin],2006-08,,,,,
+oracleas-https,7443,udp,Oracle Application Server HTTPS,[David_McMarlin],[David_McMarlin],2006-08,,,,,
+,7444-7470,,Unassigned,,,,,,,,
+sttunnel,7471,tcp,Stateless Transport Tunneling Protocol,[Bruce_Davie_3],[Bruce_Davie_3],2014-04-28,,,,,
+,7471,udp,Reserved,,,,,,,,
+,7472,,Unassigned,,,,,,,,
+rise,7473,tcp,Rise: The Vieneo Province,[Jason_Reskin],[Jason_Reskin],2007-03,,,,,
+rise,7473,udp,Rise: The Vieneo Province,[Jason_Reskin],[Jason_Reskin],2007-03,,,,,
+neo4j,7474,tcp,Neo4j Graph Database,[Neo_Technology_Inc],[Julian_Simpson],2013-02-08,,,,,
+,7474,udp,Reserved,,,,,,,,
+,7475-7490,,Unassigned,,,,,,,,
+telops-lmd,7491,tcp,telops-lmd,[David_Spencer],[David_Spencer],,,,,,
+telops-lmd,7491,udp,telops-lmd,[David_Spencer],[David_Spencer],,,,,,
+,7492-7499,,Unassigned,,,,,,,Known Unauthorized Use on port 7499,
+silhouette,7500,tcp,Silhouette User,[Anthony_Payne],[Anthony_Payne],2004-02,,,,,
+silhouette,7500,udp,Silhouette User,[Anthony_Payne],[Anthony_Payne],2004-02,,,,,
+ovbus,7501,tcp,HP OpenView Bus Daemon,[David_M_Rhodes],[David_M_Rhodes],,,,,Known Unauthorized Use on port 7501,
+ovbus,7501,udp,HP OpenView Bus Daemon,[David_M_Rhodes],[David_M_Rhodes],,,,,Known Unauthorized Use on port 7501,
+,7502-7507,,Unassigned,,,,,,,,
+adcp,7508,tcp,Automation Device Configuration Protocol,[Festo_AG],[Joerg_Ullmann],2011-05-27,2012-07-26,,,,
+,7508,udp,Reserved,,,,,,,,
+acplt,7509,tcp,ACPLT - process automation service,[Chair_for_Process_Control_Engineering],[Ulrich_Epple],2010-12-07,2012-08-07,,,,
+,7509,udp,Reserved,,,,,,,,
+ovhpas,7510,tcp,HP OpenView Application Server,[Jeff_Conrad],[Jeff_Conrad],,,,,,
+ovhpas,7510,udp,HP OpenView Application Server,[Jeff_Conrad],[Jeff_Conrad],,,,,,
+pafec-lm,7511,tcp,pafec-lm,[Billy_Dhillon],[Billy_Dhillon],,,,,,
+pafec-lm,7511,udp,pafec-lm,[Billy_Dhillon],[Billy_Dhillon],,,,,,
+,7512-7541,,Unassigned,,,,,,,,
+saratoga,7542,tcp,Saratoga Transfer Protocol,[Lloyd_Wood],[Lloyd_Wood],2007-05,,,,,
+saratoga,7542,udp,Saratoga Transfer Protocol,[Lloyd_Wood],[Lloyd_Wood],2007-05,,,,,
+atul,7543,tcp,atul server,[Mark_Stapp],[Mark_Stapp],2006-01,,,,,
+atul,7543,udp,atul server,[Mark_Stapp],[Mark_Stapp],2006-01,,,,,
+nta-ds,7544,tcp,FlowAnalyzer DisplayServer,[Fred_Messinger],[Fred_Messinger],,,,,,
+nta-ds,7544,udp,FlowAnalyzer DisplayServer,[Fred_Messinger],[Fred_Messinger],,,,,,
+nta-us,7545,tcp,FlowAnalyzer UtilityServer,[Fred_Messinger],[Fred_Messinger],,,,,,
+nta-us,7545,udp,FlowAnalyzer UtilityServer,[Fred_Messinger],[Fred_Messinger],,,,,,
+cfs,7546,tcp,Cisco Fabric service,[Rituparna_Agrawal],[Rituparna_Agrawal],2005-09,,,,,
+cfs,7546,udp,Cisco Fabric service,[Rituparna_Agrawal],[Rituparna_Agrawal],2005-09,,,,,
+cwmp,7547,tcp,DSL Forum CWMP,[Anton_Okmianski],[Anton_Okmianski],2006-01,,,,,
+cwmp,7547,udp,DSL Forum CWMP,[Anton_Okmianski],[Anton_Okmianski],2006-01,,,,,
+tidp,7548,tcp,Threat Information Distribution Protocol,[Chui_Tin_Yen],[Chui_Tin_Yen],2006-02,,,,,
+tidp,7548,udp,Threat Information Distribution Protocol,[Chui_Tin_Yen],[Chui_Tin_Yen],2006-02,,,,,
+nls-tl,7549,tcp,Network Layer Signaling Transport Layer,[Melinda_Shore],[Melinda_Shore],2006-05,,,,,
+nls-tl,7549,udp,Network Layer Signaling Transport Layer,[Melinda_Shore],[Melinda_Shore],2006-05,,,,,
+,7550,tcp,Reserved,,,,,,,,
+cloudsignaling,7550,udp,Cloud Signaling Service,[Scott_Dawson],[Scott_Dawson],2011-07-01,,,,,
+,7551-7559,,Unassigned,,,,,,,,
+sncp,7560,tcp,Sniffer Command Protocol,[Dominick_Cafarelli],[Dominick_Cafarelli],2005-08,,,,,
+sncp,7560,udp,Sniffer Command Protocol,[Dominick_Cafarelli],[Dominick_Cafarelli],2005-08,,,,,
+,7561-7562,,Unassigned,,,,,,,,
+cfw,7563,tcp,Control Framework,,,,,[RFC6230],,,
+,7563,udp,Reserved,,,,,,,,
+,7564-7565,,Unassigned,,,,,,,,
+vsi-omega,7566,tcp,VSI Omega,[Curtis_Smith],[Curtis_Smith],,,,,,
+vsi-omega,7566,udp,VSI Omega,[Curtis_Smith],[Curtis_Smith],,,,,,
+,7567-7568,,Unassigned,,,,,,,,
+dell-eql-asm,7569,tcp,Dell EqualLogic Host Group Management,[James_E_King_III],[James_E_King_III],,,,,,
+,7569,udp,Reserved,,,,,,,,
+aries-kfinder,7570,tcp,Aries Kfinder,[James_King_III],[James_King_III],,,,,,
+aries-kfinder,7570,udp,Aries Kfinder,[James_King_III],[James_King_III],,,,,,
+,7571-7573,,Unassigned,,,,,,,,
+coherence,7574,tcp,Oracle Coherence Cluster Service,[Oracle_5],[Mark_Falco],2014-07-09,,,,,
+coherence-disc,7574,udp,Oracle Coherence Cluster discovery service,[Oracle_5],[Mark_Falco],2014-07-09,,,,,
+,7575-7587,,Unassigned,,,,,,,,
+sun-lm,7588,tcp,Sun License Manager,[Sophie_Deng],[Sophie_Deng],,,,,,
+sun-lm,7588,udp,Sun License Manager,[Sophie_Deng],[Sophie_Deng],,,,,,
+,7589-7623,,Unassigned,,,,,,,,
+indi,7624,tcp,Instrument Neutral Distributed Interface,[Elwood_Downey],[Elwood_Downey],2002-04,,,,,
+indi,7624,udp,Instrument Neutral Distributed Interface,[Elwood_Downey],[Elwood_Downey],2002-04,,,,,
+,7625,,Unassigned,,,,,,,,
+simco,7626,tcp,SImple Middlebox COnfiguration (SIMCO) Server,,,,,[RFC4540],,,
+,7626,udp,De-registered,,,2006-01-30,,,,,
+simco,7626,sctp,SImple Middlebox COnfiguration (SIMCO),[Sebastian_Kiesel],[Sebastian_Kiesel],2006-01,,,,,
+soap-http,7627,tcp,SOAP Service Port,[Donald_Dylla],[Donald_Dylla],2004-12,,,,,
+soap-http,7627,udp,SOAP Service Port,[Donald_Dylla],[Donald_Dylla],2004-12,,,,,
+zen-pawn,7628,tcp,Primary Agent Work Notification,[Ty_Ellis],[Ty_Ellis],2006-05,,,,,
+zen-pawn,7628,udp,Primary Agent Work Notification,[Ty_Ellis],[Ty_Ellis],2006-05,,,,,
+xdas,7629,tcp,OpenXDAS Wire Protocol,[John_Calcote_2],[John_Calcote_2],2006-10,,,,,
+xdas,7629,udp,OpenXDAS Wire Protocol,[John_Calcote_2],[John_Calcote_2],2006-10,,,,,
+hawk,7630,tcp,HA Web Konsole,[Tim_Serong],[Tim_Serong],2010-03-31,,,,,
+,7630,udp,Reserved,,,,,,,,
+tesla-sys-msg,7631,tcp,TESLA System Messaging,[Andy_Perreault],[Andy_Perreault],2010-03-31,,,,,
+,7631,udp,Reserved,,,,,,,,
+,7632,,Unassigned,,,,,,,,
+pmdfmgt,7633,tcp,PMDF Management,[Hunter_Goatley],[Hunter_Goatley],,,,,,
+pmdfmgt,7633,udp,PMDF Management,[Hunter_Goatley],[Hunter_Goatley],,,,,,
+,7634-7647,,Unassigned,,,,,,,,
+cuseeme,7648,tcp,bonjour-cuseeme,[Marc_Manthey],[Marc_Manthey],2006-07,,,,,
+cuseeme,7648,udp,bonjour-cuseeme,[Marc_Manthey],[Marc_Manthey],2006-07,,,,,
+,7649-7671,,Unassigned,,,,,,,,
+imqstomp,7672,tcp,iMQ STOMP Server,[Amy_Kang],[Amy_Kang],2009-03-10,,,,,
+,7672,udp,Reserved,,,,,,,,
+imqstomps,7673,tcp,iMQ STOMP Server over SSL,[Amy_Kang],[Amy_Kang],2009-03-10,,,,,
+,7673,udp,Reserved,,,,,,,,
+imqtunnels,7674,tcp,iMQ SSL tunnel,[Shailesh_S_Bavadeka],[Shailesh_S_Bavadeka],2002-04,,,,,
+imqtunnels,7674,udp,iMQ SSL tunnel,[Shailesh_S_Bavadeka],[Shailesh_S_Bavadeka],2002-04,,,,,
+imqtunnel,7675,tcp,iMQ Tunnel,[Shailesh_S_Bavadeka],[Shailesh_S_Bavadeka],2002-04,,,,,
+imqtunnel,7675,udp,iMQ Tunnel,[Shailesh_S_Bavadeka],[Shailesh_S_Bavadeka],2002-04,,,,,
+imqbrokerd,7676,tcp,iMQ Broker Rendezvous,[Joseph_Di_Pol],[Joseph_Di_Pol],2002-04,,,,,
+imqbrokerd,7676,udp,iMQ Broker Rendezvous,[Joseph_Di_Pol],[Joseph_Di_Pol],2002-04,,,,,
+sun-user-https,7677,tcp,Sun App Server - HTTPS,[Abhijit_Kumar],[Abhijit_Kumar],2005-11,,,,,
+sun-user-https,7677,udp,Sun App Server - HTTPS,[Abhijit_Kumar],[Abhijit_Kumar],2005-11,,,,,
+,7678-7679,,Unassigned,,,,,,,,
+pando-pub,7680,tcp,Pando Media Public Distribution,[Laird_Popkin],[Laird_Popkin],2008-02-27,,,,,
+pando-pub,7680,udp,Pando Media Public Distribution,[Laird_Popkin],[Laird_Popkin],2008-02-27,,,,,
+,7681-7688,,Unassigned,,,,,,,,
+collaber,7689,tcp,Collaber Network Service,[Rajesh_Akkineni],[Rajesh_Akkineni],2007-01,,,,,
+collaber,7689,udp,Collaber Network Service,[Rajesh_Akkineni],[Rajesh_Akkineni],2007-01,,,,,
+,7690-7696,,Unassigned,,,,,,,,
+klio,7697,tcp,KLIO communications,[Helmut_Giritzer_2],[Helmut_Giritzer_2],2005-08,,,,,
+klio,7697,udp,KLIO communications,[Helmut_Giritzer_2],[Helmut_Giritzer_2],2005-08,,,,,
+,7698-7699,,Unassigned,,,,,,,,
+em7-secom,7700,tcp,EM7 Secure Communications,[Christopher_Cordray],[Christopher_Cordray],2008-06-05,,,,,
+,7700,udp,Reserved,,,,,,,,
+,7701-7706,,Unassigned,,,,,,,,
+sync-em7,7707,tcp,EM7 Dynamic Updates,[Christopher_Cordray],[Christopher_Cordray],2004-11,,,,,
+sync-em7,7707,udp,EM7 Dynamic Updates,[Christopher_Cordray],[Christopher_Cordray],2004-11,,,,,
+scinet,7708,tcp,scientia.net,[Christoph_Anton_Mitt],[Christoph_Anton_Mitt],2006-01,,,,,
+scinet,7708,udp,scientia.net,[Christoph_Anton_Mitt],[Christoph_Anton_Mitt],2006-01,,,,,
+,7709-7719,,Unassigned,,,,,,,,
+medimageportal,7720,tcp,MedImage Portal,[Robert_Helton],[Robert_Helton],2003-10,,,,,
+medimageportal,7720,udp,MedImage Portal,[Robert_Helton],[Robert_Helton],2003-10,,,,,
+,7721-7723,,Unassigned,,,,,,,,
+nsdeepfreezectl,7724,tcp,Novell Snap-in Deep Freeze Control,[David_Crowe],[David_Crowe],2008-01-07,,,,,
+nsdeepfreezectl,7724,udp,Novell Snap-in Deep Freeze Control,[David_Crowe],[David_Crowe],2008-01-07,,,,,
+nitrogen,7725,tcp,Nitrogen Service,[Randy_Lomnes],[Randy_Lomnes],2004-11,,,,,
+nitrogen,7725,udp,Nitrogen Service,[Randy_Lomnes],[Randy_Lomnes],2004-11,,,,,
+freezexservice,7726,tcp,FreezeX Console Service,[David_Crowe],[David_Crowe],2005-06,,,,,
+freezexservice,7726,udp,FreezeX Console Service,[David_Crowe],[David_Crowe],2005-06,,,,,
+trident-data,7727,tcp,Trident Systems Data,[Jeremy_McClintock],[Jeremy_McClintock],2005-08,,,,,
+trident-data,7727,udp,Trident Systems Data,[Jeremy_McClintock],[Jeremy_McClintock],2005-08,,,,,
+,7728-7733,,Unassigned,,,,,,,,
+smip,7734,tcp,Smith Protocol over IP,[Jim_Pettinato],[Jim_Pettinato],2007-04,,,,,
+smip,7734,udp,Smith Protocol over IP,[Jim_Pettinato],[Jim_Pettinato],2007-04,,,,,
+,7735-7737,,Unassigned,,,,,,,,
+aiagent,7738,tcp,HP Enterprise Discovery Agent,[Matthew_Darwin],[Matthew_Darwin],2005-08,,,,,
+aiagent,7738,udp,HP Enterprise Discovery Agent,[Matthew_Darwin],[Matthew_Darwin],2005-08,,,,,
+,7739-7740,,Unassigned,,,,,,,,
+scriptview,7741,tcp,ScriptView Network,[Reinhard_Wolf],[Reinhard_Wolf],2010-08-19,,,,,
+scriptview,7741,udp,ScriptView Network,[Reinhard_Wolf],[Reinhard_Wolf],2010-08-19,,,,,
+msss,7742,tcp,Mugginsoft Script Server Service,[Jonathan_Mitchell],[Jonathan_Mitchell],2008-09-08,,,,,
+,7742,udp,Reserved,,,,,,,,
+sstp-1,7743,tcp,Sakura Script Transfer Protocol,[Kouichi_Takeda],[Kouichi_Takeda],,,,,,
+sstp-1,7743,udp,Sakura Script Transfer Protocol,[Kouichi_Takeda],[Kouichi_Takeda],,,,,,
+raqmon-pdu,7744,tcp,RAQMON PDU,,,,,[RFC4712],,,
+raqmon-pdu,7744,udp,RAQMON PDU,,,,,[RFC4712],,,
+,7745-7746,,Unassigned,,,,,,,,
+prgp,7747,tcp,Put/Run/Get Protocol,[Jayasooriah],[Jayasooriah],2008-02-22,,,,,
+prgp,7747,udp,Put/Run/Get Protocol,[Jayasooriah],[Jayasooriah],2008-02-22,,,,,
+,7748-7776,,Unassigned,,,,,,,,
+cbt,7777,tcp,cbt,[Tony_Ballardie],[Tony_Ballardie],,,,,Known Unauthorized Use on port 7777,
+cbt,7777,udp,cbt,[Tony_Ballardie],[Tony_Ballardie],,,,,Known Unauthorized Use on port 7777,
+interwise,7778,tcp,Interwise,[Joseph_Gray],[Joseph_Gray],,,,,,
+interwise,7778,udp,Interwise,[Joseph_Gray],[Joseph_Gray],,,,,,
+vstat,7779,tcp,VSTAT,[Vinh_Nguyn],[Vinh_Nguyn],,,,,,
+vstat,7779,udp,VSTAT,[Vinh_Nguyn],[Vinh_Nguyn],,,,,,
+,7780,,Unassigned,,,,,,,,
+accu-lmgr,7781,tcp,accu-lmgr,[Moises_E_Hernandez],[Moises_E_Hernandez],,,,,,
+accu-lmgr,7781,udp,accu-lmgr,[Moises_E_Hernandez],[Moises_E_Hernandez],,,,,,
+,7782-7785,,Unassigned,,,,,,,Known Unauthorized Use on port 7785,
+minivend,7786,tcp,MINIVEND,[Mike_Heins],[Mike_Heins],,,,,Known Unauthorized Use on port 7786,
+minivend,7786,udp,MINIVEND,[Mike_Heins],[Mike_Heins],,,,,Known Unauthorized Use on port 7786,
+popup-reminders,7787,tcp,Popup Reminders Receive,[Robert_Harvey],[Robert_Harvey],2006-01,,,,Known Unauthorized Use on port 7787,
+popup-reminders,7787,udp,Popup Reminders Receive,[Robert_Harvey],[Robert_Harvey],2006-01,,,,Known Unauthorized Use on port 7787,
+,7788,,Unassigned,,,,,,,Known Unauthorized Use on port 7788,
+office-tools,7789,tcp,Office Tools Pro Receive,[Robert_Harvey],[Robert_Harvey],2006-01,,,,Known Unauthorized Use on port 7789,
+office-tools,7789,udp,Office Tools Pro Receive,[Robert_Harvey],[Robert_Harvey],2006-01,,,,Known Unauthorized Use on port 7789,
+,7790-7793,,Unassigned,,,,,,,,
+q3ade,7794,tcp,Q3ADE Cluster Service,[Uffe_Harksen],[Uffe_Harksen],2005-08,,,,,
+q3ade,7794,udp,Q3ADE Cluster Service,[Uffe_Harksen],[Uffe_Harksen],2005-08,,,,,
+,7795-7796,,Unassigned,,,,,,,,
+pnet-conn,7797,tcp,Propel Connector port,,,,,,,,
+pnet-conn,7797,udp,Propel Connector port,,,,,,,,
+pnet-enc,7798,tcp,Propel Encoder port,[Leif_Hedstrom],[Leif_Hedstrom],2002-04,,,,,
+pnet-enc,7798,udp,Propel Encoder port,[Leif_Hedstrom],[Leif_Hedstrom],2002-04,,,,,
+altbsdp,7799,tcp,Alternate BSDP Service,[Dieter_Siegmund],[Dieter_Siegmund],2007-10-22,,,,,
+altbsdp,7799,udp,Alternate BSDP Service,[Dieter_Siegmund],[Dieter_Siegmund],2007-10-22,,,,,
+asr,7800,tcp,Apple Software Restore,[Jim_Kateley][Shantonu_Sen],[Jim_Kateley][Shantonu_Sen],2006-01,,,,,Defined TXT keys: image=<HTTP URL of disk image>
+asr,7800,udp,Apple Software Restore,[Jim_Kateley][Shantonu_Sen],[Jim_Kateley][Shantonu_Sen],2006-01,,,,,Defined TXT keys: image=<HTTP URL of disk image>
+ssp-client,7801,tcp,Secure Server Protocol - client,[Rick_Macchio],[Rick_Macchio],2006-11,,,,,
+ssp-client,7801,udp,Secure Server Protocol - client,[Rick_Macchio],[Rick_Macchio],2006-11,,,,,
+vns-tp,7802,udp,Virtualized Network Services Tunnel Protocol,[Juniper_Networks],[Bruno_Rijsman],2013-02-01,,,,,
+,7802,tcp,Reserved,,,,,,,,
+,7803-7809,,Unassigned,,,,,,,,
+rbt-wanopt,7810,tcp,Riverbed WAN Optimization Protocol,[Vladimir_Legalov_2],[Vladimir_Legalov_2],2007-09-04,,,,,
+rbt-wanopt,7810,udp,Riverbed WAN Optimization Protocol,[Vladimir_Legalov_2],[Vladimir_Legalov_2],2007-09-04,,,,,
+,7811-7844,,Unassigned,,,,,,,,
+apc-7845,7845,tcp,APC 7845,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-7845,7845,udp,APC 7845,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-7846,7846,tcp,APC 7846,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-7846,7846,udp,APC 7846,[American_Power_Conve],[American_Power_Conve],,,,,,
+csoauth,7847,tcp,A product key authentication protocol made by CSO,[Jeff_Wamsley],[Jacob_Kiesel],2013-09-04,,,,,
+,7847,udp,Reserved,,,,,,,,
+,7848-7868,,Unassigned,,,,,,,,
+mobileanalyzer,7869,tcp,MobileAnalyzer& MobileMonitor,[Jonas_Gyllensvaan],[Jonas_Gyllensvaan],2009-04-27,,,,,
+,7869,udp,Reserved,,,,,,,,
+rbt-smc,7870,tcp,Riverbed Steelhead Mobile Service,[Gabriel_Levy],[Gabriel_Levy],2008-08-29,,,,,
+,7870,udp,Reserved,,,,,,,,
+mdm,7871,tcp,Mobile Device Management,[Dan_Harkins],[Dan_Harkins],2011-08-15,,,,,
+,7871,udp,Reserved,,,,,,,,
+,7872,tcp,Reserved,,,,,,,,
+mipv6tls,7872,udp,TLS-based Mobile IPv6 Security,[IESG],[IETF_Chair],2012-04-12,,[RFC6618],,,
+,7873-7877,,Unassigned,,,,,,,,
+owms,7878,tcp,Opswise Message Service,[Stonebranch_Inc],[Nathan_Hammond_2],2013-06-25,,,,,
+,7878,udp,Reserved,,,,,,,,
+,7879,,Unassigned,,,,,,,,
+pss,7880,tcp,Pearson,[Pearson],[Pearson],2008-01-17,,,,,
+pss,7880,udp,Pearson,[Pearson],[Pearson],2008-01-17,,,,,
+,7881-7886,,Unassigned,,,,,,,,
+ubroker,7887,tcp,Universal Broker,[Nathan_Hammond],[Nathan_Hammond],2005-10,,,,,
+ubroker,7887,udp,Universal Broker,[Nathan_Hammond],[Nathan_Hammond],2005-10,,,,,
+,7888-7899,,Unassigned,,,,,,,,
+mevent,7900,tcp,Multicast Event,[YoonSoo_Kim],[YoonSoo_Kim],2006-05,,,,,
+mevent,7900,udp,Multicast Event,[YoonSoo_Kim],[YoonSoo_Kim],2006-05,,,,,
+tnos-sp,7901,tcp,TNOS Service Protocol,[Rene_Kurt],[Rene_Kurt],2005-08,,,,,
+tnos-sp,7901,udp,TNOS Service Protocol,[Rene_Kurt],[Rene_Kurt],2005-08,,,,,
+tnos-dp,7902,tcp,TNOS shell Protocol,[Rene_Kurt],[Rene_Kurt],2005-08,,,,,
+tnos-dp,7902,udp,TNOS shell Protocol,[Rene_Kurt],[Rene_Kurt],2005-08,,,,,
+tnos-dps,7903,tcp,TNOS Secure DiaguardProtocol,[Rene_Kurt],[Rene_Kurt],2005-08,,,,,
+tnos-dps,7903,udp,TNOS Secure DiaguardProtocol,[Rene_Kurt],[Rene_Kurt],2005-08,,,,,
+,7904-7912,,Unassigned,,,,,,,,
+qo-secure,7913,tcp,QuickObjects secure port,[Jonas_Bovin],[Jonas_Bovin],,,,,,
+qo-secure,7913,udp,QuickObjects secure port,[Jonas_Bovin],[Jonas_Bovin],,,,,,
+,7914-7931,,Unassigned,,,,,,,,
+t2-drm,7932,tcp,Tier 2 Data Resource Manager,[Peter_Carlson],[Peter_Carlson],,,,,,
+t2-drm,7932,udp,Tier 2 Data Resource Manager,[Peter_Carlson],[Peter_Carlson],,,,,,
+t2-brm,7933,tcp,Tier 2 Business Rules Manager,[Peter_Carlson],[Peter_Carlson],,,,,,
+t2-brm,7933,udp,Tier 2 Business Rules Manager,[Peter_Carlson],[Peter_Carlson],,,,,,
+,7934-7961,,Unassigned,,,,,,,,
+generalsync,7962,tcp,"Encrypted, extendable, general-purpose synchronization protocol",[Dirk_Steinmetz],[Dirk_Steinmetz],2014-04-17,,,,,
+generalsync,7962,udp,"Encrypted, extendable, general-purpose synchronization protocol",[Dirk_Steinmetz],[Dirk_Steinmetz],2014-04-17,,,,,
+,7963-7966,,Unassigned,,,,,,,,
+supercell,7967,tcp,Supercell,[Kevin_Nakagawa],[Kevin_Nakagawa],,,,,,
+supercell,7967,udp,Supercell,[Kevin_Nakagawa],[Kevin_Nakagawa],,,,,,
+,7968-7978,,Unassigned,,,,,,,,
+micromuse-ncps,7979,tcp,Micromuse-ncps,[Hing_Wing_To],[Hing_Wing_To],,,,,,
+micromuse-ncps,7979,udp,Micromuse-ncps,[Hing_Wing_To],[Hing_Wing_To],,,,,,
+quest-vista,7980,tcp,Quest Vista,[Preston_Bannister],[Preston_Bannister],,,,,,
+quest-vista,7980,udp,Quest Vista,[Preston_Bannister],[Preston_Bannister],,,,,,
+sossd-collect,7981,tcp,Spotlight on SQL Server Desktop Collect,[Rob_Griffin_2],[Rob_Griffin_2],2010-08-30,,,,,
+,7981,udp,Reserved,,,,,,,,
+sossd-agent,7982,tcp,Spotlight on SQL Server Desktop Agent,[Rob_Griffin_2],[Rob_Griffin_2],2010-09-13,,,,,
+sossd-disc,7982,udp,Spotlight on SQL Server Desktop Agent Discovery,[Rob_Griffin_2],[Rob_Griffin_2],2010-09-13,,,,,
+,7983-7997,,Unassigned,,,,,,,,
+pushns,7997,tcp,PUSH Notification Service,[Tristan_Seifert],[Tristan_Seifert],2011-01-31,,,,,
+,7997,udp,Reserved,,,,,,,,
+,7998,tcp,Reserved,,,,,,,,
+usicontentpush,7998,udp,USI Content Push Service,[Prakash_Iyer],[Prakash_Iyer],2009-08-10,,,,,
+irdmi2,7999,tcp,iRDMI2,,,,,,,,
+irdmi2,7999,udp,iRDMI2,,,,,,,,
+irdmi,8000,tcp,iRDMI,[Gil_Shafriri],[Gil_Shafriri],,,,,,
+irdmi,8000,udp,iRDMI,[Gil_Shafriri],[Gil_Shafriri],,,,,,
+vcom-tunnel,8001,tcp,VCOM Tunnel,[Mark_Lewandowski],[Mark_Lewandowski],,,,,Known Unauthorized Use on port 8001,
+vcom-tunnel,8001,udp,VCOM Tunnel,[Mark_Lewandowski],[Mark_Lewandowski],,,,,Known Unauthorized Use on port 8001,
+teradataordbms,8002,tcp,Teradata ORDBMS,[Curt_Ellmann],[Curt_Ellmann],,,,,,
+teradataordbms,8002,udp,Teradata ORDBMS,[Curt_Ellmann],[Curt_Ellmann],,,,,,
+mcreport,8003,tcp,Mulberry Connect Reporting Service,[Dave_Stoneham],[Dave_Stoneham],2008-03-10,,,,,
+mcreport,8003,udp,Mulberry Connect Reporting Service,[Dave_Stoneham],[Dave_Stoneham],2008-03-10,,,,,
+,8004,,Unassigned,,,,,,,,
+mxi,8005,tcp,MXI Generation II for z/OS,[Rob_Scott],[Rob_Scott],2007-05,,,,,
+mxi,8005,udp,MXI Generation II for z/OS,[Rob_Scott],[Rob_Scott],2007-05,,,,,
+,8006-8007,,Unassigned,,,,,,,,
+http-alt,8008,tcp,HTTP Alternate,[James_Gettys],[James_Gettys],,,,,,
+http-alt,8008,udp,HTTP Alternate,[James_Gettys],[James_Gettys],,,,,,
+,8009-8018,,Unassigned,,,,,,,,
+qbdb,8019,tcp,QB DB Dynamic Port,[Sridhar_Krishnamurth],[Sridhar_Krishnamurth],2008-02-15,,,,,
+qbdb,8019,udp,QB DB Dynamic Port,[Sridhar_Krishnamurth],[Sridhar_Krishnamurth],2008-02-15,,,,,
+intu-ec-svcdisc,8020,tcp,Intuit Entitlement Service and Discovery,[Daniel_C_McGloin],[Daniel_C_McGloin],2005-05,,,,,
+intu-ec-svcdisc,8020,udp,Intuit Entitlement Service and Discovery,[Daniel_C_McGloin],[Daniel_C_McGloin],2005-05,,,,,
+intu-ec-client,8021,tcp,Intuit Entitlement Client,[Daniel_C_McGloin],[Daniel_C_McGloin],2005-05,,,,,
+intu-ec-client,8021,udp,Intuit Entitlement Client,[Daniel_C_McGloin],[Daniel_C_McGloin],2005-05,,,,,
+oa-system,8022,tcp,oa-system,[Marie_France_Dubreui],[Marie_France_Dubreui],,,,,,
+oa-system,8022,udp,oa-system,[Marie_France_Dubreui],[Marie_France_Dubreui],,,,,,
+,8023-8024,,Unassigned,,,,,,,,
+ca-audit-da,8025,tcp,CA Audit Distribution Agent,[Henning_Smith],[Henning_Smith],2006-07,,,,,
+ca-audit-da,8025,udp,CA Audit Distribution Agent,[Henning_Smith],[Henning_Smith],2006-07,,,,,
+ca-audit-ds,8026,tcp,CA Audit Distribution Server,[Henning_Smith],[Henning_Smith],2006-07,,,,,
+ca-audit-ds,8026,udp,CA Audit Distribution Server,[Henning_Smith],[Henning_Smith],2006-07,,,,,
+,8027-8031,,Unassigned,,,,,,,,
+pro-ed,8032,tcp,ProEd,,,,,,,,
+pro-ed,8032,udp,ProEd,,,,,,,,
+mindprint,8033,tcp,MindPrint,[Larry_Tusoni],[Larry_Tusoni],,,,,,
+mindprint,8033,udp,MindPrint,[Larry_Tusoni],[Larry_Tusoni],,,,,,
+vantronix-mgmt,8034,tcp,.vantronix Management,[Reyk_Floeter],[Reyk_Floeter],2008-02-27,,,,,
+vantronix-mgmt,8034,udp,.vantronix Management,[Reyk_Floeter],[Reyk_Floeter],2008-02-27,,,,,
+,8035-8039,,Unassigned,,,,,,,,
+ampify,8040,tcp,Ampify Messaging Protocol,[Tav_Espian],[Tav_Espian],2010-08-10,,,,,
+ampify,8040,udp,Ampify Messaging Protocol,[Tav_Espian],[Tav_Espian],2010-08-10,,,,,
+,8041,,Unassigned,,,,,,,,
+fs-agent,8042,tcp,FireScope Agent,[Matt_Rogers],[Matt_Rogers],2008-10-16,,,,,
+,8042,udp,Reserved,,,,,,,,
+fs-server,8043,tcp,FireScope Server,[Matt_Rogers],[Matt_Rogers],2008-10-16,,,,,
+,8043,udp,Reserved,,,,,,,,
+fs-mgmt,8044,tcp,FireScope Management Interface,[Matt_Rogers],[Matt_Rogers],2008-10-16,,,,,
+,8044,udp,Reserved,,,,,,,,
+,8045-8050,,Unassigned,,,,,,,,
+rocrail,8051,tcp,Rocrail Client Service,[Rob_Versluis],[Rob_Versluis],2011-05-23,,,,,
+,8051,udp,Reserved,,,,,,,,
+senomix01,8052,tcp,Senomix Timesheets Server,[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+senomix01,8052,udp,Senomix Timesheets Server,[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+senomix02,8053,tcp,Senomix Timesheets Client [1 year assignment],[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+senomix02,8053,udp,Senomix Timesheets Client [1 year assignment],[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+senomix03,8054,tcp,Senomix Timesheets Server [1 year assignment],[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+senomix03,8054,udp,Senomix Timesheets Server [1 year assignment],[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+senomix04,8055,tcp,Senomix Timesheets Server [1 year assignment],[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+senomix04,8055,udp,Senomix Timesheets Server [1 year assignment],[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+senomix05,8056,tcp,Senomix Timesheets Server [1 year assignment],[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+senomix05,8056,udp,Senomix Timesheets Server [1 year assignment],[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+senomix06,8057,tcp,Senomix Timesheets Client [1 year assignment],[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+senomix06,8057,udp,Senomix Timesheets Client [1 year assignment],[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+senomix07,8058,tcp,Senomix Timesheets Client [1 year assignment],[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+senomix07,8058,udp,Senomix Timesheets Client [1 year assignment],[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+senomix08,8059,tcp,Senomix Timesheets Client [1 year assignment],[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+senomix08,8059,udp,Senomix Timesheets Client [1 year assignment],[Charles_O_Dale],[Charles_O_Dale],2006-07,,,,,
+,8060,tcp,Reserved,,,,,,,,
+aero,8060,udp,Asymmetric Extended Route Optimization (AERO),[IESG],[IETF_Chair],,,[RFC6706],,,
+,8061-8065,,Unassigned,,,,,,,,
+toad-bi-appsrvr,8066,tcp,Toad BI Application Server,[Quest_Software_2],[Greg_Cottman_3],2013-04-19,,,,,
+,8066,udp,Reserved,,,,,,,,
+,8067-8073,,Unassigned,,,,,,,,
+gadugadu,8074,tcp,Gadu-Gadu,[Marcin_Gozdalik],[Marcin_Gozdalik],2006-05,,,,,
+gadugadu,8074,udp,Gadu-Gadu,[Marcin_Gozdalik],[Marcin_Gozdalik],2006-05,,,,,
+,8075-8079,,Unassigned,,,,,,,,
+http-alt,8080,tcp,HTTP Alternate (see port 80),[Stephen_Casner],[Stephen_Casner],,,,,,
+http-alt,8080,udp,HTTP Alternate (see port 80),[Stephen_Casner],[Stephen_Casner],,,,,,
+sunproxyadmin,8081,tcp,Sun Proxy Admin Service,[Arvind_Srinivasan],[Arvind_Srinivasan],2005-08,,,,,
+sunproxyadmin,8081,udp,Sun Proxy Admin Service,[Arvind_Srinivasan],[Arvind_Srinivasan],2005-08,,,,,
+us-cli,8082,tcp,Utilistor (Client),[Andy_Brewerton],[Andy_Brewerton],2005-08,,,,,
+us-cli,8082,udp,Utilistor (Client),[Andy_Brewerton],[Andy_Brewerton],2005-08,,,,,
+us-srv,8083,tcp,Utilistor (Server),[Andy_Brewerton],[Andy_Brewerton],2005-08,,,,,
+us-srv,8083,udp,Utilistor (Server),[Andy_Brewerton],[Andy_Brewerton],2005-08,,,,,
+,8084-8085,,Unassigned,,,,,,,,
+d-s-n,8086,tcp,Distributed SCADA Networking Rendezvous Port,[Gary_Hampton],[Gary_Hampton],2008-02-27,,,,,
+d-s-n,8086,udp,Distributed SCADA Networking Rendezvous Port,[Gary_Hampton],[Gary_Hampton],2008-02-27,,,,,
+simplifymedia,8087,tcp,Simplify Media SPP Protocol,[Emmanuel_Saint_Loube],[Emmanuel_Saint_Loube],2008-08-08,,,,,
+simplifymedia,8087,udp,Simplify Media SPP Protocol,[Emmanuel_Saint_Loube],[Emmanuel_Saint_Loube],2008-08-08,,,,,
+radan-http,8088,tcp,Radan HTTP,[Steve_Hay],[Steve_Hay],2008-06-13,,,,,
+radan-http,8088,udp,Radan HTTP,[Steve_Hay],[Steve_Hay],2008-06-13,,,,,
+,8089-8090,,Unassigned,,,,,,,,
+jamlink,8091,tcp,Jam Link Framework,[Evgeniy_Filatov],[Evgeniy_Filatov],2009-11-25,,,,,
+,8091,udp,Reserved,,,,,,,,
+,8092-8096,,Unassigned,,,,,,,,
+sac,8097,tcp,SAC Port Id,[Girish_Bhat],[Girish_Bhat],2006-04,,,,,
+sac,8097,udp,SAC Port Id,[Girish_Bhat],[Girish_Bhat],2006-04,,,,,
+,8098-8099,,Unassigned,,,,,,,,
+xprint-server,8100,tcp,Xprint Server,[John_McKernan],[John_McKernan],,,,,,
+xprint-server,8100,udp,Xprint Server,[John_McKernan],[John_McKernan],,,,,,
+ldoms-migr,8101,tcp,Logical Domains Migration,[Liam_Merwick],[Liam_Merwick],2009-01-16,,,,,
+,8101,udp,Reserved,,,,,,,,
+kz-migr,8102,tcp,Oracle Kernel zones migration server,[Oracle_4],[John_Levon],2013-12-24,,,,,
+,8102,udp,Reserved,,,,,,,,
+,8103-8114,,Unassigned,,,,,,,,
+mtl8000-matrix,8115,tcp,MTL8000 Matrix,[David_Pinch],[David_Pinch],2002-04,,,,,
+mtl8000-matrix,8115,udp,MTL8000 Matrix,[David_Pinch],[David_Pinch],2002-04,,,,,
+cp-cluster,8116,tcp,Check Point Clustering,[Roni_Moshitzky],[Roni_Moshitzky],,,,,,
+cp-cluster,8116,udp,Check Point Clustering,[Roni_Moshitzky],[Roni_Moshitzky],,,,,,
+purityrpc,8117,tcp,Purity replication clustering and remote management,[Pure_Storage],[Steve_Hodgson],2013-08-13,,,,,
+,8117,udp,Reserved,,,,,,,,
+privoxy,8118,tcp,Privoxy HTTP proxy,[Andreas_Oesterhelt],[Andreas_Oesterhelt],2002-06,,,,,
+privoxy,8118,udp,Privoxy HTTP proxy,[Andreas_Oesterhelt],[Andreas_Oesterhelt],2002-06,,,,,
+,8119-8120,,Unassigned,,,,,,,,
+apollo-data,8121,tcp,Apollo Data Port,[Anthony_Carrabino],[Anthony_Carrabino],2003-08,,,,,
+apollo-data,8121,udp,Apollo Data Port,[Anthony_Carrabino],[Anthony_Carrabino],2003-08,,,,,
+apollo-admin,8122,tcp,Apollo Admin Port,[Anthony_Carrabino],[Anthony_Carrabino],2003-08,,,,,
+apollo-admin,8122,udp,Apollo Admin Port,[Anthony_Carrabino],[Anthony_Carrabino],2003-08,,,,,
+,8123-8127,,Unassigned,,,,,,,,
+paycash-online,8128,tcp,PayCash Online Protocol,[MegaZone],[MegaZone],2005-08,,,,,
+paycash-online,8128,udp,PayCash Online Protocol,[MegaZone],[MegaZone],2005-08,,,,,
+paycash-wbp,8129,tcp,PayCash Wallet-Browser,[MegaZone],[MegaZone],2005-08,,,,,
+paycash-wbp,8129,udp,PayCash Wallet-Browser,[MegaZone],[MegaZone],2005-08,,,,,
+indigo-vrmi,8130,tcp,INDIGO-VRMI,[Colin_Caughie],[Colin_Caughie],,,,,,
+indigo-vrmi,8130,udp,INDIGO-VRMI,[Colin_Caughie],[Colin_Caughie],,,,,,
+indigo-vbcp,8131,tcp,INDIGO-VBCP,[Colin_Caughie],[Colin_Caughie],,,,,,
+indigo-vbcp,8131,udp,INDIGO-VBCP,[Colin_Caughie],[Colin_Caughie],,,,,,
+dbabble,8132,tcp,dbabble,[Chris_Pugmire],[Chris_Pugmire],,,,,,
+dbabble,8132,udp,dbabble,[Chris_Pugmire],[Chris_Pugmire],,,,,,
+,8133-8139,,Unassigned,,,,,,,,
+puppet,8140,tcp,The Puppet master service,[Puppet_Labs],[Zach_Leslie],2014-09-18,,,,,
+,8140,udp,Reserved,,,,,,,,
+,8141-8147,,Unassigned,,,,,,,,
+isdd,8148,tcp,i-SDD file transfer,[Frank_Waarsenburg],[Frank_Waarsenburg],2004-11,,,,,
+isdd,8148,udp,i-SDD file transfer,[Frank_Waarsenburg],[Frank_Waarsenburg],2004-11,,,,,
+,8149,tcp,Reserved,,,,,,,,
+eor-game,8149,udp,Edge of Reality game data,[Sky_Schulz],[Sky_Schulz],2011-05-09,,,,,
+,8150-8152,,Unassigned,,,,,,,,
+quantastor,8153,tcp,QuantaStor Management Interface,[OS_NEXUS],[Steven_Umbehocker],2012-09-21,,,,,
+,8153,udp,Reserved,,,,,,,,
+,8154-8159,,Unassigned,,,,,,,,
+patrol,8160,tcp,Patrol,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+patrol,8160,udp,Patrol,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+patrol-snmp,8161,tcp,Patrol SNMP,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+patrol-snmp,8161,udp,Patrol SNMP,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+lpar2rrd,8162,tcp,LPAR2RRD client server communication,[LPAR2RRD_project],[Pavel_Hampl],2013-08-14,,,,,
+,8162,udp,Reserved,,,,,,,,
+,8163-8180,,Unassigned,,,,,,,,
+intermapper,8181,tcp,Intermapper network management system,[William_Fisher],[William_Fisher],2011-05-09,,,,,
+,8181,udp,Reserved,,,,,,,,
+vmware-fdm,8182,tcp,VMware Fault Domain Manager,[Ron_Passerini],[Ron_Passerini],2010-04-27,,,,,
+vmware-fdm,8182,udp,VMware Fault Domain Manager,[Ron_Passerini],[Ron_Passerini],2010-04-27,,,,,
+proremote,8183,tcp,ProRemote,[Alex_Lelievre],[Alex_Lelievre],2009-08-18,,,,,
+,8183,udp,Reserved,,,,,,,,
+itach,8184,tcp,Remote iTach Connection,[Barend_Jacobus_van_d],[Barend_Jacobus_van_d],2010-04-27,,,,,
+itach,8184,udp,Remote iTach Connection,[Barend_Jacobus_van_d],[Barend_Jacobus_van_d],2010-04-27,,,,,
+,8185-8190,,Unassigned,,,,,,,,
+limnerpressure,8191,tcp,Limner Pressure,[Aaron_Kleinsteiber],[Aaron_Kleinsteiber],2014-01-16,,,,,
+,8191,udp,Reserved,,,,,,,,
+spytechphone,8192,tcp,SpyTech Phone Service,[Bill_Kay],[Bill_Kay],2006-04,,,,,
+spytechphone,8192,udp,SpyTech Phone Service,[Bill_Kay],[Bill_Kay],2006-04,,,,,
+,8193,,Unassigned,,,,,,,,
+blp1,8194,tcp,Bloomberg data API,[Albert_Hou],[Albert_Hou],2006-05,,,,,
+blp1,8194,udp,Bloomberg data API,[Albert_Hou],[Albert_Hou],2006-05,,,,,
+blp2,8195,tcp,Bloomberg feed,[Albert_Hou],[Albert_Hou],2006-05,,,,,
+blp2,8195,udp,Bloomberg feed,[Albert_Hou],[Albert_Hou],2006-05,,,,,
+,8196-8198,,Unassigned,,,,,,,,
+vvr-data,8199,tcp,VVR DATA,[Ming_Xu],[Ming_Xu],,,,,,
+vvr-data,8199,udp,VVR DATA,[Ming_Xu],[Ming_Xu],,,,,,
+trivnet1,8200,tcp,TRIVNET,[Saar_Wilf],[Saar_Wilf],,,,,,
+trivnet1,8200,udp,TRIVNET,[Saar_Wilf],[Saar_Wilf],,,,,,
+trivnet2,8201,tcp,TRIVNET,[Saar_Wilf],[Saar_Wilf],,,,,,
+trivnet2,8201,udp,TRIVNET,[Saar_Wilf],[Saar_Wilf],,,,,,
+,8202,tcp,Reserved,,,,,,,,
+aesop,8202,udp,Audio+Ethernet Standard Open Protocol,[POWERSOFT_SRL],[Paolo_Desii][Claudio_Lastrucci],2012-01-03,,,,,
+,8203-8203,,Unassigned,,,,,,,,
+lm-perfworks,8204,tcp,LM Perfworks,[Chris_Flynn],[Chris_Flynn],,,,,,
+lm-perfworks,8204,udp,LM Perfworks,[Chris_Flynn],[Chris_Flynn],,,,,,
+lm-instmgr,8205,tcp,LM Instmgr,[Chris_Flynn],[Chris_Flynn],,,,,,
+lm-instmgr,8205,udp,LM Instmgr,[Chris_Flynn],[Chris_Flynn],,,,,,
+lm-dta,8206,tcp,LM Dta,[Chris_Flynn],[Chris_Flynn],,,,,,
+lm-dta,8206,udp,LM Dta,[Chris_Flynn],[Chris_Flynn],,,,,,
+lm-sserver,8207,tcp,LM SServer,[Chris_Flynn],[Chris_Flynn],,,,,,
+lm-sserver,8207,udp,LM SServer,[Chris_Flynn],[Chris_Flynn],,,,,,
+lm-webwatcher,8208,tcp,LM Webwatcher,[Chris_Flynn],[Chris_Flynn],,,,,,
+lm-webwatcher,8208,udp,LM Webwatcher,[Chris_Flynn],[Chris_Flynn],,,,,,
+,8209-8229,,Unassigned,,,,,,,,
+rexecj,8230,tcp,RexecJ Server,[Curtiss_Howard],[Curtiss_Howard],2004-11,,,,,
+rexecj,8230,udp,RexecJ Server,[Curtiss_Howard],[Curtiss_Howard],2004-11,,,,,
+,8231-8242,,Unassigned,,,,,,,,
+synapse-nhttps,8243,tcp,Synapse Non Blocking HTTPS,[Ruwan_Linton],[Ruwan_Linton],2008-07-10,,,,,
+synapse-nhttps,8243,udp,Synapse Non Blocking HTTPS,[Ruwan_Linton],[Ruwan_Linton],2008-07-10,,,,,
+,8244-8275,,Unassigned,,,,,,,,
+pando-sec,8276,tcp,Pando Media Controlled Distribution,[Laird_Popkin],[Laird_Popkin],2008-02-27,,,,,
+pando-sec,8276,udp,Pando Media Controlled Distribution,[Laird_Popkin],[Laird_Popkin],2008-02-27,,,,,
+,8277-8279,,Unassigned,,,,,,,,
+synapse-nhttp,8280,tcp,Synapse Non Blocking HTTP,[Ruwan_Linton],[Ruwan_Linton],2008-06-05,,,,,
+synapse-nhttp,8280,udp,Synapse Non Blocking HTTP,[Ruwan_Linton],[Ruwan_Linton],2008-06-05,,,,,
+,8281-8291,,Unassigned,,,,,,,,
+blp3,8292,tcp,Bloomberg professional,[Albert_Hou],[Albert_Hou],2006-05,,,,,
+blp3,8292,udp,Bloomberg professional,[Albert_Hou],[Albert_Hou],2006-05,,,,,
+hiperscan-id,8293,tcp,Hiperscan Identification Service,[Thomas_Klose],[Thomas_Klose],2009-12-15,,,,,
+,8293,udp,Reserved,,,,,,,,
+blp4,8294,tcp,Bloomberg intelligent client,[Albert_Hou],[Albert_Hou],2006-05,,,,,
+blp4,8294,udp,Bloomberg intelligent client,[Albert_Hou],[Albert_Hou],2006-05,,,,,
+,8295-8299,,Unassigned,,,,,,,,
+tmi,8300,tcp,Transport Management Interface,[Steve_Kneizys],[Steve_Kneizys],2006-11,,,,,
+tmi,8300,udp,Transport Management Interface,[Steve_Kneizys],[Steve_Kneizys],2006-11,,,,,
+amberon,8301,tcp,Amberon PPC/PPS,[Ronald_Snyder],[Ronald_Snyder],2006-03,,,,,
+amberon,8301,udp,Amberon PPC/PPS,[Ronald_Snyder],[Ronald_Snyder],2006-03,,,,,
+,8302-8312,,Unassigned,,,,,,,,
+hub-open-net,8313,tcp,Hub Open Network,[Grexie],[Tim_Behrsin],2012-06-13,,,,,Defined TXT keys: _hub._tcp.host.example.com
+,8313,udp,Reserved,,,,,,,,
+,8314-8319,,Unassigned,,,,,,,,
+tnp-discover,8320,tcp,Thin(ium) Network Protocol,[Aly_Orady],[Aly_Orady],2007-08-07,,,,,
+tnp-discover,8320,udp,Thin(ium) Network Protocol,[Aly_Orady],[Aly_Orady],2007-08-07,,,,,
+tnp,8321,tcp,Thin(ium) Network Protocol,[Aly_Orady],[Aly_Orady],2007-08-07,,,,,
+tnp,8321,udp,Thin(ium) Network Protocol,[Aly_Orady],[Aly_Orady],2007-08-07,,,,,
+,8322-8350,,Unassigned,,,,,,,,
+server-find,8351,tcp,Server Find,[Chris_Brown],[Chris_Brown],,,,,,
+server-find,8351,udp,Server Find,[Chris_Brown],[Chris_Brown],,,,,,
+,8352-8375,,Unassigned,,,,,,,,
+cruise-enum,8376,tcp,Cruise ENUM,[Steve_Husak],[Steve_Husak],,,,,,
+cruise-enum,8376,udp,Cruise ENUM,[Steve_Husak],[Steve_Husak],,,,,,
+cruise-swroute,8377,tcp,Cruise SWROUTE,[Steve_Husak],[Steve_Husak],,,,,,
+cruise-swroute,8377,udp,Cruise SWROUTE,[Steve_Husak],[Steve_Husak],,,,,,
+cruise-config,8378,tcp,Cruise CONFIG,[Steve_Husak],[Steve_Husak],,,,,,
+cruise-config,8378,udp,Cruise CONFIG,[Steve_Husak],[Steve_Husak],,,,,,
+cruise-diags,8379,tcp,Cruise DIAGS,[Steve_Husak],[Steve_Husak],,,,,,
+cruise-diags,8379,udp,Cruise DIAGS,[Steve_Husak],[Steve_Husak],,,,,,
+cruise-update,8380,tcp,Cruise UPDATE,[Steve_Husak],[Steve_Husak],,,,,,
+cruise-update,8380,udp,Cruise UPDATE,[Steve_Husak],[Steve_Husak],,,,,,
+,8381-8382,,Unassigned,,,,,,,,
+m2mservices,8383,tcp,M2m Services,[Carlos_Arteaga_2],[Carlos_Arteaga_2],2004-11,,,,,
+m2mservices,8383,udp,M2m Services,[Carlos_Arteaga_2],[Carlos_Arteaga_2],2004-11,,,,,
+,8384-8399,,Unassigned,,,,,,,,
+cvd,8400,tcp,cvd,[Aaron_Bilbrey],[Aaron_Bilbrey],,,,,,
+cvd,8400,udp,cvd,[Aaron_Bilbrey],[Aaron_Bilbrey],,,,,,
+sabarsd,8401,tcp,sabarsd,[Aaron_Bilbrey],[Aaron_Bilbrey],,,,,,
+sabarsd,8401,udp,sabarsd,[Aaron_Bilbrey],[Aaron_Bilbrey],,,,,,
+abarsd,8402,tcp,abarsd,[Aaron_Bilbrey],[Aaron_Bilbrey],,,,,,
+abarsd,8402,udp,abarsd,[Aaron_Bilbrey],[Aaron_Bilbrey],,,,,,
+admind,8403,tcp,admind,[Aaron_Bilbrey],[Aaron_Bilbrey],,,,,,
+admind,8403,udp,admind,[Aaron_Bilbrey],[Aaron_Bilbrey],,,,,,
+svcloud,8404,tcp,SuperVault Cloud,[Nine_Technology_LLC],[Alex_Stoev],2009-09-14,2011-08-01,,,,
+,8404,udp,Reserved,,,,,,,,
+svbackup,8405,tcp,SuperVault Backup,[Nine_Technology_LLC],[Alex_Stoev],2009-09-14,2011-08-01,,,,
+,8405,udp,Reserved,,,,,,,,
+,8406-8414,,Unassigned,,,,,,,,
+dlpx-sp,8415,tcp,Delphix Session Protocol,[Delphix_Corp],[Peng_Dai],2012-11-01,,,,,
+,8415,udp,Reserved,,,,,,,,
+espeech,8416,tcp,eSpeech Session Protocol,[Scott_Tarone],[Scott_Tarone],2002-11,,,,,
+espeech,8416,udp,eSpeech Session Protocol,[Scott_Tarone],[Scott_Tarone],2002-11,,,,,
+espeech-rtp,8417,tcp,eSpeech RTP Protocol,[Scott_Tarone],[Scott_Tarone],2003-04,,,,,
+espeech-rtp,8417,udp,eSpeech RTP Protocol,[Scott_Tarone],[Scott_Tarone],2003-04,,,,,
+,8418-8441,,Unassigned,,,,,,,,
+cybro-a-bus,8442,tcp,CyBro A-bus Protocol,[Damir_Skrjanec],[Damir_Skrjanec],2007-05,,,,,
+cybro-a-bus,8442,udp,CyBro A-bus Protocol,[Damir_Skrjanec],[Damir_Skrjanec],2007-05,,,,,
+pcsync-https,8443,tcp,PCsync HTTPS,,,,,,,,
+pcsync-https,8443,udp,PCsync HTTPS,,,,,,,,
+pcsync-http,8444,tcp,PCsync HTTP,[Katy_Lynn_McCullough],[Katy_Lynn_McCullough],,,,,,
+pcsync-http,8444,udp,PCsync HTTP,[Katy_Lynn_McCullough],[Katy_Lynn_McCullough],,,,,,
+copy,8445,tcp,Port for copy peer sync feature,[Copy],[Jason_Dictos],2012-09-19,,,,,
+copy-disc,8445,udp,Port for copy discovery,[Copy],[Jason_Dictos],2012-09-19,,,,,
+,8446-8449,,Unassigned,,,,,,,,
+npmp,8450,tcp,npmp,[Ian_Chard],[Ian_Chard],,,,,,
+npmp,8450,udp,npmp,[Ian_Chard],[Ian_Chard],,,,,,
+,8451-8456,,Unassigned,,,,,,,,
+nexentamv,8457,tcp,Nexenta Management GUI,[Nexenta],[Andrew_Galloway],2012-12-07,,,,,
+,8457,udp,Reserved,,,,,,,,
+,8458-8469,,Unassigned,,,,,,,,
+cisco-avp,8470,tcp,Cisco Address Validation Protocol,[Cullen_Jennings],[Cullen_Jennings],2009-02-13,,,,,
+,8470,udp,Reserved,,,,,,,,
+pim-port,8471,tcp,PIM over Reliable Transport,[IESG],[IETF_Chair],2008-08-21,,[RFC6559],,,
+pim-port,8471,sctp,PIM over Reliable Transport,[IESG],[IETF_Chair],2008-08-21,,[RFC6559],,,
+,8471,udp,Reserved,,,,,,,,
+otv,8472,tcp,Overlay Transport Virtualization (OTV),[Dino_Farinacci],[Dino_Farinacci],2008-01-07,,,,,
+otv,8472,udp,Overlay Transport Virtualization (OTV),[Dino_Farinacci],[Dino_Farinacci],2008-01-07,,,,,
+vp2p,8473,tcp,Virtual Point to Point,[Jerome_Grimbert],[Jerome_Grimbert],,,,,,
+vp2p,8473,udp,Virtual Point to Point,[Jerome_Grimbert],[Jerome_Grimbert],,,,,,
+noteshare,8474,tcp,AquaMinds NoteShare,[Michael_McNabb],[Michael_McNabb],2005-10,,,,,
+noteshare,8474,udp,AquaMinds NoteShare,[Michael_McNabb],[Michael_McNabb],2005-10,,,,,
+,8475-8499,,Unassigned,,,,,,,,
+fmtp,8500,tcp,Flight Message Transfer Protocol,[Eivan_Cerasi],[Eivan_Cerasi],2003-12,,,,,
+fmtp,8500,udp,Flight Message Transfer Protocol,[Eivan_Cerasi],[Eivan_Cerasi],2003-12,,,,,
+cmtp-mgt,8501,tcp,CYTEL Message Transfer Management,,,,,,,,
+cmtp-av,8501,udp,CYTEL Message Transfer Audio and Video,[Frank_Jakel],[Frank_Jakel],2011-04-29,,,,,
+ftnmtp,8502,tcp,FTN Message Transfer Protocol,[Yuri_Myakotin],[Yuri_Myakotin],2014-01-07,,,,,
+,8502,udp,Reserved,,,,,,,,
+,8503-8553,,Unassigned,,,,,,,,
+rtsp-alt,8554,tcp,RTSP Alternate (see port 554),[Stephen_Casner_2],[Stephen_Casner_2],,,,,,
+rtsp-alt,8554,udp,RTSP Alternate (see port 554),[Stephen_Casner_2],[Stephen_Casner_2],,,,,,
+d-fence,8555,tcp,SYMAX D-FENCE,[Thomas_Geisel],[Thomas_Geisel],2003-01,,,,,
+d-fence,8555,udp,SYMAX D-FENCE,[Thomas_Geisel],[Thomas_Geisel],2003-01,,,,,
+,8556-8566,,Unassigned,,,,,,,,
+enc-tunnel,8567,tcp,EMIT tunneling protocol,[Panasonic_Intranet_Panasonic_North_America_PEWLA],[Bryant_Eastham],2005-08,2012-11-12,,,,
+enc-tunnel,8567,udp,EMIT tunneling protocol,[Panasonic_Intranet_Panasonic_North_America_PEWLA],[Bryant_Eastham],2005-08,2012-11-12,,,,
+,8568-8599,,Unassigned,,,,,,,,
+asterix,8600,tcp,Surveillance Data,[Eivan_Cerasi],[Eivan_Cerasi],2005-11,,,,,
+asterix,8600,udp,Surveillance Data,[Eivan_Cerasi],[Eivan_Cerasi],2005-11,,,,,
+,8601-8608,,Unassigned,,,,,,,,
+,8609,tcp,Reserved,,,,,,,,
+canon-cpp-disc,8609,udp,Canon Compact Printer Protocol Discovery,[Canon_Inc],[Ryusuke_Okuhara],2012-06-08,2012-06-15,,,,
+canon-mfnp,8610,tcp,Canon MFNP Service,[Ritsuto_Sako],[Ritsuto_Sako],2009-05-04,,,,,
+canon-mfnp,8610,udp,Canon MFNP Service,[Ritsuto_Sako],[Ritsuto_Sako],2009-05-04,,,,,
+canon-bjnp1,8611,tcp,Canon BJNP Port 1,[Atsushi_Nakamura],[Atsushi_Nakamura],2003-11,,,,,
+canon-bjnp1,8611,udp,Canon BJNP Port 1,[Atsushi_Nakamura],[Atsushi_Nakamura],2003-11,,,,,
+canon-bjnp2,8612,tcp,Canon BJNP Port 2,[Atsushi_Nakamura],[Atsushi_Nakamura],2003-11,,,,,
+canon-bjnp2,8612,udp,Canon BJNP Port 2,[Atsushi_Nakamura],[Atsushi_Nakamura],2003-11,,,,,
+canon-bjnp3,8613,tcp,Canon BJNP Port 3,[Atsushi_Nakamura],[Atsushi_Nakamura],2003-11,,,,,
+canon-bjnp3,8613,udp,Canon BJNP Port 3,[Atsushi_Nakamura],[Atsushi_Nakamura],2003-11,,,,,
+canon-bjnp4,8614,tcp,Canon BJNP Port 4,[Atsushi_Nakamura],[Atsushi_Nakamura],2003-11,,,,,
+canon-bjnp4,8614,udp,Canon BJNP Port 4,[Atsushi_Nakamura],[Atsushi_Nakamura],2003-11,,,,,
+imink,8615,tcp,Imink Service Control,[Canon_Inc],[KEN_ICHI_FUJII],2011-10-10,,,,,
+,8615,udp,Reserved,,,,,,,,
+,8616-8664,,Unassigned,,,,,,,Unauthorized Use Known on ports 8616 and 8617,
+monetra,8665,tcp,Monetra,[Main_Street_Softworks],[Brad_House],2013-04-02,,,,,
+,8665,udp,Reserved,,,,,,,,
+monetra-admin,8666,tcp,Monetra Administrative Access,[Main_Street_Softworks],[Brad_House],2013-04-02,,,,,
+,8666,udp,Reserved,,,,,,,,
+,8667-8674,,Unassigned,,,,,,,,
+msi-cps-rm,8675,tcp,Motorola Solutions Customer Programming Software for Radio Management,[Motorola_Solutions_Inc],[Jenish_Amin],2012-03-14,,,,,
+msi-cps-rm-disc,8675,udp,Motorola Solutions Customer Programming Software for Radio Management Discovery,[Motorola_Solutions_Inc],[Jenish_Amin],2012-03-14,,,,,
+,8676-8685,,Unassigned,,,,,,,,
+sun-as-jmxrmi,8686,tcp,Sun App Server - JMX/RMI,[Abhijit_Kumar],[Abhijit_Kumar],2005-11,,,,,
+sun-as-jmxrmi,8686,udp,Sun App Server - JMX/RMI,[Abhijit_Kumar],[Abhijit_Kumar],2005-11,,,,,
+,8687,,Unassigned,,,,,,,,
+openremote-ctrl,8688,tcp,OpenRemote Controller HTTP/REST,[OpenRemote_Inc],[Juha_Lindfors],2012-12-18,,,,,
+,8688,udp,Reserved,,,,,,,,
+,8689-8698,,Unassigned,,,,,,,,
+vnyx,8699,tcp,VNYX Primary Port,[Gregg_Green],[Gregg_Green],2004-11,,,,,
+,8699,udp,Reserved,,,2004-11,2013-05-24,,,,This entry is being removed on 2013-05-24.
+,8700-8710,,Unassigned,,,,,,,,
+nvc,8711,tcp,Nuance Voice Control,[Nuance_Communications_Inc2],[Diego_Negre],2012-10-05,,,,,
+,8711,udp,Reserved,,,,,,,,
+,8712-8731,,Unassigned,,,,,,,,
+,8732,tcp,Reserved,,,,,,,,
+dtp-net,8732,udp,DASGIP Net Services,[Dr_Matthias_Arnold],[Dr_Matthias_Arnold],2009-03-23,,,,,
+ibus,8733,tcp,iBus,[Silvano_Maffeis],[Silvano_Maffeis],,,,,,
+ibus,8733,udp,iBus,[Silvano_Maffeis],[Silvano_Maffeis],,,,,,
+,8734-8749,,Unassigned,,,,,,,,
+dey-keyneg,8750,tcp,DEY Storage Key Negotiation,[DEY_Storage_Systems_Inc],[Garrett_D_Amore],2013-03-01,,,,,
+,8750,udp,Reserved,,,,,,,,
+,8751-8762,,Unassigned,,,,,,,,
+mc-appserver,8763,tcp,MC-APPSERVER,[Romeo_Kasanwidjojo],[Romeo_Kasanwidjojo],,,,,,
+mc-appserver,8763,udp,MC-APPSERVER,[Romeo_Kasanwidjojo],[Romeo_Kasanwidjojo],,,,,,
+openqueue,8764,tcp,OPENQUEUE,[Matt_Jensen],[Matt_Jensen],,,,,,
+openqueue,8764,udp,OPENQUEUE,[Matt_Jensen],[Matt_Jensen],,,,,,
+ultraseek-http,8765,tcp,Ultraseek HTTP,[Walter_Underwood],[Walter_Underwood],,,,,,
+ultraseek-http,8765,udp,Ultraseek HTTP,[Walter_Underwood],[Walter_Underwood],,,,,,
+amcs,8766,tcp,Agilent Connectivity Service,[Agilent_Technologies_Inc],[Tom_Fay],2013-01-16,,,,,
+amcs,8766,udp,Agilent Connectivity Service,[Agilent_Technologies_Inc],[Tom_Fay],2013-01-16,,,,,
+,8767-8769,,Unassigned,,,,,,,,
+dpap,8770,tcp,Digital Photo Access Protocol (iPhoto),[Amandeep_Jawa_2],[Amandeep_Jawa_2],2004-11,,,,,"Defined TXT keys: txtvers, Version, iPSh Version, Machine ID, Machine Name, Password"
+dpap,8770,udp,Digital Photo Access Protocol (iPhoto),[Amandeep_Jawa_2],[Amandeep_Jawa_2],2004-11,,,,,"Defined TXT keys: txtvers, Version, iPSh Version, Machine ID, Machine Name, Password"
+,8771-8777,,Unassigned,,,,,,,,
+uec,8778,tcp,Stonebranch Universal Enterprise Controller,[Stonebranch_Inc],[Nathan_Hammond_2],2013-06-25,,,,,
+,8778,udp,Reserved,,,,,,,,
+,8779-8785,,Unassigned,,,,,,,,
+msgclnt,8786,tcp,Message Client,,,,,,,,
+msgclnt,8786,udp,Message Client,,,,,,,,
+msgsrvr,8787,tcp,Message Server,[Michael_O_Brien],[Michael_O_Brien],2003-03,,,,,
+msgsrvr,8787,udp,Message Server,[Michael_O_Brien],[Michael_O_Brien],2003-03,,,,,
+,8788-8792,,Unassigned,,,,,,,,
+acd-pm,8793,tcp,Accedian Performance Measurement,[Marco_Mascitto],[Marco_Mascitto],,,,,,
+acd-pm,8793,udp,Accedian Performance Measurement,[Marco_Mascitto],[Marco_Mascitto],,,,,,
+,8794-8799,,Unassigned,,,,,,,,
+sunwebadmin,8800,tcp,Sun Web Server Admin Service,[Jyri_J_Virkki],[Jyri_J_Virkki],2005-12,,,,,
+sunwebadmin,8800,udp,Sun Web Server Admin Service,[Jyri_J_Virkki],[Jyri_J_Virkki],2005-12,,,,,
+,8801-8803,,Unassigned,,,,,,,Known UNAUTHORIZED USE: Port 8801,
+truecm,8804,tcp,truecm,[Scott_Kramer],[Scott_Kramer],,,,,,
+truecm,8804,udp,truecm,[Scott_Kramer],[Scott_Kramer],,,,,,
+,8805-8872,,Unassigned,,,,,,,,
+dxspider,8873,tcp,dxspider linking protocol,[Dirk_Koopman],[Dirk_Koopman],2005-08,,,,,
+dxspider,8873,udp,dxspider linking protocol,[Dirk_Koopman],[Dirk_Koopman],2005-08,,,,,
+,8874-8879,,Unassigned,,,,,,,,
+cddbp-alt,8880,tcp,CDDBP,[Steve_Scherf],[Steve_Scherf],,,,,,
+cddbp-alt,8880,udp,CDDBP,[Steve_Scherf],[Steve_Scherf],,,,,,
+galaxy4d,8881,tcp,Galaxy4D Online Game Engine,[Galaxy4D],[Olivier_St-Laurent],2012-06-18,,,,,
+,8881,udp,Reserved,,,,,,,,
+,8882,,Unassigned,,,,,,,Unauthorized Use Known on port 8882,
+secure-mqtt,8883,tcp,Secure MQTT,[Arthur_Barr],[Arthur_Barr],2008-02-27,,,,,
+secure-mqtt,8883,udp,Secure MQTT,[Arthur_Barr],[Arthur_Barr],2008-02-27,,,,,
+,8884-8887,,Unassigned,,,,,,,,
+ddi-tcp-1,8888,tcp,NewsEDGE server TCP (TCP 1),[Fred_Yao],[Fred_Yao],,,,,Known Unauthorized Use on port 8888,
+ddi-udp-1,8888,udp,NewsEDGE server UDP (UDP 1),[Fred_Yao],[Fred_Yao],,,,,Known Unauthorized Use on port 8888,
+ddi-tcp-2,8889,tcp,Desktop Data TCP 1,[Fred_Yao],[Fred_Yao],,,,,Known Unauthorized Use on port 8889,
+ddi-udp-2,8889,udp,NewsEDGE server broadcast,[Fred_Yao],[Fred_Yao],,,,,Known Unauthorized Use on port 8889,
+ddi-tcp-3,8890,tcp,Desktop Data TCP 2,[Fred_Yao],[Fred_Yao],,,,,Known Unauthorized Use on port 8890,
+ddi-udp-3,8890,udp,NewsEDGE client broadcast,[Fred_Yao],[Fred_Yao],,,,,Known Unauthorized Use on port 8890,
+ddi-tcp-4,8891,tcp,Desktop Data TCP 3: NESS application,[Fred_Yao],[Fred_Yao],,,,,,
+ddi-udp-4,8891,udp,Desktop Data UDP 3: NESS application,[Fred_Yao],[Fred_Yao],,,,,,
+ddi-tcp-5,8892,tcp,Desktop Data TCP 4: FARM product,[Fred_Yao],[Fred_Yao],,,,,,
+ddi-udp-5,8892,udp,Desktop Data UDP 4: FARM product,[Fred_Yao],[Fred_Yao],,,,,,
+ddi-tcp-6,8893,tcp,Desktop Data TCP 5: NewsEDGE/Web application,[Fred_Yao],[Fred_Yao],,,,,,
+ddi-udp-6,8893,udp,Desktop Data UDP 5: NewsEDGE/Web application,[Fred_Yao],[Fred_Yao],,,,,,
+ddi-tcp-7,8894,tcp,Desktop Data TCP 6: COAL application,[Fred_Yao],[Fred_Yao],,,,,,
+ddi-udp-7,8894,udp,Desktop Data UDP 6: COAL application,[Fred_Yao],[Fred_Yao],,,,,,
+,8895-8898,,Unassigned,,,,,,,,
+ospf-lite,8899,tcp,ospf-lite,[Matthew_Thomas],[Matthew_Thomas],2008-01-07,,,,,
+ospf-lite,8899,udp,ospf-lite,[Matthew_Thomas],[Matthew_Thomas],2008-01-07,,,,,
+jmb-cds1,8900,tcp,JMB-CDS 1,[Curtis_Bray],[Curtis_Bray],,,,,,
+jmb-cds1,8900,udp,JMB-CDS 1,[Curtis_Bray],[Curtis_Bray],,,,,,
+jmb-cds2,8901,tcp,JMB-CDS 2,[Curtis_Bray],[Curtis_Bray],,,,,,
+jmb-cds2,8901,udp,JMB-CDS 2,[Curtis_Bray],[Curtis_Bray],,,,,,
+,8902-8909,,Unassigned,,,,,,,,
+manyone-http,8910,tcp,manyone-http,[Matt_King],[Matt_King],2002-04,,,,,
+manyone-http,8910,udp,manyone-http,[Matt_King],[Matt_King],2002-04,,,,,
+manyone-xml,8911,tcp,manyone-xml,[Matt_King],[Matt_King],2002-04,,,,,
+manyone-xml,8911,udp,manyone-xml,[Matt_King],[Matt_King],2002-04,,,,,
+wcbackup,8912,tcp,Windows Client Backup,[Jim_Lyon],[Jim_Lyon],2005-11,,,,,
+wcbackup,8912,udp,Windows Client Backup,[Jim_Lyon],[Jim_Lyon],2005-11,,,,,
+dragonfly,8913,tcp,Dragonfly System Service,[Paul_Hodara],[Paul_Hodara],2005-11,,,,,
+dragonfly,8913,udp,Dragonfly System Service,[Paul_Hodara],[Paul_Hodara],2005-11,,,,,
+,8914-8936,,Unassigned,,,,,,,,
+twds,8937,tcp,Transaction Warehouse Data Service,[Lance_M_Steenson],[Lance_M_Steenson],2009-09-18,,,,,
+,8937,udp,Reserved,,,,,,,,
+,8938-8952,,Unassigned,,,,,,,,
+ub-dns-control,8953,tcp,unbound dns nameserver control,[NLnet_Labs_Support],[NLnet_Labs_Support],2011-05-10,2011-07-11,,,,
+,8953,udp,Reserved,,,,,,,,
+cumulus-admin,8954,tcp,Cumulus Admin Port,[Thomas_Schleu],[Thomas_Schleu],,,,,,
+cumulus-admin,8954,udp,Cumulus Admin Port,[Thomas_Schleu],[Thomas_Schleu],,,,,,
+,8955-8988,,Unassigned,,,,,,,,
+sunwebadmins,8989,tcp,Sun Web Server SSL Admin Service,[Jyri_J_Virkki],[Jyri_J_Virkki],2005-12,,,,,
+sunwebadmins,8989,udp,Sun Web Server SSL Admin Service,[Jyri_J_Virkki],[Jyri_J_Virkki],2005-12,,,,,
+http-wmap,8990,tcp,webmail HTTP service,[Fred_Batty],[Fred_Batty],2007-12-03,,,,,
+http-wmap,8990,udp,webmail HTTP service,[Fred_Batty],[Fred_Batty],2007-12-03,,,,,
+https-wmap,8991,tcp,webmail HTTPS service,[Fred_Batty],[Fred_Batty],2007-12-03,,,,,
+https-wmap,8991,udp,webmail HTTPS service,[Fred_Batty],[Fred_Batty],2007-12-03,,,,,
+,8992-8997,,Unassigned,,,,,,,,
+canto-roboflow,8998,tcp,Canto RoboFlow Control,[Canto],[Thomas_Schleu_2],2014-02-26,,,,,
+,8998,udp,Reserved,,,,,,,,
+bctp,8999,tcp,Brodos Crypto Trade Protocol,[Alexander_Sahler],[Alexander_Sahler],2002-02,,,,,
+bctp,8999,udp,Brodos Crypto Trade Protocol,[Alexander_Sahler],[Alexander_Sahler],2002-02,,,,,
+cslistener,9000,tcp,CSlistener,[David_Jones],[David_Jones],,,,,,
+cslistener,9000,udp,CSlistener,[David_Jones],[David_Jones],,,,,,
+etlservicemgr,9001,tcp,ETL Service Manager,[Stephen_McCrea],[Stephen_McCrea],2002-03,,,,Known Unauthorized Use on port 9001,
+etlservicemgr,9001,udp,ETL Service Manager,[Stephen_McCrea],[Stephen_McCrea],2002-03,,,,Known Unauthorized Use on port 9001,
+dynamid,9002,tcp,DynamID authentication,[Jerome_Dusautois],[Jerome_Dusautois],2002-03,,,,,
+dynamid,9002,udp,DynamID authentication,[Jerome_Dusautois],[Jerome_Dusautois],2002-03,,,,,
+,9003-9005,,Unassigned,,,,,,,,
+,9006,,De-Commissioned Port,,,2000-02-24,,,,,
+,9007,tcp,Reserved,,,,,,,,
+ogs-client,9007,udp,Open Grid Services Client,[Gareth_Nelson_2],[Gareth_Nelson_2],2008-08-22,,,,,
+ogs-server,9008,tcp,Open Grid Services Server,[Gareth_Nelson_2],[Gareth_Nelson_2],2008-08-22,,,,,
+,9008,udp,Reserved,,,,,,,,
+pichat,9009,tcp,Pichat Server,[Mark_Seuffert],[Mark_Seuffert],2004-11,,,,,
+pichat,9009,udp,Pichat Server,[Mark_Seuffert],[Mark_Seuffert],2004-11,,,,,
+sdr,9010,tcp,Secure Data Replicator Protocol,[Sufyan_Almajali],[Sufyan_Almajali],2008-06-27,,,,,
+,9010,udp,Reserved,,,,,,,,
+,9011-9019,,Unassigned,,,,,,,,
+tambora,9020,tcp,TAMBORA,[Jason_van_Zyl],[Jason_van_Zyl],2002-03,,,,,
+tambora,9020,udp,TAMBORA,[Jason_van_Zyl],[Jason_van_Zyl],2002-03,,,,,
+panagolin-ident,9021,tcp,Pangolin Identification,[William_Benner_2],[William_Benner_2],2002-03,,,,,
+panagolin-ident,9021,udp,Pangolin Identification,[William_Benner_2],[William_Benner_2],2002-03,,,,,
+paragent,9022,tcp,PrivateArk Remote Agent,[Gal_Cucuy],[Gal_Cucuy],2002-03,,,,,
+paragent,9022,udp,PrivateArk Remote Agent,[Gal_Cucuy],[Gal_Cucuy],2002-03,,,,,
+swa-1,9023,tcp,Secure Web Access - 1,[Tim_McGranaghan],[Tim_McGranaghan],,,,,,
+swa-1,9023,udp,Secure Web Access - 1,[Tim_McGranaghan],[Tim_McGranaghan],,,,,,
+swa-2,9024,tcp,Secure Web Access - 2,[Tim_McGranaghan],[Tim_McGranaghan],,,,,,
+swa-2,9024,udp,Secure Web Access - 2,[Tim_McGranaghan],[Tim_McGranaghan],,,,,,
+swa-3,9025,tcp,Secure Web Access - 3,[Tim_McGranaghan],[Tim_McGranaghan],,,,,,
+swa-3,9025,udp,Secure Web Access - 3,[Tim_McGranaghan],[Tim_McGranaghan],,,,,,
+swa-4,9026,tcp,Secure Web Access - 4,[Tim_McGranaghan],[Tim_McGranaghan],,,,,,
+swa-4,9026,udp,Secure Web Access - 4,[Tim_McGranaghan],[Tim_McGranaghan],,,,,,
+,9027-9049,,Unassigned,,,,,,,,
+versiera,9050,tcp,Versiera Agent Listener,[Frank_Pikelner],[Frank_Pikelner],2010-01-15,,,,,
+,9050,udp,Reserved,,,,,,,,
+fio-cmgmt,9051,tcp,Fusion-io Central Manager Service,[Jim_Sermersheim],[Jim_Sermersheim],2010-01-15,,,,,
+,9051,udp,Reserved,,,,,,,,
+,9052-9079,,Unassigned,,,,,,,,
+glrpc,9080,tcp,Groove GLRPC,[Adrian_Popescu],[Adrian_Popescu],2002-09,,,,,
+glrpc,9080,udp,Groove GLRPC,[Adrian_Popescu],[Adrian_Popescu],2002-09,,,,,
+,9081,,Unassigned,,,,,,,,
+lcs-ap,9082,sctp,LCS Application Protocol,[Kimmo_Kymalainen],[Kimmo_Kymalainen],2010-06-04,,,,,
+emc-pp-mgmtsvc,9083,tcp,EMC PowerPath Mgmt Service,[Jim_Perreault],[Jim_Perreault],2010-06-04,,,,,
+,9083,udp,Reserved,,,,,,,,
+aurora,9084,tcp,IBM AURORA Performance Visualizer,[Jeroen_Massar_2],[Jeroen_Massar_2],2008-08-21,,,,,
+aurora,9084,udp,IBM AURORA Performance Visualizer,[Jeroen_Massar_2],[Jeroen_Massar_2],2008-08-21,,,,,
+aurora,9084,sctp,IBM AURORA Performance Visualizer,[Jeroen_Massar_2],[Jeroen_Massar_2],2008-08-21,,,,,
+ibm-rsyscon,9085,tcp,IBM Remote System Console,[William_LePera],[William_LePera],2008-06-18,,,,,
+ibm-rsyscon,9085,udp,IBM Remote System Console,[William_LePera],[William_LePera],2008-06-18,,,,,
+net2display,9086,tcp,Vesa Net2Display,[Kenneth_B_Ocheltree],[Kenneth_B_Ocheltree],2008-01-07,,,,,
+net2display,9086,udp,Vesa Net2Display,[Kenneth_B_Ocheltree],[Kenneth_B_Ocheltree],2008-01-07,,,,,
+classic,9087,tcp,Classic Data Server,[Paul_Cadarette],[Paul_Cadarette],2007-01,,,,,
+classic,9087,udp,Classic Data Server,[Paul_Cadarette],[Paul_Cadarette],2007-01,,,,,
+sqlexec,9088,tcp,IBM Informix SQL Interface,[Jonathan_Leffler],[Jonathan_Leffler],2005-12,,,,,
+sqlexec,9088,udp,IBM Informix SQL Interface,[Jonathan_Leffler],[Jonathan_Leffler],2005-12,,,,,
+sqlexec-ssl,9089,tcp,IBM Informix SQL Interface - Encrypted,[Jonathan_Leffler],[Jonathan_Leffler],2005-12,,,,,
+sqlexec-ssl,9089,udp,IBM Informix SQL Interface - Encrypted,[Jonathan_Leffler],[Jonathan_Leffler],2005-12,,,,,
+websm,9090,tcp,WebSM,[I_Hsing_Tsao],[I_Hsing_Tsao],,,,,,
+websm,9090,udp,WebSM,[I_Hsing_Tsao],[I_Hsing_Tsao],,,,,,
+xmltec-xmlmail,9091,tcp,xmltec-xmlmail,[Mitch_Kaufman],[Mitch_Kaufman],,,,,,
+xmltec-xmlmail,9091,udp,xmltec-xmlmail,[Mitch_Kaufman],[Mitch_Kaufman],,,,,,
+XmlIpcRegSvc,9092,tcp,Xml-Ipc Server Reg,[Casey_Harrington],[Casey_Harrington],2006-01,,,,,
+XmlIpcRegSvc,9092,udp,Xml-Ipc Server Reg,[Casey_Harrington],[Casey_Harrington],2006-01,,,,,
+copycat,9093,tcp,Copycat database replication service,[Microtec_Informatique],[Raphael_Neve],2012-03-15,,,,,
+,9093,udp,Reserved,,,,,,,,
+,9094-9099,,Unassigned,,,,,,,,
+hp-pdl-datastr,9100,tcp,PDL Data Streaming Port,[Shivaun_Albright],[Shivaun_Albright],2002-04,,,,,
+hp-pdl-datastr,9100,udp,PDL Data Streaming Port,[Shivaun_Albright],[Shivaun_Albright],2002-04,,,,,
+pdl-datastream,9100,tcp,Printer PDL Data Stream,[Stuart_Cheshire_4],[Stuart_Cheshire_4],2002-09,,,,,"The protocol name ""pdl-datastream"" is primarily registered for use
+in DNS SRV records (RFC 2782). DNS SRV records allow a protocol to run on
+any port number, but the default port for this protocol is 9100."
+pdl-datastream,9100,udp,Printer PDL Data Stream,[Stuart_Cheshire_4],[Stuart_Cheshire_4],2002-09,,,,,"The protocol name ""pdl-datastream"" is primarily registered for use
+in DNS SRV records (RFC 2782). DNS SRV records allow a protocol to run on
+any port number, but the default port for this protocol is 9100."
+bacula-dir,9101,tcp,Bacula Director,[Kern_Sibbald],[Kern_Sibbald],2002-01,,,,,
+bacula-dir,9101,udp,Bacula Director,[Kern_Sibbald],[Kern_Sibbald],2002-01,,,,,
+bacula-fd,9102,tcp,Bacula File Daemon,[Kern_Sibbald],[Kern_Sibbald],2002-01,,,,,
+bacula-fd,9102,udp,Bacula File Daemon,[Kern_Sibbald],[Kern_Sibbald],2002-01,,,,,
+bacula-sd,9103,tcp,Bacula Storage Daemon,[Kern_Sibbald],[Kern_Sibbald],2002-01,,,,,
+bacula-sd,9103,udp,Bacula Storage Daemon,[Kern_Sibbald],[Kern_Sibbald],2002-01,,,,,
+peerwire,9104,tcp,PeerWire,[Steven_Gerhardt],[Steven_Gerhardt],2004-02,,,,,
+peerwire,9104,udp,PeerWire,[Steven_Gerhardt],[Steven_Gerhardt],2004-02,,,,,
+xadmin,9105,tcp,Xadmin Control Service,,,,,[Ariën Huisken <xadmin&huisken-systems.nl> 15 June 2009],,,
+xadmin,9105,udp,Xadmin Control Service,,,,,[Ariën Huisken <xadmin&huisken-systems.nl> 15 June 2009],,,
+astergate,9106,tcp,Astergate Control Service,[Ari_Huisken],[Ari_Huisken],2010-01-04,,,,,
+astergate-disc,9106,udp,Astergate Discovery Service,[Ari_Huisken],[Ari_Huisken],2010-01-04,,,,,
+astergatefax,9107,tcp,AstergateFax Control Service,[Gijs_Middelkamp],[Gijs_Middelkamp],2010-02-03,,,,,
+,9107,udp,Reserved,,,,,,,,
+,9108-9118,,Unassigned,,,,,,,,
+mxit,9119,tcp,MXit Instant Messaging,[Marnus_Freeman],[Marnus_Freeman],2006-02,,,,,
+mxit,9119,udp,MXit Instant Messaging,[Marnus_Freeman],[Marnus_Freeman],2006-02,,,,,
+,9120-9121,,Unassigned,,,,,,,,
+grcmp,9122,tcp,Global Relay compliant mobile instant messaging protocol,[Global_Relay],[Mike_Sample],2012-11-28,,,,,
+,9122,udp,Reserved,,,,,,,,
+grcp,9123,tcp,Global Relay compliant instant messaging protocol,[Global_Relay],[Mike_Sample],2012-11-28,,,,,
+,9123,udp,Reserved,,,,,,,,
+,9124-9130,,Unassigned,,,,,,,,
+dddp,9131,tcp,Dynamic Device Discovery,[Shane_Dick],[Shane_Dick],2005-08,,,,,
+dddp,9131,udp,Dynamic Device Discovery,[Shane_Dick],[Shane_Dick],2005-08,,,,,
+,9132-9159,,Unassigned,,,,,,,,
+apani1,9160,tcp,apani1,[Neal_Taylor],[Neal_Taylor],,,,,,
+apani1,9160,udp,apani1,[Neal_Taylor],[Neal_Taylor],,,,,,
+apani2,9161,tcp,apani2,[Neal_Taylor],[Neal_Taylor],,,,,,
+apani2,9161,udp,apani2,[Neal_Taylor],[Neal_Taylor],,,,,,
+apani3,9162,tcp,apani3,[Neal_Taylor],[Neal_Taylor],,,,,,
+apani3,9162,udp,apani3,[Neal_Taylor],[Neal_Taylor],,,,,,
+apani4,9163,tcp,apani4,[Neal_Taylor],[Neal_Taylor],,,,,,
+apani4,9163,udp,apani4,[Neal_Taylor],[Neal_Taylor],,,,,,
+apani5,9164,tcp,apani5,[Neal_Taylor],[Neal_Taylor],,,,,,
+apani5,9164,udp,apani5,[Neal_Taylor],[Neal_Taylor],,,,,,
+,9165-9190,,Unassigned,,,,,,,,
+sun-as-jpda,9191,tcp,Sun AppSvr JPDA,[Abhijit_Kumar],[Abhijit_Kumar],2005-11,,,,,
+sun-as-jpda,9191,udp,Sun AppSvr JPDA,[Abhijit_Kumar],[Abhijit_Kumar],2005-11,,,,,
+,9192-9199,,Unassigned,,,,,,,,
+wap-wsp,9200,tcp,WAP connectionless session service,[WAP_Forum],[WAP_Forum],,,,,,
+wap-wsp,9200,udp,WAP connectionless session service,[WAP_Forum],[WAP_Forum],,,,,,
+wap-wsp-wtp,9201,tcp,WAP session service,[WAP_Forum],[WAP_Forum],,,,,,
+wap-wsp-wtp,9201,udp,WAP session service,[WAP_Forum],[WAP_Forum],,,,,,
+wap-wsp-s,9202,tcp,WAP secure connectionless session service,[WAP_Forum],[WAP_Forum],,,,,,
+wap-wsp-s,9202,udp,WAP secure connectionless session service,[WAP_Forum],[WAP_Forum],,,,,,
+wap-wsp-wtp-s,9203,tcp,WAP secure session service,[WAP_Forum],[WAP_Forum],,,,,,
+wap-wsp-wtp-s,9203,udp,WAP secure session service,[WAP_Forum],[WAP_Forum],,,,,,
+wap-vcard,9204,tcp,WAP vCard,[WAP_Forum],[WAP_Forum],,,,,,
+wap-vcard,9204,udp,WAP vCard,[WAP_Forum],[WAP_Forum],,,,,,
+wap-vcal,9205,tcp,WAP vCal,[WAP_Forum],[WAP_Forum],,,,,,
+wap-vcal,9205,udp,WAP vCal,[WAP_Forum],[WAP_Forum],,,,,,
+wap-vcard-s,9206,tcp,WAP vCard Secure,[WAP_Forum],[WAP_Forum],,,,,,
+wap-vcard-s,9206,udp,WAP vCard Secure,[WAP_Forum],[WAP_Forum],,,,,,
+wap-vcal-s,9207,tcp,WAP vCal Secure,[WAP_Forum],[WAP_Forum],,,,,,
+wap-vcal-s,9207,udp,WAP vCal Secure,[WAP_Forum],[WAP_Forum],,,,,,
+rjcdb-vcards,9208,tcp,rjcdb vCard,[Robert_John_Churchil],[Robert_John_Churchil],2006-01,,,,,
+rjcdb-vcards,9208,udp,rjcdb vCard,[Robert_John_Churchil],[Robert_John_Churchil],2006-01,,,,,
+almobile-system,9209,tcp,ALMobile System Service,[Rob_Graber],[Rob_Graber],2006-01,,,,,
+almobile-system,9209,udp,ALMobile System Service,[Rob_Graber],[Rob_Graber],2006-01,,,,,
+oma-mlp,9210,tcp,OMA Mobile Location Protocol,[Hans_Rohnert],[Hans_Rohnert],2002-04,,,,,
+oma-mlp,9210,udp,OMA Mobile Location Protocol,[Hans_Rohnert],[Hans_Rohnert],2002-04,,,,,
+oma-mlp-s,9211,tcp,OMA Mobile Location Protocol Secure,[Hans_Rohnert],[Hans_Rohnert],2002-04,,,,,
+oma-mlp-s,9211,udp,OMA Mobile Location Protocol Secure,[Hans_Rohnert],[Hans_Rohnert],2002-04,,,,,
+serverviewdbms,9212,tcp,Server View dbms access,[Detlef_Rothe],[Detlef_Rothe],2009-05-15,,,,,
+serverviewdbms,9212,udp,Server View dbms access,[Detlef_Rothe],[Detlef_Rothe],2009-05-15,,,,,
+serverstart,9213,tcp,ServerStart RemoteControl,[Detlef_Rothe],[Detlef_Rothe],2009-05-15,,,,,
+serverstart,9213,udp,ServerStart RemoteControl,[Detlef_Rothe],[Detlef_Rothe],2009-05-15,,,,,
+ipdcesgbs,9214,tcp,IPDC ESG BootstrapService,[Joerg_Heuer],[Joerg_Heuer],2006-02,,,,,
+ipdcesgbs,9214,udp,IPDC ESG BootstrapService,[Joerg_Heuer],[Joerg_Heuer],2006-02,,,,,
+insis,9215,tcp,Integrated Setup and Install Service,[Markus_Treinen],[Markus_Treinen],2006-02,,,,,
+insis,9215,udp,Integrated Setup and Install Service,[Markus_Treinen],[Markus_Treinen],2006-02,,,,,
+acme,9216,tcp,Aionex Communication Management Engine,[Mark_Sapp],[Mark_Sapp],2006-04,,,,,
+acme,9216,udp,Aionex Communication Management Engine,[Mark_Sapp],[Mark_Sapp],2006-04,,,,,
+fsc-port,9217,tcp,FSC Communication Port,[Teijo_Mustonen],[Teijo_Mustonen],2002-03,,,,,
+fsc-port,9217,udp,FSC Communication Port,[Teijo_Mustonen],[Teijo_Mustonen],2002-03,,,,,
+,9218-9221,,Unassigned,,,,,,,,
+teamcoherence,9222,tcp,QSC Team Coherence,[Ewan_McNab],[Ewan_McNab],2004-11,,,,,
+teamcoherence,9222,udp,QSC Team Coherence,[Ewan_McNab],[Ewan_McNab],2004-11,,,,,
+,9223-9254,,Unassigned,,,,,,,,
+mon,9255,tcp,Manager On Network,[David_Rouchet],[David_Rouchet],2007-05,,,,,
+mon,9255,udp,Manager On Network,[David_Rouchet],[David_Rouchet],2007-05,,,,,
+,9256-9276,,Unassigned,,,,,,,,
+traingpsdata,9277,udp,GPS Data transmitted from train to ground network,[Alstom_Transport_Preston],[Paul_Steane],2012-12-14,,,,,
+,9277,tcp,Reserved,,,,,,,,
+pegasus,9278,tcp,Pegasus GPS Platform,[Nestor_A_Diaz],[Nestor_A_Diaz],2009-05-12,,,,,
+pegasus,9278,udp,Pegasus GPS Platform,[Nestor_A_Diaz],[Nestor_A_Diaz],2009-05-12,,,,,
+pegasus-ctl,9279,tcp,Pegaus GPS System Control Interface,[Nestor_A_Diaz],[Nestor_A_Diaz],2009-05-12,,,,,
+pegasus-ctl,9279,udp,Pegaus GPS System Control Interface,[Nestor_A_Diaz],[Nestor_A_Diaz],2009-05-12,,,,,
+pgps,9280,tcp,Predicted GPS,[Jeremy_Freeman],[Jeremy_Freeman],2008-02-14,,,,,
+pgps,9280,udp,Predicted GPS,[Jeremy_Freeman],[Jeremy_Freeman],2008-02-14,,,,,
+swtp-port1,9281,tcp,SofaWare transport port 1,[Amir_Rapson],[Amir_Rapson],2002-02,,,,,
+swtp-port1,9281,udp,SofaWare transport port 1,[Amir_Rapson],[Amir_Rapson],2002-02,,,,,
+swtp-port2,9282,tcp,SofaWare transport port 2,[Amir_Rapson],[Amir_Rapson],2002-02,,,,,
+swtp-port2,9282,udp,SofaWare transport port 2,[Amir_Rapson],[Amir_Rapson],2002-02,,,,,
+callwaveiam,9283,tcp,CallWaveIAM,[Colin_Kelley],[Colin_Kelley],,,,,,
+callwaveiam,9283,udp,CallWaveIAM,[Colin_Kelley],[Colin_Kelley],,,,,,
+visd,9284,tcp,VERITAS Information Serve,[Ravi_Tavakely],[Ravi_Tavakely],2002-02,,,,,
+visd,9284,udp,VERITAS Information Serve,[Ravi_Tavakely],[Ravi_Tavakely],2002-02,,,,,
+n2h2server,9285,tcp,N2H2 Filter Service Port,[Jim_Irwin],[Jim_Irwin],2002-02,,,,,
+n2h2server,9285,udp,N2H2 Filter Service Port,[Jim_Irwin],[Jim_Irwin],2002-02,,,,,
+,9286,tcp,Reserved,,,,,,,,
+n2receive,9286,udp,n2 monitoring receiver,[Peter_van_Dijk],[Peter_van_Dijk],2011-01-10,,,,,
+cumulus,9287,tcp,Cumulus,[Thomas_Schleu],[Thomas_Schleu],,,,,,
+cumulus,9287,udp,Cumulus,[Thomas_Schleu],[Thomas_Schleu],,,,,,
+,9288-9291,,Unassigned,,,,,,,,
+armtechdaemon,9292,tcp,ArmTech Daemon,[Rohan_Story],[Rohan_Story],,,,,,
+armtechdaemon,9292,udp,ArmTech Daemon,[Rohan_Story],[Rohan_Story],,,,,,
+storview,9293,tcp,StorView Client,[Ryan_Smith],[Ryan_Smith],2006-07,,,,,
+storview,9293,udp,StorView Client,[Ryan_Smith],[Ryan_Smith],2006-07,,,,,
+armcenterhttp,9294,tcp,ARMCenter http Service,[Eric_Thiebaut_George],[Eric_Thiebaut_George],2006-04,,,,,
+armcenterhttp,9294,udp,ARMCenter http Service,[Eric_Thiebaut_George],[Eric_Thiebaut_George],2006-04,,,,,
+armcenterhttps,9295,tcp,ARMCenter https Service,[Eric_Thiebaut_George],[Eric_Thiebaut_George],2006-04,,,,,
+armcenterhttps,9295,udp,ARMCenter https Service,[Eric_Thiebaut_George],[Eric_Thiebaut_George],2006-04,,,,,
+,9296-9299,,Unassigned,,,,,,,,
+vrace,9300,tcp,Virtual Racing Service,[Pete_Loeffen],[Pete_Loeffen],2006-10,,,,,
+vrace,9300,udp,Virtual Racing Service,[Pete_Loeffen],[Pete_Loeffen],2006-10,,,,,
+,9301-9305,,Unassigned,,,,,,,,
+sphinxql,9306,tcp,Sphinx search server (MySQL listener),[Andrew_Aksyonoff],[Andrew_Aksyonoff],2009-10-20,,,,,
+,9306,udp,Reserved,,,,,,,,
+,9307-9311,,Unassigned,,,,,,,,
+sphinxapi,9312,tcp,Sphinx search server,[Andrew_Aksyonoff],[Andrew_Aksyonoff],2009-10-20,,,,,
+,9312,udp,Reserved,,,,,,,,
+,9313-9317,,Unassigned,,,,,,,,
+secure-ts,9318,tcp,PKIX TimeStamp over TLS,[Niklas_Weiss],[Niklas_Weiss],2004-11,,,,,
+secure-ts,9318,udp,PKIX TimeStamp over TLS,[Niklas_Weiss],[Niklas_Weiss],2004-11,,,,,
+,9319-9320,,Unassigned,,,,,,,,
+guibase,9321,tcp,guibase,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+guibase,9321,udp,guibase,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+,9322-9342,,Unassigned,,,,,,,,
+mpidcmgr,9343,tcp,MpIdcMgr,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+mpidcmgr,9343,udp,MpIdcMgr,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+mphlpdmc,9344,tcp,Mphlpdmc,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+mphlpdmc,9344,udp,Mphlpdmc,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+,9345,,Unassigned,,,,,,,,
+ctechlicensing,9346,tcp,C Tech Licensing,[Reed_Copsey_Jr],[Reed_Copsey_Jr],,,,,,
+ctechlicensing,9346,udp,C Tech Licensing,[Reed_Copsey_Jr],[Reed_Copsey_Jr],,,,,,
+,9347-9373,,Unassigned,,,,,,,,
+fjdmimgr,9374,tcp,fjdmimgr,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+fjdmimgr,9374,udp,fjdmimgr,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+,9375-9379,,Unassigned,,,,,,,,
+boxp,9380,tcp,Brivs! Open Extensible Protocol,[Danko_Alexeyev],[Danko_Alexeyev],2007-08-08,,,,,
+boxp,9380,udp,Brivs! Open Extensible Protocol,[Danko_Alexeyev],[Danko_Alexeyev],2007-08-08,,,,,
+,9381-9386,,Unassigned,,,,,,,,
+d2dconfig,9387,tcp,D2D Configuration Service,[Pete_Camble],[Pete_Camble],2008-12-24,,,,,
+,9387,udp,Reserved,,,,,,,,
+d2ddatatrans,9388,tcp,D2D Data Transfer Service,[Pete_Camble],[Pete_Camble],2008-12-24,,,,,
+,9388,udp,Reserved,,,,,,,,
+adws,9389,tcp,Active Directory Web Services,[Nitin_Gupta],[Nitin_Gupta],2008-12-24,,,,,
+,9389,udp,Reserved,,,,,,,,
+otp,9390,tcp,OpenVAS Transfer Protocol,[Tim_Brown],[Tim_Brown],2008-12-24,,,,,
+,9390,udp,Reserved,,,,,,,,
+,9391-9395,,Unassigned,,,,,,,,
+fjinvmgr,9396,tcp,fjinvmgr,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+fjinvmgr,9396,udp,fjinvmgr,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+mpidcagt,9397,tcp,MpIdcAgt,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+mpidcagt,9397,udp,MpIdcAgt,[Yutaka_Ono],[Yutaka_Ono],,,,,,
+,9398-9399,,Unassigned,,,,,,,,
+sec-t4net-srv,9400,tcp,Samsung Twain for Network Server,[Dongkeun_Kim],[Dongkeun_Kim],2007-02,,,,,
+sec-t4net-srv,9400,udp,Samsung Twain for Network Server,[Dongkeun_Kim],[Dongkeun_Kim],2007-02,,,,,
+sec-t4net-clt,9401,tcp,Samsung Twain for Network Client,[Dongkeun_Kim],[Dongkeun_Kim],2007-02,,,,,
+sec-t4net-clt,9401,udp,Samsung Twain for Network Client,[Dongkeun_Kim],[Dongkeun_Kim],2007-02,,,,,
+sec-pc2fax-srv,9402,tcp,Samsung PC2FAX for Network Server,[HyeongBae_Yu],[HyeongBae_Yu],2008-07-31,,,,,
+sec-pc2fax-srv,9402,udp,Samsung PC2FAX for Network Server,[HyeongBae_Yu],[HyeongBae_Yu],2008-07-31,,,,,
+,9403-9417,,Unassigned,,,,,,,,
+git,9418,tcp,git pack transfer service,[Linus_Torvalds],[Linus_Torvalds],2005-09,,,,,
+git,9418,udp,git pack transfer service,[Linus_Torvalds],[Linus_Torvalds],2005-09,,,,,
+,9419-9442,,Unassigned,,,,,,,,
+tungsten-https,9443,tcp,WSO2 Tungsten HTTPS,[Afkham_Azeez],[Afkham_Azeez],2006-06,,,,,
+tungsten-https,9443,udp,WSO2 Tungsten HTTPS,[Afkham_Azeez],[Afkham_Azeez],2006-06,,,,,
+wso2esb-console,9444,tcp,WSO2 ESB Administration Console HTTPS,[Ruwan_Linton],[Ruwan_Linton],2008-08-20,,,,,
+wso2esb-console,9444,udp,WSO2 ESB Administration Console HTTPS,[Ruwan_Linton],[Ruwan_Linton],2008-08-20,,,,,
+mindarray-ca,9445,tcp,MindArray Systems Console Agent,[MINDARRAY_SYSTEMS],[ALPESH_DHAMELIA],2011-10-25,,,,,
+,9445,udp,Reserved,,,,,,,,
+,9446-9449,,Unassigned,,,,,,,,
+sntlkeyssrvr,9450,tcp,Sentinel Keys Server,[Martin_Ziskind],[Martin_Ziskind],2008-08-21,,,,,
+sntlkeyssrvr,9450,udp,Sentinel Keys Server,[Martin_Ziskind],[Martin_Ziskind],2008-08-21,,,,,
+,9451-9499,,Unassigned,,,,,,,,
+ismserver,9500,tcp,ismserver,[Ian_Gordon_3],[Ian_Gordon_3],,,,,,
+ismserver,9500,udp,ismserver,[Ian_Gordon_3],[Ian_Gordon_3],,,,,,
+,9501-9521,,Unassigned,,,,,,,,
+,9522,tcp,Reserved,,,,,,,,
+sma-spw,9522,udp,SMA Speedwire,[SMA_Solar_Techology],[SMA_Solar_Techology],2011-03-08,,,,,
+,9523-9534,,Unassigned,,,,,,,,
+mngsuite,9535,tcp,Management Suite Remote Control,[Trevor_Perkes],[Trevor_Perkes],2010-02-01,,,,,
+mngsuite,9535,udp,Management Suite Remote Control,[Trevor_Perkes],[Trevor_Perkes],2010-02-01,,,,,
+laes-bf,9536,tcp,Surveillance buffering function,[Glen_Myers],[Glen_Myers],2007-05,,,,,
+laes-bf,9536,udp,Surveillance buffering function,[Glen_Myers],[Glen_Myers],2007-05,,,,,
+,9537-9554,,Unassigned,,,,,,,,
+trispen-sra,9555,tcp,Trispen Secure Remote Access,[Jaco_Botha],[Jaco_Botha],2004-11,,,,,
+trispen-sra,9555,udp,Trispen Secure Remote Access,[Jaco_Botha],[Jaco_Botha],2004-11,,,,,
+,9556-9591,,Unassigned,,,,,,,,
+ldgateway,9592,tcp,LANDesk Gateway,[Alan_Butt],[Alan_Butt],2006-03,,,,,
+ldgateway,9592,udp,LANDesk Gateway,[Alan_Butt],[Alan_Butt],2006-03,,,,,
+cba8,9593,tcp,LANDesk Management Agent (cba8),[Trevor_Perkes],[Trevor_Perkes],2010-02-01,,,,,
+cba8,9593,udp,LANDesk Management Agent (cba8),[Trevor_Perkes],[Trevor_Perkes],2010-02-01,,,,,
+msgsys,9594,tcp,Message System,[Alan_Butt],[Alan_Butt],,,,,,
+msgsys,9594,udp,Message System,[Alan_Butt],[Alan_Butt],,,,,,
+pds,9595,tcp,Ping Discovery Service,[Alan_Butt],[Alan_Butt],,,,,,
+pds,9595,udp,Ping Discovery Service,[Alan_Butt],[Alan_Butt],,,,,,
+mercury-disc,9596,tcp,Mercury Discovery,[Paul_Mclachlan],[Paul_Mclachlan],2005-11,,,,,
+mercury-disc,9596,udp,Mercury Discovery,[Paul_Mclachlan],[Paul_Mclachlan],2005-11,,,,,
+pd-admin,9597,tcp,PD Administration,[Duk_Loi],[Duk_Loi],2005-11,,,,,
+pd-admin,9597,udp,PD Administration,[Duk_Loi],[Duk_Loi],2005-11,,,,,
+vscp,9598,tcp,Very Simple Ctrl Protocol,[Ake_Hedman],[Ake_Hedman],2005-11,,,,,
+vscp,9598,udp,Very Simple Ctrl Protocol,[Ake_Hedman],[Ake_Hedman],2005-11,,,,,
+robix,9599,tcp,Robix,[Evan_Rosen],[Evan_Rosen],2005-11,,,,,
+robix,9599,udp,Robix,[Evan_Rosen],[Evan_Rosen],2005-11,,,,,
+micromuse-ncpw,9600,tcp,MICROMUSE-NCPW,[Hing_Wing_To_2],[Hing_Wing_To_2],,,,,,
+micromuse-ncpw,9600,udp,MICROMUSE-NCPW,[Hing_Wing_To_2],[Hing_Wing_To_2],,,,,,
+,9601-9611,,Unassigned,,,,,,,,
+streamcomm-ds,9612,tcp,StreamComm User Directory,[Brian_C_Wiles],[Brian_C_Wiles],,,,,,
+streamcomm-ds,9612,udp,StreamComm User Directory,[Brian_C_Wiles],[Brian_C_Wiles],,,,,,
+,9613,,Unassigned,,,,,,,,
+iadt-tls,9614,tcp,iADT Protocol over TLS,[Paul_A_Suhler],[Paul_A_Suhler],2009-02-05,,,,,
+,9614,udp,Reserved,,,,,,,,
+,9615,,Unassigned,,,,,,,,
+erunbook-agent,9616,tcp,"eRunbook Agent
+IANA assigned this well-formed service name as a replacement for ""erunbook_agent"".",[Gerhard_Wagner],[Gerhard_Wagner],2009-03-10,,,,,
+erunbook_agent,9616,tcp,eRunbook Agent,[Gerhard_Wagner],[Gerhard_Wagner],2009-03-10,,,,,"This entry is an alias to ""erunbook-agent"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+,9616,udp,Reserved,,,,,,,,
+erunbook-server,9617,tcp,"eRunbook Server
+IANA assigned this well-formed service name as a replacement for ""erunbook_server"".",[Gerhard_Wagner],[Gerhard_Wagner],2009-03-10,,,,,
+erunbook_server,9617,tcp,eRunbook Server,[Gerhard_Wagner],[Gerhard_Wagner],2009-03-10,,,,,"This entry is an alias to ""erunbook-server"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+,9617,udp,Reserved,,,,,,,,
+condor,9618,tcp,Condor Collector Service,[Todd_Tannenbaum],[Todd_Tannenbaum],2008-04-03,,,,,
+condor,9618,udp,Condor Collector Service,[Todd_Tannenbaum],[Todd_Tannenbaum],2008-04-03,,,,,
+,9619-9627,,Unassigned,,,,,,,,
+odbcpathway,9628,tcp,ODBC Pathway Service,[Adrian_Hungate],[Adrian_Hungate],2007-05,,,,,
+odbcpathway,9628,udp,ODBC Pathway Service,[Adrian_Hungate],[Adrian_Hungate],2007-05,,,,,
+uniport,9629,tcp,UniPort SSO Controller,[Adrian_Hungate],[Adrian_Hungate],2007-09-05,,,,,
+uniport,9629,udp,UniPort SSO Controller,[Adrian_Hungate],[Adrian_Hungate],2007-09-05,,,,,
+peoctlr,9630,tcp,Peovica Controller,[Adrian_Hungate],[Adrian_Hungate],2009-09-14,,,,,
+,9630,udp,Reserved,,,,,,,,
+peocoll,9631,tcp,Peovica Collector,[Adrian_Hungate],[Adrian_Hungate],2009-09-14,,,,,
+,9631,udp,Reserved,,,,,,,,
+,9632,tcp,Reserved,,,,,,,,
+mc-comm,9632,udp,Mobile-C Communications,[David_Ko_2],[David_Ko_2],2009-09-14,,,,,
+,9633-9639,,Unassigned,,,,,,,,
+pqsflows,9640,tcp,ProQueSys Flows Service,[Sarene_Caiazza],[Sarene_Caiazza],2010-04-27,,,,,
+,9640,udp,Reserved,,,,,,,,
+,9641-9665,,Unassigned,,,,,,,,
+zoomcp,9666,tcp,Zoom Control Panel Game Server Management,[Zoom_Control_Panel],[Joshua_Pedroza],2014-02-26,,,,,
+,9666,udp,Reserved,,,,,,,,
+xmms2,9667,tcp,Cross-platform Music Multiplexing System,[Juho_Herttua],[Juho_Herttua],2009-04-14,,,,,
+xmms2,9667,udp,Cross-platform Music Multiplexing System,[Juho_Herttua],[Juho_Herttua],,,,,,
+tec5-sdctp,9668,tcp,tec5 Spectral Device Control Protocol,[Michael_Muth],[Michael_Muth],2009-05-11,,,,,
+tec5-sdctp,9668,udp,tec5 Spectral Device Control Protocol,[Michael_Muth],[Michael_Muth],2009-05-11,,,,,
+,9669-9693,,Unassigned,,,,,,,,
+client-wakeup,9694,tcp,T-Mobile Client Wakeup Message,[Michael_Schonborn],[Michael_Schonborn],2009-09-11,,,,,
+client-wakeup,9694,udp,T-Mobile Client Wakeup Message,[Michael_Schonborn],[Michael_Schonborn],2009-09-11,,,,,
+ccnx,9695,tcp,Content Centric Networking,[Van_Jacobson_2][Simon_Barber],[Van_Jacobson_2][Simon_Barber],2009-09-29,,,,,
+ccnx,9695,udp,Content Centric Networking,[Van_Jacobson_2][Simon_Barber],[Van_Jacobson_2][Simon_Barber],2009-09-29,,,,,
+,9696-9699,,Unassigned,,,,,,,,
+board-roar,9700,tcp,Board M.I.T. Service,[Francesco_Rosi],[Francesco_Rosi],2006-01,,,,,
+board-roar,9700,udp,Board M.I.T. Service,[Francesco_Rosi],[Francesco_Rosi],2006-01,,,,,
+,9701-9746,,Unassigned,,,,,,,,
+l5nas-parchan,9747,tcp,L5NAS Parallel Channel,[Lawrence_J_Dickson],[Lawrence_J_Dickson],2002-03,,,,,
+l5nas-parchan,9747,udp,L5NAS Parallel Channel,[Lawrence_J_Dickson],[Lawrence_J_Dickson],2002-03,,,,,
+,9748-9749,,Unassigned,,,,,,,,
+board-voip,9750,tcp,Board M.I.T. Synchronous Collaboration,[Francesco_Rosi],[Francesco_Rosi],2006-01,,,,,
+board-voip,9750,udp,Board M.I.T. Synchronous Collaboration,[Francesco_Rosi],[Francesco_Rosi],2006-01,,,,,
+,9751-9752,,Unassigned,,,,,,,,
+rasadv,9753,tcp,rasadv,[Dave_Thaler_2],[Dave_Thaler_2],,,,,,
+rasadv,9753,udp,rasadv,[Dave_Thaler_2],[Dave_Thaler_2],,,,,,
+,9754-9761,,Unassigned,,,,,,,,
+tungsten-http,9762,tcp,WSO2 Tungsten HTTP,[Afkham_Azeez],[Afkham_Azeez],2006-06,,,,,
+tungsten-http,9762,udp,WSO2 Tungsten HTTP,[Afkham_Azeez],[Afkham_Azeez],2006-06,,,,,
+,9763-9799,,Unassigned,,,,,,,,
+davsrc,9800,tcp,WebDav Source Port,[Ethan_Fremen],[Ethan_Fremen],,,,,,
+davsrc,9800,udp,WebDav Source Port,[Ethan_Fremen],[Ethan_Fremen],,,,,,
+sstp-2,9801,tcp,Sakura Script Transfer Protocol-2,[Kouichi_Takeda_2],[Kouichi_Takeda_2],,,,,,
+sstp-2,9801,udp,Sakura Script Transfer Protocol-2,[Kouichi_Takeda_2],[Kouichi_Takeda_2],,,,,,
+davsrcs,9802,tcp,WebDAV Source TLS/SSL,[Rob_Isaac],[Rob_Isaac],2003-07,,,,,
+davsrcs,9802,udp,WebDAV Source TLS/SSL,[Rob_Isaac],[Rob_Isaac],2003-07,,,,,
+,9803-9874,,Unassigned,,,,,,,,
+sapv1,9875,tcp,Session Announcement v1,,,,,[RFC2974],,,
+sapv1,9875,udp,Session Announcement v1,,,,,[RFC2974],,,
+sd,9876,tcp,Session Director,[Van_Jacobson],[Van_Jacobson],,,,,,
+,9877,,Unassigned,,,,,,,,
+kca-service,9878,udp,The KX509 Kerberized Certificate Issuance Protocol in Use in 2012,[IESG],[IETF_Chair],2012-07-12,,[RFC6717],,,"Historically, this service has been referred to as ""kca_service"", but this service name does not meet the registry requirements."
+,9878,tcp,Reserved,,,,,,,,
+,9879-9887,,Unassigned,,,,,,,,
+cyborg-systems,9888,tcp,CYBORG Systems,[Malcolm_Graham],[Malcolm_Graham],,,,,,
+cyborg-systems,9888,udp,CYBORG Systems,[Malcolm_Graham],[Malcolm_Graham],,,,,,
+gt-proxy,9889,tcp,Port for Cable network related data proxy or repeater,[Dawei_Qi],[Dawei_Qi],2010-07-07,,,,,
+gt-proxy,9889,udp,Port for Cable network related data proxy or repeater,[Dawei_Qi],[Dawei_Qi],2010-07-07,,,,,
+,9890-9897,,Unassigned,,,,,,,,
+monkeycom,9898,tcp,MonkeyCom,[Yuji_Kuwabara],[Yuji_Kuwabara],,,,,,
+monkeycom,9898,udp,MonkeyCom,[Yuji_Kuwabara],[Yuji_Kuwabara],,,,,,
+,9899,tcp,Reserved,,,,2013-04-10,,,,
+sctp-tunneling,9899,udp,SCTP TUNNELING,[IESG],[IETF_Chair],,2013-04-10,[RFC6951],,,
+iua,9900,tcp,IUA,[Lyndon_Ong_2],[Lyndon_Ong_2],,,,,,
+iua,9900,udp,IUA,[Lyndon_Ong_2],[Lyndon_Ong_2],,,,,,
+iua,9900,sctp,IUA,[Lyndon_Ong_2],[Lyndon_Ong_2],,,,,,
+enrp,9901,udp,enrp server channel,,,,,,,,
+enrp-sctp,9901,sctp,enrp server channel,,,,,[RFC5353],,,
+enrp-sctp-tls,9902,sctp,enrp/tls server channel,,,,,[RFC5353],,,
+,9903,tcp,Reserved,,,,,,,,
+multicast-ping,9903,udp,Multicast Ping Protocol,,,,2011-12-09,[RFC6450],,,
+,9904-9908,,Unassigned,,,,,,,,
+domaintime,9909,tcp,domaintime,[Jeffry_Dwight],[Jeffry_Dwight],,,,,,
+domaintime,9909,udp,domaintime,[Jeffry_Dwight],[Jeffry_Dwight],,,,,,
+,9910,,Unassigned,,,,,,,,
+sype-transport,9911,tcp,SYPECom Transport Protocol,[Sylvain_Pedneault],[Sylvain_Pedneault],2003-03,,,,,
+sype-transport,9911,udp,SYPECom Transport Protocol,[Sylvain_Pedneault],[Sylvain_Pedneault],2003-03,,,,,
+,9912-9924,,Unassigned,,,,,,,,
+xybrid-cloud,9925,tcp,XYBRID Cloud,[Rx_Networks_Inc_2],[Drew_Davies_2],2013-04-25,,,,,
+,9925,udp,Reserved,,,,,,,,
+,9926-9949,,Unassigned,,,,,,,,
+apc-9950,9950,tcp,APC 9950,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-9950,9950,udp,APC 9950,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-9951,9951,tcp,APC 9951,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-9951,9951,udp,APC 9951,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-9952,9952,tcp,APC 9952,[American_Power_Conve],[American_Power_Conve],,,,,,
+apc-9952,9952,udp,APC 9952,[American_Power_Conve],[American_Power_Conve],,,,,,
+acis,9953,tcp,9953,[Thomas_Guth],[Thomas_Guth],2006-01,,,,,
+acis,9953,udp,9953,[Thomas_Guth],[Thomas_Guth],2006-01,,,,,
+hinp,9954,tcp,HaloteC Instrument Network Protocol,[HaloteC_Instruments],[Michel_Stam],2012-02-07,,,,,
+,9954,udp,Reserved,,,,,,,,
+alljoyn-stm,9955,tcp,Contact Port for AllJoyn standard messaging,[Qualcomm_Innovation_Center],[Craig_Dowell],2012-03-14,,,,,
+alljoyn-mcm,9955,udp,Contact Port for AllJoyn multiplexed constrained messaging,[Qualcomm_Innovation_Center],[Craig_Dowell],2012-03-14,,,,,
+,9956,tcp,Reserved,,,,,,,,
+alljoyn,9956,udp,Alljoyn Name Service,[Qualcomm_Innovation_Center],[Craig_Dowell],2011-12-21,,,,,
+,9957-9965,,Unassigned,,,,,,,,
+odnsp,9966,tcp,OKI Data Network Setting Protocol,[Masato_Sato],[Masato_Sato],2006-05,,,,,
+odnsp,9966,udp,OKI Data Network Setting Protocol,[Masato_Sato],[Masato_Sato],2006-05,,,,,
+,9967-9977,,Unassigned,,,,,,,,
+xybrid-rt,9978,tcp,XYBRID RT Server,[Rx_Networks_Inc],[Drew_Davies],2013-01-24,,,,,
+,9978,udp,Reserved,,,,,,,,
+,9979-9986,,Unassigned,,,,,,,,
+dsm-scm-target,9987,tcp,DSM/SCM Target Interface,[Mike_Dyslin],[Mike_Dyslin],2006-08,,,,,
+dsm-scm-target,9987,udp,DSM/SCM Target Interface,[Mike_Dyslin],[Mike_Dyslin],2006-08,,,,,
+nsesrvr,9988,tcp,Software Essentials Secure HTTP server,[Narayanan_Raju],[Narayanan_Raju],2009-02-05,,,,,
+,9988,udp,Reserved,,,,,,,,
+,9989-9989,,Unassigned,,,,,,,,
+osm-appsrvr,9990,tcp,OSM Applet Server,[Vinay_Gupta],[Vinay_Gupta],2003-08,,,,,
+osm-appsrvr,9990,udp,OSM Applet Server,[Vinay_Gupta],[Vinay_Gupta],2003-08,,,,,
+osm-oev,9991,tcp,OSM Event Server,[Vinay_Gupta],[Vinay_Gupta],2003-08,,,,,
+osm-oev,9991,udp,OSM Event Server,[Vinay_Gupta],[Vinay_Gupta],2003-08,,,,,
+palace-1,9992,tcp,OnLive-1,[Douglas_Crockford],[Douglas_Crockford],,,,,,
+palace-1,9992,udp,OnLive-1,[Douglas_Crockford],[Douglas_Crockford],,,,,,
+palace-2,9993,tcp,OnLive-2,[Douglas_Crockford],[Douglas_Crockford],,,,,,
+palace-2,9993,udp,OnLive-2,[Douglas_Crockford],[Douglas_Crockford],,,,,,
+palace-3,9994,tcp,OnLive-3,[Douglas_Crockford],[Douglas_Crockford],,,,,,
+palace-3,9994,udp,OnLive-3,[Douglas_Crockford],[Douglas_Crockford],,,,,,
+palace-4,9995,tcp,Palace-4,[Douglas_Crockford],[Douglas_Crockford],,,,,,
+palace-4,9995,udp,Palace-4,[Douglas_Crockford],[Douglas_Crockford],,,,,,
+palace-5,9996,tcp,Palace-5,[Douglas_Crockford],[Douglas_Crockford],,,,,,
+palace-5,9996,udp,Palace-5,[Douglas_Crockford],[Douglas_Crockford],,,,,,
+palace-6,9997,tcp,Palace-6,[Douglas_Crockford],[Douglas_Crockford],,,,,,
+palace-6,9997,udp,Palace-6,[Douglas_Crockford],[Douglas_Crockford],,,,,,
+distinct32,9998,tcp,Distinct32,[Anoop_Tewari],[Anoop_Tewari],,,,,,
+distinct32,9998,udp,Distinct32,[Anoop_Tewari],[Anoop_Tewari],,,,,,
+distinct,9999,tcp,distinct,[Anoop_Tewari],[Anoop_Tewari],,,,,,
+distinct,9999,udp,distinct,[Anoop_Tewari],[Anoop_Tewari],,,,,,
+ndmp,10000,tcp,Network Data Management Protocol,[Brian_Ehrmantraut],[Brian_Ehrmantraut],,,,,,
+ndmp,10000,udp,Network Data Management Protocol,[Brian_Ehrmantraut],[Brian_Ehrmantraut],,,,,,
+scp-config,10001,tcp,SCP Configuration,[Michael_Benz],[Michael_Benz],2010-08-06,,,,,
+scp-config,10001,udp,SCP Configuration,[Michael_Benz],[Michael_Benz],2010-08-06,,,,,
+documentum,10002,tcp,EMC-Documentum Content Server Product,[Reza_Bagherian],[Reza_Bagherian],2007-07-19,,,,,
+documentum,10002,udp,EMC-Documentum Content Server Product,[Reza_Bagherian],[Reza_Bagherian],2007-07-19,,,,,
+documentum-s,10003,tcp,"EMC-Documentum Content Server Product
+IANA assigned this well-formed service name as a replacement for ""documentum_s"".",[Reza_Bagherian],[Reza_Bagherian],2007-07-19,,,,,
+documentum_s,10003,tcp,EMC-Documentum Content Server Product,[Reza_Bagherian],[Reza_Bagherian],2007-07-19,,,,,"This entry is an alias to ""documentum-s"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+documentum-s,10003,udp,"EMC-Documentum Content Server Product
+IANA assigned this well-formed service name as a replacement for ""documentum_s"".",[Reza_Bagherian],[Reza_Bagherian],2007-07-19,,,,,
+documentum_s,10003,udp,EMC-Documentum Content Server Product,[Reza_Bagherian],[Reza_Bagherian],2007-07-19,,,,,"This entry is an alias to ""documentum-s"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+emcrmirccd,10004,tcp,EMC Replication Manager Client,[Robert_Boudrie],[Robert_Boudrie],2008-06-09,,,,,
+,10004,udp,Reserved,,,,,,,,
+emcrmird,10005,tcp,EMC Replication Manager Server,[Robert_Boudrie],[Robert_Boudrie],2008-06-09,,,,,
+,10005,udp,Reserved,,,,,,,,
+netapp-sync,10006,tcp,Sync replication protocol among different NetApp platforms,[NetApp_2],[Paul_Mu],2014-08-07,,,,,
+,10006,udp,Reserved,,,,,,,,
+mvs-capacity,10007,tcp,MVS Capacity,[Donna_Dillenberger],[Donna_Dillenberger],,,,,,
+mvs-capacity,10007,udp,MVS Capacity,[Donna_Dillenberger],[Donna_Dillenberger],,,,,,
+octopus,10008,tcp,Octopus Multiplexer,[Chris_Koeritz_2],[Chris_Koeritz_2],2002-10,,,,,
+octopus,10008,udp,Octopus Multiplexer,[Chris_Koeritz_2],[Chris_Koeritz_2],2002-10,,,,,
+swdtp-sv,10009,tcp,Systemwalker Desktop Patrol,[Akira_Ide],[Akira_Ide],2006-03,,,,,
+swdtp-sv,10009,udp,Systemwalker Desktop Patrol,[Akira_Ide],[Akira_Ide],2006-03,,,,,
+rxapi,10010,tcp,ooRexx rxapi services,[David_Ashley],[David_Ashley],2009-07-24,,,,,
+,10010,udp,Reserved,,,,,,,,
+,10011-10049,,Unassigned,,,,,,,,
+zabbix-agent,10050,tcp,Zabbix Agent,[Alexei_Vladishev],[Alexei_Vladishev],2006-02,,,,,
+zabbix-agent,10050,udp,Zabbix Agent,[Alexei_Vladishev],[Alexei_Vladishev],2006-02,,,,,
+zabbix-trapper,10051,tcp,Zabbix Trapper,[Alexei_Vladishev],[Alexei_Vladishev],2006-02,,,,,
+zabbix-trapper,10051,udp,Zabbix Trapper,[Alexei_Vladishev],[Alexei_Vladishev],2006-02,,,,,
+,10052-10054,,Unassigned,,,,,,,,
+qptlmd,10055,tcp,Quantapoint FLEXlm Licensing Service,[Justin_Vegso],[Justin_Vegso],2010-07-01,,,,,
+,10055,udp,Reserved,,,,,,,,
+,10056-10079,,Unassigned,,,,,,,,
+amanda,10080,tcp,Amanda,[John_Jackson],[John_Jackson],,,,,,
+amanda,10080,udp,Amanda,[John_Jackson],[John_Jackson],,,,,,
+famdc,10081,tcp,FAM Archive Server,[Frode_Randers],[Frode_Randers],2006-01,,,,,
+famdc,10081,udp,FAM Archive Server,[Frode_Randers],[Frode_Randers],2006-01,,,,,
+,10082-10099,,Unassigned,,,,,,,,
+itap-ddtp,10100,tcp,VERITAS ITAP DDTP,[Saugata_Guha],[Saugata_Guha],2004-05,,,,,
+itap-ddtp,10100,udp,VERITAS ITAP DDTP,[Saugata_Guha],[Saugata_Guha],2004-05,,,,,
+ezmeeting-2,10101,tcp,eZmeeting,[Albert_C_Yang],[Albert_C_Yang],2002-03,,,,,
+ezmeeting-2,10101,udp,eZmeeting,[Albert_C_Yang],[Albert_C_Yang],2002-03,,,,,
+ezproxy-2,10102,tcp,eZproxy,[Albert_C_Yang],[Albert_C_Yang],2002-03,,,,,
+ezproxy-2,10102,udp,eZproxy,[Albert_C_Yang],[Albert_C_Yang],2002-03,,,,,
+ezrelay,10103,tcp,eZrelay,[Albert_C_Yang],[Albert_C_Yang],2002-03,,,,,
+ezrelay,10103,udp,eZrelay,[Albert_C_Yang],[Albert_C_Yang],2002-03,,,,,
+swdtp,10104,tcp,Systemwalker Desktop Patrol,[Akira_Ide],[Akira_Ide],2006-09,,,,,
+swdtp,10104,udp,Systemwalker Desktop Patrol,[Akira_Ide],[Akira_Ide],2006-09,,,,,
+,10105-10106,,Unassigned,,,,,,,,
+bctp-server,10107,tcp,"VERITAS BCTP, server",[Saugata_Guha],[Saugata_Guha],2004-05,,,,,
+bctp-server,10107,udp,"VERITAS BCTP, server",[Saugata_Guha],[Saugata_Guha],2004-05,,,,,
+,10108-10109,,Unassigned,,,,,,,,
+nmea-0183,10110,tcp,NMEA-0183 Navigational Data,[Meindert_Sprang],[Meindert_Sprang],2009-02-18,,,,,
+nmea-0183,10110,udp,NMEA-0183 Navigational Data,[Meindert_Sprang],[Meindert_Sprang],2009-02-18,,,,,
+,10111,tcp,Reserved,,,,,,,,
+nmea-onenet,10111,udp,NMEA OneNet multicast messaging,[National_Marine_Electronics_Association],[Steve_Spitzer],2011-09-15,,,,,
+,10112,,Unassigned,,,,,,,,
+netiq-endpoint,10113,tcp,NetIQ Endpoint,[John_Wood],[John_Wood],,,,,,
+netiq-endpoint,10113,udp,NetIQ Endpoint,[John_Wood],[John_Wood],,,,,,
+netiq-qcheck,10114,tcp,NetIQ Qcheck,[Michael_Sharpe],[Michael_Sharpe],2010-09-14,,,,,
+netiq-qcheck,10114,udp,NetIQ Qcheck,[Michael_Sharpe],[Michael_Sharpe],2010-09-14,,,,,
+netiq-endpt,10115,tcp,NetIQ Endpoint,[Gary_Weichinger],[Gary_Weichinger],,,,,,
+netiq-endpt,10115,udp,NetIQ Endpoint,[Gary_Weichinger],[Gary_Weichinger],,,,,,
+netiq-voipa,10116,tcp,NetIQ VoIP Assessor,[Gary_Weichinger],[Gary_Weichinger],,,,,,
+netiq-voipa,10116,udp,NetIQ VoIP Assessor,[Gary_Weichinger],[Gary_Weichinger],,,,,,
+iqrm,10117,tcp,NetIQ IQCResource Managament Svc,[Michael_Sharpe],[Michael_Sharpe],2010-09-14,,,,,
+iqrm,10117,udp,NetIQ IQCResource Managament Svc,[Michael_Sharpe],[Michael_Sharpe],2010-09-14,,,,,
+,10118-10127,,Unassigned,,,,,,,,
+bmc-perf-sd,10128,tcp,BMC-PERFORM-SERVICE DAEMON,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmc-perf-sd,10128,udp,BMC-PERFORM-SERVICE DAEMON,[Portnoy_Boxman],[Portnoy_Boxman],,,,,,
+bmc-gms,10129,tcp,BMC General Manager Server,[Dima_Seliverstov],[Dima_Seliverstov],2009-07-28,,,,,
+,10129,udp,Reserved,,,,,,,,
+,10130-10159,,Unassigned,,,,,,,,
+qb-db-server,10160,tcp,QB Database Server,[Wei_Wang],[Wei_Wang],2005-11,,,,,
+qb-db-server,10160,udp,QB Database Server,[Wei_Wang],[Wei_Wang],2005-11,,,,,
+snmptls,10161,tcp,SNMP-TLS,,,,,[RFC6353],,,
+snmpdtls,10161,udp,SNMP-DTLS,,,,,[RFC6353],,,
+snmptls-trap,10162,tcp,SNMP-Trap-TLS,,,,,[RFC6353],,,
+snmpdtls-trap,10162,udp,SNMP-Trap-DTLS,,,,,[RFC6353],,,
+,10163-10199,,Unassigned,,,,,,,,
+trisoap,10200,tcp,Trigence AE Soap Service,[Brigitte_Gagne],[Brigitte_Gagne],2006-08,,,,,
+trisoap,10200,udp,Trigence AE Soap Service,[Brigitte_Gagne],[Brigitte_Gagne],2006-08,,,,,
+rsms,10201,tcp,Remote Server Management Service,[Patrick_H_Piper],[Patrick_H_Piper],2009-03-06,,,,,
+rscs,10201,udp,Remote Server Control and Test Service,[Patrick_H_Piper],[Patrick_H_Piper],2009-03-06,,,,,
+,10202-10251,,Unassigned,,,,,,,,
+apollo-relay,10252,tcp,Apollo Relay Port,[Anthony_Carrabino],[Anthony_Carrabino],2003-08,,,,,
+apollo-relay,10252,udp,Apollo Relay Port,[Anthony_Carrabino],[Anthony_Carrabino],2003-08,,,,,
+,10253-10259,,Unassigned,,,,,,,,
+axis-wimp-port,10260,tcp,Axis WIMP Port,[Stefan_Eriksson],[Stefan_Eriksson],,,,,,
+axis-wimp-port,10260,udp,Axis WIMP Port,[Stefan_Eriksson],[Stefan_Eriksson],,,,,,
+,10261-10287,,Unassigned,,,,,,,,
+blocks,10288,tcp,Blocks,[Carl_Malamud],[Carl_Malamud],,,,,,
+blocks,10288,udp,Blocks,[Carl_Malamud],[Carl_Malamud],,,,,,
+,10289-10320,,Unassigned,,,,,,,,
+cosir,10321,tcp,Computer Op System Information Report,[Kevin_C_Barber],[Kevin_C_Barber],2009-01-13,,,,,
+,10321,udp,Reserved,,,,,,,,
+,10322-10438,,Unassigned,,,,,,,,
+bngsync,10439,udp,BalanceNG session table synchronization protocol,[Inlab_Software_GmbH],[Thomas_G._Obermair],2014-05-02,,,,,
+,10439,tcp,Reserved,,,,,,,,
+,10440-10499,,Unassigned,,,,,,,,
+,10500,tcp,Reserved,,,,,,,,
+hip-nat-t,10500,udp,HIP NAT-Traversal,[Ari_Keranen],[Ari_Keranen],,,[RFC5770],,,
+,10501-10539,,Unassigned,,,,,,,,
+MOS-lower,10540,tcp,MOS Media Object Metadata Port,[Eric_Thorniley],[Eric_Thorniley],2007-09-17,,,,,
+MOS-lower,10540,udp,MOS Media Object Metadata Port,[Eric_Thorniley],[Eric_Thorniley],2007-09-17,,,,,
+MOS-upper,10541,tcp,MOS Running Order Port,[Eric_Thorniley],[Eric_Thorniley],2007-09-17,,,,,
+MOS-upper,10541,udp,MOS Running Order Port,[Eric_Thorniley],[Eric_Thorniley],2007-09-17,,,,,
+MOS-aux,10542,tcp,MOS Low Priority Port,[Eric_Thorniley],[Eric_Thorniley],2007-09-17,,,,,
+MOS-aux,10542,udp,MOS Low Priority Port,[Eric_Thorniley],[Eric_Thorniley],2007-09-17,,,,,
+MOS-soap,10543,tcp,MOS SOAP Default Port,[Eric_Thorniley],[Eric_Thorniley],2007-09-17,,,,,
+MOS-soap,10543,udp,MOS SOAP Default Port,[Eric_Thorniley],[Eric_Thorniley],2007-09-17,,,,,
+MOS-soap-opt,10544,tcp,MOS SOAP Optional Port,[Eric_Thorniley],[Eric_Thorniley],2007-09-17,,,,,
+MOS-soap-opt,10544,udp,MOS SOAP Optional Port,[Eric_Thorniley],[Eric_Thorniley],2007-09-17,,,,,
+,10545-10630,,Unassigned,,,,,,,,
+printopia,10631,tcp,"Port to allow for administration and control of ""Printopia"" application software,
+ which provides printing services to mobile users",[Ecamm_Network_LLC],[Chris_Kent],2011-10-24,,,,,
+,10631,udp,Reserved,,,,,,,,
+,10632-10799,,Unassigned,,,,,,,,
+gap,10800,tcp,Gestor de Acaparamiento para Pocket PCs,[Juan_Carlos_Olivares],[Juan_Carlos_Olivares],2006-03,,,,,
+gap,10800,udp,Gestor de Acaparamiento para Pocket PCs,[Juan_Carlos_Olivares],[Juan_Carlos_Olivares],2006-03,,,,,
+,10801-10804,,Unassigned,,,,,,,,
+lpdg,10805,tcp,LUCIA Pareja Data Group,[Alvaro_P_Dominguez],[Alvaro_P_Dominguez],2006-02,,,,,
+lpdg,10805,udp,LUCIA Pareja Data Group,[Alvaro_P_Dominguez],[Alvaro_P_Dominguez],2006-02,,,,,
+,10806-10808,,Unassigned,,,,,,,,
+nbd,10809,tcp,Linux Network Block Device,[Wouter_Verhelst],[Wouter_Verhelst],2010-08-02,,,,,
+,10809,udp,Reserved,,,,,,,,
+,10810,tcp,Reserved,,,,,,,,
+nmc-disc,10810,udp,Nuance Mobile Care Discovery,[Gordon_Waddell],[Gordon_Waddell],2011-03-21,,,,,
+,10811-10859,,Unassigned,,,,,,,,
+helix,10860,tcp,Helix Client/Server,[Matthew_Strange][Larry_Atkin_2],[Matthew_Strange][Larry_Atkin_2],2009-03-06,,,,,
+helix,10860,udp,Helix Client/Server,[Matthew_Strange][Larry_Atkin_2],[Matthew_Strange][Larry_Atkin_2],2009-03-06,,,,,
+,10861-10879,,Unassigned,,,,,,,,
+bveapi,10880,tcp,BVEssentials HTTP API,[Tri_Tech_Computers_Ltd],[James_Emerton],2012-11-19,,,,,
+bveapi,10880,udp,BVEssentials HTTP API,[Tri_Tech_Computers_Ltd],[James_Emerton],2012-11-19,,,,,
+,10881-10989,,Unassigned,,,,,,,,
+rmiaux,10990,tcp,Auxiliary RMI Port,[Eugen_Bacic_2],[Eugen_Bacic_2],,,,,,
+rmiaux,10990,udp,Auxiliary RMI Port,[Eugen_Bacic_2],[Eugen_Bacic_2],,,,,,
+,10991-10999,,Unassigned,,,,,,,,
+irisa,11000,tcp,IRISA,[V_A_Brauner],[V_A_Brauner],,,,,,
+irisa,11000,udp,IRISA,[V_A_Brauner],[V_A_Brauner],,,,,,
+metasys,11001,tcp,Metasys,[Tobin_Schuster],[Tobin_Schuster],,,,,,
+metasys,11001,udp,Metasys,[Tobin_Schuster],[Tobin_Schuster],,,,,,
+,11002-11022,,Unassigned,,,,,,,,
+cefd-vmp,10023,udp,Comtech EF-Data's Vipersat Management Protocol,[Comtech],[Nathan_Jeffords],2014-01-23,,,,,
+,10023,tcp,Reserved,,,,,,,,
+,11024-11094,,Unassigned,,,,,,,,
+weave,11095,tcp,Nest device-to-device and device-to-service application protocol,[Nest_Labs_Inc],[Grant_Erickson],2014-01-16,,,,,
+weave,11095,udp,Nest device-to-device and device-to-service application protocol,[Nest_Labs_Inc],[Grant_Erickson],2014-01-16,,,,,
+,11096-11102,,Unassigned,,,,,,,,
+origo-sync,11103,tcp,OrigoDB Server Sync Interface,[Devrex_Labs],[Robert_Friberg],2013-03-29,,,,,
+,11103,udp,Reserved,,,,,,,,
+netapp-icmgmt,11104,tcp,NetApp Intercluster Management,[Craig_Everhart],[Craig_Everhart],2010-07-06,,,,,
+,11104,udp,Reserved,,,,,,,,
+netapp-icdata,11105,tcp,NetApp Intercluster Data,[Craig_Everhart],[Craig_Everhart],2010-07-06,,,,,
+,11105,udp,Reserved,,,,,,,,
+sgi-lk,11106,tcp,SGI LK Licensing service,[Michel_Bourget],[Michel_Bourget],2009-01-06,,,,,
+sgi-lk,11106,udp,SGI LK Licensing service,[Michel_Bourget],[Michel_Bourget],2009-01-06,,,,,
+,11107,,Unassigned,,,,,,,,
+myq-termlink,11108,udp,Hardware Terminals Discovery and Low-Level Communication Protocol,[JANUS_spol],[Jakub_Ahmadyar],2013-04-23,,,,,
+,11108,tcp,Reserved,,,,,,,,
+sgi-dmfmgr,11109,tcp,Data migration facility Manager (DMF) is a browser based interface to DMF,[SGI],[John_Sygulla],2013-01-07,,,,,
+,11109,udp,Reserved,,,,,,,,
+sgi-soap,11110,tcp,Data migration facility (DMF) SOAP is a web server protocol to support remote access to DMF,[SGI],[John_Sygulla],2013-01-07,,,,,
+,11110,udp,Reserved,,,,,,,,
+vce,11111,tcp,Viral Computing Environment (VCE),[Fred_Cohen],[Fred_Cohen],,,,,,
+vce,11111,udp,Viral Computing Environment (VCE),[Fred_Cohen],[Fred_Cohen],,,,,,
+dicom,11112,tcp,DICOM,[David_Clunie],[David_Clunie],2005-08,,,,,
+dicom,11112,udp,DICOM,[David_Clunie],[David_Clunie],2005-08,,,,,
+,11113-11160,,Unassigned,,,,,,,,
+suncacao-snmp,11161,tcp,sun cacao snmp access point,[Nick_Stephen],[Nick_Stephen],2005-08,,,,,
+suncacao-snmp,11161,udp,sun cacao snmp access point,[Nick_Stephen],[Nick_Stephen],2005-08,,,,,
+suncacao-jmxmp,11162,tcp,sun cacao JMX-remoting access point,[Nick_Stephen],[Nick_Stephen],2005-08,,,,,
+suncacao-jmxmp,11162,udp,sun cacao JMX-remoting access point,[Nick_Stephen],[Nick_Stephen],2005-08,,,,,
+suncacao-rmi,11163,tcp,sun cacao rmi registry access point,[Nick_Stephen],[Nick_Stephen],2005-08,,,,,
+suncacao-rmi,11163,udp,sun cacao rmi registry access point,[Nick_Stephen],[Nick_Stephen],2005-08,,,,,
+suncacao-csa,11164,tcp,sun cacao command-streaming access point,[Nick_Stephen],[Nick_Stephen],2005-08,,,,,
+suncacao-csa,11164,udp,sun cacao command-streaming access point,[Nick_Stephen],[Nick_Stephen],2005-08,,,,,
+suncacao-websvc,11165,tcp,sun cacao web service access point,[Nick_Stephen],[Nick_Stephen],2005-08,,,,,
+suncacao-websvc,11165,udp,sun cacao web service access point,[Nick_Stephen],[Nick_Stephen],2005-08,,,,,
+,11166-11170,,Unassigned,,,,,,,,
+,11171,tcp,Reserved,,,,,,,,
+snss,11171,udp,Surgical Notes Security Service Discovery (SNSS),[David_Lethe],[David_Lethe],2010-12-24,,,,,
+oemcacao-jmxmp,11172,tcp,OEM cacao JMX-remoting access point,[David_Sechrest],[David_Sechrest],2010-09-22,,,,,
+,11172,udp,Reserved,,,,,,,,
+t5-straton,11173,tcp,Straton Runtime Programing,[COPALP],[Jerome_FOLLUT],2012-03-01,,,,,
+,11173,udp,Reserved,,,,,,,,
+oemcacao-rmi,11174,tcp,OEM cacao rmi registry access point,[David_Sechrest],[David_Sechrest],2010-09-22,,,,,
+,11174,udp,Reserved,,,,,,,,
+oemcacao-websvc,11175,tcp,OEM cacao web service access point,[David_Sechrest],[David_Sechrest],2010-09-22,,,,,
+,11175,udp,Reserved,,,,,,,,
+,11176-11200,,Unassigned,,,,,,,,
+smsqp,11201,tcp,smsqp,[Andres_Seco_Hernande],[Andres_Seco_Hernande],,,,,,
+smsqp,11201,udp,smsqp,[Andres_Seco_Hernande],[Andres_Seco_Hernande],,,,,,
+dcsl-backup,11202,tcp,DCSL Network Backup Services,[John_Reynolds],[John_Reynolds],2012-04-17,,,,,Defined TXT keys: DCSL-Service
+,11202,udp,Reserved,,,,,,,,
+,11203-11207,,Unassigned,,,,,,,,
+wifree,11208,tcp,WiFree Service,[Jose_Luis_Martin_Pei],[Jose_Luis_Martin_Pei],2006-03,,,,,
+wifree,11208,udp,WiFree Service,[Jose_Luis_Martin_Pei],[Jose_Luis_Martin_Pei],2006-03,,,,,
+,11209-11210,,Unassigned,,,,,,,,
+memcache,11211,tcp,Memory cache service,[Trond_Norbye],[Trond_Norbye],2009-02-09,,,,,
+memcache,11211,udp,Memory cache service,[Trond_Norbye],[Trond_Norbye],2009-02-09,,,,,
+,11212-11318,,Unassigned,,,,,,,,
+imip,11319,tcp,IMIP,[Len_Zuvela],[Len_Zuvela],,,,,,
+imip,11319,udp,IMIP,[Len_Zuvela],[Len_Zuvela],,,,,,
+imip-channels,11320,tcp,IMIP Channels Port,[Len_Zuvela_2],[Len_Zuvela_2],,,,,,
+imip-channels,11320,udp,IMIP Channels Port,[Len_Zuvela_2],[Len_Zuvela_2],,,,,,
+arena-server,11321,tcp,Arena Server Listen,[Earl_Brannigan],[Earl_Brannigan],,,,,,
+arena-server,11321,udp,Arena Server Listen,[Earl_Brannigan],[Earl_Brannigan],,,,,,
+,11322-11366,,Unassigned,,,,,,,,
+atm-uhas,11367,tcp,ATM UHAS,[Todd_Barker],[Todd_Barker],,,,,,
+atm-uhas,11367,udp,ATM UHAS,[Todd_Barker],[Todd_Barker],,,,,,
+,11368-11370,,Unassigned,,,,,,,,
+hkp,11371,tcp,OpenPGP HTTP Keyserver,[David_Shaw],[David_Shaw],2003-05,,,,,
+hkp,11371,udp,OpenPGP HTTP Keyserver,[David_Shaw],[David_Shaw],2003-05,,,,,
+,11372-11429,,Unassigned,,,,,,,,
+lsdp,11430,udp,Lenbrook Service Discovery Protocol,[Lenbrook_Industries_Limited],[Kevin_Groeneveld],2014-03-27,,,,,
+,11430,tcp,Reserved,,,,,,,,
+,11431-11488,,Unassigned,,,,,,,Known UNAUTHORIZED USE: port 11488,
+asgcypresstcps,11489,tcp,ASG Cypress Secure Only,[David_Luxford],[David_Luxford],2010-07-01,,,,,
+,11489,udp,Reserved,,,,,,,,
+,11490-11599,,Unassigned,,,,,,,,
+tempest-port,11600,tcp,Tempest Protocol Port,[Francis_Cianfrocca],[Francis_Cianfrocca],,,,,,
+tempest-port,11600,udp,Tempest Protocol Port,[Francis_Cianfrocca],[Francis_Cianfrocca],,,,,,
+,11601-11622,,Unassigned,,,,,,,,
+emc-xsw-dconfig,11623,tcp,EMC XtremSW distributed config,[EMC],[David_Erel],2013-09-18,,,,,
+,11623,udp,Reserved,,,,,,,,
+,11624-11719,,Unassigned,,,,,,,Unauthorized Use Known on port 11711,
+h323callsigalt,11720,tcp,H.323 Call Control Signalling Alternate,[ITU-T],[ITU-T_TSB],,2013-01-31,,,,
+h323callsigalt,11720,udp,H.323 Call Control Signalling Alternate,[ITU-T],[ITU-T_TSB],,2013-01-31,,,,
+,11721-11722,,Unassigned,,,,,,,,
+emc-xsw-dcache,11723,tcp,EMC XtremSW distributed cache,[EMC],[David_Erel],2013-09-18,,,,,
+emc-xsw-dcache,11723,udp,EMC XtremSW distributed cache,[EMC],[David_Erel],2013-09-18,,,,,
+,11724-11750,,Unassigned,,,,,,,,
+intrepid-ssl,11751,tcp,Intrepid SSL,[Robert_Eden],[Robert_Eden],2003-03,,,,,
+intrepid-ssl,11751,udp,Intrepid SSL,[Robert_Eden],[Robert_Eden],2003-03,,,,,
+,11752-11795,,Unassigned,,,,,,,,
+lanschool,11796,tcp,LanSchool,[Stoneware_Inc],[Dana_Doggett],2012-05-18,,,,,
+lanschool-mpt,11796,udp,Lanschool Multipoint,[Stoneware_Inc],[Dana_Doggett],2012-05-18,,,,,
+,11797-11875,,Unassigned,,,,,,,,
+xoraya,11876,tcp,X2E Xoraya Multichannel protocol,[Hannes_K],[Hannes_K],2010-09-13,,,,,
+xoraya,11876,udp,X2E Xoraya Multichannel protocol,[Hannes_K],[Hannes_K],2010-09-13,,,,,
+,11877,tcp,Reserved,,,,,,,,
+x2e-disc,11877,udp,X2E service discovery protocol,[Hannes_K],[Hannes_K],2010-09-13,,,,,
+,11878-11966,,Unassigned,,,,,,,,
+sysinfo-sp,11967,tcp,SysInfo Service Protocol,[Mike_Cooper],[Mike_Cooper],2003-03,,,,,
+sysinfo-sp,11967,udp,SysInfo Sercice Protocol,[Mike_Cooper],[Mike_Cooper],2003-03,,,,,
+,11968-11996,,Unassigned,,,,,,,,
+wmereceiving,11997,sctp,WorldMailExpress,[Greg_Foutz],[Greg_Foutz],2006-03,,,,,
+wmedistribution,11998,sctp,WorldMailExpress,[Greg_Foutz],[Greg_Foutz],2006-03,,,,,
+wmereporting,11999,sctp,WorldMailExpress,[Greg_Foutz],[Greg_Foutz],2006-03,,,,,
+entextxid,12000,tcp,IBM Enterprise Extender SNA XID Exchange,[Eugene_Cox],[Eugene_Cox],,,,,,
+entextxid,12000,udp,IBM Enterprise Extender SNA XID Exchange,[Eugene_Cox],[Eugene_Cox],,,,,,
+entextnetwk,12001,tcp,IBM Enterprise Extender SNA COS Network Priority,[Eugene_Cox],[Eugene_Cox],,,,,,
+entextnetwk,12001,udp,IBM Enterprise Extender SNA COS Network Priority,[Eugene_Cox],[Eugene_Cox],,,,,,
+entexthigh,12002,tcp,IBM Enterprise Extender SNA COS High Priority,[Eugene_Cox],[Eugene_Cox],,,,,,
+entexthigh,12002,udp,IBM Enterprise Extender SNA COS High Priority,[Eugene_Cox],[Eugene_Cox],,,,,,
+entextmed,12003,tcp,IBM Enterprise Extender SNA COS Medium Priority,[Eugene_Cox],[Eugene_Cox],,,,,,
+entextmed,12003,udp,IBM Enterprise Extender SNA COS Medium Priority,[Eugene_Cox],[Eugene_Cox],,,,,,
+entextlow,12004,tcp,IBM Enterprise Extender SNA COS Low Priority,[Eugene_Cox],[Eugene_Cox],,,,,,
+entextlow,12004,udp,IBM Enterprise Extender SNA COS Low Priority,[Eugene_Cox],[Eugene_Cox],,,,,,
+dbisamserver1,12005,tcp,DBISAM Database Server - Regular,[Tim_Young],[Tim_Young],2002-05,,,,,
+dbisamserver1,12005,udp,DBISAM Database Server - Regular,[Tim_Young],[Tim_Young],2002-05,,,,,
+dbisamserver2,12006,tcp,DBISAM Database Server - Admin,[Tim_Young],[Tim_Young],2002-05,,,,,
+dbisamserver2,12006,udp,DBISAM Database Server - Admin,[Tim_Young],[Tim_Young],2002-05,,,,,
+accuracer,12007,tcp,Accuracer Database System Server,[Alexander_V_Ivanov],[Alexander_V_Ivanov],2004-12,,,,,
+accuracer,12007,udp,Accuracer Database System Server,[Alexander_V_Ivanov],[Alexander_V_Ivanov],2004-12,,,,,
+accuracer-dbms,12008,tcp,Accuracer Database System Admin,[Alexander_V_Ivanov],[Alexander_V_Ivanov],2004-12,,,,,
+accuracer-dbms,12008,udp,Accuracer Database System Admin,[Alexander_V_Ivanov],[Alexander_V_Ivanov],2004-12,,,,,
+,12009,tcp,Reserved,,,,,,,,
+ghvpn,12009,udp,Green Hills VPN,[Green_Hills_Software],[Tom_R_Zavisca],2012-02-07,,,,,
+edbsrvr,12010,tcp,ElevateDB Server,[Tim_Young],[Tim_Young],2009-05-06,,,,,
+,12010,udp,Reserved,,,,,,,,
+,12011,,Unassigned,,,,,,,,
+vipera,12012,tcp,Vipera Messaging Service,[Silvano_Maffeis_2],[Silvano_Maffeis_2],2005-08,,,,,
+vipera,12012,udp,Vipera Messaging Service,[Silvano_Maffeis_2],[Silvano_Maffeis_2],2005-08,,,,,
+vipera-ssl,12013,tcp,Vipera Messaging Service over SSL Communication,[Silvano_Maffeis_2],[Silvano_Maffeis_2],2008-01-16,,,,,
+vipera-ssl,12013,udp,Vipera Messaging Service over SSL Communication,[Silvano_Maffeis_2],[Silvano_Maffeis_2],2008-01-16,,,,,
+,12014-12108,,Unassigned,,,,,,,,
+rets-ssl,12109,tcp,RETS over SSL,[Bruce_Toback],[Bruce_Toback],2003-02,,,,,
+rets-ssl,12109,udp,RETS over SSL,[Bruce_Toback],[Bruce_Toback],2003-02,,,,,
+,12110-12120,,Unassigned,,,,,,,,
+nupaper-ss,12121,tcp,NuPaper Session Service,[David_Warden_2],[David_Warden_2],2005-11,,,,,
+nupaper-ss,12121,udp,NuPaper Session Service,[David_Warden_2],[David_Warden_2],2005-11,,,,,
+,12122-12167,,Unassigned,,,,,,,,
+cawas,12168,tcp,CA Web Access Service,[Jon_Press],[Jon_Press],2005-08,,,,,
+cawas,12168,udp,CA Web Access Service,[Jon_Press],[Jon_Press],2005-08,,,,,
+,12169-12171,,Unassigned,,,,,,,,
+hivep,12172,tcp,HiveP,[Dick_Augustsson],[Dick_Augustsson],,,,,,
+hivep,12172,udp,HiveP,[Dick_Augustsson],[Dick_Augustsson],,,,,,
+,12173-12299,,Unassigned,,,,,,,,
+linogridengine,12300,tcp,LinoGrid Engine,[Frans_Lundberg],[Frans_Lundberg],2004-11,,,,,
+linogridengine,12300,udp,LinoGrid Engine,[Frans_Lundberg],[Frans_Lundberg],2004-11,,,,,
+,12301,,Unassigned,,,,,,,,
+rads,12302,tcp,"Remote Administration Daemon (RAD) is a system service that offers secure, remote, programmatic access to Solaris system configuration and run-time state",[Oracle],[Devjani_Ray],2012-04-20,,,,,
+,12302,udp,Reserved,,,,,,,,
+,12303-12320,,Unassigned,,,,,,,,
+warehouse-sss,12321,tcp,Warehouse Monitoring Syst SSS,[Craig_Steffen],[Craig_Steffen],2005-08,,,,,
+warehouse-sss,12321,udp,Warehouse Monitoring Syst SSS,[Craig_Steffen],[Craig_Steffen],2005-08,,,,,
+warehouse,12322,tcp,Warehouse Monitoring Syst,[Craig_Steffen],[Craig_Steffen],2005-08,,,,,
+warehouse,12322,udp,Warehouse Monitoring Syst,[Craig_Steffen],[Craig_Steffen],2005-08,,,,,
+,12323-12344,,Unassigned,,,,,,,,
+italk,12345,tcp,Italk Chat System,[Takayuki_Ito],[Takayuki_Ito],,,,,,
+italk,12345,udp,Italk Chat System,[Takayuki_Ito],[Takayuki_Ito],,,,,,
+,12346-12752,,Unassigned,,,,,,,,
+tsaf,12753,tcp,tsaf port,[Andreas_Fehr],[Andreas_Fehr],,,,,,
+tsaf,12753,udp,tsaf port,[Andreas_Fehr],[Andreas_Fehr],,,,,,
+,12754-12864,,Unassigned,,,,,,,,
+netperf,12865,tcp,control port for the netperf benchmark,[netperf.org],[rick_jones],2013-04-05,,,,,
+,12865,udp,Reserved,,,,,,,,
+,12866-13159,,Unassigned,,,,,,,,
+i-zipqd,13160,tcp,I-ZIPQD,[Chuck_Runquist],[Chuck_Runquist],,,,,,
+i-zipqd,13160,udp,I-ZIPQD,[Chuck_Runquist],[Chuck_Runquist],,,,,,
+,13161-13215,,Unassigned,,,,,,,,
+bcslogc,13216,tcp,Black Crow Software application logging,[Ramindur_Singh],[Ramindur_Singh],2008-12-04,,,,,
+bcslogc,13216,udp,Black Crow Software application logging,[Ramindur_Singh],[Ramindur_Singh],2008-12-04,,,,,
+rs-pias,13217,tcp,R&S Proxy Installation Assistant Service,[Guido_Kiener],[Guido_Kiener],2008-12-04,,,,,
+rs-pias,13217,udp,R&S Proxy Installation Assistant Service,[Guido_Kiener],[Guido_Kiener],2008-12-04,,,,,
+emc-vcas-tcp,13218,tcp,EMC Virtual CAS Service,,,,,,,,
+emc-vcas-udp,13218,udp,EMV Virtual CAS Service Discovery,[Mark_O_Connell],[Mark_O_Connell],2008-12-04,,,,,
+,13219-13222,,Unassigned,,,,,,,,
+powwow-client,13223,tcp,PowWow Client,[Paul_K_Peterson],[Paul_K_Peterson],,,,,,
+powwow-client,13223,udp,PowWow Client,[Paul_K_Peterson],[Paul_K_Peterson],,,,,,
+powwow-server,13224,tcp,PowWow Server,[Paul_K_Peterson],[Paul_K_Peterson],,,,,,
+powwow-server,13224,udp,PowWow Server,[Paul_K_Peterson],[Paul_K_Peterson],,,,,,
+,13225-13399,,Unassigned,,,,,,,,
+doip-data,13400,tcp,DoIP Data,[Joerg_Schneider],[Joerg_Schneider],2011-01-26,,,,,
+doip-disc,13400,udp,DoIP Discovery,[Joerg_Schneider],[Joerg_Schneider],2011-01-26,,,,,
+,13401-13719,,Unassigned,,,,,,,,
+bprd,13720,tcp,BPRD Protocol (VERITAS NetBackup),[Jeff_Holmbeck],[Jeff_Holmbeck],,,,,,
+bprd,13720,udp,BPRD Protocol (VERITAS NetBackup),[Jeff_Holmbeck],[Jeff_Holmbeck],,,,,,
+bpdbm,13721,tcp,BPDBM Protocol (VERITAS NetBackup),[Jeff_Holmbeck],[Jeff_Holmbeck],,,,,,
+bpdbm,13721,udp,BPDBM Protocol (VERITAS NetBackup),[Jeff_Holmbeck],[Jeff_Holmbeck],,,,,,
+bpjava-msvc,13722,tcp,BP Java MSVC Protocol,[Tim_Schmidt],[Tim_Schmidt],,,,,,
+bpjava-msvc,13722,udp,BP Java MSVC Protocol,[Tim_Schmidt],[Tim_Schmidt],,,,,,
+,13723,,Unassigned,,,,,,,,
+vnetd,13724,tcp,Veritas Network Utility,[Jeff_Holmbeck],[Jeff_Holmbeck],,,,,,
+vnetd,13724,udp,Veritas Network Utility,[Jeff_Holmbeck],[Jeff_Holmbeck],,,,,,
+,13725-13781,,Unassigned,,,,,,,,
+bpcd,13782,tcp,VERITAS NetBackup,[Jeff_Holmbeck],[Jeff_Holmbeck],,,,,,
+bpcd,13782,udp,VERITAS NetBackup,[Jeff_Holmbeck],[Jeff_Holmbeck],,,,,,
+vopied,13783,tcp,VOPIED Protocol,[Jeff_Holmbeck],[Jeff_Holmbeck],,,,,,
+vopied,13783,udp,VOPIED Protocol,[Jeff_Holmbeck],[Jeff_Holmbeck],,,,,,
+,13784,,Unassigned,,,,,,,,
+nbdb,13785,tcp,NetBackup Database,[Pat_Tovo],[Pat_Tovo],2004-12,,,,,
+nbdb,13785,udp,NetBackup Database,[Pat_Tovo],[Pat_Tovo],2004-12,,,,,
+nomdb,13786,tcp,Veritas-nomdb,[Clayton_Haapala],[Clayton_Haapala],2005-08,,,,,
+nomdb,13786,udp,Veritas-nomdb,[Clayton_Haapala],[Clayton_Haapala],2005-08,,,,,
+,13787-13817,,Unassigned,,,,,,,,
+dsmcc-config,13818,tcp,DSMCC Config,[Tim_Addington],[Tim_Addington],,,[ISO/IEC 13818-6 MPEG-2 DSM-CC],,,
+dsmcc-config,13818,udp,DSMCC Config,[Tim_Addington],[Tim_Addington],,,[ISO/IEC 13818-6 MPEG-2 DSM-CC],,,
+dsmcc-session,13819,tcp,DSMCC Session Messages,[Tim_Addington],[Tim_Addington],,,[ISO/IEC 13818-6 MPEG-2 DSM-CC],,,
+dsmcc-session,13819,udp,DSMCC Session Messages,[Tim_Addington],[Tim_Addington],,,[ISO/IEC 13818-6 MPEG-2 DSM-CC],,,
+dsmcc-passthru,13820,tcp,DSMCC Pass-Thru Messages,[Tim_Addington],[Tim_Addington],,,[ISO/IEC 13818-6 MPEG-2 DSM-CC],,,
+dsmcc-passthru,13820,udp,DSMCC Pass-Thru Messages,[Tim_Addington],[Tim_Addington],,,[ISO/IEC 13818-6 MPEG-2 DSM-CC],,,
+dsmcc-download,13821,tcp,DSMCC Download Protocol,[Tim_Addington],[Tim_Addington],,,[ISO/IEC 13818-6 MPEG-2 DSM-CC],,,
+dsmcc-download,13821,udp,DSMCC Download Protocol,[Tim_Addington],[Tim_Addington],,,[ISO/IEC 13818-6 MPEG-2 DSM-CC],,,
+dsmcc-ccp,13822,tcp,DSMCC Channel Change Protocol,[Tim_Addington],[Tim_Addington],,,[ISO/IEC 13818-6 MPEG-2 DSM-CC],,,
+dsmcc-ccp,13822,udp,DSMCC Channel Change Protocol,[Tim_Addington],[Tim_Addington],,,[ISO/IEC 13818-6 MPEG-2 DSM-CC],,,
+bmdss,13823,tcp,Blackmagic Design Streaming Server,[Sam_Vaughan],[Sam_Vaughan],2011-03-01,,,,,
+,13823,udp,Reserved,,,,,,,,
+,13824-13893,,Unassigned,,,,,,,,
+ucontrol,13894,tcp,Ultimate Control communication protocol,[NEGU_Soft],[borja_lopez_urkidi],2012-09-10,,,,,
+ucontrol,13894,udp,Ultimate Control communication protocol,[NEGU_Soft],[borja_lopez_urkidi],2012-09-10,,,,,
+,13895-13928,,Unassigned,,,,,,,,
+dta-systems,13929,tcp,D-TA SYSTEMS,[Alexis_Bose],[Alexis_Bose],2008-12-08,,,,,
+dta-systems,13929,udp,D-TA SYSTEMS,[Alexis_Bose],[Alexis_Bose],2008-12-08,,,,,
+medevolve,13930,tcp,MedEvolve Port Requester,[Jon_Robertson],[Jon_Robertson],2008-10-24,,,,,
+,13930,udp,Reserved,,,,,,,,
+,13931-13999,,Unassigned,,,,,,,,
+scotty-ft,14000,tcp,SCOTTY High-Speed Filetransfer,[Patrick_Verbeek],[Patrick_Verbeek],2007-05,,,,,
+scotty-ft,14000,udp,SCOTTY High-Speed Filetransfer,[Patrick_Verbeek],[Patrick_Verbeek],2007-05,,,,,
+sua,14001,tcp,SUA,[Miguel_Angel_Garcia],[Miguel_Angel_Garcia],,,,,,
+sua,14001,udp,De-Registered,[Miguel_Angel_Garcia],[Miguel_Angel_Garcia],2001-06-06,,,,,
+sua,14001,sctp,SUA,[Miguel_Angel_Garcia],[Miguel_Angel_Garcia],,,,,,
+scotty-disc,14002,udp,Discovery of a SCOTTY hardware codec board,[SCOTTY_Group_SE],[Patrick_Verbeek_2],2013-01-14,,,,,
+,14002,tcp,Reserved,,,,,,,,
+,14003-14032,,Unassigned,,,,,,,,
+sage-best-com1,14033,tcp,sage Best! Config Server 1,[Christian_Rubach],[Christian_Rubach],,,,,,
+sage-best-com1,14033,udp,sage Best! Config Server 1,[Christian_Rubach],[Christian_Rubach],,,,,,
+sage-best-com2,14034,tcp,sage Best! Config Server 2,[Christian_Rubach],[Christian_Rubach],,,,,,
+sage-best-com2,14034,udp,sage Best! Config Server 2,[Christian_Rubach],[Christian_Rubach],,,,,,
+,14035-14140,,Unassigned,,,,,,,,
+vcs-app,14141,tcp,VCS Application,[Ming_Xu],[Ming_Xu],,,,,,
+vcs-app,14141,udp,VCS Application,[Ming_Xu],[Ming_Xu],,,,,,
+icpp,14142,tcp,IceWall Cert Protocol,[Tsutomu_Fujinami],[Tsutomu_Fujinami],2005-08,,,,,
+icpp,14142,udp,IceWall Cert Protocol,[Tsutomu_Fujinami],[Tsutomu_Fujinami],2005-08,,,,,
+,14143-14144,,Unassigned,,,,,,,,
+gcm-app,14145,tcp,GCM Application,[Ming_Xu],[Ming_Xu],,,,,,
+gcm-app,14145,udp,GCM Application,[Ming_Xu],[Ming_Xu],,,,,,
+,14146-14148,,Unassigned,,,,,,,,
+vrts-tdd,14149,tcp,Veritas Traffic Director,[Sameer_Deokule],[Sameer_Deokule],2002-03,,,,,
+vrts-tdd,14149,udp,Veritas Traffic Director,[Sameer_Deokule],[Sameer_Deokule],2002-03,,,,,
+vcscmd,14150,tcp,Veritas Cluster Server Command Server,[Anand_Bhalerao],[Anand_Bhalerao],2008-10-02,,,,,
+,14150,udp,Reserved,,,,,,,,
+,14151-14153,,Unassigned,,,,,,,,
+vad,14154,tcp,Veritas Application Director,[Rajeev_Verma],[Rajeev_Verma],2006-02,,,,,
+vad,14154,udp,Veritas Application Director,[Rajeev_Verma],[Rajeev_Verma],2006-02,,,,,
+,14155-14249,,Unassigned,,,,,,,,
+cps,14250,tcp,Fencing Server,[Mayank_Vasa],[Mayank_Vasa],2008-04-03,,,,,
+cps,14250,udp,Fencing Server,[Mayank_Vasa],[Mayank_Vasa],2008-04-03,,,,,
+,14251-14413,,Unassigned,,,,,,,,
+ca-web-update,14414,tcp,CA eTrust Web Update Service,[Robert_Ciochon],[Robert_Ciochon],2006-08,,,,,
+ca-web-update,14414,udp,CA eTrust Web Update Service,[Robert_Ciochon],[Robert_Ciochon],2006-08,,,,,
+,14415-14935,,Unassigned,,,,,,,,
+hde-lcesrvr-1,14936,tcp,hde-lcesrvr-1,[Horizon_Digital_Ente],[Horizon_Digital_Ente],,,,,,
+hde-lcesrvr-1,14936,udp,hde-lcesrvr-1,[Horizon_Digital_Ente],[Horizon_Digital_Ente],,,,,,
+hde-lcesrvr-2,14937,tcp,hde-lcesrvr-2,[Horizon_Digital_Ente],[Horizon_Digital_Ente],,,,,,
+hde-lcesrvr-2,14937,udp,hde-lcesrvr-2,[Horizon_Digital_Ente],[Horizon_Digital_Ente],,,,,,
+,14938-14999,,Unassigned,,,,,,,,
+hydap,15000,tcp,Hypack Data Aquisition,[HYPACK_Inc],[Mircea_Neacsu],,2011-10-27,,,,
+hydap,15000,udp,Hypack Data Aquisition,[HYPACK_Inc],[Mircea_Neacsu],,2011-10-27,,,,
+,15001,,Unassigned,,,,,,,,
+onep-tls,15002,tcp,Open Network Environment TLS,[Cisco_3],[Andrew_Thurber],2014-01-21,,,,,
+,15002,udp,Reserved,,,,,,,,
+,15003-15117,,Unassigned,,,,,,,,
+,15118,tcp,Reserved,,,,,,,,
+v2g-secc,15118,udp,v2g Supply Equipment Communication Controller Discovery Protocol,[Holger_Lochner],[Holger_Lochner],2011-04-06,,,,,
+,15119-15344,,Unassigned,,,,,,,,
+xpilot,15345,tcp,XPilot Contact Port,[Bert_Gijsbers],[Bert_Gijsbers],,,,,,
+xpilot,15345,udp,XPilot Contact Port,[Bert_Gijsbers],[Bert_Gijsbers],,,,,,
+,15346-15362,,Unassigned,,,,,,,,
+3link,15363,tcp,3Link Negotiation,[Brant_Thomsen],[Brant_Thomsen],2003-01,,,,,
+3link,15363,udp,3Link Negotiation,[Brant_Thomsen],[Brant_Thomsen],2003-01,,,,,
+,15364-15554,,Unassigned,,,,,,,,
+cisco-snat,15555,tcp,Cisco Stateful NAT,[Kaushik_Biswas],[Kaushik_Biswas],2006-03,,,,,
+cisco-snat,15555,udp,Cisco Stateful NAT,[Kaushik_Biswas],[Kaushik_Biswas],2006-03,,,,,
+,15556-15659,,Unassigned,,,,,,,,
+bex-xr,15660,tcp,Backup Express Restore Server,[Chi_Shih_Chang],[Chi_Shih_Chang],2008-03-19,,,,,
+bex-xr,15660,udp,Backup Express Restore Server,[Chi_Shih_Chang],[Chi_Shih_Chang],2008-03-19,,,,,
+,15661-15739,,Unassigned,,,,,,,,
+ptp,15740,tcp,Picture Transfer Protocol,[Petronel_Bigioi],[Petronel_Bigioi],2004-11,,,,,Defined TXT keys: guid=<Device guid>
+ptp,15740,udp,Picture Transfer Protocol,[Petronel_Bigioi],[Petronel_Bigioi],2004-11,,,,,Defined TXT keys: guid=<Device guid>
+,15741-15997,,Unassigned,,,,,,,,
+,15998,tcp,Reserved,,,,,,,,
+2ping,15998,udp,2ping Bi-Directional Ping Service,[Ryan_Finnie],[Ryan_Finnie],2010-10-06,,,,,
+programmar,15999,tcp,ProGrammar Enterprise,[Norman_Wilson],[Norman_Wilson],2010-10-06,,,,,
+,15999,udp,Reserved,,,,,,,,
+fmsas,16000,tcp,Administration Server Access,[Mark_Davidson],[Mark_Davidson],2010-10-06,,,,Known Unauthorized Use on port 16000,
+,16000,udp,Reserved,,,,,,,Known Unauthorized Use on port 16000,
+fmsascon,16001,tcp,Administration Server Connector,[Mark_Davidson],[Mark_Davidson],2010-10-06,,,,,
+,16001,udp,Reserved,,,,,,,,
+gsms,16002,tcp,GoodSync Mediation Service,[Vadim_Maslov],[Vadim_Maslov],2010-10-06,,,,,
+,16002,udp,Reserved,,,,,,,,
+,16003,tcp,Reserved,,,,,,,,
+alfin,16003,udp,Automation and Control by REGULACE.ORG,[Ing_Tomas_Halabala],[Ing_Tomas_Halabala],2010-10-06,,,,,
+,16004-16019,,Unassigned,,,,,,,,
+jwpc,16020,tcp,Filemaker Java Web Publishing Core,[Robert_Parks],[Robert_Parks],2010-05-12,,,,,
+,16020,udp,Reserved,,,,,,,,
+jwpc-bin,16021,tcp,Filemaker Java Web Publishing Core Binary,[Robert_Parks],[Robert_Parks],2010-05-12,,,,,
+,16021,udp,Reserved,,,,,,,,
+,16022-16160,,Unassigned,,,,,,,,
+sun-sea-port,16161,tcp,Solaris SEA Port,[Dana_Porter],[Dana_Porter],2003-10,,,,,
+sun-sea-port,16161,udp,Solaris SEA Port,[Dana_Porter],[Dana_Porter],2003-10,,,,,
+solaris-audit,16162,tcp,Solaris Audit - secure remote audit log,[Jan_Friedel],[Jan_Friedel],2009-05-07,,,,,
+,16162,udp,Reserved,,,,,,,,
+,16163-16308,,Unassigned,,,,,,,,
+etb4j,16309,tcp,etb4j,[Christopher_R_Smith],[Christopher_R_Smith],2004-11,,,,,
+etb4j,16309,udp,etb4j,[Christopher_R_Smith],[Christopher_R_Smith],2004-11,,,,,
+pduncs,16310,tcp,"Policy Distribute, Update Notification",[Diane_I_Shannon],[Diane_I_Shannon],2006-08,,,,,
+pduncs,16310,udp,"Policy Distribute, Update Notification",[Diane_I_Shannon],[Diane_I_Shannon],2006-08,,,,,
+pdefmns,16311,tcp,Policy definition and update management,[Diane_I_Shannon],[Diane_I_Shannon],2007-04,,,,,
+pdefmns,16311,udp,Policy definition and update management,[Diane_I_Shannon],[Diane_I_Shannon],2007-04,,,,,
+,16312-16359,,Unassigned,,,,,,,,
+netserialext1,16360,tcp,Network Serial Extension Ports One,[Michael_J_Hoy],[Michael_J_Hoy],,,,,,
+netserialext1,16360,udp,Network Serial Extension Ports One,[Michael_J_Hoy],[Michael_J_Hoy],,,,,,
+netserialext2,16361,tcp,Network Serial Extension Ports Two,[Michael_J_Hoy],[Michael_J_Hoy],,,,,,
+netserialext2,16361,udp,Network Serial Extension Ports Two,[Michael_J_Hoy],[Michael_J_Hoy],,,,,,
+,16362-16366,,Unassigned,,,,,,,,
+netserialext3,16367,tcp,Network Serial Extension Ports Three,[Michael_J_Hoy],[Michael_J_Hoy],,,,,,
+netserialext3,16367,udp,Network Serial Extension Ports Three,[Michael_J_Hoy],[Michael_J_Hoy],,,,,,
+netserialext4,16368,tcp,Network Serial Extension Ports Four,[Michael_J_Hoy],[Michael_J_Hoy],,,,,,
+netserialext4,16368,udp,Network Serial Extension Ports Four,[Michael_J_Hoy],[Michael_J_Hoy],,,,,,
+,16369-16383,,Unassigned,,,,,,,,
+connected,16384,tcp,Connected Corp,[Nicole_C_Ouellette],[Nicole_C_Ouellette],2004-02,,,,,
+connected,16384,udp,Connected Corp,[Nicole_C_Ouellette],[Nicole_C_Ouellette],2004-02,,,,,
+,16385-16618,,Unassigned,,,,,,,,
+xoms,16619,tcp,X509 Objects Management Service,[Francis_GASCHET],[Francis_GASCHET],2008-09-08,,,,,
+,16619,udp,Reserved,,,,,,,,
+,16620-16664,,Unassigned,,,,,,,,
+axon-tunnel,16665,tcp,Reliable multipath data transport for high latencies,[Bridgeworks],[Paul_Burgess],2014-09-26,,,,,
+,16665,udp,Reserved,,,,,,,,
+,16666,tcp,Reserved,,,,,,,,
+vtp,16666,udp,Vidder Tunnel Protocol,[Vidder_Inc],[Ted_Schroeder_2],2011-10-24,,,,,
+,16667-16899,,Unassigned,,,,,,,,
+newbay-snc-mc,16900,tcp,Newbay Mobile Client Update Service,[Srinivasa_Nayudu],[Srinivasa_Nayudu],2009-07-06,,,,,
+newbay-snc-mc,16900,udp,Newbay Mobile Client Update Service,[Srinivasa_Nayudu],[Srinivasa_Nayudu],2009-07-06,,,,,
+,16901-16949,,Unassigned,,,,,,,,
+sgcip,16950,tcp,Simple Generic Client Interface Protocol,[John_Aquilino],[John_Aquilino],,,,,,
+sgcip,16950,udp,Simple Generic Client Interface Protocol,[John_Aquilino],[John_Aquilino],,,,,,
+,16951-16990,,Unassigned,,,,,,,,
+intel-rci-mp,16991,tcp,INTEL-RCI-MP,[Jane_Dashevsky],[Jane_Dashevsky],,,,,,
+intel-rci-mp,16991,udp,INTEL-RCI-MP,[Jane_Dashevsky],[Jane_Dashevsky],,,,,,
+amt-soap-http,16992,tcp,Intel(R) AMT SOAP/HTTP,[David_T_Hines],[David_T_Hines],2005-02,,,,,
+amt-soap-http,16992,udp,Intel(R) AMT SOAP/HTTP,[David_T_Hines],[David_T_Hines],2005-02,,,,,
+amt-soap-https,16993,tcp,Intel(R) AMT SOAP/HTTPS,[David_T_Hines],[David_T_Hines],2005-02,,,,,
+amt-soap-https,16993,udp,Intel(R) AMT SOAP/HTTPS,[David_T_Hines],[David_T_Hines],2005-02,,,,,
+amt-redir-tcp,16994,tcp,Intel(R) AMT Redirection/TCP,[Nimrod_Diamant],[Nimrod_Diamant],2005-02,,,,,
+amt-redir-tcp,16994,udp,Intel(R) AMT Redirection/TCP,[Nimrod_Diamant],[Nimrod_Diamant],2005-02,,,,,
+amt-redir-tls,16995,tcp,Intel(R) AMT Redirection/TLS,[Nimrod_Diamant],[Nimrod_Diamant],2005-02,,,,,
+amt-redir-tls,16995,udp,Intel(R) AMT Redirection/TLS,[Nimrod_Diamant],[Nimrod_Diamant],2005-02,,,,,
+,16996-17006,,Unassigned,,,,,,,,
+isode-dua,17007,tcp,,,,,,,,,
+isode-dua,17007,udp,,,,,,,,,
+,17008-17183,,Unassigned,,,,,,,,
+vestasdlp,17184,tcp,Vestas Data Layer Protocol,[Vestas_Wind_Systems],[Teunis_de_Wit],2013-10-30,,,,,
+,17184,udp,Reserved,,,,,,,,
+soundsvirtual,17185,tcp,Sounds Virtual,[Richard_Snider],[Richard_Snider],,,,,,
+soundsvirtual,17185,udp,Sounds Virtual,[Richard_Snider],[Richard_Snider],,,,,,
+,17186-17218,,Unassigned,,,,,,,,
+chipper,17219,tcp,Chipper,[Ronald_Jimmink],[Ronald_Jimmink],,,,,,
+chipper,17219,udp,Chipper,[Ronald_Jimmink],[Ronald_Jimmink],,,,,,
+avtp,17220,tcp,IEEE 1722 Transport Protocol for Time Sensitive Applications,[Transport_Protocol_for_Time-Sensitive_Networking_TG],[Ashley_Butterworth],2014-03-07,,,,,
+avtp,17220,udp,IEEE 1722 Transport Protocol for Time Sensitive Applications,[Transport_Protocol_for_Time-Sensitive_Networking_TG],[Ashley_Butterworth],2014-03-07,,,,,
+avdecc,17221,tcp,"IEEE 1722.1 AVB Discovery, Enumeration, Connection management, and Control",[IEEE_1722_1],[Jeffrey_Daniel_Koftinoff],2011-11-01,,,,,
+avdecc,17221,udp,"IEEE 1722.1 AVB Discovery, Enumeration, Connection management, and Control",[IEEE_1722_1],[Jeffrey_Daniel_Koftinoff],2011-11-01,,,,,
+,17222,tcp,Reserved,,,,,,,,
+cpsp,17222,udp,Control Plane Synchronization Protocol (SPSP),[Randall_Stewart_2],[Randall_Stewart_2],2011-11-10,,,,,
+,17223-17233,,Unassigned,,,,,,,,
+integrius-stp,17234,tcp,Integrius Secure Tunnel Protocol,[Christian_Klemetsson],[Christian_Klemetsson],2010-03-04,,,,,
+integrius-stp,17234,udp,Integrius Secure Tunnel Protocol,[Christian_Klemetsson],[Christian_Klemetsson],2010-03-04,,,,,
+ssh-mgmt,17235,tcp,SSH Tectia Manager,[Ville_Laurikari],[Ville_Laurikari],2005-08,,,,,
+ssh-mgmt,17235,udp,SSH Tectia Manager,[Ville_Laurikari],[Ville_Laurikari],2005-08,,,,,
+,17236-17499,,Unassigned,,,,,,,,
+db-lsp,17500,tcp,Dropbox LanSync Protocol,[Paul_Bohm],[Paul_Bohm],2010-01-21,,,,,
+db-lsp-disc,17500,udp,Dropbox LanSync Discovery,[Paul_Bohm],[Paul_Bohm],2010-01-21,,,,,
+,17501-17554,,Unassigned,,,,,,,,
+ailith,17555,tcp,Ailith management of routers,[Thomas_Boje],[Thomas_Boje],2014-03-27,,,,,
+,17555,udp,Reserved,,,,,,,,
+,17556-17728,,Unassigned,,,,,,,,
+ea,17729,tcp,Eclipse Aviation,[William_Schmidt],[William_Schmidt],2006-03,,,,,
+ea,17729,udp,Eclipse Aviation,[William_Schmidt],[William_Schmidt],2006-03,,,,,
+,17730-17753,,Unassigned,,,,,,,,
+zep,17754,tcp,Encap. ZigBee Packets,[Fred_Fierling],[Fred_Fierling],2006-02,,,,,
+zep,17754,udp,Encap. ZigBee Packets,[Fred_Fierling],[Fred_Fierling],2006-02,,,,,
+zigbee-ip,17755,tcp,ZigBee IP Transport Service,[Chris_Herzog],[Chris_Herzog],2006-05,,,,,
+zigbee-ip,17755,udp,ZigBee IP Transport Service,[Chris_Herzog],[Chris_Herzog],2006-05,,,,,
+zigbee-ips,17756,tcp,ZigBee IP Transport Secure Service,[Chris_Herzog],[Chris_Herzog],2006-05,,,,,
+zigbee-ips,17756,udp,ZigBee IP Transport Secure Service,[Chris_Herzog],[Chris_Herzog],2006-05,,,,,
+,17757-17776,,Unassigned,,,,,,,,
+sw-orion,17777,tcp,SolarWinds Orion,[Joel_Dolisy],[Joel_Dolisy],2008-09-10,,,,,
+,17777,udp,Reserved,,,,,,,,
+,17778-17999,,Unassigned,,,,,,,,
+biimenu,18000,tcp,"Beckman Instruments, Inc.",[R_L_Meyering],[R_L_Meyering],,,,,,
+biimenu,18000,udp,"Beckman Instruments, Inc.",[R_L_Meyering],[R_L_Meyering],,,,,,
+,18001-18103,,Unassigned,,,,,,,,
+radpdf,18104,tcp,RAD PDF Service,[Christopher_Truxaw],[Christopher_Truxaw],2010-10-15,,,,,
+,18104,udp,Reserved,,,,,,,,
+,18105-18135,,Unassigned,,,,,,,,
+racf,18136,tcp,z/OS Resource Access Control Facility,[Bruce_Wells],[Bruce_Wells],2010-10-04,,,,,
+,18136,udp,Reserved,,,,,,,,
+,18137-18180,,Unassigned,,,,,,,,
+opsec-cvp,18181,tcp,OPSEC CVP,[Alon_Kantor],[Alon_Kantor],,,,,,
+opsec-cvp,18181,udp,OPSEC CVP,[Alon_Kantor],[Alon_Kantor],,,,,,
+opsec-ufp,18182,tcp,OPSEC UFP,[Alon_Kantor],[Alon_Kantor],,,,,,
+opsec-ufp,18182,udp,OPSEC UFP,[Alon_Kantor],[Alon_Kantor],,,,,,
+opsec-sam,18183,tcp,OPSEC SAM,[Alon_Kantor],[Alon_Kantor],,,,,,
+opsec-sam,18183,udp,OPSEC SAM,[Alon_Kantor],[Alon_Kantor],,,,,,
+opsec-lea,18184,tcp,OPSEC LEA,[Alon_Kantor],[Alon_Kantor],,,,,,
+opsec-lea,18184,udp,OPSEC LEA,[Alon_Kantor],[Alon_Kantor],,,,,,
+opsec-omi,18185,tcp,OPSEC OMI,[Alon_Kantor],[Alon_Kantor],,,,,,
+opsec-omi,18185,udp,OPSEC OMI,[Alon_Kantor],[Alon_Kantor],,,,,,
+ohsc,18186,tcp,Occupational Health SC,[David_Fudge],[David_Fudge],2003-08,,,,,
+ohsc,18186,udp,Occupational Health Sc,[David_Fudge],[David_Fudge],2003-08,,,,,
+opsec-ela,18187,tcp,OPSEC ELA,[Alon_Kantor],[Alon_Kantor],,,,,,
+opsec-ela,18187,udp,OPSEC ELA,[Alon_Kantor],[Alon_Kantor],,,,,,
+,18188-18240,,Unassigned,,,,,,,,
+checkpoint-rtm,18241,tcp,Check Point RTM,[Dudi_Hazan],[Dudi_Hazan],,,,,,
+checkpoint-rtm,18241,udp,Check Point RTM,[Dudi_Hazan],[Dudi_Hazan],,,,,,
+iclid,18242,tcp,Checkpoint router monitoring,[Check_Point_Software],[Rahul_Bahadur],2012-06-28,,,,,
+,18242,udp,Reserved,,,,,,,,
+clusterxl,18243,tcp,Checkpoint router state backup,[Check_Point_Software],[Rahul_Bahadur],2012-06-28,,,,,
+,18243,udp,Reserved,,,,,,,,
+,18244-18261,,Unassigned,,,,,,,,
+gv-pf,18262,tcp,GV NetConfig Service,[Scott_Libert],[Scott_Libert],2008-01-29,,,,,
+gv-pf,18262,udp,GV NetConfig Service,[Scott_Libert],[Scott_Libert],2008-01-29,,,,,
+,18263-18462,,Unassigned,,,,,,,,
+ac-cluster,18463,tcp,AC Cluster,[Lisa_Zhong],[Lisa_Zhong],,,,,,
+ac-cluster,18463,udp,AC Cluster,[Lisa_Zhong],[Lisa_Zhong],,,,,,
+,18464-18633,,Unassigned,,,,,,,,
+rds-ib,18634,tcp,Reliable Datagram Service,[Andy_Grover],[Andy_Grover],2009-02-27,,,,,
+rds-ib,18634,udp,Reliable Datagram Service,[Andy_Grover],[Andy_Grover],2009-02-27,,,,,
+rds-ip,18635,tcp,Reliable Datagram Service over IP,[Andy_Grover],[Andy_Grover],2009-05-20,,,,,
+rds-ip,18635,udp,Reliable Datagram Service over IP,[Andy_Grover],[Andy_Grover],2009-05-20,,,,,
+,18636-18768,,Unassigned,,,,,,,,
+ique,18769,tcp,IQue Protocol,[Avi_Drissman],[Avi_Drissman],2002-07,,,,,
+ique,18769,udp,IQue Protocol,[Avi_Drissman],[Avi_Drissman],2002-07,,,,,
+,18770-18880,,Unassigned,,,,,,,,
+infotos,18881,tcp,Infotos,[Marcel_Dube],[Marcel_Dube],2004-11,,,,,
+infotos,18881,udp,Infotos,[Marcel_Dube],[Marcel_Dube],2004-11,,,,,
+,18882-18887,,Unassigned,,,,,,,,
+apc-necmp,18888,tcp,APCNECMP,[Michael_Yip],[Michael_Yip],,,,,,
+apc-necmp,18888,udp,APCNECMP,[Michael_Yip],[Michael_Yip],,,,,,
+,18889-18999,,Unassigned,,,,,,,,
+igrid,19000,tcp,iGrid Server,[Massimo_Cafaro],[Massimo_Cafaro],2004-11,,,,,
+igrid,19000,udp,iGrid Server,[Massimo_Cafaro],[Massimo_Cafaro],2004-11,,,,,
+,19001-19006,,Unassigned,,,,,,,,
+scintilla,19007,tcp,Scintilla protocol for device services,[Veejansh_Inc],[Chirag_Patel],2014-03-04,,,,,
+scintilla,19007,udp,Scintilla protocol for device services,[Veejansh_Inc],[Chirag_Patel],2014-03-04,,,,,
+,19008-19019,,Unassigned,,,,,,,,
+j-link,19020,tcp,J-Link TCP/IP Protocol,[SEGGER],[SEGGER],,,,,,
+,19020,udp,Reserved,,,,,,,,
+,19021-19190,,Unassigned,,,,,,,,
+opsec-uaa,19191,tcp,OPSEC UAA,[Reuven_Harrison],[Reuven_Harrison],,,,,,
+opsec-uaa,19191,udp,OPSEC UAA,[Reuven_Harrison],[Reuven_Harrison],,,,,,
+,19192-19193,,Unassigned,,,,,,,,
+ua-secureagent,19194,tcp,UserAuthority SecureAgent,[Reuven_Harrison_2],[Reuven_Harrison_2],2003-01,,,,,
+ua-secureagent,19194,udp,UserAuthority SecureAgent,[Reuven_Harrison_2],[Reuven_Harrison_2],2003-01,,,,,
+,19195-19282,,Unassigned,,,,,,,,
+keysrvr,19283,tcp,Key Server for SASSAFRAS,[Mark_Valence],[Mark_Valence],,,,,,
+keysrvr,19283,udp,Key Server for SASSAFRAS,[Mark_Valence],[Mark_Valence],,,,,,
+,19284-19314,,Unassigned,,,,,,,,
+keyshadow,19315,tcp,Key Shadow for SASSAFRAS,[Mark_Valence],[Mark_Valence],,,,,,
+keyshadow,19315,udp,Key Shadow for SASSAFRAS,[Mark_Valence],[Mark_Valence],,,,,,
+,19316-19397,,Unassigned,,,,,,,,
+mtrgtrans,19398,tcp,mtrgtrans,[Katsuhito_Muroi],[Katsuhito_Muroi],,,,,,
+mtrgtrans,19398,udp,mtrgtrans,[Katsuhito_Muroi],[Katsuhito_Muroi],,,,,,
+,19399-19409,,Unassigned,,,,,,,,
+hp-sco,19410,tcp,hp-sco,[Larry_Schwartz],[Larry_Schwartz],,,,,,
+hp-sco,19410,udp,hp-sco,[Larry_Schwartz],[Larry_Schwartz],,,,,,
+hp-sca,19411,tcp,hp-sca,[Larry_Schwartz],[Larry_Schwartz],,,,,,
+hp-sca,19411,udp,hp-sca,[Larry_Schwartz],[Larry_Schwartz],,,,,,
+hp-sessmon,19412,tcp,HP-SESSMON,[Gita_Murthy],[Gita_Murthy],,,,,,
+hp-sessmon,19412,udp,HP-SESSMON,[Gita_Murthy],[Gita_Murthy],,,,,,
+,19413-19538,,Unassigned,,,,,,,,
+fxuptp,19539,tcp,FXUPTP,[Keiji_Okuma],[Keiji_Okuma],2005-08,,,,,
+fxuptp,19539,udp,FXUPTP,[Keiji_Okuma],[Keiji_Okuma],2005-08,,,,,
+sxuptp,19540,tcp,SXUPTP,[Keiji_Okuma],[Keiji_Okuma],2002-08,,,,,
+sxuptp,19540,udp,SXUPTP,[Keiji_Okuma],[Keiji_Okuma],2002-08,,,,,
+jcp,19541,tcp,JCP Client,[Yuji_Sasaki],[Yuji_Sasaki],,,,,,
+jcp,19541,udp,JCP Client,[Yuji_Sasaki],[Yuji_Sasaki],,,,,,
+,19542-19787,,Unassigned,,,,,,,,
+mle,19788,udp,Mesh Link Establishment,[IESG],[IETF_Chair],2012-12-18,,,,,
+,19788,tcp,Reserved,,,,,,,,
+,19789-19997,,Unassigned,,,,,,,,
+iec-104-sec,19998,tcp,IEC 60870-5-104 process control - secure,[Grant_Gilchrist],[Grant_Gilchrist],2010-10-18,,,,,
+,19998,udp,Reserved,,,,,,,,
+dnp-sec,19999,tcp,Distributed Network Protocol - Secure,[Grant_Gilchrist],[Grant_Gilchrist],2008-08-04,,,,,
+dnp-sec,19999,udp,Distributed Network Protocol - Secure,[Grant_Gilchrist],[Grant_Gilchrist],2008-08-04,,,,,
+dnp,20000,tcp,DNP,[Michael_Thesing],[Michael_Thesing],,,,,,
+dnp,20000,udp,DNP,[Michael_Thesing],[Michael_Thesing],,,,,,
+microsan,20001,tcp,MicroSAN,[Thomas_E_Ludwig],[Thomas_E_Ludwig],2004-02,,,,,
+microsan,20001,udp,MicroSAN,[Thomas_E_Ludwig],[Thomas_E_Ludwig],2004-02,,,,,
+commtact-http,20002,tcp,Commtact HTTP,[Tomas_Svoboda],[Tomas_Svoboda],2004-12,,,,,
+commtact-http,20002,udp,Commtact HTTP,[Tomas_Svoboda],[Tomas_Svoboda],2004-12,,,,,
+commtact-https,20003,tcp,Commtact HTTPS,[Tomas_Svoboda],[Tomas_Svoboda],2004-12,,,,,
+commtact-https,20003,udp,Commtact HTTPS,[Tomas_Svoboda],[Tomas_Svoboda],2004-12,,,,,
+,20004,,Unassigned,,,,,,,,
+openwebnet,20005,tcp,OpenWebNet protocol for electric network,[BTicino_S_p_A],[BTicino_S_p_A],2008-04-09,,,,,
+openwebnet,20005,udp,OpenWebNet protocol for electric network,[BTicino_S_p_A],[BTicino_S_p_A],2008-04-09,,,,,
+,20006-20011,,Unassigned,,,,,,,,
+,20012,tcp,Reserved,,,,,,,,
+ss-idi-disc,20012,udp,Samsung Interdevice Interaction discovery,[Hong_Jungkih],[Hong_Jungkih],,,,,,
+ss-idi,20013,tcp,Samsung Interdevice Interaction,[Hong_Jungkih],[Hong_Jungkih],,,,,,
+,20013,udp,Reserved,,,,,,,,
+opendeploy,20014,tcp,OpenDeploy Listener,[Todd_Scallan],[Todd_Scallan],2005-08,,,,,
+opendeploy,20014,udp,OpenDeploy Listener,[Todd_Scallan],[Todd_Scallan],2005-08,,,,,
+,20015-20033,,Unassigned,,,,,,,,
+nburn-id,20034,tcp,"NetBurner ID Port
+IANA assigned this well-formed service name as a replacement for ""nburn_id"".",[Paul_Breed],[Paul_Breed],2003-11,,,,,
+nburn_id,20034,tcp,NetBurner ID Port,[Paul_Breed],[Paul_Breed],2003-11,,,,,"This entry is an alias to ""nburn-id"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+nburn-id,20034,udp,"NetBurner ID Port
+IANA assigned this well-formed service name as a replacement for ""nburn_id"".",[Paul_Breed],[Paul_Breed],2003-11,,,,,
+nburn_id,20034,udp,NetBurner ID Port,[Paul_Breed],[Paul_Breed],2003-11,,,,,"This entry is an alias to ""nburn-id"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+,20035-20045,,Unassigned,,,,,,,,
+tmophl7mts,20046,tcp,TMOP HL7 Message Transfer Service,[Tim_Riley],[Tim_Riley],2009-07-31,,,,,
+tmophl7mts,20046,udp,TMOP HL7 Message Transfer Service,[Tim_Riley],[Tim_Riley],2009-07-31,,,,,
+,20047-20047,,Unassigned,,,,,,,,
+mountd,20048,tcp,NFS mount protocol,[Nicolas_Williams],[Nicolas_Williams],2010-08-09,,,,,
+mountd,20048,udp,NFS mount protocol,[Nicolas_Williams],[Nicolas_Williams],2010-08-09,,,,,
+nfsrdma,20049,tcp,Network File System (NFS) over RDMA,,,,,[RFC5666],,,
+nfsrdma,20049,udp,Network File System (NFS) over RDMA,,,,,[RFC5666],,,
+nfsrdma,20049,sctp,Network File System (NFS) over RDMA,,,,,[RFC5666],,,
+,20050-20166,,Unassigned,,,,,,,,
+tolfab,20167,tcp,TOLfab Data Change,[Pierre_Couderc],[Pierre_Couderc],2006-03,,,,,
+tolfab,20167,udp,TOLfab Data Change,[Pierre_Couderc],[Pierre_Couderc],2006-03,,,,,
+,20168-20201,,Unassigned,,,,,,,,
+ipdtp-port,20202,tcp,IPD Tunneling Port,[Vikki_Yin_Wei],[Vikki_Yin_Wei],2003-01,,,,,
+ipdtp-port,20202,udp,IPD Tunneling Port,[Vikki_Yin_Wei],[Vikki_Yin_Wei],2003-01,,,,,
+,20203-20221,,Unassigned,,,,,,,,
+ipulse-ics,20222,tcp,iPulse-ICS,[Meggie_Garica_Woodru],[Meggie_Garica_Woodru],,,,,,
+ipulse-ics,20222,udp,iPulse-ICS,[Meggie_Garica_Woodru],[Meggie_Garica_Woodru],,,,,,
+,20223-20479,,Unassigned,,,,,,,,
+emwavemsg,20480,tcp,emWave Message Service,[Harald_Striepe],[Harald_Striepe],2008-02-14,,,,,
+emwavemsg,20480,udp,emWave Message Service,[Harald_Striepe],[Harald_Striepe],2008-02-14,,,,,
+,20481-20669,,Unassigned,,,,,,,,
+track,20670,tcp,Track,[Michael_Sweet],[Michael_Sweet],,,,,,
+track,20670,udp,Track,[Michael_Sweet],[Michael_Sweet],,,,,,
+,20671-20998,,Unassigned,,,,,,,,
+athand-mmp,20999,tcp,At Hand MMP,[Stepan_Riha],[Stepan_Riha],,,,,,
+athand-mmp,20999,udp,AT Hand MMP,[Stepan_Riha],[Stepan_Riha],,,,,,
+irtrans,21000,tcp,IRTrans Control,[Marcus_Mueller],[Marcus_Mueller],2004-11,,,,,
+irtrans,21000,udp,IRTrans Control,[Marcus_Mueller],[Marcus_Mueller],2004-11,,,,,
+,21001-21009,,Unassigned,,,,,,,,
+notezilla-lan,21010,tcp,Notezilla.Lan Server,[Conceptworld_Corporation],[Gautam_Jain],2013-08-20,,,,,
+,21010,udp,Reserved,,,,,,,,
+,21011-21552,,Unassigned,,,,,,,,
+rdm-tfs,21553,tcp,Raima RDM TFS,[Paul_Johnson],[Paul_Johnson],2011-05-02,,,,,
+,21553,udp,Reserved,,,,,,,,
+dfserver,21554,tcp,MineScape Design File Server,[Michael_Purser],[Michael_Purser],2006-06,,,,,
+dfserver,21554,udp,MineScape Design File Server,[Michael_Purser],[Michael_Purser],2006-06,,,,,
+,21555-21589,,Unassigned,,,,,,,,
+vofr-gateway,21590,tcp,VoFR Gateway,[Marty_Borden],[Marty_Borden],,,,,,
+vofr-gateway,21590,udp,VoFR Gateway,[Marty_Borden],[Marty_Borden],,,,,,
+,21591-21799,,Unassigned,,,,,,,,
+tvpm,21800,tcp,TVNC Pro Multiplexing,[Brian_Blevins],[Brian_Blevins],,,,,,
+tvpm,21800,udp,TVNC Pro Multiplexing,[Brian_Blevins],[Brian_Blevins],,,,,,
+,21801-21844,,Unassigned,,,,,,,,
+webphone,21845,tcp,webphone,[Toby_Hosterman],[Toby_Hosterman],,,,,,
+webphone,21845,udp,webphone,[Toby_Hosterman],[Toby_Hosterman],,,,,,
+netspeak-is,21846,tcp,NetSpeak Corp. Directory Services,[Toby_Hosterman],[Toby_Hosterman],,,,,,
+netspeak-is,21846,udp,NetSpeak Corp. Directory Services,[Toby_Hosterman],[Toby_Hosterman],,,,,,
+netspeak-cs,21847,tcp,NetSpeak Corp. Connection Services,[Toby_Hosterman],[Toby_Hosterman],,,,,,
+netspeak-cs,21847,udp,NetSpeak Corp. Connection Services,[Toby_Hosterman],[Toby_Hosterman],,,,,,
+netspeak-acd,21848,tcp,NetSpeak Corp. Automatic Call Distribution,[Toby_Hosterman],[Toby_Hosterman],,,,,,
+netspeak-acd,21848,udp,NetSpeak Corp. Automatic Call Distribution,[Toby_Hosterman],[Toby_Hosterman],,,,,,
+netspeak-cps,21849,tcp,NetSpeak Corp. Credit Processing System,[Toby_Hosterman],[Toby_Hosterman],,,,,,
+netspeak-cps,21849,udp,NetSpeak Corp. Credit Processing System,[Toby_Hosterman],[Toby_Hosterman],,,,,,
+,21850-21999,,Unassigned,,,,,,,,
+snapenetio,22000,tcp,SNAPenetIO,[Kevin_Kuhns],[Kevin_Kuhns],,,,,,
+snapenetio,22000,udp,SNAPenetIO,[Kevin_Kuhns],[Kevin_Kuhns],,,,,,
+optocontrol,22001,tcp,OptoControl,[Kevin_Kuhns],[Kevin_Kuhns],,,,,,
+optocontrol,22001,udp,OptoControl,[Kevin_Kuhns],[Kevin_Kuhns],,,,,,
+optohost002,22002,tcp,Opto Host Port 2,[Doug_Leany],[Doug_Leany],2006-09,,,,,
+optohost002,22002,udp,Opto Host Port 2,[Doug_Leany],[Doug_Leany],2006-09,,,,,
+optohost003,22003,tcp,Opto Host Port 3,[Doug_Leany],[Doug_Leany],2006-09,,,,,
+optohost003,22003,udp,Opto Host Port 3,[Doug_Leany],[Doug_Leany],2006-09,,,,,
+optohost004,22004,tcp,Opto Host Port 4,[Doug_Leany],[Doug_Leany],2006-09,,,,,
+optohost004,22004,udp,Opto Host Port 4,[Doug_Leany],[Doug_Leany],2006-09,,,,,
+optohost004,22005,tcp,Opto Host Port 5,[Doug_Leany],[Doug_Leany],2006-09,,,,,
+optohost004,22005,udp,Opto Host Port 5,[Doug_Leany],[Doug_Leany],2006-09,,,,,
+,22006-22124,,Unassigned,,,,,,,,
+dcap,22125,tcp,dCache Access Protocol,[Christoph_Anton_Mitt],[Christoph_Anton_Mitt],2009-03-10,,,,,
+,22125,udp,Reserved,,,,,,,,
+,22126-22127,,Unassigned,,,,,,,,
+gsidcap,22128,tcp,GSI dCache Access Protocol,[Christoph_Anton_Mitt],[Christoph_Anton_Mitt],2009-03-10,,,,,
+,22128,udp,Reserved,,,,,,,,
+,22129-22221,,Unassigned,,,,,,,,
+easyengine,22222,tcp,EasyEngine is CLI tool to manage WordPress Sites on Nginx server,[rtCamp_Solutions_Private_Limited],[Rahul_Bansal],2014-03-10,,,,,
+,22222,udp,Reserved,,,,,,,,
+,22223-22272,,Unassigned,,,,,,,,
+wnn6,22273,tcp,wnn6,[Yasunari_Gon_Yamasit],[Yasunari_Gon_Yamasit],,,,,,
+wnn6,22273,udp,wnn6,[Yasunari_Gon_Yamasit],[Yasunari_Gon_Yamasit],,,,,,
+,22274-22304,,Unassigned,,,,,,,,
+cis,22305,tcp,CompactIS Tunnel,[Justin_Paupore],[Justin_Paupore],2007-08-16,,,,,
+cis,22305,udp,CompactIS Tunnel,[Justin_Paupore],[Justin_Paupore],2007-08-16,,,,,
+,22306-22342,,Unassigned,,,,,,,,
+cis-secure,22343,tcp,CompactIS Secure Tunnel,[Justin_Paupore],[Justin_Paupore],2007-08-16,,,,,
+cis-secure,22343,udp,CompactIS Secure Tunnel,[Justin_Paupore],[Justin_Paupore],2007-08-16,,,,,
+,22344-22346,,Unassigned,,,,,,,,
+wibukey,22347,tcp,WibuKey Standard WkLan,[Wolfgang_Voelker],[Wolfgang_Voelker],2007-06,,,,,
+wibukey,22347,udp,WibuKey Standard WkLan,[Wolfgang_Voelker],[Wolfgang_Voelker],2007-06,,,,,
+,22348-22349,,Unassigned,,,,,,,,
+codemeter,22350,tcp,CodeMeter Standard,[Wolfgang_Voelker],[Wolfgang_Voelker],2007-06,,,,,
+codemeter,22350,udp,CodeMeter Standard,[Wolfgang_Voelker],[Wolfgang_Voelker],2007-06,,,,,
+codemeter-cmwan,22351,tcp,TPC/IP requests of copy protection software to a server,[WIBU-SYSTEMS_AG],[Wolfgang_Völker_2],2013-06-25,,,,,
+,22351,udp,Reserved,,,,,,,,
+,22352-22536,,Unassigned,,,,,,,,
+caldsoft-backup,22537,tcp,CaldSoft Backup server file transfer,[CaldSoft],[Mark_Caldwell],2011-08-12,,,,,
+,22537,udp,Reserved,,,,,,,,
+,22538-22554,,Unassigned,,,,,,,,
+vocaltec-wconf,22555,tcp,Vocaltec Web Conference,[Scott_Petrack],[Scott_Petrack],,,,,,
+vocaltec-phone,22555,udp,Vocaltec Internet Phone,[Scott_Petrack],[Scott_Petrack],,,,,,
+,22556-22762,,Unassigned,,,,,,,,
+talikaserver,22763,tcp,Talika Main Server,[Laxman_C_Marathe],[Laxman_C_Marathe],2006-12,,,,,
+talikaserver,22763,udp,Talika Main Server,[Laxman_C_Marathe],[Laxman_C_Marathe],2006-12,,,,,
+,22764-22799,,Unassigned,,,,,,,,
+aws-brf,22800,tcp,Telerate Information Platform LAN,[Timo_Sivonen],[Timo_Sivonen],,,,,,
+aws-brf,22800,udp,Telerate Information Platform LAN,[Timo_Sivonen],[Timo_Sivonen],,,,,,
+,22801-22950,,Unassigned,,,,,,,,
+brf-gw,22951,tcp,Telerate Information Platform WAN,[Timo_Sivonen],[Timo_Sivonen],,,,,,
+brf-gw,22951,udp,Telerate Information Platform WAN,[Timo_Sivonen],[Timo_Sivonen],,,,,,
+,22952-22999,,Unassigned,,,,,,,,
+inovaport1,23000,tcp,Inova LightLink Server Type 1,[Chris_Koeritz_3],[Chris_Koeritz_3],2006-10,,,,,
+inovaport1,23000,udp,Inova LightLink Server Type 1,[Chris_Koeritz_3],[Chris_Koeritz_3],2006-10,,,,,
+inovaport2,23001,tcp,Inova LightLink Server Type 2,[Chris_Koeritz_3],[Chris_Koeritz_3],2006-10,,,,,
+inovaport2,23001,udp,Inova LightLink Server Type 2,[Chris_Koeritz_3],[Chris_Koeritz_3],2006-10,,,,,
+inovaport3,23002,tcp,Inova LightLink Server Type 3,[Chris_Koeritz_3],[Chris_Koeritz_3],2006-10,,,,,
+inovaport3,23002,udp,Inova LightLink Server Type 3,[Chris_Koeritz_3],[Chris_Koeritz_3],2006-10,,,,,
+inovaport4,23003,tcp,Inova LightLink Server Type 4,[Chris_Koeritz_3],[Chris_Koeritz_3],2006-10,,,,,
+inovaport4,23003,udp,Inova LightLink Server Type 4,[Chris_Koeritz_3],[Chris_Koeritz_3],2006-10,,,,,
+inovaport5,23004,tcp,Inova LightLink Server Type 5,[Chris_Koeritz_3],[Chris_Koeritz_3],2006-10,,,,,
+inovaport5,23004,udp,Inova LightLink Server Type 5,[Chris_Koeritz_3],[Chris_Koeritz_3],2006-10,,,,,
+inovaport6,23005,tcp,Inova LightLink Server Type 6,[Chris_Koeritz_3],[Chris_Koeritz_3],2006-10,,,,,
+inovaport6,23005,udp,Inova LightLink Server Type 6,[Chris_Koeritz_3],[Chris_Koeritz_3],2006-10,,,,,
+,23006-23052,,Unassigned,,,,,,,,
+gntp,23053,tcp,Generic Notification Transport Protocol,[Growl_Project],[Chris_Forsythe],2012-02-07,,,,,
+,23053,udp,Reserved,,,,,,,,
+,23054-23271,,Unassigned,,,,,,,,
+,23272,tcp,Reserved,,,,,,,,
+s102,23272,udp,S102 application,[Kimmo_Kymalainen],[Kimmo_Kymalainen],2009-08-26,,,,,
+,23273-23332,,Unassigned,,,,,,,,
+elxmgmt,23333,tcp,Emulex HBAnyware Remote Management,[Maziar_Tamadon],[Maziar_Tamadon],2007-11-06,,,,,
+elxmgmt,23333,udp,Emulex HBAnyware Remote Management,[Maziar_Tamadon],[Maziar_Tamadon],2007-11-06,,,,,
+,23334-23399,,Unassigned,,,,,,,,
+novar-dbase,23400,tcp,Novar Data,[Keith_Kilroy],[Keith_Kilroy],2006-02,,,,,
+novar-dbase,23400,udp,Novar Data,[Keith_Kilroy],[Keith_Kilroy],2006-02,,,,,
+novar-alarm,23401,tcp,Novar Alarm,[Keith_Kilroy],[Keith_Kilroy],2006-02,,,,,
+novar-alarm,23401,udp,Novar Alarm,[Keith_Kilroy],[Keith_Kilroy],2006-02,,,,,
+novar-global,23402,tcp,Novar Global,[Keith_Kilroy],[Keith_Kilroy],2006-02,,,,,
+novar-global,23402,udp,Novar Global,[Keith_Kilroy],[Keith_Kilroy],2006-02,,,,,
+,23403-23455,,Unassigned,,,,,,,,
+aequus,23456,tcp,Aequus Service,[James_Anson],[James_Anson],2009-02-12,,,,,
+,23456,udp,Reserved,,,,,,,,
+aequus-alt,23457,tcp,Aequus Service Mgmt,[James_Anson],[James_Anson],2009-02-12,,,,,
+,23457,udp,Reserved,,,,,,,,
+,23458-23545,,Unassigned,,,,,,,,
+areaguard-neo,23546,tcp,AreaGuard Neo - WebServer,[SODATSW_spol],[Roman_Štěpánek],2012-05-31,,,,,
+,23546,udp,Reserved,,,,,,,,
+,23547-23999,,Unassigned,,,,,,,,
+med-ltp,24000,tcp,med-ltp,[Juergen_Fischbach],[Juergen_Fischbach],,,,,,
+med-ltp,24000,udp,med-ltp,[Juergen_Fischbach],[Juergen_Fischbach],,,,,,
+med-fsp-rx,24001,tcp,med-fsp-rx,[Juergen_Fischbach],[Juergen_Fischbach],,,,,,
+med-fsp-rx,24001,udp,med-fsp-rx,[Juergen_Fischbach],[Juergen_Fischbach],,,,,,
+med-fsp-tx,24002,tcp,med-fsp-tx,[Juergen_Fischbach],[Juergen_Fischbach],,,,,,
+med-fsp-tx,24002,udp,med-fsp-tx,[Juergen_Fischbach],[Juergen_Fischbach],,,,,,
+med-supp,24003,tcp,med-supp,[Juergen_Fischbach],[Juergen_Fischbach],,,,,,
+med-supp,24003,udp,med-supp,[Juergen_Fischbach],[Juergen_Fischbach],,,,,,
+med-ovw,24004,tcp,med-ovw,[Juergen_Fischbach],[Juergen_Fischbach],,,,,,
+med-ovw,24004,udp,med-ovw,[Juergen_Fischbach],[Juergen_Fischbach],,,,,,
+med-ci,24005,tcp,med-ci,[Juergen_Fischbach],[Juergen_Fischbach],,,,,,
+med-ci,24005,udp,med-ci,[Juergen_Fischbach],[Juergen_Fischbach],,,,,,
+med-net-svc,24006,tcp,med-net-svc,[Juergen_Fischbach],[Juergen_Fischbach],,,,,,
+med-net-svc,24006,udp,med-net-svc,[Juergen_Fischbach],[Juergen_Fischbach],,,,,,
+,24007-24241,,Unassigned,,,,,,,,
+filesphere,24242,tcp,fileSphere,[Carl_Cedergren],[Carl_Cedergren],,,,,,
+filesphere,24242,udp,fileSphere,[Carl_Cedergren],[Carl_Cedergren],,,,,,
+,24243-24248,,Unassigned,,,,,,,,
+vista-4gl,24249,tcp,Vista 4GL,[Mark_Itzcovitz],[Mark_Itzcovitz],,,,,,
+vista-4gl,24249,udp,Vista 4GL,[Mark_Itzcovitz],[Mark_Itzcovitz],,,,,,
+,24250-24320,,Unassigned,,,,,,,,
+ild,24321,tcp,Isolv Local Directory,[Mitchell_Bass],[Mitchell_Bass],2005-08,,,,,
+ild,24321,udp,Isolv Local Directory,[Mitchell_Bass],[Mitchell_Bass],2005-08,,,,,
+hid,24322,udp,Transport of Human Interface Device data streams,[Freebox_SAS],[Nicolas_Pouillon],2012-12-14,,,,,
+,24322,tcp,Reserved,,,,,,,,
+,24323-24385,,Unassigned,,,,,,,,
+intel-rci,24386,tcp,"Intel RCI
+IANA assigned this well-formed service name as a replacement for ""intel_rci"".",[Mark_Lewis_2],[Mark_Lewis_2],,,,,,
+intel_rci,24386,tcp,Intel RCI,[Mark_Lewis_2],[Mark_Lewis_2],,,,,,"This entry is an alias to ""intel-rci"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+intel-rci,24386,udp,"Intel RCI
+IANA assigned this well-formed service name as a replacement for ""intel_rci"".",[Mark_Lewis_2],[Mark_Lewis_2],,,,,,
+intel_rci,24386,udp,Intel RCI,[Mark_Lewis_2],[Mark_Lewis_2],,,,,,"This entry is an alias to ""intel-rci"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+,24387-24464,,Unassigned,,,,,,,,
+tonidods,24465,tcp,Tonido Domain Server,[Madhan_Kanagavel],[Madhan_Kanagavel],2008-07-18,,,,,
+tonidods,24465,udp,Tonido Domain Server,[Madhan_Kanagavel],[Madhan_Kanagavel],2008-07-18,,,,,
+,24466-24553,,Unassigned,,,,,,,,
+binkp,24554,tcp,BINKP,[Max_Masyutin],[Max_Masyutin],,,,,,
+binkp,24554,udp,BINKP,[Max_Masyutin],[Max_Masyutin],,,,,,
+,24555-24576,,Unassigned,,,,,,,,
+bilobit,24577,tcp,bilobit Service,[bilobit_GmbH],[Martin_Schmuker],2014-08-15,,,,,
+bilobit-update,24577,udp,bilobit Service Update,[bilobit_GmbH],[Martin_Schmuker],2014-08-15,,,,,
+,24578-24675,,Unassigned,,,,,,,,
+canditv,24676,tcp,Canditv Message Service,[Gary_Aston],[Gary_Aston],2009-03-10,,,,,
+canditv,24676,udp,Canditv Message Service,[Gary_Aston],[Gary_Aston],2009-03-10,,,,,
+flashfiler,24677,tcp,FlashFiler,[Ben_Oram],[Ben_Oram],,,,,,
+flashfiler,24677,udp,FlashFiler,[Ben_Oram],[Ben_Oram],,,,,,
+proactivate,24678,tcp,Turbopower Proactivate,[Ben_Oram],[Ben_Oram],,,,,,
+proactivate,24678,udp,Turbopower Proactivate,[Ben_Oram],[Ben_Oram],,,,,,
+,24679,,Unassigned,,,,,,,,
+tcc-http,24680,tcp,TCC User HTTP Service,[Brian_Kennedy],[Brian_Kennedy],2006-08,,,,,
+tcc-http,24680,udp,TCC User HTTP Service,[Brian_Kennedy],[Brian_Kennedy],2006-08,,,,,
+,24681-24753,,Unassigned,,,,,,,,
+cslg,24754,tcp,Citrix StorageLink Gateway,[Mark_Nijmeijer],[Mark_Nijmeijer],2009-04-17,,,,,
+,24754,udp,Reserved,,,,,,,,
+,24755-24849,,Unassigned,,,,,,,,
+,24850,tcp,Reserved,,,,,,,,
+assoc-disc,24850,udp,Device Association Discovery,[Microsoft_Corporation_3],[Sachin_Sheth],2012-06-27,,,,,
+,24851-24921,,Unassigned,,,,,,,,
+find,24922,tcp,Find Identification of Network Devices,[Jean_Paul_Moreaux],[Jean_Paul_Moreaux],,,,,,
+find,24922,udp,Find Identification of Network Devices,[Jean_Paul_Moreaux],[Jean_Paul_Moreaux],,,,,,
+,24923-24999,,Unassigned,,,,,,,,
+icl-twobase1,25000,tcp,icl-twobase1,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase1,25000,udp,icl-twobase1,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase2,25001,tcp,icl-twobase2,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase2,25001,udp,icl-twobase2,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase3,25002,tcp,icl-twobase3,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase3,25002,udp,icl-twobase3,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase4,25003,tcp,icl-twobase4,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase4,25003,udp,icl-twobase4,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase5,25004,tcp,icl-twobase5,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase5,25004,udp,icl-twobase5,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase6,25005,tcp,icl-twobase6,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase6,25005,udp,icl-twobase6,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase7,25006,tcp,icl-twobase7,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase7,25006,udp,icl-twobase7,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase8,25007,tcp,icl-twobase8,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase8,25007,udp,icl-twobase8,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase9,25008,tcp,icl-twobase9,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase9,25008,udp,icl-twobase9,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase10,25009,tcp,icl-twobase10,[J_A_Sever],[J_A_Sever],,,,,,
+icl-twobase10,25009,udp,icl-twobase10,[J_A_Sever],[J_A_Sever],,,,,,
+,25010-25470,,Unassigned,,,,,,,,
+rna,25471,sctp,RNSAP User Adaptation for Iurh,[Dario_S_Tonesi],[Dario_S_Tonesi],2011-02-07,,,,,
+,25472-25575,,Unassigned,,,,,,,,
+sauterdongle,25576,tcp,Sauter Dongle,[Christian_Brecht],[Christian_Brecht],2010-12-15,,,,,
+,25576,udp,Reserved,,,,,,,,
+,25577-25603,,Unassigned,,,,,,,,
+idtp,25604,tcp,Identifier Tracing Protocol,[Huang_Neng-geng],[Huang_Neng-geng],2011-08-09,,,,,
+,25604,udp,Reserved,,,,,,,,
+,25605-25792,,Unassigned,,,,,,,,
+vocaltec-hos,25793,tcp,Vocaltec Address Server,[Scott_Petrack],[Scott_Petrack],,,,,,
+vocaltec-hos,25793,udp,Vocaltec Address Server,[Scott_Petrack],[Scott_Petrack],,,,,,
+,25794-25899,,Unassigned,,,,,,,,
+tasp-net,25900,tcp,TASP Network Comm,[Martin_Ellis],[Martin_Ellis],2004-11,,,,,
+tasp-net,25900,udp,TASP Network Comm,[Martin_Ellis],[Martin_Ellis],2004-11,,,,,
+niobserver,25901,tcp,NIObserver,[Roman_Oliynyk],[Roman_Oliynyk],,,,,,
+niobserver,25901,udp,NIObserver,[Roman_Oliynyk],[Roman_Oliynyk],,,,,,
+nilinkanalyst,25902,tcp,NILinkAnalyst,[Roman_Oliynyk_2],[Roman_Oliynyk_2],2007-08-30,,,,,
+nilinkanalyst,25902,udp,NILinkAnalyst,[Roman_Oliynyk_2],[Roman_Oliynyk_2],2007-08-30,,,,,
+niprobe,25903,tcp,NIProbe,[Roman_Oliynyk],[Roman_Oliynyk],,,,,,
+niprobe,25903,udp,NIProbe,[Roman_Oliynyk],[Roman_Oliynyk],,,,,,
+,25904-25953,,Unassigned,,,,,,,,
+bf-game,25954,udp,Bitfighter game server,[Christopher_Eykamp],[Christopher_Eykamp],2012-08-16,,,,,
+,25954,tcp,Reserved,,,,,,,,
+bf-master,25955,udp,Bitfighter master server,[Christopher_Eykamp],[Christopher_Eykamp],2012-08-16,,,,,
+,25955,tcp,Reserved,,,,,,,,
+,25956-25999,,Unassigned,,,,,,,,
+quake,26000,tcp,quake,[Yasunari_Gon_Yamasit],[Yasunari_Gon_Yamasit],,,,,,
+quake,26000,udp,quake,[Yasunari_Gon_Yamasit],[Yasunari_Gon_Yamasit],,,,,,
+,26001-26132,,Unassigned,,,,,,,,
+scscp,26133,tcp,Symbolic Computation Software Composability Protocol,[Alexander_Konovalov],[Alexander_Konovalov],2007-11-27,,,,,
+scscp,26133,udp,Symbolic Computation Software Composability Protocol,[Alexander_Konovalov],[Alexander_Konovalov],2007-11-27,,,,,
+,26134-26207,,Unassigned,,,,,,,,
+wnn6-ds,26208,tcp,wnn6-ds,[Yasunari_Gon_Yamasit],[Yasunari_Gon_Yamasit],,,,,,
+wnn6-ds,26208,udp,wnn6-ds,[Yasunari_Gon_Yamasit],[Yasunari_Gon_Yamasit],,,,,,
+,26209-26259,,Unassigned,,,,,,,,
+ezproxy,26260,tcp,eZproxy,[Albert_C_Yang],[Albert_C_Yang],,,,,,
+ezproxy,26260,udp,eZproxy,[Albert_C_Yang],[Albert_C_Yang],,,,,,
+ezmeeting,26261,tcp,eZmeeting,[Albert_C_Yang],[Albert_C_Yang],,,,,,
+ezmeeting,26261,udp,eZmeeting,[Albert_C_Yang],[Albert_C_Yang],,,,,,
+k3software-svr,26262,tcp,K3 Software-Server,[Jim_Baldridge],[Jim_Baldridge],,,,,,
+k3software-svr,26262,udp,K3 Software-Server,[Jim_Baldridge],[Jim_Baldridge],,,,,,
+k3software-cli,26263,tcp,K3 Software-Client,[Jim_Baldridge],[Jim_Baldridge],,,,,,
+k3software-cli,26263,udp,K3 Software-Client,[Jim_Baldridge],[Jim_Baldridge],,,,,,
+,26264,,De-registered,,,,2006-04-06,,,,
+,26265-26485,,Unassigned,,,,,,,,
+exoline-tcp,26486,tcp,EXOline-TCP,[Lars_Mattsson],[Lars_Mattsson],2008-12-24,,,,,
+exoline-udp,26486,udp,EXOline-UDP,[Lars_Mattsson],[Lars_Mattsson],2008-12-24,,,,,
+exoconfig,26487,tcp,EXOconfig,[Urban_Fosseus],[Urban_Fosseus],2008-12-24,,,,,
+exoconfig,26487,udp,EXOconfig,[Urban_Fosseus],[Urban_Fosseus],2008-12-24,,,,,
+,26488,,Unassigned,,,,,,,,
+exonet,26489,tcp,EXOnet,[Urban_Fosseus],[Urban_Fosseus],2008-12-24,,,,,
+exonet,26489,udp,EXOnet,[Urban_Fosseus],[Urban_Fosseus],2008-12-24,,,,,
+,26490-26999,,Unassigned,,,,,,,,
+flex-lm,27000-27009,,FLEX LM (1-10),[Daniel_Birns],[Daniel_Birns],,,,,,
+,27010-27344,,Unassigned,,,,,,,"Unauthorized Use Known on ports 27017, 27018 and 27019",
+imagepump,27345,tcp,ImagePump,[Richard_Minner],[Richard_Minner],,,,,,
+imagepump,27345,udp,ImagePump,[Richard_Minner],[Richard_Minner],,,,,,
+,27346-27441,,Unassigned,,,,,,,,
+jesmsjc,27442,tcp,Job controller service,[Chris_Newman],[Chris_Newman],2010-10-15,,,,,
+jesmsjc,27442,udp,Job controller service,[Chris_Newman],[Chris_Newman],2010-10-15,,,,,
+,27443-27503,,Unassigned,,,,,,,,
+kopek-httphead,27504,tcp,Kopek HTTP Head Port,[Sten_H_Danielsen],[Sten_H_Danielsen],2002-07,,,,,
+kopek-httphead,27504,udp,Kopek HTTP Head Port,[Sten_H_Danielsen],[Sten_H_Danielsen],2002-07,,,,,
+,27505-27781,,Unassigned,,,,,,,,
+ars-vista,27782,tcp,ARS VISTA Application,[Spencer_Teran_2],[Spencer_Teran_2],2004-11,,,,,
+ars-vista,27782,udp,ARS VISTA Application,[Spencer_Teran_2],[Spencer_Teran_2],2004-11,,,,,
+,27783-27875,,Unassigned,,,,,,,,
+astrolink,27876,tcp,Astrolink Protocol,[Alanax_Technologies_Inc],[Wesley_Eddy],2013-01-14,,,,,
+,27876,udp,Reserved,,,,,,,,
+,27877-27998,,Unassigned,,,,,,,,
+tw-auth-key,27999,tcp,TW Authentication/Key Distribution and,[Alex_Duncan_2],[Alex_Duncan_2],,,,,,
+tw-auth-key,27999,udp,Attribute Certificate Services,[Alex_Duncan_2],[Alex_Duncan_2],,,,,,
+nxlmd,28000,tcp,NX License Manager,[Anthony_Greatorex],[Anthony_Greatorex],2004-11,,,,Unauthorized Use Known on port 28000,
+nxlmd,28000,udp,NX License Manager,[Anthony_Greatorex],[Anthony_Greatorex],2004-11,,,,,
+pqsp,28001,tcp,PQ Service,[Peter_Laschtowitz],[Peter_Laschtowitz],2009-09-15,,,,,
+,28001,udp,Reserved,,,,,,,,
+,28002-28118,,Unassigned,,,,,,,"Unauthorized Use Known on ports 28017, 28018 and 28019",
+,28119,tcp,Reserved,,,,,,,,
+a27-ran-ran,28119,udp,A27 cdma2000 RAN Management,[ThreeGPP2],[Zhiming_Li],2012-04-13,,,,,
+,28120-28199,,Unassigned,,,,,,,,
+voxelstorm,28200,tcp,VoxelStorm game server,[VoxelStorm],[Eugene_Hopkinson],2012-11-08,,,,,
+voxelstorm,28200,udp,VoxelStorm game server,[VoxelStorm],[Eugene_Hopkinson],2012-11-08,,,,,
+,28201-28239,,Unassigned,,,,,,,,
+siemensgsm,28240,tcp,Siemens GSM,[David_Anuszewski],[David_Anuszewski],2004-11,,,,,
+siemensgsm,28240,udp,Siemens GSM,[David_Anuszewski],[David_Anuszewski],2004-11,,,,,
+,28241-29117,,Unassigned,,,,,,,,
+,29118,tcp,Reserved,,,,,,,,
+,29118,udp,Reserved,,,,,,,,
+sgsap,29118,sctp,SGsAP in 3GPP,[GPP_Specifications],[GPP_Specifications],2009-06-11,,,,,
+,29119-29166,,Unassigned,,,,,,,,
+otmp,29167,tcp,ObTools Message Protocol,[Paul_Clark],[Paul_Clark],2006-02,,,,,
+otmp,29167,udp,ObTools Message Protocol,[Paul_Clark],[Paul_Clark],2006-02,,,,,
+,29168,tcp,Reserved,,,,,,,,
+,29168,udp,Reserved,,,,,,,,
+sbcap,29168,sctp,SBcAP in 3GPP,[GPP_Specifications],[GPP_Specifications],2009-06-11,,,,,
+iuhsctpassoc,29169,sctp,HNBAP and RUA Common Association,[John_Meredith],[John_Meredith],2009-09-08,,,,,
+,29170-29998,,Unassigned,,,,,,,,
+bingbang,29999,tcp,data exchange protocol for IEC61850 in wind power plants,[DEIF_AS],[Armin_Solies],2012-10-15,,,,,
+,29999,udp,Reserved,,,,,,,,
+ndmps,30000,tcp,Secure Network Data Management Protocol,[Alioune_Thiam],[Alioune_Thiam],2013-02-05,,,,,
+,30000,udp,Reserved,,,,,,,,
+pago-services1,30001,tcp,Pago Services 1,[Balduin_Mueller_Plat],[Balduin_Mueller_Plat],2002-03,,,,,
+pago-services1,30001,udp,Pago Services 1,[Balduin_Mueller_Plat],[Balduin_Mueller_Plat],2002-03,,,,,
+pago-services2,30002,tcp,Pago Services 2,[Balduin_Mueller_Plat],[Balduin_Mueller_Plat],2002-03,,,,,
+pago-services2,30002,udp,Pago Services 2,[Balduin_Mueller_Plat],[Balduin_Mueller_Plat],2002-03,,,,,
+amicon-fpsu-ra,30003,tcp,Amicon FPSU-IP Remote Administration,[Amicon_OOO],[Alexey_Novotorzhin],2013-04-25,,,,,
+amicon-fpsu-ra,30003,udp,Amicon FPSU-IP Remote Administration,[Amicon_OOO],[Alexey_Novotorzhin],2013-04-25,,,,,
+amicon-fpsu-s,30004,udp,Amicon FPSU-IP VPN,[Amicon_OOO],[Alexey_Novotorzhin],2013-04-25,,,,,
+,30004,tcp,Reserved,,,,,,,,
+,30005-30259,,Unassigned,,,,,,,,
+kingdomsonline,30260,tcp,Kingdoms Online (CraigAvenue),[Drake_Bankston],[Drake_Bankston],2009-08-18,,,,,
+kingdomsonline,30260,udp,Kingdoms Online (CraigAvenue),[Drake_Bankston],[Drake_Bankston],2009-08-18,,,,,
+,30261-30831,,Unassigned,,,,,,,,
+samsung-disc,30832,udp,Samsung Convergence Discovery Protocol,[Samsung_2],[Young_Ki_Kim],2013-05-29,,,,,
+,30832,tcp,Reserved,,,,,,,,
+,30833-30998,,Unassigned,,,,,,,,
+ovobs,30999,tcp,OpenView Service Desk Client,[Service_Desk_Product],[Service_Desk_Product],2006-05,,,,,
+ovobs,30999,udp,OpenView Service Desk Client,[Service_Desk_Product],[Service_Desk_Product],2006-05,,,,,
+,31000-31019,,Unassigned,,,,,,,,
+autotrac-acp,31020,tcp,Autotrac ACP 245,[Roberto_Jorge_Dino],[Roberto_Jorge_Dino],,,,,,
+,31020,udp,Reserved,,,,,,,,
+,31021-31028,,Unassigned,,,,,,,,
+,31029,tcp,Reserved,,,,,,,,
+yawn,31029,udp,YaWN - Yet Another Windows Notifier,[David_Spivey],[David_Spivey],2010-08-30,,,,,
+,31030-31399,,Unassigned,,,,,,,,
+pace-licensed,31400,tcp,PACE license server,[PACE_Anti-Piracy],[Allen_Cronce],2014-04-28,,,,,
+,31400,udp,Reserved,,,,,,,,
+,31401-31415,,Unassigned,,,,,,,,
+xqosd,31416,tcp,XQoS network monitor,[Joe_Elliott],[Joe_Elliott],2002-06,,,,,
+xqosd,31416,udp,XQoS network monitor,[Joe_Elliott],[Joe_Elliott],2002-06,,,,,
+,31417-31456,,Unassigned,,,,,,,,
+tetrinet,31457,tcp,TetriNET Protocol,[Emmanuel_Bourg],[Emmanuel_Bourg],2004-11,,,,,
+tetrinet,31457,udp,TetriNET Protocol,[Emmanuel_Bourg],[Emmanuel_Bourg],2004-11,,,,,
+,31458-31619,,Unassigned,,,,,,,,
+lm-mon,31620,tcp,lm mon,[System_Administrator],[System_Administrator],2003-06,,,,,
+lm-mon,31620,udp,lm mon,[System_Administrator],[System_Administrator],2003-06,,,,,
+,31621-31684,,Unassigned,,,,,,,,
+dsx-monitor,31685,tcp,"DS Expert Monitor
+IANA assigned this well-formed service name as a replacement for ""dsx_monitor"".",[John_Lowery],[John_Lowery],2008-08-21,,,,,
+dsx_monitor,31685,tcp,DS Expert Monitor,[John_Lowery],[John_Lowery],2008-08-21,,,,,"This entry is an alias to ""dsx-monitor"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+,31685,udp,Reserved,,,,,,,,
+,31686-31764,,Unassigned,,,,,,,,
+gamesmith-port,31765,tcp,GameSmith Port,[Randy_Thompson],[Randy_Thompson],2002-08,,,,,
+gamesmith-port,31765,udp,GameSmith Port,[Randy_Thompson],[Randy_Thompson],2002-08,,,,,
+,31766-31947,,Unassigned,,,,,,,,
+iceedcp-tx,31948,tcp,"Embedded Device Configuration Protocol TX
+IANA assigned this well-formed service name as a replacement for ""iceedcp_tx"".",[Oliver_Lewis],[Oliver_Lewis],2006-08,,,,,
+iceedcp_tx,31948,tcp,Embedded Device Configuration Protocol TX,[Oliver_Lewis],[Oliver_Lewis],2006-08,,,,,"This entry is an alias to ""iceedcp-tx"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+iceedcp-tx,31948,udp,"Embedded Device Configuration Protocol TX
+IANA assigned this well-formed service name as a replacement for ""iceedcp_tx"".",[Oliver_Lewis],[Oliver_Lewis],2006-08,,,,,
+iceedcp_tx,31948,udp,Embedded Device Configuration Protocol TX,[Oliver_Lewis],[Oliver_Lewis],2006-08,,,,,"This entry is an alias to ""iceedcp-tx"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+iceedcp-rx,31949,tcp,"Embedded Device Configuration Protocol RX
+IANA assigned this well-formed service name as a replacement for ""iceedcp_rx"".",[Oliver_Lewis],[Oliver_Lewis],2006-08,,,,,
+iceedcp_rx,31949,tcp,Embedded Device Configuration Protocol RX,[Oliver_Lewis],[Oliver_Lewis],2006-08,,,,,"This entry is an alias to ""iceedcp-rx"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+iceedcp-rx,31949,udp,"Embedded Device Configuration Protocol RX
+IANA assigned this well-formed service name as a replacement for ""iceedcp_rx"".",[Oliver_Lewis],[Oliver_Lewis],2006-08,,,,,
+iceedcp_rx,31949,udp,Embedded Device Configuration Protocol RX,[Oliver_Lewis],[Oliver_Lewis],2006-08,,,,,"This entry is an alias to ""iceedcp-rx"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+,31950-32033,,Unassigned,,,,,,,,
+iracinghelper,32034,tcp,iRacing helper service,[Randy_Cassidy],[Randy_Cassidy],2007-08-30,,,,,
+iracinghelper,32034,udp,iRacing helper service,[Randy_Cassidy],[Randy_Cassidy],2007-08-30,,,,,
+,32035-32248,,Unassigned,,,,,,,,
+t1distproc60,32249,tcp,T1 Distributed Processor,[Peter_Beahan],[Peter_Beahan],2004-11,,,,,
+t1distproc60,32249,udp,T1 Distributed Processor,[Peter_Beahan],[Peter_Beahan],2004-11,,,,,
+,32250-32482,,Unassigned,,,,,,,,
+apm-link,32483,tcp,Access Point Manager Link,[Tony_Diodato],[Tony_Diodato],2005-08,,,,,
+apm-link,32483,udp,Access Point Manager Link,[Tony_Diodato],[Tony_Diodato],2005-08,,,,,
+,32484-32634,,Unassigned,,,,,,,,
+sec-ntb-clnt,32635,tcp,SecureNotebook-CLNT,[Eric_Cantineau],[Eric_Cantineau],2004-11,,,,,
+sec-ntb-clnt,32635,udp,SecureNotebook-CLNT,[Eric_Cantineau],[Eric_Cantineau],2004-11,,,,,
+DMExpress,32636,tcp,DMExpress,[Arnie_Farrelly],[Arnie_Farrelly],,,,,,
+DMExpress,32636,udp,DMExpress,[Arnie_Farrelly],[Arnie_Farrelly],,,,,,
+,32637-32766,,Unassigned,,,,,,,,
+filenet-powsrm,32767,tcp,FileNet BPM WS-ReliableMessaging Client,[Chris_Adkins],[Chris_Adkins],2006-08,,,,,
+filenet-powsrm,32767,udp,FileNet BPM WS-ReliableMessaging Client,[Chris_Adkins],[Chris_Adkins],2006-08,,,,,
+filenet-tms,32768,tcp,Filenet TMS,[Daniel_Whelan],[Daniel_Whelan],,,,,,
+filenet-tms,32768,udp,Filenet TMS,[Daniel_Whelan],[Daniel_Whelan],,,,,,
+filenet-rpc,32769,tcp,Filenet RPC,[Daniel_Whelan],[Daniel_Whelan],,,,,,
+filenet-rpc,32769,udp,Filenet RPC,[Daniel_Whelan],[Daniel_Whelan],,,,,,
+filenet-nch,32770,tcp,Filenet NCH,[Daniel_Whelan],[Daniel_Whelan],,,,,,
+filenet-nch,32770,udp,Filenet NCH,[Daniel_Whelan],[Daniel_Whelan],,,,,,
+filenet-rmi,32771,tcp,FileNET RMI,[Chris_Adkins],[Chris_Adkins],,,,,,
+filenet-rmi,32771,udp,FileNet RMI,[Chris_Adkins],[Chris_Adkins],,,,,,
+filenet-pa,32772,tcp,FileNET Process Analyzer,[Chris_Adkins],[Chris_Adkins],2003-01,,,,,
+filenet-pa,32772,udp,FileNET Process Analyzer,[Chris_Adkins],[Chris_Adkins],2003-01,,,,,
+filenet-cm,32773,tcp,FileNET Component Manager,[Chris_Adkins],[Chris_Adkins],2003-08,,,,,
+filenet-cm,32773,udp,FileNET Component Manager,[Chris_Adkins],[Chris_Adkins],2003-08,,,,,
+filenet-re,32774,tcp,FileNET Rules Engine,[Chris_Adkins],[Chris_Adkins],2003-08,,,,,
+filenet-re,32774,udp,FileNET Rules Engine,[Chris_Adkins],[Chris_Adkins],2003-08,,,,,
+filenet-pch,32775,tcp,Performance Clearinghouse,[Tim_Morgan_2],[Tim_Morgan_2],2005-11,,,,,
+filenet-pch,32775,udp,Performance Clearinghouse,[Tim_Morgan_2],[Tim_Morgan_2],2005-11,,,,,
+filenet-peior,32776,tcp,FileNET BPM IOR,[Chris_Adkins],[Chris_Adkins],2006-05,,,,,
+filenet-peior,32776,udp,FileNET BPM IOR,[Chris_Adkins],[Chris_Adkins],2006-05,,,,,
+filenet-obrok,32777,tcp,FileNet BPM CORBA,[Chris_Adkins],[Chris_Adkins],2006-10,,,,,
+filenet-obrok,32777,udp,FileNet BPM CORBA,[Chris_Adkins],[Chris_Adkins],2006-10,,,,,
+,32778-32800,,Unassigned,,,,,,,,
+mlsn,32801,tcp,Multiple Listing Service Network,[Corey_Leong],[Corey_Leong],2010-10-11,,,,,
+mlsn,32801,udp,Multiple Listing Service Network,[Corey_Leong],[Corey_Leong],2010-10-11,,,,,
+,32802-32810,,Unassigned,,,,,,,,
+retp,32811,tcp,Real Estate Transport Protocol,[Corey_Leong],[Corey_Leong],2010-10-11,,,,,
+,32811,udp,Reserved,,,,,,,,
+,32812-32895,,Unassigned,,,,,,,,
+idmgratm,32896,tcp,Attachmate ID Manager,[George_Gianelos_2],[George_Gianelos_2],2003-03,,,,,
+idmgratm,32896,udp,Attachmate ID Manager,[George_Gianelos_2],[George_Gianelos_2],2003-03,,,,,
+,32897-33122,,Unassigned,,,,,,,,
+aurora-balaena,33123,tcp,Aurora (Balaena Ltd),[Andrew_Mather],[Andrew_Mather],2008-02-14,,,,,
+aurora-balaena,33123,udp,Aurora (Balaena Ltd),[Andrew_Mather],[Andrew_Mather],2008-02-14,,,,,
+,33124-33330,,Unassigned,,,,,,,,
+diamondport,33331,tcp,DiamondCentral Interface,[Edward_Browdy],[Edward_Browdy],2002-07,,,,,
+diamondport,33331,udp,DiamondCentral Interface,[Edward_Browdy],[Edward_Browdy],2002-07,,,,,
+,33332,,Unassigned,,,,,,,,
+dgi-serv,33333,tcp,Digital Gaslight Service,[George_Flanagin],[George_Flanagin],2010-03-02,,,,,
+,33333,udp,Reserved,,,,,,,,
+speedtrace,33334,tcp,SpeedTrace TraceAgent,[Holger_Heinrich],[Holger_Heinrich],2012-02-01,,,,,
+speedtrace-disc,33334,udp,SpeedTrace TraceAgent Discovery,[Holger_Heinrich],[Holger_Heinrich],2012-02-01,,,,,
+,33335-33433,,Unassigned,,,,,,,,
+traceroute,33434,tcp,traceroute use,[IANA],[IANA],,,,,,
+traceroute,33434,udp,traceroute use,[IANA],[IANA],,,,,,
+,33435-33655,,Unassigned,,,,,,,,
+snip-slave,33656,tcp,SNIP Slave,[Dr_Chris_Tucker],[Dr_Chris_Tucker],2005-08,,,,,
+snip-slave,33656,udp,SNIP Slave,[Dr_Chris_Tucker],[Dr_Chris_Tucker],2005-08,,,,,
+,33657-34248,,Unassigned,,,,,,,,
+turbonote-2,34249,tcp,TurboNote Relay Server Default Port,[Peter_Hyde],[Peter_Hyde],,,,,,
+turbonote-2,34249,udp,TurboNote Relay Server Default Port,[Peter_Hyde],[Peter_Hyde],,,,,,
+,34250-34377,,Unassigned,,,,,,,,
+p-net-local,34378,tcp,P-Net on IP local,[Kurt_Nissen],[Kurt_Nissen],2004-02,,,,,
+p-net-local,34378,udp,P-Net on IP local,[Kurt_Nissen],[Kurt_Nissen],2004-02,,,,,
+p-net-remote,34379,tcp,P-Net on IP remote,[Kurt_Nissen],[Kurt_Nissen],2004-02,,,,,
+p-net-remote,34379,udp,P-Net on IP remote,[Kurt_Nissen],[Kurt_Nissen],2004-02,,,,,
+,34380-34566,,Unassigned,,,,,,,,
+dhanalakshmi,34567,tcp,dhanalakshmi.org EDI Service,[Girish_Gopalakrishna],[Girish_Gopalakrishna],2010-04-20,,,,,
+,34567,udp,Reserved,,,,,,,,
+,34568-34961,,Unassigned,,,,,,,,
+profinet-rt,34962,tcp,PROFInet RT Unicast,[Peter_Wenzel],[Peter_Wenzel],2004-11,,,,,
+profinet-rt,34962,udp,PROFInet RT Unicast,[Peter_Wenzel],[Peter_Wenzel],2004-11,,,,,
+profinet-rtm,34963,tcp,PROFInet RT Multicast,[Peter_Wenzel],[Peter_Wenzel],2004-11,,,,,
+profinet-rtm,34963,udp,PROFInet RT Multicast,[Peter_Wenzel],[Peter_Wenzel],2004-11,,,,,
+profinet-cm,34964,tcp,PROFInet Context Manager,[Peter_Wenzel],[Peter_Wenzel],2004-11,,,,,
+profinet-cm,34964,udp,PROFInet Context Manager,[Peter_Wenzel],[Peter_Wenzel],2004-11,,,,,
+,34965-34979,,Unassigned,,,,,,,,
+ethercat,34980,tcp,EtherCAT Port,[Martin_Rostan],[Martin_Rostan],2003-11,,,,,
+ethercat,34980,udp,EhterCAT Port,[Martin_Rostan],[Martin_Rostan],2003-11,,,,,
+,34981-34999,,Unassigned,,,,,,,,
+heathview,35000,tcp,HeathView,[Heathwest_Systems_Limited],[Andrew_Porrer],2013-03-21,,,,,
+,35000,udp,Reserved,,,,,,,,
+rt-viewer,35001,tcp,ReadyTech Viewer,[ReadyTech_Corporation],[Kevin_Woodward],2013-09-13,,,,,
+rt-viewer,35001,udp,ReadyTech Viewer,[ReadyTech_Corporation],[Kevin_Woodward],2013-09-13,,,,,
+rt-sound,35002,tcp,ReadyTech Sound Server,[ReadyTech_Corporation],[Kevin_Woodward],2013-09-13,,,,,
+,35002,udp,Reserved,,,,,,,,
+rt-devicemapper,35003,tcp,ReadyTech DeviceMapper Server,[ReadyTech_Corporation],[Kevin_Woodward],2013-09-13,,,,,
+,35003,udp,Reserved,,,,,,,,
+rt-classmanager,35004,tcp,ReadyTech ClassManager,[ReadyTech_Corporation],[Kevin_Woodward],2013-09-13,,,,,
+rt-classmanager,35004,udp,ReadyTech ClassManager,[ReadyTech_Corporation],[Kevin_Woodward],2013-09-13,,,,,
+rt-labtracker,35005,tcp,ReadyTech LabTracker,[ReadyTech_Corporation],[Kevin_Woodward],2013-09-13,,,,,
+,35005,udp,Reserved,,,,,,,,
+rt-helper,35006,tcp,ReadyTech Helper Service,[ReadyTech_Corporation],[Kevin_Woodward],2013-09-13,,,,,
+,35006,udp,Reserved,,,,,,,,
+,35007-35353,,Unassigned,,,,,,,,
+kitim,35354,tcp,KIT Messenger,[Rudi_Visser],[Rudi_Visser],2011-07-07,,,,,
+,35354,udp,Reserved,,,,,,,,
+altova-lm,35355,tcp,Altova License Management,[Alexander_Falk_2],[Alexander_Falk_2],2011-07-07,,,,,
+altova-lm-disc,35355,udp,Altova License Management Discovery,[Alexander_Falk_2],[Alexander_Falk_2],2011-07-07,,,,,
+guttersnex,35356,tcp,Gutters Note Exchange,[Squee_Application_Development],[Tristan_Seifert_2],2011-07-19,,,,,
+,35356,udp,Reserved,,,,,,,,
+openstack-id,35357,tcp,OpenStack ID Service,[Rackspace_Hosting],[Ziad_Sawalha],2011-08-15,,,,,
+,35357,udp,Reserved,,,,,,,,
+,35358-36000,,Unassigned,,,,,,,,
+allpeers,36001,tcp,AllPeers Network,[Cedric_Maloux],[Cedric_Maloux],2007-04,,,,,
+allpeers,36001,udp,AllPeers Network,[Cedric_Maloux],[Cedric_Maloux],2007-04,,,,,
+,36002-36411,,Unassigned,,,,,,,,
+,36412,tcp,Reserved,,,,,,,,
+,36412,udp,Reserved,,,,,,,,
+s1-control,36412,sctp,S1-Control Plane (3GPP),[Kimmo_Kymalainen],[Kimmo_Kymalainen],2009-09-01,,,,,
+,36413-36421,,Unassigned,,,,,,,,
+,36422,tcp,Reserved,,,,,,,,
+,36422,udp,Reserved,,,,,,,,
+x2-control,36422,sctp,X2-Control Plane (3GPP),[Kimmo_Kymalainen],[Kimmo_Kymalainen],2009-09-01,,,,,
+,36423-36442,,Unassigned,,,,,,,,
+m2ap,36443,sctp,M2 Application Part,[Dario_S_Tonesi],[Dario_S_Tonesi],2011-02-07,,,,,
+m3ap,36444,sctp,M3 Application Part,[Dario_S_Tonesi],[Dario_S_Tonesi],2011-02-07,,,,,
+,36445-36523,,Unassigned,,,,,,,,
+febooti-aw,36524,tcp,Febooti Automation Workshop,[Maris_Bormanis],[Maris_Bormanis],2011-06-10,,,,,
+,36524,udp,Reserved,,,,,,,,
+,36525-36601,,Unassigned,,,,,,,,
+observium-agent,36602,tcp,Observium statistics collection agent,[Observium],[Adam_Armstrong],2013-05-10,,,,,
+,36602,udp,Reserved,,,,,,,,
+,36603-36699,,Unassigned,,,,,,,,
+mapx,36700,tcp,MapX communication,[MicroTechniX],[Yarochkin_Michail],2014-10-13,,,,,
+,36700,udp,Reserved,,,,,,,,
+,36701-36864,,Unassigned,,,,,,,,
+kastenxpipe,36865,tcp,KastenX Pipe,[Guy_Cheng],[Guy_Cheng],,,,,,
+kastenxpipe,36865,udp,KastenX Pipe,[Guy_Cheng],[Guy_Cheng],,,,,,
+,36866-37474,,Unassigned,,,,,,,,
+neckar,37475,tcp,science + computing's Venus Administration Port,[Ralf_Allrutz],[Ralf_Allrutz],2002-02,,,,,
+neckar,37475,udp,science + computing's Venus Administration Port,[Ralf_Allrutz],[Ralf_Allrutz],2002-02,,,,,
+,37476-37482,,Unassigned,,,,,,,,
+gdrive-sync,37483,tcp,Google Drive Sync,[Google],[Fil_Zembowicz],2013-02-01,,,,,
+,37483,udp,Reserved,,,,,,,,
+,37484-37653,,Unassigned,,,,,,,,
+unisys-eportal,37654,tcp,Unisys ClearPath ePortal,[Sung_U_Ro],[Sung_U_Ro],2006-01,,,,,
+unisys-eportal,37654,udp,Unisys ClearPath ePortal,[Sung_U_Ro],[Sung_U_Ro],2006-01,,,,,
+,37655-37999,,Unassigned,,,,,,,,
+ivs-database,38000,tcp,InfoVista Server Database,[InfoVista],[Sebastien_Bouchex_Bellomie],2014-05-23,,,,,
+,38000,udp,Reserved,,,,,,,,
+ivs-insertion,38001,tcp,InfoVista Server Insertion,[InfoVista],[Sebastien_Bouchex_Bellomie],2014-05-23,,,,,
+,38001,udp,Reserved,,,,,,,,
+,38002-38200,,Unassigned,,,,,,,,
+galaxy7-data,38201,tcp,Galaxy7 Data Tunnel,[Tatham_Oddie],[Tatham_Oddie],2002-09,,,,,
+galaxy7-data,38201,udp,Galaxy7 Data Tunnel,[Tatham_Oddie],[Tatham_Oddie],2002-09,,,,,
+fairview,38202,tcp,Fairview Message Service,[Jim_Lyle],[Jim_Lyle],2005-11,,,,,"Defined TXT keys: DevID=<device id>, DevType=<device type>, DevStat=<device status>"
+fairview,38202,udp,Fairview Message Service,[Jim_Lyle],[Jim_Lyle],2005-11,,,,,"Defined TXT keys: DevID=<device id>, DevType=<device type>, DevStat=<device status>"
+agpolicy,38203,tcp,AppGate Policy Server,[Martin_Forssen],[Martin_Forssen],2004-11,,,,,
+agpolicy,38203,udp,AppGate Policy Server,[Martin_Forssen],[Martin_Forssen],2004-11,,,,,
+,38204-38799,,Unassigned,,,,,,,,
+sruth,38800,tcp,"Sruth is a service for the distribution of routinely-
+ generated but arbitrary files based on a publish/subscribe
+ distribution model and implemented using a peer-to-peer transport
+ mechanism",[University_Corporation_for_Atmospheric_Research],[Steven_Emmerson],2012-05-07,,,,,
+,38800,udp,Reserved,,,,,,,,
+,38801-38864,,Unassigned,,,,,,,,
+secrmmsafecopya,38865,tcp,Security approval process for use of the secRMM SafeCopy program,[Squadra_Technologies],[Anthony_LaMark],2012-03-14,,,,,
+,38865,udp,Reserved,,,,,,,,
+,38866-39680,,Unassigned,,,,,,,,
+turbonote-1,39681,tcp,TurboNote Default Port,[Peter_Hyde],[Peter_Hyde],,,,,,
+turbonote-1,39681,udp,TurboNote Default Port,[Peter_Hyde],[Peter_Hyde],,,,,,
+,39682-39999,,Unassigned,,,,,,,,
+safetynetp,40000,tcp,SafetyNET p,[Roland_Rupp],[Roland_Rupp],2006-11,,,,,
+safetynetp,40000,udp,SafetyNET p,[Roland_Rupp],[Roland_Rupp],2006-11,,,,,
+,40001-40403,,Unassigned,,,,,,,,
+sptx,40404,tcp,Simplify Printing TX,[Tricerat],[Eric_Musgrave],2013-12-09,,,,,
+,40404,udp,Reserved,,,,,,,,
+,40405-40840,,Unassigned,,,,,,,,
+cscp,40841,tcp,CSCP,[Michael_Dodge],[Michael_Dodge],,,,,,
+cscp,40841,udp,CSCP,[Michael_Dodge],[Michael_Dodge],,,,,,
+csccredir,40842,tcp,CSCCREDIR,[Sudhir_Menon],[Sudhir_Menon],,,,,,
+csccredir,40842,udp,CSCCREDIR,[Sudhir_Menon],[Sudhir_Menon],,,,,,
+csccfirewall,40843,tcp,CSCCFIREWALL,[Sudhir_Menon],[Sudhir_Menon],,,,,,
+csccfirewall,40843,udp,CSCCFIREWALL,[Sudhir_Menon],[Sudhir_Menon],,,,,,
+,40844-40852,,Unassigned,,,,,,,,
+,40853,tcp,Reserved,,,,,,,,
+ortec-disc,40853,udp,ORTEC Service Discovery,[Jesse_Ursery],[Jesse_Ursery],2010-11-22,,,,,
+,40854-41110,,Unassigned,,,,,,,,
+fs-qos,41111,tcp,Foursticks QoS Protocol,[Chee_Kent_Lam],[Chee_Kent_Lam],2002-04,,,,,
+fs-qos,41111,udp,Foursticks QoS Protocol,[Chee_Kent_Lam],[Chee_Kent_Lam],2002-04,,,,,
+,41112-41120,,Unassigned,,,,,,,,
+tentacle,41121,tcp,Tentacle Server,[Sancho_Lerena],[Sancho_Lerena],2009-06-02,,,,,
+,41121,udp,Reserved,,,,,,,,
+,41122-41793,,Unassigned,,,,,,,,
+crestron-cip,41794,tcp,Crestron Control Port,[Ed_Ranney],[Ed_Ranney],2003-01,,,,,
+crestron-cip,41794,udp,Crestron Control Port,[Ed_Ranney],[Ed_Ranney],2003-01,,,,,
+crestron-ctp,41795,tcp,Crestron Terminal Port,[Ed_Ranney],[Ed_Ranney],2003-01,,,,,
+crestron-ctp,41795,udp,Crestron Terminal Port,[Ed_Ranney],[Ed_Ranney],2003-01,,,,,
+crestron-cips,41796,tcp,Crestron Secure Control Port,[Crestron_Electronics],[Manish_Talreja],2012-06-27,,,,,
+,41796,udp,Reserved,,,,,,,,
+crestron-ctps,41797,tcp,Crestron Secure Terminal Port,[Crestron_Electronics],[Manish_Talreja],2012-06-27,,,,,
+,41797,udp,Reserved,,,,,,,,
+,41798-42507,,Unassigned,,,,,,,Unauthorized Use Known on port 42000,
+candp,42508,tcp,Computer Associates network discovery protocol,[Jon_Press],[Jon_Press],2005-09,,,,,
+candp,42508,udp,Computer Associates network discovery protocol,[Jon_Press],[Jon_Press],2005-09,,,,,
+candrp,42509,tcp,CA discovery response,[Jon_Press],[Jon_Press],2005-08,,,,,
+candrp,42509,udp,CA discovery response,[Jon_Press],[Jon_Press],2005-08,,,,,
+caerpc,42510,tcp,CA eTrust RPC,[Jon_Press],[Jon_Press],2005-08,,,,,
+caerpc,42510,udp,CA eTrust RPC,[Jon_Press],[Jon_Press],2005-08,,,,,
+,42511-42999,,Unassigned,,,,,,,,
+recvr-rc,43000,tcp,Receiver Remote Control,[Research_Electronics_International],[Ross_Binkley],2012-12-20,,,,,
+recvr-rc-disc,43000,udp,Receiver Remote Control Discovery,[Research_Electronics_International],[Ross_Binkley],2012-12-20,,,,,
+,43001-43187,,Unassigned,,,,,,,,
+reachout,43188,tcp,REACHOUT,[Roman_Kriis],[Roman_Kriis],,,,,,
+reachout,43188,udp,REACHOUT,[Roman_Kriis],[Roman_Kriis],,,,,,
+ndm-agent-port,43189,tcp,NDM-AGENT-PORT,[Roman_Kriis],[Roman_Kriis],,,,,,
+ndm-agent-port,43189,udp,NDM-AGENT-PORT,[Roman_Kriis],[Roman_Kriis],,,,,,
+ip-provision,43190,tcp,IP-PROVISION,[Roman_Kriis],[Roman_Kriis],,,,,,
+ip-provision,43190,udp,IP-PROVISION,[Roman_Kriis],[Roman_Kriis],,,,,,
+noit-transport,43191,tcp,Reconnoiter Agent Data Transport,[Theo_Schlossnagle],[Theo_Schlossnagle],2009-05-19,,,,,
+,43191,udp,Reserved,,,,,,,,
+,43192-43209,,Unassigned,,,,,,,,
+shaperai,43210,tcp,Shaper Automation Server Management,[Shaper_Automation],[Yohann_Sulaiman],2012-06-22,,,,,
+shaperai-disc,43210,udp,Shaper Automation Server Management Discovery,[Shaper_Automation],[Yohann_Sulaiman],2012-06-22,,,,,
+,43211-43438,,Unassigned,,,,,,,,
+eq3-update,43439,tcp,EQ3 firmware update,[eQ-3_Entwicklung_GmbH],[Tido_de_Vries],2012-02-10,2014-05-09,,,,
+eq3-config,43439,udp,EQ3 discovery and configuration,[eQ-3_Entwicklung_GmbH],[Tido_de_Vries],2012-02-10,2014-05-09,,,,
+ew-mgmt,43440,tcp,Cisco EnergyWise Management,,,,,,,,
+ew-disc-cmd,43440,udp,Cisco EnergyWise Discovery and Command Flooding,[John_Parello],[John_Parello],2009-05-19,,,,,
+ciscocsdb,43441,tcp,Cisco NetMgmt DB Ports,[Cisco_Systems],[Cisco_Systems],2005-11,,,,,
+ciscocsdb,43441,udp,Cisco NetMgmt DB Ports,[Cisco_Systems],[Cisco_Systems],2005-11,,,,,
+,43442-44122,,Unassigned,,,,,,,,
+z-wave-s,44123,tcp,Z-Wave Secure Tunnel,[Sigma_Designs_Inc],[Anders_Brandt_3],2012-10-12,,,,,
+,44123,udp,Reserved,,,,,,,,
+,43124-44320,,Unassigned,,,,,,,,
+pmcd,44321,tcp,PCP server (pmcd),[Ken_McDonell],[Ken_McDonell],2010-12-20,,,,,
+pmcd,44321,udp,PCP server (pmcd),[Ken_McDonell],[Ken_McDonell],2010-12-20,,,,,
+pmcdproxy,44322,tcp,PCP server (pmcd) proxy,[Ken_McDonell],[Ken_McDonell],2003-07,2010-12-20,,,,
+pmcdproxy,44322,udp,PCP server (pmcd) proxy,[Ken_McDonell],[Ken_McDonell],2003-07,2010-12-20,,,,
+pmwebapi,44323,tcp,HTTP binding for Performance Co-Pilot client API,[Performance_Co-Pilot_PCP_Project],[Ken_McDonell_2],2013-10-09,,,,,
+,44323,udp,Unassigned,,,,,,,,"""pcp"" assignment withdrawn, moved to port 5351 per RFC6887"
+,44324-44443,,Unassigned,,,,,,,,
+cognex-dataman,44444,tcp,Cognex DataMan Management Protocol,[Cognex],[Mario_Joussen],2012-08-28,,,,,
+,44444,udp,Reserved,,,,,,,,
+,44445-44543,,Unassigned,,,,,,,Known UNAUTHORIZED USE: Ports 44515 & 44516,
+,44544,tcp,Reserved,,,,,,,,
+domiq,44544,udp,DOMIQ Building Automation,[DOMIQ_Sp_zoo],[Filip_Zawadiak],2011-08-29,,,,,
+,44545-44552,,Unassigned,,,,,,,,
+rbr-debug,44553,tcp,REALbasic Remote Debug,[Aaron_Ballman],[Aaron_Ballman],2004-11,,,,,
+rbr-debug,44553,udp,REALbasic Remote Debug,[Aaron_Ballman],[Aaron_Ballman],2004-11,,,,,
+,44554-44599,,Unassigned,,,,,,,,
+,44600,tcp,Reserved,,,,,,,,
+asihpi,44600,udp,AudioScience HPI,[Eliot_Blennerhassett],[Eliot_Blennerhassett],2011-07-07,,,,,
+,44601-44817,,Unassigned,,,,,,,,
+EtherNet-IP-2,44818,tcp,"EtherNet/IP messaging
+IANA assigned this well-formed service name as a replacement for ""EtherNet/IP-2"".",[Brian_Batke_2],[Brian_Batke_2],,,,,,New contact added for port 44818 on 2008-02-01
+EtherNet/IP-2,44818,tcp,EtherNet/IP messaging,[Brian_Batke_2],[Brian_Batke_2],,,,,,"New contact added for port 44818 on 2008-02-01
+This entry is an alias to ""EtherNet-IP-2"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+EtherNet-IP-2,44818,udp,"EtherNet/IP messaging
+IANA assigned this well-formed service name as a replacement for ""EtherNet/IP-2"".",[Brian_Batke_2],[Brian_Batke_2],,,,,,New contact added for port 44818 on 2008-02-01
+EtherNet/IP-2,44818,udp,EtherNet/IP messaging,[Brian_Batke_2],[Brian_Batke_2],,,,,,"New contact added for port 44818 on 2008-02-01
+This entry is an alias to ""EtherNet-IP-2"".
+This entry is now historic, not usable for use with many
+common service discovery mechanisms."
+,44819-44899,,Unassigned,,,,,,,,
+m3da,44900,tcp,M3DA is used for efficient machine-to-machine communications,[Eclipse_Foundation],[Didier_Lahay],2013-02-22,,,,,
+m3da-disc,44900,udp,M3DA Discovery is used for efficient machine-to-machine communications,[Eclipse_Foundation],[Didier_Lahay],2013-02-22,,,,,
+,44901-44999,,Unassigned,,,,,,,,
+asmp,45000,tcp,NSi AutoStore Status Monitoring Protocol data transfer,[Notable_Solutions_Inc],[Andrew_Andrews],2011-09-01,,,,,
+asmp-mon,45000,udp,NSi AutoStore Status Monitoring Protocol device monitoring,[Notable_Solutions_Inc],[Andrew_Andrews],2011-09-01,,,,,
+asmps,45001,tcp,NSi AutoStore Status Monitoring Protocol secure data transfer,[Notable_Solutions_Inc],[Andrew_Andrews],2011-09-01,,,,,
+,45001,udp,Reserved,,,,,,,,
+,45002-45044,,Unassigned,,,,,,,,
+synctest,45045,tcp,Remote application control protocol,[Eleks_Ltd],[Andriy_Skop],2013-04-08,,,,,
+,45045,udp,Reserved,,,,,,,,
+,45046-45053,,Unassigned,,,,,,,,
+invision-ag,45054,tcp,InVision AG,[Matthias_Schroer],[Matthias_Schroer],,,,,,
+invision-ag,45054,udp,InVision AG,[Matthias_Schroer],[Matthias_Schroer],,,,,,
+,45055-45677,,Unassigned,,,,,,,,
+eba,45678,tcp,EBA PRISE,[Patrick_Kara],[Patrick_Kara],,,,,,
+eba,45678,udp,EBA PRISE,[Patrick_Kara],[Patrick_Kara],,,,,,
+,45679-45823,,Unassigned,,,,,,,,
+dai-shell,45824,tcp,Server for the DAI family of client-server products,[Data_Access_Inc],[Adam_Robinson],2012-04-30,,,,,
+,45824,udp,Reserved,,,,,,,,
+qdb2service,45825,tcp,Qpuncture Data Access Service,[Michael_Yun],[Michael_Yun],2007-10-24,,,,,
+qdb2service,45825,udp,Qpuncture Data Access Service,[Michael_Yun],[Michael_Yun],2007-10-24,,,,,
+,45826-45965,,Unassigned,,,,,,,,
+ssr-servermgr,45966,tcp,SSRServerMgr,[Jeremy_Gilliat],[Jeremy_Gilliat],,,,,,
+ssr-servermgr,45966,udp,SSRServerMgr,[Jeremy_Gilliat],[Jeremy_Gilliat],,,,,,
+,45967-46997,,Unassigned,,,,,,,,
+spremotetablet,46998,tcp,Connection between a desktop computer or server and a signature tablet to capture handwritten signatures,[SOFTPRO_GmbH],[Christoph_Hipp],2012-07-19,2013-08-02,,,,
+,46998,udp,Reserved,,,,,,,,
+mediabox,46999,tcp,MediaBox Server,[Alexander_Graef],[Alexander_Graef],2004-11,,,,,
+mediabox,46999,udp,MediaBox Server,[Alexander_Graef],[Alexander_Graef],2004-11,,,,,
+mbus,47000,tcp,Message Bus,[Dirk_Kutscher],[Dirk_Kutscher],,,,,,
+mbus,47000,udp,Message Bus,[Dirk_Kutscher],[Dirk_Kutscher],,,,,,
+winrm,47001,tcp,Windows Remote Management Service,[Ryan_Mack],[Ryan_Mack],2009-04-29,,,,,
+,47001,udp,Reserved,,,,,,,,
+,47002-47099,,Unassigned,,,,,,,,
+jvl-mactalk,47100,udp,Configuration of motors connected to Industrial Ethernet,[JVL_Industri_Elektronik],[Kim_Berthelsen],2012-12-21,,,,,
+,47100,tcp,Reserved,,,,,,,,
+,47101-47556,,Unassigned,,,,,,,,
+dbbrowse,47557,tcp,Databeam Corporation,[Cindy_Martin],[Cindy_Martin],,,,,,
+dbbrowse,47557,udp,Databeam Corporation,[Cindy_Martin],[Cindy_Martin],,,,,,
+,47558-47623,,Unassigned,,,,,,,,
+directplaysrvr,47624,tcp,Direct Play Server,[Ajay_Jindal],[Ajay_Jindal],,,,,,
+directplaysrvr,47624,udp,Direct Play Server,[Ajay_Jindal],[Ajay_Jindal],,,,,,
+,47625-47805,,Unassigned,,,,,,,,
+ap,47806,tcp,ALC Protocol,[Dave_Robin],[Dave_Robin],,,,,,
+ap,47806,udp,ALC Protocol,[Dave_Robin],[Dave_Robin],,,,,,
+,47807,,Unassigned,,,,,,,,
+bacnet,47808,tcp,Building Automation and Control Networks,[Coleman_Brumley],[Coleman_Brumley],2011-02-10,,,,,
+bacnet,47808,udp,Building Automation and Control Networks,[Coleman_Brumley],[Coleman_Brumley],2011-02-10,,,,,
+presonus-ucnet,47809,udp,PreSonus Universal Control Network Protocol,[PreSonus_Audio_Electronics_Inc],[Matthias_Juwan],2013-07-12,,,,,
+,47809,tcp,Reserved,,,,,,,,
+,47810-47999,,Unassigned,,,,,,,,
+nimcontroller,48000,tcp,Nimbus Controller,[Carstein_Seeberg_2],[Carstein_Seeberg_2],,,,,,
+nimcontroller,48000,udp,Nimbus Controller,[Carstein_Seeberg_2],[Carstein_Seeberg_2],,,,,,
+nimspooler,48001,tcp,Nimbus Spooler,[Carstein_Seeberg_2],[Carstein_Seeberg_2],,,,,,
+nimspooler,48001,udp,Nimbus Spooler,[Carstein_Seeberg_2],[Carstein_Seeberg_2],,,,,,
+nimhub,48002,tcp,Nimbus Hub,[Carstein_Seeberg_2],[Carstein_Seeberg_2],,,,,,
+nimhub,48002,udp,Nimbus Hub,[Carstein_Seeberg_2],[Carstein_Seeberg_2],,,,,,
+nimgtw,48003,tcp,Nimbus Gateway,[Carstein_Seeberg_2],[Carstein_Seeberg_2],,,,,,
+nimgtw,48003,udp,Nimbus Gateway,[Carstein_Seeberg_2],[Carstein_Seeberg_2],,,,,,
+nimbusdb,48004,tcp,NimbusDB Connector,[Stephen_Harrison],[Stephen_Harrison],2011-01-24,,,,,
+,48004,udp,Reserved,,,,,,,,
+nimbusdbctrl,48005,tcp,NimbusDB Control,[Stephen_Harrison],[Stephen_Harrison],2011-01-24,,,,,
+,48005,udp,Reserved,,,,,,,,
+,48006-48048,,Unassigned,,,,,,,,
+3gpp-cbsp,48049,tcp,3GPP Cell Broadcast Service Protocol,[Gert_Thomasen],[Gert_Thomasen],2009-12-07,,,,,
+,48049,udp,Reserved,,,,,,,,
+weandsf,48050,tcp,WeFi Access Network Discovery and Selection Function,[WeFi_Inc],[Eran_Naveh],2013-07-19,,,,,
+,48050,udp,Reserved,,,,,,,,
+,48051-48127,,Unassigned,,,,,,,,
+isnetserv,48128,tcp,Image Systems Network Services,[Bengt_Gustafsson],[Bengt_Gustafsson],2006-05,,,,,
+isnetserv,48128,udp,Image Systems Network Services,[Bengt_Gustafsson],[Bengt_Gustafsson],2006-05,,,,,
+blp5,48129,tcp,Bloomberg locator,[Albert_Hou],[Albert_Hou],2006-05,,,,,
+blp5,48129,udp,Bloomberg locator,[Albert_Hou],[Albert_Hou],2006-05,,,,,
+,48130-48555,,Unassigned,,,,,,,,
+com-bardac-dw,48556,tcp,com-bardac-dw,[Nicholas_J_Howes],[Nicholas_J_Howes],,,,,,
+com-bardac-dw,48556,udp,com-bardac-dw,[Nicholas_J_Howes],[Nicholas_J_Howes],,,,,,
+,48557-48618,,Unassigned,,,,,,,,
+iqobject,48619,tcp,iqobject,[Bjorn_de_Bonnenfant],[Bjorn_de_Bonnenfant],2003-11,,,,,
+iqobject,48619,udp,iqobject,[Bjorn_de_Bonnenfant],[Bjorn_de_Bonnenfant],2003-11,,,,,
+,48620-48652,,Unassigned,,,,,,,,
+robotraconteur,48653,tcp,Robot Raconteur transport,[Wason_Technology_LLC],[John_Wason],2014-01-27,,,,,
+robotraconteur,48653,udp,Robot Raconteur transport,[Wason_Technology_LLC],[John_Wason],2014-01-27,,,,,
+,48654-48999,,Unassigned,,,,,,,,
+matahari,49000,tcp,Matahari Broker,[Matahari_Project],[Zane_Bitter],2011-08-31,,,,,
+,49000,udp,Reserved,,,,,,,,
+,49001-49150,,Unassigned,,,,,,,,
+,49151,,IANA Reserved,,,,,,,,
+argus,,,ARGUS Protocol,,,,,,,,
+arp,,,Address Resolution Protocol,,,,,,,,
+bbn-rcc-mon,,,BBN RCC Monitoring,,,,,,,,
+bootp,,,Bootstrap Protocol,,,,,,,,
+br-sat-mon,,,Backroom SATNET Monitoring,,,,,,,,
+cftp,,,CFTP,,,,,,,,
+chaos,,,CHAOS Protocol,,,,,,,,
+clock,,,DCNET Time Server Protocol,,,,,,,,
+cmot,,,Common Mgmnt Info Ser and Prot over TCP/IP,,,,,,,,
+cookie-jar,,,Authentication Scheme,,,,,,,,
+dcn-meas,,,DCN Measurement Subsystems Protocol,,,,,,,,
+dgp,,,Dissimilar Gateway Protocol,,,,,,,,
+dmf-mail,,,Digest Message Format for Mail,,,,,,,,
+egp,,,Exterior Gateway Protocol,,,,,,,,
+ehf-mail,,,Encoding Header Field for Mail,,,,,,,,
+emcon,,,Emission Control Protocol,,,,,,,,
+fconfig,,,Fujitsu Config Protocol,,,,,,,,
+ggp,,,Gateway Gateway Protocol,,,,,,,,
+hmp,,,Host Monitoring Protocol,,,,,,,,
+host2-ns,,,Host2 Name Server,,,,,,,,
+icmp,,,Internet Control Message Protocol,,,,,,,,
+igmp,,,Internet Group Management Protocol,,,,,,,,
+igp,,,Interior Gateway Protocol,,,,,,,,
+imap2,,,Interim Mail Access Protocol version 2,,,,,,,,
+ip,,,Internet Protocol,,,,,,,,
+ipcu,,,Internet Packet Core Utility,,,,,,,,
+ippc,,,Internet Pluribus Packet Core,,,,,,,,
+ip-arc,,,Internet Protocol on ARCNET,,,,,,,,
+ip-arpa,,,Internet Protocol on ARPANET,,,,,,,,
+ip-cmprs,,,Compressing TCP/IP Headers,,,,,,,,
+ip-dc,,,Internet Protocol on DC Networks,,,,,,,,
+ip-dvmrp,,,Distance Vector Multicast Routing Protocol,,,,,,,,
+ip-e,,,Internet Protocol on Ethernet Networks,,,,,,,,
+ip-ee,,,Internet Protocol on Exp. Ethernet Nets,,,,,,,,
+ip-fddi,,,Transmission of IP over FDDI,,,,,,,,
+ip-hc,,,Internet Protocol on Hyperchannnel,,,,,,,,
+ip-ieee,,,Internet Protocol on IEEE 802,,,,,,,,
+ip-ipx,,,Transmission of 802.2 over IPX Networks,,,,,,,,
+ip-mtu,,,IP MTU Discovery Options,,,,,,,,
+ip-netbios,,,Internet Protocol over NetBIOS Networks,,,,,,,,
+ip-slip,,,Transmission of IP over Serial Lines,,,,,,,,
+ip-wb,,,Internet Protocol on Wideband Network,,,,,,,,
+ip-x25,,,Internet Protocol on X.25 Networks,,,,,,,,
+irtp,,,Internet Reliable Transaction Protocol,,,,,,,,
+iso-tp4,,,ISO Transport Protocol Class 4,,,,,,,,
+larp,,,Locus Address Resoultion Protocol,,,,,,,,
+leaf-1,,,Leaf-1 Protocol,,,,,,,,
+leaf-2,,,Leaf-2 Protocol,,,,,,,,
+loc-srv,,,Location Service,,,,,,,,
+mail,,,Format of Electronic Mail Messages,,,,,,,,
+merit-inp,,,MERIT Internodal Protocol,,,,,,,,
+mib,,,Management Information Base,,,,,,,,
+mihcs,,,MIH Command Services,,,,,[RFC5679],,,
+mihes,,,MIH Event Services,,,,,[RFC5679],,,
+mihis,,,MIH Information Services,,,,,[RFC5679],,,
+mfe-nsp,,,MFE Network Services Protocol,,,,,,,,
+mit-subnet,,,MIT Subnet Support,,,,,,,,
+mux,,,Multiplexing Protocol,,,,,,,,
+netblt,,,Bulk Data Transfer Protocol,,,,,,,,
+neted,,,Network Standard Text Editor,,,,,,,,
+netrjs,,,Remote Job Service,,,,,,,,
+nfile,,,A File Access Protocol,,,,,,,,
+nvp-ii,,,Network Voice Protocol,,,,,,,,
+ospf,,,Open Shortest Path First Interior GW Protocol,,,,,,,,
+pcmail,,,Pcmail Transport Protocol,,,,,,,,
+ppp,,,Point-to-Point Protocol,,,,,,,,
+prm,,,Packet Radio Measurement,,,,,,,,
+pup,,,PUP Protocol,,,,,,,,
+quote,,,Quote of the Day Protocol,,,,,,,,
+rarp,,,A Reverse Address Resolution Protocol,,,,,,,,
+ratp,,,Reliable Asynchronous Transfer Protocol,,,,,,,,
+rdp,,,Reliable Data Protocol,,,,,,,,
+rip,,,Routing Information Protocol,,,,,,,,
+rvd,,,Remote Virtual Disk Protocol,,,,,,,,
+sat-expak,,,Satnet and Backroom EXPAK,,,,,,,,
+sat-mon,,,SATNET Monitoring,,,,,,,,
+smi,,,Structure of Management Information,,,,,,,,
+stp,,,Stream Protocol,,,,,,,,
+sun-rpc,,,SUN Remote Procedure Call,,,,,,,,
+tcp,,,Transmission Control Protocol,,,,,,,,
+tcp-aco,,,TCP Alternate Checksum Option,,,,,,,,
+thinwire,,,Thinwire Protocol,,,,,,,,
+tp-tcp,,,ISO Transport Service on top of the TCP,,,,,,,,
+trunk-1,,,Trunk-1 Protocol,,,,,,,,
+trunk-2,,,Trunk-2 Protocol,,,,,,,,
+ucl,,,University College London Protocol,,,,,,,,
+udp,,,User Datagram Protocol,,,,,,,,
+users,,,Active Users Protocol,,,,,,,,
+via-ftp,,,VIA Systems-File Transfer Protocol,,,,,,,,
+visa,,,VISA Protocol,,,,,,,,
+vmtp,,,Versatile Message Transaction Protocol,,,,,,,,
+wb-expak,,,Wideband EXPAK,,,,,,,,
+wb-mon,,,Wideband Monitoring,,,,,,,,
+xnet,,,Cross Net Debugger,,,,,,,,
+xns-idp,,,Xerox NS IDP,,,,,,,,
+1password,,,1Password Password Manager data sharing and synchronization protocol,[Roustem_Karimov],[Roustem_Karimov],,,,,,Defined TXT keys: None
+a-d-sync,,,Altos Design Synchronization protocol,[David_Lasker],[David_Lasker],,,,,,Defined TXT keys: None
+abi-instrument,,,Applied Biosystems Universal Instrument Framework,[Tor_Slettnes],[Tor_Slettnes],,,,,,"Defined TXT keys: product=<short product name/model>
+ description=<readable name>
+ version=<firmware/instrument controller version>"
+accessdata-f2d,,,FTK2 Database Discovery Service,[Rick_Russell],[Rick_Russell],,,,,,Defined TXT keys: Proprietary
+accessdata-f2w,,,FTK2 Backend Processing Agent Service,[Rick_Russell],[Rick_Russell],,,,,,Defined TXT keys: Proprietary
+accessone,,,Strix Systems 5S/AccessOne protocol,[Scott_Herscher_2],[Scott_Herscher_2],,,,,,Defined TXT keys: None
+accountedge,,,MYOB AccountEdge,,,,,,,,Defined TXT keys: None
+acrobatsrv,,,Adobe Acrobat,,,,,,,,"Defined TXT keys: type, path, FeedType"
+acs-ctl-ds,,tcp,Access Control Device,[Honwywell_Security_Group],[John_Dziadosz],2012-04-09,,,,,"Defined TXT keys: MAC=, GW-MAC"
+acs-ctl-ds,,udp,Access Control Device,[Honwywell_Security_Group],[John_Dziadosz],2012-04-09,,,,,"Defined TXT keys: MAC=, GW-MAC"
+acs-ctl-gw,,tcp,Access Control Gateway,[Honwywell_Security_Group],[John_Dziadosz],2012-04-09,,,,,"Defined TXT keys: MAC=, GW-MAC"
+acs-ctl-gw,,udp,Access Control Gateway,[Honwywell_Security_Group],[John_Dziadosz],2012-04-09,,,,,"Defined TXT keys: MAC=, GW-MAC"
+actionitems,,,ActionItems,[Sailalong_Software],[Sailalong_Software],,,,,,Defined TXT keys: None
+activeraid,,,Active Storage Proprietary Device Management Protocol,[Skip_Levens],[Skip_Levens],,,,,,Defined TXT keys: None
+activeraid-ssl,,,Encrypted transport of Active Storage Proprietary Device Management Protocol,[Skip_Levens],[Skip_Levens],,,,,,Defined TXT keys: None
+addressbook,,,Address-O-Matic,[Massimiliano_Ribuoli],[Massimiliano_Ribuoli],,,,,,Defined TXT keys: None
+addressbooksrv,,tcp,Address Book Server used for contacts and calendar synchronisation,[AddressBookServer],[Alexander_Hartner],2011-10-14,,,,,"Defined TXT keys: _suffix, _prefix"
+adnodes,,,"difusi Cloud based plug & play network
+ synchronization protocol, content pool database discovery, and
+ cloudOS SAaS discovery protocol.",[DIFUSI_Inc],[Mike_Wright],2011-11-07,,,,,Defined TXT keys: Proprietary
+adobe-shadow,,tcp,Adobe Shadow Server,[Adobe_Systems],[Mike_Harris],2012-04-17,,,,,Defined TXT keys: id
+adobe-vc,,,Adobe Version Cue,,,,,,,,"Defined TXT keys: txtvers=1, name, version, build"
+adisk,,,Automatic Disk Discovery,[Bob_Bradley_2],[Bob_Bradley_2],,,,,,"Defined TXT keys: sys, dkX"
+adpro-setup,,,ADPRO Security Device Setup,[Patrick_Noffke],[Patrick_Noffke],,,,,,"Defined TXT keys: txtvers, type"
+aecoretech,,,Apple Application Engineering Services,[Hani_Abdelazim],[Hani_Abdelazim],,,,,,Defined TXT keys: None
+aeroflex,,,Aeroflex instrumentation and software,[David_Hagood],[David_Hagood],,,,,,"Defined TXT keys: orb_server=<port #> (optional) CORBA ORB server used for resource discovery
+ product_id=<string> (optional) ID of licensed product
+ txtvers=""*IDN?=<identifier>"" (optional) as per LXI specification (for not yet LXI compatible instruments)"
+aerohive-proxy,,tcp,Aerohive Proxy Configuration Service,[Aerohive_Networks],[Matthew_Gast],2012-05-31,,,,,"Defined TXT keys: name, port, username"
+airdrop,,tcp,Airdrop,[Apple_Inc],[Marc_Krochmal_2],2012-03-02,,,,,"Defined TXT keys: flags, phash, ehash, cname"
+airplay,,tcp,Protocol for streaming of audio/video content,[Apple_Inc_2],[Bob_Bradley_3],2012-09-19,,,,,"Defined TXT keys: am, cn, et, ft, fv, md, pk, pw, sf, tp, vn, vs"
+airplay,,udp,Protocol for streaming of audio/video content,[Apple_Inc_2],[Bob_Bradley_3],2012-09-19,,,,,"Defined TXT keys: am, cn, et, ft, fv, md, pk, pw, sf, tp, vn, vs"
+airport,,,AirPort Base Station,[Bob_Bradley_2],[Bob_Bradley_2],,,,,,Defined TXT keys: waMA;
+airpreview,,tcp,Coda AirPreview,[Panic_Inc],[Cabel_Sasser],2012-07-19,,,,,"Defined TXT keys: hasCamera, name, UUID"
+airprojector,,,AirProjector,[Yoshinori_Nakayama],[Yoshinori_Nakayama],,,,,,"Defined TXT keys: mac=<MAC address>
+ ip=<IP address>
+ note=<Location>
+ use=<Status>
+ mainprog=<Main program version>
+ bootprog=<Boot program version>"
+airsharing,,,Air Sharing,[Erik_Rogers][Dave_Howell],[Erik_Rogers][Dave_Howell],,,,,,Defined TXT keys: None
+airsharingpro,,,Air Sharing Pro,[Erik_Rogers][Dave_Howell],[Erik_Rogers][Dave_Howell],,,,,,Defined TXT keys: None
+aloe-gwp,,tcp,Aloe Gateway Protocol,[Layered_Logic],[Brooks_Bell],2012-01-04,,,,,Defined TXT keys: Version
+aloe-pp,,tcp,Aloe Pairing Protocol,[Layered_Logic],[Brooks_Bell],2012-01-04,,,,,"Defined TXT keys: Version, DeviceName, DeviceModel, DeviceSystem, DeviceSystemVersion, AppName, AppVersion"
+amba-cam,,udp,Ambarella Cameras,[Louis_Sun],[Louis_Sun],,,,,,"Defined TXT keys: product=<product model name>
+ description=<string name>
+ version=<firmware version>"
+amiphd-p2p,,,"P2PTapWar Sample Application from ""iPhone SDK Development"" Book",[Chris_Adamson],[Chris_Adamson],,,,,,Defined TXT keys: None
+ams-htm,,,Proprietary protocol for Accu-Med HTM,[AccuMed_Services],[Sam_Carleton_2],2011-10-20,,,,,Defined TXT keys: None
+animolmd,,,Animo License Manager,[Phil_Barrett],[Phil_Barrett],,,,,,Defined TXT keys: None
+animobserver,,,Animo Batch Server,[Phil_Barrett],[Phil_Barrett],,,,,,Defined TXT keys: None
+anquetsync,,,Anquet map synchronization between desktop and handheld devices,[Paul_Lesurf],[Paul_Lesurf],,,,,,Defined TXT keys: Proprietary
+antrmai,,tcp,ANT Galio web services,[ANT_Software],[Simon_Middleton],2012-12-06,,,,,"Defined TXT keys: txtvers, man"
+appelezvous,,,Appelezvous,[Marco_Piovanelli],[Marco_Piovanelli],,,,,,Defined TXT keys: None
+apple-ausend,,,Apple Audio Units,[James_McCartney],[James_McCartney],,,,,,Defined TXT keys: None
+apple-mobdev,,tcp,Apple Mobile Device Protocol,[Apple_2],[Paul_Chinn][Justin_Ko],2011-10-20,,,,,Defined TXT keys: None
+apple-midi,,udp,Apple MIDI,[Doug_Wyatt],[Doug_Wyatt],,,,,,Defined TXT keys: None
+applerdbg,,,Apple Remote Debug Services (OpenGL Profiler),[Dave_Springer],[Dave_Springer],,,,,,Defined TXT keys: None
+appletv,,,Apple TV,[Amandeep_Jawa_3],[Amandeep_Jawa_3],,,,,,"Defined TXT keys: txtvers, PrVs, OSsi, MniT"
+appletv-itunes,,,Apple TV discovery of iTunes,[Amandeep_Jawa_3],[Amandeep_Jawa_3],,,,,,Defined TXT keys: txtvers
+appletv-pair,,,Apple TV Pairing,[Amandeep_Jawa_3],[Amandeep_Jawa_3],,,,,,Defined TXT keys: txtvers
+aquamon,,,AquaMon,,,,,,,,Defined TXT keys: None
+arcnet,,udp,Arcturus Networks Inc. Hardware Services,[Arcturus_Networks_Inc],[Michael_Durrant],2011-10-20,,,,,Defined TXT keys: None
+arn,,tcp,Active Registry Network for distribution of values and streams,[Mictron],[Michael_Wiklund],2013-10-17,,,,,Defined TXT keys: None
+aroundsound,,,AroundSound's information sharing protocol,[Winzig_LLC],[Around_Sound],2011-10-20,,,,,Defined TXT keys: Proprietary
+astnotify,,udp,Asterisk Caller-ID Notification Service,[Sven_Slezak],[Sven_Slezak],,,,,,"Defined TXT keys: prefix=<country code prefix> (numeric, additionally '+')"
+astralite,,,Astralite,[Tongji_University],[Tongji_University],,,,,,Defined TXT keys: None
+async,,,address-o-sync,[Markus_Brand],[Markus_Brand],,,,,,Defined TXT keys: None
+atlassianapp,,,"Atlassian Application (JIRA, Confluence, Fisheye, Crucible, Crowd, Bamboo) discovery service",[Denise_Fernandez],[Denise_Fernandez],,,,,,Defined TXT keys: app.url
+av,,,Allen Vanguard Hardware Service,[Mike_Bush],[Mike_Bush],,,,,,Defined TXT keys: Proprietary
+avatars,,tcp,Libravatar federated avatar hosting service.,[libravatar_org],[Francois_Marier],2011-10-11,,,,,Defined TXT keys: none
+avatars-sec,,tcp,Libravatar federated avatar hosting service.,[libravatar_org],[Francois_Marier],2011-10-11,,,,,Defined TXT keys: none
+axis-video,,,Axis Video Cameras,[Kristina_Sten],[Kristina_Sten],,,,,,Defined TXT keys: None
+b3d-convince,,,3M Unitek Digital Orthodontic System,[Rajiv_Aaron_Manglani],[Rajiv_Aaron_Manglani],,,,,,"Defined TXT keys: txtvers=1, protovers=<api version>, guid=<32 hex digits>"
+babyphone,,,BabyPhone,[Johan_Kool],[Johan_Kool],,,,,,Defined TXT keys: None
+barroomcomedy,,tcp,Peer to peer file sharing for a media player application,[Fred_Zimmerman],[Fred_Zimmerman],2013-11-05,,,,,Defined TXT keys: None
+bcloud-server,,tcp,Buddycloud Server Delegation,[buddycloud],[Simon_Tennant_2],2014-06-19,,,,,"Defined TXT keys: v, host"
+bdsk,,,BibDesk Sharing,[Adam_Maxwell],[Adam_Maxwell],,,,,,"Defined TXT keys: txtvers, authenticate"
+beacon,,,Beacon Remote Service,[Jeffrey_Sadeli],[Jeffrey_Sadeli],,,,,,"Defined TXT keys: version=<product version>, company=<product company>"
+beamer,,,Beamer Data Sharing Protocol,[Frank_Szczerba],[Frank_Szczerba],,,,,,Defined TXT keys: None
+beatpack,,,BeatPack Synchronization Server for BeatMaker,[Mathieu_Garcia],[Mathieu_Garcia],,,,,,Defined TXT keys: None
+beatsdirect,,tcp,Beats Direct allows for the discovery and control of devices,[Beats_Electronics_LLC],[Eddie_Borjas],2013-06-03,,,,,Defined TXT keys: None
+beep,,,Xgrid Technology Preview,[David_Kramer_2],[David_Kramer_2],,,,,,Defined TXT keys: None
+bender,,,Bender Communication Protocol,[Bender_GmbH_Co_KG],[Markus_Kremer],2013-10-15,,,,,Defined TXT keys: product version bus id featuremask
+bfagent,,,BuildForge Agent,[Joe_Senner_2],[Joe_Senner_2],,,,,,Defined TXT keys: None
+bigbangchess,,,Big Bang Chess,[Freeverse_Software],[Freeverse_Software],,,,,,Defined TXT keys: None
+bigbangmancala,,,Big Bang Mancala,[Freeverse_Software],[Freeverse_Software],,,,,,Defined TXT keys: None
+bitflit,,tcp,Data transfer service,[Ramesh_Gupta],[Ramesh_Gupta],2012-02-21,,,,,"Defined TXT keys: provider, vendor, user, host, deploy, prototype, schedule"
+bittorrent,,,BitTorrent Zeroconf Peer Discovery Protocol,[Robin_Perkins],[Robin_Perkins],,,,,,Defined TXT keys: None
+blackbook,,,Little Black Book Information Exchange Protocol,[David_HM_Spector][Paul_M_Franceus],[David_HM_Spector][Paul_M_Franceus],,,,,,"Defined TXT keys: product=<application name>
+ description=<application description name>
+ version=<application version/build number>
+ protovers=<version of protocol in use by by this application>"
+bluevertise,,udp,BlueVertise Network Protocol (BNP),[Fabrizio_Guglielmino],[Fabrizio_Guglielmino],,,,,,Defined TXT keys: role=<master or slave>
+boardplus,,tcp,board plus application transfer protocol,[CX5_SOFTWARE],[Yohei_Yoshihara],2013-02-04,,,,,Defined TXT keys: None
+booked-sync,,tcp,Booked communication protocol - Sharing And Sync Service,[Sören_Havemester],[Sören_Havemester],2013-02-18,,,,,"Defined TXT keys: Edition, Version, Public Shares, Machine ID, Machine Name"
+bookworm,,,Bookworm Client Discovery,[Arne_Dirks],[Arne_Dirks],,,,,,Defined TXT keys: flavors
+boundaryscan,,udp,Proprietary,[Uwe_Ziegler],[Uwe_Ziegler],,,,,,"Defined TXT keys: blocked=<name of the device>, version=<firmware/instrument controller version>"
+bousg,,,Bag Of Unusual Strategy Games,,,,,,,,Defined TXT keys: None
+boutfitness,,tcp,Bout Fitness Synchronization Service,[Bout_Fitness_LLC],[Jesse_Curry],2014-06-16,,,,,Defined TXT keys: None
+boutfitness,,udp,Bout Fitness Synchronization Service,[Bout_Fitness_LLC],[Jesse_Curry],2014-06-16,,,,,Defined TXT keys: None
+boxraysrvr,,tcp,Boxray Devices Host Server,[Caprice_Productions],[Lance_Drake],2012-07-05,,,,,Defined TXT keys: none
+bq-cromo,,tcp,bq Cromo protocol,[MUNDO_READER_SL],[Adan_Munoz],2014-09-05,,,,,Defined TXT keys: None
+bq-cromo,,udp,bq Cromo protocol,[MUNDO_READER_SL],[Adan_Munoz],2014-09-05,,,,,Defined TXT keys: None
+bri,,,RFID Reader Basic Reader Interface,[Thaddeus_Ternes],[Thaddeus_Ternes],,,,,,Defined TXT keys: None
+bridgeprotocol,,tcp,JSON RPC Bridge Protocol,[Michel_Stam_2],[Michel_Stam_2],2012-11-20,,,,,"Defined TXT keys: path, version"
+bsqdea,,,Backup Simplicity,[Qdea],[Qdea],,,,,,Defined TXT keys: None
+btp,,tcp,Beats Transfer Protocol allows for the discovery and control of devices,[Beats_Electronics_LLC_2],[Yunho_Huh],2014-02-17,2014-06-27,,,,Defined TXT keys: None
+buddycloud-api,,tcp,buddycloud API,[buddycloud],[Simon_Tennant],2013-05-20,,,,,"Defined TXT keys: v, host, protocol, path, port"
+caldav,,tcp,Calendaring Extensions to WebDAV (CalDAV) - non-TLS,[IESG],[IETF_Chair],2012-02-17,,[RFC6764],,,This is an extension of the http service. Defined TXT keys: path=<context path>
+caldavs,,tcp,Calendaring Extensions to WebDAV (CalDAV) - over TLS,[IESG],[IETF_Chair],2012-02-17,,[RFC6764],,,This is an extension of the https service. Defined TXT keys: path=<context path>
+caltalk,,,CalTalk,[Joe_Groff],[Joe_Groff],,,,,,Defined TXT keys: None
+canon-chmp,,tcp,Canon HTTP Management Protocol,[Canon_Inc_3],[Tomoyuki_Hansaki],2014-09-03,,,,,"Defined TXT keys: txtvers, mac"
+carddav,,tcp,vCard Extensions to WebDAV (CardDAV) - non-TLS,[IESG],[IETF_Chair],2012-02-17,,[RFC6352],,,This is an extension of the http service. Defined TXT keys: path=<context path>
+carddavs,,tcp,vCard Extensions to WebDAV (CardDAV) - over TLS,[IESG],[IETF_Chair],2012-02-17,,[RFC6352],,,This is an extension of the https service. Defined TXT keys: path=<context path>
+cardsend,,,Card Send Protocol,[Jeff_Grossman],[Jeff_Grossman],,,,,,Defined TXT keys: Proprietary
+carousel,,tcp,Carousel Player Protocol,[Tightrope_Media_Systems],[Scott_Jann],2011-10-17,,,,,Defined TXT keys: None
+cctv,,,IP and Closed-Circuit Television for Securitiy applications,[Frank_Rottmann],[Frank_Rottmann],,,,,,"Defined TXT keys: u=<username>, p=<password>, path=<path to XML file>"
+cheat,,,The Cheat,[Chaz_McGarvey],[Chaz_McGarvey],,,,,,Defined TXT keys: None
+chess,,,Project Gridlock,,,,,,,,Defined TXT keys: None
+chfts,,,Fluid Theme Server,,,,,,,,Defined TXT keys: None
+chili,,,The CHILI Radiology System,[Andre_Schroter],[Andre_Schroter],,,,,,Defined TXT keys: None
+ciao,,tcp,Ciao Arduino Protocol,[Mike_Colagrosso],[Mike_Colagrosso],2011-10-24,,,,,Defined TXT keys: see www.ciaoapp.com
+cip4discovery,,,Discovery of JDF (CIP4 Job Definition Format) enabled devices,[Stefan_Daun],[Stefan_Daun],,,,,,Defined TXT keys: None
+clipboard,,,Clipboard Sharing,,,,,,,,Defined TXT keys: None
+clique,,udp,Clique Link-Local Multicast Chat Room,[Telepathy_project],[Telepathy_project],,,,,,Defined TXT keys: see http://telepathy.freedesktop.org/xmpp/clique
+clscts,,,Oracle CLS Cluster Topology Service,[David_Brower],[David_Brower],,,,,,Defined TXT keys: None
+collection,,,Published Collection Object,[Brady_Anderson],[Brady_Anderson],,,,,,Defined TXT keys: version=?
+com-ocs-es-mcc,,,ElectraStar media centre control protocol,[OC],[OC],,,,,,Defined TXT keys: None
+contactserver,,,Now Contact,,,,,,,,Defined TXT keys: None
+coolanetaudio,,tcp,Coolatoola Network Audio,[Coolatoola.com],[Tim_Hewett],2014-01-03,,,,,Defined TXT keys: None
+corroboree,,,Corroboree Server,[Heath_Raftery],[Heath_Raftery],,,,,,Defined TXT keys: None
+cpnotebook2,,,NoteBook 2,[Circus_Ponies_Suppor],[Circus_Ponies_Suppor],,,,,,Defined TXT keys: None
+csi-mmws,,tcp,Canfield Scientific Inc - Mirror Mobile Web Services,[Canfield_Scientific_Inc],[James_Crismale],2013-07-02,,,,,Defined TXT keys: path
+cw-codetap,,,CodeWarrior HTI Xscale PowerTAP,[Ted_Woodward],[Ted_Woodward],,,,,,Defined TXT keys: None
+cw-dpitap,,,CodeWarrior HTI DPI PowerTAP,[Ted_Woodward],[Ted_Woodward],,,,,,Defined TXT keys: None
+cw-oncetap,,,CodeWarrior HTI OnCE PowerTAP,[Ted_Woodward],[Ted_Woodward],,,,,,Defined TXT keys: None
+cw-powertap,,,CodeWarrior HTI COP PowerTAP,[Ted_Woodward],[Ted_Woodward],,,,,,Defined TXT keys: None
+cytv,,,CyTV - Network streaming for Elgato EyeTV,[Andreas_Junghans],[Andreas_Junghans],,,,,,Defined TXT keys: None
+dacp,,,Digital Audio Control Protocol (iTunes),[Amandeep_Jawa_3],[Amandeep_Jawa_3],,,,,,"Defined TXT keys: txtvers, Ver, DbId"
+dancepartner,,,Dance partner application for iPhone,[Rory_McClure],[Rory_McClure],,,,,,Defined TXT keys: None
+dataturbine,,,Open Source DataTurbine Streaming Data Middleware,[Tony_Fountain],[Tony_Fountain],,,,,,Defined TXT keys: None
+dbaudio,,tcp,d&b audiotechnik remote network,[d_b_audiotechnik],[Christian_Laendner],2011-10-06,,,,,"Defined TXT keys:txtvers=<TXT-Record version>
+protovers=<version of proprietary protocol>
+guid=<type>
+name=<name>
+sn=<serial number>
+device=<cleartext type>
+fwver=<firmware version>"
+dbaudio,,udp,d&b audiotechnik remote network,[d_b_audiotechnik],[Christian_Laendner],2011-10-06,,,,,"Defined TXT keys:txtvers=<TXT-Record version>
+protovers=<version of proprietary protocol>
+guid=<type>
+name=<name>
+sn=<serial number>
+device=<cleartext type>
+fwver=<firmware version>"
+dccp-ping,,dccp,ping/traceroute using DCCP,[Samuel_Jero],[Samuel_Jero],2012-11-14,,,1885957735,,Defined TXT keys: None
+dell-soo-ds,,tcp,Spotlight on Oracle Diagnostic Server,[Dell_2],[Rob_Griffin_3],2013-10-03,,,,,Defined TXT keys: None
+dell-soo-ds,,udp,Spotlight on Oracle Diagnostic Server,[Dell_2],[Rob_Griffin_3],2013-10-03,,,,,Defined TXT keys: None
+dell-soss-ds-w,,tcp,Spotlight on SQL Server Diagnostic Server HTTP,[Dell_2],[Rob_Griffin_3],2013-10-03,,,,,Defined TXT keys: None
+dell-ssms-ds,,tcp,Spotlight SSMS Plugin Diagnostic Server,[Dell_2],[Rob_Griffin_3],2013-10-03,,,,,Defined TXT keys: None
+device-info,,,Device Info,[Stuart_Cheshire_5][Marc_Krochmal],[Stuart_Cheshire_5][Marc_Krochmal],,,,,,Not a service type. Special name reserved for DNS-SD device info.
+devonsync,,tcp,DEVONthink synchronization protocol,[DEVONtechnologies_LLC],[Rob_Rix][Eric_Boehnisch-Volkmann],2011-10-18,,,,,Defined TXT keys: None at present
+dictation,,,Use of a dictation service by a hand-held device,[Nuance_Communications_Inc],[Mark_Jackson],2011-10-27,,,,,"Defined TXT keys: ver, name"
+difi,,,EyeHome,[Elgato],[Elgato],,,,,,Defined TXT keys: None
+disconnect,,,DisConnect Peer to Peer Game Protocol,[Michael_S_Bogovich],[Michael_S_Bogovich],,,,,,Defined TXT keys: None
+dist-opencl,,,Distributed OpenCL discovery protocol,[William_Dillon],[William_Dillon],,2013-04-10,,,,"Defined TXT keys: TCPendpoint, UDPendpoint, UUID"
+ditrios,,,Ditrios SOA Framework Protocol,[Mark_Schmatz],[Mark_Schmatz],,,,,,Defined TXT keys: http://www.ditrios.org/index.php?link=tutorial/index#zeroconf
+divelogsync,,,Dive Log Data Sharing and Synchronization Protocol,[Greg_McLaughlin],[Greg_McLaughlin],,,,,,Defined TXT keys: None
+dlpx-sp,,tcp,Delphix Session Protocol,[Delphix_Corp],[Peng_Dai],2012-10-02,,,,,Defined TXT keys: None
+dltimesync,,udp,Local Area Dynamic Time Synchronisation Protocol,[Geoff_Back_3],[Geoff_Back_3],,,,,,Defined TXT keys: None
+dns-sd,,,DNS Service Discovery,[Stuart_Cheshire_5][Marc_Krochmal],[Stuart_Cheshire_5][Marc_Krochmal],,,,,,Not a service type. Special name reserved for DNS-SD meta queries.
+dns-update,,udp,DNS Dynamic Update Service,[Kiren_Sekar_2],[Kiren_Sekar_2],,,,,,"DNS Dynamic Update Service for a given domain may not necessarily be provided by
+the principal name servers as advertised by the domain's ""NS"" records, and may not
+necessarily always be provided on port 53. The ""_dns-update._udp.<domain>."" SRV record gives
+the target host and port where DNS Dynamic Update Service is provided for the named domain."
+dop,,,Roar (Death of Productivity),[Massive_Flow_Product],[Massive_Flow_Product],,,,,,Defined TXT keys: name=<full username>
+dropcopy,,,DropCopy,[base_t_Interactive],[base_t_Interactive],,,,,,Defined TXT keys: None
+dsgsync,,,Datacolor SpyderGallery Desktop Sync Protocol,[Datacolor],[Heath_Barber],2011-10-14,,,,,Defined TXT keys: Proprietary
+dsl-sync,,,Data Synchronization Protocol for Discovery Software products,[John_Hogg],[John_Hogg],,,,,,Defined TXT keys: Proprietary
+dtrmtdesktop,,,Desktop Transporter Remote Desktop Protocol,[Daniel_Stodle],[Daniel_Stodle],,,,,,Defined TXT keys: None
+duckrace,,tcp,A communication protocol that allows a school teacher to set work activities to students over a LAN.,[Stinky_Kitten_Limited],[Gary_Atkinson],2013-10-03,,,,,Defined TXT keys: txtvers uuid devicename
+dxtgsync,,,Documents To Go Desktop Sync Protocol,[Tim_Boyle],[Tim_Boyle],,,,,,Defined TXT keys: Proprietary
+ea-dttx-poker,,,Protocol for EA Downtown Texas Hold 'em,[Ben_Lewis],[Ben_Lewis],,,,,,Defined TXT keys: None
+earphoria,,,Earphoria,[Rogue_Amoeba],[Rogue_Amoeba],,,,,,Defined TXT keys: None
+easyspndlg-sync,,tcp,Sync service for the Easy Spend Log app,[Aaron_L_Bratcher],[Aaron_L_Bratcher],2011-10-17,,,,,Defined TXT keys: None
+eb-amuzi,,,Amuzi peer-to-peer session synchronization protocol,[Zachary_Gramana],[Zachary_Gramana],,,,,,Defined TXT keys: Proprietary
+eb-sync,,tcp,Easy Books App data sync helper for Mac OS X and iOS,[Geode_Software_Ltd],[Mathew_Waters],2014-05-14,,,,,Defined TXT keys: None
+eb-sync,,udp,Easy Books App data sync helper for Mac OS X and iOS,[Geode_Software_Ltd],[Mathew_Waters],2014-05-14,,,,,Defined TXT keys: None
+ebms,,,ebXML Messaging,[Matthew_MacKenzie],[Matthew_MacKenzie],,,,,,Defined TXT keys: Endpoint=</path/to/endpoint>
+ecms,,,Northrup Grumman/Mission Systems/ESL Data Flow Protocol,[Dan_Goff],[Dan_Goff],,,,,,Defined TXT keys: None
+ebreg,,,ebXML Registry,[Matthew_MacKenzie],[Matthew_MacKenzie],,,,,,Defined TXT keys: HttpBinding=</path/to/registry/http/binding>
+ecbyesfsgksc,,,Net Monitor Anti-Piracy Service,[Guy_Meyer],[Guy_Meyer],,,,,,Defined TXT keys: None
+edcp,,udp,LaCie Ethernet Disk Configuration Protocol,[Nicolas_Bouilleaud],[Nicolas_Bouilleaud],,,,,,"Defined TXT keys: ip, mac, dhcp, mask, gtwy, wins, name, version"
+eeg,,tcp,EEG System Discovery across local and wide area networks,[Shifted_Current],[Joel_Aaron_Clipperton],2012-09-11,,,,,Defined TXT keys: Type
+efkon-elite,,tcp,EFKON Lightweight Interface to Traffic Events,[EFKON_AG],[Thomas_Kemmer],2011-10-20,,,,,"Defined TXT keys: txtvers, protovers, model, serial, scheme, path"
+egistix,,,Egistix Auto-Discovery,[Dave_Lindquist_2],[Dave_Lindquist_2],,,,,,Defined TXT keys: None
+eheap,,,Interactive Room Software Infrastructure (Event Sharing),,,,,,,,Defined TXT keys: None
+embrace,,,DataEnvoy,[Rob_MacGregor],[Rob_MacGregor],,,,,,Defined TXT keys: None
+enphase-envoy,,tcp,Enphase Energy Envoy,[Enphase_Energy_Inc],[Chris_Eich],2011-11-08,,,,,"Defined TXT keys: - txtvers
+ - protovers
+ - serialnum"
+ep,,,Endpoint Protocol (EP) for use in Home Automation systems,[Tommy_van_der_Vorst],[Tommy_van_der_Vorst],,,,,,Defined TXT keys: dns-sd_mdns
+esp,,tcp,Extensis Server Protocol,[Loren_Barr],[Loren_Barr],2006-12,,,,,Defined TXT keys: none
+eucalyptus,,,Eucalyptus Discovery,[Support_Team],[Support_Team],,,,,,Defined TXT keys: Eucalyptus-DNS-SD
+eventserver,,,Now Up-to-Date,,,,,,,,Defined TXT keys: None
+evp,,tcp,EvP - Generic EVENT protocol,[Quentin_Glidic],,2013-06-05,,,,,Defined TXT keys: None
+evs-notif,,,EVS Notification Center Protocol,[Eric_Gillet],[Eric_Gillet],,,,,,"Defined TXT keys: ID, Address"
+ewalletsync,,,Synchronization Protocol for Ilium Software's eWallet,[Dan_Amstutz],[Dan_Amstutz],,,,,,Defined TXT keys: name=<friendly device name>
+example,,,Example Service Type,,,,,,,,"Not a real service type.
+Special 'pretend' service types (""_example._udp"" and ""_example._tcp"")
+reserved for use in illustrative examples in books and other documentation."
+exb,,,Exbiblio Cascading Service Protocol,[Claes_Fredrik_Mannby],[Claes_Fredrik_Mannby],,,,,,Defined TXT keys: Will be described at www.exbiblio.com
+extensissn,,,Extensis Serial Number,[Extensis],[Extensis],,,,,,Defined TXT keys: None
+eyetvsn,,,EyeTV Sharing,[Elgato],[Elgato],,,,,,"Defined TXT keys: txtvers=1, keyhash=<4 bytes>"
+facespan,,,FaceSpan,[Kerry_Hazelgren],[Kerry_Hazelgren],,,,,,Defined TXT keys: None
+faxstfx,,,FAXstf,[Smith_Micro],[Smith_Micro],,,,,,Defined TXT keys: None
+feed-sharing,,,NetNewsWire 2.0,[Ranchero_Software],[Ranchero_Software],,,,,,Defined TXT keys: None
+firetask,,,Firetask task sharing and synchronization protocol,[Gerald_Aquila],[Gerald_Aquila],,,,,,Defined TXT keys: None
+fish,,,Fish,[Oriol_Ferrer_Mesia],[Oriol_Ferrer_Mesia],,,,,,Defined TXT keys: None
+fix,,,Financial Information Exchange (FIX) Protocol,[Joakim_Johansson],[Joakim_Johansson],,,,,,"Defined TXT keys: Currently valid enumerated values:
+ FIX Session Protocol Versions (SESSIONVERSION): 1.1
+ FIX Application Protocol Versions (APPLICATIONVERSION): 2.7, 3.0, 4.0, 4.1, 4.2, 4.3, 4.4, 5.0
+ Possible TXT records defined and their values (replace uppercase text with enumerations from the list above):
+ txtvers=1
+ fix=APPLICATIONVERSION
+ fix supported=APPLICATIONVERSION[,APPLICATIONVERSION, ... ,APPLICATIONVERSION]
+ fixt=SESSIONVERSION"
+fjork,,,Fjork,[John_Schilling],[John_Schilling],,,,,,Defined TXT keys: None
+fl-purr,,udp,FilmLight Cluster Power Control Service,[Darrin_Smart],[Darrin_Smart],,,,,,Defined TXT keys: Proprietary
+flightdmp,,tcp,Flight Data Monitoring Protocol,[Brad_Head],[Brad_Head],2013-02-07,,,,,Defined TXT keys: None
+flightdmp,,udp,Flight Data Monitoring Protocol,[Brad_Head],[Brad_Head],2013-02-07,,,,,Defined TXT keys: None
+flir-ircam,,tcp,FLIR Infrared Camera,[FLIR_Systems_AB],[Bjorn_Roth][Klas_Malmborg],2011-10-20,,,,,Defined TXT keys: Proprietary
+fmserver-admin,,,FileMaker Server Administration Communication Service,[Eric_Jacobson],[Eric_Jacobson],,,,,,Defined TXT keys: None
+fontagentnode,,,FontAgent Pro,[Insider_Software],[Insider_Software],,,,,,Defined TXT keys: None
+foxtrot-serv,,,FoxTrot Search Server Discovery Service,[Jerome_Seydoux],[Jerome_Seydoux],,,,,,Defined TXT keys: None
+foxtrot-start,,,FoxTrot Professional Search Discovery Service,[Jerome_Seydoux],[Jerome_Seydoux],,,,,,Defined TXT keys: None
+frameforge-lic,,,FrameForge License,[James_W_Walker],[James_W_Walker],,,,,,Defined TXT keys: Proprietary
+freehand,,,FreeHand MusicPad Pro Interface Protocol,[Ted_Schroeder],[Ted_Schroeder],,,,,,Defined TXT keys: None
+frog,,,Frog Navigation Systems,[Rene_Jager],[Rene_Jager],,,,,,"Defined TXT keys: type, name, id"
+ftpcroco,,,Crocodile FTP Server,[Xnet_Communications],[Xnet_Communications],,,,,,Defined TXT keys: None
+fv-cert,,udp,Fairview Certificate,[Jim_Lyle_2],[Jim_Lyle_2],,,,,,"Defined TXT keys: DevID=<device id>, DevPK=<device public key>"
+fv-key,,udp,Fairview Key,[Jim_Lyle_2],[Jim_Lyle_2],,,,,,Defined TXT keys: KeyID=<device id>
+fv-time,,udp,Fairview Time/Date,[Jim_Lyle_2],[Jim_Lyle_2],,,,,,Defined TXT keys: None
+garagepad,,,Entrackment Client Service,[Talkative_AB],[Talkative_AB],,,,,,Defined TXT keys: None
+gforce-ssmp,,,G-Force Control via SoundSpectrum's SSMP TCP Protocol,[Andy_O_Meara],[Andy_O_Meara],,,,,,Defined TXT keys: None
+glasspad,,,GlassPad Data Exchange Protocol,[Emmanuel_Merali],[Emmanuel_Merali],,,,,,Defined TXT keys: guid
+glasspadserver,,,GlassPadServer Data Exchange Protocol,[Emmanuel_Merali],[Emmanuel_Merali],,,,,,Defined TXT keys: guid
+glrdrvmon,,,OpenGL Driver Monitor,[Dave_Springer],[Dave_Springer],,,,,,Defined TXT keys: None
+goorstop,,tcp,For iOS Application named GoOrStop,[Charlie_Kim],[Charlie_Kim],2012-08-28,,,,,Defined TXT keys: None
+googlecast,,tcp,Service related to Google Cast which is a technology for enabling multi-screen experiences. See developers.google.com/cast for more details,[Google_Inc],[Jason_Schiller],2014-01-16,,,,,Defined TXT keys: None
+gopro-wake,,udp,GoPro proprietary protocol to wake devices,[GoPro],[Joe_Enke],2014-10-13,,,,,"Defined TXT keys: model, fw_version, platform_version, protocol_version, mac_address"
+gopro-web,,udp,GoPro proprietary protocol for devices,[GoPro],[Joe_Enke],2014-10-13,,,,,"Defined TXT keys: model, fw_version, platform_version, protocol_version, mac_address"
+gotit,,tcp,Network name Got It!,[Bill_Vlahos],[Bill_Vlahos],2013-12-13,,,,,Defined TXT keys: info=name
+gpnp,,,Grid Plug and Play,[David_Brower],[David_Brower],,,,,,Defined TXT keys: None
+grillezvous,,,Roxio ToastAnywhere(tm) Recorder Sharing,,,,,,,,Defined TXT keys: AppID=<application id> KeyHash=<application license key hash>
+groovesquid,,tcp,Groovesquid Democratic Music Control Protocol,[www_nsovocal_com],[Ruben_Beltran],2011-10-18,,,,,Defined TXT keys: None
+growl,,,Growl,,,,,,,,Defined TXT keys: None
+gsremotecontrol,,tcp,General Satellite set-top box remote control,[General_Satellite],[Sergey_Zubov],2014-02-25,,,,,Defined TXT keys: None
+gucam-http,,tcp,Image Data Transfer API for Wi-Fi Camera Devices over HTTP,[Ripplex_Inc],[Hiroshi_Matsuda],2013-03-04,,,,,Defined TXT keys: device-name=<name of camera device>
+guid,,,Special service type for resolving by GUID (Globally Unique Identifier),,,,,,,,"Defined TXT keys: Varies; Depends on type of service being offered/resolved
+Although DNS-SD does not recommend or advocate using GUIDs as the primary name
+of an offered service why not?, it does support use of GUIDs as service names
+where developers want to use them that way.
+Typically users do not browse for GUIDs. They are not user-friendly and not very
+informative. Typically, the service is advertised as usual, using a user-friendly
+name. One of the TXT record attributes is a GUID for the service instance.
+Once the user has browsed and chosen the desired service instance via its user-friendly
+name, the service is resolved, the TXT record is retrieved, and the GUID is stored.
+A given network service instance is therefore being advertised two ways, for example:
+ <User-Friendly-Name>._ptp._tcp.local
+ <GUID>._guid._tcp.local
+On subsequent accesses to the service, the GUID-based name is resolved, and that
+particular service instance is discovered, even if the user has subsequently
+changed the user-friendly name to something else.
+Note: Although each different logical service type needs to have its own different
+DNS-SD service type, all GUID-based names use the same pseudo-type: ""_guid._tcp"".
+There is no possibility of name conflict because (by definition) GUIDs are globally unique."
+h323,,,"H.323 Real-time audio, video and data communication call setup protocol",[Will_MacDonald],[Will_MacDonald],,,,,,Defined TXT keys: None
+help,,,HELP command,,,,,[RFC1078],,,TCP Port Service Multiplexer (TCPMUX)
+hg,,,Mercurial web-based repository access,,,,,,,,"Defined TXT keys: None
+ path=<file system pathname to repository>
+ description=<descriptive name of repository>"
+hinz,,,HINZMobil Synchronization protocol,[Jorg_Laschke],[Jorg_Laschke],,,,,,Defined TXT keys: None
+hmcp,,,Home Media Control Protocol,[Will_Lahr],[Will_Lahr],,,,,,Defined TXT keys: None
+home-sharing,,,iTunes Home Sharing,[Amandeep_Jawa_3],[Amandeep_Jawa_3],,,,,,"Defined TXT keys: txtvers, hQ, iTSh Version, MID, Database ID, dmb, Version, OSsi, hG, hC, Machine ID"
+homeauto,,,iDo Technology Home Automation Protocol,[Tony_de_Rijk],[Tony_de_Rijk],,,,,,Defined TXT keys: None
+homeconnect,,tcp,Home Connect Protocol,[BSH_Bosch_und_Siemens_Hausgeraete_GmbH],[Jens_Clauss],2013-06-11,,,,,Defined TXT keys: txtvers + Proprietary
+honeywell-vid,,udp,Honeywell Video Systems,[Shankar_Prasad],[Shankar_Prasad],,,,,,Defined TXT keys: None
+hotwayd,,,Hotwayd,,,,,,,,Defined TXT keys: None
+howdy,,,Howdy messaging and notification protocol,[Ozate_Inc],[Joseph_Sickel],,2011-10-12,,,,Defined TXT keys: None
+hpr-bldlnx,,,HP Remote Build System for Linux-based Systems,[Jeffrey_J_Walls],[Jeffrey_J_Walls],,,,,,"Defined TXT keys: rh73, rhel3, rhel4, deb31, suse102"
+hpr-bldwin,,,HP Remote Build System for Microsoft Windows Systems,[Jeffrey_J_Walls],[Jeffrey_J_Walls],,,,,,"Defined TXT keys: xp, vista"
+hpr-db,,,Identifies systems that house databases for the Remote Build System and Remote Test System,[Jeffrey_J_Walls],[Jeffrey_J_Walls],,,,,,"Defined TXT keys: bld, tst, mstr"
+hpr-rep,,,HP Remote Repository for Build and Test Results,[Jeffrey_J_Walls],[Jeffrey_J_Walls],,,,,,"Defined TXT keys: bld, tst, official"
+hpr-toollnx,,,HP Remote System that houses compilers and tools for Linux-based Systems,[Jeffrey_J_Walls],[Jeffrey_J_Walls],,,,,,"Defined TXT keys: rh73, rhel3, rhel4, deb31, suse102"
+hpr-toolwin,,,HP Remote System that houses compilers and tools for Microsoft Windows Systems,[Jeffrey_J_Walls],[Jeffrey_J_Walls],,,,,,"Defined TXT keys: xp, vista"
+hpr-tstlnx,,,HP Remote Test System for Linux-based Systems,[Jeffrey_J_Walls],[Jeffrey_J_Walls],,,,,,"Defined TXT keys: rh73, rhel3, rhel4, deb31, suse102"
+hpr-tstwin,,,HP Remote Test System for Microsoft Windows Systems,[Jeffrey_J_Walls],[Jeffrey_J_Walls],,,,,,"Defined TXT keys: xp, vista"
+hs-off,,,Hobbyist Software Off Discovery,[Rob_Jonson],[Rob_Jonson],,,,,,Defined TXT keys: None
+htsp,,,Home Tv Streaming Protocol,[Andreas_Oman],[Andreas_Oman],,,,,,Defined TXT keys: None
+https,,tcp,HTTP over SSL/TLS,[Tim_Berners_Lee],[Tim_Berners_Lee],,,,,,"Web browsers like Safari and Internet Explorer (with the Bonjour for Windows plugin)
+ DO NOT browse for DNS-SD service type ""_https._tcp"" in addition to browsing for ""_http._tcp"".
+ This is a conscious decision to reduce proliferation of service types, to help keep
+ DNS-SD efficient on the network. Today, if a user types http://www.mybank.com/ into their
+ web browser, the web server automatically redirects the user to https://www.mybank.com/.
+ Rather than having an entirely different DNS-SD service type for https, we recommend
+ using the same redirection mechanism: advertise a plain ""http"" service, which consists
+ of nothing except an HTTP redirection to the desired ""https"" URL.
+ Work is currently being done on adding mechanisms to HTTP and TLS to allow the server
+ to tell the client that it needs to activate TLS on the current connection before
+ proceeding. If this becomes widely adopted, it further justifies the decision to
+ not create a separate DNS-SD service type ""_https._tcp"", because security becomes
+ just another one of the things that is negotiated on a per-connection basis (like
+ content-type negotiation today) rather than being an entirely separate thing."
+htvncconf,,udp,HomeTouch Vnc Configuration,[Yuval_Rakavy],[Yuval_Rakavy],2012-07-10,,,,,Defined TXT keys: None
+hyperstream,,,Atempo HyperStream deduplication server,[Laurent_Charmet],[Laurent_Charmet],,,,,,"Defined TXT keys: version=x.y.z.w
+ uuid=<36 bytes UUID string>
+ host=<real host name>"
+iad1,,,BBN IAD,,,,2013-05-24,,,,This service name is no longer in use.
+iad2,,,BBN IAD,,,,2013-05-24,,,,This service name is no longer in use.
+iad3,,,BBN IAD,,,,2013-05-24,,,,This service name is no longer in use.
+iaudit,,tcp,Braemar Inventory audit,[Braemar_Consulting],[Richard_Thompson],2014-03-05,,,,,Defined TXT keys: None
+ibiz,,,iBiz Server,[IGG_Software],[IGG_Software],,,,,,Defined TXT keys: None
+ica-networking,,,Image Capture Networking,[Baskaran_Subramaniam],[Baskaran_Subramaniam],,,,,,Defined TXT keys: None
+ican,,,Northrup Grumman/TASC/ICAN Protocol,[Laurent_Mihalkovic],[Laurent_Mihalkovic],,,,,,Defined TXT keys: None
+ichalkboard,,,iChalk,[Math_Game_House_Soft],[Math_Game_House_Soft],,,,,,Defined TXT keys: None
+ichat,,,iChat 1.0,[Jens_Alfke],[Jens_Alfke],,,,,,Defined TXT keys: Proprietary
+iconquer,,,iConquer,[Andrew_Zamler_Carhar],[Andrew_Zamler_Carhar],,,,,,Defined TXT keys: None
+icontrolbox,,tcp,A Remote Control Application service used to control Computers on a Local Area Network,[Umair_Cheema],[Umair_Cheema],2013-07-08,,,,,Defined TXT keys: None
+idata,,,Generic Data Acquisition and Control Protocol,[Carson_Fenimore],[Carson_Fenimore],,,,,,Defined TXT keys: None
+idsync,,,SplashID Synchronization Service,[Justin_Cepelak],[Justin_Cepelak],,,,,,Defined TXT keys: Proprietary
+ifolder,,,Published iFolder,[Brady_Anderson],[Brady_Anderson],,,,,,Defined TXT keys: version=?
+ihouse,,,Idle Hands iHouse Protocol,[Toby_Smith],[Toby_Smith],,,,,,Defined TXT keys: None
+ii-drills,,,Instant Interactive Drills,[Ricky_Sharp],[Ricky_Sharp],,,,,,Defined TXT keys: None
+ii-konane,,,Instant Interactive Konane,[Ricky_Sharp],[Ricky_Sharp],,,,,,Defined TXT keys: None
+ilynx,,,iLynX,[iOS_Software],[iOS_Software],,,,,,Defined TXT keys: None
+im,,tcp,Instant Messaging,,,,,[RFC3861],,,
+im,,udp,Instant Messaging,,,,,[RFC3861],,,
+imagescal,,tcp,ImagesCal App Data Sharing,[Three_Lights_Software_LLC],[Gus_Asadi],2014-07-22,,,,,Defined TXT keys: None
+imidi,,,iMidi,[Robert_Grant],[Robert_Grant],,,,,,Defined TXT keys: None
+imgsync,,tcp,Protocol synchronizing Image data,[Canon_Inc_2],[Kazuo_Moritomo],2013-03-28,,,,,"Defined TXT keys: srvver, mf, md, mn, tid, srv, sid, myhwa, imglist, devAid, serAid, vever"
+ims-ni,,tcp,Noise Inspector,[IMS_merilni_sistemi],[Metod_Celestina],2012-08-24,,,,,"Defined TXT keys: SN (serial number), SVER (software version), HVER (hardware version), PVER (protocol version))"
+indigo-dvr,,,Indigo Security Digital Video Recorders,[Haram_Lee],[Haram_Lee],,,,,,Defined TXT keys: Proprietary
+infboard,,tcp,InfBoard interactive whiteboard protocol,[Eric_Sean_Conner],[Eric_Sean_Conner],2011-10-17,,,,,Defined TXT keys: Proprietary
+inova-ontrack,,,Inova Solutions OnTrack Display Protocol,,,,,,,,Defined TXT keys: None
+idcws,,,Intermec Device Configuration Web Services,[Thaddeus_Ternes],[Thaddeus_Ternes],,,,,,Defined TXT keys: version=<x.xx>
+iota,,tcp,iotaMed medical records server,[MITM],[Martin_Wehlou],2011-10-18,,,,,Defined TXT keys: none
+ipbroadcaster,,,IP Broadcaster,[base_t_Interactive],[base_t_Interactive],,,,,,Defined TXT keys: None
+ipspeaker,,,IP Speaker Control Protocol,[Dan_Mahn],[Dan_Mahn],,,,,,Defined TXT keys: None
+ir-hvac-000,,tcp,HVAC SMIL Server,[Ingersoll_Rand_Inc],[John_Taylor],2011-09-28,,,,,Defined TXT keys: None
+irelay,,,iRelay application discovery service,[Marc_Diamante],[Marc_Diamante],,,,,,Defined TXT keys: Proprietary
+irmc,,,Intego Remote Management Console,[Olivier_Delecluse],[Olivier_Delecluse],,,,,,"Defined TXT keys: RMC Client Version=<version>, MAC Address=<address>"
+irobotmcs,,tcp,iRobot Monitor and Control Service,[iRobot_Corporation],[Tim_Farlow],2013-11-07,,,,,Defined TXT keys: None
+irobotmcs,,udp,iRobot Monitor and Control Service,[iRobot_Corporation],[Tim_Farlow],2013-11-07,,,,,Defined TXT keys: None
+irradiatd-iclip,,tcp,iClip clipboard transfer,[Irradiated_Software],[Thomas_Tempelmann],2012-06-19,,,,,Defined TXT keys: none
+isparx,,,iSparx,[Philipp_Dreiss],[Philipp_Dreiss],,,,,,Defined TXT keys: None
+ispq-vc,,,iSpQ VideoChat,[Chris_Silverberg],[Chris_Silverberg],,,,,,Defined TXT keys: None
+ishare,,,iShare,[Steve_Dekorte],[Steve_Dekorte],,,,,,Defined TXT keys: None
+isticky,,,iSticky,[Insist],[Insist],,,,,,Defined TXT keys: None
+istorm,,,iStorm,[Math_Game_House_Soft],[Math_Game_House_Soft],,,,,,Defined TXT keys: None
+isynchronize,,tcp,iSynchronize data synchronization protocol,[Smart_Apps_LTD],[Sergey_Bolshedvorsky],2011-10-11,,,,,Defined TXT keys: none
+itap-publish,,tcp,iTap Publishing Service,[HLW_Software_Development_GmbH],[Michael_Lacher],2011-10-11,,,,,Defined TXT keys: uuid=<unique server key>
+itis-device,,,IT-IS International Ltd. Device,[Ben_Webster],[Ben_Webster],,,,,,"Defined TXT keys: type=<product type>
+ configuration=<product configuration>
+ description=<human readable description>
+ version=<device and protocol version>"
+itsrc,,,iTunes Socket Remote Control,[Kevin_Leacock],[Kevin_Leacock],,,,,,Defined TXT keys: None
+ivef,,,Inter VTS Exchange Format,[Harry_ten_Berge],[Harry_ten_Berge],,,,,,Defined TXT keys: None
+iwork,,,iWork Server,[IGG_Software],[IGG_Software],,,,,,Defined TXT keys: None
+jcan,,,Northrup Grumman/TASC/JCAN Protocol,[Laurent_Mihalkovic],[Laurent_Mihalkovic],,,,,,Defined TXT keys: None
+jeditx,,,Jedit X,[Satoshi_Matsumoto],[Satoshi_Matsumoto],,,,,,Defined TXT keys: None
+jini,,,Jini Service Discovery,[Daniel_Steinberg],[Daniel_Steinberg],,,,,,Defined TXT keys: None
+jnx-kcsync,,tcp,jollys keychain cloud sync protocol,[Patrick_Stein],[Patrick_Stein],2011-10-24,,,,,"Defined TXT keys: hash=<40hex characters>
+ salt=<40hex characters>
+ uuid=<40hex characters>
+ Example:
+ hash=5e7580598c0d7064d4fc79faaeb42585e1a675f8
+ salt=f0164cb3a0c3d7efe75abea8fda86d2d56c8dda9
+ uuid=db61dc092922252e45bbb264f59147138c7fd5fa"
+jtag,,,Proprietary,[Uwe_Ziegler],[Uwe_Ziegler],,,,,,"Defined TXT keys: blocked=<name of the device>, version=<firmware/instrument controller version>"
+jukebox,,tcp,Jukebox Request Service,[Gary_Giebler_2],[Gary_Giebler_2],2011-10-18,,,,,Defined TXT keys: None
+keynoteaccess,,tcp,KeynoteAccess is used for sending remote requests/responses when controlling a slideshow with Keynote Remote,[Apple],[Brad_Vaughan],2011-10-12,,,,,Defined TXT keys: None
+keynotepairing,,tcp,KeynotePairing is used to pair Keynote Remote with Keynote,[Apple],[Brad_Vaughan],2011-10-12,,,,,Defined TXT keys: None
+ktp,,,Kabira Transaction Platform,[Ramiro_Sarmiento],[Ramiro_Sarmiento],,,,,,Defined TXT keys: None
+la-maint,,,IMP Logical Address Maintenance,,,,2013-05-24,,,,This service name is no longer in use.
+labyrinth,,udp,Labyrinth local multiplayer protocol,[Andreas_Alptun],[Andreas_Alptun],,,,,,Defined TXT keys: None
+lan2p,,,Lan2P Peer-to-Peer Network Protocol,[Ben_Guild],[Ben_Guild],,,,,,Defined TXT keys: None
+lapse,,,Gawker,[Phil_Piwonka],[Phil_Piwonka],,,,,,Defined TXT keys: None
+leaf,,,Lua Embedded Application Framework,[Ico_Doornekamp],[Ico_Doornekamp],,,,,,"Defined TXT keys: name=<readable name>
+ product=<product name/model>
+ version=<version number>"
+lexicon,,,Lexicon Vocabulary Sharing,[Jacob_Godwin_Jones],[Jacob_Godwin_Jones],,,,,,Defined TXT keys: None
+liaison,,,Liaison,[Brian_Cully],[Brian_Cully],,,,,,Defined TXT keys: None
+library,,,Delicious Library 2 Collection Data Sharing Protocol,[William_Shipley],[William_Shipley],,,,,,Defined TXT keys: None
+libratone,,,Protocol for setup and control of Libratone products,[Libratone_AS],[Claus_Jensen],2011-10-27,,,,,Defined TXT keys: None
+licor,,,LI-COR Biosciences instrument discovery,[Software_LI-COR_Biosciences],[Kevin_Ediger],2011-10-18,,,,,Defined TXT keys: None
+llrp-secure,,,RFID reader Low Level Reader Protocol over SSL/TLS,[Jason_Schoon_2],[Jason_Schoon_2],,,,,,Defined TXT keys: None
+lobby,,,Gobby,[Gobby_0x539],[Gobby_0x539],,,,,,Defined TXT keys: None
+logicnode,,udp,Logic Pro Distributed Audio,[Nikolaus_Gerteis],[Nikolaus_Gerteis],,,,,,Defined TXT keys: None
+lonbridge,,,Echelon LonBridge Server,[Rich_Blomseth],[Rich_Blomseth],,,,,,Defined TXT keys: None
+lontalk,,,LonTalk over IP (ANSI 852),[Michael_Tennefoss],[Michael_Tennefoss],,,,,,Defined TXT keys: None
+lonworks,,,Echelon LNS Remote Client,[Michael_Tennefoss],[Michael_Tennefoss],,,,,,Defined TXT keys: None
+lsys-appserver,,,Linksys One Application Server API,[Frank_Zerangue],[Frank_Zerangue],,,,,,"Defined TXT keys: path=value (relative URL)
+ engname=value (string)"
+lsys-camera,,,Linksys One Camera API,[Frank_Zerangue],[Frank_Zerangue],,,,,,"Defined TXT keys: brand=value (string)
+ model=value (string)
+ version=value (string)"
+lsys-ezcfg,,,LinkSys EZ Configuration,[Frank_Zerangue],[Frank_Zerangue],,,,,,"Defined TXT keys: model=value (string)
+ serial=value (sring)
+ hwversion=value (string)
+ swversion=value (string)
+ ifversion=value (string)
+ type=value (string)
+ mac=value (12 hex digits)"
+lsys-oamp,,,"LinkSys Operations, Administration, Management, and Provisioning",[Frank_Zerangue],[Frank_Zerangue],,,,,,"Defined TXT keys: model=value (string)
+ serial=value (sring)
+ hwversion=value (string)
+ swversion=value (string)
+ ifversion=value (string)
+ type=value (string)
+ mac=value (12 hex digits)"
+lumiere,,tcp,A protocol to remotely control DMX512 devices over the network,[Gangsta_Ltd],[Jean-Charles_Boude],2011-10-13,,,,,Defined TXT keys: None
+lumis-lca,,tcp,Lumis Cache Appliance Protocol,[Lumis],[Rodrigo_Terra],2011-10-24,,,,,Defined TXT keys: none
+lux-dtp,,,Lux Solis Data Transport Protocol,[Laurence_Flath],[Laurence_Flath],,,,,,Defined TXT keys: None
+lxi,,,LXI,[Nick_Barendt_2],[Nick_Barendt_2],,,,,,"Defined TXT keys: txtvers, *IDN?=<response defined by IEEE 488; e.g., manufacturer, model, serial number, version>"
+lyrics,,,iPod Lyrics Service,[Gary_Giebler],[Gary_Giebler],,,,,,Defined TXT keys: Proprietary
+macfoh,,,MacFOH,[Shaun_Wexler],[Shaun_Wexler],,,,,,Defined TXT keys: None
+macfoh-admin,,,MacFOH admin services,[Shaun_Wexler],[Shaun_Wexler],,,,,,Defined TXT keys: None
+macfoh-audio,,udp,MacFOH audio stream,[Shaun_Wexler],[Shaun_Wexler],,,,,,Defined TXT keys: None
+macfoh-events,,udp,MacFOH show control events,[Shaun_Wexler],[Shaun_Wexler],,,,,,Defined TXT keys: None
+macfoh-data,,udp,MacFOH realtime data,[Shaun_Wexler],[Shaun_Wexler],,,,,,Defined TXT keys: None
+macfoh-db,,,MacFOH database,[Shaun_Wexler],[Shaun_Wexler],,,,,,Defined TXT keys: None
+macfoh-remote,,,MacFOH Remote,[Shaun_Wexler],[Shaun_Wexler],,,,,,Defined TXT keys: None
+macminder,,,Mac Minder,[Luma_Code],[Luma_Code],,,,,,Defined TXT keys: None
+maestro,,,Maestro Music Sharing Service,[Luke_Steffen],[Luke_Steffen],,,,,,Defined TXT keys: None
+magicdice,,,Magic Dice Game Protocol,[Mike_Yenco],[Mike_Yenco],,,,,,Defined TXT keys: None
+mandos,,,Mandos Password Server,[Mandos_Maintainers],[Mandos_Maintainers],,,,,,Defined TXT keys: None
+matrix,,,MATRIX Remote AV Switching,[Ken_Jibiki],[Ken_Jibiki],,,,,,Defined TXT keys: None
+mavlink,,tcp,MAVLink Micro Air Vehicle Communication Protocol,[Roderick_Mann],[Roderick_Mann],2011-10-20,,,,,Defined TXT keys: 0
+mbconsumer,,,MediaBroker++ Consumer,[Nate_Rivard],[Nate_Rivard],,,,,,Defined TXT keys: None
+mbproducer,,,MediaBroker++ Producer,[Nate_Rivard],[Nate_Rivard],,,,,,Defined TXT keys: None
+mbserver,,,MediaBroker++ Server,[Nate_Rivard],[Nate_Rivard],,,,,,Defined TXT keys: None
+mconnect,,,ClairMail Connect,[Sachin_Desai],[Sachin_Desai],,,,,,Defined TXT keys: None
+mcrcp,,,MediaCentral,[equinux],[equinux],,,,,,Defined TXT keys: None
+mediaboard1,,,MediaBoardONE Asset and Information Manager data sharing and synchronization protocol,[Thomas_K_Fischer],[Thomas_K_Fischer],,,,,,Defined TXT keys: None
+mediatap,,tcp,Mediatap streaming protocol,[Mediatap_GbR],[Mario_Pörner],2011-10-11,,,,,Defined TXT keys: Proprietary
+mercurydock,,tcp,Mercury Dock Assistant,[Spider_Electronics],[Kenny_Millar],2014-03-10,,,,,"Defined TXT keys: status, signature, ver"
+mesamis,,,Mes Amis,[David_Priest],[David_Priest],,,,,,Defined TXT keys: None
+mi-raysat,,,Mental Ray for Maya,[Autodesk],[Autodesk],,,,,,Defined TXT keys: None
+mieleathome,,tcp,Miele@home Protocol,[Miele_Cie_KG],[Nils_Langhammer],2014-03-13,,,,,Defined TXT keys: txtvers and proprietary keys
+mn-passage,,tcp,A Remote Control Application service used to control Computers on a Local Area Network,[Midnight_Oil_Enterprises_LLC],[Dan_Corkill],2013-07-09,,,,,Defined TXT keys: inherited from bonjour/iOS multipeer connectivity
+mn-passage,,udp,A Remote Control Application service used to control Computers on a Local Area Network,[Midnight_Oil_Enterprises_LLC],[Dan_Corkill],2013-07-09,,,,,Defined TXT keys: inherited from bonjour/iOS multipeer connectivity
+modolansrv,,,modo LAN Services,[Matt_Craig],[Matt_Craig],,,,,,Defined TXT keys: None
+mogeneti-auth,,tcp,Authentication service for Mogeneti Software Applications,[Mogeneti],[Bart_Rijpers],2012-09-26,,,,,Defined TXT keys: none
+moneysync,,,SplashMoney Synchronization Service,[Justin_Cepelak],[Justin_Cepelak],,,,,,Defined TXT keys: Proprietary
+moneyworks,,,MoneyWorks Gold and MoneyWorks Datacentre network service,[Rowan_Daniell],[Rowan_Daniell],,,,,,Defined TXT keys: None
+moodring,,,Bonjour Mood Ring tutorial program,[Daniel_Steinberg],[Daniel_Steinberg],,,,,,Defined TXT keys: txtvers=1 mood=<ascii digit from 0-4>
+mother,,,Mother script server protocol,[Jonathan],[Jonathan],,,,,,"Defined TXT keys: user, ssl"
+movieslate,,,MovieSlate digital clapperboard,[Cliff_Joyce],[Cliff_Joyce],,,,,,Defined TXT keys: Proprietary
+mp3sushi,,,MP3 Sushi,[Alexandre_Carlhian],[Alexandre_Carlhian],,,,,,Defined TXT keys: None
+mqtt,,,IBM MQ Telemetry Transport Broker,[AndySC],[AndySC],,,,,,"Defined TXT keys: topics=<open topic to subscribe to for information>, eg topic=/info"
+mslingshot,,,Martian SlingShot,[Martin_Technology],[Martin_Technology],,,,,,"Defined TXT keys: displayName, passwordRequired, acceptsUpdates"
+msrps,,tcp,MSRP protocol over TLS,,,,2014-04-25,[RFC4976],,,Defined TXT keys:
+mumble,,,Mumble VoIP communication protocol,[Thorvald_Natvig],[Thorvald_Natvig],,,,,,Defined TXT keys: None
+musicmachine,,,Protocol for a distributed music playing service,[Johan_Mjones],[Johan_Mjones],,,,,,"Defined TXT keys: apiversion, passreq"
+mysync,,,MySync Protocol,[Martin_Redington],[Martin_Redington],,,,,,Defined TXT keys: None
+mttp,,,MenuTunes Sharing,[iThink_Software],[iThink_Software],,,,,,Defined TXT keys: None
+mxim-art2,,,Maxim Integrated Products Automated Roadtest Mk II,[Zach_Metzinger],[Zach_Metzinger],,,,,,Defined TXT keys: Proprietary
+mxim-ice,,,Maxim Integrated Products In-circuit Emulator,[Zach_Metzinger],[Zach_Metzinger],,,,,,Defined TXT keys: Proprietary
+mxs,,,MatrixStore,[Object_Matrix],[Object_Matrix],,,,,,"Defined TXT keys: None
+ mxs.system.id=<system id>
+ mxs.system.version=<system layer version>
+ mxs.cluster.id=<cluster id the system belongs to>"
+nasmon,,tcp,Proprietary communication protocol for NAS Monitor,[Infinite_Loop],[Claus_Broch2],2012-10-09,,,,,Defined TXT keys: Proprietary
+nasmon,,udp,Proprietary communication protocol for NAS Monitor,[Infinite_Loop],[Claus_Broch2],2012-10-09,,,,,Defined TXT keys: Proprietary
+ncbroadcast,,,Network Clipboard Broadcasts,[Thom_McGrath],[Thom_McGrath],,,,,,Defined TXT keys: Contact The ZAZ Software <networkclipboard at thezaz.com>
+ncdirect,,,Network Clipboard Direct Transfers,[Thom_McGrath],[Thom_McGrath],,,,,,Defined TXT keys: Contact The ZAZ Software <networkclipboard at thezaz.com>
+ncount-issuer,,tcp,The issuer service in the n-Count electronic value transfer system,[n-Count_Technology_BV],[Eduard_de_Jong],2013-01-22,,,,,Defined TXT keys: None
+ncsyncserver,,,Network Clipboard Sync Server,[Thom_McGrath],[Thom_McGrath],,,,,,Defined TXT keys: Contact The ZAZ Software <networkclipboard at thezaz.com>
+nedap-aepu,,tcp,Nedap AEOS processing unit,[Nedap],[Leon_van_der_Voort_van_der_Kleij],2014-08-28,,,,,Defined TXT keys: None
+neoriders,,udp,NeoRiders Client Discovery Protocol,[Jesse_W_Towner],[Jesse_W_Towner],,,,,,Defined TXT keys: None
+netrestore,,,NetRestore,[Mike_Bombich],[Mike_Bombich],,,,,,"Defined TXT keys: message, status, progress"
+netvu-video,,tcp,AD Group NetVu Connected Video,[AD_Holdings],[Kelvin_Lawson],2011-10-11,,,,,Defined TXT keys: none
+nextcap,,tcp,Proprietary communication protocol for NextCap capture solution,[NextDay_Aps],[Claus_Broch],2012-04-24,,,,,Defined TXT keys: Proprietary
+nextcap,,udp,Proprietary communication protocol for NextCap capture solution,[NextDay_Aps],[Claus_Broch],2012-04-24,,,,,Defined TXT keys: Proprietary
+ni,,tcp,National Instruments Network Device,[National_Instruments],[Joshua_Prewitt],2011-10-24,,,,,"Defined TXT keys: MAC, DevClass, ProdId, ProdName, SerialNo, Status, ImgPath, Comment"
+ni-rt,,tcp,National Instruments Real-Time Target,[National_Instruments],[Joshua_Prewitt],2011-10-24,,,,,"Defined TXT keys: MAC, OS, OSVer, ProcArch"
+ni-sysapi,,tcp,National Instruments System API Service,[National_Instruments],[Joshua_Prewitt],2011-10-24,,,,,"Defined TXT keys: MAC, Experts, Version"
+nodel,,tcp,Lightweight event based control protocol utilising JavaScript Object Notation,[Lumicom],[Michael_Cartmel],2013-02-07,,,,,Defined TXT keys: None
+ntlx-arch,,,American Dynamics Intellex Archive Management Service,[Gary_Sands],[Gary_Sands],,,,,,"Defined TXT keys: txtvers, macaddress, protovers, model, serial"
+ntlx-ent,,,American Dynamics Intellex Enterprise Management Service,[Gary_Sands],[Gary_Sands],,,,,,"Defined TXT keys: txtvers, macaddress, protovers, model, serial"
+ntlx-video,,,American Dynamics Intellex Video Service,[Gary_Sands],[Gary_Sands],,,,,,"Defined TXT keys: txtvers, macaddress, protovers, model, serial, control, event"
+ntx,,udp,Tenasys,[Carl_Ellis],[Carl_Ellis],,,,,,Defined TXT keys: None
+obf,,,Observations Framework,[Matthew_Baker],[Matthew_Baker],,,,,,Defined TXT keys: version=<value>
+objective,,,Means for clients to locate servers in an Objective (http://www.objective.com) instance.,[Marc_Bailey],[Marc_Bailey],,,,,,"Defined TXT keys: txtvers='1'
+ type={'production'|'standby'|'test'|'demo'}
+ protocol={['SOAP'],['CORBA']}
+ transport=['iiop']|['http']"
+oca,,tcp,"Insecure OCP.1 protocol, which is the insecure TCP/IP implementation of the Object Control Architecture",[OCA_Alliance],[Stephan_van_Tienen],2012-10-11,,,,,Defined TXT keys: txtvers=1 protovers=x
+oca,,udp,"Insecure OCP.1 protocol, which is the insecure TCP/IP implementation of the Object Control Architecture",[OCA_Alliance],[Stephan_van_Tienen],2012-10-11,,,,,Defined TXT keys: txtvers=1 protovers=x
+ocasec,,tcp,"Secure OCP.1 protocol, which is the secure TCP/IP implementation of the Object Control Architecture",[OCA_Alliance],[Stephan_van_Tienen],2012-10-11,,,,,Defined TXT keys: txtvers=1 protovers=x
+ocasec,,udp,"Secure OCP.1 protocol, which is the secure TCP/IP implementation of the Object Control Architecture",[OCA_Alliance],[Stephan_van_Tienen],2012-10-11,,,,,Defined TXT keys: txtvers=1 protovers=x
+oce,,,Oce Common Exchange Protocol,[Dion_Slijp],[Dion_Slijp],,,,,,"Defined TXT keys: type, version"
+od-master,,,OpenDirectory Master,[Jason_Thorpe],[Jason_Thorpe],,,,,,Defined TXT keys: None
+odabsharing,,,OD4Contact,[Objective_Decision],[Objective_Decision],,,,,,Defined TXT keys: None
+odisk,,,Optical Disk Sharing,[Bob_Bradley_2],[Bob_Bradley_2],,,,,,"Defined TXT keys: sys, dkX"
+officetime-sync,,,OfficeTime Synchronization Protocol,[Support],[Support],,,,,,Defined TXT keys: None
+ofocus-conf,,,OmniFocus setting configuration,[Timothy_J_Wood],[Timothy_J_Wood],,,,,,Defined TXT keys: None
+ofocus-sync,,,OmniFocus document synchronization,[Timothy_J_Wood],[Timothy_J_Wood],,,,,,Defined TXT keys: Proprietary
+ola,,tcp,Web Interface for the Open Lighting Architecture Software,[Open_Lighting_Project],[Simon_Newton_2],2013-12-09,2014-02-25,,,,"Subtypes: _www-http
+ Defined TXT keys: None"
+olpc-activity1,,udp,One Laptop per Child activity,[One_Laptop_per_Child],[One_Laptop_per_Child],,,,,,Defined TXT keys: Shared_Activity_Protocol_1.0
+oma-bcast-sg,,,OMA BCAST Service Guide Discovery Service,[Stefan_Ekenberg],[Stefan_Ekenberg],,,,,,Defined TXT keys: None
+omadm-bootstrap,,tcp,Open Mobile Alliance (OMA) Device Management (DM) Bootstrap Server Discovery Service,[Open_Mobile_Alliance],[Open_Mobile_Alliance_Device_Management_DM_Working_Group],2011-08-19,,,,,Defined TXT keys: None
+omni-bookmark,,,OmniWeb,[The_Omni_Group],[The_Omni_Group],,,,,,Defined TXT keys: None
+omni-live,,,Service for remote control of Omnisphere virtual instrument,[Glenn_Olander_2],[Glenn_Olander_2],,,,,,Defined TXT keys: omni-livetxt.html
+openbase,,,OpenBase SQL,,,,,,,,Defined TXT keys: None
+opencu,,udp,Conferencing Protocol,[Marc_Manthey_2],[Marc_Manthey_2],,,,,,Defined TXT keys: None
+oprofile,,,oprofile server protocol,[Rob_Bradford],[Rob_Bradford],,,,,,Defined TXT keys: None
+oscit,,udp,Open Sound Control Interface Transfer,[Gaspard_Bucher],[Gaspard_Bucher],,,,,,Defined TXT keys: None
+ovready,,,ObjectVideo OV Ready Protocol,[Gary_Myers],[Gary_Myers],,,,,,"Defined TXT keys: txtvers, protovers"
+owhttpd,,,OWFS (1-wire file system) web server,[Paul_H_Alfille],[Paul_H_Alfille],,,,,,Defined TXT keys: txtvers
+parentcontrol,,,Remote Parental Controls,[John_Scalo],[John_Scalo],,,,,,Defined TXT keys: None
+passwordwallet,,,PasswordWallet Data Synchronization Protocol,[Sanford_Selznick],[Sanford_Selznick],,,,,,Defined TXT keys: None
+pcast,,,Mac OS X Podcast Producer Server,[Nick_Brosnahan],[Nick_Brosnahan],,,,,,Defined TXT keys: None
+p2pchat,,udp,Peer-to-Peer Chat (Sample Java Bonjour application),[Roger_Pantos],[Roger_Pantos],,,,,,Defined TXT keys: None
+p2pstorage-sec,,tcp,DataBOND p2p storage,[Dell],[Jessica_Zhang],2012-11-19,,,,,"Defined TXT keys: txtvers, machineid, status"
+pairandshare,,tcp,Pair & Share data protocol,[Intel],[Joshua_Boelter],2011-10-18,,,,,Defined TXT keys: Proprietary
+panoply,,tcp,Panoply multimedia composite transfer protocol,[Natarajan_Balasundar],[Natarajan_Balasundar],,,,,,Defined TXT keys: None
+parabay-p2p,,tcp,Parabay P2P protocol,[Vishnu_Varadaraj],[Vishnu_Varadaraj],,,,,,Defined TXT keys: None
+parity,,tcp,PA-R-I-Ty (Public Address - Radio - Intercom - Telefony),[ims_Info],[Oskar_Persano],2011-10-20,,,,,Defined TXT keys: Proprietary
+parity,,udp,PA-R-I-Ty (Public Address - Radio - Intercom - Telefony),[ims_Info],[Oskar_Persano],2011-10-20,,,,,Defined TXT keys: Proprietary
+pgpkey-hkp,,,Horowitz Key Protocol (HKP),[Marc_Horowitz],[Marc_Horowitz],,,,,,Defined TXT keys: None
+pgpkey-http,,,PGP Keyserver using HTTP/1.1,[Jeroen_Massar_3],[Jeroen_Massar_3],,,,,,"Defined TXT keys: path=<path on the server where the HKP applications reside>
+ normally: ""path=/pks/"""
+pgpkey-https,,,PGP Keyserver using HTTPS,[Jeroen_Massar_3],[Jeroen_Massar_3],,,,,,"Defined TXT keys: path=<path on the server where the HKP applications reside>
+ normally: ""path=/pks/"""
+pgpkey-ldap,,,PGP Keyserver using LDAP,[Jeroen_Massar_3],[Jeroen_Massar_3],,,,,,Defined TXT keys: None
+pgpkey-mailto,,,PGP Key submission using SMTP,[Jeroen_Massar_3],[Jeroen_Massar_3],,,,,,Defined TXT keys: user=<user portion of the mail address>
+photoparata,,,Photo Parata Event Photography Software,[Sam_Carleton],[Sam_Carleton],,,,,,Defined TXT keys: None
+photoshow,,tcp,Show Photos over TCP,[Hamed_Ishbaitah],[Hamed_Ishbaitah],2014-07-30,,,,,Defined TXT keys: None
+photosmithsync,,tcp,Photosmith's iPad to Lightroom sync protocol,[Photosmith],[Chris_Horne],2011-10-27,,,,,Defined TXT keys: None
+pictua,,,Pictua Intercommunication Protocol,[Isaack_Rasmussen],[Isaack_Rasmussen],,,,,,Defined TXT keys: None
+piesync,,,pieSync Computer to Computer Synchronization,[Timothy_Wayper],[Timothy_Wayper],,,,,,Defined TXT keys: None
+piu,,,Pedestal Interface Unit by RPM-PSI,[James_Nikolai],[James_Nikolai],,,,,,Defined TXT keys: None
+pkixrep,,,Public Key Infrastructure Repository Locator Service,,,,,[RFC4386],,,
+poch,,,Parallel OperatiOn and Control Heuristic (Pooch),[Dean_Dauger],[Dean_Dauger],,,,,,Defined TXT keys: None
+podcastproxy,,tcp,Protocol for communication between Podcast,[Moritz_Schmale],[Moritz_Schmale],2011-10-07,,,,,Defined TXT keys: None
+pokeeye,,,"Communication channel for ""Poke Eye"" Elgato EyeTV remote controller",[Kristoffer_Lawson],[Kristoffer_Lawson],,,,,,Defined TXT keys: None
+powereasy-erp,,,PowerEasy ERP,[Ulaganathan_Sriramul],[Ulaganathan_Sriramul],,,,,,"Defined TXT keys: ip, port, name, instance, cgi-alias, major-version, minor-version, custom"
+powereasy-pos,,,PowerEasy Point of Sale,[Murthy_Parthasarathi],[Murthy_Parthasarathi],,,,,,"Defined TXT keys: ip, port, type, device-id, major-version, minor-version, custom"
+pplayer-ctrl,,,Piano Player Remote Control,[Juraj_Zopp],[Juraj_Zopp],,,,,,Defined TXT keys: Proprietary
+pres,,tcp,Presence,,,,,[RFC3861],,,
+pres,,udp,Presence,,,,,[RFC3861],,,
+presence,,,Peer-to-peer messaging / Link-Local Messaging,[XMPP_Registrar],[XMPP_Registrar],,,,,,"Defined TXT keys: See http://www.xmpp.org/registrar/linklocal.html
+Note: Registration updated May 2007. Was formerly listed as ""iChat AV""
+(Apple's IM client for Mac OS X) with TXT keys: txtvers, port.p2pj, phsh, vc,
+1st, AIM, msg, status, last When first shipped in Mac OS X 10.2, iChat's
+peer-to-peer messaging protocol was created to solve the problem of serverless
+messaging between peers on the same link. However, there is nothing inherent
+in the protocol that limits it to being only link-local; it was simply
+an artifact of iChat in Mac OS X 10.2 using link-local Multicast DNS to
+discover peers. With the advent of Wide-Area DNS-SD, it is also possible
+to use iChat's peer-to-peer messaging between machines on different links."
+print-caps,,,Retrieve a description of a device's print capabilities,[Troy_Bergstrand],[Troy_Bergstrand],,,,,,Defined TXT keys: None
+printopia,,tcp,"Port to allow for administration and control of ""Printopia"" application software,
+ which provides printing services to mobile users",[Ecamm_Network_LLC],[Chris_Kent],2011-10-24,,,,,"Defined TXT keys: uuid = 55A346CB-C87C-4569-A4B0-248E6388893B
+ vers = 1.0"
+profilemac,,,Profile for Mac medical practice management software,[David_Sinclair_2],[David_Sinclair_2],,,,,,Defined TXT keys: None
+prolog,,,Prolog,[Mike_Brady],[Mike_Brady],,,,,,Defined TXT keys: version=<version number>
+protonet,,,Protonet node and service discovery protocol,[Ali_Jelveh],[Ali_Jelveh],,,,,,"Defined TXT keys: version, notes"
+psap,,udp,Progal Service Advertising Protocol,[Soren_Weber],[Soren_Weber],,,,,,"Defined TXT keys: c0, c1, ..., cn"
+psia,,,Physical Security Interoperability Alliance Protocol,[Frank_Yeh],[Frank_Yeh],,,,,,"Defined TXT keys: txtvers, protovers"
+pstmailsync,,tcp,File synchronization protocol for Pst Mail Sync,[Arrow_Bit_SL],[Javier_Nigro],2012-04-26,,,,,Defined TXT keys: uuid=<unique instance identifier>
+pstmailsync-ssl,,tcp,Secured file synchronization protocol for Pst Mail Sync,[Arrow_Bit_SL],[Javier_Nigro],2012-04-26,,,,,Defined TXT keys: uuid=<unique instance identifier>
+ptnetprosrv2,,,PTNetPro Service,[Apple_Computer],[Apple_Computer],,,,,,"Defined TXT keys: None
+Profiling and performance analysis protocol for Shark 4.0 and BigTop."
+ptp-init,,tcp,Picture Transfer Protocol(PTP) Initiator,[Canon_Inc],[Tatsuhiko_Sakai],2011-10-03,,,,,"Defined TXT keys: srvver, mn, mf, md, srv, tid"
+ptp-req,,,PTP Initiation Request Protocol,[Mark_Wood],[Mark_Wood],,,,,,"Defined TXT keys: txtvers, guid, c0, c1, c2, ..., where the number of c_n attributes is variable"
+puzzle,,,Protocol used for puzzle games,[Michael_Thomason],[Michael_Thomason],,,,,,Defined TXT keys: None
+pvaccess,,tcp,Experimental Physics and Industrial Control System,[Matej_Sekoranja],[Matej_Sekoranja],2012-03-23,,,,,Defined TXT keys: None
+qbox,,,QBox Appliance Locator,[Geoff_Back_4],[Geoff_Back_4],,,,,,Defined TXT keys: None
+qttp,,,QuickTime Transfer Protocol,[Stuart_Cheshire_5],[Stuart_Cheshire_5],,,,,,Defined TXT keys: u=<username> p=<password> path=<path to document> (Same as for _http._tcp)
+quad,,tcp,Distributed Game Data,[Niall_Hogg],[Niall_Hogg],2011-10-25,,,,,Defined TXT keys: Proprietary
+quinn,,,Quinn Game Server,[Simon_Haertel],[Simon_Haertel],,,,,,Defined TXT keys: None
+rakket,,,Rakket Client Protocol,[Orion_Reblitz_Richar],[Orion_Reblitz_Richar],,,,,,Defined TXT keys: None
+radiotag,,,RadioTAG: Event tagging for radio services,[Andy_Buckingham],[Andy_Buckingham],,,,,,Defined TXT keys: None
+radiovis,,,RadioVIS: Visualisation for radio services,[Andy_Buckingham],[Andy_Buckingham],,,,,,Defined TXT keys: None
+radioepg,,,RadioEPG: Electronic Programme Guide for radio services,[Andy_Buckingham],[Andy_Buckingham],,,,,,Defined TXT keys: None
+radioport,,tcp,RadioPort Message Service,[Bob_Iannucci],[Bob_Iannucci],2011-11-23,,,,,Defined TXT keys: NONE
+radioport,,udp,RadioPort Message Service,[Bob_Iannucci],[Bob_Iannucci],2011-11-23,,,,,Defined TXT keys: NONE
+raop,,,Remote Audio Output Protocol (AirTunes),[BonjourDev],[BonjourDev],,2011-10-14,,,,Defined TXT keys: None
+rbr,,,RBR Instrument Communication,[Greg_Johnson],[Greg_Johnson],,,,,,Defined TXT keys: None
+rce,,,PowerCard,[DeVoeSquared],[DeVoeSquared],,,,,,Defined TXT keys: None
+rdp,,,Windows Remote Desktop Protocol,[Jugaari],[Jugaari],,,,,,Defined TXT keys: None
+realplayfavs,,,RealPlayer Shared Favorites,[RealNetworks],[RealNetworks],,,,,,Defined TXT keys: None
+recipe-box,,tcp,The Recipe Box Exchange,[Corpus_Collusion],[Kathy_Tafel],2011-08-23,,,,,Defined TXT keys: txtvers
+recipe-sharing,,tcp,Recipe Sharing Protocol,[Daniel_G_Taylor],[Daniel_G_Taylor],2007-11,,,,,Defined TXT keys: [http://www.recipemanager.org/rsp/rsp10draft.html#dnssd]
+recolive-cc,,tcp,Remote Camera Control,[RecoLive_Sàrl],[Gabriele_Mondada],2012-08-29,,,,,"Defined TXT keys: txtvers, cid, nbd, cap"
+recolive-cc,,udp,Remote Camera Control,[RecoLive_Sàrl],[Gabriele_Mondada],2012-08-29,,,,,"Defined TXT keys: txtvers, cid, nbd, cap"
+recordit-itp,,tcp,Recordit Image Transport Protocol,[Freshout],[Ruben_Beltran_del_Rio_2],2014-04-14,,,,,Defined TXT keys: None
+remote,,,Remote Device Control Protocol,[Gregory_Dudek],[Gregory_Dudek],,,,,,"Defined TXT keys: txtvers=<TXT record version tag>
+ protovers=<protocol vesion number>
+ forground=<primary device or system>
+ version=<firmware/instrument controller version>"
+remotebuddy,,tcp,Remote Buddy remote control software command and data exchange,[IOSPIRIT_GmbH],[Felix_Schwarz],2014-09-23,,,,,Defined TXT keys: None
+remoteburn,,,LaCie Remote Burn,[Serge_DE_LUCA],[Serge_DE_LUCA],,,,,,"Defined TXT keys: server_version, min_client_version"
+renderpipe,,,ARTvps RenderDrive/PURE Renderer Protocol,[Andrew_Hoddinott],[Andrew_Hoddinott],,,,,,Defined TXT keys: None
+rendezvouspong,,,RendezvousPong,[Math_Game_House_Soft],[Math_Game_House_Soft],,,,,,Defined TXT keys: None
+renkara-sync,,,Renkara synchronization protocol,[Michael_J_Primeaux],[Michael_J_Primeaux],,,,,,Defined TXT keys: None
+resol-vbus,,,RESOL VBus,[Daniel_Wippermann],[Daniel_Wippermann],,,,,,Defined TXT keys: None
+retrospect,,,Retrospect backup and restore service,[Michael_Marks],[Michael_Marks],,,,,,Defined TXT keys: None
+rfbc,,,Remote Frame Buffer Client (Used by VNC viewers in listen-mode),[Ole_Morten_Duesund],[Ole_Morten_Duesund],,,,,,"Defined TXT keys: server=dns-name/ip-address:port of currently displayed VNC server.
+ Empty if not showing anything/available."
+rfid,,,RFID Reader Mach1(tm) Protocol,[Paul_Dietrich],[Paul_Dietrich],,,,,,Defined TXT keys: None
+rgb,,tcp,RGB Spectrum Device Discovery,[RGB_Spectrum],[Steve_Hershey],2011-10-10,,,,,"Defined TXT keys: Keyboard, Mouse, Option1, Option2, Option3, Option4, ModelName"
+riousbprint,,,Remote I/O USB Printer Protocol,[Rob_Newberry],[Rob_Newberry],,,,,,Defined TXT keys: See BonjourPrinting.pdf.
+roambot,,tcp,Roambot communication,[Roambotics_Inc],[Scott_Menor],2013-10-18,,,,,Defined TXT keys: None
+roku-rcp,,,Roku Control Protocol,[Don_Woodward],[Don_Woodward],,,,,,Defined TXT keys: txtvers=1
+rql,,,RemoteQuickLaunch,[Daniel_Heffernan],[Daniel_Heffernan],,,,,,Defined TXT keys: None
+rr-disc,,,Robot Raconteur discovery,[Wason_Technology_LLC],[John_Wason],2014-01-27,,,,,Defined TXT keys: None
+rsmp-server,,,Remote System Management Protocol (Server Instance),[Geoff_Back_3],[Geoff_Back_3],,,,,,Defined TXT keys: apiver=<major.minor>
+rubygems,,,RubyGems GemServer,[Rich_Kilmer],[Rich_Kilmer],,,,,,Defined TXT keys: None
+rym-rrc,,tcp,Raymarine remote control protocol,[Raymarine_UK_Limited],[Geoffrey_Beer],2012-05-24,2012-06-04,,,,"Defined TXT keys: raymarine-mfd-rrc-version, raymarine-mfd-model, raymarine-mfd-serial"
+safarimenu,,,Safari Menu,[Jesus_De_Meyer],[Jesus_De_Meyer],,,,,,Defined TXT keys: None
+sallingbridge,,,Salling Clicker Sharing,[Jonas_Salling],[Jonas_Salling],,,,,,Defined TXT keys: None
+sallingclicker,,,Salling Clicker Service,[Jonas_Salling],[Jonas_Salling],,,,,,Defined TXT keys: None
+salutafugijms,,,Salutafugi Peer-To-Peer Java Message Service Implementation,[David_Walend],[David_Walend],,,,,,Defined TXT keys: SalutaProperties
+sandvox,,,Sandvox,[Karelia_Software],[Karelia_Software],,,,,,Defined TXT keys: None
+savagesoft,,tcp,Proprietary Client Server Protocol,[Andy_Savage],[Andy_Savage],2012-07-13,,,,,Defined TXT keys: None
+sc-golf,,,StrawberryCat Golf Protocol,[Phil_Willoughby],[Phil_Willoughby],,,,,,Defined TXT keys: None
+scanner,,,Bonjour Scanning,[Baskaran_Subramaniam],[Baskaran_Subramaniam],,,,,,Defined TXT keys: None
+schick,,,Schick,[Heiko_Kretschmer],[Heiko_Kretschmer],,,,,,Defined TXT keys: None
+scone,,,Scone,[James_Moore],[James_Moore],,,,,,Defined TXT keys: None
+scpi-raw,,,IEEE 488.2 (SCPI) Socket,[Nick_Barendt_3],[Nick_Barendt_3],,,,,,Defined TXT keys: None
+scpi-telnet,,,IEEE 488.2 (SCPI) Telnet,[Nick_Barendt_3],[Nick_Barendt_3],,,,,,Defined TXT keys: None
+sdsharing,,,Speed Download,[Yazsoft],[Yazsoft],,,,,,Defined TXT keys: None
+see,,,SubEthaEdit 2,[TheCodingMonkeys],[TheCodingMonkeys],,,,,,"Defined TXT keys: txtvers=1, name=<Full Name>, userid=<User ID>, version=2"
+seeCard,,,seeCard,[Stefan_Pantke],[Stefan_Pantke],,,,,,Defined TXT keys: None
+senteo-http,,,Senteo Assessment Software Protocol,[Michael_Boyle],[Michael_Boyle],,,,,,Defined TXT keys: None
+sentillion-vlc,,,Sentillion Vault System,[George_Hartz],[George_Hartz],,,,,,Defined TXT keys: None
+sentillion-vlt,,,Sentillion Vault Systems Cluster,[George_Hartz],[George_Hartz],,,,,,Defined TXT keys: None
+sepvsync,,,SEPV Application Data Synchronization Protocol,[Kazuya_Ogata],[Kazuya_Ogata],,,,,,Defined TXT keys: Proprietary
+serendipd,,,serendiPd Shared Patches for Pure Data,[Hans_Christoph_Stein],[Hans_Christoph_Stein],,,,,,Defined TXT keys: None
+servereye,,,ServerEye AgentContainer Communication Protocol,[Andreas_Behr],[Andreas_Behr],,,,,,Defined TXT keys: None
+servermgr,,,Mac OS X Server Admin,[Jeff_Albouze],[Jeff_Albouze],,,,,,Defined TXT keys: None
+services,,,DNS Service Discovery,[Stuart_Cheshire_5][Marc_Krochmal],[Stuart_Cheshire_5][Marc_Krochmal],,,,,,Not a service type. Special name reserved for DNS-SD meta queries.
+sessionfs,,,Session File Sharing,[Anthony_Williams],[Anthony_Williams],,,,,,"Defined TXT keys: Text keys are the file extensions of any file the user plans to share, i.e. pdf, doc, mp3."
+sftp-ssh,,,Secure File Transfer Protocol over SSH,[Bryan_Cole],[Bryan_Cole],,,,,,Defined TXT keys: u=<username> p=<password> path=<path>
+shifter,,,Window Shifter server protocol,[Antoine_Martin],[Antoine_Martin],,,,,,"Defined TXT keys: username The login username to use (optional)
+ ssh_tunnel Whether an SSH tunnel must be used (required)
+ iface The network interface the server is on (required - may be empty)
+ version Software version (required)
+ ID Server Identifier (requried)"
+shipsgm,,,Swift Office Ships,[Verek],[Verek],,,,,,Defined TXT keys: None
+shipsinvit,,,Swift Office Ships,[Verek],[Verek],,,,,,Defined TXT keys: None
+shoppersync,,,SplashShopper Synchronization Service,[Justin_Cepelak],[Justin_Cepelak],,,,,,Defined TXT keys: Proprietary
+shoutcast,,,Nicecast,[Rogue_Amoeba_2],[Rogue_Amoeba_2],,,,,,Defined TXT keys: None
+siminsufflator,,tcp,Simulated insufflator synchronisation protocol,[Niels_Castle_2],[Niels_Castle_2],2014-06-18,,,,,Defined TXT keys: None
+simmon,,,Medical simulation patient monitor syncronisation protocol,[Niels_Castle],[Niels_Castle],,,,,,Defined TXT keys: None
+simusoftpong,,,simusoftpong iPhone game protocol,[Anders_Svensson],[Anders_Svensson],,,,,,Defined TXT keys: Proprietary
+sipuri,,,Session Initiation Protocol Uniform Resource Identifier,[Jae_Woo_Lee],[Jae_Woo_Lee],,,,,,Defined TXT keys: Defined in URL specification
+sironaxray,,,Sirona Xray Protocol,[Michael_Dalpiaz],[Michael_Dalpiaz],,,,,,Defined TXT keys: Manufacturer=Sirona
+skillscapture,,tcp,The protocol is used to transfer database records between an iOS device to a Mac OS X computer,[Legentis_Ltd],[David_Elliman],2013-07-01,,,,,Defined TXT keys: None
+skillscapture,,udp,The protocol is used to transfer database records between an iOS device to a Mac OS X computer,[Legentis_Ltd],[David_Elliman],2013-07-01,,,,,Defined TXT keys: None
+skype,,,Skype,,,,,,,,"Defined TXT keys: platform, status, auth, rversion, version"
+sleep-proxy,,udp,Sleep Proxy Server,[Stuart_Cheshire_5][Marc_Krochmal],[Stuart_Cheshire_5][Marc_Krochmal],,,,,,Defined TXT keys: None
+slimcli,,,SliMP3 Server Command-Line Interface,[Dean_Blackketter_2],[Dean_Blackketter_2],,,,,,Defined TXT keys: None
+slimhttp,,,SliMP3 Server Web Interface,[Dean_Blackketter_2],[Dean_Blackketter_2],,,,,,Defined TXT keys: None
+slpda,,tcp,Remote Service Discovery in the Service Location,,,,,[RFC3832],,,
+slpda,,udp,Remote Service Discovery in the Service Location,,,,,[RFC3832],,,
+smartenergy,,,Smart Energy Profile,[Robby_Simpson],[Robby_Simpson],,,,,,Defined TXT keys: See http://www.zigbee.org/SmartEnergy
+smartsocket,,tcp,home control,[Robert_Diamond],[Robert_Diamond],2012-07-06,,,,,Defined TXT keys: None
+smb,,,Server Message Block over TCP/IP,,,,,,,,Defined TXT keys: u=<username> p=<password> path=<path>
+sms,,,Short Text Message Sending and Delivery Status Service,[Christian_Flintrup],[Christian_Flintrup],,,,,,Defined TXT keys: Proprietary
+smsync,,,Syncellence file synchronization protocol,[Dialectro_Software],[Gord_Peters],2011-10-20,,,,,"Defined TXT keys: device=<device type>
+ protocol=<version number>
+ os=<operating system name>
+ osver=<operating system version>"
+soap,,,Simple Object Access Protocol,[Andrew_Donoho],[Andrew_Donoho],,,,,,Defined TXT keys: None
+socketcloud,,,Socketcloud distributed application framework,[Robert_Goodyear],[Robert_Goodyear],,,,,,"Defined TXT keys: system, service, process, context, direction, status, progress, health, directive, flags"
+sox,,,Simple Object eXchange,[Igor_Mozolevsky],[Igor_Mozolevsky],,,,,,Defined TXT keys: Proprietary
+sparechange,,,SpareChange data sharing protocol,[Dave_Carrigan],[Dave_Carrigan],,,,,,Defined TXT keys: None
+spearcat,,,sPearCat Host Discovery,[Pierre_Frisch_2],[Pierre_Frisch_2],,,,,,"Defined TXT keys: applicationname=<Application Name>, osname=<OS Name>, sslsupport=<Uses SSL>"
+spidap,,tcp,Sierra Photonics Inc. data protocol,[Sierra_Photonics_Inc],[Support_Staff],2011-10-20,,,,,Defined TXT keys: None
+spincrisis,,,Spin Crisis,[Sphera_Software],[Sphera_Software],,,,,,Defined TXT keys: None
+spl-itunes,,,launchTunes,[David_Nanian_2],[David_Nanian_2],,,,,,Defined TXT keys: None
+spr-itunes,,,netTunes,[David_Nanian_2],[David_Nanian_2],,,,,,Defined TXT keys: None
+splashsync,,,SplashData Synchronization Service,[Justin_Cepelak],[Justin_Cepelak],,,,,,Defined TXT keys: Proprietary
+spres,,tcp,SongPresenter,[Tobias_Hoffmann],[Tobias_Hoffmann],2012-10-09,,,,,"Defined TXT keys: version, name"
+ss-sign,,tcp,Samsung Smart Interaction for Group Network,[Samsung],[Lee_HoJun],2013-01-03,,,,,Defined TXT keys: None
+ss-sign-disc,,udp,Samsung Smart Interaction for Group Network Discovery,[Samsung],[Lee_HoJun],2013-01-03,,,,,Defined TXT keys: None
+spx-hmp,,tcp,SpinetiX HMP,[SpinetiX_S_A],[Diego_Santa_Cruz],2011-10-18,,,,,"Defined TXT keys: txtvers=1
+cport= the port for the content HTTP server
+ (secondary HTTP server used for content publishing)
+ mode= the mode in which the HMP device is currently
+ operating, one of ""normal"", ""safe"" or ""recovery""
+ serial= serial number of the HMP device
+ firmware= firmware version string (e.g.,
+ 2.1.0-0.1.7844)
+ model= model string (e.g., HMP100)"
+ssh,,tcp,SSH Remote Login Protocol,[Tatu_Ylonen],[Tatu_Ylonen],,,,,,Defined TXT keys: u=<username> p=<password>
+ssscreenshare,,,Screen Sharing,,,,,,,,Defined TXT keys: None
+stingray-rpc,,tcp,Stingray Remote Procedure Call,[IK_SATPROF_LLC],[Sergey_Zubov_2],2014-05-02,,,,,Defined TXT keys: None
+stingray-remote,,tcp,Stingray remote control,[IK_SATPROF_LLC],[Sergey_Zubov_2],2014-05-02,,,,,Defined TXT keys: None
+strateges,,,Strateges,[Jean_Olivier_Lanctot],[Jean_Olivier_Lanctot],,,,,,Defined TXT keys: None
+sge-exec,,,Sun Grid Engine (Execution Host),[Bill_Van_Etten],[Bill_Van_Etten],,,,,,Defined TXT keys: None
+sge-qmaster,,,Sun Grid Engine (Master),[Bill_Van_Etten],[Bill_Van_Etten],,,,,,Defined TXT keys: None
+soda,,tcp,Secure On Device API,[Smith_Micro_Software_Inc],[David_Sperling_2],2011-10-10,,,,,"Defined TXT keys: a. ssid=<Wi-Fi SSID of the device>
+b. bssid=<Wi-Fi BSSID of the device>"
+souschef,,,SousChef Recipe Sharing Protocol,[Ben],[Ben],,,,,,Defined TXT keys: None
+sparql,,,SPARQL Protocol and RDF Query Language,[Alex_Tucker],[Alex_Tucker],,,,,,"Defined TXT keys: txtvers=1
+ path=<relative or absolute URL of endpoint>
+ protovers=<number> [if not specified then default is 1.0, corresponding to SPARQL version]
+ binding=<HTTP | SOAP> [if not specified then default is HTTP]
+ vocabs=<space separated list of URIs> [RDF vocabularies or OWL ontologies used by the endpoint]
+ metadata=<URL> [to fetch RDF/XML description of SPARQL service]"
+sqp,,tcp,Square Connect Control Protocol,[Square_Connect_Inc],[Mat_Henshall],2011-10-07,,,,,Defined TXT keys: Proprietary
+stanza,,,Lexcycle Stanza service for discovering shared books,[Marc_Prud_hommeaux],[Marc_Prud_hommeaux],,,,,,Defined TXT keys: None
+stickynotes,,,Sticky Notes,[Johnnie_Walker],[Johnnie_Walker],,,,,,Defined TXT keys: None
+stotp,,tcp,One Time Pad Synchronisation,[softthere_com],[James_Crosby],2011-10-17,,,,,Defined TXT keys: None
+supple,,,Supple Service protocol,[Dave_Christianson],[Dave_Christianson],,,,,,Defined TXT keys: type url
+surveillus,,,Surveillus Networks Discovery Protocol,[Mark_Lewis_3],[Mark_Lewis_3],,,,,,Defined TXT keys: None
+svn,,,Subversion,[CollabNet],[CollabNet],,,,,,Defined TXT keys: None
+swcards,,,Signwave Card Sharing Protocol,[Signwave_Networking],[Signwave_Networking],,,,,,Defined TXT keys: None
+switcher,,,Wireless home control remote control protocol,[Steve_Splonskowski],[Steve_Splonskowski],,,,,,Defined TXT keys: None
+swordfish,,,Swordfish Protocol for Input/Output,[Jim_Wallace],[Jim_Wallace],,,,,,Defined TXT keys: None
+swyp,,,"Framework for transferring any file from any app, to
+ any app on any device: simply with a swÿp.",[ExoMachina],[Alexander_List],2011-12-06,,,,,Defined TXT keys: NONE
+sxqdea,,,Synchronize! Pro X,[Qdea],[Qdea],,,,,,Defined TXT keys: None
+sybase-tds,,,Sybase Server,,,,,,,,Defined TXT keys: None
+syncopation,,,Syncopation Synchronization Protocol by Sonzea,[Sonzea],[Sonzea],,,,,,Defined TXT keys: None
+syncqdea,,,Synchronize! X Plus 2.0,[Qdea],[Qdea],,,,,,Defined TXT keys: None
+synergy,,,Synergy Peer Discovery,[Karl_Timmermann],[Karl_Timmermann],,,,,,Defined TXT keys: None
+synksharing,,,SynkSharing synchronization protocol,[Benjamin_Rister],[Benjamin_Rister],,,,,,Defined TXT keys: None
+taccounting,,,Data Transmission and Synchronization,[John_MacMullin],[John_MacMullin],,,,,,Defined TXT keys: None
+tango,,,Tango Remote Control Protocol,[Tony_Amundson],[Tony_Amundson],,,,,,Defined TXT keys: None
+tapinoma-ecs,,,Tapinoma Easycontact receiver,[Bonjour],[Bonjour],,,,,,Defined TXT keys: None
+taskcoachsync,,,Task Coach Two-way Synchronization Protocol for iPhone,[Jerome_Laheurte],[Jerome_Laheurte],,,,,,Defined TXT keys: None
+tbricks,,,tbricks internal protocol,[Joakim_Johansson],[Joakim_Johansson],,,,,,"Defined TXT keys: txtvers=1, sesna, seid, setype, cosna, coid,
+ cotype, sysna, syna, syid, subsyid, venid, protocols, pid"
+tcode,,,Time Code,[Marshall_Anschutz],[Marshall_Anschutz],,,,,,Defined TXT keys: None
+tcu,,,Tracking Control Unit by RPM-PSI,[James_Nikolai],[James_Nikolai],,,,,,Defined TXT keys: None
+te-faxserver,,,TE-SYSTEMS GmbH Fax Server Daemon,[Tobias_Erichsen],[Tobias_Erichsen],,,,,,Defined TXT keys: Proprietary
+teamlist,,,ARTIS Team Task,[ARTIS_Software],[ARTIS_Software],,,,,,Defined TXT keys: None
+teleport,,udp,teleport,[Julien_Robert],[Julien_Robert],,,,,,Defined TXT keys: None
+tenir-rc,,tcp,Proprietary,[Tenir_Software],[Steve_Gums],2011-10-27,,,,,Defined TXT keys: Proprietary
+tera-fsmgr,,,Terascala Filesystem Manager Protocol,[Mike_Nuss],[Mike_Nuss],,,,,,Defined TXT keys: Proprietary
+tera-mp,,,Terascala Maintenance Protocol,[Mike_Nuss],[Mike_Nuss],,,,,,Defined TXT keys: Proprietary
+test-ok,,tcp,Test Controller Card,[TEST-OK_BV],[Jeroen_Ommering],2012-09-05,,,,,Defined TXT keys: TEST-OK Test Controller Card TCCxxxx
+tf-redeye,,,ThinkFlood RedEye IR bridge,[Matt_Eagar],[Matt_Eagar],,,,,,Defined TXT keys: None
+thumbwrestling,,,tinkerbuilt Thumb Wrestling game,[Jamie_Halmick],[Jamie_Halmick],,,,,,Defined TXT keys: None
+ticonnectmgr,,,TI Connect Manager Discovery Service,[Stephen_Reid],[Stephen_Reid],,,,,,Defined TXT keys: None
+tinavigator,,,TI Navigator Hub 1.0 Discovery Service,[Stephen_Reid],[Stephen_Reid],,,,,,Defined TXT keys: None
+tivo-device,,tcp,TiVo Device Protocol,[TiVo_Inc],[Developer_Support_2],2011-10-18,,,,,Defined TXT keys: None
+tivo-hme,,,TiVo Home Media Engine Protocol,[Developer_Support],[Developer_Support],,,,,,Defined TXT keys: None
+tivo-mindrpc,,tcp,TiVo RPC Protocol,[TiVo_Inc],[Developer_Support_2],2011-10-18,,,,,Defined TXT keys: None
+tivo-music,,,TiVo Music Protocol,[Developer_Support],[Developer_Support],,,,,,Defined TXT keys: None
+tivo-photos,,,TiVo Photos Protocol,[Developer_Support],[Developer_Support],,,,,,Defined TXT keys: None
+tivo-remote,,,TiVo Remote Protocol,[Developer_Support],[Developer_Support],,,,,,"Defined TXT keys: protocol, path, swversion, platform, TSN"
+tivo-videos,,,TiVo Videos Protocol,[Developer_Support],[Developer_Support],,,,,,"Defined TXT keys: protocol, path, swversion, platform, TSN"
+todogwa,,,2Do Sync Helper Tool for Mac OS X and PCs,[Fahad_Gilani],[Fahad_Gilani],,,,,,Defined TXT keys: None
+tomboy,,,Tomboy,[Alex_Graveley],[Alex_Graveley],,,,,,Defined TXT keys: None
+toothpicserver,,,ToothPics Dental Office Support Server,[Milton_Pulis],[Milton_Pulis],,,,,,Defined TXT keys: None
+touch-able,,,iPhone and iPod touch Remote Controllable,[Amandeep_Jawa_3],[Amandeep_Jawa_3],,,,,,"Defined TXT keys: txtvers, CtlN, DbId, Ver, DvTy, OSsi, DvSv"
+touch-remote,,,iPhone and iPod touch Remote Pairing,[Amandeep_Jawa_3],[Amandeep_Jawa_3],,,,,,"Defined TXT keys: txtvers, DvNm, Pair, RemV, RemN, DvTy"
+tptx-console,,tcp,Coordination service for client users of the TotalPraisTrax iPad application,[Randy_Davenport],[Chris_Watson],2014-03-04,,,,,Defined TXT keys: None
+transmitr,,tcp,Service discovery and media transfer for peer to peer mobile media transfer app,[Windward_Code_LLC],[Alex_Belliotti],2013-11-27,,,,,Defined TXT keys: None
+tri-vis-client,,,triCerat Simplify Visibility Client,[Christopher_Karper],[Christopher_Karper],,,,,,Defined TXT keys: None
+tri-vis-server,,,triCerat Simplify Visibility Server,[Christopher_Karper],[Christopher_Karper],,,,,,Defined TXT keys: None
+tryst,,,Tryst,[Francisco_Ryan_Tolma],[Francisco_Ryan_Tolma],,,,,,Defined TXT keys: None
+tsbiis,,tcp,The Social Broadband Interference Information Sharing,[Sergio_Luis],[Sergio_Luis],2012-02-27,,,,,Defined TXT keys: there is no TXT keys defined for this protocol
+tt4inarow,,,Trivial Technology's 4 in a Row,[Nicolas_Payette],[Nicolas_Payette],,,,,,Defined TXT keys: None
+ttcheckers,,,Trivial Technology's Checkers,[Nicolas_Payette],[Nicolas_Payette],,,,,,Defined TXT keys: None
+ttp4daemon,,,TechTool Pro 4 Anti-Piracy Service,[Micromat],[Micromat],,,,,,Defined TXT keys: None
+tunage,,,Tunage Media Control Service,[Matt_Patenaude],[Matt_Patenaude],,,,,,Defined TXT keys: None
+tuneranger,,,TuneRanger,[Acertant],[Acertant],,,,,,Defined TXT keys: None
+twinlevel,,tcp,detect sanitary product,[Oblamatik_AG],[Simon_Ensslen],2012-09-05,,,,,Defined TXT keys: None
+tzrpc,,tcp,TZ-Software remote procedure call based synchronization protocol,[Thomas_Zwick],[Thomas_Zwick],2011-10-12,,,,,Defined TXT keys: Proprietary
+ubertragen,,,Ubertragen,[Widgetschmie_de],[Widgetschmie_de],,,,,,Defined TXT keys: None
+uddi,,,"Universal Description, Discovery and Integration",[Paul_Denning],[Paul_Denning],,,,,,Defined TXT keys: TBD
+uddi-inq,,,"Universal Description, Discovery and Integration Inquiry",[Paul_Denning],[Paul_Denning],,,,,,Defined TXT keys: TBD
+uddi-pub,,,"Universal Description, Discovery and Integration Publishing",[Paul_Denning],[Paul_Denning],,,,,,Defined TXT keys: TBD
+uddi-sub,,,"Universal Description, Discovery and Integration Subscription",[Paul_Denning],[Paul_Denning],,,,,,Defined TXT keys: TBD
+uddi-sec,,,"Universal Description, Discovery and Integration Security",[Paul_Denning],[Paul_Denning],,,,,,Defined TXT keys: TBD
+upnp,,,Universal Plug and Play,[Andrew_Donoho],[Andrew_Donoho],,,,,,Defined TXT keys: None
+urlbookmark,,,URL Advertising,[Sven_S_Porst],[Sven_S_Porst],,,,,,"Defined TXT keys: URL=<URL that is advertised>, name=<Name of the bookmark>"
+uswi,,,Universal Switching Corporation products,[Roger_Lemberg],[Roger_Lemberg],,,,,,Defined TXT keys: None
+utest,,,uTest,[Gregory_Power],[Gregory_Power],,,,,,Defined TXT keys: None
+uwsgi,,,Unbit Web Server Gateway Interface,[Roberto_De_Ioris],[Roberto_De_Ioris],,,,,,Defined TXT keys: None
+ve-decoder,,,American Dynamics VideoEdge Decoder Control Service,[Gary_Sands],[Gary_Sands],,,,,,"Defined TXT keys: txtvers, macaddress, protovers, model, serial, path, idp"
+ve-encoder,,,American Dynamics VideoEdge Encoder Control Service,[Gary_Sands],[Gary_Sands],,,,,,"Defined TXT keys: txtvers, macaddress, protovers, model, serial, path, idp"
+ve-recorder,,,American Dynamics VideoEdge Recorder Control Service,[Gary_Sands],[Gary_Sands],,,,,,"Defined TXT keys: txtvers, macaddress, protovers, model, serial, path, idp"
+vedabase,,tcp,Application specific synchronization protocol,[Peter_Kollath_2],[Peter_Kollath_2],2014-05-27,,,,,Defined TXT keys: txtvers=1
+virtualdj,,,VirtualDJ Remote Control protocol,[Atomix_Productions],[Stephane_Clavel],2011-10-12,,,,,Defined TXT keys: None
+visel,,,visel Q-System services,[Lehpaner_Sasa],[Lehpaner_Sasa],,,,,,"Defined TXT keys: Version=<service version>
+ Type=<service type>
+ Name=<service Name>
+ Zone=<service zone>
+ ID=<serviceID>
+ SString=<serviceString>
+ SString1=<serviceString>"
+vos,,,Virtual Object System (using VOP/TCP),[Reed_Hedges][Peter_Amstutz],[Reed_Hedges][Peter_Amstutz],,,,,,"Defined TXT keys: url=<Object URL with full path>
+ type=<Comma-seperated list of object types>
+ title=<Short title of service>
+ descr=<Short description of service>"
+vue4rendercow,,,VueProRenderCow,,,,,,,,Defined TXT keys: None
+vxi-11,,,VXI-11 TCP/IP Instrument Protocol,[Nick_Barendt_2],[Nick_Barendt_2],,,,,,Defined TXT keys: None
+wakeywakey,,tcp,Proprietary,[gerry_Brown_associates],[Gerry_Brown],2012-11-29,,,,,Defined TXT keys: None
+walkietalkie,,,Walkie Talkie,[Johan_Kool],[Johan_Kool],,,,,,Defined TXT keys: None
+wd-2go,,tcp,NAS Service Protocol,[Western_Digital],[Rajesh_Batra],2012-07-11,,,,,Defined TXT keys: None
+we-jell,,,Proprietary collaborative messaging protocol,[Vaughn_Amann],[Vaughn_Amann],,,,,,"Defined TXT keys: user=<user name>
+ stat=<OK, DND, AWY, FWD:uname>
+ agent=<agent type>"
+webdav,,,World Wide Web Distributed Authoring and Versioning (WebDAV),[Y_Y_Goland],[Y_Y_Goland],,,,,,Defined TXT keys: u=<username> p=<password> path=<path>
+webdavs,,,WebDAV over SSL/TLS,[Y_Y_Goland],[Y_Y_Goland],,,,,,Defined TXT keys: u=<username> p=<password> path=<path>
+webissync,,,WebIS Sync Protocol,[Alex_Kac],[Alex_Kac],,,,,,Defined TXT keys: None
+wedraw,,,weDraw document sharing protocol,[Oleksandr_Zakharchuk],[Oleksandr_Zakharchuk],,,,,,Defined TXT keys: None
+whamb,,,Whamb,[Whamb],[Whamb],,,,,,Defined TXT keys: None
+whistler,,,Honeywell Video Systems,[Shankar_Prasad_2],[Shankar_Prasad_2],,,,,,Defined TXT keys: None
+wicop,,udp,WiFi Control Platform,[Santorini_LLC],[Cameron_Colpitts],2011-10-25,,,,,"Defined TXT keys: state=<state>
+ loc=<location>"
+witap,,,WiTap Sample Game Protocol,[Rory_McGuire_2],[Rory_McGuire_2],,,,,,Defined TXT keys: None
+witapvoice,,,witapvoice,[Roberto_Garcia],[Roberto_Garcia],,,,,,Defined TXT keys: None
+wkgrpsvr,,,Workgroup Server Discovery,[Forest_Hill],[Forest_Hill],,,,,,Defined TXT keys: None
+workstation,,,Workgroup Manager,[Kevin_Arnold],[Kevin_Arnold],,,,,,Defined TXT keys: None
+wormhole,,,Roku Cascade Wormhole Protocol,[Don_Woodward],[Don_Woodward],,,,,,Defined TXT keys: txtvers=1
+workgroup,,,Novell collaboration workgroup,[Brady_Anderson],[Brady_Anderson],,,,,,Defined TXT keys: version=? description=?
+writietalkie,,,Writie Talkie Data Sharing,[Yin_Ki_Lau],[Yin_Ki_Lau],,,,,,Defined TXT keys: None
+ws,,,Web Services,[Andrew_Donoho],[Andrew_Donoho],,,,,,Defined TXT keys: None
+wtc-heleos,,,Wyatt Technology Corporation HELEOS,[Brent_Fulgham],[Brent_Fulgham],,,,,,Defined TXT keys: None
+wtc-qels,,,Wyatt Technology Corporation QELS,[Brent_Fulgham],[Brent_Fulgham],,,,,,Defined TXT keys: None
+wtc-rex,,,Wyatt Technology Corporation Optilab rEX,[Roy_Reapor],[Roy_Reapor],,,,,,Defined TXT keys: None
+wtc-viscostar,,,Wyatt Technology Corporation ViscoStar,[Roy_Reapor],[Roy_Reapor],,,,,,Defined TXT keys: None
+wtc-wpr,,,Wyatt Technology Corporation DynaPro Plate Reader,[Brent_Fulgham],[Brent_Fulgham],,,,,,Defined TXT keys: None
+wwdcpic,,,PictureSharing sample code,[Marc_Krochmal],[Marc_Krochmal],,,,,,Defined TXT keys: None
+x-on,,,x-on services synchronisation protocol,[Matthias_Burghardt],[Matthias_Burghardt],,,,,,Defined TXT keys: Proprietary
+x-plane9,,udp,x-plane9,[Austin_Meyer],[Austin_Meyer],,,,,,Defined TXT keys: None
+xcodedistcc,,,Xcode Distributed Compiler,[Scott_Tooker],[Scott_Tooker],,,,,,Defined TXT keys: None
+xential,,tcp,xential document creation services,[Xential],[Michiel_Terpstra],2013-11-13,,,,,Defined TXT keys: None
+xgate-rmi,,,xGate Remote Management Interface,[Tim_Jobling],[Tim_Jobling],,,,,,"Defined TXT keys: tech=value (string)
+ model=value (string)
+ version=value (string)"
+xmiserver,,tcp,XMI Systems home terminal local connection,[XMI_Systems_SA],[CLAUDE_MALLY],2013-01-18,,,,,Defined TXT keys: coucou
+xmp,,,Xperientia Mobile Protocol,[Henric_Bergh],[Henric_Bergh],2007-01,,,,,"Defined TXT keys: txtvers, user, system, nodeid, desc"
+xsanclient,,,Xsan Client,[Jeff_Albouze],[Jeff_Albouze],,,,,,Defined TXT keys: None
+xsanserver,,,Xsan Server,[Jeff_Albouze],[Jeff_Albouze],,,,,,Defined TXT keys: None
+xsansystem,,,Xsan System,[Jeff_Albouze],[Jeff_Albouze],,,,,,Defined TXT keys: None
+xtimelicence,,,xTime License,[AppMac_Software],[AppMac_Software],,,,,,Defined TXT keys: None
+xtshapro,,,xTime Project,[AppMac_Software],[AppMac_Software],,,,,,Defined TXT keys: None
+xul-http,,,XUL (XML User Interface Language) transported over HTTP,[Eran_Gampel],[Eran_Gampel],,,,,,Defined TXT keys: u=<username> p=<password> path=<path to document> (Same as for _http._tcp)
+yakumo,,udp,Yakumo iPhone OS Device Control Protocol,[Daniel_Heffernan],[Daniel_Heffernan],,,,,,Defined TXT keys: None
+z-wave,,tcp,Z-Wave Service Discovery,[Sigma_Designs_Inc],[Anders_Brandt_2],2011-10-03,,,,,"Defined TXT keys: NIF, EP, LM"
+z-wave,,udp,Z-Wave Service Discovery,[Sigma_Designs_Inc],[Anders_Brandt_2],2011-10-03,,,,,"Defined TXT keys: NIF, EP, LM"
+zeromq,,tcp,High performance brokerless messaging,[Daniel_Holth],[Daniel_Holth],2012-04-24,,,,,"Defined TXT keys: type, app, label, note"
+zeromq,,udp,High performance brokerless messaging,[Daniel_Holth],[Daniel_Holth],2012-04-24,,,,,"Defined TXT keys: type, app, label, note"
+zigbee-bridge,,tcp,ZigBee Bridge device,[ZigBee_Alliances_Network_Device_working_group],[Leslie_Mulder],2013-05-28,,,,,Defined TXT keys: see: http://www.zigbee.org/Standards/ZigBeeNetworkDevices
+zigbee-bridge,,udp,ZigBee Bridge device,[ZigBee_Alliances_Network_Device_working_group],[Leslie_Mulder],2013-05-28,,,,,Defined TXT keys: see: http://www.zigbee.org/Standards/ZigBeeNetworkDevices
+zigbee-gateway,,tcp,ZigBee IP Gateway,[ZigBee_Alliances_Network_Device_working_group],[Leslie_Mulder],2013-05-28,,,,,Defined TXT keys: see: http://www.zigbee.org/Standards/ZigBeeNetworkDevices
+zigbee-gateway,,udp,ZigBee IP Gateway,[ZigBee_Alliances_Network_Device_working_group],[Leslie_Mulder],2013-05-28,,,,,Defined TXT keys: see: http://www.zigbee.org/Standards/ZigBeeNetworkDevices
diff --git a/tcllib/modules/nmea/ChangeLog b/tcllib/modules/nmea/ChangeLog
new file mode 100644
index 0000000..2b93864
--- /dev/null
+++ b/tcllib/modules/nmea/ChangeLog
@@ -0,0 +1,101 @@
+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-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 ========================
+ *
+
+2009-02-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * nmea.man: Added category information to manpage, put into
+ 'Networking'. Regenerated support/devel/sak/doc/toc.txt.
+
+2009-01-09 Andreas Kupries <andreask@activestate.com>
+
+ * nmea.man: Fixed manpage problems reported by 'sak.tcl doc
+ validate nmea'.
+
+2009-01-08 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ nmea.tcl: lots of changes, bumped major ver to 1.0.0
+ - close_port and close_file become close
+ - fixed some problems with automatic file reading
+ - switched to registered events instead of specially named procs
+ - added default and eof events
+ - added configure command
+ nmea.man: updated for new commands and clarity
+
+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-11-15 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * nmea.tcl: added return values to do_line, new input command
+ bumped minor rev
+ * nmea.man: updated for do_line, input, new intro paragraph
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-20 Andreas Kupries <andreask@activestate.com>
+
+ * nmea.man: Bumped package version to 0.1.1.
+ * nmea/tcl:
+ * pkgIndex.tcl:
+
+2007-08-16 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * nmea.tcl fixed bug in read_port when using logging,
+ bug id 1765388
+
+2007-05-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * nmea.man: Added title, extended set of keywords.
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * nmea.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-06-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * nmea.man: Fixed syntax errors in the documentation.
+
+2006-06-30 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * New module for handling NMEA protocol
diff --git a/tcllib/modules/nmea/nmea.man b/tcllib/modules/nmea/nmea.man
new file mode 100644
index 0000000..cba215b
--- /dev/null
+++ b/tcllib/modules/nmea/nmea.man
@@ -0,0 +1,102 @@
+[manpage_begin nmea n 1.0.0]
+[keywords gps]
+[keywords nmea]
+[copyright {2006-2009, Aaron Faupell <afaupell@users.sourceforge.net>}]
+[moddesc {NMEA protocol implementation}]
+[titledesc {Process NMEA data}]
+[category Networking]
+[require Tcl 8.4]
+[require nmea [opt 1.0.0]]
+[description]
+[para]
+
+This package provides a standard interface for writing software which recieves
+NMEA standard input data. It allows for reading data from COM ports, files,
+or programmatic input. It also supports the checksumming and logging of incoming data.
+After parsing, input is dispatched to user defined handler commands for processing.
+To define a handler, see the [cmd event] command. There are no GPS specific functions
+in this package. NMEA data consists of a sentence type, followed by a list of data.
+
+[section COMMANDS]
+[list_begin definitions]
+
+[call [cmd ::nmea::input] [arg sentence]]
+Processes and dispatches the supplied sentence. If [arg sentence] contains no commas it is treated as a Tcl list, otherwise it must be standard comma delimited NMEA data, with an optional checksum and leading [const \$].
+
+[example {
+nmea::input {$GPGSA,A,3,04,05,,09,12,,,24,,,,,2.5,1.3,2.1*39}
+nmea::input [list GPGSA A 3 04 05 09 12 "" "" 24 "" "" "" 2.5 1.3 2.1]
+}]
+
+[call [cmd ::nmea::open_port] [arg port] [opt speed]]
+Open the specified COM port and read NMEA sentences when available. Port speed is set to
+4800bps by default or to [arg speed].
+
+[call [cmd ::nmea::close_port]]
+Close the com port connection if one is open.
+
+[call [cmd ::nmea::configure_port] [arg settings]]
+Changes the current port settings. [arg settings] has the same format as fconfigure -mode.
+
+[call [cmd ::nmea::open_file] [arg file] [opt rate]]
+Open file [arg file] and read NMEA sentences, one per line, at the rate specified by [opt rate] in milliseconds.
+The file format may omit the leading [const \$] and/or the checksum. If rate is <= 0 (the default) then lines
+will only be processed when a call to [cmd do_line] is made.
+
+[call [cmd ::nmea::close_file]]
+Close the open file if one exists.
+
+[call [cmd ::nmea::do_line]]
+If there is a currently open file, this command will read and process a single line from it.
+Returns the number of lines read.
+
+[call [cmd ::nmea::rate]]
+Sets the rate at which lines are processed from the open file, in milliseconds. The rate remains
+consistant across files, there does not need to be a file currently open to use this command.
+Set to 0 to disable automatic line processing.
+
+[call [cmd ::nmea::log] [opt file]]
+Starts or stops input logging. If a file name is specified then all NMEA data recieved on
+the open port will be logged to the [opt file] in append mode. If file is an empty string then
+any logging will be stopped. If no file is specified then returns a boolean value indicating
+if logging is currently enabled. Data written to the port by [cmd write],
+ data read from files, or input made using [cmd input], is not logged.
+
+[call [cmd ::nmea::checksum] [arg data]]
+Returns the checksum of the supplied data.
+
+[call [cmd ::nmea::write] [arg sentence] [arg data]]
+If there is a currently open port, this command will write the specified sentence and data to the port
+in proper NMEA checksummed format.
+
+[call [cmd ::nmea::event] [arg setence] [opt command]]
+Registers a handler proc for a given NMEA [arg sentence]. There may be at most one handler per
+sentence, any existing handler is replaced.
+If no command is specified, returns the name of the current handler for the given [arg setence]
+or an empty string if none exists. In addition to the incoming sentences there are 2 builtin types,
+EOF and DEFAULT. The handler for the DEFAULT setence is invoked if there is not a specific handler
+for that sentence. The EOF handler is invoked when End Of File is reached on the open file or port.
+[para]
+The handler procedures, with the exception of the builtin types,must take exactly one argument,
+which is a list of the data values.
+The DEFAULT handler should have two arguments, the sentence type and the data values.
+The EOF handler has no arguments.
+
+[example {
+nmea::event gpgsa parse_sat_detail
+nmea::event default handle_unknown
+
+proc parse_sat_detail {data} {
+ puts [lindex $data 1]
+}
+
+proc handle_unknown {name data} {
+ puts "unknown data type $name"
+}
+}]
+
+[list_end]
+
+[vset CATEGORY nmea]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/nmea/nmea.tcl b/tcllib/modules/nmea/nmea.tcl
new file mode 100755
index 0000000..884b4a5
--- /dev/null
+++ b/tcllib/modules/nmea/nmea.tcl
@@ -0,0 +1,197 @@
+# nmea.tcl --
+#
+# NMEA protocol implementation
+#
+# Copyright (c) 2006-2009 Aaron Faupell
+#
+# RCS: @(#) $Id: nmea.tcl,v 1.5 2009/01/09 06:49:25 afaupell Exp $
+
+package require Tcl 8.4
+package provide nmea 1.0.0
+
+namespace eval ::nmea {
+ array set ::nmea::nmea [list checksum 1 log {} rate 0]
+ array set ::nmea::dispatch ""
+}
+
+proc ::nmea::open_port {port {speed 4800}} {
+ variable nmea
+ if {[info exists nmea(fh)]} { ::nmea::close }
+ set nmea(fh) [open $port]
+ fconfigure $nmea(fh) -mode $speed,n,8,1 -handshake xonxoff -buffering line -translation crlf
+ fileevent $nmea(fh) readable [list ::nmea::read_port $nmea(fh)]
+ return $port
+}
+
+proc ::nmea::open_file {file {rate {}}} {
+ variable nmea
+ if {[info exists nmea(fh)]} { ::nmea::close }
+ set nmea(fh) [open $file]
+ if {[string is integer -strict $rate]} {
+ if {$rate < 0} { set rate 0 }
+ set nmea(rate) $rate
+ }
+ fconfigure $nmea(fh) -buffering line -blocking 0 -translation auto
+ if {$nmea(rate) > 0} {
+ after $nmea(rate) [list ::nmea::read_file $nmea(fh)]
+ }
+ return $file
+}
+
+proc ::nmea::configure_port {settings} {
+ variable nmea
+ fconfigure $nmea(fh) -mode $settings
+}
+
+proc ::nmea::close {} {
+ variable nmea
+ catch {::close $nmea(fh)}
+ unset -nocomplain nmea(fh)
+ foreach x [after info] {
+ if {[lindex [after info $x] 0 0] == "::nmea::read_file"} {
+ after cancel $x
+ }
+ }
+}
+
+proc ::nmea::read_port {f} {
+ if {[catch {gets $f} line] || [eof $f]} {
+ if {[info exists ::nmea::dispatch(EOF)]} {
+ $::nmea::dispatch(EOF)
+ }
+ nmea::close
+ }
+ if {$::nmea::nmea(log) != ""} {
+ puts $::nmea::nmea(log) $line
+ }
+ ::nmea::parse_nmea $line
+}
+
+proc ::nmea::read_file {f {auto 1}} {
+ variable nmea
+ set line [gets $f]
+ if {[eof $f]} {
+ if {[info exists ::nmea::dispatch(EOF)]} {
+ $::nmea::dispatch(EOF)
+ }
+ nmea::close
+ return 0
+ }
+ if {[string match {$*} $line]} {
+ ::nmea::parse_nmea $line
+ } else {
+ ::nmea::parse_nmea \$$line
+ }
+ if {$auto} {
+ after $nmea(rate) [list ::nmea::read_file $f]
+ }
+ return 1
+}
+
+proc ::nmea::do_line {} {
+ variable nmea
+ if {![info exists nmea(fh)]} { return -code error "there is no currently open file" }
+ return [::nmea::read_file $nmea(fh) 0]
+}
+
+proc ::nmea::configure {opt {val {}}} {
+ variable nmea
+ switch -exact -- $opt {
+ rate {
+ if {$val == ""} { return $nmea(rate) }
+ if {![string is integer $val]} { return -code error "rate must be an integer value" }
+ if {$val <= 0} {
+ foreach x [after info] {
+ if {[lindex [after info $x] 0 0] == "::nmea::read_file"} {
+ after cancel $x
+ }
+ }
+ set val 0
+ }
+ if {$nmea(rate) == 0 && $val > 0} {
+ after $val [list ::nmea::read_file $nmea(fh)]
+ }
+ set nmea(rate) $val
+ return $val
+ }
+ checksum {
+ if {$val == ""} { return $nmea(checksum) }
+ if {![string is bool $val]} { return -code error "checksum must be a boolean value" }
+ set nmea(checksum) $val
+ return $val
+ }
+ default {
+ return -code error "unknown option $opt"
+ }
+ }
+}
+
+proc ::nmea::input {sentence} {
+ if {![string match "*,*" $sentence]} { set sentence [join $sentence ,] }
+ if {[string match {$*} $sentence]} {
+ ::nmea::parse_nmea $sentence
+ } else {
+ ::nmea::parse_nmea \$$sentence
+ }
+}
+
+proc ::nmea::log {{file _X}} {
+ variable nmea
+ if {$file == "_X"} { return [expr {$nmea(log) != ""}] }
+ if {$file != ""} {
+ if {$nmea(log) != ""} { ::nmea::log {} }
+ set nmea(log) [open $file a]
+ } else {
+ catch {::close $nmea(log)}
+ set nmea(log) ""
+ }
+ return $file
+}
+
+proc ::nmea::parse_nmea {line} {
+ set line [split $line \$*]
+ set cksum [lindex $line 2]
+ set line [lindex $line 1]
+ if {$cksum == "" || !$::nmea::nmea(checksum) || [checksum $line] == $cksum} {
+ set line [split $line ,]
+ set sentence [lindex $line 0]
+ set line [lrange $line 1 end]
+ if {[info exists ::nmea::dispatch($sentence)]} {
+ $::nmea::dispatch($sentence) $line
+ } elseif {[info exists ::nmea::dispatch(DEFAULT)]} {
+ $::nmea::dispatch(DEFAULT) $sentence $line
+ }
+ }
+}
+
+proc ::nmea::checksum {line} {
+ set sum 0
+ binary scan $line c* line
+ foreach char $line {
+ set sum [expr {$sum ^ ($char % 128)}]
+ }
+ return [format %02X [expr {$sum % 256}]]
+}
+
+proc ::nmea::write {type args} {
+ variable nmea
+ set data $type,[join $args ,]
+ puts $nmea(fh) \$$data*[checksum $data]
+}
+
+proc ::nmea::event {sentence {command _X}} {
+ variable dispatch
+ set sentence [string toupper $sentence]
+ if {$command == "_X"} {
+ if {[info exists dispatch($sentence)]} {
+ return $dispatch($sentence)
+ }
+ return {}
+ }
+ if {$command == ""} {
+ unset -nocomplain dispatch($sentence)
+ return {}
+ }
+ set dispatch($sentence) $command
+ return $command
+}
diff --git a/tcllib/modules/nmea/pkgIndex.tcl b/tcllib/modules/nmea/pkgIndex.tcl
new file mode 100644
index 0000000..200dd5d
--- /dev/null
+++ b/tcllib/modules/nmea/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded nmea 1.0.0 [list source [file join $dir nmea.tcl]]
diff --git a/tcllib/modules/nns/ChangeLog b/tcllib/modules/nns/ChangeLog
new file mode 100644
index 0000000..75de1b2
--- /dev/null
+++ b/tcllib/modules/nns/ChangeLog
@@ -0,0 +1,192 @@
+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-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-21 Andreas Kupries <andreask@activestate.com>
+
+ * nns.tcl: Fixed [Bug 2182378], reported by Joe Brandt
+ * pkgIndex.tcl: <vonbane@users.sourceforge.net>. Added
+ * nns_client.man: the missing assignment for 'oneshot'.
+ Version bumped to 0.4.2.
+
+2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11 ========================
+ *
+
+2008-08-13 Michael Schlenker <mic42@users.sourceforge.net>
+
+ * nns.tcl: Fixed missing variable. Bumped version to 0.4.1.
+ * nns_auto.tcl:
+ * pkgIndex.tcl:
+
+2008-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ../../apps/nns: Switched to use of nameserv::auto to handle the
+ * ../../apps/nnslog: loss and restoration of the server
+ automatically. Got rid of the colorization frills.
+
+ * server.tcl (::nameserv::server::bind): Small extension of log
+ * pkgIndex.tcl: output for failure case of bind. Added log output
+ * nns_server.man: to trace searches. Bumped package version to 0.3.2.
+
+ * nns_auto.tcl: Refactored the bind and restore code, put the
+ * nns_auto.man: commonalities into shared commands. Extended the
+ * pkgIndex.tcl: API to become a full drop-in replacement for
+ 'nameserv', just with the persistence feature. Extended the
+ persistence to continuous and unfulfilled async searches. Now
+ exporting the API commands. Bumped package version to 0.3.
+
+ * nns.tcl: Factored the argument processing for searches into a
+ * pkgIndex.tcl: separate command. Pseudo-public. Undocumented, but
+ * nns_client.man: can be used by other nameserver packages. Fixed
+ leak when encountering a missing name server during creation of
+ a continuous or async search. Fixed async destruction of a
+ continous search from receiver object. Now exporting the API
+ commands. Bumped package version to 0.4.
+
+2008-05-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * nns_auto.tcl (::nameserv::auto::configure): Fixed incorrect
+ * server.tcl (::nameserv::server::configure): checking for
+ * nns.tcl (::nameserv::configure): wrong#args in the code
+ * pkgIndex.tcl: handling the various options. Bumped client
+ * nns_client.man: to version 0.3.2, server to 0.3.1, and auto
+ * nns_server.man: to 0.2.1. Also general documentation work.
+ * nns_auto.man:
+ * nns_intro.man:
+
+2008-04-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ../../apps/nns (::nns::ProcessCommandLine): Fixed incorrect
+ * ../../apps/nns.man: checking for wrong#args in the code handling
+ * ../../apps/nnsd.man: the options -host and -port. Reworked
+ the descriptiond of the applications a bit.
+
+ * ../../apps/nnslog: New application and its documentation, a
+ * ../../apps/nnslog.man: stripped down form of 'nns search
+ -continuous *' with different output (log of events).
+
+2008-04-30 Andreas Kupries <andreask@activestate.com>
+
+ * nns.tcl (::nameserv::configure): Fixed [Bug 1954771], bringing
+ * pkgIndex.tcl: missing variable into scope. Thanks to Joe Brandt
+ * nns_client:man: <vonbane@users.sourceforge.net> for both report
+ and fix. Bumped version to 0.3.1.
+
+2008-04-30 Andreas Kupries <andreask@activestate.com>
+
+ * nns_intro.man: New file, giving an overview of the packages and
+ * nns_auto.man: applications in the module. All other documents now
+ * nns_client.man: refer back to the introduction. Also clarified
+ * nns_common.man: the relationship to DNS, which is none, plus
+ * nns_protocol.man: reference to the Tcllib packages which do
+ * nns_server.man: handle DNS. Pointed applications out as examples
+ * ../../apps/nnsd.man: of use for the packages.
+ * ../../apps/nns.man:
+
+2008-04-03 Andreas Kupries <andreask@activestate.com>
+
+ * nns_protocol.man: Renamed nns_procotol.man, fixed the typo in
+ the filename. Thanks to Reinhard Max for seeing this.
+
+2008-03-14 Andreas Kupries <andreask@activestate.com>
+
+ * nns_client.man: Cleaned up a bit, replaced deprecated [lst_item]
+ usage with [def].
+
+2008-02-29 Andreas Kupries <andreask@activestate.com>
+
+ * nns_auto.tcl (::nameserv::auto::Rebind, ::nameserv::auto::bind):
+ * nns_auto.man: Fixed string match with bad pattern and missing
+ * pkgIndex.tcl: string to match against. Version bumped to 0.2.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-07-18 Andreas Kupries <andreask@activestate.com>
+
+ * ../../apps/nnsd: Fixed option bug. Bumped version to 1.0.1.
+
+ * ../../apps/nns: Extended example client application with
+ * ../../apps/nns.man: continuous search. Further extended to
+ detect and handle loss of connection with service, by exiting.
+ Bumped version to 1.1
+
+ * server.tcl: Implemented asynchronous and continuous searches.
+ * nns.tcl: Ditto in client. Documented this feature, and the
+ * nns_client.man: extensions to the protocol it needs.
+ * nns_server.man: Bumped both server and client to version 0.3.
+ * nns_protocol.man:
+ * pkgIndex.tcl:
+
+2007-07-17 Andreas Kupries <andreask@activestate.com>
+
+ * nns_auto.tcl: Name service client on top of the basic facility.
+ * nns_auto.man: Provides automatic restoration of registered names
+ * pkgIndex.tcl: after a loss of connection.
+
+ * nns.tcl: Extended to use the services of 'uevent' to generate
+ events for important changes, like the loss of the connection to
+ the server. The package version is bumped to 0.2.
+
+2007-05-08 Andreas Kupries <andreask@activestate.com>
+
+ * nns_client.man: New name for nns.man, to avoid clashing with the
+ * nns.tcl: nns.man of the command line client, and removed unwanted
+ log output from the client package.
+
+ * ../../apps/nnsl: Merged nnsl and nnst into one command line client
+ * ../../apps/nnst: application, nns. Added documentation for that
+ * ../../apps/nns: application.
+ * ../../apps/nns.man
+
+ * ../../apps/nnsd.man: Added documentation for the command line
+ server application.
+
+ * nns_server.man: Changed configuration -local to -localonly
+ * server.tcl: for better understanding. Bumped to version 0.2
+ * pkgIndex.tcl: Removed unwanted log output.
+
+2007-05-07 Andreas Kupries <andreask@activestate.com>
+
+ * nns.man: Added documentation for client and server packages.
+ * nns_server.man:
+
+2007-05-04 Andreas Kupries <andreask@activestate.com>
+
+ * NNS - Nano Name Service.
+ Initial commit. TODO: Documentation for client and server, ditto
+ testsuites, are needed. Only the trivial code shared by both is
+ documented and tested. Manual testing has been done however,
+ using the nns* applications, see apps/
diff --git a/tcllib/modules/nns/common.tcl b/tcllib/modules/nns/common.tcl
new file mode 100644
index 0000000..5c3e1ca
--- /dev/null
+++ b/tcllib/modules/nns/common.tcl
@@ -0,0 +1,38 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Name service - Common/shared information.
+
+# ### ### ### ######### ######### #########
+## Requirements
+
+namespace eval ::nameserv::common {}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::nameserv::common::port {} {
+ variable port
+ return $port
+}
+
+namespace eval ::nameserv::common {
+ # Derivation of the standard port number for this service.
+
+ # nameserv::server
+ # -> nameservserver / remove ':'
+ # -> 62637378737837 / phonecode
+ # -> 38573 / mod 65536
+
+ variable port 38573
+
+ # The modulo operation is required because IP port numbers are
+ # restricted to unsigned short (16 bit), i.e. 1 ... 65535.
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide nameserv::common 0.1
+
+##
+# ### ### ### ######### ######### #########
diff --git a/tcllib/modules/nns/common.test b/tcllib/modules/nns/common.test
new file mode 100644
index 0000000..c23873c
--- /dev/null
+++ b/tcllib/modules/nns/common.test
@@ -0,0 +1,34 @@
+# -*- tcl -*-
+# common.test: Tests for the common code of the name service
+#
+# Sourcing this file into Tcl runs the tests and generates output for
+# errors. No output means no errors were found.
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8
+testsNeedTcltest 1.0
+
+testing {
+ useLocal common.tcl nameserv::common
+}
+
+# -------------------------------------------------------------------------
+
+test names-common-1.0 {get IP port number, wrong#args, too many} {
+ catch {nameserv::common::port a} msg
+ set msg
+} [tcltest::tooManyArgs nameserv::common::port {}]
+
+test names-common-2.0 {get IP port number} {
+ nameserv::common::port
+} 38573
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/nns/nns.tcl b/tcllib/modules/nns/nns.tcl
new file mode 100644
index 0000000..e256206
--- /dev/null
+++ b/tcllib/modules/nns/nns.tcl
@@ -0,0 +1,432 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Name Service - Client side access
+
+# ### ### ### ######### ######### #########
+## Requirements
+
+package require Tcl 8.4
+package require comm ; # Generic message transport
+package require interp ; # Interpreter helpers.
+package require logger ; # Tracing internal activity
+package require nameserv::common ; # Common/shared utilities
+package require snit ; # OO support, for streaming search class
+package require uevent ; # Generate events for connection-loss
+
+namespace eval ::nameserv {}
+
+# ### ### ### ######### ######### #########
+## API: Write, Read, Search
+
+proc ::nameserv::bind {name data} {
+ # Registers this application at the configured name service under
+ # the specified name, and provides a value.
+ #
+ # Note: The application is allowed register multiple names.
+ #
+ # Note: A registered name is automatically removed by the server
+ # when the connection to it collapses.
+
+ DO Bind $name $data
+ return
+}
+
+proc ::nameserv::release {} {
+ # Releases all names the application has registered at the
+ # configured name service.
+
+ DO Release
+ return
+}
+
+proc ::nameserv::search {args} {
+ # Searches the configured name service for applications whose name
+ # matches the given pattern. Returns a dictionary mapping from the
+ # names to the data they provided at 'bind' time.
+
+ # In continuous and async modes it returns an object whose
+ # contents reflect the current set of matching entries.
+
+ array set a [search-parseargs $args]
+ upvar 0 a(oneshot) oneshot
+ upvar 0 a(continuous) continuous
+ upvar 0 a(pattern) pattern
+
+ if {$continuous} {
+ variable search
+ # This client uses the receiver object as tag for the search
+ # in the service. This is easily unique, and makes dispatch of
+ # incoming results later easy too.
+
+ set receiver [receiver %AUTO% $oneshot]
+ if {[catch {
+ ASYNC Search/Continuous/Start $receiver $pattern
+ } err]} {
+ # Release the allocated object to prevent a leak, then
+ # rethrow the error.
+ $receiver destroy
+ return -code error $err
+ }
+
+ set search($receiver) .
+ return $receiver
+ } else {
+ return [DO Search $pattern]
+ }
+}
+
+proc ::nameserv::protocol {} {
+ return 1
+}
+
+proc ::nameserv::server_protocol {} {
+ return [DO ProtocolVersion]
+}
+
+proc ::nameserv::server_features {} {
+ return [DO ProtocolFeatures]
+}
+
+# ### ### ### ######### ######### #########
+## semi-INT: search argument processing.
+
+proc ::nameserv::search-parseargs {arguments} {
+ # This command is semi-public. It is not documented for public
+ # use, however the package nameserv::auto uses as helper in its
+ # implementation of the search command.
+
+ switch -exact [llength $arguments] {
+ 0 {
+ set oneshot 0
+ set continuous 0
+ set pattern *
+ }
+ 1 {
+ set opt [lindex $arguments 0]
+ if {$opt eq "-continuous"} {
+ set oneshot 0
+ set continuous 1
+ set pattern *
+ } elseif {$opt eq "-async"} {
+ set oneshot 1
+ set continuous 1
+ set pattern *
+ } else {
+ set oneshot 0
+ set continuous 0
+ set pattern $opt
+ }
+ }
+ 2 {
+ set opt [lindex $arguments 0]
+ if {$opt eq "-continuous"} {
+ set oneshot 0
+ set continuous 1
+ set pattern [lindex $arguments 1]
+ } elseif {$opt eq "-async"} {
+ set oneshot 1
+ set continuous 1
+ set pattern [lindex $arguments 1]
+ } else {
+ return -code error "wrong\#args: Expected ?-continuous|-async? ?pattern?"
+ }
+ }
+ default {
+ return -code error "wrong\#args: Expected ?-continuous|-async? ?pattern?"
+ }
+ }
+
+ return [list oneshot $oneshot continuous $continuous pattern $pattern]
+}
+
+# ### ### ### ######### ######### #########
+## INT: Communication setup / teardown / use
+
+proc ::nameserv::DO {args} {
+ variable sid
+ log::debug [linsert $args end @ $sid]
+
+ if {[catch {
+ [SERV] send $sid $args
+ #eval [linsert $args 0 [SERV] send $sid] ;# $args
+ } msg]} {
+ if {[string match "*refused*" $msg]} {
+ return -code error "No name server present @ $sid"
+ } else {
+ return -code error $msg
+ }
+ }
+ # Result of the call
+ return $msg
+}
+
+proc ::nameserv::ASYNC {args} {
+ variable sid
+ log::debug [linsert $args end @ $sid]
+
+ if {[catch {
+ [SERV] send -async $sid $args
+ #eval [linsert $args 0 [SERV] send $sid] ;# $args
+ } msg]} {
+ if {[string match "*refused*" $msg]} {
+ return -code error "No name server present @ $sid"
+ } else {
+ return -code error $msg
+ }
+ }
+ # No result to return
+ return
+}
+
+proc ::nameserv::SERV {} {
+ variable comm
+ variable sid
+ variable host
+ variable port
+ if {$comm ne ""} {return $comm}
+
+ # NOTE
+ # -local 1 means that clients can only talk to a local
+ # name service. Might make sense to auto-force
+ # -local 0 for host ne "localhost".
+
+ set interp [interp::createEmpty]
+ foreach msg {
+ Search/Continuous/Change
+ } {
+ interp alias $interp $msg {} ::nameserv::$msg
+ }
+
+ set sid [list $port $host]
+ set comm [comm::comm new ::nameserv::CSERV \
+ -interp $interp \
+ -local 1 \
+ -listen 1]
+
+ $comm hook lost ::nameserv::LOST
+
+ log::debug [list SERV @ $sid : $comm]
+ return $comm
+}
+
+proc ::nameserv::LOST {args} {
+ upvar 1 id id chan chan reason reason
+ variable comm
+ variable sid
+ variable search
+
+ log::debug [list LOST @ $sid - $reason]
+
+ $comm destroy
+
+ set comm {}
+ set sid {}
+
+ # Notify async/cont search of the loss.
+ foreach r [array names search] {
+ $r DATA stop
+ unset search($r)
+ }
+
+ uevent::generate nameserv lost-connection [list reason $reason]
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Initialization - System state
+
+namespace eval ::nameserv {
+ # Object command of the communication channel to the server.
+ # If present re-configuration is not possible. Also the comm
+ # id of the server.
+
+ variable comm {}
+ variable sid {}
+
+ # Table of active async/cont searches
+
+ variable search ; array set search {}
+}
+
+# ### ### ### ######### ######### #########
+## API: Configuration management (host, port)
+
+proc ::nameserv::cget {option} {
+ return [configure $option]
+}
+
+proc ::nameserv::configure {args} {
+ variable host
+ variable port
+ variable comm
+
+ if {![llength $args]} {
+ return [list -host $host -port $port]
+ }
+ if {[llength $args] == 1} {
+ # cget
+ set opt [lindex $args 0]
+ switch -exact -- $opt {
+ -host { return $host }
+ -port { return $port }
+ default {
+ return -code error "bad option \"$opt\", expected -host, or -port"
+ }
+ }
+ }
+
+ if {$comm ne ""} {
+ return -code error "Unable to configure an active connection"
+ }
+
+ # Note: Should -port/-host be made configurable after
+ # communication has started it will be necessary to provide code
+ # which retracts everything from the old server and re-initializes
+ # the new one.
+
+ while {[llength $args]} {
+ set opt [lindex $args 0]
+ switch -exact -- $opt {
+ -host {
+ if {[llength $args] < 2} {
+ return -code error "value for \"$opt\" is missing"
+ }
+ set host [lindex $args 1]
+ set args [lrange $args 2 end]
+ }
+ -port {
+ if {[llength $args] < 2} {
+ return -code error "value for \"$opt\" is missing"
+ }
+ set port [lindex $args 1]
+ # Todo: Check non-zero unsigned short integer
+ set args [lrange $args 2 end]
+ }
+ default {
+ return -code error "bad option \"$opt\", expected -host, or -port"
+ }
+ }
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Receiver for continuous and async searches
+
+proc ::nameserv::Search/Continuous/Change {tag type response} {
+
+ # Ignore messages for searches which were canceled already.
+ #
+ # Due to the async nature of the messages for cont/async search
+ # the client may have canceled the receiver object already, sent
+ # the stop message already, but still has to process search
+ # results which were already in flight. We ignore them.
+
+ if {![llength [info commands $tag]]} return
+
+ # This client uses the receiver object as tag, dispatch the
+ # received notification to it.
+
+ $tag DATA $type $response
+ return
+}
+
+snit::type ::nameserv::receiver {
+ option -command -default {}
+
+ constructor {{once 0}} {
+ set singleshot $once
+ return
+ }
+
+ destructor {
+ if {$singleshot} return
+ ::nameserv::ASYNC Search/Continuous/Stop $self
+ Callback stop {}
+ return
+ }
+
+ method get {k} {
+ if {![info exists current($k)]} {return -code error "Unknown key \"$k\""}
+ return $current($k)
+ }
+
+ method names {} {
+ return [array names current]
+ }
+
+ method size {} {
+ return [array size current]
+ }
+
+ method getall {{pattern *}} {
+ return [array get current $pattern]
+ }
+
+ method filled {} {
+ return $filled
+ }
+
+ method {DATA stop} {} {
+ if {$filled && $singleshot} return
+ set singleshot 1 ; # Prevent 'stop' again during destruction.
+ Callback stop {}
+ return
+ }
+
+ method {DATA add} {response} {
+ set filled 1
+ if {$singleshot} {
+ ASYNC Search/Continuous/Stop $self
+ }
+ array set current $response
+ Callback add $response
+ if {$singleshot} {
+ Callback stop {}
+ }
+ return
+ }
+
+ method {DATA remove} {response} {
+ set filled 1
+ foreach {k v} $response {
+ unset -nocomplain current($k)
+ }
+ Callback remove $response
+ return
+ }
+
+ proc Callback {type response} {
+ upvar 1 options options
+ if {$options(-command) eq ""} return
+ # Defer execution to event loop
+ after 0 [linsert $options(-command) end $type $response]
+ return
+ }
+
+ variable singleshot 0
+ variable current -array {}
+ variable filled 0
+}
+
+# ### ### ### ######### ######### #########
+## Initialization - Tracing, Configuration
+
+logger::initNamespace ::nameserv
+namespace eval ::nameserv {
+ # Host and port to connect to, to get access to the nameservice.
+
+ variable host localhost
+ variable port [nameserv::common::port]
+
+ namespace export bind release search protocol \
+ server_protocol server_features configure cget
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide nameserv 0.4.2
+
+##
+# ### ### ### ######### ######### #########
diff --git a/tcllib/modules/nns/nns_auto.man b/tcllib/modules/nns/nns_auto.man
new file mode 100644
index 0000000..2547073
--- /dev/null
+++ b/tcllib/modules/nns/nns_auto.man
@@ -0,0 +1,119 @@
+[manpage_begin nameserv::auto n 0.3]
+[see_also nameserv(n)]
+[keywords automatic]
+[keywords client]
+[keywords {name service}]
+[keywords reconnect]
+[keywords restore]
+[copyright {2007-2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Name service facility}]
+[titledesc {Name service facility, Client Extension}]
+[category Networking]
+[require Tcl 8.4]
+[require nameserv::auto [opt 0.3]]
+[require nameserv]
+[description]
+
+Please read the document [term {Name service facility, introduction}]
+first.
+
+[para]
+
+This package provides the [emph exact] same API as is provided by
+package [package nameserv], i.e. the regular name service client. It
+differs from the former by taking measures to ensure that longer-lived
+data, i.e. bound names, continuous and unfullfilled async searches,
+survive the loss of the connection to the name server as much as is
+possible.
+
+[para]
+
+This means that the bound names and continuous and unfullfilled async
+searches are remembered client-side and automatically re-entered into
+the server when the connection comes back after its loss. For bound
+names there is one important limitation to such restoration: It is
+possible that a name of this client was bound by a different client
+while the connection was gone. Such names are fully lost, and the best
+the package can and will do is to inform the user of this.
+
+[section API]
+
+The user-visible API is mainly identical to the API of [package nameserv]
+and is therefore not described here. Please read the documentation of
+[package nameserv].
+
+[para]
+
+The differences are explained below, in the sections [sectref OPTIONS] and
+[sectref EVENTS].
+
+[section OPTIONS]
+
+This package supports all the options of package [package nameserv],
+plus one more. The additional option allows the user to specify the
+time interval between attempts to restore a lost connection.
+
+[list_begin options]
+[opt_def -delay [arg milliseconds]]
+
+The value of this option is an integer value > 0 which specifies the
+interval to wait between attempts to restore a lost connection, in
+milliseconds. The default value is [const 1000], i.e. one second.
+
+[list_end]
+
+[section EVENTS]
+
+This package generates all of the events of package [package nameserv],
+plus two more. Both events are generated for the tag [term nameserv].
+
+[list_begin definitions]
+[def [term lost-name]]
+
+This event is generated when a bound name is truly lost, i.e. could
+not be restored after the temporary loss of the connection to the name
+server. It indicates that a different client took ownership of the
+name while this client was out of contact.
+
+[para]
+
+The detail information of the event will be a Tcl dictionary
+containing two keys, [const name], and [const data]. Their values hold
+all the information about the lost name.
+
+[def [term re-connection]]
+
+This event is generated when the connection to the server is
+restored. The remembered data has been restored when the event is
+posted.
+
+[para]
+
+The event has no detail information.
+
+[list_end]
+
+[section DESIGN]
+
+The package is implemented on top of the regular nameservice client,
+i.e. package [package nameserv]. It detects the loss of the
+connection by listening for [term lost-connection] events, on the tag
+[term nameserv].
+
+[para]
+
+It reacts to such events by starting a periodic timer and trying to
+reconnect to the server whenver this timer triggers. On success the
+timer is canceled, a [term re-connection] event generated, and the
+package proceeds to re-enter the remembered bound names and continuous
+searches.
+
+[para]
+
+Another loss of the connection, be it during or after re-entering the
+remembered information simply restarts the timer and subsequent
+reconnection attempts.
+
+[vset CATEGORY nameserv]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/nns/nns_auto.tcl b/tcllib/modules/nns/nns_auto.tcl
new file mode 100644
index 0000000..b081741
--- /dev/null
+++ b/tcllib/modules/nns/nns_auto.tcl
@@ -0,0 +1,443 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Name Service - Client side connection monitor
+
+# ### ### ### ######### ######### #########
+## Requirements
+
+package require nameserv 0.4.1 ; # Name service client-side core
+package require uevent ; # Watch for connection-loss
+
+namespace eval ::nameserv::auto {}
+
+# ### ### ### ######### ######### #########
+## API: Write, Read, Search
+
+proc ::nameserv::auto::bind {name data} {
+ # See nameserv::bind. Remembers the information, for re-binding
+ # when the connection was lost, and later restored.
+
+ # Note: Enter has a return value we do not want, bind has no
+ # return value. Otherwise 'Enter' would not be necessary and
+ # simply be 'bind'.
+
+ Enter $name $data normal
+ return
+}
+
+proc ::nameserv::auto::release {} {
+ # Releases all names the application has registered at the
+ # configured name service.
+ variable bindings
+ variable timer
+
+ array unset bindings *
+ if {$timer ne ""} {
+ # Actually release the data only if the connection is
+ # currently not lost. Otherwise they are gone already, and
+ # just forgetting them here (see above) was enough.
+ nameserv::release
+ }
+ return
+}
+
+proc ::nameserv::auto::search {args} {
+ variable searches
+
+ # Note: Here we are using a semi-public command of 'nameserv' to
+ # parse the search arguments on our own to determine if we need
+ # the persistence or not.
+
+ array set a [nameserv::search-parseargs $args]
+ upvar 0 a(oneshot) oneshot
+ upvar 0 a(continuous) continuous
+ upvar 0 a(pattern) pattern
+
+ if {!$continuous} {
+ # Result is direct result of the search, pass through to
+ # caller, nothing to persist.
+
+ return [eval [linsert $args 0 ::nameserv::search]]
+ # 8.5: return [nameserv::search {*}$args]
+ }
+
+ # Continuous or async search. The result we got is a receiver
+ # object. Wrap our own persistent receiver around it so that it
+ # can handle a loss of connection while we are waiting for the
+ # search result.
+
+ return [receiver %AUTO% $oneshot $args]
+}
+
+proc ::nameserv::auto::protocol {} {
+ return [nameserv::protocol]
+}
+
+proc ::nameserv::auto::server_protocol {} {
+ return [nameserv::server_protocol]
+}
+
+proc ::nameserv::auto::server_features {} {
+ return [nameserv::server_features]
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper commands.
+
+proc ::nameserv::auto::Reconnect {args} {
+ # args = <>|<tags event details>
+ # <tag,event> = <'nameserv','lost'>
+ # details = dict ('reason' -> string)
+
+ StopReconnect
+
+ if {![catch {
+ ::nameserv::server_features
+ }]} {
+ # Note: Reloss of connection during Rebind will also
+ # StartReconnect
+ Rebind
+ return
+ }
+
+ StartReconnect
+ return
+}
+
+proc ::nameserv::auto::Rebind {} {
+ variable bindings
+ variable searches
+
+ foreach {name data} [array get bindings] {
+ if {![Enter $name $data restore]} return
+ }
+
+ foreach receiver [array names searches] {
+ if {![$receiver restore]} return
+ }
+
+ # Fully restored, time to notify interested parties
+ uevent::generate nameserv re-connection {}
+ return
+}
+
+proc ::nameserv::auto::Enter {name data how} {
+ variable bindings
+
+ # Remember locally for possible loss of connection ...
+ set bindings($name) $data
+
+ # ... then forward to name server
+ if {[catch {
+ nameserv::bind $name $data
+ } msg]} {
+ # Problem with server while (re)binding a name.
+
+ if {[string match {*No name server*} $msg]} {
+ # Lost the server (again), while (re)binding a name. Abort
+ # and restart the watcher waiting for the server to come
+ # back.
+ StartReconnect
+ return 0
+ }
+
+ # Other error => (name already bound). This means that someone
+ # else took the name while we were not connected to the
+ # service, or the name was bound before the call anyway. The
+ # reaction depends on our entry point. For regular bind we
+ # return the error as is to keep API compatibility. During
+ # restoration OTOH the best effort we can do is to deliver a
+ # note about the total loss of this binding to all interested
+ # observers via event. Additionally remove the lost item from
+ # the set of names to remember. Note that there is no need to
+ # restart the watcher, the server was _not_ lost.
+
+ unset bindings($name)
+ if {$how eq "normal"} {
+ return -code $msg
+ } else {
+ uevent::generate nameserv lost-name [list name $name data $data]
+ return 1
+ }
+ }
+
+ # Success, nothing further to do.
+ return 1
+}
+
+# ### ### ### ######### ######### #########
+## Management of the reconnect timer.
+
+proc ::nameserv::auto::StartReconnect {} {
+ variable timer
+ variable delay
+ if {$timer ne ""} return
+ set timer [after $delay ::nameserv::auto::Reconnect]
+ return
+}
+
+proc ::nameserv::auto::StopReconnect {} {
+ variable timer ""
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Persistent receiver for continuous and async searches.
+
+snit::type ::nameserv::auto::receiver {
+
+ option -command -default {}
+
+ constructor {once search} {
+ set mysingleshot $once
+ set mysearch $search
+ $self restore ; # Create internal volatile receiver.
+ return
+ }
+
+ destructor {
+ if {$myreceiver ne ""} { $myreceiver destroy }
+ if {$mysingleshot} return
+ Callback stop {}
+ return
+ }
+
+ method restore {} {
+ set nameserv::auto::searches($self) .
+
+ if {[catch {
+ set result [eval [linsert $mysearch 0 ::nameserv::search]]
+ # 8.5: set result [nameserv::search {*}$mysearch]
+ } msg]} {
+ # Problem with server while restoring a search.
+
+ if {[string match {*No name server*} $msg]} {
+ # Lost the server (again), while restoring the search.
+ # Abort and restart the watcher waiting for the server
+ # to come back.
+ ::nameserv::auto::StartReconnect
+ return 0
+ }
+
+ # Rethrow other problems.
+ return -code error $msg
+ }
+
+ # Restored, prepare ourselves
+ set myreceiver $result
+ set myclear 1 ; # Have to clear previous data when
+ # the new set comes in.
+ $myreceiver configure -command [mymethod DATA]
+ return 1
+ }
+
+ method get {k} {
+ if {![info exists mycurrent($k)]} {return -code error "Unknown key \"$k\""}
+ return $current($k)
+ }
+
+ method names {} {
+ return [array names mycurrent]
+ }
+
+ method size {} {
+ return [array size mycurrent]
+ }
+
+ method getall {{pattern *}} {
+ return [array get mycurrent $pattern]
+ }
+
+ method filled {} {
+ return $myfilled
+ }
+
+ # Handler for events coming from the breakable search.
+
+ method {DATA stop} {args} {
+ # Ignore the response dict, it is empty anyway.
+ # Get rid of the volatile receiver.
+ if {$myreceiver ne ""} { $myreceiver destroy }
+ # Oneshot handling happened already.
+ return
+ }
+
+ method {DATA add} {response} {
+ # New entries to handle
+ set myfilled 1
+ if {$mysingleshot} {
+ # The search was async and is now done, therefore we can
+ # get rid of the volatile receiver and do not have to care
+ # about the loss of the connection any longer.
+ $myreceiver destroy
+ set myreceiver ""
+ unset ::nameserv::auto::searches($self)
+ }
+ if {$myclear} {
+ # Handle a refill after a connection loss, the new data
+ # overwrites everything known before.
+ array unset mycurrent *
+ set myclear 0
+ }
+ array set mycurrent $response
+ Callback add $response
+ if {$mysingleshot} {
+ Callback stop {}
+ }
+ return
+ }
+
+ method {DATA remove} {response} {
+ set myfilled 1
+ foreach {k v} $response {
+ unset -nocomplain mycurrent($k)
+ }
+ Callback remove $response
+ return
+ }
+
+ # Run our own callback.
+
+ proc Callback {type response} {
+ upvar 1 options options
+ if {$options(-command) eq ""} return
+ # Defer execution to event loop
+ after 0 [linsert $options(-command) end $type $response]
+ return
+ }
+
+ # Search state
+
+ variable mysingleshot 0 ; # Bool flag, set if search is
+ # async, not continous.
+ variable mycurrent -array {} ; # Current state of search results
+ variable myfilled 0 ; # Bool flag, set when result has arrived.
+
+ variable mysearch "" ; # Copy of search definition, for
+ # its restoration after our
+ # connection to the service was
+ # restored.
+ variable myclear 0 ; # Bool flag, set when state has to
+ # be cleared before adding new
+ # data, for refill after a
+ # connection has been restored.
+ variable myreceiver "" ; # Volatile breakable regular search
+ # receiver.
+}
+
+# ### ### ### ######### ######### #########
+## Initialization - System state
+
+namespace eval ::nameserv::auto {
+ # In-memory database of bindings to restore after connection was
+ # lost and restored.
+
+ variable bindings ; array set bindings {}
+
+ # In-memory database of continuous and unfulfilled async searches
+ # to restore after the connection was lost and restored.
+
+ variable searches ; array set searches {}
+
+ # Handle of the timer used to periodically try to reconnect with
+ # the server in the case it was lost.
+
+ variable timer ""
+}
+
+# ### ### ### ######### ######### #########
+## API: Configuration management (host, port)
+
+proc ::nameserv::auto::cget {option} {
+ return [configure $option]
+}
+
+proc ::nameserv::auto::configure {args} {
+ variable delay
+
+ if {![llength $args]} {
+ # Merge the underlying configuration with the local settings
+ # before returning.
+ return [linsert [nameserv::configure] 0 -delay $delay]
+ }
+ if {[llength $args] == 1} {
+ # cget
+ set opt [lindex $args 0]
+ switch -exact -- $opt {
+ -delay { return $delay }
+ default {
+ # Not a local option, check with underlying package
+ # before throwing an error.
+ if {![catch {
+ nameserv::cget $opt
+ } v]} {
+ return $v
+ }
+ return -code error "[string map {{expected } {expected -delay, }} $v]"
+ }
+ }
+ }
+
+ while {[llength $args]} {
+ set opt [lindex $args 0]
+ switch -exact -- $opt {
+ -delay {
+ if {[llength $args] < 2} {
+ return -code error "value for \"$opt\" is missing"
+ }
+ set delay [lindex $args 1]
+ set args [lrange $args 2 end]
+
+ # Using the 'incr' hack instead of 'string is integer'
+ # allows delays larger than 32bit in Tcl 8.5.
+ if {[catch {incr delay 0}]} {
+ return -code error "bad value for \"$opt\", expected integer, got \"$delay\""
+ } elseif {$delay <= 0} {
+ return -code error "bad value for \"$opt\", is not greater than zero"
+ }
+ }
+ default {
+ # Not a local option, check with underlying package
+ # before throwing an error.
+ if {[catch {
+ nameserv::configure $opt [lindex $args 1]
+ } v]} {
+ if {[string match {bad option*} $v]} {
+ # Fix list of options in error before rethrowing.
+ return -code error "[string map {{expected } {expected -delay, }} $v]"
+ } else {
+ # Rethrow error unchanged
+ return -code error $v
+ }
+ }
+ # No error, option is processed, continue after it.
+ set args [lrange $args 2 end]
+ }
+ }
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Initialization - Tracing, Configuration
+
+logger::initNamespace ::nameserv::auto
+namespace eval ::nameserv::auto {
+ # Interval between reconnection attempts when connection was lost.
+
+ variable delay 1000 ; # One second
+
+ namespace export bind release search protocol \
+ server_protocol server_features configure cget
+}
+
+# Watch the base client for the loss of the connection.
+uevent::bind nameserv lost-connection ::nameserv::auto::Reconnect
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide nameserv::auto 0.3
+
+##
+# ### ### ### ######### ######### #########
diff --git a/tcllib/modules/nns/nns_client.man b/tcllib/modules/nns/nns_client.man
new file mode 100644
index 0000000..60068c5
--- /dev/null
+++ b/tcllib/modules/nns/nns_client.man
@@ -0,0 +1,338 @@
+[manpage_begin nameserv n 0.4.2]
+[see_also nameserv::common(n)]
+[see_also nameserv::server(n)]
+[keywords client]
+[keywords {name service}]
+[copyright {2007-2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Name service facility}]
+[titledesc {Name service facility, Client}]
+[category Networking]
+[require Tcl 8.4]
+[require nameserv [opt 0.4.2]]
+[require comm]
+[require logger]
+[description]
+
+Please read [term {Name service facility, introduction}] first.
+
+[para]
+
+This package provides a client for the name service facility
+implemented by the package [package nameserv::server].
+
+[para]
+
+This service is built in top of and for the package [package comm].
+It has nothing to do with the Internet's Domain Name System. If the
+reader is looking for a package dealing with that please see Tcllib's
+packages [package dns] and [package resolv].
+
+[section API]
+
+The package exports eight commands, as specified below:
+
+[list_begin definitions]
+
+[call [cmd ::nameserv::bind] [arg name] [arg data]]
+
+The caller of this command registers the given [arg name] as its name
+in the configured name service, and additionally associates a piece of
+[arg data] with it. The service does nothing with this information
+beyond storing it and delivering it as part of search results. The
+meaning is entirely up to the applications using the name service.
+
+[para]
+
+A generally useful choice would for example be an identifier for a
+communication endpoint managed by the package [package comm]. Anybody
+retrieving the name becomes immediately able to talk to this endpoint,
+i.e. the registering application.
+
+[para]
+
+Of further importance is that a caller can register itself under more
+than one name, and each name can have its own piece of [arg data].
+
+[para]
+
+Note that the name service, and thwerefore this command, will throw an
+error if the chosen name is already registered.
+
+[call [cmd ::nameserv::release]]
+
+Invoking this command releases all names (and their data) registered
+by all previous calls to [cmd ::nameserv::bind] of this client. Note
+that the name service will run this command implicitly when it loses
+the connection to this client.
+
+[call [cmd ::nameserv::search] [opt [option -async]|[option -continuous]] [opt [arg pattern]]]
+
+This command searches the name service for all registered names
+matching the specified glob-[arg pattern]. If not specified the
+pattern defaults to [const *], matching everything. The result of the
+command is a dictionary mapping the matching names to the data
+associated with them at [term bind]-time.
+
+[para]
+
+If either option [option -async] or [option -continuous] were
+specified the result of this command changes and becomes the Tcl
+command of an object holding the actual result.
+
+These two options are supported if and only if the service the client
+is connected to supports the protocol feature
+[term Search/Continuous].
+
+[para]
+
+For [option -async] the result object is asynchronously filled with
+the entries matching the pattern at the time of the search and then
+not modified any more.
+
+The option [option -continuous] extends this behaviour by additionally
+continuously monitoring the service for the addition and removal of
+entries which match the pattern, and updating the object's contents
+appropriately.
+
+[para]
+
+[emph Note] that the caller is responsible for configuring the object
+with a callback for proper notification when the current result (or
+further changes) arrive.
+
+[para]
+
+For more information about this object see section
+[sectref {ASYNCHRONOUS AND CONTINUOUS SEARCHES}].
+
+[call [cmd ::nameserv::protocol]]
+
+This command returns the highest version of the name service protocol
+supported by the package.
+
+[call [cmd ::nameserv::server_protocol]]
+
+This command returns the highest version of the name service protocol
+supported by the name service the client is currently connected to.
+
+[call [cmd ::nameserv::server_features]]
+
+This command returns a list containing the names of the features of
+the name service protocol which are supported by the name service the
+client is currently connected to.
+
+[call [cmd ::nameserv::cget] [option -option]]
+
+This command returns the currently configured value for the specified
+[option -option]. The list of supported options and their meaning can
+be found in section [sectref OPTIONS].
+
+[call [cmd ::nameserv::configure]]
+
+In this form the command returns a dictionary of all supported
+options, and their current values. The list of supported options and
+their meaning can be found in section [sectref OPTIONS].
+
+[call [cmd ::nameserv::configure] [option -option]]
+
+In this form the command is an alias for
+"[cmd ::nameserv::cget] [option -option]]".
+
+The list of supported options and their meaning can be found in
+section [sectref OPTIONS].
+
+[call [cmd ::nameserv::configure] "[option -option] [arg value]..."]
+
+In this form the command is used to configure one or more of the
+supported options. At least one option has to be specified, and each
+option is followed by its new value.
+
+The list of supported options and their meaning can be found in
+section [sectref OPTIONS].
+
+[para]
+
+This form can be used only as long as the client has not contacted the
+name service yet. After contact has been made reconfiguration is not
+possible anymore. This means that this form of the command is for the
+initalization of the client before it use.
+
+The command forcing a contact with the name service are
+
+[list_begin commands]
+[cmd_def bind]
+[cmd_def release]
+[cmd_def search]
+[cmd_def server_protocol]
+[cmd_def server_features]
+[list_end]
+[list_end]
+
+[section {CONNECTION HANDLING}]
+
+The client automatically connects to the service when one of the
+commands below is run for the first time, or whenever one of the
+commands is run after the connection was lost, when it was lost.
+
+[para]
+[list_begin commands]
+[cmd_def bind]
+[cmd_def release]
+[cmd_def search]
+[cmd_def server_protocol]
+[cmd_def server_features]
+[list_end]
+[para]
+
+Since version 0.2 of the client it will generate an event when the
+connection is lost, allowing higher layers to perform additional
+actions. This is done via the support package [package uevent]. This
+and all other name service related packages hereby reserve the
+uevent-tag [term nameserv]. All their events will be posted to that
+tag.
+
+[section EVENTS]
+
+This package generates only one event, [term lost-connection]. The
+detail information provided to that event is a Tcl dictionary. The
+only key contained in the dictionnary is [const reason], and its value
+will be a string describing why the connection was lost.
+
+This string is supplied by the underlying communication package,
+i.e. [package comm].
+
+[section OPTIONS]
+
+The options supported by the client are for the specification of which
+name service to contact, i.e. of the location of the name service.
+
+They are:
+
+[list_begin options]
+[opt_def -host [arg name]|[arg ipaddress]]
+
+This option specifies the host name service to contact is running on,
+either by [arg name], or by [arg ipaddress]. The initial default is
+[const localhost], i.e. it is expected to contact a name service
+running on the same host as the application using this package.
+
+[opt_def -port [arg number]]
+
+This option specifies the port the name service to contact is
+listening on. It has to be a positive integer number (> 0) not greater
+than 65536 (unsigned short). The initial default is the number
+returned by the command [cmd ::nameserv::common::port], as provided by
+the package [package ::nameserv::common].
+
+[list_end]
+
+[section {ASYNCHRONOUS AND CONTINUOUS SEARCHES}]
+
+Asynchronous and continuous searches are invoked by using either
+option [option -async] or [option -continuous] as argument to the
+command [cmd ::nameserv::search].
+
+[para]
+
+[emph Note] that these two options are supported if and only if the
+service the client is connected to supports the protocol feature
+[term Search/Continuous]. The service provided by the package
+[package ::nameserv::server] does this since version 0.3.
+
+[para]
+
+For such searches the result of the search command is the Tcl command
+of an object holding the actual result. The API provided by these
+objects is:
+
+[list_begin definitions]
+
+[def Options:]
+[list_begin options]
+[opt_def -command [arg command_prefix]]
+
+This option has to be set if a user of the result object wishes to get
+asynchronous notifications when the search result or changes to it
+arrive.
+
+[para]
+
+[emph Note] that while it is possible to poll for the arrival of the
+initial search result via the method [method filled], and for
+subsequent changes by comparing the output of method [method getall]
+against a saved copy, this is not the recommended behaviour. Setting
+the [option -command] callback and processing the notifications as
+they arrive is much more efficient.
+
+[para]
+
+The [arg command_prefix] is called with two arguments, the type of
+change, and the data of the change. The type is either [const add] or
+[const remove], indicating new data, or deleted data, respectively.
+The data of the change is always a dictionary listing the
+added/removed names and their associated data.
+
+[para]
+
+The first change reported for a search is always the set of matching
+entries at the time of the search.
+
+[list_end]
+
+[def Methods:]
+[list_begin definitions]
+
+[call [cmd \$result] [method destroy]]
+
+Destroys the object and cancels any continuous monitoring of the
+service the object may have had active.
+
+[call [cmd \$result] [method filled]]
+
+The result is a boolean value indicating whether the search result has
+already arrived ([const True]), or not ([const False]).
+
+[call [cmd \$result] [method get] [arg name]]
+
+Returns the data associated with the given [arg name] at
+[term bind]-time.
+
+[call [cmd \$result] [method names]]
+
+Returns a list containing all names known to the object at the time of
+the invokation.
+
+[call [cmd \$result] [method size]]
+
+Returns an integer value specifying the size of the result at the time
+of the invokation.
+
+[call [cmd \$result] [method getall] [opt [arg pattern]]]
+
+Returns a dictionary containing the search result at the time of the
+invokation, mapping the matching names to the data associated with
+them at [term bind]-time.
+
+[list_end]
+[list_end]
+
+[section HISTORY]
+[list_begin definitions]
+[def 0.3.1]
+Fixed SF Bug 1954771.
+
+[def 0.3]
+Extended the client with the ability to perform asynchronous and
+continuous searches.
+
+[def 0.2]
+Extended the client with the ability to generate events when it loses
+its connection to the name service. Based on package [package uevent].
+
+[def 0.1]
+Initial implementation of the client.
+[list_end]
+
+[vset CATEGORY nameserv]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/nns/nns_cluster.tcl b/tcllib/modules/nns/nns_cluster.tcl
new file mode 100644
index 0000000..6d49c1a
--- /dev/null
+++ b/tcllib/modules/nns/nns_cluster.tcl
@@ -0,0 +1,499 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Name Service - Cluster
+
+# ### ### ### ######### ######### #########
+## Requirements
+
+package require Tcl 8.5
+package require comm ; # Generic message transport
+package require interp ; # Interpreter helpers.
+package require logger ; # Tracing internal activity
+package require uuid
+package require cron
+package require nettool 0.4
+package require udp
+
+namespace eval ::comm {}
+::namespace eval ::cluster {}
+
+###
+# This package implements an ad/hoc zero configuration
+# like network of comm (and other) network connections
+###
+
+###
+# topic: 5cffdc91e554c923ebe43df13fac77d5
+###
+proc ::cluster::broadcast {args} {
+ if {$::cluster::config(debug)} {
+ puts [list $::cluster::local_pid SEND $args]
+ }
+ while {[catch {
+ set sock [listen]
+ puts -nonewline $sock [list [pid] {*}$args]
+ flush $sock
+ } error]} {
+ set ::cluster::broadcast_sock {}
+ if {$::cluster::config(debug)} {
+ puts "Broadcast ERR: $error - Reopening Socket"
+ ::cluster::sleep 2000
+ } else {
+ # Double the delay
+ ::cluster::sleep 250
+ }
+ }
+}
+
+###
+# topic: 963e24601d0dc61580c9727a74cdba67
+###
+proc ::cluster::cname rawname {
+ # Convert rawname to a canonical name
+ if {[string first @ $rawname] < 0 } {
+ return $rawname
+ }
+ lassign [split $rawname @] service host
+ if {$host eq {}} {
+ set host *
+ }
+ if {$host in {local localhost}} {
+ set host [::cluster::self]
+ }
+ return $service@$host
+}
+
+###
+# topic: 3f5f9e197cc9666dd7953d97fef34019
+###
+proc ::cluster::ipaddr macid {
+ # Convert rawname to a canonical name
+ if {$macid eq [::cluster::self]} {
+ return 127.0.0.1
+ }
+ foreach {servname dat} [search [cname *@$macid]] {
+ if {[dict exists $dat ipaddr]} {
+ return [dict get $dat ipaddr]
+ }
+ }
+ ###
+ # Do a lookup
+ ###
+ error "Could not locate $macid"
+}
+
+###
+# topic: e57db306f0e931d7febb5ad1f9cb2247
+###
+proc ::cluster::listen {} {
+ variable broadcast_sock
+ if {$broadcast_sock != {}} {
+ return $broadcast_sock
+ }
+ variable discovery_port
+ variable discovery_group
+ set broadcast_sock [udp_open $discovery_port reuse]
+ fconfigure $broadcast_sock -buffering none -blocking 0 \
+ -mcastadd $discovery_group \
+ -remote [list $discovery_group $discovery_port]
+ fileevent $broadcast_sock readable [list [namespace current]::UDPPacket $broadcast_sock]
+ ::cron::every cluster_heartbeat 30 ::cluster::heartbeat
+
+ return $broadcast_sock
+}
+
+###
+# topic: 2a33c825920162b0791e2cdae62e6164
+###
+proc ::cluster::UDPPacket sock {
+ variable ptpdata
+ set pid [pid]
+ set packet [string trim [read $sock]]
+ set peer [fconfigure $sock -peer]
+
+ if {![string is ascii $packet]} return
+ if {![::info complete $packet]} return
+
+ set sender [lindex $packet 0]
+ if {$::cluster::config(debug)} {
+ puts [list $::cluster::local_pid RECV $peer $packet]
+ }
+ if { $sender eq [pid] } {
+ # Ignore messages from myself
+ return
+ }
+
+ set messagetype [lindex $packet 1]
+ set messageinfo [lrange $packet 2 end]
+ switch -- [string toupper $messagetype] {
+ -SERVICE {
+ set serviceurl [lindex $messageinfo 0]
+ set serviceinfo [lindex $messageinfo 1]
+ dict set serviceinfo ipaddr [lindex $peer 0]
+ dict set serviceinfo closed 1
+ Service_Remove $serviceurl $serviceinfo
+ }
+ ~SERVICE {
+ set ::cluster::recv_message 1
+ set serviceurl [lindex $messageinfo 0]
+ set serviceinfo [lindex $messageinfo 1]
+ dict set serviceinfo ipaddr [lindex $peer 0]
+ Service_Modified $serviceurl $serviceinfo
+ set ::cluster::ping_recv($serviceurl) [clock seconds]
+ }
+ +SERVICE {
+ set ::cluster::recv_message 1
+ set serviceurl [lindex $messageinfo 0]
+ set serviceinfo [lindex $messageinfo 1]
+ dict set serviceinfo ipaddr [lindex $peer 0]
+ Service_Add $serviceurl $serviceinfo
+ set ::cluster::ping_recv($serviceurl) [clock seconds]
+ }
+ DISCOVERY {
+ variable config
+ ::cluster::heartbeat
+ if {$config(local_registry)==1} {
+ variable ptpdata
+ # A local registry barfs back all data that is sees
+ set now [clock seconds]
+ foreach {url info} [array get ptpdata] {
+ broadcast ~SERVICE $url $info
+ }
+ }
+ }
+ LOG {
+ set serviceurl [lindex $messageinfo 0]
+ set serviceinfo [lindex $messageinfo 1]
+ Service_Log $serviceurl $serviceinfo
+ }
+ ?WHOIS {
+ set wmacid [lindex $messageinfo 0]
+ if { $wmacid eq [::cluster::self] } {
+ broadcast +WHOIS [::cluster::self]
+ }
+ }
+ PONG {
+ set serviceurl [lindex $messageinfo 0]
+ set serviceinfo [lindex $messageinfo 1]
+ Service_Modified $serviceurl $serviceinfo
+ set ::cluster::ping_recv($serviceurl) [clock seconds]
+ }
+ PING {
+ set serviceurl [lindex $messageinfo 0]
+ foreach {url info} [search_local $serviceurl] {
+ broadcast PONG $url $info
+ }
+ }
+ }
+}
+
+proc ::cluster::ping {rawname} {
+ set rcpt [cname $rawname]
+ set ::cluster::ping_recv($rcpt) 0
+ set starttime [clock seconds]
+ set sleeptime 1
+ while 1 {
+ broadcast PING $rcpt
+ update
+ if {$::cluster::ping_recv($rcpt)} break
+ if {([clock seconds] - $starttime) > 120} {
+ error "Could not locate a local dispatch service"
+ }
+ sleep [incr sleeptime $sleeptime]
+ }
+}
+
+proc ::cluster::publish {url infodict} {
+ variable local_data
+ dict set infodict macid [self]
+ dict set infodict pid [pid]
+ set local_data($url) $infodict
+ broadcast +SERVICE $url $infodict
+}
+
+proc ::cluster::heartbeat {} {
+ variable ptpdata
+ variable config
+
+ set now [clock seconds]
+ foreach {item info} [array get ptpdata] {
+ set remove 0
+ if {[dict exists $info closed] && [dict get $info closed]} {
+ set remove 1
+ }
+ if {[dict exists $info updated] && ($now - [dict get $info updated])>$config(discovery_ttl)} {
+ set remove 1
+ }
+ if {$remove} {
+ Service_Remove $item $info
+ }
+ }
+ ###
+ # Broadcast the status of our local services
+ ###
+ variable local_data
+ foreach {url info} [array get local_data] {
+ broadcast ~SERVICE $url $info
+ }
+ ###
+ # Trigger any cluster events that haven't fired off
+ ###
+ foreach {eventid info} [array get ::cluster::events] {
+ if {$info eq "-1"} {
+ unset ::cluster::events($eventid)
+ } else {
+ lassign $info seconds ms
+ if {$seconds < $now} {
+ set ::cluster::events($eventid) -1
+ }
+ }
+ }
+}
+
+proc ::cluster::info url {
+ variable local_data
+ return [array get local_data $url]
+}
+
+proc ::cluster::unpublish {url infodict} {
+ variable local_data
+ foreach {field value} $infodict {
+ dict set local_data($url) $field $value
+ }
+ set info [lindex [array get local_data $url] 1]
+ broadcast -SERVICE $url $info
+ unset -nocomplain local_data($url)
+}
+
+proc ::cluster::configure {url infodict {send 1}} {
+ variable local_data
+ if {![::info exists local_data($url)]} return
+ foreach {field value} $infodict {
+ dict set local_data($url) $field $value
+ }
+ if {$send} {
+ broadcast ~SERVICE $url $local_data($url)
+ update
+ }
+}
+
+proc ::cluster::get_free_port {{startport 50000}} {
+ ::cluster::listen
+ ::cluster::broadcast DISCOVERY
+ after 10000 {set ::cluster::recv_message 0}
+ # Wait for a pingback or timeout
+ vwait ::cluster::recv_message
+ cluster::sleep 2000
+
+ set macid [::cluster::macid]
+ set port $startport
+ set conflict 1
+ while {$conflict} {
+ set conflict 0
+ set port [::nettool::find_port $port]
+ foreach {url info} [search *@[macid]] {
+ if {[dict exists $info port] && [dict get $info port] eq $port} {
+ incr port
+ set conflict 1
+ break
+ }
+ }
+ update
+ }
+ return $port
+}
+
+proc ::cluster::log args {
+ broadcast LOG {*}$args
+}
+
+proc ::cluster::LookUp {rawname} {
+ set self [self]
+ foreach {servname dat} [search [cname $rawname]] {
+ # Ignore services in the process of closing
+ if {[dict exists $dat macid] && [dict get $dat macid] eq $self} {
+ set ipaddr 127.0.0.1
+ } elseif {![dict exists $dat ipaddr]} {
+ set ipaddr [ipaddr [lindex [split $servname @] 1]]
+ } else {
+ set ipaddr [dict get $dat ipaddr]
+ }
+ if {![dict exists $dat port]} continue
+ if {[llength $ipaddr] > 1} {
+ ## Sort out which ipaddr is proper later
+ # for now take the last one
+ set ipaddr [lindex [dict get $dat ipaddr] end]
+ }
+ set port [dict get $dat port]
+ return [list $port $ipaddr]
+ }
+ return {}
+}
+
+###
+# topic: 2c04e58c7f93798f9a5ed31a7f5779ab
+###
+proc ::cluster::resolve {rawname} {
+ set result [LookUp $rawname]
+ if { $result ne {} } {
+ return $result
+ }
+ broadcast DISCOVERY
+ sleep 250
+ set result [LookUp $rawname]
+ if { $result ne {} } {
+ return $result
+ }
+ error "Could not locate $rawname"
+}
+
+###
+# topic: 6c7a0a3a8cb2a7ae98ff0dba960c37a7
+###
+proc ::cluster::pid {} {
+ variable local_pid
+ return $local_pid
+}
+
+proc ::cluster::macid {} {
+ variable local_macid
+ return $local_macid
+}
+
+proc ::cluster::self {} {
+ variable local_macid
+ return $local_macid
+}
+
+###
+# topic: f1b71ff12a8ac10373c67ac5d973cd81
+###
+proc ::cluster::send {service command args} {
+ set commid [resolve $service]
+ return [::comm::comm send $commid $command {*}$args]
+}
+
+proc ::cluster::throw {service command args} {
+ set commid [LookUp $service]
+ if { $commid eq {} } {
+ return
+ }
+ if [catch {::comm::comm send -async $commid $command {*}$args} reply] {
+ puts $stderr "ERR: SEND $service $reply"
+ }
+}
+
+proc ::cluster::sleep ms {
+ set eventid [incr ::cluster::eventcount]
+ set ::cluster::event($eventid) [list [clock seconds] [expr {[clock milliseconds]+$ms}]]
+ after $ms set ::cluster::event($eventid) -1
+ vwait ::cluster::event($eventid)
+}
+
+###
+# topic: c8475e832c912e962f238c61580b669e
+###
+proc ::cluster::search pattern {
+ set result {}
+ variable ptpdata
+ foreach {service dat} [array get ptpdata $pattern] {
+ foreach {field value} $dat {
+ dict set result $service $field $value
+ }
+ }
+ variable local_data
+ foreach {service dat} [array get local_data $pattern] {
+ foreach {field value} $dat {
+ dict set result $service $field $value
+ dict set result $service ipaddr 127.0.0.1
+ }
+ }
+ return $result
+}
+
+proc ::cluster::is_local pattern {
+ variable local_data
+ if {[array exists local_data $pattern]} {
+ return 1
+ }
+ if {[array exists local_data [cname $pattern]]} {
+ return 1
+ }
+ return 0
+}
+
+proc ::cluster::search_local pattern {
+ set result {}
+ variable local_data
+ foreach {service dat} [array get local_data $pattern] {
+ foreach {field value} $dat {
+ dict set result $service $field $value
+ }
+ }
+ return $result
+}
+
+proc ::cluster::Service_Add {serviceurl serviceinfo} {
+ # Code to register the presence of a service
+ if {[dict exists $serviceinfo pid] && [dict get $serviceinfo pid] eq [pid] } {
+ # Ignore attempts to overwrite locally managed services from the network
+ return
+ }
+ variable ptpdata
+ set ptpdata($serviceurl) $serviceinfo
+ dict set ptpdata($serviceurl) updated [clock seconds]
+}
+
+proc ::cluster::Service_Remove {serviceurl serviceinfo} {
+ # Code to register the loss of a service
+ if {[dict exists $serviceinfo pid] && [dict get $serviceinfo pid] eq [pid] } {
+ # Ignore attempts to overwrite locally managed services from the network
+ return
+ }
+ variable ptpdata
+ unset -nocomplain ptpdata($serviceurl)
+}
+
+proc ::cluster::Service_Modified {serviceurl serviceinfo} {
+ # Code to register an update to a service
+ if {[dict exists $serviceinfo pid] && [dict get $serviceinfo pid] eq [pid] } {
+ # Ignore attempts to overwrite locally managed services from the network
+ return
+ }
+ variable ptpdata
+ foreach {field value} $serviceinfo {
+ dict set ptpdata($serviceurl) $field $value
+ }
+ dict set ptpdata($serviceurl) updated [clock seconds]
+}
+
+proc ::cluster::Service_Log {service data} {
+ # Code to register an event
+}
+
+###
+# topic: d3e48e31cc4baf81395179f4097fee1b
+###
+namespace eval ::cluster {
+ # Number of seconds to "remember" data
+ variable config
+ array set config {
+ debug 0
+ discovery_ttl 300
+ local_registry 0
+ }
+ variable eventcount 0
+ variable cache {}
+ variable broadcast_sock {}
+ variable cache_maxage 500
+ variable discovery_port 38573
+ # Currently an unassigned group in the
+ # Local Network Control Block (224.0.0/24)
+ # See: RFC3692 and http://www.iana.org
+ variable discovery_group 224.0.0.200
+ variable local_port {}
+ variable local_macid [lindex [::nettool::mac_list] 0]
+ variable local_pid [::uuid::uuid generate]
+}
+
+package provide nameserv::cluster 0.2.3
diff --git a/tcllib/modules/nns/nns_cluster.test b/tcllib/modules/nns/nns_cluster.test
new file mode 100644
index 0000000..cdd4fac
--- /dev/null
+++ b/tcllib/modules/nns/nns_cluster.test
@@ -0,0 +1,195 @@
+# -*- tcl -*-
+# common.test: Tests for the common code of the name service
+#
+# Sourcing this file into Tcl runs the tests and generates output for
+# errors. No output means no errors were found.
+
+# -------------------------------------------------------------------------
+
+set testutilsscript [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+source $testutilsscript
+
+package require tcltest
+testsNeedTcl 8.5
+testsNeedTcltest 1.0
+
+set ::WHOAMI Main
+
+support {
+ use snit/snit2.tcl snit
+ use comm/comm.tcl comm
+ use dns/ip.tcl ip
+ use nettool/nettool.tcl nettool
+ use cron/cron.tcl cron
+ use uuid/uuid.tcl uuid
+ use interp/interp.tcl interp
+ use log/logger.tcl logger
+ use md5/md5x.tcl md5
+}
+testing {
+ useLocal nns_cluster.tcl nameserv::cluster
+}
+
+###
+# Create a server in a seperate interp
+###
+interp create server
+interp eval server [list set testutilsscript $testutilsscript]
+interp eval server {
+ source $testutilsscript
+ set ::WHOAMI Server
+
+ package require tcltest
+ testsNeedTcl 8.5
+ testsNeedTcltest 1.0
+
+ support {
+ use snit/snit2.tcl snit
+ use comm/comm.tcl comm
+ use dns/ip.tcl ip
+ use nettool/nettool.tcl nettool
+ use cron/cron.tcl cron
+ use uuid/uuid.tcl uuid
+ use interp/interp.tcl interp
+ use log/logger.tcl logger
+ use md5/md5x.tcl md5
+ }
+ testing {
+ use nns/nns_cluster.tcl nameserv::cluster
+ }
+ set ::cluster::local_pid SERVER
+ ::cluster::publish nns@[::cluster::macid] {}
+ update
+}
+set ::cluster::local_pid MAIN
+set macid [::cluster::macid]
+set myport [::nettool::allocate_port 10000]
+
+::cluster::ping nns@$macid
+set data [::cluster::search *]
+test cluster-comm-1.0 {Publish service - NNS} {
+ dict exists $data nns@[::cluster::macid]
+} {1}
+
+test cluster-comm-1.1 {Check that non-existant service does not exist} {
+ dict exists $data foo@bar
+} {0}
+
+###
+# Create a phony service
+###
+set now [clock seconds]
+::cluster::publish foo@bar [list clocktime $now]
+# The windows event loop needs a breather
+::cluster::ping nns@$macid
+
+set data [::cluster::search *]
+test cluster-comm-2.0 {Publish service - NNS} {
+ dict exists $data nns@[::cluster::macid]
+} {1}
+test cluster-comm-2.1 {Check that new service does exists} {
+ dict exists $data foo@bar
+} {1}
+
+###
+# Modify a service
+###
+::cluster::configure foo@bar {color pink}
+::cluster::ping nns@$macid
+
+set data [::cluster::search foo@bar]
+test cluster-comm-2.3 {Modify a service} {
+ dict get $data foo@bar color
+} {pink}
+
+::cluster::configure foo@bar {color blue}
+::cluster::ping nns@$macid
+
+set data [::cluster::search foo@bar]
+test cluster-comm-2.4 {Modify a service} {
+ dict get $data foo@bar color
+} {blue}
+
+
+###
+# Create another client in a seperate interp
+###
+interp create otherclient
+interp eval otherclient [list set testutilsscript $testutilsscript]
+interp eval otherclient {
+ source $testutilsscript
+ set ::WHOAMI Other
+
+ package require tcltest
+ testsNeedTcl 8
+ testsNeedTcltest 1.0
+
+ support {
+ use snit/snit2.tcl snit
+ use comm/comm.tcl comm
+ use dns/ip.tcl ip
+ use nettool/nettool.tcl nettool
+ use cron/cron.tcl cron
+ use uuid/uuid.tcl uuid
+ use interp/interp.tcl interp
+ use log/logger.tcl logger
+ use md5/md5x.tcl md5
+ }
+ testing {
+ use nns/nns_cluster.tcl nameserv::cluster
+ }
+
+ ###
+ # Cheat and let this server know the server is local
+ ###
+ set macid [::cluster::macid]
+ set myport [::nettool::allocate_port 10000]
+
+ set url other@$macid
+ ::comm::comm new $url -port $myport -local 0 -listen 1
+ ::cluster::publish $url [list port $myport protocol comm class comm]
+}
+::cluster::ping nns@$macid
+
+set data [::cluster::search *]
+test cluster-comm-3.0 {Publish service - NNS} {
+ dict exists $data nns@[::cluster::macid]
+} {1}
+test cluster-comm-3.1 {Check that new service does exists} {
+ dict exists $data foo@bar
+} {1}
+test cluster-comm-3.3 {Check that other service does exists} {
+ dict exists $data other@[::cluster::macid]
+} {1}
+
+test cluster-comm-3.3 {Check that other service does exists} {
+ set chan [::cluster::resolve other@[::cluster::macid]]
+ ::comm::comm send $chan {set foo b}
+} {b}
+
+###
+# Remove the phony service
+###
+::cluster::unpublish foo@bar {}
+::cluster::ping nns@$macid
+
+set data [::cluster::search *]
+test cluster-comm-4.0 {Publish service - NNS} {
+ dict exists $data nns@[::cluster::macid]
+} {1}
+test cluster-comm-4.1 {Check that service is closed} {
+ dict exists $data foo@bar
+} {0}
+
+###
+# Have a non-existant service fail
+###
+test cluster-comm-5.0 {Service lookup failture} {
+ catch {cluster::resolve foo@bar} pat
+} {1}
+#puts $pat
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/nns/nns_common.man b/tcllib/modules/nns/nns_common.man
new file mode 100644
index 0000000..8de8ca0
--- /dev/null
+++ b/tcllib/modules/nns/nns_common.man
@@ -0,0 +1,47 @@
+[manpage_begin nameserv::common n 0.1]
+[see_also nameserv::client(n)]
+[see_also nameserv::server(n)]
+[keywords client]
+[keywords {name service}]
+[keywords server]
+[copyright {2007-2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Name service facility}]
+[titledesc {Name service facility, shared definitions}]
+[category Networking]
+[require Tcl 8]
+[require nameserv::common [opt 0.1]]
+[description]
+
+Please read [term {Name service facility, introduction}] first.
+
+[para]
+
+This package is internal and of no interest to users. It provides the
+commands of the name service facility which are shared by the client
+and server implemented by the packages [package nameserv::server] and
+[package nameserv] (the client).
+
+[para]
+
+This service is built in top of and for the package [package comm].
+It has nothing to do with the Internet's Domain Name System. If the
+reader is looking for a package dealing with that please see Tcllib's
+packages [package dns] and [package resolv].
+
+[section API]
+
+The package exports a single command, as specified below:
+
+[list_begin definitions]
+
+[call [cmd ::nameserv::common::port]]
+
+The result returned by the command is the id of the default TCP/IP
+port a nameservice server will listen on, and a name service client
+will try to connect to.
+
+[list_end]
+
+[vset CATEGORY nameserv]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/nns/nns_intro.man b/tcllib/modules/nns/nns_intro.man
new file mode 100644
index 0000000..4ed3551
--- /dev/null
+++ b/tcllib/modules/nns/nns_intro.man
@@ -0,0 +1,128 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin nns_intro n 1.0]
+[see_also nameserv(n)]
+[see_also nameserv::auto(n)]
+[see_also nameserv::common(n)]
+[see_also nameserv::protocol(n)]
+[see_also nameserv::server(n)]
+[see_also nnsd(n)]
+[see_also nss(n)]
+[keywords client]
+[keywords {name service}]
+[keywords server]
+[copyright {2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Name service facility}]
+[titledesc {Name service facility, introduction}]
+[category Networking]
+[description]
+[para]
+
+[term nns] (short for [emph {nano nameservice}]) is a facility built
+for the package [package comm], adding a simple name service to it.
+It is also built on top of [package comm], using it for the exchange
+of messages between the client and server parts.
+
+[para]
+
+This name service facility has nothing to do with the Internet's
+[term {Domain Name System}], otherwise known as [term DNS]. If the
+reader is looking for a package dealing with that please see either of
+the packages [package dns] and [package resolv], both found in Tcllib
+too.
+
+[para]
+
+Tcllib provides 2 applications and 4 packages which are working
+together and provide access to the facility at different levels.
+
+[section Applications]
+
+The application [syscmd nnsd] provides a simple name server which can
+be run by anybody anywhere on their system, as they see fit.
+
+It is also an example on the use of the server-side package
+[package nameserv::server].
+
+[para]
+
+Complementing this server is the [syscmd nns] client application.
+
+A possible, but no very sensible use would be to enter name/port
+bindings into a server from a shell script. Not sensible, as shell
+scripts normally do not provide a [package comm]-based service.
+
+[para]
+
+The only case for this to make some sense would be in a shell script
+wrapped around a Tcl script FOO which is using comm, to register the
+listening port used by FOO.
+
+However even there it would much more sensible to extend FOO to use
+the nameservice directly. And in regard on how to that [syscmd nns]
+can be used as both example and template.
+
+Beyond that it may also be useful to perform nameservice queries from
+shell scripts.
+
+[para]
+
+The third application, [syscmd nnslog] is a stripped down form of the
+[syscmd nns] client application. It is reduced to perform a continuous
+search for all changes and logs all received events to stdout.
+
+[para]
+
+Both clients use the [package nameserv::auto] package to automatically
+hande the loss and restoration of the connection to the server.
+
+[section Packages]
+
+The two main packages implementing the service are [package nameserv]
+and [package nameserv::server], i.e. client and server. The latter has
+not much of an API, just enough to start, stop, and configure it. See
+the application [syscmd nnsd] on how to use it.
+
+[para]
+
+The basic client, in package [package nameserv], provides the main API
+to manipulate and query the service. An example of its use is the
+application [syscmd nns].
+
+[para]
+
+The second client package, [package nameserv::auto] is API compatible
+to the basic client, but provides the additional functionality that it
+will automatically restore data like bound names when the connection
+to the name service was lost and then reestablished. I.e. it
+automatically detects the loss of the server and re-enters the data
+when the server comes back.
+
+[para]
+
+The package [package nameserv::common] is of no interest to users. It
+is an internal package containing code and definitions common to the
+packages [package nameserv] and [package nameserv::server].
+
+[para]
+
+All packages use the [package uevent] package for the reporting of
+special circumstances via events, and reserve the uevent-tag
+[term nameserv] for their exclusive use. All their events will be
+posted to that tag.
+
+[section Internals]
+
+The document [term {Name service facility, client/server protocol}]
+specifies the protocol used by the packages [package nameserv] and
+[package nameserv::server] to talk to each other. It is of no interest
+to users of either the packages or applications.
+
+[para]
+
+Developers wishing to modify and/or extend or to just understand the
+internals of the nameservice facility however are strongly advised to
+read it.
+
+[vset CATEGORY nameserv]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/nns/nns_protocol.man b/tcllib/modules/nns/nns_protocol.man
new file mode 100644
index 0000000..968de1f
--- /dev/null
+++ b/tcllib/modules/nns/nns_protocol.man
@@ -0,0 +1,182 @@
+[manpage_begin nameserv::protocol n 0.1]
+[see_also comm_wire(n)]
+[see_also nameserv(n)]
+[see_also nameserv::server(n)]
+[keywords comm]
+[keywords {name service}]
+[keywords protocol]
+[copyright {2007-2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Name service facility}]
+[titledesc {Name service facility, client/server protocol}]
+[category Networking]
+[description]
+
+The packages [package nameserv::server], [package nameserv], and
+[package nameserv::common] provide a simple unprotected name service
+facility for use in small trusted environments.
+
+[para]
+
+Please read [term {Name service facility, introduction}] first.
+
+[para]
+
+This document contains the specification of the network protocol which
+is used by client and server to talk to each other, enabling
+implementations of the same protocol in other languages.
+
+[section {Nano Name Service Protocol Version 1}]
+
+This protocol defines the basic set of messages to be supported by a
+name service, also called the [term Core] feature.
+
+[subsection {Basic Layer}]
+
+The basic communication between client and server is done using the
+remote-execution protocol specified by the Tcl package [package comm].
+The relevant document specifying its on-the-wire protocol can be found
+in [term comm_wire].
+
+[para]
+
+All the scripts exchanged via this protocol are single commands in
+list form and thus can be interpreted as plain messages instead of as
+Tcl commands. The commands/messages specified in the next section are
+the only commands understood by the server-side. Command and variable
+substitutions are not allowed within the messages, i.e. arguments have
+to be literal values.
+
+[para]
+
+The protocol is synchronous. I.e. for each message sent a response is
+expected, and has to be generated. All messages are sent by the client.
+The server does not sent messages, only responses to messages.
+
+[subsection {Message Layer}]
+
+[list_begin definitions]
+
+[call [method Bind] [arg name] [arg data]]
+
+The client sends this message when it registers itself at the service
+with a [arg name] and some associated [arg data]. The server has to
+send an error response if the [arg name] is already in use. Otherwise
+the response has to be an empty string.
+
+[para]
+
+The server has to accept multiple names for the same client.
+
+[call [method Release]]
+
+The client sends this message to unregister all names it is known
+under at the service. The response has to be an empty string, always.
+
+[call [method Search] [arg pattern]]
+
+The client sends this message to search the service for names matching
+the glob-[arg pattern]. The response has to be a dictionary containing
+the matching names as keys, and mapping them to the data associated
+with it at [method Bind]-time.
+
+[call [method ProtocolVersion]]
+
+The client sends this message to query the service for the highest
+version of the name service protocol it supports. The response has to
+be a positive integer number.
+
+[para]
+
+Servers supporting only [term {Nano Name Service Protocol Version 1}]
+have to return [const 1].
+
+[call [method ProtocolFeatures]]
+
+The client sends this message to query the service for the features of
+the name service protocol it supports. The response has to be a
+list containing feature names.
+
+[para]
+
+Servers supporting only [term {Nano Name Service Protocol Version 1}]
+have to return [const {{Core}}].
+
+[list_end]
+
+[section {Nano Name Service Protocol Extension: Continuous Search}]
+
+This protocol defines an extended set of messages to be supported by a
+name service, also called the [term Search/Continuous] feature. This
+feature defines additional messages between client and server, and is
+otherwise identical to version 1 of the protocol. See the last section
+for the details of our foundation.
+
+[para]
+
+A service supporting this feature has to put the feature name
+[const Search/Continuous] into the list of features returned by the
+message [term ProtocolFeatures].
+
+[para]
+
+For this extension the protocol is asynchronous. No direct response is
+expected for any of the messages in the extension. Furthermore the
+server will start sending messages on its own, instead of only
+responses to messages, and the client has to be able to handle these
+notifications.
+
+[list_begin definitions]
+
+[call [method Search/Continuous/Start] [arg tag] [arg pattern]]
+
+The client sends this message to start searching the service for names
+matching the glob-[arg pattern].
+
+In contrast to the regular [term Search] request this one asks the
+server to continuously monitor the database for the addition and
+removal of matching entries and to notify the client of all such
+changes. The particular search is identified by the [arg tag].
+
+[para]
+
+No direct response is expected, rather the clients expect to be
+notified of changes via explicit [term Search/Continuous/Result]
+messages generated by the service.
+
+[para]
+
+It is further expected that the [arg tag] information is passed
+unchanged to the [term Search/Continuous/Result] messages. This
+tagging of the results enables clients to start multiple searches and
+distinguish between the different results.
+
+[call [method Search/Continuous/Stop] [arg tag]]
+
+The client sends this message to stop the continuous search identified
+by the [arg tag].
+
+[call [method Search/Continuous/Change] [arg tag] [method add]|[method remove] [arg response]]
+
+This message is sent by the service to clients with active continuous
+searches to transfer found changes. The first such message for a new
+continuous search has to contains the current set of matching entries.
+
+[para]
+
+To ensure this a service has to generate an [method add]-message with
+an empty [arg response] if there were no matching entries at the time.
+
+[para]
+
+The [arg response] has to be a dictionary containing the matching
+names as keys, and mapping them to the data associated with it at
+[method Bind]-time.
+
+The argument coming before the response tells the client whether the
+names in the response were added or removed from the service.
+
+[list_end]
+
+[vset CATEGORY nameserv]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/nns/nns_server.man b/tcllib/modules/nns/nns_server.man
new file mode 100644
index 0000000..b62ec61
--- /dev/null
+++ b/tcllib/modules/nns/nns_server.man
@@ -0,0 +1,145 @@
+[manpage_begin nameserv::server n 0.3.2]
+[see_also nameserv::client(n)]
+[see_also nameserv::common(n)]
+[keywords {name service}]
+[keywords server]
+[copyright {2007-2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Name service facility}]
+[titledesc {Name service facility, Server}]
+[category Networking]
+[require Tcl 8.4]
+[require nameserv::server [opt 0.3.2]]
+[require comm]
+[require interp]
+[require logger]
+[description]
+
+Please read [term {Name service facility, introduction}] first.
+
+[para]
+
+This package provides an implementation of the serviver side of the
+name service facility queried by the client provided by the package
+[package nameserv]. All information required by the server will be
+held in memory. There is no persistent state.
+
+[para]
+
+This service is built in top of and for the package [package comm].
+It has nothing to do with the Internet's Domain Name System. If the
+reader is looking for a package dealing with that please see Tcllib's
+packages [package dns] and [package resolv].
+
+[para]
+
+This server supports the [term Core] protocol feature, and since
+version 0.3 the [term Search/Continuous] feature as well.
+
+[section API]
+
+The package exports five commands, as specified below:
+
+[list_begin definitions]
+
+[call [cmd ::nameserv::server::start]]
+
+This command starts the server and causes it to listen on the
+configured port. From now on clients are able to connect and make
+requests. The result of the command is the empty string.
+
+[para]
+
+Note that any incoming requests will only be handled if the
+application the server is part of does enter an event loop after this
+command has been run.
+
+[call [cmd ::nameserv::server::stop]]
+
+Invoking this command stops the server and releases all information it
+had. Existing connections are shut down, and no new connections will
+be accepted any longer. The result of the command is the empty string.
+
+[call [cmd ::nameserv::server::active?]]
+
+This command returns a boolean value indicating the state of the
+server. The result will be [const true] if the server is active,
+i.e. has been started, and [const false] otherwise.
+
+[call [cmd ::nameserv::server::cget] [option -option]]
+
+This command returns the currently configured value for the specified
+[option -option]. The list of supported options and their meaning can
+be found in section [sectref OPTIONS].
+
+[call [cmd ::nameserv::server::configure]]
+
+In this form the command returns a dictionary of all supported
+options, and their current values. The list of supported options and
+their meaning can be found in section [sectref OPTIONS].
+
+[call [cmd ::nameserv::server::configure] [option -option]]
+
+In this form the command is an alias for
+"[cmd ::nameserv::server::cget] [option -option]]".
+
+The list of supported options and their meaning can be found in
+section [sectref OPTIONS].
+
+[call [cmd ::nameserv::server::configure] "[option -option] [arg value]..."]
+
+In this form the command is used to configure one or more of the
+supported options. At least one option has to be specified, and each
+option is followed by its new value.
+
+The list of supported options and their meaning can be found in
+section [sectref OPTIONS].
+
+[para]
+
+This form can be used only if the server is not active, i.e. has not
+been started yet, or has been stopped. While the server is active it
+cannot be reconfigured.
+
+[list_end]
+
+[section OPTIONS]
+
+The options supported by the server are for the specification of the
+TCP port to listen on, and whether to accept non-local connections or
+not.
+
+They are:
+
+[list_begin options]
+[opt_def -localonly [arg bool]]
+
+This option specifies whether to accept only local connections
+(-localonly 1) or remote connections as well (-localonly 0). The
+default is to accept only local connections.
+
+[opt_def -port [arg number]]
+
+This option specifies the port the name service will listen on after
+it has been started. It has to be a positive integer number (> 0) not
+greater than 65536 (unsigned short). The initial default is the number
+returned by the command [cmd ::nameserv::server::common::port], as
+provided by the package [package ::nameserv::server::common].
+
+[list_end]
+
+[section HISTORY]
+[list_begin definitions]
+[def 0.3]
+Extended the server with the ability to perform asynchronous and
+continuous searches.
+
+[def 0.2]
+Changed name of -local switch to -localonly.
+
+[def 0.1]
+Initial implementation of the server.
+[list_end]
+
+[vset CATEGORY nameserv]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/nns/pkgIndex.tcl b/tcllib/modules/nns/pkgIndex.tcl
new file mode 100644
index 0000000..e51fba5
--- /dev/null
+++ b/tcllib/modules/nns/pkgIndex.tcl
@@ -0,0 +1,10 @@
+if {![package vsatisfies [package provide Tcl] 8]} {return}
+package ifneeded nameserv::common 0.1 [list source [file join $dir common.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded nameserv 0.4.2 [list source [file join $dir nns.tcl]]
+package ifneeded nameserv::server 0.3.2 [list source [file join $dir server.tcl]]
+package ifneeded nameserv::auto 0.3 [list source [file join $dir nns_auto.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+package ifneeded nameserv::cluster 0.2.3 [list source [file join $dir nns_cluster.tcl]]
diff --git a/tcllib/modules/nns/server.tcl b/tcllib/modules/nns/server.tcl
new file mode 100644
index 0000000..54ee688
--- /dev/null
+++ b/tcllib/modules/nns/server.tcl
@@ -0,0 +1,385 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Name Service - Server (Singleton)
+
+# ### ### ### ######### ######### #########
+## Requirements
+
+package require Tcl 8.4
+package require comm ; # Generic message transport
+package require interp ; # Interpreter helpers.
+package require logger ; # Tracing internal activity
+package require nameserv::common ; # Common/shared utilities
+
+namespace eval ::nameserv::server {}
+
+# ### ### ### ######### ######### #########
+## API: Start, Stop
+
+proc ::nameserv::server::start {} {
+ variable comm
+ variable port
+ variable localonly
+
+ log::debug "start"
+ if {$comm ne ""} return
+
+ log::debug "start /granted"
+
+ set interp [interp::createEmpty]
+ foreach msg {
+ Bind
+ Release
+ Search
+ Search/Continuous/Start
+ Search/Continuous/Stop
+ ProtocolVersion
+ ProtocolFeatures
+ } {
+ interp alias $interp $msg {} ::nameserv::server::$msg
+ }
+
+ set comm [comm::comm new ::nameserv::server::COMM \
+ -interp $interp \
+ -port $port \
+ -listen 1 \
+ -local $localonly]
+
+ $comm hook lost ::nameserv::server::LOST
+
+ log::debug "UP @$port local-only $localonly"
+ return
+}
+
+proc ::nameserv::server::stop {} {
+ variable comm
+ variable names
+ variable data
+
+ log::debug "stop"
+ if {$comm eq ""} return
+
+ log::debug "stop /granted"
+
+ # This kills all existing connection and destroys the configured
+ # -interp as well.
+
+ $comm destroy
+ set comm ""
+
+ array unset names *
+ array unset data *
+
+ log::debug "DOWN"
+ return
+}
+
+proc ::nameserv::server::active? {} {
+ variable comm
+ return [expr {$comm ne ""}]
+}
+
+# ### ### ### ######### ######### #########
+## INT: Protocol operations
+
+proc ::nameserv::server::ProtocolVersion {} {return 1}
+proc ::nameserv::server::ProtocolFeatures {} {return {Core Search/Continuous}}
+
+proc ::nameserv::server::Bind {name cdata} {
+ variable comm
+ variable names
+ variable data
+
+ set id [$comm remoteid]
+
+ log::debug "bind ([list $name -> $cdata]), for $id"
+
+ if {[info exists data($name)]} {
+ log::debug "bind failed, \"$name\" is already bound"
+ return -code error "Name \"$name\" is already bound"
+ }
+
+ lappend names($id) $name
+ set data($name) $cdata
+
+ Search/Continuous/NotifyAdd $name $cdata
+ return
+}
+
+proc ::nameserv::server::Release {} {
+ variable comm
+ ReleaseId [$comm remoteid]
+ return
+}
+
+proc ::nameserv::server::Search {pattern} {
+ variable data
+ return [array get data $pattern]
+}
+
+proc ::nameserv::server::ReleaseId {id} {
+ variable names
+ variable data
+ variable searchi
+
+ log::debug "release id $id"
+
+ # Two steps. Release all searches the client may have open, then
+ # all names it may have bound. That last step may trigger
+ # notifications for searches by other clients. It must not trigger
+ # searches from the client just going away, hence their release
+ # first.
+
+ foreach k [array names searchi [list $id *]] {
+ Search/Release $k
+ }
+
+ if {[info exists names($id)]} {
+ set gone {}
+ foreach n $names($id) {
+ lappend gone $n $data($n)
+ catch {unset data($n)}
+
+ log::debug "release name <$n>"
+ }
+ unset names($id)
+
+ Search/Continuous/NotifyRelease $gone
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Support for continuous and async searches
+
+proc ::nameserv::server::Search/Continuous/Start {tag pattern} {
+ variable data
+ variable searchi
+ variable searchp
+ variable comm
+
+ set id [$comm remoteid]
+
+ # Register the search, then generate the initial response.
+ # Non-unique tags are silently discarded. Clients will wait
+ # forever.
+
+ set k [list $id $tag]
+
+ log::debug "search <$k>"
+
+ if {[info exists searchi($k)]} {
+ log::debug "search already known"
+ return
+ }
+
+ log::debug "search added"
+
+ set searchi($k) $pattern
+ lappend searchp($pattern) $k
+
+ $comm send -async $id [list Search/Continuous/Change \
+ $tag add [array get data $pattern]]
+ return
+}
+
+proc ::nameserv::server::Search/Continuous/Stop {tag} {
+ Search/Release [list [$comm remoteid] $tag]
+ return
+}
+
+proc ::nameserv::server::Search/Release {k} {
+ variable searchi
+ variable searchp
+
+ # Remove search information from the data store
+
+ if {![info exists searchi($k)]} return
+
+ log::debug "release search <$k>"
+
+ set pattern $searchi($k)
+ unset searchi($k)
+
+ set pos [lsearch -exact $searchp($pattern) $k]
+ if {$pos < 0} return
+ set new [lreplace $searchp($pattern) $pos $pos]
+ if {[llength $new]} {
+ # Shorten the callback list.
+ set searchp($pattern) $new
+ } else {
+ # Nothing monitors that pattern anymore, remove it completely.
+ unset searchp($pattern)
+ }
+ return
+}
+
+proc ::nameserv::server::Search/Continuous/NotifyAdd {name val} {
+ variable searchp
+
+ # Abort quickly if there are no searches waiting.
+ if {![array size searchp]} return
+
+ foreach p [array names searchp] {
+ if {![string match $p $name]} continue
+ Notify $p add [list $name $val]
+ }
+ return
+}
+
+proc ::nameserv::server::Search/Continuous/NotifyRelease {gone} {
+ variable searchp
+
+ # Abort quickly if there are no searches waiting.
+ if {![array size searchp]} return
+
+ array set m $gone
+ foreach p [array names searchp] {
+ set response [array get m $p]
+ if {![llength $response]} continue
+ Notify $p remove $response
+ }
+ return
+}
+
+proc ::nameserv::server::Notify {p type response} {
+ variable searchp
+ variable comm
+
+ foreach item $searchp($p) {
+ foreach {id tag} $item break
+ $comm send -async $id \
+ [list Search/Continuous/Change $tag $type $response]
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Initialization - In-memory database
+
+namespace eval ::nameserv::server {
+ # Database
+ # search = list (id tag) : Searches are identified by client and a tag.
+ #
+ # array (id -> list (name)) : Names under which a connection is known.
+ # array (name -> data) : Data associated with a name.
+ #
+ # array (pattern -> list (search)) : Per pattern the list of searches using it.
+ # array (search -> pattern) : Pattern per active search.
+ #
+ # searchp <~~> names
+ # searchi <~~> data
+
+ variable names ; array set names {}
+ variable data ; array set data {}
+ variable searchp ; array set searchp {}
+ variable searchi ; array set searchi {}
+}
+
+# ### ### ### ######### ######### #########
+## INT: Connection management
+
+proc ::nameserv::server::LOST {args} {
+ # Currently just to see when a client goes away.
+
+ upvar 1 id id chan chan reason reason
+ ReleaseId $id
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Initialization - System state
+
+namespace eval ::nameserv::server {
+ # Object command of the communication channel of the server.
+ # If present re-configuration is not possible.
+
+ variable comm {}
+}
+
+# ### ### ### ######### ######### #########
+## API: Configuration management (host, port)
+
+proc ::nameserv::server::cget {option} {
+ return [configure $option]
+}
+
+proc ::nameserv::server::configure {args} {
+ variable localonly
+ variable port
+ variable comm
+
+ if {![llength $args]} {
+ return [list -localonly $localonly -port $port]
+ }
+ if {[llength $args] == 1} {
+ # cget
+ set opt [lindex $args 0]
+ switch -exact -- $opt {
+ -localonly { return $localonly }
+ -port { return $port }
+ default {
+ return -code error "bad option \"$opt\", expected -localonly, or -port"
+ }
+ }
+ }
+
+ # Note: Should -port be made configurable after communication has
+ # started it might be necessary to provide code to re-initialize
+ # the connections to all known clients using the new
+ # configuration.
+
+ while {[llength $args]} {
+ set opt [lindex $args 0]
+ switch -exact -- $opt {
+ -localonly {
+ if {[llength $args] < 2} {
+ return -code error "value for \"$opt\" is missing"
+ }
+ # Todo: Check boolean
+ set new [lindex $args 1]
+ set args [lrange $args 2 end]
+
+ if {$new == $localonly} continue
+ set localonly $new
+ if {$comm eq ""} continue
+ $comm configure -local $localonly
+ }
+ -port {
+ if {$comm ne ""} {
+ return -code error "Unable to configure an active server"
+ }
+ if {[llength $args] < 2} {
+ return -code error "value for \"$opt\" is missing"
+ }
+ # Todo: Check non-zero unsigned short integer
+ set port [lindex $args 1]
+ set args [lrange $args 2 end]
+ }
+ default {
+ return -code error "bad option \"$opt\", expected -localonly, or -port"
+ }
+ }
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Initialization - Tracing, Configuration
+
+logger::initNamespace ::nameserv::server
+namespace eval ::nameserv::server {
+ # Port the server will listen on, and boolean flag determining
+ # acceptance of non-local connections.
+
+ variable port [nameserv::common::port]
+ variable localonly 1
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide nameserv::server 0.3.2
+
+##
+# ### ### ### ######### ######### #########
diff --git a/tcllib/modules/nntp/ChangeLog b/tcllib/modules/nntp/ChangeLog
new file mode 100644
index 0000000..29fcc8b
--- /dev/null
+++ b/tcllib/modules/nntp/ChangeLog
@@ -0,0 +1,154 @@
+2013-03-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * rfc977.txt: Removed copies of RFC documents. Keep only links.
+
+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-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>
+
+ * nntp.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 ========================
+ *
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * nntp.man:
+ * nntp.tcl:
+ * pkgIndex.tcl: Set version of the package to to 0.2.1
+
+2003-02-24 David N. Welton <davidw@dedasys.com>
+
+ * nntp.tcl (::nntp::squirt): Use if, string match instead of
+ regsub.
+
+2003-02-06 David N. Welton <davidw@dedasys.com>
+
+ * nntp.tcl (::nntp::fetch): Use 'string match' instead of regexp.
+ Use if string match ... string range instead of regsub (it's
+ about twice as fast in a small test I ran).
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * nntp.man: More semantic markup, less visual one.
+
+2002-08-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * nntp.man: Added example, updated reference from rfc 850 to rfc
+ 1036. See Tcllib SF #597102, by Jussi Kuosa
+ <Jussi.Kuosa@tellabs.com>.
+ * nntp.n: Out of date. Deprecated.
+
+2002-03-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * nntp.man: New file, doctools manpage.
+
+2002-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bumped version to 0.2
+
+2002-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * nntp.tcl: Fixed bug #502250 reported by Andreas Otto
+ <aotto@t-online.de> which caused the package to wrap each
+ message into braces, causing nntp servers to reject the data.
+
+2001-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * nntp.tcl: Frink 2.2 run, fixed dubious code.
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * nntp.tcl: Fixed dubious code reported by frink.
+
+2000-06-20 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * Code cleanup and bug fixes
+
+2000-06-18 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * Fixed documentation bug in man page for xpat
+
+2000-06-16 Dan Kuchler <kuchler@ajubasolutions.com>
+
+ * rfc977.txt: RFC for NNTP
+
+ * pkgIndex.tcl
+ * nntp.tcl: Initial implementation of a nntp client package.
+
+ * nntp.n: Initial documentation for the package.
+
diff --git a/tcllib/modules/nntp/nntp.man b/tcllib/modules/nntp/nntp.man
new file mode 100644
index 0000000..8b06ec4
--- /dev/null
+++ b/tcllib/modules/nntp/nntp.man
@@ -0,0 +1,338 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin nntp n 1.5.1]
+[keywords news]
+[keywords nntp]
+[keywords nntpclient]
+[keywords {rfc 977}]
+[keywords {rfc 1036}]
+[moddesc {Tcl NNTP Client Library}]
+[titledesc {Tcl client for the NNTP protocol}]
+[category Networking]
+[require Tcl 8.2]
+[require nntp [opt 0.2.1]]
+[description]
+
+The package [package nntp] provides a simple Tcl-only client library
+for the NNTP protocol. It works by opening the standard NNTP socket
+on the server, and then providing a Tcl API to access the NNTP
+protocol commands. All server errors are returned as Tcl errors
+(thrown) which must be caught with the Tcl [cmd catch] command.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::nntp::nntp] [opt [arg host]] [opt [arg port]] [opt [arg nntpName]]]
+
+The command opens a socket connection to the specified NNTP server and
+creates a new nntp object with an associated global Tcl command whose
+name is [arg nntpName]. This command may be used to access the various
+NNTP protocol commands for the new connection. The default [arg port]
+number is "119" and the default [arg host] is "news". These defaults
+can be overridden with the environment variables [var NNTPPORT] and
+[var NNTPHOST] respectively.
+
+[para]
+
+Some of the commands supported by this package are not part of the
+nntp rfc 977 ([uri http://www.rfc-editor.org/rfc/rfc977.txt]) and will
+not be available (or implemented) on all nntp servers.
+
+[para]
+
+The access command [arg nntpName] has the following general form:
+
+[list_begin definitions]
+
+[call [arg nntpName] [method method] [opt [arg "arg arg ..."]]]
+
+[arg Option] and the [arg arg]s determine the exact behavior of the
+command.
+
+[list_end]
+
+[call [arg nntpName] [method article] [opt [arg msgid]]]
+
+Query the server for article [arg msgid] from the current group. The article
+is returned as a valid tcl list which contains the headers, followed by
+a blank line, and then followed by the body of the article. Each element
+in the list is one line of the article.
+
+[call [arg nntpName] [method authinfo] [opt [arg user]] [opt [arg pass]]]
+
+Send authentication information (username and password) to the server.
+
+[call [arg nntpName] [method body] [opt [arg msgid]]]
+
+Query the server for the body of the article [arg msgid] from the current
+group. The body of the article is returned as a valid tcl list. Each element
+in the list is one line of the body of the article.
+
+[call [arg nntpName] [method configure]]
+[call [arg nntpName] [method configure] [arg option]]
+[call [arg nntpName] [method configure] [arg option] [arg value] ...]
+[call [arg nntpName] [method cget] [arg option]]
+
+Query and configure options of the nntp connection object. Currently
+only one option is supported, [option -binary]. When set articles are
+retrieved as binary data instead of text. The only methods affected by
+this are [method article] and [method body].
+
+[para]
+
+One application of this option would be the download of articles
+containing yEnc encoded images. Although encoded the data is still
+mostly binary and retrieving it as text will corrupt the information.
+
+[para]
+
+See package [package yencode] for both encoder and decoder of such data.
+
+[call [arg nntpName] [method date]]
+
+Query the server for the servers current date. The date is returned in the
+format [emph YYYYMMDDHHMMSS].
+
+[call [arg nntpName] [method group] [opt [arg group]]]
+
+Optionally set the current group, and retrieve information about the
+currently selected group. Returns the estimated number of articles in
+the group followed by the number of the first article in the group, followed
+by the last article in the group, followed by the name of the group.
+
+[call [arg nntpName] [method head] [opt [arg msgid]]]
+
+Query the server for the headers of the article [arg msgid] from the current
+group. The headers of the article are returned as a valid tcl list. Each element
+in the list is one line of the headers of the article.
+
+[call [arg nntpName] [method help]]
+
+Retrieves a list of the commands that are supported by the news server that
+is currently attached to.
+
+[call [arg nntpName] [method last]]
+
+Sets the current article pointer to point to the previous message (if there is
+one) and returns the msgid of that message.
+
+[call [arg nntpName] [method list]]
+
+Returns a tcl list of valid newsgroups and associated information. Each
+newsgroup is returned as an element in the tcl list with the following format:
+[example {
+ group last first p
+}]
+where <group> is the name of the newsgroup, <last> is the number of
+the last known article currently in that newsgroup, <first> is the
+number of the first article currently in the newsgroup, and <p> is
+either 'y' or 'n' indicating whether posting to this newsgroup is
+allowed ('y') or prohibited ('n').
+[para]
+The <first> and <last> fields will always be numeric. They may have
+leading zeros. If the <last> field evaluates to less than the
+<first> field, there are no articles currently on file in the
+newsgroup.
+
+[call [arg nntpName] [method listgroup] [opt [arg group]]]
+
+Query the server for a list of all the messages (message numbers) in the
+group specified by the argument [arg group] or by the current group if
+the [arg group] argument was not passed.
+
+[call [arg nntpName] [method mode_reader]]
+
+Query the server for its nntp 'MODE READER' response string.
+
+[call [arg nntpName] [method newgroups] [arg since]]
+
+Query the server for a list of all the new newsgroups created since the time
+specified by the argument [arg since]. The argument [arg since] can be any
+time string that is understood by [cmd {clock scan}]. The tcl list of newsgroups
+is returned in a similar form to the list of groups returned by the
+[cmd {nntpName list}] command. Each element of the list has the form:
+
+[example {
+ group last first p
+}]
+where <group> is the name of the newsgroup, <last> is the number of
+the last known article currently in that newsgroup, <first> is the
+number of the first article currently in the newsgroup, and <p> is
+either 'y' or 'n' indicating whether posting to this newsgroup is
+allowed ('y') or prohibited ('n').
+
+[call [arg nntpName] [method newnews]]
+
+Query the server for a list of new articles posted to the current group in the
+last day.
+
+[call [arg nntpName] [method newnews] [arg since]]
+
+Query the server for a list of new articles posted to the current group since
+the time specified by the argument [arg since]. The argument [arg since] can
+be any time string that is understood by [cmd {clock scan}].
+
+[call [arg nntpName] [method newnews] [arg group] [opt [arg since]]]
+
+Query the server for a list of new articles posted to the group specified by
+the argument [arg group] since the time specified by the argument [arg since]
+(or in the past day if no [arg since] argument is passed. The argument
+[arg since] can be any time string that is understood by [cmd {clock scan}].
+
+[call [arg nntpName] [method next]]
+
+Sets the current article pointer to point to the next message (if there is
+one) and returns the msgid of that message.
+
+[call [arg nntpName] [method post] [arg article]]
+
+Posts an article of the form specified in
+RFC 1036 ([uri http://www.rfc-editor.org/rfc/rfc1036.txt], successor
+to RFC 850) to the current news group.
+
+[call [arg nntpName] [method slave]]
+
+Identifies a connection as being made from a slave nntp server. This might
+be used to indicate that the connection is serving multiple people and should
+be given priority. Actual use is entirely implementation dependent and may
+vary from server to server.
+
+[call [arg nntpName] [method stat] [opt [arg msgid]]]
+
+The stat command is similar to the article command except that no
+text is returned. When selecting by message number within a group,
+the stat command serves to set the current article pointer without
+sending text. The returned acknowledgment response will contain the
+message-id, which may be of some value. Using the stat command to
+select by message-id is valid but of questionable value, since a
+selection by message-id does NOT alter the "current article pointer"
+
+[call [arg nntpName] [method quit]]
+
+Gracefully close the connection after sending a NNTP QUIT command down
+the socket.
+
+[call [arg nntpName] [method xgtitle] [opt [arg group_pattern]]]
+
+Returns a tcl list where each element is of the form:
+[example {
+newsgroup description
+}]
+If a [arg group_pattern] is specified then only newsgroups that match
+the pattern will have their name and description returned.
+
+[call [arg nntpName] [method xhdr] [arg field] [opt [arg range]]]
+
+Returns the specified header field value for the current message or for a
+list of messages from the current group. [arg field] is the title of a
+field in the header such as from, subject, date, etc. If [arg range] is
+not specified or is "" then the current message is queried. The command
+returns a list of elements where each element has the form of:
+[example {
+ msgid value
+}]
+Where msgid is the number of the message and value is the value set for the
+queried field. The [arg range] argument can be in any of the following forms:
+
+[list_begin definitions]
+
+[def [const {""}]]
+
+The current message is queried.
+
+[def [arg msgid1]-[arg msgid2]]
+
+All messages between [arg msgid1] and [arg msgid2]
+(including [arg msgid1] and [arg msgid2]) are queried.
+
+[def "[arg msgid1] [arg msgid2]"]
+
+All messages between [arg msgid1] and [arg msgid2]
+(including [arg msgid1] and [arg msgid2]) are queried.
+
+[list_end]
+
+[call [arg nntpName] [method xover] [opt [arg range]]]
+
+Returns header information for the current message or for a range of messages
+from the current group. The information is returned in a tcl list
+where each element is of the form:
+[example {
+ msgid subject from date idstring bodysize headersize xref
+}]
+If [arg range] is not specified or is "" then the current message is queried.
+The [arg range] argument can be in any of the following forms:
+
+[list_begin definitions]
+
+[def [const {""}]]
+
+The current message is queried.
+
+[def [arg msgid1]-[arg msgid2]]
+
+All messages between [arg msgid1] and [arg msgid2]
+(including [arg msgid1] and [arg msgid2]) are queried.
+
+[def "[arg msgid1] [arg msgid2]"]
+
+All messages between [arg msgid1] and [arg msgid2]
+(including [arg msgid1] and [arg msgid2]) are queried.
+
+[list_end]
+
+[call [arg nntpName] [method xpat] [arg field] [arg range] [opt [arg pattern_list]]]
+
+Returns the specified header field value for a specified message or for a
+list of messages from the current group where the messages match the
+pattern(s) given in the pattern_list. [arg field] is the title of a
+field in the header such as from, subject, date, etc. The information is
+returned in a tcl list where each element is of the form:
+[example {
+ msgid value
+}]
+Where msgid is the number of the message and value is the value set for the
+queried field. The [arg range] argument can be in any of the following forms:
+
+[list_begin definitions]
+
+[def [arg msgid]]
+
+The message specified by [arg msgid] is queried.
+
+[def [arg msgid1]-[arg msgid2]]
+
+All messages between [arg msgid1] and [arg msgid2]
+(including [arg msgid1] and [arg msgid2]) are queried.
+
+[def "[arg msgid1] [arg msgid2]"]
+
+All messages between [arg msgid1] and [arg msgid2]
+(including [arg msgid1] and [arg msgid2]) are queried.
+
+[list_end]
+[list_end]
+
+[section EXAMPLE]
+
+A bigger example for posting a single article.
+
+[para]
+[example {
+ package require nntp
+ set n [nntp::nntp NNTP_SERVER]
+ $n post "From: USER@DOMAIN.EXT (USER_FULL)
+ Path: COMPUTERNAME!USERNAME
+ Newsgroups: alt.test
+ Subject: Tcl test post -ignore
+ Message-ID: <[pid][clock seconds]
+ @COMPUTERNAME>
+ Date: [clock format [clock seconds] -format "%a, %d %
+ b %y %H:%M:%S GMT" -gmt true]
+
+ Test message body"
+}]
+
+[vset CATEGORY nntp]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/nntp/nntp.tcl b/tcllib/modules/nntp/nntp.tcl
new file mode 100644
index 0000000..58b1c73
--- /dev/null
+++ b/tcllib/modules/nntp/nntp.tcl
@@ -0,0 +1,979 @@
+# nntp.tcl --
+#
+# nntp implementation for Tcl.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# All rights reserved.
+#
+# RCS: @(#) $Id: nntp.tcl,v 1.13 2004/05/03 22:56:25 andreas_kupries Exp $
+
+package require Tcl 8.2
+package provide nntp 0.2.1
+
+namespace eval ::nntp {
+ # The socks variable holds the handle to the server connections
+ variable socks
+
+ # The counter is used to help create unique connection names
+ variable counter 0
+
+ # commands is the list of subcommands recognized by nntp
+ variable commands [list \
+ "article" \
+ "authinfo" \
+ "body" \
+ "date" \
+ "group" \
+ "head" \
+ "help" \
+ "last" \
+ "list" \
+ "listgroup" \
+ "mode_reader" \
+ "newgroups" \
+ "newnews" \
+ "next" \
+ "post" \
+ "stat" \
+ "quit" \
+ "xgtitle" \
+ "xhdr" \
+ "xover" \
+ "xpat" \
+ ]
+
+ set ::nntp::eol "\n"
+
+ # only export one command, the one used to instantiate a new
+ # nntp connection
+ namespace export nntp
+
+}
+
+# ::nntp::nntp --
+#
+# Create a new nntp connection.
+#
+# Arguments:
+# server - The name of the nntp server to connect to (optional).
+# port - The port number to connect to (optional).
+# name - The name of the nntp connection to create (optional).
+#
+# Results:
+# Creates a connection to the a nntp server. By default the
+# connection is established with the machine 'news' at port '119'
+# These defaults can be overridden with the environment variables
+# NNTPPORT and NNTPHOST, or can be passed as optional arguments
+
+proc ::nntp::nntp {{server ""} {port ""} {name ""}} {
+ global env
+ variable connections
+ variable counter
+ variable socks
+
+ # If a name wasn't specified for the connection, create a new 'unique'
+ # name for the connection
+
+ if { [llength [info level 0]] < 4 } {
+ set counter 0
+ set name "nntp${counter}"
+ while {[lsearch -exact [info commands] $name] >= 0} {
+ incr counter
+ set name "nntp${counter}"
+ }
+ }
+
+ if { ![string equal [info commands ::$name] ""] } {
+ error "command \"$name\" already exists, unable to create nntp connection"
+ }
+
+ upvar 0 ::nntp::${name}data data
+
+ set socks($name) [list ]
+
+ # Initialize instance specific variables
+
+ set data(debug) 0
+ set data(eol) "\n"
+
+ # Logic to determine whether to use the specified nntp server, or to use
+ # the default
+
+ if {$server == ""} {
+ if {[info exists env(NNTPSERVER)]} {
+ set data(host) "$env(NNTPSERVER)"
+ } else {
+ set data(host) "news"
+ }
+ } else {
+ set data(host) $server
+ }
+
+ # Logic to determine whether to use the specified nntp port, or to use the
+ # default.
+
+ if {$port == ""} {
+ if {[info exists env(NNTPPORT)]} {
+ set data(port) $env(NNTPPORT)
+ } else {
+ set data(port) 119
+ }
+ } else {
+ set data(port) $port
+ }
+
+ set data(code) 0
+ set data(mesg) ""
+ set data(addr) ""
+ set data(binary) 0
+
+ set sock [socket $data(host) $data(port)]
+
+ set data(sock) $sock
+
+ # Create the command to manipulate the nntp connection
+
+ interp alias {} ::$name {} ::nntp::NntpProc $name
+
+ ::nntp::response $name
+
+ return $name
+}
+
+# ::nntp::NntpProc --
+#
+# Command that processes all nntp object commands.
+#
+# Arguments:
+# name name of the nntp object to manipulate.
+# args command name and args for the command.
+#
+# Results:
+# Calls the appropriate nntp procedure for the command specified in
+# 'args' and passes 'args' to the command/procedure.
+
+proc ::nntp::NntpProc {name {cmd ""} args} {
+
+ # Do minimal args checks here
+
+ if { [llength [info level 0]] < 3 } {
+ error "wrong # args: should be \"$name option ?arg arg ...?\""
+ }
+
+ # Split the args into command and args components
+
+ if { [llength [info commands ::nntp::_$cmd]] == 0 } {
+ variable commands
+ set optlist [join $commands ", "]
+ set optlist [linsert $optlist "end-1" "or"]
+ error "bad option \"$cmd\": must be $optlist"
+ }
+
+ # Call the appropriate command with its arguments
+
+ return [eval [linsert $args 0 ::nntp::_$cmd $name]]
+}
+
+# ::nntp::okprint --
+#
+# Used to test the return code stored in data(code) to
+# make sure that it is alright to right to the socket.
+#
+# Arguments:
+# name name of the nntp object.
+#
+# Results:
+# Either throws an error describing the failure, or
+# 'args' and passes 'args' to the command/procedure or
+# returns 1 for 'OK' and 0 for error states.
+
+proc ::nntp::okprint {name} {
+ upvar 0 ::nntp::${name}data data
+
+ if {$data(code) >=400} {
+ set val [expr {(0 < $data(code)) && ($data(code) < 400)}]
+ error "NNTPERROR: $data(code) $data(mesg)"
+ }
+
+ # Codes less than 400 are good
+
+ return [expr {(0 < $data(code)) && ($data(code) < 400)}]
+}
+
+# ::nntp::message --
+#
+# Used to format data(mesg) for printing to the socket
+# by appending the appropriate end of line character which
+# is stored in data(eol).
+#
+# Arguments:
+# name name of the nntp object.
+#
+# Results:
+# Returns a string containing the message from data(mesg) followed
+# by the eol character(s) stored in data(eol)
+
+proc ::nntp::message {name} {
+ upvar 0 ::nntp::${name}data data
+
+ return "$data(mesg)$data(eol)"
+}
+
+#################################################
+#
+# NNTP Methods
+#
+
+proc ::nntp::_cget {name option} {
+ upvar 0 ::nntp::${name}data data
+
+ if {[string equal $option -binary]} {
+ return $data(binary)
+ } else {
+ return -code error \
+ "Illegal option \"$option\", expected \"-binary\""
+ }
+}
+
+proc ::nntp::_configure {name args} {
+ upvar 0 ::nntp::${name}data data
+
+ if {[llength $args] == 0} {
+ return [list -binary $data(binary)]
+ }
+ if {[llength $args] == 1} {
+ return [_cget $name [lindex $args 0]]
+ }
+ if {([llength $args] % 2) == 1} {
+ return -code error \
+ "wrong#args: expected even number of elements"
+ }
+ foreach {o v} $args {
+ if {[string equal $o -binary]} {
+ if {![string is boolean -strict $v]} {
+ return -code error \
+ "Expected boolean, got \"$v\""
+ }
+ set data(binary) $v
+ } else {
+ return -code error \
+ "Illegal option \"$o\", expected \"-binary\""
+ }
+ }
+ return {}
+}
+
+
+# ::nntp::_article --
+#
+# Internal article proc. Called by the 'nntpName article' command.
+# Retrieves the article specified by msgid, in the group specified by
+# the 'nntpName group' command. If no msgid is specified the current
+# (or first) article in the group is retrieved
+#
+# Arguments:
+# name name of the nntp object.
+# msgid The article number to retrieve
+#
+# Results:
+# Returns the message (if there is one) from the specified group as
+# a valid tcl list where each element is a line of the message.
+# If no article is found, the "" string is returned.
+#
+# According to RFC 977 the responses are:
+#
+# 220 n article retrieved - head and body follow
+# (n = article number, = message-id)
+# 221 n article retrieved - head follows
+# 222 n article retrieved - body follows
+# 223 n article retrieved - request text separately
+# 412 no newsgroup has been selected
+# 420 no current article has been selected
+# 423 no such article number in this group
+# 430 no such article found
+#
+
+proc ::nntp::_article {name {msgid ""}} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) "fetch"
+ return [::nntp::command $name "ARTICLE $msgid"]
+}
+
+# ::nntp::_authinfo --
+#
+# Internal authinfo proc. Called by the 'nntpName authinfo' command.
+# Passes the username and password for a nntp server to the nntp server.
+#
+# Arguments:
+# name Name of the nntp object.
+# user The username for the nntp server.
+# pass The password for 'username' on the nntp server.
+#
+# Results:
+# Returns the result of the attempts to set the username and password
+# on the nntp server ( 1 if successful, 0 if failed).
+
+proc ::nntp::_authinfo {name {user "guest"} {pass "foobar"}} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) ""
+ set res [::nntp::command $name "AUTHINFO USER $user"]
+ if {$res} {
+ set res [expr {$res && [::nntp::command $name "AUTHINFO PASS $pass"]}]
+ }
+ return $res
+}
+
+# ::nntp::_body --
+#
+# Internal body proc. Called by the 'nntpName body' command.
+# Retrieves the body of the article specified by msgid from the group
+# specified by the 'nntpName group' command. If no msgid is specified
+# the current (or first) message body is returned
+#
+# Arguments:
+# name Name of the nntp object.
+# msgid The number of the body of the article to retrieve
+#
+# Results:
+# Returns the body of article 'msgid' from the group specified through
+# 'nntpName group'. If msgid is not specified or is "" then the body of
+# the current (or the first) article in the newsgroup will be returned
+# as a valid tcl list. The "" string will be returned if there is no
+# article 'msgid' or if no group has been specified.
+
+proc ::nntp::_body {name {msgid ""}} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) "fetch"
+ return [::nntp::command $name "BODY $msgid"]
+}
+
+# ::nntp::_group --
+#
+# Internal group proc. Called by the 'nntpName group' command.
+# Sets the current group on the nntp server to the group passed in.
+#
+# Arguments:
+# name Name of the nntp object.
+# group The name of the group to set as the default group.
+#
+# Results:
+# Sets the default group to the group specified. If no group is specified
+# or if an invalid group is specified an error is thrown.
+#
+# According to RFC 977 the responses are:
+#
+# 211 n f l s group selected
+# (n = estimated number of articles in group,
+# f = first article number in the group,
+# l = last article number in the group,
+# s = name of the group.)
+# 411 no such news group
+
+proc ::nntp::_group {name {group ""}} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) "groupinfo"
+ if {$group == ""} {
+ set group $data(group)
+ }
+ return [::nntp::command $name "GROUP $group"]
+}
+
+# ::nntp::_head --
+#
+# Internal head proc. Called by the 'nntpName head' command.
+# Retrieves the header of the article specified by msgid from the group
+# specified by the 'nntpName group' command. If no msgid is specified
+# the current (or first) message header is returned
+#
+# Arguments:
+# name Name of the nntp object.
+# msgid The number of the header of the article to retrieve
+#
+# Results:
+# Returns the header of article 'msgid' from the group specified through
+# 'nntpName group'. If msgid is not specified or is "" then the header of
+# the current (or the first) article in the newsgroup will be returned
+# as a valid tcl list. The "" string will be returned if there is no
+# article 'msgid' or if no group has been specified.
+
+proc ::nntp::_head {name {msgid ""}} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) "fetch"
+ return [::nntp::command $name "HEAD $msgid"]
+}
+
+# ::nntp::_help --
+#
+# Internal help proc. Called by the 'nntpName help' command.
+# Retrieves a list of the valid nntp commands accepted by the server.
+#
+# Arguments:
+# name Name of the nntp object.
+#
+# Results:
+# Returns the NNTP commands expected by the NNTP server.
+
+proc ::nntp::_help {name} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) "fetch"
+ return [::nntp::command $name "HELP"]
+}
+
+proc ::nntp::_ihave {name {msgid ""} args} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) "fetch"
+ if {![::nntp::command $name "IHAVE $msgid"]} {
+ return ""
+ }
+ return [::nntp::squirt $name "$args"]
+}
+
+# ::nntp::_last --
+#
+# Internal last proc. Called by the 'nntpName last' command.
+# Sets the current message to the message before the current message.
+#
+# Arguments:
+# name Name of the nntp object.
+#
+# Results:
+# None.
+
+proc ::nntp::_last {name} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) "msgid"
+ return [::nntp::command $name "LAST"]
+}
+
+# ::nntp::_list --
+#
+# Internal list proc. Called by the 'nntpName list' command.
+# Lists all groups or (optionally) all groups of a specified type.
+#
+# Arguments:
+# name Name of the nntp object.
+# Type The type of groups to return (active active.times newsgroups
+# distributions distrib.pats moderators overview.fmt
+# subscriptions) - optional.
+#
+# Results:
+# Returns a tcl list of all groups or the groups that match 'type' if
+# a type is specified.
+
+proc ::nntp::_list {name {type ""}} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) "fetch"
+ return [::nntp::command $name "LIST $type"]
+}
+
+# ::nntp::_newgroups --
+#
+# Internal newgroups proc. Called by the 'nntpName newgroups' command.
+# Lists all new groups since a specified time.
+#
+# Arguments:
+# name Name of the nntp object.
+# since The time to find new groups since. The time can be in any
+# format that is accepted by 'clock scan' in tcl.
+#
+# Results:
+# Returns a tcl list of all new groups added since the time specified.
+
+proc ::nntp::_newgroups {name since args} {
+ upvar 0 ::nntp::${name}data data
+
+ set since [clock format [clock scan "$since"] -format "%y%m%d %H%M%S"]
+ set dist ""
+ set data(cmnd) "fetch"
+ return [::nntp::command $name "NEWGROUPS $since $dist"]
+}
+
+# ::nntp::_newnews --
+#
+# Internal newnews proc. Called by the 'nntpName newnews' command.
+# Lists all new news in the specified group since a specified time.
+#
+# Arguments:
+# name Name of the nntp object.
+# group Name of the newsgroup to query.
+# since The time to find new groups since. The time can be in any
+# format that is accepted by 'clock scan' in tcl. Defaults to
+# "1 day ago"
+#
+# Results:
+# Returns a tcl list of all new messages since the time specified.
+
+proc ::nntp::_newnews {name {group ""} {since ""}} {
+ upvar 0 ::nntp::${name}data data
+
+ if {$group != ""} {
+ if {[regexp -- {^[\w\.\-]+$} $group] == 0} {
+ set since $group
+ set group ""
+ }
+ }
+ if {![info exists group] || ($group == "")} {
+ if {[info exists data(group)] && ($data(group) != "")} {
+ set group $data(group)
+ } else {
+ set group "*"
+ }
+ }
+ if {"$since" == ""} {
+ set since [clock format [clock scan "now - 1 day"]]
+ }
+ set since [clock format [clock scan $since] -format "%y%m%d %H%M%S"]
+ set dist ""
+ set data(cmnd) "fetch"
+ return [::nntp::command $name "NEWNEWS $group $since $dist"]
+}
+
+# ::nntp::_next --
+#
+# Internal next proc. Called by the 'nntpName next' command.
+# Sets the current message to the next message after the current message.
+#
+# Arguments:
+# name Name of the nntp object.
+#
+# Results:
+# None.
+
+proc ::nntp::_next {name} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) "msgid"
+ return [::nntp::command $name "NEXT"]
+}
+
+# ::nntp::_post --
+#
+# Internal post proc. Called by the 'nntpName post' command.
+# Posts a message to a newsgroup.
+#
+# Responses (according to RFC 977) to a post request:
+# 240 article posted ok
+# 340 send article to be posted. End with .
+# 440 posting not allowed
+# 441 posting failed
+#
+# Arguments:
+# name Name of the nntp object.
+# article A message of the form specified in RFC 850
+#
+# Results:
+# None.
+
+proc ::nntp::_post {name article} {
+
+ if {![::nntp::command $name "POST"]} {
+ return ""
+ }
+ return [::nntp::squirt $name "$article"]
+}
+
+# ::nntp::_slave --
+#
+# Internal slave proc. Called by the 'nntpName slave' command.
+# Identifies a connection as being made from a slave nntp server.
+# This might be used to indicate that the connection is serving
+# multiple people and should be given priority. Actual use is
+# entirely implementation dependant and may vary from server to
+# server.
+#
+# Arguments:
+# name Name of the nntp object.
+#
+# Results:
+# None.
+#
+# According to RFC 977 the only response is:
+#
+# 202 slave status noted
+
+proc ::nntp::_slave {name} {
+ return [::nntp::command $name "SLAVE"]
+}
+
+# ::nntp::_stat --
+#
+# Internal stat proc. Called by the 'nntpName stat' command.
+# The stat command is similar to the article command except that no
+# text is returned. When selecting by message number within a group,
+# the stat command serves to set the current article pointer without
+# sending text. The returned acknowledgement response will contain the
+# message-id, which may be of some value. Using the stat command to
+# select by message-id is valid but of questionable value, since a
+# selection by message-id does NOT alter the "current article pointer"
+#
+# Arguments:
+# name Name of the nntp object.
+# msgid The number of the message to stat (optional) default is to
+# stat the current article
+#
+# Results:
+# Returns the statistics for the article.
+
+proc ::nntp::_stat {name {msgid ""}} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) "status"
+ return [::nntp::command $name "STAT $msgid"]
+}
+
+# ::nntp::_quit --
+#
+# Internal quit proc. Called by the 'nntpName quit' command.
+# Quits the nntp session and closes the socket. Deletes the command
+# that was created for the connection.
+#
+# Arguments:
+# name Name of the nntp object.
+#
+# Results:
+# Returns the return value from the quit command.
+
+proc ::nntp::_quit {name} {
+ upvar 0 ::nntp::${name}data data
+
+ set ret [::nntp::command $name "QUIT"]
+ close $data(sock)
+ rename ${name} {}
+ return $ret
+}
+
+#############################################################
+#
+# Extended methods (not available on all NNTP servers
+#
+
+proc ::nntp::_date {name} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) "msg"
+ return [::nntp::command $name "DATE"]
+}
+
+proc ::nntp::_listgroup {name {group ""}} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) "fetch"
+ return [::nntp::command $name "LISTGROUP $group"]
+}
+
+proc ::nntp::_mode_reader {name} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) "msg"
+ return [::nntp::command $name "MODE READER"]
+}
+
+proc ::nntp::_xgtitle {name {group_pattern ""}} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) "fetch"
+ return [::nntp::command $name "XGTITLE $group_pattern"]
+}
+
+proc ::nntp::_xhdr {name {header "message-id"} {list ""} {last ""}} {
+ upvar 0 ::nntp::${name}data data
+
+ if {![regexp -- {\d+-\d+} $list]} {
+ if {"$last" != ""} {
+ set list "$list-$last"
+ } else {
+ set list ""
+ }
+ }
+ set data(cmnd) "fetch"
+ return [::nntp::command $name "XHDR $header $list"]
+}
+
+proc ::nntp::_xindex {name {group ""}} {
+ upvar 0 ::nntp::${name}data data
+
+ if {("$group" == "") && [info exists data(group)]} {
+ set group $data(group)
+ }
+ set data(cmnd) "fetch"
+ return [::nntp::command $name "XINDEX $group"]
+}
+
+proc ::nntp::_xmotd {name {since ""}} {
+ upvar 0 ::nntp::${name}data data
+
+ if {"$since" != ""} {
+ set since [clock seconds]
+ }
+ set since [clock format [clock scan $since] -format "%y%m%d %H%M%S"]
+ set data(cmnd) "fetch"
+ return [::nntp::command $name "XMOTD $since"]
+}
+
+proc ::nntp::_xover {name {list ""} {last ""}} {
+ upvar 0 ::nntp::${name}data data
+ if {![regexp -- {\d+-\d+} $list]} {
+ if {"$last" != ""} {
+ set list "$list-$last"
+ } else {
+ set list ""
+ }
+ }
+ set data(cmnd) "fetch"
+ return [::nntp::command $name "XOVER $list"]
+}
+
+proc ::nntp::_xpat {name {header "subject"} {list 1} {last ""} args} {
+ upvar 0 ::nntp::${name}data data
+
+ set patterns ""
+
+ if {![regexp -- {\d+-\d+} $list]} {
+ if {("$last" != "") && ([string is digit $last])} {
+ set list "$list-$last"
+ }
+ } elseif {"$last" != ""} {
+ set patterns "$last"
+ }
+
+ if {[llength $args] > 0} {
+ set patterns "$patterns $args"
+ }
+
+ if {"$patterns" == ""} {
+ set patterns "*"
+ }
+
+ set data(cmnd) "fetch"
+ return [::nntp::command $name "XPAT $header $list $patterns"]
+}
+
+proc ::nntp::_xpath {name {msgid ""}} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(cmnd) "msg"
+ return [::nntp::command $name "XPATH $msgid"]
+}
+
+proc ::nntp::_xsearch {name args} {
+ set res [::nntp::command $name "XSEARCH"]
+ if {!$res} {
+ return ""
+ }
+ return [::nntp::squirt $name "$args"]
+}
+
+proc ::nntp::_xthread {name args} {
+ upvar 0 ::nntp::${name}data data
+
+ if {[llength $args] > 0} {
+ set filename "dbinit"
+ } else {
+ set filename "thread"
+ }
+ set data(cmnd) "fetchbinary"
+ return [::nntp::command $name "XTHREAD $filename"]
+}
+
+######################################################
+#
+# Helper methods
+#
+
+proc ::nntp::cmd {name cmd} {
+ upvar 0 ::nntp::${name}data data
+
+ set eol "\015\012"
+ set sock $data(sock)
+ if {$data(debug)} {
+ puts stderr "$sock command $cmd"
+ }
+ puts $sock "$cmd"
+ flush $sock
+ return
+}
+
+proc ::nntp::command {name args} {
+ set res [eval [linsert $args 0 ::nntp::cmd $name]]
+
+ return [::nntp::response $name]
+}
+
+proc ::nntp::msg {name} {
+ upvar 0 ::nntp::${name}data data
+
+ set res [::nntp::okprint $name]
+ if {!$res} {
+ return ""
+ }
+ return $data(mesg)
+}
+
+proc ::nntp::groupinfo {name} {
+ upvar 0 ::nntp::${name}data data
+
+ set data(group) ""
+
+ if {[::nntp::okprint $name] && [regexp -- {(\d+)\s+(\d+)\s+(\d+)\s+([\w\.]+)} \
+ $data(mesg) match count first last data(group)]} {
+ return [list $count $first $last $data(group)]
+ }
+ return ""
+}
+
+proc ::nntp::msgid {name} {
+ upvar 0 ::nntp::${name}data data
+
+ set result ""
+ if {[::nntp::okprint $name] && \
+ [regsub -- {\s+<[^>]+>} $data(mesg) {} result]} {
+ return $result
+ } else {
+ return ""
+ }
+}
+
+proc ::nntp::status {name} {
+ upvar 0 ::nntp::${name}data data
+
+ set result ""
+ if {[::nntp::okprint $name] && \
+ [regexp -- {\d+\s+<[^>]+>} $data(mesg) result]} {
+ return $result
+ } else {
+ return ""
+ }
+}
+
+proc ::nntp::fetch {name} {
+ upvar 0 ::nntp::${name}data data
+
+ set eol "\012"
+
+ if {![::nntp::okprint $name]} {
+ return ""
+ }
+ set sock $data(sock)
+
+ if {$data(binary)} {
+ set oldenc [fconfigure $sock -encoding]
+ fconfigure $sock -encoding binary
+ }
+
+ set result [list ]
+ while {![eof $sock]} {
+ gets $sock line
+ regsub -- {\015?\012$} $line $data(eol) line
+
+ if {[string match "." $line]} {
+ break
+ }
+ if { [string match "..*" $line] } {
+ lappend result [string range $line 1 end]
+ } else {
+ lappend result $line
+ }
+ }
+
+ if {$data(binary)} {
+ fconfigure $sock -encoding $oldenc
+ }
+
+ return $result
+}
+
+proc ::nntp::response {name} {
+ upvar 0 ::nntp::${name}data data
+
+ set eol "\012"
+
+ set sock $data(sock)
+
+ gets $sock line
+ set data(code) 0
+ set data(mesg) ""
+
+ if {$line == ""} {
+ error "nntp: unexpected EOF on $sock\n"
+ }
+
+ regsub -- {\015?\012$} $line "" line
+
+ set result [regexp -- {^((\d\d)(\d))\s*(.*)} $line match \
+ data(code) val1 val2 data(mesg)]
+
+ if {$result == 0} {
+ puts stderr "nntp garbled response: $line\n";
+ return ""
+ }
+
+ if {$val1 == 20} {
+ set data(post) [expr {!$val2}]
+ }
+
+ if {$data(debug)} {
+ puts stderr "val1 $val1 val2 $val2"
+ puts stderr "code '$data(code)'"
+ puts stderr "mesg '$data(mesg)'"
+ if {[info exists data(post)]} {
+ puts stderr "post '$data(post)'"
+ }
+ }
+
+ return [::nntp::returnval $name]
+}
+
+proc ::nntp::returnval {name} {
+ upvar 0 ::nntp::${name}data data
+
+ if {([info exists data(cmnd)]) \
+ && ($data(cmnd) != "")} {
+ set command $data(cmnd)
+ } else {
+ set command okprint
+ }
+
+ if {$data(debug)} {
+ puts stderr "returnval command '$command'"
+ }
+
+ set data(cmnd) ""
+ return [::nntp::$command $name]
+}
+
+proc ::nntp::squirt {name {body ""}} {
+ upvar 0 ::nntp::${name}data data
+
+ set body [split $body \n]
+
+ if {$data(debug)} {
+ puts stderr "$data(sock) sending [llength $body] lines\n";
+ }
+
+ foreach line $body {
+ # Print each line, possibly prepending a dot for lines
+ # starting with a dot and trimming any trailing \n.
+ if { [string match ".*" $line] } {
+ set line ".$line"
+ }
+ puts $data(sock) $line
+ }
+ puts $data(sock) "."
+ flush $data(sock)
+
+ if {$data(debug)} {
+ puts stderr "$data(sock) is finished sending"
+ }
+ return [::nntp::response $name]
+}
+#eof
+
diff --git a/tcllib/modules/nntp/pkgIndex.tcl b/tcllib/modules/nntp/pkgIndex.tcl
new file mode 100644
index 0000000..ac36bfe
--- /dev/null
+++ b/tcllib/modules/nntp/pkgIndex.tcl
@@ -0,0 +1,12 @@
+# 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.2]} {return}
+package ifneeded nntp 0.2.1 [list source [file join $dir nntp.tcl]]
diff --git a/tcllib/modules/ntp/ChangeLog b/tcllib/modules/ntp/ChangeLog
new file mode 100644
index 0000000..82bd1fa
--- /dev/null
+++ b/tcllib/modules/ntp/ChangeLog
@@ -0,0 +1,201 @@
+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-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>
+
+ * ntp.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-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * ntp_time.man: Bumped version to 1.2.1
+ * time.tcl:
+ * pkgIndex.tcl:
+
+2006-04-20 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: bug #1409219: added missing hyphen.
+
+2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * time.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * time.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-08-26 Andreas Kupries <andreask@activestate.com>
+
+ * time.tcl (::time::unixtime): Fixed the 64bit problems reported
+ in [Tcllib SF Bug 899211] by forcefully restricting results to
+ 32bit (Masking with 0xffffffff).
+
+2005-08-26 Andreas Kupries <andreask@activestate.com>
+
+ * time.test (createServerProcess): Ensure that the actual socket
+ is set to binary transport, not the listening socket. On 64bit
+ machines this can cause the fake server to send more than 4
+ bytes, causing data format errors in the client.
+
+2005-08-26 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: Deal with Andreas Kupries comment in bug #899211.
+ Keep trying to read data until the amount expected for the protocol
+ in use is received.
+ * time.test: Added some real remote using tests (with constraint).
+
+2005-08-11 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: SNTP wasn't working (raised by Donal Fellows).
+ Added support for ceptcl in addition to tcludp. Incremented
+ version.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-08-19 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: Tidied up error messages.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * time.tcl: Updated version number to distinguish
+ * ntp_time.man: from the 1.6.1 release.
+ * pkgIndex.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * time.tcl: Rel. engineering. Updated version number
+ * time.man: of time to reflect its changes, to 1.0.3.
+ * pkgIndex.tcl:
+
+2004-04-30 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: Added support for SNTP (RFC 2030).
+ * ntp_time.man:
+
+2004-02-28 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: Fix the version as 1.0.2
+
+2004-02-26 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: Applied patch #905132 to better handle socket errors.
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2003-05-29 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl: Conform more closely to the RFC in response to
+ bug #744391.
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-05-05 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Resynced package version numbers for this module.
+
+2003-05-02 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl (unixtime): Applied patch from Andreas Kupries to
+ ensure the result is always an integer.
+ * time.test: Make sure the server returns integer values and check
+ the range is valid (rather than just checking for integer).
+
+2003-04-24 Andreas Kupries <andreask@activestate.com>
+
+ * ntp_time.man: Cleanup of RFC referencing.
+
+ * time.tcl (unixtime): [SF Bug #723426] Added code to handle
+ possibility of failure in "binary scan". (ClientReadEvent):
+ Changed to append partial results, allow for empty reads.
+
+ * time.test: [SF Bug #723426]. Corrected non-unique test
+ names. Handle a missing tcltest::interpreter and fall back to
+ [info nameofexecutable].
+
+2003-04-16 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.man: Renamed the man page to avoid clashing with
+ * ntp_time.man: the tcl time.n manual page.
+
+2003-03-20 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.test: Added a test package.
+ * pkgIndex.tcl: Added a package index file.
+
+2003-03-17 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * time.tcl:
+ * time.man: Initial checkin of an RFC 868 client.
+ * examples/ntp/rdate.tcl: A demo using the time package to request
+ the current time from a remote host via tcp or udp.
+
diff --git a/tcllib/modules/ntp/ntp_time.man b/tcllib/modules/ntp/ntp_time.man
new file mode 100644
index 0000000..92a7010
--- /dev/null
+++ b/tcllib/modules/ntp/ntp_time.man
@@ -0,0 +1,131 @@
+[manpage_begin ntp_time n 1.2.1]
+[see_also ntp]
+[keywords NTP]
+[keywords {rfc 868}]
+[keywords {rfc 2030}]
+[keywords SNTP]
+[keywords time]
+[copyright {2002, Pat Thoyts <patthoyts@users.sourceforge.net>}]
+[moddesc {Network Time Facilities}]
+[titledesc {Tcl Time Service Client}]
+[category Networking]
+[require Tcl 8.0]
+[require time [opt 1.2.1]]
+[description]
+[para]
+
+This package implements a client for the RFC 868 TIME protocol
+([uri http://www.rfc-editor.org/rfc/rfc868.txt]) and also a minimal
+client for the RFC 2030 Simple Network Time Protocol
+([uri http://www.rfc-editor.org/rfc/rfc2030.txt]).
+
+RFC 868 returns the time in seconds since 1 January 1900
+to either tcp or udp clients. RFC 2030 also gives this time but also
+provides a fractional part which is not used in this client.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::time::gettime] [opt [arg "options"]] [arg timeserver] [opt [arg "port"]]]
+
+Get the time from [arg timeserver]. You may specify any of the options
+listed for the [cmd configure] command here. This command returns a
+token which must then be used with the remaining commands in this
+package. Once you have finished, you should use [cmd cleanup] to
+release all resources. The default port is [const 37].
+
+[call [cmd ::time::getsntp] [opt [arg "options"]] [arg timeserver] [opt [arg "port"]]]
+
+Get the time from an SNTP server. This accepts exactly the same
+arguments as [cmd ::time::gettime] except that the default port is
+[const 123]. The result is a token as per [cmd ::time::gettime] and
+should be handled in the same way.
+[para]
+Note that it is unlikely that any SNTP server will reply using tcp so
+you will require the [package tcludp] or the [package ceptcl]
+package. If a suitable package can be loaded then the udp protocol
+will be used by default.
+
+[call [cmd ::time::configure] [opt [arg "options"]]]
+
+Called with no arguments this command returns all the current
+configuration options and values. Otherwise it should be called with
+pairs of option name and value.
+
+[list_begin definitions]
+[def "[cmd -protocol] [arg number]"]
+ Set the default network protocol. This defaults to udp if the tcludp
+ package is available. Otherwise it will use tcp.
+[def "[cmd -port] [arg number]"]
+ Set the default port to use. RFC 868 uses port [const 37], RFC 2030 uses
+port [const 123].
+[def "[cmd -timeout] [arg number]"]
+ Set the default timeout value in milliseconds. The default is 10 seconds.
+[def "[cmd -command] [arg number]"]
+ Set a command procedure to be run when a reply is received. The
+ procedure is called with the time token appended to the argument list.
+[def "[cmd -loglevel] [arg number]"]
+ Set the logging level. The default is 'warning'.
+[list_end]
+
+[call [cmd ::time::cget] [arg name]]
+
+Get the current value for the named configuration option.
+
+[call [cmd ::time::unixtime] [arg token]]
+ Format the returned time for the unix epoch. RFC 868 time defines
+ time 0 as 1 Jan 1900, while unix time defines time 0 as 1 Jan
+ 1970. This command converts the reply to unix time.
+
+[call [cmd ::time::status] [arg token]]
+ Returns the status flag. For a successfully completed query this will be
+ [emph ok]. May be [emph error] or [emph timeout] or [emph eof].
+ See also [cmd ::time::error]
+
+[call [cmd ::time::error] [arg token]]
+ Returns the error message provided for requests whose status is [emph error].
+ If there is no error message then an empty string is returned.
+
+[call [cmd ::time::reset] [arg token] [arg [opt reason]]]
+ Reset or cancel the query optionally specfying the reason to record
+ for the [cmd error] command.
+
+[call [cmd ::time::wait] [arg token]]
+ Wait for a query to complete and return the status upon completion.
+
+[call [cmd ::time::cleanup] [arg token]]
+ Remove all state variables associated with the request.
+
+[list_end]
+
+[example {
+% set tok [::time::gettime ntp2a.mcc.ac.uk]
+% set t [::time::unixtime $tok]
+% ::time::cleanup $tok
+}]
+
+[example {
+% set tok [::time::getsntp pool.ntp.org]
+% set t [::time::unixtime $tok]
+% ::time::cleanup $tok
+}]
+
+[example {
+proc on_time {token} {
+ if {[time::status $token] eq "ok"} {
+ puts [clock format [time::unixtime $token]]
+ } else {
+ puts [time::error $token]
+ }
+ time::cleanup $token
+}
+time::getsntp -command on_time pool.ntp.org
+}]
+
+[section AUTHORS]
+Pat Thoyts
+
+[vset CATEGORY ntp]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/ntp/pkgIndex.tcl b/tcllib/modules/ntp/pkgIndex.tcl
new file mode 100644
index 0000000..21a47f4
--- /dev/null
+++ b/tcllib/modules/ntp/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded time 1.2.1 [list source [file join $dir time.tcl]]
diff --git a/tcllib/modules/ntp/time.tcl b/tcllib/modules/ntp/time.tcl
new file mode 100644
index 0000000..3e6d0f2
--- /dev/null
+++ b/tcllib/modules/ntp/time.tcl
@@ -0,0 +1,382 @@
+# time.tcl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Client for the Time protocol. See RFC 868
+# Client for Simple Network Time Protocol - RFC 2030
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.0; # tcl minimum version
+package require log; # tcllib 1.3
+
+namespace eval ::time {
+ namespace export configure gettime server cleanup
+
+ variable options
+ if {![info exists options]} {
+ array set options {
+ -timeserver {}
+ -port 37
+ -protocol tcp
+ -timeout 10000
+ -command {}
+ -loglevel warning
+ }
+ if {![catch {package require udp}]} {
+ set options(-protocol) udp
+ } else {
+ if {![catch {package require ceptcl}]} {
+ set options(-protocol) udp
+ }
+ }
+ log::lvSuppressLE emergency 0
+ log::lvSuppressLE $options(-loglevel) 1
+ log::lvSuppress $options(-loglevel) 0
+ }
+
+ # Store conversions for other epochs. Currently only unix - but maybe
+ # there are some others out there.
+ variable epoch
+ if {![info exists epoch]} {
+ array set epoch {
+ unix 2208988800
+ }
+ }
+
+ # The id for the next token.
+ variable uid
+ if {![info exists uid]} {
+ set uid 0
+ }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+# Retrieve configuration settings for the time package.
+#
+proc ::time::cget {optionname} {
+ return [configure $optionname]
+}
+
+# Description:
+# Configure the package.
+# With no options, returns a list of all current settings.
+#
+proc ::time::configure {args} {
+ variable options
+ set r {}
+ set cget 0
+
+ if {[llength $args] < 1} {
+ foreach opt [lsort [array names options]] {
+ lappend r $opt $options($opt)
+ }
+ return $r
+ }
+
+ if {[llength $args] == 1} {
+ set cget 1
+ }
+
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -port { set r [SetOrGet -port $cget] }
+ -timeout { set r [SetOrGet -timeout $cget] }
+ -protocol { set r [SetOrGet -protocol $cget] }
+ -command { set r [SetOrGet -command $cget] }
+ -loglevel {
+ if {$cget} {
+ return $options(-loglevel)
+ } else {
+ set options(-loglevel) [Pop args 1]
+ log::lvSuppressLE emergency 0
+ log::lvSuppressLE $options(-loglevel) 1
+ log::lvSuppress $options(-loglevel) 0
+ }
+ }
+ -- { Pop args ; break }
+ default {
+ set err [join [lsort [array names options -*]] ", "]
+ return -code error "bad option \"$option\": must be $err"
+ }
+ }
+ Pop args
+ }
+
+ return $r
+}
+
+# Set/get package options.
+proc ::time::SetOrGet {option {cget 0}} {
+ upvar options options
+ upvar args args
+ if {$cget} {
+ return $options($option)
+ } else {
+ set options($option) [Pop args 1]
+ }
+ return {}
+}
+
+# -------------------------------------------------------------------------
+
+proc ::time::getsntp {args} {
+ set token [eval [linsert $args 0 CommonSetup -port 123]]
+ upvar #0 $token State
+ set State(rfc) 2030
+ return [QueryTime $token]
+}
+
+proc ::time::gettime {args} {
+ set token [eval [linsert $args 0 CommonSetup -port 37]]
+ upvar #0 $token State
+ set State(rfc) 868
+ return [QueryTime $token]
+}
+
+proc ::time::CommonSetup {args} {
+ variable options
+ variable uid
+ set token [namespace current]::[incr uid]
+ variable $token
+ upvar 0 $token State
+
+ array set State [array get options]
+ set State(status) unconnected
+ set State(data) {}
+
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -glob -- $option {
+ -port { set State(-port) [Pop args 1] }
+ -timeout { set State(-timeout) [Pop args 1] }
+ -proto* { set State(-protocol) [Pop args 1] }
+ -command { set State(-command) [Pop args 1] }
+ -- { Pop args ; break }
+ default {
+ set err [join [lsort [array names State -*]] ", "]
+ return -code error "bad option \"$option\":\
+ must be $err."
+ }
+ }
+ Pop args
+ }
+
+ set len [llength $args]
+ if {$len < 1 || $len > 2} {
+ if {[catch {info level -1} arg0]} {
+ set arg0 [info level 0]
+ }
+ return -code error "wrong # args: should be\
+ \"[lindex $arg0 0] ?options? timeserver ?port?\""
+ }
+
+ set State(-timeserver) [lindex $args 0]
+ if {$len == 2} {
+ set State(-port) [lindex $args 1]
+ }
+
+ return $token
+}
+
+proc ::time::QueryTime {token} {
+ variable $token
+ upvar 0 $token State
+
+ if {[string equal $State(-protocol) "udp"]} {
+ if {[llength [package provide ceptcl]] == 0 \
+ && [llength [package provide udp]] == 0} {
+ set State(status) error
+ set State(error) "udp support is not available, \
+ either ceptcl or tcludp required"
+ return $token
+ }
+ }
+
+ if {[catch {
+ if {[string equal $State(-protocol) "udp"]} {
+ if {[llength [package provide ceptcl]] > 0} {
+ # using ceptcl
+ set State(sock) [cep -type datagram \
+ $State(-timeserver) $State(-port)]
+ fconfigure $State(sock) -blocking 0
+ } else {
+ # using tcludp
+ set State(sock) [udp_open]
+ udp_conf $State(sock) $State(-timeserver) $State(-port)
+ }
+ } else {
+ set State(sock) [socket $State(-timeserver) $State(-port)]
+ }
+ } sockerr]} {
+ set State(status) error
+ set State(error) $sockerr
+ return $token
+ }
+
+ # setup the timeout
+ if {$State(-timeout) > 0} {
+ set State(after) [after $State(-timeout) \
+ [list [namespace origin reset] $token timeout]]
+ }
+
+ set State(status) connect
+ fconfigure $State(sock) -translation binary -buffering none
+
+ # SNTP wants a 48 byte request while TIME doesn't care and is happy
+ # to accept any old rubbish. If protocol is TCP then merely connecting
+ # is sufficient to elicit a response.
+ if {[string equal $State(-protocol) "udp"]} {
+ set len [expr {($State(rfc) == 2030) ? 47 : 3}]
+ puts -nonewline $State(sock) \x0b[string repeat \0 $len]
+ }
+
+ fileevent $State(sock) readable \
+ [list [namespace origin ClientReadEvent] $token]
+
+ if {$State(-command) == {}} {
+ wait $token
+ }
+
+ return $token
+}
+
+proc ::time::unixtime {{token {}}} {
+ variable $token
+ variable epoch
+ upvar 0 $token State
+ if {$State(status) != "ok"} {
+ return -code error $State(error)
+ }
+
+ # SNTP returns 48+ bytes while TIME always returns 4.
+ if {[string length $State(data)] == 4} {
+ # RFC848 TIME
+ if {[binary scan $State(data) I r] < 1} {
+ return -code error "Unable to scan data"
+ }
+ return [expr {int($r - $epoch(unix))&0xffffffff}]
+ } elseif {[string length $State(data)] > 47} {
+ # SNTP TIME
+ if {[binary scan $State(data) c40II -> sec frac] < 1} {
+ return -code error "Failed to decode result"
+ }
+ return [expr {int($sec - $epoch(unix))&0xffffffff}]
+ } else {
+ return -code error "error: data format not recognised"
+ }
+}
+
+proc ::time::status {token} {
+ variable $token
+ upvar 0 $token State
+ return $State(status)
+}
+
+proc ::time::error {token} {
+ variable $token
+ upvar 0 $token State
+ set r {}
+ if {[info exists State(error)]} {
+ set r $State(error)
+ }
+ return $r
+}
+
+proc ::time::wait {token} {
+ variable $token
+ upvar 0 $token State
+
+ if {$State(status) == "connect"} {
+ vwait [subst $token](status)
+ }
+
+ return $State(status)
+}
+
+proc ::time::reset {token {why reset}} {
+ variable $token
+ upvar 0 $token State
+ set reason {}
+ set State(status) $why
+ catch {fileevent $State(sock) readable {}}
+ if {$why == "timeout"} {
+ set reason "timeout ocurred"
+ }
+ Finish $token $reason
+}
+
+# Description:
+# Remove any state associated with this token.
+#
+proc ::time::cleanup {token} {
+ variable $token
+ upvar 0 $token State
+ if {[info exists State]} {
+ unset State
+ }
+}
+
+# -------------------------------------------------------------------------
+
+proc ::time::ClientReadEvent {token} {
+ variable $token
+ upvar 0 $token State
+
+ append State(data) [read $State(sock)]
+ set expected [expr {($State(rfc) == 868) ? 4 : 48}]
+ if {[string length $State(data)] < $expected} { return }
+
+ #FIX ME: acquire peer data?
+
+ set State(status) ok
+ Finish $token
+ return
+}
+
+proc ::time::Finish {token {errormsg {}}} {
+ variable $token
+ upvar 0 $token State
+ global errorInfo errorCode
+
+ if {[string length $errormsg] > 0} {
+ set State(error) $errormsg
+ set State(status) error
+ }
+ catch {close $State(sock)}
+ catch {after cancel $State(after)}
+ if {[info exists State(-command)] && $State(-command) != {}} {
+ if {[catch {eval $State(-command) {$token}} err]} {
+ if {[string length $errormsg] == 0} {
+ set State(error) [list $err $errorInfo $errorCode]
+ set State(status) error
+ }
+ }
+ if {[info exists State(-command)]} {
+ unset State(-command)
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::time::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+# -------------------------------------------------------------------------
+
+package provide time 1.2.1
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/ntp/time.test b/tcllib/modules/ntp/time.test
new file mode 100644
index 0000000..9a4caf6
--- /dev/null
+++ b/tcllib/modules/ntp/time.test
@@ -0,0 +1,162 @@
+# time.test = Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Exercise the tcllib time package.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+# RCS: @(#) $Id: time.test,v 1.12 2006/10/09 21:41:41 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal time.tcl time
+}
+
+# -------------------------------------------------------------------------
+# Constraints
+#
+tcltest::testConstraint remote 0; # set true to use the remote tests.
+tcltest::testConstraint udp \
+ [llength [concat \
+ [package provide udp] \
+ [package provide ceptcl]]]
+
+# -------------------------------------------------------------------------
+
+set testScript tstsrv.tmp
+
+proc createServerProcess {} {
+ file delete -force $::testScript
+ set f [open $::testScript w+]
+ puts $f {
+ # This proc is called to handle client connections. We only need to
+ # return the time in TIME epoch and then close the channel.
+ proc ::srv {chan args} {
+ fconfigure $chan -translation binary -buffering none -eofchar {}
+
+ if {[catch {
+ set r [binary format I [expr {int([clock seconds] + 2208988800)}]]
+ puts "connect on $chan from [fconfigure $chan -peername]"
+ puts -nonewline $chan $r
+ close $chan
+ } msg]} {
+ puts stderr "error: $msg"
+ }
+ set ::done 1
+ }
+
+ set s [socket -server ::srv 0]
+ fconfigure $s -translation binary -buffering none -eofchar {}
+ set port [lindex [fconfigure $s -sockname] 2]
+
+ puts $port
+ flush stdout
+ vwait ::done
+ update
+ exit
+ }
+ close $f
+
+ # Now run the server script as a child process - return child's
+ # stdout to the caller so they can read the port to use.
+ if {[catch {
+ set f [open |[list [::tcltest::interpreter] $::testScript] r]
+ }]} {
+ set f [open |[list [info nameofexecutable] $::testScript] r]
+ }
+
+ fconfigure $f -buffering line -blocking 1
+ #after 500 {set _init 1} ; vwait _init
+ return $f
+}
+
+# -------------------------------------------------------------------------
+
+set token {}
+
+test time-1.1 {time::gettime} {
+ global token
+ list [catch {
+ set f [createServerProcess]
+ gets $f port
+ set token [::time::gettime -protocol tcp localhost $port]
+ set r {}
+ } msg] $msg
+} {0 {}}
+
+test time-1.2 {time::status} {
+ global token
+ list [catch {time::status $token} m] $m
+} {0 ok}
+
+test time-1.3 {time::unixtime} {
+ global token
+ list [catch {
+ set t [time::unixtime $token]
+ expr {(0 <= $t) && ($t <= 2147483647)}
+ } m] $m
+} {0 1}
+
+test time-1.4 {time::cget} {
+ global token
+ list [catch {
+ time::cget -port
+ } m] $m
+} {0 37}
+
+test time-1.5 {time::cleanup} {
+ global token
+ list [catch {
+ time::cleanup $token
+ } m] $m
+} {0 {}}
+
+
+# -------------------------------------------------------------------------
+
+test time-2.0 {check for real: RFC 868} {remote} {
+ set ::time::TestReady 0
+ list [catch {
+ set tok [time::gettime -protocol tcp -timeout 5000 ntp2a.mcc.ac.uk]
+ time::wait $tok
+ list [time::status $tok] [time::cleanup $tok]
+ } err] $err
+} {0 {ok {}}}
+
+test time-2.1 {check for real: RFC 868} {remote udp} {
+ set ::time::TestReady 0
+ list [catch {
+ set tok [time::gettime -protocol udp -timeout 5000 ntp2a.mcc.ac.uk]
+ time::wait $tok
+ list [time::status $tok] [time::cleanup $tok]
+ } err] $err
+} {0 {ok {}}}
+
+test time-2.2 {check for real: RFC 2030} {remote udp} {
+ set ::time::TestReady 0
+ list [catch {
+ set tok [time::getsntp -timeout 5000 ntp2a.mcc.ac.uk]
+ time::wait $tok
+ list [time::status $tok] [time::cleanup $tok]
+ } err] $err
+} {0 {ok {}}}
+
+# -------------------------------------------------------------------------
+file delete -force $::testScript
+testsuiteCleanup
+return
+
+#
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/oauth/oauth.man b/tcllib/modules/oauth/oauth.man
new file mode 100644
index 0000000..6a1fea1
--- /dev/null
+++ b/tcllib/modules/oauth/oauth.man
@@ -0,0 +1,191 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset PACKAGE_VERSION 1.0]
+[manpage_begin oauth n [vset PACKAGE_VERSION]]
+[keywords {oauth}]
+[keywords {RFC 5849}]
+[keywords {RFC 2718}]
+[keywords twitter]
+[copyright {2014 Javi P. <hxm@eggdrop.es>}]
+[moddesc {oauth}]
+[titledesc {oauth API base signature}]
+[category Networking]
+[require Tcl 8.5]
+[require oauth [opt [vset PACKAGE_VERSION]]]
+[description]
+[para]
+
+The [package oauth] package provides a simple Tcl-only library
+for communication with [uri http://oauth.net oauth] APIs.
+
+This current version of the package supports the Oauth 1.0 Protocol,
+as specified in [uri http://tools.ietf.org/rfc/rfc5849.txt {RFC 5849}].
+
+[include ../common-text/tls-security-notes.inc]
+
+[section Commands]
+
+[list_begin definitions]
+[call [cmd ::oauth::config]]
+
+When this command is invoked without arguments it returns a dictionary
+containing the current values of all options.
+
+[call [cmd ::oauth::config] [opt [arg options]...]]
+
+When invoked with arguments, options followed by their values, it is used
+to set and query various parameters of application and client, like proxy
+host and user agent for the HTTP requests. The detailed list of options
+is below:
+
+[list_begin options]
+[opt_def -accesstoken [arg string]]
+This is the user's token.
+
+[opt_def -accesstokensecret [arg string]]
+This is the user's secret token.
+
+[opt_def -consumerkey [arg string]]
+This is the public token of your app.
+
+[opt_def -consumersecret [arg string]]
+This is the private token of your app.
+
+[opt_def -debug [arg bool]]
+The default value is [const off]. If you change this option to [const on],
+the basic signature just created will be printed to stdout, among other
+debug output.
+
+[opt_def -oauthversion [arg version]]
+This is the version of the OAuth protocol to use.
+At the moment only [const 1.0] is supported, the default.
+
+[opt_def -proxyhost [arg hostname]]
+You can set up a proxy host for send contact the oauth's api server.
+
+[opt_def -proxyport [arg port-number]]
+Port number of your proxy.
+
+[opt_def -signmethod [arg method]]
+The signature method to use. OAuth 1.0 only supports [const HMAC-SHA1], the default.
+
+[opt_def -timeout [arg milliseconds]]
+Timeout in milliseconds for your query.
+The default value is [const 6000], i.e. 6 seconds.
+
+[opt_def -urlencoding [emph encoding]]
+The encoding used for creating the x-url-encoded URLs with
+[cmd ::http::formatQuery]. The default is [const utf-8], as specified
+by [uri http://tools.ietf.org/rfc/rfc2718.txt {RFC 2718}].
+
+[list_end]
+
+[call [cmd ::oauth::header] [arg baseURL] [opt [arg postQuery]]]
+
+This command is the base signature creator. With proper settings for various tokens
+and secrets (See [cmd ::oauth::config]) the result is the base authentication string
+to send to the server.
+
+[para] You do not need to call this procedure to create the query because
+[cmd ::oauth::query] (see below) will do for it for you.
+
+Doing so is useful for debugging purposes, though.
+
+[list_begin arguments]
+[arg_def url baseURL]
+
+This argument is the URI path to the OAuth API server.
+If you plan send a GET query, you should provide a full path.
+
+[example_begin]
+HTTP GET
+::oauth::header {https://api.twitter.com/1.1/users/lookup.json?screen_name=AbiertaMente}
+[example_end]
+
+[arg_def url-encoded-string postQuery]
+
+When you have to send a header in POST format, you have to put the query string into this argument.
+
+[example_begin]
+::oauth::header {https://api.twitter.com/1.1/friendships/create.json} {user_id=158812437&follow=true}
+[example_end]
+
+[list_end]
+
+[call [cmd ::oauth::query] [arg baseURL] [opt [arg postQuery]]]
+
+This procedure will use the settings made with [cmd ::oauth::config] to create the
+basic authentication and then send the command to the server API.
+
+It takes the same arguments as [cmd ::oauth::header].
+
+[para] The returned result will be a list containing 2 elements. The first
+element will be a dictionary containing the HTTP header data response.
+This allows you, for example, to check the X-Rate-Limit from OAuth.
+The second element will be the raw data returned from API server.
+This string is usually a json object which can be further decoded with the
+functions of package [package json], or any other json-parser for Tcl.
+
+[para] Here is an example of how it would work in Twitter. Do not forget to
+replace the placeholder tokens and keys of the example with your own tokens
+and keys when trying it out.
+
+[example {% package require oauth
+% package require json
+% oauth::config -consumerkey {your_consumer_key}\
+-consumersecret {your_consumer_key_secret}\
+-accesstoken {your_access_token}\
+-accesstokensecret {your_access_token_secret}
+
+% set response [oauth::query https://api.twitter.com/1.1/users/lookup.json?screen_name=AbiertaMente]
+% set jsondata [lindex $response 1]
+% set data [json::json2dict $jsondata]
+$ set data [lindex $data 0]
+% dict for {key val} $data {puts "$key => $val"}
+id => 158812437
+id_str => 158812437
+name => Un Librepensador
+screen_name => AbiertaMente
+location => Explico mis tuits ahí →
+description => 160Caracteres para un SMS y contaba mi vida entera sin recortar vocales. Ahora en Twitter, podemos usar hasta 140 y a mí me sobrarían 20 para contaros todo lo q
+url => http://t.co/SGs3k9odBn
+entities => url {urls {{url http://t.co/SGs3k9odBn expanded_url http://librepensamiento.es display_url librepensamiento.es indices {0 22}}}} description {urls {}}
+protected => false
+followers_count => 72705
+friends_count => 53099
+listed_count => 258
+created_at => Wed Jun 23 18:29:58 +0000 2010
+favourites_count => 297
+utc_offset => 7200
+time_zone => Madrid
+geo_enabled => false
+verified => false
+statuses_count => 8996
+lang => es
+status => created_at {Sun Oct 12 08:02:38 +0000 2014} id 521209314087018496 id_str 521209314087018496 text {@thesamethanhim http://t.co/WFoXOAofCt} source {<a href="http://twitter.com" rel="nofollow">Twitter Web Client</a>} truncated false in_reply_to_status_id 521076457490350081 in_reply_to_status_id_str 521076457490350081 in_reply_to_user_id 2282730867 in_reply_to_user_id_str 2282730867 in_reply_to_screen_name thesamethanhim geo null coordinates null place null contributors null retweet_count 0 favorite_count 0 entities {hashtags {} symbols {} urls {{url http://t.co/WFoXOAofCt expanded_url http://www.elmundo.es/internacional/2014/03/05/53173dc1268e3e3f238b458a.html display_url elmundo.es/internacional/… indices {16 38}}} user_mentions {{screen_name thesamethanhim name Ἑλένη id 2282730867 id_str 2282730867 indices {0 15}}}} favorited false retweeted false possibly_sensitive false lang und
+contributors_enabled => false
+is_translator => true
+is_translation_enabled => false
+profile_background_color => 709397
+profile_background_image_url => http://pbs.twimg.com/profile_background_images/704065051/9309c02aa2728bdf543505ddbd408e2e.jpeg
+profile_background_image_url_https => https://pbs.twimg.com/profile_background_images/704065051/9309c02aa2728bdf543505ddbd408e2e.jpeg
+profile_background_tile => true
+profile_image_url => http://pbs.twimg.com/profile_images/2629816665/8035fb81919b840c5cc149755d3d7b0b_normal.jpeg
+profile_image_url_https => https://pbs.twimg.com/profile_images/2629816665/8035fb81919b840c5cc149755d3d7b0b_normal.jpeg
+profile_banner_url => https://pbs.twimg.com/profile_banners/158812437/1400828874
+profile_link_color => FF3300
+profile_sidebar_border_color => FFFFFF
+profile_sidebar_fill_color => A0C5C7
+profile_text_color => 333333
+profile_use_background_image => true
+default_profile => false
+default_profile_image => false
+following => true
+follow_request_sent => false
+notifications => false}]
+
+[list_end]
+[para]
+
+[vset CATEGORY oauth]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/oauth/oauth.tcl b/tcllib/modules/oauth/oauth.tcl
new file mode 100644
index 0000000..b6ab07e
--- /dev/null
+++ b/tcllib/modules/oauth/oauth.tcl
@@ -0,0 +1,291 @@
+# !/bin/sh
+# the next line will restart with tclsh wherever it is \
+exec tclsh "$0" "$@"
+
+# oauth.tcl -*- tcl -*-
+# This module pretend give full support to API version 1.1 of Twitter
+# according to API v1.1’s Authentication Model
+#
+# Copyright (c) 2014 Javier Pérez - <hxm@eggdrop.es>
+# gave to tcllib
+#
+# About OAuthv1.0a
+# There are 3 steps we need complete to get authenticated with OAuth.
+# Steps:
+# 1. Authorizing a request: we need 7 parameters.
+# 1.1 Consumer key (oauth_consumer_key) from your app (dev.twitter.com/apps)
+# 1.2 Nonce (oauth_nonce) unique&random token autogenerated by base64 32bits
+# 1.3 Signature (oauth_signature) all the other requests and 2 secret values
+# trought a signing algorithm.
+# 1.4 Signature method (oauth_signature_method) which is HMAC-SHA1
+# 1.5 Timestamp (oauth_timestamp) time in unix format of the request
+# 1.6 Token (oauth_token) a parameter you can obtain in your account settings
+# 1.7 Version (oauth_version) the OAuth version, actually 1.0
+
+# TODO: create online documentation
+
+package require Tcl 8.5
+package provide oauth 1
+
+package require http
+package require tls
+package require base64
+package require sha1
+
+http::register https 443 ::tls::socket
+
+namespace eval ::oauth {
+ namespace export query
+
+ variable commands [namespace export]
+ variable project {OAuth1.0}
+ variable version [package present oauth]
+ variable description {OAuth authentication for Twitter support.}
+ variable author {Javier Pérez <hxm@eggdrop.es>}
+ # AK: changed to ISO date format.
+ variable created {2012-12-30, published 2014-02-10}
+ variable script [info script]
+ variable contact "$project $version ~ $description ($author)"
+
+ variable oauth
+ if {![info exists oauth]} {
+ array set oauth {
+ -accesstoken {}
+ -accesstokensecret {}
+ -consumerkey {}
+ -consumersecret {}
+ -debug 0
+ -oauthversion 1.0
+ -proxyhost {}
+ -proxyport {}
+ -ratelimit 1
+ -signmethod HMAC-SHA1
+ -timeout 6000
+ -urlencoding utf-8
+ }
+ set oauth(-useragent) "Mozilla/5.0\
+ ([string totitle $::tcl_platform(platform)]; U;\
+ $::tcl_platform(os) $::tcl_platform(osVersion))\
+ oauth/${version} Tcl/[package provide Tcl]"
+ }
+}
+
+# config --
+#
+# See documentation for details.
+#
+# Arguments:
+# args options parsed by the procedure.
+# Results:
+# This procedure returns the array with the current configuration
+# In order to create an array with the result of this procedure you can do
+# it in this way: array set settings [oauth::config ...]
+proc ::oauth::config {args} {
+ variable oauth
+ set options [array names oauth -*]
+ set usage [join $options {, }]
+ if {$args eq {}} {
+ return [array get oauth]
+ }
+ foreach {flag value} $args {
+ set optionflag [lsearch -inline -nocase $options $flag]
+ if {$optionflag eq ""} {
+ Error "Unknown option \"${flag}\", must be: $usage" BAD OPTION
+ }
+ set oauth($optionflag) $value
+ }
+ return [array get oauth]
+}
+
+# header --
+# Following OAuth1.0a rules, this procedure collects all
+# information required for get the authentication. All we need
+# is a header for our api queries with our user and app
+# information for the verification of who we are. Collect it,
+# encode it as the protocol says and add it to the geturl
+# command. If you want, you can use this procedure for your
+# own queries, just use it as header. Example:
+# http::geturl $twitter(url) -header [oauth::header <...>] <...>
+#
+# You can get more information about how twitter api works reading this:
+# https://dev.twitter.com/overview/documentation
+#
+# Arguments:
+# baseURL: full url path of twitter api. If it should be sent
+# as GET, add the query string.
+# postQuery: arguments passed at the request body as POST. This
+# should be in http query format.
+# Result:
+# This proc will return a list of values like this:
+# Authorization:
+# OAuth oauth_consumer_key="xvz1evFS4wEEPTGEFPHBog",
+# oauth_nonce="kYjzVBB8Y0ZFabxSWbWovY3uYSQ2pTgmZeNu2VS4cg",
+# oauth_signature="tnnArxj06cWHq44gCs1OSKk%2FjLY%3D",
+# oauth_signature_method="HMAC-SHA1",
+# oauth_timestamp="1318622958",
+# oauth_token="370773112-GmHxMAgYyLbNEtIKZeRNFsMKPR9EyMZeS9weJAEb",
+# oauth_version="1.0"
+proc ::oauth::header {baseURL {postQuery ""}} {
+ variable oauth
+
+ if {$oauth(-signmethod) eq ""} {
+ Error "ERROR: invalid argument for -signmethod." BAD SIGN-METHOD
+ }
+ if {[package vcompare $oauth(-oauthversion) 1.0] != 0} {
+ Error "ERROR: this script only supports oauth_version 1.0" \
+ BAD OAUTH-VERSION
+ }
+ if {$oauth(-consumerkey) eq ""} {
+ Error "ERROR: please define your consumer key.\
+ [namespace current]::config -consumerkey <...>" \
+ BAD CONSUMER-KEY
+ }
+ if {$oauth(-accesstoken) eq ""} {
+ Error "ERROR: please define your app's access token.\
+ [namespace current]::config -accesstoken <...>" \
+ BAD ACCESS-TOKEN
+ }
+
+ set randomKey [sha1::sha1 [expr {[clock milliseconds] + round(rand()*50000)}]]
+ set timestamp [clock seconds]
+
+ lappend paramList "oauth_consumer_key=$oauth(-consumerkey)"
+ lappend paramList "oauth_nonce=$randomKey"
+ lappend paramList "oauth_signature_method=$oauth(-signmethod)"
+ lappend paramList "oauth_timestamp=$timestamp"
+ lappend paramList "oauth_token=$oauth(-accesstoken)"
+ lappend paramList "oauth_version=$oauth(-oauthversion)"
+
+ if {$postQuery eq {}} {
+ set url [lindex [split $baseURL {?}] 0]
+ set queryString [lindex [split $baseURL {?}] 1]
+ foreach argument [split $queryString {&}] {
+ lappend paramList $argument
+ }
+ set httpMethod {GET}
+ } else {
+ set url $baseURL
+ set httpMethod {POST}
+ }
+
+ foreach parameter $paramList {
+ set key [lindex [split $parameter {=}] 0]
+ set value [join [lrange [split $parameter {=}] 1 end] {=}]
+ lappend header "${key}=\"${value}\""
+ }
+ set paramString [join [lsort -dictionary $paramList] {&}]
+
+ lappend baseList $httpMethod
+ lappend baseList [PercentEncode $url]
+ lappend baseList [PercentEncode $paramString]
+ set signString [join $baseList {&}]
+
+ set signKey "[PercentEncode $oauth(-consumersecret)]&[PercentEncode $oauth(-accesstokensecret)]"
+ set signature [base64::encode [sha1::hmac -bin -key $signKey $signString]]
+
+ lappend header "oauth_signature=\"[PercentEncode $signature]\""
+ if {$oauth(-debug) == 1} {
+ puts {oauth::header: Authorization Oauth}
+ foreach line $header {
+ puts "\t$line"
+ }
+ puts "\nBaseString: $signString"
+ }
+ return "Authorization [list [concat OAuth [join [lsort -dictionary $header] {, }]]]"
+}
+
+# query --
+# Sends to oauth API url the proper oauth header and querybody
+# returning the raw data from Twitter for your parse.
+# Arguments:
+# baseURL api host URL with ?arguments if it's a GET request
+# postQuery POST query if it's a POST query
+# Result:
+# The result will be list with 2 arguments.
+# The first argument is an array with the http's header
+# and the second one is JSON data received from the server. The header is
+# very important because it reports your rest API limit and will
+# inform you if you can get your account suspended.
+proc ::oauth::query {baseURL {postQuery ""}} {
+ variable oauth
+ if {$oauth(-consumerkey) eq ""} {
+ Error "ERROR: please define your consumer key.\
+ [namespace current]::config -consumerkey <...>" \
+ BAD CONSUMER-KEY
+ }
+ if {$oauth(-consumersecret) eq ""} {
+ Error "ERROR: please define your app's consumer secret.\
+ [namespace current]::config -consumersecret <...>" \
+ BAD CONSUMER-SECRET
+ }
+ if {$oauth(-accesstoken) eq ""} {
+ Error "ERROR: please define your access token.\
+ [namespace current]::config -accesstoken <...>" \
+ BAD ACCESS-TOKEN
+ }
+ if {$oauth(-accesstokensecret) eq ""} {
+ Error "ERROR: please define your app's access token secret.\
+ [namespace current]::config -accesstokensecret <...>" \
+ BAD ACCESS-TOKEN-SECRET
+ }
+ if {$postQuery eq ""} {
+ set url [lindex [split $baseURL {?}] 0]
+ set queryString [join [lrange [split $baseURL {?}] 1 end] {?}]
+ set httpMethod {GET}
+ } else {
+ set url $baseURL
+ set httpMethod {POST}
+ }
+
+ if {$httpMethod eq {GET}} {
+ if {$queryString ne {}} {
+ append url ? $queryString
+ }
+ set requestBody {}
+ } else {
+ set requestBody $queryString
+ }
+ if {$queryString ne {}} {
+ set headerURL ${url}?${queryString}
+ } else {
+ set headerURL $url
+ }
+
+ set header [header $headerURL]
+
+ http::config \
+ -proxyhost $oauth(-proxyhost) \
+ -proxyport $oauth(-proxyport) \
+ -useragent $oauth(-useragent)
+
+ set token [http::geturl $baseURL \
+ -headers $header \
+ -query $requestBody \
+ -method $httpMethod \
+ -timeout $oauth(-timeout)]
+ set ncode [http::ncode $token]
+ set data [http::data $token]
+ upvar #0 $token state
+ lappend result [array names state]
+ lappend result $data
+ http::cleanup $token
+
+ return $result
+}
+
+
+# PercentEncode --
+# Encoding process in http://tools.ietf.org/html/rfc3986#section-2.1
+# for Twitter authentication. (http::formatQuery is lowcase)
+proc ::oauth::PercentEncode {string} {
+ set utf8String [encoding convertto utf-8 $string]
+ return [string map {"\n" "%0A"} \
+ [subst [regsub -all \
+ {[^-A-Za-z0-9._~\n]} $utf8String \
+ {%[format "%02X" [scan "\\\0" "%c"]]}]]]
+}
+
+proc ::oauth::Error {string args} {
+ return -code error -errorcode [linsert $args 0 OAUTH] $string
+}
+return
diff --git a/tcllib/modules/oauth/pkgIndex.tcl b/tcllib/modules/oauth/pkgIndex.tcl
new file mode 100644
index 0000000..513e7ff
--- /dev/null
+++ b/tcllib/modules/oauth/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+package ifneeded oauth 1 [list source [file join $dir oauth.tcl]]
diff --git a/tcllib/modules/oodialect/oodialect.demo b/tcllib/modules/oodialect/oodialect.demo
new file mode 100644
index 0000000..6d08e09
--- /dev/null
+++ b/tcllib/modules/oodialect/oodialect.demo
@@ -0,0 +1,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]
diff --git a/tcllib/modules/oodialect/oodialect.md b/tcllib/modules/oodialect/oodialect.md
new file mode 100644
index 0000000..99f2063
--- /dev/null
+++ b/tcllib/modules/oodialect/oodialect.md
@@ -0,0 +1,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>
+
diff --git a/tcllib/modules/oodialect/oodialect.tcl b/tcllib/modules/oodialect/oodialect.tcl
new file mode 100644
index 0000000..ee5fc8a
--- /dev/null
+++ b/tcllib/modules/oodialect/oodialect.tcl
@@ -0,0 +1,245 @@
+###
+# oodialect.tcl
+#
+# Copyright (c) 2015 Sean Woods, Donald K Fellows
+#
+# BSD License
+###
+# @@ Meta Begin
+# Package oo::dialect 0.2
+# 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
+ }
+ }]
+}
+
+# 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)
+ }
+ foreach item [list "${NSpace}::$class" "::$class"] {
+ if {[info command $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 alias $name
+ #set alias [NSNormalize $NSpace $name]
+ # Add a local metaclass reference
+ set cname($alias) $class
+ if {![info exists ::oo::dialect::cname($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
+ }
+}
+
+package provide oo::dialect 0.3 \ No newline at end of file
diff --git a/tcllib/modules/oodialect/oodialect.test b/tcllib/modules/oodialect/oodialect.test
new file mode 100644
index 0000000..b568ec7
--- /dev/null
+++ b/tcllib/modules/oodialect/oodialect.test
@@ -0,0 +1,162 @@
+# 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-ancestry-001 {Testing heritage} {
+ ::oo::meta::ancestors ::test1::f
+} {::oo::object ::alpha::object ::bravo::object ::test1::a ::test1::f}
+
+test oodialect-ancestry-001 {Testing heritage} {
+ ::oo::meta::ancestors ::alpha::object
+} {::oo::object ::alpha::object}
+
+test oodialect-ancestry-001 {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:
diff --git a/tcllib/modules/oodialect/pkgIndex.tcl b/tcllib/modules/oodialect/pkgIndex.tcl
new file mode 100644
index 0000000..3285f10
--- /dev/null
+++ b/tcllib/modules/oodialect/pkgIndex.tcl
@@ -0,0 +1,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 oo::dialect 0.3 [list source [file join $dir oodialect.tcl]]
diff --git a/tcllib/modules/oometa/oometa.demo b/tcllib/modules/oometa/oometa.demo
new file mode 100644
index 0000000..302001f
--- /dev/null
+++ b/tcllib/modules/oometa/oometa.demo
@@ -0,0 +1,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]
diff --git a/tcllib/modules/oometa/oometa.md b/tcllib/modules/oometa/oometa.md
new file mode 100644
index 0000000..c71b620
--- /dev/null
+++ b/tcllib/modules/oometa/oometa.md
@@ -0,0 +1,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.
+
+
+
+
diff --git a/tcllib/modules/oometa/oometa.tcl b/tcllib/modules/oometa/oometa.tcl
new file mode 100644
index 0000000..138a230
--- /dev/null
+++ b/tcllib/modules/oometa/oometa.tcl
@@ -0,0 +1,377 @@
+###
+# Author: Sean Woods, yoda@etoyoc.com
+##
+# TclOO routines to implement property tracking by class and object
+###
+package require dicttool
+namespace eval ::oo::meta {
+ variable dirty_classes {}
+ variable core_classes {::oo::class ::oo::object ::tao::moac}
+}
+
+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 thisresult {}
+ set result {}
+ set queue $class
+ variable core_classes
+
+ while {[llength $queue]} {
+ set tqueue $queue
+ set queue {}
+ foreach qclass $tqueue {
+ if {$qclass in $core_classes} continue
+ foreach aclass [::info class superclasses $qclass] {
+ if { $aclass in $result } continue
+ if { $aclass in $queue } continue
+ lappend queue $aclass
+ }
+ foreach aclass [::info class mixins $qclass] {
+ if { $aclass in $result } continue
+ if { $aclass in $queue } continue
+ lappend queue $aclass
+ }
+ }
+ foreach qclass $tqueue {
+ if {$qclass ni $core_classes} continue
+ foreach aclass [::info class superclasses $qclass] {
+ if { $aclass in $result } continue
+ if { $aclass in $queue } continue
+ lappend queue $aclass
+ }
+ foreach aclass [::info class mixins $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 {
+ rebuild {
+ if {$class ni $::oo::meta::dirty_classes} {
+ lappend ::oo::meta::dirty_classes $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]
+ return [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 {
+ if {$class ni $::oo::meta::dirty_classes} {
+ lappend ::oo::meta::dirty_classes $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 {
+ 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 {
+ 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 {
+ if {$class ni $::oo::meta::dirty_classes} {
+ lappend ::oo::meta::dirty_classes $class
+ }
+ ::dict $submethod ::oo::meta::local_property($class) {*}$args
+ }
+ merge {
+ if {$class ni $::oo::meta::dirty_classes} {
+ lappend ::oo::meta::dirty_classes $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 {[dict getnull $::oo::meta::local_property($dclass) classinfo type:] eq "core"} {
+ if {$dclass ni $::oo::meta::core_classes} {
+ lappend ::oo::meta::core_classes $dclass
+ }
+ }
+ }
+ }
+
+ ###
+ # 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 aclass [lrange $cached_hierarchy($class) 0 end-1] {
+ if {[::info exists local_property($aclass)]} {
+ lappend metadata $local_property($aclass)
+ }
+ }
+ lappend metadata {classinfo {type {}}}
+ if {[::info exists local_property($class)]} {
+ set metadata [dict rmerge {*}$metadata $local_property($class)]
+ } else {
+ set metadata [dict rmerge {*}$metadata]
+ }
+ set cached_property($class) $metadata
+ return $metadata
+}
+
+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 "set branchset"} {
+ ::oo::meta::info $class {*}$args
+ } else {
+ ::oo::meta::info $class set {*}$args
+ }
+}
+
+oo::define oo::class {
+ method meta {submethod args} {
+ return [::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} {
+ set class [::info object class [self object]]
+ my variable meta
+ 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:
+ # 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]
+ }
+ set class_metadata [::oo::meta::metadata $class]
+ 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 {
+ set class_metadata [::oo::meta::metadata $class]
+ set info [dict rmerge $class_metadata $meta]
+ return [uplevel 1 [list dict $submethod [lindex $args 0] [dict get $info {*}[lrange $args 1 end-1]] [lindex $args end]]]
+ }
+ with {
+ set class_metadata [::oo::meta::metadata $class]
+ upvar 1 TEMPVAR info
+ set info [dict rmerge $class_metadata $meta]
+ return [uplevel 1 [list dict with TEMPVAR {*}$args]]
+ }
+ dump {
+ set class_metadata [::oo::meta::metadata $class]
+ return [dict rmerge $class_metadata $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
+ }
+ getnull {
+ return [dict rmerge [dict getnull [::oo::meta::metadata $class] {*}$args] [dict getnull $meta {*}$args]]
+ }
+ branchget {
+ set result {}
+ foreach {field value} [dict getnull [::oo::meta::metadata $class] {*}$args] {
+ dict set result [string trimright $field :] $value
+ }
+ foreach {field value} [dict getnull $meta {*}$args] {
+ dict set result [string trimright $field :] $value
+ }
+ return $result
+ }
+ get {
+ if {![dict exists $meta {*}$args]} {
+ return [dict get [::oo::meta::metadata $class] {*}$args]
+ }
+ return [dict rmerge [dict getnull [::oo::meta::metadata $class] {*}$args] [dict getnull $meta {*}$args]]
+ }
+ default {
+ set class_metadata [::oo::meta::metadata $class]
+ set info [dict rmerge $class_metadata $meta]
+ return [dict $submethod $info {*}$args]
+ }
+ }
+ }
+}
+package provide oo::meta 0.4.1 \ No newline at end of file
diff --git a/tcllib/modules/oometa/oometa.test b/tcllib/modules/oometa/oometa.test
new file mode 100644
index 0000000..ea9671a
--- /dev/null
+++ b/tcllib/modules/oometa/oometa.test
@@ -0,0 +1,176 @@
+# ooutil.test - Copyright (c) 2014-2015 Andreas Kupries
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+testsNeed TclOO 1
+
+testing {
+ useLocal oometa.tcl oo::meta
+ useLocal oooption.tcl oo::option
+}
+
+# -------------------------------------------------------------------------
+# Test properties
+
+oo::class create foo {
+ property color blue
+
+ constructor args {
+ my _staticInit
+ my configure {*}$args
+ }
+}
+
+oo::class create bar {
+ superclass ::foo
+ property 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
+} pink
+# With or without the trailing :
+test oo-object-meta-001b {Test accessing properties} {
+ cheers meta cget color:
+} pink
+# 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
+
+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 result {}
+ moes meta for {key value} option {
+ lappend result $key $value
+ }
+ set result
+} {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 obj-meta-for-001 {Test class meta for} {
+ set result {}
+ bar meta for {key value} option {
+ lappend result $key $value
+ }
+ set result
+} {color {label: Color default: green}}
+
+test obj-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}
+
+testsuiteCleanup
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/oometa/oooption.tcl b/tcllib/modules/oometa/oooption.tcl
new file mode 100644
index 0000000..e2c59db
--- /dev/null
+++ b/tcllib/modules/oometa/oooption.tcl
@@ -0,0 +1,168 @@
+###
+# Option handling for TclOO
+###
+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 \ No newline at end of file
diff --git a/tcllib/modules/oometa/pkgIndex.tcl b/tcllib/modules/oometa/pkgIndex.tcl
new file mode 100644
index 0000000..5735730
--- /dev/null
+++ b/tcllib/modules/oometa/pkgIndex.tcl
@@ -0,0 +1,8 @@
+#checker -scope global exclude warnUndefinedVar
+# var in question is 'dir'.
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ # PRAGMA: returnok
+ return
+}
+package ifneeded oo::meta 0.4.1 [list source [file join $dir oometa.tcl]]
+package ifneeded oo::option 0.3 [list source [file join $dir oooption.tcl]]
diff --git a/tcllib/modules/ooutil/ChangeLog b/tcllib/modules/ooutil/ChangeLog
new file mode 100644
index 0000000..c6c576d
--- /dev/null
+++ b/tcllib/modules/ooutil/ChangeLog
@@ -0,0 +1,28 @@
+2013-02-27 Andreas Kupries <andreask@activestate.com>
+
+ * ooutil.tcl (::oo::Helpers::link): New helper command.
+ * ooutil.man: Makes instance methods available without
+ * pkgIndex.tcl: 'my'. Bumped version to 1.2.
+
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2013-01-30 Andreas Kupries <andreask@activestate.com>
+
+ * ooutil.man: Added more utilities to support class variables,
+ * ooutil.tcl: class methods, and singleton classes. Packed version
+ * pkgIndex.tcl: bumped to 1.1 for all these new features.
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-05-31 Andreas Kupries <andreask@activestate.com>
+
+ * New module and package: oo::util. Right now only easy
+ referencing of instance methods for callbacks.
diff --git a/tcllib/modules/ooutil/ooutil.man b/tcllib/modules/ooutil/ooutil.man
new file mode 100644
index 0000000..72415ff
--- /dev/null
+++ b/tcllib/modules/ooutil/ooutil.man
@@ -0,0 +1,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]
diff --git a/tcllib/modules/ooutil/ooutil.tcl b/tcllib/modules/ooutil/ooutil.tcl
new file mode 100644
index 0000000..3e7d4e3
--- /dev/null
+++ b/tcllib/modules/ooutil/ooutil.tcl
@@ -0,0 +1,189 @@
+# # ## ### ##### ######## ############# ####################
+## -*- tcl -*-
+## (C) 2011-2015 Andreas Kupries, BSD licensed.
+
+# # ## ### ##### ######## ############# ####################
+## Requisites
+
+package require Tcl 8.5
+package require TclOO
+
+# # ## ### ##### ######## ############# #####################
+## Public API implementation
+
+# # ## ### ##### ######## ############# ####################
+## Easy callback support.
+## http://wiki.tcl.tk/21595. v20, Donal Fellows
+
+proc ::oo::Helpers::mymethod {method args} {
+ list [uplevel 1 {namespace which my}] $method {*}$args
+}
+
+# # ## ### ##### ######## ############# ####################
+## Class variable support. Use within instance methods.
+## No use in class definitions.
+## http://wiki.tcl.tk/21595. v63, Donal Fellows, tweaked name, comments
+
+proc ::oo::Helpers::classvariable {name args} {
+ # Get a reference to the class's namespace
+ set ns [info object namespace [uplevel 1 {self class}]]
+
+ # Double up the list of variable names
+ set vs [list $name $name]
+ foreach v $args {lappend vs $v $v}
+
+ # Lastly, link the caller's local variables to the class's
+ # variables
+ uplevel 1 [list namespace upvar $ns {*}$vs]
+}
+
+#==================================
+# Demonstration
+#==================================
+# % oo::class create Foo {
+# method bar {z} {
+# classvar 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
+
+# # ## ### ##### ######## ############# ####################
+## Class method support, with access in derived classes
+## http://wiki.tcl.tk/21595. v63, Donal Fellows
+
+proc ::oo::define::classmethod {name {args ""} {body ""}} {
+ # Create the method on the class if the caller gave arguments and body
+ set argc [llength [info level 0]]
+ if {$argc == 3} {
+ return -code error "wrong # args: should be \"[lindex [info level 0] 0] name ?args body?\""
+ }
+
+ # Get the name of the current class or class delegate
+ set cls [namespace which [lindex [info level -1] 1]]
+ set d $cls.Delegate
+ if {[info object isa object $d] && [info object isa class $d]} {
+ set cls $d
+ }
+
+ if {$argc == 4} {
+ oo::define $cls method $name $args $body
+ }
+
+ # Make the connection by forwarding
+ uplevel 1 [list forward $name [info object namespace $cls]::my $name]
+}
+
+# Build this *almost* like a class method, but with extra care to avoid nuking
+# the existing method.
+oo::class create oo::class.Delegate {
+ method create {name args} {
+ if {![string match ::* $name]} {
+ set ns [uplevel 1 {namespace current}]
+ if {$ns eq "::"} {set ns ""}
+ set name ${ns}::${name}
+ }
+ if {[string match *.Delegate $name]} {
+ return [next $name {*}$args]
+ }
+ set delegate [oo::class create $name.Delegate]
+ set cls [next $name {*}$args]
+ set superdelegates [list $delegate]
+ foreach c [info class superclass $cls] {
+ set d $c.Delegate
+ if {[info object isa object $d] && [info object isa class $d]} {
+ lappend superdelegates $d
+ }
+ }
+ oo::objdefine $cls mixin {*}$superdelegates
+ return $cls
+ }
+}
+
+oo::define oo::class self mixin oo::class.Delegate
+
+# Demonstrating…
+# ======
+# oo::class create ActiveRecord {
+# classmethod find args { puts "[self] called with arguments: $args" }
+# }
+# oo::class create Table {
+# superclass ActiveRecord
+# }
+# Table find foo bar
+# ======
+# which will write this out (I tested it):
+# ======none
+# ::Table called with arguments: foo bar
+# ======
+
+# # ## ### ##### ######## ############# ####################
+## Singleton Metaclass
+## http://wiki.tcl.tk/21595. v63, Donal Fellows
+
+oo::class create ooutil::singleton {
+ superclass oo::class
+ variable object
+ method create {name args} {
+ if {![info exists object]} {
+ set object [next $name {*}$args]
+ }
+ return $object
+ }
+ method new args {
+ if {![info exists object]} {
+ set object [next {*}$args]
+ }
+ return $object
+ }
+}
+
+# ======
+# Demonstration
+# ======
+# % oo::class create example {
+# self mixin singleton
+# method foo {} {self}
+# }
+# ::example
+# % [example new] foo
+# ::oo::Obj22
+# % [example new] foo
+# ::oo::Obj22
+
+# # ## ### ##### ######## ############# ####################
+## Linking instance methods into instance namespace for access without 'my'
+## http://wiki.tcl.tk/27999, AK
+
+proc ::oo::Helpers::link {args} {
+ set ns [uplevel 1 {namespace current}]
+ foreach link $args {
+ if {[llength $link] == 2} {
+ lassign $link src dst
+ } else {
+ lassign $link src
+ set dst $src
+ }
+ interp alias {} ${ns}::$src {} ${ns}::my $dst
+ }
+ return
+}
+
+# # ## ### ##### ######## ############# ####################
+## Ready
+
+package provide oo::util 1.2.2
diff --git a/tcllib/modules/ooutil/ooutil.test b/tcllib/modules/ooutil/ooutil.test
new file mode 100644
index 0000000..9ef01c4
--- /dev/null
+++ b/tcllib/modules/ooutil/ooutil.test
@@ -0,0 +1,84 @@
+# ooutil.test - Copyright (c) 2014-2015 Andreas Kupries
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+testsNeed TclOO 1
+
+testing {
+ useLocal ooutil.tcl oo::util
+}
+
+# -------------------------------------------------------------------------
+
+test ooutil-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup {
+ oo::class create animal {}
+ namespace eval ::ooutiltest {
+ oo::class create pet { superclass animal }
+ }
+} -body {
+ namespace eval ::ooutiltest {
+ oo::class create dog { superclass pet }
+ }
+} -cleanup {
+ namespace delete ooutiltest
+ rename animal {}
+} -result {::ooutiltest::dog}
+
+# -------------------------------------------------------------------------
+
+test ooutil-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup {
+ oo::class create TestClass {
+ superclass oo::class
+ self method create {name ignore body} {
+ next $name $body
+ }
+ }
+} -body {
+ TestClass create okay {} {}
+} -cleanup {
+ rename TestClass {}
+} -result {::okay}
+
+# -------------------------------------------------------------------------
+
+test ooutil-classmethod-1 {test ooutil classmethod} -setup {
+ oo::class create ActiveRecord {
+ classmethod find args { puts "[self] called with arguments: $args" }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+} -body {
+ Table find foo bar
+} -cleanup {
+ rename ActiveRecord {}
+} -output "::Table called with arguments: foo bar\n"
+
+test ooutil-classmethod-2 {test ooutil classmethod in namespace} -setup {
+ namespace eval testns {
+ oo::class create ActiveRecord {
+ classmethod find args { puts "[self] called with arguments: $args" }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+ }
+} -body {
+ testns::Table find foo bar
+} -cleanup {
+ namespace delete testns
+} -output "::testns::Table called with arguments: foo bar\n"
+
+testsuiteCleanup
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/ooutil/pkgIndex.tcl b/tcllib/modules/ooutil/pkgIndex.tcl
new file mode 100644
index 0000000..d9756be
--- /dev/null
+++ b/tcllib/modules/ooutil/pkgIndex.tcl
@@ -0,0 +1,7 @@
+#checker -scope global exclude warnUndefinedVar
+# var in question is 'dir'.
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ # PRAGMA: returnok
+ return
+}
+package ifneeded oo::util 1.2.2 [list source [file join $dir ooutil.tcl]] \ No newline at end of file
diff --git a/tcllib/modules/otp/ChangeLog b/tcllib/modules/otp/ChangeLog
new file mode 100644
index 0000000..c6ecb57
--- /dev/null
+++ b/tcllib/modules/otp/ChangeLog
@@ -0,0 +1,59 @@
+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-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>
+
+ * otp.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-09-01 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * modules/otp/otp.tcl: Initial version of RFC 2289 implementation
+ * modules/otp/otp.test: "A One-Time Password System"
+ * modules/otp/otp.man:
+
diff --git a/tcllib/modules/otp/otp.man b/tcllib/modules/otp/otp.man
new file mode 100644
index 0000000..cbc9ff4
--- /dev/null
+++ b/tcllib/modules/otp/otp.man
@@ -0,0 +1,95 @@
+[manpage_begin otp n 1.0.0]
+[see_also md4]
+[see_also md5]
+[see_also ripemd160]
+[see_also SASL]
+[see_also sha1]
+[keywords hashing]
+[keywords message-digest]
+[keywords password]
+[keywords {rfc 2289}]
+[keywords security]
+[moddesc {RFC 2289 A One-Time Password System}]
+[copyright {2006, Pat Thoyts <patthoyts@users.sourceforge.net>}]
+[titledesc {One-Time Passwords}]
+[category {Hashes, checksums, and encryption}]
+[require Tcl 8.2]
+[require otp [opt 1.0.0]]
+[description]
+[para]
+
+This package is an implementation in Tcl of the One-Time Password
+system as described in RFC 2289 (1). This system uses message-digest
+algorithms to sequentially hash a passphrase to create single-use
+passwords. The resulting data is then provided to the user as either
+hexadecimal digits or encoded using a dictionary of 2048 words. This
+system is used by OpenBSD for secure login and can be used as a SASL
+mechanism for authenticating users.
+
+[para]
+
+In this implementation we provide support for four algorithms that are
+included in the tcllib distribution: MD5 (2), MD4 (3), RIPE-MD160 (4)
+and SHA-1 (5).
+
+[section {COMMANDS}]
+
+[list_begin definitions]
+
+[call [cmd "::otp::otp-md4"] [opt "[arg -hex]"] [opt "[arg -words]"] \
+ [arg "-seed seed"] [arg "-count count"] [arg "data"]]
+
+[call [cmd "::otp::otp-md5"] [opt "[arg -hex]"] [opt "[arg -words]"] \
+ [arg "-seed seed"] [arg "-count count"] [arg "data"]]
+
+[call [cmd "::otp::otp-sha1"] [opt "[arg -hex]"] [opt "[arg -words]"] \
+ [arg "-seed seed"] [arg "-count count"] [arg "data"]]
+
+[call [cmd "::otp::otp-rmd160"] [opt "[arg -hex]"] [opt "[arg -words]"] \
+ [arg "-seed seed"] [arg "-count count"] [arg "data"]]
+
+[list_end]
+
+[section {EXAMPLES}]
+
+[example {
+% otp::otp-md5 -count 99 -seed host67821 "My Secret Pass Phrase"
+(binary gibberish)
+% otp::otp-md5 -words -count 99 -seed host67821 "My Secret Pass Phrase"
+SOON ARAB BURG LIMB FILE WAD
+% otp::otp-md5 -hex -count 99 -seed host67821 "My Secret Pass Phrase"
+e249b58257c80087
+}]
+
+[section {REFERENCES}]
+
+[list_begin enumerated]
+
+[enum]
+ Haller, N. et al., "A One-Time Password System", RFC 2289, February 1998.
+ [uri http://www.rfc-editor.org/rfc/rfc2289.txt]
+
+[enum]
+ Rivest, R., "The MD5 Message-Digest Algorithm", RFC 1321, MIT and
+ RSA Data Security, Inc, April 1992.
+ ([uri http://www.rfc-editor.org/rfc/rfc1321.txt])
+
+[enum]
+ Rivest, R., "The MD4 Message Digest Algorithm", RFC 1320, MIT,
+ April 1992. ([uri http://www.rfc-editor.org/rfc/rfc1320.txt])
+
+[enum]
+ H. Dobbertin, A. Bosselaers, B. Preneel,
+ "RIPEMD-160, a strengthened version of RIPEMD"
+ [uri http://www.esat.kuleuven.ac.be/~cosicart/pdf/AB-9601/AB-9601.pdf]
+
+[enum]
+ "Secure Hash Standard", National Institute of Standards
+ and Technology, U.S. Department Of Commerce, April 1995.
+ ([uri http://www.itl.nist.gov/fipspubs/fip180-1.htm])
+
+[list_end]
+
+[vset CATEGORY otp]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/otp/otp.tcl b/tcllib/modules/otp/otp.tcl
new file mode 100644
index 0000000..dede029
--- /dev/null
+++ b/tcllib/modules/otp/otp.tcl
@@ -0,0 +1,430 @@
+# otp.tcl - Copyright (C) 2006 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Tcl implementation of RFC 2289: A One-Time Password System
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+
+package require Tcl 8.2; # tcl minimum version
+
+namespace eval ::otp {
+ namespace export otp-md4 otp-md5 otp-sha1 otp-rmd160
+
+ variable Words {
+ "A" "ABE" "ACE" "ACT" "AD" "ADA" "ADD"
+ "AGO" "AID" "AIM" "AIR" "ALL" "ALP" "AM" "AMY"
+ "AN" "ANA" "AND" "ANN" "ANT" "ANY" "APE" "APS"
+ "APT" "ARC" "ARE" "ARK" "ARM" "ART" "AS" "ASH"
+ "ASK" "AT" "ATE" "AUG" "AUK" "AVE" "AWE" "AWK"
+ "AWL" "AWN" "AX" "AYE" "BAD" "BAG" "BAH" "BAM"
+ "BAN" "BAR" "BAT" "BAY" "BE" "BED" "BEE" "BEG"
+ "BEN" "BET" "BEY" "BIB" "BID" "BIG" "BIN" "BIT"
+ "BOB" "BOG" "BON" "BOO" "BOP" "BOW" "BOY" "BUB"
+ "BUD" "BUG" "BUM" "BUN" "BUS" "BUT" "BUY" "BY"
+ "BYE" "CAB" "CAL" "CAM" "CAN" "CAP" "CAR" "CAT"
+ "CAW" "COD" "COG" "COL" "CON" "COO" "COP" "COT"
+ "COW" "COY" "CRY" "CUB" "CUE" "CUP" "CUR" "CUT"
+ "DAB" "DAD" "DAM" "DAN" "DAR" "DAY" "DEE" "DEL"
+ "DEN" "DES" "DEW" "DID" "DIE" "DIG" "DIN" "DIP"
+ "DO" "DOE" "DOG" "DON" "DOT" "DOW" "DRY" "DUB"
+ "DUD" "DUE" "DUG" "DUN" "EAR" "EAT" "ED" "EEL"
+ "EGG" "EGO" "ELI" "ELK" "ELM" "ELY" "EM" "END"
+ "EST" "ETC" "EVA" "EVE" "EWE" "EYE" "FAD" "FAN"
+ "FAR" "FAT" "FAY" "FED" "FEE" "FEW" "FIB" "FIG"
+ "FIN" "FIR" "FIT" "FLO" "FLY" "FOE" "FOG" "FOR"
+ "FRY" "FUM" "FUN" "FUR" "GAB" "GAD" "GAG" "GAL"
+ "GAM" "GAP" "GAS" "GAY" "GEE" "GEL" "GEM" "GET"
+ "GIG" "GIL" "GIN" "GO" "GOT" "GUM" "GUN" "GUS"
+ "GUT" "GUY" "GYM" "GYP" "HA" "HAD" "HAL" "HAM"
+ "HAN" "HAP" "HAS" "HAT" "HAW" "HAY" "HE" "HEM"
+ "HEN" "HER" "HEW" "HEY" "HI" "HID" "HIM" "HIP"
+ "HIS" "HIT" "HO" "HOB" "HOC" "HOE" "HOG" "HOP"
+ "HOT" "HOW" "HUB" "HUE" "HUG" "HUH" "HUM" "HUT"
+ "I" "ICY" "IDA" "IF" "IKE" "ILL" "INK" "INN"
+ "IO" "ION" "IQ" "IRA" "IRE" "IRK" "IS" "IT"
+ "ITS" "IVY" "JAB" "JAG" "JAM" "JAN" "JAR" "JAW"
+ "JAY" "JET" "JIG" "JIM" "JO" "JOB" "JOE" "JOG"
+ "JOT" "JOY" "JUG" "JUT" "KAY" "KEG" "KEN" "KEY"
+ "KID" "KIM" "KIN" "KIT" "LA" "LAB" "LAC" "LAD"
+ "LAG" "LAM" "LAP" "LAW" "LAY" "LEA" "LED" "LEE"
+ "LEG" "LEN" "LEO" "LET" "LEW" "LID" "LIE" "LIN"
+ "LIP" "LIT" "LO" "LOB" "LOG" "LOP" "LOS" "LOT"
+ "LOU" "LOW" "LOY" "LUG" "LYE" "MA" "MAC" "MAD"
+ "MAE" "MAN" "MAO" "MAP" "MAT" "MAW" "MAY" "ME"
+ "MEG" "MEL" "MEN" "MET" "MEW" "MID" "MIN" "MIT"
+ "MOB" "MOD" "MOE" "MOO" "MOP" "MOS" "MOT" "MOW"
+ "MUD" "MUG" "MUM" "MY" "NAB" "NAG" "NAN" "NAP"
+ "NAT" "NAY" "NE" "NED" "NEE" "NET" "NEW" "NIB"
+ "NIL" "NIP" "NIT" "NO" "NOB" "NOD" "NON" "NOR"
+ "NOT" "NOV" "NOW" "NU" "NUN" "NUT" "O" "OAF"
+ "OAK" "OAR" "OAT" "ODD" "ODE" "OF" "OFF" "OFT"
+ "OH" "OIL" "OK" "OLD" "ON" "ONE" "OR" "ORB"
+ "ORE" "ORR" "OS" "OTT" "OUR" "OUT" "OVA" "OW"
+ "OWE" "OWL" "OWN" "OX" "PA" "PAD" "PAL" "PAM"
+ "PAN" "PAP" "PAR" "PAT" "PAW" "PAY" "PEA" "PEG"
+ "PEN" "PEP" "PER" "PET" "PEW" "PHI" "PI" "PIE"
+ "PIN" "PIT" "PLY" "PO" "POD" "POE" "POP" "POT"
+ "POW" "PRO" "PRY" "PUB" "PUG" "PUN" "PUP" "PUT"
+ "QUO" "RAG" "RAM" "RAN" "RAP" "RAT" "RAW" "RAY"
+ "REB" "RED" "REP" "RET" "RIB" "RID" "RIG" "RIM"
+ "RIO" "RIP" "ROB" "ROD" "ROE" "RON" "ROT" "ROW"
+ "ROY" "RUB" "RUE" "RUG" "RUM" "RUN" "RYE" "SAC"
+ "SAD" "SAG" "SAL" "SAM" "SAN" "SAP" "SAT" "SAW"
+ "SAY" "SEA" "SEC" "SEE" "SEN" "SET" "SEW" "SHE"
+ "SHY" "SIN" "SIP" "SIR" "SIS" "SIT" "SKI" "SKY"
+ "SLY" "SO" "SOB" "SOD" "SON" "SOP" "SOW" "SOY"
+ "SPA" "SPY" "SUB" "SUD" "SUE" "SUM" "SUN" "SUP"
+ "TAB" "TAD" "TAG" "TAN" "TAP" "TAR" "TEA" "TED"
+ "TEE" "TEN" "THE" "THY" "TIC" "TIE" "TIM" "TIN"
+ "TIP" "TO" "TOE" "TOG" "TOM" "TON" "TOO" "TOP"
+ "TOW" "TOY" "TRY" "TUB" "TUG" "TUM" "TUN" "TWO"
+ "UN" "UP" "US" "USE" "VAN" "VAT" "VET" "VIE"
+ "WAD" "WAG" "WAR" "WAS" "WAY" "WE" "WEB" "WED"
+ "WEE" "WET" "WHO" "WHY" "WIN" "WIT" "WOK" "WON"
+ "WOO" "WOW" "WRY" "WU" "YAM" "YAP" "YAW" "YE"
+ "YEA" "YES" "YET" "YOU" "ABED" "ABEL" "ABET" "ABLE"
+ "ABUT" "ACHE" "ACID" "ACME" "ACRE" "ACTA" "ACTS" "ADAM"
+ "ADDS" "ADEN" "AFAR" "AFRO" "AGEE" "AHEM" "AHOY" "AIDA"
+ "AIDE" "AIDS" "AIRY" "AJAR" "AKIN" "ALAN" "ALEC" "ALGA"
+ "ALIA" "ALLY" "ALMA" "ALOE" "ALSO" "ALTO" "ALUM" "ALVA"
+ "AMEN" "AMES" "AMID" "AMMO" "AMOK" "AMOS" "AMRA" "ANDY"
+ "ANEW" "ANNA" "ANNE" "ANTE" "ANTI" "AQUA" "ARAB" "ARCH"
+ "AREA" "ARGO" "ARID" "ARMY" "ARTS" "ARTY" "ASIA" "ASKS"
+ "ATOM" "AUNT" "AURA" "AUTO" "AVER" "AVID" "AVIS" "AVON"
+ "AVOW" "AWAY" "AWRY" "BABE" "BABY" "BACH" "BACK" "BADE"
+ "BAIL" "BAIT" "BAKE" "BALD" "BALE" "BALI" "BALK" "BALL"
+ "BALM" "BAND" "BANE" "BANG" "BANK" "BARB" "BARD" "BARE"
+ "BARK" "BARN" "BARR" "BASE" "BASH" "BASK" "BASS" "BATE"
+ "BATH" "BAWD" "BAWL" "BEAD" "BEAK" "BEAM" "BEAN" "BEAR"
+ "BEAT" "BEAU" "BECK" "BEEF" "BEEN" "BEER" "BEET" "BELA"
+ "BELL" "BELT" "BEND" "BENT" "BERG" "BERN" "BERT" "BESS"
+ "BEST" "BETA" "BETH" "BHOY" "BIAS" "BIDE" "BIEN" "BILE"
+ "BILK" "BILL" "BIND" "BING" "BIRD" "BITE" "BITS" "BLAB"
+ "BLAT" "BLED" "BLEW" "BLOB" "BLOC" "BLOT" "BLOW" "BLUE"
+ "BLUM" "BLUR" "BOAR" "BOAT" "BOCA" "BOCK" "BODE" "BODY"
+ "BOGY" "BOHR" "BOIL" "BOLD" "BOLO" "BOLT" "BOMB" "BONA"
+ "BOND" "BONE" "BONG" "BONN" "BONY" "BOOK" "BOOM" "BOON"
+ "BOOT" "BORE" "BORG" "BORN" "BOSE" "BOSS" "BOTH" "BOUT"
+ "BOWL" "BOYD" "BRAD" "BRAE" "BRAG" "BRAN" "BRAY" "BRED"
+ "BREW" "BRIG" "BRIM" "BROW" "BUCK" "BUDD" "BUFF" "BULB"
+ "BULK" "BULL" "BUNK" "BUNT" "BUOY" "BURG" "BURL" "BURN"
+ "BURR" "BURT" "BURY" "BUSH" "BUSS" "BUST" "BUSY" "BYTE"
+ "CADY" "CAFE" "CAGE" "CAIN" "CAKE" "CALF" "CALL" "CALM"
+ "CAME" "CANE" "CANT" "CARD" "CARE" "CARL" "CARR" "CART"
+ "CASE" "CASH" "CASK" "CAST" "CAVE" "CEIL" "CELL" "CENT"
+ "CERN" "CHAD" "CHAR" "CHAT" "CHAW" "CHEF" "CHEN" "CHEW"
+ "CHIC" "CHIN" "CHOU" "CHOW" "CHUB" "CHUG" "CHUM" "CITE"
+ "CITY" "CLAD" "CLAM" "CLAN" "CLAW" "CLAY" "CLOD" "CLOG"
+ "CLOT" "CLUB" "CLUE" "COAL" "COAT" "COCA" "COCK" "COCO"
+ "CODA" "CODE" "CODY" "COED" "COIL" "COIN" "COKE" "COLA"
+ "COLD" "COLT" "COMA" "COMB" "COME" "COOK" "COOL" "COON"
+ "COOT" "CORD" "CORE" "CORK" "CORN" "COST" "COVE" "COWL"
+ "CRAB" "CRAG" "CRAM" "CRAY" "CREW" "CRIB" "CROW" "CRUD"
+ "CUBA" "CUBE" "CUFF" "CULL" "CULT" "CUNY" "CURB" "CURD"
+ "CURE" "CURL" "CURT" "CUTS" "DADE" "DALE" "DAME" "DANA"
+ "DANE" "DANG" "DANK" "DARE" "DARK" "DARN" "DART" "DASH"
+ "DATA" "DATE" "DAVE" "DAVY" "DAWN" "DAYS" "DEAD" "DEAF"
+ "DEAL" "DEAN" "DEAR" "DEBT" "DECK" "DEED" "DEEM" "DEER"
+ "DEFT" "DEFY" "DELL" "DENT" "DENY" "DESK" "DIAL" "DICE"
+ "DIED" "DIET" "DIME" "DINE" "DING" "DINT" "DIRE" "DIRT"
+ "DISC" "DISH" "DISK" "DIVE" "DOCK" "DOES" "DOLE" "DOLL"
+ "DOLT" "DOME" "DONE" "DOOM" "DOOR" "DORA" "DOSE" "DOTE"
+ "DOUG" "DOUR" "DOVE" "DOWN" "DRAB" "DRAG" "DRAM" "DRAW"
+ "DREW" "DRUB" "DRUG" "DRUM" "DUAL" "DUCK" "DUCT" "DUEL"
+ "DUET" "DUKE" "DULL" "DUMB" "DUNE" "DUNK" "DUSK" "DUST"
+ "DUTY" "EACH" "EARL" "EARN" "EASE" "EAST" "EASY" "EBEN"
+ "ECHO" "EDDY" "EDEN" "EDGE" "EDGY" "EDIT" "EDNA" "EGAN"
+ "ELAN" "ELBA" "ELLA" "ELSE" "EMIL" "EMIT" "EMMA" "ENDS"
+ "ERIC" "EROS" "EVEN" "EVER" "EVIL" "EYED" "FACE" "FACT"
+ "FADE" "FAIL" "FAIN" "FAIR" "FAKE" "FALL" "FAME" "FANG"
+ "FARM" "FAST" "FATE" "FAWN" "FEAR" "FEAT" "FEED" "FEEL"
+ "FEET" "FELL" "FELT" "FEND" "FERN" "FEST" "FEUD" "FIEF"
+ "FIGS" "FILE" "FILL" "FILM" "FIND" "FINE" "FINK" "FIRE"
+ "FIRM" "FISH" "FISK" "FIST" "FITS" "FIVE" "FLAG" "FLAK"
+ "FLAM" "FLAT" "FLAW" "FLEA" "FLED" "FLEW" "FLIT" "FLOC"
+ "FLOG" "FLOW" "FLUB" "FLUE" "FOAL" "FOAM" "FOGY" "FOIL"
+ "FOLD" "FOLK" "FOND" "FONT" "FOOD" "FOOL" "FOOT" "FORD"
+ "FORE" "FORK" "FORM" "FORT" "FOSS" "FOUL" "FOUR" "FOWL"
+ "FRAU" "FRAY" "FRED" "FREE" "FRET" "FREY" "FROG" "FROM"
+ "FUEL" "FULL" "FUME" "FUND" "FUNK" "FURY" "FUSE" "FUSS"
+ "GAFF" "GAGE" "GAIL" "GAIN" "GAIT" "GALA" "GALE" "GALL"
+ "GALT" "GAME" "GANG" "GARB" "GARY" "GASH" "GATE" "GAUL"
+ "GAUR" "GAVE" "GAWK" "GEAR" "GELD" "GENE" "GENT" "GERM"
+ "GETS" "GIBE" "GIFT" "GILD" "GILL" "GILT" "GINA" "GIRD"
+ "GIRL" "GIST" "GIVE" "GLAD" "GLEE" "GLEN" "GLIB" "GLOB"
+ "GLOM" "GLOW" "GLUE" "GLUM" "GLUT" "GOAD" "GOAL" "GOAT"
+ "GOER" "GOES" "GOLD" "GOLF" "GONE" "GONG" "GOOD" "GOOF"
+ "GORE" "GORY" "GOSH" "GOUT" "GOWN" "GRAB" "GRAD" "GRAY"
+ "GREG" "GREW" "GREY" "GRID" "GRIM" "GRIN" "GRIT" "GROW"
+ "GRUB" "GULF" "GULL" "GUNK" "GURU" "GUSH" "GUST" "GWEN"
+ "GWYN" "HAAG" "HAAS" "HACK" "HAIL" "HAIR" "HALE" "HALF"
+ "HALL" "HALO" "HALT" "HAND" "HANG" "HANK" "HANS" "HARD"
+ "HARK" "HARM" "HART" "HASH" "HAST" "HATE" "HATH" "HAUL"
+ "HAVE" "HAWK" "HAYS" "HEAD" "HEAL" "HEAR" "HEAT" "HEBE"
+ "HECK" "HEED" "HEEL" "HEFT" "HELD" "HELL" "HELM" "HERB"
+ "HERD" "HERE" "HERO" "HERS" "HESS" "HEWN" "HICK" "HIDE"
+ "HIGH" "HIKE" "HILL" "HILT" "HIND" "HINT" "HIRE" "HISS"
+ "HIVE" "HOBO" "HOCK" "HOFF" "HOLD" "HOLE" "HOLM" "HOLT"
+ "HOME" "HONE" "HONK" "HOOD" "HOOF" "HOOK" "HOOT" "HORN"
+ "HOSE" "HOST" "HOUR" "HOVE" "HOWE" "HOWL" "HOYT" "HUCK"
+ "HUED" "HUFF" "HUGE" "HUGH" "HUGO" "HULK" "HULL" "HUNK"
+ "HUNT" "HURD" "HURL" "HURT" "HUSH" "HYDE" "HYMN" "IBIS"
+ "ICON" "IDEA" "IDLE" "IFFY" "INCA" "INCH" "INTO" "IONS"
+ "IOTA" "IOWA" "IRIS" "IRMA" "IRON" "ISLE" "ITCH" "ITEM"
+ "IVAN" "JACK" "JADE" "JAIL" "JAKE" "JANE" "JAVA" "JEAN"
+ "JEFF" "JERK" "JESS" "JEST" "JIBE" "JILL" "JILT" "JIVE"
+ "JOAN" "JOBS" "JOCK" "JOEL" "JOEY" "JOHN" "JOIN" "JOKE"
+ "JOLT" "JOVE" "JUDD" "JUDE" "JUDO" "JUDY" "JUJU" "JUKE"
+ "JULY" "JUNE" "JUNK" "JUNO" "JURY" "JUST" "JUTE" "KAHN"
+ "KALE" "KANE" "KANT" "KARL" "KATE" "KEEL" "KEEN" "KENO"
+ "KENT" "KERN" "KERR" "KEYS" "KICK" "KILL" "KIND" "KING"
+ "KIRK" "KISS" "KITE" "KLAN" "KNEE" "KNEW" "KNIT" "KNOB"
+ "KNOT" "KNOW" "KOCH" "KONG" "KUDO" "KURD" "KURT" "KYLE"
+ "LACE" "LACK" "LACY" "LADY" "LAID" "LAIN" "LAIR" "LAKE"
+ "LAMB" "LAME" "LAND" "LANE" "LANG" "LARD" "LARK" "LASS"
+ "LAST" "LATE" "LAUD" "LAVA" "LAWN" "LAWS" "LAYS" "LEAD"
+ "LEAF" "LEAK" "LEAN" "LEAR" "LEEK" "LEER" "LEFT" "LEND"
+ "LENS" "LENT" "LEON" "LESK" "LESS" "LEST" "LETS" "LIAR"
+ "LICE" "LICK" "LIED" "LIEN" "LIES" "LIEU" "LIFE" "LIFT"
+ "LIKE" "LILA" "LILT" "LILY" "LIMA" "LIMB" "LIME" "LIND"
+ "LINE" "LINK" "LINT" "LION" "LISA" "LIST" "LIVE" "LOAD"
+ "LOAF" "LOAM" "LOAN" "LOCK" "LOFT" "LOGE" "LOIS" "LOLA"
+ "LONE" "LONG" "LOOK" "LOON" "LOOT" "LORD" "LORE" "LOSE"
+ "LOSS" "LOST" "LOUD" "LOVE" "LOWE" "LUCK" "LUCY" "LUGE"
+ "LUKE" "LULU" "LUND" "LUNG" "LURA" "LURE" "LURK" "LUSH"
+ "LUST" "LYLE" "LYNN" "LYON" "LYRA" "MACE" "MADE" "MAGI"
+ "MAID" "MAIL" "MAIN" "MAKE" "MALE" "MALI" "MALL" "MALT"
+ "MANA" "MANN" "MANY" "MARC" "MARE" "MARK" "MARS" "MART"
+ "MARY" "MASH" "MASK" "MASS" "MAST" "MATE" "MATH" "MAUL"
+ "MAYO" "MEAD" "MEAL" "MEAN" "MEAT" "MEEK" "MEET" "MELD"
+ "MELT" "MEMO" "MEND" "MENU" "MERT" "MESH" "MESS" "MICE"
+ "MIKE" "MILD" "MILE" "MILK" "MILL" "MILT" "MIMI" "MIND"
+ "MINE" "MINI" "MINK" "MINT" "MIRE" "MISS" "MIST" "MITE"
+ "MITT" "MOAN" "MOAT" "MOCK" "MODE" "MOLD" "MOLE" "MOLL"
+ "MOLT" "MONA" "MONK" "MONT" "MOOD" "MOON" "MOOR" "MOOT"
+ "MORE" "MORN" "MORT" "MOSS" "MOST" "MOTH" "MOVE" "MUCH"
+ "MUCK" "MUDD" "MUFF" "MULE" "MULL" "MURK" "MUSH" "MUST"
+ "MUTE" "MUTT" "MYRA" "MYTH" "NAGY" "NAIL" "NAIR" "NAME"
+ "NARY" "NASH" "NAVE" "NAVY" "NEAL" "NEAR" "NEAT" "NECK"
+ "NEED" "NEIL" "NELL" "NEON" "NERO" "NESS" "NEST" "NEWS"
+ "NEWT" "NIBS" "NICE" "NICK" "NILE" "NINA" "NINE" "NOAH"
+ "NODE" "NOEL" "NOLL" "NONE" "NOOK" "NOON" "NORM" "NOSE"
+ "NOTE" "NOUN" "NOVA" "NUDE" "NULL" "NUMB" "OATH" "OBEY"
+ "OBOE" "ODIN" "OHIO" "OILY" "OINT" "OKAY" "OLAF" "OLDY"
+ "OLGA" "OLIN" "OMAN" "OMEN" "OMIT" "ONCE" "ONES" "ONLY"
+ "ONTO" "ONUS" "ORAL" "ORGY" "OSLO" "OTIS" "OTTO" "OUCH"
+ "OUST" "OUTS" "OVAL" "OVEN" "OVER" "OWLY" "OWNS" "QUAD"
+ "QUIT" "QUOD" "RACE" "RACK" "RACY" "RAFT" "RAGE" "RAID"
+ "RAIL" "RAIN" "RAKE" "RANK" "RANT" "RARE" "RASH" "RATE"
+ "RAVE" "RAYS" "READ" "REAL" "REAM" "REAR" "RECK" "REED"
+ "REEF" "REEK" "REEL" "REID" "REIN" "RENA" "REND" "RENT"
+ "REST" "RICE" "RICH" "RICK" "RIDE" "RIFT" "RILL" "RIME"
+ "RING" "RINK" "RISE" "RISK" "RITE" "ROAD" "ROAM" "ROAR"
+ "ROBE" "ROCK" "RODE" "ROIL" "ROLL" "ROME" "ROOD" "ROOF"
+ "ROOK" "ROOM" "ROOT" "ROSA" "ROSE" "ROSS" "ROSY" "ROTH"
+ "ROUT" "ROVE" "ROWE" "ROWS" "RUBE" "RUBY" "RUDE" "RUDY"
+ "RUIN" "RULE" "RUNG" "RUNS" "RUNT" "RUSE" "RUSH" "RUSK"
+ "RUSS" "RUST" "RUTH" "SACK" "SAFE" "SAGE" "SAID" "SAIL"
+ "SALE" "SALK" "SALT" "SAME" "SAND" "SANE" "SANG" "SANK"
+ "SARA" "SAUL" "SAVE" "SAYS" "SCAN" "SCAR" "SCAT" "SCOT"
+ "SEAL" "SEAM" "SEAR" "SEAT" "SEED" "SEEK" "SEEM" "SEEN"
+ "SEES" "SELF" "SELL" "SEND" "SENT" "SETS" "SEWN" "SHAG"
+ "SHAM" "SHAW" "SHAY" "SHED" "SHIM" "SHIN" "SHOD" "SHOE"
+ "SHOT" "SHOW" "SHUN" "SHUT" "SICK" "SIDE" "SIFT" "SIGH"
+ "SIGN" "SILK" "SILL" "SILO" "SILT" "SINE" "SING" "SINK"
+ "SIRE" "SITE" "SITS" "SITU" "SKAT" "SKEW" "SKID" "SKIM"
+ "SKIN" "SKIT" "SLAB" "SLAM" "SLAT" "SLAY" "SLED" "SLEW"
+ "SLID" "SLIM" "SLIT" "SLOB" "SLOG" "SLOT" "SLOW" "SLUG"
+ "SLUM" "SLUR" "SMOG" "SMUG" "SNAG" "SNOB" "SNOW" "SNUB"
+ "SNUG" "SOAK" "SOAR" "SOCK" "SODA" "SOFA" "SOFT" "SOIL"
+ "SOLD" "SOME" "SONG" "SOON" "SOOT" "SORE" "SORT" "SOUL"
+ "SOUR" "SOWN" "STAB" "STAG" "STAN" "STAR" "STAY" "STEM"
+ "STEW" "STIR" "STOW" "STUB" "STUN" "SUCH" "SUDS" "SUIT"
+ "SULK" "SUMS" "SUNG" "SUNK" "SURE" "SURF" "SWAB" "SWAG"
+ "SWAM" "SWAN" "SWAT" "SWAY" "SWIM" "SWUM" "TACK" "TACT"
+ "TAIL" "TAKE" "TALE" "TALK" "TALL" "TANK" "TASK" "TATE"
+ "TAUT" "TEAL" "TEAM" "TEAR" "TECH" "TEEM" "TEEN" "TEET"
+ "TELL" "TEND" "TENT" "TERM" "TERN" "TESS" "TEST" "THAN"
+ "THAT" "THEE" "THEM" "THEN" "THEY" "THIN" "THIS" "THUD"
+ "THUG" "TICK" "TIDE" "TIDY" "TIED" "TIER" "TILE" "TILL"
+ "TILT" "TIME" "TINA" "TINE" "TINT" "TINY" "TIRE" "TOAD"
+ "TOGO" "TOIL" "TOLD" "TOLL" "TONE" "TONG" "TONY" "TOOK"
+ "TOOL" "TOOT" "TORE" "TORN" "TOTE" "TOUR" "TOUT" "TOWN"
+ "TRAG" "TRAM" "TRAY" "TREE" "TREK" "TRIG" "TRIM" "TRIO"
+ "TROD" "TROT" "TROY" "TRUE" "TUBA" "TUBE" "TUCK" "TUFT"
+ "TUNA" "TUNE" "TUNG" "TURF" "TURN" "TUSK" "TWIG" "TWIN"
+ "TWIT" "ULAN" "UNIT" "URGE" "USED" "USER" "USES" "UTAH"
+ "VAIL" "VAIN" "VALE" "VARY" "VASE" "VAST" "VEAL" "VEDA"
+ "VEIL" "VEIN" "VEND" "VENT" "VERB" "VERY" "VETO" "VICE"
+ "VIEW" "VINE" "VISE" "VOID" "VOLT" "VOTE" "WACK" "WADE"
+ "WAGE" "WAIL" "WAIT" "WAKE" "WALE" "WALK" "WALL" "WALT"
+ "WAND" "WANE" "WANG" "WANT" "WARD" "WARM" "WARN" "WART"
+ "WASH" "WAST" "WATS" "WATT" "WAVE" "WAVY" "WAYS" "WEAK"
+ "WEAL" "WEAN" "WEAR" "WEED" "WEEK" "WEIR" "WELD" "WELL"
+ "WELT" "WENT" "WERE" "WERT" "WEST" "WHAM" "WHAT" "WHEE"
+ "WHEN" "WHET" "WHOA" "WHOM" "WICK" "WIFE" "WILD" "WILL"
+ "WIND" "WINE" "WING" "WINK" "WINO" "WIRE" "WISE" "WISH"
+ "WITH" "WOLF" "WONT" "WOOD" "WOOL" "WORD" "WORE" "WORK"
+ "WORM" "WORN" "WOVE" "WRIT" "WYNN" "YALE" "YANG" "YANK"
+ "YARD" "YARN" "YAWL" "YAWN" "YEAH" "YEAR" "YELL" "YOGA"
+ "YOKE"
+ }
+}
+
+# Encode 64 bits as words selected from the RFC 2289 dictionary.
+# See the RFC for details. Briefly the input is broken into 11 bit
+# chunks + 2bits of checksum and each chunk selects a word from the
+# 2048 word table.
+#
+proc ::otp::otp_encode {data} {
+ variable Words
+ if {[string length $data] != 8} {
+ set bc [expr {[string length $data] * 8}]
+ return -code error "invalid input: 64 bits of data\
+ required and $bc bits provided"
+ }
+ binary scan $data II A B
+
+ set cksum 0
+ foreach w [list $A $B] {
+ for {set n 0} {$n < 32} {incr n 2} {
+ incr cksum [expr {($w >> $n) & 3}]
+ }
+ }
+
+ set W0 [expr { (($A & 0xFFE00000) >> 21) & 0x07ff}]
+ set W1 [expr { (($A & 0x001FFC00) >> 10)}]
+ set W2 [expr { (($A & 0x000003FF) << 1) | (($B >> 31) & 0x1)}]
+ set W3 [expr { ($B & 0x7FF00000) >> 20}]
+ set W4 [expr { ($B & 0x000FFE00) >> 9}]
+ set W5 [expr { (($B & 0x000001FF) << 2) | ($cksum & 3)}]
+
+ foreach w [list $W0 $W1 $W2 $W3 $W4 $W5] {
+ lappend words [lindex $Words $w]
+ }
+
+ return $words
+}
+
+# Fold a 128 bit digest in little-endian format into a 64 bit
+# little-endian output
+proc ::otp::Fold64LE {digest} {
+ binary scan $digest iiii A B C D
+ set w0 [expr {($A ^ $C) & 0xffffffff}]
+ set w1 [expr {($B ^ $D) & 0xffffffff}]
+ binary format ii $w0 $w1
+}
+
+# Fold a160 bit big-endian digest (SHA-1) into a 64 bit
+# little-endian output
+proc ::otp::Fold160BE {digest} {
+ binary scan $digest IIIII A B C D E
+ set w0 [expr {(($A ^ $C) ^ $E) & 0xffffffff}]
+ set w1 [expr { ($B ^ $D) & 0xffffffff}]
+ binary format ii $w0 $w1
+}
+
+# Fold a 160 bit little-endian digest into a 64 bit
+# little-endian output.
+proc ::otp::Fold160LE {digest} {
+ binary scan $digest iiiii A B C D E
+ set w0 [expr {(($A ^ $C) ^ $E) & 0xffffffff}]
+ set w1 [expr { ($B ^ $D) & 0xffffffff}]
+ binary format ii $w0 $w1
+}
+
+# Description:
+# Pop the nth element off a list. Used in options processing.
+#
+proc ::otp::Pop {varname {nth 0}} {
+ upvar $varname args
+ set r [lindex $args $nth]
+ set args [lreplace $args $nth $nth]
+ return $r
+}
+
+proc ::otp::otp {args} {
+ array set opts {-hash md5 -seed {} -count 0 -hex 0 -words 0}
+ while {[string match -* [set option [lindex $args 0]]]} {
+ switch -exact -- $option {
+ -hex { set opts(-hex) 1}
+ -word -
+ -words { set opts(-words) 1 }
+ -hash { set opts(-hash) [Pop args 1] }
+ -seed { set opts(-seed) [Pop args 1] }
+ -count { set opts(-count) [Pop args 1] }
+ default {
+ if {[llength $args] == 1} { break }
+ if {[string compare $option "--"] == 0} { Pop args; break }
+ set err [join [lsort [array names opts]] ", "]
+ return -code error "bad option \"$option\":\
+ must be one of $err"
+ }
+ }
+ Pop args
+ }
+
+ set data [lindex $args 0]
+
+ if {[string length $opts(-seed)] < 1 || [string length $opts(-seed)] > 16} {
+ return -code error "seed must be between 1 and 16 characters in length"
+ }
+ switch -exact -- $opts(-hash) {
+ md4 { set func ::md4::md4 ; set fold ::otp::Fold64LE }
+ md5 { set func ::md5::md5 ; set fold ::otp::Fold64LE }
+ sha1 { set func ::otp::sha1 ; set fold ::otp::Fold160BE }
+ rmd160 { set func ::ripemd::ripemd160 ; set fold ::otp::Fold160LE }
+ default {
+ return -code error "invalid hash type \"$opts(-hash)\":\
+ must be one of md4, md5, rmd160 or sha1"
+ }
+ }
+ # RFC 2289: Initial step
+ set S [$fold [$func [string tolower $opts(-seed)]$data]]
+
+ # RFC2289:6 Computation step
+ for {set n 0} {$n < $opts(-count)} {incr n} {
+ set S [$fold [$func $S]]
+ }
+
+ if {$opts(-hex)} {
+ binary scan $S H* S
+ } elseif {$opts(-words)} {
+ set S [otp_encode $S]
+ }
+ return $S
+}
+
+proc ::otp::otp-md4 {args} {
+ package require md4
+ return [eval [linsert $args 0 [namespace current]::otp -hash md4]]
+}
+
+proc ::otp::otp-md5 {args} {
+ package require md5
+ return [eval [linsert $args 0 [namespace current]::otp -hash md5]]
+}
+
+proc ::otp::otp-sha1 {args} {
+ package require sha1
+ interp alias {} ::otp::sha1 {} ::sha1::sha1 -bin
+ return [eval [linsert $args 0 [namespace current]::otp -hash sha1]]
+}
+
+proc ::otp::otp-rmd160 {args} {
+ package require ripemd160
+ return [eval [linsert $args 0 [namespace current]::otp -hash rmd160]]
+}
+
+# -------------------------------------------------------------------------
+
+package provide otp 1.0.0
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/otp/otp.test b/tcllib/modules/otp/otp.test
new file mode 100644
index 0000000..83d3ff2
--- /dev/null
+++ b/tcllib/modules/otp/otp.test
@@ -0,0 +1,146 @@
+# -*- tcl -*-
+# otp.test: tests the OTP implementation. Most of the tests are directly
+# copied from RFC 2289.
+#
+# 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) 2006 Patrick Thoyts
+#
+# RCS: @(#) $Id: otp.test,v 1.2 2006/10/09 21:41:41 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal otp.tcl otp
+}
+
+# -------------------------------------------------------------------------
+
+set tests_md5 {
+ 0 "This is a test." "TeSt" 0 "9E876134D90499DD" "INCH SEA ANNE LONG AHEM TOUR"
+ 1 "This is a test." "TeSt" 1 "7965E05436F5029F" "EASE OIL FUM CURE AWRY AVIS"
+ 2 "This is a test." "TeSt" 99 "50FE1962C4965880" "BAIL TUFT BITS GANG CHEF THY"
+ 3 "AbCdEfGhIjK" "alpha1" 0 "87066DD9644BF206" "FULL PEW DOWN ONCE MORT ARC"
+ 4 "AbCdEfGhIjK" "alpha1" 1 "7CD34C1040ADD14B" "FACT HOOF AT FIST SITE KENT"
+ 5 "AbCdEfGhIjK" "alpha1" 99 "5AA37A81F212146C" "BODE HOP JAKE STOW JUT RAP"
+ 6 "OTP's are good" "correct" 0 "F205753943DE4CF9" "ULAN NEW ARMY FUSE SUIT EYED"
+ 7 "OTP's are good" "correct" 1 "DDCDAC956F234937" "SKIM CULT LOB SLAM POE HOWL"
+ 8 "OTP's are good" "correct" 99 "B203E28FA525BE47" "LONG IVY JULY AJAR BOND LEE"
+}
+
+foreach {ndx pass seed cnt hex wrds} $tests_md5 {
+ test otp-md5-hex-$ndx "otp-md5 check hex result" {
+ list [catch {
+ set res [::otp::otp-md5 -hex -seed $seed -count $cnt $pass]
+ string toupper $res
+ } msg] $msg
+ } [list 0 $hex]
+}
+
+foreach {ndx pass seed cnt hex wrds} $tests_md5 {
+ test otp-md5-words-$ndx "otp-md5 check words encoding" {
+ list [catch {
+ set res [::otp::otp-md5 -words -seed $seed -count $cnt $pass]
+ } msg] $msg
+ } [list 0 $wrds]
+}
+
+
+set tests_md4 {
+ 0 "This is a test." "TeSt" 0 "D1854218EBBB0B51" "ROME MUG FRED SCAN LIVE LACE"
+ 1 "This is a test." "TeSt" 1 "63473EF01CD0B444" "CARD SAD MINI RYE COL KIN"
+ 2 "This is a test." "TeSt" 99 "C5E612776E6C237A" "NOTE OUT IBIS SINK NAVE MODE"
+ 3 "AbCdEfGhIjK" "alpha1" 0 "50076F47EB1ADE4E" "AWAY SEN ROOK SALT LICE MAP"
+ 4 "AbCdEfGhIjK" "alpha1" 1 "65D20D1949B5F7AB" "CHEW GRIM WU HANG BUCK SAID"
+ 5 "AbCdEfGhIjK" "alpha1" 99 "D150C82CCE6F62D1" "ROIL FREE COG HUNK WAIT COCA"
+ 6 "OTP's are good" "correct" 0 "849C79D4F6F55388" "FOOL STEM DONE TOOL BECK NILE"
+ 7 "OTP's are good" "correct" 1 "8C0992FB250847B1" "GIST AMOS MOOT AIDS FOOD SEEM"
+ 8 "OTP's are good" "correct" 99 "3F3BF4B4145FD74B" "TAG SLOW NOV MIN WOOL KENO"
+}
+
+foreach {ndx pass seed cnt hex wrds} $tests_md4 {
+ test otp-md4-hex-$ndx "otp-md4 check hex result" {
+ list [catch {
+ set res [::otp::otp-md4 -hex -seed $seed -count $cnt $pass]
+ string toupper $res
+ } msg] $msg
+ } [list 0 $hex]
+}
+
+foreach {ndx pass seed cnt hex wrds} $tests_md4 {
+ test otp-md4-words-$ndx "otp-md4 check words encoding" {
+ list [catch {
+ set res [::otp::otp-md4 -words -seed $seed -count $cnt $pass]
+ } msg] $msg
+ } [list 0 $wrds]
+}
+
+set tests_sha1 {
+ 0 "This is a test." "TeSt" 0 "BB9E6AE1979D8FF4" "MILT VARY MAST OK SEES WENT"
+ 1 "This is a test." "TeSt" 1 "63D936639734385B" "CART OTTO HIVE ODE VAT NUT"
+ 2 "This is a test." "TeSt" 99 "87FEC7768B73CCF9" "GAFF WAIT SKID GIG SKY EYED"
+ 3 "AbCdEfGhIjK" "alpha1" 0 "AD85F658EBE383C9" "LEST OR HEEL SCOT ROB SUIT"
+ 4 "AbCdEfGhIjK" "alpha1" 1 "D07CE229B5CF119B" "RITE TAKE GELD COST TUNE RECK"
+ 5 "AbCdEfGhIjK" "alpha1" 99 "27BC71035AAF3DC6" "MAY STAR TIN LYON VEDA STAN"
+ 6 "OTP's are good" "correct" 0 "D51F3E99BF8E6F0B" "RUST WELT KICK FELL TAIL FRAU"
+ 7 "OTP's are good" "correct" 1 "82AEB52D943774E4" "FLIT DOSE ALSO MEW DRUM DEFY"
+ 8 "OTP's are good" "correct" 99 "4F296A74FE1567EC" "AURA ALOE HURL WING BERG WAIT"
+}
+
+foreach {ndx pass seed cnt hex wrds} $tests_sha1 {
+ test otp-sha1-hex-$ndx "otp-sha1 check hex result" {
+ list [catch {
+ set res [::otp::otp-sha1 -hex -seed $seed -count $cnt $pass]
+ string toupper $res
+ } msg] $msg
+ } [list 0 $hex]
+}
+
+foreach {ndx pass seed cnt hex wrds} $tests_sha1 {
+ test otp-sha1-words-$ndx "otp-sha1 check words encoding" {
+ list [catch {
+ set res [::otp::otp-sha1 -words -seed $seed -count $cnt $pass]
+ } msg] $msg
+ } [list 0 $wrds]
+}
+
+set tests_rmd160 {
+ 0 "This is a test." "TeSt" 0 "3A1BFB10A64B4CCD" "SAG SLUG NICE AMOS LUSH CHUM"
+ 1 "This is a test." "TeSt" 1 "39D56BF655E65DE7" "SAC LAVA WORD LEAD CHEW VAST"
+ 2 "This is a test." "TeSt" 99 "42F84BA862941033" "UN NAVY THEE NOLL TO HEN"
+ 3 "AbCdEfGhIjK" "alpha1" 0 "726EDD1BB5DB3642" "DENY DREW YEA COVE LOWE JUG"
+ 4 "AbCdEfGhIjK" "alpha1" 1 "46A231C501A1D2CE" "YAW ELY DEBT ARK IDA CLAW"
+ 5 "AbCdEfGhIjK" "alpha1" 99 "848664EF3A300CC9" "FOOL PER SHE DOCK ADD CENT"
+ 6 "OTP's are good" "correct" 0 "F90D03CC969208C8" "WEAN CLUB VALE NOW JOB CASH"
+ 7 "OTP's are good" "correct" 1 "B6F5D25A08A90009" "MANA LIEU HELL ELK GREW AVE"
+ 8 "OTP's are good" "correct" 99 "C890C1F05018BA5F" "ONCE FRAY EROS JADE GINA ONE"
+}
+
+foreach {ndx pass seed cnt hex wrds} $tests_rmd160 {
+ test otp-rmd160-hex-$ndx "otp-rmd160 check hex result" {
+ list [catch {
+ set res [::otp::otp-rmd160 -hex -seed $seed -count $cnt $pass]
+ string toupper $res
+ } msg] $msg
+ } [list 0 $hex]
+}
+
+foreach {ndx pass seed cnt hex wrds} $tests_rmd160 {
+ test otp-rmd160-words-$ndx "otp-rmd160 check words result" {
+ list [catch {
+ set res [::otp::otp-rmd160 -words -seed $seed -count $cnt $pass]
+ } msg] $msg
+ } [list 0 $wrds]
+}
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
diff --git a/tcllib/modules/otp/pkgIndex.tcl b/tcllib/modules/otp/pkgIndex.tcl
new file mode 100644
index 0000000..803854b
--- /dev/null
+++ b/tcllib/modules/otp/pkgIndex.tcl
@@ -0,0 +1,3 @@
+# pkgIndex.tcl -*- tcl -*-
+if {![package vsatisfies [package provide Tcl] 8.2]} { return }
+package ifneeded otp 1.0.0 [list source [file join $dir otp.tcl]]
diff --git a/tcllib/modules/page/ChangeLog b/tcllib/modules/page/ChangeLog
new file mode 100644
index 0000000..05b2585
--- /dev/null
+++ b/tcllib/modules/page/ChangeLog
@@ -0,0 +1,419 @@
+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-11-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * support/installation/modules.tcl: [Bug 3425271], reported
+ * support/installation/actions.tcl: by Stuart Cassoff. Extended
+ * apps/page: the installer to install the .template files as
+ well. Extended auto_path in the application to find the standard
+ plugins in the installation.
+
+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-08-31 Andreas Kupries <andreask@activestate.com>
+
+ * page_util_norm_peg.man: New files. Two, for the remaining utility
+ * page_util_norm_lemon.man: packages. Lemon docs are partial.
+
+ * page_util_peg.man: New files. Three more manpages, for most of
+ * page_util_quote.man: the utility packages.
+ * page_util_flow.man:
+
+2007-08-30 Andreas Kupries <andreask@activestate.com>
+
+ * page_pluginmgr.man: First documentation for the packages, intro,
+ * page_intro.man: and the plugin management.
+ * pluginmgr.tcl: Fixed a typo in a comment.
+
+2007-06-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pluginmgr.tcl: Replaced deprecated {expand} syntax in comments
+ with {*}.
+
+2007-03-28 Andreas Kupries <andreask@activestate.com>
+
+ * apps/page: Added a block of meta data.
+
+2007-03-23 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Added MD hints.
+
+2007-03-21 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Fixed version mismatches, index vs. package.
+ * plugins/pkgIndex.tcl:
+ * plugins/writer_mecpu.tcl:
+
+2007-03-07 Andreas Kupries <andreask@activestate.com>
+
+ * compiler_peg_mecpu.tcl: Fixed typo in name of required package
+ * pkgIndex.tcl: ('gasm;, was incorrectly 'gas'). Bumped
+ to version 0.1.1.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * pkgIndex.tcl: Bumped version to 0.2
+ * pluginmgr.tcl:
+
+2006-06-30 Andreas Kupries <akupries@shaw.ca>
+
+ * compiler_peg_mecpu.tcl: New packages generating ME
+ * gen_peg_mecpu.tcl: instructions for the CPU(core).
+ * gen_peg_mecpu.template: And page plugins using them.
+ * plugins/pkgIndex.tcl:
+ * plugins/transform_mecpu.tcl:
+ * plugins/writer_mecpu.tcl:
+ * pkgIndex.tcl:
+
+ * pluginmgr.tcl: Extended the page plugin environment with
+ commands allowing a plugin to write files. Intended for the
+ debugging of plugins, i.e. the dumping of internal state. The
+ destination for such files however are restricted to the current
+ working directory and its sub-directories. Currently only the
+ MEcpu compiler package has code to use this, to write the
+ intermediary graphs and some statistics (Disabled through
+ comments however).
+
+2006-01-11 Andreas Kupries <andreask@activestate.com>
+
+ * util_norm_peg.tcl: Inserted pragmas for the MDgen
+ * util_norm_lemon.tcl: application hinting that the
+ * gen_peg_me.tcl: pseudo-package 'page::plugin'
+ * analysis_peg_emodes.tcl: is not a true dependency.
+ * analysis_peg_minimize.tcl:
+ * analysis_peg_realizable.tcl:
+ * analysis_peg_reachable.tcl:
+
+ * analysis_peg_minimize.tcl: Changed bad reference to 'useful' to
+ the correct string, 'realizable'.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-09-28 Andreas Kupries <andreask@activestate.com>
+
+ * NOTES.txt: Renamed from NOTES. This file had the same name as a
+ directory, causing the Windows and OS X filesystem to trip badly
+ as they considered both identical.
+
+2005-09-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * plugins/config_peg.tcl: Fixed version inconsistency.
+
+ * gen_peg_canon.tcl: Fixed frink warnings.
+ * analysis_peg_emodes.tcl (compute): Fixed inconsistency in return
+ values.
+
+2005-08-02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ../../apps/page.man: Updated the documentation to list the two
+ new plugins.
+
+ * plugins/writer_identity.tcl: Additional reader and writer plugins.
+ * plugins/reader_treeser.tcl: The writer dumps the incoming data
+ as is, for inspection. The reader takes a tree serialization,
+ validates it as such and then simply passes this one.
+
+ * util_peg.tcl: Bugfixes in the computation of symbol(Node) for
+ tree nodes. Wrong var name, and missing tree reference. Also
+ change of output to stderr to use the regular page logging
+ instead.
+
+ * util_norm_peg.tcl: Extended the code flattening nested x and /
+ operators to transform x and / operators without children into
+ epsilon's.
+
+ * gen_peg_ser.tcl: Fixed output going directly to stderr to go
+ directly through the regular page logging.
+
+2005-07-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ../../examples/page: Renamed the directory examples/pg to the
+ proper name now in use.
+
+ * modules/page/plugins/reader_lemon.tcl: Reworked feedback generation
+ * modules/page/plugins/reader_peg.tcl: to properly signal end of
+ * modules/page/plugins/reader_ser.tcl: reading, for good linebreaks
+ * modules/page/plugins/reader_hb.tcl: in the output. Added to the
+ * ../../apps/page: plugins, manager, and application.
+ * pluginmgr.tcl:
+
+ * modules/page/plugins/transform_reach.tcl: Added generic feature
+ * modules/page/plugins/transform_use.tcl: query command to plugin
+ * modules/page/plugins/reader_lemon.tcl: manager and plugins.
+ * modules/page/plugins/writer_null.tcl: Added code to application,
+ * modules/page/plugins/writer_tree.tcl: manager and plugins to ask
+ * modules/page/plugins/writer_peg.tcl: for a feature 'timeable'. The
+ * modules/page/plugins/writer_ser.tcl: application will defer the
+ * modules/page/plugins/writer_tpc.tcl: collection of timing data to
+ * modules/page/plugins/writer_hb.tcl: the plugin if it can do so.
+ * modules/page/plugins/writer_me.tcl: Extended collection of timing
+ * modules/page/plugins/reader_peg.tcl: data from reader to all uses
+ * modules/page/plugins/reader_ser.tcl: of plugins. also a better
+ * modules/page/plugins/reader_hb.tcl: report at the end. All plugins
+ * ../../apps/page: are now timeable. Especially
+ * pluginmgr.tcl: the readers now provide much better data about the
+ number of characters they have read per second.
+
+2005-07-26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * ../../apps/page.man: Completed the documentation of the 'page'
+ application.
+
+ * ../../apps/page: Rewrote option processing to handle the changes
+ in the handling of configuration plugins and files. Also now
+ handling the changes when the default options are used. Better
+ error messages when plugins are not found. Corrected the
+ handling of -a, -p and their long equivalents.
+
+ * pluginmgr.tcl: Rewritten the configuration loader to accept
+ files containing lists of options as well, possibly quoted using
+ double-quotes and quotes.
+
+ * plugins/config_peg.tcl: ** New file **
+ * pkgIndex.tcl: Put the predefined configuration "peg" aka "PEG
+ parser generator" into a plugin.
+
+
+2005-07-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * A lot of changes. All packages have been renamed, i.e. shuffled
+ to different places in the namespace hierarchy. All have been
+ placed under "::page", and made more consistent. The files have
+ been moved around too, so that their names reflect the namespace
+ hierarchy as well. A customized pluginmgr has been written on
+ top of the general one, and the application has been rewritten
+ to use it. The existing parsers, code generators and
+ transformers have been put into proper plugins.
+
+2005-05-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * examples/pg/parse.y: Used the new lemon frontend to convert the
+ * examples/pg/sql.log: SQL grammar spec found in sqlite into an
+ * examples/pg/sql.peg: incomplete PEG spec from which we can
+ derive a complete spec (Removal of left
+ recursion, and completion/correction of the
+ lexical definitions).
+
+ * examples/pg/lemon.html: Created a frontend for reading grammar
+ * examples/pg/lemon.peg: specifications written for the LEMON
+ * peg_grammar_lemon.tcl: parser generator by Richard Hipp. The
+ * peg_norm_lemon.tcl: PEG grammar spec is based on the docu-
+ * apps/pg: mentation and the SQL spec found in
+ sqlite3. Integrated the frontend into
+ the PG application.
+
+ * peg_tpcserwriter.tcl: Added code to deal with grammars without
+ * peg_tpcphbwriter.tcl: start expression (as can be generated by
+ * peg_pegwriter.tcl: the usefulness transform).
+ * peg_mewriter.tcl:
+ * peg_writer.tcl:
+ * peg_emodes.tcl:
+ * peg_useful.tcl:
+
+2005-05-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * peg_emodes.tcl: Fixed problem in gen() phase. A gen() switching
+ to no can force acc() to no as well.
+
+ * apps/pg: Reworked PEG frontend code a bit to allow quick
+ switching between four variants of the PEG fronted (ME parser
+ vs. interpreted grammar, timed vs. untimed).
+
+ * pkgIndex.tcl:
+ * peg_grammar_me.tcl: New implementation of PEG frontend. PEG
+ parser as generated by the ME backend, after the fixes done
+ yesterday (PG dogfooding / bootstrapping).
+
+2005-05-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * peg_mewriter.tcl: Fixed a number of bugs (special char classes
+ generated bogus code, nonterminals and ! have to import status
+ variable when sub expression is terminal). Added (inactive) code
+ for insertion of logging code into the generated parser.
+
+2005-05-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * apps/pg: Removed two superfluous commands. Added readable
+ descriptions for the backends. Added 'null' backend which does
+ nothing. Added non-verbose char reader, disabled right now.
+
+ * peg_mewriter.tcl: Completely rewritten, removed all templates
+ save the main one, all code composition via lists, completed
+ option, kleene and pos kleene code generator, added comments
+ containing the parsing expressions matched by a particular
+ command.
+
+ * peg_quote.tcl: More forms of quoting characters.
+
+2005-05-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doc_emodes.txt: Recorded some thought about the transformation
+ which make it not worth to implement right now, as we need an
+ LL(1) grammar, otherwise we ran into either cache incoherency or
+ exponential time.
+
+ * peg_emodes.tcl: New transformation. Mode analysis. Computes
+ accept/generate data for all nodes from the given mode hints,
+ finds places where the mode can be made more strict than
+ specified.
+
+ * pg_flow.tcl: Fixed bug in setup of flow when using a start set
+ of nodes.
+
+ * doc_useful.txt: Rewritten to use the new flow management. Stores
+ * peg_useful.tcl: the results differently as well, easier to use
+ by the remove code. Updated the documentation of the transform
+ as well.
+
+2005-05-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * doc_reachable.tcl:
+ * peg_reachable.tcl: Rewritten to use the new flow
+ management. Stores the results differently as well, easier to
+ use by the remove code. Updated the documentation of the
+ transform as well.
+
+ * pg_flow.tcl: New utility. Generic tree walking, for both topdown
+ and bottomup walks, and anything in between. Maintains the state
+ of nodes to visit, and the code executed per node determines
+ what other nodes to visit.
+
+2005-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * peg_utilities.tcl: Bugfix, have to update user information of
+ symbols when nodes are removed, their definitions may have lost
+ callers.
+
+ * peg_tpcser.tcl: A first, two frontends, reading grammars which
+ * peg_tpcphb.tcl: are either in halfbaked form, or a serialization.
+
+ * peg_tpcphbwriter.tcl: Two new backends, writing the grammar out
+ * peg_tpcserwriter.tcl: as a halfbaked package (See peg_writer,
+ reduced to the Start and Define commands), and as serialization
+ of a PEG container.
+
+ * peg_writer.tcl: Moved a number of generally useful
+ * peg_utilities.tcl: functionality into the utilities.
+
+2005-05-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * peg_useful.tcl: Tweaked the definition of usefulness, better
+ based on the definition for CFG's.
+
+2005-05-02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * peg_pegwriter.tcl, peg_mewriter.tcl: Updated to changed NPEGT
+ definition (changed attribute names, node classification).
+
+ * peg_useful.tcl: Bugfix, we delete the subtrees of all unuseful
+ nodes. No cutting, deleting.
+
+ * treewriter.tcl: Back unquoted characters. Better readable.
+
+2005-04-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * peg_useful.tcl: Ditto for the usefulness analysis and
+ * doc_useful.txt: transform. Rewrote algorithm to use more proc
+ local state with quicker access, and easier checks.
+
+ * peg_reachable.tcl: Documented reachable computation and
+ * doc_reachable.txt: transform, updated to the changes in the
+ Normalized PE Grammar Tree.
+
+ * peg_utilities.tcl: New helper package. Common operations on the
+ tree.
+
+2005-04-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Reworked documentation of 'Raw PE Grammar AS Tree', as generated
+ by frontend, updated mengine to that.
+
+ * Reworked documentation of normalization step, and updated the
+ transformation code to it. Note: The non-generic backends are
+ broken by this.
+
+ * updated generic treewriter to quote attribute strings, as they
+ now may contain unprintable characters (the attributes carrying
+ lexemes).
+
+2005-04-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Added backend writing the input back in the same format, i.e. as
+ PEG. Bug fixes. Added option processing to the application to
+ switch between backends, and to select optimization levels.
+
+ * Character de/encode put into separate package. Started backend
+ writing a recursive descent parser for a grammar, based on
+ mengine.
+
+2005-04-26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bug fixes. Added transformations to com;ute reachable and useful
+ parts of the grammar, for minimizing it.
+
+2005-04-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Restructured utility packages (renames), and updated the
+ backends.
+
+2005-04-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Completed backend for writing the grammar as package providing a
+ PEG container. Bug fixes. First internal docs.
+
+2005-04-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bugfixes, added a transformation normalizing the raw AST.
+
+2005-04-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module: Utility packages for the parser generator
+ application.
diff --git a/tcllib/modules/page/NOTES.txt b/tcllib/modules/page/NOTES.txt
new file mode 100644
index 0000000..030353a
--- /dev/null
+++ b/tcllib/modules/page/NOTES.txt
@@ -0,0 +1,64 @@
+Transforms
+==========
+
+Consider: character sequence to string fusing in PEG writer.
+Consider: expression enumeration, to determine if there are common
+ expressions in the grammar which could be factored into
+ their own match procedures (*).
+
+Consider: Transformations which expand the number of common
+ expressions. Example would be strings, i.e. macthing of
+ character sequences. Instead of matching all in one use a
+ nested sequence of matching ever-growing prefixes. This
+ ensures that common prefixes in terminal strings are
+ factored into one matcher. And if we use nonterminal
+ procedures (See * below) this also enhances the caching,
+ especially if common prefixes occur in different branches of
+ a choice.
+
+(*) This could simple procedures, i.e. _not_ nonterminals. This would
+be without caching. Could also be nonterminal procedures, with mode
+expand (for value, discard would stay), to make its presence invisible
+to the AS tree structure.
+
+
+Removal of nonterminal chains
+
+ A <- B
+ B <- C
+ C <- ...
+
+Static match results !!
+
+mewriter has to be able to work with and
+without static match. Basic expr modes are
+something mewriter should do on its own
+as well.
+
+
+Compile *, + with helper nonterminals which are not shown as such
+(mode: expand).
+
+static match result - sequence - ability to remove checks after an
+always ok call, and abort sequence upon always fail.
+
+static match result - choice - ability to abort choice after ok, or
+skip always fail branches.
+
+
+Main parse routine can be simplified if start expression is a single
+nonterminal, and not a real complex expression.
+
+
+Need encoder for printable tcl char string.
+
+- The basic encoder generates a string acceptable to tcl parser for
+ use in a script, as part of the code.
+
+- The new encoder has to generate a string acceptable to the tcl
+ parser, for use in a script, which then written (puts) generates a
+ human readable representation of the character.
+
+I.e. LF in basic encode is \n, when printed it is an invislble
+character, i.e. a linefeed. In string/human encode it is \\n, which
+prints as \n, making it a readable representation of the character
diff --git a/tcllib/modules/page/analysis_peg_emodes.tcl b/tcllib/modules/page/analysis_peg_emodes.tcl
new file mode 100644
index 0000000..a6b224e
--- /dev/null
+++ b/tcllib/modules/page/analysis_peg_emodes.tcl
@@ -0,0 +1,458 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+
+# Perform mode analysis (x) on the PE grammar delivered by the
+# frontend. The grammar is in normalized form (*).
+#
+# (x) = See "doc_emodes.txt".
+# and "doc_emodes_alg.txt".
+# (*) = See "doc_normalize.txt".
+
+# This package assumes to be used from within a PAGE plugin. It uses
+# the API commands listed below. These are identical across the major
+# types of PAGE plugins, allowing this package to be used in reader,
+# transform, and writer plugins. It cannot be used in a configuration
+# plugin, and this makes no sense either.
+#
+# To ensure that our assumption is ok we require the relevant pseudo
+# package setup by the PAGE plugin management code.
+#
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: page::plugin
+
+package require page::plugin ; # S.a. pseudo-package.
+package require page::util::flow ; # Dataflow walking.
+package require page::util::peg ; # General utilities.
+package require treeql
+
+namespace eval ::page::analysis::peg::emodes {
+ namespace import ::page::util::peg::*
+}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::analysis::peg::emodes::compute {t} {
+
+ # Ignore call if already done before
+ if {[$t keyexists root page::analysis::peg::emodes]} {return 1}
+
+ # We do not actually compute per node a mode, but rather their
+ # gen'erate and acc'eptance properties, as described in
+ # "doc_emodes.txt".
+
+ # Note: This implementation will not compute acc/gen information
+ # for unreachable nodes.
+
+ # --- --- --- --------- --------- ---------
+
+ array set acc {} ; # Per node X, acc(X), undefined if no element
+ array set call {} ; # Per definition node, number of users
+ array set cala {} ; # Per definition node, number of (non-)accepting users
+
+ foreach {sym def} [$t get root definitions] {
+ set call($def) [llength [$t get $def users]]
+ set cala(0,$def) 0
+ set cala(1,$def) 0
+ }
+
+ set acc(root) 1 ; # Sentinel for root of start expression.
+
+ # --- --- --- --------- --------- ---------
+
+ #puts stderr ~~~~\t~~~\t~~~\t~~~\t~~~
+ #puts stderr Node\tAcc\tNew\tWhat\tOp
+ #puts stderr ~~~~\t~~~\t~~~\t~~~\t~~~
+
+ # A node is visited if its value for acc() is either undefined or
+ # may have changed. Basic flow is top down, from the start
+ # expression and a definition a child of its invokers.
+
+ set gstart [$t get root start]
+ if {$gstart eq ""} {
+ page_error " No start expression, unable to compute accept/generate properties"
+ return 0
+ }
+
+ page::util::flow [list $gstart] flow n {
+ # Determine first or new value.
+
+ #puts -nonewline stderr [string replace $n 1 3]
+
+ if {![info exists acc($n)]} {
+ set a [Accepting $t $n acc call cala]
+ set acc($n) $a
+ set change 0
+
+ #puts -nonewline stderr \t-\t$a\t^
+ } else {
+ set a [Accepting $t $n acc call cala]
+ set old $acc($n)
+ if {$a == $old} {
+ #puts stderr \t$old\t$a\t\ =
+ continue
+ }
+ set change 1
+ set acc($n) $a
+
+ #puts -nonewline stderr \t$old\t$a\t\ \ *
+ }
+
+ # Update counters in definitions, if the node invokes them.
+ # Also, schedule the children for their (re)definition.
+
+ if {[$t keyexists $n symbol]} {
+ #puts -nonewline stderr \t\ DEF\t[$t get $n symbol]\t[$t get $n mode]
+ } else {
+ #puts -nonewline stderr \t[$t get $n op]\t\t
+ }
+
+ if {[$t keyexists $n op] && ([$t get $n op] eq "n")} {
+ #puts -nonewline stderr ->\ [$t get $n sym]
+ set def [$t get $n def]
+ if {$def eq ""} continue
+
+ if {$change} {
+ incr cala($old,$def) -1
+ }
+ incr cala($a,$def)
+ $flow visit $def
+
+ #puts -nonewline stderr @$def\t(0a$cala(0,$def),\ 1a$cala(1,$def),\ #$call($def))\tv($def)
+ #puts stderr ""
+ continue
+ }
+
+ #puts stderr \t\t\t\tv([$t children $n])
+ $flow visitl [$t children $n]
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ array set gen {} ; # Per node X, gen(X), undefined if no element
+ array set nc {} ; # Per node, number of children
+ array set ng {} ; # Per node, number of (non-)generating children
+
+ foreach n [$t nodes] {
+ set nc($n) [$t numchildren $n]
+ set ng(0,$n) 0
+ set ng(1,$n) 0
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ #puts stderr ~~~~\t~~~\t~~~\t~~~\t~~~
+ #puts stderr Node\tGen\tNew\tWhat\tOp
+ #puts stderr ~~~~\t~~~\t~~~\t~~~\t~~~
+
+ # A node is visited if its value for gen() is either undefined or
+ # may have changed. Basic flow is bottom up, from the all
+ # leaves (and lookahead operators). Users of a definition are
+ # considered as its parents.
+
+ set start [$t leaves]
+ set q [treeql q -tree $t]
+ q query tree withatt op ! over n {lappend start $n}
+ q query tree withatt op & over n {lappend start $n}
+ q destroy
+
+ page::util::flow $start flow n {
+ # Ignore root.
+
+ if {$n eq "root"} continue
+
+ #puts -nonewline stderr [string replace $n 1 3]
+
+ # Determine first or new value.
+
+ if {![info exists gen($n)]} {
+ set g [Generating $t $n gen nc ng acc call cala]
+ set gen($n) $g
+
+ #puts -nonewline stderr \t-\t$g\t^
+
+ } else {
+ set g [Generating $t $n gen nc ng acc call cala]
+ set old $gen($n)
+ if {$g eq $old} {
+ #puts stderr \t$old\t$g\t\ =
+ continue
+ }
+ set gen($n) $g
+
+ #puts -nonewline stderr \t$old\t$g\t\ \ *
+ }
+
+ if {($g ne "maybe") && !$g && $acc($n)} {
+ # No generate here implies that none of our children will
+ # generate anything either. So the current acceptance of
+ # these non-existing values can be safely forced to
+ # non-acceptance.
+
+ set acc($n) 0
+ #puts -nonewline stderr "-a"
+ }
+
+ if {0} {
+ if {[$t keyexists $n symbol]} {
+ #puts -nonewline stderr \t\ DEF\t[$t get $n symbol]\t[$t get $n mode]
+ } else {
+ #puts -nonewline stderr \t[$t get $n op]\t\t
+ }
+ }
+
+ #puts -nonewline stderr \t(0g$ng(0,$n),1g$ng(1,$n),\ #$nc($n))
+
+ # Update counters in the (virtual) parents, and schedule them
+ # for a visit.
+
+ if {[$t keyexists $n symbol]} {
+ # Users are virtual parents.
+
+ set users [$t get $n users]
+ $flow visitl $users
+
+ if {$g ne "maybe"} {
+ foreach u $users {incr ng($g,$u)}
+ }
+ #puts stderr \tv($users)
+ continue
+ }
+
+ set p [$t parent $n]
+ $flow visit $p
+ if {$g ne "maybe"} {
+ incr ng($g,$p)
+ }
+
+ #puts stderr \tv($p)
+ }
+
+ # --- --- --- --------- --------- ---------
+
+ # Copy the calculated data over into the tree.
+ # Note: There will be no data for unreachable nodes.
+
+ foreach n [$t nodes] {
+ if {$n eq "root"} continue
+ if {![info exists acc($n)]} continue
+ $t set $n acc $acc($n)
+ $t set $n gen $gen($n)
+ }
+
+ # Recompute the modes based on the current
+ # acc/gen status of the definitions.
+
+ #puts stderr ~~~~\t~~~\t~~~~\t~~~\t~~~\t~~~
+ #puts stderr Node\tSym\tMode\tNew\tGen\tAcc
+ #puts stderr ~~~~\t~~~\t~~~~\t~~~\t~~~\t~~~
+
+ foreach {sym def} [$t get root definitions] {
+ set m {}
+
+ set old [$t get $def mode]
+
+ if {[info exists acc($def)]} {
+ switch -exact -- $gen($def)/$acc($def) {
+ 0/0 {set m discard}
+ 0/1 {error "Bad gen/acc for $sym"}
+ 1/0 {# don't touch (match, leaf)}
+ 1/1 {set m value}
+ maybe/0 {error "Bad gen/acc for $sym"}
+ maybe/1 {set m value}
+ }
+ if {$m ne ""} {
+ # Should check correctness of change, if any (We can drop
+ # to discard, nothing else).
+ $t set $def mode $m
+ }
+ #puts stderr [string replace $def 1 3]\t$sym\t$old\t[$t get $def mode]\t[$t get $def gen]\t[$t get $def acc]
+ } else {
+ #puts stderr [string replace $def 1 3]\t$sym\t$old\t\t\t\tNOT_REACHED
+ }
+ }
+
+ #puts stderr ~~~~\t~~~\t~~~~\t~~~\t~~~\t~~~
+
+ # Wrap up the whole state and save it in the tree. No need to
+ # throw this away, useful for other mode based transforms and
+ # easier to get in this way than walking the tree again.
+
+ $t set root page::analysis::peg::emodes [list \
+ [array get acc] \
+ [array get call] \
+ [array get cala] \
+ [array get gen] \
+ [array get nc] \
+ [array get ng]]
+ return 1
+}
+
+proc ::page::analysis::peg::emodes::reset {t} {
+ # Remove marker, allow recalculation of emodesness after changes.
+
+ $t unset root page::analysis::peg::emodes
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal
+
+proc ::page::analysis::peg::emodes::Accepting {t n av cv cav} {
+ upvar 1 $av acc $cv call $cav cala
+
+ # Definitions accept based on how they are called first, and on
+ # their mode if that is not possible.
+
+ if {[$t keyexists $n symbol]} {
+ # Call based acceptance.
+ # !acc if all callers do not accept.
+
+ if {$cala(0,$n) >= $call($n)} {
+ return 0
+ }
+
+ # Falling back to mode specific accptance
+ return [expr {([$t get $n mode] eq "value") ? 1 : 0}]
+ }
+
+ set op [$t get $n op]
+
+ # Lookahead operators will never accept.
+
+ if {($op eq "!") || ($op eq "&")} {
+ return 0
+ }
+
+ # All other operators inherit the acceptance
+ # of their parent.
+
+ return $acc([$t parent $n])
+}
+
+proc ::page::analysis::peg::emodes::Generating {t n gv ncv ngv av cv cav} {
+ upvar 1 $gv gen $ncv nc $ngv ng $av acc $cv call $cav cala
+ # ~~~ ~~ ~~ ~~~ ~~~~ ~~~~
+
+ # Definitions generate based on their mode, their defining
+ # expression, and the acceptance of their callers.
+
+ if {[$t keyexists $n symbol]} {
+
+ # If no caller accepts a value, then this definition will not
+ # generate one, even if its own mode asked it to do so.
+
+ if {$cala(0,$n) >= $call($n)} {
+ return 0
+ }
+
+ # The definition has callers accepting values and callres not
+ # doing so. It will generate as per its own mode and defining
+ # expression.
+
+ # The special modes know if they generate a value or not.
+ # The pass through mode looks at the expression for the
+ # information.
+
+ switch -exact -- [$t get $n mode] {
+ value {return $gen([lindex [$t children $n] 0])}
+ match {return 1}
+ leaf {return 1}
+ discard {return 0}
+ }
+ error PANIC
+ }
+
+ set op [$t get $n op]
+
+ # Inner nodes generate based on operator and children.
+
+ if {$nc($n)} {
+ switch -exact -- $op {
+ ! - & {return 0}
+ ? - * {
+ # No for all children --> no
+ # Otherwise --> maybe
+
+ if {$ng(0,$n) >= $nc($n)} {
+ return 0
+ } else {
+ return maybe
+ }
+ }
+ + - / - | {
+ # Yes for all children --> yes
+ # No for all children --> no
+ # Otherwise --> maybe
+
+ if {$ng(1,$n) >= $nc($n)} {
+ return 1
+ } elseif {$ng(0,$n) >= $nc($n)} {
+ return 0
+ } else {
+ return maybe
+ }
+ }
+ x {
+ # Yes for some children --> yes
+ # No for all children --> no
+ # Otherwise --> maybe
+
+ if {$ng(1,$n) > 0} {
+ return 1
+ } elseif {$ng(0,$n) >= $nc($n)} {
+ return 0
+ } else {
+ return maybe
+ }
+ }
+ }
+ error PANIC
+ }
+
+ # Nonterminal leaves generate based on acceptance from their
+ # parent and the referenced definition.
+
+ # As acc(X) == acc(parent(X)) the test doesn't have to go to the
+ # parent itself.
+
+ if {$op eq "n"} {
+ if {[info exists acc($n)] && !$acc($n)} {return 0}
+
+ set def [$t get $n def]
+
+ # Undefine symbols do not generate anything.
+ if {$def eq ""} {return 0}
+
+ # Inherit directly from the definition, if existing.
+ if {![info exists gen($def)]} {
+ return maybe
+ }
+
+ return $gen($def)
+ }
+
+ # Terminal leaves generate values if and only if such values are
+ # accepted by their parent. As acc(X) == acc(parent(X) the test
+ # doesn't have to go to the parent itself.
+
+
+ return $acc($n)
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::analysis::peg::emodes 0.1
diff --git a/tcllib/modules/page/analysis_peg_minimize.tcl b/tcllib/modules/page/analysis_peg_minimize.tcl
new file mode 100644
index 0000000..84cf07e
--- /dev/null
+++ b/tcllib/modules/page/analysis_peg_minimize.tcl
@@ -0,0 +1,51 @@
+# -*- tcl -*-
+# Transform - Minimize the grammar, through the removal of the
+# unreachable and not useful nonterminals (and expressions).
+
+# This package assumes to be used from within a PAGE plugin. It uses
+# the API commands listed below. These are identical across the major
+# types of PAGE plugins, allowing this package to be used in reader,
+# transform, and writer plugins. It cannot be used in a configuration
+# plugin, and this makes no sense either.
+#
+# To ensure that our assumption is ok we require the relevant pseudo
+# package setup by the PAGE plugin management code.
+#
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: page::plugin
+
+package require page::plugin ; # S.a. pseudo-package.
+package require page::analysis::peg::reachable
+package require page::analysis::peg::realizable
+
+namespace eval ::page::analysis::peg {}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::analysis::peg::minimize {t} {
+ page_info {[PEG Minimization]}
+ page_log_info ..Reachability ; ::page::analysis::peg::reachable::remove!
+ page_log_info ..Realizability ; ::page::analysis::peg::realizable::remove!
+
+ page_log_info Ok
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::analysis::peg::minimize 0.1
+
diff --git a/tcllib/modules/page/analysis_peg_reachable.tcl b/tcllib/modules/page/analysis_peg_reachable.tcl
new file mode 100644
index 0000000..27d12ff
--- /dev/null
+++ b/tcllib/modules/page/analysis_peg_reachable.tcl
@@ -0,0 +1,150 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+
+# Perform reachability analysis on the PE grammar delivered by the
+# frontend. The grammar is in normalized form (reduced to essentials,
+# graph like node-x-references, expression trees).
+
+# This package assumes to be used from within a PAGE plugin. It uses
+# the API commands listed below. These are identical across the major
+# types of PAGE plugins, allowing this package to be used in reader,
+# transform, and writer plugins. It cannot be used in a configuration
+# plugin, and this makes no sense either.
+#
+# To ensure that our assumption is ok we require the relevant pseudo
+# package setup by the PAGE plugin management code.
+#
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: page::plugin
+
+package require page::plugin ; # S.a. pseudo-package.
+package require page::util::flow ; # Dataflow walking.
+package require page::util::peg ; # General utilities.
+
+namespace eval ::page::analysis::peg::reachable {
+ namespace import ::page::util::peg::*
+}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::analysis::peg::reachable::compute {t} {
+
+ # Ignore call if already done before
+ if {[$t keyexists root page::analysis::peg::reachable]} return
+
+ # We compute the set of all nodes which are reachable from the
+ # root node of the start expression. This is a simple topdown walk
+ # where the children of all reachable nodes are mode reachable as
+ # well, and invokations of nonterminals symbols are treated as
+ # children as well. At the end of the flow all reachable non-
+ # terminal symbols and their expressions are marked, and none
+ # other.
+
+ # Initialize walking state: 2 arrays, all nodes (except root) are
+ # in or the other array, and their location tells if they are
+ # reachable or not. In the beginning no node is reachable. The
+ # goal array (reach) also serves as minder of which nodes have
+ # been seen, to cut multiple visits short.
+
+ array set unreach {} ; foreach n [$t nodes] {set unreach($n) .}
+ unset unreach(root)
+ array set reach {}
+
+ # A node is visited if it has been determined that it is indeed
+ # reachable.
+
+ page::util::flow [list [$t get root start]] flow n {
+ # Ignore nodes already reached.
+ if {[info exists reach($n)]} continue
+
+ # Reclassify node, has been reached now.
+ unset unreach($n)
+ set reach($n) .
+
+ # Schedule children for visit --> topdown flow.
+ $flow visitl [$t children $n]
+
+ # Treat n-Nodes as special, their definition as indirect
+ # child. But ignore invokations of undefined nonterminal
+ # symbols, or those already marked as reachable.
+
+ if {![$t keyexists $n op]} continue
+ if {[$t get $n op] ne "n"} continue
+
+ set def [$t get $n def]
+ if {$def eq ""} continue
+ if {[info exists reach($def)]} continue
+ $flow visit $def
+ }
+
+ # Store results. This also serves as marker.
+
+ $t set root page::analysis::peg::reachable [array names reach]
+ $t set root page::analysis::peg::unreachable [array names unreach]
+ return
+}
+
+proc ::page::analysis::peg::reachable::remove! {t} {
+
+ # Determine which nonterminal symbols are reachable from the root
+ # of the start expression.
+
+ compute $t
+
+ # Remove all nodes which are not reachable.
+
+ set unreach [$t get root page::analysis::peg::unreachable]
+ foreach n [lsort $unreach] {
+ if {[$t exists $n]} {
+ $t delete $n
+ }
+ }
+
+ # Notify the user of the definitions which were among the removed
+ # nodes. Keep only the still-existing definitions.
+
+ set res {}
+ foreach {sym def} [$t get root definitions] {
+ if {![$t exists $def]} {
+ page_warning " $sym: Unreachable nonterminal symbol, deleting"
+ } else {
+ lappend res $sym $def
+ }
+ }
+
+ # Clear computation results.
+
+ $t unset root page::analysis::peg::reachable
+ $t unset root page::analysis::peg::unreachable
+
+ $t set root definitions $res
+ updateUndefinedDueRemoval $t
+ return
+}
+
+proc ::page::analysis::peg::reachable::reset {t} {
+ # Remove marker, allow recalculation of reachability after
+ # changes.
+
+ $t unset root page::analysis::peg::reachable
+ $t unset root page::analysis::peg::unreachable
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::analysis::peg::reachable 0.1
diff --git a/tcllib/modules/page/analysis_peg_realizable.tcl b/tcllib/modules/page/analysis_peg_realizable.tcl
new file mode 100644
index 0000000..ef32a68
--- /dev/null
+++ b/tcllib/modules/page/analysis_peg_realizable.tcl
@@ -0,0 +1,257 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+
+# Perform realizability analysis (x) on the PE grammar delivered by
+# the frontend. The grammar is in normalized form (reduced to
+# essentials, graph like node-x-references, expression trees).
+#
+# (x) = See "doc_realizable.txt".
+
+# This package assumes to be used from within a PAGE plugin. It uses
+# the API commands listed below. These are identical across the major
+# types of PAGE plugins, allowing this package to be used in reader,
+# transform, and writer plugins. It cannot be used in a configuration
+# plugin, and this makes no sense either.
+#
+# To ensure that our assumption is ok we require the relevant pseudo
+# package setup by the PAGE plugin management code.
+#
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: page::plugin
+
+package require page::plugin ; # S.a. pseudo-package.
+package require page::util::flow ; # Dataflow walking.
+package require page::util::peg ; # General utilities.
+package require treeql
+
+namespace eval ::page::analysis::peg::realizable {
+ namespace import ::page::util::peg::*
+}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::analysis::peg::realizable::compute {t} {
+
+ # Ignore call if already done before
+
+ if {[$t keyexists root page::analysis::peg::realizable]} return
+
+ # We compute the set of realizable nonterminal symbols by doing the
+ # computation for all partial PE's in the grammar. We start at the
+ # leaves and then iteratively propagate the property as far as
+ # possible using the rules defining it, see the specification.
+
+ # --- --- --- --------- --------- ---------
+
+ # Initialize all nodes and the local arrays. Everything is not
+ # realizable, except for the terminal leafs of the tree. Their parents
+ # are scheduled to be visited as well.
+
+ array set realizable {} ; # Place where realizable nodes are held
+ array set unrealizable {} ; # Place where unrealizable nodes are held
+ array set nc {} ; # Per node, number of children.
+ array set uc {} ; # Per node, number of realizable children.
+
+ set nodeset [$t leaves]
+
+ set q [treeql q -tree $t]
+ $q query tree withatt op * over n {lappend nodeset $n}
+ $q query tree withatt op ? over n {lappend nodeset $n}
+ q destroy
+
+ foreach n [$t nodes] {
+ set unrealizable($n) .
+ set nc($n) [$t numchildren $n]
+ set uc($n) 0
+ }
+
+ # A node is visited if it _may_ have changed its status (to
+ # realizability).
+
+ page::util::flow $nodeset flow n {
+ # Realizable nodes cannot change, ignore them.
+
+ if {[info exists realizable($n)]} continue
+
+ # Determine new state of realizability, ignore a node if it is
+ # unchanged.
+
+ if {![Realizable $t $n nc uc realizable]} continue
+
+ # Reclassify changed node, it is now realizable.
+ unset unrealizable($n)
+ set realizable($n) .
+
+ # Schedule visits to nodes which may have been affected by
+ # this change. Update the relevant counters as well.
+
+ # @ root - none
+ # @ definition - users of the definition
+ # otherwise - parent of operator.
+
+ if {$n eq "root"} continue
+
+ if {[$t keyexists $n symbol]} {
+ set users [$t get $n users]
+ $flow visitl $users
+ foreach u $users {
+ incr uc($u)
+ }
+ continue
+ }
+
+ set p [$t parent $n]
+ incr uc($p)
+ $flow visit $p
+ }
+
+ # Set marker preventing future calls.
+ $t set root page::analysis::peg::realizable [array names realizable]
+ $t set root page::analysis::peg::unrealizable [array names unrealizable]
+ return
+}
+
+proc ::page::analysis::peg::realizable::remove! {t} {
+ # Determine which parts of the grammar are realizable
+
+ compute $t
+
+ # Remove anything which is not realizable (and all their children),
+ # except for the root itself, should it be unrealizablel.
+
+ set unreal [$t get root page::analysis::peg::unrealizable]
+ foreach n [lsort $unreal] {
+ if {$n eq "root"} continue
+ if {[$t exists $n]} {
+ $t delete $n
+ }
+ }
+
+ # Notify the user of the definitions which were among the removed
+ # nodes. Keep only the still-existing definitions.
+
+ set res {}
+ foreach {sym def} [$t get root definitions] {
+ if {![$t exists $def]} {
+ page_warning " $sym: Nonterminal symbol is not realizable, removed."
+ } else {
+ lappend res $sym $def
+ }
+ }
+ $t set root definitions $res
+
+ if {![$t exists [$t get root start]]} {
+ page_warning " <Start expression>: Is not realizable, removed."
+ $t set root start {}
+ }
+
+ # Find and cut operator chains, very restricted. Cut only chains
+ # of x- and /-operators. The other operators have only one child
+ # by definition and are thus not chains.
+
+ set q [treeql q -tree $t]
+ # q query tree over n
+ foreach n [$t children -all root] {
+ if {[$t keyexists $n symbol]} continue
+ if {[llength [$t children $n]] != 1} continue
+ set op [$t get $n op]
+ if {($op ne "/") && ($op ne "x")} continue
+ $t cut $n
+ }
+
+ flatten $q $t
+ q destroy
+
+ # Clear computation results.
+
+ $t unset root page::analysis::peg::realizable
+ $t unset root page::analysis::peg::unrealizable
+
+ updateUndefinedDueRemoval $t
+ return
+}
+
+proc ::page::analysis::peg::realizable::reset {t} {
+ # Remove marker, allow recalculation of realizability after changes.
+
+ $t unset root page::analysis::peg::realizable
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal
+
+proc ::page::analysis::peg::realizable::First {v} {
+ upvar 1 $v visit
+
+ set id [array startsearch visit]
+ set first [array nextelement visit $id]
+ array donesearch visit $id
+
+ unset visit($first)
+ return $first
+}
+
+proc ::page::analysis::peg::realizable::Realizable {t node ncv ucv uv} {
+ upvar 1 $ncv nc $ucv uc $uv realizable
+
+ if {$node eq "root"} {
+ # Root inherits realizability of the start expression.
+
+ return [info exists realizable([$t get root start])]
+ }
+
+ if {[$t keyexists $node symbol]} {
+ # Symbol definitions inherit the realizability of their
+ # expression.
+
+ return [expr {$uc($node) >= $nc($node)}]
+ }
+
+ switch -exact -- [$t get $node op] {
+ t - .. - epsilon - alpha - alnum - dot - * - ? {
+ # The terminal symbols are all realizable.
+ return 1
+ }
+ n {
+ # Symbol invokation inherits realizability of its definition.
+ # Calls to undefined symbols are not realizable.
+
+ set def [$t get $node def]
+ if {$def eq ""} {return 0}
+ return [info exists realizable($def)]
+ }
+ / - | {
+ # Choice, ordered and unordered. Realizable if we have at
+ # least one realizable branch. A quick test based on the count
+ # of realizable children is used.
+
+ return [expr {$uc($node) > 0}]
+ }
+ default {
+ # Sequence, and all other operators, are realizable if and
+ # only if all its children are realizable. A quick test based
+ # on the count of realizable children is used.
+
+ return [expr {$uc($node) >= $nc($node)}]
+ }
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::analysis::peg::realizable 0.1
diff --git a/tcllib/modules/page/compiler_peg_mecpu.tcl b/tcllib/modules/page/compiler_peg_mecpu.tcl
new file mode 100644
index 0000000..123c6da
--- /dev/null
+++ b/tcllib/modules/page/compiler_peg_mecpu.tcl
@@ -0,0 +1,1642 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Parser Generator / Transformation - Compile grammar to ME cpu instructions.
+
+# This package assumes to be used from within a PAGE plugin. It uses
+# the API commands listed below. These are identical across the major
+# types of PAGE plugins, allowing this package to be used in reader,
+# transform, and writer plugins. It cannot be used in a configuration
+# plugin, and this makes no sense either.
+#
+# To ensure that our assumption is ok we require the relevant pseudo
+# package setup by the PAGE plugin management code.
+#
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Dumping the input grammar. But not as Tcl or other code. In PEG
+## format again, pretty printing.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: page::plugin
+
+package require page::plugin ; # S.a. pseudo-package.
+
+package require grammar::me::cpu::gasm
+package require textutil
+package require struct::graph
+
+package require page::analysis::peg::emodes
+package require page::util::quote
+package require page::util::peg
+
+namespace eval ::page::compiler::peg::mecpu {
+ # Get the peg char de/encoder commands.
+ # (unquote, quote'tcl)
+
+ namespace import ::page::util::quote::*
+ namespace import ::page::util::peg::*
+
+
+ namespace eval gas {
+ namespace import ::grammar::me::cpu::gas::begin
+ namespace import ::grammar::me::cpu::gas::done
+ namespace import ::grammar::me::cpu::gas::lift
+ namespace import ::grammar::me::cpu::gas::state
+ namespace import ::grammar::me::cpu::gas::state!
+ }
+ namespace import ::grammar::me::cpu::gas::*
+ rename begin {}
+ rename done {}
+ rename lift {}
+ rename state {}
+ rename state! {}
+}
+
+# ### ### ### ######### ######### #########
+## Data structures for the generated code.
+
+## All data is held in node attributes of the tree. Per node:
+##
+## asm - List of instructions implementing the node.
+
+
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::compiler::peg::mecpu {t} {
+ # Resolve the mode hints. Every gen(X) having a value of 'maybe'
+ # (or missing) is for the purposes of this code a 'yes'.
+
+ if {![page::analysis::peg::emodes::compute $t]} {
+ page_error " Unable to generate a ME parser without accept/generate properties"
+ return
+ }
+
+ foreach n [$t nodes] {
+ if {![$t keyexists $n gen] || ([$t get $n gen] eq "maybe")} {
+ $t set $n gen 1
+ }
+ if {![$t keyexists $n acc]} {$t set $n acc 1}
+ }
+
+ # Synthesize a program, then the assembly code.
+
+ mecpu::Synth $t
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Helpers
+
+proc ::page::compiler::peg::mecpu::Synth {t} {
+ # Phase 2: Bottom-up, synthesized attributes
+
+ # We use a global graph to capture instructions and their
+ # relations. The graph is then converted into a linear list of
+ # instructions, with proper labeling and jump instructions to
+ # handle all non-linear control-flow.
+
+ set g [struct::graph g]
+ $t set root gas::called {}
+
+ page_info "* Synthesize graph code"
+
+ $t walk root -order post -type dfs n {
+ SynthNode $n
+ }
+
+ status $g ; gdump $g synth
+ remove_unconnected $g ; gdump $g nounconnected
+ remove_dead $g ; gdump $g nodead
+ denop $g ; gdump $g nonops
+ parcmerge $g ; gdump $g parcmerge
+ forwmerge $g ; gdump $g fmerge
+ backmerge $g ; gdump $g bmerge
+ status $g
+ pathlengths $g ; gdump $g pathlen
+ jumps $g ; gdump $g jumps
+ status $g
+ symbols $g $t
+
+ set cc [2code $t $g]
+ #write asm/mecode [join $cc \n]
+
+ statistics $cc
+
+ $t set root asm $cc
+ $g destroy
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode {n} {
+ upvar 1 t t g g
+ if {$n eq "root"} {
+ set code Root
+ } elseif {[$t keyexists $n symbol]} {
+ set code Nonterminal
+ } elseif {[$t keyexists $n op]} {
+ set code [$t get $n op]
+ } else {
+ return -code error "PANIC. Bad node $n, cannot classify"
+ }
+
+ page_log_info " [np $n] := ([linsert [$t children $n] 0 $code])"
+
+ SynthNode/$code $n
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/Root {n} {
+ upvar 1 t t g g
+
+ # Root is the grammar itself.
+
+ set gstart [$t get root start]
+ set gname [$t get root name]
+
+ if {$gstart eq ""} {
+ page_error " No start expression."
+ return
+ }
+
+ gas::begin $g $n halt "<Start Expression> '$gname'"
+ $g node set [Who entry] instruction .C
+ $g node set [Who entry] START .
+
+ Inline $t $gstart sexpr
+ /At sexpr/exit/ok ; /Ok ; Jmp exit/return
+ /At sexpr/exit/fail ; /Fail ; Jmp exit/return
+
+ gas::done --> $t
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/Nonterminal {n} {
+ upvar 1 t t g g
+
+ # This is the root of a definition.
+ #
+ # The text is a procedure wrapping the match code of its
+ # expression into the required the nonterminal handling (caching
+ # and such), plus the support code for the expression matcher.
+
+ set sym [$t get $n symbol]
+ set label [$t get $n label]
+ set gen [$t get $n gen]
+ set mode [$t get $n mode]
+
+ set pe [lindex [$t children $n] 0]
+ set egen [$t get $pe gen]
+
+ # -> inc_restore -found-> NOP gen: -> ok -> ias_push -> RETURN
+ # /!found \ /
+ # / \-fail --------->/
+ # / !gen: -> RETURN
+ # /
+ # \-> icl_push (-> ias_mark) -> (*) -> SV -> inc_save (-> ias_mrewind) -X
+ #
+ # X -ok----> ias_push -> ier_nonterminal
+ # \ /
+ # \-fail ----------/
+
+ # Poking into the generated instructions, converting the initial
+ # .NOP into a .C'omment.
+
+ set first [gas::begin $g $n !okfail "Nonterminal '$sym'"]
+ $g node set [Who entry] instruction .C
+ $g node set [Who entry] START .
+
+ Cmd inc_restore $label ; /Label restore ; /Ok
+
+ if {$gen} {
+ Bra ; /Label @
+ /Fail ; Nop ; Exit
+ /At @
+ /Ok ; Cmd ias_push ; Exit
+ } else {
+ Nop ; Exit
+ }
+
+ /At restore ; /Fail
+ Cmd icl_push ; # Balanced by inc_save (XX)
+ Cmd icl_push ; # Balanced by pop after ier_terminal
+
+ if {$egen} {
+ # [*] Needed for removal of SV's from stack after handling by
+ # this symbol, only if expression actually generates an SV.
+
+ Cmd ias_mark
+ }
+
+ Inline $t $pe subexpr ; /Ok ; Nop ; /Label unified
+ /At subexpr/exit/fail ; /Fail ; Jmp unified
+ /At unified
+
+ switch -exact -- $mode {
+ value {Cmd isv_nonterminal_reduce $label}
+ match {Cmd isv_nonterminal_range $label}
+ leaf {Cmd isv_nonterminal_leaf $label}
+ discard {Cmd isv_clear}
+ default {return -code error "Bad nonterminal mode \"$mode\""}
+ }
+
+ Cmd inc_save $label ; # Implied icl_pop (XX)
+
+ if {$egen} {
+ # See [*], this is the removal spoken about before.
+ Cmd ias_mrewind
+ }
+
+ /Label hold
+
+ if {$gen} {
+ /Ok
+ Cmd ias_push
+ Nop ; /Label merge
+ /At hold ; /Fail ; Jmp merge
+ /At merge
+ }
+
+ Cmd ier_nonterminal "Expected $label"
+ Cmd icl_pop
+ Exit
+
+ gas::done --> $t
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/? {n} {
+ upvar 1 t t g g
+
+ # The expression e? is equivalent to e/epsilon.
+ # And like this it is compiled.
+
+ set pe [lindex [$t children $n] 0]
+
+ gas::begin $g $n okfail ?
+
+ # -> icl_push -> ier_push -> (*) -ok--> ier_merge/ok --> icl_pop -ok----------------> OK
+ # \ /
+ # \-fail-> ier_merge/f ---> icl_rewind -> iok_ok -ok-/
+
+ Cmd icl_push
+ Cmd ier_push
+
+ Inline $t $pe subexpr
+
+ /Ok
+ Cmd ier_merge
+ Cmd icl_pop
+ /Ok ; Exit
+
+ /At subexpr/exit/fail ; /Fail
+ Cmd ier_merge
+ Cmd icl_rewind
+ Cmd iok_ok
+ /Ok ; Exit
+
+ gas::done --> $t
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/* {n} {
+ upvar 1 t t g g
+
+ # Kleene star is like a repeated ?
+
+ # Note: Compilation as while loop, as done now
+ # means that the parser has no information about
+ # the intermediate structure of the input in his
+ # cache.
+
+ # Future: Create a helper symbol X and compile
+ # the expression e = e'* as:
+ # e = X; X <- (e' X)?
+ # with match data for X put into the cache. This
+ # is not exactly equivalent, the structure of the
+ # AST is different (right-nested tree instead of
+ # a list). This however can be handled with a
+ # special nonterminal mode to expand the current
+ # SV on the stack.
+
+ # Note 2: This is a transformation which can be
+ # done on the grammar itself, before the actual
+ # backend is let loose. This "strength reduction"
+ # allows us to keep this code here.
+
+ set pe [lindex [$t children $n] 0]
+ set egen [$t get $pe gen]
+
+ # Build instruction graph.
+
+ # /<---------------------------------------------------------------\
+ # \_ \_
+ # ---> icl_push -> ier_push -> (*) -ok--> ier_merge/ok --> icl_pop ->/
+ # \
+ # \-fail-> ier_merge/f ---> icl_rewind -> iok_ok -> OK
+
+ gas::begin $g $n okfail *
+
+ Cmd icl_push ; /Label header
+ Cmd ier_push
+
+ Inline $t $pe loop
+
+ /Ok
+ Cmd ier_merge
+ Cmd icl_pop
+ Jmp header ; /CloseLoop
+
+ /At loop/exit/fail ; /Fail
+ Cmd ier_merge
+ Cmd icl_rewind
+ Cmd iok_ok
+ /Ok ; Exit
+
+ gas::done --> $t
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/+ {n} {
+ upvar 1 t t g g
+
+ # Positive Kleene star x+ is equivalent to x x*
+ # This is how it is compiled. See also the notes
+ # at the * above, they apply in essence here as
+ # well, except that the transformat scheme is
+ # slighty different:
+ #
+ # e = e'* ==> e = X; X <- e' X?
+
+ set pe [lindex [$t children $n] 0]
+
+ # Build instruction graph.
+
+ # icl_push -> ier_push -> (*) -fail-> ier_merge/fl -> icl_rewind -> FAIL
+ # \
+ # \--ok---> ier_merge/ok -> icl_pop ->\_
+ # /
+ # /<--------------------------------------------------------/
+ # /
+ # /<---------------------------------------------------------------\
+ # \_ \_
+ # -> icl_push -> ier_push -> (*) -ok--> ier_merge/ok --> icl_pop ->/
+ # \
+ # \-fail-> ier_merge/f ---> icl_rewind -> iok_ok -> OK
+
+ gas::begin $g $n okfail +
+
+ Cmd icl_push
+ Cmd ier_push
+
+ Inline $t $pe first
+ /At first/exit/fail ; /Fail
+ Cmd ier_merge
+ Cmd icl_rewind
+ /Fail ; Exit
+
+ /At first/exit/ok ; /Ok
+ Cmd ier_merge
+ Cmd icl_pop
+
+ # Loop copied from Kleene *, it is *
+
+ Cmd icl_push ; /Label header
+ Cmd ier_push
+
+ # For the loop we create the sub-expression instruction graph a
+ # second time. This is done by walking the subtree a second time
+ # and constructing a completely new node set. The result is
+ # imported under a new name.
+
+ set save [gas::state]
+ $t walk $pe -order post -type dfs n {SynthNode $n}
+ gas::state! $save
+ Inline $t $pe loop
+
+ /Ok
+ Cmd ier_merge
+ Cmd icl_pop
+ Jmp header ; /CloseLoop
+
+ /At loop/exit/fail ; /Fail
+ Cmd ier_merge
+ Cmd icl_rewind
+ Cmd iok_ok
+ /Ok ; Exit
+
+ gas::done --> $t
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode// {n} {
+ upvar 1 t t g g
+
+ set args [$t children $n]
+
+ if {![llength $args]} {
+ error "PANIC. Empty choice."
+
+ } elseif {[llength $args] == 1} {
+ # A choice over one branch is no real choice. The code
+ # generated for the child applies here as well.
+
+ gas::lift $t $n <-- [lindex $args 0]
+ return
+ }
+
+ # Choice over at least two branches.
+ # Build instruction graph.
+
+ # -> BRA
+ #
+ # BRA -> icl_push (-> ias_mark) -> ier_push -> (*) -ok -> ier_merge -> BRA'OK
+ # \-fail -> ier_merge (-> ias_mrewind) -> icl_rewind -> BRA'FAIL
+ #
+ # BRA'FAIL -> BRA
+ # BRA'FAIL -> FAIL (last branch)
+ #
+ # BRA'OK -> icl_pop -> OK
+
+ gas::begin $g $n okfail /
+
+ /Clear
+ Cmd icl_pop ; /Label BRA'OK ; /Ok ; Exit
+ /At entry
+
+ foreach pe $args {
+ set egen [$t get $pe gen]
+
+ # Note: We do not check for static match results. Doing so is
+ # an optimization we can do earlier, directly on the tree.
+
+ Cmd icl_push
+ if {$egen} {Cmd ias_mark}
+
+ Cmd ier_push
+ Inline $t $pe subexpr
+
+ /Ok
+ Cmd ier_merge
+ Jmp BRA'OK
+
+ /At subexpr/exit/fail ; /Fail
+ Cmd ier_merge
+ if {$egen} {Cmd ias_mrewind}
+ Cmd icl_rewind
+
+ # Branch failed. Go to the next branch. Fail completely at
+ # last branch.
+ }
+
+ /Fail ; Exit
+
+ gas::done --> $t
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/x {n} {
+ upvar 1 t t g g
+
+ set args [$t children $n]
+
+ if {![llength $args]} {
+ error "PANIC. Empty sequence."
+
+ } elseif {[llength $args] == 1} {
+ # A sequence of one element is no real sequence. The code
+ # generated for the child applies here as well.
+
+ gas::lift $t $n <-- [lindex $args 0]
+ return
+ }
+
+ # Sequence of at least two elements.
+ # Build instruction graph.
+
+ # -> icl_push -> SEG
+ #
+ # SEG (-> ias_mark) -> ier_push -> (*) -ok -> ier_merge -> SEG'OK
+ # \-fail -> ier_merge -> SEG'FAIL
+ #
+ # SEG'OK -> SEG
+ # SEG'OK -> icl_pop -> OK (last segment)
+ #
+ # SEG'FAIL (-> ias_mrewind) -> icl_rewind -> FAIL
+
+ gas::begin $g $n okfail x
+
+ /Clear
+ Cmd icl_rewind ; /Label SEG'FAIL ; /Fail ; Exit
+
+ /At entry
+ Cmd icl_push
+
+ set gen 0
+ foreach pe $args {
+ set egen [$t get $pe gen]
+ if {$egen && !$gen} {
+ set gen 1
+
+ # From here on out is the sequence able to generate
+ # semantic values which have to be canceled when
+ # backtracking.
+
+ Cmd ias_mark ; /Label @mark
+
+ /Clear
+ Cmd ias_mrewind ; Jmp SEG'FAIL ; /Label SEG'FAIL
+
+ /At @mark
+ }
+
+ Cmd ier_push
+ Inline $t $pe subexpr
+
+ /At subexpr/exit/fail ; /Fail
+ Cmd ier_merge
+ Jmp SEG'FAIL
+
+ /At subexpr/exit/ok ; /Ok
+ Cmd ier_merge
+ }
+
+ Cmd icl_pop
+ /Ok ; Exit
+
+ gas::done --> $t
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/& {n} {
+ upvar 1 t t g g
+ SynthLookahead $n no
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/! {n} {
+ upvar 1 t t g g
+ SynthLookahead $n yes
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/dot {n} {
+ upvar 1 t t g g
+ SynthTerminal $n {} "any character"
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/epsilon {n} {
+ upvar 1 t t g g
+
+ gas::begin $g $n okfail epsilon
+
+ Cmd iok_ok ; /Ok ; Exit
+
+ gas::done --> $t
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/alnum {n} {
+ upvar 1 t t g g
+ SynthClass $n alnum
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/alpha {n} {
+ upvar 1 t t g g
+ SynthClass $n alpha
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/digit {n} {
+ upvar 1 t t g g
+ SynthClass $n digit
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/xdigit {n} {
+ upvar 1 t t g g
+ SynthClass $n xdigit
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/punct {n} {
+ upvar 1 t t g g
+ SynthClass $n punct
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/space {n} {
+ upvar 1 t t g g
+ SynthClass $n space
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/.. {n} {
+ upvar 1 t t g g
+ # Range is [x-y]
+
+ set b [$t get $n begin]
+ set e [$t get $n end]
+
+ set tb [quote'tcl $b]
+ set te [quote'tcl $e]
+
+ set pb [quote'tclstr $b]
+ set pe [quote'tclstr $e]
+
+ SynthTerminal $n [list ict_match_tokrange $tb $te] "\\\[${pb}..${pe}\\\]"
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/t {n} {
+ upvar 1 t t g g
+
+ # Terminal node. Primitive matching.
+ # Code is parameterized by gen(X) of this node X.
+
+ set ch [$t get $n char]
+ set tch [quote'tcl $ch]
+ set pch [quote'tclstr $ch]
+
+ SynthTerminal $n [list ict_match_token $tch] $pch
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthNode/n {n} {
+ upvar 1 t t g g
+
+ # Nonterminal node. Primitive matching.
+ # The code is parameterized by acc(X) of this node X, and gen(D)
+ # of the invoked nonterminal D.
+
+ set sym [$t get $n sym]
+ set def [$t get $n def]
+
+ gas::begin $g $n okfail call'$sym'
+
+ if {$def eq ""} {
+ # Invokation of an undefined nonterminal. This will always fail.
+
+ Note "Match for undefined symbol '$sym'"
+ Cmdd iok_fail ; /Fail ; Exit
+ gas::done --> $t
+
+ } else {
+ # Combinations
+ # Acc Gen Action
+ # --- --- ------
+ # 0 0 Plain match
+ # 0 1 Match with canceling of the semantic value.
+ # 1 0 Plain match
+ # 1 1 Plain match
+ # --- --- ------
+
+ if {[$t get $n acc] || ![$t get $def gen]} {
+ Cmd icf_ntcall sym_$sym ; /Label CALL
+ /Ok ; Exit
+ /Fail ; Exit
+
+ } else {
+ Cmd ias_mark
+ Cmd icf_ntcall sym_$sym ; /Label CALL
+ Cmd ias_mrewind
+ /Ok ; Exit
+ /Fail ; Exit
+ }
+
+ set caller [Who CALL]
+ gas::done --> $t
+
+ $t lappend $def gas::callers $caller
+ $t lappend root gas::called $def
+ }
+
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthLookahead {n negated} {
+ upvar 1 g g t t
+
+ # Note: Per the rules about expression modes (! is a lookahead
+ # ____| operator) this node has a mode of 'discard', and its child
+ # ____| has so as well.
+
+ # assert t get n mode == discard
+ # assert t get pe mode == discard
+
+ set op [$t get $n op]
+ set pe [lindex [$t children $n] 0]
+ set eop [$t get $pe op]
+
+ # -> icl_push -> (*) -ok--> icl_rewind -> OK
+ # \--fail-> icl_rewind -> FAIL
+
+ # -> icl_push -> (*) -ok--> icl_rewind -> iok_negate -> FAIL
+ # \--fail-> icl_rewind -> iok_negate -> OK
+
+ gas::begin $g $n okfail [expr {$negated ? "!" : "&"}]
+
+ Cmd icl_push
+ Inline $t $pe subexpr
+
+ /Ok
+ Cmd icl_rewind
+ if {$negated} { Cmd iok_negate ; /Fail } else /Ok ; Exit
+
+ /At subexpr/exit/fail ; /Fail
+ Cmd icl_rewind
+ if {$negated} { Cmd iok_negate ; /Ok } else /Fail ; Exit
+
+ gas::done --> $t
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthClass {n op} {
+ upvar 1 t t g g
+ SynthTerminal $n [list ict_match_tokclass $op] <$op>
+ return
+}
+
+proc ::page::compiler::peg::mecpu::SynthTerminal {n cmd msg} {
+ upvar 1 t t g g
+
+ # 4 cases (+/- cmd, +/- sv).
+ #
+ # (A) +cmd+sv
+ # entry -> advance -ok-> match -ok-> sv -> OK
+ # \ \
+ # \ \-fail----------> FAIL
+ # \-fail----------------------/
+ #
+ # (B) -cmd+sv
+ # entry -> advance -ok-> sv -> OK
+ # \
+ # \-fail-----------> FAIL
+ #
+ # (C) +cmd-sv
+ # entry -> advance -ok-> match -ok-> OK
+ # \ \
+ # \ \-fail---> FAIL
+ # \-fail---------------/
+ #
+ # (D) -cmd-sv
+ # entry -> advance -ok-> OK
+ # \
+ # \-fail-----> FAIL
+
+ gas::begin $g $n okfail M'[lindex $cmd 0]
+
+ Cmd ict_advance "Expected $msg (got EOF)"
+ /Fail ; Exit
+ /Ok
+
+ if {[llength $cmd]} {
+ lappend cmd "Expected $msg"
+ eval [linsert $cmd 0 Cmd]
+ /Fail ; Exit
+ /Ok
+ }
+
+ if {[$t get $n gen]} {
+ Cmd isv_terminal
+ /Ok
+ }
+
+ Exit
+
+ gas::done --> $t
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Extending the graph of instructions (expression
+## framework, new instructions, (un)conditional sequencing).
+
+# ### ### ### ######### ######### #########
+## Internal. Working on the graph of instructions.
+
+proc ::page::compiler::peg::mecpu::2code {t g} {
+ page_info "* Generating ME assembler code"
+
+ set insn {}
+ set start [$t get root gas::entry]
+ set cat 0
+ set calls [list $start]
+
+ while {$cat < [llength $calls]} {
+ set now [lindex $calls $cat]
+ incr cat
+
+ set at 0
+ set pending [list $now]
+
+ while {$at < [llength $pending]} {
+ set current [lindex $pending $at]
+ incr at
+
+ while {$current ne ""} {
+ if {[$g node keyexists $current WRITTEN]} break
+
+ insn $g $current insn
+ $g node set $current WRITTEN .
+
+ if {[$g node keyexists $current SAVE]} {
+ lappend pending [$g node get $current SAVE]
+ }
+ if {[$g node keyexists $current CALL]} {
+ lappend calls [$g node get $current CALL]
+ }
+
+ set current [$g node get $current NEXT]
+ if {$current eq ""} break
+ if {[$g node keyexists $current WRITTEN]} {
+ lappend insn [list {} icf_jalways \
+ [$g node get $current LABEL]]
+ break
+ }
+
+ # Process the following instruction,
+ # if there is any.
+ }
+ }
+ }
+
+ return $insn
+}
+
+proc ::page::compiler::peg::mecpu::insn {g current iv} {
+ upvar 1 $iv insn
+
+ set code [$g node get $current instruction]
+ set args [$g node get $current arguments]
+
+ set label {}
+ if {[$g node keyexists $current LABEL]} {
+ set label [$g node get $current LABEL]
+ }
+
+ lappend insn [linsert $args 0 $label $code]
+ return
+}
+
+if 0 {
+ if {[lindex $ins 0] eq "icf_ntcall"} {
+ set tmp {}
+ foreach b $branches {
+ if {[$g node keyexists $b START]} {
+ set sym [$g node get $b symbol]
+ lappend ins sym_$sym
+ } else {
+ lappend tmp $b
+ }
+ }
+ set branches $tmp
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Optimizations.
+#
+## I. Remove all nodes which are not connected to anything.
+## There should be none.
+
+proc ::page::compiler::peg::mecpu::remove_unconnected {g} {
+ page_info "* Remove unconnected instructions"
+
+ foreach n [$g nodes] {
+ if {[$g node degree $n] == 0} {
+ page_error "$n ([printinsn $g $n])"
+ page_error "Found unconnected node. This should not have happened."
+ page_error "Removing the bad node."
+
+ $g node delete $n
+ }
+ }
+}
+
+proc ::page::compiler::peg::mecpu::remove_dead {g} {
+ page_info "* Remove dead instructions"
+
+ set count 0
+ set runs 0
+ set hasdead 1
+ while {$hasdead} {
+ set hasdead 0
+ foreach n [$g nodes] {
+ if {[$g node keyexists $n START]} continue
+ if {[$g node degree -in $n] > 0} continue
+
+ page_log_info " [np $n] removed, dead ([printinsn $g $n])"
+
+ $g node delete $n
+
+ set hasdead 1
+ incr count
+ }
+ incr runs
+ }
+
+ page_info " Removed [plural $count instruction] in [plural $runs run]"
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Optimizations.
+#
+## II. We have lots of .NOP instructions in the control flow, as part
+## of the framework. They made the handling of expressions easier,
+## providing clear and fixed anchor nodes to connect to from
+## inside and outside, but are rather like the epsilon-transitions
+## in a (D,N)FA. Now is the time to get rid of them.
+#
+## We keep the .C'omments, and explicit .BRA'nches.
+## We should not have any .NOP which is a dead-end (without
+## successor), nor should we find .NOPs with more than one
+## successor. The latter should have been .BRA'nches. Both
+## situations are reported on. Dead-ends we
+## remove. Multi-destination NOPs we keep.
+#
+## Without the nops in place to confus the flow we can perform a
+## series peep-hole optimizations to merge/split branches.
+
+proc ::page::compiler::peg::mecpu::denop {g} {
+ # Remove the .NOPs and reroute control flow. We keep the pseudo
+ # instructions for comments (.C) and the explicit branch points
+ # (.BRA).
+
+ page_info "* Removing the helper .NOP instructions."
+
+ set count 0
+ foreach n [$g nodes] {
+ # Skip over nodes already deleted by a previous iteration.
+ if {[$g node get $n instruction] ne ".NOP"} continue
+
+ # We keep branching .NOPs, and warn user. There shouldn't be
+ # any. such should explicit bnrachpoints.
+
+ set destinations [$g arcs -out $n]
+
+ if {[llength $destinations] > 1} {
+ page_error "$n ([printinsn $g $n])"
+ page_error "Found a .NOP with more than one destination."
+ page_error "This should have been a .BRA instruction."
+ page_error "Not removed. Internal error. Fix the transformation."
+ continue
+ }
+
+ # Nops without a destination, dead-end's are not wanted. They
+ # should not exist either too. We will do a general dead-end
+ # and dead-start removal as well.
+
+ if {[llength $destinations] < 1} {
+ page_error "$n ([printinsn $g $n])"
+ page_error "Found a .NOP without any destination, i.e. a dead end."
+ page_error "This should not have happened. Removed the node."
+
+ $g node delete $n
+ continue
+ }
+
+ page_log_info " [np $n] removed, updated cflow ([printinsn $g $n])"
+
+ # As there is exactly one destination we can now reroute all
+ # incoming arcs around the nop to the new destination.
+
+ set target [$g arc target [lindex $destinations 0]]
+ foreach a [$g arcs -in $n] {
+ $g arc move-target $a $target
+ }
+
+ $g node delete $n
+ incr count
+ }
+
+ page_info " Removed [plural $count instruction]"
+ return
+}
+
+
+# ### ### ### ######### ######### #########
+## Optimizations.
+#
+
+# Merge parallel arcs (remove one, make the other unconditional).
+
+proc ::page::compiler::peg::mecpu::parcmerge {g} {
+ page_info "* Search for identical parallel arcs and merge them"
+
+ #puts [join [info loaded] \n] /seg.fault induced with tcllibc! - tree!
+
+ set count 0
+ foreach n [$g nodes] {
+ set arcs [$g arcs -out $n]
+
+ if {[llength $arcs] < 2} continue
+ if {[llength $arcs] > 2} {
+ page_error " $n ([printinsn $g $n])"
+ page_error " Instruction has more than two destinations."
+ page_error " That is not possible. Internal error."
+ continue
+ }
+ # Two way branch. Both targets the same ?
+
+ foreach {a b} $arcs break
+
+ if {[$g arc target $a] ne [$g arc target $b]} continue
+
+ page_log_info " [np $n] outbound arcs merged ([printinsn $g $n])"
+
+ $g arc set $a condition always
+ $g arc delete $b
+
+ incr count 2
+ }
+
+ page_info " Merged [plural $count arc]"
+ return
+}
+
+# Use knowledge of the match status before and after an instruction to
+# label the arcs a bit better (This may guide the forward and backward
+# merging.).
+
+# Forward merging of instructions.
+# An ok/fail decision is done as late as possible.
+#
+# /- ok ---> Y -> U /- ok ---> U
+# X ==> X -> Y
+# \- fail -> Y -> V \- fail -> V
+
+# The Y must not have additional inputs. This more complex case we
+# will look at later.
+
+proc ::page::compiler::peg::mecpu::forwmerge {g} {
+ page_info "* Forward merging of identical instructions"
+ page_info " Delaying decisions"
+ set count 0
+ set runs 0
+
+ set merged 1
+ while {$merged} {
+ set merged 0
+ foreach n [$g nodes] {
+ # Skip nodes already killed in previous rounds.
+ if {![$g node exists $n]} continue
+
+ set outbound [$g arcs -out $n]
+ if {[llength $outbound] != 2} continue
+
+ foreach {aa ab} $outbound break
+ set na [$g arc target $aa]
+ set nb [$g arc target $ab]
+
+ set ia [$g node get $na instruction][$g node get $na arguments]
+ set ib [$g node get $nb instruction][$g node get $nb arguments]
+ if {$ia ne $ib} continue
+
+ # Additional condition: Inbounds in the targets not > 1
+
+ if {([$g node degree -in $na] > 1) ||
+ ([$g node degree -in $nb] > 1)} continue
+
+ page_log_info " /Merge [np $n] : [np $na] <- [np $nb] ([printinsn $g $na])"
+
+ # Label all arcs out of na with the condition of the arc
+ # into it. Ditto for the arcs out of nb. The latter also
+ # get na as their new origin. The arcs out of n relabeled
+ # to always. The nb is deleted. This creates the desired
+ # control structure without having to create a new node
+ # and filling it. We simply use na, discard nb, and
+ # properly rewrite the arcs to have the correct
+ # conditions.
+
+ foreach a [$g arcs -out $na] {
+ $g arc set $a condition [$g arc get $aa condition]
+ }
+ foreach a [$g arcs -out $nb] {
+ $g arc set $a condition [$g arc get $ab condition]
+ $g arc move-source $a $na
+ }
+ $g arc set $aa condition always
+ $g node delete $nb
+ set merged 1
+ incr count
+ }
+ incr runs
+ }
+
+ # NOTE: This may require a parallel arc merge, with identification
+ # of merge-able arcs based on the arc condition, i.e. labeling.
+
+ page_info " Merged [plural $count instruction] in [plural $runs run]"
+ return
+}
+
+# Backward merging of instructions.
+# Common backends are put together.
+#
+# U -> Y ->\ U ->\
+# -> X ==> -> Y -> X
+# V -> Y ->/ V ->/
+
+# Note. It is possible for an instruction to be amenable to both for-
+# and backward merging. No heuristics are known to decide which is
+# better.
+
+proc ::page::compiler::peg::mecpu::backmerge {g} {
+ page_info "* Backward merging of identical instructions"
+ page_info " Unifying paths"
+ set count 0
+ set runs 0
+
+ set merged 1
+ while {$merged} {
+ set merged 0
+ foreach n [$g nodes] {
+ # Skip nodes already killed in previous rounds.
+ if {![$g node exists $n]} continue
+
+ set inbound [$g arcs -in $n]
+ if {[llength $inbound] < 2} continue
+
+ # We have more than 1 inbound arcs on this node. Check all
+ # pairs of pre-decessors for possible unification.
+
+ # Additional condition: Outbounds in the targets not > 1
+ # We check in different levels, to avoid redundant calls.
+
+ while {[llength $inbound] > 2} {
+ set aa [lindex $inbound 0]
+ set tail [lrange $inbound 1 end]
+
+ set na [$g arc source $aa]
+ if {[$g node degree -out $na] > 1} {
+ set inbound $tail
+ continue
+ }
+
+ set inbound {}
+ foreach ab $tail {
+ set nb [$g arc source $ab]
+ if {[$g node degree -out $nb] > 1} continue
+
+ set ia [$g node get $na instruction][$g node get $na arguments]
+ set ib [$g node get $nb instruction][$g node get $nb arguments]
+
+ if {$ia ne $ib} {
+ lappend inbound $ab
+ continue
+ }
+
+ page_log_info " \\Merge [np $n] : [np $na] <- [np $nb] ([printinsn $g $na])"
+
+ # Discard the second node in the pair. Move all
+ # arcs inbound into it so that they reach the
+ # first node instead.
+
+ foreach a [$g arcs -in $nb] {$g arc move-target $a $na}
+ $g node delete $nb
+ set merged 1
+ incr count
+ }
+ }
+ }
+ incr runs
+ }
+
+ page_info " Merged [plural $count instruction] in [plural $runs run]"
+ return
+}
+
+# ### ### ### ######### ######### #########
+
+proc ::page::compiler::peg::mecpu::pathlengths {g} {
+ page_info "* Find maximum length paths"
+
+ set pending [llength [$g nodes]]
+
+ set nodes {}
+ set loops {}
+ foreach n [$g nodes] {
+ $g node set $n WAIT [$g node degree -out $n]
+ set insn [$g node get $n instruction]
+ if {($insn eq "icf_halt") || ($insn eq "icf_ntreturn")} {
+ lappend nodes $n
+ }
+ if {[$g node keyexists $n LOOP]} {
+ lappend loops $n
+ }
+ }
+
+ set level 0
+ while {[llength $nodes]} {
+ incr pending -[llength $nodes]
+ set nodes [closure $g $nodes $level]
+ incr level
+ }
+
+ if {[llength $loops]} {
+ page_info " Loop levels"
+
+ set nodes $loops
+ while {[llength $nodes]} {
+ incr pending -[llength $nodes]
+ set nodes [closure $g $nodes $level]
+ incr level
+ }
+ }
+
+ if {$pending} {
+ page_info " Remainder"
+
+ while {$pending} {
+ set nodes {}
+ foreach n [$g nodes] {
+ if {[$g node keyexists $n LEVEL]} continue
+ if {[$g node get $n WAIT] < [$g node degree -out $n]} {
+ lappend nodes $n
+ }
+ }
+ while {[llength $nodes]} {
+ incr pending -[llength $nodes]
+ set nodes [closure $g $nodes $level]
+ incr level
+ }
+ }
+ }
+ return
+}
+
+proc ::page::compiler::peg::mecpu::closure {g nodes level} {
+ page_log_info " \[[format %6d $level]\] : $nodes"
+
+ foreach n $nodes {$g node set $n LEVEL $level}
+
+ set tmp {}
+ foreach n $nodes {
+ foreach pre [$g nodes -in $n] {
+ # Ignore instructions already given a level.
+ if {[$g node keyexists $pre LEVEL]} continue
+ $g node set $pre WAIT [expr {[$g node get $pre WAIT] - 1}]
+ if {[$g node get $pre WAIT] > 0} continue
+ lappend tmp $pre
+ }
+ }
+ return [lsort -uniq -dict $tmp]
+}
+
+proc ::page::compiler::peg::mecpu::jumps {g} {
+ page_info "* Insert explicit jumps and branches"
+
+ foreach n [$g nodes] {
+ # Inbound > 1, at least one is from a jump, so a label is
+ # needed.
+
+ if {[llength [$g arcs -in $n]] > 1} {
+ set go bra[string range $n 4 end]
+ $g node set $n LABEL $go
+ }
+
+ set darcs [$g arcs -out $n]
+
+ if {[llength $darcs] == 0} {
+ $g node set $n NEXT ""
+ continue
+ }
+
+ if {[llength $darcs] == 1} {
+ set da [lindex $darcs 0]
+ set dn [$g arc target $da]
+
+ if {[$g node get $dn LEVEL] > [$g node get $n LEVEL]} {
+ # Flow is backward, an uncond. jump
+ # is needed here.
+
+ set go bra[string range $dn 4 end]
+ $g node set $dn LABEL $go
+ set j [$g node insert]
+ $g arc move-target $da $j
+ $g node set $j instruction icf_jalways
+ $g node set $j arguments $go
+
+ $g arc insert $j $dn
+
+ $g node set $n NEXT $j
+ $g node set $j NEXT ""
+ } else {
+ $g node set $n NEXT $dn
+ }
+ continue
+ }
+
+ set aok {}
+ set afl {}
+ foreach a $darcs {
+ if {[$g arc get $a condition] eq "ok"} {
+ set aok $a
+ } else {
+ set afl $a
+ }
+ }
+ set nok [$g arc target $aok]
+ set nfl [$g arc target $afl]
+
+ if {[$g node get $n instruction] eq "inc_restore"} {
+ set go bra[string range $nok 4 end]
+ $g node set $nok LABEL $go
+
+ $g node set $n NEXT $nfl
+ $g node set $n SAVE $nok
+
+ $g node set $n arguments [linsert [$g node get $n arguments] 0 $go]
+ continue
+ }
+
+ if {[$g node get $n instruction] ne ".BRA"} {
+ set bra [$g node insert]
+ $g arc move-source $aok $bra
+ $g arc move-source $afl $bra
+ $g arc insert $n $bra
+ $g node set $n NEXT $bra
+ set n $bra
+ }
+
+ if {[$g node get $nok LEVEL] > [$g node get $nfl LEVEL]} {
+ # Ok branch is direct, Fail is jump.
+
+ $g node set $n NEXT $nok
+ $g node set $n SAVE $nfl
+
+ set go bra[string range $nfl 4 end]
+ $g node set $nfl LABEL $go
+ $g node set $n instruction icf_jfail
+ $g node set $n arguments $go
+ } else {
+
+ # Fail branch is direct, Ok is jump.
+
+ $g node set $n NEXT $nfl
+ $g node set $n SAVE $nok
+
+ set go bra[string range $nok 4 end]
+ $g node set $nok LABEL $go
+ $g node set $n instruction icf_jok
+ $g node set $n arguments $go
+ }
+ }
+}
+
+proc ::page::compiler::peg::mecpu::symbols {g t} {
+ page_info "* Label subroutine heads"
+
+ # Label and mark the instructions where subroutines begin.
+ # These markers are used by 2code to locate all actually
+ # used subroutines.
+
+ foreach def [lsort -uniq [$t get root gas::called]] {
+ set gdef [$t get $def gas::entry]
+ foreach caller [$t get $def gas::callers] {
+
+ # Skip callers which are gone because of optimizations.
+ if {![$g node exists $caller]} continue
+
+ $g node set $caller CALL $gdef
+ $g node set $gdef LABEL \
+ [lindex [$g node set $caller arguments] 0]
+ }
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+
+proc ::page::compiler::peg::mecpu::statistics {code} {
+ return
+ # disabled
+ page_info "* Statistics"
+ statistics_si $code
+
+ # All higher order statistics are done only on the instructions in
+ # a basic block, i.e. a linear sequence. We are looking for
+ # high-probability blocks in itself, and then also for
+ # high-probability partials.
+
+ set blocks [basicblocks $code]
+
+ # Basic basic block statistics (full blocks)
+
+ Init bl
+ foreach b $blocks {Incr bl($b)}
+ wrstat bl asm/statistics_bb.txt
+ wrstatk bl asm/statistics_bbk.txt
+
+ # Statistics of all partial blocks, i.e. all possible
+ # sub-sequences with length > 1.
+
+ Init ps
+ foreach b $blocks {
+ for {set s 0} {$s < [llength $b]} {incr s} {
+ for {set e [expr {$s + 1}]} {$e < [llength $b]} {incr e} {
+ Incr ps([lrange $b $s $e]) $bl($b)
+ }
+ }
+ }
+
+ wrstat ps asm/statistics_ps.txt
+ wrstatk ps asm/statistics_psk.txt
+ return
+}
+
+proc ::page::compiler::peg::mecpu::statistics_si {code} {
+ page_info " Single instruction probabilities."
+
+ # What are the most used instructions, statically speaking,
+ # without considering context ?
+
+ Init si
+ foreach i $code {
+ foreach {label name} $i break
+ if {$name eq ".C"} continue
+ Incr si($name)
+ }
+
+ wrstat si asm/statistics_si.txt
+ return
+}
+
+proc ::page::compiler::peg::mecpu::Init {v} {
+ upvar 1 $v var total total
+ array set var {}
+ set total 0
+ return
+}
+
+proc ::page::compiler::peg::mecpu::Incr {v {n 1}} {
+ upvar 1 $v var total total
+ if {![info exists var]} {set var $n ; incr total ; return}
+ incr var $n
+ incr total $n
+ return
+}
+
+proc ::page::compiler::peg::mecpu::wrstat {bv file} {
+ upvar 1 $bv buckets total total
+
+ set tmp {}
+ foreach {name count} [array get buckets] {
+ lappend tmp [list $name $count]
+ }
+
+ set lines {}
+ lappend lines "Total: $total"
+
+ set half [expr {$total / 2}]
+ set down $total
+
+ foreach item [lsort -index 1 -decreasing -integer [lsort -index 0 $tmp]] {
+ foreach {key count} $item break
+
+ set percent [format %6.2f [expr {$count*100.0/$total}]]%
+ set fcount [format %8d $count]
+
+ lappend lines " $fcount $percent $key"
+ incr down -$count
+ if {$half && ($down < $half)} {
+ lappend lines **
+ set half 0
+ }
+ }
+
+ write $file [join $lines \n]\n
+ return
+}
+
+proc ::page::compiler::peg::mecpu::wrstatk {bv file} {
+ upvar 1 $bv buckets total total
+
+ set tmp {}
+ foreach {name count} [array get buckets] {
+ lappend tmp [list $name $count]
+ }
+
+ set lines {}
+ lappend lines "Total: $total"
+
+ set half [expr {$total / 2}]
+ set down $total
+
+ foreach item [lsort -index 0 [lsort -index 1 -decreasing -integer $tmp]] {
+ foreach {key count} $item break
+
+ set percent [format %6.2f [expr {$count*100.0/$total}]]%
+ set fcount [format %8d $count]
+
+ lappend lines " $fcount $percent $key"
+ incr down -$count
+ if {$down < $half} {
+ lappend lines **
+ set half -1
+ }
+ }
+
+ write $file [join $lines \n]\n
+ return
+}
+
+proc ::page::compiler::peg::mecpu::basicblocks {code} {
+ set blocks {}
+ set block {}
+
+ foreach i $code {
+ foreach {label name} $i break
+ if {
+ ($name eq ".C") ||
+ ($name eq "icf_jok") ||
+ ($name eq "icf_jfail") ||
+ ($name eq "icf_jalways") ||
+ ($name eq "icf_ntreturn")
+ } {
+ # Jumps stop a block, and are not put into the block
+ # Except if the block is of length 1. Then it is of
+ # interest to see if certain combinations are used
+ # often.
+
+ if {[llength $block]} {
+ if {[llength $block] == 1} {lappend block $name}
+ lappend blocks $block
+ }
+ set block {}
+ continue
+ } elseif {$label ne ""} {
+ # A labeled instruction starts a new block and belongs to
+ # it. Note that the previous block is saved only if it is
+ # of length > 1. A single instruction block is not
+ # something we can optimize.
+
+ if {[llength $block] > 1} {lappend blocks $block}
+ set block [list $name]
+ continue
+ }
+ # Extend current block
+ lappend block $name
+ }
+
+ if {[llength $block]} {lappend blocks $block}
+ return $blocks
+}
+
+# ### ### ### ######### ######### #########
+
+proc ::page::compiler::peg::mecpu::printinsn {g n} {
+ return "[$g node get $n instruction] <[$g node get $n arguments]>"
+}
+
+proc ::page::compiler::peg::mecpu::plural {n prefix} {
+ return "$n ${prefix}[expr {$n == 1 ? "" : "s"}]"
+}
+
+proc ::page::compiler::peg::mecpu::np {n} {
+ format %-*s 8 $n
+}
+
+proc ::page::compiler::peg::mecpu::status {g} {
+ page_info "[plural [llength [$g nodes]] instruction]"
+ return
+}
+
+proc ::page::compiler::peg::mecpu::gdump {g file} {
+ return
+ # disabled
+ variable gnext
+ page_info " %% Saving graph to \"$file\" %%"
+ write asm/[format %02d $gnext]_${file}.sgr [$g serialize]
+ incr gnext
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Strings.
+
+namespace eval ::page::compiler::peg::mecpu {
+ variable gnext 0
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::compiler::peg::mecpu 0.1.1
diff --git a/tcllib/modules/page/gen_peg_canon.tcl b/tcllib/modules/page/gen_peg_canon.tcl
new file mode 100644
index 0000000..27d5f4b
--- /dev/null
+++ b/tcllib/modules/page/gen_peg_canon.tcl
@@ -0,0 +1,481 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Parser Generator / Backend - PEG as ... PEG
+
+# ### ### ### ######### ######### #########
+## Dumping the input grammar. But not as Tcl or other code. In PEG
+## format again, pretty printing.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require textutil
+
+namespace eval ::page::gen::peg::canon {}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::gen::peg::canon {t chan} {
+
+ # Generate data for inherited attributes
+ # used during synthesis.
+ canon::Setup $t
+
+ # Synthesize all text fragments we need.
+ canon::Synth $t
+
+ # And write the grammar text.
+ puts $chan [$t get root TEXT]
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Helpers
+
+proc ::page::gen::peg::canon::Setup {t} {
+ # Phase 1: Top-down, inherited attributes:
+ #
+ # - Max length of nonterminal symbols defined by the grammar.
+ #
+ # - Indentation put on all rules to get enough space for
+ # definition attributes.
+
+ set max -1
+ array set modes {}
+
+ foreach {sym def} [$t get root definitions] {
+ set l [string length $sym]
+ if {$l > $max} {set max $l}
+
+ set mode [string index [$t get $def mode] 0]
+ set modes($mode) .
+ }
+ set modeset [join [lsort [array names modes]] ""]
+ set mlen [AttrFieldLength $modeset]
+ set heading [expr {$max + $mlen + 4}]
+ # The constant 4 is for ' <- ', see
+ # SynthNode/Nonterminal
+
+ # Save the computed information for access by the definitions and
+ # other operators.
+
+ $t set root SYM_FIELDLEN $max
+ $t set root ATT_FIELDLEN $mlen
+ $t set root ATT_BASE $modeset
+ $t set root HEADLEN $heading
+ return
+}
+
+proc ::page::gen::peg::canon::Synth {t} {
+ # Phase 2: Bottom-up, synthesized attributes
+ #
+ # - Text block per node, length and height.
+
+ $t walk root -order post -type dfs n {
+ SynthNode $t $n
+ }
+ return
+}
+
+proc ::page::gen::peg::canon::SynthNode {t n} {
+ if {$n eq "root"} {
+ set code Root
+ } elseif {[$t keyexists $n symbol]} {
+ set code Nonterminal
+ } elseif {[$t keyexists $n op]} {
+ set code [$t get $n op]
+ } else {
+ return -code error "PANIC. Bad node $n, cannot classify"
+ }
+
+ #puts stderr "SynthNode/$code $t $n"
+
+ SynthNode/$code $t $n
+
+ #SHOW [$t get $n TEXT] 1 0
+ #catch {puts stderr "\t.[$t get $n W]x[$t get $n H]"}
+ return
+}
+
+proc ::page::gen::peg::canon::SynthNode/Root {t n} {
+ # Root is the grammar itself.
+
+ # Get the data we need from our children, which are start
+ # expression and nonterminal definitions.
+
+ set gname [$t get root name]
+ set gstart [$t get root start]
+ if {$gstart ne ""} {
+ set stext [$t get $gstart TEXT]
+ } else {
+ puts stderr "No start expression."
+ set stext ""
+ }
+ set rules {}
+ foreach {sym def} [$t get root definitions] {
+ lappend rules [list $sym [$t get $def TEXT]]
+ }
+
+ # Combine them into a text for the whole grammar.
+
+ set intro "PEG $gname \("
+ set ispace [::textutil::blank [string length $intro]]
+
+ set out ""
+ append out "# -*- text -*-" \n
+ append out "## Parsing Expression Grammar '$gname'." \n
+ append out "## Layouted by the PG backend 'PEGwriter'." \n
+ append out \n
+ append out $intro[::textutil::indent $stext $ispace 1]\)
+ append out \n
+ append out \n
+
+ foreach e [lsort -dict -index 0 $rules] {
+ foreach {sym text} $e break
+ append out $text \n
+ append out \n
+ }
+
+ append out "END\;" \n
+
+ $t set root TEXT $out
+ return
+}
+
+proc ::page::gen::peg::canon::SynthNode/Nonterminal {t n} {
+ # This is the root of a definition. We now
+ # have to combine the text block for the
+ # expression with nonterminal and attribute
+ # data.
+
+ variable ms
+
+ set abase [$t get root ATT_BASE]
+ set sfl [$t get root SYM_FIELDLEN]
+ set mode [$t get $n mode]
+ set sym [$t get $n symbol]
+ set etext [$t get [lindex [$t children $n] 0] TEXT]
+
+ set out ""
+ append out $ms($abase,$mode)
+ append out $sym
+ append out [::textutil::blank [expr {$sfl - [string length $sym]}]]
+ append out " <- "
+
+ set ispace [::textutil::blank [string length $out]]
+
+ append out [::textutil::indent $etext $ispace 1]
+ append out " ;"
+
+ $t set $n TEXT $out
+ return
+}
+
+proc ::page::gen::peg::canon::SynthNode/t {t n} {
+ # Terminal node. Primitive layout.
+ # Put the char into single or double quotes.
+
+ set ch [$t get $n char]
+ if {$ch eq "'"} {set q "\""} else {set q '}
+
+ set text $q$ch$q
+
+ SetBlock $t $n $text
+ return
+}
+
+proc ::page::gen::peg::canon::SynthNode/n {t n} {
+ # Nonterminal node. Primitive layout. Text is the name of smybol
+ # itself.
+
+ SetBlock $t $n [$t get $n sym]
+ return
+}
+
+proc ::page::gen::peg::canon::SynthNode/.. {t n} {
+ # Range is [x-y]
+ set b [$t get $n begin]
+ set e [$t get $n end]
+ SetBlock $t $n "\[${b}-${e}\]"
+ return
+}
+
+proc ::page::gen::peg::canon::SynthNode/alnum {t n} {SetBlock $t $n <alnum>}
+proc ::page::gen::peg::canon::SynthNode/alpha {t n} {SetBlock $t $n <alpha>}
+proc ::page::gen::peg::canon::SynthNode/dot {t n} {SetBlock $t $n .}
+proc ::page::gen::peg::canon::SynthNode/epsilon {t n} {SetBlock $t $n ""}
+
+proc ::page::gen::peg::canon::SynthNode/? {t n} {SynthSuffix $t $n ?}
+proc ::page::gen::peg::canon::SynthNode/* {t n} {SynthSuffix $t $n *}
+proc ::page::gen::peg::canon::SynthNode/+ {t n} {SynthSuffix $t $n +}
+
+proc ::page::gen::peg::canon::SynthNode/! {t n} {SynthPrefix $t $n !}
+proc ::page::gen::peg::canon::SynthNode/& {t n} {SynthPrefix $t $n &}
+
+proc ::page::gen::peg::canon::SynthSuffix {t n op} {
+
+ set sub [lindex [$t children $n] 0]
+ set sop [$t get $sub op]
+ set etext [$t get $sub TEXT]
+
+ WrapParens $op $sop etext
+ SetBlock $t $n $etext$op
+ return
+}
+
+proc ::page::gen::peg::canon::SynthPrefix {t n op} {
+
+ set sub [lindex [$t children $n] 0]
+ set sop [$t get $sub op]
+ set etext [$t get $sub TEXT]
+
+ WrapParens $op $sop etext
+ SetBlock $t $n $op$etext
+ return
+}
+
+proc ::page::gen::peg::canon::SynthNode/x {t n} {
+ variable llen
+
+ # Space given to us for an expression.
+ set lend [expr {$llen - [$t get root HEADLEN]}]
+
+ set clist [$t children $n]
+ if {[llength $clist] == 1} {
+ # Implicit cutting out of chains.
+
+ CopyBlock $t $n [lindex $clist 0]
+
+ #puts stderr <<implicit>>
+ return
+ }
+
+ set out ""
+
+ # We are not tracking the total width of the block, but only the
+ # width of the current line, as that is where we may have to
+ # wrap. The height however is the total height.
+
+ #puts stderr <<$clist>>
+ #puts stderr \t___________________________________
+
+ set w 0
+ set h 0
+ foreach c $clist {
+ set sop [$t get $c op]
+ set sub [$t get $c TEXT]
+ set sw [$t get $c W]
+ set slw [$t get $c Wlast]
+ set sh [$t get $c H]
+
+ #puts stderr \t<$sop/$sw/$slw/$sh>___________________________________
+ #SHOW $sub $slw $sh
+
+ if {[Paren x $sop]} {
+ set sub "([::textutil::indent $sub " " 1])"
+ incr slw 2
+ incr sw 2
+
+ #puts stderr /paren/
+ #SHOW $sub $slw $sh
+ }
+
+ # Empty buffer ... Put element, and extend dimensions
+
+ #puts stderr \t.=============================
+ #SHOW $out $w $h
+
+ if {$w == 0} {
+ #puts stderr /init
+ append out $sub
+ set w $slw
+ set h $sh
+ } elseif {($w + $sw + 1) > $lend} {
+ #puts stderr /wrap/[expr {($w + $sw + 1)}]/$lend
+ # To large, wrap into next line.
+ append out \n $sub
+ incr h $sh
+ set w $slw
+ } else {
+ # We have still space to put the block in. Either by
+ # simply appending, or by indenting a multiline block
+ # properly so that its parts stay aligned with each other.
+ if {$sh == 1} {
+ #puts stderr /add/line
+ append out " " $sub
+ incr w ; incr w $slw
+ } else {
+ append out " " ; incr w
+ #puts stderr /add/block/$w
+ append out [::textutil::indent $sub [::textutil::blank $w] 1]
+ incr w $slw
+ incr h $sh ; incr h -1
+ }
+ }
+
+ #puts stderr \t.~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ #SHOW $out $w $h
+ }
+
+ SetBlock $t $n $out
+ return
+}
+
+proc ::page::gen::peg::canon::SynthNode// {t n} {
+ # We take all branches and put them together, nicely aligned under
+ # each other.
+
+ set clist [$t children $n]
+ if {[llength $clist] == 1} {
+ # Implicit cutting out of chains.
+
+ CopyBlock $t $n [lindex $clist 0]
+ return
+ }
+
+ set out ""
+ foreach c $clist {
+ set sop [$t get $c op]
+ set sub [$t get $c TEXT]
+ WrapParens / $sop sub
+ append out "/ [::textutil::indent $sub " " 1]" \n
+ }
+
+ SetBlock $t $n " [string range $out 1 end]"
+ return
+}
+
+proc ::page::gen::peg::canon::WrapParens {op sop tvar} {
+ if {[Paren $op $sop]} {
+ upvar 1 $tvar text
+ set text "([::textutil::indent $text " " 1])"
+ }
+}
+
+proc ::page::gen::peg::canon::Paren {op sop} {
+ # sop is nested under op.
+ # Parens are required if sop has a lower priority than op.
+
+ return [expr {[Priority $sop] < [Priority $op]}]
+}
+
+proc ::page::gen::peg::canon::Priority {op} {
+ switch -exact -- $op {
+ t -
+ n -
+ .. -
+ alnum -
+ alpha -
+ dot -
+ epsilon {return 4}
+ ? -
+ * -
+ + {return 3}
+ ! -
+ & {return 2}
+ x {return 1}
+ / {return 0}
+ }
+ return -code error "Internal error, bad operator \"$op\""
+}
+
+proc ::page::gen::peg::canon::CopyBlock {t n src} {
+ $t set $n TEXT [$t get $src TEXT]
+ $t set $n W [$t get $src W]
+ $t set $n Wlast [$t get $src Wlast]
+ $t set $n H [$t get $src H]
+ return
+}
+
+proc ::page::gen::peg::canon::SetBlock {t n text} {
+ set text [string trimright $text]
+ set lines [split $text \n]
+ set height [llength $lines]
+
+ if {$height > 1} {
+ set max -1
+ set ntext {}
+
+ foreach line $lines {
+ set line [string trimright $line]
+ set l [string length $line]
+ if {$l > $max} {set max $l}
+ lappend ntext $line
+ set wlast $l
+ }
+ set text [join $ntext \n]
+ set width $max
+ } else {
+ set width [string length $text]
+ set wlast $width
+ }
+
+ $t set $n TEXT $text
+ $t set $n W $width
+ $t set $n Wlast $wlast
+ $t set $n H $height
+ return
+}
+
+proc ::page::gen::peg::canon::AttrFieldLength {modeset} {
+ variable ms
+ return $ms($modeset,*)
+}
+
+if {0} {
+ proc ::page::gen::peg::canon::SHOW {text w h} {
+ set wl $w ; incr wl -1
+ puts stderr "\t/$h"
+ puts stderr "[textutil::indent $text \t|]"
+ puts stderr "\t\\[string repeat "-" $wl]^ ($w)"
+ return
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Strings.
+
+namespace eval ::page::gen::peg::canon {
+ variable llen 80
+ variable ms ; array set ms {
+ dlmv,discard {void: }
+ dlmv,leaf {leaf: }
+ dlmv,match {match: }
+ dlmv,value { }
+ dlmv,* 7
+
+ dlm,discard {void: } dlv,discard {void: }
+ dlm,leaf {leaf: } dlv,leaf {leaf: }
+ dlm,match {match: } dlv,value { }
+ dlm,* 7 dlv,* 6
+
+ dmv,discard {void: } lmv,leaf {leaf: }
+ dmv,match {match: } lmv,match {match: }
+ dmv,value { } lmv,value { }
+ dmv,* 7 lmv,* 7
+
+ dl,discard {void: } dm,discard {void: }
+ dl,leaf {leaf: } dm,match {match: }
+ dl,* 6 dm,* 7
+
+ lm,leaf {leaf: } dv,discard {void: }
+ lm,match {match: } dv,value { }
+ lm,* 7 dv,* 6
+
+ lv,leaf {leaf: } mv,match {match: }
+ lv,value { } mv,value { }
+ lv,* 6 mv,* 7
+
+ d,discard {void: } d,* 6
+ l,leaf {leaf: } l,* 6
+ m,match {match: } m,* 7
+ v,value {} v,* 0
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::gen::peg::canon 0.1
diff --git a/tcllib/modules/page/gen_peg_cpkg.tcl b/tcllib/modules/page/gen_peg_cpkg.tcl
new file mode 100644
index 0000000..5776f96
--- /dev/null
+++ b/tcllib/modules/page/gen_peg_cpkg.tcl
@@ -0,0 +1,171 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Parser Generator / Backend - PEG as Tcl script.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::util::peg
+
+namespace eval ::page::gen::peg::cpkg {
+ # Get various utilities.
+
+ namespace import ::page::util::peg::*
+}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::gen::peg::cpkg {t chan} {
+ cpkg::printWarnings [cpkg::getWarnings $t]
+
+ set grname [$t get root name]
+
+ cpkg::Header $chan $grname
+
+ set gstart [$t get root start]
+ if {$gstart ne ""} {
+ set gstart [cpkg::peOf $t $gstart]
+ } else {
+ puts stderr "No start expression."
+ }
+
+ cpkg::Start $chan $gstart
+
+ set temp {}
+ set max -1
+
+ foreach {sym def} [$t get root definitions] {
+ set eroot [lindex [$t children $def] 0]
+ set l [string length [list $sym]]
+ if {$l > $max} {set max $l}
+ lappend temp \
+ [list $sym [$t get $def mode] [cpkg::peOf $t $eroot] $l]
+ }
+
+ foreach e [lsort -dict -index 0 $temp] {
+ foreach {sym mode rule l} $e break
+ cpkg::Rule $chan $sym $mode $rule [expr {$max - $l}]
+ }
+
+ cpkg::Trailer $chan $grname
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Helpers
+
+proc ::page::gen::peg::cpkg::Header {chan grname} {
+ variable header
+ variable headerb
+
+ set stem [namespace tail $grname]
+ puts $chan [string map \
+ [list \
+ @@ [list $grname] \
+ @stem@ [list $stem] \
+ "\n\t" "\n"
+ ] \
+ $header\n$headerb]
+}
+
+proc ::page::gen::peg::cpkg::Start {chan pe} {
+ puts $chan " Start [printTclExpr $pe]\n"
+ return
+}
+
+proc ::page::gen::peg::cpkg::Rule {chan sym mode pe off} {
+ variable ms
+ set off [string repeat " " $off]
+ puts $chan " Define $ms($mode) $sym$off [printTclExpr $pe]"
+ return
+}
+
+proc ::page::gen::peg::cpkg::Trailer {chan grname} {
+ variable trailer
+ variable trailerb
+ puts $chan [string map \
+ [list \
+ @@ [list $grname] \
+ "\n\t" "\n"
+ ] \
+ $trailer\n$trailerb]
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Strings.
+
+namespace eval ::page::gen::peg::cpkg {
+ variable ms ; array set ms {
+ value {value }
+ discard {discard}
+ match {match }
+ leaf {leaf }
+ }
+ variable header {# -*- tcl -*-
+ ## Parsing Expression Grammar '@@'.
+
+ # ### ### ### ######### ######### #########
+ ## Package description
+
+ ## It provides a single command returning the handle of a
+ ## grammar container in which the grammar '@@'
+ ## is stored. The container is usable by a PEG interpreter
+ ## or other packages taking PE grammars.
+
+ # ### ### ### ######### ######### #########
+ ## Requisites.
+ ## - PEG container type
+
+ package require grammar::peg
+
+ namespace eval ::@@ {}
+
+ # ### ### ### ######### ######### #########
+ ## API
+
+ proc ::@@ {} {
+ return $@stem@::gr
+ }
+
+ # ### ### ### ######### ######### #########
+ # ### ### ### ######### ######### #########
+ ## Data and helpers.
+
+ namespace eval ::@@ {
+ # Grammar container
+ variable gr [::grammar::peg gr]
+ }
+
+ proc ::@@::Start {pe} {
+ variable gr
+ $gr start $pe
+ return
+ }
+
+ proc ::@@::Define {mode sym pe} {
+ variable gr
+ $gr nonterminal add $sym $pe
+ $gr nonterminal mode $sym $mode
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Initialization = Grammar definition
+ }
+ variable headerb "namespace eval ::@@ \{"
+
+ variable trailer "\}"
+ variable trailerb {
+ # ### ### ### ######### ######### #########
+ ## Package Management - Ready
+
+ package provide @@ 0.1
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::gen::peg::cpkg 0.1
diff --git a/tcllib/modules/page/gen_peg_hb.tcl b/tcllib/modules/page/gen_peg_hb.tcl
new file mode 100644
index 0000000..a4cbf6f
--- /dev/null
+++ b/tcllib/modules/page/gen_peg_hb.tcl
@@ -0,0 +1,79 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Parser Generator / Backend - PEG in half baked form for PEG container.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::util::peg
+
+namespace eval ::page::gen::peg::hb {
+ # Get various utilities.
+
+ namespace import ::page::util::peg::*
+}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::gen::peg::hb {t chan} {
+ hb::printWarnings [hb::getWarnings $t]
+
+ set gstart [$t get root start]
+ if {$gstart ne ""} {
+ set gstart [hb::peOf $t $gstart]
+ } else {
+ puts stderr "No start expression."
+ }
+
+ hb::Start $chan $gstart
+
+ set temp {}
+ set max -1
+ foreach {sym def} [$t get root definitions] {
+ set eroot [lindex [$t children $def] 0]
+ set l [string length [list $sym]]
+ if {$l > $max} {set max $l}
+ lappend temp \
+ [list $sym [$t get $def mode] [hb::peOf $t $eroot] $l]
+ }
+
+ foreach e [lsort -dict -index 0 $temp] {
+ foreach {sym mode rule l} $e break
+ hb::Rule $chan $sym $mode $rule [expr {$max - $l}]
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Helpers
+
+proc ::page::gen::peg::hb::Start {chan pe} {
+ puts $chan "Start [printTclExpr $pe]\n"
+ return
+}
+
+proc ::page::gen::peg::hb::Rule {chan sym mode pe off} {
+ variable ms
+ set off [string repeat " " $off]
+ puts $chan "Define $ms($mode) $sym$off [printTclExpr $pe]"
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Strings.
+
+namespace eval ::page::gen::peg::hb {
+ variable ms ; array set ms {
+ value {value }
+ discard {discard}
+ match {match }
+ leaf {leaf }
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::gen::peg::hb 0.1
diff --git a/tcllib/modules/page/gen_peg_me.tcl b/tcllib/modules/page/gen_peg_me.tcl
new file mode 100644
index 0000000..bb98902
--- /dev/null
+++ b/tcllib/modules/page/gen_peg_me.tcl
@@ -0,0 +1,888 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Parser Generator / Backend - Generate a grammar::mengine based parser.
+
+# This package assumes to be used from within a PAGE plugin. It uses
+# the API commands listed below. These are identical across the major
+# types of PAGE plugins, allowing this package to be used in reader,
+# transform, and writer plugins. It cannot be used in a configuration
+# plugin, and this makes no sense either.
+#
+# To ensure that our assumption is ok we require the relevant pseudo
+# package setup by the PAGE plugin management code.
+#
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Dumping the input grammar. But not as Tcl or other code. In PEG
+## format again, pretty printing.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: page::plugin
+
+package require page::plugin ; # S.a. pseudo-package.
+
+package require textutil
+package require page::analysis::peg::emodes
+package require page::util::quote
+package require page::util::peg
+
+namespace eval ::page::gen::peg::me {
+ # Get the peg char de/encoder commands.
+ # (unquote, quote'tcl)
+
+ namespace import ::page::util::quote::*
+ namespace import ::page::util::peg::*
+}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::gen::peg::me::package {text} {
+ variable package $text
+ return
+}
+
+proc ::page::gen::peg::me::copyright {text} {
+ variable copyright $text
+ return
+}
+
+proc ::page::gen::peg::me {t chan} {
+ variable me::package
+ variable me::copyright
+
+ # Resolve the mode hints. Every gen(X) having a value of 'maybe'
+ # (or missing) is for the purposes of this code a 'yes'.
+
+ if {![page::analysis::peg::emodes::compute $t]} {
+ page_error " Unable to generate a ME parser without accept/generate properties"
+ return
+ }
+
+ foreach n [$t nodes] {
+ if {![$t keyexists $n gen] || ([$t get $n gen] eq "maybe")} {
+ $t set $n gen 1
+ }
+ if {![$t keyexists $n acc]} {$t set $n acc 1}
+ }
+
+ $t set root Pcount 0
+
+ $t set root package $package
+ $t set root copyright $copyright
+
+ # Synthesize all text fragments we need.
+ me::Synth $t
+
+ # And write the grammar text.
+ puts $chan [$t get root TEXT]
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Helpers
+
+proc ::page::gen::peg::me::Synth {t} {
+ # Phase 2: Bottom-up, synthesized attributes
+ #
+ # - Text blocks per node.
+
+ $t walk root -order post -type dfs n {
+ SynthNode $t $n
+ }
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode {t n} {
+ if {$n eq "root"} {
+ set code Root
+ } elseif {[$t keyexists $n symbol]} {
+ set code Nonterminal
+ } elseif {[$t keyexists $n op]} {
+ set code [$t get $n op]
+ } else {
+ return -code error "PANIC. Bad node $n, cannot classify"
+ }
+
+ #puts stderr "SynthNode/$code $t $n"
+
+ SynthNode/$code $t $n
+
+ #SHOW [$t get $n TEXT] 1 0
+ #catch {puts stderr "\t.[$t get $n W]x[$t get $n H]"}
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode/Root {t n} {
+ variable template
+
+ # Root is the grammar itself.
+
+ # Text blocks we have to combine:
+ # - Code for matching the start expression
+ # - Supporting code for the above.
+ # - Code per Nonterminal definition.
+
+ set gname [$t get root name]
+ set gstart [$t get root start]
+ set gpackage [$t get root package]
+ set gcopy [$t get root copyright]
+
+ if {$gcopy ne ""} {
+ set gcopyright "## (C) $gcopy\n"
+ } else {
+ set gcopyright ""
+ }
+ if {$gpackage eq ""} {
+ set gpackage $gname
+ }
+
+ page_info " Grammar: $gname"
+ page_info " Package: $gpackage"
+ if {$gcopy ne ""} {
+ page_info " Copyright: $gcopy"
+ }
+
+ if {$gstart ne ""} {
+ set match [textutil::indent \
+ [$t get $gstart MATCH] \
+ " "]
+ } else {
+ page_error " No start expression."
+ set match ""
+ }
+
+ set crules {}
+ set rules {}
+ set support [$t get [$t get root start] SUPPORT]
+ if {[string length $support]} {
+ lappend rules $support
+ lappend rules {}
+ }
+
+ lappend crules "# Grammar '$gname'"
+ lappend crules {#}
+
+ array set def [$t get root definitions]
+ foreach sym [lsort -dict [array names def]] {
+ lappend crules [Pfx "# " [$t get $def($sym) EXPR]]
+ lappend crules {#}
+
+ lappend rules [$t get $def($sym) TEXT]
+ lappend rules {}
+ }
+ set rules [join [lrange $rules 0 end-1] \n]
+
+ lappend crules {}
+ lappend crules $rules
+
+ set crules [join $crules \n]
+
+ # @PKG@ and @NAME@ are handled after the other expansions as their
+ # contents may insert additional instances of these placeholders.
+
+ $t set root TEXT \
+ [string map \
+ [list \
+ @NAME@ $gname \
+ @PKG@ $gpackage \
+ @COPY@ $gcopyright] \
+ [string map \
+ [list \
+ @MATCH@ $match \
+ @RULES@ $crules \
+ ] $template]]
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode/Nonterminal {t n} {
+ # This is the root of a definition.
+ #
+ # The text is a procedure wrapping the match code of its
+ # expression into the required the nonterminal handling (caching
+ # and such), plus the support code for the expression matcher.
+
+ set sym [$t get $n symbol]
+ set label [$t get $n label]
+ set gen [$t get $n gen]
+ set mode [$t get $n mode]
+
+ set pe [lindex [$t children $n] 0]
+ set egen [$t get $pe gen]
+ set esupport [$t get $pe SUPPORT]
+ set ematch [$t get $pe MATCH]
+ set eexpr [$t get $pe EXPR]
+
+ # Combine the information.
+
+ set sexpr [Cat "$sym = " $eexpr]
+
+ set match {}
+ #lappend match "puts stderr \"$label << \[icl_get\]\""
+ #lappend match {}
+ lappend match [Pfx "# " $sexpr]
+ lappend match {}
+ if {$gen} {
+ lappend match {variable ok}
+ lappend match "if \{\[inc_restore $label\]\} \{"
+ lappend match " if \{\$ok\} ias_push"
+ #lappend match " puts stderr \">> $label = \$ok (c) \[icl_get\]\""
+ lappend match " return"
+ lappend match "\}"
+ } else {
+ set eop [$t get $pe op]
+ if {
+ ($eop eq "t") || ($eop eq "..") ||
+ ($eop eq "alpha") || ($eop eq "alnum")
+ } {
+ # Required iff !dot
+ # Support for terminal expression
+ lappend match {variable ok}
+ }
+
+ #lappend match "variable ok"
+ lappend match "if \{\[inc_restore $label\]\} return"
+ #lappend match "if \{\[inc_restore $label\]\} \{"
+ #lappend match " puts stderr \">> $label = \$ok (c) \[icl_get\]\""
+ #lappend match " return"
+ #lappend match "\}"
+ }
+ lappend match {}
+ lappend match {set pos [icl_get]}
+ if {$egen} {
+ # [*] Needed for removal of SV's from stack after handling by
+ # this symbol, only if expression actually generates an SV.
+ lappend match {set mrk [ias_mark]}
+ }
+ lappend match {}
+ lappend match $ematch
+ lappend match {}
+
+ switch -exact -- $mode {
+ value {lappend match "isv_nonterminal_reduce $label \$pos \$mrk"}
+ match {lappend match "isv_nonterminal_range $label \$pos"}
+ leaf {lappend match "isv_nonterminal_leaf $label \$pos"}
+ discard {lappend match "isv_clear"}
+ default {return -code error "Bad nonterminal mode \"$mode\""}
+ }
+
+ lappend match "inc_save $label \$pos"
+ if {$egen} {
+ # See [*], this is the removal spoken about before.
+ lappend match {ias_pop2mark $mrk}
+ }
+ if {$gen} {
+ lappend match {if {$ok} ias_push}
+ }
+ lappend match "ier_nonterminal \"Expected $label\" \$pos"
+ #lappend match "puts stderr \">> $label = \$ok \[icl_get\]\""
+ lappend match return
+
+ # Final assembly
+
+ set pname [Call $sym]
+ set match [list [Proc $pname [join $match \n]]]
+
+ if {[string length $esupport]} {
+ lappend match {}
+ lappend match $esupport
+ }
+
+ $t set $n TEXT [join $match \n]
+ $t set $n EXPR $sexpr
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode/? {t n} {
+ # The expression e? is equivalent to e/epsilon.
+ # And like this it is compiled.
+
+ set pe [lindex [$t children $n] 0]
+ set ematch [$t get $pe MATCH]
+ set esupport [$t get $pe SUPPORT]
+ set eexpr [$t get $pe EXPR]
+ set egen [$t get $pe gen]
+ set sexpr "[Cat "(? " $eexpr])"
+
+ set match {}
+ lappend match {}
+ lappend match [Pfx "# " $sexpr]
+ lappend match {}
+ lappend match {variable ok}
+ lappend match {}
+ lappend match {set pos [icl_get]}
+ lappend match {}
+ lappend match {set old [ier_get]}
+ lappend match $ematch
+ lappend match {ier_merge $old}
+ lappend match {}
+ lappend match {if {$ok} return}
+ lappend match {icl_rewind $pos}
+ lappend match {iok_ok}
+ lappend match {return}
+
+ # Final assembly
+
+ set pname [NextProc $t opt]
+ set match [list [Proc $pname [join $match \n]]]
+ if {[string length $esupport]} {
+ lappend match {}
+ lappend match $esupport
+ }
+
+ $t set $n EXPR $sexpr
+ $t set $n MATCH [Cat "$pname ; " [Pfx "# " $sexpr]]
+ $t set $n SUPPORT [join $match \n]
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode/* {t n} {
+ # Kleene star is like a repeated ?
+
+ # Note: Compilation as while loop, as done now
+ # means that the parser has no information about
+ # the intermediate structure of the input in his
+ # cache.
+
+ # Future: Create a helper symbol X and compile
+ # the expression e = e'* as:
+ # e = X; X <- (e' X)?
+ # with match data for X put into the cache. This
+ # is not exactly equivalent, the structure of the
+ # AST is different (right-nested tree instead of
+ # a list). This however can be handled with a
+ # special nonterminal mode to expand the current
+ # SV on the stack.
+
+ # Note 2: This is a transformation which can be
+ # done on the grammar itself, before the actual
+ # backend is let loose. This "strength reduction"
+ # allows us to keep this code here.
+
+ set pe [lindex [$t children $n] 0]
+ set ematch [$t get $pe MATCH]
+ set esupport [$t get $pe SUPPORT]
+ set eexpr [$t get $pe EXPR]
+ set egen [$t get $pe gen]
+ set sexpr "[Cat "(* " $eexpr])"
+
+ set match {}
+ lappend match {}
+ lappend match [Pfx "# " $sexpr]
+ lappend match {}
+ lappend match {variable ok}
+ lappend match {}
+ lappend match "while \{1\} \{"
+ lappend match { set pos [icl_get]}
+ lappend match {}
+ lappend match { set old [ier_get]}
+ lappend match [textutil::indent $ematch " "]
+ lappend match { ier_merge $old}
+ lappend match {}
+ lappend match { if {$ok} continue}
+ lappend match { break}
+ lappend match "\}"
+ lappend match {}
+ lappend match {icl_rewind $pos}
+ lappend match {iok_ok}
+ lappend match {return}
+
+ # Final assembly
+
+ set pname [NextProc $t kleene]
+ set match [list [Proc $pname [join $match \n]]]
+ if {[string length $esupport]} {
+ lappend match {}
+ lappend match $esupport
+ }
+
+ $t set $n MATCH [Cat "$pname ; " [Pfx "# " $sexpr]]
+ $t set $n SUPPORT [join $match \n]
+ $t set $n EXPR $sexpr
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode/+ {t n} {
+ # Positive Kleene star x+ is equivalent to x x*
+ # This is how it is compiled. See also the notes
+ # at the * above, they apply in essence here as
+ # well, except that the transformat scheme is
+ # slighty different:
+ #
+ # e = e'* ==> e = X; X <- e' X?
+
+ set pe [lindex [$t children $n] 0]
+ set ematch [$t get $pe MATCH]
+ set esupport [$t get $pe SUPPORT]
+ set eexpr [$t get $pe EXPR]
+ set egen [$t get $pe gen]
+ set sexpr "[Cat "(+ " $eexpr])"
+
+ set match {}
+ lappend match {}
+ lappend match [Pfx "# " $sexpr]
+ lappend match {}
+ lappend match {variable ok}
+ lappend match {}
+ lappend match {set pos [icl_get]}
+ lappend match {}
+ lappend match {set old [ier_get]}
+ lappend match $ematch
+ lappend match {ier_merge $old}
+ lappend match {}
+ lappend match "if \{!\$ok\} \{"
+ lappend match { icl_rewind $pos}
+ lappend match { return}
+ lappend match "\}"
+ lappend match {}
+ lappend match "while \{1\} \{"
+ lappend match { set pos [icl_get]}
+ lappend match {}
+ lappend match { set old [ier_get]}
+ lappend match [textutil::indent $ematch " "]
+ lappend match { ier_merge $old}
+ lappend match {}
+ lappend match { if {$ok} continue}
+ lappend match { break}
+ lappend match "\}"
+ lappend match {}
+ lappend match {icl_rewind $pos}
+ lappend match {iok_ok}
+ lappend match {return}
+
+ # Final assembly
+
+ set pname [NextProc $t pkleene]
+ set match [list [Proc $pname [join $match \n]]]
+ if {[string length $esupport]} {
+ lappend match {}
+ lappend match $esupport
+ }
+
+ $t set $n MATCH [Cat "$pname ; " [Pfx "# " $sexpr]]
+ $t set $n SUPPORT [join $match \n]
+ $t set $n EXPR $sexpr
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode// {t n} {
+ set args [$t children $n]
+
+ if {![llength $args]} {
+ error "PANIC. Empty choice."
+
+ } elseif {[llength $args] == 1} {
+ # A choice over one branch is no real choice. The code
+ # generated for the child applies here as well.
+
+ set pe [lindex $args 0]
+ $t set $n MATCH [$t get $pe MATCH]
+ $t set $n SUPPORT [$t get $pe SUPPORT]
+ return
+ }
+
+ # Choice over at least two branches.
+
+ set match {}
+ set support {}
+ set sexpr {}
+
+ lappend match {}
+ lappend match {}
+ lappend match {variable ok}
+ lappend match {}
+ lappend match {set pos [icl_get]}
+ foreach pe $args {
+ lappend match {}
+
+ set ematch [$t get $pe MATCH]
+ set esupport [$t get $pe SUPPORT]
+ set eexpr [$t get $pe EXPR]
+ set egen [$t get $pe gen]
+
+ # Note: We do not check for static match results. Doing so is
+ # an optimization we can do earlier, directly on the tree.
+
+ lappend sexpr $eexpr
+
+ if {[string length $esupport]} {
+ lappend support {}
+ lappend support $esupport
+ }
+
+ if {$egen} {
+ lappend match "set mrk \[ias_mark\]"
+ }
+
+ lappend match "set old \[ier_get\]"
+ lappend match $ematch
+ lappend match "ier_merge \$old"
+ lappend match {}
+ lappend match "if \{\$ok\} return"
+
+ if {$egen} {
+ lappend match "ias_pop2mark \$mrk"
+ }
+ lappend match "icl_rewind \$pos"
+ }
+ lappend match {}
+ lappend match return
+
+ # Final assembly
+
+ set sexpr "[Cat "(/ " [join $sexpr \n]])"
+ set match [linsert $match 1 [Pfx "# " $sexpr]]
+
+ set pname [NextProc $t bra]
+ set match [list [Proc $pname [join $match \n]]]
+ if {[llength $support]} {
+ lappend match {}
+ lappend match [join [lrange $support 1 end] \n]
+ }
+
+ $t set $n MATCH [Cat "$pname ; " [Pfx "# " $sexpr]]
+ $t set $n SUPPORT [join $match \n]
+ $t set $n EXPR $sexpr
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode/x {t n} {
+ set args [$t children $n]
+
+ if {![llength $args]} {
+ error "PANIC. Empty sequence."
+
+ } elseif {[llength $args] == 1} {
+ # A sequence of one element is no real sequence. The code
+ # generated for the child applies here as well.
+
+ set pe [lindex $args 0]
+ $t set $n MATCH [$t get $pe MATCH]
+ $t set $n SUPPORT [$t get $pe SUPPORT]
+ $t set $n EXPR [$t get $pe EXPRE]
+ return
+ }
+
+ # Sequence of at least two elements.
+
+ set match {}
+ set support {}
+ set sexpr {}
+ set gen 0
+
+ lappend match {}
+ lappend match {}
+ lappend match {variable ok}
+ lappend match {}
+ lappend match {set pos [icl_get]}
+
+ foreach pe $args {
+ lappend match {}
+
+ set ematch [$t get $pe MATCH]
+ set esupport [$t get $pe SUPPORT]
+ set eexpr [$t get $pe EXPR]
+ set egen [$t get $pe gen]
+
+ lappend sexpr $eexpr
+
+ if {[string length $esupport]} {
+ lappend support {}
+ lappend support $esupport
+ }
+
+ if {$egen && !$gen} {
+ # From here on out is the sequence
+ # able to generate semantic values
+ # which have to be canceled when
+ # backtracking.
+
+ lappend match "set mrk \[ias_mark\]"
+ lappend match {}
+ set gen 1
+ }
+
+ lappend match "set old \[ier_get\]"
+ lappend match $ematch
+ lappend match "ier_merge \$old"
+ lappend match {}
+
+ if {$gen} {
+ lappend match "if \{!\$ok\} \{"
+ lappend match " ias_pop2mark \$mrk"
+ lappend match " icl_rewind \$pos"
+ lappend match " return"
+ lappend match "\}"
+ } else {
+ lappend match "if \{!\$ok\} \{icl_rewind \$pos \; return\}"
+ }
+ }
+ lappend match {}
+ lappend match return
+
+ # Final assembly
+
+ set sexpr "[Cat "(x " [join $sexpr \n]])"
+ set match [linsert $match 1 [Pfx "# " $sexpr]]
+
+ set pname [NextProc $t seq]
+ set match [list [Proc $pname [join $match \n]]]
+ if {[llength $support]} {
+ lappend match {}
+ lappend match [join [lrange $support 1 end] \n]
+ }
+
+ $t set $n MATCH [Cat "$pname ; " [Pfx "# " $sexpr]]
+ $t set $n SUPPORT [join $match \n]
+ $t set $n EXPR $sexpr
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode/& {t n} {
+ SynthLookahead $t $n no
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode/! {t n} {
+ SynthLookahead $t $n yes
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode/dot {t n} {
+ SynthTerminal $t $n \
+ "any character" {}
+ $t set $n EXPR "(dot)"
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode/epsilon {t n} {
+ $t set $n MATCH iok_ok
+ $t set $n SUPPORT {}
+ $t set $n EXPR "(epsilon)"
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode/alnum {t n} {
+ SynthClass $t $n alnum
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode/alpha {t n} {
+ SynthClass $t $n alpha
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode/.. {t n} {
+ # Range is [x-y]
+
+ set b [$t get $n begin]
+ set e [$t get $n end]
+
+ set tb [quote'tcl $b]
+ set te [quote'tcl $e]
+
+ set pb [quote'tclstr $b]
+ set pe [quote'tclstr $e]
+
+ set cb [quote'tclcom $b]
+ set ce [quote'tclcom $e]
+
+ SynthTerminal $t $n \
+ "\\\[${pb}..${pe}\\\]" \
+ "ict_match_tokrange $tb $te"
+ $t set $n EXPR "(.. $cb $ce)"
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode/t {t n} {
+ # Terminal node. Primitive matching.
+ # Code is parameterized by gen(X) of this node X.
+
+ set ch [$t get $n char]
+ set tch [quote'tcl $ch]
+ set pch [quote'tclstr $ch]
+ set cch [quote'tclcom $ch]
+
+ SynthTerminal $t $n \
+ $pch \
+ "ict_match_token $tch"
+ $t set $n EXPR "(t $cch)"
+ return
+}
+
+proc ::page::gen::peg::me::SynthNode/n {t n} {
+ # Nonterminal node. Primitive matching.
+ # The code is parameterized by acc(X) of this node X, and gen(D)
+ # of the invoked nonterminal D.
+
+ set sym [$t get $n sym]
+ set def [$t get $n def]
+
+ if {$def eq ""} {
+ # Invokation of an undefined nonterminal. This will always fail.
+ set match "iok_fail ; # Match for undefined symbol '$sym'."
+ } else {
+ # Combinations
+ # Acc Gen Action
+ # --- --- ------
+ # 0 0 Plain match
+ # 0 1 Match with canceling of the semantic value.
+ # 1 0 Plain match
+ # 1 1 Plain match
+ # --- --- ------
+
+ if {[$t get $n acc] || ![$t get $def gen]} {
+ set match [Call $sym]
+ } else {
+ set match {}
+ lappend match "set p$sym \[ias_mark\]"
+ lappend match [Call $sym]
+ lappend match "ias_pop2mark \$p$sym"
+ set match [join $match \n]
+ }
+ }
+
+ set sexpr "(n $sym)"
+ $t set $n EXPR $sexpr
+ $t set $n MATCH "$match ; # $sexpr"
+ $t set $n SUPPORT {}
+ return
+}
+
+proc ::page::gen::peg::me::SynthLookahead {t n negated} {
+ # Note: Per the rules about expression modes (! is a lookahead
+ # ____| operator) this node has a mode of 'discard', and its child
+ # ____| has so as well.
+
+ # assert t get n mode == discard
+ # assert t get pe mode == discard
+
+ set op [$t get $n op]
+ set pe [lindex [$t children $n] 0]
+ set eop [$t get $pe op]
+ set ematch [$t get $pe MATCH]
+ set esupport [$t get $pe SUPPORT]
+ set eexpr [$t get $pe EXPR]
+ set pname [NextProc $t bang]
+
+ set match {}
+
+ if {
+ ($eop eq "t") || ($eop eq "..") ||
+ ($eop eq "alpha") || ($eop eq "alnum")
+ } {
+ # Required iff !dot
+ # Support for terminal expression
+ lappend match {variable ok}
+ lappend match {}
+ }
+
+ lappend match {set pos [icl_get]}
+ lappend match {}
+ lappend match $ematch
+ lappend match {}
+ lappend match {icl_rewind $pos}
+
+ if {$negated} {
+ lappend match {iok_negate}
+ }
+
+ lappend match return
+
+ set match [list [Proc $pname [join $match \n]]]
+ if {[string length $esupport]} {
+ lappend match {}
+ lappend match $esupport
+ }
+
+ $t set $n MATCH $pname
+ $t set $n SUPPORT [join $match \n]
+ $t set $n EXPR "($op $eexpr)"
+ return
+}
+
+proc ::page::gen::peg::me::SynthClass {t n op} {
+ SynthTerminal $t $n \
+ <$op> \
+ "ict_match_tokclass $op"
+ $t set $n EXPR ($op)
+ return
+}
+
+proc ::page::gen::peg::me::SynthTerminal {t n msg cmd} {
+ set match {}
+ lappend match "ict_advance \"Expected $msg (got EOF)\""
+
+ if {$cmd ne ""} {
+ lappend match "if \{\$ok\} \{$cmd \"Expected $msg\"\}"
+ }
+ if {[$t get $n gen]} {
+ lappend match "if \{\$ok\} isv_terminal"
+ }
+
+ $t set $n MATCH [join $match \n]
+ $t set $n SUPPORT {}
+ return
+}
+
+proc ::page::gen::peg::me::Call {sym} {
+ # Generator for proc names (nonterminal symbols).
+ return matchSymbol_$sym
+}
+
+proc ::page::gen::peg::me::NextProc {t {mark {}}} {
+ set count [$t get root Pcount]
+ incr count
+ $t set root Pcount $count
+ return e$mark$count
+}
+
+proc ::page::gen::peg::me::Proc {name body} {
+ set script {}
+ lappend script "proc ::@PKG@::$name \{\} \{"
+ lappend script [::textutil::indent $body " "]
+ lappend script "\}"
+ return [join $script \n]
+}
+
+proc ::page::gen::peg::me::Cat {prefix suffix} {
+ return "$prefix[textutil::indent $suffix [textutil::blank [string length $prefix]] 1]"
+}
+
+proc ::page::gen::peg::me::Pfx {prefix suffix} {
+ return [textutil::indent $suffix $prefix]
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Strings.
+
+namespace eval ::page::gen::peg::me {
+
+ variable here [file dirname [info script]]
+ variable template_file [file join $here gen_peg_me.template]
+
+ variable ch
+ variable template \
+ [string trimright [read [set ch [open $template_file r]]][close $ch]]
+ unset ch
+
+ variable package ""
+ variable copyright ""
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::gen::peg::me 0.1
diff --git a/tcllib/modules/page/gen_peg_me.template b/tcllib/modules/page/gen_peg_me.template
new file mode 100644
index 0000000..070e671
--- /dev/null
+++ b/tcllib/modules/page/gen_peg_me.template
@@ -0,0 +1,61 @@
+# -*- tcl -*-
+## Parsing Expression Grammar '@NAME@'.
+## Recursive Descent Packrat parser generated
+## by the PAGE writer plugin 'me'.
+@COPY@
+# ### ### ### ######### ######### #########
+## Package description
+
+# The commands provided here match an input provided through a buffer
+# command to the PE grammar '@NAME@'. The parser is based on the package
+# 'grammar::me::tcl' (recursive-descent, packrat, pulling chars,
+# pushing the generated AST).
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require grammar::me::tcl
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+namespace eval ::@PKG@ {
+ # Import the virtual machine for matching.
+
+ namespace import ::grammar::me::tcl::*
+ upvar #0 ::grammar::me::tcl::ok ok
+}
+
+# ### ### ### ######### ######### #########
+## API Implementation.
+
+proc ::@PKG@::parse {nxcmd emvar astvar} {
+ variable ok
+ variable se
+
+ upvar 1 $emvar emsg $astvar ast
+
+ init $nxcmd
+
+@MATCH@
+
+ isv_nonterminal_reduce ALL -1
+ set ast [sv]
+ if {!$ok} {
+ foreach {l m} [ier_get] break
+ lappend l [lc $l]
+ set emsg [list $l $m]
+ }
+
+ return $ok
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper methods
+
+@RULES@
+
+# ### ### ### ######### ######### #########
+## Package Management
+
+package provide @PKG@ 0.1
diff --git a/tcllib/modules/page/gen_peg_mecpu.tcl b/tcllib/modules/page/gen_peg_mecpu.tcl
new file mode 100644
index 0000000..e0b49aa
--- /dev/null
+++ b/tcllib/modules/page/gen_peg_mecpu.tcl
@@ -0,0 +1,289 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2006 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Parser Generator / Backend - Generate a grammar::me::cpu based parser.
+
+# This package assumes to be used from within a PAGE plugin. It uses
+# the API commands listed below. These are identical across the major
+# types of PAGE plugins, allowing this package to be used in reader,
+# transform, and writer plugins. It cannot be used in a configuration
+# plugin, and this makes no sense either.
+#
+# To ensure that our assumption is ok we require the relevant pseudo
+# package setup by the PAGE plugin management code.
+#
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+
+## The input is a grammar, not as tree, but as a list of instructions
+## (symbolic form). This backend converts that into machinecode for
+## grammar::m::cpu::core and inserts the result into a template file.
+
+## The translation from grammar tree to assembler code was done in a
+## preceding transformation.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: page::plugin
+
+package require page::plugin ; # S.a. pseudo-package.
+
+package require grammar::me::cpu::core
+package require textutil
+
+#package require page::analysis::peg::emodes
+#package require page::util::quote
+#package require page::util::peg
+
+namespace eval ::page::gen::peg::mecpu {}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::gen::peg::mecpu::package {text} {
+ variable package $text
+ return
+}
+
+proc ::page::gen::peg::mecpu::copyright {text} {
+ variable copyright $text
+ return
+}
+
+proc ::page::gen::peg::mecpu::template {path} {
+ variable template $path
+ return
+}
+
+proc ::page::gen::peg::mecpu::cmarker {list} {
+ variable cmarker $list
+ return
+}
+
+proc ::page::gen::peg::mecpu {asmcode chan} {
+
+ # asmcode = list (name code)
+ # code = list (instruction)
+ # instruction = list (label name arg...)
+
+ variable mecpu::package
+ variable mecpu::copyright
+ variable mecpu::cmarker
+ variable mecpu::template
+ variable mecpu::template_file
+
+ # Import the config options, provide fallback to defaults for the
+ # unspecified parts.
+
+ set gname [lindex $asmcode 0]
+ set gcode [lindex $asmcode 1]
+
+ if {$package eq ""} {set package $gname}
+
+ page_info " Grammar: $gname"
+ page_info " Package: $package"
+
+ if {$copyright ne ""} {
+ page_info " Copyright: $copyright"
+ set copyright "\#\# (C) $copyright\n"
+ }
+
+ if {$template eq ""} {
+ set template $template_file
+ }
+
+ page_info " Template: $template"
+
+ # Translate the incoming assembler to machine code.
+
+ set mcode [grammar::me::cpu::core::asm $gcode]
+
+ # We know that the machine code has three parts (instructions,
+ # string pool, token map). We take the data apart to allow separate
+ # insertion if the template so chooses (like for readability).
+
+ foreach {minsn mpool mtmap} $mcode break
+
+ set fminsn {} ; set i 0 ; set j 19
+ while {$i < [llength $minsn]} {
+ append fminsn " [lrange $minsn $i $j]\n"
+ incr i 20 ; incr j 20
+ }
+
+ set fmpool {} ; set i 0 ; set j 4
+ while {$i < [llength $mpool]} {
+ append fmpool " [lrange $mpool $i $j]\n"
+ incr i 5 ; incr j 5
+ }
+
+ # ------------------------------------
+ # We also generate a readable representation of the assembler
+ # instructions for insertion into a comment area.
+
+ set asmp [mecpu::2readable $gcode $minsn]
+
+ # ------------------------------------
+
+ # And write the modified template
+ puts $chan [string map [list \
+ @NAME@ $gname \
+ @PKG@ $package \
+ @COPY@ $copyright \
+ @CODE@ $mcode \
+ @INSN@ $minsn \
+ @FNSN@ $fminsn \
+ @POOL@ $mpool \
+ @FPOL@ $fmpool \
+ @TMAP@ $mtmap \
+ @ASMP@ $asmp \
+ ] [mecpu::Template]]
+ return
+}
+
+proc ::page::gen::peg::mecpu::Template {} {
+ variable template
+ return [string trimright [read [set ch [open $template r]]][close $ch]]
+}
+
+proc ::page::gen::peg::mecpu::2readable {asmcode mecode} {
+ return [2print $asmcode $mecode max [widths $asmcode max]]
+}
+
+proc ::page::gen::peg::mecpu::widths {asmcode mv} {
+ upvar 1 $mv max
+
+ # First iteration, column widths (instructions, and arguments).
+ # Ignore comments, they go across all columns.
+ # Also ignore labels (lrange 1 ..).
+
+ set mc 0
+ foreach insn $asmcode {
+ set i [lindex $insn 1]
+ if {$i eq ".C"} continue
+ set col 0
+
+ foreach x [lrange $insn 1 end] {
+ set xlen [string length $x]
+ if {![info exists max($col)] || ($xlen > $max($col))} {set max($col) $xlen}
+ incr col
+
+ # Shift the strings of various commands into the third
+ # column, if they are not already there.
+
+ if {$i eq "ier_nonterminal"} {incr col ; set i ""}
+ if {$i eq "isv_nonterminal_leaf"} {incr col ; set i ""}
+ if {$i eq "isv_nonterminal_range"} {incr col ; set i ""}
+ if {$i eq "isv_nonterminal_reduce"} {incr col ; set i ""}
+ if {$i eq "inc_save"} {incr col ; set i ""}
+ if {$i eq "ict_advance"} {incr col ; set i ""}
+ }
+ if {$col > $mc} {set mc $col}
+ }
+
+ set max($mc) 0
+ return $mc
+}
+
+proc ::page::gen::peg::mecpu::2print {asmcode mecode mv mc} {
+ variable cmarker
+ upvar 1 $mv max
+
+ set lines {}
+ set pc 0
+
+ foreach insn $asmcode {
+ foreach {label name} $insn break
+ if {$name eq ".C"} {lappend lines "" "-- [join [lrange $insn 2 end] " "]" ""}
+ if {$label ne ""} {lappend lines " ${label}:" }
+ if {$name eq ".C"} continue
+
+ set line " [format %05d $pc] "
+
+ set pcs $pc
+ incr pc [llength $insn] ; incr pc -1
+ set pce $pc ; incr pce -1
+ set imecode [lrange $mecode $pcs $pce]
+
+ if {
+ ($name eq "ier_nonterminal") ||
+ ($name eq "isv_nonterminal_leaf") ||
+ ($name eq "isv_nonterminal_range") ||
+ ($name eq "isv_nonterminal_reduce") ||
+ ($name eq "inc_save") ||
+ ($name eq "ict_advance")
+ } {
+ # Shift first argument into 2nd column, and quote it as well.
+ set insn [lreplace $insn 2 2 "" '[lindex $insn 2]']
+ } elseif {
+ ($name eq "inc_restore") ||
+ ($name eq "ict_match_token") ||
+ ($name eq "ict_match_tokclass")
+ } {
+ # Command with quoted arguments, no shifting.
+ set insn [lreplace $insn 3 3 '[lindex $insn 3]']
+ } elseif {
+ ($name eq "ict_match_tokrange")
+ } {
+ # Command with quoted arguments, no shifting.
+ set insn [lreplace $insn 4 4 '[lindex $insn 4]']
+ }
+
+ while {[llength $insn] <= $mc} {lappend insn ""}
+ lappend insn "-- $imecode"
+
+ set col 0
+ foreach x [lrange $insn 1 end] {
+ set xlen [string length $x]
+ append line " "
+ append line $x
+ append line [string repeat " " [expr {$max($col) - $xlen}]]
+ incr col
+ }
+
+ lappend lines $line
+ }
+
+ # Wrap the lines into a comment.
+
+ if {$cmarker eq ""} {set cmarker "\#"}
+
+ if {[llength $cmarker] > 1} {
+ # Comments are explictly closed as well.
+
+ foreach {cs ce} $cmarker break
+ return "$cs [join $lines " $ce\n$cs "] $ce"
+ } else {
+ # Comments are not explicitly closed. Implicit by end-of-line
+
+ return "$cmarker [join $lines "\n$cmarker "]"
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Strings.
+
+namespace eval ::page::gen::peg::mecpu {
+
+ variable here [file dirname [info script]]
+ variable template_file [file join $here gen_peg_mecpu.template]
+
+ variable package ""
+ variable copyright ""
+ variable template ""
+ variable cmarker ""
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::gen::peg::mecpu 0.1
diff --git a/tcllib/modules/page/gen_peg_mecpu.template b/tcllib/modules/page/gen_peg_mecpu.template
new file mode 100644
index 0000000..38cf901
--- /dev/null
+++ b/tcllib/modules/page/gen_peg_mecpu.template
@@ -0,0 +1,48 @@
+# -*- tcl -*-
+## Parsing Expression Grammar '@NAME@'.
+## Recursive Descent Packrat parser generated
+## by the PAGE writer plugin 'mecpu'.
+@COPY@
+# ### ### ### ######### ######### #########
+## Package description
+
+# The commands provided here match an input provided through a buffer
+# command to the PE grammar '@NAME@'. The parser is based on the ME
+# virtual machine (recursive-descent, packrat, pulling chars,
+# pushing the generated AST, suspendable).
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# Import the virtual machine for matching.
+package require grammar::me::cpu
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+snit::type ::@PKG@ {
+ constructor {} {
+ set cpu [grammar::me::cpu ${selfns}::cpu $mecode]
+ return
+ }
+ variable cpu
+ delegate method * to cpu
+
+ typevariable mecode {
+ {
+@FNSN@ }
+ {
+@FPOL@ }
+ {@TMAP@}
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Documentation. Readable form of 'mecode' above.
+
+@ASMP@
+
+# ### ### ### ######### ######### #########
+## Package Management
+
+package provide @PKG@ 0.1
diff --git a/tcllib/modules/page/gen_peg_ser.tcl b/tcllib/modules/page/gen_peg_ser.tcl
new file mode 100644
index 0000000..7fb8266
--- /dev/null
+++ b/tcllib/modules/page/gen_peg_ser.tcl
@@ -0,0 +1,63 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Parser Generator / Backend - PEG as serialized PEG container.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require grammar::peg
+package require page::util::quote
+package require page::util::peg
+
+namespace eval ::page::gen::peg::ser {
+ # Get the peg char de/encoder commands.
+ # (unquote, quote'tcl), and other utilities.
+
+ namespace import ::page::util::quote::*
+ namespace import ::page::util::peg::*
+}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::gen::peg::ser {t chan} {
+ ser::printWarnings [ser::getWarnings $t]
+
+ ::grammar::peg gr
+
+ set gstart [$t get root start]
+ if {$gstart ne ""} {
+ gr start [ser::peOf $t $gstart]
+ } else {
+ page_info "No start expression."
+ }
+
+ foreach {sym def} [$t get root definitions] {
+ set eroot [lindex [$t children $def] 0]
+
+ gr nonterminal add $sym [ser::peOf $t $eroot]
+ gr nonterminal mode $sym [$t get $def mode]
+ }
+
+ puts $chan [gr serialize]
+ gr destroy
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Helpers
+
+proc ::page::gen::peg::ser::GetRules {t} {
+ return $res
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Strings.
+
+namespace eval ::page::gen::peg::ser {}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::gen::peg::ser 0.1
diff --git a/tcllib/modules/page/gen_tree_text.tcl b/tcllib/modules/page/gen_tree_text.tcl
new file mode 100644
index 0000000..44b674f
--- /dev/null
+++ b/tcllib/modules/page/gen_tree_text.tcl
@@ -0,0 +1,94 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Parser Generator / Backend - Dump (A)ST for inspection.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::util::quote
+
+namespace eval ::page::gen::tree::text {
+ # Get the peg char de/encoder commands.
+ # (unquote, quote'tcl)
+
+ namespace import ::page::util::quote::*
+}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::gen::tree::text {t chan} {
+ set indent ""
+ set bystr " "
+ set bysiz [string length $bystr]
+ set byoff end-$bysiz
+
+ $t walk root -order both -type dfs {a n} {
+ if {$a eq "enter"} {
+ text::WriteNode $indent $chan $t $n
+ append indent $bystr
+ } else {
+ set indent [string range $indent 0 $byoff]
+ }
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Helpers
+
+proc ::page::gen::tree::text::WriteNode {indent chan t n} {
+ array set attr [$t getall $n]
+
+ if {[array size attr] == 0} {
+ puts $chan "$indent$n <>"
+ } else {
+ puts -nonewline $chan "$indent$n < "
+
+ set max -1
+ set d {}
+ foreach k [array names attr] {
+ set l [string length $k]
+ if {$l > $max} {set max $l}
+ lappend d [list $k [Quote $attr($k)] $l]
+ }
+
+ if {[llength $d] == 1} {
+ puts $chan "$k = $attr($k) >"
+ return
+ }
+
+ set first 1
+ set space $indent[string repeat " " [string length "$n < "]]
+
+ foreach e [lsort -dict -index 0 $d] {
+ foreach {k v l} $e break
+ set off [string repeat " " [expr {$max-$l}]]
+
+ if {$first} {
+ puts -nonewline $chan "$k$off = $v"
+ set first 0
+ } else {
+ puts -nonewline $chan "\n$space$k$off = $v"
+ }
+ }
+
+ puts $chan " >"
+ }
+}
+
+proc ::page::gen::tree::text::Quote {str} {
+ return $str
+
+ set res ""
+ foreach c [split $str {}] {
+ append res [quote'tcl $c]
+ }
+ return $res
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::gen::tree::text 0.1
diff --git a/tcllib/modules/page/notes/doc_emodes.txt b/tcllib/modules/page/notes/doc_emodes.txt
new file mode 100644
index 0000000..dd9ea19
--- /dev/null
+++ b/tcllib/modules/page/notes/doc_emodes.txt
@@ -0,0 +1,180 @@
+PE Grammar Tree, after ExprMode Computation
+===========================================
+
+This file documents the augmentations to a Normalized PE Grammar Tree
+as inserted by the transformational package 'pg::peg::emodes'. The
+input to the transformation is assumed to be a 'Normalized PE Grammar
+Tree' as described in 'doc_normalize.txt', possibly with augmentations
+from other transformation, as long as they are not in conflict with
+the augmentations specified here.
+
+Background
+----------
+
+The purpose of the computations and transformations specified here is
+to determine as much static information as we can about the generation
+of semantic values from terminal and non-terminal matchers. Such
+information can then be used to reduce the places in a parser which
+generate and/or handle AST nodes to the bare minimum. I.e we wish to
+avoid the generation of AST nodes by the matcher for which we are sure
+that they will be thrown away by the matcher either immediately, or
+later on.
+
+The fundamental information from which everything else is derived are
+the optional 'mode's which can specified for non-terminal symbols (See
+nonterminal 'Attribute' in the PEG Grammar). They are the hints to the
+matcher on how semantic values are generated and used.
+
+The mode of a nonterminal symbol controls three things at the same
+time: What it does with semantic values generated by its associated
+expression, if it generates its own semantic value, and how. These
+three aspects are interelated to each other, hence using one piece of
+information to set all of them. For this discussion the aspect of
+"how" is not relevant, except where it intersects with the other two.
+
+For the first aspect, the nonterminal has two choices, to either keep
+the semantic value from its expression, or to discard it. I.e this is
+about accepting versus rejection of the value. This aspect is
+'Acceptance'.
+
+For the second aspect the nonterminal has three choices, to either
+generate a value, to not generate a value at all, or to simply pass
+through whatever was done by its expression (a maybe). This aspect is
+'Generation'.
+
+The interelation of these aspects shows up as impossible
+combinations when selecting a value from each set, as made explicit in
+the next table:
+
+ Generation x Acceptance -> Mode
+ ---------- ---------- ----
+ Maybe Yes value
+ Yes Yes value
+ No Yes -- impossible --
+ Maybe No -- impossible --
+ Yes No match, leaf [1]
+ No No discard
+ ---------- ---------- ----
+
+ [1] Here the third aspect, the "how" of the generation comes
+ into play to distinguish these two modes. As said, this
+ distinction is not relevant for the current discussion.
+
+
+What we now wish to achieve is to define the vales for these two
+aspects for all expression and definition modes, which, starting from
+the settings of the modes by the input grammar, is the most definite,
+restrictive and conservative as possible.
+
+- Most definite, try to remove as many Maybe's as possible in favor of
+ Yes or No.
+
+- Most restrictive, prefer a No over Yes when trying to remove a Maybe.
+
+- Most conversative, do not try to remove a Maybe if we are not truly
+ sure about its value.
+
+The two node properties computes are
+
+* gen(X): Node -> {Yes, No, Maybe}
+
+ Yes: The node X definitely generates a semantic
+ value.
+
+ No: The node X definitely does not generate a
+ semantic value.
+
+ Maybe: The node X passes semantic values, should they
+ be generated by a child of X. We do not know
+ if values are generated or not.
+
+ A derivative function is gen', defined as
+
+ gen'(X,G): Node x {Yes, No, Pass} -> Bool
+ gen'(X,G) = (gen(X) == G)
+
+ Conversely we could define gen in terms of gen' as
+
+ gen (X) = G, iff gen'(X,G)
+
+* acc(X): Node -> Bool
+
+ True: The node X will keep semantic values generated
+ by its children.
+
+ False: The node X will throw any semantic values
+ generated by its children away.
+
+General information
+-------------------
+
+* The specification of 'doc_normalize.txt' applies fully.
+
+Structure
+---------
+
+* The structure of the tree is unchanged.
+
+Attributes
+----------
+
+Name Type Details
+---- ---- -------
+pg::peg::emodes
+ none
+ Root node only. The presence of this attribute
+ indicates that the emode computation has been been
+ executed on the grammar and that we have valid
+ results.
+
+ Transformations whose execution invalidates the emode
+ information have to remove this marker.
+==== ==== =======
+gen enum Expression and definition nodes only. Values are in
+ {yes, no, maybe}. Contains the value of gen(X).
+---- ---- -------
+acc bool Expression and definition nodes only. Contains the
+ value of acc(X).
+---- ---- -------
+
+Transformation
+--------------
+
+It is possible to specify a mode transformation based on the mode
+computation. It would resolve discontinuities in the gen/acc stati
+(Use of expressions generating a value where none is accepted) by
+duplicating relevant nonterminal definitions and forcing them into
+specific modes (discard). If expressions to be duplicated contain
+calls to undefined nonterminal symbols then the new definitions will
+do so as well.
+
+This transformation will not be written for now. The reason for that
+is that it essentially defeats packrat parsing.
+
+The definitions which are duplicated are used in both contexts which
+accept and such which do not accept the generated value, otherwise the
+regular analysis would have mode the definition itself non-accepting
+and non-generating.
+
+While it is possible to put the match status of both the original and
+duplicated definition into the packrat cache under the same label
+there is one important distinction which cannot be avoided: The
+duplicated definition does not generate a semantic value. And we
+cannot exclude the possibilities that either a cached semantic value
+is used in a non-accepting context which is not prepared to handle
+this value (by discarding it), or that an accepting context uses
+cached information which is short of one expected semantic value.
+
+So the two definitions have to cache their information under different
+labels to avoid a mixup. But now it becomes possible that the match
+engine has to fully reparse a segment of input during backtracking
+despite actually having information about matchability, just under a
+different label in the cache. And this then costs us the O(n) of the
+packrat parser, pushing it back exponential time-complexity.
+
+Conclusion: The described transformation can be applied if and only if
+we have ensured that the matcher will never backtrack in the input for
+the grammar in question. In other words, other transformation like
+left-factorisation, eliminiation of left-recursion etc. have to be
+applied first. In even other words, the grammar has to be LL(1) (which
+implies that it will not use any lookahead operators either).
diff --git a/tcllib/modules/page/notes/doc_emodes_alg.txt b/tcllib/modules/page/notes/doc_emodes_alg.txt
new file mode 100644
index 0000000..31b9508
--- /dev/null
+++ b/tcllib/modules/page/notes/doc_emodes_alg.txt
@@ -0,0 +1,171 @@
+PE Grammar Tree, after ExprMode Computation
+===========================================
+
+This file is a companion to the file 'doc_emodes.txt'. The former
+describes the node attributes we wish to have, here we formally
+specify the properties of the attributes, and then derive from that an
+algorithm for their computation.
+
+Per node
+--------
+
+First we specify the properties of the attributes on a case by case
+basis, for each possible type of node. This may invole a lot of
+repetition, but this detail is necessary to be able to the patterns in
+the definition which then allow us to simplify things.
+
+Legend
+~~~~~~
+ X Current node.
+ parent(X) Parent node of X.
+ users(X) n-Nodes invoking the definition.
+ def(X) Definition node invoked by X.
+ children(X) Set of all children of X.
+ child(X) Child of X (if X has only a single child)
+ |S| Cardinality of the set S.
+ AllYes(X) gen'(Y,yes), for all Y in children(X).
+ AllNo(X) gen'(Y,no), for all Y in children(X).
+ SomeYes(X) gen'(Y,yes), exists Y in children(X).
+ SomeNo(X) gen'(Y,no), exists Y in children(X).
+ Mode(X) Nonterminal mode provided by the input.
+ Discard(X) Mode(X) == discard
+ Value(X) Mode(X) == value
+ Data(X) Mode(X) in {match, leaf}
+
+
+Node type acc(X) gen(X)
+~~~~~~~~~ ~~~~~~ ~~~~~~
+DEF FALSE, !Value(X) || yes, Data(X) || (Value(X) && AllYes(X))
+ !acc(child(X)) || no, Discard(X) || (Value(X) && AllNo(X))
+ USER || maybe, Value(X) && !AllYes(X) && !AllNo(X)
+ gen(X,no)
+ TRUE, else
+
+ USER = (|Users(X)| == 1) &&
+ !acc(Users(X))
+~~~~~~~~~ ~~~~~~ ~~~~~~
+!, & FALSE no
+~~~~~~~~~ ~~~~~~ ~~~~~~
+?, * acc(parent(X)) no, AllNo(X) [2]
+ maybe, else
+~~~~~~~~~ ~~~~~~ ~~~~~~
++ acc(parent(X)) yes, AllYes(X)
+ no, AllNo(X)
+ maybe, else
+~~~~~~~~~ ~~~~~~ ~~~~~~
+x acc(parent(X)) yes, SomeYes(X) [3]
+ no, AllNo(X)
+ maybe, else
+~~~~~~~~~ ~~~~~~ ~~~~~~
+/ acc(parent(X)) yes, AllYes(X) [3]
+ no, AllNo(X)
+ maybe, else
+~~~~~~~~~ ~~~~~~ ~~~~~~
+t, epsilon, acc(parent(X)) [1] yes, acc(parent(X))
+dot, alnum, no, !acc(parent(X))
+alpha
+~~~~~~~~~ ~~~~~~ ~~~~~~
+n acc(parent(X)) yes, acc(X) && gen'(def(X),yes)
+ no, !acc(X) || gen'(def(X),no)
+ maybe, acc(X) && gen'(def(X),maybe)
+~~~~~~~~~ ~~~~~~ ~~~~~~
+
+From this specification we can draw the following conclusions about
+the properties and their calculation:
+
+- Acceptance data is defined top-down, from root to the leaves.
+
+- Generation data is defined bottom-up, from leaves to the root.
+
+- In the leaves Acceptance data is converted into Generation data.
+ Nonterminal calls additional hook in the Generation data of the
+ called symbols.
+
+- In the definition Generation data can convert into Acceptance data,
+ and Nonterminal uses hook in the Generation data from the calling
+ nodes, and may hook in Acceptance data as well.
+
+The important places are the two sides of boundaries, i.e. the
+definition nodes, and the n-Nodes calling on definitions. Only there
+the property values may need resolution of conflicts. Anywhere else
+the values are derived in simple equations, allowing their computation
+in trivial sweeps.
+
+
+Algorithm
+~~~~~~~~~
+
+1. Initialization.
+
+ acc(X), gen(X) for all DEFs, without consideration for
+ children and users (use maybe for unknown parts).
+
+2. Sweep
+
+ For all definitions
+
+ a. Sweep top-down.
+ acc(X) for all nodes.
+
+ b. Sweep bottom-up
+ gen(X) for all nodes.
+
+3. Resolution.
+
+ Recompute acc(X), gen(X) for all DEFs, using the full
+ equations. Remember which nodes changed.
+
+4. Repeat from 2 using the remembered set of DEFs, if not
+ empty. Stop if the set of changed DEFs is empty.
+
+Algorithm 2
+~~~~~~~~~~~
+
+1. Initialization.
+
+ acc(X), gen(X) for all DEFs, without consideration for
+ children and users (use maybe for unknown parts).
+
+2. Sweep
+
+ For all definitions
+
+ Sweep top-down.
+ acc(X), gen(X) for all nodes
+
+ The gen(X) is possible because an initial value is
+ directly computable from acc(X), without having to
+ look at the children at all.
+
+ !acc(X) => gen(X,No).
+ acc(X) => gen(X,Maybe)
+
+ Even better. If !acc(X) we can count the type of
+ calls for invoked nonterminals, and if that is the
+ number of users we can immediately change their
+ acc(X) and sweep down further (similar to reachable).
+
+ We remember the interesting places where things can change.
+ The leaf nodes, and lookahead operators.
+
+3. Sweep the 2nd, working up from each interesting place (sorted
+ by depth, deepest first) up through the ancestors, and when
+ reaching def-Nodes we can now sweep up further into the users.
+
+ If this changes acc(X) for a definition (only down to discard)
+ we remember, and after completion go back to 2.
+
+_____________________________________________________
+[1] Actually the value is not really relevant as there are no childen
+ to consider. However with the chosen definition the number of
+ special cases to consider is reduced. I.e. the definition of the
+ function is more uniform.
+
+[2] The *- and ?-operators match even if the expression underneath them
+ does not. In which case there will be no SV. So the best we can
+ say even if the expression surely does generates an SV is maybe.
+
+[3] The x- and /-operators can be made more accurate if we have data
+ about static match results, as this information can cut down the
+ set of children to actually consider for matching and generation
+ of values.
diff --git a/tcllib/modules/page/notes/doc_grammar.txt b/tcllib/modules/page/notes/doc_grammar.txt
new file mode 100644
index 0000000..9c02b3b
--- /dev/null
+++ b/tcllib/modules/page/notes/doc_grammar.txt
@@ -0,0 +1,68 @@
+Raw PE Grammar AS Tree
+======================
+
+This file documents the tree generated by the frontend for reading a
+PE grammar in textual form.
+
+General information
+-------------------
+
+* The tree is implemented using 'struct::tree'.
+* It is an abstract syntax tree semantically.
+
+Structure
+---------
+
+* The root node has one child, of type ALL (*), we call this ALL.
+
+* The structure of the tree under the node ALL reflects the structure
+ of the PE grammar used by the frontend to read grammar.
+
+ - Void nonterminals are leafs of the tree.
+
+ - Match nonterminals have one child node carrying the matched
+ terminal string.
+
+ - All other nonterminals have children per the structure of the rule
+ matched and the nonterminals therein.
+
+~~
+(*) <=> ((type == nonterminal) && (text == ALL))
+
+Attributes
+----------
+
+The node root is exceptional, it has no attributes. The "set of all
+nodes" referenced in the descriptions below does not include it.
+
+Name Type Details
+---- ---- -------
+type enum At all nodes. Values in {terminal, nonterminal}. The
+ type of the node, telling us if it is a container for
+ a nonterminal symbol or for a terminal string.
+---- ---- -------
+detail string At all nodes. Meaning of its value is dependent on the
+ value of the attribute 'type'.
+
+ nonterminal : Name of symbol
+
+ terminal : Terminal data.
+
+ This is always the lexeme, as found in
+ the input. For character data from
+ strings this means that the text
+ contains the special forms as well,
+ i.e. quoted with backslashes.
+==== ==== =======
+at int Restricted to nodes of type 'terminal'. Represents the
+atcol int location in the input where the terminal data starts
+atline int (= the location of the first character), as offset,
+ and in line/column notation (*)
+---- ---- -------
+to int As above, but representing the end location.
+tocol int
+toline int
+---- ---- -------
+
+~~
+(*) Lines are counted from 1. Columns are counted from 0.
diff --git a/tcllib/modules/page/notes/doc_normalize.txt b/tcllib/modules/page/notes/doc_normalize.txt
new file mode 100644
index 0000000..b64ad04
--- /dev/null
+++ b/tcllib/modules/page/notes/doc_normalize.txt
@@ -0,0 +1,138 @@
+Normalized PE Grammar Tree
+==========================
+
+This file documents the tree generated by the transformational package
+'pg::peg::normalize'. The input to the transformation is assumed to be
+a 'Raw PE Grammar AS Tree', as generated by the PEG frontend, and
+described in 'doc_grammar.txt'.
+
+General information
+-------------------
+
+* The tree is implemented using 'struct::tree'.
+
+* The tree is used as a higher data structures keeping the various
+ parts of a grammar together, which are: Start parsing expression,
+ definitions, and their parsing expressions. The tree nature of the
+ parsing expressions map especially nicely to this data structure.
+
+Structure
+---------
+
+* The root node represents the overall grammar. It has one child node
+ for the start expression, and one child per definition of a
+ nonterminal symbol in the grammar. No other nodes are possible. The
+ order of the children is not specified and an implementation
+ detail. Attributes in the root provide quick access, and the nodes
+ can also be distinguished by the attributes they have and/or their
+ values.
+
+* A definition node represents a single nonterminal definition from
+ the grammar. Most of the information describing the definition is
+ stored in attributes of the node. Sole exception is the parsing
+ expression associated with the defined nonterminal symbol. This is
+ represented by an expression subtree, the root of which is the
+ single child of the definition node.
+
+* All other nodes represent a parsing expression with the operator
+ stored in the node and its arguments represented by the children of
+ the node. For operators allowing more than one argument the children
+ will be in the same order as specified in the grammar. I.e. the
+ first child represents the first argument to the operator, and so
+ on.
+
+Attributes
+----------
+
+Name Type Details
+---- ---- -------
+name string Root only. The name of the grammar represented by the
+ tree.
+---- ---- -------
+start noderef Root only. Id of the tree node which is the root of
+ the start expression. A child of the root node. Does
+ not intersect with the set of definition nodes. Can be
+ empty, representing a grammar without start expression.
+---- ---- -------
+definitions Root only. Maps the names (strings) of nonterminal
+ dict symbols to the ids of the tree nodes (noderef) which
+ represents the definition of that symbol. The nodes
+ are all immediate children of the root node. None of
+ them can be the root of the start expression
+ however. The dictionary can be empty, representing a
+ grammar which has no nonterminal symbols.
+---- ---- -------
+undefined Root only. Maps the name (string) of a nonterminal
+ dict symbol which has no definition in the grammar to a
+ list containting the ids of the tree nodes (noderef)
+ which use the symbol despite that. I.e. if this value
+ is not empty the grammar is invalid and has 'holes'.
+==== ==== =======
+symbol string Root and definition nodes only. The name of the
+ nonterminal symbol whose definition the node is
+ representing. For root this is '<StartExpression>'.
+ It is defined for root so that some algorithms on
+ expressions can use it as a sentinel.
+---- ---- -------
+label string Definition nodes only. The name of the input grammar
+ level nonterminal symbol represented by the node. This
+ is normally identical to 'symbol', but can differ for
+ helper definitions introduced by transformations. For
+ such 'symbol' will refer to the generated name of the
+ symbol, and 'label' to the name of the symbol in the
+ grammar the helper belongs to.
+---- ---- -------
+mode enum Definition nodes only. Values in {value, discard,
+ leaf, match}. Specifies how the defined nonterminal
+ handles the generation of its semantic value during
+ matching.
+---- ---- -------
+users list Definition nodes only. A list containing the ids of
+ the tree nodes which reference this definition. These
+ nodes are always expression nodes, with operator
+ 'n'. The list can be empty, representing a nonterminal
+ symbol which is defined, but not used anywhere in
+ grammar.
+==== ==== =======
+op enum All expression nodes. Values in {n, t, .., epsilon,
+ alpha, alnum, x, /, ?, *, +, !, &}. Specifies the
+ operator part of the expression represented by the
+ node.
+---- ---- -------
+char char Expression nodes with operator 't' (t-Nodes)
+ only. Value is the single character from the grammar
+ to match, as represented by Tcl. I.e. any quoting from
+ the input has been resolved.
+---- ---- -------
+begin char ..-Nodes only. Values are like 'char' above, the first
+end char and last character in the range to match.
+---- ---- -------
+sym string n-Nodes only. The name of the nonterminal symbol to
+ match.
+---- ---- -------
+def noderef n-Nodes only. The id of the definition node for the
+ nonterminal symbol to match. Can be empty. In that
+ case the node repesents a try to match an undefined
+ nonterminal symbol. The value of 'sym' will be a key
+ in the dictionary of root->undefined, and the id of
+ this node an element in the list associated with that
+ key.
+==== ==== =======
+at*, to* See 'doc_grammar.txt' for the general definition.
+
+ All nodes except root.
+
+ Definition nodes: The span of input covered by the
+ definition.
+
+ Expression nodes: The span of input covered by the
+ expression.
+
+ The nodes for the operators
+
+ dot, alpha, alnum, epsilon
+
+ have no location information right now. Nodes based
+ on them may have only partial or no information as
+ well.
+---- ---- -------
diff --git a/tcllib/modules/page/notes/doc_reachable.txt b/tcllib/modules/page/notes/doc_reachable.txt
new file mode 100644
index 0000000..f6e3b10
--- /dev/null
+++ b/tcllib/modules/page/notes/doc_reachable.txt
@@ -0,0 +1,71 @@
+PE Grammar Tree, after Reachables Computation
+=============================================
+
+This file documents the augmentations to a Normalized PE Grammar Tree
+as inserted by the transformational package 'pg::peg::reachable'. The
+input to the transformation is assumed to be a 'Normalized PE Grammar
+Tree' as described in 'doc_normalize.txt', possibly with augmentations
+from other transformation, as long as they are not in conflict with
+the augmentations specified here.
+
+General information
+-------------------
+
+* The specification of 'doc_normalize.txt' applies fully.
+
+Structure
+---------
+
+* The structure of the tree is unchanged.
+
+Attributes
+----------
+
+Name Type Details
+---- ---- -------
+pg::peg::reachable
+ list
+ Root node only. The presence of this attribute
+ indicates that the reachable computation has been been
+ executed on the grammar and that we have valid
+ results.
+
+ Contains a list of the nodes (definition, and
+ expression) which are reachable from the root node of
+ the start expression.
+---- ---- -------
+pg::peg::unreachable
+ list
+ Root node only. Contains a list of the nodes
+ (definition, and expression) which are __not__
+ reachable from the root node of the start expression.
+---- ---- -------
+
+Reachability is defined on the definition and expression nodes via
+
+- The root node of the start expression is reachable.
+- An expression node is reachable if its parent node (expression or
+ definition) is reachable.
+- A definition node is reachable, if at least one its using expression
+ nodes is reachable.
+- No other node is reachable.
+
+This definition leads to a simple recursive (top-down) algorithm for
+sweeping a grammar and marking all reachable nodes. We do however
+remember only the reachbility of definitions, as that is the only
+information truly relevant.
+
+Transformation
+--------------
+
+The reachable transformation is based on the reachable computation and
+the agumented tree generated by it. The transformation removes all
+definitions which are not reachable. This may leave the grammar
+without definitions.
+
+Note that this change may remove invokations of undefined nonterminal
+symbols. It however cannot produce new invokations of undefined
+nonterminal symbols as the removed definitions have no actual users by
+definition. Those which have invoking nodes (as recorded in 'users')
+are used by an unreachable definition (This can be an unreachable
+circle of definitions).
diff --git a/tcllib/modules/page/notes/doc_realizable.txt b/tcllib/modules/page/notes/doc_realizable.txt
new file mode 100644
index 0000000..6652d90
--- /dev/null
+++ b/tcllib/modules/page/notes/doc_realizable.txt
@@ -0,0 +1,101 @@
+PE Grammar Tree, after Realizability Computation
+================================================
+
+This file documents the augmentations to a Normalized PE Grammar Tree
+as inserted by the transformational package
+'page::analysis::peg::realizable'. The input to the transformation is
+assumed to be a 'Normalized PE Grammar Tree' as described in
+'doc_normalize.txt', possibly with augmentations from other
+transformations, as long as they are not in conflict with the
+augmentations specified here.
+
+Background
+----------
+
+The realizability of a nonterminal is usually defined for Context Free
+Grammars. For PE grammars we define the property by treating them as
+CFG and then following the usual definition, given below:
+
+ A nonterminal symbol N of a CF grammar G is useful, if and
+ only if a terminal sentence can be derived from it in a finite
+ number of steps. A terminal sentence is a sentence which is
+ either empty or contains only terminal symbols.
+
+This intrinsic specification is equivalent to the following explicit
+rules for the computation of realizability of arbitrary parsing
+expressions:
+
+* A char expression (t) is realizable.
+* A range expression (..) is realizable.
+* A special expression (alnum, alpha) is realizable.
+* A dot expression (.) is realizable.
+* An epsilon expression (epsilon) is realizable.
+* A sequence expression (x) is realizable if and only if all of its
+ argument expressions are realizable.
+* A choice-expression (/) is realizable if and only if at least one
+ of its argument expressions is realizable [1].
+* A Kleene closure (*) is realizable.
+* A positive Kleene closure (+) is realizable, if and only if its
+ argument expression is realizable.
+* An optional expression (?) is realizable.
+* A nonterminal expression is realizable if and only if the invoked
+ nonterminal definition is realizable.
+* A nonterminal definition is realizable if and only if its
+ definining expression is realizable.
+* All other expressions are not realizable.
+
+From the rules above it is clear that the property is defined by the
+leaves of the expression trees and then flows upward towards the
+roots, and at the roots it jumps over the gap from nonterminal
+definition to nonterminal use for further propagation.
+
+This leads to an iterative algorithm which starts with the initial set
+of realizable nodes and then works its way to find all of their parents
+which are also realizable.
+
+[1] It is here where we treat the PEG like a CFG. The ordered choice
+is implicitly handled like an unordered choice.
+
+
+General information
+-------------------
+
+* The specification of 'doc_normalize.txt' applies fully.
+
+Structure
+---------
+
+* The structure of the tree is unchanged.
+
+Attributes
+----------
+
+Name Type Details
+---- ---- -------
+pg::peg::realizable Root node only. The presence of this attribute
+ list indicates that the realizability computation has been
+ been executed on the grammar and that we have valid
+ results.
+
+ Contains a list of the nodes which are realizable.
+---- ---- -------
+pg::peg::unrealizable
+ list
+ Root node only. Contains a list of the nodes which are
+ __not__ realizable.
+---- ---- -------
+
+Transformation
+--------------
+
+The realizability transformation is based on the realizability computation
+and the agumented tree generated by it. The transformation removes all
+(partial) expressions and definitions are not realizable. This may leave
+the grammar without definitions, and without a start expression as
+well.
+
+Note that this change may remove invokations of undefined nonterminal
+symbols. It however cannot produce new invokations of undefined
+nonterminal symbols as a unrealizable definition implies a
+unrealizable invokation, i.e. the invokations of unrealizable
+definitions are removed themselves as well.
diff --git a/tcllib/modules/page/page_intro.man b/tcllib/modules/page/page_intro.man
new file mode 100644
index 0000000..66f211a
--- /dev/null
+++ b/tcllib/modules/page/page_intro.man
@@ -0,0 +1,35 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin page_intro n 1.0]
+[keywords page]
+[keywords {parser generator}]
+[keywords {text processing}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Parser generator tools}]
+[titledesc {page introduction}]
+[category {Page Parser Generator}]
+[description]
+[para]
+
+[term page] (short for [emph {parser generator}]) stands for a set of
+related packages which help in the construction of parser generators,
+and other utilities doing text processing.
+
+[para]
+
+They are mainly geared towards supporting the Tcllib application
+[syscmd page], with the package [package page::pluginmgr] in a central
+role as the plugin management for the application. The other packages
+are performing low-level text processing and utility tasks geared
+towards parser generation and mainly accessed by [syscmd page] through
+plugins.
+
+[para]
+
+The packages implementing the plugins are not documented as regular
+packages, as they cannot be loaded into a general interpreter, like
+tclsh, without extensive preparation of the interpreter. Preparation
+which is done for them by the plugin manager.
+
+[vset CATEGORY page]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/page/page_pluginmgr.man b/tcllib/modules/page/page_pluginmgr.man
new file mode 100644
index 0000000..c0e67d7
--- /dev/null
+++ b/tcllib/modules/page/page_pluginmgr.man
@@ -0,0 +1,800 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin page_pluginmgr n 1.0]
+[keywords page]
+[keywords {parser generator}]
+[keywords {text processing}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Parser generator tools}]
+[titledesc {page plugin manager}]
+[category {Page Parser Generator}]
+[require page::pluginmgr [opt 0.2]]
+[require fileutil]
+[description]
+[para]
+
+This package provides the plugin manager central to the [syscmd page]
+application. It manages the various reader, writer, configuration, and
+transformation plugins which actually process the text (read,
+transform, and write).
+
+[para]
+
+All plugins are loaded into slave interpreters specially prepared for
+them. While implemented using packages they need this special
+environment and are not usable in a plain interpreter, like
+tclsh. Because of that they are only described in general terms in
+section [sectref {PREDEFINED PLUGINS}], and not documented as regular
+packages. It is expected that they follow the APIs specified in the
+sections
+
+[list_begin enum]
+[enum] [sectref {CONFIG PLUGIN API}]
+[enum] [sectref {READER PLUGIN API}]
+[enum] [sectref {WRITER PLUGIN API}]
+[enum] [sectref {TRANSFORM PLUGIN API}]
+[list_end]
+
+as per their type.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::page::pluginmgr::reportvia] [arg cmd]]
+
+This command defines the callback command used by
+
+[cmd ::page::pluginmgr::report] (see below) to report input errors and
+warnings. The default is to write such reports to the standard error
+channel.
+
+[call [cmd ::page::pluginmgr::report] [arg level] [arg text] [opt "[arg from] [opt [arg to]]"]]
+
+This command is used to report input errors and warnings. By default
+such reports are written to the standard error. This can be changed by
+setting a user-specific callback command with
+[cmd ::page::pluginmgr::reportvia] (see above).
+
+[para]
+
+The arguments [arg level] and [arg text] specify both the importance
+of the message, and the message itself. For the former see the package
+[package logger] for the allowed values.
+
+[para]
+
+The optional argument [arg from] and [arg to] can be used by the
+caller to indicate the location (or range) in the input where the
+reported problem occured. Each is a list containing two elements, the
+line and the column in the input, in this order.
+
+[call [cmd ::page::pluginmgr::log] [arg cmd]]
+
+This command defines a log callback command to be used by loaded
+plugins for the reporting of internal errors, warnings, and general
+information. Specifying the empty string as callback disables logging.
+
+[para]
+
+Note: The [arg cmd] has to be created by the [package logger] package,
+or follow the same API as such.
+
+[para]
+
+The command returns the empty string as its result.
+
+[call [cmd ::page::pluginmgr::configuration] [arg name]]
+
+This command loads the named configuration plugin, retrieves the
+options encoded in it, and then immediately unloads it again.
+
+[para]
+
+If the [arg name] is the path to a file, then this files will be tried
+to be loaded as a plugin first, and, if that fails, opened and its
+contents read as a list of options and their arguments, separated by
+spaces, tabs and newlines, possibly quotes with single and double
+quotes.
+
+[para]
+
+See section [sectref {CONFIG PLUGIN API}] for the API expected of
+configuration plugins.
+
+[para]
+
+The result of the command is the list of options retrieved.
+
+[call [cmd ::page::pluginmgr::reader] [arg name]]
+
+This command loads the named reader plugin and initializes it. The
+result of the command is a list of options the plugin understands.
+
+[para]
+
+Only a single reader plugin can be loaded. Loading another reader
+plugin causes the previously loaded reader plugin to be de-initialized
+and unloaded.
+
+[para]
+
+See section [sectref {READER PLUGIN API}] for the API expected of
+reader plugins.
+
+[call [cmd ::page::pluginmgr::rconfigure] [arg dict]]
+
+This commands configures the loaded reader plugin. The options and
+their values are provided as a Tcl dictionary. The result of the
+command is the empty string.
+
+[call [cmd ::page::pluginmgr::rtimeable]]
+
+This commands checks if the loaded reader plugin is able to collect
+timing statistics. The result of the command is a boolean flag. The
+result is [const true] if the plugin can be timed, and [const false]
+otherwise.
+
+[call [cmd ::page::pluginmgr::rtime]]
+
+This command activates the collection of timing statistics in the
+loaded reader plugin.
+
+[call [cmd ::page::pluginmgr::rgettime]]
+
+This command retrieves the collected timing statistics of the loaded
+reader plugin after it was executed.
+
+[call [cmd ::page::pluginmgr::rhelp]]
+
+This command retrieves the help string of the loaded reader
+plugin. This is expected to be in [term doctools] format.
+
+[call [cmd ::page::pluginmgr::rlabel]]
+
+This command retrieves the human-readable name of the loaded reader
+plugin.
+
+[call [cmd ::page::pluginmgr::read] [arg read] [arg eof] [opt [arg complete]]]
+
+This command invokes the loaded reader plugin to process the input,
+and returns the results of the plugin as its own result. The input is
+accessible through the callback commands [arg read], and [arg eof]. The
+optional [arg done] can be used to intrecept when the plugin has
+completed its processing. All arguments are command prefixes.
+
+[para]
+
+The plugin will invoke the various callbacks in the following
+situations:
+
+[list_begin definitions]
+[call [arg read] [arg num]]
+is invoked whenever input to process is needed, with the number of
+characters/bytes it asks for. The result is expected to be the input
+the plugin is in need of.
+
+[call [arg eof]]
+is invoked by the plugin to check if the input has reached the of the
+stream. The result is expected to be a boolean flag, [const true] when
+the input has hit EOF, and [const false] otherwise.
+
+[call [arg done]]
+is invoked when the plugin has completed the processing of the input.
+
+[list_end]
+
+[call [cmd ::page::pluginmgr::writer] [arg name]]
+
+This command loads the named writer plugin and initializes it. The
+result of the command is a list of options the plugin understands.
+
+[para]
+
+Only a single reader plugin can be loaded. Loading another reader
+plugin causes the previously loaded reader plugin to be de-initialized
+and unloaded.
+
+[para]
+
+See section [sectref {WRITER PLUGIN API}] for the API expected of
+writer plugins.
+
+[call [cmd ::page::pluginmgr::wconfigure] [arg dict]]
+
+This commands configures the loaded writer plugin. The options and
+their values are provided as a Tcl dictionary. The result of the
+command is the empty string.
+
+[call [cmd ::page::pluginmgr::wtimeable]]
+
+This commands checks if the loaded writer plugin is able to measure
+execution times. The result of the command is a boolean flag. The
+result is [const true] if the plugin can be timed, and [const false]
+otherwise.
+
+[call [cmd ::page::pluginmgr::wtime]]
+
+This command activates the collection of timing statistics in the
+loaded writer plugin.
+
+[call [cmd ::page::pluginmgr::wgettime]]
+
+This command retrieves the collected timing statistics of the loaded
+writer plugin after it was executed.
+
+[call [cmd ::page::pluginmgr::whelp]]
+
+This command retrieves the help string of the loaded writer
+plugin. This is expected to be in [term doctools] format.
+
+[call [cmd ::page::pluginmgr::wlabel]]
+
+This command retrieves the human-readable name of the loaded writer
+plugin.
+
+[call [cmd ::page::pluginmgr::write] [arg chan] [arg data]]
+
+The loaded writer plugin is invoked to generate the output. It is
+given the [arg data] to generate the outpout from, and the Tcl handle
+[arg chan] of the channel to write the generated output to. The
+command returns th empty string as its result.
+
+[call [cmd ::page::pluginmgr::transform] [arg name]]
+
+This command loads the named transformation plugin and initializes
+it. The result of the command is a 2-element list containing the
+plugin id and a list of options the plugin understands, in this order.
+
+[para]
+
+Multiple transformations plugins can be loaded and are identified by
+handles.
+
+[para]
+
+See section [sectref {TRANSFORM PLUGIN API}] for the API expected of
+transformation plugins.
+
+[call [cmd ::page::pluginmgr::tconfigure] [arg id] [arg dict]]
+
+This commands configures the identified transformation plugin. The
+options and their values are provided as a Tcl dictionary. The result
+of the command is the empty string.
+
+[call [cmd ::page::pluginmgr::ttimeable] [arg id]]
+
+This commands checks if the identified transformation plugin is able
+to collect timing statistics. The result of the command is a boolean
+flag. The result is [const true] if the plugin can be timed, and
+[const false] otherwise.
+
+[call [cmd ::page::pluginmgr::ttime] [arg id]]
+
+This command activates the collection of timing statistics in the
+identified transformation plugin.
+
+[call [cmd ::page::pluginmgr::tgettime] [arg id]]
+
+This command retrieves the collected timing statistics of the
+identified transformation plugin after it was executed.
+
+[call [cmd ::page::pluginmgr::thelp] [arg id]]
+
+This command retrieves the help string of the identified
+transformation plugin. This is expected to be in [term doctools]
+format.
+
+[call [cmd ::page::pluginmgr::tlabel] [arg id]]
+
+This command retrieves the human-readable name of the identified
+transformation plugin.
+
+[call [cmd ::page::pluginmgr::transform_do] [arg id] [arg data]]
+
+The identified transformation plugin is invoked to process the
+specified [arg data]. The result of the plugin is returned as the
+result of the command.
+
+[list_end]
+
+[section {CONFIG PLUGIN API}]
+
+Configuration plugins are expected to provide a single command,
+described below.
+
+[para]
+
+[list_begin definitions]
+[call [cmd page_cdefinition]]
+
+This command of a configuration plugin is called by the plugin manager
+to execute it. Its result has to be a list of options and values to
+process.
+
+[list_end]
+[para]
+
+Configuration plugins do not expect the environment to provide any
+special commands.
+
+[para]
+
+It is expected that a configuration plugin [const FOO] is implemented
+by the package [package page::config::[const FOO]].
+
+[para]
+
+Configuration plugins are loaded, executed, and unloaded in one step,
+they are not kept in memory. The command for doing this is
+[cmd ::page::pluginmgr::configuration].
+
+[section {READER PLUGIN API}]
+
+Reader plugins are expected to provide the following commands,
+described below.
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd page_rfeature] [arg name]]
+
+This command takes a feature [arg name] and returns a boolean flag
+indicating whether the feature is supported by the plugin, or not.
+
+The result has to be [const true] if the feature is supported, and
+[const false] otherwise.
+
+[para]
+
+See section [sectref FEATURES] for the possible features the plugin
+manager will ask for.
+
+[call [cmd page_rtime]]
+
+This command is invoked to activate the collection of timing
+statistics.
+
+[call [cmd page_rgettime]]
+
+This command is invoked to retrieve the collected timing statistics.
+
+[call [cmd page_rlabel]]
+
+This command is invoked to retrieve a human-readable label for the
+plugin.
+
+[call [cmd page_rhelp]]
+
+This command is invoked to retrieve a help text for plugin. The text
+is expected to be in [term doctools] format.
+
+[call [cmd page_roptions]]
+
+This command is invoked to retrieve the options understood by the
+plugin.
+
+[call [cmd page_rconfigure] [arg option] [arg value]]
+
+This command is invoked to reconfigure the plugin, specifically the
+given [arg option] is set to the new [arg value].
+
+[call [cmd page_rrun]]
+
+This command is invoked to process the input stream per the current
+plugin configuration. The result of the command is the result of the
+processing.
+
+[list_end]
+[para]
+
+Reader plugins expect the environment to provide the following special
+commands.
+
+[list_begin definitions]
+
+[call [cmd page_read] [arg num]]
+
+This command is invoked to read [arg num] characters/bytes from the
+input. Its result has to be read characters/bytes.
+
+[call [cmd page_read_done]]
+
+This command is invoked to signal that the plugin has completed the
+processing of the input.
+
+[call [cmd page_eof]]
+
+This command is invoked to check if the input stream has reached its
+end. Its result has to be a boolean flag, [const true] when the input
+has reached the end, [const false] otherwise.
+
+[call [cmd page_info] [arg text] [opt "[arg from] [opt [arg to]]"]]
+
+Invoked to report some information to the user. May indicate a
+location or range in the input. Each piece of location data, if
+provided, is a 2-element list containing line and column numbers.
+
+[call [cmd page_warning] [arg text] [opt "[arg from] [opt [arg to]]"]]
+
+Invoked to report a warning to the user. May indicate a location or
+range in the input. Each piece of location data, if provided, is a
+2-element list containing line and column numbers.
+
+[call [cmd page_error] [arg text] [opt "[arg from] [opt [arg to]]"]]
+
+Invoked to report an error to the user. May indicate a location or
+range in the input. Each piece of location data, if provided, is a
+2-element list containing line and column numbers.
+
+[call [cmd page_log_info] [arg text]]
+
+Invoked to report some internal information.
+
+[call [cmd page_log_warning] [arg text]]
+
+Invoked to report an internal warning.
+
+[call [cmd page_log_error] [arg text]]
+
+Invoked to report an internal error.
+
+[list_end]
+[para]
+
+It is expected that a reader plugin [const FOO] is implemented
+by the package [package page::reader::[const FOO]].
+
+[para]
+
+Reader plugins are loaded by the command
+[cmd ::page::pluginmgr::reader]. At most one reader plugin can be kept
+in memory.
+
+[section {WRITER PLUGIN API}]
+
+Writer plugins are expected to provide the following commands,
+described below.
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd page_wfeature]]
+
+This command takes a feature [arg name] and returns a boolean flag
+indicating whether the feature is supported by the plugin, or not.
+
+The result has to be [const true] if the feature is supported, and
+[const false] otherwise.
+
+[para]
+
+See section [sectref FEATURES] for the possible features the plugin
+manager will ask for.
+
+[call [cmd page_wtime]]
+
+This command is invoked to activate the collection of timing
+statistics.
+
+[call [cmd page_wgettime]]
+
+This command is invoked to retrieve the collected timing statistics.
+
+[call [cmd page_wlabel]]
+
+This command is invoked to retrieve a human-readable label for the
+plugin.
+
+[call [cmd page_whelp]]
+
+This command is invoked to retrieve a help text for plugin. The text
+is expected to be in [term doctools] format.
+
+[call [cmd page_woptions]]
+
+This command is invoked to retrieve the options understood by the
+plugin.
+
+[call [cmd page_wconfigure] [arg option] [arg value]]
+
+This command is invoked to reconfigure the plugin, specifically the
+given [arg option] is set to the new [arg value].
+
+[call [cmd page_wrun] [arg chan] [arg data]]
+
+This command is invoked to process the specified [arg data] and write
+it to the output stream [arg chan]. The latter is a Tcl channel handle
+opened for writing. The result of the command is the empty string.
+
+[list_end]
+[para]
+
+Writer plugins expect the environment to provide the following special
+commands.
+
+[list_begin definitions]
+
+[call [cmd page_info] [arg text] [opt "[arg from] [opt [arg to]]"]]
+
+Invoked to report some information to the user. May indicate a
+location or range in the input. Each piece of location data, if
+provided, is a 2-element list containing line and column numbers.
+
+[call [cmd page_warning] [arg text] [opt "[arg from] [opt [arg to]]"]]
+
+Invoked to report a warning to the user. May indicate a location or
+range in the input. Each piece of location data, if provided, is a
+2-element list containing line and column numbers.
+
+[call [cmd page_error] [arg text] [opt "[arg from] [opt [arg to]]"]]
+
+Invoked to report an error to the user. May indicate a location or
+range in the input. Each piece of location data, if provided, is a
+2-element list containing line and column numbers.
+
+[call [cmd page_log_info] [arg text]]
+
+Invoked to report some internal information.
+
+[call [cmd page_log_warning] [arg text]]
+
+Invoked to report an internal warning.
+
+[call [cmd page_log_error] [arg text]]
+
+Invoked to report an internal error.
+
+[list_end]
+[para]
+
+It is expected that a writer plugin [const FOO] is implemented
+by the package [package page::writer::[const FOO]].
+
+[para]
+
+Writer plugins are loaded by the command
+[cmd ::page::pluginmgr::writer]. At most one writer plugin can be kept
+in memory.
+
+[section {TRANSFORM PLUGIN API}] page::transform::*
+
+Transformation plugins are expected to provide the following commands,
+described below.
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd page_tfeature]]
+
+This command takes a feature [arg name] and returns a boolean flag
+indicating whether the feature is supported by the plugin, or not.
+
+The result has to be [const true] if the feature is supported, and
+[const false] otherwise.
+
+[para]
+
+See section [sectref FEATURES] for the possible features the plugin
+manager will ask for.
+
+[call [cmd page_ttime]]
+
+This command is invoked to activate the collection of timing
+statistics.
+
+[call [cmd page_tgettime]]
+
+This command is invoked to retrieve the collected timing statistics.
+
+[call [cmd page_tlabel]]
+
+This command is invoked to retrieve a human-readable label for the
+plugin.
+
+[call [cmd page_thelp]]
+
+This command is invoked to retrieve a help text for plugin. The text
+is expected to be in [term doctools] format.
+
+[call [cmd page_toptions]]
+
+This command is invoked to retrieve the options understood by the
+plugin.
+
+[call [cmd page_tconfigure] [arg option] [arg value]]
+
+This command is invoked to reconfigure the plugin, specifically the
+given [arg option] is set to the new [arg value].
+
+[call [cmd page_trun] [arg chan] [arg data]]
+
+This command is invoked to process the specified [arg data] and write
+it to the output stream [arg chan]. The latter is a Tcl channel handle
+opened for writing. The result of the command is the empty string.
+
+[list_end]
+[para]
+
+Transformation plugins expect the environment to provide the following
+special commands.
+
+[list_begin definitions]
+
+[call [cmd page_info] [arg text] [opt "[arg from] [opt [arg to]]"]]
+
+Invoked to report some information to the user. May indicate a
+location or range in the input. Each piece of location data, if
+provided, is a 2-element list containing line and column numbers.
+
+[call [cmd page_warning] [arg text] [opt "[arg from] [opt [arg to]]"]]
+
+Invoked to report a warning to the user. May indicate a location or
+range in the input. Each piece of location data, if provided, is a
+2-element list containing line and column numbers.
+
+[call [cmd page_error] [arg text] [opt "[arg from] [opt [arg to]]"]]
+
+Invoked to report an error to the user. May indicate a location or
+range in the input. Each piece of location data, if provided, is a
+2-element list containing line and column numbers.
+
+[call [cmd page_log_info] [arg text]]
+
+Invoked to report some internal information.
+
+[call [cmd page_log_warning] [arg text]]
+
+Invoked to report an internal warning.
+
+[call [cmd page_log_error] [arg text]]
+
+Invoked to report an internal error.
+
+[list_end]
+[para]
+
+It is expected that a transformation plugin [const FOO] is implemented
+by the package [package page::transform::[const FOO]].
+
+[para]
+
+Transformation plugins are loaded by the command
+
+[cmd ::page::pluginmgr::transform]. More than one transformation
+plugin can be kept in memory.
+
+[section {PREDEFINED PLUGINS}]
+
+The following predefined plugins are known, i.e. provided by the page
+module.
+
+[list_begin definitions]
+
+[def Configuration]
+[list_begin definitions]
+[def peg]
+
+Returns a set of options to configure the [syscmd page] application
+for the processing of a PEG grammar and the generation of ME code. See
+the packages [package grammar_peg], [package grammar_me] and relations
+for more details.
+
+[list_end]
+
+[def Reader]
+[list_begin definitions]
+[def hb]
+Expects a so-called [term {half-baked PEG container}] as input and
+returns the equivalent abstract syntax tree. See the writer plugin
+[term hb] for the plugin generating this type of input.
+
+[def lemon]
+Expects a grammar specification as understood by Richar Hipp's LEMON
+parser generator and returns an abstract syntax tree for it.
+
+[def peg]
+Expects a grammar specification in the form of a parsing expression
+grammar (PEG) and returns an abstract syntax tree for it.
+
+[def ser]
+Expect the serialized form of a parsing expression grammar as
+generated by the package [package grammar::peg] as input, converts it
+into an equivalent abstract syntax tree and returns that.
+
+[def treeser]
+Expects the serialized form of a tree as generated by the package
+[package struct::tree] as input and returns it, after validation.
+
+[list_end]
+
+[def Writer]
+[list_begin definitions]
+[def hb]
+Expects an abstract syntax tree for a parsing expression grammar as
+input and writes it out in the form of a so-called
+[term {half-baked PEG container}].
+
+[def identity]
+Takes any input and writes it as is.
+
+[def mecpu]
+Expects symbolic assembler code for the MatchEngine CPU (See the
+package [package grammar::me::cpu] and relatives) and writes it out as
+Tcl code for a parser.
+
+[def me]
+Expects an abstract syntax tree for a parsing expression grammar as
+input and writes it out as Tcl code for the MatchEngine (See the
+package [package grammar::me] and relatives) which parses input in
+that grammar.
+
+[def null]
+Takes any input and writes nothing. The logical equivalent of
+/dev/null.
+
+[def peg]
+Expects an abstract syntax tree for a parsing expression grammar as
+input and writes it out in the form of a canonical PEG which can be
+read by the reader plugin [term peg].
+
+[def ser]
+Expects an abstract syntax tree for a parsing expression grammar as
+input and writes it out as a serialized PEG container which can be
+read by the reader plugin [term ser].
+
+[def tpc]
+Expects an abstract syntax tree for a parsing expression grammar as
+input and writes it out as Tcl code initializing a PEG container as
+provided by the package [package grammar::peg].
+
+[def tree]
+Takes any serialized tree (per package [package struct::tree]) as
+input and writes it out in a generic indented format.
+
+[list_end]
+
+[def Transformation]
+[list_begin definitions]
+
+[def mecpu]
+Takes an abstract syntax tree for a parsing expression grammer as
+input, generates symbolic assembler code for the MatchEngine CPU, and
+returns that as its result (See the package [package grammar::me::cpu]
+and relatives).
+
+[def reachable]
+Takes an abstract syntax tree for a parsing expression grammer as
+input, performs a reachability analysis, and returns the modified and
+annotated tree.
+
+[def realizable]
+Takes an abstract syntax tree for a parsing expression grammer as
+input, performs an analysis of realizability, and returns the modified
+and annotated tree.
+
+[list_end]
+[list_end]
+
+[comment {
+ Make it clear that all data between plugins is shuffled around
+ in serialized form, as objects cannot be transfered/accessed
+ across the interpreter boundaries (safety concerns).
+
+ Describe the commands expected by plugins to be available in
+ the environment.
+
+ Describe the predefined features.
+}]
+
+[section FEATURES]
+
+The plugin manager currently checks the plugins for only one feature,
+[const timeable]. A plugin supporting this feature is assumed to be
+able to collect timing statistics on request.
+
+[vset CATEGORY page]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/page/page_util_flow.man b/tcllib/modules/page/page_util_flow.man
new file mode 100644
index 0000000..d6535cb
--- /dev/null
+++ b/tcllib/modules/page/page_util_flow.man
@@ -0,0 +1,96 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin page_util_flow n 1.0]
+[keywords dataflow]
+[keywords {graph walking}]
+[keywords page]
+[keywords {parser generator}]
+[keywords {text processing}]
+[keywords {tree walking}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Parser generator tools}]
+[titledesc {page dataflow/treewalker utility}]
+[category {Page Parser Generator}]
+[require page::util::flow [opt 0.1]]
+[require snit]
+[description]
+[para]
+
+This package provides a single utility command for easy dataflow based
+manipulation of arbitrary data structures, especially abstract syntax
+trees.
+
+[section API]
+
+[list_begin definitions]
+[call [cmd ::page::util::flow] [arg start] [arg flowvar] [arg nodevar] [arg script]]
+
+This command contains the core logic to drive the walking of an
+arbitrary data structure which can partitioned into separate
+parts. Examples of such structures are trees and graphs.
+
+[para]
+
+The command makes no assumptions at all about the API of the structure
+to be walked, except that that its parts, here called [term nodes],
+are identified by strings. These strings are taken as is, from the
+arguments, and the body, and handed back to the body, without
+modification.
+
+[para]
+
+Access to the actual data structure, and all decisions regarding which
+nodes to visit in what order are delegated to the body of the loop,
+i.e. the [arg script].
+
+[para]
+
+The body is invoked first for the nodes in the start-set specified via
+[arg start]), and from then on for the nodes the body has requested to
+be visited. The command stops when the set of nodes to visit becomes
+empty. Note that a node can be visited more than once. The body has
+complete control about this.
+
+[para]
+
+The body is invoked in the context of the caller. The variable named
+by [arg nodevar] will be set to the current node, and the variable
+named by [arg flowvar] will be set to the command of the flow object
+through which the body can request the nodes to visit next. The API
+provided by this object is described in the next section,
+[sectref {FLOW API}].
+
+[para]
+
+Note that the command makes no promises regarding the order in which
+nodes are visited, excpt that the nodes requested to be visited by the
+current iteration will be visited afterward, in some order.
+
+[list_end]
+
+[section {FLOW API}]
+
+This section describes the API provided by the flow object made
+accessible to the body script of [cmd ::page::util::flow].
+
+[list_begin definitions]
+
+[call [arg flow] [method visit] [arg node]]
+
+Invoking this method requests that the node [arg n] is visited after
+the current iteration.
+
+[call [arg flow] [method visitl] [arg nodelist]]
+
+Invoking this method requests that all the nodes found in the list
+[arg nodelist] are visited after the current iteration.
+
+[call [arg flow] [method visita] [arg node]...]
+
+This is the variadic arguments form of the method [method visitl], see
+above.
+
+[list_end]
+
+[vset CATEGORY page]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/page/page_util_norm_lemon.man b/tcllib/modules/page/page_util_norm_lemon.man
new file mode 100644
index 0000000..5859575
--- /dev/null
+++ b/tcllib/modules/page/page_util_norm_lemon.man
@@ -0,0 +1,51 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin page_util_norm_lemon n 1.0]
+[keywords {graph walking}]
+[keywords lemon]
+[keywords normalization]
+[keywords page]
+[keywords {parser generator}]
+[keywords {text processing}]
+[keywords {tree walking}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Parser generator tools}]
+[titledesc {page AST normalization, LEMON}]
+[category {Page Parser Generator}]
+[require page::util::norm_lemon [opt 0.1]]
+[require snit]
+[description]
+[para]
+
+This package provides a single utility command which takes an AST for a
+lemon grammar and normalizes it in various ways. The result
+is called a [term {Normalized Lemon Grammar Tree}].
+
+[para]
+
+[emph Note] that this package can only be used from within a plugin
+managed by the package [package page::pluginmgr].
+
+[comment {
+ TODO: Document the structure of a LEMON AST,
+ and then of a Normalized LEMON Tree. Which
+ is not a true AST any longer.
+}]
+
+[section API]
+
+[list_begin definitions]
+[call [cmd ::page::util::norm::lemon] [arg tree]]
+
+This command assumes the [arg tree] object contains for a lemon
+grammar. It normalizes this tree in place. The result is called a
+[term {Normalized Lemon Grammar Tree}].
+
+[para]
+
+The exact operations performed are left undocumented for the moment.
+
+[list_end]
+
+[vset CATEGORY page]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/page/page_util_norm_peg.man b/tcllib/modules/page/page_util_norm_peg.man
new file mode 100644
index 0000000..d5e98c3
--- /dev/null
+++ b/tcllib/modules/page/page_util_norm_peg.man
@@ -0,0 +1,105 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin page_util_norm_peg n 1.0]
+[keywords {graph walking}]
+[keywords normalization]
+[keywords page]
+[keywords {parser generator}]
+[keywords PEG]
+[keywords {text processing}]
+[keywords {tree walking}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Parser generator tools}]
+[titledesc {page AST normalization, PEG}]
+[category {Page Parser Generator}]
+[require page::util::norm_peg [opt 0.1]]
+[require snit]
+[description]
+[para]
+
+This package provides a single utility command which takes an AST for a
+parsing expression grammar and normalizes it in various ways. The result
+is called a [term {Normalized PE Grammar Tree}].
+
+[para]
+
+[emph Note] that this package can only be used from within a plugin
+managed by the package [package page::pluginmgr].
+
+[comment {
+ TODO: Document the structure of a PEG AST,
+ and then of a Normalized PEG Tree. Which
+ is not a true AST any longer.
+}]
+
+[section API]
+
+[list_begin definitions]
+[call [cmd ::page::util::norm::peg] [arg tree]]
+
+This command assumes the [arg tree] object contains for a
+parsing expression grammar. It normalizes this tree in place.
+The result is called a [term {Normalized PE Grammar Tree}].
+
+[para]
+
+The following operations are performd
+
+[list_begin enum]
+[enum]
+The data for all terminals is stored in their grandparental
+nodes. The terminal nodes and their parents are removed. Type
+information is dropped.
+
+[enum]
+All nodes which have exactly one child are irrelevant and are
+removed, with the exception of the root node. The immediate
+child of the root is irrelevant as well, and removed as well.
+
+[enum]
+The name of the grammar is moved from the tree node it is stored
+in to an attribute of the root node, and the tree node removed.
+[para]
+The node keeping the start expression separate is removed as
+irrelevant and the root node of the start expression tagged with
+a marker attribute, and its handle saved in an attribute of the
+root node for quick access.
+
+[enum]
+Nonterminal hint information is moved from nodes into attributes,
+and the now irrelevant nodes are deleted.
+[para]
+[emph Note:] This transformation is dependent on the removal of all
+nodes with exactly one child, as it removes the all 'Attribute'
+nodes already. Otherwise this transformation would have to put
+the information into the grandparental node.
+[para]
+The default mode given to the nonterminals is [const value].
+[para]
+Like with the global metadata definition specific information
+is moved out out of nodes into attributes, the now irrelevant
+nodes are deleted, and the root nodes of all definitions are
+tagged with marker attributes. This provides us with a mapping
+from nonterminal names to their defining nodes as well, which
+is saved in an attribute of the root node for quick reference.
+[para]
+At last the range in the input covered by a definition is
+computed. The left extent comes from the terminal for the
+nonterminal symbol it defines. The right extent comes from
+the rightmost child under the definition. While this not an
+expression tree yet the location data is sound already.
+
+[enum]
+The remaining nodes under all definitions are transformed
+into proper expression trees. First character ranges, followed
+by unary operations, characters, and nonterminals. At last the
+tree is flattened by the removal of superfluous inner nodes.
+[para]
+The order matters, to shed as much nodes as possible early, and
+to avoid unnecessary work later.
+
+[list_end]
+[list_end]
+
+[vset CATEGORY page]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/page/page_util_peg.man b/tcllib/modules/page/page_util_peg.man
new file mode 100644
index 0000000..5e75be5
--- /dev/null
+++ b/tcllib/modules/page/page_util_peg.man
@@ -0,0 +1,108 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin page_util_peg n 1.0]
+[keywords page]
+[keywords {parser generator}]
+[keywords {parsing expression grammar}]
+[keywords PEG]
+[keywords {text processing}]
+[keywords transformation]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Parser generator tools}]
+[titledesc {page PEG transformation utilities}]
+[category {Page Parser Generator}]
+[require page::util::peg [opt 0.1]]
+[require snit]
+[description]
+[para]
+
+This package provides a few common operations to PEG transformations.
+They assume a [term {Normalized PE Grammar Tree}] as input, see the
+package [package page::util::norm::peg], possibly augmented with
+attributes coming from transformations not in conflict with the base
+definition.
+
+[para]
+
+[section API]
+
+[list_begin definitions]
+[call [cmd ::page::util::peg::symbolNodeOf] [arg tree] [arg node]]
+
+Given an arbitrary expression [arg node] in the AST [arg tree] it
+determines the node (itself or an ancestor) containing the name of the
+nonterminal symbol the node belongs to, and returns its id. The result
+is either the root of the tree (for the start expression), or a
+definition node.
+
+[call [cmd ::page::util::peg::symbolOf] [arg tree] [arg node]]
+
+As [cmd ::page::util::peg::symbolNodeOf], but returns the symbol name
+instead of the node.
+
+[call [cmd ::page::util::peg::updateUndefinedDueRemoval] [arg tree]]
+
+The removal of nodes in the AST [arg tree] can cause symbols to lose
+one or more users.
+
+[example {
+ A used by B and C,
+ B is reachable,
+ C is not,
+
+ so A now loses the node in the expression for C calling it,
+ or rather, not calling it anymore.
+}]
+
+This command updates the cross-references and which nonterminals are
+now undefined.
+
+[call [cmd ::page::util::peg::flatten] [arg treequery] [arg tree]]
+
+This commands flattens nested sequence and choice operators in the AST
+[arg tree], re-using the [package treeql] object [arg treequery] to
+run the query determining which nodes to cut.
+
+[call [cmd ::page::util::peg::getWarnings] [arg tree]]
+
+This command looks at the attributes of the AST [arg tree] for
+problems with the grammar and issues warnings. They do not prevent us
+from writing the grammar, but still represent problems with it the
+user should be made aware of.
+
+[para]
+
+The result of the command is a dictionary mapping nonterminal names to
+their associated warnings.
+
+[call [cmd ::page::util::peg::printWarnings] [arg msg]]
+
+The argument of the command is a dictionary mapping nonterminal names
+to their associated warnings, as generated by, for example, the
+command [cmd ::page::util::peg::getWarnings].
+
+[para]
+
+The warnings contained therein are formatted and then printed via the
+log command [cmd page_info]. This means that this command can be used
+only from within a plugin managed by the package
+[package page::pluginmgr].
+
+[call [cmd ::page::util::peg::peOf] [arg tree] [arg eroot]]
+
+This command converts the parsing expression starting at the node
+[arg eroot] in the AST [arg tree] into a nested list. The exact syntax
+of this list specified by the package [package grammar::peg].
+
+[call [cmd ::page::util::peg::printTclExpr] [arg pe]]
+
+This command converts the parsing expression contained in the nested
+list [arg pe] into a Tcl string which can be placed into a Tcl script.
+
+See the package [package grammar::peg] for the exact syntax of
+[arg pe].
+
+[list_end]
+
+[vset CATEGORY page]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/page/page_util_quote.man b/tcllib/modules/page/page_util_quote.man
new file mode 100644
index 0000000..c1a32f3
--- /dev/null
+++ b/tcllib/modules/page/page_util_quote.man
@@ -0,0 +1,62 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin page_util_quote n 1.0]
+[keywords page]
+[keywords {parser generator}]
+[keywords quoting]
+[keywords {text processing}]
+[copyright {2007 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Parser generator tools}]
+[titledesc {page character quoting utilities}]
+[category {Page Parser Generator}]
+[require page::util::quote [opt 0.1]]
+[require snit]
+[description]
+[para]
+
+This package provides a few utility commands to convert characters
+into various forms.
+
+[section API]
+
+[list_begin definitions]
+[call [cmd ::page::util::quote::unquote] [arg char]]
+
+A character, as stored in an abstract syntax tree by a PEG processor
+(See the packages [package grammar::peg::interpreter],
+[package grammar::me], and their relations), i.e. in some quoted form,
+is converted into the equivalent Tcl character. The character is returned
+as the result of the command.
+
+[call [cmd ::page::util::quote::quote'tcl] [arg char]]
+
+This command takes a Tcl character (internal representation) and
+converts it into a string which is accepted by the Tcl parser, will
+regenerate the character in question and is 7bit ASCII. The string is
+returned as the result of this command.
+
+[call [cmd ::page::util::quote::quote'tclstr] [arg char]]
+
+This command takes a Tcl character (internal representation) and
+converts it into a string which is accepted by the Tcl parser and will
+generate a human readable representation of the character in question.
+The string is returned as the result of this command.
+
+[para]
+
+The string does not use any unprintable characters. It may use
+backslash-quoting. High UTF characters are quoted to avoid problems
+with the still prevalent ascii terminals. It is assumed that the
+string will be used in a double-quoted environment.
+
+[call [cmd ::page::util::quote::quote'tclcom] [arg char]]
+
+This command takes a Tcl character (internal representation) and
+converts it into a string which is accepted by the Tcl parser when
+used within a Tcl comment. The string is returned as the result of
+this command.
+
+[list_end]
+
+[vset CATEGORY page]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/page/parse_lemon.tcl b/tcllib/modules/page/parse_lemon.tcl
new file mode 100644
index 0000000..e3b2447
--- /dev/null
+++ b/tcllib/modules/page/parse_lemon.tcl
@@ -0,0 +1,7420 @@
+# -*- tcl -*-
+## Parsing Expression Grammar 'page::parse::lemon'.
+## RD parser by the PG backend 'MEwriter'.
+
+# ### ### ### ######### ######### #########
+## Package description
+
+# The commands provided here match an input provided through a buffer
+# command to the PE grammar 'page::parse::lemon'. The parser is based on the package
+# 'grammar::mengine' (recursive-descent, packrat, pulling chars,
+# pushing the generated AST).
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require grammar::me::tcl
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+namespace eval ::page::parse::lemon {
+ # Import the virtual machine for matching.
+
+ namespace import ::grammar::me::tcl::*
+ upvar #0 ::grammar::me::tcl::ok ok
+}
+
+# ### ### ### ######### ######### #########
+## API Implementation.
+
+proc ::page::parse::lemon::parse {nxcmd emvar astvar} {
+ variable ok
+ variable se
+
+ upvar 1 $emvar emsg $astvar ast
+
+ init $nxcmd
+
+ matchSymbol_LemonGrammar ; # (n LemonGrammar)
+
+ isv_nonterminal_reduce ALL -1
+ set ast [sv]
+ if {!$ok} {
+ foreach {l m} [ier_get] break
+ lappend l [lc $l]
+ set mx {}
+ foreach x $m {lappend mx "Expected $x"}
+ set emsg [list $l $mx]
+ }
+
+ return $ok
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper methods
+
+# Grammar 'page::parse::lemon'
+#
+# ASSIGN = (x (t :)
+# (t :)
+# (t =)
+# (n SPACE))
+#
+# C_COMMENT = (x (n CCOM_OPEN)
+# (* (x (! (n CCOM_CLOSE))
+# (dot)))
+# (n CCOM_CLOSE))
+#
+# CCOM_CLOSE = (x (t *)
+# (t /))
+#
+# CCOM_OPEN = (x (t /)
+# (t *))
+#
+# Code = (x (n DCODE)
+# (n Codeblock))
+#
+# Codeblock = (x (n LBRACE)
+# (* (/ (n Codeblock)
+# (n C_COMMENT)
+# (n Cplusplus_COMMENT)
+# (x (! (n RBRACE))
+# (dot))))
+# (n RBRACE))
+#
+# Cplusplus_COMMENT = (x (t /)
+# (t /)
+# (* (x (! (n EOL))
+# (dot)))
+# (n EOL))
+#
+# DCODE = (x (t c)
+# (t o)
+# (t d)
+# (t e)
+# (n SPACE))
+#
+# DDEFDEST = (x (t d)
+# (t e)
+# (t f)
+# (t a)
+# (t u)
+# (t l)
+# (t t)
+# (t _)
+# (t d)
+# (t e)
+# (t s)
+# (t t)
+# (t r)
+# (t u)
+# (t c)
+# (t t)
+# (t o)
+# (t r)
+# (n SPACE))
+#
+# DDEFTYPE = (x (t d)
+# (t e)
+# (t f)
+# (t a)
+# (t u)
+# (t l)
+# (t t)
+# (t _)
+# (t t)
+# (t y)
+# (t p)
+# (t e)
+# (n SPACE))
+#
+# DDEST = (x (t d)
+# (t e)
+# (t s)
+# (t t)
+# (t r)
+# (t u)
+# (t c)
+# (t t)
+# (t o)
+# (t r)
+# (n SPACE))
+#
+# DefaultDestructor = (x (n DDEFDEST)
+# (n Identifier)
+# (n Codeblock))
+#
+# DefaultType = (x (n DDEFTYPE)
+# (n Codeblock))
+#
+# Definition = (* (x (n Identifier)
+# (? (n Label))))
+#
+# DENDIF = (x (t %)
+# (t e)
+# (t n)
+# (t d)
+# (t i)
+# (t f)
+# (n SPACE))
+#
+# Destructor = (x (n DDEST)
+# (n Identifier)
+# (n Codeblock))
+#
+# DEXTRA = (x (t e)
+# (t x)
+# (t t)
+# (t r)
+# (t a)
+# (t _)
+# (t a)
+# (t r)
+# (t g)
+# (t u)
+# (t m)
+# (t e)
+# (t n)
+# (t t)
+# (n SPACE))
+#
+# DFALLBK = (x (t f)
+# (t a)
+# (t l)
+# (t l)
+# (t b)
+# (t a)
+# (t c)
+# (t k)
+# (n SPACE))
+#
+# DIFDEF = (x (t %)
+# (t i)
+# (t f)
+# (t d)
+# (t e)
+# (t f)
+# (n SPACE))
+#
+# DIFNDEF = (x (t %)
+# (t i)
+# (t f)
+# (t n)
+# (t d)
+# (t e)
+# (t f)
+# (n SPACE))
+#
+# DINCL = (x (t i)
+# (t n)
+# (t c)
+# (t l)
+# (t u)
+# (t d)
+# (t e)
+# (n SPACE))
+#
+# DINTRO = (t %)
+#
+# Directive = (x (n DINTRO)
+# (/ (n Code)
+# (n DefaultDestructor)
+# (n DefaultType)
+# (n Destructor)
+# (n ExtraArgument)
+# (n Include)
+# (n Left)
+# (n Name)
+# (n Nonassoc)
+# (n ParseAccept)
+# (n ParseFailure)
+# (n Right)
+# (n StackOverflow)
+# (n Stacksize)
+# (n StartSymbol)
+# (n SyntaxError)
+# (n TokenDestructor)
+# (n TokenPrefix)
+# (n TokenType)
+# (n Type)
+# (n Fallback)))
+#
+# DLEFT = (x (t l)
+# (t e)
+# (t f)
+# (t t)
+# (n SPACE))
+#
+# DNAME = (x (t n)
+# (t a)
+# (t m)
+# (t e)
+# (n SPACE))
+#
+# DNON = (x (t n)
+# (t o)
+# (t n)
+# (t a)
+# (t s)
+# (t s)
+# (t o)
+# (t c)
+# (n SPACE))
+#
+# DOT = (x (t .)
+# (n SPACE))
+#
+# DPACC = (x (t p)
+# (t a)
+# (t r)
+# (t s)
+# (t e)
+# (t _)
+# (t a)
+# (t c)
+# (t c)
+# (t e)
+# (t p)
+# (t t)
+# (n SPACE))
+#
+# DPFAIL = (x (t p)
+# (t a)
+# (t r)
+# (t s)
+# (t e)
+# (t _)
+# (t f)
+# (t a)
+# (t i)
+# (t l)
+# (t u)
+# (t r)
+# (t e)
+# (n SPACE))
+#
+# DRIGHT = (x (t r)
+# (t i)
+# (t g)
+# (t h)
+# (t t)
+# (n SPACE))
+#
+# DSTART = (x (t s)
+# (t t)
+# (t a)
+# (t r)
+# (t t)
+# (t _)
+# (t s)
+# (t y)
+# (t m)
+# (t b)
+# (t o)
+# (t l)
+# (n SPACE))
+#
+# DSTKOVER = (x (t s)
+# (t t)
+# (t a)
+# (t c)
+# (t k)
+# (t _)
+# (t o)
+# (t v)
+# (t e)
+# (t r)
+# (t f)
+# (t l)
+# (t o)
+# (t w)
+# (n SPACE))
+#
+# DSTKSZ = (x (t s)
+# (t t)
+# (t a)
+# (t c)
+# (t k)
+# (t _)
+# (t s)
+# (t i)
+# (t z)
+# (t e)
+# (n SPACE))
+#
+# DSYNERR = (x (t s)
+# (t y)
+# (t n)
+# (t t)
+# (t a)
+# (t x)
+# (t _)
+# (t e)
+# (t r)
+# (t r)
+# (t o)
+# (t r)
+# (n SPACE))
+#
+# DTOKDEST = (x (t t)
+# (t o)
+# (t k)
+# (t e)
+# (t n)
+# (t _)
+# (t d)
+# (t e)
+# (t s)
+# (t t)
+# (t r)
+# (t u)
+# (t c)
+# (t t)
+# (t o)
+# (t r)
+# (n SPACE))
+#
+# DTOKPFX = (x (t t)
+# (t o)
+# (t k)
+# (t e)
+# (t n)
+# (t _)
+# (t p)
+# (t r)
+# (t e)
+# (t f)
+# (t i)
+# (t x)
+# (n SPACE))
+#
+# DTOKTYPE = (x (t t)
+# (t o)
+# (t k)
+# (t e)
+# (t n)
+# (t _)
+# (t t)
+# (t y)
+# (t p)
+# (t e)
+# (n SPACE))
+#
+# DTYPE = (x (t t)
+# (t y)
+# (t p)
+# (t e)
+# (n SPACE))
+#
+# Endif = (n DENDIF)
+#
+# EOF = (! (dot))
+#
+# EOL = (/ (x (t \r)
+# (t \n))
+# (t \r)
+# (t \n))
+#
+# ExtraArgument = (x (n DEXTRA)
+# (n Codeblock))
+#
+# Fallback = (x (n DFALLBK)
+# (+ (n Identifier))
+# (n DOT))
+#
+# Ident = (x (/ (alpha)
+# (t _))
+# (* (/ (alnum)
+# (t _))))
+#
+# Identifier = (x (n Ident)
+# (n SPACE))
+#
+# Ifdef = (x (n DIFDEF)
+# (n Identifier))
+#
+# Ifndef = (x (n DIFNDEF)
+# (n Identifier))
+#
+# Include = (x (n DINCL)
+# (n Codeblock))
+#
+# Label = (x (n LPAREN)
+# (n Identifier)
+# (n RPAREN))
+#
+# LBRACE = (t \{)
+#
+# LBRACKET = (x (t [)
+# (n SPACE))
+#
+# Left = (x (n DLEFT)
+# (+ (n Identifier))
+# (n DOT))
+#
+# LemonGrammar = (x (n SPACE)
+# (+ (n Statement))
+# (n EOF))
+#
+# LPAREN = (x (t \()
+# (n SPACE))
+#
+# Name = (x (n DNAME)
+# (n Identifier))
+#
+# NatNum = (+ (.. 0 9))
+#
+# NaturalNumber = (x (n NatNum)
+# (n SPACE))
+#
+# Nonassoc = (x (n DNON)
+# (+ (n Identifier))
+# (n DOT))
+#
+# ParseAccept = (x (n DPACC)
+# (n Codeblock))
+#
+# ParseFailure = (x (n DPFAIL)
+# (n Codeblock))
+#
+# Precedence = (x (n LBRACKET)
+# (n Identifier)
+# (n RBRACKET))
+#
+# RBRACE = (t \})
+#
+# RBRACKET = (x (t ])
+# (n SPACE))
+#
+# Right = (x (n DRIGHT)
+# (+ (n Identifier))
+# (n DOT))
+#
+# RPAREN = (x (t \))
+# (n SPACE))
+#
+# Rule = (x (n Identifier)
+# (? (n Label))
+# (n ASSIGN)
+# (n Definition)
+# (n DOT)
+# (? (n Precedence))
+# (? (n Codeblock)))
+#
+# SPACE = (* (/ (t <blank>)
+# (t \t)
+# (t \n)
+# (t \r)
+# (n C_COMMENT)
+# (n Cplusplus_COMMENT)
+# (n Ifndef)
+# (n Ifdef)
+# (n Endif)))
+#
+# StackOverflow = (x (n DSTKOVER)
+# (n Codeblock))
+#
+# Stacksize = (x (n DSTKSZ)
+# (n NaturalNumber))
+#
+# StartSymbol = (x (n DSTART)
+# (n Identifier))
+#
+# Statement = (x (/ (n Directive)
+# (n Rule))
+# (n SPACE))
+#
+# SyntaxError = (x (n DSYNERR)
+# (n Codeblock))
+#
+# TokenDestructor = (x (n DTOKDEST)
+# (n Identifier)
+# (n Codeblock))
+#
+# TokenPrefix = (x (n DTOKPFX)
+# (n Identifier))
+#
+# TokenType = (x (n DTOKTYPE)
+# (n Codeblock))
+#
+# Type = (x (n DTYPE)
+# (n Identifier)
+# (n Codeblock))
+#
+
+proc ::page::parse::lemon::matchSymbol_ASSIGN {} {
+ # ASSIGN = (x (t :)
+ # (t :)
+ # (t =)
+ # (n SPACE))
+
+ if {[inc_restore ASSIGN]} return
+
+ set pos [icl_get]
+
+ eseq53 ; # (x (t :)
+ # (t :)
+ # (t =)
+ # (n SPACE))
+
+ isv_clear
+ inc_save ASSIGN $pos
+ ier_nonterminal ASSIGN $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq53 {} {
+
+ # (x (t :)
+ # (t :)
+ # (t =)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance :
+ if {$ok} {ict_match_token :}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance :
+ if {$ok} {ict_match_token :}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance =
+ if {$ok} {ict_match_token =}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_C_COMMENT {} {
+ # C_COMMENT = (x (n CCOM_OPEN)
+ # (* (x (! (n CCOM_CLOSE))
+ # (dot)))
+ # (n CCOM_CLOSE))
+
+ if {[inc_restore C_COMMENT]} return
+
+ set pos [icl_get]
+
+ eseq90 ; # (x (n CCOM_OPEN)
+ # (* (x (! (n CCOM_CLOSE))
+ # (dot)))
+ # (n CCOM_CLOSE))
+
+ isv_clear
+ inc_save C_COMMENT $pos
+ ier_nonterminal C_COMMENT $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq90 {} {
+
+ # (x (n CCOM_OPEN)
+ # (* (x (! (n CCOM_CLOSE))
+ # (dot)))
+ # (n CCOM_CLOSE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_CCOM_OPEN ; # (n CCOM_OPEN)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ekleene89 ; # (* (x (! (n CCOM_CLOSE))
+ # (dot)))
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_CCOM_CLOSE ; # (n CCOM_CLOSE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::ekleene89 {} {
+
+ # (* (x (! (n CCOM_CLOSE))
+ # (dot)))
+
+ variable ok
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ eseq88 ; # (x (! (n CCOM_CLOSE))
+ # (dot))
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::eseq88 {} {
+
+ # (x (! (n CCOM_CLOSE))
+ # (dot))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebang87
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "any character"
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::ebang87 {} {
+ set pos [icl_get]
+
+ matchSymbol_CCOM_CLOSE ; # (n CCOM_CLOSE)
+
+ icl_rewind $pos
+ iok_negate
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_CCOM_CLOSE {} {
+ # CCOM_CLOSE = (x (t *)
+ # (t /))
+
+ if {[inc_restore CCOM_CLOSE]} return
+
+ set pos [icl_get]
+
+ eseq92 ; # (x (t *)
+ # (t /))
+
+ isv_clear
+ inc_save CCOM_CLOSE $pos
+ ier_nonterminal CCOM_CLOSE $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq92 {} {
+
+ # (x (t *)
+ # (t /))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance *
+ if {$ok} {ict_match_token *}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance /
+ if {$ok} {ict_match_token /}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_CCOM_OPEN {} {
+ # CCOM_OPEN = (x (t /)
+ # (t *))
+
+ if {[inc_restore CCOM_OPEN]} return
+
+ set pos [icl_get]
+
+ eseq91 ; # (x (t /)
+ # (t *))
+
+ isv_clear
+ inc_save CCOM_OPEN $pos
+ ier_nonterminal CCOM_OPEN $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq91 {} {
+
+ # (x (t /)
+ # (t *))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance /
+ if {$ok} {ict_match_token /}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance *
+ if {$ok} {ict_match_token *}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Code {} {
+ # Code = (x (n DCODE)
+ # (n Codeblock))
+
+ variable ok
+ if {[inc_restore Code]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq16 ; # (x (n DCODE)
+ # (n Codeblock))
+
+ isv_nonterminal_reduce Code $pos $mrk
+ inc_save Code $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Code $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq16 {} {
+
+ # (x (n DCODE)
+ # (n Codeblock))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DCODE ; # (n DCODE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Codeblock ; # (n Codeblock)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Codeblock {} {
+ # Codeblock = (x (n LBRACE)
+ # (* (/ (n Codeblock)
+ # (n C_COMMENT)
+ # (n Cplusplus_COMMENT)
+ # (x (! (n RBRACE))
+ # (dot))))
+ # (n RBRACE))
+
+ variable ok
+ if {[inc_restore Codeblock]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq45 ; # (x (n LBRACE)
+ # (* (/ (n Codeblock)
+ # (n C_COMMENT)
+ # (n Cplusplus_COMMENT)
+ # (x (! (n RBRACE))
+ # (dot))))
+ # (n RBRACE))
+
+ isv_nonterminal_range Codeblock $pos
+ inc_save Codeblock $pos
+ if {$ok} ias_push
+ ier_nonterminal Codeblock $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq45 {} {
+
+ # (x (n LBRACE)
+ # (* (/ (n Codeblock)
+ # (n C_COMMENT)
+ # (n Cplusplus_COMMENT)
+ # (x (! (n RBRACE))
+ # (dot))))
+ # (n RBRACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_LBRACE ; # (n LBRACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ekleene44 ; # (* (/ (n Codeblock)
+ # (n C_COMMENT)
+ # (n Cplusplus_COMMENT)
+ # (x (! (n RBRACE))
+ # (dot))))
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_RBRACE ; # (n RBRACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::ekleene44 {} {
+
+ # (* (/ (n Codeblock)
+ # (n C_COMMENT)
+ # (n Cplusplus_COMMENT)
+ # (x (! (n RBRACE))
+ # (dot))))
+
+ variable ok
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebra43 ; # (/ (n Codeblock)
+ # (n C_COMMENT)
+ # (n Cplusplus_COMMENT)
+ # (x (! (n RBRACE))
+ # (dot)))
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::ebra43 {} {
+
+ # (/ (n Codeblock)
+ # (n C_COMMENT)
+ # (n Cplusplus_COMMENT)
+ # (x (! (n RBRACE))
+ # (dot)))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ set pCodeblock [ias_mark]
+ matchSymbol_Codeblock
+ ias_pop2mark $pCodeblock ; # (n Codeblock)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ matchSymbol_C_COMMENT ; # (n C_COMMENT)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ matchSymbol_Cplusplus_COMMENT ; # (n Cplusplus_COMMENT)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ eseq42 ; # (x (! (n RBRACE))
+ # (dot))
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::lemon::eseq42 {} {
+
+ # (x (! (n RBRACE))
+ # (dot))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebang41
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "any character"
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::ebang41 {} {
+ set pos [icl_get]
+
+ matchSymbol_RBRACE ; # (n RBRACE)
+
+ icl_rewind $pos
+ iok_negate
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Cplusplus_COMMENT {} {
+ # Cplusplus_COMMENT = (x (t /)
+ # (t /)
+ # (* (x (! (n EOL))
+ # (dot)))
+ # (n EOL))
+
+ if {[inc_restore Cplusplus_COMMENT]} return
+
+ set pos [icl_get]
+
+ eseq96 ; # (x (t /)
+ # (t /)
+ # (* (x (! (n EOL))
+ # (dot)))
+ # (n EOL))
+
+ isv_clear
+ inc_save Cplusplus_COMMENT $pos
+ ier_nonterminal Cplusplus_COMMENT $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq96 {} {
+
+ # (x (t /)
+ # (t /)
+ # (* (x (! (n EOL))
+ # (dot)))
+ # (n EOL))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance /
+ if {$ok} {ict_match_token /}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance /
+ if {$ok} {ict_match_token /}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ekleene95 ; # (* (x (! (n EOL))
+ # (dot)))
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_EOL ; # (n EOL)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::ekleene95 {} {
+
+ # (* (x (! (n EOL))
+ # (dot)))
+
+ variable ok
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ eseq94 ; # (x (! (n EOL))
+ # (dot))
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::eseq94 {} {
+
+ # (x (! (n EOL))
+ # (dot))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebang93
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "any character"
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::ebang93 {} {
+ set pos [icl_get]
+
+ matchSymbol_EOL ; # (n EOL)
+
+ icl_rewind $pos
+ iok_negate
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DCODE {} {
+ # DCODE = (x (t c)
+ # (t o)
+ # (t d)
+ # (t e)
+ # (n SPACE))
+
+ if {[inc_restore DCODE]} return
+
+ set pos [icl_get]
+
+ eseq59 ; # (x (t c)
+ # (t o)
+ # (t d)
+ # (t e)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DCODE $pos
+ ier_nonterminal DCODE $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq59 {} {
+
+ # (x (t c)
+ # (t o)
+ # (t d)
+ # (t e)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance c
+ if {$ok} {ict_match_token c}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance o
+ if {$ok} {ict_match_token o}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance d
+ if {$ok} {ict_match_token d}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DDEFDEST {} {
+ # DDEFDEST = (x (t d)
+ # (t e)
+ # (t f)
+ # (t a)
+ # (t u)
+ # (t l)
+ # (t t)
+ # (t _)
+ # (t d)
+ # (t e)
+ # (t s)
+ # (t t)
+ # (t r)
+ # (t u)
+ # (t c)
+ # (t t)
+ # (t o)
+ # (t r)
+ # (n SPACE))
+
+ if {[inc_restore DDEFDEST]} return
+
+ set pos [icl_get]
+
+ eseq60 ; # (x (t d)
+ # (t e)
+ # (t f)
+ # (t a)
+ # (t u)
+ # (t l)
+ # (t t)
+ # (t _)
+ # (t d)
+ # (t e)
+ # (t s)
+ # (t t)
+ # (t r)
+ # (t u)
+ # (t c)
+ # (t t)
+ # (t o)
+ # (t r)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DDEFDEST $pos
+ ier_nonterminal DDEFDEST $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq60 {} {
+
+ # (x (t d)
+ # (t e)
+ # (t f)
+ # (t a)
+ # (t u)
+ # (t l)
+ # (t t)
+ # (t _)
+ # (t d)
+ # (t e)
+ # (t s)
+ # (t t)
+ # (t r)
+ # (t u)
+ # (t c)
+ # (t t)
+ # (t o)
+ # (t r)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance d
+ if {$ok} {ict_match_token d}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance f
+ if {$ok} {ict_match_token f}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance u
+ if {$ok} {ict_match_token u}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance l
+ if {$ok} {ict_match_token l}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance _
+ if {$ok} {ict_match_token _}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance d
+ if {$ok} {ict_match_token d}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance s
+ if {$ok} {ict_match_token s}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance u
+ if {$ok} {ict_match_token u}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance c
+ if {$ok} {ict_match_token c}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance o
+ if {$ok} {ict_match_token o}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DDEFTYPE {} {
+ # DDEFTYPE = (x (t d)
+ # (t e)
+ # (t f)
+ # (t a)
+ # (t u)
+ # (t l)
+ # (t t)
+ # (t _)
+ # (t t)
+ # (t y)
+ # (t p)
+ # (t e)
+ # (n SPACE))
+
+ if {[inc_restore DDEFTYPE]} return
+
+ set pos [icl_get]
+
+ eseq61 ; # (x (t d)
+ # (t e)
+ # (t f)
+ # (t a)
+ # (t u)
+ # (t l)
+ # (t t)
+ # (t _)
+ # (t t)
+ # (t y)
+ # (t p)
+ # (t e)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DDEFTYPE $pos
+ ier_nonterminal DDEFTYPE $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq61 {} {
+
+ # (x (t d)
+ # (t e)
+ # (t f)
+ # (t a)
+ # (t u)
+ # (t l)
+ # (t t)
+ # (t _)
+ # (t t)
+ # (t y)
+ # (t p)
+ # (t e)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance d
+ if {$ok} {ict_match_token d}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance f
+ if {$ok} {ict_match_token f}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance u
+ if {$ok} {ict_match_token u}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance l
+ if {$ok} {ict_match_token l}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance _
+ if {$ok} {ict_match_token _}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance y
+ if {$ok} {ict_match_token y}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance p
+ if {$ok} {ict_match_token p}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DDEST {} {
+ # DDEST = (x (t d)
+ # (t e)
+ # (t s)
+ # (t t)
+ # (t r)
+ # (t u)
+ # (t c)
+ # (t t)
+ # (t o)
+ # (t r)
+ # (n SPACE))
+
+ if {[inc_restore DDEST]} return
+
+ set pos [icl_get]
+
+ eseq62 ; # (x (t d)
+ # (t e)
+ # (t s)
+ # (t t)
+ # (t r)
+ # (t u)
+ # (t c)
+ # (t t)
+ # (t o)
+ # (t r)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DDEST $pos
+ ier_nonterminal DDEST $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq62 {} {
+
+ # (x (t d)
+ # (t e)
+ # (t s)
+ # (t t)
+ # (t r)
+ # (t u)
+ # (t c)
+ # (t t)
+ # (t o)
+ # (t r)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance d
+ if {$ok} {ict_match_token d}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance s
+ if {$ok} {ict_match_token s}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance u
+ if {$ok} {ict_match_token u}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance c
+ if {$ok} {ict_match_token c}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance o
+ if {$ok} {ict_match_token o}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DefaultDestructor {} {
+ # DefaultDestructor = (x (n DDEFDEST)
+ # (n Identifier)
+ # (n Codeblock))
+
+ variable ok
+ if {[inc_restore DefaultDestructor]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq17 ; # (x (n DDEFDEST)
+ # (n Identifier)
+ # (n Codeblock))
+
+ isv_nonterminal_reduce DefaultDestructor $pos $mrk
+ inc_save DefaultDestructor $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal DefaultDestructor $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq17 {} {
+
+ # (x (n DDEFDEST)
+ # (n Identifier)
+ # (n Codeblock))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DDEFDEST ; # (n DDEFDEST)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_Codeblock ; # (n Codeblock)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DefaultType {} {
+ # DefaultType = (x (n DDEFTYPE)
+ # (n Codeblock))
+
+ variable ok
+ if {[inc_restore DefaultType]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq18 ; # (x (n DDEFTYPE)
+ # (n Codeblock))
+
+ isv_nonterminal_reduce DefaultType $pos $mrk
+ inc_save DefaultType $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal DefaultType $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq18 {} {
+
+ # (x (n DDEFTYPE)
+ # (n Codeblock))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DDEFTYPE ; # (n DDEFTYPE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Codeblock ; # (n Codeblock)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Definition {} {
+ # Definition = (* (x (n Identifier)
+ # (? (n Label))))
+
+ variable ok
+ if {[inc_restore Definition]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ ekleene11 ; # (* (x (n Identifier)
+ # (? (n Label))))
+
+ isv_nonterminal_reduce Definition $pos $mrk
+ inc_save Definition $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Definition $pos
+ return
+}
+
+proc ::page::parse::lemon::ekleene11 {} {
+
+ # (* (x (n Identifier)
+ # (? (n Label))))
+
+ variable ok
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ eseq10 ; # (x (n Identifier)
+ # (? (n Label)))
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::eseq10 {} {
+
+ # (x (n Identifier)
+ # (? (n Label)))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ eopt9 ; # (? (n Label))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::eopt9 {} {
+
+ # (? (n Label))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Label ; # (n Label)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DENDIF {} {
+ # DENDIF = (x (t %)
+ # (t e)
+ # (t n)
+ # (t d)
+ # (t i)
+ # (t f)
+ # (n SPACE))
+
+ if {[inc_restore DENDIF]} return
+
+ set pos [icl_get]
+
+ eseq82 ; # (x (t %)
+ # (t e)
+ # (t n)
+ # (t d)
+ # (t i)
+ # (t f)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DENDIF $pos
+ ier_nonterminal DENDIF $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq82 {} {
+
+ # (x (t %)
+ # (t e)
+ # (t n)
+ # (t d)
+ # (t i)
+ # (t f)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance %
+ if {$ok} {ict_match_token %}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance n
+ if {$ok} {ict_match_token n}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance d
+ if {$ok} {ict_match_token d}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance i
+ if {$ok} {ict_match_token i}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance f
+ if {$ok} {ict_match_token f}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Destructor {} {
+ # Destructor = (x (n DDEST)
+ # (n Identifier)
+ # (n Codeblock))
+
+ variable ok
+ if {[inc_restore Destructor]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq19 ; # (x (n DDEST)
+ # (n Identifier)
+ # (n Codeblock))
+
+ isv_nonterminal_reduce Destructor $pos $mrk
+ inc_save Destructor $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Destructor $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq19 {} {
+
+ # (x (n DDEST)
+ # (n Identifier)
+ # (n Codeblock))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DDEST ; # (n DDEST)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_Codeblock ; # (n Codeblock)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DEXTRA {} {
+ # DEXTRA = (x (t e)
+ # (t x)
+ # (t t)
+ # (t r)
+ # (t a)
+ # (t _)
+ # (t a)
+ # (t r)
+ # (t g)
+ # (t u)
+ # (t m)
+ # (t e)
+ # (t n)
+ # (t t)
+ # (n SPACE))
+
+ if {[inc_restore DEXTRA]} return
+
+ set pos [icl_get]
+
+ eseq63 ; # (x (t e)
+ # (t x)
+ # (t t)
+ # (t r)
+ # (t a)
+ # (t _)
+ # (t a)
+ # (t r)
+ # (t g)
+ # (t u)
+ # (t m)
+ # (t e)
+ # (t n)
+ # (t t)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DEXTRA $pos
+ ier_nonterminal DEXTRA $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq63 {} {
+
+ # (x (t e)
+ # (t x)
+ # (t t)
+ # (t r)
+ # (t a)
+ # (t _)
+ # (t a)
+ # (t r)
+ # (t g)
+ # (t u)
+ # (t m)
+ # (t e)
+ # (t n)
+ # (t t)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance x
+ if {$ok} {ict_match_token x}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance _
+ if {$ok} {ict_match_token _}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance g
+ if {$ok} {ict_match_token g}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance u
+ if {$ok} {ict_match_token u}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance m
+ if {$ok} {ict_match_token m}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance n
+ if {$ok} {ict_match_token n}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DFALLBK {} {
+ # DFALLBK = (x (t f)
+ # (t a)
+ # (t l)
+ # (t l)
+ # (t b)
+ # (t a)
+ # (t c)
+ # (t k)
+ # (n SPACE))
+
+ if {[inc_restore DFALLBK]} return
+
+ set pos [icl_get]
+
+ eseq79 ; # (x (t f)
+ # (t a)
+ # (t l)
+ # (t l)
+ # (t b)
+ # (t a)
+ # (t c)
+ # (t k)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DFALLBK $pos
+ ier_nonterminal DFALLBK $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq79 {} {
+
+ # (x (t f)
+ # (t a)
+ # (t l)
+ # (t l)
+ # (t b)
+ # (t a)
+ # (t c)
+ # (t k)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance f
+ if {$ok} {ict_match_token f}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance l
+ if {$ok} {ict_match_token l}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance l
+ if {$ok} {ict_match_token l}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance b
+ if {$ok} {ict_match_token b}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance c
+ if {$ok} {ict_match_token c}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance k
+ if {$ok} {ict_match_token k}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DIFDEF {} {
+ # DIFDEF = (x (t %)
+ # (t i)
+ # (t f)
+ # (t d)
+ # (t e)
+ # (t f)
+ # (n SPACE))
+
+ if {[inc_restore DIFDEF]} return
+
+ set pos [icl_get]
+
+ eseq80 ; # (x (t %)
+ # (t i)
+ # (t f)
+ # (t d)
+ # (t e)
+ # (t f)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DIFDEF $pos
+ ier_nonterminal DIFDEF $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq80 {} {
+
+ # (x (t %)
+ # (t i)
+ # (t f)
+ # (t d)
+ # (t e)
+ # (t f)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance %
+ if {$ok} {ict_match_token %}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance i
+ if {$ok} {ict_match_token i}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance f
+ if {$ok} {ict_match_token f}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance d
+ if {$ok} {ict_match_token d}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance f
+ if {$ok} {ict_match_token f}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DIFNDEF {} {
+ # DIFNDEF = (x (t %)
+ # (t i)
+ # (t f)
+ # (t n)
+ # (t d)
+ # (t e)
+ # (t f)
+ # (n SPACE))
+
+ if {[inc_restore DIFNDEF]} return
+
+ set pos [icl_get]
+
+ eseq81 ; # (x (t %)
+ # (t i)
+ # (t f)
+ # (t n)
+ # (t d)
+ # (t e)
+ # (t f)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DIFNDEF $pos
+ ier_nonterminal DIFNDEF $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq81 {} {
+
+ # (x (t %)
+ # (t i)
+ # (t f)
+ # (t n)
+ # (t d)
+ # (t e)
+ # (t f)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance %
+ if {$ok} {ict_match_token %}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance i
+ if {$ok} {ict_match_token i}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance f
+ if {$ok} {ict_match_token f}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance n
+ if {$ok} {ict_match_token n}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance d
+ if {$ok} {ict_match_token d}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance f
+ if {$ok} {ict_match_token f}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DINCL {} {
+ # DINCL = (x (t i)
+ # (t n)
+ # (t c)
+ # (t l)
+ # (t u)
+ # (t d)
+ # (t e)
+ # (n SPACE))
+
+ if {[inc_restore DINCL]} return
+
+ set pos [icl_get]
+
+ eseq64 ; # (x (t i)
+ # (t n)
+ # (t c)
+ # (t l)
+ # (t u)
+ # (t d)
+ # (t e)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DINCL $pos
+ ier_nonterminal DINCL $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq64 {} {
+
+ # (x (t i)
+ # (t n)
+ # (t c)
+ # (t l)
+ # (t u)
+ # (t d)
+ # (t e)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance i
+ if {$ok} {ict_match_token i}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance n
+ if {$ok} {ict_match_token n}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance c
+ if {$ok} {ict_match_token c}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance l
+ if {$ok} {ict_match_token l}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance u
+ if {$ok} {ict_match_token u}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance d
+ if {$ok} {ict_match_token d}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DINTRO {} {
+ # DINTRO = (t %)
+
+ variable ok
+ if {[inc_restore DINTRO]} return
+
+ set pos [icl_get]
+
+ ict_advance %
+ if {$ok} {ict_match_token %}
+
+ isv_clear
+ inc_save DINTRO $pos
+ ier_nonterminal DINTRO $pos
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Directive {} {
+ # Directive = (x (n DINTRO)
+ # (/ (n Code)
+ # (n DefaultDestructor)
+ # (n DefaultType)
+ # (n Destructor)
+ # (n ExtraArgument)
+ # (n Include)
+ # (n Left)
+ # (n Name)
+ # (n Nonassoc)
+ # (n ParseAccept)
+ # (n ParseFailure)
+ # (n Right)
+ # (n StackOverflow)
+ # (n Stacksize)
+ # (n StartSymbol)
+ # (n SyntaxError)
+ # (n TokenDestructor)
+ # (n TokenPrefix)
+ # (n TokenType)
+ # (n Type)
+ # (n Fallback)))
+
+ variable ok
+ if {[inc_restore Directive]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq15 ; # (x (n DINTRO)
+ # (/ (n Code)
+ # (n DefaultDestructor)
+ # (n DefaultType)
+ # (n Destructor)
+ # (n ExtraArgument)
+ # (n Include)
+ # (n Left)
+ # (n Name)
+ # (n Nonassoc)
+ # (n ParseAccept)
+ # (n ParseFailure)
+ # (n Right)
+ # (n StackOverflow)
+ # (n Stacksize)
+ # (n StartSymbol)
+ # (n SyntaxError)
+ # (n TokenDestructor)
+ # (n TokenPrefix)
+ # (n TokenType)
+ # (n Type)
+ # (n Fallback)))
+
+ isv_nonterminal_reduce Directive $pos $mrk
+ inc_save Directive $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Directive $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq15 {} {
+
+ # (x (n DINTRO)
+ # (/ (n Code)
+ # (n DefaultDestructor)
+ # (n DefaultType)
+ # (n Destructor)
+ # (n ExtraArgument)
+ # (n Include)
+ # (n Left)
+ # (n Name)
+ # (n Nonassoc)
+ # (n ParseAccept)
+ # (n ParseFailure)
+ # (n Right)
+ # (n StackOverflow)
+ # (n Stacksize)
+ # (n StartSymbol)
+ # (n SyntaxError)
+ # (n TokenDestructor)
+ # (n TokenPrefix)
+ # (n TokenType)
+ # (n Type)
+ # (n Fallback)))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DINTRO ; # (n DINTRO)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ ebra14 ; # (/ (n Code)
+ # (n DefaultDestructor)
+ # (n DefaultType)
+ # (n Destructor)
+ # (n ExtraArgument)
+ # (n Include)
+ # (n Left)
+ # (n Name)
+ # (n Nonassoc)
+ # (n ParseAccept)
+ # (n ParseFailure)
+ # (n Right)
+ # (n StackOverflow)
+ # (n Stacksize)
+ # (n StartSymbol)
+ # (n SyntaxError)
+ # (n TokenDestructor)
+ # (n TokenPrefix)
+ # (n TokenType)
+ # (n Type)
+ # (n Fallback))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::ebra14 {} {
+
+ # (/ (n Code)
+ # (n DefaultDestructor)
+ # (n DefaultType)
+ # (n Destructor)
+ # (n ExtraArgument)
+ # (n Include)
+ # (n Left)
+ # (n Name)
+ # (n Nonassoc)
+ # (n ParseAccept)
+ # (n ParseFailure)
+ # (n Right)
+ # (n StackOverflow)
+ # (n Stacksize)
+ # (n StartSymbol)
+ # (n SyntaxError)
+ # (n TokenDestructor)
+ # (n TokenPrefix)
+ # (n TokenType)
+ # (n Type)
+ # (n Fallback))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Code ; # (n Code)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_DefaultDestructor ; # (n DefaultDestructor)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_DefaultType ; # (n DefaultType)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Destructor ; # (n Destructor)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_ExtraArgument ; # (n ExtraArgument)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Include ; # (n Include)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Left ; # (n Left)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Name ; # (n Name)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Nonassoc ; # (n Nonassoc)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_ParseAccept ; # (n ParseAccept)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_ParseFailure ; # (n ParseFailure)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Right ; # (n Right)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_StackOverflow ; # (n StackOverflow)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Stacksize ; # (n Stacksize)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_StartSymbol ; # (n StartSymbol)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_SyntaxError ; # (n SyntaxError)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_TokenDestructor ; # (n TokenDestructor)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_TokenPrefix ; # (n TokenPrefix)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_TokenType ; # (n TokenType)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Type ; # (n Type)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Fallback ; # (n Fallback)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DLEFT {} {
+ # DLEFT = (x (t l)
+ # (t e)
+ # (t f)
+ # (t t)
+ # (n SPACE))
+
+ if {[inc_restore DLEFT]} return
+
+ set pos [icl_get]
+
+ eseq65 ; # (x (t l)
+ # (t e)
+ # (t f)
+ # (t t)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DLEFT $pos
+ ier_nonterminal DLEFT $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq65 {} {
+
+ # (x (t l)
+ # (t e)
+ # (t f)
+ # (t t)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance l
+ if {$ok} {ict_match_token l}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance f
+ if {$ok} {ict_match_token f}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DNAME {} {
+ # DNAME = (x (t n)
+ # (t a)
+ # (t m)
+ # (t e)
+ # (n SPACE))
+
+ if {[inc_restore DNAME]} return
+
+ set pos [icl_get]
+
+ eseq66 ; # (x (t n)
+ # (t a)
+ # (t m)
+ # (t e)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DNAME $pos
+ ier_nonterminal DNAME $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq66 {} {
+
+ # (x (t n)
+ # (t a)
+ # (t m)
+ # (t e)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance n
+ if {$ok} {ict_match_token n}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance m
+ if {$ok} {ict_match_token m}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DNON {} {
+ # DNON = (x (t n)
+ # (t o)
+ # (t n)
+ # (t a)
+ # (t s)
+ # (t s)
+ # (t o)
+ # (t c)
+ # (n SPACE))
+
+ if {[inc_restore DNON]} return
+
+ set pos [icl_get]
+
+ eseq67 ; # (x (t n)
+ # (t o)
+ # (t n)
+ # (t a)
+ # (t s)
+ # (t s)
+ # (t o)
+ # (t c)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DNON $pos
+ ier_nonterminal DNON $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq67 {} {
+
+ # (x (t n)
+ # (t o)
+ # (t n)
+ # (t a)
+ # (t s)
+ # (t s)
+ # (t o)
+ # (t c)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance n
+ if {$ok} {ict_match_token n}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance o
+ if {$ok} {ict_match_token o}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance n
+ if {$ok} {ict_match_token n}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance s
+ if {$ok} {ict_match_token s}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance s
+ if {$ok} {ict_match_token s}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance o
+ if {$ok} {ict_match_token o}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance c
+ if {$ok} {ict_match_token c}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DOT {} {
+ # DOT = (x (t .)
+ # (n SPACE))
+
+ if {[inc_restore DOT]} return
+
+ set pos [icl_get]
+
+ eseq54 ; # (x (t .)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DOT $pos
+ ier_nonterminal DOT $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq54 {} {
+
+ # (x (t .)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance .
+ if {$ok} {ict_match_token .}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DPACC {} {
+ # DPACC = (x (t p)
+ # (t a)
+ # (t r)
+ # (t s)
+ # (t e)
+ # (t _)
+ # (t a)
+ # (t c)
+ # (t c)
+ # (t e)
+ # (t p)
+ # (t t)
+ # (n SPACE))
+
+ if {[inc_restore DPACC]} return
+
+ set pos [icl_get]
+
+ eseq68 ; # (x (t p)
+ # (t a)
+ # (t r)
+ # (t s)
+ # (t e)
+ # (t _)
+ # (t a)
+ # (t c)
+ # (t c)
+ # (t e)
+ # (t p)
+ # (t t)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DPACC $pos
+ ier_nonterminal DPACC $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq68 {} {
+
+ # (x (t p)
+ # (t a)
+ # (t r)
+ # (t s)
+ # (t e)
+ # (t _)
+ # (t a)
+ # (t c)
+ # (t c)
+ # (t e)
+ # (t p)
+ # (t t)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance p
+ if {$ok} {ict_match_token p}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance s
+ if {$ok} {ict_match_token s}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance _
+ if {$ok} {ict_match_token _}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance c
+ if {$ok} {ict_match_token c}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance c
+ if {$ok} {ict_match_token c}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance p
+ if {$ok} {ict_match_token p}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DPFAIL {} {
+ # DPFAIL = (x (t p)
+ # (t a)
+ # (t r)
+ # (t s)
+ # (t e)
+ # (t _)
+ # (t f)
+ # (t a)
+ # (t i)
+ # (t l)
+ # (t u)
+ # (t r)
+ # (t e)
+ # (n SPACE))
+
+ if {[inc_restore DPFAIL]} return
+
+ set pos [icl_get]
+
+ eseq69 ; # (x (t p)
+ # (t a)
+ # (t r)
+ # (t s)
+ # (t e)
+ # (t _)
+ # (t f)
+ # (t a)
+ # (t i)
+ # (t l)
+ # (t u)
+ # (t r)
+ # (t e)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DPFAIL $pos
+ ier_nonterminal DPFAIL $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq69 {} {
+
+ # (x (t p)
+ # (t a)
+ # (t r)
+ # (t s)
+ # (t e)
+ # (t _)
+ # (t f)
+ # (t a)
+ # (t i)
+ # (t l)
+ # (t u)
+ # (t r)
+ # (t e)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance p
+ if {$ok} {ict_match_token p}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance s
+ if {$ok} {ict_match_token s}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance _
+ if {$ok} {ict_match_token _}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance f
+ if {$ok} {ict_match_token f}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance i
+ if {$ok} {ict_match_token i}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance l
+ if {$ok} {ict_match_token l}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance u
+ if {$ok} {ict_match_token u}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DRIGHT {} {
+ # DRIGHT = (x (t r)
+ # (t i)
+ # (t g)
+ # (t h)
+ # (t t)
+ # (n SPACE))
+
+ if {[inc_restore DRIGHT]} return
+
+ set pos [icl_get]
+
+ eseq70 ; # (x (t r)
+ # (t i)
+ # (t g)
+ # (t h)
+ # (t t)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DRIGHT $pos
+ ier_nonterminal DRIGHT $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq70 {} {
+
+ # (x (t r)
+ # (t i)
+ # (t g)
+ # (t h)
+ # (t t)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance i
+ if {$ok} {ict_match_token i}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance g
+ if {$ok} {ict_match_token g}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance h
+ if {$ok} {ict_match_token h}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DSTART {} {
+ # DSTART = (x (t s)
+ # (t t)
+ # (t a)
+ # (t r)
+ # (t t)
+ # (t _)
+ # (t s)
+ # (t y)
+ # (t m)
+ # (t b)
+ # (t o)
+ # (t l)
+ # (n SPACE))
+
+ if {[inc_restore DSTART]} return
+
+ set pos [icl_get]
+
+ eseq73 ; # (x (t s)
+ # (t t)
+ # (t a)
+ # (t r)
+ # (t t)
+ # (t _)
+ # (t s)
+ # (t y)
+ # (t m)
+ # (t b)
+ # (t o)
+ # (t l)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DSTART $pos
+ ier_nonterminal DSTART $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq73 {} {
+
+ # (x (t s)
+ # (t t)
+ # (t a)
+ # (t r)
+ # (t t)
+ # (t _)
+ # (t s)
+ # (t y)
+ # (t m)
+ # (t b)
+ # (t o)
+ # (t l)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance s
+ if {$ok} {ict_match_token s}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance _
+ if {$ok} {ict_match_token _}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance s
+ if {$ok} {ict_match_token s}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance y
+ if {$ok} {ict_match_token y}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance m
+ if {$ok} {ict_match_token m}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance b
+ if {$ok} {ict_match_token b}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance o
+ if {$ok} {ict_match_token o}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance l
+ if {$ok} {ict_match_token l}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DSTKOVER {} {
+ # DSTKOVER = (x (t s)
+ # (t t)
+ # (t a)
+ # (t c)
+ # (t k)
+ # (t _)
+ # (t o)
+ # (t v)
+ # (t e)
+ # (t r)
+ # (t f)
+ # (t l)
+ # (t o)
+ # (t w)
+ # (n SPACE))
+
+ if {[inc_restore DSTKOVER]} return
+
+ set pos [icl_get]
+
+ eseq71 ; # (x (t s)
+ # (t t)
+ # (t a)
+ # (t c)
+ # (t k)
+ # (t _)
+ # (t o)
+ # (t v)
+ # (t e)
+ # (t r)
+ # (t f)
+ # (t l)
+ # (t o)
+ # (t w)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DSTKOVER $pos
+ ier_nonterminal DSTKOVER $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq71 {} {
+
+ # (x (t s)
+ # (t t)
+ # (t a)
+ # (t c)
+ # (t k)
+ # (t _)
+ # (t o)
+ # (t v)
+ # (t e)
+ # (t r)
+ # (t f)
+ # (t l)
+ # (t o)
+ # (t w)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance s
+ if {$ok} {ict_match_token s}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance c
+ if {$ok} {ict_match_token c}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance k
+ if {$ok} {ict_match_token k}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance _
+ if {$ok} {ict_match_token _}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance o
+ if {$ok} {ict_match_token o}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance v
+ if {$ok} {ict_match_token v}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance f
+ if {$ok} {ict_match_token f}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance l
+ if {$ok} {ict_match_token l}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance o
+ if {$ok} {ict_match_token o}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance w
+ if {$ok} {ict_match_token w}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DSTKSZ {} {
+ # DSTKSZ = (x (t s)
+ # (t t)
+ # (t a)
+ # (t c)
+ # (t k)
+ # (t _)
+ # (t s)
+ # (t i)
+ # (t z)
+ # (t e)
+ # (n SPACE))
+
+ if {[inc_restore DSTKSZ]} return
+
+ set pos [icl_get]
+
+ eseq72 ; # (x (t s)
+ # (t t)
+ # (t a)
+ # (t c)
+ # (t k)
+ # (t _)
+ # (t s)
+ # (t i)
+ # (t z)
+ # (t e)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DSTKSZ $pos
+ ier_nonterminal DSTKSZ $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq72 {} {
+
+ # (x (t s)
+ # (t t)
+ # (t a)
+ # (t c)
+ # (t k)
+ # (t _)
+ # (t s)
+ # (t i)
+ # (t z)
+ # (t e)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance s
+ if {$ok} {ict_match_token s}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance c
+ if {$ok} {ict_match_token c}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance k
+ if {$ok} {ict_match_token k}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance _
+ if {$ok} {ict_match_token _}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance s
+ if {$ok} {ict_match_token s}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance i
+ if {$ok} {ict_match_token i}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance z
+ if {$ok} {ict_match_token z}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DSYNERR {} {
+ # DSYNERR = (x (t s)
+ # (t y)
+ # (t n)
+ # (t t)
+ # (t a)
+ # (t x)
+ # (t _)
+ # (t e)
+ # (t r)
+ # (t r)
+ # (t o)
+ # (t r)
+ # (n SPACE))
+
+ if {[inc_restore DSYNERR]} return
+
+ set pos [icl_get]
+
+ eseq74 ; # (x (t s)
+ # (t y)
+ # (t n)
+ # (t t)
+ # (t a)
+ # (t x)
+ # (t _)
+ # (t e)
+ # (t r)
+ # (t r)
+ # (t o)
+ # (t r)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DSYNERR $pos
+ ier_nonterminal DSYNERR $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq74 {} {
+
+ # (x (t s)
+ # (t y)
+ # (t n)
+ # (t t)
+ # (t a)
+ # (t x)
+ # (t _)
+ # (t e)
+ # (t r)
+ # (t r)
+ # (t o)
+ # (t r)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance s
+ if {$ok} {ict_match_token s}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance y
+ if {$ok} {ict_match_token y}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance n
+ if {$ok} {ict_match_token n}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance a
+ if {$ok} {ict_match_token a}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance x
+ if {$ok} {ict_match_token x}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance _
+ if {$ok} {ict_match_token _}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance o
+ if {$ok} {ict_match_token o}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DTOKDEST {} {
+ # DTOKDEST = (x (t t)
+ # (t o)
+ # (t k)
+ # (t e)
+ # (t n)
+ # (t _)
+ # (t d)
+ # (t e)
+ # (t s)
+ # (t t)
+ # (t r)
+ # (t u)
+ # (t c)
+ # (t t)
+ # (t o)
+ # (t r)
+ # (n SPACE))
+
+ if {[inc_restore DTOKDEST]} return
+
+ set pos [icl_get]
+
+ eseq75 ; # (x (t t)
+ # (t o)
+ # (t k)
+ # (t e)
+ # (t n)
+ # (t _)
+ # (t d)
+ # (t e)
+ # (t s)
+ # (t t)
+ # (t r)
+ # (t u)
+ # (t c)
+ # (t t)
+ # (t o)
+ # (t r)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DTOKDEST $pos
+ ier_nonterminal DTOKDEST $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq75 {} {
+
+ # (x (t t)
+ # (t o)
+ # (t k)
+ # (t e)
+ # (t n)
+ # (t _)
+ # (t d)
+ # (t e)
+ # (t s)
+ # (t t)
+ # (t r)
+ # (t u)
+ # (t c)
+ # (t t)
+ # (t o)
+ # (t r)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance o
+ if {$ok} {ict_match_token o}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance k
+ if {$ok} {ict_match_token k}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance n
+ if {$ok} {ict_match_token n}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance _
+ if {$ok} {ict_match_token _}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance d
+ if {$ok} {ict_match_token d}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance s
+ if {$ok} {ict_match_token s}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance u
+ if {$ok} {ict_match_token u}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance c
+ if {$ok} {ict_match_token c}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance o
+ if {$ok} {ict_match_token o}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DTOKPFX {} {
+ # DTOKPFX = (x (t t)
+ # (t o)
+ # (t k)
+ # (t e)
+ # (t n)
+ # (t _)
+ # (t p)
+ # (t r)
+ # (t e)
+ # (t f)
+ # (t i)
+ # (t x)
+ # (n SPACE))
+
+ if {[inc_restore DTOKPFX]} return
+
+ set pos [icl_get]
+
+ eseq76 ; # (x (t t)
+ # (t o)
+ # (t k)
+ # (t e)
+ # (t n)
+ # (t _)
+ # (t p)
+ # (t r)
+ # (t e)
+ # (t f)
+ # (t i)
+ # (t x)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DTOKPFX $pos
+ ier_nonterminal DTOKPFX $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq76 {} {
+
+ # (x (t t)
+ # (t o)
+ # (t k)
+ # (t e)
+ # (t n)
+ # (t _)
+ # (t p)
+ # (t r)
+ # (t e)
+ # (t f)
+ # (t i)
+ # (t x)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance o
+ if {$ok} {ict_match_token o}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance k
+ if {$ok} {ict_match_token k}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance n
+ if {$ok} {ict_match_token n}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance _
+ if {$ok} {ict_match_token _}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance p
+ if {$ok} {ict_match_token p}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance r
+ if {$ok} {ict_match_token r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance f
+ if {$ok} {ict_match_token f}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance i
+ if {$ok} {ict_match_token i}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance x
+ if {$ok} {ict_match_token x}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DTOKTYPE {} {
+ # DTOKTYPE = (x (t t)
+ # (t o)
+ # (t k)
+ # (t e)
+ # (t n)
+ # (t _)
+ # (t t)
+ # (t y)
+ # (t p)
+ # (t e)
+ # (n SPACE))
+
+ if {[inc_restore DTOKTYPE]} return
+
+ set pos [icl_get]
+
+ eseq77 ; # (x (t t)
+ # (t o)
+ # (t k)
+ # (t e)
+ # (t n)
+ # (t _)
+ # (t t)
+ # (t y)
+ # (t p)
+ # (t e)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DTOKTYPE $pos
+ ier_nonterminal DTOKTYPE $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq77 {} {
+
+ # (x (t t)
+ # (t o)
+ # (t k)
+ # (t e)
+ # (t n)
+ # (t _)
+ # (t t)
+ # (t y)
+ # (t p)
+ # (t e)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance o
+ if {$ok} {ict_match_token o}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance k
+ if {$ok} {ict_match_token k}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance n
+ if {$ok} {ict_match_token n}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance _
+ if {$ok} {ict_match_token _}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance y
+ if {$ok} {ict_match_token y}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance p
+ if {$ok} {ict_match_token p}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_DTYPE {} {
+ # DTYPE = (x (t t)
+ # (t y)
+ # (t p)
+ # (t e)
+ # (n SPACE))
+
+ if {[inc_restore DTYPE]} return
+
+ set pos [icl_get]
+
+ eseq78 ; # (x (t t)
+ # (t y)
+ # (t p)
+ # (t e)
+ # (n SPACE))
+
+ isv_clear
+ inc_save DTYPE $pos
+ ier_nonterminal DTYPE $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq78 {} {
+
+ # (x (t t)
+ # (t y)
+ # (t p)
+ # (t e)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance t
+ if {$ok} {ict_match_token t}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance y
+ if {$ok} {ict_match_token y}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance p
+ if {$ok} {ict_match_token p}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance e
+ if {$ok} {ict_match_token e}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Endif {} {
+ # Endif = (n DENDIF)
+
+ if {[inc_restore Endif]} return
+
+ set pos [icl_get]
+
+ matchSymbol_DENDIF ; # (n DENDIF)
+
+ isv_clear
+ inc_save Endif $pos
+ ier_nonterminal Endif $pos
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_EOF {} {
+ # EOF = (! (dot))
+
+ if {[inc_restore EOF]} return
+
+ set pos [icl_get]
+
+ ebang99
+
+ isv_clear
+ inc_save EOF $pos
+ ier_nonterminal EOF $pos
+ return
+}
+
+proc ::page::parse::lemon::ebang99 {} {
+ set pos [icl_get]
+
+ ict_advance "any character"
+
+ icl_rewind $pos
+ iok_negate
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_EOL {} {
+ # EOL = (/ (x (t \r)
+ # (t \n))
+ # (t \r)
+ # (t \n))
+
+ if {[inc_restore EOL]} return
+
+ set pos [icl_get]
+
+ ebra98 ; # (/ (x (t \r)
+ # (t \n))
+ # (t \r)
+ # (t \n))
+
+ isv_clear
+ inc_save EOL $pos
+ ier_nonterminal EOL $pos
+ return
+}
+
+proc ::page::parse::lemon::ebra98 {} {
+
+ # (/ (x (t \r)
+ # (t \n))
+ # (t \r)
+ # (t \n))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ eseq97 ; # (x (t \r)
+ # (t \n))
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance \\r
+ if {$ok} {ict_match_token \r}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance \\n
+ if {$ok} {ict_match_token \n}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::lemon::eseq97 {} {
+
+ # (x (t \r)
+ # (t \n))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance \\r
+ if {$ok} {ict_match_token \r}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance \\n
+ if {$ok} {ict_match_token \n}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_ExtraArgument {} {
+ # ExtraArgument = (x (n DEXTRA)
+ # (n Codeblock))
+
+ variable ok
+ if {[inc_restore ExtraArgument]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq20 ; # (x (n DEXTRA)
+ # (n Codeblock))
+
+ isv_nonterminal_reduce ExtraArgument $pos $mrk
+ inc_save ExtraArgument $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal ExtraArgument $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq20 {} {
+
+ # (x (n DEXTRA)
+ # (n Codeblock))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DEXTRA ; # (n DEXTRA)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Codeblock ; # (n Codeblock)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Fallback {} {
+ # Fallback = (x (n DFALLBK)
+ # (+ (n Identifier))
+ # (n DOT))
+
+ variable ok
+ if {[inc_restore Fallback]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq40 ; # (x (n DFALLBK)
+ # (+ (n Identifier))
+ # (n DOT))
+
+ isv_nonterminal_reduce Fallback $pos $mrk
+ inc_save Fallback $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Fallback $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq40 {} {
+
+ # (x (n DFALLBK)
+ # (+ (n Identifier))
+ # (n DOT))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DFALLBK ; # (n DFALLBK)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ epkleene39 ; # (+ (n Identifier))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_DOT ; # (n DOT)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::epkleene39 {} {
+
+ # (+ (n Identifier))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ icl_rewind $pos
+ return
+ }
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Ident {} {
+ # Ident = (x (/ (alpha)
+ # (t _))
+ # (* (/ (alnum)
+ # (t _))))
+
+ variable ok
+ if {[inc_restore Ident]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq50 ; # (x (/ (alpha)
+ # (t _))
+ # (* (/ (alnum)
+ # (t _))))
+
+ isv_nonterminal_range Ident $pos
+ inc_save Ident $pos
+ if {$ok} ias_push
+ ier_nonterminal Ident $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq50 {} {
+
+ # (x (/ (alpha)
+ # (t _))
+ # (* (/ (alnum)
+ # (t _))))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebra47 ; # (/ (alpha)
+ # (t _))
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ekleene49 ; # (* (/ (alnum)
+ # (t _)))
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::ebra47 {} {
+
+ # (/ (alpha)
+ # (t _))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance alpha
+ if {$ok} {ict_match_tokclass alpha}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance _
+ if {$ok} {ict_match_token _}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::lemon::ekleene49 {} {
+
+ # (* (/ (alnum)
+ # (t _)))
+
+ variable ok
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebra48 ; # (/ (alnum)
+ # (t _))
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::ebra48 {} {
+
+ # (/ (alnum)
+ # (t _))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance alnum
+ if {$ok} {ict_match_tokclass alnum}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance _
+ if {$ok} {ict_match_token _}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Identifier {} {
+ # Identifier = (x (n Ident)
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore Identifier]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq46 ; # (x (n Ident)
+ # (n SPACE))
+
+ isv_nonterminal_reduce Identifier $pos $mrk
+ inc_save Identifier $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Identifier $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq46 {} {
+
+ # (x (n Ident)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Ident ; # (n Ident)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Ifdef {} {
+ # Ifdef = (x (n DIFDEF)
+ # (n Identifier))
+
+ if {[inc_restore Ifdef]} return
+
+ set pos [icl_get]
+
+ eseq83 ; # (x (n DIFDEF)
+ # (n Identifier))
+
+ isv_clear
+ inc_save Ifdef $pos
+ ier_nonterminal Ifdef $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq83 {} {
+
+ # (x (n DIFDEF)
+ # (n Identifier))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DIFDEF ; # (n DIFDEF)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ set pIdentifier [ias_mark]
+ matchSymbol_Identifier
+ ias_pop2mark $pIdentifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Ifndef {} {
+ # Ifndef = (x (n DIFNDEF)
+ # (n Identifier))
+
+ if {[inc_restore Ifndef]} return
+
+ set pos [icl_get]
+
+ eseq84 ; # (x (n DIFNDEF)
+ # (n Identifier))
+
+ isv_clear
+ inc_save Ifndef $pos
+ ier_nonterminal Ifndef $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq84 {} {
+
+ # (x (n DIFNDEF)
+ # (n Identifier))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DIFNDEF ; # (n DIFNDEF)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ set pIdentifier [ias_mark]
+ matchSymbol_Identifier
+ ias_pop2mark $pIdentifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Include {} {
+ # Include = (x (n DINCL)
+ # (n Codeblock))
+
+ variable ok
+ if {[inc_restore Include]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq21 ; # (x (n DINCL)
+ # (n Codeblock))
+
+ isv_nonterminal_reduce Include $pos $mrk
+ inc_save Include $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Include $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq21 {} {
+
+ # (x (n DINCL)
+ # (n Codeblock))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DINCL ; # (n DINCL)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Codeblock ; # (n Codeblock)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Label {} {
+ # Label = (x (n LPAREN)
+ # (n Identifier)
+ # (n RPAREN))
+
+ variable ok
+ if {[inc_restore Label]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq12 ; # (x (n LPAREN)
+ # (n Identifier)
+ # (n RPAREN))
+
+ isv_nonterminal_reduce Label $pos $mrk
+ inc_save Label $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Label $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq12 {} {
+
+ # (x (n LPAREN)
+ # (n Identifier)
+ # (n RPAREN))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_LPAREN ; # (n LPAREN)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_RPAREN ; # (n RPAREN)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_LBRACE {} {
+ # LBRACE = (t \{)
+
+ variable ok
+ if {[inc_restore LBRACE]} return
+
+ set pos [icl_get]
+
+ ict_advance \{
+ if {$ok} {ict_match_token \173}
+
+ isv_clear
+ inc_save LBRACE $pos
+ ier_nonterminal LBRACE $pos
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_LBRACKET {} {
+ # LBRACKET = (x (t [)
+ # (n SPACE))
+
+ if {[inc_restore LBRACKET]} return
+
+ set pos [icl_get]
+
+ eseq57 ; # (x (t [)
+ # (n SPACE))
+
+ isv_clear
+ inc_save LBRACKET $pos
+ ier_nonterminal LBRACKET $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq57 {} {
+
+ # (x (t [)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance \[
+ if {$ok} {ict_match_token \133}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Left {} {
+ # Left = (x (n DLEFT)
+ # (+ (n Identifier))
+ # (n DOT))
+
+ variable ok
+ if {[inc_restore Left]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq23 ; # (x (n DLEFT)
+ # (+ (n Identifier))
+ # (n DOT))
+
+ isv_nonterminal_reduce Left $pos $mrk
+ inc_save Left $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Left $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq23 {} {
+
+ # (x (n DLEFT)
+ # (+ (n Identifier))
+ # (n DOT))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DLEFT ; # (n DLEFT)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ epkleene22 ; # (+ (n Identifier))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_DOT ; # (n DOT)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::epkleene22 {} {
+
+ # (+ (n Identifier))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ icl_rewind $pos
+ return
+ }
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_LemonGrammar {} {
+ # LemonGrammar = (x (n SPACE)
+ # (+ (n Statement))
+ # (n EOF))
+
+ variable ok
+ if {[inc_restore LemonGrammar]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq2 ; # (x (n SPACE)
+ # (+ (n Statement))
+ # (n EOF))
+
+ isv_nonterminal_reduce LemonGrammar $pos $mrk
+ inc_save LemonGrammar $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal LemonGrammar $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq2 {} {
+
+ # (x (n SPACE)
+ # (+ (n Statement))
+ # (n EOF))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ epkleene1 ; # (+ (n Statement))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_EOF ; # (n EOF)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::epkleene1 {} {
+
+ # (+ (n Statement))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Statement ; # (n Statement)
+ ier_merge $old
+
+ if {!$ok} {
+ icl_rewind $pos
+ return
+ }
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Statement ; # (n Statement)
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_LPAREN {} {
+ # LPAREN = (x (t \()
+ # (n SPACE))
+
+ if {[inc_restore LPAREN]} return
+
+ set pos [icl_get]
+
+ eseq55 ; # (x (t \()
+ # (n SPACE))
+
+ isv_clear
+ inc_save LPAREN $pos
+ ier_nonterminal LPAREN $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq55 {} {
+
+ # (x (t \()
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance \(
+ if {$ok} {ict_match_token \50}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Name {} {
+ # Name = (x (n DNAME)
+ # (n Identifier))
+
+ variable ok
+ if {[inc_restore Name]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq24 ; # (x (n DNAME)
+ # (n Identifier))
+
+ isv_nonterminal_reduce Name $pos $mrk
+ inc_save Name $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Name $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq24 {} {
+
+ # (x (n DNAME)
+ # (n Identifier))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DNAME ; # (n DNAME)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_NatNum {} {
+ # NatNum = (+ (.. 0 9))
+
+ variable ok
+ if {[inc_restore NatNum]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ epkleene52 ; # (+ (.. 0 9))
+
+ isv_nonterminal_range NatNum $pos
+ inc_save NatNum $pos
+ if {$ok} ias_push
+ ier_nonterminal NatNum $pos
+ return
+}
+
+proc ::page::parse::lemon::epkleene52 {} {
+
+ # (+ (.. 0 9))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "any in 0..9"
+ if {$ok} {ict_match_tokrange 0 9}
+ ier_merge $old
+
+ if {!$ok} {
+ icl_rewind $pos
+ return
+ }
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "any in 0..9"
+ if {$ok} {ict_match_tokrange 0 9}
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_NaturalNumber {} {
+ # NaturalNumber = (x (n NatNum)
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore NaturalNumber]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq51 ; # (x (n NatNum)
+ # (n SPACE))
+
+ isv_nonterminal_reduce NaturalNumber $pos $mrk
+ inc_save NaturalNumber $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal NaturalNumber $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq51 {} {
+
+ # (x (n NatNum)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_NatNum ; # (n NatNum)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Nonassoc {} {
+ # Nonassoc = (x (n DNON)
+ # (+ (n Identifier))
+ # (n DOT))
+
+ variable ok
+ if {[inc_restore Nonassoc]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq26 ; # (x (n DNON)
+ # (+ (n Identifier))
+ # (n DOT))
+
+ isv_nonterminal_reduce Nonassoc $pos $mrk
+ inc_save Nonassoc $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Nonassoc $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq26 {} {
+
+ # (x (n DNON)
+ # (+ (n Identifier))
+ # (n DOT))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DNON ; # (n DNON)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ epkleene25 ; # (+ (n Identifier))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_DOT ; # (n DOT)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::epkleene25 {} {
+
+ # (+ (n Identifier))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ icl_rewind $pos
+ return
+ }
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_ParseAccept {} {
+ # ParseAccept = (x (n DPACC)
+ # (n Codeblock))
+
+ variable ok
+ if {[inc_restore ParseAccept]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq27 ; # (x (n DPACC)
+ # (n Codeblock))
+
+ isv_nonterminal_reduce ParseAccept $pos $mrk
+ inc_save ParseAccept $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal ParseAccept $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq27 {} {
+
+ # (x (n DPACC)
+ # (n Codeblock))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DPACC ; # (n DPACC)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Codeblock ; # (n Codeblock)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_ParseFailure {} {
+ # ParseFailure = (x (n DPFAIL)
+ # (n Codeblock))
+
+ variable ok
+ if {[inc_restore ParseFailure]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq28 ; # (x (n DPFAIL)
+ # (n Codeblock))
+
+ isv_nonterminal_reduce ParseFailure $pos $mrk
+ inc_save ParseFailure $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal ParseFailure $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq28 {} {
+
+ # (x (n DPFAIL)
+ # (n Codeblock))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DPFAIL ; # (n DPFAIL)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Codeblock ; # (n Codeblock)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Precedence {} {
+ # Precedence = (x (n LBRACKET)
+ # (n Identifier)
+ # (n RBRACKET))
+
+ variable ok
+ if {[inc_restore Precedence]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq13 ; # (x (n LBRACKET)
+ # (n Identifier)
+ # (n RBRACKET))
+
+ isv_nonterminal_reduce Precedence $pos $mrk
+ inc_save Precedence $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Precedence $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq13 {} {
+
+ # (x (n LBRACKET)
+ # (n Identifier)
+ # (n RBRACKET))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_LBRACKET ; # (n LBRACKET)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_RBRACKET ; # (n RBRACKET)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_RBRACE {} {
+ # RBRACE = (t \})
+
+ variable ok
+ if {[inc_restore RBRACE]} return
+
+ set pos [icl_get]
+
+ ict_advance \}
+ if {$ok} {ict_match_token \175}
+
+ isv_clear
+ inc_save RBRACE $pos
+ ier_nonterminal RBRACE $pos
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_RBRACKET {} {
+ # RBRACKET = (x (t ])
+ # (n SPACE))
+
+ if {[inc_restore RBRACKET]} return
+
+ set pos [icl_get]
+
+ eseq58 ; # (x (t ])
+ # (n SPACE))
+
+ isv_clear
+ inc_save RBRACKET $pos
+ ier_nonterminal RBRACKET $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq58 {} {
+
+ # (x (t ])
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance \]
+ if {$ok} {ict_match_token \135}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Right {} {
+ # Right = (x (n DRIGHT)
+ # (+ (n Identifier))
+ # (n DOT))
+
+ variable ok
+ if {[inc_restore Right]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq30 ; # (x (n DRIGHT)
+ # (+ (n Identifier))
+ # (n DOT))
+
+ isv_nonterminal_reduce Right $pos $mrk
+ inc_save Right $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Right $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq30 {} {
+
+ # (x (n DRIGHT)
+ # (+ (n Identifier))
+ # (n DOT))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DRIGHT ; # (n DRIGHT)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ epkleene29 ; # (+ (n Identifier))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_DOT ; # (n DOT)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::epkleene29 {} {
+
+ # (+ (n Identifier))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ icl_rewind $pos
+ return
+ }
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_RPAREN {} {
+ # RPAREN = (x (t \))
+ # (n SPACE))
+
+ if {[inc_restore RPAREN]} return
+
+ set pos [icl_get]
+
+ eseq56 ; # (x (t \))
+ # (n SPACE))
+
+ isv_clear
+ inc_save RPAREN $pos
+ ier_nonterminal RPAREN $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq56 {} {
+
+ # (x (t \))
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance \)
+ if {$ok} {ict_match_token \51}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Rule {} {
+ # Rule = (x (n Identifier)
+ # (? (n Label))
+ # (n ASSIGN)
+ # (n Definition)
+ # (n DOT)
+ # (? (n Precedence))
+ # (? (n Codeblock)))
+
+ variable ok
+ if {[inc_restore Rule]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq8 ; # (x (n Identifier)
+ # (? (n Label))
+ # (n ASSIGN)
+ # (n Definition)
+ # (n DOT)
+ # (? (n Precedence))
+ # (? (n Codeblock)))
+
+ isv_nonterminal_reduce Rule $pos $mrk
+ inc_save Rule $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Rule $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq8 {} {
+
+ # (x (n Identifier)
+ # (? (n Label))
+ # (n ASSIGN)
+ # (n Definition)
+ # (n DOT)
+ # (? (n Precedence))
+ # (? (n Codeblock)))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ eopt5 ; # (? (n Label))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_ASSIGN ; # (n ASSIGN)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_Definition ; # (n Definition)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_DOT ; # (n DOT)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ eopt6 ; # (? (n Precedence))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ eopt7 ; # (? (n Codeblock))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::eopt5 {} {
+
+ # (? (n Label))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Label ; # (n Label)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::eopt6 {} {
+
+ # (? (n Precedence))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Precedence ; # (n Precedence)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::eopt7 {} {
+
+ # (? (n Codeblock))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Codeblock ; # (n Codeblock)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_SPACE {} {
+ # SPACE = (* (/ (t <blank>)
+ # (t \t)
+ # (t \n)
+ # (t \r)
+ # (n C_COMMENT)
+ # (n Cplusplus_COMMENT)
+ # (n Ifndef)
+ # (n Ifdef)
+ # (n Endif)))
+
+ if {[inc_restore SPACE]} return
+
+ set pos [icl_get]
+
+ ekleene86 ; # (* (/ (t <blank>)
+ # (t \t)
+ # (t \n)
+ # (t \r)
+ # (n C_COMMENT)
+ # (n Cplusplus_COMMENT)
+ # (n Ifndef)
+ # (n Ifdef)
+ # (n Endif)))
+
+ isv_clear
+ inc_save SPACE $pos
+ ier_nonterminal SPACE $pos
+ return
+}
+
+proc ::page::parse::lemon::ekleene86 {} {
+
+ # (* (/ (t <blank>)
+ # (t \t)
+ # (t \n)
+ # (t \r)
+ # (n C_COMMENT)
+ # (n Cplusplus_COMMENT)
+ # (n Ifndef)
+ # (n Ifdef)
+ # (n Endif)))
+
+ variable ok
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebra85 ; # (/ (t <blank>)
+ # (t \t)
+ # (t \n)
+ # (t \r)
+ # (n C_COMMENT)
+ # (n Cplusplus_COMMENT)
+ # (n Ifndef)
+ # (n Ifdef)
+ # (n Endif))
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::lemon::ebra85 {} {
+
+ # (/ (t <blank>)
+ # (t \t)
+ # (t \n)
+ # (t \r)
+ # (n C_COMMENT)
+ # (n Cplusplus_COMMENT)
+ # (n Ifndef)
+ # (n Ifdef)
+ # (n Endif))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance <blank>
+ if {$ok} {ict_match_token \40}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance \\t
+ if {$ok} {ict_match_token \t}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance \\n
+ if {$ok} {ict_match_token \n}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance \\r
+ if {$ok} {ict_match_token \r}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ matchSymbol_C_COMMENT ; # (n C_COMMENT)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ matchSymbol_Cplusplus_COMMENT ; # (n Cplusplus_COMMENT)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ matchSymbol_Ifndef ; # (n Ifndef)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ matchSymbol_Ifdef ; # (n Ifdef)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ matchSymbol_Endif ; # (n Endif)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_StackOverflow {} {
+ # StackOverflow = (x (n DSTKOVER)
+ # (n Codeblock))
+
+ variable ok
+ if {[inc_restore StackOverflow]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq31 ; # (x (n DSTKOVER)
+ # (n Codeblock))
+
+ isv_nonterminal_reduce StackOverflow $pos $mrk
+ inc_save StackOverflow $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal StackOverflow $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq31 {} {
+
+ # (x (n DSTKOVER)
+ # (n Codeblock))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DSTKOVER ; # (n DSTKOVER)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Codeblock ; # (n Codeblock)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Stacksize {} {
+ # Stacksize = (x (n DSTKSZ)
+ # (n NaturalNumber))
+
+ variable ok
+ if {[inc_restore Stacksize]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq32 ; # (x (n DSTKSZ)
+ # (n NaturalNumber))
+
+ isv_nonterminal_reduce Stacksize $pos $mrk
+ inc_save Stacksize $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Stacksize $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq32 {} {
+
+ # (x (n DSTKSZ)
+ # (n NaturalNumber))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DSTKSZ ; # (n DSTKSZ)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_NaturalNumber ; # (n NaturalNumber)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_StartSymbol {} {
+ # StartSymbol = (x (n DSTART)
+ # (n Identifier))
+
+ variable ok
+ if {[inc_restore StartSymbol]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq33 ; # (x (n DSTART)
+ # (n Identifier))
+
+ isv_nonterminal_reduce StartSymbol $pos $mrk
+ inc_save StartSymbol $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal StartSymbol $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq33 {} {
+
+ # (x (n DSTART)
+ # (n Identifier))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DSTART ; # (n DSTART)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Statement {} {
+ # Statement = (x (/ (n Directive)
+ # (n Rule))
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore Statement]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq4 ; # (x (/ (n Directive)
+ # (n Rule))
+ # (n SPACE))
+
+ isv_nonterminal_reduce Statement $pos $mrk
+ inc_save Statement $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Statement $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq4 {} {
+
+ # (x (/ (n Directive)
+ # (n Rule))
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ ebra3 ; # (/ (n Directive)
+ # (n Rule))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::ebra3 {} {
+
+ # (/ (n Directive)
+ # (n Rule))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Directive ; # (n Directive)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Rule ; # (n Rule)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_SyntaxError {} {
+ # SyntaxError = (x (n DSYNERR)
+ # (n Codeblock))
+
+ variable ok
+ if {[inc_restore SyntaxError]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq34 ; # (x (n DSYNERR)
+ # (n Codeblock))
+
+ isv_nonterminal_reduce SyntaxError $pos $mrk
+ inc_save SyntaxError $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal SyntaxError $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq34 {} {
+
+ # (x (n DSYNERR)
+ # (n Codeblock))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DSYNERR ; # (n DSYNERR)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Codeblock ; # (n Codeblock)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_TokenDestructor {} {
+ # TokenDestructor = (x (n DTOKDEST)
+ # (n Identifier)
+ # (n Codeblock))
+
+ variable ok
+ if {[inc_restore TokenDestructor]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq35 ; # (x (n DTOKDEST)
+ # (n Identifier)
+ # (n Codeblock))
+
+ isv_nonterminal_reduce TokenDestructor $pos $mrk
+ inc_save TokenDestructor $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal TokenDestructor $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq35 {} {
+
+ # (x (n DTOKDEST)
+ # (n Identifier)
+ # (n Codeblock))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DTOKDEST ; # (n DTOKDEST)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_Codeblock ; # (n Codeblock)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_TokenPrefix {} {
+ # TokenPrefix = (x (n DTOKPFX)
+ # (n Identifier))
+
+ variable ok
+ if {[inc_restore TokenPrefix]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq36 ; # (x (n DTOKPFX)
+ # (n Identifier))
+
+ isv_nonterminal_reduce TokenPrefix $pos $mrk
+ inc_save TokenPrefix $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal TokenPrefix $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq36 {} {
+
+ # (x (n DTOKPFX)
+ # (n Identifier))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DTOKPFX ; # (n DTOKPFX)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_TokenType {} {
+ # TokenType = (x (n DTOKTYPE)
+ # (n Codeblock))
+
+ variable ok
+ if {[inc_restore TokenType]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq37 ; # (x (n DTOKTYPE)
+ # (n Codeblock))
+
+ isv_nonterminal_reduce TokenType $pos $mrk
+ inc_save TokenType $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal TokenType $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq37 {} {
+
+ # (x (n DTOKTYPE)
+ # (n Codeblock))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DTOKTYPE ; # (n DTOKTYPE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Codeblock ; # (n Codeblock)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::lemon::matchSymbol_Type {} {
+ # Type = (x (n DTYPE)
+ # (n Identifier)
+ # (n Codeblock))
+
+ variable ok
+ if {[inc_restore Type]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq38 ; # (x (n DTYPE)
+ # (n Identifier)
+ # (n Codeblock))
+
+ isv_nonterminal_reduce Type $pos $mrk
+ inc_save Type $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal Type $pos
+ return
+}
+
+proc ::page::parse::lemon::eseq38 {} {
+
+ # (x (n DTYPE)
+ # (n Identifier)
+ # (n Codeblock))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DTYPE ; # (n DTYPE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_Codeblock ; # (n Codeblock)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Package Management
+
+package provide page::parse::lemon 0.1
diff --git a/tcllib/modules/page/parse_peg.tcl b/tcllib/modules/page/parse_peg.tcl
new file mode 100644
index 0000000..13f7265
--- /dev/null
+++ b/tcllib/modules/page/parse_peg.tcl
@@ -0,0 +1,4415 @@
+# -*- tcl -*-
+## Parsing Expression Grammar 'pg::peg::grammar'.
+## Recursive Descent Packrat parser generated
+## by the PAGE writer plugin 'me'.
+## (C) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# ### ### ### ######### ######### #########
+## Package description
+
+# The commands provided here match an input provided through a buffer
+# command to the PE grammar 'pg::peg::grammar'. The parser is based on the package
+# 'grammar::me::tcl' (recursive-descent, packrat, pulling chars,
+# pushing the generated AST).
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require grammar::me::tcl
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+namespace eval ::page::parse::peg {
+ # Import the virtual machine for matching.
+
+ namespace import ::grammar::me::tcl::*
+ upvar #0 ::grammar::me::tcl::ok ok
+}
+
+# ### ### ### ######### ######### #########
+## API Implementation.
+
+proc ::page::parse::peg::parse {nxcmd emvar astvar} {
+ variable ok
+ variable se
+
+ upvar 1 $emvar emsg $astvar ast
+
+ init $nxcmd
+
+ matchSymbol_Grammar ; # (n Grammar)
+
+ isv_nonterminal_reduce ALL -1
+ set ast [sv]
+ if {!$ok} {
+ foreach {l m} [ier_get] break
+ lappend l [lc $l]
+ set emsg [list $l $m]
+ }
+
+ return $ok
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper methods
+
+# Grammar 'pg::peg::grammar'
+#
+# ALNUM = (x (t <)
+# (t a)
+# (t l)
+# (t n)
+# (t u)
+# (t m)
+# (t >)
+# (n SPACE))
+#
+# ALPHA = (x (t <)
+# (t a)
+# (t l)
+# (t p)
+# (t h)
+# (t a)
+# (t >)
+# (n SPACE))
+#
+# AND = (x (t &)
+# (n SPACE))
+#
+# APOSTROPH = (t ')
+#
+# Attribute = (x (/ (n VOID)
+# (n LEAF)
+# (n MATCH))
+# (n COLON))
+#
+# Char = (/ (n CharSpecial)
+# (n CharOctalFull)
+# (n CharOctalPart)
+# (n CharUnicode)
+# (n CharUnescaped))
+#
+# CharOctalFull = (x (t \)
+# (.. 0 2)
+# (.. 0 7)
+# (.. 0 7))
+#
+# CharOctalPart = (x (t \)
+# (.. 0 7)
+# (? (.. 0 7)))
+#
+# CharSpecial = (x (t \)
+# (/ (t n)
+# (t r)
+# (t t)
+# (t ')
+# (t \")
+# (t [)
+# (t ])
+# (t \)))
+#
+# CharUnescaped = (x (! (t \))
+# (dot))
+#
+# CharUnicode = (x (t \)
+# (t u)
+# (n HexDigit)
+# (? (x (n HexDigit)
+# (? (x (n HexDigit)
+# (? (n HexDigit)))))))
+#
+# Class = (x (n OPENB)
+# (* (x (! (n CLOSEB))
+# (n Range)))
+# (n CLOSEB)
+# (n SPACE))
+#
+# CLOSE = (x (t \))
+# (n SPACE))
+#
+# CLOSEB = (t ])
+#
+# COLON = (x (t :)
+# (n SPACE))
+#
+# COMMENT = (x (t #)
+# (* (x (! (n EOL))
+# (dot)))
+# (n EOL))
+#
+# DAPOSTROPH = (t \")
+#
+# Definition = (x (? (n Attribute))
+# (n Identifier)
+# (n IS)
+# (n Expression)
+# (n SEMICOLON))
+#
+# DOT = (x (t .)
+# (n SPACE))
+#
+# END = (x (t E)
+# (t N)
+# (t D)
+# (n SPACE))
+#
+# EOF = (! (dot))
+#
+# EOL = (/ (x (t \n)
+# (t \r))
+# (t \n)
+# (t \r))
+#
+# Expression = (x (n Sequence)
+# (* (x (n SLASH)
+# (n Sequence))))
+#
+# Final = (x (n END)
+# (n SEMICOLON)
+# (n SPACE))
+#
+# Grammar = (x (n SPACE)
+# (n Header)
+# (+ (n Definition))
+# (n Final)
+# (n EOF))
+#
+# Header = (x (n PEG)
+# (n Identifier)
+# (n StartExpr))
+#
+# HexDigit = (/ (.. 0 9)
+# (.. a f)
+# (.. A F))
+#
+# Ident = (x (/ (t _)
+# (t :)
+# (alpha))
+# (* (/ (t _)
+# (t :)
+# (alnum))))
+#
+# Identifier = (x (n Ident)
+# (n SPACE))
+#
+# IS = (x (t <)
+# (t -)
+# (n SPACE))
+#
+# LEAF = (x (t l)
+# (t e)
+# (t a)
+# (t f)
+# (n SPACE))
+#
+# Literal = (/ (x (n APOSTROPH)
+# (* (x (! (n APOSTROPH))
+# (n Char)))
+# (n APOSTROPH)
+# (n SPACE))
+# (x (n DAPOSTROPH)
+# (* (x (! (n DAPOSTROPH))
+# (n Char)))
+# (n DAPOSTROPH)
+# (n SPACE)))
+#
+# MATCH = (x (t m)
+# (t a)
+# (t t)
+# (t c)
+# (t h)
+# (n SPACE))
+#
+# NOT = (x (t !)
+# (n SPACE))
+#
+# OPEN = (x (t \()
+# (n SPACE))
+#
+# OPENB = (t [)
+#
+# PEG = (x (t P)
+# (t E)
+# (t G)
+# (n SPACE))
+#
+# PLUS = (x (t +)
+# (n SPACE))
+#
+# Prefix = (x (? (/ (n AND)
+# (n NOT)))
+# (n Suffix))
+#
+# Primary = (/ (n ALNUM)
+# (n ALPHA)
+# (n Identifier)
+# (x (n OPEN)
+# (n Expression)
+# (n CLOSE))
+# (n Literal)
+# (n Class)
+# (n DOT))
+#
+# QUESTION = (x (t ?)
+# (n SPACE))
+#
+# Range = (/ (x (n Char)
+# (n TO)
+# (n Char))
+# (n Char))
+#
+# SEMICOLON = (x (t ;)
+# (n SPACE))
+#
+# Sequence = (+ (n Prefix))
+#
+# SLASH = (x (t /)
+# (n SPACE))
+#
+# SPACE = (* (/ (t <blank>)
+# (t \t)
+# (n EOL)
+# (n COMMENT)))
+#
+# STAR = (x (t *)
+# (n SPACE))
+#
+# StartExpr = (x (n OPEN)
+# (n Expression)
+# (n CLOSE))
+#
+# Suffix = (x (n Primary)
+# (? (/ (n QUESTION)
+# (n STAR)
+# (n PLUS))))
+#
+# TO = (t -)
+#
+# VOID = (x (t v)
+# (t o)
+# (t i)
+# (t d)
+# (n SPACE))
+#
+
+proc ::page::parse::peg::matchSymbol_ALNUM {} {
+ # ALNUM = (x (t <)
+ # (t a)
+ # (t l)
+ # (t n)
+ # (t u)
+ # (t m)
+ # (t >)
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore ALNUM]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq75 ; # (x (t <)
+ # (t a)
+ # (t l)
+ # (t n)
+ # (t u)
+ # (t m)
+ # (t >)
+ # (n SPACE))
+
+ isv_nonterminal_leaf ALNUM $pos
+ inc_save ALNUM $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected ALNUM" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq75 {} {
+
+ # (x (t <)
+ # (t a)
+ # (t l)
+ # (t n)
+ # (t u)
+ # (t m)
+ # (t >)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected < (got EOF)"
+ if {$ok} {ict_match_token < "Expected <"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected a (got EOF)"
+ if {$ok} {ict_match_token a "Expected a"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected l (got EOF)"
+ if {$ok} {ict_match_token l "Expected l"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected n (got EOF)"
+ if {$ok} {ict_match_token n "Expected n"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected u (got EOF)"
+ if {$ok} {ict_match_token u "Expected u"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected m (got EOF)"
+ if {$ok} {ict_match_token m "Expected m"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected > (got EOF)"
+ if {$ok} {ict_match_token > "Expected >"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_ALPHA {} {
+ # ALPHA = (x (t <)
+ # (t a)
+ # (t l)
+ # (t p)
+ # (t h)
+ # (t a)
+ # (t >)
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore ALPHA]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq74 ; # (x (t <)
+ # (t a)
+ # (t l)
+ # (t p)
+ # (t h)
+ # (t a)
+ # (t >)
+ # (n SPACE))
+
+ isv_nonterminal_leaf ALPHA $pos
+ inc_save ALPHA $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected ALPHA" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq74 {} {
+
+ # (x (t <)
+ # (t a)
+ # (t l)
+ # (t p)
+ # (t h)
+ # (t a)
+ # (t >)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected < (got EOF)"
+ if {$ok} {ict_match_token < "Expected <"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected a (got EOF)"
+ if {$ok} {ict_match_token a "Expected a"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected l (got EOF)"
+ if {$ok} {ict_match_token l "Expected l"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected p (got EOF)"
+ if {$ok} {ict_match_token p "Expected p"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected h (got EOF)"
+ if {$ok} {ict_match_token h "Expected h"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected a (got EOF)"
+ if {$ok} {ict_match_token a "Expected a"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected > (got EOF)"
+ if {$ok} {ict_match_token > "Expected >"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_AND {} {
+ # AND = (x (t &)
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore AND]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq66 ; # (x (t &)
+ # (n SPACE))
+
+ isv_nonterminal_leaf AND $pos
+ inc_save AND $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected AND" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq66 {} {
+
+ # (x (t &)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected & (got EOF)"
+ if {$ok} {ict_match_token & "Expected &"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_APOSTROPH {} {
+ # APOSTROPH = (t ')
+
+ variable ok
+ if {[inc_restore APOSTROPH]} return
+
+ set pos [icl_get]
+
+ ict_advance "Expected ' (got EOF)"
+ if {$ok} {ict_match_token ' "Expected '"}
+
+ isv_clear
+ inc_save APOSTROPH $pos
+ ier_nonterminal "Expected APOSTROPH" $pos
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Attribute {} {
+ # Attribute = (x (/ (n VOID)
+ # (n LEAF)
+ # (n MATCH))
+ # (n COLON))
+
+ variable ok
+ if {[inc_restore Attribute]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq7 ; # (x (/ (n VOID)
+ # (n LEAF)
+ # (n MATCH))
+ # (n COLON))
+
+ isv_nonterminal_reduce Attribute $pos $mrk
+ inc_save Attribute $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal "Expected Attribute" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq7 {} {
+
+ # (x (/ (n VOID)
+ # (n LEAF)
+ # (n MATCH))
+ # (n COLON))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ ebra6 ; # (/ (n VOID)
+ # (n LEAF)
+ # (n MATCH))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_COLON ; # (n COLON)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::ebra6 {} {
+
+ # (/ (n VOID)
+ # (n LEAF)
+ # (n MATCH))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_VOID ; # (n VOID)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_LEAF ; # (n LEAF)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_MATCH ; # (n MATCH)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Char {} {
+ # Char = (/ (n CharSpecial)
+ # (n CharOctalFull)
+ # (n CharOctalPart)
+ # (n CharUnicode)
+ # (n CharUnescaped))
+
+ variable ok
+ if {[inc_restore Char]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ ebra42 ; # (/ (n CharSpecial)
+ # (n CharOctalFull)
+ # (n CharOctalPart)
+ # (n CharUnicode)
+ # (n CharUnescaped))
+
+ isv_nonterminal_reduce Char $pos $mrk
+ inc_save Char $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal "Expected Char" $pos
+ return
+}
+
+proc ::page::parse::peg::ebra42 {} {
+
+ # (/ (n CharSpecial)
+ # (n CharOctalFull)
+ # (n CharOctalPart)
+ # (n CharUnicode)
+ # (n CharUnescaped))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_CharSpecial ; # (n CharSpecial)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_CharOctalFull ; # (n CharOctalFull)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_CharOctalPart ; # (n CharOctalPart)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_CharUnicode ; # (n CharUnicode)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_CharUnescaped ; # (n CharUnescaped)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_CharOctalFull {} {
+ # CharOctalFull = (x (t \)
+ # (.. 0 2)
+ # (.. 0 7)
+ # (.. 0 7))
+
+ variable ok
+ if {[inc_restore CharOctalFull]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq45 ; # (x (t \)
+ # (.. 0 2)
+ # (.. 0 7)
+ # (.. 0 7))
+
+ isv_nonterminal_range CharOctalFull $pos
+ inc_save CharOctalFull $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected CharOctalFull" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq45 {} {
+
+ # (x (t \)
+ # (.. 0 2)
+ # (.. 0 7)
+ # (.. 0 7))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected \\ (got EOF)"
+ if {$ok} {ict_match_token \134 "Expected \\"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected \[0..2\] (got EOF)"
+ if {$ok} {ict_match_tokrange 0 2 "Expected \[0..2\]"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected \[0..7\] (got EOF)"
+ if {$ok} {ict_match_tokrange 0 7 "Expected \[0..7\]"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected \[0..7\] (got EOF)"
+ if {$ok} {ict_match_tokrange 0 7 "Expected \[0..7\]"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_CharOctalPart {} {
+ # CharOctalPart = (x (t \)
+ # (.. 0 7)
+ # (? (.. 0 7)))
+
+ variable ok
+ if {[inc_restore CharOctalPart]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq47 ; # (x (t \)
+ # (.. 0 7)
+ # (? (.. 0 7)))
+
+ isv_nonterminal_range CharOctalPart $pos
+ inc_save CharOctalPart $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected CharOctalPart" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq47 {} {
+
+ # (x (t \)
+ # (.. 0 7)
+ # (? (.. 0 7)))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected \\ (got EOF)"
+ if {$ok} {ict_match_token \134 "Expected \\"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected \[0..7\] (got EOF)"
+ if {$ok} {ict_match_tokrange 0 7 "Expected \[0..7\]"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ eopt46 ; # (? (.. 0 7))
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::eopt46 {} {
+
+ # (? (.. 0 7))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected \[0..7\] (got EOF)"
+ if {$ok} {ict_match_tokrange 0 7 "Expected \[0..7\]"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_CharSpecial {} {
+ # CharSpecial = (x (t \)
+ # (/ (t n)
+ # (t r)
+ # (t t)
+ # (t ')
+ # (t \")
+ # (t [)
+ # (t ])
+ # (t \)))
+
+ variable ok
+ if {[inc_restore CharSpecial]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq44 ; # (x (t \)
+ # (/ (t n)
+ # (t r)
+ # (t t)
+ # (t ')
+ # (t \")
+ # (t [)
+ # (t ])
+ # (t \)))
+
+ isv_nonterminal_range CharSpecial $pos
+ inc_save CharSpecial $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected CharSpecial" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq44 {} {
+
+ # (x (t \)
+ # (/ (t n)
+ # (t r)
+ # (t t)
+ # (t ')
+ # (t \")
+ # (t [)
+ # (t ])
+ # (t \)))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected \\ (got EOF)"
+ if {$ok} {ict_match_token \134 "Expected \\"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ebra43 ; # (/ (t n)
+ # (t r)
+ # (t t)
+ # (t ')
+ # (t \")
+ # (t [)
+ # (t ])
+ # (t \))
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::ebra43 {} {
+
+ # (/ (t n)
+ # (t r)
+ # (t t)
+ # (t ')
+ # (t \")
+ # (t [)
+ # (t ])
+ # (t \))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected n (got EOF)"
+ if {$ok} {ict_match_token n "Expected n"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected r (got EOF)"
+ if {$ok} {ict_match_token r "Expected r"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected t (got EOF)"
+ if {$ok} {ict_match_token t "Expected t"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected ' (got EOF)"
+ if {$ok} {ict_match_token ' "Expected '"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected \" (got EOF)"
+ if {$ok} {ict_match_token \42 "Expected \""}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected \[ (got EOF)"
+ if {$ok} {ict_match_token \133 "Expected \["}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected \] (got EOF)"
+ if {$ok} {ict_match_token \135 "Expected \]"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected \\ (got EOF)"
+ if {$ok} {ict_match_token \134 "Expected \\"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_CharUnescaped {} {
+ # CharUnescaped = (x (! (t \))
+ # (dot))
+
+ variable ok
+ if {[inc_restore CharUnescaped]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq55 ; # (x (! (t \))
+ # (dot))
+
+ isv_nonterminal_range CharUnescaped $pos
+ inc_save CharUnescaped $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected CharUnescaped" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq55 {} {
+
+ # (x (! (t \))
+ # (dot))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebang54
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected any character (got EOF)"
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::ebang54 {} {
+ variable ok
+
+ set pos [icl_get]
+
+ ict_advance "Expected \\ (got EOF)"
+ if {$ok} {ict_match_token \134 "Expected \\"}
+
+ icl_rewind $pos
+ iok_negate
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_CharUnicode {} {
+ # CharUnicode = (x (t \)
+ # (t u)
+ # (n HexDigit)
+ # (? (x (n HexDigit)
+ # (? (x (n HexDigit)
+ # (? (n HexDigit)))))))
+
+ variable ok
+ if {[inc_restore CharUnicode]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq53 ; # (x (t \)
+ # (t u)
+ # (n HexDigit)
+ # (? (x (n HexDigit)
+ # (? (x (n HexDigit)
+ # (? (n HexDigit)))))))
+
+ isv_nonterminal_range CharUnicode $pos
+ inc_save CharUnicode $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected CharUnicode" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq53 {} {
+
+ # (x (t \)
+ # (t u)
+ # (n HexDigit)
+ # (? (x (n HexDigit)
+ # (? (x (n HexDigit)
+ # (? (n HexDigit)))))))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected \\ (got EOF)"
+ if {$ok} {ict_match_token \134 "Expected \\"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected u (got EOF)"
+ if {$ok} {ict_match_token u "Expected u"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_HexDigit ; # (n HexDigit)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ eopt52 ; # (? (x (n HexDigit)
+ # (? (x (n HexDigit)
+ # (? (n HexDigit))))))
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::eopt52 {} {
+
+ # (? (x (n HexDigit)
+ # (? (x (n HexDigit)
+ # (? (n HexDigit))))))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ eseq51 ; # (x (n HexDigit)
+ # (? (x (n HexDigit)
+ # (? (n HexDigit)))))
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::eseq51 {} {
+
+ # (x (n HexDigit)
+ # (? (x (n HexDigit)
+ # (? (n HexDigit)))))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_HexDigit ; # (n HexDigit)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ eopt50 ; # (? (x (n HexDigit)
+ # (? (n HexDigit))))
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::eopt50 {} {
+
+ # (? (x (n HexDigit)
+ # (? (n HexDigit))))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ eseq49 ; # (x (n HexDigit)
+ # (? (n HexDigit)))
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::eseq49 {} {
+
+ # (x (n HexDigit)
+ # (? (n HexDigit)))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_HexDigit ; # (n HexDigit)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ eopt48 ; # (? (n HexDigit))
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::eopt48 {} {
+
+ # (? (n HexDigit))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_HexDigit ; # (n HexDigit)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Class {} {
+ # Class = (x (n OPENB)
+ # (* (x (! (n CLOSEB))
+ # (n Range)))
+ # (n CLOSEB)
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore Class]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq32 ; # (x (n OPENB)
+ # (* (x (! (n CLOSEB))
+ # (n Range)))
+ # (n CLOSEB)
+ # (n SPACE))
+
+ isv_nonterminal_reduce Class $pos $mrk
+ inc_save Class $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal "Expected Class" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq32 {} {
+
+ # (x (n OPENB)
+ # (* (x (! (n CLOSEB))
+ # (n Range)))
+ # (n CLOSEB)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_OPENB ; # (n OPENB)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ ekleene31 ; # (* (x (! (n CLOSEB))
+ # (n Range)))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_CLOSEB ; # (n CLOSEB)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::ekleene31 {} {
+
+ # (* (x (! (n CLOSEB))
+ # (n Range)))
+
+ variable ok
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ eseq30 ; # (x (! (n CLOSEB))
+ # (n Range))
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::eseq30 {} {
+
+ # (x (! (n CLOSEB))
+ # (n Range))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebang29
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Range ; # (n Range)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::ebang29 {} {
+ set pos [icl_get]
+
+ matchSymbol_CLOSEB ; # (n CLOSEB)
+
+ icl_rewind $pos
+ iok_negate
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_CLOSE {} {
+ # CLOSE = (x (t \))
+ # (n SPACE))
+
+ if {[inc_restore CLOSE]} return
+
+ set pos [icl_get]
+
+ eseq72 ; # (x (t \))
+ # (n SPACE))
+
+ isv_clear
+ inc_save CLOSE $pos
+ ier_nonterminal "Expected CLOSE" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq72 {} {
+
+ # (x (t \))
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected \) (got EOF)"
+ if {$ok} {ict_match_token \51 "Expected \)"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_CLOSEB {} {
+ # CLOSEB = (t ])
+
+ variable ok
+ if {[inc_restore CLOSEB]} return
+
+ set pos [icl_get]
+
+ ict_advance "Expected \] (got EOF)"
+ if {$ok} {ict_match_token \135 "Expected \]"}
+
+ isv_clear
+ inc_save CLOSEB $pos
+ ier_nonterminal "Expected CLOSEB" $pos
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_COLON {} {
+ # COLON = (x (t :)
+ # (n SPACE))
+
+ if {[inc_restore COLON]} return
+
+ set pos [icl_get]
+
+ eseq64 ; # (x (t :)
+ # (n SPACE))
+
+ isv_clear
+ inc_save COLON $pos
+ ier_nonterminal "Expected COLON" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq64 {} {
+
+ # (x (t :)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected : (got EOF)"
+ if {$ok} {ict_match_token : "Expected :"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_COMMENT {} {
+ # COMMENT = (x (t #)
+ # (* (x (! (n EOL))
+ # (dot)))
+ # (n EOL))
+
+ if {[inc_restore COMMENT]} return
+
+ set pos [icl_get]
+
+ eseq81 ; # (x (t #)
+ # (* (x (! (n EOL))
+ # (dot)))
+ # (n EOL))
+
+ isv_clear
+ inc_save COMMENT $pos
+ ier_nonterminal "Expected COMMENT" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq81 {} {
+
+ # (x (t #)
+ # (* (x (! (n EOL))
+ # (dot)))
+ # (n EOL))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected # (got EOF)"
+ if {$ok} {ict_match_token # "Expected #"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ekleene80 ; # (* (x (! (n EOL))
+ # (dot)))
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_EOL ; # (n EOL)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::ekleene80 {} {
+
+ # (* (x (! (n EOL))
+ # (dot)))
+
+ variable ok
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ eseq79 ; # (x (! (n EOL))
+ # (dot))
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::eseq79 {} {
+
+ # (x (! (n EOL))
+ # (dot))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebang78
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected any character (got EOF)"
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::ebang78 {} {
+ set pos [icl_get]
+
+ matchSymbol_EOL ; # (n EOL)
+
+ icl_rewind $pos
+ iok_negate
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_DAPOSTROPH {} {
+ # DAPOSTROPH = (t \")
+
+ variable ok
+ if {[inc_restore DAPOSTROPH]} return
+
+ set pos [icl_get]
+
+ ict_advance "Expected \" (got EOF)"
+ if {$ok} {ict_match_token \42 "Expected \""}
+
+ isv_clear
+ inc_save DAPOSTROPH $pos
+ ier_nonterminal "Expected DAPOSTROPH" $pos
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Definition {} {
+ # Definition = (x (? (n Attribute))
+ # (n Identifier)
+ # (n IS)
+ # (n Expression)
+ # (n SEMICOLON))
+
+ variable ok
+ if {[inc_restore Definition]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq5 ; # (x (? (n Attribute))
+ # (n Identifier)
+ # (n IS)
+ # (n Expression)
+ # (n SEMICOLON))
+
+ isv_nonterminal_reduce Definition $pos $mrk
+ inc_save Definition $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal "Expected Definition" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq5 {} {
+
+ # (x (? (n Attribute))
+ # (n Identifier)
+ # (n IS)
+ # (n Expression)
+ # (n SEMICOLON))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ eopt4 ; # (? (n Attribute))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_IS ; # (n IS)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_Expression ; # (n Expression)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_SEMICOLON ; # (n SEMICOLON)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::eopt4 {} {
+
+ # (? (n Attribute))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Attribute ; # (n Attribute)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_DOT {} {
+ # DOT = (x (t .)
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore DOT]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq73 ; # (x (t .)
+ # (n SPACE))
+
+ isv_nonterminal_leaf DOT $pos
+ inc_save DOT $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected DOT" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq73 {} {
+
+ # (x (t .)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected . (got EOF)"
+ if {$ok} {ict_match_token . "Expected ."}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_END {} {
+ # END = (x (t E)
+ # (t N)
+ # (t D)
+ # (n SPACE))
+
+ if {[inc_restore END]} return
+
+ set pos [icl_get]
+
+ eseq62 ; # (x (t E)
+ # (t N)
+ # (t D)
+ # (n SPACE))
+
+ isv_clear
+ inc_save END $pos
+ ier_nonterminal "Expected END" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq62 {} {
+
+ # (x (t E)
+ # (t N)
+ # (t D)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected E (got EOF)"
+ if {$ok} {ict_match_token E "Expected E"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected N (got EOF)"
+ if {$ok} {ict_match_token N "Expected N"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected D (got EOF)"
+ if {$ok} {ict_match_token D "Expected D"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_EOF {} {
+ # EOF = (! (dot))
+
+ if {[inc_restore EOF]} return
+
+ set pos [icl_get]
+
+ ebang84
+
+ isv_clear
+ inc_save EOF $pos
+ ier_nonterminal "Expected EOF" $pos
+ return
+}
+
+proc ::page::parse::peg::ebang84 {} {
+ set pos [icl_get]
+
+ ict_advance "Expected any character (got EOF)"
+
+ icl_rewind $pos
+ iok_negate
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_EOL {} {
+ # EOL = (/ (x (t \n)
+ # (t \r))
+ # (t \n)
+ # (t \r))
+
+ if {[inc_restore EOL]} return
+
+ set pos [icl_get]
+
+ ebra83 ; # (/ (x (t \n)
+ # (t \r))
+ # (t \n)
+ # (t \r))
+
+ isv_clear
+ inc_save EOL $pos
+ ier_nonterminal "Expected EOL" $pos
+ return
+}
+
+proc ::page::parse::peg::ebra83 {} {
+
+ # (/ (x (t \n)
+ # (t \r))
+ # (t \n)
+ # (t \r))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ eseq82 ; # (x (t \n)
+ # (t \r))
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected \\n (got EOF)"
+ if {$ok} {ict_match_token \n "Expected \\n"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected \\r (got EOF)"
+ if {$ok} {ict_match_token \r "Expected \\r"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::peg::eseq82 {} {
+
+ # (x (t \n)
+ # (t \r))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected \\n (got EOF)"
+ if {$ok} {ict_match_token \n "Expected \\n"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected \\r (got EOF)"
+ if {$ok} {ict_match_token \r "Expected \\r"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Expression {} {
+ # Expression = (x (n Sequence)
+ # (* (x (n SLASH)
+ # (n Sequence))))
+
+ variable ok
+ if {[inc_restore Expression]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq10 ; # (x (n Sequence)
+ # (* (x (n SLASH)
+ # (n Sequence))))
+
+ isv_nonterminal_reduce Expression $pos $mrk
+ inc_save Expression $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal "Expected Expression" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq10 {} {
+
+ # (x (n Sequence)
+ # (* (x (n SLASH)
+ # (n Sequence))))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Sequence ; # (n Sequence)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ ekleene9 ; # (* (x (n SLASH)
+ # (n Sequence)))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::ekleene9 {} {
+
+ # (* (x (n SLASH)
+ # (n Sequence)))
+
+ variable ok
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ eseq8 ; # (x (n SLASH)
+ # (n Sequence))
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::eseq8 {} {
+
+ # (x (n SLASH)
+ # (n Sequence))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_SLASH ; # (n SLASH)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Sequence ; # (n Sequence)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Final {} {
+ # Final = (x (n END)
+ # (n SEMICOLON)
+ # (n SPACE))
+
+ if {[inc_restore Final]} return
+
+ set pos [icl_get]
+
+ eseq36 ; # (x (n END)
+ # (n SEMICOLON)
+ # (n SPACE))
+
+ isv_clear
+ inc_save Final $pos
+ ier_nonterminal "Expected Final" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq36 {} {
+
+ # (x (n END)
+ # (n SEMICOLON)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_END ; # (n END)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SEMICOLON ; # (n SEMICOLON)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Grammar {} {
+ # Grammar = (x (n SPACE)
+ # (n Header)
+ # (+ (n Definition))
+ # (n Final)
+ # (n EOF))
+
+ variable ok
+ if {[inc_restore Grammar]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq2 ; # (x (n SPACE)
+ # (n Header)
+ # (+ (n Definition))
+ # (n Final)
+ # (n EOF))
+
+ isv_nonterminal_reduce Grammar $pos $mrk
+ inc_save Grammar $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal "Expected Grammar" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq2 {} {
+
+ # (x (n SPACE)
+ # (n Header)
+ # (+ (n Definition))
+ # (n Final)
+ # (n EOF))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Header ; # (n Header)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ epkleene1 ; # (+ (n Definition))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_Final ; # (n Final)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_EOF ; # (n EOF)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::epkleene1 {} {
+
+ # (+ (n Definition))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Definition ; # (n Definition)
+ ier_merge $old
+
+ if {!$ok} {
+ icl_rewind $pos
+ return
+ }
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Definition ; # (n Definition)
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Header {} {
+ # Header = (x (n PEG)
+ # (n Identifier)
+ # (n StartExpr))
+
+ variable ok
+ if {[inc_restore Header]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq3 ; # (x (n PEG)
+ # (n Identifier)
+ # (n StartExpr))
+
+ isv_nonterminal_reduce Header $pos $mrk
+ inc_save Header $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal "Expected Header" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq3 {} {
+
+ # (x (n PEG)
+ # (n Identifier)
+ # (n StartExpr))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_PEG ; # (n PEG)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_StartExpr ; # (n StartExpr)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_HexDigit {} {
+ # HexDigit = (/ (.. 0 9)
+ # (.. a f)
+ # (.. A F))
+
+ if {[inc_restore HexDigit]} return
+
+ set pos [icl_get]
+
+ ebra56 ; # (/ (.. 0 9)
+ # (.. a f)
+ # (.. A F))
+
+ isv_clear
+ inc_save HexDigit $pos
+ ier_nonterminal "Expected HexDigit" $pos
+ return
+}
+
+proc ::page::parse::peg::ebra56 {} {
+
+ # (/ (.. 0 9)
+ # (.. a f)
+ # (.. A F))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected \[0..9\] (got EOF)"
+ if {$ok} {ict_match_tokrange 0 9 "Expected \[0..9\]"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected \[a..f\] (got EOF)"
+ if {$ok} {ict_match_tokrange a f "Expected \[a..f\]"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected \[A..F\] (got EOF)"
+ if {$ok} {ict_match_tokrange A F "Expected \[A..F\]"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Ident {} {
+ # Ident = (x (/ (t _)
+ # (t :)
+ # (alpha))
+ # (* (/ (t _)
+ # (t :)
+ # (alnum))))
+
+ variable ok
+ if {[inc_restore Ident]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq41 ; # (x (/ (t _)
+ # (t :)
+ # (alpha))
+ # (* (/ (t _)
+ # (t :)
+ # (alnum))))
+
+ isv_nonterminal_range Ident $pos
+ inc_save Ident $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected Ident" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq41 {} {
+
+ # (x (/ (t _)
+ # (t :)
+ # (alpha))
+ # (* (/ (t _)
+ # (t :)
+ # (alnum))))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebra38 ; # (/ (t _)
+ # (t :)
+ # (alpha))
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ekleene40 ; # (* (/ (t _)
+ # (t :)
+ # (alnum)))
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::ebra38 {} {
+
+ # (/ (t _)
+ # (t :)
+ # (alpha))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected _ (got EOF)"
+ if {$ok} {ict_match_token _ "Expected _"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected : (got EOF)"
+ if {$ok} {ict_match_token : "Expected :"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected <alpha> (got EOF)"
+ if {$ok} {ict_match_tokclass alpha "Expected <alpha>"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::peg::ekleene40 {} {
+
+ # (* (/ (t _)
+ # (t :)
+ # (alnum)))
+
+ variable ok
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebra39 ; # (/ (t _)
+ # (t :)
+ # (alnum))
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::ebra39 {} {
+
+ # (/ (t _)
+ # (t :)
+ # (alnum))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected _ (got EOF)"
+ if {$ok} {ict_match_token _ "Expected _"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected : (got EOF)"
+ if {$ok} {ict_match_token : "Expected :"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected <alnum> (got EOF)"
+ if {$ok} {ict_match_tokclass alnum "Expected <alnum>"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Identifier {} {
+ # Identifier = (x (n Ident)
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore Identifier]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq37 ; # (x (n Ident)
+ # (n SPACE))
+
+ isv_nonterminal_reduce Identifier $pos $mrk
+ inc_save Identifier $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal "Expected Identifier" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq37 {} {
+
+ # (x (n Ident)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Ident ; # (n Ident)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_IS {} {
+ # IS = (x (t <)
+ # (t -)
+ # (n SPACE))
+
+ if {[inc_restore IS]} return
+
+ set pos [icl_get]
+
+ eseq58 ; # (x (t <)
+ # (t -)
+ # (n SPACE))
+
+ isv_clear
+ inc_save IS $pos
+ ier_nonterminal "Expected IS" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq58 {} {
+
+ # (x (t <)
+ # (t -)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected < (got EOF)"
+ if {$ok} {ict_match_token < "Expected <"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected - (got EOF)"
+ if {$ok} {ict_match_token - "Expected -"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_LEAF {} {
+ # LEAF = (x (t l)
+ # (t e)
+ # (t a)
+ # (t f)
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore LEAF]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq60 ; # (x (t l)
+ # (t e)
+ # (t a)
+ # (t f)
+ # (n SPACE))
+
+ isv_nonterminal_leaf LEAF $pos
+ inc_save LEAF $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected LEAF" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq60 {} {
+
+ # (x (t l)
+ # (t e)
+ # (t a)
+ # (t f)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected l (got EOF)"
+ if {$ok} {ict_match_token l "Expected l"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected e (got EOF)"
+ if {$ok} {ict_match_token e "Expected e"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected a (got EOF)"
+ if {$ok} {ict_match_token a "Expected a"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected f (got EOF)"
+ if {$ok} {ict_match_token f "Expected f"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Literal {} {
+ # Literal = (/ (x (n APOSTROPH)
+ # (* (x (! (n APOSTROPH))
+ # (n Char)))
+ # (n APOSTROPH)
+ # (n SPACE))
+ # (x (n DAPOSTROPH)
+ # (* (x (! (n DAPOSTROPH))
+ # (n Char)))
+ # (n DAPOSTROPH)
+ # (n SPACE)))
+
+ variable ok
+ if {[inc_restore Literal]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ ebra28 ; # (/ (x (n APOSTROPH)
+ # (* (x (! (n APOSTROPH))
+ # (n Char)))
+ # (n APOSTROPH)
+ # (n SPACE))
+ # (x (n DAPOSTROPH)
+ # (* (x (! (n DAPOSTROPH))
+ # (n Char)))
+ # (n DAPOSTROPH)
+ # (n SPACE)))
+
+ isv_nonterminal_reduce Literal $pos $mrk
+ inc_save Literal $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal "Expected Literal" $pos
+ return
+}
+
+proc ::page::parse::peg::ebra28 {} {
+
+ # (/ (x (n APOSTROPH)
+ # (* (x (! (n APOSTROPH))
+ # (n Char)))
+ # (n APOSTROPH)
+ # (n SPACE))
+ # (x (n DAPOSTROPH)
+ # (* (x (! (n DAPOSTROPH))
+ # (n Char)))
+ # (n DAPOSTROPH)
+ # (n SPACE)))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ eseq23 ; # (x (n APOSTROPH)
+ # (* (x (! (n APOSTROPH))
+ # (n Char)))
+ # (n APOSTROPH)
+ # (n SPACE))
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ eseq27 ; # (x (n DAPOSTROPH)
+ # (* (x (! (n DAPOSTROPH))
+ # (n Char)))
+ # (n DAPOSTROPH)
+ # (n SPACE))
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::peg::eseq23 {} {
+
+ # (x (n APOSTROPH)
+ # (* (x (! (n APOSTROPH))
+ # (n Char)))
+ # (n APOSTROPH)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_APOSTROPH ; # (n APOSTROPH)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ ekleene22 ; # (* (x (! (n APOSTROPH))
+ # (n Char)))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_APOSTROPH ; # (n APOSTROPH)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::ekleene22 {} {
+
+ # (* (x (! (n APOSTROPH))
+ # (n Char)))
+
+ variable ok
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ eseq21 ; # (x (! (n APOSTROPH))
+ # (n Char))
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::eseq21 {} {
+
+ # (x (! (n APOSTROPH))
+ # (n Char))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebang20
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Char ; # (n Char)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::ebang20 {} {
+ set pos [icl_get]
+
+ matchSymbol_APOSTROPH ; # (n APOSTROPH)
+
+ icl_rewind $pos
+ iok_negate
+ return
+}
+
+proc ::page::parse::peg::eseq27 {} {
+
+ # (x (n DAPOSTROPH)
+ # (* (x (! (n DAPOSTROPH))
+ # (n Char)))
+ # (n DAPOSTROPH)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_DAPOSTROPH ; # (n DAPOSTROPH)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ ekleene26 ; # (* (x (! (n DAPOSTROPH))
+ # (n Char)))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_DAPOSTROPH ; # (n DAPOSTROPH)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::ekleene26 {} {
+
+ # (* (x (! (n DAPOSTROPH))
+ # (n Char)))
+
+ variable ok
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ eseq25 ; # (x (! (n DAPOSTROPH))
+ # (n Char))
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::eseq25 {} {
+
+ # (x (! (n DAPOSTROPH))
+ # (n Char))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebang24
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Char ; # (n Char)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::ebang24 {} {
+ set pos [icl_get]
+
+ matchSymbol_DAPOSTROPH ; # (n DAPOSTROPH)
+
+ icl_rewind $pos
+ iok_negate
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_MATCH {} {
+ # MATCH = (x (t m)
+ # (t a)
+ # (t t)
+ # (t c)
+ # (t h)
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore MATCH]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq61 ; # (x (t m)
+ # (t a)
+ # (t t)
+ # (t c)
+ # (t h)
+ # (n SPACE))
+
+ isv_nonterminal_leaf MATCH $pos
+ inc_save MATCH $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected MATCH" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq61 {} {
+
+ # (x (t m)
+ # (t a)
+ # (t t)
+ # (t c)
+ # (t h)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected m (got EOF)"
+ if {$ok} {ict_match_token m "Expected m"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected a (got EOF)"
+ if {$ok} {ict_match_token a "Expected a"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected t (got EOF)"
+ if {$ok} {ict_match_token t "Expected t"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected c (got EOF)"
+ if {$ok} {ict_match_token c "Expected c"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected h (got EOF)"
+ if {$ok} {ict_match_token h "Expected h"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_NOT {} {
+ # NOT = (x (t !)
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore NOT]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq67 ; # (x (t !)
+ # (n SPACE))
+
+ isv_nonterminal_leaf NOT $pos
+ inc_save NOT $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected NOT" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq67 {} {
+
+ # (x (t !)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected ! (got EOF)"
+ if {$ok} {ict_match_token ! "Expected !"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_OPEN {} {
+ # OPEN = (x (t \()
+ # (n SPACE))
+
+ if {[inc_restore OPEN]} return
+
+ set pos [icl_get]
+
+ eseq71 ; # (x (t \()
+ # (n SPACE))
+
+ isv_clear
+ inc_save OPEN $pos
+ ier_nonterminal "Expected OPEN" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq71 {} {
+
+ # (x (t \()
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected \( (got EOF)"
+ if {$ok} {ict_match_token \50 "Expected \("}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_OPENB {} {
+ # OPENB = (t [)
+
+ variable ok
+ if {[inc_restore OPENB]} return
+
+ set pos [icl_get]
+
+ ict_advance "Expected \[ (got EOF)"
+ if {$ok} {ict_match_token \133 "Expected \["}
+
+ isv_clear
+ inc_save OPENB $pos
+ ier_nonterminal "Expected OPENB" $pos
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_PEG {} {
+ # PEG = (x (t P)
+ # (t E)
+ # (t G)
+ # (n SPACE))
+
+ if {[inc_restore PEG]} return
+
+ set pos [icl_get]
+
+ eseq57 ; # (x (t P)
+ # (t E)
+ # (t G)
+ # (n SPACE))
+
+ isv_clear
+ inc_save PEG $pos
+ ier_nonterminal "Expected PEG" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq57 {} {
+
+ # (x (t P)
+ # (t E)
+ # (t G)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected P (got EOF)"
+ if {$ok} {ict_match_token P "Expected P"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected E (got EOF)"
+ if {$ok} {ict_match_token E "Expected E"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected G (got EOF)"
+ if {$ok} {ict_match_token G "Expected G"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_PLUS {} {
+ # PLUS = (x (t +)
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore PLUS]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq70 ; # (x (t +)
+ # (n SPACE))
+
+ isv_nonterminal_leaf PLUS $pos
+ inc_save PLUS $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected PLUS" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq70 {} {
+
+ # (x (t +)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected + (got EOF)"
+ if {$ok} {ict_match_token + "Expected +"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Prefix {} {
+ # Prefix = (x (? (/ (n AND)
+ # (n NOT)))
+ # (n Suffix))
+
+ variable ok
+ if {[inc_restore Prefix]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq14 ; # (x (? (/ (n AND)
+ # (n NOT)))
+ # (n Suffix))
+
+ isv_nonterminal_reduce Prefix $pos $mrk
+ inc_save Prefix $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal "Expected Prefix" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq14 {} {
+
+ # (x (? (/ (n AND)
+ # (n NOT)))
+ # (n Suffix))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ eopt13 ; # (? (/ (n AND)
+ # (n NOT)))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_Suffix ; # (n Suffix)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::eopt13 {} {
+
+ # (? (/ (n AND)
+ # (n NOT)))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebra12 ; # (/ (n AND)
+ # (n NOT))
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::ebra12 {} {
+
+ # (/ (n AND)
+ # (n NOT))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_AND ; # (n AND)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_NOT ; # (n NOT)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Primary {} {
+ # Primary = (/ (n ALNUM)
+ # (n ALPHA)
+ # (n Identifier)
+ # (x (n OPEN)
+ # (n Expression)
+ # (n CLOSE))
+ # (n Literal)
+ # (n Class)
+ # (n DOT))
+
+ variable ok
+ if {[inc_restore Primary]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ ebra19 ; # (/ (n ALNUM)
+ # (n ALPHA)
+ # (n Identifier)
+ # (x (n OPEN)
+ # (n Expression)
+ # (n CLOSE))
+ # (n Literal)
+ # (n Class)
+ # (n DOT))
+
+ isv_nonterminal_reduce Primary $pos $mrk
+ inc_save Primary $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal "Expected Primary" $pos
+ return
+}
+
+proc ::page::parse::peg::ebra19 {} {
+
+ # (/ (n ALNUM)
+ # (n ALPHA)
+ # (n Identifier)
+ # (x (n OPEN)
+ # (n Expression)
+ # (n CLOSE))
+ # (n Literal)
+ # (n Class)
+ # (n DOT))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_ALNUM ; # (n ALNUM)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_ALPHA ; # (n ALPHA)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Identifier ; # (n Identifier)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ eseq18 ; # (x (n OPEN)
+ # (n Expression)
+ # (n CLOSE))
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Literal ; # (n Literal)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Class ; # (n Class)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_DOT ; # (n DOT)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::peg::eseq18 {} {
+
+ # (x (n OPEN)
+ # (n Expression)
+ # (n CLOSE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_OPEN ; # (n OPEN)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Expression ; # (n Expression)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_CLOSE ; # (n CLOSE)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_QUESTION {} {
+ # QUESTION = (x (t ?)
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore QUESTION]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq68 ; # (x (t ?)
+ # (n SPACE))
+
+ isv_nonterminal_leaf QUESTION $pos
+ inc_save QUESTION $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected QUESTION" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq68 {} {
+
+ # (x (t ?)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected ? (got EOF)"
+ if {$ok} {ict_match_token ? "Expected ?"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Range {} {
+ # Range = (/ (x (n Char)
+ # (n TO)
+ # (n Char))
+ # (n Char))
+
+ variable ok
+ if {[inc_restore Range]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ ebra34 ; # (/ (x (n Char)
+ # (n TO)
+ # (n Char))
+ # (n Char))
+
+ isv_nonterminal_reduce Range $pos $mrk
+ inc_save Range $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal "Expected Range" $pos
+ return
+}
+
+proc ::page::parse::peg::ebra34 {} {
+
+ # (/ (x (n Char)
+ # (n TO)
+ # (n Char))
+ # (n Char))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ eseq33 ; # (x (n Char)
+ # (n TO)
+ # (n Char))
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_Char ; # (n Char)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::peg::eseq33 {} {
+
+ # (x (n Char)
+ # (n TO)
+ # (n Char))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Char ; # (n Char)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_TO ; # (n TO)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_Char ; # (n Char)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_SEMICOLON {} {
+ # SEMICOLON = (x (t ;)
+ # (n SPACE))
+
+ if {[inc_restore SEMICOLON]} return
+
+ set pos [icl_get]
+
+ eseq63 ; # (x (t ;)
+ # (n SPACE))
+
+ isv_clear
+ inc_save SEMICOLON $pos
+ ier_nonterminal "Expected SEMICOLON" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq63 {} {
+
+ # (x (t ;)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected \; (got EOF)"
+ if {$ok} {ict_match_token \73 "Expected \;"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Sequence {} {
+ # Sequence = (+ (n Prefix))
+
+ variable ok
+ if {[inc_restore Sequence]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ epkleene11 ; # (+ (n Prefix))
+
+ isv_nonterminal_reduce Sequence $pos $mrk
+ inc_save Sequence $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal "Expected Sequence" $pos
+ return
+}
+
+proc ::page::parse::peg::epkleene11 {} {
+
+ # (+ (n Prefix))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Prefix ; # (n Prefix)
+ ier_merge $old
+
+ if {!$ok} {
+ icl_rewind $pos
+ return
+ }
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_Prefix ; # (n Prefix)
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_SLASH {} {
+ # SLASH = (x (t /)
+ # (n SPACE))
+
+ if {[inc_restore SLASH]} return
+
+ set pos [icl_get]
+
+ eseq65 ; # (x (t /)
+ # (n SPACE))
+
+ isv_clear
+ inc_save SLASH $pos
+ ier_nonterminal "Expected SLASH" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq65 {} {
+
+ # (x (t /)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected / (got EOF)"
+ if {$ok} {ict_match_token / "Expected /"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_SPACE {} {
+ # SPACE = (* (/ (t <blank>)
+ # (t \t)
+ # (n EOL)
+ # (n COMMENT)))
+
+ if {[inc_restore SPACE]} return
+
+ set pos [icl_get]
+
+ ekleene77 ; # (* (/ (t <blank>)
+ # (t \t)
+ # (n EOL)
+ # (n COMMENT)))
+
+ isv_clear
+ inc_save SPACE $pos
+ ier_nonterminal "Expected SPACE" $pos
+ return
+}
+
+proc ::page::parse::peg::ekleene77 {} {
+
+ # (* (/ (t <blank>)
+ # (t \t)
+ # (n EOL)
+ # (n COMMENT)))
+
+ variable ok
+
+ while {1} {
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebra76 ; # (/ (t <blank>)
+ # (t \t)
+ # (n EOL)
+ # (n COMMENT))
+ ier_merge $old
+
+ if {$ok} continue
+ break
+ }
+
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::ebra76 {} {
+
+ # (/ (t <blank>)
+ # (t \t)
+ # (n EOL)
+ # (n COMMENT))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected <blank> (got EOF)"
+ if {$ok} {ict_match_token \40 "Expected <blank>"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ ict_advance "Expected \\t (got EOF)"
+ if {$ok} {ict_match_token \t "Expected \\t"}
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ matchSymbol_EOL ; # (n EOL)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ set old [ier_get]
+ matchSymbol_COMMENT ; # (n COMMENT)
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_STAR {} {
+ # STAR = (x (t *)
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore STAR]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq69 ; # (x (t *)
+ # (n SPACE))
+
+ isv_nonterminal_leaf STAR $pos
+ inc_save STAR $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected STAR" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq69 {} {
+
+ # (x (t *)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected * (got EOF)"
+ if {$ok} {ict_match_token * "Expected *"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_StartExpr {} {
+ # StartExpr = (x (n OPEN)
+ # (n Expression)
+ # (n CLOSE))
+
+ variable ok
+ if {[inc_restore StartExpr]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq35 ; # (x (n OPEN)
+ # (n Expression)
+ # (n CLOSE))
+
+ isv_nonterminal_reduce StartExpr $pos $mrk
+ inc_save StartExpr $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal "Expected StartExpr" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq35 {} {
+
+ # (x (n OPEN)
+ # (n Expression)
+ # (n CLOSE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ matchSymbol_OPEN ; # (n OPEN)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Expression ; # (n Expression)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ matchSymbol_CLOSE ; # (n CLOSE)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_Suffix {} {
+ # Suffix = (x (n Primary)
+ # (? (/ (n QUESTION)
+ # (n STAR)
+ # (n PLUS))))
+
+ variable ok
+ if {[inc_restore Suffix]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+ set mrk [ias_mark]
+
+ eseq17 ; # (x (n Primary)
+ # (? (/ (n QUESTION)
+ # (n STAR)
+ # (n PLUS))))
+
+ isv_nonterminal_reduce Suffix $pos $mrk
+ inc_save Suffix $pos
+ ias_pop2mark $mrk
+ if {$ok} ias_push
+ ier_nonterminal "Expected Suffix" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq17 {} {
+
+ # (x (n Primary)
+ # (? (/ (n QUESTION)
+ # (n STAR)
+ # (n PLUS))))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+
+ set old [ier_get]
+ matchSymbol_Primary ; # (n Primary)
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ set old [ier_get]
+ eopt16 ; # (? (/ (n QUESTION)
+ # (n STAR)
+ # (n PLUS)))
+ ier_merge $old
+
+ if {!$ok} {
+ ias_pop2mark $mrk
+ icl_rewind $pos
+ return
+ }
+
+ return
+}
+
+proc ::page::parse::peg::eopt16 {} {
+
+ # (? (/ (n QUESTION)
+ # (n STAR)
+ # (n PLUS)))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ebra15 ; # (/ (n QUESTION)
+ # (n STAR)
+ # (n PLUS))
+ ier_merge $old
+
+ if {$ok} return
+ icl_rewind $pos
+ iok_ok
+ return
+}
+
+proc ::page::parse::peg::ebra15 {} {
+
+ # (/ (n QUESTION)
+ # (n STAR)
+ # (n PLUS))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_QUESTION ; # (n QUESTION)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_STAR ; # (n STAR)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ set mrk [ias_mark]
+ set old [ier_get]
+ matchSymbol_PLUS ; # (n PLUS)
+ ier_merge $old
+
+ if {$ok} return
+ ias_pop2mark $mrk
+ icl_rewind $pos
+
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_TO {} {
+ # TO = (t -)
+
+ variable ok
+ if {[inc_restore TO]} return
+
+ set pos [icl_get]
+
+ ict_advance "Expected - (got EOF)"
+ if {$ok} {ict_match_token - "Expected -"}
+
+ isv_clear
+ inc_save TO $pos
+ ier_nonterminal "Expected TO" $pos
+ return
+}
+
+proc ::page::parse::peg::matchSymbol_VOID {} {
+ # VOID = (x (t v)
+ # (t o)
+ # (t i)
+ # (t d)
+ # (n SPACE))
+
+ variable ok
+ if {[inc_restore VOID]} {
+ if {$ok} ias_push
+ return
+ }
+
+ set pos [icl_get]
+
+ eseq59 ; # (x (t v)
+ # (t o)
+ # (t i)
+ # (t d)
+ # (n SPACE))
+
+ isv_nonterminal_leaf VOID $pos
+ inc_save VOID $pos
+ if {$ok} ias_push
+ ier_nonterminal "Expected VOID" $pos
+ return
+}
+
+proc ::page::parse::peg::eseq59 {} {
+
+ # (x (t v)
+ # (t o)
+ # (t i)
+ # (t d)
+ # (n SPACE))
+
+ variable ok
+
+ set pos [icl_get]
+
+ set old [ier_get]
+ ict_advance "Expected v (got EOF)"
+ if {$ok} {ict_match_token v "Expected v"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected o (got EOF)"
+ if {$ok} {ict_match_token o "Expected o"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected i (got EOF)"
+ if {$ok} {ict_match_token i "Expected i"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ ict_advance "Expected d (got EOF)"
+ if {$ok} {ict_match_token d "Expected d"}
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ set old [ier_get]
+ matchSymbol_SPACE ; # (n SPACE)
+ ier_merge $old
+
+ if {!$ok} {icl_rewind $pos ; return}
+
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Package Management
+
+package provide page::parse::peg 0.1
diff --git a/tcllib/modules/page/parse_peghb.tcl b/tcllib/modules/page/parse_peghb.tcl
new file mode 100644
index 0000000..ba9fab4
--- /dev/null
+++ b/tcllib/modules/page/parse_peghb.tcl
@@ -0,0 +1,118 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Parser Generator / Frontend - Read halfbaked PEG container.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+namespace eval ::page::parse::peghb {
+ variable fixup {}
+ variable definitions
+}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::parse::peghb {halfbaked t} {
+ variable peghb::fixup
+ variable peghb::definitions
+ array set definitions {}
+
+ set fixup {}
+
+ interp create -safe sb
+ # Should remove everything.
+ interp alias sb Start {} ::page::parse::peghb::Start $t
+ interp alias sb Define {} ::page::parse::peghb::Define $t
+ interp eval sb $halfbaked
+ interp delete sb
+
+ array set undefined {}
+ array set users {}
+ foreach {n sym} $fixup {
+ if {[info exists definitions($sym)]} {
+ set def $definitions($sym)
+ $t set $n def $def
+ lappend users($def) $n
+ } else {
+ lappend undefined($sym) $n
+ }
+ }
+
+ foreach def [array names users] {
+ $t set $def users $users($def)
+ }
+
+ $t set root definitions [array get definitions]
+ $t set root undefined [array get undefined]
+ $t set root symbol <StartExpression>
+ $t set root name <HalfBaked>
+
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Helpers
+
+proc ::page::parse::peghb::Start {t pe} {
+ variable fixup
+ $t set root start [treeOf $t root $pe fixup]
+ return
+}
+
+proc ::page::parse::peghb::Define {t mode sym pe} {
+ variable fixup
+ variable definitions
+
+ set def [$t insert root end]
+
+ $t set $def users {}
+ $t set $def symbol $sym
+ $t set $def label $sym
+ $t set $def mode $mode
+
+ treeOf $t $def $pe fixup
+
+ set definitions($sym) $def
+ return
+}
+
+proc ::page::parse::peghb::treeOf {t root pe fv} {
+ upvar 1 $fv fixup
+
+ set n [$t insert $root end]
+ set op [lindex $pe 0]
+ $t set $n op $op
+
+ if {$op eq "t"} {
+ $t set $n char [lindex $pe 1]
+
+ } elseif {$op eq ".."} {
+ $t set $n begin [lindex $pe 1]
+ $t set $n end [lindex $pe 2]
+
+ } elseif {$op eq "n"} {
+
+ set sym [lindex $pe 1]
+ $t set $n sym $sym
+ $t set $n def ""
+
+ lappend fixup $n $sym
+ } else {
+ foreach sub [lrange $pe 1 end] {
+ treeOf $t $n $sub fixup
+ }
+ }
+ return $n
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Strings.
+
+namespace eval ::page::parse::peghb {}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::parse::peghb 0.1
diff --git a/tcllib/modules/page/parse_pegser.tcl b/tcllib/modules/page/parse_pegser.tcl
new file mode 100644
index 0000000..b3814a7
--- /dev/null
+++ b/tcllib/modules/page/parse_pegser.tcl
@@ -0,0 +1,99 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Parser Generator / Frontend - Read serialized PEG container.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require grammar::peg
+
+namespace eval ::page::parse::pegser {}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::parse::pegser {serial t} {
+
+ ::grammar::peg gr deserialize $serial
+
+ $t set root start [pegser::treeOf $t root [gr start] fixup]
+
+ array set definitions {}
+ foreach sym [gr nonterminals] {
+ set def [$t insert root end]
+
+ $t set $def users {}
+ $t set $def symbol $sym
+ $t set $def label $sym
+ $t set $def mode [gr nonterminal mode $sym]
+ pegser::treeOf $t $def [gr nonterminal rule $sym] fixup
+
+ set definitions($sym) $def
+ }
+
+ array set undefined {}
+ array set users {}
+ foreach {n sym} $fixup {
+ if {[info exists definitions($sym)]} {
+ set def $definitions($sym)
+ $t set $n def $def
+ lappend users($def) $n
+ } else {
+ lappend undefined($sym) $n
+ }
+ }
+
+ foreach def [array names users] {
+ $t set $def users $users($def)
+ }
+
+ $t set root definitions [array get definitions]
+ $t set root undefined [array get undefined]
+ $t set root symbol <StartExpression>
+ $t set root name <Serialization>
+
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Helpers
+
+proc ::page::parse::pegser::treeOf {t root pe fv} {
+ upvar 1 $fv fixup
+
+ set n [$t insert $root end]
+ set op [lindex $pe 0]
+ $t set $n op $op
+
+ if {$op eq "t"} {
+ $t set $n char [lindex $pe 1]
+
+ } elseif {$op eq ".."} {
+ $t set $n begin [lindex $pe 1]
+ $t set $n end [lindex $pe 2]
+
+ } elseif {$op eq "n"} {
+
+ set sym [lindex $pe 1]
+ $t set $n sym $sym
+ $t set $n def ""
+
+ lappend fixup $n $sym
+ } else {
+ foreach sub [lrange $pe 1 end] {
+ treeOf $t $n $sub fixup
+ }
+ }
+ return $n
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Strings.
+
+namespace eval ::page::parse::pegser {}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::parse::pegser 0.1
diff --git a/tcllib/modules/page/peg_grammar.peg b/tcllib/modules/page/peg_grammar.peg
new file mode 100644
index 0000000..8ae4068
--- /dev/null
+++ b/tcllib/modules/page/peg_grammar.peg
@@ -0,0 +1,86 @@
+# -*- text -*-
+#
+# Parsing Expression Grammar declaring a syntax for Parsing Expression
+# Grammars, to use in a PEG-based parser generator. This specification
+# is self-referential, it uses the grammar described by to describe
+# said grammar.
+
+PEG pg::peg::grammar (Grammar)
+
+ # --------------------------------------------------------------------
+ # Syntactical constructs
+
+ Grammar <- SPACE Header Definition+ Final EOF ;
+
+ Header <- PEG Identifier StartExpr ;
+ Definition <- Attribute? Identifier IS Expression SEMICOLON ;
+ Attribute <- (VOID / LEAF / MATCH) COLON ;
+ Expression <- Sequence (SLASH Sequence)* ;
+ Sequence <- Prefix+ ;
+ Prefix <- (AND / NOT)? Suffix ;
+ Suffix <- Primary (QUESTION / STAR / PLUS)? ;
+ Primary <- ALNUM / ALPHA / Identifier
+ / OPEN Expression CLOSE
+ / Literal
+ / Class
+ / DOT
+ ;
+ Literal <- APOSTROPH (!APOSTROPH Char)* APOSTROPH SPACE
+ / DAPOSTROPH (!DAPOSTROPH Char)* DAPOSTROPH SPACE ;
+ Class <- OPENB (!CLOSEB Range)* CLOSEB SPACE ;
+ Range <- Char TO Char / Char ;
+
+ StartExpr <- OPEN Expression CLOSE ;
+void: Final <- END SEMICOLON SPACE ;
+
+ # --------------------------------------------------------------------
+ # Lexing constructs
+
+ Identifier <- Ident SPACE ;
+match: Ident <- ('_' / ':' / <alpha>) ('_' / ':' / <alnum>)* ;
+ Char <- CharSpecial / CharOctalFull / CharOctalPart
+ / CharUnicode / CharUnescaped
+ ;
+
+match: CharSpecial <- "\\" [nrt'"\[\]\\] ;
+match: CharOctalFull <- "\\" [0-2][0-7][0-7] ;
+match: CharOctalPart <- "\\" [0-7][0-7]? ;
+match: CharUnicode <- "\\" 'u' HexDigit (HexDigit (HexDigit HexDigit?)?)? ;
+match: CharUnescaped <- !"\\" . ;
+
+void: HexDigit <- [0-9a-fA-F] ;
+
+void: TO <- '-' ;
+void: OPENB <- "[" ;
+void: CLOSEB <- "]" ;
+void: APOSTROPH <- "'" ;
+void: DAPOSTROPH <- '"' ;
+void: PEG <- "PEG" SPACE ;
+void: IS <- "<-" SPACE ;
+leaf: VOID <- "void" SPACE ; # Implies that definition has no semantic value.
+leaf: LEAF <- "leaf" SPACE ; # Implies that definition has no terminals.
+leaf: MATCH <- "match" SPACE ; # Implies that semantic value is the matched string,
+ # not the parse tree from the symbol.
+void: END <- "END" SPACE ;
+void: SEMICOLON <- ";" SPACE ;
+void: COLON <- ":" SPACE ;
+void: SLASH <- "/" SPACE ;
+leaf: AND <- "&" SPACE ;
+leaf: NOT <- "!" SPACE ;
+leaf: QUESTION <- "?" SPACE ;
+leaf: STAR <- "*" SPACE ;
+leaf: PLUS <- "+" SPACE ;
+void: OPEN <- "(" SPACE ;
+void: CLOSE <- ")" SPACE ;
+leaf: DOT <- "." SPACE ;
+leaf: ALPHA <- "<alpha>" SPACE ;
+leaf: ALNUM <- "<alnum>" SPACE ;
+
+void: SPACE <- (" " / "\t" / EOL / COMMENT)* ;
+void: COMMENT <- '#' (!EOL .)* EOL ;
+void: EOL <- "\n\r" / "\n" / "\r" ;
+void: EOF <- !. ;
+
+ # --------------------------------------------------------------------
+END;
+
diff --git a/tcllib/modules/page/peg_grammar.tcl b/tcllib/modules/page/peg_grammar.tcl
new file mode 100644
index 0000000..b585125
--- /dev/null
+++ b/tcllib/modules/page/peg_grammar.tcl
@@ -0,0 +1,117 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Parser Generator / Grammar for reading of PE grammars
+
+## Parsing Expression Grammar 'pg::peg::grammar'.
+
+# ### ### ### ######### ######### #########
+## Package description
+
+## It provides a single command returning the handle of a
+## grammar container in which the grammar 'pg::peg::grammar'
+## is stored. The container is usable by a PEG interpreter
+## or other packages taking PE grammars.
+
+# ### ### ### ######### ######### #########
+## Requisites.
+## - PEG container type
+
+package require grammar::peg
+
+namespace eval ::pg::peg::grammar {}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::pg::peg::grammar {} {
+ return $grammar::gr
+}
+
+# ### ### ### ######### ######### #########
+# ### ### ### ######### ######### #########
+## Data and helpers.
+
+namespace eval ::pg::peg::grammar {
+ # Grammar container
+ variable gr [::grammar::peg gr]
+}
+
+proc ::pg::peg::grammar::Start {pe} {
+ variable gr
+ $gr start $pe
+ return
+}
+
+proc ::pg::peg::grammar::Define {mode nt pe} {
+ variable gr
+ $gr nonterminal add $nt $pe
+ $gr nonterminal mode $nt $mode
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Initialization = Grammar definition
+
+namespace eval ::pg::peg::grammar {
+ Start {n Grammar}
+
+ Define leaf ALNUM {x {t <} {t a} {t l} {t n} {t u} {t m} {t >} {n SPACE}}
+ Define leaf ALPHA {x {t <} {t a} {t l} {t p} {t h} {t a} {t >} {n SPACE}}
+ Define leaf AND {x {t &} {n SPACE}}
+ Define discard APOSTROPH {t '}
+ Define value Attribute {x {/ {n VOID} {n LEAF} {n MATCH}} {n COLON}}
+ Define value Char {/ {n CharSpecial} {n CharOctalFull} {n CharOctalPart} {n CharUnicode} {n CharUnescaped}}
+ Define match CharOctalFull {x {t \134} {.. 0 2} {.. 0 7} {.. 0 7}}
+ Define match CharOctalPart {x {t \134} {.. 0 7} {? {.. 0 7}}}
+ Define match CharSpecial {x {t \134} {/ {t n} {t r} {t t} {t '} {t \42} {t \133} {t \135} {t \134}}}
+ Define match CharUnescaped {x {! {t \134}} dot}
+ Define match CharUnicode {x {t \134} {t u} {n HexDigit} {? {x {n HexDigit} {? {x {n HexDigit} {? {n HexDigit}}}}}}}
+ Define value Class {x {n OPENB} {* {x {! {n CLOSEB}} {n Range}}} {n CLOSEB} {n SPACE}}
+ Define discard CLOSE {x {t \51} {n SPACE}}
+ Define discard CLOSEB {t \135}
+ Define discard COLON {x {t :} {n SPACE}}
+ Define discard COMMENT {x {t #} {* {x {! {n EOL}} dot}} {n EOL}}
+ Define discard DAPOSTROPH {t \42}
+ Define value Definition {x {? {n Attribute}} {n Identifier} {n IS} {n Expression} {n SEMICOLON}}
+ Define leaf DOT {x {t .} {n SPACE}}
+ Define discard END {x {t E} {t N} {t D} {n SPACE}}
+ Define discard EOF {! dot}
+ Define discard EOL {/ {x {t \n} {t \r}} {t \n} {t \r}}
+ Define value Expression {x {n Sequence} {* {x {n SLASH} {n Sequence}}}}
+ Define discard Final {x {n END} {n SEMICOLON} {n SPACE}}
+ Define value Grammar {x {n SPACE} {n Header} {+ {n Definition}} {n Final} {n EOF}}
+ Define value Header {x {n PEG} {n Identifier} {n StartExpr}}
+ Define discard HexDigit {/ {.. 0 9} {.. a f} {.. A F}}
+ Define match Ident {x {/ {t _} {t :} alpha} {* {/ {t _} {t :} alnum}}}
+ Define value Identifier {x {n Ident} {n SPACE}}
+ Define discard IS {x {t <} {t -} {n SPACE}}
+ Define leaf LEAF {x {t l} {t e} {t a} {t f} {n SPACE}}
+ Define value Literal {/ {x {n APOSTROPH} {* {x {! {n APOSTROPH}} {n Char}}} {n APOSTROPH} {n SPACE}} {x {n DAPOSTROPH} {* {x {! {n DAPOSTROPH}} {n Char}}} {n DAPOSTROPH} {n SPACE}}}
+ Define leaf MATCH {x {t m} {t a} {t t} {t c} {t h} {n SPACE}}
+ Define leaf NOT {x {t !} {n SPACE}}
+ Define discard OPEN {x {t \50} {n SPACE}}
+ Define discard OPENB {t \133}
+ Define discard PEG {x {t P} {t E} {t G} {n SPACE}}
+ Define leaf PLUS {x {t +} {n SPACE}}
+ Define value Prefix {x {? {/ {n AND} {n NOT}}} {n Suffix}}
+ Define value Primary {/ {n ALNUM} {n ALPHA} {n Identifier} {x {n OPEN} {n Expression} {n CLOSE}} {n Literal} {n Class} {n DOT}}
+ Define leaf QUESTION {x {t ?} {n SPACE}}
+ Define value Range {/ {x {n Char} {n TO} {n Char}} {n Char}}
+ Define discard SEMICOLON {x {t \73} {n SPACE}}
+ Define value Sequence {+ {n Prefix}}
+ Define discard SLASH {x {t /} {n SPACE}}
+ Define discard SPACE {* {/ {t \40} {t \t} {n EOL} {n COMMENT}}}
+ Define leaf STAR {x {t *} {n SPACE}}
+ Define value StartExpr {x {n OPEN} {n Expression} {n CLOSE}}
+ Define value Suffix {x {n Primary} {? {/ {n QUESTION} {n STAR} {n PLUS}}}}
+ Define discard TO {t -}
+ Define leaf VOID {x {t v} {t o} {t i} {t d} {n SPACE}}
+}
+
+# ### ### ### ######### ######### #########
+## Package Management - Ready
+
+# @sak notprovided pg::peg::grammar
+package provide pg::peg::grammar 0.1
+
diff --git a/tcllib/modules/page/pkgIndex.tcl b/tcllib/modules/page/pkgIndex.tcl
new file mode 100644
index 0000000..71cb403
--- /dev/null
+++ b/tcllib/modules/page/pkgIndex.tcl
@@ -0,0 +1,80 @@
+# -- PAGE application packages --
+# -- ---- plugin management
+
+package ifneeded page::pluginmgr 0.2 [list source [file join $dir pluginmgr.tcl]]
+
+# -- PAGE plugin packages
+# -- ---- Canned configurations
+
+package ifneeded page::config::peg 0.1 [list source [file join $dir plugins/config_peg.tcl]]
+
+# -- PAGE plugin packages
+# -- ---- Readers
+
+package ifneeded page::reader::peg 0.1 [list source [file join $dir plugins/reader_peg.tcl]]
+package ifneeded page::reader::lemon 0.1 [list source [file join $dir plugins/reader_lemon.tcl]]
+package ifneeded page::reader::hb 0.1 [list source [file join $dir plugins/reader_hb.tcl]]
+package ifneeded page::reader::ser 0.1 [list source [file join $dir plugins/reader_ser.tcl]]
+package ifneeded page::reader::treeser 0.1 [list source [file join $dir plugins/reader_treeser.tcl]]
+
+# -- PAGE plugin packages
+# -- ---- Writers
+
+package ifneeded page::writer::null 0.1 [list source [file join $dir plugins/writer_null.tcl]]
+package ifneeded page::writer::me 0.1 [list source [file join $dir plugins/writer_me.tcl]]
+package ifneeded page::writer::mecpu 0.1.1 [list source [file join $dir plugins/writer_mecpu.tcl]]
+package ifneeded page::writer::tree 0.1 [list source [file join $dir plugins/writer_tree.tcl]]
+package ifneeded page::writer::tpc 0.1 [list source [file join $dir plugins/writer_tpc.tcl]]
+package ifneeded page::writer::hb 0.1 [list source [file join $dir plugins/writer_hb.tcl]]
+package ifneeded page::writer::ser 0.1 [list source [file join $dir plugins/writer_ser.tcl]]
+package ifneeded page::writer::peg 0.1 [list source [file join $dir plugins/writer_peg.tcl]]
+package ifneeded page::writer::identity 0.1 [list source [file join $dir plugins/writer_identity.tcl]]
+
+# -- PAGE plugin packages
+# -- ---- Transformations
+
+package ifneeded page::transform::reachable 0.1 \
+ [list source [file join $dir plugins/transform_reachable.tcl]]
+package ifneeded page::transform::realizable 0.1 \
+ [list source [file join $dir plugins/transform_realizable.tcl]]
+package ifneeded page::transform::mecpu 0.1 \
+ [list source [file join $dir plugins/transform_mecpu.tcl]]
+
+# -- PAGE packages --
+# -- --- Parsing and normalization packages used by the reader plugins.
+
+package ifneeded page::parse::peg 0.1 [list source [file join $dir parse_peg.tcl]]
+package ifneeded page::parse::lemon 0.1 [list source [file join $dir parse_lemon.tcl]]
+package ifneeded page::parse::pegser 0.1 [list source [file join $dir parse_pegser.tcl]]
+package ifneeded page::parse::peghb 0.1 [list source [file join $dir parse_peghb.tcl]]
+
+package ifneeded page::util::norm::peg 0.1 [list source [file join $dir util_norm_peg.tcl]]
+package ifneeded page::util::norm::lemon 0.1 [list source [file join $dir util_norm_lemon.tcl]]
+
+# @mdgen EXCLUDE: peg_grammar.tcl
+### package ifneeded pg::peg::grammar 0.1 [list source [file join $dir peg_grammar.tcl]]
+
+# -- PAGE packages --
+# -- --- Code generation packages used by the writer plugins.
+
+package ifneeded page::gen::tree::text 0.1 [list source [file join $dir gen_tree_text.tcl]]
+package ifneeded page::gen::peg::cpkg 0.1 [list source [file join $dir gen_peg_cpkg.tcl]]
+package ifneeded page::gen::peg::hb 0.1 [list source [file join $dir gen_peg_hb.tcl]]
+package ifneeded page::gen::peg::ser 0.1 [list source [file join $dir gen_peg_ser.tcl]]
+package ifneeded page::gen::peg::canon 0.1 [list source [file join $dir gen_peg_canon.tcl]]
+package ifneeded page::gen::peg::me 0.1 [list source [file join $dir gen_peg_me.tcl]]
+package ifneeded page::gen::peg::mecpu 0.1 [list source [file join $dir gen_peg_mecpu.tcl]]
+
+# -- Transformation Helper Packages --
+
+package ifneeded page::analysis::peg::minimize 0.1 [list source [file join $dir analysis_peg_minimize.tcl]]
+package ifneeded page::analysis::peg::reachable 0.1 [list source [file join $dir analysis_peg_reachable.tcl]]
+package ifneeded page::analysis::peg::realizable 0.1 [list source [file join $dir analysis_peg_realizable.tcl]]
+package ifneeded page::analysis::peg::emodes 0.1 [list source [file join $dir analysis_peg_emodes.tcl]]
+package ifneeded page::compiler::peg::mecpu 0.1.1 [list source [file join $dir compiler_peg_mecpu.tcl]]
+
+# -- Various other utilities --
+
+package ifneeded page::util::peg 0.1 [list source [file join $dir util_peg.tcl]]
+package ifneeded page::util::quote 0.1 [list source [file join $dir util_quote.tcl]]
+package ifneeded page::util::flow 0.1 [list source [file join $dir util_flow.tcl]]
diff --git a/tcllib/modules/page/pluginmgr.tcl b/tcllib/modules/page/pluginmgr.tcl
new file mode 100644
index 0000000..ac00192
--- /dev/null
+++ b/tcllib/modules/page/pluginmgr.tcl
@@ -0,0 +1,581 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+
+## This package provides custom plugin management specific to PAGE. It
+## is built on top of the generic plugin management framework (See
+## ---> pluginmgr).
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require fileutil
+package require pluginmgr ; # Generic plugin management framework
+
+namespace eval ::page::pluginmgr {}
+
+# ### ### ### ######### ######### #########
+## API (Public, exported)
+
+proc ::page::pluginmgr::reportvia {cmd} {
+ variable reportcmd $cmd
+ return
+}
+
+proc ::page::pluginmgr::log {cmd} {
+ variable reader
+ variable writer
+ variable transforms
+
+ set iplist {}
+ lappend iplist [$reader interpreter]
+ lappend iplist [$writer interpreter]
+ foreach t $transforms {
+ lappend iplist [$t interpreter]
+ }
+
+ if {$cmd eq ""} {
+ # No logging. Disable with empty command,
+ # to allow the system to completely remove
+ # them from the bytecode (= No execution
+ # overhead).
+
+ foreach ip $iplist {
+ $ip eval [list proc page_log_error args {}]
+ $ip eval [list proc page_log_warning args {}]
+ $ip eval [list proc page_log_info args {}]
+ }
+ } else {
+ # Activate logging. Make the commands in
+ # the interpreters aliases to us.
+
+ foreach ip $iplist {
+ interp alias $ip page_log_error {} ${cmd}::error
+ interp alias $ip page_log_warning {} ${cmd}::warning
+ interp alias $ip page_log_info {} ${cmd}::info
+ }
+ }
+ return
+}
+
+proc ::page::pluginmgr::reader {name} {
+ variable reader
+
+ $reader load $name
+ return [$reader do page_roptions]
+}
+
+proc ::page::pluginmgr::rconfigure {dict} {
+ variable reader
+ foreach {k v} $dict {
+ $reader do page_rconfigure $k $v
+ }
+ return
+}
+
+proc ::page::pluginmgr::rtimeable {} {
+ variable reader
+ return [$reader do page_rfeature timeable]
+}
+
+proc ::page::pluginmgr::rtime {} {
+ variable reader
+ $reader do page_rtime
+ return
+}
+
+proc ::page::pluginmgr::rgettime {} {
+ variable reader
+ return [$reader do page_rgettime]
+}
+
+proc ::page::pluginmgr::rhelp {} {
+ variable reader
+ return [$reader do page_rhelp]
+}
+
+proc ::page::pluginmgr::rlabel {} {
+ variable reader
+ return [$reader do page_rlabel]
+}
+
+proc ::page::pluginmgr::read {read eof {complete {}}} {
+ variable reader
+
+ #interp alias $ip page_read {} {*}$read
+ #interp alias $ip page_eof {} {*}$eof
+
+ set ip [$reader interpreter]
+ eval [linsert $read 0 interp alias $ip page_read {}]
+ eval [linsert $eof 0 interp alias $ip page_eof {}]
+
+ if {![llength $complete]} {
+ interp alias $ip page_read_done {} ::page::pluginmgr::Nop
+ } else {
+ eval [linsert $complete 0 interp alias $ip page_read_done {}]
+ }
+
+ return [$reader do page_rrun]
+}
+
+proc ::page::pluginmgr::writer {name} {
+ variable writer
+
+ $writer load $name
+ return [$writer do page_woptions]
+}
+
+proc ::page::pluginmgr::wconfigure {dict} {
+ variable writer
+ foreach {k v} $dict {
+ $writer do page_wconfigure $k $v
+ }
+ return
+}
+
+proc ::page::pluginmgr::wtimeable {} {
+ variable writer
+ return [$writer do page_wfeature timeable]
+}
+
+proc ::page::pluginmgr::wtime {} {
+ variable writer
+ $writer do page_wtime
+ return
+}
+
+proc ::page::pluginmgr::wgettime {} {
+ variable writer
+ return [$writer do page_wgettime]
+}
+
+proc ::page::pluginmgr::whelp {} {
+ variable writer
+ return [$writer do page_whelp]
+}
+
+proc ::page::pluginmgr::wlabel {} {
+ variable writer
+ return [$writer do page_wlabel]
+}
+
+proc ::page::pluginmgr::write {chan data} {
+ variable writer
+
+ $writer do page_wrun $chan $data
+ return
+}
+
+proc ::page::pluginmgr::transform {name} {
+ variable transform
+ variable transforms
+
+ $transform load $name
+
+ set id [llength $transforms]
+ set opt [$transform do page_toptions]
+ lappend transforms [$transform clone]
+
+ return [list $id $opt]
+}
+
+proc ::page::pluginmgr::tconfigure {id dict} {
+ variable transforms
+
+ set t [lindex $transforms $id]
+
+ foreach {k v} $dict {
+ $t do page_tconfigure $k $v
+ }
+ return
+}
+
+proc ::page::pluginmgr::ttimeable {id} {
+ variable transforms
+ set t [lindex $transforms $id]
+ return [$t do page_tfeature timeable]
+}
+
+proc ::page::pluginmgr::ttime {id} {
+ variable transforms
+ set t [lindex $transforms $id]
+ $t do page_ttime
+ return
+}
+
+proc ::page::pluginmgr::tgettime {id} {
+ variable transforms
+ set t [lindex $transforms $id]
+ return [$t do page_tgettime]
+}
+
+proc ::page::pluginmgr::thelp {id} {
+ variable transforms
+ set t [lindex $transforms $id]
+ return [$t do page_thelp]
+}
+
+proc ::page::pluginmgr::tlabel {id} {
+ variable transforms
+ set t [lindex $transforms $id]
+ return [$t do page_tlabel]
+}
+
+proc ::page::pluginmgr::transform_do {id data} {
+ variable transforms
+ variable reader
+
+ set t [lindex $transforms $id]
+
+ return [$t do page_trun $data]
+}
+
+proc ::page::pluginmgr::configuration {name} {
+ variable config
+
+ if {[file exists $name]} {
+ # Try as plugin first. On failure read it as list of options,
+ # separated by spaces and tabs, and possibly quoted with
+ # quotes and double-quotes.
+
+ if {[catch {$config load $name}]} {
+ set ch [open $name r]
+ set options [::read $ch]
+ close $ch
+
+ set def {}
+ while {[string length $options]} {
+ if {[regsub "^\[ \t\n\]+" $options {} options]} {
+ # Skip whitespace
+ continue
+ }
+ if {[regexp -indices {^'(([^']|(''))*)'} \
+ $options -> word]} {
+ foreach {__ end} $word break
+ lappend def [string map {'' '} [string range $options 1 $end]]
+ set options [string range $options [incr end 2] end]
+ } elseif {[regexp -indices {^"(([^"]|(""))*)"} \
+ $options -> word]} {
+ foreach {__ end} $word break
+ lappend def [string map {{""} {"}} [string range $options 1 $end]]
+ set options [string range $options [incr end 2] end]
+ } elseif {[regexp -indices "^(\[^ \t\n\]+)" \
+ $options -> word]} {
+ foreach {__ end} $word break
+ lappend def [string range $options 0 $end]
+ set options [string range $options [incr end] end]
+ }
+ }
+ return $def
+ }
+ } else {
+ $config load $name
+ }
+ set def [$config do page_cdefinition]
+ $config unload
+ return $def
+}
+
+proc ::page::pluginmgr::report {level text {from {}} {to {}}} {
+ variable replevel
+ variable reportcmd
+ uplevel #0 [linsert $reportcmd end $replevel($level) $text $from $to]
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internals
+
+## Data structures
+##
+## - reader | Instances of pluginmgr configured for input,
+## - transform | transformational, and output plugins. The
+## - writer | manager for transforms is actually a template
+## | from which the actual instances are cloned.
+
+## - reportcmd | Callback for reporting of input error and warnings.
+## - replevel | Mapping from chosen level to the right-padded text
+## | to use.
+
+namespace eval ::page::pluginmgr {
+ variable replevel
+ array set replevel {
+ info {info }
+ warning {warning}
+ error {error }
+ }
+}
+
+proc ::page::pluginmgr::Initialize {} {
+ InitializeReporting
+ InitializeConfig
+ InitializeReader
+ InitializeTransform
+ InitializeWriter
+ return
+}
+
+proc ::page::pluginmgr::InitializeReader {} {
+ variable commands
+ variable reader_api
+ variable reader [pluginmgr RD \
+ -setup ::page::pluginmgr::InitializeReaderIp \
+ -pattern page::reader::* \
+ -api $reader_api \
+ -cmdip {} \
+ -cmds $commands]
+
+ # The page_log_* commands are set later, when it is known if
+ # logging is active or not, as their implementation depends on
+ # this.
+
+ pluginmgr::paths $reader page::reader
+ return
+}
+
+proc ::page::pluginmgr::InitializeReaderIp {p ip} {
+ interp eval $ip {
+ # @sak notprovided page::plugin
+ # @sak notprovided page::plugin::reader
+ package provide page::plugin 1.0
+ package provide page::plugin::reader 1.0
+ }
+ interp alias $ip puts {} puts
+ interp alias $ip open {} ::page::pluginmgr::AliasOpen $ip
+ interp alias $ip write {} ::page::pluginmgr::WriteFile $ip
+ return
+}
+
+proc ::page::pluginmgr::InitializeWriter {} {
+ variable commands
+ variable writer_api
+ variable writer [pluginmgr WR \
+ -setup ::page::pluginmgr::InitializeWriterIp \
+ -pattern page::writer::* \
+ -api $writer_api \
+ -cmdip {} \
+ -cmds $commands]
+
+ # The page_log_* commands are set later, when it is known if
+ # logging is active or not, as their implementation depends on
+ # this.
+
+ pluginmgr::paths $writer page::writer
+ return
+}
+
+proc ::page::pluginmgr::InitializeWriterIp {p ip} {
+ interp eval $ip {
+ # @sak notprovided page::plugin
+ # @sak notprovided page::plugin::writer
+ package provide page::plugin 1.0
+ package provide page::plugin::writer 1.0
+ }
+ interp alias $ip puts {} puts
+ interp alias $ip open {} ::page::pluginmgr::AliasOpen $ip
+ interp alias $ip write {} ::page::pluginmgr::WriteFile $ip
+ return
+}
+
+proc ::page::pluginmgr::InitializeTransform {} {
+ variable transforms {}
+ variable commands
+ variable transform_api
+ variable transform [pluginmgr TR \
+ -setup ::page::pluginmgr::InitializeTransformIp \
+ -pattern page::transform::* \
+ -api $transform_api \
+ -cmdip {} \
+ -cmds $commands]
+
+ # The page_log_* commands are set later, when it is known if
+ # logging is active or not, as their implementation depends on
+ # this.
+
+ pluginmgr::paths $transform page::transform
+ return
+}
+
+proc ::page::pluginmgr::InitializeTransformIp {p ip} {
+ interp eval $ip {
+ # @sak notprovided page::plugin
+ # @sak notprovided page::plugin::transform
+ package provide page::plugin 1.0
+ package provide page::plugin::transform 1.0
+ }
+ interp alias $ip puts {} puts
+ interp alias $ip open {} ::page::pluginmgr::AliasOpen $ip
+ interp alias $ip write {} ::page::pluginmgr::WriteFile $ip
+ return
+}
+
+proc ::page::pluginmgr::InitializeConfig {} {
+ variable config [pluginmgr CO \
+ -pattern page::config::* \
+ -api {page_cdefinition}]
+
+ pluginmgr::paths $config page::config
+ return
+}
+
+proc ::page::pluginmgr::InitializeReporting {} {
+ variable reportcmd ::page::pluginmgr::ReportStderr
+ return
+}
+
+proc ::page::pluginmgr::ReportStderr {level text from to} {
+ # from = epsilon | list (line col)
+ # to = epsilon | list (line col)
+ # line = 5 digits, col = 3 digits
+
+ if {
+ ($text eq "") &&
+ ![llength $from] &&
+ ![llength $to]
+ } {
+ puts stderr ""
+ return
+ }
+
+ puts -nonewline stderr $level
+ WriteLocation $from
+ if {![llength $to]} {
+ puts -nonewline stderr { }
+ } else {
+ puts -nonewline stderr {-}
+ }
+ WriteLocation $to
+ puts -nonewline stderr " "
+ puts -nonewline stderr $text
+ puts stderr ""
+ return
+}
+
+proc ::page::pluginmgr::WriteLocation {loc} {
+ if {![llength $loc]} {
+ set text { }
+ } else {
+ set line [lindex $loc 0]
+ set col [lindex $loc 1]
+ set text {}
+ if {![string length $line]} {
+ append text _____
+ } else {
+ append text [string map {{ } _} [format %5d $line]]
+ }
+ append text @
+ if {![string length $col]} {
+ append text ___
+ } else {
+ append text [string map {{ } _} [format %3d $col]]
+ }
+ }
+ puts -nonewline stderr $text
+ return
+}
+
+proc ::page::pluginmgr::AliasOpen {slave file {acc {}} {perm {}}} {
+
+ if {$acc eq ""} {set acc r}
+
+ ::safe::Log $slave =============================================
+ ::safe::Log $slave "open $file $acc $perm"
+
+ if {[regexp {[wa+]|(WRONLY)|(RDWR)|(APPEND)|(CREAT)|(TRUNC)} $acc]} {
+ # Do not allow write acess.
+ ::safe::Log $slave "permission denied"
+ ::safe::Log $slave 0/============================================
+ return -code error "permission denied"
+ }
+
+ if {[catch {set file [::safe::TranslatePath $slave $file]} msg]} {
+ ::safe::Log $slave $msg
+ ::safe::Log $slave "permission denied"
+ ::safe::Log $slave 1/============================================
+ return -code error "permission denied"
+ }
+
+ # check that the path is in the access path of that slave
+
+ if {[catch {::safe::FileInAccessPath $slave $file} msg]} {
+ ::safe::Log $slave $msg
+ ::safe::Log $slave "permission denied"
+ ::safe::Log $slave 2/============================================
+ return -code error "permission denied"
+ }
+
+ # do the checks on the filename :
+
+ if {[catch {::safe::CheckFileName $slave $file} msg]} {
+ ::safe::Log $slave "$file: $msg"
+ ::safe::Log $slave "$msg"
+ ::safe::Log $slave 3/============================================
+ return -code error $msg
+ }
+
+ if {[catch {::interp invokehidden $slave open $file $acc} msg]} {
+ ::safe::Log $slave "Caught: $msg"
+ ::safe::Log $slave "script error"
+ ::safe::Log $slave 4/============================================
+ return -code error "script error"
+ }
+
+ ::safe::Log $slave =/============================================
+ return $msg
+
+}
+
+proc ::page::pluginmgr::Nop {args} {}
+
+proc ::page::pluginmgr::WriteFile {slave file text} {
+ if {[file pathtype $file] ne "relative"} {
+ set file [file join [pwd] [file tail $fail]]
+ }
+ file mkdir [file dirname $file]
+ fileutil::writeFile $file $text
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+namespace eval ::page::pluginmgr {
+
+ # List of functions in the various plugin APIs
+
+ variable reader_api {
+ page_rhelp
+ page_rlabel
+ page_roptions
+ page_rconfigure
+ page_rrun
+ page_rfeature
+ }
+ variable writer_api {
+ page_whelp
+ page_wlabel
+ page_woptions
+ page_wconfigure
+ page_wrun
+ page_wfeature
+ }
+ variable transform_api {
+ page_thelp
+ page_tlabel
+ page_toptions
+ page_tconfigure
+ page_trun
+ page_tfeature
+ }
+ variable commands {
+ page_info {::page::pluginmgr::report info}
+ page_warning {::page::pluginmgr::report warning}
+ page_error {::page::pluginmgr::report error}
+ }
+}
+
+::page::pluginmgr::Initialize
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::pluginmgr 0.2
diff --git a/tcllib/modules/page/plugins/config_peg.tcl b/tcllib/modules/page/plugins/config_peg.tcl
new file mode 100644
index 0000000..517877f
--- /dev/null
+++ b/tcllib/modules/page/plugins/config_peg.tcl
@@ -0,0 +1,14 @@
+# -*- tcl -*- $Id: config_peg.tcl,v 1.2 2005/09/28 06:16:38 andreas_kupries Exp $
+
+package provide page::config::peg 0.1
+
+proc page_cdefinition {} {
+ return {
+ --reset
+ --append
+ --reader peg
+ --transform reachable
+ --transform realizable
+ --writer me
+ }
+}
diff --git a/tcllib/modules/page/plugins/pkgIndex.tcl b/tcllib/modules/page/plugins/pkgIndex.tcl
new file mode 100644
index 0000000..8b6332a
--- /dev/null
+++ b/tcllib/modules/page/plugins/pkgIndex.tcl
@@ -0,0 +1,34 @@
+#puts @plugins
+# -- PAGE plugin packages
+# -- ---- Canned configurations
+
+package ifneeded page::config::peg 0.1 [list source [file join $dir config_peg.tcl]]
+
+# -- PAGE plugin packages
+# -- ---- Readers
+
+package ifneeded page::reader::peg 0.1 [list source [file join $dir reader_peg.tcl]]
+package ifneeded page::reader::lemon 0.1 [list source [file join $dir reader_lemon.tcl]]
+package ifneeded page::reader::hb 0.1 [list source [file join $dir reader_hb.tcl]]
+package ifneeded page::reader::ser 0.1 [list source [file join $dir reader_ser.tcl]]
+package ifneeded page::reader::treeser 0.1 [list source [file join $dir reader_treeser.tcl]]
+
+# -- PAGE plugin packages
+# -- ---- Writers
+
+package ifneeded page::writer::null 0.1 [list source [file join $dir writer_null.tcl]]
+package ifneeded page::writer::me 0.1 [list source [file join $dir writer_me.tcl]]
+package ifneeded page::writer::mecpu 0.1.1 [list source [file join $dir writer_mecpu.tcl]]
+package ifneeded page::writer::tree 0.1 [list source [file join $dir writer_tree.tcl]]
+package ifneeded page::writer::tpc 0.1 [list source [file join $dir writer_tpc.tcl]]
+package ifneeded page::writer::hb 0.1 [list source [file join $dir writer_hb.tcl]]
+package ifneeded page::writer::ser 0.1 [list source [file join $dir writer_ser.tcl]]
+package ifneeded page::writer::peg 0.1 [list source [file join $dir writer_peg.tcl]]
+package ifneeded page::writer::identity 0.1 [list source [file join $dir writer_identity.tcl]]
+
+# -- PAGE plugin packages
+# -- ---- Transformations
+
+package ifneeded page::transform::reachable 0.1 [list source [file join $dir transform_reachable.tcl]]
+package ifneeded page::transform::realizable 0.1 [list source [file join $dir transform_realizable.tcl]]
+package ifneeded page::transform::mecpu 0.1 [list source [file join $dir transform_mecpu.tcl]]
diff --git a/tcllib/modules/page/plugins/reader_hb.tcl b/tcllib/modules/page/plugins/reader_hb.tcl
new file mode 100644
index 0000000..4cee18c
--- /dev/null
+++ b/tcllib/modules/page/plugins/reader_hb.tcl
@@ -0,0 +1,114 @@
+# -*- tcl -*-
+# -- $Id: reader_hb.tcl,v 1.1 2005/09/28 04:51:22 andreas_kupries Exp $ ---
+#
+# PAGE plugin - reader - HB ~ Half baked PEG Container
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_read | Access to the input stream.
+# page_read_done |
+# page_eof |
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_rfeature | Query for special plugin features page might wish to use.
+# page_rtime | Activate collection of timing statistics.
+# page_rgettime | Return the collected timing statistics.
+# page_rlabel | User readable label for the plugin.
+# page_rhelp | Doctools help text for plugin.
+# page_roptions | Options understood by plugin.
+# page_rconfigure | Option (re)configuration.
+# page_rdata | External access to processed input stream.
+# page_rrun | Process input stream per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require struct::tree ; # Data structure.
+package require page::parse::peghb
+
+global usec
+global timed
+set timed 0
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_rlabel {} {
+ return {Halfbaked PEG Container}
+}
+
+proc page_rfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_rtime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_rgettime {} {
+ global usec
+ return $usec
+}
+
+proc page_rhelp {} {
+ return {}
+}
+
+proc page_roptions {} {
+ return {}
+}
+
+proc page_rconfigure {option value} {
+ return -code error "Cannot set value of unknown option \"$option\""
+}
+
+## proc page_rdata {} {}
+## Created in 'Initialize'
+
+proc page_rrun {} {
+ global timed usec
+ page_log_info "reader/hb/run/parse"
+
+ struct::tree ::tree
+
+ if {$timed} {
+ set usec [lindex [time {
+ page::parse::peghb [page_read] ::tree
+ }] 0] ; #{}
+ } else {
+ page::parse::peghb [page_read] ::tree
+ }
+ page_read_done
+
+ set ast [::tree serialize]
+ ::tree destroy
+
+ page_log_info "reader/hb/run/ok"
+ return $ast
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::reader::hb 0.1
diff --git a/tcllib/modules/page/plugins/reader_lemon.tcl b/tcllib/modules/page/plugins/reader_lemon.tcl
new file mode 100644
index 0000000..16df290
--- /dev/null
+++ b/tcllib/modules/page/plugins/reader_lemon.tcl
@@ -0,0 +1,170 @@
+# -*- tcl -*-
+# -- $Id: reader_lemon.tcl,v 1.1 2005/09/28 04:51:22 andreas_kupries Exp $ ---
+#
+# PAGE plugin - reader - LEMON ~ Grammar specification as understood
+# by drh's lemon parser generator.
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_read | Access to the input stream.
+# page_read_done |
+# page_eof |
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_rfeature | Query for special plugin features page might wish to use.
+# page_rtime | Activate collection of timing statistics.
+# page_rgettime | Return the collected timing statistics.
+# page_rlabel | User readable label for the plugin.
+# page_rhelp | Doctools help text for plugin.
+# page_roptions | Options understood by plugin.
+# page_rconfigure | Option (re)configuration.
+# page_rdata | External access to processed input stream.
+# page_rrun | Process input stream per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::util::norm::lemon ; # Normalize AST generated by PE matcher.
+package require page::parse::lemon ; # Mengine based parser for Lemon grammars.
+package require struct::tree ; # Data structure.
+package require grammar::me::util ; # AST conversion
+
+global usec
+global timed
+set timed 0
+
+global cline
+global ccol
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_rlabel {} {
+ return {Lemon specification}
+}
+
+proc page_rfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_rtime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_rgettime {} {
+ global usec
+ return $usec
+}
+
+proc page_rhelp {} {
+ return {}
+}
+
+proc page_roptions {} {
+ return {}
+}
+
+proc page_rconfigure {option value} {
+ return -code error "Cannot set value of unknown option \"$option\""
+}
+
+## proc page_rdata {} {}
+## Created in 'Initialize'
+
+proc page_rrun {} {
+ global timed usec cline ccol
+ page_log_info "reader/lemon/run/parse"
+
+ set ast {}
+ set err {}
+
+ # Location of the next character to be read.
+ set cline 1
+ set ccol 0
+
+ if {$timed} {
+ set usec [lindex [time {
+ set ok [::page::parse::lemon::parse ::Next err ast]
+ }] 0] ; #{}
+ } else {
+ set ok [::page::parse::lemon::parse ::Next err ast]
+ }
+ page_read_done
+ page_log_info "reader/lemon/run/check-for-errors"
+
+ if {!$ok} {
+ foreach {olc messages} $err break
+ foreach {offset linecol} $olc break
+ foreach {line col} $linecol break
+
+ set olc [string map {{ } _} \
+ [format %5d $line]]@[string map {{ } _} \
+ [format %3d $col]]/([format %5d $offset])
+
+ foreach m $messages {
+ page_log_error "reader/lemon/run: $olc: $m"
+ page_error $m $linecol
+ }
+
+ page_log_info "reader/lemon/run/failed"
+ return {}
+ }
+
+ page_log_info "reader/lemon/run/ast-conversion"
+
+ struct::tree ::tree
+ ::grammar::me::util::ast2etree $ast ::grammar::me::tcl ::tree
+ ::page::util::norm::lemon ::tree
+
+ set ast [::tree serialize]
+ ::tree destroy
+
+ page_log_info "reader/lemon/run/ok"
+ return $ast
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+proc Next {} {
+ global cline ccol
+
+ if {[page_eof]} {return {}}
+
+ set ch [page_read 1]
+
+ if {$ch eq ""} {return {}}
+
+ set tok [list $ch {} $cline $ccol]
+
+ if {$ch eq "\n"} {
+ incr cline ; set ccol 0
+ } else {
+ incr ccol
+ }
+
+ return $tok
+}
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::reader::lemon 0.1
diff --git a/tcllib/modules/page/plugins/reader_peg.tcl b/tcllib/modules/page/plugins/reader_peg.tcl
new file mode 100644
index 0000000..52fd6a8
--- /dev/null
+++ b/tcllib/modules/page/plugins/reader_peg.tcl
@@ -0,0 +1,169 @@
+# -*- tcl -*-
+# -- $Id: reader_peg.tcl,v 1.1 2005/09/28 04:51:22 andreas_kupries Exp $ ---
+#
+# PAGE plugin - reader - PEG ~ Parsing Expression Grammar
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_read | Access to the input stream.
+# page_read_done |
+# page_eof |
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_rfeature | Query for special plugin features page might wish to use.
+# page_rtime | Activate collection of timing statistics.
+# page_rgettime | Return the collected timing statistics.
+# page_rlabel | User readable label for the plugin.
+# page_rhelp | Doctools help text for plugin.
+# page_roptions | Options understood by plugin.
+# page_rconfigure | Option (re)configuration.
+# page_rdata | External access to processed input stream.
+# page_rrun | Process input stream per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::util::norm::peg ; # Normalize AST generated by reader of PEG grammars
+package require page::parse::peg ; # Mengine based parser for PE grammars.
+package require struct::tree ; # Data structure.
+package require grammar::me::util ; # AST conversion
+
+global usec
+global timed
+set timed 0
+
+global cline
+global ccol
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_rlabel {} {
+ return {Parsing Expression Grammar}
+}
+
+proc page_rfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_rtime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_rgettime {} {
+ global usec
+ return $usec
+}
+
+proc page_rhelp {} {
+ return {}
+}
+
+proc page_roptions {} {
+ return {}
+}
+
+proc page_rconfigure {option value} {
+ return -code error "Cannot set value of unknown option \"$option\""
+}
+
+## proc page_rdata {} {}
+## Created in 'Initialize'
+
+proc page_rrun {} {
+ global timed usec cline ccol
+ page_log_info "reader/peg/run/parse"
+
+ set ast {}
+ set err {}
+
+ # Location of the next character to be read.
+ set cline 1
+ set ccol 0
+
+ if {$timed} {
+ set usec [lindex [time {
+ set ok [::page::parse::peg::parse ::Next err ast]
+ }] 0] ; #{}
+ } else {
+ set ok [::page::parse::peg::parse ::Next err ast]
+ }
+ page_read_done
+ page_log_info "reader/peg/run/check-for-errors"
+
+ if {!$ok} {
+ foreach {olc messages} $err break
+ foreach {offset linecol} $olc break
+ foreach {line col} $linecol break
+
+ set olc [string map {{ } _} \
+ [format %5d $line]]@[string map {{ } _} \
+ [format %3d $col]]/([format %5d $offset])
+
+ foreach m $messages {
+ page_log_error "reader/peg/run: $olc: $m"
+ page_error $m $linecol
+ }
+
+ page_log_info "reader/peg/run/failed"
+ return {}
+ }
+
+ page_log_info "reader/peg/run/ast-conversion"
+
+ struct::tree ::tree
+ ::grammar::me::util::ast2etree $ast ::grammar::me::tcl ::tree
+ ::page::util::norm::peg ::tree
+
+ set ast [::tree serialize]
+ ::tree destroy
+
+ page_log_info "reader/peg/run/ok"
+ return $ast
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+proc Next {} {
+ global cline ccol
+
+ if {[page_eof]} {return {}}
+
+ set ch [page_read 1]
+
+ if {$ch eq ""} {return {}}
+
+ set tok [list $ch {} $cline $ccol]
+
+ if {$ch eq "\n"} {
+ incr cline ; set ccol 0
+ } else {
+ incr ccol
+ }
+
+ return $tok
+}
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::reader::peg 0.1
diff --git a/tcllib/modules/page/plugins/reader_ser.tcl b/tcllib/modules/page/plugins/reader_ser.tcl
new file mode 100644
index 0000000..b4e1a68
--- /dev/null
+++ b/tcllib/modules/page/plugins/reader_ser.tcl
@@ -0,0 +1,114 @@
+# -*- tcl -*-
+# -- $Id: reader_ser.tcl,v 1.1 2005/09/28 04:51:22 andreas_kupries Exp $ ---
+#
+# PAGE plugin - reader - SER ~ Serialized PEG Container
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_read | Access to the input stream.
+# page_read_done |
+# page_eof |
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_rfeature | Query for special plugin features page might wish to use.
+# page_rtime | Activate collection of timing statistics.
+# page_rgettime | Return the collected timing statistics.
+# page_rlabel | User readable label for the plugin.
+# page_rhelp | Doctools help text for plugin.
+# page_roptions | Options understood by plugin.
+# page_rconfigure | Option (re)configuration.
+# page_rdata | External access to processed input stream.
+# page_rrun | Process input stream per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require struct::tree ; # Data structure.
+package require page::parse::pegser
+
+global usec
+global timed
+set timed 0
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_rlabel {} {
+ return {Serialized PEG Container}
+}
+
+proc page_rfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_rtime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_rgettime {} {
+ global usec
+ return $usec
+}
+
+proc page_rhelp {} {
+ return {}
+}
+
+proc page_roptions {} {
+ return {}
+}
+
+proc page_rconfigure {option value} {
+ return -code error "Cannot set value of unknown option \"$option\""
+}
+
+## proc page_rdata {} {}
+## Created in 'Initialize'
+
+proc page_rrun {} {
+ global timed usec
+ page_log_info "reader/ser/run/parse"
+
+ struct::tree ::tree
+
+ if {$timed} {
+ set usec [lindex [time {
+ page::parse::pegser [page_read] ::tree
+ }] 0] ; #{}
+ } else {
+ page::parse::pegser [page_read] ::tree
+ }
+ page_read_done
+
+ set ast [::tree serialize]
+ ::tree destroy
+
+ page_log_info "reader/ser/run/ok"
+ return $ast
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::reader::ser 0.1
diff --git a/tcllib/modules/page/plugins/reader_treeser.tcl b/tcllib/modules/page/plugins/reader_treeser.tcl
new file mode 100644
index 0000000..6394d7b
--- /dev/null
+++ b/tcllib/modules/page/plugins/reader_treeser.tcl
@@ -0,0 +1,116 @@
+# -*- tcl -*-
+# -- $Id: reader_treeser.tcl,v 1.1 2005/09/28 04:51:22 andreas_kupries Exp $ ---
+#
+# PAGE plugin - reader - TREESER ~ Serialized TREE
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_read | Access to the input stream.
+# page_read_done |
+# page_eof |
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_rfeature | Query for special plugin features page might wish to use.
+# page_rtime | Activate collection of timing statistics.
+# page_rgettime | Return the collected timing statistics.
+# page_rlabel | User readable label for the plugin.
+# page_rhelp | Doctools help text for plugin.
+# page_roptions | Options understood by plugin.
+# page_rconfigure | Option (re)configuration.
+# page_rdata | External access to processed input stream.
+# page_rrun | Process input stream per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require struct::tree ; # Data structure.
+
+global usec
+global timed
+set timed 0
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_rlabel {} {
+ return {Serialized Tree}
+}
+
+proc page_rfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_rtime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_rgettime {} {
+ global usec
+ return $usec
+}
+
+proc page_rhelp {} {
+ return {}
+}
+
+proc page_roptions {} {
+ return {}
+}
+
+proc page_rconfigure {option value} {
+ return -code error "Cannot set value of unknown option \"$option\""
+}
+
+## proc page_rdata {} {}
+## Created in 'Initialize'
+
+proc page_rrun {} {
+ global timed usec
+ page_log_info "reader/treeser/run/parse"
+
+ if {$timed} {
+ set usec [lindex [time {
+ set data [page_read]
+ }] 0] ; #{}
+ } else {
+ set data [page_read]
+ }
+ page_read_done
+
+ # Reading and passing it on is trivial.
+ # Here however we validate the we truly got
+ # a sensible serialization.
+
+ struct::tree ::tree
+ ::tree deserialize $data
+ ::tree destroy
+
+ page_log_info "reader/treeser/run/ok"
+ return $data
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::reader::treeser 0.1
diff --git a/tcllib/modules/page/plugins/transform_mecpu.tcl b/tcllib/modules/page/plugins/transform_mecpu.tcl
new file mode 100644
index 0000000..4c48e53
--- /dev/null
+++ b/tcllib/modules/page/plugins/transform_mecpu.tcl
@@ -0,0 +1,107 @@
+# -*- tcl -*-
+# -- $Id: transform_mecpu.tcl,v 1.1 2006/07/01 01:35:21 andreas_kupries Exp $ ---
+#
+# PAGE plugin - transform - mecpu ~ Translation of grammar to ME cpu instruction set.
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_tdata | Access to processed input stream.
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_tfeature | Query for special plugin features page might wish to use.
+# page_ttime | Activate collection of timing statistics.
+# page_tgettime | Return the collected timing statistics.
+# page_tlabel | User readable label for the plugin.
+# page_thelp | Doctools help text for plugin.
+# page_toptions | Options understood by plugin.
+# page_tconfigure | Option (re)configuration.
+# page_trun | Transform input data per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::compiler::peg::mecpu
+package require struct::tree ; # Data structure.
+
+global usec
+global timed
+set timed 0
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_tlabel {} {
+ return {ME cpu Translation}
+}
+
+proc page_tfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_ttime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_tgettime {} {
+ global usec
+ return $usec
+}
+
+proc page_thelp {} {
+ return {}
+}
+
+proc page_toptions {} {
+ return {}
+}
+
+proc page_tconfigure {option value} {
+ return -code error "Cannot set value of unknown option \"$option\""
+}
+
+proc page_trun {data} {
+ global timed usec
+ page_log_info "transform/mecpu/run/"
+
+ if {$timed} {
+ set usec [lindex [time {
+ ::struct::tree ::tree deserialize $data
+ page::compiler::peg::mecpu ::tree
+ }] 0] ; #{}
+ } else {
+ ::struct::tree ::tree deserialize $data
+ page::compiler::peg::mecpu ::tree
+ }
+ set name [::tree get root name]
+ set asm [::tree get root asm]
+ ::tree destroy
+
+ page_log_info "transform/mecpu/run/ok"
+ return [list $name $asm]
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::transform::mecpu 0.1
diff --git a/tcllib/modules/page/plugins/transform_reachable.tcl b/tcllib/modules/page/plugins/transform_reachable.tcl
new file mode 100644
index 0000000..2dee6dd
--- /dev/null
+++ b/tcllib/modules/page/plugins/transform_reachable.tcl
@@ -0,0 +1,107 @@
+# -*- tcl -*-
+# -- $Id: transform_reachable.tcl,v 1.1 2005/09/28 04:51:22 andreas_kupries Exp $ ---
+#
+# PAGE plugin - transform - reachable ~ Reachability Analysis
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_tdata | Access to processed input stream.
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_tfeature | Query for special plugin features page might wish to use.
+# page_ttime | Activate collection of timing statistics.
+# page_tgettime | Return the collected timing statistics.
+# page_tlabel | User readable label for the plugin.
+# page_thelp | Doctools help text for plugin.
+# page_toptions | Options understood by plugin.
+# page_tconfigure | Option (re)configuration.
+# page_trun | Transform input data per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::analysis::peg::reachable
+package require struct::tree ; # Data structure.
+
+global usec
+global timed
+set timed 0
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_tlabel {} {
+ return Reachability
+}
+
+proc page_tfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_ttime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_tgettime {} {
+ global usec
+ return $usec
+}
+
+proc page_thelp {} {
+ return {}
+}
+
+proc page_toptions {} {
+ return {}
+}
+
+proc page_tconfigure {option value} {
+ return -code error "Cannot set value of unknown option \"$option\""
+}
+
+proc page_trun {data} {
+ global timed usec
+ page_log_info "transform/reachable/run/"
+
+ if {$timed} {
+ set usec [lindex [time {
+ ::struct::tree ::tree deserialize $data
+ ::page::analysis::peg::reachable::remove! ::tree
+ }] 0] ; #{}
+ } else {
+ ::struct::tree ::tree deserialize $data
+ ::page::analysis::peg::reachable::remove! ::tree
+ }
+
+ set data [::tree serialize]
+ ::tree destroy
+
+ page_log_info "transform/reachable/run/ok"
+ return $data
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::transform::reachable 0.1
diff --git a/tcllib/modules/page/plugins/transform_realizable.tcl b/tcllib/modules/page/plugins/transform_realizable.tcl
new file mode 100644
index 0000000..38efaeb
--- /dev/null
+++ b/tcllib/modules/page/plugins/transform_realizable.tcl
@@ -0,0 +1,106 @@
+# -*- tcl -*-
+# -- $Id: transform_realizable.tcl,v 1.1 2005/09/28 04:51:22 andreas_kupries Exp $ ---
+#
+# PAGE plugin - transform - realizable ~ Realizability Analysis
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_tdata | Access to processed input stream.
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_tfeature | Query for special plugin features page might wish to use.
+# page_ttime | Activate collection of timing statistics.
+# page_tgettime | Return the collected timing statistics.
+# page_tlabel | User readable label for the plugin.
+# page_thelp | Doctools help text for plugin.
+# page_toptions | Options understood by plugin.
+# page_tconfigure | Option (re)configuration.
+# page_trun | Transform input data per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::analysis::peg::realizable
+package require struct::tree ; # Data structure.
+
+global usec
+global timed
+set timed 0
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_tlabel {} {
+ return Realizability
+}
+
+proc page_tfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_ttime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_tgettime {} {
+ global usec
+ return $usec
+}
+
+proc page_thelp {} {
+ return {}
+}
+
+proc page_toptions {} {
+ return {}
+}
+
+proc page_tconfigure {option value} {
+ return -code error "Cannot set value of unknown option \"$option\""
+}
+
+proc page_trun {data} {
+ global timed usec
+ page_log_info "transform/realizable/run/"
+
+ if {$timed} {
+ set usec [lindex [time {
+ ::struct::tree ::tree deserialize $data
+ ::page::analysis::peg::realizable::remove! ::tree
+ }] 0] ; #{}
+ } else {
+ ::struct::tree ::tree deserialize $data
+ ::page::analysis::peg::realizable::remove! ::tree
+ }
+ set data [::tree serialize]
+ ::tree destroy
+
+ page_log_info "transform/realizable/run/ok"
+ return $data
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::transform::realizable 0.1
diff --git a/tcllib/modules/page/plugins/writer_hb.tcl b/tcllib/modules/page/plugins/writer_hb.tcl
new file mode 100644
index 0000000..711e62a
--- /dev/null
+++ b/tcllib/modules/page/plugins/writer_hb.tcl
@@ -0,0 +1,106 @@
+# -*- tcl -*-
+# -- $Id: writer_hb.tcl,v 1.1 2005/09/28 04:51:22 andreas_kupries Exp $ ---
+#
+# PAGE plugin - writer - HB ~ Half Baked / Tcl Peg Container
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_wdata | Access to processed input stream.
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_wfeature | Query for special plugin features page might wish to use.
+# page_wtime | Activate collection of timing statistics.
+# page_wgettime | Return the collected timing statistics.
+# page_wlabel | User readable label for the plugin.
+# page_whelp | Doctools help text for plugin.
+# page_woptions | Options understood by plugin.
+# page_wconfigure | Option (re)configuration.
+# page_wrun | Generate output from data per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::gen::peg::hb
+package require struct::tree ; # Data structure.
+
+global usec
+global timed
+set timed 0
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_wlabel {} {
+ return {Half baked PEG Container}
+}
+
+proc page_wfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_wtime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_wgettime {} {
+ global usec
+ return $usec
+}
+
+proc page_whelp {} {
+ return {}
+}
+
+proc page_woptions {} {
+ return {}
+}
+
+proc page_wconfigure {option value} {
+ return -code error "Cannot set value of unknown option \"$option\""
+}
+
+proc page_wrun {chan data} {
+ global timed usec
+ page_log_info "writer/hb/run/"
+
+ if {$timed} {
+ set usec [lindex [time {
+ ::struct::tree ::tree deserialize $data
+ page::gen::peg::hb ::tree $chan
+ }] 0] ; #{}
+ } else {
+ ::struct::tree ::tree deserialize $data
+ page::gen::peg::hb ::tree $chan
+ }
+
+ page_log_info "writer/hb/run/ok"
+
+ ::tree destroy
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::writer::hb 0.1
diff --git a/tcllib/modules/page/plugins/writer_identity.tcl b/tcllib/modules/page/plugins/writer_identity.tcl
new file mode 100644
index 0000000..b5d9cd4
--- /dev/null
+++ b/tcllib/modules/page/plugins/writer_identity.tcl
@@ -0,0 +1,98 @@
+# -*- tcl -*-
+# -- $Id: writer_identity.tcl,v 1.1 2005/09/28 04:51:22 andreas_kupries Exp $ ---
+#
+# PAGE plugin - writer - Generic dump
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_wdata | Access to processed input stream.
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_wfeature | Query for special plugin features page might wish to use.
+# page_wtime | Activate collection of timing statistics.
+# page_wgettime | Return the collected timing statistics.
+# page_wlabel | User readable label for the plugin.
+# page_whelp | Doctools help text for plugin.
+# page_woptions | Options understood by plugin.
+# page_wconfigure | Option (re)configuration.
+# page_wrun | Generate output from data per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+global usec
+global timed
+set timed 0
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_wlabel {} {
+ return {Raw data unchanged}
+}
+
+proc page_wfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_wtime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_wgettime {} {
+ global usec
+ return $usec
+}
+proc page_whelp {} {
+ return {}
+}
+
+proc page_woptions {} {
+ return {}
+}
+
+proc page_wconfigure {option value} {
+ return -code error "Cannot set value of unknown option \"$option\""
+}
+
+proc page_wrun {chan data} {
+ global timed usec
+ page_log_info "writer/identity/run/"
+
+ if {$timed} {
+ set usec [lindex [time {
+ puts $chan $data
+ }] 0] ; #{}
+ } else {
+ puts $chan $data
+ }
+
+ page_log_info "writer/identity/run/ok"
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::writer::identity 0.1
diff --git a/tcllib/modules/page/plugins/writer_me.tcl b/tcllib/modules/page/plugins/writer_me.tcl
new file mode 100644
index 0000000..5e4d6b1
--- /dev/null
+++ b/tcllib/modules/page/plugins/writer_me.tcl
@@ -0,0 +1,115 @@
+# -*- tcl -*-
+# -- $Id: writer_me.tcl,v 1.1 2005/09/28 04:51:22 andreas_kupries Exp $ ---
+#
+# PAGE plugin - writer - ME ~ Match Engine
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_wdata | Access to processed input stream.
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_wfeature | Query for special plugin features page might wish to use.
+# page_wtime | Activate collection of timing statistics.
+# page_wgettime | Return the collected timing statistics.
+# page_wlabel | User readable label for the plugin.
+# page_whelp | Doctools help text for plugin.
+# page_woptions | Options understood by plugin.
+# page_wconfigure | Option (re)configuration.
+# page_wrun | Generate output from data per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::gen::peg::me
+package require struct::tree ; # Data structure.
+
+global usec
+global timed
+set timed 0
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_wlabel {} {
+ return {MatchEngine RecDescent}
+}
+
+proc page_wfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_wtime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_wgettime {} {
+ global usec
+ return $usec
+}
+
+proc page_whelp {} {
+ return {}
+}
+
+proc page_woptions {} {
+ return {--package --copyright}
+}
+
+proc page_wconfigure {option value} {
+ switch -exact -- $option {
+ --package {
+ page::gen::peg::me::package $value
+ }
+ --copyright {
+ page::gen::peg::me::copyright $value
+ }
+ default {
+ return -code error "Cannot set value of unknown option \"$option\""
+ }
+ }
+}
+
+proc page_wrun {chan data} {
+ global timed usec
+ page_log_info "writer/me/run/"
+
+ if {$timed} {
+ set usec [lindex [time {
+ ::struct::tree ::tree deserialize $data
+ page::gen::peg::me ::tree $chan
+ }] 0] ; #{}
+ } else {
+ ::struct::tree ::tree deserialize $data
+ page::gen::peg::me ::tree $chan
+ }
+ page_log_info "writer/me/run/ok"
+
+ ::tree destroy
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::writer::me 0.1
diff --git a/tcllib/modules/page/plugins/writer_mecpu.tcl b/tcllib/modules/page/plugins/writer_mecpu.tcl
new file mode 100644
index 0000000..00e5508
--- /dev/null
+++ b/tcllib/modules/page/plugins/writer_mecpu.tcl
@@ -0,0 +1,116 @@
+# -*- tcl -*-
+# -- $Id: writer_mecpu.tcl,v 1.2 2007/03/21 23:15:53 andreas_kupries Exp $ ---
+#
+# PAGE plugin - writer - ME cpu ~ Match Engine CPU
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_wdata | Access to processed input stream.
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_wfeature | Query for special plugin features page might wish to use.
+# page_wtime | Activate collection of timing statistics.
+# page_wgettime | Return the collected timing statistics.
+# page_wlabel | User readable label for the plugin.
+# page_whelp | Doctools help text for plugin.
+# page_woptions | Options understood by plugin.
+# page_wconfigure | Option (re)configuration.
+# page_wrun | Generate output from data per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::gen::peg::mecpu
+
+global usec
+global timed
+set timed 0
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_wlabel {} {
+ return {ME cpu Assembler}
+}
+
+proc page_wfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_wtime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_wgettime {} {
+ global usec
+ return $usec
+}
+
+proc page_whelp {} {
+ return {}
+}
+
+proc page_woptions {} {
+ return {--package --copyright --template --cmarker}
+}
+
+proc page_wconfigure {option value} {
+ switch -exact -- $option {
+ --package {
+ page::gen::peg::mecpu::package $value
+ }
+ --copyright {
+ page::gen::peg::mecpu::copyright $value
+ }
+ --template {
+ page::gen::peg::mecpu::template $value
+ }
+ --cmarker {
+ page::gen::peg::mecpu::cmarker $value
+ }
+ default {
+ return -code error "Cannot set value of unknown option \"$option\""
+ }
+ }
+}
+
+proc page_wrun {chan data} {
+ global timed usec
+ page_log_info "writer/me-cpu/run/"
+
+ if {$timed} {
+ set usec [lindex [time {
+ page::gen::peg::mecpu $data $chan
+ }] 0] ; #{}
+ } else {
+ page::gen::peg::mecpu $data $chan
+ }
+ page_log_info "writer/me-cpu/run/ok"
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::writer::mecpu 0.1.1
diff --git a/tcllib/modules/page/plugins/writer_null.tcl b/tcllib/modules/page/plugins/writer_null.tcl
new file mode 100644
index 0000000..7d15b25
--- /dev/null
+++ b/tcllib/modules/page/plugins/writer_null.tcl
@@ -0,0 +1,97 @@
+# -*- tcl -*-
+# -- $Id: writer_null.tcl,v 1.1 2005/09/28 04:51:22 andreas_kupries Exp $ ---
+#
+# PAGE plugin - writer - NULL ~ /dev/null the output
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_wdata | Access to processed input stream.
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_wfeature | Query for special plugin features page might wish to use.
+# page_wtime | Activate collection of timing statistics.
+# page_wgettime | Return the collected timing statistics.
+# page_wlabel | User readable label for the plugin.
+# page_whelp | Doctools help text for plugin.
+# page_woptions | Options understood by plugin.
+# page_wconfigure | Option (re)configuration.
+# page_wrun | Generate output from data per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+global usec
+global timed
+set timed 0
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_wlabel {} {
+ return /dev/null
+}
+
+proc page_wfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_wtime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_wgettime {} {
+ global usec
+ return $usec
+}
+
+proc page_whelp {} {
+ return {}
+}
+
+proc page_woptions {} {
+ return {}
+}
+
+proc page_wconfigure {option value} {
+ return -code error "Cannot set value of unknown option \"$option\""
+}
+
+proc page_wrun {chan data} {
+ global timed usec
+ if {$timed} {
+ set usec [lindex [time {
+ page_log_info "writer/null/run/"
+ page_log_info "writer/null/run/ok"
+ }] 0] ; #{}
+ } else {
+ page_log_info "writer/null/run/"
+ page_log_info "writer/null/run/ok"
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::writer::null 0.1
diff --git a/tcllib/modules/page/plugins/writer_peg.tcl b/tcllib/modules/page/plugins/writer_peg.tcl
new file mode 100644
index 0000000..f8cd060
--- /dev/null
+++ b/tcllib/modules/page/plugins/writer_peg.tcl
@@ -0,0 +1,106 @@
+# -*- tcl -*-
+# -- $Id: writer_peg.tcl,v 1.1 2005/09/28 04:51:22 andreas_kupries Exp $ ---
+#
+# PAGE plugin - writer - PEG ~ Canonical PE Grammar
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_wdata | Access to processed input stream.
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_wfeature | Query for special plugin features page might wish to use.
+# page_wtime | Activate collection of timing statistics.
+# page_wgettime | Return the collected timing statistics.
+# page_wlabel | User readable label for the plugin.
+# page_whelp | Doctools help text for plugin.
+# page_woptions | Options understood by plugin.
+# page_wconfigure | Option (re)configuration.
+# page_wrun | Generate output from data per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::gen::peg::canon
+package require struct::tree ; # Data structure.
+
+global usec
+global timed
+set timed 0
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_wlabel {} {
+ return {Canonical PEG}
+}
+
+proc page_wfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_wtime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_wgettime {} {
+ global usec
+ return $usec
+}
+
+proc page_whelp {} {
+ return {}
+}
+
+proc page_woptions {} {
+ return {}
+}
+
+proc page_wconfigure {option value} {
+ return -code error "Cannot set value of unknown option \"$option\""
+}
+
+proc page_wrun {chan data} {
+ global timed usec
+ page_log_info "writer/peg/run/"
+
+ if {$timed} {
+ set usec [lindex [time {
+ ::struct::tree ::tree deserialize $data
+ page::gen::peg::canon ::tree $chan
+ }] 0] ; #{}
+ } else {
+ ::struct::tree ::tree deserialize $data
+ page::gen::peg::canon ::tree $chan
+ }
+
+ page_log_info "writer/peg/run/ok"
+
+ ::tree destroy
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::writer::peg 0.1
diff --git a/tcllib/modules/page/plugins/writer_ser.tcl b/tcllib/modules/page/plugins/writer_ser.tcl
new file mode 100644
index 0000000..3b977a2
--- /dev/null
+++ b/tcllib/modules/page/plugins/writer_ser.tcl
@@ -0,0 +1,104 @@
+# -*- tcl -*-
+# -- $Id: writer_ser.tcl,v 1.1 2005/09/28 04:51:22 andreas_kupries Exp $ ---
+#
+# PAGE plugin - writer - SER ~ Serialized PEG Container
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_wdata | Access to processed input stream.
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_wfeature | Query for special plugin features page might wish to use.
+# page_wtime | Activate collection of timing statistics.
+# page_wgettime | Return the collected timing statistics.
+# page_wlabel | User readable label for the plugin.
+# page_whelp | Doctools help text for plugin.
+# page_woptions | Options understood by plugin.
+# page_wconfigure | Option (re)configuration.
+# page_wrun | Generate output from data per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::gen::peg::ser
+package require struct::tree ; # Data structure.
+
+global usec
+global timed
+set timed 0
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_wlabel {} {
+ return {Serialized PEG Container}
+}
+
+proc page_wfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_wtime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_wgettime {} {
+ global usec
+ return $usec
+}
+proc page_whelp {} {
+ return {}
+}
+
+proc page_woptions {} {
+ return {}
+}
+
+proc page_wconfigure {option value} {
+ return -code error "Cannot set value of unknown option \"$option\""
+}
+
+proc page_wrun {chan data} {
+ global timed usec
+ page_log_info "writer/ser/run/"
+
+ if {$timed} {
+ set usec [lindex [time {
+ ::struct::tree ::tree deserialize $data
+ page::gen::peg::ser ::tree $chan
+ }] 0] ; #{}
+ } else {
+ ::struct::tree ::tree deserialize $data
+ page::gen::peg::ser ::tree $chan
+ }
+ page_log_info "writer/ser/run/ok"
+
+ ::tree destroy
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::writer::ser 0.1
diff --git a/tcllib/modules/page/plugins/writer_tpc.tcl b/tcllib/modules/page/plugins/writer_tpc.tcl
new file mode 100644
index 0000000..6b14328
--- /dev/null
+++ b/tcllib/modules/page/plugins/writer_tpc.tcl
@@ -0,0 +1,105 @@
+# -*- tcl -*-
+# -- $Id: writer_tpc.tcl,v 1.1 2005/09/28 04:51:22 andreas_kupries Exp $ ---
+#
+# PAGE plugin - writer - TPC ~ Tcl Peg Container
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_wdata | Access to processed input stream.
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_wfeature | Query for special plugin features page might wish to use.
+# page_wtime | Activate collection of timing statistics.
+# page_wgettime | Return the collected timing statistics.
+# page_wlabel | User readable label for the plugin.
+# page_whelp | Doctools help text for plugin.
+# page_woptions | Options understood by plugin.
+# page_wconfigure | Option (re)configuration.
+# page_wrun | Generate output from data per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::gen::peg::cpkg
+package require struct::tree ; # Data structure.
+
+global usec
+global timed
+set timed 0
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_wlabel {} {
+ return {Tcl PEG Container (Package)}
+}
+
+proc page_wfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_wtime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_wgettime {} {
+ global usec
+ return $usec
+}
+proc page_whelp {} {
+ return {}
+}
+
+proc page_woptions {} {
+ return {}
+}
+
+proc page_wconfigure {option value} {
+ return -code error "Cannot set value of unknown option \"$option\""
+}
+
+proc page_wrun {chan data} {
+ global timed usec
+ page_log_info "writer/tpc/run/"
+
+ if {$timed} {
+ set usec [lindex [time {
+ ::struct::tree ::tree deserialize $data
+ page::gen::peg::cpkg ::tree $chan
+ }] 0] ; #{}
+ } else {
+ ::struct::tree ::tree deserialize $data
+ page::gen::peg::cpkg ::tree $chan
+ }
+
+ page_log_info "writer/tpc/run/ok"
+
+ ::tree destroy
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::writer::tpc 0.1
diff --git a/tcllib/modules/page/plugins/writer_tree.tcl b/tcllib/modules/page/plugins/writer_tree.tcl
new file mode 100644
index 0000000..d02458e
--- /dev/null
+++ b/tcllib/modules/page/plugins/writer_tree.tcl
@@ -0,0 +1,105 @@
+# -*- tcl -*-
+# -- $Id: writer_tree.tcl,v 1.1 2005/09/28 04:51:22 andreas_kupries Exp $ ---
+#
+# PAGE plugin - writer - TREE ~ Generic Tree dump
+#
+
+# ### ### ### ######### ######### #########
+## Imported API
+
+# -----------------+--
+# page_wdata | Access to processed input stream.
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Exported API
+
+# -----------------+--
+# page_wfeature | Query for special plugin features page might wish to use.
+# page_wtime | Activate collection of timing statistics.
+# page_wgettime | Return the collected timing statistics.
+# page_wlabel | User readable label for the plugin.
+# page_whelp | Doctools help text for plugin.
+# page_woptions | Options understood by plugin.
+# page_wconfigure | Option (re)configuration.
+# page_wrun | Generate output from data per plugin configuration and hardwiring.
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::gen::tree::text
+package require struct::tree ; # Data structure.
+
+global usec
+global timed
+set timed 0
+
+# ### ### ### ######### ######### #########
+## Implementation of exported API
+
+proc page_wlabel {} {
+ return {Tree Dump}
+}
+
+proc page_wfeature {key} {
+ return [string eq $key timeable]
+}
+
+proc page_wtime {} {
+ global timed
+ set timed 1
+ return
+}
+
+proc page_wgettime {} {
+ global usec
+ return $usec
+}
+proc page_whelp {} {
+ return {}
+}
+
+proc page_woptions {} {
+ return {}
+}
+
+proc page_wconfigure {option value} {
+ return -code error "Cannot set value of unknown option \"$option\""
+}
+
+proc page_wrun {chan data} {
+ global timed usec
+ page_log_info "writer/tree/run/"
+
+ if {$timed} {
+ set usec [lindex [time {
+ ::struct::tree ::tree deserialize $data
+ page::gen::tree::text ::tree $chan
+ }] 0] ; #{}
+ } else {
+ ::struct::tree ::tree deserialize $data
+ page::gen::tree::text ::tree $chan
+ }
+
+ page_log_info "writer/tree/run/ok"
+
+ ::tree destroy
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper code.
+
+# ### ### ### ######### ######### #########
+## Initialization
+
+package provide page::writer::tree 0.1
diff --git a/tcllib/modules/page/util_flow.tcl b/tcllib/modules/page/util_flow.tcl
new file mode 100644
index 0000000..d8245ff
--- /dev/null
+++ b/tcllib/modules/page/util_flow.tcl
@@ -0,0 +1,90 @@
+# -*- tcl -*-
+# General tree iterative walking for dataflow algorithms.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require snit
+
+# ### ### ### ######### ######### #########
+## API
+
+namespace eval ::page::util::flow {}
+
+proc ::page::util::flow {start fvar nvar script} {
+ set f [uplevel 1 [list ::page::util::flow::iter %AUTO% $start $fvar $nvar $script]]
+ $f destroy
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internals
+
+snit::type ::page::util::flow::iter {
+ constructor {startset fvar nvar script} {
+ $self visitl $startset
+
+ # Export the object for use by the flow script
+ upvar 3 $fvar flow ; set flow $self
+ upvar 3 $nvar current
+
+ while {[array size visit]} {
+ set nodes [array names visit]
+ array unset visit *
+
+ foreach n $nodes {
+ set current $n
+ set code [catch {uplevel 3 $script} result]
+
+ # decide what to do upon the return code:
+ #
+ # 0 - the body executed successfully
+ # 1 - the body raised an error
+ # 2 - the body invoked [return]
+ # 3 - the body invoked [break]
+ # 4 - the body invoked [continue]
+ # everything else - return and pass on the results
+
+ switch -exact -- $code {
+ 0 {}
+ 1 {
+ return -errorinfo $::errorInfo \
+ -errorcode $::errorCode -code error $result
+ }
+ 3 {
+ # FRINK: nocheck
+ return -code break
+ }
+ 4 {}
+ default {
+ # This includes code 2 (return).
+ return -code $code $result
+ }
+ }
+ }
+ }
+ return
+ }
+
+ method visit {n} {
+ set visit($n) .
+ return
+ }
+
+ method visitl {nodelist} {
+ foreach n $nodelist {set visit($n) .}
+ return
+ }
+
+ method visita {args} {
+ foreach n $args {set visit($n) .}
+ return
+ }
+
+ variable visit -array {}
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::util::flow 0.1
diff --git a/tcllib/modules/page/util_norm_lemon.tcl b/tcllib/modules/page/util_norm_lemon.tcl
new file mode 100644
index 0000000..f604f81
--- /dev/null
+++ b/tcllib/modules/page/util_norm_lemon.tcl
@@ -0,0 +1,427 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Parser Generator / Transformation - Normalize PEG AST for later.
+
+# This package assumes to be used from within a PAGE plugin. It uses
+# the API commands listed below. These are identical across the major
+# types of PAGE plugins, allowing this package to be used in reader,
+# transform, and writer plugins. It cannot be used in a configuration
+# plugin, and this makes no sense either.
+#
+# To ensure that our assumption is ok we require the relevant pseudo
+# package setup by the PAGE plugin management code.
+#
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: page::plugin
+
+package require page::plugin ; # S.a. pseudo-package.
+package require treeql
+package require page::util::quote
+package require page::util::peg
+
+namespace eval ::page::util::norm::lemon {
+ # Get the peg char de/encoder commands.
+ # (unquote, quote'tcl)
+
+ namespace import ::page::util::quote::*
+ namespace import ::page::util::peg::*
+}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::util::norm::lemon {t} {
+ set q [treeql q -tree $t]
+
+ page_info {[Lemon Normalization]}
+
+ # Retrieve grammar name out of one directive.
+ # Or from LHS of first rule.
+
+ page_log_info ..Startsymbol
+
+ set start {}
+
+ $q query tree \
+ withatt type nonterminal \
+ withatt detail StartSymbol \
+ descendants \
+ withatt type terminal \
+ over n {
+
+ lemon::TokReduce $t $n detail
+ set start [$t get $n detail]
+
+ page_info " StartSymbol: $start"
+ }
+
+ $q query tree \
+ withatt type nonterminal \
+ withatt detail Name \
+ descendants \
+ withatt type terminal \
+ over n {
+
+ lemon::TokReduce $t $n detail
+ set name [$t get $n detail]
+
+ page_info " Name: $name"
+
+ $t set root name $name
+ }
+
+ page_log_info ..Drop ; lemon::Drop $q $t
+ page_log_info ..Terminals ; lemon::Terminals $q $t
+ page_log_info ..Definitions ; lemon::Definitions $q $t
+ page_log_info ..Rules ; lemon::Rules $q $t start
+ page_log_info ..Epsilon ; lemon::ElimEpsilon $q $t
+ page_log_info ..Autoclass ; lemon::AutoClassId $q $t
+ page_log_info ..Chains
+
+ # Find and cut operator chains, very restricted. Cut only chains
+ # of x- and /-operators. The other operators have only one child
+ # by definition and are thus not chains.
+
+ #set q [treeql q -tree $t]
+ # q query tree over n
+ foreach n [$t children -all root] {
+ if {[$t keyexists $n symbol]} continue
+ if {[llength [$t children $n]] != 1} continue
+
+ set op [$t get $n op]
+ if {($op ne "/") && ($op ne "x")} continue
+ $t cut $n
+ }
+
+ page_log_info ..Flatten
+
+ lemon::flatten $q $t
+
+ # Analysis: Left recursion, and where.
+ # Manual: Definitions for terminals.
+ # Definitions for space, comments.
+ # Integration of this into the grammar.
+
+ # Sentinel for PE algorithms.
+ $t set root symbol <StartExpression>
+
+ if {$start eq ""} {
+ page_error " Startsymbol missing"
+ } else {
+ set s [$t insert root end]
+ $t set $s op n
+ $t set $s sym $start
+ $t set root start $s
+
+ array set def [$t get root definitions]
+
+ if {![info exists def($start)]} {
+ page_error " Startsymbol is undefined"
+ $t set $s def ""
+ } else {
+ $t set $s def $def($start)
+ }
+ unset def
+ }
+
+ $q destroy
+
+ page_log_info Ok
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Documentation
+#
+## See doc_normalize.txt for the specification of the publicly visible
+## attributes.
+##
+## Internal attributes
+## - DATA - Transient storage for terminal data.
+
+# ### ### ### ######### ######### #########
+## Internal. Helpers
+
+proc ::page::util::norm::lemon::Drop {q t} {
+ # Simple normalization.
+ # All lemon specific data is dropped completely.
+
+ foreach drop {
+ Directive Codeblock Label Precedence
+ } {
+ $q query tree withatt type nonterminal \
+ withatt detail $drop over n {
+ $t delete $n
+ }
+ }
+
+ # Some nodes can be dropped, but not their children.
+
+ $q query tree withatt type nonterminal \
+ withatt detail Statement over n {
+ $t cut $n
+ }
+
+ # Cut the ALL and LemonGrammar nodes, direct access, no search
+ # needed.
+
+ $t cut [lindex [$t children root] 0]
+ $t cut [lindex [$t children root] 0]
+
+ return
+}
+
+proc ::page::util::norm::lemon::Terminals {q t} {
+ # The data for all terminals is stored in their grandparental
+ # nodes. We get rid of both terminals and their parents.
+
+ $q query tree withatt type terminal over n {
+ set p [$t parent $n]
+ set gp [$t parent $p]
+
+ CopyLocation $t $n $gp
+ AttrCopy $t $n detail $gp DATA
+ TokReduce $t $gp DATA
+ $t delete $p
+ }
+
+ # We can now drop the type attribute, as all the remaining nodes
+ # (which have it) will contain the value 'nonterminal'.
+
+ $q query tree hasatt type over n {
+ $t unset $n type
+ }
+ return
+}
+
+proc ::page::util::norm::lemon::Definitions {q t} {
+ # Convert 'Definition' into the sequences they are.
+ # Sequences of length one will be flattened later.
+ # Empty sequences (Length zero) are epsilon.
+ # Epsilon will be later converted to ? of the
+ # whole choice they are part of.
+
+ $q query tree withatt detail Definition over n {
+ $t unset $n detail
+
+ if {[$t children $n] < 1} {
+ $t set $n op epsilon
+ } else {
+ $t set $n op x
+ }
+ }
+ return
+}
+
+proc ::page::util::norm::lemon::Rules {q t sv} {
+ upvar $sv start
+ # We move nonterminal hint information from nodes into attributes,
+ # and delete the now irrelevant nodes.
+
+ # Like with the global metadata we move definition specific
+ # information out of nodes into attributes, get rid of the
+ # superfluous nodes, and tag the definition roots with marker
+ # attributes.
+
+ array set defs {}
+ $q query tree withatt detail Rule over n {
+ set first [Child $t $n 0]
+
+ set sym [$t get $first DATA]
+ $t set $n symbol $sym
+ $t set $n label $sym
+ $t set $n users {}
+ $t set $n mode value
+
+ if {$start eq ""} {
+ page_info " StartSymbol: $sym"
+ set start $sym
+ }
+
+ # We get the left extend of the definition from the terminal
+ # for the symbol it defines.
+
+ MergeLocations $t $first [Rightmost $t $n] $n
+ $t unset $n detail
+
+ lappend defs($sym) $n
+ $t cut $first
+ }
+
+ set d {}
+ foreach sym [array names defs] {
+ set nodes $defs($sym)
+ if {[llength $nodes] == 1} {
+ lappend d $sym [lindex $nodes 0]
+ } else {
+ # Merge multi-node definition together, under a choice.
+
+ set r [$t insert root end]
+ set c [$t insert $r end]
+
+ $t set $r symbol $sym
+ $t set $r label $sym
+ $t set $r users {}
+ $t set $r mode value
+ $t set $c op /
+
+ foreach n $nodes {
+ set seq [lindex [$t children $n] 0]
+ $t move $c end $seq
+ $t delete $n
+ }
+
+ lappend d $sym $r
+ }
+ }
+
+ # We remember a mapping from nonterminal names to their defining
+ # nodes in the root as well, for quick reference later, when we
+ # build nonterminal usage references
+
+ $t set root definitions $d
+ return
+}
+
+proc ::page::util::norm::lemon::Rightmost {t n} {
+ # Determine the rightmost leaf under the specified node.
+
+ if {[$t isleaf $n]} {return $n}
+ return [Rightmost $t [lindex [$t children $n] end]]
+}
+
+proc ::page::util::norm::lemon::ElimEpsilon {q t} {
+ # We convert choices with an epsilon in them into
+ # optional choices without an epsilon branch.
+
+ $q query tree withatt op epsilon over n {
+ set choice [$t parent $n]
+
+ # Move branches into the epsilon, which becomes the new
+ # choice. And the choice becomes an option.
+ foreach c [$t children $choice] {
+ if {$c eq $n} continue
+ $t move $n end $c
+ }
+ $t set $n op /
+ $t set $choice op ?
+ }
+ return
+}
+
+proc ::page::util::norm::lemon::AutoClassId {q t} {
+
+ array set defs [$t get root definitions]
+ array set use {}
+
+ $q query tree \
+ withatt op x \
+ children \
+ hasatt DATA \
+ over n {
+ # All identifiers are nonterminals, and for the
+ # undefined ones we create rules which define
+ # them as terminal sequences.
+
+ set sym [$t get $n DATA]
+ $t unset $n DATA
+
+ $t set $n op n
+ $t set $n sym $sym
+
+ if {![info exists defs($sym)]} {
+ set defs($sym) [NewTerminal $t $sym]
+ }
+ $t set $n def $defs($sym)
+
+ lappend use($sym) $n
+ $t unset $n detail
+ }
+
+ $t set root definitions [array get defs]
+
+ foreach sym [array names use] {
+ $t set $defs($sym) users $use($sym)
+ }
+
+ $t set root undefined {}
+ return
+}
+
+proc ::page::util::norm::lemon::NewTerminal {t sym} {
+ page_log_info " Terminal: $sym"
+
+ set r [$t insert root end]
+ $t set $r symbol $sym
+ $t set $r label $sym
+ $t set $r users {}
+ $t set $r mode leaf
+
+ set s [$t insert $r end]
+ $t set $s op x
+
+ foreach ch [split $sym {}] {
+ set c [$t insert $s end]
+ $t set $c op t
+ $t set $c char $ch
+ }
+ return $r
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Low-level helpers.
+
+proc ::page::util::norm::lemon::CopyLocation {t src dst} {
+ $t set $dst range [$t get $src range]
+ $t set $dst range_lc [$t get $src range_lc]
+ return
+}
+
+proc ::page::util::norm::lemon::MergeLocations {t srca srcb dst} {
+ set ar [$t get $srca range]
+ set arlc [$t get $srca range_lc]
+
+ set br [$t get $srcb range]
+ set brlc [$t get $srcb range_lc]
+
+ $t set $dst range [list [lindex $ar 0] [lindex $br 1]]
+ $t set $dst range_lc [list [lindex $arlc 0] [lindex $brlc 1]]
+ return
+}
+
+proc ::page::util::norm::lemon::AttrCopy {t src asrc dst adst} {
+ $t set $dst $adst [$t get $src $asrc]
+ return
+}
+
+proc ::page::util::norm::lemon::Child {t n index} {
+ return [lindex [$t children $n] $index]
+}
+
+proc ::page::util::norm::lemon::TokReduce {t src attr} {
+ set tokens [$t get $src $attr]
+ set ch {}
+ foreach tok $tokens {
+ lappend ch [lindex $tok 0]
+ }
+ $t set $src $attr [join $ch {}]
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::util::norm::lemon 0.1
diff --git a/tcllib/modules/page/util_norm_peg.tcl b/tcllib/modules/page/util_norm_peg.tcl
new file mode 100644
index 0000000..90405be
--- /dev/null
+++ b/tcllib/modules/page/util_norm_peg.tcl
@@ -0,0 +1,415 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Parser Generator / Transformation - Normalize PEG AST for later.
+
+# This package assumes to be used from within a PAGE plugin. It uses
+# the API commands listed below. These are identical across the major
+# types of PAGE plugins, allowing this package to be used in reader,
+# transform, and writer plugins. It cannot be used in a configuration
+# plugin, and this makes no sense either.
+#
+# To ensure that our assumption is ok we require the relevant pseudo
+# package setup by the PAGE plugin management code.
+#
+# -----------------+--
+# page_info | Reporting to the user.
+# page_warning |
+# page_error |
+# -----------------+--
+# page_log_error | Reporting of internals.
+# page_log_warning |
+# page_log_info |
+# -----------------+--
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: page::plugin
+
+package require page::plugin ; # S.a. pseudo-package.
+package require treeql
+package require page::util::quote
+
+namespace eval ::page::util::norm::peg {
+ # Get the peg char de/encoder commands.
+ # (unquote, quote'tcl)
+
+ namespace import ::page::util::quote::*
+}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::util::norm::peg {t} {
+ set q [treeql q -tree $t]
+
+ page_info {[PEG Normalization]}
+ page_log_info ..Terminals ; peg::Terminals $q $t
+ page_log_info ..Chains ; peg::CutChains $q $t
+ page_log_info ..Metadata ; peg::Metadata $q $t
+ page_log_info ..Definitions ; peg::Definitions $q $t
+ page_log_info ..Expressions ; peg::Expressions $q $t
+
+ # Sentinel for PE algorithms.
+ $t set root symbol <StartExpression>
+ $q destroy
+
+ page_log_info Ok
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Documentation
+#
+## See doc_normalize.txt for the specification of the publicly visible
+## attributes.
+##
+## Internal attributes
+## - DATA - Transient storage for terminal data.
+
+# ### ### ### ######### ######### #########
+## Internal. Helpers
+
+proc ::page::util::norm::peg::Terminals {q t} {
+ # The data for all terminals is stored in their grandparental
+ # nodes. We get rid of both terminals and their parents.
+
+ $q query tree withatt type terminal over n {
+ set p [$t parent $n]
+ set gp [$t parent $p]
+
+ CopyLocation $t $n $gp
+ AttrCopy $t $n detail $gp DATA
+ TokReduce $t $gp DATA
+ $t delete $p
+ }
+
+ # We can now drop the type attribute, as all the remaining nodes
+ # (which have it) will contain the value 'nonterminal'.
+
+ $q query tree hasatt type over n {
+ $t unset $n type
+ }
+ return
+}
+
+proc ::page::util::norm::peg::CutChains {q t} {
+ # All nodes which have exactly one child are irrelevant. We get
+ # rid of them. The root node is the sole exception. The immediate
+ # child of the root however is superfluous as well.
+
+ $q query tree notq {root} over n {
+ if {[llength [$t children $n]] != 1} continue
+ $t cut $n
+ }
+
+ foreach n [$t children root] {$t cut $n}
+ return
+}
+
+proc ::page::util::norm::peg::Metadata {q t} {
+ # Having the name of the grammar in a tree node is overkill. We
+ # move this information into an attribute of the root node.
+ # The node keeping the start expression separate is irrelevant as
+ # well. We get rid of it, and tag the root of the start expression
+ # with a marker attribute.
+
+ $q query tree withatt detail Header over n {
+ set tmp [Child $t $n 0]
+ set sexpr [Child $t $n 1]
+
+ AttrCopy $t $tmp DATA root name
+ $t cut $tmp
+ $t cut $n
+ break
+ }
+
+ # Remember the node for the start expression in the root for quick
+ # access by later stages.
+
+ $t set root start $sexpr
+ return
+}
+
+proc ::page::util::norm::peg::Definitions {q t} {
+ # We move nonterminal hint information from nodes into attributes,
+ # and delete the now irrelevant nodes.
+
+ # NOTE: This transformation is dependent on the removal of all
+ # nodes with exactly one child, as it removes the all 'Attribute'
+ # nodes already. Otherwise this transformation would have to put
+ # the information into the grandparental node.
+
+ # The default mode for nonterminals is 'value'.
+
+ $q query tree withatt detail Definition over n {
+ $t set $n mode value
+ }
+
+ foreach {a mode} {
+ VOID discard
+ MATCH match
+ LEAF leaf
+ } {
+ $q query tree withatt detail $a over n {
+ set p [$t parent $n]
+ $t set $p mode $mode
+ $t delete $n
+ }
+ }
+
+ # Like with the global metadata we move definition specific
+ # information out of nodes into attributes, get rid of the
+ # superfluous nodes, and tag the definition roots with marker
+ # attributes.
+
+ set defs {}
+ $q query tree withatt detail Definition over n {
+ # Define mode information for all nonterminals without an
+ # explicit specification. We also save the mode information
+ # from deletion when we redo the definition node.
+
+ set first [Child $t $n 0]
+
+ set sym [$t get $first DATA]
+ $t set $n symbol $sym
+ $t set $n label $sym
+ $t set $n users {}
+
+ # Now determine the range in the input covered by the
+ # definition. The left extent comes from the terminal for the
+ # nonterminal symbol it defines. The right extent comes from
+ # the rightmost child under the definition. While this not an
+ # expression tree yet the location data is sound already.
+
+ MergeLocations $t $first [Rightmost $t $n] $n
+ $t unset $n detail
+
+ lappend defs $sym $n
+ $t cut $first
+ }
+
+ # We remember a mapping from nonterminal names to their defining
+ # nodes in the root as well, for quick reference later, when we
+ # build nonterminal usage references
+
+ $t set root definitions $defs
+ return
+}
+
+proc ::page::util::norm::peg::Rightmost {t n} {
+ # Determine the rightmost leaf under the specified node.
+
+ if {[$t isleaf $n]} {return $n}
+ return [Rightmost $t [lindex [$t children $n] end]]
+}
+
+proc ::page::util::norm::peg::Expressions {q t} {
+ # We now transform the remaining nodes into proper expression
+ # trees. The order matters, to shed as much nodes as possible
+ # early, and to avoid unncessary work.
+
+ ExprRanges $q $t
+ ExprUnaryOps $q $t
+ ExprChars $q $t
+ ExprNonterminals $q $t
+ ExprOperators $q $t
+ ExprFlatten $q $t
+ return
+}
+
+proc ::page::util::norm::peg::ExprRanges {q t} {
+ # Ranges = .. operator
+
+ $q query tree withatt detail Range over n {
+ # Two the children, both of text 'Char', their data is what we
+ # take. The children become irrelevant and are removed.
+
+ foreach {b e} [$t children $n] break
+ set begin [unquote [$t get $b DATA]]
+ set end [unquote [$t get $e DATA]]
+
+ $t set $n op ..
+ $t set $n begin $begin
+ $t set $n end $end
+
+ MergeLocations $t $b $e $n
+
+ $t unset $n detail
+
+ $t delete $b
+ $t delete $e
+ }
+ return
+}
+
+proc ::page::util::norm::peg::ExprUnaryOps {q t} {
+ # Unary operators ... Their transformation sheds more nodes.
+
+ foreach {a op} {
+ QUESTION ?
+ STAR *
+ PLUS +
+ AND &
+ NOT !
+ } {
+ $q query tree withatt detail $a over n {
+ set p [$t parent $n]
+
+ $t set $p op $op
+ $t cut $n
+
+ $t unset $p detail
+ }
+ }
+ return
+}
+
+proc ::page::util::norm::peg::ExprChars {q t} {
+ # Chars = t operator (The remaining Char'acters are plain terminal
+ # symbols.
+
+ $q query tree withatt detail Char over n {
+ set ch [unquote [$t get $n DATA]]
+
+ $t set $n op t
+ $t set $n char $ch
+
+ $t unset $n detail
+ $t unset $n DATA
+ }
+ return
+}
+
+proc ::page::util::norm::peg::ExprNonterminals {q t} {
+ # Identifiers = n operator (nonterminal references) ...
+
+ array set defs [$t get root definitions]
+ array set undefined {}
+
+ $q query tree withatt detail Identifier over n {
+ set sym [$t get $n DATA]
+
+ $t set $n op n
+ $t set $n sym $sym
+
+ $t unset $n detail
+ $t unset $n DATA
+
+ # Create x-references between the users and the definition of
+ # a nonterminal symbol.
+
+ if {![info exists defs($sym)]} {
+ $t set $n def {}
+ lappend undefined($sym) $n
+ continue
+ } else {
+ set def $defs($sym)
+ $t set $n def $def
+ }
+
+ set users [$t get $def users]
+ lappend users $n
+ $t set $def users $users
+ }
+
+ $t set root undefined [array get undefined]
+ return
+}
+
+proc ::page::util::norm::peg::ExprOperators {q t} {
+ # The remaining operator nodes can be changed directly from node
+ # text to operator. Se we do.
+
+ foreach {a op} {
+ EPSILON epsilon
+ ALNUM alnum
+ ALPHA alpha
+ DOT dot
+ Literal x
+ Class /
+ Sequence x
+ Expression /
+ } {
+ $q query tree withatt detail $a over n {
+ $t set $n op $op
+ $t unset $n detail
+ }
+ }
+ return
+}
+
+proc ::page::util::norm::peg::ExprFlatten {q t} {
+ # Last tweaks of the expressions. Classes inside of Expressions,
+ # and Literals in Sequences create nested / or x expressions. We
+ # locate such and flatten the nested expression, cutting out the
+ # superfluous operator.
+
+ foreach op {x /} {
+ # Locate all x operators, whose parents are x operators as
+ # well, then go back to the child operators and cut them out.
+
+ $q query tree withatt op $op \
+ parent unique withatt op $op \
+ children withatt op $op \
+ over n {
+ $t cut $n
+ }
+
+ # Locate all x operators without children and convert them
+ # into epsilon operators. Because that is what they accept,
+ # nothing.
+
+ $q query tree withatt op $op over n {
+ if {[$t numchildren $n]} continue
+ $t set $n op epsilon
+ }
+ }
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Low-level helpers.
+
+proc ::page::util::norm::peg::CopyLocation {t src dst} {
+ $t set $dst range [$t get $src range]
+ $t set $dst range_lc [$t get $src range_lc]
+ return
+}
+
+proc ::page::util::norm::peg::MergeLocations {t srca srcb dst} {
+ set ar [$t get $srca range]
+ set arlc [$t get $srca range_lc]
+
+ set br [$t get $srcb range]
+ set brlc [$t get $srcb range_lc]
+
+ $t set $dst range [list [lindex $ar 0] [lindex $br 1]]
+ $t set $dst range_lc [list [lindex $arlc 0] [lindex $brlc 1]]
+ return
+}
+
+proc ::page::util::norm::peg::TokReduce {t src attr} {
+ set tokens [$t get $src $attr]
+ set ch {}
+ foreach tok $tokens {
+ lappend ch [lindex $tok 0]
+ }
+ $t set $src $attr [join $ch {}]
+ return
+}
+
+proc ::page::util::norm::peg::AttrCopy {t src asrc dst adst} {
+ $t set $dst $adst [$t get $src $asrc]
+ return
+}
+
+proc ::page::util::norm::peg::Child {t n index} {
+ return [lindex [$t children $n] $index]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::util::norm::peg 0.1
diff --git a/tcllib/modules/page/util_peg.tcl b/tcllib/modules/page/util_peg.tcl
new file mode 100644
index 0000000..172c26e
--- /dev/null
+++ b/tcllib/modules/page/util_peg.tcl
@@ -0,0 +1,209 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+
+## This package provides a number of utility commands to
+## transformations for common operations. It assumes a 'Normalized PE
+## Grammar Tree' as input, possibly augmented with attributes coming
+## from transformation not in conflict with the base definition.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require page::util::quote
+
+namespace eval ::page::util::peg {
+ namespace export \
+ symbolOf symbolNodeOf \
+ updateUndefinedDueRemoval \
+ flatten peOf printTclExpr \
+ getWarnings printWarnings
+
+ # Get the peg char de/encoder commands.
+ # (unquote, quote'tcl).
+
+ namespace import ::page::util::quote::*
+}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::util::peg::symbolNodeOf {t n} {
+ # Given an arbitrary root it determines the node (itself or an
+ # ancestor) containing the name of the nonterminal symbol the node
+ # belongs to, and returns its id. The result is either the root of
+ # the tree (for the start expression), or a definition mode.
+
+ while {![$t keyexists $n symbol]} {
+ set n [$t parent $n]
+ }
+ return $n
+}
+
+proc ::page::util::peg::symbolOf {t n} {
+ # As above, but returns the symbol name.
+
+ return [$t get [symbolNodeOf $t $n] symbol]
+}
+
+proc ::page::util::peg::updateUndefinedDueRemoval {t} {
+ # The removal of nodes may have caused symbols to lose one or more
+ # users. Example: A used by B and C, B is reachable, C is not, so A
+ # now loses a node in the expression for C calling it, or rather
+ # not anymore.
+
+ foreach {sym def} [$t get root definitions] {
+ set res {}
+ foreach u [$t get $def users] {
+ if {![$t exists $u]} continue
+ lappend res $u
+ }
+ $t set $def users $res
+ }
+
+ # Update the knowledge of undefined nonterminals. To be used when
+ # a transformation can remove invokations of undefined symbols,
+ # and is not able to generate such invokations.
+
+ set res {}
+ foreach {sym invokers} [$t get root undefined] {
+ set sres {}
+ foreach n $invokers {
+ if {![$t exists $n]} continue
+ lappend sres $n
+ }
+ if {[llength $sres]} {
+ lappend res $sym $sres
+ }
+ }
+ $t set root undefined $res
+ return
+}
+
+proc ::page::util::peg::flatten {q t} {
+ # Flatten nested x-, or /-operators.
+ # See peg_normalize.tcl, peg::normalize::ExprFlatten
+
+ foreach op {x /} {
+ # Locate all x operators, whose parents are x oerators as
+ # well, then go back to the child operators and cut them out.
+
+ $q query \
+ tree withatt op $op \
+ parent unique withatt op $op \
+ children withatt op $op \
+ over n {
+ $t cut $n
+ }
+ }
+ return
+}
+
+proc ::page::util::peg::getWarnings {t} {
+ # Look at the attributes for problems with the grammar and issue
+ # warnings. They do not prevent us from writing the grammar, but
+ # still represent problems with it the user should be made aware
+ # of.
+
+ array set msg {}
+ array set undefined [$t get root undefined]
+ foreach sym [array names undefined] {
+ set msg($sym) {}
+ foreach ref $undefined($sym) {
+ lappend msg($sym) "Undefined symbol used by the definition of '[symbolOf $t $ref]'."
+ }
+ }
+
+ foreach {sym def} [$t get root definitions] {
+ if {[llength [$t get $def users]] == 0} {
+ set msg($sym) [list "This symbol has been defined, but is not used."]
+ }
+ }
+
+ return [array get msg]
+}
+
+proc ::page::util::peg::printWarnings {msg} {
+ if {![llength $msg]} return
+
+ set dict {}
+ set max -1
+ foreach {k v} $msg {
+ set l [string length [list $k]]
+ if {$l > $max} {set max $l}
+ lappend dict [list $k $v $l]
+ }
+
+ foreach e [lsort -dict -index 0 $dict] {
+ foreach {k msgs l} $e break
+
+ set off [string repeat " " [expr {$max - $l}]]
+ page_info "[list $k]$off : [lindex $msgs 0]"
+
+ if {[llength $msgs] > 1} {
+ set indent [string repeat " " [string length [list $k]]]
+ foreach m [lrange $msgs 1 end] {
+ puts stderr " $indent$off : $m"
+ }
+ }
+ }
+ return
+}
+
+proc ::page::util::peg::peOf {t eroot} {
+ set op [$t get $eroot op]
+ set pe [list $op]
+
+ set ch [$t children $eroot]
+
+ if {[llength $ch]} {
+ foreach c $ch {
+ lappend pe [peOf $t $c]
+ }
+ } elseif {$op eq "n"} {
+ lappend pe [$t get $eroot sym]
+ } elseif {$op eq "t"} {
+ lappend pe [unquote [$t get $eroot char]]
+ } elseif {$op eq ".."} {
+ lappend pe \
+ [unquote [$t get $eroot begin]] \
+ [unquote [$t get $eroot end]]
+
+ }
+ return $pe
+}
+
+proc ::page::util::peg::printTclExpr {pe} {
+ list [PrintExprSub $pe]
+}
+
+# ### ### ### ######### ######### #########
+## Internal
+
+proc ::page::util::peg::PrintExprSub {pe} {
+ set op [lindex $pe 0]
+ set args [lrange $pe 1 end]
+
+ #puts stderr "PE [llength $args] $op | $args"
+
+ if {$op eq "t"} {
+ set a [lindex $args 0]
+ return "$op [quote'tcl $a]"
+ } elseif {$op eq ".."} {
+ set a [lindex $args 0]
+ set b [lindex $args 1]
+ return "$op [quote'tcl $a] [quote'tcl $b]"
+ } elseif {$op eq "n"} {
+ return $pe
+ } else {
+ set res $op
+ foreach a $args {
+ lappend res [PrintExprSub $a]
+ }
+ return $res
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::util::peg 0.1
diff --git a/tcllib/modules/page/util_quote.tcl b/tcllib/modules/page/util_quote.tcl
new file mode 100644
index 0000000..6c7b65e
--- /dev/null
+++ b/tcllib/modules/page/util_quote.tcl
@@ -0,0 +1,173 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Parser Generator / (Un)quoting characters.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+namespace eval ::page::util::quote {
+ namespace export unquote \
+ quote'tcl quote'tclstr quote'tclcom
+}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::page::util::quote::unquote {ch} {
+ # A character, as stored in the grammar tree
+ # by the frontend is transformed into a proper
+ # Tcl character (internal representation).
+
+ switch -exact -- $ch {
+ "\\n" {return \n}
+ "\\t" {return \t}
+ "\\r" {return \r}
+ "\\[" {return \[}
+ "\\]" {return \]}
+ "\\'" {return '}
+ "\\\"" {return "\""}
+ "\\\\" {return \\}
+ }
+
+ if {[regexp {^\\([0-2][0-7][0-7])$} $ch -> ocode]} {
+ return [format %c $ocode]
+ } elseif {[regexp {^\\([0-7][0-7]?)$} $ch -> ocode]} {
+ return [format %c 0$ocode]
+ } elseif {[regexp {^\\u([0-9a-fA-F][0-9a-fA-F]?[0-9a-fA-F]?[0-9a-fA-F]?)$} $ch -> hcode]} {
+ return [format %c 0x$hcode]
+ }
+
+ return $ch
+}
+
+proc ::page::util::quote::quote'tcl {ch} {
+ # Converts a Tcl character (internal representation)
+ # into a string which is accepted by the Tcl parser,
+ # will regenerate the character in question and is
+ # 7bit ASCII. 'quoted' is a boolean flag and set if
+ # the returned representation is a \-quoted form.
+ # Because they have to be treated specially when
+ # creating a list containing the reperesentation.
+
+ # Special characters
+
+ switch -exact -- $ch {
+ "\n" {return "\\n"}
+ "\r" {return "\\r"}
+ "\t" {return "\\t"}
+ "\\" - "\;" -
+ " " - "\"" -
+ "(" - ")" -
+ "\{" - "\}" -
+ "\[" - "\]" {
+ # Quote space and all the brackets as well, using octal,
+ # for easy impure list-ness.
+
+ scan $ch %c chcode
+ return \\[format %o $chcode]
+ }
+ }
+
+ scan $ch %c chcode
+
+ # Control characters: Octal
+ if {[string is control -strict $ch]} {
+ return \\[format %o $chcode]
+ }
+
+ # Beyond 7-bit ASCII: Unicode
+
+ if {$chcode > 127} {
+ return \\u[format %04x $chcode]
+ }
+
+ # Regular character: Is its own representation.
+
+ return $ch
+}
+
+proc ::page::util::quote::quote'tclstr {ch} {
+ # Converts a Tcl character (internal representation)
+ # into a string which is accepted by the Tcl parser and will
+ # generate a human readable representation of the character in
+ # question, one which when puts to a channel describes the
+ # character without using any unprintable characters. It may use
+ # \-quoting. High utf characters are quoted to avoid problem with
+ # the still prevalent ascii terminals. It is assumed that the
+ # string will be used in a ""-quoted environment.
+
+ # Special characters
+
+ switch -exact -- $ch {
+ " " {return "<blank>"}
+ "\n" {return "\\\\n"}
+ "\r" {return "\\\\r"}
+ "\t" {return "\\\\t"}
+ "\"" - "\\" - "\;" -
+ "(" - ")" -
+ "\{" - "\}" -
+ "\[" - "\]" {
+ return \\$ch
+ }
+ }
+
+ scan $ch %c chcode
+
+ # Control characters: Octal
+ if {[string is control -strict $ch]} {
+ return \\\\[format %o $chcode]
+ }
+
+ # Beyond 7-bit ASCII: Unicode
+
+ if {$chcode > 127} {
+ return \\\\u[format %04x $chcode]
+ }
+
+ # Regular character: Is its own representation.
+
+ return $ch
+}
+
+proc ::page::util::quote::quote'tclcom {ch} {
+ # Converts a Tcl character (internal representation)
+ # into a string which is accepted by the Tcl parser when used
+ # within a Tcl comment.
+
+ # Special characters
+
+ switch -exact -- $ch {
+ " " {return "<blank>"}
+ "\n" {return "\\n"}
+ "\r" {return "\\r"}
+ "\t" {return "\\t"}
+ "\"" -
+ "\{" - "\}" -
+ "(" - ")" {
+ return \\$ch
+ }
+ }
+
+ scan $ch %c chcode
+
+ # Control characters: Octal
+ if {[string is control -strict $ch]} {
+ return \\[format %o $chcode]
+ }
+
+ # Beyond 7-bit ASCII: Unicode
+
+ if {$chcode > 127} {
+ return \\u[format %04x $chcode]
+ }
+
+ # Regular character: Is its own representation.
+
+ return $ch
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide page::util::quote 0.1
diff --git a/tcllib/modules/pki/CA.crt b/tcllib/modules/pki/CA.crt
new file mode 100644
index 0000000..5308bad
--- /dev/null
+++ b/tcllib/modules/pki/CA.crt
@@ -0,0 +1,24 @@
+-----BEGIN CERTIFICATE-----
+MIIEBjCCAu6gAwIBAgIJAJsptsQf3TXPMA0GCSqGSIb3DQEBBQUAMF8xCzAJBgNV
+BAYTAlVTMRAwDgYDVQQIEwdGbG9yaWRhMQ4wDAYDVQQHEwVUYW1wYTEPMA0GA1UE
+ChMGVGNsbGliMQwwCgYDVQQLEwNSU0ExDzANBgNVBAMTBlRlc3RDQTAeFw0xMDA4
+MDkwNzM3MzhaFw0zNTA4MTAwNzM3MzhaMF8xCzAJBgNVBAYTAlVTMRAwDgYDVQQI
+EwdGbG9yaWRhMQ4wDAYDVQQHEwVUYW1wYTEPMA0GA1UEChMGVGNsbGliMQwwCgYD
+VQQLEwNSU0ExDzANBgNVBAMTBlRlc3RDQTCCASIwDQYJKoZIhvcNAQEBBQADggEP
+ADCCAQoCggEBAL9llE7rpNUW+YI8rdQgoG40E/FMMu2h9/6pVzCtILqOLFlSMSIQ
+4CxKhIzPuiP+BSufNXmeMXSueifuT2mlb5ap6T2tmd5Vi09um5xw3Spu2Juz7Zfj
+LDFnsMxuF3U4Qwl/9qEydmhtDnYATC8iRicXsPGvNVeTZgX3iZzzA3uFkD6NVEki
+X1X3MgmE8eCGTw4U/k3MIK7wPQtZMSO4Aey9I/ub5ieZrAK0yZLjiubP27gb8ZIJ
+wK2EXI2lZZH6g8JML7RwW5Yr0VoczEf79wKAUi15xQKfh+gxVzTnuKgdJ/ZMyzcW
++Pdap1YlHfewQfxeHBt60Rkr2x2UFU4hLIECAwEAAaOBxDCBwTAdBgNVHQ4EFgQU
+hSwdCbdrD6EONdeqS8tIst6yVNUwgZEGA1UdIwSBiTCBhoAUhSwdCbdrD6EONdeq
+S8tIst6yVNWhY6RhMF8xCzAJBgNVBAYTAlVTMRAwDgYDVQQIEwdGbG9yaWRhMQ4w
+DAYDVQQHEwVUYW1wYTEPMA0GA1UEChMGVGNsbGliMQwwCgYDVQQLEwNSU0ExDzAN
+BgNVBAMTBlRlc3RDQYIJAJsptsQf3TXPMAwGA1UdEwQFMAMBAf8wDQYJKoZIhvcN
+AQEFBQADggEBAL7Uhodh2ATX4IvsGqryZdLVnG9TkMn9o8ge9EUupYtt9/9/K+My
+dqXCHVuKwMYr5V5S5HAQxwTTQ4ByPaLYz+V8dumyBOdSp5l5x5NWJ+2oCn/DpL7U
+9ezqL9gzEf5AVLxigSo/V5c4uUpE4K3tbGHDVpF1z7OT6LOpkvWui1FpLQoDc9HK
+BmT1J+fQSHfsScV65T6qsQAGPUyRXqh79LIrY0ZWvDun5xy13KmCk37Gc2+fCx2m
+QEJFyaCMojsCfJz2XRtBtwn8bpBnFUP187f4snkU5Ga/5TjQGq6YBP2BWR8W3tM0
+zGk5KboIltjQSbW9KYVratpF+gp3e6ni9B0=
+-----END CERTIFICATE-----
diff --git a/tcllib/modules/pki/CA.key b/tcllib/modules/pki/CA.key
new file mode 100644
index 0000000..ca1df73
--- /dev/null
+++ b/tcllib/modules/pki/CA.key
@@ -0,0 +1,30 @@
+-----BEGIN RSA PRIVATE KEY-----
+Proc-Type: 4,ENCRYPTED
+DEK-Info: DES-EDE3-CBC,8C1A2E69ACFC3E90
+
+GVnzdBMa+GX2u4jOpSYU6P1JBQYbB9FRrfB/0QGdhKHU2OPEZzYZo2LwgpEBVMWT
+dVsbBECil4h0UnUsC/+DmJPv/SF++VJK8JvtO2opNCmeYrH5VAwqN2tqIXX2sWng
+9Fk7HVjsLfTUvw6nc5TI07qK2okGcT9yMTjEGXKPLkMs5K16gKoMHf5yQPQmOpfR
+HrE8odoPib1JKDV9j4FYjfBEja7Y4GLFbNobvaQIvA/pbKE4mGkGczn6vjdkGTbv
+wAI0fIWqfOnfE+VlSz9lT4mOVHt6x4WQbfUgJKf29pL9DH+I22K2cgzGwMLzLot3
+IhPiO6coFfLOKKNbRv4gtxTjXvnlwm217GDoEPgDKG1qwWzjSwI8DBsLjMhKHDfz
+0ScyItR3wkTVaTE0sQYFS5VmKzgH2rQ8ichk4AUzM5+myxg1ALKi9GRtIKKbY+0H
+EseYxzbRhTSVo0GPGiu8j6BVK40uynF4ydrjlETQsJhZZTeJPjPGNh6m3eP5zW0Q
+Im8UgW6ZZumzINJPrEKrwRF7qEGSLRv3lkMOj08sYFsSqFnBex90cov1pJOUCCAL
+mBgLFFb6P9kEAqZOnNcwrohcf8gmW1pATTgT1+y0OTC1rEJ+asvCn6yN2QkhyNqq
+vabFqxyWxVi9MsodP4+eY9Hjhl5WwkuVCnBG69HugOFvVKHIpGxfQjSnQNaYfI6a
+UKLixw0ZdfWN8sNG4gcisj/O/VHKbEWwp+N452lTzzFE7+QvCtg6rn+LPLEyTZRb
+b7QQc6CcqELL4qksm/FNP8pIyGfsUKYVE79FDK+mxDxZpWEMJ6J6dwj1jwzGbMnP
+5sgmAeaSinkqUQf/4AoiU1eIj1fiXHcsub7mFzzBP9NKQZ4YrkBeu7zfsP8Ex5Ol
+W3WmKIkw2MBG9Q0dP3HQBDw5k35X5ydJvrtaRJLDZZDwA24WcyKffYUHGV4KhsxC
+Vjzkth+MkBaPAtB35tRlr1Fr0wC6MNTeZOuPNgGM+t1ejg1NPN722J+ihne05KW/
+wzBgz3veeJeUlxRPZl0Sklct029fV+pZGwxlx72hMiyBwDh9pBhmIjWJFzuQ35CG
+DNZm1spGcDU9sd1y1txS+QVd3CDP7a5CrUuI7S8FYJEREGzWGn/dF9hxrbeLLXRf
+qvcUwCAobFfV14Z1cwoxZ9MWTXBYynxUYO7TYajb/6vIvYOAQ3DGSPelvNRsrilT
+GV0CJ1Mx6JEaTzGQQeB2JxO09T0qxKMT6h4BbLhZRledmrI/Pvp/roUmnvdE3kBn
+MkRUxzGBD9EBPA02F2paDRxXPZRHvpGomvP32JL7AJ8tln8z4TsHclpls0E7dmk9
+KKQSLk1DOUjarJhPHmGyDOn9tVdgzbfyQjdmZ1wxBvYbBuqS82FcoWohF2GnyYAm
+X7tdS9AVNDErVXOmqh2hcYFY3NFBLy0altpMaTVqTx1SwkpHh6YGt9ioltzP7kxz
+wxHz/w4DPrxaUOFYZX9dffGceFf5/h2DfhqobnwZuCgDo7SDUKJI0f88bR+1d1q6
+qr2T9ZuzIPIllMzGVfNwq5WsPy+klq/lK0QRl6RZdLEM0Q5h6WOYeoxpOGjW6E1h
+-----END RSA PRIVATE KEY-----
diff --git a/tcllib/modules/pki/ChangeLog b/tcllib/modules/pki/ChangeLog
new file mode 100644
index 0000000..55d47a6
--- /dev/null
+++ b/tcllib/modules/pki/ChangeLog
@@ -0,0 +1,30 @@
+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-11-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * MD5SUMS: Updated to version 0.2, by Roy Keene.
+ * pkgIndex.tcl:
+ * pki.man:
+ * pki.tcl:
+ * pki.test:
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2010-10-08 Andreas Kupries <andreask@activestate.com>
+
+ * New module: PKI, Public Key Infrastructure. By Roy Keene.
+
diff --git a/tcllib/modules/pki/pkgIndex.tcl b/tcllib/modules/pki/pkgIndex.tcl
new file mode 100644
index 0000000..3892c58
--- /dev/null
+++ b/tcllib/modules/pki/pkgIndex.tcl
@@ -0,0 +1 @@
+package ifneeded pki 0.6 [list source [file join $dir pki.tcl]]
diff --git a/tcllib/modules/pki/pki.man b/tcllib/modules/pki/pki.man
new file mode 100644
index 0000000..c74ce7d
--- /dev/null
+++ b/tcllib/modules/pki/pki.man
@@ -0,0 +1,302 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin pki n 0.6]
+[see_also aes(n)]
+[see_also blowfish(n)]
+[see_also des(n)]
+[see_also md5(n)]
+[see_also sha1(n)]
+[keywords cipher]
+[keywords {data integrity}]
+[keywords encryption]
+[keywords {public key cipher}]
+[keywords rsa]
+[keywords security]
+[copyright {2010, 2011, 2012, 2013, Roy Keene, Andreas Kupries}]
+[moddesc {public key encryption}]
+[titledesc {Implementation of the public key cipher}]
+[category {Hashes, checksums, and encryption}]
+[require Tcl 8.5]
+[require pki [opt 0.6]]
+[description]
+[para]
+
+[section {COMMANDS}]
+
+[list_begin definitions]
+
+[call [cmd "::pki::encrypt"] \
+ [opt [arg "-binary"]] \
+ [opt [arg "-hex"]] \
+ [opt [arg "-pad"]] \
+ [opt [arg "-nopad"]] \
+ [opt [arg "-priv"]] \
+ [opt [arg "-pub"]] \
+ [opt [arg "--"]] \
+ [arg input] [arg key]]
+
+Encrypt a message using PKI (probably RSA).
+
+Requires the caller to specify either [option -priv] to encrypt with
+the private key or [option -pub] to encrypt with the public key. The
+default option is to pad and return in hex. One of [option -pub] or
+[option -priv] must be specified.
+
+The [option -hex] option causes the data to be returned in encoded as
+a hexidecimal string, while the [option -binary] option causes the data
+to be returned as a binary string. If they are specified multiple
+times, the last one specified is used.
+
+The [option -pad] option causes the data to be padded per PKCS#1 prior
+to being encrypted. The [option -nopad] inhibits this behaviour. If
+they are specified multiple times, the last one specified is used.
+
+[comment {
+ What happens when both are specified ?
+ -- Last one specified takes precedence
+ What happens when none are specified ?
+ -- Error is generated for "-priv/-pub", defaults to -hex -pad
+
+ What are -hex, -binary ?
+ -- Results stored in hex or binary, like sha1::sha1's -hex/-bin
+ What are -pad, -nopad ?
+ -- Whether or not to pad the input per PKCS#1
+
+ Could it be sensible to use "-encoding binary|hex" instead ?
+ -- Yes, but I was trying to be similar to existing modules
+ Could it be sensible to use "-pad <bool>" ?
+ -- Yes
+ With suitable defaults ?
+}]
+
+The input to encrypt is specified as [arg input].
+
+The [arg key] parameter, holding the key to use, is a return value
+from either
+[cmd ::pki::pkcs::parse_key],
+[cmd ::pki::x509::parse_cert], or
+[cmd ::pki::rsa::generate].
+
+[para] Mapping to OpenSSL's [syscmd openssl] application:
+[list_begin enumerated]
+[enum] "openssl rsautl -encrypt" == "::pki::encrypt -binary -pub"
+[enum] "openssl rsautl -sign" == "::pki::encrypt -binary -priv"
+[list_end]
+
+[call [cmd "::pki::decrypt"] \
+ [opt [arg "-binary"]] \
+ [opt [arg "-hex"]] \
+ [opt [arg "-unpad"]] \
+ [opt [arg "-nounpad"]] \
+ [opt [arg "-priv"]] \
+ [opt [arg "-pub"]] \
+ [opt [arg "--"]] \
+ [arg input] [arg key]]
+
+Decrypt a message using PKI (probably RSA). See [cmd ::pki::encrypt] for option handling.
+
+[para] Mapping to OpenSSL's [syscmd openssl] application:
+[list_begin enumerated]
+[enum] "openssl rsautl -decrypt" == "::pki::decrypt -binary -priv"
+[enum] "openssl rsautl -verify" == "::pki::decrypt -binary -pub"
+[list_end]
+
+[call [cmd ::pki::sign] [arg input] [arg key] [opt [arg algo]]]
+
+Digitally sign message [arg input] using the private [arg key]. If [arg algo]
+is ommited "sha1" is assumed. Possible values for [arg algo] include
+"md5", "sha1", "sha256", and "raw". Specifyin "raw" for [arg algo] will
+inhibit the building of an ASN.1 structure to encode which hashing
+algorithm was chosen.
+
+The [arg input] should be the plain text, hashing will be performed on it.
+
+The [arg key] should include the private key.
+
+[comment {
+ What is the default for algo?
+ -- sha1
+ What choices for algo has the user ?
+ -- md5, sha1, sha256, and "raw" currently
+}]
+
+[call [cmd ::pki::verify] [arg signedmessage] [arg plaintext] [arg key] [opt [arg algo]]]
+
+Verify a digital signature using a public [arg key]. Returns true or false.
+
+[comment {
+ What is the default for algo?
+ -- The default is to look at the data for the OID of the algorithm, but if it was signed "raw" it will need to be specified. It's actually ignored right now.
+ What choices for algo has the user ?
+ -- md5, sha1, sha256
+
+ NOTE: Why is the result OK and ?
+
+ I would have expected a simple boolean value.
+ -- It's probably reasonable to change it. It's more likely to generate an error than return failed.
+}]
+
+[call [cmd ::pki::key] [arg key] [opt [arg password]] [opt [arg encodePem]]]
+
+Convert a key structure into a serialized PEM (default) or DER encoded private key suitable for other applications. For RSA keys this means PKCS#1.
+
+[call [cmd ::pki::pkcs::parse_key] [arg key] [opt [arg password]]]
+
+Convert a PKCS#1 private [arg key] into a usable key, i.e. one which
+can be used as argument for
+[cmd ::pki::encrypt],
+[cmd ::pki::decrypt],
+[cmd ::pki::sign], and
+[cmd ::pki::verify].
+
+[comment {
+ What is the default for password?
+ What choices for password has the user ?
+}]
+
+[call [cmd ::pki::x509::parse_cert] [arg cert]]
+
+Convert an X.509 certificate to a usable (public) key, i.e. one which
+can be used as argument for
+[cmd ::pki:encrypt],
+[cmd ::pki::decrypt], and
+[cmd ::pki::verify].
+
+The [arg cert] argument can be either PEM or DER encoded.
+
+[call [cmd ::pki::rsa::generate] [arg bitlength] [opt [arg exponent]]]
+
+Generate a new RSA key pair, the parts of which can be used as
+argument for
+[cmd ::pki::encrypt],
+[cmd ::pki::decrypt],
+[cmd ::pki::sign], and
+[cmd ::pki::verify].
+
+The [arg bitlength] argument is the length of the public key modulus.
+
+The [arg exponent] argument should generally not be specified unless
+you really know what you are doing.
+
+[comment {
+ What is the default for exponent?
+ -- 65537 (0x10001)
+ What choices for exponent has the user ?
+ -- Any value, but it should be chosen wisely. This is the "RSA exponent" and small values may represent a security risk.
+}]
+
+[call [cmd ::pki::x509::verify_cert] [arg cert] [arg trustedcerts] [opt [arg intermediatecerts]]]
+
+Verify that a trust can be found between the certificate specified in the
+[arg cert] argument and one of the certificates specified in the list
+of certificates in the [arg trustedcerts] argument. (Eventually the
+chain can be through untrusted certificates listed in the [arg intermediatecerts]
+argument, but this is currently unimplemented).
+
+The certificates specified in the [arg cert] and [arg trustedcerts] option
+should be parsed (from [cmd ::pki::x509::parse_cert]).
+
+[call [cmd ::pki::x509::validate_cert] \
+ [arg cert] \
+ [opt "[option -sign_message] [arg dn_of_signer]"] \
+ [opt "[option -encrypt_message] [arg dn_of_signer]"] \
+ [opt "[option -sign_cert] [arg dn_to_be_signed] [arg ca_depth]"] \
+ [opt "[option -ssl] [arg dn]"] \
+]
+
+Validate that a certificate is valid to be used in some capacity. If
+multiple options are specified they must all be met for this procedure
+to return "true".
+
+Currently, only the [option "-sign_cert"] option is functional.
+
+Arguments for the [option "-sign_cert"] option are [arg dn_to_be_signed]
+and [arg ca_depth]. The [arg dn_to_be_signed] is the distinguished from
+the subject of a certificate to verify that the certificate specified in
+the [arg cert] argument can sign. The [arg ca_depth] argument is used to
+indicate at which depth the verification should be done at. Some
+certificates are limited to how far down the chain they can be used to
+verify a given certificate.
+
+[call [cmd ::pki::pkcs::create_csr] [arg keylist] [arg namelist] [opt [arg encodePem]] [opt [arg algo]]]
+
+Generate a certificate signing request from a key pair specified in
+the [arg keylist] argument.
+
+The [arg namelist] argument is a list of "name" followed by "value"
+pairs to encoding as the requested distinguished name in the CSR.
+
+The [arg encodePem] option specifies whether or not the result should
+be PEM encoded or DER encoded. A "true" value results in the result
+being PEM encoded, while any other value 9results in the the result
+being DER encoded. DER encoding is the default.
+
+The [arg algo] argument specifies the hashing algorithm we should use
+to sign this certificate signing request with. The default is "sha1".
+Other possible values include "md5" and "sha256".
+
+[call [cmd ::pki::pkcs::parse_csr] [arg csr]]
+
+Parse a Certificate Signing Request. The [arg csr] argument can be
+either PEM or DER encoded.
+
+[call [cmd ::pki::x509::create_cert] [arg signreqlist] [arg cakeylist] [arg serial_number] [arg notBefore] [arg notAfter] [arg isCA] [arg extensions] [opt [arg encodePem]] [opt [arg algo]]]
+
+Sign a signing request (usually from [cmd ::pki::pkcs::create_csr] or
+[cmd ::pki::pkcs::parse_csr]) with a Certificate Authority (CA) certificate.
+
+The [arg signreqlist] argument should be the parsed signing request.
+
+The [arg cakeylist] argument should be the parsed CA certificate.
+
+The [arg serial_number] argument should be a serial number unique to
+this certificate from this certificate authority.
+
+The [arg notBefore] and [arg notAfter] arguments should contain the
+time before and after which (respectively) the certificate should
+be considered invalid. The time should be encoded as something
+[cmd "clock format"] will accept (i.e., the results of [cmd "clock seconds"]
+and [cmd "clock add"]).
+
+The [arg isCA] argument is a boolean argumen describing whether or not
+the signed certificate should be a a CA certificate. If specified as
+true the "id-ce-basicConstraints" extension is added with the arguments
+of "critical" being true, "allowCA" being true, and caDepth being
+-1 (infinite).
+
+The [arg extensions] argument is a list of extensions and their parameters
+that should be encoded into the created certificate. Currently only one
+extension is understood ("id-ce-basicConstraints"). It accepts three
+arguments [arg critical] [arg allowCA] [arg caDepth]. The [arg critical]
+argument to this extension (and any extension) whether or not the
+validator should reject the certificate as invalid if it does not
+understand the extension (if set to "true") or should ignore the extension
+(if set to "false"). The [arg allowCA] argument is used to specify
+as a boolean value whether or not we can be used a certificate
+authority (CA). The [arg caDepth] argument indicates how many children
+CAs can be children of this CA in a depth-wise fashion. A value of "0"
+for the [arg caDepth] argument means that this CA cannot sign a CA
+certificate and have the result be valid. A value of "-1" indicates
+infinite depth.
+
+[list_end]
+
+[section "EXAMPLES"]
+
+[example {
+}]
+
+[example {
+}]
+
+[section "REFERENCES"]
+
+[list_begin enumerated]
+[enum]
+[list_end]
+
+[section AUTHORS]
+Roy Keene
+
+[vset CATEGORY rsa]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pki/pki.tcl b/tcllib/modules/pki/pki.tcl
new file mode 100644
index 0000000..275ca57
--- /dev/null
+++ b/tcllib/modules/pki/pki.tcl
@@ -0,0 +1,1884 @@
+#! /usr/bin/env tclsh
+# -*- tcl -*-
+# RSA
+#
+# (c) 2010, 2011, 2012, 2013 Roy Keene.
+# BSD Licensed.
+
+# # ## ### ##### ######## #############
+## Requisites
+
+package require Tcl 8.5
+
+## Versions of asn lower than 0.8.4 are known to have defects
+package require asn 0.8.4
+
+## Further dependencies
+package require aes
+package require des
+package require math::bignum
+package require md5 2
+package require sha1
+package require sha256
+
+# # ## ### ##### ######## #############
+## Requisites
+
+namespace eval ::pki {
+ variable oids
+ array set oids {
+ 1.2.840.113549.1.1.1 rsaEncryption
+ 1.2.840.113549.1.1.5 sha1WithRSAEncryption
+ 1.2.840.113549.2.5 md5
+ 1.3.14.3.2.26 sha1
+ 2.16.840.1.101.3.4.2.1 sha256
+ 0.9.2342.19200300.100.1.1 uid
+ 0.9.2342.19200300.100.1.10 manager
+ 0.9.2342.19200300.100.1.11 documentIdentifier
+ 0.9.2342.19200300.100.1.12 documentTitle
+ 0.9.2342.19200300.100.1.13 documentVersion
+ 0.9.2342.19200300.100.1.14 documentAuthor
+ 0.9.2342.19200300.100.1.15 documentLocation
+ 0.9.2342.19200300.100.1.2 textEncodedORAddress
+ 0.9.2342.19200300.100.1.20 homePhone
+ 0.9.2342.19200300.100.1.21 secretary
+ 0.9.2342.19200300.100.1.22 otherMailbox
+ 0.9.2342.19200300.100.1.25 dc
+ 0.9.2342.19200300.100.1.26 aRecord
+ 0.9.2342.19200300.100.1.27 mDRecord
+ 0.9.2342.19200300.100.1.28 mXRecord
+ 0.9.2342.19200300.100.1.29 nSRecord
+ 0.9.2342.19200300.100.1.3 mail
+ 0.9.2342.19200300.100.1.30 sOARecord
+ 0.9.2342.19200300.100.1.31 cNAMERecord
+ 0.9.2342.19200300.100.1.37 associatedDomain
+ 0.9.2342.19200300.100.1.38 associatedName
+ 0.9.2342.19200300.100.1.39 homePostalAddress
+ 0.9.2342.19200300.100.1.4 info
+ 0.9.2342.19200300.100.1.40 personalTitle
+ 0.9.2342.19200300.100.1.41 mobile
+ 0.9.2342.19200300.100.1.42 pager
+ 0.9.2342.19200300.100.1.43 co
+ 0.9.2342.19200300.100.1.43 friendlyCountryName
+ 0.9.2342.19200300.100.1.44 uniqueIdentifier
+ 0.9.2342.19200300.100.1.45 organizationalStatus
+ 0.9.2342.19200300.100.1.46 janetMailbox
+ 0.9.2342.19200300.100.1.47 mailPreferenceOption
+ 0.9.2342.19200300.100.1.48 buildingName
+ 0.9.2342.19200300.100.1.49 dSAQuality
+ 0.9.2342.19200300.100.1.5 drink
+ 0.9.2342.19200300.100.1.50 singleLevelQuality
+ 0.9.2342.19200300.100.1.51 subtreeMinimumQuality
+ 0.9.2342.19200300.100.1.52 subtreeMaximumQuality
+ 0.9.2342.19200300.100.1.53 personalSignature
+ 0.9.2342.19200300.100.1.54 dITRedirect
+ 0.9.2342.19200300.100.1.55 audio
+ 0.9.2342.19200300.100.1.56 documentPublisher
+ 0.9.2342.19200300.100.1.6 roomNumber
+ 0.9.2342.19200300.100.1.60 jpegPhoto
+ 0.9.2342.19200300.100.1.7 photo
+ 0.9.2342.19200300.100.1.8 userClass
+ 0.9.2342.19200300.100.1.9 host
+ 1.2.840.113549.1.9.1 email
+ 1.3.6.1.4.1.2428.90.1.1 norEduOrgUniqueNumber
+ 1.3.6.1.4.1.2428.90.1.11 norEduOrgSchemaVersion
+ 1.3.6.1.4.1.2428.90.1.12 norEduOrgNIN
+ 1.3.6.1.4.1.2428.90.1.2 norEduOrgUnitUniqueNumber
+ 1.3.6.1.4.1.2428.90.1.3 norEduPersonBirthDate
+ 1.3.6.1.4.1.2428.90.1.4 norEduPersonLIN
+ 1.3.6.1.4.1.2428.90.1.5 norEduPersonNIN
+ 1.3.6.1.4.1.2428.90.1.6 norEduOrgAcronym
+ 1.3.6.1.4.1.2428.90.1.7 norEduOrgUniqueIdentifier
+ 1.3.6.1.4.1.2428.90.1.8 norEduOrgUnitUniqueIdentifier
+ 1.3.6.1.4.1.2428.90.1.9 federationFeideSchemaVersion
+ 1.3.6.1.4.1.250.1.57 labeledURI
+ 1.3.6.1.4.1.5923.1.1.1.1 eduPersonAffiliation
+ 1.3.6.1.4.1.5923.1.1.1.10 eduPersonTargetedID
+ 1.3.6.1.4.1.5923.1.1.1.2 eduPersonNickname
+ 1.3.6.1.4.1.5923.1.1.1.3 eduPersonOrgDN
+ 1.3.6.1.4.1.5923.1.1.1.4 eduPersonOrgUnitDN
+ 1.3.6.1.4.1.5923.1.1.1.5 eduPersonPrimaryAffiliation
+ 1.3.6.1.4.1.5923.1.1.1.6 eduPersonPrincipalName
+ 1.3.6.1.4.1.5923.1.1.1.7 eduPersonEntitlement
+ 1.3.6.1.4.1.5923.1.1.1.8 eduPersonPrimaryOrgUnitDN
+ 1.3.6.1.4.1.5923.1.1.1.9 eduPersonScopedAffiliation
+ 1.3.6.1.4.1.5923.1.2.1.2 eduOrgHomePageURI
+ 1.3.6.1.4.1.5923.1.2.1.3 eduOrgIdentityAuthNPolicyURI
+ 1.3.6.1.4.1.5923.1.2.1.4 eduOrgLegalName
+ 1.3.6.1.4.1.5923.1.2.1.5 eduOrgSuperiorURI
+ 1.3.6.1.4.1.5923.1.2.1.6 eduOrgWhitePagesURI
+ 1.3.6.1.4.1.5923.1.5.1.1 isMemberOf
+ 2.16.840.1.113730.3.1.1 carLicense
+ 2.16.840.1.113730.3.1.2 departmentNumber
+ 2.16.840.1.113730.3.1.216 userPKCS12
+ 2.16.840.1.113730.3.1.241 displayName
+ 2.16.840.1.113730.3.1.3 employeeNumber
+ 2.16.840.1.113730.3.1.39 preferredLanguage
+ 2.16.840.1.113730.3.1.4 employeeType
+ 2.16.840.1.113730.3.1.40 userSMIMECertificate
+ 2.5.4.0 objectClass
+ 2.5.4.1 aliasedEntryName
+ 2.5.4.10 o
+ 2.5.4.11 ou
+ 2.5.4.12 title
+ 2.5.4.13 description
+ 2.5.4.14 searchGuide
+ 2.5.4.15 businessCategory
+ 2.5.4.16 postalAddress
+ 2.5.4.17 postalCode
+ 2.5.4.18 postOfficeBox
+ 2.5.4.19 physicalDeliveryOfficeName
+ 2.5.4.2 knowledgeInformation
+ 2.5.4.20 telephoneNumber
+ 2.5.4.21 telexNumber
+ 2.5.4.22 teletexTerminalIdentifier
+ 2.5.4.23 facsimileTelephoneNumber
+ 2.5.4.23 fax
+ 2.5.4.24 x121Address
+ 2.5.4.25 internationaliSDNNumber
+ 2.5.4.26 registeredAddress
+ 2.5.4.27 destinationIndicator
+ 2.5.4.28 preferredDeliveryMethod
+ 2.5.4.29 presentationAddress
+ 2.5.4.3 cn
+ 2.5.4.30 supportedApplicationContext
+ 2.5.4.31 member
+ 2.5.4.32 owner
+ 2.5.4.33 roleOccupant
+ 2.5.4.34 seeAlso
+ 2.5.4.35 userPassword
+ 2.5.4.36 userCertificate
+ 2.5.4.37 cACertificate
+ 2.5.4.38 authorityRevocationList
+ 2.5.4.39 certificateRevocationList
+ 2.5.4.4 sn
+ 2.5.4.40 crossCertificatePair
+ 2.5.4.41 name
+ 2.5.4.42 gn
+ 2.5.4.43 initials
+ 2.5.4.44 generationQualifier
+ 2.5.4.45 x500UniqueIdentifier
+ 2.5.4.46 dnQualifier
+ 2.5.4.47 enhancedSearchGuide
+ 2.5.4.48 protocolInformation
+ 2.5.4.49 distinguishedName
+ 2.5.4.5 serialNumber
+ 2.5.4.50 uniqueMember
+ 2.5.4.51 houseIdentifier
+ 2.5.4.52 supportedAlgorithms
+ 2.5.4.53 deltaRevocationList
+ 2.5.4.54 dmdName
+ 2.5.4.6 c
+ 2.5.4.65 pseudonym
+ 2.5.4.7 l
+ 2.5.4.8 st
+ 2.5.4.9 street
+ 2.5.29.14 id-ce-subjectKeyIdentifier
+ 2.5.29.15 id-ce-keyUsage
+ 2.5.29.16 id-ce-privateKeyUsagePeriod
+ 2.5.29.17 id-ce-subjectAltName
+ 2.5.29.18 id-ce-issuerAltName
+ 2.5.29.19 id-ce-basicConstraints
+ 2.5.29.20 id-ce-cRLNumber
+ 2.5.29.32 id-ce-certificatePolicies
+ 2.5.29.33 id-ce-cRLDistributionPoints
+ 2.5.29.35 id-ce-authorityKeyIdentifier
+ }
+
+ variable handlers
+ array set handlers {
+ rsa {::pki::rsa::encrypt ::pki::rsa::decrypt ::pki::rsa::generate ::pki::rsa::serialize_key}
+ }
+
+ variable INT_MAX [expr {[format "%u" -1] / 2}]
+}
+
+namespace eval ::pki::rsa {}
+namespace eval ::pki::x509 {}
+namespace eval ::pki::pkcs {}
+
+# # ## ### ##### ######## #############
+## Implementation
+
+proc ::pki::_dec_to_hex {num} {
+ set retval [format %llx $num]
+ return $retval
+}
+
+proc ::pki::_dec_to_ascii {num {bitlen -1}} {
+ set retval ""
+
+ while {$num} {
+ set currchar [expr {$num & 0xff}]
+ set retval "[format %c $currchar]$retval"
+ set num [expr {$num >> 8}]
+ }
+
+ if {$bitlen != -1} {
+ set bytelen [expr {$bitlen / 8}]
+ while {[string length $retval] < $bytelen} {
+ set retval "\x00$retval"
+ }
+ }
+
+ return $retval
+}
+
+proc ::pki::_powm {x y m} {
+ if {$y == 0} {
+ return 1
+ }
+
+ set retval 1
+
+ while {$y > 0} {
+ if {($y & 1) == 1} {
+ set retval [expr {($retval * $x) % $m}]
+ }
+
+ set y [expr {$y >> 1}]
+ set x [expr {($x * $x) % $m}]
+ }
+
+ return $retval
+}
+
+## **NOTE** Requires that "m" be prime
+### a^-1 === a^(m-2) (all mod m)
+proc ::pki::_modi {a m} {
+ return [_powm $a [expr {$m - 2}] $m]
+}
+
+proc ::pki::_oid_number_to_name {oid} {
+ set oid [join $oid .]
+
+ if {[info exists ::pki::oids($oid)]} {
+ return $::pki::oids($oid)
+ }
+
+ return $oid
+}
+
+proc ::pki::_oid_name_to_number {name} {
+ foreach {chkoid chkname} [array get ::pki::oids] {
+ if {[string equal -nocase $chkname $name]} {
+ return [split $chkoid .]
+ }
+ }
+
+ return -code error
+}
+
+proc ::pki::rsa::_encrypt_num {input exponent mod} {
+ set ret [::pki::_powm $input $exponent $mod]
+
+ return $ret
+}
+
+proc ::pki::rsa::_decrypt_num {input exponent mod} {
+ set ret [::pki::_powm $input $exponent $mod]
+
+ return $ret
+}
+
+proc ::pki::_pad_pkcs {data bitlength {blocktype 2}} {
+ set ret ""
+
+ set bytes_to_pad [expr {($bitlength / 8) - 3 - [string length $data]}]
+ if {$bytes_to_pad < 0} {
+ return $data
+ }
+
+ switch -- $blocktype {
+ 0 {
+ }
+ 1 {
+ append ret "\x00\x01"
+ append ret [string repeat "\xff" $bytes_to_pad]
+ append ret "\x00"
+ }
+ 2 {
+ append ret "\x00\x02"
+ for {set idx 0} {$idx < $bytes_to_pad} {incr idx} {
+ append ret [format %c [expr {int(rand() * 255 + 1)}]]
+ }
+ append ret "\x00"
+ }
+ }
+
+ append ret $data
+
+ return $ret
+}
+
+proc ::pki::_unpad_pkcs {data} {
+ set check [string index $data 0]
+ binary scan [string index $data 1] H* blocktype
+ set datalen [string length $data]
+
+ if {$check != "\x00"} {
+ return $data
+ }
+
+ switch -- $blocktype {
+ "00" {
+ # Padding Scheme 1, the first non-zero byte is the start of data
+ for {set idx 2} {$idx < $datalen} {incr idx} {
+ set char [string index $data $idx]
+ if {$char != "\x00"} {
+ set ret [string range $data $idx end]
+ }
+ }
+ }
+ "01" {
+ # Padding Scheme 2, pad bytes are 0xFF followed by 0x00
+ for {set idx 2} {$idx < $datalen} {incr idx} {
+ set char [string index $data $idx]
+ if {$char != "\xff"} {
+ if {$char == "\x00"} {
+ set ret [string range $data [expr {$idx + 1}] end]
+
+ break
+ } else {
+ return -code error "Invalid padding, seperator byte is not 0x00"
+ }
+ }
+ }
+ }
+ "02" {
+ # Padding Scheme 3, pad bytes are random, followed by 0x00
+ for {set idx 2} {$idx < $datalen} {incr idx} {
+ set char [string index $data $idx]
+ if {$char == "\x00"} {
+ set ret [string range $data [expr {$idx + 1}] end]
+
+ break
+ }
+ }
+ }
+ default {
+ return $data
+ }
+ }
+
+ if {![info exists ret]} {
+ return -code error "Invalid padding, no seperator byte found"
+ }
+
+ return $ret
+}
+
+proc ::pki::rsa::encrypt {mode input keylist} {
+ switch -- $mode {
+ "pub" {
+ set exponent_ent e
+ }
+ "priv" {
+ set exponent_ent d
+ }
+ }
+
+ array set key $keylist
+
+ set exponent $key($exponent_ent)
+ set mod $key(n)
+
+ ## RSA requires that the input be no larger than the key
+ set input_len_bits [expr {[string length $input] * 8}]
+ if {$key(l) < $input_len_bits} {
+ return -code error "Message length exceeds key length"
+ }
+
+ binary scan $input H* input_num
+
+ set input_num "0x${input_num}"
+
+ set retval_num [_encrypt_num $input_num $exponent $mod]
+
+ set retval [::pki::_dec_to_ascii $retval_num $key(l)]
+
+ return $retval
+}
+
+proc ::pki::rsa::decrypt {mode input keylist} {
+ switch -- $mode {
+ "pub" {
+ set exponent_ent e
+ }
+ "priv" {
+ set exponent_ent d
+ }
+ }
+
+ array set key $keylist
+
+ set exponent $key($exponent_ent)
+ set mod $key(n)
+
+ binary scan $input H* input_num
+
+ set input_num "0x${input_num}"
+
+ set retval_num [_decrypt_num $input_num $exponent $mod]
+
+ set retval [::pki::_dec_to_ascii $retval_num $key(l)]
+
+ return $retval
+}
+
+proc ::pki::rsa::serialize_key {keylist} {
+ array set key $keylist
+
+ foreach entry [list n e d p q] {
+ if {![info exists key($entry)]} {
+ return -code error "Key does not contain an element $entry"
+ }
+ }
+
+ # Exponent 1
+ ## d (mod p-1)
+ set e1 [expr {$key(d) % ($key(p) - 1)}]
+
+ # Exponent 2
+ #set e2 [expr d mod (q-1)]
+ set e2 [expr {$key(d) % ($key(q) - 1)}]
+
+ # Coefficient
+ ## Modular multiplicative inverse of q mod p
+ set c [::pki::_modi $key(q) $key(p)]
+
+ set ret [::asn::asnSequence \
+ [::asn::asnBigInteger [::math::bignum::fromstr 0]] \
+ [::asn::asnBigInteger [::math::bignum::fromstr $key(n)]] \
+ [::asn::asnBigInteger [::math::bignum::fromstr $key(e)]] \
+ [::asn::asnBigInteger [::math::bignum::fromstr $key(d)]] \
+ [::asn::asnBigInteger [::math::bignum::fromstr $key(p)]] \
+ [::asn::asnBigInteger [::math::bignum::fromstr $key(q)]] \
+ [::asn::asnBigInteger [::math::bignum::fromstr $e1]] \
+ [::asn::asnBigInteger [::math::bignum::fromstr $e2]] \
+ [::asn::asnBigInteger [::math::bignum::fromstr $c]] \
+ ]
+
+ return [list data $ret begin "-----BEGIN RSA PRIVATE KEY-----" end "-----END RSA PRIVATE KEY-----"]
+}
+
+proc ::pki::_lookup_command {action keylist} {
+ array set key $keylist
+
+ set type $key(type)
+
+ switch -- $action {
+ "encrypt" {
+ set idx 0
+ }
+ "decrypt" {
+ set idx 1
+ }
+ "generate" {
+ set idx 2
+ }
+ "serialize_key" {
+ set idx 3
+ }
+ }
+
+ set cmdlist $::pki::handlers($type)
+
+ set ret [lindex $cmdlist $idx]
+
+ return $ret
+}
+
+proc ::pki::encrypt args {
+ set outmode "hex"
+ set enablepad 1
+
+ set argsmode 0
+ set newargs [list]
+ foreach arg $args {
+ if {![string match "-*" $arg]} {
+ set argsmode 1
+ }
+
+ if {$argsmode} {
+ lappend newargs $arg
+ continue
+ }
+
+ switch -- $arg {
+ "-pub" {
+ set mode pub
+ set padmode 2
+ }
+ "-priv" {
+ set mode priv
+ set padmode 1
+ }
+ "-hex" {
+ set outmode "hex"
+ }
+ "-binary" {
+ set outmode "bin"
+ }
+ "-pad" {
+ set enablepad 1
+ }
+ "-nopad" {
+ set enablepad 0
+ }
+ "--" {
+ set argsmode 1
+ }
+ default {
+ return -code error "usage: encrypt ?-binary? ?-hex? ?-pad? ?-nopad? -priv|-pub ?--? input key"
+ }
+ }
+ }
+ set args $newargs
+
+ if {[llength $args] != 2 || ![info exists mode]} {
+ return -code error "usage: encrypt ?-binary? ?-hex? ?-pad? ?-nopad? -priv|-pub ?--? input key"
+ }
+
+ set input [lindex $args 0]
+ set keylist [lindex $args 1]
+ array set key $keylist
+
+ if {$enablepad} {
+ set input [::pki::_pad_pkcs $input $key(l) $padmode]
+ }
+
+ set encrypt [::pki::_lookup_command encrypt $keylist]
+
+ set retval [$encrypt $mode $input $keylist]
+
+ switch -- $outmode {
+ "hex" {
+ binary scan $retval H* retval
+ }
+ }
+
+ return $retval
+}
+
+proc ::pki::decrypt args {
+ set inmode "hex"
+ set enableunpad 1
+
+ set argsmode 0
+ set newargs [list]
+ foreach arg $args {
+ if {![string match "-*" $arg]} {
+ set argsmode 1
+ }
+
+ if {$argsmode} {
+ lappend newargs $arg
+ continue
+ }
+
+ switch -- $arg {
+ "-pub" {
+ set mode pub
+ }
+ "-priv" {
+ set mode priv
+ }
+ "-hex" {
+ set inmode "hex"
+ }
+ "-binary" {
+ set inmode "bin"
+ }
+ "-unpad" {
+ set enableunpad 1
+ }
+ "-nounpad" {
+ set enableunpad 0
+ }
+ "--" {
+ set argsmode 1
+ }
+ default {
+ return -code error "usage: decrypt ?-binary? ?-hex? ?-unpad? ?-nounpad? -priv|-pub ?--? input key"
+ }
+ }
+ }
+ set args $newargs
+
+ if {[llength $args] != 2 || ![info exists mode]} {
+ return -code error "usage: decrypt ?-binary? ?-hex? ?-unpad? ?-nounpad? -priv|-pub ?--? input key"
+ }
+
+ set input [lindex $args 0]
+ set keylist [lindex $args 1]
+ array set key $keylist
+
+ switch -- $inmode {
+ "hex" {
+ set input [binary format H* $input]
+ }
+ }
+
+ set decrypt [::pki::_lookup_command decrypt $keylist]
+
+ set retval [$decrypt $mode $input $keylist]
+
+ if {$enableunpad} {
+ set retval [::pki::_unpad_pkcs $retval]
+ }
+
+ return $retval
+}
+
+# Hash and encrypt with private key
+proc ::pki::sign {input keylist {algo "sha1"}} {
+ switch -- $algo {
+ "md5" {
+ package require md5
+
+ set header "\x30\x20\x30\x0c\x06\x08\x2a\x86\x48\x86\xf7\x0d\x02\x05\x05\x00\x04\x10"
+ set hash [md5::md5 $input]
+ }
+ "sha1" {
+ package require sha1
+
+ set header "\x30\x21\x30\x09\x06\x05\x2b\x0e\x03\x02\x1a\x05\x00\x04\x14"
+ set hash [sha1::sha1 -bin $input]
+ }
+ "sha256" {
+ package require sha256
+
+ set header "\x30\x31\x30\x0d\x06\x09\x60\x86\x48\x01\x65\x03\x04\x02\x01\x05\x00\x04\x20"
+ set hash [sha2::sha256 -bin $input]
+ }
+ "raw" {
+ set header ""
+ set hash $input
+ }
+ default {
+ return -code error "Invalid algorithm selected, must be one of: md5, sha1, sha256, raw"
+ }
+ }
+
+ set plaintext "${header}${hash}"
+
+ array set key $keylist
+
+ set padded [::pki::_pad_pkcs $plaintext $key(l) 1]
+
+ return [::pki::encrypt -binary -nopad -priv -- $padded $keylist]
+}
+
+# Verify known-plaintext with signature
+proc ::pki::verify {signedmessage checkmessage keylist {algo default}} {
+ package require asn
+
+ if {[catch {
+ set plaintext [::pki::decrypt -binary -unpad -pub -- $signedmessage $keylist]
+ }]} {
+ return false
+ }
+
+ if {$algo == "default"} {
+ set algoId "unknown"
+ set digest ""
+
+ catch {
+ ::asn::asnGetSequence plaintext message
+ ::asn::asnGetSequence message digestInfo
+ ::asn::asnGetObjectIdentifier digestInfo algoId
+ ::asn::asnGetOctetString message digest
+ }
+
+ set algoId [::pki::_oid_number_to_name $algoId]
+ } else {
+ set algoId $algo
+ set digest $plaintext
+ }
+
+ switch -- $algoId {
+ "md5" - "md5WithRSAEncryption" {
+ set checkdigest [md5::md5 $checkmessage]
+ }
+ "sha1" - "sha1WithRSAEncryption" {
+ set checkdigest [sha1::sha1 -bin $checkmessage]
+ }
+ "sha256" - "sha256WithRSAEncryption" {
+ set checkdigest [sha2::sha256 -bin $checkmessage]
+ }
+ default {
+ return -code error "Unknown hashing algorithm: $algoId"
+ }
+ }
+
+ if {$checkdigest != $digest} {
+ return false
+ }
+
+ return true
+}
+
+proc ::pki::key {keylist {password ""} {encodePem 1}} {
+ set serialize_key [::pki::_lookup_command serialize_key $keylist]
+
+ if {$serialize_key eq ""} {
+ array set key $keylist
+
+ return -code error "Do not know how to serialize an $key(type) key"
+ }
+
+ array set retval_parts [$serialize_key $keylist]
+
+ if {$encodePem} {
+ set retval [::pki::_encode_pem $retval_parts(data) $retval_parts(begin) $retval_parts(end) $password]
+ } else {
+ if {$password != ""} {
+ return -code error "DER encoded keys may not be password protected"
+ }
+
+ set retval $retval_parts(data)
+ }
+
+ return $retval
+}
+
+proc ::pki::_parse_init {} {
+ if {[info exists ::pki::_parse_init_done]} {
+ return
+ }
+
+ package require asn
+
+ set test "FAIL"
+ catch {
+ set test [binary decode base64 "UEFTUw=="]
+ }
+
+ switch -- $test {
+ "PASS" {
+ set ::pki::rsa::base64_binary 1
+ }
+ "FAIL" {
+ set ::pki::rsa::base64_binary 0
+
+ package require base64
+ }
+ }
+
+ set ::pki::_parse_init_done 1
+ return
+}
+
+proc ::pki::_getopensslkey {password salt bytes} {
+ package require md5
+
+ set salt [string range $salt 0 7]
+
+ set saltedkey "${password}${salt}"
+ for {set ret ""} {[string length $ret] < $bytes} {} {
+ if {![info exists hash]} {
+ set hash $saltedkey
+ } else {
+ set hash "${hash}${saltedkey}"
+ }
+
+ set hash [md5::md5 $hash]
+
+ append ret $hash
+ }
+
+ if {[string length $ret] < $bytes} {
+ set bytes_to_add [expr $bytes - [string length $ret]]
+ set ret "[string repeat "\x00" $bytes_to_add]${ret}"
+ }
+
+ set ret [string range $ret 0 [expr {$bytes - 1}]]
+
+ return $ret
+}
+
+proc ::pki::_encode_pem {data begin end {password ""} {algo "aes-256-cbc"}} {
+ set ret ""
+
+ append ret "${begin}\n"
+ if {$password != ""} {
+ switch -glob -- $algo {
+ "aes-*" {
+ set algostr [string toupper $algo]
+ set work [split $algo "-"]
+ set algo "aes"
+ set keysize [lindex $work 1]
+ set mode [lindex $work 2]
+ set blocksize 16
+ set ivsize [expr {$blocksize * 8}]
+ }
+ default {
+ return -code error "Only AES is currently supported"
+ }
+ }
+
+ set keybytesize [expr {$keysize / 8}]
+ set ivbytesize [expr {$ivsize / 8}]
+
+ set iv ""
+ while {[string length $iv] < $ivbytesize} {
+ append iv [::pki::_random -binary]
+ }
+ set iv [string range $iv 0 [expr {$ivbytesize - 1}]]
+
+ set password_key [::pki::_getopensslkey $password $iv $keybytesize]
+
+ set pad [expr {$blocksize - ([string length $data] % $blocksize)}]
+ append data [string repeat "\x09" $pad]
+
+ switch -- $algo {
+ "aes" {
+ set data [aes::aes -dir encrypt -mode $mode -iv $iv -key $password_key -- $data]
+ }
+ }
+
+ binary scan $iv H* iv
+ set iv [string toupper $iv]
+
+ append ret "Proc-Type: 4,ENCRYPTED\n"
+ append ret "DEK-Info: $algostr,$iv\n"
+ append ret "\n"
+ }
+
+ if {$::pki::rsa::base64_binary} {
+ append ret [binary encode base64 -maxlen 64 $data]
+ } else {
+ append ret [::base64::encode -maxlen 64 $data]
+ }
+ append ret "\n"
+ append ret "${end}\n"
+
+ return $ret
+}
+
+proc ::pki::_parse_pem {pem begin end {password ""}} {
+ # Unencode a PEM-encoded object
+ set testpem [split $pem \n]
+ set pem_startidx [lsearch -exact $testpem $begin]
+ set pem_endidx [lsearch -exact -start $pem_startidx $testpem $end]
+
+ if {$pem_startidx == -1 || $pem_endidx == -1} {
+ return [list data $pem]
+ }
+
+ set pem $testpem
+
+ incr pem_startidx
+ incr pem_endidx -1
+
+ array set ret [list]
+
+ set newpem ""
+ foreach line [lrange $pem $pem_startidx $pem_endidx] {
+ if {[string match "*:*" $line]} {
+ set work [split $line :]
+
+ set var [string toupper [lindex $work 0]]
+ set val [string trim [join [lrange $work 1 end] :]]
+
+ set ret($var) $val
+
+ continue
+ }
+
+ set line [string trim $line]
+
+ append newpem $line
+ }
+
+ if {$newpem != ""} {
+ if {$::pki::rsa::base64_binary} {
+ set pem [binary decode base64 $newpem]
+ } else {
+ set pem [::base64::decode $newpem]
+ }
+ }
+
+ if {[info exists ret(PROC-TYPE)] && [info exists ret(DEK-INFO)]} {
+ if {$ret(PROC-TYPE) == "4,ENCRYPTED"} {
+ if {$password == ""} {
+ return [list error "ENCRYPTED"]
+ }
+
+ switch -glob -- $ret(DEK-INFO) {
+ "DES-EDE3-*" {
+ package require des
+
+ # DES-EDE3-CBC,03B1F1883BFA4412
+ set keyinfo $ret(DEK-INFO)
+
+ set work [split $keyinfo ,]
+ set cipher [lindex $work 0]
+ set iv [lindex $work 1]
+
+ set work [split $cipher -]
+ set algo [lindex $work 0]
+ set mode [string tolower [lindex $work 2]]
+
+ set iv [binary format H* $iv]
+ set password_key [::pki::_getopensslkey $password $iv 24]
+
+ set pem [DES::des -dir decrypt -mode $mode -iv $iv -key $password_key -- $pem]
+ }
+ "AES-*" {
+ package require aes
+
+ # AES-256-CBC,AF517BA39E94FF39D1395C63F6DE9657
+ set keyinfo $ret(DEK-INFO)
+
+ set work [split $keyinfo ,]
+ set cipher [lindex $work 0]
+ set iv [lindex $work 1]
+
+ set work [split $cipher -]
+ set algo [lindex $work 0]
+ set keysize [lindex $work 1]
+ set mode [string tolower [lindex $work 2]]
+
+ set iv [binary format H* $iv]
+ set password_key [::pki::_getopensslkey $password $iv [expr $keysize / 8]]
+
+ set pem [aes::aes -dir decrypt -mode $mode -iv $iv -key $password_key -- $pem]
+ }
+ }
+ }
+ }
+
+ set ret(data) $pem
+
+ return [array get ret]
+}
+
+proc ::pki::pkcs::parse_key {key {password ""}} {
+ array set parsed_key [::pki::_parse_pem $key "-----BEGIN RSA PRIVATE KEY-----" "-----END RSA PRIVATE KEY-----" $password]
+
+ set key_seq $parsed_key(data)
+
+ ::asn::asnGetSequence key_seq key
+ ::asn::asnGetBigInteger key version
+ ::asn::asnGetBigInteger key ret(n)
+ ::asn::asnGetBigInteger key ret(e)
+ ::asn::asnGetBigInteger key ret(d)
+ ::asn::asnGetBigInteger key ret(p)
+ ::asn::asnGetBigInteger key ret(q)
+
+ set ret(n) [::math::bignum::tostr $ret(n)]
+ set ret(e) [::math::bignum::tostr $ret(e)]
+ set ret(d) [::math::bignum::tostr $ret(d)]
+ set ret(p) [::math::bignum::tostr $ret(p)]
+ set ret(q) [::math::bignum::tostr $ret(q)]
+ set ret(l) [expr {int([::pki::_bits $ret(n)] / 8.0000 + 0.5) * 8}]
+ set ret(type) rsa
+
+ return [array get ret]
+}
+
+proc ::pki::x509::_dn_to_list {dn} {
+ set ret ""
+
+ while {$dn != ""} {
+ ::asn::asnGetSet dn dn_parts
+ ::asn::asnGetSequence dn_parts curr_part
+ ::asn::asnGetObjectIdentifier curr_part label
+ ::asn::asnGetString curr_part value
+
+ set label [::pki::_oid_number_to_name $label]
+ lappend ret $label $value
+ }
+
+ return $ret
+}
+
+proc ::pki::x509::_list_to_dn {name} {
+ set ret ""
+ foreach {oid_name value} $name {
+ if {![regexp {[^ A-Za-z0-9'()+,.:/?=-]} $value]} {
+ set asnValue [::asn::asnPrintableString $value]
+ } else {
+ set asnValue [::asn::asnUTF8String $value]
+ }
+
+ append ret [::asn::asnSet \
+ [::asn::asnSequence \
+ [::asn::asnObjectIdentifier [::pki::_oid_name_to_number $oid_name]] \
+ $asnValue \
+ ] \
+ ] \
+ }
+
+ return $ret
+}
+
+proc ::pki::x509::_dn_to_string {dn} {
+ set ret [list]
+
+ foreach {label value} [_dn_to_list $dn] {
+ set label [string toupper $label]
+
+ lappend ret "$label=$value"
+ }
+
+ set ret [join $ret {, }]
+
+ return $ret
+}
+
+proc ::pki::x509::_string_to_dn {string} {
+ foreach {label value} [split $string ",="] {
+ set label [string trim $label]
+ set value [string trim $value]
+
+ lappend namelist $label $value
+ }
+
+ return [_list_to_dn $namelist]
+}
+
+proc ::pki::x509::_dn_to_cn {dn} {
+ foreach {label value} [split $dn ",="] {
+ set label [string toupper [string trim $label]]
+ set value [string trim $value]
+
+ if {$label == "CN"} {
+ return $value
+ }
+ }
+
+ return ""
+}
+
+proc ::pki::x509::_utctime_to_native {utctime} {
+ return [clock scan $utctime -format {%y%m%d%H%M%SZ} -gmt true]
+}
+
+proc ::pki::x509::_native_to_utctime {time} {
+ return [clock format $time -format {%y%m%d%H%M%SZ} -gmt true]
+}
+
+proc ::pki::x509::parse_cert {cert} {
+ array set parsed_cert [::pki::_parse_pem $cert "-----BEGIN CERTIFICATE-----" "-----END CERTIFICATE-----"]
+ set cert_seq $parsed_cert(data)
+
+ array set ret [list]
+
+ # Decode X.509 certificate, which is an ASN.1 sequence
+ ::asn::asnGetSequence cert_seq wholething
+ ::asn::asnGetSequence wholething cert
+
+ set ret(cert) $cert
+ set ret(cert) [::asn::asnSequence $ret(cert)]
+ binary scan $ret(cert) H* ret(cert)
+
+ ::asn::asnPeekByte cert peek_tag
+ if {$peek_tag != 0x02} {
+ # Version number is optional, if missing assumed to be value of 0
+ ::asn::asnGetContext cert - asn_version
+ ::asn::asnGetInteger asn_version ret(version)
+ incr ret(version)
+ } else {
+ set ret(version) 1
+ }
+
+ ::asn::asnGetBigInteger cert ret(serial_number)
+ ::asn::asnGetSequence cert data_signature_algo_seq
+ ::asn::asnGetObjectIdentifier data_signature_algo_seq ret(data_signature_algo)
+ ::asn::asnGetSequence cert issuer
+ ::asn::asnGetSequence cert validity
+ ::asn::asnGetUTCTime validity ret(notBefore)
+ ::asn::asnGetUTCTime validity ret(notAfter)
+ ::asn::asnGetSequence cert subject
+ ::asn::asnGetSequence cert pubkeyinfo
+ ::asn::asnGetSequence pubkeyinfo pubkey_algoid
+ ::asn::asnGetObjectIdentifier pubkey_algoid ret(pubkey_algo)
+ ::asn::asnGetBitString pubkeyinfo pubkey
+
+ set extensions_list [list]
+ while {$cert != ""} {
+ ::asn::asnPeekByte cert peek_tag
+
+ switch -- [format {0x%02x} $peek_tag] {
+ "0xa1" {
+ ::asn::asnGetContext cert - issuerUniqID
+ }
+ "0xa2" {
+ ::asn::asnGetContext cert - subjectUniqID
+ }
+ "0xa3" {
+ ::asn::asnGetContext cert - extensions_ctx
+ ::asn::asnGetSequence extensions_ctx extensions
+ while {$extensions != ""} {
+ ::asn::asnGetSequence extensions extension
+ ::asn::asnGetObjectIdentifier extension ext_oid
+
+ ::asn::asnPeekByte extension peek_tag
+ if {$peek_tag == 0x1} {
+ ::asn::asnGetBoolean extension ext_critical
+ } else {
+ set ext_critical false
+ }
+
+ ::asn::asnGetOctetString extension ext_value_seq
+
+ set ext_oid [::pki::_oid_number_to_name $ext_oid]
+
+ set ext_value [list $ext_critical]
+
+ switch -- $ext_oid {
+ id-ce-basicConstraints {
+ ::asn::asnGetSequence ext_value_seq ext_value_bin
+
+ if {$ext_value_bin != ""} {
+ ::asn::asnGetBoolean ext_value_bin allowCA
+ } else {
+ set allowCA "false"
+ }
+
+ if {$ext_value_bin != ""} {
+ ::asn::asnGetInteger ext_value_bin caDepth
+ } else {
+ set caDepth -1
+ }
+
+ lappend ext_value $allowCA $caDepth
+ }
+ default {
+ binary scan $ext_value_seq H* ext_value_seq_hex
+ lappend ext_value $ext_value_seq_hex
+ }
+ }
+
+ lappend extensions_list $ext_oid $ext_value
+ }
+ }
+ }
+ }
+ set ret(extensions) $extensions_list
+
+ ::asn::asnGetSequence wholething signature_algo_seq
+ ::asn::asnGetObjectIdentifier signature_algo_seq ret(signature_algo)
+ ::asn::asnGetBitString wholething ret(signature)
+
+ # Convert values from ASN.1 decoder to usable values if needed
+ set ret(notBefore) [::pki::x509::_utctime_to_native $ret(notBefore)]
+ set ret(notAfter) [::pki::x509::_utctime_to_native $ret(notAfter)]
+ set ret(serial_number) [::math::bignum::tostr $ret(serial_number)]
+ set ret(data_signature_algo) [::pki::_oid_number_to_name $ret(data_signature_algo)]
+ set ret(signature_algo) [::pki::_oid_number_to_name $ret(signature_algo)]
+ set ret(pubkey_algo) [::pki::_oid_number_to_name $ret(pubkey_algo)]
+ set ret(issuer) [_dn_to_string $issuer]
+ set ret(subject) [_dn_to_string $subject]
+ set ret(signature) [binary format B* $ret(signature)]
+ binary scan $ret(signature) H* ret(signature)
+
+ # Handle RSA public keys by extracting N and E
+ switch -- $ret(pubkey_algo) {
+ "rsaEncryption" {
+ set pubkey [binary format B* $pubkey]
+ binary scan $pubkey H* ret(pubkey)
+
+ ::asn::asnGetSequence pubkey pubkey_parts
+ ::asn::asnGetBigInteger pubkey_parts ret(n)
+ ::asn::asnGetBigInteger pubkey_parts ret(e)
+
+ set ret(n) [::math::bignum::tostr $ret(n)]
+ set ret(e) [::math::bignum::tostr $ret(e)]
+ set ret(l) [expr {int([::pki::_bits $ret(n)] / 8.0000 + 0.5) * 8}]
+ set ret(type) rsa
+ }
+ }
+
+ return [array get ret]
+}
+
+# Verify whether a cert is valid, regardless of trust
+proc ::pki::x509::validate_cert {cert args} {
+ # Verify arguments and load options
+ for {set idx 0} {$idx < [llength $args]} {incr idx} {
+ set arg [lindex $args $idx]
+
+ switch -- $arg {
+ "-sign_message" {
+ incr idx
+ set dn [lindex $args $idx]
+ set cn [_dn_to_cn $dn]
+
+ set opts(sign_message) $cn
+ }
+ "-encrypt_message" {
+ incr idx
+ set dn [lindex $args $idx]
+ set cn [_dn_to_cn $dn]
+
+ set opts(encrypt_message) $cn
+ }
+ "-sign_cert" {
+ incr idx
+ set dn [lindex $args $idx]
+ if {$dn == "ALL" || $dn == "ANY"} {
+ set cn $dn
+ } else {
+ set cn [_dn_to_cn $dn]
+ }
+
+ incr idx
+ set currdepth [lindex $args $idx]
+
+ set opts(sign_cert) [list $cn $currdepth]
+ }
+ "-ssl" {
+ incr idx
+ set dn [lindex $args $idx]
+ set cn [_dn_to_cn $dn]
+
+ set opts(ssl) $cn
+ }
+ default {
+ return -code error {wrong # args: should be "validate_cert cert ?-sign_message dn_of_signer? ?-encrypt_message dn_of_signer? ?-sign_cert [dn_to_be_signed | ANY | ALL] ca_depth? ?-ssl dn?"}
+ }
+ }
+ }
+
+ # Load cert
+ array set cert_arr $cert
+
+ # Validate certificate
+ ## Validate times
+ if {![info exists cert_arr(notBefore)] || ![info exists cert_arr(notAfter)]} {
+ return false
+ }
+
+ set currtime [clock seconds]
+ if {$currtime < $cert_arr(notBefore) || $currtime > $cert_arr(notAfter)} {
+ return false
+ }
+
+ # Check for extensions and process them
+ ## Critical extensions must be understood, non-critical extensions may be ignored if not understood
+ set CA 0
+ set CAdepth -1
+ foreach {ext_id ext_val} $cert_arr(extensions) {
+ set critical [lindex $ext_val 0]
+
+ switch -- $ext_id {
+ id-ce-basicConstraints {
+ set CA [lindex $ext_val 1]
+ set CAdepth [lindex $ext_val 2]
+ }
+ default {
+ ### If this extensions is critical and not understood, we must reject it
+ if {$critical} {
+ return false
+ }
+ }
+ }
+ }
+
+ if {[info exists opts(sign_cert)]} {
+ if {!$CA} {
+ return false
+ }
+
+ if {$CAdepth >= 0} {
+ set sign_depth [lindex $opts(sign_cert) 1]
+ if {$sign_depth > $CAdepth} {
+ return false
+ }
+ }
+ }
+
+ return true
+}
+
+proc ::pki::x509::verify_cert {cert trustedcerts {intermediatecerts ""}} {
+ # Validate cert
+ if {![validate_cert $cert]} {
+ return false;
+ }
+
+ # Load trusted certs
+ foreach trustedcert_list $trustedcerts {
+ if {![validate_cert $trustedcert_list -sign_cert ANY -1]} {
+ continue
+ }
+
+ unset -nocomplain trustedcert
+ array set trustedcert $trustedcert_list
+
+ set subject $trustedcert(subject)
+
+ set trustedcertinfo($subject) $trustedcert_list
+ }
+
+ # Load intermediate certs
+ foreach intermediatecert_list $intermediatecerts {
+ if {![validate_cert $intermediatecert_list -sign_cert ANY -1]} {
+ continue
+ }
+
+ unset -nocomplain intermediatecert
+ array set intermediatecert $intermediatecert_list
+
+ set subject $intermediatecert(subject)
+
+ set intermediatecertinfo($subject) $intermediatecert_list
+ }
+
+ # Load cert
+ array set cert_arr $cert
+
+ # Verify certificate
+ ## Encode certificate to hash later
+ set message [binary format H* $cert_arr(cert)]
+
+ ## Find CA to verify against
+ if {![info exists trustedcertinfo($cert_arr(issuer))]} {
+ ## XXX: Try to find an intermediate path
+
+ ## XXX: Verify each cert in the intermediate path, returning in
+ ## failure if a link in the chain breaks
+
+ ## Otherwise, return in failure
+ return false
+ }
+
+ set cacert $trustedcertinfo($cert_arr(issuer))
+ array set cacert_arr $cacert
+
+ ## Set signature to binary form
+ set signature [::pki::_dec_to_ascii 0x$cert_arr(signature) $cacert_arr(l)]
+
+ ## Verify
+ set ret [::pki::verify $signature $message $cacert]
+
+ return $ret
+}
+
+# Generate a PKCS#10 Certificate Signing Request
+proc ::pki::pkcs::create_csr {keylist namelist {encodePem 0} {algo "sha1"}} {
+ array set key $keylist
+
+ set name [::pki::x509::_list_to_dn $namelist]
+
+ set type $key(type)
+
+ switch -- $type {
+ "rsa" {
+ set pubkey [::asn::asnSequence \
+ [::asn::asnBigInteger [::math::bignum::fromstr $key(n)]] \
+ [::asn::asnBigInteger [::math::bignum::fromstr $key(e)]] \
+ ]
+ set pubkey_algo_params [::asn::asnNull]
+ }
+ }
+ binary scan $pubkey B* pubkey_bitstring
+
+ set cert_req_info [::asn::asnSequence \
+ [::asn::asnInteger 0] \
+ [::asn::asnSequence $name] \
+ [::asn::asnSequence \
+ [::asn::asnSequence \
+ [::asn::asnObjectIdentifier [::pki::_oid_name_to_number ${type}Encryption]] \
+ $pubkey_algo_params \
+ ] \
+ [::asn::asnBitString $pubkey_bitstring] \
+ ] \
+ [::asn::asnContextConstr 0 ""] \
+ ]
+
+ set signature [::pki::sign $cert_req_info $keylist $algo]
+ binary scan $signature B* signature_bitstring
+
+ set cert_req [::asn::asnSequence \
+ $cert_req_info \
+ [::asn::asnSequence [::asn::asnObjectIdentifier [::pki::_oid_name_to_number "${algo}With${type}Encryption"]] [::asn::asnNull]] \
+ [::asn::asnBitString $signature_bitstring] \
+ ]
+
+ if {$encodePem} {
+ set cert_req [::pki::_encode_pem $cert_req "-----BEGIN CERTIFICATE REQUEST-----" "-----END CERTIFICATE REQUEST-----"]
+ }
+
+ return $cert_req
+}
+
+# Parse a PKCS#10 CSR
+proc ::pki::pkcs::parse_csr {csr} {
+ array set ret [list]
+
+ array set parsed_csr [::pki::_parse_pem $csr "-----BEGIN CERTIFICATE REQUEST-----" "-----END CERTIFICATE REQUEST-----"]
+ set csr $parsed_csr(data)
+
+ ::asn::asnGetSequence csr cert_req_seq
+ ::asn::asnGetSequence cert_req_seq cert_req_info
+
+ set cert_req_info_saved [::asn::asnSequence $cert_req_info]
+
+ ::asn::asnGetInteger cert_req_info version
+ ::asn::asnGetSequence cert_req_info name
+ ::asn::asnGetSequence cert_req_info pubkeyinfo
+ ::asn::asnGetSequence pubkeyinfo pubkey_algoid
+ ::asn::asnGetObjectIdentifier pubkey_algoid pubkey_type
+ ::asn::asnGetBitString pubkeyinfo pubkey
+ ::asn::asnGetSequence cert_req_seq signature_algo_seq
+ ::asn::asnGetObjectIdentifier signature_algo_seq signature_algo
+ ::asn::asnGetBitString cert_req_seq signature_bitstring
+
+ # Convert parsed fields to native types
+ set signature [binary format B* $signature_bitstring]
+ set ret(subject) [::pki::x509::_dn_to_string $name]
+
+ ## Convert Pubkey type to string
+ set pubkey_type [::pki::_oid_number_to_name $pubkey_type]
+
+ # Parse public key, based on type
+ switch -- $pubkey_type {
+ "rsaEncryption" {
+ set pubkey [binary format B* $pubkey]
+
+ ::asn::asnGetSequence pubkey pubkey_parts
+ ::asn::asnGetBigInteger pubkey_parts key(n)
+ ::asn::asnGetBigInteger pubkey_parts key(e)
+
+ set key(n) [::math::bignum::tostr $key(n)]
+ set key(e) [::math::bignum::tostr $key(e)]
+ set key(l) [expr {2**int(ceil(log([::pki::_bits $key(n)])/log(2)))}]
+ set key(type) rsa
+ }
+ default {
+ return -code error "Unsupported key type: $pubkey_type"
+ }
+ }
+
+ # Convert key to RSA parts
+ set keylist [array get key]
+
+ # Validate CSR requestor has access to the private key
+ set csrValid [::pki::verify $signature $cert_req_info_saved $keylist]
+ if {!$csrValid} {
+ return -code error "CSR Signature check failed"
+ }
+
+ array set ret $keylist
+
+ return [array get ret]
+}
+
+proc ::pki::x509::create_cert {signreqlist cakeylist serial_number notBefore notAfter isCA extensions {encodePem 0} {algo "sha1"}} {
+ # Parse parameters
+ array set cakey $cakeylist
+ array set signreq $signreqlist
+
+ set type $signreq(type)
+
+ # Process extensions
+ set extensions_list $extensions
+ unset extensions
+ array set extensions $extensions_list
+
+ # If we are generating a CA cert, add a CA extension
+ if {$isCA} {
+ set extensions(id-ce-basicConstraints) [list true true -1]
+ }
+
+ # Determine what version we need to use (default to 1)
+ if {[array get extensions] == ""} {
+ set version 1
+ } else {
+ set version 3
+ }
+
+ set certlist [list]
+
+ # Create certificate to be signed
+ ## Insert version number (if not version 1)
+ if {$version != 1} {
+ lappend certlist [::asn::asnContextConstr 0 [::asn::asnInteger [expr {$version - 1}]]]
+ }
+
+ ## Insert serial number
+ lappend certlist [::asn::asnBigInteger [math::bignum::fromstr $serial_number]]
+
+ ## Insert data algorithm
+ lappend certlist [::asn::asnSequence \
+ [::asn::asnObjectIdentifier [::pki::_oid_name_to_number "${algo}With${type}Encryption"]] \
+ [::asn::asnNull] \
+ ]
+
+ ## Insert issuer
+ lappend certlist [::asn::asnSequence [::pki::x509::_string_to_dn $cakey(subject)]]
+
+ ## Insert validity requirements
+ lappend certlist [::asn::asnSequence \
+ [::asn::asnUTCTime [::pki::x509::_native_to_utctime $notBefore]] \
+ [::asn::asnUTCTime [::pki::x509::_native_to_utctime $notAfter]] \
+ ]
+
+ ## Insert subject
+ lappend certlist [::asn::asnSequence [::pki::x509::_string_to_dn $signreq(subject)]]
+
+ ## Insert public key information
+ switch -- $type {
+ "rsa" {
+ set pubkey [::asn::asnSequence \
+ [::asn::asnBigInteger [::math::bignum::fromstr $signreq(n)]] \
+ [::asn::asnBigInteger [::math::bignum::fromstr $signreq(e)]] \
+ ]
+
+ set pubkey_algo_params [::asn::asnNull]
+ }
+ }
+ binary scan $pubkey B* pubkey_bitstring
+
+ lappend certlist [::asn::asnSequence \
+ [::asn::asnSequence \
+ [::asn::asnObjectIdentifier [::pki::_oid_name_to_number "${type}Encryption"]] \
+ $pubkey_algo_params \
+ ] \
+ [::asn::asnBitString $pubkey_bitstring] \
+ ]
+
+ ## Insert extensions
+ if {[array get extensions] != ""} {
+ set extensionslist [list]
+
+ foreach {extension extvalue} [array get extensions] {
+ set critical 0
+
+ switch -- $extension {
+ "id-ce-basicConstraints" {
+ set critical [lindex $extvalue 0]
+ set allowCA [lindex $extvalue 1]
+ set caDepth [lindex $extvalue 2]
+
+ if {$caDepth < 0} {
+ set extvalue [::asn::asnSequence [::asn::asnBoolean $allowCA]]
+ } else {
+ set extvalue [::asn::asnSequence [::asn::asnBoolean $allowCA] [::asn::asnInteger $caDepth]]
+ }
+ }
+ default {
+ return -code error "Unknown extension: $extension"
+ }
+ }
+
+ lappend extensionslist [::asn::asnSequence \
+ [::asn::asnObjectIdentifier [::pki::_oid_name_to_number $extension]] \
+ [::asn::asnBoolean $critical] \
+ [::asn::asnOctetString $extvalue] \
+ ]
+ }
+
+ lappend certlist [::asn::asnContextConstr 3 [::asn::asnSequenceFromList $extensionslist]]
+ }
+
+ ## Enclose certificate data in an ASN.1 sequence
+ set cert [::asn::asnSequenceFromList $certlist]
+
+ # Sign certificate request using CA
+ set signature [::pki::sign $cert $cakeylist $algo]
+ binary scan $signature B* signature_bitstring
+
+ set cert [::asn::asnSequence \
+ $cert \
+ [::asn::asnSequence \
+ [::asn::asnObjectIdentifier [::pki::_oid_name_to_number "${algo}With${type}Encryption"]] \
+ [::asn::asnNull] \
+ ] \
+ [::asn::asnBitString $signature_bitstring] \
+ ]
+
+ if {$encodePem} {
+ set cert [::pki::_encode_pem $cert "-----BEGIN CERTIFICATE-----" "-----END CERTIFICATE-----"]
+ }
+
+ return $cert
+}
+
+proc ::pki::_bits {num} {
+ if {$num == 0} {
+ return 0
+ }
+
+ set num [format %llx $num]
+
+ set numlen [string length $num]
+
+ set numprecise 2
+
+ if {$numlen > $numprecise} {
+ set basebits [expr {($numlen - $numprecise) * 4}]
+ } else {
+ set basebits 0
+ }
+
+ set highbits 0x[string range $num 0 [expr {$numprecise - 1}]]
+
+ set ret [expr {$basebits + log($highbits) / 0.69314718055994530941723}]
+
+ set ret [expr {floor($ret) + 1}]
+
+ set ret [lindex [split $ret .] 0]
+
+ return $ret
+}
+
+proc ::pki::_random args {
+ if {[lindex $args 0] == "-binary"} {
+ set outputmode binary
+ } else {
+ set outputmode numeric
+ }
+
+ if {![info exists ::pki::_random_dev]} {
+ foreach trydev [list /dev/urandom /dev/random __RAND__] {
+ if {$trydev != "__RAND__"} {
+ if {[catch {
+ set fd [open $trydev [list RDONLY BINARY]]
+ close $fd
+ unset fd
+ }]} {
+ continue
+ }
+ }
+
+ set ::pki::_random_dev $trydev
+
+ break
+ }
+ }
+
+ set dev ${::pki::_random_dev}
+
+ switch -- $dev {
+ "__RAND__" {
+ set ret [expr {int(rand() * 2147483647)}]
+ }
+ default {
+ set fd [open $dev [list RDONLY BINARY]]
+ set data [read $fd 8]
+ close $fd
+
+ binary scan $data H* ret
+ set ret [expr 0x$ret]
+ }
+ }
+
+ switch -- $outputmode {
+ "numeric" {
+ # Do nothing, results are already numeric
+ }
+ "binary" {
+ set ret [binary format H* [format %02llx $ret]]
+ }
+ }
+
+ return $ret
+}
+
+proc ::pki::_isprime {n} {
+ set k 10
+
+ if {$n <= 3} {
+ return true
+ }
+
+ if {$n % 2 == 0} {
+ return false
+ }
+
+ # write n - 1 as 2^sd with d odd by factoring powers of 2 from n \u2212 1
+ set d [expr {$n - 1}]
+ set s 0
+ while {$d % 2 == 0} {
+ set d [expr {$d / 2}]
+ incr s
+ }
+
+ while {$k > 0} {
+ incr k -1
+ set rand_1 [expr {int(rand() * $::pki::INT_MAX)}]
+ set rand_2 [expr {int(rand() * $::pki::INT_MAX)}]
+ if {$rand_1 < $rand_2} {
+ set rand_num $rand_1
+ set rand_den $rand_2
+ } else {
+ set rand_num $rand_2
+ set rand_den $rand_1
+ }
+
+ set a [expr {2 + (($n - 4) * $rand_num / $rand_den)}]
+
+ set x [_powm $a $d $n]
+ if {$x == 1 || $x == $n - 1} {
+ continue
+ }
+
+ for {set r 1} {$r < $s} {incr r} {
+ set x [_powm $x 2 $n]
+ if {$x == 1} {
+ return false
+ }
+ if {$x == $n - 1} {
+ break
+ }
+ }
+
+ if {$x != $n - 1} {
+ return false
+ }
+ }
+
+ return true
+}
+
+proc ::pki::rsa::_generate_private {p q e bitlength} {
+ set totient [expr {($p - 1) * ($q - 1)}]
+
+ for {set di 1} {$di < $e} {incr di} {
+ set dchk [expr {($totient * $di + 1) / $e}]
+ set chkval [expr {$dchk * $e - 1}]
+
+ set rem [expr {$chkval % $totient}]
+ if {$rem == 0} {
+ break
+ }
+ }
+
+ # puts "bd=[_bits $dchk], di = $di"
+ for {} {1} {incr di $e} {
+ set dchk [expr {($totient * $di + 1) / $e}]
+ set chkval [expr {$dchk * $e - 1}]
+
+ set rem [expr {$chkval % $totient}]
+ if {$rem == 0} {
+ if {[::pki::_bits $dchk] > $bitlength} {
+ if {![info exists d]} {
+ set d $dchk
+ }
+
+ break
+ }
+
+ set d $dchk
+ }
+
+ }
+
+ return $d
+}
+
+proc ::pki::rsa::generate {bitlength {exponent 0x10001}} {
+ set e $exponent
+
+ # Step 1. Pick 2 numbers that when multiplied together will give a number with the appropriate length
+ set componentbitlen [expr {$bitlength / 2}]
+ set bitmask [expr {(1 << $componentbitlen) - 1}]
+
+ set p 0
+ set q 0
+ while 1 {
+ set plen [::pki::_bits $p]
+ set qlen [::pki::_bits $q]
+
+ if {$plen >= $componentbitlen} {
+ set p [expr {$p & $bitmask}]
+
+ set plen [::pki::_bits $p]
+ }
+
+ if {$qlen >= $componentbitlen} {
+ set q [expr {$q & $bitmask}]
+
+ set qlen [::pki::_bits $q]
+ }
+
+ if {$plen >= $componentbitlen && $qlen >= $componentbitlen} {
+ break
+ }
+
+ set x [::pki::_random]
+ set y [::pki::_random]
+
+ set xlen [expr {[::pki::_bits $x] / 2}]
+ set ylen [expr {[::pki::_bits $y] / 2}]
+
+ set xmask [expr {(1 << $xlen) - 1}]
+ set ymask [expr {(1 << $ylen) - 1}]
+
+ set p [expr {($p << $xlen) + ($x & $xmask)}]
+ set q [expr {($q << $ylen) + ($y & $ymask)}]
+ }
+
+
+ # Step 2. Verify that "p" and "q" are useful
+ ## Step 2.a. Verify that they are not too close
+ ### Where "too close" is defined as 2*n^(1/4)
+ set quadroot_of_n [expr {isqrt(isqrt($p * $q))}]
+ set min_distance [expr {2 * $quadroot_of_n}]
+ set distance [expr {abs($p - $q)}]
+
+ if {$distance < $min_distance} {
+ #### Try again.
+
+ return [::pki::rsa::generate $bitlength $exponent]
+ }
+
+ # Step 3. Convert the numbers into prime numbers
+ if {$p % 2 == 0} {
+ incr p -1
+ }
+ while {![::pki::_isprime $p]} {
+ incr p -2
+ }
+
+ if {$q % 2 == 0} {
+ incr q -1
+ }
+ while {![::pki::_isprime $q]} {
+ incr q -2
+ }
+
+ # Step 4. Compute N by multiplying P and Q
+ set n [expr {$p * $q}]
+ set retkey(n) $n
+
+ # Step 5. Compute D ...
+ ## Step 5.a. Generate D
+ set d [::pki::rsa::_generate_private $p $q $e $bitlength]
+ set retkey(d) $d
+
+ ## Step 5.b. Verify D is large enough
+ ### Verify that D is greater than (1/3)*n^(1/4)
+ set quadroot_of_n [expr {isqrt(isqrt($n))}]
+ set min_d [expr {$quadroot_of_n / 3}]
+ if {$d < $min_d} {
+ #### Try again.
+
+ return [::pki::rsa::generate $bitlength $exponent]
+ }
+
+ # Step 6. Encode key information
+ set retkey(type) rsa
+ set retkey(e) $e
+ set retkey(l) $bitlength
+
+ # Step 7. Record additional information that will be needed to write out a PKCS#1 compliant key
+ set retkey(p) $p
+ set retkey(q) $q
+
+ return [array get retkey]
+}
+
+## Initialize parsing routines, which may load additional packages (base64)
+::pki::_parse_init
+
+# # ## ### ##### ######## #############
+## Ready
+
+package provide pki 0.6
diff --git a/tcllib/modules/pki/pki.test b/tcllib/modules/pki/pki.test
new file mode 100644
index 0000000..9a66ff7
--- /dev/null
+++ b/tcllib/modules/pki/pki.test
@@ -0,0 +1,403 @@
+# rsa.test - Copyright (c) 2010 Roy Keene, Andreas Kupries
+#
+# the test-values are taken from:
+# ??
+#
+# $Id$
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ use asn/asn.tcl asn
+ use base64/base64.tcl base64
+ use des/des.tcl des
+ use math/bignum.tcl math::bignum
+ use md5/md5x.tcl md5 ;# md5 2.x!
+ use sha1/sha1.tcl sha1
+ use sha1/sha256.tcl sha256
+ use aes/aes.tcl aes
+}
+testing {
+ useLocal pki.tcl pki
+}
+
+# -------------------------------------------------------------------------
+
+test rsa-parse-aeskey-1.0 {parse_key} -setup {
+ set fd [open [file join $::tcltest::testsDirectory test.key.aes] r]
+ set privkey [read $fd]
+ close $fd ; unset fd
+
+ set password "ARoseIsARoseIsARose"
+} -body {
+ dictsort [::pki::pkcs::parse_key $privkey $password]
+} -cleanup {
+ unset privkey password
+} -result {d 4821708078078814272825737770757352316921506482526873519719051463644222257651923197825994018656421190278177720014932984365118366602027256382375921341192781177112398174373076887129954817822368157304055327895506098881228521168940083073283595671416028753301552269895847121119899618677892849270785450525228277087545852904246091363590456069440574806479467479724488815982259021323617233373449030738298588184972148901173121148634892058648703349014218791530847767762515588159636682267580355756974401553230588009724381821442787415368995149629493809933380894522643851913309510865914033228986295772184835354265231482340110365953 e 65537 l 2048 n 20606474229739240365059039861892702888430699076971875439310562489263214483191006887246310401088091004060054335612563612411917991000786455919906798626524375611634511845705141177165689526939976649836053082770641226108840795034158866930145876068965913035873741839723777813944236146677082729876717709231945588228947001753667862858297850461440476551869914895980840772354759428144421149613554402682425181850295101375623815063198594704730226304723548382258248785251384891817576645955371924194287071569929361029204431671633821160423187871463713776212876252047207985933876036458343140423787003660018607222053134170461225878347 p 151903506703070744388477144011062627922344490485619606525415439019240332914406492743669447033002173681213181316912563402042948038453846038272948559137687751740338183189809253891948725876860938554446847405802064303332011747457634488959045893106143553864597546566768167692662722957924358908573096347694362541259 q 135655026516400219835182288872064651548166413404981613626584975073279765274581289299963783472100901444904090497633607380440126562041149560121122191822729803838692049608052805597752016733559257401832457990520641184379220785155858496800358974243933025297673311305372951490297748845447521569920828454777048335233 type rsa}
+
+test rsa-parse-deskey-1.0 {parse_key} -setup {
+ set fd [open [file join $::tcltest::testsDirectory test.key.des] r]
+ set privkey [read $fd]
+ close $fd ; unset fd
+
+ set password "ARoseIsARoseIsARose"
+} -body {
+ dictsort [::pki::pkcs::parse_key $privkey $password]
+} -cleanup {
+ unset privkey password
+} -result {d 4821708078078814272825737770757352316921506482526873519719051463644222257651923197825994018656421190278177720014932984365118366602027256382375921341192781177112398174373076887129954817822368157304055327895506098881228521168940083073283595671416028753301552269895847121119899618677892849270785450525228277087545852904246091363590456069440574806479467479724488815982259021323617233373449030738298588184972148901173121148634892058648703349014218791530847767762515588159636682267580355756974401553230588009724381821442787415368995149629493809933380894522643851913309510865914033228986295772184835354265231482340110365953 e 65537 l 2048 n 20606474229739240365059039861892702888430699076971875439310562489263214483191006887246310401088091004060054335612563612411917991000786455919906798626524375611634511845705141177165689526939976649836053082770641226108840795034158866930145876068965913035873741839723777813944236146677082729876717709231945588228947001753667862858297850461440476551869914895980840772354759428144421149613554402682425181850295101375623815063198594704730226304723548382258248785251384891817576645955371924194287071569929361029204431671633821160423187871463713776212876252047207985933876036458343140423787003660018607222053134170461225878347 p 151903506703070744388477144011062627922344490485619606525415439019240332914406492743669447033002173681213181316912563402042948038453846038272948559137687751740338183189809253891948725876860938554446847405802064303332011747457634488959045893106143553864597546566768167692662722957924358908573096347694362541259 q 135655026516400219835182288872064651548166413404981613626584975073279765274581289299963783472100901444904090497633607380440126562041149560121122191822729803838692049608052805597752016733559257401832457990520641184379220785155858496800358974243933025297673311305372951490297748845447521569920828454777048335233 type rsa}
+
+test rsa-generate-csr-1.0 {csr} -setup {
+ set fd [open [file join $::tcltest::testsDirectory test.key.des] r]
+ set privkey [read $fd]
+ close $fd ; unset fd
+
+ set password "ARoseIsARoseIsARose"
+
+ set privkey [::pki::pkcs::parse_key $privkey $password]
+} -body {
+ ::pki::pkcs::create_csr $privkey [list C US ST Florida L Tampa O Tcllib OU RSA CN TestCert] 1
+} -cleanup {
+ unset privkey password
+} -result {-----BEGIN CERTIFICATE REQUEST-----
+MIICpjCCAY4CAQAwYTELMAkGA1UEBhMCVVMxEDAOBgNVBAgTB0Zsb3JpZGExDjAM
+BgNVBAcTBVRhbXBhMQ8wDQYDVQQKEwZUY2xsaWIxDDAKBgNVBAsTA1JTQTERMA8G
+A1UEAxMIVGVzdENlcnQwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCj
+PBaKPeHx1oQb0nfMPeglBgyIpsv8CuIH7CAT8SGxoK1zIBQUhnNOZvel1/Kore68
+mY0ftiqmVbLO7aZy9X0Vy97hcEnhIekuPCauVg3kWjOspPbxmd3Bf7vfw7RGsvUt
+GGc3FZnU/X3GhzlKCq1osQCSZdLwirDm8ny4tbkTEDnGIB+4IJbSvifGQDqQNwtx
+cDigwRwAgDDdaKYBiW4bp+ZowJxorqc60w6xcl8DKhpPPaqRFN2kBcAxU/vztan1
+5NjNmmOPIkDcvIDEEkxKDoefTWaaF/MEGNtZZgIfIbVMos9+1soBzBb2ZH5NVtuK
+3RGA+4DxUk5kiI+eLANLAgMBAAGgADANBgkqhkiG9w0BAQUFAAOCAQEAff0WNTPX
+M6rdFGOXBxTsC7NUGcoquuM6QsceadMbBVRtRUUbaUsusXdxDWhdylqHM3xPNx0L
+4Ex0FeL9icD/8xvJmCXzBeNt3uvThTvIwHYqnOCSlhx9InUUx2l6U0rAwZ+CIuMi
+7lG2+Z5qVD035bAZ7LT/4s4fjKSL4cTZQOdCcoFtoptj9+L8EItwwYDzffJWdG8s
+OUtMBn+Zh45k2UtLKu38jBNtVpNFAEJLlr/Arj6Jj3yTmEFrocxkwK6IPbOHQTu3
+tyJ5CkDpUqkxYZ0D4wfr8tFEru0jQNl5bSDt9QQvg1Kj6+OC9aaRvxwnmc6REfky
+8sCv80Pn5dNCGg==
+-----END CERTIFICATE REQUEST-----
+}
+
+test rsa-parse-certv1-1.0 {parse_cert} -setup {
+ set fd [open [file join $::tcltest::testsDirectory test-v1.crt] r]
+ set pubkey [read $fd]
+ close $fd ; unset fd
+} -body {
+ dictsort [::pki::x509::parse_cert $pubkey]
+} -cleanup {
+ unset pubkey
+} -result {cert 30820221020612481595aa03300d06092a864886f70d0101050500305f310b30090603550406130255533110300e06035504081307466c6f72696461310e300c0603550407130554616d7061310f300d060355040a130654636c6c6962310c300a060355040b1303525341310f300d06035504031306546573744341301e170d3130303830393037353230355a170d3230303830393037353230355a3061310b30090603550406130255533110300e06035504081307466c6f72696461310e300c0603550407130554616d7061310f300d060355040a130654636c6c6962310c300a060355040b13035253413111300f06035504031308546573744365727430820122300d06092a864886f70d01010105000382010f003082010a0282010100a33c168a3de1f1d6841bd277cc3de825060c88a6cbfc0ae207ec2013f121b1a0ad7320141486734e66f7a5d7f2a8adeebc998d1fb62aa655b2ceeda672f57d15cbdee17049e121e92e3c26ae560de45a33aca4f6f199ddc17fbbdfc3b446b2f52d1867371599d4fd7dc687394a0aad68b1009265d2f08ab0e6f27cb8b5b9131039c6201fb82096d2be27c6403a90370b717038a0c11c008030dd68a601896e1ba7e668c09c68aea73ad30eb1725f032a1a4f3daa9114dda405c03153fbf3b5a9f5e4d8cd9a638f2240dcbc80c4124c4a0e879f4d669a17f30418db5966021f21b54ca2cf7ed6ca01cc16f6647e4d56db8add1180fb80f1524e64888f9e2c034b0203010001 data_signature_algo sha1WithRSAEncryption e 65537 extensions {} issuer {C=US, ST=Florida, L=Tampa, O=Tcllib, OU=RSA, CN=TestCA} l 2048 n 20606474229739240365059039861892702888430699076971875439310562489263214483191006887246310401088091004060054335612563612411917991000786455919906798626524375611634511845705141177165689526939976649836053082770641226108840795034158866930145876068965913035873741839723777813944236146677082729876717709231945588228947001753667862858297850461440476551869914895980840772354759428144421149613554402682425181850295101375623815063198594704730226304723548382258248785251384891817576645955371924194287071569929361029204431671633821160423187871463713776212876252047207985933876036458343140423787003660018607222053134170461225878347 notAfter 1596959525 notBefore 1281340325 pubkey 3082010a0282010100a33c168a3de1f1d6841bd277cc3de825060c88a6cbfc0ae207ec2013f121b1a0ad7320141486734e66f7a5d7f2a8adeebc998d1fb62aa655b2ceeda672f57d15cbdee17049e121e92e3c26ae560de45a33aca4f6f199ddc17fbbdfc3b446b2f52d1867371599d4fd7dc687394a0aad68b1009265d2f08ab0e6f27cb8b5b9131039c6201fb82096d2be27c6403a90370b717038a0c11c008030dd68a601896e1ba7e668c09c68aea73ad30eb1725f032a1a4f3daa9114dda405c03153fbf3b5a9f5e4d8cd9a638f2240dcbc80c4124c4a0e879f4d669a17f30418db5966021f21b54ca2cf7ed6ca01cc16f6647e4d56db8add1180fb80f1524e64888f9e2c034b0203010001 pubkey_algo rsaEncryption serial_number 20100809075203 signature 7acbd0a587f1663e8a21b65f9161f08431f454d8b988f52f68d6d5bd9ad9675475819024f11c9c40df209fb05a297ffa72292c81e29bbc6c32e49bd968a49e77ae7be1055357e98602a031396f8b994455f936a85922800bddc379b76c2f63653c3b2bbaec4c81bedf9f9da78b6a80b253e8f98cde7289085837b22af454083ec6b772c374b40f1bf8d3c7a5e779b6fbbac885a5fa905a115475c7cf8a4d18deb7c91b96d5e47ba1291f4bc702371f1aede0b952648a6894c5e4c2496a7a8234788a7290d256e5cda99b772f43f019ddb1d758d06a1fd03865fdce762cf22850f996aa8cdc7d844115e3d1c533428d96a9fe774ba5ba07817607664b6bf3bf12 signature_algo sha1WithRSAEncryption subject {C=US, ST=Florida, L=Tampa, O=Tcllib, OU=RSA, CN=TestCert} type rsa version 1}
+
+test rsa-parse-certv3-1.0 {parse_cert} -setup {
+ set fd [open [file join $::tcltest::testsDirectory test-v3.crt] r]
+ set pubkey [read $fd]
+ close $fd ; unset fd
+} -body {
+ dictsort [::pki::x509::parse_cert $pubkey]
+} -cleanup {
+ unset pubkey
+} -result {cert 30820226a003020102020612481595a9c0300d06092a864886f70d0101050500305f310b30090603550406130255533110300e06035504081307466c6f72696461310e300c0603550407130554616d7061310f300d060355040a130654636c6c6962310c300a060355040b1303525341310f300d06035504031306546573744341301e170d3130303830393037353133365a170d3230303830393037353133365a3061310b30090603550406130255533110300e06035504081307466c6f72696461310e300c0603550407130554616d7061310f300d060355040a130654636c6c6962310c300a060355040b13035253413111300f06035504031308546573744365727430820122300d06092a864886f70d01010105000382010f003082010a0282010100a33c168a3de1f1d6841bd277cc3de825060c88a6cbfc0ae207ec2013f121b1a0ad7320141486734e66f7a5d7f2a8adeebc998d1fb62aa655b2ceeda672f57d15cbdee17049e121e92e3c26ae560de45a33aca4f6f199ddc17fbbdfc3b446b2f52d1867371599d4fd7dc687394a0aad68b1009265d2f08ab0e6f27cb8b5b9131039c6201fb82096d2be27c6403a90370b717038a0c11c008030dd68a601896e1ba7e668c09c68aea73ad30eb1725f032a1a4f3daa9114dda405c03153fbf3b5a9f5e4d8cd9a638f2240dcbc80c4124c4a0e879f4d669a17f30418db5966021f21b54ca2cf7ed6ca01cc16f6647e4d56db8add1180fb80f1524e64888f9e2c034b0203010001 data_signature_algo sha1WithRSAEncryption e 65537 extensions {} issuer {C=US, ST=Florida, L=Tampa, O=Tcllib, OU=RSA, CN=TestCA} l 2048 n 20606474229739240365059039861892702888430699076971875439310562489263214483191006887246310401088091004060054335612563612411917991000786455919906798626524375611634511845705141177165689526939976649836053082770641226108840795034158866930145876068965913035873741839723777813944236146677082729876717709231945588228947001753667862858297850461440476551869914895980840772354759428144421149613554402682425181850295101375623815063198594704730226304723548382258248785251384891817576645955371924194287071569929361029204431671633821160423187871463713776212876252047207985933876036458343140423787003660018607222053134170461225878347 notAfter 1596959496 notBefore 1281340296 pubkey 3082010a0282010100a33c168a3de1f1d6841bd277cc3de825060c88a6cbfc0ae207ec2013f121b1a0ad7320141486734e66f7a5d7f2a8adeebc998d1fb62aa655b2ceeda672f57d15cbdee17049e121e92e3c26ae560de45a33aca4f6f199ddc17fbbdfc3b446b2f52d1867371599d4fd7dc687394a0aad68b1009265d2f08ab0e6f27cb8b5b9131039c6201fb82096d2be27c6403a90370b717038a0c11c008030dd68a601896e1ba7e668c09c68aea73ad30eb1725f032a1a4f3daa9114dda405c03153fbf3b5a9f5e4d8cd9a638f2240dcbc80c4124c4a0e879f4d669a17f30418db5966021f21b54ca2cf7ed6ca01cc16f6647e4d56db8add1180fb80f1524e64888f9e2c034b0203010001 pubkey_algo rsaEncryption serial_number 20100809075136 signature 30105b040c0d26a7899098e61b73844741510637bdb70ad81c10717bba7bb8dc478ee6cff562ad05f92756475e0ba85b3a9515e73e3904a48165996e48d03a7c435c98d7ca913edf07c7aca6c6dcbc4169bd953c0c073ad8521f7826a57e63740725b56b80ba68291a6c54ea6c74ce6a43879fbd0c0ed2c3b023901a8ef932535742f13b31033c893107caf9642c034952a6a3341edae5d714610d9c040bc044dfeec8bfd3125bf46f2ba15a68e164ca3bdf59f38b8117d1b4c43cfa1755f1169212aaa44ac8251b39b349bb931e8a419257b529e82ad8777fd65a62f45a171eb1b18f0196570e4a3b058e09ad0ec85e0a5968a330e59b32b22a2eae69e1a3a4 signature_algo sha1WithRSAEncryption subject {C=US, ST=Florida, L=Tampa, O=Tcllib, OU=RSA, CN=TestCert} type rsa version 3}
+
+test rsa-parse-cacert-1.0 {parse_cert} -setup {
+ set fd [open [file join $::tcltest::testsDirectory CA.crt] r]
+ set pubkey [read $fd]
+ close $fd ; unset fd
+} -body {
+ dictsort [::pki::x509::parse_cert $pubkey]
+} -cleanup {
+ unset pubkey
+} -result {cert 308202eea0030201020209009b29b6c41fdd35cf300d06092a864886f70d0101050500305f310b30090603550406130255533110300e06035504081307466c6f72696461310e300c0603550407130554616d7061310f300d060355040a130654636c6c6962310c300a060355040b1303525341310f300d06035504031306546573744341301e170d3130303830393037333733385a170d3335303831303037333733385a305f310b30090603550406130255533110300e06035504081307466c6f72696461310e300c0603550407130554616d7061310f300d060355040a130654636c6c6962310c300a060355040b1303525341310f300d0603550403130654657374434130820122300d06092a864886f70d01010105000382010f003082010a0282010100bf65944eeba4d516f9823cadd420a06e3413f14c32eda1f7fea95730ad20ba8e2c5952312210e02c4a848ccfba23fe052b9f35799e3174ae7a27ee4f69a56f96a9e93dad99de558b4f6e9b9c70dd2a6ed89bb3ed97e32c3167b0cc6e17753843097ff6a13276686d0e76004c2f22462717b0f1af3557936605f7899cf3037b85903e8d5449225f55f7320984f1e0864f0e14fe4dcc20aef03d0b593123b801ecbd23fb9be62799ac02b4c992e38ae6cfdbb81bf19209c0ad845c8da56591fa83c24c2fb4705b962bd15a1ccc47fbf70280522d79c5029f87e8315734e7b8a81d27f64ccb3716f8f75aa756251df7b041fc5e1c1b7ad1192bdb1d94154e212c810203010001a381c43081c1301d0603551d0e04160414852c1d09b76b0fa10e35d7aa4bcb48b2deb254d53081910603551d230481893081868014852c1d09b76b0fa10e35d7aa4bcb48b2deb254d5a163a461305f310b30090603550406130255533110300e06035504081307466c6f72696461310e300c0603550407130554616d7061310f300d060355040a130654636c6c6962310c300a060355040b1303525341310f300d060355040313065465737443418209009b29b6c41fdd35cf300c0603551d13040530030101ff data_signature_algo sha1WithRSAEncryption e 65537 extensions {id-ce-subjectKeyIdentifier {false 0414852c1d09b76b0fa10e35d7aa4bcb48b2deb254d5} id-ce-authorityKeyIdentifier {false 3081868014852c1d09b76b0fa10e35d7aa4bcb48b2deb254d5a163a461305f310b30090603550406130255533110300e06035504081307466c6f72696461310e300c0603550407130554616d7061310f300d060355040a130654636c6c6962310c300a060355040b1303525341310f300d060355040313065465737443418209009b29b6c41fdd35cf} id-ce-basicConstraints {false 1 -1}} issuer {C=US, ST=Florida, L=Tampa, O=Tcllib, OU=RSA, CN=TestCA} l 2048 n 24161606882664512184359265185750837725108535101957340182512690512950889280510175836653980019439405807509520118166835198926328713901946216313990307823213762851130122553610411084164096778558222486569750697608231998818342043083553499928765840766586577148563804434733745484416582976688503343857730022194918419820043366167270205314454789050632414594372175021330643138454461788318306110532766986666994575469007919602783172146356611527403971910037954057021421611608595373199910520988014831498419657809400692831589285260267441816651113464389720766612297754777522129247659432535168409289483999817599902067306541004223550663809 notAfter 2070344258 notBefore 1281339458 pubkey 3082010a0282010100bf65944eeba4d516f9823cadd420a06e3413f14c32eda1f7fea95730ad20ba8e2c5952312210e02c4a848ccfba23fe052b9f35799e3174ae7a27ee4f69a56f96a9e93dad99de558b4f6e9b9c70dd2a6ed89bb3ed97e32c3167b0cc6e17753843097ff6a13276686d0e76004c2f22462717b0f1af3557936605f7899cf3037b85903e8d5449225f55f7320984f1e0864f0e14fe4dcc20aef03d0b593123b801ecbd23fb9be62799ac02b4c992e38ae6cfdbb81bf19209c0ad845c8da56591fa83c24c2fb4705b962bd15a1ccc47fbf70280522d79c5029f87e8315734e7b8a81d27f64ccb3716f8f75aa756251df7b041fc5e1c1b7ad1192bdb1d94154e212c810203010001 pubkey_algo rsaEncryption serial_number 11180668503388403151 signature bed4868761d804d7e08bec1aaaf265d2d59c6f5390c9fda3c81ef4452ea58b6df7ff7f2be33276a5c21d5b8ac0c62be55e52e47010c704d34380723da2d8cfe57c76e9b204e752a79979c7935627eda80a7fc3a4bed4f5ecea2fd83311fe4054bc62812a3f579738b94a44e0aded6c61c3569175cfb393e8b3a992f5ae8b51692d0a0373d1ca0664f527e7d04877ec49c57ae53eaab100063d4c915ea87bf4b22b634656bc3ba7e71cb5dca982937ec6736f9f0b1da6404245c9a08ca23b027c9cf65d1b41b709fc6e90671543f5f3b7f8b27914e466bfe538d01aae9804fd81591f16ded334cc693929ba0896d8d049b5bd29856b6ada45fa0a777ba9e2f41d signature_algo sha1WithRSAEncryption subject {C=US, ST=Florida, L=Tampa, O=Tcllib, OU=RSA, CN=TestCA} type rsa version 3}
+
+test rsa-generate-cert-1.0 {cert} -setup {
+ set fd [open [file join $::tcltest::testsDirectory test.key.des] r]
+ set privkey [read $fd]
+ close $fd ; unset fd
+
+ set fd [open [file join $::tcltest::testsDirectory CA.crt] r]
+ set cacert [read $fd]
+ close $fd ; unset fd
+
+ set fd [open [file join $::tcltest::testsDirectory CA.key] r]
+ set cakey [read $fd]
+ close $fd ; unset fd
+
+ set password "ARoseIsARoseIsARose"
+
+ set privkey [::pki::pkcs::parse_key $privkey $password]
+
+ array set ca_arr [::pki::pkcs::parse_key $cakey $password]
+ array set ca_arr [::pki::x509::parse_cert $cacert]
+ set ca [array get ca_arr]
+
+ set csr [::pki::pkcs::parse_csr [::pki::pkcs::create_csr $privkey [list C US ST Florida L Tampa O Tcllib OU RSA CN TestCert]]]
+} -body {
+ ::pki::x509::create_cert $csr $ca 20100809075203 1281340325 1596959525 0 "" 1
+} -cleanup {
+ unset privkey cakey cacert ca_arr ca password csr
+} -result {-----BEGIN CERTIFICATE-----
+MIIDOTCCAiECBhJIFZWqAzANBgkqhkiG9w0BAQUFADBfMQswCQYDVQQGEwJVUzEQ
+MA4GA1UECBMHRmxvcmlkYTEOMAwGA1UEBxMFVGFtcGExDzANBgNVBAoTBlRjbGxp
+YjEMMAoGA1UECxMDUlNBMQ8wDQYDVQQDEwZUZXN0Q0EwHhcNMTAwODA5MDc1MjA1
+WhcNMjAwODA5MDc1MjA1WjBhMQswCQYDVQQGEwJVUzEQMA4GA1UECBMHRmxvcmlk
+YTEOMAwGA1UEBxMFVGFtcGExDzANBgNVBAoTBlRjbGxpYjEMMAoGA1UECxMDUlNB
+MREwDwYDVQQDEwhUZXN0Q2VydDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoC
+ggEBAKM8Foo94fHWhBvSd8w96CUGDIimy/wK4gfsIBPxIbGgrXMgFBSGc05m96XX
+8qit7ryZjR+2KqZVss7tpnL1fRXL3uFwSeEh6S48Jq5WDeRaM6yk9vGZ3cF/u9/D
+tEay9S0YZzcVmdT9fcaHOUoKrWixAJJl0vCKsObyfLi1uRMQOcYgH7ggltK+J8ZA
+OpA3C3FwOKDBHACAMN1opgGJbhun5mjAnGiupzrTDrFyXwMqGk89qpEU3aQFwDFT
++/O1qfXk2M2aY48iQNy8gMQSTEoOh59NZpoX8wQY21lmAh8htUyiz37WygHMFvZk
+fk1W24rdEYD7gPFSTmSIj54sA0sCAwEAATANBgkqhkiG9w0BAQUFAAOCAQEAesvQ
+pYfxZj6KIbZfkWHwhDH0VNi5iPUvaNbVvZrZZ1R1gZAk8RycQN8gn7BaKX/6ciks
+geKbvGwy5JvZaKSed6574QVTV+mGAqAxOW+LmURV+TaoWSKAC93DebdsL2NlPDsr
+uuxMgb7fn52ni2qAslPo+YzecokIWDeyKvRUCD7Gt3LDdLQPG/jTx6Xnebb7usiF
+pfqQWhFUdcfPik0Y3rfJG5bV5HuhKR9LxwI3Hxrt4LlSZIpolMXkwklqeoI0eIpy
+kNJW5c2pm3cvQ/AZ3bHXWNBqH9A4Zf3OdizyKFD5lqqM3H2EQRXj0cUzQo2Wqf53
+S6W6B4F2B2ZLa/O/Eg==
+-----END CERTIFICATE-----
+}
+
+test rsa-generate-cacert-1.0 {cert} -setup {
+ set fd [open [file join $::tcltest::testsDirectory test.key.des] r]
+ set privkey [read $fd]
+ close $fd ; unset fd
+
+ set fd [open [file join $::tcltest::testsDirectory CA.crt] r]
+ set cacert [read $fd]
+ close $fd ; unset fd
+
+ set fd [open [file join $::tcltest::testsDirectory CA.key] r]
+ set cakey [read $fd]
+ close $fd ; unset fd
+
+ set password "ARoseIsARoseIsARose"
+
+ set privkey [::pki::pkcs::parse_key $privkey $password]
+
+ array set ca_arr [::pki::pkcs::parse_key $cakey $password]
+ array set ca_arr [::pki::x509::parse_cert $cacert]
+ set ca [array get ca_arr]
+
+ set csr [::pki::pkcs::parse_csr [::pki::pkcs::create_csr $privkey [list C US ST Florida L Tampa O Tcllib OU RSA CN TestCert]]]
+} -body {
+ ::pki::x509::create_cert $csr $ca 20100809075203 1281340325 1596959525 1 "" 1
+} -cleanup {
+ unset privkey cakey cacert ca_arr ca password csr
+} -result {-----BEGIN CERTIFICATE-----
+MIIDUzCCAjugAwIBAgIGEkgVlaoDMA0GCSqGSIb3DQEBBQUAMF8xCzAJBgNVBAYT
+AlVTMRAwDgYDVQQIEwdGbG9yaWRhMQ4wDAYDVQQHEwVUYW1wYTEPMA0GA1UEChMG
+VGNsbGliMQwwCgYDVQQLEwNSU0ExDzANBgNVBAMTBlRlc3RDQTAeFw0xMDA4MDkw
+NzUyMDVaFw0yMDA4MDkwNzUyMDVaMGExCzAJBgNVBAYTAlVTMRAwDgYDVQQIEwdG
+bG9yaWRhMQ4wDAYDVQQHEwVUYW1wYTEPMA0GA1UEChMGVGNsbGliMQwwCgYDVQQL
+EwNSU0ExETAPBgNVBAMTCFRlc3RDZXJ0MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8A
+MIIBCgKCAQEAozwWij3h8daEG9J3zD3oJQYMiKbL/AriB+wgE/EhsaCtcyAUFIZz
+Tmb3pdfyqK3uvJmNH7YqplWyzu2mcvV9Fcve4XBJ4SHpLjwmrlYN5FozrKT28Znd
+wX+738O0RrL1LRhnNxWZ1P19xoc5SgqtaLEAkmXS8Iqw5vJ8uLW5ExA5xiAfuCCW
+0r4nxkA6kDcLcXA4oMEcAIAw3WimAYluG6fmaMCcaK6nOtMOsXJfAyoaTz2qkRTd
+pAXAMVP787Wp9eTYzZpjjyJA3LyAxBJMSg6Hn01mmhfzBBjbWWYCHyG1TKLPftbK
+AcwW9mR+TVbbit0RgPuA8VJOZIiPniwDSwIDAQABoxMwETAPBgNVHRMBAf8EBTAD
+AQH/MA0GCSqGSIb3DQEBBQUAA4IBAQA5nJ5k5HpGnBmDTB/cWd6LP7ygQ/jg9SEc
+dVhSb6xy7h7O2txsndfH5fTyJilKRAfl/NGs5ZyV9q97OIP1aAhIRQiKUwSHu2+l
+kHHVNn8DFGHRKhA5YSreZKR++tjAmowk0XQbEU33MZVPGPFlrL37V84Xf04MmFdD
+kFtZO/soAzO8cPVizz3DNk7SNDCsWjmaTVH1yKmzBLJhrU86o4BEqbYbjbwdtelZ
+cgeGPntr9c/ngnUlPU90HNp2e65zHUyf/3hWps72tSx5dNKcaE9NX8xxK5WZde8i
+mn/PueMPCKdX1v9Nou51yReEa8D9h7D7klWwacrRoYh9Y4++g1by
+-----END CERTIFICATE-----
+}
+
+test rsa-verify-certv1-1.0 {verify_cert} -setup {
+ set fd [open [file join $::tcltest::testsDirectory test-v1.crt] r]
+ set pubcert [read $fd]
+ close $fd ; unset fd
+
+ set fd [open [file join $::tcltest::testsDirectory CA.crt] r]
+ set cacert [read $fd]
+ close $fd ; unset fd
+
+ set pubcert [::pki::x509::parse_cert $pubcert]
+ set cacert [::pki::x509::parse_cert $cacert]
+} -body {
+ ::pki::x509::verify_cert $pubcert [list $cacert]
+} -cleanup {
+ unset pubcert cacert
+} -result {true}
+
+test rsa-verify-certv3-1.0 {verify_cert} -setup {
+ set fd [open [file join $::tcltest::testsDirectory test-v3.crt] r]
+ set pubcert [read $fd]
+ close $fd ; unset fd
+
+ set fd [open [file join $::tcltest::testsDirectory CA.crt] r]
+ set cacert [read $fd]
+ close $fd ; unset fd
+
+ set pubcert [::pki::x509::parse_cert $pubcert]
+ set cacert [::pki::x509::parse_cert $cacert]
+} -body {
+ ::pki::x509::verify_cert $pubcert [list $cacert]
+} -cleanup {
+ unset pubcert cacert
+} -result {true}
+
+test rsa-verify-badcertv1-1.0 {verify_cert} -setup {
+ set fd [open [file join $::tcltest::testsDirectory test-v1.crt] r]
+ set pubcert [read $fd]
+ close $fd ; unset fd
+
+ set fd [open [file join $::tcltest::testsDirectory test-v1.crt] r]
+ set cacert [read $fd]
+ close $fd ; unset fd
+
+ set pubcert [::pki::x509::parse_cert $pubcert]
+ set cacert [::pki::x509::parse_cert $cacert]
+} -body {
+ ::pki::x509::verify_cert $pubcert [list $cacert]
+} -cleanup {
+ unset pubcert cacert
+} -result {false}
+
+test rsa-verify-badcertv3-1.0 {verify_cert} -setup {
+ set fd [open [file join $::tcltest::testsDirectory test-v3.crt] r]
+ set pubcert [read $fd]
+ close $fd ; unset fd
+
+ set fd [open [file join $::tcltest::testsDirectory test-v3.crt] r]
+ set cacert [read $fd]
+ close $fd ; unset fd
+
+ set pubcert [::pki::x509::parse_cert $pubcert]
+ set cacert [::pki::x509::parse_cert $cacert]
+} -body {
+ ::pki::x509::verify_cert $pubcert [list $cacert]
+} -cleanup {
+ unset pubcert cacert
+} -result {false}
+
+test rsa-verify-badcertv3-2.0 {verify_cert} -setup {
+ set fd [open [file join $::tcltest::testsDirectory test-v3.crt] r]
+ set pubcert [read $fd]
+ close $fd ; unset fd
+
+ set fd [open [file join $::tcltest::testsDirectory CA.crt] r]
+ set cacert [read $fd]
+ close $fd ; unset fd
+
+ set pubcert [::pki::x509::parse_cert $pubcert]
+ set cacert [::pki::x509::parse_cert $cacert]
+
+ # Remove all extensions from CA cert
+ array set cacert_arr $cacert
+ set cacert_arr(extensions) ""
+ set cacert [array get cacert_arr]
+} -body {
+ ::pki::x509::verify_cert $pubcert [list $cacert]
+} -cleanup {
+ unset pubcert cacert
+} -result {false}
+
+test rsa-crypt-roundtrip-1.0 {encrypt, decrypt} -setup {
+ set data "This is a test"
+ set password "ARoseIsARoseIsARose"
+
+ set fd [open [file join $::tcltest::testsDirectory test.key.des] r]
+ set privkey [read $fd]
+ close $fd ; unset fd
+
+ set fd [open [file join $::tcltest::testsDirectory test-v1.crt] r]
+ set pubkey [read $fd]
+ close $fd ; unset fd
+
+ array set key [::pki::pkcs::parse_key $privkey $password]
+ array set key [::pki::x509::parse_cert $pubkey]
+ set keylist [array get key]
+ unset password privkey pubkey key
+} -body {
+ set ciphertext [::pki::encrypt -binary -pub -- $data $keylist]
+ set plaintext [::pki::decrypt -binary -priv -- $ciphertext $keylist]
+} -cleanup {
+ unset -nocomplain data ciphertext plaintext
+} -result {This is a test}
+
+test rsa-sign-verify-1.0 {sign, verify} -setup {
+ set data "This is a test"
+ set password "ARoseIsARoseIsARose"
+
+ set fd [open [file join $::tcltest::testsDirectory test.key.des] r]
+ set privkey [read $fd]
+ close $fd ; unset fd
+
+ set fd [open [file join $::tcltest::testsDirectory test-v1.crt] r]
+ set pubkey [read $fd]
+ close $fd ; unset fd
+
+ array set key [::pki::pkcs::parse_key $privkey $password]
+ array set key [::pki::x509::parse_cert $pubkey]
+ set keylist [array get key]
+ unset password privkey pubkey key
+} -body {
+ set ciphertext [::pki::encrypt -binary -priv -- $data $keylist]
+ set plaintext [::pki::decrypt -binary -pub -- $ciphertext $keylist]
+} -cleanup {
+ unset -nocomplain data ciphertext plaintext
+} -result {This is a test}
+
+
+foreach keylen {256 512 1024 2048} {
+
+ # Just one key for the whole round and its tests. Its possible to
+ # generate one for each test, but then we will really spend way to
+ # much effort on the setup of each test.
+ set key [::pki::rsa::generate $keylen]
+
+ test rsa-crypt-roundtrip-2.0.$keylen "encrypt, decrypt pub/priv for keylen $keylen" -body {
+ set plain "Pub/priv test"
+ set cipher [::pki::encrypt -binary -pub -- $plain $key]
+ set uncipher [::pki::decrypt -binary -priv -- $cipher $key]
+
+ string equal $plain $uncipher
+ } -cleanup {
+ unset -nocomplain plain cipher uncipher
+ } -result 1
+
+ test rsa-crypt-roundtrip-2.1.$keylen "encrypt, decrypt priv/pub for keylen $keylen" -body {
+ set plain "Priv/pub test"
+ set cipher [::pki::encrypt -binary -priv -- $plain $key]
+ set uncipher [::pki::decrypt -binary -pub -- $cipher $key]
+
+ string equal $plain $uncipher
+ } -cleanup {
+ unset -nocomplain plain cipher uncipher
+ } -result 1
+
+ if {$keylen >= 512} {
+ foreach {i hash} {
+ 0 md5
+ 1 sha1
+ 2 sha256
+ } {
+ test rsa-sign-verify-2.$i.$keylen "sign, verify $hash for keylen $keylen" -body {
+ set plain "This message is so long, it will never fit into a key"
+ set signed [::pki::sign $plain $key $hash]
+ set verified [::pki::verify $signed $plain $key]
+ } -cleanup {
+ unset -nocomplain plain signed verified
+ } -result true
+ }
+ }
+
+ unset key
+}
+
+# -------------------------------------------------------------------------
+testsuiteCleanup
+
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
diff --git a/tcllib/modules/pki/test-v1.crt b/tcllib/modules/pki/test-v1.crt
new file mode 100644
index 0000000..e39d88b
--- /dev/null
+++ b/tcllib/modules/pki/test-v1.crt
@@ -0,0 +1,20 @@
+-----BEGIN CERTIFICATE-----
+MIIDOTCCAiECBhJIFZWqAzANBgkqhkiG9w0BAQUFADBfMQswCQYDVQQGEwJVUzEQ
+MA4GA1UECBMHRmxvcmlkYTEOMAwGA1UEBxMFVGFtcGExDzANBgNVBAoTBlRjbGxp
+YjEMMAoGA1UECxMDUlNBMQ8wDQYDVQQDEwZUZXN0Q0EwHhcNMTAwODA5MDc1MjA1
+WhcNMjAwODA5MDc1MjA1WjBhMQswCQYDVQQGEwJVUzEQMA4GA1UECBMHRmxvcmlk
+YTEOMAwGA1UEBxMFVGFtcGExDzANBgNVBAoTBlRjbGxpYjEMMAoGA1UECxMDUlNB
+MREwDwYDVQQDEwhUZXN0Q2VydDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoC
+ggEBAKM8Foo94fHWhBvSd8w96CUGDIimy/wK4gfsIBPxIbGgrXMgFBSGc05m96XX
+8qit7ryZjR+2KqZVss7tpnL1fRXL3uFwSeEh6S48Jq5WDeRaM6yk9vGZ3cF/u9/D
+tEay9S0YZzcVmdT9fcaHOUoKrWixAJJl0vCKsObyfLi1uRMQOcYgH7ggltK+J8ZA
+OpA3C3FwOKDBHACAMN1opgGJbhun5mjAnGiupzrTDrFyXwMqGk89qpEU3aQFwDFT
++/O1qfXk2M2aY48iQNy8gMQSTEoOh59NZpoX8wQY21lmAh8htUyiz37WygHMFvZk
+fk1W24rdEYD7gPFSTmSIj54sA0sCAwEAATANBgkqhkiG9w0BAQUFAAOCAQEAesvQ
+pYfxZj6KIbZfkWHwhDH0VNi5iPUvaNbVvZrZZ1R1gZAk8RycQN8gn7BaKX/6ciks
+geKbvGwy5JvZaKSed6574QVTV+mGAqAxOW+LmURV+TaoWSKAC93DebdsL2NlPDsr
+uuxMgb7fn52ni2qAslPo+YzecokIWDeyKvRUCD7Gt3LDdLQPG/jTx6Xnebb7usiF
+pfqQWhFUdcfPik0Y3rfJG5bV5HuhKR9LxwI3Hxrt4LlSZIpolMXkwklqeoI0eIpy
+kNJW5c2pm3cvQ/AZ3bHXWNBqH9A4Zf3OdizyKFD5lqqM3H2EQRXj0cUzQo2Wqf53
+S6W6B4F2B2ZLa/O/Eg==
+-----END CERTIFICATE-----
diff --git a/tcllib/modules/pki/test-v3.crt b/tcllib/modules/pki/test-v3.crt
new file mode 100644
index 0000000..f3ba676
--- /dev/null
+++ b/tcllib/modules/pki/test-v3.crt
@@ -0,0 +1,20 @@
+-----BEGIN CERTIFICATE-----
+MIIDPjCCAiagAwIBAgIGEkgVlanAMA0GCSqGSIb3DQEBBQUAMF8xCzAJBgNVBAYT
+AlVTMRAwDgYDVQQIEwdGbG9yaWRhMQ4wDAYDVQQHEwVUYW1wYTEPMA0GA1UEChMG
+VGNsbGliMQwwCgYDVQQLEwNSU0ExDzANBgNVBAMTBlRlc3RDQTAeFw0xMDA4MDkw
+NzUxMzZaFw0yMDA4MDkwNzUxMzZaMGExCzAJBgNVBAYTAlVTMRAwDgYDVQQIEwdG
+bG9yaWRhMQ4wDAYDVQQHEwVUYW1wYTEPMA0GA1UEChMGVGNsbGliMQwwCgYDVQQL
+EwNSU0ExETAPBgNVBAMTCFRlc3RDZXJ0MIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8A
+MIIBCgKCAQEAozwWij3h8daEG9J3zD3oJQYMiKbL/AriB+wgE/EhsaCtcyAUFIZz
+Tmb3pdfyqK3uvJmNH7YqplWyzu2mcvV9Fcve4XBJ4SHpLjwmrlYN5FozrKT28Znd
+wX+738O0RrL1LRhnNxWZ1P19xoc5SgqtaLEAkmXS8Iqw5vJ8uLW5ExA5xiAfuCCW
+0r4nxkA6kDcLcXA4oMEcAIAw3WimAYluG6fmaMCcaK6nOtMOsXJfAyoaTz2qkRTd
+pAXAMVP787Wp9eTYzZpjjyJA3LyAxBJMSg6Hn01mmhfzBBjbWWYCHyG1TKLPftbK
+AcwW9mR+TVbbit0RgPuA8VJOZIiPniwDSwIDAQABMA0GCSqGSIb3DQEBBQUAA4IB
+AQAwEFsEDA0mp4mQmOYbc4RHQVEGN723CtgcEHF7unu43EeO5s/1Yq0F+SdWR14L
+qFs6lRXnPjkEpIFlmW5I0Dp8Q1yY18qRPt8Hx6ymxty8QWm9lTwMBzrYUh94JqV+
+Y3QHJbVrgLpoKRpsVOpsdM5qQ4efvQwO0sOwI5AajvkyU1dC8TsxAzyJMQfK+WQs
+A0lSpqM0Htrl1xRhDZwEC8BE3+7Iv9MSW/RvK6FaaOFkyjvfWfOLgRfRtMQ8+hdV
+8RaSEqqkSsglGzmzSbuTHopBkle1Kegq2Hd/1lpi9FoXHrGxjwGWVw5KOwWOCa0O
+yF4KWWijMOWbMrIqLq5p4aOk
+-----END CERTIFICATE-----
diff --git a/tcllib/modules/pki/test.csr b/tcllib/modules/pki/test.csr
new file mode 100644
index 0000000..6e22f14
--- /dev/null
+++ b/tcllib/modules/pki/test.csr
@@ -0,0 +1,17 @@
+-----BEGIN CERTIFICATE REQUEST-----
+MIICpjCCAY4CAQAwYTELMAkGA1UEBhMCVVMxEDAOBgNVBAgTB0Zsb3JpZGExDjAM
+BgNVBAcTBVRhbXBhMQ8wDQYDVQQKEwZUY2xsaWIxDDAKBgNVBAsTA1JTQTERMA8G
+A1UEAxMIVGVzdENlcnQwggEiMA0GCSqGSIb3DQEBAQUAA4IBDwAwggEKAoIBAQCj
+PBaKPeHx1oQb0nfMPeglBgyIpsv8CuIH7CAT8SGxoK1zIBQUhnNOZvel1/Kore68
+mY0ftiqmVbLO7aZy9X0Vy97hcEnhIekuPCauVg3kWjOspPbxmd3Bf7vfw7RGsvUt
+GGc3FZnU/X3GhzlKCq1osQCSZdLwirDm8ny4tbkTEDnGIB+4IJbSvifGQDqQNwtx
+cDigwRwAgDDdaKYBiW4bp+ZowJxorqc60w6xcl8DKhpPPaqRFN2kBcAxU/vztan1
+5NjNmmOPIkDcvIDEEkxKDoefTWaaF/MEGNtZZgIfIbVMos9+1soBzBb2ZH5NVtuK
+3RGA+4DxUk5kiI+eLANLAgMBAAGgADANBgkqhkiG9w0BAQUFAAOCAQEAff0WNTPX
+M6rdFGOXBxTsC7NUGcoquuM6QsceadMbBVRtRUUbaUsusXdxDWhdylqHM3xPNx0L
+4Ex0FeL9icD/8xvJmCXzBeNt3uvThTvIwHYqnOCSlhx9InUUx2l6U0rAwZ+CIuMi
+7lG2+Z5qVD035bAZ7LT/4s4fjKSL4cTZQOdCcoFtoptj9+L8EItwwYDzffJWdG8s
+OUtMBn+Zh45k2UtLKu38jBNtVpNFAEJLlr/Arj6Jj3yTmEFrocxkwK6IPbOHQTu3
+tyJ5CkDpUqkxYZ0D4wfr8tFEru0jQNl5bSDt9QQvg1Kj6+OC9aaRvxwnmc6REfky
+8sCv80Pn5dNCGg==
+-----END CERTIFICATE REQUEST-----
diff --git a/tcllib/modules/pki/test.key.aes b/tcllib/modules/pki/test.key.aes
new file mode 100644
index 0000000..1050718
--- /dev/null
+++ b/tcllib/modules/pki/test.key.aes
@@ -0,0 +1,30 @@
+-----BEGIN RSA PRIVATE KEY-----
+Proc-Type: 4,ENCRYPTED
+DEK-Info: AES-256-CBC,A63D2250AEC17BBA948C0711A7477A88
+
+DcIqtKV3RzcfzOk0K4WwRU4dK4373bsoek/trIvHYbs6sQlU0Ydk8ddDYyWlt0vR
+MdEhEi4kTbtWhczSa9kgjQo59fZ8br8iHaSkUDPqKZUCy5qAlLsfRnCiA4JnZaDy
+BD8ROFNTdb1MTnGPqrY2+9nv/BAPNlqr+95zcAim7vBJxO0idmUKCzVFAEHn+akD
+UPX/Rkku7tIprsA5ePsQ9Z7B8qJ3LqhxKauZE+qV3hcX8/E7fndpYxQ5I3/6W3Wj
+hkfH4cTwNC9H0jcaoDDlh0O1xMfq2YQxyq20Cfse8NO11Is8UMbXWBZ90uhk6lnk
+xsVzOB2A7WbiiNEfbLBYgsUqy9ffGKhJWXoUUzl6Ze9lolD0mJjinKwAMEszwWNg
+qSwJQi+omgv0+0yP2gnMkqwsBzPFrEt/Iw0/nMKNNn8RXK2C3itD61tX/T/4p5Gj
+VvISFp+KjlgASBMaSNCE/FsfAsz7OxrkvrOJcEAZ1sWjfBUXSq20ESFGk74S5AUj
+xjrSeurl7pyLjfEgx2YR6ybF3SSnVst3wQ9BPLnG8439VKONixSukDvk/XJuY4UO
+dLuSm7aTcLy43jLosxLKHJ6jfwJEOhKMFGXkyb1h7UZnU3rydvgJF7Hw+HGsnuH6
+0cd4gKyMoTclxRn8oULlQafuOYwTO0xOV5cOjtKdnaTfasd4xrYuWGuW93INvyTh
+6lYhVgcjo+F7TDm1bqgAH354Cb3FqERx4VmeJm20YfpPilDuM1ygkh5tObM2ffqr
+vJ9T66RsjhqpMv8trjj4F8oZK614D1MVKv7/2A02GEx8eoKiv1IsIoLe4Ihe5Ido
+oswOXxdtkJj4kd/feKPOFnCajOdWGR88IMUldMIsTetxAlaNrZkTz0OAKZ0pTRgj
+BsiXVwT6OX3GF7cL41Q6FXbLZGrLnGGnOjRFpBK+0JeQ8hQFortqiLBXUaNK//gH
+pzMwApPRBfX5VxU4bVxai5WoBz63MAdOJaHKTBfNF8ebMsUC6Z+ue3H/rQmTjscz
+zxelmeKHGbFCUyW/bmGh3MDkriXUNVgqFQTqDQIbsOVzwHAQ3m6N7zREcep+/uCk
+2VlJY2HRuAsf8U+sATGveYkCcq+1nr1ZPcbeLHom9NL8cDXvWRwj84Y3Fv0BPuod
+PRBLZWMe8bOICV7cxsyRPfNf9ov+QyLc7LeMdmy9gYZABnRUZRKAOcNGHDIVULeT
+L9+QiyzeW6AK5BgkNrTpHC6fWo6jqfDjZJrhJvQbzvykJwiMJvahuRYlejLVx1HA
+uFANAhgM9APAjnzpyvbS5EcB+Q+9TrF8d+MufR3ijvMT2evIsUthwprS7CkJLCXl
+WeGw/YI58xWwk1l3LZ8bT04Jy1cS+8CVnmZXtCq0yRVsIVbsMlN4WW1b6AxMTGlC
+VB8ne9lw3zSqraDu/8he0TQi0JzYs86CwjDkMTIaIrXn+6W7tlcSUpnrQeAfgx+d
+w8qklOraCLAcXWhFw2kbc7pzvKvVzRr2R0GtZaGYInEFUP9e7fJT4R9K1cBi9DGm
+gmtJUWHnxI9QMHDslST9NGkrulBisoJ0kuVNUmIX0x2zii7w+Kk5a87lUB06pAmV
+-----END RSA PRIVATE KEY-----
diff --git a/tcllib/modules/pki/test.key.des b/tcllib/modules/pki/test.key.des
new file mode 100644
index 0000000..904521c
--- /dev/null
+++ b/tcllib/modules/pki/test.key.des
@@ -0,0 +1,30 @@
+-----BEGIN RSA PRIVATE KEY-----
+Proc-Type: 4,ENCRYPTED
+DEK-Info: DES-EDE3-CBC,2AD65AF586C2E7FF
+
+0pAOYQCqE9NPUJSrK4gu5P9H1yydKcLvuhIIsh5S1RtlEqzz1eythmGRTD/S6QnS
+c2zmmkaHndGKB3S55BTw0UnGP3XROdl1VtCqlf2mvp7MY3E9xF+ZKgw6L2yUeFW5
+ZlKEyglWIB5J4yKgX8yAe6nqdhNEXG6JolCQH45x5uRiMTtxuGgivmvFfTV3TjaO
+GXUMcbNeslJ4PZwxmUFR5YD4QSxwHe4Ur3dz2CMW6ea+TGbWNyqoEEEz81BKeAFF
+cAxAtnyWpo9NmRc2TmGRstXrfzBW/lgNrkLgqoNHkfXT5p+kkG4mIInIKWpeKsJB
+wByDFIB5+Sr3VkZJYOMJQcYkVWc2Y+o1l8/cqk9cuLYMO81OQw3QEwy0WSkXpVfP
+CIbIQOyp3Hi02drlcIjv+d6OYWDYwMB1DiPQSYGO16jFORtC0Mrmt5XiUE4kWTap
+3K4MVphvkJaSjUCzbLVzChhXWICwwGPG/x8F1Fkre/xevwdFq6qZB2HfZVqjtWrn
+E6nVWjWcaavIxJEJPuCfhU+gKsV/nyxMFqBpck8YRxUE1yYdG9sSHaiL/z8vom1r
+09VorVpa1v0AI+05XgJPZHPmjbadNn7oA3knqbICv6Jh0URXlW+TtEWGde+YDz9x
+HC6TexiZU2tQcZMtcR999yI9UYXekDS6jXLjfpEZuM971IbUefjEGnBhBpoxW4Zw
+MDzmWDJxyT3bz4ZURANm1nE3i/9R6sDwv7egu62wY6wo8KmEA126eX4CE1TAeRyF
+7DZCsmMWHQJej8N5kmTpREtBKZhCrmRYOE6vTELZWfsLN00yTpUFzzrM5gfgYDt5
+Ry8t9OQrr7T3TZDu20DMrNRL/3/t3Ap133zgM6c/jD955PyfFA3ph/m4wBiVP1cf
+LZDh/Qa+z4xvgSML8NHGhLXJgmvdPGcbKGYRj+LNVanSr3yrVJynIcr/3ckiMgEl
+lS5hr3VJVNbX/DgNsqkVoQPudl5p/aiMx/qPY3brxsxyLCk6oF0Z7L4ksdSGIaMt
+cMH0eNTuqthWK2D2JWrhPWeY0EcSOx4NtNEqUsCQFZhg+mO1xUKJdnc9x1eaHoZe
+XR9lRCjBVXD6iBNy2bscJONoz5MhuHjBqYjSF5jQL/Xfe9qgmLrqdiqqIw4R04c3
+g09JlDWRS78a68FXhc5Yo6AmqJD4UNMKH3npFUk2Vk+SD6HwUmpM+hFDM+L2tFi+
+7QNyKmWwTfFgyLQOG45Kqhl0i6Ia857UedZX7ezrJ2AoiCUn8oT2NmfJif8/jtL4
+wVLdkav7L2H64Xd9ZcWtDIWuLT9L1Fuy9LFFByscRSy1jvSj0ILrNB2Og1YWfWEE
+t/OzTlm9jpzkiKQxFGCizzt1ZnnQfrB3BN28vPThw9Dh0DRCexYXWpwY2KhHTQFo
+ghSBFh0mAZfCpHdiHM27XGvPUAo6WNP8LaA8tvvWArcU3wqaEjpbsaPw2kY0qMY6
+Kds/t/Hi3fC75IN7XWfwxr1c6hxeiBgrR48i+nVPXqlWFoT5svsqquwhxukxifoF
+fBuX6STP+RwCa5sDqfICPeLTj1jg0zBjUVB7f0w6FiOLfxQIxnNJ+g==
+-----END RSA PRIVATE KEY-----
diff --git a/tcllib/modules/pluginmgr/ChangeLog b/tcllib/modules/pluginmgr/ChangeLog
new file mode 100644
index 0000000..46fcf83
--- /dev/null
+++ b/tcllib/modules/pluginmgr/ChangeLog
@@ -0,0 +1,117 @@
+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-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 ========================
+ *
+
+2009-03-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pluginmgr.tcl: Hook into the log system of the SafeBase to get
+ * pkgIndex.tcl: more detailed error information when a plugin
+ * pluginmgr.man: could not be loaded. Bumped to version 0.3
+
+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-19 Andreas Kupries <akupries@shaw.ca>
+
+ * pluginmgr.tcl (AddPaths): Fixed typo in the code converting the
+ * pluginmgr.man: package pattern into a regular expression. A
+ * pkgIndex.tcl: bogus space char separated * from its quoting
+ backslash, end result was a RE pattern without capturing
+ parentheses, so the plugin name was never properly extracted
+ from the package name. This fixes [SF Tcllib Bug 1798210].
+ Thanks to Jeremy Cowgar for the report. Additionally added
+ support for directory 'plugins' in the dot-directories
+ (pluginmgr::path). Package version bumped to 0.2.
+
+2007-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * pluginmgr.man: Fixed typo in the example, used the wrong
+ dot-path (.../plugins, should be .../plugin). Thanks to Jeremy
+ Cowgar for finding this.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-06-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pluginmgr.tcl: Replaced deprecated {expand} syntax in comments
+ with {*}.
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pluginmgr.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 ========================
+ *
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-07-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pluginmgr.tcl: Added and documented option -setup,
+ * pluginmgr.man: and clone method.
+
+2005-06-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pluginmgr.tcl: Validation now reports missing API commands. Set
+ plugin name before external check, so that the callback can use
+ 'do' when inspecting the plugin. Command setup has no need for
+ alias deletion, interpreters are always new and clean.
+
+ * plugin.tcl: Changed completely to a package based approach,
+ * plugin.man: using the safe base for proper package
+ handling. Plugins are packages. Framework has to perform only
+ validation and initialization, not search.
+
+2005-04-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * plugin.tcl: Updated to changed method names in path, added
+ * plugin.man: method 'interpreter', and fixed bug in alias
+ creation.
+
+2005-04-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * plugin.man: New module for the management of plugins.
+ * plugin.tcl:
+ * pkgIndex.tcl:
+
diff --git a/tcllib/modules/pluginmgr/pkgIndex.tcl b/tcllib/modules/pluginmgr/pkgIndex.tcl
new file mode 100644
index 0000000..6a25058
--- /dev/null
+++ b/tcllib/modules/pluginmgr/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded pluginmgr 0.3 [list source [file join $dir pluginmgr.tcl]]
diff --git a/tcllib/modules/pluginmgr/pluginmgr.man b/tcllib/modules/pluginmgr/pluginmgr.man
new file mode 100644
index 0000000..7043f1e
--- /dev/null
+++ b/tcllib/modules/pluginmgr/pluginmgr.man
@@ -0,0 +1,427 @@
+[comment {-*- tcl -*- paths manpage}]
+[manpage_begin pluginmgr n 0.3]
+[keywords {plugin management}]
+[keywords {plugin search}]
+[copyright {2005 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Plugin management}]
+[titledesc {Manage a plugin}]
+[category {Programming tools}]
+[require Tcl 8.4]
+[require pluginmgr [opt 0.3]]
+[description]
+
+This package provides commands and objects for the generic management
+of plugins which can be loaded into an application.
+
+[para]
+
+To avoid the implementation of yet another system to locate Tcl code
+the system provides by this package is built on top of the regular
+package management system. Each plugin is considered as a package and
+a simple invokation of [cmd {package require}] is enough to locate and
+load it, if it exists. The only time we will need additional paths is
+when a plugin manager is part of a wrapped application and has to be
+able to search for plugins existing outside of that application. For
+this situation the package provides a command to create a general set
+of such paths based on names for the plugin manager and/or application
+in question.
+
+[para]
+
+The main contribution of this package is a generic framework which
+allows the easy declaration of
+
+[list_begin enumerated]
+[enum]
+How to translate a plugin name to the name of the package implementing
+it, and vice versa.
+
+[enum]
+The list of commands a plugin has to provide as API, and also of more
+complex checks as code.
+
+[enum]
+The list of commands expected by the plugin from the environment.
+
+[list_end]
+
+This then allows the easy generation of plugin managers customized to
+particular types of plugins for an application.
+
+[para]
+
+It should be noted that all plugin code is considered untrusted and
+will always be executed within a safe interpreter. The interpreter is
+enabled enough to allow plugins the loading of all additional packages
+they may need.
+
+[section {PUBLIC API}]
+[subsection {PACKAGE COMMANDS}]
+
+[list_begin definitions]
+
+[call [cmd ::pluginmgr] [arg objectName] [opt [arg "option value"]...]]
+
+This command creates a new plugin manager object with an associated
+Tcl command whose name is [arg objectName]. This [term object] command
+is explained in full detail in the sections [sectref {OBJECT COMMAND}]
+and [sectref {OBJECT METHODS}]. The object command will be created
+under the current namespace if the [arg objectName] is not fully
+qualified, and in the specified namespace otherwise.
+
+[para]
+
+The options and their values coming after the name of the object are
+used to set the initial configuration of the mamager object,
+specifying the applicable plugins and their API.
+
+[call [cmd ::pluginmgr::paths] [arg objectName] [arg name]...]
+
+This utility command adds a set of paths to the specified object,
+based on the given [arg name]s.
+
+It will search for:
+
+[list_begin enumerated]
+
+[enum]
+
+The environment variable [var [arg name]_PLUGINS]. Its contents will
+be interpreted as a list of package paths. The entries have to be
+separated by either [const :] (unix) or [const \;] (windows).
+
+[para]
+
+The name will be converted to upper-case letters.
+
+[enum]
+
+The registry entry "HKEY_LOCAL_MACHINE\SOFTWARE\[arg name]\PLUGINS".
+Its contents will be interpreted as a list of package paths. The
+entries have to be separated by [const \;]. This item is considered
+only when on Windows (tm).
+
+[para]
+
+The casing of letters is not changed.
+
+[enum]
+
+The registry entry "HKEY_CURRENT_USER\SOFTWARE\[arg name]\PLUGINS".
+Its contents will be interpreted as a list of package paths. The
+entries have to be separated by [const \;]. This item is considered
+only when on Windows (tm).
+
+[para]
+
+The casing of letters is not changed.
+
+[enum]
+
+The directory [file "~/.[arg name]/plugin"].
+
+[enum]
+
+The directory [file "~/.[arg name]/plugins"].
+
+[para]
+
+The casing of letters is not changed.
+
+[list_end]
+[para]
+
+and add all the paths found that way to the list of package paths
+maintained by the object.
+
+[para]
+
+If [arg name] is namespaced each item in the list will be repeated per
+prefix of [arg name], with conversion of :-sequences into the proper
+separator (underscore for environment variables, backslash for
+registry entries, and / for directories).
+
+[para]
+Examples:
+[para]
+
+[example {
+ ::pluginmgr::paths ::obj docidx
+
+ => env DOCIDX_PLUGINS
+ reg HKEY_LOCAL_MACHINE\SOFTWARE\docidx\PLUGINS
+ reg HKEY_CURRENT_USER\SOFTWARE\docidx\PLUGINS
+ path ~/.docidx/plugins
+
+ ::pluginmgr::paths ::obj doctools::idx
+
+ => env DOCTOOLS_PLUGINS
+ env DOCTOOLS_IDX_PLUGINS
+ reg HKEY_LOCAL_MACHINE\SOFTWARE\doctools\PLUGINS
+ reg HKEY_LOCAL_MACHINE\SOFTWARE\doctools\idx\PLUGINS
+ reg HKEY_CURRENT_USER\SOFTWARE\doctools\PLUGINS
+ reg HKEY_CURRENT_USER\SOFTWARE\doctools\idx\PLUGINS
+ path ~/.doctools/plugin
+ path ~/.doctools/idx/plugin
+}]
+
+[list_end]
+
+[subsection {OBJECT COMMAND}]
+
+All commands created by the command [cmd ::pluginmgr] (See section
+[sectref {PACKAGE COMMANDS}]) have the following general form and may
+be used to invoke various operations on their plugin manager object.
+
+[list_begin definitions]
+
+[call [cmd objectName] [method method] [opt [arg "arg arg ..."]]]
+
+The method [method method] and its [arg arg]'uments determine the exact
+behavior of the command. See section [sectref {OBJECT METHODS}] for
+the detailed specifications.
+
+[list_end]
+
+[subsection {OBJECT METHODS}]
+
+[list_begin definitions]
+
+[call [arg objectName] [method clone]]
+
+This method creates a new plugin management object and returns the
+associated object command. The generated object is a clone of the
+object the method was invoked on. I.e. the new object will have the
+same configuration as the current object. With regard to state, if the
+current object has a plugin loaded then this plugin and all associated
+state is moved to the generated clone and the current object is reset
+into the base state (no plugin loaded). In this manner a configured
+plugin manager is also a factory for loaded plugins.
+
+[call [arg objectName] [method configure]]
+
+The method returns a list of all known options and their current
+values when called without any arguments.
+
+[call [arg objectName] [method configure] [arg option]]
+
+The method behaves like the method [method cget] when called with a
+single argument and returns the value of the option specified by said
+argument.
+
+[call [arg objectName] [method configure] [option -option] [arg value]...]
+
+The method reconfigures the specified [option option]s of the object,
+setting them to the associated [arg value]s, when called with an even
+number of arguments, at least two.
+
+[para]
+
+The legal options are described in the section
+[sectref {OBJECT CONFIGURATION}].
+
+[call [arg objectName] [method cget] [option -option]]
+
+This method expects a legal configuration option as argument and will
+return the current value of that option for the object the method was
+invoked for.
+
+[para]
+
+The legal configuration options are described in section
+[sectref {OBJECT CONFIGURATION}].
+
+[call [arg objectName] [method destroy]]
+
+This method destroys the object it is invoked for.
+
+[call [arg objectName] [method do] [arg arg]...]
+
+This method interprets its list of arguments as the words of a command
+and invokes this command in the execution context of the plugin.
+
+The result of the invoked command is made the result of the method.
+
+The call will fail with an error if no valid plugin has been loaded
+into the manager object.
+
+[call [arg objectName] [method interpreter]]
+
+This method returns the handle of the safe interpreter the current
+plugin is loaded into. An empty string as return value signals that
+the manager currently has no valid plugin loaded.
+
+[call [arg objectName] [method plugin]]
+
+This method returns the name of the plugin currently loaded. An empty
+string as return value signals that the manager currently has no valid
+plugin loaded.
+
+[call [arg objectName] [method load] [arg string]]
+
+This method loads, validates, and initializes a named plugin into the
+manager object.
+
+[para]
+The algorithm to locate and load the plugin employed is:
+
+[list_begin enumerated]
+[enum]
+
+If the [arg string] contains the path to an existing file then this
+file is taken as the implementation of the plugin.
+
+[enum]
+Otherwise the plugin name is translated into a package name via the value
+of the option [option -pattern] and then loaded through the
+regular package management.
+
+[enum]
+The load fails.
+
+[list_end]
+[para]
+
+The algorithm to validate and initialize the loaded code is:
+
+[list_begin enumerated]
+[enum]
+If the option [option -api] is non-empty introspection commands are
+used to ascertain that the plugin provides the listed commands.
+
+[enum]
+If the option [option -check] is non-empty the specified command
+prefix is called.
+
+[enum]
+If either of the above fails the candidate plugin is unloaded again
+
+[enum]
+Otherwise all the commands specified via the option
+[option -cmds] are installed in the plugin.
+
+[list_end]
+[para]
+
+A previously loaded plugin is discarded, but only if the new plugin
+was found and sucessfully validated and initialized. Note that there
+will be no intereference between old and new plugin as both will be
+put into separate safe interpreters.
+
+[call [arg objectName] [method unload]]
+
+This method unloads the currently loaded plugin. It returns the empty
+string. The call will be silently ignored if no plugin is loaded at
+all.
+
+[call [arg objectName] [method list]]
+
+This method uses the contents of the option [option -pattern] to find
+all packages which can be plugins under the purview of this manager
+object. It translates their names into plugin names and returns a list
+containing them.
+
+[call [arg objectName] [method path] [arg path]]
+
+This methods adds the specified [arg path] to the list of additional
+package paths to look at when searching for a plugin. It returns the
+empty string. Duplicate paths are ignored, i.e. each path is added
+only once. Paths are made absolute, but are not normalized.
+
+[call [arg objectName] [method paths]]
+
+This method returns a list containing all additional paths which have
+been added to the plugin manager object since its creation.
+
+[list_end]
+
+[subsection {OBJECT CONFIGURATION}]
+
+All plugin manager objects understand the following configuration options:
+
+[list_begin options]
+
+[opt_def -pattern [arg string]]
+
+The value of this option is a glob pattern which has to contain
+exactly one '*'-operator. All packages whose names match this pattern
+are the plugins recognized by the manager object. And vice versa, the
+replacement of the '*'-operator with a plugin name will yield the name
+of the package implementing that plugin.
+
+[para]
+
+This option has no default, except if option [option -name] was set.
+It has to be set before attempting to load a plugin, either directly,
+or through option [option -name].
+
+[opt_def -api [arg list]]
+
+The value of this option is a list of command names, and any plugin
+loaded has to provide these commands. Names which are not fully
+qualified are considered to be rooted in the global namespace.
+
+If empty no expectations are made on the plugin. The default value is
+the empty list.
+
+[opt_def -check [arg cmdprefix]]
+
+The value of this option is interpreted as a command prefix.
+
+Its purpose is to perform complex checks on a loaded plugin package to
+validate it, which go beyond a simple list of provided commands.
+
+[para]
+
+It is called with the manager object command as the only argument and
+has to return a boolean value. A value of [const true] will be
+interpreted to mean that the candidate plugin passed the test.
+
+The call will happen if and only if the candidate plugin already
+passed the basic API check specified through the option [option -api].
+
+[para]
+
+The default value is the empty list, which causes the manager object
+to suppress the call and to assume the candidate plugin passes.
+
+[opt_def -cmds [arg dict]]
+
+The value of this option is a dictionary. It specifies the commands
+which will be made available to the plugin (as keys), and the trusted
+commands in the environment which implement them (as values).
+
+The trusted commands will be executed in the interpreter specified by
+the option [option -cmdip].
+
+The default value is the empty dictionary.
+
+[opt_def -cmdip [arg ipspec]]
+
+The value of this option is the path of the interpreter where the
+trusted commands given to the plugin will be executed in.
+
+The default is the empty string, referring to the current interpreter.
+
+[opt_def -setup [arg cmdprefix]]
+
+The value of this option is interpreted as a command prefix.
+
+[para]
+
+It is called whenever a new safe interpreter for a plugin has been
+created, but before a plugin is loaded. It is provided with the
+manager object command and the interpreter handle as its only
+arguments. Any return value will be ignored.
+
+[para]
+
+Its purpose is give a user of the plugin management the ability to
+define commands, packages, etc. a chosen plugin may need while being
+loaded.
+
+[list_end]
+
+[vset CATEGORY pluginmgr]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pluginmgr/pluginmgr.tcl b/tcllib/modules/pluginmgr/pluginmgr.tcl
new file mode 100644
index 0000000..0490a6e
--- /dev/null
+++ b/tcllib/modules/pluginmgr/pluginmgr.tcl
@@ -0,0 +1,421 @@
+# plugin.tcl --
+#
+# Generic plugin management.
+#
+# Copyright (c) 2005 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pluginmgr.tcl,v 1.8 2009/03/31 02:14:40 andreas_kupries Exp $
+
+# ### ### ### ######### ######### #########
+## Description
+
+# Each instance of the plugin manager can be configured with data
+# which specifies where to find plugins, and how to validate
+# them. With that it can then be configured to load and provide access
+# to a specific plugin, doing all required checks and
+# initialization. Users for specific plugin types simply have to
+# encapsulate the generic class, providing all the specifics, leaving
+# their users only the task of naming the requested actual plugin.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.4
+package require snit
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+snit::type ::pluginmgr {
+
+ # ### ### ### ######### ######### #########
+ ## Public API - Options
+
+ # - Pattern to match package name. Exactly one '*'. No default.
+ # - List of commands the plugin has to provide. Empty list default.
+ # - Callback for additional checking after the API presence has
+ # been verified. Empty list default.
+ # - Dictionary of commands to put into the plugin interpreter.
+ # Key: cmds for plugin, value is cmds to invoke for them.
+ # - Interpreter to use for the -cmds (invoked commands). Default
+ # is current interp.
+ # - Callback for additional setup actions on the plugin
+ # interpreter after its creation, but before plugin is loaded into
+ # it. Empty list default.
+
+ option -pattern {}
+ option -api {}
+ option -check {}
+ option -cmds {}
+ option -cmdip {}
+ option -setup {}
+
+ # ### ### ### ######### ######### #########
+ ## Public API - Methods
+
+ method do {args} {
+ if {$plugin eq ""} {
+ return -code error "No plugin defined"
+ }
+ return [$sip eval $args]
+ }
+
+ method interpreter {} {
+ return $sip
+ }
+
+ method plugin {} {
+ return $plugin
+ }
+
+ method load {name} {
+ if {$name eq $plugin} return
+
+ if {$options(-pattern) eq ""} {
+ return -code error "Translation pattern is not configured"
+ }
+
+ set save $sip
+
+ $self SetupIp
+ if {![$self LoadPlugin $name]} {
+ set sip $save
+ return -code error "Unable to locate or load plugin \"$name\" ($myloaderror)"
+ }
+
+ if {![$self CheckAPI missing]} {
+ set sip $save
+ return -code error \
+ "Cannot use plugin \"$name\", API incomplete: \"$missing\" missing"
+ }
+
+ set savedname $plugin
+ set plugin $name
+ if {![$self CheckExternal]} {
+ set sip $save
+ set plugin $savedname
+ return -code error \
+ "Cannot use plugin \"$name\", API bad"
+ }
+ $self SetupExternalCmds
+
+ if {$save ne ""} {interp delete $save}
+ return
+ }
+
+ method unload {} {
+ if {$sip eq ""} return
+ interp delete $sip
+ set sip ""
+ set plugin ""
+ return
+ }
+
+ method list {} {
+ if {$options(-pattern) eq ""} {
+ return -code error "Translation pattern is not configured"
+ }
+
+ set save $sip
+ $self SetupIp
+
+ set result {}
+ set pattern [string map [list \
+ + \\+ ? \\? \
+ \[ \\\[ \] \\\] \
+ ( \\( ) \\) \
+ . \\. \* {(.*)} \
+ ] $options(-pattern)]
+
+ # @mdgen NODEP: bogus-package
+ $sip eval {catch {package require bogus-package}}
+ foreach p [$sip eval {package names}] {
+ if {![regexp $pattern $p -> plugin]} continue
+ lappend result $plugin
+ }
+
+ interp delete $sip
+ set sip $save
+ return $result
+ }
+
+ method path {path} {
+ set path [file join [pwd] $path]
+ if {[lsearch -exact $paths $path] < 0} {
+ lappend paths $path
+ }
+ return
+ }
+
+ method paths {} {
+ return $paths
+ }
+
+ method clone {} {
+ set o [$type create %AUTO% \
+ -pattern $options(-pattern) \
+ -api $options(-api) \
+ -check $options(-check) \
+ -cmds $options(-cmds) \
+ -cmdip $options(-cmdip) \
+ -setup $options(-setup)]
+
+ $o __clone__ $paths $sip $plugin
+
+ # Clone has become owner of the interp.
+ set sip {}
+ set plugin {}
+
+ return $o
+ }
+
+ method __clone__ {_paths _sip _plugin} {
+ set paths $_paths
+ set sip $_sip
+ set plugin $_plugin
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal - Configuration and state
+
+ variable paths {} ; # List of paths to provide the sip with.
+ variable sip {} ; # Safe interp used for plugin execution.
+ variable plugin {} ; # Name of currently loaded plugin.
+ variable myloaderror {} ; # Last error reported by the Safe base
+
+ # ### ### ### ######### ######### #########
+ ## Internal - Object construction and descruction.
+
+ constructor {args} {
+ $self configurelist $args
+ return
+ }
+
+ destructor {
+ if {$sip ne ""} {interp delete $sip}
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal - Option management
+
+ onconfigure -pattern {newvalue} {
+ set current $options(-pattern)
+ if {$newvalue eq $current} return
+
+ set n [regexp -all "\\*" $newvalue]
+ if {$n < 1} {
+ return -code error "Invalid pattern, * missing"
+ } elseif {$n > 1} {
+ return -code error "Invalid pattern, too many *'s"
+ }
+
+ set options(-pattern) $newvalue
+ return
+ }
+
+ onconfigure -api {newvalue} {
+ set current $options(-api)
+ if {$newvalue eq $current} return
+ set options(-api) $newvalue
+ return
+ }
+
+ onconfigure -cmds {newvalue} {
+ set current $options(-cmds)
+ if {$newvalue eq $current} return
+ set options(-cmds) $newvalue
+ return
+ }
+
+ onconfigure -cmdip {newvalue} {
+ set current $options(-cmdip)
+ if {$newvalue eq $current} return
+ set options(-cmdip) $newvalue
+ return
+ }
+
+
+ # ### ### ### ######### ######### #########
+ ## Internal - Helper commands
+
+ method SetupIp {} {
+ set sip [::safe::interpCreate]
+ foreach p $paths {
+ ::safe::interpAddToAccessPath $sip $p
+ }
+
+ if {![llength $options(-setup)]} return
+ uplevel \#0 [linsert $options(-setup) end $self $sip]
+ return
+ }
+
+ method LoadPlugin {name} {
+ if {[file exists $name]} {
+ # Plugin files are loaded directly.
+
+ $sip invokehidden source $name
+ return 1
+ }
+
+ # Otherwise the name is transformed into a package name
+ # and loaded thorugh the package management.
+
+ set pluginpackage [string map \
+ [list * $name] $options(-pattern)]
+
+ ::safe::setLogCmd [mymethod PluginError]
+ if {[catch {
+ $sip eval [list package require $pluginpackage]
+ } res]} {
+ ::safe::setLogCmd {}
+ return 0
+ }
+ ::safe::setLogCmd {}
+ return 1
+ }
+
+ method CheckAPI {mv} {
+ upvar 1 $mv missing
+ if {![llength $options(-api)]} {return 1}
+
+ # Check the plugin for useability.
+
+ foreach p $options(-api) {
+ if {[llength [$sip eval [list info commands $p]]] == 1} continue
+ interp delete $sip
+ set missing $p
+ return 0
+ }
+ return 1
+ }
+
+ method CheckExternal {} {
+ if {![llength $options(-check)]} {return 1}
+ return [uplevel \#0 [linsert $options(-check) end $self]]
+ }
+
+
+ method SetupExternalCmds {} {
+ if {![llength $options(-cmds)]} return
+
+ set cip $options(-cmdip)
+ foreach {pcmd ecmd} $options(-cmds) {
+ eval [linsert $ecmd 0 interp alias $sip $pcmd $cip]
+ #interp alias $sip $pcmd $cip {*}$ecmd
+ }
+ return
+ }
+
+ method PluginError {message} {
+ if {[string match {*script error*} $message]} return
+ set myloaderror $message
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+
+ proc paths {pmgr args} {
+ if {[llength $args] == 0} {
+ return -code error "wrong#args: Expect \"[info level 0] object name...\""
+ }
+ foreach name $args {
+ AddPaths $pmgr $name
+ }
+ return
+ }
+
+ proc AddPaths {pmgr name} {
+ global env tcl_platform
+
+ if {$tcl_platform(platform) eq "windows"} {
+ set sep \;
+ } else {
+ set sep :
+ }
+
+ #puts "$pmgr += ($name) $sep"
+
+ regsub -all {::+} [string trim $name :] \000 name
+ set name [split $name \000]
+
+ # Environment variables
+
+ set prefix {}
+ foreach part $name {
+ lappend prefix $part
+ set ev [string toupper [join $prefix _]]_PLUGINS
+
+ #puts "+? env($ev)"
+
+ if {[info exists env($ev)]} {
+ foreach path [split $env($ev) $sep] {
+ $pmgr path $path
+ }
+ }
+ }
+
+ # Windows registry
+
+ if {
+ ($tcl_platform(platform) eq "windows") &&
+ ![catch {package require registry}]
+ } {
+ foreach root {
+ HKEY_LOCAL_MACHINE
+ HKEY_CURRENT_USER
+ } {
+ set prefix {}
+ foreach part $name {
+ lappend prefix $part
+ set rk $root\\SOFTWARE\\[join $prefix \\]PLUGINS
+
+ #puts "+? registry($rk)"
+
+ if {![catch {set data [registry get $rk {}]}]} {
+ foreach path [split $data $sep] {
+ $pmgr path $path
+ }
+ }
+ }
+ }
+ }
+
+ # Home directory dot path
+
+ set prefix {}
+ foreach part $name {
+ lappend prefix $part
+ set pd [file join ~ .[join $prefix /] plugin]
+
+ #puts "+? path($pd)"
+
+ if {[file exists $pd]} {
+ $pmgr path $pd
+ }
+
+ # Cover for the goof in the example found in the docs.
+ # Note that supporting the directory name 'plugins' is
+ # also more consistent with the environment variables
+ # above, where we also use plugins, plural.
+
+ set pd [file join ~ .[join $prefix /] plugins]
+
+ #puts "+? path($pd)"
+
+ if {[file exists $pd]} {
+ $pmgr path $pd
+ }
+ }
+ return
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pluginmgr 0.3
diff --git a/tcllib/modules/png/ChangeLog b/tcllib/modules/png/ChangeLog
new file mode 100644
index 0000000..91a83c0
--- /dev/null
+++ b/tcllib/modules/png/ChangeLog
@@ -0,0 +1,145 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2012-07-09 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * png.tcl: add capability to read and write images from color lists
+ * png.tcl: make crc package optional in imageInfo
+
+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 ========================
+ *
+
+2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * png.pcx: New file. Syntax definitions for the public commands of
+ the png package.
+
+2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.10 ========================
+ *
+
+2007-08-20 Andreas Kupries <andreask@activestate.com>
+
+ * png.tcl: Bumped version of package to 0.1.2.
+ * png.man:
+ * pkgIndex.tcl:
+
+2007-04-30 Andreas Kupries <andreask@activestate.com>
+
+ * png.test: Added tests for removeComments, also converted to use
+ of 'TestFilesGlob'.
+
+2004-04-28 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * png.tcl: fixed output file encoding in removeComments
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * png.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-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * png.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * png.test: Hooked into the new common test support code.
+
+2006-01-10 Andreas Kupries <andreask@activestate.com>
+
+ * png.test: Fixed [SF Tcllib Bug 1316055]. Uncluttering test
+ output.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-08-25 Andreas Kupries <andreask@activestate.com>
+
+ * png.tcl (::png::validate): Added forced truncation to 32bit when
+ * png.tcl (::png::imageInfo): reformatting a read negative crc to
+ unsigned. Otherwise this is becomes a 64bit unsigned, causing
+ bogus crc checksum failures. This fixes [Tcllib SF Bug 1042420].
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-09-22 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * png.test: updated timestamp test to use gmt
+
+2004-08-25 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * png.tcl bug fix in getTimestamp, made times be interpreted as gmt.
+
+2004-08-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * png.man: Spelling police.
+ * png.test:
+
+2004-05-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * png.tcl: Fixed a problem with the reading of crc data from png
+ files. The 'binary scan' may return a negative integer, but the
+ check is against unsigned data. Added code to check for this and
+ compute the proper unsigned number for correct comparison.
+
+ * png.test: New file. A testsuite for the module. Incomplete.
+ Tests the validation, signature, retrieval of image information,
+ and of timestamps. The image files used are from the official
+ PNG testsuite.
+
+2004-05-20 Aaron Faupell <afaupell@users.sourceforge.net>
+
+ * png.tcl: moved file opening and signature validation to
+ a seperate proc. added isPNG command.
+ * png.man: updated to include isPNG command
+
+2004-05-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module for querying PNG images, and manipulating their
+ comments, and timestamp.
diff --git a/tcllib/modules/png/pkgIndex.tcl b/tcllib/modules/png/pkgIndex.tcl
new file mode 100644
index 0000000..548da9a
--- /dev/null
+++ b/tcllib/modules/png/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.2]} {return}
+package ifneeded png 0.2 [list source [file join $dir png.tcl]]
diff --git a/tcllib/modules/png/png.man b/tcllib/modules/png/png.man
new file mode 100644
index 0000000..e65a651
--- /dev/null
+++ b/tcllib/modules/png/png.man
@@ -0,0 +1,141 @@
+[manpage_begin png n 0.1.2]
+[keywords comment]
+[keywords image]
+[keywords png]
+[keywords timestamp]
+[copyright {2004, Code: Aaron Faupell <afaupell@users.sourceforge.net>}]
+[copyright {2004, Doc: Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Image manipulation}]
+[titledesc {PNG querying and manipulation of meta data}]
+[category {File formats}]
+[require Tcl 8.2]
+[require crc32]
+[require png [opt 0.1.2]]
+[description]
+[para]
+
+This package provides commands to query and modify PNG images. PNG
+stands for [term {Portable Network Graphics}] and is specified at
+[uri http://www.libpng.org/pub/png/spec/1.2].
+
+[section COMMANDS]
+[list_begin definitions]
+[call [cmd ::png::validate] [arg file]]
+
+Returns a value indicating if [arg file] is a valid PNG file. The file
+is checked for PNG signature, each chunks checksum is verified,
+existence of a data chunk is verified, first chunk is checked for
+header, last chunk is checked for ending. Things [emph not] checked
+for are: validity of values within a chunk, multiple header chunks,
+noncontiguous data chunks, end chunk before actual eof. This procedure
+can take lots of time.
+
+[para]
+Possible return values:
+
+[list_begin definitions]
+[def OK]
+File is a valid PNG file.
+[def SIG]
+no/broken PNG signature.
+[def BADLEN]
+corrupt chunk length.
+[def EOF]
+premature end of file.
+[def NOHDR]
+missing header chunk.
+[def CKSUM]
+crc mismatch.
+[def NODATA]
+missing data chunk(s).
+[def NOEND]
+missing end marker.
+[list_end]
+
+[call [cmd ::png::isPNG] [arg file]]
+
+Returns a boolean value indicating if the file [arg file] starts with
+a PNG signature. This is a much faster and less intensive check than
+[cmd ::png::validate] as it does not check if the PNG data is valid.
+
+[call [cmd ::png::imageInfo] [arg file]]
+
+Returns a dictionary with keys [const width], [const height],
+
+[const depth], [const color], [const compression], [const filter], and
+[const interlace]. The values are the associated properties of the PNG
+image in [arg file].
+
+Throws an error if file is not a PNG image, or if the checksum of the
+header is invalid. For information on interpreting the values for the
+returned properties see
+
+[uri http://www.libpng.org/pub/png/spec/1.2/PNG-Chunks.html].
+
+[call [cmd ::png::getTimestamp] [arg file]]
+
+Returns the epoch time if a timestamp chunk is found in the PNG image
+contained in the [arg file], otherwise returns the empty string. Does
+not attempt to verify the checksum of the timestamp chunk.
+
+Throws an error if the [arg file] is not a valid PNG image.
+
+[call [cmd ::png::setTimestamp] [arg file] [arg time]]
+
+Writes a new timestamp to the [arg file], either replacing the old
+timestamp, or adding one just before the data chunks if there was no
+previous timestamp. [arg time] is the new time in the gmt epoch
+format.
+
+Throws an error if [arg file] is not a valid PNG image.
+
+[call [cmd ::png::getComments] [arg file]]
+
+Currently supports only uncompressed comments. Does not attempt to
+verify the checksums of the comment chunks. Returns a list where each
+element is a comment. Each comment is itself a list. The list for a
+plain text comment consists of 2 elements: the human readable keyword,
+and the text data. A unicode (international) comment consists of 4
+elements: the human readable keyword, the language identifier, the
+translated keyword, and the unicode text data.
+
+Throws an error if [arg file] is not a valid PNG image.
+
+[call [cmd ::png::removeComments] [arg file]]
+
+Removes all comments from the PNG image in [arg file]. Beware - This
+uses memory equal to the file size minus comments, to hold the
+intermediate result.
+
+Throws an error if [arg file] is not a valid PNG image.
+
+[call [cmd ::png::addComment] [arg file] [arg keyword] [arg text]]
+
+Adds a plain [arg text] comment to the PNG image in [arg file], just
+before the first data chunk. Will throw an error if no data chunk is
+found. [arg keyword] has to be less than 80 characters long to conform
+to the PNG specification.
+
+[call [cmd ::png::addComment] [arg file] [arg keyword] [arg lang] [arg keyword2] [arg text]]
+
+Adds a unicode (international) comment to the PNG image in [arg file],
+just before the first data chunk. Will throw an error if no data chunk
+is found. [arg keyword] has to be less than 80 characters long to
+conform to the PNG specification. [arg keyword2] is the translated
+[arg keyword], in the language specified by the language identifier
+[arg lang].
+
+[call [cmd ::png::image] [arg file]]
+
+Given a PNG file returns the image in the list of scanlines format used by Tk_GetColor.
+
+[call [cmd ::png::write] [arg file] [arg data]]
+
+Takes a list of scanlines in the Tk_GetColor format and writes the represented image
+to [arg file].
+
+[list_end]
+
+[vset CATEGORY png]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/png/png.pcx b/tcllib/modules/png/png.pcx
new file mode 100644
index 0000000..bbafe83
--- /dev/null
+++ b/tcllib/modules/png/png.pcx
@@ -0,0 +1,61 @@
+# -*- tcl -*- png.pcx
+# Syntax of the commands provided by package png.
+#
+# 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 png
+pcx::tcldep 0.1.2 needs tcl 8.2
+
+namespace eval ::png {}
+
+#pcx::message FOO {... text ...} type
+#pcx::scan <VERSION> <NAME> <RULE>
+
+pcx::check 0.1.2 std ::png::addComment \
+ {checkSimpleArgs 3 5 {
+ checkFileName
+ checkWord
+ checkWord
+ {checkSimpleArgs 2 2 {
+ checkWord
+ checkWord
+ }}
+ }}
+pcx::check 0.1.2 std ::png::getComments \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+pcx::check 0.1.2 std ::png::getTimestamp \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+pcx::check 0.1.2 std ::png::imageInfo \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+pcx::check 0.1.2 std ::png::isPNG \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+pcx::check 0.1.2 std ::png::removeComments \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+pcx::check 0.1.2 std ::png::setTimestamp \
+ {checkSimpleArgs 2 2 {
+ checkFileName
+ checkWholeNum
+ }}
+pcx::check 0.1.2 std ::png::validate \
+ {checkSimpleArgs 1 1 {
+ checkFileName
+ }}
+
+# Initialization via pcx::init.
+# Use a ::png::init procedure for non-standard initialization.
+pcx::complete
diff --git a/tcllib/modules/png/png.tcl b/tcllib/modules/png/png.tcl
new file mode 100644
index 0000000..b3d6ac1
--- /dev/null
+++ b/tcllib/modules/png/png.tcl
@@ -0,0 +1,289 @@
+# png.tcl --
+#
+# Querying and modifying PNG image files.
+#
+# Copyright (c) 2004-2012 Aaron Faupell <afaupell@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: png.tcl,v 1.11 2012/07/09 16:35:04 afaupell Exp $
+
+package provide png 0.2
+
+namespace eval ::png {}
+
+proc ::png::_openPNG {file {mode r}} {
+ set fh [open $file $mode]
+ fconfigure $fh -encoding binary -translation binary -eofchar {}
+ if {[read $fh 8] != "\x89PNG\r\n\x1a\n"} { close $fh; return -code error "not a png file" }
+ return $fh
+}
+
+proc ::png::_chunks {fh} {
+ set out [list]
+ while {[set r [read $fh 8]] != ""} {
+ binary scan $r Ia4 len type
+ lappend out [list $type [tell $fh] $len]
+ seek $fh [expr {$len + 4}] current
+ }
+ return $out
+}
+
+proc ::png::isPNG {file} {
+ if {[catch {_openPNG $file} fh]} { return 0 }
+ close $fh
+ return 1
+}
+
+proc ::png::validate {file} {
+ package require crc32
+ if {[catch {_openPNG $file} fh]} { return SIG }
+ set num 0
+ set idat 0
+ set last {}
+
+ while {[set r [read $fh 8]] != ""} {
+ binary scan $r Ia4 len type
+ if {$len < 0} { close $fh; return BADLEN }
+ set r [read $fh $len]
+ binary scan [read $fh 4] I crc
+ if {$crc < 0} {set crc [format %u [expr {$crc & 0xffffffff}]]}
+ if {[eof $fh]} { close $fh; return EOF }
+ if {($num == 0) && ($type != "IHDR")} { close $fh; return NOHDR }
+ if {$type == "IDAT"} { set idat 1 }
+ if {[::crc::crc32 $type$r] != $crc} { close $fh; return CKSUM }
+ set last $type
+ incr num
+ }
+ close $fh
+ if {!$idat} { return NODATA }
+ if {$last != "IEND"} { return NOEND }
+ return OK
+}
+
+proc ::png::imageInfo {file} {
+ set fh [_openPNG $file]
+ binary scan [read $fh 8] Ia4 len type
+ set r [read $fh $len]
+ if {![eof $fh] && $type == "IHDR"} {
+ binary scan $r IIccccc width height depth color compression filter interlace
+ binary scan [read $fh 4] I check
+ if {$check < 0} {set check [format %u [expr {$check & 0xffffffff}]]}
+ if {![catch {package present crc32}] && [::crc::crc32 IHDR$r] != $check} {
+ return -code error "header checksum failed"
+ }
+ close $fh
+ return [list width $width height $height depth $depth color $color \
+ compression $compression filter $filter interlace $interlace]
+ }
+ close $fh
+ return
+}
+
+proc ::png::getTimestamp {file} {
+ set fh [_openPNG $file]
+
+ while {[set r [read $fh 8]] != ""} {
+ binary scan $r Ia4 len type
+ if {$type == "tIME"} {
+ set r [read $fh [expr {$len + 4}]]
+ binary scan $r Sccccc year month day hour minute second
+ close $fh
+ return [clock scan "$month/$day/$year $hour:$minute:$second" -gmt 1]
+ }
+ seek $fh [expr {$len + 4}] current
+ }
+ close $fh
+ return
+}
+
+proc ::png::setTimestamp {file time} {
+ set fh [_openPNG $file r+]
+
+ set time [eval binary format Sccccc [string map {" 0" " "} [clock format $time -format "%Y %m %d %H %M %S" -gmt 1]]]
+ if {![catch {package present crc32}]} {
+ append time [binary format I [::crc::crc32 tIME$time]]
+ } else {
+ append time [binary format I 0]
+ }
+
+ while {[set r [read $fh 8]] != ""} {
+ binary scan $r Ia4 len type
+ if {[eof $fh]} { close $fh; return }
+ if {$type == "tIME"} {
+ seek $fh 0 current
+ puts -nonewline $fh $time
+ close $fh
+ return
+ }
+ if {$type == "IDAT" && ![info exists idat]} { set idat [expr {[tell $fh] - 8}] }
+ seek $fh [expr {$len + 4}] current
+ }
+ if {![info exists idat]} { close $fh; return -code error "no timestamp or data chunk found" }
+ seek $fh $idat start
+ set data [read $fh]
+ seek $fh $idat start
+ puts -nonewline $fh [binary format I 7]tIME$time$data
+ close $fh
+ return
+}
+
+proc ::png::getComments {file} {
+ set fh [_openPNG $file]
+ set text {}
+
+ while {[set r [read $fh 8]] != ""} {
+ binary scan $r Ia4 len type
+ set pos [tell $fh]
+ if {$type == "tEXt"} {
+ set r [read $fh $len]
+ lappend text [split $r \x00]
+ } elseif {$type == "iTXt"} {
+ set r [read $fh $len]
+ set keyword [lindex [split $r \x00] 0]
+ set r [string range $r [expr {[string length $keyword] + 1}] end]
+ binary scan $r cc comp method
+ if {$comp == 0} {
+ lappend text [linsert [split [string range $r 2 end] \x00] 0 $keyword]
+ }
+ }
+ seek $fh [expr {$pos + $len + 4}] start
+ }
+ close $fh
+ return $text
+}
+
+proc ::png::removeComments {file} {
+ set fh [_openPNG $file r+]
+ set data "\x89PNG\r\n\x1a\n"
+ while {[set r [read $fh 8]] != ""} {
+ binary scan $r Ia4 len type
+ if {$type == "zTXt" || $type == "iTXt" || $type == "tEXt"} {
+ seek $fh [expr {$len + 4}] current
+ } else {
+ seek $fh -8 current
+ append data [read $fh [expr {$len + 12}]]
+ }
+ }
+ close $fh
+ set fh [open $file w]
+ fconfigure $fh -encoding binary -translation binary -eofchar {}
+ puts -nonewline $fh $data
+ close $fh
+}
+
+proc ::png::addComment {file keyword arg1 args} {
+ if {[llength $args] > 0 && [llength $args] != 2} { close $fh; return -code error "wrong number of arguments" }
+ set fh [_openPNG $file r+]
+
+ if {[llength $args] > 0} {
+ set comment "iTXt$keyword\x00\x00\x00$arg1\x00[encoding convertto utf-8 [lindex $args 0]]\x00[encoding convertto utf-8 [lindex $args 1]]"
+ } else {
+ set comment "tEXt$keyword\x00$arg1"
+ }
+
+ if {![catch {package present crc32}]} {
+ append comment [binary format I [::crc::crc32 $comment]]
+ } else {
+ append comment [binary format I 0]
+ }
+
+ while {[set r [read $fh 8]] != ""} {
+ binary scan $r Ia4 len type
+ if {$type == "IDAT"} {
+ seek $fh -8 current
+ set pos [tell $fh]
+ set data [read $fh]
+ seek $fh $pos start
+ set 1 [tell $fh]
+ puts -nonewline $fh $comment
+ set clen [binary format I [expr {[tell $fh] - $1 - 8}]]
+ seek $fh $pos start
+ puts -nonewline $fh $clen$comment$data
+ close $fh
+ return
+ }
+ seek $fh [expr {$len + 4}] current
+ }
+ close $fh
+ return -code error "no data chunk found"
+}
+
+proc ::png::image {file} {
+ set fh [_openPNG $file]
+ set chunks [_chunks $fh]
+ set cdata {}
+
+ set h [lsearch -exact -index 0 -inline $chunks IHDR]
+ seek $fh [lindex $h 1] start
+ binary scan [read $fh [lindex $h 2]] IIccccc width height depth color compression filter interlace
+
+ if {$color != 2 || $compression != 0 || $depth != 8} {
+ return -code error "unsupported image format"
+ }
+
+ foreach c [lsearch -exact -index 0 -all -inline $chunks IDAT] {
+ seek $fh [lindex $c 1] start
+ append cdata [read $fh [lindex $c 2]]
+ }
+ set data [zlib decompress $cdata]
+
+ set len [string length $data]
+ set col 1
+ set offset 1
+ set row [list]
+ set out [list]
+ while {$offset < $len} {
+ binary scan $data @${offset}H2H2H2 r g b
+ lappend row "#$r$g$b"
+ incr offset 3
+ if {$col == $width} {
+ set col 1
+ incr offset
+ lappend out $row
+ set row [list]
+ continue
+ }
+ incr col
+ }
+ return $out
+}
+
+proc ::png::write {file in} {
+ set blocksize 65524
+ set chunks [list]
+ set data ""
+ lappend chunks [list IHDR [binary format IIccccc [llength [lindex $in 0]] [llength $in] 8 2 0 0 0]]
+
+ foreach row $in {
+ append data \x00
+ foreach pixel $row {
+ set pixel [string trimleft $pixel "#"]
+ append data [binary format H2H2H2 [string range $pixel 0 1] [string range $pixel 2 3] [string range $pixel 4 5]]
+ }
+ }
+ set cdata [zlib compress $data]
+ set offset 0
+ while {$offset < ([string length $cdata] + $blocksize)} {
+ lappend chunks [list IDAT [string range $cdata $offset [expr {$offset+$blocksize-1}]]]
+ incr offset $blocksize
+ }
+ #lappend chunks [list tIME [eval binary format Sccccc [clock format [clock seconds] -format "%Y %m %d %H %M %S"]]]
+ lappend chunks [list IEND ""]
+ _write $file $chunks
+}
+
+proc ::png::_write {file chunks} {
+ package require crc32
+ set fh [open $file w+]
+ fconfigure $fh -encoding binary -translation binary
+ puts -nonewline $fh "\x89PNG\r\n\x1a\n"
+ foreach chunk $chunks {
+ puts -nonewline $fh [binary format Ia4 [string length [lindex $chunk 1]] [lindex $chunk 0]]
+ puts -nonewline $fh [lindex $chunk 1]
+ puts -nonewline $fh [binary format I [::crc::crc32 [join $chunk ""]]]
+ }
+ close $fh
+ return $file
+}
diff --git a/tcllib/modules/png/png.test b/tcllib/modules/png/png.test
new file mode 100644
index 0000000..c805d4d
--- /dev/null
+++ b/tcllib/modules/png/png.test
@@ -0,0 +1,306 @@
+# -*- tcl -*-
+# png.test: tests for png decoding and manipulation.
+#
+# Copyright (c) 2004 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+#
+# RCS: @(#) $Id: png.test,v 1.10 2007/04/30 22:47:14 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+# Trf / tcllibc
+support {
+ use crc/crc32.tcl crc32 ::crc
+}
+testing {
+ useLocal png.tcl png
+}
+
+# -------------------------------------------------------------------------
+# Validation
+
+foreach f [TestFilesGlob testimages/*.png] {
+ set root [file rootname [file tail $f]]
+
+ # All files have a valid signature, except for two.
+
+ test png-ispng-$root {is png} {
+ ::png::isPNG $f
+ } [expr {
+ ![string equal $root xcrn0g04] &&
+ ![string equal $root xlfn0g04]
+ }] ; # {}
+
+ # All files are fully valid, except for all beginning with an 'x'.
+
+ if {[string match x* $root]} continue
+
+ test png-validate-$root {full validation} {
+ ::png::validate $f
+ } OK ;# {}
+}
+
+# Validation II, the bad files ...
+
+foreach f [TestFilesGlob testimages/x*.png] {
+ set root [file rootname [file tail $f]]
+
+ test png-validate-$root {full validation} {
+ ::png::validate $f
+ } [expr {[string match x00n0g01 $root] ? "NODATA" : "SIG"}] ;# {}
+}
+
+
+# -------------------------------------------------------------------------
+# imageInfo ...
+
+array set expected {
+ basi0g01 {color 0 compression 0 depth 1 filter 0 height 32 interlace 1 width 32}
+ basi0g02 {color 0 compression 0 depth 2 filter 0 height 32 interlace 1 width 32}
+ basi0g04 {color 0 compression 0 depth 4 filter 0 height 32 interlace 1 width 32}
+ basi0g08 {color 0 compression 0 depth 8 filter 0 height 32 interlace 1 width 32}
+ basi0g16 {color 0 compression 0 depth 16 filter 0 height 32 interlace 1 width 32}
+ basi2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 1 width 32}
+ basi2c16 {color 2 compression 0 depth 16 filter 0 height 32 interlace 1 width 32}
+ basi3p01 {color 3 compression 0 depth 1 filter 0 height 32 interlace 1 width 32}
+ basi3p02 {color 3 compression 0 depth 2 filter 0 height 32 interlace 1 width 32}
+ basi3p04 {color 3 compression 0 depth 4 filter 0 height 32 interlace 1 width 32}
+ basi3p08 {color 3 compression 0 depth 8 filter 0 height 32 interlace 1 width 32}
+ basi4a08 {color 4 compression 0 depth 8 filter 0 height 32 interlace 1 width 32}
+ basi4a16 {color 4 compression 0 depth 16 filter 0 height 32 interlace 1 width 32}
+ basi6a08 {color 6 compression 0 depth 8 filter 0 height 32 interlace 1 width 32}
+ basi6a16 {color 6 compression 0 depth 16 filter 0 height 32 interlace 1 width 32}
+ basn0g01 {color 0 compression 0 depth 1 filter 0 height 32 interlace 0 width 32}
+ basn0g02 {color 0 compression 0 depth 2 filter 0 height 32 interlace 0 width 32}
+ basn0g04 {color 0 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ basn0g08 {color 0 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ basn0g16 {color 0 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ basn2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ basn2c16 {color 2 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ basn3p01 {color 3 compression 0 depth 1 filter 0 height 32 interlace 0 width 32}
+ basn3p02 {color 3 compression 0 depth 2 filter 0 height 32 interlace 0 width 32}
+ basn3p04 {color 3 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ basn3p08 {color 3 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ basn4a08 {color 4 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ basn4a16 {color 4 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ basn6a08 {color 6 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ basn6a16 {color 6 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ bgai4a08 {color 4 compression 0 depth 8 filter 0 height 32 interlace 1 width 32}
+ bgai4a16 {color 4 compression 0 depth 16 filter 0 height 32 interlace 1 width 32}
+ bgan6a08 {color 6 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ bgan6a16 {color 6 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ bgbn4a08 {color 4 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ bggn4a16 {color 4 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ bgwn6a08 {color 6 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ bgyn6a16 {color 6 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ ccwn2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ ccwn3p08 {color 3 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ cdfn2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 8}
+ cdhn2c08 {color 2 compression 0 depth 8 filter 0 height 8 interlace 0 width 32}
+ cdsn2c08 {color 2 compression 0 depth 8 filter 0 height 8 interlace 0 width 8}
+ cdun2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ ch1n3p04 {color 3 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ ch2n3p08 {color 3 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ cm0n0g04 {color 0 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ cm7n0g04 {color 0 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ cm9n0g04 {color 0 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ cs3n2c16 {color 2 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ cs3n3p08 {color 3 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ cs5n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ cs5n3p08 {color 3 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ cs8n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ cs8n3p08 {color 3 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ ct0n0g04 {color 0 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ ct1n0g04 {color 0 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ ctzn0g04 {color 0 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ f00n0g08 {color 0 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ f00n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ f01n0g08 {color 0 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ f01n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ f02n0g08 {color 0 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ f02n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ f03n0g08 {color 0 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ f03n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ f04n0g08 {color 0 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ f04n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ g03n0g16 {color 0 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ g03n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ g03n3p04 {color 3 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ g04n0g16 {color 0 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ g04n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ g04n3p04 {color 3 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ g05n0g16 {color 0 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ g05n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ g05n3p04 {color 3 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ g07n0g16 {color 0 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ g07n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ g07n3p04 {color 3 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ g10n0g16 {color 0 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ g10n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ g10n3p04 {color 3 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ g25n0g16 {color 0 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ g25n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ g25n3p04 {color 3 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ oi1n0g16 {color 0 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ oi1n2c16 {color 2 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ oi2n0g16 {color 0 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ oi2n2c16 {color 2 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ oi4n0g16 {color 0 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ oi4n2c16 {color 2 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ oi9n0g16 {color 0 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ oi9n2c16 {color 2 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ pngsuite_logo {color 2 compression 0 depth 8 filter 0 height 256 interlace 0 width 256}
+ pp0n2c16 {color 2 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ pp0n6a08 {color 6 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ ps1n0g08 {color 0 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ ps1n2c16 {color 2 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ ps2n0g08 {color 0 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ ps2n2c16 {color 2 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ s01i3p01 {color 3 compression 0 depth 1 filter 0 height 1 interlace 1 width 1}
+ s01n3p01 {color 3 compression 0 depth 1 filter 0 height 1 interlace 0 width 1}
+ s02i3p01 {color 3 compression 0 depth 1 filter 0 height 2 interlace 1 width 2}
+ s02n3p01 {color 3 compression 0 depth 1 filter 0 height 2 interlace 0 width 2}
+ s03i3p01 {color 3 compression 0 depth 1 filter 0 height 3 interlace 1 width 3}
+ s03n3p01 {color 3 compression 0 depth 1 filter 0 height 3 interlace 0 width 3}
+ s04i3p01 {color 3 compression 0 depth 1 filter 0 height 4 interlace 1 width 4}
+ s04n3p01 {color 3 compression 0 depth 1 filter 0 height 4 interlace 0 width 4}
+ s05i3p02 {color 3 compression 0 depth 2 filter 0 height 5 interlace 1 width 5}
+ s05n3p02 {color 3 compression 0 depth 2 filter 0 height 5 interlace 0 width 5}
+ s06i3p02 {color 3 compression 0 depth 2 filter 0 height 6 interlace 1 width 6}
+ s06n3p02 {color 3 compression 0 depth 2 filter 0 height 6 interlace 0 width 6}
+ s07i3p02 {color 3 compression 0 depth 2 filter 0 height 7 interlace 1 width 7}
+ s07n3p02 {color 3 compression 0 depth 2 filter 0 height 7 interlace 0 width 7}
+ s08i3p02 {color 3 compression 0 depth 2 filter 0 height 8 interlace 1 width 8}
+ s08n3p02 {color 3 compression 0 depth 2 filter 0 height 8 interlace 0 width 8}
+ s09i3p02 {color 3 compression 0 depth 2 filter 0 height 9 interlace 1 width 9}
+ s09n3p02 {color 3 compression 0 depth 2 filter 0 height 9 interlace 0 width 9}
+ s32i3p04 {color 3 compression 0 depth 4 filter 0 height 32 interlace 1 width 32}
+ s32n3p04 {color 3 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ s33i3p04 {color 3 compression 0 depth 4 filter 0 height 33 interlace 1 width 33}
+ s33n3p04 {color 3 compression 0 depth 4 filter 0 height 33 interlace 0 width 33}
+ s34i3p04 {color 3 compression 0 depth 4 filter 0 height 34 interlace 1 width 34}
+ s34n3p04 {color 3 compression 0 depth 4 filter 0 height 34 interlace 0 width 34}
+ s35i3p04 {color 3 compression 0 depth 4 filter 0 height 35 interlace 1 width 35}
+ s35n3p04 {color 3 compression 0 depth 4 filter 0 height 35 interlace 0 width 35}
+ s36i3p04 {color 3 compression 0 depth 4 filter 0 height 36 interlace 1 width 36}
+ s36n3p04 {color 3 compression 0 depth 4 filter 0 height 36 interlace 0 width 36}
+ s37i3p04 {color 3 compression 0 depth 4 filter 0 height 37 interlace 1 width 37}
+ s37n3p04 {color 3 compression 0 depth 4 filter 0 height 37 interlace 0 width 37}
+ s38i3p04 {color 3 compression 0 depth 4 filter 0 height 38 interlace 1 width 38}
+ s38n3p04 {color 3 compression 0 depth 4 filter 0 height 38 interlace 0 width 38}
+ s39i3p04 {color 3 compression 0 depth 4 filter 0 height 39 interlace 1 width 39}
+ s39n3p04 {color 3 compression 0 depth 4 filter 0 height 39 interlace 0 width 39}
+ s40i3p04 {color 3 compression 0 depth 4 filter 0 height 40 interlace 1 width 40}
+ s40n3p04 {color 3 compression 0 depth 4 filter 0 height 40 interlace 0 width 40}
+ tbbn1g04 {color 0 compression 0 depth 4 filter 0 height 32 interlace 0 width 32}
+ tbbn2c16 {color 2 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ tbbn3p08 {color 3 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ tbgn2c16 {color 2 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ tbgn3p08 {color 3 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ tbrn2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ tbwn1g16 {color 0 compression 0 depth 16 filter 0 height 32 interlace 0 width 32}
+ tbwn3p08 {color 3 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ tbyn3p08 {color 3 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ tp0n1g08 {color 0 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ tp0n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ tp0n3p08 {color 3 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ tp1n3p08 {color 3 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ z00n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ z03n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ z06n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+ z09n2c08 {color 2 compression 0 depth 8 filter 0 height 32 interlace 0 width 32}
+}
+
+foreach f [TestFilesGlob testimages/*.png] {
+ set root [file rootname [file tail $f]]
+
+ # Files beginning with x are invalid, and thus not usable in these
+ # tests.
+
+ if {[string match x* $root]} continue
+
+ test png-imageinfo-$root {retrieve image information} {
+ dictsort [::png::imageInfo $f]
+ } $expected($root) ; # {}
+}
+
+# -------------------------------------------------------------------------
+# Timestamps
+
+array set exptime {
+ cm0n0g04 946730096
+ cm7n0g04 0
+ cm9n0g04 946684799
+}
+
+foreach f [TestFilesGlob testimages/cm*.png] {
+ set root [file rootname [file tail $f]]
+
+ #puts [clock format $exptime($root) -gmt 1]
+
+ test png-gettimestamp-$root {retrieve timestamp} {
+ ::png::getTimestamp $f
+ } $exptime($root) ; # {}
+}
+
+# -------------------------------------------------------------------------
+# Comments
+
+array set comex {
+ ct1n0g04 {{Title PngSuite} {Author {Willem A.J. van Schaik
+(willem@schaik.com)}} {Copyright {Copyright Willem van Schaik, Singapore 1995-96}} {Description {A compilation of a set of images created to test the
+various color-types of the PNG format. Included are
+black&white, color, paletted, with alpha channel, with
+transparency formats. All bit-depths allowed according
+to the spec are present.}} {Software {Created on a NeXTstation color using "pnmtopng".}} {Disclaimer Freeware.}}
+ ctzn0g04 {{Title PngSuite} {Author {Willem A.J. van Schaik
+(willem@schaik.com)}}}
+}
+
+# - Retrieval
+
+foreach f [TestFilesGlob testimages/*.png] {
+ set root [file rootname [file tail $f]]
+
+ # All files have a valid signature, except for two. These we ignore.
+ if {[string equal $root xcrn0g04]} continue
+ if {[string equal $root xlfn0g04]} continue
+ # All files are fully valid, except for all beginning with an
+ # 'x'. We ignore them as well.
+ if {[string match x* $root]} continue
+
+ test png-getcomment-$root {get comments} {
+ ::png::getComments $f
+ } [expr {
+ ![info exists comex($root)] ? "" : $comex($root)
+ }] ; # {}
+}
+
+# - Removal
+
+# Note: For a bad removeComments tests fail only on platforms where
+# the system encoding is not ASCII like, or the EOL is not a plain
+# LF. Windows for example, or asian systems.
+
+foreach root [array names comex] {
+ set f [localPath testimages/${root}.png]
+
+ test png-removecomment-$root {remove comments} {
+ set copy [makeFile {} pngrc.$root]
+ file copy -force $f $copy
+
+ ::png::removeComments $copy
+ set res [list [::png::validate $copy] [::png::getComments $copy]]
+ removeFile pngrc.$root
+ set res
+ } {OK {}}
+}
+
+# -------------------------------------------------------------------------
+testsuiteCleanup
diff --git a/tcllib/modules/png/testimages/basi0g01.png b/tcllib/modules/png/testimages/basi0g01.png
new file mode 100644
index 0000000..556fa72
--- /dev/null
+++ b/tcllib/modules/png/testimages/basi0g01.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basi0g02.png b/tcllib/modules/png/testimages/basi0g02.png
new file mode 100644
index 0000000..ce09821
--- /dev/null
+++ b/tcllib/modules/png/testimages/basi0g02.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basi0g04.png b/tcllib/modules/png/testimages/basi0g04.png
new file mode 100644
index 0000000..3853273
--- /dev/null
+++ b/tcllib/modules/png/testimages/basi0g04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basi0g08.png b/tcllib/modules/png/testimages/basi0g08.png
new file mode 100644
index 0000000..faed8be
--- /dev/null
+++ b/tcllib/modules/png/testimages/basi0g08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basi0g16.png b/tcllib/modules/png/testimages/basi0g16.png
new file mode 100644
index 0000000..a9f2816
--- /dev/null
+++ b/tcllib/modules/png/testimages/basi0g16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basi2c08.png b/tcllib/modules/png/testimages/basi2c08.png
new file mode 100644
index 0000000..2aab44d
--- /dev/null
+++ b/tcllib/modules/png/testimages/basi2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basi2c16.png b/tcllib/modules/png/testimages/basi2c16.png
new file mode 100644
index 0000000..cd7e50f
--- /dev/null
+++ b/tcllib/modules/png/testimages/basi2c16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basi3p01.png b/tcllib/modules/png/testimages/basi3p01.png
new file mode 100644
index 0000000..00a7cea
--- /dev/null
+++ b/tcllib/modules/png/testimages/basi3p01.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basi3p02.png b/tcllib/modules/png/testimages/basi3p02.png
new file mode 100644
index 0000000..bb16b44
--- /dev/null
+++ b/tcllib/modules/png/testimages/basi3p02.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basi3p04.png b/tcllib/modules/png/testimages/basi3p04.png
new file mode 100644
index 0000000..b4e888e
--- /dev/null
+++ b/tcllib/modules/png/testimages/basi3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basi3p08.png b/tcllib/modules/png/testimages/basi3p08.png
new file mode 100644
index 0000000..50a6d1c
--- /dev/null
+++ b/tcllib/modules/png/testimages/basi3p08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basi4a08.png b/tcllib/modules/png/testimages/basi4a08.png
new file mode 100644
index 0000000..398132b
--- /dev/null
+++ b/tcllib/modules/png/testimages/basi4a08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basi4a16.png b/tcllib/modules/png/testimages/basi4a16.png
new file mode 100644
index 0000000..51192e7
--- /dev/null
+++ b/tcllib/modules/png/testimages/basi4a16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basi6a08.png b/tcllib/modules/png/testimages/basi6a08.png
new file mode 100644
index 0000000..aecb32e
--- /dev/null
+++ b/tcllib/modules/png/testimages/basi6a08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basi6a16.png b/tcllib/modules/png/testimages/basi6a16.png
new file mode 100644
index 0000000..4181533
--- /dev/null
+++ b/tcllib/modules/png/testimages/basi6a16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basn0g01.png b/tcllib/modules/png/testimages/basn0g01.png
new file mode 100644
index 0000000..1d72242
--- /dev/null
+++ b/tcllib/modules/png/testimages/basn0g01.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basn0g02.png b/tcllib/modules/png/testimages/basn0g02.png
new file mode 100644
index 0000000..5083324
--- /dev/null
+++ b/tcllib/modules/png/testimages/basn0g02.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basn0g04.png b/tcllib/modules/png/testimages/basn0g04.png
new file mode 100644
index 0000000..0bf3687
--- /dev/null
+++ b/tcllib/modules/png/testimages/basn0g04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basn0g08.png b/tcllib/modules/png/testimages/basn0g08.png
new file mode 100644
index 0000000..23c8237
--- /dev/null
+++ b/tcllib/modules/png/testimages/basn0g08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basn0g16.png b/tcllib/modules/png/testimages/basn0g16.png
new file mode 100644
index 0000000..e7c82f7
--- /dev/null
+++ b/tcllib/modules/png/testimages/basn0g16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basn2c08.png b/tcllib/modules/png/testimages/basn2c08.png
new file mode 100644
index 0000000..db5ad15
--- /dev/null
+++ b/tcllib/modules/png/testimages/basn2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basn2c16.png b/tcllib/modules/png/testimages/basn2c16.png
new file mode 100644
index 0000000..50c1cb9
--- /dev/null
+++ b/tcllib/modules/png/testimages/basn2c16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basn3p01.png b/tcllib/modules/png/testimages/basn3p01.png
new file mode 100644
index 0000000..b145c2b
--- /dev/null
+++ b/tcllib/modules/png/testimages/basn3p01.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basn3p02.png b/tcllib/modules/png/testimages/basn3p02.png
new file mode 100644
index 0000000..8985b3d
--- /dev/null
+++ b/tcllib/modules/png/testimages/basn3p02.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basn3p04.png b/tcllib/modules/png/testimages/basn3p04.png
new file mode 100644
index 0000000..0fbf9e8
--- /dev/null
+++ b/tcllib/modules/png/testimages/basn3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basn3p08.png b/tcllib/modules/png/testimages/basn3p08.png
new file mode 100644
index 0000000..0ddad07
--- /dev/null
+++ b/tcllib/modules/png/testimages/basn3p08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basn4a08.png b/tcllib/modules/png/testimages/basn4a08.png
new file mode 100644
index 0000000..3e13052
--- /dev/null
+++ b/tcllib/modules/png/testimages/basn4a08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basn4a16.png b/tcllib/modules/png/testimages/basn4a16.png
new file mode 100644
index 0000000..8243644
--- /dev/null
+++ b/tcllib/modules/png/testimages/basn4a16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basn6a08.png b/tcllib/modules/png/testimages/basn6a08.png
new file mode 100644
index 0000000..e608738
--- /dev/null
+++ b/tcllib/modules/png/testimages/basn6a08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/basn6a16.png b/tcllib/modules/png/testimages/basn6a16.png
new file mode 100644
index 0000000..984a995
--- /dev/null
+++ b/tcllib/modules/png/testimages/basn6a16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/bgai4a08.png b/tcllib/modules/png/testimages/bgai4a08.png
new file mode 100644
index 0000000..398132b
--- /dev/null
+++ b/tcllib/modules/png/testimages/bgai4a08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/bgai4a16.png b/tcllib/modules/png/testimages/bgai4a16.png
new file mode 100644
index 0000000..51192e7
--- /dev/null
+++ b/tcllib/modules/png/testimages/bgai4a16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/bgan6a08.png b/tcllib/modules/png/testimages/bgan6a08.png
new file mode 100644
index 0000000..e608738
--- /dev/null
+++ b/tcllib/modules/png/testimages/bgan6a08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/bgan6a16.png b/tcllib/modules/png/testimages/bgan6a16.png
new file mode 100644
index 0000000..984a995
--- /dev/null
+++ b/tcllib/modules/png/testimages/bgan6a16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/bgbn4a08.png b/tcllib/modules/png/testimages/bgbn4a08.png
new file mode 100644
index 0000000..7cbefc3
--- /dev/null
+++ b/tcllib/modules/png/testimages/bgbn4a08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/bggn4a16.png b/tcllib/modules/png/testimages/bggn4a16.png
new file mode 100644
index 0000000..13fd85b
--- /dev/null
+++ b/tcllib/modules/png/testimages/bggn4a16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/bgwn6a08.png b/tcllib/modules/png/testimages/bgwn6a08.png
new file mode 100644
index 0000000..a67ff20
--- /dev/null
+++ b/tcllib/modules/png/testimages/bgwn6a08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/bgyn6a16.png b/tcllib/modules/png/testimages/bgyn6a16.png
new file mode 100644
index 0000000..ae3e9be
--- /dev/null
+++ b/tcllib/modules/png/testimages/bgyn6a16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/ccwn2c08.png b/tcllib/modules/png/testimages/ccwn2c08.png
new file mode 100644
index 0000000..47c2481
--- /dev/null
+++ b/tcllib/modules/png/testimages/ccwn2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/ccwn3p08.png b/tcllib/modules/png/testimages/ccwn3p08.png
new file mode 100644
index 0000000..8bb2c10
--- /dev/null
+++ b/tcllib/modules/png/testimages/ccwn3p08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/cdfn2c08.png b/tcllib/modules/png/testimages/cdfn2c08.png
new file mode 100644
index 0000000..559e526
--- /dev/null
+++ b/tcllib/modules/png/testimages/cdfn2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/cdhn2c08.png b/tcllib/modules/png/testimages/cdhn2c08.png
new file mode 100644
index 0000000..3e07e8e
--- /dev/null
+++ b/tcllib/modules/png/testimages/cdhn2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/cdsn2c08.png b/tcllib/modules/png/testimages/cdsn2c08.png
new file mode 100644
index 0000000..076c32c
--- /dev/null
+++ b/tcllib/modules/png/testimages/cdsn2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/cdun2c08.png b/tcllib/modules/png/testimages/cdun2c08.png
new file mode 100644
index 0000000..846033b
--- /dev/null
+++ b/tcllib/modules/png/testimages/cdun2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/ch1n3p04.png b/tcllib/modules/png/testimages/ch1n3p04.png
new file mode 100644
index 0000000..17cd12d
--- /dev/null
+++ b/tcllib/modules/png/testimages/ch1n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/ch2n3p08.png b/tcllib/modules/png/testimages/ch2n3p08.png
new file mode 100644
index 0000000..25c1798
--- /dev/null
+++ b/tcllib/modules/png/testimages/ch2n3p08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/cm0n0g04.png b/tcllib/modules/png/testimages/cm0n0g04.png
new file mode 100644
index 0000000..9fba5db
--- /dev/null
+++ b/tcllib/modules/png/testimages/cm0n0g04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/cm7n0g04.png b/tcllib/modules/png/testimages/cm7n0g04.png
new file mode 100644
index 0000000..f7dc46e
--- /dev/null
+++ b/tcllib/modules/png/testimages/cm7n0g04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/cm9n0g04.png b/tcllib/modules/png/testimages/cm9n0g04.png
new file mode 100644
index 0000000..dd70911
--- /dev/null
+++ b/tcllib/modules/png/testimages/cm9n0g04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/cs3n2c16.png b/tcllib/modules/png/testimages/cs3n2c16.png
new file mode 100644
index 0000000..bf5fd20
--- /dev/null
+++ b/tcllib/modules/png/testimages/cs3n2c16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/cs3n3p08.png b/tcllib/modules/png/testimages/cs3n3p08.png
new file mode 100644
index 0000000..f4a6623
--- /dev/null
+++ b/tcllib/modules/png/testimages/cs3n3p08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/cs5n2c08.png b/tcllib/modules/png/testimages/cs5n2c08.png
new file mode 100644
index 0000000..40f947c
--- /dev/null
+++ b/tcllib/modules/png/testimages/cs5n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/cs5n3p08.png b/tcllib/modules/png/testimages/cs5n3p08.png
new file mode 100644
index 0000000..dfd6e6e
--- /dev/null
+++ b/tcllib/modules/png/testimages/cs5n3p08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/cs8n2c08.png b/tcllib/modules/png/testimages/cs8n2c08.png
new file mode 100644
index 0000000..8e01d32
--- /dev/null
+++ b/tcllib/modules/png/testimages/cs8n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/cs8n3p08.png b/tcllib/modules/png/testimages/cs8n3p08.png
new file mode 100644
index 0000000..a44066e
--- /dev/null
+++ b/tcllib/modules/png/testimages/cs8n3p08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/ct0n0g04.png b/tcllib/modules/png/testimages/ct0n0g04.png
new file mode 100644
index 0000000..40d1e06
--- /dev/null
+++ b/tcllib/modules/png/testimages/ct0n0g04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/ct1n0g04.png b/tcllib/modules/png/testimages/ct1n0g04.png
new file mode 100644
index 0000000..3ba110a
--- /dev/null
+++ b/tcllib/modules/png/testimages/ct1n0g04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/ctzn0g04.png b/tcllib/modules/png/testimages/ctzn0g04.png
new file mode 100644
index 0000000..b4401c9
--- /dev/null
+++ b/tcllib/modules/png/testimages/ctzn0g04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/f00n0g08.png b/tcllib/modules/png/testimages/f00n0g08.png
new file mode 100644
index 0000000..45a0075
--- /dev/null
+++ b/tcllib/modules/png/testimages/f00n0g08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/f00n2c08.png b/tcllib/modules/png/testimages/f00n2c08.png
new file mode 100644
index 0000000..d6a1fff
--- /dev/null
+++ b/tcllib/modules/png/testimages/f00n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/f01n0g08.png b/tcllib/modules/png/testimages/f01n0g08.png
new file mode 100644
index 0000000..4a1107b
--- /dev/null
+++ b/tcllib/modules/png/testimages/f01n0g08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/f01n2c08.png b/tcllib/modules/png/testimages/f01n2c08.png
new file mode 100644
index 0000000..26fee95
--- /dev/null
+++ b/tcllib/modules/png/testimages/f01n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/f02n0g08.png b/tcllib/modules/png/testimages/f02n0g08.png
new file mode 100644
index 0000000..bfe410c
--- /dev/null
+++ b/tcllib/modules/png/testimages/f02n0g08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/f02n2c08.png b/tcllib/modules/png/testimages/f02n2c08.png
new file mode 100644
index 0000000..e590f12
--- /dev/null
+++ b/tcllib/modules/png/testimages/f02n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/f03n0g08.png b/tcllib/modules/png/testimages/f03n0g08.png
new file mode 100644
index 0000000..ed01e29
--- /dev/null
+++ b/tcllib/modules/png/testimages/f03n0g08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/f03n2c08.png b/tcllib/modules/png/testimages/f03n2c08.png
new file mode 100644
index 0000000..7581150
--- /dev/null
+++ b/tcllib/modules/png/testimages/f03n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/f04n0g08.png b/tcllib/modules/png/testimages/f04n0g08.png
new file mode 100644
index 0000000..663fdae
--- /dev/null
+++ b/tcllib/modules/png/testimages/f04n0g08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/f04n2c08.png b/tcllib/modules/png/testimages/f04n2c08.png
new file mode 100644
index 0000000..3c8b511
--- /dev/null
+++ b/tcllib/modules/png/testimages/f04n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g03n0g16.png b/tcllib/modules/png/testimages/g03n0g16.png
new file mode 100644
index 0000000..41083ca
--- /dev/null
+++ b/tcllib/modules/png/testimages/g03n0g16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g03n2c08.png b/tcllib/modules/png/testimages/g03n2c08.png
new file mode 100644
index 0000000..a9354db
--- /dev/null
+++ b/tcllib/modules/png/testimages/g03n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g03n3p04.png b/tcllib/modules/png/testimages/g03n3p04.png
new file mode 100644
index 0000000..60396c9
--- /dev/null
+++ b/tcllib/modules/png/testimages/g03n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g04n0g16.png b/tcllib/modules/png/testimages/g04n0g16.png
new file mode 100644
index 0000000..32395b7
--- /dev/null
+++ b/tcllib/modules/png/testimages/g04n0g16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g04n2c08.png b/tcllib/modules/png/testimages/g04n2c08.png
new file mode 100644
index 0000000..a652b0c
--- /dev/null
+++ b/tcllib/modules/png/testimages/g04n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g04n3p04.png b/tcllib/modules/png/testimages/g04n3p04.png
new file mode 100644
index 0000000..5661cc3
--- /dev/null
+++ b/tcllib/modules/png/testimages/g04n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g05n0g16.png b/tcllib/modules/png/testimages/g05n0g16.png
new file mode 100644
index 0000000..70b37f0
--- /dev/null
+++ b/tcllib/modules/png/testimages/g05n0g16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g05n2c08.png b/tcllib/modules/png/testimages/g05n2c08.png
new file mode 100644
index 0000000..932c136
--- /dev/null
+++ b/tcllib/modules/png/testimages/g05n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g05n3p04.png b/tcllib/modules/png/testimages/g05n3p04.png
new file mode 100644
index 0000000..9619930
--- /dev/null
+++ b/tcllib/modules/png/testimages/g05n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g07n0g16.png b/tcllib/modules/png/testimages/g07n0g16.png
new file mode 100644
index 0000000..d6a47c2
--- /dev/null
+++ b/tcllib/modules/png/testimages/g07n0g16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g07n2c08.png b/tcllib/modules/png/testimages/g07n2c08.png
new file mode 100644
index 0000000..5973464
--- /dev/null
+++ b/tcllib/modules/png/testimages/g07n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g07n3p04.png b/tcllib/modules/png/testimages/g07n3p04.png
new file mode 100644
index 0000000..c73fb61
--- /dev/null
+++ b/tcllib/modules/png/testimages/g07n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g10n0g16.png b/tcllib/modules/png/testimages/g10n0g16.png
new file mode 100644
index 0000000..85f2c95
--- /dev/null
+++ b/tcllib/modules/png/testimages/g10n0g16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g10n2c08.png b/tcllib/modules/png/testimages/g10n2c08.png
new file mode 100644
index 0000000..b303997
--- /dev/null
+++ b/tcllib/modules/png/testimages/g10n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g10n3p04.png b/tcllib/modules/png/testimages/g10n3p04.png
new file mode 100644
index 0000000..1b6a6be
--- /dev/null
+++ b/tcllib/modules/png/testimages/g10n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g25n0g16.png b/tcllib/modules/png/testimages/g25n0g16.png
new file mode 100644
index 0000000..a9f6787
--- /dev/null
+++ b/tcllib/modules/png/testimages/g25n0g16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g25n2c08.png b/tcllib/modules/png/testimages/g25n2c08.png
new file mode 100644
index 0000000..03f505a
--- /dev/null
+++ b/tcllib/modules/png/testimages/g25n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/g25n3p04.png b/tcllib/modules/png/testimages/g25n3p04.png
new file mode 100644
index 0000000..4f943c6
--- /dev/null
+++ b/tcllib/modules/png/testimages/g25n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/oi1n0g16.png b/tcllib/modules/png/testimages/oi1n0g16.png
new file mode 100644
index 0000000..e7c82f7
--- /dev/null
+++ b/tcllib/modules/png/testimages/oi1n0g16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/oi1n2c16.png b/tcllib/modules/png/testimages/oi1n2c16.png
new file mode 100644
index 0000000..50c1cb9
--- /dev/null
+++ b/tcllib/modules/png/testimages/oi1n2c16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/oi2n0g16.png b/tcllib/modules/png/testimages/oi2n0g16.png
new file mode 100644
index 0000000..14d64c5
--- /dev/null
+++ b/tcllib/modules/png/testimages/oi2n0g16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/oi2n2c16.png b/tcllib/modules/png/testimages/oi2n2c16.png
new file mode 100644
index 0000000..4c2e3e3
--- /dev/null
+++ b/tcllib/modules/png/testimages/oi2n2c16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/oi4n0g16.png b/tcllib/modules/png/testimages/oi4n0g16.png
new file mode 100644
index 0000000..69e73ed
--- /dev/null
+++ b/tcllib/modules/png/testimages/oi4n0g16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/oi4n2c16.png b/tcllib/modules/png/testimages/oi4n2c16.png
new file mode 100644
index 0000000..93691e3
--- /dev/null
+++ b/tcllib/modules/png/testimages/oi4n2c16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/oi9n0g16.png b/tcllib/modules/png/testimages/oi9n0g16.png
new file mode 100644
index 0000000..9248413
--- /dev/null
+++ b/tcllib/modules/png/testimages/oi9n0g16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/oi9n2c16.png b/tcllib/modules/png/testimages/oi9n2c16.png
new file mode 100644
index 0000000..f0512e4
--- /dev/null
+++ b/tcllib/modules/png/testimages/oi9n2c16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/pngsuite.doc b/tcllib/modules/png/testimages/pngsuite.doc
new file mode 100644
index 0000000..7da918b
--- /dev/null
+++ b/tcllib/modules/png/testimages/pngsuite.doc
@@ -0,0 +1,520 @@
+ PNGSUITE
+----------------
+
+ testset for PNG-(de)coders
+ created by Willem van Schaik
+------------------------------------
+
+This is a collection of graphics images created to test the png applications
+like viewers, converters and editors. All (as far as that is possible)
+formats supported by the PNG standard are represented.
+
+
+1. INTRODUCTION
+--------------------
+
+1.1 PNG capabilities
+------------------------
+
+Supported color-types are:
+
+ - grayscale
+ - grayscale + alpha-channel
+ - color palettes
+ - rgb
+ - rgb + alpha-channel
+
+Allowed bitdepths are depending on the color-type, but are in the range
+of 1-bit (grayscale, which is b&w) upto 16-bits.
+
+Special features are:
+
+ - interlacing (Adam-7)
+ - gamma-support
+ - transparency (a poor-man's alpha solution)
+
+
+1.2 File naming
+-------------------
+
+Where possible, the testfiles are 32x32 bits icons. This results in a still
+reasonable size of the suite even with a large number of tests. The name
+of each test-file reflects thetype in the following way:
+
+ g04i2c08.png
+ || |||+---- bit-depth
+ || ||+----- color-type (descriptive)
+ || |+------ color-type (numerical)
+ || +------- interlaced or non-interlaced
+ |+--------- parameter of test (in this case gamma-value)
+ +---------- test feature (in this case gamma)
+
+
+1.3 PNG formats
+-------------------
+
+color-type:
+ 0g - grayscale
+ 2c - rgb color
+ 3p - paletted
+ 4a - grayscale + alpha channel
+ 6a - rgb color + alpha channel
+
+bit-depth:
+ 01 - with color-type 0, 3
+ 02 - with color-type 0, 3
+ 04 - with color-type 0, 3
+ 08 - with color-type 0, 2, 3, 4, 6
+ 16 - with color-type 0, 2, 4, 6
+
+interlacing:
+ n - non-interlaced
+ i - interlaced
+
+
+2. THE TESTS
+-----------------
+
+2.1 Sizes
+-------------
+
+These tests are there to check if your software handles pictures well, with
+picture sizes that are not a multiple of 8. This is particularly important
+with Adam-7 type interlacing. In the same way these tests check if pictures
+size 1x1 and similar are ok.
+
+ s01 - 1x1 pixel picture
+ s02 - 2x2 pixel picture
+ s03 - 3x3 pixel picture
+ s04 - 4x4 pixel picture
+ s05 - 5x5 pixel picture
+ s06 - 6x6 pixel picture
+ s07 - 7x7 pixel picture
+ s08 - 8x8 pixel picture
+ s09 - 9x9 pixel picture
+ s32 - 32x32 pixel picture
+ s33 - 33x33 pixel picture
+ s34 - 34x34 pixel picture
+ s35 - 35x35 pixel picture
+ s36 - 36x36 pixel picture
+ s37 - 37x37 pixel picture
+ s38 - 38x38 pixel picture
+ s39 - 39x39 pixel picture
+ s40 - 40x40 pixel picture
+
+
+2.2 Background
+------------------
+
+When the PNG file contains a background chunck, this should be used for
+pictures with alpha-channel or pictures with a transparency chunck. For
+pictures without this background-chunk, but with alpha, this testset
+assumes a black background.
+
+For the images in this test, the left-side should be 100% the background
+color, where moving to the right the color should gradually become the
+image pattern.
+
+ bga - alpha + no background
+ bgw - alpha + white background
+ bgg - alpha + gray background
+ bgb - alpha + black background
+ bgy - alpha + yellow background
+
+
+2.3 Transparency
+--------------------
+
+Transparency should be used together with a background chunk. To test the
+combination of the two the latter 4 tests are there. How to handle pictures
+with transparancy, but without a background, opinions can differ. Here we
+use black, but especially in the case of paletted images, the normal color
+would maybe even be better.
+
+ tp0 - not transparent for reference
+ tp1 - transparent, but no background chunk
+ tbw - transparent + white background
+ tbg - transparent + gray background
+ tbb - transparent + black background
+ tby - transparent + yellow background
+
+
+2.4 Gamma
+-------------
+
+To test if your viewer handles gamma-correction, 6 testfiles are available.
+They contain corrected color-ramps and a corresponding gamma-chunk with the
+file-gamma value. These are created in such a way that when the viewer does
+the gamma correction right, all 6 should be displayed identical.
+
+If they are different, probably the gamma correction is omitted. In that
+case, have a look at the two right coloumns in the 6 pictures. The image
+where those two look the same (when looked from far) reflects the gamma of
+your system. However, because of the limited size of the image, you should
+do more elaborate tests to determine your display gamma.
+
+ g03 - file-gamma = 0.35, for display with gamma = 2.8
+ g04 - file-gamma = 0.45, for display with gamma = 2.2 (PC)
+ g05 - file-gamma = 0.55, for display with gamma = 1.8 (Mac)
+ g07 - file-gamma = 0.70, for display with gamma = 1.4
+ g10 - file-gamma = 1.00, for display with gamma = 1.0 (NeXT)
+ g25 - file-gamma = 2.50, for display with gamma = 0.4
+
+
+2.5 Filtering
+-----------------
+
+PNG uses file-filtering, for optimal compression. Normally the type is of
+filtering is adjusted to the contents of the picture, but here each file
+has the same picture, with a different filtering.
+
+ f0 - no filtering
+ f1 - sub filtering
+ f2 - up filtering
+ f3 - average filtering
+ f4 - paeth filtering
+
+
+2.6 Additional palettes
+---------------------------
+
+Besides the normal use of paletted images, palette chunks can in combination
+with true-color (and other) images also be used to select color lookup-tables
+when the video system is of limited capabilities. The suggested palette chunk
+is specially created for this purpose.
+
+ pp - normal palette chunk
+ ps - suggested palette chunk
+
+
+2.7 Ancillary chunks (under construction)
+------------------------
+
+To test the correct decoding of ancillary chunks, these test-files contain
+one or more examples of these chunkcs. Depending on the type of chunk, a
+number of typical values are selected to test. Unluckily, the testset can
+not contain all combinations, because that would be an endless set.
+
+The significant bits are used in files with the next higher bit-depth. They
+indicate howmany bits are valid.
+
+ cs3 - 3 significant bits
+ cs5 - 5 significant bits
+ cs8 - 8 significant bits (reference)
+ cs3 - 13 significant bits
+
+For the physical pixel dimensions, the result of each decoding should be
+a sqare picture. The first (cdf) image is an example of flat (horizontal)
+pixels, where the pHYS chunk (x is 1 per unit, y = 4 per unit) must take
+care of the correction. The second is just the other way round. The last
+example uses the unit specifier, for 1000 pixels per meter. This should
+result in a picture of 3.2 cm square.
+
+ cdf - physical pixel dimensions, 8x32 flat pixels
+ cdh - physical pixel dimensions, 32x8 high pixels
+ cds - physical pixel dimensions, 8x8 square pixels
+ cdu - physical pixel dimensions, with unit-specifier
+
+ ccw - primary chromaticities and white point
+
+ ch1 - histogram 15 colors
+ ch2 - histogram 256 colors
+
+ cm7 - modification time, 01-jan-1970
+ cm9 - modification time, 31-dec-1999
+ cm0 - modification time, 01-jan-2000
+
+In the textual chunk, a number of the standard, and some non-standard
+text items are included.
+
+ ct0 - no textual data
+ ct1 - with textual data
+ ctz - with compressed textual data
+
+
+2.8 Chunk ordering (still under construction)
+----------------------
+
+These testfiles will test the obligatory ordering relations between various
+chunk types (not yet) as well as the number of data chunks used for the image.
+
+ oi1 - mother image with 1 idat-chunk
+ oi2 - image with 2 idat-chunks
+ oi4 - image with 4 unequal sized idat-chunks
+ oi9 - all idat-chunks of length one
+
+
+2.9 Compression level
+-------------------------
+
+Here you will find a set of images compressed by zlib, ranging from level 0
+for no compression at maximum speed upto level 9 for maximum compression.
+
+ z00 - zlib compression level 0 - none
+ z03 - zlib compression level 3
+ z06 - zlib compression level 6 - default
+ z09 - zlib compression level 9 - maximum
+
+
+2.10 Corrupted files (under construction)
+-----------------------
+
+All these files are illegal. When decoding they should generate appropriate
+error-messages.
+
+ x00 - empty IDAT chunk
+ xcr - added cr bytes
+ xlf - added lf bytes
+ xc0 - color type 0
+ xc9 - color type 9
+ xd0 - bit-depth 0
+ xd3 - bit-depth 3
+ xd9 - bit-depth 99
+ xcs - incorrect IDAT checksum
+
+
+3. TEST FILES
+------------------
+
+For each of the tests listed above, one or more test-files are created. A
+selection is made (for each test) for the color-type and bitdepth to be used
+for the tests. Further for a number of tests, both a non-interlaced as well
+as an interlaced version is available.
+
+
+3.1 Basic format test files (non-interlaced)
+------------------------------------------------
+
+ basn0g01 - black & white
+ basn0g02 - 2 bit (4 level) grayscale
+ basn0g04 - 4 bit (16 level) grayscale
+ basn0g08 - 8 bit (256 level) grayscale
+ basn0g16 - 16 bit (64k level) grayscale
+ basn2c08 - 3x8 bits rgb color
+ basn2c16 - 3x16 bits rgb color
+ basn3p01 - 1 bit (2 color) paletted
+ basn3p02 - 2 bit (4 color) paletted
+ basn3p04 - 4 bit (16 color) paletted
+ basn3p08 - 8 bit (256 color) paletted
+ basn4a08 - 8 bit grayscale + 8 bit alpha-channel
+ basn4a16 - 16 bit grayscale + 16 bit alpha-channel
+ basn6a08 - 3x8 bits rgb color + 8 bit alpha-channel
+ basn6a16 - 3x16 bits rgb color + 16 bit alpha-channel
+
+
+3.2 Basic format test files (Adam-7 interlaced)
+---------------------------------------------------
+
+ basi0g01 - black & white
+ basi0g02 - 2 bit (4 level) grayscale
+ basi0g04 - 4 bit (16 level) grayscale
+ basi0g08 - 8 bit (256 level) grayscale
+ basi0g16 - 16 bit (64k level) grayscale
+ basi2c08 - 3x8 bits rgb color
+ basi2c16 - 3x16 bits rgb color
+ basi3p01 - 1 bit (2 color) paletted
+ basi3p02 - 2 bit (4 color) paletted
+ basi3p04 - 4 bit (16 color) paletted
+ basi3p08 - 8 bit (256 color) paletted
+ basi4a08 - 8 bit grayscale + 8 bit alpha-channel
+ basi4a16 - 16 bit grayscale + 16 bit alpha-channel
+ basi6a08 - 3x8 bits rgb color + 8 bit alpha-channel
+ basi6a16 - 3x16 bits rgb color + 16 bit alpha-channel
+
+
+3.3 Sizes test files
+-----------------------
+
+ s01n3p01 - 1x1 paletted file, no interlacing
+ s02n3p01 - 2x2 paletted file, no interlacing
+ s03n3p01 - 3x3 paletted file, no interlacing
+ s04n3p01 - 4x4 paletted file, no interlacing
+ s05n3p02 - 5x5 paletted file, no interlacing
+ s06n3p02 - 6x6 paletted file, no interlacing
+ s07n3p02 - 7x7 paletted file, no interlacing
+ s08n3p02 - 8x8 paletted file, no interlacing
+ s09n3p02 - 9x9 paletted file, no interlacing
+ s32n3p04 - 32x32 paletted file, no interlacing
+ s33n3p04 - 33x33 paletted file, no interlacing
+ s34n3p04 - 34x34 paletted file, no interlacing
+ s35n3p04 - 35x35 paletted file, no interlacing
+ s36n3p04 - 36x36 paletted file, no interlacing
+ s37n3p04 - 37x37 paletted file, no interlacing
+ s38n3p04 - 38x38 paletted file, no interlacing
+ s39n3p04 - 39x39 paletted file, no interlacing
+ s40n3p04 - 40x40 paletted file, no interlacing
+
+ s01i3p01 - 1x1 paletted file, interlaced
+ s02i3p01 - 2x2 paletted file, interlaced
+ s03i3p01 - 3x3 paletted file, interlaced
+ s04i3p01 - 4x4 paletted file, interlaced
+ s05i3p02 - 5x5 paletted file, interlaced
+ s06i3p02 - 6x6 paletted file, interlaced
+ s07i3p02 - 7x7 paletted file, interlaced
+ s08i3p02 - 8x8 paletted file, interlaced
+ s09i3p02 - 9x9 paletted file, interlaced
+ s32i3p04 - 32x32 paletted file, interlaced
+ s33i3p04 - 33x33 paletted file, interlaced
+ s34i3p04 - 34x34 paletted file, interlaced
+ s35i3p04 - 35x35 paletted file, interlaced
+ s36i3p04 - 36x36 paletted file, interlaced
+ s37i3p04 - 37x37 paletted file, interlaced
+ s38i3p04 - 38x38 paletted file, interlaced
+ s39i3p04 - 39x39 paletted file, interlaced
+ s40i3p04 - 40x40 paletted file, interlaced
+
+
+3.4 Background test files (with alpha)
+------------------------------------------
+
+ bgai4a08 - 8 bit grayscale, alpha, no background chunk, interlaced
+ bgai4a16 - 16 bit grayscale, alpha, no background chunk, interlaced
+ bgan6a08 - 3x8 bits rgb color, alpha, no background chunk
+ bgan6a16 - 3x16 bits rgb color, alpha, no background chunk
+
+ bgbn4a08 - 8 bit grayscale, alpha, black background chunk
+ bggn4a16 - 16 bit grayscale, alpha, gray background chunk
+ bgwn6a08 - 3x8 bits rgb color, alpha, white background chunk
+ bgyn6a16 - 3x16 bits rgb color, alpha, yellow background chunk
+
+
+3.5 Transparency (and background) test files
+------------------------------------------------
+
+ tp0n1g08 - not transparent for reference (logo on gray)
+ tbbn1g04 - transparent, black background chunk
+ tbwn1g16 - transparent, white background chunk
+ tp0n2c08 - not transparent for reference (logo on gray)
+ tbrn2c08 - transparent, red background chunk
+ tbgn2c16 - transparent, green background chunk
+ tbbn2c16 - transparent, blue background chunk
+ tp0n3p08 - not transparent for reference (logo on gray)
+ tp1n3p08 - transparent, but no background chunk
+ tbbn3p08 - transparent, black background chunk
+ tbgn3p08 - transparent, light-gray background chunk
+ tbwn3p08 - transparent, white background chunk
+ tbyn3p08 - transparent, yellow background chunk
+
+
+3.6 Gamma test files
+------------------------
+
+ g03n0g16 - grayscale, file-gamma = 0.35
+ g04n0g16 - grayscale, file-gamma = 0.45
+ g05n0g16 - grayscale, file-gamma = 0.55
+ g07n0g16 - grayscale, file-gamma = 0.70
+ g10n0g16 - grayscale, file-gamma = 1.00
+ g25n0g16 - grayscale, file-gamma = 2.50
+ g03n2c08 - color, file-gamma = 0.35
+ g04n2c08 - color, file-gamma = 0.45
+ g05n2c08 - color, file-gamma = 0.55
+ g07n2c08 - color, file-gamma = 0.70
+ g10n2c08 - color, file-gamma = 1.00
+ g25n2c08 - color, file-gamma = 2.50
+ g03n3p04 - paletted, file-gamma = 0.35
+ g04n3p04 - paletted, file-gamma = 0.45
+ g05n3p04 - paletted, file-gamma = 0.55
+ g07n3p04 - paletted, file-gamma = 0.70
+ g10n3p04 - paletted, file-gamma = 1.00
+ g25n3p04 - paletted, file-gamma = 2.50
+
+
+3.7 Filtering test files
+----------------------------
+
+ f00n0g08 - grayscale, no interlacing, filter-type 0
+ f01n0g08 - grayscale, no interlacing, filter-type 1
+ f02n0g08 - grayscale, no interlacing, filter-type 2
+ f03n0g08 - grayscale, no interlacing, filter-type 3
+ f04n0g08 - grayscale, no interlacing, filter-type 4
+ f00n2c08 - color, no interlacing, filter-type 0
+ f01n2c08 - color, no interlacing, filter-type 1
+ f02n2c08 - color, no interlacing, filter-type 2
+ f03n2c08 - color, no interlacing, filter-type 3
+ f04n2c08 - color, no interlacing, filter-type 4
+
+
+3.8 Additional palette chunk test files
+-------------------------------------------
+
+ pp0n2c16 - six-cube palette-chunk in true-color image
+ pp0n6a08 - six-cube palette-chunk in true-color+alpha image
+ ps1n0g08 - six-cube suggested palette (1 byte) in grayscale image
+ ps1n2c16 - six-cube suggested palette (1 byte) in true-color image
+ ps2n0g08 - six-cube suggested palette (2 bytes) in grayscale image
+ ps2n2c16 - six-cube suggested palette (2 bytes) in true-color image
+
+
+3.9 Ancillary chunks test files
+-----------------------------------
+
+ cs5n2c08 - color, 5 significant bits
+ cs8n2c08 - color, 8 significant bits (reference)
+ cs3n2c16 - color, 13 significant bits
+ cs3n3p08 - paletted, 3 significant bits
+ cs5n3p08 - paletted, 5 significant bits
+ cs8n3p08 - paletted, 8 significant bits (reference)
+
+ cdfn2c08 - physical pixel dimensions, 8x32 flat pixels
+ cdhn2c08 - physical pixel dimensions, 32x8 high pixels
+ cdsn2c08 - physical pixel dimensions, 8x8 square pixels
+ cdun2c08 - physical pixel dimensions, 1000 pixels per 1 meter
+
+ ccwn2c08 - chroma chunk w:0.3127,0.3290 r:0.64,0.33 g:0.30,0.60 b:0.15,0.06
+ ccwn3p08 - chroma chunk w:0.3127,0.3290 r:0.64,0.33 g:0.30,0.60 b:0.15,0.06
+
+ ch1n3p04 - histogram 15 colors
+ ch2n3p08 - histogram 256 colors
+
+ cm7n0g04 - modification time, 01-jan-1970 00:00:00
+ cm9n0g04 - modification time, 31-dec-1999 23:59:59
+ cm0n0g04 - modification time, 01-jan-2000 12:34:56
+
+ ct0n0g04 - no textual data
+ ct1n0g04 - with textual data
+ ctzn0g04 - with compressed textual data
+
+
+
+3.10 Chunk ordering
+----------------------
+
+ oi1n0g16 - grayscale mother image with 1 idat-chunk
+ oi2n0g16 - grayscale image with 2 idat-chunks
+ oi4n0g16 - grayscale image with 4 unequal sized idat-chunks
+ oi9n0g16 - grayscale image with all idat-chunks length one
+ oi1n2c16 - color mother image with 1 idat-chunk
+ oi2n2c16 - color image with 2 idat-chunks
+ oi4n2c16 - color image with 4 unequal sized idat-chunks
+ oi9n2c16 - color image with all idat-chunks length one
+
+
+
+3.11 Compression level
+-------------------------
+
+ z00n2c08 - color, no interlacing, compression level 0 (none)
+ z03n2c08 - color, no interlacing, compression level 3
+ z06n2c08 - color, no interlacing, compression level 6 (default)
+ z09n2c08 - color, no interlacing, compression level 9 (maximum)
+
+
+
+3.12 Currupted files
+-----------------------
+
+ x00n0g01 - empty 0x0 grayscale file
+ xcrn0g04 - added cr bytes
+ xlfn0g04 - added lf bytes
+ xc0n0c08 - color type 0
+ xc9n0c08 - color type 9
+ xd0n2c00 - bit-depth 0
+ xd3n2c03 - bit-depth 3
+ xd9n2c99 - bit-depth 99
+ xcsn2c08 - incorrect IDAT checksum
+
+
+--------
+ (c) Willem van Schaik
+ willem@schaik.com
+ Singapore, October 1996
diff --git a/tcllib/modules/png/testimages/pngsuite_logo.png b/tcllib/modules/png/testimages/pngsuite_logo.png
new file mode 100644
index 0000000..205460d
--- /dev/null
+++ b/tcllib/modules/png/testimages/pngsuite_logo.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/pp0n2c16.png b/tcllib/modules/png/testimages/pp0n2c16.png
new file mode 100644
index 0000000..8f2aad7
--- /dev/null
+++ b/tcllib/modules/png/testimages/pp0n2c16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/pp0n6a08.png b/tcllib/modules/png/testimages/pp0n6a08.png
new file mode 100644
index 0000000..4ed7a30
--- /dev/null
+++ b/tcllib/modules/png/testimages/pp0n6a08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/ps1n0g08.png b/tcllib/modules/png/testimages/ps1n0g08.png
new file mode 100644
index 0000000..2053df2
--- /dev/null
+++ b/tcllib/modules/png/testimages/ps1n0g08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/ps1n2c16.png b/tcllib/modules/png/testimages/ps1n2c16.png
new file mode 100644
index 0000000..b03ecfc
--- /dev/null
+++ b/tcllib/modules/png/testimages/ps1n2c16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/ps2n0g08.png b/tcllib/modules/png/testimages/ps2n0g08.png
new file mode 100644
index 0000000..beeab8f
--- /dev/null
+++ b/tcllib/modules/png/testimages/ps2n0g08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/ps2n2c16.png b/tcllib/modules/png/testimages/ps2n2c16.png
new file mode 100644
index 0000000..c256f90
--- /dev/null
+++ b/tcllib/modules/png/testimages/ps2n2c16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s01i3p01.png b/tcllib/modules/png/testimages/s01i3p01.png
new file mode 100644
index 0000000..6c0fad1
--- /dev/null
+++ b/tcllib/modules/png/testimages/s01i3p01.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s01n3p01.png b/tcllib/modules/png/testimages/s01n3p01.png
new file mode 100644
index 0000000..cb2c8c7
--- /dev/null
+++ b/tcllib/modules/png/testimages/s01n3p01.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s02i3p01.png b/tcllib/modules/png/testimages/s02i3p01.png
new file mode 100644
index 0000000..2defaed
--- /dev/null
+++ b/tcllib/modules/png/testimages/s02i3p01.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s02n3p01.png b/tcllib/modules/png/testimages/s02n3p01.png
new file mode 100644
index 0000000..2b1b669
--- /dev/null
+++ b/tcllib/modules/png/testimages/s02n3p01.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s03i3p01.png b/tcllib/modules/png/testimages/s03i3p01.png
new file mode 100644
index 0000000..c23fdc4
--- /dev/null
+++ b/tcllib/modules/png/testimages/s03i3p01.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s03n3p01.png b/tcllib/modules/png/testimages/s03n3p01.png
new file mode 100644
index 0000000..6d96ee4
--- /dev/null
+++ b/tcllib/modules/png/testimages/s03n3p01.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s04i3p01.png b/tcllib/modules/png/testimages/s04i3p01.png
new file mode 100644
index 0000000..0e710c2
--- /dev/null
+++ b/tcllib/modules/png/testimages/s04i3p01.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s04n3p01.png b/tcllib/modules/png/testimages/s04n3p01.png
new file mode 100644
index 0000000..956396c
--- /dev/null
+++ b/tcllib/modules/png/testimages/s04n3p01.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s05i3p02.png b/tcllib/modules/png/testimages/s05i3p02.png
new file mode 100644
index 0000000..d14cbd3
--- /dev/null
+++ b/tcllib/modules/png/testimages/s05i3p02.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s05n3p02.png b/tcllib/modules/png/testimages/s05n3p02.png
new file mode 100644
index 0000000..bf940f0
--- /dev/null
+++ b/tcllib/modules/png/testimages/s05n3p02.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s06i3p02.png b/tcllib/modules/png/testimages/s06i3p02.png
new file mode 100644
index 0000000..456ada3
--- /dev/null
+++ b/tcllib/modules/png/testimages/s06i3p02.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s06n3p02.png b/tcllib/modules/png/testimages/s06n3p02.png
new file mode 100644
index 0000000..501064d
--- /dev/null
+++ b/tcllib/modules/png/testimages/s06n3p02.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s07i3p02.png b/tcllib/modules/png/testimages/s07i3p02.png
new file mode 100644
index 0000000..44b66ba
--- /dev/null
+++ b/tcllib/modules/png/testimages/s07i3p02.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s07n3p02.png b/tcllib/modules/png/testimages/s07n3p02.png
new file mode 100644
index 0000000..6a58259
--- /dev/null
+++ b/tcllib/modules/png/testimages/s07n3p02.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s08i3p02.png b/tcllib/modules/png/testimages/s08i3p02.png
new file mode 100644
index 0000000..acf74f3
--- /dev/null
+++ b/tcllib/modules/png/testimages/s08i3p02.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s08n3p02.png b/tcllib/modules/png/testimages/s08n3p02.png
new file mode 100644
index 0000000..b7094e1
--- /dev/null
+++ b/tcllib/modules/png/testimages/s08n3p02.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s09i3p02.png b/tcllib/modules/png/testimages/s09i3p02.png
new file mode 100644
index 0000000..0bfae8e
--- /dev/null
+++ b/tcllib/modules/png/testimages/s09i3p02.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s09n3p02.png b/tcllib/modules/png/testimages/s09n3p02.png
new file mode 100644
index 0000000..711ab82
--- /dev/null
+++ b/tcllib/modules/png/testimages/s09n3p02.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s32i3p04.png b/tcllib/modules/png/testimages/s32i3p04.png
new file mode 100644
index 0000000..0841910
--- /dev/null
+++ b/tcllib/modules/png/testimages/s32i3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s32n3p04.png b/tcllib/modules/png/testimages/s32n3p04.png
new file mode 100644
index 0000000..fa58e3e
--- /dev/null
+++ b/tcllib/modules/png/testimages/s32n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s33i3p04.png b/tcllib/modules/png/testimages/s33i3p04.png
new file mode 100644
index 0000000..ab0dc14
--- /dev/null
+++ b/tcllib/modules/png/testimages/s33i3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s33n3p04.png b/tcllib/modules/png/testimages/s33n3p04.png
new file mode 100644
index 0000000..764f1a3
--- /dev/null
+++ b/tcllib/modules/png/testimages/s33n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s34i3p04.png b/tcllib/modules/png/testimages/s34i3p04.png
new file mode 100644
index 0000000..bd99039
--- /dev/null
+++ b/tcllib/modules/png/testimages/s34i3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s34n3p04.png b/tcllib/modules/png/testimages/s34n3p04.png
new file mode 100644
index 0000000..9cbc68b
--- /dev/null
+++ b/tcllib/modules/png/testimages/s34n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s35i3p04.png b/tcllib/modules/png/testimages/s35i3p04.png
new file mode 100644
index 0000000..e2a5e0a
--- /dev/null
+++ b/tcllib/modules/png/testimages/s35i3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s35n3p04.png b/tcllib/modules/png/testimages/s35n3p04.png
new file mode 100644
index 0000000..90b892e
--- /dev/null
+++ b/tcllib/modules/png/testimages/s35n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s36i3p04.png b/tcllib/modules/png/testimages/s36i3p04.png
new file mode 100644
index 0000000..eb61b6f
--- /dev/null
+++ b/tcllib/modules/png/testimages/s36i3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s36n3p04.png b/tcllib/modules/png/testimages/s36n3p04.png
new file mode 100644
index 0000000..b38d179
--- /dev/null
+++ b/tcllib/modules/png/testimages/s36n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s37i3p04.png b/tcllib/modules/png/testimages/s37i3p04.png
new file mode 100644
index 0000000..6e2b1e9
--- /dev/null
+++ b/tcllib/modules/png/testimages/s37i3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s37n3p04.png b/tcllib/modules/png/testimages/s37n3p04.png
new file mode 100644
index 0000000..4d3054d
--- /dev/null
+++ b/tcllib/modules/png/testimages/s37n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s38i3p04.png b/tcllib/modules/png/testimages/s38i3p04.png
new file mode 100644
index 0000000..a0a8a14
--- /dev/null
+++ b/tcllib/modules/png/testimages/s38i3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s38n3p04.png b/tcllib/modules/png/testimages/s38n3p04.png
new file mode 100644
index 0000000..1233ed0
--- /dev/null
+++ b/tcllib/modules/png/testimages/s38n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s39i3p04.png b/tcllib/modules/png/testimages/s39i3p04.png
new file mode 100644
index 0000000..04fee93
--- /dev/null
+++ b/tcllib/modules/png/testimages/s39i3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s39n3p04.png b/tcllib/modules/png/testimages/s39n3p04.png
new file mode 100644
index 0000000..c750100
--- /dev/null
+++ b/tcllib/modules/png/testimages/s39n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s40i3p04.png b/tcllib/modules/png/testimages/s40i3p04.png
new file mode 100644
index 0000000..68f358b
--- /dev/null
+++ b/tcllib/modules/png/testimages/s40i3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/s40n3p04.png b/tcllib/modules/png/testimages/s40n3p04.png
new file mode 100644
index 0000000..864b6b9
--- /dev/null
+++ b/tcllib/modules/png/testimages/s40n3p04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/tbbn1g04.png b/tcllib/modules/png/testimages/tbbn1g04.png
new file mode 100644
index 0000000..fc80020
--- /dev/null
+++ b/tcllib/modules/png/testimages/tbbn1g04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/tbbn2c16.png b/tcllib/modules/png/testimages/tbbn2c16.png
new file mode 100644
index 0000000..5abfbbb
--- /dev/null
+++ b/tcllib/modules/png/testimages/tbbn2c16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/tbbn3p08.png b/tcllib/modules/png/testimages/tbbn3p08.png
new file mode 100644
index 0000000..4210d16
--- /dev/null
+++ b/tcllib/modules/png/testimages/tbbn3p08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/tbgn2c16.png b/tcllib/modules/png/testimages/tbgn2c16.png
new file mode 100644
index 0000000..236c81d
--- /dev/null
+++ b/tcllib/modules/png/testimages/tbgn2c16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/tbgn3p08.png b/tcllib/modules/png/testimages/tbgn3p08.png
new file mode 100644
index 0000000..42db232
--- /dev/null
+++ b/tcllib/modules/png/testimages/tbgn3p08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/tbrn2c08.png b/tcllib/modules/png/testimages/tbrn2c08.png
new file mode 100644
index 0000000..8c21474
--- /dev/null
+++ b/tcllib/modules/png/testimages/tbrn2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/tbwn1g16.png b/tcllib/modules/png/testimages/tbwn1g16.png
new file mode 100644
index 0000000..dba2cbb
--- /dev/null
+++ b/tcllib/modules/png/testimages/tbwn1g16.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/tbwn3p08.png b/tcllib/modules/png/testimages/tbwn3p08.png
new file mode 100644
index 0000000..7922135
--- /dev/null
+++ b/tcllib/modules/png/testimages/tbwn3p08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/tbyn3p08.png b/tcllib/modules/png/testimages/tbyn3p08.png
new file mode 100644
index 0000000..5b2c6cb
--- /dev/null
+++ b/tcllib/modules/png/testimages/tbyn3p08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/tp0n1g08.png b/tcllib/modules/png/testimages/tp0n1g08.png
new file mode 100644
index 0000000..caad31d
--- /dev/null
+++ b/tcllib/modules/png/testimages/tp0n1g08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/tp0n2c08.png b/tcllib/modules/png/testimages/tp0n2c08.png
new file mode 100644
index 0000000..f26be44
--- /dev/null
+++ b/tcllib/modules/png/testimages/tp0n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/tp0n3p08.png b/tcllib/modules/png/testimages/tp0n3p08.png
new file mode 100644
index 0000000..4d6cf9e
--- /dev/null
+++ b/tcllib/modules/png/testimages/tp0n3p08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/tp1n3p08.png b/tcllib/modules/png/testimages/tp1n3p08.png
new file mode 100644
index 0000000..6c5fd6e
--- /dev/null
+++ b/tcllib/modules/png/testimages/tp1n3p08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/x00n0g01.png b/tcllib/modules/png/testimages/x00n0g01.png
new file mode 100644
index 0000000..db3a5fd
--- /dev/null
+++ b/tcllib/modules/png/testimages/x00n0g01.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/xcrn0g04.png b/tcllib/modules/png/testimages/xcrn0g04.png
new file mode 100644
index 0000000..5bce9f3
--- /dev/null
+++ b/tcllib/modules/png/testimages/xcrn0g04.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/xlfn0g04.png b/tcllib/modules/png/testimages/xlfn0g04.png
new file mode 100644
index 0000000..1fd104b
--- /dev/null
+++ b/tcllib/modules/png/testimages/xlfn0g04.png
@@ -0,0 +1,13 @@
+PNG
+
+
+
+
+
+IHDR )IDATx]
+0 P*@#
+
+#T10lPF`ؠF=IQ*u`%qk
+H񚈩mߟ э=,fOK
+
+t(F ;P{xp]9/p*$(*yՃ@C  cqNU#)11.rf0gh(tEkIENDB` \ No newline at end of file
diff --git a/tcllib/modules/png/testimages/z00n2c08.png b/tcllib/modules/png/testimages/z00n2c08.png
new file mode 100644
index 0000000..7669eb8
--- /dev/null
+++ b/tcllib/modules/png/testimages/z00n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/z03n2c08.png b/tcllib/modules/png/testimages/z03n2c08.png
new file mode 100644
index 0000000..bfb10de
--- /dev/null
+++ b/tcllib/modules/png/testimages/z03n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/z06n2c08.png b/tcllib/modules/png/testimages/z06n2c08.png
new file mode 100644
index 0000000..b90ebc1
--- /dev/null
+++ b/tcllib/modules/png/testimages/z06n2c08.png
Binary files differ
diff --git a/tcllib/modules/png/testimages/z09n2c08.png b/tcllib/modules/png/testimages/z09n2c08.png
new file mode 100644
index 0000000..5f191a7
--- /dev/null
+++ b/tcllib/modules/png/testimages/z09n2c08.png
Binary files differ
diff --git a/tcllib/modules/pop3/ChangeLog b/tcllib/modules/pop3/ChangeLog
new file mode 100644
index 0000000..97e5e38
--- /dev/null
+++ b/tcllib/modules/pop3/ChangeLog
@@ -0,0 +1,419 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2012-01-10 Andreas Kupries <andreask@activestate.com>
+
+ * pop3.test: Requiring Tcl 8.4 here as well.
+
+ * pop3.tcl: [Bug 3471474]: Fixed bug where the socketcmd was not
+ * pop3.man: treated as cmdprefix as documented, but as command
+ * pkgIndex.tcl: name. Dropped supported for 8.2 and moved forward
+ to require Tcl 8.4. Keep the 8.4-ism of 'eq'. Bumped the version
+ to 1.9.
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-11-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.test (pop3-7.0): Updated for additional configure options
+ returned by peek, plus same change to the socket handle handling
+ as for pop3-0.8, see below.
+
+2011-11-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.test (pop3-0.8): Modified the test case matching a bit to
+ handle the fact that under 8.6 a socket channel handle may
+ contain hex data after the general prefix, instead of just
+ digits.
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2011-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.test: Fixed tests results to list the new options.
+ * pop3.tcl: Fixed issue with closing during open introduced by the
+ patch. When a connect error occurs we cannot send a QUIT any
+ longer, and have to close the socket directly.
+
+2011-01-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.tcl: Extended package with STARTTLS support provided by
+ * pop3.man: Pascal Scheffers. This switches a regular connection
+ * pkgIndex.tcl: over to SSL/TLS. Version bumped to 1.8.
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2009-09-28 Andreas Kupries <andreask@activestate.com>
+
+ * pop3.test: Moved the dialog setup for test pop3-7.0 into the
+ test, to ensure that it is not run if TLS is not available.
+
+2009-04-13 Andreas Kupries <andreask@activestate.com>
+
+ * pop3.tcl (::pop3::open): Extended to accept a new option
+ * pop3.man: -socketcmd, through which the user can override the
+ * pop3.test: way the connection is opened. Primary use is securing
+ * pkgIndex.tcl: of the connection via SSL (package tls, command
+ tls::socket). Updated documentation. Extended testsuite. Bumped
+ package version to 1.7.
+
+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-08-08 Andreas Kupries <andreask@activestate.com>
+
+ * pop3.test: And snit is loaded by coserv.tcl too, no explicit
+ load required.
+
+2007-08-01 Andreas Kupries <andreask@activestate.com>
+
+ * pop3.test: Updated to new snit dependency in comm.
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.man: Fixed all warnings due to use of now deprecated
+ commands. Added a section about how to give feedback.
+
+2006-10-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.test: Made pop3-0.5 more robust, accept more than just
+ 'connection refused' as proper failure to connect. Like 'timed
+ out'.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.test: Added use of local log package, fixed bug in dialog
+ setup for testcases pop3-2.4 and -2.5, extended these two test
+ cases to have the dialog trace in their result.
+
+2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.test: Fixed cleanup of temp. files used by testsuite.
+
+2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.test: Hooked into the new common test support code.
+
+2006-01-10 Andreas Kupries <andreask@activestate.com>
+
+ * pop3.test: Fixed [SF Tcllib Bug 1316056]. Uncluttering test
+ output.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2004-10-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * clnt.tcl: Removed old unused code. It was part of the testsuite
+ * srv.tcl: in the very beginning. It was unused in the first
+ rewrite to the old sub process and dialog facility.
+
+ * pop3.test: Rewritten to use the new facilities for programmed
+ interaction and sub processes.
+
+ * pop3.tcl (::pop3::open): Capitalized the user and pass
+ commands. Every command in the wire is now fully capitalized.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-08-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.test: Added code to remove the temp. file containing the
+ server log.
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-01-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: Version bumped up to 1.6.1.
+ * pop3.man:
+
+ * pop3.test: New test for the corner case.
+ * pop3.tcl (::pop3::RetrFast): Thanks to Clif Flynt for reporting a
+ new corner case I had not considered in the fast/slow
+ transition code, plus patch. Modified a number of string
+ comparisons, using [string equal] instead of "==" (Improved
+ performance due to less conversion and less checking for
+ numerics, and possibly bytecompilation in Tcl 8.4+).
+
+2003-11-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.tcl (pop3::open): Remembering initial count of messages, as
+ limit for message ids.
+ (pop3::delete): Replaced [status] call with access to stored
+ limit for validation of message ids.
+ (pop3::retrieve): Ditto.
+ The changes above fix [SF Tcllib Bug 833486].
+
+ * pop3.test: Updated testsuite to the changes in the sequences of
+ pop3 commands (New STAT after PASS, and no STAT before
+ LAST/RETR, nor before LAST/DELE).
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-05-02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.test: Creating the name of the file containing the fake
+ server only once. Because the tcltest 1.0 [makeFile] coming with
+ Tcl 8.2 will return the fully generated name only once, and not
+ everytime it is called.
+
+2003-04-21 Andreas Kupries <andreask@activestate.com>
+
+ * pop3.test (0.6): Fixed test 0.6, removed dependency on service
+ running on port 25 (smtp), using fake service on some free port
+ instead.
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * pop3.tcl:
+ * pop3.man:
+ * pkgIndex.tcl: Set version of the package to to 1.6
+
+2003-04-09 Andreas Kupries <andreask@activestate.com>
+
+ * pop3.man: Documented new API.
+
+ * pop3.tcl: More logging of internal activity. Final nail into the
+ bug #528928 (Additional border cases were not handled yet,
+ incorrect handling detected through the new testsuite).
+
+ New API 'pop3::config'.
+
+ * pop3.test: Testsuite rewritten. Uses the sub-process and server
+ support provided by the new module 'devtools'. Avoids the stdin
+ lockup on windows. Uses a micro server for fixed responses to
+ the client instead of a true pop3 server, simplifies the
+ testing, less external dependencies, also better control over
+ the data sent to the client = easier to create intentionally
+ (semi-)bogus information to stress border cases.
+
+2003-04-03 Andreas Kupries <andreask@activestate.com>
+
+ * pop3.tcl: Fixed bug in the new code which wasn't found because
+ that case was untestable when using a full-blown pop3 demon (Was
+ unable to construct a message which caused the boundary
+ condition to ocur in the client). Found using the microserver
+ code.
+
+ * pop3.test: Removed test case planned to test the above mentioned
+ boundary case. Added code for a microserver based testcase which
+ does exercize the condition. Deactivated as microserver is not
+ yet part of tcllib.
+
+ * pop3.test:
+ * srv.tcl: Corrected leftover changes from yesterday which should
+ not have been in the commit. I.e. reactivated reporting and
+ correct cleanup.
+
+2003-04-02 Andreas Kupries <andreask@activestate.com>
+
+ * srv.tcl:
+ * pop3.test: Added tests and messages for bug #528928.
+
+ * pop3.tcl (pop3::open): Bug fix, close channel to server when
+ talking to it fails (no greeting, login failure). This cleans up
+ a leak of open sockets.
+
+ (pop3::RetrFast): Fixed bug #528928 where a .-stuffed line was
+ misinterpreted as mail terminator.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.man: More semantic markup, less visual one.
+
+2002-10-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.test: Updated to expect 10 messages in pop3-6.0.
+ * srv.tcl: Initialize server with 10 messages. Divert log output
+ to server log. Prevents hangs in pop3-6.0.
+
+ * pop3.tcl (pop3::retrieve): Changed conditionals around [scan] to
+ check for the actual number of conversions required to make the
+ code work, instead of < 0. This fixes bug 620062.
+
+2002-09-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * srv.tcl: Extended to cleanup the fake maildrop directories when
+ exiting the server.
+
+ * pop3.test: Updated to handle differences between 8.3 and 8.4
+ (different error messages). Added code to suppress logging under
+ normal circumstances. Extended to clean up the log file created
+ by the test pop3 server.
+
+2002-09-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.test: Added testcase 6.0, a nano-client to retrieve and
+ delete all messages on a pop server in one go. Directly derived
+ from the script for Tcllib bug #501577. Unable to reproduce that
+ bug :(
+
+ * pop3.test:
+ * clnt.tcl:
+ * srv.tcl: Added testsuite. Incomplete. No test of 'delete'
+ command yet. The problems found by the testsuite so far were all
+ in the used pop3 server (pop3d module of tcllib).
+
+2002-03-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.man: New file, doctools manpage.
+
+2002-01-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Bumped version to 1.5.1
+
+2001-12-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.tcl (retrieve): Forgot several 'RETR $index'
+ commands. Fixed now. This is tcllib bug item #490151 reported by
+ an unknown person.
+
+2001-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.n:
+ * pop3.tcl:
+ * pkgIndex.tcl: Version up to 1.5
+
+2001-08-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.tcl: Added UIDL command, patch [448634] by Mark G. Saye
+ <markgsaye@users.sourceforge.net>. Code was added manually as
+ the patch was not applicable anymore after the recent changes
+ (see below). Updated implementation of UIDL to use the new
+ command [RetrSlow] instead of performing the retrieval by
+ itself. Also updated the implementations of the TOP and LIST
+ commands to do the same.
+
+2001-08-02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.n: Updated to new package version, see [447013] too.
+
+ * pop3.tcl: Lots of changes with regard to items [443613] and
+ [443645]. Switched auto back to binary (or else the counting of
+ octects is not right and we will hang trying to read more than
+ is coming from the server). This means we have to perform EOL
+ translation on the message on our own, this was effectively an
+ unreported bug. also unreported was that the faster code did not
+ do .-unstuffing, which the slower line-by-line code did. This is
+ now fixed too. My thanks to Ashwin Hirschi
+ <deery@users.sourceforge.net> for his help in testing the code.
+
+2001-07-31 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: Updated to reflect pkg version in the code. After
+ the fact comment: This also fixes SF bug [447013]
+
+ * pop3.tcl: Added 'state' variable to remember state information
+ about the active (= open) pop3 connections. This state includes
+ information about the retrieval mode to use and whether we are
+ talking to an MS Exchange server or not. MS Exchange can't be
+ set automatically for now, but the retrieval mode is
+ auto-detected. Because of the former, pop3::open now accepts the
+ options -msex and -retr-mode. This should allay and fix the SF
+ bugs [443613] and [443645].
+
+ (pop3::list): Fixed bug [443619].
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3.tcl: Fixed dubious code reported by frink.
+
+2001-01-24 Scott Redman <redman@tivo.com>
+
+ * pop3.tcl: Fixed a bug when getting the "." back
+ with extra \r by adding a [string trimright $line].
+ Reported by Joe English, [bug: 124477].
+
+2000-09-14 Scott Redman <redman@ajubasolutions.com>
+
+ * pop3.tcl: Based on feedback from Cameron Laird, I did some
+ digging into the RFC and figured out that using the number of
+ octets given by RETR at the beginning of the retrieval to grab
+ that number of bytes was far more efficient. Thanks to Cameron
+ for pointing that out. Speed for retrieval should be greatly
+ improved. Changed version to 1.1.
+
+2000-05-18 Scott Redman <redman@scriptics.com>
+
+ * pop3.tcl:
+ * pop3.n: Applied patch from Petteri Kettunen to add the LIST and
+ TOP implementations. See RFC1939. Also removed a spurious puts
+ command. [bug: 5426]
+
+2000-05-17 Scott Redman <redman@scriptics.com>
+
+ * pop3.tcl: Remove extra '.'s added by the POP3 server. If a
+ line begins with a '.', the server will add a '.' to the line to
+ prevent confusion with the end-of-message character (which is also
+ '.'). [bug: 5522]
+
+2000-03-06 Scott Redman <redman@scriptics.com>
+
+ * ChangeLog:
+ * man.macros:
+ * pkgIndex.tcl:
+ * pop3.n:
+ * pop3.tcl: New POP3 email client API, inspired by Scott
+ Beasley's "frenchie" email client program.
diff --git a/tcllib/modules/pop3/pkgIndex.tcl b/tcllib/modules/pop3/pkgIndex.tcl
new file mode 100644
index 0000000..a104789
--- /dev/null
+++ b/tcllib/modules/pop3/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.4]} {return}
+package ifneeded pop3 1.9 [list source [file join $dir pop3.tcl]]
diff --git a/tcllib/modules/pop3/pop3.man b/tcllib/modules/pop3/pop3.man
new file mode 100644
index 0000000..829fb29
--- /dev/null
+++ b/tcllib/modules/pop3/pop3.man
@@ -0,0 +1,274 @@
+[manpage_begin pop3 n 1.9]
+[keywords email]
+[keywords mail]
+[keywords pop]
+[keywords pop3]
+[keywords {rfc 1939}]
+[keywords secure]
+[keywords ssl]
+[keywords tls]
+[comment {-*- tcl -*- doctools manpage}]
+[moddesc {Tcl POP3 Client Library}]
+[titledesc {Tcl client for POP3 email protocol}]
+[category Networking]
+[require Tcl 8.4]
+[require pop3 [opt 1.9]]
+[description]
+
+The [package pop3] package provides a simple Tcl-only client library
+for the POP3 email protocol as specified in
+[uri http://www.rfc-editor.org/rfc/rfc1939.txt {RFC 1939}].
+
+It works by opening the standard POP3 socket on the server,
+transmitting the username and password, then providing a Tcl API to
+access the POP3 protocol commands. All server errors are returned as
+Tcl errors (thrown) which must be caught with the Tcl [cmd catch]
+command.
+
+[include ../common-text/tls-security-notes.inc]
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::pop3::open] \
+ [opt "[option -msex] 0|1"] \
+ [opt "[option -retr-mode] retr|list|slow"] \
+ [opt "[option -socketcmd] cmdprefix"] \
+ [opt "[option -stls] 0|1"] \
+ [opt "[option -tls-callback] stls-callback-command"] \
+ [arg {host username password}] [opt [arg port]]]
+
+Open a socket connection to the server specified by [arg host],
+transmit the [arg username] and [arg password] as login information to
+the server. The default port number is [const 110], which can be
+overridden using the optional [arg port] argument. The return value
+is a channel used by all of the other ::pop3 functions.
+
+[para]
+
+The command recognizes three options
+
+[list_begin options]
+
+[opt_def -msex boolean]
+
+Setting this option tells the package that the server we are talking
+to is an MS Exchange server (which has some oddities we have to work
+around). The default is [const False].
+
+[opt_def -retr-mode retr|list|slow]
+
+The retrieval mode determines how exactly messages are read from the
+server.
+
+The allowed values are [const retr], [const list] and [const slow].
+The default is [const retr]. See [cmd ::pop3::retrieve] for more
+information.
+
+[opt_def -socketcmd cmdprefix]
+
+This option allows the user to overide the use of the builtin
+[cmd socket] command with any API-compatible command. The envisioned
+main use is the securing of the new connection via SSL, through the
+specification of the command [cmd tls::socket]. This command is
+specially recognized as well, changing the default port of the
+connection to [const 995].
+
+[opt_def -stls boolean]
+
+Setting this option tells the package to secure the connection using
+SSL or TLS. It performs STARTTLS as described in IETF RFC 2595, it
+first opens a normal, unencrypted connection and then negotiates a
+SSLv3 or TLSv1 connection. If the connection cannot be secured, the
+connection will be closed and an error will be returned
+
+[opt_def -tls-callback stls-callback-command]
+
+This option allows the user to overide the [cmd tls::callback] used during
+the [const -stls] SSL/TLS handshake. See the TLS manual for details on how
+to implement this callback.
+
+[list_end]
+
+[call [cmd ::pop3::config] [arg chan]]
+
+Returns the configuration of the pop3 connection identified by the
+channel handle [arg chan] as a serialized array.
+
+[call [cmd ::pop3::status] [arg chan]]
+
+Query the server for the status of the mail spool. The status is
+returned as a list containing two elements, the first is the number of
+email messages on the server and the second is the size (in octets, 8
+bit blocks) of the entire mail spool.
+
+[call [cmd ::pop3::last] [arg chan]]
+
+Query the server for the last email message read from the spool. This
+value includes all messages read from all clients connecting to the
+login account. This command may not be supported by the email server,
+in which case the server may return 0 or an error.
+
+[call [cmd ::pop3::retrieve] [arg {chan startIndex}] [opt [arg endIndex]]]
+
+Retrieve a range of messages from the server. If the [arg endIndex]
+is not specified, only one message will be retrieved. The return
+value is a list containing each message as a separate element. See
+the [arg startIndex] and [arg endIndex] descriptions below.
+
+[para]
+
+The retrieval mode determines how exactly messages are read from the
+server. The mode [const retr] assumes that the RETR command delivers
+the size of the message as part of the command status and uses this to
+read the message efficiently. In mode [const list] RETR does not
+deliver the size, but the LIST command does and we use this to
+retrieve the message size before the actual retrieval, which can then
+be done efficiently. In the last mode, [const slow], the system is
+unable to obtain the size of the message to retrieve in any manner and
+falls back to reading the message from the server line by line.
+
+[para]
+
+It should also be noted that the system checks upon the configured
+mode and falls back to the slower modes if the above assumptions are
+not true.
+
+[call [cmd ::pop3::delete] [arg {chan startIndex}] [opt [arg endIndex]]]
+
+Delete a range of messages from the server. If the [arg endIndex] is
+not specified, only one message will be deleted. Note, the indices
+are not reordered on the server, so if you delete message 1, then the
+first message in the queue is message 2 (message index 1 is no longer
+valid). See the [arg startIndex] and [arg endIndex] descriptions
+below.
+
+[list_begin definitions]
+
+[def [arg startIndex]]
+
+The [arg startIndex] may be an index of a specific message starting
+with the index 1, or it have any of the following values:
+
+[list_begin definitions]
+
+[def [const start]]
+
+This is a logical value for the first message in the spool, equivalent
+to the value 1.
+
+[def [const next]]
+
+The message immediately following the last message read, see
+[cmd ::pop3::last].
+
+[def [const end]]
+
+The most recent message in the spool (the end of the spool). This is
+useful to retrieve only the most recent message.
+
+[list_end]
+
+[def [arg endIndex]]
+
+The [arg endIndex] is an optional parameter and defaults to the value
+"-1", which indicates to only retrieve the one message specified by
+
+[arg startIndex]. If specified, it may be an index of a specific
+message starting with the index "1", or it may have any of the
+following values:
+
+[list_begin definitions]
+
+[def [const last]]
+
+The message is the last message read by a POP3 client, see
+[cmd ::pop3::last].
+
+[def [const end]]
+
+The most recent message in the spool (the end of the spool).
+
+[list_end]
+[list_end]
+
+[call [cmd ::pop3::list] [arg chan] [opt [arg msg]]]
+
+Returns the scan listing of the mailbox. If parameter [arg msg] is
+given, then the listing only for that message is returned.
+
+[call [cmd ::pop3::top] [arg chan] [arg msg] [arg n] ]
+
+Optional POP3 command, not all servers may support this.
+
+[cmd ::pop3::top] retrieves headers of a message, specified by
+parameter [arg msg], and number of [arg n] lines from the message
+body.
+
+[call [cmd ::pop3::uidl] [arg chan] [opt [arg msg]]]
+
+Optional POP3 command, not all servers may support this.
+
+[cmd ::pop3::uidl] returns the uid listing of the mailbox. If the
+parameter [arg msg] is specified, then the listing only for that
+message is returned.
+
+[call [cmd ::pop3::capa] [arg chan]]
+
+Optional POP3 command, not all servers may support this.
+
+[cmd ::pop3::capa] returns a list of the capabilities of the server.
+TOP, SASL, UIDL, LOGIN-DELAY and STLS are typical capabilities.
+
+See IETF RFC 2449.
+
+[call [cmd ::pop3::close] [arg chan]]
+
+Gracefully close the connect after sending a POP3 QUIT command down
+the socket.
+
+[list_end]
+
+[section {Secure mail transfer}]
+
+A pop3 connection can be secured with SSL/TLS by requiring the package
+[package TLS] and then using either the option [option -socketcmd] or
+the option [option -stls] of the command [cmd pop3::open].
+
+The first method, option [option -socketcmd], will force the use
+of the [cmd tls::socket] command when opening the connection. This is
+suitable for POP3 servers which expect SSL connections only. These will
+generally be listening on port 995.
+
+[example {
+ package require tls
+ tls::init -cafile /path/to/ca/cert -keyfile ...
+
+ # Create secured pop3 channel
+ pop3::open -socketcmd tls::socket \\
+ $thehost $theuser $thepassword
+
+ ...
+}]
+
+The second method, option [option -stls], will connect to the standard POP3
+port and then perform an STARTTLS handshake. This will only work for POP3
+servers which have this capability. The package will confirm that the
+server supports STARTTLS and the handshake was performed correctly before
+proceeding with authentication.
+
+[example {
+ package require tls
+ tls::init -cafile /path/to/ca/cert -keyfile ...
+
+ # Create secured pop3 channel
+ pop3::open -stls 1 \\
+ $thehost $theuser $thepassword
+
+ ...
+}]
+
+[vset CATEGORY pop3]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pop3/pop3.tcl b/tcllib/modules/pop3/pop3.tcl
new file mode 100644
index 0000000..1c467e6
--- /dev/null
+++ b/tcllib/modules/pop3/pop3.tcl
@@ -0,0 +1,830 @@
+# pop3.tcl --
+#
+# POP3 mail client package, written in pure Tcl.
+# Some concepts borrowed from "frenchie", a POP3
+# mail client utility written by Scott Beasley.
+#
+# Copyright (c) 2000 by Ajuba Solutions.
+# portions Copyright (c) 2000 by Scott Beasley
+# portions Copyright (c) 2010-2012 Andreas Kupries
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pop3.tcl,v 1.38 2012/01/10 20:02:22 andreas_kupries Exp $
+
+package require Tcl 8.4
+package require cmdline
+package require log
+package provide pop3 1.9
+
+namespace eval ::pop3 {
+
+ # The state variable remembers information about the open pop3
+ # connection. It is indexed by channel id. The information is
+ # a keyed list, with keys "msex" and "retr_mode". The value
+ # associated with "msex" is boolean, a true value signals that the
+ # server at the other end is MS Exchange. The value associated
+ # with "retr_mode" is one of {retr, list, slow}.
+
+ # The value of "msex" influences how the translation for the
+ # channel is set and is determined by the contents of the received
+ # greeting. The value of "retr_mode" is initially "retr" and
+ # completely determined by the first call to [retrieve]. For "list"
+ # the system will use LIST before RETR to retrieve the message size.
+
+ # The state can be influenced by options given to "open".
+
+ variable state
+ array set state {}
+
+}
+
+# ::pop3::config --
+#
+# Retrieve configuration of pop3 connection
+#
+# Arguments:
+# chan The channel, returned by ::pop3::open
+#
+# Results:
+# A serialized array.
+
+proc ::pop3::config {chan} {
+ variable state
+ return $state($chan)
+}
+
+# ::pop3::close --
+#
+# Close the connection to the POP3 server.
+#
+# Arguments:
+# chan The channel, returned by ::pop3::open
+#
+# Results:
+# None.
+
+proc ::pop3::close {chan} {
+ variable state
+ catch {::pop3::send $chan "QUIT"}
+ unset state($chan)
+ ::close $chan
+ return
+}
+
+# ::pop3::delete --
+#
+# Delete messages on the POP3 server.
+#
+# Arguments:
+# chan The channel, returned by ::pop3::open
+# start The first message to delete in the range.
+# May be "next" (the next message after the last
+# one seen, see ::pop3::last), "start" (aka 1),
+# "end" (the last message in the spool, for
+# deleting only the last message).
+# end (optional, defaults to -1) The last message
+# to delete in the range. May be "last"
+# (the last message viewed), "end" (the last
+# message in the spool), or "-1" (the default,
+# any negative number means delete only
+# one message).
+#
+# Results:
+# None.
+# May throw errors from the server.
+
+proc ::pop3::delete {chan start {end -1}} {
+
+ variable state
+ array set cstate $state($chan)
+ set count $cstate(limit)
+ set last 0
+ catch {set last [::pop3::last $chan]}
+
+ if {![string is integer $start]} {
+ if {[string match $start "next"]} {
+ set start $last
+ incr start
+ } elseif {$start == "start"} {
+ set start 1
+ } elseif {$start == "end"} {
+ set start $count
+ } else {
+ error "POP3 Deletion error: Bad start index $start"
+ }
+ }
+ if {$start == 0} {
+ set start 1
+ }
+
+ if {![string is integer $end]} {
+ if {$end == "end"} {
+ set end $count
+ } elseif {$end == "last"} {
+ set end $last
+ } else {
+ error "POP3 Deletion error: Bad end index $end"
+ }
+ } elseif {$end < 0} {
+ set end $start
+ }
+
+ if {$end > $count} {
+ set end $count
+ }
+
+ for {set index $start} {$index <= $end} {incr index} {
+ if {[catch {::pop3::send $chan "DELE $index"} errorStr]} {
+ error "POP3 DELETE ERROR: $errorStr"
+ }
+ }
+ return {}
+}
+
+# ::pop3::last --
+#
+# Gets the index of the last email read from the server.
+# Note, some POP3 servers do not support this feature,
+# in which case the value returned may always be zero,
+# or an error may be thrown.
+#
+# Arguments:
+# chan The channel, returned by ::pop3::open
+#
+# Results:
+# The index of the last email message read, which may
+# be zero if none have been read or if the server does
+# not support this feature.
+# Server errors may be thrown, including some cases
+# when the LAST command is not supported.
+
+proc ::pop3::last {chan} {
+
+ if {[catch {
+ set resultStr [::pop3::send $chan "LAST"]
+ } errorStr]} {
+ error "POP3 LAST ERROR: $errorStr"
+ }
+
+ return [string trim $resultStr]
+}
+
+# ::pop3::list --
+#
+# Returns "scan listing" of the mailbox. If parameter msg
+# is defined, then the listing only for the given message
+# is returned.
+#
+# Arguments:
+# chan The channel open to the POP3 server.
+# msg The message number (optional).
+#
+# Results:
+# If msg parameter is not given, Tcl list of scan listings in
+# the maildrop is returned. In case msg parameter is given,
+# a list of length one containing the specified message listing
+# is returned.
+
+proc ::pop3::list {chan {msg ""}} {
+ global PopErrorNm PopErrorStr debug
+
+ if {$msg == ""} {
+ if {[catch {::pop3::send $chan "LIST"} errorStr]} {
+ error "POP3 LIST ERROR: $errorStr"
+ }
+ set msgBuffer [RetrSlow $chan]
+ } else {
+ # argument msg given, single-line response expected
+
+ if {[catch {expr {0 + $msg}}]} {
+ error "POP3 LIST ERROR: malformed message number '$msg'"
+ } else {
+ set msgBuffer [string trim [::pop3::send $chan "LIST $msg"]]
+ }
+ }
+ return $msgBuffer
+}
+
+# pop3::open --
+#
+# Opens a connection to a POP3 mail server.
+#
+# Arguments:
+# args A list of options and values, possibly empty,
+# followed by the regular arguments, i.e. host, user,
+# passwd and port. The latter is optional.
+#
+# host The name or IP address of the POP3 server host.
+# user The username to use when logging into the server.
+# passwd The password to use when logging into the server.
+# port (optional) The socket port to connect to, defaults
+# to port 110, the POP standard port address.
+#
+# Results:
+# The connection channel (a socket).
+# May throw errors from the server.
+
+proc ::pop3::open {args} {
+ variable state
+ array set cstate {socketcmd ::socket msex 0 retr_mode retr limit {} stls 0 tls-callback {}}
+
+ log::log debug "pop3::open | [join $args]"
+
+ while {[set err [cmdline::getopt args {
+ msex.arg
+ retr-mode.arg
+ socketcmd.arg
+ stls.arg
+ tls-callback.arg
+ } opt arg]]} {
+ if {$err < 0} {
+ return -code error "::pop3::open : $arg"
+ }
+ switch -exact -- $opt {
+ msex {
+ if {![string is boolean $arg]} {
+ return -code error \
+ ":pop3::open : Argument to -msex has to be boolean"
+ }
+ set cstate(msex) $arg
+ }
+ retr-mode {
+ switch -exact -- $arg {
+ retr - list - slow {
+ set cstate(retr_mode) $arg
+ }
+ default {
+ return -code error \
+ ":pop3::open : Argument to -retr-mode has to be one of retr, list or slow"
+ }
+ }
+ }
+ socketcmd {
+ set cstate(socketcmd) $arg
+ }
+ stls {
+ if {![string is boolean $arg]} {
+ return -code error \
+ ":pop3::open : Argument to -tls has to be boolean"
+ }
+ set cstate(stls) $arg
+ }
+ tls-callback {
+ set cstate(tls-callback) $arg
+ }
+ default {
+ # Can't happen
+ }
+ }
+ }
+
+ if {[llength $args] > 4} {
+ return -code error "To many arguments to ::pop3::open"
+ }
+ if {[llength $args] < 3} {
+ return -code error "Not enough arguments to ::pop3::open"
+ }
+ foreach {host user password port} $args break
+ if {$port == {}} {
+ if {([lindex $cstate(socketcmd) 0] eq "tls::socket") ||
+ ([lindex $cstate(socketcmd) 0] eq "::tls::socket")} {
+ # Standard port for SSL-based pop3 connections.
+ set port 995
+ } else {
+ # Standard port for any other type of connection.
+ set port 110
+ }
+ }
+
+ log::log debug "pop3::open | protocol, connect to $host $port"
+
+ # Argument processing is finally complete, now open the channel
+
+ set chan [eval [linsert $cstate(socketcmd) end $host $port]]
+ fconfigure $chan -buffering none
+
+ log::log debug "pop3::open | connect on $chan"
+
+ if {$cstate(msex)} {
+ # We are talking to MS Exchange. Work around its quirks.
+ fconfigure $chan -translation binary
+ } else {
+ fconfigure $chan -translation {binary crlf}
+ }
+
+ log::log debug "pop3::open | wait for greeting"
+
+ if {[catch {::pop3::send $chan {}} errorStr]} {
+ ::close $chan
+ return -code error "POP3 CONNECT ERROR: $errorStr"
+ }
+
+ if {0} {
+ # -FUTURE- Identify MS Exchange servers
+ set cstate(msex) 1
+
+ # We are talking to MS Exchange. Work around its quirks.
+ fconfigure $chan -translation binary
+ }
+
+ if {$cstate(stls)} {
+ log::log debug "pop3::open | negotiating TLS on $chan"
+ if {[catch {
+ set capa [::pop3::capa $chan]
+ log::log debug "pop3::open | Server $chan can $capa"
+ } errorStr]} {
+ close $chan
+ return -code error "POP3 CONNECT/STLS ERROR: $errorStr"
+ }
+
+ if { [lsearch -exact $capa STLS] == -1} {
+ log::log debug "pop3::open | Server $chan can't STLS"
+ close $chan
+ return -code error "POP CONNECT ERROR: STLS requested but not supported by server"
+ }
+ log::log debug "pop3::open | server can TLS on $chan"
+
+ if {[catch {
+ ::pop3::send $chan "STLS"
+ } errorStr]} {
+ close $chan
+ return -code error "POP3 STLS ERROR: $errorStr"
+ }
+
+ package require tls
+
+ log::log debug "pop3::open | tls::import $chan"
+ # Explicitly disable ssl2 and only allow ssl3 and tlsv1. Although the defaults
+ # will work with most servers, ssl2 is really, really old and is deprecated.
+ if {$cstate(tls-callback) ne ""} {
+ set newchan [tls::import $chan -ssl2 0 -ssl3 1 -tls1 1 -cipher SSLv3,TLSv1 -command $cstate(tls-callback)]
+ } else {
+ set newchan [tls::import $chan -ssl2 0 -ssl3 1 -tls1 1 -cipher SSLv3,TLSv1]
+ }
+
+ if {[catch {
+ log::log debug "pop3::open | tls::handshake $chan"
+ tls::handshake $chan
+ } errorStr]} {
+ close $chan
+ return -code error "POP3 CONNECT/TLS HANDSHAKE ERROR: $errorStr"
+ }
+
+ array set security [tls::status $chan]
+ set sbits 0
+ if { [info exists security(sbits)] } {
+ set sbits $security(sbits)
+ }
+ if { $sbits == 0 } {
+ close $chan
+ return -code error "POP3 CONNECT/TLS: TLS Requested but not available"
+ } elseif { $sbits < 128 } {
+ close $chan
+ return -code error "POP3 CONNECT/TLS: TLS Requested but insufficient (<128bits): $sbits"
+ }
+
+ log::log debug "pop3::open | $chan now in $sbits bit TLS mode ($security(cipher))"
+ }
+
+ log::log debug "pop3::open | authenticate $user (*password not shown*)"
+
+ if {[catch {
+ ::pop3::send $chan "USER $user"
+ ::pop3::send $chan "PASS $password"
+ } errorStr]} {
+ ::close $chan
+ return -code error "POP3 LOGIN ERROR: $errorStr"
+ }
+
+ # [ 833486 ] Can't delete messages one at a time ...
+ # Remember the number of messages in the maildrop at the beginning
+ # of the session. This gives us the highest possible number for
+ # message ids later. Note that this number must not be affected
+ # when deleting mails later. While the number of messages drops
+ # down the limit for the message id's stays the same. The messages
+ # are not renumbered before the session actually closed.
+
+ set cstate(limit) [lindex [::pop3::status $chan] 0]
+
+ # Remember the state.
+
+ set state($chan) [array get cstate]
+
+ log::log debug "pop3::open | ok ($chan)"
+ return $chan
+}
+
+# ::pop3::retrieve --
+#
+# Retrieve email message(s) from the server.
+#
+# Arguments:
+# chan The channel, returned by ::pop3::open
+# start The first message to retrieve in the range.
+# May be "next" (the next message after the last
+# one seen, see ::pop3::last), "start" (aka 1),
+# "end" (the last message in the spool, for
+# retrieving only the last message).
+# end (optional, defaults to -1) The last message
+# to retrieve in the range. May be "last"
+# (the last message viewed), "end" (the last
+# message in the spool), or "-1" (the default,
+# any negative number means retrieve only
+# one message).
+#
+# Results:
+# A list containing all of the messages retrieved.
+# May throw errors from the server.
+
+proc ::pop3::retrieve {chan start {end -1}} {
+ variable state
+ array set cstate $state($chan)
+
+ set count $cstate(limit)
+ set last 0
+ catch {set last [::pop3::last $chan]}
+
+ if {![string is integer $start]} {
+ if {[string match $start "next"]} {
+ set start $last
+ incr start
+ } elseif {$start == "start"} {
+ set start 1
+ } elseif {$start == "end"} {
+ set start $count
+ } else {
+ error "POP3 Retrieval error: Bad start index $start"
+ }
+ }
+ if {$start == 0} {
+ set start 1
+ }
+
+ if {![string is integer $end]} {
+ if {$end == "end"} {
+ set end $count
+ } elseif {$end == "last"} {
+ set end $last
+ } else {
+ error "POP3 Retrieval error: Bad end index $end"
+ }
+ } elseif {$end < 0} {
+ set end $start
+ }
+
+ if {$end > $count} {
+ set end $count
+ }
+
+ set result {}
+
+ ::log::log debug "pop3 $chan retrieve $start -- $end"
+
+ for {set index $start} {$index <= $end} {incr index} {
+ switch -exact -- $cstate(retr_mode) {
+ retr {
+ set sizeStr [::pop3::send $chan "RETR $index"]
+
+ ::log::log debug "pop3 $chan retrieve ($sizeStr)"
+
+ if {[scan $sizeStr {%d %s} size dummy] < 1} {
+ # The server did not deliver the size information.
+ # Switch our mode to "list" and use the slow
+ # method this time. The next call will use LIST before
+ # RETR to get the size information. If even that fails
+ # the system will fall back to slow mode all the time.
+
+ ::log::log debug "pop3 $chan retrieve - no size information, go slow"
+
+ set cstate(retr_mode) list
+ set state($chan) [array get cstate]
+
+ # Retrieve in slow motion.
+ set msgBuffer [RetrSlow $chan]
+ } else {
+ ::log::log debug "pop3 $chan retrieve - size information present, use fast mode"
+
+ set msgBuffer [RetrFast $chan $size]
+ }
+ }
+ list {
+ set sizeStr [::pop3::send $chan "LIST $index"]
+
+ if {[scan $sizeStr {%d %d %s} dummy size dummy] < 2} {
+ # Not even LIST generates the necessary size information.
+ # Switch to full slow mode and don't bother anymore.
+
+ set cstate(retr_mode) slow
+ set state($chan) [array get cstate]
+
+ ::pop3::send $chan "RETR $index"
+
+ # Retrieve in slow motion.
+ set msgBuffer [RetrSlow $chan]
+ } else {
+ # Ignore response of RETR, already know the size
+ # through LIST
+
+ ::pop3::send $chan "RETR $index"
+ set msgBuffer [RetrFast $chan $size]
+ }
+ }
+ slow {
+ # Retrieve in slow motion.
+
+ ::pop3::send $chan "RETR $index"
+ set msgBuffer [RetrSlow $chan]
+ }
+ }
+ lappend result $msgBuffer
+ }
+ return $result
+}
+
+# ::pop3::RetrFast --
+#
+# Fast retrieval of a message from the pop3 server.
+# Internal helper to prevent code bloat in "pop3::retrieve"
+#
+# Arguments:
+# chan The channel to read the message from.
+#
+# Results:
+# The text of the retrieved message.
+
+proc ::pop3::RetrFast {chan size} {
+ set msgBuffer [read $chan $size]
+
+ foreach line [split $msgBuffer \n] {
+ ::log::log debug "pop3 $chan fast <$line>"
+ }
+
+ # There is a small discrepance in counting octets we have to be
+ # aware of. 'size' is #octets before transmission, i.e. can be
+ # with one eol character, CR or LF. The channel system in binary
+ # mode counts every character, and the protocol specified CRLF as
+ # eol, so for every line in the message we read that many
+ # characters _less_. Another factor which can cause a miscount is
+ # the ".-stuffing performed by the sender. I.e. what we got now is
+ # not necessarily the complete message. We have to perform slow
+ # reads to get the remainder of the message. This has another
+ # complication. We cannot simply check for a line containing the
+ # terminating signature, simply because the point where the
+ # message was broken in two might just be in between the dots of a
+ # "\r\n..\r\n" sequence. We have to make sure that we do not
+ # misinterpret the second part of this sequence as terminator.
+ # Another possibility: "\r\n.\r\n" is broken just after the dot.
+ # Then we have to ensure to not to miss the terminator entirely.
+
+ # Sometimes the gets returns nothing, need to get the real
+ # terminating "." / "
+
+ if {[string equal [string range $msgBuffer end-3 end] "\n.\r\n"]} {
+ # Complete terminator found. Remove it from the message buffer.
+
+ ::log::log debug "pop3 $chan /5__"
+ set msgBuffer [string range $msgBuffer 0 end-3]
+
+ } elseif {[string equal [string range $msgBuffer end-2 end] "\n.\r"]} {
+ # Complete terminator found. Remove it from the message buffer.
+ # Also perform an empty read to remove the missing '\n' from
+ # the channel. If we don't do this all following commands will
+ # run into off-by-one (character) problems.
+
+ ::log::log debug "pop3 $chan /4__"
+ set msgBuffer [string range $msgBuffer 0 end-2]
+ while {[read $chan 1] != "\n"} {}
+
+ } elseif {[string equal [string range $msgBuffer end-1 end] "\n."]} {
+ # \n. at the end of the fast buffer.
+ # Can be \n.\r\n = Terminator
+ # or \n..\r\n = dot-stuffed single .
+
+ log::log debug "pop3 $chan /check for cut .. or terminator sequence"
+
+ # Idle until non-empty line encountered.
+ while {[set line [gets $chan]] == ""} {}
+ if {"$line" == "\r"} {
+ # Terminator already found. Note that we have to
+ # remove the partial terminator sequence from the
+ # message buffer.
+ ::log::log debug "pop3 $chan /3__ <$line>"
+ set msgBuffer [string range $msgBuffer 0 end-1]
+ } else {
+ # Append line and look for the real terminator
+ append msgBuffer $line
+ ::log::log debug "pop3 $chan ____ <$line>"
+ while {[set line [gets $chan]] != ".\r"} {
+ ::log::log debug "pop3 $chan ____ <$line>"
+ append msgBuffer $line
+ }
+ ::log::log debug "pop3 $chan /2__ <$line>"
+ }
+ } elseif {[string equal [string index $msgBuffer end] \n]} {
+ # Line terminator (\n) found. The remainder of the mail has to
+ # consist of true lines we can read directly.
+
+ while {![string equal [set line [gets $chan]] ".\r"]} {
+ ::log::log debug "pop3 $chan ____ <$line>"
+ append msgBuffer $line
+ }
+ ::log::log debug "pop3 $chan /1__ <$line>"
+ } else {
+ # Incomplete line at the end of the buffer. We complete it in
+ # a single read, and then handle the remainder like the case
+ # before, where we had a complete line at the end of the
+ # buffer.
+
+ set line [gets $chan]
+ ::log::log debug "pop3 $chan /1a_ <$line>"
+ append msgBuffer $line
+
+ ::log::log debug "pop3 $chan /1b_"
+
+ while {![string equal [set line [gets $chan]] ".\r"]} {
+ ::log::log debug "pop3 $chan ____ <$line>"
+ append msgBuffer $line
+ }
+ ::log::log debug "pop3 $chan /1c_ <$line>"
+ }
+
+ ::log::log debug "pop3 $chan done"
+
+ # Map both cr+lf and cr to lf to simulate auto EOL translation, then
+ # unstuff .-stuffed lines.
+
+ return [string map [::list \n.. \n.] [string map [::list \r \n] [string map [::list \r\n \n] $msgBuffer]]]
+}
+
+# ::pop3::RetrSlow --
+#
+# Slow retrieval of a message from the pop3 server.
+# Internal helper to prevent code bloat in "pop3::retrieve"
+#
+# Arguments:
+# chan The channel to read the message from.
+#
+# Results:
+# The text of the retrieved message.
+
+proc ::pop3::RetrSlow {chan} {
+
+ set msgBuffer ""
+
+ while {1} {
+ set line [string trimright [gets $chan] \r]
+ ::log::log debug "pop3 $chan slow $line"
+
+ # End of the message is a line with just "."
+ if {$line == "."} {
+ break
+ } elseif {[string index $line 0] == "."} {
+ set line [string range $line 1 end]
+ }
+
+ append msgBuffer $line "\n"
+ }
+
+ return $msgBuffer
+}
+
+# ::pop3::send --
+#
+# Send a command string to the POP3 server. This is an
+# internal function, but may be used in rare cases.
+#
+# Arguments:
+# chan The channel open to the POP3 server.
+# cmdstring POP3 command string
+#
+# Results:
+# Result string from the POP3 server, except for the +OK tag.
+# Errors from the POP3 server are thrown.
+
+proc ::pop3::send {chan cmdstring} {
+ global PopErrorNm PopErrorStr debug
+
+ if {$cmdstring != {}} {
+ ::log::log debug "pop3 $chan >>> $cmdstring"
+ puts $chan $cmdstring
+ }
+
+ set popRet [string trim [gets $chan]]
+ ::log::log debug "pop3 $chan <<< $popRet"
+
+ if {[string first "+OK" $popRet] == -1} {
+ error [string range $popRet 4 end]
+ }
+
+ return [string range $popRet 3 end]
+}
+
+# ::pop3::status --
+#
+# Get the status of the mail spool on the POP3 server.
+#
+# Arguments:
+# chan The channel, returned by ::pop3::open
+#
+# Results:
+# A list containing two elements, {msgCount octetSize},
+# where msgCount is the number of messages in the spool
+# and octetSize is the size (in octets, or 8 bytes) of
+# the entire spool.
+
+proc ::pop3::status {chan} {
+
+ if {[catch {set statusStr [::pop3::send $chan "STAT"]} errorStr]} {
+ error "POP3 STAT ERROR: $errorStr"
+ }
+
+ # Dig the sent size and count info out.
+ set rawStatus [split [string trim $statusStr]]
+
+ return [::list [lindex $rawStatus 0] [lindex $rawStatus 1]]
+}
+
+# ::pop3::top --
+#
+# Optional POP3 command (see RFC1939). Retrieves message header
+# and given number of lines from the message body.
+#
+# Arguments:
+# chan The channel open to the POP3 server.
+# msg The message number to be retrieved.
+# n Number of lines returned from the message body.
+#
+# Results:
+# Text (with newlines) from the server.
+# Errors from the POP3 server are thrown.
+
+proc ::pop3::top {chan msg n} {
+ global PopErrorNm PopErrorStr debug
+
+ if {[catch {::pop3::send $chan "TOP $msg $n"} errorStr]} {
+ error "POP3 TOP ERROR: $errorStr"
+ }
+
+ return [RetrSlow $chan]
+}
+
+# ::pop3::uidl --
+#
+# Returns "uid listing" of the mailbox. If parameter msg
+# is defined, then the listing only for the given message
+# is returned.
+#
+# Arguments:
+# chan The channel open to the POP3 server.
+# msg The message number (optional).
+#
+# Results:
+# If msg parameter is not given, Tcl list of uid listings in
+# the maildrop is returned. In case msg parameter is given,
+# a list of length one containing the uid of the specified
+# message listing is returned.
+
+proc ::pop3::uidl {chan {msg ""}} {
+ if {$msg == ""} {
+ if {[catch {::pop3::send $chan "UIDL"} errorStr]} {
+ error "POP3 UIDL ERROR: $errorStr"
+ }
+ set msgBuffer [RetrSlow $chan]
+ } else {
+ # argument msg given, single-line response expected
+
+ if {[catch {expr {0 + $msg}}]} {
+ error "POP3 UIDL ERROR: malformed message number '$msg'"
+ } else {
+ set msgBuffer [string trim [::pop3::send $chan "UIDL $msg"]]
+ }
+ }
+
+ return $msgBuffer
+}
+
+# ::pop3::capa --
+#
+# Returns "capabilities" of the server.
+#
+# Arguments:
+# chan The channel open to the POP3 server.
+#
+# Results:
+# A Tcl list with the capabilities of the server.
+# UIDL, TOP, STLS are typical capabilities.
+
+
+proc ::pop3::capa {chan} {
+ global PopErrorNm PopErrorStr debug
+
+ if {[catch {::pop3::send $chan "CAPA"} errorStr]} {
+ error "POP3 CAPA ERROR: $errorStr"
+ }
+ set msgBuffer [string map {\r {}} [RetrSlow $chan]]
+
+ return [split $msgBuffer \n]
+}
+
diff --git a/tcllib/modules/pop3/pop3.test b/tcllib/modules/pop3/pop3.test
new file mode 100644
index 0000000..30b53de
--- /dev/null
+++ b/tcllib/modules/pop3/pop3.test
@@ -0,0 +1,611 @@
+# -*- tcl -*-
+# pop3.test: tests for the pop3 client.
+#
+# 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) 2002-2006 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pop3.test,v 1.31 2012/01/10 20:06:52 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.4
+testsNeedTcltest 1.0
+
+tcltest::testConstraint hastls [expr {![catch {package require tls}]}]
+
+support {
+ #use snit/snit.tcl snit ;# comm futures, not used, still a dependency
+ #use comm/comm.tcl comm
+ use log/log.tcl log
+ useTcllibFile devtools/coserv.tcl ; # loads comm, snit too!
+ useTcllibFile devtools/dialog.tcl
+}
+testing {
+ useLocal pop3.tcl pop3
+}
+
+# -------------------------------------------------------------------------
+# Server processes. Programmed dialogs, server side.
+
+dialog::setup server {Pop3 Fake Server}
+
+# ----------------------------------------------------------------------
+# Dialog scripts for the various servers we start ...
+
+proc init {} {
+ dialog::crlf.
+ dialog::send. {+OK localhost coserv ready <534358773_pop3d1_12380@localhost>}
+}
+proc initBad {} {
+ dialog::crlf.
+ dialog::send. Grumble
+}
+proc loginOk {} {
+ init
+ dialog::respond. {+OK please send PASS command}
+ dialog::respond. {+OK congratulations}
+}
+proc loginStatusOk {} {
+ init
+ dialog::respond. {+OK please send PASS command}
+ dialog::respond. {+OK congratulations}
+ dialog::respond. {+OK 11 176}
+}
+proc loginFailed {} {
+ init
+ dialog::respond. {+OK please send PASS command}
+ dialog::respond. {-ERR authentication failed, sorry}
+}
+proc loginFailedLock {} {
+ init
+ dialog::respond. {+OK please send PASS command}
+ dialog::respond. {-ERR could not aquire lock for maildrop ak}
+}
+proc statusOk {} {
+ loginStatusOk
+ dialog::respond. {+OK 11 176}
+}
+proc statusOkQuit {} {
+ statusOk
+ dialog::respond. {+OK localhost coserv shutting down}
+}
+proc lastFailed {} {
+ loginStatusOk
+ dialog::respond. {-ERR unknown command 'LAST'}
+}
+proc uidlFailed {} {
+ loginStatusOk
+ dialog::respond. {-ERR unknown command 'UIDL'}
+}
+proc retrFailed {} {
+ loginStatusOk
+ dialog::respond. {-ERR unknown command 'LAST'}
+ dialog::respond. {+OK localhost coserv shutting down}
+}
+proc topFailed {} {
+ loginStatusOk
+ dialog::respond. {-ERR no such message}
+ dialog::respond. {+OK localhost coserv shutting down}
+}
+
+set __messageA {MIME-Version: 1.0
+Content-Type: text/plain;
+ charset="us-ascii"
+
+Test ______
+
+.
+
+--
+Done
+}
+
+set __messageB {MIME-Version: 1.0
+Content-Type: text/plain;
+ charset="us-ascii"
+
+Test ______
+
+This line can cause a failure.
+
+--
+Done
+}
+
+set __messageC {MIME-Version: 1.0
+Content-Type: text/plain;
+ charset="us-ascii"
+
+Test ______
+
+This line can cause a failure.
+
+--
+Done
+}
+
+proc message {msg {n {}}} {
+ if {$n == {}} {set n [string length $msg]}
+
+ set lines [split $msg \n]
+ set n [llength $lines]
+
+ foreach l $lines {
+ if {[string match .* $l]} {set l .$l}
+ if {[string length $l] || ($n > 1)} {
+ dialog::send. $l
+ }
+ incr n -1
+ }
+ dialog::send. .
+}
+
+proc retrMessage {list msg {n {}}} {
+ if {$n == {}} {set n [string length $msg]}
+
+ loginOk
+ dialog::respond. "+OK 1 $n"
+ dialog::respond. {-ERR unknown command 'LAST'}
+
+ if {$list} {dialog::respond. "+OK 1 $n"}
+
+ dialog::respond. "+OK $n octets"
+ message $msg $n
+ dialog::respond. {+OK localhost coserv shutting down}
+}
+
+proc topMessage {msg} {
+ loginStatusOk
+ dialog::respond. +OK
+ message $msg
+ dialog::respond. {+OK localhost coserv shutting down}
+}
+
+proc deleDialog {} {
+ loginStatusOk
+ dialog::respond. {+OK 11 176}
+
+ foreach n {1 2 3 4 5 6 7 8 9 10 11} {
+ dialog::respond. {-ERR unknown command 'LAST'}
+ dialog::respond. {+OK 6 octets}
+ dialog::send. {Content-Type: text/plain;}
+ dialog::send. { charset="us-ascii"}
+ dialog::send. {}
+ dialog::send. { }
+ dialog::send. {.}
+ dialog::respond. {-ERR unknown command 'LAST'}
+ dialog::respond. "+OK message $n deleted"
+ }
+ dialog::respond. {+OK localhost coserv shutting down}
+}
+
+proc bgerror {message} {
+ global errorCode errorInfo
+ puts $errorCode
+ puts $errorInfo
+ return
+}
+
+proc peek {chan} {
+ set res {}
+ array set _ [::pop3::config $chan]
+ foreach k [lsort [array names _]] {
+ lappend res $k $_($k)
+ }
+ return $res
+}
+
+# Reduce output generated by the client.
+set disable 1
+::log::lvSuppress info $disable
+::log::lvSuppress notice $disable
+::log::lvSuppress debug $disable
+::log::lvSuppress warning $disable
+
+#tcltest::verbose {pass body error skip}
+
+if 0 {
+ rename test test__
+ proc test {args} {
+ puts "[lindex $args 0] ________________________________________________________________________"
+ return [uplevel test__ $args]
+ }
+}
+
+proc blot {txt sock} {
+ string map [list $sock SOCK] $txt
+}
+
+# ----------------------------------------------------------------------
+# Tests. Operations
+#
+# open, status, delete, cut, open, status |
+# open, status, delete, close |
+#
+# ----------------------------------------------------------------------
+
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+# Handling of 'open' alone.
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+
+test pop3-0.0 {bogus options} {
+ catch {pop3::open -foo bar localhost ak smash 7664} msg
+ set msg
+} {::pop3::open : Illegal option "-foo"}
+
+test pop3-0.1 {bogus options} {
+ catch {pop3::open -msex bar localhost ak smash 2534} msg
+ set msg
+} {:pop3::open : Argument to -msex has to be boolean}
+
+test pop3-0.2 {bogus options} {
+ catch {pop3::open -retr-mode bar localhost ak smash 54345} msg
+ set msg
+} {:pop3::open : Argument to -retr-mode has to be one of retr, list or slow}
+
+test pop3-0.3 {not enough arguments} {
+ catch {pop3::open localhost ak} msg
+ set msg
+} {Not enough arguments to ::pop3::open}
+
+test pop3-0.4 {too many arguments} {
+ catch {pop3::open localhost ak smash 432490 dribble} msg
+ set msg
+} {To many arguments to ::pop3::open}
+
+test pop3-0.5 {connect to missing server} {
+ catch {pop3::open localhost foo foo 1111} msg
+ string match {couldn't open socket: *} $msg
+} 1
+
+test pop3-0.6 {wrong type of server (fake)} {
+ dialog::dialog_set initBad
+ catch {pop3::open localhost foo foo [dialog::listener]} msg
+ dialog::waitdone
+ regsub {^([^:]*:).*$} $msg {\1} msg
+ set msg
+} {POP3 CONNECT ERROR:}
+
+test pop3-0.7 {unknown user} {
+ dialog::dialog_set loginFailed
+ catch {pop3::open localhost usrX *** [dialog::listener]} msg
+ dialog::waitdone
+ set msg
+} {POP3 LOGIN ERROR: authentication failed, sorry}
+
+test pop3-0.8 {open pop3 channel} {
+ dialog::dialog_set loginStatusOk
+ set psock [pop3::open localhost ak smash [dialog::listener]]
+ close $psock
+ dialog::waitdone
+ set msg [string match sock* $psock]
+ # status data is retained if the connection is not closed through
+ # the prescribed api command.
+ lappend msg [peek $psock]
+ set msg
+} {1 {limit 11 msex 0 retr_mode retr socketcmd ::socket stls 0 tls-callback {}}}
+
+test pop3-0.9 {outside close} {
+ dialog::dialog_set loginStatusOk
+ set psock [pop3::open localhost ak smash [dialog::listener]]
+ close $psock
+ catch {pop3::close $psock} msg
+ dialog::waitdone
+ blot $msg $psock
+} {can not find channel named "SOCK"}
+
+test pop3-0.10 {multiple open pop3 channel to same maildrop} {
+ dialog::dialog_set loginFailedLock
+ catch {pop3::open localhost ak smash [dialog::listener]} msg
+ dialog::waitdone
+ set msg
+} {POP3 LOGIN ERROR: could not aquire lock for maildrop ak}
+
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+# Handling of 'status'.
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+
+test pop3-1.0 {status after cut} {
+ dialog::dialog_set loginStatusOk
+ set psock [pop3::open localhost ak smash [dialog::listener]]
+ close $psock
+ catch {pop3::status $psock} msg
+ dialog::waitdone
+ blot $msg $psock
+} {POP3 STAT ERROR: can not find channel named "SOCK"}
+
+test pop3-1.1 {status after close} {
+ dialog::dialog_set loginStatusOk
+ set psock [pop3::open localhost ak smash [dialog::listener]]
+ pop3::close $psock
+ catch {pop3::status $psock} msg
+ dialog::waitdone
+ blot $msg $psock
+} {POP3 STAT ERROR: can not find channel named "SOCK"}
+
+test pop3-1.2 {status ok} {
+ dialog::dialog_set statusOkQuit
+ set psock [pop3::open localhost ak smash [dialog::listener]]
+ set status [pop3::status $psock]
+ lappend status [peek $psock]
+ pop3::close $psock
+ dialog::waitdone
+ set status
+} {11 176 {limit 11 msex 0 retr_mode retr socketcmd ::socket stls 0 tls-callback {}}}
+
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+# Handling of 'retrieve'.
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+
+test pop3-2.0 {retrieve, no arguments} {
+ catch {pop3::retrieve} msg
+ set msg
+} [tcltest::wrongNumArgs "pop3::retrieve" "chan start ?end?" 0]
+
+test pop3-2.1 {retrieve, not enough arguments} {
+ catch {pop3::retrieve sock5} msg
+ set msg
+} [tcltest::wrongNumArgs "pop3::retrieve" "chan start ?end?" 1]
+
+test pop3-2.2 {retrieve, too many arguments} {
+ catch {pop3::retrieve sock5 foo bar fox} msg
+ set msg
+} [tcltest::tooManyArgs "pop3::retrieve" "chan start ?end?"]
+
+test pop3-2.3 {retrieve without valid channel} {
+ catch {pop3::retrieve sock5 foo bar} msg
+ set msg
+} {can't read "state(sock5)": no such element in array}
+
+test pop3-2.4 {retrieve, invalid start} {
+ dialog::dialog_set retrFailed
+ set psock [pop3::open localhost ak smash [dialog::listener]]
+ catch {pop3::retrieve $psock foo bar} msg
+ pop3::close $psock
+ list $msg [join [dialog::waitdone] \n]
+} {{POP3 Retrieval error: Bad start index foo} {crlf
+>> {+OK localhost coserv ready <534358773_pop3d1_12380@localhost>}
+<< {USER ak}
+>> {+OK please send PASS command}
+<< {PASS smash}
+>> {+OK congratulations}
+<< STAT
+>> {+OK 11 176}
+<< LAST
+>> {-ERR unknown command 'LAST'}
+<< QUIT
+>> {+OK localhost coserv shutting down}
+empty}}
+
+test pop3-2.5 {retrieve, invalid end} {
+ dialog::dialog_set retrFailed
+ set psock [pop3::open localhost ak smash [dialog::listener]]
+ catch {pop3::retrieve $psock 0 bar} msg
+ pop3::close $psock
+ list $msg [join [dialog::waitdone] \n]
+} {{POP3 Retrieval error: Bad end index bar} {crlf
+>> {+OK localhost coserv ready <534358773_pop3d1_12380@localhost>}
+<< {USER ak}
+>> {+OK please send PASS command}
+<< {PASS smash}
+>> {+OK congratulations}
+<< STAT
+>> {+OK 11 176}
+<< LAST
+>> {-ERR unknown command 'LAST'}
+<< QUIT
+>> {+OK localhost coserv shutting down}
+empty}}
+
+set msg {MIME-Version: 1.0
+Content-Type: text/plain;
+ charset="us-ascii"
+
+
+}
+
+foreach {n mode len listflag} {
+ 0 retr {} 0
+ 1 list {} 1
+ 2 slow {} 0
+ 3 retr 98 0
+ 4 retr 114 0
+ 5 retr 0 0
+ 6 retr 1 0
+ 7 retr 97 0
+ 8 retr 113 0
+ 9 retr 99 0
+ 10 retr 115 0
+ 11 retr 116 0
+} {
+ test pop3-2.6.$n "retrieval, $mode $len" {
+ dialog::dialog_set {retrMessage $listflag $__messageA $len}
+ set psock [pop3::open -retr-mode $mode localhost ak smash [dialog::listener]]
+ set res [pop3::retrieve $psock 1]
+ pop3::close $psock
+ dialog::waitdone
+ set res
+ } [list $__messageA] ; # {}
+}
+
+# Note: 2.7 == 2.6.3 | Separate test cases to make clear that they
+# Note: 2.8 == 2.6.4 | there created to check for a bug report.
+
+test pop3-2.7 {fast retrieval, .-stuff border break, #528928} {
+ dialog::dialog_set {retrMessage 0 $__messageA 98}
+ set psock [pop3::open -retr-mode retr localhost ak smash [dialog::listener]]
+ set res [pop3::retrieve $psock 1]
+ pop3::close $psock
+ dialog::waitdone
+ set res
+} [list $__messageA]
+
+
+test pop3-2.8 {fast retrieval, .-stuff border break, #528928} {
+ dialog::dialog_set {retrMessage 0 $__messageA 114}
+ set psock [pop3::open -retr-mode retr localhost ak smash [dialog::listener]]
+ set res [pop3::retrieve $psock 1]
+ pop3::close $psock
+ dialog::waitdone
+ set res
+} [list $__messageA]
+
+test pop3-2.9 {fast retrieval, .-stuff border break} {
+ dialog::dialog_set {retrMessage 0 $__messageB 126}
+ set psock [pop3::open -retr-mode retr localhost ak smash [dialog::listener]]
+ set res [pop3::retrieve $psock 1]
+ pop3::close $psock
+ dialog::waitdone
+ set res
+} [list $__messageB]
+
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+# Handling of 'top'.
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+
+test pop3-3.0 {top, no arguments} {
+ catch {pop3::top} msg
+ set msg
+} [tcltest::wrongNumArgs "pop3::top" "chan msg n" 0]
+
+test pop3-3.1 {top, not enough arguments} {
+ catch {pop3::top sock5} msg
+ set msg
+} [tcltest::wrongNumArgs "pop3::top" "chan msg n" 1]
+
+test pop3-3.2 {top, too many arguments} {
+ catch {pop3::top sock5 foo bar fox} msg
+ set msg
+} [tcltest::tooManyArgs "pop3::top" "chan msg n"]
+
+test pop3-3.3 {top without valid channel} {
+ catch {pop3::top sockXXX foo bar} msg
+ set msg
+} {POP3 TOP ERROR: can not find channel named "sockXXX"}
+
+test pop3-3.4 {top, invalid message id} {
+ dialog::dialog_set topFailed
+ set psock [pop3::open localhost ak smash [dialog::listener]]
+ catch {pop3::top $psock foo bar} msg
+ pop3::close $psock
+ dialog::waitdone
+ set msg
+} {POP3 TOP ERROR: no such message}
+
+set msg {MIME-Version: 1.0
+Content-Type: text/plain;
+ charset="us-ascii"
+
+}
+
+test pop3-3.5 {top} {
+ dialog::dialog_set {topMessage $__messageA}
+ set psock [pop3::open localhost ak smash [dialog::listener]]
+ set res [pop3::top $psock 1 1]
+ pop3::close $psock
+ dialog::waitdone
+ set res
+} $__messageA
+
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+# Handling of 'delete'
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+
+
+test pop3-5.0 {get and delete all message, nano-client} {
+ set res ""
+ dialog::dialog_set deleDialog
+ set psock [pop3::open -retr-mode slow localhost ak smash [dialog::listener]]
+ set x [lindex [pop3::status $psock] 0]
+ lappend res $x
+ for {set i 0 } {$i < $x} {incr i} {
+ set j [expr {$i + 1}]
+ set msg [pop3::retrieve $psock $j]
+ lappend res [string length $msg]
+ pop3::delete $psock $j
+ }
+ pop3::close $psock
+
+ set n 3
+ foreach t [dialog::waitdone] {
+ if {![string match "<<*" $t]} {continue}
+ # Ignore commands from the login interaction.
+ if {$n} {incr n -1 ; continue}
+ lappend res [lindex $t 1]
+ }
+ set res
+} {11 67 67 67 67 67 67 67 67 67 67 67 STAT LAST {RETR 1} LAST {DELE 1} LAST {RETR 2} LAST {DELE 2} LAST {RETR 3} LAST {DELE 3} LAST {RETR 4} LAST {DELE 4} LAST {RETR 5} LAST {DELE 5} LAST {RETR 6} LAST {DELE 6} LAST {RETR 7} LAST {DELE 7} LAST {RETR 8} LAST {DELE 8} LAST {RETR 9} LAST {DELE 9} LAST {RETR 10} LAST {DELE 10} LAST {RETR 11} LAST {DELE 11} QUIT}
+
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+# Handling of 'last', 'uidl'.
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+
+## None. The server used here (tcllib/pop3d)
+## does not support the 'LAST' command, nor 'UIDL'.
+
+test pop3-6.0 {last} {
+ dialog::dialog_set lastFailed
+ set psock [pop3::open localhost ak smash [dialog::listener]]
+ catch {pop3::last $psock} msg
+ pop3::close $psock
+ dialog::waitdone
+ set msg
+} {POP3 LAST ERROR: unknown command 'LAST'}
+
+test pop3-6.1 {uidl} {
+ dialog::dialog_set uidlFailed
+ set psock [pop3::open localhost ak smash [dialog::listener]]
+ catch {pop3::uidl $psock} msg
+ pop3::close $psock
+ dialog::waitdone
+ set msg
+} {POP3 UIDL ERROR: unknown command 'UIDL'}
+
+test pop3-7.0 {open pop3 channel secured via package tls} hastls {
+ dialog::shutdown
+ dialog::setup server {Pop3 Fake Server} 1
+
+ tls::init \
+ -keyfile [tcllibPath devtools/receiver.key] \
+ -certfile [tcllibPath devtools/receiver.crt] \
+ -cafile [tcllibPath devtools/ca.crt] \
+ -ssl2 1 \
+ -ssl3 1 \
+ -tls1 0 \
+ -require 1
+
+ dialog::dialog_set loginStatusOk
+ set psock [pop3::open -socketcmd tls::socket localhost ak smash [dialog::listener]]
+ close $psock
+ dialog::waitdone
+ set msg [string match sock* $psock]
+ # status data is retained if the connection is not closed through
+ # the prescribed api command.
+ lappend msg [peek $psock]
+ set msg
+} {1 {limit 11 msex 0 retr_mode retr socketcmd tls::socket stls 0 tls-callback {}}}
+
+# ----------------------------------------------------------------------
+# ----------------------------------------------------------------------
+dialog::shutdown
+testsuiteCleanup
diff --git a/tcllib/modules/pop3d/ChangeLog b/tcllib/modules/pop3d/ChangeLog
new file mode 100644
index 0000000..0b9e58e
--- /dev/null
+++ b/tcllib/modules/pop3d/ChangeLog
@@ -0,0 +1,335 @@
+2013-03-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.man: Added references to the relevant RFCs 1939 and 2449.
+ * rfc1939.txt: Removed copies of RFC documents. Keep only links.
+ * rfc2449.txt:
+
+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-11-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.test: Another update to accept both 127.x.x.x and ::1 as
+ possible result. The OS configuration may cause return of the
+ former even for 8.6+.
+
+2011-11-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.test: Updated the tests to handle Tcl 8.6+ IPv6 changes.
+
+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 ========================
+ *
+
+2009-09-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.test: Fixed typos in expected results, the socket command
+ comes back fully qualified.
+
+2009-04-14 Andreas Kupries <andreask@activestate.com>
+
+ * pop3d.man: Updated documentation with example on how to use the
+ option -socket to secure the server channel with TLS.
+ * pop3d.tcl: Fixed typos in comments.
+
+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-08-02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.test: Updated to prevent the multiple loading of comm.
+
+2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.man: Fixed all warnings due to use of now deprecated
+ * pop3d_dbox.man: commands. Added a section about how to give feedback.
+ * pop3d_udb.man:
+
+2006-10-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.test: Accept anything matching 127.*.*.* as ip-address for
+ localhost.
+
+2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.9 ========================
+ *
+
+2006-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * pop3d.test: Fixed the tests requiring tcltest 2.x syntax,
+ despite our declaration that tcltest 1.0 is acceptable. This
+ broke 8.2/8.3, and the missing shutdown of the fake client
+ processes then hung the testsuite at the end.
+
+2006-01-28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.test: .... Fixed usage of temp. files by testsuite. Fixed
+ * pop3d_dbox.test: use of duplicate test names.
+ * pop3d_udb.test:
+
+2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.test: More boilerplate simplified via use of test support.
+ * pop3d_dbox.test:
+ * pop3d_udb.test:
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.test: Hooked into the new common test support code.
+ * pop3d_dbox.test:
+ * pop3d_udb.test:
+
+2006-01-10 Andreas Kupries <andreask@activestate.com>
+
+ * pop3d.test: Fixed [SF Tcllib Bug 1316057]. Uncluttering test
+ output.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-09-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: Fixed version inconsistency.
+
+2005-09-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.tcl (H_capa): Replaced 8.4isms (operator eq) with usage of
+ 'string equal'. The module is for 8.3+.
+
+2005-07-07 Reinhard Max <max@suse.de>
+
+ * pop3d.test: Using wildcards in some expected results so that
+ they don't need adjustments every time the version number is
+ bumped. Added tests for CAPA.
+
+ * pop3d.tcl: Added basic support for the CAPA command as specified
+ in RFC2449. Cleaned up and optimized pop3d::Transfer.
+
+ * pop3d.man: Added documentation for [autCmd exists].
+
+ * rfc2449.txt: New file: "POP3 Extension Mechanism".
+
+2005-07-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.man: Bumped version number to 1.1.0.
+
+2005-07-06 Reinhard Max <max@suse.de>
+
+ * pop3d.tcl: Added a -socket option to server objects, so that
+ * pop3d.man: e.g. SSL sockets from the tls extension can be
+ * pop3d.test: used. Bumped version number to 1.1.0.
+
+2004-10-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.test: Made verbosity easier to switch, and log output a
+ bit more readable.
+
+ * pop3d.tcl: Made prefix strings of log output consistent.
+
+2004-10-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.test: Rewritten to use the new facilities for programmed
+ interaction and sub processes.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-08-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d_dbox.test: Fixed problems with usage of md5, now
+ * pop3d.test: switchable between v1 and v2.
+ * pop3d.tcl:
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: Both pop3d and dbox rely on 'mime', which requires
+ * pop3d.man: Tcl 8.3. This implies that these packages require
+ * pop3d_dbox.man: Tcl 8.3 as well, and not 8.2, as advertised.
+
+ * pop3d.tcl: Requiring v1 of md5 explicitly.
+
+ * pop3d.test: Explicitly loading the supporting packages
+ * pop3d_dbox.test: (mime, md5, dbox, udb, ...). Ensured usage of
+ md5 v1. Excluding the whole series of tests if the interpreter
+ is not at least 8.3. Added suppression of logger output.
+
+2003-10-21 Andreas Kupries <andreask@activestate.com>
+
+ * pop3d.tcl (H_quit): Remember the handle of the idle event we are
+ scheduling. This event can be passed by by an eof on the
+ channel. (CloseConnection): Kill a pending idle event, it was
+ passed by and is not relevant anymore. [Bug 650977].
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-05-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.test: Added propagation of auto_path so that
+ sub-processes are able to find additional packages even if
+ tcllib is not installed.
+
+2003-04-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.test: Updated to new version number.
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * pop3d.tcl:
+ * pop3d.man:
+ * pop3d_dbox.tcl:
+ * pop3d_dbox.man:
+ * pop3d_udb.tcl:
+ * pop3d_udbx.man:
+ * pkgIndex.tcl: Set version of the package 'pop3d' to to
+ 1.0.1. 'dbox' is now at version 1.1. 'udb' is now at version
+ 1.0.1.
+
+2003-04-09 Andreas Kupries <andreask@activestate.com>
+
+ * pop3d.tcl: A bit more logging of internals.
+
+2003-04-02 Andreas Kupries <andreask@activestate.com>
+
+ * pop3d_dbox.tcl: Started to add log output.
+
+ * pop3d.tcl: Added "."-stuffing. Not done by mime, out of scope,
+ has to be done by the transport, i.e. the pop3 demon. Also
+ removed the transmission of superfluous newline at end of the
+ message.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.man: More semantic markup, less visual one.
+ * pop3d_dbox.man:
+ * pop3d_udb.man:
+
+2002-09-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.tcl (Transfer): Use a single dot to write the
+ terminator. Not \n.\n. Puts does the terminating \n, and
+ buildmessage/copymessage the other. Brought the client out of
+ sync after a retrieval because of an empty line after the
+ terminator line of the multi-line response.
+
+2002-08-31 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * Note aside: The pop3 server may understate the size of a message
+ and of the maildrop. This happens as the package 'mime' we use
+ to transfer a message may add additional headers not present in
+ the original message (For example Mime-Version and/or
+ Content-Type).
+
+ * pop3d.tcl (::pop3d::Transfer): Fixed oversight in my usage of
+ 'mime::copymessage'. This command copies a mime message to a
+ channel, but does not know about the framing protocol. In other
+ words, it does not write the singular dot closing a pop3 data
+ transfer. We have to do this in the calling routine. Added such
+ a piece of code. Fixed problem with distinguishing RETR and TOP
+ modes, wrong conditional.
+
+ * pop3d.test:
+ * pop3d.tcl (CheckLogin): Now additionally retrieves size of
+ maildrop after querying the number of waiting messages.
+ (H_stat): Returns size of maildrop as second result of
+ STAT. Bugfix, pop3d was not rfc 1939 compliant with respect to
+ STAT, and now is. This problem was found while working on the
+ testsuite for the pop3 package (Result of pop3::stat was
+ bogus). Updated the testsuite.
+
+ * pop3d_dbox.tcl:
+ * pop3d_dbox.man: method 'size' no accepts a call without message
+ id and returns the total size of the mail drop for that
+ case. Reason for the change: see above.
+
+2002-06-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.test: Modified testsuite courtesy Gerald Lester
+ <gwlester@users.sourceforge.net> for better execution of the
+ subshells under windows.
+
+2002-05-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d.test:
+ * pop3d.man:
+ * pop3d_dbox.tcl: Split port into configured port and true
+ port. This allows the usage of port "0" to force auto-selection
+ of a free port. Documented the special behaviour of
+ -port. Created testsuite for pop3 server. Tcllib #532216.
+
+2002-05-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pop3d_dbox.man:
+ * pop3d_dbox.tcl:
+ * pop3d_dbox.test: New method [destroy]. Extended
+ documentation. Clarified interaction lock/remove and interaction
+ lock/stat/(size/get/dele). Added checks of message ids in size,
+ get, dele. Added general check of define base directory to all
+ methods. Added testsuite. Bugfixes. Tcllib #532216.
+
+ * pop3d_udb.man:
+ * pop3d_udb.tcl:
+ * pop3d_udb.test: Documented [destroy]. Fixed documentation of
+ [lookup], refered to non-existing method [do]. Added [destroy]
+ method. Added test suite. Tcllib #532216.
+
+2002-03-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module. Pop3 server, and associated objects for simple user
+ and mailbox management. No testsuite yet. Testsuite will be
+ written in conjunction with testsuite for pop3 module.
diff --git a/tcllib/modules/pop3d/pkgIndex.tcl b/tcllib/modules/pop3d/pkgIndex.tcl
new file mode 100644
index 0000000..034143a
--- /dev/null
+++ b/tcllib/modules/pop3d/pkgIndex.tcl
@@ -0,0 +1,16 @@
+# 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.2]} {return}
+package ifneeded pop3d::udb 1.1 [list source [file join $dir pop3d_udb.tcl]]
+
+if {![package vsatisfies [package provide Tcl] 8.3]} {return}
+package ifneeded pop3d 1.1.0 [list source [file join $dir pop3d.tcl]]
+package ifneeded pop3d::dbox 1.0.2 [list source [file join $dir pop3d_dbox.tcl]]
diff --git a/tcllib/modules/pop3d/pop3d.man b/tcllib/modules/pop3d/pop3d.man
new file mode 100644
index 0000000..4336437
--- /dev/null
+++ b/tcllib/modules/pop3d/pop3d.man
@@ -0,0 +1,273 @@
+[comment {-*- tcl -*-}]
+[manpage_begin pop3d n 1.1.0]
+[keywords internet]
+[keywords network]
+[keywords pop3]
+[keywords protocol]
+[keywords {rfc 1939}]
+[keywords secure]
+[keywords ssl]
+[keywords tls]
+[copyright {2002-2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[copyright {2005 Reinhard Max <max@suse.de>}]
+[moddesc {Tcl POP3 Server Package}]
+[titledesc {Tcl POP3 server implementation}]
+[category Networking]
+[require Tcl 8.3]
+[require pop3d [opt 1.1.0]]
+[description]
+[para]
+
+[list_begin definitions]
+
+[call [cmd ::pop3d::new] [opt [arg serverName]]]
+
+This command creates a new server object with an associated global Tcl
+command whose name is [arg serverName].
+
+[list_end]
+
+The command [cmd serverName] may be used to invoke various operations
+on the server. It has the following general form:
+
+[list_begin definitions]
+[call [cmd serverName] [arg option] [opt [arg "arg arg ..."]]]
+
+[arg Option] and the [arg arg]s determine the exact behavior of the
+command.
+
+[list_end]
+
+[para]
+
+A pop3 server can be started on any port the caller has permission for
+from the operating system. The default port will be 110, which is the
+port defined by the standard specified in
+RFC 1939 ([uri http://www.rfc-editor.org/rfc/rfc1939.txt]).
+
+After creating, configuring and starting a the server object will
+listen for and accept connections on that port and handle them
+according to the POP3 protocol.
+
+[para]
+
+[emph Note:] The server provided by this module will handle only the
+basic protocol by itself. For the higher levels of user authentication
+and handling of the actual mailbox contents callbacks will be invoked.
+
+[para]
+
+The following commands are possible for server objects:
+
+[list_begin definitions]
+
+[call [arg serverName] [method up]]
+
+After this call the server will listen for connections on its configured port.
+
+[call [arg serverName] [method down]]
+
+After this call the server will stop listening for connections. This
+does not affect existing connections.
+
+[call [arg serverName] [method destroy] [opt [arg mode]]]
+
+Destroys the server object. Currently open connections are handled
+depending on the chosen mode.
+
+The provided [arg mode]s are:
+
+[list_begin definitions]
+
+[def [const kill]]
+
+Destroys the server immediately, and forcefully closes all currently
+open connections. This is the default mode.
+
+[def [const defer]]
+
+Stops the server from accepting new connections and will actually
+destroy it only after the last of the currently open connections for
+the server is closed.
+
+[list_end]
+
+[call [arg serverName] [method configure]]
+
+Returns a list containing all options and their current values in a
+format suitable for use by the command [cmd {array set}]. The options
+themselves are described in section [sectref Options].
+
+[call [arg serverName] [method configure] [arg -option]]
+
+Returns the current value of the specified option. This is an alias
+for the method [method cget]. The options themselves are described in
+section [sectref Options].
+
+[call [arg serverName] [method configure] [arg {-option value}]...]
+
+Sets the specified option to the provided value. The options
+themselves are described in section [sectref Options].
+
+[call [arg serverName] [method cget] [arg -option]]
+
+Returns the current value of the specified option. The options
+themselves are described in section [sectref Options].
+
+[call [arg serverName] [method conn] list]
+
+Returns a list containing the ids of all connections currently open.
+
+[call [arg serverName] [method conn] state [arg id]]
+
+Returns a list suitable for [lb][cmd {array set}][rb] containing the
+state of the connection referenced by [arg id].
+
+[list_end]
+
+[section Options]
+
+The following options are available to pop3 server objects.
+
+[list_begin definitions]
+
+[def "[option -port] [arg port]"]
+
+Defines the [arg port] to listen on for new connections. Default is
+110. This option is a bit special. If [arg port] is set to "0" the
+server, or rather the operating system, will select a free port on its
+own. When querying [option -port] the id of this chosen port will be
+returned. Changing the port while the server is up will neither change
+the returned value, nor will it change on which port the server is
+listening on. Only after resetting the server via a call to
+
+[method down] followed by a call to [method up] will the new port take
+effect. It is at that time that the value returned when querying
+[option -port] will change too.
+
+[def "[option -auth] [arg command]"]
+
+Defines a [arg command] prefix to call whenever the authentication of
+a user is required. If no such command is specified the server will
+reject all users. The interface which has to be provided by the
+command prefix is described in section [sectref Authentication].
+
+[def "[option -storage] [arg command]"]
+
+Defines a [arg command] prefix to call whenever the handling of
+mailbox contents is required. If no such command is specified the
+server will claim that all mailboxes are empty. The interface which
+has to be provided by the command prefix is described in section
+[sectref Mailboxes].
+
+[def "[option -socket] [arg command]"]
+
+Defines a [arg command] prefix to call for opening the listening socket.
+This can be used to make the pop3 server listen on a SSL socket
+as provided by the [package tls] package, see the command [cmd tls::socket].
+
+[list_end]
+
+[section Authentication]
+
+Here we describe the interface which has to be provided by the
+authentication callback so that pop3 servers following the interface
+of this module are able to use it.
+
+[list_begin definitions]
+
+[call [arg authCmd] [method exists] [arg name]]
+
+This method is given a user[arg name] and has to return a boolean
+value telling whether or not the specified user exists.
+
+[call [arg authCmd] [method lookup] [arg name]]
+
+This method is given a user[arg name] and has to return a two-element
+list containing the password for this user and a storage reference, in
+this order.
+
+[para]
+
+The storage reference is passed unchanged to the storage callback, see
+sections [sectref Options] and [sectref Mailboxes] for either the
+option defining it and or the interface to provide, respectively.
+
+[list_end]
+
+[section Mailboxes]
+
+Here we describe the interface which has to be provided by the storage
+callback so that pop3 servers following the interface of this module
+are able to use it. The [arg mbox] argument is the storage reference
+as returned by the [method lookup] method of the authentication
+command, see section [sectref Authentication].
+
+[list_begin definitions]
+
+[call [arg storageCmd] [method dele] [arg mbox] [arg msgList]]]
+
+Deletes the messages whose numeric ids are contained in the
+[arg msgList] from the mailbox specified via [arg mbox].
+
+[call [arg storageCmd] [method lock] [arg mbox]]
+
+This method locks the specified mailbox for use by a single connection
+to the server. This is necessary to prevent havoc if several
+connections to the same mailbox are open. The complementary method is
+[method unlock]. The command will return true if the lock could be set
+successfully or false if not.
+
+[call [arg storageCmd] [method unlock] [arg mbox]]
+
+This is the complementary method to [method lock], it revokes the lock
+on the specified mailbox.
+
+[call [arg storageCmd] [method size] [arg mbox] [opt [arg msgId]]]
+
+Determines the size of the message specified through its id in
+[arg msgId], in bytes, and returns this number. The command will
+return the size of the whole maildrop if no message id was specified.
+
+[call [arg storageCmd] [method stat] [arg mbox]]
+
+Determines the number of messages in the specified mailbox and returns
+this number.
+
+[call [arg storageCmd] [method get] [arg mbox] [arg msgId]]
+
+Returns a handle for the specified message. This handle is a mime
+token following the interface described in the documentation of
+package [package mime]. The pop3 server will use the functionality of
+the mime token to send the mail to the requestor at the other end of a
+pop3 connection.
+
+[list_end]
+
+[section {Secure mail transfer}]
+
+The option [option -socket] (see [sectref Options]) enables users of
+the package to override how the server opens its listening socket.
+
+The envisioned main use is the specification of the [cmd tls::socket]
+command, see package [package tls], to secure the communication.
+
+[example {
+ package require tls
+ tls::init \\
+ ...
+
+ pop3d::new S -socket tls::socket
+ ...
+}]
+
+[section References]
+
+[list_begin enumerated]
+[enum] [uri http://www.rfc-editor.org/rfc/rfc1939.txt {RFC 1939}]
+[enum] [uri http://www.rfc-editor.org/rfc/rfc2449.txt {RFC 2449}]
+[list_end]
+
+[vset CATEGORY pop3d]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pop3d/pop3d.tcl b/tcllib/modules/pop3d/pop3d.tcl
new file mode 100644
index 0000000..fe67150
--- /dev/null
+++ b/tcllib/modules/pop3d/pop3d.tcl
@@ -0,0 +1,1147 @@
+# pop3d.tcl --
+#
+# Implementation of a pop3 server for Tcl.
+#
+# Copyright (c) 2002-2009 by Andreas Kupries
+# Copyright (c) 2005 by Reinhard Max (-socket option)
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require md5 ; # tcllib | APOP
+package require mime ; # tcllib | storage callback
+package require log ; # tcllib | tracing
+
+package provide pop3d 1.1.0
+
+namespace eval ::pop3d {
+ # Data storage in the pop3d module
+ # -------------------------------
+ #
+ # There's a number of bits to keep track of for each server and
+ # connection managed by it.
+ #
+ # port
+ # callbacks
+ # connections
+ # connection state
+ # server state
+ #
+ # It would quickly become unwieldy to try to keep these in arrays or lists
+ # within the pop3d namespace itself. Instead, each pop3 server will
+ # get its own namespace. Each namespace contains:
+ #
+ # port - port to listen on
+ # sock - listening socket
+ # authCmd - authentication callback
+ # storCmd - storage callback
+ # sockCmd - command prefix for opening the server socket
+ # state - state of the server (up, down, exiting)
+ # conn - map : sock -> state array
+ # counter - counter for state arrays
+ #
+ # Per connection in a server its own state array 'connXXX'.
+ #
+ # id - unique id for the connection (APOP)
+ # state - state of connection (auth, trans, update, fail)
+ # name - user for that connection
+ # storage - storage ref for that user
+ # logon - authentication method (empty, apop, user)
+ # deleted - list of deleted messages
+ # msg - number of messages in storage
+ # remotehost - name of remote host for connection
+ # remoteport - remote port for connection
+
+ # counter is used to give a unique name for unnamed server
+ variable counter 0
+
+ # commands is the list of subcommands recognized by the server
+ variable commands [list \
+ "cget" \
+ "configure" \
+ "destroy" \
+ "down" \
+ "up" \
+ ]
+
+ variable version [package present pop3d]
+ variable server "tcllib/pop3d-$version"
+
+ variable cmdMap ; array set cmdMap {
+ CAPA H_capa
+ USER H_user
+ PASS H_pass
+ APOP H_apop
+ STAT H_stat
+ DELE H_dele
+ RETR H_retr
+ TOP H_top
+ QUIT H_quit
+ NOOP H_noop
+ RSET H_rset
+ LIST H_list
+ }
+
+ # Capabilities to be reported by the CAPA command. The list
+ # contains pairs of capability strings and the connection state in
+ # which they are reported. The state can be "auth", "trans", or
+ # "both".
+ variable capabilities \
+ [list \
+ USER both \
+ PIPELINING both \
+ "IMPLEMENTATION $server" trans \
+ ]
+
+ # -- UIDL -- not implemented --
+
+ # Only export one command, the one used to instantiate a new server
+ namespace export new
+}
+
+# ::pop3d::new --
+#
+# Create a new pop3 server with a given name; if no name is given, use
+# pop3dX, where X is a number.
+#
+# Arguments:
+# name name of the pop3 server; if null, generate one.
+#
+# Results:
+# name name of the pop3 server created
+
+proc ::pop3d::new {{name ""}} {
+ variable counter
+
+ if { [llength [info level 0]] == 1 } {
+ incr counter
+ set name "pop3d${counter}"
+ }
+
+ if { ![string equal [info commands ::$name] ""] } {
+ return -code error "command \"$name\" already exists, unable to create pop3 server"
+ }
+
+ # Set up the namespace
+ namespace eval ::pop3d::pop3d::$name {
+ variable port 110
+ variable trueport 110
+ variable sock {}
+ variable sockCmd ::socket
+ variable authCmd {}
+ variable storCmd {}
+ variable state down
+ variable conn ; array set conn {}
+ variable counter 0
+ }
+
+ # Create the command to manipulate the pop3 server
+ interp alias {} ::$name {} ::pop3d::Pop3dProc $name
+
+ return $name
+}
+
+##########################
+# Private functions follow
+
+# ::pop3d::Pop3dProc --
+#
+# Command that processes all pop3 server object commands.
+#
+# Arguments:
+# name name of the pop3 server object to manipulate.
+# args command name and args for the command
+#
+# Results:
+# Varies based on command to perform
+
+proc ::pop3d::Pop3dProc {name {cmd ""} args} {
+ # Do minimal args checks here
+ if { [llength [info level 0]] == 2 } {
+ return -code error "wrong # args: should be \"$name option ?arg arg ...?\""
+ }
+
+ # Split the args into command and args components
+ if { [llength [info commands ::pop3d::_$cmd]] == 0 } {
+ variable commands
+ set optlist [join $commands ", "]
+ set optlist [linsert $optlist "end-1" "or"]
+ return -code error "bad option \"$cmd\": must be $optlist"
+ }
+ eval [list ::pop3d::_$cmd $name] $args
+}
+
+# ::pop3d::_up --
+#
+# Start listening on the configured port.
+#
+# Arguments:
+# name name of the pop3 server.
+#
+# Results:
+# None.
+
+proc ::pop3d::_up {name} {
+ upvar ::pop3d::pop3d::${name}::port port
+ upvar ::pop3d::pop3d::${name}::trueport trueport
+ upvar ::pop3d::pop3d::${name}::state state
+ upvar ::pop3d::pop3d::${name}::sockCmd sockCmd
+ upvar ::pop3d::pop3d::${name}::sock sock
+
+ log::log debug "pop3d $name up"
+ if {[string equal $state up]} {return}
+
+ log::log debug "pop3d $name listening, requested port $port"
+
+ set cmd $sockCmd
+ lappend cmd -server [list ::pop3d::HandleNewConnection $name] $port
+ #puts $cmd
+ set s [eval $cmd]
+ set trueport [lindex [fconfigure $s -sockname] 2]
+
+ ::log::log debug "pop3d $name listening on $trueport, socket $s ([fconfigure $s -sockname])"
+
+ set state up
+ set sock $s
+ return
+}
+
+# ::pop3d::_down --
+#
+# Stop listening on the configured port.
+#
+# Arguments:
+# name name of the pop3 server.
+#
+# Results:
+# None.
+
+proc ::pop3d::_down {name} {
+ upvar ::pop3d::pop3d::${name}::state state
+ upvar ::pop3d::pop3d::${name}::sock sock
+ upvar ::pop3d::pop3d::${name}::trueport trueport
+ upvar ::pop3d::pop3d::${name}::port port
+
+ # Ignore if server is down or exiting
+ if {![string equal $state up]} {return}
+
+ close $sock
+ set state down
+ set sock {}
+
+ set trueport $port
+ return
+}
+
+# ::pop3d::_destroy --
+#
+# Destroy a pop3 server.
+#
+# Arguments:
+# name name of the pop3 server.
+# mode destruction mode
+#
+# Results:
+# None.
+
+proc ::pop3d::_destroy {name {mode kill}} {
+ upvar ::pop3d::pop3d::${name}::conn conn
+
+ switch -exact -- $mode {
+ kill {
+ _down $name
+ foreach c [array names conn] {
+ CloseConnection $name $c
+ }
+
+ namespace delete ::pop3d::pop3d::$name
+ interp alias {} ::$name {}
+ }
+ defer {
+ if {[array size conn] > 0} {
+ upvar ::pop3d::pop3d::${name}::state state
+
+ _down $name
+ set state exiting
+ return
+ }
+ _destroy $name kill
+ return
+ }
+ default {
+ return -code error \
+ "Illegal destruction mode \"$mode\":\
+ Expected \"kill\", or \"defer\""
+ }
+ }
+ return
+}
+
+# ::pop3d::_cget --
+#
+# Query option value
+#
+# Arguments:
+# name name of the pop3 server.
+#
+# Results:
+# None.
+
+proc ::pop3d::_cget {name anoption} {
+ switch -exact -- $anoption {
+ -state {
+ upvar ::pop3d::pop3d::${name}::state state
+ return $state
+ }
+ -port {
+ upvar ::pop3d::pop3d::${name}::trueport trueport
+ return $trueport
+ }
+ -auth {
+ upvar ::pop3d::pop3d::${name}::authCmd authCmd
+ return $authCmd
+ }
+ -storage {
+ upvar ::pop3d::pop3d::${name}::storCmd storCmd
+ return $storCmd
+ }
+ -socket {
+ upvar ::pop3d::pop3d::${name}::sockCmd sockCmd
+ return $sockCmd
+ }
+ default {
+ return -code error \
+ "Unknown option \"$anoption\":\
+ Expected \"-state\", \"-port\", \"-auth\", \"-socket\", or \"-storage\""
+ }
+ }
+ # return - in all branches
+}
+
+# ::pop3d::_configure --
+#
+# Query and set option values
+#
+# Arguments:
+# name name of the pop3 server.
+# args options and option values
+#
+# Results:
+# None.
+
+proc ::pop3d::_configure {name args} {
+ set argc [llength $args]
+ if {($argc > 1) && (($argc % 2) == 1)} {
+ return -code error \
+ "wrong # args, expected: -option | (-option value)..."
+ }
+ if {$argc == 1} {
+ return [_cget $name [lindex $args 0]]
+ }
+
+ upvar ::pop3d::pop3d::${name}::trueport trueport
+ upvar ::pop3d::pop3d::${name}::port port
+ upvar ::pop3d::pop3d::${name}::authCmd authCmd
+ upvar ::pop3d::pop3d::${name}::storCmd storCmd
+ upvar ::pop3d::pop3d::${name}::sockCmd sockCmd
+ upvar ::pop3d::pop3d::${name}::state state
+
+ if {$argc == 0} {
+ # Return the full configuration.
+ return [list \
+ -port $trueport \
+ -auth $authCmd \
+ -storage $storCmd \
+ -socket $sockCmd \
+ -state $state \
+ ]
+ }
+
+ while {[llength $args] > 0} {
+ set option [lindex $args 0]
+ set value [lindex $args 1]
+ switch -exact -- $option {
+ -auth {set authCmd $value}
+ -storage {set storCmd $value}
+ -socket {set sockCmd $value}
+ -port {
+ set port $value
+
+ # Propagate to the queried value if the server is down
+ # and thus has no real true port.
+
+ if {[string equal $state down]} {
+ set trueport $value
+ }
+ }
+ -state {
+ return -code error "Option -state is read-only"
+ }
+ default {
+ return -code error \
+ "Unknown option \"$option\":\
+ Expected \"-port\", \"-auth\", \"-socket\", or \"-storage\""
+ }
+ }
+ set args [lrange $args 2 end]
+ }
+ return ""
+}
+
+
+# ::pop3d::_conn --
+#
+# Query connection state.
+#
+# Arguments:
+# name name of the pop3 server.
+# cmd subcommand to perform
+# args arguments for subcommand
+#
+# Results:
+# Specific to subcommand
+
+proc ::pop3d::_conn {name cmd args} {
+ upvar ::pop3d::pop3d::${name}::conn conn
+ switch -exact -- $cmd {
+ list {
+ if {[llength $args] > 0} {
+ return -code error "wrong # args: should be \"$name conn list\""
+ }
+ return [array names conn]
+ }
+ state {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be \"$name conn state connId\""
+ }
+ set sock [lindex $args 0]
+ upvar $conn($sock) cstate
+ return [array get cstate]
+ }
+ default {
+ return -code error "bad option \"$cmd\": must be list, or state"
+ }
+ }
+}
+
+##########################
+##########################
+# Server implementation.
+
+proc ::pop3d::HandleNewConnection {name sock rHost rPort} {
+ upvar ::pop3d::pop3d::${name}::conn conn
+ upvar ::pop3d::pop3d::${name}::counter counter
+
+ set csa ::pop3d::pop3d::${name}::conn[incr counter]
+ set conn($sock) $csa
+ upvar $csa cstate
+
+ set cstate(remotehost) $rHost
+ set cstate(remoteport) $rPort
+ set cstate(server) $name
+ set cstate(id) "<[string map {- {}} [clock clicks]]_${name}_[pid]@[::info hostname]>"
+ set cstate(state) "auth"
+ set cstate(name) ""
+ set cstate(logon) ""
+ set cstate(storage) ""
+ set cstate(deleted) ""
+ set cstate(msg) 0
+ set cstate(size) 0
+
+ ::log::log notice "pop3d $name $sock state auth, waiting for logon"
+
+ fconfigure $sock -buffering line -translation crlf -blocking 0
+
+ if {[catch {::pop3d::GreetPeer $name $sock} errmsg]} {
+ close $sock
+ log::log error "pop3d $name $sock greeting $errmsg"
+ unset cstate
+ unset conn($sock)
+ return
+ }
+
+ fileevent $sock readable [list ::pop3d::HandleCommand $name $sock]
+ return
+}
+
+proc ::pop3d::CloseConnection {name sock} {
+ upvar ::pop3d::pop3d::${name}::storCmd storCmd
+ upvar ::pop3d::pop3d::${name}::state state
+ upvar ::pop3d::pop3d::${name}::conn conn
+
+ upvar $conn($sock) cstate
+
+ # Kill a pending idle event for CloseConnection, we are closing now.
+ catch {after cancel $cstate(idlepending)}
+
+ ::log::log debug "pop3d $name $sock closing connection"
+
+ if {[catch {close $sock} msg]} {
+ ::log::log error "pop3d $name $sock close: $msg"
+ }
+ if {$storCmd != {}} {
+ # remove possible lock set in storage facility.
+ if {[catch {
+ uplevel #0 [linsert $storCmd end unlock $cstate(storage)]
+ } msg]} {
+ ::log::log error "pop3d $name $sock storage unlock: $msg"
+ # -W- future ? kill all connections, execute clean up of storage
+ # -W- facility.
+ }
+ }
+
+ unset cstate
+ unset conn($sock)
+
+ ::log::log notice "pop3d $name $sock closed"
+
+ if {[string equal $state existing] && ([array size conn] == 0)} {
+ _destroy $name
+ }
+ return
+}
+
+proc ::pop3d::HandleCommand {name sock} {
+ # @c Called by the event system after arrival of a new command for
+ # @c connection.
+
+ # @a sock: Direct access to the channel representing the connection.
+
+ # Client closed connection, bye bye
+ if {[eof $sock]} {
+ CloseConnection $name $sock
+ return
+ }
+
+ # line was incomplete, wait for more
+ if {[gets $sock line] < 0} {
+ return
+ }
+
+ upvar ::pop3d::pop3d::${name}::conn conn
+ upvar $conn($sock) cstate
+ variable cmdMap
+
+ ::log::log info "pop3d $name $sock < $line"
+
+ set fail [catch {
+ set cmd [string toupper [lindex $line 0]]
+
+ if {![::info exists cmdMap($cmd)]} {
+ # unknown command, use unknown handler
+
+ HandleUnknownCmd $name $sock $cmd $line
+ } else {
+ $cmdMap($cmd) $name $sock $cmd $line
+ }
+ } errmsg] ;#{}
+
+ if {$fail} {
+ # Had an error during handling of 'cmd'.
+ # Handled by closing the connection.
+ # (We do not know how to relay the internal error to the client)
+
+ ::log::log error "pop3d $name $sock $cmd: $errmsg"
+ CloseConnection $name $sock
+ }
+ return
+}
+
+proc ::pop3d::GreetPeer {name sock} {
+ # @c Called after the initialization of a new connection. Writes the
+ # @c greeting to the new client. Overides the baseclass definition
+ # @c (<m server:GreetPeer>).
+ #
+ # @a conn: Descriptor of connection to write to.
+
+ upvar cstate cstate
+ variable server
+
+ log::log debug "pop3d $name $sock _ Greeting"
+
+ Respond2Client $name $sock +OK \
+ "[::info hostname] $server ready $cstate(id)"
+ return
+}
+
+proc ::pop3d::HandleUnknownCmd {name sock cmd line} {
+ Respond2Client $name $sock -ERR "unknown command '$cmd'"
+ return
+}
+
+proc ::pop3d::Respond2Client {name sock ok wtext} {
+ ::log::log info "pop3d $name $sock > $ok $wtext"
+ puts $sock "$ok $wtext"
+ return
+}
+
+##########################
+##########################
+# Command implementations.
+
+proc ::pop3d::H_capa {name sock cmd line} {
+ # @c Handle CAPA command.
+
+ # Capabilities should better be configurable and handled per
+ # server object, so that e.g. USER/PASS authentication can be
+ # turned off.
+
+ upvar cstate cstate
+ variable capabilities
+
+ Respond2Client $name $sock +OK "Capability list follows"
+ foreach {capability state} $capabilities {
+ if {
+ [string equal $state "both"] ||
+ [string equal $state $cstate(state)]
+ } {
+ puts $sock $capability
+ }
+ }
+ puts $sock .
+ return
+}
+
+proc ::pop3d::H_user {name sock cmd line} {
+ # @c Handle USER command.
+ #
+ # @a conn: Descriptor of connection to write to.
+ # @a cmd: The sent command
+ # @a line: The sent line, with <a cmd> as first word.
+
+ # Called only in places where cstate is known!
+ upvar cstate cstate
+
+ if {[string equal $cstate(logon) apop]} {
+ Respond2Client $name $sock -ERR "login mechanism APOP was chosen"
+ } elseif {[string equal $cstate(state) trans]} {
+ Respond2Client $name $sock -ERR "client already authenticated"
+ } else {
+ # The user name is the first argument to the command
+
+ set cstate(name) [lindex [split $line] 1]
+ set cstate(logon) user
+
+ Respond2Client $name $sock +OK "please send PASS command"
+ }
+ return
+}
+
+
+proc ::pop3d::H_pass {name sock cmd line} {
+ # @c Handle PASS command.
+ #
+ # @a conn: Descriptor of connection to write to.
+ # @a cmd: The sent command
+ # @a line: The sent line, with <a cmd> as first word.
+
+ # Called only in places where cstate is known!
+ upvar cstate cstate
+
+ if {[string equal $cstate(logon) apop]} {
+ Respond2Client $name $sock -ERR "login mechanism APOP was chosen"
+ } elseif {[string equal $cstate(state) trans]} {
+ Respond2Client $name $sock -ERR "client already authenticated"
+ } else {
+ upvar ::pop3d::pop3d::${name}::authCmd authCmd
+
+ if {$authCmd == {}} {
+ # No authentication is possible. Reject all users.
+ CheckLogin $name $sock "" "" ""
+ return
+ }
+
+ # The password is given as the first argument of the command
+
+ set pwd [lindex [split $line] 1]
+
+ if {![uplevel #0 [linsert $authCmd end exists $cstate(name)]]} {
+ ::log::log warning "pop3d $name $sock $authCmd lookup $cstate(name) : user does not exist"
+ CheckLogin $name $sock "" "" ""
+ return
+ }
+ if {[catch {
+ set info [uplevel #0 [linsert $authCmd end lookup $cstate(name)]]
+ } msg]} {
+ ::log::log error "pop3d $name $sock $authCmd lookup $cstate(name) : $msg"
+ CheckLogin $name $sock "" "" ""
+ return
+ }
+ CheckLogin $name $sock $pwd [lindex $info 0] [lindex $info 1]
+ }
+ return
+}
+
+
+proc ::pop3d::H_apop {name sock cmd line} {
+ # @c Handle APOP command.
+ #
+ # @a conn: Descriptor of connection to write to.
+ # @a cmd: The sent command
+ # @a line: The sent line, with <a cmd> as first word.
+
+ # Called only in places where cstate is known!
+ upvar cstate cstate
+
+ if {[string equal $cstate(logon) user]} {
+ Respond2Client $name $sock -ERR "login mechanism USER/PASS was chosen"
+ return
+ } elseif {[string equal $cstate(state) trans]} {
+ Respond2Client $name $sock -ERR "client already authenticated"
+ return
+ }
+
+ # The first two arguments to the command are user name and its
+ # response to the challenge set by the server.
+
+ set cstate(name) [lindex $line 1]
+ set cstate(logon) apop
+
+ upvar ::pop3d::pop3d::${name}::authCmd authCmd
+
+ #log::log debug "authCmd|$authCmd|"
+
+ if {$authCmd == {}} {
+ # No authentication is possible. Reject all users.
+ CheckLogin $name $sock "" "" ""
+ return
+ }
+
+ set digest [lindex $line 2]
+
+ if {![uplevel #0 [linsert $authCmd end exists $cstate(name)]]} {
+ ::log::log warning "pop3d $name $sock $authCmd lookup $cstate(name) : user does not exist"
+ CheckLogin $name $sock "" "" ""
+ return
+ }
+ if {[catch {
+ set info [uplevel #0 [linsert $authCmd end lookup $cstate(name)]]
+ } msg]} {
+ ::log::log error "pop3d $name $sock $authCmd lookup $cstate(name) : $msg"
+ CheckLogin $name $sock "" "" ""
+ return
+ }
+
+ set pwd [lindex $info 0]
+ set storage [lindex $info 1]
+
+ ::log::log debug "pop3d $name $sock info = <$info>"
+
+ if {$storage == {}} {
+ # user does not exist, skip over digest computation
+ CheckLogin $name $sock "" "" $storage
+ return
+ }
+
+ # Do the same algorithm as the client to generate a digest, then
+ # compare our data with information sent by the client. As we are
+ # using tcl 8.x there is need to use channels, an immediate
+ # computation is possible.
+
+ set ourDigest [Md5 "$cstate(id)$pwd"]
+
+ ::log::log debug "pop3d $name $sock digest input <$cstate(id)$pwd>"
+ ::log::log debug "pop3d $name $sock digest outpt <$ourDigest>"
+ ::log::log debug "pop3d $name $sock digest given <$digest>"
+
+ CheckLogin $name $sock $digest $ourDigest $storage
+ return
+}
+
+
+proc ::pop3d::H_stat {name sock cmd line} {
+ # @c Handle STAT command.
+ #
+ # @a conn: Descriptor of connection to write to.
+ # @a cmd: The sent command
+ # @a line: The sent line, with <a cmd> as first word.
+
+ # Called only in places where cstate is known!
+ upvar cstate cstate
+
+ if {[string equal $cstate(state) auth]} {
+ Respond2Client $name $sock -ERR "client not authenticated"
+ } else {
+ # Return number of messages waiting and size of the contents
+ # of the chosen maildrop in octects.
+ Respond2Client $name $sock +OK "$cstate(msg) $cstate(size)"
+ }
+
+ return
+}
+
+
+proc ::pop3d::H_dele {name sock cmd line} {
+ # @c Handle DELE command.
+ #
+ # @a conn: Descriptor of connection to write to.
+ # @a cmd: The sent command
+ # @a line: The sent line, with <a cmd> as first word.
+
+ # Called only in places where cstate is known!
+ upvar cstate cstate
+
+ if {[string equal $cstate(state) auth]} {
+ Respond2Client $name $sock -ERR "client not authenticated"
+ return
+ }
+
+ set msgid [lindex $line 1]
+
+ if {
+ ($msgid < 1) ||
+ ($msgid > $cstate(msg)) ||
+ ([lsearch $msgid $cstate(deleted)] >= 0)
+ } {
+ Respond2Client $name $sock -ERR "no such message"
+ } else {
+ lappend cstate(deleted) $msgid
+ Respond2Client $name $sock +OK "message $msgid deleted"
+ }
+ return
+}
+
+
+proc ::pop3d::H_retr {name sock cmd line} {
+ # @c Handle RETR command.
+ #
+ # @a conn: Descriptor of connection to write to.
+ # @a cmd: The sent command
+ # @a line: The sent line, with <a cmd> as first word.
+
+ # Called only in places where cstate is known!
+ upvar cstate cstate
+
+ if {[string equal $cstate(state) auth]} {
+ Respond2Client $name $sock -ERR "client not authenticated"
+ return
+ }
+
+ set msgid [lindex $line 1]
+
+ if {
+ ($msgid > $cstate(msg)) ||
+ ([lsearch $msgid $cstate(deleted)] >= 0)
+ } {
+ Respond2Client $name $sock -ERR "no such message"
+ } else {
+ Transfer $name $sock $msgid
+ }
+ return
+}
+
+
+proc ::pop3d::H_top {name sock cmd line} {
+ # @c Handle RETR command.
+ #
+ # @a conn: Descriptor of connection to write to.
+ # @a cmd: The sent command
+ # @a line: The sent line, with <a cmd> as first word.
+
+ # Called only in places where cstate is known!
+ upvar cstate cstate
+
+ if {[string equal $cstate(state) auth]} {
+ Respond2Client $name $sock -ERR "client not authenticated"
+ return
+ }
+
+ set msgid [lindex $line 1]
+ set nlines [lindex $line 2]
+
+ if {
+ ($msgid > $cstate(msg)) ||
+ ([lsearch $msgid $cstate(deleted)] >= 0)
+ } {
+ Respond2Client $name $sock -ERR "no such message"
+ } elseif {$nlines == {}} {
+ Respond2Client $name $sock -ERR "missing argument: #lines to read"
+ } elseif {$nlines < 0} {
+ Respond2Client $name $sock -ERR \
+ "number of lines has to be greater than or equal to zero."
+ } elseif {$nlines == 0} {
+ # nlines == 0, no limit, same as H_retr
+ Transfer $name $sock $msgid
+ } else {
+ # nlines > 0
+ Transfer $name $sock $msgid $nlines
+ }
+ return
+}
+
+
+proc ::pop3d::H_quit {name sock cmd line} {
+ # @c Handle QUIT command.
+ #
+ # @a conn: Descriptor of connection to write to.
+ # @a cmd: The sent command
+ # @a line: The sent line, with <a cmd> as first word.
+
+ # Called only in places where cstate is known!
+ upvar cstate cstate
+ variable server
+
+ set cstate(state) update
+
+ if {$cstate(deleted) != {}} {
+ upvar ::pop3d::pop3d::${name}::storCmd storCmd
+ if {$storCmd != {}} {
+ uplevel #0 [linsert $storCmd end \
+ dele $cstate(storage) $cstate(deleted)]
+ }
+ }
+
+ set cstate(idlepending) [after idle [list ::pop3d::CloseConnection $name $sock]]
+
+ Respond2Client $name $sock +OK \
+ "[::info hostname] $server shutting down"
+ return
+}
+
+
+proc ::pop3d::H_noop {name sock cmd line} {
+ # @c Handle NOOP command.
+ #
+ # @a conn: Descriptor of connection to write to.
+ # @a cmd: The sent command
+ # @a line: The sent line, with <a cmd> as first word.
+
+ # Called only in places where cstate is known!
+ upvar cstate cstate
+
+ if {[string equal $cstate(state) fail]} {
+ Respond2Client $name $sock -ERR "login failed, no actions possible"
+ } elseif {[string equal $cstate(state) auth]} {
+ Respond2Client $name $sock -ERR "client not authenticated"
+ } else {
+ Respond2Client $name $sock +OK ""
+ }
+ return
+}
+
+
+proc ::pop3d::H_rset {name sock cmd line} {
+ # @c Handle RSET command.
+ #
+ # @a conn: Descriptor of connection to write to.
+ # @a cmd: The sent command
+ # @a line: The sent line, with <a cmd> as first word.
+
+ # Called only in places where cstate is known!
+ upvar cstate cstate
+
+ if {[string equal $cstate(state) fail]} {
+ Respond2Client $name $sock -ERR "login failed, no actions possible"
+ } elseif {[string equal $cstate(state) auth]} {
+ Respond2Client $name $sock -ERR "client not authenticated"
+ } else {
+ set cstate(deleted) ""
+
+ Respond2Client $name $sock +OK "$cstate(msg) messages waiting"
+ }
+ return
+}
+
+
+proc ::pop3d::H_list {name sock cmd line} {
+ # @c Handle LIST command. Generates scan listing
+ #
+ # @a conn: Descriptor of connection to write to.
+ # @a cmd: The sent command
+ # @a line: The sent line, with <a cmd> as first word.
+
+ # Called only in places where cstate is known!
+ upvar cstate cstate
+
+ if {[string equal $cstate(state) fail]} {
+ Respond2Client $name $sock -ERR "login failed, no actions possible"
+ return
+ } elseif {[string equal $cstate(state) auth]} {
+ Respond2Client $name $sock -ERR "client not authenticated"
+ return
+ }
+
+ set msgid [lindex $line 1]
+
+ upvar ::pop3d::pop3d::${name}::storCmd storCmd
+
+ if {$msgid == {}} {
+ # full listing
+ Respond2Client $name $sock +OK "$cstate(msg) messages"
+
+ set n $cstate(msg)
+
+ for {set i 1} {$i <= $n} {incr i} {
+ Respond2Client $name $sock $i \
+ [uplevel #0 [linsert $storCmd end \
+ size $cstate(storage) $i]]
+ }
+ puts $sock "."
+
+ } else {
+ # listing for specified message
+
+ if {
+ ($msgid < 1) ||
+ ($msgid > $cstate(msg)) ||
+ ([lsearch $msgid $cstate(deleted)] >= 0)
+ } {
+ Respond2Client $name $sock -ERR "no such message"
+ return
+ }
+
+ Respond2Client $name $sock +OK \
+ "$msgid [uplevel #0 [linsert $storCmd end \
+ size $cstate(storage) $msgid]]"
+ return
+ }
+}
+
+##########################
+##########################
+# Command helper commands.
+
+proc ::pop3d::CheckLogin {name sock clientid serverid storage} {
+ # @c Internal procedure. General code used by USER/PASS and
+ # @c APOP login mechanisms to verify the given user-id.
+ # @c Locks the mailbox in case of a match.
+ #
+ # @a conn: Descriptor of connection to write to.
+ # @a clientid: Authentication code transmitted by client
+ # @a serverid: Authentication code calculated here.
+ # @a storage: Handle of mailbox requested by client.
+
+ #log::log debug "CheckLogin|$name|$sock|$clientid|$serverid|$storage|"
+
+ upvar cstate cstate
+ upvar ::pop3d::pop3d::${name}::storCmd storCmd
+
+ set noStorage [expr {$storCmd == {}}]
+
+ if {$storage == {}} {
+ # The user given by the client has no storage, therefore it does
+ # not exist. React as if wrong password was given.
+
+ set cstate(state) auth
+ set cstate(logon) ""
+
+ ::log::log notice "pop3d $name $sock state auth, no maildrop"
+ Respond2Client $name $sock -ERR "authentication failed, sorry"
+
+ } elseif {[string compare $clientid $serverid] != 0} {
+ # password/digest given by client dos not match
+
+ set cstate(state) auth
+ set cstate(logon) ""
+
+ ::log::log notice "pop3d $name $sock state auth, secret does not match"
+ Respond2Client $name $sock -ERR "authentication failed, sorry"
+
+ } elseif {
+ !$noStorage &&
+ ! [uplevel #0 [linsert $storCmd end lock $storage]]
+ } {
+ # maildrop is locked already (by someone else).
+
+ set cstate(state) auth
+ set cstate(logon) ""
+
+ ::log::log notice "pop3d $name $sock state auth, maildrop already locked"
+ Respond2Client $name $sock -ERR \
+ "could not aquire lock for maildrop $cstate(name)"
+ } else {
+ # everything went fine. allow to proceed in session.
+
+ set cstate(storage) $storage
+ set cstate(state) trans
+ set cstate(logon) ""
+
+ set cstate(msg) 0
+ if {!$noStorage} {
+ set cstate(msg) [uplevel #0 [linsert $storCmd end \
+ stat $cstate(storage)]]
+ set cstate(size) [uplevel #0 [linsert $storCmd end \
+ size $cstate(storage)]]
+ }
+
+ ::log::log notice \
+ "pop3d $name $sock login $cstate(name) $storage $cstate(msg)"
+ ::log::log notice "pop3d $name $sock state trans"
+
+ Respond2Client $name $sock +OK "congratulations"
+ }
+ return
+}
+
+proc ::pop3d::Transfer {name sock msgid {limit -1}} {
+ # We ask the storage for the mime token of the mail and use
+ # that to generate and copy the mail to the requestor.
+
+ upvar cstate cstate
+ upvar ::pop3d::pop3d::${name}::storCmd storCmd
+
+ if {$limit < 0} {
+ Respond2Client $name $sock +OK \
+ "[uplevel #0 [linsert $storCmd end \
+ size $cstate(storage) $msgid]] octets"
+ } else {
+ Respond2Client $name $sock +OK ""
+ }
+
+ set token [uplevel #0 [linsert $storCmd end get $cstate(storage) $msgid]]
+
+ ::log::log debug "pop3d $name $sock transfering data ($token)"
+
+ if {$limit < 0} {
+ # Full transfer, we can use "copymessage" and avoid
+ # construction in memory (depending on source of token).
+
+ log::log debug "pop3d $name Transfer $msgid /full"
+
+ # We do "."-stuffing here. This is not in the scope of the
+ # MIME library we use, but a transport dependent thing.
+
+ set msg [string trimright [string map [list "\n." "\n.."] \
+ [mime::buildmessage $token]] \n]
+ log::log debug "($msg)"
+ puts $sock $msg
+ puts $sock .
+
+ } else {
+ # As long as FR #531541 is not implemented we have to build
+ # the entire message in memory and then cut it down to the
+ # requested size. If limit was greater than the number of
+ # lines in the message we will get the terminating "."
+ # too. Using regsub we make sure that it is not present and
+ # reattach during the transfer. Otherwise we would have to use
+ # a regexp/if combo to decide wether to attach the terminator
+ # not.
+
+ set msg [split [mime::buildmessage $token] \n]
+ set i 0
+ incr limit -1
+ while {[lindex $msg $i] != {}} {
+ incr i
+ incr limit
+ }
+ # i now refers to the line separating header and body
+
+ regsub -- "\n\\.\n$" [string map [list "\n." "\n.."] [join [lrange $msg 0 $limit] \n]] {} data
+ puts $sock ${data}\n.
+ }
+ ::log::log debug "pop3d $name $sock transfer complete"
+ # response already sent.
+ return
+}
+
+set major [lindex [split [package require md5] .] 0]
+if {$::major < 2} {
+ proc ::pop3d::Md5 {text} {md5::md5 $text}
+} else {
+ proc ::pop3d::Md5 {text} {string tolower [md5::md5 -hex $text]}
+}
+unset major
+
+##########################
+# Module initialization
+return
diff --git a/tcllib/modules/pop3d/pop3d.test b/tcllib/modules/pop3d/pop3d.test
new file mode 100644
index 0000000..af0b77d
--- /dev/null
+++ b/tcllib/modules/pop3d/pop3d.test
@@ -0,0 +1,772 @@
+# -*- tcl -*-
+# pop3.test: tests for the simple pop3 server.
+#
+# 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) 2002-2014 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pop3d.test,v 1.24 2011/11/14 22:33:48 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5 ;# Required by mime.tcl
+testsNeedTcltest 1.0
+
+support {
+ #use comm/comm.tcl comm
+ useTcllibFile devtools/coserv.tcl ; # loads comm too
+ useTcllibFile devtools/dialog.tcl
+ use md5/md5x.tcl md5
+ use mime/mime.tcl mime
+ useLocal pop3d_udb.tcl pop3d::udb
+ useLocalKeep pop3d_dbox.tcl pop3d::dbox
+}
+testing {
+ useLocalKeep pop3d.tcl pop3d
+}
+
+# -------------------------------------------------------------------------
+# Server processes. Programmed dialogs, server side.
+
+dialog::setup client {Pop3 Fake Client}
+
+# -------------------------------------------------------------------------
+
+proc bgerror {message} {
+ global errorCode errorInfo
+ puts $errorCode
+ puts $errorInfo
+ return
+}
+
+# Reduce output generated by the server objects
+set disable 1
+::log::lvSuppress info $disable
+::log::lvSuppress notice $disable
+::log::lvSuppress debug $disable
+::log::lvSuppress warning $disable
+if {!$disable} {
+ tcltest::verbose {pass body error skip}
+}
+
+# ----------------------------------------------------------------------
+# Basic stuff - Create and destroy servers,
+# (re)configure and query configuration.
+
+test pop3-srv-1.0 {anon create/destroy} {
+ set srv [::pop3d::new]
+ $srv destroy
+ set srv
+} pop3d1
+
+test pop3-srv-1.1 {named create/destroy} {
+ set srv [::pop3d::new foo]
+ $srv destroy
+ set srv
+} foo
+
+test pop3-srv-1.2 {multiple create} {
+ ::pop3d::new foo
+ catch {::pop3d::new foo} msg
+ foo destroy
+ set msg
+} {command "foo" already exists, unable to create pop3 server}
+
+test pop3-srv-1.3 {correct creation, destruction} {
+ ::pop3d::new foo
+ set res [list [info exists ::pop3d::pop3d::foo::port]]
+ foo destroy
+ lappend res [info exists ::pop3d::pop3d::foo::port]
+} {1 0}
+
+test pop3-srv-1.4 {unknown method} {
+ set srv [::pop3d::new]
+ catch {$srv foo} res
+ $srv destroy
+ set res
+} {bad option "foo": must be cget, configure, destroy, down, or up}
+
+
+test pop3-srv-2.0 {base configuration} {
+ set srv [::pop3d::new]
+ set res [$srv configure]
+ $srv destroy
+ set res
+} {-port 110 -auth {} -storage {} -socket ::socket -state down}
+
+foreach {n opt val} {
+ 0 -port 110
+ 1 -state down
+ 2 -auth {}
+ 3 -storage {}
+ 4 -socket ::socket
+} {
+ test pop3-srv-2.1.$n {cget} {
+ set srv [::pop3d::new]
+ set res [$srv cget $opt]
+ $srv destroy
+ set res
+ } $val ; # {}
+ test pop3-srv-2.2.$n {configure get} {
+ set srv [::pop3d::new]
+ set res [$srv configure $opt]
+ $srv destroy
+ set res
+ } $val ; # {}
+}
+
+foreach {n opt val} {
+ 0 -port 2048
+ 2 -auth p3udb54
+ 3 -storage p3dbox128
+ 4 -socket s0ck3t
+} {
+ test pop3-srv-2.3.$n {configure set/get} {
+ set srv [::pop3d::new]
+ $srv configure $opt $val
+ set res [$srv cget $opt]
+ $srv destroy
+ set res
+ } $val ; # {}
+}
+
+test pop3-srv-2.3.1 {configure set/get} {
+ set srv [::pop3d::new]
+ catch {$srv configure -state exiting} res
+ $srv destroy
+ set res
+} {Option -state is read-only}
+
+test pop3-srv-2.4 {configure set/get} {
+ set srv [::pop3d::new]
+ $srv configure -port 2048 -auth p3udb54 -storage p3dbox128 -socket s0ck3t
+ set res [$srv configure]
+ $srv destroy
+ set res
+} {-port 2048 -auth p3udb54 -storage p3dbox128 -socket s0ck3t -state down}
+
+test pop3-srv-2.5 {configure} {
+ set srv [::pop3d::new]
+ catch {$srv configure -port 2048 -auth} res
+ $srv destroy
+ set res
+} {wrong # args, expected: -option | (-option value)...}
+
+test pop3-srv-2.6 {connection introspection} {
+ set srv [::pop3d::new]
+ set res [$srv conn list]
+ $srv destroy
+ set res
+} {}
+
+test pop3-srv-2.7 {connection introspection} {
+ set srv [::pop3d::new]
+ catch {$srv conn list foo} res
+ $srv destroy
+ regsub $srv $res @ res
+ set res
+} {wrong # args: should be "@ conn list"}
+
+test pop3-srv-2.8 {connection introspection} {
+ set srv [::pop3d::new]
+ catch {$srv conn state} res
+ $srv destroy
+ regsub $srv $res @ res
+ set res
+} {wrong # args: should be "@ conn state connId"}
+
+test pop3-srv-2.9 {connection introspection} {
+ set srv [::pop3d::new]
+ catch {$srv conn state foo bar} res
+ $srv destroy
+ regsub $srv $res @ res
+ set res
+} {wrong # args: should be "@ conn state connId"}
+
+test pop3-srv-2.10 {connection introspection} {
+ set srv [::pop3d::new]
+ catch {$srv conn foo} res
+ $srv destroy
+ regsub $srv $res @ res
+ set res
+} {bad option "foo": must be list, or state}
+
+
+# ----------------------------------------------------------------------
+# Advanced I: Basic server up, down, check for true listening,
+# check state, port information
+#
+# Helper functionality to create and destroy servers
+
+proc newsrv {} {
+ global srv
+ log::log debug "/============================================"
+
+ set srv [::pop3d::new]
+ $srv configure -port 0
+ $srv up
+ ::log::log debug "..... $srv @ [$srv cget -port]"
+ return
+}
+
+proc delsrv {} {
+ global srv
+ $srv destroy
+}
+
+proc talk {{mode trace+res}} {
+ global srv
+
+ after 1000 [list dialog::runclient [$srv cget -port]]
+ dialog::waitdone ; # Wait for 'halt.keep.' or general halt.
+
+ if {[string equal $mode trace+res]} {
+ set trace [dialog::received]
+ regsub -all [info hostname] $trace {%%} trace
+ regsub "\[0-9\]+_${srv}_\[0-9\]+@" $trace {==@} trace
+
+ set c [lindex [$srv conn list] 0]
+ if {$c != {}} {set res [$srv conn state $c]} else {set res {}}
+ set res [ppcstate $res]
+
+ return [list $trace $res]
+
+ } elseif {[string equal $mode resonly]} {
+
+ set c [lindex [$srv conn list] 0]
+ if {$c != {}} {set res [$srv conn state $c]} else {set res {}}
+ set res [ppcstate $res]
+
+ return $res
+
+ } else {
+ # Trace only
+
+ set trace [dialog::received]
+ regsub -all [info hostname] $trace {%%} trace
+ regsub "\[0-9\]+_${srv}_\[0-9\]+@" $trace {==@} trace
+
+ return $trace
+ }
+}
+
+# ----------------------------------------------------------------------
+
+test pop3-srv-3.0 {basic up} {
+ newsrv
+ set res [$srv cget -state]
+ delsrv
+ set res
+} {up}
+
+test pop3-srv-3.1 {basic up & down} {
+ newsrv
+ set res [$srv cget -state]
+ $srv down
+ lappend res [$srv cget -state]
+ lappend res [$srv cget -port]
+ delsrv
+ set res
+} {up down 0}
+
+
+
+# ----------------------------------------------------------------------
+# Advanced II.
+#
+# Full interaction with the server.
+#
+# First some helper commands to for the mgmt of a subprocess
+# (Which will be the client), to create a server in a specific
+# initial state, and to perform specific queries of the state.
+
+proc ppcstate {state} {
+ if {$state == {}} {return $state}
+ global srv
+ array set tmp $state
+
+ regsub -all [info hostname] $tmp(id) {%%} tmp(id)
+ regsub "\[0-9\]+_${srv}_\[0-9\]+@" $tmp(id) {==@} tmp(id)
+
+ set tmp(server) [string equal $tmp(server) $srv]
+ set tmp(remoteport) ""
+
+ return [dictsort [array get tmp]]
+}
+
+proc newfsrv {} {
+ global srv udb dbox
+ newsrv
+ $srv configure \
+ -auth [set udb [::pop3d::udb::new]] \
+ -storage [set dbox [::pop3d::dbox::new]]
+
+ makeDirectory __dbox__
+ $dbox base __dbox__
+ $dbox add usr0
+ $udb add ak smash usr0
+
+ foreach f {10 20 30} {
+ makeFile {} [file join __dbox__ usr0 $f]
+ }
+
+ $dbox add usr1
+ $udb add jh wooof usr1
+ return
+}
+
+proc delfsrv {} {
+ global udb dbox
+ delsrv
+ $udb destroy
+ foreach m [$dbox list] {$dbox remove $m}
+ $dbox destroy
+
+ foreach f {10 20 30} {
+ set f [file join __dbox__ usr0 $f]
+ if {![file exists $f]} continue
+ removeFile {} $f
+ }
+
+ removeDirectory __dbox__
+ return
+}
+
+# ----------------------------------------------------------------------
+
+test pop3-srv-4.0.0 {connection introspection} {
+ newsrv
+ dialog::dialog_set {
+ dialog::crlf. ; # Network EOL setting
+ dialog::receive. ; # Greeting
+ dialog::halt.keep. ; # Stop execution, keep socket open
+ }
+
+ set res [talk resonly]
+ delsrv
+ expr {
+ [string match {deleted {} id <==@%%> logon {} msg 0 name {} remotehost 127.*.*.* remoteport {} server 1 size 0 state auth storage {}} $res] ||
+ [string match {deleted {} id <==@%%> logon {} msg 0 name {} remotehost ::1 remoteport {} server 1 size 0 state auth storage {}} $res]
+ }
+} 1
+
+test pop3-srv-5.0 {initial contact, greeting} {
+ newsrv
+ dialog::dialog_set {
+ dialog::crlf. ; # Network EOL setting
+ dialog::receive. ; # Greeting
+ dialog::geval. {set received [lindex $received end]}
+ dialog::halt.keep. ; # Stop execution, keep socket open
+ }
+
+ set res [talk traceonly]
+ delsrv
+ string match {+OK %% tcllib/pop3d-* ready <==@%%>} $res
+} 1
+
+test pop3-srv-6.0 {unknown command} {
+ newsrv
+ dialog::dialog_set {
+ dialog::crlf. ; # Network EOL setting
+ dialog::receive. ; # Greeting
+ dialog::request. {FOOBAR blub}
+ dialog::geval. {set received [lindex $received end]}
+ dialog::halt.keep. ; # Stop execution, keep socket open
+ }
+
+ set res [talk traceonly]
+ delsrv
+ set res
+} {-ERR unknown command 'FOOBAR'}
+
+
+# ----------------------------------------------------------------------
+# Database of possible responses and server states.
+
+array set cstate {
+ 0 {deleted {} id <==@%%> logon user msg 0 name foo remotehost @ADDR remoteport {} server 1 size 0 state auth storage {}}
+ 1 {deleted {} id <==@%%> logon {} msg 0 name {} remotehost @ADDR remoteport {} server 1 size 0 state auth storage {}}
+ 2 {}
+ 3 {deleted {} id <==@%%> logon {} msg 0 name foo remotehost @ADDR remoteport {} server 1 size 0 state auth storage {}}
+ 4 {deleted {} id <==@%%> logon {} msg 3 name ak remotehost @ADDR remoteport {} server 1 size 3 state trans storage usr0}
+ 5 {deleted {} id <==@%%> logon {} msg 0 name ak remotehost @ADDR remoteport {} server 1 size 0 state auth storage {}}
+ 6 {deleted 1 id <==@%%> logon {} msg 3 name ak remotehost @ADDR remoteport {} server 1 size 3 state trans storage usr0}
+}
+
+array set log {
+ 0 {+OK please send PASS command}
+ 1 {+OK %% tcllib/pop3d-* shutting down}
+ 2 {-ERR client not authenticated}
+ 3 {-ERR authentication failed, sorry}
+ 4 {-ERR login mechanism USER/PASS was chosen}
+ 5 {+OK congratulations -ERR client already authenticated}
+ 6 {+OK congratulations}
+ 7 {-ERR client already authenticated}
+ 8 {+OK 3 3}
+ 9 {+OK message 1 deleted}
+ 10 {+OK 1 octets}
+ 11 {+OK }
+ 12 {+OK 3 messages waiting}
+ 13 {-ERR no such message}
+ 14 {+OK 1 1}
+ 15 {+OK 3 messages 1 1 2 1 3 1}
+ 16 {+OK 0 messages}
+ 17 {+OK Capability list follows}
+ 18 {{+OK message 1 deleted} 1 1}
+}
+
+# ======================================================================
+# ======================================================================
+# AUTHORIZATION state - Initial state, after the greeting.
+# Allowed commands: USER, APOP, QUIT, CAPA
+# Not permitted: PASS, STAT, DELE, RETR, TOP, RSET, LIST, NOOP
+#
+
+proc Match {l c res} {
+ global log cstate
+ foreach addr {127.*.*.* ::1} {
+ set cs [string map [list @ADDR $addr] $cstate($c)]
+ if {[string match [list $log($l) $cs] $res]} { return 1 }
+ }
+ return 0
+}
+
+foreach {n cmd lidx cidx} {
+ 0 {USER foo} 0 0
+ 1 {APOP foo bar} 3 3
+ 2 {QUIT} 1 2
+ 3 {STAT} 2 1
+ 4 {DELE 1} 2 1
+ 5 {RETR 1} 2 1
+ 6 {TOP 1 10} 2 1
+ 7 {RSET} 2 1
+ 8 {LIST} 2 1
+ 9 {NOOP} 2 1
+ 10 {PASS xxx} 3 1
+ 11 {CAPA} 17 1
+} {
+ test pop3-srv-7.0.$n "auth, $cmd" {
+ newfsrv
+ dialog::dialog_set {
+ dialog::crlf. ; # Network EOL setting
+ dialog::receive. ; # Greeting
+ dialog::request. $cmd
+ dialog::geval. {set received [lindex $received end]}
+ dialog::halt.keep. ; # Stop execution, keep socket open
+ }
+
+ set res [talk trace+res]
+ delfsrv
+ Match $lidx $cidx $res
+ } 1
+}
+
+# ----------------------------------------------------------------------
+# Mutual exclusion of the different authentication methods,
+# block multiple authentication
+
+test pop3-srv-7.1 {auth, USER/APOP} {
+ newfsrv
+ dialog::dialog_set {
+ dialog::crlf. ; # Network EOL setting
+ dialog::receive. ; # Greeting
+ dialog::request. {USER foo}
+ dialog::request. {APOP foo barr}
+ dialog::geval. {set received [lindex $received end]}
+ dialog::halt.keep. ; # Stop execution, keep socket open
+ }
+
+ set res [talk trace+res]
+ delfsrv
+ Match 4 0 $res
+} 1
+
+test pop3-srv-7.2 {auth, APOP/USER} {
+ newfsrv
+ dialog::dialog_set {
+ dialog::crlf. ; # Network EOL setting
+ dialog::receive. ; # Greeting
+ dialog::geval. {
+ regexp {(<.*>)} [lindex $received 0] -> id
+ set hash [string tolower [comm::comm send $main [list md5::md5 -hex ${id}smash]]]
+ set vcommand "APOP ak $hash"
+ }
+ dialog::reqgvar. vcommand
+ dialog::request. {USER foo}
+ dialog::geval. {set received [join [lrange $received end-1 end]]}
+ dialog::halt.keep. ; # Stop execution, keep socket open
+ }
+
+ set res [talk trace+res]
+ delfsrv
+ Match 5 4 $res
+} 1
+
+# ----------------------------------------------------------------------
+# Checking authentication
+
+foreach {n user pass lidx cidx} {
+ 0 foo bar 3 3
+ 1 ak bar 3 5
+ 2 ak smash 6 4
+} {
+ test pop3-srv-7.3.$n {USER/PASS} {
+ newfsrv
+ dialog::dialog_set {
+ dialog::crlf. ; # Network EOL setting
+ dialog::receive. ; # Greeting
+ dialog::request. [list USER $user]
+ dialog::request. [list PASS $pass]
+ dialog::geval. {set received [lindex $received end]}
+ dialog::halt.keep. ; # Stop execution, keep socket open
+ }
+
+ set res [talk trace+res]
+ delfsrv
+ Match $lidx $cidx $res
+ } 1
+
+ test pop3-srv-7.4.$n {APOP} {
+ newfsrv
+ dialog::dialog_set {
+ dialog::crlf. ; # Network EOL setting
+ dialog::receive. ; # Greeting
+ dialog::geval. [string map [list @@@ $pass !!! $user] {
+ regexp {(<.*>)} [lindex $received 0] -> id
+ set hash [string tolower [comm::comm send $main [list md5::md5 -hex ${id}@@@]]]
+ set vcommand "APOP !!! $hash"
+ }]
+ dialog::sendgvar. vcommand
+ dialog::receive. ; # Apop response
+ dialog::geval. {set received [lindex $received end]}
+ dialog::halt.keep. ; # Stop execution, keep socket open
+ }
+
+ set res [talk trace+res]
+ delfsrv
+ Match $lidx $cidx $res
+ } 1
+}
+
+
+# ======================================================================
+# ======================================================================
+# TRANSACTION state - after successful authentication.
+# Allowed commands: QUIT, STAT, DELE, RETR, TOP, RSET, LIST, NOOP, CAPA
+# Not permitted: USER, PASS, APOP
+#
+
+foreach {n cmd lidx cidx} {
+ 0 {USER foo} 7 4
+ 1 {APOP foo bar} 7 4
+ 2 {QUIT} 1 2
+ 3 {STAT} 8 4
+ 4 {DELE 1} 9 6
+ 5 {RETR 1} 10 4
+ 6 {TOP 1 10} 11 4
+ 7 {RSET} 12 4
+ 9 {NOOP} 11 4
+ 10 {PASS xxx} 7 4
+ 11 {CAPA} 17 4
+} {
+ test pop3-srv-7.5.$n "trans, $cmd" {
+ newfsrv
+ dialog::dialog_set {
+ dialog::crlf. ; # Network EOL setting
+ dialog::receive. ; # Greeting
+ dialog::request. {USER ak}
+ dialog::request. {PASS smash}
+ dialog::request. $cmd
+ dialog::geval. {set received [lindex $received end]}
+ dialog::halt.keep. ; # Stop execution, keep socket open
+ }
+
+ set res [talk trace+res]
+ delfsrv
+ Match $lidx $cidx $res
+ } 1
+}
+
+# ======================================================================
+# ======================================================================
+# Test that deletion of messages is handled correctly (only after QUIT).
+# (Out of range, actual deletion only after the QUIT ...)
+
+foreach {n id lidx cidx} {
+ 0 -1 13 4
+ 1 0 13 4
+ 2 1 9 6
+ 3 4 13 4
+} {
+ test pop3-srv-7.6.$n {DELE, out of range message index} {
+ newfsrv
+ dialog::dialog_set {
+ dialog::crlf. ; # Network EOL setting
+ dialog::receive. ; # Greeting
+ dialog::request. {USER ak}
+ dialog::request. {PASS smash}
+ dialog::request. [list DELE $id]
+ dialog::geval. {set received [lindex $received end]}
+ dialog::halt.keep. ; # Stop execution, keep socket open
+ }
+
+ set res [talk trace+res]
+ delfsrv
+ Match $lidx $cidx $res
+ } 1
+}
+
+test pop3-srv-7.6.4 {DELE, out of range message index} {
+ newfsrv
+ dialog::dialog_set {
+ dialog::crlf. ; # Network EOL setting
+ dialog::receive. ; # Greeting
+ dialog::request. {USER ak}
+ dialog::request. {PASS smash}
+ dialog::request. {DELE 1}
+ dialog::request. {DELE 1}
+ dialog::geval. {set received [lindex $received end]}
+ dialog::halt.keep. ; # Stop execution, keep socket open
+ }
+
+ set res [talk trace+res]
+ delfsrv
+ Match 13 6 $res
+} 1
+
+
+test pop3-srv-7.7 {DELE, abort} {
+ newfsrv
+ dialog::dialog_set {
+ dialog::geval. {
+ set fex [file exists [file join __dbox__ usr0 10]]
+ }
+ dialog::crlf. ; # Network EOL setting
+ dialog::receive. ; # Greeting
+ dialog::request. {USER ak}
+ dialog::request. {PASS smash}
+ dialog::request. {DELE 1}
+ dialog::geval. {
+ set received [lrange $received end end]
+ lappend received $fex
+ lappend received [file exists [file join __dbox__ usr0 10]]
+ }
+ dialog::halt.keep. ; # Stop execution, keep socket open
+ }
+
+ set res [talk trace+res]
+ set has [file exists [file join __dbox__ usr0 10]]
+ delfsrv
+ list [Match 18 6 $res] $has
+} {1 1}
+
+test pop3-srv-7.8 {DELE, complete} {
+ newfsrv
+ dialog::dialog_set {
+ dialog::geval. {
+ set fex [file exists [file join __dbox__ usr0 10]]
+ }
+ dialog::crlf. ; # Network EOL setting
+ dialog::receive. ; # Greeting
+ dialog::request. {USER ak}
+ dialog::request. {PASS smash}
+ dialog::request. {DELE 1}
+ dialog::geval. {
+ set fexb [file exists [file join __dbox__ usr0 10]]
+ }
+ dialog::request. QUIT
+ dialog::geval. {
+ set received [lrange $received end-1 end-1]
+ lappend received $fex $fexb
+ }
+ dialog::halt.keep. ; # Stop execution, keep socket open
+ }
+
+ set res [talk traceonly]
+ lappend res [file exists [file join __dbox__ usr0 10]]
+ delfsrv
+ set res
+} [list $log(9) 1 1 0] ; # {}
+
+foreach {n cmd lidx cidx} {
+ 0 {DELE 1} 13 6
+ 1 {RETR 1} 13 6
+ 2 {TOP 1 10} 13 6
+} {
+ test pop3-srv-7.10.$n "DELE, $cmd" {
+ newfsrv
+ dialog::dialog_set {
+ dialog::crlf. ; # Network EOL setting
+ dialog::receive. ; # Greeting
+ dialog::request. {USER ak}
+ dialog::request. {PASS smash}
+ dialog::request. {DELE 1}
+ dialog::request. $cmd
+ dialog::geval. {set received [lindex $received end]}
+ dialog::halt.keep. ; # Stop execution, keep socket open
+ }
+
+ set res [talk trace+res]
+ delfsrv
+ Match $lidx $cidx $res
+ } 1
+}
+
+# ======================================================================
+# ======================================================================
+# LIST
+#
+
+foreach {n user pass id lidx} {
+ 0 ak smash 0 13
+ 1 ak smash -1 13
+ 2 ak smash 1 14
+ 3 ak smash 4 13
+ 4 ak smash {} 15
+ 5 jh wooof 0 13
+ 6 jh wooof 1 13
+ 7 jh wooof {} 16
+} {
+ test pop3-srv-7.11.$n "LIST $id" {
+ newfsrv
+ dialog::dialog_set {
+ dialog::crlf. ; # Network EOL setting
+ dialog::receive. ; # Greeting
+ dialog::request. [list USER $user]
+ dialog::request. [list PASS $pass]
+ dialog::geval. {set received {}}
+ if {$id != {}} {
+ dialog::request. [list LIST $id]
+ } else {
+ dialog::request. LIST
+ dialog::eval. {
+ global received
+ fconfigure $sock -blocking 1
+ while {![eof $sock]} {
+ gets $sock line
+ if {[string equal $line .]} break
+ lappend received $line
+ }
+ fconfigure $sock -blocking 0
+ }
+ }
+ dialog::geval. {set received [join $received]}
+ dialog::halt.keep. ; # Stop execution, keep socket open
+ }
+
+ set res [talk traceonly]
+ delfsrv
+ set res
+ } $log($lidx) ; # {}
+}
+
+# ----------------------------------------------------------------------
+dialog::shutdown
+testsuiteCleanup
diff --git a/tcllib/modules/pop3d/pop3d_dbox.man b/tcllib/modules/pop3d/pop3d_dbox.man
new file mode 100644
index 0000000..2f4dfe7
--- /dev/null
+++ b/tcllib/modules/pop3d/pop3d_dbox.man
@@ -0,0 +1,164 @@
+[comment {-*- tcl -*-}]
+[manpage_begin pop3d::dbox n 1.0.2]
+[keywords internet]
+[keywords network]
+[keywords pop3]
+[keywords protocol]
+[keywords {rfc 822}]
+[copyright {2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Tcl POP3 Server Package}]
+[titledesc {Simple mailbox database for pop3d}]
+[category Networking]
+[require Tcl 8.3]
+[require pop3d::dbox [opt 1.0.2]]
+[description]
+[para]
+
+The package [package pop3d::dbox] provides simple/basic mailbox
+management facilities. Each mailbox object manages a single base
+directory whose subdirectories represent the managed mailboxes. Mails
+in a mailbox are represented by files in a mailbox directory, where
+each of these files contains a single mail, both headers and body, in
+RFC 822 ([uri http://www.rfc-editor.org/rfc/rfc822.txt]) conformant
+format.
+
+[para]
+
+Any mailbox object following the interface described below can be used
+in conjunction with the pop3 server core provided by the package
+[package pop3d]. It is especially possible to directly use the objects
+created by this package in the storage callback of pop3 servers
+following the same interface as servers created by the package
+[package pop3d].
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd ::pop3d::dbox::new] [opt [arg dbName]]]
+
+This command creates a new database object with an associated global
+Tcl command whose name is [arg dbName].
+
+[list_end]
+
+The command [cmd dbName] may be used to invoke various operations on
+the database. It has the following general form:
+
+[list_begin definitions]
+[call [cmd dbName] [arg option] [opt [arg "arg arg ..."]]]
+
+[arg Option] and the [arg arg]s determine the exact behavior of the
+command.
+
+[list_end]
+
+[para]
+
+The following commands are possible for database objects:
+
+[list_begin definitions]
+
+[call [arg dbName] [method destroy]]
+
+Destroys the mailbox database and all transient data. The directory
+associated with the object is not destroyed.
+
+[call [arg dbName] [method base] [arg base]]
+
+Defines the base directory containing the mailboxes to manage. If this
+method is not called none of the following methods will work.
+
+[call [arg dbName] [method add] [arg mbox]]
+
+Adds a mailbox of name [arg mbox] to the database. The name must be a
+valid path component.
+
+[call [arg dbName] [method remove] [arg mbox]]
+
+Removes the mailbox specified through [arg mbox], and the mails
+contained therein, from the database. This method will fail if the
+specified mailbox is locked.
+
+[call [arg dbName] [method move] [arg {old new}]]
+
+Changes the name of the mailbox [arg old] to [arg new].
+
+[call [arg dbName] [method list]]
+
+Returns a list containing the names of all mailboxes in the directory
+associated with the database.
+
+[call [arg dbName] [method exists] [arg mbox]]
+
+Returns true if the mailbox with name [arg mbox] exists in the
+database, or false if not.
+
+[call [arg dbName] [method locked] [arg mbox]]
+
+Checks if the mailbox specified through [arg mbox] is currently locked.
+
+[call [arg dbName] [method lock] [arg mbox]]
+
+This method locks the specified mailbox for use by a single connection
+to the server. This is necessary to prevent havoc if several
+connections to the same mailbox are open. The complementary method is
+[method unlock]. The command will return true if the lock could be set
+successfully or false if not.
+
+[call [arg dbName] [method unlock] [arg mbox]]
+
+This is the complementary method to [method lock], it revokes the lock
+on the specified mailbox.
+
+[call [arg dbName] [method stat] [arg mbox]]
+
+Determines the number of messages in the specified mailbox and returns
+this number. This method fails if the mailbox [arg mbox] is not
+locked.
+
+[call [arg dbName] [method size] [arg mbox] [opt [arg msgId]]]
+
+Determines the size of the message specified through its id in
+
+[arg msgId], in bytes, and returns this number. The command will
+return the size of the whole maildrop if no message id was specified.
+
+If specified the [arg msgId] has to be in the range "1 ... [lb][arg dbName] [method stat][rb]"
+
+or this call will fail. If [method stat] was not called before this
+call, [method size] will assume that there are zero messages in the
+mailbox.
+
+[call [arg dbName] [method dele] [arg {mbox msgList}]]
+
+Deletes the messages whose numeric ids are contained in the
+[arg msgList] from the mailbox specified via [arg mbox].
+
+The [arg msgList] must not be empty or this call will fail.
+
+The numeric ids in [arg msgList] have to be in the range "1 ...
+[lb][arg dbName] [method stat][rb]" or this
+call will fail. If [method stat] was not called
+before this call, [method dele] will assume
+that there are zero messages in the mailbox.
+
+[call [arg storageCmd] [method get] [arg mbox] [arg msgId]]
+
+Returns a handle for the specified message. This handle is a mime
+token following the interface described in the documentation of
+package [package mime]. The token is [emph read-only]. In other
+words, the caller is allowed to do anything with the token except to
+modify it.
+
+The [arg msgId] has to be in the range "1 ...
+[lb][arg dbName] [method stat][rb]" or this
+call will fail. If [method stat] was not called
+before this call, [method get] will assume
+that there are zero messages in the mailbox.
+
+[list_end]
+
+[vset CATEGORY pop3d]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pop3d/pop3d_dbox.tcl b/tcllib/modules/pop3d/pop3d_dbox.tcl
new file mode 100644
index 0000000..562a906
--- /dev/null
+++ b/tcllib/modules/pop3d/pop3d_dbox.tcl
@@ -0,0 +1,485 @@
+# -*- tcl -*-
+# pop3d_dbox.tcl --
+#
+# Implementation of a simple mailbox database for the pop3 server
+# Each mailbox is a a directory in a base directory, with each mail
+# a file in that directory. The mail file contains both headers and
+# body of the mail.
+#
+# Copyright (c) 2002 by Andreas Kupries
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require mime ; # tcllib | mime token is result of "get".
+package require log ; # tcllib | Logging package
+
+namespace eval ::pop3d::dbox {
+ # Data storage in the pop3d::dbox module
+ # -------------------------------------
+ # One array per object containing the db contents. Keyed by user name.
+ # And the information about the last file data was read from.
+
+ # counter is used to give a unique name for unnamed databases
+ variable counter 0
+
+ # commands is the list of subcommands recognized by the server
+ variable commands [list \
+ "add" \
+ "base" \
+ "dele" \
+ "destroy" \
+ "exists" \
+ "get" \
+ "list" \
+ "lock" \
+ "locked" \
+ "move" \
+ "remove" \
+ "size" \
+ "stat" \
+ "unlock" \
+ ]
+}
+
+
+# ::pop3d::dbox::new --
+#
+# Create a new mailbox database with a given name;
+# if no name is given, use
+# p3dboxX, where X is a number.
+#
+# Arguments:
+# name name of the mailbox database; if null, generate one.
+#
+# Results:
+# name name of the mailbox database created
+
+proc ::pop3d::dbox::new {{name ""}} {
+ variable counter
+
+ if { [llength [info level 0]] == 1 } {
+ incr counter
+ set name "p3dbox${counter}"
+ }
+
+ if { ![string equal [info commands ::$name] ""] } {
+ return -code error \
+ "command \"$name\" already exists,\
+ unable to create mailbox database"
+ }
+
+ # Set up the namespace
+ namespace eval ::pop3d::dbox::dbox::$name {
+ variable dir ""
+ variable state ; array set state {}
+ variable locked ; array set locked {}
+ variable transfer ; array set transfer {}
+ }
+
+ # Create the command to manipulate the mailbox database
+ interp alias {} ::$name {} ::pop3d::dbox::DboxProc $name
+
+ return $name
+}
+
+##########################
+# Private functions follow
+
+# ::pop3d::dbox::DboxProc --
+#
+# Command that processes all mailbox database object commands.
+#
+# Arguments:
+# name name of the mailbox database object to manipulate.
+# args command name and args for the command
+#
+# Results:
+# Varies based on command to perform
+
+proc ::pop3d::dbox::DboxProc {name {cmd ""} args} {
+
+ # Do minimal args checks here
+ if { [llength [info level 0]] == 2 } {
+ return -code error \
+ "wrong # args: should be \"$name option ?arg arg ...?\""
+ }
+
+ # Split the args into command and args components
+ if { [llength [info commands ::pop3d::dbox::_$cmd]] == 0 } {
+ variable commands
+ set optlist [join $commands ", "]
+ set optlist [linsert $optlist "end-1" "or"]
+ return -code error "bad option \"$cmd\": must be $optlist"
+ }
+ eval [list ::pop3d::dbox::_$cmd $name] $args
+}
+
+
+proc ::pop3d::dbox::_base {name base} {
+ # @c Constructor. Does some more checks on the given base directory.
+
+ # sanity checks
+ if {$base == {}} {
+ return -code error "directory not specified"
+ }
+ if {! [file exists $base]} {
+ return -code error "base: \"$base\" does not exist"
+ }
+ if {! [file isdirectory $base]} {
+ return -code error "base: \"$base\" not a directory"
+ }
+ if {! [file readable $base]} {
+ return -code error "base: \"$base\" not readable"
+ }
+ if {! [file writable $base]} {
+ return -code error "base: \"$base\" not writable"
+ }
+
+ upvar ::pop3d::dbox::dbox::${name}::dir dir
+ set dir $base
+ return
+}
+
+
+# ::pop3d::dbox::_destroy --
+#
+# Destroy a mail database, including its associated command and
+# data storage.
+#
+# Arguments:
+# name Name of the database to destroy.
+#
+# Results:
+# None.
+
+proc ::pop3d::dbox::_destroy {name} {
+ namespace delete ::pop3d::dbox::dbox::$name
+ interp alias {} ::$name {}
+ return
+}
+
+proc ::pop3d::dbox::_add {name mbox} {
+ # @c Create a mailbox with handle <a mbox>. The handle is used as the
+ # @c name of the directory to contain the mails too.
+ #
+ # @a mbox: Reference to the mailbox to be operated on.
+
+ set dir [CheckDir $name]
+ set mboxpath [file join $dir $mbox]
+
+ if {[file exists $mboxpath]} {
+ return -code error "cannot add \"$mbox\", mailbox already in existence"
+ }
+
+ file mkdir $mboxpath
+ return
+}
+
+
+proc ::pop3d::dbox::_remove {name mbox} {
+ # @c Remove mailbox with handle <a mbox>. This will destroy all mails
+ # @c contained in it too.
+ #
+ # @a mbox: Reference to the mailbox to be operated on.
+
+ set dir [CheckDir $name]
+ set mboxpath [file join $dir $mbox]
+
+ if {![file exists $mboxpath]} {
+ return -code error "cannot remove \"$mbox\", mailbox does not exist"
+ }
+
+ if {[_locked $name $mbox]} {
+ return -code error "cannot remove \"$mbox\", mailbox is locked"
+ }
+
+ file delete -force $mboxpath
+ return
+}
+
+
+proc ::pop3d::dbox::_move {name old new} {
+ # @c Change the handle of mailbox <a old> to <a new>.
+ #
+ # @a old: Reference to the mailbox to be operated on.
+ # @a new: New reference to the mailbox
+
+ set dir [CheckDir $name]
+ set oldpath [file join $dir $old]
+ set newpath [file join $dir $new]
+
+ if {![file exists $oldpath]} {
+ return -code error "cannot move \"$old\", mailbox does not exist"
+ }
+ if {[file exists $newpath]} {
+ return -code error \
+ "cannot move \"$old\", destination \"$new\" already exists"
+ }
+
+ file rename -force $oldpath $newpath
+ return
+}
+
+
+proc ::pop3d::dbox::_list {name} {
+ # @c Lists known mailboxes in object.
+ # @r List of mailbox names.
+
+ set dir [CheckDir $name]
+ set here [pwd]
+ cd $dir
+ set files [glob -nocomplain *]
+ cd $here
+
+ set res [list]
+ foreach f $files {
+ set mboxpath [file join $dir $f]
+ if {! [file isdirectory $mboxpath]} {continue}
+ if {! [file readable $mboxpath]} {continue}
+ if {! [file writable $mboxpath]} {continue}
+ lappend res $f
+ }
+ return $res
+}
+
+
+proc ::pop3d::dbox::_exists {name mbox} {
+ # @c Determines existence of mailbox <a mbox>.
+ # @a mbox: Reference to the mailbox to check for.
+ # @r 1 if the mailbox exists, 0 else.
+
+ set dir [CheckDir $name]
+ set mbox [file join $dir $mbox]
+ return [file exists $mbox]
+}
+
+
+proc ::pop3d::dbox::_locked {name mbox} {
+ # @c Checks wether the specified mailbox is locked or not.
+ # @a mbox: Reference to the mailbox to check.
+ # @r 1 if the mailbox is locked, 0 else.
+
+ set dir [CheckDir $name]
+ set mbox [file join $dir $mbox]
+
+ upvar ::pop3d::dbox::dbox::${name}::locked locked
+
+ return [::info exists locked($mbox)]
+}
+
+
+# -- interface to the pop server (storage callback) --
+
+proc ::pop3d::dbox::_lock {name mbox} {
+ # @c Locks the given mailbox, additionally stores a list of the
+ # @c available files in the manager state. All files (= messages)
+ # @c added to the mailbox after this operation will be ignored
+ # @c during the session.
+ #
+ # @a mbox: Reference to the mailbox to be locked.
+ # @r 1 if mailbox was locked sucessfully, 0 else.
+
+ # locked already ?
+ if {[_locked $name $mbox]} {
+ return 0
+ }
+
+ set dir [Check $name $mbox]
+
+ # Compute a list of message files residing in the mailbox directory
+
+ upvar ::pop3d::dbox::dbox::${name}::state state
+ upvar ::pop3d::dbox::dbox::${name}::locked locked
+
+ set state($dir) [lsort [glob -nocomplain [file join $dir *]]]
+ set locked($dir) 1
+ return 1
+}
+
+
+proc ::pop3d::dbox::_unlock {name mbox} {
+ # @c A locked mailbox is unlocked, thereby made available
+ # @c to other sessions.
+ #
+ # @a mbox: Reference to the mailbox to be locked.
+
+ # not locked ?
+ if {![_locked $name $mbox]} {return}
+ set dir [Check $name $mbox]
+
+ upvar ::pop3d::dbox::dbox::${name}::state state
+ upvar ::pop3d::dbox::dbox::${name}::locked locked
+
+ unset state($dir)
+ unset locked($dir)
+ return
+}
+
+
+proc ::pop3d::dbox::_stat {name mbox} {
+ # @c Determines the number of messages picked up by <m lock>.
+ # @c Will fail if the mailbox was not locked.
+ #
+ # @a mbox: Reference to the mailbox queried.
+ # @r The number of messages in the mailbox
+
+ set dir [Check $name $mbox]
+
+ if {![_locked $name $mbox]} {
+ return -code error "mailbox \"$mbox\" is not locked"
+ }
+
+ upvar ::pop3d::dbox::dbox::${name}::state state
+
+ return [llength $state($dir)]
+}
+
+
+proc ::pop3d::dbox::_size {name mbox {msgId {}}} {
+ # @c Determines the size of the specified message, in bytes.
+ #
+ # @a mbox: Reference to the mailbox to be operated on.
+ # @a msgId: Numerical index of the message to look at.
+ # @r size of the message in bytes.
+
+ log::log debug "$name size $mbox ($msgId)"
+
+ set dir [Check $name $mbox]
+
+ log::log debug "$name mbox dir = $dir"
+
+ upvar ::pop3d::dbox::dbox::${name}::state state
+
+ if {$msgId == {}} {
+ log::log debug "$name size /full"
+
+ # Full size of the maildrop requested.
+ if {![info exists state($dir)]} {
+ # No stat before size, assume that there are no messages
+ # in the maildrop, which implies that the maildrop is
+ # empty, i.e. of size 0.
+ return 0
+ }
+
+ set n 0
+ set k [llength $state($dir)]
+ for {set id 0} {$id < $k} {incr id} {
+ incr n [file size [lindex $state($dir) $id]]
+ }
+ return $n
+ }
+
+ if {
+ ($msgId < 1) ||
+ (![info exists state($dir)]) ||
+ ([llength $state($dir)] < $msgId)
+ } {
+ return -code error "id \"$msgId\" out of range"
+ }
+ incr msgId -1
+
+ ## log::log debug "$name msg mails = $state($dir)"
+ log::log debug "$name msg file = [lindex $state($dir) $msgId]"
+
+ return [file size [lindex $state($dir) $msgId]]
+}
+
+
+proc ::pop3d::dbox::_dele {name mbox msgList} {
+ # @c Deletes the specified messages from the mailbox. This should
+ # @c be followed by a <m unlock> as the state is not updated
+ # @c accordingly.
+ #
+ # @a mbox: Reference to the mailbox to be operated on.
+ # @a msgList: List of message ids.
+
+ set dir [Check $name $mbox]
+ if {[llength $msgList] == 0} {
+ return -code error "nothing to delete"
+ }
+
+ # @d The code assumes that the id's in the list were already
+ # @d checked against the maximal number of messages.
+
+ upvar ::pop3d::dbox::dbox::${name}::state state
+
+ foreach msgId $msgList {
+ if {
+ ($msgId < 1) ||
+ (![info exists state($dir)]) ||
+ ([llength $state($dir)] < $msgId)
+ } {
+ return -code error "id \"$msgId\" out of range"
+ }
+ }
+ foreach msgId $msgList {
+ file delete [lindex $state($dir) [incr msgId -1]]
+ }
+
+ # the mailbox state is unusable now.
+ return
+}
+
+proc ::pop3d::dbox::_get {name mbox msgId} {
+ set dir [Check $name $mbox]
+
+ upvar ::pop3d::dbox::dbox::${name}::state state
+
+ if {
+ ($msgId < 1) ||
+ (![info exists state($dir)]) ||
+ ([llength $state($dir)] < $msgId)
+ } {
+ return -code error "id \"$msgId\" out of range"
+ }
+ incr msgId -1
+
+ set mailfile [lindex $state($dir) $msgId]
+
+ set token [::mime::initialize -file $mailfile]
+ return $token
+}
+
+###########################
+###########################
+# Internal helper commands.
+
+proc ::pop3d::dbox::Check {name mbox} {
+ # @c Internal procedure. Used to map a mailbox handle
+ # @c to the directory containing the messages.
+ # @a mbox: Reference to the mailbox to be operated on.
+ # @r Path of directory holding the message files of the
+ # @r specified mailbox.
+
+ set dir [CheckDir $name]
+ set mboxpath [file join $dir $mbox]
+
+ if {! [file exists $mboxpath]} {
+ return -code error "\"$mbox\" does not exist"
+ }
+ if {! [file isdirectory $mboxpath]} {
+ return -code error "\"$mbox\" is not a directory"
+ }
+ if {! [file readable $mboxpath]} {
+ return -code error "\"$mbox\" is not readable"
+ }
+ if {! [file writable $mboxpath]} {
+ return -code error "\"$mbox\" is not writable"
+ }
+ return $mboxpath
+}
+
+proc ::pop3d::dbox::CheckDir {name} {
+ upvar ::pop3d::dbox::dbox::${name}::dir dir
+
+ if {$dir == {}} {
+ return -code error "base directory not specified"
+ }
+ return $dir
+}
+
+##########################
+# Module initialization
+
+package provide pop3d::dbox 1.0.2
diff --git a/tcllib/modules/pop3d/pop3d_dbox.test b/tcllib/modules/pop3d/pop3d_dbox.test
new file mode 100644
index 0000000..13ef57a
--- /dev/null
+++ b/tcllib/modules/pop3d/pop3d_dbox.test
@@ -0,0 +1,592 @@
+# -*- tcl -*-
+# pop3_dbox.test: tests for the simple pop3 mail database.
+#
+# 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) 2002-2014 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pop3d_dbox.test,v 1.11 2006/10/09 21:41:41 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5 ;# Required by mime.tcl
+testsNeedTcltest 1.0
+
+support {
+ use md5/md5x.tcl md5
+ use mime/mime.tcl mime
+}
+testing {
+ useLocal pop3d_dbox.tcl pop3d::dbox
+}
+
+# -------------------------------------------------------------------------
+# Reduce output generated by the server objects
+
+::log::lvSuppress info
+::log::lvSuppress notice
+::log::lvSuppress debug
+::log::lvSuppress warning
+
+# ----------------------------------------------------------------------
+
+test pop3-dbox-1.0 {anon create/destroy} {
+ set dbox [::pop3d::dbox::new]
+ $dbox destroy
+ regsub {[0-9]+$} $dbox {} dbox
+ set dbox
+} p3dbox
+
+test pop3-dbox-1.1 {named create/destroy} {
+ set dbox [::pop3d::dbox::new foo]
+ $dbox destroy
+ set dbox
+} foo
+
+test pop3-dbox-1.2 {multiple create} {
+ ::pop3d::dbox::new foo
+ catch {::pop3d::dbox::new foo} msg
+ foo destroy
+ set msg
+} {command "foo" already exists, unable to create mailbox database}
+
+test pop3-dbox-1.3 {correct creation, destruction} {
+ ::pop3d::dbox::new foo
+ set res [list [info exists ::pop3d::dbox::dbox::foo::dir]]
+ foo destroy
+ lappend res [info exists ::pop3d::dbox::dbox::foo::dir]
+} {1 0}
+
+test pop3-dbox-1.4 {unknown method} {
+ set dbox [::pop3d::dbox::new]
+ catch {$dbox foo} res
+ $dbox destroy
+ set res
+} {bad option "foo": must be add, base, dele, destroy, exists, get, list, lock, locked, move, remove, size, stat, or unlock}
+
+
+
+test pop3-dbox-2.0 {initialization} {
+ set dbox [::pop3d::dbox::new]
+ catch {$dbox base {}} res
+ $dbox destroy
+ set res
+} {directory not specified}
+
+test pop3-dbox-2.1 {initialization} {
+ set dbox [::pop3d::dbox::new]
+ catch {$dbox base foo} res
+ $dbox destroy
+ set res
+} {base: "foo" does not exist}
+
+test pop3-dbox-2.2 {initialization} {
+ makeFile {} __bar__
+ set dbox [::pop3d::dbox::new]
+ catch {$dbox base __bar__} res
+ $dbox destroy
+ removeFile __bar__
+ set res
+} {base: "__bar__" not a directory}
+
+test pop3-dbox-2.3 {initialization} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ set res [list [$dbox base __dbox__]]
+ lappend res [$dbox list]
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {{} {}}
+
+
+test pop3-dbox-3.0 {adding mailboxes} {
+ set dbox [::pop3d::dbox::new]
+ catch {$dbox add known} res
+ $dbox destroy
+ set res
+} {base directory not specified}
+
+test pop3-dbox-3.1 {adding mailboxes} {
+ makeDirectory [file join __dbox__ known]
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ catch {$dbox add known} res
+ $dbox destroy
+ removeDirectory [file join __dbox__ known]
+ set res
+} {cannot add "known", mailbox already in existence}
+
+test pop3-dbox-3.2 {adding mailboxes} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ set res [file exists [file join __dbox__ usr0]]
+ $dbox add usr0
+ lappend res [file exists [file join __dbox__ usr0]]
+ lappend res [lsort [$dbox list]]
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {0 1 usr0}
+
+test pop3-dbox-4.0 {removing mailboxes} {
+ set dbox [::pop3d::dbox::new]
+ catch {$dbox remove known} res
+ $dbox destroy
+ set res
+} {base directory not specified}
+
+test pop3-dbox-4.1 {removing mailboxes} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ catch {$dbox remove usr1} res
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {cannot remove "usr1", mailbox does not exist}
+
+test pop3-dbox-4.2 {removing mailboxes} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add usr0
+
+ set res [file exists [file join __dbox__ usr0]]
+ $dbox remove usr0
+ lappend res [file exists [file join __dbox__ usr0]]
+
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {1 0}
+
+
+test pop3-dbox-5.0 {renaming mailboxes} {
+ set dbox [::pop3d::dbox::new]
+ catch {$dbox move usr0 usr1} res
+ $dbox destroy
+ set res
+} {base directory not specified}
+
+test pop3-dbox-5.1 {renaming mailboxes} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ catch {$dbox move usr0 usr1} res
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {cannot move "usr0", mailbox does not exist}
+
+test pop3-dbox-5.2 {renaming mailboxes} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add usr0
+ $dbox add known
+ catch {$dbox move usr0 known} res
+ $dbox remove usr0
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {cannot move "usr0", destination "known" already exists}
+
+test pop3-dbox-5.3 {renaming mailboxes} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add usr0
+
+ set res {}
+ lappend res [file exists [file join __dbox__ usr0]]
+
+ $dbox move usr0 usr1
+
+ lappend res [file exists [file join __dbox__ usr0]]
+ lappend res [file exists [file join __dbox__ usr1]]
+
+ $dbox remove usr1
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {1 0 1}
+
+
+test pop3-dbox-6.0 {existence of mailboxes} {
+ set dbox [::pop3d::dbox::new]
+ catch {$dbox exists foo} res
+ $dbox destroy
+ set res
+} {base directory not specified}
+
+test pop3-dbox-6.1 {existence of mailboxes} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ set res [$dbox exists foo]
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} 0
+
+test pop3-dbox-6.2 {existence of mailboxes} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add known
+
+ set res [$dbox exists known]
+
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} 1
+
+
+test pop3-dbox-7.0 {locking} {
+ set dbox [::pop3d::dbox::new]
+ catch {$dbox locked foo} res
+ $dbox destroy
+ set res
+} {base directory not specified}
+test pop3-dbox-7.1 {locking} {
+ set dbox [::pop3d::dbox::new]
+ catch {$dbox lock foo} res
+ $dbox destroy
+ set res
+} {base directory not specified}
+test pop3-dbox-7.2 {locking} {
+ set dbox [::pop3d::dbox::new]
+ catch {$dbox unlock foo} res
+ $dbox destroy
+ set res
+} {base directory not specified}
+
+test pop3-dbox-7.3 {locking} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ set res [$dbox locked known]
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} 0
+
+test pop3-dbox-7.4 {locking} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add known
+
+ set res [$dbox locked known]
+ lappend res [$dbox lock known]
+ lappend res [$dbox locked known]
+ $dbox unlock known
+ lappend res [$dbox locked known]
+
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {0 1 1 0}
+
+test pop3-dbox-7.5 {locking} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add known
+
+ set res [$dbox lock known]
+ lappend res [$dbox lock known]
+ $dbox unlock known
+ lappend res [$dbox locked known]
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {1 0 0}
+
+test pop3-dbox-7.6 {locking} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add usr0
+ $dbox lock usr0
+ catch {$dbox remove usr0} res
+ $dbox unlock usr0
+ $dbox remove usr0
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {cannot remove "usr0", mailbox is locked}
+
+
+test pop3-dbox-8.0 {stat} {
+ set dbox [::pop3d::dbox::new]
+ catch {$dbox stat known} res
+ $dbox destroy
+ set res
+} {base directory not specified}
+
+test pop3-dbox-8.1 {stat} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add known
+
+ catch {$dbox stat known} res
+
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {mailbox "known" is not locked}
+
+test pop3-dbox-8.2 {stat} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add known
+ $dbox lock known
+
+ set res [$dbox stat known]
+
+ $dbox unlock known
+ $dbox destroy
+ set res
+} 0
+
+test pop3-dbox-8.3 {stat} {
+ set dbox [::pop3d::dbox::new]
+ makeDirectory __dbox__
+ $dbox base __dbox__
+ $dbox add usr0
+ makeFile {} [file join __dbox__ usr0 a]
+ makeFile {abc} [file join __dbox__ usr0 d]
+ makeFile {abcdef} [file join __dbox__ usr0 c]
+ $dbox lock usr0
+ set res [$dbox stat usr0]
+ $dbox unlock usr0
+ $dbox remove usr0
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} 3
+
+
+test pop3-dbox-9.0 {size} {
+ set dbox [::pop3d::dbox::new]
+ catch {$dbox size known 0} res
+ $dbox destroy
+ set res
+} {base directory not specified}
+
+test pop3-dbox-9.1 {size} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add known
+
+ catch {$dbox size known 0} res
+
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {id "0" out of range}
+
+test pop3-dbox-9.2 {size} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add usr0
+ makeFile {} [file join __dbox__ usr0 a]
+ makeFile {abc} [file join __dbox__ usr0 d]
+ makeFile {abcdef} [file join __dbox__ usr0 c]
+ catch {$dbox size usr0 1} res
+ $dbox remove usr0
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {id "1" out of range}
+
+test pop3-dbox-9.3 {size} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add usr0
+ makeFile {} [file join __dbox__ usr0 a]
+ makeFile {abc} [file join __dbox__ usr0 b]
+ makeFile {abcdef} [file join __dbox__ usr0 c]
+
+ $dbox lock usr0
+ set res [$dbox stat usr0]
+ lappend res [$dbox size usr0 1]
+ lappend res [$dbox size usr0 2]
+ lappend res [$dbox size usr0 3]
+
+ catch {$dbox size usr0 4} resb
+ lappend res $resb
+
+ $dbox unlock usr0
+ $dbox remove usr0
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {3 1 4 7 {id "4" out of range}}
+
+
+
+test pop3-dbox-10.0 {get} {
+ set dbox [::pop3d::dbox::new]
+ catch {$dbox get known 0} res
+ $dbox destroy
+ set res
+} {base directory not specified}
+
+test pop3-dbox-10.1 {get} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add known
+
+ catch {$dbox get known 0} res
+
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {id "0" out of range}
+
+test pop3-dbox-10.2 {get} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add usr0
+ makeFile {} [file join __dbox__ usr0 a]
+ makeFile {abc} [file join __dbox__ usr0 d]
+ makeFile {abcdef} [file join __dbox__ usr0 c]
+ catch {$dbox get usr0 1} res
+ $dbox remove usr0
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {id "1" out of range}
+
+test pop3-dbox-10.3 {get} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add usr0
+ makeFile {} [file join __dbox__ usr0 a]
+ makeFile {} [file join __dbox__ usr0 b]
+ makeFile {} [file join __dbox__ usr0 c]
+
+ $dbox lock usr0
+ set res [$dbox stat usr0]
+ lappend res [$dbox get usr0 1]
+ lappend res [$dbox get usr0 2]
+ lappend res [$dbox get usr0 3]
+
+ catch {$dbox get usr0 4} resb
+ lappend res $resb
+
+ $dbox unlock usr0
+ $dbox remove usr0
+ $dbox destroy
+ regsub -all {::mime::[0-9]+} $res {X} res
+ removeDirectory __dbox__
+ set res
+} {3 X X X {id "4" out of range}}
+
+
+test pop3-dbox-11.0 {dele} {
+ set dbox [::pop3d::dbox::new]
+ catch {$dbox dele known 0} res
+ $dbox destroy
+ set res
+} {base directory not specified}
+
+test pop3-dbox-11.1 {dele} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add known
+
+ catch {$dbox dele known {}} res
+
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {nothing to delete}
+
+test pop3-dbox-11.2 {dele} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add known
+
+ catch {$dbox dele known 0} res
+
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {id "0" out of range}
+
+test pop3-dbox-11.3 {dele} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add usr0
+ makeFile {} [file join __dbox__ usr0 a]
+ makeFile {abc} [file join __dbox__ usr0 d]
+ makeFile {abcdef} [file join __dbox__ usr0 c]
+ catch {$dbox dele usr0 1} res
+ $dbox remove usr0
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {id "1" out of range}
+
+test pop3-dbox-11.4 {dele} {
+ makeDirectory __dbox__
+ set dbox [::pop3d::dbox::new]
+ $dbox base __dbox__
+ $dbox add usr0
+ makeFile {} [file join __dbox__ usr0 a]
+ makeFile {} [file join __dbox__ usr0 b]
+ makeFile {} [file join __dbox__ usr0 c]
+
+ set res {}
+ foreach f {a b c} {
+ lappend res [file exists [file join __dbox__ usr0 $f]]
+ }
+
+ $dbox lock usr0
+ lappend res [$dbox stat usr0]
+
+ $dbox dele usr0 {1 2 3}
+
+ foreach f {a b c} {
+ lappend res [file exists [file join __dbox__ usr0 $f]]
+ }
+ # unusable state, wrong information
+ lappend res [$dbox stat usr0]
+
+ catch {$dbox dele usr0 4} resb
+ lappend res $resb
+
+ $dbox unlock usr0
+ $dbox remove usr0
+ $dbox destroy
+ removeDirectory __dbox__
+ set res
+} {1 1 1 3 0 0 0 3 {id "4" out of range}}
+
+
+# ----------------------------------------------------------------------
+testsuiteCleanup
diff --git a/tcllib/modules/pop3d/pop3d_udb.man b/tcllib/modules/pop3d/pop3d_udb.man
new file mode 100644
index 0000000..ff9cfc7
--- /dev/null
+++ b/tcllib/modules/pop3d/pop3d_udb.man
@@ -0,0 +1,112 @@
+[comment {-*- tcl -*-}]
+[manpage_begin pop3d::udb n 1.0.1]
+[keywords internet]
+[keywords network]
+[keywords pop3]
+[keywords protocol]
+[copyright {2002 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Tcl POP3 Server Package}]
+[titledesc {Simple user database for pop3d}]
+[category Networking]
+[require Tcl 8.2]
+[require pop3d::udb [opt 1.0.1]]
+[description]
+[para]
+
+The package [package pop3d::udb] provides simple in memory databases
+which can be used in conjunction with the pop3 server core provided by
+the package [package pop3d]. The databases will use the names of users
+as keys and associates passwords and storage references with them.
+
+[para]
+
+Objects created by this package can be directly used in the
+authentication callback of pop3 servers following the same interface
+as servers created by the package [package pop3d].
+
+[para]
+
+[list_begin definitions]
+
+[call [cmd ::pop3d::udb::new] [opt [arg dbName]]]
+
+This command creates a new database object with an associated global
+Tcl command whose name is [arg dbName].
+
+[list_end]
+
+The command [cmd dbName] may be used to invoke various operations on
+the database. It has the following general form:
+
+[list_begin definitions]
+[call [cmd dbName] [arg option] [opt [arg "arg arg ..."]]]
+
+[arg Option] and the [arg arg]s determine the exact behavior of the
+command.
+
+[list_end]
+
+[para]
+
+The following commands are possible for database objects:
+
+[list_begin definitions]
+
+[call [arg dbName] [method destroy]]
+
+Destroys the database object.
+
+[call [arg dbName] [method add] [arg {user pwd storage}]]
+
+Add a new user or changes the data of an existing user. Stores
+[arg password] and [arg storage] reference for the given [arg user].
+
+[call [arg dbName] [method remove] [arg user]]
+
+Removes the specified [arg user] from the database.
+
+[call [arg dbName] [method rename] [arg {user newName}]]
+
+Changes the name of the specified [arg user] to [arg newName].
+
+[call [arg dbName] [method lookup] [arg user]]
+
+Searches the database for the specified [arg user] and returns a
+two-element list containing the associated password and storage
+reference, in this order. Throws an error if the user could not be
+found. This is the interface as expected by the authentication
+callback of package [package pop3d].
+
+[call [arg dbName] [method exists] [arg user]]
+
+Returns true if the specified [arg user] is known to the database,
+else false.
+
+[call [arg dbName] [method who]]
+
+Returns a list of users known to the database.
+
+[call [arg dbName] [method save] [opt [arg file]]]
+
+Saves the contents of the database into the given [arg file]. If the
+file is not specified the system will use the path last used in a call
+to [arg dbName] [method read]. The generated file can be read by the
+[method read] method.
+
+[call [arg dbName] [method read] [arg file]]
+
+Reads the specified [arg file] and adds the contained user definitions
+to the database. As the file is actually [cmd source]'d a safe
+interpreter is employed to safeguard against malicious code. This
+interpreter knows the [cmd add] command for adding users and their
+associated data to this database. This command has the same argument
+signature as the method [method add]. The path of the [arg file] is
+remembered internally so that it can be used in the next call of
+
+[arg dbName] [method save] without an argument.
+
+[list_end]
+
+[vset CATEGORY pop3d]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pop3d/pop3d_udb.tcl b/tcllib/modules/pop3d/pop3d_udb.tcl
new file mode 100644
index 0000000..f6ad710
--- /dev/null
+++ b/tcllib/modules/pop3d/pop3d_udb.tcl
@@ -0,0 +1,300 @@
+# -*- tcl -*-
+# pop3d_udb.tcl --
+#
+# Implementation of a simple user database for the pop3 server
+#
+# Copyright (c) 2002 by Andreas Kupries
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+namespace eval ::pop3d::udb {
+ # Data storage in the pop3d::udb module
+ # -------------------------------------
+ # One array per object containing the db contents. Keyed by user name.
+ # And the information about the last file data was read from.
+
+ # counter is used to give a unique name for unnamed databases
+ variable counter 0
+
+ # commands is the list of subcommands recognized by the server
+ variable commands [list \
+ "add" \
+ "destroy" \
+ "exists" \
+ "lookup" \
+ "read" \
+ "remove" \
+ "rename" \
+ "save" \
+ "who" \
+ ]
+}
+
+
+# ::pop3d::udb::new --
+#
+# Create a new user database with a given name; if no name is given, use
+# p3udbX, where X is a number.
+#
+# Arguments:
+# name name of the user database; if null, generate one.
+#
+# Results:
+# name name of the user database created
+
+proc ::pop3d::udb::new {{name ""}} {
+ variable counter
+
+ if { [llength [info level 0]] == 1 } {
+ incr counter
+ set name "p3udb${counter}"
+ }
+
+ if { ![string equal [info commands ::$name] ""] } {
+ return -code error \
+ "command \"$name\" already exists,\
+ unable to create user database"
+ }
+
+ # Set up the namespace
+ namespace eval ::pop3d::udb::udb::$name {
+ variable user ; array set user {}
+ variable lastfile ""
+ }
+
+ # Create the command to manipulate the user database
+ interp alias {} ::$name {} ::pop3d::udb::UdbProc $name
+
+ return $name
+}
+
+##########################
+# Private functions follow
+
+# ::pop3d::udb::UdbProc --
+#
+# Command that processes all user database object commands.
+#
+# Arguments:
+# name name of the user database object to manipulate.
+# args command name and args for the command
+#
+# Results:
+# Varies based on command to perform
+
+proc ::pop3d::udb::UdbProc {name {cmd ""} args} {
+
+ # Do minimal args checks here
+ if { [llength [info level 0]] == 2 } {
+ return -code error \
+ "wrong # args: should be \"$name option ?arg arg ...?\""
+ }
+
+ # Split the args into command and args components
+ if { [llength [info commands ::pop3d::udb::_$cmd]] == 0 } {
+ variable commands
+ set optlist [join $commands ", "]
+ set optlist [linsert $optlist "end-1" "or"]
+ return -code error "bad option \"$cmd\": must be $optlist"
+ }
+ eval [list ::pop3d::udb::_$cmd $name] $args
+}
+
+
+# ::pop3d::udb::_destroy --
+#
+# Destroy a user database, including its associated command and
+# data storage.
+#
+# Arguments:
+# name Name of the database to destroy.
+#
+# Results:
+# None.
+
+proc ::pop3d::udb::_destroy {name} {
+ namespace delete ::pop3d::udb::udb::$name
+ interp alias {} ::$name {}
+ return
+}
+
+
+proc ::pop3d::udb::_add {name usrName password storage} {
+ # @c Add the user <a usrName> to the database, together with its
+ # @c password and a storage reference. The latter is stored and passed
+ # @c through this system without interpretation of the given value.
+
+ # @a usrName: The name of the user defined here.
+ # @a password: Password given to the user.
+ # @a storage: symbolic reference to the maildrop of user <a usrName>.
+ # @a storage: Usable for a storage system only.
+
+ if {$usrName == {}} {return -code error "user specification missing"}
+ if {$password == {}} {return -code error "password not specified"}
+ if {$storage == {}} {return -code error "storage location not defined"}
+
+ upvar ::pop3d::udb::udb::${name}::user user
+
+ set user($usrName) [list $password $storage]
+ return
+}
+
+
+proc ::pop3d::udb::_remove {name usrName} {
+ # @c Remove the user <a usrName> from the database.
+ #
+ # @a usrName: The name of the user to remove.
+
+ if {$usrName == {}} {return -code error "user specification missing"}
+
+ upvar ::pop3d::udb::udb::${name}::user user
+
+ if {![::info exists user($usrName)]} {
+ return -code error "user \"$usrName\" not known"
+ }
+
+ unset user($usrName)
+ return
+}
+
+
+proc ::pop3d::udb::_rename {name usrName newName} {
+ # @c Renames user <a usrName> to <a newName>.
+ # @a usrName: The name of the user to rename.
+ # @a newName: The new name to give to the user
+
+ if {$usrName == {}} {return -code error "user specification missing"}
+ if {$newName == {}} {return -code error "user specification missing"}
+
+ upvar ::pop3d::udb::udb::${name}::user user
+
+ if {![::info exists user($usrName)]} {
+ return -code error "user \"$usrName\" not known"
+ }
+ if {[::info exists user($newName)]} {
+ return -code error "user \"$newName\" is known"
+ }
+
+ set data $user($usrName)
+ unset user($usrName)
+
+ set user($newName) $data
+ return
+}
+
+
+proc ::pop3d::udb::_lookup {name usrName} {
+ # @c Query database for information about user <a usrName>.
+ # @c Overrides <m userdbBase:lookup>.
+ # @a usrName: Name of the user to query for.
+ # @r a 2-element list containing password and storage
+ # @r reference for user <a usrName>, in this order.
+
+ upvar ::pop3d::udb::udb::${name}::user user
+
+ if {![::info exists user($usrName)]} {
+ return -code error "user \"$usrName\" not known"
+ }
+ return $user($usrName)
+}
+
+
+proc ::pop3d::udb::_exists {name usrName} {
+ # @c Determines wether user <a usrName> is registered or not.
+ # @a usrName: The name of the user to check for.
+
+ upvar ::pop3d::udb::udb::${name}::user user
+
+ return [::info exists user($usrName)]
+}
+
+
+proc ::pop3d::udb::_who {name} {
+ # @c Determines the names of all registered users.
+ # @r A list containing the names of all registered users.
+
+ upvar ::pop3d::udb::udb::${name}::user user
+
+ return [array names user]
+}
+
+
+proc ::pop3d::udb::_save {name {file {}}} {
+ # @c Stores the current contents of the in-memory user database
+ # @c into the specified file.
+
+ # @a file: The name of the file to write to. If it is not specified, or
+ # @a file: as empty, the value of the member variable <v externalFile>
+ # @a file: is used instead.
+
+ # save operation: do a backup of the file, write new contents,
+ # restore backup in case of problems.
+
+ upvar ::pop3d::udb::udb::${name}::user user
+ upvar ::pop3d::udb::udb::${name}::lastfile lastfile
+
+ if {$file == {}} {
+ set file $lastfile
+ }
+ if {$file == {}} {
+ return -code error "No file known to save data into"
+ }
+
+ set tmp [file join [file dirname $file] [pid]]
+
+ set f [open $tmp w]
+ puts $f "# -*- tcl -*-"
+ puts $f "# ----------- user authentication database -"
+ puts $f ""
+
+ foreach name [array names user] {
+ set password [lindex $user($name) 0]
+ set storage [lindex $user($name) 1]
+
+ puts $f "\tadd [list $name] [list $password] [list $storage]"
+ }
+
+ puts $f ""
+ close $f
+
+ if {[file exists $file]} {
+ file rename -force $file $file.old
+ }
+ file rename -force $tmp $file
+ return
+}
+
+
+proc ::pop3d::udb::_read {name path} {
+ # @c Reads the contents of the specified <a path> into the in-memory
+ # @c database of users, passwords and storage references.
+
+ # @a path: The name of the file to read.
+
+ # @n The name of the file is remembered internally, and used by
+ # @n <m save> (if called without or empty argument).
+
+ upvar ::pop3d::udb::udb::${name}::user user
+ upvar ::pop3d::udb::udb::${name}::lastfile lastfile
+
+ if {$path == {}} {
+ return -code error "No file known to read from"
+ }
+
+ set lastfile $path
+
+ foreach key [array names user] {unset user($key)}
+
+ set ip [interp create -safe]
+ interp alias $ip add {} ::pop3d::udb::_add $name
+ $ip invokehidden -global source $path
+ interp delete $ip
+
+ return
+}
+
+##########################
+# Module initialization
+
+package provide pop3d::udb 1.1
diff --git a/tcllib/modules/pop3d/pop3d_udb.test b/tcllib/modules/pop3d/pop3d_udb.test
new file mode 100644
index 0000000..57bc81c
--- /dev/null
+++ b/tcllib/modules/pop3d/pop3d_udb.test
@@ -0,0 +1,244 @@
+# -*- tcl -*-
+# pop3_udb.test: tests for the simple pop3 user database.
+#
+# 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) 2002 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pop3d_udb.test,v 1.7 2006/10/09 21:41:41 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.2
+testsNeedTcltest 1.0
+
+testing {
+ useLocal pop3d_udb.tcl pop3d::udb
+}
+
+# ----------------------------------------------------------------------
+
+test pop3-udb-1.0 {anon create/destroy} {
+ set udb [::pop3d::udb::new]
+ $udb destroy
+ regsub {[0-9]+$} $udb {} udb
+ set udb
+} p3udb
+
+test pop3-udb-1.1 {named create/destroy} {
+ set udb [::pop3d::udb::new foo]
+ $udb destroy
+ set udb
+} foo
+
+test pop3-udb-1.2 {multiple create} {
+ ::pop3d::udb::new foo
+ catch {::pop3d::udb::new foo} msg
+ foo destroy
+ set msg
+} {command "foo" already exists, unable to create user database}
+
+test pop3-udb-1.3 {correct creation, destruction} {
+ ::pop3d::udb::new foo
+ set res [list [info exists ::pop3d::udb::udb::foo::lastfile]]
+ foo destroy
+ lappend res [info exists ::pop3d::udb::udb::foo::lastfile]
+} {1 0}
+
+test pop3-udb-1.4 {unknown method} {
+ set udb [::pop3d::udb::new]
+ catch {$udb foo} res
+ $udb destroy
+ set res
+} {bad option "foo": must be add, destroy, exists, lookup, read, remove, rename, save, or who}
+
+
+test pop3-udb-2.0 {adding entries, created empty} {
+ set udb [::pop3d::udb::new]
+ set res [$udb who]
+ $udb destroy
+ set res
+} {}
+
+test pop3-udb-2.1 {adding entries} {
+ set udb [::pop3d::udb::new]
+ $udb add bar blurb ****
+ set res [$udb who]
+ $udb destroy
+ set res
+} {bar}
+
+test pop3-udb-2.2 {adding entries, missing user} {
+ set udb [::pop3d::udb::new]
+ catch {$udb add {} blurb ****} res
+ $udb destroy
+ set res
+} {user specification missing}
+
+test pop3-udb-2.3 {adding entries, missing passwd} {
+ set udb [::pop3d::udb::new]
+ catch {$udb add bar {} ****} res
+ $udb destroy
+ set res
+} {password not specified}
+
+test pop3-udb-2.4 {adding entries, missing storage} {
+ set udb [::pop3d::udb::new]
+ catch {$udb add bar blurb {}} res
+ $udb destroy
+ set res
+} {storage location not defined}
+
+
+test pop3-udb-3.0 {removing entries} {
+ set udb [::pop3d::udb::new]
+ $udb add bar blurb ****
+ set res [list [$udb who]]
+ $udb remove bar
+ lappend res [$udb who]
+ $udb destroy
+ set res
+} {bar {}}
+
+test pop3-udb-3.1 {removing entries} {
+ set udb [::pop3d::udb::new]
+ catch {$udb remove bar} res
+ $udb destroy
+ set res
+} {user "bar" not known}
+
+test pop3-udb-3.2 {removing entries} {
+ set udb [::pop3d::udb::new]
+ catch {$udb remove {}} res
+ $udb destroy
+ set res
+} {user specification missing}
+
+
+test pop3-udb-4.0 {renaming entries} {
+ set udb [::pop3d::udb::new]
+ $udb add bar blurb ****
+ set res [list [$udb who]]
+ $udb rename bar booze
+ lappend res [$udb who]
+ $udb destroy
+ set res
+} {bar booze}
+
+test pop3-udb-4.1 {renaming entries} {
+ set udb [::pop3d::udb::new]
+ catch {$udb rename {} {}} res
+ $udb destroy
+ set res
+} {user specification missing}
+
+test pop3-udb-4.2 {renaming entries} {
+ set udb [::pop3d::udb::new]
+ catch {$udb rename bar {}} res
+ $udb destroy
+ set res
+} {user specification missing}
+
+test pop3-udb-4.3 {renaming entries} {
+ set udb [::pop3d::udb::new]
+ catch {$udb rename bar floss} res
+ $udb destroy
+ set res
+} {user "bar" not known}
+
+test pop3-udb-4.4 {renaming entries} {
+ set udb [::pop3d::udb::new]
+ $udb add bar blurb ****
+ $udb add booze blurb ****
+ catch {$udb rename bar booze} res
+ $udb destroy
+ set res
+} {user "booze" is known}
+
+
+test pop3-udb-5.0 {searching for entries} {
+ set udb [::pop3d::udb::new]
+ $udb add bar blurb ****
+ set res [$udb lookup bar]
+ $udb destroy
+ set res
+} {blurb ****}
+
+test pop3-udb-5.1 {searching for entries} {
+ set udb [::pop3d::udb::new]
+ catch {$udb lookup bar} res
+ $udb destroy
+ set res
+} {user "bar" not known}
+
+
+test pop3-udb-6.0 {existence of entries} {
+ set udb [::pop3d::udb::new]
+ $udb add bar blurb ****
+ set res [$udb exists bar]
+ $udb destroy
+ set res
+} 1
+
+test pop3-udb-6.1 {existence of entries} {
+ set udb [::pop3d::udb::new]
+ set res [$udb exists bar]
+ $udb destroy
+ set res
+} 0
+
+# = who = already tested as part of add/remove
+
+
+test pop3-udb-7.0 {save database} {
+ makeFile {} __UDB__
+ makeFile {} __UDB__.old
+ set udb [::pop3d::udb::new]
+ $udb add bar blurb ****
+ $udb add booze Xblurb ***X
+ $udb save __UDB__
+ $udb destroy
+ set res [viewFile __UDB__]
+ removeFile __UDB__
+ removeFile __UDB__.old
+ set res
+} {# -*- tcl -*-
+# ----------- user authentication database -
+
+ add bar blurb ****
+ add booze Xblurb ***X
+}
+
+test pop3-udb-7.1 {read database} {
+ makeFile {} __UDB__
+ makeFile {} __UDB__.old
+ set udb [::pop3d::udb::new]
+ $udb add bar blurb ****
+ $udb add booze Xblurb ***X
+ $udb save __UDB__
+ $udb destroy
+
+ set udb [::pop3d::udb::new]
+ $udb read __UDB__
+ set res [list [lsort [$udb who]]]
+ foreach u [lsort [$udb who]] {
+ lappend res [$udb lookup $u]
+ }
+ $udb destroy
+
+ removeFile __UDB__
+ removeFile __UDB__.old
+ set res
+} {{bar booze} {blurb ****} {Xblurb ***X}}
+
+
+
+# ----------------------------------------------------------------------
+testsuiteCleanup
diff --git a/tcllib/modules/processman/pkgIndex.tcl b/tcllib/modules/processman/pkgIndex.tcl
new file mode 100644
index 0000000..c4c072a
--- /dev/null
+++ b/tcllib/modules/processman/pkgIndex.tcl
@@ -0,0 +1,12 @@
+# 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 odie::processman 0.3 [list source [file join $dir processman.tcl]]
+package ifneeded processman 0.3 [list source [file join $dir processman.tcl]]
diff --git a/tcllib/modules/processman/processman.man b/tcllib/modules/processman/processman.man
new file mode 100644
index 0000000..366ad9b
--- /dev/null
+++ b/tcllib/modules/processman/processman.man
@@ -0,0 +1,74 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset PACKAGE_VERSION 0.1]
+[manpage_begin processman n [vset PACKAGE_VERSION]]
+[keywords {processman}]
+[keywords {odie}]
+[copyright {2015 Sean Woods <yoda@etoyoc.com>}]
+[moddesc {processman}]
+[titledesc {Tool for automating the period callback of commands}]
+[category System]
+[require Tcl 8.5]
+[require twapi 3.1]
+[require cron 1.1]
+[require processman [opt [vset PACKAGE_VERSION]]]
+[description]
+[para]
+
+The [package processman] package provides a Pure-tcl set of utilities
+to manage child processes in a platform-generic nature.
+
+[section Commands]
+[list_begin definitions]
+
+[call [cmd ::processman::find_exe] [arg name]]
+
+Locate an executable by the name of [arg name] in the system path. On windows,
+also add the .exe extention if not given.
+
+[call [cmd ::processman::kill] [arg id]]
+
+Kill a child process [arg id].
+
+[call [cmd ::processman::kill_all]]
+
+Kill all processes spawned by this program
+
+[call [cmd ::processman::killexe] [arg name]]
+
+Kill a process identified by the executable. On Unix, this triggers a killall.
+On windows, [cmd twapi::get_process_ids] is used to map a name one or more IDs,
+which are then killed.
+
+[call [cmd ::processman::onexit] [arg id] [arg cmd]]
+
+Arrange to execute the script [arg cmd] when this programe detects that
+process [arg id] as terminated.
+
+[call [cmd ::processman::priority] [arg id] [arg level]]
+
+Mark process [arg id] with the priorty [arg level]. Valid levels: low, high, default.
+[para]
+On Unix, the process is tagged using the [cmd nice] command.
+[para]
+On Windows, the process is modifed via the [cmd twapi::set_priority_class]
+
+[call [cmd ::processman::process_list]]
+
+Return a list of processes that have been triggered by this program, as
+well as a boolean flag to indicate if the process is still running.
+
+
+[call [cmd ::processman::process_list] [arg id]]
+
+Return true if process [arg id] is still running, false otherwise.
+
+[call [cmd ::processman::spawn] [arg id] [arg cmd] [arg args]]
+
+Start a child process, identified by [arg id]. [arg cmd] is the name
+of the command to execute. [arg args] are arguments to pass to that command.
+
+[list_end]
+[para]
+[vset CATEGORY odie]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/processman/processman.tcl b/tcllib/modules/processman/processman.tcl
new file mode 100644
index 0000000..74f99a3
--- /dev/null
+++ b/tcllib/modules/processman/processman.tcl
@@ -0,0 +1,270 @@
+###
+# IRM External Process Manager
+###
+
+package require cron 1.1
+
+::namespace eval ::processman {}
+
+if { $::tcl_platform(platform) eq "windows" } {
+ package require twapi
+} else {
+ ###
+ # Try to utilize C level utilities that are bundled
+ # with either TclX or Odielib
+ ###
+ if [catch {package require odielib}] {
+ catch {package require Tclx}
+ }
+ if {[info commands subprocess_exists] eq {}} {
+ proc ::processman::subprocess_exists pid {
+ set dat [exec ps]
+ foreach line [split $dat \n] {
+ if {![scan $line "%d %s" thispid rest]} continue
+ if { $thispid eq $pid} {
+ return $thispid
+ }
+ }
+ return 0
+ }
+ }
+ if {[info commands kill_subprocess] eq {}} {
+ proc ::processman::kill_subprocess pid {
+ catch {exec kill $pid}
+ }
+ }
+}
+if {[info commands harvest_zombies] eq {}} {
+ proc ::processman::harvest_zombies args {
+ }
+}
+
+###
+# topic: a0cdb7503872cd302756c732956cd5c3
+# title: Periodic scan of the state of processes
+###
+proc ::processman::events {} {
+ variable process_binding
+ foreach {id bind} $process_binding {
+ if {![running $id]} {
+ kill $id
+ catch {eval $bind}
+ }
+ }
+}
+
+###
+# topic: 95edbb845e0a8802b1cc3119516a6502
+# title: Locate and executable of name
+###
+proc ::processman::find_exe name {
+ global tcl_platform
+ if {$tcl_platform(platform)=="windows"} {set suffix .exe} {set suffix {}}
+ foreach f [list $name ~/irm/bin/$name ./$name/$name ./$name ../$name/$name ../../$name/$name] {
+ if {[file executable $f]} break
+ append f $suffix
+ if {[file executable $f]} break
+ }
+ if {![file executable $f]} {
+ error "Cannot find the $name executable"
+ return {}
+ }
+ return $f
+}
+
+###
+# topic: ac021b1116f0c1d5e3319d9f333f0c89
+# title: Kill a process
+###
+proc ::processman::kill id {
+ variable process_list
+ variable process_binding
+ global tcl_platform
+
+ if {![dict exists $process_list $id]} {
+ return
+ }
+ foreach pid [dict get $process_list $id] {
+ if { $tcl_platform(platform) eq "unix" } {
+ catch {kill_subprocess $pid}
+ } elseif { $tcl_platform(platform) eq "windows" } {
+ catch {::twapi::end_process $pid}
+ }
+ }
+ dict set process_list $id {}
+ dict unset process_binding $id
+ harvest_zombies
+}
+
+###
+# topic: 8987329d60cd1adc766e09a0227f87b6
+# title: Kill all processes spawned by this program
+###
+proc ::processman::kill_all {} {
+ variable process_list
+ if {![info exists process_list]} {
+ return {}
+ }
+ foreach {name pidlist} $process_list {
+ kill $name
+ }
+ harvest_zombies
+}
+
+###
+# topic: 17a9014236425560140ba62bbb2745a8
+# title: Kill a process
+###
+proc ::processman::killexe name {
+ if {$::tcl_platform(platform) eq "windows" } {
+ set pids [twapi::get_process_ids -name $name.exe]
+ foreach pid $pids {
+ # Catch the error in case process does not exist any more
+ catch {twapi::end_process $pid}
+ }
+ #catch {exec taskkill /F /IM $name.exe} err
+ puts $err
+ } else {
+ catch {exec killall -9 $name} err
+ ##puts $err
+ }
+ harvest_zombies
+}
+
+###
+# topic: 02406b2a7edd05c887554384ad2db41f
+# title: Issue a command when process {$id} exits
+###
+proc ::processman::onexit {id cmd} {
+ variable process_binding
+ if {![running $id]} {
+ catch {eval $cmd}
+ return
+ }
+ dict set process_binding $id $cmd
+}
+
+###
+# topic: ee784ae29e5b66867a30428b3095dc65
+# title: Changes priority of task
+###
+proc ::processman::priority {id level} {
+ variable process_list
+
+ set pid [running $id]
+ if {![string is integer $pid]} {
+ set pid 0
+ }
+ if {!$pid} {
+ return
+ }
+ if { $::tcl_platform(platform) eq "windows" } {
+ package require twapi
+ switch $level {
+ low {
+ twapi::set_priority_class $pid 0x4000
+ }
+ high {
+ twapi::set_priority_class $pid 0x20
+ }
+ default {
+ twapi::set_priority_class $pid 0x8000
+ }
+ }
+ } else {
+ switch $level {
+ low {
+ exec renice -n 10 -p $pid
+ }
+ high {
+ exec renice -n -5 -p $pid
+ }
+ default {
+ exec renice -n 0 -p $pid
+ }
+ }
+ }
+}
+
+###
+# topic: 8bccf62b4fa11949dba4c85e05d116e9
+# title: Return a list of processes and their current state
+###
+proc ::processman::process_list {} {
+ variable process_list
+ if {![info exists process_list]} {
+ return {}
+ }
+ set result {}
+ foreach {name pidlist} $process_list {
+ foreach pid $pidlist {
+ lappend result $name $pid [subprocess_exists $pid]
+ }
+ }
+ return $result
+}
+
+###
+# topic: 96b4b2c53ea1554006417e507197488c
+# title: Test if a process is running
+###
+proc ::processman::running id {
+ variable process_list
+ if {![dict exists $process_list $id]} {
+ return 0
+ }
+ foreach pid [dict get $process_list $id] {
+ if { $::tcl_platform(platform) eq "windows" } {
+ if {[::twapi::process_exists $pid]} {
+ return $pid
+ }
+ } else {
+ if {[subprocess_exists $pid]} {
+ return $pid
+ }
+ }
+ }
+ return 0
+}
+
+###
+# topic: 61694ad97dbac52351431ad0d8c448e3
+# title: Launch a task in the background
+###
+proc ::processman::spawn {id command args} {
+ variable process_list
+ if {[llength $command] == 1} {
+ set command [lindex $command 0]
+ }
+ if {$::tcl_platform(platform) eq "windows"} {
+ set pid [exec "$command" {*}$args &]
+ } else {
+ set pid [exec $command {*}$args &]
+ }
+ dict lappend process_list $id $pid
+ return $pid
+}
+
+###
+# topic: 56fbf345652c5ca18543a67a6bc95787
+# title: Process Management Tools
+###
+namespace eval ::processman {
+###
+# initialize tables
+###
+
+variable process_list
+variable process_binding
+if { ![info exists process_list]} {
+ set process_list {}
+}
+if {![info exists process_binding]} {
+ set process_binding {}
+}
+}
+
+::cron::every processman 60 ::processman::events
+
+package provide odie::processman 0.3
+package provide processman 0.3
diff --git a/tcllib/modules/profiler/ChangeLog b/tcllib/modules/profiler/ChangeLog
new file mode 100644
index 0000000..f5b3fd3
--- /dev/null
+++ b/tcllib/modules/profiler/ChangeLog
@@ -0,0 +1,258 @@
+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-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>
+
+ * profiler.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-09-27 Andreas Kupries <andreask@activestate.com>
+
+ * profiler.test: [SF Tcllib Bug 1272913]. Fixed. Added constraint
+ for 8.4- specific tests, duplicated testcase profiler-7.2 to
+ capture the differences in results generated by 8.5+ vs 8.4-.
+
+2006-09-19 Andreas Kupries <andreask@activestate.com>
+
+ * profiler.man: Bumped version to 0.3
+ * profiler.tcl:
+ * pkgIndex.tcl:
+
+2006-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * profiler.test: More boilerplate simplified via use of test support.
+
+2006-01-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * profiler.test: Hooked into the new common test support code.
+
+2005-11-02 David N. Welton <davidw@dedasys.com>
+
+ * profiler.tcl (::profiler::printsorted): Added a printsorted proc
+ in order to print stuff out sorted with different keys.
+
+2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.8 ========================
+ *
+
+2005-04-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * profiler.man: Synchronized indexed and provided versions.
+ * pkgIndex.tcl
+
+2005-03-30 Eric Melski <ericm@electric-cloud.com>
+
+ * profiler.tcl (::profiler::TraceHandler): Make sure that caller names
+ always have a :: prefix, to avoid getting confused by "::foo" versus
+ "foo", which actually refer to the same procedure [Bug 1172938].
+ Incremented version number to 0.2.3.
+
+ * profiler.test: Added tests to verify fix for Bug 1172938.
+
+2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.7 ========================
+ *
+
+2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6.1 ========================
+ *
+
+2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.6 ========================
+ *
+
+2004-02-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * profiler.tcl (stats): Bugfix by Bob Techentin, preventing a
+ division by zero if the average time has become zero.
+
+2003-10-29 Andreas Kupries <andreask@activestate.com>
+
+ * profiler.man: Updated documented signature of 'reset', missed
+ the pattern argument [Bug 832487].
+
+2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.4 ========================
+ *
+
+2003-05-02 Andreas Kupries <andreask@activestate.com>
+
+ * profiler.test: found a test failing for 8.5 due to incomplete
+ auto_path propagation and setup. Fixed.
+
+2003-04-29 Pat Thoyts <patthoyts@users.sourceforge.net>
+
+ * profiler.tcl (::profiler::stats): Check for sum being zero when
+ using tcl < 8.4 (no execution trace available). Prevents a divide
+ by zero error.
+
+2003-04-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * profiler.test:
+ * profiler.tcl: Accepted patch #575376 by Hemang Lavana
+ <hemanglavana@users.sourceforge.net> reorganizing the internals
+ a bit and using the 8.4 specific trace support if possible.
+
+2003-04-11 Andreas Kupries <andreask@activestate.com>
+
+ * profiler.tcl:
+ * profiler.man:
+ * pkgIndex.tcl: Set version of the package to to 0.2.1.
+
+2003-02-24 David N. Welton <davidw@dedasys.com>
+
+ * profiler.tcl (::profiler::tZero): Use string map instead of
+ regsub.
+
+2003-02-06 David N. Welton <davidw@dedasys.com>
+
+ * profiler.tcl (::profiler::profProc): Use string match instead of
+ regexp.
+
+2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * profiler.man: More semantic markup, less visual one.
+
+2002-10-14 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * profiler.tcl (dump): required result initialization. [Bug #564767]
+
+2002-04-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * profiler.man: Added doctools manpage.
+
+2001-08-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pkgIndex.tcl: Moved version to 0.2.
+
+ * profiler.test: Adapted testsuite.
+
+ * profiler.n: Added documentation. Same patch as below.
+
+ * profiler.tcl: Applied patch [446799] by Hemang Lavana
+ <hemanglavana@users.sourceforge.net>, adding support for
+ resume/suspend operations to the profiler. moved version to 0.2.
+
+2001-07-31 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * profiler.tcl (Handler): Fixed [446562].
+
+2001-07-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * profiler.tcl: Frink 2.2 run, fixed dubious code.
+
+2001-06-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * profiler.tcl: Fixed dubious code reported by frink.
+
+2000-09-20 Eric Melski <ericm@ajubasolutions.com>
+
+ * profiler.tcl: Corrected some non-Tcl-style-guide conforming
+ function headers.
+
+2000-06-15 Eric Melski <ericm@ajubasolutions.com>
+
+ * profiler.tcl: Added mods from Philip Ehrens
+ <pehrens@ligo.caltech.edu> to changed formatting, add additional
+ statistics. [RFE: 5060]
+
+2000-03-27 Eric Melski <ericm@scriptics.com>
+
+ * profiler.tcl: Added a check for [clock clicks] wrapping.
+
+2000-03-20 Eric Melski <ericm@scriptics.com>
+
+ * profiler.test:
+ * profiler.tcl: Fixed issue with printing of descendants.
+
+2000-03-09 Eric Melski <ericm@scriptics.com>
+
+ * profiler.test: Adapted tests to work inside and outside of
+ tcllib test framework.
+
+2000-03-08 Eric Melski <ericm@scriptics.com>
+
+ * profiler.test:
+ * profiler.tcl: Added tracking of descendant time; changed
+ definition of total time to include compile time (which makes
+ determination of exclusive time (time in a function but not in its
+ descendants) easier).
+
+2000-03-03 Eric Melski <ericm@scriptics.com>
+
+ * profiler.tcl: Added profiler::reset function and enhanced
+ profiler::sortFunctions
+
+ * profiler.n: Updated documentation.
+
+2000-02-24 Eric Melski <ericm@scriptics.com>
+
+ * profiler.tcl: Fixed dump command output to include
+ the name of the function being dumped.
+
+2000-02-17 Eric Melski <ericm@scriptics.com>
+
+ * pkgIndex.tcl: package index for profiler.
+
+ * man.macros:
+ * profiler.n: Doc for profiler.
+
+ * profiler.test: Tests for profiler.
+
+ * profiler.tcl: Simple Tcl function-level profiler.
+
diff --git a/tcllib/modules/profiler/pkgIndex.tcl b/tcllib/modules/profiler/pkgIndex.tcl
new file mode 100644
index 0000000..f0a94e3
--- /dev/null
+++ b/tcllib/modules/profiler/pkgIndex.tcl
@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.3]} {return}
+package ifneeded profiler 0.3 [list source [file join $dir profiler.tcl]]
diff --git a/tcllib/modules/profiler/profiler.man b/tcllib/modules/profiler/profiler.man
new file mode 100644
index 0000000..1737264
--- /dev/null
+++ b/tcllib/modules/profiler/profiler.man
@@ -0,0 +1,121 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin profiler n 0.3]
+[keywords performance]
+[keywords profile]
+[keywords speed]
+[moddesc {Tcl Profiler}]
+[titledesc {Tcl source code profiler}]
+[category {Programming tools}]
+[require Tcl 8.3]
+[require profiler [opt 0.3]]
+[description]
+[para]
+
+The [package profiler] package provides a simple Tcl source code
+profiler. It is a function-level profiler; that is, it collects only
+function-level information, not the more detailed line-level
+information. It operates by redefining the Tcl [cmd proc] command.
+Profiling is initiated via the [cmd ::profiler::init] command.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::profiler::init]]
+
+Initiate profiling. All procedures created after this command is
+called will be profiled. To profile an entire application, this
+command must be called before any other commands.
+
+[call [cmd ::profiler::dump] [arg pattern]]
+
+Dump profiling information for the all functions matching
+
+[arg pattern]. If no pattern is specified, information for all
+functions will be returned. The result is a list of key/value pairs
+that maps function names to information about that function. The
+information about each function is in turn a list of key/value pairs.
+The keys used and their values are:
+
+[list_begin definitions]
+
+[def [const totalCalls]]
+
+The total number of times [arg functionName] was called.
+
+[def [const callerDist]]
+
+A list of key/value pairs mapping each calling function that called
+[arg functionName] to the number of times it called
+
+[arg functionName].
+
+[def [const compileTime]]
+
+The runtime, in clock clicks, of [arg functionName] the first time
+that it was called.
+
+[def [const totalRuntime]]
+
+The sum of the runtimes of all calls of [arg functionName].
+
+[def [const averageRuntime]]
+
+Average runtime of [arg functionName].
+
+[def [const descendantTime]]
+
+Sum of the time spent in descendants of [arg functionName].
+
+[def [const averageDescendantTime]]
+
+Average time spent in descendants of [arg functionName].
+
+[list_end]
+
+[call [cmd ::profiler::print] [opt [arg pattern]]]
+
+Print profiling information for all functions matching [arg pattern].
+If no pattern is specified, information about all functions will be
+displayed. The return result is a human readable display of the
+profiling information.
+
+[call [cmd ::profiler::reset] [opt [arg pattern]]]
+
+Reset profiling information for all functions matching [arg pattern].
+If no pattern is specified, information will be reset for all
+functions.
+
+[call [cmd ::profiler::suspend] [opt [arg pattern]]]
+
+Suspend profiling for all functions matching [arg pattern]. If no
+pattern is specified, profiling will be suspended for all
+functions. It stops gathering profiling information after this command
+is issued. However, it does not erase any profiling information that
+has been gathered previously. Use resume command to re-enable
+profiling.
+
+[call [cmd ::profiler::resume] [opt [arg pattern]]]
+
+Resume profiling for all functions matching [arg pattern]. If no
+pattern is specified, profiling will be resumed for all functions.
+This command should be invoked after suspending the profiler in the
+code.
+
+[call [cmd ::profiler::sortFunctions] [arg key]]
+
+Return a list of functions sorted by a particular profiling statistic.
+Supported values for [arg key] are: [const calls],
+
+[const exclusiveTime], [const compileTime], [const nonCompileTime],
+[const totalRuntime], [const avgExclusiveTime], and
+
+[const avgRuntime]. The return result is a list of lists, where each
+sublist consists of a function name and the value of [arg key] for
+that function.
+
+[list_end]
+
+[vset CATEGORY profiler]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/profiler/profiler.tcl b/tcllib/modules/profiler/profiler.tcl
new file mode 100644
index 0000000..5756e8a
--- /dev/null
+++ b/tcllib/modules/profiler/profiler.tcl
@@ -0,0 +1,638 @@
+# profiler.tcl --
+#
+# Tcl code profiler.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: profiler.tcl,v 1.29 2006/09/19 23:36:17 andreas_kupries Exp $
+
+package require Tcl 8.3 ;# uses [clock clicks -milliseconds]
+package provide profiler 0.3
+
+namespace eval ::profiler {
+}
+
+# ::profiler::tZero --
+#
+# Start a named timer instance
+#
+# Arguments:
+# tag name for the timer instance; if none is given, defaults to ""
+#
+# Results:
+# None.
+
+proc ::profiler::tZero { { tag "" } } {
+ set ms [ clock clicks -milliseconds ]
+ set us [ clock clicks ]
+ set tag [string map {: ""} $tag]
+ # FRINK: nocheck
+ set ::profiler::T$tag [ list $us $ms ]
+ return
+}
+
+# ::profiler::tMark --
+#
+# Return the delta time since the start of a named timer.
+#
+# Arguments:
+# tag Tag for which to return a delta; if none is given, defaults to
+# ""
+#
+# Results:
+# dt Time difference between start of the timer and the current
+# time, in microseconds.
+
+proc ::profiler::tMark { { tag "" } } {
+ set ut [ clock clicks ]
+ set mt [ clock clicks -milliseconds ]
+ set tag [string map {: ""} $tag]
+
+ # Per tag a variable was created within the profiler
+ # namespace. But we should check if the tag does ecxist.
+
+ if {![info exists ::profiler::T$tag]} {
+ error "Unknown tag \"$tag\""
+ }
+ # FRINK: nocheck
+ set ust [ lindex [ set ::profiler::T$tag ] 0 ]
+ # FRINK: nocheck
+ set mst [ lindex [ set ::profiler::T$tag ] 1 ]
+ set udt [ expr { ($ut-$ust) } ]
+ set mdt [ expr { ($mt-$mst) } ]000
+ set dt $udt
+ ;## handle wrapping of the microsecond clock
+ if { $dt < 0 || $dt > 1000000 } { set dt $mdt }
+ set dt
+}
+
+# ::profiler::stats --
+#
+# Compute statistical information for a set of values, including
+# the mean, the standard deviation, and the covariance.
+#
+# Arguments:
+# args Values for which to compute information.
+#
+# Results:
+# A list with three elements: the mean, the standard deviation, and the
+# covariance.
+
+proc ::profiler::stats {args} {
+ set sum 0
+ set mean 0
+ set sigma_sq 0
+ set sigma 0
+ set cov 0
+ set N [ llength $args ]
+ if { $N > 1 } {
+ foreach val $args {
+ incr sum $val
+ }
+ if {$sum > 0} {
+ set mean [ expr { $sum/$N } ]
+ foreach val $args {
+ set sigma_sq [ expr { $sigma_sq+pow(($val-$mean),2) } ]
+ }
+ set sigma_sq [ expr { $sigma_sq/($N-1) } ]
+ set sigma [ expr { round(sqrt($sigma_sq)) } ]
+ if { $mean != 0 } {
+ set cov [ expr { (($sigma*1.0)/$mean)*100 } ]
+ set cov [ expr { round($cov*10)/10.0 } ]
+ }
+ }
+ }
+ return [ list $mean $sigma $cov ]
+}
+
+# ::profiler::Handler --
+#
+# Profile a function (tcl8.3). This function works together with
+# profProc, which replaces the proc command. When a new procedure
+# is defined, it creates and alias to this function; when that
+# procedure is called, it calls this handler first, which gathers
+# profiling information from the call.
+#
+# Arguments:
+# name name of the function to profile.
+# args arguments to pass to the original function.
+#
+# Results:
+# res result from the original function.
+
+proc ::profiler::Handler {name args} {
+ variable enabled
+
+ if { [info level] == 1 } {
+ set caller GLOBAL
+ } else {
+ # Get the name of the calling procedure
+ set caller [lindex [info level -1] 0]
+ # Remove the ORIG suffix
+ set caller [string range $caller 0 end-4]
+
+ # Make sure that caller names always include the "::" prefix;
+ # otherwise we get confused by the string inequality between
+ # "::foo" and "foo" -- even though those refer to the same proc.
+
+ if { ![string equal -length 2 $caller "::"] } {
+ set caller "::$caller"
+ }
+ }
+
+ ::profiler::enterHandler $name $caller
+ set CODE [uplevel 1 [list ${name}ORIG] $args]
+ ::profiler::leaveHandler $name $caller
+ return $CODE
+}
+
+# ::profiler::TraceHandler --
+#
+# Profile a function (tcl8.4+). This function works together with
+# profProc, which replaces the proc command. When a new procedure
+# is defined, it creates an execution trace on the function; when
+# that function is called, 'enter' and 'leave' traces invoke this
+# handler first, which gathers profiling information from the call.
+#
+# Arguments:
+# name name of the function to profile.
+# cmd command name and its expanded arguments.
+# args for 'enter' operation, value of args is "enter"
+# for 'leave' operation, args is list of
+# 3 elements: <code> <result> "leave"
+#
+# Results:
+# None
+
+proc ::profiler::TraceHandler {name cmd args} {
+
+ if { [info level] == 1 } {
+ set caller GLOBAL
+ } else {
+ # Get the name of the calling procedure
+ set caller [lindex [info level -1] 0]
+
+ # Make sure that caller names always include the "::" prefix;
+ # otherwise we get confused by the string inequality between
+ # "::foo" and "foo" -- even though those refer to the same proc.
+
+ if { ![string equal -length 2 $caller "::"] } {
+ set caller "::$caller"
+ }
+ }
+
+ set type [lindex $args end]
+ ::profiler::${type}Handler $name $caller
+}
+
+# ::profiler::enterHandler --
+#
+# Profile a function. This function works together with Handler and
+# TraceHandler to collect profiling information just before it invokes
+# the function.
+#
+# Arguments:
+# name name of the function to profile.
+# caller name of the function that calls the profiled function.
+#
+# Results:
+# None
+
+proc ::profiler::enterHandler {name caller} {
+ variable enabled
+
+ if { !$enabled($name) } {
+ return
+ }
+
+ if { [catch {incr ::profiler::callers($name,$caller)}] } {
+ set ::profiler::callers($name,$caller) 1
+ }
+ ::profiler::tZero $name.$caller
+}
+
+# ::profiler::leaveHandler --
+#
+# Profile a function. This function works together with Handler and
+# TraceHandler to collect profiling information just after it invokes
+# the function.
+#
+# Arguments:
+# name name of the function to profile.
+# caller name of the function that calls the profiled function.
+#
+# Results:
+# None
+
+proc ::profiler::leaveHandler {name caller} {
+ variable enabled
+
+ if { !$enabled($name) } {
+ return
+ }
+
+ set t [::profiler::tMark $name.$caller]
+ lappend ::profiler::statTime($name) $t
+
+ if { [incr ::profiler::callCount($name)] == 1 } {
+ set ::profiler::compileTime($name) $t
+ }
+ incr ::profiler::totalRuntime($name) $t
+ if { [catch {incr ::profiler::descendantTime($caller) $t}] } {
+ set ::profiler::descendantTime($caller) $t
+ }
+ if { [catch {incr ::profiler::descendants($caller,$name)}] } {
+ set ::profiler::descendants($caller,$name) 1
+ }
+}
+
+# ::profiler::profProc --
+#
+# Replacement for the proc command that adds rudimentary profiling
+# capabilities to Tcl.
+#
+# Arguments:
+# name name of the procedure
+# arglist list of arguments
+# body body of the procedure
+#
+# Results:
+# None.
+
+proc ::profiler::profProc {name arglist body} {
+ variable callCount
+ variable compileTime
+ variable totalRuntime
+ variable descendantTime
+ variable statTime
+ variable enabled
+ variable paused
+
+ # Get the fully qualified name of the proc
+ set ns [uplevel [list namespace current]]
+ # If the proc call did not happen at the global context and it did not
+ # have an absolute namespace qualifier, we have to prepend the current
+ # namespace to the command name
+ if { ![string equal $ns "::"] } {
+ if { ![string match "::*" $name] } {
+ set name "${ns}::${name}"
+ }
+ }
+ if { ![string match "::*" $name] } {
+ set name "::$name"
+ }
+
+ # Set up accounting for this procedure
+ set callCount($name) 0
+ set compileTime($name) 0
+ set totalRuntime($name) 0
+ set descendantTime($name) 0
+ set statTime($name) {}
+ set enabled($name) [expr {!$paused}]
+
+ if {[package vsatisfies [package provide Tcl] 8.4]} {
+ uplevel 1 [list ::_oldProc $name $arglist $body]
+ trace add execution $name {enter leave} \
+ [list ::profiler::TraceHandler $name]
+ } else {
+ uplevel 1 [list ::_oldProc ${name}ORIG $arglist $body]
+ uplevel 1 [list interp alias {} $name {} ::profiler::Handler $name]
+ }
+ return
+}
+
+# ::profiler::init --
+#
+# Initialize the profiler.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None. Renames proc to _oldProc and sets an alias for proc to
+# profiler::profProc
+
+proc ::profiler::init {} {
+ # paused is set to 1 when the profiler is suspended.
+ variable paused 0
+
+ rename ::proc ::_oldProc
+ interp alias {} proc {} ::profiler::profProc
+
+ return
+}
+
+# ::profiler::printname --
+#
+# Returns a string with some human readable information about
+# the command name that was passed to this procedure.
+
+proc ::profiler::printname {name} {
+ variable callCount
+ variable compileTime
+ variable totalRuntime
+ variable descendantTime
+ variable descendants
+ variable statTime
+ variable callers
+
+ set result ""
+
+ set avgRuntime 0
+ set sigmaRuntime 0
+ set covRuntime 0
+ set avgDesTime 0
+ if { $callCount($name) > 0 } {
+ foreach {m s c} [eval ::profiler::stats $statTime($name)] { break }
+ set avgRuntime $m
+ set sigmaRuntime $s
+ set covRuntime $c
+ set avgDesTime \
+ [expr {$descendantTime($name)/$callCount($name)}]
+ }
+
+ append result "Profiling information for $name\n"
+ append result "[string repeat = 60]\n"
+ append result " Total calls: $callCount($name)\n"
+ if { !$callCount($name) } {
+ append result "\n"
+ return $result
+ }
+ append result " Caller distribution:\n"
+ set i [expr {[string length $name] + 1}]
+ foreach index [lsort [array names callers $name,*]] {
+ append result " [string range $index $i end]: $callers($index)\n"
+ }
+ append result " Compile time: $compileTime($name)\n"
+ append result " Total runtime: $totalRuntime($name)\n"
+ append result " Average runtime: $avgRuntime\n"
+ append result " Runtime StDev: $sigmaRuntime\n"
+ append result " Runtime cov(%): $covRuntime\n"
+ append result " Total descendant time: $descendantTime($name)\n"
+ append result "Average descendant time: $avgDesTime\n"
+ append result "Descendants:\n"
+ if { !$descendantTime($name) } {
+ append result " none\n"
+ }
+ foreach index [lsort [array names descendants $name,*]] {
+ append result " [string range $index $i end]: \
+ $descendants($index)\n"
+ }
+ append result "\n"
+ return $result
+}
+
+
+# ::profiler::print --
+#
+# Print information about a proc.
+#
+# Arguments:
+# pattern pattern of the proc's to get info for; default is *.
+#
+# Results:
+# A human readable printout of info.
+
+proc ::profiler::print {{pattern *}} {
+ variable callCount
+
+ set result ""
+ foreach name [lsort [array names callCount $pattern]] {
+ append result [printname $name]
+ }
+ return $result
+}
+
+# ::profiler::printsorted --
+#
+# This proc takes a key and a pattern as arguments, and produces
+# human readable results for the procs that match the pattern,
+# sorted by the key.
+
+proc ::profiler::printsorted {key {pattern *}} {
+ variable callCount
+ variable compileTime
+ variable totalRuntime
+ variable descendantTime
+ variable descendants
+ variable statTime
+ variable callers
+
+ set data [sortFunctions $key]
+ foreach {k v} $data {
+ append result [printname [lindex $k 0]]
+ }
+ return $result
+}
+
+
+# ::profiler::dump --
+#
+# Dump out the information for a proc in a big blob.
+#
+# Arguments:
+# pattern pattern of the proc's to lookup; default is *.
+#
+# Results:
+# data data about the proc's.
+
+proc ::profiler::dump {{pattern *}} {
+ variable callCount
+ variable compileTime
+ variable totalRuntime
+ variable callers
+ variable descendantTime
+ variable descendants
+ variable statTime
+
+ set result ""
+ foreach name [lsort [array names callCount $pattern]] {
+ set i [expr {[string length $name] + 1}]
+ catch {unset thisCallers}
+ foreach index [lsort [array names callers $name,*]] {
+ set thisCallers([string range $index $i end]) $callers($index)
+ }
+ set avgRuntime 0
+ set sigmaRuntime 0
+ set covRuntime 0
+ set avgDesTime 0
+ if { $callCount($name) > 0 } {
+ foreach {m s c} [eval ::profiler::stats $statTime($name)] { break }
+ set avgRuntime $m
+ set sigmaRuntime $s
+ set covRuntime $c
+ set avgDesTime \
+ [expr {$descendantTime($name)/$callCount($name)}]
+ }
+ set descendantList [list ]
+ foreach index [lsort [array names descendants $name,*]] {
+ lappend descendantList [string range $index $i end]
+ }
+ lappend result $name [list callCount $callCount($name) \
+ callerDist [array get thisCallers] \
+ compileTime $compileTime($name) \
+ totalRuntime $totalRuntime($name) \
+ averageRuntime $avgRuntime \
+ stddevRuntime $sigmaRuntime \
+ covpercentRuntime $covRuntime \
+ descendantTime $descendantTime($name) \
+ averageDescendantTime $avgDesTime \
+ descendants $descendantList]
+ }
+ return $result
+}
+
+# ::profiler::sortFunctions --
+#
+# Return a list of functions sorted by a particular field and the
+# value of that field.
+#
+# Arguments:
+# field field to sort by
+#
+# Results:
+# slist sorted list of lists, sorted by the field in question.
+
+proc ::profiler::sortFunctions {{field ""}} {
+ switch -glob -- $field {
+ "calls" {
+ upvar ::profiler::callCount data
+ }
+ "compileTime" {
+ upvar ::profiler::compileTime data
+ }
+ "totalRuntime" {
+ upvar ::profiler::totalRuntime data
+ }
+ "avgRuntime" -
+ "averageRuntime" {
+ variable callCount
+ variable totalRuntime
+ foreach fxn [array names callCount] {
+ if { $callCount($fxn) > 1 } {
+ set data($fxn) \
+ [expr {$totalRuntime($fxn)/($callCount($fxn) - 1)}]
+ }
+ }
+ }
+ "exclusiveRuntime" {
+ variable totalRuntime
+ variable descendantTime
+ foreach fxn [array names totalRuntime] {
+ set data($fxn) \
+ [expr {$totalRuntime($fxn) - $descendantTime($fxn)}]
+ }
+ }
+ "avgExclusiveRuntime" {
+ variable totalRuntime
+ variable callCount
+ variable descendantTime
+ foreach fxn [array names totalRuntime] {
+ if { $callCount($fxn) } {
+ set data($fxn) \
+ [expr {($totalRuntime($fxn) - \
+ $descendantTime($fxn)) / $callCount($fxn)}]
+ }
+ }
+ }
+ "nonCompileTime" {
+ variable compileTime
+ variable totalRuntime
+ foreach fxn [array names totalRuntime] {
+ set data($fxn) [expr {$totalRuntime($fxn)-$compileTime($fxn)}]
+ }
+ }
+ default {
+ error "unknown statistic \"$field\": should be calls,\
+ compileTime, exclusiveRuntime, nonCompileTime,\
+ totalRuntime, avgExclusiveRuntime, or avgRuntime"
+ }
+ }
+
+ set result [list ]
+ foreach fxn [array names data] {
+ lappend result [list $fxn $data($fxn)]
+ }
+ return [lsort -integer -index 1 $result]
+}
+
+# ::profiler::reset --
+#
+# Reset collected data for functions matching a given pattern.
+#
+# Arguments:
+# pattern pattern of functions to reset; default is *.
+#
+# Results:
+# None.
+
+proc ::profiler::reset {{pattern *}} {
+ variable callCount
+ variable compileTime
+ variable totalRuntime
+ variable callers
+ variable statTime
+
+ foreach name [array names callCount $pattern] {
+ set callCount($name) 0
+ set compileTime($name) 0
+ set totalRuntime($name) 0
+ set statTime($name) {}
+ foreach caller [array names callers $name,*] {
+ unset callers($caller)
+ }
+ }
+ return
+}
+
+# ::profiler::suspend --
+#
+# Suspend the profiler.
+#
+# Arguments:
+# pattern pattern of functions to suspend; default is *.
+#
+# Results:
+# None. Resets the `enabled($name)' variable to 0
+# to suspend profiling
+
+proc ::profiler::suspend {{pattern *}} {
+ variable callCount
+ variable enabled
+ variable paused
+
+ set paused 1
+ foreach name [array names callCount $pattern] {
+ set enabled($name) 0
+ }
+
+ return
+}
+
+# ::profiler::resume --
+#
+# Resume the profiler, after it has been suspended.
+#
+# Arguments:
+# pattern pattern of functions to suspend; default is *.
+#
+# Results:
+# None. Sets the `enabled($name)' variable to 1
+# so as to enable the profiler.
+
+proc ::profiler::resume {{pattern *}} {
+ variable callCount
+ variable enabled
+ variable paused
+
+ set paused 0
+ foreach name [array names callCount $pattern] {
+ set enabled($name) 1
+ }
+
+ return
+}
+
diff --git a/tcllib/modules/profiler/profiler.test b/tcllib/modules/profiler/profiler.test
new file mode 100644
index 0000000..32a80d6
--- /dev/null
+++ b/tcllib/modules/profiler/profiler.test
@@ -0,0 +1,474 @@
+# Profiler tests. -*- tcl -*-
+#
+# Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# All rights reserved.
+#
+# RCS: @(#) $Id: profiler.test,v 1.20 2006/10/09 21:41:41 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.3
+testsNeedTcltest 1.0
+
+testing {
+ useLocal profiler.tcl profiler
+}
+
+::tcltest::testConstraint tcl8.4only \
+ [expr {![package vsatisfies [package provide Tcl] 8.5]}]
+
+# -------------------------------------------------------------------------
+
+test profiler-1.0 {profiler::init redirects the proc command} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ list [interp alias {} proc] [info commands ::_oldProc]
+ }]
+ interp delete $c
+ set result
+} [list ::profiler::profProc ::_oldProc]
+
+test profiler-2.0 {profiler creates two wrapper proc and real proc} {tcl8.3only} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ proc foo {} {
+ puts "foo!"
+ }
+ list [info commands foo] [info commands fooORIG]
+ }]
+ interp delete $c
+ set result
+} [list foo fooORIG]
+test profiler-2.1 {profiler creates procs in correct scope} {tcl8.3only} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ namespace eval foo {}
+ proc ::foo::foo {} {
+ puts "foo!"
+ }
+ list [info commands ::foo::foo] [info commands ::foo::fooORIG]
+ }]
+ interp delete $c
+ set result
+} [list ::foo::foo ::foo::fooORIG]
+test profiler-2.2 {profiler creates procs in correct scope} {tcl8.3only} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ namespace eval foo {
+ proc foo {} {
+ puts "foo!"
+ }
+ }
+ list [info commands ::foo::foo] [info commands ::foo::fooORIG]
+ }]
+ interp delete $c
+ set result
+} [list ::foo::foo ::foo::fooORIG]
+test profiler-2.3 {profiler creates procs in correct scope} {tcl8.3only} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ namespace eval foo {
+ namespace eval bar {}
+ proc bar::foo {} {
+ puts "foo!"
+ }
+ }
+ list [info commands ::foo::bar::foo] \
+ [info commands ::foo::bar::fooORIG]
+ }]
+ interp delete $c
+ set result
+} [list ::foo::bar::foo ::foo::bar::fooORIG]
+test profiler-2.4 {profiler creates procs in correct scope} {tcl8.3only} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ namespace eval foo {
+ proc ::foo {} {
+ puts "foo!"
+ }
+ }
+ list [info commands ::foo] \
+ [info commands ::fooORIG]
+ }]
+ interp delete $c
+ set result
+} [list ::foo ::fooORIG]
+
+test profiler-3.1 {profiler wrappers do profiling} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ proc ::foo {} {
+ set foobar 0
+ }
+ foo
+ foo
+ foo
+ foo
+ profiler::dump ::foo
+ }]
+ interp delete $c
+ array set bar $result
+ array set foo $bar(::foo)
+ list callCount $foo(callCount) callerDist $foo(callerDist)
+} [list callCount 4 callerDist [list GLOBAL 4]]
+
+test profiler::leaveHandler::initialize_descendent_time {} {
+ # Verify that the profiler tracks descendent time correctly. We'll make
+ # a simple call tree, foo -> bar, then invoke foo, then check the profiler
+ # stats to see that _some_ descendent time has been logged for the call
+ # to bar. We won't be able to predict exactly how much time will get
+ # billed there, but it should be non-zero.
+
+ set c [interp create]
+ interp alias $c parentSet {} set
+ array set stats [lindex [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+
+ profiler::init
+ proc ::foo {} {
+ ::bar
+ }
+ proc ::bar {} {
+ after 300
+ }
+ foo
+
+ profiler::dump ::foo
+ }] 1]
+ interp delete $c
+ list descendantTime [expr {$stats(descendantTime) > 0}]
+} {descendantTime 1}
+test profiler::leaveHandler::increment_descendent_time {} {
+ # Verify that the profiler increments descendent time each time a
+ # a descendent is invoked. We'll make a simple call tree, foo -> bar, then
+ # invoke foo, check the descendent time for foo, then invoke foo again and
+ # check the descendent time again. It should have been incremented after
+ # the second call.
+
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ proc ::foo {} {
+ ::bar
+ }
+ proc ::bar {} {
+ after 300
+ }
+ foo
+ array set stats [lindex [profiler::dump ::foo] 1]
+ set before $stats(descendantTime)
+ foo
+ array set stats [lindex [profiler::dump ::foo] 1]
+ set after $stats(descendantTime)
+ list before [expr {$before - $before}] \
+ after [expr {($after - $before) > 0}]
+ }]
+ interp delete $c
+ set result
+} {before 0 after 1}
+
+test profiler-4.1 {profiler::print produces nicer output than dump} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ proc ::foo {} {
+ set foobar 0
+ }
+ foo
+ foo
+ foo
+ foo
+ profiler::print ::foo
+ }]
+ interp delete $c
+ regsub {Compile time:.*} $result {} result
+ string trim $result
+} "Profiling information for ::foo
+============================================================
+ Total calls: 4
+ Caller distribution:
+ GLOBAL: 4"
+
+test profiler-5.1 {profiler respects suspend/resume} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ proc ::foo {} {
+ set foobar 0
+ }
+ foo
+ foo
+ foo
+ foo
+ profiler::suspend ::foo ; # note the qualification, has to match proc!
+ foo
+ foo
+ set res [profiler::print ::foo]
+ profiler::resume
+ set res
+ }]
+ interp delete $c
+ regsub {Compile time:.*} $result {} result
+ string trim $result
+} "Profiling information for ::foo
+============================================================
+ Total calls: 4
+ Caller distribution:
+ GLOBAL: 4"
+
+test profiler-6.1 {profiler handles functions with funny names} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ lappend auto_path [file dirname [file dirname [info script]]]
+ package require profiler
+ profiler::init
+ proc ::foo(bar) {} {
+ set foobar 0
+ }
+ foo(bar); foo(bar); foo(bar)
+ profiler::dump ::foo(bar)
+ }]
+ interp delete $c
+ array set bar $result
+ array set foo ${bar(::foo(bar))}
+ list callCount $foo(callCount) callerDist $foo(callerDist)
+} [list callCount 3 callerDist [list GLOBAL 3]]
+
+test profiler-7.1 {sortFunctions} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ catch {profiler::sortFunctions} res
+ set res
+ }]
+ interp delete $c
+ set result
+} "unknown statistic \"\": should be calls, compileTime, exclusiveRuntime,\
+nonCompileTime, totalRuntime, avgExclusiveRuntime, or avgRuntime"
+test profiler-7.2 {sortFunctions} tcl8.4only {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ proc ::foo {} {
+ set foobar 0
+ }
+ proc ::bar {} {
+ set foobar 1
+ }
+ foo; foo; bar;
+ profiler::sortFunctions calls
+ }]
+ interp delete $c
+ set result
+} [list [list ::bar 1] [list ::foo 2]]
+test profiler-7.2-85 {sortFunctions} tcl8.5plus {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ proc ::foo {} {
+ set foobar 0
+ }
+ proc ::bar {} {
+ set foobar 1
+ }
+ foo; foo; bar;
+ profiler::sortFunctions calls
+ }]
+ interp delete $c
+ set result
+} [list [list ::tcl::clock::scan 0] [list ::tcl::clock::format 0] [list ::tcl::clock::add 0] [list ::bar 1] [list ::foo 2]]
+test profiler-7.3 {sortFunctions} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ proc ::foo {} {
+ set foobar 0
+ }
+ proc ::bar {} {
+ set foobar 1
+ }
+ foo; foo; bar;
+ catch {profiler::sortFunctions compileTime}
+ }]
+ interp delete $c
+ set result
+} 0
+test profiler-7.4 {sortFunctions} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ proc ::foo {} {
+ set foobar 0
+ }
+ proc ::bar {} {
+ set foobar 1
+ }
+ foo; foo; bar;
+ catch {profiler::sortFunctions totalRuntime}
+ }]
+ interp delete $c
+ set result
+} 0
+test profiler-7.5 {sortFunctions} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ proc ::foo {} {
+ set foobar 0
+ }
+ proc ::bar {} {
+ set foobar 1
+ }
+ foo; foo; bar;
+ catch {profiler::sortFunctions avgRuntime}
+ }]
+ interp delete $c
+ set result
+} 0
+
+test profiler-8.1 {reset} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ proc ::foo {} {
+ set foobar 0
+ }
+ proc ::bar {} {
+ set foobar 1
+ }
+ foo; foo; bar;
+ profiler::reset
+ profiler::dump ::foo
+ }]
+ interp delete $c
+ array set bar $result
+ array set foo $bar(::foo)
+ list callCount $foo(callCount) callerDist $foo(callerDist)
+} [list callCount 0 callerDist [list ]]
+test profiler-8.2 {reset with a pattern} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ proc ::foo {} {
+ set foobar 0
+ }
+ proc ::bar {} {
+ set foobar 1
+ }
+ foo; foo; bar;
+ profiler::reset ::foo
+ profiler::dump *
+ }]
+ interp delete $c
+ array set data $result
+ catch {unset foo}
+ catch {unset bar}
+ array set foo $data(::foo)
+ array set bar $data(::bar)
+ list [list callCount $foo(callCount) callerDist $foo(callerDist)] \
+ [list callCount $bar(callCount) callerDist $bar(callerDist)]
+} [list [list callCount 0 callerDist [list ]] \
+ [list callCount 1 callerDist [list GLOBAL 1]]]
+
+test profiler-9.1 {dump for multiple functions} {
+ set c [interp create]
+ interp alias $c parentSet {} set
+ set result [$c eval {
+ set auto_path [parentSet auto_path]
+ package require profiler
+ profiler::init
+ proc ::foo {} {
+ set foobar 0
+ }
+ proc ::bar {} {
+ set foobar 1
+ }
+ foo; foo; bar;
+ profiler::dump *
+ }]
+ interp delete $c
+ array set data $result
+ catch {unset foo}
+ catch {unset bar}
+ array set foo $data(::foo)
+ array set bar $data(::bar)
+ list [list callCount $foo(callCount) callerDist $foo(callerDist)] \
+ [list callCount $bar(callCount) callerDist $bar(callerDist)]
+} [list [list callCount 2 callerDist [list GLOBAL 2]] \
+ [list callCount 1 callerDist [list GLOBAL 1]]]
+
+catch {unset foo}
+catch {unset bar}
+
+testsuiteCleanup
diff --git a/tcllib/modules/pt/ChangeLog b/tcllib/modules/pt/ChangeLog
new file mode 100644
index 0000000..53bb24b
--- /dev/null
+++ b/tcllib/modules/pt/ChangeLog
@@ -0,0 +1,2582 @@
+2014-01-22 Andreas Kupries <aku@hephaistos>
+
+ * pt_pgen.tcl Ticket [1b7fe4fe19]: Fixed missing class/package
+ * pt_pgen.man: initialization for critcl generator. Bumped
+ * pkgIndex.tcl: package version to 1.0.2
+
+ * ../../apps/pt Ticket [c3ab006ca2]: Fixed help delivered by the
+ 'pt' application.
+
+2014-01-22 Andreas Kupries <aku@hephaistos>
+
+ * pt_peg_from_peg.man: Fixed handling of empty strings in a
+ * pt_peg_from_peg.tcl: PEG. Treat as <epsilon>. Bumped to 1.0.2
+ * pt_peg_to_peg.man: Fixed generation of PEG from
+ * pt_peg_to_peg.tcl: <epsilon>. Produce a proper empty
+ string. Bumped to 1.0.1
+
+ * tests/data/ok/peg_container-bulk/11_epsilon: New files to test
+ * tests/data/ok/peg_container-incremental/11_epsilon: handling of
+ * tests/data/ok/peg_container-templated-bulk/11_epsilon: <epsilon>
+ * tests/data/ok/peg_container-templated-incremental/11_epsilon: and
+ * tests/data/ok/peg_cparam/11_epsilon: empty strings across the board.
+ * tests/data/ok/peg_cparam-critcl/11_epsilon:
+ * tests/data/ok/peg_json-indalign/11_epsilon:
+ * tests/data/ok/peg_json-indented/11_epsilon:
+ * tests/data/ok/peg_json-ultracompact/11_epsilon:
+ * tests/data/ok/peg_param/11_epsilon:
+ * tests/data/ok/peg_param-compact/11_epsilon:
+ * tests/data/ok/peg_param-inlined/11_epsilon:
+ * tests/data/ok/peg_param-unopt/11_epsilon:
+ * tests/data/ok/peg_peg/11_epsilon:
+ * tests/data/ok/peg_peg-ast/11_epsilon:
+ * tests/data/ok/peg_peg-ast-fused/11_epsilon:
+ * tests/data/ok/peg_peg-ast-templated/11_epsilon:
+ * tests/data/ok/peg_peg-ast-templated-fused/11_epsilon:
+ * tests/data/ok/peg_peg-fused/11_epsilon:
+ * tests/data/ok/peg_peg-templated/11_epsilon:
+ * tests/data/ok/peg_peg-templated-fused/11_epsilon:
+ * tests/data/ok/peg_serial/11_epsilon:
+ * tests/data/ok/peg_serial-canonical/11_epsilon:
+ * tests/data/ok/peg_serial-print/11_epsilon:
+ * tests/data/ok/peg_tclparam/11_epsilon:
+ * tests/data/ok/peg_tclparam-snit/11_epsilon:
+ * tests/data/ok/peg_tclparam-tcloo/11_epsilon:
+
+2013-12-17 Andreas Kupries <andreask@activestate.com>
+
+ * pt_parse_peg.man: Added missing documentation for the PEG parser
+ package.
+ * pt_peg_op.man: Added missing documentation for this utility package.
+ * pt_peg_op.tcl: Exported 'minimize'.
+
+2013-12-06 Andreas Kupries <andreask@activestate.com>
+
+ * tools/regenerate_parsers.tcl: Ticket [f5155519e7]. Dropped use
+ * ../../apps/pt: of bash. Switched to easier to read invokation
+ without all the shell tricks and magic.
+
+2013-08-06 Andreas Kupries <aku@hephaistos>
+
+ * pt_astree.man [Ticket 0d9f835d4d]: Removed (non)terminal
+ methods, and replaced with documentation for new, new0.
+
+ * pt_peg_interp.man [Ticket 0d9f835d4d]: Fixed typo of
+ "pt::peg::interpreter", to "pt::peg::interp".
+
+2013-03-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pt: Moved to the apps/ directory, with the other proper applications.
+ * pt.man:
+
+2013-03-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tests/data/ok/peg_json-indalign/0_basic_arithmetic: Updated to match
+ * tests/data/ok/peg_json-indalign/2_fun_arithmetic: json::write 1.0.2
+ * tests/data/ok/peg_json-indalign/3_peg_itself: ("/" not quoted as "\/")
+ * tests/data/ok/peg_json-indalign/4_choice:
+ * tests/data/ok/peg_json-indented/0_basic_arithmetic:
+ * tests/data/ok/peg_json-indented/2_fun_arithmetic:
+ * tests/data/ok/peg_json-indented/3_peg_itself:
+ * tests/data/ok/peg_json-indented/4_choice:
+ * tests/data/ok/peg_json-ultracompact/0_basic_arithmetic:
+ * tests/data/ok/peg_json-ultracompact/2_fun_arithmetic:
+ * tests/data/ok/peg_json-ultracompact/3_peg_itself:
+ * tests/data/ok/peg_json-ultracompact/4_choice:
+
+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-11-09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * rde_critcl/util.c: Fix build warning, get a strlen declaration.
+ * rde_critcl/param.c: Fix bug in TRACE output.
+ * rde_critcl/p.c: Tweaked TRACE output for clarity.
+ * rde_critcl/ot.c: Fix the actual issue, a missing string rep for
+ a Tcl_Obj literal getting interned.
+ * pt_rdengine.tcl: Bumped package version to 1.0.2
+ * pt_rdengine.man:
+ * pkgIndex.tcl
+
+ * tests/data/ok/peg_param-critcl/0_basic_arithmetic: Updated the
+ * tests/data/ok/peg_param-critcl/10_notahead: test data to match
+ * tests/data/ok/peg_param-critcl/1_functions: the code change
+ * tests/data/ok/peg_param-critcl/2_fun_arithmetic: (in param.c)
+ * tests/data/ok/peg_param-critcl/3_peg_itself: above.
+ * tests/data/ok/peg_param-critcl/4_choice:
+ * tests/data/ok/peg_param-critcl/5_sequence:
+ * tests/data/ok/peg_param-critcl/6_optional:
+ * tests/data/ok/peg_param-critcl/7_kleene:
+ * tests/data/ok/peg_param-critcl/8_pkleene:
+ * tests/data/ok/peg_param-critcl/9_ahead:
+
+2011-11-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tests/data/ok/peg_tclparam-tcloo/0_basic_arithmetic: Updated the
+ * tests/data/ok/peg_tclparam-tcloo/10_notahead: test data to match
+ * tests/data/ok/peg_tclparam-tcloo/1_functions: the [2011-06-06]
+ * tests/data/ok/peg_tclparam-tcloo/2_fun_arithmetic: change.
+ * tests/data/ok/peg_tclparam-tcloo/3_peg_itself:
+ * tests/data/ok/peg_tclparam-tcloo/4_choice:
+ * tests/data/ok/peg_tclparam-tcloo/5_sequence:
+ * tests/data/ok/peg_tclparam-tcloo/6_optional:
+ * tests/data/ok/peg_tclparam-tcloo/7_kleene:
+ * tests/data/ok/peg_tclparam-tcloo/8_pkleene:
+ * tests/data/ok/peg_tclparam-tcloo/9_ahead:
+
+ * tests/data/ok/peg_param-critcl/0_basic_arithmetic: Updated the
+ * tests/data/ok/peg_param-critcl/10_notahead: test data to match
+ * tests/data/ok/peg_param-critcl/1_functions: an unrecorded code
+ * tests/data/ok/peg_param-critcl/2_fun_arithmetic: change.
+ * tests/data/ok/peg_param-critcl/3_peg_itself:
+ * tests/data/ok/peg_param-critcl/4_choice:
+ * tests/data/ok/peg_param-critcl/5_sequence:
+ * tests/data/ok/peg_param-critcl/6_optional:
+ * tests/data/ok/peg_param-critcl/7_kleene:
+ * tests/data/ok/peg_param-critcl/8_pkleene:
+ * tests/data/ok/peg_param-critcl/9_ahead:
+
+2011-09-08 Andreas Kupries <andreask@activestate.com>
+
+ * include/expr_pe.inc: Fixed the example to be a proper expression
+ * include/expr_pe_serial.inc: grammar, with the correct operator
+ * include/expr_peg.inc: precedences. Thanks to Lars Hellstrom.
+ * include/expr_serial.inc:
+
+2011-06-06 Andreas Kupries <andreask@activestate.com>
+
+ * pt_tclparam_config_tcloo.tcl: Fixed typo, OO is TclOO.
+ * pkgIndex.tcl: Bumped version to 1.0.2.
+
+2011-02-16 Andreas Kupries <andreask@activestate.com>
+
+ * include/format/options_tclparam_oo.inc: Documented option -package, and
+ * include/format/options_tclparam_snit.inc: the new cross -class/-package
+ * pkgIndex.tcl: resolution. Implemented resolution of missing -package
+ * pt_pgen.tcl: and -class through each other. Bumped version to 1.0.1.
+ * pt_pgen.man:
+
+2011-01-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * include/example/expr_ptgenb.inc: Fixed a typo in the example,
+ * include/example/full_app.inc: and dropped continuation lines
+ to prevent missformatting in the formatted docs.
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2011-01-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * pt_peg_to_json.test: Dropped the local json::write package,
+ * pkgIndex.tcl: replaced with use of the common json::write
+ * json_write.tcl: derived from it.
+
+2010-11-25 Andreas Kupries <andreask@activestate.com>
+
+ * pt_cparam_config_critcl.man: Added pragmas for meta-data
+ * pt_cparam_config_critcl.tcl: scanning to prevent the
+ requirements of the embedded code template to be taken as the
+ requirements of the package itself. Bumped version to 1.0.1.
+
+2010-10-07 Andreas Kupries <andreask@activestate.com>
+
+ * pt_tclparam_config_snit.man: Added pragmas for meta-data
+ * pt_tclparam_config_snit.tcl: scanning to prevent the
+ * pt_tclparam_config_tcloo.man: requirements of the embedded code
+ * pt_tclparam_config_tcloo.tcl: template to be taken as the
+ * pkgIndex.tcl: requirements of this package. Bumped versions to
+ 1.0.1.
+
+2010-07-27 Andreas Kupries <andreask@activestate.com>
+
+ * pt_peg_interp.test: New files. Additional testsuites.
+ * pt_runtime.test: Demonstrate the problem with X* and X?
+ * tests/pt_peg_interp.tests: alone in a symbol, for modes
+ * tests/pt_runtime.tests: leaf and value.
+
+ * pt_peg_interp.tcl: Fixed two typos in comments.
+ * pt_rdengine.test:
+
+ * pt_astree.tcl: New constructor new0 for zero-length
+ * pt_astree.man: nodes. Bumped version to 1.1
+
+ * pt_rdengine_tcl.tcl: Use of the new constructor to handle
+ * pt_rdengine.tcl: symbols whose RHS uses * or ? as toplevel
+ * pt_rdengine.man: operator and did not match anything at runtime,
+ which is allowed. Bumped version to 1.0.1
+
+ * pt_peg_interp.tcl: Some tweaks to the debug helper code (tracing
+ * pt_rdengine_tcl.tcl: expressions and instructions).
+
+ * pkgIndex.tcl: Bumped versions.
+
+2010-07-09 Andreas Kupries <andreask@activestate.com>
+
+ * include/example/expr_json.inc: Fixed various typos in the JSON
+ example, i.e. missing closing double-quote, missing commas,
+ missing backslash quoting of forward slashes in strings.
+
+2010-06-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * include/arch_core.dia: Navigational diagrams and images
+ * include/arch_core.png:
+ * include/arch_core_container.dia:
+ * include/arch_core_container.png:
+ * include/arch_core_eplugins.dia:
+ * include/arch_core_eplugins.png:
+ * include/arch_core_export.dia:
+ * include/arch_core_export.png:
+ * include/arch_core_import.dia:
+ * include/arch_core_import.png:
+ * include/arch_core_iplugins.dia:
+ * include/arch_core_iplugins.png:
+ * include/arch_core_support.dia:
+ * include/arch_core_support.png:
+ * include/arch_core_transform.dia:
+ * include/arch_core_transform.png:
+ * include/arch_support.dia:
+ * include/arch_support.png:
+ * include/arch_user_app.dia:
+ * include/arch_user_app.png:
+ * include/arch_user_pkg.dia:
+ * include/arch_user_pkg.png:
+ * include/architecture.dia: Foundation for the variant diagrams above.
+ * include/architecture.png:
+
+ * include/example/expr_ptgenb.inc: Text blocks for the full examples
+ * include/example/flow.dia: shown in the pt and pt::pgen documentation.
+ * include/example/flow.png:
+ * include/example/full.inc:
+ * include/example/full_app.inc:
+ * include/example/full_pkg.inc:
+ * include/example/parser_use.inc:
+
+ * pt.man: Addition of larger examples to pt and pt::pgen manpages,
+ * pt_astree.man: plus addition of navigational images to all manpages
+ * pt_cparam_config_critcl.man: for packages and APIs.
+ * pt_from_api.man:
+ * pt_introduction.man:
+ * pt_parser_api.man:
+ * pt_peg_container.man:
+ * pt_peg_export.man:
+ * pt_peg_import.man:
+ * pt_peg_interp.man:
+ * pt_pegrammar.man:
+ * pt_pexpression.man:
+ * pt_pgen.man:
+ * pt_rdengine.man:
+ * pt_tclparam_config_snit.man:
+ * pt_tclparam_config_tcloo.man:
+ * pt_to_api.man:
+ * include/export/plugin.inc:
+ * include/export/to.inc:
+ * include/import/from.inc:
+ * include/import/plugin.inc:
+
+2010-06-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * include/serial/ast.inc: Added image for the AST.
+ * include/example/expr_ast.dia: New. tklib diagram for the AST.
+ * include/example/expr_ast.png: New. PNG image of the above.
+ * include/example/expr_ast.txt: New. Text variant of the above.
+ * include/example/expr_ast.pic: New. *roff variant of the above.
+ * include/gen_options.inc: Replaced example with diagram via image.
+ * include/gen_options.dia: New. tklib diagram.
+ * include/gen_options.png: New. PNG image derived from diagram.
+ * include/gen_options.txt: New. Text variant of the above.
+ * include/gen_options.pic: New. *roff variant of the above.
+
+2010-04-07 Andreas Kupries <andreask@activestate.com>
+
+ * pt_peg_to_cparam.tcl (::pt::peg::to::cparam::convert): Changed
+ * pt_peg_to_cparam.man: definition of string table from 'const
+ * pkgIndex.tcl: char const*' to 'char const*'. The older
+ * tests/data/ok/peg_cparam-critcl/6_optional: definition choked
+ * tests/data/ok/peg_cparam-critcl/8_pkleene: the HPUX cc on IA64.
+ * tests/data/ok/peg_cparam-critcl/1_functions: Bumped version to
+ * tests/data/ok/peg_cparam-critcl/3_peg_itself: 1.0.1. Updated
+ * tests/data/ok/peg_cparam-critcl/10_notahead: the testsuite.
+ * tests/data/ok/peg_cparam-critcl/7_kleene:
+ * tests/data/ok/peg_cparam-critcl/5_sequence:
+ * tests/data/ok/peg_cparam-critcl/4_choice:
+ * tests/data/ok/peg_cparam-critcl/9_ahead:
+ * tests/data/ok/peg_cparam-critcl/0_basic_arithmetic:
+ * tests/data/ok/peg_cparam-critcl/2_fun_arithmetic:
+ * tests/data/ok/peg_cparam/6_optional:
+ * tests/data/ok/peg_cparam/8_pkleene:
+ * tests/data/ok/peg_cparam/1_functions:
+ * tests/data/ok/peg_cparam/3_peg_itself:
+ * tests/data/ok/peg_cparam/10_notahead:
+ * tests/data/ok/peg_cparam/7_kleene:
+ * tests/data/ok/peg_cparam/5_sequence:
+ * tests/data/ok/peg_cparam/4_choice:
+ * tests/data/ok/peg_cparam/9_ahead:
+ * tests/data/ok/peg_cparam/0_basic_arithmetic:
+ * tests/data/ok/peg_cparam/2_fun_arithmetic:
+
+ * pt_parse_peg_c.tcl: See above, updated the generated code.
+
+2010-03-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * New module, 'pt' for ParserTools. Requires Tcl 8.5. Supercedes
+ grammar_peg, grammar_me, and page.
+
+Fossil 2010-03-15 17:22:27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Switched to struct::stack 1.5 with its enhanced speed under Tcl 8.5+,
+ and extended API making a number of our lreverse calls superfluous.
+
+ Tcl based specialized parsers nearly doubled their speed (Ad 7, 80%).
+ Interpretation of grammars gained as well, although only 60%.
+ <verbatim>
+ +---+-------------------------------------------------------+-------------+-----------+------+-------+
+ | | | PBASE/BENCH | PXE/BENCH | | |
+ | | INPUT 3044 chars | chars/sec | chars/sec | x | % |
+ +---+-------------------------------------------------------+-------------+-----------+------+-------+
+ | 3 | peg interpreter rde(tcl) stack(tcl) PEG | 286.80 | 451.50 | 1.57 | 57.43 |
+ | 2 | peg interpreter rde(tcl) stack(critcl) PEG | 807.79 | 807.44 | 1.00 | -0.04 |
+ | 1 | peg interpreter rde(critcl) stack(n/a) PEG | 3415.33 | 3403.46 | 1.00 | -0.35 |
+ +---+-------------------------------------------------------+-------------+-----------+------+-------+
+ | 7 | peg specialized parse(tcl) rde(tcl) stack(tcl) PEG | 729.48 | 1317.50 | 1.81 | 80.61 |
+ | 6 | peg specialized parse(tcl) rde(tcl) stack(critcl) PEG | 3623.86 | 3612.41 | 1.00 | -0.32 |
+ | 5 | peg specialized parse(tcl) rde(critcl) stack(n/a) PEG | 27708.20 | 27630.59 | 1.00 | -0.28 |
+ | 4 | peg specialized parse(critcl) rde(n/a) stack(n/a) PEG | 71496.87 | 68350.27 | 0.96 | -4.40 |
+ +---+-------------------------------------------------------+-------------+-----------+------+-------+
+ </verbatim>
+
+Fossil 2010-03-10 06:29:44 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added super instructions to handle arbitrarily long sequences and
+ choices of characters, i.e. strings and classes, in a single
+ instruction each. Done for both C and Tcl generators and
+ implementations.
+
+ The speed gain is modest, from 2% up to 6%. The C is actually which
+ got the highest gain, i.e. 6%. The Tcl code, for which I made this
+ change and had more hope for, is (only) in the 2-4% range.
+
+ The size gains are better, slashing off about 10-20% of the size of
+ generated parsers.
+
+ The speed numbers ...
+ <verbatim>
+ +---+-------------------------------------------------------+-------------+-------------+------+------+
+ | | | PBASE/BENCH | PFUSE/BENCH | | |
+ | | INPUT 3044 chars | chars/sec | chars/sec | x | % |
+ +---+-------------------------------------------------------+-------------+-------------+------+------+
+ | 3 | peg interpreter rde(tcl) stack(tcl) PEG | 287.33 | 291.48 | 1.01 | 1.44 |
+ | 2 | peg interpreter rde(tcl) stack(critcl) PEG | 808.06 | 820.24 | 1.02 | 1.51 |
+ | 1 | peg interpreter rde(critcl) stack(n/a) PEG | 3351.95 | 3444.03 | 1.03 | 2.75 |
+ +---+-------------------------------------------------------+-------------+-------------+------+------+
+ | 7 | peg specialized parse(tcl) rde(tcl) stack(tcl) PEG | 709.55 | 741.13 | 1.04 | 4.45 |
+ | 6 | peg specialized parse(tcl) rde(tcl) stack(critcl) PEG | 3500.13 | 3596.56 | 1.03 | 2.76 |
+ | 5 | peg specialized parse(tcl) rde(critcl) stack(n/a) PEG | 26723.71 | 27848.07 | 1.04 | 4.21 |
+ | 4 | peg specialized parse(critcl) rde(n/a) stack(n/a) PEG | 67466.47 | 71646.49 | 1.06 | 6.20 |
+ +---+-------------------------------------------------------+-------------+-------------+------+------+
+ </verbatim>
+
+Fossil 2010-03-10 06:27:07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Extended API to handle multiple arguments
+
+Fossil 2010-03-09 03:33:54 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Line between handling of TC and reading characters redrawn. ReadChar
+ becomes ExtendTC. Calling code in i_input_next and si:next_* is now
+ smaller. Tried to use a cache (variable mytlen) for the length of
+ mytoken, for easier access over 'string length'. However the time
+ needed to manage this variable is more than the time we gain from
+ the direct variale access, making this 'optimization' a net loss.
+
+Fossil 2010-03-07 17:02:18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed typo in comment
+
+Fossil 2010-03-07 00:18:42 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Removed the handling of the line/column counters from the C and Tcl
+ runtimes. Because this is (a) in the critical path (i.e it is run
+ for every processed character), and (b) irrelevant to the parsing
+ itself. In C its removal does not do much, runtime is apparently
+ dominated by other factors. For Tcl this is a major simplification
+ however and boosts performance by 3 to 8 percent, depending on the
+ implementation of stacks (Tcl, and C respectively). The methods
+ line, column, and position (translation) are gone, the tokens method
+ changes semantics (returns a string now instead of list of
+ char/location data). The token cache drops the lin/col data as well,
+ making it only a plain string.
+
+Fossil 2010-03-05 14:39:23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Simplified the innards of the si:next_ instructions, removed a few
+ superfluous commands
+
+Fossil 2010-03-05 06:20:50 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed typo in usage of "string is"
+
+Fossil 2010-03-05 06:19:36 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Benchmarks updated to new API of grammar interpreter as per change
+ [c566928fec]
+
+Fossil 2010-03-03 03:45:52 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ si_next_ to si:next_, to consolidate the prefix of super
+ instructions as si:
+
+Fossil 2010-03-03 00:07:12 Andreas Kupries <andreask@activestate.com>
+
+ Documented the pt::rde super instructions. HTML regenerated.
+
+Fossil 2010-02-27 22:05:38 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added tests for parser of the PEG specification language, checking
+ out the generated ASTs.
+
+Fossil 2010-02-27 22:04:19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Reworked grammar interpreter API, moved specification of grammar to
+ execute from construction time to method. Default grammar is empty
+ (epsilon) now. Brings the API more in line with the API of the
+ parsers specialized to a grammar. Doc updated and HTML regenerated.
+
+Fossil 2010-02-27 22:00:10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Drop struct::set use and switching from grammar tests, package not
+ used there
+
+Fossil 2010-02-27 21:58:39 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Remove bogus reference to set implementation, unseen due to being
+ set by previous tests
+
+Fossil 2010-02-22 00:16:36 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Merged doc track [d72eb3f762] back to main track
+
+Fossil 2010-02-21 23:25:18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Worked on the C/PARAM based parsers. Did the same aggregation of
+ instruction sequences into super instructions. While there is
+ basically no effect on the speed of the generated parsers it does
+ slash the size of parser code by an substantial amount. They also
+ look easier to read, replacing the various non-linear goto
+ statements we had with plain early returns. The runtime inlined into
+ CriTcl parsers is stripped of comments, empty lines, and irrelevant
+ declarations. Updated the test cases.
+
+Fossil 2010-02-21 21:02:45 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed declaration of message reference, is id, not string
+
+Fossil 2010-02-21 21:02:09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed calculation of #entries in generated string table
+
+Fossil 2010-02-19 22:33:25 Andreas Kupries <andreask@activestate.com>
+
+ Dropped the stripping of unknown options from the plugins. Pass
+ option names through unchanged now, instead of prefixing with dash
+ ('-'). This makes the export manager consistent with the converters,
+ i.e. no FOO (manager) versus -FOO (converter) confusion anymore. It
+ is now -FOO for the export manager as well.
+
+Fossil 2010-02-19 21:17:19 Andreas Kupries <andreask@activestate.com>
+
+ Dropped bogus requirement in docs. Regenerated HTML
+
+Fossil 2010-02-19 20:53:21 Andreas Kupries <andreask@activestate.com>
+
+ Dropped hardwiring of user/format configuration from export manager,
+ and call them options
+
+Fossil 2010-02-19 20:50:48 Andreas Kupries <andreask@activestate.com>
+
+ Changed json export converter to accept -name, -file, and -user
+ options, as required for conformance with the export converter API
+
+Fossil 2010-02-19 04:38:21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Merged doc changes back to mainline
+
+Fossil 2010-02-19 04:35:01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ <verbatim>
+ Continued optimization work on Tcl/PARAM based parsers.
+
+ Overview of performance changes:
+
+ * Pure C parser unchanged, expected, as it is not modified by this.
+
+ * Grammar interpreter unchanged, expected, as it is not modified by
+ this. Because of the actual looping it uses nothing that can be
+ merged/simplified.
+
+ * Tcl parsers. The interesting part.
+
+ * 33- 55% speed gains on top of a Tcl runtime with Tcl stacks.
+ * 153-170% speed gains on top of a Tcl runtime with C stacks.
+ * 75% speed gains on top of a C runtime.
+
+
+ The work started in the generator code for the parser, where
+ instruction sequences were folded as much as possible, with the
+ newly-made "super-instructions" getting added to the Tcl and C
+ implementations of pt::rde.
+
+ * Converted the choice/sequence code sequences into single super
+ instructions. Implemented these super instructions in the Tcl and C
+ runtimes. In C they simply call the relevant instruction
+ implementations, whereas in Tcl the instruction code is inlined, to
+ avoid additional method dispatch.
+
+ * Per sequence we merged 4-6 to one instruction (init and exit), and
+ per transition between parts 4-5 to one.
+
+ * Per choice we merged 4-6 to one instruction (init and exit), and
+ per transition between branches 5-7 to one.
+
+ * Noted that I missed an optimization of sequence exit in commit [],
+ the loc/ast pop-rewind/dicard instruction could have been merged
+ into existing supers, making fail/return superfluous. This is now
+ all handled in the new supers.
+
+ * Super instructions for handling characters, character ranges, and
+ the predefined character classes. Each folds three instructions into
+ one.
+
+ * Super instructions for (positive) kleene closures, folding six into
+ two instructions per kleene closure, and an additional folding of
+ two into one per positive kleene closure.
+
+ * Super instructions for optional sequences (5/2) and lookahead (3/2
+ or 5/2).
+
+ * Super instructions to handle symbol setup and completion, folding
+ 3-5/1 and 4-6/1.
+
+ Detailed performance numbers:
+
+ +---+-------------------------------------------------------+-------------+---------+-----------+-----------+
+ | | BASELINE INPUT 3044 chars | u-seconds | seconds | chars/sec | usec/char |
+ +---+-------------------------------------------------------+-------------+---------+-----------+-----------+
+ | 3 | peg interpreter rde(tcl) stack(tcl) PEG | 11178686.40 | 11.18 | 272.30 | 3672.37 |
+ | 2 | peg interpreter rde(tcl) stack(critcl) PEG | 4152088.34 | 4.15 | 733.13 | 1364.02 |
+ | 1 | peg interpreter rde(critcl) stack(n/a) PEG | 933447.08 | 0.93 | 3261.03 | 306.65 |
+ +---+-------------------------------------------------------+-------------+---------+-----------+-----------+
+ | 7 | peg specialized parse(tcl) rde(tcl) stack(tcl) PEG | 6680846.60 | 6.68 | 455.63 | 2194.76 |
+ | 6 | peg specialized parse(tcl) rde(tcl) stack(critcl) PEG | 2614125.16 | 2.61 | 1164.44 | 858.78 |
+ | 5 | peg specialized parse(tcl) rde(critcl) stack(n/a) PEG | 202883.36 | 0.20 | 15003.69 | 66.65 |
+ | 4 | peg specialized parse(critcl) rde(n/a) stack(n/a) PEG | 46395.68 | 0.05 | 65609.56 | 15.24 |
+ +---+-------------------------------------------------------+-------------+---------+-----------+-----------+
+ +---+-------------------------------------------------------+-------------+---------+-----------+-----------+
+ | | SUPERED INPUT 3044 chars | u-seconds | seconds | chars/sec | usec/char |
+ +---+-------------------------------------------------------+-------------+---------+-----------+-----------+
+ | 3 | peg interpreter rde(tcl) stack(tcl) PEG | 10748830.70 | 10.75 | 283.19 | 3531.15 |
+ | 2 | peg interpreter rde(tcl) stack(critcl) PEG | 4106306.58 | 4.11 | 741.30 | 1348.98 |
+ | 1 | peg interpreter rde(critcl) stack(n/a) PEG | 899587.82 | 0.90 | 3383.77 | 295.53 |
+ +---+-------------------------------------------------------+-------------+---------+-----------+-----------+
+ | 7 | peg specialized parse(tcl) rde(tcl) stack(tcl) PEG | 4324268.00 | 4.32 | 703.93 | 1420.59 |
+ | 6 | peg specialized parse(tcl) rde(tcl) stack(critcl) PEG | 963972.73 | 0.96 | 3157.77 | 316.68 |
+ | 5 | peg specialized parse(tcl) rde(critcl) stack(n/a) PEG | 116598.70 | 0.12 | 26106.64 | 38.30 |
+ | 4 | peg specialized parse(critcl) rde(n/a) stack(n/a) PEG | 46564.36 | 0.05 | 65371.89 | 15.30 |
+ +---+-------------------------------------------------------+-------------+---------+-----------+-----------+
+
+ +---+-------------------------------------------------------+-----------+-----------+------+--------+
+ | | | BASELINE | SUPERED | | |
+ | | INPUT 3044 chars | chars/sec | chars/sec | x | % |
+ +---+-------------------------------------------------------+-----------+-----------+------+--------+
+ | 3 | peg interpreter rde(tcl) stack(tcl) PEG | 272.30 | 283.19 | 1.04 | 4.00 |
+ | 2 | peg interpreter rde(tcl) stack(critcl) PEG | 733.13 | 741.30 | 1.01 | 1.11 |
+ | 1 | peg interpreter rde(critcl) stack(n/a) PEG | 3261.03 | 3383.77 | 1.04 | 3.76 |
+ +---+-------------------------------------------------------+-----------+-----------+------+--------+
+ | 7 | peg specialized parse(tcl) rde(tcl) stack(tcl) PEG | 455.63 | 703.93 | 1.54 | 54.50 |
+ | 6 | peg specialized parse(tcl) rde(tcl) stack(critcl) PEG | 1164.44 | 3157.77 | 2.71 | 171.18 |
+ | 5 | peg specialized parse(tcl) rde(critcl) stack(n/a) PEG | 15003.69 | 26106.64 | 1.74 | 74.00 |
+ | 4 | peg specialized parse(critcl) rde(n/a) stack(n/a) PEG | 65609.56 | 65371.89 | 1.00 | -0.36 |
+ +---+-------------------------------------------------------+-----------+-----------+------+--------+
+
+ Updated Tcl PEG parser to use these changes.
+ Updated testsuite to the changes in the generated Tcl parser code.
+
+ Another side-effect (beyond the higher speed) of using the super-
+ instructions is that the generated parser code is smaller. Because
+ more code is now in the runtime, and acessible through short commands,
+ instead of requiring long, heavily replicated instruction sequences.
+ This effect is also why super instructions make sense for the C
+ parsers as well. For these it is not about the speed, although some
+ gains may be had there too, but about the space savings.
+ </verbatim>
+
+Fossil 2010-02-19 00:16:48 Andreas Kupries <andreask@activestate.com>
+
+ Moved import plugin API to separate document, with import converter
+ API, and updated dependent manpages. HTML regenerated
+
+Fossil 2010-02-17 23:16:38 Andreas Kupries <andreask@activestate.com>
+
+ Moved export plugin API to separate document, with export converter
+ API, and updated dependent manpages. HTML regenerated
+
+Fossil 2010-02-17 19:37:45 Andreas Kupries <andreask@activestate.com>
+
+ Completed revamp of pt::pegen docs, regenerated the HTML
+
+Fossil 2010-02-17 00:42:06 Andreas Kupries <andreask@activestate.com>
+
+ Reworked the main docs a bit more, with pt::pgen moving to be
+ maintainer docs
+
+Fossil 2010-02-16 03:18:26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Postprocessing of benchmarks (get chars/seconds as easier to
+ understand measure of speed, and comparing two benchmarks)
+
+Fossil 2010-02-14 22:40:43 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Tcl/PARAM optimizations
+
+ * Dropped two irrelevant instructions at branch/choice exit.
+ * Merged two instructions at choice/branch init into one.
+ * Reorganized inter-branch transitions (changed which instructions are
+ merged into super), resulting in simplified internals of
+ instructions causing less stack-churn (adjacent pop/push cycles).
+
+ Total:
+ * Removed three instructions per choice.
+ * Simplified 1-2 instructions per choice branch.
+
+ Updated Tcl PEG parser to use these changes.
+ Updated testsuite to the changes in the generated Tcl parser code.
+
+ Performance Benchmarks:
+
+ Pure C parser unchanged, expected, as it is not modified by this.
+
+ Grammar interpreter unchanged, expected, as it is not modified by
+ this. Because of the actual looping it uses nothing can be
+ merged/simplified.
+
+ Tcl parsers. The interesting part.
+
+ * 13% speed gains on top of Tcl runtime with Tcl stacks.
+
+ Guessing that these gains are a combined effect of less stack churn
+ and lesser number of instructions (= time in dispatch).
+
+ * 7% speed gains on top of a Tcl runtime with C stacks.
+
+ Guessing that these gains are mainly by the lesser number of
+ instructions, whereas the reduced stack churn is negligible as the
+ stacks are already at C speed.
+
+ * No gains on top of a C runtime.
+
+ Dispatch and stacks are apparently already so fast that the
+ reductions we gain are negligible.
+
+ Full numbers:
+
+ +---+-------------------------------------------------------+-------------+pre mini-super
+ | | INTERP | 1 |
+ +---+-------------------------------------------------------+-------------+
+ | 1 | peg interpreter rde(critcl) stack(n/a) PEG | 921297.92 |
+ | 2 | peg interpreter rde(tcl) stack(critcl) PEG | 4126362.26 |
+ | 3 | peg interpreter rde(tcl) stack(tcl) PEG | 11270454.30 |
+ | 4 | peg specialized parse(critcl) rde(n/a) stack(n/a) PEG | 46029.57 |
+ | 5 | peg specialized parse(tcl) rde(critcl) stack(n/a) PEG | 202939.32 |
+ | 6 | peg specialized parse(tcl) rde(tcl) stack(critcl) PEG | 2730657.87 |
+ | 7 | peg specialized parse(tcl) rde(tcl) stack(tcl) PEG | 7286020.90 |
+ +---+-------------------------------------------------------+-------------+
+
+ +---+-------------------------------------------------------+-------------+post mini-super
+ | | INTERP | 1 |
+ +---+-------------------------------------------------------+-------------+
+ | 1 | peg interpreter rde(critcl) stack(n/a) PEG | 922109.94 |
+ | 2 | peg interpreter rde(tcl) stack(critcl) PEG | 4221659.87 |
+ | 3 | peg interpreter rde(tcl) stack(tcl) PEG | 11229381.00 |
+ | 4 | peg specialized parse(critcl) rde(n/a) stack(n/a) PEG | 45696.72 |
+ | 5 | peg specialized parse(tcl) rde(critcl) stack(n/a) PEG | 203223.80 |
+ | 6 | peg specialized parse(tcl) rde(tcl) stack(critcl) PEG | 2541266.51 |
+ | 7 | peg specialized parse(tcl) rde(tcl) stack(tcl) PEG | 6407152.80 |
+ +---+-------------------------------------------------------+-------------+
+
+ === sorted by speed (in chars/second) ===
+
+ PRE
+ interpreter n/a tcl tcl 11270454 11.27 3758.07 266.09
+ specialized tcl tcl tcl 7286021 7.29 2429.48 411.61
+ interpreter n/a tcl critcl 4126362 4.13 1375.91 726.79
+ specialized tcl tcl critcl 2730658 2.73 910.52 1098.27
+ interpreter n/a critcl n/a 921298 0.92 307.20 3255.19
+ specialized tcl critcl n/a 202939 0.20 67.67 14777.82
+ specialized critcl n/a n/a 46030 0.05 15.35 65153.77
+
+ POST speed normalized against PRE
+ interpreter n/a tcl tcl 11229381 11.23 3744.38 267.07 1.0037
+ specialized tcl tcl tcl 6407153 6.41 2136.43 468.07 1.1372
+ interpreter n/a tcl critcl 4221660 4.22 1407.69 710.38 0.9774
+ specialized tcl tcl critcl 2541267 2.54 847.37 1180.12 1.0745
+ interpreter n/a critcl n/a 922110 0.92 307.47 3252.32 0.9991
+ specialized tcl critcl n/a 203224 0.20 67.76 14757.13 0.9986
+ specialized critcl n/a n/a 45697 0.05 15.24 65628.34 1.0073
+
+ === sorted by runtime ===
+
+ interpreter n/a tcl tcl 11229381 11.23 3744.38 267.07 1.0037 +0.37% /effectively unchanged
+ interpreter n/a tcl critcl 4221660 4.22 1407.69 710.38 0.9774 -2.26%
+ interpreter n/a critcl n/a 922110 0.92 307.47 3252.32 0.9991 -0.09%
+
+ specialized tcl tcl tcl 6407153 6.41 2136.43 468.07 1.1372 +13.72% /pure tcl gain
+ specialized tcl tcl critcl 2541267 2.54 847.37 1180.12 1.0745 +7.45% /less gains because with C-stack gad already more speed
+ specialized tcl critcl n/a 203224 0.20 67.76 14757.13 0.9986 -0.14% /no real gains for C runtime. stack churn and icount
+ /dispatch not enough compared to C-speed alone
+ specialized critcl n/a n/a 45697 0.05 15.24 65628.34 1.0073 +0.73% /pure C was not changed.
+
+Fossil 2010-02-14 22:39:28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Dropped superfluous helper, and modified commit using message in a
+ file for newer fossil supporting -M
+
+Fossil 2010-02-14 06:06:13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Integrate changes anf fixes of [1dfde84572], [90da02b641],
+ [a67d8236f2] into the PEG critcl parser
+
+Fossil 2010-02-14 06:04:02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Put line markers into the inlined runtime
+
+Fossil 2010-02-14 06:02:07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix memory leak of state structure, of NC data, and stack
+ mishandling in pop/merge
+
+Fossil 2010-02-14 05:58:49 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Indentation fixup
+
+Fossil 2010-02-13 19:20:09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ This change needs a bit more explanation, as it may seem to
+ needlessly complicate the generator. First, when executing a choice
+ or sequence (/- and x-operators), we run choice/sequence-init, and
+ -exit, and in between these for each branch/part the
+ branch/part-init and -exit sequences, and in between that the
+ branch/part code itself. The generator is structured in the same
+ way, easily generating these code pieces. However, in the resulting
+ code choice/seq- and branch/part-init are adjacent, and the
+ branchpart-exit and -init of adjacent branches/parts are adjacent as
+ well. Looking at these combined sequences there are several
+ optimzation possibilites where the code can be simplified. The
+ re-structuring now causes the generator to emit these adjacent
+ sequences together, as they will occur in the output. In this way we
+ can see in the generator where we can optimize, something the
+ current simple system doesn't really show us. As is the change only
+ does the re-structuring, not the optimzation. That will happen in
+ subsequent checkins.
+
+Fossil 2010-02-13 19:19:38 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated tests affected by bugfix [e28495f2e4]
+
+Fossil 2010-02-12 23:46:48 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Started on super-instructions [daea5c0c82]. Tcl/PARAM generator and
+ rde/tcl
+
+Fossil 2010-02-12 23:45:05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix directory references to input, and package search
+
+Fossil 2010-02-12 20:08:39 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Tweaked docs for PEs a bit, to better differentiate between atomic
+ vs. combined PEs. Regenerated the HTML
+
+Fossil 2010-02-12 20:00:26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Continued work on the app documentation. Parser API docs completed
+
+Fossil 2010-02-12 08:22:21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ More doc work, app docs added, parser api doc started.
+
+Fossil 2010-02-11 05:18:21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix code-generation bug in C/PARAM for undefined nonterminals
+
+Fossil 2010-02-10 06:34:56 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Bugfix in container backend of pt::pgen, left-overs from the file
+ API
+
+Fossil 2010-02-10 06:24:22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ pt_pgen -> pt, better error handling, integrated help, command
+ syntax changes, to be documented
+
+Fossil 2010-02-10 04:30:51 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Moved parser regen helper app to a new tools directory
+
+Fossil 2010-02-10 04:30:18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated the active PEG parsers to the new grammar of [f5b89bb487]
+
+Fossil 2010-02-08 21:22:18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Drop references to struct::set implementation
+
+Fossil 2010-02-08 21:21:42 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Drop use of struct::set in json conversion tests, package not used
+
+Fossil 2010-02-08 21:20:28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix use of wrong tests/ file for json import, and remove references
+ to the struct::set implementation
+
+Fossil 2010-02-08 18:50:18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Gave the snit and tcloo generators a -package option, like we have
+ for critcl, updated the helper app (re)generating the peg parsers
+
+Fossil 2010-02-06 00:22:56 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Changed helper app for the regeneration of internal peg parser
+ packages to Tcl, from bash
+
+Fossil 2010-02-06 00:22:04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Extended pt_pgen wrapper app to supply input file info through
+ option -file
+
+Fossil 2010-02-06 00:21:34 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Bugfix of bad returns, wrongly squashing the result
+
+Fossil 2010-02-06 00:20:29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Creative writing bugfix
+
+Fossil 2010-02-05 23:39:51 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Move template file -> text conversion out of the pt::pgen package to
+ the wrapper application
+
+Fossil 2010-02-05 23:39:10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Brought generated HTML docs up to date
+
+Fossil 2010-02-05 23:35:25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Continued work on the pt::pgen manpage. Looks complete now
+
+Fossil 2010-02-05 23:34:44 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Tweak to the docgen helper
+
+Fossil 2010-02-05 06:13:24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Continued work on the redone pt_pgen manpage
+
+Fossil 2010-02-04 22:37:09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Manpage of pt::pgen restarted from scratch. Incomplete.
+
+Fossil 2010-02-04 20:12:14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Regenerated HTML after fixing a bug in doctools/html inter-document
+ link-generation
+
+Fossil 2010-02-04 08:31:02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Tweak the PEG language grammar: Simpler definitions of EOL,
+ WHITESPACE. Added missing definition of CONTROL. Updated all tests.
+ Fixed typo for SPACE in PEG AST processor, and added CONTROL there
+ as well.
+
+Fossil 2010-02-04 00:51:04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ pt::pgen switched to string API, wrapper app pt_pgen does files.
+ Updated docs. Simpler example.
+
+Fossil 2010-02-04 00:27:17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Small tweaks to filename and text of the peg language intro
+
+Fossil 2010-02-04 00:14:12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added tutorial/introduction to the text language for PE grammars.
+ Some tweaks.
+
+Fossil 2010-02-03 21:05:03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Reworked the why/whatis stuff, lots more examples, and all examples
+ bases on a standard grammar
+
+Fossil 2010-02-03 04:15:57 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Shuffled example and serialization spec includes around
+
+Fossil 2010-02-03 04:10:22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed bug in the RDE Tcl/C interface layer. Track Tcl_Obj* uwhose
+ intrep is an interned string, and invalidate them when the parser
+ state is destroyed. Otherwise a future parser may wrongly reuse an
+ already gone intrep. More asserts regarding use of string ids
+
+Fossil 2010-02-03 00:41:23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Now using a standard grammar (4-op expressions) for examples of
+ various representations
+
+Fossil 2010-02-02 23:09:15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Addressing another point made by Will, giving the JSON format its
+ own full-blown specification, and noting the similarity to the Tcl
+ serialization only at the end
+
+Fossil 2010-02-02 22:13:47 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated the documentation of pt::pgen to address points made by Will
+ in his review
+
+Fossil 2010-02-01 17:08:12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updates to HTML docs after tweaks in doc sources, see change
+ [86429d140d].
+
+Fossil 2010-02-01 04:36:24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed problem of TestFilesProcess with the cparam template, doing
+ unwanted replacements (because lots is using @ for placeholders, or
+ parts thereof). Solution is hackish, should find a different one
+
+Fossil 2010-02-01 04:34:52 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed lots of copy/paste bogosities in the cparam/critcl testsuite
+
+Fossil 2010-02-01 04:32:55 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Oops. Forgot the underlying test file in previous commit,
+ [513f872246]
+
+Fossil 2010-02-01 04:31:57 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated testing of peg importer, equivalent to the changes for
+ testing the core conversion, as per change [c71beb9c6f]
+
+Fossil 2010-02-01 04:30:41 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Force the irrelevant packages into quiescent state, this will also
+ catch if they are used again in the future
+
+Fossil 2010-02-01 04:29:21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added proper test results for cparam/critcl output
+
+Fossil 2010-02-01 04:28:43 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated test results, taking [ca324cb654] and [e1dd6a4871] into
+ account
+
+Fossil 2010-01-31 18:10:53 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed typo in comment
+
+Fossil 2010-01-31 00:39:51 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated benchmark numbers in my notes
+
+Fossil 2010-01-31 00:35:18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated the benchmarks to handle the 2 implementations of
+ pt::parse::peg, and have them ignore the irrelevant combinations
+
+Fossil 2010-01-30 23:35:33 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated tests to check both implementations of pt::parse::peg, as
+ introduced by [70bbe864da]
+
+Fossil 2010-01-30 23:34:48 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Modified pt::parse::peg to have two implementations, tcl and
+ c(ritcl)
+
+Fossil 2010-01-30 23:33:54 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ (1) Modified the critcl configuration to inline the C code of the
+ low-level PARAM engine, and to make its API static. Otherwise these
+ functions get into conflict with the pt::rde implementation using
+ the same functions underneath, if both are put into the same shared
+ library. This part uses the SCOPE feature introduced by
+ [d0367c875e]. (2) Added support for a package name separate from the
+ class/namespace information. (3) Implemented the missing 'destroy'
+ method for parser objects. This uses the new client data introduced
+ by [d0367c875e] to store the Tcl_Command token.
+
+Fossil 2010-01-30 23:15:16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ (1) Added notes about class option. (2) Fixed missing package
+ require, because pt::rde may not supply it anymore depending on
+ which implementation is chosen. (3) Made name of snit::type FQN,
+ otherwise use from an accel manager may bork.
+
+Fossil 2010-01-30 23:12:46 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Followup to [d0367c875e]. Commit the file which was left out of that
+ commit due to the bug fixed by [7920ef85].
+
+Fossil 2010-01-30 23:11:24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Oops, bug in the new commitm dropped first file from commits
+
+Fossil 2010-01-30 23:04:05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Reworked the low-level PARAM implementation. (1) Enabled the user to
+ change the level of visibility for the public functions. Default is
+ global, setting the define SCOPE allows changed. For example, to
+ 'static'. (2) Added a clientData field to the state structure, and
+ associated accessor functions.
+
+Fossil 2010-01-30 22:56:59 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added option -package to output format critcl
+
+Fossil 2010-01-30 22:55:56 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added proper class names, user info, and fixed path for outputfile
+
+Fossil 2010-01-30 22:54:50 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added commit helper reading message from file
+
+Fossil 2010-01-30 02:37:33 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Test setup tweaks. Better handling of parse errors in the converter
+ (more complete stack trace)
+
+Fossil 2010-01-29 20:02:02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated tests for pt::peg::from::peg. (1) Dropped struct::set, none
+ of the packages use it. (2) Adding handling of the pt::rde
+ accelerator.
+
+Fossil 2010-01-29 19:05:05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed bug introduced with [c0bab67996]. Snit's simpledispatch breaks
+ usage of 'return -code XXX', a construct I use in the guarded
+ control flow instructions, i.e. i:{ok,fail}_{continue,return}.
+
+Fossil 2010-01-29 03:41:05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Longer timeline
+
+Fossil 2010-01-29 01:23:02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added helper script to generate tcl and critcl parsers for PEG
+
+Fossil 2010-01-29 01:05:44 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed missing application of @ns@ when calling a parsing function
+
+Fossil 2010-01-29 01:01:36 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Tweaked C/PARAM formatting (kleene, poskleene, choice)
+
+Fossil 2010-01-29 00:31:10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added tests for C/PARAM conversion, bugfixes in code and draft test
+ controller
+
+Fossil 2010-01-29 00:02:57 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added docs for the new cparam converter and config, updated raft of
+ other docs
+
+Fossil 2010-01-29 00:01:55 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ The raw C output of the generator takes a -template option, not
+ -class
+
+Fossil 2010-01-29 00:01:15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Moved provide, notes on more placeholders, reduce Tcl requirement
+ due to critcl bailing out
+
+Fossil 2010-01-28 19:30:28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix missing package requirement. Cannot assume that pt::rde loads
+ it, as the rde may be C based
+
+Fossil 2010-01-28 19:29:40 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Critcl config of C/PARAM; Bugfixes; p vs param header, wrong types,
+ er_convert => rde_param_query_er_tcl, comment syntax, ordering of
+ the code blocks to avoid forward declarations
+
+Fossil 2010-01-28 19:27:15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Bugfixes in C/PARAM generator: i_symbol_restore calls, and bad subst
+ in the implementations of the specials.
+
+Fossil 2010-01-28 19:25:51 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Moved er_convert from method level to low-level PARAM, and renamed
+ to rde_param_query_er_tcl. Fixed PARAM headers, do not need anything
+ from the higher layer (no pInt)
+
+Fossil 2010-01-28 08:34:13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added draft conversion PEG to C/PARAM, and draft canned config for
+ embedding C/PARAM into a CriTcl environment
+
+Fossil 2010-01-27 00:29:53 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added parset method to the snit and oo templates, and the snit-based
+ peg-parser
+
+Fossil 2010-01-27 00:28:52 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Changed order of benchmarks
+
+Fossil 2010-01-26 20:11:23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Bugfix in nc_clear, forgot to delete the hash-entry pointing to the
+ deleted second-level tables, causing the i_symbol_ instructions to
+ try to operate on these deleted but reachable tables, and panicking
+
+Fossil 2010-01-26 19:57:34 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Benchmark tweaked, switched from virtual channel to parset/data for
+ direct use of a string
+
+Fossil 2010-01-26 19:51:58 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Oops in [70b3f95f5b]. Forgot to make icount init conditional. Fixed.
+
+Fossil 2010-01-26 19:42:17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added counting of instructions to the tracing (=> allows generation
+ of execution traces which are comparable between tcl/critcl
+ implementations)
+
+Fossil 2010-01-26 19:40:38 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed implementation of reset, made it handle a missing channel;
+ tweaks to the i_symbol_ functions
+
+Fossil 2010-01-26 19:32:38 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Bugfixes: i_input_next did not set ST/ER after reading from channel;
+ i_symbol_save used wrong location for key (CL instead of top(LS);
+ Added more asserts to i_value_reduce
+
+Fossil 2010-01-26 19:26:51 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added trace outside of the enter/leave tracking. Fixed bug in
+ printf, the buffer for fomratted data was to small four the data
+ structures (AST) we are tracking. Moved to static global, and made 1
+ MB (vs 0.5 KB on stack before)
+
+Fossil 2010-01-26 19:24:25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Draft definition for parsing from a string instead of channel
+
+Fossil 2010-01-26 19:23:39 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix ReadChar bug mishandling an undefined channel
+
+Fossil 2010-01-26 19:22:50 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added instruction trace-ability to Tcl RDE. Switch by (de-)comment.
+
+Fossil 2010-01-23 00:56:34 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ More tracing trying to find a mishandling of SV
+
+Fossil 2010-01-22 23:55:42 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Deactivated tracing again, and fix macro def error.
+
+Fossil 2010-01-22 23:53:44 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Optimize sv_set, ignore if value is unchanged, trace sv push on ast
+ a bit more
+
+Fossil 2010-01-22 23:44:27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix crash caused by bogus cleanup of read buffer in state reset
+
+Fossil 2010-01-22 23:43:24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Reworked and more tracing using the new enter/return
+
+Fossil 2010-01-22 23:43:00 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Handle void return in tracing and fix formatting of enter
+
+Fossil 2010-01-22 22:47:23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated trace users to the generic names
+
+Fossil 2010-01-22 22:46:55 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Extended the trace support to allow enter/return tracing; renamed to
+ be non-rde specific,; reactivated
+
+Fossil 2010-01-22 22:37:22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix typo in rde switcheroo
+
+Fossil 2010-01-20 00:42:50 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated benchmarks, allow them to switch between rde implementations
+
+Fossil 2010-01-20 00:27:29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Test tuning for RDE
+
+Fossil 2010-01-20 00:00:47 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Disabled tracing
+
+Fossil 2010-01-19 23:58:47 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added check of SV != NULL when pushing on the stack, this place
+ might be broken
+
+Fossil 2010-01-19 23:58:04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Dropped bogus range-check
+
+Fossil 2010-01-19 23:57:41 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed out-of-bounds message
+
+Fossil 2010-01-19 22:44:19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Traced, fixed missing update of string table size
+
+Fossil 2010-01-19 22:39:08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix off-by-one-error in TC query
+
+Fossil 2010-01-19 22:27:37 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Started tracing of crash ... Fixed missing return of function
+ rde_param_new()
+
+Fossil 2010-01-19 22:26:55 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added tracing support
+
+Fossil 2010-01-19 21:29:00 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed a few variable name typos
+
+Fossil 2009-12-18 23:13:44 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: More assertions, centered on the string table
+
+Fossil 2009-12-18 23:00:16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: Started peppering code with assertions. Factored
+ dup-string in param_intern into separate function. Noted how the
+ string table can be handled by RDE-stack, also that PARAM should
+ have string table size, for more assertions on use of string ids
+
+Fossil 2009-12-18 06:17:52 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: fix missing return of i_symbol_restore result (found
+ flag)
+
+Fossil 2009-12-18 06:14:17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: fix missing guard condition of i:ok_ast_value_push
+
+Fossil 2009-12-18 06:09:17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: Fix location err in i_error_nonterminal, and inline
+ error clearance into the test instructions
+
+Fossil 2009-12-18 06:00:13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: fix CL handling in error case of i_test instructions
+
+Fossil 2009-12-18 05:56:05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: fix off-by-one error in TC retrieval
+
+Fossil 2009-12-18 05:55:44 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: fix line/col init in TC append, and handling of
+ multiple chars
+
+Fossil 2009-12-18 05:55:15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: Added utility macro, panic after a count
+
+Fossil 2009-12-18 05:24:51 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: fix another instruction name typo
+
+Fossil 2009-12-18 05:19:25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: switch to snit2, import snit error support, fix arg
+ errors for instructions with such (missed arg names), converted all
+ wrong/args tests to support the different messages of snit/critcl
+
+Fossil 2009-12-18 05:18:13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: i_error_push fixed, handle NULL
+
+Fossil 2009-12-18 04:24:51 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: initialization fixes, NC key ordering fixes in query,
+ implemented "data" method
+
+Fossil 2009-12-18 04:23:01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: sync error message to tcl implementation
+
+Fossil 2009-12-18 04:22:02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: start on implementation specific results, and support
+ for it
+
+Fossil 2009-12-18 04:19:19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: TC append extend to take string instead of single char
+
+Fossil 2009-12-18 02:49:48 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: Fixed missing init of IN, and handle null IN for
+ queries
+
+Fossil 2009-12-18 02:49:15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: fix typos
+
+Fossil 2009-12-18 02:48:44 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl :: activate debugging support
+
+Fossil 2009-12-18 02:48:44 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ More helpers
+
+Fossil 2009-12-17 22:44:08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl - method complete done
+
+Fossil 2009-12-17 22:28:36 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl - SC accessors made
+
+Fossil 2009-12-17 22:11:06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl - added CL, TC accessors
+
+Fossil 2009-12-17 21:18:17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl - added accessors for SV, ARS, and AS
+
+Fossil 2009-12-17 21:04:07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl - added accessors for ER/ES
+
+Fossil 2009-12-17 20:15:24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl - added forgotten destroy method
+
+Fossil 2009-12-17 19:49:10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critc - query location stack
+
+Fossil 2009-12-17 19:36:56 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde c code - started implementing the query methods
+
+Fossil 2009-12-17 19:00:22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde critcl code - completed NC cleanup for reset and delete
+
+Fossil 2009-12-17 18:46:09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed various typos on the rde critcl code
+
+Fossil 2009-12-17 18:32:35 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ SC --> NC, to be consisten with the specification of the PARAM
+ architectural state
+
+Fossil 2009-12-17 18:29:22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde tests - completed ast/symbol instructions. basic tests for query
+ methods (they are indirectly tested everywhere, through their use in
+ the rde_state test helper procedure)
+
+Fossil 2009-12-17 00:25:25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde tests, ast instructions, mostly
+
+Fossil 2009-12-16 23:30:04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde tests, value instructions
+
+Fossil 2009-12-16 23:00:29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde tests, loc instructions
+
+Fossil 2009-12-16 22:25:25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde tests - switched back to myrde as std object, added missing
+ wrong args tests, more tests: status/symbol/error instructions
+
+Fossil 2009-12-16 22:23:25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde - Added method to preload TC
+
+Fossil 2009-12-16 19:20:43 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ rde - added tests for control flow instructions
+
+Fossil 2009-12-16 06:40:42 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ First set of tests, basic create/destroy
+
+Fossil 2009-12-16 06:40:24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix bug in handling of optional args to <tokens>
+
+Fossil 2009-12-16 06:39:54 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added state retrieval for tests
+
+Fossil 2009-12-16 05:59:18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Put std accel handling code on top, and started on the (way overdue)
+ rde testsuite.
+
+Fossil 2009-12-16 05:09:11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Make place for switchable main package with accelerators
+
+Fossil 2009-12-16 01:32:59 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Modified TC/CC interaction to avoid copying, now CC is pointer into
+ TC
+
+Fossil 2009-12-16 01:27:01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Second series of fixes for problems found by cc
+
+Fossil 2009-12-15 23:54:01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ First series of fixes for problems found by the cc
+
+Fossil 2009-12-15 23:22:29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Completed methods test_char/range, added string id ObjType, and use
+ to cache error message strings
+
+Fossil 2009-12-15 06:23:46 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ symbol cache handling completed, a number of bugfixes (typos), sv/er
+ macros for common ops
+
+Fossil 2009-12-15 05:24:26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated to changed stack API, added TC handling, completed
+ i_input_next and CC associated structures
+
+Fossil 2009-12-15 05:23:05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ New data structure, token cache, API and implementation
+
+Fossil 2009-12-15 05:22:43 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Moved API to long int, fixed API of _top, fixed type name typos
+
+Fossil 2009-12-15 00:21:28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Started on reading input in the C runtime
+
+Fossil 2009-12-14 23:35:35 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Update regarding non-use of interp
+
+Fossil 2009-12-14 23:35:19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix error message for i_errror_nonterminal
+
+Fossil 2009-12-14 23:26:45 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated interning of strings for class tests
+
+Fossil 2009-12-14 23:26:15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Implemented all instruction methods, but char/range testing, still
+ missing: query methods
+
+Fossil 2009-12-14 23:23:37 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Reworked char testing in lowest layer to use utf as primary rep,
+ unichar only for classes, and using public Tcl API for tess, instead
+ of doing eval. removed interp, not needed any longer. still missing:
+ symbol, terminal caches
+
+Fossil 2009-12-14 21:08:04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added string interning functionality
+
+Fossil 2009-12-14 21:07:45 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added API to update the string table in use
+
+Fossil 2009-12-14 20:03:12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Implemented the simple instructions (no arguments, no query but ST)
+
+Fossil 2009-12-14 20:01:45 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added API to query ST
+
+Fossil 2009-12-14 19:42:30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added method boilerplate code (syntax info, basic argument check
+ derived from that, todo markers)
+
+Fossil 2009-12-14 05:07:03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Continued work on C RDE runtime, here working from the top down.
+
+Fossil 2009-12-13 08:07:21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Continued work on the C runtime, low level data structures and
+ functions for PARAM state
+
+Fossil 2009-12-13 08:06:53 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ typo fix
+
+Fossil 2009-12-13 01:41:04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Started on a critcl implementation of the runtime
+
+Fossil 2009-12-13 01:38:08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Inlined okfail for the 2 most-used i_test_xxx instructions, and for
+ the remainder pre-compute the error messages
+
+Fossil 2009-12-13 01:37:04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ More iterations
+
+Fossil 2009-12-13 01:36:40 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Verbose benchmarks, and bench with comparison to a baseline
+
+Fossil 2009-12-13 00:54:38 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added helper command for benchmarking, and notes about performance
+ on my machine (vs gila).
+
+Fossil 2009-12-12 00:04:20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ typo
+
+Fossil 2009-12-12 00:04:15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Nother idea
+
+Fossil 2009-12-11 22:29:14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Draft runtime based on TclOO, plus notes on optimization
+ possibilities
+
+Fossil 2009-12-11 22:26:48 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ typo bugfix
+
+Fossil 2009-12-11 21:41:59 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Basic docs for the parser generator on top of everything
+
+Fossil 2009-12-11 20:26:53 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Draft testcases for TclOO/PARAM
+
+Fossil 2009-12-11 20:03:09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ First benchmarks, and notes on results. We are no speed demon.
+
+Fossil 2009-12-11 18:20:24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Slight tweak dropping struct::set dependency
+
+Fossil 2009-12-11 17:21:39 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Pulled some outside notes in
+
+Fossil 2009-12-11 17:14:41 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added generated html docs to repo
+
+Fossil 2009-12-11 17:13:42 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Changed doc html gen to save results in a module-local directory
+
+Fossil 2009-12-11 17:10:29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added table - instructions vs state
+
+Fossil 2009-12-11 08:16:27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added Tcl/PARAM canned config: tcloo based parser classes
+
+Fossil 2009-12-11 08:15:22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed the space/whitespace problem of the PEG pe-grammar across all
+ representations in the tests
+
+Fossil 2009-12-11 08:13:28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated tests to changes in Tcl/PARAM snit config
+
+Fossil 2009-12-11 06:09:51 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Generated snit parser for PEG, made a package, and switched from-peg
+ converter from interpreter to compiled parser
+
+Fossil 2009-12-11 06:08:09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Tweaked snit parser to use procs instead of methodschanged
+
+Fossil 2009-12-11 06:06:43 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added prelude config option, and tweaked the placeholder processing
+ to remove unneeded space
+
+Fossil 2009-12-11 06:05:18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added i:ok_return instruction, use of stack get method in places
+
+Fossil 2009-12-11 06:04:26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Extended generator with serial input, and snit output
+
+Fossil 2009-12-11 06:03:38 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added script app around pt::pgen
+
+Fossil 2009-12-11 02:56:12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Tcl/PARAM snit config: bugfixes, tweaks. Tcl/PARAM: bugfixes, tweaks
+
+Fossil 2009-12-11 00:59:59 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ tcl/param configuration - snit, basics
+
+Fossil 2009-12-10 22:43:12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated docs of Tcl/PARAM converter
+
+Fossil 2009-12-10 08:04:14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed logic error in param assembler, updated testcases. Found while
+ working on the tcl/param converter.
+
+Fossil 2009-12-10 07:56:54 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Remove unwanted file
+
+Fossil 2009-12-10 07:55:10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added parameterizable param assembler generating tcl code. Need
+ predefined configs for plain Tcl, snit, TclOO. Need config handling
+ too.
+
+Fossil 2009-12-10 04:04:32 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix typos in &/! test results
+
+Fossil 2009-12-09 07:29:05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Redone innards of PARAM assembler again. Now looks a bit like a DSL
+ for specifying the translation. New features - compact/inline, with
+ previous state inlined-non-compact, and now default inlined-compact.
+ compact shares PE translations = common sub expression elimination.
+ new test cases
+
+Fossil 2009-12-09 00:59:43 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added method for block existence check
+
+Fossil 2009-12-09 00:59:21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added example code
+
+Fossil 2009-12-08 08:18:01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Optimized the manageent of the ARS/AS stacks, based on semantic
+ modes and derived ability to generate AST nodes by partial
+ expressions. Rewrote generator innards to use a dict instead of list
+ for bottom up data transfer (more extensible), tweaked instruction
+ order. Updated associated tests.
+
+Fossil 2009-12-08 05:02:10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Tests cases for & and ! (pos/neg look-ahead) operators added
+
+Fossil 2009-12-08 05:01:40 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ whitespace tweak
+
+Fossil 2009-12-06 01:52:36 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated tests for [7c2d7d4320]
+
+Fossil 2009-12-06 00:58:28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Testcases for ? * and + operators added
+
+Fossil 2009-12-05 00:06:22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ draft of the transform optimizing mode assignments
+
+Fossil 2009-12-04 23:33:50 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Factored a helper for drop unrealizable to the PE operations
+
+Fossil 2009-12-04 21:29:54 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ New grammar transform taking out symbol chains, where allowed by the
+ modes
+
+Fossil 2009-12-04 20:56:40 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix bugs (missing export, wrong operation on start expr in called)
+
+Fossil 2009-12-04 20:49:59 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ cleanup from the space clash, now space and whitespace
+
+Fossil 2009-12-04 19:49:13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Bugfixes in the grammar op, from typos to functional
+
+Fossil 2009-12-04 19:37:52 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Make grammar transforms a visible package
+
+Fossil 2009-12-04 19:37:24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix bug in Called for prefix/suffix operators
+
+Fossil 2009-12-04 19:36:53 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Clean export list
+
+Fossil 2009-12-04 07:36:05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Upddated intro with new/gone packages
+
+Fossil 2009-12-04 07:34:38 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added expression printouts in comments to the param asssembler
+ output
+
+Fossil 2009-12-04 07:34:04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ First grammar transforms
+
+Fossil 2009-12-04 07:11:35 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Changed PEG grammar definition, allowing grammars without symbols
+ and rules, only the strt expression
+
+Fossil 2009-12-04 03:28:56 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added param assembler as output to the parser generator. Fixed
+ template handling
+
+Fossil 2009-12-03 06:18:49 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Basic testcase: sequence operator
+
+Fossil 2009-12-03 06:07:38 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixing missing reset of label, etc. counter
+
+Fossil 2009-12-03 06:07:00 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Basic testcase: choice operator, and killed trailing whitespace
+
+Fossil 2009-12-03 06:06:02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Killed the cryptic text::write commands, also now removing trailing
+ whitespace when making new lines
+
+Fossil 2009-12-03 03:47:13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ completed converter to param assembler
+
+Fossil 2009-12-03 03:16:12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added quote cstring, for writing chars usable in C code
+
+Fossil 2009-12-03 03:15:46 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added undef method, to remove saved blocks
+
+Fossil 2009-12-03 00:17:17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Completely refactored the assembler internals, started on more use
+ of jump flow in the functions
+
+Fossil 2009-12-02 00:24:45 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ continued work on the param export
+
+Fossil 2009-12-02 00:24:28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ update helper
+
+Fossil 2009-12-01 15:17:20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Canonicalize pe on input to container
+
+Fossil 2009-12-01 07:33:30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Continued work on param export.
+
+Fossil 2009-12-01 00:48:35 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Started on export to param assembler, in prep for other exports to
+ executable code
+
+Fossil 2009-11-30 06:24:57 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed missing packages, plus new package, parser gen, finally, first
+ draft
+
+Fossil 2009-11-30 06:20:42 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ fixed missing var decl
+
+Fossil 2009-11-30 06:02:01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ fixed copyright typo
+
+Fossil 2009-11-30 06:00:32 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ updated architectural package information
+
+Fossil 2009-11-30 06:00:07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed peg import/export references
+
+Fossil 2009-11-30 05:59:46 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ updated documented peg syntax
+
+Fossil 2009-11-30 05:57:56 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Importing from PEG text, conversion core and plugin. placeholder
+ docs for container import
+
+Fossil 2009-11-30 05:29:36 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ fix comment type
+
+Fossil 2009-11-30 02:39:35 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ bug fixes, missing args, bad type codes, negated condition
+
+Fossil 2009-11-30 01:20:32 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed parens generation for x / operators, and added priorities for
+ str/cl
+
+Fossil 2009-11-29 23:57:46 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added missing constructor
+
+Fossil 2009-11-29 22:03:37 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed char order issue in char class, and dependent representations
+
+Fossil 2009-11-29 22:02:38 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ fix test numbering
+
+Fossil 2009-11-29 22:02:08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ another helper
+
+Fossil 2009-11-29 21:40:39 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ bug fixes: chan, ars/as handling, i_test_ arguments and error
+ messaging, varname typos
+
+Fossil 2009-11-29 21:37:41 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ bugfix in ?, savemode, factored next to method, one place doing call
+ -> atomic pe conversion
+
+Fossil 2009-11-29 21:36:54 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ change for easier reading
+
+Fossil 2009-11-29 09:44:34 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ fixed nonterminal clash in peg grammar
+
+Fossil 2009-11-29 09:44:15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ fixed missing package in index
+
+Fossil 2009-11-29 08:17:14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ subst -> string map is easier, fixed missing state var for rde
+
+Fossil 2009-11-29 08:16:44 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ added missing packages
+
+Fossil 2009-11-29 07:55:38 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ added preloaded container holding the PEG grammar specification,
+ updated doc pkg index
+
+Fossil 2009-11-29 07:50:20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ fixed outdated references
+
+Fossil 2009-11-29 07:17:36 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ added import manager, docs, tests. added import info to the module
+ architectural information, updated package index
+
+Fossil 2009-11-29 07:16:30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ added import docs and text blocks
+
+Fossil 2009-11-29 07:15:36 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ dropped duplicates
+
+Fossil 2009-11-29 06:43:06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ importing from json
+
+Fossil 2009-11-29 06:34:05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ typo
+
+Fossil 2009-11-29 06:33:53 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ typo & formatting tweak
+
+Fossil 2009-11-29 06:05:47 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ fix typos
+
+Fossil 2009-11-29 03:33:15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ typo fix
+
+Fossil 2009-11-29 03:28:57 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Typos and comnsolidation
+
+Fossil 2009-11-29 00:59:13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated dependency info, and comments on PARAM state
+
+Fossil 2009-11-29 00:45:24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Brought the peg interpreter docs uptodate with its implementation
+
+Fossil 2009-11-29 00:43:56 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed typo, missing element, and added notes on channel usage
+
+Fossil 2009-11-29 00:15:00 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Finalized the param-based RDE, instruction set and names, per the
+ needs of the PEG interpreter
+
+Fossil 2009-11-28 23:51:15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Grammar Interpreter - Fix cons bug, switch to methods for direct
+ execution to simplify access to state, simplified execution due to
+ mode changes, ast changes. Finalized instructions used, and names
+
+Fossil 2009-11-28 22:39:40 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Simplified PARAM after AST changes
+
+Fossil 2009-11-28 00:44:36 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Consequence of AST changes, semantic modes: drop match, identical to
+ leaf now. further: discard -> void for consistency across all things
+
+Fossil 2009-11-27 23:51:47 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Changed AST definition to not contain terminals, only nonterminals
+
+Fossil 2009-11-27 07:32:18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Removed 2 now superfluous include files
+
+Fossil 2009-11-27 07:23:21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Reworked the RDE docs to take advantage of the PARAM spec
+
+Fossil 2009-11-27 07:22:49 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Completed the PARM spec
+
+Fossil 2009-11-27 07:22:36 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed typo
+
+Fossil 2009-11-27 03:55:54 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Complete reworking the interpreter to perform direct execution of an
+ expression
+
+Fossil 2009-11-27 03:55:18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed typo
+
+Fossil 2009-11-27 00:40:56 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Started to rework the PEG intepreter from a big switch to a direct
+ execution model
+
+Fossil 2009-11-27 00:27:09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Continued work on the param spec
+
+Fossil 2009-11-26 08:04:13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Started separate doc for the virtual machine behind rde, named PARAM
+ aka PAck RAt Machine
+
+Fossil 2009-11-26 07:28:07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ helper for forced commit
+
+Fossil 2009-11-26 07:27:19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Title tweak, and changes to instruction names
+
+Fossil 2009-11-26 00:38:44 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ More tweaks
+
+Fossil 2009-11-26 00:33:17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Reworking the rde docs ... put associated methods and state
+ descriptions together
+
+Fossil 2009-11-25 23:19:32 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ clarification of mycurrent, drop empty string from token description
+
+Fossil 2009-11-25 23:17:08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Tweak converter/export titles
+
+Fossil 2009-11-25 07:02:55 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Started on documenting the parser/runtime state
+
+Fossil 2009-11-25 06:27:39 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Completes docs for the methods of the runtime; modified complete to
+ not use an artificial symbol for aggregation if the AST stack has
+ only one AST.
+
+Fossil 2009-11-25 06:07:52 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Drop dependency on textutil, fix typo
+
+Fossil 2009-11-24 08:49:27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Documented the instructions handling locations and ast stack. Fixed
+ argument errors of the AST methods
+
+Fossil 2009-11-24 08:41:06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Documented the instructions handling symbol cache and semantic value
+
+Fossil 2009-11-24 07:40:02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Completed docs of the i_chan instructions
+
+Fossil 2009-11-24 07:16:04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed description of serialize
+
+Fossil 2009-11-24 07:09:39 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Work on the parser runtime, first doc draft
+
+Fossil 2009-11-24 07:08:47 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix section reference
+
+Fossil 2009-11-24 07:08:27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix section reference
+
+Fossil 2009-11-23 21:54:38 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Strip down and streamline the introduction to parsing expression
+ grammars.
+
+Fossil 2009-11-22 01:57:38 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ AST structure handling, code, doc, tests
+
+Fossil 2009-11-22 01:57:14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Tweak labels, drop now irrelevant use of struct::set
+
+Fossil 2009-11-21 23:12:01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Typo fixes, and phrasing cleanup
+
+Fossil 2009-11-21 08:55:23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ More work on the docs for ASTs
+
+Fossil 2009-11-21 08:39:03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Tweaks, and formalized the reference from each package to its place
+ in the module architecture
+
+Fossil 2009-11-21 08:37:58 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ More architecture info, core layer structure
+
+Fossil 2009-11-21 08:37:36 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Docs for ASTs
+
+Fossil 2009-11-21 06:41:36 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Continued the renaming to "pt" prefix.
+
+Fossil 2009-11-21 06:28:00 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ doc tweaks
+
+Fossil 2009-11-21 06:01:41 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Removed the bogus file for which I did the fork dance, and updated
+ test names for the "pt" prefix
+
+Fossil 2009-11-21 05:57:11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ pt::peg::structure --> pt::peg
+
+Fossil 2009-11-21 05:46:36 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Merge saved file back
+
+Fossil 2009-11-21 05:45:04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Proper file name
+
+Fossil 2009-11-21 05:25:06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Moved pt::peg --> pt::peg::container, as it should have been
+
+Fossil 2009-11-20 06:38:54 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Simplify pt::pe::structure --> pt::pe
+
+Fossil 2009-11-20 06:08:33 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix typo, and tweaked source readability
+
+Fossil 2009-11-20 05:34:32 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Switch from grammar(_peg) to "pt" (Parser Tools). Code, tests, and
+ docs.
+
+Fossil 2009-11-20 04:42:01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Factored more common parts of the documentation into their own
+ files, included as needed.
+
+Fossil 2009-11-20 03:39:08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Started on top-down docs, with an introduction, and the basics
+
+Fossil 2009-11-20 03:14:31 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated to handle module rename grammar_peg -> pt
+
+Fossil 2009-11-20 03:13:07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added markers to fileutil::fileType
+
+Fossil 2009-11-19 19:51:06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added notes re expression equivalence and simplification and how the
+ t/.. commit [21c4130f31] started a slippery slope
+
+Fossil 2009-11-19 07:01:15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Extended peg 2 peg conversion with flatten/fused for string/class
+ aggregation
+
+Fossil 2009-11-19 06:09:48 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Split PE structure handling into basic and advanced, moving
+ rename/called to the latter. Extended advanced with 2 new ops to
+ simplify/transforms expressions.
+
+Fossil 2009-11-19 04:45:13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Dropped code from peg2peg conversion made irrelevant by commit
+ [21c4130f31].
+
+Fossil 2009-11-19 04:43:51 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Simplified the expression walker commands
+
+Fossil 2009-11-19 04:39:19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Nailed down an ambiguity in the canonical PE serialization (t X <=>
+ .. X X)
+
+Fossil 2009-11-19 03:45:49 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Split json export into core converter, and small plugin
+
+Fossil 2009-11-19 03:45:01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Typo fixes
+
+Fossil 2009-11-18 05:06:43 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Three files forgotten in last commit
+
+Fossil 2009-11-18 05:05:45 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Split peg export into core converter, and small plugin
+
+Fossil 2009-11-18 05:03:26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed typos, cleanup
+
+Fossil 2009-11-18 05:02:23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added restricted delta variant
+
+Fossil 2009-11-17 06:28:21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Split the container export plugin into a regular converter package
+ and a much smaller plugin, essentially just a shim between manager
+ and converter. For direct use of the converter in trusted
+ environment, where the overhead of the safe base is not needed.
+
+Fossil 2009-11-17 06:26:19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ text::write API extension, readable cmd names
+
+Fossil 2009-11-17 06:24:28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Tweaked doc generation command, clear screen
+
+Fossil 2009-11-16 05:54:38 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix bugs in the container export (missing component setup, bad
+ access to component), updates tests
+
+Fossil 2009-11-16 05:42:43 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ container export extended with templating, new testcases, and doc
+ brought up to date
+
+Fossil 2009-11-16 05:23:20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed var name oops
+
+Fossil 2009-11-16 03:53:00 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated package requirements in docs
+
+Fossil 2009-11-16 03:50:44 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added forgotten char utility package implementation
+
+Fossil 2009-11-16 03:50:03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed bugs in peg export, and added char quoting, updated tests
+
+Fossil 2009-11-16 03:49:25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added char quoting to container generation, updated all affected
+ test files
+
+Fossil 2009-11-16 03:48:34 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added char quoting to expression printing, updated affected test
+ files
+
+Fossil 2009-11-16 03:45:33 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix file access in tests, assume utf8 and binary eol == identity to
+ internals
+
+Fossil 2009-11-16 03:44:55 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Index the char utility package
+
+Fossil 2009-11-16 03:44:31 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added pre-cleanup to test runs
+
+Fossil 2009-11-16 03:42:41 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added test files for self-referential peg grammar
+
+Fossil 2009-11-15 21:48:58 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Lifted the peg & container plugin tests to the export manager
+
+Fossil 2009-11-15 21:42:01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ New export plugin, "container". Result is snit::type around
+ grammar::peg, preloaded with the exported grammar
+
+Fossil 2009-11-15 21:40:56 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Extended container bulk query methods with bulk setting, and
+ modified add/remove to accept multiple and zero arguments
+
+Fossil 2009-11-15 20:15:43 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ New method -, undo last +, extend ++ to accept multiple fields
+
+Fossil 2009-11-15 19:37:45 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added recall+add stack operator, added full reset command, changed
+ get/getl to perform full reset before returning the (saved) current
+ block.
+
+Fossil 2009-11-15 19:26:17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Bring the plugin package requirements uptodate
+
+Fossil 2009-11-15 19:14:11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ PEG grammar in PEG text, for future tests
+
+Fossil 2009-11-15 17:56:05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Reworked peg/peg export to use the text generation support package
+
+Fossil 2009-11-15 17:54:02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Wrote text generation support package. Derived from the
+ doctools2base package, but modified, hopefully clearer/easier to use
+
+Fossil 2009-11-15 16:55:25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ peg/peg export test results updated to current output, as near-final
+
+Fossil 2009-11-15 10:01:38 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Continued work on expression/text conversion, basic conversion is
+ done
+
+Fossil 2009-11-15 09:12:34 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Draft peg to peg export, and test case. Fail: Expression conversion
+ not done yet
+
+Fossil 2009-11-15 09:11:32 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Typo fix
+
+Fossil 2009-11-15 09:11:09 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Typo fixes
+
+Fossil 2009-11-15 09:10:49 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Test execution tweak
+
+Fossil 2009-11-15 08:20:08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added documentation for the PEG text representation
+
+Fossil 2009-11-15 08:19:43 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Version fix, and slight editing of json export docs
+
+Fossil 2009-11-15 06:36:48 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Documentation fixes
+
+Fossil 2009-11-15 06:36:28 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Shortcuts to fossil
+
+Fossil 2009-11-15 05:55:15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Factored json specific generation into separate package
+
+Fossil 2009-11-15 05:54:36 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed required and provided versions
+
+Fossil 2009-11-15 05:54:12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed missing indicator of chosen struct::set implementation n the
+ export test cases
+
+Fossil 2009-11-15 05:07:29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Updated export to integrate json tests
+
+Fossil 2009-11-15 05:06:55 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added json export
+
+Fossil 2009-11-15 05:03:12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Update tests for error message changes, added tests of
+ verify-as-canonical, followup on last change
+
+Fossil 2009-11-15 05:01:24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix trailing white space in the canonical peg serializations, fix
+ error message for it
+
+Fossil 2009-11-15 01:51:37 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Added export manager (code, doc test), draft, as we have no actual
+ plugins yet
+
+Fossil 2009-11-15 01:50:40 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Container paren mismatch fix, and tweak of test setup for future
+ testing of import/export management
+
+Fossil 2009-11-15 01:45:39 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Documentation fixes re package and version requirements
+
+Fossil 2009-11-14 09:01:33 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Reworked instructions in the PEG interpreter, and added first draft
+ of the RD engine (= runtime)
+
+Fossil 2009-11-14 07:29:43 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Bumped the version number, this is planned to become the first
+ mature version
+
+Fossil 2009-11-14 07:29:05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Revamped the PEG interpreter. Has no actual foundation for execution
+ yet
+
+Fossil 2009-11-14 07:11:32 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Reformatted a few commands, lsearch -> in, dropped old peg.tcl
+
+Fossil 2009-11-14 04:23:46 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Lifted PEG handling to 8.5 (lassign, ensemble), updated tests. Test
+ canonicalize
+
+Fossil 2009-11-14 03:47:52 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Drop snit requirement, and modified bottomup along the lines of
+ topdown, cmdprefix now has access to caller context
+
+Fossil 2009-11-14 03:44:03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ PE handling now distinguishes regular/canonical serialization
+ (latter = pure list). Updated code, doc, tests, users. topdown
+ method modified to allow callback to reach into caller context
+
+Fossil 2009-11-14 02:47:02 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ pe::structure revamped for 8.5 (expansion, lassign, ensemble)
+
+Fossil 2009-11-13 23:50:18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Revamped the container class. General structure with extensible
+ import/export like for doctools v2. Dropped validity tracking.
+ Switched to the structure packages for PE/PEG validation and
+ handling. Basic tests
+
+Fossil 2009-11-13 23:49:01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Forgotten testfiles for grammar merge
+
+Fossil 2009-11-13 23:48:16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ PEG handling extended, grammar merging added, inlined rule
+ canonicalization
+
+Fossil 2009-11-13 23:47:16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ File forgotten in last commit
+
+Fossil 2009-11-13 23:45:47 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ PE handling extended, structural equality check added
+
+Fossil 2009-11-12 21:10:10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fixed bug in topdown method, made bottomup and topdown public (added
+ docs and tests)
+
+Fossil 2009-11-12 06:17:35 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Common text block about symbol modes. Container API tweaks.
+
+Fossil 2009-11-12 06:02:49 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Complete PEG structure spec, verification code, and testsuite
+
+Fossil 2009-11-12 06:02:00 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Fix printing bug in the handling of argument results
+
+Fossil 2009-11-12 04:43:12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ Baseline for the PEG modules and packages
+
+Fossil 2009-11-12 04:37:03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ initial empty check-in
diff --git a/tcllib/modules/pt/char.tcl b/tcllib/modules/pt/char.tcl
new file mode 100644
index 0000000..f7d2e57
--- /dev/null
+++ b/tcllib/modules/pt/char.tcl
@@ -0,0 +1,289 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Operations with characters: (Un)quoting.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+
+namespace eval char {
+ namespace export unquote quote
+ namespace ensemble create
+ namespace eval quote {
+ namespace export tcl string comment cstring
+ namespace ensemble create
+ }
+}
+
+# ### ### ### ######### ######### #########
+## API
+
+proc ::char::unquote {args} {
+ if {1 == [llength $args]} { return [Unquote {*}$args] }
+ set res {}
+ foreach ch $args { lappend res [Unquote $ch] }
+ return $res
+}
+
+proc ::char::Unquote {ch} {
+
+ # A character, stored in quoted form is transformed back into a
+ # proper Tcl character (i.e. the internal representation).
+
+ switch -exact -- $ch {
+ "\\n" {return \n}
+ "\\t" {return \t}
+ "\\r" {return \r}
+ "\\[" {return \[}
+ "\\]" {return \]}
+ "\\'" {return '}
+ "\\\"" {return "\""}
+ "\\\\" {return \\}
+ }
+
+ if {[regexp {^\\([0-2][0-7][0-7])$} $ch -> ocode]} {
+ return [format %c $ocode]
+
+ } elseif {[regexp {^\\([0-7][0-7]?)$} $ch -> ocode]} {
+ return [format %c 0$ocode]
+
+ } elseif {[regexp {^\\u([[:xdigit:]][[:xdigit:]]?[[:xdigit:]]?[[:xdigit:]]?)$} $ch -> hcode]} {
+ return [format %c 0x$hcode]
+
+ }
+
+ return $ch
+}
+
+# ### ### ### ######### ######### #########
+
+proc ::char::quote::tcl {ch args} {
+ Arg Tcl $ch {*}$args
+}
+
+proc ::char::quote::Tcl {ch} {
+ # Input: A single character
+ # Output: A string representing the input.
+ # Properties of the output:
+ # (1) Contains only ASCII characters (7bit Unicode subset).
+ # (2) When embedded in a ""-quoted Tcl string in a piece of Tcl
+ # code the Tcl parser will regenerate the input character.
+
+ # Special character?
+ switch -exact -- $ch {
+ "\n" {return "\\n"}
+ "\r" {return "\\r"}
+ "\t" {return "\\t"}
+ "\\" - "\;" -
+ " " - "\"" -
+ "(" - ")" -
+ "\{" - "\}" -
+ "\[" - "\]" {
+ # Quote space and all the brackets as well, using octal,
+ # for easy impure list-ness.
+
+ scan $ch %c chcode
+ return \\[format %o $chcode]
+ }
+ }
+
+ scan $ch %c chcode
+
+ # Control character?
+ if {[::string is control -strict $ch]} {
+ return \\[format %o $chcode]
+ }
+
+ # Unicode beyond 7bit ASCII?
+ if {$chcode > 127} {
+ return \\u[format %04x $chcode]
+ }
+
+ # Regular character: Is its own representation.
+ return $ch
+}
+
+# ### ### ### ######### ######### #########
+
+proc ::char::quote::string {ch args} {
+ Arg String $ch {*}$args
+}
+
+proc ::char::quote::String {ch} {
+ # Input: A single character
+ # Output: A string representing the input
+ # Properties of the output
+ # (1) Human-readable, for use in error messages, or comments.
+ # (1a) Uses only printable characters.
+ # (2) NO particular properties with regard to C or Tcl parsers.
+
+ scan $ch %c chcode
+
+ # Map the ascii control characters to proper names.
+ if {($chcode <= 32) || ($chcode == 127)} {
+ variable strmap
+ return [dict get $strmap $chcode]
+ }
+
+ # Printable ascii characters represent themselves.
+ if {$chcode < 128} {
+ return $ch
+ }
+
+ # Unicode characters. Mostly represent themselves, except if
+ # control or not printable. Then they are represented by their
+ # codepoint.
+
+ # Control characters: Octal
+ if {[::string is control -strict $ch] ||
+ ![::string is print -strict $ch]} {
+ return <U+[format %04x $chcode]>
+ }
+
+ return $ch
+}
+
+namespace eval ::char::quote {
+ variable strmap {
+ 0 <NUL> 8 <BS> 16 <DLE> 24 <CAN> 32 <SPACE>
+ 1 <SOH> 9 <TAB> 17 <DC1> 25 <EM> 127 <DEL>
+ 2 <STX> 10 <LF> 18 <DC2> 26 <SUB>
+ 3 <ETX> 11 <VTAB> 19 <DC3> 27 <ESC>
+ 4 <EOT> 12 <FF> 20 <DC4> 28 <FS>
+ 5 <ENQ> 13 <CR> 21 <NAK> 29 <GS>
+ 6 <ACK> 14 <SO> 22 <SYN> 30 <RS>
+ 7 <BEL> 15 <SI> 23 <ETB> 31 <US>
+ }
+}
+
+# ### ### ### ######### ######### #########
+
+proc ::char::quote::cstring {ch args} {
+ Arg CString $ch {*}$args
+}
+
+proc ::char::quote::CString {ch} {
+ # Input: A single character
+ # Output: A string representing the input.
+ # Properties of the output:
+ # (1) Contains only ASCII characters (7bit Unicode subset).
+ # (2) When embedded in a ""-quoted C string in a piece of
+ # C code the C parser will regenerate the input character
+ # in UTF-8 encoding.
+
+ # Special characters (named).
+ switch -exact -- $ch {
+ "\n" {return "\\n"}
+ "\r" {return "\\r"}
+ "\t" {return "\\t"}
+ "\"" - "\\" {
+ return \\$ch
+ }
+ "\{" - "\}" {
+ # The generated C code containing the result of this
+ # transform may be embedded in Tcl code (Brace-quoted),
+ # i.e. like for a critcl-based package. To avoid tripping
+ # the Tcl parser with unbalanced braces we sacrifice
+ # readability of the generated code a bit and insert
+ # braces in their octal form.
+ scan $ch %c chcode
+ return \\[format %o $chcode]
+ }
+ }
+
+ scan $ch %c chcode
+
+ # Control characters: Octal
+ if {[::string is control -strict $ch]} {
+ return \\[format %o $chcode]
+ }
+
+ # Beyond 7-bit ASCII: Unicode
+ if {$chcode > 127} {
+ # Recode the character into the sequence of utf-8 bytes and
+ # convert each to octal.
+ foreach x [split [encoding convertto utf-8 $ch] {}] {
+ scan $x %c x
+ append res \\[format %o $x]
+ }
+ return $res
+ }
+
+ # Regular character: Is its own representation.
+
+ return $ch
+}
+
+# ### ### ### ######### ######### #########
+
+proc ::char::quote::comment {ch args} {
+ Arg Comment $ch {*}$args
+}
+
+proc ::char::quote::Comment {ch} {
+ # Converts a Tcl character (internal representation) into a string
+ # which is accepted by the Tcl parser when used within a Tcl
+ # comment.
+
+ # Special characters
+
+ switch -exact -- $ch {
+ " " {return "<blank>"}
+ "\n" {return "\\n"}
+ "\r" {return "\\r"}
+ "\t" {return "\\t"}
+ "\"" -
+ "\{" - "\}" -
+ "(" - ")" {
+ return \\$ch
+ }
+ }
+
+ scan $ch %c chcode
+
+ # Control characters: Octal
+ if {[::string is control -strict $ch]} {
+ return \\[format %o $chcode]
+ }
+
+ # Beyond 7-bit ASCII: Unicode
+
+ if {$chcode > 127} {
+ return \\u[format %04x $chcode]
+ }
+
+ # Regular character: Is its own representation.
+
+ return $ch
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Argument processing helper
+
+proc ::char::quote::Arg {cmdpfx str args} {
+ # single argument => treat as string,
+ # process all characters separately.
+ # return transformed string.
+ if {![llength $args]} {
+ set r {}
+ foreach c [split $str {}] {
+ append r [uplevel 1 [linsert $cmdpfx end $c]]
+ }
+ return $r
+ }
+
+ # multiple arguments => process each like a single argument, and
+ # return list of transform results.
+ set args [linsert $args 0 $str]
+ foreach str $args {
+ lappend res [uplevel 1 [list Arg $cmdpfx $str]]
+ }
+ return $res
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide char 1.0.1
diff --git a/tcllib/modules/pt/char.test b/tcllib/modules/pt/char.test
new file mode 100644
index 0000000..9a85357
--- /dev/null
+++ b/tcllib/modules/pt/char.test
@@ -0,0 +1,36 @@
+# -*- tcl -*-
+# char.test: tests for the char package.
+#
+# Copyright (c) 2014 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: char.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+support {
+}
+testing {
+ useLocal char.tcl char
+}
+
+# -------------------------------------------------------------------------
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/char.tests]
+
+#----------------------------------------------------------------------
+
+unset mytestdir
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/configuration.tcl b/tcllib/modules/pt/configuration.tcl
new file mode 100644
index 0000000..0bf5cc9
--- /dev/null
+++ b/tcllib/modules/pt/configuration.tcl
@@ -0,0 +1,81 @@
+# configuration.tcl --
+#
+# Generic configuration management, for use by import and export
+# managers.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: configuration.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# Each object manages a set of configuration variables.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require snit
+
+# ### ### ### ######### ######### #########
+## API
+
+snit::type ::configuration {
+
+ # ### ### ### ######### ######### #########
+ ## Options :: None
+
+ # ### ### ### ######### ######### #########
+ ## Creating, destruction
+
+ # Default constructor.
+ # Default destructor.
+
+ # ### ### ### ######### ######### #########
+ ## Public methods. Reading and writing the configuration.
+
+ method names {} {
+ return [array names myconfiguration]
+ }
+
+ method get {} {
+ return [array get myconfiguration]
+ }
+
+ method set {name {value {}}} {
+ # 7 instead of 3 in the condition below, because of the 4
+ # implicit arguments snit is providing to each method.
+ if {[llength [info level 0]] == 7} {
+ set myconfiguration($name) $value
+ } elseif {![info exists myconfiguration($name)]} {
+ return -code error "can't read \"$name\": no such variable"
+ }
+ return $myconfiguration($name)
+ }
+
+ method unset {args} {
+ if {![llength $args]} { lappend args * }
+ foreach pattern $args {
+ array unset myconfiguration $pattern
+ }
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal methods :: None.
+
+ # ### ### ### ######### ######### #########
+ ## State :: Configuration data, Tcl array
+
+ variable myconfiguration -array {}
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide configuration 1
+return
diff --git a/tcllib/modules/pt/include/arch_core.dia b/tcllib/modules/pt/include/arch_core.dia
new file mode 100644
index 0000000..ac1e034
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core.dia
@@ -0,0 +1,4 @@
+# -*- tcl -*- tcl.tk//DSL diagram//EN//1.0
+set mark 2
+source [file join [file dirname [file normalize [info script]]] architecture.dia]
+return
diff --git a/tcllib/modules/pt/include/arch_core.png b/tcllib/modules/pt/include/arch_core.png
new file mode 100644
index 0000000..c65da4a
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core.png
Binary files differ
diff --git a/tcllib/modules/pt/include/arch_core_container.dia b/tcllib/modules/pt/include/arch_core_container.dia
new file mode 100644
index 0000000..f693ca9
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core_container.dia
@@ -0,0 +1,4 @@
+# -*- tcl -*- tcl.tk//DSL diagram//EN//1.0
+set mark 6
+source [file join [file dirname [file normalize [info script]]] architecture.dia]
+return
diff --git a/tcllib/modules/pt/include/arch_core_container.png b/tcllib/modules/pt/include/arch_core_container.png
new file mode 100644
index 0000000..f577233
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core_container.png
Binary files differ
diff --git a/tcllib/modules/pt/include/arch_core_eplugins.dia b/tcllib/modules/pt/include/arch_core_eplugins.dia
new file mode 100644
index 0000000..eac0c95
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core_eplugins.dia
@@ -0,0 +1,4 @@
+# -*- tcl -*- tcl.tk//DSL diagram//EN//1.0
+set mark 8
+source [file join [file dirname [file normalize [info script]]] architecture.dia]
+return
diff --git a/tcllib/modules/pt/include/arch_core_eplugins.png b/tcllib/modules/pt/include/arch_core_eplugins.png
new file mode 100644
index 0000000..9089fb2
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core_eplugins.png
Binary files differ
diff --git a/tcllib/modules/pt/include/arch_core_export.dia b/tcllib/modules/pt/include/arch_core_export.dia
new file mode 100644
index 0000000..78228c2
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core_export.dia
@@ -0,0 +1,4 @@
+# -*- tcl -*- tcl.tk//DSL diagram//EN//1.0
+set mark 7
+source [file join [file dirname [file normalize [info script]]] architecture.dia]
+return
diff --git a/tcllib/modules/pt/include/arch_core_export.png b/tcllib/modules/pt/include/arch_core_export.png
new file mode 100644
index 0000000..293cb82
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core_export.png
Binary files differ
diff --git a/tcllib/modules/pt/include/arch_core_import.dia b/tcllib/modules/pt/include/arch_core_import.dia
new file mode 100644
index 0000000..76e6c49
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core_import.dia
@@ -0,0 +1,4 @@
+# -*- tcl -*- tcl.tk//DSL diagram//EN//1.0
+set mark 5
+source [file join [file dirname [file normalize [info script]]] architecture.dia]
+return
diff --git a/tcllib/modules/pt/include/arch_core_import.png b/tcllib/modules/pt/include/arch_core_import.png
new file mode 100644
index 0000000..5749efb
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core_import.png
Binary files differ
diff --git a/tcllib/modules/pt/include/arch_core_iplugins.dia b/tcllib/modules/pt/include/arch_core_iplugins.dia
new file mode 100644
index 0000000..4b5de6c
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core_iplugins.dia
@@ -0,0 +1,4 @@
+# -*- tcl -*- tcl.tk//DSL diagram//EN//1.0
+set mark 4
+source [file join [file dirname [file normalize [info script]]] architecture.dia]
+return
diff --git a/tcllib/modules/pt/include/arch_core_iplugins.png b/tcllib/modules/pt/include/arch_core_iplugins.png
new file mode 100644
index 0000000..079cce7
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core_iplugins.png
Binary files differ
diff --git a/tcllib/modules/pt/include/arch_core_support.dia b/tcllib/modules/pt/include/arch_core_support.dia
new file mode 100644
index 0000000..e24e068
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core_support.dia
@@ -0,0 +1,4 @@
+# -*- tcl -*- tcl.tk//DSL diagram//EN//1.0
+set mark 10
+source [file join [file dirname [file normalize [info script]]] architecture.dia]
+return
diff --git a/tcllib/modules/pt/include/arch_core_support.png b/tcllib/modules/pt/include/arch_core_support.png
new file mode 100644
index 0000000..b33ec99
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core_support.png
Binary files differ
diff --git a/tcllib/modules/pt/include/arch_core_transform.dia b/tcllib/modules/pt/include/arch_core_transform.dia
new file mode 100644
index 0000000..6775bdd
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core_transform.dia
@@ -0,0 +1,4 @@
+# -*- tcl -*- tcl.tk//DSL diagram//EN//1.0
+set mark 9
+source [file join [file dirname [file normalize [info script]]] architecture.dia]
+return
diff --git a/tcllib/modules/pt/include/arch_core_transform.png b/tcllib/modules/pt/include/arch_core_transform.png
new file mode 100644
index 0000000..bc6358d
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_core_transform.png
Binary files differ
diff --git a/tcllib/modules/pt/include/arch_support.dia b/tcllib/modules/pt/include/arch_support.dia
new file mode 100644
index 0000000..1cb320e
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_support.dia
@@ -0,0 +1,4 @@
+# -*- tcl -*- tcl.tk//DSL diagram//EN//1.0
+set mark 3
+source [file join [file dirname [file normalize [info script]]] architecture.dia]
+return
diff --git a/tcllib/modules/pt/include/arch_support.png b/tcllib/modules/pt/include/arch_support.png
new file mode 100644
index 0000000..072ce3a
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_support.png
Binary files differ
diff --git a/tcllib/modules/pt/include/arch_user_app.dia b/tcllib/modules/pt/include/arch_user_app.dia
new file mode 100644
index 0000000..22ea225
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_user_app.dia
@@ -0,0 +1,4 @@
+# -*- tcl -*- tcl.tk//DSL diagram//EN//1.0
+set mark 0
+source [file join [file dirname [file normalize [info script]]] architecture.dia]
+return
diff --git a/tcllib/modules/pt/include/arch_user_app.png b/tcllib/modules/pt/include/arch_user_app.png
new file mode 100644
index 0000000..66c3af9
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_user_app.png
Binary files differ
diff --git a/tcllib/modules/pt/include/arch_user_pkg.dia b/tcllib/modules/pt/include/arch_user_pkg.dia
new file mode 100644
index 0000000..a9090b0
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_user_pkg.dia
@@ -0,0 +1,4 @@
+# -*- tcl -*- tcl.tk//DSL diagram//EN//1.0
+set mark 1
+source [file join [file dirname [file normalize [info script]]] architecture.dia]
+return
diff --git a/tcllib/modules/pt/include/arch_user_pkg.png b/tcllib/modules/pt/include/arch_user_pkg.png
new file mode 100644
index 0000000..bb89aac
--- /dev/null
+++ b/tcllib/modules/pt/include/arch_user_pkg.png
Binary files differ
diff --git a/tcllib/modules/pt/include/architecture.dia b/tcllib/modules/pt/include/architecture.dia
new file mode 100644
index 0000000..399f14b
--- /dev/null
+++ b/tcllib/modules/pt/include/architecture.dia
@@ -0,0 +1,53 @@
+# -*- tcl -*- tcl.tk//DSL diagram//EN//1.0
+# Parser Tools Architecture Diagram
+
+set counter 0
+if {![info exists mark]} { set mark -1 }
+
+proc xbox {args} {
+ variable mark
+ variable counter
+
+ if {$mark == $counter} {
+ lappend args color red stroke 2
+ }
+ incr counter
+ return [uplevel 1 [list box {*}$args]]
+}
+
+proc area {label args} {
+ set E [xbox fillcolor lightyellow {*}$args]
+ group {
+ text text $label with nw at [last box nw]
+ }
+ return $E
+}
+
+down
+set boxwidth [90 mm]
+set movelength [5 mm]
+
+set A [area Applications]
+move
+set U [area "User Packages"]
+move
+set C [area "Core Packages" height [90 mm]]
+move
+set S [area "Support Packages"]
+
+text at $A "pt"
+text at $U "pt::pgen"
+text at $S "<general>"
+block {
+ set fillcolor white
+ set boxwidth [20 mm]
+
+ xbox "json" "peg" height [25 mm] dotted ; up ; arrow stroke 4
+ xbox "Import:" ; right ; arrow same <->
+ xbox "Container" width [25 mm] ; arrow same
+ xbox "Export:" ; down ; arrow <- stroke 4
+ xbox "json" "peg" "cparam" "tclparam" height [25 mm] dotted ; left ; move
+ xbox "Execute" "Transform" height [25 mm] width [25 mm] ; up
+ arrow <-> stroke 4 ; down ; move from [last box s]
+ xbox "AST / PE / PEG Support" width [75 mm]
+} at $C
diff --git a/tcllib/modules/pt/include/architecture.png b/tcllib/modules/pt/include/architecture.png
new file mode 100644
index 0000000..36b957b
--- /dev/null
+++ b/tcllib/modules/pt/include/architecture.png
Binary files differ
diff --git a/tcllib/modules/pt/include/channel_notes.inc b/tcllib/modules/pt/include/channel_notes.inc
new file mode 100644
index 0000000..1ad32f3
--- /dev/null
+++ b/tcllib/modules/pt/include/channel_notes.inc
@@ -0,0 +1,14 @@
+[para]
+
+Note here that the Parser Tools are based on Tcl 8.5+. In other words,
+the channel argument is not restricted to files, sockets, etc. We have
+the full power of [term {reflected channels}] available.
+
+[para]
+
+It should also be noted that the parser pulls the characters from the
+input stream as it needs them. If a parser created by this package has
+to be operated in a push aka event-driven manner it will be necessary
+to go to Tcl 8.6+ and use the [package coroutine::auto] to wrap it
+into a coroutine where [cmd read] is properly changed for
+push-operation.
diff --git a/tcllib/modules/pt/include/concept.inc b/tcllib/modules/pt/include/concept.inc
new file mode 100644
index 0000000..fa96d79
--- /dev/null
+++ b/tcllib/modules/pt/include/concept.inc
@@ -0,0 +1,22 @@
+[comment {
+ Description of the concepts used in parsing expression
+ grammars and how their relate to each other. This is useful
+ to understand the chosen serialization.
+}]
+[list_begin enumerated]
+[enum]
+
+A [term {parsing expression grammar}] consists of a
+[term {start parsing expression}] and a (possibly empty) list of
+[term rules].
+
+[enum]
+Each rule defines a nonterminal symbol of the grammar, with its name,
+semantic mode, and sentennial structure. The latter is provided by a
+[term {parsing expression}].
+
+[enum]
+Each nonterminal symbol is specified at most once, with its name as
+the identifying part.
+
+[list_end]
diff --git a/tcllib/modules/pt/include/example/expr_ast.dia b/tcllib/modules/pt/include/example/expr_ast.dia
new file mode 100644
index 0000000..21038e5
--- /dev/null
+++ b/tcllib/modules/pt/include/example/expr_ast.dia
@@ -0,0 +1,44 @@
+# -*- tcl -*- tcl.tk//DSL diagram//EN//1.0
+set boxwidth [3 cm]
+proc achild {args} { arrow <- {*}$args}
+proc char {pos x} {
+ variable movelength
+ move down [expr {0.5*$movelength}]
+ box "\"$x\"" textcolor blue
+ group {
+ text text $pos with nw at [last box nw] textcolor red
+ }
+}
+down
+box "Expression 0 4"
+achild
+box "Factor 0 4"
+group {
+ achild down left left left left ; down
+ box "Term 0 2"
+ achild
+ box "Number 0 2"
+ group {
+ achild down left left ; down
+ box "Digit 0 0" ; char 0 1
+ } ; group {
+ achild down
+ box "Digit 1 1" ; char 1 2
+ } ; group {
+ achild down right right ; down
+ box "Digit 2 2" ; char 2 0
+ }
+} ; group {
+ achild down down down down down
+ box "AddOp 3 3" ; char 3 +
+} ; group {
+ achild down right right ; down
+ box "Term 4 4"
+ achild
+ box "Number 4 4"
+ achild down
+ box "Digit 4 4" ; char 4 5
+}
+line stroke 2 dotted \
+ from [0.25 between [6th box nw] [5th box sw ]] \
+ to [0.25 between [last box ne] [2nd last box se]]
diff --git a/tcllib/modules/pt/include/example/expr_ast.inc b/tcllib/modules/pt/include/example/expr_ast.inc
new file mode 100644
index 0000000..1d12780
--- /dev/null
+++ b/tcllib/modules/pt/include/example/expr_ast.inc
@@ -0,0 +1,19 @@
+[example {
+set ast {Expression 0 4
+ {Factor 0 4
+ {Term 0 2
+ {Number 0 2
+ {Digit 0 0}
+ {Digit 1 1}
+ {Digit 2 2}
+ }
+ }
+ {AddOp 3 3}
+ {Term 4 4
+ {Number 4 4
+ {Digit 4 4}
+ }
+ }
+ }
+}
+}]
diff --git a/tcllib/modules/pt/include/example/expr_ast.pic b/tcllib/modules/pt/include/example/expr_ast.pic
new file mode 100644
index 0000000..6d09f2c
--- /dev/null
+++ b/tcllib/modules/pt/include/example/expr_ast.pic
@@ -0,0 +1,11 @@
+.nf
+ +- Digit 0 0 | 1
+ | |
+ +- Term 0 2 --- Number 0 2 -+- Digit 1 1 | 2
+ | | |
+ | +- Digit 2 2 | 0
+ | |
+Expression 0 4 --- Factor 0 4 -+----------------------------- AddOp 3 3 | +
+ | |
+ +- Term 4 4 --- Number 4 4 --- Digit 4 4 | 5
+.fi
diff --git a/tcllib/modules/pt/include/example/expr_ast.png b/tcllib/modules/pt/include/example/expr_ast.png
new file mode 100644
index 0000000..e33e8f1
--- /dev/null
+++ b/tcllib/modules/pt/include/example/expr_ast.png
Binary files differ
diff --git a/tcllib/modules/pt/include/example/expr_ast.txt b/tcllib/modules/pt/include/example/expr_ast.txt
new file mode 100644
index 0000000..f662f8c
--- /dev/null
+++ b/tcllib/modules/pt/include/example/expr_ast.txt
@@ -0,0 +1,9 @@
+ +- Digit 0 0 | 1
+ | |
+ +- Term 0 2 --- Number 0 2 -+- Digit 1 1 | 2
+ | | |
+ | +- Digit 2 2 | 0
+ | |
+Expression 0 4 --- Factor 0 4 -+----------------------------- AddOp 3 3 | +
+ | |
+ +- Term 4 4 --- Number 4 4 --- Digit 4 4 | 5
diff --git a/tcllib/modules/pt/include/example/expr_container.inc b/tcllib/modules/pt/include/example/expr_container.inc
new file mode 100644
index 0000000..b568459
--- /dev/null
+++ b/tcllib/modules/pt/include/example/expr_container.inc
@@ -0,0 +1,33 @@
+[example {
+snit::type a_pe_grammar {
+ constructor {} {
+ install myg using pt::peg::container ${selfns}::G
+ $myg start {n Expression}
+ $myg add AddOp Digit Expression Factor MulOp Number Sign Term
+ $myg modes {
+ AddOp value
+ Digit value
+ Expression value
+ Factor value
+ MulOp value
+ Number value
+ Sign value
+ Term value
+ }
+ $myg rules {
+ AddOp {/ {t -} {t +}}
+ Digit {/ {t 0} {t 1} {t 2} {t 3} {t 4} {t 5} {t 6} {t 7} {t 8} {t 9}}
+ Expression {/ {x {t \50} {n Expression} {t \51}} {x {n Factor} {* {x {n MulOp} {n Factor}}}}}
+ Factor {x {n Term} {* {x {n AddOp} {n Term}}}}
+ MulOp {/ {t *} {t /}}
+ Number {x {? {n Sign}} {+ {n Digit}}}
+ Sign {/ {t -} {t +}}
+ Term {n Number}
+ }
+ return
+ }
+
+ component myg
+ delegate method * to myg
+}
+}]
diff --git a/tcllib/modules/pt/include/example/expr_json.inc b/tcllib/modules/pt/include/example/expr_json.inc
new file mode 100644
index 0000000..45b30f8
--- /dev/null
+++ b/tcllib/modules/pt/include/example/expr_json.inc
@@ -0,0 +1,41 @@
+[example {
+{
+ "pt::grammar::peg" : {
+ "rules" : {
+ "AddOp" : {
+ "is" : "\/ {t -} {t +}",
+ "mode" : "value"
+ },
+ "Digit" : {
+ "is" : "\/ {t 0} {t 1} {t 2} {t 3} {t 4} {t 5} {t 6} {t 7} {t 8} {t 9}",
+ "mode" : "value"
+ },
+ "Expression" : {
+ "is" : "\/ {x {t (} {n Expression} {t )}} {x {n Factor} {* {x {n MulOp} {n Factor}}}}",
+ "mode" : "value"
+ },
+ "Factor" : {
+ "is" : "x {n Term} {* {x {n AddOp} {n Term}}}",
+ "mode" : "value"
+ },
+ "MulOp" : {
+ "is" : "\/ {t *} {t \/}",
+ "mode" : "value"
+ },
+ "Number" : {
+ "is" : "x {? {n Sign}} {+ {n Digit}}",
+ "mode" : "value"
+ },
+ "Sign" : {
+ "is" : "\/ {t -} {t +}",
+ "mode" : "value"
+ },
+ "Term" : {
+ "is" : "n Number",
+ "mode" : "value"
+ }
+ },
+ "start" : "n Expression"
+ }
+}
+}]
diff --git a/tcllib/modules/pt/include/example/expr_param.inc b/tcllib/modules/pt/include/example/expr_param.inc
new file mode 100644
index 0000000..ecfbb3a
--- /dev/null
+++ b/tcllib/modules/pt/include/example/expr_param.inc
@@ -0,0 +1,758 @@
+[example {
+# -*- text -*-
+# Parsing Expression Grammar 'TEMPLATE'.
+# Generated for unknown, from file 'TEST'
+
+#
+# Grammar Start Expression
+#
+
+<<MAIN>>:
+ call sym_Expression
+ halt
+
+#
+# value Symbol 'AddOp'
+#
+
+sym_AddOp:
+# /
+# '-'
+# '+'
+
+ symbol_restore AddOp
+ found! jump found_7
+ loc_push
+
+ call choice_5
+
+ fail! value_clear
+ ok! value_leaf AddOp
+ symbol_save AddOp
+ error_nonterminal AddOp
+ loc_pop_discard
+
+found_7:
+ ok! ast_value_push
+ return
+
+choice_5:
+# /
+# '-'
+# '+'
+
+ error_clear
+
+ loc_push
+ error_push
+
+ input_next "t -"
+ ok! test_char "-"
+
+ error_pop_merge
+ ok! jump oknoast_4
+
+ loc_pop_rewind
+ loc_push
+ error_push
+
+ input_next "t +"
+ ok! test_char "+"
+
+ error_pop_merge
+ ok! jump oknoast_4
+
+ loc_pop_rewind
+ status_fail
+ return
+
+oknoast_4:
+ loc_pop_discard
+ return
+#
+# value Symbol 'Digit'
+#
+
+sym_Digit:
+# /
+# '0'
+# '1'
+# '2'
+# '3'
+# '4'
+# '5'
+# '6'
+# '7'
+# '8'
+# '9'
+
+ symbol_restore Digit
+ found! jump found_22
+ loc_push
+
+ call choice_20
+
+ fail! value_clear
+ ok! value_leaf Digit
+ symbol_save Digit
+ error_nonterminal Digit
+ loc_pop_discard
+
+found_22:
+ ok! ast_value_push
+ return
+
+choice_20:
+# /
+# '0'
+# '1'
+# '2'
+# '3'
+# '4'
+# '5'
+# '6'
+# '7'
+# '8'
+# '9'
+
+ error_clear
+
+ loc_push
+ error_push
+
+ input_next "t 0"
+ ok! test_char "0"
+
+ error_pop_merge
+ ok! jump oknoast_19
+
+ loc_pop_rewind
+ loc_push
+ error_push
+
+ input_next "t 1"
+ ok! test_char "1"
+
+ error_pop_merge
+ ok! jump oknoast_19
+
+ loc_pop_rewind
+ loc_push
+ error_push
+
+ input_next "t 2"
+ ok! test_char "2"
+
+ error_pop_merge
+ ok! jump oknoast_19
+
+ loc_pop_rewind
+ loc_push
+ error_push
+
+ input_next "t 3"
+ ok! test_char "3"
+
+ error_pop_merge
+ ok! jump oknoast_19
+
+ loc_pop_rewind
+ loc_push
+ error_push
+
+ input_next "t 4"
+ ok! test_char "4"
+
+ error_pop_merge
+ ok! jump oknoast_19
+
+ loc_pop_rewind
+ loc_push
+ error_push
+
+ input_next "t 5"
+ ok! test_char "5"
+
+ error_pop_merge
+ ok! jump oknoast_19
+
+ loc_pop_rewind
+ loc_push
+ error_push
+
+ input_next "t 6"
+ ok! test_char "6"
+
+ error_pop_merge
+ ok! jump oknoast_19
+
+ loc_pop_rewind
+ loc_push
+ error_push
+
+ input_next "t 7"
+ ok! test_char "7"
+
+ error_pop_merge
+ ok! jump oknoast_19
+
+ loc_pop_rewind
+ loc_push
+ error_push
+
+ input_next "t 8"
+ ok! test_char "8"
+
+ error_pop_merge
+ ok! jump oknoast_19
+
+ loc_pop_rewind
+ loc_push
+ error_push
+
+ input_next "t 9"
+ ok! test_char "9"
+
+ error_pop_merge
+ ok! jump oknoast_19
+
+ loc_pop_rewind
+ status_fail
+ return
+
+oknoast_19:
+ loc_pop_discard
+ return
+#
+# value Symbol 'Expression'
+#
+
+sym_Expression:
+# /
+# x
+# '\('
+# (Expression)
+# '\)'
+# x
+# (Factor)
+# *
+# x
+# (MulOp)
+# (Factor)
+
+ symbol_restore Expression
+ found! jump found_46
+ loc_push
+ ast_push
+
+ call choice_44
+
+ fail! value_clear
+ ok! value_reduce Expression
+ symbol_save Expression
+ error_nonterminal Expression
+ ast_pop_rewind
+ loc_pop_discard
+
+found_46:
+ ok! ast_value_push
+ return
+
+choice_44:
+# /
+# x
+# '\('
+# (Expression)
+# '\)'
+# x
+# (Factor)
+# *
+# x
+# (MulOp)
+# (Factor)
+
+ error_clear
+
+ ast_push
+ loc_push
+ error_push
+
+ call sequence_27
+
+ error_pop_merge
+ ok! jump ok_43
+
+ ast_pop_rewind
+ loc_pop_rewind
+ ast_push
+ loc_push
+ error_push
+
+ call sequence_40
+
+ error_pop_merge
+ ok! jump ok_43
+
+ ast_pop_rewind
+ loc_pop_rewind
+ status_fail
+ return
+
+ok_43:
+ ast_pop_discard
+ loc_pop_discard
+ return
+
+sequence_27:
+# x
+# '\('
+# (Expression)
+# '\)'
+
+ loc_push
+ error_clear
+
+ error_push
+
+ input_next "t ("
+ ok! test_char "("
+
+ error_pop_merge
+ fail! jump failednoast_29
+ ast_push
+ error_push
+
+ call sym_Expression
+
+ error_pop_merge
+ fail! jump failed_28
+ error_push
+
+ input_next "t )"
+ ok! test_char ")"
+
+ error_pop_merge
+ fail! jump failed_28
+
+ ast_pop_discard
+ loc_pop_discard
+ return
+
+failed_28:
+ ast_pop_rewind
+
+failednoast_29:
+ loc_pop_rewind
+ return
+
+sequence_40:
+# x
+# (Factor)
+# *
+# x
+# (MulOp)
+# (Factor)
+
+ ast_push
+ loc_push
+ error_clear
+
+ error_push
+
+ call sym_Factor
+
+ error_pop_merge
+ fail! jump failed_41
+ error_push
+
+ call kleene_37
+
+ error_pop_merge
+ fail! jump failed_41
+
+ ast_pop_discard
+ loc_pop_discard
+ return
+
+failed_41:
+ ast_pop_rewind
+ loc_pop_rewind
+ return
+
+kleene_37:
+# *
+# x
+# (MulOp)
+# (Factor)
+
+ loc_push
+ error_push
+
+ call sequence_34
+
+ error_pop_merge
+ fail! jump failed_38
+ loc_pop_discard
+ jump kleene_37
+
+failed_38:
+ loc_pop_rewind
+ status_ok
+ return
+
+sequence_34:
+# x
+# (MulOp)
+# (Factor)
+
+ ast_push
+ loc_push
+ error_clear
+
+ error_push
+
+ call sym_MulOp
+
+ error_pop_merge
+ fail! jump failed_35
+ error_push
+
+ call sym_Factor
+
+ error_pop_merge
+ fail! jump failed_35
+
+ ast_pop_discard
+ loc_pop_discard
+ return
+
+failed_35:
+ ast_pop_rewind
+ loc_pop_rewind
+ return
+#
+# value Symbol 'Factor'
+#
+
+sym_Factor:
+# x
+# (Term)
+# *
+# x
+# (AddOp)
+# (Term)
+
+ symbol_restore Factor
+ found! jump found_60
+ loc_push
+ ast_push
+
+ call sequence_57
+
+ fail! value_clear
+ ok! value_reduce Factor
+ symbol_save Factor
+ error_nonterminal Factor
+ ast_pop_rewind
+ loc_pop_discard
+
+found_60:
+ ok! ast_value_push
+ return
+
+sequence_57:
+# x
+# (Term)
+# *
+# x
+# (AddOp)
+# (Term)
+
+ ast_push
+ loc_push
+ error_clear
+
+ error_push
+
+ call sym_Term
+
+ error_pop_merge
+ fail! jump failed_58
+ error_push
+
+ call kleene_54
+
+ error_pop_merge
+ fail! jump failed_58
+
+ ast_pop_discard
+ loc_pop_discard
+ return
+
+failed_58:
+ ast_pop_rewind
+ loc_pop_rewind
+ return
+
+kleene_54:
+# *
+# x
+# (AddOp)
+# (Term)
+
+ loc_push
+ error_push
+
+ call sequence_51
+
+ error_pop_merge
+ fail! jump failed_55
+ loc_pop_discard
+ jump kleene_54
+
+failed_55:
+ loc_pop_rewind
+ status_ok
+ return
+
+sequence_51:
+# x
+# (AddOp)
+# (Term)
+
+ ast_push
+ loc_push
+ error_clear
+
+ error_push
+
+ call sym_AddOp
+
+ error_pop_merge
+ fail! jump failed_52
+ error_push
+
+ call sym_Term
+
+ error_pop_merge
+ fail! jump failed_52
+
+ ast_pop_discard
+ loc_pop_discard
+ return
+
+failed_52:
+ ast_pop_rewind
+ loc_pop_rewind
+ return
+#
+# value Symbol 'MulOp'
+#
+
+sym_MulOp:
+# /
+# '*'
+# '/'
+
+ symbol_restore MulOp
+ found! jump found_67
+ loc_push
+
+ call choice_65
+
+ fail! value_clear
+ ok! value_leaf MulOp
+ symbol_save MulOp
+ error_nonterminal MulOp
+ loc_pop_discard
+
+found_67:
+ ok! ast_value_push
+ return
+
+choice_65:
+# /
+# '*'
+# '/'
+
+ error_clear
+
+ loc_push
+ error_push
+
+ input_next "t *"
+ ok! test_char "*"
+
+ error_pop_merge
+ ok! jump oknoast_64
+
+ loc_pop_rewind
+ loc_push
+ error_push
+
+ input_next "t /"
+ ok! test_char "/"
+
+ error_pop_merge
+ ok! jump oknoast_64
+
+ loc_pop_rewind
+ status_fail
+ return
+
+oknoast_64:
+ loc_pop_discard
+ return
+#
+# value Symbol 'Number'
+#
+
+sym_Number:
+# x
+# ?
+# (Sign)
+# +
+# (Digit)
+
+ symbol_restore Number
+ found! jump found_80
+ loc_push
+ ast_push
+
+ call sequence_77
+
+ fail! value_clear
+ ok! value_reduce Number
+ symbol_save Number
+ error_nonterminal Number
+ ast_pop_rewind
+ loc_pop_discard
+
+found_80:
+ ok! ast_value_push
+ return
+
+sequence_77:
+# x
+# ?
+# (Sign)
+# +
+# (Digit)
+
+ ast_push
+ loc_push
+ error_clear
+
+ error_push
+
+ call optional_70
+
+ error_pop_merge
+ fail! jump failed_78
+ error_push
+
+ call poskleene_73
+
+ error_pop_merge
+ fail! jump failed_78
+
+ ast_pop_discard
+ loc_pop_discard
+ return
+
+failed_78:
+ ast_pop_rewind
+ loc_pop_rewind
+ return
+
+optional_70:
+# ?
+# (Sign)
+
+ loc_push
+ error_push
+
+ call sym_Sign
+
+ error_pop_merge
+ fail! loc_pop_rewind
+ ok! loc_pop_discard
+ status_ok
+ return
+
+poskleene_73:
+# +
+# (Digit)
+
+ loc_push
+
+ call sym_Digit
+
+ fail! jump failed_74
+
+loop_75:
+ loc_pop_discard
+ loc_push
+ error_push
+
+ call sym_Digit
+
+ error_pop_merge
+ ok! jump loop_75
+ status_ok
+
+failed_74:
+ loc_pop_rewind
+ return
+#
+# value Symbol 'Sign'
+#
+
+sym_Sign:
+# /
+# '-'
+# '+'
+
+ symbol_restore Sign
+ found! jump found_86
+ loc_push
+
+ call choice_5
+
+ fail! value_clear
+ ok! value_leaf Sign
+ symbol_save Sign
+ error_nonterminal Sign
+ loc_pop_discard
+
+found_86:
+ ok! ast_value_push
+ return
+#
+# value Symbol 'Term'
+#
+
+sym_Term:
+# (Number)
+
+ symbol_restore Term
+ found! jump found_89
+ loc_push
+ ast_push
+
+ call sym_Number
+
+ fail! value_clear
+ ok! value_reduce Term
+ symbol_save Term
+ error_nonterminal Term
+ ast_pop_rewind
+ loc_pop_discard
+
+found_89:
+ ok! ast_value_push
+ return
+
+#
+#
+}]
diff --git a/tcllib/modules/pt/include/example/expr_pe.inc b/tcllib/modules/pt/include/example/expr_pe.inc
new file mode 100644
index 0000000..236819f
--- /dev/null
+++ b/tcllib/modules/pt/include/example/expr_pe.inc
@@ -0,0 +1,3 @@
+[example {
+ Expression <- Term (AddOp Term)*
+}]
diff --git a/tcllib/modules/pt/include/example/expr_pe_serial.inc b/tcllib/modules/pt/include/example/expr_pe_serial.inc
new file mode 100644
index 0000000..6c98abd
--- /dev/null
+++ b/tcllib/modules/pt/include/example/expr_pe_serial.inc
@@ -0,0 +1,3 @@
+[example {
+ {x {n Term} {* {x {n AddOp} {n Term}}}}
+}]
diff --git a/tcllib/modules/pt/include/example/expr_peg.inc b/tcllib/modules/pt/include/example/expr_peg.inc
new file mode 100644
index 0000000..0437c32
--- /dev/null
+++ b/tcllib/modules/pt/include/example/expr_peg.inc
@@ -0,0 +1,12 @@
+[example {
+PEG calculator (Expression)
+ Digit <- '0'/'1'/'2'/'3'/'4'/'5'/'6'/'7'/'8'/'9' ;
+ Sign <- '-' / '+' ;
+ Number <- Sign? Digit+ ;
+ Expression <- Term (AddOp Term)* ;
+ MulOp <- '*' / '/' ;
+ Term <- Factor (MulOp Factor)* ;
+ AddOp <- '+'/'-' ;
+ Factor <- '(' Expression ')' / Number ;
+END;
+}]
diff --git a/tcllib/modules/pt/include/example/expr_peg_compact.inc b/tcllib/modules/pt/include/example/expr_peg_compact.inc
new file mode 100644
index 0000000..5c93557
--- /dev/null
+++ b/tcllib/modules/pt/include/example/expr_peg_compact.inc
@@ -0,0 +1,11 @@
+[example {
+PEG calculator (Expression)
+ Sign <- [-+] ;
+ Number <- Sign? <ddigit>+ ;
+ Expression <- '(' Expression ')' / (Factor (MulOp Factor)*) ;
+ MulOp <- [*/] ;
+ Factor <- Term (AddOp Term)* ;
+ AddOp <- [-+] ;
+ Term <- Number ;
+END;
+}]
diff --git a/tcllib/modules/pt/include/example/expr_ptgen.inc b/tcllib/modules/pt/include/example/expr_ptgen.inc
new file mode 100644
index 0000000..2b7a910
--- /dev/null
+++ b/tcllib/modules/pt/include/example/expr_ptgen.inc
@@ -0,0 +1,49 @@
+[example {
+> tclsh8.5
+% package require pt::pgen
+% puts ====\n[pt::pgen peg {
+ PEG calculator (Expression)
+ Digit <- '0'/'1'/'2'/'3'/'4'/'5'/'6'/'7'/'8'/'9' ;
+ Sign <- '-' / '+' ;
+ Number <- Sign? Digit+ ;
+ Expression <- '(' Expression ')' / (Factor (MulOp Factor)*) ;
+ MulOp <- '*' / '/' ;
+ Factor <- Term (AddOp Term)* ;
+ AddOp <- '+'/'-' ;
+ Term <- Number ;
+ END;
+ } container -name basic_arithmetic]
+====
+snit::type basic_arithmetic {
+ constructor {} {
+ install myg using pt::peg::container ${selfns}::G
+ $myg start {n Expression}
+ $myg add AddOp Digit Expression Factor MulOp Number Sign Term
+ $myg modes {
+ AddOp value
+ Digit value
+ Expression value
+ Factor value
+ MulOp value
+ Number value
+ Sign value
+ Term value
+ }
+ $myg rules {
+ AddOp {/ {t -} {t +}}
+ Digit {/ {t 0} {t 1} {t 2} {t 3} {t 4} {t 5} {t 6} {t 7} {t 8} {t 9}}
+ Expression {/ {x {t \50} {n Expression} {t \51}} {x {n Factor} {* {x {n MulOp} {n Factor}}}}}
+ Factor {x {n Term} {* {x {n AddOp} {n Term}}}}
+ MulOp {/ {t *} {t /}}
+ Number {x {? {n Sign}} {+ {n Digit}}}
+ Sign {/ {t -} {t +}}
+ Term {n Number}
+ }
+ return
+ }
+
+ component myg
+ delegate method * to myg
+}
+%
+}]
diff --git a/tcllib/modules/pt/include/example/expr_ptgenb.inc b/tcllib/modules/pt/include/example/expr_ptgenb.inc
new file mode 100644
index 0000000..f16d64d
--- /dev/null
+++ b/tcllib/modules/pt/include/example/expr_ptgenb.inc
@@ -0,0 +1,11 @@
+[example {
+package require Tcl 8.5
+package require fileutil
+package require pt::pgen
+
+lassign $argv name
+set grammar [fileutil::cat $name.peg]
+set pclass [pt::pgen peg $gr snit -class $name -file $name.peg -name $name]
+fileutil::writeFile $name.tcl $pclass
+exit 0
+}]
diff --git a/tcllib/modules/pt/include/example/expr_serial.inc b/tcllib/modules/pt/include/example/expr_serial.inc
new file mode 100644
index 0000000..91cac81
--- /dev/null
+++ b/tcllib/modules/pt/include/example/expr_serial.inc
@@ -0,0 +1,15 @@
+[example {
+pt::grammar::peg {
+ rules {
+ AddOp {is {/ {t -} {t +}} mode value}
+ Digit {is {/ {t 0} {t 1} {t 2} {t 3} {t 4} {t 5} {t 6} {t 7} {t 8} {t 9}} mode value}
+ Expression {is {x {n Term} {* {x {n AddOp} {n Term}}}} mode value}
+ Factor {is {/ {x {t (} {n Expression} {t )}} {n Number}} mode value}
+ MulOp {is {/ {t *} {t /}} mode value}
+ Number {is {x {? {n Sign}} {+ {n Digit}}} mode value}
+ Sign {is {/ {t -} {t +}} mode value}
+ Term {is {x {n Factor} {* {x {n MulOp} {n Factor}}}} mode value}
+ }
+ start {n Expression}
+}
+}]
diff --git a/tcllib/modules/pt/include/example/flow.dia b/tcllib/modules/pt/include/example/flow.dia
new file mode 100644
index 0000000..b05fbf0
--- /dev/null
+++ b/tcllib/modules/pt/include/example/flow.dia
@@ -0,0 +1,5 @@
+# -*- tcl -*- tcl.tk//DSL diagram//EN//1.0
+
+ellipse "Grammar" ; arrow ; box "PT generate" width [3 cm] ; arrow
+diamond "parser code" height [2 cm] ; down ; arrow ; box "tclsh" ; right
+arrow ; ellipse "AST" ; arrow <- from [last box w] left ; ellipse "Text"
diff --git a/tcllib/modules/pt/include/example/flow.png b/tcllib/modules/pt/include/example/flow.png
new file mode 100644
index 0000000..10a5448
--- /dev/null
+++ b/tcllib/modules/pt/include/example/flow.png
Binary files differ
diff --git a/tcllib/modules/pt/include/example/full.inc b/tcllib/modules/pt/include/example/full.inc
new file mode 100644
index 0000000..8c1698a
--- /dev/null
+++ b/tcllib/modules/pt/include/example/full.inc
@@ -0,0 +1,54 @@
+
+In this section we are working a complete example, starting with a PEG
+grammar and ending with running the parser generated from it over some
+input, following the outline shown in the figure below:
+
+[para][image flow][para]
+
+Our grammar, assumed to the stored in the file [file calculator.peg]
+is
+
+[include expr_peg.inc]
+
+From this we create a snit-based parser
+
+[include full_[vset MODE].inc]
+
+which leaves us with the parser package and class written to the file
+[file calculator.tcl].
+
+Assuming that this package is then properly installed in a place where
+Tcl can find it we can now use this class via a script like
+
+[include parser_use.inc]
+
+where the abstract syntax tree stored in the variable will look like
+
+[para][include expr_ast.inc][para]
+
+assuming that the input file and channel contained the text
+
+[example { 120+5 }]
+
+A more graphical representation of the tree would be
+
+[para][image expr_ast][para]
+
+Regardless, at this point it is the user's responsibility to work with
+the tree to reach whatever goal she desires. I.e. analyze it,
+transform it, etc. The package [package pt::ast] should be of help
+here, providing commands to walk such ASTs structures in various ways.
+
+[para]
+
+One important thing to note is that the parsers used here return a
+data structure representing the structure of the input per the grammar
+underlying the parser. There are [emph no] callbacks during the
+parsing process, i.e. no [term {parsing actions}], as most other
+parsers will have.
+
+[para]
+
+Going back to the last snippet of code, the execution of the parser
+for some input, note how the parser instance follows the specified
+[term {Parser API}].
diff --git a/tcllib/modules/pt/include/example/full_app.inc b/tcllib/modules/pt/include/example/full_app.inc
new file mode 100644
index 0000000..3f0fef6
--- /dev/null
+++ b/tcllib/modules/pt/include/example/full_app.inc
@@ -0,0 +1,5 @@
+via
+
+[example {
+pt generate snit calculator.tcl -class calculator -name calculator peg calculator.peg
+}]
diff --git a/tcllib/modules/pt/include/example/full_pkg.inc b/tcllib/modules/pt/include/example/full_pkg.inc
new file mode 100644
index 0000000..a0ad70b
--- /dev/null
+++ b/tcllib/modules/pt/include/example/full_pkg.inc
@@ -0,0 +1,7 @@
+using the script [file gen]
+
+[include expr_ptgenb.inc]
+
+calling it like
+
+[example { tclsh8.5 gen calculator }]
diff --git a/tcllib/modules/pt/include/example/parser_use.inc b/tcllib/modules/pt/include/example/parser_use.inc
new file mode 100644
index 0000000..266740a
--- /dev/null
+++ b/tcllib/modules/pt/include/example/parser_use.inc
@@ -0,0 +1,13 @@
+[example {
+ package require calculator
+
+ lassign $argv input
+ set channel [open $input r]
+
+ set parser [calculator]
+ set ast [$parser parse $channel]
+ $parser destroy
+ close $channel
+
+ ... now process the returned abstract syntax tree ...
+}]
diff --git a/tcllib/modules/pt/include/export/config/container.inc b/tcllib/modules/pt/include/export/config/container.inc
new file mode 100644
index 0000000..13b89b1
--- /dev/null
+++ b/tcllib/modules/pt/include/export/config/container.inc
@@ -0,0 +1,78 @@
+
+[section Configuration]
+
+The CONTAINER export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+[arg_def enum mode]
+
+The value of this configuration variable controls which methods of
+[package pt::peg] instances the plugin will use to specify the
+grammar. There are two legal values
+
+[list_begin definitions]
+[def [const bulk]]
+
+In this mode the methods [method start], [method add], [method modes],
+and [method rules] are used to specify the grammar in a bulk manner,
+i.e. as a set of nonterminal symbols, and two dictionaries mapping
+from the symbols to their semantic modes and parsing expressions.
+
+[para]
+
+This mode is the default.
+
+[def [const incremental]]
+
+In this mode the methods [method start], [method add], [method mode],
+and [method rule] are used to specify the grammar piecemal, with each
+nonterminal having its own block of defining commands.
+
+[list_end]
+
+[arg_def string template]
+
+If this configuration variable is set it is assumed to contain a
+string into which to put the generated code and other configuration
+data. The various locations are expected to be specified with the
+following placeholders:
+
+[list_begin definitions]
+
+[def [const @user@]]
+To be replaced with the value of the configuration variable [option user].
+
+[def [const @format@]]
+To be replaced with the the constant [const CONTAINER].
+
+[def [const @file@]]
+To be replaced with the value of the configuration variable [option file].
+
+[def [const @name@]]
+To be replaced with the value of the configuration variable [option name].
+
+[def [const @mode@]]
+To be replaced with the value of the configuration variable [option mode].
+
+[def [const @code@]]
+To be replaced with the generated code.
+
+[list_end]
+
+[para]
+
+If this configuration variable is not set, or empty, then the plugin
+falls back to a standard template, which is defined as "[const @code@]".
+
+[list_end]
+
+[emph Note] that this plugin may ignore the standard configuration
+variables [var user], [var format], [var file], and their values,
+depending on the chosen template.
+
+[para]
+
+The content of the standard configuration variable [var name], if set,
+is used as name of the grammar in the output. Otherwise the plugin
+falls back to the default name [const a_pe_grammar].
diff --git a/tcllib/modules/pt/include/export/config/cparam.inc b/tcllib/modules/pt/include/export/config/cparam.inc
new file mode 100644
index 0000000..afe817f
--- /dev/null
+++ b/tcllib/modules/pt/include/export/config/cparam.inc
@@ -0,0 +1,80 @@
+[section Configuration]
+
+The C/PARAM export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+
+[arg_def string template]
+
+If this configuration variable is set it is assumed to contain a
+string into which to put the generated code and other configuration
+data. The various locations are expected to be specified with the
+following placeholders:
+
+[list_begin definitions]
+
+[def [const @user@]]
+To be replaced with the value of the configuration variable [option user].
+
+[def [const @format@]]
+To be replaced with the the constant [const C/PARAM].
+
+[def [const @file@]]
+To be replaced with the value of the configuration variable [option file].
+
+[def [const @name@]]
+To be replaced with the value of the configuration variable [option name].
+
+[def [const @code@]]
+To be replaced with the generated C code.
+
+[list_end]
+
+The following configuration variables are special, in that they will
+occur within the generated code, and are replaced there as well.
+
+[list_begin definitions]
+
+[def [const @statedecl@]]
+To be replaced with the value of the configuration variable [option state-decl].
+
+[def [const @stateref@]]
+To be replaced with the value of the configuration variable [option state-ref].
+
+[def [const @strings@]]
+To be replaced with the value of the configuration variable [option string-varname].
+
+[def [const @self@]]
+To be replaced with the value of the configuration variable [option self-command].
+
+[def [const @def@]]
+To be replaced with the value of the configuration variable [option fun-qualifier].
+
+[def [const @ns@]]
+To be replaced with the value of the configuration variable [option namespace].
+
+[def [const @main@]]
+To be replaced with the value of the configuration variable [option main].
+
+[def [const @prelude@]]
+To be replaced with the value of the configuration variable [option prelude].
+
+[list_end]
+
+[para]
+
+If this configuration variable is not set, or empty, then the plugin
+falls back to a standard template, which is defined as "[const @code@]".
+
+[list_end]
+
+[emph Note] that this plugin may ignore the standard configuration
+variables [var user], [var format], [var file], and their values,
+depending on the chosen template.
+
+[para]
+
+The content of the standard configuration variable [var name], if set,
+is used as name of the grammar in the output. Otherwise the plugin
+falls back to the default name [const a_pe_grammar].
diff --git a/tcllib/modules/pt/include/export/config/json.inc b/tcllib/modules/pt/include/export/config/json.inc
new file mode 100644
index 0000000..0b0053c
--- /dev/null
+++ b/tcllib/modules/pt/include/export/config/json.inc
@@ -0,0 +1,36 @@
+[section Configuration]
+
+The JSON export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+[arg_def boolean indented]
+
+If this flag is set the plugin will break the generated JSON code
+across lines and indent it according to its inner structure, with each
+key of a dictionary on a separate line.
+
+[para]
+
+If this flag is not set (the default), the whole JSON object will be
+written on a single line, with minimum spacing between all elements.
+
+
+[arg_def boolean aligned]
+
+If this flag is set the generator ensures that the values for the keys
+in a dictionary are vertically aligned with each other, for a nice
+table effect. To make this work this also implies that [var indented]
+is set.
+
+[para]
+
+If this flag is not set (the default), the output is formatted as per
+the value of [var indented], without trying to align the values for
+dictionary keys.
+
+[list_end]
+
+[emph Note] that this plugin ignores the standard configuration
+variables [var user], [var format], [var file], and [var name], and
+their values.
diff --git a/tcllib/modules/pt/include/export/config/param.inc b/tcllib/modules/pt/include/export/config/param.inc
new file mode 100644
index 0000000..2c3d911
--- /dev/null
+++ b/tcllib/modules/pt/include/export/config/param.inc
@@ -0,0 +1,49 @@
+[section Configuration]
+
+The PARAM export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+
+[arg_def string template]
+
+If this configuration variable is set it is assumed to contain a
+string into which to put the generated text and other configuration
+data. The various locations are expected to be specified with the
+following placeholders:
+
+[list_begin definitions]
+
+[def [const @user@]]
+To be replaced with the value of the configuration variable [option user].
+
+[def [const @format@]]
+To be replaced with the the constant [const PARAM].
+
+[def [const @file@]]
+To be replaced with the value of the configuration variable [option file].
+
+[def [const @name@]]
+To be replaced with the value of the configuration variable [option name].
+
+[def [const @code@]]
+To be replaced with the generated text.
+
+[list_end]
+
+[para]
+
+If this configuration variable is not set, or empty, then the plugin
+falls back to a standard template, which is defined as "[const @code@]".
+
+[list_end]
+
+[emph Note] that this plugin may ignore the standard configuration
+variables [var user], [var format], [var file], and their values,
+depending on the chosen template.
+
+[para]
+
+The content of the standard configuration variable [var name], if set,
+is used as name of the grammar in the output. Otherwise the plugin
+falls back to the default name [const a_pe_grammar].
diff --git a/tcllib/modules/pt/include/export/config/peg.inc b/tcllib/modules/pt/include/export/config/peg.inc
new file mode 100644
index 0000000..9f50e5f
--- /dev/null
+++ b/tcllib/modules/pt/include/export/config/peg.inc
@@ -0,0 +1,49 @@
+[section Configuration]
+
+The PEG export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+
+[arg_def string template]
+
+If this configuration variable is set it is assumed to contain a
+string into which to put the generated text and other configuration
+data. The various locations are expected to be specified with the
+following placeholders:
+
+[list_begin definitions]
+
+[def [const @user@]]
+To be replaced with the value of the configuration variable [option user].
+
+[def [const @format@]]
+To be replaced with the the constant [const PEG].
+
+[def [const @file@]]
+To be replaced with the value of the configuration variable [option file].
+
+[def [const @name@]]
+To be replaced with the value of the configuration variable [option name].
+
+[def [const @code@]]
+To be replaced with the generated text.
+
+[list_end]
+
+[para]
+
+If this configuration variable is not set, or empty, then the plugin
+falls back to a standard template, which is defined as "[const @code@]".
+
+[list_end]
+
+[emph Note] that this plugin may ignore the standard configuration
+variables [var user], [var format], [var file], and their values,
+depending on the chosen template.
+
+[para]
+
+The content of the standard configuration variable [var name], if set,
+is used as name of the grammar in the output. Otherwise the plugin
+falls back to the default name [const a_pe_grammar].
diff --git a/tcllib/modules/pt/include/export/config/tclparam.inc b/tcllib/modules/pt/include/export/config/tclparam.inc
new file mode 100644
index 0000000..cec07e8
--- /dev/null
+++ b/tcllib/modules/pt/include/export/config/tclparam.inc
@@ -0,0 +1,74 @@
+[section Configuration]
+
+The Tcl/PARAM export plugin recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin arguments]
+
+[arg_def string template]
+
+If this configuration variable is set it is assumed to contain a
+string into which to put the generated code and other configuration
+data. The various locations are expected to be specified with the
+following placeholders:
+
+[list_begin definitions]
+
+[def [const @user@]]
+To be replaced with the value of the configuration variable [option user].
+
+[def [const @format@]]
+To be replaced with the the constant [const Tcl/PARAM].
+
+[def [const @file@]]
+To be replaced with the value of the configuration variable [option file].
+
+[def [const @name@]]
+To be replaced with the value of the configuration variable [option name].
+
+[def [const @code@]]
+To be replaced with the generated Tcl code.
+
+[list_end]
+
+The following configuration variables are special, in that they will
+occur within the generated code, and are replaced there as well.
+
+[list_begin definitions]
+
+[def [const @runtime@]]
+To be replaced with the value of the configuration variable [option runtime-command].
+
+[def [const @self@]]
+To be replaced with the value of the configuration variable [option self-command].
+
+[def [const @def@]]
+To be replaced with the value of the configuration variable [option proc-command].
+
+[def [const @ns@]]
+To be replaced with the value of the configuration variable [option namespace].
+
+[def [const @main@]]
+To be replaced with the value of the configuration variable [option main].
+
+[def [const @prelude@]]
+To be replaced with the value of the configuration variable [option prelude].
+
+[list_end]
+
+[para]
+
+If this configuration variable is not set, or empty, then the plugin
+falls back to a standard template, which is defined as "[const @code@]".
+
+[list_end]
+
+[emph Note] that this plugin may ignore the standard configuration
+variables [var user], [var format], [var file], and their values,
+depending on the chosen template.
+
+[para]
+
+The content of the standard configuration variable [var name], if set,
+is used as name of the grammar in the output. Otherwise the plugin
+falls back to the default name [const a_pe_grammar].
diff --git a/tcllib/modules/pt/include/export/config/to_container.inc b/tcllib/modules/pt/include/export/config/to_container.inc
new file mode 100644
index 0000000..d6a32a6
--- /dev/null
+++ b/tcllib/modules/pt/include/export/config/to_container.inc
@@ -0,0 +1,7 @@
+
+[section "[vset TPREFIX]Options"]
+
+The converter to the CONTAINER format recognizes the following options
+and changes its behaviour as they specify.
+
+[include ../../format/options_container.inc]
diff --git a/tcllib/modules/pt/include/export/config/to_cparam.inc b/tcllib/modules/pt/include/export/config/to_cparam.inc
new file mode 100644
index 0000000..7955732
--- /dev/null
+++ b/tcllib/modules/pt/include/export/config/to_cparam.inc
@@ -0,0 +1,25 @@
+
+[section Options]
+
+The converter to C code recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[include ../../format/options_cparam_rawc.inc]
+
+While the high parameterizability of this converter, as shown by the
+multitude of options it supports, is an advantage to the advanced
+user, allowing her to customize the output of the converter as needed,
+a novice user will likely not see the forest for the trees.
+
+[para]
+
+To help these latter users an adjunct package is provided, containing
+a canned configuration which will generate immediately useful full
+parsers. It is
+
+[list_begin definitions]
+[def [package pt::cparam::configuration::critcl]]
+
+Generated parsers are embedded into a [package Critcl]-based framework.
+
+[list_end]
diff --git a/tcllib/modules/pt/include/export/config/to_json.inc b/tcllib/modules/pt/include/export/config/to_json.inc
new file mode 100644
index 0000000..dce6a17
--- /dev/null
+++ b/tcllib/modules/pt/include/export/config/to_json.inc
@@ -0,0 +1,8 @@
+
+[section "[vset TPREFIX]Options"]
+
+The converter to the JSON grammar exchange format recognizes the
+following configuration variables and changes its behaviour as they
+specify.
+
+[include ../../format/options_json.inc]
diff --git a/tcllib/modules/pt/include/export/config/to_param.inc b/tcllib/modules/pt/include/export/config/to_param.inc
new file mode 100644
index 0000000..091bed2
--- /dev/null
+++ b/tcllib/modules/pt/include/export/config/to_param.inc
@@ -0,0 +1,51 @@
+
+[section "[vset TPREFIX]Options"]
+
+The converter to PARAM markup recognizes the following configuration
+variables and changes its behaviour as they specify.
+
+[list_begin options]
+
+[opt_def -template string]
+
+The value of this configuration variable is a string into which to put
+the generated text and the other configuration settings. The various
+locations for user-data are expected to be specified with the
+placeholders listed below. The default value is "[const @code@]".
+
+[list_begin definitions]
+
+[def [const @user@]]
+To be replaced with the value of the configuration variable [option -user].
+
+[def [const @format@]]
+To be replaced with the the constant [const PARAM].
+
+[def [const @file@]]
+To be replaced with the value of the configuration variable [option -file].
+
+[def [const @name@]]
+To be replaced with the value of the configuration variable [option -name].
+
+[def [const @code@]]
+To be replaced with the generated text.
+
+[list_end]
+
+[opt_def -name string]
+
+The value of this configuration variable is the name of the grammar
+for which the conversion is run. The default value is [const a_pe_grammar].
+
+[opt_def -user string]
+
+The value of this configuration variable is the name of the user for
+which the conversion is run. The default value is [const unknown].
+
+[opt_def -file string]
+
+The value of this configuration variable is the name of the file or
+other entity from which the grammar came, for which the conversion is
+run. The default value is [const unknown].
+
+[list_end]
diff --git a/tcllib/modules/pt/include/export/config/to_peg.inc b/tcllib/modules/pt/include/export/config/to_peg.inc
new file mode 100644
index 0000000..d99609a
--- /dev/null
+++ b/tcllib/modules/pt/include/export/config/to_peg.inc
@@ -0,0 +1,7 @@
+
+[section "[vset TPREFIX]Options"]
+
+The converter to the PEG language recognizes the following options and
+changes its behaviour as they specify.
+
+[include ../../format/options_peg.inc]
diff --git a/tcllib/modules/pt/include/export/config/to_tclparam.inc b/tcllib/modules/pt/include/export/config/to_tclparam.inc
new file mode 100644
index 0000000..b09c5b2
--- /dev/null
+++ b/tcllib/modules/pt/include/export/config/to_tclparam.inc
@@ -0,0 +1,156 @@
+
+[section Options]
+
+The converter to Tcl/PARAM markup recognizes the following
+configuration variables and changes its behaviour as they specify.
+
+[list_begin options]
+
+[opt_def -template string]
+
+The value of this configuration variable is a string into which to put
+the generated text and the other configuration settings. The various
+locations for user-data are expected to be specified with the
+placeholders listed below. The default value is "[const @code@]".
+
+[list_begin definitions]
+
+[def [const @user@]]
+To be replaced with the value of the configuration variable [option -user].
+
+[def [const @format@]]
+To be replaced with the the constant [const Tcl/PARAM].
+
+[def [const @file@]]
+To be replaced with the value of the configuration variable [option -file].
+
+[def [const @name@]]
+To be replaced with the value of the configuration variable [option -name].
+
+[def [const @code@]]
+To be replaced with the generated Tcl code.
+
+[list_end]
+
+The following configuration variables are special, in that they will
+occur within the generated code, and are replaced there as well.
+
+[list_begin definitions]
+
+[def [const @runtime@]]
+To be replaced with the value of the configuration variable [option runtime-command].
+
+[def [const @self@]]
+To be replaced with the value of the configuration variable [option self-command].
+
+[def [const @def@]]
+To be replaced with the value of the configuration variable [option proc-command].
+
+[def [const @ns@]]
+To be replaced with the value of the configuration variable [option namespace].
+
+[def [const @main@]]
+To be replaced with the value of the configuration variable [option main].
+
+[def [const @prelude@]]
+To be replaced with the value of the configuration variable [option prelude].
+
+[list_end]
+
+[opt_def -name string]
+
+The value of this configuration variable is the name of the grammar
+for which the conversion is run. The default value is [const a_pe_grammar].
+
+[opt_def -user string]
+
+The value of this configuration variable is the name of the user for
+which the conversion is run. The default value is [const unknown].
+
+[opt_def -file string]
+
+The value of this configuration variable is the name of the file or
+other entity from which the grammar came, for which the conversion is
+run. The default value is [const unknown].
+
+
+[opt_def -runtime-command string]
+
+A Tcl string representing the Tcl command or reference to it used to
+call PARAM instruction from parser procedures, per the chosen
+framework (template).
+
+The default value is the empty string.
+
+
+[opt_def -self-command string]
+
+A Tcl string representing the Tcl command or reference to it used to
+call the parser procedures (methods ...) from another parser
+procedure, per the chosen framework (template).
+
+The default value is the empty string.
+
+
+[opt_def -proc-command string]
+
+The name of the Tcl command used to define procedures (methods ...),
+per the chosen framework (template).
+The default value is [const proc].
+
+
+[opt_def -namespace string]
+
+The name of the namespace the parser procedures (methods, ...) shall
+reside in, including the trailing '::' needed to separate it from the
+actual procedure name.
+
+The default value is [const ::].
+
+
+[opt_def -main string]
+
+The name of the main procedure (method, ...) to be called by the
+chosen framework (template) to start parsing input.
+
+The default value is [const __main].
+
+
+[opt_def -prelude string]
+
+A snippet of code to be insert at the head of each generated parsing
+command.
+
+The default value is the empty string.
+
+
+[opt_def -indent integer]
+
+The number of characters to indent each line of the generated code by.
+
+The default value is [const 0].
+
+[list_end]
+
+While the high parameterizability of this converter, as shown by the
+multitude of options it supports, is an advantage to the advanced
+user, allowing her to customize the output of the converter as needed,
+a novice user will likely not see the forest for the trees.
+
+[para]
+
+To help these latter users two adjunct packages are provided, each
+containing a canned configuration which will generate immediately
+useful full parsers. These are
+
+[list_begin definitions]
+[def [package pt::tclparam::configuration::snit]]
+
+Generated parsers are classes based on the [package snit] package,
+i.e. snit::type's.
+
+[def [package pt::tclparam::configuration::tcloo]]
+
+Generated parsers are classes based on the [package OO] package.
+
+[list_end]
diff --git a/tcllib/modules/pt/include/export/format/container.inc b/tcllib/modules/pt/include/export/format/container.inc
new file mode 100644
index 0000000..5b2cc68
--- /dev/null
+++ b/tcllib/modules/pt/include/export/format/container.inc
@@ -0,0 +1,3 @@
+[require pt::peg]
+[require text::write]
+[require char]
diff --git a/tcllib/modules/pt/include/export/format/cparam.inc b/tcllib/modules/pt/include/export/format/cparam.inc
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/pt/include/export/format/cparam.inc
diff --git a/tcllib/modules/pt/include/export/format/json.inc b/tcllib/modules/pt/include/export/format/json.inc
new file mode 100644
index 0000000..f868e55
--- /dev/null
+++ b/tcllib/modules/pt/include/export/format/json.inc
@@ -0,0 +1,2 @@
+[require pt::peg]
+[require json::write]
diff --git a/tcllib/modules/pt/include/export/format/null.inc b/tcllib/modules/pt/include/export/format/null.inc
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/pt/include/export/format/null.inc
diff --git a/tcllib/modules/pt/include/export/format/param.inc b/tcllib/modules/pt/include/export/format/param.inc
new file mode 100644
index 0000000..d9ff38b
--- /dev/null
+++ b/tcllib/modules/pt/include/export/format/param.inc
@@ -0,0 +1,2 @@
+[require pt::peg]
+[require pt::pe]
diff --git a/tcllib/modules/pt/include/export/format/peg.inc b/tcllib/modules/pt/include/export/format/peg.inc
new file mode 100644
index 0000000..0b7a89f
--- /dev/null
+++ b/tcllib/modules/pt/include/export/format/peg.inc
@@ -0,0 +1,3 @@
+[require pt::peg]
+[require pt::pe]
+[require text::write]
diff --git a/tcllib/modules/pt/include/export/format/tclparam.inc b/tcllib/modules/pt/include/export/format/tclparam.inc
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/pt/include/export/format/tclparam.inc
diff --git a/tcllib/modules/pt/include/export/plugin.inc b/tcllib/modules/pt/include/export/plugin.inc
new file mode 100644
index 0000000..a7676d7
--- /dev/null
+++ b/tcllib/modules/pt/include/export/plugin.inc
@@ -0,0 +1,71 @@
+[comment {-*- tcl -*- --- !doctools ---}]
+[manpage_begin pt::peg::export::[vset PACKAGE] n [vset VERSION]]
+[include ../module.inc]
+[include ../keywords_export.inc]
+[titledesc "PEG Export Plugin. Write [vset NAME] format"]
+[require pt::peg::export::[vset PACKAGE] [opt [vset VERSION]]]
+[require pt::peg::to::[vset PACKAGE]]
+[description]
+[include ../ref_intro.inc]
+
+This package implements the parsing expression grammar export plugin
+for the generation of [vset NAME] markup.
+
+[para]
+
+It resides in the Export section of the Core Layer of Parser Tools and
+is intended to be used by [package pt::peg::export], the export
+manager, sitting between it and the corresponding core conversion
+functionality provided by [package pt::peg::to::[vset PACKAGE]].
+
+[para][image arch_core_eplugins][para]
+
+[para]
+
+While the direct use of this package with a regular interpreter is
+possible, this is strongly disrecommended and requires a number of
+contortions to provide the expected environment.
+
+The proper way to use this functionality depends on the situation:
+
+[list_begin enumerated]
+[enum]
+
+In an untrusted environment the proper access is through the package
+[package pt::peg::export] and the export manager objects it
+provides.
+
+[enum]
+
+In a trusted environment however simply use the package
+[package pt::peg::to::[vset PACKAGE]] and access the core
+conversion functionality directly.
+
+[list_end]
+
+
+[section API]
+
+The API provided by this package satisfies the specification of the
+Plugin API found in the [manpage {Parser Tools Export API}]
+specification.
+
+[list_begin definitions]
+
+[call [cmd export] [arg serial] [arg configuration]]
+
+This command takes the canonical serialization of a parsing expression
+grammar, as specified in section [sectref {PEG serialization format}],
+and contained in [arg serial], the [arg configuration], a dictionary,
+and generates [vset NAME] markup encoding the grammar.
+
+The created string is then returned as the result of the command.
+
+[list_end]
+
+[include config/[vset CONFIG].inc]
+[include ../format/[vset PACKAGE].inc]
+[include ../serial/pegrammar.inc]
+[include ../serial/pexpression.inc]
+[include ../feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/include/export/to.inc b/tcllib/modules/pt/include/export/to.inc
new file mode 100644
index 0000000..bdc4d54
--- /dev/null
+++ b/tcllib/modules/pt/include/export/to.inc
@@ -0,0 +1,75 @@
+[comment {-*- tcl -*- --- !doctools ---}]
+[manpage_begin pt::peg::to::[vset PACKAGE] n [vset VERSION]]
+[include ../module.inc]
+[include ../keywords_convert.inc]
+[titledesc "PEG Conversion. Write [vset NAME] format"]
+[require pt::peg::to::[vset PACKAGE] [opt [vset VERSION]]]
+[include format/[vset REQUIRE].inc]
+[description]
+[include ../ref_intro.inc]
+
+This package implements the converter from parsing expression grammars
+to [vset NAME] markup.
+
+[para]
+
+It resides in the Export section of the Core Layer of Parser Tools,
+and can be used either directly with the other packages of this layer,
+or indirectly through the export manager provided by
+[package pt::peg::export]. The latter is intented for use in untrusted
+environments and done through the corresponding export plugin
+[package pt::peg::export::[vset PACKAGE]] sitting between converter
+and export manager.
+
+[para][image arch_core_eplugins][para]
+
+
+[section API]
+
+The API provided by this package satisfies the specification of the
+Converter API found in the [manpage {Parser Tools Export API}]
+specification.
+
+
+[list_begin definitions]
+
+[call [cmd pt::peg::to::[vset PACKAGE]] [method reset]]
+
+This command resets the configuration of the package to its default
+settings.
+
+[call [cmd pt::peg::to::[vset PACKAGE]] [method configure]]
+
+This command returns a dictionary containing the current configuration
+of the package.
+
+[call [cmd pt::peg::to::[vset PACKAGE]] [method configure] [arg option]]
+
+This command returns the current value of the specified configuration
+[arg option] of the package. For the set of legal options, please read
+the section [sectref Options].
+
+[call [cmd pt::peg::to::[vset PACKAGE]] [method configure] [arg option] [arg value]...]
+
+This command sets the given configuration [arg option]s of the
+package, to the specified [arg value]s. For the set of legal options,
+please read the section [sectref Options].
+
+[call [cmd pt::peg::to::[vset PACKAGE]] [method convert] [arg serial]]
+
+This command takes the canonical serialization of a parsing expression
+grammar, as specified in section [sectref {PEG serialization format}],
+and contained in [arg serial], and generates [vset NAME] markup
+encoding the grammar, per the current package configuration.
+
+The created string is then returned as the result of the command.
+
+[list_end]
+
+[vset TPREFIX {}]
+[include config/to_[vset CONFIG].inc]
+[include ../format/[vset PACKAGE].inc]
+[include ../serial/pegrammar.inc]
+[include ../serial/pexpression.inc]
+[include ../feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/include/feedback.inc b/tcllib/modules/pt/include/feedback.inc
new file mode 100644
index 0000000..8fc01a0
--- /dev/null
+++ b/tcllib/modules/pt/include/feedback.inc
@@ -0,0 +1,3 @@
+[comment {--- Standard trailer for all manpages in this module --}]
+[vset CATEGORY pt]
+[include ../../doctools2base/include/feedback.inc]
diff --git a/tcllib/modules/pt/include/format/container.inc b/tcllib/modules/pt/include/format/container.inc
new file mode 100644
index 0000000..7cb464d
--- /dev/null
+++ b/tcllib/modules/pt/include/format/container.inc
@@ -0,0 +1,21 @@
+
+[section {Grammar Container}]
+
+[include whatis_container.inc]
+[para]
+
+It has no direct formal specification beyond what was said above.
+
+[subsection Example]
+
+Assuming the following PEG for simple mathematical expressions
+
+[para]
+[include ../example/expr_peg.inc]
+[para]
+
+one possible CONTAINER serialization for it is
+
+[para]
+[include ../example/expr_container.inc]
+[para]
diff --git a/tcllib/modules/pt/include/format/cparam.inc b/tcllib/modules/pt/include/format/cparam.inc
new file mode 100644
index 0000000..703bd81
--- /dev/null
+++ b/tcllib/modules/pt/include/format/cparam.inc
@@ -0,0 +1,38 @@
+
+[section {C/PARAM code representation of parsing expression grammars}]
+
+[include whatis_cparam_rawc.inc]
+[para]
+
+The bulk of such a framework has to be specified through the option
+[option -template]. The additional options
+
+[list_begin options]
+[opt_def -fun-qualifier string]
+[opt_def -main string]
+[opt_def -namespace string]
+[opt_def -prelude string]
+[opt_def -self-command string]
+[opt_def -state-decl string]
+[opt_def -state-ref string]
+[opt_def -string-varname string]
+[list_end]
+
+provide code snippets which help to glue framework and generated code
+together. Their placeholders are in the [emph generated] code.
+
+Further the options
+
+[list_begin options]
+[opt_def -indent integer]
+[opt_def -comments boolean]
+[list_end]
+
+allow for the customization of the code indent (default none), and
+whether to generate comments showing the parsing expressions a
+function is for (default on).
+
+[subsection Example]
+
+We are forgoing an example of this representation, with apologies.
+It would be way to large for this document.
diff --git a/tcllib/modules/pt/include/format/json.inc b/tcllib/modules/pt/include/format/json.inc
new file mode 100644
index 0000000..468d889
--- /dev/null
+++ b/tcllib/modules/pt/include/format/json.inc
@@ -0,0 +1,3 @@
+
+[section {JSON Grammar Exchange Format}]
+[include json_core.inc]
diff --git a/tcllib/modules/pt/include/format/json_core.inc b/tcllib/modules/pt/include/format/json_core.inc
new file mode 100644
index 0000000..b19c39b
--- /dev/null
+++ b/tcllib/modules/pt/include/format/json_core.inc
@@ -0,0 +1,103 @@
+
+[include whatis_json.inc]
+[para]
+
+It is formally specified by the rules below:
+
+[list_begin enumerated][comment {-- json points --}]
+[enum]
+The JSON of any PEG is a JSON object.
+
+[enum]
+This object holds a single key, [const pt::grammar::peg], and its
+value. This value holds the contents of the grammar.
+
+[enum]
+The contents of the grammar are a JSON object holding the set of
+nonterminal symbols and the starting expression. The relevant keys and
+their values are
+
+[list_begin definitions][comment {-- grammar keywords --}]
+[def [const rules]]
+
+The value is a JSON object whose keys are the names of the nonterminal
+symbols known to the grammar.
+
+[list_begin enumerated][comment {-- nonterminals --}]
+[enum]
+Each nonterminal symbol may occur only once.
+
+[enum]
+The empty string is not a legal nonterminal symbol.
+
+[enum]
+The value for each symbol is a JSON object itself. The relevant
+keys and their values in this dictionary are
+
+[list_begin definitions][comment {-- nonterminal keywords --}]
+[def [const is]]
+
+The value is a JSON string holding the Tcl serialization of the
+parsing expression describing the symbols sentennial structure, as
+specified in the section [sectref {PE serialization format}].
+
+[comment {
+ This part we could try to expand further into a json data structure
+(array of (objects of) arrays ?)
+}]
+
+[def [const mode]]
+
+The value is a JSON holding holding one of three values specifying how
+a parser should handle the semantic value produced by the symbol.
+
+[include ../modes.inc]
+[list_end][comment {-- nonterminal keywords --}]
+[list_end][comment {-- nonterminals --}]
+
+[def [const start]]
+
+The value is a JSON string holding the Tcl serialization of the start
+parsing expression of the grammar, as specified in the section
+[sectref {PE serialization format}].
+
+[list_end][comment {-- grammar keywords --}]
+
+[enum]
+The terminal symbols of the grammar are specified implicitly as the
+set of all terminal symbols used in the start expression and on the
+RHS of the grammar rules.
+
+[list_end][comment {-- json points --}]
+
+[para]
+
+As an aside to the advanced reader, this is pretty much the same as
+the Tcl serialization of PE grammars, as specified in section
+[sectref {PEG serialization format}], except that the Tcl dictionaries
+and lists of that format are mapped to JSON objects and arrays. Only
+the parsing expressions themselves are not translated further, but
+kept as JSON strings containing a nested Tcl list, and there is no
+concept of canonicity for the JSON either.
+
+[subsection Example]
+
+Assuming the following PEG for simple mathematical expressions
+
+[para]
+[include ../example/expr_peg.inc]
+[para]
+
+a JSON serialization for it is
+
+[para]
+[include ../example/expr_json.inc]
+[para]
+
+and a Tcl serialization of the same is
+
+[para]
+[include ../example/expr_serial.inc]
+[para]
+
+The similarity of the latter to the JSON should be quite obvious.
diff --git a/tcllib/modules/pt/include/format/options_container.inc b/tcllib/modules/pt/include/format/options_container.inc
new file mode 100644
index 0000000..4ebff51
--- /dev/null
+++ b/tcllib/modules/pt/include/format/options_container.inc
@@ -0,0 +1,60 @@
+[list_begin options]
+[include options_std.inc]
+
+[opt_def -mode [const bulk]|[const incremental]]
+
+The value of this option controls which methods of
+
+[package pt::peg::container] instances are used to specify the
+grammar, i.e. preload it into the container. There are two legal
+values, as listed below. The default is [const bulk].
+
+[list_begin definitions]
+[def [const bulk]]
+
+In this mode the methods [method start], [method add], [method modes],
+and [method rules] are used to specify the grammar in a bulk manner,
+i.e. as a set of nonterminal symbols, and two dictionaries mapping
+from the symbols to their semantic modes and parsing expressions.
+
+[para]
+
+This mode is the default.
+
+[def [const incremental]]
+
+In this mode the methods [method start], [method add], [method mode],
+and [method rule] are used to specify the grammar piecemal, with each
+nonterminal having its own block of defining commands.
+
+[list_end]
+
+[opt_def -template string]
+
+The value of this option is a string into which to put the generated
+code and the other configuration settings. The various locations for
+user-data are expected to be specified with the placeholders listed
+below. The default value is "[const @code@]".
+
+[list_begin definitions]
+
+[def [const @user@]]
+To be replaced with the value of the option [option -user].
+
+[def [const @format@]]
+To be replaced with the the constant [const CONTAINER].
+
+[def [const @file@]]
+To be replaced with the value of the option [option -file].
+
+[def [const @name@]]
+To be replaced with the value of the option [option -name].
+
+[def [const @mode@]]
+To be replaced with the value of the option [option -mode].
+
+[def [const @code@]]
+To be replaced with the generated code.
+
+[list_end]
+[list_end]
diff --git a/tcllib/modules/pt/include/format/options_cparam_critcl.inc b/tcllib/modules/pt/include/format/options_cparam_critcl.inc
new file mode 100644
index 0000000..30b5d66
--- /dev/null
+++ b/tcllib/modules/pt/include/format/options_cparam_critcl.inc
@@ -0,0 +1,34 @@
+
+[list_begin options]
+[include options_std.inc]
+
+[comment {= = == === ===== ======== =============}]
+[opt_def -class string]
+
+The value of this option is the name of the class to generate, without
+leading colons.
+
+The default value is [const CLASS].
+
+[para]
+
+For a simple value [var X] without colons, like CLASS, the parser
+command will be [var X]::[var X]. Whereas for a namespaced value
+[var X::Y] the parser command will be [var X::Y].
+
+[comment {= = == === ===== ======== =============}]
+[opt_def -package string]
+
+The value of this option is the name of the package to generate.
+
+The default value is [const PACKAGE].
+
+[comment {= = == === ===== ======== =============}]
+[opt_def -version string]
+
+The value of this option is the version of the package to generate.
+
+The default value is [const 1].
+
+[comment {= = == === ===== ======== =============}]
+[list_end]
diff --git a/tcllib/modules/pt/include/format/options_cparam_rawc.inc b/tcllib/modules/pt/include/format/options_cparam_rawc.inc
new file mode 100644
index 0000000..01021f9
--- /dev/null
+++ b/tcllib/modules/pt/include/format/options_cparam_rawc.inc
@@ -0,0 +1,142 @@
+
+[list_begin options]
+[include options_std.inc]
+
+[opt_def -template string]
+
+The value of this option is a string into which to put
+the generated text and the other configuration settings. The various
+locations for user-data are expected to be specified with the
+placeholders listed below. The default value is "[const @code@]".
+
+[list_begin definitions]
+
+[def [const @user@]]
+To be replaced with the value of the option [option -user].
+
+[def [const @format@]]
+To be replaced with the the constant [const C/PARAM].
+
+[def [const @file@]]
+To be replaced with the value of the option [option -file].
+
+[def [const @name@]]
+To be replaced with the value of the option [option -name].
+
+[def [const @code@]]
+To be replaced with the generated Tcl code.
+
+[list_end]
+
+The following options are special, in that they will
+occur within the generated code, and are replaced there as well.
+
+[list_begin definitions]
+
+[def [const @statedecl@]]
+To be replaced with the value of the option [option state-decl].
+
+[def [const @stateref@]]
+To be replaced with the value of the option [option state-ref].
+
+[def [const @strings@]]
+To be replaced with the value of the option [option string-varname].
+
+[def [const @self@]]
+To be replaced with the value of the option [option self-command].
+
+[def [const @def@]]
+To be replaced with the value of the option [option fun-qualifier].
+
+[def [const @ns@]]
+To be replaced with the value of the option [option namespace].
+
+[def [const @main@]]
+To be replaced with the value of the option [option main].
+
+[def [const @prelude@]]
+To be replaced with the value of the option [option prelude].
+
+[list_end]
+
+[opt_def -state-decl string]
+
+A C string representing the argument declaration to use in the
+generated parsing functions to refer to the parsing state. In essence
+type and argument name.
+
+The default value is the string [const {RDE_PARAM p}].
+
+
+[opt_def -state-ref string]
+
+A C string representing the argument named used in the generated
+parsing functions to refer to the parsing state.
+
+The default value is the string [const p].
+
+
+[opt_def -self-command string]
+
+A C string representing the reference needed to call the generated
+parser function (methods ...) from another parser fonction, per the
+chosen framework (template).
+
+The default value is the empty string.
+
+
+[opt_def -fun-qualifier string]
+
+A C string containing the attributes to give to the generated
+functions (methods ...), per the chosen framework (template).
+
+The default value is [const static].
+
+
+[opt_def -namespace string]
+
+The name of the C namespace the parser functions (methods, ...) shall
+reside in, or a general prefix to add to the function names.
+
+The default value is the empty string.
+
+
+[opt_def -main string]
+
+The name of the main function (method, ...) to be called by the chosen
+framework (template) to start parsing input.
+
+The default value is [const __main].
+
+
+[opt_def -string-varname string]
+
+The name of the variable used for the table of strings used by the
+generated parser, i.e. error messages, symbol names, etc.
+
+The default value is [const p_string].
+
+
+[opt_def -prelude string]
+
+A snippet of code to be inserted at the head of each generated parsing
+function.
+
+The default value is the empty string.
+
+
+[opt_def -indent integer]
+
+The number of characters to indent each line of the generated code by.
+
+The default value is [const 0].
+
+
+[opt_def -comments boolean]
+
+A flag controlling the generation of code comments containing the
+original parsing expression a parsing function is for.
+
+The default value is [const on].
+
+[list_end]
diff --git a/tcllib/modules/pt/include/format/options_json.inc b/tcllib/modules/pt/include/format/options_json.inc
new file mode 100644
index 0000000..a6b472c
--- /dev/null
+++ b/tcllib/modules/pt/include/format/options_json.inc
@@ -0,0 +1,31 @@
+
+[list_begin options]
+[include options_std.inc]
+
+[opt_def -indented boolean]
+
+If this option is set the system will break the generated JSON across
+lines and indent it according to its inner structure, with each key of
+a dictionary on a separate line.
+
+[para]
+
+If the option is not set (the default), the whole JSON object will be
+written on a single line, with minimum spacing between all elements.
+
+
+[opt_def -aligned boolean]
+
+If this option is set the system will ensure that the values for the
+keys in a dictionary are vertically aligned with each other, for a
+nice table effect.
+
+To make this work this also implies that [option -indented] is set.
+
+[para]
+
+If the option is not set (the default), the output is formatted as per
+the value of [var indented], without trying to align the values for
+dictionary keys.
+
+[list_end]
diff --git a/tcllib/modules/pt/include/format/options_peg.inc b/tcllib/modules/pt/include/format/options_peg.inc
new file mode 100644
index 0000000..4b85984
--- /dev/null
+++ b/tcllib/modules/pt/include/format/options_peg.inc
@@ -0,0 +1,30 @@
+
+[list_begin options]
+[include options_std.inc]
+
+[opt_def -template string]
+
+The value of this option is a string into which to put the generated
+text and the values of the other options. The various locations for
+user-data are expected to be specified with the placeholders listed
+below. The default value is "[const @code@]".
+
+[list_begin definitions]
+
+[def [const @user@]]
+To be replaced with the value of the option [option -user].
+
+[def [const @format@]]
+To be replaced with the the constant [const PEG].
+
+[def [const @file@]]
+To be replaced with the value of the option [option -file].
+
+[def [const @name@]]
+To be replaced with the value of the option [option -name].
+
+[def [const @code@]]
+To be replaced with the generated text.
+
+[list_end]
+[list_end]
diff --git a/tcllib/modules/pt/include/format/options_std.inc b/tcllib/modules/pt/include/format/options_std.inc
new file mode 100644
index 0000000..3b156ee
--- /dev/null
+++ b/tcllib/modules/pt/include/format/options_std.inc
@@ -0,0 +1,16 @@
+
+[opt_def -file string]
+
+The value of this option is the name of the file or other entity from
+which the grammar came, for which the command is run. The default
+value is [const unknown].
+
+[opt_def -name string]
+
+The value of this option is the name of the grammar we are processing.
+The default value is [const a_pe_grammar].
+
+[opt_def -user string]
+
+The value of this option is the name of the user for which the command
+is run. The default value is [const unknown].
diff --git a/tcllib/modules/pt/include/format/options_tclparam_oo.inc b/tcllib/modules/pt/include/format/options_tclparam_oo.inc
new file mode 100644
index 0000000..d57d717
--- /dev/null
+++ b/tcllib/modules/pt/include/format/options_tclparam_oo.inc
@@ -0,0 +1,32 @@
+
+[list_begin options]
+[include options_std.inc]
+
+[comment {================================================================================}]
+[opt_def -class string]
+
+The value of this option is the name of the class to generate, without
+leading colons. Note, it serves double-duty as the name of the package
+to generate too, if option [option -package] is not specified, see below.
+
+The default value is [const CLASS], applying if neither option
+[option -class] nor [option -package] were specified.
+
+[comment {================================================================================}]
+[opt_def -package string]
+
+The value of this option is the name of the package to generate, without
+leading colons. Note, it serves double-duty as the name of the class
+to generate too, if option [option -class] is not specified, see above.
+
+The default value is [const PACKAGE], applying if neither option
+[option -package] nor [option -class] were specified.
+
+[comment {================================================================================}]
+[opt_def -version string]
+
+The value of this option is the version of the package to generate.
+
+The default value is [const 1].
+
+[list_end]
diff --git a/tcllib/modules/pt/include/format/options_tclparam_snit.inc b/tcllib/modules/pt/include/format/options_tclparam_snit.inc
new file mode 100644
index 0000000..d57d717
--- /dev/null
+++ b/tcllib/modules/pt/include/format/options_tclparam_snit.inc
@@ -0,0 +1,32 @@
+
+[list_begin options]
+[include options_std.inc]
+
+[comment {================================================================================}]
+[opt_def -class string]
+
+The value of this option is the name of the class to generate, without
+leading colons. Note, it serves double-duty as the name of the package
+to generate too, if option [option -package] is not specified, see below.
+
+The default value is [const CLASS], applying if neither option
+[option -class] nor [option -package] were specified.
+
+[comment {================================================================================}]
+[opt_def -package string]
+
+The value of this option is the name of the package to generate, without
+leading colons. Note, it serves double-duty as the name of the class
+to generate too, if option [option -class] is not specified, see above.
+
+The default value is [const PACKAGE], applying if neither option
+[option -package] nor [option -class] were specified.
+
+[comment {================================================================================}]
+[opt_def -version string]
+
+The value of this option is the version of the package to generate.
+
+The default value is [const 1].
+
+[list_end]
diff --git a/tcllib/modules/pt/include/format/param.inc b/tcllib/modules/pt/include/format/param.inc
new file mode 100644
index 0000000..b99139b
--- /dev/null
+++ b/tcllib/modules/pt/include/format/param.inc
@@ -0,0 +1,21 @@
+
+[section {PARAM code representation of parsing expression grammars}]
+
+[include whatis_param.inc]
+[para]
+
+It has no direct formal specification beyond what was said above.
+
+[subsection Example]
+
+Assuming the following PEG for simple mathematical expressions
+
+[para]
+[include ../example/expr_peg.inc]
+[para]
+
+one possible PARAM serialization for it is
+
+[para]
+[include ../example/expr_param.inc]
+[para]
diff --git a/tcllib/modules/pt/include/format/peg.inc b/tcllib/modules/pt/include/format/peg.inc
new file mode 100644
index 0000000..c68fdb1
--- /dev/null
+++ b/tcllib/modules/pt/include/format/peg.inc
@@ -0,0 +1,119 @@
+
+[section {PEG Specification Language}]
+
+[include whatis_peg.inc]
+[para]
+
+It is formally specified by the grammar shown below, written in
+itself. For a tutorial / introduction to the language please go and
+read the [manpage {PEG Language Tutorial}].
+
+[para]
+[example {
+PEG pe-grammar-for-peg (Grammar)
+
+ # --------------------------------------------------------------------
+ # Syntactical constructs
+
+ Grammar <- WHITESPACE Header Definition* Final EOF ;
+
+ Header <- PEG Identifier StartExpr ;
+ Definition <- Attribute? Identifier IS Expression SEMICOLON ;
+ Attribute <- (VOID / LEAF) COLON ;
+ Expression <- Sequence (SLASH Sequence)* ;
+ Sequence <- Prefix+ ;
+ Prefix <- (AND / NOT)? Suffix ;
+ Suffix <- Primary (QUESTION / STAR / PLUS)? ;
+ Primary <- ALNUM / ALPHA / ASCII / CONTROL / DDIGIT / DIGIT
+ / GRAPH / LOWER / PRINTABLE / PUNCT / SPACE / UPPER
+ / WORDCHAR / XDIGIT
+ / Identifier
+ / OPEN Expression CLOSE
+ / Literal
+ / Class
+ / DOT
+ ;
+ Literal <- APOSTROPH (!APOSTROPH Char)* APOSTROPH WHITESPACE
+ / DAPOSTROPH (!DAPOSTROPH Char)* DAPOSTROPH WHITESPACE ;
+ Class <- OPENB (!CLOSEB Range)* CLOSEB WHITESPACE ;
+ Range <- Char TO Char / Char ;
+
+ StartExpr <- OPEN Expression CLOSE ;
+void: Final <- "END" WHITESPACE SEMICOLON WHITESPACE ;
+
+ # --------------------------------------------------------------------
+ # Lexing constructs
+
+ Identifier <- Ident WHITESPACE ;
+leaf: Ident <- ([_:] / <alpha>) ([_:] / <alnum>)* ;
+ Char <- CharSpecial / CharOctalFull / CharOctalPart
+ / CharUnicode / CharUnescaped
+ ;
+
+leaf: CharSpecial <- "\\" [nrt'"\[\]\\] ;
+leaf: CharOctalFull <- "\\" [0-2][0-7][0-7] ;
+leaf: CharOctalPart <- "\\" [0-7][0-7]? ;
+leaf: CharUnicode <- "\\" 'u' HexDigit (HexDigit (HexDigit HexDigit?)?)? ;
+leaf: CharUnescaped <- !"\\" . ;
+
+void: HexDigit <- [0-9a-fA-F] ;
+
+void: TO <- '-' ;
+void: OPENB <- "[" ;
+void: CLOSEB <- "]" ;
+void: APOSTROPH <- "'" ;
+void: DAPOSTROPH <- '"' ;
+void: PEG <- "PEG" !([_:] / <alnum>) WHITESPACE ;
+void: IS <- "<-" WHITESPACE ;
+leaf: VOID <- "void" WHITESPACE ; # Implies that definition has no semantic value.
+leaf: LEAF <- "leaf" WHITESPACE ; # Implies that definition has no terminals.
+void: SEMICOLON <- ";" WHITESPACE ;
+void: COLON <- ":" WHITESPACE ;
+void: SLASH <- "/" WHITESPACE ;
+leaf: AND <- "&" WHITESPACE ;
+leaf: NOT <- "!" WHITESPACE ;
+leaf: QUESTION <- "?" WHITESPACE ;
+leaf: STAR <- "*" WHITESPACE ;
+leaf: PLUS <- "+" WHITESPACE ;
+void: OPEN <- "(" WHITESPACE ;
+void: CLOSE <- ")" WHITESPACE ;
+leaf: DOT <- "." WHITESPACE ;
+
+leaf: ALNUM <- "<alnum>" WHITESPACE ;
+leaf: ALPHA <- "<alpha>" WHITESPACE ;
+leaf: ASCII <- "<ascii>" WHITESPACE ;
+leaf: CONTROL <- "<control>" WHITESPACE ;
+leaf: DDIGIT <- "<ddigit>" WHITESPACE ;
+leaf: DIGIT <- "<digit>" WHITESPACE ;
+leaf: GRAPH <- "<graph>" WHITESPACE ;
+leaf: LOWER <- "<lower>" WHITESPACE ;
+leaf: PRINTABLE <- "<print>" WHITESPACE ;
+leaf: PUNCT <- "<punct>" WHITESPACE ;
+leaf: SPACE <- "<space>" WHITESPACE ;
+leaf: UPPER <- "<upper>" WHITESPACE ;
+leaf: WORDCHAR <- "<wordchar>" WHITESPACE ;
+leaf: XDIGIT <- "<xdigit>" WHITESPACE ;
+
+void: WHITESPACE <- (" " / "\t" / EOL / COMMENT)* ;
+void: COMMENT <- '#' (!EOL .)* EOL ;
+void: EOL <- "\n\r" / "\n" / "\r" ;
+void: EOF <- !. ;
+
+ # --------------------------------------------------------------------
+END;
+}]
+
+[subsection Example]
+
+Our example specifies the grammar for a basic 4-operation calculator.
+
+[para]
+[include ../example/expr_peg.inc]
+[para]
+
+Using higher-level features of the notation, i.e. the character
+classes (predefined and custom), this example can be rewritten as
+
+[para]
+[include ../example/expr_peg_compact.inc]
+[para]
diff --git a/tcllib/modules/pt/include/format/tclparam.inc b/tcllib/modules/pt/include/format/tclparam.inc
new file mode 100644
index 0000000..2183bd9
--- /dev/null
+++ b/tcllib/modules/pt/include/format/tclparam.inc
@@ -0,0 +1,30 @@
+
+[section {Tcl/PARAM code representation of parsing expression grammars}]
+
+The Tcl/PARAM representation of parsing expression grammars is Tcl
+code whose execution will parse input per the grammar. The code is
+based on the virtual machine documented in the
+[manpage {PackRat Machine Specification}], using its instructions
+and a few more to handle control flow.
+
+[para]
+
+Note that the generated code by itself is not functional. It expects
+to be embedded into a framework which provides services like the PARAM
+state, implementations for the PARAM instructions, etc.
+
+The bulk of such a framework has to be specified through the option
+[option -template]. The additional options
+
+[list_begin options]
+[opt_def -indent integer]
+[opt_def -main string]
+[opt_def -namespace string]
+[opt_def -prelude string]
+[opt_def -proc-command string]
+[opt_def -runtime-command string]
+[opt_def -self-command string]
+[list_end]
+
+provide code snippets which help to glue framework and generated code
+together. Their placeholders are in the [emph generated] code.
diff --git a/tcllib/modules/pt/include/format/whatis_container.inc b/tcllib/modules/pt/include/format/whatis_container.inc
new file mode 100644
index 0000000..6ed7034
--- /dev/null
+++ b/tcllib/modules/pt/include/format/whatis_container.inc
@@ -0,0 +1,13 @@
+
+The [const container] format is another form of describing parsing
+expression grammars. While data in this format is executable it does
+not constitute a parser for the grammar. It always has to be used in
+conjunction with the package [package pt::peg::interp], a grammar
+interpreter.
+
+[para]
+
+The format represents grammars by a [cmd snit::type], i.e. class,
+whose instances are API-compatible to the instances of the
+[package pt::peg::container] package, and which are preloaded with the
+grammar in question.
diff --git a/tcllib/modules/pt/include/format/whatis_cparam_critcl.inc b/tcllib/modules/pt/include/format/whatis_cparam_critcl.inc
new file mode 100644
index 0000000..6e669b9
--- /dev/null
+++ b/tcllib/modules/pt/include/format/whatis_cparam_critcl.inc
@@ -0,0 +1,4 @@
+
+The [const critcl] format is executable code, a parser for the
+grammar. It is a Tcl package with the actual parser implementation
+written in C and embedded in Tcl via the [package critcl] package.
diff --git a/tcllib/modules/pt/include/format/whatis_cparam_rawc.inc b/tcllib/modules/pt/include/format/whatis_cparam_rawc.inc
new file mode 100644
index 0000000..19f532f
--- /dev/null
+++ b/tcllib/modules/pt/include/format/whatis_cparam_rawc.inc
@@ -0,0 +1,9 @@
+
+The [const c] format is executable code, a parser for the grammar. The
+parser implementation is written in C and can be tweaked to the users'
+needs through a multitude of options.
+
+[para]
+
+The [cmd critcl] format, for example, is implemented as a canned
+configuration of these options on top of the generator for [const c].
diff --git a/tcllib/modules/pt/include/format/whatis_json.inc b/tcllib/modules/pt/include/format/whatis_json.inc
new file mode 100644
index 0000000..09dbca2
--- /dev/null
+++ b/tcllib/modules/pt/include/format/whatis_json.inc
@@ -0,0 +1,5 @@
+
+The [const json] format for parsing expression grammars was written as
+a data exchange format not bound to Tcl. It was defined to allow the
+exchange of grammars with PackRat/PEG based parser generators for
+other languages.
diff --git a/tcllib/modules/pt/include/format/whatis_param.inc b/tcllib/modules/pt/include/format/whatis_param.inc
new file mode 100644
index 0000000..46e75da
--- /dev/null
+++ b/tcllib/modules/pt/include/format/whatis_param.inc
@@ -0,0 +1,12 @@
+
+The PARAM code representation of parsing expression grammars is
+assembler-like text using the instructions of the virtual machine
+documented in the [manpage {PackRat Machine Specification}], plus a
+few more for control flow (jump ok, jump fail, call symbol, return).
+
+[para]
+
+It is not really useful, except possibly as a tool demonstrating how a
+grammar is compiled in general, without getting distracted by the
+incidentials of a framework, i.e. like the supporting C and Tcl code
+generated by the other PARAM-derived formats.
diff --git a/tcllib/modules/pt/include/format/whatis_peg.inc b/tcllib/modules/pt/include/format/whatis_peg.inc
new file mode 100644
index 0000000..ae49cc3
--- /dev/null
+++ b/tcllib/modules/pt/include/format/whatis_peg.inc
@@ -0,0 +1,7 @@
+
+[const peg], a language for the specification of parsing expression
+grammars is meant to be human readable, and writable as well, yet
+strict enough to allow its processing by machine. Like any computer
+language. It was defined to make writing the specification of a
+grammar easy, something the other formats found in the Parser Tools do
+not lend themselves too.
diff --git a/tcllib/modules/pt/include/format/whatis_tclparam_oo.inc b/tcllib/modules/pt/include/format/whatis_tclparam_oo.inc
new file mode 100644
index 0000000..da29b1e
--- /dev/null
+++ b/tcllib/modules/pt/include/format/whatis_tclparam_oo.inc
@@ -0,0 +1,4 @@
+
+The [const oo] format is executable code, a parser for the grammar. It
+is a Tcl package holding a [package TclOO] class, whose instances are
+parsers for the input grammar.
diff --git a/tcllib/modules/pt/include/format/whatis_tclparam_snit.inc b/tcllib/modules/pt/include/format/whatis_tclparam_snit.inc
new file mode 100644
index 0000000..622240e
--- /dev/null
+++ b/tcllib/modules/pt/include/format/whatis_tclparam_snit.inc
@@ -0,0 +1,4 @@
+
+The [const snit] format is executable code, a parser for the
+grammar. It is a Tcl package holding a [cmd snit::type], i.e. a class,
+whose instances are parsers for the input grammar.
diff --git a/tcllib/modules/pt/include/gen.inc b/tcllib/modules/pt/include/gen.inc
new file mode 100644
index 0000000..d2f8743
--- /dev/null
+++ b/tcllib/modules/pt/include/gen.inc
@@ -0,0 +1,6 @@
+[def [const [vset NAME]]]
+[include format/whatis_[vset WHATIS].inc]
+[para]
+
+The set of options supported by the generator for this format is
+listed and explained in section [sectref [vset SECT]].
diff --git a/tcllib/modules/pt/include/gen_options.dia b/tcllib/modules/pt/include/gen_options.dia
new file mode 100644
index 0000000..4d75d22
--- /dev/null
+++ b/tcllib/modules/pt/include/gen_options.dia
@@ -0,0 +1,7 @@
+# -*- tcl -*- tcl.tk//DSL diagram//EN//1.0
+set boxwidth [4 cm]
+line ;group {
+ arc cw ; arc ; arrow ; box "interpreted (Tcl)" ; arrow ; box container
+} ; arc ; line ; arc cw ; arrow ; box "specialized" ; group {
+ arc ; arc cw ; arrow ; box "C" ; arrow ; box "critcl / C"
+} ; arc cw ; arc ; arrow ; box "Tcl" ; arrow ; box "snit / oo"
diff --git a/tcllib/modules/pt/include/gen_options.inc b/tcllib/modules/pt/include/gen_options.inc
new file mode 100644
index 0000000..9559fa7
--- /dev/null
+++ b/tcllib/modules/pt/include/gen_options.inc
@@ -0,0 +1 @@
+[para][image gen_options][para]
diff --git a/tcllib/modules/pt/include/gen_options.pic b/tcllib/modules/pt/include/gen_options.pic
new file mode 100644
index 0000000..78f723e
--- /dev/null
+++ b/tcllib/modules/pt/include/gen_options.pic
@@ -0,0 +1,9 @@
+.nf
+ + --- C ---> critcl, c
+ |
+ + --- specialized -+
+ | |
+ ---+ + --- Tcl -> snit, oo
+ |
+ + --- interpreted (Tcl) ------> container
+.fi
diff --git a/tcllib/modules/pt/include/gen_options.png b/tcllib/modules/pt/include/gen_options.png
new file mode 100644
index 0000000..9d64a55
--- /dev/null
+++ b/tcllib/modules/pt/include/gen_options.png
Binary files differ
diff --git a/tcllib/modules/pt/include/gen_options.txt b/tcllib/modules/pt/include/gen_options.txt
new file mode 100644
index 0000000..a8d02e5
--- /dev/null
+++ b/tcllib/modules/pt/include/gen_options.txt
@@ -0,0 +1,7 @@
+ + --- C ---> critcl, c
+ |
+ + --- specialized -+
+ | |
+ ---+ + --- Tcl -> snit, oo
+ |
+ + --- interpreted (Tcl) ------> container
diff --git a/tcllib/modules/pt/include/gen_verticals.inc b/tcllib/modules/pt/include/gen_verticals.inc
new file mode 100644
index 0000000..90cada1
--- /dev/null
+++ b/tcllib/modules/pt/include/gen_verticals.inc
@@ -0,0 +1,22 @@
+[example {
+ USER
+ |
+ Common API
+ |
+ +---------------------------+---------------------------+
+ | | |
+
+ Interpreted Specialized Tcl Specialized C
+ +------------------------+ +------------------------+ +------------------------+
+ | [container] + | | [snit or TclOO] | | C code alone or embed- |
+ | pt::peg::interp | | | | ded in Tcl (Critcl) |
+ +========================+ +========================+ | |
+ | pt::rde | | pt::rde | | |
+ | | | | | |
+ | Tcl | Critcl | | Tcl | Critcl | | |
+ +===============+ | +===============+ | | |
+ | struct::stack | | | struct::stack | | | |
+ | | | | | | | |
+ | Tcl | Critcl | | | Tcl | Critcl | | | |
+ +------+--------+--------+ +------+--------+--------+ +------------------------+
+}]
diff --git a/tcllib/modules/pt/include/import/format/json.inc b/tcllib/modules/pt/include/import/format/json.inc
new file mode 100644
index 0000000..193b279
--- /dev/null
+++ b/tcllib/modules/pt/include/import/format/json.inc
@@ -0,0 +1,2 @@
+[require pt::peg]
+[require json]
diff --git a/tcllib/modules/pt/include/import/format/peg.inc b/tcllib/modules/pt/include/import/format/peg.inc
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/pt/include/import/format/peg.inc
diff --git a/tcllib/modules/pt/include/import/from.inc b/tcllib/modules/pt/include/import/from.inc
new file mode 100644
index 0000000..9a0acc3
--- /dev/null
+++ b/tcllib/modules/pt/include/import/from.inc
@@ -0,0 +1,49 @@
+[comment {-*- tcl -*- --- !doctools ---}]
+[manpage_begin pt::peg::from::[vset PACKAGE] n [vset VERSION]]
+[include ../module.inc]
+[include ../keywords_convert.inc]
+[titledesc "PEG Conversion. Read [vset NAME] format"]
+[require pt::peg::from::[vset PACKAGE] [opt [vset VERSION]]]
+[include format/[vset REQUIRE].inc]
+[description]
+[include ../ref_intro.inc]
+
+This package implements the converter from [vset NAME] markup to
+parsing expression grammars.
+
+[para]
+
+It resides in the Import section of the Core Layer of Parser Tools,
+and can be used either directly with the other packages of this layer,
+or indirectly through the import manager provided by
+[package pt::peg::import]. The latter is intented for use in untrusted
+environments and done through the corresponding import plugin
+[package pt::peg::import::[vset PACKAGE]] sitting between converter
+and import manager.
+
+[para][image arch_core_iplugins][para]
+
+[section API]
+
+The API provided by this package satisfies the specification of the
+Converter API found in the [manpage {Parser Tools Import API}]
+specification.
+
+[list_begin definitions]
+
+[call [cmd pt::peg::from::[vset PACKAGE]] [method convert] [arg text]]
+
+This command takes the [vset NAME] markup encoding a parsing
+expression grammar and contained in [arg text], and generates the
+canonical serialization of said grammar, as specified in section
+[sectref {PEG serialization format}].
+
+The created value is then returned as the result of the command.
+
+[list_end]
+
+[include ../format/[vset PACKAGE].inc]
+[include ../serial/pegrammar.inc]
+[include ../serial/pexpression.inc]
+[include ../feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/include/import/plugin.inc b/tcllib/modules/pt/include/import/plugin.inc
new file mode 100644
index 0000000..a9aec5f
--- /dev/null
+++ b/tcllib/modules/pt/include/import/plugin.inc
@@ -0,0 +1,69 @@
+[comment {-*- tcl -*- --- !doctools ---}]
+[manpage_begin pt::peg::import::[vset PACKAGE] n [vset VERSION]]
+[include ../module.inc]
+[include ../keywords_import.inc]
+[titledesc "PEG Import Plugin. Read [vset NAME] format"]
+[require pt::peg::import::[vset PACKAGE] [opt [vset VERSION]]]
+[require pt::peg::to::[vset PACKAGE]]
+[description]
+[include ../ref_intro.inc]
+
+This package implements the parsing expression grammar import plugin
+processing [vset NAME] markup.
+
+[para]
+
+It resides in the Import section of the Core Layer of Parser Tools and
+is intended to be used by [package pt::peg::import], the import
+manager, sitting between it and the corresponding core conversion
+functionality provided by [package pt::peg::from::[vset PACKAGE]].
+
+[para][image arch_core_iplugins][para]
+[para]
+
+While the direct use of this package with a regular interpreter is
+possible, this is strongly disrecommended and requires a number of
+contortions to provide the expected environment.
+
+The proper way to use this functionality depends on the situation:
+
+[list_begin enumerated]
+[enum]
+
+In an untrusted environment the proper access is through the package
+[package pt::peg::import] and the import manager objects it
+provides.
+
+[enum]
+
+In a trusted environment however simply use the package
+[package pt::peg::from::[vset PACKAGE]] and access the core
+conversion functionality directly.
+
+[list_end]
+
+
+[section API]
+
+The API provided by this package satisfies the specification of the
+Plugin API found in the [manpage {Parser Tools Import API}]
+specification.
+
+[list_begin definitions]
+
+[call [cmd import] [arg text]]
+
+This command takes the [vset NAME] markup encoding a parsing
+expression grammar and contained in [arg text], and generates the
+canonical serialization of said grammar, as specified in section
+[sectref {PEG serialization format}].
+
+The created value is then returned as the result of the command.
+
+[list_end]
+
+[include ../format/[vset PACKAGE].inc]
+[include ../serial/pegrammar.inc]
+[include ../serial/pexpression.inc]
+[include ../feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/include/keywords.inc b/tcllib/modules/pt/include/keywords.inc
new file mode 100644
index 0000000..aaad9db
--- /dev/null
+++ b/tcllib/modules/pt/include/keywords.inc
@@ -0,0 +1,17 @@
+[comment {--- Keywords common to all packages in Parser Tools ---}]
+[keywords {EBNF}]
+[keywords {LL(k)}]
+[keywords {PEG}]
+[keywords {TDPL}]
+[keywords {context-free languages}]
+[keywords {expression}]
+[keywords {grammar}]
+[keywords {matching}]
+[keywords {parser}]
+[keywords {parsing expression grammar}]
+[keywords {parsing expression}]
+[keywords {push down automaton}]
+[keywords {recursive descent}]
+[keywords {state}]
+[keywords {top-down parsing languages}]
+[keywords {transducer}]
diff --git a/tcllib/modules/pt/include/keywords_convert.inc b/tcllib/modules/pt/include/keywords_convert.inc
new file mode 100644
index 0000000..acf9161
--- /dev/null
+++ b/tcllib/modules/pt/include/keywords_convert.inc
@@ -0,0 +1,5 @@
+[comment {--- Keywords shared among all the conversion packages ---}]
+[keywords [vset NAME]]
+[keywords {conversion}]
+[keywords {format conversion}]
+[keywords {serialization}]
diff --git a/tcllib/modules/pt/include/keywords_export.inc b/tcllib/modules/pt/include/keywords_export.inc
new file mode 100644
index 0000000..ad5ca06
--- /dev/null
+++ b/tcllib/modules/pt/include/keywords_export.inc
@@ -0,0 +1,5 @@
+[comment {--- Keywords shared among all the export plugins ---}]
+[keywords [vset NAME]]
+[keywords {export}]
+[keywords {plugin}]
+[keywords {serialization}]
diff --git a/tcllib/modules/pt/include/keywords_import.inc b/tcllib/modules/pt/include/keywords_import.inc
new file mode 100644
index 0000000..9a633bc
--- /dev/null
+++ b/tcllib/modules/pt/include/keywords_import.inc
@@ -0,0 +1,5 @@
+[comment {--- Keywords shared among all the import plugins ---}]
+[keywords [vset NAME]]
+[keywords {import}]
+[keywords {plugin}]
+[keywords {serialization}]
diff --git a/tcllib/modules/pt/include/modes.inc b/tcllib/modules/pt/include/modes.inc
new file mode 100644
index 0000000..4fce8d0
--- /dev/null
+++ b/tcllib/modules/pt/include/modes.inc
@@ -0,0 +1,21 @@
+[list_begin definitions][comment {-- modes --}]
+
+[def [const value]]
+
+The semantic value of the nonterminal symbol is an abstract syntax
+tree consisting of a single node node for the nonterminal itself,
+which has the ASTs of the symbol's right hand side as its children.
+
+[def [const leaf]]
+
+The semantic value of the nonterminal symbol is an abstract syntax
+tree consisting of a single node node for the nonterminal, without any
+children. Any ASTs generated by the symbol's right hand side are
+discarded.
+
+[def [const void]]
+
+The nonterminal has no semantic value. Any ASTs generated by the
+symbol's right hand side are discarded (as well).
+
+[list_end][comment {-- modes --}]
diff --git a/tcllib/modules/pt/include/module.inc b/tcllib/modules/pt/include/module.inc
new file mode 100644
index 0000000..8a41ee7
--- /dev/null
+++ b/tcllib/modules/pt/include/module.inc
@@ -0,0 +1,6 @@
+[comment {--- Standard header for all manpages in this module --}]
+[copyright {2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
+[moddesc {Parser Tools}]
+[include keywords.inc]
+[category {Parsing and Grammars}]
+[require Tcl 8.5]
diff --git a/tcllib/modules/pt/include/param_1is.inc b/tcllib/modules/pt/include/param_1is.inc
new file mode 100644
index 0000000..6b9d39b
--- /dev/null
+++ b/tcllib/modules/pt/include/param_1is.inc
@@ -0,0 +1,3 @@
+[para]
+This part of the machine's state is used and modified by the
+instructions defined in the section [sectref [vset INS0]].
diff --git a/tcllib/modules/pt/include/param_2is.inc b/tcllib/modules/pt/include/param_2is.inc
new file mode 100644
index 0000000..15362f0
--- /dev/null
+++ b/tcllib/modules/pt/include/param_2is.inc
@@ -0,0 +1,4 @@
+[para]
+This part of the machine's state is used and modified by the
+instructions defined in the sections [sectref [vset INS0]], and
+[sectref [vset INS1]].
diff --git a/tcllib/modules/pt/include/param_3is.inc b/tcllib/modules/pt/include/param_3is.inc
new file mode 100644
index 0000000..d6e9364
--- /dev/null
+++ b/tcllib/modules/pt/include/param_3is.inc
@@ -0,0 +1,4 @@
+[para]
+This part of the machine's state is used and modified by the
+instructions defined in the sections [sectref [vset INS0]],
+[sectref [vset INS1]], and [sectref [vset INS2]].
diff --git a/tcllib/modules/pt/include/param_okfail.inc b/tcllib/modules/pt/include/param_okfail.inc
new file mode 100644
index 0000000..0751f77
--- /dev/null
+++ b/tcllib/modules/pt/include/param_okfail.inc
@@ -0,0 +1,7 @@
+[para]
+
+Success and failure of the test are both recorded directly in ST.
+Success further clears ES, wheras failure sets the pair of CL and
+expected input (encoded as a leaf parsing expression) as the new ES
+and then rewinds CL by one character, preparing the machine for
+another parse attempt by a possible alternative.
diff --git a/tcllib/modules/pt/include/param_special.inc b/tcllib/modules/pt/include/param_special.inc
new file mode 100644
index 0000000..55cc600
--- /dev/null
+++ b/tcllib/modules/pt/include/param_special.inc
@@ -0,0 +1,4 @@
+This instruction implements the special PE operator "[vset OP]", which
+checks if CC falls into the character class of the same name, or not.
+
+[include param_okfail.inc]
diff --git a/tcllib/modules/pt/include/rde_0cins.inc b/tcllib/modules/pt/include/rde_0cins.inc
new file mode 100644
index 0000000..8e44138
--- /dev/null
+++ b/tcllib/modules/pt/include/rde_0cins.inc
@@ -0,0 +1,5 @@
+[call [arg objectName] [method i_[vset IFAIL]/[vset IOKX]]]
+
+This method is a convenient combination of control flow and the two
+PARAM instructions [cmd [vset IFAIL]] and [cmd [vset IOK]]. The former
+is executed for "ST == fail", the latter for "ST == ok".
diff --git a/tcllib/modules/pt/include/rde_0gins.inc b/tcllib/modules/pt/include/rde_0gins.inc
new file mode 100644
index 0000000..5a64b26
--- /dev/null
+++ b/tcllib/modules/pt/include/rde_0gins.inc
@@ -0,0 +1,4 @@
+[call [arg objectName] [method i:[vset G]_[vset INS]]]
+
+This guarded method, a variant of [method i_[vset INS]], executes only
+for "ST == [vset G]".
diff --git a/tcllib/modules/pt/include/rde_0ginsb.inc b/tcllib/modules/pt/include/rde_0ginsb.inc
new file mode 100644
index 0000000..5e2a0fb
--- /dev/null
+++ b/tcllib/modules/pt/include/rde_0ginsb.inc
@@ -0,0 +1,4 @@
+[call [arg objectName] [method i:[vset G]_[vset INS]]]
+
+This method implements a guarded variant of the the PARAM instruction
+[cmd [vset INS]], which executes only for "ST == [vset G]".
diff --git a/tcllib/modules/pt/include/rde_0ins.inc b/tcllib/modules/pt/include/rde_0ins.inc
new file mode 100644
index 0000000..38f8848
--- /dev/null
+++ b/tcllib/modules/pt/include/rde_0ins.inc
@@ -0,0 +1,3 @@
+[call [arg objectName] [method i_[vset INS]]]
+
+This method implements the PARAM instruction [cmd [vset INS]].
diff --git a/tcllib/modules/pt/include/rde_1ins.inc b/tcllib/modules/pt/include/rde_1ins.inc
new file mode 100644
index 0000000..c51a43b
--- /dev/null
+++ b/tcllib/modules/pt/include/rde_1ins.inc
@@ -0,0 +1,3 @@
+[call [arg objectName] [method i_[vset INS]] [arg [vset IA0]]]
+
+This method implements the PARAM instruction [cmd [vset INS]].
diff --git a/tcllib/modules/pt/include/rde_2ins.inc b/tcllib/modules/pt/include/rde_2ins.inc
new file mode 100644
index 0000000..eb8f314
--- /dev/null
+++ b/tcllib/modules/pt/include/rde_2ins.inc
@@ -0,0 +1,3 @@
+[call [arg objectName] [method i_[vset INS]] [arg [vset IA0]] [arg [vset IA1]]]
+
+This method implements the PARAM instruction [cmd [vset INS]].
diff --git a/tcllib/modules/pt/include/ref_intro.inc b/tcllib/modules/pt/include/ref_intro.inc
new file mode 100644
index 0000000..a8f7484
--- /dev/null
+++ b/tcllib/modules/pt/include/ref_intro.inc
@@ -0,0 +1,12 @@
+
+[para]
+
+Are you lost ?
+
+Do you have trouble understanding this document ?
+
+In that case please read the overview provided by the
+[manpage {Introduction to Parser Tools}]. This document is the
+entrypoint to the whole system the current package is a part of.
+
+[para]
diff --git a/tcllib/modules/pt/include/serial/ast.inc b/tcllib/modules/pt/include/serial/ast.inc
new file mode 100644
index 0000000..090a8c2
--- /dev/null
+++ b/tcllib/modules/pt/include/serial/ast.inc
@@ -0,0 +1,104 @@
+[comment {-*- text -*-}]
+[section {AST serialization format}]
+
+Here we specify the format used by the Parser Tools to serialize
+Abstract Syntax Trees (ASTs) as immutable values for transport,
+comparison, etc.
+
+[para]
+
+Each node in an AST represents a nonterminal symbol of a grammar, and
+the range of tokens/characters in the input covered by it. ASTs do not
+contain terminal symbols, i.e. tokens/characters. These can be
+recovered from the input given a symbol's location.
+
+[para]
+
+We distinguish between [term regular] and [term canonical]
+serializations.
+
+While a tree may have more than one regular serialization only exactly
+one of them will be [term canonical].
+
+
+[list_begin definitions][comment {-- serializations --}]
+[def {Regular serialization}]
+
+[list_begin enumerated][comment {-- regular points --}]
+
+[enum]
+The serialization of any AST is the serialization of its root node.
+
+[enum]
+The serialization of any node is a Tcl list containing at least three
+elements.
+
+[list_begin enumerated][comment {-- node elements --}]
+[enum]
+The first element is the name of the nonterminal symbol stored in the
+node.
+
+[enum]
+The second and third element are the locations of the first and last
+token in the token stream the node represents (covers).
+
+[list_begin enumerated][comment {--- location constraints}]
+[enum]
+Locations are provided as non-negative integer offsets from the
+beginning of the token stream, with the first token found in the
+stream located at offset 0 (zero).
+
+[enum]
+The end location has to be equal to or larger than the start location.
+
+[list_end][comment {--- location constraints}]
+
+[enum]
+All elements after the first three represent the children of the node,
+which are themselves nodes. This means that the serializations of
+nodes without children, i.e. leaf nodes, have exactly three elements.
+
+The children are stored in the list with the leftmost child first, and
+the rightmost child last.
+
+[list_end][comment {-- node elements --}]
+[list_end][comment {-- regular points --}]
+
+[def {Canonical serialization}]
+
+The canonical serialization of an abstract syntax tree has the format
+as specified in the previous item, and then additionally satisfies the
+constraints below, which make it unique among all the possible
+serializations of this tree.
+
+[list_begin enumerated][comment {-- canonical points --}]
+[enum]
+
+The string representation of the value is the canonical representation
+of a pure Tcl list. I.e. it does not contain superfluous whitespace.
+
+[list_end][comment {-- canonical points --}]
+[list_end][comment {-- serializations --}]
+[para]
+
+[subsection Example]
+
+Assuming the parsing expression grammar below
+
+[para]
+[include ../example/expr_peg.inc]
+[para]
+
+and the input string
+
+[example { 120+5 }]
+
+then a parser should deliver the abstract syntax tree below (except for whitespace)
+
+[para]
+[include ../example/expr_ast.inc]
+[para]
+
+Or, more graphical
+
+[para][image expr_ast][para]
diff --git a/tcllib/modules/pt/include/serial/pegrammar.inc b/tcllib/modules/pt/include/serial/pegrammar.inc
new file mode 100644
index 0000000..4dbdb56
--- /dev/null
+++ b/tcllib/modules/pt/include/serial/pegrammar.inc
@@ -0,0 +1,114 @@
+[section {PEG serialization format}]
+
+Here we specify the format used by the Parser Tools to serialize
+Parsing Expression Grammars as immutable values for transport,
+comparison, etc.
+
+[para]
+
+We distinguish between [term regular] and [term canonical]
+serializations.
+
+While a PEG may have more than one regular serialization only exactly
+one of them will be [term canonical].
+
+
+[list_begin definitions][comment {-- serializations --}]
+[def {regular serialization}]
+
+[list_begin enumerated][comment {-- regular points --}]
+[enum]
+The serialization of any PEG is a nested Tcl dictionary.
+
+[enum]
+This dictionary holds a single key, [const pt::grammar::peg], and its
+value. This value holds the contents of the grammar.
+
+[enum]
+The contents of the grammar are a Tcl dictionary holding the set of
+nonterminal symbols and the starting expression. The relevant keys and
+their values are
+
+[list_begin definitions][comment {-- grammar keywords --}]
+[def [const rules]]
+
+The value is a Tcl dictionary whose keys are the names of the
+nonterminal symbols known to the grammar.
+
+[list_begin enumerated][comment {-- nonterminals --}]
+[enum]
+Each nonterminal symbol may occur only once.
+
+[enum]
+The empty string is not a legal nonterminal symbol.
+
+[enum]
+The value for each symbol is a Tcl dictionary itself. The relevant
+keys and their values in this dictionary are
+
+[list_begin definitions][comment {-- nonterminal keywords --}]
+[def [const is]]
+
+The value is the serialization of the parsing expression describing
+the symbols sentennial structure, as specified in the section
+[sectref {PE serialization format}].
+
+[def [const mode]]
+
+The value can be one of three values specifying how a parser should
+handle the semantic value produced by the symbol.
+
+[include ../modes.inc]
+[list_end][comment {-- nonterminal keywords --}]
+[list_end][comment {-- nonterminals --}]
+
+[def [const start]]
+
+The value is the serialization of the start parsing expression of the
+grammar, as specified in the section [sectref {PE serialization format}].
+
+[list_end][comment {-- grammar keywords --}]
+
+[enum]
+The terminal symbols of the grammar are specified implicitly as the
+set of all terminal symbols used in the start expression and on the
+RHS of the grammar rules.
+
+
+[list_end][comment {-- regular points --}]
+
+[def {canonical serialization}]
+
+The canonical serialization of a grammar has the format as specified
+in the previous item, and then additionally satisfies the constraints
+below, which make it unique among all the possible serializations of
+this grammar.
+
+[list_begin enumerated][comment {-- canonical points --}]
+[enum]
+
+The keys found in all the nested Tcl dictionaries are sorted in
+ascending dictionary order, as generated by Tcl's builtin command
+[cmd {lsort -increasing -dict}].
+
+[enum]
+
+The string representation of the value is the canonical representation
+of a Tcl dictionary. I.e. it does not contain superfluous whitespace.
+
+[list_end][comment {-- canonical points --}]
+[list_end][comment {-- serializations --}]
+
+[subsection Example]
+
+Assuming the following PEG for simple mathematical expressions
+
+[para]
+[include ../example/expr_peg.inc]
+[para]
+
+then its canonical serialization (except for whitespace) is
+
+[para]
+[include ../example/expr_serial.inc]
+[para]
diff --git a/tcllib/modules/pt/include/serial/pexpression.inc b/tcllib/modules/pt/include/serial/pexpression.inc
new file mode 100644
index 0000000..c0b2255
--- /dev/null
+++ b/tcllib/modules/pt/include/serial/pexpression.inc
@@ -0,0 +1,245 @@
+[comment {-*- text -*-}]
+[section {PE serialization format}]
+
+Here we specify the format used by the Parser Tools to serialize
+Parsing Expressions as immutable values for transport, comparison,
+etc.
+
+[para]
+
+We distinguish between [term regular] and [term canonical]
+serializations.
+
+While a parsing expression may have more than one regular
+serialization only exactly one of them will be [term canonical].
+
+[list_begin definitions][comment {-- serializations --}]
+[def {Regular serialization}]
+
+[list_begin definitions][comment {-- regular points --}]
+
+[def [const {Atomic Parsing Expressions}]]
+[list_begin enumerated][comment {-- atomic points --}]
+
+[enum]
+The string [const epsilon] is an atomic parsing expression. It matches
+the empty string.
+
+[enum]
+The string [const dot] is an atomic parsing expression. It matches
+any character.
+
+[enum]
+The string [const alnum] is an atomic parsing expression. It matches
+any Unicode alphabet or digit character. This is a custom extension of
+PEs based on Tcl's builtin command [cmd {string is}].
+
+[enum]
+The string [const alpha] is an atomic parsing expression. It matches
+any Unicode alphabet character. This is a custom extension of PEs
+based on Tcl's builtin command [cmd {string is}].
+
+[enum]
+The string [const ascii] is an atomic parsing expression. It matches
+any Unicode character below U0080. This is a custom extension of PEs
+based on Tcl's builtin command [cmd {string is}].
+
+[enum]
+The string [const control] is an atomic parsing expression. It matches
+any Unicode control character. This is a custom extension of PEs based
+on Tcl's builtin command [cmd {string is}].
+
+[enum]
+The string [const digit] is an atomic parsing expression. It matches
+any Unicode digit character. Note that this includes characters
+outside of the [lb]0..9[rb] range. This is a custom extension of PEs
+based on Tcl's builtin command [cmd {string is}].
+
+[enum]
+The string [const graph] is an atomic parsing expression. It matches
+any Unicode printing character, except for space. This is a custom
+extension of PEs based on Tcl's builtin command [cmd {string is}].
+
+[enum]
+The string [const lower] is an atomic parsing expression. It matches
+any Unicode lower-case alphabet character. This is a custom extension
+of PEs based on Tcl's builtin command [cmd {string is}].
+
+[enum]
+The string [const print] is an atomic parsing expression. It matches
+any Unicode printing character, including space. This is a custom
+extension of PEs based on Tcl's builtin command [cmd {string is}].
+
+[enum]
+The string [const punct] is an atomic parsing expression. It matches
+any Unicode punctuation character. This is a custom extension of PEs
+based on Tcl's builtin command [cmd {string is}].
+
+[enum]
+The string [const space] is an atomic parsing expression. It matches
+any Unicode space character. This is a custom extension of PEs based
+on Tcl's builtin command [cmd {string is}].
+
+[enum]
+The string [const upper] is an atomic parsing expression. It matches
+any Unicode upper-case alphabet character. This is a custom extension
+of PEs based on Tcl's builtin command [cmd {string is}].
+
+[enum]
+The string [const wordchar] is an atomic parsing expression. It
+matches any Unicode word character. This is any alphanumeric character
+(see alnum), and any connector punctuation characters (e.g.
+underscore). This is a custom extension of PEs based on Tcl's builtin
+command [cmd {string is}].
+
+[enum]
+The string [const xdigit] is an atomic parsing expression. It matches
+any hexadecimal digit character. This is a custom extension of PEs
+based on Tcl's builtin command [cmd {string is}].
+
+[enum]
+The string [const ddigit] is an atomic parsing expression. It matches
+any decimal digit character. This is a custom extension of PEs based
+on Tcl's builtin command [cmd regexp].
+
+[enum]
+The expression
+ [lb]list t [var x][rb]
+is an atomic parsing expression. It matches the terminal string [var x].
+
+[enum]
+The expression
+ [lb]list n [var A][rb]
+is an atomic parsing expression. It matches the nonterminal [var A].
+
+[list_end][comment {-- atomic points --}]
+
+[def [const {Combined Parsing Expressions}]]
+[list_begin enumerated][comment {-- combined points --}]
+
+[enum]
+For parsing expressions [var e1], [var e2], ... the result of
+
+ [lb]list / [var e1] [var e2] ... [rb]
+
+is a parsing expression as well.
+
+This is the [term {ordered choice}], aka [term {prioritized choice}].
+
+[enum]
+For parsing expressions [var e1], [var e2], ... the result of
+
+ [lb]list x [var e1] [var e2] ... [rb]
+
+is a parsing expression as well.
+
+This is the [term {sequence}].
+
+[enum]
+For a parsing expression [var e] the result of
+
+ [lb]list * [var e][rb]
+
+is a parsing expression as well.
+
+This is the [term {kleene closure}], describing zero or more
+repetitions.
+
+[enum]
+For a parsing expression [var e] the result of
+
+ [lb]list + [var e][rb]
+
+is a parsing expression as well.
+
+This is the [term {positive kleene closure}], describing one or more
+repetitions.
+
+[enum]
+For a parsing expression [var e] the result of
+
+ [lb]list & [var e][rb]
+
+is a parsing expression as well.
+
+This is the [term {and lookahead predicate}].
+
+[enum]
+For a parsing expression [var e] the result of
+
+ [lb]list ! [var e][rb]
+
+is a parsing expression as well.
+
+This is the [term {not lookahead predicate}].
+
+
+[enum]
+For a parsing expression [var e] the result of
+
+ [lb]list ? [var e][rb]
+
+is a parsing expression as well.
+
+This is the [term {optional input}].
+
+
+[list_end][comment {-- combined points --}]
+[list_end][comment {-- regular points --}]
+
+[def {Canonical serialization}]
+
+The canonical serialization of a parsing expression has the format as
+specified in the previous item, and then additionally satisfies the
+constraints below, which make it unique among all the possible
+serializations of this parsing expression.
+
+[list_begin enumerated][comment {-- canonical points --}]
+[enum]
+
+The string representation of the value is the canonical representation
+of a pure Tcl list. I.e. it does not contain superfluous whitespace.
+
+[enum]
+
+Terminals are [emph not] encoded as ranges (where start and end of the
+range are identical).
+
+[comment {
+ Thinking about this I am not sure if that was a good move.
+ There are a lot more equivalent encodings around that just
+ the one I used above. Examples
+
+ {x {t a} {t b} {tc } {t d}}
+ {x {x {t a} {t b}} {x {tc } {t d}}}
+ {x {x {t a} {t b} {tc } {t d}}}
+
+ etc. Having the t/.. equivalence added it can now be argued
+ that we should handle these as well. Which essentially
+ amounts to a whole-sale system to simplify parsing
+ expressions. This moves expression equality from intensional
+ to extensional, or as near as is possible.
+
+ The only counter-argument I have is that the t/.. equivalence
+ is restricted to leaves of the tree, or alternatively, to
+ terminal symbol operators.
+}]
+
+[list_end][comment {-- canonical points --}]
+[list_end][comment {-- serializations --}]
+[para]
+
+[subsection Example]
+
+Assuming the parsing expression shown on the right-hand side of the
+rule
+
+[para]
+[include ../example/expr_pe.inc]
+[para]
+
+then its canonical serialization (except for whitespace) is
+
+[para]
+[include ../example/expr_pe_serial.inc]
+[para]
diff --git a/tcllib/modules/pt/include/std_parser_object_api.inc b/tcllib/modules/pt/include/std_parser_object_api.inc
new file mode 100644
index 0000000..71b70d9
--- /dev/null
+++ b/tcllib/modules/pt/include/std_parser_object_api.inc
@@ -0,0 +1,71 @@
+
+[call [arg objectName] [method destroy]]
+
+This method destroys the parser instance, releasing all claimed memory
+and other resources, and deleting the instance command.
+
+[para]
+
+The result of the command is the empty string.
+
+
+[call [arg objectName] [method parse] [arg chan]]
+
+This method runs the parser using the contents of [arg chan] as input
+(starting at the current location in the channel), until parsing is
+not possible anymore, either because parsing has completed, or run
+into a syntax error.
+
+[include channel_notes.inc]
+
+[para]
+
+Upon successful completion the command returns an abstract syntax tree
+as its result.
+
+This AST is in the form specified in section
+[sectref {AST serialization format}].
+
+As a plain nested Tcl-list it can then be processed with any Tcl
+commands the user likes, doing transformations, semantic checks, etc.
+
+To help in this the package [package pt::ast] provides a set of
+convenience commands for validation of the tree's basic structure,
+printing it for debugging, and walking it either from the bottom up,
+or top down.
+
+[para]
+
+When encountering a syntax error the command will throw an error instead.
+
+This error will be a 4-element Tcl-list, containing, in the order
+listed below:
+
+[list_begin enumerated]
+[enum]
+The string [const pt::rde] identifying it as parser runtime error.
+
+[enum]
+The location of the parse error, as character offset from the
+beginning of the parsed input.
+
+[enum]
+The location of parse error, now as a 2-element list containing
+line-number and column in the line.
+
+[enum]
+A set of atomic parsing expressions indicating encoding the characters
+and/or nonterminal symbols the parser expected to see at the location
+of the parse error, but did not get.
+
+ For the specification of atomic parsing expressions please see the
+section [sectref {PE serialization format}].
+
+[list_end]
+
+
+[call [arg objectName] [method parset] [arg text]]
+
+This method runs the parser using the string in [arg text] as input.
+In all other ways it behaves like the method [method parse], shown
+above.
diff --git a/tcllib/modules/pt/paths.tcl b/tcllib/modules/pt/paths.tcl
new file mode 100644
index 0000000..cac1824
--- /dev/null
+++ b/tcllib/modules/pt/paths.tcl
@@ -0,0 +1,75 @@
+# paths.tcl --
+#
+# Generic path list management, for use by import management.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: paths.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# Each object manages a list of paths.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require snit
+
+# ### ### ### ######### ######### #########
+## API
+
+snit::type ::paths {
+
+ # ### ### ### ######### ######### #########
+ ## Options :: None
+
+ # ### ### ### ######### ######### #########
+ ## Creation, destruction
+
+ # Default constructor.
+ # Default destructor.
+
+ # ### ### ### ######### ######### #########
+ ## Methods :: Querying and manipulating the list of paths.
+
+ method paths {} {
+ return $mypaths
+ }
+
+ method add {path} {
+ if {$path in $mypaths} return
+ lappend mypaths $path
+ return
+ }
+
+ method remove {path} {
+ set pos [lsearch $mypaths $path]
+ if {$pos < 0} return
+ set mypaths [lreplace $mypaths $pos $pos]
+ return
+ }
+
+ method clear {} {
+ set mypaths {}
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal methods :: None
+
+ # ### ### ### ######### ######### #########
+ ## State :: List of paths.
+
+ variable mypaths {}
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide paths 1
+return
diff --git a/tcllib/modules/pt/pkgIndex.tcl b/tcllib/modules/pt/pkgIndex.tcl
new file mode 100644
index 0000000..bc7044a
--- /dev/null
+++ b/tcllib/modules/pt/pkgIndex.tcl
@@ -0,0 +1,67 @@
+if {![package vsatisfies [package provide Tcl] 8.5]} return
+
+# General utilities.
+package ifneeded char 1.0.1 [list source [file join $dir char.tcl]]
+package ifneeded configuration 1 [list source [file join $dir configuration.tcl]]
+package ifneeded paths 1 [list source [file join $dir paths.tcl]]
+package ifneeded text::write 1 [list source [file join $dir text_write.tcl]]
+
+# AST support
+package ifneeded pt::ast 1.1 [list source [file join $dir pt_astree.tcl]]
+
+# General parser support. Currently only conversion of structured
+# syntax errors (or parts thereof) into a human-readable form.
+package ifneeded pt::util 1.1 [list source [file join $dir pt_util.tcl]]
+
+# Parsing Expression support
+package ifneeded pt::pe 1.0.2 [list source [file join $dir pt_pexpression.tcl]]
+package ifneeded pt::pe::op 1.0.1 [list source [file join $dir pt_pexpr_op.tcl]]
+
+# Parsing Expression Grammar support.
+package ifneeded pt::peg 1 [list source [file join $dir pt_pegrammar.tcl]]
+package ifneeded pt::peg::container 1 [list source [file join $dir pt_peg_container.tcl]]
+package ifneeded pt::peg::interp 1.0.1 [list source [file join $dir pt_peg_interp.tcl]]
+package ifneeded pt::peg::op 1.0.1 [list source [file join $dir pt_peg_op.tcl]]
+package ifneeded pt::parse::peg 1.0.1 [list source [file join $dir pt_parse_peg.tcl]]
+
+
+# Export/import managers. Assumes an untrusted environment.
+package ifneeded pt::peg::export 1 [list source [file join $dir pt_peg_export.tcl]]
+package ifneeded pt::peg::import 1 [list source [file join $dir pt_peg_import.tcl]]
+
+# Export plugins, connecting manager to the core conversion packages.
+package ifneeded pt::peg::export::container 1 [list source [file join $dir pt_peg_export_container.tcl]]
+package ifneeded pt::peg::export::json 1 [list source [file join $dir pt_peg_export_json.tcl]]
+package ifneeded pt::peg::export::peg 1 [list source [file join $dir pt_peg_export_peg.tcl]]
+
+# Import plugins, connecting manager to the core conversion packages.
+package ifneeded pt::peg::import::json 1 [list source [file join $dir pt_peg_import_json.tcl]]
+package ifneeded pt::peg::import::peg 1 [list source [file join $dir pt_peg_import_peg.tcl]]
+
+# Export core functionality: Conversion from PEG to a specific format.
+package ifneeded pt::peg::to::container 1 [list source [file join $dir pt_peg_to_container.tcl]]
+package ifneeded pt::peg::to::cparam 1.1.3 [list source [file join $dir pt_peg_to_cparam.tcl]]
+package ifneeded pt::peg::to::json 1 [list source [file join $dir pt_peg_to_json.tcl]]
+package ifneeded pt::peg::to::param 1.0.1 [list source [file join $dir pt_peg_to_param.tcl]]
+package ifneeded pt::peg::to::peg 1.0.2 [list source [file join $dir pt_peg_to_peg.tcl]]
+package ifneeded pt::peg::to::tclparam 1.0.3 [list source [file join $dir pt_peg_to_tclparam.tcl]]
+
+# Import core functionality: Conversion from a specific format to PEG.
+package ifneeded pt::peg::from::json 1 [list source [file join $dir pt_peg_from_json.tcl]]
+package ifneeded pt::peg::from::peg 1.0.3 [list source [file join $dir pt_peg_from_peg.tcl]]
+
+# PARAM runtime.
+package ifneeded pt::rde 1.1 [list source [file join $dir pt_rdengine.tcl]]
+package ifneeded pt::rde::oo 1.1 [list source [file join $dir pt_rdengine_oo.tcl]]
+
+# PEG grammar specification, as CONTAINER
+package ifneeded pt::peg::container::peg 1 [list source [file join $dir pt_peg_container_peg.tcl]]
+
+# */PARAM support (canned configurations).
+package ifneeded pt::cparam::configuration::critcl 1.0.2 [list source [file join $dir pt_cparam_config_critcl.tcl]]
+package ifneeded pt::cparam::configuration::tea 0.1 [list source [file join $dir pt_cparam_config_tea.tcl]]
+package ifneeded pt::tclparam::configuration::snit 1.0.2 [list source [file join $dir pt_tclparam_config_snit.tcl]]
+package ifneeded pt::tclparam::configuration::tcloo 1.0.4 [list source [file join $dir pt_tclparam_config_tcloo.tcl]]
+
+# Parser generator core.
+package ifneeded pt::pgen 1.0.3 [list source [file join $dir pt_pgen.tcl]]
diff --git a/tcllib/modules/pt/pt.bench b/tcllib/modules/pt/pt.bench
new file mode 100644
index 0000000..6b04829
--- /dev/null
+++ b/tcllib/modules/pt/pt.bench
@@ -0,0 +1,186 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'pt' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# (c) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# We need at least version 8.5 for the packages and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+
+package require Tcl 8.5
+
+package forget struct::stack
+package forget char
+package forget snit
+package forget pt::ast
+package forget pt::parse::peg
+package forget pt::pe
+package forget pt::pe::op
+package forget pt::peg
+package forget pt::peg::container
+package forget pt::peg::container::peg
+package forget pt::peg::interp
+package forget pt::rde
+
+catch { namespace delete ::snit }
+catch { namespace delete ::pt }
+
+set self [file join [pwd] [file dirname [info script]]]
+set mod [file dirname $self]
+set index [file join [file dirname $self] tcllibc pkgIndex.tcl]
+
+if 1 {
+ if {[file exists $index]} {
+ set ::dir [file dirname $index]
+ uplevel #0 [list source $index]
+ unset ::dir
+ package require tcllibc
+ }
+}
+
+source [file join $mod snit snit2.tcl]
+source [file join $mod struct stack.tcl]
+
+source [file join $self char.tcl]
+source [file join $self pt_astree.tcl]
+source [file join $self pt_pexpression.tcl]
+source [file join $self pt_pegrammar.tcl]
+source [file join $self pt_peg_container.tcl]
+source [file join $self pt_peg_container_peg.tcl]
+source [file join $self pt_rdengine.tcl]
+source [file join $self pt_peg_interp.tcl]
+source [file join $self pt_parse_peg.tcl]
+
+# ### ### ### ######### ######### ######### ###########################
+## Initialize the data we are using as parser input.
+
+set peg [file join $self tests data ok peg_peg-fused/3_peg_itself]
+set c [open $peg r]
+set input [read $c]
+close $c
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+struct::stack::SwitchTo {}
+foreach e [struct::stack::KnownImplementations] {
+ ::struct::stack::LoadAccelerator $e
+}
+
+pt::rde::SwitchTo {}
+foreach e [pt::rde::KnownImplementations] {
+ ::pt::rde::LoadAccelerator $e
+}
+
+pt::parse::peg::SwitchTo {}
+foreach e [pt::parse::peg::KnownImplementations] {
+ ::pt::parse::peg::LoadAccelerator $e
+}
+
+# ### ### ### ######### ######### ######### ###########################
+
+proc DOI {rdeimpl stackimpl} {
+
+ if {$rdeimpl eq "critcl"} {
+ set iter 1000
+ } elseif {$stackimpl eq "critcl"} {
+ set iter 100
+ } else {
+ set iter 10
+ }
+
+ bench -iter $iter -desc "peg interpreter rde($rdeimpl) stack($stackimpl) PEG" -pre {
+ set g [pt::peg::container::peg %AUTO%] ; # load peg grammar
+ set i [pt::peg::interp %AUTO%] ; # grammar interpreter / parser
+ $i use $g
+ $g destroy
+ } -body {
+ $i parset $input
+ } -post {
+ $i destroy
+ }
+ return
+}
+
+proc DOS {parseimpl rdeimpl stackimpl} {
+
+ if {$parseimpl eq "critcl"} {
+ set iter 1000
+ } elseif {$rdeimpl eq "critcl"} {
+ set iter 1000
+ } elseif {$stackimpl eq "critcl"} {
+ set iter 100
+ } else {
+ set iter 10
+ }
+
+ bench -iter $iter -desc "peg specialized parse($parseimpl) rde($rdeimpl) stack($stackimpl) PEG" -pre {
+ set i [pt::parse::peg]
+ } -body {
+ $i parset $input
+ } -post {
+ $i destroy
+ }
+
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+# Note: When using pt::rde's C implementation struct::stack is not
+# used, and its implementation of no relevance.
+#
+# Similarly, when pt::parse::peg's C implementation is used
+# neither pt::rde's, nor struct::stack's implementations are of
+# relevance.
+
+foreach parseimpl [pt::parse::peg::Implementations] {
+ pt::parse::peg::SwitchTo $parseimpl
+
+ if {$parseimpl eq "critcl"} {
+ pt::rde::SwitchTo {}
+ struct::stack::SwitchTo {}
+ DOS $parseimpl n/a n/a
+ } else {
+ foreach rdeimpl [pt::rde::Implementations] {
+ pt::rde::SwitchTo $rdeimpl
+
+ if {$rdeimpl eq "critcl"} {
+ struct::stack::SwitchTo {}
+ DOS $parseimpl $rdeimpl n/a
+ } else {
+ foreach stackimpl [struct::stack::Implementations] {
+ struct::stack::SwitchTo $stackimpl
+
+ DOS $parseimpl $rdeimpl $stackimpl
+ }
+ }
+ }
+ }
+}
+
+foreach rdeimpl [pt::rde::Implementations] {
+ pt::rde::SwitchTo $rdeimpl
+
+ if {$rdeimpl eq "critcl"} {
+ struct::stack::SwitchTo {}
+ DOI $rdeimpl n/a
+ } else {
+ foreach stackimpl [struct::stack::Implementations] {
+ struct::stack::SwitchTo $stackimpl
+
+ DOI $rdeimpl $stackimpl
+ }
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/pt/pt_astree.man b/tcllib/modules/pt/pt_astree.man
new file mode 100644
index 0000000..a5b57d7
--- /dev/null
+++ b/tcllib/modules/pt/pt_astree.man
@@ -0,0 +1,171 @@
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt::ast n 1.1]
+[include include/module.inc]
+[titledesc {Abstract Syntax Tree Serialization}]
+[require pt::ast [opt 1.1]]
+[description]
+[include include/ref_intro.inc]
+
+This package provides commands to work with the serializations of
+abstract syntax trees as managed by the Parser Tools, and specified in
+section [sectref {AST serialization format}].
+
+[para]
+
+This is a supporting package in the Core Layer of Parser Tools.
+[para][image arch_core_support][para]
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::pt::ast] [method verify] \
+ [arg serial] [opt [arg canonvar]]]
+
+This command verifies that the content of [arg serial] is a valid
+serialization of an abstract syntax tree and will throw an error if
+that is not the case. The result of the command is the empty string.
+
+[para]
+
+If the argument [arg canonvar] is specified it is interpreted as the
+name of a variable in the calling context. This variable will be
+written to if and only if [arg serial] is a valid regular
+serialization. Its value will be a boolean, with [const True]
+indicating that the serialization is not only valid, but also
+[term canonical]. [const False] will be written for a valid, but
+non-canonical serialization.
+
+[para]
+
+For the specification of serializations see the section
+[sectref {AST serialization format}].
+
+[call [cmd ::pt::ast] [method verify-as-canonical] \
+ [arg serial]]
+
+This command verifies that the content of [arg serial] is a valid
+[term canonical] serialization of an abstract syntax tree and will
+throw an error if that is not the case. The result of the command is
+the empty string.
+
+[para]
+
+For the specification of canonical serializations see the section
+[sectref {AST serialization format}].
+
+[call [cmd ::pt::ast] [method canonicalize] [arg serial]]
+
+This command assumes that the content of [arg serial] is a valid
+[term regular] serialization of an abstract syntax and will throw an
+error if that is not the case.
+
+[para]
+
+It will then convert the input into the [term canonical] serialization
+of the contained tree and return it as its result. If the input is
+already canonical it will be returned unchanged.
+
+[para]
+
+For the specification of regular and canonical serializations see the
+section [sectref {AST serialization format}].
+
+[call [cmd ::pt::ast] [method print] [arg serial]]
+
+This command assumes that the argument [arg serial] contains a valid
+serialization of an abstract syntax tree and returns a string
+containing that tree in a human readable form.
+
+[para]
+
+The exact format of this form is not specified and cannot be relied on
+for parsing or other machine-based activities.
+
+[para]
+
+For the specification of serializations see the section
+[sectref {AST serialization format}].
+
+[call [cmd ::pt::ast] [method bottomup] [arg cmdprefix] [arg ast]]
+
+This command walks the abstract syntax tree [arg ast] from the bottom
+up to the root, invoking the command prefix [arg cmdprefix] for each
+node. This implies that the children of a node N are handled before N.
+
+[para]
+
+The command prefix has the signature
+
+[list_begin definitions]
+[call [cmd cmdprefix] [arg ast]]
+
+I.e. it is invoked with the ast node the walk is currently at.
+
+[para]
+
+The result returned by the command prefix replaces [arg ast] in the
+node it was a child of, allowing transformations of the tree.
+
+[para]
+
+This also means that for all inner node the contents of the children
+elements are the results of the command prefix invoked for the
+children of this node.
+
+[list_end]
+
+[call [cmd ::pt::ast] [method topdown] [arg cmdprefix] [arg pe]]
+
+This command walks the abstract syntax tree [arg ast] from the root
+down to the leaves, invoking the command prefix [arg cmdprefix] for
+each node. This implies that the children of a node N are handled
+after N.
+
+[para]
+
+The command prefix has the same signature as for [method bottomup],
+see above.
+
+[para]
+
+The result returned by the command prefix is [emph ignored].
+
+[call [cmd ::pt::ast] [method equal] \
+ [arg seriala] [arg serialb]]
+
+This command tests the two sbstract syntax trees [arg seriala] and
+[arg serialb] for structural equality. The result of the command is a
+boolean value. It will be set to [const true] if the trees are
+identical, and [const false] otherwise.
+
+[para]
+
+String equality is usable only if we can assume that the two trees are
+pure Tcl lists.
+
+[call [cmd ::pt::ast] [method new0] [arg s] \
+ [arg loc] [opt [arg child]...]]
+
+This command command constructs the ast for a nonterminal node
+refering refering to the symbol [arg s] at position [arg loc] in the
+input, and the set of child nodes [arg child] ..., from left
+right. The latter may be empty. The constructed node is returned as
+the result of the command. The end position is [arg loc]-1, i.e. one
+character before the start. This type of node is possible for rules
+containing optional parts.
+
+[call [cmd ::pt::ast] [method new] [arg s] \
+ [arg start] [arg end] [opt [arg child]...]]
+
+This command command constructs the ast for a nonterminal node
+refering to the symbol [arg s] covering the range of positions
+[arg start] to [arg end] in the input, and the set of child nodes
+[arg child] ..., from left right. The latter may be empty. The
+constructed node is returned as the result of the command.
+
+[list_end]
+
+[include include/serial/ast.inc]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_astree.tcl b/tcllib/modules/pt/pt_astree.tcl
new file mode 100644
index 0000000..5d8379b
--- /dev/null
+++ b/tcllib/modules/pt/pt_astree.tcl
@@ -0,0 +1,234 @@
+# -*- tcl -*-
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Verification of serialized parsing expressions, conversion
+# between such and other data structures, and their construction.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.5 ; # Required runtime.
+package require char ; # Character quoting utilities.
+
+# # ## ### ##### ######## ############# #####################
+##
+
+namespace eval ::pt::ast {
+ namespace export \
+ verify verify-as-canonical canonicalize \
+ equal bottomup topdown \
+ print new new0
+
+ namespace ensemble create
+}
+
+# # ## ### ##### ######## #############
+## Public API
+
+# Check that the proposed serialization of an abstract syntax tree is
+# indeed such.
+
+proc ::pt::ast::verify {serial {canonvar {}}} {
+ variable ourprefix
+ #puts "V <$serial> /[llength [info level 0]] / [info level 0]"
+
+ if {$canonvar ne {}} {
+ upvar 1 $canonvar iscanonical
+ set iscanonical [string equal $serial [list {*}$serial]]
+ }
+
+ topdown [list [namespace current]::Verify] $serial
+ return
+}
+
+proc ::pt::ast::verify-as-canonical {serial} {
+ verify $serial iscanonical
+ if {!$iscanonical} {
+ variable ourprefix
+ variable ourimpure
+ return -code error $ourprefix$ourimpure
+ }
+ return
+}
+
+proc ::pt::ast::Verify {ast} {
+ variable ourprefix
+ variable ourbadrange
+ variable ourbadend
+ variable ourbadstart
+ variable ourshort
+
+ if {[llength $ast] < 3} {
+ return -code error $ourprefix$ourshort
+ }
+
+ # Open Questions
+ # - Should we constrain the locations of the children to be
+ # inside of the parent ?
+ # - Should we constrain the locations of the children to not
+ # overlap ?
+ # Note: Gaps we have to allow, comments and whitespace and such.
+
+ lassign $ast type start end
+
+ if {![string is integer -strict $start]} {
+ return -code error $ourprefix[format $ourbadstart $start]
+ } elseif {$start < 0} {
+ return -code error $ourprefix[format $ourbadstart $start]
+ }
+
+ if {![string is integer -strict $end] || ($end < 0)} {
+ return -code error $ourprefix[format $ourbadend $end]
+ }
+
+ if {$end < $start} {
+ return -code error $ourprefix$ourbadrange
+ }
+
+ upvar 1 iscanonical iscanonical
+ if {
+ [info exists iscanonical] && ($ast ne [list {*}$ast])
+ } {
+ # Reject coding with superfluous whitespace as non-canonical.
+ set iscanonical 0
+ }
+ return
+}
+
+# # ## ### ##### ######## #############
+
+proc ::pt::ast::canonicalize {serial} {
+ verify $serial iscanonical
+ if {$iscanonical} { return $serial }
+ return [bottomup [list [namespace current]::Canonicalize] $serial]
+}
+
+proc ::pt::ast::Canonicalize {ast} {
+ # We construct a pure list out of the node data.
+ return [list {*}$ast]
+}
+
+# # ## ### ##### ######## #############
+
+# Converts a parsing expression serialization into a human readable
+# string for test results. It assumes that the serialization is at
+# least structurally sound.
+
+proc ::pt::ast::print {serial} {
+ return [join [bottomup [list [namespace current]::Print] $serial] \n]
+}
+
+proc ::pt::ast::Print {ast} {
+ set children [lassign $ast type start end]
+ set result [list [list <$type> :: $start $end]]
+
+ # The arguments are already processed for printing
+ foreach c $children {
+ foreach line $c {
+ lappend result " $line"
+ }
+ }
+ return $result
+}
+
+# # ## ### ##### ######## #############
+
+proc ::pt::ast::equal {seriala serialb} {
+ return [string equal \
+ [canonicalize $seriala] \
+ [canonicalize $serialb]]
+}
+
+# # ## ### ##### ######## #############
+
+proc ::pt::ast::bottomup {cmdprefix ast} {
+ Bottomup 2 $cmdprefix $ast
+}
+
+proc ::pt::ast::Bottomup {level cmdprefix ast} {
+ set children [lassign $ast type start end]
+ set new [list $type $start $end]
+
+ set clevel $level
+ incr clevel
+
+ foreach c $children {
+ lappend new [Bottomup $clevel $cmdprefix $c]
+ }
+
+ return [uplevel $level [list {*}$cmdprefix $new]]
+}
+
+proc ::pt::ast::topdown {cmdprefix ast} {
+ Topdown 2 $cmdprefix $ast
+ return
+}
+
+proc ::pt::ast::Topdown {level cmdprefix ast} {
+ uplevel $level [list {*}$cmdprefix $ast]
+
+ incr level
+ foreach c [lrange $ast 3 end] {
+ Topdown $level $cmdprefix $c
+ }
+ return
+}
+
+# # ## ### ##### ######## #############
+
+proc ::pt::ast::new {sym start end args} {
+ variable ourbadstart
+ variable ourbadend
+ variable ourbadrange
+
+ if {![string is integer -strict $start] || ($start < 0)} {
+ return -code error [format $ourbadstart $start]
+ }
+ if {![string is integer -strict $end] || ($end < 0)} {
+ return -code error [format $ourbadend $end]
+ }
+ if {$end < $start} {
+ return -code error $ourbadrange
+ }
+
+ return [list $sym $start $end {*}$args]
+}
+
+proc ::pt::ast::new0 {sym start args} {
+ variable ourbadstart
+
+ if {![string is integer -strict $start] || ($start < 0)} {
+ return -code error [format $ourbadstart $start]
+ }
+
+ # The end of the range is placed one position before the start,
+ # making it zero-length (length = end-start+1), i.e. empty. Such
+ # nodes are possible for symbols whose RHS uses * or ? as their
+ # top-level operator.
+
+ set end $start
+ incr end -1
+
+ return [list $sym $start $end {*}$args]
+}
+
+namespace eval ::pt::ast {
+ # # ## ### ##### ######## #############
+ ## Strings for error messages.
+
+ variable ourprefix "error in serialization:"
+ variable ourbadstart " expected integer >= 0 as start of range, got \"%s\""
+ variable ourbadend " expected integer >= 0 as end of range, got \"%s\""
+ variable ourbadrange " expected start <= end for range"
+ variable ourshort " expected at least 3 elements for node"
+ variable ourimpure " has irrelevant whitespace"
+
+ ##
+ # # ## ### ##### ######## #############
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide pt::ast 1.1
+return
diff --git a/tcllib/modules/pt/pt_astree.test b/tcllib/modules/pt/pt_astree.test
new file mode 100644
index 0000000..85fb8d0
--- /dev/null
+++ b/tcllib/modules/pt/pt_astree.test
@@ -0,0 +1,40 @@
+# -*- tcl -*-
+# pt_astree.test: tests for the pt::ast package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_astree.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ; # For tests/common
+ use snit/snit.tcl snit
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_astree.tcl pt::ast
+}
+
+# -------------------------------------------------------------------------
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/pt_astree.tests]
+
+#----------------------------------------------------------------------
+
+unset mytestdir
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_cparam_config_critcl.man b/tcllib/modules/pt/pt_cparam_config_critcl.man
new file mode 100644
index 0000000..4f8d376
--- /dev/null
+++ b/tcllib/modules/pt/pt_cparam_config_critcl.man
@@ -0,0 +1,48 @@
+[vset VERSION 1.0.2]
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt::cparam::configuration::critcl n [vset VERSION]]
+[include include/module.inc]
+[titledesc {C/PARAM, Canned configuration, Critcl}]
+[require pt::cparam::configuration::critcl [opt [vset VERSION]]]
+[description]
+[include include/ref_intro.inc]
+
+This package is an adjunct to [package pt::peg::to::cparam], to make
+the use of this highly configurable package easier by providing a
+canned configuration. When applied this configuration causes the
+package [package pt::peg::to::cparam] to generate
+[package critcl]-based parser packages.
+
+[para]
+
+It is a supporting package in the Core Layer of Parser Tools.
+[para][image arch_core_support][para]
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::pt::cparam::configuration::critcl] [method def] \
+ [arg name] [arg pkg] [arg version] [arg cmdprefix]]
+
+The command applies the configuration provided by this package to the
+[arg cmdprefix], causing the creation of [package critcl]-based parsers
+whose class is [arg name], in package [arg pkg] with [arg version].
+
+[para]
+
+The use of a command prefix as API allows application of the
+configuration to not only [package pt::peg::to::cparam]
+([cmd {pt::peg::to::cparam configure}]), but also export manager
+instances and PEG containers ([cmd {$export configuration set}] and
+[cmd {[$container exporter] configuration set}] respectively).
+
+[para]
+
+Or anything other command prefix accepting two arguments, option and
+value.
+
+[list_end]
+
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_cparam_config_critcl.tcl b/tcllib/modules/pt/pt_cparam_config_critcl.tcl
new file mode 100644
index 0000000..656105f
--- /dev/null
+++ b/tcllib/modules/pt/pt_cparam_config_critcl.tcl
@@ -0,0 +1,492 @@
+# -*- tcl -*-
+# Copyright (c) 2009-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# TODO: Refactor this and pt::cparam::configuration::critcl to avoid
+# TODO: duplication of the supporting code (creation of the RDE
+# TODO: amalgamation, basic C template).
+
+# Canned configuration for the converter to C/PARAM representation,
+# causing generation of a proper critcl-based parser.
+
+# The requirements of the embedded template are not our requirements.
+# @mdgen NODEP: critcl
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.5 ; # Required runtime.
+
+# # ## ### ##### ######## ############# #####################
+##
+
+namespace eval ::pt::cparam::configuration::critcl {
+ namespace export def
+ namespace ensemble create
+
+ # @mdgen OWNER: rde_critcl/util.*
+ # @mdgen OWNER: rde_critcl/stack.*
+ # @mdgen OWNER: rde_critcl/tc.*
+ # @mdgen OWNER: rde_critcl/param.*
+ # Access to the rde_critcl files forming the low-level runtime
+ variable selfdir [file dirname [file normalize [info script]]]
+}
+
+# # ## ### ##### ######## #############
+## Public API
+
+# Check that the proposed serialization of an abstract syntax tree is
+# indeed such.
+
+proc ::pt::cparam::configuration::critcl::def {class pkg version cmd} {
+ # TODO :: See if we can consolidate the API for converters,
+ # TODO :: plugins, export manager, and container in some way.
+ # TODO :: Container may make exporter manager available through
+ # TODO :: public method.
+
+ # class = The namespace/prefix for the generated commands.
+ # pkg = The name of the generated package / parser.
+ # version = The version of the generated package / parser.
+
+ if {[string first :: $class] < 0} {
+ set cheader $class
+ set ctrailer $class
+ } else {
+ set cheader [namespace qualifier $class]
+ set ctrailer [namespace tail $class]
+ }
+
+ lappend map @@RUNTIME@@ [GetRuntime]
+ lappend map @@PKG@@ $pkg
+ lappend map @@VERSION@@ $version
+ lappend map @@CLASS@@ $class
+ lappend map @@CHEAD@@ $cheader
+ lappend map @@CTAIL@@ $ctrailer
+ lappend map \n\t \n ;# undent the template
+
+ {*}$cmd -main MAIN
+ {*}$cmd -indent 8
+ {*}$cmd -template [string trim \
+ [string map $map {
+ ## -*- tcl -*-
+ ##
+ ## Critcl-based C/PARAM implementation of the parsing
+ ## expression grammar
+ ##
+ ## @name@
+ ##
+ ## Generated from file @file@
+ ## for user @user@
+ ##
+ # # ## ### ##### ######## ############# #####################
+ ## Requirements
+
+ package require Tcl 8.4
+ package require critcl
+ # @sak notprovided @@PKG@@
+ package provide @@PKG@@ @@VERSION@@
+
+ # Note: The implementation of the PARAM virtual machine
+ # underlying the C/PARAM code used below is inlined
+ # into the generated parser, allowing for direct access
+ # and manipulation of the RDE state, instead of having
+ # to dispatch through the Tcl interpreter.
+
+ # # ## ### ##### ######## ############# #####################
+ ##
+
+ namespace eval ::@@CHEAD@@ {
+ # # ## ### ##### ######## ############# #####################
+ ## Supporting code for the main command.
+
+ catch {
+ #critcl::cflags -g
+ #critcl::debug memory symbols
+ }
+
+ # # ## ### ###### ######## #############
+ ## RDE runtime, inlined, and made static.
+
+ # This is the C code for the RDE, i.e. the implementation
+ # of pt::rde. Only the low-level engine is imported, the
+ # Tcl interface layer is ignored. This generated parser
+ # provides its own layer for that.
+
+ critcl::ccode {
+ /* -*- c -*- */
+
+ #include <string.h>
+ #define SCOPE static
+
+@@RUNTIME@@
+ }
+
+ # # ## ### ###### ######## #############
+ ## BEGIN of GENERATED CODE. DO NOT EDIT.
+
+ critcl::ccode {
+ /* -*- c -*- */
+
+@code@
+ }
+
+ ## END of GENERATED CODE. DO NOT EDIT.
+ # # ## ### ###### ######## #############
+
+ # # ## ### ###### ######## #############
+ ## Global PARSER management, per interp
+
+ critcl::ccode {
+ /* -*- c -*- */
+
+ typedef struct PARSERg {
+ long int counter;
+ char buf [50];
+ } PARSERg;
+
+ static void
+ PARSERgRelease (ClientData cd, Tcl_Interp* interp)
+ {
+ ckfree((char*) cd);
+ }
+
+ static const char*
+ PARSERnewName (Tcl_Interp* interp)
+ {
+#define KEY "tcllib/parser/@@PKG@@/critcl"
+
+ Tcl_InterpDeleteProc* proc = PARSERgRelease;
+ PARSERg* parserg;
+
+ parserg = Tcl_GetAssocData (interp, KEY, &proc);
+ if (parserg == NULL) {
+ parserg = (PARSERg*) ckalloc (sizeof (PARSERg));
+ parserg->counter = 0;
+
+ Tcl_SetAssocData (interp, KEY, proc,
+ (ClientData) parserg);
+ }
+
+ parserg->counter ++;
+ sprintf (parserg->buf, "@@CTAIL@@%ld", parserg->counter);
+ return parserg->buf;
+#undef KEY
+ }
+
+ static void
+ PARSERdeleteCmd (ClientData clientData)
+ {
+ /*
+ * Release the whole PARSER
+ * (Low-level engine only actually).
+ */
+ rde_param_del ((RDE_PARAM) clientData);
+ }
+ }
+
+ # # ## ### ##### ######## #############
+ ## Functions implementing the object methods, and helper.
+
+ critcl::ccode {
+ static int COMPLETE (RDE_PARAM p, Tcl_Interp* interp);
+
+ static int parser_PARSE (RDE_PARAM p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+ {
+ int mode;
+ Tcl_Channel chan;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "chan");
+ return TCL_ERROR;
+ }
+
+ chan = Tcl_GetChannel(interp,
+ Tcl_GetString (objv[2]),
+ &mode);
+
+ if (!chan) {
+ return TCL_ERROR;
+ }
+
+ rde_param_reset (p, chan);
+ MAIN (p) ; /* Entrypoint for the generated code. */
+ return COMPLETE (p, interp);
+ }
+
+ static int parser_PARSET (RDE_PARAM p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+ {
+ char* buf;
+ int len;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "text");
+ return TCL_ERROR;
+ }
+
+ buf = Tcl_GetStringFromObj (objv[2], &len);
+
+ rde_param_reset (p, NULL);
+ rde_param_data (p, buf, len);
+ MAIN (p) ; /* Entrypoint for the generated code. */
+ return COMPLETE (p, interp);
+ }
+
+ /* See also rde_critcl/m.c, param_COMPLETE() */
+ static int COMPLETE (RDE_PARAM p, Tcl_Interp* interp)
+ {
+ if (rde_param_query_st (p)) {
+ long int ac;
+ Tcl_Obj** av;
+
+ rde_param_query_ast (p, &ac, &av);
+
+ if (ac > 1) {
+ Tcl_Obj** lv = NALLOC (3+ac, Tcl_Obj*);
+
+ memcpy(lv + 3, av, ac * sizeof (Tcl_Obj*));
+ lv [0] = Tcl_NewObj ();
+ lv [1] = Tcl_NewIntObj (1 + rde_param_query_lstop (p));
+ lv [2] = Tcl_NewIntObj (rde_param_query_cl (p));
+
+ Tcl_SetObjResult (interp, Tcl_NewListObj (3, lv));
+ ckfree ((char*) lv);
+
+ } else if (ac == 0) {
+ /*
+ * Match, but no AST. This is possible if the grammar
+ * consists of only the start expression.
+ */
+ Tcl_SetObjResult (interp, Tcl_NewStringObj ("",-1));
+ } else {
+ Tcl_SetObjResult (interp, av [0]);
+ }
+
+ return TCL_OK;
+ } else {
+ Tcl_Obj* xv [1];
+ const ERROR_STATE* er = rde_param_query_er (p);
+ Tcl_Obj* res = rde_param_query_er_tcl (p, er);
+ /* res = list (location, list(msg)) */
+
+ /* Stick the exception type-tag before the existing elements */
+ xv [0] = Tcl_NewStringObj ("pt::rde",-1);
+ Tcl_ListObjReplace(interp, res, 0, 0, 1, xv);
+
+ Tcl_SetErrorCode (interp, "PT", "RDE", "SYNTAX", NULL);
+ Tcl_SetObjResult (interp, res);
+ return TCL_ERROR;
+ }
+ }
+ }
+
+ # # ## ### ##### ######## #############
+ ## Object command, method dispatch.
+
+ critcl::ccode {
+ static int parser_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+ {
+ RDE_PARAM p = (RDE_PARAM) cd;
+ int m, res;
+
+ static CONST char* methods [] = {
+ "destroy", "parse", "parset", NULL
+ };
+ enum methods {
+ M_DESTROY, M_PARSE, M_PARSET
+ };
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs (interp, objc, objv, "option ?arg arg ...?");
+ return TCL_ERROR;
+ } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option",
+ 0, &m) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /* Dispatch to methods. They check the #args in
+ * detail before performing the requested
+ * functionality
+ */
+
+ switch (m) {
+ case M_DESTROY:
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_DeleteCommandFromToken(interp, (Tcl_Command) rde_param_query_clientdata (p));
+ return TCL_OK;
+
+ case M_PARSE: res = parser_PARSE (p, interp, objc, objv); break;
+ case M_PARSET: res = parser_PARSET (p, interp, objc, objv); break;
+ default:
+ /* Not coming to this place */
+ ASSERT (0,"Reached unreachable location");
+ }
+
+ return res;
+ }
+ }
+
+ # # ## ### ##### ######## #############
+ # Class command, i.e. object construction.
+
+ critcl::ccommand @@CTAIL@@_critcl {dummy interp objc objv} {
+ /*
+ * Syntax: No arguments beyond the name
+ */
+
+ RDE_PARAM parser;
+ CONST char* name;
+ Tcl_Obj* fqn;
+ Tcl_CmdInfo ci;
+ Tcl_Command c;
+
+#define USAGE "?name?"
+
+ if ((objc != 2) && (objc != 1)) {
+ Tcl_WrongNumArgs (interp, 1, objv, USAGE);
+ return TCL_ERROR;
+ }
+
+ if (objc < 2) {
+ name = PARSERnewName (interp);
+ } else {
+ name = Tcl_GetString (objv [1]);
+ }
+
+ if (!Tcl_StringMatch (name, "::*")) {
+ /* Relative name. Prefix with current namespace */
+
+ Tcl_Eval (interp, "namespace current");
+ fqn = Tcl_GetObjResult (interp);
+ fqn = Tcl_DuplicateObj (fqn);
+ Tcl_IncrRefCount (fqn);
+
+ if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) {
+ Tcl_AppendToObj (fqn, "::", -1);
+ }
+ Tcl_AppendToObj (fqn, name, -1);
+ } else {
+ fqn = Tcl_NewStringObj (name, -1);
+ Tcl_IncrRefCount (fqn);
+ }
+ Tcl_ResetResult (interp);
+
+ if (Tcl_GetCommandInfo (interp,
+ Tcl_GetString (fqn),
+ &ci)) {
+ Tcl_Obj* err;
+
+ err = Tcl_NewObj ();
+ Tcl_AppendToObj (err, "command \"", -1);
+ Tcl_AppendObjToObj (err, fqn);
+ Tcl_AppendToObj (err, "\" already exists", -1);
+
+ Tcl_DecrRefCount (fqn);
+ Tcl_SetObjResult (interp, err);
+ return TCL_ERROR;
+ }
+
+ parser = rde_param_new (sizeof(p_string)/sizeof(char*), (char**) p_string);
+ c = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn),
+ parser_objcmd, (ClientData) parser,
+ PARSERdeleteCmd);
+ rde_param_clientdata (parser, (ClientData) c);
+ Tcl_SetObjResult (interp, fqn);
+ Tcl_DecrRefCount (fqn);
+ return TCL_OK;
+ }
+
+ ##
+ # # ## ### ##### ######## #############
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## Ready (Note: Our package provide is at the top).
+ return
+ }]]
+
+ return
+}
+
+proc ::pt::cparam::configuration::critcl::GetRuntime {} {
+ # This is the C code for the RDE, i.e. the implementation of
+ # pt::rde. Only the low-level engine is imported, the Tcl
+ # interface layer is ignored. This generated parser provides its
+ # own layer for that.
+
+ # We are inlining the code (making the functions static) to
+ # prevent any conflict with the support for pt::rde, should both
+ # be put into the same shared library.
+
+ variable selfdir
+
+ set code {}
+
+ foreach f {
+ rde_critcl/util.h
+ rde_critcl/stack.h
+ rde_critcl/tc.h
+ rde_critcl/param.h
+ rde_critcl/util.c
+ rde_critcl/stack.c
+ rde_critcl/tc.c
+ rde_critcl/param.c
+ } {
+ # Load C code.
+ set c [open $selfdir/$f]
+ set d [read $c]
+ close $c
+
+ # Strip include directives and anything explicitly excluded.
+ set skip 0
+ set n {}
+ foreach l [split $d \n] {
+ if {[string match {*#include*} $l]} {
+ continue
+ }
+ if {[string match {*SKIP START*} $l]} {
+ set skip 1
+ continue
+ }
+ if {[string match {*SKIP END*} $l]} {
+ set skip 0
+ continue
+ }
+ if {$skip} continue
+ lappend n $l
+ }
+ set d [join $n \n]
+
+ # Strip comments, trailing whitespace, empty lines.
+ set d [regsub -all {/\*.*?\*/} $d {}]
+ set d [regsub -all {//.*?\n} $d {}]
+ set d [regsub -all {[ ]+$} $d {}]
+ while {1} {
+ set n [string map [list \n\n \n] $d]
+ if {$n eq $d} break
+ set d $n
+ }
+
+ # Indent code.
+ lappend code "#line 1 \"$f\""
+ foreach l [split $d \n] {
+ if {$l ne ""} { set l \t$l }
+ lappend code $l
+ }
+ }
+
+ #lappend code "#line x \"X\""
+ return [join $code \n]
+}
+
+# # ## ### ##### ######## #############
+
+namespace eval ::pt::cparam::configuration::critcl {}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide pt::cparam::configuration::critcl 1.0.2
+return
diff --git a/tcllib/modules/pt/pt_cparam_config_critcl.test b/tcllib/modules/pt/pt_cparam_config_critcl.test
new file mode 100644
index 0000000..ed0cdbd
--- /dev/null
+++ b/tcllib/modules/pt/pt_cparam_config_critcl.test
@@ -0,0 +1,50 @@
+# -*- tcl -*-
+# pt_cparam_config_critcl.test: tests for the pt::peg::to::cparam
+# converter package configured for critcl.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_cparam_config_critcl.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set ; # used by pt::pe::op,
+ TestAccelInit struct::set ; # however not by the
+ # # commands used here.
+
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pexpr_op.tcl pt::pe::op
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal text_write.tcl text::write
+ useLocal char.tcl char
+
+ useLocal pt_peg_to_cparam.tcl pt::peg::to::cparam
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_cparam_config_critcl.tcl pt::cparam::configuration::critcl
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/pt_cparam_config_critcl.tests]
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_cparam_config_tea.man b/tcllib/modules/pt/pt_cparam_config_tea.man
new file mode 100644
index 0000000..a110117
--- /dev/null
+++ b/tcllib/modules/pt/pt_cparam_config_tea.man
@@ -0,0 +1,48 @@
+[vset VERSION 0.1]
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt::cparam::configuration::tea n [vset VERSION]]
+[include include/module.inc]
+[titledesc {C/PARAM, Canned configuration, TEA}]
+[require pt::cparam::configuration::tea [opt [vset VERSION]]]
+[description]
+[include include/ref_intro.inc]
+
+This package is an adjunct to [package pt::peg::to::cparam], to make
+the use of this highly configurable package easier by providing a
+canned configuration. When applied this configuration causes the
+package [package pt::peg::to::cparam] to generate plain parser code
+ready for inclusion into a [term TEA]-based C extension.
+
+[para]
+
+It is a supporting package in the Core Layer of Parser Tools.
+[para][image arch_core_support][para]
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::pt::cparam::configuration::tea] [method def] \
+ [arg name] [arg pkg] [arg version] [arg cmdprefix]]
+
+The command applies the configuration provided by this package to the
+[arg cmdprefix], causing the creation of [package tea]-based parsers
+whose class is [arg name], in package [arg pkg] with [arg version].
+
+[para]
+
+The use of a command prefix as API allows application of the
+configuration to not only [package pt::peg::to::cparam]
+([cmd {pt::peg::to::cparam configure}]), but also export manager
+instances and PEG containers ([cmd {$export configuration set}] and
+[cmd {[$container exporter] configuration set}] respectively).
+
+[para]
+
+Or anything other command prefix accepting two arguments, option and
+value.
+
+[list_end]
+
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_cparam_config_tea.tcl b/tcllib/modules/pt/pt_cparam_config_tea.tcl
new file mode 100644
index 0000000..97aa99e
--- /dev/null
+++ b/tcllib/modules/pt/pt_cparam_config_tea.tcl
@@ -0,0 +1,465 @@
+# -*- tcl -*-
+# Copyright (c) 2014 Christian Gollwitzer <auriocus@gmx.de>
+
+# TODO: Refactor this and pt::cparam::configuration::critcl to avoid
+# TODO: duplication of the supporting code (creation of the RDE
+# TODO: amalgamation, basic C template).
+
+# Canned configuration for the converter to C/PARAM representation,
+# causing generation of a C-based parser which can be plugged into a
+# TEA-based C extension. The supporting files, i.e. configure.in,
+# Makefile.in, etc. still have to be written separately, and manually.
+
+# The generated file can easily be compiled with a single
+#
+# gcc -dynamiclib -o <parser>.dylib <parser>.c -DUSE_TCL_STUBS -ltclstub8.5
+#
+# or similar, or included in a larger package, if added to the source
+# files and by invoking the <parser>_Init() function within the init
+# function of the main package.
+#
+# TODO: Put the above note/semi-example into the manpage for this generator.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.5 ; # Required runtime.
+
+# # ## ### ##### ######## ############# #####################
+##
+
+namespace eval ::pt::cparam::configuration::tea {
+ namespace export def
+ namespace ensemble create
+
+ # @mdgen OWNER: rde_critcl/util.*
+ # @mdgen OWNER: rde_critcl/stack.*
+ # @mdgen OWNER: rde_critcl/tc.*
+ # @mdgen OWNER: rde_critcl/param.*
+ # Access to the rde_critcl files forming the low-level runtime
+ variable selfdir [file dirname [file normalize [info script]]]
+}
+
+# # ## ### ##### ######## #############
+## Public API
+
+# Check that the proposed serialization of an abstract syntax tree is
+# indeed such.
+
+proc ::pt::cparam::configuration::tea::def {class pkg version cmd} {
+ # TODO :: See if we can consolidate the API for converters,
+ # TODO :: plugins, export manager, and container in some way.
+ # TODO :: Container may make exporter manager available through
+ # TODO :: public method.
+
+ # class = The namespace/prefix for the generated commands.
+ # pkg = The name of the generated package / parser.
+ # version = The version of the generated package / parser.
+
+ if {[string first :: $class] < 0} {
+ set cheader $class
+ set ctrailer $class
+ } else {
+ set cheader [namespace qualifier $class]
+ set ctrailer [namespace tail $class]
+ }
+
+ set pkghead [string range $pkg 0 0]
+ set pkgtail [string range $pkg 1 end]
+ set pkglowcase "[string toupper $pkghead][string tolower $pkgtail]"
+
+ lappend map @@RUNTIME@@ [GetRuntime]
+ lappend map @@PKG@@ $pkg
+ lappend map @@PKGLOWCASE@@ $pkglowcase
+ lappend map @@VERSION@@ $version
+ lappend map @@CLASS@@ $class
+ lappend map @@CHEAD@@ $cheader
+ lappend map @@CTAIL@@ $ctrailer
+ lappend map \n\t \n ;# undent the template
+
+ {*}$cmd -main MAIN
+ {*}$cmd -indent 8
+ {*}$cmd -template [string trim \
+ [string map $map {
+ /************************************************************
+ **
+ ** TEA-based C/PARAM implementation of the parsing
+ ** expression grammar
+ **
+ ** @name@
+ **
+ ** Generated from file @file@
+ ** for user @user@
+ **
+ * * ** *** ***** ******** ************* *********************/
+ #include <string.h>
+ #include <tcl.h>
+ #include <stdlib.h>
+ #include <ctype.h>
+ #define SCOPE static
+
+@@RUNTIME@@
+@code@
+ /* -*- c -*- */
+
+ typedef struct PARSERg {
+ long int counter;
+ char buf [50];
+ } PARSERg;
+
+ static void
+ PARSERgRelease (ClientData cd, Tcl_Interp* interp)
+ {
+ ckfree((char*) cd);
+ }
+
+ static const char*
+ PARSERnewName (Tcl_Interp* interp)
+ {
+#define KEY "tcllib/parser/@@PKG@@/TEA"
+
+ Tcl_InterpDeleteProc* proc = PARSERgRelease;
+ PARSERg* parserg;
+
+ parserg = Tcl_GetAssocData (interp, KEY, &proc);
+ if (parserg == NULL) {
+ parserg = (PARSERg*) ckalloc (sizeof (PARSERg));
+ parserg->counter = 0;
+
+ Tcl_SetAssocData (interp, KEY, proc,
+ (ClientData) parserg);
+ }
+
+ parserg->counter ++;
+ sprintf (parserg->buf, "@@CTAIL@@%ld", parserg->counter);
+ return parserg->buf;
+#undef KEY
+ }
+
+ static void
+ PARSERdeleteCmd (ClientData clientData)
+ {
+ /*
+ * Release the whole PARSER
+ * (Low-level engine only actually).
+ */
+ rde_param_del ((RDE_PARAM) clientData);
+ }
+
+
+ /* * ** *** ***** ******** *************
+ ** Functions implementing the object methods, and helper.
+ */
+
+ static int COMPLETE (RDE_PARAM p, Tcl_Interp* interp);
+
+ static int parser_PARSE (RDE_PARAM p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+ {
+ int mode;
+ Tcl_Channel chan;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "chan");
+ return TCL_ERROR;
+ }
+
+ chan = Tcl_GetChannel(interp,
+ Tcl_GetString (objv[2]),
+ &mode);
+
+ if (!chan) {
+ return TCL_ERROR;
+ }
+
+ rde_param_reset (p, chan);
+ MAIN (p) ; /* Entrypoint for the generated code. */
+ return COMPLETE (p, interp);
+ }
+
+ static int parser_PARSET (RDE_PARAM p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+ {
+ char* buf;
+ int len;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "text");
+ return TCL_ERROR;
+ }
+
+ buf = Tcl_GetStringFromObj (objv[2], &len);
+
+ rde_param_reset (p, NULL);
+ rde_param_data (p, buf, len);
+ MAIN (p) ; /* Entrypoint for the generated code. */
+ return COMPLETE (p, interp);
+ }
+
+ /* See also rde_critcl/m.c, param_COMPLETE() */
+ static int COMPLETE (RDE_PARAM p, Tcl_Interp* interp)
+ {
+ if (rde_param_query_st (p)) {
+ long int ac;
+ Tcl_Obj** av;
+
+ rde_param_query_ast (p, &ac, &av);
+
+ if (ac > 1) {
+ Tcl_Obj** lv = NALLOC (3+ac, Tcl_Obj*);
+
+ memcpy(lv + 3, av, ac * sizeof (Tcl_Obj*));
+ lv [0] = Tcl_NewObj ();
+ lv [1] = Tcl_NewIntObj (1 + rde_param_query_lstop (p));
+ lv [2] = Tcl_NewIntObj (rde_param_query_cl (p));
+
+ Tcl_SetObjResult (interp, Tcl_NewListObj (3, lv));
+ ckfree ((char*) lv);
+
+ } else if (ac == 0) {
+ /*
+ * Match, but no AST. This is possible if the grammar
+ * consists of only the start expression.
+ */
+ Tcl_SetObjResult (interp, Tcl_NewStringObj ("",-1));
+ } else {
+ Tcl_SetObjResult (interp, av [0]);
+ }
+
+ return TCL_OK;
+ } else {
+ Tcl_Obj* xv [1];
+ const ERROR_STATE* er = rde_param_query_er (p);
+ Tcl_Obj* res = rde_param_query_er_tcl (p, er);
+ /* res = list (location, list(msg)) */
+
+ /* Stick the exception type-tag before the existing elements */
+ xv [0] = Tcl_NewStringObj ("pt::rde",-1);
+ Tcl_ListObjReplace(interp, res, 0, 0, 1, xv);
+
+ Tcl_SetErrorCode (interp, "PT", "RDE", "SYNTAX", NULL);
+ Tcl_SetObjResult (interp, res);
+ return TCL_ERROR;
+ }
+ }
+
+
+ /* * ** *** ***** ******** *************
+ ** Object command, method dispatch.
+ */
+ static int parser_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+ {
+ RDE_PARAM p = (RDE_PARAM) cd;
+ int m, res;
+
+ static CONST char* methods [] = {
+ "destroy", "parse", "parset", NULL
+ };
+ enum methods {
+ M_DESTROY, M_PARSE, M_PARSET
+ };
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs (interp, objc, objv, "option ?arg arg ...?");
+ return TCL_ERROR;
+ } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option",
+ 0, &m) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /* Dispatch to methods. They check the #args in
+ * detail before performing the requested
+ * functionality
+ */
+
+ switch (m) {
+ case M_DESTROY:
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_DeleteCommandFromToken(interp, (Tcl_Command) rde_param_query_clientdata (p));
+ return TCL_OK;
+
+ case M_PARSE: res = parser_PARSE (p, interp, objc, objv); break;
+ case M_PARSET: res = parser_PARSET (p, interp, objc, objv); break;
+ default:
+ /* Not coming to this place */
+ ASSERT (0,"Reached unreachable location");
+ }
+
+ return res;
+ }
+
+ /** * ** *** ***** ******** *************
+ * Class command, i.e. object construction.
+ */
+ static int ParserClassCmd (ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj * const*objv) {
+ /*
+ * Syntax: No arguments beyond the name
+ */
+
+ RDE_PARAM parser;
+ CONST char* name;
+ Tcl_Obj* fqn;
+ Tcl_CmdInfo ci;
+ Tcl_Command c;
+
+#define USAGE "?name?"
+
+ if ((objc != 2) && (objc != 1)) {
+ Tcl_WrongNumArgs (interp, 1, objv, USAGE);
+ return TCL_ERROR;
+ }
+
+ if (objc < 2) {
+ name = PARSERnewName (interp);
+ } else {
+ name = Tcl_GetString (objv [1]);
+ }
+
+ if (!Tcl_StringMatch (name, "::*")) {
+ /* Relative name. Prefix with current namespace */
+
+ Tcl_Eval (interp, "namespace current");
+ fqn = Tcl_GetObjResult (interp);
+ fqn = Tcl_DuplicateObj (fqn);
+ Tcl_IncrRefCount (fqn);
+
+ if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) {
+ Tcl_AppendToObj (fqn, "::", -1);
+ }
+ Tcl_AppendToObj (fqn, name, -1);
+ } else {
+ fqn = Tcl_NewStringObj (name, -1);
+ Tcl_IncrRefCount (fqn);
+ }
+ Tcl_ResetResult (interp);
+
+ if (Tcl_GetCommandInfo (interp,
+ Tcl_GetString (fqn),
+ &ci)) {
+ Tcl_Obj* err;
+
+ err = Tcl_NewObj ();
+ Tcl_AppendToObj (err, "command \"", -1);
+ Tcl_AppendObjToObj (err, fqn);
+ Tcl_AppendToObj (err, "\" already exists", -1);
+
+ Tcl_DecrRefCount (fqn);
+ Tcl_SetObjResult (interp, err);
+ return TCL_ERROR;
+ }
+
+ parser = rde_param_new (sizeof(p_string)/sizeof(char*), (char**) p_string);
+ c = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn),
+ parser_objcmd, (ClientData) parser,
+ PARSERdeleteCmd);
+ rde_param_clientdata (parser, (ClientData) c);
+ Tcl_SetObjResult (interp, fqn);
+ Tcl_DecrRefCount (fqn);
+ return TCL_OK;
+ }
+
+ int @@PKGLOWCASE@@_Init(Tcl_Interp* interp) {
+ if (interp == 0) return TCL_ERROR;
+
+ if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (Tcl_CreateObjCommand(interp, "@@CLASS@@", ParserClassCmd , NULL, NULL) == NULL) {
+ Tcl_SetResult(interp, "Can't create constructor", NULL);
+ return TCL_ERROR;
+ }
+
+
+ Tcl_PkgProvide(interp, "@@PKG@@", "0.1");
+
+ return TCL_OK;
+ }
+
+ }]]
+
+ return
+}
+
+proc ::pt::cparam::configuration::tea::GetRuntime {} {
+ # This is the C code for the RDE, i.e. the implementation of
+ # pt::rde. Only the low-level engine is imported, the Tcl
+ # interface layer is ignored. This generated parser provides its
+ # own layer for that.
+
+ # We are inlining the code (making the functions static) to
+ # prevent any conflict with the support for pt::rde, should both
+ # be put into the same shared library.
+
+ variable selfdir
+
+ set code {}
+
+ foreach f {
+ rde_critcl/util.h
+ rde_critcl/stack.h
+ rde_critcl/tc.h
+ rde_critcl/param.h
+ rde_critcl/util.c
+ rde_critcl/stack.c
+ rde_critcl/tc.c
+ rde_critcl/param.c
+ } {
+ # Load C code.
+ set c [open $selfdir/$f]
+ set d [read $c]
+ close $c
+
+ # Strip include directives and anything explicitly excluded.
+ set skip 0
+ set n {}
+ foreach l [split $d \n] {
+ if {[string match {*#include*} $l]} {
+ continue
+ }
+ if {[string match {*SKIP START*} $l]} {
+ set skip 1
+ continue
+ }
+ if {[string match {*SKIP END*} $l]} {
+ set skip 0
+ continue
+ }
+ if {$skip} continue
+ lappend n $l
+ }
+ set d [join $n \n]
+
+ # Strip comments, trailing whitespace, empty lines.
+ set d [regsub -all {/\*.*?\*/} $d {}]
+ set d [regsub -all {//.*?\n} $d {}]
+ set d [regsub -all {[ ]+$} $d {}]
+ while {1} {
+ set n [string map [list \n\n \n] $d]
+ if {$n eq $d} break
+ set d $n
+ }
+
+ # Indent code.
+ lappend code "#line 1 \"$f\""
+ foreach l [split $d \n] {
+ if {$l ne ""} { set l \t$l }
+ lappend code $l
+ }
+ }
+
+ #lappend code "#line x \"X\""
+ return [join $code \n]
+}
+
+# # ## ### ##### ######## #############
+
+namespace eval ::pt::cparam::configuration::tea {}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide pt::cparam::configuration::tea 0.1
+return
diff --git a/tcllib/modules/pt/pt_cparam_config_tea.test b/tcllib/modules/pt/pt_cparam_config_tea.test
new file mode 100644
index 0000000..092cfdc
--- /dev/null
+++ b/tcllib/modules/pt/pt_cparam_config_tea.test
@@ -0,0 +1,50 @@
+# -*- tcl -*-
+# pt_cparam_config_critcl.test: tests for the pt::peg::to::cparam
+# converter package configured for critcl.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_cparam_config_critcl.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set ; # used by pt::pe::op,
+ TestAccelInit struct::set ; # however not by the
+ # # commands used here.
+
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pexpr_op.tcl pt::pe::op
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal text_write.tcl text::write
+ useLocal char.tcl char
+
+ useLocal pt_peg_to_cparam.tcl pt::peg::to::cparam
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_cparam_config_tea.tcl pt::cparam::configuration::tea
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/pt_cparam_config_tea.tests]
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_from_api.man b/tcllib/modules/pt/pt_from_api.man
new file mode 100644
index 0000000..5b5667b
--- /dev/null
+++ b/tcllib/modules/pt/pt_from_api.man
@@ -0,0 +1,203 @@
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt_import_api i 1]
+[include include/module.inc]
+[titledesc {Parser Tools Import API}]
+[description]
+[include include/ref_intro.inc]
+
+This document describes two APIs. First the API shared by all packages
+for the conversion of some other format into Parsing Expression
+Grammars , and then the API shared by the packages which implement the
+import plugins sitting on top of the conversion packages.
+
+[para]
+
+Its intended audience are people who wish to create their own
+converter for some type of input, and/or an import plugin for their or
+some other converter.
+
+[para]
+
+It resides in the Import section of the Core Layer of Parser Tools.
+[para][image arch_core_import][para]
+
+[section {Converter API}]
+
+Any (grammar) import converter has to follow the rules set out below:
+
+[list_begin enumerated][comment {-- converter rules --}]
+
+[enum] A converter is a package. Its name is arbitrary, however it is
+ recommended to put it under the [namespace ::pt::peg::from]
+ namespace.
+
+[enum] The package provides either a single Tcl command following the
+ API outlined below, or a class command whose instances follow
+ the same API. The commands which follow the API are called
+ [term {converter commands}].
+
+[enum] A converter command has to provide the following single method
+ with the given signature and semantic. Converter commands
+ are allowed to provide more methods of their own, but not
+ less, and they may not provide different semantics for the
+ standardized method.
+
+[list_begin definitions][comment {-- api command signatures --}]
+
+[call [cmd CONVERTER] [method convert] [arg text]]
+
+This method has to accept some [arg text], a parsing expression
+grammar in some format.
+
+The result of the method has to be the canonical serialization of a
+parsing expression grammar, as specified in section
+[sectref {PEG serialization format}], the result of reading and
+converting the input text.
+
+[list_end][comment {-- api command signatures --}]
+[list_end][comment {-- converter rules --}]
+
+[section {Plugin API}]
+
+Any (grammar) import plugin has to follow the rules set out below:
+
+[list_begin enumerated][comment {-- plugin rules --}]
+
+[enum] A plugin is a package.
+
+[enum] The name of a plugin package has the form
+
+ pt::peg::import::[var FOO],
+
+ where [var FOO] is the name of the format the plugin will
+ accept input for.
+
+[enum] The plugin can expect that the package
+ [package pt::peg::import::plugin] is present, as
+ indicator that it was invoked from a genuine plugin manager.
+
+ [para]
+
+ It is recommended that a plugin does check for the presence of
+ this package.
+
+[enum] The plugin can expect that a command named [cmd IncludeFile]
+ is present, with the signature
+
+[list_begin definitions]
+[call [cmd IncludeFile] [arg currentfile] [arg path]]
+
+This command has to be invoked by the plugin when it has to process an
+included file, if the format has the concept of such.
+
+[para]
+The plugin has to supply the following arguments
+
+[list_begin arguments]
+[arg_def string currentfile]
+The path of the file it is currently processing. This may be the empty
+string if no such is known.
+
+[arg_def string path]
+The path of the include file as specified in the include directive
+being processed.
+
+[list_end]
+
+The result of the command will be a 5-element list containing
+
+[list_begin enum]
+
+[enum] A boolean flag indicating the success ([const True]) or failure
+ ([const False]) of the operation.
+
+[enum] In case of success the contents of the included file, and the
+ empty string otherwise.
+
+[enum] The resolved, i.e. absolute path of the included file, if
+ possible, or the unchanged [arg path] argument. This is for
+ display in an error message, or as the [arg currentfile]
+ argument of another call to [cmd IncludeFile] should this file
+ contain more files.
+
+[enum] In case of success an empty string, and for failure a code
+ indicating the reason for it, one of
+
+[list_begin definitions]
+[def notfound] The specified file could not be found.
+[def notread] The specified file was found, but not be read into memory.
+[list_end][comment {-- include error codes --}]
+
+[enum] An empty string in case of success of a [const notfound]
+ failure, and an additional error message describing the reason
+ for a [const notread] error in more detail.
+
+[list_end][comment {-- result list elements --}]
+[list_end][comment {-- include-file signature --}]
+
+[enum] A plugin has to provide a single command, in the global
+ namespace, with the signature shown below. Plugins are allowed
+ to provide more commands of their own, but not less, and they
+ may not provide different semantics for the standardized
+ command.
+
+[list_begin definitions][comment {-- api command signatures --}]
+
+[call [cmd ::import] [arg text]]
+
+This command has to accept the a text containing a parsing expression
+grammar in some format. The result of the command has to be the result
+of the converter invoked by the plugin for the input grammar, the
+canonical serialization of the parsing expression grammar contained in
+the input.
+
+[list_begin arguments][comment {-- arguments --}]
+
+[arg_def string text]
+
+This argument will contain the parsing expression grammar for which to
+generate the serialization.
+
+The specification of what a [term canonical] serialization is can be
+found in the section [sectref {PEG serialization format}].
+
+[list_end][comment {-- arguments --}]
+[list_end][comment {-- api command signatures --}]
+
+[enum] A single usage cycle of a plugin consists of an invokation of
+ the command [cmd import]. This call has to leave the plugin in
+ a state where another usage cycle can be run without problems.
+
+[list_end][comment {-- plugin rules --}]
+
+[section Usage]
+
+To use a converter do
+
+[example {
+ # Get the converter (single command here, not class)
+ package require the-converter-package
+
+ # Perform the conversion
+ set serial [theconverter convert $thegrammartext]
+
+ ... process the result ...
+}]
+
+To use a plugin [var FOO] do
+
+[example {
+ # Get an import plugin manager
+ package require pt::peg::import
+ pt::peg::import I
+
+ # Run the plugin, and the converter inside.
+ set serial [I import serial $thegrammartext FOO]
+
+ ... process the result ...
+}]
+
+[include include/serial/pegrammar.inc]
+[include include/serial/pexpression.inc]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_introduction.man b/tcllib/modules/pt/pt_introduction.man
new file mode 100644
index 0000000..12e8a13
--- /dev/null
+++ b/tcllib/modules/pt/pt_introduction.man
@@ -0,0 +1,155 @@
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt_introduction n 1]
+[include include/module.inc]
+[titledesc {Introduction to Parser Tools}]
+[description]
+
+Welcome to the Parser Tools, a system for the creation and
+manipulation of parsers and the grammars driving them.
+
+[para]
+
+What are your goals which drove you here ?
+
+[list_begin enumerated]
+[enum]
+Do you simply wish to create a parser for some language ?
+
+[para]
+In that case have a look at our parser generator application,
+[cmd pt], or, for a slightly deeper access, the package underneath it,
+[package pt::pgen].
+
+[enum]
+Do you wish to know more about the architecture of the system ?
+
+[para]
+This is described in the section
+[sectref {Parser Tools Architecture}], below
+
+[enum]
+Is your interest in the theoretical background upon which the packages
+and tools are build ?
+
+[para]
+See the [manpage {Introduction to Parsing Expression Grammars}].
+
+[list_end]
+
+[section {Parser Tools Architecture}]
+
+The system can be split into roughly three layers, as seen in the
+figure below
+
+[para][image architecture][para]
+
+These layers are, from high to low:
+
+[list_begin enumerated]
+[enum]
+
+At the top we have the application and the packages using the packages
+of the layer below to implement common usecases. One example is the
+aforementioned [package pt::pgen] which provides a parser generator.
+
+[para]
+
+The list of packages belonging to this layer can be found in section
+[sectref {User Packages}]
+
+[enum]
+
+In this layer we have the packages which provide the core of the
+functionality for the whole system. They are, in essence, a set of
+blocks which can be combined in myriad ways, like Lego (tm). The
+packages in the previous level are 'just' pre-fabricated combinations
+to cover the most important use cases.
+
+[para]
+
+The list of packages belonging to this layer can be found in section
+[sectref {Core Packages}]
+
+[enum]
+
+Last, but not least is the layer containing support packages providing
+generic functionality which not necessarily belong into the module.
+
+[para]
+
+The list of packages belonging to this layer can be found in section
+[sectref {Support Packages}]
+
+[list_end]
+
+[subsection {User Packages}]
+[list_begin definitions]
+[def [package pt::pgen]]
+[list_end]
+
+[subsection {Core Packages}]
+
+This layer is further split into six sections handling the storage,
+import, export, transformation, and execution of grammars, plus
+grammar specific support packages.
+
+[list_begin definitions]
+[def Storage]
+[list_begin definitions][comment {----- core storage ---}]
+[def [package pt::peg::container]]
+[list_end][comment {------------------- core storage ---}]
+
+[def Export]
+[list_begin definitions][comment {----- core export ---}]
+[def [package pt::peg::export]]
+[def [package pt::peg::export::container]]
+[def [package pt::peg::export::json]]
+[def [package pt::peg::export::peg]]
+[def [package pt::peg::to::container]]
+[def [package pt::peg::to::json]]
+[def [package pt::peg::to::peg]]
+[def [package pt::peg::to::param]]
+[def [package pt::peg::to::tclparam]]
+[def [package pt::peg::to::cparam]]
+[list_end][comment {------------------- core export ---}]
+
+[def Import]
+[list_begin definitions][comment {----- core import ---}]
+[def [package pt::peg::import]]
+[def [package pt::peg::import::container]]
+[def [package pt::peg::import::json]]
+[def [package pt::peg::import::peg]]
+[def [package pt::peg::from::container]]
+[def [package pt::peg::from::json]]
+[def [package pt::peg::from::peg]]
+[list_end][comment {------------------- core import ---}]
+
+[def Transformation]
+[def Execution]
+[list_begin definitions][comment {----- core execution ---}]
+[def [package pt::peg::interp]]
+[def [package pt::rde]]
+[list_end][comment {------------------- core execution ---}]
+
+[def Support]
+[list_begin definitions][comment {----- core support ---}]
+[def [package pt::tclparam::configuration::snit]]
+[def [package pt::tclparam::configuration::tcloo]]
+[def [package pt::cparam::configuration::critcl]]
+[def [package pt::ast]]
+[def [package pt::pe]]
+[def [package pt::peg]]
+[list_end][comment {------------------- core support ---}]
+[list_end]
+
+[subsection {Support Packages}]
+[list_begin definitions]
+[def [package pt::peg::container::peg]]
+[def [package text::write]]
+[def [package configuration]]
+[def [package paths]]
+[def [package char]]
+[list_end]
+
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_json_language.man b/tcllib/modules/pt/pt_json_language.man
new file mode 100644
index 0000000..be4e599
--- /dev/null
+++ b/tcllib/modules/pt/pt_json_language.man
@@ -0,0 +1,13 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin pt::json_language n 1]
+[include include/module.inc]
+[titledesc {The JSON Grammar Exchange Format}]
+[description]
+[include include/ref_intro.inc]
+
+[include include/format/json_core.inc]
+
+[include include/serial/pegrammar.inc]
+[include include/serial/pexpression.inc]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_param.man b/tcllib/modules/pt/pt_param.man
new file mode 100644
index 0000000..c37601c
--- /dev/null
+++ b/tcllib/modules/pt/pt_param.man
@@ -0,0 +1,490 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin pt::param n 1]
+[keywords {virtual machine}]
+[include include/module.inc]
+[titledesc {PackRat Machine Specification}]
+[description]
+[include include/ref_intro.inc]
+
+Welcome to the PackRat Machine (short: [term PARAM]), a virtual
+machine geared towards the support of recursive descent parsers,
+especially packrat parsers. Towards this end it has features like the
+caching and reuse of partial results, the caching of the encountered
+input, and the ability to backtrack in both input and AST creation.
+
+[para]
+
+This document specifies the machine in terms of its architectural
+state and instruction set.
+
+[section {Architectural State}]
+
+Any PARAM implementation has to manage at least the following state:
+
+[list_begin definitions]
+[def "[term Input] (IN)"]
+
+This is the channel the characters to process are read from.
+[vset INS0 {Input Handling}][include include/param_1is.inc]
+
+[def "[term {Current Character}] (CC)"]
+
+The character from the [term input] currently tested against its
+possible alternatives.
+
+[vset INS0 {Character Processing}][include include/param_1is.inc]
+
+[def "[term {Current Location}] (CL)"]
+
+The location of the [term {current character}] in the [term input], as
+offset relative to the beginning of the input. Character offsets are
+counted from [const 0].
+
+[vset INS0 {Character Processing}]
+[vset INS1 {Location Handling}]
+[vset INS2 {Nonterminal Execution}][include include/param_3is.inc]
+
+[def "[term {Location Stack}] (LS)"]
+
+A stack of locations in the [term input], saved for possible
+backtracking.
+
+[vset INS0 {Character Processing}]
+[vset INS1 {Location Handling}]
+[vset INS2 {Nonterminal Execution}][include include/param_3is.inc]
+
+[def "[term Status] (ST)"]
+
+The status of the last attempt of testing the [term input], indicating
+either success or failure.
+
+[vset INS0 {Status Control}]
+[vset INS1 {Character Processing}]
+[vset INS2 {Nonterminal Execution}][include include/param_3is.inc]
+
+[def "[term {Semantic Value}] (SV)"]
+
+The current semantic value, either empty, or a node for AST
+constructed from the input.
+
+[vset INS0 {Value Construction}]
+[vset INS1 {AST Construction}][include include/param_2is.inc]
+
+[def "[term {AST Reduction Stack}] (ARS)"]
+
+The stack of partial ASTs constructed during the processing of
+nonterminal symbols.
+
+[vset INS0 {Value Construction}]
+[vset INS1 {AST Construction}][include include/param_2is.inc]
+
+[def "[term {AST Stack}] (AS)"]
+
+The stack of reduction stacks, saved for possible backtracking.
+
+[vset INS0 {Value Construction}]
+[vset INS1 {AST Construction}][include include/param_2is.inc]
+
+[def "[term {Error Status}] (ER)"]
+
+The machine's current knowledge of errors. This is either empty, or
+set to a pair of location in the input and the set of messages for
+that location.
+
+[para]
+[emph Note] that this part of the machine's state can be set even if
+the last test of the [term {current character}] was successful. For
+example, the *-operator (matching a sub-expression zero or more times)
+in a PEG is always successful, even if it encounters a problem further
+in the input and has to backtrack. Such problems must not be forgotten
+when continuing the parsing.
+
+[vset INS0 {Error Handling}]
+[vset INS1 {Character Processing}]
+[vset INS2 {Nonterminal Execution}][include include/param_3is.inc]
+
+[def "[term {Error Stack}] (ES)"]
+
+The stack of error stati, saved for backtracking. This enables the
+machine to merge current and older error stati when performing
+backtracking in choices after an failed match.
+
+[vset INS0 {Error Handling}]
+[vset INS1 {Character Processing}]
+[vset INS2 {Nonterminal Execution}][include include/param_3is.inc]
+
+[def "[term {Nonterminal Cache}] (NC)"]
+
+A cache of machine states keyed by pairs name of nonterminal symbol
+and location in the input. Each pair (N, L) is associated with a
+4-tuple holding the values to use for CL, ST, SV, and ER after the
+nonterminal N was parsed starting from the location L.
+
+It is a performance aid for backtracking parsers, allowing them to
+avoid an expensive reparsing of complex nonterminal symbols if they
+have been encountered before at a given location.
+
+[para]
+
+The key location is where machine started the attempt to match the
+named nonterminal symbol, and the location in the saved 4-tuple is
+where machine ended up after the attempt completed, independent of the
+success of the attempt.
+
+[vset INS0 {Nonterminal Execution}][include include/param_1is.inc]
+
+[def "[term {Terminal Cache}] (TC)"]
+
+A cache of characters read from IN, with their location in IN as pair
+of line and column, keyed by the location in IN, this time as
+character offset from the beginning of IN.
+
+It is a performance aid for backtracking parsers, allowing them to
+avoid a possibly expensive rereading of characters from IN, or even
+enabling backtracking at, i.e. in the case of IN not randomly
+seekable.
+
+[vset INS0 {Input Handling}][include include/param_1is.inc]
+
+[list_end]
+
+[section {Instruction Set}]
+
+With the machine's architectural state specified it is now possible to
+specify the instruction set operating on that state and to be
+implemented by any realization of the PARAM. The 37 instructions are
+grouped roughly by the state they influence and/or query during their
+execution.
+
+[subsection {Input Handling}]
+
+The instructions in this section mainly access IN, pulling the
+characters to process into the machine.
+
+[list_begin definitions]
+[def "[cmd input_next] [arg msg]"]
+
+This method reads the next character, i.e. the character after CL,
+from IN. If successful this character becomes CC, CL is advanced by
+one, ES is cleared, and the operation is recorded as a success in ST.
+
+[para]
+
+The operation may read the character from IN if the next character
+is not yet known to TC. If successful the new character is stored in
+TC, with its location (line, column), and the operation otherwise
+behaves as specified above. Future reads from the same location,
+possible due to backtracking, will then be satisfied from TC instead
+of IN.
+
+[para]
+
+If, on the other hand, the end of IN was reached, the operation is
+recorded as failed in ST, CL is left unchanged, and the pair of CL and
+[arg msg] becomes the new ES.
+
+[list_end]
+
+[subsection {Character Processing}]
+
+The instructions in this section mainly access CC, testing it against
+character classes, ranges, and individual characters.
+
+[list_begin definitions]
+
+[def [cmd test_alnum]]
+[vset OP alnum][include include/param_special.inc]
+
+[def [cmd test_alpha]]
+[vset OP alpha][include include/param_special.inc]
+
+[def [cmd test_ascii]]
+[vset OP ascii][include include/param_special.inc]
+
+[def "[cmd test_char] [arg char]"]
+
+This instruction implements the character matching operator, i.e. it
+checks if CC is [arg char].
+[include include/param_okfail.inc]
+
+[def [cmd test_ddigit]]
+[vset OP ddigit][include include/param_special.inc]
+
+[def [cmd test_digit]]
+[vset OP digit][include include/param_special.inc]
+
+[def [cmd test_graph]]
+[vset OP graph][include include/param_special.inc]
+
+[def [cmd test_lower]]
+[vset OP lower][include include/param_special.inc]
+
+[def [cmd test_print]]
+[vset OP print][include include/param_special.inc]
+
+[def [cmd test_punct]]
+[vset OP punct][include include/param_special.inc]
+
+[def "[cmd test_range] [arg chars] [arg chare]"]
+
+This instruction implements the range matching operator, i.e. it
+checks if CC falls into the interval of characters spanned up by the
+two characters from [arg chars] to [arg chare], both inclusive.
+[include include/param_okfail.inc]
+
+[def [cmd test_space]]
+[vset OP space][include include/param_special.inc]
+
+[def [cmd test_upper]]
+[vset OP upper][include include/param_special.inc]
+
+[def [cmd test_wordchar]]
+[vset OP wordchar][include include/param_special.inc]
+
+[def [cmd test_xdigit]]
+[vset OP xdigit][include include/param_special.inc]
+
+[list_end]
+
+[subsection {Error Handling}]
+
+The instructions in this section mainly access ER and ES.
+
+[list_begin definitions]
+
+[def [cmd error_clear]]
+
+This instruction clears ER.
+
+[def [cmd error_push]]
+
+This instruction makes a copy of ER and pushes it on ES.
+
+[def [cmd error_pop_merge]]
+
+This instruction takes the topmost entry of ES and merges the error
+status it contains with ES, making the result the new ES.
+
+[para]
+
+The merge is governed by four rules, with the merge result
+
+[list_begin enumerated][comment {---------------------------- merge rules ---}]
+[enum]
+Empty if both states are empty.
+
+[enum]
+The non-empty state if only one of the two states is non-empty.
+
+[enum]
+The state with the larger location, if the two states specify
+different locations.
+
+[enum]
+The pair of the location shared by the two states, and the set-union
+of their messages for states at the same location.
+
+[list_end][comment {----------------------------------------- merge rules ---}]
+
+[def "[cmd error_nonterminal] [arg symbol]"]
+
+This is a guarded instruction. It does nothing if either ES is empty,
+or if the location in ES is not just past the last location saved in
+LS. Otherwise it sets the pair of that location and the nonterminal
+[arg symbol] as the new ES.
+
+[para]
+[emph Note]: In the above "just past" means "that location plus one",
+or also "the location of the next character after that location".
+
+[list_end]
+
+[subsection {Status Control}]
+
+The instructions in this section directly manipulate ST.
+
+[list_begin definitions]
+
+[def [cmd status_ok]]
+
+This instruction sets ST to [const true], recording a success.
+
+[def [cmd status_fail]]
+
+This instruction sets ST to [const false], recording a failure.
+
+[def [cmd status_negate]]
+
+This instruction negates ST, turning a failure into a success and vice
+versa.
+
+[list_end]
+
+[subsection {Location Handling}]
+
+The instructions in this section access CL and LS.
+
+[list_begin definitions]
+
+[def [cmd loc_push]]
+
+This instruction makes a copy of CL and pushes it on LS.
+
+[def [cmd loc_pop_discard]]
+
+This instructions pops the last saved location from LS.
+
+[def [cmd loc_pop_rewind]]
+
+This instruction pops the last saved location from LS and restores it
+as CL.
+
+[list_end]
+
+[subsection {Nonterminal Execution}]
+
+The instructions in this section access and manipulate NC.
+
+[list_begin definitions]
+
+[def "[cmd symbol_restore] [arg symbol]"]
+
+This instruction checks if NC contains data for the nonterminal
+[arg symbol] at CL, or not. The result of the instruction is a boolean
+flag, with [const True] indicating that data was found in the
+cache. In that case the instruction has further updated the
+architectural state of the machine with the cached information, namely
+CL, ST, ER, and SV.
+
+[para]
+
+The method with which the instruction's result is transformed into
+control flow is left undefined and the responsibility of the
+implementation.
+
+[def "[cmd symbol_save] [arg symbol]"]
+
+This instructions saves the current settings of CL, ST, ER, and SV in
+NC, using the pair of nonterminal [arg symbol] and the last location
+saved in LS as key.
+
+[list_end]
+
+[subsection {Value Construction}]
+
+The instructions in this section manipulate SV.
+
+[list_begin definitions]
+[def [cmd value_clear]]
+
+This instruction clears SV.
+
+[def "[cmd value_leaf] [arg symbol]"]
+
+This instruction constructs an AST node for [arg symbol] covering the
+range of IN from one character after the last location saved on LS to
+CL and stores it in SV. ...
+
+[def "[cmd value_reduce] [arg symbol]"]
+
+This instruction generally behaves like [cmd value_nonterminal_leaf],
+except that it takes all AST nodes on ARS, if any, and makes them the
+children of the new node, with the last node saved on ARS becoming the
+right-most / last child. Note that ARS is not modfied by this
+operation.
+
+[list_end]
+
+[subsection {AST Construction}]
+
+The instructions in this section manipulate ARS and AS.
+
+[list_begin definitions]
+
+[def [cmd ast_value_push]]
+
+This instruction makes a copy of SV and pushes it on ARS.
+
+[def [cmd ast_push]]
+
+This instruction pushes the current state of ARS on AS and then clears
+ARS.
+
+[def [cmd ast_pop_rewind]]
+
+This instruction pops the last entry saved on AS and restores it as
+the new state of ARS.
+
+[def [cmd ast_pop_discard]]
+
+This instruction pops the last entry saved on AS.
+
+[list_end]
+
+[subsection {Control Flow}]
+
+Normally this section would contain the specifications of the control
+flow instructions of the PARAM, i.e. (un)conditional jumps and the
+like. However, this part of the PARAM is intentionally left
+unspecified. This allows the implementations to freely choose how to
+implement control flow.
+
+[para]
+
+The implementation of this machine in Parser Tools, i.e the package
+[package pt::rde], is not only coded in Tcl, but also relies on Tcl
+commands to provide it with control flow (instructions).
+
+[section {Interaction of the Instructions with the Architectural State}]
+
+[comment {-- in lieu of a true table markup --}]
+[example {
+Instruction Inputs Outputs
+======================= ======================= ====================
+ast_pop_discard AS -> AS
+ast_pop_rewind AS -> AS, ARS
+ast_push ARS, AS -> AS
+ast_value_push SV, ARS -> ARS
+======================= ======================= ====================
+error_clear - -> ER
+error_nonterminal sym ER, LS -> ER
+error_pop_merge ES, ER -> ER
+error_push ES, ER -> ES
+======================= ======================= ====================
+input_next msg IN -> TC, CL, CC, ST, ER
+======================= ======================= ====================
+loc_pop_discard LS -> LS
+loc_pop_rewind LS -> LS, CL
+loc_push CL, LS -> LS
+======================= ======================= ====================
+status_fail - -> ST
+status_negate ST -> ST
+status_ok - -> ST
+======================= ======================= ====================
+symbol_restore sym NC -> CL, ST, ER, SV
+symbol_save sym CL, ST, ER, SV LS -> NC
+======================= ======================= ====================
+test_alnum CC -> ST, ER
+test_alpha CC -> ST, ER
+test_ascii CC -> ST, ER
+test_char char CC -> ST, ER
+test_ddigit CC -> ST, ER
+test_digit CC -> ST, ER
+test_graph CC -> ST, ER
+test_lower CC -> ST, ER
+test_print CC -> ST, ER
+test_punct CC -> ST, ER
+test_range chars chare CC -> ST, ER
+test_space CC -> ST, ER
+test_upper CC -> ST, ER
+test_wordchar CC -> ST, ER
+test_xdigit CC -> ST, ER
+======================= ======================= ====================
+value_clear - -> SV
+value_leaf symbol LS, CL -> SV
+value_reduce symbol ARS, LS, CL -> SV
+======================= ======================= ====================
+}]
+
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_parse_peg.man b/tcllib/modules/pt/pt_parse_peg.man
new file mode 100644
index 0000000..c2f7299
--- /dev/null
+++ b/tcllib/modules/pt/pt_parse_peg.man
@@ -0,0 +1,38 @@
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt_parse_peg i 1]
+[include include/module.inc]
+[titledesc {Parser Tools PEG Parser}]
+[require pt::parse::peg 1]
+[description]
+[include include/ref_intro.inc]
+
+This package provides a class whose instances are parsers for parsing
+expression grammars in textual form.
+
+[section {Class API}]
+
+[list_begin definitions]
+[call [cmd pt::parse::peg] [opt [arg objectName]]]
+
+The class command constructs parser instances, i.e. objects. The
+result of the command is the fully-qualified name of the instance
+command.
+
+[para]
+
+If no [arg objectName] is specified the class will generate and use an
+automatic name. If the [arg objectName] was specified, but is not
+fully qualified the command will be created in the current namespace.
+
+[list_end]
+
+[section {Instances API}]
+
+All parser instances provide at least the methods shown below:
+
+[list_begin definitions]
+[include include/std_parser_object_api.inc]
+[list_end]
+
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_parse_peg.tcl b/tcllib/modules/pt/pt_parse_peg.tcl
new file mode 100644
index 0000000..13ccd75
--- /dev/null
+++ b/tcllib/modules/pt/pt_parse_peg.tcl
@@ -0,0 +1,180 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2009-2014 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# # ## ### ##### ######## ############# #####################
+## Package description
+
+## Implementation of a parser for PE grammars. We have multiple
+## implementations in Tcl (Snit-based), and C (Critcl-based). The
+## system will try to use the latter where possible.
+
+# @mdgen EXCLUDE: pt_parse_peg_c.tcl
+
+package require Tcl 8.5
+
+namespace eval ::pt::parse::peg {}
+
+# # ## ### ##### ######## ############# #####################
+## Management of stack implementations.
+
+# ::pt::parse::peg::LoadAccelerator --
+#
+# Loads a named implementation, if possible.
+#
+# Arguments:
+# key Name of the implementation to load.
+#
+# Results:
+# A boolean flag. True if the implementation
+# was successfully loaded; and False otherwise.
+
+proc ::pt::parse::peg::LoadAccelerator {key} {
+ variable accel
+ set r 0
+ switch -exact -- $key {
+ critcl {
+ if {![package vsatisfies [package provide Tcl] 8.5]} {return 0}
+ if {[catch {package require tcllibc}]} {return 0}
+ set r [llength [info commands ::pt::parse::peg_critcl]]
+ }
+ tcl {
+ variable selfdir
+ source [file join $selfdir pt_parse_peg_tcl.tcl]
+ set r 1
+ }
+ default {
+ return -code error "invalid accelerator/impl. package $key:\
+ must be one of [join [KnownImplementations] {, }]"
+ }
+ }
+ set accel($key) $r
+ return $r
+}
+
+# ::pt::parse::peg::SwitchTo --
+#
+# Activates a loaded named implementation.
+#
+# Arguments:
+# key Name of the implementation to activate.
+#
+# Results:
+# None.
+
+proc ::pt::parse::peg::SwitchTo {key} {
+ variable accel
+ variable loaded
+
+ if {$key eq $loaded} {
+ # No change, nothing to do.
+ return
+ } elseif {$key ne {}} {
+ # Validate the target implementation of the switch.
+
+ if {![info exists accel($key)]} {
+ return -code error "Unable to activate unknown implementation \"$key\""
+ } elseif {![info exists accel($key)] || !$accel($key)} {
+ return -code error "Unable to activate missing implementation \"$key\""
+ }
+ }
+
+ # Deactivate the previous implementation, if there was any.
+
+ if {$loaded ne {}} {
+ rename ::pt::parse::peg ::pt::parse::peg_$loaded
+ }
+
+ # Activate the new implementation, if there is any.
+
+ if {$key ne {}} {
+ rename ::pt::parse::peg_$key ::pt::parse::peg
+ }
+
+ # Remember the active implementation, for deactivation by future
+ # switches.
+
+ set loaded $key
+ return
+}
+
+# ::pt::parse::peg::Implementations --
+#
+# Determines which implementations are
+# present, i.e. loaded.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A list of implementation keys.
+
+proc ::pt::parse::peg::Implementations {} {
+ variable accel
+ set res {}
+ foreach n [array names accel] {
+ if {!$accel($n)} continue
+ lappend res $n
+ }
+ return $res
+}
+
+# ::pt::parse::peg::KnownImplementations --
+#
+# Determines which implementations are known
+# as possible implementations.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A list of implementation keys. In the order
+# of preference, most prefered first.
+
+proc ::pt::parse::peg::KnownImplementations {} {
+ return {critcl tcl}
+}
+
+proc ::pt::parse::peg::Names {} {
+ return {
+ critcl {tcllibc based}
+ tcl {pure Tcl}
+ }
+}
+
+# # ## ### ##### ######## ############# #####################
+## Initialization: Data structures.
+
+namespace eval ::pt::parse::peg {
+ variable selfdir [file dirname [info script]]
+ variable accel
+ array set accel {tcl 0 critcl 0}
+ variable loaded {}
+}
+
+# # ## ### ##### ######## ############# #####################
+
+## Initialization: Choose an implementation, the most prefered is
+## listed first. Loads only one of the possible implementations. And
+## activates it.
+
+namespace eval ::pt::parse::peg {
+ variable e
+ foreach e [KnownImplementations] {
+ if {[LoadAccelerator $e]} {
+ SwitchTo $e
+ break
+ }
+ }
+ unset e
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+namespace eval ::pt {
+ # Export the constructor command.
+ namespace export rde
+}
+
+package provide pt::parse::peg 1.0.1
diff --git a/tcllib/modules/pt/pt_parse_peg.test b/tcllib/modules/pt/pt_parse_peg.test
new file mode 100644
index 0000000..d64809b
--- /dev/null
+++ b/tcllib/modules/pt/pt_parse_peg.test
@@ -0,0 +1,83 @@
+# -*- tcl -*-
+# pt_parse_peg.test: tests for the pt::parse::peg peg parsing package.
+#
+# Copyright (c) 2010 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_parse_peg.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/stack.tcl struct::stack ; # User: pt::rde
+ TestAccelInit struct::stack ; # (tcl)
+
+ use snit/snit.tcl snit
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_astree.tcl pt::ast
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal pt_peg_container.tcl pt::peg::container
+
+ useAccel [useTcllibC] pt/pt_rdengine.tcl pt::rde ; # User: pt::parse::peg
+ TestAccelInit pt::rde ; # or: pt:peg::interp
+
+ # Get the parser used by the converter, either the grammar
+ # interpreter, or snit-based and spcialized to PEG.
+ #useLocal pt_peg_container_peg.tcl pt::peg::container::peg
+ #useLocal pt_peg_interp.tcl pt::peg::interp
+
+ source [localPath tests/common]
+}
+testing {
+ useAccel [useTcllibC] pt/pt_parse_peg.tcl pt::parse::peg ; # User: pt::peg::from::peg
+ TestAccelInit pt::parse::peg
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+# Note: When using pt::rde's C implementation struct::stack is not
+# used, and its implementation of no relevance.
+#
+# Similarly, when pt::parse::peg's C implementation is used
+# neither pt::rde's, nor struct::stack's implementations are of
+# relevance.
+
+TestAccelDo pt::parse::peg parseimpl {
+ if {$parseimpl eq "critcl"} {
+ set rdeimpl n/a
+ set stackimpl n/a
+ pt::rde::SwitchTo {}
+ struct::stack::SwitchTo {}
+ source [localPath tests/pt_parse_peg.tests]
+ } else {
+ TestAccelDo pt::rde rdeimpl {
+ if {$rdeimpl eq "critcl"} {
+ set stackimpl n/a
+ struct::stack::SwitchTo {}
+ source [localPath tests/pt_parse_peg.tests]
+ } else {
+ TestAccelDo struct::stack stackimpl {
+ source [localPath tests/pt_parse_peg.tests]
+ }
+ }
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+TestAccelExit pt::parse::peg
+TestAccelExit pt::rde
+TestAccelExit struct::stack
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_parse_peg_c.tcl b/tcllib/modules/pt/pt_parse_peg_c.tcl
new file mode 100644
index 0000000..dd214f6
--- /dev/null
+++ b/tcllib/modules/pt/pt_parse_peg_c.tcl
@@ -0,0 +1,4995 @@
+## -*- tcl -*-
+##
+## Critcl-based C/PARAM implementation of the parsing
+## expression grammar
+##
+## PEG
+##
+## Generated from file 3_peg_itself
+## for user aku
+##
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.4
+package require critcl
+# @sak notprovided pt_parse_peg_c
+package provide pt_parse_peg_c 1.0.1
+
+# Note: The implementation of the PARAM virtual machine
+# underlying the C/PARAM code used below is inlined
+# into the generated parser, allowing for direct access
+# and manipulation of the RDE state, instead of having
+# to dispatch through the Tcl interpreter.
+
+# # ## ### ##### ######## ############# #####################
+##
+
+namespace eval ::pt::parse {
+ # # ## ### ##### ######## ############# #####################
+ ## Supporting code for the main command.
+
+ catch {
+ #critcl::cflags -g
+ #critcl::debug memory symbols
+ }
+
+ # # ## ### ###### ######## #############
+ ## RDE runtime, inlined, and made static.
+
+ # This is the C code for the RDE, i.e. the implementation
+ # of pt::rde. Only the low-level engine is imported, the
+ # Tcl interface layer is ignored. This generated parser
+ # provides its own layer for that.
+
+ critcl::ccode {
+ /* -*- c -*- */
+
+ #include <string.h>
+ #define SCOPE static
+
+#line 1 "rde_critcl/util.h"
+
+ #ifndef _RDE_UTIL_H
+ #define _RDE_UTIL_H 1
+ #ifndef SCOPE
+ #define SCOPE
+ #endif
+ #define ALLOC(type) (type *) ckalloc (sizeof (type))
+ #define NALLOC(n,type) (type *) ckalloc ((n) * sizeof (type))
+ #undef RDE_DEBUG
+ #define RDE_DEBUG 1
+ #undef RDE_TRACE
+ #ifdef RDE_DEBUG
+ #define STOPAFTER(x) { static int count = (x); count --; if (!count) { Tcl_Panic ("stop"); } }
+ #define XSTR(x) #x
+ #define STR(x) XSTR(x)
+ #define RANGEOK(i,n) ((0 <= (i)) && (i < (n)))
+ #define ASSERT(x,msg) if (!(x)) { Tcl_Panic (msg " (" #x "), in file " __FILE__ " @line " STR(__LINE__));}
+ #define ASSERT_BOUNDS(i,n) ASSERT (RANGEOK(i,n),"array index out of bounds: " STR(i) " >= " STR(n))
+ #else
+ #define STOPAFTER(x)
+ #define ASSERT(x,msg)
+ #define ASSERT_BOUNDS(i,n)
+ #endif
+ #ifdef RDE_TRACE
+ SCOPE void trace_enter (const char* fun);
+ SCOPE void trace_return (const char *pat, ...);
+ SCOPE void trace_printf (const char *pat, ...);
+ #define ENTER(fun) trace_enter (fun)
+ #define RETURN(format,x) trace_return (format,x) ; return x
+ #define RETURNVOID trace_return ("%s","(void)") ; return
+ #define TRACE0(x) trace_printf0 x
+ #define TRACE(x) trace_printf x
+ #else
+ #define ENTER(fun)
+ #define RETURN(f,x) return x
+ #define RETURNVOID return
+ #define TRACE0(x)
+ #define TRACE(x)
+ #endif
+ #endif
+
+
+#line 1 "rde_critcl/stack.h"
+
+ #ifndef _RDE_DS_STACK_H
+ #define _RDE_DS_STACK_H 1
+ typedef void (*RDE_STACK_CELL_FREE) (void* cell);
+ typedef struct RDE_STACK_* RDE_STACK;
+ static const int RDE_STACK_INITIAL_SIZE = 256;
+ #endif
+
+
+#line 1 "rde_critcl/tc.h"
+
+ #ifndef _RDE_DS_TC_H
+ #define _RDE_DS_TC_H 1
+ typedef struct RDE_TC_* RDE_TC;
+ #endif
+
+
+#line 1 "rde_critcl/param.h"
+
+ #ifndef _RDE_DS_PARAM_H
+ #define _RDE_DS_PARAM_H 1
+ typedef struct RDE_PARAM_* RDE_PARAM;
+ typedef struct ERROR_STATE {
+ int refCount;
+ long int loc;
+ RDE_STACK msg;
+ } ERROR_STATE;
+ typedef struct NC_STATE {
+ long int CL;
+ long int ST;
+ Tcl_Obj* SV;
+ ERROR_STATE* ER;
+ } NC_STATE;
+ #endif
+
+
+#line 1 "rde_critcl/util.c"
+
+ #ifdef RDE_TRACE
+ typedef struct F_STACK {
+ const char* str;
+ struct F_STACK* down;
+ } F_STACK;
+ static F_STACK* top = 0;
+ static int level = 0;
+ static void
+ push (const char* str)
+ {
+ F_STACK* new = ALLOC (F_STACK);
+ new->str = str;
+ new->down = top;
+ top = new;
+ level += 4;
+ }
+ static void
+ pop (void)
+ {
+ F_STACK* next = top->down;
+ level -= 4;
+ ckfree ((char*)top);
+ top = next;
+ }
+ static void
+ indent (void)
+ {
+ int i;
+ for (i = 0; i < level; i++) {
+ fwrite(" ", 1, 1, stdout);
+ fflush (stdout);
+ }
+ if (top) {
+ fwrite(top->str, 1, strlen(top->str), stdout);
+ fflush (stdout);
+ }
+ fwrite(" ", 1, 1, stdout);
+ fflush (stdout);
+ }
+ SCOPE void
+ trace_enter (const char* fun)
+ {
+ push (fun);
+ indent();
+ fwrite("ENTER\n", 1, 6, stdout);
+ fflush (stdout);
+ }
+ static char msg [1024*1024];
+ SCOPE void
+ trace_return (const char *pat, ...)
+ {
+ int len;
+ va_list args;
+ indent();
+ fwrite("RETURN = ", 1, 9, stdout);
+ fflush (stdout);
+ va_start(args, pat);
+ len = vsprintf(msg, pat, args);
+ va_end(args);
+ msg[len++] = '\n';
+ msg[len] = '\0';
+ fwrite(msg, 1, len, stdout);
+ fflush (stdout);
+ pop();
+ }
+ SCOPE void
+ trace_printf (const char *pat, ...)
+ {
+ int len;
+ va_list args;
+ indent();
+ va_start(args, pat);
+ len = vsprintf(msg, pat, args);
+ va_end(args);
+ msg[len++] = '\n';
+ msg[len] = '\0';
+ fwrite(msg, 1, len, stdout);
+ fflush (stdout);
+ }
+ SCOPE void
+ trace_printf0 (const char *pat, ...)
+ {
+ int len;
+ va_list args;
+ va_start(args, pat);
+ len = vsprintf(msg, pat, args);
+ va_end(args);
+ msg[len++] = '\n';
+ msg[len] = '\0';
+ fwrite(msg, 1, len, stdout);
+ fflush (stdout);
+ }
+ #endif
+
+
+#line 1 "rde_critcl/stack.c"
+
+ typedef struct RDE_STACK_ {
+ long int max;
+ long int top;
+ RDE_STACK_CELL_FREE freeCellProc;
+ void** cell;
+ } RDE_STACK_;
+
+ SCOPE RDE_STACK
+ rde_stack_new (RDE_STACK_CELL_FREE freeCellProc)
+ {
+ RDE_STACK s = ALLOC (RDE_STACK_);
+ s->cell = NALLOC (RDE_STACK_INITIAL_SIZE, void*);
+ s->max = RDE_STACK_INITIAL_SIZE;
+ s->top = 0;
+ s->freeCellProc = freeCellProc;
+ return s;
+ }
+ SCOPE void
+ rde_stack_del (RDE_STACK s)
+ {
+ if (s->freeCellProc && s->top) {
+ long int i;
+ for (i=0; i < s->top; i++) {
+ ASSERT_BOUNDS(i,s->max);
+ s->freeCellProc ( s->cell [i] );
+ }
+ }
+ ckfree ((char*) s->cell);
+ ckfree ((char*) s);
+ }
+ SCOPE void
+ rde_stack_push (RDE_STACK s, void* item)
+ {
+ if (s->top >= s->max) {
+ long int new = s->max ? (2 * s->max) : RDE_STACK_INITIAL_SIZE;
+ void** cell = (void**) ckrealloc ((char*) s->cell, new * sizeof(void*));
+ ASSERT (cell,"Memory allocation failure for RDE stack");
+ s->max = new;
+ s->cell = cell;
+ }
+ ASSERT_BOUNDS(s->top,s->max);
+ s->cell [s->top] = item;
+ s->top ++;
+ }
+ SCOPE void*
+ rde_stack_top (RDE_STACK s)
+ {
+ ASSERT_BOUNDS(s->top-1,s->max);
+ return s->cell [s->top - 1];
+ }
+ SCOPE void
+ rde_stack_pop (RDE_STACK s, long int n)
+ {
+ ASSERT (n >= 0, "Bad pop count");
+ if (n == 0) return;
+ if (s->freeCellProc) {
+ while (n) {
+ s->top --;
+ ASSERT_BOUNDS(s->top,s->max);
+ s->freeCellProc ( s->cell [s->top] );
+ n --;
+ }
+ } else {
+ s->top -= n;
+ }
+ }
+ SCOPE void
+ rde_stack_trim (RDE_STACK s, long int n)
+ {
+ ASSERT (n >= 0, "Bad trimsize");
+ if (s->freeCellProc) {
+ while (s->top > n) {
+ s->top --;
+ ASSERT_BOUNDS(s->top,s->max);
+ s->freeCellProc ( s->cell [s->top] );
+ }
+ } else {
+ s->top = n;
+ }
+ }
+ SCOPE void
+ rde_stack_drop (RDE_STACK s, long int n)
+ {
+ ASSERT (n >= 0, "Bad pop count");
+ if (n == 0) return;
+ s->top -= n;
+ }
+ SCOPE void
+ rde_stack_move (RDE_STACK dst, RDE_STACK src)
+ {
+ ASSERT (dst->freeCellProc == src->freeCellProc, "Ownership mismatch");
+
+ while (src->top > 0) {
+ src->top --;
+ ASSERT_BOUNDS(src->top,src->max);
+ rde_stack_push (dst, src->cell [src->top] );
+ }
+ }
+ SCOPE void
+ rde_stack_get (RDE_STACK s, long int* cn, void*** cc)
+ {
+ *cn = s->top;
+ *cc = s->cell;
+ }
+ SCOPE long int
+ rde_stack_size (RDE_STACK s)
+ {
+ return s->top;
+ }
+
+
+#line 1 "rde_critcl/tc.c"
+
+ typedef struct RDE_TC_ {
+ int max;
+ int num;
+ char* str;
+ RDE_STACK off;
+ } RDE_TC_;
+
+ SCOPE RDE_TC
+ rde_tc_new (void)
+ {
+ RDE_TC tc = ALLOC (RDE_TC_);
+ tc->max = RDE_STACK_INITIAL_SIZE;
+ tc->num = 0;
+ tc->str = NALLOC (RDE_STACK_INITIAL_SIZE, char);
+ tc->off = rde_stack_new (NULL);
+ return tc;
+ }
+ SCOPE void
+ rde_tc_del (RDE_TC tc)
+ {
+ rde_stack_del (tc->off);
+ ckfree (tc->str);
+ ckfree ((char*) tc);
+ }
+ SCOPE long int
+ rde_tc_size (RDE_TC tc)
+ {
+ return rde_stack_size (tc->off);
+ }
+ SCOPE void
+ rde_tc_clear (RDE_TC tc)
+ {
+ tc->num = 0;
+ rde_stack_trim (tc->off, 0);
+ }
+ SCOPE char*
+ rde_tc_append (RDE_TC tc, char* string, long int len)
+ {
+ long int base = tc->num;
+ long int off = tc->num;
+ char* ch;
+ int clen;
+ Tcl_UniChar uni;
+ if (len < 0) {
+ len = strlen (string);
+ }
+
+ if (!len) {
+ return tc->str + base;
+ }
+
+ if ((tc->num + len) >= tc->max) {
+ int new = len + (tc->max ? (2 * tc->max) : RDE_STACK_INITIAL_SIZE);
+ char* str = ckrealloc (tc->str, new * sizeof(char));
+ ASSERT (str,"Memory allocation failure for token character array");
+ tc->max = new;
+ tc->str = str;
+ }
+ tc->num += len;
+ ASSERT_BOUNDS(tc->num,tc->max);
+ ASSERT_BOUNDS(off,tc->max);
+ ASSERT_BOUNDS(off+len-1,tc->max);
+ ASSERT_BOUNDS(off+len-1,tc->num);
+ memcpy (tc->str + off, string, len);
+
+ ch = string;
+ while (ch < (string + len)) {
+ ASSERT_BOUNDS(off,tc->num);
+ rde_stack_push (tc->off, (void*) off);
+ clen = Tcl_UtfToUniChar (ch, &uni);
+ off += clen;
+ ch += clen;
+ }
+ return tc->str + base;
+ }
+ SCOPE void
+ rde_tc_get (RDE_TC tc, int at, char** ch, long int* len)
+ {
+ long int oc, off, top, end;
+ void** ov;
+ rde_stack_get (tc->off, &oc, &ov);
+ ASSERT_BOUNDS(at,oc);
+ off = (long int) ov [at];
+ if ((at+1) == oc) {
+ end = tc->num;
+ } else {
+ end = (long int) ov [at+1];
+ }
+ TRACE (("rde_tc_get (RDE_TC %p, @ %d) => %d.[%d ... %d]/%d",tc,at,end-off,off,end-1,tc->num));
+ ASSERT_BOUNDS(off,tc->num);
+ ASSERT_BOUNDS(end-1,tc->num);
+ *ch = tc->str + off;
+ *len = end - off;
+ }
+ SCOPE void
+ rde_tc_get_s (RDE_TC tc, int at, int last, char** ch, long int* len)
+ {
+ long int oc, off, top, end;
+ void** ov;
+ rde_stack_get (tc->off, &oc, &ov);
+ ASSERT_BOUNDS(at,oc);
+ ASSERT_BOUNDS(last,oc);
+ off = (long int) ov [at];
+ if ((last+1) == oc) {
+ end = tc->num;
+ } else {
+ end = (long int) ov [last+1];
+ }
+ TRACE (("rde_tc_get_s (RDE_TC %p, @ %d .. %d) => %d.[%d ... %d]/%d",tc,at,last,end-off,off,end-1,tc->num));
+ ASSERT_BOUNDS(off,tc->num);
+ ASSERT_BOUNDS(end-1,tc->num);
+ *ch = tc->str + off;
+ *len = end - off;
+ }
+
+
+#line 1 "rde_critcl/param.c"
+
+ typedef struct RDE_PARAM_ {
+ Tcl_Channel IN;
+ Tcl_Obj* readbuf;
+ char* CC;
+ long int CC_len;
+ RDE_TC TC;
+ long int CL;
+ RDE_STACK LS;
+ ERROR_STATE* ER;
+ RDE_STACK ES;
+ long int ST;
+ Tcl_Obj* SV;
+ Tcl_HashTable NC;
+
+ RDE_STACK ast ;
+ RDE_STACK mark ;
+
+ long int numstr;
+ char** string;
+
+ ClientData clientData;
+ } RDE_PARAM_;
+ typedef int (*UniCharClass) (int);
+ typedef enum test_class_id {
+ tc_alnum,
+ tc_alpha,
+ tc_ascii,
+ tc_control,
+ tc_ddigit,
+ tc_digit,
+ tc_graph,
+ tc_lower,
+ tc_printable,
+ tc_punct,
+ tc_space,
+ tc_upper,
+ tc_wordchar,
+ tc_xdigit
+ } test_class_id;
+ static void ast_node_free (void* n);
+ static void error_state_free (void* es);
+ static void error_set (RDE_PARAM p, long int s);
+ static void nc_clear (RDE_PARAM p);
+ static int UniCharIsAscii (int character);
+ static int UniCharIsHexDigit (int character);
+ static int UniCharIsDecDigit (int character);
+ static void test_class (RDE_PARAM p, UniCharClass class, test_class_id id);
+ static int er_int_compare (const void* a, const void* b);
+ #define SV_INIT(p) \
+ p->SV = NULL; \
+ TRACE (("SV_INIT (%p => %p)", (p), (p)->SV))
+ #define SV_SET(p,newsv) \
+ if (((p)->SV) != (newsv)) { \
+ TRACE (("SV_CLEAR/set (%p => %p)", (p), (p)->SV)); \
+ if ((p)->SV) { \
+ Tcl_DecrRefCount ((p)->SV); \
+ } \
+ (p)->SV = (newsv); \
+ TRACE (("SV_SET (%p => %p)", (p), (p)->SV)); \
+ if ((p)->SV) { \
+ Tcl_IncrRefCount ((p)->SV); \
+ } \
+ }
+ #define SV_CLEAR(p) \
+ TRACE (("SV_CLEAR (%p => %p)", (p), (p)->SV)); \
+ if ((p)->SV) { \
+ Tcl_DecrRefCount ((p)->SV); \
+ } \
+ (p)->SV = NULL
+ #define ER_INIT(p) \
+ p->ER = NULL; \
+ TRACE (("ER_INIT (%p => %p)", (p), (p)->ER))
+ #define ER_CLEAR(p) \
+ error_state_free ((p)->ER); \
+ (p)->ER = NULL
+ SCOPE RDE_PARAM
+ rde_param_new (long int nstr, char** strings)
+ {
+ RDE_PARAM p;
+ ENTER ("rde_param_new");
+ TRACE (("\tINT %d strings @ %p", nstr, strings));
+ p = ALLOC (RDE_PARAM_);
+ p->numstr = nstr;
+ p->string = strings;
+ p->readbuf = Tcl_NewObj ();
+ Tcl_IncrRefCount (p->readbuf);
+ TRACE (("\tTcl_Obj* readbuf %p used %d", p->readbuf,p->readbuf->refCount));
+ Tcl_InitHashTable (&p->NC, TCL_ONE_WORD_KEYS);
+ p->IN = NULL;
+ p->CL = -1;
+ p->ST = 0;
+ ER_INIT (p);
+ SV_INIT (p);
+ p->CC = NULL;
+ p->CC_len = 0;
+ p->TC = rde_tc_new ();
+ p->ES = rde_stack_new (error_state_free);
+ p->LS = rde_stack_new (NULL);
+ p->ast = rde_stack_new (ast_node_free);
+ p->mark = rde_stack_new (NULL);
+ RETURN ("%p", p);
+ }
+ SCOPE void
+ rde_param_del (RDE_PARAM p)
+ {
+ ENTER ("rde_param_del");
+ TRACE (("RDE_PARAM %p",p));
+ ER_CLEAR (p); TRACE (("\ter_clear"));
+ SV_CLEAR (p); TRACE (("\tsv_clear"));
+ nc_clear (p); TRACE (("\tnc_clear"));
+ Tcl_DeleteHashTable (&p->NC); TRACE (("\tnc hashtable delete"));
+ rde_tc_del (p->TC); TRACE (("\ttc clear"));
+ rde_stack_del (p->ES); TRACE (("\tes clear"));
+ rde_stack_del (p->LS); TRACE (("\tls clear"));
+ rde_stack_del (p->ast); TRACE (("\tast clear"));
+ rde_stack_del (p->mark); TRACE (("\tmark clear"));
+ TRACE (("\tTcl_Obj* readbuf %p used %d", p->readbuf,p->readbuf->refCount));
+ Tcl_DecrRefCount (p->readbuf);
+ ckfree ((char*) p);
+ RETURNVOID;
+ }
+ SCOPE void
+ rde_param_reset (RDE_PARAM p, Tcl_Channel chan)
+ {
+ ENTER ("rde_param_reset");
+ TRACE (("RDE_PARAM %p",p));
+ TRACE (("Tcl_Channel %p",chan));
+ p->IN = chan;
+ p->CL = -1;
+ p->ST = 0;
+ p->CC = NULL;
+ p->CC_len = 0;
+ ER_CLEAR (p);
+ SV_CLEAR (p);
+ nc_clear (p);
+ rde_tc_clear (p->TC);
+ rde_stack_trim (p->ES, 0);
+ rde_stack_trim (p->LS, 0);
+ rde_stack_trim (p->ast, 0);
+ rde_stack_trim (p->mark, 0);
+ TRACE (("\tTcl_Obj* readbuf %p used %d", p->readbuf,p->readbuf->refCount));
+ RETURNVOID;
+ }
+ SCOPE void
+ rde_param_update_strings (RDE_PARAM p, long int nstr, char** strings)
+ {
+ ENTER ("rde_param_update_strings");
+ TRACE (("RDE_PARAM %p", p));
+ TRACE (("INT %d strings", nstr));
+ p->numstr = nstr;
+ p->string = strings;
+ RETURNVOID;
+ }
+ SCOPE void
+ rde_param_data (RDE_PARAM p, char* buf, long int len)
+ {
+ (void) rde_tc_append (p->TC, buf, len);
+ }
+ SCOPE void
+ rde_param_clientdata (RDE_PARAM p, ClientData clientData)
+ {
+ p->clientData = clientData;
+ }
+ static void
+ nc_clear (RDE_PARAM p)
+ {
+ Tcl_HashSearch hs;
+ Tcl_HashEntry* he;
+ Tcl_HashTable* tablePtr;
+ for(he = Tcl_FirstHashEntry(&p->NC, &hs);
+ he != NULL;
+ he = Tcl_FirstHashEntry(&p->NC, &hs)) {
+ Tcl_HashSearch hsc;
+ Tcl_HashEntry* hec;
+ tablePtr = (Tcl_HashTable*) Tcl_GetHashValue (he);
+ for(hec = Tcl_FirstHashEntry(tablePtr, &hsc);
+ hec != NULL;
+ hec = Tcl_NextHashEntry(&hsc)) {
+ NC_STATE* scs = Tcl_GetHashValue (hec);
+ error_state_free (scs->ER);
+ if (scs->SV) { Tcl_DecrRefCount (scs->SV); }
+ ckfree ((char*) scs);
+ }
+ Tcl_DeleteHashTable (tablePtr);
+ ckfree ((char*) tablePtr);
+ Tcl_DeleteHashEntry (he);
+ }
+ }
+ SCOPE ClientData
+ rde_param_query_clientdata (RDE_PARAM p)
+ {
+ return p->clientData;
+ }
+ SCOPE void
+ rde_param_query_amark (RDE_PARAM p, long int* mc, void*** mv)
+ {
+ rde_stack_get (p->mark, mc, mv);
+ }
+ SCOPE void
+ rde_param_query_ast (RDE_PARAM p, long int* ac, Tcl_Obj*** av)
+ {
+ rde_stack_get (p->ast, ac, (void***) av);
+ }
+ SCOPE const char*
+ rde_param_query_in (RDE_PARAM p)
+ {
+ return p->IN
+ ? Tcl_GetChannelName (p->IN)
+ : "";
+ }
+ SCOPE const char*
+ rde_param_query_cc (RDE_PARAM p, long int* len)
+ {
+ *len = p->CC_len;
+ return p->CC;
+ }
+ SCOPE int
+ rde_param_query_cl (RDE_PARAM p)
+ {
+ return p->CL;
+ }
+ SCOPE const ERROR_STATE*
+ rde_param_query_er (RDE_PARAM p)
+ {
+ return p->ER;
+ }
+ SCOPE Tcl_Obj*
+ rde_param_query_er_tcl (RDE_PARAM p, const ERROR_STATE* er)
+ {
+ Tcl_Obj* res;
+ if (!er) {
+
+ res = Tcl_NewStringObj ("", 0);
+ } else {
+ Tcl_Obj* ov [2];
+ Tcl_Obj** mov;
+ long int mc, i, j;
+ void** mv;
+ int lastid;
+ const char* msg;
+ rde_stack_get (er->msg, &mc, &mv);
+
+ qsort (mv, mc, sizeof (void*), er_int_compare);
+
+ mov = NALLOC (mc, Tcl_Obj*);
+ lastid = -1;
+ for (i=0, j=0; i < mc; i++) {
+ ASSERT_BOUNDS (i,mc);
+ if (((long int) mv [i]) == lastid) continue;
+ lastid = (long int) mv [i];
+ ASSERT_BOUNDS((long int) mv[i],p->numstr);
+ msg = p->string [(long int) mv[i]];
+ ASSERT_BOUNDS (j,mc);
+ mov [j] = Tcl_NewStringObj (msg, -1);
+ j++;
+ }
+
+ ov [0] = Tcl_NewIntObj (er->loc);
+ ov [1] = Tcl_NewListObj (j, mov);
+ res = Tcl_NewListObj (2, ov);
+ ckfree ((char*) mov);
+ }
+ return res;
+ }
+ SCOPE void
+ rde_param_query_es (RDE_PARAM p, long int* ec, ERROR_STATE*** ev)
+ {
+ rde_stack_get (p->ES, ec, (void***) ev);
+ }
+ SCOPE void
+ rde_param_query_ls (RDE_PARAM p, long int* lc, void*** lv)
+ {
+ rde_stack_get (p->LS, lc, lv);
+ }
+ SCOPE long int
+ rde_param_query_lstop (RDE_PARAM p)
+ {
+ return (long int) rde_stack_top (p->LS);
+ }
+ SCOPE Tcl_HashTable*
+ rde_param_query_nc (RDE_PARAM p)
+ {
+ return &p->NC;
+ }
+ SCOPE int
+ rde_param_query_st (RDE_PARAM p)
+ {
+ return p->ST;
+ }
+ SCOPE Tcl_Obj*
+ rde_param_query_sv (RDE_PARAM p)
+ {
+ TRACE (("SV_QUERY %p => (%p)", (p), (p)->SV)); \
+ return p->SV;
+ }
+ SCOPE long int
+ rde_param_query_tc_size (RDE_PARAM p)
+ {
+ return rde_tc_size (p->TC);
+ }
+ SCOPE void
+ rde_param_query_tc_get_s (RDE_PARAM p, long int at, long int last, char** ch, long int* len)
+ {
+ rde_tc_get_s (p->TC, at, last, ch, len);
+ }
+ SCOPE const char*
+ rde_param_query_string (RDE_PARAM p, long int id)
+ {
+ TRACE (("rde_param_query_string (RDE_PARAM %p, %d/%d)", p, id, p->numstr));
+ ASSERT_BOUNDS(id,p->numstr);
+ return p->string [id];
+ }
+ SCOPE void
+ rde_param_i_ast_pop_discard (RDE_PARAM p)
+ {
+ rde_stack_pop (p->mark, 1);
+ }
+ SCOPE void
+ rde_param_i_ast_pop_rewind (RDE_PARAM p)
+ {
+ long int trim = (long int) rde_stack_top (p->mark);
+ ENTER ("rde_param_i_ast_pop_rewind");
+ TRACE (("RDE_PARAM %p",p));
+ rde_stack_pop (p->mark, 1);
+ rde_stack_trim (p->ast, trim);
+ TRACE (("SV = (%p rc%d '%s')",
+ p->SV,
+ p->SV ? p->SV->refCount : -1,
+ p->SV ? Tcl_GetString (p->SV) : ""));
+ RETURNVOID;
+ }
+ SCOPE void
+ rde_param_i_ast_rewind (RDE_PARAM p)
+ {
+ long int trim = (long int) rde_stack_top (p->mark);
+ ENTER ("rde_param_i_ast_rewind");
+ TRACE (("RDE_PARAM %p",p));
+ rde_stack_trim (p->ast, trim);
+ TRACE (("SV = (%p rc%d '%s')",
+ p->SV,
+ p->SV ? p->SV->refCount : -1,
+ p->SV ? Tcl_GetString (p->SV) : ""));
+ RETURNVOID;
+ }
+ SCOPE void
+ rde_param_i_ast_push (RDE_PARAM p)
+ {
+ rde_stack_push (p->mark, (void*) rde_stack_size (p->ast));
+ }
+ SCOPE void
+ rde_param_i_ast_value_push (RDE_PARAM p)
+ {
+ ENTER ("rde_param_i_ast_value_push");
+ TRACE (("RDE_PARAM %p",p));
+ ASSERT(p->SV,"Unable to push undefined semantic value");
+ TRACE (("rde_param_i_ast_value_push %p => (%p)", p, p->SV));
+ TRACE (("SV = (%p rc%d '%s')", p->SV, p->SV->refCount, Tcl_GetString (p->SV)));
+ rde_stack_push (p->ast, p->SV);
+ Tcl_IncrRefCount (p->SV);
+ RETURNVOID;
+ }
+ static void
+ ast_node_free (void* n)
+ {
+ Tcl_DecrRefCount ((Tcl_Obj*) n);
+ }
+ SCOPE void
+ rde_param_i_error_clear (RDE_PARAM p)
+ {
+ ER_CLEAR (p);
+ }
+ SCOPE void
+ rde_param_i_error_nonterminal (RDE_PARAM p, long int s)
+ {
+
+ return;
+#if 0
+ long int pos;
+ if (!p->ER) return;
+ pos = 1 + (long int) rde_stack_top (p->LS);
+ if (p->ER->loc != pos) return;
+ error_set (p, s);
+ p->ER->loc = pos;
+#endif
+ }
+ SCOPE void
+ rde_param_i_error_pop_merge (RDE_PARAM p)
+ {
+ ERROR_STATE* top = (ERROR_STATE*) rde_stack_top (p->ES);
+
+ if (top == p->ER) {
+ rde_stack_pop (p->ES, 1);
+ return;
+ }
+
+ if (!top) {
+ rde_stack_pop (p->ES, 1);
+ return;
+ }
+
+ if (!p->ER) {
+ rde_stack_drop (p->ES, 1);
+ p->ER = top;
+
+ return;
+ }
+
+ if (top->loc < p->ER->loc) {
+ rde_stack_pop (p->ES, 1);
+ return;
+ }
+
+ if (top->loc > p->ER->loc) {
+ rde_stack_drop (p->ES, 1);
+ error_state_free (p->ER);
+ p->ER = top;
+
+ return;
+ }
+
+ rde_stack_move (p->ER->msg, top->msg);
+ rde_stack_pop (p->ES, 1);
+ }
+ SCOPE void
+ rde_param_i_error_push (RDE_PARAM p)
+ {
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ }
+ static void
+ error_set (RDE_PARAM p, long int s)
+ {
+ error_state_free (p->ER);
+ p->ER = ALLOC (ERROR_STATE);
+ p->ER->refCount = 1;
+ p->ER->loc = p->CL;
+ p->ER->msg = rde_stack_new (NULL);
+ ASSERT_BOUNDS(s,p->numstr);
+ rde_stack_push (p->ER->msg, (void*) s);
+ }
+ static void
+ error_state_free (void* esx)
+ {
+ ERROR_STATE* es = esx;
+ if (!es) return;
+ es->refCount --;
+ if (es->refCount > 0) return;
+ rde_stack_del (es->msg);
+ ckfree ((char*) es);
+ }
+ SCOPE void
+ rde_param_i_loc_pop_discard (RDE_PARAM p)
+ {
+ rde_stack_pop (p->LS, 1);
+ }
+ SCOPE void
+ rde_param_i_loc_pop_rewind (RDE_PARAM p)
+ {
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_pop (p->LS, 1);
+ }
+ SCOPE void
+ rde_param_i_loc_push (RDE_PARAM p)
+ {
+ rde_stack_push (p->LS, (void*) p->CL);
+ }
+ SCOPE void
+ rde_param_i_loc_rewind (RDE_PARAM p)
+ {
+ p->CL = (long int) rde_stack_top (p->LS);
+ }
+ SCOPE void
+ rde_param_i_input_next (RDE_PARAM p, long int m)
+ {
+ int leni;
+ char* ch;
+ ASSERT_BOUNDS(m,p->numstr);
+ p->CL ++;
+ if (p->CL < rde_tc_size (p->TC)) {
+
+ rde_tc_get (p->TC, p->CL, &p->CC, &p->CC_len);
+
+ ASSERT_BOUNDS (p->CC_len-1, TCL_UTF_MAX);
+ p->ST = 1;
+ ER_CLEAR (p);
+ return;
+ }
+ if (!p->IN ||
+ Tcl_Eof (p->IN) ||
+ (Tcl_ReadChars (p->IN, p->readbuf, 1, 0) <= 0)) {
+
+ p->ST = 0;
+ error_set (p, m);
+ return;
+ }
+
+ ch = Tcl_GetStringFromObj (p->readbuf, &leni);
+ ASSERT_BOUNDS (leni, TCL_UTF_MAX);
+ p->CC = rde_tc_append (p->TC, ch, leni);
+ p->CC_len = leni;
+ p->ST = 1;
+ ER_CLEAR (p);
+ }
+ SCOPE void
+ rde_param_i_status_fail (RDE_PARAM p)
+ {
+ p->ST = 0;
+ }
+ SCOPE void
+ rde_param_i_status_ok (RDE_PARAM p)
+ {
+ p->ST = 1;
+ }
+ SCOPE void
+ rde_param_i_status_negate (RDE_PARAM p)
+ {
+ p->ST = !p->ST;
+ }
+ SCOPE int
+ rde_param_i_symbol_restore (RDE_PARAM p, long int s)
+ {
+ NC_STATE* scs;
+ Tcl_HashEntry* hPtr;
+ Tcl_HashTable* tablePtr;
+
+ hPtr = Tcl_FindHashEntry (&p->NC, (char*) p->CL);
+ if (!hPtr) { return 0; }
+ tablePtr = (Tcl_HashTable*) Tcl_GetHashValue (hPtr);
+ hPtr = Tcl_FindHashEntry (tablePtr, (char*) s);
+ if (!hPtr) { return 0; }
+
+ scs = Tcl_GetHashValue (hPtr);
+ p->CL = scs->CL;
+ p->ST = scs->ST;
+ error_state_free (p->ER);
+ p->ER = scs->ER;
+ if (p->ER) { p->ER->refCount ++; }
+ TRACE (("SV_RESTORE (%p) '%s'",scs->SV, scs->SV ? Tcl_GetString (scs->SV):""));
+ SV_SET (p, scs->SV);
+ return 1;
+ }
+ SCOPE void
+ rde_param_i_symbol_save (RDE_PARAM p, long int s)
+ {
+ long int at = (long int) rde_stack_top (p->LS);
+ NC_STATE* scs;
+ Tcl_HashEntry* hPtr;
+ Tcl_HashTable* tablePtr;
+ int isnew;
+ ENTER ("rde_param_i_symbol_save");
+ TRACE (("RDE_PARAM %p",p));
+ TRACE (("INT %d",s));
+
+ hPtr = Tcl_CreateHashEntry (&p->NC, (char*) at, &isnew);
+ if (isnew) {
+ tablePtr = ALLOC (Tcl_HashTable);
+ Tcl_InitHashTable (tablePtr, TCL_ONE_WORD_KEYS);
+ Tcl_SetHashValue (hPtr, tablePtr);
+ } else {
+ tablePtr = (Tcl_HashTable*) Tcl_GetHashValue (hPtr);
+ }
+ hPtr = Tcl_CreateHashEntry (tablePtr, (char*) s, &isnew);
+ if (isnew) {
+
+ scs = ALLOC (NC_STATE);
+ scs->CL = p->CL;
+ scs->ST = p->ST;
+ TRACE (("SV_CACHE (%p '%s')", p->SV, p->SV ? Tcl_GetString(p->SV) : ""));
+ scs->SV = p->SV;
+ if (scs->SV) { Tcl_IncrRefCount (scs->SV); }
+ scs->ER = p->ER;
+ if (scs->ER) { scs->ER->refCount ++; }
+ Tcl_SetHashValue (hPtr, scs);
+ } else {
+
+ scs = (NC_STATE*) Tcl_GetHashValue (hPtr);
+ scs->CL = p->CL;
+ scs->ST = p->ST;
+ TRACE (("SV_CACHE/over (%p '%s')", p->SV, p->SV ? Tcl_GetString(p->SV) : "" ));
+ if (scs->SV) { Tcl_DecrRefCount (scs->SV); }
+ scs->SV = p->SV;
+ if (scs->SV) { Tcl_IncrRefCount (scs->SV); }
+ error_state_free (scs->ER);
+ scs->ER = p->ER;
+ if (scs->ER) { scs->ER->refCount ++; }
+ }
+ TRACE (("SV = (%p rc%d '%s')",
+ p->SV,
+ p->SV ? p->SV->refCount : -1,
+ p->SV ? Tcl_GetString (p->SV) : ""));
+ RETURNVOID;
+ }
+ SCOPE void
+ rde_param_i_test_alnum (RDE_PARAM p)
+ {
+ test_class (p, Tcl_UniCharIsAlnum, tc_alnum);
+ }
+ SCOPE void
+ rde_param_i_test_alpha (RDE_PARAM p)
+ {
+ test_class (p, Tcl_UniCharIsAlpha, tc_alpha);
+ }
+ SCOPE void
+ rde_param_i_test_ascii (RDE_PARAM p)
+ {
+ test_class (p, UniCharIsAscii, tc_ascii);
+ }
+ SCOPE void
+ rde_param_i_test_control (RDE_PARAM p)
+ {
+ test_class (p, Tcl_UniCharIsControl, tc_control);
+ }
+ SCOPE void
+ rde_param_i_test_char (RDE_PARAM p, const char* c, long int msg)
+ {
+ ASSERT_BOUNDS(msg,p->numstr);
+ p->ST = Tcl_UtfNcmp (p->CC, c, 1) == 0;
+ if (p->ST) {
+ ER_CLEAR (p);
+ } else {
+ error_set (p, msg);
+ p->CL --;
+ }
+ }
+ SCOPE void
+ rde_param_i_test_ddigit (RDE_PARAM p)
+ {
+ test_class (p, UniCharIsDecDigit, tc_ddigit);
+ }
+ SCOPE void
+ rde_param_i_test_digit (RDE_PARAM p)
+ {
+ test_class (p, Tcl_UniCharIsDigit, tc_digit);
+ }
+ SCOPE void
+ rde_param_i_test_graph (RDE_PARAM p)
+ {
+ test_class (p, Tcl_UniCharIsGraph, tc_graph);
+ }
+ SCOPE void
+ rde_param_i_test_lower (RDE_PARAM p)
+ {
+ test_class (p, Tcl_UniCharIsLower, tc_lower);
+ }
+ SCOPE void
+ rde_param_i_test_print (RDE_PARAM p)
+ {
+ test_class (p, Tcl_UniCharIsPrint, tc_printable);
+ }
+ SCOPE void
+ rde_param_i_test_punct (RDE_PARAM p)
+ {
+ test_class (p, Tcl_UniCharIsPunct, tc_punct);
+ }
+ SCOPE void
+ rde_param_i_test_range (RDE_PARAM p, const char* s, const char* e, long int msg)
+ {
+ ASSERT_BOUNDS(msg,p->numstr);
+ p->ST =
+ (Tcl_UtfNcmp (s, p->CC, 1) <= 0) &&
+ (Tcl_UtfNcmp (p->CC, e, 1) <= 0);
+ if (p->ST) {
+ ER_CLEAR (p);
+ } else {
+ error_set (p, msg);
+ p->CL --;
+ }
+ }
+ SCOPE void
+ rde_param_i_test_space (RDE_PARAM p)
+ {
+ test_class (p, Tcl_UniCharIsSpace, tc_space);
+ }
+ SCOPE void
+ rde_param_i_test_upper (RDE_PARAM p)
+ {
+ test_class (p, Tcl_UniCharIsUpper, tc_upper);
+ }
+ SCOPE void
+ rde_param_i_test_wordchar (RDE_PARAM p)
+ {
+ test_class (p, Tcl_UniCharIsWordChar, tc_wordchar);
+ }
+ SCOPE void
+ rde_param_i_test_xdigit (RDE_PARAM p)
+ {
+ test_class (p, UniCharIsHexDigit, tc_xdigit);
+ }
+ static void
+ test_class (RDE_PARAM p, UniCharClass class, test_class_id id)
+ {
+ Tcl_UniChar ch;
+ Tcl_UtfToUniChar(p->CC, &ch);
+ ASSERT_BOUNDS(id,p->numstr);
+ p->ST = !!class (ch);
+
+ if (p->ST) {
+ ER_CLEAR (p);
+ } else {
+ error_set (p, id);
+ p->CL --;
+ }
+ }
+ static int
+ UniCharIsAscii (int character)
+ {
+ return (character >= 0) && (character < 0x80);
+ }
+ static int
+ UniCharIsHexDigit (int character)
+ {
+ return (character >= 0) && (character < 0x80) && isxdigit(character);
+ }
+ static int
+ UniCharIsDecDigit (int character)
+ {
+ return (character >= 0) && (character < 0x80) && isdigit(character);
+ }
+ SCOPE void
+ rde_param_i_value_clear (RDE_PARAM p)
+ {
+ SV_CLEAR (p);
+ }
+ SCOPE void
+ rde_param_i_value_leaf (RDE_PARAM p, long int s)
+ {
+ Tcl_Obj* newsv;
+ Tcl_Obj* ov [3];
+ long int pos = 1 + (long int) rde_stack_top (p->LS);
+ ASSERT_BOUNDS(s,p->numstr);
+ ov [0] = Tcl_NewStringObj (p->string[s], -1);
+ ov [1] = Tcl_NewIntObj (pos);
+ ov [2] = Tcl_NewIntObj (p->CL);
+ newsv = Tcl_NewListObj (3, ov);
+ TRACE (("rde_param_i_value_leaf => '%s'",Tcl_GetString (newsv)));
+ SV_SET (p, newsv);
+ }
+ SCOPE void
+ rde_param_i_value_reduce (RDE_PARAM p, long int s)
+ {
+ Tcl_Obj* newsv;
+ int oc, i, j;
+ Tcl_Obj** ov;
+ long int ac;
+ Tcl_Obj** av;
+ long int pos = 1 + (long int) rde_stack_top (p->LS);
+ long int mark = (long int) rde_stack_top (p->mark);
+ long int asize = rde_stack_size (p->ast);
+ long int new = asize - mark;
+ ASSERT (new >= 0, "Bad number of elements to reduce");
+ ov = NALLOC (3+new, Tcl_Obj*);
+ ASSERT_BOUNDS(s,p->numstr);
+ ov [0] = Tcl_NewStringObj (p->string[s], -1);
+ ov [1] = Tcl_NewIntObj (pos);
+ ov [2] = Tcl_NewIntObj (p->CL);
+ rde_stack_get (p->ast, &ac, (void***) &av);
+ for (i = 3, j = mark; j < asize; i++, j++) {
+ ASSERT_BOUNDS (i, 3+new);
+ ASSERT_BOUNDS (j, ac);
+ ov [i] = av [j];
+ }
+ ASSERT (i == 3+new, "Reduction result incomplete");
+ newsv = Tcl_NewListObj (3+new, ov);
+ TRACE (("rde_param_i_value_reduce => '%s'",Tcl_GetString (newsv)));
+ SV_SET (p, newsv);
+ ckfree ((char*) ov);
+ }
+ static int
+ er_int_compare (const void* a, const void* b)
+ {
+
+ const void** ael = (const void**) a;
+ const void** bel = (const void**) b;
+ long int avalue = (long int) *ael;
+ long int bvalue = (long int) *bel;
+ if (avalue < bvalue) { return -1; }
+ if (avalue > bvalue) { return 1; }
+ return 0;
+ }
+ SCOPE int
+ rde_param_i_symbol_start (RDE_PARAM p, long int s)
+ {
+ if (rde_param_i_symbol_restore (p, s)) {
+ if (p->ST) {
+ rde_stack_push (p->ast, p->SV);
+ Tcl_IncrRefCount (p->SV);
+ }
+ return 1;
+ }
+ rde_stack_push (p->LS, (void*) p->CL);
+ return 0;
+ }
+ SCOPE int
+ rde_param_i_symbol_start_d (RDE_PARAM p, long int s)
+ {
+ if (rde_param_i_symbol_restore (p, s)) {
+ if (p->ST) {
+ rde_stack_push (p->ast, p->SV);
+ Tcl_IncrRefCount (p->SV);
+ }
+ return 1;
+ }
+ rde_stack_push (p->LS, (void*) p->CL);
+ rde_stack_push (p->mark, (void*) rde_stack_size (p->ast));
+ return 0;
+ }
+ SCOPE int
+ rde_param_i_symbol_void_start (RDE_PARAM p, long int s)
+ {
+ if (rde_param_i_symbol_restore (p, s)) return 1;
+ rde_stack_push (p->LS, (void*) p->CL);
+ return 0;
+ }
+ SCOPE int
+ rde_param_i_symbol_void_start_d (RDE_PARAM p, long int s)
+ {
+ if (rde_param_i_symbol_restore (p, s)) return 1;
+ rde_stack_push (p->LS, (void*) p->CL);
+ rde_stack_push (p->mark, (void*) rde_stack_size (p->ast));
+ return 0;
+ }
+ SCOPE void
+ rde_param_i_symbol_done_d_reduce (RDE_PARAM p, long int s, long int m)
+ {
+ if (p->ST) {
+ rde_param_i_value_reduce (p, s);
+ } else {
+ SV_CLEAR (p);
+ }
+ rde_param_i_symbol_save (p, s);
+ rde_param_i_error_nonterminal (p, m);
+ rde_param_i_ast_pop_rewind (p);
+ rde_stack_pop (p->LS, 1);
+ if (p->ST) {
+ rde_stack_push (p->ast, p->SV);
+ Tcl_IncrRefCount (p->SV);
+ }
+ }
+ SCOPE void
+ rde_param_i_symbol_done_leaf (RDE_PARAM p, long int s, long int m)
+ {
+ if (p->ST) {
+ rde_param_i_value_leaf (p, s);
+ } else {
+ SV_CLEAR (p);
+ }
+ rde_param_i_symbol_save (p, s);
+ rde_param_i_error_nonterminal (p, m);
+ rde_stack_pop (p->LS, 1);
+ if (p->ST) {
+ rde_stack_push (p->ast, p->SV);
+ Tcl_IncrRefCount (p->SV);
+ }
+ }
+ SCOPE void
+ rde_param_i_symbol_done_d_leaf (RDE_PARAM p, long int s, long int m)
+ {
+ if (p->ST) {
+ rde_param_i_value_leaf (p, s);
+ } else {
+ SV_CLEAR (p);
+ }
+ rde_param_i_symbol_save (p, s);
+ rde_param_i_error_nonterminal (p, m);
+ rde_param_i_ast_pop_rewind (p);
+ rde_stack_pop (p->LS, 1);
+ if (p->ST) {
+ rde_stack_push (p->ast, p->SV);
+ Tcl_IncrRefCount (p->SV);
+ }
+ }
+ SCOPE void
+ rde_param_i_symbol_done_void (RDE_PARAM p, long int s, long int m)
+ {
+ SV_CLEAR (p);
+ rde_param_i_symbol_save (p, s);
+ rde_param_i_error_nonterminal (p, m);
+ rde_stack_pop (p->LS, 1);
+ }
+ SCOPE void
+ rde_param_i_symbol_done_d_void (RDE_PARAM p, long int s, long int m)
+ {
+ SV_CLEAR (p);
+ rde_param_i_symbol_save (p, s);
+ rde_param_i_error_nonterminal (p, m);
+ rde_param_i_ast_pop_rewind (p);
+ rde_stack_pop (p->LS, 1);
+ }
+ SCOPE void
+ rde_param_i_next_char (RDE_PARAM p, const char* c, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_char (p, c, m);
+ }
+ SCOPE void
+ rde_param_i_next_range (RDE_PARAM p, const char* s, const char* e, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_range (p, s, e, m);
+ }
+ SCOPE void
+ rde_param_i_next_alnum (RDE_PARAM p, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_alnum (p);
+ }
+ SCOPE void
+ rde_param_i_next_alpha (RDE_PARAM p, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_alpha (p);
+ }
+ SCOPE void
+ rde_param_i_next_ascii (RDE_PARAM p, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_ascii (p);
+ }
+ SCOPE void
+ rde_param_i_next_control (RDE_PARAM p, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_control (p);
+ }
+ SCOPE void
+ rde_param_i_next_ddigit (RDE_PARAM p, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_ddigit (p);
+ }
+ SCOPE void
+ rde_param_i_next_digit (RDE_PARAM p, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_digit (p);
+ }
+ SCOPE void
+ rde_param_i_next_graph (RDE_PARAM p, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_graph (p);
+ }
+ SCOPE void
+ rde_param_i_next_lower (RDE_PARAM p, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_lower (p);
+ }
+ SCOPE void
+ rde_param_i_next_print (RDE_PARAM p, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_print (p);
+ }
+ SCOPE void
+ rde_param_i_next_punct (RDE_PARAM p, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_punct (p);
+ }
+ SCOPE void
+ rde_param_i_next_space (RDE_PARAM p, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_space (p);
+ }
+ SCOPE void
+ rde_param_i_next_upper (RDE_PARAM p, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_upper (p);
+ }
+ SCOPE void
+ rde_param_i_next_wordchar (RDE_PARAM p, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_wordchar (p);
+ }
+ SCOPE void
+ rde_param_i_next_xdigit (RDE_PARAM p, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_xdigit (p);
+ }
+ SCOPE void
+ rde_param_i_notahead_start_d (RDE_PARAM p)
+ {
+ rde_stack_push (p->LS, (void*) p->CL);
+ rde_stack_push (p->mark, (void*) rde_stack_size (p->ast));
+ }
+ SCOPE void
+ rde_param_i_notahead_exit_d (RDE_PARAM p)
+ {
+ if (p->ST) {
+ rde_param_i_ast_pop_rewind (p);
+ } else {
+ rde_stack_pop (p->mark, 1);
+ }
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_pop (p->LS, 1);
+ p->ST = !p->ST;
+ }
+ SCOPE void
+ rde_param_i_notahead_exit (RDE_PARAM p)
+ {
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_pop (p->LS, 1);
+ p->ST = !p->ST;
+ }
+ SCOPE void
+ rde_param_i_state_push_2 (RDE_PARAM p)
+ {
+
+ rde_stack_push (p->LS, (void*) p->CL);
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ }
+ SCOPE void
+ rde_param_i_state_push_void (RDE_PARAM p)
+ {
+ rde_stack_push (p->LS, (void*) p->CL);
+ ER_CLEAR (p);
+ rde_stack_push (p->ES, p->ER);
+
+ }
+ SCOPE void
+ rde_param_i_state_push_value (RDE_PARAM p)
+ {
+ rde_stack_push (p->mark, (void*) rde_stack_size (p->ast));
+ rde_stack_push (p->LS, (void*) p->CL);
+ ER_CLEAR (p);
+ rde_stack_push (p->ES, p->ER);
+
+ }
+ SCOPE void
+ rde_param_i_state_merge_ok (RDE_PARAM p)
+ {
+ rde_param_i_error_pop_merge (p);
+ if (!p->ST) {
+ p->ST = 1;
+ p->CL = (long int) rde_stack_top (p->LS);
+ }
+ rde_stack_pop (p->LS, 1);
+ }
+ SCOPE void
+ rde_param_i_state_merge_void (RDE_PARAM p)
+ {
+ rde_param_i_error_pop_merge (p);
+ if (!p->ST) {
+ p->CL = (long int) rde_stack_top (p->LS);
+ }
+ rde_stack_pop (p->LS, 1);
+ }
+ SCOPE void
+ rde_param_i_state_merge_value (RDE_PARAM p)
+ {
+ rde_param_i_error_pop_merge (p);
+ if (!p->ST) {
+ long int trim = (long int) rde_stack_top (p->mark);
+ rde_stack_trim (p->ast, trim);
+ p->CL = (long int) rde_stack_top (p->LS);
+ }
+ rde_stack_pop (p->mark, 1);
+ rde_stack_pop (p->LS, 1);
+ }
+ SCOPE int
+ rde_param_i_kleene_close (RDE_PARAM p)
+ {
+ int stop = !p->ST;
+ rde_param_i_error_pop_merge (p);
+ if (stop) {
+ p->ST = 1;
+ p->CL = (long int) rde_stack_top (p->LS);
+ }
+ rde_stack_pop (p->LS, 1);
+ return stop;
+ }
+ SCOPE int
+ rde_param_i_kleene_abort (RDE_PARAM p)
+ {
+ int stop = !p->ST;
+ if (stop) {
+ p->CL = (long int) rde_stack_top (p->LS);
+ }
+ rde_stack_pop (p->LS, 1);
+ return stop;
+ }
+ SCOPE int
+ rde_param_i_seq_void2void (RDE_PARAM p)
+ {
+ rde_param_i_error_pop_merge (p);
+ if (p->ST) {
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ return 0;
+ } else {
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_pop (p->LS, 1);
+ return 1;
+ }
+ }
+ SCOPE int
+ rde_param_i_seq_void2value (RDE_PARAM p)
+ {
+ rde_param_i_error_pop_merge (p);
+ if (p->ST) {
+ rde_stack_push (p->mark, (void*) rde_stack_size (p->ast));
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ return 0;
+ } else {
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_pop (p->LS, 1);
+ return 1;
+ }
+ }
+ SCOPE int
+ rde_param_i_seq_value2value (RDE_PARAM p)
+ {
+ rde_param_i_error_pop_merge (p);
+ if (p->ST) {
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ return 0;
+ } else {
+ long int trim = (long int) rde_stack_top (p->mark);
+ rde_stack_pop (p->mark, 1);
+ rde_stack_trim (p->ast, trim);
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_pop (p->LS, 1);
+ return 1;
+ }
+ }
+ SCOPE int
+ rde_param_i_bra_void2void (RDE_PARAM p)
+ {
+ rde_param_i_error_pop_merge (p);
+ if (p->ST) {
+ rde_stack_pop (p->LS, 1);
+ } else {
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ }
+ return p->ST;
+ }
+ SCOPE int
+ rde_param_i_bra_void2value (RDE_PARAM p)
+ {
+ rde_param_i_error_pop_merge (p);
+ if (p->ST) {
+ rde_stack_pop (p->LS, 1);
+ } else {
+ rde_stack_push (p->mark, (void*) rde_stack_size (p->ast));
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ }
+ return p->ST;
+ }
+ SCOPE int
+ rde_param_i_bra_value2void (RDE_PARAM p)
+ {
+ rde_param_i_error_pop_merge (p);
+ if (p->ST) {
+ rde_stack_pop (p->mark, 1);
+ rde_stack_pop (p->LS, 1);
+ } else {
+ long int trim = (long int) rde_stack_top (p->mark);
+ rde_stack_pop (p->mark, 1);
+ rde_stack_trim (p->ast, trim);
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ }
+ return p->ST;
+ }
+ SCOPE int
+ rde_param_i_bra_value2value (RDE_PARAM p)
+ {
+ rde_param_i_error_pop_merge (p);
+ if (p->ST) {
+ rde_stack_pop (p->mark, 1);
+ rde_stack_pop (p->LS, 1);
+ } else {
+ long int trim = (long int) rde_stack_top (p->mark);
+ rde_stack_trim (p->ast, trim);
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ }
+ return p->ST;
+ }
+ SCOPE void
+ rde_param_i_next_str (RDE_PARAM p, const char* str, long int m)
+ {
+ int at = p->CL;
+
+ while (*str) {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) {
+ p->ER->loc = at+1;
+ p->CL = at;
+ return;
+ }
+ rde_param_i_test_char (p, str, m);
+ if (!p->ST) {
+ p->ER->loc = at+1;
+ p->CL = at;
+ return;
+ }
+ str = Tcl_UtfNext (str);
+ }
+ }
+ SCOPE void
+ rde_param_i_next_class (RDE_PARAM p, const char* class, long int m)
+ {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ while (*class) {
+ p->ST = Tcl_UtfNcmp (p->CC, class, 1) == 0;
+ if (p->ST) {
+ ER_CLEAR (p);
+ return;
+ }
+ class = Tcl_UtfNext (class);
+ }
+ error_set (p, m);
+ p->CL --;
+ }
+
+
+ }
+
+ # # ## ### ###### ######## #############
+ ## BEGIN of GENERATED CODE. DO NOT EDIT.
+
+ critcl::ccode {
+ /* -*- c -*- */
+
+ /*
+ * Declaring the parse functions
+ */
+
+ static void sequence_4 (RDE_PARAM p);
+ static void sym_ALNUM (RDE_PARAM p);
+ static void sequence_9 (RDE_PARAM p);
+ static void sym_ALPHA (RDE_PARAM p);
+ static void sequence_14 (RDE_PARAM p);
+ static void sym_AND (RDE_PARAM p);
+ static void sym_APOSTROPH (RDE_PARAM p);
+ static void sequence_21 (RDE_PARAM p);
+ static void sym_ASCII (RDE_PARAM p);
+ static void choice_26 (RDE_PARAM p);
+ static void sequence_29 (RDE_PARAM p);
+ static void sym_Attribute (RDE_PARAM p);
+ static void choice_37 (RDE_PARAM p);
+ static void sym_Char (RDE_PARAM p);
+ static void sequence_44 (RDE_PARAM p);
+ static void sym_CharOctalFull (RDE_PARAM p);
+ static void optional_50 (RDE_PARAM p);
+ static void sequence_52 (RDE_PARAM p);
+ static void sym_CharOctalPart (RDE_PARAM p);
+ static void sequence_57 (RDE_PARAM p);
+ static void sym_CharSpecial (RDE_PARAM p);
+ static void notahead_61 (RDE_PARAM p);
+ static void sequence_64 (RDE_PARAM p);
+ static void sym_CharUnescaped (RDE_PARAM p);
+ static void optional_72 (RDE_PARAM p);
+ static void sequence_74 (RDE_PARAM p);
+ static void optional_76 (RDE_PARAM p);
+ static void sequence_78 (RDE_PARAM p);
+ static void optional_80 (RDE_PARAM p);
+ static void sequence_82 (RDE_PARAM p);
+ static void sym_CharUnicode (RDE_PARAM p);
+ static void notahead_87 (RDE_PARAM p);
+ static void sequence_90 (RDE_PARAM p);
+ static void kleene_92 (RDE_PARAM p);
+ static void sequence_96 (RDE_PARAM p);
+ static void sym_Class (RDE_PARAM p);
+ static void sequence_101 (RDE_PARAM p);
+ static void sym_CLOSE (RDE_PARAM p);
+ static void sym_CLOSEB (RDE_PARAM p);
+ static void sequence_108 (RDE_PARAM p);
+ static void sym_COLON (RDE_PARAM p);
+ static void notahead_113 (RDE_PARAM p);
+ static void sequence_116 (RDE_PARAM p);
+ static void kleene_118 (RDE_PARAM p);
+ static void sequence_121 (RDE_PARAM p);
+ static void sym_COMMENT (RDE_PARAM p);
+ static void sequence_126 (RDE_PARAM p);
+ static void sym_CONTROL (RDE_PARAM p);
+ static void sym_DAPOSTROPH (RDE_PARAM p);
+ static void sequence_133 (RDE_PARAM p);
+ static void sym_DDIGIT (RDE_PARAM p);
+ static void optional_137 (RDE_PARAM p);
+ static void sequence_143 (RDE_PARAM p);
+ static void sym_Definition (RDE_PARAM p);
+ static void sequence_148 (RDE_PARAM p);
+ static void sym_DIGIT (RDE_PARAM p);
+ static void sequence_153 (RDE_PARAM p);
+ static void sym_DOT (RDE_PARAM p);
+ static void notahead_157 (RDE_PARAM p);
+ static void sym_EOF (RDE_PARAM p);
+ static void sym_EOL (RDE_PARAM p);
+ static void sequence_165 (RDE_PARAM p);
+ static void kleene_167 (RDE_PARAM p);
+ static void sequence_169 (RDE_PARAM p);
+ static void sym_Expression (RDE_PARAM p);
+ static void sequence_176 (RDE_PARAM p);
+ static void sym_Final (RDE_PARAM p);
+ static void kleene_182 (RDE_PARAM p);
+ static void sequence_186 (RDE_PARAM p);
+ static void sym_Grammar (RDE_PARAM p);
+ static void sequence_191 (RDE_PARAM p);
+ static void sym_GRAPH (RDE_PARAM p);
+ static void sequence_197 (RDE_PARAM p);
+ static void sym_Header (RDE_PARAM p);
+ static void choice_202 (RDE_PARAM p);
+ static void choice_206 (RDE_PARAM p);
+ static void kleene_208 (RDE_PARAM p);
+ static void sequence_210 (RDE_PARAM p);
+ static void sym_Ident (RDE_PARAM p);
+ static void sequence_215 (RDE_PARAM p);
+ static void sym_Identifier (RDE_PARAM p);
+ static void sequence_220 (RDE_PARAM p);
+ static void sym_IS (RDE_PARAM p);
+ static void sequence_225 (RDE_PARAM p);
+ static void sym_LEAF (RDE_PARAM p);
+ static void notahead_230 (RDE_PARAM p);
+ static void sequence_233 (RDE_PARAM p);
+ static void kleene_235 (RDE_PARAM p);
+ static void sequence_239 (RDE_PARAM p);
+ static void notahead_243 (RDE_PARAM p);
+ static void sequence_246 (RDE_PARAM p);
+ static void kleene_248 (RDE_PARAM p);
+ static void sequence_252 (RDE_PARAM p);
+ static void choice_254 (RDE_PARAM p);
+ static void sym_Literal (RDE_PARAM p);
+ static void sequence_259 (RDE_PARAM p);
+ static void sym_LOWER (RDE_PARAM p);
+ static void sequence_264 (RDE_PARAM p);
+ static void sym_NOT (RDE_PARAM p);
+ static void sequence_269 (RDE_PARAM p);
+ static void sym_OPEN (RDE_PARAM p);
+ static void sym_OPENB (RDE_PARAM p);
+ static void notahead_278 (RDE_PARAM p);
+ static void sequence_281 (RDE_PARAM p);
+ static void sym_PEG (RDE_PARAM p);
+ static void sequence_286 (RDE_PARAM p);
+ static void sym_PLUS (RDE_PARAM p);
+ static void choice_291 (RDE_PARAM p);
+ static void optional_293 (RDE_PARAM p);
+ static void sequence_296 (RDE_PARAM p);
+ static void sym_Prefix (RDE_PARAM p);
+ static void sequence_317 (RDE_PARAM p);
+ static void choice_322 (RDE_PARAM p);
+ static void sym_Primary (RDE_PARAM p);
+ static void sequence_327 (RDE_PARAM p);
+ static void sym_PRINTABLE (RDE_PARAM p);
+ static void sequence_332 (RDE_PARAM p);
+ static void sym_PUNCT (RDE_PARAM p);
+ static void sequence_337 (RDE_PARAM p);
+ static void sym_QUESTION (RDE_PARAM p);
+ static void sequence_343 (RDE_PARAM p);
+ static void choice_346 (RDE_PARAM p);
+ static void sym_Range (RDE_PARAM p);
+ static void sequence_351 (RDE_PARAM p);
+ static void sym_SEMICOLON (RDE_PARAM p);
+ static void poskleene_355 (RDE_PARAM p);
+ static void sym_Sequence (RDE_PARAM p);
+ static void sequence_360 (RDE_PARAM p);
+ static void sym_SLASH (RDE_PARAM p);
+ static void sequence_365 (RDE_PARAM p);
+ static void sym_SPACE (RDE_PARAM p);
+ static void sequence_370 (RDE_PARAM p);
+ static void sym_STAR (RDE_PARAM p);
+ static void sym_StartExpr (RDE_PARAM p);
+ static void choice_382 (RDE_PARAM p);
+ static void optional_384 (RDE_PARAM p);
+ static void sequence_386 (RDE_PARAM p);
+ static void sym_Suffix (RDE_PARAM p);
+ static void sym_TO (RDE_PARAM p);
+ static void sequence_393 (RDE_PARAM p);
+ static void sym_UPPER (RDE_PARAM p);
+ static void sequence_398 (RDE_PARAM p);
+ static void sym_VOID (RDE_PARAM p);
+ static void choice_403 (RDE_PARAM p);
+ static void kleene_405 (RDE_PARAM p);
+ static void sym_WHITESPACE (RDE_PARAM p);
+ static void sequence_410 (RDE_PARAM p);
+ static void sym_WORDCHAR (RDE_PARAM p);
+ static void sequence_415 (RDE_PARAM p);
+ static void sym_XDIGIT (RDE_PARAM p);
+
+ /*
+ * Precomputed table of strings (symbols, error messages, etc.).
+ */
+
+ static char const* p_string [178] = {
+ /* 0 = */ "alnum",
+ /* 1 = */ "alpha",
+ /* 2 = */ "ascii",
+ /* 3 = */ "control",
+ /* 4 = */ "ddigit",
+ /* 5 = */ "digit",
+ /* 6 = */ "graph",
+ /* 7 = */ "lower",
+ /* 8 = */ "print",
+ /* 9 = */ "punct",
+ /* 10 = */ "space",
+ /* 11 = */ "upper",
+ /* 12 = */ "wordchar",
+ /* 13 = */ "xdigit",
+ /* 14 = */ "str <alnum>",
+ /* 15 = */ "n ALNUM",
+ /* 16 = */ "ALNUM",
+ /* 17 = */ "str <alpha>",
+ /* 18 = */ "n ALPHA",
+ /* 19 = */ "ALPHA",
+ /* 20 = */ "t &",
+ /* 21 = */ "n AND",
+ /* 22 = */ "AND",
+ /* 23 = */ "t '",
+ /* 24 = */ "n APOSTROPH",
+ /* 25 = */ "APOSTROPH",
+ /* 26 = */ "str <ascii>",
+ /* 27 = */ "n ASCII",
+ /* 28 = */ "ASCII",
+ /* 29 = */ "n Attribute",
+ /* 30 = */ "Attribute",
+ /* 31 = */ "n Char",
+ /* 32 = */ "Char",
+ /* 33 = */ "t \\\\",
+ /* 34 = */ ".. 0 2",
+ /* 35 = */ ".. 0 7",
+ /* 36 = */ "n CharOctalFull",
+ /* 37 = */ "CharOctalFull",
+ /* 38 = */ "n CharOctalPart",
+ /* 39 = */ "CharOctalPart",
+ /* 40 = */ "cl nrt'\\\"\\[\\]\\\\",
+ /* 41 = */ "n CharSpecial",
+ /* 42 = */ "CharSpecial",
+ /* 43 = */ "dot",
+ /* 44 = */ "n CharUnescaped",
+ /* 45 = */ "CharUnescaped",
+ /* 46 = */ "str \173\\u\175",
+ /* 47 = */ "n CharUnicode",
+ /* 48 = */ "CharUnicode",
+ /* 49 = */ "n Class",
+ /* 50 = */ "Class",
+ /* 51 = */ "t )",
+ /* 52 = */ "n CLOSE",
+ /* 53 = */ "CLOSE",
+ /* 54 = */ "t \\]",
+ /* 55 = */ "n CLOSEB",
+ /* 56 = */ "CLOSEB",
+ /* 57 = */ "t :",
+ /* 58 = */ "n COLON",
+ /* 59 = */ "COLON",
+ /* 60 = */ "t #",
+ /* 61 = */ "n COMMENT",
+ /* 62 = */ "COMMENT",
+ /* 63 = */ "str <control>",
+ /* 64 = */ "n CONTROL",
+ /* 65 = */ "CONTROL",
+ /* 66 = */ "t \173\"\175",
+ /* 67 = */ "n DAPOSTROPH",
+ /* 68 = */ "DAPOSTROPH",
+ /* 69 = */ "str <ddigit>",
+ /* 70 = */ "n DDIGIT",
+ /* 71 = */ "DDIGIT",
+ /* 72 = */ "n Definition",
+ /* 73 = */ "Definition",
+ /* 74 = */ "str <digit>",
+ /* 75 = */ "n DIGIT",
+ /* 76 = */ "DIGIT",
+ /* 77 = */ "t .",
+ /* 78 = */ "n DOT",
+ /* 79 = */ "DOT",
+ /* 80 = */ "n EOF",
+ /* 81 = */ "EOF",
+ /* 82 = */ "cl \173\n\r\175",
+ /* 83 = */ "n EOL",
+ /* 84 = */ "EOL",
+ /* 85 = */ "n Expression",
+ /* 86 = */ "Expression",
+ /* 87 = */ "str END",
+ /* 88 = */ "n Final",
+ /* 89 = */ "Final",
+ /* 90 = */ "n Grammar",
+ /* 91 = */ "Grammar",
+ /* 92 = */ "str <graph>",
+ /* 93 = */ "n GRAPH",
+ /* 94 = */ "GRAPH",
+ /* 95 = */ "n Header",
+ /* 96 = */ "Header",
+ /* 97 = */ "cl _:",
+ /* 98 = */ "n Ident",
+ /* 99 = */ "Ident",
+ /* 100 = */ "n Identifier",
+ /* 101 = */ "Identifier",
+ /* 102 = */ "str <-",
+ /* 103 = */ "n IS",
+ /* 104 = */ "IS",
+ /* 105 = */ "str leaf",
+ /* 106 = */ "n LEAF",
+ /* 107 = */ "LEAF",
+ /* 108 = */ "n Literal",
+ /* 109 = */ "Literal",
+ /* 110 = */ "str <lower>",
+ /* 111 = */ "n LOWER",
+ /* 112 = */ "LOWER",
+ /* 113 = */ "t !",
+ /* 114 = */ "n NOT",
+ /* 115 = */ "NOT",
+ /* 116 = */ "t (",
+ /* 117 = */ "n OPEN",
+ /* 118 = */ "OPEN",
+ /* 119 = */ "t \173[\175",
+ /* 120 = */ "n OPENB",
+ /* 121 = */ "OPENB",
+ /* 122 = */ "str PEG",
+ /* 123 = */ "n PEG",
+ /* 124 = */ "PEG",
+ /* 125 = */ "t +",
+ /* 126 = */ "n PLUS",
+ /* 127 = */ "PLUS",
+ /* 128 = */ "n Prefix",
+ /* 129 = */ "Prefix",
+ /* 130 = */ "n Primary",
+ /* 131 = */ "Primary",
+ /* 132 = */ "str <print>",
+ /* 133 = */ "n PRINTABLE",
+ /* 134 = */ "PRINTABLE",
+ /* 135 = */ "str <punct>",
+ /* 136 = */ "n PUNCT",
+ /* 137 = */ "PUNCT",
+ /* 138 = */ "t ?",
+ /* 139 = */ "n QUESTION",
+ /* 140 = */ "QUESTION",
+ /* 141 = */ "n Range",
+ /* 142 = */ "Range",
+ /* 143 = */ "t \173;\175",
+ /* 144 = */ "n SEMICOLON",
+ /* 145 = */ "SEMICOLON",
+ /* 146 = */ "n Sequence",
+ /* 147 = */ "Sequence",
+ /* 148 = */ "t /",
+ /* 149 = */ "n SLASH",
+ /* 150 = */ "SLASH",
+ /* 151 = */ "str <space>",
+ /* 152 = */ "n SPACE",
+ /* 153 = */ "SPACE",
+ /* 154 = */ "t *",
+ /* 155 = */ "n STAR",
+ /* 156 = */ "STAR",
+ /* 157 = */ "n StartExpr",
+ /* 158 = */ "StartExpr",
+ /* 159 = */ "n Suffix",
+ /* 160 = */ "Suffix",
+ /* 161 = */ "t -",
+ /* 162 = */ "n TO",
+ /* 163 = */ "TO",
+ /* 164 = */ "str <upper>",
+ /* 165 = */ "n UPPER",
+ /* 166 = */ "UPPER",
+ /* 167 = */ "str void",
+ /* 168 = */ "n VOID",
+ /* 169 = */ "VOID",
+ /* 170 = */ "n WHITESPACE",
+ /* 171 = */ "WHITESPACE",
+ /* 172 = */ "str <wordchar>",
+ /* 173 = */ "n WORDCHAR",
+ /* 174 = */ "WORDCHAR",
+ /* 175 = */ "str <xdigit>",
+ /* 176 = */ "n XDIGIT",
+ /* 177 = */ "XDIGIT"
+ };
+
+ /*
+ * Grammar Start Expression
+ */
+
+ static void MAIN (RDE_PARAM p) {
+ sym_Grammar (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'ALNUM'
+ */
+
+ static void sym_ALNUM (RDE_PARAM p) {
+ /*
+ * x
+ * "<alnum>"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 16)) return ;
+ sequence_4 (p);
+ rde_param_i_symbol_done_leaf (p, 16, 15);
+ return;
+ }
+
+ static void sequence_4 (RDE_PARAM p) {
+ /*
+ * x
+ * "<alnum>"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "<alnum>", 14);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'ALPHA'
+ */
+
+ static void sym_ALPHA (RDE_PARAM p) {
+ /*
+ * x
+ * "<alpha>"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 19)) return ;
+ sequence_9 (p);
+ rde_param_i_symbol_done_leaf (p, 19, 18);
+ return;
+ }
+
+ static void sequence_9 (RDE_PARAM p) {
+ /*
+ * x
+ * "<alpha>"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "<alpha>", 17);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'AND'
+ */
+
+ static void sym_AND (RDE_PARAM p) {
+ /*
+ * x
+ * '&'
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 22)) return ;
+ sequence_14 (p);
+ rde_param_i_symbol_done_leaf (p, 22, 21);
+ return;
+ }
+
+ static void sequence_14 (RDE_PARAM p) {
+ /*
+ * x
+ * '&'
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_char (p, "&", 20);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * void Symbol 'APOSTROPH'
+ */
+
+ static void sym_APOSTROPH (RDE_PARAM p) {
+ /*
+ * '''
+ */
+
+ if (rde_param_i_symbol_void_start (p, 25)) return ;
+ rde_param_i_next_char (p, "'", 23);
+ rde_param_i_symbol_done_void (p, 25, 24);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'ASCII'
+ */
+
+ static void sym_ASCII (RDE_PARAM p) {
+ /*
+ * x
+ * "<ascii>"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 28)) return ;
+ sequence_21 (p);
+ rde_param_i_symbol_done_leaf (p, 28, 27);
+ return;
+ }
+
+ static void sequence_21 (RDE_PARAM p) {
+ /*
+ * x
+ * "<ascii>"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "<ascii>", 26);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * value Symbol 'Attribute'
+ */
+
+ static void sym_Attribute (RDE_PARAM p) {
+ /*
+ * x
+ * /
+ * (VOID)
+ * (LEAF)
+ * (COLON)
+ */
+
+ if (rde_param_i_symbol_start_d (p, 30)) return ;
+ sequence_29 (p);
+ rde_param_i_symbol_done_d_reduce (p, 30, 29);
+ return;
+ }
+
+ static void sequence_29 (RDE_PARAM p) {
+ /*
+ * x
+ * /
+ * (VOID)
+ * (LEAF)
+ * (COLON)
+ */
+
+ rde_param_i_state_push_value (p);
+ choice_26 (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_COLON (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ static void choice_26 (RDE_PARAM p) {
+ /*
+ * /
+ * (VOID)
+ * (LEAF)
+ */
+
+ rde_param_i_state_push_value (p);
+ sym_VOID (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_LEAF (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ /*
+ * value Symbol 'Char'
+ */
+
+ static void sym_Char (RDE_PARAM p) {
+ /*
+ * /
+ * (CharSpecial)
+ * (CharOctalFull)
+ * (CharOctalPart)
+ * (CharUnicode)
+ * (CharUnescaped)
+ */
+
+ if (rde_param_i_symbol_start_d (p, 32)) return ;
+ choice_37 (p);
+ rde_param_i_symbol_done_d_reduce (p, 32, 31);
+ return;
+ }
+
+ static void choice_37 (RDE_PARAM p) {
+ /*
+ * /
+ * (CharSpecial)
+ * (CharOctalFull)
+ * (CharOctalPart)
+ * (CharUnicode)
+ * (CharUnescaped)
+ */
+
+ rde_param_i_state_push_value (p);
+ sym_CharSpecial (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_CharOctalFull (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_CharOctalPart (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_CharUnicode (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_CharUnescaped (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'CharOctalFull'
+ */
+
+ static void sym_CharOctalFull (RDE_PARAM p) {
+ /*
+ * x
+ * '\'
+ * range (0 .. 2)
+ * range (0 .. 7)
+ * range (0 .. 7)
+ */
+
+ if (rde_param_i_symbol_start (p, 37)) return ;
+ sequence_44 (p);
+ rde_param_i_symbol_done_leaf (p, 37, 36);
+ return;
+ }
+
+ static void sequence_44 (RDE_PARAM p) {
+ /*
+ * x
+ * '\'
+ * range (0 .. 2)
+ * range (0 .. 7)
+ * range (0 .. 7)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_char (p, "\\", 33);
+ if (rde_param_i_seq_void2void(p)) return;
+ rde_param_i_next_range (p, "0", "2", 34);
+ if (rde_param_i_seq_void2void(p)) return;
+ rde_param_i_next_range (p, "0", "7", 35);
+ if (rde_param_i_seq_void2void(p)) return;
+ rde_param_i_next_range (p, "0", "7", 35);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'CharOctalPart'
+ */
+
+ static void sym_CharOctalPart (RDE_PARAM p) {
+ /*
+ * x
+ * '\'
+ * range (0 .. 7)
+ * ?
+ * range (0 .. 7)
+ */
+
+ if (rde_param_i_symbol_start (p, 39)) return ;
+ sequence_52 (p);
+ rde_param_i_symbol_done_leaf (p, 39, 38);
+ return;
+ }
+
+ static void sequence_52 (RDE_PARAM p) {
+ /*
+ * x
+ * '\'
+ * range (0 .. 7)
+ * ?
+ * range (0 .. 7)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_char (p, "\\", 33);
+ if (rde_param_i_seq_void2void(p)) return;
+ rde_param_i_next_range (p, "0", "7", 35);
+ if (rde_param_i_seq_void2void(p)) return;
+ optional_50 (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ static void optional_50 (RDE_PARAM p) {
+ /*
+ * ?
+ * range (0 .. 7)
+ */
+
+ rde_param_i_state_push_2 (p);
+ rde_param_i_next_range (p, "0", "7", 35);
+ rde_param_i_state_merge_ok (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'CharSpecial'
+ */
+
+ static void sym_CharSpecial (RDE_PARAM p) {
+ /*
+ * x
+ * '\'
+ * [nrt'\"[]\]
+ */
+
+ if (rde_param_i_symbol_start (p, 42)) return ;
+ sequence_57 (p);
+ rde_param_i_symbol_done_leaf (p, 42, 41);
+ return;
+ }
+
+ static void sequence_57 (RDE_PARAM p) {
+ /*
+ * x
+ * '\'
+ * [nrt'\"[]\]
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_char (p, "\\", 33);
+ if (rde_param_i_seq_void2void(p)) return;
+ rde_param_i_next_class (p, "nrt'\"[]\\", 40);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'CharUnescaped'
+ */
+
+ static void sym_CharUnescaped (RDE_PARAM p) {
+ /*
+ * x
+ * !
+ * '\'
+ * <dot>
+ */
+
+ if (rde_param_i_symbol_start (p, 45)) return ;
+ sequence_64 (p);
+ rde_param_i_symbol_done_leaf (p, 45, 44);
+ return;
+ }
+
+ static void sequence_64 (RDE_PARAM p) {
+ /*
+ * x
+ * !
+ * '\'
+ * <dot>
+ */
+
+ rde_param_i_state_push_void (p);
+ notahead_61 (p);
+ if (rde_param_i_seq_void2void(p)) return;
+ rde_param_i_input_next (p, 43);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ static void notahead_61 (RDE_PARAM p) {
+ /*
+ * !
+ * '\'
+ */
+
+ rde_param_i_loc_push (p);
+ rde_param_i_next_char (p, "\\", 33);
+ rde_param_i_notahead_exit (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'CharUnicode'
+ */
+
+ static void sym_CharUnicode (RDE_PARAM p) {
+ /*
+ * x
+ * "\u"
+ * <xdigit>
+ * ?
+ * x
+ * <xdigit>
+ * ?
+ * x
+ * <xdigit>
+ * ?
+ * <xdigit>
+ */
+
+ if (rde_param_i_symbol_start (p, 48)) return ;
+ sequence_82 (p);
+ rde_param_i_symbol_done_leaf (p, 48, 47);
+ return;
+ }
+
+ static void sequence_82 (RDE_PARAM p) {
+ /*
+ * x
+ * "\u"
+ * <xdigit>
+ * ?
+ * x
+ * <xdigit>
+ * ?
+ * x
+ * <xdigit>
+ * ?
+ * <xdigit>
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "\\u", 46);
+ if (rde_param_i_seq_void2void(p)) return;
+ rde_param_i_next_xdigit (p, 13);
+ if (rde_param_i_seq_void2void(p)) return;
+ optional_80 (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ static void optional_80 (RDE_PARAM p) {
+ /*
+ * ?
+ * x
+ * <xdigit>
+ * ?
+ * x
+ * <xdigit>
+ * ?
+ * <xdigit>
+ */
+
+ rde_param_i_state_push_2 (p);
+ sequence_78 (p);
+ rde_param_i_state_merge_ok (p);
+ return;
+ }
+
+ static void sequence_78 (RDE_PARAM p) {
+ /*
+ * x
+ * <xdigit>
+ * ?
+ * x
+ * <xdigit>
+ * ?
+ * <xdigit>
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_xdigit (p, 13);
+ if (rde_param_i_seq_void2void(p)) return;
+ optional_76 (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ static void optional_76 (RDE_PARAM p) {
+ /*
+ * ?
+ * x
+ * <xdigit>
+ * ?
+ * <xdigit>
+ */
+
+ rde_param_i_state_push_2 (p);
+ sequence_74 (p);
+ rde_param_i_state_merge_ok (p);
+ return;
+ }
+
+ static void sequence_74 (RDE_PARAM p) {
+ /*
+ * x
+ * <xdigit>
+ * ?
+ * <xdigit>
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_xdigit (p, 13);
+ if (rde_param_i_seq_void2void(p)) return;
+ optional_72 (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ static void optional_72 (RDE_PARAM p) {
+ /*
+ * ?
+ * <xdigit>
+ */
+
+ rde_param_i_state_push_2 (p);
+ rde_param_i_next_xdigit (p, 13);
+ rde_param_i_state_merge_ok (p);
+ return;
+ }
+
+ /*
+ * value Symbol 'Class'
+ */
+
+ static void sym_Class (RDE_PARAM p) {
+ /*
+ * x
+ * (OPENB)
+ * *
+ * x
+ * !
+ * (CLOSEB)
+ * (Range)
+ * (CLOSEB)
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start_d (p, 50)) return ;
+ sequence_96 (p);
+ rde_param_i_symbol_done_d_reduce (p, 50, 49);
+ return;
+ }
+
+ static void sequence_96 (RDE_PARAM p) {
+ /*
+ * x
+ * (OPENB)
+ * *
+ * x
+ * !
+ * (CLOSEB)
+ * (Range)
+ * (CLOSEB)
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ sym_OPENB (p);
+ if (rde_param_i_seq_void2value(p)) return;
+ kleene_92 (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_CLOSEB (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ static void kleene_92 (RDE_PARAM p) {
+ /*
+ * *
+ * x
+ * !
+ * (CLOSEB)
+ * (Range)
+ */
+
+ while (1) {
+ rde_param_i_state_push_2 (p);
+ sequence_90 (p);
+ if (rde_param_i_kleene_close(p)) return;
+ }
+ return;
+ }
+
+ static void sequence_90 (RDE_PARAM p) {
+ /*
+ * x
+ * !
+ * (CLOSEB)
+ * (Range)
+ */
+
+ rde_param_i_state_push_void (p);
+ notahead_87 (p);
+ if (rde_param_i_seq_void2value(p)) return;
+ sym_Range (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ static void notahead_87 (RDE_PARAM p) {
+ /*
+ * !
+ * (CLOSEB)
+ */
+
+ rde_param_i_loc_push (p);
+ sym_CLOSEB (p);
+ rde_param_i_notahead_exit (p);
+ return;
+ }
+
+ /*
+ * void Symbol 'CLOSE'
+ */
+
+ static void sym_CLOSE (RDE_PARAM p) {
+ /*
+ * x
+ * '\)'
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_void_start (p, 53)) return ;
+ sequence_101 (p);
+ rde_param_i_symbol_done_void (p, 53, 52);
+ return;
+ }
+
+ static void sequence_101 (RDE_PARAM p) {
+ /*
+ * x
+ * '\)'
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_char (p, ")", 51);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * void Symbol 'CLOSEB'
+ */
+
+ static void sym_CLOSEB (RDE_PARAM p) {
+ /*
+ * ']'
+ */
+
+ if (rde_param_i_symbol_void_start (p, 56)) return ;
+ rde_param_i_next_char (p, "]", 54);
+ rde_param_i_symbol_done_void (p, 56, 55);
+ return;
+ }
+
+ /*
+ * void Symbol 'COLON'
+ */
+
+ static void sym_COLON (RDE_PARAM p) {
+ /*
+ * x
+ * ':'
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_void_start (p, 59)) return ;
+ sequence_108 (p);
+ rde_param_i_symbol_done_void (p, 59, 58);
+ return;
+ }
+
+ static void sequence_108 (RDE_PARAM p) {
+ /*
+ * x
+ * ':'
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_char (p, ":", 57);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * void Symbol 'COMMENT'
+ */
+
+ static void sym_COMMENT (RDE_PARAM p) {
+ /*
+ * x
+ * '#'
+ * *
+ * x
+ * !
+ * (EOL)
+ * <dot>
+ * (EOL)
+ */
+
+ if (rde_param_i_symbol_void_start (p, 62)) return ;
+ sequence_121 (p);
+ rde_param_i_symbol_done_void (p, 62, 61);
+ return;
+ }
+
+ static void sequence_121 (RDE_PARAM p) {
+ /*
+ * x
+ * '#'
+ * *
+ * x
+ * !
+ * (EOL)
+ * <dot>
+ * (EOL)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_char (p, "#", 60);
+ if (rde_param_i_seq_void2void(p)) return;
+ kleene_118 (p);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_EOL (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ static void kleene_118 (RDE_PARAM p) {
+ /*
+ * *
+ * x
+ * !
+ * (EOL)
+ * <dot>
+ */
+
+ while (1) {
+ rde_param_i_state_push_2 (p);
+ sequence_116 (p);
+ if (rde_param_i_kleene_close(p)) return;
+ }
+ return;
+ }
+
+ static void sequence_116 (RDE_PARAM p) {
+ /*
+ * x
+ * !
+ * (EOL)
+ * <dot>
+ */
+
+ rde_param_i_state_push_void (p);
+ notahead_113 (p);
+ if (rde_param_i_seq_void2void(p)) return;
+ rde_param_i_input_next (p, 43);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ static void notahead_113 (RDE_PARAM p) {
+ /*
+ * !
+ * (EOL)
+ */
+
+ rde_param_i_loc_push (p);
+ sym_EOL (p);
+ rde_param_i_notahead_exit (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'CONTROL'
+ */
+
+ static void sym_CONTROL (RDE_PARAM p) {
+ /*
+ * x
+ * "<control>"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 65)) return ;
+ sequence_126 (p);
+ rde_param_i_symbol_done_leaf (p, 65, 64);
+ return;
+ }
+
+ static void sequence_126 (RDE_PARAM p) {
+ /*
+ * x
+ * "<control>"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "<control>", 63);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * void Symbol 'DAPOSTROPH'
+ */
+
+ static void sym_DAPOSTROPH (RDE_PARAM p) {
+ /*
+ * '\"'
+ */
+
+ if (rde_param_i_symbol_void_start (p, 68)) return ;
+ rde_param_i_next_char (p, "\"", 66);
+ rde_param_i_symbol_done_void (p, 68, 67);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'DDIGIT'
+ */
+
+ static void sym_DDIGIT (RDE_PARAM p) {
+ /*
+ * x
+ * "<ddigit>"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 71)) return ;
+ sequence_133 (p);
+ rde_param_i_symbol_done_leaf (p, 71, 70);
+ return;
+ }
+
+ static void sequence_133 (RDE_PARAM p) {
+ /*
+ * x
+ * "<ddigit>"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "<ddigit>", 69);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * value Symbol 'Definition'
+ */
+
+ static void sym_Definition (RDE_PARAM p) {
+ /*
+ * x
+ * ?
+ * (Attribute)
+ * (Identifier)
+ * (IS)
+ * (Expression)
+ * (SEMICOLON)
+ */
+
+ if (rde_param_i_symbol_start_d (p, 73)) return ;
+ sequence_143 (p);
+ rde_param_i_symbol_done_d_reduce (p, 73, 72);
+ return;
+ }
+
+ static void sequence_143 (RDE_PARAM p) {
+ /*
+ * x
+ * ?
+ * (Attribute)
+ * (Identifier)
+ * (IS)
+ * (Expression)
+ * (SEMICOLON)
+ */
+
+ rde_param_i_state_push_value (p);
+ optional_137 (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_Identifier (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_IS (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_Expression (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_SEMICOLON (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ static void optional_137 (RDE_PARAM p) {
+ /*
+ * ?
+ * (Attribute)
+ */
+
+ rde_param_i_state_push_2 (p);
+ sym_Attribute (p);
+ rde_param_i_state_merge_ok (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'DIGIT'
+ */
+
+ static void sym_DIGIT (RDE_PARAM p) {
+ /*
+ * x
+ * "<digit>"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 76)) return ;
+ sequence_148 (p);
+ rde_param_i_symbol_done_leaf (p, 76, 75);
+ return;
+ }
+
+ static void sequence_148 (RDE_PARAM p) {
+ /*
+ * x
+ * "<digit>"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "<digit>", 74);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'DOT'
+ */
+
+ static void sym_DOT (RDE_PARAM p) {
+ /*
+ * x
+ * '.'
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 79)) return ;
+ sequence_153 (p);
+ rde_param_i_symbol_done_leaf (p, 79, 78);
+ return;
+ }
+
+ static void sequence_153 (RDE_PARAM p) {
+ /*
+ * x
+ * '.'
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_char (p, ".", 77);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * void Symbol 'EOF'
+ */
+
+ static void sym_EOF (RDE_PARAM p) {
+ /*
+ * !
+ * <dot>
+ */
+
+ if (rde_param_i_symbol_void_start (p, 81)) return ;
+ notahead_157 (p);
+ rde_param_i_symbol_done_void (p, 81, 80);
+ return;
+ }
+
+ static void notahead_157 (RDE_PARAM p) {
+ /*
+ * !
+ * <dot>
+ */
+
+ rde_param_i_loc_push (p);
+ rde_param_i_input_next (p, 43);
+ rde_param_i_notahead_exit (p);
+ return;
+ }
+
+ /*
+ * void Symbol 'EOL'
+ */
+
+ static void sym_EOL (RDE_PARAM p) {
+ /*
+ * [\n\r]
+ */
+
+ if (rde_param_i_symbol_void_start (p, 84)) return ;
+ rde_param_i_next_class (p, "\n\r", 82);
+ rde_param_i_symbol_done_void (p, 84, 83);
+ return;
+ }
+
+ /*
+ * value Symbol 'Expression'
+ */
+
+ static void sym_Expression (RDE_PARAM p) {
+ /*
+ * x
+ * (Sequence)
+ * *
+ * x
+ * (SLASH)
+ * (Sequence)
+ */
+
+ if (rde_param_i_symbol_start_d (p, 86)) return ;
+ sequence_169 (p);
+ rde_param_i_symbol_done_d_reduce (p, 86, 85);
+ return;
+ }
+
+ static void sequence_169 (RDE_PARAM p) {
+ /*
+ * x
+ * (Sequence)
+ * *
+ * x
+ * (SLASH)
+ * (Sequence)
+ */
+
+ rde_param_i_state_push_value (p);
+ sym_Sequence (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ kleene_167 (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ static void kleene_167 (RDE_PARAM p) {
+ /*
+ * *
+ * x
+ * (SLASH)
+ * (Sequence)
+ */
+
+ while (1) {
+ rde_param_i_state_push_2 (p);
+ sequence_165 (p);
+ if (rde_param_i_kleene_close(p)) return;
+ }
+ return;
+ }
+
+ static void sequence_165 (RDE_PARAM p) {
+ /*
+ * x
+ * (SLASH)
+ * (Sequence)
+ */
+
+ rde_param_i_state_push_void (p);
+ sym_SLASH (p);
+ if (rde_param_i_seq_void2value(p)) return;
+ sym_Sequence (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ /*
+ * void Symbol 'Final'
+ */
+
+ static void sym_Final (RDE_PARAM p) {
+ /*
+ * x
+ * "END"
+ * (WHITESPACE)
+ * (SEMICOLON)
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_void_start (p, 89)) return ;
+ sequence_176 (p);
+ rde_param_i_symbol_done_void (p, 89, 88);
+ return;
+ }
+
+ static void sequence_176 (RDE_PARAM p) {
+ /*
+ * x
+ * "END"
+ * (WHITESPACE)
+ * (SEMICOLON)
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "END", 87);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_SEMICOLON (p);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * value Symbol 'Grammar'
+ */
+
+ static void sym_Grammar (RDE_PARAM p) {
+ /*
+ * x
+ * (WHITESPACE)
+ * (Header)
+ * *
+ * (Definition)
+ * (Final)
+ * (EOF)
+ */
+
+ if (rde_param_i_symbol_start_d (p, 91)) return ;
+ sequence_186 (p);
+ rde_param_i_symbol_done_d_reduce (p, 91, 90);
+ return;
+ }
+
+ static void sequence_186 (RDE_PARAM p) {
+ /*
+ * x
+ * (WHITESPACE)
+ * (Header)
+ * *
+ * (Definition)
+ * (Final)
+ * (EOF)
+ */
+
+ rde_param_i_state_push_void (p);
+ sym_WHITESPACE (p);
+ if (rde_param_i_seq_void2value(p)) return;
+ sym_Header (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ kleene_182 (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_Final (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_EOF (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ static void kleene_182 (RDE_PARAM p) {
+ /*
+ * *
+ * (Definition)
+ */
+
+ while (1) {
+ rde_param_i_state_push_2 (p);
+ sym_Definition (p);
+ if (rde_param_i_kleene_close(p)) return;
+ }
+ return;
+ }
+
+ /*
+ * leaf Symbol 'GRAPH'
+ */
+
+ static void sym_GRAPH (RDE_PARAM p) {
+ /*
+ * x
+ * "<graph>"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 94)) return ;
+ sequence_191 (p);
+ rde_param_i_symbol_done_leaf (p, 94, 93);
+ return;
+ }
+
+ static void sequence_191 (RDE_PARAM p) {
+ /*
+ * x
+ * "<graph>"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "<graph>", 92);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * value Symbol 'Header'
+ */
+
+ static void sym_Header (RDE_PARAM p) {
+ /*
+ * x
+ * (PEG)
+ * (Identifier)
+ * (StartExpr)
+ */
+
+ if (rde_param_i_symbol_start_d (p, 96)) return ;
+ sequence_197 (p);
+ rde_param_i_symbol_done_d_reduce (p, 96, 95);
+ return;
+ }
+
+ static void sequence_197 (RDE_PARAM p) {
+ /*
+ * x
+ * (PEG)
+ * (Identifier)
+ * (StartExpr)
+ */
+
+ rde_param_i_state_push_void (p);
+ sym_PEG (p);
+ if (rde_param_i_seq_void2value(p)) return;
+ sym_Identifier (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_StartExpr (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'Ident'
+ */
+
+ static void sym_Ident (RDE_PARAM p) {
+ /*
+ * x
+ * /
+ * [_:]
+ * <alpha>
+ * *
+ * /
+ * [_:]
+ * <alnum>
+ */
+
+ if (rde_param_i_symbol_start (p, 99)) return ;
+ sequence_210 (p);
+ rde_param_i_symbol_done_leaf (p, 99, 98);
+ return;
+ }
+
+ static void sequence_210 (RDE_PARAM p) {
+ /*
+ * x
+ * /
+ * [_:]
+ * <alpha>
+ * *
+ * /
+ * [_:]
+ * <alnum>
+ */
+
+ rde_param_i_state_push_void (p);
+ choice_202 (p);
+ if (rde_param_i_seq_void2void(p)) return;
+ kleene_208 (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ static void choice_202 (RDE_PARAM p) {
+ /*
+ * /
+ * [_:]
+ * <alpha>
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_class (p, "_:", 97);
+ if (rde_param_i_bra_void2void(p)) return;
+ rde_param_i_next_alpha (p, 1);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ static void kleene_208 (RDE_PARAM p) {
+ /*
+ * *
+ * /
+ * [_:]
+ * <alnum>
+ */
+
+ while (1) {
+ rde_param_i_state_push_2 (p);
+ choice_206 (p);
+ if (rde_param_i_kleene_close(p)) return;
+ }
+ return;
+ }
+
+ static void choice_206 (RDE_PARAM p) {
+ /*
+ * /
+ * [_:]
+ * <alnum>
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_class (p, "_:", 97);
+ if (rde_param_i_bra_void2void(p)) return;
+ rde_param_i_next_alnum (p, 0);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * value Symbol 'Identifier'
+ */
+
+ static void sym_Identifier (RDE_PARAM p) {
+ /*
+ * x
+ * (Ident)
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start_d (p, 101)) return ;
+ sequence_215 (p);
+ rde_param_i_symbol_done_d_reduce (p, 101, 100);
+ return;
+ }
+
+ static void sequence_215 (RDE_PARAM p) {
+ /*
+ * x
+ * (Ident)
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_value (p);
+ sym_Ident (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ /*
+ * void Symbol 'IS'
+ */
+
+ static void sym_IS (RDE_PARAM p) {
+ /*
+ * x
+ * "<-"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_void_start (p, 104)) return ;
+ sequence_220 (p);
+ rde_param_i_symbol_done_void (p, 104, 103);
+ return;
+ }
+
+ static void sequence_220 (RDE_PARAM p) {
+ /*
+ * x
+ * "<-"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "<-", 102);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'LEAF'
+ */
+
+ static void sym_LEAF (RDE_PARAM p) {
+ /*
+ * x
+ * "leaf"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 107)) return ;
+ sequence_225 (p);
+ rde_param_i_symbol_done_leaf (p, 107, 106);
+ return;
+ }
+
+ static void sequence_225 (RDE_PARAM p) {
+ /*
+ * x
+ * "leaf"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "leaf", 105);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * value Symbol 'Literal'
+ */
+
+ static void sym_Literal (RDE_PARAM p) {
+ /*
+ * /
+ * x
+ * (APOSTROPH)
+ * *
+ * x
+ * !
+ * (APOSTROPH)
+ * (Char)
+ * (APOSTROPH)
+ * (WHITESPACE)
+ * x
+ * (DAPOSTROPH)
+ * *
+ * x
+ * !
+ * (DAPOSTROPH)
+ * (Char)
+ * (DAPOSTROPH)
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start_d (p, 109)) return ;
+ choice_254 (p);
+ rde_param_i_symbol_done_d_reduce (p, 109, 108);
+ return;
+ }
+
+ static void choice_254 (RDE_PARAM p) {
+ /*
+ * /
+ * x
+ * (APOSTROPH)
+ * *
+ * x
+ * !
+ * (APOSTROPH)
+ * (Char)
+ * (APOSTROPH)
+ * (WHITESPACE)
+ * x
+ * (DAPOSTROPH)
+ * *
+ * x
+ * !
+ * (DAPOSTROPH)
+ * (Char)
+ * (DAPOSTROPH)
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_value (p);
+ sequence_239 (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sequence_252 (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ static void sequence_239 (RDE_PARAM p) {
+ /*
+ * x
+ * (APOSTROPH)
+ * *
+ * x
+ * !
+ * (APOSTROPH)
+ * (Char)
+ * (APOSTROPH)
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ sym_APOSTROPH (p);
+ if (rde_param_i_seq_void2value(p)) return;
+ kleene_235 (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_APOSTROPH (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ static void kleene_235 (RDE_PARAM p) {
+ /*
+ * *
+ * x
+ * !
+ * (APOSTROPH)
+ * (Char)
+ */
+
+ while (1) {
+ rde_param_i_state_push_2 (p);
+ sequence_233 (p);
+ if (rde_param_i_kleene_close(p)) return;
+ }
+ return;
+ }
+
+ static void sequence_233 (RDE_PARAM p) {
+ /*
+ * x
+ * !
+ * (APOSTROPH)
+ * (Char)
+ */
+
+ rde_param_i_state_push_void (p);
+ notahead_230 (p);
+ if (rde_param_i_seq_void2value(p)) return;
+ sym_Char (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ static void notahead_230 (RDE_PARAM p) {
+ /*
+ * !
+ * (APOSTROPH)
+ */
+
+ rde_param_i_loc_push (p);
+ sym_APOSTROPH (p);
+ rde_param_i_notahead_exit (p);
+ return;
+ }
+
+ static void sequence_252 (RDE_PARAM p) {
+ /*
+ * x
+ * (DAPOSTROPH)
+ * *
+ * x
+ * !
+ * (DAPOSTROPH)
+ * (Char)
+ * (DAPOSTROPH)
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ sym_DAPOSTROPH (p);
+ if (rde_param_i_seq_void2value(p)) return;
+ kleene_248 (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_DAPOSTROPH (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ static void kleene_248 (RDE_PARAM p) {
+ /*
+ * *
+ * x
+ * !
+ * (DAPOSTROPH)
+ * (Char)
+ */
+
+ while (1) {
+ rde_param_i_state_push_2 (p);
+ sequence_246 (p);
+ if (rde_param_i_kleene_close(p)) return;
+ }
+ return;
+ }
+
+ static void sequence_246 (RDE_PARAM p) {
+ /*
+ * x
+ * !
+ * (DAPOSTROPH)
+ * (Char)
+ */
+
+ rde_param_i_state_push_void (p);
+ notahead_243 (p);
+ if (rde_param_i_seq_void2value(p)) return;
+ sym_Char (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ static void notahead_243 (RDE_PARAM p) {
+ /*
+ * !
+ * (DAPOSTROPH)
+ */
+
+ rde_param_i_loc_push (p);
+ sym_DAPOSTROPH (p);
+ rde_param_i_notahead_exit (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'LOWER'
+ */
+
+ static void sym_LOWER (RDE_PARAM p) {
+ /*
+ * x
+ * "<lower>"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 112)) return ;
+ sequence_259 (p);
+ rde_param_i_symbol_done_leaf (p, 112, 111);
+ return;
+ }
+
+ static void sequence_259 (RDE_PARAM p) {
+ /*
+ * x
+ * "<lower>"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "<lower>", 110);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'NOT'
+ */
+
+ static void sym_NOT (RDE_PARAM p) {
+ /*
+ * x
+ * '!'
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 115)) return ;
+ sequence_264 (p);
+ rde_param_i_symbol_done_leaf (p, 115, 114);
+ return;
+ }
+
+ static void sequence_264 (RDE_PARAM p) {
+ /*
+ * x
+ * '!'
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_char (p, "!", 113);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * void Symbol 'OPEN'
+ */
+
+ static void sym_OPEN (RDE_PARAM p) {
+ /*
+ * x
+ * '\('
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_void_start (p, 118)) return ;
+ sequence_269 (p);
+ rde_param_i_symbol_done_void (p, 118, 117);
+ return;
+ }
+
+ static void sequence_269 (RDE_PARAM p) {
+ /*
+ * x
+ * '\('
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_char (p, "(", 116);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * void Symbol 'OPENB'
+ */
+
+ static void sym_OPENB (RDE_PARAM p) {
+ /*
+ * '['
+ */
+
+ if (rde_param_i_symbol_void_start (p, 121)) return ;
+ rde_param_i_next_char (p, "[", 119);
+ rde_param_i_symbol_done_void (p, 121, 120);
+ return;
+ }
+
+ /*
+ * void Symbol 'PEG'
+ */
+
+ static void sym_PEG (RDE_PARAM p) {
+ /*
+ * x
+ * "PEG"
+ * !
+ * /
+ * [_:]
+ * <alnum>
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_void_start (p, 124)) return ;
+ sequence_281 (p);
+ rde_param_i_symbol_done_void (p, 124, 123);
+ return;
+ }
+
+ static void sequence_281 (RDE_PARAM p) {
+ /*
+ * x
+ * "PEG"
+ * !
+ * /
+ * [_:]
+ * <alnum>
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "PEG", 122);
+ if (rde_param_i_seq_void2void(p)) return;
+ notahead_278 (p);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ static void notahead_278 (RDE_PARAM p) {
+ /*
+ * !
+ * /
+ * [_:]
+ * <alnum>
+ */
+
+ rde_param_i_loc_push (p);
+ choice_206 (p);
+ rde_param_i_notahead_exit (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'PLUS'
+ */
+
+ static void sym_PLUS (RDE_PARAM p) {
+ /*
+ * x
+ * '+'
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 127)) return ;
+ sequence_286 (p);
+ rde_param_i_symbol_done_leaf (p, 127, 126);
+ return;
+ }
+
+ static void sequence_286 (RDE_PARAM p) {
+ /*
+ * x
+ * '+'
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_char (p, "+", 125);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * value Symbol 'Prefix'
+ */
+
+ static void sym_Prefix (RDE_PARAM p) {
+ /*
+ * x
+ * ?
+ * /
+ * (AND)
+ * (NOT)
+ * (Suffix)
+ */
+
+ if (rde_param_i_symbol_start_d (p, 129)) return ;
+ sequence_296 (p);
+ rde_param_i_symbol_done_d_reduce (p, 129, 128);
+ return;
+ }
+
+ static void sequence_296 (RDE_PARAM p) {
+ /*
+ * x
+ * ?
+ * /
+ * (AND)
+ * (NOT)
+ * (Suffix)
+ */
+
+ rde_param_i_state_push_value (p);
+ optional_293 (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_Suffix (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ static void optional_293 (RDE_PARAM p) {
+ /*
+ * ?
+ * /
+ * (AND)
+ * (NOT)
+ */
+
+ rde_param_i_state_push_2 (p);
+ choice_291 (p);
+ rde_param_i_state_merge_ok (p);
+ return;
+ }
+
+ static void choice_291 (RDE_PARAM p) {
+ /*
+ * /
+ * (AND)
+ * (NOT)
+ */
+
+ rde_param_i_state_push_value (p);
+ sym_AND (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_NOT (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ /*
+ * value Symbol 'Primary'
+ */
+
+ static void sym_Primary (RDE_PARAM p) {
+ /*
+ * /
+ * (ALNUM)
+ * (ALPHA)
+ * (ASCII)
+ * (CONTROL)
+ * (DDIGIT)
+ * (DIGIT)
+ * (GRAPH)
+ * (LOWER)
+ * (PRINTABLE)
+ * (PUNCT)
+ * (SPACE)
+ * (UPPER)
+ * (WORDCHAR)
+ * (XDIGIT)
+ * (Identifier)
+ * x
+ * (OPEN)
+ * (Expression)
+ * (CLOSE)
+ * (Literal)
+ * (Class)
+ * (DOT)
+ */
+
+ if (rde_param_i_symbol_start_d (p, 131)) return ;
+ choice_322 (p);
+ rde_param_i_symbol_done_d_reduce (p, 131, 130);
+ return;
+ }
+
+ static void choice_322 (RDE_PARAM p) {
+ /*
+ * /
+ * (ALNUM)
+ * (ALPHA)
+ * (ASCII)
+ * (CONTROL)
+ * (DDIGIT)
+ * (DIGIT)
+ * (GRAPH)
+ * (LOWER)
+ * (PRINTABLE)
+ * (PUNCT)
+ * (SPACE)
+ * (UPPER)
+ * (WORDCHAR)
+ * (XDIGIT)
+ * (Identifier)
+ * x
+ * (OPEN)
+ * (Expression)
+ * (CLOSE)
+ * (Literal)
+ * (Class)
+ * (DOT)
+ */
+
+ rde_param_i_state_push_value (p);
+ sym_ALNUM (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_ALPHA (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_ASCII (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_CONTROL (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_DDIGIT (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_DIGIT (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_GRAPH (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_LOWER (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_PRINTABLE (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_PUNCT (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_SPACE (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_UPPER (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_WORDCHAR (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_XDIGIT (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_Identifier (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sequence_317 (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_Literal (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_Class (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_DOT (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ static void sequence_317 (RDE_PARAM p) {
+ /*
+ * x
+ * (OPEN)
+ * (Expression)
+ * (CLOSE)
+ */
+
+ rde_param_i_state_push_void (p);
+ sym_OPEN (p);
+ if (rde_param_i_seq_void2value(p)) return;
+ sym_Expression (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_CLOSE (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'PRINTABLE'
+ */
+
+ static void sym_PRINTABLE (RDE_PARAM p) {
+ /*
+ * x
+ * "<print>"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 134)) return ;
+ sequence_327 (p);
+ rde_param_i_symbol_done_leaf (p, 134, 133);
+ return;
+ }
+
+ static void sequence_327 (RDE_PARAM p) {
+ /*
+ * x
+ * "<print>"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "<print>", 132);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'PUNCT'
+ */
+
+ static void sym_PUNCT (RDE_PARAM p) {
+ /*
+ * x
+ * "<punct>"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 137)) return ;
+ sequence_332 (p);
+ rde_param_i_symbol_done_leaf (p, 137, 136);
+ return;
+ }
+
+ static void sequence_332 (RDE_PARAM p) {
+ /*
+ * x
+ * "<punct>"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "<punct>", 135);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'QUESTION'
+ */
+
+ static void sym_QUESTION (RDE_PARAM p) {
+ /*
+ * x
+ * '?'
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 140)) return ;
+ sequence_337 (p);
+ rde_param_i_symbol_done_leaf (p, 140, 139);
+ return;
+ }
+
+ static void sequence_337 (RDE_PARAM p) {
+ /*
+ * x
+ * '?'
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_char (p, "?", 138);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * value Symbol 'Range'
+ */
+
+ static void sym_Range (RDE_PARAM p) {
+ /*
+ * /
+ * x
+ * (Char)
+ * (TO)
+ * (Char)
+ * (Char)
+ */
+
+ if (rde_param_i_symbol_start_d (p, 142)) return ;
+ choice_346 (p);
+ rde_param_i_symbol_done_d_reduce (p, 142, 141);
+ return;
+ }
+
+ static void choice_346 (RDE_PARAM p) {
+ /*
+ * /
+ * x
+ * (Char)
+ * (TO)
+ * (Char)
+ * (Char)
+ */
+
+ rde_param_i_state_push_value (p);
+ sequence_343 (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_Char (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ static void sequence_343 (RDE_PARAM p) {
+ /*
+ * x
+ * (Char)
+ * (TO)
+ * (Char)
+ */
+
+ rde_param_i_state_push_value (p);
+ sym_Char (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_TO (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ sym_Char (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ /*
+ * void Symbol 'SEMICOLON'
+ */
+
+ static void sym_SEMICOLON (RDE_PARAM p) {
+ /*
+ * x
+ * ';'
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_void_start (p, 145)) return ;
+ sequence_351 (p);
+ rde_param_i_symbol_done_void (p, 145, 144);
+ return;
+ }
+
+ static void sequence_351 (RDE_PARAM p) {
+ /*
+ * x
+ * ';'
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_char (p, ";", 143);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * value Symbol 'Sequence'
+ */
+
+ static void sym_Sequence (RDE_PARAM p) {
+ /*
+ * +
+ * (Prefix)
+ */
+
+ if (rde_param_i_symbol_start_d (p, 147)) return ;
+ poskleene_355 (p);
+ rde_param_i_symbol_done_d_reduce (p, 147, 146);
+ return;
+ }
+
+ static void poskleene_355 (RDE_PARAM p) {
+ /*
+ * +
+ * (Prefix)
+ */
+
+ rde_param_i_loc_push (p);
+ sym_Prefix (p);
+ if (rde_param_i_kleene_abort(p)) return;
+ while (1) {
+ rde_param_i_state_push_2 (p);
+ sym_Prefix (p);
+ if (rde_param_i_kleene_close(p)) return;
+ }
+ return;
+ }
+
+ /*
+ * void Symbol 'SLASH'
+ */
+
+ static void sym_SLASH (RDE_PARAM p) {
+ /*
+ * x
+ * '/'
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_void_start (p, 150)) return ;
+ sequence_360 (p);
+ rde_param_i_symbol_done_void (p, 150, 149);
+ return;
+ }
+
+ static void sequence_360 (RDE_PARAM p) {
+ /*
+ * x
+ * '/'
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_char (p, "/", 148);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'SPACE'
+ */
+
+ static void sym_SPACE (RDE_PARAM p) {
+ /*
+ * x
+ * "<space>"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 153)) return ;
+ sequence_365 (p);
+ rde_param_i_symbol_done_leaf (p, 153, 152);
+ return;
+ }
+
+ static void sequence_365 (RDE_PARAM p) {
+ /*
+ * x
+ * "<space>"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "<space>", 151);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'STAR'
+ */
+
+ static void sym_STAR (RDE_PARAM p) {
+ /*
+ * x
+ * '*'
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 156)) return ;
+ sequence_370 (p);
+ rde_param_i_symbol_done_leaf (p, 156, 155);
+ return;
+ }
+
+ static void sequence_370 (RDE_PARAM p) {
+ /*
+ * x
+ * '*'
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_char (p, "*", 154);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * value Symbol 'StartExpr'
+ */
+
+ static void sym_StartExpr (RDE_PARAM p) {
+ /*
+ * x
+ * (OPEN)
+ * (Expression)
+ * (CLOSE)
+ */
+
+ if (rde_param_i_symbol_start_d (p, 158)) return ;
+ sequence_317 (p);
+ rde_param_i_symbol_done_d_reduce (p, 158, 157);
+ return;
+ }
+
+ /*
+ * value Symbol 'Suffix'
+ */
+
+ static void sym_Suffix (RDE_PARAM p) {
+ /*
+ * x
+ * (Primary)
+ * ?
+ * /
+ * (QUESTION)
+ * (STAR)
+ * (PLUS)
+ */
+
+ if (rde_param_i_symbol_start_d (p, 160)) return ;
+ sequence_386 (p);
+ rde_param_i_symbol_done_d_reduce (p, 160, 159);
+ return;
+ }
+
+ static void sequence_386 (RDE_PARAM p) {
+ /*
+ * x
+ * (Primary)
+ * ?
+ * /
+ * (QUESTION)
+ * (STAR)
+ * (PLUS)
+ */
+
+ rde_param_i_state_push_value (p);
+ sym_Primary (p);
+ if (rde_param_i_seq_value2value(p)) return;
+ optional_384 (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ static void optional_384 (RDE_PARAM p) {
+ /*
+ * ?
+ * /
+ * (QUESTION)
+ * (STAR)
+ * (PLUS)
+ */
+
+ rde_param_i_state_push_2 (p);
+ choice_382 (p);
+ rde_param_i_state_merge_ok (p);
+ return;
+ }
+
+ static void choice_382 (RDE_PARAM p) {
+ /*
+ * /
+ * (QUESTION)
+ * (STAR)
+ * (PLUS)
+ */
+
+ rde_param_i_state_push_value (p);
+ sym_QUESTION (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_STAR (p);
+ if (rde_param_i_bra_value2value(p)) return;
+ sym_PLUS (p);
+ rde_param_i_state_merge_value (p);
+ return;
+ }
+
+ /*
+ * void Symbol 'TO'
+ */
+
+ static void sym_TO (RDE_PARAM p) {
+ /*
+ * '-'
+ */
+
+ if (rde_param_i_symbol_void_start (p, 163)) return ;
+ rde_param_i_next_char (p, "-", 161);
+ rde_param_i_symbol_done_void (p, 163, 162);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'UPPER'
+ */
+
+ static void sym_UPPER (RDE_PARAM p) {
+ /*
+ * x
+ * "<upper>"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 166)) return ;
+ sequence_393 (p);
+ rde_param_i_symbol_done_leaf (p, 166, 165);
+ return;
+ }
+
+ static void sequence_393 (RDE_PARAM p) {
+ /*
+ * x
+ * "<upper>"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "<upper>", 164);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'VOID'
+ */
+
+ static void sym_VOID (RDE_PARAM p) {
+ /*
+ * x
+ * "void"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 169)) return ;
+ sequence_398 (p);
+ rde_param_i_symbol_done_leaf (p, 169, 168);
+ return;
+ }
+
+ static void sequence_398 (RDE_PARAM p) {
+ /*
+ * x
+ * "void"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "void", 167);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * void Symbol 'WHITESPACE'
+ */
+
+ static void sym_WHITESPACE (RDE_PARAM p) {
+ /*
+ * *
+ * /
+ * <space>
+ * (COMMENT)
+ */
+
+ if (rde_param_i_symbol_void_start (p, 171)) return ;
+ kleene_405 (p);
+ rde_param_i_symbol_done_void (p, 171, 170);
+ return;
+ }
+
+ static void kleene_405 (RDE_PARAM p) {
+ /*
+ * *
+ * /
+ * <space>
+ * (COMMENT)
+ */
+
+ while (1) {
+ rde_param_i_state_push_2 (p);
+ choice_403 (p);
+ if (rde_param_i_kleene_close(p)) return;
+ }
+ return;
+ }
+
+ static void choice_403 (RDE_PARAM p) {
+ /*
+ * /
+ * <space>
+ * (COMMENT)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_space (p, 10);
+ if (rde_param_i_bra_void2void(p)) return;
+ sym_COMMENT (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'WORDCHAR'
+ */
+
+ static void sym_WORDCHAR (RDE_PARAM p) {
+ /*
+ * x
+ * "<wordchar>"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 174)) return ;
+ sequence_410 (p);
+ rde_param_i_symbol_done_leaf (p, 174, 173);
+ return;
+ }
+
+ static void sequence_410 (RDE_PARAM p) {
+ /*
+ * x
+ * "<wordchar>"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "<wordchar>", 172);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ /*
+ * leaf Symbol 'XDIGIT'
+ */
+
+ static void sym_XDIGIT (RDE_PARAM p) {
+ /*
+ * x
+ * "<xdigit>"
+ * (WHITESPACE)
+ */
+
+ if (rde_param_i_symbol_start (p, 177)) return ;
+ sequence_415 (p);
+ rde_param_i_symbol_done_leaf (p, 177, 176);
+ return;
+ }
+
+ static void sequence_415 (RDE_PARAM p) {
+ /*
+ * x
+ * "<xdigit>"
+ * (WHITESPACE)
+ */
+
+ rde_param_i_state_push_void (p);
+ rde_param_i_next_str (p, "<xdigit>", 175);
+ if (rde_param_i_seq_void2void(p)) return;
+ sym_WHITESPACE (p);
+ rde_param_i_state_merge_void (p);
+ return;
+ }
+
+ }
+
+ ## END of GENERATED CODE. DO NOT EDIT.
+ # # ## ### ###### ######## #############
+
+ # # ## ### ###### ######## #############
+ ## Global PARSER management, per interp
+
+ critcl::ccode {
+ /* -*- c -*- */
+
+ typedef struct PARSERg {
+ long int counter;
+ char buf [50];
+ } PARSERg;
+
+ static void
+ PARSERgRelease (ClientData cd, Tcl_Interp* interp)
+ {
+ ckfree((char*) cd);
+ }
+
+ static const char*
+ PARSERnewName (Tcl_Interp* interp)
+ {
+#define KEY "tcllib/parser/pt_parse_peg_c/critcl"
+
+ Tcl_InterpDeleteProc* proc = PARSERgRelease;
+ PARSERg* parserg;
+
+ parserg = Tcl_GetAssocData (interp, KEY, &proc);
+ if (parserg == NULL) {
+ parserg = (PARSERg*) ckalloc (sizeof (PARSERg));
+ parserg->counter = 0;
+
+ Tcl_SetAssocData (interp, KEY, proc,
+ (ClientData) parserg);
+ }
+
+ parserg->counter ++;
+ sprintf (parserg->buf, "peg%ld", parserg->counter);
+ return parserg->buf;
+#undef KEY
+ }
+
+ static void
+ PARSERdeleteCmd (ClientData clientData)
+ {
+ /*
+ * Release the whole PARSER
+ * (Low-level engine only actually).
+ */
+ rde_param_del ((RDE_PARAM) clientData);
+ }
+ }
+
+ # # ## ### ##### ######## #############
+ ## Functions implementing the object methods, and helper.
+
+ critcl::ccode {
+ static int COMPLETE (RDE_PARAM p, Tcl_Interp* interp);
+
+ static int parser_PARSE (RDE_PARAM p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+ {
+ int mode;
+ Tcl_Channel chan;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "chan");
+ return TCL_ERROR;
+ }
+
+ chan = Tcl_GetChannel(interp,
+ Tcl_GetString (objv[2]),
+ &mode);
+
+ if (!chan) {
+ return TCL_ERROR;
+ }
+
+ rde_param_reset (p, chan);
+ MAIN (p) ; /* Entrypoint for the generated code. */
+ return COMPLETE (p, interp);
+ }
+
+ static int parser_PARSET (RDE_PARAM p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+ {
+ char* buf;
+ int len;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "text");
+ return TCL_ERROR;
+ }
+
+ buf = Tcl_GetStringFromObj (objv[2], &len);
+
+ rde_param_reset (p, NULL);
+ rde_param_data (p, buf, len);
+ MAIN (p) ; /* Entrypoint for the generated code. */
+ return COMPLETE (p, interp);
+ }
+
+ /* See also rde_critcl/m.c, param_COMPLETE() */
+ static int COMPLETE (RDE_PARAM p, Tcl_Interp* interp)
+ {
+ if (rde_param_query_st (p)) {
+ long int ac;
+ Tcl_Obj** av;
+
+ rde_param_query_ast (p, &ac, &av);
+
+ if (ac > 1) {
+ Tcl_Obj** lv = NALLOC (3+ac, Tcl_Obj*);
+
+ memcpy(lv + 3, av, ac * sizeof (Tcl_Obj*));
+ lv [0] = Tcl_NewObj ();
+ lv [1] = Tcl_NewIntObj (1 + rde_param_query_lstop (p));
+ lv [2] = Tcl_NewIntObj (rde_param_query_cl (p));
+
+ Tcl_SetObjResult (interp, Tcl_NewListObj (3, lv));
+ ckfree ((char*) lv);
+
+ } else if (ac == 0) {
+ /*
+ * Match, but no AST. This is possible if the grammar
+ * consists of only the start expression.
+ */
+ Tcl_SetObjResult (interp, Tcl_NewStringObj ("",-1));
+ } else {
+ Tcl_SetObjResult (interp, av [0]);
+ }
+
+ return TCL_OK;
+ } else {
+ Tcl_Obj* xv [1];
+ const ERROR_STATE* er = rde_param_query_er (p);
+ Tcl_Obj* res = rde_param_query_er_tcl (p, er);
+ /* res = list (location, list(msg)) */
+
+ /* Stick the exception type-tag before the existing elements */
+ xv [0] = Tcl_NewStringObj ("pt::rde",-1);
+ Tcl_ListObjReplace(interp, res, 0, 0, 1, xv);
+
+ Tcl_SetErrorCode (interp, "PT", "RDE", "SYNTAX", NULL);
+ Tcl_SetObjResult (interp, res);
+ return TCL_ERROR;
+ }
+ }
+ }
+
+ # # ## ### ##### ######## #############
+ ## Object command, method dispatch.
+
+ critcl::ccode {
+ static int parser_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+ {
+ RDE_PARAM p = (RDE_PARAM) cd;
+ int m, res;
+
+ static CONST char* methods [] = {
+ "destroy", "parse", "parset", NULL
+ };
+ enum methods {
+ M_DESTROY, M_PARSE, M_PARSET
+ };
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs (interp, objc, objv, "option ?arg arg ...?");
+ return TCL_ERROR;
+ } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option",
+ 0, &m) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /* Dispatch to methods. They check the #args in
+ * detail before performing the requested
+ * functionality
+ */
+
+ switch (m) {
+ case M_DESTROY:
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_DeleteCommandFromToken(interp, (Tcl_Command) rde_param_query_clientdata (p));
+ return TCL_OK;
+
+ case M_PARSE: res = parser_PARSE (p, interp, objc, objv); break;
+ case M_PARSET: res = parser_PARSET (p, interp, objc, objv); break;
+ default:
+ /* Not coming to this place */
+ ASSERT (0,"Reached unreachable location");
+ }
+
+ return res;
+ }
+ }
+
+ # # ## ### ##### ######## #############
+ # Class command, i.e. object construction.
+
+ critcl::ccommand peg_critcl {dummy interp objc objv} {
+ /*
+ * Syntax: No arguments beyond the name
+ */
+
+ RDE_PARAM parser;
+ CONST char* name;
+ Tcl_Obj* fqn;
+ Tcl_CmdInfo ci;
+ Tcl_Command c;
+
+#define USAGE "?name?"
+
+ if ((objc != 2) && (objc != 1)) {
+ Tcl_WrongNumArgs (interp, 1, objv, USAGE);
+ return TCL_ERROR;
+ }
+
+ if (objc < 2) {
+ name = PARSERnewName (interp);
+ } else {
+ name = Tcl_GetString (objv [1]);
+ }
+
+ if (!Tcl_StringMatch (name, "::*")) {
+ /* Relative name. Prefix with current namespace */
+
+ Tcl_Eval (interp, "namespace current");
+ fqn = Tcl_GetObjResult (interp);
+ fqn = Tcl_DuplicateObj (fqn);
+ Tcl_IncrRefCount (fqn);
+
+ if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) {
+ Tcl_AppendToObj (fqn, "::", -1);
+ }
+ Tcl_AppendToObj (fqn, name, -1);
+ } else {
+ fqn = Tcl_NewStringObj (name, -1);
+ Tcl_IncrRefCount (fqn);
+ }
+ Tcl_ResetResult (interp);
+
+ if (Tcl_GetCommandInfo (interp,
+ Tcl_GetString (fqn),
+ &ci)) {
+ Tcl_Obj* err;
+
+ err = Tcl_NewObj ();
+ Tcl_AppendToObj (err, "command \"", -1);
+ Tcl_AppendObjToObj (err, fqn);
+ Tcl_AppendToObj (err, "\" already exists", -1);
+
+ Tcl_DecrRefCount (fqn);
+ Tcl_SetObjResult (interp, err);
+ return TCL_ERROR;
+ }
+
+ parser = rde_param_new (sizeof(p_string)/sizeof(char*), (char**) p_string);
+ c = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn),
+ parser_objcmd, (ClientData) parser,
+ PARSERdeleteCmd);
+ rde_param_clientdata (parser, (ClientData) c);
+ Tcl_SetObjResult (interp, fqn);
+ Tcl_DecrRefCount (fqn);
+ return TCL_OK;
+ }
+
+ ##
+ # # ## ### ##### ######## #############
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready (Note: Our package provide is at the top).
+return
diff --git a/tcllib/modules/pt/pt_parse_peg_tcl.tcl b/tcllib/modules/pt/pt_parse_peg_tcl.tcl
new file mode 100644
index 0000000..297d76b
--- /dev/null
+++ b/tcllib/modules/pt/pt_parse_peg_tcl.tcl
@@ -0,0 +1,2431 @@
+## -*- tcl -*-
+##
+## Snit-based Tcl/PARAM implementation of the parsing
+## expression grammar
+##
+## PEG
+##
+## Generated from file 3_peg_itself
+## for user aku
+##
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.5
+package require snit
+package require pt::rde ; # Implementation of the PARAM
+ # virtual machine underlying the
+ # Tcl/PARAM code used below.
+
+# # ## ### ##### ######## ############# #####################
+##
+
+snit::type ::pt::parse::peg_tcl {
+ # # ## ### ##### ######## #############
+ ## Public API
+
+ constructor {} {
+ # Create the runtime supporting the parsing process.
+ set myparser [pt::rde ${selfns}::ENGINE]
+ return
+ }
+
+ method parse {channel} {
+ $myparser reset $channel
+ MAIN ; # Entrypoint for the generated code.
+ return [$myparser complete]
+ }
+
+ method parset {text} {
+ $myparser reset
+ $myparser data $text
+ MAIN ; # Entrypoint for the generated code.
+ return [$myparser complete]
+ }
+
+ # # ## ### ###### ######## #############
+ ## Configuration
+
+ pragma -hastypeinfo 0
+ pragma -hastypemethods 0
+ pragma -hasinfo 0
+ pragma -simpledispatch 1
+
+ # # ## ### ###### ######## #############
+ ## Data structures.
+
+ variable myparser {} ; # Our instantiation of the PARAM.
+
+ # # ## ### ###### ######## #############
+ ## BEGIN of GENERATED CODE. DO NOT EDIT.
+
+ #
+ # Grammar Start Expression
+ #
+
+ proc MAIN {} { upvar 1 myparser myparser
+ sym_Grammar
+ return
+ }
+
+ #
+ # leaf Symbol 'ALNUM'
+ #
+
+ proc sym_ALNUM {} { upvar 1 myparser myparser
+ # x
+ # "<alnum>"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start ALNUM
+ sequence_4
+ $myparser si:void_leaf_symbol_end ALNUM
+ return
+ }
+
+ proc sequence_4 {} { upvar 1 myparser myparser
+ # x
+ # "<alnum>"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str <alnum>
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'ALPHA'
+ #
+
+ proc sym_ALPHA {} { upvar 1 myparser myparser
+ # x
+ # "<alpha>"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start ALPHA
+ sequence_9
+ $myparser si:void_leaf_symbol_end ALPHA
+ return
+ }
+
+ proc sequence_9 {} { upvar 1 myparser myparser
+ # x
+ # "<alpha>"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str <alpha>
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'AND'
+ #
+
+ proc sym_AND {} { upvar 1 myparser myparser
+ # x
+ # '&'
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start AND
+ sequence_14
+ $myparser si:void_leaf_symbol_end AND
+ return
+ }
+
+ proc sequence_14 {} { upvar 1 myparser myparser
+ # x
+ # '&'
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_char &
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # void Symbol 'APOSTROPH'
+ #
+
+ proc sym_APOSTROPH {} { upvar 1 myparser myparser
+ # '''
+
+ $myparser si:void_void_symbol_start APOSTROPH
+ $myparser si:next_char '
+ $myparser si:void_clear_symbol_end APOSTROPH
+ return
+ }
+
+ #
+ # leaf Symbol 'ASCII'
+ #
+
+ proc sym_ASCII {} { upvar 1 myparser myparser
+ # x
+ # "<ascii>"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start ASCII
+ sequence_21
+ $myparser si:void_leaf_symbol_end ASCII
+ return
+ }
+
+ proc sequence_21 {} { upvar 1 myparser myparser
+ # x
+ # "<ascii>"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str <ascii>
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # value Symbol 'Attribute'
+ #
+
+ proc sym_Attribute {} { upvar 1 myparser myparser
+ # x
+ # /
+ # (VOID)
+ # (LEAF)
+ # (COLON)
+
+ $myparser si:value_symbol_start Attribute
+ sequence_29
+ $myparser si:reduce_symbol_end Attribute
+ return
+ }
+
+ proc sequence_29 {} { upvar 1 myparser myparser
+ # x
+ # /
+ # (VOID)
+ # (LEAF)
+ # (COLON)
+
+ $myparser si:value_state_push
+ choice_26
+ $myparser si:valuevalue_part
+ sym_COLON
+ $myparser si:value_state_merge
+ return
+ }
+
+ proc choice_26 {} { upvar 1 myparser myparser
+ # /
+ # (VOID)
+ # (LEAF)
+
+ $myparser si:value_state_push
+ sym_VOID
+ $myparser si:valuevalue_branch
+ sym_LEAF
+ $myparser si:value_state_merge
+ return
+ }
+
+ #
+ # value Symbol 'Char'
+ #
+
+ proc sym_Char {} { upvar 1 myparser myparser
+ # /
+ # (CharSpecial)
+ # (CharOctalFull)
+ # (CharOctalPart)
+ # (CharUnicode)
+ # (CharUnescaped)
+
+ $myparser si:value_symbol_start Char
+ choice_37
+ $myparser si:reduce_symbol_end Char
+ return
+ }
+
+ proc choice_37 {} { upvar 1 myparser myparser
+ # /
+ # (CharSpecial)
+ # (CharOctalFull)
+ # (CharOctalPart)
+ # (CharUnicode)
+ # (CharUnescaped)
+
+ $myparser si:value_state_push
+ sym_CharSpecial
+ $myparser si:valuevalue_branch
+ sym_CharOctalFull
+ $myparser si:valuevalue_branch
+ sym_CharOctalPart
+ $myparser si:valuevalue_branch
+ sym_CharUnicode
+ $myparser si:valuevalue_branch
+ sym_CharUnescaped
+ $myparser si:value_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'CharOctalFull'
+ #
+
+ proc sym_CharOctalFull {} { upvar 1 myparser myparser
+ # x
+ # '\'
+ # range (0 .. 2)
+ # range (0 .. 7)
+ # range (0 .. 7)
+
+ $myparser si:void_symbol_start CharOctalFull
+ sequence_44
+ $myparser si:void_leaf_symbol_end CharOctalFull
+ return
+ }
+
+ proc sequence_44 {} { upvar 1 myparser myparser
+ # x
+ # '\'
+ # range (0 .. 2)
+ # range (0 .. 7)
+ # range (0 .. 7)
+
+ $myparser si:void_state_push
+ $myparser si:next_char \134
+ $myparser si:voidvoid_part
+ $myparser si:next_range 0 2
+ $myparser si:voidvoid_part
+ $myparser si:next_range 0 7
+ $myparser si:voidvoid_part
+ $myparser si:next_range 0 7
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'CharOctalPart'
+ #
+
+ proc sym_CharOctalPart {} { upvar 1 myparser myparser
+ # x
+ # '\'
+ # range (0 .. 7)
+ # ?
+ # range (0 .. 7)
+
+ $myparser si:void_symbol_start CharOctalPart
+ sequence_52
+ $myparser si:void_leaf_symbol_end CharOctalPart
+ return
+ }
+
+ proc sequence_52 {} { upvar 1 myparser myparser
+ # x
+ # '\'
+ # range (0 .. 7)
+ # ?
+ # range (0 .. 7)
+
+ $myparser si:void_state_push
+ $myparser si:next_char \134
+ $myparser si:voidvoid_part
+ $myparser si:next_range 0 7
+ $myparser si:voidvoid_part
+ optional_50
+ $myparser si:void_state_merge
+ return
+ }
+
+ proc optional_50 {} { upvar 1 myparser myparser
+ # ?
+ # range (0 .. 7)
+
+ $myparser si:void2_state_push
+ $myparser si:next_range 0 7
+ $myparser si:void_state_merge_ok
+ return
+ }
+
+ #
+ # leaf Symbol 'CharSpecial'
+ #
+
+ proc sym_CharSpecial {} { upvar 1 myparser myparser
+ # x
+ # '\'
+ # [nrt'\"[]\]
+
+ $myparser si:void_symbol_start CharSpecial
+ sequence_57
+ $myparser si:void_leaf_symbol_end CharSpecial
+ return
+ }
+
+ proc sequence_57 {} { upvar 1 myparser myparser
+ # x
+ # '\'
+ # [nrt'\"[]\]
+
+ $myparser si:void_state_push
+ $myparser si:next_char \134
+ $myparser si:voidvoid_part
+ $myparser si:next_class nrt'\42\133\135\134
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'CharUnescaped'
+ #
+
+ proc sym_CharUnescaped {} { upvar 1 myparser myparser
+ # x
+ # !
+ # '\'
+ # <dot>
+
+ $myparser si:void_symbol_start CharUnescaped
+ sequence_64
+ $myparser si:void_leaf_symbol_end CharUnescaped
+ return
+ }
+
+ proc sequence_64 {} { upvar 1 myparser myparser
+ # x
+ # !
+ # '\'
+ # <dot>
+
+ $myparser si:void_state_push
+ notahead_61
+ $myparser si:voidvoid_part
+ $myparser i_input_next dot
+ $myparser si:void_state_merge
+ return
+ }
+
+ proc notahead_61 {} { upvar 1 myparser myparser
+ # !
+ # '\'
+
+ $myparser i_loc_push
+ $myparser si:next_char \134
+ $myparser si:void_notahead_exit
+ return
+ }
+
+ #
+ # leaf Symbol 'CharUnicode'
+ #
+
+ proc sym_CharUnicode {} { upvar 1 myparser myparser
+ # x
+ # "\u"
+ # <xdigit>
+ # ?
+ # x
+ # <xdigit>
+ # ?
+ # x
+ # <xdigit>
+ # ?
+ # <xdigit>
+
+ $myparser si:void_symbol_start CharUnicode
+ sequence_82
+ $myparser si:void_leaf_symbol_end CharUnicode
+ return
+ }
+
+ proc sequence_82 {} { upvar 1 myparser myparser
+ # x
+ # "\u"
+ # <xdigit>
+ # ?
+ # x
+ # <xdigit>
+ # ?
+ # x
+ # <xdigit>
+ # ?
+ # <xdigit>
+
+ $myparser si:void_state_push
+ $myparser si:next_str \134u
+ $myparser si:voidvoid_part
+ $myparser si:next_xdigit
+ $myparser si:voidvoid_part
+ optional_80
+ $myparser si:void_state_merge
+ return
+ }
+
+ proc optional_80 {} { upvar 1 myparser myparser
+ # ?
+ # x
+ # <xdigit>
+ # ?
+ # x
+ # <xdigit>
+ # ?
+ # <xdigit>
+
+ $myparser si:void2_state_push
+ sequence_78
+ $myparser si:void_state_merge_ok
+ return
+ }
+
+ proc sequence_78 {} { upvar 1 myparser myparser
+ # x
+ # <xdigit>
+ # ?
+ # x
+ # <xdigit>
+ # ?
+ # <xdigit>
+
+ $myparser si:void_state_push
+ $myparser si:next_xdigit
+ $myparser si:voidvoid_part
+ optional_76
+ $myparser si:void_state_merge
+ return
+ }
+
+ proc optional_76 {} { upvar 1 myparser myparser
+ # ?
+ # x
+ # <xdigit>
+ # ?
+ # <xdigit>
+
+ $myparser si:void2_state_push
+ sequence_74
+ $myparser si:void_state_merge_ok
+ return
+ }
+
+ proc sequence_74 {} { upvar 1 myparser myparser
+ # x
+ # <xdigit>
+ # ?
+ # <xdigit>
+
+ $myparser si:void_state_push
+ $myparser si:next_xdigit
+ $myparser si:voidvoid_part
+ optional_72
+ $myparser si:void_state_merge
+ return
+ }
+
+ proc optional_72 {} { upvar 1 myparser myparser
+ # ?
+ # <xdigit>
+
+ $myparser si:void2_state_push
+ $myparser si:next_xdigit
+ $myparser si:void_state_merge_ok
+ return
+ }
+
+ #
+ # value Symbol 'Class'
+ #
+
+ proc sym_Class {} { upvar 1 myparser myparser
+ # x
+ # (OPENB)
+ # *
+ # x
+ # !
+ # (CLOSEB)
+ # (Range)
+ # (CLOSEB)
+ # (WHITESPACE)
+
+ $myparser si:value_symbol_start Class
+ sequence_96
+ $myparser si:reduce_symbol_end Class
+ return
+ }
+
+ proc sequence_96 {} { upvar 1 myparser myparser
+ # x
+ # (OPENB)
+ # *
+ # x
+ # !
+ # (CLOSEB)
+ # (Range)
+ # (CLOSEB)
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ sym_OPENB
+ $myparser si:voidvalue_part
+ kleene_92
+ $myparser si:valuevalue_part
+ sym_CLOSEB
+ $myparser si:valuevalue_part
+ sym_WHITESPACE
+ $myparser si:value_state_merge
+ return
+ }
+
+ proc kleene_92 {} { upvar 1 myparser myparser
+ # *
+ # x
+ # !
+ # (CLOSEB)
+ # (Range)
+
+ while {1} {
+ $myparser si:void2_state_push
+ sequence_90
+ $myparser si:kleene_close
+ }
+ return
+ }
+
+ proc sequence_90 {} { upvar 1 myparser myparser
+ # x
+ # !
+ # (CLOSEB)
+ # (Range)
+
+ $myparser si:void_state_push
+ notahead_87
+ $myparser si:voidvalue_part
+ sym_Range
+ $myparser si:value_state_merge
+ return
+ }
+
+ proc notahead_87 {} { upvar 1 myparser myparser
+ # !
+ # (CLOSEB)
+
+ $myparser i_loc_push
+ sym_CLOSEB
+ $myparser si:void_notahead_exit
+ return
+ }
+
+ #
+ # void Symbol 'CLOSE'
+ #
+
+ proc sym_CLOSE {} { upvar 1 myparser myparser
+ # x
+ # '\)'
+ # (WHITESPACE)
+
+ $myparser si:void_void_symbol_start CLOSE
+ sequence_101
+ $myparser si:void_clear_symbol_end CLOSE
+ return
+ }
+
+ proc sequence_101 {} { upvar 1 myparser myparser
+ # x
+ # '\)'
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_char \51
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # void Symbol 'CLOSEB'
+ #
+
+ proc sym_CLOSEB {} { upvar 1 myparser myparser
+ # ']'
+
+ $myparser si:void_void_symbol_start CLOSEB
+ $myparser si:next_char \135
+ $myparser si:void_clear_symbol_end CLOSEB
+ return
+ }
+
+ #
+ # void Symbol 'COLON'
+ #
+
+ proc sym_COLON {} { upvar 1 myparser myparser
+ # x
+ # ':'
+ # (WHITESPACE)
+
+ $myparser si:void_void_symbol_start COLON
+ sequence_108
+ $myparser si:void_clear_symbol_end COLON
+ return
+ }
+
+ proc sequence_108 {} { upvar 1 myparser myparser
+ # x
+ # ':'
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_char :
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # void Symbol 'COMMENT'
+ #
+
+ proc sym_COMMENT {} { upvar 1 myparser myparser
+ # x
+ # '#'
+ # *
+ # x
+ # !
+ # (EOL)
+ # <dot>
+ # (EOL)
+
+ $myparser si:void_void_symbol_start COMMENT
+ sequence_121
+ $myparser si:void_clear_symbol_end COMMENT
+ return
+ }
+
+ proc sequence_121 {} { upvar 1 myparser myparser
+ # x
+ # '#'
+ # *
+ # x
+ # !
+ # (EOL)
+ # <dot>
+ # (EOL)
+
+ $myparser si:void_state_push
+ $myparser si:next_char #
+ $myparser si:voidvoid_part
+ kleene_118
+ $myparser si:voidvoid_part
+ sym_EOL
+ $myparser si:void_state_merge
+ return
+ }
+
+ proc kleene_118 {} { upvar 1 myparser myparser
+ # *
+ # x
+ # !
+ # (EOL)
+ # <dot>
+
+ while {1} {
+ $myparser si:void2_state_push
+ sequence_116
+ $myparser si:kleene_close
+ }
+ return
+ }
+
+ proc sequence_116 {} { upvar 1 myparser myparser
+ # x
+ # !
+ # (EOL)
+ # <dot>
+
+ $myparser si:void_state_push
+ notahead_113
+ $myparser si:voidvoid_part
+ $myparser i_input_next dot
+ $myparser si:void_state_merge
+ return
+ }
+
+ proc notahead_113 {} { upvar 1 myparser myparser
+ # !
+ # (EOL)
+
+ $myparser i_loc_push
+ sym_EOL
+ $myparser si:void_notahead_exit
+ return
+ }
+
+ #
+ # leaf Symbol 'CONTROL'
+ #
+
+ proc sym_CONTROL {} { upvar 1 myparser myparser
+ # x
+ # "<control>"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start CONTROL
+ sequence_126
+ $myparser si:void_leaf_symbol_end CONTROL
+ return
+ }
+
+ proc sequence_126 {} { upvar 1 myparser myparser
+ # x
+ # "<control>"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str <control>
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # void Symbol 'DAPOSTROPH'
+ #
+
+ proc sym_DAPOSTROPH {} { upvar 1 myparser myparser
+ # '\"'
+
+ $myparser si:void_void_symbol_start DAPOSTROPH
+ $myparser si:next_char \42
+ $myparser si:void_clear_symbol_end DAPOSTROPH
+ return
+ }
+
+ #
+ # leaf Symbol 'DDIGIT'
+ #
+
+ proc sym_DDIGIT {} { upvar 1 myparser myparser
+ # x
+ # "<ddigit>"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start DDIGIT
+ sequence_133
+ $myparser si:void_leaf_symbol_end DDIGIT
+ return
+ }
+
+ proc sequence_133 {} { upvar 1 myparser myparser
+ # x
+ # "<ddigit>"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str <ddigit>
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # value Symbol 'Definition'
+ #
+
+ proc sym_Definition {} { upvar 1 myparser myparser
+ # x
+ # ?
+ # (Attribute)
+ # (Identifier)
+ # (IS)
+ # (Expression)
+ # (SEMICOLON)
+
+ $myparser si:value_symbol_start Definition
+ sequence_143
+ $myparser si:reduce_symbol_end Definition
+ return
+ }
+
+ proc sequence_143 {} { upvar 1 myparser myparser
+ # x
+ # ?
+ # (Attribute)
+ # (Identifier)
+ # (IS)
+ # (Expression)
+ # (SEMICOLON)
+
+ $myparser si:value_state_push
+ optional_137
+ $myparser si:valuevalue_part
+ sym_Identifier
+ $myparser si:valuevalue_part
+ sym_IS
+ $myparser si:valuevalue_part
+ sym_Expression
+ $myparser si:valuevalue_part
+ sym_SEMICOLON
+ $myparser si:value_state_merge
+ return
+ }
+
+ proc optional_137 {} { upvar 1 myparser myparser
+ # ?
+ # (Attribute)
+
+ $myparser si:void2_state_push
+ sym_Attribute
+ $myparser si:void_state_merge_ok
+ return
+ }
+
+ #
+ # leaf Symbol 'DIGIT'
+ #
+
+ proc sym_DIGIT {} { upvar 1 myparser myparser
+ # x
+ # "<digit>"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start DIGIT
+ sequence_148
+ $myparser si:void_leaf_symbol_end DIGIT
+ return
+ }
+
+ proc sequence_148 {} { upvar 1 myparser myparser
+ # x
+ # "<digit>"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str <digit>
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'DOT'
+ #
+
+ proc sym_DOT {} { upvar 1 myparser myparser
+ # x
+ # '.'
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start DOT
+ sequence_153
+ $myparser si:void_leaf_symbol_end DOT
+ return
+ }
+
+ proc sequence_153 {} { upvar 1 myparser myparser
+ # x
+ # '.'
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_char .
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # void Symbol 'EOF'
+ #
+
+ proc sym_EOF {} { upvar 1 myparser myparser
+ # !
+ # <dot>
+
+ $myparser si:void_void_symbol_start EOF
+ notahead_157
+ $myparser si:void_clear_symbol_end EOF
+ return
+ }
+
+ proc notahead_157 {} { upvar 1 myparser myparser
+ # !
+ # <dot>
+
+ $myparser i_loc_push
+ $myparser i_input_next dot
+ $myparser si:void_notahead_exit
+ return
+ }
+
+ #
+ # void Symbol 'EOL'
+ #
+
+ proc sym_EOL {} { upvar 1 myparser myparser
+ # [\n\r]
+
+ $myparser si:void_void_symbol_start EOL
+ $myparser si:next_class \n\r
+ $myparser si:void_clear_symbol_end EOL
+ return
+ }
+
+ #
+ # value Symbol 'Expression'
+ #
+
+ proc sym_Expression {} { upvar 1 myparser myparser
+ # x
+ # (Sequence)
+ # *
+ # x
+ # (SLASH)
+ # (Sequence)
+
+ $myparser si:value_symbol_start Expression
+ sequence_169
+ $myparser si:reduce_symbol_end Expression
+ return
+ }
+
+ proc sequence_169 {} { upvar 1 myparser myparser
+ # x
+ # (Sequence)
+ # *
+ # x
+ # (SLASH)
+ # (Sequence)
+
+ $myparser si:value_state_push
+ sym_Sequence
+ $myparser si:valuevalue_part
+ kleene_167
+ $myparser si:value_state_merge
+ return
+ }
+
+ proc kleene_167 {} { upvar 1 myparser myparser
+ # *
+ # x
+ # (SLASH)
+ # (Sequence)
+
+ while {1} {
+ $myparser si:void2_state_push
+ sequence_165
+ $myparser si:kleene_close
+ }
+ return
+ }
+
+ proc sequence_165 {} { upvar 1 myparser myparser
+ # x
+ # (SLASH)
+ # (Sequence)
+
+ $myparser si:void_state_push
+ sym_SLASH
+ $myparser si:voidvalue_part
+ sym_Sequence
+ $myparser si:value_state_merge
+ return
+ }
+
+ #
+ # void Symbol 'Final'
+ #
+
+ proc sym_Final {} { upvar 1 myparser myparser
+ # x
+ # "END"
+ # (WHITESPACE)
+ # (SEMICOLON)
+ # (WHITESPACE)
+
+ $myparser si:void_void_symbol_start Final
+ sequence_176
+ $myparser si:void_clear_symbol_end Final
+ return
+ }
+
+ proc sequence_176 {} { upvar 1 myparser myparser
+ # x
+ # "END"
+ # (WHITESPACE)
+ # (SEMICOLON)
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str END
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:voidvoid_part
+ sym_SEMICOLON
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # value Symbol 'Grammar'
+ #
+
+ proc sym_Grammar {} { upvar 1 myparser myparser
+ # x
+ # (WHITESPACE)
+ # (Header)
+ # *
+ # (Definition)
+ # (Final)
+ # (EOF)
+
+ $myparser si:value_symbol_start Grammar
+ sequence_186
+ $myparser si:reduce_symbol_end Grammar
+ return
+ }
+
+ proc sequence_186 {} { upvar 1 myparser myparser
+ # x
+ # (WHITESPACE)
+ # (Header)
+ # *
+ # (Definition)
+ # (Final)
+ # (EOF)
+
+ $myparser si:void_state_push
+ sym_WHITESPACE
+ $myparser si:voidvalue_part
+ sym_Header
+ $myparser si:valuevalue_part
+ kleene_182
+ $myparser si:valuevalue_part
+ sym_Final
+ $myparser si:valuevalue_part
+ sym_EOF
+ $myparser si:value_state_merge
+ return
+ }
+
+ proc kleene_182 {} { upvar 1 myparser myparser
+ # *
+ # (Definition)
+
+ while {1} {
+ $myparser si:void2_state_push
+ sym_Definition
+ $myparser si:kleene_close
+ }
+ return
+ }
+
+ #
+ # leaf Symbol 'GRAPH'
+ #
+
+ proc sym_GRAPH {} { upvar 1 myparser myparser
+ # x
+ # "<graph>"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start GRAPH
+ sequence_191
+ $myparser si:void_leaf_symbol_end GRAPH
+ return
+ }
+
+ proc sequence_191 {} { upvar 1 myparser myparser
+ # x
+ # "<graph>"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str <graph>
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # value Symbol 'Header'
+ #
+
+ proc sym_Header {} { upvar 1 myparser myparser
+ # x
+ # (PEG)
+ # (Identifier)
+ # (StartExpr)
+
+ $myparser si:value_symbol_start Header
+ sequence_197
+ $myparser si:reduce_symbol_end Header
+ return
+ }
+
+ proc sequence_197 {} { upvar 1 myparser myparser
+ # x
+ # (PEG)
+ # (Identifier)
+ # (StartExpr)
+
+ $myparser si:void_state_push
+ sym_PEG
+ $myparser si:voidvalue_part
+ sym_Identifier
+ $myparser si:valuevalue_part
+ sym_StartExpr
+ $myparser si:value_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'Ident'
+ #
+
+ proc sym_Ident {} { upvar 1 myparser myparser
+ # x
+ # /
+ # [_:]
+ # <alpha>
+ # *
+ # /
+ # [_:]
+ # <alnum>
+
+ $myparser si:void_symbol_start Ident
+ sequence_210
+ $myparser si:void_leaf_symbol_end Ident
+ return
+ }
+
+ proc sequence_210 {} { upvar 1 myparser myparser
+ # x
+ # /
+ # [_:]
+ # <alpha>
+ # *
+ # /
+ # [_:]
+ # <alnum>
+
+ $myparser si:void_state_push
+ choice_202
+ $myparser si:voidvoid_part
+ kleene_208
+ $myparser si:void_state_merge
+ return
+ }
+
+ proc choice_202 {} { upvar 1 myparser myparser
+ # /
+ # [_:]
+ # <alpha>
+
+ $myparser si:void_state_push
+ $myparser si:next_class _:
+ $myparser si:voidvoid_branch
+ $myparser si:next_alpha
+ $myparser si:void_state_merge
+ return
+ }
+
+ proc kleene_208 {} { upvar 1 myparser myparser
+ # *
+ # /
+ # [_:]
+ # <alnum>
+
+ while {1} {
+ $myparser si:void2_state_push
+ choice_206
+ $myparser si:kleene_close
+ }
+ return
+ }
+
+ proc choice_206 {} { upvar 1 myparser myparser
+ # /
+ # [_:]
+ # <alnum>
+
+ $myparser si:void_state_push
+ $myparser si:next_class _:
+ $myparser si:voidvoid_branch
+ $myparser si:next_alnum
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # value Symbol 'Identifier'
+ #
+
+ proc sym_Identifier {} { upvar 1 myparser myparser
+ # x
+ # (Ident)
+ # (WHITESPACE)
+
+ $myparser si:value_symbol_start Identifier
+ sequence_215
+ $myparser si:reduce_symbol_end Identifier
+ return
+ }
+
+ proc sequence_215 {} { upvar 1 myparser myparser
+ # x
+ # (Ident)
+ # (WHITESPACE)
+
+ $myparser si:value_state_push
+ sym_Ident
+ $myparser si:valuevalue_part
+ sym_WHITESPACE
+ $myparser si:value_state_merge
+ return
+ }
+
+ #
+ # void Symbol 'IS'
+ #
+
+ proc sym_IS {} { upvar 1 myparser myparser
+ # x
+ # "<-"
+ # (WHITESPACE)
+
+ $myparser si:void_void_symbol_start IS
+ sequence_220
+ $myparser si:void_clear_symbol_end IS
+ return
+ }
+
+ proc sequence_220 {} { upvar 1 myparser myparser
+ # x
+ # "<-"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str <-
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'LEAF'
+ #
+
+ proc sym_LEAF {} { upvar 1 myparser myparser
+ # x
+ # "leaf"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start LEAF
+ sequence_225
+ $myparser si:void_leaf_symbol_end LEAF
+ return
+ }
+
+ proc sequence_225 {} { upvar 1 myparser myparser
+ # x
+ # "leaf"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str leaf
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # value Symbol 'Literal'
+ #
+
+ proc sym_Literal {} { upvar 1 myparser myparser
+ # /
+ # x
+ # (APOSTROPH)
+ # *
+ # x
+ # !
+ # (APOSTROPH)
+ # (Char)
+ # (APOSTROPH)
+ # (WHITESPACE)
+ # x
+ # (DAPOSTROPH)
+ # *
+ # x
+ # !
+ # (DAPOSTROPH)
+ # (Char)
+ # (DAPOSTROPH)
+ # (WHITESPACE)
+
+ $myparser si:value_symbol_start Literal
+ choice_254
+ $myparser si:reduce_symbol_end Literal
+ return
+ }
+
+ proc choice_254 {} { upvar 1 myparser myparser
+ # /
+ # x
+ # (APOSTROPH)
+ # *
+ # x
+ # !
+ # (APOSTROPH)
+ # (Char)
+ # (APOSTROPH)
+ # (WHITESPACE)
+ # x
+ # (DAPOSTROPH)
+ # *
+ # x
+ # !
+ # (DAPOSTROPH)
+ # (Char)
+ # (DAPOSTROPH)
+ # (WHITESPACE)
+
+ $myparser si:value_state_push
+ sequence_239
+ $myparser si:valuevalue_branch
+ sequence_252
+ $myparser si:value_state_merge
+ return
+ }
+
+ proc sequence_239 {} { upvar 1 myparser myparser
+ # x
+ # (APOSTROPH)
+ # *
+ # x
+ # !
+ # (APOSTROPH)
+ # (Char)
+ # (APOSTROPH)
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ sym_APOSTROPH
+ $myparser si:voidvalue_part
+ kleene_235
+ $myparser si:valuevalue_part
+ sym_APOSTROPH
+ $myparser si:valuevalue_part
+ sym_WHITESPACE
+ $myparser si:value_state_merge
+ return
+ }
+
+ proc kleene_235 {} { upvar 1 myparser myparser
+ # *
+ # x
+ # !
+ # (APOSTROPH)
+ # (Char)
+
+ while {1} {
+ $myparser si:void2_state_push
+ sequence_233
+ $myparser si:kleene_close
+ }
+ return
+ }
+
+ proc sequence_233 {} { upvar 1 myparser myparser
+ # x
+ # !
+ # (APOSTROPH)
+ # (Char)
+
+ $myparser si:void_state_push
+ notahead_230
+ $myparser si:voidvalue_part
+ sym_Char
+ $myparser si:value_state_merge
+ return
+ }
+
+ proc notahead_230 {} { upvar 1 myparser myparser
+ # !
+ # (APOSTROPH)
+
+ $myparser i_loc_push
+ sym_APOSTROPH
+ $myparser si:void_notahead_exit
+ return
+ }
+
+ proc sequence_252 {} { upvar 1 myparser myparser
+ # x
+ # (DAPOSTROPH)
+ # *
+ # x
+ # !
+ # (DAPOSTROPH)
+ # (Char)
+ # (DAPOSTROPH)
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ sym_DAPOSTROPH
+ $myparser si:voidvalue_part
+ kleene_248
+ $myparser si:valuevalue_part
+ sym_DAPOSTROPH
+ $myparser si:valuevalue_part
+ sym_WHITESPACE
+ $myparser si:value_state_merge
+ return
+ }
+
+ proc kleene_248 {} { upvar 1 myparser myparser
+ # *
+ # x
+ # !
+ # (DAPOSTROPH)
+ # (Char)
+
+ while {1} {
+ $myparser si:void2_state_push
+ sequence_246
+ $myparser si:kleene_close
+ }
+ return
+ }
+
+ proc sequence_246 {} { upvar 1 myparser myparser
+ # x
+ # !
+ # (DAPOSTROPH)
+ # (Char)
+
+ $myparser si:void_state_push
+ notahead_243
+ $myparser si:voidvalue_part
+ sym_Char
+ $myparser si:value_state_merge
+ return
+ }
+
+ proc notahead_243 {} { upvar 1 myparser myparser
+ # !
+ # (DAPOSTROPH)
+
+ $myparser i_loc_push
+ sym_DAPOSTROPH
+ $myparser si:void_notahead_exit
+ return
+ }
+
+ #
+ # leaf Symbol 'LOWER'
+ #
+
+ proc sym_LOWER {} { upvar 1 myparser myparser
+ # x
+ # "<lower>"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start LOWER
+ sequence_259
+ $myparser si:void_leaf_symbol_end LOWER
+ return
+ }
+
+ proc sequence_259 {} { upvar 1 myparser myparser
+ # x
+ # "<lower>"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str <lower>
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'NOT'
+ #
+
+ proc sym_NOT {} { upvar 1 myparser myparser
+ # x
+ # '!'
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start NOT
+ sequence_264
+ $myparser si:void_leaf_symbol_end NOT
+ return
+ }
+
+ proc sequence_264 {} { upvar 1 myparser myparser
+ # x
+ # '!'
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_char !
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # void Symbol 'OPEN'
+ #
+
+ proc sym_OPEN {} { upvar 1 myparser myparser
+ # x
+ # '\('
+ # (WHITESPACE)
+
+ $myparser si:void_void_symbol_start OPEN
+ sequence_269
+ $myparser si:void_clear_symbol_end OPEN
+ return
+ }
+
+ proc sequence_269 {} { upvar 1 myparser myparser
+ # x
+ # '\('
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_char \50
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # void Symbol 'OPENB'
+ #
+
+ proc sym_OPENB {} { upvar 1 myparser myparser
+ # '['
+
+ $myparser si:void_void_symbol_start OPENB
+ $myparser si:next_char \133
+ $myparser si:void_clear_symbol_end OPENB
+ return
+ }
+
+ #
+ # void Symbol 'PEG'
+ #
+
+ proc sym_PEG {} { upvar 1 myparser myparser
+ # x
+ # "PEG"
+ # !
+ # /
+ # [_:]
+ # <alnum>
+ # (WHITESPACE)
+
+ $myparser si:void_void_symbol_start PEG
+ sequence_281
+ $myparser si:void_clear_symbol_end PEG
+ return
+ }
+
+ proc sequence_281 {} { upvar 1 myparser myparser
+ # x
+ # "PEG"
+ # !
+ # /
+ # [_:]
+ # <alnum>
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str PEG
+ $myparser si:voidvoid_part
+ notahead_278
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ proc notahead_278 {} { upvar 1 myparser myparser
+ # !
+ # /
+ # [_:]
+ # <alnum>
+
+ $myparser i_loc_push
+ choice_206
+ $myparser si:void_notahead_exit
+ return
+ }
+
+ #
+ # leaf Symbol 'PLUS'
+ #
+
+ proc sym_PLUS {} { upvar 1 myparser myparser
+ # x
+ # '+'
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start PLUS
+ sequence_286
+ $myparser si:void_leaf_symbol_end PLUS
+ return
+ }
+
+ proc sequence_286 {} { upvar 1 myparser myparser
+ # x
+ # '+'
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_char +
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # value Symbol 'Prefix'
+ #
+
+ proc sym_Prefix {} { upvar 1 myparser myparser
+ # x
+ # ?
+ # /
+ # (AND)
+ # (NOT)
+ # (Suffix)
+
+ $myparser si:value_symbol_start Prefix
+ sequence_296
+ $myparser si:reduce_symbol_end Prefix
+ return
+ }
+
+ proc sequence_296 {} { upvar 1 myparser myparser
+ # x
+ # ?
+ # /
+ # (AND)
+ # (NOT)
+ # (Suffix)
+
+ $myparser si:value_state_push
+ optional_293
+ $myparser si:valuevalue_part
+ sym_Suffix
+ $myparser si:value_state_merge
+ return
+ }
+
+ proc optional_293 {} { upvar 1 myparser myparser
+ # ?
+ # /
+ # (AND)
+ # (NOT)
+
+ $myparser si:void2_state_push
+ choice_291
+ $myparser si:void_state_merge_ok
+ return
+ }
+
+ proc choice_291 {} { upvar 1 myparser myparser
+ # /
+ # (AND)
+ # (NOT)
+
+ $myparser si:value_state_push
+ sym_AND
+ $myparser si:valuevalue_branch
+ sym_NOT
+ $myparser si:value_state_merge
+ return
+ }
+
+ #
+ # value Symbol 'Primary'
+ #
+
+ proc sym_Primary {} { upvar 1 myparser myparser
+ # /
+ # (ALNUM)
+ # (ALPHA)
+ # (ASCII)
+ # (CONTROL)
+ # (DDIGIT)
+ # (DIGIT)
+ # (GRAPH)
+ # (LOWER)
+ # (PRINTABLE)
+ # (PUNCT)
+ # (SPACE)
+ # (UPPER)
+ # (WORDCHAR)
+ # (XDIGIT)
+ # (Identifier)
+ # x
+ # (OPEN)
+ # (Expression)
+ # (CLOSE)
+ # (Literal)
+ # (Class)
+ # (DOT)
+
+ $myparser si:value_symbol_start Primary
+ choice_322
+ $myparser si:reduce_symbol_end Primary
+ return
+ }
+
+ proc choice_322 {} { upvar 1 myparser myparser
+ # /
+ # (ALNUM)
+ # (ALPHA)
+ # (ASCII)
+ # (CONTROL)
+ # (DDIGIT)
+ # (DIGIT)
+ # (GRAPH)
+ # (LOWER)
+ # (PRINTABLE)
+ # (PUNCT)
+ # (SPACE)
+ # (UPPER)
+ # (WORDCHAR)
+ # (XDIGIT)
+ # (Identifier)
+ # x
+ # (OPEN)
+ # (Expression)
+ # (CLOSE)
+ # (Literal)
+ # (Class)
+ # (DOT)
+
+ $myparser si:value_state_push
+ sym_ALNUM
+ $myparser si:valuevalue_branch
+ sym_ALPHA
+ $myparser si:valuevalue_branch
+ sym_ASCII
+ $myparser si:valuevalue_branch
+ sym_CONTROL
+ $myparser si:valuevalue_branch
+ sym_DDIGIT
+ $myparser si:valuevalue_branch
+ sym_DIGIT
+ $myparser si:valuevalue_branch
+ sym_GRAPH
+ $myparser si:valuevalue_branch
+ sym_LOWER
+ $myparser si:valuevalue_branch
+ sym_PRINTABLE
+ $myparser si:valuevalue_branch
+ sym_PUNCT
+ $myparser si:valuevalue_branch
+ sym_SPACE
+ $myparser si:valuevalue_branch
+ sym_UPPER
+ $myparser si:valuevalue_branch
+ sym_WORDCHAR
+ $myparser si:valuevalue_branch
+ sym_XDIGIT
+ $myparser si:valuevalue_branch
+ sym_Identifier
+ $myparser si:valuevalue_branch
+ sequence_317
+ $myparser si:valuevalue_branch
+ sym_Literal
+ $myparser si:valuevalue_branch
+ sym_Class
+ $myparser si:valuevalue_branch
+ sym_DOT
+ $myparser si:value_state_merge
+ return
+ }
+
+ proc sequence_317 {} { upvar 1 myparser myparser
+ # x
+ # (OPEN)
+ # (Expression)
+ # (CLOSE)
+
+ $myparser si:void_state_push
+ sym_OPEN
+ $myparser si:voidvalue_part
+ sym_Expression
+ $myparser si:valuevalue_part
+ sym_CLOSE
+ $myparser si:value_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'PRINTABLE'
+ #
+
+ proc sym_PRINTABLE {} { upvar 1 myparser myparser
+ # x
+ # "<print>"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start PRINTABLE
+ sequence_327
+ $myparser si:void_leaf_symbol_end PRINTABLE
+ return
+ }
+
+ proc sequence_327 {} { upvar 1 myparser myparser
+ # x
+ # "<print>"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str <print>
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'PUNCT'
+ #
+
+ proc sym_PUNCT {} { upvar 1 myparser myparser
+ # x
+ # "<punct>"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start PUNCT
+ sequence_332
+ $myparser si:void_leaf_symbol_end PUNCT
+ return
+ }
+
+ proc sequence_332 {} { upvar 1 myparser myparser
+ # x
+ # "<punct>"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str <punct>
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'QUESTION'
+ #
+
+ proc sym_QUESTION {} { upvar 1 myparser myparser
+ # x
+ # '?'
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start QUESTION
+ sequence_337
+ $myparser si:void_leaf_symbol_end QUESTION
+ return
+ }
+
+ proc sequence_337 {} { upvar 1 myparser myparser
+ # x
+ # '?'
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_char ?
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # value Symbol 'Range'
+ #
+
+ proc sym_Range {} { upvar 1 myparser myparser
+ # /
+ # x
+ # (Char)
+ # (TO)
+ # (Char)
+ # (Char)
+
+ $myparser si:value_symbol_start Range
+ choice_346
+ $myparser si:reduce_symbol_end Range
+ return
+ }
+
+ proc choice_346 {} { upvar 1 myparser myparser
+ # /
+ # x
+ # (Char)
+ # (TO)
+ # (Char)
+ # (Char)
+
+ $myparser si:value_state_push
+ sequence_343
+ $myparser si:valuevalue_branch
+ sym_Char
+ $myparser si:value_state_merge
+ return
+ }
+
+ proc sequence_343 {} { upvar 1 myparser myparser
+ # x
+ # (Char)
+ # (TO)
+ # (Char)
+
+ $myparser si:value_state_push
+ sym_Char
+ $myparser si:valuevalue_part
+ sym_TO
+ $myparser si:valuevalue_part
+ sym_Char
+ $myparser si:value_state_merge
+ return
+ }
+
+ #
+ # void Symbol 'SEMICOLON'
+ #
+
+ proc sym_SEMICOLON {} { upvar 1 myparser myparser
+ # x
+ # ';'
+ # (WHITESPACE)
+
+ $myparser si:void_void_symbol_start SEMICOLON
+ sequence_351
+ $myparser si:void_clear_symbol_end SEMICOLON
+ return
+ }
+
+ proc sequence_351 {} { upvar 1 myparser myparser
+ # x
+ # ';'
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_char \73
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # value Symbol 'Sequence'
+ #
+
+ proc sym_Sequence {} { upvar 1 myparser myparser
+ # +
+ # (Prefix)
+
+ $myparser si:value_symbol_start Sequence
+ poskleene_355
+ $myparser si:reduce_symbol_end Sequence
+ return
+ }
+
+ proc poskleene_355 {} { upvar 1 myparser myparser
+ # +
+ # (Prefix)
+
+ $myparser i_loc_push
+ sym_Prefix
+ $myparser si:kleene_abort
+ while {1} {
+ $myparser si:void2_state_push
+ sym_Prefix
+ $myparser si:kleene_close
+ }
+ return
+ }
+
+ #
+ # void Symbol 'SLASH'
+ #
+
+ proc sym_SLASH {} { upvar 1 myparser myparser
+ # x
+ # '/'
+ # (WHITESPACE)
+
+ $myparser si:void_void_symbol_start SLASH
+ sequence_360
+ $myparser si:void_clear_symbol_end SLASH
+ return
+ }
+
+ proc sequence_360 {} { upvar 1 myparser myparser
+ # x
+ # '/'
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_char /
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'SPACE'
+ #
+
+ proc sym_SPACE {} { upvar 1 myparser myparser
+ # x
+ # "<space>"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start SPACE
+ sequence_365
+ $myparser si:void_leaf_symbol_end SPACE
+ return
+ }
+
+ proc sequence_365 {} { upvar 1 myparser myparser
+ # x
+ # "<space>"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str <space>
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'STAR'
+ #
+
+ proc sym_STAR {} { upvar 1 myparser myparser
+ # x
+ # '*'
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start STAR
+ sequence_370
+ $myparser si:void_leaf_symbol_end STAR
+ return
+ }
+
+ proc sequence_370 {} { upvar 1 myparser myparser
+ # x
+ # '*'
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_char *
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # value Symbol 'StartExpr'
+ #
+
+ proc sym_StartExpr {} { upvar 1 myparser myparser
+ # x
+ # (OPEN)
+ # (Expression)
+ # (CLOSE)
+
+ $myparser si:value_symbol_start StartExpr
+ sequence_317
+ $myparser si:reduce_symbol_end StartExpr
+ return
+ }
+
+ #
+ # value Symbol 'Suffix'
+ #
+
+ proc sym_Suffix {} { upvar 1 myparser myparser
+ # x
+ # (Primary)
+ # ?
+ # /
+ # (QUESTION)
+ # (STAR)
+ # (PLUS)
+
+ $myparser si:value_symbol_start Suffix
+ sequence_386
+ $myparser si:reduce_symbol_end Suffix
+ return
+ }
+
+ proc sequence_386 {} { upvar 1 myparser myparser
+ # x
+ # (Primary)
+ # ?
+ # /
+ # (QUESTION)
+ # (STAR)
+ # (PLUS)
+
+ $myparser si:value_state_push
+ sym_Primary
+ $myparser si:valuevalue_part
+ optional_384
+ $myparser si:value_state_merge
+ return
+ }
+
+ proc optional_384 {} { upvar 1 myparser myparser
+ # ?
+ # /
+ # (QUESTION)
+ # (STAR)
+ # (PLUS)
+
+ $myparser si:void2_state_push
+ choice_382
+ $myparser si:void_state_merge_ok
+ return
+ }
+
+ proc choice_382 {} { upvar 1 myparser myparser
+ # /
+ # (QUESTION)
+ # (STAR)
+ # (PLUS)
+
+ $myparser si:value_state_push
+ sym_QUESTION
+ $myparser si:valuevalue_branch
+ sym_STAR
+ $myparser si:valuevalue_branch
+ sym_PLUS
+ $myparser si:value_state_merge
+ return
+ }
+
+ #
+ # void Symbol 'TO'
+ #
+
+ proc sym_TO {} { upvar 1 myparser myparser
+ # '-'
+
+ $myparser si:void_void_symbol_start TO
+ $myparser si:next_char -
+ $myparser si:void_clear_symbol_end TO
+ return
+ }
+
+ #
+ # leaf Symbol 'UPPER'
+ #
+
+ proc sym_UPPER {} { upvar 1 myparser myparser
+ # x
+ # "<upper>"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start UPPER
+ sequence_393
+ $myparser si:void_leaf_symbol_end UPPER
+ return
+ }
+
+ proc sequence_393 {} { upvar 1 myparser myparser
+ # x
+ # "<upper>"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str <upper>
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'VOID'
+ #
+
+ proc sym_VOID {} { upvar 1 myparser myparser
+ # x
+ # "void"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start VOID
+ sequence_398
+ $myparser si:void_leaf_symbol_end VOID
+ return
+ }
+
+ proc sequence_398 {} { upvar 1 myparser myparser
+ # x
+ # "void"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str void
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # void Symbol 'WHITESPACE'
+ #
+
+ proc sym_WHITESPACE {} { upvar 1 myparser myparser
+ # *
+ # /
+ # <space>
+ # (COMMENT)
+
+ $myparser si:void_void_symbol_start WHITESPACE
+ kleene_405
+ $myparser si:void_clear_symbol_end WHITESPACE
+ return
+ }
+
+ proc kleene_405 {} { upvar 1 myparser myparser
+ # *
+ # /
+ # <space>
+ # (COMMENT)
+
+ while {1} {
+ $myparser si:void2_state_push
+ choice_403
+ $myparser si:kleene_close
+ }
+ return
+ }
+
+ proc choice_403 {} { upvar 1 myparser myparser
+ # /
+ # <space>
+ # (COMMENT)
+
+ $myparser si:void_state_push
+ $myparser si:next_space
+ $myparser si:voidvoid_branch
+ sym_COMMENT
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'WORDCHAR'
+ #
+
+ proc sym_WORDCHAR {} { upvar 1 myparser myparser
+ # x
+ # "<wordchar>"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start WORDCHAR
+ sequence_410
+ $myparser si:void_leaf_symbol_end WORDCHAR
+ return
+ }
+
+ proc sequence_410 {} { upvar 1 myparser myparser
+ # x
+ # "<wordchar>"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str <wordchar>
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ #
+ # leaf Symbol 'XDIGIT'
+ #
+
+ proc sym_XDIGIT {} { upvar 1 myparser myparser
+ # x
+ # "<xdigit>"
+ # (WHITESPACE)
+
+ $myparser si:void_symbol_start XDIGIT
+ sequence_415
+ $myparser si:void_leaf_symbol_end XDIGIT
+ return
+ }
+
+ proc sequence_415 {} { upvar 1 myparser myparser
+ # x
+ # "<xdigit>"
+ # (WHITESPACE)
+
+ $myparser si:void_state_push
+ $myparser si:next_str <xdigit>
+ $myparser si:voidvoid_part
+ sym_WHITESPACE
+ $myparser si:void_state_merge
+ return
+ }
+
+ ## END of GENERATED CODE. DO NOT EDIT.
+ # # ## ### ###### ######## #############
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide pt::parse::peg_tcl 1.0.1
+return \ No newline at end of file
diff --git a/tcllib/modules/pt/pt_parser_api.man b/tcllib/modules/pt/pt_parser_api.man
new file mode 100644
index 0000000..0abbf9d
--- /dev/null
+++ b/tcllib/modules/pt/pt_parser_api.man
@@ -0,0 +1,82 @@
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt_parser_api i 1]
+[include include/module.inc]
+[titledesc {Parser API}]
+[description]
+[include include/ref_intro.inc]
+
+This document describes the API shared by the grammar interpreter
+provided by the package [package pt::peg::interp] and the parsers
+generated by the [cmd pt] application for the result formats
+[const critcl], [const snit], and [const oo] regarding access
+to the actual parsing functionality.
+
+[para]
+
+Its intended audience are people who wish to create a parser for some
+language of theirs and then use that parser within a Tcl-based package
+or application.
+
+[para]
+
+It resides in the User Layer of Parser Tools.
+[para][image arch_user_pkg][para]
+
+[section {Class API}]
+
+[list_begin definitions]
+[call [cmd className] [opt [arg objectName]]]
+
+The class command constructs parser instances, i.e. objects. The
+result of the command is the fully-qualified name of the instance
+command.
+
+[para]
+
+If no [arg objectName] is specified the class will generate and use an
+automatic name. If the [arg objectName] was specified, but is not
+fully qualified the command will be created in the current namespace.
+
+[list_end]
+
+[section {Instance API}]
+
+All parser instances provide at least the methods shown below:
+
+[list_begin definitions]
+[include include/std_parser_object_api.inc]
+[list_end]
+
+[section Usage]
+
+A generated parser is used like this
+
+[example {
+ package require the-parser-package ;# Generated by result-formats 'critcl', 'snit' or 'oo' of 'pt'.
+ set parser [the-parser-class]
+
+ set ast [$parser parse $channel]
+ ... process the abstract syntax tree ...
+}]
+
+When using a grammar interpreter for parsing some differences creep in
+
+[example {
+ package require the-grammar-package ;# Generated by result-format 'container' of 'pt'.
+ set grammar [the-grammar-class]
+
+ package require pt::peg::interp
+ set parser [pt::peg::interp]
+
+ $parser use $grammar
+
+ set ast [$parser parse $channel]
+ $parser destroy
+
+ ... process the abstract syntax tree ...
+}]
+
+[include include/serial/ast.inc]
+[include include/serial/pexpression.inc]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_peg_container.man b/tcllib/modules/pt/pt_peg_container.man
new file mode 100644
index 0000000..65889d0
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_container.man
@@ -0,0 +1,385 @@
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt::peg::container n 1]
+[include include/module.inc]
+[titledesc {PEG Storage}]
+[require snit]
+[require pt::peg::container [opt 1]]
+[description]
+[include include/ref_intro.inc]
+
+This package provides a container class for parsing expression
+grammars, with each instance storing a single grammar and allowing the
+user to manipulate and query its definition.
+
+[para]
+
+It resides in the Storage section of the Core Layer of Parser Tools,
+and is one of the three pillars the management of parsing expression
+grammars resides on.
+
+[para][image arch_core_container][para]
+
+The other two pillars are, as shown above
+
+[list_begin enum]
+[enum] [manpage {PEG Import}], and
+[enum] [manpage {PEG Export}]
+[list_end]
+
+[para]
+
+Packages related to this are:
+
+[list_begin definitions]
+[def [package pt::rde]]
+
+This package provides an implementation of PARAM, a virtual machine
+for the parsing of a channel, geared towards the needs of handling
+PEGs.
+
+[def [package pt::peg::interp]]
+
+This package implements an interpreter for PEGs on top of the virtual
+machine provided by [package pt::peg::rde]
+
+[list_end]
+
+[subsection {Class API}]
+
+The package exports the API described here.
+
+[list_begin definitions]
+
+[call [cmd ::pt::peg] [arg objectName] \
+ [opt "[const =]|[const :=]|[const <--]|[const as]|[const deserialize] [arg src]"]]
+
+The command creates a new container object for a parsing expression
+grammar and returns the fully qualified name of the object command as
+its result. The API of this object command is described in the section
+[sectref {Object API}]. It may be used to invoke various operations on
+the object.
+
+[para]
+
+The new container will be empty if no [arg src] is specified. Otherwise
+it will contain a copy of the grammar contained in the [arg src].
+
+All operators except [const deserialize] interpret [arg src] as a
+container object command. The [const deserialize] operator interprets
+[arg src] as the serialization of a parsing expression grammar
+instead, as specified in section [sectref {PEG serialization format}].
+
+[para]
+
+An empty grammar has no nonterminal symbols, and the start expression
+is the empty expression, i.e. epsilon. It is [term valid], but not
+[term useful].
+
+[list_end]
+
+[subsection {Object API}]
+[para]
+
+All objects created by this package provide the following methods for
+the manipulation and querying of their contents:
+
+[list_begin definitions]
+
+[call [arg objectName] [method destroy]]
+
+This method destroys the object, releasing all claimed memory, and
+deleting the associated object command.
+
+[call [arg objectName] [method clear]]
+
+This method resets the object to contain the empty grammar. It does
+[emph not] destroy the object itself.
+
+[call [arg objectName] [method importer]]
+
+This method returns the import manager object currently attached to
+the container, if any.
+
+[call [arg objectName] [method importer] [arg object]]
+
+This method attaches the [arg object] as import manager to the
+container, and returns it as the result of the command.
+
+Note that the [arg object] is [emph not] put into ownership of the
+container. I.e., destruction of the container will [emph not] destroy
+the [arg object].
+
+[para]
+
+It is expected that [arg object] provides a method named
+[method {import text}] which takes a text and a format name, and
+returns the canonical serialization of the table of contents contained in
+the text, assuming the given format.
+
+[call [arg objectName] [method exporter]]
+
+This method returns the export manager object currently attached to
+the container, if any.
+
+[call [arg objectName] [method exporter] [arg object]]
+
+This method attaches the [arg object] as export manager to the
+container, and returns it as the result of the command.
+
+Note that the [arg object] is [emph not] put into ownership of the
+container. I.e., destruction of the container will [emph not] destroy
+the [arg object].
+
+[para]
+
+It is expected that [arg object] provides a method named
+[method {export object}] which takes the container and a format name,
+and returns a text encoding table of contents stored in the container, in
+the given format. It is further expected that the [arg object] will
+use the container's method [method serialize] to obtain the
+serialization of the table of contents from which to generate the text.
+
+[call [arg objectName] [method =] [arg source]]
+
+This method assigns the contents of the PEG object [arg source] to
+ourselves, overwriting the existing definition. This is the assignment
+operator for grammars.
+
+[para]
+
+This operation is in effect equivalent to
+[para]
+[example_begin]
+ [arg objectName] [method {deserialize =}] [lb][arg source] [method serialize][rb]
+[example_end]
+
+[call [arg objectName] [method -->] [arg destination]]
+
+This method assigns our contents to the PEG object [arg destination],
+overwriting the existing definition. This is the reverse assignment
+operator for grammars.
+
+[para]
+
+This operation is in effect equivalent to
+[para]
+[example_begin]
+ [arg destination] [method {deserialize =}] [lb][arg objectName] [method serialize][rb]
+[example_end]
+
+[call [arg objectName] [method serialize] [opt [arg format]]]
+
+This method returns our grammar in some textual form usable for
+transfer, persistent storage, etc. If no [arg format] is not specified
+the returned result is the canonical serialization of the grammar, as
+specified in the section [sectref {PEG serialization format}].
+
+[para]
+
+Otherwise the object will use the attached export manager to convert
+the data to the specified format. In that case the method will fail
+with an error if the container has no export manager attached to it.
+
+[call [arg objectName] [method {deserialize =}] [arg data] [opt [arg format]]]
+
+This is the complementary method to [method serialize].
+
+It replaces the current definition with the grammar contained in the
+[arg data]. If no [arg format] was specified it is assumed to be the
+regular serialization of a grammar, as specified in the section
+[sectref {PEG serialization format}]
+
+[para]
+
+Otherwise the object will use the attached import manager to convert
+the data from the specified format to a serialization it can handle.
+In that case the method will fail with an error if the container has
+no import manager attached to it.
+
+[para]
+
+The result of the method is the empty string.
+
+[call [arg objectName] [method {deserialize +=}] [arg data] [opt [arg format]]]
+
+This method behaves like [method {deserialize =}] in its essentials,
+except that it merges the grammar in the [arg data] to its
+contents instead of replacing it.
+
+The method will fail with an error and leave the grammar unchanged if
+merging is not possible, i.e. would produce an invalid grammar.
+
+[para]
+
+The result of the method is the empty string.
+
+[call [arg objectName] [method start]]
+
+This method returns the current start expression of the grammar.
+
+[call [arg objectName] [method start] [arg pe]]
+
+This method defines the [term {start expression}] of the grammar. It
+replaces the current start expression with the parsing expression
+[arg pe], and returns the new start expression.
+
+[para]
+
+The method will fail with an error and leave the grammar unchanged if
+[arg pe] does not contain a valid parsing expression as specified in
+the section [sectref {PE serialization format}].
+
+[call [arg objectName] [method nonterminals]]
+
+This method returns the set of all nonterminal symbols known to the
+grammar.
+
+[call [arg objectName] [method modes]]
+
+This method returns a dictionary mapping the set of all nonterminal
+symbols known to the grammar to their semantic modes.
+
+[call [arg objectName] [method modes] [arg dict]]
+
+This method takes a dictionary mapping a set of nonterminal symbols
+known to the grammar to their semantic modes, and returns the new full
+mapping of nonterminal symbols to semantic modes.
+
+[para]
+
+The method will fail with an error if any of the nonterminal symbols
+in the dictionary is not known to the grammar, or the empty string,
+i.e. an invalid nonterminal symbol, or if any the chosen [arg mode]s
+is not one of the legal values.
+
+[call [arg objectName] [method rules]]
+
+This method returns a dictionary mapping the set of all nonterminal
+symbols known to the grammar to their parsing expressions (right-hand
+sides).
+
+[call [arg objectName] [method rules] [arg dict]]
+
+This method takes a dictionary mapping a set of nonterminal symbols
+known to the grammar to their parsing expressions (right-hand sides),
+and returns the new full mapping of nonterminal symbols to parsing
+expressions.
+
+[para]
+
+The method will fail with an error any of the nonterminal symbols in
+the dictionary is not known to the grammar, or the empty string,
+i.e. an invalid nonterminal symbol, or any of the chosen parsing
+expressions is not a valid parsing expression as specified in the
+section [sectref {PE serialization format}].
+
+[call [arg objectName] [method add] [opt [arg nt]...]]
+
+This method adds the nonterminal symbols [arg nt], etc. to the
+grammar, and defines default semantic mode and expression for it
+([const value] and [const epsilon] respectively).
+
+The method returns the empty string as its result.
+
+[para]
+
+The method will fail with an error and leaves the grammar unchanged if
+any of the nonterminal symbols are either already defined in our
+grammar, or are the empty string (an invalid nonterminal symbol).
+
+[para]
+
+The method does nothing if no symbol was specified as argument.
+
+[call [arg objectName] [method remove] [opt [arg nt]...]]
+
+This method removes the named nonterminal symbols [arg nt], etc. from
+the set of nonterminal symbols known to our grammar.
+
+The method returns the empty string as its result.
+
+[para]
+
+The method will fail with an error and leave the grammar unchanged if
+any of the nonterminal symbols is not known to the grammar, or is the
+empty string, i.e. an invalid nonterminal symbol.
+
+[call [arg objectName] [method exists] [arg nt]]
+
+This method tests whether the nonterminal symbol [arg nt] is known
+to our grammar or not.
+
+The result is a boolean value. It will be set to [const true] if
+[arg nt] is known, and [const false] otherwise.
+
+[para]
+
+The method will fail with an error if [arg nt] is the empty string,
+i.e. an invalid nonterminal symbol.
+
+[call [arg objectName] [method rename] [arg ntold] [arg ntnew]]
+
+This method renames the nonterminal symbol [arg ntold] to [arg ntnew].
+The method returns the empty string as its result.
+
+[para]
+
+The method will fail with an error and leave the grammar unchanged if
+either [arg ntold] is not known to the grammar, or [arg ntnew] is
+already known, or any of them is the empty string, i.e. an invalid
+nonterminal symbol.
+
+[call [arg objectName] [method mode] [arg nt]]
+
+This method returns the current semantic mode for the nonterminal
+symbol [arg nt].
+
+[para]
+
+The method will fail with an error if [arg nt] is not known to the
+grammar, or the empty string, i.e. an invalid nonterminal symbol.
+
+[call [arg objectName] [method mode] [arg nt] [arg mode]]
+
+This mode sets the semantic mode for the nonterminal symbol [arg nt],
+and returns the new mode.
+
+The method will fail with an error if [arg nt] is not known to the
+grammar, or the empty string, i.e. an invalid nonterminal symbol, or
+the chosen [arg mode] is not one of the legal values.
+
+[para]
+
+The following modes are legal:
+[include include/modes.inc]
+
+[call [arg objectName] [method rule] [arg nt]]
+
+This method returns the current parsing expression (right-hand side)
+for the nonterminal symbol [arg nt].
+
+[para]
+
+The method will fail with an error if [arg nt] is not known to the
+grammar, or the empty string, i.e. an invalid nonterminal symbol.
+
+[call [arg objectName] [method rule] [arg nt] [arg pe]]
+
+This method set the parsing expression (right-hand side) of the
+nonterminal [arg nt] to [arg pe], and returns the new parsing
+expression.
+
+[para]
+
+The method will fail with an error if [arg nt] is not known to the
+grammar, or the empty string, i.e. an invalid nonterminal symbol, or
+[arg pe] does not contain a valid parsing expression as specified in
+the section [sectref {PE serialization format}].
+
+[list_end]
+[para]
+
+[include include/serial/pegrammar.inc]
+[include include/serial/pexpression.inc]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_peg_container.tcl b/tcllib/modules/pt/pt_peg_container.tcl
new file mode 100644
index 0000000..96915b6
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_container.tcl
@@ -0,0 +1,530 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Grammars / Parsing Expression Grammars / Container
+
+# ### ### ### ######### ######### #########
+## Package description
+
+# A class whose instances hold all the information describing a single
+# parsing expression grammar (terminal symbols, nonterminal symbols,
+# nonterminal rules, start expression, parsing hints (called 'mode')),
+# and operations to define, manipulate, and query this information.
+#
+# Note that the container provides no higher-level operations on the
+# grammar, like the removal of unreachable nonterminals, rule
+# rewriting, etc.
+#
+# The set of terminal symbols is the set of characters (i.e.
+# implicitly defined). For Tcl this means that all the unicode
+# characters are supported.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require snit ; # Tcllib | OO system used
+package require pt::pe ; # PE serialization
+package require pt::peg ; # PEG serialization
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+snit::type ::pt::peg::container {
+ # Concepts:
+ # - A parsing expression grammar consists of a start (parsing)
+ # expression, and a set of nonterminal symbol with their
+ # definitions.
+ # - The definition of each nonterminal symbol consists of its
+ # name, semantic made, and sentennial structure, the latter
+ # provided by a parsing expression.
+ # - The nonterminal symbols are identified by their name, and each
+ # can occur at most once.
+
+ # ### ### ### ######### ######### #########
+ ## Options
+
+ ## None
+
+ # ### ### ### ######### ######### #########
+ ## Instance API
+
+ constructor {args} {}
+
+ # Bulk deletion.
+ method clear {} {}
+
+ # Bulk copying.
+ method = {source} {} ; # Assign contents
+ # of source object
+ # to us.
+ method --> {destination} {} ; # Assign our
+ # contents to the
+ # destination
+ # object.
+ method serialize {{format {}}} {} ; # Return our
+ # contents in the
+ # specified format
+ # (By default the
+ # canonical
+ # serialization).
+ method {deserialize =} {data {format {}}} {} ; # Assign contents
+ # in format to us
+ # (By default a
+ # regular
+ # serialization).
+ method {deserialize +=} {data {format {}}} {} ; # Add contents in
+ # format to us (By
+ # default a
+ # regular
+ # serialization).
+
+ # Bulk queries
+ method nonterminals {} {} ; # Return set of known symbols
+ method modes {{dict {}}} {} ; # Query/set dict (sym -> mode)
+ method rules {{dict {}}} {} ; # Query/set dict (sym -> rhs)
+
+ # Start expression
+ method start {{pe {}}} {} ; # Query/set start expression.
+
+ # Non-terminal manipulation and querying
+ method add {args} {} ; # Add new nonterminals, default
+ # rhs and modes.
+ method remove {args} {} ; # Remove nonterminals, and
+ # associated data.
+ method exists {nt} {} ; # Check if nonterminal is known.
+ method rename {nt ntnew} {} ; # Rename a nonterminal
+ method mode {nt {mode {}}} {} ; # Query/set nonterminal mode
+ method rule {nt {rule {}}} {} ; # Query/set nonterminal rhs
+
+ # Administrative data
+ method importer {{object {}}} {} ; # Query/set import manager.
+ method exporter {{object {}}} {} ; # Query/set export manager.
+
+ # ### ### ### ######### ######### #########
+ ## Instance API Implementation.
+
+ constructor {args} {
+ $self clear
+
+ if {
+ (([llength $args] != 0) && ([llength $args] != 2)) ||
+ (([llength $args] == 2) && ([lindex $args 0] ni {= := <-- as deserialize}))
+ } {
+ return -code error "wrong#args: $self ?=|:=|<--|as|deserialize a'?"
+ }
+
+ # Serialization arguments.
+ # [llength args] in {0 2}
+ #
+ # = src-obj
+ # := src-obj
+ # <-- src-obj
+ # as src-obj
+ # deserialize src-value
+
+ if {[llength $args] == 2} {
+ foreach {op val} $args break
+ switch -exact -- $op {
+ = - := - <-- - as {
+ $self deserialize = [$val serialize]
+ }
+ deserialize {
+ $self deserialize = $val
+ }
+ }
+ }
+ return
+ }
+
+ # Default destructor.
+
+ # ### ### ### ######### ######### #########
+
+ method invalidate {} {
+ array unset mypeg *
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Administrative data
+
+ method exporter {{object {}}} {
+ # TODO :: unlink/link change notification callbacks on the
+ # config/include components so that we can invalidate our
+ # cache when the settings change.
+
+ if {[llength [info level 0]] == 6} {
+ set myexporter $object
+ }
+ return $myexporter
+ }
+
+ method importer {{object {}}} {
+ if {[llength [info level 0]] == 6} {
+ set myimporter $object
+ }
+ return $myimporter
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Direct manipulation of the grammar.
+
+ ## Bulk deletion
+
+ method clear {} {
+ array unset myrhs *
+ array unset mymode *
+ set mystartpe [pt::pe epsilon]
+ return
+ }
+
+ ## Bulk queries
+
+ method nonterminals {} {
+ return [array names myrhs]
+ }
+
+ method modes {{dict {}}} {
+ if {[llength [info level 0]] == 6} {
+ VerifyAsKnown [dict keys $dict]
+ foreach mode [dict values $dict] {
+ if {![info exists ourmode($mode)]} {
+ set ours [linsert [join [lsort -dict [array names ourmode]] ", "] end-1 or]
+ return -code error "Expected one of $ours, got \"$mode\""
+ }
+ }
+ array set mymode $dict
+ return
+ }
+ return [array get mymode]
+ }
+
+ method rules {{dict {}}} {
+ if {[llength [info level 0]] == 6} {
+ VerifyAsKnown [dict keys $dict]
+ foreach {nt pe} $dict {
+ lappend tmp $nt [pt::pe canonicalize $pe]
+ }
+ array set myrhs $tmp
+ return
+ }
+ return [array get myrhs]
+ }
+
+ ## Start expression
+
+ method start {{pe {}}} {
+ if {[llength [info level 0]] == 6} {
+ set mystartpe [pt::pe canonicalize $pe]
+ return
+ }
+ return $mystartpe
+ }
+
+ ## Non-terminal manipulation and querying
+
+ method add {args} {
+ if {![llength $args]} return
+ VerifyAsUnknown $args
+ foreach nt $args {
+ set myrhs($nt) [pt::pe epsilon]
+ set mymode($nt) value
+ }
+ return
+ }
+
+ method remove {args} {
+ if {![llength $args]} return
+ VerifyAsKnown $args
+ foreach nt $args {
+ unset myrhs($nt)
+ unset mymode($nt)
+ }
+ return
+ }
+
+ method exists {nt} {
+ if {$nt eq {}} {
+ return -code error "Expected nonterminal name, got the empty string"
+ }
+ return [info exists myrhs($nt)]
+ }
+
+ method rename {ntold ntnew} {
+ VerifyAsKnown1 $ntold
+ VerifyAsUnknown1 $ntnew
+
+ # We have to go through all rules and rewrite their RHS to use
+ # the new name of the nonterminal.
+
+ set myrhs($ntnew) $myrhs($ntold)
+ unset myrhs($ntold)
+ set mymode($ntnew) $mymode($ntold)
+ unset mymode($ntold)
+
+ foreach nt [array names myrhs] {
+ set myrhs($nt) [pt::pe rename \
+ $myrhs($nt) $ntold $ntnew]
+ }
+ return
+ }
+
+ method mode {nt {mode {}}} {
+ VerifyAsKnown1 $nt
+ if {[llength [info level 0]] == 7} {
+ if {![info exists ourmode($mode)]} {
+ set ours [linsert [join [lsort -dict [array names ourmode]] ", "] end-1 or]
+ return -code error "Expected one of $ours, got \"$mode\""
+ }
+ set mymode($nt) $mode
+ }
+ return $mymode($nt)
+ }
+
+ method rule {nt {pe {}}} {
+ VerifyAsKnown1 $nt
+ if {[llength [info level 0]] == 7} {
+ set myrhs($nt) [pt::pe canonicalize $pe]
+ }
+ return $myrhs($nt)
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Public methods. Bulk loading and merging.
+
+ method = {source} {
+ $self deserialize [$source serialize]
+ return
+ }
+
+ method --> {destination} {
+ $destination deserialize [$self serialize]
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method serialize {{format {}}} {
+ # Default format is the regular PEG serialization
+ if {[llength [info level 0]] == 5} {
+ set format serial
+ }
+
+ # First check the cache for a remebered representation of the
+ # index for the chosen format, and return it, if such is
+ # known.
+
+ if {[info exists mypeg($format)]} {
+ return $mypeg($format)
+ }
+
+ # If there is no cached representation we have to generate it
+ # from it from our internal representation.
+
+ if {$format eq "serial"} {
+ return [$self GenerateSerial]
+ } else {
+ return [$self Generate $format]
+ }
+
+ return -code error "Internal error, reached unreachable location"
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method {deserialize =} {data {format {}}} {
+ # Default format is the regular PEG serialization
+ if {[llength [info level 0]] == 6} {
+ set format serial
+ }
+
+ if {$format ne "serial"} {
+ set data [$self Import $format $data]
+ # pt::peg verify-as-canonical $data
+ # ImportSerial verifies.
+ }
+
+ $self ImportSerial $data
+ return
+ }
+
+ method {deserialize +=} {data {format {}}} {
+ # Default format is the regular PEG serialization
+ if {[llength [info level 0]] == 6} {
+ set format serial
+ }
+
+ if {$format ne "serial"} {
+ set data [$self Import $format $data]
+ # pt::peg verify-as-canonical $data
+ # merge or ImportSerial verify the structure.
+ }
+
+ set data [pt::peg merge [$self serialize] $data]
+ # pt::peg verify-as-canonical $data
+ # ImportSerial verifies.
+
+ $self ImportSerial $data
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal methods
+
+ proc VerifyAsKnown1 {nt} {
+ upvar 1 myrhs myrhs
+ if {$nt eq {}} {
+ return -code error "Expected nonterminal name, got the empty string"
+ }
+ if {![info exists myrhs($nt)]} {
+ return -code error "Invalid nonterminal \"$nt\""
+ }
+ return
+ }
+
+ proc VerifyAsUnknown1 {nt} {
+ upvar 1 myrhs myrhs
+ if {$nt eq {}} {
+ return -code error "Expected nonterminal name, got the empty string"
+ }
+ if {[info exists myrhs($nt)]} {
+ return -code error "Nonterminal \"$nt\" is already known"
+ }
+ return
+ }
+
+ proc VerifyAsKnown {ntlist} {
+ upvar 1 myrhs myrhs
+ foreach nt $ntlist {
+ if {$nt eq {}} {
+ return -code error "Expected nonterminal name, got the empty string"
+ }
+ if {![info exists myrhs($nt)]} {
+ return -code error "Invalid nonterminal \"$nt\""
+ }
+ }
+ return
+ }
+
+ proc VerifyAsUnknown {ntlist} {
+ upvar 1 myrhs myrhs
+ foreach nt $ntlist {
+ if {$nt eq {}} {
+ return -code error "Expected nonterminal name, got the empty string"
+ }
+ if {[info exists myrhs($nt)]} {
+ return -code error "Nonterminal \"$nt\" is already known"
+ }
+ }
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method GenerateSerial {} {
+ # We can generate the list serialization easily from the
+ # internal representation.
+
+ # Construct result. inside out
+ set rules {}
+ foreach nt [lsort -dict [array names myrhs]] {
+ lappend rules $nt [list \
+ is $myrhs($nt) \
+ mode $mymode($nt)]
+ }
+
+ set serial [list pt::grammar::peg \
+ [list \
+ rules $rules \
+ start $mystartpe]]
+
+ # This is just present to assert that the code above creates
+ # correct serializations.
+ pt::peg verify-as-canonical $serial
+
+ set mypeg(serial) $serial
+ return $serial
+ }
+
+ method Generate {format} {
+ if {$myexporter eq {}} {
+ return -code error "Unable to export from \"$format\", no exporter configured"
+ }
+ set res [$myexporter export object $self $format]
+ set mypeg($format) $res
+ return $res
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method ImportSerial {serial} {
+ pt::peg verify $serial iscanonical
+
+ # Kill existing content
+ $self clear
+
+ # Unpack the serialization.
+ array set peg $serial
+ array set peg $peg(pt::grammar::peg)
+ unset peg(pt::grammar::peg)
+
+ # We are setting the relevant variables directly instead of
+ # going through the accessor methods.
+
+ set mystartpe $peg(start)
+
+ foreach {nt def} $peg(rules) {
+ array set sd $def
+ set myrhs($nt) $sd(is)
+ set mymode($nt) $sd(mode)
+ unset sd
+ }
+
+ # Extend cache (only if canonical, as we return only canonical
+ # data).
+ if {$iscanonical} {
+ set mypeg(serial) $serial
+ }
+ return
+ }
+
+ method Import {format data} {
+ if {$myimporter eq {}} {
+ return -code error "Unable to import from \"$format\", no importer configured"
+ }
+
+ return [$myimporter import text $data $format]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## State
+
+ # References the to export/import managers extending the
+ # (de)serialization abilities of the grammar.
+
+ variable myexporter {}
+ variable myimporter {}
+
+ # Internal representation of the grammar.
+
+ variable mystartpe {} ; # Start parsing expression.
+ variable myrhs -array {} ; # Right hand side (parsing
+ # expression)s for the known
+ # nonterminal symbols.
+ variable mymode -array {} ; # Modes for the known nonterminal
+ # symols.
+
+ typevariable ourmode -array {
+ value .
+ leaf .
+ void .
+ }
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Package Management
+
+package provide pt::peg::container 1
diff --git a/tcllib/modules/pt/pt_peg_container.test b/tcllib/modules/pt/pt_peg_container.test
new file mode 100644
index 0000000..ce42853
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_container.test
@@ -0,0 +1,52 @@
+# -*- tcl -*-
+# peg_container.test: Tests for the pt::peg package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_container.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use fileutil/fileutil.tcl fileutil
+ use snit/snit.tcl snit
+ use pluginmgr/pluginmgr.tcl pluginmgr
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pegrammar.tcl pt::peg
+
+ #useLocal peg_export.tcl pt::peg::export
+ #useLocal import.tcl pt::peg::import
+ #use doctools2base/nroff_manmacros.tcl doctools::nroff::man_macros
+
+ source [localPath tests/common]
+}
+testing {
+ useLocalKeep pt_peg_container.tcl pt::peg::container
+}
+
+# -------------------------------------------------------------------------
+
+#setup_plugins
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::set setimpl {
+ source [localPath tests/pt_peg_container.tests]
+}
+
+#----------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_container_peg.man b/tcllib/modules/pt/pt_peg_container_peg.man
new file mode 100644
index 0000000..3fcb7d0
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_container_peg.man
@@ -0,0 +1,22 @@
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt::peg::container::peg n 1]
+[include include/module.inc]
+[titledesc {PEG Storage. Canned PEG grammar specification}]
+[require snit]
+[require pt::peg::container::peg [opt 1]]
+[require pt::peg::container]
+[description]
+[include include/ref_intro.inc]
+
+This package provides a sub-type of [package pt::peg::container] which
+is preloaded with a parsing expression grammar describing a textual
+format for parsing expression grammars.
+
+[para]
+
+The sub-type provides the exact same API as
+[package pt::peg::container]. Instead of duplicating its contents the
+reader is asked to read the referenced document.
+
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_peg_container_peg.tcl b/tcllib/modules/pt/pt_peg_container_peg.tcl
new file mode 100644
index 0000000..8e03618
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_container_peg.tcl
@@ -0,0 +1,146 @@
+# -*- tcl -*-
+# Parsing Expression Grammar 'PEG'.
+# Definition of a human-readable form of parsing expression grammar specification.
+
+package require Tcl 8.5
+package require snit
+package require pt::peg::container
+
+snit::type pt::peg::container::peg {
+ constructor {} {
+ install myg using pt::peg::container ${selfns}::G
+ $myg start {n Grammar}
+ $myg add ALNUM ALPHA AND APOSTROPH ASCII Attribute Char CharOctalFull CharOctalPart CharSpecial CharUnescaped CharUnicode Class CLOSE CLOSEB COLON COMMENT DAPOSTROPH DDIGIT Definition DIGIT DOT END EOF EOL Expression Final Grammar GRAPH Header Ident Identifier IS LEAF Literal LOWER NOT OPEN OPENB PEG PLUS Prefix Primary PRINTABLE PUNCT QUESTION Range SEMICOLON Sequence SLASH SPACE STAR StartExpr Suffix TO UPPER VOID WHITESPACE WORDCHAR XDIGIT
+ $myg modes {
+ ALNUM leaf
+ ALPHA leaf
+ AND leaf
+ APOSTROPH void
+ ASCII leaf
+ Attribute value
+ Char value
+ CharOctalFull leaf
+ CharOctalPart leaf
+ CharSpecial leaf
+ CharUnescaped leaf
+ CharUnicode leaf
+ Class value
+ CLOSE void
+ CLOSEB void
+ COLON void
+ COMMENT void
+ DAPOSTROPH void
+ DDIGIT leaf
+ Definition value
+ DIGIT leaf
+ DOT leaf
+ END void
+ EOF void
+ EOL void
+ Expression value
+ Final void
+ Grammar value
+ GRAPH leaf
+ Header value
+ Ident leaf
+ Identifier value
+ IS void
+ LEAF leaf
+ Literal value
+ LOWER leaf
+ NOT leaf
+ OPEN void
+ OPENB void
+ PEG void
+ PLUS leaf
+ Prefix value
+ Primary value
+ PRINTABLE leaf
+ PUNCT leaf
+ QUESTION leaf
+ Range value
+ SEMICOLON void
+ Sequence value
+ SLASH void
+ SPACE leaf
+ STAR leaf
+ StartExpr value
+ Suffix value
+ TO void
+ UPPER leaf
+ VOID leaf
+ WHITESPACE void
+ WORDCHAR leaf
+ XDIGIT leaf
+ }
+ $myg rules {
+ ALNUM {x {t <} {t a} {t l} {t n} {t u} {t m} {t >} {n WHITESPACE}}
+ ALPHA {x {t <} {t a} {t l} {t p} {t h} {t a} {t >} {n WHITESPACE}}
+ AND {x {t &} {n WHITESPACE}}
+ APOSTROPH {t '}
+ ASCII {x {t <} {t a} {t s} {t c} {t i} {t i} {t >} {n WHITESPACE}}
+ Attribute {x {/ {n VOID} {n LEAF}} {n COLON}}
+ Char {/ {n CharSpecial} {n CharOctalFull} {n CharOctalPart} {n CharUnicode} {n CharUnescaped}}
+ CharOctalFull {x {t \134} {.. 0 2} {.. 0 7} {.. 0 7}}
+ CharOctalPart {x {t \134} {.. 0 7} {? {.. 0 7}}}
+ CharSpecial {x {t \134} {/ {t n} {t r} {t t} {t '} {t \42} {t \133} {t \135} {t \134}}}
+ CharUnescaped {x {! {t \134}} dot}
+ CharUnicode {x {t \134} {t u} xdigit {? {x xdigit {? {x xdigit {? xdigit}}}}}}
+ Class {x {n OPENB} {* {x {! {n CLOSEB}} {n Range}}} {n CLOSEB} {n WHITESPACE}}
+ CLOSE {x {t \51} {n WHITESPACE}}
+ CLOSEB {t \135}
+ COLON {x {t :} {n WHITESPACE}}
+ COMMENT {x {t #} {* {x {! {n EOL}} dot}} {n EOL}}
+ DAPOSTROPH {t \42}
+ DDIGIT {x {t <} {t d} {t d} {t i} {t g} {t i} {t t} {t >} {n WHITESPACE}}
+ Definition {x {? {n Attribute}} {n Identifier} {n IS} {n Expression} {n SEMICOLON}}
+ DIGIT {x {t <} {t d} {t i} {t g} {t i} {t t} {t >} {n WHITESPACE}}
+ DOT {x {t .} {n WHITESPACE}}
+ END {x {t E} {t N} {t D} {n WHITESPACE}}
+ EOF {! dot}
+ EOL {/ {x {t \r} {t \n}} {t \n} {t \r}}
+ Expression {x {n Sequence} {* {x {n SLASH} {n Sequence}}}}
+ Final {x {n END} {n SEMICOLON} {n WHITESPACE}}
+ Grammar {x {n WHITESPACE} {n Header} {* {n Definition}} {n Final} {n EOF}}
+ GRAPH {x {t <} {t g} {t r} {t a} {t p} {t h} {t >} {n WHITESPACE}}
+ Header {x {n PEG} {n Identifier} {n StartExpr}}
+ Ident {x {/ {t _} {t :} alpha} {* {/ {t _} {t :} alnum}}}
+ Identifier {x {n Ident} {n WHITESPACE}}
+ IS {x {t <} {t -} {n WHITESPACE}}
+ LEAF {x {t l} {t e} {t a} {t f} {n WHITESPACE}}
+ Literal {/ {x {n APOSTROPH} {* {x {! {n APOSTROPH}} {n Char}}} {n APOSTROPH} {n WHITESPACE}} {x {n DAPOSTROPH} {* {x {! {n DAPOSTROPH}} {n Char}}} {n DAPOSTROPH} {n WHITESPACE}}}
+ LOWER {x {t <} {t l} {t o} {t w} {t e} {t r} {t >} {n WHITESPACE}}
+ NOT {x {t !} {n WHITESPACE}}
+ OPEN {x {t \50} {n WHITESPACE}}
+ OPENB {t \133}
+ PEG {x {t P} {t E} {t G} {n WHITESPACE}}
+ PLUS {x {t +} {n WHITESPACE}}
+ Prefix {x {? {/ {n AND} {n NOT}}} {n Suffix}}
+ Primary {/ {n ALNUM} {n ALPHA} {n ASCII} {n DDIGIT} {n DIGIT} {n GRAPH} {n LOWER} {n PRINTABLE} {n PUNCT} {n SPACE} {n UPPER} {n WORDCHAR} {n XDIGIT} {n Identifier} {x {n OPEN} {n Expression} {n CLOSE}} {n Literal} {n Class} {n DOT}}
+ PRINTABLE {x {t <} {t p} {t r} {t i} {t n} {t t} {t >} {n WHITESPACE}}
+ PUNCT {x {t <} {t p} {t u} {t n} {t c} {t t} {t >} {n WHITESPACE}}
+ QUESTION {x {t ?} {n WHITESPACE}}
+ Range {/ {x {n Char} {n TO} {n Char}} {n Char}}
+ SEMICOLON {x {t \73} {n WHITESPACE}}
+ Sequence {+ {n Prefix}}
+ SLASH {x {t /} {n WHITESPACE}}
+ SPACE {x {t <} {t s} {t p} {t a} {t c} {t e} {t >} {n WHITESPACE}}
+ STAR {x {t *} {n WHITESPACE}}
+ StartExpr {x {n OPEN} {n Expression} {n CLOSE}}
+ Suffix {x {n Primary} {? {/ {n QUESTION} {n STAR} {n PLUS}}}}
+ TO {t -}
+ UPPER {x {t <} {t u} {t p} {t p} {t e} {t r} {t >} {n WHITESPACE}}
+ VOID {x {t v} {t o} {t i} {t d} {n WHITESPACE}}
+ WHITESPACE {* {/ {t \40} {t \t} {n EOL} {n COMMENT}}}
+ WORDCHAR {x {t <} {t w} {t o} {t r} {t d} {t c} {t h} {t a} {t r} {t >} {n WHITESPACE}}
+ XDIGIT {x {t <} {t x} {t d} {t i} {t g} {t i} {t t} {t >} {n WHITESPACE}}
+ }
+ return
+ }
+
+ component myg
+ delegate method * to myg
+}
+
+package provide pt::peg::container::peg 1
+return
diff --git a/tcllib/modules/pt/pt_peg_export.man b/tcllib/modules/pt/pt_peg_export.man
new file mode 100644
index 0000000..7b8cf5f
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_export.man
@@ -0,0 +1,195 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin pt::peg::export n 1]
+[include include/module.inc]
+[titledesc {PEG Export}]
+[require snit]
+[require configuration]
+[require pt::peg]
+[require pluginmgr]
+[require pt::peg::export [opt 1]]
+[description]
+[include include/ref_intro.inc]
+
+This package provides a manager for parsing expression grammars, with
+each instance handling a set of plugins for the export of them to
+other formats, i.e. their conversion to, for example [term nroff],
+[term HTML], etc.
+
+[para]
+
+It resides in the Export section of the Core Layer of Parser Tools,
+and is one of the three pillars the management of parsing expression
+grammars resides on.
+
+[para][image arch_core_export][para]
+
+The other two pillars are, as shown above
+
+[list_begin enum]
+[enum] [manpage {PEG Import}], and
+[enum] [manpage {PEG Storage}]
+[list_end]
+
+[para]
+
+For information about the data structure which is the major input to
+the manager objects provided by this package see the section
+[sectref {PEG serialization format}].
+
+[para]
+
+The plugin system of this class is based on the package
+[package pluginmgr], and configured to look for plugins using
+
+[list_begin enum]
+[enum] the environment variable [var GRAMMAR_PEG_EXPORT_PLUGINS],
+[enum] the environment variable [var GRAMMAR_PEG_PLUGINS],
+[enum] the environment variable [var GRAMMAR_PLUGINS],
+[enum] the path [file {~/.grammar/peg/export/plugin}]
+[enum] the path [file {~/.grammar/peg/plugin}]
+[enum] the path [file {~/.grammar/plugin}]
+[enum] the path [file {~/.grammar/peg/export/plugins}]
+[enum] the path [file {~/.grammar/peg/plugins}]
+[enum] the path [file {~/.grammar/plugins}]
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\GRAMMAR\PEG\EXPORT\PLUGINS"
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\GRAMMAR\PEG\PLUGINS"
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\GRAMMAR\PLUGINS"
+[list_end]
+
+The last three are used only when the package is run on a machine
+using the Windows(tm) operating system.
+
+[para]
+
+The whole system is delivered with three predefined export plugins,
+namely
+
+[list_begin definitions]
+[def container] See [manpage {PEG Export Plugin. To CONTAINER format}] for details.
+[def json] See [manpage {PEG Export Plugin. To JSON format}] for details.
+[def peg] See [manpage {PEG Export Plugin. To PEG format}] for details.
+[list_end]
+
+[para]
+
+For readers wishing to write their own export plugin for some format,
+i.e. [term {plugin writer}]s, reading and understanding the
+[manpage {Parser Tools Export API}] specification is an absolute
+necessity, as it documents the interaction between this package and
+its plugins in detail.
+
+[section API]
+[subsection {Package commands}]
+
+[list_begin definitions]
+
+[call [cmd ::pt::peg::export] [arg objectName]]
+
+This command creates a new export manager object with an associated
+Tcl command whose name is [arg objectName]. This [term object] command
+is explained in full detail in the sections [sectref {Object command}]
+and [sectref {Object methods}]. The object command will be created
+under the current namespace if the [arg objectName] is not fully
+qualified, and in the specified namespace otherwise.
+
+[list_end]
+
+[subsection {Object command}]
+
+All objects created by the [cmd ::pt::peg::export] command have
+the following general form:
+
+[list_begin definitions]
+
+[call [cmd objectName] [method method] [opt [arg "arg arg ..."]]]
+
+The method [method method] and its [arg arg]'uments determine the
+exact behavior of the command.
+
+See section [sectref {Object methods}] for the detailed
+specifications.
+
+[list_end]
+
+[subsection {Object methods}]
+
+[list_begin definitions]
+
+[call [arg objectName] [method destroy]]
+
+This method destroys the object it is invoked for.
+
+[call [arg objectName] [method {export serial}] [arg serial] [opt [arg format]]]
+
+This method takes the canonical serialization of a parsing expression
+grammar stored in [arg serial] and converts it to the specified
+[arg format], using the export plugin for the format. This will fail
+with an error if no plugin could be found for the format.
+
+The string generated by the conversion process is returned as
+the result of this method.
+
+[para]
+
+If no format is specified the method defaults to [const text].
+
+[para]
+
+The specification of what a [term canonical] serialization is can be
+found in the section [sectref {PEG serialization format}].
+
+[para]
+
+The plugin has to conform to the interface documented in the
+[manpage {Parser Tools Export API}] specification.
+
+[call [arg objectName] [method {export object}] [arg object] [opt [arg format]]]
+
+This method is a convenient wrapper around the [method {export serial}]
+method described by the previous item.
+
+It expects that [arg object] is an object command supporting a
+[method serialize] method returning the canonical serialization of a
+parsing expression grammar. It invokes that method, feeds the result
+into [method {export serial}] and returns the resulting string as its
+own result.
+
+[call [arg objectName] [method {configuration names}]]
+
+This method returns a list containing the names of all configuration
+options currently known to the object.
+
+[call [arg objectName] [method {configuration get}]]
+
+This method returns a dictionary containing the names and values of
+all configuration options currently known to the object.
+
+[call [arg objectName] [method {configuration set}] [arg name] \
+ [opt [arg value]]]
+
+This method sets the configuration option [arg name] to the
+specified [arg value] and returns the new value of the option.
+
+[para]
+
+If no value is specified it simply returns the current value, without
+changing it.
+
+[para]
+
+Note that these configuration options and their values are simply
+passed to a plugin when the actual export is performed. It is the
+plugin which checks the validity, not the manager.
+
+[call [arg objectName] [method {configuration unset}] [arg pattern]...]
+
+This method unsets all configuration options matching the specified
+glob [arg pattern]s. If no pattern is specified it will unset all
+currently defined configuration options.
+
+[list_end]
+
+[include include/serial/pegrammar.inc]
+[include include/serial/pexpression.inc]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_peg_export.tcl b/tcllib/modules/pt/pt_peg_export.tcl
new file mode 100644
index 0000000..5f78aac
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_export.tcl
@@ -0,0 +1,119 @@
+# pt_peg_export.tcl --
+#
+# Exporting parsing expression grammars into other formats.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pt_peg_export.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# Each object manages a set of plugins for the conversion of parsing
+# expression grammars into some textual representation. I.e. this
+# object manages the conversion to specialized serializations of
+# parsing expression grammars.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require configuration
+package require pt::peg
+package require pluginmgr
+package require snit
+
+# ### ### ### ######### ######### #########
+## API
+
+snit::type ::pt::peg::export {
+
+ # ### ### ### ######### ######### #########
+ ## Options :: None
+
+ # ### ### ### ######### ######### #########
+ ## Creation, destruction.
+
+ constructor {} {
+ install myconfig using ::configuration ${selfns}::CONFIG
+ return
+ }
+
+ destructor {
+ $myconfig destroy
+ # Clear the cache of loaded export plugins.
+ foreach k [array names myplugin] {
+ $myplugin($k) destroy
+ }
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Convert from the Tcl index serialization to other formats.
+
+ method {export object} {obj {format {}}} {
+ return [$self export serial [$obj serialize] $format]
+ }
+
+ method {export serial} {serial {format {}}} {
+ set serial [pt::peg canonicalize $serial]
+ set plugin [$self GetPlugin $format]
+
+ # We have a plugin, now feed it.
+
+ set configuration [$myconfig get]
+
+ return [$plugin do export $serial $configuration]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal methods
+
+ method GetPlugin {format} {
+ if {$format eq {}} { set format text }
+
+ if {![info exists myplugin($format)]} {
+ set plugin [pluginmgr ${selfns}::fmt-$format \
+ -pattern pt::peg::export::* \
+ -api { export } \
+ -setup [mymethod PluginSetup]]
+ ::pluginmgr::paths $plugin pt::peg::export
+ $plugin load $format
+ set myplugin($format) $plugin
+ } else {
+ set plugin $myplugin($format)
+ }
+
+ return $plugin
+ }
+
+ method PluginSetup {mgr ip} {
+ # Inject a pseudo package into the plugin interpreter the
+ # formatters can use to check that they were loaded into a
+ # proper environment.
+ $ip eval {package provide pt::peg::export::plugin 1}
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## State
+
+ # Array serving as a cache for the various plugin managers holding
+ # a specific export plugin.
+
+ variable myplugin -array {}
+
+ # A component managing the configuration given to the export
+ # plugins when they are invoked.
+
+ component myconfig -public configuration
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pt::peg::export 1
+return
diff --git a/tcllib/modules/pt/pt_peg_export.test b/tcllib/modules/pt/pt_peg_export.test
new file mode 100644
index 0000000..15767d2
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_export.test
@@ -0,0 +1,49 @@
+# -*- tcl -*-
+# peg_export.test: tests for the pt::peg::export package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_export.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use snit/snit.tcl snit
+ use pluginmgr/pluginmgr.tcl pluginmgr
+
+ useLocal configuration.tcl configuration
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pegrammar.tcl pt::peg
+
+ source [localPath tests/common]
+}
+testing {
+ useLocalKeep pt_peg_export.tcl pt::peg::export
+}
+
+# -------------------------------------------------------------------------
+
+setup_plugins
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::set setimpl {
+ source [localPath tests/pt_peg_export.tests]
+}
+
+#----------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_export_container.man b/tcllib/modules/pt/pt_peg_export_container.man
new file mode 100644
index 0000000..30cce4b
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_export_container.man
@@ -0,0 +1,6 @@
+[comment {--- doctools ---}]
+[vset PACKAGE container]
+[vset NAME CONTAINER]
+[vset CONFIG container]
+[vset VERSION 1]
+[include include/export/plugin.inc]
diff --git a/tcllib/modules/pt/pt_peg_export_container.tcl b/tcllib/modules/pt/pt_peg_export_container.tcl
new file mode 100644
index 0000000..4a4b455
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_export_container.tcl
@@ -0,0 +1,51 @@
+# peg_export_container.tcl --
+#
+# The PEG to CONTAINER export plugin. Generation of Tcl code, a
+# snit::type.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pt_peg_export_container.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# This package is a plugin for the pt::peg export manager. It
+# takes the canonical serialization of a parsing expression grammar
+# and produces text in CONTAINER format.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: pt::peg::export::plugin
+
+package require Tcl 8.5
+package require pt::peg::export::plugin ; # The presence of this
+ # pseudo package
+ # indicates execution
+ # inside of a properly
+ # initialized plugin
+ # interpreter.
+package require pt::peg::to::container
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc export {serial configuration} {
+
+ pt::peg::to::container reset
+ foreach {option value} $configuration {
+ pt::peg::to::container configure $option $value
+ }
+
+ set text [pt::peg::to::container convert $serial]
+
+ pt::peg::to::container reset
+ return $text
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pt::peg::export::container 1
+return
diff --git a/tcllib/modules/pt/pt_peg_export_container.test b/tcllib/modules/pt/pt_peg_export_container.test
new file mode 100644
index 0000000..d3d47f6
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_export_container.test
@@ -0,0 +1,50 @@
+# -*- tcl -*-
+# peg_export_container.test: tests for the pt::peg::export::container
+# package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_export_container.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal text_write.tcl text::write
+
+ source [localPath tests/common]
+}
+testing {
+ package provide pt::peg::export::plugin 1
+ # The above fakes the export plugin environment.
+
+ useLocal pt_peg_export_container.tcl pt::peg::export::container
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::set setimpl {
+ source [localPath tests/pt_peg_export_container.tests]
+}
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_export_json.man b/tcllib/modules/pt/pt_peg_export_json.man
new file mode 100644
index 0000000..57cfd62
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_export_json.man
@@ -0,0 +1,6 @@
+[comment {--- doctools ---}]
+[vset PACKAGE json]
+[vset NAME JSON]
+[vset CONFIG json]
+[vset VERSION 1]
+[include include/export/plugin.inc]
diff --git a/tcllib/modules/pt/pt_peg_export_json.tcl b/tcllib/modules/pt/pt_peg_export_json.tcl
new file mode 100644
index 0000000..12eaa50
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_export_json.tcl
@@ -0,0 +1,50 @@
+# pt_peg_export_json.tcl --
+#
+# The PEG to JSON export plugin. Generation of Tcl code, a
+# snit::type.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pt_peg_export_json.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# This package is a plugin for the pt::peg export manager. It
+# takes the canonical serialization of a parsing expression grammar
+# and produces text in JSON format.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: pt::peg::export::plugin
+
+package require Tcl 8.5
+package require pt::peg::export::plugin ; # The presence of this
+ # pseudo package indicates
+ # execution inside of a
+ # properly initialized
+ # plugin interpreter.
+package require pt::peg::to::json
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc export {serial configuration} {
+
+ pt::peg::to::json reset
+ foreach {option value} $configuration {
+ pt::peg::to::json configure $option $value
+ }
+
+ set text [pt::peg::to::json convert $serial]
+
+ pt::peg::to::json reset
+ return $text
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pt::peg::export::json 1
+return
diff --git a/tcllib/modules/pt/pt_peg_export_json.test b/tcllib/modules/pt/pt_peg_export_json.test
new file mode 100644
index 0000000..a0f055e
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_export_json.test
@@ -0,0 +1,48 @@
+# -*- tcl -*-
+# peg_export_json.test: tests for the pt::peg::export::json package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_export_json.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pegrammar.tcl pt::peg
+
+ source [localPath tests/common]
+}
+testing {
+ package provide pt::peg::export::plugin 1
+ # The above fakes the export plugin environment.
+
+ useLocal pt_peg_export_json.tcl pt::peg::export::json
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::set setimpl {
+ source [localPath tests/pt_peg_export_json.tests]
+}
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_export_peg.man b/tcllib/modules/pt/pt_peg_export_peg.man
new file mode 100644
index 0000000..1c89c13
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_export_peg.man
@@ -0,0 +1,6 @@
+[comment {--- doctools ---}]
+[vset PACKAGE peg]
+[vset NAME PEG]
+[vset CONFIG peg]
+[vset VERSION 1]
+[include include/export/plugin.inc]
diff --git a/tcllib/modules/pt/pt_peg_export_peg.tcl b/tcllib/modules/pt/pt_peg_export_peg.tcl
new file mode 100644
index 0000000..32c6ea3
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_export_peg.tcl
@@ -0,0 +1,51 @@
+# peg_to_export.tcl --
+#
+# The PEG to PEG (text representation) export plugin. Generation
+# of plain text.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pt_peg_export_peg.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# This package is a plugin for the pt::peg export manager. It
+# takes the canonical serialization of a parsing expression grammar
+# and produces the corresponding human readable text representation.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: pt::peg::export::plugin
+
+package require Tcl 8.5
+package require pt::peg::export::plugin ; # The presence of this
+ # pseudo package
+ # indicates execution
+ # inside of a properly
+ # initialized plugin
+ # interpreter.
+package require pt::peg::to::peg
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc export {serial configuration} {
+
+ pt::peg::to::peg reset
+ foreach {option value} $configuration {
+ pt::peg::to::peg configure $option $value
+ }
+
+ set text [pt::peg::to::peg convert $serial]
+
+ pt::peg::to::peg reset
+ return $text
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pt::peg::export::peg 1
+return
diff --git a/tcllib/modules/pt/pt_peg_export_peg.test b/tcllib/modules/pt/pt_peg_export_peg.test
new file mode 100644
index 0000000..7cf151e
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_export_peg.test
@@ -0,0 +1,49 @@
+# -*- tcl -*-
+# peg_export_peg.test: tests for the pt::peg::export::peg package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_export_peg.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pexpr_op.tcl pt::pe::op
+ useLocal pt_pegrammar.tcl pt::peg
+
+ source [localPath tests/common]
+}
+testing {
+ package provide pt::peg::export::plugin 1
+ # The above fakes the export plugin environment.
+
+ useLocal pt_peg_export_peg.tcl pt::peg::export::peg
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::set setimpl {
+ source [localPath tests/pt_peg_export_peg.tests]
+}
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_from_container.man b/tcllib/modules/pt/pt_peg_from_container.man
new file mode 100644
index 0000000..0771b4a
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_from_container.man
@@ -0,0 +1,21 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[manpage_begin pt::peg::from::container n 0]
+[include include/module.inc]
+[include include/keywords.inc]
+[titledesc "PEG Conversion. From CONTAINER format"]
+[description]
+[include include/ref_intro.inc]
+
+This package does not exist.
+
+There is no need for it.
+
+The CONTAINER format for parsing expression grammars is a piece of Tcl
+code which, then sourced, provides a class whose instances have the
+grammar we wish to import loaded.
+
+Another way of looking at this is, the CONTAINER output is its own
+import package.
+
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_peg_from_json.man b/tcllib/modules/pt/pt_peg_from_json.man
new file mode 100644
index 0000000..0d5dae4
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_from_json.man
@@ -0,0 +1,7 @@
+[comment {--- doctools ---}]
+[vset PACKAGE json]
+[vset NAME JSON]
+[vset REQUIRE json]
+[vset CONFIG json]
+[vset VERSION 1]
+[include include/import/from.inc]
diff --git a/tcllib/modules/pt/pt_peg_from_json.tcl b/tcllib/modules/pt/pt_peg_from_json.tcl
new file mode 100644
index 0000000..0d99d21
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_from_json.tcl
@@ -0,0 +1,48 @@
+# peg_from_json.tcl --
+#
+# Conversion to PEG from JSON (Java Script Object Notation).
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pt_peg_from_json.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# This package takes text in JSON format (Java Script data transfer
+# format) and produces the canonical serialization of a parsing
+# expression grammar.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require pt::peg ; # Verification that the input is proper.
+package require json
+
+# ### ### ### ######### ######### #########
+##
+
+namespace eval ::pt::peg::from::json {
+ namespace export convert
+ namespace ensemble create
+}
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc ::pt::peg::from::json::convert {text} {
+ # Note: We cannot fail here on duplicate keys in the input, as we
+ # do for Tcl-based canonical PEG serializations, because our
+ # underlying JSON parser automatically merges them, by taking only
+ # the last found definition. I.e. of two or more definitions for
+ # some key X the last overwrites all previous occurences.
+
+ return [pt::peg canonicalize [json::json2dict $text]]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pt::peg::from::json 1
+return
diff --git a/tcllib/modules/pt/pt_peg_from_json.test b/tcllib/modules/pt/pt_peg_from_json.test
new file mode 100644
index 0000000..834a68e
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_from_json.test
@@ -0,0 +1,40 @@
+# -*- tcl -*-
+# pt_peg_from_json.test: tests for the pt::peg::from::json converter package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_from_json.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use json/json.tcl json
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pegrammar.tcl pt::peg
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_peg_from_json.tcl pt::peg::from::json
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/pt_peg_from_json.tests]
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_from_peg.man b/tcllib/modules/pt/pt_peg_from_peg.man
new file mode 100644
index 0000000..e18e3e7
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_from_peg.man
@@ -0,0 +1,7 @@
+[comment {--- doctools ---}]
+[vset PACKAGE peg]
+[vset NAME PEG]
+[vset REQUIRE peg]
+[vset CONFIG peg]
+[vset VERSION 1.0.3]
+[include include/import/from.inc]
diff --git a/tcllib/modules/pt/pt_peg_from_peg.tcl b/tcllib/modules/pt/pt_peg_from_peg.tcl
new file mode 100644
index 0000000..7449224
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_from_peg.tcl
@@ -0,0 +1,394 @@
+# pt_peg_from_peg.tcl --
+#
+# Conversion from PEG (Human readable text) to PEG.
+#
+# Copyright (c) 2009-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pt_peg_from_peg.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# This package takes text for a human-readable PEG and produces the
+# canonical serialization of a parsing expression grammar.
+
+# TODO :: APIs for reading from arbitrary channel.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require pt::peg ; # Verification that the input is proper.
+#package require pt::peg::interp
+#package require pt::peg::container::peg
+package require pt::parse::peg
+package require pt::ast
+package require pt::pe
+package require pt::pe::op
+
+# ### ### ### ######### ######### #########
+##
+
+namespace eval ::pt::peg::from::peg {
+ namespace export convert convert-file
+ namespace ensemble create
+}
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc ::pt::peg::from::peg::convert {text} {
+ # Initialize data for the pseudo-channel
+ variable input $text
+ variable loc 0
+ variable max [expr { [string length $text] - 1 }]
+
+ return [Convert]
+}
+
+proc ::pt::peg::from::peg::convert-file {path} {
+ # Initialize data for the pseudo-channel
+ variable input [fileutil::cat $path]
+ variable loc 0
+ variable max [expr { [string length $input] - 1 }]
+
+ return [Convert]
+}
+
+# ### ### ### ######### ######### #########
+
+proc ::pt::peg::from::peg::Convert {} {
+ # Create the runtime ...
+ set c [chan create read pt::peg::from::peg::CHAN] ; # pseudo-channel for input
+
+ #set g [pt::peg::container::peg %AUTO] ; # load peg grammar
+ #set i [pt::peg::interp %AUTO% $g] ; # grammar interpreter / parser
+ #$g destroy
+ set i [pt::parse::peg]
+
+ # Parse input.
+ set fail [catch {
+ set ast [$i parse $c]
+ } msg]
+ if {$fail} {
+ set ei $::errorInfo
+ set ec $::errorCode
+ }
+
+ $i destroy
+ close $c
+
+ if {$fail} {
+ variable input {}
+ return -code error -errorinfo $ei -errorcode $ec $msg
+ }
+
+ # Now convert the AST to the grammar serial.
+ set serial [pt::ast bottomup \
+ pt::peg::from::peg::GEN \
+ $ast]
+
+ variable input {}
+ return $serial
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Internals - Pseudo channel to couple the in-memory text with the
+## RDE.
+
+namespace eval ::pt::peg::from::peg::CHAN {
+ namespace export initialize finalize read watch
+ namespace ensemble create
+}
+
+proc pt::peg::from::peg::CHAN::initialize {c mode} {
+ return {initialize finalize watch read}
+}
+
+proc pt::peg::from::peg::CHAN::finalize {c} {}
+proc pt::peg::from::peg::CHAN::watch {c events} {}
+
+proc pt::peg::from::peg::CHAN::read {c n} {
+ # Note: Should have binary string of the input, to properly handle
+ # encodings ...
+ variable ::pt::peg::from::peg::input
+ variable ::pt::peg::from::peg::loc
+ variable ::pt::peg::from::peg::max
+
+ if {$loc >= $max} { return {} }
+
+ set end [expr {$loc + $n - 1}]
+ set res [string range $input $loc $end]
+
+ incr loc $n
+
+ return $res
+}
+
+# ### ### ### ######### ######### #########
+## Internals - Bottom up walk converting AST to PEG serialization.
+## Pseudo-ensemble
+
+namespace eval ::pt::peg::from::peg::GEN {}
+
+proc pt::peg::from::peg::GEN {ast} {
+ # The reason for not being an ensemble, an additional param
+ # (8.6+ can code that as ensemble).
+ return [namespace eval GEN $ast]
+}
+
+proc pt::peg::from::peg::GEN::ALNUM {s e} {
+ return [pt::pe alnum]
+}
+
+proc pt::peg::from::peg::GEN::ALPHA {s e} {
+ return [pt::pe alpha]
+}
+
+proc pt::peg::from::peg::GEN::AND {s e} {
+ return [pt::pe ahead [pt::pe dot]] ; # -> Prefix
+}
+
+proc pt::peg::from::peg::GEN::ASCII {s e} {
+ return [pt::pe ascii]
+}
+
+proc pt::peg::from::peg::GEN::Attribute {s e args} {
+ return [lindex $args 0] ; # -> Definition
+}
+
+proc pt::peg::from::peg::GEN::Char {s e args} {
+ return [lindex $args 0]
+}
+
+proc pt::peg::from::peg::GEN::CharOctalFull {s e} {
+ variable ::pt::peg::from::peg::input
+ return [pt::pe terminal [char unquote [string range $input $s $e]]]
+}
+
+proc pt::peg::from::peg::GEN::CharOctalPart {s e} {
+ variable ::pt::peg::from::peg::input
+ return [pt::pe terminal [char unquote [string range $input $s $e]]]
+}
+
+proc pt::peg::from::peg::GEN::CharSpecial {s e} {
+ variable ::pt::peg::from::peg::input
+ return [pt::pe terminal [char unquote [string range $input $s $e]]]
+}
+
+proc pt::peg::from::peg::GEN::CharUnescaped {s e} {
+ variable ::pt::peg::from::peg::input
+ return [pt::pe terminal [string range $input $s $e]]
+}
+
+proc pt::peg::from::peg::GEN::CharUnicode {s e} {
+ variable ::pt::peg::from::peg::input
+ return [pt::pe terminal [char unquote [string range $input $s $e]]]
+}
+
+proc pt::peg::from::peg::GEN::Class {s e args} {
+ if {[llength $args] == 1} { ; # integrated pe::op flatten
+ return [lindex $args 0]
+ } else {
+ return [pt::pe choice {*}$args] ; # <- Chars and Ranges
+ }
+}
+
+proc pt::peg::from::peg::GEN::CONTROL {s e} {
+ return [pt::pe control]
+}
+
+proc pt::peg::from::peg::GEN::DDIGIT {s e} {
+ return [pt::pe ddigit]
+}
+
+proc pt::peg::from::peg::GEN::Definition {s e args} {
+ # args = list/2 (symbol pe) | <- Ident(ifier) Expression
+ # args = list/3 (mode symbol pe) | <- Attribute Ident(ifier) Expression
+ if {[llength $args] == 3} {
+ lassign $args mode sym pe
+ } else {
+ lassign $args sym pe
+ set mode value
+ }
+ # sym = list/2 ('n' name)
+ return [list [lindex $sym 1] $mode [pt::pe::op flatten $pe]]
+}
+
+proc pt::peg::from::peg::GEN::DIGIT {s e} {
+ return [pt::pe digit]
+}
+
+proc pt::peg::from::peg::GEN::DOT {s e} {
+ return [pt::pe dot]
+}
+
+proc pt::peg::from::peg::GEN::Expression {s e args} {
+ if {[llength $args] == 1} { ; # integrated pe::op flatten
+ return [lindex $args 0]
+ } else {
+ return [pt::pe choice {*}$args] ; # <- Primary
+ }
+}
+
+proc pt::peg::from::peg::GEN::Grammar {s e args} {
+ # args = list (start, list/3(symbol, mode, rule)...) <- Header Definition*
+ array set symbols {}
+ set rules {}
+ foreach def [lsort -index 0 -dict [lassign $args startexpr]] {
+ lassign $def sym mode rhs
+ if {[info exists symbol($sym)]} {
+ return -code error "Double declaration of symolb '$sym'"
+ }
+ set symbols($sym) .
+ lappend rules $sym [list is $rhs mode $mode]
+ }
+ # Full grammar
+ return [list pt::grammar::peg [list rules $rules start $startexpr]]
+}
+
+proc pt::peg::from::peg::GEN::GRAPH {s e} {
+ return [pt::pe graph]
+}
+
+proc pt::peg::from::peg::GEN::Header {s e args} {
+ # args = list/2 (list/2 ('n', name), pe) <- Ident(ifier) StartExpr
+ return [lindex $args 1] ; # StartExpr passes through
+}
+
+proc pt::peg::from::peg::GEN::Ident {s e} {
+ variable ::pt::peg::from::peg::input
+ return [pt::pe nonterminal [string range $input $s $e]]
+}
+
+proc pt::peg::from::peg::GEN::Identifier {s e args} {
+ return [lindex $args 0] ; # <- Ident, passes through
+}
+
+proc pt::peg::from::peg::GEN::LEAF {s e} {
+ return leaf
+}
+
+proc pt::peg::from::peg::GEN::LOWER {s e} {
+ return [pt::pe lower]
+}
+
+proc pt::peg::from::peg::GEN::Literal {s e args} {
+ set n [llength $args]
+ if {$n == 1} {
+ # integrated pe::op flatten, return just the char.
+ return [lindex $args 0]
+ } elseif {$n == 0} {
+ # No chars, empty string, IOW epsilon.
+ return [pt::pe epsilon]
+ } else {
+ # Series of chars -> Primary
+ return [pt::pe sequence {*}$args]
+ }
+}
+
+proc pt::peg::from::peg::GEN::NOT {s e} {
+ return [pt::pe notahead [pt::pe dot]] ; # -> Prefix (dot is placeholder)
+}
+
+proc pt::peg::from::peg::GEN::PLUS {s e} {
+ return [pt::pe repeat1 [pt::pe dot]] ; # -> Suffix (dot is placeholder)
+}
+
+proc pt::peg::from::peg::GEN::Primary {s e args} {
+ return [lindex $args 0] ; # -> Expression, pass through
+}
+
+proc pt::peg::from::peg::GEN::Prefix {s e args} {
+ # args = list/1 (pe) | <- AND/NOT, Expression
+ # args = list/2 (pe/prefix, pe) | <- Expression
+ if {[llength $args] == 2} {
+ # Prefix operator present ... Replace its child (dot,
+ # placeholder) with our second, the actual expression.
+ return [lreplace [lindex $args 0] 1 1 [lindex $args 1]]
+ } else {
+ # Pass the sub-expression
+ return [lindex $args 0]
+ }
+}
+
+proc pt::peg::from::peg::GEN::PRINTABLE {s e} {
+ return [pt::pe printable]
+}
+
+proc pt::peg::from::peg::GEN::PUNCT {s e} {
+ return [pt::pe punct]
+}
+
+proc pt::peg::from::peg::GEN::QUESTION {s e} {
+ return [pt::pe optional [pt::pe dot]] ; # -> Suffix (dot is placeholder)
+}
+
+proc pt::peg::from::peg::GEN::Range {s e args} {
+ # args = list/1 (pe/t) | <- Char (pass through)
+ # args = list/2 (pe/t, pe/t) | <- Char, Char
+ if {[llength $args] == 2} {
+ # Convert two terminals to range
+ return [pt::pe range [lindex $args 0 1] [lindex $args 1 1]]
+ } else {
+ # Pass the char ...
+ return [lindex $args 0]
+ }
+}
+
+proc pt::peg::from::peg::GEN::Sequence {s e args} {
+ if {[llength $args] == 1} { ; # integrated pe::op flatten
+ return [lindex $args 0]
+ } else {
+ return [pt::pe sequence {*}$args] ; # <- Prefix+
+ }
+}
+
+proc pt::peg::from::peg::GEN::SPACE {s e} {
+ return [pt::pe space]
+}
+
+proc pt::peg::from::peg::GEN::STAR {s e} {
+ return [pt::pe repeat0 [pt::pe dot]] ; # -> Suffix (dot is placeholder)
+}
+
+proc pt::peg::from::peg::GEN::StartExpr {s e args} {
+ # args = list/1 (pe) | <- Expression, -> Header
+ return [pt::pe::op flatten [lindex $args 0]]
+}
+proc pt::peg::from::peg::GEN::Suffix {s e args} {
+ # args = list/1 (pe) | <- Expression
+ # args = list/2 (pe, pe/suffix) | <- Expression */+/?
+ if {[llength $args] == 2} {
+ # Suffix operator present ... Replace its child (dot,
+ # placeholder) with our first, the actual expression.
+ return [lreplace [lindex $args 1] 1 1 [lindex $args 0]]
+ } else {
+ # Pass the sub-expression
+ return [lindex $args 0]
+ }
+}
+
+proc pt::peg::from::peg::GEN::UPPER {s e} {
+ return [pt::pe upper]
+}
+
+proc pt::peg::from::peg::GEN::VOID {s e} {
+ return void
+}
+
+proc pt::peg::from::peg::GEN::WORDCHAR {s e} {
+ return [pt::pe wordchar]
+}
+
+proc pt::peg::from::peg::GEN::XDIGIT {s e} {
+ return [pt::pe xdigit]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pt::peg::from::peg 1.0.3
+return
diff --git a/tcllib/modules/pt/pt_peg_from_peg.test b/tcllib/modules/pt/pt_peg_from_peg.test
new file mode 100644
index 0000000..65667ae
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_from_peg.test
@@ -0,0 +1,86 @@
+# -*- tcl -*-
+# pt_peg_from_peg.test: tests for the pt::peg::from::peg converter package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_from_peg.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/stack.tcl struct::stack ; # User: pt::rde
+ TestAccelInit struct::stack ; # (tcl)
+
+ use snit/snit.tcl snit
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_astree.tcl pt::ast
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pexpr_op.tcl pt::pe::op
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal pt_peg_container.tcl pt::peg::container
+
+ useAccel [useTcllibC] pt/pt_rdengine.tcl pt::rde ; # User: pt::parse::peg
+ TestAccelInit pt::rde ; # or: pt:peg::interp
+
+ # Get the parser used by the converter, either the grammar
+ # interpreter, or snit-based and spcialized to PEG.
+ #useLocal pt_peg_container_peg.tcl pt::peg::container::peg
+ #useLocal pt_peg_interp.tcl pt::peg::interp
+
+ useAccel [useTcllibC] pt/pt_parse_peg.tcl pt::parse::peg ; # User: pt::peg::from::peg
+ TestAccelInit pt::parse::peg
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_peg_from_peg.tcl pt::peg::from::peg
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+# Note: When using pt::rde's C implementation struct::stack is not
+# used, and its implementation of no relevance.
+#
+# Similarly, when pt::parse::peg's C implementation is used
+# neither pt::rde's, nor struct::stack's implementations are of
+# relevance.
+
+TestAccelDo pt::parse::peg parseimpl {
+ if {$parseimpl eq "critcl"} {
+ set rdeimpl n/a
+ set stackimpl n/a
+ pt::rde::SwitchTo {}
+ struct::stack::SwitchTo {}
+ source [localPath tests/pt_peg_from_peg.tests]
+ } else {
+ TestAccelDo pt::rde rdeimpl {
+ if {$rdeimpl eq "critcl"} {
+ set stackimpl n/a
+ struct::stack::SwitchTo {}
+ source [localPath tests/pt_peg_from_peg.tests]
+ } else {
+ TestAccelDo struct::stack stackimpl {
+ source [localPath tests/pt_peg_from_peg.tests]
+ }
+ }
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+TestAccelExit pt::parse::peg
+TestAccelExit pt::rde
+TestAccelExit struct::stack
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_import.man b/tcllib/modules/pt/pt_peg_import.man
new file mode 100644
index 0000000..8712a8a
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_import.man
@@ -0,0 +1,218 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin pt::peg::import n 1]
+[include include/module.inc]
+[titledesc {PEG Import}]
+[require snit]
+[require configuration]
+[require pt::peg]
+[require pluginmgr]
+[require pt::peg::import [opt 1]]
+[description]
+[include include/ref_intro.inc]
+
+This package provides a manager for parsing expression grammars, with
+each instance handling a set of plugins for the import of them from
+other formats, i.e. their conversion from, for example [term peg],
+[term container], [term json], etc.
+
+[para]
+
+It resides in the Import section of the Core Layer of Parser Tools,
+and is one of the three pillars the management of parsing expression
+grammars resides on.
+
+[para][image arch_core_import][para]
+
+The other two pillars are, as shown above
+
+[list_begin enum]
+[enum] [manpage {PEG Export}], and
+[enum] [manpage {PEG Storage}]
+[list_end]
+
+[para]
+
+For information about the data structure which is the major output of
+the manager objects provided by this package see the section
+[sectref {PEG serialization format}].
+
+[para]
+
+The plugin system of our class is based on the package
+[package pluginmgr], and configured to look for plugins using
+
+[list_begin enum]
+[enum] the environment variable [var GRAMMAR_PEG_IMPORT_PLUGINS],
+[enum] the environment variable [var GRAMMAR_PEG_PLUGINS],
+[enum] the environment variable [var GRAMMAR_PLUGINS],
+[enum] the path [file {~/.grammar/peg/import/plugin}]
+[enum] the path [file {~/.grammar/peg/plugin}]
+[enum] the path [file {~/.grammar/plugin}]
+[enum] the path [file {~/.grammar/peg/import/plugins}]
+[enum] the path [file {~/.grammar/peg/plugins}]
+[enum] the path [file {~/.grammar/plugins}]
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\GRAMMAR\PEG\IMPORT\PLUGINS"
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\GRAMMAR\PEG\PLUGINS"
+[enum] the registry entry "HKEY_CURRENT_USER\SOFTWARE\GRAMMAR\PLUGINS"
+[list_end]
+
+The last three are used only when the package is run on a machine
+using the Windows(tm) operating system.
+
+[para]
+
+The whole system is delivered with three predefined import plugins,
+namely
+
+[list_begin definitions]
+[def container] See [manpage {PEG Import Plugin. From CONTAINER format}] for details.
+[def json] See [manpage {PEG Import Plugin. From JSON format}] for details.
+[def peg] See [manpage {PEG Import Plugin. From PEG format}] for details.
+[list_end]
+
+[para]
+
+For readers wishing to write their own import plugin for some format,
+i.e. [term {plugin writer}]s, reading and understanding the
+[manpage {Parser Tools Impport API}] specification is an absolute
+necessity, as it documents the interaction between this package and
+its plugins in detail.
+
+[section API]
+[subsection {Package commands}]
+
+[list_begin definitions]
+
+[call [cmd ::pt::peg::import] [arg objectName]]
+
+This command creates a new import manager object with an associated
+Tcl command whose name is [arg objectName]. This [term object] command
+is explained in full detail in the sections [sectref {Object command}]
+and [sectref {Object methods}]. The object command will be created
+under the current namespace if the [arg objectName] is not fully
+qualified, and in the specified namespace otherwise.
+
+[list_end]
+
+[subsection {Object command}]
+
+All objects created by the [cmd ::pt::peg::import] command have
+the following general form:
+
+[list_begin definitions]
+
+[call [cmd objectName] [method method] [opt [arg "arg arg ..."]]]
+
+The method [method method] and its [arg arg]'uments determine the
+exact behavior of the command.
+
+See section [sectref {Object methods}] for the detailed
+specifications.
+
+[list_end]
+
+[subsection {Object methods}]
+
+[list_begin definitions]
+
+[call [arg objectName] [method destroy]]
+
+This method destroys the object it is invoked for.
+
+[call [arg objectName] [method {import text}] [arg text] [opt [arg format]]]
+
+This method takes the [arg text] and converts it from the specified
+[arg format] to the canonical serialization of a parsing expression
+grammar using the import plugin for the format. An error is thrown if
+no plugin could be found for the format.
+
+The serialization generated by the conversion process is returned as
+the result of this method.
+
+[para]
+
+If no format is specified the method defaults to [const text].
+
+[para]
+
+The specification of what a [term canonical] serialization is can be
+found in the section [sectref {PEG serialization format}].
+
+[para]
+
+The plugin has to conform to the interface documented in the
+[manpage {Parser Tools Import API}] specification.
+
+[call [arg objectName] [method {import file}] [arg path] [opt [arg format]]]
+
+This method is a convenient wrapper around the [method {import text}]
+method described by the previous item.
+
+It reads the contents of the specified file into memory, feeds the
+result into [method {import text}] and returns the resulting
+serialization as its own result.
+
+[call [arg objectName] [method {import object text}] [arg object] \
+ [arg text] [opt [arg format]]]
+
+This method is a convenient wrapper around the [method {import text}]
+method described by the previous item.
+
+It expects that [arg object] is an object command supporting a
+[method deserialize] method expecting the canonical serialization of a
+parsing expression grammar.
+
+It imports the text using [method {import text}] and then feeds the
+resulting serialization into the [arg object] via [method deserialize].
+
+This method returns the empty string as it result.
+
+[call [arg objectName] [method {import object file}] [arg object] \
+ [arg path] [opt [arg format]]]
+
+This method behaves like [method {import object text}], except that it
+reads the text to convert from the specified file instead of being
+given it as argument.
+
+[call [arg objectName] [method includes]]
+
+This method returns a list containing the currently specified paths to
+use to search for include files when processing input.
+
+The order of paths in the list corresponds to the order in which they
+are used, from first to last, and also corresponds to the order in
+which they were added to the object.
+
+[call [arg objectName] [method {include add}] [arg path]]
+
+This methods adds the specified [arg path] to the list of paths to use
+to search for include files when processing input. The path is added
+to the end of the list, causing it to be searched after all previously
+added paths. The result of the command is the empty string.
+
+[para]
+
+The method does nothing if the path is already known.
+
+[call [arg objectName] [method {include remove}] [arg path]]
+
+This methods removes the specified [arg path] from the list of paths
+to use to search for include files when processing input. The result
+of the command is the empty string.
+
+[para]
+
+The method does nothing if the path is not known.
+
+[call [arg objectName] [method {include clear}]]
+
+This method clears the list of paths to use to search for include
+files when processing input. The result of the command is the empty
+string.
+
+[list_end]
+
+[include include/serial/pegrammar.inc]
+[include include/serial/pexpression.inc]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_peg_import.tcl b/tcllib/modules/pt/pt_peg_import.tcl
new file mode 100644
index 0000000..00a653d
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_import.tcl
@@ -0,0 +1,190 @@
+# import.tcl --
+#
+# Importing parsing expression grammars from other formats.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pt_peg_import.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# Each object manages a set of plugins for the creation of parsing
+# expression grammars from some textual representation. I.e. this
+# object manages the conversion from specialized serializations of
+# parsing expression grammars into their standard form.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require paths
+package require pt::peg
+package require pluginmgr
+package require snit
+
+# ### ### ### ######### ######### #########
+## API
+
+snit::type ::pt::peg::import {
+
+ # ### ### ### ######### ######### #########
+ ## Options :: None
+
+ # ### ### ### ######### ######### #########
+ ## Creation, destruction.
+
+ constructor {} {
+ install myinclude using ::paths ${selfns}::INCLUDE
+ return
+ }
+
+ destructor {
+ $myinclude destroy
+ # Clear the cache of loaded import plugins.
+ foreach k [array names myplugin] {
+ $myplugin($k) destroy
+ }
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Convert from other formats to the Tcl PEG serialization
+
+ method {import object text} {obj text {format {}}} {
+ $obj deserialize [$self import text $text $format]
+ return
+ }
+
+ method {import object file} {obj path {format {}}} {
+ $obj deserialize [$self import file $path $format]
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method {import text} {text {format {}}} {
+ set plugin [$self GetPlugin $format]
+
+ return [$plugin do import $text]
+ }
+
+ method {import file} {path {format {}}} {
+ # The plugin is not trusted to handle the file to convert.
+ return [$self import text [fileutil::cat $path] $format]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Internal methods
+
+ method GetPlugin {format} {
+ if {$format eq {}} { set format text }
+
+ if {![info exists myplugin($format)]} {
+ set plugin [pluginmgr ${selfns}::fmt-$format \
+ -pattern pt::peg::import::* \
+ -api { import } \
+ -setup [mymethod PluginSetup]]
+ ::pluginmgr::paths $plugin pt::peg::import
+ $plugin load $format
+ set myplugin($format) $plugin
+ } else {
+ set plugin $myplugin($format)
+ }
+
+ return $plugin
+ }
+
+ method PluginSetup {mgr ip} {
+ # Inject a pseudo package into the plugin interpreter the
+ # formatters can use to check that they were loaded into a
+ # proper environment.
+ $ip eval {package provide pt::peg::import::plugin 1}
+ return
+ }
+
+ method PluginSetup {mgr ip} {
+ # Inject a pseudo package into the plugin interpreter the
+ # import plugins can use to check that they were loaded into a
+ # proper environment.
+ $ip eval {package provide pt::peg::import::plugin 1}
+
+ # The import plugins may use msgcat, which requires access to
+ # tcl_platform during its initialization, and won't have it by
+ # default. We trust them enough to hand out the information.
+ # TODO :: remove user/wordSize, etc. We need only 'os'.
+ $ip eval [list array set ::tcl_platform [array get ::tcl_platform]]
+
+ # Provide an alias-command a plugin can use to ask for any
+ # file, so that it can handle the processing of include files,
+ # should its format have that concept. The alias will be
+ # directed to a method of ours and use the configured include
+ # paths to find the file.
+
+ ::interp alias $ip include {} {*}[mymethod IncludeFile]
+ return
+ }
+
+ method IncludeFile {currentfile path} {
+ # result = ok text fullpath error-code error-message
+
+ # Find the file, or not.
+ set fullpath [$self Locate $path]
+ if {$fullpath eq {}} {
+ return [list 0 {} $path notfound {}]
+ }
+
+ # Read contents, or not.
+ if {[catch {
+ set data [fileutil::cat $fullpath]
+ } msg]} {
+ set error notread
+ set emessage $msg
+ return [list 0 {} $fullpath notread $msg]
+ }
+
+ return [list 1 $data $fullpath {} {}]
+ }
+
+ method Locate {path} {
+ upvar 1 currentfile currentfile
+
+ if {$currentfile ne {}} {
+ set pathstosearch \
+ [linsert [$myinclude paths] 0 \
+ [file dirname [file normalize $currentfile]]]
+ } else {
+ set pathstosearch [$myinclude paths]
+ }
+
+ foreach base $pathstosearch {
+ set try [file join $base $path]
+ if {![file exists $try]} continue
+ return $try
+ }
+ # Nothing found
+ return {}
+ }
+
+ # ### ### ### ######### ######### #########
+ ## State
+
+ # Array serving as a cache for the various plugin managers holding
+ # a specific import plugin.
+
+ variable myplugin -array {}
+
+ # A component managing the configuration given to the import
+ # plugins when they are invoked.
+
+ component myinclude -public include
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pt::peg::import 1
+return
diff --git a/tcllib/modules/pt/pt_peg_import.test b/tcllib/modules/pt/pt_peg_import.test
new file mode 100644
index 0000000..872bc54
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_import.test
@@ -0,0 +1,43 @@
+# -*- tcl -*-
+# peg_import.test: tests for the pt::peg::import package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_import.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use snit/snit.tcl snit
+ use pluginmgr/pluginmgr.tcl pluginmgr
+
+ useLocal paths.tcl paths
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pegrammar.tcl pt::peg
+
+ source [localPath tests/common]
+}
+testing {
+ useLocalKeep pt_peg_import.tcl pt::peg::import
+}
+
+# -------------------------------------------------------------------------
+
+setup_plugins
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/pt_peg_import.tests]
+
+#----------------------------------------------------------------------
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_import_container.man b/tcllib/modules/pt/pt_peg_import_container.man
new file mode 100644
index 0000000..9ec9e13
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_import_container.man
@@ -0,0 +1,21 @@
+[comment {-*- tcl -*- --- doctools ---}]
+[manpage_begin pt::peg::import::container n 0]
+[include include/module.inc]
+[include include/keywords.inc]
+[titledesc "PEG Import Plugin. From CONTAINER format"]
+[description]
+[include include/ref_intro.inc]
+
+This package does not exist.
+
+There is no need for it.
+
+The CONTAINER format for parsing expression grammars is a piece of Tcl
+code which, then sourced, provides a class whose instances have the
+grammar we wish to import loaded.
+
+Another way of looking at this is, the CONTAINER output is its own
+import package.
+
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_peg_import_json.man b/tcllib/modules/pt/pt_peg_import_json.man
new file mode 100644
index 0000000..49b5ad1
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_import_json.man
@@ -0,0 +1,6 @@
+[comment {--- doctools ---}]
+[vset PACKAGE json]
+[vset NAME JSON]
+[vset CONFIG json]
+[vset VERSION 1]
+[include include/import/plugin.inc]
diff --git a/tcllib/modules/pt/pt_peg_import_json.tcl b/tcllib/modules/pt/pt_peg_import_json.tcl
new file mode 100644
index 0000000..085f784
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_import_json.tcl
@@ -0,0 +1,40 @@
+# pt_peg_import_json.tcl --
+#
+# The PEG from JSON import plugin.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pt_peg_import_json.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# This package is a plugin for the pt::peg import manager. It takes
+# text in JSON format for a parsing expression grammar and produces
+# the canonical serialization of that grammar.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: pt::peg::import::plugin
+
+package require Tcl 8.5
+package require pt::peg::import::plugin ; # The presence of this
+ # pseudo package indicates
+ # execution inside of a
+ # properly initialized
+ # plugin interpreter.
+package require pt::peg::from::json
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc import {text} {
+ return [pt::peg::from::json convert $text]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pt::peg::import::json 1
+return
diff --git a/tcllib/modules/pt/pt_peg_import_json.test b/tcllib/modules/pt/pt_peg_import_json.test
new file mode 100644
index 0000000..ae96e97
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_import_json.test
@@ -0,0 +1,45 @@
+# -*- tcl -*-
+# toc_import_json.test: tests for the doctools::toc::import::json package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_import_json.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use json/json.tcl json
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal pt_peg_from_json.tcl pt::peg::from::json
+
+ source [localPath tests/common]
+}
+testing {
+ package provide pt::peg::import::plugin 1
+ # The above fakes plugin environment. Well, not completely. We are
+ # leaving out a definition for the 'include' alias
+
+ useLocal pt_peg_import_json.tcl pt::peg::import::json
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/pt_peg_import_json.tests]
+
+# -------------------------------------------------------------------------
+
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_import_peg.man b/tcllib/modules/pt/pt_peg_import_peg.man
new file mode 100644
index 0000000..9ec94b7
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_import_peg.man
@@ -0,0 +1,6 @@
+[comment {--- doctools ---}]
+[vset PACKAGE peg]
+[vset NAME PEG]
+[vset CONFIG peg]
+[vset VERSION 1]
+[include include/import/plugin.inc]
diff --git a/tcllib/modules/pt/pt_peg_import_peg.tcl b/tcllib/modules/pt/pt_peg_import_peg.tcl
new file mode 100644
index 0000000..e7ce2ab
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_import_peg.tcl
@@ -0,0 +1,41 @@
+# pt_peg_import_peg.tcl --
+#
+# The PEG to PEG (text representation) import plugin. Generation
+# of plain text.
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pt_peg_import_peg.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# This package is a plugin for the pt::peg import manager. It takes
+# the human readable text representation of a parsing expression
+# grammar and produces the corresponding canonical serialization.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+# @mdgen NODEP: pt::peg::import::plugin
+
+package require Tcl 8.5
+package require pt::peg::import::plugin ; # The presence of this
+ # pseudo package indicates
+ # execution inside of a
+ # properly initialized
+ # plugin interpreter.
+package require pt::peg::from::peg
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc import {text} {
+ return [pt::peg::from::peg convert $text]
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pt::peg::import::peg 1
+return
diff --git a/tcllib/modules/pt/pt_peg_import_peg.test b/tcllib/modules/pt/pt_peg_import_peg.test
new file mode 100644
index 0000000..bdfdafe
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_import_peg.test
@@ -0,0 +1,91 @@
+# -*- tcl -*-
+# peg_import_peg.test: tests for the pt::peg::import::peg package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_import_peg.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/stack.tcl struct::stack ; # User: pt::rde
+ TestAccelInit struct::stack ; #
+
+ use snit/snit.tcl snit
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_astree.tcl pt::ast
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pexpr_op.tcl pt::pe::op
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal pt_peg_container.tcl pt::peg::container
+
+ useAccel [useTcllibC] pt/pt_rdengine.tcl pt::rde ; # User: pt::parse::peg
+ TestAccelInit pt::rde ; # or: pt:peg::interp
+
+ # Get the parser used by the converter, either the grammar
+ # interpreter, or snit-based and spcialized to PEG.
+ #useLocal pt_peg_container_peg.tcl pt::peg::container::peg
+ #useLocal pt_peg_interp.tcl pt::peg::interp
+
+ useAccel [useTcllibC] pt/pt_parse_peg.tcl pt::parse::peg ; # User: pt::peg::from::peg
+ TestAccelInit pt::parse::peg
+
+ useLocal pt_peg_from_peg.tcl pt::peg::from::peg
+
+ source [localPath tests/common]
+}
+testing {
+ package provide pt::peg::import::plugin 1
+ # The above fakes the import plugin environment.
+
+ useLocal pt_peg_import_peg.tcl pt::peg::import::peg
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+# Note: When using pt::rde's C implementation struct::stack is not
+# used, and its implementation of no relevance.
+#
+# Similarly, when pt::parse::peg's C implementation is used
+# neither pt::rde's, nor struct::stack's implementations are of
+# relevance.
+
+TestAccelDo pt::parse::peg parseimpl {
+ if {$parseimpl eq "critcl"} {
+ set rdeimpl n/a
+ set stackimpl n/a
+ pt::rde::SwitchTo {}
+ struct::stack::SwitchTo {}
+ source [localPath tests/pt_peg_import_peg.tests]
+ } else {
+ TestAccelDo pt::rde rdeimpl {
+ if {$rdeimpl eq "critcl"} {
+ set stackimpl n/a
+ struct::stack::SwitchTo {}
+ source [localPath tests/pt_peg_import_peg.tests]
+ } else {
+ TestAccelDo struct::stack stackimpl {
+ source [localPath tests/pt_peg_import_peg.tests]
+ }
+ }
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+TestAccelExit pt::parse::peg
+TestAccelExit pt::rde
+TestAccelExit struct::stack
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_interp.man b/tcllib/modules/pt/pt_peg_interp.man
new file mode 100644
index 0000000..99d0f00
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_interp.man
@@ -0,0 +1,80 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset PACKAGE_VERSION 1.0.1]
+[manpage_begin pt::peg::interp n [vset PACKAGE_VERSION]]
+[include include/module.inc]
+[titledesc {Interpreter for parsing expression grammars}]
+[require pt::peg::interp [opt [vset PACKAGE_VERSION]]]
+[require pt::rde [opt 1]]
+[require snit]
+[description]
+[include include/ref_intro.inc]
+
+This package provides a class whose instances are Packrat parsers
+configurable with a parsing expression grammar. The grammar is
+executed directly, i.e. interpreted, with the underlying runtime
+provided by the package [package pt::rde], basing everything on the
+PARAM.
+
+[para]
+
+Like the supporting runtime this package resides in the Execution
+section of the Core Layer of Parser Tools.
+[para][image arch_core_transform][para]
+
+[para]
+
+The interpreted grammar is copied from an instance of [package \
+pt::peg::container], or anything providing the same API, like the
+container classes created by [package pt::peg::to::container] or the
+associated export plugin [package pt::peg::export::container].
+
+[subsection {Class API}]
+
+The package exports the API described here.
+
+[list_begin definitions]
+
+[call [cmd ::pt::peg::interp] [arg objectName] [arg grammar]]
+
+The command creates a new parser object and returns the fully
+qualified name of the object command as its result. The API of this
+object command is described in the section [sectref {Object API}]. It
+may be used to invoke various operations on the object.
+
+[para]
+
+This new parser is configured for the execution of an empty PEG. To
+configure the object for any other PEG use the method [method use] of
+the [sectref {Object API}].
+
+[list_end]
+
+[subsection {Object API}]
+
+All objects created by this package provide the following methods.
+
+[list_begin definitions]
+
+[call [arg objectName] [method use] [arg grammar]]
+
+This method configures the grammar interpreter / parser for the
+execution of the PEG stored in [arg grammar], an object which is
+API-compatible to instances of [package pt::peg::container]. The
+parser copies the relevant information of the grammar, and does
+[emph not] take ownership of the object.
+
+[para]
+
+The information of any previously used grammar is overwritten.
+
+[para]
+
+The result of the method the empty string.
+
+[include include/std_parser_object_api.inc]
+[list_end]
+
+[include include/serial/ast.inc]
+[include include/serial/pexpression.inc]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_peg_interp.tcl b/tcllib/modules/pt/pt_peg_interp.tcl
new file mode 100644
index 0000000..a6f576e
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_interp.tcl
@@ -0,0 +1,385 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2009-2014 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# Interpreter for parsing expression grammars. In essence a recursive
+# descent parser configurable with a parsing expression grammar.
+
+# ### ### ### ######### ######### #########
+## Package description
+
+## The instances of this class parse a text provided through a channel
+## based on a parsing expression grammar provided by a peg container
+## object. The parsing process is interpretative, i.e. the parsing
+## expressions are decoded and checked on the fly and possibly
+## multiple times, as they are encountered.
+
+## The interpreter operates in pull-push mode, i.e. the interpreter
+## object is in charge and reads the characters from the channel as
+## needed, and returns with the result of the parse, either when
+## encountering an error, or when the parse was successful.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require pt::rde ; # Virtual machine geared to the parsing of PEGs.
+package require snit
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+snit::type ::pt::peg::interp {
+
+ # ### ### ### ######### ######### #########
+ ## Instance API
+
+ constructor {} {}
+
+ method use {grammar} {}
+
+ method parse {channel} {} ; # Parse the contents of the channel
+ # against the configured grammar.
+
+ method parset {text} {} ; # Parse the text against the
+ # configured grammar.
+
+ # ### ### ### ######### ######### #########
+ ## Options
+
+ ## None
+
+ # ### ### ### ######### ######### #########
+ ## Instance API Implementation.
+
+ constructor {} {
+ # Create the runtime supporting the parsing process.
+ set myparser [pt::rde ${selfns}::ENGINE]
+ return
+ }
+
+ method use {grammar} {
+ # Release the information of any previously used grammar.
+
+ array unset myrhs *
+ array unset mymode *
+ set mystart epsilon
+
+ # Copy the grammar into internal tables.
+
+ # Note how the grammar is not used in any way, shape, or form
+ # afterward.
+
+ # Note also that it is not required to verify the
+ # grammar. This was done while it was loaded into the grammar
+ # object, be it incrementally or at once.
+
+ array set myrhs [$grammar rules]
+ array set mymode [$grammar modes]
+ set mystart [$grammar start]
+ return
+ }
+
+ method parse {channel} {
+ $myparser reset $channel
+ $self {*}$mystart
+ return [$myparser complete]
+ }
+
+ method parset {text} {
+ $myparser reset
+ $myparser data $text
+ $self {*}$mystart
+ return [$myparser complete]
+ }
+
+ # ### ### ### ######### ######### #########
+ ## Parse operator implementation
+
+ # No input to parse, nor consume. Ok, always.
+
+ method epsilon {} {
+ $myparser i_status_ok
+ return
+ }
+
+ # Parse and consume one character. No matter which character. This
+ # fails only when reaching EOF. Does not consume input on failure.
+
+ method dot {} {
+ $self Next
+ return
+ }
+
+ # Parse and consume one specific character. This fails if the
+ # character at the location is not in the specified character
+ # class. Does not consume input on failure.
+
+ foreach operator {
+ alnum alpha ascii control ddigit digit graph
+ lower print punct space upper wordchar xdigit
+ } {
+ method $operator {} [string map [list @ $operator] {
+ $self Next
+ $myparser i:fail_return
+ $myparser i_test_@
+ return
+ }]
+ }
+
+ # Parse and consume one specific character. This fails if the
+ # character at the location is not the expected character. Does
+ # not consume input on failure.
+
+ method t {char} {
+ $self Next
+ $myparser i:fail_return
+ $myparser i_test_char $char
+ return
+ }
+
+ # Parse and consume one character, if in the specified range. This
+ # fails if the read character is outside of the range. Does not
+ # consume input on failure.
+
+ method .. {chstart chend} {
+ $self Next
+ $myparser i:fail_return
+ $myparser i_test_range $chstart $chend
+ return
+ }
+
+ # To parse a nonterminal symbol in the input we execute its
+ # parsing expression, i.e its right-hand side. This can be cut
+ # short if the necessary information can be obtained from the
+ # nonterminal cache. Does not consume input on failure.
+
+ method n {symbol} {
+ set savemode $mycurrentmode
+ set mycurrentmode $mymode($symbol)
+
+ # Query NC, and shortcut
+ if {[$myparser i_symbol_restore $symbol]} {
+ $self ASTFinalize
+ return
+ }
+
+ # Save location and AST construction state
+ $myparser i_loc_push ; # (i)
+ $myparser i_ast_push ; # (1)
+
+ # Run the right hand side.
+ $self {*}$myrhs($symbol)
+
+ # Generate a semantic value, based on the currently active
+ # semantic mode.
+ switch -exact -- $mycurrentmode {
+ value { $myparser i_value_clear/reduce $symbol }
+ leaf { $myparser i_value_clear/leaf $symbol }
+ void { $myparser i_value_clear }
+ }
+
+ $myparser i_symbol_save $symbol
+
+ # Drop ARS. Unconditional as any necessary reduction was done
+ # already (See (a)), and left the result in SV
+ $myparser i_ast_pop_rewind ; # (Ad 1)
+ $self ASTFinalize
+
+ # Even if parse is ok.
+ $myparser i_error_nonterminal $symbol
+ $myparser i_loc_pop_discard ; # (Ad i)
+ return
+ }
+
+ # And lookahead predicate. We parse the expression against the
+ # input and return the parse result. No input is consumed.
+
+ method & {expression} {
+ $myparser i_loc_push
+
+ $self {*}$expression
+
+ $myparser i_loc_pop_rewind
+ return
+ }
+
+ # Negated lookahead predicate. We parse the expression against the
+ # input and returns the negated parse result. No input is
+ # consumed.
+
+ method ! {expression} {
+ $myparser i_loc_push
+ $myparser i_ast_push
+
+ $self {*}$expression
+
+ $myparser i_ast_pop_discard/rewind ;# -- fail/ok
+ $myparser i_loc_pop_rewind
+ $myparser i_status_negate
+ return
+ }
+
+ # Parsing an optional expression. This tries to parse the sub
+ # expression. It will never fail, even if the sub expression
+ # itself is not succesful. Consumes only input if it could parse
+ # the sub expression. Like *, but without the repetition.
+
+ method ? {expression} {
+ $myparser i_loc_push
+ $myparser i_error_push
+
+ $self {*}$expression
+
+ $myparser i_error_pop_merge
+ $myparser i_loc_pop_rewind/discard ;# -- fail/ok
+ $myparser i_status_ok
+ return
+ }
+
+ # Parse zero or more repetitions of an expression (Kleene
+ # closure). This consumes as much input as we were able to parse
+ # the sub expression. The expresion as a whole is always
+ # succesful, even if the sub expression fails (zero repetitions).
+
+ method * {expression} {
+ # do { ... } while ok.
+ while {1} {
+ $myparser i_loc_push
+ $myparser i_error_push
+
+ $self {*}$expression
+
+ $myparser i_error_pop_merge
+ $myparser i_loc_pop_rewind/discard ;# -- fail/ok
+ $myparser i:ok_continue
+ break
+ }
+ $myparser i_status_ok
+ return
+ }
+
+ # Parse one or more repetitions of an expression (Positive kleene
+ # closure). This is similar to *, except for one round at the
+ # front which has to parse for success of the whole. This
+ # expression can fail. It will consume only as much input as it
+ # was able to parse.
+
+ method + {expression} {
+ $myparser i_loc_push
+
+ $self {*}$expression
+
+ $myparser i_loc_pop_rewind/discard ;# -- fail/ok
+ $myparser i:fail_return
+
+ $self * $expression
+ return
+ }
+
+ # Parsing a sequence of expressions. This parses each sub
+ # expression in turn, each consuming input. In the case of failure
+ # by one of the sequence's elements nothing is consumed at all.
+
+ method x {args} {
+ $myparser i_loc_push
+ $myparser i_ast_push
+ $myparser i_error_clear
+
+ foreach expression $args {
+ $myparser i_error_push
+
+ $self {*}$expression
+
+ $myparser i_error_pop_merge
+ # Branch failed, track back and report to caller.
+ $myparser i:fail_ast_pop_rewind
+ $myparser i:fail_loc_pop_rewind
+ $myparser i:fail_return ; # Stop trying on element failure
+ }
+
+ # All elements OK, squash backtracking state
+ $myparser i_loc_pop_discard
+ $myparser i_ast_pop_discard
+ return
+ }
+
+ # Parsing a series of alternatives (Choice). This parses each
+ # alternative in turn, always starting from the current
+ # location. Nothing is consumed if all alternatives fail. Consumes
+ # as much as was consumed by the succesful branch.
+
+ method / {args} {
+ $myparser i_error_clear
+
+ foreach expression $args {
+ $myparser i_loc_push
+ $myparser i_ast_push
+ $myparser i_error_push
+
+ $self {*}$expression
+
+ $myparser i_error_pop_merge
+ $myparser i_ast_pop_rewind/discard
+ $myparser i_loc_pop_rewind/discard
+ $myparser i:fail_continue
+ return ; # Stop trying on finding a successful branch.
+ }
+
+ # All branches FAIL
+ $myparser i_status_fail
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+
+ method Next {} {
+ # We are processing the outer method call into an atomic
+ # parsing expression for error messaging.
+ $myparser i_input_next [regsub {^.*Snit_method} [lreplace [info level -1] 1 4] {}]
+ return
+ }
+
+ method ASTFinalize {} {
+ if {$mycurrentmode ne "void"} {
+ $myparser i:ok_ast_value_push
+ }
+ upvar 1 savemode savemode
+ set mycurrentmode $savemode
+ return
+ }
+
+ # ### ### ### ######### ######### #########
+ ## State Interpreter data structures.
+
+ variable myparser {} ; # Our PARAM instantiation.
+ variable myrhs -array {} ; # Dictionary mapping nonterminal
+ # symbols to parsing expressions
+ # describing their sentence
+ # structure.
+ variable mymode -array {} ; # Dictionary mapping nonterminal
+ # symbols to semantic modes
+ # (controlling AST generation).
+ variable mystart epsilon ; # The parsing expression to start
+ # the parse process with.
+ variable mycurrentmode value ; # The currently active semantic mode.
+
+ # ### ### ### ######### ######### #########
+ ## Debugging helper. To activate
+ ## string map {{self {*}} {self TRACE {*}}}
+
+ method TRACE {args} {
+ puts |$args|enter
+ set res [$self {*}$args]
+ puts |$args|return
+ return $res
+ }
+
+ ##
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Package Management
+
+package provide pt::peg::interp 1.0.1
diff --git a/tcllib/modules/pt/pt_peg_interp.test b/tcllib/modules/pt/pt_peg_interp.test
new file mode 100644
index 0000000..9ea6621
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_interp.test
@@ -0,0 +1,66 @@
+# -*- tcl -*-
+# pt_peg_interp.test: tests for the pt::peg::interp peg interpreter package.
+#
+# Copyright (c) 2010 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_interp.test,v 1.1 2010/07/27 22:53:53 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/stack.tcl struct::stack ; # User: pt::rde
+ TestAccelInit struct::stack ; # (tcl)
+
+ use snit/snit.tcl snit
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_astree.tcl pt::ast
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal pt_peg_container.tcl pt::peg::container
+
+ useAccel [useTcllibC] pt/pt_rdengine.tcl pt::rde ; # User: pt::parse::peg
+ TestAccelInit pt::rde ; # or: pt:peg::interp
+
+ # Here we are testing the PEG interpreter, so we need the grammar
+ # as a container.
+ useLocal pt_peg_container_peg.tcl pt::peg::container::peg
+
+ source [localPath tests/common]
+}
+testing {
+ use pt/pt_peg_interp.tcl pt::peg::interp
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+# Note: When using pt::rde's C implementation struct::stack is not
+# used, and its implementation of no relevance.
+
+TestAccelDo pt::rde rdeimpl {
+ if {$rdeimpl eq "critcl"} {
+ set stackimpl n/a
+ struct::stack::SwitchTo {}
+ source [localPath tests/pt_peg_interp.tests]
+ } else {
+ TestAccelDo struct::stack stackimpl {
+ source [localPath tests/pt_peg_interp.tests]
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+TestAccelExit pt::rde
+TestAccelExit struct::stack
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_introduction.man b/tcllib/modules/pt/pt_peg_introduction.man
new file mode 100644
index 0000000..c800901
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_introduction.man
@@ -0,0 +1,208 @@
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt::pegrammar n 1]
+[include include/module.inc]
+[titledesc {Introduction to Parsing Expression Grammars}]
+[description]
+[include include/ref_intro.inc]
+
+Welcome to the introduction to [term {Parsing Expression Grammar}]s
+(short: [term PEG]), the formalism used by the Parser Tools.
+
+It is assumed that the reader has a basic knowledge of parsing theory,
+i.e. [term {Context-Free Grammars}] (short: [term CFG]),
+[term languages], and associated terms like [term LL(k)],
+[term LR(k)], [term terminal] and [term nonterminal] [term symbols],
+etc.
+
+We do not intend to recapitulate such basic definitions or terms like
+[term useful], [term reachable], (left/right) [term recursive],
+[term nullable], first/last/follow sets, etc.
+
+[comment {-- doctools extension -- 2nd argument for term to distinguish printed text and actual term, for the indexing ---}]
+
+Please see the [sectref References] at the end instead if you are in
+need of places and books which provide such background information.
+
+[para]
+
+PEGs are formally very similar to CFGs, with terminal and nonterminal
+symbols, start symbol, and rules defining the structure of each
+nonterminal symbol.
+
+The main difference lies in the choice(sic!) of [term choice]
+operators. Where CFGs use an [term {unordered choice}] to represent
+alternatives PEGs use [term {prioritized choice}]. Which is fancy way
+of saying that a parser has to try the first alternative first and can
+try the other alternatives if only if it fails for the first, and so
+on.
+
+[para]
+
+On the CFG side this gives rise to LL(k) and LR(k) for making the
+choice [term deterministic] with a bounded [term lookahead] of k
+terminal symbols, where LL is in essence [term topdown] aka
+[term {recursive descent}] parsing, and LR [term bottomup] aka
+[term {shift reduce}] parsing.
+
+[para]
+
+On the PEG side we can parse input with recursive descent and
+[term backtracking] of failed choices, the latter of which amounts to
+unlimited lookahead.
+
+By additionally recording the success or failure of nonterminals at
+the specific locations they were tried at and reusing this information
+after backtracking we can avoid the exponential blowup of running time
+usually associated with backtracking and keep the parsing linear. The
+memory requirements are of course higher due to this cache, as we are
+trading space for time.
+
+[para]
+
+This is the basic concept behind [term {packrat parsers}].
+
+[para]
+
+A limitation pure PEGs share with LL(k) CFGs is that
+[term left-recursive] grammars cannot be parsed, with the associated
+recursive descent parser entering an infinite recursion.
+
+This limitation is usually overcome by extending pure PEGs with
+explicit operators to specify repetition, zero or more, and one or
+more, or, formally spoken, for the [term {kleene closure}] and
+[term {positive kleene closure}].
+
+This is what the Parser Tools are doing.
+
+[para]
+
+Another extension, specific to Parser Tools, is a set of operators
+which map more or less directly to various character classes built
+into Tcl, i.e. the classes reachable via [cmd {string is}].
+
+[para]
+
+The remainder of this document consists of the formal definition of
+PEGs for the mathematically inclined, and an appendix listing
+references to places with more information on PEGs specifically, and
+parsing in general.
+
+[section {Formal definition}]
+[para]
+
+For the mathematically inclined, a Parsing Expression Grammar is a
+4-tuple (VN,VT,R,eS) where
+
+[list_begin itemized]
+[item]
+VN is a set of [term {nonterminal symbols}],
+
+[item]
+VT is a set of [term {terminal symbols}],
+
+[item]
+R is a finite set of rules, where each rule is a pair (A,e), A in VN,
+and [term e] a [term {parsing expression}].
+
+[item]
+eS is a parsing expression, the [term {start expression}].
+
+[list_end]
+[para]
+
+Further constraints are
+
+[list_begin itemized]
+[item]
+The intersection of VN and VT is empty.
+
+[item]
+For all A in VT exists exactly one pair (A,e) in R. In other words, R
+is a function from nonterminal symbols to parsing expressions.
+
+[list_end]
+[para]
+
+Parsing expressions are inductively defined via
+
+[list_begin itemized]
+[item]
+The empty string (epsilon) is a parsing expression.
+
+[item]
+A terminal symbol [term a] is a parsing expression.
+
+[item]
+A nonterminal symbol [term A] is a parsing expression.
+
+[item]
+[term e1][term e2] is a parsing expression for parsing expressions
+[term e1] and [term 2]. This is called [term sequence].
+
+[item]
+[term e1]/[term e2] is a parsing expression for parsing expressions
+[term e1] and [term 2]. This is called [term {ordered choice}].
+
+[item]
+[term e]* is a parsing expression for parsing expression
+[term e]. This is called [term {zero-or-more repetitions}], also known
+as [term {kleene closure}].
+
+[item]
+[term e]+ is a parsing expression for parsing expression
+[term e]. This is called [term {one-or-more repetitions}], also known
+as [term {positive kleene closure}].
+
+[item]
+![term e] is a parsing expression for parsing expression
+[term e1]. This is called a [term {not lookahead predicate}].
+
+[item]
+&[term e] is a parsing expression for parsing expression
+[term e1]. This is called an [term {and lookahead predicate}].
+
+[list_end]
+[para]
+
+[para]
+
+PEGs are used to define a grammatical structure for streams of symbols
+over VT. They are a modern phrasing of older formalisms invented by
+Alexander Birham. These formalisms were called TS (TMG recognition
+scheme), and gTS (generalized TS). Later they were renamed to TPDL
+(Top-Down Parsing Languages) and gTPDL (generalized TPDL).
+
+[para]
+
+They can be easily implemented by recursive descent parsers with
+backtracking. This makes them relatives of LL(k) Context-Free
+Grammars.
+
+[section References]
+
+[list_begin enumerated]
+[enum]
+[uri {http://www.pdos.lcs.mit.edu/~baford/packrat/} \
+ {The Packrat Parsing and Parsing Expression Grammars Page}],
+by Bryan Ford, Massachusetts Institute of Technology. This is the main
+entry page to PEGs, and their realization through Packrat Parsers.
+
+[enum]
+[uri {http://en.wikipedia.org/wiki/Parsing_expression_grammar}]
+Wikipedia's entry about Parsing Expression Grammars.
+
+[enum]
+[uri {http://www.cs.vu.nl/~dick/PTAPG.html} \
+ {Parsing Techniques - A Practical Guide }], an online book
+offering a clear, accessible, and thorough discussion of many
+different parsing techniques with their interrelations and
+applicabilities, including error recovery techniques.
+
+[enum]
+[uri {http://scifac.ru.ac.za/compilers/} \
+ {Compilers and Compiler Generators}], an online book using
+CoCo/R, a generator for recursive descent parsers.
+[list_end]
+
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_peg_language.man b/tcllib/modules/pt/pt_peg_language.man
new file mode 100644
index 0000000..7fd1523
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_language.man
@@ -0,0 +1,316 @@
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin pt::peg_language n 1]
+[include include/module.inc]
+[titledesc {PEG Language Tutorial}]
+[description]
+[include include/ref_intro.inc]
+
+Welcome to the tutorial / introduction for the
+[sectref {PEG Specification Language}].
+
+If you are already familiar with the language we are about to discuss,
+and only wish to refresh your memory you can, of course, skip ahead to
+the aforementioned section and just read the full formal specification.
+
+[section {What is it?}]
+
+[include include/format/whatis_peg.inc]
+
+[section {The elements of the language}]
+[subsection {Basic structure}]
+
+The general outline of a textual PEG is
+
+[example {
+PEG <<name>> (<<start-expression>>)
+ <<rules>>
+END;
+}]
+
+[emph Note]: We are using text in double angle-brackets as
+place-holders for things not yet explained.
+
+[subsection Names]
+
+Names are mostly used to identify the nonterminal symbols of the
+grammar, i.e. that which occurs on the left-hand side of a <rule>.
+The exception to that is the name given after the keyword [const PEG]
+(see previous section), which is the name of the whole grammar itself.
+
+[para]
+
+The structure of a name is simple:
+
+[list_begin enumerated]
+[enum] It begins with a letter, underscore, or colon, followed by
+[enum] zero or more letters, digits, underscores, or colons.
+[list_end]
+
+Or, in formal textual notation:
+
+[example {
+ ([_:] / <alpha>) ([_:] / <alnum>)*
+}]
+
+Examples of names:
+
+[example {
+ Hello
+ ::world
+ _:submarine55_
+}]
+
+Examples of text which are [emph not] names:
+
+[example {
+ 12
+ .bogus
+ 0wrong
+ @location
+}]
+
+[subsection Rules]
+
+The main body of the text of a grammar specification is taken up by
+the rules. Each rule defines the sentence structure of one nonterminal
+symbol. Their basic structure is
+
+[example {
+ <<name>> <- <<expression>> ;
+}]
+
+The <name> specifies the nonterminal symbol to be defined, the
+<expression> after the arrow (<-) then declares its structure.
+
+[para]
+
+Note that each rule ends in a single semicolon, even the last.
+I.e. the semicolon is a rule [emph terminator], not a separator.
+
+[para]
+
+We can have as many rules as we like, as long as we define each
+nonterminal symbol at most once, and have at least one rule for each
+nonterminal symbol which occured in an expression, i.e. in either the
+start expression of the grammar, or the right-hande side of a rule.
+
+[subsection Expressions]
+
+The [emph parsing] expressions are the meat of any specification. They
+declare the structure of the whole document (<<start-expression>>),
+and of all nonterminal symbols.
+
+[para]
+
+All expressions are made up out of [term {atomic expressions}] and
+[term operators] combining them. We have operators for choosing
+between alternatives, repetition of parts, and for look-ahead
+constraints. There is no explicit operator for the sequencing (also
+known as [term concatenation]) of parts however. This is specified by
+simply placing the parts adjacent to each other.
+
+[para]
+
+Here are the operators, from highest to lowest priority (i.e. strength
+of binding):
+
+[example {
+ # Binary operators.
+
+ <<expression-1>> <<expression-2>> # sequence. parse 1, then 2.
+ <<expression-1>> / <<expression-2>> # alternative. try to parse 1, and parse 2 if 1 failed to parse.
+
+ # Prefix operators. Lookahead constraints. Same priority.
+
+ & <<expression>> # Parse expression, ok on successful parse.
+ ! <<expression>> # Ditto, except ok on failure to parse.
+
+ # Suffix operators. Repetition. Same priority.
+
+ <<expression>> ? # Parse expression none, or once (repeat 0 or 1).
+ <<expression>> * # Parse expression zero or more times.
+ <<expression>> + # Parse expression one or more times.
+
+ # Expression nesting
+
+ ( <<expression>> ) # Put an expression in parens to change its priority.
+}]
+
+With this we can now deconstruct the formal expression for names given
+in section [sectref Names]:
+
+[example {
+ ([_:] / <alpha>) ([_:] / <alnum>)*
+}]
+
+It is a sequence of two parts,
+[example { [_:] / <alpha> }]
+and
+[example { ([_:] / <alnum>)* }]
+
+The parentheses around the parts kept their inner alternatives bound
+together against the normally higher priority of the sequence. Each of
+the two parts is an alternative, with the second part additionally
+repeated zero or more times, leaving us with the three atomic
+expressions
+
+[example {
+ [_:]
+ <alpha>
+ <alnum>
+}]
+
+And [term {atomic expressions}] are our next topic. They
+fall into three classes:
+
+[list_begin enumerated]
+[enum] names, i.e. nonterminal symbols,
+[enum] string literals, and
+[enum] character classes.
+[list_end]
+
+Names we know about already, or see section [sectref Names] for a
+refresher.
+
+[para]
+
+String literals are simple. They are delimited by (i.e. start and end
+with) either a single or double-apostroph, and in between the
+delimiters we can have any character but the delimiter itself. They
+can be empty as well. Examples of strings are
+
+[example {
+ ''
+ ""
+ 'hello'
+ "umbra"
+ "'"
+ '"'
+}]
+
+The last two examples show how to place any of the delimiters into a
+string.
+
+[para]
+
+For the last, but not least of our atomic expressions, character
+classes, we have a number of predefined classes, shown below, and the
+ability to construct or own. The predefined classes are:
+
+[example {
+ <alnum> # Any unicode alphabet or digit character (string is alnum).
+ <alpha> # Any unicode alphabet character (string is alpha).
+ <ascii> # Any unicode character below codepoint 0x80 (string is ascii).
+ <control> # Any unicode control character (string is control).
+ <ddigit> # The digit characters [0-9].
+ <digit> # Any unicode digit character (string is digit).
+ <graph> # Any unicode printing character, except space (string is graph).
+ <lower> # Any unicode lower-case alphabet character (string is lower).
+ <print> # Any unicode printing character, incl. space (string is print).
+ <punct> # Any unicode punctuation character (string is punct).
+ <space> # Any unicode space character (string is space).
+ <upper> # Any unicode upper-case alphabet character (string is upper).
+ <wordchar> # Any unicode word character (string is wordchar).
+ <xdigit> # The hexadecimal digit characters [0-9a-fA-F].
+ . # Any character, except end of input.
+}]
+
+And the syntax of custom-defined character classes is
+
+[example {
+ [ <<range>>* ]
+}]
+
+where each range is either a single character, or of the form
+
+[example {
+ <<character>> - <character>>
+}]
+
+Examples for character classes we have seen already in the course of
+this introduction are
+
+[example {
+ [_:]
+ [0-9]
+ [0-9a-fA-F]
+}]
+
+We are nearly done with expressions. The only piece left is to tell
+how the characters in character classes and string literals are
+specified.
+
+[para]
+
+Basically characters in the input stand for themselves, and in
+addition to that we several types of escape syntax to to repesent
+control characters, or characters outside of the encoding the text is
+in.
+
+[para]
+
+All the escaped forms are started with a backslash character ('\',
+unicode codepoint 0x5C). This is then followed by a series of octal
+digits, or 'u' and hexedecimal digits, or a regular character from a
+fixed set for various control characters. Some examples:
+
+[example {
+ \n \r \t \' \" \[ \] \\ #
+ \000 up to \277 # octal escape, all ascii character, leading 0's can be removed.
+ \u2CA7 # hexadecimal escape, all unicode characters.
+ # # Here 2ca7 <=> Koptic Small Letter Tau
+}]
+
+[subsection {Whitespace and comments}]
+
+One issue not touched upon so far is whitespace and comments.
+
+[para]
+
+Whitespace is any unicode space character, i.e. anything in the
+character class <space>, and comments. The latter are sequences of
+characters starting with a '#' (hash, unicode codepoint 0x23) and
+ending at the next end-of-line.
+
+[para]
+
+Whitespace can be freely used between all syntactical elements of a
+grammar specification. It cannot be used inside of syntactical
+elements, like names, string literals, predefined character classes,
+etc.
+
+[subsection {Nonterminal attributes}]
+
+Lastly, a more advanced topic. In the section [sectref Rules] we gave
+the structure of a rule as
+
+[example {
+ <<name>> <- <<expression>> ;
+}]
+
+This is not quite true. It is possible to associate a semantic mode
+with the nonterminal in the rule, by writing it before the name,
+separated from it by a colon, i.e. writing
+
+[example {
+ <<mode>> : <<name>> <- <<expression>> ;
+}]
+
+is also allowed. This mode is optional. The known modes and their
+meanings are:
+
+[include include/modes.inc]
+
+Of these three modes only [const leaf] and [const void] can be
+specified directly. [const value] is implicitly specified by the
+absence of a mode before the nonterminal.
+
+[para]
+
+Now, with all the above under our belt it should be possible to not
+only read, but understand the formal specification of the text
+representation shown in the next section, written in itself.
+
+[include include/format/peg.inc]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_peg_op.man b/tcllib/modules/pt/pt_peg_op.man
new file mode 100644
index 0000000..c160d23
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_op.man
@@ -0,0 +1,179 @@
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt_peg_op i 1.0.1]
+[include include/module.inc]
+[titledesc {Parser Tools PE Grammar Utility Operations}]
+[require pt::peg::op 1.0.1]
+[description]
+[include include/ref_intro.inc]
+
+This package provides a number of utility commands manipulating a PE
+grammar (container) in various ways.
+
+[section API]
+
+[list_begin definitions]
+[comment ---------------------------------------------------------------------]
+[call [cmd ::peg::peg::op] [method called] [arg container]]
+
+This command determines the static call structure for the nonterminal
+symbols of the grammar stored in the [arg container].
+
+[para] The result of the command is a dictionary mapping from each
+symbol to the symbols it calls. The empty string is the key used to
+represent the start expression of the grammar.
+
+[para] The grammar in the container is not modified.
+
+[para] The [arg container] instance has to expose a method API as is
+provided by the package [package pt::peg::container].
+
+[comment ---------------------------------------------------------------------]
+[call [cmd ::peg::peg::op] [method dechain] [arg container]]
+
+This command simplifies all symbols which just chain to a different
+symbol by inlining the right hand side of the called symbol in its
+callers. This works if and only the modes match properly, per the
+decision table below.
+
+[para][example {
+caller called | dechain | notes
+--------------+---------+-----------------------
+value value | yes | value is passed
+value leaf | yes | value is passed
+value void | yes | caller is implied void
+leaf value | no | generated value was discarded, inlined would not. called may be implied void.
+leaf leaf | no | s.a.
+leaf void | no | s.a.
+void value | no | caller drops value, inlined would not.
+void leaf | no | s.a.
+void void | yes |
+}]
+
+[para] The result of the command is the empty string.
+
+[para] The grammar in the container is directly modified. If that is
+not wanted, a copy of the original container has to be used.
+
+[para] The [arg container] instance has to expose a method API as is
+provided by the package [package pt::peg::container].
+
+[comment ---------------------------------------------------------------------]
+[call [cmd ::peg::peg::op] [method {drop unreachable}] [arg container]]
+
+This command removes all symbols from the grammar which are not
+[method reachable].
+
+[para] The result of the command is the empty string.
+
+[para] The grammar in the container is directly modified. If that is
+not wanted, a copy of the original container has to be used.
+
+[para] The [arg container] instance has to expose a method API as is
+provided by the package [package pt::peg::container].
+
+[comment ---------------------------------------------------------------------]
+[call [cmd ::peg::peg::op] [method {drop unrealizable}] [arg container]]
+
+This command removes all symbols from the grammar which are not
+[method realizable].
+
+[para] The result of the command is the empty string.
+
+[para] The grammar in the container is directly modified. If that is
+not wanted, a copy of the original container has to be used.
+
+[para] The [arg container] instance has to expose a method API as is
+provided by the package [package pt::peg::container].
+
+[comment ---------------------------------------------------------------------]
+[call [cmd ::peg::peg::op] [method flatten] [arg container]]
+
+This command flattens (see [package pt::pe::op]) all expressions in
+the grammar, i.e. the start expression and the right hand sides of all
+nonterminal symbols.
+
+[para] The result of the command is the empty string.
+
+[para] The grammar in the container is directly modified. If that is
+not wanted, a copy of the original container has to be used.
+
+[para] The [arg container] instance has to expose a method API as is
+provided by the package [package pt::peg::container].
+
+[comment ---------------------------------------------------------------------]
+[call [cmd ::peg::peg::op] [method minimize] [arg container]]
+
+This command reduces the provided grammar by applying most of the other methods of this package.
+
+[para] After flattening the expressions it removes unreachable and
+unrealizable symbols, flattens the expressions again, then optimizes
+the symbol modes before collapsing symbol chains as much as possible.
+
+[para] The result of the command is the empty string.
+
+[para] The grammar in the container is directly modified. If that is
+not wanted, a copy of the original container has to be used.
+
+[para] The [arg container] instance has to expose a method API as is
+provided by the package [package pt::peg::container].
+
+[comment ---------------------------------------------------------------------]
+[call [cmd ::peg::peg::op] [method modeopt] [arg container]]
+
+This command optimizes the semantic modes of non-terminal symbols
+according to the two rules below.
+
+[list_begin enumerated]
+[enum] If a symbol X with mode [const value] calls no other symbols,
+ i.e. uses only terminal symbols in whatever combination, then
+ this can be represented simpler by using mode [const leaf].
+
+[enum] If a symbol X is only called from symbols with modes
+ [const leaf] or [const void] then this symbol should have mode
+ [const void] also, as any AST it could generate will be
+ discarded anyway.
+[list_end]
+
+[para] The result of the command is the empty string.
+
+[para] The grammar in the container is directly modified. If that is
+not wanted, a copy of the original container has to be used.
+
+[para] The [arg container] instance has to expose a method API as is
+provided by the package [package pt::peg::container].
+
+[comment ---------------------------------------------------------------------]
+[call [cmd ::peg::peg::op] [method reachable] [arg container]]
+
+This command computes the set of all nonterminal symbols which are
+reachable from the start expression of the grammar. This is
+essentially the transitive closure over [method called] and the
+symbol's right hand sides, beginning with the start expression.
+
+[para] The result of the command is the list of reachable symbols.
+
+[para] The grammar in the container is not modified.
+
+[para] The [arg container] instance has to expose a method API as is
+provided by the package [package pt::peg::container].
+
+[comment ---------------------------------------------------------------------]
+[call [cmd ::peg::peg::op] [method realizable] [arg container]]
+
+This command computes the set of all nonterminal symbols which are
+realizable, i.e. can derive pure terminal phrases. This is done
+iteratively, starting with state unrealizable for all and any, and
+then updating all symbols which are realizable, propagating changes,
+until nothing changes any more.
+
+[para] The result of the command is the list of realizable symbols.
+
+[para] The grammar in the container is not modified.
+
+[para] The [arg container] instance has to expose a method API as is
+provided by the package [package pt::peg::container].
+
+[list_end]
+
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_peg_op.tcl b/tcllib/modules/pt/pt_peg_op.tcl
new file mode 100644
index 0000000..dfa676d
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_op.tcl
@@ -0,0 +1,377 @@
+# -*- tcl -*-
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Utility commands operating on parsing expressions.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.5 ; # Required runtime.
+package require pt::pe ; # PE basics
+package require pt::pe::op ; # PE transforms
+package require struct::set ; # Set operations (symbol sets)
+
+# # ## ### ##### ######## ############# #####################
+##
+
+namespace eval ::pt::peg::op {
+ namespace export \
+ flatten called reachable realizable \
+ dechain drop modeopt minimize
+
+ namespace ensemble create
+
+ namespace eval ::pt::peg::op::drop {
+ namespace export \
+ unreachable unrealizable
+
+ namespace ensemble create
+ }
+}
+
+# # ## ### ##### ######## #############
+## Public API
+
+proc ::pt::peg::op::flatten {container} {
+ # Flatten all expressions in the grammar, i.e. start expression
+ # and nonterminal symbol right hand sides.
+
+ $container start [pt::pe::op flatten [$container start]]
+
+ foreach {symbol rule} [$container rules] {
+ $container rule $symbol [pt::pe::op flatten $rule]
+ }
+
+ return
+}
+
+proc ::pt::peg::op::called {container} {
+ # Determine static call structure for the nonterminal symbols of
+ # the grammar. Result is dictionary mapping from each symbol to
+ # the symbols it calls. The empty string is used to represent the
+ # start expression (as key).
+
+ lappend dict {} [pt::pe::op called [$container start]]
+
+ foreach {symbol rule} [$container rules] {
+ lappend dict $symbol [pt::pe::op called $rule]
+ }
+
+ return $dict
+}
+
+proc ::pt::peg::op::dechain {container} {
+
+ # Simplify all symbols which just chain to a different symbol by
+ # inlining the called symbol in its callers. This works if and
+ # only the modes match properly.
+
+ # X Z dechain notes
+ # value value| yes | value is passed
+ # value leaf | yes | value is passed
+ # value void | yes | X is implied void
+ # leaf value| no | generated value was discarded, inlined doesn't. Z may be implied void
+ # leaf leaf | no | s.a.
+ # leaf void | no | s.a.
+ # void value| no | X drops value, inline doesn't
+ # void leaf | no | s.a.
+ # void void | yes |
+
+ array set caller [Invert [called $container]]
+ # caller = array (x -> list(caller-of-x))
+ array set mode [$container modes]
+ # mode = array (x -> mode-of-x)
+
+ set changed 1
+ while {$changed} {
+ set changed 0
+ foreach {symbol rule} [$container rules] {
+ # Ignore regular operators and terminals
+ if {[lindex $rule 0] ne "n"} continue
+ set called [lindex $rule 1]
+
+ # Ignore chains where mode changes form a barrier.
+ if {
+ ($mode($symbol) ne "value") &&
+ (($mode($symbol) ne "void") ||
+ ($mode($called) ne "void"))
+ } continue
+
+ # We have the chain symbol -> called.
+ # Replace all users of 'symbol' with 'called'
+
+ foreach user $caller($symbol) {
+ $container rule $user \
+ [pt::pe::op rename $symbol $called \
+ [$container rule $user]]
+ }
+
+ set changed 1
+ array set caller [Invert [called $container]]
+ }
+ }
+
+ return
+}
+
+# # ## ### ##### ######## #############
+
+proc ::pt::peg::op::modeopt {container} {
+
+ # Optimize the semantic modes of symbols.
+
+ # Rules.
+ # 1. If a symbol X with mode 'value' calls no other symbols,
+ # i.e. uses only terminal symbols in whatever combination, then
+ # this can be represented simpler by using mode leaf.
+ #
+ # 2. If a symbol X is only called from symbols with modes 'leaf'
+ # or 'void' then this symbol should have mode 'void' also, as
+ # any AST it could generate will be discarded anyway.
+
+ array set calls [called $container]
+ array set caller [Invert [array get calls]]
+ array set mode [$container modes]
+ set mode() value
+
+ # calls = array (x -> called-by-x)
+ # caller = array (x -> users-of-x)
+
+ set changed [$container nonterminals]
+ while {[llength $changed]} {
+puts <$changed>
+ set scan $changed
+ set changed {}
+
+ foreach sym $scan {
+ # Rule 1
+ if {![llength $calls($sym)] &&
+ ($mode($sym) eq "value")} {
+puts (1)$sym
+ set mode($sym) leaf
+ }
+
+ # Rule 2
+ set callmode [CallMode $caller($sym) mode]
+ if {($callmode eq "void") &&
+ ($mode($sym) ne "void")} {
+
+puts (2)$sym
+ set mode($sym) void
+
+ # This change may change calling context and this call
+ # mode of the symbols we call, so put them back up for
+ # consideration.
+ struct::set add changed $calls($sym)
+ }
+ }
+ }
+
+ # Save the optimized modes back to the grammar.
+ unset mode()
+ $container modes [array get mode]
+ return
+}
+
+proc ::pt::peg::op::CallMode {callers mv} {
+ upvar 1 $mv mode
+ set res {}
+ foreach sym $callers {
+ struct::set include res $mode($sym)
+ }
+ if {[struct::set contains $res value]} {
+ return value
+ } else {
+ return void
+ }
+}
+
+# # ## ### ##### ######## #############
+
+proc ::pt::peg::op::minimize {container} {
+ flatten $container
+ drop unreachable $container
+ drop unrealizable $container
+ flatten $container
+ optmodes $container
+ dechain $container
+ return
+}
+
+# # ## ### ##### ######## #############
+
+proc ::pt::peg::op::reachable {container} {
+
+ # We compute the set of all nonterminal symbols which are
+ # reachable from the start expression of the grammar. This is
+ # essentially the transitive closure over [called] and the symbol's
+ # right hand sides, beginning with the start expression.
+
+ set reachable {}
+ set pending [pt::pe::op called [$container start]]
+ set known [$container nonterminals]
+
+ while {[llength $pending]} {
+ set new $pending
+ set pending {}
+ foreach symbol $new {
+ if {
+ ![struct::set contains $known $symbol] ||
+ [struct::set contains $reachable $symbol]
+ } continue
+
+ struct::set add pending \
+ [pt::pe::op called [$container rule $symbol]]
+ }
+
+ # Everything from the previous round is reachable, now that we
+ # expanded it we can even add it to the result.
+ struct::set add reachable $new
+ }
+
+ return $reachable
+}
+
+proc ::pt::peg::op::drop::unreachable {container} {
+
+ set unreachable [struct::set difference \
+ [$container nonterminals] \
+ [pt::peg::op reachable $container]]
+
+ if {![llength $unreachable]} return
+
+ $container remove {*}$unreachable
+ return
+}
+
+# # ## ### ##### ######## #############
+
+proc ::pt::peg::op::realizable {container} {
+
+ # We compute the set of all nonterminal symbols which are
+ # realizable, i.e. can derive pure terminal phrases. This is done
+ # iteratively, starting with state unrealizable for all and any,
+ # and then updating all symbols which are realizable, propagating
+ # changes, until nothing changes any more.
+
+ set realizable {}
+ array set caller [Invert [called $container]]
+ # caller = array (x -> list(caller-of-x))
+
+ set maychange [$container nonterminals]
+ lappend maychange {} ;# special marker for the start expression.
+
+ while {[llength $maychange]} {
+ set scan $maychange
+ set maychange {}
+
+ foreach symbol $scan {
+ # Ignore symbols we have a settled result for.
+ if {[struct::set contains $realizable $symbol]} \
+ continue
+
+ set real [pt::pe bottomup pt::peg::op::Realizable \
+ [expr {
+ ($symbol eq {})
+ ? [$container start]
+ : [$container rule $symbol]
+ }]]
+ if {!$real} continue
+
+ struct::set include realizable $symbol
+
+ # Symbol may be unreachable, i.e. have no callers.
+ if {![info exists caller($symbol)]} continue
+ struct::set add maychange $caller($symbol)
+ }
+ }
+
+ return $realizable
+}
+
+proc ::pt::peg::op::Realizable {pe op arguments} {
+ switch -exact -- $op {
+ n {
+ upvar 1 realizable realizable
+ lassign $arguments symbol
+ return [struct::set contains $realizable $symbol]
+ }
+ / {
+ # Choice is realizable if we have at least one realizable
+ # branch. This is also the place where we have to remove
+ # unrealizable children when we drop unrealizable symbols
+ # from a grammar.
+
+ return [tcl::mathfunc::max {*}$arguments]
+ }
+ x - * - + - ? - & - ! {
+ # All other operators are realizable if and only if all
+ # its children are realizable.
+
+ return [tcl::mathfunc::min {*}$arguments]
+ }
+ default {
+ # The terminals and special forms are realizable by
+ # definition.
+ return 1
+ }
+ }
+}
+
+proc ::pt::peg::op::drop::unrealizable {container} {
+
+ set all [$container nonterminals]
+ lappend all {} ; # marker for start expression.
+
+ set unrealizable \
+ [struct::set difference \
+ $all [pt::peg::op realizable $container]]
+
+ if {![llength $unrealizable]} return
+
+ if {[struct::set contains $unrealizable {}]} {
+ struct::set exclude unrealizable {}
+ $container start epsilon
+ }
+
+ # Drop the unrealizable symbols.
+
+ $container remove {*}$unrealizable
+
+ # Phase II. For the remaining symbols, if any, rewrite their
+ # expressions to get rid of the references to the dropped symbols
+ # (these may occur in choice (/) operators).
+
+ foreach symbol [$container nonterminals] {
+ $container rule $symbol \
+ [pt::pe::op drop $unrealizable \
+ [$container rule $symbol]]
+ }
+ return
+}
+
+# # ## ### ##### ######## #############
+## Internals
+
+proc ::pt::peg::op::Invert {dict} {
+ # dict = dict (a -> list(b))
+ # result = dict (b -> list(a))
+ array set tmp {}
+ foreach {a blist} $dict {
+ foreach b $blist {
+ lappend tmp($b) $a
+ }
+ }
+ return [array get tmp]
+}
+
+# # ## ### ##### ######## #############
+## State / Configuration :: n/a
+
+namespace eval ::pt::peg::op {}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide pt::peg::op 1.0.1
+return
diff --git a/tcllib/modules/pt/pt_peg_to_container.man b/tcllib/modules/pt/pt_peg_to_container.man
new file mode 100644
index 0000000..eed003a
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_container.man
@@ -0,0 +1,7 @@
+[comment {--- doctools ---}]
+[vset PACKAGE container]
+[vset NAME CONTAINER]
+[vset REQUIRE container]
+[vset CONFIG container]
+[vset VERSION 1]
+[include include/export/to.inc]
diff --git a/tcllib/modules/pt/pt_peg_to_container.tcl b/tcllib/modules/pt/pt_peg_to_container.tcl
new file mode 100644
index 0000000..4ecc06f
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_container.tcl
@@ -0,0 +1,345 @@
+# peg_to_container.tcl --
+#
+# Conversion from PEG to CONTAINER (Tcl code).
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pt_peg_to_container.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# This package takes the canonical serialization of a parsing
+# expression grammar and produces text in CONTAINER format, a form
+# of Tcl code which defines a snit::type whose instances store the
+# converted grammar.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require pt::peg ; # Verification that the input is
+ # proper.
+package require pt::pe ; # Conversion of expressions.
+package require text::write ; # Text generation support
+package require char ; # Character quoting needed for
+ # the Tcl code to be correct.
+
+# ### ### ### ######### ######### #########
+##
+
+namespace eval ::pt::peg::to::container {
+ namespace export \
+ reset configure convert
+
+ namespace ensemble create
+}
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc ::pt::peg::to::container::reset {} {
+ variable template @code@
+ variable mode bulk
+ variable name a_pe_grammar
+ variable file unknown
+ variable user unknown
+ return
+}
+
+proc ::pt::peg::to::container::configure {args} {
+ variable template
+ variable mode
+ variable name
+ variable file
+ variable user
+
+ if {[llength $args] == 0} {
+ return [list \
+ -file $file \
+ -mode $mode \
+ -name $name \
+ -template $template \
+ -user $user]
+ } elseif {[llength $args] == 1} {
+ lassign $args option
+ set variable [string range $option 1 end]
+ if {[info exists $variable]} {
+ return [set $variable]
+ } else {
+ return -code error "Expected one of -file, -mode, -name, -template, or -user, got \"$option\""
+ }
+ } elseif {[llength $args] % 2 == 0} {
+ foreach {option value} $args {
+ set variable [string range $option 1 end]
+ if {![info exists $variable]} {
+ return -code error "Expected one of -file, -mode, -name, -template, or -user, got \"$option\""
+ }
+ }
+ foreach {option value} $args {
+ set variable [string range $option 1 end]
+ switch -exact -- $variable {
+ mode {
+ if {$value ni {bulk incremental}} {
+ return -code error "Expected bulk, or incremental, got \"$value\""
+ }
+ }
+ template {
+ if {$value eq {}} {
+ return -code error "Expected template, got the empty string"
+ }
+ }
+ name -
+ file -
+ user { }
+ }
+ set $variable $value
+ }
+ } else {
+ return -code error {wrong#args, expected option value ...}
+ }
+}
+
+proc ::pt::peg::to::container::convert {serial} {
+ variable user
+ variable file
+ variable name
+ variable mode
+ variable template
+
+ ::pt::peg verify-as-canonical $serial
+
+ # TODO :: Reformat expressions for line-length (wrapping)
+ # TODO :: Reformat 'add' bulk symbols for line-length (wrapping).
+ # TODO :: Generate a read-only container.
+
+ # Unpack the serialization, known as canonical.
+ array set peg $serial
+ array set peg $peg(pt::grammar::peg)
+ unset peg(pt::grammar::peg)
+
+ # Determine the field size for nonterminal symbol names.
+ set smax [text::write maxlen [dict keys $peg(rules)]]
+
+ # Assemble the output, various pieces.
+ text::write reset
+ StartExpression $peg(start)
+ Rules $peg(rules) $smax
+ Type
+
+ # At last retrieve the fully assembled code and integrate with the
+ # chosen template.
+ return [string map \
+ [list \
+ @user@ $user \
+ @format@ CONTAINER \
+ @file@ $file \
+ @name@ $name \
+ @mode@ $mode \
+ @code@ [text::write get]] $template]
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Internals
+
+proc ::pt::peg::to::container::StartExpression {startexpression} {
+ text::write clear
+
+ text::write field install myg using pt::peg::container {${selfns}::G}
+ text::write /line
+
+ text::write field {$myg} start [Expression $startexpression]
+ text::write /line
+
+ text::write indent 4
+ text::write store START
+ return
+}
+
+proc ::pt::peg::to::container::Rules {rules smax} {
+ variable mode
+ text::write clear
+ if {[llength $rules]} {
+ text::write /line
+ switch -exact -- $mode {
+ bulk { BulkLoading $rules $smax }
+ incremental { IncrementalLoading $rules $smax }
+ }
+
+ text::write field return
+ text::write /line
+
+ text::write indent 4
+ }
+ text::write store RULES
+ return
+}
+
+proc ::pt::peg::to::container::BulkLoading {rules smax} {
+ # 2 phases. First reshuffle the input into bulk
+ # dictionaries, then write them.
+
+ foreach {symbol def} $rules {
+ lassign $def _ is _ mode
+ lappend symbols $symbol
+ lappend modes $symbol $mode
+ lappend rhs $symbol $is
+ }
+
+ text::write clear
+ foreach {symbol mode} $modes {
+ text::write fieldl $smax $symbol
+ text::write field $mode
+ text::write /line
+ }
+ text::write indent 4
+ text::write store MODES
+
+ text::write clear
+ foreach {symbol is} $rhs {
+ text::write fieldl $smax $symbol
+ text::write field [Expression $is]
+ text::write /line
+ }
+ text::write indent 4
+ text::write store RULES
+
+ # note - allow line wrapping, max length of line?
+ text::write clear
+ text::write field {$myg} {add } {*}$symbols
+ text::write /line
+
+ text::write field {$myg} modes \{
+ text::write /line
+
+ text::write recall MODES
+
+ text::write field \}
+ text::write /line
+
+ text::write field {$myg} rules \{
+ text::write /line
+
+ text::write recall RULES
+
+ text::write field \}
+ text::write /line
+ return
+}
+
+proc ::pt::peg::to::container::IncrementalLoading {rules smax} {
+ foreach {symbol def} $rules {
+ lassign $def _ is _ mode
+
+ text::write field {$myg}
+ text::write fieldl 5 add
+ text::write fieldl $smax $symbol
+ text::write /line
+
+ text::write field {$myg}
+ text::write fieldl 5 mode
+ text::write fieldl $smax $symbol
+ text::write field $mode
+ text::write /line
+
+ text::write field {$myg}
+ text::write fieldl 5 rule
+ text::write fieldl $smax $symbol
+ text::write field [Expression $is]
+ text::write /line
+
+ text::write /line
+ }
+ return
+}
+
+proc ::pt::peg::to::container::TypeBody {} {
+ text::write clear
+
+ text::write field constructor "{}" \{
+ text::write /line
+
+ text::write recall START
+ text::write recall RULES
+
+ text::write field \}
+ text::write /line
+
+ text::write /line
+
+ text::write field component myg
+ text::write /line
+
+ text::write field delegate method * to myg
+ text::write /line
+
+ text::write indent 4
+ text::write store BODY
+ return
+}
+
+proc ::pt::peg::to::container::Type {} {
+ variable name
+
+ TypeBody
+
+ text::write clear
+
+ text::write field snit::type $name \{
+ text::write /line
+
+ text::write recall BODY
+
+ text::write field \}
+ text::write /line
+ return
+}
+
+proc ::pt::peg::to::container::Expression {pe} {
+ return [list [pt::pe bottomup \
+ [namespace current]::Convert \
+ $pe]]
+}
+
+proc ::pt::peg::to::container::Convert {pe operator arguments} {
+ if {$operator eq "t"} {
+ return "$operator [char quote tcl [lindex $arguments 0]]"
+ } elseif {$operator eq ".."} {
+ lassign $arguments ca ce
+ return "$operator [char quote tcl $ca] [char quote tcl $ce]"
+ } else {
+ return $pe
+ }
+ return -code error {INTERNAL ERROR}
+}
+
+# ### ### ### ######### ######### #########
+## Configuration
+
+namespace eval ::pt::peg::to::container {
+
+ variable template @code@ ; # A string. Specifies how to
+ # embed the generated code into a
+ # larger frame- work (the
+ # template).
+ variable mode bulk ; # enum (bulk,
+ # incremental). Chooses between
+ # code for bulk or incrementally
+ # loading of the grammar into its
+ # container.
+ variable name a_pe_grammar ; # String. Name of the grammar.
+ variable file unknown ; # String. Name of the file or
+ # other entity the grammar came
+ # from.
+ variable user unknown ; # String. Name of the user on
+ # which behalf the conversion has
+ # been invoked.
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pt::peg::to::container 1
+return
diff --git a/tcllib/modules/pt/pt_peg_to_container.test b/tcllib/modules/pt/pt_peg_to_container.test
new file mode 100644
index 0000000..ac85ab0
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_container.test
@@ -0,0 +1,48 @@
+# -*- tcl -*-
+# pt_peg_export_container.test: tests for the pt::peg::export::container
+# package/plugin.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_to_container.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal text_write.tcl text::write
+ useLocal char.tcl char
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_peg_to_container.tcl pt::peg::to::container
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::set setimpl {
+ source [localPath tests/pt_peg_to_container.tests]
+}
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_to_cparam.man b/tcllib/modules/pt/pt_peg_to_cparam.man
new file mode 100644
index 0000000..9e46797
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_cparam.man
@@ -0,0 +1,7 @@
+[comment {--- doctools ---}]
+[vset PACKAGE cparam]
+[vset NAME CPARAM]
+[vset REQUIRE cparam]
+[vset CONFIG cparam]
+[vset VERSION 1.1.2]
+[include include/export/to.inc]
diff --git a/tcllib/modules/pt/pt_peg_to_cparam.tcl b/tcllib/modules/pt/pt_peg_to_cparam.tcl
new file mode 100644
index 0000000..f8298f7
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_cparam.tcl
@@ -0,0 +1,1661 @@
+# peg_to_param.tcl --
+#
+# Conversion of PEG to C PARAM, customizable text blocks.
+#
+# Copyright (c) 2009-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pt_peg_to_cparam.tcl,v 1.2 2010/04/07 19:40:54 andreas_kupries Exp $
+
+# This package takes the canonical serialization of a parsing
+# expression grammar and produces text in PARAM assembler, i.e.
+# readable machine code for the PARAM virtual machine.
+
+## NOTE: Should have cheat sheet of PARAM instructions (which parts of
+## the arch state they touch, and secondly, bigger effects).
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require pt::peg ; # Verification that the input
+ # is proper.
+package require pt::pe ; # Walking an expression.
+package require pt::pe::op ; # String/Class fusing
+package require text::write ; # Text generation support
+package require char
+
+# ### ### ### ######### ######### #########
+##
+
+namespace eval ::pt::peg::to::cparam {
+ namespace export \
+ reset configure convert
+
+ namespace ensemble create
+}
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc ::pt::peg::to::cparam::reset {} {
+ variable insertcmd {} ; # -insert-command (hook)
+ variable template @code@ ; # -template
+ variable name a_pe_grammar ; # -name
+ variable file unknown ; # -file
+ variable user unknown ; # -user
+ variable self {} ; # -self-command
+ variable ns {} ; # -namespace
+ variable def static ; # -fun-qualifier
+ variable main __main ; # -main
+ variable indent 0 ; # -indent
+ variable comments 1 ; # -comments
+ variable prelude {} ; # -prelude
+ variable statedecl {RDE_PARAM p} ; # -state-decl
+ variable stateref {p} ; # -state-ref
+ variable strings p_string ; # -string-varname
+ return
+}
+
+proc ::pt::peg::to::cparam::configure {args} {
+ variable template
+ variable name
+ variable file
+ variable user
+ variable self
+ variable ns
+ variable def
+ variable main
+ variable omap
+ variable indent
+ variable insertcmd
+ variable comments
+ variable prelude
+ variable statedecl
+ variable stateref
+ variable strings
+
+ if {[llength $args] == 0} {
+ return [list \
+ -comments $comments \
+ -file $file \
+ -fun-qualifier $def \
+ -indent $indent \
+ -insert-command $insertcmd \
+ -main $main \
+ -name $name \
+ -namespace $ns \
+ -self-command $self \
+ -state-decl $statedecl \
+ -state-ref $stateref \
+ -string-varname $strings \
+ -template $template \
+ -user $user \
+ ]
+ } elseif {[llength $args] == 1} {
+ lassign $args option
+ set variable [string range $option 1 end]
+ if {[info exists omap($variable)]} {
+ return [set $omap($variable)]
+ } else {
+ # TODO: compute this string dynamically.
+ return -code error "Expected one of -comments, -file, -fun-qualifier, -indent, -insert-cmd, -main, -name, -namespace, -self-command, -state-decl, -state-ref, -string-varname, -template, or -user, got \"$option\""
+ }
+ } elseif {[llength $args] % 2 == 0} {
+ foreach {option value} $args {
+ set variable [string range $option 1 end]
+ if {![info exists omap($variable)]} {
+ # TODO: compute this string dynamically.
+ return -code error "Expected one of -comments, -file, -fun-qualifier, -indent, -insert-cmd, -main, -name, -namespace, -self-command, -state-decl, -state-ref, -string-varname, -template, or -user, got \"$option\""
+ }
+ }
+ foreach {option value} $args {
+ set variable $omap([string range $option 1 end])
+ switch -exact -- $variable {
+ template {
+ if {$value eq {}} {
+ return -code error "Expected template, got the empty string"
+ }
+ }
+ indent {
+ if {![string is integer -strict $value] || ($value < 0)} {
+ return -code error "Expected int > 0, got \"$value\""
+ }
+ }
+ comments {
+ if {![string is boolean -strict $value]} {
+ return -code error "Expected boolean, got \"$value\""
+ }
+ }
+ insert-cmd -
+ statedecl -
+ stateref -
+ strings -
+ self -
+ def -
+ ns -
+ main -
+ name -
+ file -
+ user { }
+ }
+ set $variable $value
+ }
+ } else {
+ return -code error {wrong#args, expected option value ...}
+ }
+}
+
+proc ::pt::peg::to::cparam::convert {serial} {
+ variable Op::Asm::cache
+ variable template
+ variable name
+ variable file
+ variable user
+ variable self
+ variable ns
+ variable def
+ variable main
+ variable indent
+ variable insertcmd
+ variable prelude
+ variable statedecl
+ variable stateref
+ variable strings
+
+ Op::Asm::Setup
+
+ ::pt::peg verify-as-canonical $serial
+
+ # Unpack the serialization, known as canonical
+ array set peg $serial
+ array set peg $peg(pt::grammar::peg)
+ unset peg(pt::grammar::peg)
+
+ set modes {}
+ foreach {symbol symdef} $peg(rules) {
+ lassign $symdef _ is _ mode
+ lappend modes $symbol $mode
+ }
+
+ text::write reset
+
+ # Fixed elements of the string table as needed by the lower level
+ # PARAM functions (class tests, see param.c, enum test_class).
+ # ** Keep in sync **
+ #
+ # Maybe move the interning into the lower level, i.e. PARAM ?
+
+ Op::Asm::String alnum
+ Op::Asm::String alpha
+ Op::Asm::String ascii
+ Op::Asm::String control
+ Op::Asm::String ddigit
+ Op::Asm::String digit
+ Op::Asm::String graph
+ Op::Asm::String lower
+ Op::Asm::String print
+ Op::Asm::String punct
+ Op::Asm::String space
+ Op::Asm::String upper
+ Op::Asm::String wordchar
+ Op::Asm::String xdigit
+
+ Op::Asm::Header {Declaring the parse functions}
+ text::write /line
+ text::write store FORWARD
+
+ text::write clear
+ set blocks {}
+
+ # Translate all expressions/symbols, results are stored in
+ # text::write blocks, command results are the block ids.
+
+ set start [pt::pe::op flatten \
+ [pt::pe::op fusechars \
+ [pt::pe::op flatten \
+ $peg(start)]]]
+
+ lappend blocks [set start [Expression $start $modes]]
+
+ foreach {symbol symdef} $peg(rules) {
+ lassign $symdef _ is _ mode
+ set is [pt::pe::op flatten \
+ [pt::pe::op fusechars \
+ [pt::pe::op flatten \
+ $is]]]
+ lappend blocks [Symbol $symbol $mode $is $modes]
+ }
+
+ # Assemble the output from the stored blocks.
+ text::write clear
+ text::write recall FORWARD
+ text::write /line
+
+ Op::Asm::Header {Precomputed table of strings (symbols, error messages, etc.).}
+ text::write /line
+ set n [llength $cache(_strings)]
+ text::write field static char const* @strings@ \[$n\] = \{
+ text::write /line
+ foreach s [lrange $cache(_strings) 0 end-1] {
+ text::write field " " ${s},
+ text::write /line
+ }
+ text::write field " " [lindex $cache(_strings) end]
+ text::write /line
+ text::write field \}\;
+ text::write /line
+ text::write /line
+
+ Op::Asm::Header {Grammar Start Expression}
+ Op::Asm::FunStart @main@
+ Op::Asm::Call $start 0
+ Op::Asm::CStmt return
+ Op::Asm::FunClose
+
+ foreach b $blocks {
+ Op::Asm::Use $b
+ text::write /line
+ }
+
+ # At last retrieve the fully assembled result and integrate with
+ # the chosen template.
+
+ set code [text::write get]
+ if {$indent} {
+ set code [Indent $code $indent]
+ }
+
+ set xprelude $prelude ; if {$xprelude ne {}} { set xprelude " $xprelude" }
+ set xself $self ; if {$xself ne {}} { append xself { } }
+
+ # I. run code through the insertcmd hook (if specified) to prepare it for embedding
+ if {[llength $insertcmd]} {
+ set code [{*}$insertcmd $code]
+ }
+
+ # II. Phase 1 merge of code into the template.
+ # (Placeholders only in the template)
+ lappend map @user@ $user
+ lappend map @format@ C/PARAM
+ lappend map @file@ $file
+ lappend map @name@ $name
+ lappend map @code@ $code
+ set code [string map $map $template]
+ unset map
+
+ # III. Phase 2 merge of code into the template.
+ # (Placeholders in generated code, and template).
+ lappend map @statedecl@ $statedecl
+ lappend map @stateref@ $stateref
+ lappend map @strings@ $strings
+ lappend map { @prelude@} $xprelude
+ lappend map {@self@ } $xself
+ lappend map @def@ $def
+ lappend map @ns@ $ns
+ lappend map @main@ $main
+ set code [string map $map $code]
+
+ return $code
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Internals
+
+proc ::pt::peg::to::cparam::Indent {text n} {
+ set b [string repeat { } $n]
+ return $b[join [split $text \n] \n$b]
+}
+
+proc ::pt::peg::to::cparam::Expression {expression modes} {
+ return [pt::pe bottomup \
+ [list [namespace current]::Op $modes] \
+ $expression]
+}
+
+proc ::pt::peg::to::cparam::Symbol {symbol mode rhs modes} {
+ set expression [Expression $rhs $modes]
+
+ text::write clear
+ Op::Asm::Header "$mode Symbol '$symbol'"
+ text::write store FUN_HEADER
+
+ Op::Asm::Start
+ Op::Asm::ReExpression $symbol
+ Op::Asm::GenAST $expression
+ Op::Asm::PE $rhs
+
+ set gen [dict get $result gen]
+
+ Op::Asm::Function sym_$symbol {
+ # Message is Tcl list. Quote for C embedding.
+ set msg [Op::Asm::String [char quote cstring [list n $symbol]]]
+ # Quote for C embedding.
+ set symbol [Op::Asm::String [char quote cstring $symbol]]
+
+ # We have six possibilites for the combination of AST node
+ # generation by the rhs and AST generation by the symbol. Two
+ # of these (leaf/0, value/0 coincide, leaving 5). This
+ # controls the use of AS/ARS instructions.
+
+ switch -exact -- $mode/$gen {
+ value/1 {
+ # Generate value for symbol, rhs may have generated
+ # AST nodes as well, keep rhs
+
+ Op::Asm::CBlock if (rde_param_i_symbol_start_d (@stateref@, $symbol)) return \;
+ Op::Asm::Call $expression
+ Op::Asm::Ins symbol_done_d_reduce $symbol $msg
+
+ #Op::Asm::CBlock if (!rde_param_i_symbol_restore (@stateref@, $symbol)) \{
+ #Op::Asm::>>> 4
+
+ #Op::Asm::Ins loc_push
+ #Op::Asm::Ins ast_push
+
+ #Op::Asm::Call $expression
+
+ #Op::Asm::CBlock if (rde_param_query_st(@stateref@)) \{
+ #Op::Asm::>>> 4
+ #Op::Asm::Ins value_reduce $symbol
+ #Op::Asm::<<< 4
+ #Op::Asm::CBlock \} else \{
+ #Op::Asm::>>> 4
+ #Op::Asm::Ins value_clear
+ #Op::Asm::<<< 4
+ #Op::Asm::CBlock \}
+
+ #Op::Asm::Ins symbol_save $symbol
+ #Op::Asm::Ins error_nonterminal $symbol
+
+ #Op::Asm::Ins ast_pop_rewind
+ #Op::Asm::Ins loc_pop_discard
+
+ #Op::Asm::<<< 4
+ #Op::Asm::CBlock \}
+
+ #Op::Asm::CBlock if (rde_param_query_st(@stateref@)) \{
+ #Op::Asm::>>> 4
+ #Op::Asm::Ins ast_value_push
+ #Op::Asm::<<< 4
+ #Op::Asm::CBlock \}
+ }
+ leaf/0 -
+ value/0 {
+ # Generate value for symbol, rhs cannot generate its
+ # own AST nodes => leaf/0.
+
+ Op::Asm::CBlock if (rde_param_i_symbol_start (@stateref@, $symbol)) return \;
+ Op::Asm::Call $expression
+ Op::Asm::Ins symbol_done_leaf $symbol $msg
+
+ #Op::Asm::CBlock if (!rde_param_i_symbol_restore (@stateref@, $symbol)) \{
+ #Op::Asm::>>> 4
+
+ #Op::Asm::Ins loc_push
+
+ #Op::Asm::Call $expression
+
+ #Op::Asm::CBlock if (rde_param_query_st(@stateref@)) \{
+ #Op::Asm::>>> 4
+ #Op::Asm::Ins value_leaf $symbol
+ #Op::Asm::<<< 4
+ #Op::Asm::CBlock \} else \{
+ #Op::Asm::>>> 4
+ #Op::Asm::Ins value_clear
+ #Op::Asm::<<< 4
+ #Op::Asm::CBlock \}
+
+ #Op::Asm::Ins symbol_save $symbol
+ #Op::Asm::Ins error_nonterminal $symbol
+
+ #Op::Asm::Ins loc_pop_discard
+
+ #Op::Asm::<<< 4
+ #Op::Asm::CBlock \}
+
+ #Op::Asm::CBlock if (rde_param_query_st(@stateref@)) \{
+ #Op::Asm::>>> 4
+ #Op::Asm::Ins ast_value_push
+ #Op::Asm::<<< 4
+ #Op::Asm::CBlock \}
+ }
+ leaf/1 {
+ # Generate value for symbol, rhs may have generated
+ # AST nodes as well, discard rhs.
+
+ Op::Asm::CBlock if (rde_param_i_symbol_start_d (@stateref@, $symbol)) return \;
+ Op::Asm::Call $expression
+ Op::Asm::Ins symbol_done_d_leaf $symbol $msg
+
+ #Op::Asm::CBlock if (!rde_param_i_symbol_restore (@stateref@, $symbol)) \{
+ #Op::Asm::>>> 4
+
+ #Op::Asm::Ins loc_push
+ #Op::Asm::Ins ast_push
+
+ #Op::Asm::Call $expression
+
+ #Op::Asm::CBlock if (rde_param_query_st(@stateref@)) \{
+ #Op::Asm::>>> 4
+ #Op::Asm::Ins value_leaf $symbol
+ #Op::Asm::<<< 4
+ #Op::Asm::CBlock \} else \{
+ #Op::Asm::>>> 4
+ #Op::Asm::Ins value_clear
+ #Op::Asm::<<< 4
+ #Op::Asm::CBlock \}
+
+ #Op::Asm::Ins symbol_save $symbol
+ #Op::Asm::Ins error_nonterminal $symbol
+
+ #Op::Asm::Ins ast_pop_rewind
+ #Op::Asm::Ins loc_pop_discard
+
+ #Op::Asm::<<< 4
+ #Op::Asm::CBlock \}
+
+ #Op::Asm::CBlock if (rde_param_query_st(@stateref@)) \{
+ #Op::Asm::>>> 4
+ #Op::Asm::Ins ast_value_push
+ #Op::Asm::<<< 4
+ #Op::Asm::CBlock \}
+ }
+ void/1 {
+ # Generate no value for symbol, rhs may have generated
+ # AST nodes as well, discard rhs.
+ # // test case missing //
+
+ Op::Asm::CBlock if (rde_param_i_symbol_void_start_d (@stateref@, $symbol)) return \;
+ Op::Asm::Call $expression
+ Op::Asm::Ins symbol_done_d_void $symbol $msg
+
+ #Op::Asm::CBlock if (!rde_param_i_symbol_restore (@stateref@, $symbol)) \{
+ #Op::Asm::>>> 4
+
+ #Op::Asm::Ins loc_push
+ #Op::Asm::Ins ast_push
+
+ #Op::Asm::Call $expression
+
+ #Op::Asm::Ins value_clear
+
+ #Op::Asm::Ins symbol_save $symbol
+ #Op::Asm::Ins error_nonterminal $symbol
+
+ #Op::Asm::Ins ast_pop_rewind
+ #Op::Asm::Ins loc_pop_discard
+
+ #Op::Asm::<<< 4
+ #Op::Asm::CBlock \}
+ }
+ void/0 {
+ # Generate no value for symbol, rhs cannot generate
+ # its own AST nodes. Nothing to save nor discard.
+
+ Op::Asm::CBlock if (rde_param_i_symbol_void_start (@stateref@, $symbol)) return \;
+ Op::Asm::Call $expression
+ Op::Asm::Ins symbol_done_void $symbol $msg
+
+ #Op::Asm::CBlock if (!rde_param_i_symbol_restore (@stateref@, $symbol)) \{
+ #Op::Asm::>>> 4
+
+ #Op::Asm::Ins loc_push
+
+ #Op::Asm::Call $expression
+
+ #Op::Asm::Ins value_clear
+
+ #Op::Asm::Ins symbol_save $symbol
+ #Op::Asm::Ins error_nonterminal $symbol
+
+ #Op::Asm::Ins loc_pop_discard
+
+ #Op::Asm::<<< 4
+ #Op::Asm::CBlock \}
+ }
+ }
+ } $expression
+ Op::Asm::Done
+}
+
+namespace eval ::pt::peg::to::cparam::Op {
+ namespace export \
+ alpha alnum ascii control digit graph lower print \
+ punct space upper wordchar xdigit ddigit \
+ dot epsilon t .. n ? * + & ! x /
+}
+
+proc ::pt::peg::to::cparam::Op {modes pe op arguments} {
+ return [namespace eval Op [list $op $modes {*}$arguments]]
+}
+
+proc ::pt::peg::to::cparam::Op::epsilon {modes} {
+ Asm::Start
+ Asm::ReExpression epsilon
+ Asm::Direct {
+ Asm::Ins status_ok
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::cparam::Op::dot {modes} {
+ Asm::Start
+ Asm::ReExpression dot
+ Asm::Direct {
+ Asm::Ins input_next [Asm::String dot]
+ }
+ Asm::Done
+}
+
+foreach test {
+ alpha alnum ascii control digit graph lower print
+ punct space upper wordchar xdigit ddigit
+} {
+ proc ::pt::peg::to::cparam::Op::$test {modes} \
+ [string map [list @OP@ $test] {
+ Asm::Start
+ Asm::ReExpression @OP@
+ Asm::Direct {
+ set m [Asm::String @OP@]
+ #Asm::Ins input_next [Asm::String @OP@]
+ #Asm::CStmt if (!rde_param_query_st(@stateref@)) return
+ #Asm::Ins test_@OP@
+ Asm::Ins next_@OP@ $m
+ }
+ Asm::Done
+ }]
+}
+
+proc ::pt::peg::to::cparam::Op::t {modes char} {
+ Asm::Start
+ Asm::ReTerminal t $char
+ Asm::Direct {
+ # Message is Tcl list. Quote for C embedding.
+ set msg [Asm::String [char quote cstring [list t $char]]]
+ # Quote for C embedding.
+ set char [char quote cstring $char]
+
+ #Asm::Ins input_next $msg
+ #Asm::CStmt if (!rde_param_query_st(@stateref@)) return
+ #Asm::Ins test_char \"$char\" $msg
+ Asm::Ins next_char \"$char\" $msg
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::cparam::Op::.. {modes chs che} {
+ Asm::Start
+ Asm::ReTerminal .. $chs $che
+ Asm::Direct {
+ # Message is Tcl list. Quote for C embedding.
+ set msg [Asm::String [char quote cstring [list .. $chs $che]]]
+
+ # Quote for C embedding
+ set chs [char quote cstring $chs]
+ set che [char quote cstring $che]
+
+ #Asm::Ins input_next $msg
+ #Asm::CStmt if (!rde_param_query_st(@stateref@)) return
+ #Asm::Ins test_range \"$chs\" \"$che\" $msg
+ Asm::Ins next_range \"$chs\" \"$che\" $msg
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::cparam::Op::str {modes args} {
+ Asm::Start
+ Asm::ReTerminal str {*}$args
+ Asm::Direct {
+ set str [join $args {}]
+ # Message is Tcl list. Quote for C embedding.
+ set msg [Asm::String [char quote cstring [list str $str]]]
+ # Quote for C embedding
+ set str [char quote cstring $str]
+
+ # Without fusing this would be rendered as a sequence of
+ # characters, with associated stack churn for each
+ # character/part (See Op::x, void/all).
+
+ Asm::Ins next_str \"$str\" $msg
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::cparam::Op::cl {modes args} {
+ # rorc = Range-OR-Char-List
+ Asm::Start
+ Asm::ReTerminal cl {*}$args
+ Asm::Direct {
+ # Without fusing this would be rendered as a choice of
+ # characters, with associated stack churn for each
+ # character/branch (See Op::/, void/all).
+
+ set cl [join [Ranges {*}$args] {}]
+ # Message is Tcl list. Quote for C embedding.
+ set msg [Asm::String [char quote cstring [list cl $cl]]]
+ # Quote for C embedding
+ set cl [char quote cstring $cl]
+
+ Asm::Ins next_class \"$cl\" $msg
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::cparam::Op::Ranges {args} {
+ set res {}
+ foreach rorc $args { lappend res [Range $rorc] }
+ return $res
+}
+
+proc ::pt::peg::to::cparam::Op::Range {rorc} {
+ # See also pt::peg::to::peg
+
+ # We use string ops here to distinguish terminals and ranges. The
+ # input can be a single char, not a list, and further the char may
+ # not be a proper list. Example: double-apostroph.
+ if {[string length $rorc] > 1} {
+ lassign $rorc s e
+
+ # The whole range is expanded into its full set of characters.
+ # Beware, this may blow the process if the range tries to
+ # match a substantial part of the unicode character set. We
+ # should see if there is a way to keep it encoded as range
+ # without giving up on the fast matching.
+
+ set s [scan $s %c]
+ set e [scan $e %c]
+
+ set res {}
+ for {set i $s} {$i <= $e} {incr i} {
+ append res [format %c $i]
+ }
+ return $res
+ } else {
+ return $rorc ;#[char quote tcl $rorc]
+ }
+}
+
+proc ::pt::peg::to::cparam::Op::n {modes symbol} {
+ # symbol mode determines AST generation
+ # void => non-generative,
+ # leaf/value => generative.
+
+ Asm::Start
+ Asm::ReTerminal n $symbol
+
+ if {![dict exists $modes $symbol]} {
+ # Incomplete grammar. The symbol has no definition.
+ Asm::Direct {
+ Asm::CStmt "/* Undefined symbol '$symbol' */"
+ Asm::Ins status_fail
+ }
+ } else {
+ Asm::GenAST [list gen [expr { [dict get $modes $symbol] ne "void" }]]
+ Asm::Direct {
+ Asm::Self sym_$symbol
+ }
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::cparam::Op::& {modes expression} {
+ # Note: This operation could be inlined, as it has no special
+ # control flow. Not done to make the higher-level ops are
+ # similar in construction and use = consistent and simple.
+
+ Asm::Start
+ Asm::ReExpression & $expression
+ Asm::GenAST $expression
+
+ Asm::Function [Asm::NewBlock ahead] {
+ Asm::Ins loc_push
+ Asm::Call $expression
+ Asm::Ins loc_pop_rewind
+ } $expression
+ Asm::Done
+}
+
+proc ::pt::peg::to::cparam::Op::! {modes expression} {
+ # Note: This operation could be inlined, as it has no special
+ # control flow. Not done to make the higher-level ops are
+ # similar in construction and use = consistent and simple.
+
+ Asm::Start
+ Asm::ReExpression ! $expression
+ if {[dict get $expression gen]} {
+ Asm::Function [Asm::NewBlock notahead] {
+ # The sub-expression may generate AST elements. We must
+ # not pass them through.
+
+ #Asm::Ins loc_push
+ #Asm::Ins ast_push
+
+ Asm::Ins notahead_start_d
+ Asm::Call $expression
+ Asm::Ins notahead_exit_d
+
+ #Asm::CBlock if (rde_param_query_st(@stateref@)) \{
+ #Asm::>>> 4
+ #Asm::Ins ast_pop_rewind
+ #Asm::<<< 4
+ #Asm::CBlock \} else \{
+ #Asm::>>> 4
+ #Asm::Ins ast_pop_discard
+ #Asm::<<< 4
+ #Asm::CBlock \}
+
+ #Asm::Ins loc_pop_rewind
+ #Asm::Ins status_negate
+ } $expression
+ } else {
+ Asm::Function [Asm::NewBlock notahead] {
+ # The sub-expression cannot generate AST elements. We can
+ # ignore AS/ARS, simplifying the code.
+
+ Asm::Ins loc_push
+ Asm::Call $expression
+ Asm::Ins notahead_exit
+
+ #Asm::Ins loc_pop_rewind
+ #Asm::Ins status_negate
+ } $expression
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::cparam::Op::? {modes expression} {
+ # Note: This operation could be inlined, as it has no special
+ # control flow. Not done to make the higher-level ops are
+ # similar in construction and use => consistent and simple.
+
+ Asm::Start
+ Asm::ReExpression ? $expression
+ Asm::GenAST $expression
+
+ Asm::Function [Asm::NewBlock optional] {
+ #Asm::Ins loc_push
+ #Asm::Ins error_push
+
+ Asm::Ins state_push_2
+ Asm::Call $expression
+ Asm::Ins state_merge_ok
+
+ #Asm::Ins error_pop_merge
+
+ #Asm::CBlock if (rde_param_query_st(@stateref@)) \{
+ #Asm::>>> 4
+ #Asm::Ins loc_pop_discard
+ #Asm::<<< 4
+ #Asm::CBlock \} else \{
+ #Asm::>>> 4
+ #Asm::Ins loc_pop_rewind
+ #Asm::<<< 4
+ #Asm::CBlock \}
+
+ #Asm::Ins status_ok
+ } $expression
+ Asm::Done
+}
+
+proc ::pt::peg::to::cparam::Op::* {modes expression} {
+ Asm::Start
+ Asm::ReExpression * $expression
+ Asm::GenAST $expression
+
+ Asm::Function [Asm::NewBlock kleene] {
+ Asm::CBlock while (1) \{
+ Asm::>>> 4
+ #Asm::Ins loc_push
+ #Asm::Ins error_push
+
+ Asm::Ins state_push_2
+ Asm::Call $expression
+ Asm::CStmt if (rde_param_i_kleene_close(@stateref@)) return
+
+ #Asm::Ins error_pop_merge
+
+ #Asm::CStmt if (!rde_param_query_st(@stateref@)) break
+ #Asm::Ins loc_pop_discard
+ Asm::<<< 4
+ Asm::CBlock \}
+ # FAILED, clean up and return OK.
+ #text::write /line
+ #Asm::Ins loc_pop_rewind
+ #Asm::Ins status_ok
+ } $expression
+ Asm::Done
+}
+
+proc ::pt::peg::to::cparam::Op::+ {modes expression} {
+ Asm::Start
+ Asm::ReExpression + $expression
+ Asm::GenAST $expression
+
+ Asm::Function [Asm::NewBlock poskleene] {
+ Asm::Ins loc_push
+ Asm::Call $expression
+ Asm::CStmt if (rde_param_i_kleene_abort(@stateref@)) return
+
+ #Asm::CStmt if (!rde_param_query_st(@stateref@)) goto error
+ #Asm::Ins loc_pop_discard
+ #text::write /line
+
+ Asm::CBlock while (1) \{
+ Asm::>>> 4
+ #Asm::Ins loc_push
+ #Asm::Ins error_push
+
+ Asm::Ins state_push_2
+ Asm::Call $expression
+ Asm::CStmt if (rde_param_i_kleene_close(@stateref@)) return
+
+ #Asm::Ins error_pop_merge
+
+ #Asm::CStmt if (!rde_param_query_st(@stateref@)) break
+ #Asm::Ins loc_pop_discard
+ Asm::<<< 4
+ Asm::CBlock \}
+ # FAILED, clean up and return OK.
+ #text::write /line
+ #Asm::Ins status_ok
+ #Asm::CLabel error
+ #Asm::Ins loc_pop_rewind
+ } $expression
+ Asm::Done
+}
+
+proc ::pt::peg::to::cparam::Op::x {modes args} {
+ if {[llength $args] == 1} {
+ return [lindex $args 0]
+ }
+
+ Asm::Start
+ Asm::ReExpression x {*}$args
+ set gens [Asm::GenAST {*}$args]
+
+ # We have three possibilities regarding AST node generation, each
+ # requiring a slightly different instruction sequence.
+
+ # i. gen == 0 <=> No node generation at all.
+ # ii. gens[0] == 1 <=> We may have nodes from the beginning.
+ # iii. <=> Node generation starts in the middle.
+
+ if {![dict get $result gen]} {
+ set mode none
+ } elseif {[lindex $gens 0]} {
+ set mode all
+ } else {
+ set mode some
+ }
+
+ Asm::Function [Asm::NewBlock sequence] {
+ switch -exact -- $mode {
+ none {
+ # (Ad i) No AST node generation at all.
+
+ Asm::xinit0
+
+ # Note: This loop runs at code generation time. At
+ # runtime the entire construction is essentially a
+ # fully unrolled loop, with each iteration having its
+ # own block of instructions.
+
+ foreach expression [lrange $args 0 end-1] {
+ Asm::Call $expression
+ Asm::xinter00
+ }
+ Asm::Call [lindex $args end]
+ Asm::xexit0
+ }
+ all {
+ # (Ad ii) AST node generation from start to end.
+
+ Asm::xinit1
+
+ # Note: This loop runs at code generation time. At
+ # runtime the entire construction is essentially a
+ # fully unrolled loop, with each iteration having its
+ # own block of instructions.
+
+ foreach expression [lrange $args 0 end-1] {
+ Asm::Call $expression
+ Asm::xinter11
+ }
+ Asm::Call [lindex $args end]
+ Asm::xexit1
+ }
+ some {
+ # (Ad iii). Start without AST nodes, later parts do
+ # AST nodes.
+
+ Asm::xinit0
+
+ # Note: This loop runs at code generation time. At
+ # runtime the entire construction is essentially a
+ # fully unrolled loop, with each iteration having its
+ # own block of instructions.
+
+ set pushed 0
+ foreach expression [lrange $args 0 end-1] xgen [lrange $gens 1 end] {
+ Asm::Call $expression
+ if {!$pushed && $xgen} {
+ Asm::xinter01
+ set pushed 1
+ continue
+ }
+ if {$pushed} {
+ #Asm::xinter11 error_pushed
+ Asm::xinter11
+ } else {
+ Asm::xinter00
+ }
+ }
+ Asm::Call [lindex $args end]
+ #Asm::xexit1a
+ Asm::xexit1
+ }
+ }
+ } {*}$args
+ Asm::Done
+}
+
+proc ::pt::peg::to::cparam::Op::/ {modes args} {
+ if {[llength $args] == 1} {
+ return [lindex $args 0]
+ }
+
+ Asm::Start
+ Asm::ReExpression / {*}$args
+ set gens [Asm::GenAST {*}$args]
+
+ # Optimized AST handling: Handle each branch separately, based on
+ # its ability to generate AST nodes.
+
+ Asm::Function [Asm::NewBlock choice] {
+ set hasxgen 0
+ set hasnoxgen 0
+ if {[tcl::mathfunc::max {*}$gens]} { set hasxgen 1 }
+ if {![tcl::mathfunc::min {*}$gens]} { set hasnoxgen 1 }
+
+ set xgen [lindex $gens 0]
+ Asm::/init$xgen
+
+ # Note: This loop runs at code generation time. At runtime the
+ # entire construction is essentially a fully unrolled loop,
+ # with each iteration having its own block of instructions.
+
+ foreach expression [lrange $args 0 end-1] nxgen [lrange $gens 1 end] {
+ Asm::Call $expression
+ Asm::/inter$xgen$nxgen
+ set xgen $nxgen
+ }
+
+ Asm::Call [lindex $args end]
+ Asm::/exit$nxgen;#[expr {$nxgen ? $hasnoxgen : $hasxgen }]
+
+ } {*}$args
+ Asm::Done
+}
+
+# ### ### ### ######### ######### #########
+## Assembler commands
+
+namespace eval ::pt::peg::to::cparam::Op::Asm {}
+
+# ### ### ### ######### ######### #########
+## The various part of a sequence compilation.
+proc ::pt::peg::to::cparam::Op::Asm::xinit0 {} {
+ #Ins loc_push
+ #Ins error_clear
+ #text::write /line
+ #Ins error_push
+
+ Ins state_push_void
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::xinit1 {} {
+ #Ins ast_push
+ #Ins loc_push
+ #Ins error_clear
+ #text::write /line
+ #Ins error_push
+
+ Ins state_push_value
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::xinter00 {} {
+ #Ins error_pop_merge
+ # Stop the sequence on element failure, and
+ # restore state to before we tried the sequence.
+ #CStmt if (!rde_param_query_st(@stateref@)) goto error
+ #Ins error_push
+
+ CStmt if (rde_param_i_seq_void2void(@stateref@)) return
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::xinter01 {} {
+ #Ins error_pop_merge
+ # Stop the sequence on element failure, and
+ # restore state to before we tried the sequence.
+ #CStmt if (!rde_param_query_st(@stateref@)) goto error
+ #Ins ast_push
+ #Ins error_push
+
+ CStmt if (rde_param_i_seq_void2value(@stateref@)) return
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::xinter11 {{label error}} {
+ #Ins error_pop_merge
+ # Stop the sequence on element failure, and
+ # restore state to before we tried the sequence.
+ #CStmt if (!rde_param_query_st(@stateref@)) goto $label
+ #Ins error_push
+
+ CStmt if (rde_param_i_seq_value2value(@stateref@)) return
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::xexit0 {} {
+ #Ins error_pop_merge
+
+ # Stop the sequence on element failure, and
+ # restore state to before we tried the sequence.
+
+ #CStmt if (!rde_param_query_st(@stateref@)) goto error
+
+ # All elements OK, squash backtracking state
+ #text::write /line
+ #Ins loc_pop_discard
+ #CStmt return
+
+ #CLabel error
+ #Ins loc_pop_rewind
+
+ Ins state_merge_void
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::xexit1 {} {
+ #Ins error_pop_merge
+
+ # Stop the sequence on element failure, and
+ # restore state to before we tried the sequence.
+
+ #CStmt if (!rde_param_query_st(@stateref@)) goto error
+
+ # All elements OK, squash backtracking state
+ #text::write /line
+ #Ins ast_pop_discard
+ #Ins loc_pop_discard
+ #CStmt return
+
+ #CLabel error
+ #Ins ast_pop_rewind
+ #Ins loc_pop_rewind
+
+ Ins state_merge_value
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::xexit1a {} { error deprecated/illegal-to-call
+ Ins error_pop_merge
+
+ # Stop the sequence on element failure, and
+ # restore state to before we tried the sequence.
+
+ CStmt if (!rde_param_query_st(@stateref@)) goto error_pushed
+
+ # All elements OK, squash backtracking state
+ text::write /line
+ Ins ast_pop_discard
+ Ins loc_pop_discard
+ CStmt return
+
+ CLabel error_pushed
+ Ins ast_pop_rewind
+ CLabel error
+ Ins loc_pop_rewind
+ return
+}
+
+# ### ### ### ######### ######### #########
+## The various part of a choice compilation.
+
+proc ::pt::peg::to::cparam::Op::Asm::/init0 {} {
+ #Ins error_clear
+ #text::write /line
+ #Ins loc_push
+ #Ins error_push
+
+ Ins state_push_void
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::/init1 {} {
+ #Ins error_clear
+ #text::write /line
+ #Ins ast_push
+ #Ins loc_push
+ #Ins error_push
+
+ Ins state_push_value
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::/inter00 {} {
+ #Ins error_pop_merge
+ #CStmt if (rde_param_query_st(@stateref@)) goto ok
+ #Ins loc_pop_rewind
+ #Ins loc_push
+ #Ins error_push
+
+ CStmt if (rde_param_i_bra_void2void(@stateref@)) return
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::/inter01 {} {
+ #Ins error_pop_merge
+ #CStmt if (rde_param_query_st(@stateref@)) goto ok
+ #Ins loc_pop_rewind
+ #Ins ast_push
+ #Ins loc_push
+ #Ins error_push
+
+ CStmt if (rde_param_i_bra_void2value(@stateref@)) return
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::/inter10 {} {
+ #Ins error_pop_merge
+ #CStmt if (rde_param_query_st(@stateref@)) goto ok_xgen
+ #Ins ast_pop_rewind
+ #Ins loc_pop_rewind
+ #Ins ast_push ??-wrong
+ #Ins loc_push
+ #Ins error_push
+
+ CStmt if (rde_param_i_bra_value2void(@stateref@)) return
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::/inter11 {} {
+ #Ins error_pop_merge
+ #CStmt if (rde_param_query_st(@stateref@)) goto ok_xgen
+ #Ins ast_pop_rewind
+ #Ins loc_pop_rewind
+ #Ins ast_push
+ #Ins loc_push
+ #Ins error_push
+
+ CStmt if (rde_param_i_bra_value2value(@stateref@)) return
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::/exit0 {} {
+ Ins state_merge_void
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::/exit1 {} {
+ Ins state_merge_value
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::/exit00 {} { error deprecated
+ Ins error_pop_merge
+
+ CStmt if (rde_param_query_st(@stateref@)) goto ok
+
+ Ins loc_pop_rewind
+
+ # All branches FAILED
+ text::write /line
+ Ins status_fail
+ CStmt return
+
+ CLabel ok
+ Ins loc_pop_discard
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::/exit01 {} { error deprecated
+ Ins error_pop_merge
+
+ CStmt if (rde_param_query_st(@stateref@)) goto ok
+
+ Ins loc_pop_rewind
+
+ # All branches FAILED
+ text::write /line
+ Ins status_fail
+ CStmt return
+
+ CLabel ok_xgen
+ Ins ast_pop_discard
+ CLabel ok
+ Ins loc_pop_discard
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::/exit10 {} { error deprecated
+ Ins error_pop_merge
+
+ CStmt if (rde_param_query_st(@stateref@)) goto ok_xgen
+ Ins ast_pop_rewind
+
+ Ins loc_pop_rewind
+
+ # All branches FAILED
+ text::write /line
+ Ins status_fail
+ CStmt return
+
+ CLabel ok_xgen
+ Ins ast_pop_discard
+
+ Ins loc_pop_discard
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::/exit11 {} { error deprecated
+ Ins error_pop_merge
+
+ CStmt if (rde_param_query_st(@stateref@)) goto ok_xgen
+ Ins ast_pop_rewind
+
+ Ins loc_pop_rewind
+
+ # All branches FAILED
+ text::write /line
+ Ins status_fail
+ CStmt return
+
+ CLabel ok_xgen
+ Ins ast_pop_discard
+
+ CLabel ok
+ Ins loc_pop_discard
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Allocate a text block / internal symbol / function
+
+proc ::pt::peg::to::cparam::Op::Asm::Start {} {
+ upvar 1 result result
+ set result {def {} use {} gen 0 pe {}}
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::Done {} {
+ upvar 1 result result
+ return -code return $result
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::ReExpression {op args} {
+ upvar 1 result result
+
+ set pe $op
+ foreach a $args {
+ lappend pe [dict get $a pe]
+ }
+
+ dict set result pe $pe
+ PE $pe
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::ReTerminal {op args} {
+ upvar 1 result result
+
+ set pe [linsert $args 0 $op]
+ dict set result pe $pe
+ PE $pe
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::GenAST {args} {
+ upvar 1 result result
+
+ foreach a $args {
+ lappend flags [dict get $a gen]
+ }
+
+ dict set result gen [tcl::mathfunc::max {*}$flags]
+ dict set result genmin [tcl::mathfunc::min {*}$flags]
+ return $flags
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::NewBlock {type} {
+ variable counter
+ variable lastid ${type}_[incr counter]
+ return $lastid
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::Function {name def args} {
+ upvar 1 result result
+ variable cache
+ variable field
+
+ set k [list [dict get $result gen] [dict get $result pe]]
+
+ # Hardcoded 'compact == 1', compare "pt_peg_to_param.tcl"
+ if {[info exists cache($k)]} {
+ dict set result def {}
+ dict set result use $cache($k)
+ return
+ }
+
+ text::write clear
+ if {[text::write exists FUN_HEADER]} {
+ text::write recall FUN_HEADER
+ text::write undef FUN_HEADER
+ }
+
+ FunStart $name
+
+ # Comment at function start.
+ text::write recall PE ; # Generated in Asm::ReExpression, printed
+ text::write undef PE ; # representation of the expression, to
+ # make the generated code more readable.
+ uplevel 1 $def
+ CStmt return
+
+ FunClose
+
+ if {[llength $args]} {
+ Use {*}$args
+ }
+
+ text::write store $name
+
+ set useb [NewBlock anon]
+ text::write clear
+ Self $name
+ text::write store $useb
+
+ dict set result def $name
+ dict set result use $useb
+
+ set cache($k) $useb
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::Direct {use} {
+ variable field
+ upvar 1 result result
+
+ set useb [NewBlock anon]
+ text::write clear
+
+ set saved $field
+ set field 0
+
+ uplevel 1 $use
+
+ text::write store $useb
+
+ set field $saved
+
+ dict set result def {}
+ dict set result use $useb
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::Call {expr {distance 1}} {
+ variable field
+ #if {$distance} { text::write /line }
+
+ set id [dict get $expr use]
+
+ text::write store CURRENT
+ text::write clear
+ text::write recall $id
+ text::write indent $field
+ text::write store CALL
+
+ text::write clear
+ text::write recall CURRENT
+ text::write recall CALL
+
+ text::write undef CURRENT
+ text::write undef CALL
+
+ #if {$distance} { text::write /line }
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::Use {args} {
+ foreach item $args {
+ set def [dict get $item def]
+ if {$def eq {}} continue
+ text::write recall $def
+ text::write undef $def
+ }
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::FunStart {name} {
+ text::write /line
+ text::write field @def@ void @ns@$name (@statedecl@) \{ @prelude@
+ text::write /line
+ text::write store CURRENT
+
+ text::write clear
+ text::write recall FORWARD
+ text::write field @def@ void @ns@$name (@statedecl@)\;
+ text::write /line
+ text::write store FORWARD
+
+ text::write clear
+ text::write recall CURRENT
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::FunClose {} {
+ text::write field \}
+ text::write /line
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::Ins {args} {
+ set args [lassign $args name]
+ CStmt rde_param_i_$name ([join [linsert $args 0 @stateref@] {, }])
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::Self {args} {
+ variable field
+ set args [lassign $args name]
+ set saved $field
+ set field 0
+ CStmt @self@ @ns@$name ([join [linsert $args 0 @stateref@] {, }])
+ set field $saved
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::>>> {n} {
+ variable field
+ incr field $n
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::<<< {n} {
+ variable field
+ incr field -$n
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::CLabel {name} {
+ text::write /line
+ <<< 2
+ CBlock ${name}:
+ >>> 2
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::CStmt {args} {
+ variable field
+
+ # Note: The lreplace/lindex dance appends a ; to the last element
+ # in the list, closing the statement.
+
+ text::write fieldl $field {}
+ text::write field {*}[lreplace $args end end [lindex $args end]\;]
+ text::write /line
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::CBlock {args} {
+ variable field
+ text::write fieldl $field {}
+ text::write field {*}$args
+ text::write /line
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::Header {text} {
+ text::write field "/*"
+ text::write /line
+ text::write field " * $text"
+ text::write /line
+ text::write field " */"
+ text::write /line
+ #text::write /line
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::PE {pe} {
+ variable ::pt::peg::to::cparam::comments
+
+ text::write clear
+ if {$comments} {
+ text::write field " /*"
+ text::write /line
+
+ # Ticket [da61329276]: Detect C comment opener and closer, and
+ # disarm them. This can occur with char classes, and char
+ # sequences, i.e. strings. We recode them into
+ # backslash-escaped unicode code-points.
+
+ # Note: Putting this into the 'pe print' method is not
+ # possible, as the output can be used in other contexts (Tcl,
+ # whatever), each with their own special strings to be aware
+ # of. This is something each generator has to handle, knowing
+ # their special sequences.
+
+ lappend map "*/" "\\u002a\\u002f"
+ lappend map "/*" "\\u002f\\u002a"
+
+ foreach l [split [pt::pe print $pe] \n] {
+ text::write field " * [string map $map $l]"
+ text::write /line
+ }
+ text::write field " */"
+ text::write /line
+ text::write /line
+ }
+ # Keeping the definition of PE, albeit empty avoids having to
+ # special case the places using this block.
+ text::write store PE
+ return
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::String {s} {
+ variable cache
+
+ set k str,$s
+
+ if {![info exists cache($k)]} {
+ set id [incr cache(_str,counter)]
+ set cache($k) $id
+
+ lappend cache(_strings) \
+ "/* [format %8d $id] = */ \"$s\""
+ }
+
+ return $cache($k)
+}
+
+proc ::pt::peg::to::cparam::Op::Asm::Setup {} {
+ variable counter 0
+ variable field 3
+ variable cache
+ array unset cache *
+ set cache(_str,counter) -1
+ set cache(_strings) {}
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Configuration
+
+namespace eval ::pt::peg::to::cparam {
+ namespace eval ::pt::peg::to::cparam::Op::Asm {
+ variable counter 0
+ variable fieldlen {17 5 5}
+ variable field 3
+ variable cache
+ array set cache {}
+ set cache(_str,counter) -1
+ set cache(_strings) {}
+ }
+
+ # Map from option name (without leading dash) to the name of the
+ # variable used to store setting.
+ variable omap ; array set omap {
+ comments comments
+ file file
+ fun-qualifier def
+ indent indent
+ insert-cmd insertcmd
+ main main
+ name name
+ namespace ns
+ prelude prelude
+ self-command self
+ state-decl statedecl
+ state-ref stateref
+ string-varname strings
+ template template
+ user user
+ }
+
+ variable insertcmd {}
+ variable comments 1
+ variable self {}
+ variable ns {}
+ variable def static
+ variable main __main
+ variable indent 0
+ variable prelude {}
+ variable statedecl {RDE_PARAM p}
+ variable stateref p
+ variable strings p_string
+
+ variable template @code@ ; # A string. Together with the
+ # insertcmd (if any) it specifies
+ # how to embed the generated code
+ # into a larger framework (the
+ # template).
+ variable name a_pe_grammar ; # String. Name of the grammar.
+ variable file unknown ; # String. Name of the file or
+ # other entity the grammar came
+ # from.
+ variable user unknown ; # String. Name of the user on
+ # which behalf the conversion has
+ # been invoked.
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pt::peg::to::cparam 1.1.3
+return
diff --git a/tcllib/modules/pt/pt_peg_to_cparam.test b/tcllib/modules/pt/pt_peg_to_cparam.test
new file mode 100644
index 0000000..9f908a5
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_cparam.test
@@ -0,0 +1,47 @@
+# -*- tcl -*-
+# pt_peg_to_cparam.test: tests for the pt::peg::to::cparam converter package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_to_cparam.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set ; # used by pt::pe::op,
+ TestAccelInit struct::set ; # however not by the
+ # # commands used here.
+
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pexpr_op.tcl pt::pe::op
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal text_write.tcl text::write
+ useLocal char.tcl char
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_peg_to_cparam.tcl pt::peg::to::cparam
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/pt_peg_to_cparam.tests]
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_to_json.man b/tcllib/modules/pt/pt_peg_to_json.man
new file mode 100644
index 0000000..4a27026
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_json.man
@@ -0,0 +1,7 @@
+[comment {--- doctools ---}]
+[vset PACKAGE json]
+[vset NAME JSON]
+[vset REQUIRE json]
+[vset CONFIG json]
+[vset VERSION 1]
+[include include/export/to.inc]
diff --git a/tcllib/modules/pt/pt_peg_to_json.tcl b/tcllib/modules/pt/pt_peg_to_json.tcl
new file mode 100644
index 0000000..0d26b90
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_json.tcl
@@ -0,0 +1,149 @@
+# peg_to_json.tcl --
+#
+# Conversion from PEG to JSON (Java Script Object Notation).
+#
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pt_peg_to_json.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# This package takes the canonical serialization of a parsing
+# expression grammar and produces text in JSON format, Java Script
+# data transfer format.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require pt::peg ; # Verification that the
+ # input is proper.
+package require json::write
+
+# ### ### ### ######### ######### #########
+##
+
+namespace eval ::pt::peg::to::json {
+ namespace export \
+ reset configure convert
+
+ namespace ensemble create
+}
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc ::pt::peg::to::json::reset {} {
+ variable indented 0
+ variable aligned 0
+ variable name a_pe_grammar
+ variable file unknown
+ variable user unknown
+ return
+}
+
+proc ::pt::peg::to::json::configure {args} {
+ variable indented
+ variable aligned
+ variable name
+ variable file
+ variable user
+
+ if {[llength $args] == 0} {
+ return [list \
+ -file $file \
+ -name $name \
+ -user $user \
+ -indented $indented \
+ -aligned $aligned]
+ } elseif {[llength $args] == 1} {
+ lassign $args option
+ set variable [string range $option 1 end]
+ if {[info exists $variable]} {
+ return [set $variable]
+ } else {
+ return -code error "Expected one of -aligned, or -indented, got \"$option\""
+ }
+ } elseif {[llength $args] % 2 == 0} {
+ foreach {option value} $args {
+ set variable [string range $option 1 end]
+ if {![info exists $variable]} {
+ return -code error "Expected one of -aligned, or -indented, got \"$option\""
+ }
+ }
+ foreach {option value} $args {
+ set variable [string range $option 1 end]
+ switch -exact -- $variable {
+ indented - aligned {
+ if {![::string is boolean -strict $value]} {
+ return -code error "Expected boolean, got \"$value\""
+ }
+ }
+ name -
+ file -
+ user { }
+ }
+ set $variable $value
+ }
+ } else {
+ return -code error {wrong#args, expected option value ...}
+ }
+}
+
+proc ::pt::peg::to::json::convert {serial} {
+ variable indented
+ variable aligned
+
+ ::pt::peg verify-as-canonical $serial
+
+ json::write indented $indented
+ json::write aligned $aligned
+
+ # Unpack the serialization, known as canonical
+ array set peg $serial
+ array set peg $peg(pt::grammar::peg)
+ unset peg(pt::grammar::peg)
+
+ # Assemble the rules object
+ set rules {}
+ foreach {symbol def} $peg(rules) {
+ lassign $def _ is _ mode
+ lappend rules $symbol \
+ [json::write object \
+ is [json::write string $is] \
+ mode [json::write string $mode]]
+ }
+
+ # Assemble the final result
+ return [json::write object pt::grammar::peg \
+ [json::write object \
+ rules [json::write object {*}$rules] \
+ start [json::write string $peg(start)]]]
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Configuration
+
+namespace eval ::pt::peg::to::json {
+
+ # Combinations of the format specific entries
+ # I A |
+ # - - + ---------------------
+ # 0 0 | Ultracompact (no whitespace, single line)
+ # 1 0 | Indented
+ # 0 1 | Not possible, per the implications above.
+ # 1 1 | Indented + Tabular aligned keys
+ # - - + ---------------------
+
+ variable indented 0
+ variable aligned 0
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pt::peg::to::json 1
+return
diff --git a/tcllib/modules/pt/pt_peg_to_json.test b/tcllib/modules/pt/pt_peg_to_json.test
new file mode 100644
index 0000000..7f9bcf3
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_json.test
@@ -0,0 +1,40 @@
+# -*- tcl -*-
+# pt_peg_to_json.test: tests for the pt::peg::to::json converter package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_to_json.test,v 1.2 2011/01/14 03:49:54 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+ use json/json_write.tcl json::write
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pegrammar.tcl pt::peg
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_peg_to_json.tcl pt::peg::to::json
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/pt_peg_to_json.tests]
+
+# -------------------------------------------------------------------------
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_to_param.man b/tcllib/modules/pt/pt_peg_to_param.man
new file mode 100644
index 0000000..deec79a
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_param.man
@@ -0,0 +1,7 @@
+[comment {--- doctools ---}]
+[vset PACKAGE param]
+[vset NAME PARAM]
+[vset REQUIRE param]
+[vset CONFIG param]
+[vset VERSION 1]
+[include include/export/to.inc]
diff --git a/tcllib/modules/pt/pt_peg_to_param.tcl b/tcllib/modules/pt/pt_peg_to_param.tcl
new file mode 100644
index 0000000..0ed0179
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_param.tcl
@@ -0,0 +1,1029 @@
+# peg_to_param.tcl --
+#
+# Conversion of PEG to PARAM assembler.
+#
+# Copyright (c) 2009-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pt_peg_to_param.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# This package takes the canonical serialization of a parsing
+# expression grammar and produces text in PARAM assembler, i.e.
+# readable machine code for the PARAM virtual machine.
+
+## NOTE: Should have cheat sheet of PARAM instructions (which parts of
+## the arch state they touch, and secondly, bigger effects).
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require pt::peg ; # Verification that the input
+ # is proper.
+package require pt::pe ; # Walking an expression.
+package require text::write ; # Text generation support
+package require char
+
+# ### ### ### ######### ######### #########
+##
+
+namespace eval ::pt::peg::to::param {
+ namespace export \
+ reset configure convert
+
+ namespace ensemble create
+}
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc ::pt::peg::to::param::reset {} {
+ variable template @code@
+ variable name a_pe_grammar
+ variable file unknown
+ variable user unknown
+ variable inline 1
+ variable compact 1
+ return
+}
+
+proc ::pt::peg::to::param::configure {args} {
+ variable template
+ variable name
+ variable file
+ variable user
+ variable inline
+ variable compact
+
+ if {[llength $args] == 0} {
+ return [list \
+ -inline $inline \
+ -compact $compact \
+ -file $file \
+ -name $name \
+ -template $template \
+ -user $user]
+ } elseif {[llength $args] == 1} {
+ lassign $args option
+ set variable [string range $option 1 end]
+ if {[info exists $variable]} {
+ return [set $variable]
+ } else {
+ return -code error "Expected one of -compact, -file, -inline, -name, -template, or -user, got \"$option\""
+ }
+ } elseif {[llength $args] % 2 == 0} {
+ foreach {option value} $args {
+ set variable [string range $option 1 end]
+ if {![info exists $variable]} {
+ return -code error "Expected one of -compact, -file, -inline, -name, -template, or -user, got \"$option\""
+ }
+ }
+ foreach {option value} $args {
+ set variable [string range $option 1 end]
+ switch -exact -- $variable {
+ template {
+ if {$value eq {}} {
+ return -code error "Expected template, got the empty string"
+ }
+ }
+ inline - compact {
+ if {![::string is boolean -strict $value]} {
+ return -code error "Expected boolean, got \"$value\""
+ }
+ }
+ name -
+ file -
+ user { }
+ }
+ set $variable $value
+ }
+ } else {
+ return -code error {wrong#args, expected option value ...}
+ }
+}
+
+proc ::pt::peg::to::param::convert {serial} {
+ variable template
+ variable name
+ variable file
+ variable user
+
+ Op::Asm::Setup
+
+ ::pt::peg verify-as-canonical $serial
+
+ # Unpack the serialization, known as canonical
+ array set peg $serial
+ array set peg $peg(pt::grammar::peg)
+ unset peg(pt::grammar::peg)
+
+ set modes {}
+ foreach {symbol def} $peg(rules) {
+ lassign $def _ is _ mode
+ lappend modes $symbol $mode
+ }
+
+ text::write reset
+ set blocks {}
+
+ # Translate all expressions/symbols, results are stored in
+ # text::write blocks, command results are the block ids.
+ lappend blocks [set start [Expression $peg(start) $modes]]
+
+ foreach {symbol def} $peg(rules) {
+ lassign $def _ is _ mode
+ lappend blocks [Symbol $symbol $mode $is $modes]
+ }
+
+ # Assemble the output from the stored blocks.
+ text::write clear
+ Op::Asm::Header {Grammar Start Expression}
+ Op::Asm::Label <<MAIN>>
+ Op::Asm::Call $start 0
+ Op::Asm::Ins halt
+ text::write /line
+
+ Op::Asm::Use {*}$blocks
+
+ # At last retrieve the fully assembled result and integrate with
+ # the chosen template.
+
+ return [string map \
+ [list \
+ @user@ $user \
+ @format@ PEG \
+ @file@ $file \
+ @name@ $name \
+ @code@ [text::write get]] $template]
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Internals
+
+proc ::pt::peg::to::param::Expression {expression modes} {
+ return [pt::pe bottomup \
+ [list [namespace current]::Op $modes] \
+ $expression]
+}
+
+proc ::pt::peg::to::param::Symbol {symbol mode rhs modes} {
+
+ set expression [Expression $rhs $modes]
+
+ text::write clear
+ Op::Asm::Header "$mode Symbol '$symbol'"
+ text::write store FUN_HEADER
+
+ Op::Asm::Start
+ Op::Asm::ReExpression $symbol
+ Op::Asm::GenAST $expression
+ Op::Asm::PE $rhs
+
+ set gen [dict get $result gen]
+
+ Op::Asm::Function sym_$symbol {
+
+ # We have six possibilites for the combination of AST node
+ # generation by the rhs and AST generation by the symbol. Two
+ # of these (leaf/0, value/0 coincide, leaving 5). This
+ # controls the use of AS/ARS instructions.
+
+ switch -exact -- $mode/$gen {
+ value/1 {
+ # Generate value for symbol, rhs may have generated
+ # AST nodes as well, keep rhs
+
+ set found [Op::Asm::NewLabel found]
+
+ Op::Asm::Ins symbol_restore $symbol
+ Op::Asm::Ins found! jump $found
+
+ Op::Asm::Ins loc_push
+ Op::Asm::Ins ast_push
+
+ Op::Asm::Call $expression
+
+ Op::Asm::Ins fail! value_clear
+ Op::Asm::Ins ok! value_reduce $symbol
+
+ Op::Asm::Ins symbol_save $symbol
+ Op::Asm::Ins error_nonterminal $symbol
+
+ Op::Asm::Ins ast_pop_rewind
+ Op::Asm::Ins loc_pop_discard
+
+ Op::Asm::Label $found
+ Op::Asm::Ins ok! ast_value_push
+ }
+ leaf/0 -
+ value/0 {
+ # Generate value for symbol, rhs cannot generate its
+ # own AST nodes => leaf/0.
+
+ set found [Op::Asm::NewLabel found]
+
+ Op::Asm::Ins symbol_restore $symbol
+ Op::Asm::Ins found! jump $found
+
+ Op::Asm::Ins loc_push
+
+ Op::Asm::Call $expression
+
+ Op::Asm::Ins fail! value_clear
+ Op::Asm::Ins ok! value_leaf $symbol
+
+ Op::Asm::Ins symbol_save $symbol
+ Op::Asm::Ins error_nonterminal $symbol
+
+ Op::Asm::Ins loc_pop_discard
+
+ Op::Asm::Label $found
+ Op::Asm::Ins ok! ast_value_push
+ }
+ leaf/1 {
+ # Generate value for symbol, rhs may have generated
+ # AST nodes as well, discard rhs.
+
+ set found [Op::Asm::NewLabel found]
+
+ Op::Asm::Ins symbol_restore $symbol
+ Op::Asm::Ins found! jump $found
+
+ Op::Asm::Ins loc_push
+ Op::Asm::Ins ast_push
+
+ Op::Asm::Call $expression
+
+ Op::Asm::Ins fail! value_clear
+ Op::Asm::Ins ok! value_leaf $symbol
+
+ Op::Asm::Ins symbol_save $symbol
+ Op::Asm::Ins error_nonterminal $symbol
+
+ Op::Asm::Ins ast_pop_rewind
+ Op::Asm::Ins loc_pop_discard
+
+ Op::Asm::Label $found
+ Op::Asm::Ins ok! ast_value_push
+ }
+ void/1 {
+ # Generate no value for symbol, rhs may have generated
+ # AST nodes as well, discard rhs.
+
+ Op::Asm::Ins symbol_restore $symbol ; # Implied
+ Op::Asm::Ins found! return
+
+ Op::Asm::Ins loc_push
+ Op::Asm::Ins ast_push
+
+ Op::Asm::Call $expression
+
+ Op::Asm::Ins value_clear
+
+ Op::Asm::Ins symbol_save $symbol
+ Op::Asm::Ins error_nonterminal $symbol
+
+ Op::Asm::Ins ast_pop_rewind
+ Op::Asm::Ins loc_pop_discard
+ }
+ void/0 {
+ # Generate no value for symbol, rhs cannot generate
+ # its own AST nodes. Nothing to save nor discard.
+
+ Op::Asm::Ins symbol_restore $symbol ; # Implied
+ Op::Asm::Ins found! return
+
+ Op::Asm::Ins loc_push
+
+ Op::Asm::Call $expression
+
+ Op::Asm::Ins value_clear
+
+ Op::Asm::Ins symbol_save $symbol
+ Op::Asm::Ins error_nonterminal $symbol
+
+ Op::Asm::Ins loc_pop_discard
+ }
+ }
+ } $expression
+ Op::Asm::Done
+}
+
+namespace eval ::pt::peg::to::param::Op {
+ namespace export \
+ alpha alnum ascii digit graph lower print \
+ punct space upper wordchar xdigit ddigit \
+ dot epsilon t .. n ? * + & ! x /
+}
+
+proc ::pt::peg::to::param::Op {modes pe op arguments} {
+ return [namespace eval Op [list $op $modes {*}$arguments]]
+}
+
+proc ::pt::peg::to::param::Op::epsilon {modes} {
+ Asm::Start
+ Asm::ReExpression epsilon
+ Asm::Direct {
+ Asm::Ins status_ok
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::param::Op::dot {modes} {
+ Asm::Start
+ Asm::ReExpression dot
+ Asm::Direct {
+ Asm::Ins input_next \"dot\"
+ }
+ Asm::Done
+}
+
+foreach test {
+ alpha alnum ascii digit graph lower print
+ punct space upper wordchar xdigit ddigit
+} {
+ proc ::pt::peg::to::param::Op::$test {modes} \
+ [string map [list @ $test] {
+ variable ::pt::peg::to::param::inline
+ Asm::Start
+ Asm::ReExpression @
+ if {$inline} {
+ Asm::Direct {
+ Asm::Ins input_next \"@\"
+ Asm::Ins ok! test_@
+ }
+ } else {
+ Asm::Function [Asm::NewBlock @] {
+ Asm::Ins input_next \"@\"
+ Asm::Ins ok! test_@
+ }
+ }
+ Asm::Done
+ }]
+}
+
+proc ::pt::peg::to::param::Op::t {modes char} {
+ variable ::pt::peg::to::param::inline
+ Asm::Start
+ Asm::ReTerminal t $char
+ if {$inline} {
+ Asm::Direct {
+ set c [char quote string $char]
+
+ Asm::Ins input_next "\"t $c\""
+ Asm::Ins ok! test_char \"$c\"
+ }
+ } else {
+ Asm::Function [Asm::NewBlock char ] {
+ set c [char quote string $char]
+
+ Asm::Ins input_next "\"t $c\""
+ Asm::Ins ok! test_char \"$c\"
+ }
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::param::Op::.. {modes chstart chend} {
+ variable ::pt::peg::to::param::inline
+ Asm::Start
+ Asm::ReTerminal .. $chstart $chend
+ if {$inline} {
+ Asm::Direct {
+ set s [char quote string $chstart]
+ set e [char quote string $chend]
+
+ Asm::Ins input_next "\".. $s $e\""
+ Asm::Ins ok! test_range \"$s\" \"$e\"
+ }
+ } else {
+ Asm::Function [Asm::NewBlock range] {
+ set s [char quote string $chstart]
+ set e [char quote string $chend]
+
+ Asm::Ins input_next "\".. $s $e\""
+ Asm::Ins ok! test_range \"$s\" \"$e\"
+ }
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::param::Op::n {modes symbol} {
+ # symbol mode determines AST generation
+ # void => non-generative,
+ # leaf/value => generative.
+
+ Asm::Start
+ Asm::ReTerminal n $symbol
+
+ if {![dict exists $modes $symbol]} {
+ # Incomplete grammar. The symbol has no definition.
+ Asm::Direct {
+ Asm::Ins status_fail {} "; # Undefined symbol '$symbol'"
+ }
+ } else {
+ Asm::GenAST [list gen [expr { [dict get $modes $symbol] ne "void" }]]
+ Asm::Direct {
+ Asm::Ins call sym_$symbol
+ }
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::param::Op::& {modes expression} {
+ # Note: This operation could be inlined, as it has no special
+ # control flow. Not done to make the higher-level ops are
+ # similar in construction and use = consistent and simple.
+
+ Asm::Start
+ Asm::ReExpression & $expression
+ Asm::GenAST $expression
+
+ Asm::Function [Asm::NewBlock ahead] {
+ Asm::Ins loc_push
+ Asm::Call $expression
+ Asm::Ins loc_pop_rewind
+ } $expression
+ Asm::Done
+}
+
+proc ::pt::peg::to::param::Op::! {modes expression} {
+ # Note: This operation could be inlined, as it has no special
+ # control flow. Not done to make the higher-level ops are
+ # similar in construction and use = consistent and simple.
+
+ Asm::Start
+ Asm::ReExpression ! $expression
+ if {[dict get $expression gen]} {
+ Asm::Function [Asm::NewBlock notahead] {
+ # The sub-expression may generate AST elements. We must
+ # not pass them through.
+
+ Asm::Ins loc_push
+ Asm::Ins ast_push
+
+ Asm::Call $expression
+
+ Asm::Ins fail! ast_pop_discard
+ Asm::Ins ok! ast_pop_rewind
+ Asm::Ins loc_pop_rewind
+ Asm::Ins status_negate
+ } $expression
+ } else {
+ Asm::Function [Asm::NewBlock notahead] {
+ # The sub-expression cannot generate AST elements. We can
+ # ignore AS/ARS, simplifying the code.
+
+ Asm::Ins loc_push
+
+ Asm::Call $expression
+
+ Asm::Ins loc_pop_rewind
+ Asm::Ins status_negate
+ } $expression
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::param::Op::? {modes expression} {
+ # Note: This operation could be inlined, as it has no special
+ # control flow. Not done to make the higher-level ops are
+ # similar in construction and use => consistent and simple.
+
+ Asm::Start
+ Asm::ReExpression ? $expression
+ Asm::GenAST $expression
+
+ Asm::Function [Asm::NewBlock optional] {
+ Asm::Ins loc_push
+ Asm::Ins error_push
+
+ Asm::Call $expression
+
+ Asm::Ins error_pop_merge
+ Asm::Ins fail! loc_pop_rewind
+ Asm::Ins ok! loc_pop_discard
+ Asm::Ins status_ok
+ } $expression
+ Asm::Done
+}
+
+proc ::pt::peg::to::param::Op::* {modes expression} {
+ Asm::Start
+ Asm::ReExpression * $expression
+ Asm::GenAST $expression
+
+ Asm::Function [Asm::NewBlock kleene] {
+ set failed [Asm::NewLabel failed]
+
+ Asm::Ins loc_push
+ Asm::Ins error_push
+
+ Asm::Call $expression
+
+ Asm::Ins error_pop_merge
+ Asm::Ins fail! jump $failed
+ Asm::Ins loc_pop_discard
+ Asm::Ins jump [Asm::LastId] ; # Loop head = Function head.
+
+ # FAILED, clean up and return OK.
+ Asm::Label $failed
+ Asm::Ins loc_pop_rewind
+ Asm::Ins status_ok
+ } $expression
+ Asm::Done
+}
+
+proc ::pt::peg::to::param::Op::+ {modes expression} {
+ Asm::Start
+ Asm::ReExpression + $expression
+ Asm::GenAST $expression
+
+ Asm::Function [Asm::NewBlock poskleene] {
+ set failed [Asm::NewLabel failed]
+ set loophead [Asm::NewLabel loop]
+
+ Asm::Ins loc_push
+
+ Asm::Call $expression
+
+ # FAILED truly.
+ Asm::Ins fail! jump $failed
+
+ Asm::Label $loophead
+ Asm::Ins loc_pop_discard
+ Asm::Ins loc_push
+ Asm::Ins error_push
+
+ Asm::Call $expression
+
+ Asm::Ins error_pop_merge
+ Asm::Ins ok! jump $loophead
+ # FAILED, clean up and return OK.
+ Asm::Ins status_ok
+
+ Asm::Label $failed
+ Asm::Ins loc_pop_rewind
+ } $expression
+ Asm::Done
+}
+
+proc ::pt::peg::to::param::Op::x {modes args} {
+ if {[llength $args] == 1} {
+ return [lindex $args 0]
+ }
+
+ Asm::Start
+ Asm::ReExpression x {*}$args
+ set gens [Asm::GenAST {*}$args]
+
+ # We have three possibilities regarding AST node generation, each
+ # requiring a slightly different instruction sequence.
+
+ # i. gen == 0 <=> No node generation at all.
+ # ii. gens[0] == 1 <=> We may have nodes from the beginning.
+ # iii. <=> Node generation starts in the middle.
+
+ if {![dict get $result gen]} {
+ set mode none
+ } elseif {[lindex $gens 0]} {
+ set mode all
+ } else {
+ set mode some
+ }
+
+ Asm::Function [Asm::NewBlock sequence] {
+
+ set failed [Asm::NewLabel failed]
+ if {$mode eq "some"} {
+ set failed_noast [Asm::NewLabel failednoast]
+ }
+
+ switch -exact -- $mode {
+ none {
+ # (Ad i) No AST node generation at all.
+
+ Asm::Ins loc_push
+ Asm::Ins error_clear
+ text::write /line
+
+ # Note: This loop runs at code generation time. At
+ # runtime the entire construction is essentially a
+ # fully unrolled loop, with each iteration having its
+ # own block of instructions.
+
+ foreach expression $args {
+ Asm::Ins error_push
+
+ Asm::Call $expression
+
+ Asm::Ins error_pop_merge
+ # Stop the sequence on element failure
+ Asm::Ins fail! jump $failed
+ }
+
+ # All elements OK, squash backtracking state
+ text::write /line
+ Asm::Ins loc_pop_discard
+ Asm::Ins return
+
+ # An element failed, restore state to before we tried
+ # the sequence.
+ Asm::Label $failed
+ Asm::Ins loc_pop_rewind
+ }
+ all {
+ # (Ad ii) AST node generation from start to end.
+
+ Asm::Ins ast_push
+ Asm::Ins loc_push
+ Asm::Ins error_clear
+ text::write /line
+
+ # Note: This loop runs at code generation time. At
+ # runtime the entire construction is essentially a
+ # fully unrolled loop, with each iteration having its
+ # own block of instructions.
+
+ foreach expression $args {
+ Asm::Ins error_push
+
+ Asm::Call $expression
+
+ Asm::Ins error_pop_merge
+ # Stop the sequence on element failure
+ Asm::Ins fail! jump $failed
+ }
+
+ # All elements OK, squash backtracking state
+ text::write /line
+ Asm::Ins ast_pop_discard
+ Asm::Ins loc_pop_discard
+ Asm::Ins return
+
+ # An element failed, restore state to before we tried
+ # the sequence.
+ Asm::Label $failed
+ Asm::Ins ast_pop_rewind
+ Asm::Ins loc_pop_rewind
+ }
+ some {
+ # (Ad iii). Start without AST nodes, later parts do
+ # AST nodes.
+
+ Asm::Ins loc_push
+ Asm::Ins error_clear
+ text::write /line
+
+ # Note: This loop runs at code generation time. At
+ # runtime the entire construction is essentially a
+ # fully unrolled loop, with each iteration having its
+ # own block of instructions.
+
+ set pushed 0
+ foreach expression $args xgen $gens {
+ if {!$pushed && $xgen} {
+ Asm::Ins ast_push
+ set pushed 1
+ }
+
+ Asm::Ins error_push
+
+ Asm::Call $expression
+
+ Asm::Ins error_pop_merge
+ # Stop the sequence on element failure
+ if {$pushed} {
+ Asm::Ins fail! jump $failed
+ } else {
+ Asm::Ins fail! jump $failed_noast
+ }
+ }
+
+ # All elements OK, squash backtracking state.
+ text::write /line
+ Asm::Ins ast_pop_discard
+ Asm::Ins loc_pop_discard
+ Asm::Ins return
+
+ # An element failed, restore state to before we tried
+ # the sequence.
+ Asm::Label $failed
+ Asm::Ins ast_pop_rewind
+ Asm::Label $failed_noast
+ Asm::Ins loc_pop_rewind
+ }
+ }
+ } {*}$args
+ Asm::Done
+}
+
+proc ::pt::peg::to::param::Op::/ {modes args} {
+ if {[llength $args] == 1} {
+ return [lindex $args 0]
+ }
+
+ Asm::Start
+ Asm::ReExpression / {*}$args
+ set gens [Asm::GenAST {*}$args]
+
+ if {![dict get $result genmin]} {
+ # We have at least one branch without AST node generation.
+ set ok_noast [Asm::NewLabel oknoast]
+ } else {
+ set ok_noast {}
+ }
+ if {[dict get $result gen]} {
+ # We have at least one branch capable of generating AST nodes.
+ set ok [Asm::NewLabel ok]
+ } else {
+ set ok {}
+ }
+
+ # Optimized AST handling: Handle each branch separately, based on
+ # its ability to generate AST nodes.
+
+ Asm::Function [Asm::NewBlock choice] {
+ Asm::Ins error_clear
+ text::write /line
+
+ # Note: This loop runs at code generation time. At runtime the
+ # entire construction is seentially a fully unrolled loop,
+ # with each iteration having its own block of instructions.
+
+ foreach expression $args xgen $gens {
+ if {$xgen} {
+ Asm::Ins ast_push
+ }
+ Asm::Ins loc_push
+ Asm::Ins error_push
+
+ Asm::Call $expression
+
+ Asm::Ins error_pop_merge
+ if {$xgen} {
+ Asm::Ins ok! jump $ok
+ } else {
+ Asm::Ins ok! jump $ok_noast
+ }
+ text::write /line
+ if {$xgen} {
+ Asm::Ins ast_pop_rewind
+ }
+ Asm::Ins loc_pop_rewind
+ }
+
+ # All branches FAILED
+ Asm::Ins status_fail
+ Asm::Ins return
+
+ # A branch was successful, squash the backtracking state
+ if {$ok ne {}} {
+ Asm::Label $ok
+ Asm::Ins ast_pop_discard
+ }
+ if {$ok_noast ne {}} {
+ Asm::Label $ok_noast
+ }
+ Asm::Ins loc_pop_discard
+ } {*}$args
+ Asm::Done
+}
+
+# ### ### ### ######### ######### #########
+## Allocate a text block / internal symbol / function
+
+namespace eval ::pt::peg::to::param::Op::Asm {}
+
+proc ::pt::peg::to::param::Op::Asm::Start {} {
+ upvar 1 result result
+ set result {def {} use {} gen 0 pe {}}
+ return
+}
+
+proc ::pt::peg::to::param::Op::Asm::Done {} {
+ upvar 1 result result
+ return -code return $result
+ return
+}
+
+proc ::pt::peg::to::param::Op::Asm::ReExpression {op args} {
+ upvar 1 result result
+
+ set pe $op
+ foreach a $args {
+ lappend pe [dict get $a pe]
+ }
+
+ dict set result pe $pe
+ PE $pe
+ return
+}
+
+proc ::pt::peg::to::param::Op::Asm::ReTerminal {op args} {
+ upvar 1 result result
+
+ set pe [linsert $args 0 $op]
+ dict set result pe $pe
+ PE $pe
+ return
+}
+
+proc ::pt::peg::to::param::Op::Asm::GenAST {args} {
+ upvar 1 result result
+
+ foreach a $args {
+ lappend flags [dict get $a gen]
+ }
+
+ dict set result gen [tcl::mathfunc::max {*}$flags]
+ dict set result genmin [tcl::mathfunc::min {*}$flags]
+ return $flags
+}
+
+proc ::pt::peg::to::param::Op::Asm::NewBlock {type} {
+ variable counter
+ variable lastid ${type}_[incr counter]
+ return $lastid
+}
+
+proc ::pt::peg::to::param::Op::Asm::NewLabel {{prefix {label}}} {
+ variable counter
+ return ${prefix}_[incr counter]
+}
+
+proc ::pt::peg::to::param::Op::Asm::Function {name def args} {
+ upvar 1 result result
+ variable ::pt::peg::to::param::compact
+ variable cache
+
+ set k [list [dict get $result gen] [dict get $result pe]]
+
+#puts $name///<<$k>>==[info exists cache($k)]\t\t($result)
+
+ if {$compact && [info exists cache($k)]} {
+ dict set result def {}
+ dict set result use $cache($k)
+ return
+ }
+
+ text::write clear
+ if {[text::write exists FUN_HEADER]} {
+ text::write recall FUN_HEADER
+ text::write undef FUN_HEADER
+ }
+
+ Label $name
+ text::write recall PE ; # Generated in Asm::Zip, printed rep
+ text::write undef PE ; # of the expression, for code clarity
+
+ uplevel 1 $def
+ Ins return
+
+ if {[llength $args]} {
+ Use {*}$args
+ }
+
+ text::write store $name
+
+ set useb [NewBlock anon]
+ text::write clear
+ Ins call $name
+ text::write store $useb
+
+ dict set result def $name
+ dict set result use $useb
+
+ set cache($k) $useb
+ return
+}
+
+proc ::pt::peg::to::param::Op::Asm::Direct {use} {
+ upvar 1 result result
+
+ set useb [NewBlock anon]
+ text::write clear
+ uplevel 1 $use
+ text::write store $useb
+
+ dict set result def {}
+ dict set result use $useb
+ return
+}
+
+proc ::pt::peg::to::param::Op::Asm::Call {expr {distance 1}} {
+ if {$distance} { text::write /line }
+ text::write recall [dict get $expr use]
+ if {$distance} { text::write /line }
+ return
+}
+
+proc ::pt::peg::to::param::Op::Asm::Use {args} {
+ foreach item $args {
+ set def [dict get $item def]
+ if {$def eq {}} continue
+ text::write recall $def
+ text::write undef $def
+ }
+ return
+}
+
+proc ::pt::peg::to::param::Op::Asm::Ins {args} {
+ variable fieldlen
+
+ if {[string match *! [lindex $args 0]]} {
+ set args [lassign $args guard]
+ text::write fieldr 8 $guard
+ } else {
+ text::write fieldr 8 {}
+ }
+ foreach w $args len $fieldlen {
+ text::write fieldl $len $w
+ }
+ text::write /line
+ return
+}
+
+proc ::pt::peg::to::param::Op::Asm::Label {label} {
+ text::write /line
+ text::write field ${label}:
+ text::write /line
+ return
+}
+
+proc ::pt::peg::to::param::Op::Asm::LastId {} {
+ variable lastid
+ return $lastid
+}
+
+proc ::pt::peg::to::param::Op::Asm::Header {text} {
+ text::write field "#"
+ text::write /line
+ text::write field "# $text"
+ text::write /line
+ text::write field "#"
+ text::write /line
+ #text::write /line
+ return
+}
+
+proc ::pt::peg::to::param::Op::Asm::PE {pe} {
+ text::write clear
+ text::write field [pt::pe print $pe]
+ text::write /line
+ text::write prefix "# "
+ text::write /line
+ text::write store PE
+ return
+}
+
+proc ::pt::peg::to::param::Op::Asm::Setup {} {
+ variable counter 0
+ variable fieldlen {17 5 5}
+ variable cache
+ array unset cache *
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Configuration
+
+namespace eval ::pt::peg::to::param {
+ namespace eval ::pt::peg::to::param::Op::Asm {
+ variable counter 0
+ variable fieldlen {17 5 5}
+ variable cache
+ array set cache {}
+ }
+
+ variable inline 1 ; # A boolean flag. Specifies if we
+ # should inline terminal tests
+ # (default), or put them into
+ # their own functions.
+ variable compact 1 ; # A boolean flag. Specifies if we
+ # should try to coalesce
+ # identical parsing expressions,
+ # i.e. compile them once
+ # (default), or not.
+ variable template @code@ ; # A string. Specifies how to
+ # embed the generated code into a
+ # larger frame- work (the
+ # template).
+ variable name a_pe_grammar ; # String. Name of the grammar.
+ variable file unknown ; # String. Name of the file or
+ # other entity the grammar came
+ # from.
+ variable user unknown ; # String. Name of the user on
+ # which behalf the conversion has
+ # been invoked.
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pt::peg::to::param 1.0.1
+return
diff --git a/tcllib/modules/pt/pt_peg_to_param.test b/tcllib/modules/pt/pt_peg_to_param.test
new file mode 100644
index 0000000..da102de
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_param.test
@@ -0,0 +1,41 @@
+# -*- tcl -*-
+# pt_peg_to_param.test: tests for the pt::peg::to::param converter package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_to_param.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal text_write.tcl text::write
+ useLocal char.tcl char
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_peg_to_param.tcl pt::peg::to::param
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/pt_peg_to_param.tests]
+
+# -------------------------------------------------------------------------
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_to_peg.man b/tcllib/modules/pt/pt_peg_to_peg.man
new file mode 100644
index 0000000..f6ea24e
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_peg.man
@@ -0,0 +1,7 @@
+[comment {--- doctools ---}]
+[vset PACKAGE peg]
+[vset NAME PEG]
+[vset REQUIRE peg]
+[vset CONFIG peg]
+[vset VERSION 1.0.2]
+[include include/export/to.inc]
diff --git a/tcllib/modules/pt/pt_peg_to_peg.tcl b/tcllib/modules/pt/pt_peg_to_peg.tcl
new file mode 100644
index 0000000..9622b57
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_peg.tcl
@@ -0,0 +1,413 @@
+# peg_to_peg.tcl --
+#
+# Conversion from PEG to PEG (Human readable text).
+#
+# Copyright (c) 2009-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pt_peg_to_peg.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# This package takes the canonical serialization of a parsing
+# expression grammar and produces text in PEG format, a form of text
+# which specifies a PEG in a human readable, yet formal manner,
+# similar too, but not identical to EBNF.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require pt::peg ; # Verification that the input
+ # is proper.
+package require pt::pe ; # Walking an expression.
+package require pt::pe::op ; # Flatten & fuse.
+package require text::write ; # Text generation support
+package require textutil::adjust
+package require struct::list
+
+# ### ### ### ######### ######### #########
+##
+
+namespace eval ::pt::peg::to::peg {
+ namespace export \
+ reset configure convert
+
+ namespace ensemble create
+}
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc ::pt::peg::to::peg::reset {} {
+ variable template @code@
+ variable name a_pe_grammar
+ variable file unknown
+ variable user unknown
+ variable fused 1
+ return
+}
+
+proc ::pt::peg::to::peg::configure {args} {
+ variable template
+ variable name
+ variable file
+ variable user
+ variable fused
+
+ if {[llength $args] == 0} {
+ return [list \
+ -file $file \
+ -fused $fused \
+ -name $name \
+ -template $template \
+ -user $user]
+ } elseif {[llength $args] == 1} {
+ lassign $args option
+ set variable [string range $option 1 end]
+ if {[info exists $variable]} {
+ return [set $variable]
+ } else {
+ return -code error "Expected one of -file, -fused, -name, -template, or -user, got \"$option\""
+ }
+ } elseif {[llength $args] % 2 == 0} {
+ foreach {option value} $args {
+ set variable [string range $option 1 end]
+ if {![info exists $variable]} {
+ return -code error "Expected one of -file, -fused, -name, -template, or -user, got \"$option\""
+ }
+ }
+ foreach {option value} $args {
+ set variable [string range $option 1 end]
+ switch -exact -- $variable {
+ template {
+ if {$value eq {}} {
+ return -code error "Expected template, got the empty string"
+ }
+ }
+ fused {
+ if {![::string is boolean -strict $value]} {
+ return -code error "Expected boolean, got \"$value\""
+ }
+ }
+ name -
+ file -
+ user { }
+ }
+ set $variable $value
+ }
+ } else {
+ return -code error {wrong#args, expected option value ...}
+ }
+}
+
+proc ::pt::peg::to::peg::convert {serial} {
+ variable template
+ variable name
+ variable file
+ variable user
+
+ ::pt::peg verify-as-canonical $serial
+
+ # Unpack the serialization, known as canonical
+ array set peg $serial
+ array set peg $peg(pt::grammar::peg)
+ unset peg(pt::grammar::peg)
+
+ # Determine the field sizes for nonterminal symbol names and
+ # semantic modes.
+
+ set smax [text::write maxlen [dict keys $peg(rules)]]
+ set mmax [ModeSize $peg(rules)]
+
+ # Assemble the output, various pieces
+ text::write reset
+ Header $peg(start)
+ Rules $peg(rules) $mmax $smax
+ Trailer
+
+ # At last retrieve the fully assembled result and integrate with
+ # the chosen template.
+ return [string map \
+ [list \
+ @user@ $user \
+ @format@ PEG \
+ @file@ $file \
+ @name@ $name \
+ @code@ [text::write get]] $template]
+
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Internals
+
+proc ::pt::peg::to::peg::Header {startexpression} {
+ variable name
+
+ text::write field PEG
+ text::write field $name
+ text::write field ([Expression $startexpression])
+ text::write /line
+ return
+}
+
+proc ::pt::peg::to::peg::Rules {rules mmax smax} {
+ if {[llength $rules]} { text::write /line }
+
+ foreach {symbol def} $rules {
+ lassign $def _ is _ mode
+ set mode [expr {($mode eq "value")
+ ? ""
+ : "${mode}:"}]
+
+ text::write fieldl $mmax $mode
+ text::write fieldl $smax $symbol
+ text::write field "<-"
+ text::write field [Expression $is]
+ text::write field ";"
+ text::write /line
+ }
+
+ if {[llength $rules]} { text::write /line }
+ return
+}
+
+proc ::pt::peg::to::peg::Trailer {} {
+ text::write field {END;}
+ text::write /line
+ return
+}
+
+# ### ### ### ######### ######### #########
+
+proc ::pt::peg::to::peg::Expression {pe} {
+ variable fused
+
+ if {$fused} {
+ # First flatten for a maximum amount of adjacent terminals and
+ # ranges, then fuse these into strings and classes, then
+ # flatten again, eliminating all sequences and choices fully
+ # subsumed by the new elements.
+
+ set pe [pt::pe::op flatten \
+ [pt::pe::op fusechars \
+ [pt::pe::op flatten \
+ $pe]]]
+ }
+
+ return [lindex [pt::pe bottomup \
+ [namespace current]::Convert \
+ $pe] 0]
+}
+
+proc ::pt::peg::to::peg::Convert {pe operator arguments} {
+ # For the inner nodes the each of arguments are a pair of
+ # generated text, and the sub-expression it came from, in this
+ # order.
+
+ switch -exact -- $operator {
+ alpha - alnum - ascii - control - digit - graph - lower - print -
+ punct - space - upper - wordchar - xdigit - ddigit {
+ # Special forms ...
+ return [list <$operator> $pe]
+ }
+ dot {
+ # Special form ...
+ return [list "." $pe]
+ }
+ epsilon {
+ # Special form, represented by the empty string ...
+ return [list "''" $pe]
+ }
+ t {
+ # Character ...
+ lassign $arguments char
+ return [list "'[Char ${char}]'" $pe]
+ }
+ .. {
+ # Range of characters ... Show as character class.
+ # Note: Canonical input means that an expression like
+ # {.. X X} cannot occur, and can be ignored.
+
+ lassign $arguments chstart chend
+ return [list "\[[Char ${chstart}]-[Char $chend]\]" $pe]
+ }
+ n {
+ # Nonterminal symbol
+ lassign $arguments symbol
+ return [list $symbol $pe]
+ }
+ ? - * - + {
+ # Suffix operators (Option, Kleene Closure, Positive KC) ...
+ lassign $arguments child
+ lassign $child text def
+ lassign $def coperator
+ return [list [MayParens $operator $coperator $text]$operator $pe]
+ }
+ & -
+ ! {
+ # Prefix operators (And/Not Lookahead) ...
+ lassign $arguments child
+ lassign $child text def
+ lassign $def coperator
+ return [list $operator[MayParens $operator $coperator $text] $pe]
+ }
+ x {
+ # Sequences ...
+ # TODO :: merge adjacent chars into strings ... also, cut
+ # x out if only one child
+
+ set t {}
+ set x {}
+ foreach a $arguments {
+ lassign $a text def
+ lassign $def coperator
+ lappend t [MayParens $operator $coperator $text]
+ lappend x $def
+ }
+ return [list [join $t { }] [list x {*}$x]]
+ }
+ / {
+ # Choices ...
+ # TODO :: merge adjacent chars and ranges into classes ...
+ # also, cut / out if only one child
+
+ set t {}
+ set x {}
+ foreach a $arguments {
+ lassign $a text def
+ lassign $def coperator
+ lappend t [MayParens $operator $coperator $text]
+ lappend x $def
+ }
+ return [list [join $t { / }] [list / {*}$x]]
+ }
+ str {
+ return [list \
+ '[join [struct::list map $arguments \
+ [namespace current]::Char] {}]' \
+ $pe]
+ }
+ cl {
+ return [list \
+ \[[join [struct::list map $arguments \
+ [namespace current]::Range] {}]\] \
+ $pe]
+ }
+ }
+}
+
+proc ::pt::peg::to::peg::Range {range} {
+ # See also pt::peg::to::tclparam
+
+ # Use string ops here to distinguish terminals and ranges. The
+ # input can be a single char, not a list, and further the char may
+ # not be a proper list. Example: double-apostroph.
+ if {[string length $range] > 1} {
+ lassign $range s e
+ return [Char $s]-[Char $e]
+ } else {
+ return [Char $range]
+ }
+}
+
+proc ::pt::peg::to::peg::Char {ch} {
+ # Encode a character, handle special cases. We cannot use package
+ # char, as that is geared towards character encoding for Tcl code.
+
+ switch -exact -- $ch {
+ "\n" { return "\\n" }
+ "\r" { return "\\r" }
+ "\t" { return "\\t" }
+ "\\" { return "\\\\" }
+ "\"" { return "\\\"" }
+ "'" { return "\\'" }
+ "\]" { return "\\\]" }
+ "\[" { return "\\\[" }
+ }
+
+ scan $ch %c chcode
+
+ # Control characters: Octal
+ if {[::string is control -strict $ch]} {
+ return \\[format %o $chcode]
+ }
+
+ # Beyond 7-bit ASCII: Unicode
+
+ if {$chcode > 127} {
+ return \\u[format %04x $chcode]
+ }
+
+ # Regular character: Is its own representation.
+
+ return $ch
+
+}
+
+proc ::pt::peg::to::peg::MayParens {op cop text} {
+ if {![NeedParens $op $cop]} { return $text }
+ return "([::textutil::adjust::indent $text " " 1])"
+}
+
+proc ::pt::peg::to::peg::NeedParens {op cop} {
+ variable priority
+ # c(hild)op is nested under op.
+ # Parens are required if cop has a lower priority than op.
+
+ return [expr {$priority($cop) < $priority($op)}]
+}
+
+# ### ### ### ######### ######### #########
+
+proc ::pt::peg::to::peg::ModeSize {rules} {
+ set modes {}
+ foreach {symbol def} $rules {
+ lassign $def _ is _ mode
+ if {$mode eq "value"} continue ; # These are not shown in the
+ # text representation, as
+ # they are the implicit
+ # default for it.
+ lappend modes ${mode}:
+ }
+ return [text::write maxlen [lsort -uniq $modes]]
+}
+
+# ### ### ### ######### ######### #########
+## Configuration
+
+namespace eval ::pt::peg::to::peg {
+
+ variable template @code@ ; # A string. Specifies how to
+ # embed the generated code into a
+ # larger frame- work (the
+ # template).
+ variable name a_pe_grammar ; # String. Name of the grammar.
+ variable file unknown ; # String. Name of the file or
+ # other entity the grammar came
+ # from.
+ variable user unknown ; # String. Name of the user on
+ # which behalf the conversion has
+ # been invoked.
+ variable fused 1 ; # Boolean flag. If true character
+ # sequences and choices are fused
+ # into strings and classes.
+
+ variable priority
+ array set priority {
+ / 0 t 4 ascii 4 upper 4
+ x 1 n 4 digit 4 wordchar 4
+ & 2 .. 4 graph 4 xdigit 4
+ ! 2 dot 4 lower 4 ddigit 4
+ + 3 epsilon 4 print 4 str 4
+ * 3 alnum 4 punct 4 cl 4
+ ? 3 alpha 4 space 4 control 4
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pt::peg::to::peg 1.0.2
+return
diff --git a/tcllib/modules/pt/pt_peg_to_peg.test b/tcllib/modules/pt/pt_peg_to_peg.test
new file mode 100644
index 0000000..c549ff5
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_peg.test
@@ -0,0 +1,48 @@
+# -*- tcl -*-
+# pt_peg_to_peg.test: tests for the pt::peg::to::peg converter package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_to_peg.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pexpr_op.tcl pt::pe::op
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal text_write.tcl text::write
+ useLocal char.tcl char
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_peg_to_peg.tcl pt::peg::to::peg
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::set setimpl {
+ source [localPath tests/pt_peg_to_peg.tests]
+}
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_peg_to_tclparam.man b/tcllib/modules/pt/pt_peg_to_tclparam.man
new file mode 100644
index 0000000..b47ab8a
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_tclparam.man
@@ -0,0 +1,7 @@
+[comment {--- doctools ---}]
+[vset PACKAGE tclparam]
+[vset NAME TCLPARAM]
+[vset REQUIRE tclparam]
+[vset CONFIG tclparam]
+[vset VERSION 1.0.3]
+[include include/export/to.inc]
diff --git a/tcllib/modules/pt/pt_peg_to_tclparam.tcl b/tcllib/modules/pt/pt_peg_to_tclparam.tcl
new file mode 100644
index 0000000..21bbd30
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_tclparam.tcl
@@ -0,0 +1,1273 @@
+# peg_to_param.tcl --
+#
+# Conversion of PEG to Tcl/C PARAM, customizable text blocks.
+#
+# Copyright (c) 2009-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: pt_peg_to_tclparam.tcl,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# This package takes the canonical serialization of a parsing
+# expression grammar and produces text in PARAM assembler, i.e.
+# readable machine code for the PARAM virtual machine.
+
+## NOTE: Should have cheat sheet of PARAM instructions (which parts of
+## the arch state they touch, and secondly, bigger effects).
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require pt::peg ; # Verification that the input
+ # is proper.
+package require pt::pe ; # Walking an expression.
+package require pt::pe::op ; # String/Class fusing
+package require text::write ; # Text generation support
+package require char
+
+# ### ### ### ######### ######### #########
+##
+
+namespace eval ::pt::peg::to::tclparam {
+ namespace export \
+ reset configure convert
+
+ namespace ensemble create
+}
+
+# ### ### ### ######### ######### #########
+## API.
+
+proc ::pt::peg::to::tclparam::reset {} {
+ variable template @code@
+ variable name a_pe_grammar
+ variable file unknown
+ variable user unknown
+ variable self {}
+ variable ns ::
+ variable runtime {}
+ variable def proc
+ variable main __main
+ variable indent 0
+ variable prelude {}
+ return
+}
+
+proc ::pt::peg::to::tclparam::configure {args} {
+ variable template
+ variable name
+ variable file
+ variable user
+ variable self
+ variable ns
+ variable runtime
+ variable def
+ variable main
+ variable omap
+ variable indent
+ variable prelude
+
+ if {[llength $args] == 0} {
+ return [list \
+ -indent $indent \
+ -runtime-command $runtime \
+ -self-command $self \
+ -proc-command $def \
+ -namespace $ns \
+ -main $main \
+ -file $file \
+ -name $name \
+ -template $template \
+ -user $user]
+ } elseif {[llength $args] == 1} {
+ lassign $args option
+ set variable [string range $option 1 end]
+ if {[info exists omap($variable)]} {
+ return [set $omap($variable)]
+ } else {
+ return -code error "Expected one of -indent, -runtime-command, -proc-command, -self-command, -namespace, -main, -file, -name, -template, or -user, got \"$option\""
+ }
+ } elseif {[llength $args] % 2 == 0} {
+ foreach {option value} $args {
+ set variable [string range $option 1 end]
+ if {![info exists omap($variable)]} {
+ return -code error "Expected one of -indent, -runtime-command, -proc-command, -self-command, -namespace, -main, -file, -name, -template, or -user, got \"$option\""
+ }
+ }
+ foreach {option value} $args {
+ set variable $omap([string range $option 1 end])
+ switch -exact -- $variable {
+ template {
+ if {$value eq {}} {
+ return -code error "Expected template, got the empty string"
+ }
+ }
+ indent {
+ if {![string is integer -strict $value] || ($value < 0)} {
+ return -code error "Expected int > 0, got \"$value\""
+ }
+ }
+ runtime -
+ self -
+ def -
+ ns -
+ main -
+ name -
+ file -
+ user { }
+ }
+ set $variable $value
+ }
+ } else {
+ return -code error {wrong#args, expected option value ...}
+ }
+}
+
+proc ::pt::peg::to::tclparam::convert {serial} {
+ variable template
+ variable name
+ variable file
+ variable user
+ variable self
+ variable ns
+ variable runtime
+ variable def
+ variable main
+ variable indent
+ variable prelude
+
+ Op::Asm::Setup
+
+ ::pt::peg verify-as-canonical $serial
+
+ # Unpack the serialization, known as canonical
+ array set peg $serial
+ array set peg $peg(pt::grammar::peg)
+ unset peg(pt::grammar::peg)
+
+ set modes {}
+ foreach {symbol symdef} $peg(rules) {
+ lassign $symdef _ is _ mode
+ lappend modes $symbol $mode
+ }
+
+ text::write reset
+ set blocks {}
+
+ # Translate all expressions/symbols, results are stored in
+ # text::write blocks, command results are the block ids.
+
+ set start [pt::pe::op flatten \
+ [pt::pe::op fusechars \
+ [pt::pe::op flatten \
+ $peg(start)]]]
+
+ lappend blocks [set start [Expression $start $modes]]
+
+ foreach {symbol symdef} $peg(rules) {
+ lassign $symdef _ is _ mode
+ set is [pt::pe::op flatten \
+ [pt::pe::op fusechars \
+ [pt::pe::op flatten \
+ $is]]]
+ lappend blocks [Symbol $symbol $mode $is $modes]
+ }
+
+ # Assemble the output from the stored blocks.
+ text::write clear
+ Op::Asm::Header {Grammar Start Expression}
+ Op::Asm::FunStart @main@
+ Op::Asm::Call $start 0
+ Op::Asm::Tcl return
+ Op::Asm::FunClose
+
+ foreach b $blocks {
+ Op::Asm::Use $b
+ text::write /line
+ }
+
+ # At last retrieve the fully assembled result and integrate with
+ # the chosen template.
+
+ set code [text::write get]
+ if {$indent} {
+ set code [Indent $code $indent]
+ }
+
+ set pre $prelude ; if {$pre ne {}} { set pre " $pre" }
+ set run $runtime ; if {$run ne {}} { append run { } }
+ set slf $self ; if {$slf ne {}} { append slf { } }
+
+ set code [string map \
+ [list \
+ @user@ $user \
+ @format@ Tcl/PARAM \
+ @file@ $file \
+ @name@ $name \
+ @code@ $code] $template]
+ set code [string map \
+ [list \
+ {@runtime@ } $run \
+ { @prelude@} $pre \
+ {@self@ } $slf \
+ @def@ $def \
+ @ns@ $ns \
+ @main@ $main] $code]
+
+ return $code
+ # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Internals
+
+proc ::pt::peg::to::tclparam::Indent {text n} {
+ set b [string repeat { } $n]
+ return $b[join [split $text \n] \n$b]
+}
+
+proc ::pt::peg::to::tclparam::Expression {expression modes} {
+ # We first flatten for a maximum amount of adjacent terminals and
+ # ranges, then fuse these into strings and classes, then flatten
+ # again, eliminating all sequences and choices fully subsumed by
+ # the new elements.
+
+ return [pt::pe bottomup \
+ [list [namespace current]::Op $modes] \
+ $expression]
+}
+
+proc ::pt::peg::to::tclparam::Symbol {symbol mode rhs modes} {
+
+ set expression [Expression $rhs $modes]
+
+ text::write clear
+ Op::Asm::Header "$mode Symbol '$symbol'"
+ text::write store FUN_HEADER
+
+ Op::Asm::Start
+ Op::Asm::ReExpression $symbol
+ Op::Asm::GenAST $expression
+ Op::Asm::PE $rhs
+
+ set gen [dict get $result gen]
+
+ Op::Asm::Function sym_$symbol {
+
+ # We have six possibilites for the combination of AST node
+ # generation by the rhs and AST generation by the symbol. Two
+ # of these (leaf/0, value/0 coincide, leaving 5). This
+ # controls the use of AS/ARS instructions.
+
+ switch -exact -- $mode/$gen {
+ value/1 {
+ # Generate value for symbol, rhs may have generated
+ # AST nodes as well, keep rhs
+
+ #Op::Asm::Tcl if \{!\[@runtime@ i_symbol_restore $symbol\]\} \{
+ #Op::Asm::>>> 4
+ #Op::Asm::Ins i_loc_push
+ #Op::Asm::Ins i_ast_push
+
+ Op::Asm::Ins si:value_symbol_start $symbol
+ Op::Asm::Call $expression
+ Op::Asm::Ins si:reduce_symbol_end $symbol
+
+ #Op::Asm::Ins i_value_clear/reduce $symbol
+ #Op::Asm::Ins i_symbol_save $symbol
+ #Op::Asm::Ins i_error_nonterminal $symbol
+ #Op::Asm::Ins i_ast_pop_rewind
+ #Op::Asm::Ins i_loc_pop_discard
+ #Op::Asm::<<< 4
+ #Op::Asm::Tcl \}
+ #Op::Asm::Ins i:ok_ast_value_push
+ }
+ leaf/0 -
+ value/0 {
+ # Generate value for symbol, rhs cannot generate its
+ # own AST nodes => leaf/0.
+
+ #Op::Asm::Tcl if \{!\[@runtime@ i_symbol_restore $symbol\]\} \{
+ #Op::Asm::>>> 4
+ #Op::Asm::Ins i_loc_push
+
+ Op::Asm::Ins si:void_symbol_start $symbol
+ Op::Asm::Call $expression
+ Op::Asm::Ins si:void_leaf_symbol_end $symbol
+
+ #Op::Asm::Ins i_value_clear/leaf $symbol
+ #Op::Asm::Ins i_symbol_save $symbol
+ #Op::Asm::Ins i_error_nonterminal $symbol
+ #Op::Asm::Ins i_loc_pop_discard
+ #Op::Asm::<<< 4
+ #Op::Asm::Tcl \}
+ #Op::Asm::Ins i:ok_ast_value_push
+ }
+ leaf/1 {
+ # Generate value for symbol, rhs may have generated
+ # AST nodes as well, discard rhs.
+
+ #Op::Asm::Tcl if \{!\[@runtime@ i_symbol_restore $symbol\]\} \{
+ #Op::Asm::>>> 4
+ #Op::Asm::Ins i_loc_push
+ #Op::Asm::Ins i_ast_push
+
+ Op::Asm::Ins si:value_symbol_start $symbol
+ Op::Asm::Call $expression
+ Op::Asm::Ins si:value_leaf_symbol_end $symbol
+
+ #Op::Asm::Ins i_value_clear/leaf $symbol
+ #Op::Asm::Ins i_symbol_save $symbol
+ #Op::Asm::Ins i_error_nonterminal $symbol
+ #Op::Asm::Ins i_ast_pop_rewind
+ #Op::Asm::Ins i_loc_pop_discard
+ #Op::Asm::<<< 4
+ #Op::Asm::Tcl \}
+ #Op::Asm::Ins i:ok_ast_value_push
+ }
+ void/1 {
+ # Generate no value for symbol, rhs may have generated
+ # AST nodes as well, discard rhs.
+ # // test case missing //
+
+ #Op::Asm::Tcl if \{!\[@runtime@ i_symbol_restore $symbol\]\} \{
+ #Op::Asm::>>> 4
+ #Op::Asm::Ins i_loc_push
+ #Op::Asm::Ins i_ast_push
+
+ Op::Asm::Ins si:value_void_symbol_start $symbol
+ Op::Asm::Call $expression
+ Op::Asm::Ins si:value_clear_symbol_end $symbol
+
+ #Op::Asm::Ins i_value_clear
+ #Op::Asm::Ins i_symbol_save $symbol
+ #Op::Asm::Ins i_error_nonterminal $symbol
+ #Op::Asm::Ins i_ast_pop_rewind
+ #Op::Asm::Ins i_loc_pop_discard
+ #Op::Asm::<<< 4
+ #Op::Asm::Tcl \}
+ }
+ void/0 {
+ # Generate no value for symbol, rhs cannot generate
+ # its own AST nodes. Nothing to save nor discard.
+
+ #Op::Asm::Tcl if \{!\[@runtime@ i_symbol_restore $symbol\]\} \{
+ #Op::Asm::>>> 4
+ #Op::Asm::Ins i_loc_push
+
+ Op::Asm::Ins si:void_void_symbol_start $symbol
+ Op::Asm::Call $expression
+ Op::Asm::Ins si:void_clear_symbol_end $symbol
+
+ #Op::Asm::Ins i_value_clear
+ #Op::Asm::Ins i_symbol_save $symbol
+ #Op::Asm::Ins i_error_nonterminal $symbol
+ #Op::Asm::Ins i_loc_pop_discard
+ #Op::Asm::<<< 4
+ #Op::Asm::Tcl \}
+ }
+ }
+ } $expression
+ Op::Asm::Done
+}
+
+namespace eval ::pt::peg::to::tclparam::Op {
+ namespace export \
+ alpha alnum ascii control digit graph lower print \
+ punct space upper wordchar xdigit ddigit \
+ dot epsilon t .. n ? * + & ! x / str cl
+}
+
+proc ::pt::peg::to::tclparam::Op {modes pe op arguments} {
+ return [namespace eval Op [list $op $modes {*}$arguments]]
+}
+
+proc ::pt::peg::to::tclparam::Op::epsilon {modes} {
+ Asm::Start
+ Asm::ReExpression epsilon
+ Asm::Direct {
+ Asm::Ins i_status_ok
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::tclparam::Op::dot {modes} {
+ Asm::Start
+ Asm::ReExpression dot
+ Asm::Direct {
+ Asm::Ins i_input_next dot
+ }
+ Asm::Done
+}
+
+foreach test {
+ alpha alnum ascii control digit graph lower print
+ punct space upper wordchar xdigit ddigit
+} {
+ proc ::pt::peg::to::tclparam::Op::$test {modes} \
+ [string map [list @ $test] {
+ Asm::Start
+ Asm::ReExpression @
+ Asm::Direct {
+ #Asm::Ins i_input_next @
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_@
+
+ Asm::Ins si:next_@
+ }
+ Asm::Done
+ }]
+}
+
+proc ::pt::peg::to::tclparam::Op::t {modes char} {
+ Asm::Start
+ Asm::ReTerminal t $char
+ Asm::Direct {
+ set char [char quote tcl $char]
+
+ #Asm::Ins i_input_next "\{t $char\}"
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_char $char
+
+ Asm::Ins si:next_char $char
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::tclparam::Op::.. {modes chs che} {
+ Asm::Start
+ Asm::ReTerminal .. $chs $che
+ Asm::Direct {
+ set chs [char quote tcl $chs]
+ set che [char quote tcl $che]
+
+ #Asm::Ins i_input_next "\{.. $chs $che\}"
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_range $chs $che
+
+ Asm::Ins si:next_range $chs $che
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::tclparam::Op::str {modes args} {
+ Asm::Start
+ Asm::ReTerminal str {*}$args
+ Asm::Direct {
+ # Without fusing this would be rendered as a sequence of
+ # characters, with associated stack churn for each character/part
+ # (See Op::x, void/all).
+
+ set str [join $args {}]
+ set str [char quote tcl $str]
+
+ Asm::Ins si:next_str $str
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::tclparam::Op::cl {modes args} {
+ # rorc = Range-OR-Char-List
+ Asm::Start
+ Asm::ReTerminal cl {*}$args
+ Asm::Direct {
+ # Without fusing this would be rendered as a choice of
+ # characters, with associated stack churn for each
+ # character/branch (See Op::/, void/all).
+
+ set cl [join [Ranges {*}$args] {}]
+ set cl [char quote tcl $cl]
+
+ Asm::Ins si:next_class $cl
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::tclparam::Op::Ranges {args} {
+ set res {}
+ foreach rorc $args { lappend res [Range $rorc] }
+ return $res
+}
+
+proc ::pt::peg::to::tclparam::Op::Range {rorc} {
+ # See also pt::peg::to::peg
+
+ # We use string ops here to distinguish terminals and ranges. The
+ # input can be a single char, not a list, and further the char may
+ # not be a proper list. Example: double-apostroph.
+ if {[string length $rorc] > 1} {
+ lassign $rorc s e
+
+ # The whole range is expanded into its full set of characters.
+ # Beware, this may blow the process if the range tries to
+ # match a substantial part of the unicode character set. We
+ # should see if there is a way to keep it encoded as range
+ # without giving up on the fast matching.
+
+ set s [scan $s %c]
+ set e [scan $e %c]
+
+ set res {}
+ for {set i $s} {$i <= $e} {incr i} {
+ append res [format %c $i]
+ }
+ return $res
+ } else {
+ return $rorc ;#[char quote tcl $rorc]
+ }
+}
+
+proc ::pt::peg::to::tclparam::Op::n {modes symbol} {
+ # symbol mode determines AST generation
+ # void => non-generative,
+ # leaf/value => generative.
+
+ Asm::Start
+ Asm::ReTerminal n $symbol
+
+ if {![dict exists $modes $symbol]} {
+ # Incomplete grammar. The symbol has no definition.
+ Asm::Direct {
+ Asm::Ins i_status_fail "; # Undefined symbol '$symbol'"
+ }
+ } else {
+ Asm::GenAST [list gen [expr { [dict get $modes $symbol] ne "void" }]]
+ Asm::Direct {
+ Asm::Self sym_$symbol
+ }
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::tclparam::Op::& {modes expression} {
+ # Note: This operation could be inlined, as it has no special
+ # control flow. Not done to make the higher-level ops are
+ # similar in construction and use = consistent and simple.
+
+ Asm::Start
+ Asm::ReExpression & $expression
+ Asm::GenAST $expression
+
+ Asm::Function [Asm::NewBlock ahead] {
+ Asm::Ins i_loc_push
+ Asm::Call $expression
+ Asm::Ins i_loc_pop_rewind
+ } $expression
+ Asm::Done
+}
+
+proc ::pt::peg::to::tclparam::Op::! {modes expression} {
+ # Note: This operation could be inlined, as it has no special
+ # control flow. Not done to make the higher-level ops are
+ # similar in construction and use = consistent and simple.
+
+ Asm::Start
+ Asm::ReExpression ! $expression
+ if {[dict get $expression gen]} {
+ Asm::Function [Asm::NewBlock notahead] {
+ # The sub-expression may generate AST elements. We must
+ # not pass them through.
+
+ #Asm::Ins i_loc_push
+ #Asm::Ins i_ast_push
+
+ Asm::Ins si:value_notahead_start
+
+ Asm::Call $expression
+
+ #Asm::Ins i_ast_pop_discard/rewind
+ #Asm::Ins i_loc_pop_rewind
+ #Asm::Ins i_status_negate
+
+ Asm::Ins si:value_notahead_exit
+ } $expression
+ } else {
+ Asm::Function [Asm::NewBlock notahead] {
+ # The sub-expression cannot generate AST elements. We can
+ # ignore AS/ARS, simplifying the code.
+
+ Asm::Ins i_loc_push
+
+ Asm::Call $expression
+
+ #Asm::Ins i_loc_pop_rewind
+ #Asm::Ins i_status_negate
+
+ Asm::Ins si:void_notahead_exit
+ } $expression
+ }
+ Asm::Done
+}
+
+proc ::pt::peg::to::tclparam::Op::? {modes expression} {
+ # Note: This operation could be inlined, as it has no special
+ # control flow. Not done to make the higher-level ops are
+ # similar in construction and use => consistent and simple.
+
+ Asm::Start
+ Asm::ReExpression ? $expression
+ Asm::GenAST $expression
+
+ Asm::Function [Asm::NewBlock optional] {
+ #Asm::Ins i_loc_push
+ #Asm::Ins i_error_push
+
+ Asm::Ins si:void2_state_push
+
+ Asm::Call $expression
+
+ #Asm::Ins i_error_pop_merge
+ #Asm::Ins i_loc_pop_rewind/discard
+ #Asm::Ins i_status_ok
+
+ Asm::Ins si:void_state_merge_ok
+ } $expression
+ Asm::Done
+}
+
+proc ::pt::peg::to::tclparam::Op::* {modes expression} {
+ Asm::Start
+ Asm::ReExpression * $expression
+ Asm::GenAST $expression
+
+ Asm::Function [Asm::NewBlock kleene] {
+ Asm::Tcl while \{1\} \{
+ Asm::>>> 4
+ #Asm::Ins i_loc_push
+ #Asm::Ins i_error_push
+
+ Asm::Ins si:void2_state_push
+
+ Asm::Call $expression
+
+ #Asm::Ins i_error_pop_merge
+ #Asm::Ins i_loc_pop_rewind/discard
+ #Asm::Ins i:fail_status_ok
+ #Asm::Tcl i:fail_return
+
+ Asm::Ins si:kleene_close
+ Asm::<<< 4
+ Asm::Tcl \}
+ # FAILED, clean up and return OK.
+ } $expression
+ Asm::Done
+}
+
+proc ::pt::peg::to::tclparam::Op::+ {modes expression} {
+ Asm::Start
+ Asm::ReExpression + $expression
+ Asm::GenAST $expression
+
+ Asm::Function [Asm::NewBlock poskleene] {
+ Asm::Ins i_loc_push
+
+ Asm::Call $expression
+
+ #Asm::Ins i_loc_pop_rewind/discard
+ #Asm::Ins i:fail_return
+
+ Asm::Ins si:kleene_abort
+
+ Asm::Tcl while \{1\} \{
+ Asm::>>> 4
+ #Asm::Ins i_loc_push
+ #Asm::Ins i_error_push
+
+ Asm::Ins si:void2_state_push
+
+ Asm::Call $expression
+
+ #Asm::Ins i_error_pop_merge
+ #Asm::Ins i_loc_pop_rewind/discard
+ #Asm::Ins i:ok_continue
+ #Asm::Tcl break
+
+ Asm::Ins si:kleene_close
+ Asm::<<< 4
+ Asm::Tcl \}
+ # FAILED, clean up and return OK.
+ #Asm::Ins i_status_ok
+
+ } $expression
+ Asm::Done
+}
+
+proc ::pt::peg::to::tclparam::Op::x {modes args} {
+ if {[llength $args] == 1} {
+ return [lindex $args 0]
+ }
+
+ Asm::Start
+ Asm::ReExpression x {*}$args
+ set gens [Asm::GenAST {*}$args]
+
+ # We have three possibilities regarding AST node generation, each
+ # requiring a slightly different instruction sequence.
+
+ # i. gen == 0 <=> No node generation at all.
+ # ii. gens[0] == 1 <=> We may have nodes from the beginning.
+ # iii. <=> Node generation starts in the middle.
+
+ if {![dict get $result gen]} {
+ set mode none
+ } elseif {[lindex $gens 0]} {
+ set mode all
+ } else {
+ set mode some
+ }
+
+ Asm::Function [Asm::NewBlock sequence] {
+ switch -exact -- $mode {
+ none {
+ # (Ad i) No AST node generation at all.
+
+ Asm::xinit0
+
+ # Note: This loop runs at code generation time. At
+ # runtime the entire construction is essentially a
+ # fully unrolled loop, with each iteration having its
+ # own block of instructions.
+
+ foreach expression [lrange $args 0 end-1] {
+ Asm::Call $expression
+ Asm::xinter00
+ }
+ Asm::Call [lindex $args end]
+ Asm::xexit0
+ }
+ all {
+ # (Ad ii) AST node generation from start to end.
+
+ Asm::xinit1
+
+ # Note: This loop runs at code generation time. At
+ # runtime the entire construction is essentially a
+ # fully unrolled loop, with each iteration having its
+ # own block of instructions.
+
+ foreach expression [lrange $args 0 end-1] {
+ Asm::Call $expression
+ Asm::xinter11
+ }
+ Asm::Call [lindex $args end]
+ Asm::xexit1
+ }
+ some {
+ # (Ad iii). Start without AST nodes, later parts do
+ # AST nodes.
+
+ Asm::xinit0
+
+ # Note: This loop runs at code generation time. At
+ # runtime the entire construction is essentially a
+ # fully unrolled loop, with each iteration having its
+ # own block of instructions.
+
+ set pushed 0
+ foreach expression [lrange $args 0 end-1] xgen [lrange $gens 1 end] {
+ Asm::Call $expression
+ if {!$pushed && $xgen} {
+ Asm::xinter01
+ set pushed 1
+ continue
+ }
+ if {$pushed} {
+ Asm::xinter11
+ } else {
+ Asm::xinter00
+ }
+ }
+ Asm::Call [lindex $args end]
+ Asm::xexit1
+ }
+ }
+ } {*}$args
+ Asm::Done
+}
+
+proc ::pt::peg::to::tclparam::Op::/ {modes args} {
+ if {[llength $args] == 1} {
+ return [lindex $args 0]
+ }
+
+ Asm::Start
+ Asm::ReExpression / {*}$args
+ set gens [Asm::GenAST {*}$args]
+
+ # Optimized AST handling: Handle each branch separately, based on
+ # its ability to generate AST nodes.
+
+ Asm::Function [Asm::NewBlock choice] {
+ set xgen [lindex $gens 0]
+ Asm::/init$xgen
+
+ # Note: This loop runs at code generation time. At runtime the
+ # entire construction is essentially a fully unrolled loop,
+ # with each iteration having its own block of instructions.
+
+ foreach expression [lrange $args 0 end-1] nxgen [lrange $gens 1 end] {
+ Asm::Call $expression
+ Asm::/inter$xgen$nxgen
+ set xgen $nxgen
+ }
+
+ Asm::Call [lindex $args end]
+ Asm::/exit$nxgen
+
+ } {*}$args
+ Asm::Done
+}
+
+# ### ### ### ######### ######### #########
+## Assembler commands
+
+namespace eval ::pt::peg::to::tclparam::Op::Asm {}
+
+# ### ### ### ######### ######### #########
+## The various part of a sequence compilation.
+
+proc ::pt::peg::to::tclparam::Op::Asm::xinit0 {} {
+ #Ins i_loc_push
+ #Ins i_error_clear_push
+
+ Ins si:void_state_push
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::xinit1 {} {
+ #Ins i_ast_push
+ #Ins i_loc_push
+ #Ins i_error_clear_push
+
+ Ins si:value_state_push
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::xinter00 {} {
+ #Ins i_error_pop_merge
+ # Stop the sequence on element failure, and
+ # restore state to before we tried the sequence.
+ #Ins i:fail_loc_pop_rewind
+ #Ins i:fail_return
+ #Ins i_error_push
+
+ Ins si:voidvoid_part
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::xinter01 {} {
+ #Ins i_error_pop_merge
+ # Stop the sequence on element failure, and
+ # restore state to before we tried the sequence.
+ #Ins i:fail_loc_pop_rewind
+ #Ins i:fail_return
+ #Ins i_ast_push
+ #Ins i_error_push
+
+ Ins si:voidvalue_part
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::xinter11 {} {
+ #Ins i_error_pop_merge
+ # Stop the sequence on element failure, and
+ # restore state to before we tried the sequence.
+ #Ins i:fail_ast_pop_rewind
+ #Ins i:fail_loc_pop_rewind
+ #Ins i:fail_return
+ #Ins i_error_push
+
+ Ins si:valuevalue_part
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::xexit0 {} {
+ #Ins i_error_pop_merge
+ #Ins i_loc_pop_rewind/discard
+ #Ins i:fail_return
+
+ Ins si:void_state_merge
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::xexit1 {} {
+ #Ins i_error_pop_merge
+ #Ins i_ast_pop_rewind/discard
+ #Ins i_loc_pop_rewind/discard
+ #Ins i:fail_return
+
+ Ins si:value_state_merge
+ return
+}
+
+# ### ### ### ######### ######### #########
+## The various part of a choice compilation.
+
+proc ::pt::peg::to::tclparam::Op::Asm::/init0 {} {
+ #Ins i_loc_push
+ #Ins i_error_clear_push
+
+ Ins si:void_state_push
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::/init1 {} {
+ #Ins i_ast_push
+ #Ins i_loc_push
+ #Ins i_error_clear_push
+
+ Ins si:value_state_push
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::/inter00 {} {
+ #Ins i_error_pop_merge
+ # A branch was successful, squash the backtracking state
+ #Ins i:ok_loc_pop_discard
+ #Ins i:ok_return
+ #Ins i_loc_rewind
+ #Ins i_error_push
+
+ Ins si:voidvoid_branch
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::/inter01 {} {
+ #Ins i_error_pop_merge
+ # A branch was successful, squash the backtracking state
+ #Ins i:ok_loc_pop_discard
+ #Ins i:ok_return
+ #Ins i_ast_push
+ #Ins i_loc_rewind
+ #Ins i_error_push
+
+ Ins si:voidvalue_branch
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::/inter10 {} {
+ #Ins i_error_pop_merge
+ #Ins i_ast_pop_rewind/discard
+ # A branch was successful, squash the backtracking state
+ #Ins i:ok_loc_pop_discard
+ #Ins i:ok_return
+ #Ins i_loc_rewind
+ #Ins i_error_push
+
+ Ins si:valuevoid_branch
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::/inter11 {} {
+ #Ins i_error_pop_merge
+ # A branch was successful, squash the backtracking state
+ #Ins i:ok_ast_pop_discard
+ #Ins i:ok_loc_pop_discard
+ #Ins i:ok_return
+ #Ins i_ast_rewind
+ #Ins i_loc_rewind
+ #Ins i_error_push
+
+ Ins si:valuevalue_branch
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::/exit0 {} {
+ #Ins i_error_pop_merge
+ #Ins i_loc_pop_rewind/discard
+
+ Ins si:void_state_merge
+
+ # Note: on ok we return, on fail, we .. set to fail ... The last
+ # is unnecessary. Which then makes the conditional return also
+ # irrelevant.
+
+ # A branch was successful, squash the backtracking state
+ #Ins i:ok_return
+
+ # All branches FAILED
+ #text::write /line
+ #Ins i_status_fail
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::/exit1 {} {
+ #Ins i_error_pop_merge
+ #Ins i_ast_pop_rewind/discard
+ #Ins i_loc_pop_rewind/discard
+
+ Ins si:value_state_merge
+
+ # Note: on ok we return, on fail, we .. set to fail ... The last
+ # is unnecessary. Which then makes the conditional return also
+ # irrelevant.
+
+ # A branch was successful, squash the backtracking state
+ #Ins i:ok_return
+
+ # All branches FAILED
+ #text::write /line
+ #Ins i_status_fail
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Allocate a text block / internal symbol / function
+
+proc ::pt::peg::to::tclparam::Op::Asm::Start {} {
+ upvar 1 result result
+ set result {def {} use {} gen 0 pe {}}
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::Done {} {
+ upvar 1 result result
+ return -code return $result
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::ReExpression {op args} {
+ upvar 1 result result
+
+ set pe $op
+ foreach a $args {
+ lappend pe [dict get $a pe]
+ }
+
+ dict set result pe $pe
+ PE $pe
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::ReTerminal {op args} {
+ upvar 1 result result
+
+ set pe [linsert $args 0 $op]
+ dict set result pe $pe
+ PE $pe
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::GenAST {args} {
+ upvar 1 result result
+
+ foreach a $args {
+ lappend flags [dict get $a gen]
+ }
+
+ dict set result gen [tcl::mathfunc::max {*}$flags]
+ dict set result genmin [tcl::mathfunc::min {*}$flags]
+ return $flags
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::NewBlock {type} {
+ variable counter
+ variable lastid ${type}_[incr counter]
+ return $lastid
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::Function {name def args} {
+ upvar 1 result result
+ variable cache
+
+ set k [list [dict get $result gen] [dict get $result pe]]
+
+ # Hardcoded 'compact == 1', compare "pt_peg_to_param.tcl"
+ if {[info exists cache($k)]} {
+ dict set result def {}
+ dict set result use $cache($k)
+ return
+ }
+
+ text::write clear
+ if {[text::write exists FUN_HEADER]} {
+ text::write recall FUN_HEADER
+ text::write undef FUN_HEADER
+ }
+
+ FunStart $name
+
+ text::write recall PE ; # Generated in Asm::ReExpression, printed
+ text::write undef PE ; # representation of the expression, to
+ # make the generated code more readable.
+ uplevel 1 $def
+ Tcl return
+
+ FunClose
+
+ if {[llength $args]} {
+ Use {*}$args
+ }
+
+ text::write store $name
+
+ set useb [NewBlock anon]
+ text::write clear
+ Self $name
+ text::write store $useb
+
+ dict set result def $name
+ dict set result use $useb
+
+ set cache($k) $useb
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::Direct {use} {
+ upvar 1 result result
+
+ set useb [NewBlock anon]
+ text::write clear
+ uplevel 1 $use
+ text::write store $useb
+
+ dict set result def {}
+ dict set result use $useb
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::Call {expr {distance 1}} {
+ #if {$distance} { text::write /line }
+
+ text::write recall [dict get $expr use]
+
+ #if {$distance} { text::write /line }
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::Use {args} {
+ foreach item $args {
+ set def [dict get $item def]
+ if {$def eq {}} continue
+ text::write recall $def
+ text::write undef $def
+ }
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::FunStart {name} {
+ text::write /line
+ text::write field @def@ @ns@$name \{\} \{ @prelude@
+ text::write /line
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::FunClose {} {
+ text::write field \}
+ text::write /line
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::Ins {args} {
+ Tcl @runtime@ {*}$args
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::Self {args} {
+ Tcl @self@ {*}$args
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::>>> {n} {
+ variable field
+ incr field $n
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::<<< {n} {
+ variable field
+ incr field -$n
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::Tcl {args} {
+ variable field
+ text::write fieldl $field {}
+ text::write field {*}$args
+ text::write /line
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::Header {text} {
+ text::write field "#"
+ text::write /line
+ text::write field "# $text"
+ text::write /line
+ text::write field "#"
+ text::write /line
+ #text::write /line
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::PE {pe} {
+ text::write clear
+ text::write field [pt::pe print $pe]
+ text::write /line
+ text::write prefix " # "
+ text::write /line
+ text::write store PE
+ return
+}
+
+proc ::pt::peg::to::tclparam::Op::Asm::Setup {} {
+ variable counter 0
+ variable field 3
+ variable cache
+ array unset cache *
+ return
+}
+
+# ### ### ### ######### ######### #########
+## Configuration
+
+namespace eval ::pt::peg::to::tclparam {
+ namespace eval ::pt::peg::to::tclparam::Op::Asm {
+ variable counter 0
+ variable fieldlen {17 5 5}
+ variable field 3
+ variable cache
+ array set cache {}
+ }
+
+ variable omap ; array set omap {
+ runtime-command runtime
+ self-command self
+ proc-command def
+ namespace ns
+ main main
+ file file
+ name name
+ template template
+ user user
+ indent indent
+ prelude prelude
+ }
+
+ variable self {}
+ variable ns ::
+ variable runtime {}
+ variable def proc
+ variable main __main
+ variable indent 0
+ variable prelude {}
+
+ variable template @code@ ; # A string. Specifies how to
+ # embed the generated code into a
+ # larger frame- work (the
+ # template).
+ variable name a_pe_grammar ; # String. Name of the grammar.
+ variable file unknown ; # String. Name of the file or
+ # other entity the grammar came
+ # from.
+ variable user unknown ; # String. Name of the user on
+ # which behalf the conversion has
+ # been invoked.
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide pt::peg::to::tclparam 1.0.3
+return
diff --git a/tcllib/modules/pt/pt_peg_to_tclparam.test b/tcllib/modules/pt/pt_peg_to_tclparam.test
new file mode 100644
index 0000000..bc03ffc
--- /dev/null
+++ b/tcllib/modules/pt/pt_peg_to_tclparam.test
@@ -0,0 +1,47 @@
+# -*- tcl -*-
+# pt_peg_to_tclparam.test: tests for the pt::peg::to::tclparam converter package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_peg_to_tclparam.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set ; # used by pt::pe::op,
+ TestAccelInit struct::set ; # however not by the
+ # # commands used here.
+
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pexpr_op.tcl pt::pe::op
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal text_write.tcl text::write
+ useLocal char.tcl char
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_peg_to_tclparam.tcl pt::peg::to::tclparam
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/pt_peg_to_tclparam.tests]
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_pegrammar.man b/tcllib/modules/pt/pt_pegrammar.man
new file mode 100644
index 0000000..36816b0
--- /dev/null
+++ b/tcllib/modules/pt/pt_pegrammar.man
@@ -0,0 +1,144 @@
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt::peg n 1]
+[include include/module.inc]
+[titledesc {Parsing Expression Grammar Serialization}]
+[require pt::peg [opt 1]]
+[require pt::pe]
+[description]
+[include include/ref_intro.inc]
+
+This package provides commands to work with the serializations of
+parsing expression grammars as managed by the Parser Tools, and
+specified in section [sectref {PEG serialization format}].
+
+[para]
+
+This is a supporting package in the Core Layer of Parser Tools.
+[para][image arch_core_support][para]
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::pt::peg] [method verify] \
+ [arg serial] [opt [arg canonvar]]]
+
+This command verifies that the content of [arg serial] is a valid
+serialization of a parsing expression and will throw an error if that
+is not the case. The result of the command is the empty string.
+
+[para]
+
+If the argument [arg canonvar] is specified it is interpreted as the
+name of a variable in the calling context. This variable will be
+written to if and only if [arg serial] is a valid regular
+serialization. Its value will be a boolean, with [const True]
+indicating that the serialization is not only valid, but also
+[term canonical]. [const False] will be written for a valid, but
+non-canonical serialization.
+
+[para]
+
+For the specification of serializations see the section
+[sectref {PE serialization format}].
+
+[call [cmd ::pt::peg] [method verify-as-canonical] \
+ [arg serial]]
+
+This command verifies that the content of [arg serial] is a valid
+[term canonical] serialization of a PEG and will throw an error if
+that is not the case. The result of the command is the empty string.
+
+[para]
+
+For the specification of canonical serializations see the section
+[sectref {PEG serialization format}].
+
+[call [cmd ::pt::peg] [method canonicalize] [arg serial]]
+
+This command assumes that the content of [arg serial] is a valid
+[term regular] serialization of a PEG and will throw an error if that
+is not the case.
+
+[para]
+
+It will then convert the input into the [term canonical] serialization
+of the contained PEG and return it as its result. If the input is
+already canonical it will be returned unchanged.
+
+[para]
+
+For the specification of regular and canonical serializations see the
+section [sectref {PEG serialization format}].
+
+[call [cmd ::pt::peg] [method print] [arg serial]]
+
+This command assumes that the argument [arg serial] contains a valid
+serialization of a parsing expression and returns a string containing
+that PE in a human readable form.
+
+[para]
+
+The exact format of this form is not specified and cannot be relied on
+for parsing or other machine-based activities.
+
+[para]
+
+For the specification of serializations see the section
+[sectref {PEG serialization format}].
+
+[call [cmd ::pt::peg] [method merge] \
+ [arg seriala] [arg serialb]]
+
+This command accepts the regular serializations of two grammars and
+uses them to create their union. The result of the command is the
+canonical serialization of this unified grammar.
+
+[para]
+A merge errors occurs if for any nonterminal symbol S occuring in both
+input grammars the two input grammars specify different semantic
+modes.
+
+[para]
+The semantic mode of each nonterminal symbol S is the semantic mode of
+S in any of its input grammars. The previous rule made sure that for
+symbols occuring in both grammars these values are identical.
+
+[para]
+
+The right-hand side of each nonterminal symbol S occuring in both
+input grammars is the choice between the right-hand sides of S in the
+input grammars, with the parsing expression of S in [arg seriala]
+coming first, except if both expressions are identical. In that case
+the first expression is taken.
+
+[para]
+The right-hand side of each nonterminal symbol S occuring in only one
+of the input grammars is the right-hand side of S in its input
+grammar.
+
+[para]
+The start expression of the unified grammar is the choice between the
+start expressions of the input grammars, with the start expression of
+[arg seriala] coming first, except if both expressions are identical.
+In that case the first expression is taken
+
+[call [cmd ::pt::peg] [method equal] \
+ [arg seriala] [arg serialb]]
+
+This command tests the two grammars [arg seriala] and [arg serialb]
+for structural equality. The result of the command is a boolean
+value. It will be set to [const true] if the expressions are
+identical, and [const false] otherwise.
+
+[para]
+
+String equality is usable only if we can assume that the two grammars
+are pure Tcl lists and dictionaries.
+
+[list_end]
+
+[include include/serial/pegrammar.inc]
+[include include/serial/pexpression.inc]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_pegrammar.tcl b/tcllib/modules/pt/pt_pegrammar.tcl
new file mode 100644
index 0000000..c264fdb
--- /dev/null
+++ b/tcllib/modules/pt/pt_pegrammar.tcl
@@ -0,0 +1,380 @@
+# -*- tcl -*-
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Verification of serialized PEGs, and conversion between
+# serializations and other data structures.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.5 ; # Required runtime.
+package require pt::pe
+
+# # ## ### ##### ######## ############# #####################
+##
+
+namespace eval ::pt::peg {
+ namespace export \
+ verify verify-as-canonical canonicalize print merge equal
+ namespace ensemble create
+}
+
+# # ## ### ##### ######## #############
+## Public API
+
+# Check that the proposed serialization of a keyword index is
+# indeed such.
+
+proc ::pt::peg::verify {serial {canonvar {}}} {
+ variable ourprefix
+ variable ourshort
+ variable ourtag
+ variable ourcbadlen
+ variable ourmiss
+ variable ourbadpe
+ variable ourcode
+
+ # Basic syntax: Length and outer type code
+ if {[llength $serial] != 2} {
+ return -code error $ourprefix$ourshort
+ }
+
+ lassign $serial tag contents
+
+ if {$tag ne $ourcode} {
+ return -code error $ourprefix[format $ourtag $tag]
+ }
+
+ # contents = dict (rules, start -> ...)
+
+ if {[llength $contents] != 4} {
+ return -code error $ourprefix$ourcbadlen
+ }
+
+ # Unpack the contents, then check that all necessary keys are
+ # present. Together with the length check we can then also be
+ # sure that no other key is present either.
+ array set peg $contents
+ foreach k {rules start} {
+ if {[info exists peg($k)]} continue
+ return -code error $ourprefix[format $ourmiss $k]
+ }
+
+ if {[catch {
+ pt::pe verify $peg(start) canon
+ } msg]} {
+ return -code error \
+ [string map \
+ [list \
+ {error in serialization:} \
+ $ourprefix[format $ourbadpe start]] \
+ $msg]
+ }
+
+ if {$canonvar eq {}} {
+ VerifyRules $peg(rules)
+ } else {
+ upvar 1 $canonvar iscanonical
+ set iscanonical $canon
+
+ VerifyRules $peg(rules) iscanonical
+
+ # Quick exit if the inner structure was already
+ # non-canonical.
+ if {!$iscanonical} return
+
+ # Now various checks if the keys and identifiers are
+ # properly sorted to make this a canonical serialization.
+
+ lassign $contents a _ b _
+ if {[list $a $b] ne {rules start}} {
+ set iscanonical 0
+ }
+
+ if {$serial ne [list {*}$serial]} {
+ set iscanonical 0
+ }
+
+ if {$contents ne [list {*}$contents]} {
+ set iscanonical 0
+ }
+ }
+
+ # Everything checked out.
+ return
+}
+
+proc ::pt::peg::verify-as-canonical {serial} {
+ verify $serial iscanonical
+ if {!$iscanonical} {
+ variable ourprefix
+ variable ourdupsort
+ return -code error $ourprefix$ourdupsort
+ }
+ return
+}
+
+proc ::pt::peg::canonicalize {serial} {
+ variable ourcode
+
+ verify $serial iscanonical
+ if {$iscanonical} { return $serial }
+
+ # Unpack the serialization.
+ array set peg $serial
+ array set peg $peg($ourcode)
+ unset peg($ourcode)
+
+ # Construct result, inside out
+ set rules {}
+ array set r $peg(rules)
+ foreach symbol [lsort -dict [array names r]] {
+ array set sd $r($symbol)
+ lappend rules \
+ $symbol [list \
+ is [pt::pe \
+ canonicalize $sd(is)] \
+ mode $sd(mode)]
+ unset sd
+ }
+
+ set serial [list $ourcode \
+ [list \
+ rules $rules \
+ start [pt::pe \
+ canonicalize $peg(start)]]]
+ return $serial
+}
+
+# Converts a PEG serialization into a human readable string for
+# test results. It assumes that the serialization is at least
+# structurally sound.
+
+proc ::pt::peg::print {serial} {
+ variable ourcode
+
+ # Unpack the serialization.
+ array set peg $serial
+ array set peg $peg($ourcode)
+ unset peg($ourcode)
+ # Print
+ set lines {}
+ lappend lines $ourcode
+ lappend lines " start := [join [split [pt::pe print $peg(start)] \n] "\n "]"
+ lappend lines { rules}
+ foreach {symbol value} $peg(rules) {
+ array set sd $value
+ # keys :: is, mode
+ lappend lines " $symbol :: <$sd(mode)> :="
+ lappend lines " [join [split [pt::pe print $sd(is)] \n] "\n "]"
+ unset sd
+ }
+ return [join $lines \n]
+}
+
+# # ## ### ##### ######## #############
+
+proc ::pt::peg::merge {seriala serialb} {
+ variable ourcode
+
+ verify $seriala
+ verify $serialb
+
+ array set pega $seriala
+ array set pega $pega($ourcode)
+ unset pega($ourcode)
+
+ array set pegb $serialb
+ array set pegb $pegb($ourcode)
+ unset pegb($ourcode)
+
+ array set ra $pega(rules)
+ array set rb $pegb(rules)
+
+ foreach symbol [array names rb] {
+ if {![info exists ra($symbol)]} {
+ # No conflict possible, copy over
+ set ra($symbol) $rb($symbol)
+ } else {
+ # unpack definitions, check for conflicts
+ array set sda $ra($symbol)
+ array set sdb $rb($symbol)
+
+ if {$sda(mode) ne $sdb(mode)} {
+ return -code "Merge error for nonterminal \"$symbol\", semantic mode mismatch"
+ }
+
+ # Merge parsing expressions, if not identical ...
+ if {![pt::pe equal \
+ $sda(is) \
+ $sdb(is)]} {
+ set sda(is) [pt::pe choice \
+ $sda(is) \
+ $sdb(is)]
+ set ra($symbol) [array get sda]
+ }
+
+ unset sda
+ unset sdb
+ }
+ }
+
+ # Construct result, inside out
+
+ set rules {}
+ foreach symbol [lsort -dict [array names ra]] {
+ array set sd $ra($symbol)
+ lappend rules \
+ $symbol [list \
+ is $sd(is) \
+ mode $sd(mode)]
+ unset sd
+ }
+
+ if {![pt::pe equal \
+ $pega(start) \
+ $pegb(start)]} {
+ set start [pt::pe choice \
+ $pega(start) \
+ $pegb(start)]
+ } else {
+ set start $pega(start)
+ }
+
+ set serial [list $ourcode \
+ [list \
+ rules $rules \
+ start $start]]
+ return $serial
+
+}
+
+# # ## ### ##### ######## #############
+
+proc ::pt::peg::equal {seriala serialb} {
+ # syntactical (intensional) grammar equality.
+ string equal \
+ [canonicalize $seriala] \
+ [canonicalize $serialb]
+}
+
+# # ## ### ##### ######## #############
+
+
+proc ::pt::peg::VerifyRules {rules {canonvar {}}} {
+ variable ourprefix
+ variable ourrbadlen
+ variable oursdup
+ variable oursempty
+ variable oursbadlen
+ variable oursmiss
+ variable ourbadpe
+ variable ourbadmode
+ variable ourmode
+
+ if {$canonvar ne {}} {
+ upvar 1 $canonvar iscanonical
+ }
+
+ if {[llength $rules] % 2 == 1} {
+ return -code error $ourprefix$ourrbadlen
+ }
+
+ if {$rules ne [list {*}$rules]} {
+ set iscanonical 0
+ }
+
+ array set r $rules
+
+ if {([array size r]*2) < [llength $rules]} {
+ return -code error $ourprefix$oursdup
+ }
+
+ foreach symbol [array names r] {
+ if {$symbol eq {}} {
+ return -code error $ourprefix$oursempty
+ }
+
+ set def $r($symbol)
+
+ if {[llength $def] != 4} {
+ return -code error $ourprefix[format $oursbadlen $symbol]
+ }
+
+ if {$def ne [list {*}$def]} {
+ set iscanonical 0
+ }
+
+ array set sd $def
+ foreach k {is mode} {
+ if {[info exists sd($k)]} continue
+ return -code error $ourprefix[format $oursmiss $symbol $k]
+ }
+
+ if {[catch {
+ pt::pe verify $sd(is) canon
+ } msg]} {
+ return -code error \
+ [string map \
+ [list \
+ {error in serialization:} \
+ $ourprefix[format $ourbadpe ($symbol)]] \
+ $msg]
+ }
+
+ if {![info exists ourmode($sd(mode))]} {
+ return -code error $ourprefix[format $ourbadmode $symbol $sd(mode)]
+ }
+
+ # Now various checks if the keys and identifiers are
+ # properly sorted to make this a canonical serialization.
+
+ if {!$canon} {
+ set iscanonical 0
+ continue
+ }
+
+ lassign $def a _ b _
+ if {[list $a $b] ne {is mode}} {
+ set iscanonical 0
+ }
+ }
+ return
+}
+
+namespace eval ::pt::peg {
+ # # ## ### ##### ######## #############
+
+ variable ourcode pt::grammar::peg
+ variable ourprefix {error in serialization:}
+ # # Test cases (grammar-peg-structure-)
+ variable ourshort { dictionary too short, expected exactly one key} ; #
+ variable ourtag { bad type tag "%s"} ; #
+ variable ourcbadlen { dictionary of bad length, expected exactly two keys} ; #
+ variable ourmiss { missing expected key "%s"} ; #
+ variable oursmiss { symbol "%s", missing expected key "%s"} ; #
+ variable ourbadpe { bad %s parsing expression:} ; #
+ variable ourbadmode { symbol "%s", bad nonterminal mode "%s"} ; #
+ variable ourrbadlen { rule dictionary of bad length, not a dictionary} ; #
+ variable oursempty { expected symbol name, got empty string}
+ variable oursbadlen { symbol dictionary for "%s" of bad length, expected exactly two keys} ; #
+ variable oursdup { duplicate nonterminal keywords} ; #
+ # Message for non-canonical serialization when expecting canonical form
+ variable ourdupsort { duplicate and/or unsorted keywords and/or irrelevant whitespace} ; #
+
+ variable ourmode
+ array set ourmode {
+ value .
+ leaf .
+ void .
+ }
+
+ ##
+ # # ## ### ##### ######## #############
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide pt::peg 1
+return
diff --git a/tcllib/modules/pt/pt_pegrammar.test b/tcllib/modules/pt/pt_pegrammar.test
new file mode 100644
index 0000000..78f8faa
--- /dev/null
+++ b/tcllib/modules/pt/pt_pegrammar.test
@@ -0,0 +1,42 @@
+# -*- tcl -*-
+# peg_structure.test: tests for the pt::peg package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_pegrammar.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ; # For tests/common
+ use snit/snit.tcl snit
+
+ useLocal pt_pexpression.tcl pt::pe
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_pegrammar.tcl pt::peg
+}
+
+# -------------------------------------------------------------------------
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/pt_pegrammar.tests]
+
+#----------------------------------------------------------------------
+
+unset mytestdir
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_pexpr_op.man b/tcllib/modules/pt/pt_pexpr_op.man
new file mode 100644
index 0000000..015e071
--- /dev/null
+++ b/tcllib/modules/pt/pt_pexpr_op.man
@@ -0,0 +1,89 @@
+[vset VERSION 1.0.1]
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt::pe::op n [vset VERSION]]
+[include include/module.inc]
+[titledesc {Parsing Expression Utilities}]
+[require pt::pe::op [opt [vset VERSION]]]
+[require pt::pe [opt 1]]
+[require struct::set]
+[description]
+[include include/ref_intro.inc]
+
+This package provides additional commands to work with the
+serializations of parsing expressions as managed by the PEG and
+related packages, and specified in section
+[sectref {PE serialization format}].
+
+[para]
+
+This is an internal package, for use by the higher level packages
+handling PEGs, their conversion into and out of various other formats,
+or other uses.
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::pt::pe::op] [method drop] \
+ [arg dropset] [arg pe]]
+
+This command removes all occurences of any of the nonterminals symbols
+in the set [arg dropset] from the parsing expression [arg pe], and
+simplifies it. This may result in the expression becoming "epsilon",
+i.e. matching nothing.
+
+[call [cmd ::pt::pe::op] [method rename] \
+ [arg nt] [arg ntnew] [arg pe]]
+
+This command renames all occurences of the nonterminal [arg nt] in the
+parsing expression [arg pe] into [arg ntnew].
+
+[call [cmd ::pt::pe::op] [method called] [arg pe]]
+
+This command extracts the set of all nonterminal symbols used,
+i.e. 'called', in the parsing expression [arg pe].
+
+[call [cmd ::pt::pe::op] [method flatten] [arg pe]]
+
+This command transforms the parsing expression by eliminating
+sequences nested in sequences, and choices in choices, lifting the
+children of the nested expression into the parent. It further
+eliminates all sequences and choices with only one child, as these are
+redundant.
+
+[para]
+
+The resulting parsing expression is returned as the result of the
+command.
+
+[call [cmd ::pt::pe::op] [method fusechars] [arg pe]]
+
+This command transforms the parsing expression by fusing adjacent
+terminals in sequences and adjacent terminals and ranges in choices,
+it (re)constructs highlevel [term strings] and
+[term {character classes}].
+
+[para]
+
+The resulting pseudo-parsing expression is returned as the result of
+the command and may contain the pseudo-operators [const str] for
+character sequences, aka strings, and [const cl] for character
+choices, aka character classes.
+
+[para]
+
+The result is called a [term {pseudo-parsing expression}] because it
+is not a true parsing expression anymore, and will fail a check with
+[cmd {::pt::peg verify}] if the new pseudo-operators
+are present in the result, but is otherwise of sound structure for a
+parsing expression.
+
+Notably, the commands [cmd {::pt::peg bottomup}] and
+[cmd {::pt::peg topdown}] will process them without
+trouble.
+
+[list_end]
+
+[include include/serial/pexpression.inc]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_pexpr_op.tcl b/tcllib/modules/pt/pt_pexpr_op.tcl
new file mode 100644
index 0000000..b6706ed
--- /dev/null
+++ b/tcllib/modules/pt/pt_pexpr_op.tcl
@@ -0,0 +1,335 @@
+# -*- tcl -*-
+# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Utility commands operating on parsing expressions.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.5 ; # Required runtime.
+package require pt::pe ; # PE basics
+package require struct::set ; # Set operations (symbol sets)
+
+# # ## ### ##### ######## ############# #####################
+##
+
+namespace eval ::pt::pe::op {
+ namespace export \
+ drop rename called flatten fusechars
+
+ namespace ensemble create
+}
+
+# # ## ### ##### ######## #############
+## Public API
+
+proc ::pt::pe::op::rename {nt ntnew serial} {
+ if {$nt eq $ntnew} {
+ return $serial
+ }
+ return [pt::pe bottomup \
+ [list [namespace current]::Rename $nt $ntnew] \
+ $serial]
+}
+
+proc ::pt::pe::op::drop {dropset serial} {
+ set res [pt::pe bottomup \
+ [list [namespace current]::Drop $dropset] \
+ $serial]
+ if {$res eq "@@"} { set res [pt::pe epsilon] }
+ return $res
+}
+
+proc ::pt::pe::op::called {serial} {
+ return [pt::pe bottomup \
+ [list [namespace current]::Called] \
+ $serial]
+}
+
+proc ::pt::pe::op::flatten {serial} {
+ return [pt::pe bottomup \
+ [list [namespace current]::Flatten] \
+ $serial]
+}
+
+proc ::pt::pe::op::fusechars {serial} {
+ return [pt::pe bottomup \
+ [list [namespace current]::FuseChars] \
+ $serial]
+}
+
+# # ## ### ##### ######## #############
+## Internals
+
+proc ::pt::pe::op::Drop {dropset pe op arguments} {
+ if {$op eq "n"} {
+ lassign $arguments symbol
+ if {[struct::set contains $dropset $symbol]} {
+ return @@
+ } else {
+ return $pe
+ }
+ }
+
+ switch -exact -- $op {
+ / - x - * - + - ? - & - ! {
+ set newarg {}
+ foreach a $arguments {
+ if {$a eq "@@"} continue
+ lappend newarg $a
+ }
+
+ if {![llength $newarg]} {
+ # Nothing remained, drop the whole expression
+ return [pt::pe epsilon]
+ } elseif {[llength $newarg] < [llength $argument]} {
+ # Some removed, construct a new expression
+ set pe [list $op {*}$newarg]
+ } ; # None removed, no change.
+ }
+ }
+
+ return $pe
+}
+
+proc ::pt::pe::op::Rename {nt ntnew pe op arguments} {
+ #puts R($op)/$arguments/
+ if {($op eq "n") && ([lindex $arguments 0] eq $nt)} {
+ return [pt::pe nonterminal $ntnew]
+ } else {
+ return $pe
+ }
+}
+
+proc ::pt::pe::op::Called {pe op arguments} {
+ # arguments = list(set-of-symbols) for operators, and n.
+ # ignored for terminal expressions.
+ # result = set-of-symbols
+
+ #puts -nonewline C|$op|$arguments|=
+ switch -exact -- $op {
+ n - & - ! - * - + - ? {
+ #puts |[lindex $arguments 0]|
+ return [lindex $arguments 0]
+ }
+ x - / {
+ #puts |[struct::set union {*}$arguments]|
+ return [struct::set union {*}$arguments]
+ }
+ }
+ #puts ||
+ return {}
+}
+
+proc ::pt::pe::op::Flatten {pe op arguments} {
+ switch -exact -- $op {
+ x - / {
+ if {[llength $arguments] == 1} {
+ # Cut single-child x/ out of the tree
+ return [lindex $arguments 0]
+ } else {
+ set res {}
+ foreach c $arguments {
+ if {[lindex $c 0] eq $op} {
+ # Cut x in x (/ in /) operator out of the
+ # tree.
+ lappend res {*}[lrange $c 1 end]
+ } else {
+ # Leave anything else unchanged.
+ lappend res $c
+ }
+ }
+ return [list $op {*}$res]
+ }
+ }
+ default {
+ # Leave anything not x/ unchanged
+ return $pe
+ }
+ }
+}
+
+proc ::pt::pe::op::FuseChars {pe op arguments} {
+ switch -exact -- $op {
+ x {
+ set changed 0 ; # boolean flag showing if fuse ops were done.
+ set buf {} ; # accumulator of chars in a string.
+ set res {} ; # accumulator of new children for operator.
+
+ foreach c $arguments {
+ CollectTerminal $c
+ FuseTerminal
+ lappend res $c
+ }
+
+ # Capture a run of characters at the end of the sequence.
+ FuseTerminal
+
+ if {$changed} {
+ return [list x {*}$res]
+ } else {
+ return $pe
+ }
+ }
+ / {
+ set changed 0 ; # boolean flag showing if fuse ops were done.
+ set buf {} ; # accumulator of chars and ranges in a class.
+ set res {} ; # accumulator of new children for operator.
+
+ foreach c $arguments {
+ CollectClass $c
+ FuseClass
+ lappend res $c
+ }
+
+ # Capture a run of characters and ranges at the end of the
+ # sequence.
+ FuseClass
+
+ if {$changed} {
+ return [list / {*}$res]
+ } else {
+ return $pe
+ }
+ }
+ default {
+ # Leave anything not x/ unchanged
+ return $pe
+ }
+ }
+}
+
+# # ## ### ##### ######## #############
+## Fuser Support
+
+proc ::pt::pe::op::CollectTerminal {c} {
+ if {[lindex $c 0] ne "t"} return
+
+ # A terminal. Just extend the accumulator. The main processing
+ # happens after each run of t-operators, see FuseTerminal.
+
+ upvar 1 buf buf
+ lappend buf [lindex $c 1]
+ return -code continue
+}
+
+proc ::pt::pe::op::FuseTerminal {} {
+ upvar 1 changed changed res res buf buf
+
+ # Nothing has accumulated, nothing to fuse.
+ if {$buf eq {}} return
+
+ # The current non-t operator is after one or more t-operators. We
+ # have to flush its accumulated data to keep the expression
+ # correct.
+
+ if {[llength $buf] > 1} {
+ # We are behind an actual series of t-operators, i.e. a
+ # string. We flush it and signal the change to the processing
+ # after the loop,
+
+ lappend res [list str {*}$buf]
+ set changed 1
+ } else {
+ # We are behind a single t-operator. We keep it as is, there
+ # is no actual need to make it a string.
+
+ lappend res [pt::pe terminal [lindex $buf 0]]
+ }
+
+ # Reset the accumulator for the next series.
+ set buf {}
+ return
+}
+
+# # ## ### ##### ######## #############
+
+proc ::pt::pe::op::CollectClass {c} {
+ if {[lindex $c 0] ni {t ..}} return
+
+ # A terminal or range. Just extend the accumulator. The main processing
+ # happens after each run of t-operators, see FuseClass.
+
+ upvar 1 buf buf
+ set new [lrange $c 1 end]
+ if {([llength $new] == 1) || ([lindex $new 0] eq [lindex $new 1])} {
+ set new [list [lindex $new 0]]
+ #set new [lindex $new 0]
+ # Note how new is rewrapped as a list, because that is what
+ # FuseClass below expects, always. See <*>
+ }
+ lappend buf $new
+ return -code continue
+}
+
+proc ::pt::pe::op::FuseClass {} {
+ upvar 1 changed changed res res buf buf
+
+ # buf :: list (elems), elems :: list (char ?char?)
+
+ # Nothing has accumulated, nothing to fuse.
+ if {$buf eq {}} return
+
+ # The current non-t operator is after one or more
+ # t/..-operators. We have to flush the accumulated data to keep
+ # the expression correct.
+
+ if {[llength $buf] > 1} {
+ # We are behind an actual series of t/..-operators, i.e. a
+ # class. We flush it, signal the change to the processing
+ # after the loop, and reset the accumulator for the next
+ # series.
+
+ # TODO :: Sort class elements, aggregate adjacents into larger
+ # ranges if possible and worthwhile (>= 3), look for
+ # overlapping ranges and merge.
+
+ # buf :: list (elems), elems :: list (char ?char?)
+ # The single-element elems have to change, become simple chars.
+ # A simple {*}-operation is not enough, as that leaves these as lists.
+
+ lappend tmp cl
+ foreach elem $buf {
+ if {[llength $elem] == 1} {
+ lappend tmp [lindex $elem 0]
+ } else {
+ lappend tmp $elem
+ }
+ }
+ lappend res $tmp
+ set changed 1
+ } else {
+ # We are behind a single t- or ..-operator. A terminal can be
+ # kept as is, but a range has to be encapsulated into a class,
+ # except of the range is something like a-a, then this is just
+ # a different coding of a single character ...
+
+ set args [lindex $buf 0] ; # <*> args expected to be a list.
+ if {[llength $args] == 1} {
+ lappend res [pt::pe terminal [lindex $args 0]]
+ } else {
+ lassign $args a b
+ set changed 1
+ if {$a ne $b} {
+ lappend res [list cl {*}$buf]
+ } else {
+ lappend res [pt::pe terminal $a]
+ }
+ }
+ }
+
+ # Reset the accumulator for the next series.
+ set buf {}
+ return
+}
+
+# # ## ### ##### ######## #############
+## State / Configuration :: n/a
+
+namespace eval ::pt::pe::op {}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide pt::pe::op 1.0.1
+return
diff --git a/tcllib/modules/pt/pt_pexpr_op.test b/tcllib/modules/pt/pt_pexpr_op.test
new file mode 100644
index 0000000..e934c2e
--- /dev/null
+++ b/tcllib/modules/pt/pt_pexpr_op.test
@@ -0,0 +1,46 @@
+# -*- tcl -*-
+# pe_op.test: tests for the pt::pe::op package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_pexpr_op.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ use fileutil/fileutil.tcl fileutil ; # For tests/common
+ use snit/snit.tcl snit
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_pexpr_op.tcl pt::pe::op
+}
+
+# -------------------------------------------------------------------------
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+TestAccelDo struct::set setimpl {
+ source [localPath tests/pt_pexpr_op.tests]
+}
+
+#----------------------------------------------------------------------
+
+unset mytestdir
+TestAccelExit struct::set
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_pexpression.man b/tcllib/modules/pt/pt_pexpression.man
new file mode 100644
index 0000000..43093b5
--- /dev/null
+++ b/tcllib/modules/pt/pt_pexpression.man
@@ -0,0 +1,275 @@
+[vset VERSION 1.0.1]
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt::pe n [vset VERSION]]
+[include include/module.inc]
+[titledesc {Parsing Expression Serialization}]
+[require pt::pe [opt [vset VERSION]]]
+[require char]
+[description]
+[include include/ref_intro.inc]
+
+This package provides commands to work with the serializations of
+parsing expressions as managed by the Parser Tools, and specified in
+section [sectref {PE serialization format}].
+
+[para]
+
+This is a supporting package in the Core Layer of Parser Tools.
+[para][image arch_core_support][para]
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::pt::pe] [method verify] \
+ [arg serial] [opt [arg canonvar]]]
+
+This command verifies that the content of [arg serial] is a valid
+serialization of a parsing expression and will throw an error if that
+is not the case. The result of the command is the empty string.
+
+[para]
+
+If the argument [arg canonvar] is specified it is interpreted as the
+name of a variable in the calling context. This variable will be
+written to if and only if [arg serial] is a valid regular
+serialization. Its value will be a boolean, with [const True]
+indicating that the serialization is not only valid, but also
+[term canonical]. [const False] will be written for a valid, but
+non-canonical serialization.
+
+[para]
+
+For the specification of serializations see the section
+[sectref {PE serialization format}].
+
+[call [cmd ::pt::pe] [method verify-as-canonical] \
+ [arg serial]]
+
+This command verifies that the content of [arg serial] is a valid
+[term canonical] serialization of a parsing expression and will throw
+an error if that is not the case. The result of the command is the
+empty string.
+
+[para]
+
+For the specification of canonical serializations see the section
+[sectref {PE serialization format}].
+
+[call [cmd ::pt::pe] [method canonicalize] [arg serial]]
+
+This command assumes that the content of [arg serial] is a valid
+[term regular] serialization of a parsing expression and will throw an
+error if that is not the case.
+
+[para]
+
+It will then convert the input into the [term canonical] serialization
+of this parsing expression and return it as its result. If the input
+is already canonical it will be returned unchanged.
+
+[para]
+
+For the specification of regular and canonical serializations see the
+section [sectref {PE serialization format}].
+
+[call [cmd ::pt::pe] [method print] [arg serial]]
+
+This command assumes that the argument [arg serial] contains a valid
+serialization of a parsing expression and returns a string containing
+that PE in a human readable form.
+
+[para]
+
+The exact format of this form is not specified and cannot be relied on
+for parsing or other machine-based activities.
+
+[para]
+
+For the specification of serializations see the section
+[sectref {PE serialization format}].
+
+[call [cmd ::pt::pe] [method bottomup] [arg cmdprefix] [arg pe]]
+
+This command walks the parsing expression [arg pe] from the bottom up
+to the root, invoking the command prefix [arg cmdprefix] for each
+partial expression. This implies that the children of a parsing
+expression PE are handled before PE.
+
+[para]
+
+The command prefix has the signature
+
+[list_begin definitions]
+[call [cmd cmdprefix] [arg pe] [arg op] [arg arguments]]
+
+I.e. it is invoked with the parsing expression [arg pe] the walk is
+currently at, the [arg op]'erator in the [arg pe], and the operator's
+[arg arguments].
+
+[para]
+
+The result returned by the command prefix replaces [arg pe] in the
+parsing expression it was a child of, allowing transformations of the
+expression tree.
+
+[para]
+
+This also means that for all inner parsing expressions the contents of
+[arg arguments] are the results of the command prefix invoked for the
+children of this inner parsing expression.
+
+[list_end]
+
+[call [cmd ::pt::pe] [method topdown] [arg cmdprefix] [arg pe]]
+
+This command walks the parsing expression [arg pe] from the root down
+to the leaves, invoking the command prefix [arg cmdprefix] for each
+partial expression. This implies that the children of a parsing
+expression PE are handled after PE.
+
+[para]
+
+The command prefix has the same signature as for [method bottomup],
+see above.
+
+[para]
+
+The result returned by the command prefix is [emph ignored].
+
+[call [cmd ::pt::pe] [method equal] \
+ [arg seriala] [arg serialb]]
+
+This command tests the two parsing expressions [arg seriala] and
+[arg serialb] for structural equality. The result of the command is a
+boolean value. It will be set to [const true] if the expressions are
+identical, and [const false] otherwise.
+
+[para]
+
+String equality is usable only if we can assume that the two parsing
+expressions are pure Tcl lists.
+
+[call [cmd ::pt::pe] [method epsilon]]
+
+This command constructs the atomic parsing expression for epsilon.
+
+[call [cmd ::pt::pe] [method dot]]
+
+This command constructs the atomic parsing expression for dot.
+
+[call [cmd ::pt::pe] [method alnum]]
+
+This command constructs the atomic parsing expression for alnum.
+
+[call [cmd ::pt::pe] [method alpha]]
+
+This command constructs the atomic parsing expression for alpha.
+
+[call [cmd ::pt::pe] [method ascii]]
+
+This command constructs the atomic parsing expression for ascii.
+
+[call [cmd ::pt::pe] [method control]]
+
+This command constructs the atomic parsing expression for control.
+
+[call [cmd ::pt::pe] [method digit]]
+
+This command constructs the atomic parsing expression for digit.
+
+[call [cmd ::pt::pe] [method graph]]
+
+This command constructs the atomic parsing expression for graph.
+
+[call [cmd ::pt::pe] [method lower]]
+
+This command constructs the atomic parsing expression for lower.
+
+[call [cmd ::pt::pe] [method print]]
+
+This command constructs the atomic parsing expression for print.
+
+[call [cmd ::pt::pe] [method punct]]
+
+This command constructs the atomic parsing expression for punct.
+
+[call [cmd ::pt::pe] [method space]]
+
+This command constructs the atomic parsing expression for space.
+
+[call [cmd ::pt::pe] [method upper]]
+
+This command constructs the atomic parsing expression for upper.
+
+[call [cmd ::pt::pe] [method wordchar]]
+
+This command constructs the atomic parsing expression for wordchar.
+
+[call [cmd ::pt::pe] [method xdigit]]
+
+This command constructs the atomic parsing expression for xdigit.
+
+[call [cmd ::pt::pe] [method ddigit]]
+
+This command constructs the atomic parsing expression for ddigit.
+
+[call [cmd ::pt::pe] [method terminal] [arg t]]
+
+This command constructs the atomic parsing expression for the terminal
+symbol [arg t].
+
+[call [cmd ::pt::pe] [method range] [arg ta] [arg tb]]
+
+This command constructs the atomic parsing expression for the range of
+terminal symbols [arg ta] ... [arg tb].
+
+[call [cmd ::pt::pe] [method nonterminal] [arg nt]]
+
+This command constructs the atomic parsing expression for the
+nonterminal symbol [arg nt].
+
+[call [cmd ::pt::pe] [method choice] [arg pe]...]
+
+This command constructs the parsing expression representing the
+ordered or prioritized choice between the argument parsing
+expressions. The first argument has the highest priority.
+
+[call [cmd ::pt::pe] [method sequence] [arg pe]...]
+
+This command constructs the parsing expression representing the
+sequence of the argument parsing expression. The first argument is the
+first element of the sequence.
+
+[call [cmd ::pt::pe] [method repeat0] [arg pe]]
+
+This command constructs the parsing expression representing the zero
+or more repetition of the argument parsing expression [arg pe], also
+known as the kleene closure.
+
+[call [cmd ::pt::pe] [method repeat1] [arg pe]]
+
+This command constructs the parsing expression representing the one or
+more repetition of the argument parsing expression [arg pe], also
+known as the positive kleene closure.
+
+[call [cmd ::pt::pe] [method optional] [arg pe]]
+
+This command constructs the parsing expression representing the
+optionality of the argument parsing expression [arg pe].
+
+[call [cmd ::pt::pe] [method ahead] [arg pe]]
+
+This command constructs the parsing expression representing the
+positive lookahead of the argument parsing expression [arg pe].
+
+[call [cmd ::pt::pe] [method notahead] [arg pe]]
+
+This command constructs the parsing expression representing the
+negative lookahead of the argument parsing expression [arg pe].
+
+[list_end]
+
+[include include/serial/pexpression.inc]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_pexpression.tcl b/tcllib/modules/pt/pt_pexpression.tcl
new file mode 100644
index 0000000..c821dd3
--- /dev/null
+++ b/tcllib/modules/pt/pt_pexpression.tcl
@@ -0,0 +1,321 @@
+# -*- tcl -*-
+# Copyright (c) 2009-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Verification of serialized parsing expressions, conversion
+# between such and other data structures, and their construction.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.5 ; # Required runtime.
+package require char ; # Character quoting utilities.
+
+# # ## ### ##### ######## ############# #####################
+##
+
+namespace eval ::pt::pe {
+ namespace export \
+ verify verify-as-canonical canonicalize \
+ bottomup topdown print equal \
+ \
+ epsilon dot alnum alpha ascii digit graph lower printable \
+ control punct space upper wordchar xdigit ddigit \
+ nonterminal optional repeat0 repeat1 ahead notahead \
+ choice sequence \
+ terminal range class str
+
+ namespace ensemble create
+}
+
+# # ## ### ##### ######## #############
+## Public API
+
+# Check that the proposed serialization of a keyword index is
+# indeed such.
+
+proc ::pt::pe::verify {serial {canonvar {}}} {
+ variable ourprefix
+ variable ourempty
+ #puts "V <$serial> /[llength [info level 0]] / [info level 0]"
+
+ if {[llength $serial] == 0} {
+ return -code error $ourprefix$ourempty
+ }
+
+ if {$canonvar ne {}} {
+ upvar 1 $canonvar iscanonical
+ set iscanonical [string equal $serial [list {*}$serial]]
+ }
+
+ topdown [list [namespace current]::Verify] $serial
+ return
+}
+
+proc ::pt::pe::verify-as-canonical {serial} {
+ verify $serial iscanonical
+ if {!$iscanonical} {
+ variable ourprefix
+ variable ourimpure
+ return -code error $ourprefix$ourimpure
+ }
+ return
+}
+
+proc ::pt::pe::Verify {pe op arguments} {
+ variable ourprefix
+ variable ourbadop
+ variable ourarity
+ variable ourwrongargs
+ variable ourempty
+
+ #puts "VE <$pe /$op /$arguments>"
+ if {[llength $pe] == 0} {
+ return -code error $ourprefix$ourempty
+ }
+
+ if {![info exists ourarity($op)]} {
+ return -code error $ourprefix[format $ourbadop $op]
+ }
+
+ lassign $ourarity($op) min max
+
+ set n [llength $arguments]
+ if {($n < $min) || (($max >= 0) && ($n > $max))} {
+ return -code error $ourprefix[format $ourwrongargs $op]
+ }
+
+ upvar 1 iscanonical iscanonical
+ if {
+ [info exists iscanonical] &&
+ (($pe ne [list {*}$pe]) ||
+ ($op eq "..") && ([lindex $arguments 0] eq [lindex $arguments 1]))
+ } {
+ # Reject coding with superfluous whitespace, and the use of
+ # {.. x x} as coding for {t x} as non-canonical.
+
+ set iscanonical 0
+ }
+ return
+}
+
+# # ## ### ##### ######## #############
+
+proc ::pt::pe::canonicalize {serial} {
+ verify $serial iscanonical
+ if {$iscanonical} { return $serial }
+ return [bottomup [list [namespace current]::Canonicalize] $serial]
+}
+
+proc ::pt::pe::Canonicalize {pe op arguments} {
+ # The input is mostly already pulled apart into its elements. Now
+ # we construct a pure list out of them, and if necessary, convert
+ # a {.. x x} expression into the canonical {t x} representation.
+
+ if {($op eq ".." ) &&
+ ([lindex $arguments 0] eq [lindex $arguments 1])} {
+ return [list t [lindex $arguments 0]]
+ }
+ return [list $op {*}$arguments]
+}
+
+# # ## ### ##### ######## #############
+
+# Converts a parsing expression serialization into a human readable
+# string for test results. It assumes that the serialization is at
+# least structurally sound.
+
+proc ::pt::pe::print {serial} {
+ return [join [bottomup [list [namespace current]::Print] $serial] \n]
+}
+
+proc ::pt::pe::Print {pe op arguments} {
+ switch -exact -- $op {
+ epsilon - alpha - alnum - ascii - digit - graph - lower - print - \
+ control - punct - space - upper - wordchar - xdigit - ddigit - dot {
+ return [list <$op>]
+ }
+ str { return [list "\"[join [char quote comment {*}$arguments] {}]\""] }
+ cl { return [list "\[[join [char quote comment {*}$arguments] {}]\]"] }
+ n { return [list "([lindex $arguments 0])"] }
+ t { return [list "'[char quote comment [lindex $arguments 0]]'"] }
+ .. {
+ lassign $arguments ca ce
+ return [list "range ([char quote comment $ca] .. [char quote comment $ce])"]
+ }
+ }
+ # The arguments are already processed for printing
+
+ set out {}
+ lappend out $op
+ foreach a $arguments {
+ foreach line $a {
+ lappend out " $line"
+ }
+ }
+ return $out
+}
+
+# # ## ### ##### ######## #############
+
+proc ::pt::pe::equal {seriala serialb} {
+ return [string equal \
+ [canonicalize $seriala] \
+ [canonicalize $serialb]]
+}
+
+# # ## ### ##### ######## #############
+
+proc ::pt::pe::bottomup {cmdprefix pe} {
+ Bottomup 2 $cmdprefix $pe
+}
+
+proc ::pt::pe::Bottomup {level cmdprefix pe} {
+ set op [lindex $pe 0]
+ set ar [lrange $pe 1 end]
+
+ switch -exact -- $op {
+ & - ! - * - + - ? - x - / {
+ set clevel $level
+ incr clevel
+ set nar {}
+ foreach a $ar {
+ lappend nar [Bottomup $clevel $cmdprefix $a]
+ }
+ set ar $nar
+ set pe [list $op {*}$nar]
+ }
+ default {}
+ }
+
+ return [uplevel $level [list {*}$cmdprefix $pe $op $ar]]
+}
+
+proc ::pt::pe::topdown {cmdprefix pe} {
+ Topdown 2 $cmdprefix $pe
+ return
+}
+
+proc ::pt::pe::Topdown {level cmdprefix pe} {
+ set op [lindex $pe 0]
+ set ar [lrange $pe 1 end]
+
+ uplevel $level [list {*}$cmdprefix $pe $op $ar]
+
+ switch -exact -- $op {
+ & - ! - * - + - ? - x - / {
+ incr level
+ foreach a $ar {
+ Topdown $level $cmdprefix $a
+ }
+ }
+ default {}
+ }
+ return
+}
+
+# # ## ### ##### ######## #############
+
+proc ::pt::pe::epsilon {} { return epsilon }
+proc ::pt::pe::dot {} { return dot }
+proc ::pt::pe::alnum {} { return alnum }
+proc ::pt::pe::alpha {} { return alpha }
+proc ::pt::pe::ascii {} { return ascii }
+proc ::pt::pe::control {} { return control }
+proc ::pt::pe::digit {} { return digit }
+proc ::pt::pe::graph {} { return graph }
+proc ::pt::pe::lower {} { return lower }
+proc ::pt::pe::printable {} { return print }
+proc ::pt::pe::punct {} { return punct }
+proc ::pt::pe::space {} { return space }
+proc ::pt::pe::upper {} { return upper }
+proc ::pt::pe::wordchar {} { return wordchar }
+proc ::pt::pe::xdigit {} { return xdigit }
+proc ::pt::pe::ddigit {} { return ddigit }
+
+proc ::pt::pe::nonterminal {nt} { list n $nt }
+proc ::pt::pe::optional {pe} { list ? $pe }
+proc ::pt::pe::repeat0 {pe} { list * $pe }
+proc ::pt::pe::repeat1 {pe} { list + $pe }
+proc ::pt::pe::ahead {pe} { list & $pe }
+proc ::pt::pe::notahead {pe} { list ! $pe }
+
+proc ::pt::pe::choice {pe args} { linsert $args 0 / $pe }
+proc ::pt::pe::sequence {pe args} { linsert $args 0 x $pe }
+
+proc ::pt::pe::terminal {t} {
+ list t $t
+}
+proc ::pt::pe::range {ta tb} {
+ if {$ta eq $tb} {
+ list t $ta
+ } else {
+ list .. $ta $tb
+ }
+}
+proc ::pt::pe::class {set} {
+ if {[string length $set] > 1} {
+ list cl $set
+ } else {
+ list t $set
+ }
+}
+proc ::pt::pe::str {str} {
+ if {[string length $str] > 1} {
+ list str $str
+ } else {
+ list t $str
+ }
+}
+
+namespace eval ::pt::pe {
+ # # ## ### ##### ######## #############
+ ## Strings for error messages.
+
+ variable ourprefix "error in serialization:"
+ variable ourempty " got empty string"
+ variable ourwrongargs " wrong#args for \"%s\""
+ variable ourbadop " invalid operator \"%s\""
+ variable ourimpure " has irrelevant whitespace or (.. X X)"
+
+ # # ## ### ##### ######## #############
+ ## operator arities
+
+ variable ourarity
+ array set ourarity {
+ epsilon {0 0}
+ alpha {0 0}
+ alnum {0 0}
+ ascii {0 0}
+ control {0 0}
+ digit {0 0}
+ graph {0 0}
+ lower {0 0}
+ print {0 0}
+ punct {0 0}
+ space {0 0}
+ upper {0 0}
+ wordchar {0 0}
+ xdigit {0 0}
+ ddigit {0 0}
+ dot {0 0}
+ .. {2 2}
+ n {1 1}
+ t {1 1}
+ & {1 1}
+ ! {1 1}
+ * {1 1}
+ + {1 1}
+ ? {1 1}
+ x {1 -1}
+ / {1 -1}
+ }
+
+ ##
+ # # ## ### ##### ######## #############
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide pt::pe 1.0.2
+return
diff --git a/tcllib/modules/pt/pt_pexpression.test b/tcllib/modules/pt/pt_pexpression.test
new file mode 100644
index 0000000..6765e10
--- /dev/null
+++ b/tcllib/modules/pt/pt_pexpression.test
@@ -0,0 +1,40 @@
+# -*- tcl -*-
+# pe_structure.test: tests for the pt::pe package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_pexpression.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+support {
+ use fileutil/fileutil.tcl fileutil ; # For tests/common
+ use snit/snit.tcl snit
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_pexpression.tcl pt::pe
+}
+
+# -------------------------------------------------------------------------
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/pt_pexpression.tests]
+
+#----------------------------------------------------------------------
+
+unset mytestdir
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_pgen.man b/tcllib/modules/pt/pt_pgen.man
new file mode 100644
index 0000000..9e7b85c
--- /dev/null
+++ b/tcllib/modules/pt/pt_pgen.man
@@ -0,0 +1,86 @@
+[comment {-*- text -*- doctools manpage}]
+[vset PGEN_VERSION 1.0.2]
+[manpage_begin pt::pgen n [vset PGEN_VERSION]]
+[include include/module.inc]
+[titledesc {Parser Generator}]
+[require pt::pgen [opt [vset PGEN_VERSION]]]
+[description]
+[include include/ref_intro.inc]
+
+This package provides a command implementing a
+[term {parser generator}]
+taking parsing expression grammars as input.
+
+[para]
+
+It is the implementation of method [method generate] of [cmd pt], the
+[manpage {Parser Tools Application}].
+
+[para]
+
+As such the intended audience of this document are people wishing to
+modify and/or extend this part of [cmd pt]'s functionality. Users of
+[cmd pt] on the other hand are hereby refered to the applications'
+manpage, i.e. [manpage {Parser Tools Application}].
+
+[para]
+
+It resides in the User Package Layer of Parser Tools.
+[para][image arch_user_pkg][para]
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::pt::pgen] \
+ [arg inputformat] \
+ [arg text] \
+ [arg resultformat] \
+ [opt [arg options...]]]
+
+This command takes the parsing expression grammar in [arg text] (in
+the format specified by [arg inputformat]), and returns the same
+grammar in the format [arg resultformat] as the result of the command.
+
+[para]
+
+The two known input formats are [const peg] and [const json].
+Introductions to them, including their formal specifications, can be
+found in the [manpage {PEG Language Tutorial}] and
+[manpage {The JSON Grammar Exchange Format}]. The packages used to
+parse these formats are
+
+[list_begin definitions]
+[def [const peg]] [package pt::peg::from::peg]
+[def [const json]] [package pt::peg::from::json]
+[list_end]
+
+[para]
+
+On the output side the known formats, and the packages used to
+generate them are
+
+[list_begin definitions]
+
+[def [const c]] [package pt::peg::to::cparam]
+[def [const container]] [package pt::peg::to::container]
+[def [const critcl]] [package pt::peg::to::cparam] +
+ [package pt::cparam::configuration::critcl]
+[def [const json]] [package pt::peg::to::json]
+[def [const oo]] [package pt::peg::to::tclparam] +
+ [package pt::tclparam::configuration::tcloo]
+[def [const peg]] [package pt::peg::to::peg]
+[def [const snit]] [package pt::peg::to::tclparam] +
+ [package pt::tclparam::configuration::snit]
+[list_end]
+
+The options supported by each of these formats are documented
+with their respective packages.
+
+[list_end]
+
+[section Example]
+[vset MODE pkg][include include/example/full.inc]
+
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_pgen.tcl b/tcllib/modules/pt/pt_pgen.tcl
new file mode 100644
index 0000000..b00eed2
--- /dev/null
+++ b/tcllib/modules/pt/pt_pgen.tcl
@@ -0,0 +1,221 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2009-2014 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# Grammars / Parsing Expression Grammars / Parser Generator
+
+# ### ### ### ######### ######### #########
+## Package description
+
+# A package exporting a parser generator command.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5
+package require fileutil
+package require pt::peg::from::json ; # Frontends: json, and PEG text form
+package require pt::peg::from::peg ; #
+package require pt::peg::to::container ; # Backends: json, peg, container code,
+package require pt::peg::to::json ; # param assembler,
+package require pt::peg::to::peg ; #
+package require pt::peg::to::param ; # PARAM assembly, raw
+package require pt::peg::to::tclparam ; # PARAM assembly, embedded into Tcl
+package require pt::peg::to::cparam ; # PARAM assembly, embedded into C
+package require pt::tclparam::configuration::snit 1.0.2 ; # PARAM/Tcl, snit::type
+package require pt::tclparam::configuration::tcloo 1.0.4 ; # PARAM/Tcl, TclOO class
+package require pt::cparam::configuration::critcl 1.0.2 ; # PARAM/C, in critcl
+package require pt::cparam::configuration::tea ; # PARAM/C, in TEA
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+namespace eval ::pt::pgen {
+ namespace export json peg serial
+ namespace ensemble create
+}
+
+# # ## ### ##### ######## #############
+## Public API - Processing the input.
+
+proc ::pt::pgen::serial {input args} {
+ #lappend args -file $inputfile
+ return [Write {*}$args $input]
+}
+
+proc ::pt::pgen::json {input args} {
+ #lappend args -file $inputfile
+ return [Write {*}$args [pt::peg::from::json convert $input]]
+}
+
+proc ::pt::pgen::peg {input args} {
+ #lappend args -file $inputfile
+ return [Write {*}$args [pt::peg::from::peg convert $input]]
+}
+
+# # ## ### ##### ######## #############
+## Internals - Generating the parser.
+
+namespace eval ::pt::pgen::Write {
+ namespace export json peg container param snit oo critcl c tea
+ namespace ensemble create
+}
+
+proc ::pt::pgen::Write::json {args} {
+ # args = (option value)... grammar
+ pt::peg::to::json configure {*}[lrange $args 0 end-1]
+ return [pt::peg::to::json convert [lindex $args end]]
+}
+
+proc ::pt::pgen::Write::peg {args} {
+ # args = (option value)... grammar
+ pt::peg::to::peg configure {*}[lrange $args 0 end-1]
+ return [pt::peg::to::peg convert [lindex $args end]]
+}
+
+proc ::pt::pgen::Write::container {args} {
+ # args = (option value)... grammar
+ pt::peg::to::container configure {*}[lrange $args 0 end-1]
+ return [pt::peg::to::container convert [lindex $args end]]
+}
+
+proc ::pt::pgen::Write::param {args} {
+ # args = (option value)... grammar
+ pt::peg::to::param configure {*}[lrange $args 0 end-1]
+ return [pt::peg::to::param convert [lindex $args end]]
+}
+
+proc ::pt::pgen::Write::snit {args} {
+ # args = (option value)... grammar
+ pt::peg::to::tclparam configure {*}[Package [Version [Class [lrange $args 0 end-1]]]]
+ ClassPackageDefaults
+
+ pt::tclparam::configuration::snit def \
+ $class $package $version \
+ {pt::peg::to::tclparam configure}
+
+ return [pt::peg::to::tclparam convert [lindex $args end]]
+}
+
+proc ::pt::pgen::Write::oo {args} {
+ # args = (option value)... grammar
+ pt::peg::to::tclparam configure {*}[Package [Version [Class [lrange $args 0 end-1]]]]
+ ClassPackageDefaults
+
+ pt::tclparam::configuration::tcloo def \
+ $class $package $version \
+ {pt::peg::to::tclparam configure}
+
+ return [pt::peg::to::tclparam convert [lindex $args end]]
+}
+
+proc ::pt::pgen::Write::tea {args} {
+ # args = (option value)... grammar
+ # Class -> touches/defines variable 'class'
+ # Package -> touches/defines variable 'package'
+ # Version -> touches/defines variable 'version'
+ pt::peg::to::cparam configure {*}[Package [Version [Class [lrange $args 0 end-1]]]]
+ ClassPackageDefaults
+
+ pt::cparam::configuration::tea def \
+ $class $package $version \
+ {pt::peg::to::cparam configure}
+
+ return [pt::peg::to::cparam convert [lindex $args end]]
+}
+
+proc ::pt::pgen::Write::critcl {args} {
+ # args = (option value)... grammar
+ # Class -> touches/defines variable 'class'
+ # Package -> touches/defines variable 'package'
+ # Version -> touches/defines variable 'version'
+ pt::peg::to::cparam configure {*}[Package [Version [Class [lrange $args 0 end-1]]]]
+ ClassPackageDefaults
+
+ pt::cparam::configuration::critcl def \
+ $class $package $version \
+ {pt::peg::to::cparam configure}
+
+ return [pt::peg::to::cparam convert [lindex $args end]]
+}
+
+proc ::pt::pgen::Write::c {args} {
+ # args = (option value)... grammar
+ pt::peg::to::cparam configure {*}[lrange $args 0 end-1]
+ return [pt::peg::to::cparam convert [lindex $args end]]
+}
+
+# ### ### ### ######### ######### #########
+## Internals: Special option handling handling.
+
+proc ::pt::pgen::Write::ClassPackageDefaults {} {
+ upvar 1 class class
+ upvar 1 package package
+ upvar 1 version version
+
+ # Initialize undefined class and package names from each other,
+ # i.e. from whichever of the two was specified, or fallback to
+ # hardwired defaults if neither was specified.
+
+ if {[info exists class] && ![info exists package]} {
+ set package $class
+ } elseif {[info exists package] && ![info exists class]} {
+ set class $package
+ } elseif {![info exists package] && ![info exists class]} {
+ set class CLASS
+ set package PACKAGE
+ }
+
+ # Initialize undefined version information.
+
+ if {![info exists version]} {
+ set version 1
+ }
+ return
+}
+
+# Class, Package, Version - identical modulo option and variable name.
+# TODO: Refactor into some common code.
+
+proc ::pt::pgen::Write::Class {optiondict} {
+ upvar 1 class class
+ set res {}
+ foreach {option value} $optiondict {
+ if {$option eq "-class"} {
+ set class $value
+ continue
+ }
+ lappend res $option $value
+ }
+ return $res
+}
+
+proc ::pt::pgen::Write::Package {optiondict} {
+ upvar 1 package package
+ set res {}
+ foreach {option value} $optiondict {
+ if {$option eq "-package"} {
+ set package $value
+ continue
+ }
+ lappend res $option $value
+ }
+ return $res
+}
+
+proc ::pt::pgen::Write::Version {optiondict} {
+ upvar 1 version version
+ set res {}
+ foreach {option value} $optiondict {
+ if {$option eq "-version"} {
+ set version $value
+ continue
+ }
+ lappend res $option $value
+ }
+ return $res
+}
+
+# ### ### ### ######### ######### #########
+## Package Management
+
+package provide pt::pgen 1.0.3
diff --git a/tcllib/modules/pt/pt_pgen.test b/tcllib/modules/pt/pt_pgen.test
new file mode 100644
index 0000000..e3f550f
--- /dev/null
+++ b/tcllib/modules/pt/pt_pgen.test
@@ -0,0 +1,132 @@
+# -*- tcl -*-
+# pt_pgen.test: Testing the parser generator, and the generated parsers.
+# Mainly for testing generated parsers for good and bad inputs.
+#
+# Copyright (c) 2014 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_parse_peg.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+# Check if we have critcl available.
+tcltest::testConstraint critcl [expr {![catch {package require critcl}]}]
+
+# Check if we have TclOO available.
+tcltest::testConstraint tcloo [expr {![catch {package require TclOO}]}]
+
+support {
+ useAccel [useTcllibC] struct/stack.tcl struct::stack ; # User: pt::rde
+ TestAccelInit struct::stack ; # (tcl)
+
+ useAccel [useTcllibC] struct/sets.tcl struct::set
+ TestAccelInit struct::set
+
+ if {![package vsatisfies [package present Tcl] 8.6]} {
+ # Pull in try emulation for 8.5. Tcl 8.6 has it builtin.
+ use try/try.tcl try
+ }
+ use snit/snit.tcl snit
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_util.tcl pt::util
+ useLocal pt_astree.tcl pt::ast
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pexpr_op.tcl pt::pe::op
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal pt_peg_container.tcl pt::peg::container
+
+ useAccel [useTcllibC] pt/pt_rdengine.tcl pt::rde ; # User: pt::parse::peg
+ TestAccelInit pt::rde ; # and: pt:peg::interp
+
+ if {[tcltest::testConstraint tcloo]} {
+ useLocal pt_rdengine_oo.tcl pt::rde::oo
+ }
+ useLocal pt_peg_interp.tcl pt::peg::interp
+
+ useAccel [useTcllibC] pt/pt_parse_peg.tcl pt::parse::peg ; # User: pt::peg::from::peg
+ TestAccelInit pt::parse::peg
+
+ useLocal pt_peg_from_json.tcl pt::peg::from::json ; # Frontends: json, and PEG text form
+ useLocal pt_peg_from_peg.tcl pt::peg::from::peg ; #
+ useLocal pt_peg_to_container.tcl pt::peg::to::container ; # Backends: json, peg, container code,
+ useLocal pt_peg_to_json.tcl pt::peg::to::json ; # param assembler,
+ useLocal pt_peg_to_peg.tcl pt::peg::to::peg ; #
+ useLocal pt_peg_to_param.tcl pt::peg::to::param ; # PARAM assembly, raw
+ useLocal pt_peg_to_tclparam.tcl pt::peg::to::tclparam ; # PARAM assembly, embedded into Tcl
+ useLocal pt_peg_to_cparam.tcl pt::peg::to::cparam ; # PARAM assembly, embedded into C
+ useLocal pt_tclparam_config_snit.tcl pt::tclparam::configuration::snit ; # PARAM/Tcl, snit::type
+ useLocal pt_tclparam_config_tcloo.tcl pt::tclparam::configuration::tcloo ; # PARAM/Tcl, TclOO class
+ useLocal pt_cparam_config_critcl.tcl pt::cparam::configuration::critcl ; # PARAM/C, in critcl
+
+ # Get the parser used by the converter, either the grammar
+ # interpreter, or snit-based and spcialized to PEG.
+ #useLocal pt_peg_container_peg.tcl pt::peg::container::peg
+ #useLocal pt_peg_interp.tcl pt::peg::interp
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_pgen.tcl pt::pgen ;# Generator
+}
+
+set mytestdir tests/data
+
+# Table of test cases ...
+# Id PEG InText Error detail Readable char
+set chars {}
+lappend chars 0 \{ \{ [list t \{] \{
+lappend chars 1 \[ \[ [list t \[] \[
+lappend chars 2 \" \" [list t \"] \"
+lappend chars 3 \\033 \033 [list t \33] <ESC>
+lappend chars 4 \\n \n [list t \n] <LF>
+lappend chars 5 \\r \r [list t \r] <CR>
+lappend chars 6 \\t \t [list t \t] <TAB>
+# \b, \f, \v - Extend PEG grammar to recognize. Also \e = \33
+lappend chars 7 \\010 \b [list t \b] <BS>
+lappend chars 8 \\014 \f [list t \f] <FF>
+lappend chars 9 \\013 \v [list t \v] <VTAB>
+lappend chars 10 \\007 \a [list t \a] <BEL>
+lappend chars 11 { } { } [list t { }] <SPACE>
+lappend chars 12 \\\\ \\ [list t \\] \\
+ # math symbol, circled asterix
+lappend chars 13 \\u229b \u229b [list t \u229b] \u229b
+# test all control characters ... (and DEL)
+# more characters: above ascii = unicode BMP.
+
+# Grammar for all test cases below, with the actual character mapped
+# in (replacing @).
+set gtemplate "PEG a_pe_grammar ('@') END;"
+set etemplate "Parse error at position 0 (Line 0, column 0).\n... X ...\n ^\nExpected one of\n* The character '@'\n"
+
+# -------------------------------------------------------------------------
+# While some of the C pieces are usually not required at runtime (like
+# C stack when RDE is also C), we are calling on the parser generator
+# here, which still may use a different implementation. So, no
+# shurtcuts, and full 16x expansion (2^4).
+
+TestAccelDo struct::set setimpl {
+ TestAccelDo pt::parse::peg parseimpl {
+ TestAccelDo pt::rde rdeimpl {
+ TestAccelDo struct::stack stackimpl {
+ source [localPath tests/pt_pgen.tests]
+ }
+ }
+ }
+}
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::stack
+TestAccelExit pt::rde
+TestAccelExit pt::parse::peg
+TestAccelExit struct::set
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_rdengine.man b/tcllib/modules/pt/pt_rdengine.man
new file mode 100644
index 0000000..af4b7b8
--- /dev/null
+++ b/tcllib/modules/pt/pt_rdengine.man
@@ -0,0 +1,669 @@
+[vset VERSION 1.1]
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt::rde n [vset VERSION]]
+[include include/module.inc]
+[titledesc {Parsing Runtime Support, PARAM based}]
+[require pt::rde [opt [vset VERSION]]]
+[require snit]
+[require struct::stack 1.5]
+[require pt::ast 1.1]
+[description]
+[include include/ref_intro.inc]
+
+This package provides a class whose instances provide the runtime
+support for recursive descent parsers with backtracking, as is needed
+for the execution of, for example, parsing expression grammars. It
+implements the [manpage {PackRat Machine Specification}], as such that
+document is [emph required] reading to understand both this manpage,
+and the package itself. The description below does make numerous
+shorthand references to the PARAM's instructions and the various parts
+of its architectural state.
+
+[para]
+
+The package resides in the Execution section of the Core Layer of
+Parser Tools.
+[para][image arch_core_transform][para]
+
+[para]
+
+Note: This package not only has the standard Tcl implementation, but
+also an accelerator, i.e. a C implementation, based on Critcl.
+
+[para]
+
+[subsection {Class API}]
+
+The package exports the API described here.
+
+[list_begin definitions]
+
+[call [cmd ::pt::rde] [arg objectName]]
+
+The command creates a new runtime object for a recursive descent
+parser with backtracking and returns the fully qualified name of the
+object command as its result. The API of this object command is
+described in the section [sectref {Object API}]. It may be used to
+invoke various operations on the object.
+
+[list_end]
+
+[subsection {Object API}]
+
+All objects created by this package provide the following 63 methods
+for the manipulation and querying of their state, which is, in essence
+the architectural state of a PARAM.
+
+[para]
+
+First some general methods and the state accessors.
+
+[list_begin definitions]
+
+[call [arg objectName] [method destroy]]
+
+This method destroys the object, releasing all claimed memory, and
+deleting the associated object command.
+
+[call [arg objectName] [method reset] [arg chan]]
+
+This method resets the state of the runtme to its defaults, preparing
+it for the parsing of the character in the channel [arg chan], which
+becomes IN.
+
+[include include/channel_notes.inc]
+
+[call [arg objectName] [method complete]]
+
+This method completes parsing, either returning the AST made from the
+elements of ARS, or throwing an error containing the current ER.
+
+[call [arg objectName] [method chan]]
+
+This method returns the handle of the channel which is IN.
+
+[call [arg objectName] [method line]]
+
+This method returns the line number for the position IN is currently
+at. Note that this may not match with the line number for CL, due to
+backtracking.
+
+[call [arg objectName] [method column]]
+
+This method returns the column for the position IN is currently
+at. Note that this may not match with the column for CL, due to
+backtracking.
+
+[call [arg objectName] [method current]]
+
+This method returns CC.
+
+[call [arg objectName] [method location]]
+
+This method returns CL.
+
+[call [arg objectName] [method locations]]
+
+This method returns the LS. The topmost entry of the stack will be the
+first element of the returned list.
+
+[call [arg objectName] [method ok]]
+
+This method returns ST.
+
+[call [arg objectName] [method value]]
+
+This method returns SV.
+
+[call [arg objectName] [method error]]
+
+This method returns ER. This is either the empty string for an empty
+ER, or a list of 2 elements, the location the error is for, and a set
+of messages which specify which symbols were expected at the
+location. The messages are encoded as one of the possible atomic
+parsing expressions (special operators, terminal, range, and
+nonterminal operator).
+
+[call [arg objectName] [method errors]]
+
+This method returns ES. The topmost entry of the stack will be the
+first element of the returned list. Each entry is encoded as described
+for [method error].
+
+[call [arg objectName] [method tokens] [opt "[arg from] [opt [arg to]]"]]
+
+This method returns the part of TC for the range of locations of IN
+starting at [arg from] and ending at [arg to]. If [arg to] is not
+specified it is taken as identical to [arg from]. If neither argument
+is specified the whole of TC is returned.
+
+[para]
+
+Each token in the returned list is a list of three elements itself,
+containing the character at the location, and the associated line and
+column numbers, in this order.
+
+[call [arg objectName] [method symbols]]
+
+This method returns a dictionary containing NC. Keys are two-element
+lists containing nonterminal symbol and location, in this order. The
+values are 4-tuples containing CL, ST, ER, and SV, in this order. ER
+is encoded as specified for the method [method error].
+
+[call [arg objectName] [method known]]
+
+This method returns a list containing the keys of SC. They are
+encoded in the same manner as is done by method [method symbols].
+
+[call [arg objectName] [method reducible]]
+
+This method returns ARS. The topmost entry of the stack will be the
+first element of the returned list
+
+[call [arg objectName] [method asts]]
+
+This method returns AS. The topmost entry of the stack will be the
+first element of the returned list
+
+[call [arg objectName] [method ast]]
+
+This is a convenience method returning the topmost element of ARS.
+
+[call [arg objectName] [method position] [arg loc]]
+
+This method returns the line and column numbers for the specified
+location of IN, assuming that this location has already been reached
+during the parsing process.
+
+[list_end]
+
+The following methods implement all PARAM instructions. They all have
+the prefix "i_".
+
+[para]
+
+The control flow is mainly provided by Tcl's builtin commands, like
+[cmd if], [cmd while], etc., plus a few guarded variants of PARAM
+instructions and Tcl commands.. That means that these instruction
+variants will do nothing if their guard condition is not
+fulfilled. They can be recognized by the prefix "i:ok_" and "i:fail_",
+which denote the value ST has to have for the instruction to execute.
+
+[para]
+
+The instructions are listed in the same order they occur in the
+[manpage {PackRat Machine Specification}], with the guard variants
+listed after their regular implementation, if any, or in their place.
+
+[list_begin definitions]
+
+[vset INS input_next][vset IA0 msg][include include/rde_1ins.inc]
+
+[vset INS test_alnum][include include/rde_0ins.inc]
+[vset INS test_alpha][include include/rde_0ins.inc]
+[vset INS test_ascii][include include/rde_0ins.inc]
+[vset INS test_char][vset IA0 char][include include/rde_1ins.inc]
+[vset INS test_ddigit][include include/rde_0ins.inc]
+[vset INS test_digit][include include/rde_0ins.inc]
+[vset INS test_graph][include include/rde_0ins.inc]
+[vset INS test_lower][include include/rde_0ins.inc]
+[vset INS test_print][include include/rde_0ins.inc]
+[vset INS test_punct][include include/rde_0ins.inc]
+[vset INS test_range][vset IA0 chars][vset IA1 chare][include include/rde_2ins.inc]
+[vset INS test_space][include include/rde_0ins.inc]
+[vset INS test_upper][include include/rde_0ins.inc]
+[vset INS test_wordchar][include include/rde_0ins.inc]
+[vset INS test_xdigit][include include/rde_0ins.inc]
+
+[vset INS error_clear][include include/rde_0ins.inc]
+[vset INS error_push][include include/rde_0ins.inc]
+[vset INS error_pop_merge][include include/rde_0ins.inc]
+[vset INS error_nonterminal][vset IA0 symbol][include include/rde_1ins.inc]
+
+[vset INS status_ok][include include/rde_0ins.inc]
+[vset INS status_fail][include include/rde_0ins.inc]
+[vset INS status_negate][include include/rde_0ins.inc]
+
+[vset INS loc_push][include include/rde_0ins.inc]
+[vset INS loc_pop_discard][include include/rde_0ins.inc]
+[vset INS loc_pop_rewind][include include/rde_0ins.inc]
+[vset G ok][vset INS loc_pop_rewind][include include/rde_0gins.inc]
+[vset IFAIL loc_pop_rewind]
+[vset IOK loc_pop_discard]
+[vset IOKX discard][include include/rde_0cins.inc]
+
+[vset INS symbol_restore][vset IA0 symbol][include include/rde_1ins.inc]
+
+[para] The boolean result of the check is returned as the result of
+the method and can be used with standard Tcl control flow commands.
+
+[vset INS symbol_save][vset IA0 symbol][include include/rde_1ins.inc]
+
+[vset INS value_clear][include include/rde_0ins.inc]
+[vset IFAIL value_clear]
+[vset IOK value_leaf]
+[vset IOKX leaf][include include/rde_0cins.inc]
+[vset IFAIL value_clear]
+[vset IOK value_reduce]
+[vset IOKX reduce][include include/rde_0cins.inc]
+
+[vset G ok][vset INS ast_value_push][include include/rde_0ginsb.inc]
+[vset INS ast_push][include include/rde_0ins.inc]
+[vset INS ast_pop_rewind][include include/rde_0ins.inc]
+[vset G fail][vset INS ast_pop_rewind][include include/rde_0gins.inc]
+[vset IFAIL ast_pop_rewind]
+[vset IOK ast_pop_discard]
+[vset IOKX discard][include include/rde_0cins.inc]
+[vset INS ast_pop_discard][include include/rde_0ins.inc]
+[vset IFAIL ast_pop_discard]
+[vset IOK ast_pop_rewind]
+[vset IOKX rewind][include include/rde_0cins.inc]
+
+[call [arg objectName] [method i:ok_continue]]
+
+This guarded method executes only for "ST == ok". Then it aborts the
+current iteration of the innermost loop in the calling Tcl procedure.
+
+[call [arg objectName] [method i:fail_continue]]
+
+This guarded method executes only for "ST == fail". Then it aborts the
+current iteration of the innermost loop in the calling Tcl procedure.
+
+[call [arg objectName] [method i:fail_return]]
+
+This guarded method executes only for "ST == fail". Then it aborts the
+calling Tcl procedure.
+
+[call [arg objectName] [method i:ok_return]]
+
+This guarded method executes only for "ST == ok". Then it aborts the
+calling Tcl procedure.
+
+[list_end]
+[para]
+
+The next set of methods are [term {super instructions}], meaning that
+each implements a longer sequence of instructions commonly used in
+parsers. The combinated instructions of the previous set, i.e. those
+with names matching the pattern "i_*/*", are actually super
+instructions as well, albeit with limited scope, handling 2
+instructions with their control flow. The upcoming set is much broader
+in scope, folding as much as six or more PARAM instructions into a
+single method call.
+
+[para]
+
+In this we can see the reasoning behind their use well:
+
+[list_begin enumerated]
+[enum]
+By using less instructions the generated parsers become smaller, as
+the common parts are now truly part of the common runtime, and not
+explicitly written in the parser's code over and over again.
+
+[enum]
+Using less instructions additionally reduces the overhead associated
+with calls into the runtime, i.e. the cost of method dispatch and of
+setting up the variable context.
+
+[enum]
+Another effect of the super instructions is that their internals can
+be optimized as well, especially regarding control flow, and stack
+use, as the runtime internals are accessible to all instructions
+folded into the sequence.
+[list_end]
+
+[para]
+
+[list_begin definitions]
+[call [arg objectName] [method si:void_state_push]]
+
+This method combines [example {
+i_loc_push
+i_error_clear
+i_error_push
+}]
+
+Parsers use it at the beginning of [term void] sequences and choices
+with a [term void] initial branch.
+
+[call [arg objectName] [method si:void2_state_push]]
+
+This method combines [example {
+i_loc_push
+i_error_clear
+i_error_push
+}]
+
+Parsers use it at the beginning of optional and repeated expressions.
+
+[call [arg objectName] [method si:value_state_push]]
+
+This method combines [example {
+i_ast_push
+i_loc_push
+i_error_clear
+i_error_push
+}]
+
+Parsers use it at the beginning of sequences generating an AST and
+choices with an initial branch generating an AST.
+
+[call [arg objectName] [method si:void_state_merge]]
+
+This method combines [example {
+i_error_pop_merge
+i_loc_pop_rewind/discard
+}]
+
+Parsers use it at the end of void sequences and choices whose last
+branch is void.
+
+[call [arg objectName] [method si:void_state_merge_ok]]
+
+This method combines [example {
+i_error_pop_merge
+i_loc_pop_rewind/discard
+i_status_ok
+}]
+
+Parsers use it at the end of optional expressions
+
+[call [arg objectName] [method si:value_state_merge]]
+
+This method combines [example {
+i_error_pop_merge
+i_ast_pop_rewind/discard
+i_loc_pop_rewind/discard
+}]
+
+Parsers use it at the end of sequences generating ASTs and choices
+whose last branch generates an AST
+
+[call [arg objectName] [method si:value_notahead_start]]
+
+This method combines [example {
+i_loc_push
+i_ast_push
+}]
+
+Parsers use it at the beginning of negative lookahead predicates which
+generate ASTs.
+
+[call [arg objectName] [method si:void_notahead_exit]]
+
+This method combines [example {
+i_loc_pop_rewind
+i_status_negate
+}]
+
+Parsers use it at the end of void negative lookahead predicates.
+
+[call [arg objectName] [method si:value_notahead_exit]]
+
+This method combines [example {
+i_ast_pop_discard/rewind
+i_loc_pop_rewind
+i_status_negate
+}]
+
+Parsers use it at the end of negative lookahead predicates which
+generate ASTs.
+
+[call [arg objectName] [method si:kleene_abort]]
+
+This method combines [example {
+i_loc_pop_rewind/discard
+i:fail_return
+}]
+
+Parsers use it to stop a positive repetition when its first, required, expression fails.
+
+[call [arg objectName] [method si:kleene_close]]
+
+This method combines [example {
+i_error_pop_merge
+i_loc_pop_rewind/discard
+i:fail_status_ok
+i:fail_return
+}]
+
+Parsers use it at the end of repetitions.
+
+[call [arg objectName] [method si:voidvoid_branch]]
+
+This method combines [example {
+i_error_pop_merge
+i:ok_loc_pop_discard
+i:ok_return
+i_loc_rewind
+i_error_push
+}]
+
+Parsers use it when transiting between branches of a choice when both are void.
+
+[call [arg objectName] [method si:voidvalue_branch]]
+
+This method combines [example {
+i_error_pop_merge
+i:ok_loc_pop_discard
+i:ok_return
+i_ast_push
+i_loc_rewind
+i_error_push
+}]
+
+Parsers use it when transiting between branches of a choice when the
+failing branch is void, and the next to test generates an AST.
+
+[call [arg objectName] [method si:valuevoid_branch]]
+
+This method combines [example {
+i_error_pop_merge
+i_ast_pop_rewind/discard
+i:ok_loc_pop_discard
+i:ok_return
+i_loc_rewind
+i_error_push
+}]
+
+Parsers use it when transiting between branches of a choice when the
+failing branch generates an AST, and the next to test is void.
+
+[call [arg objectName] [method si:valuevalue_branch]]
+
+This method combines [example {
+i_error_pop_merge
+i_ast_pop_discard
+i:ok_loc_pop_discard
+i:ok_return
+i_ast_rewind
+i_loc_rewind
+i_error_push
+}]
+
+Parsers use it when transiting between branches of a choice when both
+generate ASTs.
+
+[call [arg objectName] [method si:voidvoid_part]]
+
+This method combines [example {
+i_error_pop_merge
+i:fail_loc_pop_rewind
+i:fail_return
+i_error_push
+}]
+
+Parsers use it when transiting between parts of a sequence and both
+are void.
+
+[call [arg objectName] [method si:voidvalue_part]]
+
+This method combines [example {
+i_error_pop_merge
+i:fail_loc_pop_rewind
+i:fail_return
+i_ast_push
+i_error_push
+}]
+
+Parsers use it when transiting between parts of a sequence and the
+sucessfully matched part is void, and after it an AST is generated.
+
+[call [arg objectName] [method si:valuevalue_part]]
+
+This method combines [example {
+i_error_pop_merge
+i:fail_ast_pop_rewind
+i:fail_loc_pop_rewind
+i:fail_return
+i_error_push
+}]
+
+Parsers use it when transiting between parts of a sequence and both
+parts generate ASTs.
+
+[call [arg objectName] [method si:value_symbol_start] [arg symbol]]
+
+This method combines [example {
+if/found? i_symbol_restore $symbol
+i:found:ok_ast_value_push
+i:found_return
+i_loc_push
+i_ast_push
+}]
+
+Parsers use it at the beginning of a nonterminal symbol generating an
+AST, whose right-hand side may have generated an AST as well.
+
+[call [arg objectName] [method si:value_void_symbol_start] [arg symbol]]
+
+This method combines [example {
+if/found? i_symbol_restore $symbol
+i:found:ok_ast_value_push
+i:found_return
+i_loc_push
+i_ast_push
+}]
+
+Parsers use it at the beginning of a void nonterminal symbol whose
+right-hand side may generate an AST.
+
+[call [arg objectName] [method si:void_symbol_start] [arg symbol]]
+
+This method combines [example {
+if/found? i_symbol_restore $symbol
+i:found_return
+i_loc_push
+i_ast_push
+}]
+
+Parsers use it at the beginning of a nonterminal symbol generating an
+AST whose right-hand side is void.
+
+[call [arg objectName] [method si:void_void_symbol_start] [arg symbol]]
+
+This method combines [example {
+if/found? i_symbol_restore $symbol
+i:found_return
+i_loc_push
+}]
+
+Parsers use it at the beginning of a void nonterminal symbol whose
+right-hand side is void as well.
+
+[call [arg objectName] [method si:reduce_symbol_end] [arg symbol]]
+
+This method combines [example {
+i_value_clear/reduce $symbol
+i_symbol_save $symbol
+i_error_nonterminal $symbol
+i_ast_pop_rewind
+i_loc_pop_discard
+i:ok_ast_value_push
+}]
+
+Parsers use it at the end of a non-terminal symbol generating an AST
+using the AST generated by the right-hand side as child.
+
+[call [arg objectName] [method si:void_leaf_symbol_end] [arg symbol]]
+
+This method combines [example {
+i_value_clear/leaf $symbol
+i_symbol_save $symbol
+i_error_nonterminal $symbol
+i_loc_pop_discard
+i:ok_ast_value_push
+}]
+
+Parsers use it at the end of a non-terminal symbol generating an AST
+whose right-hand side is void.
+
+[call [arg objectName] [method si:value_leaf_symbol_end] [arg symbol]]
+
+This method combines [example {
+i_value_clear/leaf $symbol
+i_symbol_save $symbol
+i_error_nonterminal $symbol
+i_loc_pop_discard
+i_ast_pop_rewind
+i:ok_ast_value_push
+}]
+
+Parsers use it at the end of a non-terminal symbol generating an AST
+discarding the AST generated by the right-hand side.
+
+[call [arg objectName] [method si:value_clear_symbol_end] [arg symbol]]
+
+This method combines [example {
+i_value_clear
+i_symbol_save $symbol
+i_error_nonterminal $symbol
+i_loc_pop_discard
+i_ast_pop_rewind
+}]
+
+Parsers use it at the end of a void non-terminal symbol, discarding
+the AST generated by the right-hand side.
+
+[call [arg objectName] [method si:void_clear_symbol_end] [arg symbol]]
+
+This method combines [example {
+i_value_clear
+i_symbol_save $symbol
+i_error_nonterminal $symbol
+i_loc_pop_discard
+}]
+
+Parsers use it at the end of a void non-terminal symbol with a void
+right-hand side.
+
+[call [arg objectName] [method si:next_char] [arg tok]]
+[call [arg objectName] [method si:next_range] [arg toks] [arg toke]]
+[call [arg objectName] [method si:next_alnum]]
+[call [arg objectName] [method si:next_alpha]]
+[call [arg objectName] [method si:next_ascii]]
+[call [arg objectName] [method si:next_ddigit]]
+[call [arg objectName] [method si:next_digit]]
+[call [arg objectName] [method si:next_graph]]
+[call [arg objectName] [method si:next_lower]]
+[call [arg objectName] [method si:next_print]]
+[call [arg objectName] [method si:next_punct]]
+[call [arg objectName] [method si:next_space]]
+[call [arg objectName] [method si:next_upper]]
+[call [arg objectName] [method si:next_wordchar]]
+[call [arg objectName] [method si:next_xdigit]]
+
+These methods all combine [example {
+i_input_next $msg
+i:fail_return
+}]
+
+with the appropriate [cmd i_test_xxx] instruction. Parsers use them for
+handling atomic expressions.
+
+[list_end]
+[para]
+
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_rdengine.tcl b/tcllib/modules/pt/pt_rdengine.tcl
new file mode 100644
index 0000000..c0e69a2
--- /dev/null
+++ b/tcllib/modules/pt/pt_rdengine.tcl
@@ -0,0 +1,206 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2009-2015 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# # ## ### ##### ######## ############# #####################
+## Package description
+
+## Implementation of the PackRat Machine (PARAM), a virtual machine on
+## top of which parsers for Parsing Expression Grammars (PEGs) can be
+## realized. This implementation is tied to Tcl for control flow. We
+## (will) have alternate implementations written in TclOO, and critcl,
+## all exporting the same API.
+#
+## RD stands for Recursive Descent.
+
+## This package has a pure Tcl implementation, and a C implementation,
+## choosing the latter over the former, if possible.
+
+# @mdgen EXCLUDE: pt_rdengine_c.tcl
+
+package require Tcl 8.5
+
+namespace eval ::pt::rde {}
+
+# # ## ### ##### ######## ############# #####################
+## Support narrative tracing.
+
+package require debug
+debug level pt/rdengine
+debug prefix pt/rdengine {}
+
+# # ## ### ##### ######## ############# #####################
+## Management of RDengine implementations.
+
+# ::pt::rde::LoadAccelerator --
+#
+# Loads a named implementation, if possible.
+#
+# Arguments:
+# key Name of the implementation to load.
+#
+# Results:
+# A boolean flag. True if the implementation
+# was successfully loaded; and False otherwise.
+
+proc ::pt::rde::LoadAccelerator {key} {
+ debug.pt/rdengine {[info level 0]}
+ variable accel
+ set r 0
+ switch -exact -- $key {
+ critcl {
+ if {![package vsatisfies [package provide Tcl] 8.5]} {return 0}
+ if {[catch {package require tcllibc}]} {return 0}
+ set r [llength [info commands ::pt::rde_critcl]]
+ }
+ tcl {
+ variable selfdir
+ source [file join $selfdir pt_rdengine_tcl.tcl]
+ set r 1
+ }
+ default {
+ return -code error "invalid accelerator/impl. package $key:\
+ must be one of [join [KnownImplementations] {, }]"
+ }
+ }
+ set accel($key) $r
+ debug.pt/rdengine {[info level 0] ==> ($r)}
+ return $r
+}
+
+# ::pt::rde::SwitchTo --
+#
+# Activates a loaded named implementation.
+#
+# Arguments:
+# key Name of the implementation to activate.
+#
+# Results:
+# None.
+
+proc ::pt::rde::SwitchTo {key} {
+ debug.pt/rdengine {[info level 0]}
+ variable accel
+ variable loaded
+
+ if {$key eq $loaded} {
+ # No change, nothing to do.
+ debug.pt/rdengine {[info level 0] == $loaded /no change}
+ return
+ } elseif {$key ne {}} {
+ # Validate the target implementation of the switch.
+ debug.pt/rdengine {[info level 0] validate}
+
+ if {![info exists accel($key)]} {
+ return -code error "Unable to activate unknown implementation \"$key\""
+ } elseif {![info exists accel($key)] || !$accel($key)} {
+ return -code error "Unable to activate missing implementation \"$key\""
+ }
+ }
+
+ # Deactivate the previous implementation, if there was any.
+
+ if {$loaded ne {}} {
+ debug.pt/rdengine {[info level 0] disable $loaded}
+ rename ::pt::rde ::pt::rde_$loaded
+ }
+
+ # Activate the new implementation, if there is any.
+
+ if {$key ne {}} {
+ debug.pt/rdengine {[info level 0] enable $key}
+ rename ::pt::rde_$key ::pt::rde
+ }
+
+ # Remember the active implementation, for deactivation by future
+ # switches.
+
+ set loaded $key
+ debug.pt/rdengine {[info level 0] /done}
+ return
+}
+
+# ::pt::rde::Implementations --
+#
+# Determines which implementations are
+# present, i.e. loaded.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A list of implementation keys.
+
+proc ::pt::rde::Implementations {} {
+ debug.pt/rdengine {[info level 0]}
+ variable accel
+ set res {}
+ foreach n [array names accel] {
+ if {!$accel($n)} continue
+ lappend res $n
+ }
+ debug.pt/rdengine {[info level 0] ==> ($res)}
+ return $res
+}
+
+# ::pt::rde::KnownImplementations --
+#
+# Determines which implementations are known
+# as possible implementations.
+#
+# Arguments:
+# None.
+#
+# Results:
+# A list of implementation keys. In the order
+# of preference, most prefered first.
+
+proc ::pt::rde::KnownImplementations {} {
+ debug.pt/rdengine {[info level 0]}
+ return {critcl tcl}
+}
+
+proc ::pt::rde::Names {} {
+ debug.pt/rdengine {[info level 0]}
+ return {
+ critcl {tcllibc based}
+ tcl {pure Tcl}
+ }
+}
+
+# # ## ### ##### ######## ############# #####################
+## Initialization: Data structures.
+
+namespace eval ::pt::rde {
+ variable selfdir [file dirname [info script]]
+ variable accel
+ array set accel {tcl 0 critcl 0}
+ variable loaded {}
+}
+
+# # ## ### ##### ######## ############# #####################
+
+## Initialization: Choose an implementation, the most prefered is
+## listed first. Loads only one of the possible implementations. And
+## activates it.
+
+namespace eval ::pt::rde {
+ variable e
+ foreach e [KnownImplementations] {
+ if {[LoadAccelerator $e]} {
+ SwitchTo $e
+ break
+ }
+ }
+ unset e
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+namespace eval ::pt {
+ # Export the constructor command.
+ namespace export rde
+}
+
+package provide pt::rde 1.1
diff --git a/tcllib/modules/pt/pt_rdengine.test b/tcllib/modules/pt/pt_rdengine.test
new file mode 100644
index 0000000..37f0af6
--- /dev/null
+++ b/tcllib/modules/pt/pt_rdengine.test
@@ -0,0 +1,99 @@
+# -*- tcl -*-
+# pt_rdeengine.test: tests for the pt::rde package.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_rdengine.test,v 1.2 2010/07/27 22:53:53 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+support {
+ useAccel [useTcllibC] struct/stack.tcl struct::stack
+ TestAccelInit struct::stack
+
+ use snit/snit2.tcl snit
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_astree.tcl pt::ast
+}
+
+testing {
+ useAccel [useTcllibC] pt/pt_rdengine.tcl pt::rde
+ TestAccelInit pt::rde
+}
+
+#----------------------------------------------------------------------
+
+proc rde_state {r} {
+ lappend res [list IN [$r chan]]
+ lappend res [list CC [$r current]]
+ lappend res [list CL [$r location]]
+ lappend res [list LS [$r lmarked]]
+ lappend res [list ST [expr {[$r ok] ? "ok" : "fail"}]]
+ lappend res [list SV [$r value]]
+ lappend res [list ER [$r error]]
+ lappend res [list ES [$r emarked]]
+ lappend res [list TC [$r tokens]]
+ lappend res [list NC [dictsort [$r symbols]]]
+ lappend res [list AR [$r asts]]
+ lappend res [list AS [$r amarked]]
+ return "\n [join $res "\n "]"
+}
+
+#----------------------------------------------------------------------
+
+snitErrors
+TestAccelDo struct::stack stkimpl {
+ TestAccelDo pt::rde rdeimpl {
+
+ switch -exact -- $rdeimpl {
+ critcl {
+ set MY myrde
+
+ proc tmWrong {m loarg n {xarg {}}} {
+ return [tcltest::wrongNumArgs "myrde $m" $loarg $n]
+ }
+
+ proc tmTooMany {m loarg {xarg {}}} {
+ return [tcltest::tooManyArgs "myrde $m" $loarg]
+ }
+
+ proc take {tcl critcl} { return $critcl }
+ }
+ tcl {
+ set MY ::myrde
+
+ proc tmWrong {m loarg n {xarg {}}} {
+ if {$xarg == {}} {set xarg $loarg}
+ if {$xarg != {}} {set xarg " $xarg"}
+ incr n
+ return [tcltest::wrongNumArgs "::pt::rde::$m" "name$xarg" $n]
+ }
+
+ proc tmTooMany {m loarg {xarg {}}} {
+ if {$xarg == {}} {set xarg $loarg}
+ if {$xarg != {}} {set xarg " $xarg"}
+ return [tcltest::tooManyArgs "::pt::rde::$m" "name$xarg"]
+ }
+
+ proc take {tcl critcl} { return $tcl }
+ }
+ }
+
+ source [localPath tests/pt_rdengine.tests]
+ }
+}
+
+#----------------------------------------------------------------------
+
+TestAccelExit pt::rde
+TestAccelExit struct::stack
+rename rde_state {}
+testsuiteCleanup
diff --git a/tcllib/modules/pt/pt_rdengine_c.tcl b/tcllib/modules/pt/pt_rdengine_c.tcl
new file mode 100644
index 0000000..8016b00
--- /dev/null
+++ b/tcllib/modules/pt/pt_rdengine_c.tcl
@@ -0,0 +1,168 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2009-2015 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# # ## ### ##### ######## ############# #####################
+## Package description
+
+## Implementation of the PackRat Machine (PARAM), a virtual machine on
+## top of which parsers for Parsing Expression Grammars (PEGs) can be
+## realized. This implementation is written in C, for parsers written in
+## Tcl. As such the parsers themselves are tied to Tcl for control flow.
+#
+## RD stands for Recursive Descent.
+
+# # ## ### ##### ######## ############# #####################
+## Requisites
+
+package require Tcl 8.4
+package require critcl
+# @sak notprovided pt_rde_critcl
+package provide pt_rde_critcl 1.3.4
+
+# # ## ### ##### ######## ############# #####################
+## Implementation
+
+namespace eval ::pt {
+
+ # # ## ### ##### ######## ############# #####################
+ ## Supporting code for the main command.
+
+ catch {
+ #critcl::cheaders -g
+ #critcl::debug memory symbols
+ }
+
+ critcl::cheaders rde_critcl/*.h
+ critcl::csources rde_critcl/*.c
+
+ critcl::ccode {
+ /* -*- c -*- */
+
+ #include <util.h> /* Allocation macros */
+ #include <p.h> /* Public state API */
+ #include <ms.h> /* Instance command */
+
+ /* .................................................. */
+ /* Global PARAM management, per interp
+ */
+
+ typedef struct PARAMg {
+ long int counter;
+ char buf [50];
+ } PARAMg;
+
+ static void
+ PARAMgRelease (ClientData cd, Tcl_Interp* interp)
+ {
+ ckfree((char*) cd);
+ }
+
+ static CONST char*
+ PARAMnewName (Tcl_Interp* interp)
+ {
+#define KEY "tcllib/pt::rde/critcl"
+
+ Tcl_InterpDeleteProc* proc = PARAMgRelease;
+ PARAMg* paramg;
+
+ paramg = Tcl_GetAssocData (interp, KEY, &proc);
+ if (paramg == NULL) {
+ paramg = (PARAMg*) ckalloc (sizeof (PARAMg));
+ paramg->counter = 0;
+
+ Tcl_SetAssocData (interp, KEY, proc,
+ (ClientData) paramg);
+ }
+
+ paramg->counter ++;
+ sprintf (paramg->buf, "rde%ld", paramg->counter);
+ return paramg->buf;
+
+#undef KEY
+ }
+
+ static void
+ PARAMdeleteCmd (ClientData clientData)
+ {
+ /* Release the whole PARAM. */
+ param_delete ((RDE_STATE) clientData);
+ }
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## Main command, PARAM creation.
+
+ critcl::ccommand rde_critcl {dummy interp objc objv} {
+ /* Syntax: No arguments beyond the name
+ */
+
+ CONST char* name;
+ RDE_STATE param;
+ Tcl_Obj* fqn;
+ Tcl_CmdInfo ci;
+ Tcl_Command c;
+
+#define USAGE "?name?"
+
+ if ((objc != 2) && (objc != 1)) {
+ Tcl_WrongNumArgs (interp, 1, objv, USAGE);
+ return TCL_ERROR;
+ }
+
+ if (objc < 2) {
+ name = PARAMnewName (interp);
+ } else {
+ name = Tcl_GetString (objv [1]);
+ }
+
+ if (!Tcl_StringMatch (name, "::*")) {
+ /* Relative name. Prefix with current namespace */
+
+ Tcl_Eval (interp, "namespace current");
+ fqn = Tcl_GetObjResult (interp);
+ fqn = Tcl_DuplicateObj (fqn);
+ Tcl_IncrRefCount (fqn);
+
+ if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) {
+ Tcl_AppendToObj (fqn, "::", -1);
+ }
+ Tcl_AppendToObj (fqn, name, -1);
+ } else {
+ fqn = Tcl_NewStringObj (name, -1);
+ Tcl_IncrRefCount (fqn);
+ }
+ Tcl_ResetResult (interp);
+
+ if (Tcl_GetCommandInfo (interp,
+ Tcl_GetString (fqn),
+ &ci)) {
+ Tcl_Obj* err;
+
+ err = Tcl_NewObj ();
+ Tcl_AppendToObj (err, "command \"", -1);
+ Tcl_AppendObjToObj (err, fqn);
+ Tcl_AppendToObj (err, "\" already exists", -1);
+
+ Tcl_DecrRefCount (fqn);
+ Tcl_SetObjResult (interp, err);
+ return TCL_ERROR;
+ }
+
+ param = param_new ();
+ c = Tcl_CreateObjCommand (interp, Tcl_GetString (fqn),
+ paramms_objcmd, (ClientData) param,
+ PARAMdeleteCmd);
+ param_setcmd (param, c);
+
+ Tcl_SetObjResult (interp, fqn);
+ Tcl_DecrRefCount (fqn);
+ return TCL_OK;
+ }
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide pt::rde::critcl 1.3.4
+return
diff --git a/tcllib/modules/pt/pt_rdengine_oo.tcl b/tcllib/modules/pt/pt_rdengine_oo.tcl
new file mode 100644
index 0000000..063ed67
--- /dev/null
+++ b/tcllib/modules/pt/pt_rdengine_oo.tcl
@@ -0,0 +1,2169 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2009-2015 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# # ## ### ##### ######## ############# #####################
+## Package description
+
+## Implementation of the PackRat Machine (PARAM), a virtual machine on
+## top of which parsers for Parsing Expression Grammars (PEGs) can be
+## realized. This implementation is tied to Tcl for control flow. We
+## (will) have alternate implementations written in TclOO, and critcl,
+## all exporting the same API.
+#
+## RD stands for Recursive Descent.
+
+# # ## ### ##### ######## ############# #####################
+## Requisites
+
+package require Tcl 8.5
+package require TclOO
+package require struct::stack 1.5 ; # Requiring peekr, getr, get, trim* methods
+package require pt::ast
+package require pt::pe
+
+# # ## ### ##### ######## ############# #####################
+## Support narrative tracing.
+
+package require debug
+debug level pt/rdengine
+debug prefix pt/rdengine {}
+
+
+# # ## ### ##### ######## ############# #####################
+## Implementation
+
+oo::class create ::pt::rde::oo {
+ # # ## ### ##### ######## ############# #####################
+ ## Instruction counter for tracing. Unused else. Plus other helpers.
+
+ method TraceInitialization {} {
+ # Creation of the tracing support procedures.
+ # Conditional on debug tag "pt/rdengine".
+ # The instance namespace is the current context.
+ # This is where the procedures go.
+
+ proc Instruction {label {a {}} {b {}}} {
+ upvar 1 mytracecounter mytracecounter myok myok myloc myloc mycurrent mycurrent mysvalue mysvalue myerror myerror __inst theinst
+ set theinst [list $label $a $b]
+ return "[uplevel 1 self] <<[format %08d [incr mytracecounter]]>> START I:[format %-30s $label] [format %-10s $a] [format %-10s $b] :: [State]"
+ }
+
+ proc InstReturn {} {
+ upvar 1 mytracecounter mytracecounter myok myok myloc myloc mycurrent mycurrent mysvalue mysvalue myerror myerror __inst theinst
+ lassign $theinst label a b
+ return "[uplevel 1 self] <<[format %08d $mytracecounter]>> END__ I:[format %-30s $label] [format %-10s $a] [format %-10s $b] :: [State]"
+ }
+
+ proc State {} {
+ upvar 1 myok myok myloc myloc mycurrent mycurrent mysvalue mysvalue myerror myerror
+ set sv [expr {[info exists mysvalue] ? $mysvalue : ""}]
+ return "ST $myok CL $myloc CC ($mycurrent) SV ($sv) ER ($myerror)"
+ }
+
+ proc TraceSetupStacks {} {
+ set selfns [namespace current]
+
+ # Move stack instances aside.
+ rename ${selfns}::LOC ${selfns}::LOC__
+ rename ${selfns}::ERR ${selfns}::ERR__
+ rename ${selfns}::AST ${selfns}::AST__
+ rename ${selfns}::MARK ${selfns}::MRK__
+
+ # Create procedures doing tracing, and forwarding to
+ # the renamed actual instances.
+
+ interp alias {} ${selfns}::LOC {} ${selfns}::WRAP LS LOC__
+ interp alias {} ${selfns}::ERR {} ${selfns}::WRAP ES ERR__
+ interp alias {} ${selfns}::AST {} ${selfns}::WRAP ARS AST__
+ interp alias {} ${selfns}::MARK {} ${selfns}::WRAP ASM MRK__
+
+ proc WRAP {label stack args} {
+ debug.pt/rdengine { $label ___ $args}
+ set res [$stack {*}$args]
+
+ # Show state state after the op
+ set n [$stack size]
+ if {!$n} {
+ set c {()}
+ } elseif {$n == 1} {
+ set c <<[$stack peek $n]>>
+ } else {
+ set c <<[join [$stack peek $n] {>> <<}]>>
+ }
+ debug.pt/rdengine { $label == ($n):$c}
+
+ # And op return
+ debug.pt/rdengine { $label ==> ($res)}
+ return $res
+ }
+ return
+ }
+
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Lifecycle
+
+ constructor {} {
+ debug.pt/rdengine {[my TraceInitialization][self] constructor}
+
+ #set selfns [self namespace]
+
+ set mystackloc [struct::stack LOC] ; # LS
+ set mystackerr [struct::stack ERR] ; # ES
+ set mystackast [struct::stack AST] ; # ARS/AS
+ set mystackmark [struct::stack MARK] ; # s.a.
+
+ debug.pt/rdengine {[TraceSetupStacks][self] constructor /done}
+ my reset {}
+ return
+ }
+
+ method reset {chan} {
+ debug.pt/rdengine {[self] reset ($chan)}
+
+ set mychan $chan ; # IN
+ set mycurrent {} ; # CC
+ set myloc -1 ; # CL
+ set myok 0 ; # ST
+ set msvalue {} ; # SV
+ set myerror {} ; # ER
+ set mytoken {} ; # TC (string)
+ array unset mysymbol * ; # NC
+
+ $mystackloc clear
+ $mystackerr clear
+ $mystackast clear
+ $mystackmark clear
+
+ debug.pt/rdengine {[self] reset /done}
+ return
+ }
+
+ method complete {} {
+ debug.pt/rdengine {[self] complete [State]}
+
+ if {$myok} {
+ set n [$mystackast size]
+ debug.pt/rdengine {[self] complete ast $n}
+ if {$n > 1} {
+ # Multiple ASTs left, reduce into single containing them.
+ set pos [$mystackloc peek]
+ incr pos
+ set children [$mystackast peekr [$mystackast size]] ; # SaveToMark
+ set ast [pt::ast new {} $pos $myloc {*}$children] ; # Reduce ALL
+
+ debug.pt/rdengine {[self] complete n ==> ($ast)}
+ return $ast
+ } elseif {$n == 0} {
+ # Match, but no AST. This is possible if the grammar
+ # consists of only the start expression.
+
+ debug.pt/rdengine {[self] complete 0 ==> ()}
+ return {}
+ } else {
+ # Match, with AST.
+ set ast [$mystackast peek]
+ debug.pt/rdengine {[self] complete 1 ==> ($ast)}
+ return $ast
+ }
+ } else {
+ lassign $myerror loc messages
+ return -code error \
+ -errorcode {PT RDE SYNTAX} \
+ [list pt::rde $loc $messages]
+ }
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - State accessors
+
+ method chan {} { debug.pt/rdengine {[self] chan} ; return $mychan }
+
+ # - - -- --- ----- --------
+
+ method current {} { debug.pt/rdengine {[self] current} ; return $mycurrent }
+ method location {} { debug.pt/rdengine {[self] location} ; return $myloc }
+ method lmarked {} { debug.pt/rdengine {[self] lmarked} ; return [$mystackloc getr] }
+
+ # - - -- --- ----- --------
+
+ method ok {} { debug.pt/rdengine {[self] ok} ; return $myok }
+ method value {} { debug.pt/rdengine {[self] value} ; return $mysvalue }
+ method error {} { debug.pt/rdengine {[self] error} ; return $myerror }
+ method emarked {} { debug.pt/rdengine {[self] emarked} ; return [$mystackerr getr] }
+
+ # - - -- --- ----- --------
+
+ method tokens {{from {}} {to {}}} {
+ debug.pt/rdengine {[self] tokens ($from) ($to)}
+ switch -exact [llength [info level 0]] {
+ 4 { return $mytoken }
+ 5 { return [string range $mytoken $from $from] }
+ 6 { return [string range $mytoken $from $to] }
+ }
+ }
+
+ method symbols {} {
+ debug.pt/rdengine {[self] symbols}
+ return [array get mysymbol]
+ }
+
+ method scached {} {
+ debug.pt/rdengine {[self] scached}
+ return [array names mysymbol]
+ }
+
+ # - - -- --- ----- --------
+
+ method asts {} { debug.pt/rdengine {[self] asts} ; return [$mystackast getr] }
+ method amarked {} { debug.pt/rdengine {[self] amarked} ; return [$mystackmark getr] }
+ method ast {} { debug.pt/rdengine {[self] ast} ; return [$mystackast peek] }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Preloading the token cache.
+
+ method data {string} {
+ debug.pt/rdengine {[self] data +[string length $string]}
+ append mytoken $string
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## Common instruction sequences
+
+ method si:void_state_push {} {
+ debug.pt/rdengine {[Instruction si:void_state_push]}
+ # i_loc_push
+ # i_error_clear_push
+ $mystackloc push $myloc
+ set myerror {}
+ $mystackerr push {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:void2_state_push {} {
+ debug.pt/rdengine {[Instruction si:void2_state_push]}
+ # i_loc_push
+ # i_error_push
+ $mystackloc push $myloc
+ $mystackerr push {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:value_state_push {} {
+ debug.pt/rdengine {[Instruction si:value_state_push]}
+ # i_ast_push
+ # i_loc_push
+ # i_error_clear_push
+ $mystackmark push [$mystackast size]
+ $mystackloc push $myloc
+ set myerror {}
+ $mystackerr push {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:void_state_merge {} {
+ debug.pt/rdengine {[Instruction si:void_state_merge]}
+ # i_error_pop_merge
+ # i_loc_pop_rewind/discard
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+
+ set last [$mystackloc pop]
+ if {!$myok} {
+ set myloc $last
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:void_state_merge_ok {} {
+ debug.pt/rdengine {[Instruction si:void_state_merge_ok]}
+ # i_error_pop_merge
+ # i_loc_pop_rewind/discard
+ # i_status_ok
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+
+ set last [$mystackloc pop]
+ if {!$myok} {
+ set myloc $last
+ set myok 1
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:value_state_merge {} {
+ debug.pt/rdengine {[Instruction si:value_state_merge]}
+ # i_error_pop_merge
+ # i_ast_pop_rewind/discard
+ # i_loc_pop_rewind/discard
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+
+ set mark [$mystackmark pop]
+ set last [$mystackloc pop]
+ if {!$myok} {
+ $mystackast trim* $mark
+ set myloc $last
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:value_notahead_start {} {
+ debug.pt/rdengine {[Instruction si:value_notahead_start]}
+ # i_loc_push
+ # i_ast_push
+
+ $mystackloc push $myloc
+ $mystackmark push [$mystackast size]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:void_notahead_exit {} {
+ debug.pt/rdengine {[Instruction si:void_notahead_exit]}
+ # i_loc_pop_rewind
+ # i_status_negate
+
+ set myloc [$mystackloc pop]
+ set myok [expr {!$myok}]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:value_notahead_exit {} {
+ debug.pt/rdengine {[Instruction si:value_notahead_exit]}
+ # i_ast_pop_discard/rewind
+ # i_loc_pop_rewind
+ # i_status_negate
+
+ set mark [$mystackmark pop]
+ if {$myok} {
+ $mystackast trim* $mark
+ }
+ set myloc [$mystackloc pop]
+ set myok [expr {!$myok}]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:kleene_abort {} {
+ debug.pt/rdengine {[Instruction si:kleene_abort]}
+ # i_loc_pop_rewind/discard
+ # i:fail_return
+
+ set last [$mystackloc pop]
+ if {$myok} {
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set myloc $last
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+
+ method si:kleene_close {} {
+ debug.pt/rdengine {[Instruction si:kleene_close]}
+ # i_error_pop_merge
+ # i_loc_pop_rewind/discard
+ # i:fail_status_ok
+ # i:fail_return
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+
+ set last [$mystackloc pop]
+ if {$myok} {
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set myok 1
+ set myloc $last
+
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:voidvoid_branch {} {
+ debug.pt/rdengine {[Instruction si:voidvoid_branch]}
+ # i_error_pop_merge
+ # i:ok_loc_pop_discard
+ # i:ok_return
+ # i_loc_rewind
+ # i_error_push
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+
+ if {$myok} {
+ $mystackloc pop
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ set myloc [$mystackloc peek]
+ $mystackerr push $myerror
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:voidvalue_branch {} {
+ debug.pt/rdengine {[Instruction si:voidvalue_branch]}
+ # i_error_pop_merge
+ # i:ok_loc_pop_discard
+ # i:ok_return
+ # i_ast_push
+ # i_loc_rewind
+ # i_error_push
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+
+ if {$myok} {
+ $mystackloc pop
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackmark push [$mystackast size]
+ set myloc [$mystackloc peek]
+ $mystackerr push {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:valuevoid_branch {} {
+ debug.pt/rdengine {[Instruction si:valuevoid_branch]}
+ # i_error_pop_merge
+ # i_ast_pop_rewind/discard
+ # i:ok_loc_pop_discard
+ # i:ok_return
+ # i_loc_rewind
+ # i_error_push
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+ set mark [$mystackmark pop]
+ if {$myok} {
+ $mystackloc pop
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackast trim* $mark
+ set myloc [$mystackloc peek]
+ $mystackerr push {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:valuevalue_branch {} {
+ debug.pt/rdengine {[Instruction si:valuevalue_branch]}
+ # i_error_pop_merge
+ # i_ast_pop_discard
+ # i:ok_loc_pop_discard
+ # i:ok_return
+ # i_ast_rewind
+ # i_loc_rewind
+ # i_error_push
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+ if {$myok} {
+ $mystackmark pop
+ $mystackloc pop
+
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackast trim* [$mystackmark peek]
+ set myloc [$mystackloc peek]
+ $mystackerr push {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:voidvoid_part {} {
+ debug.pt/rdengine {[Instruction si:voidvoid_part]}
+ # i_error_pop_merge
+ # i:fail_loc_pop_rewind
+ # i:fail_return
+ # i_error_push
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+ if {!$myok} {
+ set myloc [$mystackloc pop]
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackerr push $myerror
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:voidvalue_part {} {
+ debug.pt/rdengine {[Instruction si:voidvalue_part]}
+ # i_error_pop_merge
+ # i:fail_loc_pop_rewind
+ # i:fail_return
+ # i_ast_push
+ # i_error_push
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+ if {!$myok} {
+ set myloc [$mystackloc pop]
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackmark push [$mystackast size]
+ $mystackerr push $myerror
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:valuevalue_part {} {
+ debug.pt/rdengine {[Instruction si:valuevalue_part]}
+ # i_error_pop_merge
+ # i:fail_ast_pop_rewind
+ # i:fail_loc_pop_rewind
+ # i:fail_return
+ # i_error_push
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+ if {!$myok} {
+ $mystackast trim* [$mystackmark pop]
+ set myloc [$mystackloc pop]
+
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackerr push $myerror
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:next_str {tok} {
+ debug.pt/rdengine {[Instruction si:next_str $tok]}
+ # String = sequence of characters.
+ # No need for all the intermediate stack churn.
+
+ set n [string length $tok]
+ set last [expr {$myloc + $n}]
+ set max [string length $mytoken]
+
+ incr myloc
+ if {($last >= $max) && ![my ExtendTCN [expr {$last - $max + 1}]]} {
+ set myok 0
+ set myerror [list $myloc [list [list str $tok]]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set lex [string range $mytoken $myloc $last]
+ set mycurrent [string index $mytoken $last]
+
+ # ATTENTION: The error output of this instruction is different
+ # from a regular sequence of si:next_char instructions. The
+ # error location will be the start of the string token we
+ # wanted to match, and the message will contain the entire
+ # string token. In the regular sequence we would see the exact
+ # point of the mismatch instead, with the message containing
+ # the expected character.
+
+ set myok [expr {$tok eq $lex}]
+
+ if {$myok} {
+ set myloc $last
+ set myerror {}
+ } else {
+ set myerror [list $myloc [list [list str $tok]]]
+ incr myloc -1
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_class {tok} {
+ debug.pt/rdengine {[Instruction si:next_class $tok]}
+ # Class = Choice of characters. No need for stack churn.
+
+ # i_input_next "\{t $c\}"
+ # i:fail_return
+ # i_test_<user class>
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list [list cl $tok]]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ # Note what is needle versus hay. The token, i.e. the string
+ # of allowed characters is the hay in which the current
+ # character is looked, making it the needle.
+ set myok [expr {[string first $mycurrent $tok] >= 0}]
+
+ if {$myok} {
+ set myerror {}
+ } else {
+ set myerror [list $myloc [list [list cl $tok]]]
+ incr myloc -1
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_char {tok} {
+ debug.pt/rdengine {[Instruction si:next_char $tok]}
+ # i_input_next "\{t $c\}"
+ # i:fail_return
+ # i_test_char $c
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list [list t $tok]]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [expr {$tok eq $mycurrent}]
+ if {$myok} {
+ set myerror {}
+ } else {
+ set myerror [list $myloc [list [list t $tok]]]
+ incr myloc -1
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_range {toks toke} {
+ debug.pt/rdengine {[Instruction si:next_range $toks $toke]}
+ #Asm::Ins i_input_next "\{.. $s $e\}"
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_range $s $e
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list [list .. $toks $toke]]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [expr {
+ ([string compare $toks $mycurrent] <= 0) &&
+ ([string compare $mycurrent $toke] <= 0)
+ }] ; # {}
+ if {$myok} {
+ set myerror {}
+ } else {
+ set myerror [list $myloc [list [pt::pe range $toks $toke]]]
+ incr myloc -1
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:next_alnum {} {
+ debug.pt/rdengine {[Instruction si:next_alnum]}
+ #Asm::Ins i_input_next alnum
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_alnum
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list alnum]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is alnum -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list alnum]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_alpha {} {
+ debug.pt/rdengine {[Instruction si:next_alpha]}
+ #Asm::Ins i_input_next alpha
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_alpha
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list alpha]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is alpha -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list alpha]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_ascii {} {
+ debug.pt/rdengine {[Instruction si:next_ascii]}
+ #Asm::Ins i_input_next ascii
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_ascii
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list ascii]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is ascii -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list ascii]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_control {} {
+ debug.pt/rdengine {[Instruction si:next_control]}
+ #Asm::Ins i_input_next control
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_control
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list control]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is control -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list control]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_ddigit {} {
+ debug.pt/rdengine {[Instruction si:next_ddigit]}
+ #Asm::Ins i_input_next ddigit
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_ddigit
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list ddigit]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string match {[0-9]} $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list ddigit]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_digit {} {
+ debug.pt/rdengine {[Instruction si:next_digit]}
+ #Asm::Ins i_input_next digit
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_digit
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list digit]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is digit -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list digit]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_graph {} {
+ debug.pt/rdengine {[Instruction si:next_graph]}
+ #Asm::Ins i_input_next graph
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_graph
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list graph]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is graph -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list graph]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_lower {} {
+ debug.pt/rdengine {[Instruction si:next_lower]}
+ #Asm::Ins i_input_next lower
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_lower
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list lower]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is lower -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list lower]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_print {} {
+ debug.pt/rdengine {[Instruction si:next_print]}
+ #Asm::Ins i_input_next print
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_print
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list print]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is print -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list print]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_punct {} {
+ debug.pt/rdengine {[Instruction si:next_punct]}
+ #Asm::Ins i_input_next punct
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_punct
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list punct]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is punct -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list punct]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_space {} {
+ debug.pt/rdengine {[Instruction si:next_space]}
+ #Asm::Ins i_input_next space
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_space
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list space]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is space -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list space]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_upper {} {
+ debug.pt/rdengine {[Instruction si:next_upper]}
+ #Asm::Ins i_input_next upper
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_upper
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list upper]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is upper -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list upper]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_wordchar {} {
+ debug.pt/rdengine {[Instruction si:next_wordchar]}
+ #Asm::Ins i_input_next wordchar
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_wordchar
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list wordchar]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is wordchar -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list wordchar]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_xdigit {} {
+ debug.pt/rdengine {[Instruction si:next_xdigit]}
+ #Asm::Ins i_input_next xdigit
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_xdigit
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list xdigit]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is xdigit -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list xdigit]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:value_symbol_start {symbol} {
+ debug.pt/rdengine {[Instruction si:value_symbol_start $symbol]}
+ # if @runtime@ i_symbol_restore $symbol
+ # i:found:ok_ast_value_push
+ # i:found_return
+ # i_loc_push
+ # i_ast_push
+
+ set k [list $myloc $symbol]
+ if {[info exists mysymbol($k)]} {
+ lassign $mysymbol($k) myloc myok myerror mysvalue
+ if {$myok} {
+ $mystackast push $mysvalue
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackloc push $myloc
+ $mystackmark push [$mystackast size]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:value_void_symbol_start {symbol} {
+ debug.pt/rdengine {[Instruction si:value_void_symbol_start $symbol]}
+ # if @runtime@ i_symbol_restore $symbol
+ # i:found_return
+ # i_loc_push
+ # i_ast_push
+
+ set k [list $myloc $symbol]
+ if {[info exists mysymbol($k)]} {
+ lassign $mysymbol($k) myloc myok myerror mysvalue
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackloc push $myloc
+ $mystackmark push [$mystackast size]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:void_symbol_start {symbol} {
+ debug.pt/rdengine {[Instruction si:void_symbol_start $symbol]}
+ # if @runtime@ i_symbol_restore $symbol
+ # i:found:ok_ast_value_push
+ # i:found_return
+ # i_loc_push
+
+ set k [list $myloc $symbol]
+ if {[info exists mysymbol($k)]} {
+ lassign $mysymbol($k) myloc myok myerror mysvalue
+ if {$myok} {
+ $mystackast push $mysvalue
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackloc push $myloc
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:void_void_symbol_start {symbol} {
+ debug.pt/rdengine {[Instruction si:void_void_symbol_start $symbol]}
+ # if @runtime@ i_symbol_restore $symbol
+ # i:found_return
+ # i_loc_push
+
+ set k [list $myloc $symbol]
+ if {[info exists mysymbol($k)]} {
+ lassign $mysymbol($k) myloc myok myerror mysvalue
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackloc push $myloc
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:reduce_symbol_end {symbol} {
+ debug.pt/rdengine {[Instruction si:reduce_symbol_end $symbol]}
+ # i_value_clear/reduce $symbol
+ # i_symbol_save $symbol
+ # i_error_nonterminal $symbol
+ # i_ast_pop_rewind
+ # i_loc_pop_discard
+ # i:ok_ast_value_push
+
+ set mysvalue {}
+ set at [$mystackloc pop]
+
+ if {$myok} {
+ set mark [$mystackmark peek];# Old size of stack before current nt pushed more.
+ set newa [expr {[$mystackast size] - $mark}]
+ set pos $at
+ incr pos
+
+ if {!$newa} {
+ set mysvalue {}
+ } elseif {$newa == 1} {
+ # peek 1 => single element comes back
+ set mysvalue [list [$mystackast peek]] ; # SaveToMark
+ } else {
+ # peek n > 1 => list of elements comes back
+ set mysvalue [$mystackast peekr $newa] ; # SaveToMark
+ }
+
+ if {$at == $myloc} {
+ # The symbol did not process any input. As this is
+ # signaled to be ok (*) we create a node covering an
+ # empty range. (Ad *): Can happen for a RHS using
+ # toplevel operators * or ?.
+ set mysvalue [pt::ast new0 $symbol $pos {*}$mysvalue]
+ } else {
+ set mysvalue [pt::ast new $symbol $pos $myloc {*}$mysvalue] ; # Reduce $symbol
+ }
+ }
+
+ set k [list $at $symbol]
+ set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
+
+ # si:reduce_symbol_end / i_error_nonterminal -- inlined -- disabled
+ if {0} {if {[llength $myerror]} {
+ set pos $at
+ incr pos
+ lassign $myerror loc messages
+ if {$loc == $pos} {
+ set myerror [list $loc [list [list n $symbol]]]
+ }
+ }}
+
+ $mystackast trim* [$mystackmark pop]
+ if {$myok} {
+ $mystackast push $mysvalue
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:void_leaf_symbol_end {symbol} {
+ debug.pt/rdengine {[Instruction si:void_leaf_symbol_end $symbol]}
+ # i_value_clear/leaf $symbol
+ # i_symbol_save $symbol
+ # i_error_nonterminal $symbol
+ # i_loc_pop_discard
+ # i:ok_ast_value_push
+
+ set mysvalue {}
+ set at [$mystackloc pop]
+
+ if {$myok} {
+ set pos $at
+ incr pos
+ if {$at == $myloc} {
+ # The symbol did not process any input. As this is
+ # signaled to be ok (*) we create a node covering an
+ # empty range. (Ad *): Can happen for a RHS using
+ # toplevel operators * or ?.
+ set mysvalue [pt::ast new0 $symbol $pos]
+ } else {
+ set mysvalue [pt::ast new $symbol $pos $myloc]
+ }
+ }
+
+ set k [list $at $symbol]
+ set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
+
+ # si:void_leaf_symbol_end / i_error_nonterminal -- inlined -- disabled
+ if {0} {if {[llength $myerror]} {
+ set pos $at
+ incr pos
+ lassign $myerror loc messages
+ if {$loc == $pos} {
+ set myerror [list $loc [list [list n $symbol]]]
+ }
+ }}
+
+ if {$myok} {
+ $mystackast push $mysvalue
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:value_leaf_symbol_end {symbol} {
+ debug.pt/rdengine {[Instruction si:value_leaf_symbol_end $symbol]}
+ # i_value_clear/leaf $symbol
+ # i_symbol_save $symbol
+ # i_error_nonterminal $symbol
+ # i_loc_pop_discard
+ # i_ast_pop_rewind
+ # i:ok_ast_value_push
+
+ set mysvalue {}
+ set at [$mystackloc pop]
+
+ if {$myok} {
+ set pos $at
+ incr pos
+ if {$at == $myloc} {
+ # The symbol did not process any input. As this is
+ # signaled to be ok (*) we create a node covering an
+ # empty range. (Ad *): Can happen for a RHS using
+ # toplevel operators * or ?.
+ set mysvalue [pt::ast new0 $symbol $pos]
+ } else {
+ set mysvalue [pt::ast new $symbol $pos $myloc]
+ }
+ }
+
+ set k [list $at $symbol]
+ set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
+
+ # si:value_leaf_symbol_end / i_error_nonterminal -- inlined -- disabled
+ if {0} {if {[llength $myerror]} {
+ set pos $at
+ incr pos
+ lassign $myerror loc messages
+ if {$loc == $pos} {
+ set myerror [list $loc [list [list n $symbol]]]
+ }
+ }}
+
+ $mystackast trim* [$mystackmark pop]
+ if {$myok} {
+ $mystackast push $mysvalue
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:value_clear_symbol_end {symbol} {
+ debug.pt/rdengine {[Instruction si:value_clear_symbol_end $symbol]}
+ # i_value_clear
+ # i_symbol_save $symbol
+ # i_error_nonterminal $symbol
+ # i_loc_pop_discard
+ # i_ast_pop_rewind
+
+ set mysvalue {}
+ set at [$mystackloc pop]
+
+ set k [list $at $symbol]
+ set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
+
+ # si:value_clear_symbol_end / i_error_nonterminal -- inlined -- disabled
+ if {0} {if {[llength $myerror]} {
+ set pos $at
+ incr pos
+ lassign $myerror loc messages
+ if {$loc == $pos} {
+ set myerror [list $loc [list [list n $symbol]]]
+ }
+ }}
+
+ $mystackast trim* [$mystackmark pop]
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:void_clear_symbol_end {symbol} {
+ debug.pt/rdengine {[Instruction si:void_clear_symbol_end $symbol]}
+ # i_value_clear
+ # i_symbol_save $symbol
+ # i_error_nonterminal $symbol
+ # i_loc_pop_discard
+
+ set mysvalue {}
+ set at [$mystackloc pop]
+
+ set k [list $at $symbol]
+ set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
+
+ # si:void_clear_symbol_end / i_error_nonterminal -- inlined -- disabled
+ if {0} {if {[llength $myerror]} {
+ set pos $at
+ incr pos
+ lassign $myerror loc messages
+ if {$loc == $pos} {
+ set myerror [list $loc [list [list n $symbol]]]
+ }
+ }}
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - Control flow
+
+ method i:ok_continue {} {
+ debug.pt/rdengine {[Instruction i:ok_continue]}
+ if {!$myok} return
+ return -code continue
+ }
+
+ method i:fail_continue {} {
+ debug.pt/rdengine {[Instruction i:fail_continue]}
+ if {$myok} return
+ return -code continue
+ }
+
+ method i:fail_return {} {
+ debug.pt/rdengine {[Instruction i:fail_return]}
+ if {$myok} return
+ return -code return
+ }
+
+ method i:ok_return {} {
+ debug.pt/rdengine {[Instruction i:ok_return]}
+ if {!$myok} return
+ return -code return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - Unconditional matching.
+
+ method i_status_ok {} {
+ debug.pt/rdengine {[Instruction i_status_ok]}
+ set myok 1
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_status_fail {} {
+ debug.pt/rdengine {[Instruction i_status_fail]}
+ set myok 0
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_status_negate {} {
+ debug.pt/rdengine {[Instruction i_status_negate]}
+ set myok [expr {!$myok}]
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - Error handling.
+
+ method i_error_clear {} {
+ debug.pt/rdengine {[Instruction i_error_clear]}
+ set myerror {}
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_error_push {} {
+ debug.pt/rdengine {[Instruction i_error_push]}
+ $mystackerr push $myerror
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_error_clear_push {} {
+ debug.pt/rdengine {[Instruction i_error_clear_push]}
+ set myerror {}
+ $mystackerr push {}
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_error_pop_merge {} {
+ debug.pt/rdengine {[Instruction i_error_pop_merge]}
+ set olderror [$mystackerr pop]
+
+ # We have either old or new error data, keep it.
+
+ if {![llength $myerror]} { set myerror $olderror ; debug.pt/rdengine {[InstReturn]} ; return }
+ if {![llength $olderror]} { debug.pt/rdengine {[InstReturn]} ; return }
+
+ # If one of the errors is further on in the input choose that as
+ # the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} { set myerror $olderror ; debug.pt/rdengine {[InstReturn]} ; return }
+ if {$loe > $lon} { debug.pt/rdengine {[InstReturn]} ; return }
+
+ # Equal locations, merge the message lists.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_error_nonterminal {symbol} {
+ debug.pt/rdengine {[Instruction i_error_nonterminal $symbol]}
+ # i_error_nonterminal -- Disabled. Generate only low-level
+ # i_error_nonterminal -- errors until we have worked out how
+ # i_error_nonterminal -- to integrate symbol information with
+ # i_error_nonterminal -- them. Do not forget where this
+ # i_error_nonterminal -- instruction is inlined.
+ return
+
+ # Inlined: Errors, Expected.
+ if {![llength $myerror]} {
+ debug.pt/rdengine {no error}
+ return
+ }
+ set pos [$mystackloc peek]
+ incr pos
+ lassign $myerror loc messages
+ if {$loc != $pos} {
+ debug.pt/rdengine {my $myerror != pos $pos}
+ return
+ }
+ set myerror [list $loc [list [list n $symbol]]]
+
+ debug.pt/rdengine {::= ($myerror)}
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - Basic input handling and tracking
+
+ method i_loc_pop_rewind/discard {} {
+ debug.pt/rdengine {[Instruction i_loc_pop_rewind/discard]}
+ #$myparser i:fail_loc_pop_rewind
+ #$myparser i:ok_loc_pop_discard
+ #return
+ set last [$mystackloc pop]
+ if {!$myok} {
+ set myloc $last
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_loc_pop_discard {} {
+ debug.pt/rdengine {[Instruction i_loc_pop_discard]}
+ $mystackloc pop
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # i:ok_loc_pop_discard - all uses inlined
+
+ method i_loc_pop_rewind {} {
+ debug.pt/rdengine {[Instruction i_loc_pop_rewind]}
+ set myloc [$mystackloc pop]
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i:fail_loc_pop_rewind {} {
+ debug.pt/rdengine {[Instruction i:fail_loc_pop_rewind]}
+ if {!$myok} {
+ set myloc [$mystackloc pop]
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_loc_push {} {
+ debug.pt/rdengine {[Instruction i_loc_push]}
+ $mystackloc push $myloc
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_loc_rewind {} {
+ debug.pt/rdengine {[Instruction i_loc_rewind]}
+ # i_loc_pop_rewind - set myloc [$mystackloc pop]
+ # i_loc_push - $mystackloc push $myloc
+ set myloc [$mystackloc peek]
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - AST stack handling
+
+ method i_ast_pop_rewind/discard {} {
+ debug.pt/rdengine {[Instruction i_ast_pop_rewind/discard]}
+ #$myparser i:fail_ast_pop_rewind
+ #$myparser i:ok_ast_pop_discard
+ #return
+ set mark [$mystackmark pop]
+ if {!$myok} {
+ $mystackast trim* $mark
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_ast_pop_discard/rewind {} {
+ debug.pt/rdengine {[Instruction i_ast_pop_discard/rewind]}
+ #$myparser i:ok_ast_pop_rewind
+ #$myparser i:fail_ast_pop_discard
+ #return
+ set mark [$mystackmark pop]
+ if {$myok} {
+ $mystackast trim* $mark
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_ast_pop_discard {} {
+ debug.pt/rdengine {[Instruction i_ast_pop_discard]}
+ $mystackmark pop
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # i:ok_ast_pop_discard - all uses inlined
+
+ method i_ast_pop_rewind {} {
+ debug.pt/rdengine {[Instruction i_ast_pop_rewind]}
+ $mystackast trim* [$mystackmark pop]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i:fail_ast_pop_rewind {} {
+ debug.pt/rdengine {[Instruction i:fail_ast_pop_rewind]}
+ if {!$myok} {
+ $mystackast trim* [$mystackmark pop]
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_ast_push {} {
+ debug.pt/rdengine {[Instruction i_ast_push]}
+ $mystackmark push [$mystackast size]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i:ok_ast_value_push {} {
+ debug.pt/rdengine {[Instruction i:ok_ast_value_push]}
+ if {$myok} {
+ $mystackast push $mysvalue
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # i_ast_rewind - all uses inlined
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - Nonterminal cache
+
+ method i_symbol_restore {symbol} {
+ debug.pt/rdengine {[Instruction i_symbol_restore $symbol]}
+ # Satisfy from cache if possible.
+ set k [list $myloc $symbol]
+ if {![info exists mysymbol($k)]} {
+ debug.pt/rdengine {[InstReturn]}
+ return 0
+ }
+ lassign $mysymbol($k) myloc myok myerror mysvalue
+ # We go forward, as the nonterminal matches (or not).
+ debug.pt/rdengine {[InstReturn]}
+ return 1
+ }
+
+ method i_symbol_save {symbol} {
+ debug.pt/rdengine {[Instruction i_symbol_save $symbol]}
+ # Store not only the value, but also how far
+ # the match went (if it was a match).
+ set at [$mystackloc peek]
+ set k [list $at $symbol]
+ set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - Semantic values.
+
+ method i_value_clear {} {
+ debug.pt/rdengine {[Instruction i_value_clear]}
+ set mysvalue {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_value_clear/leaf {symbol} {
+ debug.pt/rdengine {[Instruction i_value_clear/leaf $symbol] :: ([expr {[$mystackloc peek]+1}])-@$myloc)}
+
+ # not quite value_lead (guarded, and clear on fail)
+ # Inlined clear, reduce, and optimized.
+ # Clear ; if {$ok} {Reduce $symbol}
+ set mysvalue {}
+ if {$myok} {
+ set pos [$mystackloc peek]
+ incr pos
+
+ if {($pos - 1) == $myloc} {
+ # The symbol did not process any input. As this is
+ # signaled to be ok (*) we create a node covering an
+ # empty range. (Ad *): Can happen for a RHS using
+ # toplevel operators * or ?.
+ set mysvalue [pt::ast new0 $symbol $pos]
+ } else {
+ set mysvalue [pt::ast new $symbol $pos $myloc]
+ }
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_value_clear/reduce {symbol} {
+ debug.pt/rdengine {[Instruction i_value_clear/reduce $symbol]}
+ set mysvalue {}
+ if {$myok} {
+ set mark [$mystackmark peek];# Old size of stack before current nt pushed more.
+ set newa [expr {[$mystackast size] - $mark}]
+
+ set pos [$mystackloc peek]
+ incr pos
+
+ if {!$newa} {
+ set mysvalue {}
+ } elseif {$newa == 1} {
+ # peek 1 => single element comes back
+ set mysvalue [list [$mystackast peek]] ; # SaveToMark
+ } else {
+ # peek n > 1 => list of elements comes back
+ set mysvalue [$mystackast peekr $newa] ; # SaveToMark
+ }
+
+ if {($pos - 1) == $myloc} {
+ # The symbol did not process any input. As this is
+ # signaled to be ok (*) we create a node covering an
+ # empty range. (Ad *): Can happen for a RHS using
+ # toplevel operators * or ?.
+ set mysvalue [pt::ast new0 $symbol $pos {*}$mysvalue]
+ } else {
+ set mysvalue [pt::ast new $symbol $pos $myloc {*}$mysvalue] ; # Reduce $symbol
+ }
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - Terminal matching
+
+ method i_input_next {msg} {
+ debug.pt/rdengine {[Instruction i_input_next $msg]}
+ # Inlined: Getch, Expected, ClearErrors
+ # Satisfy from input cache if possible.
+
+ incr myloc
+ # May read from the input (ExtendTC), and remember the
+ # information. Note: We are implicitly incrementing the
+ # location!
+ if {($myloc >= [string length $mytoken]) && ![my ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list $msg]]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok 1
+ set myerror {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_char {tok} {
+ debug.pt/rdengine {[Instruction i_test_char $tok] :: ok [expr {$tok eq $mycurrent}], [expr {$tok eq $mycurrent ? "@$myloc" : "back@[expr {$myloc-1}]"}]}
+ set myok [expr {$tok eq $mycurrent}]
+ my OkFailD {pt::pe terminal $tok}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_range {toks toke} {
+ debug.pt/rdengine {[Instruction i_test_range $toks $toke]}
+ set myok [expr {
+ ([string compare $toks $mycurrent] <= 0) &&
+ ([string compare $mycurrent $toke] <= 0)
+ }] ; # {}
+ my OkFailD {pt::pe range $toks $toke}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_alnum {} {
+ debug.pt/rdengine {[Instruction i_test_alnum]}
+ set myok [string is alnum -strict $mycurrent]
+ my OkFailD {pt::pe alnum}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_alpha {} {
+ debug.pt/rdengine {[Instruction i_test_alpha]}
+ set myok [string is alpha -strict $mycurrent]
+ my OkFailD {pt::pe alpha}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_ascii {} {
+ debug.pt/rdengine {[Instruction i_test_ascii]}
+ set myok [string is ascii -strict $mycurrent]
+ my OkFailD {pt::pe ascii}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_control {} {
+ debug.pt/rdengine {[Instruction i_test_control]}
+ set myok [string is control -strict $mycurrent]
+ my OkFailD {pt::pe control}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_ddigit {} {
+ debug.pt/rdengine {[Instruction i_test_ddigit]}
+ set myok [string match {[0-9]} $mycurrent]
+ my OkFailD {pt::pe ddigit}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_digit {} {
+ debug.pt/rdengine {[Instruction i_test_digit]}
+ set myok [string is digit -strict $mycurrent]
+ my OkFailD {pt::pe digit}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_graph {} {
+ debug.pt/rdengine {[Instruction i_test_graph]}
+ set myok [string is graph -strict $mycurrent]
+ my OkFailD {pt::pe graph}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_lower {} {
+ debug.pt/rdengine {[Instruction i_test_lower]}
+ set myok [string is lower -strict $mycurrent]
+ my OkFailD {pt::pe lower}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_print {} {
+ debug.pt/rdengine {[Instruction i_test_print]}
+ set myok [string is print -strict $mycurrent]
+ my OkFailD {pt::pe printable}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_punct {} {
+ debug.pt/rdengine {[Instruction i_test_punct]}
+ set myok [string is punct -strict $mycurrent]
+ my OkFailD {pt::pe punct}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_space {} {
+ debug.pt/rdengine {[Instruction i_test_space]}
+ set myok [string is space -strict $mycurrent]
+ my OkFailD {pt::pe space}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_upper {} {
+ debug.pt/rdengine {[Instruction i_test_upper]}
+ set myok [string is upper -strict $mycurrent]
+ my OkFailD {pt::pe upper}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_wordchar {} {
+ debug.pt/rdengine {[Instruction i_test_wordchar]}
+ set myok [string is wordchar -strict $mycurrent]
+ my OkFailD {pt::pe wordchar}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_xdigit {} {
+ debug.pt/rdengine {[Instruction i_test_xdigit]}
+ set myok [string is xdigit -strict $mycurrent]
+ my OkFailD {pt::pe xdigit}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## Internals
+
+ method ExtendTC {} {
+ if {($mychan eq {}) ||
+ [eof $mychan]} {return 0}
+
+ set ch [read $mychan 1]
+ if {$ch eq {}} {
+ return 0
+ }
+
+ append mytoken $ch
+ return 1
+ }
+
+ method ExtendTCN {n} {
+ if {($mychan eq {}) ||
+ [eof $mychan]} {return 0}
+
+ set str [read $mychan $n]
+ set k [string length $str]
+
+ append mytoken $str
+ if {$k < $n} {
+ return 0
+ }
+
+ return 1
+ }
+
+ method OkFailD {msgcmd} {
+ # Inlined: Expected, Unget, ClearErrors
+ if {!$myok} {
+ set myerror [list $myloc [list [uplevel 1 $msgcmd]]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## Data structures.
+ ## Mainly the architectural state of the instance's PARAM.
+
+ variable \
+ mychan mycurrent myloc mystackloc \
+ myok mysvalue myerror mystackerr \
+ mytoken mysymbol mystackast mystackmark \
+ mytracecounter
+
+ # Parser Input (channel, location (line, column)) ...........
+ # Token, current parsing location, stack of locations .......
+ # Match state . ........ ............. .....................
+ # Caches for tokens and nonterminals .. .....................
+ # Abstract syntax tree (AST) .......... .....................
+
+ # # ## ### ##### ######## ############# #####################
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+package provide pt::rde::oo 1.1
+return
diff --git a/tcllib/modules/pt/pt_rdengine_tcl.tcl b/tcllib/modules/pt/pt_rdengine_tcl.tcl
new file mode 100644
index 0000000..fce660f
--- /dev/null
+++ b/tcllib/modules/pt/pt_rdengine_tcl.tcl
@@ -0,0 +1,2282 @@
+# -*- tcl -*-
+#
+# Copyright (c) 2009-2015 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# # ## ### ##### ######## ############# #####################
+## Package description
+
+## Implementation of the PackRat Machine (PARAM), a virtual machine on
+## top of which parsers for Parsing Expression Grammars (PEGs) can be
+## realized. This implementation is tied to Tcl for control flow. We
+## (will) have alternate implementations written in TclOO, and critcl,
+## all exporting the same API.
+#
+## RD stands for Recursive Descent.
+
+# # ## ### ##### ######## ############# #####################
+## Requisites
+
+package require Tcl 8.5
+package require snit
+package require struct::stack 1.5 ; # Requiring peekr, getr, get, trim* methods
+package require pt::ast
+package require pt::pe
+
+# # ## ### ##### ######## ############# #####################
+## Support narrative tracing.
+
+package require debug
+debug level pt/rdengine
+debug prefix pt/rdengine {}
+
+
+# # ## ### ##### ######## ############# #####################
+## Implementation
+
+snit::type ::pt::rde_tcl {
+ # # ## ### ##### ######## ############# #####################
+ ## Instruction counter for tracing. Unused else. Plus other helpers.
+ variable trace 0
+
+ proc Instruction {label {a {}} {b {}}} {
+ upvar 1 self self trace trace myok myok myloc myloc mycurrent mycurrent mysvalue mysvalue myerror myerror __inst theinst
+ set theinst [list $label $a $b]
+ return "$self <<[format %08d [incr trace]]>> START I:[format %-30s $label] [format %-10s $a] [format %-10s $b] :: [State]"
+ }
+
+ proc InstReturn {} {
+ upvar 1 self self trace trace myok myok myloc myloc mycurrent mycurrent mysvalue mysvalue myerror myerror __inst theinst
+ lassign $theinst label a b
+ return "$self <<[format %08d $trace]>> END__ I:[format %-30s $label] [format %-10s $a] [format %-10s $b] :: [State]"
+ }
+
+ proc State {} {
+ upvar 1 myok myok myloc myloc mycurrent mycurrent mysvalue mysvalue myerror myerror
+ return "ST $myok CL $myloc CC ($mycurrent) SV ($mysvalue) ER ($myerror)"
+ }
+
+ proc TraceSetupStacks {} {
+ upvar selfns selfns
+
+ # Move stack instances aside.
+ rename ${selfns}::LOC ${selfns}::LOC__
+ rename ${selfns}::ERR ${selfns}::ERR__
+ rename ${selfns}::AST ${selfns}::AST__
+ rename ${selfns}::MARK ${selfns}::MRK__
+
+ # Create procedures doing tracing, and forwarding to the
+ # renamed actual instances.
+
+ interp alias {} ${selfns}::LOC {} ${selfns}::WRAP LS LOC__
+ interp alias {} ${selfns}::ERR {} ${selfns}::WRAP ES ERR__
+ interp alias {} ${selfns}::AST {} ${selfns}::WRAP ARS AST__
+ interp alias {} ${selfns}::MARK {} ${selfns}::WRAP ASM MRK__
+
+ proc ${selfns}::WRAP {label stack args} {
+ debug.pt/rdengine { $label ___ $args}
+ set res [$stack {*}$args]
+
+ # Show state state after the op
+ set n [$stack size]
+ if {!$n} {
+ set c {()}
+ } elseif {$n == 1} {
+ set c <<[$stack peek $n]>>
+ } else {
+ set c <<[join [$stack peek $n] {>> <<}]>>
+ }
+ debug.pt/rdengine { $label == ($n):$c}
+
+ # And op return
+ debug.pt/rdengine { $label ==> ($res)}
+ return $res
+ }
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Lifecycle
+
+ constructor {} {
+ debug.pt/rdengine {$self constructor}
+
+ set mystackloc [struct::stack ${selfns}::LOC] ; # LS
+ set mystackerr [struct::stack ${selfns}::ERR] ; # ES
+ set mystackast [struct::stack ${selfns}::AST] ; # ARS/AS
+ set mystackmark [struct::stack ${selfns}::MARK] ; # s.a.
+
+ debug.pt/rdengine {[TraceSetupStacks]$self constructor /done}
+ return
+ }
+
+ method reset {{chan {}}} {
+ debug.pt/rdengine {$self reset ($chan)}
+
+ set mychan $chan ; # IN
+ set mycurrent {} ; # CC
+ set myloc -1 ; # CL
+ set myok 0 ; # ST
+ set msvalue {} ; # SV
+ set myerror {} ; # ER
+ set mytoken {} ; # TC (string)
+ array unset mysymbol * ; # NC
+
+ $mystackloc clear
+ $mystackerr clear
+ $mystackast clear
+ $mystackmark clear
+
+ debug.pt/rdengine {$self reset /done}
+ return
+ }
+
+ method complete {} {
+ debug.pt/rdengine {$self complete [State]}
+
+ if {$myok} {
+ set n [$mystackast size]
+ debug.pt/rdengine {$self complete ast $n}
+ if {$n > 1} {
+ # Multiple ASTs left, reduce into single containing them.
+ set pos [$mystackloc peek]
+ incr pos
+ set children [$mystackast peekr [$mystackast size]] ; # SaveToMark
+ set ast [pt::ast new {} $pos $myloc {*}$children] ; # Reduce ALL
+
+ debug.pt/rdengine {$self complete n ==> ($ast)}
+ return $ast
+ } elseif {$n == 0} {
+ # Match, but no AST. This is possible if the grammar
+ # consists of only the start expression.
+
+ debug.pt/rdengine {$self complete 0 ==> ()}
+ return {}
+ } else {
+ # Match, with AST.
+ set ast [$mystackast peek]
+ debug.pt/rdengine {$self complete 1 ==> ($ast)}
+ return $ast
+ }
+ } else {
+ lassign $myerror loc messages
+ return -code error \
+ -errorcode {PT RDE SYNTAX} \
+ [list pt::rde $loc $messages]
+ }
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - State accessors
+
+ method chan {} { debug.pt/rdengine {$self chan} ; return $mychan }
+
+ # - - -- --- ----- --------
+
+ method current {} { debug.pt/rdengine {$self current} ; return $mycurrent }
+ method location {} { debug.pt/rdengine {$self location} ; return $myloc }
+ method lmarked {} { debug.pt/rdengine {$self lmarked} ; return [$mystackloc getr] }
+
+ # - - -- --- ----- --------
+
+ method ok {} { debug.pt/rdengine {$self ok} ; return $myok }
+ method value {} { debug.pt/rdengine {$self value} ; return $mysvalue }
+ method error {} { debug.pt/rdengine {$self error} ; return $myerror }
+ method emarked {} { debug.pt/rdengine {$self emarked} ; return [$mystackerr getr] }
+
+ # - - -- --- ----- --------
+
+ method tokens {{from {}} {to {}}} {
+ debug.pt/rdengine {$self tokens ($from) ($to)}
+ switch -exact [llength [info level 0]] {
+ 5 { return $mytoken }
+ 6 { return [string range $mytoken $from $from] }
+ 7 { return [string range $mytoken $from $to] }
+ }
+ }
+
+ method symbols {} {
+ debug.pt/rdengine {$self symbols}
+ return [array get mysymbol]
+ }
+
+ method scached {} {
+ debug.pt/rdengine {$self scached}
+ return [array names mysymbol]
+ }
+
+ # - - -- --- ----- --------
+
+ method asts {} { debug.pt/rdengine {$self asts} ; return [$mystackast getr] }
+ method amarked {} { debug.pt/rdengine {$self amarked} ; return [$mystackmark getr] }
+ method ast {} { debug.pt/rdengine {$self ast} ; return [$mystackast peek] }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Preloading the token cache.
+
+ method data {data} {
+ debug.pt/rdengine {$self data +[string length $data]}
+ append mytoken $data
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## Common instruction sequences
+
+ method si:void_state_push {} {
+ debug.pt/rdengine {[Instruction si:void_state_push]}
+ # i_loc_push
+ # i_error_clear_push
+ $mystackloc push $myloc
+ set myerror {}
+ $mystackerr push {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:void2_state_push {} {
+ debug.pt/rdengine {[Instruction si:void2_state_push]}
+ # i_loc_push
+ # i_error_push
+ $mystackloc push $myloc
+ $mystackerr push {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:value_state_push {} {
+ debug.pt/rdengine {[Instruction si:value_state_push]}
+ # i_ast_push
+ # i_loc_push
+ # i_error_clear_push
+ $mystackmark push [$mystackast size]
+ $mystackloc push $myloc
+ set myerror {}
+ $mystackerr push {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:void_state_merge {} {
+ debug.pt/rdengine {[Instruction si:void_state_merge]}
+ # i_error_pop_merge
+ # i_loc_pop_rewind/discard
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+
+ set last [$mystackloc pop]
+ if {!$myok} {
+ set myloc $last
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:void_state_merge_ok {} {
+ debug.pt/rdengine {[Instruction si:void_state_merge_ok]}
+ # i_error_pop_merge
+ # i_loc_pop_rewind/discard
+ # i_status_ok
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+
+ set last [$mystackloc pop]
+ if {!$myok} {
+ set myloc $last
+ set myok 1
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:value_state_merge {} {
+ debug.pt/rdengine {[Instruction si:value_state_merge]}
+ # i_error_pop_merge
+ # i_ast_pop_rewind/discard
+ # i_loc_pop_rewind/discard
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+
+ set mark [$mystackmark pop]
+ set last [$mystackloc pop]
+ if {!$myok} {
+ $mystackast trim* $mark
+ set myloc $last
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:value_notahead_start {} {
+ debug.pt/rdengine {[Instruction si:value_notahead_start]}
+ # i_loc_push
+ # i_ast_push
+
+ $mystackloc push $myloc
+ $mystackmark push [$mystackast size]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:void_notahead_exit {} {
+ debug.pt/rdengine {[Instruction si:void_notahead_exit]}
+ # i_loc_pop_rewind
+ # i_status_negate
+
+ set myloc [$mystackloc pop]
+ set myok [expr {!$myok}]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:value_notahead_exit {} {
+ debug.pt/rdengine {[Instruction si:value_notahead_exit]}
+ # i_ast_pop_discard/rewind
+ # i_loc_pop_rewind
+ # i_status_negate
+
+ set mark [$mystackmark pop]
+ if {$myok} {
+ $mystackast trim* $mark
+ }
+ set myloc [$mystackloc pop]
+ set myok [expr {!$myok}]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:kleene_abort {} {
+ debug.pt/rdengine {[Instruction si:kleene_abort]}
+ # i_loc_pop_rewind/discard
+ # i:fail_return
+
+ set last [$mystackloc pop]
+ if {$myok} {
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set myloc $last
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+
+ method si:kleene_close {} {
+ debug.pt/rdengine {[Instruction si:kleene_close]}
+ # i_error_pop_merge
+ # i_loc_pop_rewind/discard
+ # i:fail_status_ok
+ # i:fail_return
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+
+ set last [$mystackloc pop]
+ if {$myok} {
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set myok 1
+ set myloc $last
+
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:voidvoid_branch {} {
+ debug.pt/rdengine {[Instruction si:voidvoid_branch]}
+ # i_error_pop_merge
+ # i:ok_loc_pop_discard
+ # i:ok_return
+ # i_loc_rewind
+ # i_error_push
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+
+ if {$myok} {
+ $mystackloc pop
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ set myloc [$mystackloc peek]
+ $mystackerr push $myerror
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:voidvalue_branch {} {
+ debug.pt/rdengine {[Instruction si:voidvalue_branch]}
+ # i_error_pop_merge
+ # i:ok_loc_pop_discard
+ # i:ok_return
+ # i_ast_push
+ # i_loc_rewind
+ # i_error_push
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+
+ if {$myok} {
+ $mystackloc pop
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackmark push [$mystackast size]
+ set myloc [$mystackloc peek]
+ $mystackerr push {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:valuevoid_branch {} {
+ debug.pt/rdengine {[Instruction si:valuevoid_branch]}
+ # i_error_pop_merge
+ # i_ast_pop_rewind/discard
+ # i:ok_loc_pop_discard
+ # i:ok_return
+ # i_loc_rewind
+ # i_error_push
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+ set mark [$mystackmark pop]
+ if {$myok} {
+ $mystackloc pop
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackast trim* $mark
+ set myloc [$mystackloc peek]
+ $mystackerr push {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:valuevalue_branch {} {
+ debug.pt/rdengine {[Instruction si:valuevalue_branch]}
+ # i_error_pop_merge
+ # i_ast_pop_discard
+ # i:ok_loc_pop_discard
+ # i:ok_return
+ # i_ast_rewind
+ # i_loc_rewind
+ # i_error_push
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+ if {$myok} {
+ $mystackmark pop
+ $mystackloc pop
+
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackast trim* [$mystackmark peek]
+ set myloc [$mystackloc peek]
+ $mystackerr push {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:voidvoid_part {} {
+ debug.pt/rdengine {[Instruction si:voidvoid_part]}
+ # i_error_pop_merge
+ # i:fail_loc_pop_rewind
+ # i:fail_return
+ # i_error_push
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+ if {!$myok} {
+ set myloc [$mystackloc pop]
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackerr push $myerror
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:voidvalue_part {} {
+ debug.pt/rdengine {[Instruction si:voidvalue_part]}
+ # i_error_pop_merge
+ # i:fail_loc_pop_rewind
+ # i:fail_return
+ # i_ast_push
+ # i_error_push
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+ if {!$myok} {
+ set myloc [$mystackloc pop]
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackmark push [$mystackast size]
+ $mystackerr push $myerror
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:valuevalue_part {} {
+ debug.pt/rdengine {[Instruction si:valuevalue_part]}
+ # i_error_pop_merge
+ # i:fail_ast_pop_rewind
+ # i:fail_loc_pop_rewind
+ # i:fail_return
+ # i_error_push
+
+ set olderror [$mystackerr pop]
+ # We have either old or new error data, keep it.
+ if {![llength $myerror]} {
+ set myerror $olderror
+ } elseif {[llength $olderror]} {
+ # If one of the errors is further on in the input choose
+ # that as the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} {
+ set myerror $olderror
+ } elseif {$loe == $lon} {
+ # Equal locations, merge the message lists, set-like.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ }
+ }
+ if {!$myok} {
+ $mystackast trim* [$mystackmark pop]
+ set myloc [$mystackloc pop]
+
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackerr push $myerror
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:next_str {tok} {
+ debug.pt/rdengine {[Instruction si:next_str $tok]}
+ # String = sequence of characters.
+ # No need for all the intermediate stack churn.
+
+ set n [string length $tok]
+ set last [expr {$myloc + $n}]
+ set max [string length $mytoken]
+
+ incr myloc
+ if {($last >= $max) && ![ExtendTCN [expr {$last - $max + 1}]]} {
+ set myok 0
+ set myerror [list $myloc [list [pt::pe str $tok]]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set lex [string range $mytoken $myloc $last]
+ set mycurrent [string index $mytoken $last]
+
+ # ATTENTION: The error output of this instruction is different
+ # from a regular sequence of si:next_char instructions. The
+ # error location will be the start of the string token we
+ # wanted to match, and the message will contain the entire
+ # string token. In the regular sequence we would see the exact
+ # point of the mismatch instead, with the message containing
+ # the expected character.
+
+ set myok [expr {$tok eq $lex}]
+
+ if {$myok} {
+ set myloc $last
+ set myerror {}
+ } else {
+ set myerror [list $myloc [list [pt::pe str $tok]]]
+ incr myloc -1
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_class {tok} {
+ debug.pt/rdengine {[Instruction si:next_class $tok]}
+ # Class = Choice of characters. No need for stack churn.
+
+ # i_input_next "\{t $c\}"
+ # i:fail_return
+ # i_test_<user class>
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list [pt::pe class $tok]]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ # Note what is needle versus hay. The token, i.e. the string
+ # of allowed characters is the hay in which the current
+ # character is looked, making it the needle.
+ set myok [expr {[string first $mycurrent $tok] >= 0}]
+
+ if {$myok} {
+ set myerror {}
+ } else {
+ set myerror [list $myloc [list [pt::pe class $tok]]]
+ incr myloc -1
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_char {tok} {
+ debug.pt/rdengine {[Instruction si:next_char $tok]}
+ # i_input_next "\{t $c\}"
+ # i:fail_return
+ # i_test_char $c
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list [pt::pe terminal $tok]]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [expr {$tok eq $mycurrent}]
+ if {$myok} {
+ set myerror {}
+ } else {
+ set myerror [list $myloc [list [pt::pe terminal $tok]]]
+ incr myloc -1
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_range {toks toke} {
+ debug.pt/rdengine {[Instruction si:next_range $toks $toke]}
+ #Asm::Ins i_input_next "\{.. $s $e\}"
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_range $s $e
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list [pt::pe range $toks $toke]]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [expr {
+ ([string compare $toks $mycurrent] <= 0) &&
+ ([string compare $mycurrent $toke] <= 0)
+ }] ; # {}
+ if {$myok} {
+ set myerror {}
+ } else {
+ set myerror [list $myloc [list [pt::pe range $toks $toke]]]
+ incr myloc -1
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:next_alnum {} {
+ debug.pt/rdengine {[Instruction si:next_alnum]}
+ #Asm::Ins i_input_next alnum
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_alnum
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list alnum]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is alnum -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list alnum]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_alpha {} {
+ debug.pt/rdengine {[Instruction si:next_alpha]}
+ #Asm::Ins i_input_next alpha
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_alpha
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list alpha]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is alpha -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list alpha]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_ascii {} {
+ debug.pt/rdengine {[Instruction si:next_ascii]}
+ #Asm::Ins i_input_next ascii
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_ascii
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list ascii]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is ascii -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list ascii]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_control {} {
+ debug.pt/rdengine {[Instruction si:next_control]}
+ #Asm::Ins i_input_next control
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_control
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list control]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is control -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list control]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_ddigit {} {
+ debug.pt/rdengine {[Instruction si:next_ddigit]}
+ #Asm::Ins i_input_next ddigit
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_ddigit
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list ddigit]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string match {[0-9]} $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list ddigit]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_digit {} {
+ debug.pt/rdengine {[Instruction si:next_digit]}
+ #Asm::Ins i_input_next digit
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_digit
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list digit]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is digit -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list digit]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_graph {} {
+ debug.pt/rdengine {[Instruction si:next_graph]}
+ #Asm::Ins i_input_next graph
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_graph
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list graph]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is graph -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list graph]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_lower {} {
+ debug.pt/rdengine {[Instruction si:next_lower]}
+ #Asm::Ins i_input_next lower
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_lower
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list lower]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is lower -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list lower]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_print {} {
+ debug.pt/rdengine {[Instruction si:next_print]}
+ #Asm::Ins i_input_next print
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_print
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list print]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is print -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list print]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_punct {} {
+ debug.pt/rdengine {[Instruction si:next_punct]}
+ #Asm::Ins i_input_next punct
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_punct
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list punct]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is punct -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list punct]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_space {} {
+ debug.pt/rdengine {[Instruction si:next_space]}
+ #Asm::Ins i_input_next space
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_space
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list space]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is space -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list space]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_upper {} {
+ debug.pt/rdengine {[Instruction si:next_upper]}
+ #Asm::Ins i_input_next upper
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_upper
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list upper]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is upper -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list upper]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_wordchar {} {
+ debug.pt/rdengine {[Instruction si:next_wordchar]}
+ #Asm::Ins i_input_next wordchar
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_wordchar
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list wordchar]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is wordchar -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list wordchar]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:next_xdigit {} {
+ debug.pt/rdengine {[Instruction si:next_xdigit]}
+ #Asm::Ins i_input_next xdigit
+ #Asm::Ins i:fail_return
+ #Asm::Ins i_test_xdigit
+
+ incr myloc
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list xdigit]]
+ # i:fail_return
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok [string is xdigit -strict $mycurrent]
+ if {!$myok} {
+ set myerror [list $myloc [list xdigit]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # - -- --- ----- -------- ------------- ---------------------
+
+ method si:value_symbol_start {symbol} {
+ debug.pt/rdengine {[Instruction si:value_symbol_start $symbol]}
+ # if @runtime@ i_symbol_restore $symbol
+ # i:found:ok_ast_value_push
+ # i:found_return
+ # i_loc_push
+ # i_ast_push
+
+ set k [list $myloc $symbol]
+ if {[info exists mysymbol($k)]} {
+ lassign $mysymbol($k) myloc myok myerror mysvalue
+ if {$myok} {
+ $mystackast push $mysvalue
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackloc push $myloc
+ $mystackmark push [$mystackast size]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:value_void_symbol_start {symbol} {
+ debug.pt/rdengine {[Instruction si:value_void_symbol_start $symbol]}
+ # if @runtime@ i_symbol_restore $symbol
+ # i:found_return
+ # i_loc_push
+ # i_ast_push
+
+ set k [list $myloc $symbol]
+ if {[info exists mysymbol($k)]} {
+ lassign $mysymbol($k) myloc myok myerror mysvalue
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackloc push $myloc
+ $mystackmark push [$mystackast size]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:void_symbol_start {symbol} {
+ debug.pt/rdengine {[Instruction si:void_symbol_start $symbol]}
+ # if @runtime@ i_symbol_restore $symbol
+ # i:found:ok_ast_value_push
+ # i:found_return
+ # i_loc_push
+
+ set k [list $myloc $symbol]
+ if {[info exists mysymbol($k)]} {
+ lassign $mysymbol($k) myloc myok myerror mysvalue
+ if {$myok} {
+ $mystackast push $mysvalue
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackloc push $myloc
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:void_void_symbol_start {symbol} {
+ debug.pt/rdengine {[Instruction si:void_void_symbol_start $symbol]}
+ # if @runtime@ i_symbol_restore $symbol
+ # i:found_return
+ # i_loc_push
+
+ set k [list $myloc $symbol]
+ if {[info exists mysymbol($k)]} {
+ lassign $mysymbol($k) myloc myok myerror mysvalue
+ debug.pt/rdengine {[InstReturn]}
+ return -code return
+ }
+ $mystackloc push $myloc
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:reduce_symbol_end {symbol} {
+ debug.pt/rdengine {[Instruction si:reduce_symbol_end $symbol]}
+ # i_value_clear/reduce $symbol
+ # i_symbol_save $symbol
+ # i_error_nonterminal $symbol
+ # i_ast_pop_rewind
+ # i_loc_pop_discard
+ # i:ok_ast_value_push
+
+ set mysvalue {}
+ set at [$mystackloc pop]
+
+ if {$myok} {
+ set mark [$mystackmark peek];# Old size of stack before current nt pushed more.
+ set newa [expr {[$mystackast size] - $mark}]
+ set pos $at
+ incr pos
+
+ if {!$newa} {
+ set mysvalue {}
+ } elseif {$newa == 1} {
+ # peek 1 => single element comes back
+ set mysvalue [list [$mystackast peek]] ; # SaveToMark
+ } else {
+ # peek n > 1 => list of elements comes back
+ set mysvalue [$mystackast peekr $newa] ; # SaveToMark
+ }
+
+ if {$at == $myloc} {
+ # The symbol did not process any input. As this is
+ # signaled to be ok (*) we create a node covering an
+ # empty range. (Ad *): Can happen for a RHS using
+ # toplevel operators * or ?.
+ set mysvalue [pt::ast new0 $symbol $pos {*}$mysvalue]
+ } else {
+ set mysvalue [pt::ast new $symbol $pos $myloc {*}$mysvalue] ; # Reduce $symbol
+ }
+ }
+
+ set k [list $at $symbol]
+ set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
+
+ # si:reduce_symbol_end / i_error_nonterminal -- inlined -- disabled
+ if {0} {if {[llength $myerror]} {
+ set pos $at
+ incr pos
+ lassign $myerror loc messages
+ if {$loc == $pos} {
+ set myerror [list $loc [list [list n $symbol]]]
+ }
+ }}
+
+ $mystackast trim* [$mystackmark pop]
+ if {$myok} {
+ $mystackast push $mysvalue
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:void_leaf_symbol_end {symbol} {
+ debug.pt/rdengine {[Instruction si:void_leaf_symbol_end $symbol]}
+ # i_value_clear/leaf $symbol
+ # i_symbol_save $symbol
+ # i_error_nonterminal $symbol
+ # i_loc_pop_discard
+ # i:ok_ast_value_push
+
+ set mysvalue {}
+ set at [$mystackloc pop]
+
+ if {$myok} {
+ set pos $at
+ incr pos
+ if {$at == $myloc} {
+ # The symbol did not process any input. As this is
+ # signaled to be ok (*) we create a node covering an
+ # empty range. (Ad *): Can happen for a RHS using
+ # toplevel operators * or ?.
+ set mysvalue [pt::ast new0 $symbol $pos]
+ } else {
+ set mysvalue [pt::ast new $symbol $pos $myloc]
+ }
+ }
+
+ set k [list $at $symbol]
+ set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
+
+ # si:void_leaf_symbol_end / i_error_nonterminal -- inlined -- disabled
+ if {0} {if {[llength $myerror]} {
+ set pos $at
+ incr pos
+ lassign $myerror loc messages
+ if {$loc == $pos} {
+ set myerror [list $loc [list [list n $symbol]]]
+ }
+ }}
+
+ if {$myok} {
+ $mystackast push $mysvalue
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:value_leaf_symbol_end {symbol} {
+ debug.pt/rdengine {[Instruction si:value_leaf_symbol_end $symbol]}
+ # i_value_clear/leaf $symbol
+ # i_symbol_save $symbol
+ # i_error_nonterminal $symbol
+ # i_loc_pop_discard
+ # i_ast_pop_rewind
+ # i:ok_ast_value_push
+
+ set mysvalue {}
+ set at [$mystackloc pop]
+
+ if {$myok} {
+ set pos $at
+ incr pos
+ if {$at == $myloc} {
+ # The symbol did not process any input. As this is
+ # signaled to be ok (*) we create a node covering an
+ # empty range. (Ad *): Can happen for a RHS using
+ # toplevel operators * or ?.
+ set mysvalue [pt::ast new0 $symbol $pos]
+ } else {
+ set mysvalue [pt::ast new $symbol $pos $myloc]
+ }
+ }
+
+ set k [list $at $symbol]
+ set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
+
+ # si:value_leaf_symbol_end / i_error_nonterminal -- inlined -- disabled
+ if {0} {if {[llength $myerror]} {
+ set pos $at
+ incr pos
+ lassign $myerror loc messages
+ if {$loc == $pos} {
+ set myerror [list $loc [list [list n $symbol]]]
+ }
+ }}
+
+ $mystackast trim* [$mystackmark pop]
+ if {$myok} {
+ $mystackast push $mysvalue
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:value_clear_symbol_end {symbol} {
+ debug.pt/rdengine {[Instruction si:value_clear_symbol_end $symbol]}
+ # i_value_clear
+ # i_symbol_save $symbol
+ # i_error_nonterminal $symbol
+ # i_loc_pop_discard
+ # i_ast_pop_rewind
+
+ set mysvalue {}
+ set at [$mystackloc pop]
+
+ set k [list $at $symbol]
+ set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
+
+ # si:value_clear_symbol_end / i_error_nonterminal -- inlined -- disabled
+ if {0} {if {[llength $myerror]} {
+ set pos $at
+ incr pos
+ lassign $myerror loc messages
+ if {$loc == $pos} {
+ set myerror [list $loc [list [list n $symbol]]]
+ }
+ }}
+
+ $mystackast trim* [$mystackmark pop]
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method si:void_clear_symbol_end {symbol} {
+ debug.pt/rdengine {[Instruction si:void_clear_symbol_end $symbol]}
+ # i_value_clear
+ # i_symbol_save $symbol
+ # i_error_nonterminal $symbol
+ # i_loc_pop_discard
+
+ set mysvalue {}
+ set at [$mystackloc pop]
+
+ set k [list $at $symbol]
+ set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
+
+ # si:void_clear_symbol_end / i_error_nonterminal -- inlined -- disabled
+ if {0} {if {[llength $myerror]} {
+ set pos $at
+ incr pos
+ lassign $myerror loc messages
+ if {$loc == $pos} {
+ set myerror [list $loc [list [list n $symbol]]]
+ }
+ }}
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - Control flow
+
+ method i:ok_continue {} {
+ debug.pt/rdengine {[Instruction i:ok_continue]}
+ if {!$myok} return
+ return -code continue
+ }
+
+ method i:fail_continue {} {
+ debug.pt/rdengine {[Instruction i:fail_continue]}
+ if {$myok} return
+ return -code continue
+ }
+
+ method i:fail_return {} {
+ debug.pt/rdengine {[Instruction i:fail_return]}
+ if {$myok} return
+ return -code return
+ }
+
+ method i:ok_return {} {
+ debug.pt/rdengine {[Instruction i:ok_return]}
+ if {!$myok} return
+ return -code return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - Unconditional matching.
+
+ method i_status_ok {} {
+ debug.pt/rdengine {[Instruction i_status_ok]}
+ set myok 1
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_status_fail {} {
+ debug.pt/rdengine {[Instruction i_status_fail]}
+ set myok 0
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_status_negate {} {
+ debug.pt/rdengine {[Instruction i_status_negate]}
+ set myok [expr {!$myok}]
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - Error handling.
+
+ method i_error_clear {} {
+ debug.pt/rdengine {[Instruction i_error_clear]}
+ set myerror {}
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_error_push {} {
+ debug.pt/rdengine {[Instruction i_error_push]}
+ $mystackerr push $myerror
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_error_clear_push {} {
+ debug.pt/rdengine {[Instruction i_error_clear_push]}
+ set myerror {}
+ $mystackerr push {}
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_error_pop_merge {} {
+ debug.pt/rdengine {[Instruction i_error_pop_merge]}
+ set olderror [$mystackerr pop]
+
+ # We have either old or new error data, keep it.
+
+ if {![llength $myerror]} { set myerror $olderror ; debug.pt/rdengine {[InstReturn]} ; return }
+ if {![llength $olderror]} { debug.pt/rdengine {[InstReturn]} ; return }
+
+ # If one of the errors is further on in the input choose that as
+ # the information to propagate.
+
+ lassign $myerror loe msgse
+ lassign $olderror lon msgsn
+
+ if {$lon > $loe} { set myerror $olderror ; debug.pt/rdengine {[InstReturn]} ; return }
+ if {$loe > $lon} { debug.pt/rdengine {[InstReturn]} ; return }
+
+ # Equal locations, merge the message lists.
+ set myerror [list $loe [lsort -uniq [list {*}$msgse {*}$msgsn]]]
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_error_nonterminal {symbol} {
+ debug.pt/rdengine {[Instruction i_error_nonterminal $symbol]}
+ # i_error_nonterminal -- Disabled. Generate only low-level
+ # i_error_nonterminal -- errors until we have worked out how
+ # i_error_nonterminal -- to integrate symbol information with
+ # i_error_nonterminal -- them. Do not forget where this
+ # i_error_nonterminal -- instruction is inlined.
+ return
+
+ # Inlined: Errors, Expected.
+ if {![llength $myerror]} {
+ debug.pt/rdengine {no error}
+ return
+ }
+ set pos [$mystackloc peek]
+ incr pos
+ lassign $myerror loc messages
+ if {$loc != $pos} {
+ debug.pt/rdengine {my $myerror != pos $pos}
+ return
+ }
+ set myerror [list $loc [list [list n $symbol]]]
+
+ debug.pt/rdengine {::= ($myerror)}
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - Basic input handling and tracking
+
+ method i_loc_pop_rewind/discard {} {
+ debug.pt/rdengine {[Instruction i_loc_pop_rewind/discard]}
+ #$myparser i:fail_loc_pop_rewind
+ #$myparser i:ok_loc_pop_discard
+ #return
+ set last [$mystackloc pop]
+ if {!$myok} {
+ set myloc $last
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_loc_pop_discard {} {
+ debug.pt/rdengine {[Instruction i_loc_pop_discard]}
+ $mystackloc pop
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i:ok_loc_pop_discard {} {
+ debug.pt/rdengine {[Instruction i:ok_loc_pop_discard]}
+ if {$myok} {
+ $mystackloc pop
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_loc_pop_rewind {} {
+ debug.pt/rdengine {[Instruction i_loc_pop_rewind]}
+ set myloc [$mystackloc pop]
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i:fail_loc_pop_rewind {} {
+ debug.pt/rdengine {[Instruction i:fail_loc_pop_rewind]}
+ if {!$myok} {
+ set myloc [$mystackloc pop]
+ }
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_loc_push {} {
+ debug.pt/rdengine {[Instruction i_loc_push]}
+ $mystackloc push $myloc
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_loc_rewind {} {
+ debug.pt/rdengine {[Instruction i_loc_rewind]}
+ # i_loc_pop_rewind - set myloc [$mystackloc pop]
+ # i_loc_push - $mystackloc push $myloc
+ set myloc [$mystackloc peek]
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - AST stack handling
+
+ method i_ast_pop_rewind/discard {} {
+ debug.pt/rdengine {[Instruction i_ast_pop_rewind/discard]}
+ #$myparser i:fail_ast_pop_rewind
+ #$myparser i:ok_ast_pop_discard
+ #return
+ set mark [$mystackmark pop]
+ if {!$myok} {
+ $mystackast trim* $mark
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_ast_pop_discard/rewind {} {
+ debug.pt/rdengine {[Instruction i_ast_pop_discard/rewind]}
+ #$myparser i:ok_ast_pop_rewind
+ #$myparser i:fail_ast_pop_discard
+ #return
+ set mark [$mystackmark pop]
+ if {$myok} {
+ $mystackast trim* $mark
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_ast_pop_discard {} {
+ debug.pt/rdengine {[Instruction i_ast_pop_discard]}
+ $mystackmark pop
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i:ok_ast_pop_discard {} {
+ debug.pt/rdengine {[Instruction i:ok_ast_pop_discard]}
+ if {$myok} {
+ $mystackmark pop
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_ast_pop_rewind {} {
+ debug.pt/rdengine {[Instruction i_ast_pop_rewind]}
+ $mystackast trim* [$mystackmark pop]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i:fail_ast_pop_rewind {} {
+ debug.pt/rdengine {[Instruction i:fail_ast_pop_rewind]}
+ if {!$myok} {
+ $mystackast trim* [$mystackmark pop]
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_ast_push {} {
+ debug.pt/rdengine {[Instruction i_ast_push]}
+ $mystackmark push [$mystackast size]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i:ok_ast_value_push {} {
+ debug.pt/rdengine {[Instruction i:ok_ast_value_push]}
+ if {$myok} {
+ $mystackast push $mysvalue
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_ast_rewind {} {
+ debug.pt/rdengine {[Instruction i_ast_rewind]}
+ # i_ast_pop_rewind - $mystackast trim* [$mystackmark pop]
+ # i_ast_push - $mystackmark push [$mystackast size]
+
+ $mystackast trim* [$mystackmark peek]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - Nonterminal cache
+
+ method i_symbol_restore {symbol} {
+ debug.pt/rdengine {[Instruction i_symbol_restore $symbol]}
+ # Satisfy from cache if possible.
+ set k [list $myloc $symbol]
+ if {![info exists mysymbol($k)]} {
+ debug.pt/rdengine {[InstReturn]}
+ return 0
+ }
+ lassign $mysymbol($k) myloc myok myerror mysvalue
+ # We go forward, as the nonterminal matches (or not).
+ debug.pt/rdengine {[InstReturn]}
+ return 1
+ }
+
+ method i_symbol_save {symbol} {
+ debug.pt/rdengine {[Instruction i_symbol_save $symbol]}
+ # Store not only the value, but also how far
+ # the match went (if it was a match).
+ set at [$mystackloc peek]
+ set k [list $at $symbol]
+ set mysymbol($k) [list $myloc $myok $myerror $mysvalue]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - Semantic values.
+
+ method i_value_clear {} {
+ debug.pt/rdengine {[Instruction i_value_clear]}
+ set mysvalue {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_value_clear/leaf {symbol} {
+ debug.pt/rdengine {[Instruction i_value_clear/leaf $symbol] :: ([expr {[$mystackloc peek]+1}])-@$myloc)}
+
+ # not quite value_lead (guarded, and clear on fail)
+ # Inlined clear, reduce, and optimized.
+ # Clear ; if {$ok} {Reduce $symbol}
+ set mysvalue {}
+ if {$myok} {
+ set pos [$mystackloc peek]
+ incr pos
+
+ if {($pos - 1) == $myloc} {
+ # The symbol did not process any input. As this is
+ # signaled to be ok (*) we create a node covering an empty
+ # range. (Ad *): Can happen for a RHS using toplevel
+ # operators * or ?.
+ set mysvalue [pt::ast new0 $symbol $pos]
+ } else {
+ set mysvalue [pt::ast new $symbol $pos $myloc]
+ }
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_value_clear/reduce {symbol} {
+ debug.pt/rdengine {[Instruction i_value_clear/reduce $symbol]}
+ set mysvalue {}
+ if {$myok} {
+ set mark [$mystackmark peek];# Old size of stack before current nt pushed more.
+ set newa [expr {[$mystackast size] - $mark}]
+
+ set pos [$mystackloc peek]
+ incr pos
+
+ if {!$newa} {
+ set mysvalue {}
+ } elseif {$newa == 1} {
+ # peek 1 => single element comes back
+ set mysvalue [list [$mystackast peek]] ; # SaveToMark
+ } else {
+ # peek n > 1 => list of elements comes back
+ set mysvalue [$mystackast peekr $newa] ; # SaveToMark
+ }
+
+ if {($pos - 1) == $myloc} {
+ # The symbol did not process any input. As this is
+ # signaled to be ok (*) we create a node covering an empty
+ # range. (Ad *): Can happen for a RHS using toplevel
+ # operators * or ?.
+ set mysvalue [pt::ast new0 $symbol $pos {*}$mysvalue]
+ } else {
+ set mysvalue [pt::ast new $symbol $pos $myloc {*}$mysvalue] ; # Reduce $symbol
+ }
+ }
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## API - Instructions - Terminal matching
+
+ method i_input_next {msg} {
+ debug.pt/rdengine {[Instruction i_input_next $msg]}
+ # Inlined: Getch, Expected, ClearErrors
+ # Satisfy from input cache if possible.
+
+ incr myloc
+ # May read from the input (ExtendTC), and remember the
+ # information. Note: We are implicitly incrementing the
+ # location!
+ if {($myloc >= [string length $mytoken]) && ![ExtendTC]} {
+ set myok 0
+ set myerror [list $myloc [list $msg]]
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+ set mycurrent [string index $mytoken $myloc]
+
+ set myok 1
+ set myerror {}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_char {tok} {
+ debug.pt/rdengine {[Instruction i_test_char $tok] :: ok [expr {$tok eq $mycurrent}], [expr {$tok eq $mycurrent ? "@$myloc" : "back@[expr {$myloc-1}]"}]}
+ set myok [expr {$tok eq $mycurrent}]
+ OkFailD {pt::pe terminal $tok}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_range {toks toke} {
+ debug.pt/rdengine {[Instruction i_test_range $toks $toke]}
+ set myok [expr {
+ ([string compare $toks $mycurrent] <= 0) &&
+ ([string compare $mycurrent $toke] <= 0)
+ }] ; # {}
+ OkFailD {pt::pe range $toks $toke}
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_alnum {} {
+ debug.pt/rdengine {[Instruction i_test_alnum]}
+ set myok [string is alnum -strict $mycurrent]
+ OkFail alnum
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_alpha {} {
+ debug.pt/rdengine {[Instruction i_test_alpha]}
+ set myok [string is alpha -strict $mycurrent]
+ OkFail alpha
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_ascii {} {
+ debug.pt/rdengine {[Instruction i_test_ascii]}
+ set myok [string is ascii -strict $mycurrent]
+ OkFail ascii
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_control {} {
+ debug.pt/rdengine {[Instruction i_test_control]}
+ set myok [string is control -strict $mycurrent]
+ OkFail control
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_ddigit {} {
+ debug.pt/rdengine {[Instruction i_test_ddigit]}
+ set myok [string match {[0-9]} $mycurrent]
+ OkFail ddigit
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_digit {} {
+ debug.pt/rdengine {[Instruction i_test_digit]}
+ set myok [string is digit -strict $mycurrent]
+ OkFail digit
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_graph {} {
+ debug.pt/rdengine {[Instruction i_test_graph]}
+ set myok [string is graph -strict $mycurrent]
+ OkFail graph
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_lower {} {
+ debug.pt/rdengine {[Instruction i_test_lower]}
+ set myok [string is lower -strict $mycurrent]
+ OkFail lower
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_print {} {
+ debug.pt/rdengine {[Instruction i_test_print]}
+ set myok [string is print -strict $mycurrent]
+ OkFail print
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_punct {} {
+ debug.pt/rdengine {[Instruction i_test_punct]}
+ set myok [string is punct -strict $mycurrent]
+ OkFail punct
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_space {} {
+ debug.pt/rdengine {[Instruction i_test_space]}
+ set myok [string is space -strict $mycurrent]
+ OkFail space
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_upper {} {
+ debug.pt/rdengine {[Instruction i_test_upper]}
+ set myok [string is upper -strict $mycurrent]
+ OkFail upper
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_wordchar {} {
+ debug.pt/rdengine {[Instruction i_test_wordchar]}
+ set myok [string is wordchar -strict $mycurrent]
+ OkFail wordchar
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ method i_test_xdigit {} {
+ debug.pt/rdengine {[Instruction i_test_xdigit]}
+ set myok [string is xdigit -strict $mycurrent]
+ OkFail xdigit
+
+ debug.pt/rdengine {[InstReturn]}
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## Internals
+
+ proc ExtendTC {} {
+ upvar 1 mychan mychan mytoken mytoken
+
+ if {($mychan eq {}) ||
+ [eof $mychan]} {return 0}
+
+ set ch [read $mychan 1]
+ if {$ch eq {}} {
+ return 0
+ }
+
+ append mytoken $ch
+ return 1
+ }
+
+ proc ExtendTCN {n} {
+ upvar 1 mychan mychan mytoken mytoken
+
+ if {($mychan eq {}) ||
+ [eof $mychan]} {return 0}
+
+ set str [read $mychan $n]
+ set k [string length $str]
+
+ append mytoken $str
+ if {$k < $n} {
+ return 0
+ }
+
+ return 1
+ }
+
+ proc OkFail {msg} {
+ upvar 1 myok myok myerror myerror myloc myloc
+ # Inlined: Expected, Unget, ClearErrors
+ if {!$myok} {
+ set myerror [list $myloc [list $ourmsg($msg)]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ return
+ }
+
+ proc OkFailD {msgcmd} {
+ upvar 1 myok myok myerror myerror myloc myloc
+ # Inlined: Expected, Unget, ClearErrors
+ if {!$myok} {
+ set myerror [list $myloc [list [uplevel 1 $msgcmd]]]
+ incr myloc -1
+ } else {
+ set myerror {}
+ }
+ return
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## Data structures.
+ ## Mainly the architectural state of the instance's PARAM.
+
+ # # ## ### ###### ######## #############
+ ## Configuration
+
+ pragma -hastypeinfo 0
+ pragma -hastypemethods 0
+ pragma -hasinfo 0
+
+ #pragma -simpledispatch 1 ; # Cannot use this. Doing so breaks
+ # # the use of 'return -code XXX' in
+ # # the guarded control flow
+ # # instructions, i.e.
+ # # i:{ok,fail}_{continue,return}.
+
+ typevariable ourmsg -array {}
+
+ typeconstructor {
+ debug.pt/rdengine {}
+
+ set ourmsg(alnum) [pt::pe alnum]
+ set ourmsg(alpha) [pt::pe alpha]
+ set ourmsg(ascii) [pt::pe ascii]
+ set ourmsg(control) [pt::pe control]
+ set ourmsg(ddigit) [pt::pe ddigit]
+ set ourmsg(digit) [pt::pe digit]
+ set ourmsg(graph) [pt::pe graph]
+ set ourmsg(lower) [pt::pe lower]
+ set ourmsg(print) [pt::pe printable]
+ set ourmsg(punct) [pt::pe punct]
+ set ourmsg(space) [pt::pe space]
+ set ourmsg(upper) [pt::pe upper]
+ set ourmsg(wordchar) [pt::pe wordchar]
+ set ourmsg(xdigit) [pt::pe xdigit]
+
+ debug.pt/rdengine {/done}
+ return
+ }
+
+ # Parser Input (channel, location (line, column)) ...........
+
+ variable mychan {} ; # IN. Channel we read the characters
+ # from. Its current location is
+ # where the next character will be
+ # read from, when needed.
+
+ # Token, current parsing location, stack of locations .......
+
+ variable mycurrent {} ; # CC. Current character.
+ variable myloc -1 ; # CL. Location of 'mycurrent' as
+ # offset in the input, relative to
+ # the starting location.
+ variable mystackloc {} ; # LS. Stack object holding parsing
+ # location, see i_loc_mark_set,
+ # i_loc_mark_rewind,
+ # i_loc_mark_drop, and
+ # i_value_(leaf,range,reduce)
+
+ # Match state . ........ ............. .....................
+
+ variable myok 0 ; # ST. Boolean flag indicating the
+ # success (true) or failure
+ # (failure) of the last match
+ # operation.
+ variable mysvalue {} ; # SV. The semantic value produced by
+ # the last match.
+ variable myerror {} ; # ER. Error information for the last
+ # match. Empty string if the match
+ # was ok, otherwise list (location,
+ # list (message...)).
+ variable mystackerr {} ; # ES. Stack object holding saved
+ # error states, see i_error_mark,
+ # i_error_merge
+
+ # Caches for tokens and nonterminals .. .....................
+
+ # list(list(char line col value))
+ variable mytoken {} ; # TC. String of all read characters,
+ # the tokens.
+ variable mysymbol -array {} ; # NC. Cache of data about
+ # nonterminal symbols. Indexed by
+ # location and symbol name, value is
+ # a 4-tuple (go, ok, error, sv)
+
+ # Abstract syntax tree (AST) .......... .....................
+ # AS/ARS intertwined. ARS is top of mystackast, with the markers
+ # on mystackmark showing there ARS ends and AS with older ARS
+ # begins.
+
+ variable mystackast {} ; # ARS. Stack of semantic values
+ # (i.e. partial ASTs) to use in
+ # further AST construction, see
+ # i_ast_push, and i_ast_pop2mark.
+ variable mystackmark {} ; # AS. Stack of locations into the
+ # previous stack, see
+ # i_ast_mark_set,
+ # i_ast_mark_discard, and
+ # i_ast_mark_rewind.
+
+ # # ## ### ##### ######## ############# #####################
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready, return to manager.
+return
diff --git a/tcllib/modules/pt/pt_runtime.test b/tcllib/modules/pt/pt_runtime.test
new file mode 100644
index 0000000..684b50a
--- /dev/null
+++ b/tcllib/modules/pt/pt_runtime.test
@@ -0,0 +1,106 @@
+# -*- tcl -*-
+# pt_runtime.test: tests for the pt::rde package and parsers on top
+# (generated, interpreted) for various grammars and inputs.
+#
+# Copyright (c) 2010 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_runtime.test,v 1.1 2010/07/27 22:53:53 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2.0
+
+support {
+ useAccel [useTcllibC] struct/stack.tcl struct::stack
+ TestAccelInit struct::stack
+
+ use snit/snit2.tcl snit
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_astree.tcl pt::ast
+
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_pexpr_op.tcl pt::pe::op
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal pt_peg_container.tcl pt::peg::container
+
+ # runtime underneath generated and interpreted parsers
+ useAccel [useTcllibC] pt/pt_rdengine.tcl pt::rde
+ TestAccelInit pt::rde
+
+ # interpreter for arbitrary grammars
+ useLocal pt_peg_interp.tcl pt::peg::interp
+
+ useLocal text_write.tcl text::write
+ useLocal char.tcl char
+
+ # generator for snit parsers
+ useLocal pt_tclparam_config_snit.tcl pt::tclparam::configuration::snit
+ useLocal pt_peg_to_tclparam.tcl pt::peg::to::tclparam
+}
+
+#----------------------------------------------------------------------
+
+snitErrors
+# -------------------------------------------------------------------------
+# Note: When using pt::rde's C implementation struct::stack is not
+# used, and its implementation of no relevance.
+
+TestAccelDo pt::rde rdeimpl {
+ switch -exact -- $rdeimpl {
+ critcl {
+ set MY myrde
+
+ proc tmWrong {m loarg n {xarg {}}} {
+ return [tcltest::wrongNumArgs "myrde $m" $loarg $n]
+ }
+
+ proc tmTooMany {m loarg {xarg {}}} {
+ return [tcltest::tooManyArgs "myrde $m" $loarg]
+ }
+
+ proc take {tcl critcl} { return $critcl }
+ }
+ tcl {
+ set MY ::myrde
+
+ proc tmWrong {m loarg n {xarg {}}} {
+ if {$xarg == {}} {set xarg $loarg}
+ if {$xarg != {}} {set xarg " $xarg"}
+ incr n
+ return [tcltest::wrongNumArgs "::pt::rde::$m" "name$xarg" $n]
+ }
+
+ proc tmTooMany {m loarg {xarg {}}} {
+ if {$xarg == {}} {set xarg $loarg}
+ if {$xarg != {}} {set xarg " $xarg"}
+ return [tcltest::tooManyArgs "::pt::rde::$m" "name$xarg"]
+ }
+
+ proc take {tcl critcl} { return $tcl }
+ }
+ }
+
+ if {$rdeimpl eq "critcl"} {
+ set stackimpl n/a
+ struct::stack::SwitchTo {}
+ source [localPath tests/pt_runtime.tests]
+ } else {
+ TestAccelDo struct::stack stackimpl {
+ source [localPath tests/pt_runtime.tests]
+ }
+ }
+}
+
+#----------------------------------------------------------------------
+
+TestAccelExit pt::rde
+TestAccelExit struct::stack
+testsuiteCleanup
diff --git a/tcllib/modules/pt/pt_tclparam_config_snit.man b/tcllib/modules/pt/pt_tclparam_config_snit.man
new file mode 100644
index 0000000..409f0f1
--- /dev/null
+++ b/tcllib/modules/pt/pt_tclparam_config_snit.man
@@ -0,0 +1,48 @@
+[vset VERSION 1.0.2]
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt::tclparam::configuration::snit n [vset VERSION]]
+[include include/module.inc]
+[titledesc {Tcl/PARAM, Canned configuration, Snit}]
+[require pt::tclparam::configuration::snit [opt [vset VERSION]]]
+[description]
+[include include/ref_intro.inc]
+
+This package is an adjunct to [package pt::peg::to::tclparam], to make
+the use of this highly configurable package easier by providing a
+canned configuration. When applied this configuration causes the
+package [package pt::peg::to::tclparam] to generate
+[package snit]-based parser packages.
+
+[para]
+
+It is a supporting package in the Core Layer of Parser Tools.
+[para][image arch_core_support][para]
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::pt::tclparam::configuration::snit] [method def] \
+ [arg name] [arg pkg] [arg version] [arg cmdprefix]]
+
+The command applies the configuration provided by this package to the
+[arg cmdprefix], causing the creation of [package snit]-based parsers
+whose class is [arg name], in package [arg pkg] with [arg version].
+
+[para]
+
+The use of a command prefix as API allows application of the
+configuration to not only [package pt::peg::to::tclparam]
+([cmd {pt::peg::to::tclparam configure}]), but also export manager
+instances and PEG containers ([cmd {$export configuration set}] and
+[cmd {[$container exporter] configuration set}] respectively).
+
+[para]
+
+Or anything other command prefix accepting two arguments, option and
+value.
+
+[list_end]
+
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_tclparam_config_snit.tcl b/tcllib/modules/pt/pt_tclparam_config_snit.tcl
new file mode 100644
index 0000000..806253f
--- /dev/null
+++ b/tcllib/modules/pt/pt_tclparam_config_snit.tcl
@@ -0,0 +1,141 @@
+# -*- tcl -*-
+# Copyright (c) 2009-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Canned configuration for the converter to Tcl/PARAM representation,
+# causing generation of a proper snit class.
+
+# The requirements of the embedded template are not our requirements.
+# @mdgen NODEP: snit
+# @mdgen NODEP: pt::rde
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.5 ; # Required runtime.
+
+# # ## ### ##### ######## ############# #####################
+##
+
+namespace eval ::pt::tclparam::configuration::snit {
+ namespace export def
+ namespace ensemble create
+}
+
+# # ## ### ##### ######## #############
+## Public API
+
+# Check that the proposed serialization of an abstract syntax tree is
+# indeed such.
+
+proc ::pt::tclparam::configuration::snit::def {class pkg version cmd} {
+
+ # TODO :: See if we can consolidate the API for converters,
+ # TODO :: plugins, export manager, and container in some way.
+ # TODO :: Container may make exporter manager available through
+ # TODO :: public method.
+
+ # class : is actually the name of the package to generate, and
+ # will be prefixed with :: to make it a proper absolute
+ # class and Tcl namespace name.
+
+ lappend map @@PKG@@ $pkg
+ lappend map @@VERSION@@ $version
+ lappend map @@CLASS@@ $class
+ lappend map \n\t \n ;# undent the template
+
+ {*}$cmd -runtime-command {$myparser}
+ #{*}$cmd -self-command {$self}
+ #{*}$cmd -proc-command method
+ {*}$cmd -self-command {}
+ {*}$cmd -proc-command proc
+ {*}$cmd -prelude {upvar 1 myparser myparser}
+ {*}$cmd -namespace {}
+ {*}$cmd -main MAIN
+ {*}$cmd -indent 4
+ {*}$cmd -template [string trim \
+ [string map $map {
+ ## -*- tcl -*-
+ ##
+ ## Snit-based Tcl/PARAM implementation of the parsing
+ ## expression grammar
+ ##
+ ## @name@
+ ##
+ ## Generated from file @file@
+ ## for user @user@
+ ##
+ # # ## ### ##### ######## ############# #####################
+ ## Requirements
+
+ package require Tcl 8.5
+ package require snit
+ package require pt::rde ; # Implementation of the PARAM
+ # virtual machine underlying the
+ # Tcl/PARAM code used below.
+
+ # # ## ### ##### ######## ############# #####################
+ ##
+
+ snit::type ::@@CLASS@@ {
+ # # ## ### ##### ######## #############
+ ## Public API
+
+ constructor {} {
+ # Create the runtime supporting the parsing process.
+ set myparser [pt::rde ${selfns}::ENGINE]
+ return
+ }
+
+ method parse {channel} {
+ $myparser reset $channel
+ MAIN ; # Entrypoint for the generated code.
+ return [$myparser complete]
+ }
+
+ method parset {text} {
+ $myparser reset
+ $myparser data $text
+ MAIN ; # Entrypoint for the generated code.
+ return [$myparser complete]
+ }
+
+ # # ## ### ###### ######## #############
+ ## Configuration
+
+ pragma -hastypeinfo 0
+ pragma -hastypemethods 0
+ pragma -hasinfo 0
+ pragma -simpledispatch 1
+
+ # # ## ### ###### ######## #############
+ ## Data structures.
+
+ variable myparser {} ; # Our instantiation of the PARAM.
+
+ # # ## ### ###### ######## #############
+ ## BEGIN of GENERATED CODE. DO NOT EDIT.
+
+@code@
+ ## END of GENERATED CODE. DO NOT EDIT.
+ # # ## ### ###### ######## #############
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## Ready
+
+ package provide @@PKG@@ @@VERSION@@
+ return
+ }]]
+
+ return
+}
+
+# # ## ### ##### ######## #############
+
+namespace eval ::pt::tclparam::configuration::snit {}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide pt::tclparam::configuration::snit 1.0.2
+return
diff --git a/tcllib/modules/pt/pt_tclparam_config_snit.test b/tcllib/modules/pt/pt_tclparam_config_snit.test
new file mode 100644
index 0000000..44197e3
--- /dev/null
+++ b/tcllib/modules/pt/pt_tclparam_config_snit.test
@@ -0,0 +1,50 @@
+# -*- tcl -*-
+# pt_tclparam_config_snit.test: tests for the pt::peg::to::tclparam
+# converter package configured for snit.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_tclparam_config_snit.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set ; # used by pt::pe::op,
+ TestAccelInit struct::set ; # however not by the
+ # # commands used here.
+
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pexpr_op.tcl pt::pe::op
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal text_write.tcl text::write
+ useLocal char.tcl char
+
+ useLocal pt_peg_to_tclparam.tcl pt::peg::to::tclparam
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_tclparam_config_snit.tcl pt::tclparam::configuration::snit
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/pt_tclparam_config_snit.tests]
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_tclparam_config_tcloo.man b/tcllib/modules/pt/pt_tclparam_config_tcloo.man
new file mode 100644
index 0000000..9cb6601
--- /dev/null
+++ b/tcllib/modules/pt/pt_tclparam_config_tcloo.man
@@ -0,0 +1,48 @@
+[vset VERSION 1.0.4]
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt::tclparam::configuration::tcloo n [vset VERSION]]
+[include include/module.inc]
+[titledesc {Tcl/PARAM, Canned configuration, Tcloo}]
+[require pt::tclparam::configuration::tcloo [opt [vset VERSION]]]
+[description]
+[include include/ref_intro.inc]
+
+This package is an adjunct to [package pt::peg::to::tclparam], to make
+the use of this highly configurable package easier by providing a
+canned configuration. When applied this configuration causes the
+package [package pt::peg::to::tclparam] to generate
+[package OO]-based parser packages.
+
+[para]
+
+It is a supporting package in the Core Layer of Parser Tools.
+[para][image arch_core_support][para]
+
+[section API]
+
+[list_begin definitions]
+
+[call [cmd ::pt::tclparam::configuration::tcloo] [method def] \
+ [arg name] [arg pkg] [arg version] [arg cmdprefix]]
+
+The command applies the configuration provided by this package to the
+[arg cmdprefix], causing the creation of [package OO]-based parsers
+whose class is [arg name], in package [arg pkg] with [arg version].
+
+[para]
+
+The use of a command prefix as API allows application of the
+configuration to not only [package pt::peg::to::tclparam]
+([cmd {pt::peg::to::tclparam configure}]), but also export manager
+instances and PEG containers ([cmd {$export configuration set}] and
+[cmd {[$container exporter] configuration set}] respectively).
+
+[para]
+
+Or anything other command prefix accepting two arguments, option and
+value.
+
+[list_end]
+
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_tclparam_config_tcloo.tcl b/tcllib/modules/pt/pt_tclparam_config_tcloo.tcl
new file mode 100644
index 0000000..3e2d152
--- /dev/null
+++ b/tcllib/modules/pt/pt_tclparam_config_tcloo.tcl
@@ -0,0 +1,121 @@
+# -*- tcl -*-
+# Copyright (c) 2009-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Canned configuration for the converter to Tcl/PARAM representation,
+# causing generation of a proper TclOO class.
+
+# The requirements of the embedded template are not our requirements.
+# @mdgen NODEP: TclOO
+# @mdgen NODEP: pt::rde::oo
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.5 ; # Required runtime.
+
+# # ## ### ##### ######## ############# #####################
+##
+
+namespace eval ::pt::tclparam::configuration::tcloo {
+ namespace export def
+ namespace ensemble create
+}
+
+# # ## ### ##### ######## #############
+## Public API
+
+# Check that the proposed serialization of an abstract syntax tree is
+# indeed such.
+
+proc ::pt::tclparam::configuration::tcloo::def {class pkg version cmd} {
+
+ # TODO :: See if we can consolidate the API for converters,
+ # TODO :: plugins, export manager, and container in some way.
+ # TODO :: Container may make exporter manager available through
+ # TODO :: public method.
+
+ lappend map @@PKG@@ $pkg
+ lappend map @@VERSION@@ $version
+ lappend map @@CLASS@@ $class
+ lappend map \n\t \n ;# undent the template
+
+ {*}$cmd -runtime-command my
+ {*}$cmd -self-command my
+ {*}$cmd -proc-command method
+ {*}$cmd -prelude {}
+ {*}$cmd -namespace {}
+ {*}$cmd -main MAIN
+ {*}$cmd -indent 4
+ {*}$cmd -template [string trim \
+ [string map $map {
+ ## -*- tcl -*-
+ ##
+ ## OO-based Tcl/PARAM implementation of the parsing
+ ## expression grammar
+ ##
+ ## @name@
+ ##
+ ## Generated from file @file@
+ ## for user @user@
+ ##
+ # # ## ### ##### ######## ############# #####################
+ ## Requirements
+
+ package require Tcl 8.5
+ package require TclOO
+ package require pt::rde::oo ; # OO-based implementation of the
+ # PARAM virtual machine
+ # underlying the Tcl/PARAM code
+ # used below.
+
+ # # ## ### ##### ######## ############# #####################
+ ##
+
+ oo::class create @@CLASS@@ {
+ # # ## ### ##### ######## #############
+ ## Public API
+
+ superclass pt::rde::oo ; # TODO - Define this class.
+ # Or can we inherit from a snit
+ # class too ?
+
+ method parse {channel} {
+ my reset $channel
+ my MAIN ; # Entrypoint for the generated code.
+ return [my complete]
+ }
+
+ method parset {text} {
+ my reset {}
+ my data $text
+ my MAIN ; # Entrypoint for the generated code.
+ return [my complete]
+ }
+
+ # # ## ### ###### ######## #############
+ ## BEGIN of GENERATED CODE. DO NOT EDIT.
+
+@code@
+ ## END of GENERATED CODE. DO NOT EDIT.
+ # # ## ### ###### ######## #############
+ }
+
+ # # ## ### ##### ######## ############# #####################
+ ## Ready
+
+ package provide @@PKG@@ @@VERSION@@
+ return
+ }]]
+
+ return
+}
+
+# # ## ### ##### ######## #############
+
+namespace eval ::pt::tclparam::configuration::tcloo {}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide pt::tclparam::configuration::tcloo 1.0.4
+return
diff --git a/tcllib/modules/pt/pt_tclparam_config_tcloo.test b/tcllib/modules/pt/pt_tclparam_config_tcloo.test
new file mode 100644
index 0000000..dc4533f
--- /dev/null
+++ b/tcllib/modules/pt/pt_tclparam_config_tcloo.test
@@ -0,0 +1,50 @@
+# -*- tcl -*-
+# pt_tclparam_config_tcloo.test: tests for the pt::peg::to::tclparam
+# converter package configured for tcloo.
+#
+# Copyright (c) 2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: pt_tclparam_config_tcloo.test,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+testsNeedTcl 8.5
+testsNeedTcltest 2
+
+support {
+ useAccel [useTcllibC] struct/sets.tcl struct::set ; # used by pt::pe::op,
+ TestAccelInit struct::set ; # however not by the
+ # # commands used here.
+
+ use fileutil/fileutil.tcl fileutil ;# tests/common
+ use textutil/adjust.tcl textutil::adjust
+
+ useLocal pt_pexpression.tcl pt::pe
+ useLocal pt_pexpr_op.tcl pt::pe::op
+ useLocal pt_pegrammar.tcl pt::peg
+ useLocal text_write.tcl text::write
+ useLocal char.tcl char
+
+ useLocal pt_peg_to_tclparam.tcl pt::peg::to::tclparam
+
+ source [localPath tests/common]
+}
+testing {
+ useLocal pt_tclparam_config_tcloo.tcl pt::tclparam::configuration::tcloo
+}
+
+set mytestdir tests/data
+
+# -------------------------------------------------------------------------
+
+source [localPath tests/pt_tclparam_config_tcloo.tests]
+
+# -------------------------------------------------------------------------
+TestAccelExit struct::set
+testsuiteCleanup
+return
diff --git a/tcllib/modules/pt/pt_to_api.man b/tcllib/modules/pt/pt_to_api.man
new file mode 100644
index 0000000..e9a616f
--- /dev/null
+++ b/tcllib/modules/pt/pt_to_api.man
@@ -0,0 +1,217 @@
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt_export_api i 1]
+[include include/module.inc]
+[titledesc {Parser Tools Export API}]
+[description]
+[include include/ref_intro.inc]
+
+This document describes two APIs. First the API shared by all packages
+for the conversion of Parsing Expression Grammars into some other
+format, and then the API shared by the packages which implement the
+export plugins sitting on top of the conversion packages.
+
+[para]
+
+Its intended audience are people who wish to create their own
+converter for some type of output, and/or an export plugin for
+their or some other converter.
+
+[para]
+
+It resides in the Export section of the Core Layer of Parser Tools.
+[para][image arch_core_export][para]
+
+[section {Converter API}]
+
+Any (grammar) export converter has to follow the rules set out below:
+
+[list_begin enumerated][comment {-- converter rules --}]
+
+[enum] A converter is a package. Its name is arbitrary, however it is
+ recommended to put it under the [namespace ::pt::peg::to]
+ namespace.
+
+[enum] The package provides either a single Tcl command following the
+ API outlined below, or a class command whose instances follow
+ the same API. The commands which follow the API are called
+ [term {converter commands}].
+
+[enum] A converter command has to provide the following three methods
+ with the given signatures and semantics. Converter commands
+ are allowed to provide more methods of their own, but not
+ less, and they may not provide different semantics for the
+ standardized methods.
+
+[list_begin definitions][comment {-- api command signatures --}]
+
+[call [cmd CONVERTER] [method reset]]
+
+This method has to reset the configuration of the converter to its
+default settings. The result of the method has to be the empty
+string.
+
+[call [cmd CONVERTER] [method configure]]
+
+This method, in this form, has to return a dictionary containing the
+current configuration of the converter.
+
+[call [cmd CONVERTER] [method configure] [arg option]]
+
+This method, in this form, has to return the current value of the
+specified configuration [arg option] of the converter.
+
+[para]
+
+Please read the section [sectref Options] for the set of standard
+options any converter has to accept.
+
+Any other options accepted by a specific converter will be described
+in its manpage.
+
+[call [cmd CONVERTER] [method configure] [arg option] [arg value]...]
+
+This command, in this form, sets the specified [arg option]s of the
+converter to the given [arg value]s.
+
+[para]
+
+Please read the section [sectref Options] for the set of standard
+options a converter has to accept.
+
+Any other options accepted by a specific converter will be described
+in its manpage.
+
+[call [cmd CONVERTER] [method convert] [arg serial]]
+
+This method has to accept the canonical serialization of a parsing
+expression grammar, as specified in section
+[sectref {PEG serialization format}], and contained in [arg serial].
+
+The result of the method has to be the result of converting the input
+grammar into whatever the converter is for, per its configuration.
+
+[list_end][comment {-- api command signatures --}]
+[list_end][comment {-- converter rules --}]
+
+[section {Plugin API}]
+
+Any (grammar) export plugin has to follow the rules set out below:
+
+[list_begin enumerated][comment {-- plugin rules --}]
+
+[enum] A plugin is a package.
+
+[enum] The name of a plugin package has the form
+
+ pt::peg::export::[var FOO],
+
+ where [var FOO] is the name of the format the plugin will
+ generate output for.
+
+[enum] The plugin can expect that the package
+ [package pt::peg::export::plugin] is present, as
+ indicator that it was invoked from a genuine plugin manager.
+
+ [para]
+
+ It is recommended that a plugin does check for the presence of
+ this package.
+
+[enum] A plugin has to provide a single command, in the global
+ namespace, with the signature shown below. Plugins are allowed
+ to provide more command of their own, but not less, and they
+ may not provide different semantics for the standardized
+ command.
+
+[list_begin definitions][comment {-- api command signatures --}]
+
+[call [cmd ::export] [arg serial] [arg configuration]]
+
+This command has to accept the canonical serialization of a parsing
+expression grammar and the configuration for the converter invoked by
+the plugin. The result of the command has to be the result of the
+converter invoked by the plugin for th input grammar and
+configuration.
+
+[list_begin arguments][comment {-- arguments --}]
+
+[arg_def string serial]
+
+This argument will contain the [term canonical] serialization of the
+parsing expression grammar for which to generate the output.
+
+The specification of what a [term canonical] serialization is can be
+found in the section [sectref {PEG serialization format}].
+
+[arg_def dictionary configuration]
+
+This argument will contain the configuration to configure the
+converter with before invoking it, as a dictionary mapping from
+options to values.
+
+[para]
+
+Please read the section [sectref Options] for the set of standard
+options any converter has to accept, and thus any plugin as well.
+
+Any other options accepted by a specific plugin will be described in
+its manpage.
+
+[list_end][comment {-- arguments --}]
+[list_end][comment {-- api command signatures --}]
+
+[enum] A single usage cycle of a plugin consists of an invokation of
+ the command [cmd export]. This call has to leave the plugin in
+ a state where another usage cycle can be run without problems.
+
+[list_end][comment {-- plugin rules --}]
+
+[section Options]
+
+Each export converter and plugin for an export converter has to accept
+the options below in their [method configure] method. Converters are
+allowed to ignore the contents of these options when performing a
+conversion, but they must not reject them. Plugins are expected to
+pass the options given to them to the converter they are invoking.
+
+[list_begin options]
+[include include/format/options_std.inc]
+[list_end]
+
+[section Usage]
+
+To use a converter do
+
+[example {
+ # Get the converter (single command here, not class)
+ package require the-converter-package
+
+ # Provide a configuration
+ theconverter configure ...
+
+ # Perform the conversion
+ set result [theconverter convert $thegrammarserial]
+
+ ... process the result ...
+}]
+
+To use a plugin [var FOO] do
+
+[example {
+ # Get an export plugin manager
+ package require pt::peg::export
+ pt::peg::export E
+
+ # Provide a configuration
+ E configuration set ...
+
+ # Run the plugin, and the converter inside.
+ set result [E export serial $grammarserial FOO]
+
+ ... process the result ...
+}]
+
+[include include/serial/pegrammar.inc]
+[include include/serial/pexpression.inc]
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_util.man b/tcllib/modules/pt/pt_util.man
new file mode 100644
index 0000000..e345ab7
--- /dev/null
+++ b/tcllib/modules/pt/pt_util.man
@@ -0,0 +1,54 @@
+[vset VERSION 1.1]
+[comment {-*- text -*- doctools manpage}]
+[manpage_begin pt::util n [vset VERSION]]
+[include include/module.inc]
+[titledesc {General utilities}]
+[require pt::ast [opt [vset VERSION]]]
+[description]
+[include include/ref_intro.inc]
+
+This package provides general utility commands.
+
+[para]
+
+This is a supporting package in the Core Layer of Parser Tools.
+[para][image arch_core_support][para]
+
+[section API]
+
+[list_begin definitions]
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd ::pt::util] [method error2readable] \
+ [arg error] [arg text]]
+
+This command takes the structured form of a syntax [arg error] as
+thrown by parser runtimes and the input [arg text] to the parser which
+caused that error and returns a string describing the error in a
+human-readable form.
+
+[para] The input [arg text] is required to convert the character
+position of the error into a more readable line/column format, and to
+provide excerpts of the input around the error position.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd ::pt::util] [method error2position] \
+ [arg error] [arg text]]
+
+This command takes the structured form of a syntax [arg error] as
+thrown by parser runtimes and the input [arg text] to the parser which
+caused that error and returns a 2-element list containing the line
+number and column index for the error's character position in the
+input, in this order.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[call [cmd ::pt::util] [method error2text] [arg error]]
+
+This command takes the structured form of a syntax [arg error] as
+thrown by parser runtimes and returns a list of strings, each
+describing a possible expected input in a human-readable form.
+
+[comment {= = == === ===== ======== ============= =====================}]
+[list_end]
+
+[include include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/pt/pt_util.tcl b/tcllib/modules/pt/pt_util.tcl
new file mode 100644
index 0000000..ed39663
--- /dev/null
+++ b/tcllib/modules/pt/pt_util.tcl
@@ -0,0 +1,160 @@
+# -*- tcl -*-
+# Copyright (c) 2014 Andreas Kupries <andreas_kupries@sourceforge.net>
+
+# Utility commands for parser syntax errors.
+
+# # ## ### ##### ######## ############# #####################
+## Requirements
+
+package require Tcl 8.5 ; # Required runtime.
+package require char
+
+# # ## ### ##### ######## ############# #####################
+##
+
+namespace eval ::pt::util {
+ namespace export error2readable error2position error2text
+ namespace ensemble create
+
+ namespace import ::char::quote
+}
+
+# # ## ### ##### ######## #############
+## Public API
+
+proc ::pt::util::error2readable {error text} {
+ lassign $error _ location msgs
+ lassign [Position $location $text] l c
+
+ lappend map \n \\n
+ lappend map \r \\r
+ lappend map \t \\t
+
+ # Get 10 chars before and after the failure point. Depending on
+ # the relative position of input beginning and end we may get less
+ # back of either. Special characters in the input (line endings,
+ # tabs) are quoted to keep this on a single line.
+ set prefix [string map $map [string range $text ${location}-10 $location]]
+ set suffix [string map $map [string range $text ${location}+1 ${location}+10]]
+
+ # Construct a line pointing to the failure position. By using the
+ # transformed prefix as our source (length) no complex
+ # calculations are required. It is implicit in the prefix/suffix
+ # separation above.
+ set n [string length $prefix]
+ incr n -1
+ set point [string repeat - $n]
+ append point ^
+
+ # Print our results.
+ lappend lines "Parse error at position $location (Line $l, column $c)."
+ lappend lines "... ${prefix}${suffix} ..."
+ lappend lines " $point"
+ lappend lines "Expected one of"
+ lappend lines "* [join [Readables $msgs] "\n* "]"
+ lappend lines ""
+
+ return [join $lines \n]
+}
+
+proc ::pt::util::error2position {error text} {
+ lassign $error _ location msgs
+ return [Position $location $text]
+}
+
+proc ::pt::util::error2text {error} {
+ lassign $error _ location msgs
+ return [Readables $msgs]
+}
+
+# # ## ### ##### ######## #############
+## Internals
+
+proc ::pt::util::Position {location text} {
+ incr location -1
+
+ # Computing the line/col of a position is quite easy. Split the
+ # part before the location into lines (at eol), count them, and
+ # look at the length of the last line in that.
+
+ set prefix [string range $text 0 $location]
+ set lines [split $prefix \n]
+ set line [llength $lines]
+ set col [string length [lindex $lines end]]
+
+ return [list $line $col]
+}
+
+proc ::pt::util::Readables {msgs} {
+ set cl {}
+ set r {}
+ foreach pe $msgs {
+ switch -exact -- [lindex $pe 0] {
+ t {
+ # Fuse to multiple 't'-tags into a single 'cl'-tag.
+ lappend cl [lindex $pe 1]
+ }
+ cl {
+ # Fuse multiple 'cl'-tags into one.
+ foreach c [split [lindex $pe 1]] { lappend cl $c }
+ }
+ default {
+ lappend r [Readable $pe]
+ }
+ }
+ }
+ if {[set n [llength $cl]]} {
+ if {$n > 1} {
+ lappend r [Readable [list cl [join [lsort -dict $cl] {}]]]
+ } else {
+ lappend r [Readable [list t [lindex $cl 0]]]
+ }
+ }
+ return [lsort -dict $r]
+}
+
+proc ::pt::util::Readable {pe} {
+ set details [lassign $pe tag]
+ switch -exact -- $tag {
+ t {
+ set details [quote string {*}$details]
+ set m "The character '$details'"
+ }
+ n { set m "The symbol $details" }
+ .. {
+ set details [quote string {*}$details]
+ set m "A character in range '[join $details '-']'"
+ }
+ str {
+ set details [join [quote string {*}[split $details {}]] {}]
+ set m "A string \"$details\""
+ }
+ cl {
+ set details [join [quote string {*}[split $details {}]] {}]
+ set m "A character in set \{$details\}"
+ }
+ alpha { set m "A unicode alphabetical character" }
+ alnum { set m "A unicode alphanumerical character" }
+ ascii { set m "An ascii character" }
+ digit { set m "A unicode digit character" }
+ graph { set m "A unicode printing character, but not space" }
+ lower { set m "A unicode lower-case alphabetical character" }
+ print { set m "A unicode printing character, including space" }
+ control { set m "A unicode control character" }
+ punct { set m "A unicode punctuation character" }
+ space { set m "A unicode space character" }
+ upper { set m "A unicode upper-case alphabetical character" }
+ wordchar { set m "A unicode word character (alphanumerics + connectors)" }
+ xdigit { set m "A hexadecimal digit" }
+ ddigit { set m "A decimal digit" }
+ dot { set m "Any character" }
+ default { set m [string totitle $tag] }
+ }
+ return $m
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+
+package provide pt::util 1.1
+return
diff --git a/tcllib/modules/pt/rde_critcl/m.c b/tcllib/modules/pt/rde_critcl/m.c
new file mode 100644
index 0000000..9a56bc6
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/m.c
@@ -0,0 +1,2746 @@
+/* pt::rde::critcl - critcl - layer 3 definitions.
+ *
+ * -> Method functions.
+ * Implementations for all state methods.
+ */
+
+#include <m.h> /* Our public API */
+#include <pInt.h> /* State public and internal APIs */
+#include <ot.h> /* Tcl_Objype for interned strings. */
+#include <util.h> /* Allocation utilities */
+#include <string.h>
+
+/* .................................................. */
+
+int
+param_AMARKED (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde amarked
+ * [0] [1]
+ */
+
+ long int mc, i;
+ void** mv;
+ Tcl_Obj** ov;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_query_amark (p->p, &mc, &mv);
+
+ ov = NALLOC (mc, Tcl_Obj*);
+
+ for (i=0; i < mc; i++) {
+ ov [i] = Tcl_NewIntObj ((long int) mv [i]);
+ }
+
+ Tcl_SetObjResult (interp,
+ Tcl_NewListObj (mc, ov));
+
+ ckfree ((char*) ov);
+
+ return TCL_OK;
+}
+
+int
+param_AST (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde ast
+ * [0] [1]
+ */
+
+ long int ac;
+ Tcl_Obj** av;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_query_ast (p->p, &ac, &av);
+
+ Tcl_SetObjResult (interp, av [ac-1]);
+
+ return TCL_OK;
+}
+
+int
+param_ASTS (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde asts
+ * [0] [1]
+ */
+
+ long int ac;
+ Tcl_Obj** av;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_query_ast (p->p, &ac, &av);
+
+ Tcl_SetObjResult (interp, Tcl_NewListObj (ac, av));
+
+ return TCL_OK;
+}
+
+int
+param_CHAN (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde chan
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult (interp,
+ Tcl_NewStringObj (rde_param_query_in (p->p),
+ -1));
+
+ return TCL_OK;
+}
+
+int
+param_COMPLETE (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* See also pt_cparam_config_critcl.tcl, COMPLETE().
+ * Syntax: rde complete
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (rde_param_query_st (p->p)) {
+ long int ac;
+ Tcl_Obj** av;
+
+ rde_param_query_ast (p->p, &ac, &av);
+
+ if (ac > 1) {
+ Tcl_Obj** lv = NALLOC (3+ac, Tcl_Obj*);
+
+ memcpy(lv + 3, av, ac * sizeof (Tcl_Obj*));
+ lv [0] = Tcl_NewObj ();
+ lv [1] = Tcl_NewIntObj (1 + rde_param_query_lstop (p->p));
+ lv [2] = Tcl_NewIntObj (rde_param_query_cl (p->p));
+
+ Tcl_SetObjResult (interp, Tcl_NewListObj (3, lv));
+ ckfree ((char*) lv);
+ } else if (ac == 0) {
+ /*
+ * Match, but no AST. This is possible if the grammar consists of
+ * only the start expression.
+ */
+ Tcl_SetObjResult (interp, Tcl_NewStringObj ("",-1));
+ } else {
+ Tcl_SetObjResult (interp, av [0]);
+ }
+
+ return TCL_OK;
+
+ } else {
+ Tcl_Obj* xv [1];
+ const ERROR_STATE* er = rde_param_query_er (p->p);
+ Tcl_Obj* res = rde_param_query_er_tcl (p->p, er);
+ /* res = list (location, list(msg)) */
+
+ /* Stick the exception type-tag before the existing elements */
+ xv [0] = Tcl_NewStringObj ("pt::rde",-1);
+ Tcl_ListObjReplace(interp, res, 0, 0, 1, xv);
+
+ Tcl_SetErrorCode (interp, "PT", "RDE", "SYNTAX", NULL);
+ Tcl_SetObjResult (interp, res);
+ return TCL_ERROR;
+ }
+}
+
+int
+param_CURRENT (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde current
+ * [0] [1]
+ */
+
+ const char* ch;
+ long int len;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ ch = rde_param_query_cc (p->p, &len);
+ Tcl_SetObjResult (interp, Tcl_NewStringObj (ch, len));
+
+ return TCL_OK;
+}
+
+int
+param_DATA (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde data DATA
+ * [0] [1] [2]
+ */
+
+ char* buf;
+ int len;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "data");
+ return TCL_ERROR;
+ }
+
+ buf = Tcl_GetStringFromObj (objv [2], &len);
+
+ rde_param_data (p->p, buf, len);
+
+ return TCL_OK;
+}
+
+int
+param_DESTROY (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde destroy
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_DeleteCommandFromToken(interp, p->c);
+ return TCL_OK;
+}
+
+int
+param_EMARKED (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde emarked
+ * [0] [1]
+ */
+
+ long int ec, i;
+ ERROR_STATE** ev;
+ Tcl_Obj** ov;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_query_es (p->p, &ec, &ev);
+
+ ov = NALLOC (ec, Tcl_Obj*);
+
+ for (i=0; i < ec; i++) {
+ ov [i] = rde_param_query_er_tcl (p->p, ev [i]);
+ }
+
+ Tcl_SetObjResult (interp, Tcl_NewListObj (ec, ov));
+
+ ckfree ((char*) ov);
+
+ return TCL_OK;
+}
+
+int
+param_ERROR (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde error
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult (interp,
+ rde_param_query_er_tcl (p->p,
+ rde_param_query_er (p->p)));
+ return TCL_OK;
+}
+
+int
+param_LMARKED (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde lmarked
+ * [0] [1]
+ */
+
+ long int lc, i;
+ void** lv;
+ Tcl_Obj** ov;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_query_ls (p->p, &lc, &lv);
+
+ ov = NALLOC (lc, Tcl_Obj*);
+
+ for (i=0; i < lc; i++) {
+ ov [i] = Tcl_NewIntObj ((long int) lv [i]);
+ }
+
+ Tcl_SetObjResult (interp, Tcl_NewListObj (lc, ov));
+
+ ckfree ((char*) ov);
+ return TCL_OK;
+}
+
+int
+param_LOCATION (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde location
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult (interp,
+ Tcl_NewIntObj (rde_param_query_cl (p->p)));
+
+ return TCL_OK;
+}
+
+int
+param_OK (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde ok
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult (interp,
+ Tcl_NewIntObj (rde_param_query_st (p->p)));
+
+ return TCL_OK;
+}
+
+int
+param_RESET (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde reset ?CHAN?
+ * [0] [1] [2]
+ */
+
+ int mode;
+ Tcl_Channel chan;
+
+ if ((objc != 3) && (objc != 2)) {
+ Tcl_WrongNumArgs (interp, 2, objv, "?chan?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Can't use TclGetChannelFromObj, nice as it would be. This fucntion is
+ * not part of Tcl's public C API.
+ */
+
+ if (objc == 2) {
+ chan = NULL;
+ } else {
+ chan = Tcl_GetChannel(interp,
+ Tcl_GetString (objv[2]),
+ &mode);
+
+ if (!chan) {
+ return TCL_ERROR;
+ }
+ }
+
+ rde_param_reset (p->p, chan);
+
+ return TCL_OK;
+}
+
+int
+param_SCACHED (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde scached
+ * [0] [1]
+ */
+
+ Tcl_HashTable* nc;
+ Tcl_Obj* res;
+ Tcl_HashSearch hs;
+ Tcl_HashEntry* he;
+ Tcl_HashTable* tablePtr;
+ Tcl_Obj* kv [2];
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ nc = rde_param_query_nc (p->p);
+ res = Tcl_NewListObj (0, NULL);
+
+ for(he = Tcl_FirstHashEntry(nc, &hs);
+ he != NULL;
+ he = Tcl_NextHashEntry(&hs)) {
+
+ Tcl_HashSearch hsc;
+ Tcl_HashEntry* hec;
+ long int loc = (long int) Tcl_GetHashKey (nc, he);
+
+ kv [0] = Tcl_NewIntObj (loc);
+ tablePtr = (Tcl_HashTable*) Tcl_GetHashValue (he);
+
+ for(hec = Tcl_FirstHashEntry(tablePtr, &hsc);
+ hec != NULL;
+ hec = Tcl_NextHashEntry(&hsc)) {
+
+ long int symid = (long int) Tcl_GetHashKey (tablePtr, hec);
+ const char* sym = rde_param_query_string (p->p, symid);
+
+ kv [1] = Tcl_NewStringObj (sym,-1);
+
+ Tcl_ListObjAppendElement (interp, res,
+ Tcl_NewListObj (2, kv));
+ }
+ }
+
+ Tcl_SetObjResult (interp, res);
+ return TCL_OK;
+}
+
+int
+param_SYMBOLS (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde symbols
+ * [0] [1]
+ */
+
+ Tcl_HashTable* nc;
+ Tcl_Obj* res;
+ Tcl_HashSearch hs;
+ Tcl_HashEntry* he;
+ Tcl_HashTable* tablePtr;
+ Tcl_Obj* kv [2];
+ Tcl_Obj* vv [4];
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ nc = rde_param_query_nc (p->p);
+ res = Tcl_NewListObj (0, NULL);
+
+ for(he = Tcl_FirstHashEntry(nc, &hs);
+ he != NULL;
+ he = Tcl_NextHashEntry(&hs)) {
+
+ Tcl_HashSearch hsc;
+ Tcl_HashEntry* hec;
+ long int loc = (long int) Tcl_GetHashKey (nc, he);
+
+ kv [0] = Tcl_NewIntObj (loc);
+ tablePtr = (Tcl_HashTable*) Tcl_GetHashValue (he);
+
+ for(hec = Tcl_FirstHashEntry(tablePtr, &hsc);
+ hec != NULL;
+ hec = Tcl_NextHashEntry(&hsc)) {
+
+ NC_STATE* scs = Tcl_GetHashValue (hec);
+ long int symid = (long int) Tcl_GetHashKey (tablePtr, hec);
+ const char* sym = rde_param_query_string (p->p, symid);
+
+ kv [1] = Tcl_NewStringObj (sym,-1);
+
+ vv [0] = Tcl_NewIntObj (scs->CL);
+ vv [1] = Tcl_NewIntObj (scs->ST);
+ vv [2] = rde_param_query_er_tcl (p->p, scs->ER);
+ vv [3] = (scs->SV ? scs->SV : Tcl_NewObj ());
+
+ Tcl_ListObjAppendElement (interp, res, Tcl_NewListObj (2, kv));
+ Tcl_ListObjAppendElement (interp, res, Tcl_NewListObj (4, vv));
+ }
+ }
+
+ Tcl_SetObjResult (interp, res);
+
+ return TCL_OK;
+}
+
+int
+param_TOKENS (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde tokens ?FROM ?TO??
+ * [0] [1] [2] [3]
+ */
+
+ long int num, from, to;
+
+ if ((objc < 2) || (objc > 4)) {
+ Tcl_WrongNumArgs (interp, 2, objv, "?from? ?to?");
+ return TCL_ERROR;
+ }
+
+ num = rde_param_query_tc_size (p->p);
+
+ if (objc == 2) {
+ from = 0;
+ to = num - 1;
+ } else if (objc == 3) {
+
+ if (Tcl_GetLongFromObj (interp, objv [2], &from) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ to = from;
+
+ } else { /* objc == 4 */
+ if (Tcl_GetLongFromObj (interp, objv [2], &from) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetLongFromObj (interp, objv [3], &to) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+
+ if (from < 0) { from = 0; }
+ if (to >= num) { to = num-1; }
+
+ if (to < from) {
+ Tcl_SetObjResult (interp, Tcl_NewObj ());
+ } else {
+ long int len;
+ char* buf;
+
+ rde_param_query_tc_get_s (p->p, from, to, &buf, &len);
+
+ Tcl_SetObjResult (interp, Tcl_NewStringObj (buf,len));
+ }
+
+ return TCL_OK;
+}
+
+int
+param_VALUE (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde value
+ * [0] [1]
+ */
+
+ Tcl_Obj* sv;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ sv = rde_param_query_sv (p->p);
+ if (!sv) {
+ sv = Tcl_NewObj ();
+ }
+
+ Tcl_SetObjResult (interp, sv);
+
+ return TCL_OK;
+}
+
+/* .................................................. */
+
+int
+param_F_continue (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i:fail_continue
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (!rde_param_query_st (p->p)) {
+ return TCL_CONTINUE;
+ }
+
+ return TCL_OK;
+}
+
+int
+param_F_return (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i:fail_return
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (!rde_param_query_st (p->p)) {
+ return TCL_RETURN;
+ }
+
+ return TCL_OK;
+}
+
+int
+param_O_continue (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i:ok_continue
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (rde_param_query_st (p->p)) {
+ return TCL_CONTINUE;
+ }
+
+ return TCL_OK;
+}
+
+int
+param_O_return (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i:ok_return
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (rde_param_query_st (p->p)) {
+ return TCL_RETURN;
+ }
+
+ return TCL_OK;
+}
+
+int
+param_I_st_fail (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_status_fail
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_status_fail (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_st_neg (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_status_negate
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_status_negate (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_st_ok (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_status_ok
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_status_ok (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_er_clear (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_error_clear
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_error_clear (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_er_clear_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_error_clear
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_error_clear (p->p);
+ rde_param_i_error_push (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_er_nt (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_error_nonterminal SYMBOL
+ * [0] [1] [2]
+ */
+
+ long int sym;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "symbol");
+ return TCL_ERROR;
+ }
+
+ /*
+ * interning: n + space + symbol
+ *
+ * The obj literal here is very likely shared with the arguments of
+ * i_symbol_save/restore, and i_value_leaf/reduce, and derivatives. This
+ * here is the only point between these where we save the string id in the
+ * Tcl_Obj*.
+ */
+
+ sym = rde_ot_intern1 (p, "n", objv [2]);
+ rde_param_i_error_nonterminal (p->p, sym);
+
+ return TCL_OK;
+}
+
+int
+param_I_er_popmerge (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_error_pop_merge
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_error_pop_merge (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_er_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_error_push
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_error_push (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_F_loc_pop_rewind (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i:fail_loc_pop_rewind
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_loc_pop_rewind (p->p);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_I_loc_pop_discard (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_loc_pop_discard
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_loc_pop_discard (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_O_loc_pop_discard (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_loc_pop_discard
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_loc_pop_discard (p->p);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_I_loc_pop_rewdis (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_loc_pop_rewind/discard
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_loc_pop_rewind (p->p);
+ } else {
+ rde_param_i_loc_pop_discard (p->p);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_I_loc_pop_rewind (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_loc_pop_rewind
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_loc_pop_rewind (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_loc_rewind (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_loc_pop_rewind
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_loc_rewind (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_loc_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_loc_pop_push
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_loc_push (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_F_ast_pop_rewind (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i:fail_ast_pop_rewind
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_ast_pop_rewind (p->p);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_I_ast_pop_discard (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_ast_pop_discard
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_ast_pop_discard (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_O_ast_pop_discard (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_ast_pop_discard
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_ast_pop_discard (p->p);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_I_ast_pop_disrew (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_ast_pop_discard/rewind
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_ast_pop_discard (p->p);
+ } else {
+ rde_param_i_ast_pop_rewind (p->p);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_I_ast_pop_rewdis (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_ast_pop_rewind/discard
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_ast_pop_rewind (p->p);
+ } else {
+ rde_param_i_ast_pop_discard (p->p);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_I_ast_pop_rewind (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_ast_pop_rewind
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_ast_pop_rewind (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_ast_rewind (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_ast_pop_rewind
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_ast_rewind (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_ast_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_ast_push
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_ast_push (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_O_ast_value_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_ast_value_push
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_ast_value_push (p->p);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_I_symbol_restore (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_symbol_restore SYMBOL
+ * [0] [1] [2]
+ */
+
+ long int sym;
+ int found;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "symbol");
+ return TCL_ERROR;
+ }
+
+ /*
+ * We cannot save the interned string id in the Tcl_Obj*, because this is
+ * already taken by the argument of param_I_er_nt aka i_error_nonterminal,
+ * due to literal sharing in procedure bodies.
+ */
+
+ sym = param_intern (p, Tcl_GetString (objv [2]));
+ found = rde_param_i_symbol_restore (p->p, sym);
+ Tcl_SetObjResult (interp, Tcl_NewIntObj (found));
+
+ return TCL_OK;
+}
+
+int
+param_I_symbol_save (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_symbol_save SYMBOL
+ * [0] [1] [2]
+ */
+
+ long int sym;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "symbol");
+ return TCL_ERROR;
+ }
+
+ /*
+ * We cannot save the interned string id in the Tcl_Obj*, because this is
+ * already taken by the argument of param_I_er_nt aka i_error_nonterminal,
+ * due to literal sharing in procedure bodies.
+ */
+
+ sym = param_intern (p, Tcl_GetString (objv [2]));
+ rde_param_i_symbol_save (p->p, sym);
+
+ return TCL_OK;
+}
+
+int
+param_I_value_cleaf (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_value_clear/leaf SYMBOL
+ * [0] [1] [2]
+ */
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "symbol");
+ return TCL_ERROR;
+ }
+
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_value_clear (p->p);
+ } else {
+ long int sym;
+
+ /*
+ * We cannot save the interned string id in the Tcl_Obj*, because this
+ * is already taken by the argument of param_I_er_nt aka
+ * i_error_nonterminal, due to literal sharing in procedure bodies.
+ */
+
+ sym = param_intern (p, Tcl_GetString (objv [2]));
+ rde_param_i_value_leaf (p->p, sym);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_I_value_clear (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_value_clear
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_value_clear (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_value_creduce (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_value_clear/reduce SYMBOL
+ * [0] [1] [2]
+ */
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "symbol");
+ return TCL_ERROR;
+ }
+
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_value_clear (p->p);
+ } else {
+ long int sym;
+
+ /*
+ * We cannot save the interned string id in the Tcl_Obj*, because this
+ * is already taken by the argument of param_I_er_nt aka
+ * i_error_nonterminal, due to literal sharing in procedure bodies.
+ */
+
+ sym = param_intern (p, Tcl_GetString (objv [2]));
+ rde_param_i_value_reduce (p->p, sym);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_I_input_next (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_input_next MSG
+ * [0] [1] [2]
+ */
+
+ long int msg;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "msg");
+ return TCL_ERROR;
+ }
+
+ /*
+ * interning: msg as is. Already has PE operator in the message.
+ */
+
+ msg = rde_ot_intern0 (p, objv [2]);
+ rde_param_i_input_next (p->p, msg);
+
+ return TCL_OK;
+}
+
+int
+param_I_test_alnum (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_test_alnum
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_test_alnum (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_test_alpha (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_test_alpha
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_test_alpha (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_test_ascii (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_test_ascii
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_test_ascii (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_test_char (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ long int msg;
+ char* ch;
+
+ /* Syntax: rde i_test_char CHAR
+ * [0] [1] [2]
+ */
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "tok");
+ return TCL_ERROR;
+ }
+
+ /*
+ * interning: t + space + char
+ */
+
+ ch = Tcl_GetString (objv [2]);
+ msg = rde_ot_intern1 (p, "t", objv [2]);
+
+ rde_param_i_test_char (p->p, ch, msg);
+ return TCL_OK;
+}
+
+int
+param_I_test_control (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_test_control
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_test_control (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_test_ddigit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_test_ddigit
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_test_ddigit (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_test_digit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_test_digit
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_test_digit (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_test_graph (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_test_graph
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_test_graph (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_test_lower (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_test_lower
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_test_lower (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_test_print (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_test_print
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_test_print (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_test_punct (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_test_punct
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_test_punct (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_test_range (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ long int msg;
+ char* chs;
+ char* che;
+
+ /* Syntax: rde i_test_range START END
+ * [0] [1] [2] [3]
+ */
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs (interp, 2, objv, "toks toke");
+ return TCL_ERROR;
+ }
+
+ /*
+ * interning: .. + space + char + space + char
+ */
+
+ chs = Tcl_GetString (objv [2]);
+ che = Tcl_GetString (objv [3]);
+ msg = rde_ot_intern2 (p, "..", objv [2], objv[3]);
+
+ rde_param_i_test_range (p->p, chs, che, msg);
+
+ return TCL_OK;
+}
+
+int
+param_I_test_space (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_test_space
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_test_space (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_test_upper (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_test_upper
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_test_upper (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_test_wordchar (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_test_wordchar
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_test_wordchar (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_I_test_xdigit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde i_test_xdigit
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_test_xdigit (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_void_state_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:void_state_push
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_loc_push (p->p);
+ rde_param_i_error_clear (p->p);
+ rde_param_i_error_push (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_value_state_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:value_state_push
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_ast_push (p->p);
+ rde_param_i_loc_push (p->p);
+ rde_param_i_error_clear (p->p);
+ rde_param_i_error_push (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_void_state_merge (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:void_state_merge
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_error_pop_merge (p->p);
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_loc_pop_rewind (p->p);
+ } else {
+ rde_param_i_loc_pop_discard (p->p);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_SI_value_state_merge (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:value_state_merge
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_error_pop_merge (p->p);
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_ast_pop_rewind (p->p);
+ rde_param_i_loc_pop_rewind (p->p);
+ } else {
+ rde_param_i_ast_pop_discard (p->p);
+ rde_param_i_loc_pop_discard (p->p);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_SI_voidvoid_branch (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:voidvoid_branch
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_error_pop_merge (p->p);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_loc_pop_discard (p->p);
+ return TCL_RETURN;
+ }
+ rde_param_i_loc_rewind (p->p);
+ rde_param_i_error_push (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_voidvalue_branch (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:voidvalue_branch
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_error_pop_merge (p->p);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_loc_pop_discard (p->p);
+ return TCL_RETURN;
+ }
+ rde_param_i_ast_push (p->p);
+ rde_param_i_loc_rewind (p->p);
+ rde_param_i_error_push (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_valuevoid_branch (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:valuevoid_branch
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_error_pop_merge (p->p);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_ast_pop_discard (p->p);
+ rde_param_i_loc_pop_discard (p->p);
+ return TCL_RETURN;
+ }
+ rde_param_i_ast_pop_rewind (p->p);
+ rde_param_i_loc_rewind (p->p);
+ rde_param_i_error_push (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_valuevalue_branch (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:valuevalue:branch
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_error_pop_merge (p->p);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_ast_pop_discard (p->p);
+ rde_param_i_loc_pop_discard (p->p);
+ return TCL_RETURN;
+ }
+ rde_param_i_ast_rewind (p->p);
+ rde_param_i_loc_rewind (p->p);
+ rde_param_i_error_push (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_voidvoid_part (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:voidvoid_part
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_error_pop_merge (p->p);
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_loc_pop_rewind (p->p);
+ return TCL_RETURN;
+ }
+ rde_param_i_error_push (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_voidvalue_part (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:voidvalue_part
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_error_pop_merge (p->p);
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_loc_pop_rewind (p->p);
+ return TCL_RETURN;
+ }
+ rde_param_i_ast_push (p->p);
+ rde_param_i_error_push (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_valuevalue_part (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:valuevalue_part
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_error_pop_merge (p->p);
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_ast_pop_rewind (p->p);
+ rde_param_i_loc_pop_rewind (p->p);
+ return TCL_RETURN;
+ }
+ rde_param_i_error_push (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_next_char (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ long int msg;
+ char* ch;
+
+ /* Syntax: rde i_next_char CHAR
+ * [0] [1] [2]
+ */
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "tok");
+ return TCL_ERROR;
+ }
+
+ /*
+ * interning: t + space + char
+ */
+
+ ch = Tcl_GetString (objv [2]);
+ msg = rde_ot_intern1 (p, "t", objv [2]);
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_char (p->p, ch, msg);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_next_range (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ long int msg;
+ char* chs;
+ char* che;
+
+ /* Syntax: rde i_next_range START END
+ * [0] [1] [2] [3]
+ */
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs (interp, 2, objv, "toks toke");
+ return TCL_ERROR;
+ }
+
+ /*
+ * interning: .. + space + char + space + char
+ */
+
+ chs = Tcl_GetString (objv [2]);
+ che = Tcl_GetString (objv [3]);
+ msg = rde_ot_intern2 (p, "..", objv [2], objv[3]);
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_range (p->p, chs, che, msg);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_next_alnum (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:next_alnum
+ * [0] [1]
+ */
+
+ long int msg;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ msg = param_intern (p, "alnum");
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_alnum (p->p);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_next_alpha (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:next_alpha
+ * [0] [1]
+ */
+
+ long int msg;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ msg = param_intern (p, "alpha");
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_alpha (p->p);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_next_ascii (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:next_ascii
+ * [0] [1]
+ */
+
+ long int msg;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ msg = param_intern (p, "ascii");
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_ascii (p->p);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_next_control (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:next_control
+ * [0] [1]
+ */
+
+ long int msg;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ msg = param_intern (p, "control");
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_control (p->p);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_next_ddigit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:next_ddigit
+ * [0] [1]
+ */
+
+ long int msg;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ msg = param_intern (p, "ddigit");
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_ddigit (p->p);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_next_digit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:next_digit
+ * [0] [1]
+ */
+
+ long int msg;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ msg = param_intern (p, "digit");
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_digit (p->p);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_next_graph (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:next_graph
+ * [0] [1]
+ */
+
+ long int msg;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ msg = param_intern (p, "graph");
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_graph (p->p);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_next_lower (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:next_lower
+ * [0] [1]
+ */
+
+ long int msg;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ msg = param_intern (p, "lower");
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_lower (p->p);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_next_print (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:next_print
+ * [0] [1]
+ */
+
+ long int msg;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ msg = param_intern (p, "print");
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_print (p->p);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_next_punct (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:next_punct
+ * [0] [1]
+ */
+
+ long int msg;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ msg = param_intern (p, "punct");
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_punct (p->p);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_next_space (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:next_space
+ * [0] [1]
+ */
+
+ long int msg;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ msg = param_intern (p, "space");
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_space (p->p);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_next_upper (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:next_upper
+ * [0] [1]
+ */
+
+ long int msg;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ msg = param_intern (p, "upper");
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_upper (p->p);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_next_wordchar (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:next_wordchar
+ * [0] [1]
+ */
+
+ long int msg;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ msg = param_intern (p, "wordchar");
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_wordchar (p->p);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_next_xdigit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:next_xdigit
+ * [0] [1]
+ */
+
+ long int msg;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ msg = param_intern (p, "xdigit");
+
+ rde_param_i_input_next (p->p, msg);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_test_xdigit (p->p);
+ }
+ return TCL_OK;
+}
+
+int
+param_SI_void2_state_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:void2_state_push
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_loc_push (p->p);
+ rde_param_i_error_push (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_void_state_merge_ok (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:void_state_merge_ok
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_error_pop_merge (p->p);
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_loc_pop_rewind (p->p);
+ rde_param_i_status_ok (p->p);
+ } else {
+ rde_param_i_loc_pop_discard (p->p);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_SI_value_notahead_start (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:void_notahead_start
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_loc_push (p->p);
+ rde_param_i_ast_push (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_void_notahead_exit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:void_notahead_exit
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_loc_pop_rewind (p->p);
+ rde_param_i_status_negate (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_value_notahead_exit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:value_notahead_exit
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_loc_pop_rewind (p->p);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_ast_pop_rewind (p->p);
+ } else {
+ rde_param_i_ast_pop_discard (p->p);
+ }
+ rde_param_i_status_negate (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_kleene_abort (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:kleene_abort
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_loc_pop_discard (p->p);
+ return TCL_OK;
+ } else {
+ rde_param_i_loc_pop_rewind (p->p);
+ return TCL_RETURN;
+ }
+}
+
+int
+param_SI_kleene_close (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:kleene_close
+ * [0] [1]
+ */
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs (interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ rde_param_i_error_pop_merge (p->p);
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_loc_pop_discard (p->p);
+ return TCL_OK;
+ } else {
+ rde_param_i_loc_pop_rewind (p->p);
+ rde_param_i_status_ok (p->p);
+ return TCL_RETURN;
+ }
+}
+
+int
+param_SI_value_symbol_start (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:value_symbol_start SYMBOL
+ * [0] [1] [2]
+ */
+
+ long int sym;
+ int found;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "symbol");
+ return TCL_ERROR;
+ }
+
+ /*
+ * We cannot save the interned string id in the Tcl_Obj*, because this is
+ * already taken by the argument of param_I_er_nt aka i_error_nonterminal,
+ * due to literal sharing in procedure bodies.
+ */
+
+ sym = param_intern (p, Tcl_GetString (objv [2]));
+
+ found = rde_param_i_symbol_restore (p->p, sym);
+ if (found) {
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_ast_value_push (p->p);
+ }
+ return TCL_RETURN;
+ }
+
+ rde_param_i_loc_push (p->p);
+ rde_param_i_ast_push (p->p);
+ return TCL_OK;
+}
+
+int
+param_SI_value_void_symbol_start (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:value_void_symbol_start SYMBOL
+ * [0] [1] [2]
+ */
+
+ long int sym;
+ int found;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "symbol");
+ return TCL_ERROR;
+ }
+
+ /*
+ * We cannot save the interned string id in the Tcl_Obj*, because this is
+ * already taken by the argument of param_I_er_nt aka i_error_nonterminal,
+ * due to literal sharing in procedure bodies.
+ */
+
+ sym = param_intern (p, Tcl_GetString (objv [2]));
+
+ found = rde_param_i_symbol_restore (p->p, sym);
+ if (found) {
+ return TCL_RETURN;
+ }
+
+ rde_param_i_loc_push (p->p);
+ rde_param_i_ast_push (p->p);
+ return TCL_OK;
+}
+
+int
+param_SI_void_symbol_start (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:void_symbol_start SYMBOL
+ * [0] [1] [2]
+ */
+
+ long int sym;
+ int found;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "symbol");
+ return TCL_ERROR;
+ }
+
+ /*
+ * We cannot save the interned string id in the Tcl_Obj*, because this is
+ * already taken by the argument of param_I_er_nt aka i_error_nonterminal,
+ * due to literal sharing in procedure bodies.
+ */
+
+ sym = param_intern (p, Tcl_GetString (objv [2]));
+
+ found = rde_param_i_symbol_restore (p->p, sym);
+ if (found) {
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_ast_value_push (p->p);
+ }
+ return TCL_RETURN;
+ }
+
+ rde_param_i_loc_push (p->p);
+ return TCL_OK;
+}
+
+int
+param_SI_void_void_symbol_start (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:void_void_symbol_start SYMBOL
+ * [0] [1] [2]
+ */
+
+ long int sym;
+ int found;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "symbol");
+ return TCL_ERROR;
+ }
+
+ /*
+ * We cannot save the interned string id in the Tcl_Obj*, because this is
+ * already taken by the argument of param_I_er_nt aka i_error_nonterminal,
+ * due to literal sharing in procedure bodies.
+ */
+
+ sym = param_intern (p, Tcl_GetString (objv [2]));
+
+ found = rde_param_i_symbol_restore (p->p, sym);
+ if (found) {
+ return TCL_RETURN;
+ }
+
+ rde_param_i_loc_push (p->p);
+ return TCL_OK;
+}
+
+int
+param_SI_reduce_symbol_end (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:reduce_symbol_end SYMBOL
+ * [0] [1] [2]
+ */
+
+ long int sym, msg;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "symbol");
+ return TCL_ERROR;
+ }
+
+ /*
+ * We cannot save the interned string id in the Tcl_Obj*, because this is
+ * already taken by the argument of param_I_er_nt aka i_error_nonterminal,
+ * due to literal sharing in procedure bodies.
+ */
+
+ sym = param_intern (p, Tcl_GetString (objv [2]));
+
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_value_clear (p->p);
+ } else {
+ rde_param_i_value_reduce (p->p, sym);
+ }
+
+ rde_param_i_symbol_save (p->p, sym);
+
+ /*
+ * interning: n + space + symbol
+ *
+ * The obj literal here is very likely shared with the arguments of
+ * i_symbol_save/restore, and i_value_leaf/reduce, and derivatives. This
+ * here is the only point between these where we save the string id in the
+ * Tcl_Obj*.
+ */
+
+ msg = rde_ot_intern1 (p, "n", objv [2]);
+
+ rde_param_i_error_nonterminal (p->p, msg);
+ rde_param_i_ast_pop_rewind (p->p);
+ rde_param_i_loc_pop_discard (p->p);
+
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_ast_value_push (p->p);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_SI_void_leaf_symbol_end (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:void_leaf_symbol_end SYMBOL
+ * [0] [1] [2]
+ */
+
+ long int sym, msg;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "symbol");
+ return TCL_ERROR;
+ }
+
+ /*
+ * We cannot save the interned string id in the Tcl_Obj*, because this is
+ * already taken by the argument of param_I_er_nt aka i_error_nonterminal,
+ * due to literal sharing in procedure bodies.
+ */
+
+ sym = param_intern (p, Tcl_GetString (objv [2]));
+
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_value_clear (p->p);
+ } else {
+ rde_param_i_value_leaf (p->p, sym);
+ }
+
+ rde_param_i_symbol_save (p->p, sym);
+
+ /*
+ * interning: n + space + symbol
+ *
+ * The obj literal here is very likely shared with the arguments of
+ * i_symbol_save/restore, and i_value_leaf/reduce, and derivatives. This
+ * here is the only point between these where we save the string id in the
+ * Tcl_Obj*.
+ */
+
+ msg = rde_ot_intern1 (p, "n", objv [2]);
+
+ rde_param_i_error_nonterminal (p->p, msg);
+ rde_param_i_loc_pop_discard (p->p);
+
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_ast_value_push (p->p);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_SI_value_leaf_symbol_end (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:value_leaf_symbol_end SYMBOL
+ * [0] [1] [2]
+ */
+
+ long int sym, msg;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "symbol");
+ return TCL_ERROR;
+ }
+
+ /*
+ * We cannot save the interned string id in the Tcl_Obj*, because this is
+ * already taken by the argument of param_I_er_nt aka i_error_nonterminal,
+ * due to literal sharing in procedure bodies.
+ */
+
+ sym = param_intern (p, Tcl_GetString (objv [2]));
+
+ if (!rde_param_query_st (p->p)) {
+ rde_param_i_value_clear (p->p);
+ } else {
+ rde_param_i_value_leaf (p->p, sym);
+ }
+
+ rde_param_i_symbol_save (p->p, sym);
+
+ /*
+ * interning: n + space + symbol
+ *
+ * The obj literal here is very likely shared with the arguments of
+ * i_symbol_save/restore, and i_value_leaf/reduce, and derivatives. This
+ * here is the only point between these where we save the string id in the
+ * Tcl_Obj*.
+ */
+
+ msg = rde_ot_intern1 (p, "n", objv [2]);
+
+ rde_param_i_error_nonterminal (p->p, msg);
+ rde_param_i_ast_pop_rewind (p->p);
+ rde_param_i_loc_pop_discard (p->p);
+
+ if (rde_param_query_st (p->p)) {
+ rde_param_i_ast_value_push (p->p);
+ }
+
+ return TCL_OK;
+}
+
+int
+param_SI_value_clear_symbol_end (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:value_clear_symbol_end SYMBOL
+ * [0] [1] [2]
+ */
+
+ long int sym, msg;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "symbol");
+ return TCL_ERROR;
+ }
+
+ /*
+ * We cannot save the interned string id in the Tcl_Obj*, because this is
+ * already taken by the argument of param_I_er_nt aka i_error_nonterminal,
+ * due to literal sharing in procedure bodies.
+ */
+
+ sym = param_intern (p, Tcl_GetString (objv [2]));
+
+ rde_param_i_value_clear (p->p);
+ rde_param_i_symbol_save (p->p, sym);
+
+ /*
+ * interning: n + space + symbol
+ *
+ * The obj literal here is very likely shared with the arguments of
+ * i_symbol_save/restore, and i_value_leaf/reduce, and derivatives. This
+ * here is the only point between these where we save the string id in the
+ * Tcl_Obj*.
+ */
+
+ msg = rde_ot_intern1 (p, "n", objv [2]);
+
+ rde_param_i_error_nonterminal (p->p, msg);
+ rde_param_i_ast_pop_rewind (p->p);
+ rde_param_i_loc_pop_discard (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_void_clear_symbol_end (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ /* Syntax: rde si:void_clear_symbol_end SYMBOL
+ * [0] [1] [2]
+ */
+
+ long int sym, msg;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "symbol");
+ return TCL_ERROR;
+ }
+
+ /*
+ * We cannot save the interned string id in the Tcl_Obj*, because this is
+ * already taken by the argument of param_I_er_nt aka i_error_nonterminal,
+ * due to literal sharing in procedure bodies.
+ */
+
+ sym = param_intern (p, Tcl_GetString (objv [2]));
+
+ rde_param_i_value_clear (p->p);
+ rde_param_i_symbol_save (p->p, sym);
+
+ /*
+ * interning: n + space + symbol
+ *
+ * The obj literal here is very likely shared with the arguments of
+ * i_symbol_save/restore, and i_value_leaf/reduce, and derivatives. This
+ * here is the only point between these where we save the string id in the
+ * Tcl_Obj*.
+ */
+
+ msg = rde_ot_intern1 (p, "n", objv [2]);
+
+ rde_param_i_error_nonterminal (p->p, msg);
+ rde_param_i_loc_pop_discard (p->p);
+
+ return TCL_OK;
+}
+
+int
+param_SI_next_str (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ long int msg;
+ int len, i;
+ char* str;
+
+ /* Syntax: rde i_next_char CHAR
+ * [0] [1] [2]
+ */
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "tok");
+ return TCL_ERROR;
+ }
+
+ /*
+ * interning: str + space + char
+ */
+
+ str = Tcl_GetStringFromObj (objv [2], &len);
+ msg = rde_ot_intern1 (p, "str", objv [2]);
+
+ rde_param_i_next_str (p->p, str, msg);
+ return TCL_OK;
+}
+
+int
+param_SI_next_class (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ long int msg;
+ int len, i;
+ char* class;
+
+ /* Syntax: rde i_next_char CHAR
+ * [0] [1] [2]
+ */
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs (interp, 2, objv, "tok");
+ return TCL_ERROR;
+ }
+
+ /*
+ * interning: cl + space + char
+ */
+
+ class = Tcl_GetStringFromObj (objv [2], &len);
+ msg = rde_ot_intern1 (p, "cl", objv [2]);
+
+ rde_param_i_next_class (p->p, class, msg);
+ return TCL_OK;
+}
+
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/m.h b/tcllib/modules/pt/rde_critcl/m.h
new file mode 100644
index 0000000..8d3395a
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/m.h
@@ -0,0 +1,150 @@
+/* pt::rde::critcl - critcl - layer 3 declarations
+ * Method functions.
+ */
+
+#ifndef _M_H
+#define _M_H 1
+
+#include "tcl.h"
+#include <p.h>
+
+int param_AMARKED (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_AST (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_ASTS (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_CHAN (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_COLUMN (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_COMPLETE (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_CURRENT (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_DATA (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_DESTROY (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_EMARKED (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_ERROR (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_LINE (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_LMARKED (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_LOCATION (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_OK (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_POSITION (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_RESET (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SCACHED (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SYMBOLS (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_TOKENS (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_VALUE (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+int param_F_continue (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_F_return (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_O_continue (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_O_return (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+int param_I_st_fail (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_st_neg (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_st_ok (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+int param_I_er_clear (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_er_clear_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_er_nt (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_er_popmerge (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_er_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+int param_F_loc_pop_rewind (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_loc_pop_discard (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_loc_pop_rewdis (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_loc_pop_rewind (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_loc_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_loc_rewind (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_O_loc_pop_discard (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+int param_F_ast_pop_rewind (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_ast_pop_discard (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_ast_pop_disrew (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_ast_pop_rewdis (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_ast_pop_rewind (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_ast_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_ast_rewind (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_O_ast_pop_discard (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_O_ast_value_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+int param_I_symbol_restore (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_symbol_save (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+int param_I_value_cleaf (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_value_clear (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_value_creduce (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+int param_I_input_next (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+int param_I_test_alnum (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_test_alpha (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_test_ascii (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_test_char (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_test_control (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_test_ddigit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_test_digit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_test_graph (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_test_lower (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_test_print (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_test_punct (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_test_range (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_test_space (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_test_upper (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_test_wordchar (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_I_test_xdigit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+int param_SI_void_state_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_value_state_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_void_state_merge (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_value_state_merge (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_voidvoid_branch (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_voidvalue_branch (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_valuevoid_branch (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_valuevalue_branch (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_voidvoid_part (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_voidvalue_part (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_valuevalue_part (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+int param_SI_next_char (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_range (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_alnum (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_alpha (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_ascii (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_control (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_ddigit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_digit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_graph (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_lower (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_print (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_punct (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_space (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_upper (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_wordchar (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_xdigit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+int param_SI_void2_state_push (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_void_state_merge_ok (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_value_notahead_start (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_void_notahead_exit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_value_notahead_exit (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_kleene_abort (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_kleene_close (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+int param_SI_value_symbol_start (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_value_void_symbol_start (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_void_symbol_start (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_void_void_symbol_start (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_reduce_symbol_end (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_void_leaf_symbol_end (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_value_leaf_symbol_end (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_value_clear_symbol_end (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_void_clear_symbol_end (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+int param_SI_next_str (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+int param_SI_next_class (RDE_STATE p, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+#endif /* _M_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/ms.c b/tcllib/modules/pt/rde_critcl/ms.c
new file mode 100644
index 0000000..2865e73
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/ms.c
@@ -0,0 +1,317 @@
+/* pt::rde::critcl - critcl - layer 2 definitions
+ *
+ * -> Support for the stack methods in layer 3.
+ */
+
+#include <ms.h> /* Our public API */
+#include <m.h> /* Method declarations */
+#include <util.h> /* Trace utilities */
+#ifdef RDE_TRACE
+#include <pInt.h> /* To have access to icount */
+#endif
+/* .................................................. */
+/*
+ *---------------------------------------------------------------------------
+ *
+ * paramms_objcmd --
+ *
+ * Implementation of stack objects, the main dispatcher function.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * Per the called methods.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+paramms_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
+{
+ RDE_STATE p = (RDE_STATE) cd;
+ int m, res = TCL_ERROR;
+
+ static CONST char* methods [] = {
+ "amarked", "ast", "asts", "chan",
+ "complete", "current", "data", "destroy", "emarked",
+ "error", "lmarked", "location", "ok",
+ "reset", "scached", "symbols", "tokens",
+ "value", "i:fail_continue", "i:fail_return", "i:ok_continue",
+ "i:ok_return", "i_status_fail", "i_status_negate", "i_status_ok",
+ "i_error_clear","i_error_nonterminal", "i_error_pop_merge", "i_error_push",
+ "i:fail_loc_pop_rewind", "i_loc_pop_discard",
+ "i_loc_pop_rewind/discard", "i_loc_pop_rewind", "i_loc_push",
+ "i:fail_ast_pop_rewind", "i_ast_pop_discard", "i_ast_pop_discard/rewind",
+ "i_ast_pop_rewind/discard", "i_ast_pop_rewind", "i_ast_push",
+ "i:ok_ast_value_push", "i_symbol_restore", "i_symbol_save",
+ "i_value_clear/leaf", "i_value_clear", "i_value_clear/reduce",
+ "i_input_next", "i_test_alnum", "i_test_alpha", "i_test_ascii", "i_test_char", "i_test_control",
+ "i_test_ddigit","i_test_digit", "i_test_graph", "i_test_lower", "i_test_print",
+ "i_test_punct", "i_test_range", "i_test_space", "i_test_upper", "i_test_wordchar",
+ "i_test_xdigit",
+ "i:ok_ast_pop_discard", "i_ast_rewind",
+ "i:ok_loc_pop_discard", "i_loc_rewind",
+ "i_error_clear_push",
+ "si:void_state_push",
+ "si:value_state_push",
+ "si:void_state_merge",
+ "si:value_state_merge",
+ "si:voidvoid_branch",
+ "si:voidvalue_branch",
+ "si:valuevoid_branch",
+ "si:valuevalue_branch",
+ "si:voidvoid_part",
+ "si:voidvalue_part",
+ "si:valuevalue_part",
+ "si:next_char",
+ "si:next_range",
+ "si:next_alnum", "si:next_alpha", "si:next_ascii", "si:next_control",
+ "si:next_ddigit","si:next_digit", "si:next_graph", "si:next_lower", "si:next_print",
+ "si:next_punct", "si:next_space", "si:next_upper", "si:next_wordchar",
+ "si:next_xdigit",
+
+ "si:void2_state_push",
+ "si:void_state_merge_ok",
+ "si:value_notahead_start",
+ "si:void_notahead_exit",
+ "si:value_notahead_exit",
+ "si:kleene_abort",
+ "si:kleene_close",
+
+ "si:value_symbol_start",
+ "si:value_void_symbol_start",
+ "si:void_symbol_start",
+ "si:void_void_symbol_start",
+ "si:reduce_symbol_end",
+ "si:void_leaf_symbol_end",
+ "si:value_leaf_symbol_end",
+ "si:value_clear_symbol_end",
+ "si:void_clear_symbol_end",
+
+ "si:next_str",
+ "si:next_class",
+ NULL
+ };
+ enum methods {
+ M_AMARKED, M_AST, M_ASTS, M_CHAN, M_COMPLETE, M_CURRENT,
+ M_DATA, M_DESTROY, M_EMARKED, M_ERROR, M_LMARKED, M_LOCATION, M_OK,
+ M_RESET, M_SCACHED, M_SYMBOLS, M_TOKENS,
+ M_VALUE, M_F_continue, M_F_return, M_O_continue, M_O_return,
+ M_I_st_fail, M_I_st_neg, M_I_st_ok, M_I_er_clear, M_I_er_nt,
+ M_I_er_popmerge, M_I_er_push, M_F_loc_pop_rewind, M_I_loc_pop_discard,
+ M_I_loc_pop_rewdis, M_I_loc_pop_rewind, M_I_loc_push, M_F_ast_pop_rewind,
+ M_I_ast_pop_discard, M_I_ast_pop_disrew, M_I_ast_pop_rewdis,
+ M_I_ast_pop_rewind, M_I_ast_push, M_O_ast_value_push, M_I_symbol_restore,
+ M_I_symbol_save, M_I_value_cleaf, M_I_value_clear, M_I_value_creduce,
+ M_I_input_next, M_I_test_alnum, M_I_test_alpha, M_I_test_ascii, M_I_test_char, M_I_test_control,
+ M_I_test_ddigit, M_I_test_digit, M_I_test_graph, M_I_test_lower, M_I_test_print,
+ M_I_test_punct, M_I_test_range, M_I_test_space, M_I_test_upper, M_I_test_wordchar,
+ M_I_test_xdigit,
+
+ M_O_ast_pop_discard,
+ M_I_ast_rewind,
+ M_O_loc_pop_discard,
+ M_I_loc_rewind,
+ M_I_er_clear_push,
+
+ M_SI_void_state_push,
+ M_SI_value_state_push,
+ M_SI_void_state_merge,
+ M_SI_value_state_merge,
+ M_SI_voidvoid_branch,
+ M_SI_voidvalue_branch,
+ M_SI_valuevoid_branch,
+ M_SI_valuevalue_branch,
+ M_SI_voidvoid_part,
+ M_SI_voidvalue_part,
+ M_SI_valuevalue_part,
+
+ M_SI_next_char,
+ M_SI_next_range,
+ M_SI_next_alnum,
+ M_SI_next_alpha,
+ M_SI_next_ascii,
+ M_SI_next_control,
+ M_SI_next_ddigit,
+ M_SI_next_digit,
+ M_SI_next_graph,
+ M_SI_next_lower,
+ M_SI_next_print,
+ M_SI_next_punct,
+ M_SI_next_space,
+ M_SI_next_upper,
+ M_SI_next_wordchar,
+ M_SI_next_xdigit,
+
+ M_SI_void2_state_push,
+ M_SI_void_state_merge_ok,
+ M_SI_value_notahead_start,
+ M_SI_void_notahead_exit,
+ M_SI_value_notahead_exit,
+ M_SI_kleene_abort,
+ M_SI_kleene_close,
+
+ M_SI_value_symbol_start,
+ M_SI_value_void_symbol_start,
+ M_SI_void_symbol_start,
+ M_SI_void_void_symbol_start,
+ M_SI_reduce_symbol_end,
+ M_SI_void_leaf_symbol_end,
+ M_SI_value_leaf_symbol_end,
+ M_SI_value_clear_symbol_end,
+ M_SI_void_clear_symbol_end,
+
+ M_SI_next_str,
+ M_SI_next_class
+ };
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs (interp, objc, objv, "option ?arg arg ...?");
+ return TCL_ERROR;
+ } else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option",
+ 0, &m) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /* Dispatch to methods. They check the #args in detail before performing
+ * the requested functionality
+ */
+
+ TRACE0 (("%8d RDE %s", ++p->icount, Tcl_GetString(objv [1])));
+ ENTER (Tcl_GetString(objv [1]));
+
+ switch (m) {
+ case M_AMARKED: res = param_AMARKED (p, interp, objc, objv); break;
+ case M_AST: res = param_AST (p, interp, objc, objv); break;
+ case M_ASTS: res = param_ASTS (p, interp, objc, objv); break;
+ case M_CHAN: res = param_CHAN (p, interp, objc, objv); break;
+ case M_COMPLETE: res = param_COMPLETE (p, interp, objc, objv); break;
+ case M_CURRENT: res = param_CURRENT (p, interp, objc, objv); break;
+ case M_DATA: res = param_DATA (p, interp, objc, objv); break;
+ case M_DESTROY: res = param_DESTROY (p, interp, objc, objv); break;
+ case M_EMARKED: res = param_EMARKED (p, interp, objc, objv); break;
+ case M_ERROR: res = param_ERROR (p, interp, objc, objv); break;
+ case M_LMARKED: res = param_LMARKED (p, interp, objc, objv); break;
+ case M_LOCATION: res = param_LOCATION (p, interp, objc, objv); break;
+ case M_OK: res = param_OK (p, interp, objc, objv); break;
+ case M_RESET: res = param_RESET (p, interp, objc, objv); break;
+ case M_SCACHED: res = param_SCACHED (p, interp, objc, objv); break;
+ case M_SYMBOLS: res = param_SYMBOLS (p, interp, objc, objv); break;
+ case M_TOKENS: res = param_TOKENS (p, interp, objc, objv); break;
+ case M_VALUE: res = param_VALUE (p, interp, objc, objv); break;
+ case M_F_continue: res = param_F_continue (p, interp, objc, objv); break;
+ case M_F_return: res = param_F_return (p, interp, objc, objv); break;
+ case M_O_continue: res = param_O_continue (p, interp, objc, objv); break;
+ case M_O_return: res = param_O_return (p, interp, objc, objv); break;
+ case M_I_st_fail: res = param_I_st_fail (p, interp, objc, objv); break;
+ case M_I_st_neg: res = param_I_st_neg (p, interp, objc, objv); break;
+ case M_I_st_ok: res = param_I_st_ok (p, interp, objc, objv); break;
+ case M_I_er_clear: res = param_I_er_clear (p, interp, objc, objv); break;
+ case M_I_er_clear_push: res = param_I_er_clear_push (p, interp, objc, objv); break;
+ case M_I_er_nt: res = param_I_er_nt (p, interp, objc, objv); break;
+ case M_I_er_popmerge: res = param_I_er_popmerge (p, interp, objc, objv); break;
+ case M_I_er_push: res = param_I_er_push (p, interp, objc, objv); break;
+ case M_F_loc_pop_rewind: res = param_F_loc_pop_rewind (p, interp, objc, objv); break;
+ case M_I_loc_pop_discard: res = param_I_loc_pop_discard (p, interp, objc, objv); break;
+ case M_I_loc_pop_rewdis: res = param_I_loc_pop_rewdis (p, interp, objc, objv); break;
+ case M_I_loc_pop_rewind: res = param_I_loc_pop_rewind (p, interp, objc, objv); break;
+ case M_I_loc_push: res = param_I_loc_push (p, interp, objc, objv); break;
+ case M_I_loc_rewind: res = param_I_loc_rewind (p, interp, objc, objv); break;
+ case M_O_loc_pop_discard: res = param_O_loc_pop_discard (p, interp, objc, objv); break;
+ case M_F_ast_pop_rewind: res = param_F_ast_pop_rewind (p, interp, objc, objv); break;
+ case M_I_ast_pop_discard: res = param_I_ast_pop_discard (p, interp, objc, objv); break;
+ case M_I_ast_pop_disrew: res = param_I_ast_pop_disrew (p, interp, objc, objv); break;
+ case M_I_ast_pop_rewdis: res = param_I_ast_pop_rewdis (p, interp, objc, objv); break;
+ case M_I_ast_pop_rewind: res = param_I_ast_pop_rewind (p, interp, objc, objv); break;
+ case M_I_ast_push: res = param_I_ast_push (p, interp, objc, objv); break;
+ case M_I_ast_rewind: res = param_I_ast_rewind (p, interp, objc, objv); break;
+ case M_O_ast_pop_discard: res = param_O_ast_pop_discard (p, interp, objc, objv); break;
+ case M_O_ast_value_push: res = param_O_ast_value_push (p, interp, objc, objv); break;
+ case M_I_symbol_restore: res = param_I_symbol_restore (p, interp, objc, objv); break;
+ case M_I_symbol_save: res = param_I_symbol_save (p, interp, objc, objv); break;
+ case M_I_value_cleaf: res = param_I_value_cleaf (p, interp, objc, objv); break;
+ case M_I_value_clear: res = param_I_value_clear (p, interp, objc, objv); break;
+ case M_I_value_creduce: res = param_I_value_creduce (p, interp, objc, objv); break;
+ case M_I_input_next: res = param_I_input_next (p, interp, objc, objv); break;
+ case M_I_test_alnum: res = param_I_test_alnum (p, interp, objc, objv); break;
+ case M_I_test_alpha: res = param_I_test_alpha (p, interp, objc, objv); break;
+ case M_I_test_ascii: res = param_I_test_ascii (p, interp, objc, objv); break;
+ case M_I_test_char: res = param_I_test_char (p, interp, objc, objv); break;
+ case M_I_test_control: res = param_I_test_control (p, interp, objc, objv); break;
+ case M_I_test_ddigit: res = param_I_test_ddigit (p, interp, objc, objv); break;
+ case M_I_test_digit: res = param_I_test_digit (p, interp, objc, objv); break;
+ case M_I_test_graph: res = param_I_test_graph (p, interp, objc, objv); break;
+ case M_I_test_lower: res = param_I_test_lower (p, interp, objc, objv); break;
+ case M_I_test_print: res = param_I_test_print (p, interp, objc, objv); break;
+ case M_I_test_punct: res = param_I_test_punct (p, interp, objc, objv); break;
+ case M_I_test_range: res = param_I_test_range (p, interp, objc, objv); break;
+ case M_I_test_space: res = param_I_test_space (p, interp, objc, objv); break;
+ case M_I_test_upper: res = param_I_test_upper (p, interp, objc, objv); break;
+ case M_I_test_wordchar: res = param_I_test_wordchar (p, interp, objc, objv); break;
+ case M_I_test_xdigit: res = param_I_test_xdigit (p, interp, objc, objv); break;
+
+ case M_SI_void_state_push: res = param_SI_void_state_push (p, interp, objc, objv); break;
+ case M_SI_value_state_push: res = param_SI_value_state_push (p, interp, objc, objv); break;
+ case M_SI_void_state_merge: res = param_SI_void_state_merge (p, interp, objc, objv); break;
+ case M_SI_value_state_merge: res = param_SI_value_state_merge (p, interp, objc, objv); break;
+ case M_SI_voidvoid_branch: res = param_SI_voidvoid_branch (p, interp, objc, objv); break;
+ case M_SI_voidvalue_branch: res = param_SI_voidvalue_branch (p, interp, objc, objv); break;
+ case M_SI_valuevoid_branch: res = param_SI_valuevoid_branch (p, interp, objc, objv); break;
+ case M_SI_valuevalue_branch: res = param_SI_valuevalue_branch (p, interp, objc, objv); break;
+ case M_SI_voidvoid_part: res = param_SI_voidvoid_part (p, interp, objc, objv); break;
+ case M_SI_voidvalue_part: res = param_SI_voidvalue_part (p, interp, objc, objv); break;
+ case M_SI_valuevalue_part: res = param_SI_valuevalue_part (p, interp, objc, objv); break;
+
+ case M_SI_next_char: res = param_SI_next_char (p, interp, objc, objv); break;
+ case M_SI_next_range: res = param_SI_next_range (p, interp, objc, objv); break;
+ case M_SI_next_alnum: res = param_SI_next_alnum (p, interp, objc, objv); break;
+ case M_SI_next_alpha: res = param_SI_next_alpha (p, interp, objc, objv); break;
+ case M_SI_next_ascii: res = param_SI_next_ascii (p, interp, objc, objv); break;
+ case M_SI_next_control: res = param_SI_next_control (p, interp, objc, objv); break;
+ case M_SI_next_ddigit: res = param_SI_next_ddigit (p, interp, objc, objv); break;
+ case M_SI_next_digit: res = param_SI_next_digit (p, interp, objc, objv); break;
+ case M_SI_next_graph: res = param_SI_next_graph (p, interp, objc, objv); break;
+ case M_SI_next_lower: res = param_SI_next_lower (p, interp, objc, objv); break;
+ case M_SI_next_print: res = param_SI_next_print (p, interp, objc, objv); break;
+ case M_SI_next_punct: res = param_SI_next_punct (p, interp, objc, objv); break;
+ case M_SI_next_space: res = param_SI_next_space (p, interp, objc, objv); break;
+ case M_SI_next_upper: res = param_SI_next_upper (p, interp, objc, objv); break;
+ case M_SI_next_wordchar: res = param_SI_next_wordchar(p, interp, objc, objv); break;
+ case M_SI_next_xdigit: res = param_SI_next_xdigit (p, interp, objc, objv); break;
+
+ case M_SI_void2_state_push: res = param_SI_void2_state_push (p, interp, objc, objv); break;
+ case M_SI_void_state_merge_ok: res = param_SI_void_state_merge_ok (p, interp, objc, objv); break;
+ case M_SI_value_notahead_start: res = param_SI_value_notahead_start (p, interp, objc, objv); break;
+ case M_SI_void_notahead_exit: res = param_SI_void_notahead_exit (p, interp, objc, objv); break;
+ case M_SI_value_notahead_exit: res = param_SI_value_notahead_exit (p, interp, objc, objv); break;
+ case M_SI_kleene_abort: res = param_SI_kleene_abort (p, interp, objc, objv); break;
+ case M_SI_kleene_close: res = param_SI_kleene_close (p, interp, objc, objv); break;
+
+ case M_SI_value_symbol_start: res = param_SI_value_symbol_start (p, interp, objc, objv); break;
+ case M_SI_value_void_symbol_start: res = param_SI_value_void_symbol_start (p, interp, objc, objv); break;
+ case M_SI_void_symbol_start: res = param_SI_void_symbol_start (p, interp, objc, objv); break;
+ case M_SI_void_void_symbol_start: res = param_SI_void_void_symbol_start (p, interp, objc, objv); break;
+ case M_SI_reduce_symbol_end: res = param_SI_reduce_symbol_end (p, interp, objc, objv); break;
+ case M_SI_void_leaf_symbol_end: res = param_SI_void_leaf_symbol_end (p, interp, objc, objv); break;
+ case M_SI_value_leaf_symbol_end: res = param_SI_value_leaf_symbol_end (p, interp, objc, objv); break;
+ case M_SI_value_clear_symbol_end: res = param_SI_value_clear_symbol_end (p, interp, objc, objv); break;
+ case M_SI_void_clear_symbol_end: res = param_SI_void_clear_symbol_end (p, interp, objc, objv); break;
+
+ case M_SI_next_str: res = param_SI_next_str (p, interp, objc, objv); break;
+ case M_SI_next_class: res = param_SI_next_class (p, interp, objc, objv); break;
+ default:
+ /* Not coming to this place */
+ ASSERT (0,"Reached unreachable location");
+ }
+
+ RETURN ("%d",res);
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/ms.h b/tcllib/modules/pt/rde_critcl/ms.h
new file mode 100644
index 0000000..362334d
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/ms.h
@@ -0,0 +1,20 @@
+/* pt::rde::critcl - critcl - layer 2 declarations
+ * Support for param methods.
+ */
+
+#ifndef _MS_H
+#define _MS_H 1
+
+#include "tcl.h"
+
+int paramms_objcmd (ClientData cd, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv);
+
+#endif /* _MS_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/ot.c b/tcllib/modules/pt/rde_critcl/ot.c
new file mode 100644
index 0000000..3b99b04
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/ot.c
@@ -0,0 +1,236 @@
+/*
+ * = = == === ===== ======== ============= =====================
+ * == pt::rde (critcl) - Data Structures - Tcl_ObjType for interned strings.
+ *
+ */
+
+#include <ot.h> /* Our public API */
+#include <util.h> /* Allocation macros */
+#include <pInt.h> /* API to basic intern(ing) of strings */
+#include <string.h>
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+static void ot_free_rep (Tcl_Obj* obj);
+static void ot_dup_rep (Tcl_Obj* obj, Tcl_Obj* dup);
+static void ot_string_rep (Tcl_Obj* obj);
+static int ot_from_any (Tcl_Interp* ip, Tcl_Obj* obj);
+
+static Tcl_ObjType ot_type = {
+ "tcllib/pt::rde/critcl",
+ ot_free_rep,
+ ot_dup_rep,
+ ot_string_rep,
+ ot_from_any
+};
+
+static int IsCached (RDE_STATE p, Tcl_Obj* obj, long int* id);
+static long int Make (RDE_STATE p, Tcl_Obj* obj, const char* str);
+
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+long int
+rde_ot_intern0 (RDE_STATE p,
+ Tcl_Obj* detail)
+{
+ long int id;
+
+ TRACE (("rde_ot_intern0 (%p, %p = '%s')", p, detail, Tcl_GetString(detail)));
+ if (IsCached (p, detail, &id)) {
+ return id;
+ }
+
+ TRACE (("INTERNALIZE"));
+ return Make (p, detail, Tcl_GetString (detail));
+}
+
+long int
+rde_ot_intern1 (RDE_STATE p,
+ const char* operator,
+ Tcl_Obj* detail)
+{
+ long int id;
+ Tcl_DString buf;
+
+ TRACE (("rde_ot_intern1 (%p, '%s' %p = '%s')", p, operator, detail, Tcl_GetString(detail)));
+ if (IsCached (p, detail, &id)) {
+ return id;
+ }
+
+ TRACE (("INTERNALIZE"));
+
+ /* Create a list of operator + detail.
+ * Using a DString.
+ */
+
+ Tcl_DStringInit (&buf);
+ Tcl_DStringAppendElement (&buf, operator);
+ Tcl_DStringAppendElement (&buf, Tcl_GetString (detail));
+
+ id = Make (p, detail, Tcl_DStringValue (&buf));
+
+ Tcl_DStringFree (&buf);
+ return id;
+}
+
+long int
+rde_ot_intern2 (RDE_STATE p,
+ const char* operator,
+ Tcl_Obj* detail1,
+ Tcl_Obj* detail2)
+{
+ long int id;
+ Tcl_DString buf;
+
+ TRACE (("rde_ot_intern2 (%p, '%s' %p = '%s', %p = '%s')", p, operator,
+ detail1, Tcl_GetString(detail1)
+ detail2, Tcl_GetString(detail2)));
+ if (IsCached (p, detail1, &id)) {
+ return id;
+ }
+
+ TRACE (("INTERNALIZE"));
+
+ /* Create a list of operator + detail1 + detail2.
+ * Using a DString.
+ */
+
+ Tcl_DStringInit (&buf);
+ Tcl_DStringAppendElement (&buf, operator);
+ Tcl_DStringAppendElement (&buf, Tcl_GetString (detail1));
+ Tcl_DStringAppendElement (&buf, Tcl_GetString (detail2));
+
+ id = Make (p, detail1, Tcl_DStringValue (&buf));
+
+ Tcl_DStringFree (&buf);
+ return id;
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+static int
+IsCached (RDE_STATE p, Tcl_Obj* obj, long int* id)
+{
+ /*
+ * Quick exit if we have a cached and valid value.
+ */
+
+ if ((obj->typePtr == &ot_type) &&
+ (obj->internalRep.twoPtrValue.ptr1 == p)) {
+ RDE_STRING* rs = (RDE_STRING*) obj->internalRep.twoPtrValue.ptr2;
+ TRACE (("CACHED %p = %d", rs, rs->id));
+ *id = rs->id;
+ return 1;
+ }
+
+ return 0;
+}
+
+static long int
+Make (RDE_STATE p, Tcl_Obj* obj, const char* str)
+{
+ long int id = param_intern (p, str);
+ RDE_STRING* rs = ALLOC (RDE_STRING);
+
+ rs->next = p->sfirst;
+ rs->self = obj;
+ rs->id = id;
+ p->sfirst = rs;
+
+ /* Invalidate previous int.rep before setting our own.
+ * Inlined copy of TclFreeIntRep() macro (tclInt.h)
+ */
+
+ if ((obj)->typePtr &&
+ (obj)->typePtr->freeIntRepProc) {
+ (obj)->typePtr->freeIntRepProc(obj);
+ }
+
+ obj->internalRep.twoPtrValue.ptr1 = p;
+ obj->internalRep.twoPtrValue.ptr2 = rs;
+ obj->typePtr = &ot_type;
+
+ return id;
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+static void
+ot_free_rep(Tcl_Obj* obj)
+{
+ RDE_STATE p = (RDE_STATE) obj->internalRep.twoPtrValue.ptr1;
+ RDE_STRING* rs = (RDE_STRING*) obj->internalRep.twoPtrValue.ptr2;
+
+ /* Take structure out of the tracking list. */
+ if (p->sfirst == rs) {
+ p->sfirst = rs->next;
+ } else {
+ RDE_STRING* iter = p->sfirst;
+ while (iter->next != rs) {
+ iter = iter->next;
+ }
+ iter->next = rs->next;
+ }
+
+ /* Drop the now un-tracked structure */
+ ckfree ((char*) rs);
+
+ /* Nothing to release in the obj itself, just resetting references. */
+ obj->internalRep.twoPtrValue.ptr1 = NULL;
+ obj->internalRep.twoPtrValue.ptr2 = NULL;
+}
+
+static void
+ot_dup_rep(Tcl_Obj* obj, Tcl_Obj* dup)
+{
+ RDE_STRING* ors = (RDE_STRING*) obj->internalRep.twoPtrValue.ptr2;
+ RDE_STRING* drs;
+ RDE_STATE p = ((RDE_STATE) obj->internalRep.twoPtrValue.ptr1);
+
+ drs = ALLOC (RDE_STRING);
+ drs->next = p->sfirst;
+ drs->self = dup;
+ drs->id = ors->id;
+ p->sfirst = drs;
+
+ dup->internalRep.twoPtrValue.ptr1 = obj->internalRep.twoPtrValue.ptr1;
+ dup->internalRep.twoPtrValue.ptr2 = drs;
+ dup->typePtr = &ot_type;
+}
+
+static void
+ot_string_rep(Tcl_Obj* obj)
+{
+ (void) obj;
+ ASSERT (0, "Attempted reconversion of rde string to string rep");
+}
+
+static int
+ot_from_any(Tcl_Interp* ip, Tcl_Obj* obj)
+{
+ (void) ip;
+ (void) obj;
+ ASSERT (0, "Illegal conversion into rde string");
+ return TCL_ERROR;
+}
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/ot.h b/tcllib/modules/pt/rde_critcl/ot.h
new file mode 100644
index 0000000..086b2b2
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/ot.h
@@ -0,0 +1,32 @@
+/*
+ * = = == === ===== ======== ============= =====================
+ * == pt::rde (critcl) - Data Structures - ObjType for interned strings.
+ */
+
+#ifndef _RDE_DS_OT_H
+#define _RDE_DS_OT_H 1
+
+#include "tcl.h"
+#include <p.h> /* State declarations */
+
+long int rde_ot_intern0 (RDE_STATE p,
+ Tcl_Obj* detail);
+
+long int rde_ot_intern1 (RDE_STATE p,
+ const char* operator,
+ Tcl_Obj* detail);
+
+long int rde_ot_intern2 (RDE_STATE p,
+ const char* operator,
+ Tcl_Obj* detail1,
+ Tcl_Obj* detail2);
+
+#endif /* _RDE_DS_OT_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/p.c b/tcllib/modules/pt/rde_critcl/p.c
new file mode 100644
index 0000000..ac41446
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/p.c
@@ -0,0 +1,183 @@
+/* pt::rde::critcl - critcl - layer 1 definitions
+ * (c) PARAM functions
+ */
+
+#include <pInt.h> /* Our public and internal APIs */
+#include <util.h> /* Allocation macros */
+#include <string.h>
+
+/* .................................................. */
+
+static char*
+dup_string (const char* str);
+
+/* .................................................. */
+
+RDE_STATE
+param_new (void)
+{
+ RDE_STATE p;
+
+ ENTER ("param_new");
+
+ p = ALLOC (RDE_STATE_);
+#ifdef RDE_TRACE
+ p->icount = 0;
+#endif
+ p->c = NULL;
+
+ p->maxnum = 0;
+ p->numstr = 0;
+ p->string = NULL;
+ p->sfirst = NULL;
+ Tcl_InitHashTable (&p->str, TCL_STRING_KEYS);
+
+ p->p = rde_param_new (p->numstr, p->string);
+
+ /*
+ * Fixed elements of the string table, as needed by the lower level PARAM
+ * functions (class tests, see param.c, enum test_class).
+ * Further pt_peg_to_cparam.tcl, [::pt::peg::to::cparam::convert]
+ * ** Keep in sync **
+ *
+ * Maybe move the interning into the lower level, i.e. PARAM ?
+ */
+
+ param_intern (p, "alnum");
+ param_intern (p, "alpha");
+ param_intern (p, "ascii");
+ param_intern (p, "control");
+ param_intern (p, "ddigit");
+ param_intern (p, "digit");
+ param_intern (p, "graph");
+ param_intern (p, "lower");
+ param_intern (p, "print");
+ param_intern (p, "punct");
+ param_intern (p, "space");
+ param_intern (p, "upper");
+ param_intern (p, "wordchar");
+ param_intern (p, "xdigit");
+
+ RETURN ("%p",p);
+}
+
+void
+param_delete (RDE_STATE p)
+{
+ RDE_STRING* next;
+
+ ENTER ("param_delete");
+ TRACE (("RDE_STATE %p",p));
+
+ while (p->numstr) {
+ p->numstr --;
+ ASSERT_BOUNDS(p->numstr,p->maxnum);
+ ckfree (p->string [p->numstr]);
+ }
+
+ Tcl_DeleteHashTable (&p->str);
+
+ /* Process the list of Tcl_Obj* which have references to interned strings.
+ * We have to invalidate & release their intreps, and detach them from
+ * this state.
+ */
+ while (p->sfirst) {
+ next = p->sfirst->next;
+
+ TRACE (("del intern %p having %p '%s'", p, p->sfirst->self, Tcl_GetString(p->sfirst->self)));
+
+ p->sfirst->self->internalRep.twoPtrValue.ptr1 = NULL;
+ p->sfirst->self->internalRep.twoPtrValue.ptr2 = NULL;
+ p->sfirst->self->typePtr = NULL;
+
+ ckfree ((char*) p->sfirst);
+ p->sfirst = next;
+ }
+
+ rde_param_del (p->p);
+ ckfree ((char*) p);
+
+ RETURNVOID;
+}
+
+void
+param_setcmd (RDE_STATE p, Tcl_Command c)
+{
+ ENTER ("param_setcmd");
+ TRACE (("RDE_STATE %p",p));
+ TRACE (("Tcl_Command %p",c));
+
+ p->c = c;
+
+ RETURNVOID;
+}
+
+long int
+param_intern (RDE_STATE p, const char* literal)
+{
+ long int res;
+ int isnew;
+ Tcl_HashEntry* hPtr;
+
+ ENTER ("param_intern");
+ TRACE (("RDE_STATE %p",p));
+ TRACE (("CHAR* '%s'",literal));
+
+ hPtr = Tcl_FindHashEntry (&p->str, literal);
+ if (hPtr) {
+ res = (long int) Tcl_GetHashValue (hPtr);
+ RETURN("CACHED %d",res);
+ }
+
+ hPtr = Tcl_CreateHashEntry(&p->str, literal, &isnew);
+ ASSERT (isnew, "Should have found entry");
+
+ Tcl_SetHashValue (hPtr, p->numstr);
+
+ if (p->numstr >= p->maxnum) {
+ long int new;
+ char** str;
+
+ new = 2 * (p->maxnum ? p->maxnum : 8);
+ TRACE (("extend to %d strings",new));
+
+ str = (char**) ckrealloc ((char*) p->string, new * sizeof(char*));
+ ASSERT (str,"Memory allocation failure for string table");
+ p->maxnum = new;
+ p->string = str;
+ }
+
+ res = p->numstr;
+
+ ASSERT_BOUNDS(res,p->maxnum);
+ p->string [res] = dup_string (literal);
+ p->numstr ++;
+
+ TRACE (("UPDATE ENGINE"));
+ rde_param_update_strings (p->p, p->numstr, p->string);
+
+ RETURN("NEW %d",res);
+}
+/* .................................................. */
+
+static char*
+dup_string (const char* str)
+{
+ int n = strlen(str);
+ char* s = NALLOC(n+1,char);
+
+ memcpy (s, str, n);
+ s[n] = '\0';
+
+ return s;
+}
+
+/* .................................................. */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/p.h b/tcllib/modules/pt/rde_critcl/p.h
new file mode 100644
index 0000000..cb11529
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/p.h
@@ -0,0 +1,24 @@
+/* pt::rde::critcl - critcl - layer 1 declarations
+ * (c) PARAM functions
+ */
+
+#ifndef _P_H
+#define _P_H 1
+
+#include "tcl.h"
+
+typedef struct RDE_STATE_* RDE_STATE;
+
+RDE_STATE param_new (void);
+void param_delete (RDE_STATE p);
+void param_setcmd (RDE_STATE p, Tcl_Command c);
+
+#endif /* _P_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/pInt.h b/tcllib/modules/pt/rde_critcl/pInt.h
new file mode 100644
index 0000000..993d983
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/pInt.h
@@ -0,0 +1,50 @@
+/* pt::rde::critcl - critcl - layer 1 declarations
+ * (c) PARAM functions
+ */
+
+#ifndef _P_INT_H
+#define _P_INT_H 1
+
+#include <p.h> /* Public decls */
+#include <param.h> /* PARAM architectural state */
+#include <util.h> /* Tracing support */
+
+typedef struct RDE_STRING {
+ struct RDE_STRING* next;
+ Tcl_Obj* self;
+ int id;
+} RDE_STRING;
+
+typedef struct RDE_STATE_ {
+ RDE_PARAM p;
+ Tcl_Command c;
+
+ struct RDE_STRING* sfirst;
+
+ Tcl_HashTable str; /* Table to intern strings, i.e. convert them into
+ * unique numerical indices for the PARAM instructions.
+ */
+
+ /* And the counter mapping from ids to strings, this is handed to the
+ * PARAM for use.
+ */
+ long int maxnum; /* NOTE -- */
+ long int numstr; /* This is, essentially, an RDE_STACK (char* elements) */
+ char** string; /* Convert over to that instead of replicating the code */
+
+#ifdef RDE_TRACE
+ int icount; /* Instruction counter, when tracing */
+#endif
+} RDE_STATE_;
+
+long int param_intern (RDE_STATE p, const char* literal);
+
+#endif /* _P_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/param.c b/tcllib/modules/pt/rde_critcl/param.c
new file mode 100644
index 0000000..314b3cb
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/param.c
@@ -0,0 +1,1789 @@
+/*
+ * = = == === ===== ======== ============= =====================
+ * == pt::rde (critcl) - Data Structures - PARAM architectural state.
+ */
+
+#include <param.h> /* Public and private APIs */
+#include <stack.h> /* Stack handling */
+#include <tc.h> /* Token cache handling */
+#include <util.h> /* Allocation utilities */
+#include <string.h>
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+typedef struct RDE_PARAM_ {
+
+ Tcl_Channel IN;
+ Tcl_Obj* readbuf;
+ char* CC; /* [TCL_UTF_MAX] */
+ long int CC_len;
+
+ RDE_TC TC;
+
+ long int CL;
+ RDE_STACK LS; /* long int :: locations */
+
+ ERROR_STATE* ER;
+ RDE_STACK ES; /* ERROR_STATE* :: errors */
+
+ long int ST;
+ Tcl_Obj* SV;
+
+ Tcl_HashTable NC;
+
+ /*
+ * AS/ARS are actually intertwined. ARS is the top of 'ast' below, with
+ * the markers on 'mark' showing where ARS ends and AS with older ARS
+ * begins.
+ */
+
+ RDE_STACK ast ; /* Tcl_Obj* :: ast (node) */
+ RDE_STACK mark ; /* long int :: markers */
+
+ /* Various non PARAM state needed, the only part. An array of all the
+ * strings needed by this state instance. The instruction implementations
+ * take indices into this array instead of the actual strings, where
+ * needed. This field is NOT owned by the state.
+ */
+
+ long int numstr; /* String table (error messages), and its size */
+ char** string;
+
+ /*
+ * A generic value for the higher layers to associate their own
+ * information with the parser's state.
+ */
+
+ ClientData clientData;
+
+} RDE_PARAM_;
+
+typedef int (*UniCharClass) (int);
+
+/* See also p.c, param_new(), table of param_intern() calls.
+ * ** Keep in sync **
+ */
+typedef enum test_class_id {
+ tc_alnum,
+ tc_alpha,
+ tc_ascii,
+ tc_control,
+ tc_ddigit,
+ tc_digit,
+ tc_graph,
+ tc_lower,
+ tc_printable,
+ tc_punct,
+ tc_space,
+ tc_upper,
+ tc_wordchar,
+ tc_xdigit
+} test_class_id;
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+static void ast_node_free (void* n);
+static void error_state_free (void* es);
+static void error_set (RDE_PARAM p, long int s);
+static void nc_clear (RDE_PARAM p);
+
+static int UniCharIsAscii (int character);
+static int UniCharIsHexDigit (int character);
+static int UniCharIsDecDigit (int character);
+
+static void test_class (RDE_PARAM p, UniCharClass class, test_class_id id);
+static int er_int_compare (const void* a, const void* b);
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+#define SV_INIT(p) \
+ p->SV = NULL; \
+ TRACE (("SV_INIT (%p => %p)", (p), (p)->SV))
+
+#define SV_SET(p,newsv) \
+ if (((p)->SV) != (newsv)) { \
+ TRACE (("SV_CLEAR/set (%p => %p)", (p), (p)->SV)); \
+ if ((p)->SV) { \
+ Tcl_DecrRefCount ((p)->SV); \
+ } \
+ (p)->SV = (newsv); \
+ TRACE (("SV_SET (%p => %p)", (p), (p)->SV)); \
+ if ((p)->SV) { \
+ Tcl_IncrRefCount ((p)->SV); \
+ } \
+ }
+
+#define SV_CLEAR(p) \
+ TRACE (("SV_CLEAR (%p => %p)", (p), (p)->SV)); \
+ if ((p)->SV) { \
+ Tcl_DecrRefCount ((p)->SV); \
+ } \
+ (p)->SV = NULL
+
+#define ER_INIT(p) \
+ p->ER = NULL; \
+ TRACE (("ER_INIT (%p => %p)", (p), (p)->ER))
+
+#define ER_CLEAR(p) \
+ error_state_free ((p)->ER); \
+ (p)->ER = NULL
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE RDE_PARAM
+rde_param_new (long int nstr, char** strings)
+{
+ RDE_PARAM p;
+
+ ENTER ("rde_param_new");
+ TRACE (("\tINT %d strings @ %p", nstr, strings));
+
+ p = ALLOC (RDE_PARAM_);
+ p->numstr = nstr;
+ p->string = strings;
+
+ p->readbuf = Tcl_NewObj ();
+ Tcl_IncrRefCount (p->readbuf);
+
+ TRACE (("\tTcl_Obj* readbuf %p used %d", p->readbuf,p->readbuf->refCount));
+
+ Tcl_InitHashTable (&p->NC, TCL_ONE_WORD_KEYS);
+
+ p->IN = NULL;
+ p->CL = -1;
+ p->ST = 0;
+
+ ER_INIT (p);
+ SV_INIT (p);
+
+ p->CC = NULL;
+ p->CC_len = 0;
+
+ p->TC = rde_tc_new ();
+ p->ES = rde_stack_new (error_state_free);
+ p->LS = rde_stack_new (NULL);
+ p->ast = rde_stack_new (ast_node_free);
+ p->mark = rde_stack_new (NULL);
+
+ RETURN ("%p", p);
+}
+
+SCOPE void
+rde_param_del (RDE_PARAM p)
+{
+ ENTER ("rde_param_del");
+ TRACE (("RDE_PARAM %p",p));
+
+ ER_CLEAR (p); TRACE (("\ter_clear"));
+ SV_CLEAR (p); TRACE (("\tsv_clear"));
+
+ nc_clear (p); TRACE (("\tnc_clear"));
+ Tcl_DeleteHashTable (&p->NC); TRACE (("\tnc hashtable delete"));
+
+ rde_tc_del (p->TC); TRACE (("\ttc clear"));
+ rde_stack_del (p->ES); TRACE (("\tes clear"));
+ rde_stack_del (p->LS); TRACE (("\tls clear"));
+ rde_stack_del (p->ast); TRACE (("\tast clear"));
+ rde_stack_del (p->mark); TRACE (("\tmark clear"));
+
+ TRACE (("\tTcl_Obj* readbuf %p used %d", p->readbuf,p->readbuf->refCount));
+
+ Tcl_DecrRefCount (p->readbuf);
+ ckfree ((char*) p);
+
+ RETURNVOID;
+}
+
+SCOPE void
+rde_param_reset (RDE_PARAM p, Tcl_Channel chan)
+{
+ ENTER ("rde_param_reset");
+ TRACE (("RDE_PARAM %p",p));
+ TRACE (("Tcl_Channel %p",chan));
+
+ p->IN = chan;
+ p->CL = -1;
+ p->ST = 0;
+
+ p->CC = NULL;
+ p->CC_len = 0;
+
+ ER_CLEAR (p);
+ SV_CLEAR (p);
+ nc_clear (p);
+
+ rde_tc_clear (p->TC);
+ rde_stack_trim (p->ES, 0);
+ rde_stack_trim (p->LS, 0);
+ rde_stack_trim (p->ast, 0);
+ rde_stack_trim (p->mark, 0);
+
+ TRACE (("\tTcl_Obj* readbuf %p used %d", p->readbuf,p->readbuf->refCount));
+
+ RETURNVOID;
+}
+
+SCOPE void
+rde_param_update_strings (RDE_PARAM p, long int nstr, char** strings)
+{
+ ENTER ("rde_param_update_strings");
+ TRACE (("RDE_PARAM %p", p));
+ TRACE (("INT %d strings", nstr));
+
+ p->numstr = nstr;
+ p->string = strings;
+
+ RETURNVOID;
+}
+
+SCOPE void
+rde_param_data (RDE_PARAM p, char* buf, long int len)
+{
+ (void) rde_tc_append (p->TC, buf, len);
+}
+
+SCOPE void
+rde_param_clientdata (RDE_PARAM p, ClientData clientData)
+{
+ p->clientData = clientData;
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+static void
+nc_clear (RDE_PARAM p)
+{
+ Tcl_HashSearch hs;
+ Tcl_HashEntry* he;
+ Tcl_HashTable* tablePtr;
+
+ for(he = Tcl_FirstHashEntry(&p->NC, &hs);
+ he != NULL;
+ he = Tcl_FirstHashEntry(&p->NC, &hs)) {
+
+ Tcl_HashSearch hsc;
+ Tcl_HashEntry* hec;
+
+ tablePtr = (Tcl_HashTable*) Tcl_GetHashValue (he);
+
+ for(hec = Tcl_FirstHashEntry(tablePtr, &hsc);
+ hec != NULL;
+ hec = Tcl_NextHashEntry(&hsc)) {
+
+ NC_STATE* scs = Tcl_GetHashValue (hec);
+ error_state_free (scs->ER);
+ if (scs->SV) { Tcl_DecrRefCount (scs->SV); }
+ ckfree ((char*) scs);
+ }
+
+ Tcl_DeleteHashTable (tablePtr);
+ ckfree ((char*) tablePtr);
+ Tcl_DeleteHashEntry (he);
+ }
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE ClientData
+rde_param_query_clientdata (RDE_PARAM p)
+{
+ return p->clientData;
+}
+
+SCOPE void
+rde_param_query_amark (RDE_PARAM p, long int* mc, void*** mv)
+{
+ rde_stack_get (p->mark, mc, mv);
+}
+
+SCOPE void
+rde_param_query_ast (RDE_PARAM p, long int* ac, Tcl_Obj*** av)
+{
+ rde_stack_get (p->ast, ac, (void***) av);
+}
+
+SCOPE const char*
+rde_param_query_in (RDE_PARAM p)
+{
+ return p->IN
+ ? Tcl_GetChannelName (p->IN)
+ : "";
+}
+
+SCOPE const char*
+rde_param_query_cc (RDE_PARAM p, long int* len)
+{
+ *len = p->CC_len;
+ return p->CC;
+}
+
+SCOPE int
+rde_param_query_cl (RDE_PARAM p)
+{
+ return p->CL;
+}
+
+SCOPE const ERROR_STATE*
+rde_param_query_er (RDE_PARAM p)
+{
+ return p->ER;
+}
+
+SCOPE Tcl_Obj*
+rde_param_query_er_tcl (RDE_PARAM p, const ERROR_STATE* er)
+{
+ Tcl_Obj* res;
+
+ if (!er) {
+ /*
+ * Consider keeping one of these around in the main object state, for
+ * quick return.
+ */
+ res = Tcl_NewStringObj ("", 0);
+ } else {
+ Tcl_Obj* ov [2];
+ Tcl_Obj** mov;
+ long int mc, i, j;
+ void** mv;
+ int lastid;
+ const char* msg;
+
+ rde_stack_get (er->msg, &mc, &mv);
+
+ /*
+ * Note: We are peeking inside the (message) stack here and are
+ * modifying it in place. This doesn't matter, we are using the stack
+ * code for convenience, not for the ordering.
+ */
+
+ qsort (mv, mc, sizeof (void*), er_int_compare);
+
+ /*
+ * Convert message ids to strings. We ignore duplicates, by comparing
+ * to the last processed id. Here the sorting (see above) comes into
+ * play, we know that duplicates are bunched together in runs, making
+ * it easy to drop them.
+ */
+
+ mov = NALLOC (mc, Tcl_Obj*);
+ lastid = -1;
+ for (i=0, j=0; i < mc; i++) {
+ ASSERT_BOUNDS (i,mc);
+
+ if (((long int) mv [i]) == lastid) continue;
+ lastid = (long int) mv [i];
+
+ ASSERT_BOUNDS((long int) mv[i],p->numstr);
+ msg = p->string [(long int) mv[i]]; /* inlined query_string */
+
+ ASSERT_BOUNDS (j,mc);
+ mov [j] = Tcl_NewStringObj (msg, -1);
+ j++;
+ }
+
+ /*
+ * Assemble the result.
+ */
+
+ ov [0] = Tcl_NewIntObj (er->loc);
+ ov [1] = Tcl_NewListObj (j, mov);
+
+ res = Tcl_NewListObj (2, ov);
+
+ ckfree ((char*) mov);
+ }
+
+ return res;
+}
+
+SCOPE void
+rde_param_query_es (RDE_PARAM p, long int* ec, ERROR_STATE*** ev)
+{
+ rde_stack_get (p->ES, ec, (void***) ev);
+}
+
+SCOPE void
+rde_param_query_ls (RDE_PARAM p, long int* lc, void*** lv)
+{
+ rde_stack_get (p->LS, lc, lv);
+}
+
+SCOPE long int
+rde_param_query_lstop (RDE_PARAM p)
+{
+ return (long int) rde_stack_top (p->LS);
+}
+
+SCOPE Tcl_HashTable*
+rde_param_query_nc (RDE_PARAM p)
+{
+ return &p->NC;
+}
+
+SCOPE int
+rde_param_query_st (RDE_PARAM p)
+{
+ return p->ST;
+}
+
+SCOPE Tcl_Obj*
+rde_param_query_sv (RDE_PARAM p)
+{
+ TRACE (("SV_QUERY %p => (%p)", (p), (p)->SV)); \
+ return p->SV;
+}
+
+SCOPE long int
+rde_param_query_tc_size (RDE_PARAM p)
+{
+ return rde_tc_size (p->TC);
+}
+
+SCOPE void
+rde_param_query_tc_get_s (RDE_PARAM p, long int at, long int last, char** ch, long int* len)
+{
+ rde_tc_get_s (p->TC, at, last, ch, len);
+}
+
+SCOPE const char*
+rde_param_query_string (RDE_PARAM p, long int id)
+{
+ TRACE (("rde_param_query_string (RDE_PARAM %p, %d/%d)", p, id, p->numstr));
+
+ ASSERT_BOUNDS(id,p->numstr);
+
+ return p->string [id];
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE void
+rde_param_i_ast_pop_discard (RDE_PARAM p)
+{
+ rde_stack_pop (p->mark, 1);
+}
+
+SCOPE void
+rde_param_i_ast_pop_rewind (RDE_PARAM p)
+{
+ long int trim = (long int) rde_stack_top (p->mark);
+
+ ENTER ("rde_param_i_ast_pop_rewind");
+ TRACE (("RDE_PARAM %p",p));
+
+ rde_stack_pop (p->mark, 1);
+ rde_stack_trim (p->ast, trim);
+
+ TRACE (("SV = (%p rc%d '%s')",
+ p->SV,
+ p->SV ? p->SV->refCount : -1,
+ p->SV ? Tcl_GetString (p->SV) : ""));
+ RETURNVOID;
+}
+
+SCOPE void
+rde_param_i_ast_rewind (RDE_PARAM p)
+{
+ long int trim = (long int) rde_stack_top (p->mark);
+
+ ENTER ("rde_param_i_ast_rewind");
+ TRACE (("RDE_PARAM %p",p));
+
+ rde_stack_trim (p->ast, trim);
+
+ TRACE (("SV = (%p rc%d '%s')",
+ p->SV,
+ p->SV ? p->SV->refCount : -1,
+ p->SV ? Tcl_GetString (p->SV) : ""));
+ RETURNVOID;
+}
+
+SCOPE void
+rde_param_i_ast_push (RDE_PARAM p)
+{
+ rde_stack_push (p->mark, (void*) rde_stack_size (p->ast));
+}
+
+SCOPE void
+rde_param_i_ast_value_push (RDE_PARAM p)
+{
+ ENTER ("rde_param_i_ast_value_push");
+ TRACE (("RDE_PARAM %p",p));
+
+ ASSERT(p->SV,"Unable to push undefined semantic value");
+ TRACE (("rde_param_i_ast_value_push %p => (%p)", p, p->SV));
+ TRACE (("SV = (%p rc%d '%s')", p->SV, p->SV->refCount, Tcl_GetString (p->SV)));
+
+ rde_stack_push (p->ast, p->SV);
+ Tcl_IncrRefCount (p->SV);
+
+ RETURNVOID;
+}
+
+static void
+ast_node_free (void* n)
+{
+ Tcl_DecrRefCount ((Tcl_Obj*) n);
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE void
+rde_param_i_error_clear (RDE_PARAM p)
+{
+ ER_CLEAR (p);
+}
+
+SCOPE void
+rde_param_i_error_nonterminal (RDE_PARAM p, long int s)
+{
+ /*
+ * Disabled. Generate only low-level errors until we have worked out how
+ * to integrate symbol information with them. Do not forget where this
+ * instruction is inlined - No such exist, places using the instruction
+ * directly call on this function.
+ */
+ return;
+#if 0
+ long int pos;
+ if (!p->ER) return;
+ pos = 1 + (long int) rde_stack_top (p->LS);
+ if (p->ER->loc != pos) return;
+ error_set (p, s);
+ p->ER->loc = pos;
+#endif
+}
+
+SCOPE void
+rde_param_i_error_pop_merge (RDE_PARAM p)
+{
+ ERROR_STATE* top = (ERROR_STATE*) rde_stack_top (p->ES);
+
+ /*
+ * The states are identical. Nothing has to be done in that case.
+ */
+
+ if (top == p->ER) {
+ rde_stack_pop (p->ES, 1);
+ return;
+ }
+
+ /*
+ * Saved state is nothing, keep current, discard top.
+ * No refCount to change.
+ */
+
+ if (!top) {
+ rde_stack_pop (p->ES, 1);
+ return;
+ }
+
+ /*
+ * Current state is nothing, keep top, dicard current. We 'drop' as we are
+ * taking ownership of the error state in 'top' back from the stack.
+ */
+
+ if (!p->ER) {
+ rde_stack_drop (p->ES, 1);
+ p->ER = top;
+
+ /*
+ * Note: The refCount of top is left unchanged. The reference lost
+ * through the drop is taken over by ER.
+ */
+ return;
+ }
+
+ /*
+ * Both top and current have data. Compare their locations to determine
+ * which to keep, or discard, respectively.
+ *
+ * The current state is farther ahead in the input, keep it, and discard
+ * the saved information.
+ */
+
+ if (top->loc < p->ER->loc) {
+ rde_stack_pop (p->ES, 1);
+ return;
+ }
+
+ /*
+ * The saved state is farther ahead than the current one, keep it, discard
+ * current. We 'drop' as we are taking ownership of the error state in
+ * 'top' back from the stack.
+ */
+
+ if (top->loc > p->ER->loc) {
+ rde_stack_drop (p->ES, 1);
+ error_state_free (p->ER);
+ p->ER = top;
+
+ /*
+ * Note: The refCount of top is left unchanged. The reference lost
+ * through the drop is taken over by ER.
+ */
+ return;
+ }
+
+ /*
+ * Both states describe the same location. We merge the message sets. We
+ * do not make the set unique however. This can be defered until the data
+ * is actually retrieved by the user of the PARAM.
+ */
+
+ rde_stack_move (p->ER->msg, top->msg);
+ rde_stack_pop (p->ES, 1);
+}
+
+SCOPE void
+rde_param_i_error_push (RDE_PARAM p)
+{
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+}
+
+static void
+error_set (RDE_PARAM p, long int s)
+{
+ error_state_free (p->ER);
+
+ p->ER = ALLOC (ERROR_STATE);
+ p->ER->refCount = 1;
+ p->ER->loc = p->CL;
+ p->ER->msg = rde_stack_new (NULL);
+
+ ASSERT_BOUNDS(s,p->numstr);
+
+ rde_stack_push (p->ER->msg, (void*) s);
+}
+
+static void
+error_state_free (void* esx)
+{
+ ERROR_STATE* es = esx;
+
+ if (!es) return;
+
+ es->refCount --;
+ if (es->refCount > 0) return;
+
+ rde_stack_del (es->msg);
+ ckfree ((char*) es);
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE void
+rde_param_i_loc_pop_discard (RDE_PARAM p)
+{
+ rde_stack_pop (p->LS, 1);
+}
+
+SCOPE void
+rde_param_i_loc_pop_rewind (RDE_PARAM p)
+{
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_pop (p->LS, 1);
+}
+
+SCOPE void
+rde_param_i_loc_push (RDE_PARAM p)
+{
+ rde_stack_push (p->LS, (void*) p->CL);
+}
+
+SCOPE void
+rde_param_i_loc_rewind (RDE_PARAM p)
+{
+ p->CL = (long int) rde_stack_top (p->LS);
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE void
+rde_param_i_input_next (RDE_PARAM p, long int m)
+{
+ int leni;
+ char* ch;
+
+ ASSERT_BOUNDS(m,p->numstr);
+
+ p->CL ++;
+
+ if (p->CL < rde_tc_size (p->TC)) {
+ /*
+ * We are at a known position, we can and do take the associated
+ * character out of the token cache.
+ *
+ * FUTURE :: keep track of what location the data stored in CC is
+ * for. If the location is identical no extraction is required. This
+ * may help when a choice repeatedly tests the same character.
+ */
+
+ rde_tc_get (p->TC, p->CL, &p->CC, &p->CC_len);
+ /* Note: BOUNDS(n) <=> [0..(n-1)].
+ * cc_len in [1..utfmax] <=> cc_len-1 in [0...utfmax-1] <=> BOUNDS(utfmax)
+ */
+ ASSERT_BOUNDS (p->CC_len-1, TCL_UTF_MAX);
+
+ p->ST = 1;
+ ER_CLEAR (p);
+ return;
+ }
+
+ if (!p->IN ||
+ Tcl_Eof (p->IN) ||
+ (Tcl_ReadChars (p->IN, p->readbuf, 1, 0) <= 0)) {
+ /*
+ * As we are outside of the known range we tried to read a character
+ * from the input, to extend the token cache with. That failed.
+ */
+
+ p->ST = 0;
+ error_set (p, m);
+ return;
+ }
+
+ /*
+ * We got a new character, we now extend the token cache, and also make it
+ * current.
+ */
+
+ ch = Tcl_GetStringFromObj (p->readbuf, &leni);
+ ASSERT_BOUNDS (leni, TCL_UTF_MAX);
+
+ p->CC = rde_tc_append (p->TC, ch, leni);
+ p->CC_len = leni;
+
+ p->ST = 1;
+ ER_CLEAR (p);
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE void
+rde_param_i_status_fail (RDE_PARAM p)
+{
+ p->ST = 0;
+}
+
+SCOPE void
+rde_param_i_status_ok (RDE_PARAM p)
+{
+ p->ST = 1;
+}
+
+SCOPE void
+rde_param_i_status_negate (RDE_PARAM p)
+{
+ p->ST = !p->ST;
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE int
+rde_param_i_symbol_restore (RDE_PARAM p, long int s)
+{
+ NC_STATE* scs;
+ Tcl_HashEntry* hPtr;
+ Tcl_HashTable* tablePtr;
+
+ /*
+ * 2-level hash table keyed by location, and symbol ...
+ */
+
+ hPtr = Tcl_FindHashEntry (&p->NC, (char*) p->CL);
+ if (!hPtr) { return 0; }
+
+ tablePtr = (Tcl_HashTable*) Tcl_GetHashValue (hPtr);
+ hPtr = Tcl_FindHashEntry (tablePtr, (char*) s);
+ if (!hPtr) { return 0; }
+
+ /*
+ * Found information, apply it to the state, restoring the cached
+ * situation.
+ */
+
+ scs = Tcl_GetHashValue (hPtr);
+
+ p->CL = scs->CL;
+ p->ST = scs->ST;
+
+ error_state_free (p->ER);
+ p->ER = scs->ER;
+ if (p->ER) { p->ER->refCount ++; }
+
+ TRACE (("SV_RESTORE (%p) '%s'",scs->SV, scs->SV ? Tcl_GetString (scs->SV):""));
+
+ SV_SET (p, scs->SV);
+
+ return 1;
+}
+
+SCOPE void
+rde_param_i_symbol_save (RDE_PARAM p, long int s)
+{
+ long int at = (long int) rde_stack_top (p->LS);
+ NC_STATE* scs;
+ Tcl_HashEntry* hPtr;
+ Tcl_HashTable* tablePtr;
+ int isnew;
+
+ ENTER ("rde_param_i_symbol_save");
+ TRACE (("RDE_PARAM %p",p));
+ TRACE (("INT %d",s));
+
+ /*
+ * 2-level hash table keyed by location, and symbol ...
+ */
+
+ hPtr = Tcl_CreateHashEntry (&p->NC, (char*) at, &isnew);
+
+ if (isnew) {
+ tablePtr = ALLOC (Tcl_HashTable);
+ Tcl_InitHashTable (tablePtr, TCL_ONE_WORD_KEYS);
+ Tcl_SetHashValue (hPtr, tablePtr);
+ } else {
+ tablePtr = (Tcl_HashTable*) Tcl_GetHashValue (hPtr);
+ }
+
+ hPtr = Tcl_CreateHashEntry (tablePtr, (char*) s, &isnew);
+
+ if (isnew) {
+ /*
+ * Copy state into new cache entry.
+ */
+
+ scs = ALLOC (NC_STATE);
+ scs->CL = p->CL;
+ scs->ST = p->ST;
+
+ TRACE (("SV_CACHE (%p '%s')", p->SV, p->SV ? Tcl_GetString(p->SV) : ""));
+
+ scs->SV = p->SV;
+ if (scs->SV) { Tcl_IncrRefCount (scs->SV); }
+
+ scs->ER = p->ER;
+ if (scs->ER) { scs->ER->refCount ++; }
+
+ Tcl_SetHashValue (hPtr, scs);
+ } else {
+ /*
+ * Copy state into existing cache entry, overwriting the previous
+ * information.
+ */
+
+ scs = (NC_STATE*) Tcl_GetHashValue (hPtr);
+
+ scs->CL = p->CL;
+ scs->ST = p->ST;
+
+ TRACE (("SV_CACHE/over (%p '%s')", p->SV, p->SV ? Tcl_GetString(p->SV) : "" ));
+
+ if (scs->SV) { Tcl_DecrRefCount (scs->SV); }
+ scs->SV = p->SV;
+ if (scs->SV) { Tcl_IncrRefCount (scs->SV); }
+
+ error_state_free (scs->ER);
+ scs->ER = p->ER;
+ if (scs->ER) { scs->ER->refCount ++; }
+ }
+
+ TRACE (("SV = (%p rc%d '%s')",
+ p->SV,
+ p->SV ? p->SV->refCount : -1,
+ p->SV ? Tcl_GetString (p->SV) : ""));
+ RETURNVOID;
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE void
+rde_param_i_test_alnum (RDE_PARAM p)
+{
+ test_class (p, Tcl_UniCharIsAlnum, tc_alnum);
+}
+
+SCOPE void
+rde_param_i_test_alpha (RDE_PARAM p)
+{
+ test_class (p, Tcl_UniCharIsAlpha, tc_alpha);
+}
+
+SCOPE void
+rde_param_i_test_ascii (RDE_PARAM p)
+{
+ test_class (p, UniCharIsAscii, tc_ascii);
+}
+
+SCOPE void
+rde_param_i_test_control (RDE_PARAM p)
+{
+ test_class (p, Tcl_UniCharIsControl, tc_control);
+}
+
+SCOPE void
+rde_param_i_test_char (RDE_PARAM p, const char* c, long int msg)
+{
+ ASSERT_BOUNDS(msg,p->numstr);
+
+ p->ST = Tcl_UtfNcmp (p->CC, c, 1) == 0;
+
+ if (p->ST) {
+ ER_CLEAR (p);
+ } else {
+ error_set (p, msg);
+ p->CL --;
+ }
+}
+
+SCOPE void
+rde_param_i_test_ddigit (RDE_PARAM p)
+{
+ test_class (p, UniCharIsDecDigit, tc_ddigit);
+}
+
+SCOPE void
+rde_param_i_test_digit (RDE_PARAM p)
+{
+ test_class (p, Tcl_UniCharIsDigit, tc_digit);
+}
+
+SCOPE void
+rde_param_i_test_graph (RDE_PARAM p)
+{
+ test_class (p, Tcl_UniCharIsGraph, tc_graph);
+}
+
+SCOPE void
+rde_param_i_test_lower (RDE_PARAM p)
+{
+ test_class (p, Tcl_UniCharIsLower, tc_lower);
+}
+
+SCOPE void
+rde_param_i_test_print (RDE_PARAM p)
+{
+ test_class (p, Tcl_UniCharIsPrint, tc_printable);
+}
+
+SCOPE void
+rde_param_i_test_punct (RDE_PARAM p)
+{
+ test_class (p, Tcl_UniCharIsPunct, tc_punct);
+}
+
+SCOPE void
+rde_param_i_test_range (RDE_PARAM p, const char* s, const char* e, long int msg)
+{
+ ASSERT_BOUNDS(msg,p->numstr);
+
+ p->ST =
+ (Tcl_UtfNcmp (s, p->CC, 1) <= 0) &&
+ (Tcl_UtfNcmp (p->CC, e, 1) <= 0);
+
+ if (p->ST) {
+ ER_CLEAR (p);
+ } else {
+ error_set (p, msg);
+ p->CL --;
+ }
+}
+
+SCOPE void
+rde_param_i_test_space (RDE_PARAM p)
+{
+ test_class (p, Tcl_UniCharIsSpace, tc_space);
+}
+
+SCOPE void
+rde_param_i_test_upper (RDE_PARAM p)
+{
+ test_class (p, Tcl_UniCharIsUpper, tc_upper);
+}
+
+SCOPE void
+rde_param_i_test_wordchar (RDE_PARAM p)
+{
+ test_class (p, Tcl_UniCharIsWordChar, tc_wordchar);
+}
+
+SCOPE void
+rde_param_i_test_xdigit (RDE_PARAM p)
+{
+ test_class (p, UniCharIsHexDigit, tc_xdigit);
+}
+
+static void
+test_class (RDE_PARAM p, UniCharClass class, test_class_id id)
+{
+ Tcl_UniChar ch;
+ Tcl_UtfToUniChar(p->CC, &ch);
+
+ ASSERT_BOUNDS(id,p->numstr);
+
+ p->ST = !!class (ch);
+
+ /* The double-negation normalizes the output of the class function to the
+ * regular booleans 0 and 1.
+ */
+
+ if (p->ST) {
+ ER_CLEAR (p);
+ } else {
+ error_set (p, id);
+ p->CL --;
+ }
+}
+
+static int
+UniCharIsAscii (int character)
+{
+ return (character >= 0) && (character < 0x80);
+}
+
+static int
+UniCharIsHexDigit (int character)
+{
+ return (character >= 0) && (character < 0x80) && isxdigit(character);
+}
+
+static int
+UniCharIsDecDigit (int character)
+{
+ return (character >= 0) && (character < 0x80) && isdigit(character);
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE void
+rde_param_i_value_clear (RDE_PARAM p)
+{
+ SV_CLEAR (p);
+}
+
+SCOPE void
+rde_param_i_value_leaf (RDE_PARAM p, long int s)
+{
+ Tcl_Obj* newsv;
+ Tcl_Obj* ov [3];
+ long int pos = 1 + (long int) rde_stack_top (p->LS);
+
+ ASSERT_BOUNDS(s,p->numstr);
+
+ ov [0] = Tcl_NewStringObj (p->string[s], -1);
+ ov [1] = Tcl_NewIntObj (pos);
+ ov [2] = Tcl_NewIntObj (p->CL);
+
+ newsv = Tcl_NewListObj (3, ov);
+
+ TRACE (("rde_param_i_value_leaf => '%s'",Tcl_GetString (newsv)));
+
+ SV_SET (p, newsv);
+}
+
+SCOPE void
+rde_param_i_value_reduce (RDE_PARAM p, long int s)
+{
+ Tcl_Obj* newsv;
+ int i, j;
+ Tcl_Obj** ov;
+ long int ac;
+ Tcl_Obj** av;
+
+ long int pos = 1 + (long int) rde_stack_top (p->LS);
+ long int mark = (long int) rde_stack_top (p->mark);
+ long int asize = rde_stack_size (p->ast);
+ long int new = asize - mark;
+
+ ASSERT (new >= 0, "Bad number of elements to reduce");
+
+ ov = NALLOC (3+new, Tcl_Obj*);
+
+ ASSERT_BOUNDS(s,p->numstr);
+
+ ov [0] = Tcl_NewStringObj (p->string[s], -1);
+ ov [1] = Tcl_NewIntObj (pos);
+ ov [2] = Tcl_NewIntObj (p->CL);
+
+ rde_stack_get (p->ast, &ac, (void***) &av);
+ for (i = 3, j = mark; j < asize; i++, j++) {
+ ASSERT_BOUNDS (i, 3+new);
+ ASSERT_BOUNDS (j, ac);
+ ov [i] = av [j];
+ }
+
+ ASSERT (i == 3+new, "Reduction result incomplete");
+ newsv = Tcl_NewListObj (3+new, ov);
+
+ TRACE (("rde_param_i_value_reduce => '%s'",Tcl_GetString (newsv)));
+
+ SV_SET (p, newsv);
+ ckfree ((char*) ov);
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+static int
+er_int_compare (const void* a, const void* b)
+{
+ /* a, b = pointers to element, as void*.
+ * Actual element type is (void*), and
+ * actually stored data is (long int).
+ */
+
+ const void** ael = (const void**) a;
+ const void** bel = (const void**) b;
+
+ long int avalue = (long int) *ael;
+ long int bvalue = (long int) *bel;
+
+ if (avalue < bvalue) { return -1; }
+ if (avalue > bvalue) { return 1; }
+ return 0;
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ * == Super Instructions.
+ */
+
+SCOPE int
+rde_param_i_symbol_start (RDE_PARAM p, long int s)
+{
+ if (rde_param_i_symbol_restore (p, s)) {
+ if (p->ST) {
+ rde_stack_push (p->ast, p->SV);
+ Tcl_IncrRefCount (p->SV);
+ }
+ return 1;
+ }
+
+ rde_stack_push (p->LS, (void*) p->CL);
+ return 0;
+}
+
+SCOPE int
+rde_param_i_symbol_start_d (RDE_PARAM p, long int s)
+{
+ if (rde_param_i_symbol_restore (p, s)) {
+ if (p->ST) {
+ rde_stack_push (p->ast, p->SV);
+ Tcl_IncrRefCount (p->SV);
+ }
+ return 1;
+ }
+
+ rde_stack_push (p->LS, (void*) p->CL);
+ rde_stack_push (p->mark, (void*) rde_stack_size (p->ast));
+ return 0;
+}
+
+SCOPE int
+rde_param_i_symbol_void_start (RDE_PARAM p, long int s)
+{
+ if (rde_param_i_symbol_restore (p, s)) return 1;
+
+ rde_stack_push (p->LS, (void*) p->CL);
+ return 0;
+}
+
+SCOPE int
+rde_param_i_symbol_void_start_d (RDE_PARAM p, long int s)
+{
+ if (rde_param_i_symbol_restore (p, s)) return 1;
+
+ rde_stack_push (p->LS, (void*) p->CL);
+ rde_stack_push (p->mark, (void*) rde_stack_size (p->ast));
+ return 0;
+}
+
+SCOPE void
+rde_param_i_symbol_done_d_reduce (RDE_PARAM p, long int s, long int m)
+{
+ if (p->ST) {
+ rde_param_i_value_reduce (p, s);
+ } else {
+ SV_CLEAR (p);
+ }
+
+ rde_param_i_symbol_save (p, s);
+ rde_param_i_error_nonterminal (p, m);
+ rde_param_i_ast_pop_rewind (p);
+
+ rde_stack_pop (p->LS, 1);
+
+ if (p->ST) {
+ rde_stack_push (p->ast, p->SV);
+ Tcl_IncrRefCount (p->SV);
+ }
+}
+
+SCOPE void
+rde_param_i_symbol_done_leaf (RDE_PARAM p, long int s, long int m)
+{
+ if (p->ST) {
+ rde_param_i_value_leaf (p, s);
+ } else {
+ SV_CLEAR (p);
+ }
+
+ rde_param_i_symbol_save (p, s);
+ rde_param_i_error_nonterminal (p, m);
+
+ rde_stack_pop (p->LS, 1);
+
+ if (p->ST) {
+ rde_stack_push (p->ast, p->SV);
+ Tcl_IncrRefCount (p->SV);
+ }
+}
+
+SCOPE void
+rde_param_i_symbol_done_d_leaf (RDE_PARAM p, long int s, long int m)
+{
+ if (p->ST) {
+ rde_param_i_value_leaf (p, s);
+ } else {
+ SV_CLEAR (p);
+ }
+
+ rde_param_i_symbol_save (p, s);
+ rde_param_i_error_nonterminal (p, m);
+ rde_param_i_ast_pop_rewind (p);
+
+ rde_stack_pop (p->LS, 1);
+
+ if (p->ST) {
+ rde_stack_push (p->ast, p->SV);
+ Tcl_IncrRefCount (p->SV);
+ }
+}
+
+SCOPE void
+rde_param_i_symbol_done_void (RDE_PARAM p, long int s, long int m)
+{
+ SV_CLEAR (p);
+ rde_param_i_symbol_save (p, s);
+ rde_param_i_error_nonterminal (p, m);
+
+ rde_stack_pop (p->LS, 1);
+}
+
+SCOPE void
+rde_param_i_symbol_done_d_void (RDE_PARAM p, long int s, long int m)
+{
+ SV_CLEAR (p);
+ rde_param_i_symbol_save (p, s);
+ rde_param_i_error_nonterminal (p, m);
+ rde_param_i_ast_pop_rewind (p);
+
+ rde_stack_pop (p->LS, 1);
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE void
+rde_param_i_next_char (RDE_PARAM p, const char* c, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_char (p, c, m);
+}
+
+SCOPE void
+rde_param_i_next_range (RDE_PARAM p, const char* s, const char* e, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_range (p, s, e, m);
+}
+
+SCOPE void
+rde_param_i_next_alnum (RDE_PARAM p, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_alnum (p);
+}
+
+SCOPE void
+rde_param_i_next_alpha (RDE_PARAM p, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_alpha (p);
+}
+
+SCOPE void
+rde_param_i_next_ascii (RDE_PARAM p, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_ascii (p);
+}
+
+SCOPE void
+rde_param_i_next_control (RDE_PARAM p, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_control (p);
+}
+
+SCOPE void
+rde_param_i_next_ddigit (RDE_PARAM p, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_ddigit (p);
+}
+
+SCOPE void
+rde_param_i_next_digit (RDE_PARAM p, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_digit (p);
+}
+
+SCOPE void
+rde_param_i_next_graph (RDE_PARAM p, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_graph (p);
+}
+
+SCOPE void
+rde_param_i_next_lower (RDE_PARAM p, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_lower (p);
+}
+
+SCOPE void
+rde_param_i_next_print (RDE_PARAM p, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_print (p);
+}
+
+SCOPE void
+rde_param_i_next_punct (RDE_PARAM p, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_punct (p);
+}
+
+SCOPE void
+rde_param_i_next_space (RDE_PARAM p, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_space (p);
+}
+
+SCOPE void
+rde_param_i_next_upper (RDE_PARAM p, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_upper (p);
+}
+
+SCOPE void
+rde_param_i_next_wordchar (RDE_PARAM p, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_wordchar (p);
+}
+
+SCOPE void
+rde_param_i_next_xdigit (RDE_PARAM p, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+ rde_param_i_test_xdigit (p);
+}
+
+SCOPE void
+rde_param_i_notahead_start_d (RDE_PARAM p)
+{
+ rde_stack_push (p->LS, (void*) p->CL);
+ rde_stack_push (p->mark, (void*) rde_stack_size (p->ast));
+}
+
+SCOPE void
+rde_param_i_notahead_exit_d (RDE_PARAM p)
+{
+ if (p->ST) {
+ rde_param_i_ast_pop_rewind (p);
+ } else {
+ rde_stack_pop (p->mark, 1);
+ }
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_pop (p->LS, 1);
+ p->ST = !p->ST;
+}
+
+SCOPE void
+rde_param_i_notahead_exit (RDE_PARAM p)
+{
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_pop (p->LS, 1);
+ p->ST = !p->ST;
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE void
+rde_param_i_state_push_2 (RDE_PARAM p)
+{
+ /* loc_push + error_push */
+ rde_stack_push (p->LS, (void*) p->CL);
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+}
+
+SCOPE void
+rde_param_i_state_push_void (RDE_PARAM p)
+{
+ rde_stack_push (p->LS, (void*) p->CL);
+ ER_CLEAR (p);
+ rde_stack_push (p->ES, p->ER);
+ /* if (p->ER) { p->ER->refCount ++; } */
+}
+
+SCOPE void
+rde_param_i_state_push_value (RDE_PARAM p)
+{
+ rde_stack_push (p->mark, (void*) rde_stack_size (p->ast));
+ rde_stack_push (p->LS, (void*) p->CL);
+ ER_CLEAR (p);
+ rde_stack_push (p->ES, p->ER);
+ /* if (p->ER) { p->ER->refCount ++; } */
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE void
+rde_param_i_state_merge_ok (RDE_PARAM p)
+{
+ rde_param_i_error_pop_merge (p);
+
+ if (!p->ST) {
+ p->ST = 1;
+ p->CL = (long int) rde_stack_top (p->LS);
+ }
+ rde_stack_pop (p->LS, 1);
+}
+
+SCOPE void
+rde_param_i_state_merge_void (RDE_PARAM p)
+{
+ rde_param_i_error_pop_merge (p);
+
+ if (!p->ST) {
+ p->CL = (long int) rde_stack_top (p->LS);
+ }
+ rde_stack_pop (p->LS, 1);
+}
+
+SCOPE void
+rde_param_i_state_merge_value (RDE_PARAM p)
+{
+ rde_param_i_error_pop_merge (p);
+
+ if (!p->ST) {
+ long int trim = (long int) rde_stack_top (p->mark);
+ rde_stack_trim (p->ast, trim);
+ p->CL = (long int) rde_stack_top (p->LS);
+ }
+ rde_stack_pop (p->mark, 1);
+ rde_stack_pop (p->LS, 1);
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE int
+rde_param_i_kleene_close (RDE_PARAM p)
+{
+ int stop = !p->ST;
+ rde_param_i_error_pop_merge (p);
+
+ if (stop) {
+ p->ST = 1;
+ p->CL = (long int) rde_stack_top (p->LS);
+ }
+
+ rde_stack_pop (p->LS, 1);
+ return stop;
+}
+
+SCOPE int
+rde_param_i_kleene_abort (RDE_PARAM p)
+{
+ int stop = !p->ST;
+
+ if (stop) {
+ p->CL = (long int) rde_stack_top (p->LS);
+ }
+
+ rde_stack_pop (p->LS, 1);
+ return stop;
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE int
+rde_param_i_seq_void2void (RDE_PARAM p)
+{
+ rde_param_i_error_pop_merge (p);
+
+ if (p->ST) {
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ return 0;
+ } else {
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_pop (p->LS, 1);
+ return 1;
+ }
+}
+
+SCOPE int
+rde_param_i_seq_void2value (RDE_PARAM p)
+{
+ rde_param_i_error_pop_merge (p);
+
+ if (p->ST) {
+ rde_stack_push (p->mark, (void*) rde_stack_size (p->ast));
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ return 0;
+ } else {
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_pop (p->LS, 1);
+ return 1;
+ }
+}
+
+SCOPE int
+rde_param_i_seq_value2value (RDE_PARAM p)
+{
+ rde_param_i_error_pop_merge (p);
+
+ if (p->ST) {
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ return 0;
+ } else {
+ long int trim = (long int) rde_stack_top (p->mark);
+
+ rde_stack_pop (p->mark, 1);
+ rde_stack_trim (p->ast, trim);
+
+ p->CL = (long int) rde_stack_top (p->LS);
+ rde_stack_pop (p->LS, 1);
+ return 1;
+ }
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE int
+rde_param_i_bra_void2void (RDE_PARAM p)
+{
+ rde_param_i_error_pop_merge (p);
+
+ if (p->ST) {
+ rde_stack_pop (p->LS, 1);
+ } else {
+ p->CL = (long int) rde_stack_top (p->LS);
+
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ }
+
+ return p->ST;
+}
+
+SCOPE int
+rde_param_i_bra_void2value (RDE_PARAM p)
+{
+ rde_param_i_error_pop_merge (p);
+
+ if (p->ST) {
+ rde_stack_pop (p->LS, 1);
+ } else {
+ rde_stack_push (p->mark, (void*) rde_stack_size (p->ast));
+ p->CL = (long int) rde_stack_top (p->LS);
+
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ }
+
+ return p->ST;
+}
+
+SCOPE int
+rde_param_i_bra_value2void (RDE_PARAM p)
+{
+ rde_param_i_error_pop_merge (p);
+
+ if (p->ST) {
+ rde_stack_pop (p->mark, 1);
+ rde_stack_pop (p->LS, 1);
+ } else {
+ long int trim = (long int) rde_stack_top (p->mark);
+ rde_stack_pop (p->mark, 1);
+ rde_stack_trim (p->ast, trim);
+
+ p->CL = (long int) rde_stack_top (p->LS);
+
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ }
+
+ return p->ST;
+}
+
+SCOPE int
+rde_param_i_bra_value2value (RDE_PARAM p)
+{
+ rde_param_i_error_pop_merge (p);
+
+ if (p->ST) {
+ rde_stack_pop (p->mark, 1);
+ rde_stack_pop (p->LS, 1);
+ } else {
+ long int trim = (long int) rde_stack_top (p->mark);
+ rde_stack_trim (p->ast, trim);
+
+ p->CL = (long int) rde_stack_top (p->LS);
+
+ rde_stack_push (p->ES, p->ER);
+ if (p->ER) { p->ER->refCount ++; }
+ }
+
+ return p->ST;
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE void
+rde_param_i_next_str (RDE_PARAM p, const char* str, long int m)
+{
+ int at = p->CL;
+
+ /* Future: Place match string into a shared table of constants, like error
+ * messages, indexed by code. Precomputed length information.
+ *
+ * NOTE how we are modifying the error location after the fact. The
+ * message contains the entire string, so the location should be the
+ * start of the string in the input, not somewhere in the middle. This
+ * matches the Tcl runtimes. Here we have to adjust the stored location
+ * due to our progress through the pattern.
+ */
+
+ while (*str) {
+ rde_param_i_input_next (p, m);
+ if (!p->ST) {
+ p->ER->loc = at+1;
+ p->CL = at;
+ return;
+ }
+
+ rde_param_i_test_char (p, str, m);
+ if (!p->ST) {
+ p->ER->loc = at+1;
+ p->CL = at;
+ return;
+ }
+
+ str = Tcl_UtfNext (str);
+ }
+}
+
+SCOPE void
+rde_param_i_next_class (RDE_PARAM p, const char* class, long int m)
+{
+ rde_param_i_input_next (p, m);
+ if (!p->ST) return;
+
+ while (*class) {
+ p->ST = Tcl_UtfNcmp (p->CC, class, 1) == 0;
+
+ if (p->ST) {
+ ER_CLEAR (p);
+ return;
+ }
+
+ class = Tcl_UtfNext (class);
+ }
+
+ error_set (p, m);
+ p->CL --;
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+
+/*
+ * local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/param.h b/tcllib/modules/pt/rde_critcl/param.h
new file mode 100644
index 0000000..3d9fb36
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/param.h
@@ -0,0 +1,183 @@
+/*
+ * = = == === ===== ======== ============= =====================
+ * == pt::rde (critcl) - Data Structures - PARAM architectural state.
+ */
+
+#ifndef _RDE_DS_PARAM_H
+#define _RDE_DS_PARAM_H 1
+
+#include "tcl.h"
+#include <util.h> /* Scoping */
+#include <stack.h> /* Stack handling */
+
+/*
+ * The state structure is opaque, its internals are known only to the
+ * functions declared here.
+ */
+
+typedef struct RDE_PARAM_* RDE_PARAM;
+
+typedef struct ERROR_STATE {
+ int refCount;
+ long int loc;
+ RDE_STACK msg; /* long int :: error messages */
+} ERROR_STATE;
+
+typedef struct NC_STATE {
+ long int CL;
+ long int ST;
+ Tcl_Obj* SV;
+ ERROR_STATE* ER;
+} NC_STATE;
+
+/* SKIP START */
+/* Admin
+ */
+
+SCOPE RDE_PARAM rde_param_new (long int n, char** strings);
+SCOPE void rde_param_del (RDE_PARAM p);
+SCOPE void rde_param_reset (RDE_PARAM p, Tcl_Channel chan);
+SCOPE void rde_param_update_strings (RDE_PARAM p, long int n, char** strings);
+SCOPE void rde_param_data (RDE_PARAM p, char* buf, long int len);
+SCOPE void rde_param_clientdata (RDE_PARAM p, ClientData clientData);
+
+/* Accessors
+ */
+
+SCOPE ClientData rde_param_query_clientdata (RDE_PARAM p);
+SCOPE void rde_param_query_amark (RDE_PARAM p, long int* mc, void*** mv);
+SCOPE void rde_param_query_ast (RDE_PARAM p, long int* ac, Tcl_Obj*** av);
+SCOPE const char* rde_param_query_in (RDE_PARAM p);
+SCOPE const char* rde_param_query_cc (RDE_PARAM p, long int* len);
+SCOPE int rde_param_query_cl (RDE_PARAM p);
+SCOPE const ERROR_STATE* rde_param_query_er (RDE_PARAM p);
+SCOPE Tcl_Obj* rde_param_query_er_tcl (RDE_PARAM p, const ERROR_STATE* er);
+SCOPE void rde_param_query_es (RDE_PARAM p, long int* ec, ERROR_STATE*** ev);
+SCOPE void rde_param_query_ls (RDE_PARAM p, long int* lc, void*** lv);
+SCOPE long int rde_param_query_lstop (RDE_PARAM p);
+SCOPE Tcl_HashTable* rde_param_query_nc (RDE_PARAM p);
+SCOPE int rde_param_query_st (RDE_PARAM p);
+SCOPE Tcl_Obj* rde_param_query_sv (RDE_PARAM p);
+SCOPE long int rde_param_query_tc_size (RDE_PARAM p);
+SCOPE void rde_param_query_tc_get_s (RDE_PARAM p, long int at, long int last, char** ch, long int* len);
+SCOPE const char* rde_param_query_string (RDE_PARAM p, long int id);
+
+/* Instructions
+ */
+
+SCOPE void rde_param_i_ast_pop_discard (RDE_PARAM p);
+SCOPE void rde_param_i_ast_pop_rewind (RDE_PARAM p);
+SCOPE void rde_param_i_ast_push (RDE_PARAM p);
+SCOPE void rde_param_i_ast_rewind (RDE_PARAM p);
+SCOPE void rde_param_i_ast_value_push (RDE_PARAM p);
+
+SCOPE void rde_param_i_error_clear (RDE_PARAM p);
+SCOPE void rde_param_i_error_nonterminal (RDE_PARAM p, long int s);
+SCOPE void rde_param_i_error_pop_merge (RDE_PARAM p);
+SCOPE void rde_param_i_error_push (RDE_PARAM p);
+
+SCOPE void rde_param_i_loc_pop_discard (RDE_PARAM p);
+SCOPE void rde_param_i_loc_pop_rewind (RDE_PARAM p);
+SCOPE void rde_param_i_loc_push (RDE_PARAM p);
+SCOPE void rde_param_i_loc_rewind (RDE_PARAM p);
+
+SCOPE void rde_param_i_input_next (RDE_PARAM p, long int m);
+
+SCOPE void rde_param_i_status_fail (RDE_PARAM p);
+SCOPE void rde_param_i_status_ok (RDE_PARAM p);
+SCOPE void rde_param_i_status_negate (RDE_PARAM p);
+
+SCOPE int rde_param_i_symbol_restore (RDE_PARAM p, long int s);
+SCOPE void rde_param_i_symbol_save (RDE_PARAM p, long int s);
+
+SCOPE void rde_param_i_test_char (RDE_PARAM p, const char* c, long int m);
+SCOPE void rde_param_i_test_range (RDE_PARAM p, const char* s, const char* e, long int m);
+
+SCOPE void rde_param_i_test_alnum (RDE_PARAM p);
+SCOPE void rde_param_i_test_alpha (RDE_PARAM p);
+SCOPE void rde_param_i_test_ascii (RDE_PARAM p);
+SCOPE void rde_param_i_test_control (RDE_PARAM p);
+SCOPE void rde_param_i_test_ddigit (RDE_PARAM p);
+SCOPE void rde_param_i_test_digit (RDE_PARAM p);
+SCOPE void rde_param_i_test_graph (RDE_PARAM p);
+SCOPE void rde_param_i_test_lower (RDE_PARAM p);
+SCOPE void rde_param_i_test_print (RDE_PARAM p);
+SCOPE void rde_param_i_test_punct (RDE_PARAM p);
+SCOPE void rde_param_i_test_space (RDE_PARAM p);
+SCOPE void rde_param_i_test_upper (RDE_PARAM p);
+SCOPE void rde_param_i_test_wordchar (RDE_PARAM p);
+SCOPE void rde_param_i_test_xdigit (RDE_PARAM p);
+
+SCOPE void rde_param_i_value_clear (RDE_PARAM p);
+SCOPE void rde_param_i_value_leaf (RDE_PARAM p, long int s);
+SCOPE void rde_param_i_value_reduce (RDE_PARAM p, long int s);
+
+/* Super Instructions - Aggregated common instruction sequences.
+ */
+
+SCOPE int rde_param_i_symbol_start (RDE_PARAM p, long int s);
+SCOPE int rde_param_i_symbol_start_d (RDE_PARAM p, long int s);
+SCOPE int rde_param_i_symbol_void_start (RDE_PARAM p, long int s);
+SCOPE int rde_param_i_symbol_void_start_d (RDE_PARAM p, long int s);
+
+SCOPE void rde_param_i_symbol_done_d_reduce (RDE_PARAM p, long int s, long int m);
+SCOPE void rde_param_i_symbol_done_leaf (RDE_PARAM p, long int s, long int m);
+SCOPE void rde_param_i_symbol_done_d_leaf (RDE_PARAM p, long int s, long int m);
+SCOPE void rde_param_i_symbol_done_void (RDE_PARAM p, long int s, long int m);
+SCOPE void rde_param_i_symbol_done_d_void (RDE_PARAM p, long int s, long int m);
+
+SCOPE void rde_param_i_next_char (RDE_PARAM p, const char* c, long int m);
+SCOPE void rde_param_i_next_range (RDE_PARAM p, const char* s, const char* e, long int m);
+
+SCOPE void rde_param_i_next_alnum (RDE_PARAM p, long int m);
+SCOPE void rde_param_i_next_alpha (RDE_PARAM p, long int m);
+SCOPE void rde_param_i_next_ascii (RDE_PARAM p, long int m);
+SCOPE void rde_param_i_next_control (RDE_PARAM p, long int m);
+SCOPE void rde_param_i_next_ddigit (RDE_PARAM p, long int m);
+SCOPE void rde_param_i_next_digit (RDE_PARAM p, long int m);
+SCOPE void rde_param_i_next_graph (RDE_PARAM p, long int m);
+SCOPE void rde_param_i_next_lower (RDE_PARAM p, long int m);
+SCOPE void rde_param_i_next_print (RDE_PARAM p, long int m);
+SCOPE void rde_param_i_next_punct (RDE_PARAM p, long int m);
+SCOPE void rde_param_i_next_space (RDE_PARAM p, long int m);
+SCOPE void rde_param_i_next_upper (RDE_PARAM p, long int m);
+SCOPE void rde_param_i_next_wordchar (RDE_PARAM p, long int m);
+SCOPE void rde_param_i_next_xdigit (RDE_PARAM p, long int m);
+
+SCOPE void rde_param_i_notahead_start_d (RDE_PARAM p);
+SCOPE void rde_param_i_notahead_exit_d (RDE_PARAM p);
+SCOPE void rde_param_i_notahead_exit (RDE_PARAM p);
+
+SCOPE void rde_param_i_state_push_2 (RDE_PARAM p);
+SCOPE void rde_param_i_state_push_void (RDE_PARAM p);
+SCOPE void rde_param_i_state_push_value (RDE_PARAM p);
+
+SCOPE void rde_param_i_state_merge_ok (RDE_PARAM p);
+SCOPE void rde_param_i_state_merge_void (RDE_PARAM p);
+SCOPE void rde_param_i_state_merge_value (RDE_PARAM p);
+
+SCOPE int rde_param_i_kleene_close (RDE_PARAM p);
+SCOPE int rde_param_i_kleene_abort (RDE_PARAM p);
+
+SCOPE int rde_param_i_seq_void2void (RDE_PARAM p);
+SCOPE int rde_param_i_seq_void2value (RDE_PARAM p);
+SCOPE int rde_param_i_seq_value2value (RDE_PARAM p);
+
+SCOPE int rde_param_i_bra_void2void (RDE_PARAM p);
+SCOPE int rde_param_i_bra_void2value (RDE_PARAM p);
+SCOPE int rde_param_i_bra_value2void (RDE_PARAM p);
+SCOPE int rde_param_i_bra_value2value (RDE_PARAM p);
+
+SCOPE void rde_param_i_next_str (RDE_PARAM p, const char* str, long int m);
+SCOPE void rde_param_i_next_class (RDE_PARAM p, const char* class, long int m);
+
+/* SKIP END */
+#endif /* _RDE_DS_PARAM_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/stack.c b/tcllib/modules/pt/rde_critcl/stack.c
new file mode 100644
index 0000000..c5ebc8e
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/stack.c
@@ -0,0 +1,160 @@
+/*
+ * = = == === ===== ======== ============= =====================
+ * == pt::rde (critcl) - Data Structures - Generic stack
+ */
+
+#include <stack.h> /* Our public API */
+#include <util.h> /* Allocation macros */
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+typedef struct RDE_STACK_ {
+ long int max; /* Size of the cell array. */
+ long int top; /* Index of the topmost _unused_ cell in the
+ * array === Index of the _next_ cell to use
+ * === Size of the stack. */
+ RDE_STACK_CELL_FREE freeCellProc;
+ void** cell; /* Array of the stack cells. */
+} RDE_STACK_;
+
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE RDE_STACK
+rde_stack_new (RDE_STACK_CELL_FREE freeCellProc)
+{
+ RDE_STACK s = ALLOC (RDE_STACK_);
+ s->cell = NALLOC (RDE_STACK_INITIAL_SIZE, void*);
+ s->max = RDE_STACK_INITIAL_SIZE;
+ s->top = 0;
+ s->freeCellProc = freeCellProc;
+
+ return s;
+}
+
+SCOPE void
+rde_stack_del (RDE_STACK s)
+{
+ if (s->freeCellProc && s->top) {
+ long int i;
+ for (i=0; i < s->top; i++) {
+ ASSERT_BOUNDS(i,s->max);
+ s->freeCellProc ( s->cell [i] );
+ }
+ }
+
+ ckfree ((char*) s->cell);
+ ckfree ((char*) s);
+}
+
+SCOPE void
+rde_stack_push (RDE_STACK s, void* item)
+{
+ if (s->top >= s->max) {
+ long int new = s->max ? (2 * s->max) : RDE_STACK_INITIAL_SIZE;
+ void** cell = (void**) ckrealloc ((char*) s->cell, new * sizeof(void*));
+ ASSERT (cell,"Memory allocation failure for RDE stack");
+ s->max = new;
+ s->cell = cell;
+ }
+
+ ASSERT_BOUNDS(s->top,s->max);
+ s->cell [s->top] = item;
+ s->top ++;
+}
+
+SCOPE void*
+rde_stack_top (RDE_STACK s)
+{
+ ASSERT_BOUNDS(s->top-1,s->max);
+ return s->cell [s->top - 1];
+}
+
+SCOPE void
+rde_stack_pop (RDE_STACK s, long int n)
+{
+ ASSERT (n >= 0, "Bad pop count");
+ if (n == 0) return;
+
+ if (s->freeCellProc) {
+ while (n) {
+ s->top --;
+ ASSERT_BOUNDS(s->top,s->max);
+ s->freeCellProc ( s->cell [s->top] );
+ n --;
+ }
+ } else {
+ s->top -= n;
+ }
+}
+
+SCOPE void
+rde_stack_trim (RDE_STACK s, long int n)
+{
+ ASSERT (n >= 0, "Bad trimsize");
+
+ if (s->freeCellProc) {
+ while (s->top > n) {
+ s->top --;
+ ASSERT_BOUNDS(s->top,s->max);
+ s->freeCellProc ( s->cell [s->top] );
+ }
+ } else {
+ s->top = n;
+ }
+}
+
+SCOPE void
+rde_stack_drop (RDE_STACK s, long int n)
+{
+ ASSERT (n >= 0, "Bad pop count");
+ if (n == 0) return;
+ s->top -= n;
+}
+
+SCOPE void
+rde_stack_move (RDE_STACK dst, RDE_STACK src)
+{
+ ASSERT (dst->freeCellProc == src->freeCellProc, "Ownership mismatch");
+
+ /*
+ * Note: The destination takes ownership of the moved cell, thus there is
+ * no need to run free on them.
+ */
+
+ while (src->top > 0) {
+ src->top --;
+ ASSERT_BOUNDS(src->top,src->max);
+ rde_stack_push (dst, src->cell [src->top] );
+ }
+}
+
+SCOPE void
+rde_stack_get (RDE_STACK s, long int* cn, void*** cc)
+{
+ *cn = s->top;
+ *cc = s->cell;
+}
+
+SCOPE long int
+rde_stack_size (RDE_STACK s)
+{
+ return s->top;
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/stack.h b/tcllib/modules/pt/rde_critcl/stack.h
new file mode 100644
index 0000000..ca24666
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/stack.h
@@ -0,0 +1,62 @@
+/*
+ * = = == === ===== ======== ============= =====================
+ * == pt::rde (critcl) - Data Structures - Generic stack
+ */
+
+#ifndef _RDE_DS_STACK_H
+#define _RDE_DS_STACK_H 1
+
+#include <util.h> /* Scoping */
+
+/*
+ * The stack data structure declared in this file is an array of void*
+ * cells, with each cell either directly containing the data, or being
+ * a pointer to it.
+ *
+ * The structure maintains a max-size field, reallocating the array if
+ * and only if we go over this size. Each allocation doubles the
+ * available room.
+ *
+ * A pointer to a delete function is maintained, to delete cells which
+ * are references to the actual data.
+ */
+
+typedef void (*RDE_STACK_CELL_FREE) (void* cell);
+typedef struct RDE_STACK_* RDE_STACK;
+
+static const int RDE_STACK_INITIAL_SIZE = 256;
+
+/*
+ * Notes
+ * - push -- Item allocation is responsibility of caller.
+ * Stack takes ownership of the item.
+ * - pop -- Stack frees allocated item.
+ * - trim -- Ditto
+ * - top -- Provides top item, no transfer of ownership.
+ * - del -- Releases stack, cell array, and items, if any.
+ * - drop -- Like pop, but doesn't free, assumes that caller
+ * is taking ownership of the pointer.
+ */
+
+/* SKIP START */
+SCOPE RDE_STACK rde_stack_new (RDE_STACK_CELL_FREE freeCellProc);
+SCOPE void rde_stack_del (RDE_STACK s);
+
+SCOPE void* rde_stack_top (RDE_STACK s);
+SCOPE void rde_stack_push (RDE_STACK s, void* item);
+SCOPE void rde_stack_pop (RDE_STACK s, long int n);
+SCOPE void rde_stack_trim (RDE_STACK s, long int n);
+SCOPE void rde_stack_drop (RDE_STACK s, long int n);
+SCOPE void rde_stack_move (RDE_STACK dst, RDE_STACK src);
+SCOPE void rde_stack_get (RDE_STACK s, long int* cn, void*** cc);
+SCOPE long int rde_stack_size (RDE_STACK s);
+/* SKIP END */
+#endif /* _RDE_DS_STACK_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/tc.c b/tcllib/modules/pt/rde_critcl/tc.c
new file mode 100644
index 0000000..1b3ca63
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/tc.c
@@ -0,0 +1,186 @@
+/*
+ * = = == === ===== ======== ============= =====================
+ * == pt::rde (critcl) - Data Structures - Token cache
+ */
+
+#include <tc.h> /* Our public API */
+#include <stack.h> /* Stack handling */
+#include <util.h> /* Allocation macros */
+#include <string.h>
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+typedef struct RDE_TC_ {
+ int max; /* Max number of bytes in the cache */
+ int num; /* Current number of bytes in the cache */
+ char* str; /* Character cache (utf8) */
+ RDE_STACK off; /* Offsets of characters in 'string' */
+} RDE_TC_;
+
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+SCOPE RDE_TC
+rde_tc_new (void)
+{
+ RDE_TC tc = ALLOC (RDE_TC_);
+
+ tc->max = RDE_STACK_INITIAL_SIZE;
+ tc->num = 0;
+ tc->str = NALLOC (RDE_STACK_INITIAL_SIZE, char);
+ tc->off = rde_stack_new (NULL);
+
+ return tc;
+}
+
+SCOPE void
+rde_tc_del (RDE_TC tc)
+{
+ rde_stack_del (tc->off);
+
+ ckfree (tc->str);
+ ckfree ((char*) tc);
+}
+
+SCOPE long int
+rde_tc_size (RDE_TC tc)
+{
+ return rde_stack_size (tc->off);
+}
+
+SCOPE void
+rde_tc_clear (RDE_TC tc)
+{
+ tc->num = 0;
+
+ rde_stack_trim (tc->off, 0);
+}
+
+SCOPE char*
+rde_tc_append (RDE_TC tc, char* string, long int len)
+{
+ long int base = tc->num;
+ long int off = tc->num;
+ char* ch;
+ int clen;
+ Tcl_UniChar uni;
+
+ if (len < 0) {
+ len = strlen (string);
+ }
+
+ /*
+ * Nothing to append, nothing to do. Bail immediately.
+ */
+
+ if (!len) {
+ return tc->str + base;
+ }
+
+ /*
+ * Extend character buffer to hold the new string, and copy the string in.
+ */
+
+ if ((tc->num + len) >= tc->max) {
+ int new = len + (tc->max ? (2 * tc->max) : RDE_STACK_INITIAL_SIZE);
+ char* str = ckrealloc (tc->str, new * sizeof(char));
+ ASSERT (str,"Memory allocation failure for token character array");
+ tc->max = new;
+ tc->str = str;
+ }
+
+ tc->num += len;
+ ASSERT_BOUNDS(tc->num,tc->max);
+ ASSERT_BOUNDS(off,tc->max);
+ ASSERT_BOUNDS(off+len-1,tc->max);
+ ASSERT_BOUNDS(off+len-1,tc->num);
+ memcpy (tc->str + off, string, len);
+
+ /*
+ * Now update the offset counter, this is done per character in the new
+ * string.
+ */
+
+ ch = string;
+ while (ch < (string + len)) {
+ ASSERT_BOUNDS(off,tc->num);
+ rde_stack_push (tc->off, (void*) off);
+
+ clen = Tcl_UtfToUniChar (ch, &uni);
+
+ off += clen;
+ ch += clen;
+ }
+
+ return tc->str + base;
+}
+
+SCOPE void
+rde_tc_get (RDE_TC tc, int at, char** ch, long int* len)
+{
+ long int oc, off, end;
+ void** ov;
+
+ rde_stack_get (tc->off, &oc, &ov);
+
+ ASSERT_BOUNDS(at,oc);
+
+ off = (long int) ov [at];
+ if ((at+1) == oc) {
+ end = tc->num;
+ } else {
+ end = (long int) ov [at+1];
+ }
+
+ TRACE (("rde_tc_get (RDE_TC %p, @ %d) => %d.[%d ... %d]/%d",tc,at,end-off,off,end-1,tc->num));
+
+ ASSERT_BOUNDS(off,tc->num);
+ ASSERT_BOUNDS(end-1,tc->num);
+
+ *ch = tc->str + off;
+ *len = end - off;
+}
+
+SCOPE void
+rde_tc_get_s (RDE_TC tc, int at, int last, char** ch, long int* len)
+{
+ long int oc, off, end;
+ void** ov;
+
+ rde_stack_get (tc->off, &oc, &ov);
+
+ ASSERT_BOUNDS(at,oc);
+ ASSERT_BOUNDS(last,oc);
+
+ off = (long int) ov [at];
+ if ((last+1) == oc) {
+ end = tc->num;
+ } else {
+ end = (long int) ov [last+1];
+ }
+
+ TRACE (("rde_tc_get_s (RDE_TC %p, @ %d .. %d) => %d.[%d ... %d]/%d",tc,at,last,end-off,off,end-1,tc->num));
+
+ ASSERT_BOUNDS(off,tc->num);
+ ASSERT_BOUNDS(end-1,tc->num);
+
+ *ch = tc->str + off;
+ *len = end - off;
+}
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/tc.h b/tcllib/modules/pt/rde_critcl/tc.h
new file mode 100644
index 0000000..6195400
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/tc.h
@@ -0,0 +1,31 @@
+/*
+ * = = == === ===== ======== ============= =====================
+ * == pt::rde (critcl) - Data Structures - Generic token cache
+ */
+
+#ifndef _RDE_DS_TC_H
+#define _RDE_DS_TC_H 1
+
+#include <util.h> /* Scoping */
+
+typedef struct RDE_TC_* RDE_TC;
+
+/* SKIP START */
+SCOPE RDE_TC rde_tc_new (void);
+SCOPE void rde_tc_del (RDE_TC tc);
+
+SCOPE long int rde_tc_size (RDE_TC tc);
+SCOPE void rde_tc_clear (RDE_TC tc);
+SCOPE char* rde_tc_append (RDE_TC tc, char* ch, long int len);
+SCOPE void rde_tc_get (RDE_TC tc, int at, char** ch, long int *len);
+SCOPE void rde_tc_get_s (RDE_TC tc, int at, int last, char** ch, long int *len);
+/* SKIP END */
+#endif /* _RDE_DS_TC_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/util.c b/tcllib/modules/pt/rde_critcl/util.c
new file mode 100644
index 0000000..2eb0454
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/util.c
@@ -0,0 +1,145 @@
+/*
+ * = = == === ===== ======== ============= =====================
+ * == pt::rde (critcl) - Data Structures - PARAM architectural state.
+ */
+
+#include <string.h>
+#include <util.h> /* Allocation utilities */
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+#ifdef RDE_TRACE
+typedef struct F_STACK {
+ const char* str;
+ struct F_STACK* down;
+} F_STACK;
+
+static F_STACK* top = 0;
+static int level = 0;
+
+static void
+push (const char* str)
+{
+ F_STACK* new = ALLOC (F_STACK);
+ new->str = str;
+ new->down = top;
+ top = new;
+ level += 4;
+}
+
+static void
+pop (void)
+{
+ F_STACK* next = top->down;
+ level -= 4;
+ ckfree ((char*)top);
+ top = next;
+}
+
+static void
+indent (void)
+{
+ int i;
+ for (i = 0; i < level; i++) {
+ fwrite(" ", 1, 1, stdout);
+ fflush (stdout);
+ }
+
+ if (top) {
+ fwrite(top->str, 1, strlen(top->str), stdout);
+ fflush (stdout);
+ }
+
+ fwrite(" ", 1, 1, stdout);
+ fflush (stdout);
+}
+
+SCOPE void
+trace_enter (const char* fun)
+{
+ push (fun);
+ indent();
+ fwrite("ENTER\n", 1, 6, stdout);
+ fflush (stdout);
+}
+
+/*
+ * We may trace large data structures (AST!)
+ */
+static char msg [1024*1024];
+
+SCOPE void
+trace_return (const char *pat, ...)
+{
+ int len;
+ va_list args;
+
+ indent();
+ fwrite("RETURN = ", 1, 9, stdout);
+ fflush (stdout);
+
+ va_start(args, pat);
+ len = vsprintf(msg, pat, args);
+ va_end(args);
+
+ msg[len++] = '\n';
+ msg[len] = '\0';
+
+ fwrite(msg, 1, len, stdout);
+ fflush (stdout);
+
+ pop();
+}
+
+SCOPE void
+trace_printf (const char *pat, ...)
+{
+ int len;
+ va_list args;
+
+ indent();
+
+ va_start(args, pat);
+ len = vsprintf(msg, pat, args);
+ va_end(args);
+
+ msg[len++] = '\n';
+ msg[len] = '\0';
+
+ fwrite(msg, 1, len, stdout);
+ fflush (stdout);
+}
+
+SCOPE void
+trace_printf0 (const char *pat, ...)
+{
+ int len;
+ va_list args;
+
+ va_start(args, pat);
+ len = vsprintf(msg, pat, args);
+ va_end(args);
+
+ msg[len++] = '\n';
+ msg[len] = '\0';
+
+ fwrite(msg, 1, len, stdout);
+ fflush (stdout);
+}
+
+#endif
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+
+/*
+ * local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/rde_critcl/util.h b/tcllib/modules/pt/rde_critcl/util.h
new file mode 100644
index 0000000..e89f9eb
--- /dev/null
+++ b/tcllib/modules/pt/rde_critcl/util.h
@@ -0,0 +1,79 @@
+/*
+ * = = == === ===== ======== ============= =====================
+ * == pt::rde (critcl) - General utilities
+ */
+
+#ifndef _RDE_UTIL_H
+#define _RDE_UTIL_H 1
+
+#include <tcl.h>
+
+/*
+ * Default scope, global
+ */
+
+#ifndef SCOPE
+#define SCOPE
+#endif
+
+/*
+ * Allocation macros for common situations.
+ */
+
+#define ALLOC(type) (type *) ckalloc (sizeof (type))
+#define NALLOC(n,type) (type *) ckalloc ((n) * sizeof (type))
+
+/*
+ * General assertions, and asserting the proper range of an array index.
+ */
+
+#undef RDE_DEBUG
+#define RDE_DEBUG 1
+
+#undef RDE_TRACE
+/* #define RDE_TRACE 1 */
+
+/*
+ * = = == === ===== ======== ============= =====================
+ */
+
+#ifdef RDE_DEBUG
+#define STOPAFTER(x) { static int count = (x); count --; if (!count) { Tcl_Panic ("stop"); } }
+#define XSTR(x) #x
+#define STR(x) XSTR(x)
+#define RANGEOK(i,n) ((0 <= (i)) && (i < (n)))
+#define ASSERT(x,msg) if (!(x)) { Tcl_Panic (msg " (" #x "), in file " __FILE__ " @line " STR(__LINE__));}
+#define ASSERT_BOUNDS(i,n) ASSERT (RANGEOK(i,n),"array index out of bounds: " STR(i) " >= " STR(n))
+#else
+#define STOPAFTER(x)
+#define ASSERT(x,msg)
+#define ASSERT_BOUNDS(i,n)
+#endif
+
+#ifdef RDE_TRACE
+SCOPE void trace_enter (const char* fun);
+SCOPE void trace_return (const char *pat, ...);
+SCOPE void trace_printf (const char *pat, ...);
+
+#define ENTER(fun) trace_enter (fun)
+#define RETURN(format,x) trace_return (format,x) ; return x
+#define RETURNVOID trace_return ("%s","(void)") ; return
+#define TRACE0(x) trace_printf0 x
+#define TRACE(x) trace_printf x
+#else
+#define ENTER(fun)
+#define RETURN(f,x) return x
+#define RETURNVOID return
+#define TRACE0(x)
+#define TRACE(x)
+#endif
+
+#endif /* _RDE_UTIL_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcllib/modules/pt/tests/char.tests b/tcllib/modules/pt/tests/char.tests
new file mode 100644
index 0000000..594aae1
--- /dev/null
+++ b/tcllib/modules/pt/tests/char.tests
@@ -0,0 +1,236 @@
+# -*- tcl -*-
+# Testsuite for char.
+# Called by the ../char.test driver file.
+
+test char-1.0.0 {char, wrong#args} -constraints tcl8.5minus -body {
+ char
+} -returnCodes error \
+ -result {wrong # args: should be "char subcommand ?argument ...?"}
+
+test char-1.0.1 {char, wrong#args} -constraints tcl8.6plus -body {
+ char
+} -returnCodes error \
+ -result {wrong # args: should be "char subcommand ?arg ...?"}
+
+test char-1.1 {char, bogus method} -body {
+ char bogus
+} -returnCodes error \
+ -result {unknown or ambiguous subcommand "bogus": must be quote, or unquote}
+
+test char-1.2.0 {char, wrong#args} -constraints tcl8.5minus -body {
+ char quote
+} -returnCodes error \
+ -result {wrong # args: should be "char quote subcommand ?argument ...?"}
+
+test char-1.2.1 {char, wrong#args} -constraints tcl8.6plus -body {
+ char quote
+} -returnCodes error \
+ -result {wrong # args: should be "char quote subcommand ?arg ...?"}
+
+test char-1.3 {char, bogus method} -body {
+ char quote bogus
+} -returnCodes error \
+ -result {unknown or ambiguous subcommand "bogus": must be comment, cstring, string, or tcl}
+
+#----------------------------------------------------------------------
+
+test char-2.0.0 {char tcl, wrong#args} -constraints tcl8.5minus -body {
+ char quote tcl
+} -returnCodes error -result {wrong # args: should be "char quote tcl ch ..."}
+
+test char-2.0.1 {char tcl, wrong#args} -constraints tcl8.6plus -body {
+ char quote tcl
+} -returnCodes error -result {wrong # args: should be "char quote tcl ch ?arg ...?"}
+
+test char-2.1 {char tcl, single char} -body {
+ char quote tcl A
+} -result A
+
+test char-2.2 {char tcl, multi char} -body {
+ char quote tcl A B
+} -result {A B}
+
+foreach {n label input expected} {
+ 0 obrace \{ \\173
+ 1 obrckt \[ \\133
+ 2 dquote \" \\42
+ 3 escape \033 \\33
+ 4 lf \n \\n
+ 5 space { } \\40
+ 6 backslash \\ \\134
+ 7 A A A
+ 8 del \177 \\177
+ 9 circast \u229b \\u229b
+} {
+ test char-2.3.$n "char tcl, map $label" -body {
+ char quote tcl $input
+ } -result $expected
+
+ # collect table columns for string and multi-arg tests.
+ lappend ll $label
+ lappend li $input
+ lappend le $expected
+}
+
+test char-2.4 "char tcl, map string" -body {
+ char quote tcl [join $li {}]
+} -result [join $le {}]
+
+test char-2.5 "char tcl, map multiple" -body {
+ char quote tcl {*}$li
+} -result $le
+
+unset -nocomplain n label input expected ll li le
+
+#----------------------------------------------------------------------
+
+test char-3.0.0 {char string, wrong#args} -constraints tcl8.5minus -body {
+ char quote string
+} -returnCodes error -result {wrong # args: should be "char quote string ch ..."}
+
+test char-3.0.1 {char string, wrong#args} -constraints tcl8.6plus -body {
+ char quote string
+} -returnCodes error -result {wrong # args: should be "char quote string ch ?arg ...?"}
+
+test char-3.1 {char string, single char} -body {
+ char quote string A
+} -result A
+
+test char-3.2 {char string, multi char} -body {
+ char quote string A B
+} -result {A B}
+
+foreach {n label input expected} {
+ 0 obrace \{ \{
+ 1 obrckt \[ \[
+ 2 dquote \" \"
+ 3 escape \033 <ESC>
+ 4 lf \n <LF>
+ 5 space { } <SPACE>
+ 6 backslash \\ \\
+ 7 A A A
+ 8 del \177 <DEL>
+ 9 circast \u229b \u229b
+} {
+ test char-3.3.$n "char string, map $label" -body {
+ char quote string $input
+ } -result $expected
+
+ # collect table columns for string and multi-arg tests.
+ lappend ll $label
+ lappend li $input
+ lappend le $expected
+}
+
+test char-3.4 "char string, map string" -body {
+ char quote string [join $li {}]
+} -result [join $le {}]
+
+test char-3.5 "char string, map multiple" -body {
+ char quote string {*}$li
+} -result $le
+
+unset -nocomplain n label input expected ll li le
+
+#----------------------------------------------------------------------
+
+test char-4.0.0 {char cstring, wrong#args} -constraints tcl8.5minus -body {
+ char quote cstring
+} -returnCodes error -result {wrong # args: should be "char quote cstring ch ..."}
+
+test char-4.0.1 {char cstring, wrong#args} -constraints tcl8.6plus -body {
+ char quote cstring
+} -returnCodes error -result {wrong # args: should be "char quote cstring ch ?arg ...?"}
+
+test char-4.1 {char cstring, single char} -body {
+ char quote cstring A
+} -result A
+
+test char-4.2 {char cstring, multi char} -body {
+ char quote cstring A B
+} -result {A B}
+
+foreach {n label input expected} {
+ 0 obrace \{ \\173
+ 1 obrckt \[ \[
+ 2 dquote \" \\\"
+ 3 escape \033 \\33
+ 4 lf \n \\n
+ 5 space { } { }
+ 6 backslash \\ \\\\
+ 7 A A A
+ 8 del \177 \\177
+ 9 circast \u229b \\342\\212\\233
+} {
+ test char-4.3.$n "char cstring, map $label" -body {
+ char quote cstring $input
+ } -result $expected
+
+ # collect table columns for string and multi-arg tests.
+ lappend ll $label
+ lappend li $input
+ lappend le $expected
+}
+
+test char-4.4 "char cstring, map string" -body {
+ char quote cstring [join $li {}]
+} -result [join $le {}]
+
+test char-4.5 "char cstring, map multiple" -body {
+ char quote cstring {*}$li
+} -result $le
+
+unset -nocomplain n label input expected ll li le
+
+#----------------------------------------------------------------------
+
+test char-5.0.0 {char comment, wrong#args} -constraints tcl8.5minus -body {
+ char quote comment
+} -returnCodes error -result {wrong # args: should be "char quote comment ch ..."}
+
+test char-5.0.1 {char comment, wrong#args} -constraints tcl8.6plus -body {
+ char quote comment
+} -returnCodes error -result {wrong # args: should be "char quote comment ch ?arg ...?"}
+
+test char-5.1 {char comment, single char} -body {
+ char quote comment A
+} -result A
+
+test char-5.2 {char comment, multi char} -body {
+ char quote comment A B
+} -result {A B}
+
+foreach {n label input expected} {
+ 0 obrace \{ \\\{
+ 1 obrckt \[ \[
+ 2 dquote \" \\\"
+ 3 escape \033 \\33
+ 4 lf \n \\n
+ 5 space { } <blank>
+ 6 backslash \\ \\
+ 7 A A A
+ 8 del \177 \\177
+ 9 circast \u229b \\u229b
+} {
+ test char-5.3.$n "char comment, map $label" -body {
+ char quote comment $input
+ } -result $expected
+
+ # collect table columns for string and multi-arg tests.
+ lappend ll $label
+ lappend li $input
+ lappend le $expected
+}
+
+test char-5.4 "char comment, map string" -body {
+ char quote comment [join $li {}]
+} -result [join $le {}]
+
+test char-5.5 "char comment, map multiple" -body {
+ char quote comment {*}$li
+} -result $le
+
+unset -nocomplain n label input expected ll li le
+
+#----------------------------------------------------------------------
+return
diff --git a/tcllib/modules/pt/tests/common b/tcllib/modules/pt/tests/common
new file mode 100644
index 0000000..773bf97
--- /dev/null
+++ b/tcllib/modules/pt/tests/common
@@ -0,0 +1,412 @@
+# -*- tcl -*-
+# Code common to the various control files.
+#
+# Copyright (c) 2009-2014 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# All rights reserved.
+#
+# RCS: @(#) $Id: common,v 1.1 2010/03/26 05:07:24 andreas_kupries Exp $
+
+# -------------------------------------------------------------------------
+
+# Similar to TestFiles in devtools/testutilities.tcl, but not
+# identical. Here we do not expect source'able test suites, but data
+# files, organized in sections under a main directory.
+
+proc TestFilesProcess {maindir section inset outset -> nv lv iv dv ev script {optionalok 0}} {
+ upvar 1 $nv n $lv label $dv data $ev expected $iv inputfile
+
+ set pattern $maindir/$section/$inset/*
+
+ set files [TestFilesGlob $pattern]
+ if {![llength $files]} {
+ if {$optionalok} return
+ return -code error "No files matching \"$pattern\""
+ }
+ foreach src $files {
+ if {[string match *README* $src]} continue
+ if {[file isdirectory $src]} continue
+
+ set srcname [file tail $src]
+ set exp [localPath $maindir]/$section/$outset/$srcname
+ set data [fileutil::cat -translation binary -encoding utf-8 $src]
+ set expected [string trim [fileutil::cat -translation binary -encoding utf-8 $exp]]
+ set expected [string map [list \
+ @sak @sak \
+ @line @line \
+ {@ %d} {@ %d} \
+ {@ %p} {@ %p} \
+ @ $::tcltest::testsDirectory] $expected]
+
+ regexp -- {^([0-9]+)} $srcname -> n
+ regsub -all -- {^[0-9]+} $srcname {} label
+
+ scan $n %d n
+ set label [string trim [string map {_ { }} $label]]
+ set inputfile $src
+
+ uplevel 1 $script
+ }
+ return
+}
+
+
+proc TestFilesProcessIn {maindir section inset -> nv lv iv dv script} {
+ upvar 1 $nv n $lv label $dv data $iv inputfile
+
+ set pattern $maindir/$section/$inset/*
+
+ set files [TestFilesGlob $pattern]
+ if {![llength $files]} {
+ return -code error "No files matching \"$pattern\""
+ }
+ foreach src $files {
+ if {[string match *README* $src]} continue
+ if {[file isdirectory $src]} continue
+
+ set srcname [file tail $src]
+ set data [fileutil::cat -translation binary -encoding utf-8 $src]
+
+ regexp -- {^([0-9]+)} $srcname -> n
+ regsub -all -- {^[0-9]+} $srcname {} label
+
+ scan $n %d n
+ set label [string trim [string map {_ { }} $label]]
+ set inputfile $src
+
+ uplevel 1 $script
+ }
+ return
+}
+
+# -------------------------------------------------------------------------
+
+proc setup_plugins {} {
+ global env
+
+ array_unset env LANG*
+ array_unset env LC_*
+ set env(LANG) C ; # Usually default if nothing is set, OS X requires this.
+
+ set paths [join [list \
+ [tcllibPath grammar_peg] \
+ [tcllibPath struct] \
+ [tcllibPath json] \
+ [tcllibPath textutil] \
+ ] \
+ [expr {$::tcl_platform(platform) eq "windows" ? ";" : ":"}]]
+
+ # Initialize the paths an import plugin manager should use when
+ # searching for an import plugin used by the code under test, and
+ # also provide the paths enabling the import plugins to find their
+ # supporting packages as well.
+
+ set env(GRAMMAR_PEG_IMPORT_PLUGINS) $paths
+
+ # Initialize the paths an export plugin manager should use when
+ # searching for an export plugin used by the code under test, and
+ # also provide the paths enabling the export plugins to find their
+ # supporting packages as well.
+
+ set env(GRAMMAR_PEG_EXPORT_PLUGINS) $paths
+
+ return
+}
+
+# -------------------------------------------------------------------------
+
+proc stripcomments {text} {
+ set pattern {[[:space:]]*\[comment[[:space:]][[:space:]]*\{[^\}]*\}[[:space:]]*\][[:space:]]*}
+ regsub -all -- $pattern $text {} text
+ return $text
+}
+
+proc striphtmlcomments {text {n {}}} {
+ set pattern {<!--.*?-->}
+ if {$n eq {}} {
+ regsub -all -- $pattern $text {} text
+ } else {
+ while {$n} {
+ regsub -- $pattern $text {} text
+ incr n -1
+ }
+ }
+ return $text
+}
+
+proc stripmanmacros {text} {
+ return [string map [list \n[pt::nroff::man_macros::contents] {}] $text]
+}
+
+proc stripnroffcomments {text {n {}}} {
+# return $text
+ set pattern "'\\\\\"\[^\n\]*\n"
+ if {$n eq {}} {
+ regsub -all -- $pattern $text {} text
+ } else {
+ while {$n} {
+ regsub -- $pattern $text {} text
+ incr n -1
+ }
+ }
+ return $text
+}
+
+# -------------------------------------------------------------------------
+
+# Validate a serialization against the tree it
+# was generated from.
+
+proc validate_serial {t serial {rootname {}}} {
+ if {$rootname == {}} {
+ set rootname [$t rootname]
+ }
+
+ # List length is multiple of 3
+ if {[llength $serial] % 3} {
+ return serial/wrong#elements
+ }
+
+ # Scan through list and built a number helper
+ # structures (arrays).
+
+ array set a {}
+ array set p {}
+ array set ch {}
+ foreach {node parent attr} $serial {
+ # Node has to exist in tree
+ if {![$t exists $node]} {
+ return node/$node/unknown
+ }
+ if {![info exists ch($node)]} {set ch($node) {}}
+ # Parent reference has to be empty or
+ # integer, == 0 %3, >=0, < length serial
+ if {$parent != {}} {
+ if {![string is integer -strict $parent]} {
+ return node/$node/parent/no-integer/$parent
+ }
+ if {$parent % 3} {
+ return node/$node/parent/not-triple/$parent
+ }
+ if {$parent < 0} {
+ return node/$node/parent/out-of-bounds/$parent
+ }
+ if {$parent >= [llength $serial]} {
+ return node/$node/parent/out-of-bounds/$parent
+ }
+ # Resolve parent index into node name, has to match
+ set parentnode [lindex $serial $parent]
+ if {![$t exists $parentnode]} {
+ return node/$node/parent/unknown/$parent/$parentnode
+ }
+ if {![string equal [$t parent $node] $parentnode]} {
+ return node/$node/parent/mismatch/$parent/$parentnode/[$t parent $node]
+ }
+ lappend ch($parentnode) $node
+ } else {
+ set p($node) {}
+ }
+ # Attr list has to be of even length.
+ if {[llength $attr] % 2} {
+ return attr/$node/wrong#elements
+ }
+ # Attr have to exist and match in all respects
+ if {![string equal \
+ [dictsort $attr] \
+ [dictsort [$t getall $node]]]} {
+ return attr/$node/mismatch
+ }
+ }
+ # Second pass, check that the children information is encoded
+ # correctly. Reconstructed data has to match originals.
+
+ foreach {node parent attr} $serial {
+ if {![string equal $ch($node) [$t children $node]]} {
+ return node/$node/children/mismatch
+ }
+ }
+
+ # Reverse check
+ # - List of nodes from the 'rootname' and check
+ # that it and all its children are present
+ # in the structure.
+
+ set ::FOO {}
+ $t walk $rootname n {walker $n}
+
+ foreach n $::FOO {
+ if {![info exists ch($n)]} {
+ return node/$n/mismatch/reachable/missing
+ }
+ }
+ if {[llength $::FOO] != [llength $serial]/3} {
+ return structure/mismatch/#nodes/multiples
+ }
+ if {[llength $::FOO] != [array size ch]} {
+ return structure/mismatch/#nodes/multiples/ii
+ }
+ return ok
+}
+
+# Callbacks for tree walking.
+# Remember the node in a global variable.
+
+proc walker {node} {
+ lappend ::FOO $node
+}
+
+proc match_tree {ta tb} {
+ match_node $ta [$ta rootname] $tb [$tb rootname]
+ return
+}
+
+proc match_node {ta a tb b} {
+ if {[dictsort [$ta getall $a]] ne [dictsort [$tb getall $b]]} {
+ return -code error "$ta/$a at $tb/$b, attribute mismatch (([dictsort [$ta getall $a]]) ne ([dictsort [$tb getall $b]]))"
+ }
+ if {[llength [$ta children $a]] != [llength [$tb children $b]]} {
+ return -code error "$ta/$a at $tb/$b, children mismatch"
+ }
+ foreach ca [$ta children $a] cb [$tb children $b] {
+ match_node $ta $ca $tb $cb
+ }
+ return
+}
+
+# -------------------------------------------------------------------------
+## Dynamically create a parser for a PE grammar stored in a string.
+## Different types:
+## - critcl -- Run through critcl tool for compilation at test time.
+## - oo
+## - container -- interpreter loaded from a container
+## - snit
+
+proc make-parser {format glabel grammar} {
+ global pcounter
+ if {![info exist pcounter]} { set pcounter 0 }
+
+ set debug 0
+ set keep 0
+
+ # should be preloaded by test suite.
+ if {[catch {
+ package present pt::pgen
+ }]} {
+ error "pt::pgen package required and not loaded. Please fix your testsuite."
+ }
+
+ # Options per format.
+ # container : -name
+ # critcl : -class -name
+ # oo : -class -name
+ # snit : -class -name
+
+ set gc GC[incr pcounter]
+ lappend cmd pt::pgen peg $grammar $format -name G
+ if {$format ne "container"} {
+ lappend cmd -class $gc
+ }
+
+ try {
+ set code [eval $cmd]
+ } trap {PT RDE SYNTAX} {e o} {
+ error [pt::util error2readable $e $grammar]
+ }
+
+ # debugging generator output
+ if {$debug} {
+ set k [expr {$keep ? [open $gc$format w] : "stdout"}]
+ puts $k "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% $format ($glabel)"
+ puts $k $code
+ puts $k "#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% $format ($glabel)"
+ if {$keep} { close $k }
+ }
+
+ # Now do format-specific post-processing of the generated code to
+ # get a proper parser object.
+
+ switch -exact -- $format {
+ container {
+ # should be preloaded by test suite.
+ if {[catch {
+ package present pt::peg::interp
+ }]} {
+ error "pt::peg::interp package required and not loaded. Please fix your testsuite."
+ }
+
+ # Instantiate container class (transient).
+ eval $code
+ # Instantiate container (transient).
+ set c [G %AUTO%]
+
+ # Instantiate PEG interpreter, and configure with grammar in container.
+ set p [pt::peg::interp %AUTO%]
+ $p use $c
+
+ # Clean up the transient pieces (container class and instance).
+ $c destroy
+ G destroy
+ }
+ snit {
+ # Instantiate the parser class.
+ # ATTENTION: We chop the last 2 lines of the code first,
+ # unwanted "package provide" and "return" commands.
+ eval [join [lrange [split $code \n] 0 end-2] \n]
+
+ # Instantiate a parser based on the class.
+ set p [$gc %AUTO%]
+ # Note: Cannot destroy class now, would destroy instance as well.
+ }
+ oo {
+ # Instantiate the parser class.
+ # ATTENTION: We chop the last 2 lines of the code first,
+ # unwanted "package provide" and "return" commands.
+ eval [join [lrange [split $code \n] 0 end-2] \n]
+
+ # Instantiate a parser based on the class.
+ set p [$gc new]
+ # Note: Cannot destroy class now, would destroy instance as well.
+ }
+ critcl {
+ # Instantiate the parser class.
+ # ATTENTION: We chop the last line of the code first,
+ # unwanted "return" command.
+ #
+ # ATTENTION: We muck with [info script] to distinguish the
+ # multiple parsers going through this file and procedure
+ # from each other. Without doing this they would all map
+ # to the same file and critcl bailing on us for code
+ # redefinition after a compile & link for that file.
+
+ set here [info script]
+ info script $gc
+
+ eval [join [lrange [split $code \n] 0 end-1] \n]
+
+ # Above invoked critcl's collection of the C fragments.
+ # We have made sure (in "pt_pgen.test" and
+ # "tests/pt_pgen.tests") that the critcl package is
+ # available (we use it in run&compile mode).
+
+ # Hidden in the execution of the command instantiating the
+ # parser is the compilation, link and load of the C
+ # pieces, via $auto_index() and [unknown].
+ set p [${gc}::${gc}_critcl]
+
+ info script $here
+ }
+ }
+
+ # Provide parser instance.
+ if {$debug} {
+ puts "P = ($p)"
+ puts "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% $format ($glabel)"
+ puts "** [join [info loaded] "\n** "]"
+ puts "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% $format ($glabel)"
+ puts %%
+ puts %%%
+ }
+ return $p
+}
+
+# -------------------------------------------------------------------------
+return
diff --git a/tcllib/modules/pt/tests/data/gr/README.txt b/tcllib/modules/pt/tests/data/gr/README.txt
new file mode 100644
index 0000000..ac2f950
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/README.txt
@@ -0,0 +1,50 @@
+This directory contains the test cases for
+ pt_pgen.test,
+via tests/pt_pgen.tests
+
+Organization:
+
+* def/<n>_<foo>
+ Primary test cases.
+
+Per primary test case FOO we have
+
+* ok-FOO
+ Test inputs which result in a sucessful parse.
+ We must have files here.
+
+* ok-FOO-res
+ Per test input file TIF in ok-FOO we have an associated result
+ file here, also named TIF, containing the output of the
+ parser, i.e. the generated AST, in raw form, on that input.
+
+* fail-FOO
+ Test inputs which result in a failed parse.
+ This directory can be empty or missing.
+ Because some expressions (X*, X?) cannot fail.
+
+ NOTE: If an expression can fail, please create test cases
+ which demonstrate this.
+
+* fail-FOO-<backend>-res
+ Per test input file TIF in fail-FOO we have an associated
+ result file here, also named TIF, containing the error thrown
+ by the parser (implemented via <backend>) on that input.
+
+Possible <backend>s are:
+
+ container Parser is the PEG interpreter. Plain Tcl,
+ possibly accelerated through C-level
+ implementations for stacks and the like.
+
+ critcl Fully C-based parser, embedded in Critcl.
+
+ oo Premade parser with a Tcl runtime using the
+ TclOO object system. Possibly accelerated
+ through C-level implementations for stacks and
+ the like.
+
+ snit Premade parser with a Tcl runtime using the
+ snit object system. Possibly accelerated
+ through C-level implementations for stacks and
+ the like.
diff --git a/tcllib/modules/pt/tests/data/gr/TODO b/tcllib/modules/pt/tests/data/gr/TODO
new file mode 100644
index 0000000..c95ad7c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/TODO
@@ -0,0 +1,36 @@
+Constructions not yet covered by the test suite ...
+
+Operator Covered Notes
+-------- ------- -----
+. dot y
+.. range y char range
+alnum y
+alpha y
+ascii y
+cl y general char class, fused char choice
+control y
+ddigit y
+digit y
+graph y
+lower y
+n nonterminal y
+printable y
+punct y
+space y
+str y fused char sequence
+t terminal y general terminal char
+upper y
+wordchar y
+xdigit y
+/ choice y
+x sequence y
+* repeat0 y kleene
++ repeat1 y pos.kleene
+? optional y
+! notahead lookahead predicate, assert non-match
+-------- ------- -----
+& ahead lookahead predicate, assert match
+-------- ------- -----
+epsilon n internal, not directly accessible
+ only indirectly through "?"
+-------- -------
diff --git a/tcllib/modules/pt/tests/data/gr/def/0_sequence b/tcllib/modules/pt/tests/data/gr/def/0_sequence
new file mode 100644
index 0000000..d57b9bf
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/0_sequence
@@ -0,0 +1,2 @@
+PEG a_pe_grammar ('a' 'b' 'c')
+END;
diff --git a/tcllib/modules/pt/tests/data/gr/def/10_kleene b/tcllib/modules/pt/tests/data/gr/def/10_kleene
new file mode 100644
index 0000000..2cbe9f6
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/10_kleene
@@ -0,0 +1,2 @@
+PEG a_pe_grammar ('a'* 'b')
+END;
diff --git a/tcllib/modules/pt/tests/data/gr/def/11_sym-kleene b/tcllib/modules/pt/tests/data/gr/def/11_sym-kleene
new file mode 100644
index 0000000..23e632e
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/11_sym-kleene
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- 'a'* 'b';
+END;
diff --git a/tcllib/modules/pt/tests/data/gr/def/12_alnum b/tcllib/modules/pt/tests/data/gr/def/12_alnum
new file mode 100644
index 0000000..4b584b2
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/12_alnum
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (<alnum>)
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/13_sym-alnum b/tcllib/modules/pt/tests/data/gr/def/13_sym-alnum
new file mode 100644
index 0000000..b1d956b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/13_sym-alnum
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- <alnum>;
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/14_alpha b/tcllib/modules/pt/tests/data/gr/def/14_alpha
new file mode 100644
index 0000000..bcc3d89
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/14_alpha
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (<alpha>)
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/15_sym-alpha b/tcllib/modules/pt/tests/data/gr/def/15_sym-alpha
new file mode 100644
index 0000000..75efad6
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/15_sym-alpha
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- <alpha>;
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/16_ascii b/tcllib/modules/pt/tests/data/gr/def/16_ascii
new file mode 100644
index 0000000..dc81758
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/16_ascii
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (<ascii>)
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/17_sym-ascii b/tcllib/modules/pt/tests/data/gr/def/17_sym-ascii
new file mode 100644
index 0000000..4e07e2f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/17_sym-ascii
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- <ascii>;
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/18_control b/tcllib/modules/pt/tests/data/gr/def/18_control
new file mode 100644
index 0000000..f27795f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/18_control
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (<control>)
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/19_sym-control b/tcllib/modules/pt/tests/data/gr/def/19_sym-control
new file mode 100644
index 0000000..7ab7d4f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/19_sym-control
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- <control>;
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/1_sym-sequence b/tcllib/modules/pt/tests/data/gr/def/1_sym-sequence
new file mode 100644
index 0000000..8455372
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/1_sym-sequence
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- 'a' 'b' 'c';
+END;
diff --git a/tcllib/modules/pt/tests/data/gr/def/20_ddigit b/tcllib/modules/pt/tests/data/gr/def/20_ddigit
new file mode 100644
index 0000000..76f7d9b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/20_ddigit
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (<ddigit>)
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/21_sym-ddigit b/tcllib/modules/pt/tests/data/gr/def/21_sym-ddigit
new file mode 100644
index 0000000..2108e85
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/21_sym-ddigit
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- <ddigit>;
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/22_digit b/tcllib/modules/pt/tests/data/gr/def/22_digit
new file mode 100644
index 0000000..dd89d04
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/22_digit
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (<digit>)
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/23_sym-digit b/tcllib/modules/pt/tests/data/gr/def/23_sym-digit
new file mode 100644
index 0000000..fb9a386
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/23_sym-digit
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- <digit>;
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/24_graph b/tcllib/modules/pt/tests/data/gr/def/24_graph
new file mode 100644
index 0000000..04ef869
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/24_graph
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (<graph>)
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/25_sym-graph b/tcllib/modules/pt/tests/data/gr/def/25_sym-graph
new file mode 100644
index 0000000..da12176
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/25_sym-graph
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- <graph>;
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/26_lower b/tcllib/modules/pt/tests/data/gr/def/26_lower
new file mode 100644
index 0000000..a999eda
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/26_lower
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (<lower>)
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/27_sym-lower b/tcllib/modules/pt/tests/data/gr/def/27_sym-lower
new file mode 100644
index 0000000..642065f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/27_sym-lower
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- <lower>;
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/28_print b/tcllib/modules/pt/tests/data/gr/def/28_print
new file mode 100644
index 0000000..6eae26e
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/28_print
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (<print>)
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/29_sym-print b/tcllib/modules/pt/tests/data/gr/def/29_sym-print
new file mode 100644
index 0000000..ba2b1a6
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/29_sym-print
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- <print>;
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/2_choice b/tcllib/modules/pt/tests/data/gr/def/2_choice
new file mode 100644
index 0000000..e712dfe
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/2_choice
@@ -0,0 +1,2 @@
+PEG a_pe_grammar ('alpha' / 'anumeric' / 'digit')
+END;
diff --git a/tcllib/modules/pt/tests/data/gr/def/30_punct b/tcllib/modules/pt/tests/data/gr/def/30_punct
new file mode 100644
index 0000000..20d28a1
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/30_punct
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (<punct>)
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/31_sym-punct b/tcllib/modules/pt/tests/data/gr/def/31_sym-punct
new file mode 100644
index 0000000..99ba959
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/31_sym-punct
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- <punct>;
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/32_space b/tcllib/modules/pt/tests/data/gr/def/32_space
new file mode 100644
index 0000000..de96b7c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/32_space
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (<space>)
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/33_sym-space b/tcllib/modules/pt/tests/data/gr/def/33_sym-space
new file mode 100644
index 0000000..49d5de7
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/33_sym-space
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- <space>;
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/34_upper b/tcllib/modules/pt/tests/data/gr/def/34_upper
new file mode 100644
index 0000000..d911035
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/34_upper
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (<upper>)
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/35_sym-upper b/tcllib/modules/pt/tests/data/gr/def/35_sym-upper
new file mode 100644
index 0000000..04273e7
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/35_sym-upper
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- <upper>;
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/36_wordchar b/tcllib/modules/pt/tests/data/gr/def/36_wordchar
new file mode 100644
index 0000000..46f9943
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/36_wordchar
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (<wordchar>)
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/37_sym-wordchar b/tcllib/modules/pt/tests/data/gr/def/37_sym-wordchar
new file mode 100644
index 0000000..754fcc8
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/37_sym-wordchar
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- <wordchar>;
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/38_xdigit b/tcllib/modules/pt/tests/data/gr/def/38_xdigit
new file mode 100644
index 0000000..f44cca5
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/38_xdigit
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (<xdigit>)
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/39_sym-xdigit b/tcllib/modules/pt/tests/data/gr/def/39_sym-xdigit
new file mode 100644
index 0000000..b9399a7
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/39_sym-xdigit
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- <xdigit>;
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/3_sym-choice b/tcllib/modules/pt/tests/data/gr/def/3_sym-choice
new file mode 100644
index 0000000..db70f63
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/3_sym-choice
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- 'alpha' / 'anumeric' / 'digit';
+END;
diff --git a/tcllib/modules/pt/tests/data/gr/def/40_dot b/tcllib/modules/pt/tests/data/gr/def/40_dot
new file mode 100644
index 0000000..8a2034f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/40_dot
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (.)
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/41_sym-dot b/tcllib/modules/pt/tests/data/gr/def/41_sym-dot
new file mode 100644
index 0000000..a71b4a4
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/41_sym-dot
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- .;
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/42_optional b/tcllib/modules/pt/tests/data/gr/def/42_optional
new file mode 100644
index 0000000..129b83a
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/42_optional
@@ -0,0 +1,2 @@
+PEG a_pe_grammar ("have"? "not")
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/43_sym-optional b/tcllib/modules/pt/tests/data/gr/def/43_sym-optional
new file mode 100644
index 0000000..dd90c65
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/43_sym-optional
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- "have"? "not";
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/44_notahead b/tcllib/modules/pt/tests/data/gr/def/44_notahead
new file mode 100644
index 0000000..129a686
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/44_notahead
@@ -0,0 +1,3 @@
+# An identifier is an alphanumeric string which is not a keyword.
+PEG a_pe_grammar (!("serial"!<alnum>) (<alpha> <alnum>+ !<alnum>))
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/45_sym-notahead b/tcllib/modules/pt/tests/data/gr/def/45_sym-notahead
new file mode 100644
index 0000000..d2f2ad5
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/45_sym-notahead
@@ -0,0 +1,4 @@
+# An identifier is an alphanumeric string which is not a keyword.
+PEG a_pe_grammar (N)
+ N <- !("serial"!<alnum>) (<alpha> <alnum>+ !<alnum>);
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/46_ahead b/tcllib/modules/pt/tests/data/gr/def/46_ahead
new file mode 100644
index 0000000..4490174
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/46_ahead
@@ -0,0 +1,2 @@
+PEG a_pe_grammar (<alpha> <alnum>+ &'=')
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/47_sym-ahead b/tcllib/modules/pt/tests/data/gr/def/47_sym-ahead
new file mode 100644
index 0000000..82c6238
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/47_sym-ahead
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- <alpha> <alnum>+ &'=';
+END; \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/def/48_ticket-4a4e443ce9 b/tcllib/modules/pt/tests/data/gr/def/48_ticket-4a4e443ce9
new file mode 100644
index 0000000..5c23253
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/48_ticket-4a4e443ce9
@@ -0,0 +1,5 @@
+PEG err (eos)
+ eos <- ex (<space>+ ex)*;
+ ex <- (!X ('x'/'z'))+ X? ;
+ X <- "x" ;
+END;
diff --git a/tcllib/modules/pt/tests/data/gr/def/4_class b/tcllib/modules/pt/tests/data/gr/def/4_class
new file mode 100644
index 0000000..e670280
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/4_class
@@ -0,0 +1,2 @@
+PEG a_pe_grammar ([axe])
+END;
diff --git a/tcllib/modules/pt/tests/data/gr/def/5_sym-class b/tcllib/modules/pt/tests/data/gr/def/5_sym-class
new file mode 100644
index 0000000..eed7927
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/5_sym-class
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- [axe];
+END;
diff --git a/tcllib/modules/pt/tests/data/gr/def/6_range b/tcllib/modules/pt/tests/data/gr/def/6_range
new file mode 100644
index 0000000..1853d13
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/6_range
@@ -0,0 +1,2 @@
+PEG a_pe_grammar ("0x" [A-F])
+END;
diff --git a/tcllib/modules/pt/tests/data/gr/def/7_sym-range b/tcllib/modules/pt/tests/data/gr/def/7_sym-range
new file mode 100644
index 0000000..3fbc0bd
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/7_sym-range
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- "0x" [A-F];
+END;
diff --git a/tcllib/modules/pt/tests/data/gr/def/8_pkleene b/tcllib/modules/pt/tests/data/gr/def/8_pkleene
new file mode 100644
index 0000000..73aa691
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/8_pkleene
@@ -0,0 +1,2 @@
+PEG a_pe_grammar ('a'+ 'b')
+END;
diff --git a/tcllib/modules/pt/tests/data/gr/def/9_sym-pkleene b/tcllib/modules/pt/tests/data/gr/def/9_sym-pkleene
new file mode 100644
index 0000000..2d1964d
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/def/9_sym-pkleene
@@ -0,0 +1,3 @@
+PEG a_pe_grammar (N)
+ N <- 'a'+ 'b';
+END;
diff --git a/tcllib/modules/pt/tests/data/gr/fail-ahead-container-res/0_notmatch b/tcllib/modules/pt/tests/data/gr/fail-ahead-container-res/0_notmatch
new file mode 100644
index 0000000..2a7e3d0
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-ahead-container-res/0_notmatch
@@ -0,0 +1 @@
+1 {pt::rde 4 {alnum {t =}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-ahead-critcl-res/0_notmatch b/tcllib/modules/pt/tests/data/gr/fail-ahead-critcl-res/0_notmatch
new file mode 100644
index 0000000..2a7e3d0
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-ahead-critcl-res/0_notmatch
@@ -0,0 +1 @@
+1 {pt::rde 4 {alnum {t =}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-ahead-oo-res/0_notmatch b/tcllib/modules/pt/tests/data/gr/fail-ahead-oo-res/0_notmatch
new file mode 100644
index 0000000..2a7e3d0
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-ahead-oo-res/0_notmatch
@@ -0,0 +1 @@
+1 {pt::rde 4 {alnum {t =}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-ahead-snit-res/0_notmatch b/tcllib/modules/pt/tests/data/gr/fail-ahead-snit-res/0_notmatch
new file mode 100644
index 0000000..2a7e3d0
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-ahead-snit-res/0_notmatch
@@ -0,0 +1 @@
+1 {pt::rde 4 {alnum {t =}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-ahead/0_notmatch b/tcllib/modules/pt/tests/data/gr/fail-ahead/0_notmatch
new file mode 100644
index 0000000..f1997f0
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-ahead/0_notmatch
@@ -0,0 +1 @@
+abba, \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-alnum-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-alnum-container-res/0_outside
new file mode 100644
index 0000000..54b275b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-alnum-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-alnum-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-alnum-critcl-res/0_outside
new file mode 100644
index 0000000..54b275b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-alnum-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-alnum-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-alnum-oo-res/0_outside
new file mode 100644
index 0000000..54b275b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-alnum-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-alnum-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-alnum-snit-res/0_outside
new file mode 100644
index 0000000..54b275b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-alnum-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-alnum/0_outside b/tcllib/modules/pt/tests/data/gr/fail-alnum/0_outside
new file mode 100644
index 0000000..851c75c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-alnum/0_outside
@@ -0,0 +1 @@
+= \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-alpha-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-alpha-container-res/0_outside
new file mode 100644
index 0000000..c70f854
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-alpha-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alpha} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-alpha-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-alpha-critcl-res/0_outside
new file mode 100644
index 0000000..c70f854
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-alpha-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alpha} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-alpha-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-alpha-oo-res/0_outside
new file mode 100644
index 0000000..c70f854
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-alpha-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alpha} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-alpha-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-alpha-snit-res/0_outside
new file mode 100644
index 0000000..c70f854
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-alpha-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alpha} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-alpha/0_outside b/tcllib/modules/pt/tests/data/gr/fail-alpha/0_outside
new file mode 100644
index 0000000..851c75c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-alpha/0_outside
@@ -0,0 +1 @@
+= \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-ascii-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-ascii-container-res/0_outside
new file mode 100644
index 0000000..50b4e98
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-ascii-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ascii} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-ascii-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-ascii-critcl-res/0_outside
new file mode 100644
index 0000000..50b4e98
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-ascii-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ascii} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-ascii-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-ascii-oo-res/0_outside
new file mode 100644
index 0000000..50b4e98
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-ascii-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ascii} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-ascii-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-ascii-snit-res/0_outside
new file mode 100644
index 0000000..50b4e98
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-ascii-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ascii} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-ascii/0_outside b/tcllib/modules/pt/tests/data/gr/fail-ascii/0_outside
new file mode 100644
index 0000000..e346472
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-ascii/0_outside
@@ -0,0 +1 @@
+ \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-container-res/0_aleph b/tcllib/modules/pt/tests/data/gr/fail-choice-container-res/0_aleph
new file mode 100644
index 0000000..1cafeb5
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-container-res/0_aleph
@@ -0,0 +1 @@
+1 {pt::rde 2 {{t p}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-container-res/1_anumber b/tcllib/modules/pt/tests/data/gr/fail-choice-container-res/1_anumber
new file mode 100644
index 0000000..f926e43
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-container-res/1_anumber
@@ -0,0 +1 @@
+1 {pt::rde 4 {{t e}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-container-res/2_digup b/tcllib/modules/pt/tests/data/gr/fail-choice-container-res/2_digup
new file mode 100644
index 0000000..c1ca109
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-container-res/2_digup
@@ -0,0 +1 @@
+1 {pt::rde 3 {{t i}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-container-res/3_other b/tcllib/modules/pt/tests/data/gr/fail-choice-container-res/3_other
new file mode 100644
index 0000000..2a250cb
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-container-res/3_other
@@ -0,0 +1 @@
+1 {pt::rde 0 {{t a} {t d}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/0_aleph b/tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/0_aleph
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/0_aleph
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/1_anumber b/tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/1_anumber
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/1_anumber
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/2_digup b/tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/2_digup
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/2_digup
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/3_other b/tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/3_other
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-critcl-res/3_other
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/0_aleph b/tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/0_aleph
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/0_aleph
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/1_anumber b/tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/1_anumber
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/1_anumber
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/2_digup b/tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/2_digup
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/2_digup
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/3_other b/tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/3_other
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-oo-res/3_other
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/0_aleph b/tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/0_aleph
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/0_aleph
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/1_anumber b/tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/1_anumber
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/1_anumber
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/2_digup b/tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/2_digup
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/2_digup
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/3_other b/tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/3_other
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice-snit-res/3_other
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice/0_aleph b/tcllib/modules/pt/tests/data/gr/fail-choice/0_aleph
new file mode 100644
index 0000000..6f39413
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice/0_aleph
@@ -0,0 +1 @@
+aleph
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice/1_anumber b/tcllib/modules/pt/tests/data/gr/fail-choice/1_anumber
new file mode 100644
index 0000000..1886ef7
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice/1_anumber
@@ -0,0 +1 @@
+anumber
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice/2_digup b/tcllib/modules/pt/tests/data/gr/fail-choice/2_digup
new file mode 100644
index 0000000..1f0b692
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice/2_digup
@@ -0,0 +1 @@
+digup
diff --git a/tcllib/modules/pt/tests/data/gr/fail-choice/3_other b/tcllib/modules/pt/tests/data/gr/fail-choice/3_other
new file mode 100644
index 0000000..e45c9c2
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-choice/3_other
@@ -0,0 +1 @@
+other
diff --git a/tcllib/modules/pt/tests/data/gr/fail-class-container-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-class-container-res/0_beta
new file mode 100644
index 0000000..dba77a0
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-class-container-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 0 {{t a} {t e} {t x}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-class-critcl-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-class-critcl-res/0_beta
new file mode 100644
index 0000000..3a3e834
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-class-critcl-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 0 {{cl axe}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-class-oo-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-class-oo-res/0_beta
new file mode 100644
index 0000000..3a3e834
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-class-oo-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 0 {{cl axe}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-class-snit-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-class-snit-res/0_beta
new file mode 100644
index 0000000..3a3e834
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-class-snit-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 0 {{cl axe}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-class/0_beta b/tcllib/modules/pt/tests/data/gr/fail-class/0_beta
new file mode 100644
index 0000000..65b2df8
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-class/0_beta
@@ -0,0 +1 @@
+beta
diff --git a/tcllib/modules/pt/tests/data/gr/fail-control-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-control-container-res/0_outside
new file mode 100644
index 0000000..51f0d4f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-control-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 control} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-control-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-control-critcl-res/0_outside
new file mode 100644
index 0000000..51f0d4f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-control-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 control} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-control-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-control-oo-res/0_outside
new file mode 100644
index 0000000..51f0d4f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-control-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 control} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-control-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-control-snit-res/0_outside
new file mode 100644
index 0000000..51f0d4f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-control-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 control} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-control/0_outside b/tcllib/modules/pt/tests/data/gr/fail-control/0_outside
new file mode 100644
index 0000000..8c7e5a6
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-control/0_outside
@@ -0,0 +1 @@
+A \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-ddigit-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-ddigit-container-res/0_outside
new file mode 100644
index 0000000..025255f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-ddigit-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ddigit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-ddigit-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-ddigit-critcl-res/0_outside
new file mode 100644
index 0000000..025255f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-ddigit-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ddigit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-ddigit-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-ddigit-oo-res/0_outside
new file mode 100644
index 0000000..025255f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-ddigit-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ddigit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-ddigit-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-ddigit-snit-res/0_outside
new file mode 100644
index 0000000..025255f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-ddigit-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ddigit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-ddigit/0_outside b/tcllib/modules/pt/tests/data/gr/fail-ddigit/0_outside
new file mode 100644
index 0000000..c137216
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-ddigit/0_outside
@@ -0,0 +1 @@
+F \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-digit-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-digit-container-res/0_outside
new file mode 100644
index 0000000..a56e9ea
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-digit-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 digit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-digit-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-digit-critcl-res/0_outside
new file mode 100644
index 0000000..a56e9ea
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-digit-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 digit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-digit-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-digit-oo-res/0_outside
new file mode 100644
index 0000000..a56e9ea
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-digit-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 digit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-digit-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-digit-snit-res/0_outside
new file mode 100644
index 0000000..a56e9ea
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-digit-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 digit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-digit/0_outside b/tcllib/modules/pt/tests/data/gr/fail-digit/0_outside
new file mode 100644
index 0000000..c137216
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-digit/0_outside
@@ -0,0 +1 @@
+F \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-dot-container-res/0_none b/tcllib/modules/pt/tests/data/gr/fail-dot-container-res/0_none
new file mode 100644
index 0000000..e479b47
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-dot-container-res/0_none
@@ -0,0 +1 @@
+1 {pt::rde 0 dot} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-dot-critcl-res/0_none b/tcllib/modules/pt/tests/data/gr/fail-dot-critcl-res/0_none
new file mode 100644
index 0000000..e479b47
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-dot-critcl-res/0_none
@@ -0,0 +1 @@
+1 {pt::rde 0 dot} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-dot-oo-res/0_none b/tcllib/modules/pt/tests/data/gr/fail-dot-oo-res/0_none
new file mode 100644
index 0000000..e479b47
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-dot-oo-res/0_none
@@ -0,0 +1 @@
+1 {pt::rde 0 dot} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-dot-snit-res/0_none b/tcllib/modules/pt/tests/data/gr/fail-dot-snit-res/0_none
new file mode 100644
index 0000000..e479b47
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-dot-snit-res/0_none
@@ -0,0 +1 @@
+1 {pt::rde 0 dot} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-dot/0_none b/tcllib/modules/pt/tests/data/gr/fail-dot/0_none
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-dot/0_none
diff --git a/tcllib/modules/pt/tests/data/gr/fail-graph-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-graph-container-res/0_outside
new file mode 100644
index 0000000..1f53f39
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-graph-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 graph} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-graph-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-graph-critcl-res/0_outside
new file mode 100644
index 0000000..1f53f39
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-graph-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 graph} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-graph-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-graph-oo-res/0_outside
new file mode 100644
index 0000000..1f53f39
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-graph-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 graph} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-graph-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-graph-snit-res/0_outside
new file mode 100644
index 0000000..1f53f39
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-graph-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 graph} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-graph/0_outside b/tcllib/modules/pt/tests/data/gr/fail-graph/0_outside
new file mode 100644
index 0000000..0519ecb
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-graph/0_outside
@@ -0,0 +1 @@
+ \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-lower-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-lower-container-res/0_outside
new file mode 100644
index 0000000..e98dc4b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-lower-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 lower} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-lower-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-lower-critcl-res/0_outside
new file mode 100644
index 0000000..e98dc4b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-lower-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 lower} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-lower-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-lower-oo-res/0_outside
new file mode 100644
index 0000000..e98dc4b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-lower-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 lower} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-lower-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-lower-snit-res/0_outside
new file mode 100644
index 0000000..e98dc4b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-lower-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 lower} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-lower/0_outside b/tcllib/modules/pt/tests/data/gr/fail-lower/0_outside
new file mode 100644
index 0000000..8c7e5a6
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-lower/0_outside
@@ -0,0 +1 @@
+A \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-notahead-container-res/0_keyword b/tcllib/modules/pt/tests/data/gr/fail-notahead-container-res/0_keyword
new file mode 100644
index 0000000..607316f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-notahead-container-res/0_keyword
@@ -0,0 +1 @@
+1 {pt::rde 6 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-notahead-critcl-res/0_keyword b/tcllib/modules/pt/tests/data/gr/fail-notahead-critcl-res/0_keyword
new file mode 100644
index 0000000..607316f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-notahead-critcl-res/0_keyword
@@ -0,0 +1 @@
+1 {pt::rde 6 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-notahead-oo-res/0_keyword b/tcllib/modules/pt/tests/data/gr/fail-notahead-oo-res/0_keyword
new file mode 100644
index 0000000..607316f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-notahead-oo-res/0_keyword
@@ -0,0 +1 @@
+1 {pt::rde 6 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-notahead-snit-res/0_keyword b/tcllib/modules/pt/tests/data/gr/fail-notahead-snit-res/0_keyword
new file mode 100644
index 0000000..607316f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-notahead-snit-res/0_keyword
@@ -0,0 +1 @@
+1 {pt::rde 6 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-notahead/0_keyword b/tcllib/modules/pt/tests/data/gr/fail-notahead/0_keyword
new file mode 100644
index 0000000..4832b68
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-notahead/0_keyword
@@ -0,0 +1 @@
+serial \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-pkleene-container-res/0_b b/tcllib/modules/pt/tests/data/gr/fail-pkleene-container-res/0_b
new file mode 100644
index 0000000..225a3ae
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-pkleene-container-res/0_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{t a}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-pkleene-critcl-res/0_b b/tcllib/modules/pt/tests/data/gr/fail-pkleene-critcl-res/0_b
new file mode 100644
index 0000000..225a3ae
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-pkleene-critcl-res/0_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{t a}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-pkleene-oo-res/0_b b/tcllib/modules/pt/tests/data/gr/fail-pkleene-oo-res/0_b
new file mode 100644
index 0000000..225a3ae
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-pkleene-oo-res/0_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{t a}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-pkleene-snit-res/0_b b/tcllib/modules/pt/tests/data/gr/fail-pkleene-snit-res/0_b
new file mode 100644
index 0000000..225a3ae
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-pkleene-snit-res/0_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{t a}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-pkleene/0_b b/tcllib/modules/pt/tests/data/gr/fail-pkleene/0_b
new file mode 100644
index 0000000..63d8dbd
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-pkleene/0_b
@@ -0,0 +1 @@
+b \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-print-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-print-container-res/0_outside
new file mode 100644
index 0000000..fd32f7c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-print-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 print} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-print-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-print-critcl-res/0_outside
new file mode 100644
index 0000000..fd32f7c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-print-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 print} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-print-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-print-oo-res/0_outside
new file mode 100644
index 0000000..fd32f7c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-print-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 print} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-print-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-print-snit-res/0_outside
new file mode 100644
index 0000000..fd32f7c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-print-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 print} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-print/0_outside b/tcllib/modules/pt/tests/data/gr/fail-print/0_outside
new file mode 100644
index 0000000..7b71c6e
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-print/0_outside
@@ -0,0 +1 @@
+ \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-punct-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-punct-container-res/0_outside
new file mode 100644
index 0000000..4e5d250
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-punct-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 punct} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-punct-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-punct-critcl-res/0_outside
new file mode 100644
index 0000000..4e5d250
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-punct-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 punct} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-punct-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-punct-oo-res/0_outside
new file mode 100644
index 0000000..4e5d250
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-punct-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 punct} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-punct-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-punct-snit-res/0_outside
new file mode 100644
index 0000000..4e5d250
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-punct-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 punct} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-punct/0_outside b/tcllib/modules/pt/tests/data/gr/fail-punct/0_outside
new file mode 100644
index 0000000..851c75c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-punct/0_outside
@@ -0,0 +1 @@
+= \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-range-container-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-range-container-res/0_beta
new file mode 100644
index 0000000..f122de2
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-range-container-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 2 {{.. A F}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-range-critcl-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-range-critcl-res/0_beta
new file mode 100644
index 0000000..f122de2
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-range-critcl-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 2 {{.. A F}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-range-oo-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-range-oo-res/0_beta
new file mode 100644
index 0000000..f122de2
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-range-oo-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 2 {{.. A F}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-range-snit-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-range-snit-res/0_beta
new file mode 100644
index 0000000..f122de2
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-range-snit-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 2 {{.. A F}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-range/0_beta b/tcllib/modules/pt/tests/data/gr/fail-range/0_beta
new file mode 100644
index 0000000..05d9281
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-range/0_beta
@@ -0,0 +1 @@
+0xbeta
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sequence-container-res/0_abe b/tcllib/modules/pt/tests/data/gr/fail-sequence-container-res/0_abe
new file mode 100644
index 0000000..04a385e
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sequence-container-res/0_abe
@@ -0,0 +1 @@
+1 {pt::rde 2 {{t c}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sequence-container-res/1_b b/tcllib/modules/pt/tests/data/gr/fail-sequence-container-res/1_b
new file mode 100644
index 0000000..225a3ae
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sequence-container-res/1_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{t a}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sequence-critcl-res/0_abe b/tcllib/modules/pt/tests/data/gr/fail-sequence-critcl-res/0_abe
new file mode 100644
index 0000000..57fff23
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sequence-critcl-res/0_abe
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str abc}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sequence-critcl-res/1_b b/tcllib/modules/pt/tests/data/gr/fail-sequence-critcl-res/1_b
new file mode 100644
index 0000000..57fff23
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sequence-critcl-res/1_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str abc}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sequence-oo-res/0_abe b/tcllib/modules/pt/tests/data/gr/fail-sequence-oo-res/0_abe
new file mode 100644
index 0000000..57fff23
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sequence-oo-res/0_abe
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str abc}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sequence-oo-res/1_b b/tcllib/modules/pt/tests/data/gr/fail-sequence-oo-res/1_b
new file mode 100644
index 0000000..57fff23
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sequence-oo-res/1_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str abc}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sequence-snit-res/0_abe b/tcllib/modules/pt/tests/data/gr/fail-sequence-snit-res/0_abe
new file mode 100644
index 0000000..57fff23
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sequence-snit-res/0_abe
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str abc}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sequence-snit-res/1_b b/tcllib/modules/pt/tests/data/gr/fail-sequence-snit-res/1_b
new file mode 100644
index 0000000..57fff23
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sequence-snit-res/1_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str abc}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sequence/0_abe b/tcllib/modules/pt/tests/data/gr/fail-sequence/0_abe
new file mode 100644
index 0000000..a6d6aed
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sequence/0_abe
@@ -0,0 +1 @@
+abe
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sequence/1_b b/tcllib/modules/pt/tests/data/gr/fail-sequence/1_b
new file mode 100644
index 0000000..63d8dbd
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sequence/1_b
@@ -0,0 +1 @@
+b \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-space-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-space-container-res/0_outside
new file mode 100644
index 0000000..84e1761
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-space-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 space} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-space-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-space-critcl-res/0_outside
new file mode 100644
index 0000000..84e1761
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-space-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 space} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-space-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-space-oo-res/0_outside
new file mode 100644
index 0000000..84e1761
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-space-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 space} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-space-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-space-snit-res/0_outside
new file mode 100644
index 0000000..84e1761
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-space-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 space} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-space/0_outside b/tcllib/modules/pt/tests/data/gr/fail-space/0_outside
new file mode 100644
index 0000000..500c070
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-space/0_outside
@@ -0,0 +1 @@
+X \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-ahead-container-res/0_notmatch b/tcllib/modules/pt/tests/data/gr/fail-sym-ahead-container-res/0_notmatch
new file mode 100644
index 0000000..2a7e3d0
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-ahead-container-res/0_notmatch
@@ -0,0 +1 @@
+1 {pt::rde 4 {alnum {t =}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-ahead-critcl-res/0_notmatch b/tcllib/modules/pt/tests/data/gr/fail-sym-ahead-critcl-res/0_notmatch
new file mode 100644
index 0000000..2a7e3d0
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-ahead-critcl-res/0_notmatch
@@ -0,0 +1 @@
+1 {pt::rde 4 {alnum {t =}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-ahead-oo-res/0_notmatch b/tcllib/modules/pt/tests/data/gr/fail-sym-ahead-oo-res/0_notmatch
new file mode 100644
index 0000000..2a7e3d0
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-ahead-oo-res/0_notmatch
@@ -0,0 +1 @@
+1 {pt::rde 4 {alnum {t =}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-ahead-snit-res/0_notmatch b/tcllib/modules/pt/tests/data/gr/fail-sym-ahead-snit-res/0_notmatch
new file mode 100644
index 0000000..2a7e3d0
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-ahead-snit-res/0_notmatch
@@ -0,0 +1 @@
+1 {pt::rde 4 {alnum {t =}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-ahead/0_notmatch b/tcllib/modules/pt/tests/data/gr/fail-sym-ahead/0_notmatch
new file mode 100644
index 0000000..f1997f0
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-ahead/0_notmatch
@@ -0,0 +1 @@
+abba, \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-alnum-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-alnum-container-res/0_outside
new file mode 100644
index 0000000..54b275b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-alnum-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-alnum-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-alnum-critcl-res/0_outside
new file mode 100644
index 0000000..54b275b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-alnum-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-alnum-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-alnum-oo-res/0_outside
new file mode 100644
index 0000000..54b275b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-alnum-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-alnum-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-alnum-snit-res/0_outside
new file mode 100644
index 0000000..54b275b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-alnum-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-alnum/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-alnum/0_outside
new file mode 100644
index 0000000..851c75c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-alnum/0_outside
@@ -0,0 +1 @@
+= \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-alpha-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-alpha-container-res/0_outside
new file mode 100644
index 0000000..c70f854
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-alpha-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alpha} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-alpha-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-alpha-critcl-res/0_outside
new file mode 100644
index 0000000..c70f854
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-alpha-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alpha} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-alpha-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-alpha-oo-res/0_outside
new file mode 100644
index 0000000..c70f854
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-alpha-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alpha} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-alpha-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-alpha-snit-res/0_outside
new file mode 100644
index 0000000..c70f854
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-alpha-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 alpha} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-alpha/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-alpha/0_outside
new file mode 100644
index 0000000..851c75c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-alpha/0_outside
@@ -0,0 +1 @@
+= \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-ascii-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-ascii-container-res/0_outside
new file mode 100644
index 0000000..50b4e98
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-ascii-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ascii} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-ascii-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-ascii-critcl-res/0_outside
new file mode 100644
index 0000000..50b4e98
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-ascii-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ascii} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-ascii-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-ascii-oo-res/0_outside
new file mode 100644
index 0000000..50b4e98
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-ascii-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ascii} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-ascii-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-ascii-snit-res/0_outside
new file mode 100644
index 0000000..50b4e98
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-ascii-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ascii} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-ascii/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-ascii/0_outside
new file mode 100644
index 0000000..e346472
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-ascii/0_outside
@@ -0,0 +1 @@
+ \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/0_aleph b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/0_aleph
new file mode 100644
index 0000000..1cafeb5
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/0_aleph
@@ -0,0 +1 @@
+1 {pt::rde 2 {{t p}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/1_anumber b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/1_anumber
new file mode 100644
index 0000000..f926e43
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/1_anumber
@@ -0,0 +1 @@
+1 {pt::rde 4 {{t e}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/2_digup b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/2_digup
new file mode 100644
index 0000000..c1ca109
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/2_digup
@@ -0,0 +1 @@
+1 {pt::rde 3 {{t i}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/3_other b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/3_other
new file mode 100644
index 0000000..2a250cb
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-container-res/3_other
@@ -0,0 +1 @@
+1 {pt::rde 0 {{t a} {t d}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/0_aleph b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/0_aleph
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/0_aleph
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/1_anumber b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/1_anumber
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/1_anumber
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/2_digup b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/2_digup
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/2_digup
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/3_other b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/3_other
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-critcl-res/3_other
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/0_aleph b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/0_aleph
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/0_aleph
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/1_anumber b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/1_anumber
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/1_anumber
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/2_digup b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/2_digup
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/2_digup
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/3_other b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/3_other
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-oo-res/3_other
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/0_aleph b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/0_aleph
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/0_aleph
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/1_anumber b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/1_anumber
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/1_anumber
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/2_digup b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/2_digup
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/2_digup
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/3_other b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/3_other
new file mode 100644
index 0000000..ff63c21
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice-snit-res/3_other
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str alpha} {str anumeric} {str digit}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice/0_aleph b/tcllib/modules/pt/tests/data/gr/fail-sym-choice/0_aleph
new file mode 100644
index 0000000..6f39413
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice/0_aleph
@@ -0,0 +1 @@
+aleph
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice/1_anumber b/tcllib/modules/pt/tests/data/gr/fail-sym-choice/1_anumber
new file mode 100644
index 0000000..1886ef7
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice/1_anumber
@@ -0,0 +1 @@
+anumber
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice/2_digup b/tcllib/modules/pt/tests/data/gr/fail-sym-choice/2_digup
new file mode 100644
index 0000000..1f0b692
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice/2_digup
@@ -0,0 +1 @@
+digup
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-choice/3_other b/tcllib/modules/pt/tests/data/gr/fail-sym-choice/3_other
new file mode 100644
index 0000000..e45c9c2
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-choice/3_other
@@ -0,0 +1 @@
+other
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-class-container-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-sym-class-container-res/0_beta
new file mode 100644
index 0000000..dba77a0
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-class-container-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 0 {{t a} {t e} {t x}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-class-critcl-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-sym-class-critcl-res/0_beta
new file mode 100644
index 0000000..3a3e834
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-class-critcl-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 0 {{cl axe}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-class-oo-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-sym-class-oo-res/0_beta
new file mode 100644
index 0000000..3a3e834
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-class-oo-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 0 {{cl axe}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-class-snit-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-sym-class-snit-res/0_beta
new file mode 100644
index 0000000..3a3e834
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-class-snit-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 0 {{cl axe}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-class/0_beta b/tcllib/modules/pt/tests/data/gr/fail-sym-class/0_beta
new file mode 100644
index 0000000..65b2df8
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-class/0_beta
@@ -0,0 +1 @@
+beta
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-control-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-control-container-res/0_outside
new file mode 100644
index 0000000..51f0d4f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-control-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 control} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-control-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-control-critcl-res/0_outside
new file mode 100644
index 0000000..51f0d4f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-control-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 control} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-control-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-control-oo-res/0_outside
new file mode 100644
index 0000000..51f0d4f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-control-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 control} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-control-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-control-snit-res/0_outside
new file mode 100644
index 0000000..51f0d4f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-control-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 control} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-control/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-control/0_outside
new file mode 100644
index 0000000..8c7e5a6
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-control/0_outside
@@ -0,0 +1 @@
+A \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-container-res/0_outside
new file mode 100644
index 0000000..025255f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ddigit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-critcl-res/0_outside
new file mode 100644
index 0000000..025255f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ddigit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-oo-res/0_outside
new file mode 100644
index 0000000..025255f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ddigit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-snit-res/0_outside
new file mode 100644
index 0000000..025255f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-ddigit-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 ddigit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-ddigit/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-ddigit/0_outside
new file mode 100644
index 0000000..c137216
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-ddigit/0_outside
@@ -0,0 +1 @@
+F \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-digit-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-digit-container-res/0_outside
new file mode 100644
index 0000000..a56e9ea
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-digit-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 digit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-digit-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-digit-critcl-res/0_outside
new file mode 100644
index 0000000..a56e9ea
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-digit-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 digit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-digit-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-digit-oo-res/0_outside
new file mode 100644
index 0000000..a56e9ea
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-digit-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 digit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-digit-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-digit-snit-res/0_outside
new file mode 100644
index 0000000..a56e9ea
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-digit-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 digit} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-digit/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-digit/0_outside
new file mode 100644
index 0000000..c137216
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-digit/0_outside
@@ -0,0 +1 @@
+F \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-dot-container-res/0_none b/tcllib/modules/pt/tests/data/gr/fail-sym-dot-container-res/0_none
new file mode 100644
index 0000000..e479b47
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-dot-container-res/0_none
@@ -0,0 +1 @@
+1 {pt::rde 0 dot} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-dot-critcl-res/0_none b/tcllib/modules/pt/tests/data/gr/fail-sym-dot-critcl-res/0_none
new file mode 100644
index 0000000..e479b47
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-dot-critcl-res/0_none
@@ -0,0 +1 @@
+1 {pt::rde 0 dot} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-dot-oo-res/0_none b/tcllib/modules/pt/tests/data/gr/fail-sym-dot-oo-res/0_none
new file mode 100644
index 0000000..e479b47
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-dot-oo-res/0_none
@@ -0,0 +1 @@
+1 {pt::rde 0 dot} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-dot-snit-res/0_none b/tcllib/modules/pt/tests/data/gr/fail-sym-dot-snit-res/0_none
new file mode 100644
index 0000000..e479b47
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-dot-snit-res/0_none
@@ -0,0 +1 @@
+1 {pt::rde 0 dot} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-dot/0_none b/tcllib/modules/pt/tests/data/gr/fail-sym-dot/0_none
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-dot/0_none
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-graph-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-graph-container-res/0_outside
new file mode 100644
index 0000000..1f53f39
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-graph-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 graph} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-graph-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-graph-critcl-res/0_outside
new file mode 100644
index 0000000..1f53f39
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-graph-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 graph} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-graph-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-graph-oo-res/0_outside
new file mode 100644
index 0000000..1f53f39
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-graph-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 graph} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-graph-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-graph-snit-res/0_outside
new file mode 100644
index 0000000..1f53f39
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-graph-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 graph} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-graph/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-graph/0_outside
new file mode 100644
index 0000000..0519ecb
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-graph/0_outside
@@ -0,0 +1 @@
+ \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-lower-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-lower-container-res/0_outside
new file mode 100644
index 0000000..e98dc4b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-lower-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 lower} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-lower-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-lower-critcl-res/0_outside
new file mode 100644
index 0000000..e98dc4b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-lower-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 lower} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-lower-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-lower-oo-res/0_outside
new file mode 100644
index 0000000..e98dc4b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-lower-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 lower} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-lower-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-lower-snit-res/0_outside
new file mode 100644
index 0000000..e98dc4b
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-lower-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 lower} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-lower/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-lower/0_outside
new file mode 100644
index 0000000..8c7e5a6
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-lower/0_outside
@@ -0,0 +1 @@
+A \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-notahead-container-res/0_keyword b/tcllib/modules/pt/tests/data/gr/fail-sym-notahead-container-res/0_keyword
new file mode 100644
index 0000000..607316f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-notahead-container-res/0_keyword
@@ -0,0 +1 @@
+1 {pt::rde 6 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-notahead-critcl-res/0_keyword b/tcllib/modules/pt/tests/data/gr/fail-sym-notahead-critcl-res/0_keyword
new file mode 100644
index 0000000..607316f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-notahead-critcl-res/0_keyword
@@ -0,0 +1 @@
+1 {pt::rde 6 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-notahead-oo-res/0_keyword b/tcllib/modules/pt/tests/data/gr/fail-sym-notahead-oo-res/0_keyword
new file mode 100644
index 0000000..607316f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-notahead-oo-res/0_keyword
@@ -0,0 +1 @@
+1 {pt::rde 6 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-notahead-snit-res/0_keyword b/tcllib/modules/pt/tests/data/gr/fail-sym-notahead-snit-res/0_keyword
new file mode 100644
index 0000000..607316f
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-notahead-snit-res/0_keyword
@@ -0,0 +1 @@
+1 {pt::rde 6 alnum} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-notahead/0_keyword b/tcllib/modules/pt/tests/data/gr/fail-sym-notahead/0_keyword
new file mode 100644
index 0000000..4832b68
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-notahead/0_keyword
@@ -0,0 +1 @@
+serial \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-container-res/0_b b/tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-container-res/0_b
new file mode 100644
index 0000000..225a3ae
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-container-res/0_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{t a}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-critcl-res/0_b b/tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-critcl-res/0_b
new file mode 100644
index 0000000..225a3ae
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-critcl-res/0_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{t a}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-oo-res/0_b b/tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-oo-res/0_b
new file mode 100644
index 0000000..225a3ae
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-oo-res/0_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{t a}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-snit-res/0_b b/tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-snit-res/0_b
new file mode 100644
index 0000000..225a3ae
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-pkleene-snit-res/0_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{t a}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-pkleene/0_b b/tcllib/modules/pt/tests/data/gr/fail-sym-pkleene/0_b
new file mode 100644
index 0000000..63d8dbd
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-pkleene/0_b
@@ -0,0 +1 @@
+b \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-print-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-print-container-res/0_outside
new file mode 100644
index 0000000..fd32f7c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-print-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 print} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-print-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-print-critcl-res/0_outside
new file mode 100644
index 0000000..fd32f7c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-print-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 print} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-print-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-print-oo-res/0_outside
new file mode 100644
index 0000000..fd32f7c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-print-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 print} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-print-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-print-snit-res/0_outside
new file mode 100644
index 0000000..fd32f7c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-print-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 print} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-print/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-print/0_outside
new file mode 100644
index 0000000..7b71c6e
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-print/0_outside
@@ -0,0 +1 @@
+ \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-punct-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-punct-container-res/0_outside
new file mode 100644
index 0000000..4e5d250
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-punct-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 punct} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-punct-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-punct-critcl-res/0_outside
new file mode 100644
index 0000000..4e5d250
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-punct-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 punct} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-punct-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-punct-oo-res/0_outside
new file mode 100644
index 0000000..4e5d250
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-punct-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 punct} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-punct-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-punct-snit-res/0_outside
new file mode 100644
index 0000000..4e5d250
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-punct-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 punct} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-punct/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-punct/0_outside
new file mode 100644
index 0000000..851c75c
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-punct/0_outside
@@ -0,0 +1 @@
+= \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-range-container-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-sym-range-container-res/0_beta
new file mode 100644
index 0000000..f122de2
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-range-container-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 2 {{.. A F}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-range-critcl-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-sym-range-critcl-res/0_beta
new file mode 100644
index 0000000..f122de2
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-range-critcl-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 2 {{.. A F}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-range-oo-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-sym-range-oo-res/0_beta
new file mode 100644
index 0000000..f122de2
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-range-oo-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 2 {{.. A F}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-range-snit-res/0_beta b/tcllib/modules/pt/tests/data/gr/fail-sym-range-snit-res/0_beta
new file mode 100644
index 0000000..f122de2
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-range-snit-res/0_beta
@@ -0,0 +1 @@
+1 {pt::rde 2 {{.. A F}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-range/0_beta b/tcllib/modules/pt/tests/data/gr/fail-sym-range/0_beta
new file mode 100644
index 0000000..05d9281
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-range/0_beta
@@ -0,0 +1 @@
+0xbeta
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-container-res/0_abe b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-container-res/0_abe
new file mode 100644
index 0000000..04a385e
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-container-res/0_abe
@@ -0,0 +1 @@
+1 {pt::rde 2 {{t c}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-container-res/1_b b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-container-res/1_b
new file mode 100644
index 0000000..225a3ae
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-container-res/1_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{t a}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-critcl-res/0_abe b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-critcl-res/0_abe
new file mode 100644
index 0000000..57fff23
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-critcl-res/0_abe
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str abc}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-critcl-res/1_b b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-critcl-res/1_b
new file mode 100644
index 0000000..57fff23
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-critcl-res/1_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str abc}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-oo-res/0_abe b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-oo-res/0_abe
new file mode 100644
index 0000000..57fff23
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-oo-res/0_abe
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str abc}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-oo-res/1_b b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-oo-res/1_b
new file mode 100644
index 0000000..57fff23
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-oo-res/1_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str abc}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-snit-res/0_abe b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-snit-res/0_abe
new file mode 100644
index 0000000..57fff23
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-snit-res/0_abe
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str abc}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-snit-res/1_b b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-snit-res/1_b
new file mode 100644
index 0000000..57fff23
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence-snit-res/1_b
@@ -0,0 +1 @@
+1 {pt::rde 0 {{str abc}}}
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-sequence/0_abe b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence/0_abe
new file mode 100644
index 0000000..a6d6aed
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence/0_abe
@@ -0,0 +1 @@
+abe
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-sequence/1_b b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence/1_b
new file mode 100644
index 0000000..63d8dbd
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-sequence/1_b
@@ -0,0 +1 @@
+b \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-space-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-space-container-res/0_outside
new file mode 100644
index 0000000..84e1761
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-space-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 space} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-space-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-space-critcl-res/0_outside
new file mode 100644
index 0000000..84e1761
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-space-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 space} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-space-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-space-oo-res/0_outside
new file mode 100644
index 0000000..84e1761
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-space-oo-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 space} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-space-snit-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-space-snit-res/0_outside
new file mode 100644
index 0000000..84e1761
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-space-snit-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 space} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-space/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-space/0_outside
new file mode 100644
index 0000000..500c070
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-space/0_outside
@@ -0,0 +1 @@
+X \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-upper-container-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-upper-container-res/0_outside
new file mode 100644
index 0000000..6e21041
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-upper-container-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 upper} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-upper-critcl-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-upper-critcl-res/0_outside
new file mode 100644
index 0000000..6e21041
--- /dev/null
+++ b/tcllib/modules/pt/tests/data/gr/fail-sym-upper-critcl-res/0_outside
@@ -0,0 +1 @@
+1 {pt::rde 0 upper} \ No newline at end of file
diff --git a/tcllib/modules/pt/tests/data/gr/fail-sym-upper-oo-res/0_outside b/tcllib/modules/pt/tests/data/gr/fail-sym-upper-oo-res/0_outside
new file mode 100644